diff --git a/LeanPool.lean b/LeanPool.lean
index aa0c8e656..24ce51333 100644
--- a/LeanPool.lean
+++ b/LeanPool.lean
@@ -1765,6 +1765,153 @@ import LeanPool.HansonWright.Probability.Moments.Cumulant
 import LeanPool.HansonWright.Probability.Moments.Exponential
 import LeanPool.HansonWright.Probability.Process.FiniteMaximum
 import LeanPool.HansonWright.Probability.Process.SubGaussian
+import LeanPool.HopfProblem
+import LeanPool.HopfProblem.CuspFibre.CuspBoundaryTopVanishing
+import LeanPool.HopfProblem.CuspFibre.CuspCentralHomology1
+import LeanPool.HopfProblem.CuspFibre.CuspCentralHomology2
+import LeanPool.HopfProblem.CuspFibre.CuspCentralHomology3
+import LeanPool.HopfProblem.CuspFibre.CuspCentralHomology4
+import LeanPool.HopfProblem.CuspFibre.CuspNegation
+import LeanPool.HopfProblem.CuspFibre.CuspPositiveRetraction
+import LeanPool.HopfProblem.CuspFibre.CuspSpecialization
+import LeanPool.HopfProblem.Elliptic.Core1
+import LeanPool.HopfProblem.Elliptic.Core2
+import LeanPool.HopfProblem.Elliptic.Core3
+import LeanPool.HopfProblem.Elliptic.Core4
+import LeanPool.HopfProblem.Elliptic.Core5
+import LeanPool.HopfProblem.Elliptic.Core6
+import LeanPool.HopfProblem.Elliptic.Core7
+import LeanPool.HopfProblem.Elliptic.Core8
+import LeanPool.HopfProblem.Foundations.CanonicalProduct
+import LeanPool.HopfProblem.Foundations.Complex
+import LeanPool.HopfProblem.Foundations.Core1
+import LeanPool.HopfProblem.Foundations.Core2
+import LeanPool.HopfProblem.Foundations.Core3
+import LeanPool.HopfProblem.Foundations.Core4
+import LeanPool.HopfProblem.Foundations.Core5
+import LeanPool.HopfProblem.Foundations.EuclideanSphere
+import LeanPool.HopfProblem.Foundations.FibreTopology
+import LeanPool.HopfProblem.Foundations.InvariantSubsetQuotient
+import LeanPool.HopfProblem.Foundations.LineBundleTransport
+import LeanPool.HopfProblem.Foundations.LocalOrbitQuotient
+import LeanPool.HopfProblem.Foundations.PeriodTorusTypeOneOne
+import LeanPool.HopfProblem.Foundations.SplitGroupExtension
+import LeanPool.HopfProblem.Foundations.TrianglePeriodFamilyHomologySplitting
+import LeanPool.HopfProblem.Foundations.TriangleRegularBaseFundamentalGroup
+import LeanPool.HopfProblem.Foundations.TwoAffineCharts
+import LeanPool.HopfProblem.Foundations.TwoOpenTransition
+import LeanPool.HopfProblem.HomologyOfX.CuspCoinvariants
+import LeanPool.HopfProblem.HomologyOfX.SmallChainBiprod
+import LeanPool.HopfProblem.HomologyOfX.ThreefoldGluing1
+import LeanPool.HopfProblem.HomologyOfX.ThreefoldGluing2
+import LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology1
+import LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology2
+import LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology3
+import LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology4
+import LeanPool.HopfProblem.HomologyOfX.ThreefoldHomologyStarCoproduct
+import LeanPool.HopfProblem.HomologyOfX.TrianglePeriodFamilyHomologyAlgebra
+import LeanPool.HopfProblem.HomologyOfX.TrianglePeriodFamilyHomologyLattice
+import LeanPool.HopfProblem.HomologyTheory.FirstHurewicz1
+import LeanPool.HopfProblem.HomologyTheory.FirstHurewicz2
+import LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+import LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import LeanPool.HopfProblem.HomologyTheory.SphereHomology1
+import LeanPool.HopfProblem.HomologyTheory.SphereHomology2
+import LeanPool.HopfProblem.HomologyTheory.SphereHomology3
+import LeanPool.HopfProblem.Hurewicz.HigherHurewicz1
+import LeanPool.HopfProblem.Hurewicz.HigherHurewicz2
+import LeanPool.HopfProblem.Hurewicz.SecondHurewicz
+import LeanPool.HopfProblem.Hurewicz.SixthHurewicz
+import LeanPool.HopfProblem.Hurewicz.ThirdHurewicz
+import LeanPool.HopfProblem.Lattice.Core1
+import LeanPool.HopfProblem.Lattice.Core2
+import LeanPool.HopfProblem.MainTheorem.Core1
+import LeanPool.HopfProblem.MainTheorem.Core2
+import LeanPool.HopfProblem.MainTheorem.Core3
+import LeanPool.HopfProblem.MainTheorem.SixSphereCube1
+import LeanPool.HopfProblem.MainTheorem.SixSphereCube2
+import LeanPool.HopfProblem.MainTheorem.SixSphereCube3
+import LeanPool.HopfProblem.PeriodFamily.Core1
+import LeanPool.HopfProblem.PeriodFamily.Core2
+import LeanPool.HopfProblem.PeriodFamily.Core3
+import LeanPool.HopfProblem.PeriodFamily.Core4
+import LeanPool.HopfProblem.PeriodFamily.Core5
+import LeanPool.HopfProblem.PeriodFamily.Core6
+import LeanPool.HopfProblem.PeriodFamily.Core7
+import LeanPool.HopfProblem.PeriodFamily.Core8
+import LeanPool.HopfProblem.PeriodFamily.Core9
+import LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap1
+import LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap2
+import LeanPool.HopfProblem.PeriodFamily.PeriodDomain
+import LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen1
+import LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen2
+import LeanPool.HopfProblem.Pi1.MappingTorus
+import LeanPool.HopfProblem.Pi1.MappingTorusHomology
+import LeanPool.HopfProblem.Pi1.ThreefoldOverlapMappingTorus1
+import LeanPool.HopfProblem.Pi1.ThreefoldOverlapMappingTorus2
+import LeanPool.HopfProblem.Pi1.TwistGroup
+import LeanPool.HopfProblem.Prelude
+import LeanPool.HopfProblem.Recognition.Degree1
+import LeanPool.HopfProblem.Recognition.Degree2
+import LeanPool.HopfProblem.Recognition.Degree3
+import LeanPool.HopfProblem.Recognition.Smale1
+import LeanPool.HopfProblem.Recognition.Smale10
+import LeanPool.HopfProblem.Recognition.Smale11
+import LeanPool.HopfProblem.Recognition.Smale12
+import LeanPool.HopfProblem.Recognition.Smale13
+import LeanPool.HopfProblem.Recognition.Smale2
+import LeanPool.HopfProblem.Recognition.Smale3
+import LeanPool.HopfProblem.Recognition.Smale4
+import LeanPool.HopfProblem.Recognition.Smale5
+import LeanPool.HopfProblem.Recognition.Smale6
+import LeanPool.HopfProblem.Recognition.Smale7
+import LeanPool.HopfProblem.Recognition.Smale8
+import LeanPool.HopfProblem.Recognition.Smale9
+import LeanPool.HopfProblem.Threefold.SixSphereComplexAtlas
+import LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import LeanPool.HopfProblem.Threefold.SpecialPeriods10
+import LeanPool.HopfProblem.Threefold.SpecialPeriods11
+import LeanPool.HopfProblem.Threefold.SpecialPeriods12
+import LeanPool.HopfProblem.Threefold.SpecialPeriods2
+import LeanPool.HopfProblem.Threefold.SpecialPeriods3
+import LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import LeanPool.HopfProblem.Threefold.SpecialPeriods5
+import LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import LeanPool.HopfProblem.Threefold.SpecialPeriods8
+import LeanPool.HopfProblem.Threefold.SpecialPeriods9
+import LeanPool.HopfProblem.Toric.CuspHoneycombHexagon
+import LeanPool.HopfProblem.Toric.DiagonalQuotient1
+import LeanPool.HopfProblem.Toric.DiagonalQuotient2
+import LeanPool.HopfProblem.Toric.DiagonalQuotient3
+import LeanPool.HopfProblem.Toric.DiagonalQuotient4
+import LeanPool.HopfProblem.Toric.ToricSpace1
+import LeanPool.HopfProblem.Toric.ToricSpace2
+import LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology3
+import LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology4
+import LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology5
+import LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology7
+import LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology8
+import LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology9
+import LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import LeanPool.HopfProblem.Uniformization.CuspUniformization2
+import LeanPool.HopfProblem.Uniformization.CuspUniformization3
+import LeanPool.HopfProblem.Uniformization.CuspUniformization4
+import LeanPool.HopfProblem.Uniformization.HolomorphicCousin
+import LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import LeanPool.HopfProblem.Uniformization.SpecialPeriods3
+import LeanPool.HopfProblem.Uniformization.SpecialPeriods4
+import LeanPool.HopfProblem.Uniformization.SpecialPeriods5
+import LeanPool.HopfProblem.Uniformization.SpecialPeriods6
+import LeanPool.HopfProblem.Uniformization.SpecialPeriods7
+import LeanPool.HopfProblem.Uniformization.SpecialPeriods8
+import LeanPool.HopfProblem.Uniformization.SpecialPeriods9
+import LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
 import LeanPool.Incompleteness
 import LeanPool.Incompleteness.Arith.D1
 import LeanPool.Incompleteness.Arith.D3
diff --git a/LeanPool/HopfProblem.lean b/LeanPool/HopfProblem.lean
new file mode 100644
index 000000000..f49204dd3
--- /dev/null
+++ b/LeanPool/HopfProblem.lean
@@ -0,0 +1,51 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+
+module
+
+public import LeanPool.HopfProblem.MainTheorem.Core3
+
+/-!
+# A complex structure on the six-sphere
+
+Source: url:https://github.com/plby/HopfProblem/tree/9ac8a456b526527837d7082ff775213ca8bc9809
+Authors: Boris Alexeev, Yury G. Kudryashov, Sebastian Kumar, The Formal Conjectures Authors
+Status: verified
+Main declarations: `Mathoverflow1973.mathoverflow_1973`
+Tags: complex-geometry, differential-topology, complex-manifolds, six-sphere, torus-fibrations
+MSC: 32Q55, 57R15
+-/
+
+/-!
+# A complex structure on the six-sphere
+
+This project formalizes the construction in Levent Alpöge's paper
+*A compact complex threefold fibred by tori over the projective line, and the six-sphere*.
+It constructs a compact complex threefold, identifies its underlying smooth manifold with the
+standard six-sphere, and transports the complex atlas to `unitSphere 6`.
+
+## Provenance
+
+The canonical source is Boris Alexeev's Apache-2.0-licensed
+[`plby/HopfProblem`](https://github.com/plby/HopfProblem) at commit
+`9ac8a456b526527837d7082ff775213ca8bc9809`. The thematic source tree was prepared in
+[upstream pull request #1](https://github.com/plby/HopfProblem/pull/1) at commit
+`bcbeff1324f22d228c9bde649532228826dab47d`. The original source states that most of its Lean
+code was written by Codex, so this import is classified as AI provenance.
+
+The mathematics follows [Alpöge's paper](https://alpo.ge/s6.pdf). The final statement was adapted
+from the Formal Conjectures rendering of MathOverflow question 1973. Complex-analysis material,
+including the Riemann mapping and Hurwitz developments, was adapted from Yury Kudryashov's
+[Mathlib pull request #33505](https://github.com/leanprover-community/mathlib4/pull/33505) at
+commit `d43061d911b1aeae0788591da437a3b115098962`. Topological material, including simple
+connectedness of spheres and path-factorization results used for van Kampen, was adapted from
+Sebastian Kumar's [Mathlib pull request #28246](https://github.com/leanprover-community/mathlib4/pull/28246)
+at commit `037ad801e1e5a5b7aa1750957c07f7769812effc`.
+
+The reused upstream material is Apache-2.0 licensed and was modified and reorganized here.
+Copyright (c) 2025, 2026 Yury Kudryashov; copyright (c) 2026 Sebastian Kumar; copyright 2025
+The Formal Conjectures Authors.
+-/
diff --git a/LeanPool/HopfProblem/CuspFibre/CuspBoundaryTopVanishing.lean b/LeanPool/HopfProblem/CuspFibre/CuspBoundaryTopVanishing.lean
new file mode 100644
index 000000000..efcba8c10
--- /dev/null
+++ b/LeanPool/HopfProblem/CuspFibre/CuspBoundaryTopVanishing.lean
@@ -0,0 +1,2227 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.PeriodFamily.Core8
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Toric.ToricSpace2
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap1
+import all LeanPool.HopfProblem.CuspFibre.CuspPositiveRetraction
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Toric.CuspHoneycombHexagon
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology7
+import all LeanPool.HopfProblem.CuspFibre.CuspCentralHomology3
+import all LeanPool.HopfProblem.CuspFibre.CuspSpecialization
+import all LeanPool.HopfProblem.HomologyOfX.CuspCoinvariants
+import all LeanPool.HopfProblem.PeriodFamily.Core2
+import all LeanPool.HopfProblem.CuspFibre.CuspCentralHomology4
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldGluing1
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology1
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen2
+import all LeanPool.HopfProblem.Elliptic.Core5
+import all LeanPool.HopfProblem.Pi1.TwistGroup
+import all LeanPool.HopfProblem.PeriodFamily.Core5
+import all LeanPool.HopfProblem.PeriodFamily.Core6
+import all LeanPool.HopfProblem.PeriodFamily.Core8
+
+/-!
+# Hopf problem: cusp fibre · cusp boundary top vanishing
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem CuspBoundaryTopVanishing.hexagon_second_eq_zero_of_baseFirstZero
+    {y : CuspHoneycombTiling.Plane} (hy : y ∈ CuspHoneycombTiling.baseCell)
+    (hzero : CuspCentralHomology.baseTorusPoint y 0 = 0) : y 1 = 0 := by
+  change ((-y 1 : ℝ) : AddCircle (1 : ℝ)) = 0 at hzero
+  obtain ⟨n, hn⟩ := (AddCircle.coe_eq_zero_iff (1 : ℝ)).mp hzero
+  have hn' : (n : ℝ) = -y 1 := by simpa only [zsmul_eq_mul, mul_one] using hn
+  have hb : |(n : ℝ)| < 1 := by
+    rw [hn', abs_neg]
+    exact (CuspHoneycombTiling.baseCell_coordinate_bound_sharp hy 1).trans_lt (by norm_num)
+  have hnlo : (-1 : ℤ) < n := by exact_mod_cast (abs_lt.mp hb).1
+  have hnhi : n < (1 : ℤ) := by exact_mod_cast (abs_lt.mp hb).2
+  have hnzero : n = 0 := by omega
+  rw [hnzero, Int.cast_zero] at hn'
+  linarith
+
+private theorem CuspBoundaryTopVanishing.baseTorusProjection_overlapPhaseHomeomorph
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) (hr1 : r < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 r))
+    (hR : ToricSpace.SmallDrift C r) (a : ℝ) (p : CuspCentralHomology.OverlapPhaseCell a) :
+    CuspCentralHomology.baseTorusProjection C r hr
+        (CuspCentralHomology.overlapPhaseHomeomorph C r hr hr1 hC hR a p :
+          CuspRetraction.QuotientCentralFibre C r) =
+      CuspCentralHomology.baseTorusPoint (p.2 : CuspHoneycombTiling.Plane) := by
+  rw [CuspCentralHomology.overlapPhaseHomeomorph_coe,
+    CuspCentralHomology.baseTorusProjection_honeycombCollapseMap]
+
+private theorem CuspBoundaryTopVanishing.baseTorusPoint_overlapPhaseHomeomorph_symm
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) (hr1 : r < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 r))
+    (hR : ToricSpace.SmallDrift C r) (a : ℝ) (q : CuspCentralHomology.overlapRegion C r hr a) :
+    CuspCentralHomology.baseTorusPoint
+        (((CuspCentralHomology.overlapPhaseHomeomorph C r hr hr1 hC hR a).symm q).2 :
+          CuspHoneycombTiling.Plane) =
+      CuspCentralHomology.baseTorusProjection C r hr
+        (q : CuspRetraction.QuotientCentralFibre C r) := by
+  have h :=
+    baseTorusProjection_overlapPhaseHomeomorph C r hr hr1 hC hR a
+      ((CuspCentralHomology.overlapPhaseHomeomorph C r hr hr1 hC hR a).symm q)
+  rw [Homeomorph.apply_symm_apply] at h
+  exact h.symm
+
+private theorem CuspBoundaryTopVanishing.overlapPhaseHomeomorph_symm_second_zero
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) (hr1 : r < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 r))
+    (hR : ToricSpace.SmallDrift C r) (a : ℝ) (q : CuspCentralHomology.overlapRegion C r hr a)
+    (hzero :
+      CuspCentralHomology.baseTorusProjection C r hr (q : CuspRetraction.QuotientCentralFibre C r)
+          0 =
+        0) :
+    (((CuspCentralHomology.overlapPhaseHomeomorph C r hr hr1 hC hR a).symm q).2 :
+          CuspHoneycombTiling.Plane)
+        1 =
+      0 := by
+  apply hexagon_second_eq_zero_of_baseFirstZero
+  · exact
+      (CuspCentralHomology.Radial.mem_baseCell_iff _).mpr
+        ((CuspCentralHomology.overlapPhaseHomeomorph C r hr hr1 hC hR a).symm q).2.2.2.le
+  · rw [baseTorusPoint_overlapPhaseHomeomorph_symm]
+    exact hzero
+
+private abbrev CuspBoundaryTopVanishing.AxisAnnulus (a : ℝ) :=
+  { x : CuspCentralHomology.Radial.Annulus a // (x : (CuspHoneycombTiling.Plane)) 1 = 0 }
+
+private def CuspBoundaryTopVanishing.axisAnnulusInclusion (a : ℝ) :
+    C(AxisAnnulus a, CuspCentralHomology.Radial.Annulus a) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private theorem
+    CuspBoundaryTopVanishing.axisAnnulus_ne_zero (a : ℝ) (ha : 0 ≤ a) (x : AxisAnnulus a) :
+    (x.1 : (CuspHoneycombTiling.Plane)) ≠ 0 :=
+  (CuspCentralHomology.Radial.cellGauge_pos_iff _).mp (ha.trans_lt x.1.2.1)
+
+private def CuspBoundaryTopVanishing.axisAnnulusDirection : (CuspHoneycombTiling.Plane) :=
+  ![0, (1 / 2 : ℝ)]
+
+@[simp]
+private theorem CuspBoundaryTopVanishing.axisAnnulusDirection_gauge :
+    CuspCentralHomology.Radial.cellGauge axisAnnulusDirection = 1 := by
+  norm_num [axisAnnulusDirection, CuspCentralHomology.Radial.cellGauge]
+
+private def
+    CuspBoundaryTopVanishing.axisAnnulusBlend (a : ℝ) (s : unitInterval) (x : AxisAnnulus a) :
+    (CuspHoneycombTiling.Plane) :=
+  (1 - (s : ℝ)) • (x.1 : (CuspHoneycombTiling.Plane)) + (s : ℝ) • axisAnnulusDirection
+
+@[simp]
+private theorem CuspBoundaryTopVanishing.axisAnnulusBlend_zero (a : ℝ) (x : AxisAnnulus a) :
+    axisAnnulusBlend a 0 x = (x.1 : (CuspHoneycombTiling.Plane)) := by simp [axisAnnulusBlend]
+
+@[simp]
+private theorem CuspBoundaryTopVanishing.axisAnnulusBlend_one (a : ℝ) (x : AxisAnnulus a) :
+    axisAnnulusBlend a 1 x = axisAnnulusDirection := by simp [axisAnnulusBlend]
+
+private theorem CuspBoundaryTopVanishing.axisAnnulusBlend_second (a : ℝ) (s : unitInterval)
+    (x : AxisAnnulus a) : axisAnnulusBlend a s x 1 = (s : ℝ) / 2 := by
+  simp [axisAnnulusBlend, axisAnnulusDirection, x.2, div_eq_mul_inv]
+
+private theorem
+    CuspBoundaryTopVanishing.axisAnnulusBlend_ne_zero (a : ℝ) (ha : 0 ≤ a) (s : unitInterval)
+    (x : AxisAnnulus a) : axisAnnulusBlend a s x ≠ 0 := by
+  intro hzero
+  have hs : (s : ℝ) = 0 := by
+    have h := congrFun hzero 1
+    rw [axisAnnulusBlend_second] at h
+    change (s : ℝ) / 2 = 0 at h
+    linarith
+  apply axisAnnulus_ne_zero a ha x
+  simpa [axisAnnulusBlend, hs] using hzero
+
+private theorem CuspBoundaryTopVanishing.axisAnnulusBlend_gauge_pos (a : ℝ) (ha : 0 ≤ a)
+    (s : unitInterval) (x : AxisAnnulus a) :
+    0 < CuspCentralHomology.Radial.cellGauge (axisAnnulusBlend a s x) :=
+  (CuspCentralHomology.Radial.cellGauge_pos_iff _).mpr (axisAnnulusBlend_ne_zero a ha s x)
+
+private theorem CuspBoundaryTopVanishing.axisAnnulusBlend_continuous (a : ℝ) :
+    Continuous (fun p : unitInterval × AxisAnnulus a => axisAnnulusBlend a p.1 p.2) := by
+  have hx :
+    Continuous (fun p : unitInterval × AxisAnnulus a => (p.2.1 : (CuspHoneycombTiling.Plane))) :=
+    continuous_subtype_val.comp (continuous_subtype_val.comp continuous_snd)
+  exact
+    ((continuous_const.sub (continuous_subtype_val.comp continuous_fst)).smul hx).add
+      ((continuous_subtype_val.comp continuous_fst).smul continuous_const)
+
+private def
+    CuspBoundaryTopVanishing.axisAnnulusRadius (a : ℝ) (s : unitInterval) (x : AxisAnnulus a) :
+    ℝ :=
+  CuspCentralHomology.Radial.radiusBlend ((a + 1) / 2) s
+    (CuspCentralHomology.Radial.cellGauge (x.1 : (CuspHoneycombTiling.Plane)))
+
+@[simp]
+private theorem CuspBoundaryTopVanishing.axisAnnulusRadius_zero (a : ℝ) (x : AxisAnnulus a) :
+    axisAnnulusRadius a 0 x =
+      CuspCentralHomology.Radial.cellGauge (x.1 : (CuspHoneycombTiling.Plane)) := by
+  simp [axisAnnulusRadius, CuspCentralHomology.Radial.radiusBlend]
+
+@[simp]
+private theorem CuspBoundaryTopVanishing.axisAnnulusRadius_one (a : ℝ) (x : AxisAnnulus a) :
+    axisAnnulusRadius a 1 x = (a + 1) / 2 := by
+  simp [axisAnnulusRadius, CuspCentralHomology.Radial.radiusBlend]
+
+private theorem
+    CuspBoundaryTopVanishing.axisAnnulusRadius_mem (a : ℝ) (ha1 : a < 1) (s : unitInterval)
+    (x : AxisAnnulus a) : axisAnnulusRadius a s x ∈ Set.Ioo a 1 :=
+  CuspCentralHomology.Radial.radiusBlend_mem (convex_Ioo a 1) ((a + 1) / 2)
+    ⟨by linarith, by linarith⟩ s _ x.1.2
+
+private theorem CuspBoundaryTopVanishing.axisAnnulusRadius_continuous (a : ℝ) :
+    Continuous (fun p : unitInterval × AxisAnnulus a => axisAnnulusRadius a p.1 p.2) := by
+  have hx :
+    Continuous (fun p : unitInterval × AxisAnnulus a => (p.2.1 : (CuspHoneycombTiling.Plane))) :=
+    continuous_subtype_val.comp (continuous_subtype_val.comp continuous_snd)
+  exact
+    ((continuous_const.sub (continuous_subtype_val.comp continuous_fst)).mul
+          (CuspCentralHomology.Radial.cellGauge_continuous.comp hx)).add
+      ((continuous_subtype_val.comp continuous_fst).mul continuous_const)
+
+private def
+    CuspBoundaryTopVanishing.axisAnnulusContractionPoint (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    CuspCentralHomology.Radial.Annulus a :=
+  ⟨((a + 1) / 2) • axisAnnulusDirection,
+    by
+    rw [CuspCentralHomology.Radial.cellGauge_smul_of_nonneg _ (by linarith : 0 ≤ (a + 1) / 2),
+      axisAnnulusDirection_gauge, mul_one]
+    constructor <;> linarith⟩
+
+@[simp]
+private theorem CuspBoundaryTopVanishing.axisAnnulusContractionPoint_coe (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) :
+    (axisAnnulusContractionPoint a ha ha1 : (CuspHoneycombTiling.Plane)) =
+      ((a + 1) / 2) • axisAnnulusDirection :=
+  rfl
+
+private theorem CuspBoundaryTopVanishing.axisAnnulusContractFormula_gauge_mo1973_29730 (a : ℝ)
+    (ha : 0 ≤ a) (ha1 : a < 1) (s : unitInterval) (x : AxisAnnulus a) :
+    CuspCentralHomology.Radial.cellGauge
+        ((axisAnnulusRadius a s x /
+            CuspCentralHomology.Radial.cellGauge (axisAnnulusBlend a s x)) •
+          axisAnnulusBlend a s x) =
+      axisAnnulusRadius a s x := by
+  have hz := axisAnnulusBlend_gauge_pos a ha s x
+  have hr := ha.trans_lt (axisAnnulusRadius_mem a ha1 s x).1
+  rw [CuspCentralHomology.Radial.cellGauge_smul_of_nonneg _ (div_nonneg hr.le hz.le),
+    div_mul_cancel₀ _ hz.ne']
+
+private def CuspBoundaryTopVanishing.axisAnnulusContract (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1)
+    (s : unitInterval) (x : AxisAnnulus a) : CuspCentralHomology.Radial.Annulus a :=
+  ⟨(axisAnnulusRadius a s x / CuspCentralHomology.Radial.cellGauge (axisAnnulusBlend a s x)) •
+      axisAnnulusBlend a s x,
+    by
+    rw [axisAnnulusContractFormula_gauge_mo1973_29730 a ha ha1 s x]
+    exact axisAnnulusRadius_mem a ha1 s x⟩
+
+@[simp]
+private theorem CuspBoundaryTopVanishing.axisAnnulusContract_coe (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1)
+    (s : unitInterval) (x : AxisAnnulus a) :
+    (axisAnnulusContract a ha ha1 s x : (CuspHoneycombTiling.Plane)) =
+      (axisAnnulusRadius a s x / CuspCentralHomology.Radial.cellGauge (axisAnnulusBlend a s x)) •
+        axisAnnulusBlend a s x :=
+  rfl
+
+private theorem CuspBoundaryTopVanishing.axisAnnulusContract_continuous (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) :
+    Continuous (fun p : unitInterval × AxisAnnulus a => axisAnnulusContract a ha ha1 p.1 p.2) :=
+  (((axisAnnulusRadius_continuous a).div
+            (CuspCentralHomology.Radial.cellGauge_continuous.comp (axisAnnulusBlend_continuous a))
+            (fun p => (axisAnnulusBlend_gauge_pos a ha p.1 p.2).ne')).smul
+        (axisAnnulusBlend_continuous a)).subtype_mk
+    _
+
+@[simp]
+private theorem CuspBoundaryTopVanishing.axisAnnulusContract_zero (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1)
+    (x : AxisAnnulus a) : axisAnnulusContract a ha ha1 0 x = x.1 := by
+  apply Subtype.ext
+  simp only [axisAnnulusContract_coe, axisAnnulusRadius_zero, axisAnnulusBlend_zero,
+    div_self (ha.trans_lt x.1.2.1).ne', one_smul]
+
+@[simp]
+private theorem CuspBoundaryTopVanishing.axisAnnulusContract_one (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1)
+    (x : AxisAnnulus a) :
+    axisAnnulusContract a ha ha1 1 x = axisAnnulusContractionPoint a ha ha1 := by
+  apply Subtype.ext
+  simp only [axisAnnulusContract_coe, axisAnnulusRadius_one, axisAnnulusBlend_one,
+    axisAnnulusDirection_gauge, div_one, axisAnnulusContractionPoint_coe]
+
+private def CuspBoundaryTopVanishing.axisAnnulusContraction (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    (axisAnnulusInclusion a).Homotopy
+      (ContinuousMap.const (AxisAnnulus a) (axisAnnulusContractionPoint a ha ha1))
+    where
+  toFun p := axisAnnulusContract a ha ha1 p.1 p.2
+  continuous_toFun := axisAnnulusContract_continuous a ha ha1
+  map_zero_left := axisAnnulusContract_zero a ha ha1
+  map_one_left := axisAnnulusContract_one a ha ha1
+
+private theorem CuspBoundaryTopVanishing.homologyLinearMap_comp_eq_zero_of_subsingleton {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] {Z : Type} [TopologicalSpace Z] (g : C(X, Z))
+    (h : C(Z, Y)) (n : ℕ) [Subsingleton (SingularMayerVietoris.SingularHomology Z n)] :
+    (SingularMayerVietoris.singularHomologyMap h n).comp
+        (SingularMayerVietoris.singularHomologyMap g n) =
+      0 := by
+  apply LinearMap.ext
+  intro a
+  change
+    SingularMayerVietoris.singularHomologyMap h n
+        (SingularMayerVietoris.singularHomologyMap g n a) =
+      0
+  rw [Subsingleton.elim (SingularMayerVietoris.singularHomologyMap g n a) 0, map_zero]
+
+private theorem
+    CuspBoundaryTopVanishing.singularHomologyMap_comp_eq_zero_of_subsingleton {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] {Z : Type} [TopologicalSpace Z] (g : C(X, Z))
+    (h : C(Z, Y)) (n : ℕ) [Subsingleton (SingularMayerVietoris.SingularHomology Z n)] :
+    SingularMayerVietoris.singularHomologyMap (h.comp g) n = 0 := by
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp]
+  exact homologyLinearMap_comp_eq_zero_of_subsingleton g h n
+
+private theorem
+    CuspBoundaryTopVanishing.singularHomologyMap_eq_zero_of_homotopic_factor {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] {Z : Type} [TopologicalSpace Z] (f : C(X, Y))
+    (g : C(X, Z)) (h : C(Z, Y)) (hfac : f.Homotopic (h.comp g)) (n : ℕ)
+    [Subsingleton (SingularMayerVietoris.SingularHomology Z n)] :
+    SingularMayerVietoris.singularHomologyMap f n = 0 := by
+  rw [PeriodTorusHigherHomology.homotopic_homologyMap hfac n]
+  exact singularHomologyMap_comp_eq_zero_of_subsingleton g h n
+
+private theorem CuspBoundaryTopVanishing.singularHomologyMap_eq_zero_of_connecting {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : C(X, Y)) (U V : Set X) (U' V' : Set Y)
+    (hfU : Set.MapsTo f U U') (hfV : Set.MapsTo f V V') (hU : IsOpen U) (hV : IsOpen V)
+    (hcover : U ∪ V = Set.univ) (hU' : IsOpen U') (hV' : IsOpen V') (hcover' : U' ∪ V' = Set.univ)
+    (n : ℕ)
+    (hinj :
+      Function.Injective (SingularMayerVietoris.connectingHomomorphism U' V' hU' hV' hcover' n))
+    (hzero :
+      SingularMayerVietoris.singularHomologyMap
+          (SingularMayerVietoris.intersectionRestriction f U V U' V' hfU hfV) n =
+        0) :
+    SingularMayerVietoris.singularHomologyMap f (n + 1) = 0 := by
+  apply LinearMap.ext
+  intro a
+  apply hinj
+  simpa only [hzero, LinearMap.zero_apply, map_zero] using
+    (SingularMayerVietoris.connectingHomomorphism_naturality_apply f U V U' V' hfU hfV hU hV
+        hcover hU' hV' hcover' n a).symm
+
+private def CuspBoundaryTopVanishing.pullbackIntersectionMap {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (U' V' : Set Y) :
+    C(((f ⁻¹' U') ∩ (f ⁻¹' V') : Set X), (U' ∩ V' : Set Y)) :=
+  SingularMayerVietoris.intersectionRestriction f (f ⁻¹' U') (f ⁻¹' V') U' V' (fun _ hx => hx)
+    (fun _ hx => hx)
+
+private theorem CuspBoundaryTopVanishing.pullback_cover {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (U' V' : Set Y) (hcover' : U' ∪ V' = Set.univ) :
+    (f ⁻¹' U') ∪ (f ⁻¹' V') = Set.univ := by rw [← Set.preimage_union, hcover', Set.preimage_univ]
+
+private theorem
+    CuspBoundaryTopVanishing.singularHomologyMap_eq_zero_of_pullback_connecting {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : C(X, Y)) (U' V' : Set Y) (hU' : IsOpen U')
+    (hV' : IsOpen V') (hcover' : U' ∪ V' = Set.univ) (n : ℕ)
+    (hinj :
+      Function.Injective (SingularMayerVietoris.connectingHomomorphism U' V' hU' hV' hcover' n))
+    (hzero : SingularMayerVietoris.singularHomologyMap (pullbackIntersectionMap f U' V') n = 0) :
+    SingularMayerVietoris.singularHomologyMap f (n + 1) = 0 :=
+  singularHomologyMap_eq_zero_of_connecting f (f ⁻¹' U') (f ⁻¹' V') U' V' (fun _ hx => hx)
+    (fun _ hx => hx) (hU'.preimage f.continuous) (hV'.preimage f.continuous)
+    (pullback_cover f U' V' hcover') hU' hV' hcover' n hinj hzero
+
+private def CuspBoundaryTopVanishing.centralH4Connecting (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha1 : a < 1) :
+    SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C ε) 4 →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (CuspCentralHomology.overlapRegion C ε hε a) 3 :=
+  SingularMayerVietoris.connectingHomomorphism (CuspCentralHomology.outerRegion C ε hε a)
+    (CuspCentralHomology.innerRegion C ε hε)
+    (CuspCentralHomology.outerRegion_isOpen C ε hε hε1 hC hR a)
+    (CuspCentralHomology.innerRegion_isOpen C ε hε hε1 hC hR)
+    (CuspCentralHomology.outerRegion_union_innerRegion C ε hε a ha1) 3
+
+private theorem
+    CuspBoundaryTopVanishing.centralH4Connecting_injective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    Function.Injective (centralH4Connecting C ε hε hε1 hC hR a ha1) := by
+  let :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology (CuspCentralHomology.outerRegion C ε hε a) 4) :=
+    CuspCentralHomology.outerRegion_homology_subsingleton C ε hε hε1 hC hR a ha ha1 1
+  let :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology (CuspCentralHomology.innerRegion C ε hε) 4) :=
+    CuspCentralHomology.innerRegion_homology_subsingleton C ε hε hε1 hC hR 1
+  exact
+    CuspCentralHomology.coverConnecting_injective_of_vanishing
+      (CuspCentralHomology.outerRegion C ε hε a) (CuspCentralHomology.innerRegion C ε hε)
+      (CuspCentralHomology.outerRegion_isOpen C ε hε hε1 hC hR a)
+      (CuspCentralHomology.innerRegion_isOpen C ε hε hε1 hC hR)
+      (CuspCentralHomology.outerRegion_union_innerRegion C ε hε a ha1) 3
+
+private def
+    CuspBoundaryTopVanishing.centralPullbackIntersectionMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) {X : Type} [TopologicalSpace X] (a : ℝ)
+    (f : C(X, CuspRetraction.QuotientCentralFibre C ε)) :
+    C(((f ⁻¹' CuspCentralHomology.outerRegion C ε hε a) ∩
+          (f ⁻¹' CuspCentralHomology.innerRegion C ε hε) :
+        Set X),
+      CuspCentralHomology.overlapRegion C ε hε a) :=
+  pullbackIntersectionMap f (CuspCentralHomology.outerRegion C ε hε a)
+    (CuspCentralHomology.innerRegion C ε hε)
+
+private theorem CuspBoundaryTopVanishing.central_homologyFourMap_eq_zero_of_intersection
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) {X : Type} [TopologicalSpace X] (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) (f : C(X, CuspRetraction.QuotientCentralFibre C ε))
+    (hzero :
+      SingularMayerVietoris.singularHomologyMap (centralPullbackIntersectionMap C ε hε a f) 3 =
+        0) :
+    SingularMayerVietoris.singularHomologyMap f 4 = 0 :=
+  singularHomologyMap_eq_zero_of_pullback_connecting f (CuspCentralHomology.outerRegion C ε hε a)
+    (CuspCentralHomology.innerRegion C ε hε)
+    (CuspCentralHomology.outerRegion_isOpen C ε hε hε1 hC hR a)
+    (CuspCentralHomology.innerRegion_isOpen C ε hε hε1 hC hR)
+    (CuspCentralHomology.outerRegion_union_innerRegion C ε hε a ha1) 3
+    (centralH4Connecting_injective C ε hε hε1 hC hR a ha ha1) hzero
+
+private theorem CuspBoundaryTopVanishing.central_homologyFourMap_eq_zero_of_homotopic_factor
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) {X : Type} [TopologicalSpace X] {Y : Type}
+    [TopologicalSpace Y] [Subsingleton (SingularMayerVietoris.SingularHomology Y 3)] (a : ℝ)
+    (ha : 0 ≤ a) (ha1 : a < 1) (f : C(X, CuspRetraction.QuotientCentralFibre C ε))
+    (g :
+      C(((f ⁻¹' CuspCentralHomology.outerRegion C ε hε a) ∩
+            (f ⁻¹' CuspCentralHomology.innerRegion C ε hε) :
+          Set X),
+        Y))
+    (k : C(Y, CuspCentralHomology.overlapRegion C ε hε a))
+    (hfactor : (centralPullbackIntersectionMap C ε hε a f).Homotopic (k.comp g)) :
+    SingularMayerVietoris.singularHomologyMap f 4 = 0 := by
+  apply central_homologyFourMap_eq_zero_of_intersection C ε hε hε1 hC hR a ha ha1 f
+  exact
+    singularHomologyMap_eq_zero_of_homotopic_factor (centralPullbackIntersectionMap C ε hε a f) g
+      k hfactor 3
+
+private theorem CuspBoundaryTopVanishing.central_homologyFourMap_eq_zero_of_phase_homotopic_factor
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) {X : Type} [TopologicalSpace X] (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) (f : C(X, CuspRetraction.QuotientCentralFibre C ε))
+    (g :
+      C(((f ⁻¹' CuspCentralHomology.outerRegion C ε hε a) ∩
+            (f ⁻¹' CuspCentralHomology.innerRegion C ε hε) :
+          Set X),
+        ToricSpace.CompactFibreTorus))
+    (k : C(ToricSpace.CompactFibreTorus, CuspCentralHomology.overlapRegion C ε hε a))
+    (hfactor : (centralPullbackIntersectionMap C ε hε a f).Homotopic (k.comp g)) :
+    SingularMayerVietoris.singularHomologyMap f 4 = 0 := by
+  let : Subsingleton (SingularMayerVietoris.SingularHomology ToricSpace.CompactFibreTorus 3) :=
+    CuspCentralHomology.compactFibreTorus_homology_subsingleton 0
+  exact
+    central_homologyFourMap_eq_zero_of_homotopic_factor C ε hε hε1 hC hR a ha ha1 f g k hfactor
+
+private theorem CuspBoundaryTopVanishing.baseFirstZero_overlap_homotopic_phase
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) (hr1 : r < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 r))
+    (hR : ToricSpace.SmallDrift C r) {X : Type} [TopologicalSpace X] (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) (f : C(X, CuspRetraction.QuotientCentralFibre C r))
+    (hzero : ∀ x, CuspCentralHomology.baseTorusProjection C r hr (f x) 0 = 0) :
+    ∃ g :
+      C(((f ⁻¹' CuspCentralHomology.outerRegion C r hr a) ∩
+            (f ⁻¹' CuspCentralHomology.innerRegion C r hr) :
+          Set X),
+        ToricSpace.CompactFibreTorus),
+      ∃ k : C(ToricSpace.CompactFibreTorus, CuspCentralHomology.overlapRegion C r hr a),
+        (centralPullbackIntersectionMap C r hr a f).Homotopic (k.comp g) := by
+  let e := CuspCentralHomology.overlapPhaseHomeomorph C r hr hr1 hC hR a
+  let i := centralPullbackIntersectionMap C r hr a f
+  let g :
+    C(((f ⁻¹' CuspCentralHomology.outerRegion C r hr a) ∩
+          (f ⁻¹' CuspCentralHomology.innerRegion C r hr) :
+        Set X),
+      ToricSpace.CompactFibreTorus) :=
+    ⟨fun x => (e.symm (i x)).1, (e.symm.continuous.comp i.continuous).fst⟩
+  let b :
+    C(((f ⁻¹' CuspCentralHomology.outerRegion C r hr a) ∩
+          (f ⁻¹' CuspCentralHomology.innerRegion C r hr) :
+        Set X),
+      AxisAnnulus a) :=
+    ⟨fun x =>
+      ⟨(e.symm (i x)).2,
+        overlapPhaseHomeomorph_symm_second_zero C r hr hr1 hC hR a (i x) (hzero x.1)⟩,
+      (e.symm.continuous.comp i.continuous).snd.subtype_mk _⟩
+  let k : C(ToricSpace.CompactFibreTorus, CuspCentralHomology.overlapRegion C r hr a) :=
+    ⟨fun z => e (z, axisAnnulusContractionPoint a ha ha1),
+      e.continuous.comp (continuous_id.prodMk continuous_const)⟩
+  refine ⟨g, k, ⟨?_⟩⟩
+  refine
+    { toFun := fun p => e (g p.2, axisAnnulusContraction a ha ha1 (p.1, b p.2))
+      continuous_toFun :=
+        e.continuous.comp
+          ((g.continuous.comp continuous_snd).prodMk
+            ((axisAnnulusContraction a ha ha1).continuous.comp
+              (continuous_fst.prodMk (b.continuous.comp continuous_snd))))
+      map_zero_left := ?_
+      map_one_left := ?_ }
+  · intro x
+    change e ((e.symm (i x)).1, axisAnnulusContract a ha ha1 0 (b x)) = i x
+    rw [axisAnnulusContract_zero]
+    exact e.apply_symm_apply (i x)
+  · intro x
+    change
+      e (g x, axisAnnulusContract a ha ha1 1 (b x)) =
+        e (g x, axisAnnulusContractionPoint a ha ha1)
+    rw [axisAnnulusContract_one]
+
+private theorem CuspBoundaryTopVanishing.central_homologyFourMap_eq_zero_of_baseFirstZero
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) (hr1 : r < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 r))
+    (hR : ToricSpace.SmallDrift C r) {X : Type} [TopologicalSpace X]
+    (f : C(X, CuspRetraction.QuotientCentralFibre C r))
+    (hzero : ∀ x, CuspCentralHomology.baseTorusProjection C r hr (f x) 0 = 0) :
+    SingularMayerVietoris.singularHomologyMap f 4 = 0 := by
+  obtain ⟨g, k, hfactor⟩ :=
+    baseFirstZero_overlap_homotopic_phase C r hr hr1 hC hR (1 / 2) (by norm_num) (by norm_num) f
+      hzero
+  exact
+    central_homologyFourMap_eq_zero_of_phase_homotopic_factor C r hr hr1 hC hR (1 / 2)
+      (by norm_num) (by norm_num) f g k hfactor
+
+private theorem
+    CuspSpecialization.expFibreAction_exponentialPoint (w : Fin 2 → ℂ) {t : ℂ} (ht : t ≠ 0)
+    (z : ComplexPlane₂) :
+    CuspRetraction.expFibreAction w (CuspUniformization.exponentialPoint t z) =
+      CuspUniformization.exponentialPoint t (w + z) := by
+  have hx := CuspUniformization.exponentialPoint_mem ht z
+  have hx' :
+    CuspRetraction.expFibreAction w (CuspUniformization.exponentialPoint t z) ∈
+      ToricSpace.openTorus := by
+    apply (ToricSpace.mem_openTorus_iff _).mpr
+    rw [CuspRetraction.time_expFibreAction, CuspUniformization.time_exponentialPoint ht]
+    exact ht
+  apply
+    CuspUniformization.torusCoordinates_injective hx'
+      (CuspUniformization.exponentialPoint_mem ht _)
+  rw [CuspRetraction.expFibreAction, ToricSpace.torusCoordinates_action _ hx,
+    CuspUniformization.torusCoordinates_exponentialPoint ht,
+    CuspUniformization.torusCoordinates_exponentialPoint ht]
+  ext i
+  fin_cases i <;>
+    simp [ToricSpace.fibreMultiplier, CuspRetraction.expFibreUnits_coe,
+      CuspUniformization.exponentialCoordinates, CuspUniformization.exponential_add]
+
+private theorem
+    CuspSpecialization.position_exponentialPoint {t : ℂ} (ht : t ≠ 0) (z : ComplexPlane₂) :
+    ToricSpace.position (CuspUniformization.exponentialPoint t z) = fun i =>
+      (-2 * Real.pi * (z i).im) / Real.log ‖t‖ := by
+  ext i
+  simp only [ToricSpace.position, CuspUniformization.time_exponentialPoint ht,
+    ToricSpace.logCoordinates, ToricSpace.logNorm,
+    CuspUniformization.torusCoordinates_exponentialPoint ht]
+  have he :
+    CuspUniformization.exponentialCoordinates t z i.castSucc =
+      CuspUniformization.exponential (z i) := by fin_cases i <;> rfl
+  rw [he, CuspUniformization.log_norm_exponential]
+
+private theorem CuspSpecialization.markedCoordinate_im (Z : Matrix (Fin 2) (Fin 2) ℂ)
+    (a β : (CuspHoneycombTiling.Plane)) (i : Fin 2) :
+    ((CuspRetraction.realToComplex a + Z *ᵥ CuspRetraction.realToComplex β) i).im =
+      (Z.map Complex.im *ᵥ β) i := by
+  fin_cases i <;> simp [Matrix.mulVec, dotProduct, Fin.sum_univ_two, Complex.mul_im, ]
+
+private theorem
+    CuspSpecialization.position_markedExponentialPoint (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (s : ℂ) (hlog : Real.log ‖CuspUniformization.exponential s‖ ≠ 0)
+    (a β : (CuspHoneycombTiling.Plane)) :
+    ToricSpace.position
+        (CuspUniformization.exponentialPoint (CuspUniformization.exponential s)
+          (CuspRetraction.realToComplex a +
+            CuspUniformization.logarithmicPeriod C s *ᵥ CuspRetraction.realToComplex β)) =
+      ToricSpace.displacement C (CuspUniformization.exponential s) β := by
+  rw [position_exponentialPoint (CuspUniformization.exponential_ne_zero s)]
+  ext i
+  rw [markedCoordinate_im]
+  apply (div_eq_iff hlog).mpr
+  have h := congrFun (CuspUniformization.imaginary_displacement C s hlog β) i
+  simpa only [Pi.smul_apply, smul_eq_mul, mul_comm] using h.symm
+
+private theorem
+    CuspSpecialization.changeTwist_markedExponentialPoint (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (s : ℂ) (hlog : Real.log ‖CuspUniformization.exponential s‖ < 0)
+    (hR :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (CuspUniformization.exponential s)) ≤
+        -Real.log ‖CuspUniformization.exponential s‖ / 4)
+    (a β : (CuspHoneycombTiling.Plane)) :
+    CuspRetraction.changeTwist C D
+        (CuspUniformization.exponentialPoint (CuspUniformization.exponential s)
+          (CuspRetraction.realToComplex a +
+            CuspUniformization.logarithmicPeriod C s *ᵥ CuspRetraction.realToComplex β)) =
+      CuspUniformization.exponentialPoint (CuspUniformization.exponential s)
+        (CuspRetraction.realToComplex a +
+          CuspUniformization.logarithmicPeriod D s *ᵥ CuspRetraction.realToComplex β) := by
+  unfold CuspRetraction.changeTwist CuspRetraction.correction
+  rw [CuspUniformization.time_exponentialPoint (CuspUniformization.exponential_ne_zero s),
+    position_markedExponentialPoint C s hlog.ne,
+    ToricSpace.inverseDisplacement_displacement C hlog hR,
+    expFibreAction_exponentialPoint _ (CuspUniformization.exponential_ne_zero s)]
+  congr 1
+  simp only [CuspUniformization.logarithmicPeriod, Matrix.add_mulVec, Matrix.sub_mulVec]
+  abel
+
+private theorem CuspBoundaryTopVanishing.baseTorusProjection_centralProject
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) (x : CuspRetraction.CentralFibre) :
+    CuspCentralHomology.baseTorusProjection C r hr (CuspCollapse.centralProject C r hr x) =
+      CuspCentralHomology.baseTorusPoint
+        ((CuspHoneycomb.honeycombHomeomorph (C 0)).symm (CuspCollapse.centralModulus x)) := by
+  obtain ⟨p, rfl⟩ := CuspHoneycomb.honeycombPolarMap_surjective (C 0) x
+  change
+    CuspCentralHomology.baseTorusProjection C r hr (CuspHoneycomb.honeycombCollapseMap C r hr p) =
+      CuspCentralHomology.baseTorusPoint
+        ((CuspHoneycomb.honeycombHomeomorph (C 0)).symm
+          (CuspCollapse.centralModulus
+            (CuspCollapse.centralPolarMap (CuspHoneycomb.phaseCoordinatesHomeomorph (C 0) p))))
+  rw [CuspCentralHomology.baseTorusProjection_honeycombCollapseMap,
+    CuspCollapse.centralModulus_centralPolarMap]
+  exact
+    congrArg CuspCentralHomology.baseTorusPoint
+      ((CuspHoneycomb.honeycombHomeomorph (C 0)).symm_apply_apply p.2).symm
+
+private theorem CuspBoundaryTopVanishing.position_modulus {x : ToricSpace.Space}
+    (hx : ToricSpace.time x ≠ 0) :
+    ToricSpace.position (ToricSpace.modulus x) = ToricSpace.position x := by
+  ext i
+  simp only [ToricSpace.position, ToricSpace.time_modulus, Complex.norm_real, Real.norm_eq_abs,
+    abs_of_nonneg (norm_nonneg _), ToricSpace.logCoordinates, ToricSpace.logNorm,
+    CuspSpecialization.torusCoordinates_modulus ((ToricSpace.mem_openTorus_iff x).mpr hx),
+    ToricCharts.coordinateModulus_apply]
+
+private theorem CuspBoundaryTopVanishing.normalizedPosition_modulus (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    {x : ToricSpace.Space} (hx : ToricSpace.time x ≠ 0) :
+    CuspControlledRetraction.normalizedPosition C₀ (ToricSpace.modulus x) =
+      CuspControlledRetraction.normalizedPosition C₀ x := by
+  simp only [CuspControlledRetraction.normalizedPosition, ToricSpace.time_modulus,
+    position_modulus hx, CuspControlledRetraction.inverseDisplacement_positiveTwist_norm]
+
+private theorem CuspBoundaryTopVanishing.baseTorusProjection_prescribedCollapse
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) (η : ℝ)
+    (x : CuspControlledRetraction.PuncturedClosedTube η) :
+    CuspCentralHomology.baseTorusProjection C r hr
+        (CuspCollapse.centralProject C r hr
+          (CuspControlledRetraction.prescribedCollapse (C 0) η x)) =
+      CuspCentralHomology.baseTorusPoint
+        (CuspControlledRetraction.normalizedPosition (C 0) (x.1 : ToricSpace.Space)) := by
+  rw [baseTorusProjection_centralProject, CuspControlledRetraction.prescribedCollapse_modulus]
+  change
+    CuspCentralHomology.baseTorusPoint
+        ((CuspHoneycomb.honeycombHomeomorph (C 0)).symm
+          (CuspHoneycomb.honeycombHomeomorph (C 0)
+            (CuspControlledRetraction.normalizedPosition (C 0)
+              (((CuspControlledRetraction.puncturedPolarHomeomorph η).symm x).2.1.1 :
+                ToricSpace.Space)))) =
+      _
+  rw [Homeomorph.symm_apply_apply,
+    CuspControlledRetraction.puncturedPolarHomeomorph_symm_positive_coe]
+  change
+    CuspCentralHomology.baseTorusPoint
+        (CuspControlledRetraction.normalizedPosition (C 0)
+          (ToricSpace.modulus (x.1 : ToricSpace.Space))) =
+      _
+  rw [normalizedPosition_modulus (C 0) x.2]
+
+private theorem CuspBoundaryTopVanishing.inverseDisplacement_positiveTwist_frozen
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (t : ℂ) :
+    ToricSpace.inverseDisplacement (CuspPositive.positiveTwist (C 0)) t =
+      ToricSpace.inverseDisplacement (CuspRetraction.frozen C) t := by
+  unfold ToricSpace.inverseDisplacement ToricSpace.displacementMatrix
+  rw [CuspPositive.driftMatrix_positiveTwist]
+  rfl
+
+private theorem CuspBoundaryTopVanishing.normalizedPosition_changeTwist_markedPoint
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (s : ℂ)
+    (hlog : Real.log ‖CuspUniformization.exponential s‖ < 0)
+    (hRC :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (CuspUniformization.exponential s)) ≤
+        -Real.log ‖CuspUniformization.exponential s‖ / 4)
+    (hR0 :
+      ToricSpace.entryNorm
+          (ToricSpace.driftMatrix (CuspRetraction.frozen C) (CuspUniformization.exponential s)) ≤
+        -Real.log ‖CuspUniformization.exponential s‖ / 4)
+    (a β : (CuspHoneycombTiling.Plane)) :
+    CuspControlledRetraction.normalizedPosition (C 0)
+        (CuspRetraction.changeTwist C (CuspRetraction.frozen C)
+          (CuspUniformization.exponentialPoint (CuspUniformization.exponential s)
+            (CuspRetraction.realToComplex a +
+              CuspUniformization.logarithmicPeriod C s *ᵥ CuspRetraction.realToComplex β))) =
+      ToricSpace.realCuspVector β := by
+  rw [CuspSpecialization.changeTwist_markedExponentialPoint C (CuspRetraction.frozen C) s hlog
+      hRC,
+    CuspControlledRetraction.normalizedPosition,
+    CuspUniformization.time_exponentialPoint (CuspUniformization.exponential_ne_zero s),
+    CuspSpecialization.position_markedExponentialPoint (CuspRetraction.frozen C) s hlog.ne,
+    inverseDisplacement_positiveTwist_frozen,
+    ToricSpace.inverseDisplacement_displacement (CuspRetraction.frozen C) hlog hR0]
+
+private def CuspBoundaryTopVanishing.markedPointPunctured (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (η : ℝ)
+    (s : ℂ) (hη : ‖CuspUniformization.exponential s‖ ≤ η) (a β : (CuspHoneycombTiling.Plane)) :
+    CuspControlledRetraction.PuncturedClosedTube η :=
+  ⟨⟨CuspUniformization.exponentialPoint (CuspUniformization.exponential s)
+        (CuspRetraction.realToComplex a +
+          CuspUniformization.logarithmicPeriod C s *ᵥ CuspRetraction.realToComplex β),
+      by
+      rw [CuspUniformization.time_exponentialPoint (CuspUniformization.exponential_ne_zero s)]
+      exact hη⟩,
+    by
+    change
+      ToricSpace.time (CuspUniformization.exponentialPoint (CuspUniformization.exponential s) _) ≠
+        0
+    rw [CuspUniformization.time_exponentialPoint (CuspUniformization.exponential_ne_zero s)]
+    exact CuspUniformization.exponential_ne_zero s⟩
+
+private theorem CuspBoundaryTopVanishing.baseTorusProjection_straightened_markedPoint
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) (η : ℝ) (s : ℂ)
+    (hη : ‖CuspUniformization.exponential s‖ ≤ η)
+    (hlog : Real.log ‖CuspUniformization.exponential s‖ < 0)
+    (hRC :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (CuspUniformization.exponential s)) ≤
+        -Real.log ‖CuspUniformization.exponential s‖ / 4)
+    (hR0 :
+      ToricSpace.entryNorm
+          (ToricSpace.driftMatrix (CuspRetraction.frozen C) (CuspUniformization.exponential s)) ≤
+        -Real.log ‖CuspUniformization.exponential s‖ / 4)
+    (a β : (CuspHoneycombTiling.Plane)) :
+    CuspCentralHomology.baseTorusProjection C r hr
+        (CuspCollapse.centralProject C r hr
+          (CuspControlledRetraction.straightenedPrescribedCollapse C η
+            (markedPointPunctured C η s hη a β))) =
+      PeriodTorusHigherHomology.coordinateProjection 2 β := by
+  rw [CuspControlledRetraction.straightenedPrescribedCollapse, Function.comp_apply,
+    baseTorusProjection_prescribedCollapse]
+  change
+    CuspCentralHomology.baseTorusPoint
+        (CuspControlledRetraction.normalizedPosition (C 0)
+          (CuspRetraction.changeTwist C (CuspRetraction.frozen C)
+            (CuspUniformization.exponentialPoint (CuspUniformization.exponential s)
+              (CuspRetraction.realToComplex a +
+                CuspUniformization.logarithmicPeriod C s *ᵥ CuspRetraction.realToComplex β)))) =
+      _
+  rw [normalizedPosition_changeTwist_markedPoint C s hlog hRC hR0,
+    CuspCentralHomology.baseTorusPoint_realCuspVector]
+
+private theorem CuspBoundaryTopVanishing.periodEquiv_split (D : SpecialPeriods.CuspFamily.Data)
+    (s : SpecialPeriods.CuspFamily.LogBase D.radius) (x : RealPlane₄) :
+    D.periods.periodEquiv s x =
+      CuspRetraction.realToComplex ![x 2, x 3] +
+        CuspUniformization.logarithmicPeriod D.correction (s : ℂ) *ᵥ
+          CuspRetraction.realToComplex ![x 0, x 1] := by
+  rw [HolomorphicPeriodMap.periodEquiv_coordinates, ← D.point_leftBlock s]
+  ext i
+  fin_cases i <;>
+      simp [SpecialPeriods.CuspFamily.Data.periods_point, PeriodPoint.leftBlock,
+        CuspRetraction.realToComplex, dotProduct, Fin.sum_univ_two] <;>
+    ring
+
+private def CuspBoundaryTopVanishing.periodLogCover (D : SpecialPeriods.CuspFamily.Data)
+    (s : SpecialPeriods.CuspFamily.LogBase D.radius) (x : RealPlane₄) :
+    CuspUniformization.LogCover D.radius :=
+  ⟨((s : ℂ), D.periods.periodEquiv s x), s.2⟩
+
+private def
+    CuspBoundaryTopVanishing.periodPointPunctured (D : SpecialPeriods.CuspFamily.Data) (η : ℝ)
+    (s : SpecialPeriods.CuspFamily.LogBase D.radius)
+    (hη : ‖CuspUniformization.exponential (s : ℂ)‖ ≤ η) (x : RealPlane₄) :
+    CuspControlledRetraction.PuncturedClosedTube η :=
+  ⟨⟨CuspUniformization.totalExponentialPoint (periodLogCover D s x),
+      by
+      rw [CuspUniformization.time_totalExponentialPoint]
+      exact hη⟩,
+    by
+    change ToricSpace.time (CuspUniformization.totalExponentialPoint (periodLogCover D s x)) ≠ 0
+    rw [CuspUniformization.time_totalExponentialPoint]
+    exact CuspUniformization.exponential_ne_zero (s : ℂ)⟩
+
+@[simp]
+private theorem
+    CuspBoundaryTopVanishing.periodPointPunctured_coe (D : SpecialPeriods.CuspFamily.Data)
+    (η : ℝ) (s : SpecialPeriods.CuspFamily.LogBase D.radius)
+    (hη : ‖CuspUniformization.exponential (s : ℂ)‖ ≤ η) (x : RealPlane₄) :
+    ((periodPointPunctured D η s hη x).1 : ToricSpace.Space) =
+      CuspUniformization.totalExponentialPoint (periodLogCover D s x) :=
+  rfl
+
+private theorem CuspBoundaryTopVanishing.periodPointPunctured_quotient
+    (D : SpecialPeriods.CuspFamily.Data) (η : ℝ) (hηr : η < D.radius)
+    (s : SpecialPeriods.CuspFamily.LogBase D.radius)
+    (hη : ‖CuspUniformization.exponential (s : ℂ)‖ ≤ η) (x : RealPlane₄) :
+    (CuspRetraction.closedQuotientMap D.correction hηr (periodPointPunctured D η s hη x).1).1 =
+      (CuspUniformization.puncturedCuspCover D.correction D.radius (periodLogCover D s x)).1 :=
+  rfl
+
+private theorem CuspBoundaryTopVanishing.periodPointPunctured_eq_markedPoint
+    (D : SpecialPeriods.CuspFamily.Data) (η : ℝ) (s : SpecialPeriods.CuspFamily.LogBase D.radius)
+    (hη : ‖CuspUniformization.exponential (s : ℂ)‖ ≤ η) (x : RealPlane₄) :
+    periodPointPunctured D η s hη x =
+      markedPointPunctured D.correction η (s : ℂ) hη ![x 2, x 3] ![x 0, x 1] := by
+  apply Subtype.ext
+  apply Subtype.ext
+  change
+    CuspUniformization.exponentialPoint (CuspUniformization.exponential (s : ℂ))
+        (D.periods.periodEquiv s x) =
+      _
+  rw [periodEquiv_split]
+  rfl
+
+private theorem CuspBoundaryTopVanishing.baseTorusProjection_straightened_periodPoint
+    (D : SpecialPeriods.CuspFamily.Data) (η : ℝ) (s : SpecialPeriods.CuspFamily.LogBase D.radius)
+    (hη : ‖CuspUniformization.exponential (s : ℂ)‖ ≤ η)
+    (hR0 :
+      ToricSpace.entryNorm
+          (ToricSpace.driftMatrix (CuspRetraction.frozen D.correction)
+            (CuspUniformization.exponential (s : ℂ))) ≤
+        -Real.log ‖CuspUniformization.exponential (s : ℂ)‖ / 4)
+    (x : RealPlane₄) :
+    CuspCentralHomology.baseTorusProjection D.correction D.radius D.radius_pos
+        (CuspCollapse.centralProject D.correction D.radius D.radius_pos
+          (CuspControlledRetraction.straightenedPrescribedCollapse D.correction η
+            (periodPointPunctured D η s hη x))) =
+      PeriodTorusHigherHomology.coordinateProjection 2 ![x 0, x 1] := by
+  rw [periodPointPunctured_eq_markedPoint]
+  exact
+    baseTorusProjection_straightened_markedPoint D.correction D.radius D.radius_pos η s hη
+      (D.logarithmic_height s) (D.logarithmic_drift s) hR0 ![x 2, x 3] ![x 0, x 1]
+
+private theorem CuspBoundaryTopVanishing.baseTorusProjection_straightened_periodPoint_of_smallDrift
+    (D : SpecialPeriods.CuspFamily.Data) (δ : ℝ)
+    (hR0 : ToricSpace.SmallDrift (CuspRetraction.frozen D.correction) δ) (η : ℝ)
+    (s : SpecialPeriods.CuspFamily.LogBase D.radius)
+    (hδ : ‖CuspUniformization.exponential (s : ℂ)‖ < δ)
+    (hη : ‖CuspUniformization.exponential (s : ℂ)‖ ≤ η) (x : RealPlane₄) :
+    CuspCentralHomology.baseTorusProjection D.correction D.radius D.radius_pos
+        (CuspCollapse.centralProject D.correction D.radius D.radius_pos
+          (CuspControlledRetraction.straightenedPrescribedCollapse D.correction η
+            (periodPointPunctured D η s hη x))) =
+      PeriodTorusHigherHomology.coordinateProjection 2 ![x 0, x 1] :=
+  baseTorusProjection_straightened_periodPoint D η s hη
+    (hR0 _ (norm_pos_iff.mpr (CuspUniformization.exponential_ne_zero _)) hδ) x
+
+private theorem
+    CuspBoundaryTopVanishing.exists_period_base_radius (D : SpecialPeriods.CuspFamily.Data) :
+    ∃ δ : ℝ,
+      0 < δ ∧
+        δ < D.radius ∧
+          δ < 1 ∧
+            ∀ (η : ℝ) (s : SpecialPeriods.CuspFamily.LogBase D.radius),
+              ‖CuspUniformization.exponential (s : ℂ)‖ < δ →
+                ∀ (hη : ‖CuspUniformization.exponential (s : ℂ)‖ ≤ η) (x : RealPlane₄),
+                  CuspCentralHomology.baseTorusProjection D.correction D.radius D.radius_pos
+                      (CuspCollapse.centralProject D.correction D.radius D.radius_pos
+                        (CuspControlledRetraction.straightenedPrescribedCollapse D.correction η
+                          (periodPointPunctured D η s hη x))) =
+                    PeriodTorusHigherHomology.coordinateProjection 2 ![x 0, x 1] := by
+  obtain ⟨δ, hδ, hδr, hδ1, _, hR0⟩ :=
+    CuspRetraction.exists_common_frozen_radius D.correction D.radius_pos
+      (fun i j => (D.holomorphic i j).continuousOn)
+  exact
+    ⟨δ, hδ, hδr, hδ1, fun η s hs hη x =>
+      baseTorusProjection_straightened_periodPoint_of_smallDrift D δ hR0 η s hs hη x⟩
+
+private abbrev
+    CuspBoundaryTopVanishingCircle.NormCircle (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r ρ : ℝ) :=
+  { q : CuspQuotient.QuotientSpace C r // ‖CuspQuotient.projection C r q‖ = ρ }
+
+private def CuspBoundaryTopVanishingCircle.normCircleIntoClosed (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r η ρ : ℝ) (hρη : ρ ≤ η) : C(NormCircle C r ρ, CuspRetraction.ClosedQuotient C r η)
+    where
+  toFun q := ⟨q.1, q.2.trans_le hρη⟩
+  continuous_toFun := continuous_subtype_val.subtype_mk _
+
+private theorem CuspBoundaryTopVanishingCircle.normCircle_projection_ne_zero
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r ρ : ℝ) (hρ : 0 < ρ) (q : NormCircle C r ρ) :
+    CuspQuotient.projection C r q ≠ 0 := by
+  apply norm_pos_iff.mp
+  rw [q.2]
+  exact hρ
+
+private def
+    CuspBoundaryTopVanishingCircle.prescribedCircleCollapse (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (η ρ : ℝ) (hρ : 0 < ρ) (hρη : ρ ≤ η) (hηr : η < r)
+    (q : NormCircle C r ρ) : CuspRetraction.QuotientCentralFibre C r :=
+  CuspControlledRetraction.prescribedActualFibreCollapse C r hr hηr
+    (CuspQuotient.projection C r q) (normCircle_projection_ne_zero C r ρ hρ q) (q.2.trans_le hρη)
+    ⟨q.1, rfl⟩
+
+private def
+    CuspBoundaryTopVanishingCircle.HasPrescribedCircleEndpoint (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (η ρ : ℝ)
+    (R : C(CuspRetraction.ClosedQuotient C r η, CuspRetraction.QuotientCentralFibre C r)) :
+    Prop :=
+  ∀ (hηr : η < r) (x : CuspControlledRetraction.PuncturedClosedTube η),
+    ‖ToricSpace.time (x.1 : ToricSpace.Space)‖ = ρ →
+      R (CuspRetraction.closedQuotientMap C hηr x.1) =
+        CuspCollapse.centralProject C r hr
+          (CuspControlledRetraction.straightenedPrescribedCollapse C η x)
+
+private theorem CuspBoundaryTopVanishingCircle.controlledRetraction_actualFibre_eq
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) (η ρ : ℝ) (hρη : ρ ≤ η) (hηr : η < r)
+    (R : C(CuspRetraction.ClosedQuotient C r η, CuspRetraction.QuotientCentralFibre C r))
+    (hEnd : HasPrescribedCircleEndpoint C r hr η ρ R) (t : ℂ) (ht : t ≠ 0) (hnorm : ‖t‖ = ρ)
+    (q : CuspControlledRetraction.ActualQuotientFibre C r t) :
+    R
+        ((CuspControlledRetraction.quotientLevelFibreHomeomorph C r η t (hnorm.trans_le hρη)).symm
+            q).1 =
+      CuspControlledRetraction.prescribedActualFibreCollapse C r hr hηr t ht (hnorm.trans_le hρη)
+        q := by
+  have he :=
+    CuspControlledRetraction.prescribedFibreCollapse_eq_of_endpoint C r hr hηr t ht R
+      (fun x hx => hEnd hηr x (hx.trans hnorm))
+  exact
+    congrFun he
+      ((CuspControlledRetraction.quotientLevelFibreHomeomorph C r η t (hnorm.trans_le hρη)).symm
+        q)
+
+private theorem CuspBoundaryTopVanishingCircle.controlledRetraction_normCircle_eq
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) (η ρ : ℝ) (hρ : 0 < ρ) (hρη : ρ ≤ η)
+    (hηr : η < r)
+    (R : C(CuspRetraction.ClosedQuotient C r η, CuspRetraction.QuotientCentralFibre C r))
+    (hEnd : HasPrescribedCircleEndpoint C r hr η ρ R) (q : NormCircle C r ρ) :
+    R (normCircleIntoClosed C r η ρ hρη q) = prescribedCircleCollapse C r hr η ρ hρ hρη hηr q :=
+  controlledRetraction_actualFibre_eq C r hr η ρ hρη hηr R hEnd (CuspQuotient.projection C r q)
+    (normCircle_projection_ne_zero C r ρ hρ q) q.2 ⟨q.1, rfl⟩
+
+private theorem CuspBoundaryTopVanishingCircle.prescribedCircleCollapse_continuous_of_endpoint
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) (η ρ : ℝ) (hρ : 0 < ρ) (hρη : ρ ≤ η)
+    (hηr : η < r)
+    (R : C(CuspRetraction.ClosedQuotient C r η, CuspRetraction.QuotientCentralFibre C r))
+    (hEnd : HasPrescribedCircleEndpoint C r hr η ρ R) :
+    Continuous (prescribedCircleCollapse C r hr η ρ hρ hρη hηr) := by
+  have he :
+    (fun q => R (normCircleIntoClosed C r η ρ hρη q)) =
+      prescribedCircleCollapse C r hr η ρ hρ hρη hηr :=
+    funext (controlledRetraction_normCircle_eq C r hr η ρ hρ hρη hηr R hEnd)
+  rw [← he]
+  exact R.continuous.comp (normCircleIntoClosed C r η ρ hρη).continuous
+
+private theorem
+    CuspBoundaryTopVanishingCircle.prescribedActualFibreCollapse_continuous_of_circle_endpoint
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) (η ρ : ℝ) (hρη : ρ ≤ η) (hηr : η < r)
+    (R : C(CuspRetraction.ClosedQuotient C r η, CuspRetraction.QuotientCentralFibre C r))
+    (hEnd : HasPrescribedCircleEndpoint C r hr η ρ R) (t : ℂ) (ht : t ≠ 0) (hnorm : ‖t‖ = ρ) :
+    Continuous
+      (CuspControlledRetraction.prescribedActualFibreCollapse C r hr hηr t ht
+        (hnorm.trans_le hρη)) := by
+  have he :
+    (fun q : CuspControlledRetraction.ActualQuotientFibre C r t =>
+        R
+          ((CuspControlledRetraction.quotientLevelFibreHomeomorph C r η t
+                  (hnorm.trans_le hρη)).symm
+              q).1) =
+      CuspControlledRetraction.prescribedActualFibreCollapse C r hr hηr t ht
+        (hnorm.trans_le hρη) :=
+    funext (controlledRetraction_actualFibre_eq C r hr η ρ hρη hηr R hEnd t ht hnorm)
+  rw [← he]
+  exact
+    (R.continuous.comp continuous_subtype_val).comp
+      (CuspControlledRetraction.quotientLevelFibreHomeomorph C r η t
+          (hnorm.trans_le hρη)).symm.continuous
+
+private theorem CuspBoundaryTopVanishingCircle.exists_controlled_circle_retraction
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {r : ℝ} (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 r)) :
+    ∃ η₀ : ℝ,
+      0 < η₀ ∧
+        η₀ < r ∧
+          η₀ < 1 ∧
+            ∀ (η : ℝ) (hη : 0 < η),
+              η ≤ η₀ →
+                ∀ (ρ : ℝ) (hρ : 0 < ρ) (hρη : ρ ≤ η),
+                  ∃ R :
+                    C(CuspRetraction.ClosedQuotient C r η,
+                      CuspRetraction.QuotientCentralFibre C r),
+                    R.comp (CuspRetraction.quotientCentralIntoClosed C r η hη.le) =
+                        ContinuousMap.id (CuspRetraction.QuotientCentralFibre C r) ∧
+                      ∃ H :
+                        (ContinuousMap.id (CuspRetraction.ClosedQuotient C r η)).HomotopyRel
+                          ((CuspRetraction.quotientCentralIntoClosed C r η hη.le).comp R)
+                          {q : CuspRetraction.ClosedQuotient C r η |
+                            CuspQuotient.projection C r q = 0},
+                        (∀ s q,
+                            ‖CuspQuotient.projection C r (H (s, q))‖ ≤
+                              ‖CuspQuotient.projection C r q‖) ∧
+                          HasPrescribedCircleEndpoint C r hr η ρ R ∧
+                            ∀ hηr : η < r,
+                              Continuous (prescribedCircleCollapse C r hr η ρ hρ hρη hηr) ∧
+                                (∀ q : NormCircle C r ρ,
+                                    R (normCircleIntoClosed C r η ρ hρη q) =
+                                      prescribedCircleCollapse C r hr η ρ hρ hρη hηr q) ∧
+                                  ∀ (t : ℂ) (ht : t ≠ 0) (hnorm : ‖t‖ = ρ),
+                                    Continuous
+                                        (CuspControlledRetraction.prescribedActualFibreCollapse C
+                                          r hr hηr t ht (hnorm.trans_le hρη)) ∧
+                                      ∀ q : CuspControlledRetraction.ActualQuotientFibre C r t,
+                                        R
+                                            ((CuspControlledRetraction.quotientLevelFibreHomeomorph
+                                                    C r η t (hnorm.trans_le hρη)).symm
+                                                q).1 =
+                                          CuspControlledRetraction.prescribedActualFibreCollapse C
+                                            r hr hηr t ht (hnorm.trans_le hρη) q := by
+  obtain ⟨η₀, hη₀, hη₀r, hη₀1, hret⟩ :=
+    CuspControlledRetraction.exists_closed_quotient_controlled_strongDeformationRetraction C hr hC
+  refine ⟨η₀, hη₀, hη₀r, hη₀1, ?_⟩
+  intro η hη hηη₀ ρ hρ hρη
+  obtain ⟨R, hR, H, hmono, hEnd⟩ := hret η hη hηη₀ ρ hρ hρη
+  refine ⟨R, hR, H, hmono, hEnd, ?_⟩
+  intro hηr
+  refine
+    ⟨prescribedCircleCollapse_continuous_of_endpoint C r hr η ρ hρ hρη hηr R hEnd,
+      controlledRetraction_normCircle_eq C r hr η ρ hρ hρη hηr R hEnd, ?_⟩
+  intro t ht hnorm
+  exact
+    ⟨prescribedActualFibreCollapse_continuous_of_circle_endpoint C r hr η ρ hρη hηr R hEnd t ht
+        hnorm,
+      controlledRetraction_actualFibre_eq C r hr η ρ hρη hηr R hEnd t ht hnorm⟩
+
+private def CuspBoundaryGammaZero.restrictedMatrix : Matrix (Fin 3) (Fin 3) ℤ :=
+  !![1, 0, 0; 1, 1, 0; 0, 0, 1]
+
+private def CuspBoundaryGammaZero.restrictedInverseMatrix : Matrix (Fin 3) (Fin 3) ℤ :=
+  !![1, 0, 0; -1, 1, 0; 0, 0, 1]
+
+@[simp]
+private theorem CuspBoundaryGammaZero.restrictedMatrix_det : restrictedMatrix.det = 1 := by decide
+
+private theorem CuspBoundaryGammaZero.restrictedInverseMatrix_mul :
+    restrictedInverseMatrix * restrictedMatrix = 1 := by decide
+
+private theorem CuspBoundaryGammaZero.restrictedMatrix_mul_inverse :
+    restrictedMatrix * restrictedInverseMatrix = 1 := by decide
+
+private def CuspBoundaryGammaZero.restrictedMonodromy :
+    PeriodTorusHigherHomology.ProductTorus 3 ≃ₜ PeriodTorusHigherHomology.ProductTorus 3 :=
+  Elliptic.HigherHomology.matrixTorusHomeomorph restrictedMatrix restrictedInverseMatrix
+    restrictedInverseMatrix_mul restrictedMatrix_mul_inverse
+
+@[simp]
+private theorem CuspBoundaryGammaZero.restrictedMonodromy_apply
+    (y : PeriodTorusHigherHomology.ProductTorus 3) :
+    restrictedMonodromy y = PeriodTorusHigherHomology.torusMatrixMap restrictedMatrix y :=
+  rfl
+
+private theorem CuspBoundaryGammaZero.restrictedMatrix_real_apply (x : Fin 3 → ℝ) :
+    restrictedMatrix.map (Int.castRingHom ℝ) *ᵥ x = ![x 0, x 0 + x 1, x 2] := by
+  ext i
+  fin_cases i <;> simp [restrictedMatrix, Matrix.mulVec, dotProduct, Fin.sum_univ_three]
+
+private theorem CuspBoundaryGammaZero.restrictedMonodromy_coordinateProjection (x : Fin 3 → ℝ) :
+    restrictedMonodromy (PeriodTorusHigherHomology.coordinateProjection 3 x) =
+      PeriodTorusHigherHomology.coordinateProjection 3 ![x 0, x 0 + x 1, x 2] := by
+  rw [restrictedMonodromy_apply, PeriodTorusHigherHomology.torusMatrixMap_coordinateProjection,
+    restrictedMatrix_real_apply]
+
+private def
+    CuspBoundaryGammaZero.fibreMap : C(PeriodTorusHigherHomology.ProductTorus 3, RealTorus₄) :=
+  PeriodFamily.GammaZero.fibreInclusion.comp
+    (PeriodFamily.GammaZero.fibreHomeomorph.symm :
+      C(PeriodTorusHigherHomology.ProductTorus 3, PeriodFamily.GammaZero.Fibre))
+
+@[simp]
+private theorem CuspBoundaryGammaZero.fibreMap_coordinateProjection (x : Fin 3 → ℝ) :
+    fibreMap (PeriodTorusHigherHomology.coordinateProjection 3 x) =
+      standardLattice.mkQ (Fin.cons 0 x) :=
+  PeriodFamily.GammaZero.fibreHomeomorph_symm_coordinateProjection x
+
+@[simp]
+private theorem
+    CuspBoundaryGammaZero.fibreMap_gamma (y : PeriodTorusHigherHomology.ProductTorus 3) :
+    PeriodFamily.GammaZero.fibreGamma (fibreMap y) = 0 :=
+  (PeriodFamily.GammaZero.fibreHomeomorph.symm y).property
+
+private theorem CuspBoundaryGammaZero.cuspRealEquiv_cons_zero (x : Fin 3 → ℝ) :
+    SpecialPeriods.CuspFamily.cuspRealEquiv 1 (Fin.cons 0 x) =
+      Fin.cons 0 ![x 0, x 0 + x 1, x 2] := by
+  ext i
+  fin_cases i <;> simp [SpecialPeriods.CuspFamily.cuspRealEquiv, add_comm] <;> rfl
+
+private theorem
+    CuspBoundaryGammaZero.fibreMap_monodromy (y : PeriodTorusHigherHomology.ProductTorus 3) :
+    fibreMap (restrictedMonodromy y) = ThreefoldOverlapMappingTorus.Cusp.monodromy (fibreMap y) :=
+  by
+  obtain ⟨x, rfl⟩ := PeriodTorusHigherHomology.coordinateProjection_surjective 3 y
+  rw [restrictedMonodromy_coordinateProjection, fibreMap_coordinateProjection,
+    fibreMap_coordinateProjection]
+  change
+    standardLattice.mkQ (Fin.cons 0 ![x 0, x 0 + x 1, x 2]) =
+      SpecialPeriods.CuspFamily.cuspTorusHomeomorph 1 (standardLattice.mkQ (Fin.cons 0 x))
+  rw [SpecialPeriods.CuspFamily.cuspTorusHomeomorph_mkQ, cuspRealEquiv_cons_zero]
+
+public
+theorem CuspBoundaryGammaZero.equivariant_zpow_mo1973_29887 {X Y : Type*}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : C(X, Y))
+    (he : ∀ x, e (f x) = g (e x)) (n : ℤ) (x : X) : e ((f ^ n) x) = (g ^ n) (e x) := by
+  have hinv (x : X) : e (f.symm x) = g.symm (e x) := by
+    apply g.injective
+    rw [← he, f.apply_symm_apply, g.apply_symm_apply]
+  induction n using Int.induction_on generalizing x with
+  | zero => simp
+  | succ n ih =>
+    simp only [zpow_add_one, Homeomorph.mul_apply]
+    rw [ih, he]
+  | pred n ih =>
+    simp only [zpow_sub_one, Homeomorph.mul_apply, Homeomorph.inv_apply]
+    rw [ih, hinv]
+
+private def
+    CuspBoundaryGammaZero.mappingTorusMap {X Y : Type*} [TopologicalSpace X] [TopologicalSpace Y]
+    (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : C(X, Y)) (he : ∀ x, e (f x) = g (e x)) :
+    C(MappingTorus.Torus f, MappingTorus.Torus g)
+    where
+  toFun :=
+    Quotient.lift (fun p : ℝ × X => MappingTorus.mk g (p.1, e p.2))
+      (by
+        rintro p q ⟨n, rfl⟩
+        change
+          MappingTorus.mk g (p.1, e p.2) = MappingTorus.mk g (p.1 + (n : ℝ), e ((f ^ (-n)) p.2))
+        rw [equivariant_zpow_mo1973_29887 f g e he]
+        exact (MappingTorus.mk_deck g n (p.1, e p.2)).symm)
+  continuous_toFun :=
+    ((MappingTorus.mk_continuous g).comp
+          (continuous_fst.prodMk (e.continuous.comp continuous_snd))).quotient_lift
+      _
+
+@[simp]
+private theorem CuspBoundaryGammaZero.mappingTorusMap_mk {X Y : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : C(X, Y)) (he : ∀ x, e (f x) = g (e x))
+    (t : ℝ) (x : X) :
+    mappingTorusMap f g e he (MappingTorus.mk f (t, x)) = MappingTorus.mk g (t, e x) :=
+  rfl
+
+@[simp]
+private theorem CuspBoundaryGammaZero.mappingTorusMap_base {X Y : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : C(X, Y)) (he : ∀ x, e (f x) = g (e x))
+    (q : MappingTorus.Torus f) :
+    MappingTorus.base g (mappingTorusMap f g e he q) = MappingTorus.base f q := by
+  obtain ⟨⟨t, x⟩, rfl⟩ := MappingTorus.mk_surjective f q
+  rfl
+
+private abbrev CuspBoundaryGammaZero.Boundary :=
+  MappingTorus.Torus restrictedMonodromy
+
+private def
+    CuspBoundaryGammaZero.boundaryMap : C(Boundary, ThreefoldOverlapMappingTorus.Cusp.Boundary) :=
+  mappingTorusMap restrictedMonodromy ThreefoldOverlapMappingTorus.Cusp.monodromy fibreMap
+    fibreMap_monodromy
+
+@[simp]
+private theorem CuspBoundaryGammaZero.boundaryMap_mk (t : ℝ)
+    (y : PeriodTorusHigherHomology.ProductTorus 3) :
+    boundaryMap (MappingTorus.mk restrictedMonodromy (t, y)) =
+      MappingTorus.mk ThreefoldOverlapMappingTorus.Cusp.monodromy (t, fibreMap y) :=
+  rfl
+
+private def CuspBoundaryTopVanishing.gammaBoundaryToPunctured (D : SpecialPeriods.CuspFamily.Data)
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) :
+    C(CuspBoundaryGammaZero.Boundary,
+      CuspUniformization.PuncturedQuotient D.correction D.radius) :=
+  (ThreefoldOverlapMappingTorus.Cusp.boundaryInclusion D h).comp CuspBoundaryGammaZero.boundaryMap
+
+private def CuspBoundaryTopVanishing.gammaBoundaryToFull (D : SpecialPeriods.CuspFamily.Data)
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) :
+    C(CuspBoundaryGammaZero.Boundary, CuspQuotient.QuotientSpace D.correction D.radius) :=
+  (⟨Subtype.val, continuous_subtype_val⟩ :
+        C(CuspUniformization.PuncturedQuotient D.correction D.radius,
+          CuspQuotient.QuotientSpace D.correction D.radius)).comp
+    (gammaBoundaryToPunctured D h)
+
+private theorem
+    CuspBoundaryTopVanishing.gammaBoundaryToPunctured_mk (D : SpecialPeriods.CuspFamily.Data)
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) (t : ℝ)
+    (x : PeriodTorusHigherHomology.ProductTorus 3) :
+    gammaBoundaryToPunctured D h
+        (MappingTorus.mk CuspBoundaryGammaZero.restrictedMonodromy (t, x)) =
+      ThreefoldOverlapMappingTorus.Cusp.boundaryCylinder D h
+        (t, CuspBoundaryGammaZero.fibreMap x) :=
+  rfl
+
+private theorem CuspBoundaryTopVanishing.gammaBoundaryToFull_realCoordinates
+    (D : SpecialPeriods.CuspFamily.Data) (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius)
+    (t : ℝ) (x : Fin 3 → ℝ) :
+    gammaBoundaryToFull D h
+        (MappingTorus.mk CuspBoundaryGammaZero.restrictedMonodromy
+          (t, PeriodTorusHigherHomology.coordinateProjection 3 x)) =
+      (CuspUniformization.puncturedCuspCover D.correction D.radius
+          ⟨((ThreefoldOverlapMappingTorus.Cusp.logPoint D.radius D.radius_pos t h : ℂ),
+              D.periods.periodEquiv
+                (ThreefoldOverlapMappingTorus.Cusp.logPoint D.radius D.radius_pos t h)
+                (Fin.cons 0 x)),
+            (ThreefoldOverlapMappingTorus.Cusp.logPoint D.radius D.radius_pos t
+                h).property⟩).val := by
+  change
+    (gammaBoundaryToPunctured D h
+          (MappingTorus.mk CuspBoundaryGammaZero.restrictedMonodromy
+            (t, PeriodTorusHigherHomology.coordinateProjection 3 x))).val =
+      _
+  rw [gammaBoundaryToPunctured_mk, CuspBoundaryGammaZero.fibreMap_coordinateProjection]
+  exact
+    congrArg Subtype.val
+      (ThreefoldOverlapMappingTorus.Cusp.boundaryCylinder_realCoordinates D h t (Fin.cons 0 x))
+
+private theorem
+    CuspBoundaryTopVanishing.logPoint_exponential_norm (D : SpecialPeriods.CuspFamily.Data)
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) (t : ℝ) :
+    ‖CuspUniformization.exponential
+          (ThreefoldOverlapMappingTorus.Cusp.logPoint D.radius D.radius_pos t h : ℂ)‖ =
+      ‖ThreefoldHomologyCuspFibre.heightParameter D h‖ := by
+  rw [ThreefoldHomologyCuspFibre.heightParameter_norm]
+  calc
+    _ =
+        Real.exp
+          (Real.log
+            ‖CuspUniformization.exponential
+                (ThreefoldOverlapMappingTorus.Cusp.logPoint D.radius D.radius_pos t h : ℂ)‖) :=
+      (Real.exp_log (norm_pos_iff.mpr (CuspUniformization.exponential_ne_zero _))).symm
+    _ = _ := by
+      rw [CuspUniformization.log_norm_exponential, ThreefoldOverlapMappingTorus.Cusp.logPoint_im]
+
+private theorem CuspBoundaryTopVanishing.gammaBoundaryToFull_projection_norm
+    (D : SpecialPeriods.CuspFamily.Data) (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius)
+    (q : CuspBoundaryGammaZero.Boundary) :
+    ‖CuspQuotient.projection D.correction D.radius (gammaBoundaryToFull D h q)‖ =
+      ‖ThreefoldHomologyCuspFibre.heightParameter D h‖ := by
+  obtain ⟨⟨t, x⟩, rfl⟩ := MappingTorus.mk_surjective CuspBoundaryGammaZero.restrictedMonodromy q
+  change
+    ‖CuspQuotient.projection D.correction D.radius
+          (gammaBoundaryToPunctured D h
+            (MappingTorus.mk CuspBoundaryGammaZero.restrictedMonodromy (t, x)))‖ =
+      _
+  rw [gammaBoundaryToPunctured_mk, ThreefoldOverlapMappingTorus.Cusp.boundaryCylinder_base]
+  exact logPoint_exponential_norm D h t
+
+private def CuspBoundaryTopVanishing.gammaBoundaryToClosed (D : SpecialPeriods.CuspFamily.Data)
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) (η : ℝ)
+    (hη : ‖ThreefoldHomologyCuspFibre.heightParameter D h‖ ≤ η) :
+    C(CuspBoundaryGammaZero.Boundary, CuspRetraction.ClosedQuotient D.correction D.radius η)
+    where
+  toFun
+    q :=
+    ⟨gammaBoundaryToFull D h q,
+      by
+      rw [gammaBoundaryToFull_projection_norm]
+      exact hη⟩
+  continuous_toFun := (gammaBoundaryToFull D h).continuous.subtype_mk _
+
+@[simp]
+private theorem
+    CuspBoundaryTopVanishing.gammaBoundaryToClosed_coe (D : SpecialPeriods.CuspFamily.Data)
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) (η : ℝ)
+    (hη : ‖ThreefoldHomologyCuspFibre.heightParameter D h‖ ≤ η)
+    (q : CuspBoundaryGammaZero.Boundary) :
+    (gammaBoundaryToClosed D h η hη q).val = gammaBoundaryToFull D h q :=
+  rfl
+
+private def
+    CuspBoundaryTopVanishing.gammaBoundaryHeightHomotopy (D : SpecialPeriods.CuspFamily.Data)
+    (h₀ h₁ : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) :
+    (gammaBoundaryToFull D h₀).Homotopy (gammaBoundaryToFull D h₁)
+    where
+  toFun
+    p :=
+    ((ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D).symm
+        (ThreefoldOverlapMappingTorus.Cusp.heightContraction D.radius h₀ (p.1, h₁),
+          CuspBoundaryGammaZero.boundaryMap p.2)).val
+  continuous_toFun :=
+    continuous_subtype_val.comp
+      ((ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D).symm.continuous.comp
+        (((ThreefoldOverlapMappingTorus.Cusp.heightContraction D.radius h₀).continuous.comp
+              (continuous_fst.prodMk continuous_const)).prodMk
+          (CuspBoundaryGammaZero.boundaryMap.continuous.comp continuous_snd)))
+  map_zero_left
+    q :=
+    congrArg
+      (fun h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius =>
+        ((ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D).symm
+            (h, CuspBoundaryGammaZero.boundaryMap q)).val)
+      ((ThreefoldOverlapMappingTorus.Cusp.heightContraction D.radius h₀).map_zero_left h₁)
+  map_one_left
+    q :=
+    congrArg
+      (fun h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius =>
+        ((ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D).symm
+            (h, CuspBoundaryGammaZero.boundaryMap q)).val)
+      ((ThreefoldOverlapMappingTorus.Cusp.heightContraction D.radius h₀).map_one_left h₁)
+
+private theorem CuspBoundaryTopVanishing.gammaBoundaryToFull_homology_eq
+    (D : SpecialPeriods.CuspFamily.Data)
+    (h₀ h₁ : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (gammaBoundaryToFull D h₀) n =
+      SingularMayerVietoris.singularHomologyMap (gammaBoundaryToFull D h₁) n :=
+  PeriodTorusHigherHomology.homotopy_homologyMap (gammaBoundaryHeightHomotopy D h₀ h₁) n
+
+private theorem CuspBoundaryTopVanishing.gammaBoundaryToFilling_eq :
+    (ThreefoldOverlapMappingTorus.boundaryToFilling Option.none).comp
+        CuspBoundaryGammaZero.boundaryMap =
+      gammaBoundaryToFull ThreefoldOverlapMappingTorus.Cusp.specialData
+        ThreefoldOverlapMappingTorus.Cusp.specialHeight := by
+  rw [ThreefoldOverlapMappingTorus.boundaryToFilling_cusp]
+  rfl
+
+private theorem CuspBoundaryTopVanishing.gammaBoundaryToClosed_realCoordinates
+    (D : SpecialPeriods.CuspFamily.Data) (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius)
+    (η : ℝ) (hη : ‖ThreefoldHomologyCuspFibre.heightParameter D h‖ ≤ η) (hηr : η < D.radius)
+    (t : ℝ) (x : Fin 3 → ℝ) :
+    gammaBoundaryToClosed D h η hη
+        (MappingTorus.mk CuspBoundaryGammaZero.restrictedMonodromy
+          (t, PeriodTorusHigherHomology.coordinateProjection 3 x)) =
+      CuspRetraction.closedQuotientMap D.correction hηr
+        (periodPointPunctured D η
+            (ThreefoldOverlapMappingTorus.Cusp.logPoint D.radius D.radius_pos t h)
+            ((logPoint_exponential_norm D h t).trans_le hη) (Fin.cons 0 x)).1 := by
+  apply Subtype.ext
+  rw [gammaBoundaryToClosed_coe, periodPointPunctured_quotient]
+  exact gammaBoundaryToFull_realCoordinates D h t x
+
+private theorem CuspBoundaryTopVanishing.retraction_gammaBoundaryToClosed_realCoordinates
+    (D : SpecialPeriods.CuspFamily.Data) (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius)
+    (η : ℝ) (hη : ‖ThreefoldHomologyCuspFibre.heightParameter D h‖ ≤ η) (hηr : η < D.radius)
+    (R :
+      C(CuspRetraction.ClosedQuotient D.correction D.radius η,
+        CuspRetraction.QuotientCentralFibre D.correction D.radius))
+    (hEnd :
+      CuspBoundaryTopVanishingCircle.HasPrescribedCircleEndpoint D.correction D.radius
+        D.radius_pos η ‖ThreefoldHomologyCuspFibre.heightParameter D h‖ R)
+    (t : ℝ) (x : Fin 3 → ℝ) :
+    R
+        (gammaBoundaryToClosed D h η hη
+          (MappingTorus.mk CuspBoundaryGammaZero.restrictedMonodromy
+            (t, PeriodTorusHigherHomology.coordinateProjection 3 x))) =
+      CuspCollapse.centralProject D.correction D.radius D.radius_pos
+        (CuspControlledRetraction.straightenedPrescribedCollapse D.correction η
+          (periodPointPunctured D η
+            (ThreefoldOverlapMappingTorus.Cusp.logPoint D.radius D.radius_pos t h)
+            ((logPoint_exponential_norm D h t).trans_le hη) (Fin.cons 0 x))) := by
+  rw [gammaBoundaryToClosed_realCoordinates D h η hη hηr]
+  apply hEnd hηr
+  rw [periodPointPunctured_coe, CuspUniformization.time_totalExponentialPoint]
+  exact logPoint_exponential_norm D h t
+
+private theorem CuspBoundaryTopVanishing.retraction_gammaBoundary_base_zero
+    (D : SpecialPeriods.CuspFamily.Data) (δ : ℝ)
+    (hbase :
+      ∀ (η : ℝ) (s : SpecialPeriods.CuspFamily.LogBase D.radius),
+        ‖CuspUniformization.exponential (s : ℂ)‖ < δ →
+          ∀ (hη : ‖CuspUniformization.exponential (s : ℂ)‖ ≤ η) (x : RealPlane₄),
+            CuspCentralHomology.baseTorusProjection D.correction D.radius D.radius_pos
+                (CuspCollapse.centralProject D.correction D.radius D.radius_pos
+                  (CuspControlledRetraction.straightenedPrescribedCollapse D.correction η
+                    (periodPointPunctured D η s hη x))) =
+              PeriodTorusHigherHomology.coordinateProjection 2 ![x 0, x 1])
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) (η : ℝ)
+    (hη : ‖ThreefoldHomologyCuspFibre.heightParameter D h‖ ≤ η) (hηr : η < D.radius)
+    (hδ : ‖ThreefoldHomologyCuspFibre.heightParameter D h‖ < δ)
+    (R :
+      C(CuspRetraction.ClosedQuotient D.correction D.radius η,
+        CuspRetraction.QuotientCentralFibre D.correction D.radius))
+    (hEnd :
+      CuspBoundaryTopVanishingCircle.HasPrescribedCircleEndpoint D.correction D.radius
+        D.radius_pos η ‖ThreefoldHomologyCuspFibre.heightParameter D h‖ R)
+    (q : CuspBoundaryGammaZero.Boundary) :
+    CuspCentralHomology.baseTorusProjection D.correction D.radius D.radius_pos
+        (R (gammaBoundaryToClosed D h η hη q)) 0 =
+      0 := by
+  obtain ⟨⟨t, y⟩, rfl⟩ := MappingTorus.mk_surjective CuspBoundaryGammaZero.restrictedMonodromy q
+  obtain ⟨x, rfl⟩ := PeriodTorusHigherHomology.coordinateProjection_surjective 3 y
+  rw [retraction_gammaBoundaryToClosed_realCoordinates D h η hη hηr R hEnd]
+  have hb :=
+    hbase η (ThreefoldOverlapMappingTorus.Cusp.logPoint D.radius D.radius_pos t h)
+      ((logPoint_exponential_norm D h t).trans_lt hδ)
+      ((logPoint_exponential_norm D h t).trans_le hη) (Fin.cons 0 x)
+  simpa using congrFun hb (0 : Fin 2)
+
+private def
+    CuspBoundaryTopVanishing.gammaBoundaryCentralHomotopy (D : SpecialPeriods.CuspFamily.Data)
+    (η : ℝ) (hη₀ : 0 ≤ η)
+    (R :
+      C(CuspRetraction.ClosedQuotient D.correction D.radius η,
+        CuspRetraction.QuotientCentralFibre D.correction D.radius))
+    (H :
+      (ContinuousMap.id (CuspRetraction.ClosedQuotient D.correction D.radius η)).Homotopy
+        ((CuspRetraction.quotientCentralIntoClosed D.correction D.radius η hη₀).comp R))
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius)
+    (hη : ‖ThreefoldHomologyCuspFibre.heightParameter D h‖ ≤ η) :
+    (gammaBoundaryToFull D h).Homotopy
+      ((ThreefoldHomologyFinitenessCusp.fullCentralInclusion D).comp
+        (R.comp (gammaBoundaryToClosed D h η hη)))
+    where
+  toFun p := (H (p.1, gammaBoundaryToClosed D h η hη p.2)).val
+  continuous_toFun :=
+    continuous_subtype_val.comp
+      (H.continuous.comp
+        (continuous_fst.prodMk ((gammaBoundaryToClosed D h η hη).continuous.comp continuous_snd)))
+  map_zero_left q := congrArg Subtype.val (H.map_zero_left (gammaBoundaryToClosed D h η hη q))
+  map_one_left q := congrArg Subtype.val (H.map_one_left (gammaBoundaryToClosed D h η hη q))
+
+private theorem CuspBoundaryTopVanishing.gammaBoundaryToFull_homology_eq_central
+    (D : SpecialPeriods.CuspFamily.Data) (η : ℝ) (hη₀ : 0 ≤ η)
+    (R :
+      C(CuspRetraction.ClosedQuotient D.correction D.radius η,
+        CuspRetraction.QuotientCentralFibre D.correction D.radius))
+    (H :
+      (ContinuousMap.id (CuspRetraction.ClosedQuotient D.correction D.radius η)).Homotopy
+        ((CuspRetraction.quotientCentralIntoClosed D.correction D.radius η hη₀).comp R))
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius)
+    (hη : ‖ThreefoldHomologyCuspFibre.heightParameter D h‖ ≤ η) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (gammaBoundaryToFull D h) n =
+      (SingularMayerVietoris.singularHomologyMap
+            (ThreefoldHomologyFinitenessCusp.fullCentralInclusion D) n).comp
+        (SingularMayerVietoris.singularHomologyMap (R.comp (gammaBoundaryToClosed D h η hη)) n) :=
+  by
+  rw [PeriodTorusHigherHomology.homotopy_homologyMap
+      (gammaBoundaryCentralHomotopy D η hη₀ R H h hη) n,
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+
+private theorem CuspBoundaryTopVanishing.gammaBoundaryToFull_homology_eq_zero_of_retraction
+    (D : SpecialPeriods.CuspFamily.Data) (η : ℝ) (hη₀ : 0 ≤ η)
+    (R :
+      C(CuspRetraction.ClosedQuotient D.correction D.radius η,
+        CuspRetraction.QuotientCentralFibre D.correction D.radius))
+    (H :
+      (ContinuousMap.id (CuspRetraction.ClosedQuotient D.correction D.radius η)).Homotopy
+        ((CuspRetraction.quotientCentralIntoClosed D.correction D.radius η hη₀).comp R))
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius)
+    (hη : ‖ThreefoldHomologyCuspFibre.heightParameter D h‖ ≤ η) (n : ℕ)
+    (hzero :
+      SingularMayerVietoris.singularHomologyMap (R.comp (gammaBoundaryToClosed D h η hη)) n = 0) :
+    SingularMayerVietoris.singularHomologyMap (gammaBoundaryToFull D h) n = 0 := by
+  rw [gammaBoundaryToFull_homology_eq_central D η hη₀ R H h hη n, hzero, LinearMap.comp_zero]
+
+private theorem CuspBoundaryTopVanishing.gammaBoundaryToFull_homologyFour_eq_zero_of_retraction
+    (D : SpecialPeriods.CuspFamily.Data) (η : ℝ) (hη₀ : 0 ≤ η)
+    (R :
+      C(CuspRetraction.ClosedQuotient D.correction D.radius η,
+        CuspRetraction.QuotientCentralFibre D.correction D.radius))
+    (H :
+      (ContinuousMap.id (CuspRetraction.ClosedQuotient D.correction D.radius η)).Homotopy
+        ((CuspRetraction.quotientCentralIntoClosed D.correction D.radius η hη₀).comp R))
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius)
+    (hη : ‖ThreefoldHomologyCuspFibre.heightParameter D h‖ ≤ η)
+    (hzero :
+      SingularMayerVietoris.singularHomologyMap (R.comp (gammaBoundaryToClosed D h η hη)) 4 = 0) :
+    SingularMayerVietoris.singularHomologyMap (gammaBoundaryToFull D h) 4 = 0 :=
+  gammaBoundaryToFull_homology_eq_zero_of_retraction D η hη₀ R H h hη 4 hzero
+
+private theorem CuspBoundaryTopVanishing.gammaBoundaryToFull_homologyFour_eq_zero
+    (D : SpecialPeriods.CuspFamily.Data) (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) :
+    SingularMayerVietoris.singularHomologyMap (gammaBoundaryToFull D h) 4 = 0 := by
+  obtain ⟨δ, hδ, _hδr, _hδ1, hbase⟩ := exists_period_base_radius D
+  obtain ⟨η₀, hη₀, hη₀r, _hη₀1, hret⟩ :=
+    CuspBoundaryTopVanishingCircle.exists_controlled_circle_retraction D.correction D.radius_pos
+      D.holomorphic
+  let η := Min.min η₀ δ
+  have hη : 0 < η := lt_min hη₀ hδ
+  have hηr : η < D.radius := (min_le_left η₀ δ).trans_lt hη₀r
+  obtain ⟨h', hh'⟩ := ThreefoldHomologyCuspFibre.exists_smallHeight D hη
+  have hρ : 0 < ‖ThreefoldHomologyCuspFibre.heightParameter D h'‖ :=
+    norm_pos_iff.mpr (ThreefoldHomologyCuspFibre.heightParameter_ne_zero D h')
+  obtain ⟨R, _hR, H, _hmono, hEnd, _hall⟩ :=
+    hret η hη (min_le_left η₀ δ) ‖ThreefoldHomologyCuspFibre.heightParameter D h'‖ hρ hh'.le
+  have hzero :
+    SingularMayerVietoris.singularHomologyMap (R.comp (gammaBoundaryToClosed D h' η hh'.le)) 4 =
+      0 := by
+    apply
+      central_homologyFourMap_eq_zero_of_baseFirstZero D.correction D.radius D.radius_pos
+        D.radius_lt_one D.holomorphic D.smallDrift
+    intro q
+    exact
+      retraction_gammaBoundary_base_zero D δ hbase h' η hh'.le hηr
+        (hh'.trans_le (min_le_right η₀ δ)) R hEnd q
+  rw [gammaBoundaryToFull_homology_eq D h h' 4]
+  exact
+    gammaBoundaryToFull_homologyFour_eq_zero_of_retraction D η hη.le R H.toHomotopy h' hh'.le
+      hzero
+
+private theorem CuspBoundaryGammaZero.fibreMap_eq_capSectionFibre (j : Elliptic.Kind) :
+    fibreMap = PeriodFamily.Boundary.EllipticCapProduct.capSectionFibre j 0 := by
+  apply ContinuousMap.ext
+  intro y
+  obtain ⟨x, rfl⟩ := PeriodTorusHigherHomology.coordinateProjection_surjective 3 y
+  rw [fibreMap_coordinateProjection,
+    PeriodFamily.Boundary.EllipticCapProduct.capSectionFibre_zero_coordinateProjection]
+
+private theorem CuspBoundaryGammaZero.fibreMap_h3_coordinates
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3) :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (SingularMayerVietoris.singularHomologyMap fibreMap 3 a) =
+      Pi.single (3 : Fin 4) (Elliptic.HigherHomology.torusH3Coordinates a) := by
+  rw [fibreMap_eq_capSectionFibre .three]
+  exact PeriodFamily.Boundary.EllipticCapProduct.capSectionFibre_zero_h3 .three a
+
+private theorem CuspBoundaryGammaZero.fibreMap_h3_top :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (SingularMayerVietoris.singularHomologyMap fibreMap 3
+          (Elliptic.HigherHomology.torusH3Coordinates.symm 1)) =
+      Pi.single (3 : Fin 4) 1 := by rw [fibreMap_h3_coordinates, LinearEquiv.apply_symm_apply]
+
+private theorem CuspBoundaryGammaZero.restrictedMonodromy_h3_identity :
+    MappingTorusHomology.monodromyHomologyMap restrictedMonodromy 3 = LinearMap.id := by
+  apply LinearMap.ext
+  intro a
+  apply Elliptic.HigherHomology.torusH3Coordinates.injective
+  change
+    Elliptic.HigherHomology.torusH3Coordinates
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.torusMatrixMap restrictedMatrix) 3 a) =
+      Elliptic.HigherHomology.torusH3Coordinates a
+  rw [Elliptic.HigherHomology.torusH3Coordinates_matrix_natural, restrictedMatrix_det, one_mul]
+
+private theorem CuspBoundaryGammaZero.topWang_injective :
+    Function.Injective (MappingTorusHomology.wangBoundary restrictedMonodromy 3) := by
+  let :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 4) :=
+    PeriodTorusHigherHomology.productTorus_homology_subsingleton_of_lt (by decide : 3 < 4)
+  have hzero : MappingTorusHomology.fibreHomologyMap restrictedMonodromy 4 = 0 := by
+    apply LinearMap.ext
+    intro a
+    exact
+      (congrArg (MappingTorusHomology.fibreHomologyMap restrictedMonodromy 4)
+            (Subsingleton.elim a 0)).trans
+        (map_zero (MappingTorusHomology.fibreHomologyMap restrictedMonodromy 4))
+  apply LinearMap.ker_eq_bot.mp
+  rw [← MappingTorusHomology.wang_exact_at_mappingTorus restrictedMonodromy 3, hzero,
+    LinearMap.range_zero]
+
+private theorem CuspBoundaryGammaZero.topWang_surjective :
+    Function.Surjective (MappingTorusHomology.wangBoundary restrictedMonodromy 3) := by
+  intro a
+  have ha : a ∈ LinearMap.ker (MappingTorusHomology.wangDifference restrictedMonodromy 3) := by
+    change a - MappingTorusHomology.monodromyHomologyMap restrictedMonodromy 3 a = 0
+    rw [restrictedMonodromy_h3_identity, LinearMap.id_apply, sub_self]
+  rw [← MappingTorusHomology.wangBoundary_range restrictedMonodromy 3] at ha
+  exact ha
+
+private def CuspBoundaryGammaZero.topWangEquiv :
+    SingularMayerVietoris.SingularHomology (MappingTorus.Torus restrictedMonodromy) 4 ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3 :=
+  LinearEquiv.ofBijective (MappingTorusHomology.wangBoundary restrictedMonodromy 3)
+    ⟨topWang_injective, topWang_surjective⟩
+
+private def CuspBoundaryGammaZero.H4Coordinates :
+    SingularMayerVietoris.SingularHomology (MappingTorus.Torus restrictedMonodromy) 4 ≃ₗ[ℤ] ℤ :=
+  topWangEquiv.trans Elliptic.HigherHomology.torusH3Coordinates
+
+private def CuspBoundaryGammaZero.fundamentalClass :
+    SingularMayerVietoris.SingularHomology (MappingTorus.Torus restrictedMonodromy) 4 :=
+  H4Coordinates.symm 1
+
+@[simp]
+private theorem CuspBoundaryGammaZero.H4Coordinates_fundamentalClass :
+    H4Coordinates fundamentalClass = 1 :=
+  H4Coordinates.apply_symm_apply 1
+
+private theorem CuspBoundaryGammaZero.wangBoundary_fundamentalClass :
+    MappingTorusHomology.wangBoundary restrictedMonodromy 3 fundamentalClass =
+      Elliptic.HigherHomology.torusH3Coordinates.symm 1 := by
+  apply Elliptic.HigherHomology.torusH3Coordinates.injective
+  rw [LinearEquiv.apply_symm_apply]
+  exact H4Coordinates_fundamentalClass
+
+private theorem CuspBoundaryGammaZero.mappingTorusMap_mapsTo_U {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : C(X, Y)) (he : ∀ x, e (f x) = g (e x)) :
+    Set.MapsTo (mappingTorusMap f g e he) (MappingTorus.HomologyCover.U f)
+      (MappingTorus.HomologyCover.U g) := by
+  intro q hq
+  change MappingTorus.base g (mappingTorusMap f g e he q) ≠ ((0 : ℝ) : MappingTorus.Circle)
+  rw [mappingTorusMap_base]
+  exact hq
+
+private theorem CuspBoundaryGammaZero.mappingTorusMap_mapsTo_V {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : C(X, Y)) (he : ∀ x, e (f x) = g (e x)) :
+    Set.MapsTo (mappingTorusMap f g e he) (MappingTorus.HomologyCover.V f)
+      (MappingTorus.HomologyCover.V g) := by
+  intro q hq
+  change MappingTorus.base g (mappingTorusMap f g e he q) ≠ ((-(1 / 2 : ℝ)) : MappingTorus.Circle)
+  rw [mappingTorusMap_base]
+  exact hq
+
+private def CuspBoundaryGammaZero.mappingTorusIntersectionMap {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : C(X, Y)) (he : ∀ x, e (f x) = g (e x)) :
+    C((MappingTorus.HomologyCover.U f ∩ MappingTorus.HomologyCover.V f :
+        Set (MappingTorus.Torus f)),
+      (MappingTorus.HomologyCover.U g ∩ MappingTorus.HomologyCover.V g :
+        Set (MappingTorus.Torus g))) :=
+  SingularMayerVietoris.intersectionRestriction (mappingTorusMap f g e he)
+    (MappingTorus.HomologyCover.U f) (MappingTorus.HomologyCover.V f)
+    (MappingTorus.HomologyCover.U g) (MappingTorus.HomologyCover.V g)
+    (mappingTorusMap_mapsTo_U f g e he) (mappingTorusMap_mapsTo_V f g e he)
+
+private theorem
+    CuspBoundaryGammaZero.mappingTorusIntersectionMap_lower {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : C(X, Y)) (he : ∀ x, e (f x) = g (e x)) :
+    (mappingTorusIntersectionMap f g e he).comp (PeriodFamily.Boundary.lowerComponentFibre f) =
+      (PeriodFamily.Boundary.lowerComponentFibre g).comp e := by
+  apply ContinuousMap.ext
+  intro x
+  apply Subtype.ext
+  change
+    mappingTorusMap f g e he (PeriodFamily.Boundary.lowerComponentFibre f x).val =
+      (PeriodFamily.Boundary.lowerComponentFibre g (e x)).val
+  simp only [PeriodFamily.Boundary.lowerComponentFibre_coe, mappingTorusMap_mk]
+
+private theorem
+    CuspBoundaryGammaZero.mappingTorusIntersectionMap_upper {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : C(X, Y)) (he : ∀ x, e (f x) = g (e x)) :
+    (mappingTorusIntersectionMap f g e he).comp (PeriodFamily.Boundary.upperComponentFibre f) =
+      (PeriodFamily.Boundary.upperComponentFibre g).comp e := by
+  apply ContinuousMap.ext
+  intro x
+  apply Subtype.ext
+  change
+    mappingTorusMap f g e he (PeriodFamily.Boundary.upperComponentFibre f x).val =
+      (PeriodFamily.Boundary.upperComponentFibre g (e x)).val
+  simp only [PeriodFamily.Boundary.upperComponentFibre_coe, mappingTorusMap_mk]
+
+private def
+    CuspBoundaryGammaZero.mappingTorusIntersectionComparison {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : C(X, Y)) (he : ∀ x, e (f x) = g (e x))
+    (n : ℕ) :
+    (SingularMayerVietoris.SingularHomology X n ×
+        SingularMayerVietoris.SingularHomology X n) →ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology Y n × SingularMayerVietoris.SingularHomology Y n) :=
+  (MappingTorusHomology.intersectionHomologyEquiv g n).toLinearMap.comp
+    ((SingularMayerVietoris.singularHomologyMap (mappingTorusIntersectionMap f g e he) n).comp
+      (MappingTorusHomology.intersectionHomologyEquiv f n).symm.toLinearMap)
+
+@[simp]
+private theorem CuspBoundaryGammaZero.mappingTorusIntersectionComparison_apply {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : C(X, Y))
+    (he : ∀ x, e (f x) = g (e x)) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology X n × SingularMayerVietoris.SingularHomology X n) :
+    mappingTorusIntersectionComparison f g e he n a =
+      MappingTorusHomology.intersectionHomologyEquiv g n
+        (SingularMayerVietoris.singularHomologyMap (mappingTorusIntersectionMap f g e he) n
+          ((MappingTorusHomology.intersectionHomologyEquiv f n).symm a)) :=
+  rfl
+
+private theorem CuspBoundaryGammaZero.mappingTorusIntersectionComparison_lower {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : C(X, Y))
+    (he : ∀ x, e (f x) = g (e x)) (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    mappingTorusIntersectionComparison f g e he n (a, 0) =
+      (SingularMayerVietoris.singularHomologyMap e n a, 0) := by
+  rw [mappingTorusIntersectionComparison_apply,
+    PeriodFamily.Boundary.intersectionHomologyEquiv_symm_lower, ← LinearMap.comp_apply, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp, mappingTorusIntersectionMap_lower,
+    PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply,
+    PeriodFamily.Boundary.lowerComponentFibre_homology]
+
+private theorem CuspBoundaryGammaZero.mappingTorusIntersectionComparison_upper {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : C(X, Y))
+    (he : ∀ x, e (f x) = g (e x)) (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    mappingTorusIntersectionComparison f g e he n (0, a) =
+      (0, SingularMayerVietoris.singularHomologyMap e n a) := by
+  rw [mappingTorusIntersectionComparison_apply,
+    PeriodFamily.Boundary.intersectionHomologyEquiv_symm_upper, ← LinearMap.comp_apply, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp, mappingTorusIntersectionMap_upper,
+    PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply,
+    PeriodFamily.Boundary.upperComponentFibre_homology]
+
+private theorem CuspBoundaryGammaZero.mappingTorusIntersectionComparison_pair {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : C(X, Y))
+    (he : ∀ x, e (f x) = g (e x)) (n : ℕ) (a b : SingularMayerVietoris.SingularHomology X n) :
+    mappingTorusIntersectionComparison f g e he n (a, b) =
+      (SingularMayerVietoris.singularHomologyMap e n a,
+        SingularMayerVietoris.singularHomologyMap e n b) := by
+  have hab : (a, b) = (a, (0 : SingularMayerVietoris.SingularHomology X n)) + (0, b) := by
+    ext <;> simp
+  rw [hab, map_add, mappingTorusIntersectionComparison_lower,
+    mappingTorusIntersectionComparison_upper]
+  simp
+
+private theorem CuspBoundaryGammaZero.mappingTorus_boundaryCoordinates_naturality {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : C(X, Y))
+    (he : ∀ x, e (f x) = g (e x)) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) (n + 1)) :
+    MappingTorusHomology.boundaryCoordinates g n
+        (SingularMayerVietoris.singularHomologyMap (mappingTorusMap f g e he) (n + 1) a) =
+      MappingTorusHomology.intersectionHomologyEquiv g n
+        (SingularMayerVietoris.singularHomologyMap (mappingTorusIntersectionMap f g e he) n
+          (MappingTorusHomology.mayerVietorisConnecting f n a)) := by
+  have h :=
+    SingularMayerVietoris.connectingHomomorphism_naturality_apply (mappingTorusMap f g e he)
+      (MappingTorus.HomologyCover.U f) (MappingTorus.HomologyCover.V f)
+      (MappingTorus.HomologyCover.U g) (MappingTorus.HomologyCover.V g)
+      (mappingTorusMap_mapsTo_U f g e he) (mappingTorusMap_mapsTo_V f g e he)
+      (MappingTorus.HomologyCover.U_open f) (MappingTorus.HomologyCover.V_open f)
+      (MappingTorus.HomologyCover.cover f) (MappingTorus.HomologyCover.U_open g)
+      (MappingTorus.HomologyCover.V_open g) (MappingTorus.HomologyCover.cover g) n a
+  exact (congrArg (MappingTorusHomology.intersectionHomologyEquiv g n) h).symm
+
+private theorem CuspBoundaryGammaZero.mappingTorus_boundaryCoordinates_comparison {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : C(X, Y))
+    (he : ∀ x, e (f x) = g (e x)) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) (n + 1)) :
+    MappingTorusHomology.boundaryCoordinates g n
+        (SingularMayerVietoris.singularHomologyMap (mappingTorusMap f g e he) (n + 1) a) =
+      mappingTorusIntersectionComparison f g e he n
+        (-MappingTorusHomology.wangBoundary f n a, MappingTorusHomology.wangBoundary f n a) := by
+  rw [mappingTorus_boundaryCoordinates_naturality f g e he,
+    PeriodFamily.Boundary.mappingTorusConnecting_eq_marked_boundary f n a]
+  rfl
+
+private theorem CuspBoundaryGammaZero.mappingTorus_boundaryCoordinates_pair {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : C(X, Y))
+    (he : ∀ x, e (f x) = g (e x)) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) (n + 1)) :
+    MappingTorusHomology.boundaryCoordinates g n
+        (SingularMayerVietoris.singularHomologyMap (mappingTorusMap f g e he) (n + 1) a) =
+      (-SingularMayerVietoris.singularHomologyMap e n (MappingTorusHomology.wangBoundary f n a),
+        SingularMayerVietoris.singularHomologyMap e n
+          (MappingTorusHomology.wangBoundary f n a)) := by
+  rw [mappingTorus_boundaryCoordinates_comparison f g e he,
+    mappingTorusIntersectionComparison_pair, map_neg]
+
+private theorem CuspBoundaryGammaZero.wangBoundary_mappingTorusMap {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : C(X, Y)) (he : ∀ x, e (f x) = g (e x))
+    (n : ℕ) (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) (n + 1)) :
+    MappingTorusHomology.wangBoundary g n
+        (SingularMayerVietoris.singularHomologyMap (mappingTorusMap f g e he) (n + 1) a) =
+      SingularMayerVietoris.singularHomologyMap e n (MappingTorusHomology.wangBoundary f n a) := by
+  change
+    -(MappingTorusHomology.boundaryCoordinates g n
+            (SingularMayerVietoris.singularHomologyMap (mappingTorusMap f g e he) (n + 1) a)).1 =
+      _
+  rw [mappingTorus_boundaryCoordinates_pair f g e he, neg_neg]
+
+private theorem CuspBoundaryGammaZero.boundaryMap_wang (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology Boundary (n + 1)) :
+    MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n
+        (SingularMayerVietoris.singularHomologyMap boundaryMap (n + 1) a) =
+      SingularMayerVietoris.singularHomologyMap fibreMap n
+        (MappingTorusHomology.wangBoundary restrictedMonodromy n a) :=
+  wangBoundary_mappingTorusMap restrictedMonodromy ThreefoldOverlapMappingTorus.Cusp.monodromy
+    fibreMap fibreMap_monodromy n a
+
+private def CuspBoundaryGammaZero.nativeClass :
+    SingularMayerVietoris.SingularHomology ThreefoldOverlapMappingTorus.Cusp.Boundary 4 :=
+  SingularMayerVietoris.singularHomologyMap boundaryMap 4 fundamentalClass
+
+private theorem CuspBoundaryGammaZero.nativeClass_wang :
+    MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy 3 nativeClass =
+      SingularMayerVietoris.singularHomologyMap fibreMap 3
+        (Elliptic.HigherHomology.torusH3Coordinates.symm 1) := by
+  change
+    MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy 3
+        (SingularMayerVietoris.singularHomologyMap boundaryMap 4 fundamentalClass) =
+      _
+  rw [boundaryMap_wang, wangBoundary_fundamentalClass]
+
+private theorem CuspBoundaryGammaZero.nativeClass_wang_coordinates :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy 3
+          nativeClass) =
+      Pi.single (3 : Fin 4) 1 := by rw [nativeClass_wang, fibreMap_h3_top]
+
+private theorem CuspBoundaryTopVanishing.boundaryToFilling_gammaBoundary_homologyFour_eq_zero :
+    SingularMayerVietoris.singularHomologyMap
+        ((ThreefoldOverlapMappingTorus.boundaryToFilling Option.none).comp
+          CuspBoundaryGammaZero.boundaryMap)
+        4 =
+      0 := by
+  rw [gammaBoundaryToFilling_eq]
+  exact
+    gammaBoundaryToFull_homologyFour_eq_zero ThreefoldOverlapMappingTorus.Cusp.specialData
+      ThreefoldOverlapMappingTorus.Cusp.specialHeight
+
+private theorem CuspBoundaryTopVanishing.boundaryToFilling_boundaryMap_homologyFour
+    (a : SingularMayerVietoris.SingularHomology CuspBoundaryGammaZero.Boundary 4) :
+    SingularMayerVietoris.singularHomologyMap
+        (ThreefoldOverlapMappingTorus.boundaryToFilling Option.none) 4
+        (SingularMayerVietoris.singularHomologyMap CuspBoundaryGammaZero.boundaryMap 4 a) =
+      0 := by
+  have h := LinearMap.congr_fun boundaryToFilling_gammaBoundary_homologyFour_eq_zero a
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp CuspBoundaryGammaZero.boundaryMap
+      (ThreefoldOverlapMappingTorus.boundaryToFilling Option.none) 4] at h
+  exact h
+
+private theorem CuspBoundaryTopVanishing.boundaryToFilling_nativeClass_eq_zero :
+    SingularMayerVietoris.singularHomologyMap
+        (ThreefoldOverlapMappingTorus.boundaryToFilling Option.none) 4
+        CuspBoundaryGammaZero.nativeClass =
+      0 :=
+  boundaryToFilling_boundaryMap_homologyFour CuspBoundaryGammaZero.fundamentalClass
+
+private theorem CuspBoundaryTopVanishing.boundaryFillingHomologyMap_nativeClass_eq_zero :
+    ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none 4
+        CuspBoundaryGammaZero.nativeClass =
+      0 :=
+  boundaryToFilling_nativeClass_eq_zero
+
+private theorem CuspBoundaryGammaZero.regularMap_gamma_zero (q : Boundary) :
+    PeriodFamily.GammaZero.familyGamma ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData
+        (ThreefoldOverlapMappingTorus.boundaryToRegularFamily Option.none (boundaryMap q)) =
+      0 := by
+  obtain ⟨⟨t, y⟩, rfl⟩ := MappingTorus.mk_surjective restrictedMonodromy q
+  rw [boundaryMap_mk, ThreefoldOverlapMappingTorus.Cusp.boundaryToRegularFamily_cusp_mk,
+    PeriodFamily.GammaZero.familyGamma_quotient, fibreMap_gamma]
+
+private def CuspBoundaryGammaZero.regularGammaZeroMap :
+    C(Boundary,
+      PeriodFamily.GammaZero.Space ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData) :=
+  PeriodFamily.GammaZero.lift ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData
+    ((ThreefoldOverlapMappingTorus.boundaryToRegularFamily Option.none).comp boundaryMap)
+    regularMap_gamma_zero
+
+@[simp]
+private theorem CuspBoundaryGammaZero.inclusion_comp_regularGammaZeroMap :
+    (PeriodFamily.GammaZero.inclusion ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData).comp
+        regularGammaZeroMap =
+      (ThreefoldOverlapMappingTorus.boundaryToRegularFamily Option.none).comp boundaryMap :=
+  rfl
+
+private theorem CuspBoundaryGammaZero.boundaryRegularHomologyMap_gammaZero_factor (n : ℕ) :
+    (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none n).comp
+        (SingularMayerVietoris.singularHomologyMap boundaryMap n) =
+      (SingularMayerVietoris.singularHomologyMap
+            (PeriodFamily.GammaZero.inclusion
+              ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData)
+            n).comp
+        (SingularMayerVietoris.singularHomologyMap regularGammaZeroMap n) := by
+  have h :=
+    PeriodTorusHigherHomology.singularHomologyMap_comp regularGammaZeroMap
+      (PeriodFamily.GammaZero.inclusion ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData) n
+  rw [inclusion_comp_regularGammaZeroMap] at h
+  exact
+    (PeriodTorusHigherHomology.singularHomologyMap_comp boundaryMap
+          (ThreefoldOverlapMappingTorus.boundaryToRegularFamily Option.none) n).symm.trans
+      h
+
+private theorem CuspBoundaryGammaZero.boundaryRegularHomologyMap_gammaZero_mem_range (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology Boundary n) :
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none n
+        (SingularMayerVietoris.singularHomologyMap boundaryMap n a) ∈
+      LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodFamily.GammaZero.inclusion ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData)
+          n) := by
+  refine ⟨SingularMayerVietoris.singularHomologyMap regularGammaZeroMap n a, ?_⟩
+  exact (LinearMap.congr_fun (boundaryRegularHomologyMap_gammaZero_factor n) a).symm
+
+private theorem CuspBoundaryGammaZero.nativeClass_regular_mem_range :
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none 4 nativeClass ∈
+      LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodFamily.GammaZero.inclusion ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData)
+          4) :=
+  boundaryRegularHomologyMap_gammaZero_mem_range 4 fundamentalClass
+
+private def CuspNegation.triangleNeg (s : ToricFan.Triangle) : ToricFan.Triangle :=
+  ⟨-s.a - 1, -s.b - 1, !s.upper⟩
+
+private def
+    CuspNegation.permute (z : ToricCharts.CoordinateSpace 3) : ToricCharts.CoordinateSpace 3 :=
+  fun j => z j.rev
+
+private theorem CuspNegation.triangleNeg_involutive : Function.Involutive triangleNeg := by
+  intro s
+  ext <;> simp [triangleNeg]
+
+private theorem CuspNegation.permute_involutive : Function.Involutive permute := by
+  intro z
+  funext j
+  simp [permute]
+
+private theorem CuspNegation.permute_holomorphic : ContDiff ℂ ω permute :=
+  contDiff_pi.mpr fun j => contDiff_apply ℂ ℂ j.rev
+
+private theorem CuspNegation.time_permute (z : ToricCharts.CoordinateSpace 3) :
+    ToricFan.Triangle.time (permute z) = ToricFan.Triangle.time z := by
+  simp [ToricFan.Triangle.time, permute, Fin.rev]
+  ring
+
+private theorem CuspNegation.triangleNeg_shift (s : ToricFan.Triangle) (v : Fin 2 → ℤ) :
+    triangleNeg (s.shift v) = (triangleNeg s).shift (-v) := by
+  ext <;> simp [triangleNeg, ToricFan.Triangle.shift] <;> ring
+
+private theorem CuspNegation.transition_triangleNeg (s t : ToricFan.Triangle) (i j : Fin 3) :
+    ToricFan.Triangle.transition (triangleNeg s) (triangleNeg t) i j =
+      ToricFan.Triangle.transition s t i.rev j.rev := by
+  cases hs : s.upper <;> cases ht : t.upper <;> fin_cases i <;> fin_cases j <;>
+      simp [ToricFan.Triangle.transition, ToricFan.Triangle.dual, ToricFan.Triangle.rays,
+        triangleNeg, hs, ht, Matrix.mul_apply, Fin.sum_univ_succ, Fin.rev] <;>
+    ring
+
+private theorem CuspNegation.chartChange_triangleNeg_source_iff (s t : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) :
+    permute z ∈ (ToricFan.Triangle.chartChange (triangleNeg s) (triangleNeg t)).source ↔
+      z ∈ (ToricFan.Triangle.chartChange s t).source := by
+  simp only [ToricFan.Triangle.chartChange_source]
+  constructor
+  · intro h i j hij
+    have hneg : ToricFan.Triangle.transition (triangleNeg s) (triangleNeg t) i.rev j.rev < 0 := by
+      simpa only [transition_triangleNeg, Fin.rev_rev] using hij
+    simpa only [permute, Fin.rev_rev] using h i.rev j.rev hneg
+  · intro h i j hij
+    exact h i.rev j.rev (by simpa only [transition_triangleNeg] using hij)
+
+private theorem CuspNegation.chartChange_triangleNeg_apply (s t : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) :
+    ToricFan.Triangle.chartChange (triangleNeg s) (triangleNeg t) (permute z) =
+      permute (ToricFan.Triangle.chartChange s t z) := by
+  funext i
+  change
+    (∏ j, z j.rev ^ ToricFan.Triangle.transition (triangleNeg s) (triangleNeg t) i j) =
+      ∏ j, z j ^ ToricFan.Triangle.transition s t i.rev j
+  simp only [transition_triangleNeg]
+  simp [Fin.prod_univ_succ, Fin.rev, mul_comm, mul_left_comm, mul_assoc]
+
+private theorem CuspNegation.cuspVector_neg (v : Fin 2 → ℤ) :
+    ToricSpace.cuspVector (-v) = -ToricSpace.cuspVector v := by
+  ext i
+  fin_cases i <;> simp [ToricSpace.cuspVector]
+
+private theorem
+    CuspNegation.exponentialMultiplier_neg (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ)
+    (t : ℂ) :
+    ToricSpace.exponentialMultiplier C (-v) t = (ToricSpace.exponentialMultiplier C v t)⁻¹ := by
+  have he : (fun i => ((-v) i : ℂ)) = -(fun i => (v i : ℂ)) := by
+    ext i
+    simp
+  ext j
+  change
+    Complex.exp (2 * Real.pi * Complex.I * ((C t) *ᵥ (fun i => ((-v) i : ℂ))) j) =
+      (Complex.exp (2 * Real.pi * Complex.I * ((C t) *ᵥ (fun i => (v i : ℂ))) j))⁻¹
+  rw [he, Matrix.mulVec_neg]
+  simp only [Pi.neg_apply, mul_neg, Complex.exp_neg]
+
+private def CuspNegation.logNeg (p : ℂ × ComplexPlane₂) : ℂ × ComplexPlane₂ :=
+  (p.1, -p.2)
+
+private theorem CuspNegation.negation_compatible (s t : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) (hz : z ∈ (ToricFan.Triangle.chartChange s t).source) :
+    ToricSpace.inclusion (triangleNeg t) (permute (ToricFan.Triangle.chartChange s t z)) =
+      ToricSpace.inclusion (triangleNeg s) (permute z) := by
+  apply ((ToricSpace.inclusion_eq_iff (triangleNeg s) (triangleNeg t) (permute z) _).mpr ?_).symm
+  exact ⟨(chartChange_triangleNeg_source_iff s t z).mpr hz, chartChange_triangleNeg_apply s t z⟩
+
+private def CuspNegation.toricNegation : ToricSpace.Space → ToricSpace.Space :=
+  ToricSpace.descend (fun s z => ToricSpace.inclusion (triangleNeg s) (permute z))
+
+@[simp]
+private theorem CuspNegation.toricNegation_inclusion (s : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) :
+    toricNegation (ToricSpace.inclusion s z) = ToricSpace.inclusion (triangleNeg s) (permute z) :=
+  ToricSpace.descend_inclusion _ negation_compatible s z
+
+private theorem CuspNegation.toricNegation_holomorphic :
+    ContMDiff (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω toricNegation :=
+  ToricSpace.descend_holomorphic _ _ negation_compatible
+    (fun s =>
+      (ToricSpace.inclusion_holomorphic (triangleNeg s)).comp permute_holomorphic.contMDiff)
+
+private theorem CuspNegation.toricNegation_involutive : Function.Involutive toricNegation := by
+  intro x
+  obtain ⟨s, z, rfl⟩ := ToricSpace.inclusion_jointly_surjective x
+  rw [toricNegation_inclusion, toricNegation_inclusion, triangleNeg_involutive s,
+    permute_involutive z]
+
+@[simp]
+private theorem CuspNegation.time_toricNegation (x : ToricSpace.Space) :
+    ToricSpace.time (toricNegation x) = ToricSpace.time x := by
+  obtain ⟨s, z, rfl⟩ := ToricSpace.inclusion_jointly_surjective x
+  rw [toricNegation_inclusion, ToricSpace.time_inclusion, ToricSpace.time_inclusion, time_permute]
+
+private theorem CuspNegation.toricNegation_translate (v : Fin 2 → ℤ) (x : ToricSpace.Space) :
+    toricNegation (ToricSpace.translate v x) = ToricSpace.translate (-v) (toricNegation x) := by
+  obtain ⟨s, z, rfl⟩ := ToricSpace.inclusion_jointly_surjective x
+  rw [ToricSpace.translate_inclusion, toricNegation_inclusion, toricNegation_inclusion,
+    ToricSpace.translate_inclusion, triangleNeg_shift]
+
+private theorem CuspNegation.factors_triangleNeg_inverse (s : ToricFan.Triangle) (u : Fin 2 → ℂˣ) :
+    ToricSpace.factors (triangleNeg s) (ToricSpace.fibreMultiplier u⁻¹) =
+      permute (ToricSpace.factors s (ToricSpace.fibreMultiplier u)) := by
+  ext i
+  cases hs : s.upper <;> fin_cases i <;>
+    simp [ToricSpace.factors, ToricCharts.monomial, ToricFan.Triangle.dual, triangleNeg, permute,
+      hs, ToricSpace.fibreMultiplier, Fin.prod_univ_succ, Fin.rev, mul_comm]
+
+private theorem CuspNegation.permute_scale (s : ToricFan.Triangle) (u : Fin 2 → ℂˣ)
+    (z : ToricCharts.CoordinateSpace 3) :
+    permute (ToricSpace.scale s (ToricSpace.fibreMultiplier u) z) =
+      ToricSpace.scale (triangleNeg s) (ToricSpace.fibreMultiplier u⁻¹) (permute z) := by
+  ext i
+  change
+    ToricSpace.factors s (ToricSpace.fibreMultiplier u) i.rev * z i.rev =
+      ToricSpace.factors (triangleNeg s) (ToricSpace.fibreMultiplier u⁻¹) i * z i.rev
+  rw [factors_triangleNeg_inverse]
+  rfl
+
+private theorem CuspNegation.toricNegation_fibreMultiplier (u : Fin 2 → ℂˣ) (x : ToricSpace.Space) :
+    toricNegation (ToricSpace.torusAction (ToricSpace.fibreMultiplier u) x) =
+      ToricSpace.torusAction (ToricSpace.fibreMultiplier u⁻¹) (toricNegation x) := by
+  obtain ⟨s, z, rfl⟩ := ToricSpace.inclusion_jointly_surjective x
+  rw [ToricSpace.torusAction_inclusion, toricNegation_inclusion, toricNegation_inclusion,
+    ToricSpace.torusAction_inclusion, permute_scale]
+
+private theorem CuspNegation.toricNegation_variableMultiplier (u : ℂ → Fin 2 → ℂˣ)
+    (x : ToricSpace.Space) :
+    toricNegation (ToricSpace.variableMultiplier u x) =
+      ToricSpace.variableMultiplier (fun t => (u t)⁻¹) (toricNegation x) := by
+  simp only [ToricSpace.variableMultiplier, toricNegation_fibreMultiplier, time_toricNegation]
+
+private theorem CuspNegation.toricNegation_twistedTranslate (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) (x : ToricSpace.Space) :
+    toricNegation (ToricSpace.twistedTranslate C v x) =
+      ToricSpace.twistedTranslate C (-v) (toricNegation x) := by
+  have he :
+    (fun t => (ToricSpace.exponentialMultiplier C v t)⁻¹) =
+      ToricSpace.exponentialMultiplier C (-v) :=
+    funext fun t => (exponentialMultiplier_neg C v t).symm
+  rw [ToricSpace.twistedTranslate, toricNegation_variableMultiplier, toricNegation_translate, he,
+    ToricSpace.twistedTranslate, cuspVector_neg]
+
+private def CuspNegation.tubeNegation (D : TopologicalSpace.Opens ℂ) (x : ToricSpace.Tube D) :
+    ToricSpace.Tube D :=
+  ⟨toricNegation x, by
+    change ToricSpace.time (toricNegation x) ∈ D
+    rw [time_toricNegation]
+    exact x.2⟩
+
+private theorem CuspNegation.tubeNegation_involutive (D : TopologicalSpace.Opens ℂ) :
+    Function.Involutive (tubeNegation D) := fun x => Subtype.ext (toricNegation_involutive x)
+
+private theorem CuspNegation.tubeNegation_continuous (D : TopologicalSpace.Opens ℂ) :
+    Continuous (tubeNegation D) :=
+  (toricNegation_holomorphic.continuous.comp continuous_subtype_val).subtype_mk _
+
+private theorem CuspNegation.tubeNegation_translate (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (D : TopologicalSpace.Opens ℂ) (v : Fin 2 → ℤ) (x : ToricSpace.Tube D) :
+    tubeNegation D (ToricSpace.tubeTranslate C D v x) =
+      ToricSpace.tubeTranslate C D (-v) (tubeNegation D x) :=
+  Subtype.ext (toricNegation_twistedTranslate C v x)
+
+private theorem CuspNegation.tubeNegation_related (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    {x y : ToricSpace.Tube (CuspQuotient.disc ε)} (hxy : (CuspQuotient.relation C ε).r x y) :
+    (CuspQuotient.relation C ε).r (tubeNegation (CuspQuotient.disc ε) x)
+      (tubeNegation (CuspQuotient.disc ε) y) := by
+  let := ToricSpace.tubeAction C (CuspQuotient.disc ε)
+  change x ∈ MulAction.orbit CuspQuotient.LatticeGroup y at hxy
+  change
+    tubeNegation (CuspQuotient.disc ε) x ∈
+      MulAction.orbit CuspQuotient.LatticeGroup (tubeNegation (CuspQuotient.disc ε) y)
+  obtain ⟨g, rfl⟩ := hxy
+  refine ⟨Multiplicative.ofAdd (-g.toAdd), ?_⟩
+  exact (tubeNegation_translate C (CuspQuotient.disc ε) g.toAdd y).symm
+
+private def CuspNegation.quotientNegation (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    CuspQuotient.QuotientSpace C ε → CuspQuotient.QuotientSpace C ε :=
+  Quotient.map (tubeNegation (CuspQuotient.disc ε)) (fun _ _ h => tubeNegation_related C ε h)
+
+@[simp]
+private theorem CuspNegation.quotientNegation_quotientMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (x : ToricSpace.Tube (CuspQuotient.disc ε)) :
+    quotientNegation C ε (CuspQuotient.quotientMap C ε x) =
+      CuspQuotient.quotientMap C ε (tubeNegation (CuspQuotient.disc ε) x) :=
+  rfl
+
+private theorem
+    CuspNegation.quotientNegation_involutive (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    Function.Involutive (quotientNegation C ε) := by
+  intro q
+  induction q using Quotient.inductionOn with
+  | h
+    x =>
+    change
+      CuspQuotient.quotientMap C ε
+          (tubeNegation (CuspQuotient.disc ε) (tubeNegation (CuspQuotient.disc ε) x)) =
+        CuspQuotient.quotientMap C ε x
+    rw [tubeNegation_involutive (CuspQuotient.disc ε) x]
+
+private theorem
+    CuspNegation.quotientNegation_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    Continuous (quotientNegation C ε) :=
+  ((CuspQuotient.quotientMap_continuous C ε).comp
+        (tubeNegation_continuous (CuspQuotient.disc ε))).quotient_lift
+    _
+
+private def CuspNegation.quotientHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    CuspQuotient.QuotientSpace C ε ≃ₜ CuspQuotient.QuotientSpace C ε
+    where
+  toFun := quotientNegation C ε
+  invFun := quotientNegation C ε
+  left_inv := quotientNegation_involutive C ε
+  right_inv := quotientNegation_involutive C ε
+  continuous_toFun := quotientNegation_continuous C ε
+  continuous_invFun := quotientNegation_continuous C ε
+
+private def CuspNegation.fibreReciprocal (w : ToricCharts.CoordinateSpace 3) :
+    ToricCharts.CoordinateSpace 3 :=
+  ![(w 0)⁻¹, (w 1)⁻¹, w 2]
+
+private theorem CuspNegation.fibreReciprocal_mem_torus {w : ToricCharts.CoordinateSpace 3}
+    (hw : w ∈ ToricCharts.torus) : fibreReciprocal w ∈ ToricCharts.torus := by
+  intro i
+  fin_cases i
+  · exact inv_ne_zero (hw 0)
+  · exact inv_ne_zero (hw 1)
+  · exact hw 2
+
+private theorem CuspNegation.permute_mem_torus {w : ToricCharts.CoordinateSpace 3}
+    (hw : w ∈ ToricCharts.torus) : permute w ∈ ToricCharts.torus := fun i => hw i.rev
+
+private theorem CuspNegation.rays_triangleNeg (s : ToricFan.Triangle) (i j : Fin 3) :
+    (triangleNeg s).rays i j = if i = 2 then s.rays i j.rev else -s.rays i j.rev := by
+  cases hs : s.upper <;> fin_cases i <;> fin_cases j <;>
+      simp [ToricFan.Triangle.rays, triangleNeg, hs, Fin.rev] <;>
+    ring
+
+private theorem CuspNegation.monomial_rays_triangleNeg (s : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) :
+    ToricCharts.monomial (triangleNeg s).rays (permute z) =
+      fibreReciprocal (ToricCharts.monomial s.rays z) := by
+  have hp (i : Fin 3) : (∏ j : Fin 3, z j.rev ^ s.rays i j.rev) = ∏ j : Fin 3, z j ^ s.rays i j :=
+    Equiv.prod_comp Fin.revPerm (fun j => z j ^ s.rays i j)
+  ext i
+  by_cases hi : i = 2
+  · subst i
+    change (∏ j, z j.rev ^ (triangleNeg s).rays 2 j) = ∏ j, z j ^ s.rays 2 j
+    simp only [rays_triangleNeg]
+    exact hp 2
+  · have ht :
+      fibreReciprocal (ToricCharts.monomial s.rays z) i = (ToricCharts.monomial s.rays z i)⁻¹ := by
+      fin_cases i <;> simp_all [fibreReciprocal]
+    rw [ht]
+    change (∏ j, z j.rev ^ (triangleNeg s).rays i j) = (∏ j, z j ^ s.rays i j)⁻¹
+    simp only [rays_triangleNeg, hi, ite_false, zpow_neg, Finset.prod_inv_distrib]
+    exact congrArg Inv.inv (hp i)
+
+private theorem CuspNegation.torusCoordinates_toricNegation {x : ToricSpace.Space}
+    (hx : x ∈ ToricSpace.openTorus) :
+    ToricSpace.torusCoordinates (toricNegation x) =
+      fibreReciprocal (ToricSpace.torusCoordinates x) := by
+  obtain ⟨z, hz, rfl⟩ := hx
+  rw [toricNegation_inclusion, ToricSpace.torusCoordinates_inclusion _ (permute_mem_torus hz),
+    ToricSpace.torusCoordinates_inclusion _ hz, monomial_rays_triangleNeg]
+
+private theorem CuspNegation.toricNegation_mem_openTorus {x : ToricSpace.Space}
+    (hx : x ∈ ToricSpace.openTorus) : toricNegation x ∈ ToricSpace.openTorus := by
+  apply (ToricSpace.mem_openTorus_iff _).mpr
+  rw [time_toricNegation]
+  exact (ToricSpace.mem_openTorus_iff _).mp hx
+
+private theorem CuspNegation.toricNegation_torusPoint {w : ToricCharts.CoordinateSpace 3}
+    (hw : w ∈ ToricCharts.torus) :
+    toricNegation (CuspUniformization.torusPoint w) =
+      CuspUniformization.torusPoint (fibreReciprocal w) := by
+  apply
+    CuspUniformization.torusCoordinates_injective
+      (toricNegation_mem_openTorus (CuspUniformization.torusPoint_mem hw))
+      (CuspUniformization.torusPoint_mem (fibreReciprocal_mem_torus hw))
+  rw [torusCoordinates_toricNegation (CuspUniformization.torusPoint_mem hw),
+    CuspUniformization.torusCoordinates_torusPoint hw,
+    CuspUniformization.torusCoordinates_torusPoint (fibreReciprocal_mem_torus hw)]
+
+private theorem CuspNegation.exponential_neg (z : ℂ) :
+    CuspUniformization.exponential (-z) = (CuspUniformization.exponential z)⁻¹ := by
+  simp only [CuspUniformization.exponential, mul_neg, Complex.exp_neg]
+
+private theorem CuspNegation.fibreReciprocal_exponentialCoordinates (t : ℂ) (z : ComplexPlane₂) :
+    fibreReciprocal (CuspUniformization.exponentialCoordinates t z) =
+      CuspUniformization.exponentialCoordinates t (-z) := by
+  ext i
+  fin_cases i <;>
+    simp [fibreReciprocal, CuspUniformization.exponentialCoordinates, exponential_neg]
+
+private theorem
+    CuspNegation.toricNegation_exponentialPoint {t : ℂ} (ht : t ≠ 0) (z : ComplexPlane₂) :
+    toricNegation (CuspUniformization.exponentialPoint t z) =
+      CuspUniformization.exponentialPoint t (-z) := by
+  change
+    toricNegation
+        (CuspUniformization.torusPoint (CuspUniformization.exponentialCoordinates t z)) =
+      CuspUniformization.torusPoint (CuspUniformization.exponentialCoordinates t (-z))
+  rw [toricNegation_torusPoint (CuspUniformization.exponentialCoordinates_mem ht z),
+    fibreReciprocal_exponentialCoordinates]
+
+private def CuspNegation.logCoverNegation (ε : ℝ) (p : CuspUniformization.LogCover ε) :
+    CuspUniformization.LogCover ε :=
+  ⟨logNeg p, p.2⟩
+
+private theorem CuspNegation.totalExponentialPoint_logNeg (p : ℂ × ComplexPlane₂) :
+    toricNegation (CuspUniformization.totalExponentialPoint p) =
+      CuspUniformization.totalExponentialPoint (logNeg p) :=
+  toricNegation_exponentialPoint (CuspUniformization.exponential_ne_zero p.1) p.2
+
+private theorem CuspNegation.tubeNegation_totalExponentialLift (ε : ℝ)
+    (p : CuspUniformization.LogCover ε) :
+    tubeNegation (CuspQuotient.disc ε) (CuspUniformization.totalExponentialLift ε p) =
+      CuspUniformization.totalExponentialLift ε (logCoverNegation ε p) :=
+  Subtype.ext (totalExponentialPoint_logNeg p)
+
+private theorem
+    CuspNegation.quotientNegation_totalCuspCover (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (p : CuspUniformization.LogCover ε) :
+    quotientNegation C ε (CuspUniformization.totalCuspCover C ε p) =
+      CuspUniformization.totalCuspCover C ε (logCoverNegation ε p) := by
+  change
+    quotientNegation C ε
+        (CuspQuotient.quotientMap C ε (CuspUniformization.totalExponentialLift ε p)) =
+      _
+  rw [quotientNegation_quotientMap, tubeNegation_totalExponentialLift]
+  rfl
+
+private theorem CuspNegation.quotientNegation_puncturedCuspCover (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (p : CuspUniformization.LogCover ε) :
+    quotientNegation C ε (CuspUniformization.puncturedCuspCover C ε p).val =
+      (CuspUniformization.puncturedCuspCover C ε (logCoverNegation ε p)).val :=
+  quotientNegation_totalCuspCover C ε p
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/CuspFibre/CuspCentralHomology1.lean b/LeanPool/HopfProblem/CuspFibre/CuspCentralHomology1.lean
new file mode 100644
index 000000000..74b9dc29e
--- /dev/null
+++ b/LeanPool/HopfProblem/CuspFibre/CuspCentralHomology1.lean
@@ -0,0 +1,67 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Recognition.Smale5
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.Recognition.Smale5
+
+/-!
+# Hopf problem: cusp fibre · cusp central homology 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem
+    CuspCentralHomology.singularHomologyMap_const_eq_zero {Y : Type} [TopologicalSpace Y]
+    (X : Type) [TopologicalSpace X] (y : Y) (n : ℕ) (hn : n ≠ 0) :
+    SingularMayerVietoris.singularHomologyMap (ContinuousMap.const X y) n = 0 := by
+  let := PeriodTorusHigherHomology.point_homology_subsingleton n hn
+  change
+    SingularMayerVietoris.singularHomologyMap
+        ((ContinuousMap.const Unit y).comp (ContinuousMap.const X ())) n =
+      0
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp]
+  ext a
+  change
+    SingularMayerVietoris.singularHomologyMap (ContinuousMap.const Unit y) n
+        (SingularMayerVietoris.singularHomologyMap (ContinuousMap.const X ()) n a) =
+      0
+  rw [Subsingleton.elim (SingularMayerVietoris.singularHomologyMap (ContinuousMap.const X ()) n a)
+      (0 : SingularMayerVietoris.SingularHomology Unit n),
+    map_zero]
+
+public
+theorem CuspCentralHomology.singularHomologyMap_eq_zero_of_nullhomotopic {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : C(X, Y)) (hf : f.Nullhomotopic) (n : ℕ)
+    (hn : n ≠ 0) : SingularMayerVietoris.singularHomologyMap f n = 0 := by
+  obtain ⟨y, hy⟩ := hf
+  rw [PeriodTorusHigherHomology.homotopic_homologyMap hy n]
+  exact singularHomologyMap_const_eq_zero X y n hn
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/CuspFibre/CuspCentralHomology2.lean b/LeanPool/HopfProblem/CuspFibre/CuspCentralHomology2.lean
new file mode 100644
index 000000000..852c128ab
--- /dev/null
+++ b/LeanPool/HopfProblem/CuspFibre/CuspCentralHomology2.lean
@@ -0,0 +1,624 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+
+/-!
+# Hopf problem: cusp fibre · cusp central homology 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def CuspCentralHomology.suspensionSetoid (X : Type*) : Setoid (unitInterval × X)
+    where
+  r p q := p.1 = q.1 ∧ (p.1 = 0 ∨ p.1 = 1 ∨ p.2 = q.2)
+  iseqv :=
+    { refl := fun _ => ⟨rfl, Or.inr (Or.inr rfl)⟩
+      symm := by
+        rintro p q ⟨ht, h | h | h⟩
+        · exact ⟨ht.symm, Or.inl (ht.symm.trans h)⟩
+        · exact ⟨ht.symm, Or.inr (Or.inl (ht.symm.trans h))⟩
+        · exact ⟨ht.symm, Or.inr (Or.inr h.symm)⟩
+      trans := by
+        rintro p q r ⟨hpq, hp | hp | hp⟩ ⟨hqr, hq⟩
+        · exact ⟨hpq.trans hqr, Or.inl hp⟩
+        · exact ⟨hpq.trans hqr, Or.inr (Or.inl hp)⟩
+        · rcases hq with hq | hq | hq
+          · exact ⟨hpq.trans hqr, Or.inl (hpq.trans hq)⟩
+          · exact ⟨hpq.trans hqr, Or.inr (Or.inl (hpq.trans hq))⟩
+          · exact ⟨hpq.trans hqr, Or.inr (Or.inr (hp.trans hq))⟩ }
+
+private def CuspCentralHomology.Suspension (X : Type*) :=
+  Quotient (suspensionSetoid X)
+
+private instance CuspCentralHomology.instLocal1 {X : Type*} [TopologicalSpace X] :
+    TopologicalSpace (Suspension X) :=
+  inferInstanceAs (TopologicalSpace (Quotient (suspensionSetoid X)))
+
+private def CuspCentralHomology.Suspension.mk {X : Type*} (t : unitInterval) (x : X) :
+    CuspCentralHomology.Suspension X :=
+  Quotient.mk (CuspCentralHomology.suspensionSetoid X) (t, x)
+
+private theorem
+    CuspCentralHomology.Suspension.mk_eq_mk_iff {X : Type*} (t s : unitInterval) (x y : X) :
+    CuspCentralHomology.Suspension.mk t x = CuspCentralHomology.Suspension.mk s y ↔
+      t = s ∧ (t = 0 ∨ t = 1 ∨ x = y) :=
+  Quotient.eq
+
+private theorem CuspCentralHomology.Suspension.mk_surjective {X : Type*} :
+    Function.Surjective (fun p : unitInterval × X => CuspCentralHomology.Suspension.mk p.1 p.2) :=
+  Quotient.mk_surjective
+
+private theorem CuspCentralHomology.Suspension.isQuotientMap_mk {X : Type*} [TopologicalSpace X] :
+    Topology.IsQuotientMap
+      (fun p : unitInterval × X => CuspCentralHomology.Suspension.mk p.1 p.2) :=
+  isQuotientMap_quotient_mk'
+
+@[continuity, fun_prop]
+private theorem CuspCentralHomology.Suspension.continuous_mk {X : Type*} [TopologicalSpace X] :
+    Continuous (fun p : unitInterval × X => CuspCentralHomology.Suspension.mk p.1 p.2) :=
+  isQuotientMap_mk.continuous
+
+private def CuspCentralHomology.Suspension.height {X : Type*} :
+    CuspCentralHomology.Suspension X → unitInterval :=
+  Quotient.lift Prod.fst (fun _ _ h => h.1)
+
+@[continuity, fun_prop]
+private theorem CuspCentralHomology.Suspension.continuous_height {X : Type*} [TopologicalSpace X] :
+    Continuous (height : CuspCentralHomology.Suspension X → _) :=
+  isQuotientMap_mk.continuous_iff.mpr continuous_fst
+
+@[continuity, fun_prop]
+private theorem
+    CuspCentralHomology.Suspension.continuous_realHeight {X : Type*} [TopologicalSpace X] :
+    Continuous (fun p : CuspCentralHomology.Suspension X => (height p : ℝ)) :=
+  continuous_subtype_val.comp continuous_height
+
+private theorem CuspCentralHomology.Suspension.mk_zero_eq {X : Type*} (x y : X) :
+    CuspCentralHomology.Suspension.mk 0 x = CuspCentralHomology.Suspension.mk 0 y :=
+  Quotient.sound ⟨rfl, Or.inl rfl⟩
+
+private theorem CuspCentralHomology.Suspension.mk_one_eq {X : Type*} (x y : X) :
+    CuspCentralHomology.Suspension.mk 1 x = CuspCentralHomology.Suspension.mk 1 y :=
+  Quotient.sound ⟨rfl, Or.inr (Or.inl rfl)⟩
+
+private def CuspCentralHomology.Suspension.northOpen {X : Type*} :
+    Set (CuspCentralHomology.Suspension X) :=
+  {p | (height p : ℝ) < 3 / 4}
+
+private def CuspCentralHomology.Suspension.southOpen {X : Type*} :
+    Set (CuspCentralHomology.Suspension X) :=
+  {p | 1 / 4 < (height p : ℝ)}
+
+@[simp]
+private theorem CuspCentralHomology.Suspension.mem_northOpen {X : Type*}
+    (p : CuspCentralHomology.Suspension X) : p ∈ northOpen ↔ (height p : ℝ) < 3 / 4 :=
+  Iff.rfl
+
+@[simp]
+private theorem CuspCentralHomology.Suspension.mem_southOpen {X : Type*}
+    (p : CuspCentralHomology.Suspension X) : p ∈ southOpen ↔ 1 / 4 < (height p : ℝ) :=
+  Iff.rfl
+
+private theorem CuspCentralHomology.Suspension.northOpen_isOpen {X : Type*} [TopologicalSpace X] :
+    IsOpen (northOpen : Set (CuspCentralHomology.Suspension X)) :=
+  isOpen_lt continuous_realHeight continuous_const
+
+private theorem CuspCentralHomology.Suspension.southOpen_isOpen {X : Type*} [TopologicalSpace X] :
+    IsOpen (southOpen : Set (CuspCentralHomology.Suspension X)) :=
+  isOpen_lt continuous_const continuous_realHeight
+
+private theorem CuspCentralHomology.Suspension.open_cover {X : Type*} :
+    (northOpen ∪ southOpen : Set (CuspCentralHomology.Suspension X)) = Set.univ := by
+  ext p
+  simp only [Set.mem_union, mem_northOpen, mem_southOpen, Set.mem_univ, iff_true]
+  by_cases h : (height p : ℝ) < 3 / 4
+  · exact Or.inl h
+  · exact Or.inr (by linarith)
+
+private def CuspCentralHomology.Suspension.north {X : Type*} [Nonempty X] :
+    CuspCentralHomology.Suspension X :=
+  CuspCentralHomology.Suspension.mk 0 (Classical.choice ‹Nonempty X›)
+
+private def CuspCentralHomology.Suspension.south {X : Type*} [Nonempty X] :
+    CuspCentralHomology.Suspension X :=
+  CuspCentralHomology.Suspension.mk 1 (Classical.choice ‹Nonempty X›)
+
+@[simp]
+private theorem CuspCentralHomology.Suspension.mk_zero {X : Type*} [Nonempty X] (x : X) :
+    CuspCentralHomology.Suspension.mk 0 x = north :=
+  mk_zero_eq _ _
+
+@[simp]
+private theorem CuspCentralHomology.Suspension.mk_one {X : Type*} [Nonempty X] (x : X) :
+    CuspCentralHomology.Suspension.mk 1 x = south :=
+  mk_one_eq _ _
+
+private theorem CuspCentralHomology.Suspension.north_mem_northOpen {X : Type*} [Nonempty X] :
+    (north : CuspCentralHomology.Suspension X) ∈ northOpen := by
+  change (0 : ℝ) < 3 / 4
+  norm_num
+
+private theorem CuspCentralHomology.Suspension.south_mem_southOpen {X : Type*} [Nonempty X] :
+    (south : CuspCentralHomology.Suspension X) ∈ southOpen := by
+  change (1 / 4 : ℝ) < 1
+  norm_num
+
+private instance CuspCentralHomology.Suspension.instLocal1 {X : Type*} [Nonempty X] :
+    Nonempty (CuspCentralHomology.Suspension X) :=
+  ⟨north⟩
+
+private abbrev CuspCentralHomology.Suspension.middleBand (X : Type*) :=
+  (northOpen ∩ southOpen : Set (CuspCentralHomology.Suspension X))
+
+private abbrev CuspCentralHomology.Suspension.middleCylinder (X : Type*) :=
+  (fun p : unitInterval × X => CuspCentralHomology.Suspension.mk p.1 p.2) ⁻¹' middleBand X
+
+private theorem CuspCentralHomology.Suspension.middleBand_isOpen {X : Type*} [TopologicalSpace X] :
+    IsOpen (middleBand X) :=
+  northOpen_isOpen.inter southOpen_isOpen
+
+private theorem CuspCentralHomology.Suspension.middleCylinder_height_mo1973_4378 {X : Type*}
+    (p : middleCylinder X) : (1 / 4 : ℝ) < (p.1.1 : ℝ) ∧ (p.1.1 : ℝ) < 3 / 4 :=
+  ⟨p.2.2, p.2.1⟩
+
+private theorem CuspCentralHomology.Suspension.middleBand_restrict_injective {X : Type*} :
+    Function.Injective
+      ((middleBand X).restrictPreimage
+        (fun p : unitInterval × X => CuspCentralHomology.Suspension.mk p.1 p.2)) := by
+  intro p q h
+  have hmk :
+    CuspCentralHomology.Suspension.mk p.1.1 p.1.2 =
+      CuspCentralHomology.Suspension.mk q.1.1 q.1.2 :=
+    congrArg Subtype.val h
+  obtain ⟨ht, hx⟩ := (mk_eq_mk_iff _ _ _ _).mp hmk
+  have hp := middleCylinder_height_mo1973_4378 p
+  have hx' : p.1.2 = q.1.2 := by
+    rcases hx with h0 | h1 | hx
+    · have hz : (p.1.1 : ℝ) = 0 := congrArg Subtype.val h0
+      linarith [hp.1]
+    · have hz : (p.1.1 : ℝ) = 1 := congrArg Subtype.val h1
+      linarith [hp.2]
+    · exact hx
+  exact Subtype.ext (Prod.ext ht hx')
+
+private def
+    CuspCentralHomology.Suspension.middleBandQuotientHomeomorph {X : Type*} [TopologicalSpace X] :
+    middleCylinder X ≃ₜ middleBand X :=
+  ((isHomeomorph_iff_isQuotientMap_injective).mpr
+        ⟨isQuotientMap_mk.restrictPreimage_isOpen middleBand_isOpen,
+          middleBand_restrict_injective⟩).homeomorph
+    _
+
+private def
+    CuspCentralHomology.Suspension.middleCylinderHomeomorph {X : Type*} [TopologicalSpace X] :
+    middleCylinder X ≃ₜ (Set.Ioo (1 / 4 : ℝ) (3 / 4) × X)
+    where
+  toFun p := (⟨p.1.1, middleCylinder_height_mo1973_4378 p⟩, p.1.2)
+  invFun p := ⟨(⟨p.1, by constructor <;> linarith [p.1.2.1, p.1.2.2]⟩, p.2), p.1.2.2, p.1.2.1⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := by
+    apply Continuous.prodMk
+    · apply Continuous.subtype_mk
+      exact continuous_subtype_val.comp (continuous_fst.comp continuous_subtype_val)
+    · exact continuous_snd.comp continuous_subtype_val
+  continuous_invFun := by
+    apply Continuous.subtype_mk
+    apply Continuous.prodMk
+    · apply Continuous.subtype_mk
+      exact continuous_subtype_val.comp continuous_fst
+    · exact continuous_snd
+
+private def CuspCentralHomology.Suspension.middleBandHomeomorph {X : Type*} [TopologicalSpace X] :
+    middleBand X ≃ₜ (Set.Ioo (1 / 4 : ℝ) (3 / 4) × X) :=
+  middleBandQuotientHomeomorph.symm.trans middleCylinderHomeomorph
+
+private instance CuspCentralHomology.Suspension.middleInterval_contractibleSpace :
+    ContractibleSpace (Set.Ioo (1 / 4 : ℝ) (3 / 4)) :=
+  (convex_Ioo (1 / 4 : ℝ) (3 / 4)).contractibleSpace ⟨1 / 2, by norm_num⟩
+
+private def
+    CuspCentralHomology.Suspension.middleBandHomotopyEquiv {X : Type*} [TopologicalSpace X] :
+    middleBand X ≃ₕ X :=
+  middleBandHomeomorph.toHomotopyEquiv.trans
+    (((Classical.choice (ContractibleSpace.hequiv_unit (Set.Ioo (1 / 4 : ℝ) (3 / 4)))).prodCongr
+          (ContinuousMap.HomotopyEquiv.refl X)).trans
+      (Homeomorph.uniqueProd Unit X).toHomotopyEquiv)
+
+private theorem
+    CuspCentralHomology.Suspension.joined_north {X : Type*} [TopologicalSpace X] [Nonempty X]
+    (p : CuspCentralHomology.Suspension X) :
+    Joined (north : CuspCentralHomology.Suspension X) p := by
+  obtain ⟨⟨t, x⟩, rfl⟩ := mk_surjective p
+  refine
+    ⟨{  toFun := fun s : unitInterval => CuspCentralHomology.Suspension.mk (s * t) x
+        continuous_toFun := by
+          apply continuous_mk.comp (f := fun s : unitInterval => (s * t, x))
+          apply Continuous.prodMk
+          · apply Continuous.subtype_mk
+            exact continuous_subtype_val.mul continuous_const
+          · exact continuous_const
+        source' := by simp
+        target' := by simp }⟩
+
+private instance CuspCentralHomology.Suspension.suspension_pathConnectedSpace {X : Type*}
+    [TopologicalSpace X] [Nonempty X] : PathConnectedSpace (CuspCentralHomology.Suspension X)
+    where
+  nonempty := inferInstance
+  joined p q := (joined_north p).symm.trans (joined_north q)
+
+/-- A choice-based lift of a function along a surjection in its second coordinate. -/
+public
+def CuspCentralHomology.Suspension.liftFromSurjection {A B S Z : Type*}
+    (q : A → B) (hq : Function.Surjective q) (F : S × A → Z) (p : S × B) : Z :=
+  F (p.1, Function.surjInv hq p.2)
+
+private theorem CuspCentralHomology.Suspension.liftFromSurjection_comp_mo1973_4392
+    {A B S Z : Type*} (q : A → B) (hq : Function.Surjective q) (F : S × A → Z)
+    (hF : ∀ s a b, q a = q b → F (s, a) = F (s, b)) (s : S) (a : A) :
+    liftFromSurjection q hq F (s, q a) = F (s, a) :=
+  hF s _ _ (Function.surjInv_eq hq (q a))
+
+public
+theorem CuspCentralHomology.Suspension.liftFromSurjection_continuous_mo1973_4393
+    {A B S Z : Type*} [TopologicalSpace A] [TopologicalSpace B] [TopologicalSpace S]
+    [TopologicalSpace Z] [LocallyCompactSpace S] (q : A → B) (hq : Topology.IsQuotientMap q)
+    (F : S × A → Z) (hF : ∀ s a b, q a = q b → F (s, a) = F (s, b)) (hcont : Continuous F) :
+    Continuous (liftFromSurjection q hq.surjective F) := by
+  apply hq.continuous_lift_prod_right
+  convert hcont using 1
+  funext p
+  exact liftFromSurjection_comp_mo1973_4392 q hq.surjective F hF p.1 p.2
+
+private abbrev CuspCentralHomology.Suspension.NorthCylinder_mo1973_4394 (X : Type*)
+     :=
+  (fun p : unitInterval × X => CuspCentralHomology.Suspension.mk p.1 p.2) ⁻¹' northOpen
+
+private def CuspCentralHomology.Suspension.northProjection_mo1973_4395 {X : Type*}
+     :
+    NorthCylinder_mo1973_4394 X → (northOpen : Set (CuspCentralHomology.Suspension X)) :=
+  northOpen.restrictPreimage
+    (fun p : unitInterval × X => CuspCentralHomology.Suspension.mk p.1 p.2)
+
+private theorem CuspCentralHomology.Suspension.northProjection_isQuotientMap_mo1973_4396
+    {X : Type*} [TopologicalSpace X] :
+    Topology.IsQuotientMap (northProjection_mo1973_4395 (X := X)) :=
+  isQuotientMap_mk.restrictPreimage_isOpen northOpen_isOpen
+
+private def CuspCentralHomology.Suspension.northCylinderContraction_mo1973_4397 {X : Type*}
+     (p : unitInterval × NorthCylinder_mo1973_4394 X) :
+    (northOpen : Set (CuspCentralHomology.Suspension X)) :=
+  ⟨CuspCentralHomology.Suspension.mk (unitInterval.symm p.1 * p.2.1.1) p.2.1.2,
+    by
+    change ((unitInterval.symm p.1 * p.2.1.1 : unitInterval) : ℝ) < 3 / 4
+    exact lt_of_le_of_lt unitInterval.mul_le_right p.2.2⟩
+
+private theorem CuspCentralHomology.Suspension.northCylinderContraction_respects_mo1973_4398
+    {X : Type*} (s : unitInterval) (a b : NorthCylinder_mo1973_4394 X)
+    (h : northProjection_mo1973_4395 a = northProjection_mo1973_4395 b) :
+    northCylinderContraction_mo1973_4397 (s, a) = northCylinderContraction_mo1973_4397 (s, b) := by
+  apply Subtype.ext
+  have hab :
+    CuspCentralHomology.Suspension.mk a.1.1 a.1.2 =
+      CuspCentralHomology.Suspension.mk b.1.1 b.1.2 :=
+    congrArg Subtype.val h
+  rcases (mk_eq_mk_iff _ _ _ _).mp hab with ⟨ht, hzero | hone | hx⟩
+  · apply (mk_eq_mk_iff _ _ _ _).mpr
+    exact
+      ⟨congrArg (fun t => unitInterval.symm s * t) ht,
+        Or.inl (by rw [hzero, MulZeroClass.mul_zero])⟩
+  · have ha : (a.1.1 : ℝ) < 3 / 4 := a.2
+    rw [hone] at ha
+    norm_num at ha
+  · change
+      CuspCentralHomology.Suspension.mk (unitInterval.symm s * a.1.1) a.1.2 =
+        CuspCentralHomology.Suspension.mk (unitInterval.symm s * b.1.1) b.1.2
+    rw [ht, hx]
+
+private theorem CuspCentralHomology.Suspension.northCylinderContraction_continuous_mo1973_4399
+    {X : Type*} [TopologicalSpace X] :
+    Continuous (northCylinderContraction_mo1973_4397 (X := X)) := by
+  apply Continuous.subtype_mk
+  apply
+    continuous_mk.comp (f := fun p : unitInterval × NorthCylinder_mo1973_4394 X =>
+      (unitInterval.symm p.1 * p.2.1.1, p.2.1.2))
+  apply Continuous.prodMk
+  · apply Continuous.subtype_mk
+    exact
+      (continuous_const.sub (continuous_subtype_val.comp continuous_fst)).mul
+        (continuous_subtype_val.comp
+          (continuous_fst.comp (continuous_subtype_val.comp continuous_snd)))
+  · exact continuous_snd.comp (continuous_subtype_val.comp continuous_snd)
+
+private def CuspCentralHomology.Suspension.northContract_mo1973_4400 {X : Type*}
+    [TopologicalSpace X] :
+    unitInterval × (northOpen : Set (CuspCentralHomology.Suspension X)) →
+      (northOpen : Set (CuspCentralHomology.Suspension X)) :=
+  liftFromSurjection northProjection_mo1973_4395
+    northProjection_isQuotientMap_mo1973_4396.surjective northCylinderContraction_mo1973_4397
+
+private theorem CuspCentralHomology.Suspension.northContract_projection_mo1973_4401 {X : Type*}
+    [TopologicalSpace X] (s : unitInterval) (a : NorthCylinder_mo1973_4394 X) :
+    northContract_mo1973_4400 (s, northProjection_mo1973_4395 a) =
+      northCylinderContraction_mo1973_4397 (s, a) :=
+  liftFromSurjection_comp_mo1973_4392 _ _ _ northCylinderContraction_respects_mo1973_4398 s a
+
+private theorem CuspCentralHomology.Suspension.northContract_continuous_mo1973_4402 {X : Type*}
+    [TopologicalSpace X] : Continuous (northContract_mo1973_4400 (X := X)) :=
+  liftFromSurjection_continuous_mo1973_4393 _ northProjection_isQuotientMap_mo1973_4396 _
+    northCylinderContraction_respects_mo1973_4398 northCylinderContraction_continuous_mo1973_4399
+
+private def CuspCentralHomology.Suspension.northContraction {X : Type*} [TopologicalSpace X]
+    [Nonempty X] :
+    ContinuousMap.Homotopy (ContinuousMap.id (northOpen : Set (CuspCentralHomology.Suspension X)))
+      (ContinuousMap.const _ ⟨north, north_mem_northOpen⟩)
+    where
+  toFun := northContract_mo1973_4400
+  continuous_toFun := northContract_continuous_mo1973_4402
+  map_zero_left
+    q := by
+    obtain ⟨a, rfl⟩ := northProjection_isQuotientMap_mo1973_4396.surjective q
+    rw [northContract_projection_mo1973_4401]
+    apply Subtype.ext
+    change
+      CuspCentralHomology.Suspension.mk (unitInterval.symm 0 * a.1.1) a.1.2 =
+        CuspCentralHomology.Suspension.mk a.1.1 a.1.2
+    simp
+  map_one_left
+    q := by
+    obtain ⟨a, rfl⟩ := northProjection_isQuotientMap_mo1973_4396.surjective q
+    rw [northContract_projection_mo1973_4401]
+    apply Subtype.ext
+    change CuspCentralHomology.Suspension.mk (unitInterval.symm 1 * a.1.1) a.1.2 = north
+    simp
+
+private instance CuspCentralHomology.Suspension.northOpen_contractibleSpace {X : Type*}
+    [TopologicalSpace X] [Nonempty X] :
+    ContractibleSpace (northOpen : Set (CuspCentralHomology.Suspension X)) :=
+  (contractible_iff_id_nullhomotopic _).mpr ⟨⟨north, north_mem_northOpen⟩, ⟨northContraction⟩⟩
+
+private abbrev CuspCentralHomology.Suspension.SouthCylinder_mo1973_4406 (X : Type*)
+     :=
+  (fun p : unitInterval × X => CuspCentralHomology.Suspension.mk p.1 p.2) ⁻¹' southOpen
+
+private def CuspCentralHomology.Suspension.southProjection_mo1973_4407 {X : Type*}
+     :
+    SouthCylinder_mo1973_4406 X → (southOpen : Set (CuspCentralHomology.Suspension X)) :=
+  southOpen.restrictPreimage
+    (fun p : unitInterval × X => CuspCentralHomology.Suspension.mk p.1 p.2)
+
+private theorem CuspCentralHomology.Suspension.southProjection_isQuotientMap_mo1973_4408
+    {X : Type*} [TopologicalSpace X] :
+    Topology.IsQuotientMap (southProjection_mo1973_4407 (X := X)) :=
+  isQuotientMap_mk.restrictPreimage_isOpen southOpen_isOpen
+
+private def CuspCentralHomology.Suspension.southCylinderContraction_mo1973_4409 {X : Type*}
+     (p : unitInterval × SouthCylinder_mo1973_4406 X) :
+    (southOpen : Set (CuspCentralHomology.Suspension X)) :=
+  ⟨CuspCentralHomology.Suspension.mk
+      (unitInterval.symm (unitInterval.symm p.1 * unitInterval.symm p.2.1.1)) p.2.1.2,
+    by
+    change
+      1 / 4 <
+        ((unitInterval.symm (unitInterval.symm p.1 * unitInterval.symm p.2.1.1) : unitInterval) :
+          ℝ)
+    have hle : unitInterval.symm p.1 * unitInterval.symm p.2.1.1 ≤ unitInterval.symm p.2.1.1 :=
+      unitInterval.mul_le_right
+    have hbound :
+      p.2.1.1 ≤ unitInterval.symm (unitInterval.symm p.1 * unitInterval.symm p.2.1.1) :=
+      unitInterval.le_symm_comm.mpr hle
+    exact lt_of_lt_of_le p.2.2 hbound⟩
+
+private theorem CuspCentralHomology.Suspension.southCylinderContraction_respects_mo1973_4410
+    {X : Type*} (s : unitInterval) (a b : SouthCylinder_mo1973_4406 X)
+    (h : southProjection_mo1973_4407 a = southProjection_mo1973_4407 b) :
+    southCylinderContraction_mo1973_4409 (s, a) = southCylinderContraction_mo1973_4409 (s, b) := by
+  apply Subtype.ext
+  have hab :
+    CuspCentralHomology.Suspension.mk a.1.1 a.1.2 =
+      CuspCentralHomology.Suspension.mk b.1.1 b.1.2 :=
+    congrArg Subtype.val h
+  rcases (mk_eq_mk_iff _ _ _ _).mp hab with ⟨ht, hzero | hone | hx⟩
+  · have ha : 1 / 4 < (a.1.1 : ℝ) := a.2
+    rw [hzero] at ha
+    norm_num at ha
+  · apply (mk_eq_mk_iff _ _ _ _).mpr
+    refine
+      ⟨congrArg (fun t => unitInterval.symm (unitInterval.symm s * unitInterval.symm t)) ht,
+        Or.inr (Or.inl ?_)⟩
+    simp [hone]
+  · change
+      CuspCentralHomology.Suspension.mk
+          (unitInterval.symm (unitInterval.symm s * unitInterval.symm a.1.1)) a.1.2 =
+        CuspCentralHomology.Suspension.mk
+          (unitInterval.symm (unitInterval.symm s * unitInterval.symm b.1.1)) b.1.2
+    rw [ht, hx]
+
+private theorem CuspCentralHomology.Suspension.southCylinderContraction_continuous_mo1973_4411
+    {X : Type*} [TopologicalSpace X] :
+    Continuous (southCylinderContraction_mo1973_4409 (X := X)) := by
+  apply Continuous.subtype_mk
+  apply
+    continuous_mk.comp (f := fun p : unitInterval × SouthCylinder_mo1973_4406 X =>
+      (unitInterval.symm (unitInterval.symm p.1 * unitInterval.symm p.2.1.1), p.2.1.2))
+  apply Continuous.prodMk
+  · apply Continuous.subtype_mk
+    exact
+      continuous_const.sub
+        ((continuous_const.sub (continuous_subtype_val.comp continuous_fst)).mul
+          (continuous_const.sub
+            (continuous_subtype_val.comp
+              (continuous_fst.comp (continuous_subtype_val.comp continuous_snd)))))
+  · exact continuous_snd.comp (continuous_subtype_val.comp continuous_snd)
+
+private def CuspCentralHomology.Suspension.southContract_mo1973_4412 {X : Type*}
+    [TopologicalSpace X] :
+    unitInterval × (southOpen : Set (CuspCentralHomology.Suspension X)) →
+      (southOpen : Set (CuspCentralHomology.Suspension X)) :=
+  liftFromSurjection southProjection_mo1973_4407
+    southProjection_isQuotientMap_mo1973_4408.surjective southCylinderContraction_mo1973_4409
+
+private theorem CuspCentralHomology.Suspension.southContract_projection_mo1973_4413 {X : Type*}
+    [TopologicalSpace X] (s : unitInterval) (a : SouthCylinder_mo1973_4406 X) :
+    southContract_mo1973_4412 (s, southProjection_mo1973_4407 a) =
+      southCylinderContraction_mo1973_4409 (s, a) :=
+  liftFromSurjection_comp_mo1973_4392 _ _ _ southCylinderContraction_respects_mo1973_4410 s a
+
+private theorem CuspCentralHomology.Suspension.southContract_continuous_mo1973_4414 {X : Type*}
+    [TopologicalSpace X] : Continuous (southContract_mo1973_4412 (X := X)) :=
+  liftFromSurjection_continuous_mo1973_4393 _ southProjection_isQuotientMap_mo1973_4408 _
+    southCylinderContraction_respects_mo1973_4410 southCylinderContraction_continuous_mo1973_4411
+
+private def CuspCentralHomology.Suspension.southContraction {X : Type*} [TopologicalSpace X]
+    [Nonempty X] :
+    ContinuousMap.Homotopy (ContinuousMap.id (southOpen : Set (CuspCentralHomology.Suspension X)))
+      (ContinuousMap.const _ ⟨south, south_mem_southOpen⟩)
+    where
+  toFun := southContract_mo1973_4412
+  continuous_toFun := southContract_continuous_mo1973_4414
+  map_zero_left
+    q := by
+    obtain ⟨a, rfl⟩ := southProjection_isQuotientMap_mo1973_4408.surjective q
+    rw [southContract_projection_mo1973_4413]
+    apply Subtype.ext
+    change
+      CuspCentralHomology.Suspension.mk
+          (unitInterval.symm (unitInterval.symm 0 * unitInterval.symm a.1.1)) a.1.2 =
+        CuspCentralHomology.Suspension.mk a.1.1 a.1.2
+    simp
+  map_one_left
+    q := by
+    obtain ⟨a, rfl⟩ := southProjection_isQuotientMap_mo1973_4408.surjective q
+    rw [southContract_projection_mo1973_4413]
+    apply Subtype.ext
+    change
+      CuspCentralHomology.Suspension.mk
+          (unitInterval.symm (unitInterval.symm 1 * unitInterval.symm a.1.1)) a.1.2 =
+        south
+    simp
+
+private instance CuspCentralHomology.Suspension.southOpen_contractibleSpace {X : Type*}
+    [TopologicalSpace X] [Nonempty X] :
+    ContractibleSpace (southOpen : Set (CuspCentralHomology.Suspension X)) :=
+  (contractible_iff_id_nullhomotopic _).mpr ⟨⟨south, south_mem_southOpen⟩, ⟨southContraction⟩⟩
+
+@[simp]
+private theorem CuspCentralHomology.Suspension.middleBandHomotopyEquiv_apply {X : Type*}
+    [TopologicalSpace X] (p : middleBand X) :
+    middleBandHomotopyEquiv p = (middleBandHomeomorph p).2 :=
+  rfl
+
+private instance
+    CuspCentralHomology.Suspension.suspension_compactSpace {X : Type*} [TopologicalSpace X]
+    [CompactSpace X] : CompactSpace (CuspCentralHomology.Suspension X) :=
+  mk_surjective.compactSpace continuous_mk
+
+private theorem
+    CuspCentralHomology.contractibleCoverConnecting_injective {X : Type} [TopologicalSpace X]
+    (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ)
+    [ContractibleSpace U] [ContractibleSpace V] (n : ℕ) :
+    Function.Injective (SingularMayerVietoris.connectingHomomorphism U V hU hV hcover n) := by
+  let :=
+    PeriodTorusHigherHomology.contractible_homology_subsingleton U (n + 1) (Nat.succ_ne_zero _)
+  let :=
+    PeriodTorusHigherHomology.contractible_homology_subsingleton V (n + 1) (Nat.succ_ne_zero _)
+  apply LinearMap.ker_eq_bot.mp
+  rw [← SingularMayerVietoris.exact_at_ambient U V hU hV hcover n]
+  apply LinearMap.range_eq_bot.mpr
+  apply LinearMap.ext
+  intro a
+  have ha : a = 0 := Subsingleton.elim _ _
+  rw [ha, map_zero, LinearMap.zero_apply]
+
+private theorem
+    CuspCentralHomology.contractibleCoverConnecting_surjective {X : Type} [TopologicalSpace X]
+    (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ)
+    [ContractibleSpace U] [ContractibleSpace V] (n : ℕ) :
+    Function.Surjective (SingularMayerVietoris.connectingHomomorphism U V hU hV hcover (n + 1)) :=
+  by
+  let :=
+    PeriodTorusHigherHomology.contractible_homology_subsingleton U (n + 1) (Nat.succ_ne_zero _)
+  let :=
+    PeriodTorusHigherHomology.contractible_homology_subsingleton V (n + 1) (Nat.succ_ne_zero _)
+  intro a
+  have ha : a ∈ LinearMap.ker (SingularMayerVietoris.leftHomologyMap U V (n + 1)) := by
+    exact Subsingleton.elim _ _
+  rw [← SingularMayerVietoris.exact_at_intersection U V hU hV hcover (n + 1)] at ha
+  exact ha
+
+private def CuspCentralHomology.contractibleCoverHomologyHigherEquiv {X : Type} [TopologicalSpace X]
+    (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ)
+    [ContractibleSpace U] [ContractibleSpace V] (n : ℕ) :
+    SingularMayerVietoris.SingularHomology X (n + 2) ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (U ∩ V : Set X) (n + 1) :=
+  LinearEquiv.ofBijective (SingularMayerVietoris.connectingHomomorphism U V hU hV hcover (n + 1))
+    ⟨contractibleCoverConnecting_injective U V hU hV hcover (n + 1),
+      contractibleCoverConnecting_surjective U V hU hV hcover n⟩
+
+private def CuspCentralHomology.contractibleCoverConnectingToKernel {X : Type} [TopologicalSpace X]
+    (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) :
+    SingularMayerVietoris.SingularHomology X 1 →ₗ[ℤ]
+      LinearMap.ker (SingularMayerVietoris.leftHomologyMap U V 0) :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    ((SingularMayerVietoris.connectingHomomorphism U V hU hV hcover 0).codRestrict
+        (LinearMap.ker (SingularMayerVietoris.leftHomologyMap U V 0))
+        (by
+          intro a
+          rw [← SingularMayerVietoris.exact_at_intersection U V hU hV hcover 0]
+          exact ⟨a, rfl⟩)).toAddMonoidHom
+
+private theorem CuspCentralHomology.contractibleCoverConnectingToKernel_bijective {X : Type}
+    [TopologicalSpace X] (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ)
+    [ContractibleSpace U] [ContractibleSpace V] :
+    Function.Bijective (contractibleCoverConnectingToKernel U V hU hV hcover) := by
+  constructor
+  · intro a b hab
+    apply contractibleCoverConnecting_injective U V hU hV hcover 0
+    exact congrArg Subtype.val hab
+  · intro a
+    have ha :
+      (a : SingularMayerVietoris.SingularHomology (U ∩ V : Set X) 0) ∈
+        LinearMap.range (SingularMayerVietoris.connectingHomomorphism U V hU hV hcover 0) :=
+      (SingularMayerVietoris.exact_at_intersection U V hU hV hcover 0).symm.le a.property
+    obtain ⟨b, hb⟩ := ha
+    exact ⟨b, Subtype.ext hb⟩
+
+private def
+    CuspCentralHomology.contractibleCoverHomologyOneEquivKernel {X : Type} [TopologicalSpace X]
+    (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ)
+    [ContractibleSpace U] [ContractibleSpace V] :
+    SingularMayerVietoris.SingularHomology X 1 ≃ₗ[ℤ]
+      LinearMap.ker (SingularMayerVietoris.leftHomologyMap U V 0) :=
+  LinearEquiv.ofBijective (contractibleCoverConnectingToKernel U V hU hV hcover)
+    (contractibleCoverConnectingToKernel_bijective U V hU hV hcover)
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/CuspFibre/CuspCentralHomology3.lean b/LeanPool/HopfProblem/CuspFibre/CuspCentralHomology3.lean
new file mode 100644
index 000000000..164d81267
--- /dev/null
+++ b/LeanPool/HopfProblem/CuspFibre/CuspCentralHomology3.lean
@@ -0,0 +1,5726 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology7
+public import LeanPool.HopfProblem.CuspFibre.CuspCentralHomology1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.CuspFibre.CuspCentralHomology2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology3
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology4
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.Toric.ToricSpace2
+import all LeanPool.HopfProblem.CuspFibre.CuspPositiveRetraction
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+import all LeanPool.HopfProblem.Toric.CuspHoneycombHexagon
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology7
+import all LeanPool.HopfProblem.CuspFibre.CuspCentralHomology1
+
+/-!
+# Hopf problem: cusp fibre · cusp central homology 3
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem
+    CuspCentralHomology.central_pathConnectedSpace (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) : PathConnectedSpace (CuspRetraction.QuotientCentralFibre C r) := by
+  exact
+    (CuspHoneycomb.honeycombCollapseMap_surjective C r hr).pathConnectedSpace
+      (CuspHoneycomb.honeycombCollapseMap_continuous C r hr)
+
+private def
+    CuspCentralHomology.centralBasePoint (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) :
+    CuspRetraction.QuotientCentralFibre C r :=
+  CuspHoneycomb.honeycombCollapseMap C r hr (1, 0)
+
+private def CuspCentralHomology.centralSingularH0Equiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) :
+    SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 0 ≃ₗ[ℤ] ℤ := by
+  let := central_pathConnectedSpace C r hr
+  exact
+    PeriodTorusHigherHomology.connectedHomologyZeroEquiv (CuspRetraction.QuotientCentralFibre C r)
+
+private theorem
+    CuspCentralHomology.centralSingularH0Equiv_natural (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) {X : Type} [TopologicalSpace X] [PathConnectedSpace X]
+    (f : C(X, CuspRetraction.QuotientCentralFibre C r))
+    (a : SingularMayerVietoris.SingularHomology X 0) :
+    centralSingularH0Equiv C r hr (SingularMayerVietoris.singularHomologyMap f 0 a) =
+      PeriodTorusHigherHomology.connectedHomologyZeroEquiv X a := by
+  let := central_pathConnectedSpace C r hr
+  exact PeriodTorusHigherHomology.connectedHomologyZeroEquiv_natural f a
+
+private structure CuspCentralHomology.SmallCentralModel (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) where
+  radius : ℝ
+  radius_pos : 0 < radius
+  radius_lt : radius < r
+  radius_lt_one : radius < 1
+  smallDrift : ToricSpace.SmallDrift C radius
+  equivalence : CuspRetraction.QuotientCentralFibre C r ≃ₕ CuspQuotient.QuotientSpace C radius
+  inclusion_eq :
+    equivalence.toFun = centralIntoSmallerQuotient C r radius radius_pos radius_lt.le hC
+
+private theorem
+    CuspCentralHomology.exists_smallCentralModel (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Nonempty (SmallCentralModel C r hC) := by
+  obtain ⟨δ₀, hδ₀, hδ₀r, _hδ₀1, he⟩ := exists_centralHomotopyEquiv C r hr hC
+  have hCδ₀ : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 δ₀) := fun i j =>
+    (hC i j).mono (Metric.ball_subset_ball hδ₀r.le)
+  obtain ⟨δ, hδ, hδδ₀, hδ1, hR, _hCδ⟩ := CuspQuotient.exists_admissible_radius C hδ₀ hCδ₀
+  have hδr := hδδ₀.trans hδ₀r
+  obtain ⟨e, he⟩ := he δ hδ hδδ₀.le hδr.le
+  exact ⟨⟨δ, hδ, hδr, hδ1, hR, e, he⟩⟩
+
+private def
+    CuspCentralHomology.smallCentralModel (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    SmallCentralModel C r hC :=
+  Classical.choice (exists_smallCentralModel C r hr hC)
+
+private theorem CuspCentralHomology.SmallCentralModel.holomorphic {C : ℂ → Matrix (Fin 2) (Fin 2) ℂ}
+    {r : ℝ} {hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)}
+    (M : CuspCentralHomology.SmallCentralModel C r hC) :
+    ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 M.radius) := fun i j =>
+  (hC i j).mono (Metric.ball_subset_ball M.radius_lt.le)
+
+private def CuspCentralHomology.SmallCentralModel.singularH1Equiv {C : ℂ → Matrix (Fin 2) (Fin 2) ℂ}
+    {r : ℝ} {hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)}
+    (M : CuspCentralHomology.SmallCentralModel C r hC)
+    (q : CuspRetraction.QuotientCentralFibre C r) :
+    SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 1 ≃ₗ[ℤ]
+      (Fin 2 → ℤ) :=
+  (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv M.equivalence 1).trans
+    (CuspQuotient.singularH1Equiv C M.radius M.radius_pos M.radius_lt_one M.holomorphic
+      M.smallDrift (M.equivalence q))
+
+private def CuspCentralHomology.centralSingularH1Equiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 1 ≃ₗ[ℤ]
+      (Fin 2 → ℤ) :=
+  (smallCentralModel C r hr hC).singularH1Equiv (centralBasePoint C r hr)
+
+private theorem
+    CuspCentralHomology.centralSingularH1_free (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Module.Free ℤ
+      (SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 1) :=
+  Module.Free.of_equiv (centralSingularH1Equiv C r hr hC).symm
+
+private theorem
+    CuspCentralHomology.centralSingularH1_finite (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Module.Finite ℤ
+      (SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 1) :=
+  Module.Finite.of_surjective (centralSingularH1Equiv C r hr hC).symm.toLinearMap
+    (centralSingularH1Equiv C r hr hC).symm.surjective
+
+private theorem
+    CuspCentralHomology.centralSingularH1_finrank (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Module.finrank ℤ
+        (SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 1) =
+      2 := by
+  rw [(centralSingularH1Equiv C r hr hC).finrank_eq]
+  simp
+
+private def
+    CuspCentralHomology.edgeCharacter (n : Fin 2 → ℤ) : ToricSpace.CompactFibreTorus →* Circle
+    where
+  toFun u := u 0 ^ (-n 1) * u 1 ^ n 0
+  map_one' := by simp
+  map_mul' u
+    v := by
+    simp only [Pi.mul_apply, mul_zpow]
+    ac_rfl
+
+private theorem CuspCentralHomology.edgeCharacter_continuous (n : Fin 2 → ℤ) :
+    Continuous (edgeCharacter n) :=
+  ((continuous_apply 0).zpow (-n 1)).mul ((continuous_apply 1).zpow (n 0))
+
+private theorem CuspCentralHomology.edgeCharacter_edgeCompactPhase (n m : Fin 2 → ℤ) (a : Circle) :
+    edgeCharacter n (ToricSpace.edgeCompactPhase m a) = a ^ (n 0 * m 1 - n 1 * m 0) := by
+  change (a ^ m 0) ^ (-n 1) * (a ^ m 1) ^ n 0 = _
+  rw [← zpow_mul, ← zpow_mul, ← zpow_add]
+  congr 1
+  ring
+
+@[simp]
+private theorem CuspCentralHomology.edgeCharacter_own_phase (n : Fin 2 → ℤ) (a : Circle) :
+    edgeCharacter n (ToricSpace.edgeCompactPhase n a) = 1 := by
+  rw [edgeCharacter_edgeCompactPhase]
+  simp [mul_comm]
+
+private abbrev CuspCentralHomology.hexagonCharacter (k : Fin 6) :
+    ToricSpace.CompactFibreTorus →* Circle :=
+  edgeCharacter (ToricComponent.hexagonRay k)
+
+private def CuspCentralHomology.hexagonCharacterSection (k : Fin 6) :
+    Circle →* ToricSpace.CompactFibreTorus :=
+  ToricSpace.edgeCompactPhase (ToricComponent.hexagonRay (k + 1))
+
+private theorem CuspCentralHomology.hexagonCharacterSection_continuous (k : Fin 6) :
+    Continuous (hexagonCharacterSection k) :=
+  ToricSpace.edgeCompactPhase_continuous _
+
+@[simp]
+private theorem CuspCentralHomology.hexagonCharacter_section (k : Fin 6) (a : Circle) :
+    hexagonCharacter k (hexagonCharacterSection k a) = a := by
+  rw [hexagonCharacterSection, edgeCharacter_edgeCompactPhase]
+  have hd :
+    ToricComponent.hexagonRay k 0 * ToricComponent.hexagonRay (k + 1) 1 -
+        ToricComponent.hexagonRay k 1 * ToricComponent.hexagonRay (k + 1) 0 =
+      1 := by fin_cases k <;> decide
+  rw [hd, zpow_one]
+
+private theorem CuspCentralHomology.hexagonCharacter_decomposition (k : Fin 6)
+    (u : ToricSpace.CompactFibreTorus) :
+    ToricSpace.edgeCompactPhase (ToricComponent.hexagonRay k) ((hexagonCharacter (k + 1) u)⁻¹) *
+        hexagonCharacterSection k (hexagonCharacter k u) =
+      u := by
+  funext i
+  fin_cases k <;> fin_cases i <;>
+    simp [hexagonCharacter, edgeCharacter, hexagonCharacterSection, ToricSpace.edgeCompactPhase,
+      ToricComponent.hexagonRay]
+
+private theorem CuspCentralHomology.ker_hexagonCharacter (k : Fin 6) :
+    (hexagonCharacter k).ker = ToricSpace.edgeCircle (ToricComponent.hexagonRay k) := by
+  ext u
+  constructor
+  · intro hu
+    change hexagonCharacter k u = 1 at hu
+    change ∃ a : Circle, ToricSpace.edgeCompactPhase (ToricComponent.hexagonRay k) a = u
+    refine ⟨(hexagonCharacter (k + 1) u)⁻¹, ?_⟩
+    simpa only [hu, map_one, mul_one] using hexagonCharacter_decomposition k u
+  · rintro ⟨a, rfl⟩
+    exact edgeCharacter_own_phase (ToricComponent.hexagonRay k) a
+
+private theorem CuspCentralHomology.hexagonCharacter_eq_iff (k : Fin 6)
+    (u v : ToricSpace.CompactFibreTorus) :
+    hexagonCharacter k u = hexagonCharacter k v ↔
+      u⁻¹ * v ∈ ToricSpace.edgeCircle (ToricComponent.hexagonRay k) := by
+  rw [← ker_hexagonCharacter, MonoidHom.mem_ker, map_mul, map_inv, inv_mul_eq_one]
+
+private theorem CuspCentralHomology.chartPoint_stabilizer_fst_zero (i : Fin 6)
+    (z : ToricCharts.CoordinateSpace 2) (hz0 : z 0 = 0) (hz1 : z 1 ≠ 0) :
+    MulAction.stabilizer ToricSpace.CompactFibreTorus
+        (CuspHoneycombHexagon.chartPoint i z : ToricSpace.Space) =
+      ToricSpace.edgeCircle (ToricComponent.hexagonRay i) := by
+  have hne : ToricComponent.zeroCoordinate i ≠ CuspHoneycombHexagon.firstCoordinate i := by
+    intro h
+    have hv := congrArg (ToricComponent.zeroTriangle i).vertex h
+    rw [ToricComponent.zeroTriangle_vertex, CuspHoneycombHexagon.firstCoordinate_vertex] at hv
+    exact ToricComponent.hexagonRay_ne_zero i hv.symm
+  have hrest (j : Fin 3) (hj0 : j ≠ ToricComponent.zeroCoordinate i)
+    (hj1 : j ≠ CuspHoneycombHexagon.firstCoordinate i) :
+    CuspHoneycombHexagon.liftCoordinates i z j ≠ 0 := by
+    rcases CuspHoneycombHexagon.coordinates_exhaustive i j with h | h | h
+    · exact (hj0 h).elim
+    · exact (hj1 h).elim
+    · subst j
+      simpa only [CuspHoneycombHexagon.liftCoordinates_second] using hz1
+  rw [CuspHoneycombHexagon.chartPoint_coe]
+  have h :=
+    ToricSpace.compactFibre_stabilizer_eq_edgeCircle_of_two_zero (ToricComponent.zeroTriangle i)
+      (CuspHoneycombHexagon.liftCoordinates i z) (ToricComponent.zeroCoordinate i)
+      (CuspHoneycombHexagon.firstCoordinate i) hne (CuspHoneycombHexagon.liftCoordinates_zero i z)
+      (by simpa only [CuspHoneycombHexagon.liftCoordinates_first] using hz0) hrest
+  simpa only [CuspHoneycombHexagon.firstCoordinate_vertex, ToricComponent.zeroTriangle_vertex,
+    sub_zero] using h
+
+private theorem CuspCentralHomology.chartPoint_stabilizer_snd_zero (i : Fin 6)
+    (z : ToricCharts.CoordinateSpace 2) (hz0 : z 0 ≠ 0) (hz1 : z 1 = 0) :
+    MulAction.stabilizer ToricSpace.CompactFibreTorus
+        (CuspHoneycombHexagon.chartPoint i z : ToricSpace.Space) =
+      ToricSpace.edgeCircle (ToricComponent.hexagonRay (i + 1)) := by
+  have hne : ToricComponent.zeroCoordinate i ≠ CuspHoneycombHexagon.secondCoordinate i := by
+    intro h
+    have hv := congrArg (ToricComponent.zeroTriangle i).vertex h
+    rw [ToricComponent.zeroTriangle_vertex, CuspHoneycombHexagon.secondCoordinate_vertex] at hv
+    exact ToricComponent.hexagonRay_ne_zero (i + 1) hv.symm
+  have hrest (j : Fin 3) (hj0 : j ≠ ToricComponent.zeroCoordinate i)
+    (hj1 : j ≠ CuspHoneycombHexagon.secondCoordinate i) :
+    CuspHoneycombHexagon.liftCoordinates i z j ≠ 0 := by
+    rcases CuspHoneycombHexagon.coordinates_exhaustive i j with h | h | h
+    · exact (hj0 h).elim
+    · subst j
+      simpa only [CuspHoneycombHexagon.liftCoordinates_first] using hz0
+    · exact (hj1 h).elim
+  rw [CuspHoneycombHexagon.chartPoint_coe]
+  have h :=
+    ToricSpace.compactFibre_stabilizer_eq_edgeCircle_of_two_zero (ToricComponent.zeroTriangle i)
+      (CuspHoneycombHexagon.liftCoordinates i z) (ToricComponent.zeroCoordinate i)
+      (CuspHoneycombHexagon.secondCoordinate i) hne
+      (CuspHoneycombHexagon.liftCoordinates_zero i z)
+      (by simpa only [CuspHoneycombHexagon.liftCoordinates_second] using hz1) hrest
+  simpa only [CuspHoneycombHexagon.secondCoordinate_vertex, ToricComponent.zeroTriangle_vertex,
+    sub_zero] using h
+
+private theorem CuspCentralHomology.positiveBoundary_stabilizer_eq_edgeCircle (k : Fin 6)
+    (q : CuspHoneycombHexagon.positiveBoundary k)
+    (hprev : q.1 ≠ CuspHoneycombHexagon.squarePoint (k - 1) CuspHoneycombHexagon.cornerZero)
+    (hcurr : q.1 ≠ CuspHoneycombHexagon.squarePoint k CuspHoneycombHexagon.cornerZero) :
+    MulAction.stabilizer ToricSpace.CompactFibreTorus (q.1.1 : ToricSpace.Space) =
+      ToricSpace.edgeCircle (ToricComponent.hexagonRay k) := by
+  obtain ⟨i, z, he⟩ := CuspHoneycombHexagon.chartPoint_jointly_surjective q.1.1
+  have hqzero (hz0 : z 0 = 0) (hz1 : z 1 = 0) :
+    q.1 = CuspHoneycombHexagon.squarePoint i CuspHoneycombHexagon.cornerZero := by
+    apply Subtype.ext
+    change
+      q.1.1 =
+        CuspHoneycombHexagon.chartPoint i (fun j => (CuspHoneycombHexagon.cornerZero.1 j : ℂ))
+    rw [← he]
+    apply congrArg (CuspHoneycombHexagon.chartPoint i)
+    funext j
+    fin_cases j
+    · change z 0 = 0
+      exact hz0
+    · change z 1 = 0
+      exact hz1
+  have hb :
+    (CuspHoneycombHexagon.chartPoint i z : ToricSpace.Space) ∈
+      ToricSpace.rayDivisor (ToricComponent.hexagonRay k) := by
+    rw [he]
+    exact q.property
+  rcases (CuspHoneycombHexagon.chartPoint_mem_rayDivisor_iff i k z).mp hb with ⟨rfl, hz0⟩ |
+    ⟨rfl, hz1⟩
+  · have hz1 : z 1 ≠ 0 := fun hz1 => hcurr (hqzero hz0 hz1)
+    rw [← he]
+    exact chartPoint_stabilizer_fst_zero k z hz0 hz1
+  · have hz0 : z 0 ≠ 0 := by
+      intro hz0
+      apply hprev
+      simpa only [add_sub_cancel_right] using hqzero hz0 hz1
+    rw [← he]
+    exact chartPoint_stabilizer_snd_zero i z hz0 hz1
+
+private theorem CuspCentralHomology.compatibleBoundaryArc_stabilizer (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) (t : unitInterval) (ht0 : t ≠ 0) (ht1 : t ≠ 1) :
+    MulAction.stabilizer ToricSpace.CompactFibreTorus
+        ((CuspHoneycombHexagon.compatibleBoundaryArc C₀ k t).1.1 : ToricSpace.Space) =
+      ToricSpace.edgeCircle (ToricComponent.hexagonRay k) := by
+  apply
+    positiveBoundary_stabilizer_eq_edgeCircle k
+      (CuspHoneycombHexagon.compatibleBoundaryArc C₀ k t)
+  · intro h
+    apply ht0
+    apply (CuspHoneycombHexagon.compatibleBoundaryArc C₀ k).injective
+    apply Subtype.ext
+    exact h.trans (CuspHoneycombHexagon.compatibleBoundaryArc_zero_point C₀ k).symm
+  · intro h
+    apply ht1
+    apply (CuspHoneycombHexagon.compatibleBoundaryArc C₀ k).injective
+    apply Subtype.ext
+    exact h.trans (CuspHoneycombHexagon.compatibleBoundaryArc_one_point C₀ k).symm
+
+private def CuspCollapse.centralPhaseOrbit (q : CuspPositiveRetraction.PositiveCentralFibre)
+    (u : ToricSpace.CompactFibreTorus) : CuspRetraction.CentralFibre :=
+  centralPolarMap (u, q)
+
+@[simp]
+private theorem
+    CuspCollapse.centralPhaseOrbit_apply (q : CuspPositiveRetraction.PositiveCentralFibre)
+    (u : ToricSpace.CompactFibreTorus) : centralPhaseOrbit q u = centralPolarMap (u, q) :=
+  rfl
+
+private abbrev CuspCollapse.CentralModulusFibre (q : CuspPositiveRetraction.PositiveCentralFibre) :=
+  { x : CuspRetraction.CentralFibre // centralModulus x = q }
+
+private def CuspCollapse.centralPhaseOrbitToFibre (q : CuspPositiveRetraction.PositiveCentralFibre)
+    (u : ToricSpace.CompactFibreTorus) : CentralModulusFibre q :=
+  ⟨centralPhaseOrbit q u, centralModulus_centralPolarMap (u, q)⟩
+
+private theorem CuspCentralHomology.centralPhaseOrbit_eq_iff_character (k : Fin 6)
+    (q : CuspPositiveRetraction.PositiveCentralFibre)
+    (hq :
+      MulAction.stabilizer ToricSpace.CompactFibreTorus (q.1 : ToricSpace.Space) =
+        ToricSpace.edgeCircle (ToricComponent.hexagonRay k))
+    (u v : ToricSpace.CompactFibreTorus) :
+    CuspCollapse.centralPhaseOrbit q u = CuspCollapse.centralPhaseOrbit q v ↔
+      hexagonCharacter k u = hexagonCharacter k v := by
+  rw [CuspCollapse.centralPhaseOrbit_apply, CuspCollapse.centralPhaseOrbit_apply,
+    CuspCollapse.centralPolarMap_eq_iff]
+  simp only [true_and, hq]
+  exact (hexagonCharacter_eq_iff k u v).symm
+
+private def CuspCentralHomology.characterCircleOrbit (k : Fin 6)
+    (q : CuspPositiveRetraction.PositiveCentralFibre) (a : Circle) :
+    CuspCollapse.CentralModulusFibre q :=
+  CuspCollapse.centralPhaseOrbitToFibre q (hexagonCharacterSection k a)
+
+private theorem CuspCentralHomology.characterCircleOrbit_character (k : Fin 6)
+    (q : CuspPositiveRetraction.PositiveCentralFibre)
+    (hq :
+      MulAction.stabilizer ToricSpace.CompactFibreTorus (q.1 : ToricSpace.Space) =
+        ToricSpace.edgeCircle (ToricComponent.hexagonRay k))
+    (u : ToricSpace.CompactFibreTorus) :
+    characterCircleOrbit k q (hexagonCharacter k u) = CuspCollapse.centralPhaseOrbitToFibre q u :=
+  by
+  apply Subtype.ext
+  apply (centralPhaseOrbit_eq_iff_character k q hq _ _).mpr
+  exact hexagonCharacter_section k _
+
+private theorem CuspCentralHomology.characterCircleOrbit_injective (k : Fin 6)
+    (q : CuspPositiveRetraction.PositiveCentralFibre)
+    (hq :
+      MulAction.stabilizer ToricSpace.CompactFibreTorus (q.1 : ToricSpace.Space) =
+        ToricSpace.edgeCircle (ToricComponent.hexagonRay k)) :
+    Function.Injective (characterCircleOrbit k q) := by
+  intro a b hab
+  have he := (centralPhaseOrbit_eq_iff_character k q hq _ _).mp (congrArg Subtype.val hab)
+  simpa only [hexagonCharacter_section] using he
+
+private def CuspCentralHomology.edgeArcPositive (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (k : Fin 6)
+    (t : unitInterval) : CuspPositiveRetraction.PositiveCentralFibre :=
+  ⟨⟨(CuspHoneycombHexagon.compatibleBoundaryArc C₀ k t).1.1,
+      (CuspHoneycombHexagon.compatibleBoundaryArc C₀ k t).1.2⟩,
+    ToricSpace.time_eq_zero_of_mem_rayDivisor
+      (CuspHoneycombHexagon.compatibleBoundaryArc C₀ k t).1.1.2⟩
+
+@[simp]
+private theorem CuspCentralHomology.edgeArcPositive_coe (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (k : Fin 6)
+    (t : unitInterval) :
+    (edgeArcPositive C₀ k t).1.1 =
+      ((CuspHoneycombHexagon.compatibleBoundaryArc C₀ k t).1.1 : ToricSpace.Space) :=
+  rfl
+
+private theorem CuspCentralHomology.edgeArcPositive_continuous (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) : Continuous (edgeArcPositive C₀ k) := by
+  apply Continuous.subtype_mk
+  apply Continuous.subtype_mk
+  exact
+    continuous_subtype_val.comp
+      (continuous_subtype_val.comp
+        (continuous_subtype_val.comp
+          (CuspHoneycombHexagon.compatibleBoundaryArc C₀ k).continuous))
+
+private theorem CuspCentralHomology.edgeArcPositive_injective (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) : Function.Injective (edgeArcPositive C₀ k) := by
+  intro s t h
+  apply (CuspHoneycombHexagon.compatibleBoundaryArc C₀ k).injective
+  apply Subtype.ext
+  apply Subtype.ext
+  apply Subtype.ext
+  exact congrArg (fun q : CuspPositiveRetraction.PositiveCentralFibre => q.1.1) h
+
+private theorem
+    CuspCentralHomology.edgeArcPositive_stabilizer (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (k : Fin 6)
+    (t : unitInterval) (ht0 : t ≠ 0) (ht1 : t ≠ 1) :
+    MulAction.stabilizer ToricSpace.CompactFibreTorus
+        ((edgeArcPositive C₀ k t).1 : ToricSpace.Space) =
+      ToricSpace.edgeCircle (ToricComponent.hexagonRay k) :=
+  compatibleBoundaryArc_stabilizer C₀ k t ht0 ht1
+
+private def CuspCentralHomology.edgeCylinder (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (k : Fin 6)
+    (p : unitInterval × Circle) : CuspRetraction.CentralFibre :=
+  CuspCollapse.centralPolarMap (hexagonCharacterSection k p.2, edgeArcPositive C₀ k p.1)
+
+@[simp]
+private theorem CuspCentralHomology.edgeCylinder_coe (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (k : Fin 6)
+    (p : unitInterval × Circle) :
+    (edgeCylinder C₀ k p : ToricSpace.Space) =
+      ToricSpace.compactFibreAction (hexagonCharacterSection k p.2)
+        ((CuspHoneycombHexagon.compatibleBoundaryArc C₀ k p.1).1.1 : ToricSpace.Space) :=
+  rfl
+
+private theorem
+    CuspCentralHomology.edgeCylinder_continuous (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (k : Fin 6) :
+    Continuous (edgeCylinder C₀ k) :=
+  CuspCollapse.centralPolarMap_continuous.comp
+    (((hexagonCharacterSection_continuous k).comp continuous_snd).prodMk
+      ((edgeArcPositive_continuous C₀ k).comp continuous_fst))
+
+@[simp]
+private theorem CuspCentralHomology.edgeCylinder_modulus (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (k : Fin 6)
+    (p : unitInterval × Circle) :
+    CuspCollapse.centralModulus (edgeCylinder C₀ k p) = edgeArcPositive C₀ k p.1 :=
+  CuspCollapse.centralModulus_centralPolarMap _
+
+private theorem
+    CuspCentralHomology.edgeCylinder_character (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (k : Fin 6)
+    (t : unitInterval) (ht0 : t ≠ 0) (ht1 : t ≠ 1) (u : ToricSpace.CompactFibreTorus) :
+    edgeCylinder C₀ k (t, hexagonCharacter k u) =
+      CuspCollapse.centralPolarMap (u, edgeArcPositive C₀ k t) :=
+  congrArg Subtype.val
+    (characterCircleOrbit_character k (edgeArcPositive C₀ k t)
+      (edgeArcPositive_stabilizer C₀ k t ht0 ht1) u)
+
+private theorem CuspCentralHomology.edgeCylinder_eq_iff_of_interior (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) (s t : unitInterval) (hs0 : s ≠ 0) (hs1 : s ≠ 1) (a b : Circle) :
+    edgeCylinder C₀ k (s, a) = edgeCylinder C₀ k (t, b) ↔ s = t ∧ a = b := by
+  constructor
+  · intro h
+    have hst : s = t :=
+      edgeArcPositive_injective C₀ k
+        (by simpa only [edgeCylinder_modulus] using congrArg CuspCollapse.centralModulus h)
+    subst t
+    refine ⟨rfl, ?_⟩
+    apply
+      characterCircleOrbit_injective k (edgeArcPositive C₀ k s)
+        (edgeArcPositive_stabilizer C₀ k s hs0 hs1)
+    exact Subtype.ext h
+  · rintro ⟨rfl, rfl⟩
+    rfl
+
+private theorem
+    CuspCentralHomology.edgeCylinder_zero_coe (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (k : Fin 6)
+    (a : Circle) :
+    (edgeCylinder C₀ k (0, a) : ToricSpace.Space) =
+      ToricSpace.inclusion (ToricComponent.zeroTriangle (k - 1)) 0 := by
+  rw [edgeCylinder_coe, CuspHoneycombHexagon.compatibleBoundaryArc_zero,
+    CuspHoneycombHexagon.positiveBoundaryArc_zero_coe,
+    ToricSpace.compactFibreAction_inclusion_zero]
+
+private theorem CuspCentralHomology.edgeCylinder_one_coe (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (k : Fin 6)
+    (a : Circle) :
+    (edgeCylinder C₀ k (1, a) : ToricSpace.Space) =
+      ToricSpace.inclusion (ToricComponent.zeroTriangle k) 0 := by
+  rw [edgeCylinder_coe, CuspHoneycombHexagon.compatibleBoundaryArc_one,
+    CuspHoneycombHexagon.positiveBoundaryArc_one_coe,
+    ToricSpace.compactFibreAction_inclusion_zero]
+
+private theorem
+    CuspCentralHomology.edgeCylinder_character_all (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (k : Fin 6)
+    (t : unitInterval) (u : ToricSpace.CompactFibreTorus) :
+    edgeCylinder C₀ k (t, hexagonCharacter k u) =
+      CuspCollapse.centralPolarMap (u, edgeArcPositive C₀ k t) := by
+  by_cases ht0 : t = 0
+  · subst t
+    apply Subtype.ext
+    rw [edgeCylinder_zero_coe, CuspCollapse.centralPolarMap_coe, edgeArcPositive_coe,
+      CuspHoneycombHexagon.compatibleBoundaryArc_zero,
+      CuspHoneycombHexagon.positiveBoundaryArc_zero_coe,
+      ToricSpace.compactFibreAction_inclusion_zero]
+  by_cases ht1 : t = 1
+  · subst t
+    apply Subtype.ext
+    rw [edgeCylinder_one_coe, CuspCollapse.centralPolarMap_coe, edgeArcPositive_coe,
+      CuspHoneycombHexagon.compatibleBoundaryArc_one,
+      CuspHoneycombHexagon.positiveBoundaryArc_one_coe,
+      ToricSpace.compactFibreAction_inclusion_zero]
+  exact edgeCylinder_character C₀ k t ht0 ht1 u
+
+private def CuspCentralHomology.cornerOrigin (k : Fin 6) : CuspRetraction.CentralFibre :=
+  ⟨ToricSpace.inclusion (ToricComponent.zeroTriangle k) 0, by simp [ToricFan.Triangle.time]⟩
+
+@[simp]
+private theorem CuspCentralHomology.cornerOrigin_coe (k : Fin 6) :
+    (cornerOrigin k : ToricSpace.Space) =
+      ToricSpace.inclusion (ToricComponent.zeroTriangle k) 0 :=
+  rfl
+
+private theorem CuspCentralHomology.zeroTriangle_upper_eq_iff_parity (k l : Fin 6) :
+    (ToricComponent.zeroTriangle k).upper = (ToricComponent.zeroTriangle l).upper ↔
+      k.val % 2 = l.val % 2 := by
+  have h :
+    ∀ k l : Fin 6,
+      (ToricComponent.zeroTriangle k).upper = (ToricComponent.zeroTriangle l).upper ↔
+        k.val % 2 = l.val % 2 := by decide
+  exact h k l
+
+private def CuspCentralHomology.cornerPoint (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (k : Fin 6) : CuspRetraction.QuotientCentralFibre C ε :=
+  CuspCollapse.centralProject C ε hε (cornerOrigin k)
+
+@[simp]
+private theorem CuspCentralHomology.cornerPoint_coe (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (k : Fin 6) :
+    (cornerPoint C ε hε k : CuspQuotient.QuotientSpace C ε) =
+      CuspQuotient.centralChartMap C ε hε (ToricComponent.zeroTriangle k)
+        CuspQuotient.centralOrigin :=
+  rfl
+
+private theorem
+    CuspCentralHomology.cornerPoint_eq_iff_parity (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (k l : Fin 6) :
+    cornerPoint C ε hε k = cornerPoint C ε hε l ↔ k.val % 2 = l.val % 2 := by
+  rw [Subtype.ext_iff, cornerPoint_coe, cornerPoint_coe,
+    CuspQuotient.centralChartMap_origin_eq_iff, zeroTriangle_upper_eq_iff_parity]
+
+private def CuspCentralHomology.evenPole (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    CuspRetraction.QuotientCentralFibre C ε :=
+  cornerPoint C ε hε 0
+
+private def CuspCentralHomology.oddPole (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    CuspRetraction.QuotientCentralFibre C ε :=
+  cornerPoint C ε hε 1
+
+private theorem
+    CuspCentralHomology.cornerPoint_eq_evenPole_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (k : Fin 6) : cornerPoint C ε hε k = evenPole C ε hε ↔ k.val % 2 = 0 := by
+  simpa only [evenPole, Fin.val_zero, Nat.zero_mod] using cornerPoint_eq_iff_parity C ε hε k 0
+
+private theorem
+    CuspCentralHomology.cornerPoint_eq_oddPole_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (k : Fin 6) : cornerPoint C ε hε k = oddPole C ε hε ↔ k.val % 2 = 1 := by
+  simpa [oddPole] using cornerPoint_eq_iff_parity C ε hε k 1
+
+private theorem
+    CuspCentralHomology.pole_ne (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    evenPole C ε hε ≠ oddPole C ε hε := by
+  intro h
+  have hp := (cornerPoint_eq_iff_parity C ε hε 0 1).mp h
+  norm_num at hp
+
+private abbrev CuspCentralHomology.ThreeCircles :=
+  _root_.Circle ⊕ (_root_.Circle ⊕ _root_.Circle)
+
+private def CuspCentralHomology.unitCircleHomologyZeroEquiv :
+    SingularMayerVietoris.SingularHomology _root_.Circle 0 ≃ₗ[ℤ] ℤ :=
+  PeriodTorusHigherHomology.connectedHomologyZeroEquiv _root_.Circle
+
+private def CuspCentralHomology.unitCircleHomologyOneEquiv :
+    SingularMayerVietoris.SingularHomology _root_.Circle 1 ≃ₗ[ℤ] ℤ :=
+  (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+        (AddCircle.homeomorphCircle (T := (1 : ℝ)) one_ne_zero).symm 1).trans
+    PeriodTorusHigherHomology.circleHomologyOneEquiv
+
+private theorem CuspCentralHomology.unitCircle_homology_subsingleton (n : ℕ) :
+    Subsingleton (SingularMayerVietoris.SingularHomology _root_.Circle (n + 2)) := by
+  let := PeriodTorusHigherHomology.circle_homology_subsingleton n
+  exact
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+        (AddCircle.homeomorphCircle (T := (1 : ℝ)) one_ne_zero).symm
+        (n + 2)).injective.subsingleton
+
+private def CuspCentralHomology.threeCirclesHomologySplit (n : ℕ) :
+    SingularMayerVietoris.SingularHomology ThreeCircles n ≃ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology _root_.Circle n ×
+        (SingularMayerVietoris.SingularHomology _root_.Circle n ×
+          SingularMayerVietoris.SingularHomology _root_.Circle n)) :=
+  ((PeriodTorusHigherHomology.sumHomologyEquiv _root_.Circle (_root_.Circle ⊕ _root_.Circle)
+          n).toAddEquiv.trans
+      ((AddEquiv.refl _).prodCongr
+        (PeriodTorusHigherHomology.sumHomologyEquiv _root_.Circle _root_.Circle
+            n).toAddEquiv)).toIntLinearEquiv
+
+private def CuspCentralHomology.integerTripleEquiv : (ℤ × (ℤ × ℤ)) ≃ₗ[ℤ] (Fin 3 → ℤ) :=
+  ({    toFun a := ![a.1, a.2.1, a.2.2]
+        invFun a := (a 0, (a 1, a 2))
+        left_inv _ := rfl
+        right_inv a := by ext i; fin_cases i <;> rfl
+        map_add' a b := by ext i; fin_cases i <;> rfl } :
+      (ℤ × (ℤ × ℤ)) ≃+ (Fin 3 → ℤ)).toIntLinearEquiv
+
+private def CuspCentralHomology.threeCirclesHomologyZeroEquiv :
+    SingularMayerVietoris.SingularHomology ThreeCircles 0 ≃ₗ[ℤ] (Fin 3 → ℤ) :=
+  ((threeCirclesHomologySplit 0).toAddEquiv.trans
+      ((unitCircleHomologyZeroEquiv.toAddEquiv.prodCongr
+            (unitCircleHomologyZeroEquiv.toAddEquiv.prodCongr
+              unitCircleHomologyZeroEquiv.toAddEquiv)).trans
+        integerTripleEquiv.toAddEquiv)).toIntLinearEquiv
+
+private def CuspCentralHomology.threeCirclesHomologyOneEquiv :
+    SingularMayerVietoris.SingularHomology ThreeCircles 1 ≃ₗ[ℤ] (Fin 3 → ℤ) :=
+  ((threeCirclesHomologySplit 1).toAddEquiv.trans
+      ((unitCircleHomologyOneEquiv.toAddEquiv.prodCongr
+            (unitCircleHomologyOneEquiv.toAddEquiv.prodCongr
+              unitCircleHomologyOneEquiv.toAddEquiv)).trans
+        integerTripleEquiv.toAddEquiv)).toIntLinearEquiv
+
+private theorem CuspCentralHomology.threeCircles_homology_subsingleton (n : ℕ) :
+    Subsingleton (SingularMayerVietoris.SingularHomology ThreeCircles (n + 2)) := by
+  let := unitCircle_homology_subsingleton n
+  exact (threeCirclesHomologySplit (n + 2)).injective.subsingleton
+
+private def CuspCentralHomology.sumCoordinates : (Fin 3 → ℤ) →ₗ[ℤ] ℤ
+    where
+  toFun a := ∑ i, a i
+  map_add' a b := by simp only [Pi.add_apply, Finset.sum_add_distrib]
+  map_smul' r a := by simp only [RingHom.id_apply, Pi.smul_apply, Finset.smul_sum]
+
+@[simp]
+private theorem CuspCentralHomology.sumCoordinates_apply (a : Fin 3 → ℤ) :
+    sumCoordinates a = a 0 + a 1 + a 2 := by
+  simp only [sumCoordinates, LinearMap.coe_mk, AddHom.coe_mk, Fin.sum_univ_three]
+
+private theorem CuspCentralHomology.sumHomology_map_mo1973_12039 {X Y Z : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace Z] (f : C(X ⊕ Y, Z)) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (X ⊕ Y) n) :
+    SingularMayerVietoris.singularHomologyMap f n a =
+      SingularMayerVietoris.singularHomologyMap (f.comp (PeriodTorusHigherHomology.sumInlMap X Y))
+          n (PeriodTorusHigherHomology.sumHomologyEquiv X Y n a).1 +
+        SingularMayerVietoris.singularHomologyMap
+          (f.comp (PeriodTorusHigherHomology.sumInrMap X Y)) n
+          (PeriodTorusHigherHomology.sumHomologyEquiv X Y n a).2 := by
+  have hf :
+    f =
+      PeriodTorusHigherHomology.sumElimMap (f.comp (PeriodTorusHigherHomology.sumInlMap X Y))
+        (f.comp (PeriodTorusHigherHomology.sumInrMap X Y)) := by
+    ext x
+    cases x <;> rfl
+  conv_lhs => rw [hf]
+  exact PeriodTorusHigherHomology.sumHomologyEquiv_sumElim _ _ n a
+
+private theorem
+    CuspCentralHomology.threeCirclesHomologyZeroEquiv_map {Y : Type} [TopologicalSpace Y]
+    [PathConnectedSpace Y] (f : C(ThreeCircles, Y))
+    (a : SingularMayerVietoris.SingularHomology ThreeCircles 0) :
+    PeriodTorusHigherHomology.connectedHomologyZeroEquiv Y
+        (SingularMayerVietoris.singularHomologyMap f 0 a) =
+      sumCoordinates (threeCirclesHomologyZeroEquiv a) := by
+  rw [sumHomology_map_mo1973_12039 f, map_add]
+  rw [sumHomology_map_mo1973_12039
+      (f.comp
+        (PeriodTorusHigherHomology.sumInrMap _root_.Circle (_root_.Circle ⊕ _root_.Circle))),
+    map_add]
+  rw [PeriodTorusHigherHomology.connectedHomologyZeroEquiv_natural,
+    PeriodTorusHigherHomology.connectedHomologyZeroEquiv_natural,
+    PeriodTorusHigherHomology.connectedHomologyZeroEquiv_natural, sumCoordinates_apply]
+  exact (add_assoc _ _ _).symm
+
+private theorem CuspCentralHomology.threeCirclesHomologyZeroEquiv_map_homotopyEquiv {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] [PathConnectedSpace Y] (e : X ≃ₕ ThreeCircles)
+    (f : C(X, Y)) (a : SingularMayerVietoris.SingularHomology X 0) :
+    PeriodTorusHigherHomology.connectedHomologyZeroEquiv Y
+        (SingularMayerVietoris.singularHomologyMap f 0 a) =
+      sumCoordinates
+        (threeCirclesHomologyZeroEquiv
+          (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv e 0 a)) := by
+  obtain ⟨b, rfl⟩ := (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv e 0).symm.surjective a
+  rw [LinearEquiv.apply_symm_apply,
+    PeriodTorusHigherHomology.homotopyEquivHomologyEquiv_symm_apply]
+  change
+    PeriodTorusHigherHomology.connectedHomologyZeroEquiv Y
+        (((SingularMayerVietoris.singularHomologyMap f 0).comp
+            (SingularMayerVietoris.singularHomologyMap e.invFun 0))
+          b) =
+      _
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp]
+  exact threeCirclesHomologyZeroEquiv_map (f.comp e.invFun) b
+
+private def CuspCentralHomology.sumCoordinatesKernelEquiv :
+    LinearMap.ker sumCoordinates ≃ₗ[ℤ] (Fin 2 → ℤ) :=
+  ({    toFun a := ![a.1 1, a.1 2]
+        invFun
+          a :=
+          ⟨![-a 0 - a 1, a 0, a 1],
+            by
+            change sumCoordinates ![-a 0 - a 1, a 0, a 1] = 0
+            rw [sumCoordinates_apply]
+            change -a 0 - a 1 + a 0 + a 1 = 0
+            ring⟩
+        left_inv
+          a := by
+          apply Subtype.ext
+          have ha : a.1 0 + a.1 1 + a.1 2 = 0 := by
+            simpa only [LinearMap.mem_ker, sumCoordinates_apply] using a.2
+          ext i
+          fin_cases i
+          · change -a.1 1 - a.1 2 = a.1 0
+            omega
+          · rfl
+          · rfl
+        right_inv a := by ext i; fin_cases i <;> rfl
+        map_add' a b := by ext i; fin_cases i <;> rfl } :
+      LinearMap.ker sumCoordinates ≃+ (Fin 2 → ℤ)).toIntLinearEquiv
+
+@[simp]
+private theorem
+    CuspCentralHomology.centralProject_edgeCylinder_zero (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (k : Fin 6) (a : Circle) :
+    CuspCollapse.centralProject C ε hε (edgeCylinder (C 0) k (0, a)) =
+      cornerPoint C ε hε (k - 1) :=
+  congrArg (CuspCollapse.centralProject C ε hε) (Subtype.ext (edgeCylinder_zero_coe (C 0) k a))
+
+@[simp]
+private theorem
+    CuspCentralHomology.centralProject_edgeCylinder_one (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (k : Fin 6) (a : Circle) :
+    CuspCollapse.centralProject C ε hε (edgeCylinder (C 0) k (1, a)) = cornerPoint C ε hε k :=
+  congrArg (CuspCollapse.centralProject C ε hε) (Subtype.ext (edgeCylinder_one_coe (C 0) k a))
+
+private def
+    CuspCentralHomology.doubleCylinder (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (p : unitInterval × ThreeCircles) : CuspRetraction.QuotientCentralFibre C ε :=
+  match p.2 with
+  | Sum.inl a => CuspCollapse.centralProject C ε hε (edgeCylinder (C 0) 0 (p.1, a))
+  | Sum.inr (Sum.inl a) =>
+    CuspCollapse.centralProject C ε hε (edgeCylinder (C 0) 1 (unitInterval.symm p.1, a))
+  | Sum.inr (Sum.inr a) => CuspCollapse.centralProject C ε hε (edgeCylinder (C 0) 2 (p.1, a))
+
+@[simp]
+private theorem CuspCentralHomology.doubleCylinder_first (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (t : unitInterval) (a : Circle) :
+    doubleCylinder C ε hε (t, Sum.inl a) =
+      CuspCollapse.centralProject C ε hε (edgeCylinder (C 0) 0 (t, a)) :=
+  rfl
+
+@[simp]
+private theorem CuspCentralHomology.doubleCylinder_middle (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (t : unitInterval) (a : Circle) :
+    doubleCylinder C ε hε (t, Sum.inr (Sum.inl a)) =
+      CuspCollapse.centralProject C ε hε (edgeCylinder (C 0) 1 (unitInterval.symm t, a)) :=
+  rfl
+
+@[simp]
+private theorem CuspCentralHomology.doubleCylinder_last (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (t : unitInterval) (a : Circle) :
+    doubleCylinder C ε hε (t, Sum.inr (Sum.inr a)) =
+      CuspCollapse.centralProject C ε hε (edgeCylinder (C 0) 2 (t, a)) :=
+  rfl
+
+private theorem
+    CuspCentralHomology.doubleCylinder_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : Continuous (doubleCylinder C ε hε) := by
+  have h0 :
+    Continuous
+      (fun p : unitInterval × Circle =>
+        CuspCollapse.centralProject C ε hε (edgeCylinder (C 0) 0 p)) :=
+    (CuspCollapse.centralProject_continuous C ε hε).comp (edgeCylinder_continuous (C 0) 0)
+  have h1 :
+    Continuous
+      (fun p : unitInterval × Circle =>
+        CuspCollapse.centralProject C ε hε (edgeCylinder (C 0) 1 (unitInterval.symm p.1, p.2))) :=
+    (CuspCollapse.centralProject_continuous C ε hε).comp
+      ((edgeCylinder_continuous (C 0) 1).comp
+        ((unitInterval.continuous_symm.comp continuous_fst).prodMk continuous_snd))
+  have h2 :
+    Continuous
+      (fun p : unitInterval × Circle =>
+        CuspCollapse.centralProject C ε hε (edgeCylinder (C 0) 2 p)) :=
+    (CuspCollapse.centralProject_continuous C ε hε).comp (edgeCylinder_continuous (C 0) 2)
+  let e0 :
+    unitInterval × ThreeCircles ≃ₜ (unitInterval × Circle) ⊕ (unitInterval × (Circle ⊕ Circle)) :=
+    Homeomorph.prodSumDistrib
+  let e1 :
+    unitInterval × (Circle ⊕ Circle) ≃ₜ (unitInterval × Circle) ⊕ (unitInterval × Circle) :=
+    Homeomorph.prodSumDistrib
+  have h := (h0.sumElim ((h1.sumElim h2).comp e1.continuous)).comp e0.continuous
+  apply h.congr
+  rintro ⟨t, a⟩
+  rcases a with a | a | a <;> rfl
+
+@[simp]
+private theorem CuspCentralHomology.doubleCylinder_zero (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (a : ThreeCircles) : doubleCylinder C ε hε (0, a) = oddPole C ε hε := by
+  rcases a with a | a | a <;>
+    simp only [doubleCylinder_first, doubleCylinder_middle, doubleCylinder_last,
+      unitInterval.symm_zero, centralProject_edgeCylinder_zero, centralProject_edgeCylinder_one]
+  all_goals exact (cornerPoint_eq_oddPole_iff C ε hε _).mpr (by decide)
+
+@[simp]
+private theorem CuspCentralHomology.doubleCylinder_one (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (a : ThreeCircles) : doubleCylinder C ε hε (1, a) = evenPole C ε hε := by
+  rcases a with a | a | a <;>
+    simp only [doubleCylinder_first, doubleCylinder_middle, doubleCylinder_last,
+      unitInterval.symm_one, centralProject_edgeCylinder_zero, centralProject_edgeCylinder_one]
+  all_goals exact (cornerPoint_eq_evenPole_iff C ε hε _).mpr (by decide)
+
+private theorem
+    CuspCentralHomology.doubleCylinder_respects (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (p q : unitInterval × ThreeCircles) (h : (suspensionSetoid ThreeCircles).r p q) :
+    doubleCylinder C ε hε p = doubleCylinder C ε hε q := by
+  rcases p with ⟨s, a⟩
+  rcases q with ⟨t, b⟩
+  change s = t ∧ (s = 0 ∨ s = 1 ∨ a = b) at h
+  rcases h with ⟨hst, hs⟩
+  cases hst
+  rcases hs with rfl | rfl | rfl <;> simp only [doubleCylinder_zero, doubleCylinder_one]
+
+private def CuspCentralHomology.doubleSuspensionMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : Suspension ThreeCircles → CuspRetraction.QuotientCentralFibre C ε :=
+  Quotient.lift (doubleCylinder C ε hε) (doubleCylinder_respects C ε hε)
+
+@[simp]
+private theorem
+    CuspCentralHomology.doubleSuspensionMap_mk (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (t : unitInterval) (a : ThreeCircles) :
+    doubleSuspensionMap C ε hε (Suspension.mk t a) = doubleCylinder C ε hε (t, a) :=
+  rfl
+
+private theorem
+    CuspCentralHomology.doubleSuspensionMap_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) : Continuous (doubleSuspensionMap C ε hε) :=
+  (Suspension.isQuotientMap_mk (X := ThreeCircles)).continuous_iff.mpr
+    (doubleCylinder_continuous C ε hε)
+
+private theorem CuspCentralHomology.chartPoint_branchVertices_fst_zero (i : Fin 6)
+    (z : ToricCharts.CoordinateSpace 2) (hz0 : z 0 = 0) (hz1 : z 1 ≠ 0) :
+    ToricSpace.branchVertices (CuspHoneycombHexagon.chartPoint i z : ToricSpace.Space) =
+      {0, ToricComponent.hexagonRay i} := by
+  rw [CuspHoneycombHexagon.chartPoint_coe, ToricSpace.branchVertices_inclusion]
+  ext v
+  change
+    (∃ j,
+        CuspHoneycombHexagon.liftCoordinates i z j = 0 ∧
+          (ToricComponent.zeroTriangle i).vertex j = v) ↔
+      v = 0 ∨ v = ToricComponent.hexagonRay i
+  constructor
+  · rintro ⟨j, hj, rfl⟩
+    rcases CuspHoneycombHexagon.coordinates_exhaustive i j with rfl | rfl | rfl
+    · exact Or.inl (ToricComponent.zeroTriangle_vertex i)
+    · exact Or.inr (CuspHoneycombHexagon.firstCoordinate_vertex i)
+    · exact (hz1 (by simpa only [CuspHoneycombHexagon.liftCoordinates_second] using hj)).elim
+  · rintro (rfl | rfl)
+    · exact
+        ⟨ToricComponent.zeroCoordinate i, CuspHoneycombHexagon.liftCoordinates_zero i z,
+          ToricComponent.zeroTriangle_vertex i⟩
+    · exact
+        ⟨CuspHoneycombHexagon.firstCoordinate i,
+          (CuspHoneycombHexagon.liftCoordinates_first i z).trans hz0,
+          CuspHoneycombHexagon.firstCoordinate_vertex i⟩
+
+private theorem CuspCentralHomology.chartPoint_branchVertices_snd_zero (i : Fin 6)
+    (z : ToricCharts.CoordinateSpace 2) (hz0 : z 0 ≠ 0) (hz1 : z 1 = 0) :
+    ToricSpace.branchVertices (CuspHoneycombHexagon.chartPoint i z : ToricSpace.Space) =
+      {0, ToricComponent.hexagonRay (i + 1)} := by
+  rw [CuspHoneycombHexagon.chartPoint_coe, ToricSpace.branchVertices_inclusion]
+  ext v
+  change
+    (∃ j,
+        CuspHoneycombHexagon.liftCoordinates i z j = 0 ∧
+          (ToricComponent.zeroTriangle i).vertex j = v) ↔
+      v = 0 ∨ v = ToricComponent.hexagonRay (i + 1)
+  constructor
+  · rintro ⟨j, hj, rfl⟩
+    rcases CuspHoneycombHexagon.coordinates_exhaustive i j with rfl | rfl | rfl
+    · exact Or.inl (ToricComponent.zeroTriangle_vertex i)
+    · exact (hz0 (by simpa only [CuspHoneycombHexagon.liftCoordinates_first] using hj)).elim
+    · exact Or.inr (CuspHoneycombHexagon.secondCoordinate_vertex i)
+  · rintro (rfl | rfl)
+    · exact
+        ⟨ToricComponent.zeroCoordinate i, CuspHoneycombHexagon.liftCoordinates_zero i z,
+          ToricComponent.zeroTriangle_vertex i⟩
+    · exact
+        ⟨CuspHoneycombHexagon.secondCoordinate i,
+          (CuspHoneycombHexagon.liftCoordinates_second i z).trans hz1,
+          CuspHoneycombHexagon.secondCoordinate_vertex i⟩
+
+private theorem CuspCentralHomology.positiveBoundary_branchVertices (k : Fin 6)
+    (q : CuspHoneycombHexagon.positiveBoundary k)
+    (hprev : q.1 ≠ CuspHoneycombHexagon.squarePoint (k - 1) CuspHoneycombHexagon.cornerZero)
+    (hcurr : q.1 ≠ CuspHoneycombHexagon.squarePoint k CuspHoneycombHexagon.cornerZero) :
+    ToricSpace.branchVertices (q.1.1 : ToricSpace.Space) = {0, ToricComponent.hexagonRay k} := by
+  obtain ⟨i, z, he⟩ := CuspHoneycombHexagon.chartPoint_jointly_surjective q.1.1
+  have hqzero (hz0 : z 0 = 0) (hz1 : z 1 = 0) :
+    q.1 = CuspHoneycombHexagon.squarePoint i CuspHoneycombHexagon.cornerZero := by
+    apply Subtype.ext
+    change
+      q.1.1 =
+        CuspHoneycombHexagon.chartPoint i (fun j => (CuspHoneycombHexagon.cornerZero.1 j : ℂ))
+    rw [← he]
+    apply congrArg (CuspHoneycombHexagon.chartPoint i)
+    funext j
+    fin_cases j
+    · change z 0 = 0
+      exact hz0
+    · change z 1 = 0
+      exact hz1
+  have hb :
+    (CuspHoneycombHexagon.chartPoint i z : ToricSpace.Space) ∈
+      ToricSpace.rayDivisor (ToricComponent.hexagonRay k) := by
+    rw [he]
+    exact q.property
+  rcases (CuspHoneycombHexagon.chartPoint_mem_rayDivisor_iff i k z).mp hb with ⟨rfl, hz0⟩ |
+    ⟨rfl, hz1⟩
+  · have hz1 : z 1 ≠ 0 := fun hz1 => hcurr (hqzero hz0 hz1)
+    rw [← he]
+    exact chartPoint_branchVertices_fst_zero k z hz0 hz1
+  · have hz0 : z 0 ≠ 0 := by
+      intro hz0
+      apply hprev
+      simpa only [add_sub_cancel_right] using hqzero hz0 hz1
+    rw [← he]
+    exact chartPoint_branchVertices_snd_zero i z hz0 hz1
+
+private theorem
+    CuspCentralHomology.compatibleBoundaryArc_branchVertices (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) (t : unitInterval) (ht0 : t ≠ 0) (ht1 : t ≠ 1) :
+    ToricSpace.branchVertices
+        ((CuspHoneycombHexagon.compatibleBoundaryArc C₀ k t).1.1 : ToricSpace.Space) =
+      {0, ToricComponent.hexagonRay k} := by
+  apply positiveBoundary_branchVertices k (CuspHoneycombHexagon.compatibleBoundaryArc C₀ k t)
+  · intro h
+    apply ht0
+    apply (CuspHoneycombHexagon.compatibleBoundaryArc C₀ k).injective
+    apply Subtype.ext
+    exact h.trans (CuspHoneycombHexagon.compatibleBoundaryArc_zero_point C₀ k).symm
+  · intro h
+    apply ht1
+    apply (CuspHoneycombHexagon.compatibleBoundaryArc C₀ k).injective
+    apply Subtype.ext
+    exact h.trans (CuspHoneycombHexagon.compatibleBoundaryArc_one_point C₀ k).symm
+
+private theorem CuspCentralHomology.edgeArcPositive_branchVertices (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) (t : unitInterval) (ht0 : t ≠ 0) (ht1 : t ≠ 1) :
+    ToricSpace.branchVertices ((edgeArcPositive C₀ k t).1 : ToricSpace.Space) =
+      {0, ToricComponent.hexagonRay k} :=
+  compatibleBoundaryArc_branchVertices C₀ k t ht0 ht1
+
+private theorem
+    CuspCentralHomology.branchVertices_compactFibreAction (u : ToricSpace.CompactFibreTorus)
+    (x : ToricSpace.Space) :
+    ToricSpace.branchVertices (ToricSpace.compactFibreAction u x) = ToricSpace.branchVertices x :=
+  ToricSpace.branchVertices_torusAction _ x
+
+private theorem CuspCentralHomology.edgeCylinder_branchVertices (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) (p : unitInterval × Circle) (ht0 : p.1 ≠ 0) (ht1 : p.1 ≠ 1) :
+    ToricSpace.branchVertices (edgeCylinder C₀ k p : ToricSpace.Space) =
+      {0, ToricComponent.hexagonRay k} := by
+  rw [edgeCylinder_coe, branchVertices_compactFibreAction]
+  exact compatibleBoundaryArc_branchVertices C₀ k p.1 ht0 ht1
+
+private theorem CuspCentralHomology.edgeArcPositive_branchCount (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) (t : unitInterval) (ht0 : t ≠ 0) (ht1 : t ≠ 1) :
+    ToricSpace.branchCount ((edgeArcPositive C₀ k t).1 : ToricSpace.Space) = 2 := by
+  rw [← ToricSpace.branchVertices_ncard, edgeArcPositive_branchVertices C₀ k t ht0 ht1]
+  exact Set.ncard_pair (ToricComponent.hexagonRay_ne_zero k).symm
+
+private theorem
+    CuspCentralHomology.edgeCylinder_branchCount (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (k : Fin 6)
+    (p : unitInterval × Circle) (ht0 : p.1 ≠ 0) (ht1 : p.1 ≠ 1) :
+    ToricSpace.branchCount (edgeCylinder C₀ k p : ToricSpace.Space) = 2 := by
+  rw [← ToricSpace.branchVertices_ncard, edgeCylinder_branchVertices C₀ k p ht0 ht1]
+  exact Set.ncard_pair (ToricComponent.hexagonRay_ne_zero k).symm
+
+private theorem CuspCentralHomology.edgeArcPositive_zero_branchCount (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) : ToricSpace.branchCount ((edgeArcPositive C₀ k 0).1 : ToricSpace.Space) = 3 := by
+  rw [edgeArcPositive_coe, CuspHoneycombHexagon.compatibleBoundaryArc_zero_point,
+    CuspHoneycombHexagon.squarePoint_cornerZero_coe, ToricSpace.branchCount_inclusion,
+    ToricCharts.zeroCount_zero]
+
+private theorem CuspCentralHomology.edgeArcPositive_one_branchCount (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) : ToricSpace.branchCount ((edgeArcPositive C₀ k 1).1 : ToricSpace.Space) = 3 := by
+  rw [edgeArcPositive_coe, CuspHoneycombHexagon.compatibleBoundaryArc_one_point,
+    CuspHoneycombHexagon.squarePoint_cornerZero_coe, ToricSpace.branchCount_inclusion,
+    ToricCharts.zeroCount_zero]
+
+private theorem CuspCentralHomology.hexagonRay_first_half_ne_neg (k l : Fin 6) (hk : k.val < 3)
+    (hl : l.val < 3) : ToricComponent.hexagonRay k ≠ -ToricComponent.hexagonRay l := by
+  have h :
+    ∀ k l : Fin 6,
+      k.val < 3 → l.val < 3 → ToricComponent.hexagonRay k ≠ -ToricComponent.hexagonRay l := by
+    decide
+  exact h k l hk hl
+
+private theorem CuspCentralHomology.hexagonPair_image_add_eq (k l : Fin 6) (hk : k.val < 3)
+    (hl : l.val < 3) (d : Fin 2 → ℤ)
+    (h :
+      ({0, ToricComponent.hexagonRay k} : Set (Fin 2 → ℤ)) =
+        (fun w => w + d) '' {0, ToricComponent.hexagonRay l}) :
+    k = l ∧ d = 0 := by
+  simp only [Set.image_insert_eq, Set.image_singleton, zero_add, Set.pair_eq_pair_iff] at h
+  rcases h with ⟨hd, hn⟩ | ⟨hd, hn⟩
+  · subst d
+    exact ⟨ToricComponent.hexagonRay_injective (by simpa only [add_zero] using hn), rfl⟩
+  · have hneg : ToricComponent.hexagonRay k = -ToricComponent.hexagonRay l := by
+      funext i
+      have hd' := congrFun hd i
+      have hn' := congrFun hn i
+      change (0 : ℤ) = ToricComponent.hexagonRay l i + d i at hd'
+      change ToricComponent.hexagonRay k i = d i at hn'
+      change ToricComponent.hexagonRay k i = -ToricComponent.hexagonRay l i
+      omega
+    exact (hexagonRay_first_half_ne_neg k l hk hl hneg).elim
+
+private def CuspCentralHomology.projectedEdgeCylinder (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (k : Fin 6) (p : unitInterval × Circle) :
+    CuspRetraction.QuotientCentralFibre C ε :=
+  CuspCollapse.centralProject C ε hε (edgeCylinder (C 0) k p)
+
+private theorem CuspCentralHomology.centralProject_branchCount_eq (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) {x y : CuspRetraction.CentralFibre}
+    (h : CuspCollapse.centralProject C ε hε x = CuspCollapse.centralProject C ε hε y) :
+    ToricSpace.branchCount (x : ToricSpace.Space) =
+      ToricSpace.branchCount (y : ToricSpace.Space) := by
+  obtain ⟨v, hv⟩ := (CuspCollapse.centralProject_eq_iff C ε hε x y).mp h
+  rw [← hv, ToricSpace.branchCount_twistedTranslate]
+
+private theorem CuspCentralHomology.projectedEdgeCylinder_eq_iff_of_interior
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (k l : Fin 6) (hk : k.val < 3)
+    (hl : l.val < 3) (s t : unitInterval) (hs0 : s ≠ 0) (hs1 : s ≠ 1) (ht0 : t ≠ 0) (ht1 : t ≠ 1)
+    (a b : Circle) :
+    projectedEdgeCylinder C ε hε k (s, a) = projectedEdgeCylinder C ε hε l (t, b) ↔
+      k = l ∧ s = t ∧ a = b := by
+  constructor
+  · intro he
+    obtain ⟨v, hv⟩ := (CuspCollapse.centralProject_eq_iff C ε hε _ _).mp he
+    have hb := congrArg ToricSpace.branchVertices hv
+    rw [ToricSpace.branchVertices_twistedTranslate,
+      edgeCylinder_branchVertices (C 0) l (t, b) ht0 ht1,
+      edgeCylinder_branchVertices (C 0) k (s, a) hs0 hs1] at hb
+    obtain ⟨hkl, hv0⟩ := hexagonPair_image_add_eq k l hk hl (ToricSpace.cuspVector v) hb.symm
+    have hzero : v = 0 :=
+      ToricSpace.cuspVector_injective (hv0.trans ToricSpace.cuspVector_zero.symm)
+    subst v
+    subst l
+    rw [ToricSpace.twistedTranslate_zero] at hv
+    exact
+      ⟨rfl, (edgeCylinder_eq_iff_of_interior (C 0) k s t hs0 hs1 a b).mp (Subtype.ext hv.symm)⟩
+  · rintro ⟨rfl, rfl, rfl⟩
+    rfl
+
+private theorem CuspCentralHomology.projectedEdgeCylinder_interior_ne_corner
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (k : Fin 6) (t : unitInterval)
+    (ht0 : t ≠ 0) (ht1 : t ≠ 1) (a : Circle) (j : Fin 6) :
+    projectedEdgeCylinder C ε hε k (t, a) ≠ cornerPoint C ε hε j := by
+  intro he
+  have hb := centralProject_branchCount_eq C ε hε he
+  rw [edgeCylinder_branchCount (C 0) k (t, a) ht0 ht1, cornerOrigin_coe,
+    ToricSpace.branchCount_inclusion, ToricCharts.zeroCount_zero] at hb
+  omega
+
+private def CuspCentralHomology.cylinderEdgeData_mo1973_12083 (t : unitInterval)
+    (a : ThreeCircles) : Fin 6 × (unitInterval × Circle) :=
+  match a with
+  | Sum.inl a => (0, t, a)
+  | Sum.inr (Sum.inl a) => (1, unitInterval.symm t, a)
+  | Sum.inr (Sum.inr a) => (2, t, a)
+
+private theorem CuspCentralHomology.cylinderEdgeData_index_lt_mo1973_12084 (t : unitInterval)
+    (a : ThreeCircles) : (cylinderEdgeData_mo1973_12083 t a).1.val < 3 := by
+  rcases a with a | a | a <;> norm_num [cylinderEdgeData_mo1973_12083]
+
+private theorem CuspCentralHomology.cylinderEdgeData_time_ne_zero_mo1973_12085 (t : unitInterval)
+    (a : ThreeCircles) (ht0 : t ≠ 0) (ht1 : t ≠ 1) :
+    (cylinderEdgeData_mo1973_12083 t a).2.1 ≠ 0 := by
+  rcases a with a | a | a
+  · exact ht0
+  · exact fun h => ht1 (unitInterval.symm_eq_zero.mp h)
+  · exact ht0
+
+private theorem CuspCentralHomology.cylinderEdgeData_time_ne_one_mo1973_12086 (t : unitInterval)
+    (a : ThreeCircles) (ht0 : t ≠ 0) (ht1 : t ≠ 1) :
+    (cylinderEdgeData_mo1973_12083 t a).2.1 ≠ 1 := by
+  rcases a with a | a | a
+  · exact ht1
+  · exact fun h => ht0 (unitInterval.symm_eq_one.mp h)
+  · exact ht1
+
+private theorem CuspCentralHomology.cylinderEdgeData_eq_iff_mo1973_12087 (s t : unitInterval)
+    (a b : ThreeCircles) :
+    ((cylinderEdgeData_mo1973_12083 s a).1 = (cylinderEdgeData_mo1973_12083 t b).1 ∧
+        (cylinderEdgeData_mo1973_12083 s a).2.1 = (cylinderEdgeData_mo1973_12083 t b).2.1 ∧
+          (cylinderEdgeData_mo1973_12083 s a).2.2 = (cylinderEdgeData_mo1973_12083 t b).2.2) ↔
+      s = t ∧ a = b := by
+  rcases a with a | a | a <;> rcases b with b | b | b <;>
+    simp [cylinderEdgeData_mo1973_12083, unitInterval.symm_inj]
+
+private theorem CuspCentralHomology.doubleCylinder_eq_projected_mo1973_12088
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (t : unitInterval)
+    (a : ThreeCircles) :
+    doubleCylinder C ε hε (t, a) =
+      projectedEdgeCylinder C ε hε (cylinderEdgeData_mo1973_12083 t a).1
+        (cylinderEdgeData_mo1973_12083 t a).2 := by rcases a with a | a | a <;> rfl
+
+private theorem
+    CuspCentralHomology.doubleCylinder_eq_iff_of_interior (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (s t : unitInterval) (hs0 : s ≠ 0) (hs1 : s ≠ 1) (ht0 : t ≠ 0)
+    (ht1 : t ≠ 1) (a b : ThreeCircles) :
+    doubleCylinder C ε hε (s, a) = doubleCylinder C ε hε (t, b) ↔ s = t ∧ a = b := by
+  simp only [doubleCylinder_eq_projected_mo1973_12088]
+  exact
+    (projectedEdgeCylinder_eq_iff_of_interior C ε hε _ _
+          (cylinderEdgeData_index_lt_mo1973_12084 s a)
+          (cylinderEdgeData_index_lt_mo1973_12084 t b) _ _
+          (cylinderEdgeData_time_ne_zero_mo1973_12085 s a hs0 hs1)
+          (cylinderEdgeData_time_ne_one_mo1973_12086 s a hs0 hs1)
+          (cylinderEdgeData_time_ne_zero_mo1973_12085 t b ht0 ht1)
+          (cylinderEdgeData_time_ne_one_mo1973_12086 t b ht0 ht1) _ _).trans
+      (cylinderEdgeData_eq_iff_mo1973_12087 s t a b)
+
+private theorem
+    CuspCentralHomology.doubleCylinder_interior_ne_corner (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (t : unitInterval) (ht0 : t ≠ 0) (ht1 : t ≠ 1) (a : ThreeCircles)
+    (j : Fin 6) : doubleCylinder C ε hε (t, a) ≠ cornerPoint C ε hε j := by
+  rw [doubleCylinder_eq_projected_mo1973_12088]
+  exact
+    projectedEdgeCylinder_interior_ne_corner C ε hε _ _
+      (cylinderEdgeData_time_ne_zero_mo1973_12085 t a ht0 ht1)
+      (cylinderEdgeData_time_ne_one_mo1973_12086 t a ht0 ht1) _ j
+
+private theorem CuspCentralHomology.doubleCylinder_eq_oddPole_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (t : unitInterval) (a : ThreeCircles) :
+    doubleCylinder C ε hε (t, a) = oddPole C ε hε ↔ t = 0 := by
+  constructor
+  · intro h
+    by_contra ht0
+    by_cases ht1 : t = 1
+    · subst t
+      exact pole_ne C ε hε (by simpa only [doubleCylinder_one] using h)
+    · exact doubleCylinder_interior_ne_corner C ε hε t ht0 ht1 a 1 h
+  · rintro rfl
+    exact doubleCylinder_zero C ε hε a
+
+private theorem
+    CuspCentralHomology.doubleCylinder_eq_evenPole_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (t : unitInterval) (a : ThreeCircles) :
+    doubleCylinder C ε hε (t, a) = evenPole C ε hε ↔ t = 1 := by
+  constructor
+  · intro h
+    by_contra ht1
+    by_cases ht0 : t = 0
+    · subst t
+      apply pole_ne C ε hε
+      simpa only [doubleCylinder_zero] using h.symm
+    · exact doubleCylinder_interior_ne_corner C ε hε t ht0 ht1 a 0 h
+  · rintro rfl
+    exact doubleCylinder_one C ε hε a
+
+private theorem CuspCentralHomology.doubleCylinder_eq_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (p q : unitInterval × ThreeCircles) :
+    doubleCylinder C ε hε p = doubleCylinder C ε hε q ↔ (suspensionSetoid ThreeCircles).r p q := by
+  rcases p with ⟨s, a⟩
+  rcases q with ⟨t, b⟩
+  constructor
+  · intro h
+    change s = t ∧ (s = 0 ∨ s = 1 ∨ a = b)
+    by_cases hs0 : s = 0
+    · subst s
+      have ht0 : t = 0 :=
+        (doubleCylinder_eq_oddPole_iff C ε hε t b).mp
+          (h.symm.trans (doubleCylinder_zero C ε hε a))
+      exact ⟨ht0.symm, Or.inl rfl⟩
+    by_cases hs1 : s = 1
+    · subst s
+      have ht1 : t = 1 :=
+        (doubleCylinder_eq_evenPole_iff C ε hε t b).mp
+          (h.symm.trans (doubleCylinder_one C ε hε a))
+      exact ⟨ht1.symm, Or.inr (Or.inl rfl)⟩
+    have ht0 : t ≠ 0 := by
+      intro ht0
+      subst t
+      exact
+        doubleCylinder_interior_ne_corner C ε hε s hs0 hs1 a 1
+          (h.trans (doubleCylinder_zero C ε hε b))
+    have ht1 : t ≠ 1 := by
+      intro ht1
+      subst t
+      exact
+        doubleCylinder_interior_ne_corner C ε hε s hs0 hs1 a 0
+          (h.trans (doubleCylinder_one C ε hε b))
+    obtain ⟨hst, hab⟩ := (doubleCylinder_eq_iff_of_interior C ε hε s t hs0 hs1 ht0 ht1 a b).mp h
+    exact ⟨hst, Or.inr (Or.inr hab)⟩
+  · exact doubleCylinder_respects C ε hε _ _
+
+private theorem CuspCentralHomology.doubleSuspensionMap_injective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) : Function.Injective (doubleSuspensionMap C ε hε) := by
+  intro x y h
+  obtain ⟨⟨s, a⟩, rfl⟩ := Suspension.mk_surjective x
+  obtain ⟨⟨t, b⟩, rfl⟩ := Suspension.mk_surjective y
+  exact Quotient.sound ((doubleCylinder_eq_iff C ε hε (s, a) (t, b)).mp h)
+
+private theorem
+    CuspCentralHomology.edgeArcPositive_opposite (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (k : Fin 6)
+    (t : unitInterval) :
+    edgeArcPositive C₀ (k + 3) (unitInterval.symm t) =
+      CuspCollapse.positiveCentralTranslate C₀
+        (ToricSpace.cuspVector (ToricComponent.hexagonRay k)) (edgeArcPositive C₀ k t) := by
+  apply Subtype.ext
+  apply Subtype.ext
+  exact CuspHoneycombHexagon.compatibleBoundaryArc_opposite_coe C₀ k t
+
+private theorem
+    CuspCentralHomology.centralCollapseMap_phaseDeckMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (v : Fin 2 → ℤ) (p : CuspCollapse.PhasePositiveSpace) :
+    CuspCollapse.centralCollapseMap C ε hε (CuspCollapse.phaseDeckMap (C 0) v p) =
+      CuspCollapse.centralCollapseMap C ε hε p := by
+  apply (CuspCollapse.centralProject_eq_iff C ε hε _ _).mpr
+  exact ⟨v, (CuspCollapse.centralPolarMap_phaseDeckMap C v p).symm⟩
+
+private theorem
+    CuspCentralHomology.centralCollapseMap_opposite (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (k : Fin 6) (t : unitInterval) (u : ToricSpace.CompactFibreTorus) :
+    CuspCollapse.centralCollapseMap C ε hε
+        (u, edgeArcPositive (C 0) (k + 3) (unitInterval.symm t)) =
+      CuspCollapse.centralCollapseMap C ε hε
+        ((CuspCollapse.deckFibrePhase (C 0)
+                (ToricSpace.cuspVector (ToricComponent.hexagonRay k)))⁻¹ *
+            u,
+          edgeArcPositive (C 0) k t) := by
+  have h :=
+    centralCollapseMap_phaseDeckMap C ε hε (ToricSpace.cuspVector (ToricComponent.hexagonRay k))
+      ((CuspCollapse.deckFibrePhase (C 0)
+              (ToricSpace.cuspVector (ToricComponent.hexagonRay k)))⁻¹ *
+          u,
+        edgeArcPositive (C 0) k t)
+  simpa only [CuspCollapse.phaseDeckMap, mul_inv_cancel_left, ← edgeArcPositive_opposite] using h
+
+private theorem CuspCentralHomology.centralProject_edgeCylinder_opposite
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (k : Fin 6) (t : unitInterval)
+    (a : Circle) :
+    CuspCollapse.centralProject C ε hε (edgeCylinder (C 0) (k + 3) (unitInterval.symm t, a)) =
+      CuspCollapse.centralProject C ε hε
+        (edgeCylinder (C 0) k
+          (t,
+            hexagonCharacter k
+              ((CuspCollapse.deckFibrePhase (C 0)
+                    (ToricSpace.cuspVector (ToricComponent.hexagonRay k)))⁻¹ *
+                hexagonCharacterSection (k + 3) a))) := by
+  change
+    CuspCollapse.centralCollapseMap C ε hε
+        (hexagonCharacterSection (k + 3) a, edgeArcPositive (C 0) (k + 3) (unitInterval.symm t)) =
+      _
+  rw [centralCollapseMap_opposite]
+  exact
+    (congrArg (CuspCollapse.centralProject C ε hε)
+        (edgeCylinder_character_all (C 0) k t
+          ((CuspCollapse.deckFibrePhase (C 0)
+                (ToricSpace.cuspVector (ToricComponent.hexagonRay k)))⁻¹ *
+            hexagonCharacterSection (k + 3) a))).symm
+
+private theorem CuspCentralHomology.centralProject_edgeCylinder_opposite_exists
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (k : Fin 6) (t : unitInterval)
+    (a : Circle) :
+    ∃ b : Circle,
+      CuspCollapse.centralProject C ε hε (edgeCylinder (C 0) (k + 3) (unitInterval.symm t, a)) =
+        CuspCollapse.centralProject C ε hε (edgeCylinder (C 0) k (t, b)) :=
+  ⟨_, centralProject_edgeCylinder_opposite C ε hε k t a⟩
+
+private theorem CuspCentralHomology.edgeCylinder_mem_range_doubleCylinder
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (k : Fin 6) (t : unitInterval)
+    (a : Circle) :
+    CuspCollapse.centralProject C ε hε (edgeCylinder (C 0) k (t, a)) ∈
+      Set.range (doubleCylinder C ε hε) := by
+  fin_cases k
+  · exact ⟨(t, Sum.inl a), rfl⟩
+  · change CuspCollapse.centralProject C ε hε (edgeCylinder (C 0) (1 : Fin 6) (t, a)) ∈ _
+    refine ⟨(unitInterval.symm t, Sum.inr (Sum.inl a)), ?_⟩
+    rw [doubleCylinder_middle, unitInterval.symm_symm]
+  · exact ⟨(t, Sum.inr (Sum.inr a)), rfl⟩
+  · change CuspCollapse.centralProject C ε hε (edgeCylinder (C 0) (3 : Fin 6) (t, a)) ∈ _
+    obtain ⟨b, hb⟩ := centralProject_edgeCylinder_opposite_exists C ε hε 0 (unitInterval.symm t) a
+    refine ⟨(unitInterval.symm t, Sum.inl b), ?_⟩
+    simpa only [show (0 + 3 : Fin 6) = 3 from by decide, doubleCylinder_first,
+      unitInterval.symm_symm] using hb.symm
+  · change CuspCollapse.centralProject C ε hε (edgeCylinder (C 0) (4 : Fin 6) (t, a)) ∈ _
+    obtain ⟨b, hb⟩ := centralProject_edgeCylinder_opposite_exists C ε hε 1 (unitInterval.symm t) a
+    refine ⟨(t, Sum.inr (Sum.inl b)), ?_⟩
+    simpa only [show (1 + 3 : Fin 6) = 4 from by decide, doubleCylinder_middle,
+      unitInterval.symm_symm] using hb.symm
+  · change CuspCollapse.centralProject C ε hε (edgeCylinder (C 0) (5 : Fin 6) (t, a)) ∈ _
+    obtain ⟨b, hb⟩ := centralProject_edgeCylinder_opposite_exists C ε hε 2 (unitInterval.symm t) a
+    refine ⟨(unitInterval.symm t, Sum.inr (Sum.inr b)), ?_⟩
+    simpa only [show (2 + 3 : Fin 6) = 5 from by decide, doubleCylinder_last,
+      unitInterval.symm_symm] using hb.symm
+
+private theorem CuspCentralHomology.centralCollapseMap_edgeArc_mem_range_doubleCylinder
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (k : Fin 6) (t : unitInterval)
+    (u : ToricSpace.CompactFibreTorus) :
+    CuspCollapse.centralCollapseMap C ε hε (u, edgeArcPositive (C 0) k t) ∈
+      Set.range (doubleCylinder C ε hε) := by
+  have h := edgeCylinder_mem_range_doubleCylinder C ε hε k t (hexagonCharacter k u)
+  change
+    CuspCollapse.centralProject C ε hε
+        (CuspCollapse.centralPolarMap (u, edgeArcPositive (C 0) k t)) ∈
+      _
+  rwa [edgeCylinder_character_all] at h
+
+private theorem
+    CuspCentralHomology.range_doubleSuspensionMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : Set.range (doubleSuspensionMap C ε hε) = Set.range (doubleCylinder C ε hε) := by
+  ext q
+  constructor
+  · rintro ⟨p, rfl⟩
+    obtain ⟨⟨t, z⟩, rfl⟩ := Suspension.mk_surjective p
+    exact ⟨(t, z), rfl⟩
+  · rintro ⟨⟨t, z⟩, rfl⟩
+    exact ⟨Suspension.mk t z, rfl⟩
+
+private abbrev CuspCentralHomology.FundamentalCell :=
+  ToricSpace.CompactFibreTorus × CuspHoneycombTiling.baseCell
+
+private instance
+    CuspCentralHomology.fundamentalCell_compactSpace : CompactSpace FundamentalCell := by
+  let : CompactSpace CuspHoneycombTiling.baseCell :=
+    isCompact_iff_compactSpace.mp CuspHoneycombTiling.baseCell_isCompact
+  infer_instance
+
+private def CuspCentralHomology.fundamentalCellInclusion (p : FundamentalCell) :
+    CuspHoneycomb.PhasePlane :=
+  (p.1, (p.2 : (CuspHoneycombTiling.Plane)))
+
+private theorem CuspCentralHomology.fundamentalCellInclusion_continuous :
+    Continuous fundamentalCellInclusion :=
+  continuous_fst.prodMk (continuous_subtype_val.comp continuous_snd)
+
+private def CuspCentralHomology.fundamentalCellMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : FundamentalCell → CuspRetraction.QuotientCentralFibre C ε :=
+  CuspHoneycomb.honeycombCollapseMap C ε hε ∘ fundamentalCellInclusion
+
+private theorem CuspCentralHomology.fundamentalCellMap_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) : Continuous (fundamentalCellMap C ε hε) :=
+  (CuspHoneycomb.honeycombCollapseMap_continuous C ε hε).comp fundamentalCellInclusion_continuous
+
+private theorem
+    CuspCentralHomology.honeycombCollapseMap_deck_invariant (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (v : (CuspHoneycombTiling.Lattice)) (p : CuspHoneycomb.PhasePlane) :
+    CuspHoneycomb.honeycombCollapseMap C ε hε (CuspHoneycomb.honeycombDeckMap (C 0) v p) =
+      CuspHoneycomb.honeycombCollapseMap C ε hε p := by
+  apply (CuspHoneycomb.honeycombCollapseMap_eq_iff C ε hε _ _).mpr
+  refine ⟨v, rfl, ?_⟩
+  simp [CuspHoneycomb.honeycombDeckMap]
+
+private theorem CuspCentralHomology.fundamentalCellMap_surjective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) : Function.Surjective (fundamentalCellMap C ε hε) := by
+  intro q
+  obtain ⟨p, hp⟩ := CuspHoneycomb.honeycombCollapseMap_surjective C ε hε q
+  obtain ⟨v, hv⟩ := CuspHoneycombTiling.exists_mem_cell p.2
+  let y : CuspHoneycombTiling.baseCell := ⟨p.2 - CuspHoneycombTiling.latticePoint v, hv⟩
+  refine ⟨(CuspCollapse.deckFibrePhase (C 0) (ToricSpace.cuspVector v) * p.1, y), ?_⟩
+  change
+    CuspHoneycomb.honeycombCollapseMap C ε hε
+        (CuspCollapse.deckFibrePhase (C 0) (ToricSpace.cuspVector v) * p.1,
+          p.2 - CuspHoneycombTiling.latticePoint v) =
+      q
+  simpa only [CuspHoneycomb.honeycombDeckMap, ToricSpace.cuspVector_cuspVector,
+    CuspHoneycombTiling.latticePoint_neg, sub_eq_add_neg] using
+    (honeycombCollapseMap_deck_invariant C ε hε (ToricSpace.cuspVector v) p).trans hp
+
+private theorem
+    CuspCentralHomology.fundamentalCellMap_eq_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (p q : FundamentalCell) :
+    fundamentalCellMap C ε hε p = fundamentalCellMap C ε hε q ↔
+      ∃ v : (CuspHoneycombTiling.Lattice),
+        (p.2 : (CuspHoneycombTiling.Plane)) =
+            (q.2 : (CuspHoneycombTiling.Plane)) +
+              CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v) ∧
+          p.1⁻¹ * (CuspCollapse.deckFibrePhase (C 0) v * q.1) ∈
+            MulAction.stabilizer ToricSpace.CompactFibreTorus
+              ((CuspHoneycomb.honeycombHomeomorph (C 0) (p.2 : (CuspHoneycombTiling.Plane))).1 :
+                ToricSpace.Space) :=
+  CuspHoneycomb.honeycombCollapseMap_eq_iff C ε hε (fundamentalCellInclusion p)
+    (fundamentalCellInclusion q)
+
+private theorem
+    CuspCentralHomology.fundamentalCellMap_isProperMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : IsProperMap (fundamentalCellMap C ε hε) := by
+  let := CuspQuotient.quotient_t2Space C ε hε hε1 hC hR
+  exact (fundamentalCellMap_continuous C ε hε).isProperMap
+
+private theorem
+    CuspCentralHomology.fundamentalCellMap_isClosedMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : IsClosedMap (fundamentalCellMap C ε hε) :=
+  (fundamentalCellMap_isProperMap C ε hε hε1 hC hR).isClosedMap
+
+private theorem
+    CuspCentralHomology.fundamentalCellMap_isQuotientMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : Topology.IsQuotientMap (fundamentalCellMap C ε hε) :=
+  (fundamentalCellMap_isClosedMap C ε hε hε1 hC hR).isQuotientMap
+    (fundamentalCellMap_continuous C ε hε) (fundamentalCellMap_surjective C ε hε)
+
+private theorem
+    CuspCentralHomology.fundamentalCellMap_eq_of_interior (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (p q : FundamentalCell)
+    (hp : (p.2 : (CuspHoneycombTiling.Plane)) ∈ interior CuspHoneycombTiling.baseCell)
+    (h : fundamentalCellMap C ε hε p = fundamentalCellMap C ε hε q) : p = q := by
+  obtain ⟨u, hb, hphase⟩ := (fundamentalCellMap_eq_iff C ε hε p q).mp h
+  have hpcell :
+    (p.2 : (CuspHoneycombTiling.Plane)) ∈ CuspHoneycombTiling.cell (ToricSpace.cuspVector u) := by
+    rw [hb, CuspHoneycombTiling.mem_cell, add_sub_cancel_right]
+    exact q.2.2
+  have hpinterior : (p.2 : (CuspHoneycombTiling.Plane)) ∈ interior (CuspHoneycombTiling.cell 0) :=
+    by simpa only [CuspHoneycombTiling.cell_zero] using hp
+  have hcells :=
+    (CuspHoneycombTiling.containingCells_eq_singleton_iff (p.2 : (CuspHoneycombTiling.Plane))
+          0).mpr
+      hpinterior
+  have hcu : ToricSpace.cuspVector u = 0 := by
+    have hu :
+      ToricSpace.cuspVector u ∈
+        {v : (CuspHoneycombTiling.Lattice) |
+          (p.2 : (CuspHoneycombTiling.Plane)) ∈ CuspHoneycombTiling.cell v} :=
+      hpcell
+    simpa only [hcells, Set.mem_singleton_iff] using hu
+  have hu : u = 0 := ToricSpace.cuspVector_injective (hcu.trans ToricSpace.cuspVector_zero.symm)
+  subst u
+  have hb' : (p.2 : (CuspHoneycombTiling.Plane)) = (q.2 : (CuspHoneycombTiling.Plane)) := by
+    simpa only [ToricSpace.cuspVector_zero, CuspHoneycombTiling.latticePoint_zero, add_zero] using
+      hb
+  have hstab :=
+    CuspHoneycomb.honeycombHomeomorph_stabilizer_eq_bot_of_mem_interior (C 0)
+      (p.2 : (CuspHoneycombTiling.Plane)) 0 hpinterior
+  have hphase' : p.1 = q.1 := by
+    simpa only [hstab, Subgroup.mem_bot, CuspCollapse.deckFibrePhase_zero, one_mul,
+      inv_mul_eq_one] using hphase
+  exact Prod.ext hphase' (Subtype.ext hb')
+
+private theorem CuspCentralHomology.fundamentalCellMap_interior_iff_of_eq
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (p q : FundamentalCell)
+    (h : fundamentalCellMap C ε hε p = fundamentalCellMap C ε hε q) :
+    (p.2 : (CuspHoneycombTiling.Plane)) ∈ interior CuspHoneycombTiling.baseCell ↔
+      (q.2 : (CuspHoneycombTiling.Plane)) ∈ interior CuspHoneycombTiling.baseCell := by
+  constructor
+  · intro hp
+    have hpq := fundamentalCellMap_eq_of_interior C ε hε p q hp h
+    simpa only [← hpq] using hp
+  · intro hq
+    have hqp := fundamentalCellMap_eq_of_interior C ε hε q p hq h.symm
+    simpa only [← hqp] using hq
+
+private theorem
+    CuspCentralHomology.fundamentalCellMap_eq_or_frontier (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (p q : FundamentalCell)
+    (h : fundamentalCellMap C ε hε p = fundamentalCellMap C ε hε q) :
+    p = q ∨
+      ((p.2 : (CuspHoneycombTiling.Plane)) ∈ frontier CuspHoneycombTiling.baseCell ∧
+        (q.2 : (CuspHoneycombTiling.Plane)) ∈ frontier CuspHoneycombTiling.baseCell) := by
+  by_cases hp : (p.2 : (CuspHoneycombTiling.Plane)) ∈ interior CuspHoneycombTiling.baseCell
+  · exact Or.inl (fundamentalCellMap_eq_of_interior C ε hε p q hp h)
+  · right
+    rw [CuspHoneycombTiling.baseCell_isClosed.frontier_eq]
+    refine ⟨⟨p.2.2, hp⟩, q.2.2, ?_⟩
+    intro hq
+    exact hp ((fundamentalCellMap_interior_iff_of_eq C ε hε p q h).mpr hq)
+
+private theorem CuspCentralHomology.fundamentalCellMap_eq_base_or_frontier
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (p q : FundamentalCell)
+    (h : fundamentalCellMap C ε hε p = fundamentalCellMap C ε hε q) :
+    (p.2 : (CuspHoneycombTiling.Plane)) = (q.2 : (CuspHoneycombTiling.Plane)) ∨
+      ((p.2 : (CuspHoneycombTiling.Plane)) ∈ frontier CuspHoneycombTiling.baseCell ∧
+        (q.2 : (CuspHoneycombTiling.Plane)) ∈ frontier CuspHoneycombTiling.baseCell) := by
+  rcases fundamentalCellMap_eq_or_frontier C ε hε p q h with hpq | hfrontier
+  · exact Or.inl (congrArg (fun r : FundamentalCell => (r.2 : (CuspHoneycombTiling.Plane))) hpq)
+  · exact Or.inr hfrontier
+
+private def CuspCentralHomology.Radial.cellGauge (x : CuspHoneycombTiling.Plane) : ℝ :=
+  Max.max |2 * x 0 + x 1| (Max.max |x 0 - x 1| |x 0 + 2 * x 1|)
+
+private theorem CuspCentralHomology.Radial.cellGauge_continuous : Continuous cellGauge :=
+  (((continuous_const.mul (continuous_apply 0)).add (continuous_apply 1)).abs).max
+    (((continuous_apply 0).sub (continuous_apply 1)).abs.max
+      ((continuous_apply 0).add (continuous_const.mul (continuous_apply 1))).abs)
+
+private theorem CuspCentralHomology.Radial.cellGauge_nonneg (x : CuspHoneycombTiling.Plane) :
+    0 ≤ cellGauge x :=
+  (abs_nonneg _).trans (le_max_left _ _)
+
+@[simp]
+private theorem CuspCentralHomology.Radial.cellGauge_zero :
+    cellGauge (0 : CuspHoneycombTiling.Plane) = 0 := by simp [cellGauge]
+
+private theorem CuspCentralHomology.Radial.cellGauge_smul (c : ℝ) (x : CuspHoneycombTiling.Plane) :
+    cellGauge (c • x) = |c| * cellGauge x := by
+  have h0 : 2 * (c * x 0) + c * x 1 = c * (2 * x 0 + x 1) := by ring
+  have h1 : c * x 0 - c * x 1 = c * (x 0 - x 1) := by ring
+  have h2 : c * x 0 + 2 * (c * x 1) = c * (x 0 + 2 * x 1) := by ring
+  simp only [cellGauge, Pi.smul_apply, smul_eq_mul, h0, h1, h2, abs_mul,
+    mul_max_of_nonneg _ _ (abs_nonneg c)]
+
+private theorem CuspCentralHomology.Radial.cellGauge_smul_of_nonneg (c : ℝ) (hc : 0 ≤ c)
+    (x : CuspHoneycombTiling.Plane) : cellGauge (c • x) = c * cellGauge x := by
+  rw [cellGauge_smul, abs_of_nonneg hc]
+
+@[simp]
+private theorem CuspCentralHomology.Radial.cellGauge_eq_zero_iff (x : CuspHoneycombTiling.Plane) :
+    cellGauge x = 0 ↔ x = 0 := by
+  constructor
+  · intro hx
+    have h0 : |2 * x 0 + x 1| ≤ 0 := (le_max_left _ _).trans (le_of_eq hx)
+    have h1 : |x 0 - x 1| ≤ 0 := (le_max_left _ _).trans ((le_max_right _ _).trans (le_of_eq hx))
+    have h0' : 2 * x 0 + x 1 = 0 := abs_eq_zero.mp (le_antisymm h0 (abs_nonneg _))
+    have h1' : x 0 - x 1 = 0 := abs_eq_zero.mp (le_antisymm h1 (abs_nonneg _))
+    funext i
+    fin_cases i
+    · change x 0 = 0
+      linarith
+    · change x 1 = 0
+      linarith
+  · rintro rfl
+    exact cellGauge_zero
+
+private theorem CuspCentralHomology.Radial.cellGauge_pos_iff (x : CuspHoneycombTiling.Plane) :
+    0 < cellGauge x ↔ x ≠ 0 := by
+  constructor
+  · intro hx hzero
+    simp only [hzero, cellGauge_zero, lt_self_iff_false] at hx
+  · intro hx
+    apply lt_of_le_of_ne (cellGauge_nonneg x)
+    intro h
+    exact hx ((cellGauge_eq_zero_iff x).mp h.symm)
+
+private theorem CuspCentralHomology.Radial.mem_baseCell_iff (x : CuspHoneycombTiling.Plane) :
+    x ∈ CuspHoneycombTiling.baseCell ↔ cellGauge x ≤ 1 := by
+  simp only [CuspHoneycombTiling.mem_baseCell, cellGauge, max_le_iff]
+
+private theorem
+    CuspCentralHomology.Radial.mem_interior_baseCell_iff (x : CuspHoneycombTiling.Plane) :
+    x ∈ interior CuspHoneycombTiling.baseCell ↔ cellGauge x < 1 := by
+  constructor
+  · intro hx
+    have hle := (mem_baseCell_iff x).mp (interior_subset hx)
+    apply lt_of_le_of_ne hle
+    intro heq
+    have hopen : IsOpen ((fun a : ℝ => a • x) ⁻¹' interior CuspHoneycombTiling.baseCell) :=
+      isOpen_interior.preimage (continuous_id.smul continuous_const)
+    have hone : (1 : ℝ) ∈ (fun a : ℝ => a • x) ⁻¹' interior CuspHoneycombTiling.baseCell := by
+      simpa only [Set.mem_preimage, one_smul] using hx
+    obtain ⟨δ, hδ, hball⟩ := Metric.isOpen_iff.mp hopen 1 hone
+    have ha : (1 + δ / 2) • x ∈ interior CuspHoneycombTiling.baseCell :=
+      hball
+        (by
+          change Dist.dist (1 + δ / 2) (1 : ℝ) < δ
+          rw [Real.dist_eq, add_sub_cancel_left, abs_of_pos (half_pos hδ)]
+          exact half_lt_self hδ)
+    have hb := (mem_baseCell_iff _).mp (interior_subset ha)
+    rw [cellGauge_smul_of_nonneg _ (by linarith), heq, mul_one] at hb
+    linarith
+  · intro hx
+    have hopen : IsOpen {y : CuspHoneycombTiling.Plane | cellGauge y < 1} :=
+      isOpen_lt cellGauge_continuous continuous_const
+    apply mem_interior_iff_mem_nhds.mpr
+    apply Filter.mem_of_superset (hopen.mem_nhds hx)
+    intro y hy
+    exact (mem_baseCell_iff y).mpr hy.le
+
+private theorem
+    CuspCentralHomology.Radial.mem_frontier_baseCell_iff (x : CuspHoneycombTiling.Plane) :
+    x ∈ frontier CuspHoneycombTiling.baseCell ↔ cellGauge x = 1 := by
+  rw [frontier, CuspHoneycombTiling.baseCell_isClosed.closure_eq, Set.mem_sdiff, mem_baseCell_iff,
+    mem_interior_baseCell_iff, not_lt]
+  exact ⟨fun h => le_antisymm h.1 h.2, fun h => ⟨h.le, h.ge⟩⟩
+
+private def CuspCentralHomology.fundamentalRadius (p : FundamentalCell) : ℝ :=
+  Radial.cellGauge (p.2 : (CuspHoneycombTiling.Plane))
+
+private theorem CuspCentralHomology.fundamentalRadius_continuous : Continuous fundamentalRadius :=
+  Radial.cellGauge_continuous.comp (continuous_subtype_val.comp continuous_snd)
+
+private theorem
+    CuspCentralHomology.fundamentalRadius_eq_of_map_eq (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (p q : FundamentalCell)
+    (h : fundamentalCellMap C ε hε p = fundamentalCellMap C ε hε q) :
+    fundamentalRadius p = fundamentalRadius q := by
+  change
+    Radial.cellGauge (p.2 : (CuspHoneycombTiling.Plane)) =
+      Radial.cellGauge (q.2 : (CuspHoneycombTiling.Plane))
+  rcases fundamentalCellMap_eq_base_or_frontier C ε hε p q h with he | ⟨hp, hq⟩
+  · exact congrArg Radial.cellGauge he
+  · rw [(Radial.mem_frontier_baseCell_iff _).mp hp, (Radial.mem_frontier_baseCell_iff _).mp hq]
+
+private def
+    CuspCentralHomology.centralRadius (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    CuspRetraction.QuotientCentralFibre C ε → ℝ :=
+  CuspHoneycombHexagon.CommonFibres.descend (fundamentalCellMap C ε hε) fundamentalRadius
+    (fundamentalCellMap_surjective C ε hε)
+
+@[simp]
+private theorem
+    CuspCentralHomology.centralRadius_fundamentalCellMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (p : FundamentalCell) :
+    centralRadius C ε hε (fundamentalCellMap C ε hε p) =
+      Radial.cellGauge (p.2 : (CuspHoneycombTiling.Plane)) :=
+  CuspHoneycombHexagon.CommonFibres.descend_apply (fundamentalCellMap C ε hε) fundamentalRadius
+    (fundamentalCellMap_surjective C ε hε) (fundamentalRadius_eq_of_map_eq C ε hε) p
+
+private def
+    CuspCentralHomology.centralBoundary (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    Set (CuspRetraction.QuotientCentralFibre C ε) :=
+  {q | centralRadius C ε hε q = 1}
+
+private def CuspCentralHomology.outerRegion (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (a : ℝ) : Set (CuspRetraction.QuotientCentralFibre C ε) :=
+  {q | a < centralRadius C ε hε q}
+
+private def
+    CuspCentralHomology.innerRegion (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    Set (CuspRetraction.QuotientCentralFibre C ε) :=
+  {q | centralRadius C ε hε q < 1}
+
+private theorem CuspCentralHomology.fundamentalCellMap_mem_centralBoundary_iff
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (p : FundamentalCell) :
+    fundamentalCellMap C ε hε p ∈ centralBoundary C ε hε ↔
+      (p.2 : (CuspHoneycombTiling.Plane)) ∈ frontier CuspHoneycombTiling.baseCell := by
+  change centralRadius C ε hε (fundamentalCellMap C ε hε p) = 1 ↔ _
+  rw [centralRadius_fundamentalCellMap]
+  exact (Radial.mem_frontier_baseCell_iff _).symm
+
+private theorem CuspCentralHomology.fundamentalCellMap_mem_innerRegion_iff
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (p : FundamentalCell) :
+    fundamentalCellMap C ε hε p ∈ innerRegion C ε hε ↔
+      (p.2 : (CuspHoneycombTiling.Plane)) ∈ interior CuspHoneycombTiling.baseCell := by
+  change centralRadius C ε hε (fundamentalCellMap C ε hε p) < 1 ↔ _
+  rw [centralRadius_fundamentalCellMap]
+  exact (Radial.mem_interior_baseCell_iff _).symm
+
+private theorem
+    CuspCentralHomology.centralBoundary_eq_image (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) :
+    centralBoundary C ε hε =
+      CuspHoneycomb.honeycombCollapseMap C ε hε ''
+        ((Set.univ : Set ToricSpace.CompactFibreTorus) ×ˢ
+          frontier CuspHoneycombTiling.baseCell) := by
+  ext q
+  constructor
+  · intro hq
+    obtain ⟨p, rfl⟩ := fundamentalCellMap_surjective C ε hε q
+    exact
+      ⟨(p.1, (p.2 : (CuspHoneycombTiling.Plane))),
+        ⟨Set.mem_univ _, (fundamentalCellMap_mem_centralBoundary_iff C ε hε p).mp hq⟩, rfl⟩
+  · rintro ⟨⟨φ, x⟩, ⟨_, hx⟩, rfl⟩
+    let p : FundamentalCell := (φ, ⟨x, CuspHoneycombTiling.baseCell_isClosed.frontier_subset hx⟩)
+    exact (fundamentalCellMap_mem_centralBoundary_iff C ε hε p).mpr hx
+
+private theorem
+    CuspCentralHomology.centralBoundary_subset_outerRegion (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (a : ℝ) (ha : a < 1) : centralBoundary C ε hε ⊆ outerRegion C ε hε a := by
+  intro q hq
+  change a < centralRadius C ε hε q
+  change centralRadius C ε hε q = 1 at hq
+  rwa [hq]
+
+private theorem CuspCentralHomology.outerRegion_union_innerRegion (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (a : ℝ) (ha : a < 1) :
+    outerRegion C ε hε a ∪ innerRegion C ε hε = Set.univ := by
+  apply Set.eq_univ_of_forall
+  intro q
+  by_cases hq : centralRadius C ε hε q < 1
+  · exact Or.inr hq
+  · exact Or.inl (ha.trans_le (le_of_not_gt hq))
+
+private theorem
+    CuspCentralHomology.centralRadius_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : Continuous (centralRadius C ε hε) :=
+  CuspHoneycombHexagon.CommonFibres.descend_continuous (fundamentalCellMap C ε hε)
+    fundamentalRadius (fundamentalCellMap_surjective C ε hε)
+    (fundamentalCellMap_isQuotientMap C ε hε hε1 hC hR) fundamentalRadius_continuous
+    (fundamentalRadius_eq_of_map_eq C ε hε)
+
+private theorem CuspCentralHomology.outerRegion_isOpen (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) : IsOpen (outerRegion C ε hε a) :=
+  isOpen_lt continuous_const (centralRadius_continuous C ε hε hε1 hC hR)
+
+private theorem CuspCentralHomology.innerRegion_isOpen (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : IsOpen (innerRegion C ε hε) :=
+  isOpen_lt (centralRadius_continuous C ε hε hε1 hC hR) continuous_const
+
+private theorem CuspCentralHomology.honeycombHomeomorph_baseCell_coe (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (x : CuspHoneycombTiling.baseCell) :
+    ((CuspHoneycomb.honeycombHomeomorph C₀ (x : (CuspHoneycombTiling.Plane))).1 :
+        ToricSpace.Space) =
+      ((CuspHoneycombHexagon.compatibleCellHomeomorph C₀ x).1 : ToricSpace.Space) := by
+  let y : CuspHoneycombTiling.cell 0 := CuspHoneycombTiling.cellTranslationHomeomorph 0 x
+  have hy : (y : (CuspHoneycombTiling.Plane)) = (x : (CuspHoneycombTiling.Plane)) := by
+    change
+      (x : (CuspHoneycombTiling.Plane)) + CuspHoneycombTiling.latticePoint 0 =
+        (x : (CuspHoneycombTiling.Plane))
+    rw [CuspHoneycombTiling.latticePoint_zero, add_zero]
+  have hnorm : (CuspHoneycombTiling.cellTranslationHomeomorph 0).symm y = x :=
+    (CuspHoneycombTiling.cellTranslationHomeomorph 0).symm_apply_apply x
+  have h := CuspHoneycomb.honeycombHomeomorph_cell_coe C₀ 0 y
+  rw [hy, hnorm, ToricSpace.cuspVector_zero, neg_zero, ToricSpace.twistedTranslate_zero] at h
+  exact h
+
+private def CuspCentralHomology.edgeArcBase (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (k : Fin 6)
+    (t : unitInterval) : CuspHoneycombTiling.baseCell :=
+  (CuspHoneycombHexagon.compatibleCellHomeomorph C₀).symm
+    (CuspHoneycombHexagon.compatibleBoundaryArc C₀ k t).1
+
+@[simp]
+private theorem
+    CuspCentralHomology.compatibleCellHomeomorph_edgeArcBase (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) (t : unitInterval) :
+    CuspHoneycombHexagon.compatibleCellHomeomorph C₀ (edgeArcBase C₀ k t) =
+      (CuspHoneycombHexagon.compatibleBoundaryArc C₀ k t).1 :=
+  (CuspHoneycombHexagon.compatibleCellHomeomorph C₀).apply_symm_apply _
+
+private theorem
+    CuspCentralHomology.edgeArcBase_mem_frontier (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (k : Fin 6)
+    (t : unitInterval) :
+    (edgeArcBase C₀ k t : (CuspHoneycombTiling.Plane)) ∈ frontier CuspHoneycombTiling.baseCell := by
+  rw [CuspHoneycombTiling.frontier_baseCell, Set.mem_iUnion]
+  refine ⟨k, (edgeArcBase C₀ k t).2, ?_⟩
+  apply
+    (CuspHoneycombHexagon.compatibleCellHomeomorph_mem_boundary_iff C₀ (edgeArcBase C₀ k t) k).mp
+  rw [compatibleCellHomeomorph_edgeArcBase]
+  exact (CuspHoneycombHexagon.compatibleBoundaryArc C₀ k t).2
+
+@[simp]
+private theorem CuspCentralHomology.honeycombHomeomorph_edgeArcBase (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) (t : unitInterval) :
+    CuspHoneycomb.honeycombHomeomorph C₀ (edgeArcBase C₀ k t : (CuspHoneycombTiling.Plane)) =
+      edgeArcPositive C₀ k t := by
+  apply Subtype.ext
+  apply Subtype.ext
+  change
+    ((CuspHoneycomb.honeycombHomeomorph C₀ (edgeArcBase C₀ k t : (CuspHoneycombTiling.Plane))).1 :
+        ToricSpace.Space) =
+      ((CuspHoneycombHexagon.compatibleBoundaryArc C₀ k t).1.1 : ToricSpace.Space)
+  rw [honeycombHomeomorph_baseCell_coe, compatibleCellHomeomorph_edgeArcBase]
+
+private theorem
+    CuspCentralHomology.exists_edgeArcBase_of_mem_frontier (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (x : (CuspHoneycombTiling.Plane)) (hx : x ∈ frontier CuspHoneycombTiling.baseCell) :
+    ∃ k : Fin 6, ∃ t : unitInterval, (edgeArcBase C₀ k t : (CuspHoneycombTiling.Plane)) = x := by
+  obtain ⟨k, hbase, hside⟩ :=
+    Set.mem_iUnion.mp ((congrArg (x ∈ ·) CuspHoneycombTiling.frontier_baseCell).mp hx)
+  let a : CuspHoneycombTiling.baseCell := ⟨x, hbase⟩
+  have ha :
+    CuspHoneycombHexagon.compatibleCellHomeomorph C₀ a ∈
+      CuspHoneycombHexagon.positiveBoundary k :=
+    (CuspHoneycombHexagon.compatibleCellHomeomorph_mem_boundary_iff C₀ a k).mpr hside
+  obtain ⟨t, ht⟩ :=
+    (CuspHoneycombHexagon.compatibleBoundaryArc C₀ k).surjective
+      ⟨CuspHoneycombHexagon.compatibleCellHomeomorph C₀ a, ha⟩
+  refine ⟨k, t, ?_⟩
+  have hcell : edgeArcBase C₀ k t = a := by
+    apply (CuspHoneycombHexagon.compatibleCellHomeomorph C₀).injective
+    rw [compatibleCellHomeomorph_edgeArcBase]
+    exact congrArg Subtype.val ht
+  exact congrArg Subtype.val hcell
+
+private theorem
+    CuspCentralHomology.honeycombHomeomorph_mem_edgeArcs_iff (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (x : (CuspHoneycombTiling.Plane)) :
+    (∃ k : Fin 6,
+        ∃ t : unitInterval, CuspHoneycomb.honeycombHomeomorph C₀ x = edgeArcPositive C₀ k t) ↔
+      x ∈ frontier CuspHoneycombTiling.baseCell := by
+  constructor
+  · rintro ⟨k, t, h⟩
+    have hx : x = (edgeArcBase C₀ k t : (CuspHoneycombTiling.Plane)) :=
+      (CuspHoneycomb.honeycombHomeomorph C₀).injective
+        (h.trans (honeycombHomeomorph_edgeArcBase C₀ k t).symm)
+    rw [hx]
+    exact edgeArcBase_mem_frontier C₀ k t
+  · intro hx
+    obtain ⟨k, t, ht⟩ := exists_edgeArcBase_of_mem_frontier C₀ x hx
+    refine ⟨k, t, ?_⟩
+    rw [← ht, honeycombHomeomorph_edgeArcBase]
+
+private theorem
+    CuspCentralHomology.mem_centralBoundary_iff_edgeArc (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (q : CuspRetraction.QuotientCentralFibre C ε) :
+    q ∈ centralBoundary C ε hε ↔
+      ∃ k : Fin 6,
+        ∃ t : unitInterval,
+          ∃ u : ToricSpace.CompactFibreTorus,
+            CuspCollapse.centralCollapseMap C ε hε (u, edgeArcPositive (C 0) k t) = q := by
+  rw [centralBoundary_eq_image]
+  constructor
+  · rintro ⟨⟨u, x⟩, ⟨_, hx⟩, hq⟩
+    obtain ⟨k, t, ht⟩ := (honeycombHomeomorph_mem_edgeArcs_iff (C 0) x).mpr hx
+    refine ⟨k, t, u, ?_⟩
+    change
+      CuspCollapse.centralCollapseMap C ε hε (u, CuspHoneycomb.honeycombHomeomorph (C 0) x) =
+        q at hq
+    rw [ht] at hq
+    exact hq
+  · rintro ⟨k, t, u, hq⟩
+    refine
+      ⟨(u, (edgeArcBase (C 0) k t : (CuspHoneycombTiling.Plane))),
+        ⟨Set.mem_univ _, edgeArcBase_mem_frontier (C 0) k t⟩, ?_⟩
+    change
+      CuspCollapse.centralCollapseMap C ε hε
+          (u,
+            CuspHoneycomb.honeycombHomeomorph (C 0)
+              (edgeArcBase (C 0) k t : (CuspHoneycombTiling.Plane))) =
+        q
+    rw [honeycombHomeomorph_edgeArcBase]
+    exact hq
+
+private theorem CuspCentralHomology.centralCollapseMap_edgeArc_mem_centralBoundary
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (k : Fin 6) (t : unitInterval)
+    (u : ToricSpace.CompactFibreTorus) :
+    CuspCollapse.centralCollapseMap C ε hε (u, edgeArcPositive (C 0) k t) ∈
+      centralBoundary C ε hε :=
+  (mem_centralBoundary_iff_edgeArc C ε hε _).mpr ⟨k, t, u, rfl⟩
+
+private theorem CuspCentralHomology.centralProject_edgeCylinder_mem_centralBoundary
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (k : Fin 6)
+    (p : unitInterval × Circle) :
+    CuspCollapse.centralProject C ε hε (edgeCylinder (C 0) k p) ∈ centralBoundary C ε hε :=
+  centralCollapseMap_edgeArc_mem_centralBoundary C ε hε k p.1 (hexagonCharacterSection k p.2)
+
+private def
+    CuspCentralHomology.threeCirclesIntersectionHomologyZeroEquiv {X : Type} [TopologicalSpace X]
+    (U V : Set X) (e : (U ∩ V : Set X) ≃ₕ ThreeCircles) :
+    SingularMayerVietoris.SingularHomology (U ∩ V : Set X) 0 ≃ₗ[ℤ] (Fin 3 → ℤ) :=
+  ((PeriodTorusHigherHomology.homotopyEquivHomologyEquiv e 0).toAddEquiv.trans
+      threeCirclesHomologyZeroEquiv.toAddEquiv).toIntLinearEquiv
+
+private theorem CuspCentralHomology.threeCirclesIntersectionHomologyZeroEquiv_map {X : Type}
+    [TopologicalSpace X] (U V : Set X) {Y : Type} [TopologicalSpace Y] [PathConnectedSpace Y]
+    (e : (U ∩ V : Set X) ≃ₕ ThreeCircles) (f : C((U ∩ V : Set X), Y))
+    (a : SingularMayerVietoris.SingularHomology (U ∩ V : Set X) 0) :
+    PeriodTorusHigherHomology.connectedHomologyZeroEquiv Y
+        (SingularMayerVietoris.singularHomologyMap f 0 a) =
+      sumCoordinates (threeCirclesIntersectionHomologyZeroEquiv U V e a) :=
+  threeCirclesHomologyZeroEquiv_map_homotopyEquiv e f a
+
+private theorem CuspCentralHomology.threeCirclesIntersectionLeftMap_zero_iff {X : Type}
+    [TopologicalSpace X] (U V : Set X) [PathConnectedSpace U] [PathConnectedSpace V]
+    (e : (U ∩ V : Set X) ≃ₕ ThreeCircles)
+    (a : SingularMayerVietoris.SingularHomology (U ∩ V : Set X) 0) :
+    SingularMayerVietoris.leftHomologyMap U V 0 a = 0 ↔
+      sumCoordinates (threeCirclesIntersectionHomologyZeroEquiv U V e a) = 0 := by
+  constructor
+  · intro ha
+    have hleft :
+      SingularMayerVietoris.singularHomologyMap
+          (ContinuousMap.inclusion (Set.inter_subset_left : U ∩ V ⊆ U)) 0 a =
+        0 := by
+      rw [SingularMayerVietoris.leftHomologyMap_apply] at ha
+      exact congrArg Prod.fst ha
+    have hsum :=
+      threeCirclesIntersectionHomologyZeroEquiv_map U V e
+        (ContinuousMap.inclusion (Set.inter_subset_left : U ∩ V ⊆ U)) a
+    rw [hleft, map_zero] at hsum
+    exact hsum.symm
+  · intro ha
+    have hleft :
+      SingularMayerVietoris.singularHomologyMap
+          (ContinuousMap.inclusion (Set.inter_subset_left : U ∩ V ⊆ U)) 0 a =
+        0 := by
+      apply (PeriodTorusHigherHomology.connectedHomologyZeroEquiv U).injective
+      rw [map_zero, threeCirclesIntersectionHomologyZeroEquiv_map U V e]
+      exact ha
+    have hright :
+      SingularMayerVietoris.singularHomologyMap
+          (ContinuousMap.inclusion (Set.inter_subset_right : U ∩ V ⊆ V)) 0 a =
+        0 := by
+      apply (PeriodTorusHigherHomology.connectedHomologyZeroEquiv V).injective
+      rw [map_zero, threeCirclesIntersectionHomologyZeroEquiv_map U V e]
+      exact ha
+    rw [SingularMayerVietoris.leftHomologyMap_apply, hleft, hright, neg_zero]
+    rfl
+
+private theorem
+    CuspCentralHomology.threeCirclesIntersection_mem_ker_iff {X : Type} [TopologicalSpace X]
+    (U V : Set X) [PathConnectedSpace U] [PathConnectedSpace V]
+    (e : (U ∩ V : Set X) ≃ₕ ThreeCircles)
+    (a : SingularMayerVietoris.SingularHomology (U ∩ V : Set X) 0) :
+    a ∈ LinearMap.ker (SingularMayerVietoris.leftHomologyMap U V 0) ↔
+      threeCirclesIntersectionHomologyZeroEquiv U V e a ∈ LinearMap.ker sumCoordinates :=
+  threeCirclesIntersectionLeftMap_zero_iff U V e a
+
+private def
+    CuspCentralHomology.threeCirclesIntersectionKernelToSumEquiv {X : Type} [TopologicalSpace X]
+    (U V : Set X) [PathConnectedSpace U] [PathConnectedSpace V]
+    (e : (U ∩ V : Set X) ≃ₕ ThreeCircles) :
+    LinearMap.ker (SingularMayerVietoris.leftHomologyMap U V 0) ≃ₗ[ℤ]
+      LinearMap.ker sumCoordinates :=
+  ({    toFun
+          a :=
+          ⟨threeCirclesIntersectionHomologyZeroEquiv U V e a,
+            (threeCirclesIntersection_mem_ker_iff U V e a).mp a.property⟩
+        invFun
+          b :=
+          ⟨(threeCirclesIntersectionHomologyZeroEquiv U V e).symm b,
+            by
+            apply (threeCirclesIntersection_mem_ker_iff U V e _).mpr
+            simpa only [LinearEquiv.apply_symm_apply] using b.property⟩
+        left_inv
+          a := Subtype.ext ((threeCirclesIntersectionHomologyZeroEquiv U V e).symm_apply_apply a)
+        right_inv
+          b := Subtype.ext ((threeCirclesIntersectionHomologyZeroEquiv U V e).apply_symm_apply b)
+        map_add' a
+          b := Subtype.ext ((threeCirclesIntersectionHomologyZeroEquiv U V e).map_add a b) } :
+      LinearMap.ker (SingularMayerVietoris.leftHomologyMap U V 0) ≃+
+        LinearMap.ker sumCoordinates).toIntLinearEquiv
+
+private def CuspCentralHomology.threeCirclesIntersectionKernelEquiv {X : Type} [TopologicalSpace X]
+    (U V : Set X) [PathConnectedSpace U] [PathConnectedSpace V]
+    (e : (U ∩ V : Set X) ≃ₕ ThreeCircles) :
+    LinearMap.ker (SingularMayerVietoris.leftHomologyMap U V 0) ≃ₗ[ℤ] (Fin 2 → ℤ) :=
+  ((threeCirclesIntersectionKernelToSumEquiv U V e).toAddEquiv.trans
+      sumCoordinatesKernelEquiv.toAddEquiv).toIntLinearEquiv
+
+private abbrev CuspCentralHomology.ThreeCircleSuspension :=
+  Suspension ThreeCircles
+
+private def CuspCentralHomology.threeCircleSuspensionHomologyZeroEquiv :
+    SingularMayerVietoris.SingularHomology ThreeCircleSuspension 0 ≃ₗ[ℤ] ℤ :=
+  PeriodTorusHigherHomology.connectedHomologyZeroEquiv ThreeCircleSuspension
+
+private def CuspCentralHomology.threeCircleSuspensionHomologyOneEquiv :
+    SingularMayerVietoris.SingularHomology ThreeCircleSuspension 1 ≃ₗ[ℤ] (Fin 2 → ℤ) :=
+  (contractibleCoverHomologyOneEquivKernel
+        ((CuspCentralHomology.Suspension.northOpen :
+          Set CuspCentralHomology.ThreeCircleSuspension))
+        ((CuspCentralHomology.Suspension.southOpen :
+          Set CuspCentralHomology.ThreeCircleSuspension))
+        Suspension.northOpen_isOpen Suspension.southOpen_isOpen Suspension.open_cover).trans
+    (threeCirclesIntersectionKernelEquiv
+      ((CuspCentralHomology.Suspension.northOpen : Set CuspCentralHomology.ThreeCircleSuspension))
+      ((CuspCentralHomology.Suspension.southOpen : Set CuspCentralHomology.ThreeCircleSuspension))
+      (Suspension.middleBandHomotopyEquiv (X := ThreeCircles)))
+
+private def CuspCentralHomology.threeCircleSuspensionHomologyTwoEquiv :
+    SingularMayerVietoris.SingularHomology ThreeCircleSuspension 2 ≃ₗ[ℤ] (Fin 3 → ℤ) :=
+  (contractibleCoverHomologyHigherEquiv
+        ((CuspCentralHomology.Suspension.northOpen :
+          Set CuspCentralHomology.ThreeCircleSuspension))
+        ((CuspCentralHomology.Suspension.southOpen :
+          Set CuspCentralHomology.ThreeCircleSuspension))
+        Suspension.northOpen_isOpen Suspension.southOpen_isOpen Suspension.open_cover 0).trans
+    ((PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+          (Suspension.middleBandHomotopyEquiv (X := ThreeCircles)) 1).trans
+      threeCirclesHomologyOneEquiv)
+
+private theorem CuspCentralHomology.threeCircleSuspension_homology_subsingleton (n : ℕ) :
+    Subsingleton (SingularMayerVietoris.SingularHomology ThreeCircleSuspension (n + 3)) := by
+  let := threeCircles_homology_subsingleton n
+  exact
+    ((contractibleCoverHomologyHigherEquiv
+            ((CuspCentralHomology.Suspension.northOpen :
+              Set CuspCentralHomology.ThreeCircleSuspension))
+            ((CuspCentralHomology.Suspension.southOpen :
+              Set CuspCentralHomology.ThreeCircleSuspension))
+            Suspension.northOpen_isOpen Suspension.southOpen_isOpen Suspension.open_cover
+            (n + 1)).trans
+        (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+          (Suspension.middleBandHomotopyEquiv (X := ThreeCircles))
+          (n + 2))).injective.subsingleton
+
+private def CuspCentralHomology.threeCircleSuspensionBetti : ℕ → ℕ
+  | 0 => 1
+  | 1 => 2
+  | 2 => 3
+  | _ => 0
+
+private def CuspCentralHomology.threeCircleSuspensionHomologyEquiv (n : ℕ) :
+    SingularMayerVietoris.SingularHomology ThreeCircleSuspension n ≃ₗ[ℤ]
+      (Fin (threeCircleSuspensionBetti n) → ℤ) := by
+  cases n with
+  | zero =>
+    exact threeCircleSuspensionHomologyZeroEquiv.trans (LinearEquiv.funUnique (Fin 1) ℤ ℤ).symm
+  | succ n =>
+    cases n with
+    | zero => exact threeCircleSuspensionHomologyOneEquiv
+    | succ n =>
+      cases n with
+      | zero => exact threeCircleSuspensionHomologyTwoEquiv
+      | succ
+        n =>
+        change
+          SingularMayerVietoris.SingularHomology ThreeCircleSuspension (n + 3) ≃ₗ[ℤ] (Fin 0 → ℤ)
+        letI := threeCircleSuspension_homology_subsingleton n
+        exact LinearEquiv.ofSubsingleton _ _
+
+private theorem
+    CuspCentralHomology.doubleCylinder_mem_centralBoundary (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (p : unitInterval × ThreeCircles) :
+    doubleCylinder C ε hε p ∈ centralBoundary C ε hε := by
+  rcases p with ⟨t, a | (a | a)⟩
+  · exact centralProject_edgeCylinder_mem_centralBoundary C ε hε 0 (t, a)
+  · exact centralProject_edgeCylinder_mem_centralBoundary C ε hε 1 (unitInterval.symm t, a)
+  · exact centralProject_edgeCylinder_mem_centralBoundary C ε hε 2 (t, a)
+
+private theorem CuspCentralHomology.range_doubleCylinder_eq_centralBoundary
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    Set.range (doubleCylinder C ε hε) = centralBoundary C ε hε := by
+  ext q
+  constructor
+  · rintro ⟨p, rfl⟩
+    exact doubleCylinder_mem_centralBoundary C ε hε p
+  · intro hq
+    obtain ⟨k, t, u, hu⟩ := (mem_centralBoundary_iff_edgeArc C ε hε q).mp hq
+    rw [← hu]
+    exact centralCollapseMap_edgeArc_mem_range_doubleCylinder C ε hε k t u
+
+private theorem CuspCentralHomology.range_doubleSuspensionMap_eq_centralBoundary
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    Set.range (doubleSuspensionMap C ε hε) = centralBoundary C ε hε := by
+  rw [range_doubleSuspensionMap, range_doubleCylinder_eq_centralBoundary]
+
+private theorem CuspCentralHomology.doubleSuspensionMap_mem_centralBoundary
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (p : ThreeCircleSuspension) :
+    doubleSuspensionMap C ε hε p ∈ centralBoundary C ε hε := by
+  rw [← range_doubleSuspensionMap_eq_centralBoundary]
+  exact Set.mem_range_self p
+
+private def
+    CuspCentralHomology.doubleSuspensionBoundaryMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (p : ThreeCircleSuspension) : centralBoundary C ε hε :=
+  ⟨doubleSuspensionMap C ε hε p, doubleSuspensionMap_mem_centralBoundary C ε hε p⟩
+
+private theorem CuspCentralHomology.doubleSuspensionBoundaryMap_continuous
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    Continuous (doubleSuspensionBoundaryMap C ε hε) :=
+  (doubleSuspensionMap_continuous C ε hε).subtype_mk _
+
+private theorem CuspCentralHomology.doubleSuspensionBoundaryMap_bijective
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    Function.Bijective (doubleSuspensionBoundaryMap C ε hε) := by
+  constructor
+  · intro p q h
+    exact doubleSuspensionMap_injective C ε hε (congrArg Subtype.val h)
+  · rintro ⟨q, hq⟩
+    rw [← range_doubleSuspensionMap_eq_centralBoundary] at hq
+    obtain ⟨p, hp⟩ := hq
+    exact ⟨p, Subtype.ext hp⟩
+
+private def
+    CuspCentralHomology.doubleSuspensionBoundaryEquiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : ThreeCircleSuspension ≃ centralBoundary C ε hε :=
+  Equiv.ofBijective (doubleSuspensionBoundaryMap C ε hε)
+    (doubleSuspensionBoundaryMap_bijective C ε hε)
+
+private def
+    CuspCentralHomology.doubleSuspensionBoundaryHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : ThreeCircleSuspension ≃ₜ centralBoundary C ε hε := by
+  letI := CuspQuotient.quotient_t2Space C ε hε hε1 hC hR
+  exact
+    (doubleSuspensionBoundaryEquiv C ε hε).toHomeomorphOfContinuousClosed
+      (doubleSuspensionBoundaryMap_continuous C ε hε)
+      (doubleSuspensionBoundaryMap_continuous C ε hε).isClosedMap
+
+private def
+    CuspCentralHomology.centralBoundarySuspensionHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : centralBoundary C ε hε ≃ₜ ThreeCircleSuspension :=
+  (doubleSuspensionBoundaryHomeomorph C ε hε hε1 hC hR).symm
+
+@[simp]
+private theorem CuspCentralHomology.centralBoundarySuspensionHomeomorph_symm_coe
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (p : ThreeCircleSuspension) :
+    ((centralBoundarySuspensionHomeomorph C ε hε hε1 hC hR).symm p :
+        CuspRetraction.QuotientCentralFibre C ε) =
+      doubleSuspensionMap C ε hε p :=
+  rfl
+
+
+private def
+    CuspCentralHomology.centralBoundaryHomologyOneEquiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    SingularMayerVietoris.SingularHomology (centralBoundary C ε hε) 1 ≃ₗ[ℤ] (Fin 2 → ℤ) :=
+  (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+        (centralBoundarySuspensionHomeomorph C ε hε hε1 hC hR) 1).trans
+    threeCircleSuspensionHomologyOneEquiv
+
+private abbrev CuspCentralHomology.InteriorPhaseCell :=
+  ToricSpace.CompactFibreTorus × (interior CuspHoneycombTiling.baseCell)
+
+private def CuspCentralHomology.interiorCellInclusion (p : InteriorPhaseCell) : FundamentalCell :=
+  (p.1, ⟨(p.2 : (CuspHoneycombTiling.Plane)), interior_subset p.2.2⟩)
+
+@[simp]
+private theorem CuspCentralHomology.interiorCellInclusion_snd_coe (p : InteriorPhaseCell) :
+    ((interiorCellInclusion p).2 : (CuspHoneycombTiling.Plane)) =
+      (p.2 : (CuspHoneycombTiling.Plane)) :=
+  rfl
+
+private theorem
+    CuspCentralHomology.interiorCellInclusion_continuous : Continuous interiorCellInclusion :=
+  continuous_fst.prodMk ((continuous_subtype_val.comp continuous_snd).subtype_mk _)
+
+private theorem CuspCentralHomology.interiorCellInclusion_injective :
+    Function.Injective interiorCellInclusion := by
+  intro p q hpq
+  apply Prod.ext
+  · exact congrArg (fun r : FundamentalCell => r.1) hpq
+  · apply Subtype.ext
+    exact congrArg (fun r : FundamentalCell => (r.2 : (CuspHoneycombTiling.Plane))) hpq
+
+private def
+    CuspCentralHomology.interiorCellMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    InteriorPhaseCell → CuspRetraction.QuotientCentralFibre C ε :=
+  fundamentalCellMap C ε hε ∘ interiorCellInclusion
+
+private theorem CuspCentralHomology.interiorCellMap_eq_fundamentalCellMap
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (p : InteriorPhaseCell) :
+    interiorCellMap C ε hε p = fundamentalCellMap C ε hε (interiorCellInclusion p) :=
+  rfl
+
+@[simp]
+private theorem CuspCentralHomology.interiorCellMap_apply (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (p : InteriorPhaseCell) :
+    interiorCellMap C ε hε p =
+      CuspHoneycomb.honeycombCollapseMap C ε hε (p.1, (p.2 : (CuspHoneycombTiling.Plane))) :=
+  rfl
+
+private theorem
+    CuspCentralHomology.interiorCellMap_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : Continuous (interiorCellMap C ε hε) :=
+  (fundamentalCellMap_continuous C ε hε).comp interiorCellInclusion_continuous
+
+private theorem
+    CuspCentralHomology.interiorCellMap_injective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : Function.Injective (interiorCellMap C ε hε) := by
+  intro p q hpq
+  apply interiorCellInclusion_injective
+  exact
+    fundamentalCellMap_eq_of_interior C ε hε (interiorCellInclusion p) (interiorCellInclusion q)
+      p.2.2 hpq
+
+private def
+    CuspCentralHomology.interiorImage (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    Set (CuspRetraction.QuotientCentralFibre C ε) :=
+  Set.range (interiorCellMap C ε hε)
+
+private theorem CuspCentralHomology.fundamentalCellMap_mem_interiorImage_iff
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (p : FundamentalCell) :
+    fundamentalCellMap C ε hε p ∈ interiorImage C ε hε ↔
+      (p.2 : (CuspHoneycombTiling.Plane)) ∈ interior CuspHoneycombTiling.baseCell := by
+  constructor
+  · rintro ⟨q, hq⟩
+    have he := fundamentalCellMap_eq_of_interior C ε hε (interiorCellInclusion q) p q.2.2 hq
+    rw [← he]
+    exact q.2.2
+  · intro hp
+    exact ⟨(p.1, ⟨(p.2 : (CuspHoneycombTiling.Plane)), hp⟩), rfl⟩
+
+private def CuspCentralHomology.interiorCellMapToImage (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (p : InteriorPhaseCell) : interiorImage C ε hε :=
+  ⟨interiorCellMap C ε hε p, Set.mem_range_self p⟩
+
+private theorem
+    CuspCentralHomology.interiorCellMapToImage_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) : Continuous (interiorCellMapToImage C ε hε) :=
+  (interiorCellMap_continuous C ε hε).subtype_mk _
+
+private theorem
+    CuspCentralHomology.interiorCellMapToImage_surjective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) : Function.Surjective (interiorCellMapToImage C ε hε) := by
+  rintro ⟨y, p, hp⟩
+  exact ⟨p, Subtype.ext hp⟩
+
+private theorem
+    CuspCentralHomology.interiorCellMapToImage_injective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) : Function.Injective (interiorCellMapToImage C ε hε) := by
+  intro p q hpq
+  exact interiorCellMap_injective C ε hε (congrArg Subtype.val hpq)
+
+private def
+    CuspCentralHomology.interiorPreimageHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : InteriorPhaseCell ≃ₜ (fundamentalCellMap C ε hε ⁻¹' interiorImage C ε hε)
+    where
+  toFun
+    p := ⟨interiorCellInclusion p, (fundamentalCellMap_mem_interiorImage_iff C ε hε _).mpr p.2.2⟩
+  invFun
+    p :=
+    (p.1.1,
+      ⟨(p.1.2 : (CuspHoneycombTiling.Plane)),
+        (fundamentalCellMap_mem_interiorImage_iff C ε hε p.1).mp p.2⟩)
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := interiorCellInclusion_continuous.subtype_mk _
+  continuous_invFun :=
+    (continuous_fst.comp continuous_subtype_val).prodMk
+      ((continuous_subtype_val.comp (continuous_snd.comp continuous_subtype_val)).subtype_mk _)
+
+private theorem
+    CuspCentralHomology.interiorCellMapToImage_isProperMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : IsProperMap (interiorCellMapToImage C ε hε) := by
+  have hf :=
+    (fundamentalCellMap_isProperMap C ε hε hε1 hC hR).restrictPreimage (interiorImage C ε hε)
+  have hg := (interiorPreimageHomeomorph C ε hε).isProperMap
+  have hc := hf.comp hg
+  have he :
+    (interiorImage C ε hε).restrictPreimage (fundamentalCellMap C ε hε) ∘
+        interiorPreimageHomeomorph C ε hε =
+      interiorCellMapToImage C ε hε := by
+    funext p
+    apply Subtype.ext
+    rfl
+  rw [he] at hc
+  exact hc
+
+private theorem
+    CuspCentralHomology.interiorCellMapToImage_isClosedMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : IsClosedMap (interiorCellMapToImage C ε hε) :=
+  (interiorCellMapToImage_isProperMap C ε hε hε1 hC hR).isClosedMap
+
+private def CuspCentralHomology.interiorCellHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : InteriorPhaseCell ≃ₜ interiorImage C ε hε :=
+  Equiv.toHomeomorphOfContinuousClosed
+    (Equiv.ofBijective (interiorCellMapToImage C ε hε)
+      ⟨interiorCellMapToImage_injective C ε hε, interiorCellMapToImage_surjective C ε hε⟩)
+    (interiorCellMapToImage_continuous C ε hε)
+    (interiorCellMapToImage_isClosedMap C ε hε hε1 hC hR)
+
+@[simp]
+private theorem
+    CuspCentralHomology.interiorCellHomeomorph_coe (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (p : InteriorPhaseCell) :
+    (interiorCellHomeomorph C ε hε hε1 hC hR p : CuspRetraction.QuotientCentralFibre C ε) =
+      interiorCellMap C ε hε p :=
+  rfl
+
+private theorem CuspCentralHomology.innerRegion_eq_interiorImage (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) : innerRegion C ε hε = interiorImage C ε hε := by
+  ext q
+  obtain ⟨p, rfl⟩ := fundamentalCellMap_surjective C ε hε q
+  exact
+    (fundamentalCellMap_mem_innerRegion_iff C ε hε p).trans
+      (fundamentalCellMap_mem_interiorImage_iff C ε hε p).symm
+
+private def CuspCentralHomology.innerRegionHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : InteriorPhaseCell ≃ₜ innerRegion C ε hε :=
+  (interiorCellHomeomorph C ε hε hε1 hC hR).trans
+    (Homeomorph.setCongr (innerRegion_eq_interiorImage C ε hε).symm)
+
+@[simp]
+private theorem
+    CuspCentralHomology.innerRegionHomeomorph_coe (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (p : InteriorPhaseCell) :
+    (innerRegionHomeomorph C ε hε hε1 hC hR p : CuspRetraction.QuotientCentralFibre C ε) =
+      interiorCellMap C ε hε p :=
+  interiorCellHomeomorph_coe C ε hε hε1 hC hR p
+
+private theorem
+    CuspCentralHomology.innerRegionHomeomorph_honeycomb (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (p : InteriorPhaseCell) :
+    (innerRegionHomeomorph C ε hε hε1 hC hR p : CuspRetraction.QuotientCentralFibre C ε) =
+      CuspHoneycomb.honeycombCollapseMap C ε hε (p.1, (p.2 : (CuspHoneycombTiling.Plane))) := by
+  rw [innerRegionHomeomorph_coe, interiorCellMap_apply]
+
+private theorem CuspCentralHomology.innerRegionHomeomorph_radius (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (p : InteriorPhaseCell) :
+    centralRadius C ε hε
+        (innerRegionHomeomorph C ε hε hε1 hC hR p : CuspRetraction.QuotientCentralFibre C ε) =
+      Radial.cellGauge (p.2 : (CuspHoneycombTiling.Plane)) := by
+  rw [innerRegionHomeomorph_coe, interiorCellMap_eq_fundamentalCellMap,
+    centralRadius_fundamentalCellMap, interiorCellInclusion_snd_coe]
+
+private abbrev CuspCentralHomology.Radial.InteriorCell :=
+  interior CuspHoneycombTiling.baseCell
+
+private def CuspCentralHomology.Radial.interiorCellZero : InteriorCell :=
+  ⟨0, (mem_interior_baseCell_iff 0).mpr (by rw [cellGauge_zero]; norm_num)⟩
+
+private def CuspCentralHomology.Radial.interiorCellContract (s : unitInterval) (x : InteriorCell) :
+    InteriorCell :=
+  ⟨(1 - (s : ℝ)) • (x : CuspHoneycombTiling.Plane),
+    by
+    apply (mem_interior_baseCell_iff _).mpr
+    rw [cellGauge_smul_of_nonneg _ (sub_nonneg.mpr s.2.2)]
+    calc
+      (1 - (s : ℝ)) * cellGauge x ≤ 1 * cellGauge x :=
+        mul_le_mul_of_nonneg_right (sub_le_self 1 s.2.1) (cellGauge_nonneg x)
+      _ = cellGauge x := (one_mul _)
+      _ < 1 := (mem_interior_baseCell_iff x).mp x.2⟩
+
+private theorem CuspCentralHomology.Radial.interiorCellContract_continuous :
+    Continuous (fun p : unitInterval × InteriorCell => interiorCellContract p.1 p.2) :=
+  ((continuous_const.sub (continuous_subtype_val.comp continuous_fst)).smul
+        (continuous_subtype_val.comp continuous_snd)).subtype_mk
+    _
+
+@[simp]
+private theorem CuspCentralHomology.Radial.interiorCellContract_zero (x : InteriorCell) :
+    interiorCellContract 0 x = x := by
+  apply Subtype.ext
+  simp [interiorCellContract]
+
+@[simp]
+private theorem CuspCentralHomology.Radial.interiorCellContract_one (x : InteriorCell) :
+    interiorCellContract 1 x = interiorCellZero := by
+  apply Subtype.ext
+  simp [interiorCellContract, interiorCellZero]
+
+@[simp]
+private theorem CuspCentralHomology.Radial.interiorCellContract_fixed_zero (s : unitInterval) :
+    interiorCellContract s interiorCellZero = interiorCellZero := by
+  apply Subtype.ext
+  simp [interiorCellContract, interiorCellZero]
+
+private def CuspCentralHomology.Radial.interiorCellContraction :
+    (ContinuousMap.id InteriorCell).HomotopyRel
+      (ContinuousMap.const InteriorCell interiorCellZero) { interiorCellZero }
+    where
+  toFun p := interiorCellContract p.1 p.2
+  continuous_toFun := interiorCellContract_continuous
+  map_zero_left := interiorCellContract_zero
+  map_one_left := interiorCellContract_one
+  prop' s x
+    hx := by
+    rcases Set.mem_singleton_iff.mp hx with rfl
+    exact interiorCellContract_fixed_zero s
+
+private def CuspCentralHomology.Radial.interiorCellPointHomotopyEquiv : InteriorCell ≃ₕ Unit
+    where
+  toFun := ContinuousMap.const _ ()
+  invFun := ContinuousMap.const _ interiorCellZero
+  left_inv := ⟨interiorCellContraction.toHomotopy.symm⟩
+  right_inv := by
+    convert ContinuousMap.Homotopic.refl (ContinuousMap.id Unit) using 1
+    ext u
+
+private def
+    CuspCentralHomology.Radial.interiorCellProductHomotopyEquiv (X : Type*) [TopologicalSpace X] :
+    (X × InteriorCell) ≃ₕ X :=
+  ((ContinuousMap.HomotopyEquiv.refl X).prodCongr interiorCellPointHomotopyEquiv).trans
+    (Homeomorph.prodUnique X Unit).toHomotopyEquiv
+
+private abbrev CuspCentralHomology.Radial.CellFrontier :=
+  frontier CuspHoneycombTiling.baseCell
+
+private abbrev CuspCentralHomology.Radial.Annulus (a : ℝ) :=
+  { x : (CuspHoneycombTiling.Plane) // a < cellGauge x ∧ cellGauge x < 1 }
+
+private noncomputable def CuspCentralHomology.Radial.normalize (x : (CuspHoneycombTiling.Plane)) :
+    (CuspHoneycombTiling.Plane) :=
+  (cellGauge x)⁻¹ • x
+
+private theorem CuspCentralHomology.Radial.normalize_gauge (x : (CuspHoneycombTiling.Plane))
+    (hx : x ≠ 0) : cellGauge (CuspCentralHomology.Radial.normalize x) = 1 := by
+  rw [CuspCentralHomology.Radial.normalize,
+    cellGauge_smul_of_nonneg _ (inv_nonneg.mpr (cellGauge_nonneg x))]
+  exact inv_mul_cancel₀ ((cellGauge_pos_iff x).mpr hx).ne'
+
+private theorem CuspCentralHomology.Radial.normalize_continuousOn :
+    ContinuousOn CuspCentralHomology.Radial.normalize {x : (CuspHoneycombTiling.Plane) | x ≠ 0} :=
+  (cellGauge_continuous.continuousOn.inv₀ (fun x hx => ((cellGauge_pos_iff x).mpr hx).ne')).smul
+    continuous_id.continuousOn
+
+private noncomputable def CuspCentralHomology.Radial.direction
+    (x : { x : (CuspHoneycombTiling.Plane) // x ≠ 0 }) : CellFrontier :=
+  ⟨CuspCentralHomology.Radial.normalize x,
+    (mem_frontier_baseCell_iff _).mpr (normalize_gauge x x.2)⟩
+
+private theorem CuspCentralHomology.Radial.direction_continuous : Continuous direction :=
+  normalize_continuousOn.domRestrict.subtype_mk _
+
+private theorem CuspCentralHomology.Radial.cellGauge_smul_frontier (c : ℝ) (hc : 0 ≤ c)
+    (u : CellFrontier) : cellGauge (c • (u : (CuspHoneycombTiling.Plane))) = c := by
+  rw [cellGauge_smul_of_nonneg c hc, (mem_frontier_baseCell_iff _).mp u.2, mul_one]
+
+private noncomputable def CuspCentralHomology.Radial.radialRangeHomeomorph (R : Set ℝ)
+    (hR : ∀ r ∈ R, 0 < r) :
+    { x : (CuspHoneycombTiling.Plane) // cellGauge x ∈ R } ≃ₜ CellFrontier × R
+    where
+  toFun x := (direction ⟨x, (cellGauge_pos_iff x).mp (hR _ x.2)⟩, ⟨cellGauge x, x.2⟩)
+  invFun
+    p :=
+    ⟨(p.2 : ℝ) • (p.1 : (CuspHoneycombTiling.Plane)),
+      by
+      rw [cellGauge_smul_frontier _ (hR _ p.2.2).le]
+      exact p.2.2⟩
+  left_inv
+    x := by
+    apply Subtype.ext
+    change
+      cellGauge x • ((cellGauge x)⁻¹ • (x : (CuspHoneycombTiling.Plane))) =
+        (x : (CuspHoneycombTiling.Plane))
+    rw [smul_smul, mul_inv_cancel₀ (hR _ x.2).ne', one_smul]
+  right_inv
+    p := by
+    apply Prod.ext
+    · apply Subtype.ext
+      change
+        CuspCentralHomology.Radial.normalize ((p.2 : ℝ) • (p.1 : (CuspHoneycombTiling.Plane))) =
+          (p.1 : (CuspHoneycombTiling.Plane))
+      rw [CuspCentralHomology.Radial.normalize, cellGauge_smul_frontier _ (hR _ p.2.2).le,
+        smul_smul, inv_mul_cancel₀ (hR _ p.2.2).ne', one_smul]
+    · apply Subtype.ext
+      exact cellGauge_smul_frontier _ (hR _ p.2.2).le p.1
+  continuous_toFun :=
+    (direction_continuous.comp (continuous_subtype_val.subtype_mk _)).prodMk
+      ((cellGauge_continuous.comp continuous_subtype_val).subtype_mk _)
+  continuous_invFun :=
+    ((continuous_subtype_val.comp continuous_snd).smul
+          (continuous_subtype_val.comp continuous_fst)).subtype_mk
+      _
+
+private noncomputable def CuspCentralHomology.Radial.annulusHomeomorph (a : ℝ) (ha : 0 ≤ a) :
+    Annulus a ≃ₜ CellFrontier × Set.Ioo a 1 :=
+  radialRangeHomeomorph (Set.Ioo a 1) (fun _ hr => ha.trans_lt hr.1)
+
+private abbrev CuspCentralHomology.Radial.RadialDomain (R : Set ℝ) :=
+  { x : (CuspHoneycombTiling.Plane) // cellGauge x ∈ R }
+
+private def CuspCentralHomology.Radial.radiusProjection (R : Set ℝ) (hR : ∀ r ∈ R, 0 < r) :
+    C(RadialDomain R, CellFrontier) :=
+  ⟨fun x => (radialRangeHomeomorph R hR x).1,
+    continuous_fst.comp (radialRangeHomeomorph R hR).continuous⟩
+
+private def CuspCentralHomology.Radial.radiusSection (R : Set ℝ) (hR : ∀ r ∈ R, 0 < r) (c : ℝ)
+    (hc : c ∈ R) : C(CellFrontier, RadialDomain R) :=
+  ⟨fun u => (radialRangeHomeomorph R hR).symm (u, ⟨c, hc⟩),
+    (radialRangeHomeomorph R hR).symm.continuous.comp (continuous_id.prodMk continuous_const)⟩
+
+private theorem CuspCentralHomology.Radial.radiusProjection_coe (R : Set ℝ) (hR : ∀ r ∈ R, 0 < r)
+    (x : RadialDomain R) :
+    (radiusProjection R hR x : (CuspHoneycombTiling.Plane)) =
+      CuspCentralHomology.Radial.normalize x :=
+  rfl
+
+private theorem
+    CuspCentralHomology.Radial.radiusSection_coe (R : Set ℝ) (hR : ∀ r ∈ R, 0 < r) (c : ℝ)
+    (hc : c ∈ R) (u : CellFrontier) :
+    (radiusSection R hR c hc u : (CuspHoneycombTiling.Plane)) =
+      c • (u : (CuspHoneycombTiling.Plane)) :=
+  rfl
+
+private theorem
+    CuspCentralHomology.Radial.radiusProjection_comp_section (R : Set ℝ) (hR : ∀ r ∈ R, 0 < r)
+    (c : ℝ) (hc : c ∈ R) :
+    (radiusProjection R hR).comp (radiusSection R hR c hc) = ContinuousMap.id CellFrontier := by
+  apply ContinuousMap.ext
+  intro u
+  change ((radialRangeHomeomorph R hR) ((radialRangeHomeomorph R hR).symm (u, ⟨c, hc⟩))).1 = u
+  rw [Homeomorph.apply_symm_apply]
+
+private def CuspCentralHomology.Radial.radiusBlend (c : ℝ) (s : unitInterval) (r : ℝ) : ℝ :=
+  (1 - (s : ℝ)) * r + (s : ℝ) * c
+
+private theorem CuspCentralHomology.Radial.radiusBlend_mem {R : Set ℝ} (hconv : Convex ℝ R) (c : ℝ)
+    (hc : c ∈ R) (s : unitInterval) (r : ℝ) (hr : r ∈ R) : radiusBlend c s r ∈ R :=
+  hconv hr hc (sub_nonneg.mpr s.2.2) s.2.1 (sub_add_cancel 1 (s : ℝ))
+
+private def CuspCentralHomology.Radial.radiusHomotopyMap (R : Set ℝ) (hR : ∀ r ∈ R, 0 < r)
+    (hconv : Convex ℝ R) (c : ℝ) (hc : c ∈ R) : C(unitInterval × RadialDomain R, RadialDomain R)
+    where
+  toFun
+    p :=
+    (radialRangeHomeomorph R hR).symm
+      ((radialRangeHomeomorph R hR p.2).1,
+        ⟨radiusBlend c p.1 (cellGauge p.2), radiusBlend_mem hconv c hc p.1 _ p.2.2⟩)
+  continuous_toFun :=
+    (radialRangeHomeomorph R hR).symm.continuous.comp
+      ((continuous_fst.comp ((radialRangeHomeomorph R hR).continuous.comp continuous_snd)).prodMk
+        ((((continuous_const.sub (continuous_subtype_val.comp continuous_fst)).mul
+                  (cellGauge_continuous.comp (continuous_subtype_val.comp continuous_snd))).add
+              ((continuous_subtype_val.comp continuous_fst).mul continuous_const)).subtype_mk
+          _))
+
+private theorem CuspCentralHomology.Radial.radiusHomotopyMap_coe (R : Set ℝ) (hR : ∀ r ∈ R, 0 < r)
+    (hconv : Convex ℝ R) (c : ℝ) (hc : c ∈ R) (s : unitInterval) (x : RadialDomain R) :
+    (radiusHomotopyMap R hR hconv c hc (s, x) : (CuspHoneycombTiling.Plane)) =
+      radiusBlend c s (cellGauge x) • CuspCentralHomology.Radial.normalize x :=
+  rfl
+
+private theorem CuspCentralHomology.Radial.radiusHomotopyMap_gauge (R : Set ℝ) (hR : ∀ r ∈ R, 0 < r)
+    (hconv : Convex ℝ R) (c : ℝ) (hc : c ∈ R) (s : unitInterval) (x : RadialDomain R) :
+    cellGauge (radiusHomotopyMap R hR hconv c hc (s, x)) = radiusBlend c s (cellGauge x) :=
+  cellGauge_smul_frontier _ (hR _ (radiusBlend_mem hconv c hc s _ x.2)).le
+    (radialRangeHomeomorph R hR x).1
+
+private theorem CuspCentralHomology.Radial.radiusHomotopyMap_zero (R : Set ℝ) (hR : ∀ r ∈ R, 0 < r)
+    (hconv : Convex ℝ R) (c : ℝ) (hc : c ∈ R) (x : RadialDomain R) :
+    radiusHomotopyMap R hR hconv c hc (0, x) = x := by
+  apply Subtype.ext
+  rw [radiusHomotopyMap_coe]
+  change
+    ((1 - (0 : ℝ)) * cellGauge x + 0 * c) • CuspCentralHomology.Radial.normalize x =
+      (x : (CuspHoneycombTiling.Plane))
+  rw [sub_zero, one_mul, MulZeroClass.zero_mul, add_zero, CuspCentralHomology.Radial.normalize,
+    smul_smul, mul_inv_cancel₀ (hR _ x.2).ne', one_smul]
+
+private theorem CuspCentralHomology.Radial.radiusHomotopyMap_one (R : Set ℝ) (hR : ∀ r ∈ R, 0 < r)
+    (hconv : Convex ℝ R) (c : ℝ) (hc : c ∈ R) (x : RadialDomain R) :
+    radiusHomotopyMap R hR hconv c hc (1, x) =
+      radiusSection R hR c hc (radiusProjection R hR x) := by
+  apply Subtype.ext
+  rw [radiusHomotopyMap_coe, radiusSection_coe, radiusProjection_coe]
+  change
+    ((1 - (1 : ℝ)) * cellGauge x + 1 * c) • CuspCentralHomology.Radial.normalize x =
+      c • CuspCentralHomology.Radial.normalize x
+  rw [sub_self, MulZeroClass.zero_mul, one_mul, zero_add]
+
+private theorem CuspCentralHomology.Radial.radiusHomotopyMap_fixed (R : Set ℝ) (hR : ∀ r ∈ R, 0 < r)
+    (hconv : Convex ℝ R) (c : ℝ) (hc : c ∈ R) (s : unitInterval) (x : RadialDomain R)
+    (hx : cellGauge x = c) : radiusHomotopyMap R hR hconv c hc (s, x) = x := by
+  have hblend : radiusBlend c s (cellGauge x) = cellGauge x := by
+    rw [radiusBlend, hx]
+    ring
+  apply Subtype.ext
+  rw [radiusHomotopyMap_coe, hblend, CuspCentralHomology.Radial.normalize, smul_smul,
+    mul_inv_cancel₀ (hR _ x.2).ne', one_smul]
+
+private def CuspCentralHomology.Radial.radiusHomotopy (R : Set ℝ) (hR : ∀ r ∈ R, 0 < r)
+    (hconv : Convex ℝ R) (c : ℝ) (hc : c ∈ R) :
+    (ContinuousMap.id (RadialDomain R)).Homotopy
+      ((radiusSection R hR c hc).comp (radiusProjection R hR))
+    where
+  toContinuousMap := radiusHomotopyMap R hR hconv c hc
+  map_zero_left := radiusHomotopyMap_zero R hR hconv c hc
+  map_one_left := radiusHomotopyMap_one R hR hconv c hc
+
+private def CuspCentralHomology.Radial.radialHomotopyEquiv (R : Set ℝ) (hR : ∀ r ∈ R, 0 < r)
+    (hconv : Convex ℝ R) (c : ℝ) (hc : c ∈ R) : RadialDomain R ≃ₕ CellFrontier
+    where
+  toFun := radiusProjection R hR
+  invFun := radiusSection R hR c hc
+  left_inv := ⟨(radiusHomotopy R hR hconv c hc).symm⟩
+  right_inv := by rw [radiusProjection_comp_section]
+
+private def
+    CuspCentralHomology.Radial.annulusFrontierHomotopyEquiv (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    Annulus a ≃ₕ CellFrontier :=
+  radialHomotopyEquiv (Set.Ioo a 1) (fun _ hr => ha.trans_lt hr.1) (convex_Ioo a 1) ((a + 1) / 2)
+    ⟨by linarith, by linarith⟩
+
+private abbrev CuspCentralHomology.Radial.OpenCollar (a : ℝ) :=
+  { x : (CuspHoneycombTiling.Plane) // a < cellGauge x ∧ cellGauge x ≤ 1 }
+
+private def CuspCentralHomology.Radial.frontierIntoOpenCollar (a : ℝ) (ha1 : a < 1) :
+    C(CellFrontier, OpenCollar a) :=
+  ⟨fun u =>
+    ⟨u, by
+      rw [(mem_frontier_baseCell_iff _).mp u.2]
+      exact ⟨ha1, le_rfl⟩⟩,
+    continuous_subtype_val.subtype_mk _⟩
+
+private def CuspCentralHomology.Radial.openCollarRetraction (a : ℝ) (ha : 0 ≤ a) :
+    C(OpenCollar a, CellFrontier) :=
+  radiusProjection (Set.Ioc a 1) (fun _ hr => ha.trans_lt hr.1)
+
+private def
+    CuspCentralHomology.Radial.outwardOpenCollarHomotopy (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    (ContinuousMap.id (OpenCollar a)).HomotopyRel
+      ((frontierIntoOpenCollar a ha1).comp (openCollarRetraction a ha))
+      {x : OpenCollar a | cellGauge x = 1}
+    where
+  toContinuousMap :=
+    radiusHomotopyMap (Set.Ioc a 1) (fun _ hr => ha.trans_lt hr.1) (convex_Ioc a 1) 1
+      ⟨ha1, le_rfl⟩
+  map_zero_left :=
+    radiusHomotopyMap_zero (Set.Ioc a 1) (fun _ hr => ha.trans_lt hr.1) (convex_Ioc a 1) 1
+      ⟨ha1, le_rfl⟩
+  map_one_left
+    x := by
+    apply Subtype.ext
+    change
+      ((1 - (1 : ℝ)) * cellGauge x + 1 * 1) • CuspCentralHomology.Radial.normalize x =
+        CuspCentralHomology.Radial.normalize x
+    rw [sub_self, MulZeroClass.zero_mul, one_mul, zero_add, one_smul]
+  prop' s x
+    hx :=
+    radiusHomotopyMap_fixed (Set.Ioc a 1) (fun _ hr => ha.trans_lt hr.1) (convex_Ioc a 1) 1
+      ⟨ha1, le_rfl⟩ s x hx
+
+private theorem CuspCentralHomology.Radial.outwardOpenCollarHomotopy_coe (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) (s : unitInterval) (x : OpenCollar a) :
+    (outwardOpenCollarHomotopy a ha ha1 (s, x) : (CuspHoneycombTiling.Plane)) =
+      ((1 - (s : ℝ)) + (s : ℝ) / cellGauge x) • (x : (CuspHoneycombTiling.Plane)) := by
+  change radiusBlend 1 s (cellGauge x) • CuspCentralHomology.Radial.normalize x = _
+  rw [CuspCentralHomology.Radial.normalize, smul_smul]
+  congr 1
+  rw [radiusBlend, mul_one, add_mul, mul_assoc, mul_inv_cancel₀ (ha.trans_lt x.2.1).ne', mul_one,
+    div_eq_mul_inv]
+
+private theorem CuspCentralHomology.Radial.outwardOpenCollarHomotopy_gauge (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) (s : unitInterval) (x : OpenCollar a) :
+    cellGauge (outwardOpenCollarHomotopy a ha ha1 (s, x)) =
+      (1 - (s : ℝ)) * cellGauge x + (s : ℝ) := by
+  change
+    cellGauge
+        (radiusHomotopyMap (Set.Ioc a 1) (fun _ hr => ha.trans_lt hr.1) (convex_Ioc a 1) 1
+          ⟨ha1, le_rfl⟩ (s, x)) =
+      _
+  simpa only [radiusBlend, mul_one] using
+    radiusHomotopyMap_gauge (Set.Ioc a 1) (fun _ hr => ha.trans_lt hr.1) (convex_Ioc a 1) 1
+      ⟨ha1, le_rfl⟩ s x
+
+private theorem CuspCentralHomology.Radial.outwardOpenCollarHomotopy_fixed (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) (s : unitInterval) (x : OpenCollar a)
+    (hx : (x : (CuspHoneycombTiling.Plane)) ∈ frontier CuspHoneycombTiling.baseCell) :
+    outwardOpenCollarHomotopy a ha ha1 (s, x) = x :=
+  (outwardOpenCollarHomotopy a ha ha1).eq_fst s ((mem_frontier_baseCell_iff _).mp hx)
+
+private def CuspCentralHomology.Radial.circlePlaneComplexEquiv : CuspHoneycombTiling.Plane ≃L[ℝ] ℂ
+    where
+  toFun x := ⟨x 0, x 1⟩
+  invFun z := ![z.re, z.im]
+  left_inv
+    x := by
+    funext i
+    fin_cases i <;> rfl
+  right_inv
+    z := by
+    cases z
+    rfl
+  map_add' _ _ := rfl
+  map_smul' c x := by apply Complex.ext <;> simp
+  continuous_toFun := by
+    simp only [Complex.mk_eq_add_mul_I]
+    fun_prop
+  continuous_invFun := by
+    apply continuous_pi
+    intro i
+    fin_cases i <;> fun_prop
+
+private theorem CuspCentralHomology.Radial.circleFrontier_ne_zero
+    (x : frontier CuspHoneycombTiling.baseCell) : (x : CuspHoneycombTiling.Plane) ≠ 0 := by
+  intro hx
+  have hg := (mem_frontier_baseCell_iff (x : CuspHoneycombTiling.Plane)).mp x.property
+  exact zero_ne_one (by simpa only [hx, cellGauge_zero] using hg)
+
+private theorem CuspCentralHomology.Radial.circleFrontierComplex_ne_zero
+    (x : frontier CuspHoneycombTiling.baseCell) :
+    circlePlaneComplexEquiv (x : CuspHoneycombTiling.Plane) ≠ 0 := by
+  intro hx
+  exact circleFrontier_ne_zero x (circlePlaneComplexEquiv.map_eq_zero_iff.mp hx)
+
+private def
+    CuspCentralHomology.Radial.frontierCircleForward (x : frontier CuspHoneycombTiling.baseCell) :
+    Circle :=
+  ⟨NormedSpace.normalize (circlePlaneComplexEquiv (x : CuspHoneycombTiling.Plane)),
+    mem_sphere_zero_iff_norm.mpr (NormedSpace.norm_normalize (circleFrontierComplex_ne_zero x))⟩
+
+@[simp]
+private theorem CuspCentralHomology.Radial.frontierCircleForward_coe
+    (x : frontier CuspHoneycombTiling.baseCell) :
+    (frontierCircleForward x : ℂ) =
+      ‖circlePlaneComplexEquiv (x : CuspHoneycombTiling.Plane)‖⁻¹ •
+        circlePlaneComplexEquiv (x : CuspHoneycombTiling.Plane) :=
+  rfl
+
+private theorem CuspCentralHomology.Radial.frontierCircleForward_continuous :
+    Continuous frontierCircleForward := by
+  apply Continuous.subtype_mk
+  have h :
+    Continuous
+      (fun x : frontier CuspHoneycombTiling.baseCell =>
+        circlePlaneComplexEquiv (x : CuspHoneycombTiling.Plane)) :=
+    circlePlaneComplexEquiv.continuous.comp continuous_subtype_val
+  exact (h.norm.inv₀ fun x => norm_ne_zero_iff.mpr (circleFrontierComplex_ne_zero x)).smul h
+
+private theorem CuspCentralHomology.Radial.circleComplexPlane_ne_zero (z : Circle) :
+    circlePlaneComplexEquiv.symm (z : ℂ) ≠ 0 := by
+  intro hz
+  exact z.coe_ne_zero (circlePlaneComplexEquiv.symm.map_eq_zero_iff.mp hz)
+
+private theorem CuspCentralHomology.Radial.circleComplexPlaneGauge_pos (z : Circle) :
+    0 < cellGauge (circlePlaneComplexEquiv.symm (z : ℂ)) :=
+  (cellGauge_pos_iff _).mpr (circleComplexPlane_ne_zero z)
+
+private def CuspCentralHomology.Radial.frontierCircleInverse (z : Circle) :
+    frontier CuspHoneycombTiling.baseCell :=
+  ⟨(cellGauge (circlePlaneComplexEquiv.symm (z : ℂ)))⁻¹ • circlePlaneComplexEquiv.symm (z : ℂ),
+    (mem_frontier_baseCell_iff _).mpr
+      (by
+        rw [cellGauge_smul_of_nonneg _ (inv_nonneg.mpr (cellGauge_nonneg _)),
+          inv_mul_cancel₀ (ne_of_gt (circleComplexPlaneGauge_pos z))])⟩
+
+@[simp]
+private theorem CuspCentralHomology.Radial.frontierCircleInverse_coe (z : Circle) :
+    (frontierCircleInverse z : CuspHoneycombTiling.Plane) =
+      (cellGauge (circlePlaneComplexEquiv.symm (z : ℂ)))⁻¹ •
+        circlePlaneComplexEquiv.symm (z : ℂ) :=
+  rfl
+
+private theorem CuspCentralHomology.Radial.frontierCircleInverse_continuous :
+    Continuous frontierCircleInverse := by
+  apply Continuous.subtype_mk
+  have h : Continuous (fun z : Circle => circlePlaneComplexEquiv.symm (z : ℂ)) :=
+    circlePlaneComplexEquiv.symm.continuous.comp continuous_subtype_val
+  exact
+    ((cellGauge_continuous.comp h).inv₀ fun z => ne_of_gt (circleComplexPlaneGauge_pos z)).smul h
+
+@[simp]
+private theorem CuspCentralHomology.Radial.frontierCircleInverse_forward
+    (x : frontier CuspHoneycombTiling.baseCell) :
+    frontierCircleInverse (frontierCircleForward x) = x := by
+  apply Subtype.ext
+  change
+    (cellGauge (circlePlaneComplexEquiv.symm (frontierCircleForward x : ℂ)))⁻¹ •
+        circlePlaneComplexEquiv.symm (frontierCircleForward x : ℂ) =
+      (x : CuspHoneycombTiling.Plane)
+  rw [frontierCircleForward_coe, map_smul, circlePlaneComplexEquiv.symm_apply_apply,
+    cellGauge_smul_of_nonneg _ (inv_nonneg.mpr (norm_nonneg _)),
+    (mem_frontier_baseCell_iff _).mp x.property, mul_one, inv_inv, smul_smul,
+    mul_inv_cancel₀ (norm_ne_zero_iff.mpr (circleFrontierComplex_ne_zero x)), one_smul]
+
+@[simp]
+private theorem CuspCentralHomology.Radial.frontierCircleForward_inverse (z : Circle) :
+    frontierCircleForward (frontierCircleInverse z) = z := by
+  apply Circle.ext
+  change
+    NormedSpace.normalize
+        (circlePlaneComplexEquiv (frontierCircleInverse z : CuspHoneycombTiling.Plane)) =
+      (z : ℂ)
+  rw [frontierCircleInverse_coe, map_smul, circlePlaneComplexEquiv.apply_symm_apply,
+    NormedSpace.normalize_smul_of_pos (inv_pos.mpr (circleComplexPlaneGauge_pos z))]
+  exact NormedSpace.normalize_eq_self_of_norm_eq_one z.norm_coe
+
+private def CuspCentralHomology.Radial.frontierCellCircleHomeomorph :
+    frontier CuspHoneycombTiling.baseCell ≃ₜ Circle
+    where
+  toFun := frontierCircleForward
+  invFun := frontierCircleInverse
+  left_inv := frontierCircleInverse_forward
+  right_inv := frontierCircleForward_inverse
+  continuous_toFun := frontierCircleForward_continuous
+  continuous_invFun := frontierCircleInverse_continuous
+
+@[simp]
+private theorem CuspCentralHomology.Radial.frontierCellCircleHomeomorph_symm_coe (z : Circle) :
+    (frontierCellCircleHomeomorph.symm z : CuspHoneycombTiling.Plane) =
+      (cellGauge ![(z : ℂ).re, (z : ℂ).im])⁻¹ • ![(z : ℂ).re, (z : ℂ).im] :=
+  rfl
+
+private def
+    CuspCentralHomology.Radial.annulusCircleHomotopyEquiv (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    Annulus a ≃ₕ Circle :=
+  (annulusFrontierHomotopyEquiv a ha ha1).trans frontierCellCircleHomeomorph.toHomotopyEquiv
+
+private def
+    CuspCentralHomology.Radial.phaseAnnulusHomotopyEquiv (X : Type*) [TopologicalSpace X] (a : ℝ)
+    (ha : 0 ≤ a) (ha1 : a < 1) : (X × Annulus a) ≃ₕ X × Circle :=
+  (ContinuousMap.HomotopyEquiv.refl X).prodCongr (annulusCircleHomotopyEquiv a ha ha1)
+
+private abbrev CuspCentralHomology.OverlapPhaseCell (a : ℝ) :=
+  ToricSpace.CompactFibreTorus × Radial.Annulus a
+
+private def CuspCentralHomology.annulusCellInclusion (a : ℝ) (p : OverlapPhaseCell a) :
+    InteriorPhaseCell :=
+  (p.1, ⟨(p.2 : (CuspHoneycombTiling.Plane)), (Radial.mem_interior_baseCell_iff _).mpr p.2.2.2⟩)
+
+@[simp]
+private theorem CuspCentralHomology.annulusCellInclusion_snd_coe (a : ℝ) (p : OverlapPhaseCell a) :
+    ((annulusCellInclusion a p).2 : (CuspHoneycombTiling.Plane)) =
+      (p.2 : (CuspHoneycombTiling.Plane)) :=
+  rfl
+
+private theorem CuspCentralHomology.annulusCellInclusion_continuous (a : ℝ) :
+    Continuous (annulusCellInclusion a) :=
+  continuous_fst.prodMk ((continuous_subtype_val.comp continuous_snd).subtype_mk _)
+
+private theorem CuspCentralHomology.annulusCellInclusion_injective (a : ℝ) :
+    Function.Injective (annulusCellInclusion a) := by
+  intro p q hpq
+  apply Prod.ext
+  · exact congrArg (fun r : InteriorPhaseCell => r.1) hpq
+  · apply Subtype.ext
+    exact congrArg (fun r : InteriorPhaseCell => (r.2 : (CuspHoneycombTiling.Plane))) hpq
+
+private def
+    CuspCentralHomology.overlapRegion (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (a : ℝ) : Set (CuspRetraction.QuotientCentralFibre C ε) :=
+  outerRegion C ε hε a ∩ innerRegion C ε hε
+
+private def
+    CuspCentralHomology.overlapIntoInner (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (a : ℝ) : C(overlapRegion C ε hε a, innerRegion C ε hε) :=
+  ⟨fun q => ⟨(q : CuspRetraction.QuotientCentralFibre C ε), q.2.2⟩,
+    continuous_subtype_val.subtype_mk _⟩
+
+private def
+    CuspCentralHomology.overlapCellMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (p : OverlapPhaseCell a) : overlapRegion C ε hε a :=
+  ⟨(innerRegionHomeomorph C ε hε hε1 hC hR (annulusCellInclusion a p) :
+      CuspRetraction.QuotientCentralFibre C ε),
+    by
+    constructor
+    · change a < centralRadius C ε hε _
+      rw [innerRegionHomeomorph_radius, annulusCellInclusion_snd_coe]
+      exact p.2.2.1
+    · exact (innerRegionHomeomorph C ε hε hε1 hC hR (annulusCellInclusion a p)).2⟩
+
+@[simp]
+private theorem CuspCentralHomology.overlapCellMap_coe (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (p : OverlapPhaseCell a) :
+    (overlapCellMap C ε hε hε1 hC hR a p : CuspRetraction.QuotientCentralFibre C ε) =
+      CuspHoneycomb.honeycombCollapseMap C ε hε (p.1, (p.2 : (CuspHoneycombTiling.Plane))) :=
+  innerRegionHomeomorph_honeycomb C ε hε hε1 hC hR (annulusCellInclusion a p)
+
+private theorem
+    CuspCentralHomology.overlapCellMap_intoInner (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (p : OverlapPhaseCell a) :
+    overlapIntoInner C ε hε a (overlapCellMap C ε hε hε1 hC hR a p) =
+      innerRegionHomeomorph C ε hε hε1 hC hR (annulusCellInclusion a p) :=
+  rfl
+
+private theorem
+    CuspCentralHomology.overlapCellMap_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) : Continuous (overlapCellMap C ε hε hε1 hC hR a) :=
+  (continuous_subtype_val.comp
+        ((innerRegionHomeomorph C ε hε hε1 hC hR).continuous.comp
+          (annulusCellInclusion_continuous a))).subtype_mk
+    _
+
+private def
+    CuspCentralHomology.overlapCellInverse (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (q : overlapRegion C ε hε a) : OverlapPhaseCell a :=
+  let p := (innerRegionHomeomorph C ε hε hε1 hC hR).symm (overlapIntoInner C ε hε a q)
+  (p.1,
+    ⟨(p.2 : (CuspHoneycombTiling.Plane)), by
+      constructor
+      · rw [← innerRegionHomeomorph_radius C ε hε hε1 hC hR p]
+        dsimp only [p]
+        rw [Homeomorph.apply_symm_apply]
+        exact q.2.1
+      · exact (Radial.mem_interior_baseCell_iff _).mp p.2.2⟩)
+
+private theorem
+    CuspCentralHomology.overlapCellInverse_interior (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (q : overlapRegion C ε hε a) :
+    annulusCellInclusion a (overlapCellInverse C ε hε hε1 hC hR a q) =
+      (innerRegionHomeomorph C ε hε hε1 hC hR).symm (overlapIntoInner C ε hε a q) :=
+  rfl
+
+private theorem CuspCentralHomology.overlapCellInverse_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) :
+    Continuous (overlapCellInverse C ε hε hε1 hC hR a) := by
+  have hp :=
+    (innerRegionHomeomorph C ε hε hε1 hC hR).symm.continuous.comp
+      (overlapIntoInner C ε hε a).continuous
+  exact
+    (continuous_fst.comp hp).prodMk
+      ((continuous_subtype_val.comp (continuous_snd.comp hp)).subtype_mk _)
+
+private def CuspCentralHomology.overlapPhaseHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) : OverlapPhaseCell a ≃ₜ overlapRegion C ε hε a
+    where
+  toFun := overlapCellMap C ε hε hε1 hC hR a
+  invFun := overlapCellInverse C ε hε hε1 hC hR a
+  left_inv
+    p := by
+    apply annulusCellInclusion_injective a
+    rw [overlapCellInverse_interior, overlapCellMap_intoInner, Homeomorph.symm_apply_apply]
+  right_inv
+    q := by
+    apply Subtype.ext
+    change
+      (innerRegionHomeomorph C ε hε hε1 hC hR
+            (annulusCellInclusion a (overlapCellInverse C ε hε hε1 hC hR a q)) :
+          CuspRetraction.QuotientCentralFibre C ε) =
+        (q : CuspRetraction.QuotientCentralFibre C ε)
+    rw [overlapCellInverse_interior, Homeomorph.apply_symm_apply]
+    rfl
+  continuous_toFun := overlapCellMap_continuous C ε hε hε1 hC hR a
+  continuous_invFun := overlapCellInverse_continuous C ε hε hε1 hC hR a
+
+@[simp]
+private theorem
+    CuspCentralHomology.overlapPhaseHomeomorph_coe (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (p : OverlapPhaseCell a) :
+    (overlapPhaseHomeomorph C ε hε hε1 hC hR a p : CuspRetraction.QuotientCentralFibre C ε) =
+      CuspHoneycomb.honeycombCollapseMap C ε hε (p.1, (p.2 : (CuspHoneycombTiling.Plane))) :=
+  overlapCellMap_coe C ε hε hε1 hC hR a p
+
+private def
+    CuspCentralHomology.overlapHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) :
+    overlapRegion C ε hε a ≃ₜ ToricSpace.CompactFibreTorus × Radial.CellFrontier × Set.Ioo a 1 :=
+  (overlapPhaseHomeomorph C ε hε hε1 hC hR a).symm.trans
+    ((Homeomorph.refl ToricSpace.CompactFibreTorus).prodCongr (Radial.annulusHomeomorph a ha))
+
+private def CuspCentralHomology.innerRegionHomotopyEquiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : innerRegion C ε hε ≃ₕ ToricSpace.CompactFibreTorus :=
+  (innerRegionHomeomorph C ε hε hε1 hC hR).symm.toHomotopyEquiv.trans
+    (Radial.interiorCellProductHomotopyEquiv ToricSpace.CompactFibreTorus)
+
+private def
+    CuspCentralHomology.overlapCircleHomotopyEquiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    overlapRegion C ε hε a ≃ₕ ToricSpace.CompactFibreTorus × Circle :=
+  (overlapPhaseHomeomorph C ε hε hε1 hC hR a).symm.toHomotopyEquiv.trans
+    (Radial.phaseAnnulusHomotopyEquiv ToricSpace.CompactFibreTorus a ha ha1)
+
+private theorem
+    CuspCentralHomology.overlapIntoInner_phase_map (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    (innerRegionHomotopyEquiv C ε hε hε1 hC hR).toFun.comp (overlapIntoInner C ε hε a) =
+      (ContinuousMap.fst :
+            C(ToricSpace.CompactFibreTorus × Circle, ToricSpace.CompactFibreTorus)).comp
+        (overlapCircleHomotopyEquiv C ε hε hε1 hC hR a ha ha1).toFun := by
+  ext q
+  rfl
+
+private abbrev CuspCentralHomology.CollarPhaseCell (a : ℝ) :=
+  ToricSpace.CompactFibreTorus × Radial.OpenCollar a
+
+private def
+    CuspCentralHomology.collarCellInclusion (a : ℝ) (p : CollarPhaseCell a) : FundamentalCell :=
+  (p.1, ⟨(p.2 : (CuspHoneycombTiling.Plane)), (Radial.mem_baseCell_iff _).mpr p.2.2.2⟩)
+
+private theorem CuspCentralHomology.collarCellInclusion_continuous (a : ℝ) :
+    Continuous (collarCellInclusion a) :=
+  continuous_fst.prodMk ((continuous_subtype_val.comp continuous_snd).subtype_mk _)
+
+private theorem CuspCentralHomology.collarCellInclusion_injective (a : ℝ) :
+    Function.Injective (collarCellInclusion a) := by
+  intro p q hpq
+  apply Prod.ext
+  · exact congrArg (fun r : FundamentalCell => r.1) hpq
+  · apply Subtype.ext
+    exact congrArg (fun r : FundamentalCell => (r.2 : (CuspHoneycombTiling.Plane))) hpq
+
+private theorem CuspCentralHomology.fundamentalCellMap_mem_outerRegion_iff
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (a : ℝ) (p : FundamentalCell) :
+    fundamentalCellMap C ε hε p ∈ outerRegion C ε hε a ↔
+      a < Radial.cellGauge (p.2 : (CuspHoneycombTiling.Plane)) := by
+  change a < centralRadius C ε hε (fundamentalCellMap C ε hε p) ↔ _
+  rw [centralRadius_fundamentalCellMap]
+
+private def
+    CuspCentralHomology.collarCellMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (a : ℝ) (p : CollarPhaseCell a) : outerRegion C ε hε a :=
+  ⟨fundamentalCellMap C ε hε (collarCellInclusion a p),
+    (fundamentalCellMap_mem_outerRegion_iff C ε hε a _).mpr p.2.2.1⟩
+
+@[simp]
+private theorem CuspCentralHomology.collarCellMap_coe (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (a : ℝ) (p : CollarPhaseCell a) :
+    (collarCellMap C ε hε a p : CuspRetraction.QuotientCentralFibre C ε) =
+      CuspHoneycomb.honeycombCollapseMap C ε hε (p.1, (p.2 : (CuspHoneycombTiling.Plane))) :=
+  rfl
+
+private theorem
+    CuspCentralHomology.centralRadius_collarCellMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (a : ℝ) (p : CollarPhaseCell a) :
+    centralRadius C ε hε (collarCellMap C ε hε a p) =
+      Radial.cellGauge (p.2 : (CuspHoneycombTiling.Plane)) :=
+  centralRadius_fundamentalCellMap C ε hε (collarCellInclusion a p)
+
+private theorem
+    CuspCentralHomology.collarCellMap_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (a : ℝ) : Continuous (collarCellMap C ε hε a) :=
+  ((fundamentalCellMap_continuous C ε hε).comp (collarCellInclusion_continuous a)).subtype_mk _
+
+private theorem
+    CuspCentralHomology.collarCellMap_surjective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (a : ℝ) : Function.Surjective (collarCellMap C ε hε a) := by
+  rintro ⟨q, hq⟩
+  obtain ⟨p, hp⟩ := fundamentalCellMap_surjective C ε hε q
+  have hg : a < Radial.cellGauge (p.2 : (CuspHoneycombTiling.Plane)) := by
+    apply (fundamentalCellMap_mem_outerRegion_iff C ε hε a p).mp
+    rwa [hp]
+  refine
+    ⟨(p.1, ⟨(p.2 : (CuspHoneycombTiling.Plane)), hg, (Radial.mem_baseCell_iff _).mp p.2.2⟩), ?_⟩
+  apply Subtype.ext
+  exact hp
+
+private def CuspCentralHomology.collarPreimageHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (a : ℝ) :
+    CollarPhaseCell a ≃ₜ (fundamentalCellMap C ε hε ⁻¹' outerRegion C ε hε a)
+    where
+  toFun
+    p :=
+    ⟨collarCellInclusion a p, (fundamentalCellMap_mem_outerRegion_iff C ε hε a _).mpr p.2.2.1⟩
+  invFun
+    p :=
+    (p.1.1,
+      ⟨(p.1.2 : (CuspHoneycombTiling.Plane)),
+        (fundamentalCellMap_mem_outerRegion_iff C ε hε a p.1).mp p.2,
+        (Radial.mem_baseCell_iff _).mp p.1.2.2⟩)
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := (collarCellInclusion_continuous a).subtype_mk _
+  continuous_invFun :=
+    (continuous_fst.comp continuous_subtype_val).prodMk
+      ((continuous_subtype_val.comp (continuous_snd.comp continuous_subtype_val)).subtype_mk _)
+
+private theorem
+    CuspCentralHomology.collarCellMap_isProperMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (a : ℝ) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : IsProperMap (collarCellMap C ε hε a) := by
+  have hf :=
+    (fundamentalCellMap_isProperMap C ε hε hε1 hC hR).restrictPreimage (outerRegion C ε hε a)
+  have hc := hf.comp (collarPreimageHomeomorph C ε hε a).isProperMap
+  have he :
+    (outerRegion C ε hε a).restrictPreimage (fundamentalCellMap C ε hε) ∘
+        collarPreimageHomeomorph C ε hε a =
+      collarCellMap C ε hε a := by
+    funext p
+    apply Subtype.ext
+    rfl
+  rw [he] at hc
+  exact hc
+
+private theorem
+    CuspCentralHomology.collarCellMap_isClosedMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (a : ℝ) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : IsClosedMap (collarCellMap C ε hε a) :=
+  (collarCellMap_isProperMap C ε hε a hε1 hC hR).isClosedMap
+
+private theorem
+    CuspCentralHomology.collarCellMap_isQuotientMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (a : ℝ) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : Topology.IsQuotientMap (collarCellMap C ε hε a) :=
+  (collarCellMap_isClosedMap C ε hε a hε1 hC hR).isQuotientMap (collarCellMap_continuous C ε hε a)
+    (collarCellMap_surjective C ε hε a)
+
+private def CuspCentralHomology.collarCellHomotopy (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    C(unitInterval × CollarPhaseCell a, CollarPhaseCell a)
+    where
+  toFun p := (p.2.1, Radial.outwardOpenCollarHomotopy a ha ha1 (p.1, p.2.2))
+  continuous_toFun :=
+    (continuous_fst.comp continuous_snd).prodMk
+      ((Radial.outwardOpenCollarHomotopy a ha ha1).continuous.comp
+        (continuous_fst.prodMk (continuous_snd.comp continuous_snd)))
+
+@[simp]
+private theorem CuspCentralHomology.collarCellHomotopy_zero (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1)
+    (p : CollarPhaseCell a) : collarCellHomotopy a ha ha1 (0, p) = p := by
+  apply Prod.ext
+  · rfl
+  · exact (Radial.outwardOpenCollarHomotopy a ha ha1).apply_zero p.2
+
+private theorem CuspCentralHomology.collarCellHomotopy_fixed (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1)
+    (s : unitInterval) (p : CollarPhaseCell a)
+    (hp : (p.2 : (CuspHoneycombTiling.Plane)) ∈ frontier CuspHoneycombTiling.baseCell) :
+    collarCellHomotopy a ha ha1 (s, p) = p := by
+  apply Prod.ext
+  · rfl
+  · exact Radial.outwardOpenCollarHomotopy_fixed a ha ha1 s p.2 hp
+
+private theorem CuspCentralHomology.collarCellHomotopy_compatible (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (s : unitInterval)
+    (p q : CollarPhaseCell a) (h : collarCellMap C ε hε a p = collarCellMap C ε hε a q) :
+    collarCellMap C ε hε a (collarCellHomotopy a ha ha1 (s, p)) =
+      collarCellMap C ε hε a (collarCellHomotopy a ha ha1 (s, q)) := by
+  have he :
+    fundamentalCellMap C ε hε (collarCellInclusion a p) =
+      fundamentalCellMap C ε hε (collarCellInclusion a q) :=
+    congrArg Subtype.val h
+  rcases
+    fundamentalCellMap_eq_or_frontier C ε hε (collarCellInclusion a p) (collarCellInclusion a q)
+      he with
+    hpq | ⟨hp, hq⟩
+  · rw [collarCellInclusion_injective a hpq]
+  · rw [collarCellHomotopy_fixed a ha ha1 s p hp, collarCellHomotopy_fixed a ha ha1 s q hq]
+    exact h
+
+private def
+    CuspCentralHomology.outerRegionBoundaryInclusion (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (a : ℝ) (ha1 : a < 1) : C(centralBoundary C ε hε, outerRegion C ε hε a)
+    where
+  toFun x := ⟨x, centralBoundary_subset_outerRegion C ε hε a ha1 x.2⟩
+  continuous_toFun := continuous_subtype_val.subtype_mk _
+
+private def CuspCentralHomology.outerRegionDeformation (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (s : unitInterval)
+    (x : outerRegion C ε hε a) : outerRegion C ε hε a :=
+  CuspHoneycombHexagon.CommonFibres.descend (collarCellMap C ε hε a)
+    (fun p => collarCellMap C ε hε a (collarCellHomotopy a ha ha1 (s, p)))
+    (collarCellMap_surjective C ε hε a) x
+
+@[simp]
+private theorem CuspCentralHomology.outerRegionDeformation_collarCellMap
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1)
+    (s : unitInterval) (p : CollarPhaseCell a) :
+    outerRegionDeformation C ε hε a ha ha1 s (collarCellMap C ε hε a p) =
+      collarCellMap C ε hε a (collarCellHomotopy a ha ha1 (s, p)) :=
+  CuspHoneycombHexagon.CommonFibres.descend_apply (collarCellMap C ε hε a)
+    (fun p => collarCellMap C ε hε a (collarCellHomotopy a ha ha1 (s, p)))
+    (collarCellMap_surjective C ε hε a) (collarCellHomotopy_compatible C ε hε a ha ha1 s) p
+
+private theorem CuspCentralHomology.outerRegionDeformation_collarCellMap_coe
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1)
+    (s : unitInterval) (p : CollarPhaseCell a) :
+    (outerRegionDeformation C ε hε a ha ha1 s (collarCellMap C ε hε a p) :
+        CuspRetraction.QuotientCentralFibre C ε) =
+      CuspHoneycomb.honeycombCollapseMap C ε hε
+        (p.1,
+          ((1 - (s : ℝ)) + (s : ℝ) / Radial.cellGauge p.2) •
+            (p.2 : (CuspHoneycombTiling.Plane))) := by
+  rw [outerRegionDeformation_collarCellMap, collarCellMap_coe]
+  change
+    CuspHoneycomb.honeycombCollapseMap C ε hε
+        (p.1,
+          (Radial.outwardOpenCollarHomotopy a ha ha1 (s, p.2) : (CuspHoneycombTiling.Plane))) =
+      _
+  rw [Radial.outwardOpenCollarHomotopy_coe]
+
+@[simp]
+private theorem
+    CuspCentralHomology.outerRegionDeformation_zero (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (x : outerRegion C ε hε a) :
+    outerRegionDeformation C ε hε a ha ha1 0 x = x := by
+  obtain ⟨p, rfl⟩ := collarCellMap_surjective C ε hε a x
+  rw [outerRegionDeformation_collarCellMap, collarCellHomotopy_zero]
+
+private theorem CuspCentralHomology.outerRegionDeformation_radius (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (s : unitInterval)
+    (x : outerRegion C ε hε a) :
+    centralRadius C ε hε (outerRegionDeformation C ε hε a ha ha1 s x) =
+      (1 - (s : ℝ)) * centralRadius C ε hε x + (s : ℝ) := by
+  obtain ⟨p, rfl⟩ := collarCellMap_surjective C ε hε a x
+  rw [outerRegionDeformation_collarCellMap, centralRadius_collarCellMap,
+    centralRadius_collarCellMap]
+  exact Radial.outwardOpenCollarHomotopy_gauge a ha ha1 s p.2
+
+private theorem CuspCentralHomology.outerRegionDeformation_one_mem_boundary
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1)
+    (x : outerRegion C ε hε a) :
+    (outerRegionDeformation C ε hε a ha ha1 1 x : CuspRetraction.QuotientCentralFibre C ε) ∈
+      centralBoundary C ε hε := by
+  change centralRadius C ε hε (outerRegionDeformation C ε hε a ha ha1 1 x) = 1
+  rw [outerRegionDeformation_radius]
+  simp
+
+private theorem CuspCentralHomology.outerRegionDeformation_fixed (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (s : unitInterval)
+    (x : outerRegion C ε hε a)
+    (hx : (x : CuspRetraction.QuotientCentralFibre C ε) ∈ centralBoundary C ε hε) :
+    outerRegionDeformation C ε hε a ha ha1 s x = x := by
+  obtain ⟨p, rfl⟩ := collarCellMap_surjective C ε hε a x
+  have hp : (p.2 : (CuspHoneycombTiling.Plane)) ∈ frontier CuspHoneycombTiling.baseCell := by
+    apply (Radial.mem_frontier_baseCell_iff _).mpr
+    change centralRadius C ε hε (collarCellMap C ε hε a p) = 1 at hx
+    rwa [centralRadius_collarCellMap] at hx
+  rw [outerRegionDeformation_collarCellMap, collarCellHomotopy_fixed a ha ha1 s p hp]
+
+private theorem
+    CuspCentralHomology.outerRegionDeformation_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    Continuous
+      (fun p : unitInterval × outerRegion C ε hε a =>
+        outerRegionDeformation C ε hε a ha ha1 p.1 p.2) := by
+  apply (collarCellMap_isQuotientMap C ε hε a hε1 hC hR).continuous_lift_prod_right
+  have hc := (collarCellMap_continuous C ε hε a).comp (collarCellHomotopy a ha ha1).continuous
+  simpa only [outerRegionDeformation_collarCellMap, Function.comp_def, Prod.eta] using hc
+
+private def CuspCentralHomology.outerRegionRetraction (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : C(outerRegion C ε hε a, centralBoundary C ε hε)
+    where
+  toFun
+    x :=
+    ⟨outerRegionDeformation C ε hε a ha ha1 1 x,
+      outerRegionDeformation_one_mem_boundary C ε hε a ha ha1 x⟩
+  continuous_toFun :=
+    (continuous_subtype_val.comp
+          ((outerRegionDeformation_continuous C ε hε a ha ha1 hε1 hC hR).comp
+            (continuous_const.prodMk continuous_id))).subtype_mk
+      _
+
+@[simp]
+private theorem
+    CuspCentralHomology.outerRegionRetraction_coe (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (x : outerRegion C ε hε a) :
+    (outerRegionRetraction C ε hε a ha ha1 hε1 hC hR x :
+        CuspRetraction.QuotientCentralFibre C ε) =
+      outerRegionDeformation C ε hε a ha ha1 1 x :=
+  rfl
+
+private theorem
+    CuspCentralHomology.outerRegionRetraction_collarCellMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (p : CollarPhaseCell a) :
+    (outerRegionRetraction C ε hε a ha ha1 hε1 hC hR (collarCellMap C ε hε a p) :
+        CuspRetraction.QuotientCentralFibre C ε) =
+      CuspHoneycomb.honeycombCollapseMap C ε hε
+        (p.1, (Radial.cellGauge p.2)⁻¹ • (p.2 : (CuspHoneycombTiling.Plane))) := by
+  rw [outerRegionRetraction_coe, outerRegionDeformation_collarCellMap_coe]
+  simp
+
+@[simp]
+private theorem CuspCentralHomology.outerRegionRetraction_comp_inclusion
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1)
+    (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    (outerRegionRetraction C ε hε a ha ha1 hε1 hC hR).comp
+        (outerRegionBoundaryInclusion C ε hε a ha1) =
+      ContinuousMap.id (centralBoundary C ε hε) := by
+  apply ContinuousMap.ext
+  intro x
+  apply Subtype.ext
+  change
+    (outerRegionDeformation C ε hε a ha ha1 1 (outerRegionBoundaryInclusion C ε hε a ha1 x) :
+        CuspRetraction.QuotientCentralFibre C ε) =
+      x
+  exact
+    congrArg Subtype.val
+      (outerRegionDeformation_fixed C ε hε a ha ha1 1
+        (outerRegionBoundaryInclusion C ε hε a ha1 x) x.2)
+
+private def CuspCentralHomology.outerRegionHomotopyRel (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    (ContinuousMap.id (outerRegion C ε hε a)).HomotopyRel
+      ((outerRegionBoundaryInclusion C ε hε a ha1).comp
+        (outerRegionRetraction C ε hε a ha ha1 hε1 hC hR))
+      {x : outerRegion C ε hε a |
+        (x : CuspRetraction.QuotientCentralFibre C ε) ∈ centralBoundary C ε hε}
+    where
+  toFun p := outerRegionDeformation C ε hε a ha ha1 p.1 p.2
+  continuous_toFun := outerRegionDeformation_continuous C ε hε a ha ha1 hε1 hC hR
+  map_zero_left := outerRegionDeformation_zero C ε hε a ha ha1
+  map_one_left _ := rfl
+  prop' := outerRegionDeformation_fixed C ε hε a ha ha1
+
+private def CuspCentralHomology.outerRegionBoundaryHomotopyEquiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : outerRegion C ε hε a ≃ₕ centralBoundary C ε hε
+    where
+  toFun := outerRegionRetraction C ε hε a ha ha1 hε1 hC hR
+  invFun := outerRegionBoundaryInclusion C ε hε a ha1
+  left_inv := ⟨(outerRegionHomotopyRel C ε hε a ha ha1 hε1 hC hR).toHomotopy.symm⟩
+  right_inv := by
+    refine ⟨?_⟩
+    rw [outerRegionRetraction_comp_inclusion]
+    exact ContinuousMap.Homotopy.refl _
+
+@[simp]
+private theorem CuspCentralHomology.outerRegionBoundaryHomotopyEquiv_apply
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1)
+    (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (x : outerRegion C ε hε a) :
+    outerRegionBoundaryHomotopyEquiv C ε hε a ha ha1 hε1 hC hR x =
+      outerRegionRetraction C ε hε a ha ha1 hε1 hC hR x :=
+  rfl
+
+private abbrev CuspCentralHomology.BoundaryPhaseCell :=
+  ToricSpace.CompactFibreTorus × Radial.CellFrontier
+
+private theorem CuspCentralHomology.honeycombCollapseMap_frontier_mem_boundary
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (p : BoundaryPhaseCell) :
+    CuspHoneycomb.honeycombCollapseMap C ε hε (p.1, (p.2 : (CuspHoneycombTiling.Plane))) ∈
+      centralBoundary C ε hε := by
+  rw [centralBoundary_eq_image]
+  exact ⟨(p.1, (p.2 : (CuspHoneycombTiling.Plane))), ⟨Set.mem_univ _, p.2.2⟩, rfl⟩
+
+private def
+    CuspCentralHomology.boundaryCellMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    C(BoundaryPhaseCell, centralBoundary C ε hε)
+    where
+  toFun
+    p :=
+    ⟨CuspHoneycomb.honeycombCollapseMap C ε hε (p.1, (p.2 : (CuspHoneycombTiling.Plane))),
+      honeycombCollapseMap_frontier_mem_boundary C ε hε p⟩
+  continuous_toFun := by
+    have hi :
+      Continuous (fun p : BoundaryPhaseCell => (p.1, (p.2 : (CuspHoneycombTiling.Plane)))) :=
+      continuous_fst.prodMk (continuous_subtype_val.comp continuous_snd)
+    exact ((CuspHoneycomb.honeycombCollapseMap_continuous C ε hε).comp hi).subtype_mk _
+
+@[simp]
+private theorem CuspCentralHomology.boundaryCellMap_coe (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (p : BoundaryPhaseCell) :
+    (boundaryCellMap C ε hε p : CuspRetraction.QuotientCentralFibre C ε) =
+      CuspHoneycomb.honeycombCollapseMap C ε hε (p.1, (p.2 : (CuspHoneycombTiling.Plane))) :=
+  rfl
+
+private def CuspCentralHomology.circleBoundaryCellMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : C(ToricSpace.CompactFibreTorus × Circle, centralBoundary C ε hε) :=
+  (boundaryCellMap C ε hε).comp
+    ⟨fun p => (p.1, Radial.frontierCellCircleHomeomorph.symm p.2),
+      continuous_fst.prodMk
+        (Radial.frontierCellCircleHomeomorph.symm.continuous.comp continuous_snd)⟩
+
+@[simp]
+private theorem
+    CuspCentralHomology.circleBoundaryCellMap_apply (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (p : ToricSpace.CompactFibreTorus × Circle) :
+    circleBoundaryCellMap C ε hε p =
+      boundaryCellMap C ε hε (p.1, Radial.frontierCellCircleHomeomorph.symm p.2) :=
+  rfl
+
+private def
+    CuspCentralHomology.overlapIntoOuter (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (a : ℝ) : C(overlapRegion C ε hε a, outerRegion C ε hε a) :=
+  ⟨fun q => ⟨(q : CuspRetraction.QuotientCentralFibre C ε), q.2.1⟩,
+    continuous_subtype_val.subtype_mk _⟩
+
+@[simp]
+private theorem CuspCentralHomology.overlapIntoOuter_coe (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (a : ℝ) (q : overlapRegion C ε hε a) :
+    (overlapIntoOuter C ε hε a q : CuspRetraction.QuotientCentralFibre C ε) =
+      (q : CuspRetraction.QuotientCentralFibre C ε) :=
+  rfl
+
+private def
+    CuspCentralHomology.annulusIntoCollar (a : ℝ) (p : OverlapPhaseCell a) : CollarPhaseCell a :=
+  (p.1, ⟨(p.2 : (CuspHoneycombTiling.Plane)), p.2.2.1, p.2.2.2.le⟩)
+
+private theorem
+    CuspCentralHomology.overlapIntoOuter_phaseHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (p : OverlapPhaseCell a) :
+    overlapIntoOuter C ε hε a (overlapPhaseHomeomorph C ε hε hε1 hC hR a p) =
+      collarCellMap C ε hε a (annulusIntoCollar a p) := by
+  apply Subtype.ext
+  rw [overlapIntoOuter_coe, overlapPhaseHomeomorph_coe, collarCellMap_coe]
+  rfl
+
+private theorem CuspCentralHomology.outerRegionRetraction_overlapPhaseHomeomorph
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (p : OverlapPhaseCell a) :
+    outerRegionRetraction C ε hε a ha ha1 hε1 hC hR
+        (overlapIntoOuter C ε hε a (overlapPhaseHomeomorph C ε hε hε1 hC hR a p)) =
+      boundaryCellMap C ε hε (p.1, (Radial.annulusHomeomorph a ha p.2).1) := by
+  apply Subtype.ext
+  rw [overlapIntoOuter_phaseHomeomorph, outerRegionRetraction_collarCellMap, boundaryCellMap_coe]
+  rfl
+
+private theorem CuspCentralHomology.overlapCircleHomotopyEquiv_phaseHomeomorph
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (p : OverlapPhaseCell a) :
+    overlapCircleHomotopyEquiv C ε hε hε1 hC hR a ha ha1
+        (overlapPhaseHomeomorph C ε hε hε1 hC hR a p) =
+      (p.1, Radial.annulusCircleHomotopyEquiv a ha ha1 p.2) := by
+  change
+    Radial.phaseAnnulusHomotopyEquiv ToricSpace.CompactFibreTorus a ha ha1
+        ((overlapPhaseHomeomorph C ε hε hε1 hC hR a).symm
+          (overlapPhaseHomeomorph C ε hε hε1 hC hR a p)) =
+      _
+  rw [Homeomorph.symm_apply_apply]
+  rfl
+
+private theorem
+    CuspCentralHomology.overlapIntoOuter_boundary (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1)
+    (q : overlapRegion C ε hε a) :
+    outerRegionBoundaryHomotopyEquiv C ε hε a ha ha1 hε1 hC hR (overlapIntoOuter C ε hε a q) =
+      circleBoundaryCellMap C ε hε (overlapCircleHomotopyEquiv C ε hε hε1 hC hR a ha ha1 q) := by
+  obtain ⟨p, rfl⟩ := (overlapPhaseHomeomorph C ε hε hε1 hC hR a).surjective q
+  rw [outerRegionBoundaryHomotopyEquiv_apply, outerRegionRetraction_overlapPhaseHomeomorph,
+    overlapCircleHomotopyEquiv_phaseHomeomorph, circleBoundaryCellMap_apply]
+  congr 1
+  apply Prod.ext
+  · rfl
+  · change
+      (Radial.annulusHomeomorph a ha p.2).1 =
+        Radial.frontierCellCircleHomeomorph.symm
+          (Radial.frontierCellCircleHomeomorph (Radial.annulusHomeomorph a ha p.2).1)
+    exact (Radial.frontierCellCircleHomeomorph.symm_apply_apply _).symm
+
+private theorem CuspCentralHomology.overlapIntoOuter_boundary_map (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    (outerRegionBoundaryHomotopyEquiv C ε hε a ha ha1 hε1 hC hR).toFun.comp
+        (overlapIntoOuter C ε hε a) =
+      (circleBoundaryCellMap C ε hε).comp
+        (overlapCircleHomotopyEquiv C ε hε hε1 hC hR a ha ha1).toFun := by
+  apply ContinuousMap.ext
+  intro q
+  exact overlapIntoOuter_boundary C ε hε hε1 hC hR a ha ha1 q
+
+private def CuspCentralHomology.phaseOrbitVertex : Radial.CellFrontier :=
+  ⟨![(1 / 3 : ℝ), 1 / 3],
+    (Radial.mem_frontier_baseCell_iff _).mpr (by norm_num [Radial.cellGauge])⟩
+
+@[simp]
+private theorem CuspCentralHomology.phaseOrbitVertex_coe :
+    (phaseOrbitVertex : (CuspHoneycombTiling.Plane)) = ![(1 / 3 : ℝ), 1 / 3] :=
+  rfl
+
+private theorem CuspCentralHomology.phaseOrbitVertex_eq_triangleBarycenter :
+    (phaseOrbitVertex : (CuspHoneycombTiling.Plane)) =
+      CuspHoneycombTiling.triangleBarycenter (ToricComponent.zeroTriangle 0) := by
+  rw [CuspHoneycombTiling.triangleBarycenter_zeroTriangle]
+  funext i
+  fin_cases i <;> norm_num [phaseOrbitVertex, ToricComponent.hexagonRay]
+
+private theorem CuspCentralHomology.honeycombCollapseMap_phaseOrbitVertex
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (φ : ToricSpace.CompactFibreTorus) :
+    CuspHoneycomb.honeycombCollapseMap C ε hε
+        (φ, (phaseOrbitVertex : (CuspHoneycombTiling.Plane))) =
+      CuspHoneycomb.honeycombCollapseMap C ε hε
+        (1, (phaseOrbitVertex : (CuspHoneycombTiling.Plane))) := by
+  apply (CuspHoneycomb.honeycombCollapseMap_eq_iff C ε hε _ _).mpr
+  refine ⟨0, by simp, ?_⟩
+  rw [phaseOrbitVertex_eq_triangleBarycenter,
+    CuspHoneycomb.honeycombHomeomorph_stabilizer_triangleBarycenter]
+  trivial
+
+private theorem CuspCentralHomology.phaseOrbitAnchor_coe :
+    (Radial.frontierCellCircleHomeomorph.symm 1 : (CuspHoneycombTiling.Plane)) =
+      ![(1 / 2 : ℝ), 0] := by
+  rw [Radial.frontierCellCircleHomeomorph_symm_coe]
+  ext i
+  fin_cases i <;> norm_num [Radial.cellGauge, Pi.smul_apply, smul_eq_mul]
+
+private theorem CuspCentralHomology.phaseOrbitSegment_coordinates (s : unitInterval) :
+    (1 - (s : ℝ)) • (![(1 / 2 : ℝ), 0] : (CuspHoneycombTiling.Plane)) +
+        (s : ℝ) • (![(1 / 3 : ℝ), 1 / 3] : (CuspHoneycombTiling.Plane)) =
+      ![(1 / 2 : ℝ) - (s : ℝ) / 6, (s : ℝ) / 3] := by
+  ext i
+  fin_cases i <;> simp [Pi.add_apply, smul_eq_mul] <;> ring
+
+private theorem CuspCentralHomology.phaseOrbitSegment_mem_frontier (s : unitInterval) :
+    (1 - (s : ℝ)) • (![(1 / 2 : ℝ), 0] : (CuspHoneycombTiling.Plane)) +
+        (s : ℝ) • (![(1 / 3 : ℝ), 1 / 3] : (CuspHoneycombTiling.Plane)) ∈
+      frontier CuspHoneycombTiling.baseCell := by
+  apply (Radial.mem_frontier_baseCell_iff _).mpr
+  rw [phaseOrbitSegment_coordinates]
+  simp only [Radial.cellGauge, Matrix.cons_val_zero, Matrix.cons_val_one]
+  have h0 : 2 * ((1 / 2 : ℝ) - (s : ℝ) / 6) + (s : ℝ) / 3 = 1 := by ring
+  rw [h0, abs_one]
+  apply max_eq_left
+  apply max_le
+  · apply abs_le.mpr
+    constructor <;> linarith [s.2.1, s.2.2]
+  · apply abs_le.mpr
+    constructor <;> linarith [s.2.1, s.2.2]
+
+private def CuspCentralHomology.phaseOrbitSegment : C(unitInterval, Radial.CellFrontier)
+    where
+  toFun
+    s :=
+    ⟨(1 - (s : ℝ)) • (![(1 / 2 : ℝ), 0] : (CuspHoneycombTiling.Plane)) +
+        (s : ℝ) • (![(1 / 3 : ℝ), 1 / 3] : (CuspHoneycombTiling.Plane)),
+      phaseOrbitSegment_mem_frontier s⟩
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    exact
+      ((continuous_const.sub continuous_subtype_val).smul continuous_const).add
+        (continuous_subtype_val.smul continuous_const)
+
+@[simp]
+private theorem CuspCentralHomology.phaseOrbitSegment_coe (s : unitInterval) :
+    (phaseOrbitSegment s : (CuspHoneycombTiling.Plane)) =
+      (1 - (s : ℝ)) • (![(1 / 2 : ℝ), 0] : (CuspHoneycombTiling.Plane)) +
+        (s : ℝ) • (![(1 / 3 : ℝ), 1 / 3] : (CuspHoneycombTiling.Plane)) :=
+  rfl
+
+@[simp]
+private theorem CuspCentralHomology.phaseOrbitSegment_zero :
+    phaseOrbitSegment 0 = Radial.frontierCellCircleHomeomorph.symm 1 := by
+  apply Subtype.ext
+  rw [phaseOrbitSegment_coe, phaseOrbitAnchor_coe]
+  simp
+
+@[simp]
+private theorem
+    CuspCentralHomology.phaseOrbitSegment_one : phaseOrbitSegment 1 = phaseOrbitVertex := by
+  apply Subtype.ext
+  rw [phaseOrbitSegment_coe, phaseOrbitVertex_coe]
+  simp
+
+private theorem
+    CuspCentralHomology.boundaryCellMap_phaseOrbitVertex (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (φ : ToricSpace.CompactFibreTorus) :
+    boundaryCellMap C ε hε (φ, phaseOrbitVertex) = boundaryCellMap C ε hε (1, phaseOrbitVertex) :=
+  Subtype.ext (honeycombCollapseMap_phaseOrbitVertex C ε hε φ)
+
+private def CuspCentralHomology.boundaryPhaseOrbit (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : C(ToricSpace.CompactFibreTorus, centralBoundary C ε hε) :=
+  (circleBoundaryCellMap C ε hε).comp ⟨fun φ => (φ, 1), continuous_id.prodMk continuous_const⟩
+
+private def
+    CuspCentralHomology.boundaryPhaseOrbitHomotopy (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) :
+    (boundaryPhaseOrbit C ε hε).Homotopy
+      (ContinuousMap.const ToricSpace.CompactFibreTorus
+        (boundaryCellMap C ε hε (1, phaseOrbitVertex)))
+    where
+  toFun p := boundaryCellMap C ε hε (p.2, phaseOrbitSegment p.1)
+  continuous_toFun :=
+    (boundaryCellMap C ε hε).continuous.comp
+      (continuous_snd.prodMk (phaseOrbitSegment.continuous.comp continuous_fst))
+  map_zero_left
+    φ := by
+    change boundaryCellMap C ε hε (φ, phaseOrbitSegment 0) = circleBoundaryCellMap C ε hε (φ, 1)
+    rw [phaseOrbitSegment_zero, circleBoundaryCellMap_apply]
+  map_one_left
+    φ := by
+    change boundaryCellMap C ε hε (φ, phaseOrbitSegment 1) = _
+    rw [phaseOrbitSegment_one]
+    exact boundaryCellMap_phaseOrbitVertex C ε hε φ
+
+private theorem
+    CuspCentralHomology.boundaryPhaseOrbit_nullhomotopic (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) : (boundaryPhaseOrbit C ε hε).Nullhomotopic :=
+  ⟨boundaryCellMap C ε hε (1, phaseOrbitVertex), ⟨boundaryPhaseOrbitHomotopy C ε hε⟩⟩
+
+private def CuspCentralHomology.innerRegionInclusion (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : C(innerRegion C ε hε, CuspRetraction.QuotientCentralFibre C ε) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private def
+    CuspCentralHomology.innerRegionInclusionHomotopy (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    (innerRegionInclusion C ε hε).Homotopy
+      (ContinuousMap.const (innerRegion C ε hε)
+        (CuspHoneycomb.honeycombCollapseMap C ε hε
+          (1, (phaseOrbitVertex : (CuspHoneycombTiling.Plane)))))
+    where
+  toFun
+    p :=
+    let x := (innerRegionHomeomorph C ε hε hε1 hC hR).symm p.2
+    CuspHoneycomb.honeycombCollapseMap C ε hε
+      (x.1,
+        (1 - (p.1 : ℝ)) • (x.2 : (CuspHoneycombTiling.Plane)) +
+          (p.1 : ℝ) • (phaseOrbitVertex : (CuspHoneycombTiling.Plane)))
+  continuous_toFun := by
+    have hx :=
+      (innerRegionHomeomorph C ε hε hε1 hC hR).symm.continuous.comp
+        (continuous_snd : Continuous (Prod.snd : unitInterval × innerRegion C ε hε → _))
+    have hs : Continuous (fun p : unitInterval × innerRegion C ε hε => (p.1 : ℝ)) :=
+      continuous_subtype_val.comp continuous_fst
+    exact
+      (CuspHoneycomb.honeycombCollapseMap_continuous C ε hε).comp
+        ((continuous_fst.comp hx).prodMk
+          (((continuous_const.sub hs).smul
+                (continuous_subtype_val.comp (continuous_snd.comp hx))).add
+            (hs.smul continuous_const)))
+  map_zero_left
+    q := by
+    change
+      CuspHoneycomb.honeycombCollapseMap C ε hε
+          (((innerRegionHomeomorph C ε hε hε1 hC hR).symm q).1,
+            (1 - (0 : ℝ)) •
+                (((innerRegionHomeomorph C ε hε hε1 hC hR).symm q).2 :
+                  (CuspHoneycombTiling.Plane)) +
+              (0 : ℝ) • (phaseOrbitVertex : (CuspHoneycombTiling.Plane))) =
+        (q : CuspRetraction.QuotientCentralFibre C ε)
+    rw [sub_zero, one_smul, zero_smul, add_zero]
+    simpa only [Homeomorph.apply_symm_apply] using
+      (innerRegionHomeomorph_honeycomb C ε hε hε1 hC hR
+          ((innerRegionHomeomorph C ε hε hε1 hC hR).symm q)).symm
+  map_one_left
+    q := by
+    change
+      CuspHoneycomb.honeycombCollapseMap C ε hε
+          (((innerRegionHomeomorph C ε hε hε1 hC hR).symm q).1,
+            (1 - (1 : ℝ)) •
+                (((innerRegionHomeomorph C ε hε hε1 hC hR).symm q).2 :
+                  (CuspHoneycombTiling.Plane)) +
+              (1 : ℝ) • (phaseOrbitVertex : (CuspHoneycombTiling.Plane))) =
+        _
+    rw [sub_self, zero_smul, one_smul, zero_add]
+    exact honeycombCollapseMap_phaseOrbitVertex C ε hε _
+
+private theorem
+    CuspCentralHomology.innerRegionInclusion_nullhomotopic (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : (innerRegionInclusion C ε hε).Nullhomotopic :=
+  ⟨CuspHoneycomb.honeycombCollapseMap C ε hε
+      (1, (phaseOrbitVertex : (CuspHoneycombTiling.Plane))),
+    ⟨innerRegionInclusionHomotopy C ε hε hε1 hC hR⟩⟩
+
+private def
+    CuspCentralHomology.boundaryLoop (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    C(Circle, centralBoundary C ε hε) :=
+  (circleBoundaryCellMap C ε hε).comp ⟨fun z => (1, z), continuous_const.prodMk continuous_id⟩
+
+@[simp]
+private theorem CuspCentralHomology.boundaryLoop_apply (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (z : Circle) : boundaryLoop C ε hε z = circleBoundaryCellMap C ε hε (1, z) :=
+  rfl
+
+private def CuspCentralHomology.centralBoundaryInclusion (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : C(centralBoundary C ε hε, CuspRetraction.QuotientCentralFibre C ε) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private def CuspCentralHomology.boundaryLoopInCentral (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : C(Circle, CuspRetraction.QuotientCentralFibre C ε) :=
+  (centralBoundaryInclusion C ε hε).comp (boundaryLoop C ε hε)
+
+private def CuspCentralHomology.boundaryLoopContraction (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) :
+    (boundaryLoopInCentral C ε hε).Homotopy
+      (ContinuousMap.const Circle (CuspHoneycomb.honeycombCollapseMap C ε hε (1, 0)))
+    where
+  toFun
+    p :=
+    CuspHoneycomb.honeycombCollapseMap C ε hε
+      (1,
+        (1 - (p.1 : ℝ)) •
+          (Radial.frontierCellCircleHomeomorph.symm p.2 : (CuspHoneycombTiling.Plane)))
+  continuous_toFun :=
+    (CuspHoneycomb.honeycombCollapseMap_continuous C ε hε).comp
+      (continuous_const.prodMk
+        ((continuous_const.sub (continuous_subtype_val.comp continuous_fst)).smul
+          (continuous_subtype_val.comp
+            (Radial.frontierCellCircleHomeomorph.symm.continuous.comp continuous_snd))))
+  map_zero_left
+    z := by
+    change
+      CuspHoneycomb.honeycombCollapseMap C ε hε
+          (1,
+            (1 - (0 : ℝ)) •
+              (Radial.frontierCellCircleHomeomorph.symm z : (CuspHoneycombTiling.Plane))) =
+        CuspHoneycomb.honeycombCollapseMap C ε hε
+          (1, (Radial.frontierCellCircleHomeomorph.symm z : (CuspHoneycombTiling.Plane)))
+    simp only [sub_zero, one_smul]
+  map_one_left
+    z := by
+    change
+      CuspHoneycomb.honeycombCollapseMap C ε hε
+          (1,
+            (1 - (1 : ℝ)) •
+              (Radial.frontierCellCircleHomeomorph.symm z : (CuspHoneycombTiling.Plane))) =
+        CuspHoneycomb.honeycombCollapseMap C ε hε (1, 0)
+    simp only [sub_self, zero_smul]
+
+private theorem
+    CuspCentralHomology.boundaryLoopInCentral_nullhomotopic (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) : (boundaryLoopInCentral C ε hε).Nullhomotopic :=
+  ⟨CuspHoneycomb.honeycombCollapseMap C ε hε (1, 0), ⟨boundaryLoopContraction C ε hε⟩⟩
+
+private theorem CuspCentralHomology.centralBoundaryInclusion_comp_boundaryLoop_nullhomotopic
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    ((centralBoundaryInclusion C ε hε).comp (boundaryLoop C ε hε)).Nullhomotopic :=
+  boundaryLoopInCentral_nullhomotopic C ε hε
+
+private theorem
+    CuspCentralHomology.centralBoundary_pathConnectedSpace (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : PathConnectedSpace (centralBoundary C ε hε) :=
+  (centralBoundarySuspensionHomeomorph C ε hε hε1 hC hR).symm.surjective.pathConnectedSpace
+    (centralBoundarySuspensionHomeomorph C ε hε hε1 hC hR).symm.continuous
+
+private theorem
+    CuspCentralHomology.overlapRegion_pathConnectedSpace (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    PathConnectedSpace (overlapRegion C ε hε a) := by
+  let : PathConnectedSpace Radial.CellFrontier :=
+    Radial.frontierCellCircleHomeomorph.symm.surjective.pathConnectedSpace
+      Radial.frontierCellCircleHomeomorph.symm.continuous
+  let : PathConnectedSpace (Set.Ioo a 1) :=
+    isPathConnected_iff_pathConnectedSpace.mp
+      ((convex_Ioo a 1).isPathConnected (Set.nonempty_Ioo.mpr ha1))
+  exact
+    (overlapHomeomorph C ε hε hε1 hC hR a ha).symm.surjective.pathConnectedSpace
+      (overlapHomeomorph C ε hε hε1 hC hR a ha).symm.continuous
+
+private theorem
+    CuspCentralHomology.halfCoverLeftHomologyZero_injective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    Function.Injective
+      (SingularMayerVietoris.leftHomologyMap (outerRegion C ε hε (1 / 2)) (innerRegion C ε hε)
+        0) := by
+  let := centralBoundary_pathConnectedSpace C ε hε hε1 hC hR
+  let := overlapRegion_pathConnectedSpace C ε hε hε1 hC hR (1 / 2) (by norm_num) (by norm_num)
+  let e := outerRegionBoundaryHomotopyEquiv C ε hε (1 / 2) (by norm_num) (by norm_num) hε1 hC hR
+  let i : C((overlapRegion C ε hε (1 / 2)), (outerRegion C ε hε (1 / 2))) :=
+    ContinuousMap.inclusion
+      (Set.inter_subset_left :
+        (outerRegion C ε hε (1 / 2)) ∩ (innerRegion C ε hε) ⊆ (outerRegion C ε hε (1 / 2)))
+  let g : C((overlapRegion C ε hε (1 / 2)), (centralBoundary C ε hε)) := e.toFun.comp i
+  intro a b hab
+  have hi :
+    SingularMayerVietoris.singularHomologyMap i 0 a =
+      SingularMayerVietoris.singularHomologyMap i 0 b := by
+    have h := congrArg Prod.fst hab
+    simp only [SingularMayerVietoris.leftHomologyMap_apply] at h
+    change
+      SingularMayerVietoris.singularHomologyMap i 0 a =
+        SingularMayerVietoris.singularHomologyMap i 0 b at h
+    exact h
+  have hg :
+    SingularMayerVietoris.singularHomologyMap g 0 a =
+      SingularMayerVietoris.singularHomologyMap g 0 b := by
+    dsimp [g]
+    rw [PeriodTorusHigherHomology.singularHomologyMap_comp]
+    exact congrArg (SingularMayerVietoris.singularHomologyMap e.toFun 0) hi
+  apply
+    (PeriodTorusHigherHomology.connectedHomologyZeroEquiv
+        (overlapRegion C ε hε (1 / 2))).injective
+  have hn :=
+    congrArg (PeriodTorusHigherHomology.connectedHomologyZeroEquiv (centralBoundary C ε hε)) hg
+  exact
+    (PeriodTorusHigherHomology.connectedHomologyZeroEquiv_natural g a).symm.trans
+      (hn.trans (PeriodTorusHigherHomology.connectedHomologyZeroEquiv_natural g b))
+
+private theorem CuspCentralHomology.halfCoverRightHomologyOne_surjective
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    Function.Surjective
+      (SingularMayerVietoris.rightHomologyMap (outerRegion C ε hε (1 / 2)) (innerRegion C ε hε)
+        1) := by
+  let hU := outerRegion_isOpen C ε hε hε1 hC hR (1 / 2)
+  let hV := innerRegion_isOpen C ε hε hε1 hC hR
+  let hc := outerRegion_union_innerRegion C ε hε (1 / 2) (by norm_num)
+  intro a
+  have hz :
+    SingularMayerVietoris.connectingHomomorphism (outerRegion C ε hε (1 / 2)) (innerRegion C ε hε)
+        hU hV hc 0 a =
+      0 := by
+    apply halfCoverLeftHomologyZero_injective C ε hε hε1 hC hR
+    have h :=
+      LinearMap.congr_fun
+        (SingularMayerVietoris.connectingHomomorphism_comp_left (outerRegion C ε hε (1 / 2))
+          (innerRegion C ε hε) hU hV hc 0)
+        a
+    simpa only [LinearMap.comp_apply, LinearMap.zero_apply, map_zero] using h
+  have hm :
+    a ∈
+      LinearMap.ker
+        (SingularMayerVietoris.connectingHomomorphism (outerRegion C ε hε (1 / 2))
+          (innerRegion C ε hε) hU hV hc 0) :=
+    hz
+  rw [←
+    SingularMayerVietoris.exact_at_ambient (outerRegion C ε hε (1 / 2)) (innerRegion C ε hε) hU hV
+      hc 0] at hm
+  exact hm
+
+private theorem CuspCentralHomology.innerRegionInclusion_homology_eq_zero
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (innerRegionInclusion C ε hε) (n + 1) = 0 :=
+  singularHomologyMap_eq_zero_of_nullhomotopic _
+    (innerRegionInclusion_nullhomotopic C ε hε hε1 hC hR) (n + 1) (Nat.succ_ne_zero n)
+
+private theorem CuspCentralHomology.centralBoundaryInclusion_homology_one_surjective
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    Function.Surjective
+      (SingularMayerVietoris.singularHomologyMap (centralBoundaryInclusion C ε hε) 1) := by
+  let e := outerRegionBoundaryHomotopyEquiv C ε hε (1 / 2) (by norm_num) (by norm_num) hε1 hC hR
+  let E := PeriodTorusHigherHomology.homotopyEquivHomologyEquiv e 1
+  have he :
+    (SingularMayerVietoris.subtypeInclusion (outerRegion C ε hε (1 / 2))).comp e.symm.toFun =
+      centralBoundaryInclusion C ε hε := by
+    apply ContinuousMap.ext
+    intro q
+    rfl
+  intro a
+  obtain ⟨⟨x, y⟩, hxy⟩ := halfCoverRightHomologyOne_surjective C ε hε hε1 hC hR a
+  refine ⟨E x, ?_⟩
+  rw [← he, PeriodTorusHigherHomology.singularHomologyMap_comp]
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (SingularMayerVietoris.subtypeInclusion (outerRegion C ε hε (1 / 2))) 1 (E.symm (E x)) =
+      a
+  rw [E.symm_apply_apply]
+  have hv :
+    SingularMayerVietoris.singularHomologyMap
+        (SingularMayerVietoris.subtypeInclusion (innerRegion C ε hε)) 1 =
+      0 :=
+    innerRegionInclusion_homology_eq_zero C ε hε hε1 hC hR 0
+  simpa only [SingularMayerVietoris.rightHomologyMap_apply, hv, LinearMap.zero_apply,
+    add_zero] using hxy
+
+private theorem CuspCentralHomology.centralBoundaryInclusion_homology_one_injective
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    Function.Injective
+      (SingularMayerVietoris.singularHomologyMap (centralBoundaryInclusion C ε hε) 1) := by
+  let := centralSingularH1_finite C ε hε hC
+  let i :=
+    (centralBoundaryHomologyOneEquiv C ε hε hε1 hC hR).trans
+      (centralSingularH1Equiv C ε hε hC).symm
+  exact
+    IsNoetherian.injective_of_surjective_of_injective i.toLinearMap
+      (SingularMayerVietoris.singularHomologyMap (centralBoundaryInclusion C ε hε) 1) i.injective
+      (centralBoundaryInclusion_homology_one_surjective C ε hε hε1 hC hR)
+
+private theorem
+    CuspCentralHomology.boundaryLoop_homology_one_eq_zero (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    SingularMayerVietoris.singularHomologyMap (boundaryLoop C ε hε) 1 = 0 := by
+  have hzero :=
+    singularHomologyMap_eq_zero_of_nullhomotopic _
+      (centralBoundaryInclusion_comp_boundaryLoop_nullhomotopic C ε hε) 1 (by decide)
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp] at hzero
+  apply LinearMap.ext
+  intro a
+  apply centralBoundaryInclusion_homology_one_injective C ε hε hε1 hC hR
+  simpa only [LinearMap.comp_apply, LinearMap.zero_apply, map_zero] using
+    LinearMap.congr_fun hzero a
+
+@[simp]
+private theorem
+    CuspCentralHomology.centralCollapseMap_branchCount (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (p : CuspCollapse.PhasePositiveSpace) :
+    CuspQuotient.branchCount C ε (CuspCollapse.centralCollapseMap C ε hε p).1 =
+      ToricSpace.branchCount (p.2.1 : ToricSpace.Space) := by
+  change ToricSpace.branchCount (ToricSpace.compactFibreAction p.1 (p.2.1 : ToricSpace.Space)) = _
+  exact ToricSpace.branchCount_torusAction _ _
+
+@[simp]
+private theorem
+    CuspCentralHomology.fundamentalCellMap_branchCount (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (p : FundamentalCell) :
+    CuspQuotient.branchCount C ε (fundamentalCellMap C ε hε p).1 =
+      ToricSpace.branchCount
+        ((CuspHoneycomb.honeycombHomeomorph (C 0) (p.2 : (CuspHoneycombTiling.Plane))).1 :
+          ToricSpace.Space) :=
+  centralCollapseMap_branchCount C ε hε
+    (p.1, CuspHoneycomb.honeycombHomeomorph (C 0) (p.2 : (CuspHoneycombTiling.Plane)))
+
+private theorem
+    CuspCentralHomology.edgeArcPositive_branchCount_ge_two (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) (t : unitInterval) :
+    2 ≤ ToricSpace.branchCount ((edgeArcPositive C₀ k t).1 : ToricSpace.Space) := by
+  by_cases ht0 : t = 0
+  · subst t
+    rw [edgeArcPositive_zero_branchCount]
+    decide
+  by_cases ht1 : t = 1
+  · subst t
+    rw [edgeArcPositive_one_branchCount]
+    decide
+  rw [edgeArcPositive_branchCount C₀ k t ht0 ht1]
+
+private theorem
+    CuspCentralHomology.mem_centralBoundary_iff_branchCount (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (q : CuspRetraction.QuotientCentralFibre C ε) :
+    q ∈ centralBoundary C ε hε ↔ 2 ≤ CuspQuotient.branchCount C ε q.1 := by
+  constructor
+  · intro hq
+    obtain ⟨k, t, u, rfl⟩ := (mem_centralBoundary_iff_edgeArc C ε hε q).mp hq
+    rw [centralCollapseMap_branchCount]
+    exact edgeArcPositive_branchCount_ge_two (C 0) k t
+  · intro hq
+    obtain ⟨p, rfl⟩ := fundamentalCellMap_surjective C ε hε q
+    apply (fundamentalCellMap_mem_centralBoundary_iff C ε hε p).mpr
+    by_contra hp
+    have hi : (p.2 : (CuspHoneycombTiling.Plane)) ∈ interior CuspHoneycombTiling.baseCell :=
+      (mem_interior_iff_notMem_frontier p.2.2).mpr hp
+    have hb :
+      ToricSpace.branchCount
+          ((CuspHoneycomb.honeycombHomeomorph (C 0) (p.2 : (CuspHoneycombTiling.Plane))).1 :
+            ToricSpace.Space) =
+        1 :=
+      (CuspHoneycomb.honeycombHomeomorph_branchCount_eq_one_iff (C 0)
+            (p.2 : (CuspHoneycombTiling.Plane))).mpr
+        ⟨0, by simpa only [CuspHoneycombTiling.cell_zero] using hi⟩
+    rw [fundamentalCellMap_branchCount, hb] at hq
+    exact (by decide : ¬2 ≤ (1 : ℕ)) hq
+
+private def CuspCentralHomology.phaseMultiply (u : ToricSpace.CompactFibreTorus)
+    (p : CuspCollapse.PhasePositiveSpace) : CuspCollapse.PhasePositiveSpace :=
+  (u * p.1, p.2)
+
+private theorem
+    CuspCentralHomology.centralCollapseRelation_phaseMultiply (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (u : ToricSpace.CompactFibreTorus) (p q : CuspCollapse.PhasePositiveSpace)
+    (h : CuspCollapse.centralCollapseRelation C₀ p q) :
+    CuspCollapse.centralCollapseRelation C₀ (phaseMultiply u p) (phaseMultiply u q) := by
+  obtain ⟨v, hv, hu⟩ := h
+  refine ⟨v, hv, ?_⟩
+  change
+    (u * p.1)⁻¹ * (CuspCollapse.deckFibrePhase C₀ v * (u * q.1)) ∈
+      MulAction.stabilizer ToricSpace.CompactFibreTorus (p.2.1 : ToricSpace.Space)
+  have he :
+    (u * p.1)⁻¹ * (CuspCollapse.deckFibrePhase C₀ v * (u * q.1)) =
+      p.1⁻¹ * (CuspCollapse.deckFibrePhase C₀ v * q.1) := by
+    calc
+      _ = p.1⁻¹ * ((u⁻¹ * u) * (CuspCollapse.deckFibrePhase C₀ v * q.1)) := by
+        simp only [mul_inv_rev]
+        ac_rfl
+      _ = p.1⁻¹ * (CuspCollapse.deckFibrePhase C₀ v * q.1) := by rw [inv_mul_cancel, one_mul]
+  rw [he]
+  exact hu
+
+private def CuspCentralHomology.phaseMultiplyModel (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (u : ToricSpace.CompactFibreTorus) :
+    CuspCollapse.CentralCollapseModel C₀ → CuspCollapse.CentralCollapseModel C₀ :=
+  Quotient.map' (phaseMultiply u) (centralCollapseRelation_phaseMultiply C₀ u)
+
+private def
+    CuspCentralHomology.centralPhaseAction (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (u : ToricSpace.CompactFibreTorus) (x : CuspRetraction.QuotientCentralFibre C ε) :
+    CuspRetraction.QuotientCentralFibre C ε :=
+  CuspCollapse.centralCollapseModelMap C ε hε
+    (phaseMultiplyModel (C 0) u ((CuspCollapse.centralCollapseEquiv C ε hε).symm x))
+
+@[simp]
+private theorem
+    CuspCentralHomology.centralPhaseAction_collapse (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (u : ToricSpace.CompactFibreTorus) (p : CuspCollapse.PhasePositiveSpace) :
+    centralPhaseAction C ε hε u (CuspCollapse.centralCollapseMap C ε hε p) =
+      CuspCollapse.centralCollapseMap C ε hε (u * p.1, p.2) := by
+  unfold centralPhaseAction
+  rw [CuspCollapse.centralCollapseEquiv_symm_map]
+  rfl
+
+@[simp]
+private theorem
+    CuspCentralHomology.centralPhaseAction_branchCount (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (u : ToricSpace.CompactFibreTorus)
+    (x : CuspRetraction.QuotientCentralFibre C ε) :
+    CuspQuotient.branchCount C ε (centralPhaseAction C ε hε u x).1 =
+      CuspQuotient.branchCount C ε x.1 := by
+  obtain ⟨p, rfl⟩ := CuspCollapse.centralCollapseMap_surjective C ε hε x
+  rw [centralPhaseAction_collapse, centralCollapseMap_branchCount, centralCollapseMap_branchCount]
+
+private theorem
+    CuspCentralHomology.centralPhaseAction_mem_boundary_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (u : ToricSpace.CompactFibreTorus)
+    (x : CuspRetraction.QuotientCentralFibre C ε) :
+    centralPhaseAction C ε hε u x ∈ centralBoundary C ε hε ↔ x ∈ centralBoundary C ε hε := by
+  rw [mem_centralBoundary_iff_branchCount, centralPhaseAction_branchCount,
+    mem_centralBoundary_iff_branchCount]
+
+private def CuspCentralHomology.boundaryPhaseAction (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (u : ToricSpace.CompactFibreTorus) (x : centralBoundary C ε hε) :
+    centralBoundary C ε hε :=
+  ⟨centralPhaseAction C ε hε u x.1, (centralPhaseAction_mem_boundary_iff C ε hε u x.1).mpr x.2⟩
+
+private theorem CuspCentralHomology.centralPhaseAction_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε)) :
+    Continuous
+      (fun p : ToricSpace.CompactFibreTorus × CuspRetraction.QuotientCentralFibre C ε =>
+        centralPhaseAction C ε hε p.1 p.2) := by
+  apply (CuspCollapse.centralCollapseMap_isQuotientMap C ε hε hC).continuous_lift_prod_right
+  have hm :
+    Continuous
+      (fun p : ToricSpace.CompactFibreTorus × CuspCollapse.PhasePositiveSpace =>
+        (p.1 * p.2.1, p.2.2)) :=
+    (continuous_fst.mul continuous_snd.fst).prodMk continuous_snd.snd
+  exact
+    ((CuspCollapse.centralCollapseMap_continuous C ε hε).comp hm).congr
+      (fun p => (centralPhaseAction_collapse C ε hε p.1 p.2).symm)
+
+private theorem
+    CuspCentralHomology.boundaryPhaseAction_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε)) :
+    Continuous
+      (fun p : ToricSpace.CompactFibreTorus × centralBoundary C ε hε =>
+        boundaryPhaseAction C ε hε p.1 p.2) :=
+  ((centralPhaseAction_continuous C ε hε hC).comp
+        (continuous_fst.prodMk (continuous_subtype_val.comp continuous_snd))).subtype_mk
+    _
+
+private def CuspCentralHomology.boundaryPhaseActionMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε)) :
+    C(ToricSpace.CompactFibreTorus × centralBoundary C ε hε, centralBoundary C ε hε) :=
+  ⟨fun p => boundaryPhaseAction C ε hε p.1 p.2, boundaryPhaseAction_continuous C ε hε hC⟩
+
+@[simp]
+private theorem CuspCentralHomology.centralPhaseAction_honeycombCollapseMap
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (u : ToricSpace.CompactFibreTorus)
+    (p : CuspHoneycomb.PhasePlane) :
+    centralPhaseAction C ε hε u (CuspHoneycomb.honeycombCollapseMap C ε hε p) =
+      CuspHoneycomb.honeycombCollapseMap C ε hε (u * p.1, p.2) :=
+  centralPhaseAction_collapse C ε hε u (p.1, CuspHoneycomb.honeycombHomeomorph (C 0) p.2)
+
+@[simp]
+private theorem
+    CuspCentralHomology.boundaryPhaseAction_boundaryCellMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (u : ToricSpace.CompactFibreTorus) (p : BoundaryPhaseCell) :
+    boundaryPhaseAction C ε hε u (boundaryCellMap C ε hε p) =
+      boundaryCellMap C ε hε (u * p.1, p.2) := by
+  apply Subtype.ext
+  exact centralPhaseAction_honeycombCollapseMap C ε hε u (p.1, p.2)
+
+private theorem CuspCentralHomology.boundaryPhaseAction_circleBoundaryCellMap
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (u : ToricSpace.CompactFibreTorus)
+    (p : ToricSpace.CompactFibreTorus × Circle) :
+    boundaryPhaseAction C ε hε u (circleBoundaryCellMap C ε hε p) =
+      circleBoundaryCellMap C ε hε (u * p.1, p.2) := by
+  rw [circleBoundaryCellMap_apply, boundaryPhaseAction_boundaryCellMap,
+    circleBoundaryCellMap_apply]
+
+private theorem
+    CuspCentralHomology.circleBoundaryCellMap_phaseAction (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (u : ToricSpace.CompactFibreTorus) (z : Circle) :
+    circleBoundaryCellMap C ε hε (u, z) = boundaryPhaseAction C ε hε u (boundaryLoop C ε hε z) := by
+  rw [boundaryLoop_apply, boundaryPhaseAction_circleBoundaryCellMap, mul_one]
+
+private theorem CuspCentralHomology.circleBoundaryCellMap_eq_phaseAction
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε)) :
+    circleBoundaryCellMap C ε hε =
+      (boundaryPhaseActionMap C ε hε hC).comp
+        ((ContinuousMap.id ToricSpace.CompactFibreTorus).prodMap (boundaryLoop C ε hε)) := by
+  apply ContinuousMap.ext
+  intro p
+  exact circleBoundaryCellMap_phaseAction C ε hε p.1 p.2
+
+private def CuspCentralHomology.circleCoordinateHomeomorph : Circle ≃ₜ AddCircle (1 : ℝ) :=
+  (AddCircle.homeomorphCircle (T := (1 : ℝ)) one_ne_zero).symm
+
+@[simp]
+private theorem CuspCentralHomology.circleCoordinateHomeomorph_symm_apply (x : AddCircle (1 : ℝ)) :
+    circleCoordinateHomeomorph.symm x = AddCircle.toCircle x :=
+  AddCircle.homeomorphCircle_apply one_ne_zero x
+
+private theorem CuspCentralHomology.circleCoordinateHomeomorph_mul (u v : Circle) :
+    circleCoordinateHomeomorph (u * v) =
+      circleCoordinateHomeomorph u + circleCoordinateHomeomorph v := by
+  apply circleCoordinateHomeomorph.symm.injective
+  rw [Homeomorph.symm_apply_apply, circleCoordinateHomeomorph_symm_apply, AddCircle.toCircle_add,
+    ← circleCoordinateHomeomorph_symm_apply, ← circleCoordinateHomeomorph_symm_apply,
+    Homeomorph.symm_apply_apply, Homeomorph.symm_apply_apply]
+
+private theorem CuspCentralHomology.circleCoordinateHomeomorph_zpow (u : Circle) (n : ℤ) :
+    circleCoordinateHomeomorph (u ^ n) = n • circleCoordinateHomeomorph u := by
+  apply circleCoordinateHomeomorph.symm.injective
+  rw [Homeomorph.symm_apply_apply, circleCoordinateHomeomorph_symm_apply,
+    AddCircle.toCircle_zsmul, ← circleCoordinateHomeomorph_symm_apply,
+    Homeomorph.symm_apply_apply]
+
+private theorem CuspCentralHomology.circleCoordinateHomeomorph_exp (x : ℝ) :
+    circleCoordinateHomeomorph (Circle.exp (2 * Real.pi * x)) = (x : AddCircle (1 : ℝ)) := by
+  apply circleCoordinateHomeomorph.symm.injective
+  rw [Homeomorph.symm_apply_apply, circleCoordinateHomeomorph_symm_apply,
+    AddCircle.toCircle_apply_mk, div_one]
+
+private def CuspCentralHomology.compactFibreTorusHomeomorph :
+    ToricSpace.CompactFibreTorus ≃ₜ PeriodTorusHigherHomology.ProductTorus 2 :=
+  Homeomorph.piCongrRight (fun _ : Fin 2 => circleCoordinateHomeomorph)
+
+private theorem
+    CuspCentralHomology.compactFibreTorusHomeomorph_mul (u v : ToricSpace.CompactFibreTorus) :
+    compactFibreTorusHomeomorph (u * v) =
+      compactFibreTorusHomeomorph u + compactFibreTorusHomeomorph v := by
+  funext i
+  exact circleCoordinateHomeomorph_mul (u i) (v i)
+
+private theorem CuspCentralHomology.compactFibreTorusHomeomorph_exp (x : Fin 2 → ℝ) :
+    compactFibreTorusHomeomorph (fun i => Circle.exp (2 * Real.pi * x i)) =
+      PeriodTorusHigherHomology.coordinateProjection 2 x := by
+  funext i
+  exact circleCoordinateHomeomorph_exp (x i)
+
+private def CuspCentralHomology.productTorusLastHomeomorph (n : ℕ) :
+    PeriodTorusHigherHomology.ProductTorus (n + 1) ≃ₜ
+      PeriodTorusHigherHomology.ProductTorus n × AddCircle (1 : ℝ)
+    where
+  toFun x := (fun i => x i.castSucc, x (Fin.last n))
+  invFun p := Fin.snoc p.1 p.2
+  left_inv x := Fin.snoc_init_self x
+  right_inv p := by simp only [Fin.snoc_castSucc, Fin.snoc_last]
+  continuous_toFun :=
+    (continuous_pi (fun i => continuous_apply i.castSucc)).prodMk (continuous_apply (Fin.last n))
+  continuous_invFun := by
+    apply continuous_pi
+    intro i
+    refine Fin.lastCases ?_ (fun j => ?_) i
+    · simpa only [Fin.snoc_last] using
+        (continuous_snd :
+          Continuous
+            (fun p : PeriodTorusHigherHomology.ProductTorus n × AddCircle (1 : ℝ) => p.2))
+    · simpa only [Fin.snoc_castSucc, Function.comp_def] using
+        ((continuous_apply j).comp continuous_fst :
+          Continuous
+            (fun p : PeriodTorusHigherHomology.ProductTorus n × AddCircle (1 : ℝ) => p.1 j))
+
+private def CuspCentralHomology.fibreTorusCircleHomeomorph :
+    (ToricSpace.CompactFibreTorus × Circle) ≃ₜ PeriodTorusHigherHomology.ProductTorus 3 :=
+  (compactFibreTorusHomeomorph.prodCongr circleCoordinateHomeomorph).trans
+    (productTorusLastHomeomorph 2).symm
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def CuspCentralHomology.circleParametrizedMap {X D : Type} [TopologicalSpace X]
+    [TopologicalSpace D] (a : C(X × D, D)) (α : C(_root_.Circle, D)) : C(X × _root_.Circle, D) :=
+  a.comp ((ContinuousMap.id X).prodMap α)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def CuspCentralHomology.circleParametrizedOrbit {X D : Type} [TopologicalSpace X]
+    [TopologicalSpace D] (a : C(X × D, D)) (α : C(_root_.Circle, D)) : C(X, D) :=
+  a.comp ((ContinuousMap.id X).prodMk (ContinuousMap.const X (α 1)))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def CuspCentralHomology.circleParametrizedSourceHomeomorph (X : Type) [TopologicalSpace X] :
+    (AddCircle (1 : ℝ) × X) ≃ₜ (X × _root_.Circle) :=
+  (circleCoordinateHomeomorph.symm.prodCongr (Homeomorph.refl X)).trans
+    (Homeomorph.prodComm _root_.Circle X)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def CuspCentralHomology.additiveCircleParametrizedMap {X D : Type} [TopologicalSpace X]
+    [TopologicalSpace D] (a : C(X × D, D)) (β : C(AddCircle (1 : ℝ), D)) :
+    C(AddCircle (1 : ℝ) × X, D) :=
+  (a.comp (Homeomorph.prodComm D X : C(D × X, X × D))).comp (β.prodMap (ContinuousMap.id X))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    CuspCentralHomology.circleParametrizedMap_comp_source {X D : Type} [TopologicalSpace X]
+    [TopologicalSpace D] (a : C(X × D, D)) (α : C(_root_.Circle, D)) :
+    (circleParametrizedMap a α).comp
+        (circleParametrizedSourceHomeomorph X : C(AddCircle (1 : ℝ) × X, X × _root_.Circle)) =
+      additiveCircleParametrizedMap a
+        (α.comp (circleCoordinateHomeomorph.symm : C(AddCircle (1 : ℝ), _root_.Circle))) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem CuspCentralHomology.parameterMap_positiveCircleCross_eq_zero {X D : Type}
+    [TopologicalSpace X] [TopologicalSpace D] (β : C(AddCircle (1 : ℝ), D))
+    (hβ : SingularMayerVietoris.singularHomologyMap β 1 = 0) (n : ℕ)
+    (b : SingularMayerVietoris.SingularHomology X n) :
+    SingularMayerVietoris.singularHomologyMap (β.prodMap (ContinuousMap.id X)) (n + 1)
+        (PeriodTorusHigherHomology.positiveCircleCross X n b) =
+      0 := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductHomology_natural β (ContinuousMap.id X) n
+      (FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop) b
+  change
+    SingularMayerVietoris.singularHomologyMap (β.prodMap (ContinuousMap.id X)) (n + 1)
+        (PeriodTorusHigherHomology.positiveCircleCross X n b) =
+      PeriodTorusHigherHomology.crossProductHomology D X n
+        (SingularMayerVietoris.singularHomologyMap β 1
+          (FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop))
+        (SingularMayerVietoris.singularHomologyMap (ContinuousMap.id X) n b) at h
+  rw [hβ, LinearMap.zero_apply, map_zero, LinearMap.zero_apply] at h
+  exact h
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem CuspCentralHomology.additiveCircleParametrizedHomologyMap_eq_zero {X D : Type}
+    [TopologicalSpace X] [TopologicalSpace D] (a : C(X × D, D)) (β : C(AddCircle (1 : ℝ), D))
+    (hβ : SingularMayerVietoris.singularHomologyMap β 1 = 0) (n : ℕ)
+    (hsection :
+      SingularMayerVietoris.singularHomologyMap
+          ((additiveCircleParametrizedMap a β).comp
+            (PeriodTorusHigherHomology.CircleTopology.productSection X))
+          (n + 1) =
+        0) :
+    SingularMayerVietoris.singularHomologyMap (additiveCircleParametrizedMap a β) (n + 1) = 0 := by
+  have hs (c : SingularMayerVietoris.SingularHomology X (n + 1)) :
+    SingularMayerVietoris.singularHomologyMap (additiveCircleParametrizedMap a β) (n + 1)
+        (PeriodTorusHigherHomology.circleSectionHomology X (n + 1) c) =
+      0 := by
+    change
+      ((SingularMayerVietoris.singularHomologyMap (additiveCircleParametrizedMap a β)
+                (n + 1)).comp
+            (SingularMayerVietoris.singularHomologyMap
+              (PeriodTorusHigherHomology.CircleTopology.productSection X) (n + 1)))
+          c =
+        0
+    rw [← PeriodTorusHigherHomology.singularHomologyMap_comp, hsection, LinearMap.zero_apply]
+  have hc (c : SingularMayerVietoris.SingularHomology X n) :
+    SingularMayerVietoris.singularHomologyMap (additiveCircleParametrizedMap a β) (n + 1)
+        (PeriodTorusHigherHomology.positiveCircleCross X n c) =
+      0 := by
+    rw [additiveCircleParametrizedMap, PeriodTorusHigherHomology.singularHomologyMap_comp,
+      LinearMap.comp_apply, parameterMap_positiveCircleCross_eq_zero β hβ, map_zero]
+  apply LinearMap.ext
+  intro c
+  change
+    SingularMayerVietoris.singularHomologyMap (additiveCircleParametrizedMap a β) (n + 1) c = 0
+  obtain ⟨p, rfl⟩ := (PeriodTorusHigherHomology.circleProductHomologyEquiv X n).symm.surjective c
+  rw [PeriodTorusHigherHomology.circleProductHomologyEquiv_symm_eq_section_add_cross, map_add, hs,
+    hc, add_zero]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem CuspCentralHomology.circleParametrizedHomologyMap_eq_zero {X D : Type}
+    [TopologicalSpace X] [TopologicalSpace D] (a : C(X × D, D)) (α : C(_root_.Circle, D))
+    (hα : SingularMayerVietoris.singularHomologyMap α 1 = 0) (n : ℕ)
+    (horbit :
+      SingularMayerVietoris.singularHomologyMap (circleParametrizedOrbit a α) (n + 1) = 0) :
+    SingularMayerVietoris.singularHomologyMap (circleParametrizedMap a α) (n + 1) = 0 := by
+  let β : C(AddCircle (1 : ℝ), D) :=
+    α.comp (circleCoordinateHomeomorph.symm : C(AddCircle (1 : ℝ), _root_.Circle))
+  have hβ : SingularMayerVietoris.singularHomologyMap β 1 = 0 := by
+    rw [show β = α.comp (circleCoordinateHomeomorph.symm : C(AddCircle (1 : ℝ), _root_.Circle))
+        from rfl,
+      PeriodTorusHigherHomology.singularHomologyMap_comp, hα, LinearMap.zero_comp]
+  have hsectionMap :
+    (additiveCircleParametrizedMap a β).comp
+        (PeriodTorusHigherHomology.CircleTopology.productSection X) =
+      circleParametrizedOrbit a α := by
+    apply ContinuousMap.ext
+    intro x
+    change a (x, α (circleCoordinateHomeomorph.symm 0)) = a (x, α 1)
+    rw [circleCoordinateHomeomorph_symm_apply, AddCircle.toCircle_zero]
+  have hzero :
+    SingularMayerVietoris.singularHomologyMap (additiveCircleParametrizedMap a β) (n + 1) = 0 :=
+    additiveCircleParametrizedHomologyMap_eq_zero a β hβ n (by rw [hsectionMap]; exact horbit)
+  have hcomp :
+    (SingularMayerVietoris.singularHomologyMap (circleParametrizedMap a α) (n + 1)).comp
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv (circleParametrizedSourceHomeomorph X)
+            (n + 1)).toLinearMap =
+      0 := by
+    rw [PeriodTorusHigherHomology.homeomorphHomologyEquiv_toLinearMap, ←
+      PeriodTorusHigherHomology.singularHomologyMap_comp, circleParametrizedMap_comp_source]
+    exact hzero
+  apply LinearMap.ext
+  intro c
+  obtain ⟨d, rfl⟩ :=
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv (circleParametrizedSourceHomeomorph X)
+          (n + 1)).surjective
+      c
+  exact LinearMap.congr_fun hcomp d
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    CuspCentralHomology.circleParametrizedHomologyMap_eq_zero_of_nullhomotopic {X D : Type}
+    [TopologicalSpace X] [TopologicalSpace D] (a : C(X × D, D)) (α : C(_root_.Circle, D))
+    (hα : SingularMayerVietoris.singularHomologyMap α 1 = 0) (n : ℕ)
+    (horbit : (circleParametrizedOrbit a α).Nullhomotopic) :
+    SingularMayerVietoris.singularHomologyMap (circleParametrizedMap a α) (n + 1) = 0 :=
+  circleParametrizedHomologyMap_eq_zero a α hα n
+    (singularHomologyMap_eq_zero_of_nullhomotopic _ horbit (n + 1) (Nat.succ_ne_zero n))
+
+private theorem CuspCentralHomology.boundaryPhaseAction_parametrizedOrbit
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε)) :
+    circleParametrizedOrbit (boundaryPhaseActionMap C ε hε hC) (boundaryLoop C ε hε) =
+      boundaryPhaseOrbit C ε hε := by
+  apply ContinuousMap.ext
+  intro u
+  exact (circleBoundaryCellMap_phaseAction C ε hε u 1).symm
+
+private theorem CuspCentralHomology.circleBoundaryCellMap_homology_eq_zero
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (circleBoundaryCellMap C ε hε) (n + 1) = 0 := by
+  rw [circleBoundaryCellMap_eq_phaseAction C ε hε hC]
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (circleParametrizedMap (boundaryPhaseActionMap C ε hε hC) (boundaryLoop C ε hε)) (n + 1) =
+      0
+  apply circleParametrizedHomologyMap_eq_zero_of_nullhomotopic
+  · exact boundaryLoop_homology_one_eq_zero C ε hε hε1 hC hR
+  · rw [boundaryPhaseAction_parametrizedOrbit]
+    exact boundaryPhaseOrbit_nullhomotopic C ε hε
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def CuspCentralHomology.rightCircleSection (X : Type) [TopologicalSpace X] :
+    C(X, X × _root_.Circle) :=
+  (ContinuousMap.id X).prodMk (ContinuousMap.const X 1)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem CuspCentralHomology.rightCircleProjection_section (X : Type) [TopologicalSpace X]
+    (n : ℕ) :
+    (SingularMayerVietoris.singularHomologyMap (ContinuousMap.fst : C(X × _root_.Circle, X))
+            n).comp
+        (SingularMayerVietoris.singularHomologyMap (rightCircleSection X) n) =
+      LinearMap.id := by
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp]
+  exact PeriodTorusHigherHomology.singularHomologyMap_id X n
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem CuspCentralHomology.rightCircleProjection_surjective_allDegrees (X : Type)
+    [TopologicalSpace X] (n : ℕ) :
+    Function.Surjective
+      (SingularMayerVietoris.singularHomologyMap (ContinuousMap.fst : C(X × _root_.Circle, X))
+        n) := by
+  intro a
+  exact
+    ⟨SingularMayerVietoris.singularHomologyMap (rightCircleSection X) n a,
+      LinearMap.congr_fun (rightCircleProjection_section X n) a⟩
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem CuspCentralHomology.rightCircleProjection_surjective (X : Type) [TopologicalSpace X]
+    (n : ℕ) :
+    Function.Surjective
+      (SingularMayerVietoris.singularHomologyMap (ContinuousMap.fst : C(X × _root_.Circle, X))
+        (n + 1)) :=
+  rightCircleProjection_surjective_allDegrees X (n + 1)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    CuspCentralHomology.rightCircleProductHomologyEquiv (X : Type) [TopologicalSpace X] (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (X × _root_.Circle) (n + 1) ≃ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology X (n + 1) ×
+        SingularMayerVietoris.SingularHomology X n) :=
+  (PeriodTorusHigherHomology.homeomorphHomologyEquiv (circleParametrizedSourceHomeomorph X).symm
+        (n + 1)).trans
+    (PeriodTorusHigherHomology.circleProductHomologyEquiv X n)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem
+    CuspCentralHomology.rightCircleProductHomologyEquiv_fst (X : Type) [TopologicalSpace X]
+    (n : ℕ) (a : SingularMayerVietoris.SingularHomology (X × _root_.Circle) (n + 1)) :
+    (rightCircleProductHomologyEquiv X n a).1 =
+      SingularMayerVietoris.singularHomologyMap (ContinuousMap.fst : C(X × _root_.Circle, X))
+        (n + 1) a := by
+  change
+    PeriodTorusHigherHomology.circleProjectionHomology X (n + 1)
+        (SingularMayerVietoris.singularHomologyMap
+          ((circleParametrizedSourceHomeomorph X).symm :
+            C(X × _root_.Circle, AddCircle (1 : ℝ) × X))
+          (n + 1) a) =
+      _
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem CuspCentralHomology.rightCircleProductHomologyEquiv_symm_projection (X : Type)
+    [TopologicalSpace X] (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology X (n + 1) ×
+        SingularMayerVietoris.SingularHomology X n) :
+    SingularMayerVietoris.singularHomologyMap (ContinuousMap.fst : C(X × _root_.Circle, X))
+        (n + 1) ((rightCircleProductHomologyEquiv X n).symm a) =
+      a.1 := by rw [← rightCircleProductHomologyEquiv_fst, LinearEquiv.apply_symm_apply]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    CuspCentralHomology.rightCircleProjectionKernelEquiv (X : Type) [TopologicalSpace X] (n : ℕ) :
+    LinearMap.ker
+        (SingularMayerVietoris.singularHomologyMap (ContinuousMap.fst : C(X × _root_.Circle, X))
+          (n + 1)) ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology X n :=
+  ({    toFun a := (rightCircleProductHomologyEquiv X n a).2
+        invFun
+          b :=
+          ⟨(rightCircleProductHomologyEquiv X n).symm (0, b), by
+            rw [LinearMap.mem_ker, rightCircleProductHomologyEquiv_symm_projection]⟩
+        left_inv
+          a := by
+          apply Subtype.ext
+          apply (rightCircleProductHomologyEquiv X n).injective
+          rw [LinearEquiv.apply_symm_apply]
+          apply Prod.ext
+          · rw [rightCircleProductHomologyEquiv_fst]
+            exact a.property.symm
+          · rfl
+        right_inv
+          b := by
+          change
+            ((rightCircleProductHomologyEquiv X n)
+                  ((rightCircleProductHomologyEquiv X n).symm (0, b))).2 =
+              b
+          rw [LinearEquiv.apply_symm_apply]
+        map_add' a
+          b := by
+          change (rightCircleProductHomologyEquiv X n ((a : _) + b)).2 = _
+          rw [map_add]
+          rfl } :
+      LinearMap.ker
+          (SingularMayerVietoris.singularHomologyMap (ContinuousMap.fst : C(X × _root_.Circle, X))
+            (n + 1)) ≃+
+        SingularMayerVietoris.SingularHomology X n).toIntLinearEquiv
+
+private def CuspCentralHomology.compactFibreTorusHomologyEquiv (n : ℕ) :
+    SingularMayerVietoris.SingularHomology ToricSpace.CompactFibreTorus n ≃ₗ[ℤ]
+      PeriodTorusHigherHomology.binomialModule 2 n :=
+  (PeriodTorusHigherHomology.homeomorphHomologyEquiv compactFibreTorusHomeomorph n).trans
+    (PeriodTorusHigherHomology.productTorusHomologyEquiv 2 n)
+
+private def CuspCentralHomology.fibreTorusCircleHomologyEquiv (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (ToricSpace.CompactFibreTorus × Circle) n ≃ₗ[ℤ]
+      PeriodTorusHigherHomology.binomialModule 3 n :=
+  (PeriodTorusHigherHomology.homeomorphHomologyEquiv fibreTorusCircleHomeomorph n).trans
+    (PeriodTorusHigherHomology.productTorusHomologyEquiv 3 n)
+
+private def CuspCentralHomology.fibreTorusCircleHomologyThreeEquiv :
+    SingularMayerVietoris.SingularHomology (ToricSpace.CompactFibreTorus × Circle) 3 ≃ₗ[ℤ] ℤ :=
+  (fibreTorusCircleHomologyEquiv 3).trans (LinearEquiv.funUnique (Fin 1) ℤ ℤ)
+
+private theorem
+    CuspCentralHomology.compactFibreTorus_homology_subsingleton_of_lt {n : ℕ} (hn : 2 < n) :
+    Subsingleton (SingularMayerVietoris.SingularHomology ToricSpace.CompactFibreTorus n) := by
+  let := PeriodTorusHigherHomology.productTorus_homology_subsingleton_of_lt hn
+  exact
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv compactFibreTorusHomeomorph
+        n).injective.subsingleton
+
+private theorem CuspCentralHomology.compactFibreTorus_homology_subsingleton (n : ℕ) :
+    Subsingleton (SingularMayerVietoris.SingularHomology ToricSpace.CompactFibreTorus (n + 3)) :=
+  compactFibreTorus_homology_subsingleton_of_lt (by omega)
+
+private theorem
+    CuspCentralHomology.fibreTorusCircle_homology_subsingleton_of_lt {n : ℕ} (hn : 3 < n) :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology (ToricSpace.CompactFibreTorus × Circle) n) := by
+  let := PeriodTorusHigherHomology.productTorus_homology_subsingleton_of_lt hn
+  exact
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv fibreTorusCircleHomeomorph
+        n).injective.subsingleton
+
+private theorem CuspCentralHomology.fibreTorusCircle_homology_subsingleton (n : ℕ) :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology (ToricSpace.CompactFibreTorus × Circle) (n + 4)) :=
+  fibreTorusCircle_homology_subsingleton_of_lt (by omega)
+
+private def
+    CuspCentralHomology.outerRegionSuspensionHomotopyEquiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    outerRegion C ε hε a ≃ₕ ThreeCircleSuspension :=
+  (outerRegionBoundaryHomotopyEquiv C ε hε a ha ha1 hε1 hC hR).trans
+    (centralBoundarySuspensionHomeomorph C ε hε hε1 hC hR).toHomotopyEquiv
+
+
+private def
+    CuspCentralHomology.overlapRegionHomologyThreeEquiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    SingularMayerVietoris.SingularHomology (overlapRegion C ε hε a) 3 ≃ₗ[ℤ] ℤ :=
+  (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+        (overlapCircleHomotopyEquiv C ε hε hε1 hC hR a ha ha1) 3).trans
+    fibreTorusCircleHomologyThreeEquiv
+
+private theorem
+    CuspCentralHomology.outerRegion_homology_subsingleton (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (n : ℕ) :
+    Subsingleton (SingularMayerVietoris.SingularHomology (outerRegion C ε hε a) (n + 3)) := by
+  let := threeCircleSuspension_homology_subsingleton n
+  exact
+    (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+        (outerRegionSuspensionHomotopyEquiv C ε hε hε1 hC hR a ha ha1)
+        (n + 3)).injective.subsingleton
+
+private theorem
+    CuspCentralHomology.innerRegion_homology_subsingleton (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (n : ℕ) :
+    Subsingleton (SingularMayerVietoris.SingularHomology (innerRegion C ε hε) (n + 3)) := by
+  let := compactFibreTorus_homology_subsingleton n
+  exact
+    (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+        (innerRegionHomotopyEquiv C ε hε hε1 hC hR) (n + 3)).injective.subsingleton
+
+private theorem
+    CuspCentralHomology.overlapRegion_homology_subsingleton (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (n : ℕ) :
+    Subsingleton (SingularMayerVietoris.SingularHomology (overlapRegion C ε hε a) (n + 4)) := by
+  let := fibreTorusCircle_homology_subsingleton n
+  exact
+    (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+        (overlapCircleHomotopyEquiv C ε hε hε1 hC hR a ha ha1) (n + 4)).injective.subsingleton
+
+private def CuspCentralHomology.middleInnerHomologyEquiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (innerRegion C ε hε) n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology ToricSpace.CompactFibreTorus n :=
+  PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (innerRegionHomotopyEquiv C ε hε hε1 hC hR)
+    n
+
+private def
+    CuspCentralHomology.middleOverlapHomologyEquiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (overlapRegion C ε hε a) n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (ToricSpace.CompactFibreTorus × Circle) n :=
+  PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+    (overlapCircleHomotopyEquiv C ε hε hε1 hC hR a ha ha1) n
+
+private theorem
+    CuspCentralHomology.overlapIntoOuter_homology_eq_zero (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (overlapIntoOuter C ε hε a) (n + 1) = 0 := by
+  have hm :=
+    congrArg
+      (fun f : C((overlapRegion C ε hε a), centralBoundary C ε hε) =>
+        SingularMayerVietoris.singularHomologyMap f (n + 1))
+      (overlapIntoOuter_boundary_map C ε hε hε1 hC hR a ha ha1)
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodTorusHigherHomology.singularHomologyMap_comp,
+    circleBoundaryCellMap_homology_eq_zero C ε hε hε1 hC hR n] at hm
+  apply LinearMap.ext
+  intro z
+  apply
+    (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+        (outerRegionBoundaryHomotopyEquiv C ε hε a ha ha1 hε1 hC hR) (n + 1)).injective
+  simpa only [PeriodTorusHigherHomology.homotopyEquivHomologyEquiv_apply, LinearMap.comp_apply,
+    LinearMap.zero_apply, map_zero] using LinearMap.congr_fun hm z
+
+private theorem CuspCentralHomology.middleInnerProjection_natural (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (n : ℕ) :
+    (middleInnerHomologyEquiv C ε hε hε1 hC hR n).toLinearMap.comp
+        (SingularMayerVietoris.singularHomologyMap (overlapIntoInner C ε hε a) n) =
+      (SingularMayerVietoris.singularHomologyMap
+            (ContinuousMap.fst :
+              C(ToricSpace.CompactFibreTorus × Circle, ToricSpace.CompactFibreTorus))
+            n).comp
+        (middleOverlapHomologyEquiv C ε hε hε1 hC hR a ha ha1 n).toLinearMap := by
+  have hm :=
+    congrArg
+      (fun f : C((overlapRegion C ε hε a), ToricSpace.CompactFibreTorus) =>
+        SingularMayerVietoris.singularHomologyMap f n)
+      (overlapIntoInner_phase_map C ε hε hε1 hC hR a ha ha1)
+  simpa only [PeriodTorusHigherHomology.singularHomologyMap_comp, middleInnerHomologyEquiv,
+    middleOverlapHomologyEquiv,
+    PeriodTorusHigherHomology.homotopyEquivHomologyEquiv_toLinearMap] using hm
+
+private theorem
+    CuspCentralHomology.middleInnerProjection_zero_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (n : ℕ)
+    (z : SingularMayerVietoris.SingularHomology (overlapRegion C ε hε a) n) :
+    SingularMayerVietoris.singularHomologyMap (overlapIntoInner C ε hε a) n z = 0 ↔
+      SingularMayerVietoris.singularHomologyMap
+          (ContinuousMap.fst :
+            C(ToricSpace.CompactFibreTorus × Circle, ToricSpace.CompactFibreTorus))
+          n (middleOverlapHomologyEquiv C ε hε hε1 hC hR a ha ha1 n z) =
+        0 := by
+  have hm := LinearMap.congr_fun (middleInnerProjection_natural C ε hε hε1 hC hR a ha ha1 n) z
+  change
+    middleInnerHomologyEquiv C ε hε hε1 hC hR n
+        (SingularMayerVietoris.singularHomologyMap (overlapIntoInner C ε hε a) n z) =
+      _ at hm
+  constructor
+  · intro hz
+    rw [hz, map_zero] at hm
+    exact hm.symm
+  · intro hz
+    apply (middleInnerHomologyEquiv C ε hε hε1 hC hR n).injective
+    simpa only [map_zero] using hm.trans hz
+
+private theorem CuspCentralHomology.overlapIntoInner_homology_surjective
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (n : ℕ) :
+    Function.Surjective
+      (SingularMayerVietoris.singularHomologyMap (overlapIntoInner C ε hε a) (n + 1)) := by
+  intro z
+  obtain ⟨w, hw⟩ :=
+    rightCircleProjection_surjective ToricSpace.CompactFibreTorus n
+      (middleInnerHomologyEquiv C ε hε hε1 hC hR (n + 1) z)
+  refine ⟨(middleOverlapHomologyEquiv C ε hε hε1 hC hR a ha ha1 (n + 1)).symm w, ?_⟩
+  apply (middleInnerHomologyEquiv C ε hε hε1 hC hR (n + 1)).injective
+  have hm :=
+    LinearMap.congr_fun (middleInnerProjection_natural C ε hε hε1 hC hR a ha ha1 (n + 1))
+      ((middleOverlapHomologyEquiv C ε hε hε1 hC hR a ha ha1 (n + 1)).symm w)
+  simpa only [LinearMap.comp_apply, LinearEquiv.coe_coe, LinearEquiv.apply_symm_apply, hw] using
+    hm
+
+private theorem
+    CuspCentralHomology.middleLeftHomologyMap_apply (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (n : ℕ)
+    (z : SingularMayerVietoris.SingularHomology (overlapRegion C ε hε a) (n + 1)) :
+    SingularMayerVietoris.leftHomologyMap (outerRegion C ε hε a) (innerRegion C ε hε) (n + 1) z =
+      (0, -SingularMayerVietoris.singularHomologyMap (overlapIntoInner C ε hε a) (n + 1) z) := by
+  calc
+    SingularMayerVietoris.leftHomologyMap (outerRegion C ε hε a) (innerRegion C ε hε) (n + 1) z =
+        (SingularMayerVietoris.singularHomologyMap (overlapIntoOuter C ε hε a) (n + 1) z,
+          -SingularMayerVietoris.singularHomologyMap (overlapIntoInner C ε hε a) (n + 1) z) :=
+      SingularMayerVietoris.leftHomologyMap_apply (outerRegion C ε hε a) (innerRegion C ε hε)
+        (n + 1) z
+    _ = _ := by
+      rw [overlapIntoOuter_homology_eq_zero C ε hε hε1 hC hR a ha ha1 n, LinearMap.zero_apply]
+
+private theorem
+    CuspCentralHomology.middleLeftHomology_mem_ker_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (n : ℕ)
+    (z : SingularMayerVietoris.SingularHomology (overlapRegion C ε hε a) (n + 1)) :
+    z ∈
+        LinearMap.ker
+          (SingularMayerVietoris.leftHomologyMap (outerRegion C ε hε a) (innerRegion C ε hε)
+            (n + 1)) ↔
+      SingularMayerVietoris.singularHomologyMap
+          (ContinuousMap.fst :
+            C(ToricSpace.CompactFibreTorus × Circle, ToricSpace.CompactFibreTorus))
+          (n + 1) (middleOverlapHomologyEquiv C ε hε hε1 hC hR a ha ha1 (n + 1) z) =
+        0 := by
+  change
+    SingularMayerVietoris.leftHomologyMap (outerRegion C ε hε a) (innerRegion C ε hε) (n + 1) z =
+        0 ↔
+      _
+  rw [middleLeftHomologyMap_apply C ε hε hε1 hC hR a ha ha1 n z]
+  constructor
+  · intro hz
+    have hi :
+      -SingularMayerVietoris.singularHomologyMap (overlapIntoInner C ε hε a) (n + 1) z = 0 :=
+      congrArg Prod.snd hz
+    exact
+      (middleInnerProjection_zero_iff C ε hε hε1 hC hR a ha ha1 (n + 1) z).mp (neg_eq_zero.mp hi)
+  · intro hz
+    rw [(middleInnerProjection_zero_iff C ε hε hε1 hC hR a ha ha1 (n + 1) z).mpr hz, neg_zero]
+    rfl
+
+private def CuspCentralHomology.middleLeftKernelToProjectionEquiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (n : ℕ) :
+    LinearMap.ker
+        (SingularMayerVietoris.leftHomologyMap (outerRegion C ε hε a) (innerRegion C ε hε)
+          (n + 1)) ≃ₗ[ℤ]
+      LinearMap.ker
+        (SingularMayerVietoris.singularHomologyMap
+          (ContinuousMap.fst :
+            C(ToricSpace.CompactFibreTorus × Circle, ToricSpace.CompactFibreTorus))
+          (n + 1)) :=
+  ({    toFun
+          z :=
+          ⟨middleOverlapHomologyEquiv C ε hε hε1 hC hR a ha ha1 (n + 1) z.1,
+            (middleLeftHomology_mem_ker_iff C ε hε hε1 hC hR a ha ha1 n z.1).mp z.2⟩
+        invFun
+          z :=
+          ⟨(middleOverlapHomologyEquiv C ε hε hε1 hC hR a ha ha1 (n + 1)).symm z.1,
+            (middleLeftHomology_mem_ker_iff C ε hε hε1 hC hR a ha ha1 n _).mpr
+              (by
+                rw [LinearEquiv.apply_symm_apply]
+                exact z.2)⟩
+        left_inv z := Subtype.ext (LinearEquiv.symm_apply_apply _ z.1)
+        right_inv z := Subtype.ext (LinearEquiv.apply_symm_apply _ z.1)
+        map_add' z
+          w := by
+          apply Subtype.ext
+          exact map_add (middleOverlapHomologyEquiv C ε hε hε1 hC hR a ha ha1 (n + 1)) z.1 w.1 } :
+      LinearMap.ker
+          (SingularMayerVietoris.leftHomologyMap (outerRegion C ε hε a) (innerRegion C ε hε)
+            (n + 1)) ≃+
+        LinearMap.ker
+          (SingularMayerVietoris.singularHomologyMap
+            (ContinuousMap.fst :
+              C(ToricSpace.CompactFibreTorus × Circle, ToricSpace.CompactFibreTorus))
+            (n + 1))).toIntLinearEquiv
+
+private def CuspCentralHomology.middleLeftKernelEquiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (n : ℕ) :
+    LinearMap.ker
+        (SingularMayerVietoris.leftHomologyMap (outerRegion C ε hε a) (innerRegion C ε hε)
+          (n + 1)) ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology ToricSpace.CompactFibreTorus n :=
+  ((middleLeftKernelToProjectionEquiv C ε hε hε1 hC hR a ha ha1 n).toAddEquiv.trans
+      (rightCircleProjectionKernelEquiv ToricSpace.CompactFibreTorus
+          n).toAddEquiv).toIntLinearEquiv
+
+private theorem
+    CuspCentralHomology.coverConnecting_injective_of_vanishing {X : Type} [TopologicalSpace X]
+    (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (n : ℕ)
+    [Subsingleton (SingularMayerVietoris.SingularHomology U (n + 1))]
+    [Subsingleton (SingularMayerVietoris.SingularHomology V (n + 1))] :
+    Function.Injective (SingularMayerVietoris.connectingHomomorphism U V hU hV hcover n) := by
+  apply LinearMap.ker_eq_bot.mp
+  rw [← SingularMayerVietoris.exact_at_ambient U V hU hV hcover n]
+  apply LinearMap.range_eq_bot.mpr
+  apply LinearMap.ext
+  intro a
+  have ha : a = 0 := Subsingleton.elim _ _
+  rw [ha, map_zero, LinearMap.zero_apply]
+
+private theorem CuspCentralHomology.coverConnecting_surjective_of_vanishing {X : Type}
+    [TopologicalSpace X] (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ)
+    (n : ℕ) [Subsingleton (SingularMayerVietoris.SingularHomology U n)]
+    [Subsingleton (SingularMayerVietoris.SingularHomology V n)] :
+    Function.Surjective (SingularMayerVietoris.connectingHomomorphism U V hU hV hcover n) := by
+  intro a
+  have ha : a ∈ LinearMap.ker (SingularMayerVietoris.leftHomologyMap U V n) := by
+    exact Subsingleton.elim _ _
+  rw [← SingularMayerVietoris.exact_at_intersection U V hU hV hcover n] at ha
+  exact ha
+
+private def CuspCentralHomology.coverConnectingEquivOfVanishing {X : Type} [TopologicalSpace X]
+    (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (n : ℕ)
+    [Subsingleton (SingularMayerVietoris.SingularHomology U (n + 1))]
+    [Subsingleton (SingularMayerVietoris.SingularHomology V (n + 1))]
+    [Subsingleton (SingularMayerVietoris.SingularHomology U n)]
+    [Subsingleton (SingularMayerVietoris.SingularHomology V n)] :
+    SingularMayerVietoris.SingularHomology X (n + 1) ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (U ∩ V : Set X) n :=
+  LinearEquiv.ofBijective (SingularMayerVietoris.connectingHomomorphism U V hU hV hcover n)
+    ⟨coverConnecting_injective_of_vanishing U V hU hV hcover n,
+      coverConnecting_surjective_of_vanishing U V hU hV hcover n⟩
+
+public
+theorem CuspCentralHomology.coverHomology_subsingleton_of_vanishing {X : Type}
+    [TopologicalSpace X] (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ)
+    (n : ℕ) [Subsingleton (SingularMayerVietoris.SingularHomology U (n + 1))]
+    [Subsingleton (SingularMayerVietoris.SingularHomology V (n + 1))]
+    [Subsingleton (SingularMayerVietoris.SingularHomology (U ∩ V : Set X) n)] :
+    Subsingleton (SingularMayerVietoris.SingularHomology X (n + 1)) :=
+  (coverConnecting_injective_of_vanishing U V hU hV hcover n).subsingleton
+
+private def
+    CuspCentralHomology.coverConnectingToKernel {X : Type} [TopologicalSpace X] (U V : Set X)
+    (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology X (n + 1) →ₗ[ℤ]
+      LinearMap.ker (SingularMayerVietoris.leftHomologyMap U V n) :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    ((SingularMayerVietoris.connectingHomomorphism U V hU hV hcover n).codRestrict
+        (LinearMap.ker (SingularMayerVietoris.leftHomologyMap U V n))
+        (by
+          intro a
+          rw [← SingularMayerVietoris.exact_at_intersection U V hU hV hcover n]
+          exact ⟨a, rfl⟩)).toAddMonoidHom
+
+private theorem
+    CuspCentralHomology.coverConnectingToKernel_surjective {X : Type} [TopologicalSpace X]
+    (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (n : ℕ) :
+    Function.Surjective (coverConnectingToKernel U V hU hV hcover n) := by
+  intro a
+  have ha :
+    (a : SingularMayerVietoris.SingularHomology (U ∩ V : Set X) n) ∈
+      LinearMap.range (SingularMayerVietoris.connectingHomomorphism U V hU hV hcover n) :=
+    (SingularMayerVietoris.exact_at_intersection U V hU hV hcover n).symm.le a.property
+  obtain ⟨b, hb⟩ := ha
+  exact ⟨b, Subtype.ext hb⟩
+
+@[simp]
+private theorem
+    CuspCentralHomology.coverConnectingToKernel_eq_zero_iff {X : Type} [TopologicalSpace X]
+    (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology X (n + 1)) :
+    coverConnectingToKernel U V hU hV hcover n a = 0 ↔
+      SingularMayerVietoris.connectingHomomorphism U V hU hV hcover n a = 0 := by
+  constructor
+  · exact fun ha => congrArg Subtype.val ha
+  · exact fun ha => Subtype.ext ha
+
+private theorem CuspCentralHomology.coverConnectingToKernel_ker {X : Type} [TopologicalSpace X]
+    (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (n : ℕ) :
+    LinearMap.ker (coverConnectingToKernel U V hU hV hcover n) =
+      LinearMap.ker (SingularMayerVietoris.connectingHomomorphism U V hU hV hcover n) := by
+  ext a
+  exact coverConnectingToKernel_eq_zero_iff U V hU hV hcover n a
+
+private theorem CuspCentralHomology.coverConnectingToKernel_exact {X : Type} [TopologicalSpace X]
+    (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (n : ℕ) :
+    LinearMap.range (SingularMayerVietoris.rightHomologyMap U V (n + 1)) =
+      LinearMap.ker (coverConnectingToKernel U V hU hV hcover n) := by
+  rw [coverConnectingToKernel_ker]
+  exact SingularMayerVietoris.exact_at_ambient U V hU hV hcover n
+
+private theorem CuspCentralHomology.coverConnectingToKernel_injective_of_vanishing {X : Type}
+    [TopologicalSpace X] (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ)
+    (n : ℕ) [Subsingleton (SingularMayerVietoris.SingularHomology U (n + 1))]
+    [Subsingleton (SingularMayerVietoris.SingularHomology V (n + 1))] :
+    Function.Injective (coverConnectingToKernel U V hU hV hcover n) := by
+  intro a b hab
+  apply coverConnecting_injective_of_vanishing U V hU hV hcover n
+  exact congrArg Subtype.val hab
+
+private def
+    CuspCentralHomology.coverConnectingKernelEquivOfVanishing {X : Type} [TopologicalSpace X]
+    (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (n : ℕ)
+    [Subsingleton (SingularMayerVietoris.SingularHomology U (n + 1))]
+    [Subsingleton (SingularMayerVietoris.SingularHomology V (n + 1))] :
+    SingularMayerVietoris.SingularHomology X (n + 1) ≃ₗ[ℤ]
+      LinearMap.ker (SingularMayerVietoris.leftHomologyMap U V n) :=
+  LinearEquiv.ofBijective (coverConnectingToKernel U V hU hV hcover n)
+    ⟨coverConnectingToKernel_injective_of_vanishing U V hU hV hcover n,
+      coverConnectingToKernel_surjective U V hU hV hcover n⟩
+
+private def CuspCentralHomology.integerExtensionLift {B : Type*} [AddCommGroup B] [Module ℤ B]
+    (d : B →ₗ[ℤ] ℤ) (hd : Function.Surjective d) : B :=
+  Classical.choose (hd 1)
+
+@[simp]
+private theorem
+    CuspCentralHomology.integerExtensionLift_spec {B : Type*} [AddCommGroup B] [Module ℤ B]
+    (d : B →ₗ[ℤ] ℤ) (hd : Function.Surjective d) : d (integerExtensionLift d hd) = 1 :=
+  Classical.choose_spec (hd 1)
+
+private def
+    CuspCentralHomology.integerExtensionAssembly {A B : Type*} [AddCommGroup A] [AddCommGroup B]
+    [Module ℤ A] [Module ℤ B] (i : A →ₗ[ℤ] B) (b : B) : (A × ℤ) →ₗ[ℤ] B :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun az := i az.1 + az.2 • b
+      map_zero' := by simp only [Prod.fst_zero, Prod.snd_zero, map_zero, zero_smul, add_zero]
+      map_add' az
+        aw := by
+        change i (az.1 + aw.1) + (az.2 + aw.2) • b = (i az.1 + az.2 • b) + (i aw.1 + aw.2 • b)
+        rw [map_add, add_zsmul]
+        exact add_add_add_comm _ _ _ _ }
+
+@[simp]
+private theorem CuspCentralHomology.integerExtensionAssembly_apply {A B : Type*} [AddCommGroup A]
+    [AddCommGroup B] [Module ℤ A] [Module ℤ B] (i : A →ₗ[ℤ] B) (b : B) (az : A × ℤ) :
+    integerExtensionAssembly i b az = i az.1 + az.2 • b :=
+  rfl
+
+private theorem
+    CuspCentralHomology.integerExtension_boundary_inclusion {A B : Type*} [AddCommGroup A]
+    [AddCommGroup B] [Module ℤ A] [Module ℤ B] (i : A →ₗ[ℤ] B) (d : B →ₗ[ℤ] ℤ)
+    (hexact : LinearMap.range i = LinearMap.ker d) (a : A) : d (i a) = 0 := by
+  have ha : i a ∈ LinearMap.range i := ⟨a, rfl⟩
+  rw [hexact] at ha
+  exact ha
+
+private theorem CuspCentralHomology.integerExtensionAssembly_boundary {A B : Type*} [AddCommGroup A]
+    [AddCommGroup B] [Module ℤ A] [Module ℤ B] (i : A →ₗ[ℤ] B) (d : B →ₗ[ℤ] ℤ)
+    (hexact : LinearMap.range i = LinearMap.ker d) (b : B) (hb : d b = 1) (az : A × ℤ) :
+    d (integerExtensionAssembly i b az) = az.2 := by
+  rw [integerExtensionAssembly_apply, map_add, map_zsmul,
+    integerExtension_boundary_inclusion i d hexact, hb, zero_add]
+  simp
+
+private theorem
+    CuspCentralHomology.integerExtensionAssembly_injective {A B : Type*} [AddCommGroup A]
+    [AddCommGroup B] [Module ℤ A] [Module ℤ B] (i : A →ₗ[ℤ] B) (d : B →ₗ[ℤ] ℤ)
+    (hi : Function.Injective i) (hexact : LinearMap.range i = LinearMap.ker d) (b : B)
+    (hb : d b = 1) : Function.Injective (integerExtensionAssembly i b) := by
+  intro az aw h
+  have hsnd : az.2 = aw.2 := by
+    have hd := congrArg d h
+    simpa only [integerExtensionAssembly_boundary i d hexact b hb] using hd
+  apply Prod.ext _ hsnd
+  apply hi
+  apply add_right_cancel (b := aw.2 • b)
+  simpa only [integerExtensionAssembly_apply, hsnd] using h
+
+private theorem
+    CuspCentralHomology.integerExtensionAssembly_surjective {A B : Type*} [AddCommGroup A]
+    [AddCommGroup B] [Module ℤ A] [Module ℤ B] (i : A →ₗ[ℤ] B) (d : B →ₗ[ℤ] ℤ)
+    (hexact : LinearMap.range i = LinearMap.ker d) (b : B) (hb : d b = 1) :
+    Function.Surjective (integerExtensionAssembly i b) := by
+  intro y
+  have hk : y - d y • b ∈ LinearMap.ker d := by
+    change d (y - d y • b) = 0
+    rw [map_sub, map_zsmul, hb]
+    simp
+  rw [← hexact] at hk
+  obtain ⟨a, ha⟩ := hk
+  refine ⟨(a, d y), ?_⟩
+  change i a + d y • b = y
+  rw [ha, sub_add_cancel]
+
+private def
+    CuspCentralHomology.splitIntegerExtensionEquiv {A B : Type*} [AddCommGroup A] [AddCommGroup B]
+    [Module ℤ A] [Module ℤ B] (i : A →ₗ[ℤ] B) (d : B →ₗ[ℤ] ℤ) (hi : Function.Injective i)
+    (hd : Function.Surjective d) (hexact : LinearMap.range i = LinearMap.ker d) :
+    B ≃ₗ[ℤ] (A × ℤ) :=
+  (LinearEquiv.ofBijective (integerExtensionAssembly i (integerExtensionLift d hd))
+      ⟨integerExtensionAssembly_injective i d hi hexact (integerExtensionLift d hd)
+          (integerExtensionLift_spec d hd),
+        integerExtensionAssembly_surjective i d hexact (integerExtensionLift d hd)
+          (integerExtensionLift_spec d hd)⟩).symm
+
+@[simp]
+private theorem
+    CuspCentralHomology.splitIntegerExtensionEquiv_symm_apply {A B : Type*} [AddCommGroup A]
+    [AddCommGroup B] [Module ℤ A] [Module ℤ B] (i : A →ₗ[ℤ] B) (d : B →ₗ[ℤ] ℤ)
+    (hi : Function.Injective i) (hd : Function.Surjective d)
+    (hexact : LinearMap.range i = LinearMap.ker d) (az : A × ℤ) :
+    (splitIntegerExtensionEquiv i d hi hd hexact).symm az =
+      i az.1 + az.2 • integerExtensionLift d hd :=
+  rfl
+
+@[simp]
+private theorem CuspCentralHomology.splitIntegerExtensionEquiv_snd {A B : Type*} [AddCommGroup A]
+    [AddCommGroup B] [Module ℤ A] [Module ℤ B] (i : A →ₗ[ℤ] B) (d : B →ₗ[ℤ] ℤ)
+    (hi : Function.Injective i) (hd : Function.Surjective d)
+    (hexact : LinearMap.range i = LinearMap.ker d) (b : B) :
+    (splitIntegerExtensionEquiv i d hi hd hexact b).2 = d b := by
+  have h :=
+    integerExtensionAssembly_boundary i d hexact (integerExtensionLift d hd)
+      (integerExtensionLift_spec d hd) (splitIntegerExtensionEquiv i d hi hd hexact b)
+  change
+    d
+        ((splitIntegerExtensionEquiv i d hi hd hexact).symm
+          (splitIntegerExtensionEquiv i d hi hd hexact b)) =
+      _ at h
+  rw [LinearEquiv.symm_apply_apply] at h
+  exact h.symm
+
+private def CuspCentralHomology.signedRightMap {C E : Type*} [AddCommGroup C] [AddCommGroup E]
+    [Module ℤ C] [Module ℤ E] (A : Type*) [AddCommGroup A] (p : E →ₗ[ℤ] C) :
+    E →ₗ[ℤ] (A × C) :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun e := (0, -p e)
+      map_zero' := by simp only [map_zero, neg_zero, Prod.mk_zero_zero]
+      map_add' e
+        f := by
+        apply Prod.ext
+        · exact (add_zero 0).symm
+        · exact (congrArg Neg.neg (p.map_add e f)).trans (neg_add (p e) (p f)) }
+
+@[simp]
+private theorem
+    CuspCentralHomology.signedRightMap_apply {A C E : Type*} [AddCommGroup A] [AddCommGroup C]
+    [AddCommGroup E] [Module ℤ C] [Module ℤ E] (p : E →ₗ[ℤ] C) (e : E) :
+    signedRightMap A p e = (0, -p e) :=
+  rfl
+
+private def CuspCentralHomology.firstSummandMap {A B C : Type*} [AddCommGroup A] [AddCommGroup B]
+    [AddCommGroup C] [Module ℤ A] [Module ℤ B] (r : (A × C) →ₗ[ℤ] B) : A →ₗ[ℤ] B :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun a := r (a, 0)
+      map_zero' := r.map_zero
+      map_add' a b := by simpa only [Prod.mk_add_mk, add_zero] using r.map_add (a, 0) (b, 0) }
+
+@[simp]
+private theorem CuspCentralHomology.firstSummandMap_apply {A B C : Type*} [AddCommGroup A]
+    [AddCommGroup B] [AddCommGroup C] [Module ℤ A] [Module ℤ B] (r : (A × C) →ₗ[ℤ] B) (a : A) :
+    firstSummandMap r a = r (a, 0) :=
+  rfl
+
+private theorem CuspCentralHomology.firstSummandMap_injective {A B C E : Type*} [AddCommGroup A]
+    [AddCommGroup B] [AddCommGroup C] [AddCommGroup E] [Module ℤ A] [Module ℤ B] [Module ℤ C]
+    [Module ℤ E] (p : E →ₗ[ℤ] C) (r : (A × C) →ₗ[ℤ] B)
+    (hker : LinearMap.ker r = LinearMap.range (signedRightMap A p)) :
+    Function.Injective (firstSummandMap r) := by
+  apply LinearMap.ker_eq_bot.mp
+  apply le_antisymm _ bot_le
+  intro a ha
+  have hmem : (a, 0) ∈ LinearMap.ker r := ha
+  rw [hker] at hmem
+  obtain ⟨e, he⟩ := hmem
+  change a = 0
+  exact (congrArg Prod.fst he).symm
+
+private theorem CuspCentralHomology.secondSummand_eq_zero {A B C E : Type*} [AddCommGroup A]
+    [AddCommGroup B] [AddCommGroup C] [AddCommGroup E] [Module ℤ B] [Module ℤ C]
+    [Module ℤ E] (p : E →ₗ[ℤ] C) (hp : Function.Surjective p) (r : (A × C) →ₗ[ℤ] B)
+    (hker : LinearMap.ker r = LinearMap.range (signedRightMap A p)) (c : C) : r (0, c) = 0 := by
+  have hmem : (0, c) ∈ LinearMap.range (signedRightMap A p) := by
+    obtain ⟨e, he⟩ := hp (-c)
+    refine ⟨e, ?_⟩
+    simp only [signedRightMap_apply, he, neg_neg]
+  rw [← hker] at hmem
+  exact hmem
+
+private theorem CuspCentralHomology.firstSummandMap_apply_fst {A B C E : Type*} [AddCommGroup A]
+    [AddCommGroup B] [AddCommGroup C] [AddCommGroup E] [Module ℤ A] [Module ℤ B] [Module ℤ C]
+    [Module ℤ E] (p : E →ₗ[ℤ] C) (hp : Function.Surjective p) (r : (A × C) →ₗ[ℤ] B)
+    (hker : LinearMap.ker r = LinearMap.range (signedRightMap A p)) (ac : A × C) :
+    firstSummandMap r ac.1 = r ac := by
+  have h := r.map_add (ac.1, 0) (0, ac.2)
+  simpa only [firstSummandMap_apply, Prod.mk_add_mk, add_zero, zero_add,
+    secondSummand_eq_zero p hp r hker] using h.symm
+
+private theorem CuspCentralHomology.firstSummandMap_range {A B C E : Type*} [AddCommGroup A]
+    [AddCommGroup B] [AddCommGroup C] [AddCommGroup E] [Module ℤ A] [Module ℤ B] [Module ℤ C]
+    [Module ℤ E] (p : E →ₗ[ℤ] C) (hp : Function.Surjective p) (r : (A × C) →ₗ[ℤ] B)
+    (hker : LinearMap.ker r = LinearMap.range (signedRightMap A p)) :
+    LinearMap.range (firstSummandMap r) = LinearMap.range r := by
+  ext b
+  constructor
+  · rintro ⟨a, ha⟩
+    exact ⟨(a, 0), ha⟩
+  · rintro ⟨ac, hac⟩
+    exact ⟨ac.1, (firstSummandMap_apply_fst p hp r hker ac).trans hac⟩
+
+private theorem CuspCentralHomology.eq_signedRightMap_of_apply {A C E : Type*} [AddCommGroup A]
+    [AddCommGroup C] [AddCommGroup E] [Module ℤ C] [Module ℤ E]
+    (left : E →ₗ[ℤ] (A × C)) (p : E →ₗ[ℤ] C) (hl : ∀ e, left e = (0, -p e)) :
+    left = signedRightMap A p := by
+  apply LinearMap.ext
+  intro e
+  exact hl e
+
+private theorem CuspCentralHomology.firstSummandMap_injective_of_signed_formula {A B C E : Type*}
+    [AddCommGroup A] [AddCommGroup B] [AddCommGroup C] [AddCommGroup E] [Module ℤ A] [Module ℤ B]
+    [Module ℤ C] [Module ℤ E] (left : E →ₗ[ℤ] (A × C)) (p : E →ₗ[ℤ] C) (r : (A × C) →ₗ[ℤ] B)
+    (hl : ∀ e, left e = (0, -p e)) (hexact : LinearMap.range left = LinearMap.ker r) :
+    Function.Injective (firstSummandMap r) := by
+  apply firstSummandMap_injective p r
+  rw [← eq_signedRightMap_of_apply left p hl]
+  exact hexact.symm
+
+private theorem CuspCentralHomology.firstSummandMap_range_of_signed_formula {A B C E : Type*}
+    [AddCommGroup A] [AddCommGroup B] [AddCommGroup C] [AddCommGroup E] [Module ℤ A] [Module ℤ B]
+    [Module ℤ C] [Module ℤ E] (left : E →ₗ[ℤ] (A × C)) (p : E →ₗ[ℤ] C)
+    (hp : Function.Surjective p) (r : (A × C) →ₗ[ℤ] B) (hl : ∀ e, left e = (0, -p e))
+    (hexact : LinearMap.range left = LinearMap.ker r) :
+    LinearMap.range (firstSummandMap r) = LinearMap.range r := by
+  apply firstSummandMap_range p hp r
+  rw [← eq_signedRightMap_of_apply left p hl]
+  exact hexact.symm
+
+private def
+    CuspCentralHomology.middleConnectingKernelEquiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    LinearMap.ker
+        (SingularMayerVietoris.leftHomologyMap (outerRegion C ε hε a) (innerRegion C ε hε)
+          1) ≃ₗ[ℤ]
+      ℤ :=
+  (middleLeftKernelEquiv C ε hε hε1 hC hR a ha ha1 0).trans
+    ((compactFibreTorusHomologyEquiv 0).trans (LinearEquiv.funUnique (Fin 1) ℤ ℤ))
+
+private def
+    CuspCentralHomology.middleQuotientMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C ε) 2 →ₗ[ℤ] ℤ :=
+  (middleConnectingKernelEquiv C ε hε hε1 hC hR a ha ha1).toLinearMap.comp
+    (coverConnectingToKernel (outerRegion C ε hε a) (innerRegion C ε hε)
+      (outerRegion_isOpen C ε hε hε1 hC hR a) (innerRegion_isOpen C ε hε hε1 hC hR)
+      (outerRegion_union_innerRegion C ε hε a ha1) 1)
+
+private theorem CuspCentralHomology.middleQuotientMap_surjective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    Function.Surjective (middleQuotientMap C ε hε hε1 hC hR a ha ha1) :=
+  (middleConnectingKernelEquiv C ε hε hε1 hC hR a ha ha1).surjective.comp
+    (coverConnectingToKernel_surjective (outerRegion C ε hε a) (innerRegion C ε hε)
+      (outerRegion_isOpen C ε hε hε1 hC hR a) (innerRegion_isOpen C ε hε hε1 hC hR)
+      (outerRegion_union_innerRegion C ε hε a ha1) 1)
+
+private theorem CuspCentralHomology.middleQuotientMap_ker (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    LinearMap.ker (middleQuotientMap C ε hε hε1 hC hR a ha ha1) =
+      LinearMap.ker
+        (coverConnectingToKernel (outerRegion C ε hε a) (innerRegion C ε hε)
+          (outerRegion_isOpen C ε hε hε1 hC hR a) (innerRegion_isOpen C ε hε hε1 hC hR)
+          (outerRegion_union_innerRegion C ε hε a ha1) 1) := by
+  ext x
+  change
+    middleConnectingKernelEquiv C ε hε hε1 hC hR a ha ha1
+          (coverConnectingToKernel (outerRegion C ε hε a) (innerRegion C ε hε) _ _ _ 1 x) =
+        0 ↔
+      _
+  constructor
+  · intro hx
+    apply (middleConnectingKernelEquiv C ε hε hε1 hC hR a ha ha1).injective
+    simpa only [map_zero] using hx
+  · intro hx
+    change coverConnectingToKernel (outerRegion C ε hε a) (innerRegion C ε hε) _ _ _ 1 x = 0 at hx
+    rw [hx, map_zero]
+
+private theorem CuspCentralHomology.middleOuterInclusion_eq_firstSummand
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (a : ℝ) :
+    SingularMayerVietoris.singularHomologyMap
+        (SingularMayerVietoris.subtypeInclusion (outerRegion C ε hε a)) 2 =
+      firstSummandMap
+        (SingularMayerVietoris.rightHomologyMap (outerRegion C ε hε a) (innerRegion C ε hε) 2) := by
+  apply LinearMap.ext
+  intro x
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (SingularMayerVietoris.subtypeInclusion (outerRegion C ε hε a)) 2 x =
+      SingularMayerVietoris.singularHomologyMap
+          (SingularMayerVietoris.subtypeInclusion (outerRegion C ε hε a)) 2 x +
+        SingularMayerVietoris.singularHomologyMap
+          (SingularMayerVietoris.subtypeInclusion (innerRegion C ε hε)) 2 0
+  rw [map_zero, add_zero]
+
+private theorem
+    CuspCentralHomology.middleOuterInclusion_injective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    Function.Injective
+      (SingularMayerVietoris.singularHomologyMap
+        (SingularMayerVietoris.subtypeInclusion (outerRegion C ε hε a)) 2) := by
+  rw [middleOuterInclusion_eq_firstSummand C ε hε a]
+  exact
+    firstSummandMap_injective_of_signed_formula
+      (SingularMayerVietoris.leftHomologyMap (outerRegion C ε hε a) (innerRegion C ε hε) 2)
+      (SingularMayerVietoris.singularHomologyMap (overlapIntoInner C ε hε a) 2)
+      (SingularMayerVietoris.rightHomologyMap (outerRegion C ε hε a) (innerRegion C ε hε) 2)
+      (middleLeftHomologyMap_apply C ε hε hε1 hC hR a ha ha1 1)
+      (SingularMayerVietoris.exact_at_pair (outerRegion C ε hε a) (innerRegion C ε hε)
+        (outerRegion_isOpen C ε hε hε1 hC hR a) (innerRegion_isOpen C ε hε hε1 hC hR)
+        (outerRegion_union_innerRegion C ε hε a ha1) 2)
+
+private theorem
+    CuspCentralHomology.middleOuterInclusion_range (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap
+          (SingularMayerVietoris.subtypeInclusion (outerRegion C ε hε a)) 2) =
+      LinearMap.range
+        (SingularMayerVietoris.rightHomologyMap (outerRegion C ε hε a) (innerRegion C ε hε) 2) := by
+  rw [middleOuterInclusion_eq_firstSummand C ε hε a]
+  exact
+    firstSummandMap_range_of_signed_formula
+      (SingularMayerVietoris.leftHomologyMap (outerRegion C ε hε a) (innerRegion C ε hε) 2)
+      (SingularMayerVietoris.singularHomologyMap (overlapIntoInner C ε hε a) 2)
+      (overlapIntoInner_homology_surjective C ε hε hε1 hC hR a ha ha1 1)
+      (SingularMayerVietoris.rightHomologyMap (outerRegion C ε hε a) (innerRegion C ε hε) 2)
+      (middleLeftHomologyMap_apply C ε hε hε1 hC hR a ha ha1 1)
+      (SingularMayerVietoris.exact_at_pair (outerRegion C ε hε a) (innerRegion C ε hε)
+        (outerRegion_isOpen C ε hε hε1 hC hR a) (innerRegion_isOpen C ε hε hε1 hC hR)
+        (outerRegion_union_innerRegion C ε hε a ha1) 2)
+
+private theorem
+    CuspCentralHomology.middleSecondHomology_exact (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap
+          (SingularMayerVietoris.subtypeInclusion (outerRegion C ε hε a)) 2) =
+      LinearMap.ker (middleQuotientMap C ε hε hε1 hC hR a ha ha1) := by
+  rw [middleOuterInclusion_range C ε hε hε1 hC hR a ha ha1, middleQuotientMap_ker]
+  exact
+    coverConnectingToKernel_exact (outerRegion C ε hε a) (innerRegion C ε hε)
+      (outerRegion_isOpen C ε hε hε1 hC hR a) (innerRegion_isOpen C ε hε hε1 hC hR)
+      (outerRegion_union_innerRegion C ε hε a ha1) 1
+
+private def CuspCentralHomology.middleSecondHomologySplit (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C ε) 2 ≃ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology (outerRegion C ε hε a) 2 × ℤ) :=
+  splitIntegerExtensionEquiv
+    (SingularMayerVietoris.singularHomologyMap
+      (SingularMayerVietoris.subtypeInclusion (outerRegion C ε hε a)) 2)
+    (middleQuotientMap C ε hε hε1 hC hR a ha ha1)
+    (middleOuterInclusion_injective C ε hε hε1 hC hR a ha ha1)
+    (middleQuotientMap_surjective C ε hε hε1 hC hR a ha ha1)
+    (middleSecondHomology_exact C ε hε hε1 hC hR a ha ha1)
+
+private def CuspCentralHomology.middleIntegerFourEquiv : ((Fin 3 → ℤ) × ℤ) ≃ₗ[ℤ] (Fin 4 → ℤ) :=
+  ({    toFun p := ![p.1 0, p.1 1, p.1 2, p.2]
+        invFun v := (![v 0, v 1, v 2], v 3)
+        left_inv
+          p := by
+          apply Prod.ext
+          · funext i
+            fin_cases i <;> rfl
+          · rfl
+        right_inv
+          v := by
+          funext i
+          fin_cases i <;> rfl
+        map_add' p
+          q := by
+          funext i
+          fin_cases i <;> rfl } :
+      ((Fin 3 → ℤ) × ℤ) ≃+ (Fin 4 → ℤ)).toIntLinearEquiv
+
+private def
+    CuspCentralHomology.middleOuterHomologyTwoEquiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    SingularMayerVietoris.SingularHomology (outerRegion C ε hε a) 2 ≃ₗ[ℤ] (Fin 3 → ℤ) :=
+  (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+        (outerRegionSuspensionHomotopyEquiv C ε hε hε1 hC hR a ha ha1) 2).trans
+    threeCircleSuspensionHomologyTwoEquiv
+
+private def
+    CuspCentralHomology.centralSingularH3Equiv_of_admissible (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C ε) 3 ≃ₗ[ℤ]
+      (Fin 2 → ℤ) := by
+  letI := outerRegion_homology_subsingleton C ε hε hε1 hC hR (1 / 2) (by norm_num) (by norm_num) 0
+  letI := innerRegion_homology_subsingleton C ε hε hε1 hC hR 0
+  exact
+    ((coverConnectingKernelEquivOfVanishing (outerRegion C ε hε (1 / 2)) (innerRegion C ε hε)
+              (outerRegion_isOpen C ε hε hε1 hC hR (1 / 2)) (innerRegion_isOpen C ε hε hε1 hC hR)
+              (outerRegion_union_innerRegion C ε hε (1 / 2) (by norm_num)) 2).trans
+          (middleLeftKernelEquiv C ε hε hε1 hC hR (1 / 2) (by norm_num) (by norm_num) 1)).trans
+      (compactFibreTorusHomologyEquiv 1)
+
+private def
+    CuspCentralHomology.centralSingularH2Equiv_of_admissible (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C ε) 2 ≃ₗ[ℤ]
+      (Fin 4 → ℤ) :=
+  (((middleSecondHomologySplit C ε hε hε1 hC hR (1 / 2) (by norm_num)
+              (by norm_num)).toAddEquiv.trans
+          (AddEquiv.prodCongr
+            (middleOuterHomologyTwoEquiv C ε hε hε1 hC hR (1 / 2) (by norm_num)
+                (by norm_num)).toAddEquiv
+            (AddEquiv.refl ℤ))).trans
+      middleIntegerFourEquiv.toAddEquiv).toIntLinearEquiv
+
+private def CuspControlledRetraction.normalizedPosition (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (x : ToricSpace.Space) : (Fin 2 → ℝ) :=
+  ToricSpace.realCuspVector
+    (ToricSpace.inverseDisplacement (CuspPositive.positiveTwist C₀) (ToricSpace.time x)
+      (ToricSpace.position x))
+
+private theorem CuspControlledRetraction.inverseDisplacement_positiveTwist_norm
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (t : ℂ) :
+    ToricSpace.inverseDisplacement (CuspPositive.positiveTwist C₀) (‖t‖ : ℂ) =
+      ToricSpace.inverseDisplacement (CuspPositive.positiveTwist C₀) t := by
+  unfold ToricSpace.inverseDisplacement
+  congr 1
+  simp only [ToricSpace.displacementMatrix, CuspPositive.driftMatrix_positiveTwist,
+    Complex.norm_of_nonneg (norm_nonneg t)]
+
+private theorem CuspControlledRetraction.realCuspVector_continuous :
+    Continuous ToricSpace.realCuspVector := by
+  apply continuous_pi
+  intro i
+  fin_cases i
+  · exact continuous_apply 1
+  · exact (continuous_apply 0).neg
+
+private theorem
+    CuspControlledRetraction.normalizedPosition_continuousAt (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    {ε : ℝ} (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε)
+    {x : ToricSpace.Space} (hx : ToricSpace.time x ≠ 0) (ht : ‖ToricSpace.time x‖ < ε) :
+    ContinuousAt (normalizedPosition C₀) x := by
+  have htpos : 0 < ‖ToricSpace.time x‖ := norm_pos_iff.mpr hx
+  have hlog : Real.log ‖ToricSpace.time x‖ < 0 := Real.log_neg htpos (ht.trans hε1)
+  have hinv :=
+    ToricSpace.inverseDisplacement_continuousAt (CuspPositive.positiveTwist C₀)
+      (fun _ _ => continuousAt_const) hlog (hR _ htpos ht) (ToricSpace.position x)
+  have hp :
+    ContinuousAt (fun y : ToricSpace.Space => (ToricSpace.time y, ToricSpace.position y)) x :=
+    ToricSpace.time_holomorphic.continuous.continuousAt.prodMk
+      (ToricSpace.position_continuousAt hx hlog.ne)
+  exact
+    realCuspVector_continuous.continuousAt.comp
+      (ContinuousAt.comp (f := fun y : ToricSpace.Space =>
+        (ToricSpace.time y, ToricSpace.position y)) (g := fun p : ℂ × (Fin 2 → ℝ) =>
+        ToricSpace.inverseDisplacement (CuspPositive.positiveTwist C₀) p.1 p.2) hinv hp)
+
+private theorem CuspControlledRetraction.normalizedPosition_twistedTranslate
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {ε : ℝ} (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (v : Fin 2 → ℤ)
+    {x : ToricSpace.Space} (hx : ToricSpace.time x ≠ 0) (ht : ‖ToricSpace.time x‖ < ε) :
+    normalizedPosition C₀ (ToricSpace.twistedTranslate (CuspPositive.positiveTwist C₀) v x) =
+      normalizedPosition C₀ x + CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v) := by
+  have htpos : 0 < ‖ToricSpace.time x‖ := norm_pos_iff.mpr hx
+  have hlog : Real.log ‖ToricSpace.time x‖ < 0 := Real.log_neg htpos (ht.trans hε1)
+  unfold normalizedPosition
+  rw [ToricSpace.time_twistedTranslate,
+    ToricSpace.position_twistedTranslate_displacement (CuspPositive.positiveTwist C₀) v
+      ((ToricSpace.mem_openTorus_iff x).mpr hx) hlog.ne,
+    ToricSpace.inverseDisplacement_add,
+    ToricSpace.inverseDisplacement_displacement (CuspPositive.positiveTwist C₀) hlog
+      (hR _ htpos ht),
+    map_add, ToricSpace.realCuspVector_latticeReal]
+  rfl
+
+private theorem CuspControlledRetraction.normalizedPosition_closedPositive_continuousAt
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (hηε : η < ε)
+    {q : ToricSpace.ClosedPositiveTube η} (hq : ToricSpace.time (q.1 : ToricSpace.Space) ≠ 0) :
+    ContinuousAt
+      (fun r : ToricSpace.ClosedPositiveTube η => normalizedPosition C₀ (r.1 : ToricSpace.Space))
+      q :=
+  ContinuousAt.comp (f := fun r : ToricSpace.ClosedPositiveTube η => (r.1 : ToricSpace.Space))
+    (g := normalizedPosition C₀) (normalizedPosition_continuousAt C₀ hε1 hR hq (q.2.trans_lt hηε))
+    (continuous_subtype_val.comp continuous_subtype_val).continuousAt
+
+private theorem CuspControlledRetraction.normalizedPosition_closedPositive_continuousOn
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (hηε : η < ε) :
+    ContinuousOn
+      (fun q : ToricSpace.ClosedPositiveTube η => normalizedPosition C₀ (q.1 : ToricSpace.Space))
+      {q | ToricSpace.time (q.1 : ToricSpace.Space) ≠ 0} := by
+  intro q hq
+  exact (normalizedPosition_closedPositive_continuousAt C₀ hε1 hR hηε hq).continuousWithinAt
+
+private theorem CuspControlledRetraction.normalizedPosition_closedPositive_twistedTranslate
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (hηε : η < ε) (v : Fin 2 → ℤ)
+    {q : ToricSpace.ClosedPositiveTube η} (hq : ToricSpace.time (q.1 : ToricSpace.Space) ≠ 0) :
+    normalizedPosition C₀ ((CuspPositive.closedPositiveTranslate C₀ η v q).1 : ToricSpace.Space) =
+      normalizedPosition C₀ (q.1 : ToricSpace.Space) +
+        CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v) :=
+  normalizedPosition_twistedTranslate C₀ hε1 hR v hq (q.2.trans_lt hηε)
+
+private noncomputable def CuspControlledRetraction.Interpolation.tentWeight (ρ r : ℝ) : ℝ :=
+  Max.max 0 (1 - |r - ρ| / (ρ / 2))
+
+private theorem CuspControlledRetraction.Interpolation.tentWeight_continuous (ρ : ℝ) :
+    Continuous (tentWeight ρ) :=
+  continuous_const.max
+    (continuous_const.sub ((continuous_id.sub continuous_const).abs.div_const (ρ / 2)))
+
+private theorem
+    CuspControlledRetraction.Interpolation.tentWeight_self (ρ : ℝ) : tentWeight ρ ρ = 1 := by
+  simp [tentWeight]
+
+private theorem CuspControlledRetraction.Interpolation.tentWeight_eq_zero_of_half_le_abs {ρ : ℝ}
+    (hρ : 0 < ρ) (r : ℝ) (hr : ρ / 2 ≤ |r - ρ|) : tentWeight ρ r = 0 := by
+  apply max_eq_left
+  have hdiv : 1 ≤ |r - ρ| / (ρ / 2) :=
+    (le_div_iff₀ (half_pos hρ)).mpr (by simpa only [one_mul] using hr)
+  linarith
+
+private theorem
+    CuspControlledRetraction.Interpolation.tentWeight_eq_zero_of_le_half {ρ : ℝ} (hρ : 0 < ρ)
+    (r : ℝ) (hr : r ≤ ρ / 2) : tentWeight ρ r = 0 := by
+  apply tentWeight_eq_zero_of_half_le_abs hρ r
+  linarith [neg_le_abs (r - ρ)]
+
+private noncomputable def CuspControlledRetraction.Interpolation.interpolate {X E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] (ρ : ℝ) (h : X → ℝ) (a b : X → E)
+    (p : unitInterval × X) : E :=
+  a p.2 + ((p.1 : ℝ) * tentWeight ρ (h p.2)) • (b p.2 - a p.2)
+
+private theorem CuspControlledRetraction.Interpolation.interpolate_zero {X E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] (ρ : ℝ) (h : X → ℝ) (a b : X → E) (x : X) :
+    interpolate ρ h a b (0, x) = a x := by simp [interpolate]
+
+private theorem
+    CuspControlledRetraction.Interpolation.interpolate_eq_left_of_height_le_half {X E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] (ρ : ℝ) (h : X → ℝ) (a b : X → E) (hρ : 0 < ρ)
+    (s : unitInterval) (x : X) (hx : h x ≤ ρ / 2) : interpolate ρ h a b (s, x) = a x := by
+  simp only [interpolate, tentWeight_eq_zero_of_le_half hρ (h x) hx, MulZeroClass.mul_zero,
+    zero_smul, add_zero]
+
+private theorem
+    CuspControlledRetraction.Interpolation.interpolate_fixed_of_height_zero {X E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] (ρ : ℝ) (h : X → ℝ) (a b : X → E) (hρ : 0 < ρ)
+    (s : unitInterval) (x : X) (hx : h x = 0) : interpolate ρ h a b (s, x) = a x :=
+  interpolate_eq_left_of_height_le_half ρ h a b hρ s x (by rw [hx]; exact (half_pos hρ).le)
+
+private theorem CuspControlledRetraction.Interpolation.interpolate_one_of_height_eq {X E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] (ρ : ℝ) (h : X → ℝ) (a b : X → E) (x : X)
+    (hx : h x = ρ) : interpolate ρ h a b (1, x) = b x := by
+  simp [interpolate, hx, tentWeight_self]
+
+private theorem CuspControlledRetraction.Interpolation.interpolate_translate {X E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] (ρ : ℝ) (h : X → ℝ) (a b : X → E) (hρ : 0 < ρ)
+    (T : X → X) (d : E) (hT : ∀ x, h (T x) = h x) (ha : ∀ x, a (T x) = a x + d)
+    (hb : ∀ x, h x ≠ 0 → b (T x) = b x + d) (s : unitInterval) (x : X) :
+    interpolate ρ h a b (s, T x) = interpolate ρ h a b (s, x) + d := by
+  by_cases hx : h x = 0
+  · rw [interpolate_fixed_of_height_zero ρ h a b hρ s (T x) ((hT x).trans hx),
+      interpolate_fixed_of_height_zero ρ h a b hρ s x hx, ha x]
+  · simp only [interpolate, hT x, ha x, hb x hx, add_sub_add_right_eq_sub]
+    exact add_right_comm _ _ _
+
+private theorem CuspControlledRetraction.Interpolation.interpolate_continuous {X E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace X] (ρ : ℝ) (h : X → ℝ)
+    (a b : X → E) (hρ : 0 < ρ) (hh : Continuous h) (ha : Continuous a)
+    (hb : ContinuousOn b {x : X | h x ≠ 0}) : Continuous (interpolate ρ h a b) := by
+  have hw : Continuous (fun p : unitInterval × X => (p.1 : ℝ) * tentWeight ρ (h p.2)) :=
+    (continuous_subtype_val.comp continuous_fst).mul
+      ((tentWeight_continuous ρ).comp (hh.comp continuous_snd))
+  have hu : ContinuousOn (interpolate ρ h a b) {p : unitInterval × X | h p.2 ≠ 0} :=
+    (ha.comp continuous_snd).continuousOn.add
+      (hw.continuousOn.smul
+        ((hb.comp continuous_snd.continuousOn (fun _ hp => hp)).sub
+          (ha.comp continuous_snd).continuousOn))
+  have hv : ContinuousOn (interpolate ρ h a b) {p : unitInterval × X | h p.2 < ρ / 2} :=
+    (ha.comp continuous_snd).continuousOn.congr fun p hp =>
+      interpolate_eq_left_of_height_le_half ρ h a b hρ p.1 p.2 hp.le
+  have hcover :
+    {p : unitInterval × X | h p.2 ≠ 0} ∪ {p : unitInterval × X | h p.2 < ρ / 2} = Set.univ := by
+    apply Set.eq_univ_of_forall
+    intro p
+    by_cases hp : h p.2 = 0
+    · right
+      change h p.2 < ρ / 2
+      rw [hp]
+      exact half_pos hρ
+    · exact Or.inl hp
+  rw [← continuousOn_univ, ← hcover]
+  exact
+    hu.union_of_isOpen hv (isOpen_ne_fun (hh.comp continuous_snd) continuous_const)
+      (isOpen_Iio.preimage (hh.comp continuous_snd))
+
+private def
+    CuspControlledRetraction.positiveHeight {η : ℝ} (q : ToricSpace.ClosedPositiveTube η) : ℝ :=
+  ‖ToricSpace.time (q.1 : ToricSpace.Space)‖
+
+private theorem CuspControlledRetraction.positiveHeight_continuous {η : ℝ} :
+    Continuous (positiveHeight : ToricSpace.ClosedPositiveTube η → ℝ) :=
+  (ToricSpace.time_holomorphic.continuous.comp
+      (continuous_subtype_val.comp continuous_subtype_val)).norm
+
+private theorem
+    CuspControlledRetraction.positiveHeight_translate (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (η : ℝ)
+    (v : Fin 2 → ℤ) (q : ToricSpace.ClosedPositiveTube η) :
+    positiveHeight (CuspPositive.closedPositiveTranslate C₀ η v q) = positiveHeight q := by
+  change
+    ‖ToricSpace.time
+          (ToricSpace.twistedTranslate (CuspPositive.positiveTwist C₀) v
+            (q.1 : ToricSpace.Space))‖ =
+      _
+  rw [ToricSpace.time_twistedTranslate]
+  rfl
+
+private def CuspControlledRetraction.positiveEndpoint {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hone :
+      ∀ q : ToricSpace.ClosedPositiveTube η,
+        ToricSpace.time ((P (1, q)).1 : ToricSpace.Space) = 0) :
+    C(ToricSpace.ClosedPositiveTube η, CuspPositiveRetraction.PositiveCentralFibre)
+    where
+  toFun q := ⟨(P (1, q)).1, hone q⟩
+  continuous_toFun :=
+    (continuous_subtype_val.comp
+          (P.continuous.comp (continuous_const.prodMk continuous_id))).subtype_mk
+      _
+
+private def CuspControlledRetraction.endpointPosition {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hone :
+      ∀ q : ToricSpace.ClosedPositiveTube η,
+        ToricSpace.time ((P (1, q)).1 : ToricSpace.Space) = 0)
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    C(ToricSpace.ClosedPositiveTube η, CuspHoneycombTiling.Plane)
+    where
+  toFun q := (CuspHoneycomb.honeycombHomeomorph C₀).symm (positiveEndpoint P hone q)
+  continuous_toFun :=
+    (CuspHoneycomb.honeycombHomeomorph C₀).symm.continuous.comp
+      (positiveEndpoint P hone).continuous
+
+private theorem CuspControlledRetraction.positiveEndpoint_equivariant {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hone :
+      ∀ q : ToricSpace.ClosedPositiveTube η,
+        ToricSpace.time ((P (1, q)).1 : ToricSpace.Space) = 0)
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (hequiv :
+      ∀ s v q,
+        P (s, CuspPositive.closedPositiveTranslate C₀ η v q) =
+          CuspPositive.closedPositiveTranslate C₀ η v (P (s, q)))
+    (v : Fin 2 → ℤ) (q : ToricSpace.ClosedPositiveTube η) :
+    positiveEndpoint P hone (CuspPositive.closedPositiveTranslate C₀ η v q) =
+      CuspCollapse.positiveCentralTranslate C₀ v (positiveEndpoint P hone q) := by
+  apply Subtype.ext
+  exact congrArg (fun x : ToricSpace.ClosedPositiveTube η => x.1) (hequiv 1 v q)
+
+private theorem CuspControlledRetraction.endpointPosition_equivariant {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hone :
+      ∀ q : ToricSpace.ClosedPositiveTube η,
+        ToricSpace.time ((P (1, q)).1 : ToricSpace.Space) = 0)
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (hequiv :
+      ∀ s v q,
+        P (s, CuspPositive.closedPositiveTranslate C₀ η v q) =
+          CuspPositive.closedPositiveTranslate C₀ η v (P (s, q)))
+    (v : Fin 2 → ℤ) (q : ToricSpace.ClosedPositiveTube η) :
+    endpointPosition P hone C₀ (CuspPositive.closedPositiveTranslate C₀ η v q) =
+      endpointPosition P hone C₀ q + CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v) :=
+  by
+  change
+    (CuspHoneycomb.honeycombHomeomorph C₀).symm
+        (positiveEndpoint P hone (CuspPositive.closedPositiveTranslate C₀ η v q)) =
+      _
+  rw [positiveEndpoint_equivariant P hone C₀ hequiv,
+    CuspHoneycomb.honeycombHomeomorph_symm_equivariant]
+  rfl
+
+private theorem CuspControlledRetraction.normalizedPosition_height_continuousOn_mo1973_13101
+    {η : ℝ} (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {ε : ℝ} (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (hηε : η < ε) :
+    ContinuousOn
+      (fun q : ToricSpace.ClosedPositiveTube η => normalizedPosition C₀ (q.1 : ToricSpace.Space))
+      {q | positiveHeight q ≠ 0} := by
+  simpa only [positiveHeight, ne_eq, norm_eq_zero] using
+    normalizedPosition_closedPositive_continuousOn C₀ hε1 hR hηε
+
+private def CuspControlledRetraction.centralInterpolation {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hone :
+      ∀ q : ToricSpace.ClosedPositiveTube η,
+        ToricSpace.time ((P (1, q)).1 : ToricSpace.Space) = 0)
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {ε : ℝ} (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (hηε : η < ε) (hη : 0 ≤ η)
+    (ρ : ℝ) (hρ : 0 < ρ) :
+    C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η)
+    where
+  toFun
+    p :=
+    CuspPositiveRetraction.positiveCentralInclusion η hη
+      (CuspHoneycomb.honeycombHomeomorph C₀
+        (Interpolation.interpolate ρ positiveHeight (endpointPosition P hone C₀)
+          (fun q => normalizedPosition C₀ (q.1 : ToricSpace.Space)) p))
+  continuous_toFun :=
+    (CuspPositiveRetraction.positiveCentralInclusion η hη).continuous.comp
+      ((CuspHoneycomb.honeycombHomeomorph C₀).continuous.comp
+        (Interpolation.interpolate_continuous ρ positiveHeight (endpointPosition P hone C₀)
+          (fun q => normalizedPosition C₀ (q.1 : ToricSpace.Space)) hρ positiveHeight_continuous
+          (endpointPosition P hone C₀).continuous
+          (normalizedPosition_height_continuousOn_mo1973_13101 C₀ hε1 hR hηε)))
+
+private theorem CuspControlledRetraction.centralInterpolation_apply {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hone :
+      ∀ q : ToricSpace.ClosedPositiveTube η,
+        ToricSpace.time ((P (1, q)).1 : ToricSpace.Space) = 0)
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {ε : ℝ} (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (hηε : η < ε) (hη : 0 ≤ η)
+    (ρ : ℝ) (hρ : 0 < ρ) (s : unitInterval) (q : ToricSpace.ClosedPositiveTube η) :
+    centralInterpolation P hone C₀ hε1 hR hηε hη ρ hρ (s, q) =
+      CuspPositiveRetraction.positiveCentralInclusion η hη
+        (CuspHoneycomb.honeycombHomeomorph C₀
+          (Interpolation.interpolate ρ positiveHeight (endpointPosition P hone C₀)
+            (fun r => normalizedPosition C₀ (r.1 : ToricSpace.Space)) (s, q))) :=
+  rfl
+
+private theorem CuspControlledRetraction.centralInterpolation_zero {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hone :
+      ∀ q : ToricSpace.ClosedPositiveTube η,
+        ToricSpace.time ((P (1, q)).1 : ToricSpace.Space) = 0)
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {ε : ℝ} (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (hηε : η < ε) (hη : 0 ≤ η)
+    (ρ : ℝ) (hρ : 0 < ρ) (q : ToricSpace.ClosedPositiveTube η) :
+    centralInterpolation P hone C₀ hε1 hR hηε hη ρ hρ (0, q) = P (1, q) := by
+  rw [centralInterpolation_apply, Interpolation.interpolate_zero]
+  change
+    CuspPositiveRetraction.positiveCentralInclusion η hη
+        (CuspHoneycomb.honeycombHomeomorph C₀
+          ((CuspHoneycomb.honeycombHomeomorph C₀).symm (positiveEndpoint P hone q))) =
+      _
+  rw [Homeomorph.apply_symm_apply]
+  rfl
+
+private theorem CuspControlledRetraction.centralInterpolation_central {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hone :
+      ∀ q : ToricSpace.ClosedPositiveTube η,
+        ToricSpace.time ((P (1, q)).1 : ToricSpace.Space) = 0)
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {ε : ℝ} (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (hηε : η < ε) (hη : 0 ≤ η)
+    (ρ : ℝ) (hρ : 0 < ρ) (s : unitInterval) (q : ToricSpace.ClosedPositiveTube η) :
+    ToricSpace.time
+        ((centralInterpolation P hone C₀ hε1 hR hηε hη ρ hρ (s, q)).1 : ToricSpace.Space) =
+      0 :=
+  (CuspHoneycomb.honeycombHomeomorph C₀
+      (Interpolation.interpolate ρ positiveHeight (endpointPosition P hone C₀)
+        (fun r => normalizedPosition C₀ (r.1 : ToricSpace.Space)) (s, q))).2
+
+private theorem CuspControlledRetraction.centralInterpolation_eq_endpoint_of_height_le_half {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hone :
+      ∀ q : ToricSpace.ClosedPositiveTube η,
+        ToricSpace.time ((P (1, q)).1 : ToricSpace.Space) = 0)
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {ε : ℝ} (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (hηε : η < ε) (hη : 0 ≤ η)
+    (ρ : ℝ) (hρ : 0 < ρ) (s : unitInterval) (q : ToricSpace.ClosedPositiveTube η)
+    (hq : positiveHeight q ≤ ρ / 2) :
+    centralInterpolation P hone C₀ hε1 hR hηε hη ρ hρ (s, q) = P (1, q) := by
+  rw [centralInterpolation_apply,
+    Interpolation.interpolate_eq_left_of_height_le_half _ _ _ _ hρ s q hq]
+  change
+    CuspPositiveRetraction.positiveCentralInclusion η hη
+        (CuspHoneycomb.honeycombHomeomorph C₀
+          ((CuspHoneycomb.honeycombHomeomorph C₀).symm (positiveEndpoint P hone q))) =
+      _
+  rw [Homeomorph.apply_symm_apply]
+  rfl
+
+private theorem CuspControlledRetraction.centralInterpolation_fixed {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hone :
+      ∀ q : ToricSpace.ClosedPositiveTube η,
+        ToricSpace.time ((P (1, q)).1 : ToricSpace.Space) = 0)
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {ε : ℝ} (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (hηε : η < ε) (hη : 0 ≤ η)
+    (ρ : ℝ) (hρ : 0 < ρ)
+    (hfix : ∀ s q, ToricSpace.time (q.1 : ToricSpace.Space) = 0 → P (s, q) = q)
+    (s : unitInterval) (q : ToricSpace.ClosedPositiveTube η)
+    (hq : ToricSpace.time (q.1 : ToricSpace.Space) = 0) :
+    centralInterpolation P hone C₀ hε1 hR hηε hη ρ hρ (s, q) = q := by
+  rw [centralInterpolation_eq_endpoint_of_height_le_half P hone C₀ hε1 hR hηε hη ρ hρ s q
+      (by simpa only [positiveHeight, hq, norm_zero] using (half_pos hρ).le)]
+  exact hfix 1 q hq
+
+private theorem CuspControlledRetraction.centralInterpolation_equivariant {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hone :
+      ∀ q : ToricSpace.ClosedPositiveTube η,
+        ToricSpace.time ((P (1, q)).1 : ToricSpace.Space) = 0)
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {ε : ℝ} (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (hηε : η < ε) (hη : 0 ≤ η)
+    (ρ : ℝ) (hρ : 0 < ρ)
+    (hequiv :
+      ∀ s v q,
+        P (s, CuspPositive.closedPositiveTranslate C₀ η v q) =
+          CuspPositive.closedPositiveTranslate C₀ η v (P (s, q)))
+    (s : unitInterval) (v : Fin 2 → ℤ) (q : ToricSpace.ClosedPositiveTube η) :
+    centralInterpolation P hone C₀ hε1 hR hηε hη ρ hρ
+        (s, CuspPositive.closedPositiveTranslate C₀ η v q) =
+      CuspPositive.closedPositiveTranslate C₀ η v
+        (centralInterpolation P hone C₀ hε1 hR hηε hη ρ hρ (s, q)) := by
+  have he :=
+    Interpolation.interpolate_translate ρ positiveHeight (endpointPosition P hone C₀)
+      (fun q => normalizedPosition C₀ (q.1 : ToricSpace.Space)) hρ
+      (CuspPositive.closedPositiveTranslate C₀ η v)
+      (CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v))
+      (positiveHeight_translate C₀ η v) (endpointPosition_equivariant P hone C₀ hequiv v)
+      (fun q hq =>
+        normalizedPosition_closedPositive_twistedTranslate C₀ hε1 hR hηε v
+          (norm_ne_zero_iff.mp hq))
+      s q
+  rw [centralInterpolation_apply, he, CuspHoneycomb.honeycombHomeomorph_equivariant]
+  rfl
+
+private theorem CuspControlledRetraction.centralInterpolation_nonincreasing {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hone :
+      ∀ q : ToricSpace.ClosedPositiveTube η,
+        ToricSpace.time ((P (1, q)).1 : ToricSpace.Space) = 0)
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {ε : ℝ} (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (hηε : η < ε) (hη : 0 ≤ η)
+    (ρ : ℝ) (hρ : 0 < ρ) (s : unitInterval) (q : ToricSpace.ClosedPositiveTube η) :
+    positiveHeight (centralInterpolation P hone C₀ hε1 hR hηε hη ρ hρ (s, q)) ≤
+      positiveHeight q := by
+  change
+    ‖ToricSpace.time
+          ((centralInterpolation P hone C₀ hε1 hR hηε hη ρ hρ (s, q)).1 : ToricSpace.Space)‖ ≤
+      _
+  rw [centralInterpolation_central, norm_zero]
+  exact norm_nonneg _
+
+private theorem CuspControlledRetraction.centralInterpolation_one_of_height_eq {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hone :
+      ∀ q : ToricSpace.ClosedPositiveTube η,
+        ToricSpace.time ((P (1, q)).1 : ToricSpace.Space) = 0)
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {ε : ℝ} (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (hηε : η < ε) (hη : 0 ≤ η)
+    (ρ : ℝ) (hρ : 0 < ρ) (q : ToricSpace.ClosedPositiveTube η) (hq : positiveHeight q = ρ) :
+    centralInterpolation P hone C₀ hε1 hR hηε hη ρ hρ (1, q) =
+      CuspPositiveRetraction.positiveCentralInclusion η hη
+        (CuspHoneycomb.honeycombHomeomorph C₀ (normalizedPosition C₀ (q.1 : ToricSpace.Space))) :=
+  by rw [centralInterpolation_apply, Interpolation.interpolate_one_of_height_eq _ _ _ _ q hq]
+
+private def CuspControlledRetraction.Concatenation.slice {X Y : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] (P : C(unitInterval × X, Y)) (s : unitInterval) : C(X, Y) :=
+  ⟨fun x => P (s, x), P.continuous.comp (continuous_const.prodMk continuous_id)⟩
+
+private def CuspControlledRetraction.Concatenation.asHomotopy {X Y : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] (P : C(unitInterval × X, Y)) : (slice P 0).Homotopy (slice P 1)
+    where
+  toContinuousMap := P
+  map_zero_left _ := rfl
+  map_one_left _ := rfl
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/CuspFibre/CuspCentralHomology4.lean b/LeanPool/HopfProblem/CuspFibre/CuspCentralHomology4.lean
new file mode 100644
index 000000000..c72e1470c
--- /dev/null
+++ b/LeanPool/HopfProblem/CuspFibre/CuspCentralHomology4.lean
@@ -0,0 +1,4639 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology8
+public import LeanPool.HopfProblem.HomologyOfX.CuspCoinvariants
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.CuspFibre.CuspCentralHomology2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology3
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology4
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.Toric.ToricSpace2
+import all LeanPool.HopfProblem.CuspFibre.CuspPositiveRetraction
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Toric.CuspHoneycombHexagon
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology7
+import all LeanPool.HopfProblem.CuspFibre.CuspCentralHomology1
+import all LeanPool.HopfProblem.CuspFibre.CuspCentralHomology3
+import all LeanPool.HopfProblem.CuspFibre.CuspSpecialization
+import all LeanPool.HopfProblem.HomologyOfX.CuspCoinvariants
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology8
+
+/-!
+# Hopf problem: cusp fibre · cusp central homology 4
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem CuspSpecialization.torusDifference_one_coordinates
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 1) :
+    coordinateTorusH1Coordinates (CuspCoinvariants.torusDifference 1 a) =
+      CuspCoinvariants.oneDifference (coordinateTorusH1Coordinates a) := by
+  rw [CuspCoinvariants.torusDifference_apply, map_sub, coordinateTorusH1Coordinates_matrix]
+  simp only [CuspCoinvariants.oneDifference, Matrix.mulVecLin_apply, Matrix.sub_mulVec,
+    Matrix.one_mulVec]
+
+private def CuspSpecialization.torusOneCoinvariantEquiv :
+    CuspCoinvariants.TorusCoinvariants 1 ≃ₗ[ℤ] (Fin 2 → ℤ) :=
+  ((CuspCoinvariants.quotientRangeEquiv coordinateTorusH1Coordinates
+          (CuspCoinvariants.torusDifference 1) CuspCoinvariants.oneDifference
+          torusDifference_one_coordinates).toAddEquiv.trans
+      CuspCoinvariants.oneCoinvariantEquiv.toAddEquiv).toIntLinearEquiv
+
+private def CuspCentralHomology.baseTorusPoint (y : CuspHoneycombTiling.Plane) :
+    PeriodTorusHigherHomology.ProductTorus 2 :=
+  PeriodTorusHigherHomology.coordinateProjection 2 (CuspSpecialization.sourceBaseMarking y)
+
+@[simp]
+private theorem CuspCentralHomology.baseTorusPoint_apply (y : CuspHoneycombTiling.Plane) :
+    baseTorusPoint y =
+      PeriodTorusHigherHomology.coordinateProjection 2 (-ToricSpace.realCuspVector y) :=
+  rfl
+
+private theorem CuspCentralHomology.baseTorusPoint_continuous : Continuous baseTorusPoint :=
+  (PeriodTorusHigherHomology.coordinateProjection_continuous 2).comp
+    CuspSpecialization.sourceBaseMarking.continuous
+
+private theorem
+    CuspCentralHomology.baseTorusPoint_surjective : Function.Surjective baseTorusPoint :=
+  (PeriodTorusHigherHomology.coordinateProjection_surjective 2).comp
+    CuspSpecialization.sourceBaseMarking.surjective
+
+private theorem
+    CuspCentralHomology.baseTorusPoint_deck (v : Fin 2 → ℤ) (y : CuspHoneycombTiling.Plane) :
+    baseTorusPoint (y + CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v)) =
+      baseTorusPoint y := by
+  apply (CuspSpecialization.sourceCoordinateProjection_eq_iff _ _).mpr
+  exact ⟨v, CuspSpecialization.sourceBaseMarking_deck v y⟩
+
+private theorem CuspCentralHomology.baseTorusPoint_realCuspVector (y : CuspHoneycombTiling.Plane) :
+    baseTorusPoint (ToricSpace.realCuspVector y) =
+      PeriodTorusHigherHomology.coordinateProjection 2 y := by
+  change
+    PeriodTorusHigherHomology.coordinateProjection 2
+        (CuspSpecialization.sourceBaseMarking (CuspSpecialization.sourceBaseMarking.symm y)) =
+      _
+  rw [Homeomorph.apply_symm_apply]
+
+private theorem CuspCentralHomology.baseTorusPoint_eq_iff (y z : CuspHoneycombTiling.Plane) :
+    baseTorusPoint y = baseTorusPoint z ↔
+      ∃ v : Fin 2 → ℤ, y = z + CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v) := by
+  constructor
+  · intro h
+    obtain ⟨v, hv⟩ := (CuspSpecialization.sourceCoordinateProjection_eq_iff _ _).mp h
+    refine ⟨v, CuspSpecialization.sourceBaseMarking.injective ?_⟩
+    rw [CuspSpecialization.sourceBaseMarking_deck]
+    exact hv
+  · rintro ⟨v, rfl⟩
+    exact baseTorusPoint_deck v z
+
+private theorem CuspCentralHomology.baseTorusPoint_eq_of_collapse_eq_mo1973_14352
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) (p q : CuspHoneycomb.PhasePlane)
+    (h :
+      CuspHoneycomb.honeycombCollapseMap C r hr p = CuspHoneycomb.honeycombCollapseMap C r hr q) :
+    baseTorusPoint p.2 = baseTorusPoint q.2 := by
+  obtain ⟨v, hv, _⟩ := (CuspHoneycomb.honeycombCollapseMap_eq_iff C r hr p q).mp h
+  rw [hv, baseTorusPoint_deck]
+
+private def CuspCentralHomology.baseTorusProjection (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) :
+    CuspRetraction.QuotientCentralFibre C r → PeriodTorusHigherHomology.ProductTorus 2 :=
+  CuspHoneycombHexagon.CommonFibres.descend (CuspHoneycomb.honeycombCollapseMap C r hr)
+    (fun p => baseTorusPoint p.2) (CuspHoneycomb.honeycombCollapseMap_surjective C r hr)
+
+@[simp]
+private theorem CuspCentralHomology.baseTorusProjection_honeycombCollapseMap
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) (p : CuspHoneycomb.PhasePlane) :
+    baseTorusProjection C r hr (CuspHoneycomb.honeycombCollapseMap C r hr p) =
+      baseTorusPoint p.2 :=
+  CuspHoneycombHexagon.CommonFibres.descend_apply _ _ _
+    (baseTorusPoint_eq_of_collapse_eq_mo1973_14352 C r hr) p
+
+private theorem
+    CuspCentralHomology.baseTorusProjection_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Continuous (baseTorusProjection C r hr) :=
+  CuspHoneycombHexagon.CommonFibres.descend_continuous _ _ _
+    (CuspHoneycomb.honeycombCollapseMap_isQuotientMap C r hr hC)
+    (baseTorusPoint_continuous.comp continuous_snd)
+    (baseTorusPoint_eq_of_collapse_eq_mo1973_14352 C r hr)
+
+private def CuspCentralHomology.baseTorusProjectionMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    C(CuspRetraction.QuotientCentralFibre C r, PeriodTorusHigherHomology.ProductTorus 2) :=
+  ⟨baseTorusProjection C r hr, baseTorusProjection_continuous C r hr hC⟩
+
+@[simp]
+private theorem
+    CuspCentralHomology.baseTorusProjection_productCollapse (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r)
+    (p : ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2) :
+    baseTorusProjection C r hr (CuspSpecialization.productCollapse C r hr p) = p.2 := by
+  rcases p with ⟨u, t⟩
+  obtain ⟨y, rfl⟩ := PeriodTorusHigherHomology.coordinateProjection_surjective 2 t
+  rw [CuspSpecialization.productCollapse_coordinateProjection,
+    baseTorusProjection_honeycombCollapseMap]
+  exact baseTorusPoint_realCuspVector y
+
+private def
+    CuspCentralHomology.baseTorusSection (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) :
+    C(PeriodTorusHigherHomology.ProductTorus 2, CuspRetraction.QuotientCentralFibre C r)
+    where
+  toFun t := CuspSpecialization.productCollapse C r hr (1, t)
+  continuous_toFun :=
+    (CuspSpecialization.productCollapse C r hr).continuous.comp
+      (continuous_const.prodMk continuous_id)
+
+@[simp]
+private theorem
+    CuspCentralHomology.baseTorusProjection_section (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (t : PeriodTorusHigherHomology.ProductTorus 2) :
+    baseTorusProjection C r hr (baseTorusSection C r hr t) = t :=
+  baseTorusProjection_productCollapse C r hr (1, t)
+
+private abbrev CuspCentralHomology.Theta :=
+  Suspension (Fin 3)
+
+private def CuspCentralHomology.thetaEdgeIndex (j : Fin 3) : Fin 6 :=
+  j.castLE (by decide)
+
+private def CuspCentralHomology.thetaCircleInclusion (j : Fin 3) (z : Circle) : ThreeCircles :=
+  ![Sum.inl z, Sum.inr (Sum.inl z), Sum.inr (Sum.inr z)] j
+
+private theorem CuspCentralHomology.thetaCircleInclusion_continuous (j : Fin 3) :
+    Continuous (thetaCircleInclusion j) := by
+  fin_cases j
+  · exact continuous_inl
+  · exact continuous_inr.comp continuous_inl
+  · exact continuous_inr.comp continuous_inr
+
+private def
+    CuspCentralHomology.thetaCharacterMap : C(ToricSpace.CompactFibreTorus × Fin 3, ThreeCircles)
+    where
+  toFun p := thetaCircleInclusion p.2 (hexagonCharacter (thetaEdgeIndex p.2) p.1)
+  continuous_toFun :=
+    continuous_prod_of_discrete_right.mpr fun j =>
+      (thetaCircleInclusion_continuous j).comp
+        (edgeCharacter_continuous (ToricComponent.hexagonRay (thetaEdgeIndex j)))
+
+private def CuspCentralHomology.thetaCharacterCollapseFun_mo1973_14386
+    (p : ToricSpace.CompactFibreTorus × Theta) : ThreeCircleSuspension :=
+  Quotient.lift (s := suspensionSetoid (Fin 3))
+    (fun q => Suspension.mk q.1 (thetaCharacterMap (p.1, q.2)))
+    (fun a b hab => by
+      apply (Suspension.mk_eq_mk_iff _ _ _ _).mpr
+      rcases hab with ⟨ht, hzero | hone | hj⟩
+      · exact ⟨ht, Or.inl hzero⟩
+      · exact ⟨ht, Or.inr (Or.inl hone)⟩
+      · exact ⟨ht, Or.inr (Or.inr (by rw [hj]))⟩)
+    p.2
+
+private theorem CuspCentralHomology.thetaCharacterCollapseFun_continuous_mo1973_14387 :
+    Continuous thetaCharacterCollapseFun_mo1973_14386 := by
+  apply (Suspension.isQuotientMap_mk (X := Fin 3)).continuous_lift_prod_right
+  change
+    Continuous
+      (fun p : ToricSpace.CompactFibreTorus × (unitInterval × Fin 3) =>
+        Suspension.mk p.2.1 (thetaCharacterMap (p.1, p.2.2)))
+  exact
+    Suspension.continuous_mk.comp
+      ((continuous_fst.comp continuous_snd).prodMk
+        (thetaCharacterMap.continuous.comp
+          (continuous_fst.prodMk (continuous_snd.comp continuous_snd))))
+
+private def CuspCentralHomology.thetaCharacterCollapse :
+    C(ToricSpace.CompactFibreTorus × Theta, ThreeCircleSuspension) :=
+  ⟨thetaCharacterCollapseFun_mo1973_14386, thetaCharacterCollapseFun_continuous_mo1973_14387⟩
+
+@[simp]
+private theorem CuspCentralHomology.thetaCharacterCollapse_mk (u : ToricSpace.CompactFibreTorus)
+    (t : unitInterval) (j : Fin 3) :
+    thetaCharacterCollapse (u, Suspension.mk t j) =
+      Suspension.mk t (thetaCircleInclusion j (hexagonCharacter (thetaEdgeIndex j) u)) :=
+  rfl
+
+@[simp]
+private theorem CuspCentralHomology.thetaCharacterCollapse_height
+    (p : ToricSpace.CompactFibreTorus × Theta) :
+    Suspension.height (thetaCharacterCollapse p) = Suspension.height p.2 := by
+  rcases p with ⟨u, q⟩
+  obtain ⟨⟨t, j⟩, rfl⟩ := Suspension.mk_surjective q
+  rfl
+
+private def CuspCentralHomology.thetaNorth : Set (ToricSpace.CompactFibreTorus × Theta) :=
+  Prod.snd ⁻¹' Suspension.northOpen
+
+private def CuspCentralHomology.thetaSouth : Set (ToricSpace.CompactFibreTorus × Theta) :=
+  Prod.snd ⁻¹' Suspension.southOpen
+
+@[simp]
+private theorem CuspCentralHomology.mem_thetaNorth (p : ToricSpace.CompactFibreTorus × Theta) :
+    p ∈ thetaNorth ↔ (Suspension.height p.2 : ℝ) < 3 / 4 :=
+  Iff.rfl
+
+@[simp]
+private theorem CuspCentralHomology.mem_thetaSouth (p : ToricSpace.CompactFibreTorus × Theta) :
+    p ∈ thetaSouth ↔ 1 / 4 < (Suspension.height p.2 : ℝ) :=
+  Iff.rfl
+
+private theorem CuspCentralHomology.thetaNorth_isOpen : IsOpen thetaNorth :=
+  Suspension.northOpen_isOpen.preimage continuous_snd
+
+private theorem CuspCentralHomology.thetaSouth_isOpen : IsOpen thetaSouth :=
+  Suspension.southOpen_isOpen.preimage continuous_snd
+
+private theorem CuspCentralHomology.theta_open_cover : thetaNorth ∪ thetaSouth = Set.univ := by
+  rw [thetaNorth, thetaSouth, ← Set.preimage_union, Suspension.open_cover, Set.preimage_univ]
+
+private theorem CuspCentralHomology.thetaCharacterCollapse_preimage_north :
+    thetaCharacterCollapse ⁻¹' Suspension.northOpen = thetaNorth := by
+  ext p
+  simp only [Set.mem_preimage, Suspension.mem_northOpen, mem_thetaNorth,
+    thetaCharacterCollapse_height]
+
+private theorem CuspCentralHomology.thetaCharacterCollapse_preimage_south :
+    thetaCharacterCollapse ⁻¹' Suspension.southOpen = thetaSouth := by
+  ext p
+  simp only [Set.mem_preimage, Suspension.mem_southOpen, mem_thetaSouth,
+    thetaCharacterCollapse_height]
+
+private theorem CuspCentralHomology.thetaCharacterCollapse_mapsTo_north :
+    Set.MapsTo thetaCharacterCollapse thetaNorth Suspension.northOpen := by
+  intro p hp
+  rw [← thetaCharacterCollapse_preimage_north] at hp
+  exact hp
+
+private theorem CuspCentralHomology.thetaCharacterCollapse_mapsTo_south :
+    Set.MapsTo thetaCharacterCollapse thetaSouth Suspension.southOpen := by
+  intro p hp
+  rw [← thetaCharacterCollapse_preimage_south] at hp
+  exact hp
+
+private def CuspCentralHomology.thetaCircleLabel : C(ThreeCircles, Fin 3)
+    where
+  toFun := Sum.elim (fun _ => 0) (Sum.elim (fun _ => 1) (fun _ => 2))
+  continuous_toFun := continuous_const.sumElim (continuous_const.sumElim continuous_const)
+
+@[simp]
+private theorem CuspCentralHomology.thetaCircleLabel_inl (z : _root_.Circle) :
+    thetaCircleLabel (Sum.inl z) = 0 :=
+  rfl
+
+@[simp]
+private theorem CuspCentralHomology.thetaCircleLabel_inr_inl (z : _root_.Circle) :
+    thetaCircleLabel (Sum.inr (Sum.inl z)) = 1 :=
+  rfl
+
+@[simp]
+private theorem CuspCentralHomology.thetaCircleLabel_inr_inr (z : _root_.Circle) :
+    thetaCircleLabel (Sum.inr (Sum.inr z)) = 2 :=
+  rfl
+
+@[simp]
+private theorem CuspCentralHomology.thetaCircleLabel_inclusion (j : Fin 3) (z : _root_.Circle) :
+    thetaCircleLabel (thetaCircleInclusion j z) = j := by fin_cases j <;> rfl
+
+private def CuspCentralHomology.thetaForgetCircleFun_mo1973_14410 :
+    ThreeCircleSuspension → Theta :=
+  Quotient.lift (s := suspensionSetoid ThreeCircles)
+    (fun p => Suspension.mk p.1 (thetaCircleLabel p.2))
+    (fun a b hab => by
+      apply (Suspension.mk_eq_mk_iff _ _ _ _).mpr
+      rcases hab with ⟨ht, hzero | hone | hz⟩
+      · exact ⟨ht, Or.inl hzero⟩
+      · exact ⟨ht, Or.inr (Or.inl hone)⟩
+      · exact ⟨ht, Or.inr (Or.inr (congrArg thetaCircleLabel hz))⟩)
+
+private theorem CuspCentralHomology.thetaForgetCircleFun_continuous_mo1973_14411 :
+    Continuous thetaForgetCircleFun_mo1973_14410 := by
+  apply (Suspension.isQuotientMap_mk (X := ThreeCircles)).continuous_iff.mpr
+  change
+    Continuous (fun p : unitInterval × ThreeCircles => Suspension.mk p.1 (thetaCircleLabel p.2))
+  exact
+    Suspension.continuous_mk.comp
+      (continuous_fst.prodMk (thetaCircleLabel.continuous.comp continuous_snd))
+
+private def CuspCentralHomology.thetaForgetCircle : C(ThreeCircleSuspension, Theta) :=
+  ⟨thetaForgetCircleFun_mo1973_14410, thetaForgetCircleFun_continuous_mo1973_14411⟩
+
+@[simp]
+private theorem CuspCentralHomology.thetaForgetCircle_mk (t : unitInterval) (z : ThreeCircles) :
+    thetaForgetCircle (Suspension.mk t z) = Suspension.mk t (thetaCircleLabel z) :=
+  rfl
+
+private theorem CuspCentralHomology.thetaForgetCircle_circle (t : unitInterval) (j : Fin 3)
+    (z : _root_.Circle) :
+    thetaForgetCircle (Suspension.mk t (thetaCircleInclusion j z)) = Suspension.mk t j := by
+  rw [thetaForgetCircle_mk, thetaCircleLabel_inclusion]
+
+@[simp]
+private theorem CuspCentralHomology.thetaForgetCircle_collapse (u : ToricSpace.CompactFibreTorus)
+    (q : Theta) : thetaForgetCircle (thetaCharacterCollapse (u, q)) = q := by
+  obtain ⟨⟨t, j⟩, rfl⟩ := Suspension.mk_surjective q
+  rw [thetaCharacterCollapse_mk, thetaForgetCircle_circle]
+
+private theorem CuspCentralHomology.threePoint_homology_subsingleton (n : ℕ) (hn : n ≠ 0) :
+    Subsingleton (SingularMayerVietoris.SingularHomology (Fin 3) n) :=
+  PeriodTorusHigherHomology.totallyDisconnected_homology_subsingleton (Fin 3) n hn
+
+private theorem CuspCentralHomology.theta_homology_subsingleton (n : ℕ) :
+    Subsingleton (SingularMayerVietoris.SingularHomology Theta (n + 2)) := by
+  let := threePoint_homology_subsingleton (n + 1) (Nat.succ_ne_zero n)
+  exact
+    ((contractibleCoverHomologyHigherEquiv (Suspension.northOpen : Set Theta) Suspension.southOpen
+            Suspension.northOpen_isOpen Suspension.southOpen_isOpen Suspension.open_cover n).trans
+        (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+          (Suspension.middleBandHomotopyEquiv (X := Fin 3)) (n + 1))).injective.subsingleton
+
+private def CuspCentralHomology.dualSidePoint (k : Fin 6) (t : unitInterval) :
+    (CuspHoneycombTiling.Plane) :=
+  CuspHoneycombTiling.dualStandardPlaneHomeomorph.symm
+    (CuspHoneycombHexagon.sideIntervalHomeomorph k t : (CuspHoneycombTiling.Plane))
+
+private theorem
+    CuspCentralHomology.dualSidePoint_continuous (k : Fin 6) : Continuous (dualSidePoint k) :=
+  CuspHoneycombTiling.dualStandardPlaneHomeomorph.symm.continuous.comp
+    (continuous_subtype_val.comp (CuspHoneycombHexagon.sideIntervalHomeomorph k).continuous)
+
+private theorem CuspCentralHomology.edgeArcBase_eq_dualSidePoint (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) (t : unitInterval) :
+    (edgeArcBase C₀ k t : (CuspHoneycombTiling.Plane)) = dualSidePoint k t := by
+  have h :
+    edgeArcBase C₀ k t =
+      CuspHoneycombTiling.standardHexagonDualHomeomorph
+        ⟨(CuspHoneycombHexagon.sideIntervalHomeomorph k t : (CuspHoneycombTiling.Plane)),
+          (CuspHoneycombHexagon.sideIntervalHomeomorph k t).2.1⟩ := by
+    apply (CuspHoneycombHexagon.compatibleCellHomeomorph C₀).injective
+    rw [compatibleCellHomeomorph_edgeArcBase,
+      CuspHoneycombHexagon.compatibleCellHomeomorph_sideInterval]
+  exact congrArg Subtype.val h
+
+private def CuspCentralHomology.orientedEdgeBasePoint (t : unitInterval) (j : Fin 3) :
+    (CuspHoneycombTiling.Plane) :=
+  dualSidePoint (thetaEdgeIndex j) (if j = 1 then unitInterval.symm t else t)
+
+@[simp]
+private theorem CuspCentralHomology.orientedEdgeBasePoint_zero (t : unitInterval) :
+    orientedEdgeBasePoint t 0 = dualSidePoint 0 t := by
+  simp [thetaEdgeIndex, orientedEdgeBasePoint]
+
+@[simp]
+private theorem CuspCentralHomology.orientedEdgeBasePoint_one (t : unitInterval) :
+    orientedEdgeBasePoint t 1 = dualSidePoint 1 (unitInterval.symm t) := by
+  simp [thetaEdgeIndex, orientedEdgeBasePoint]
+
+@[simp]
+private theorem CuspCentralHomology.orientedEdgeBasePoint_two (t : unitInterval) :
+    orientedEdgeBasePoint t 2 = dualSidePoint 2 t := by
+  simp [thetaEdgeIndex, orientedEdgeBasePoint]
+
+private theorem CuspCentralHomology.orientedEdgeBasePoint_continuous (j : Fin 3) :
+    Continuous (fun t => orientedEdgeBasePoint t j) := by
+  by_cases hj : j = 1
+  · simpa only [orientedEdgeBasePoint, ite_eq_left hj, Function.comp_def] using
+      (dualSidePoint_continuous (thetaEdgeIndex j)).comp unitInterval.continuous_symm
+  · simpa only [orientedEdgeBasePoint, ite_eq_right hj] using
+      dualSidePoint_continuous (thetaEdgeIndex j)
+
+private def CuspCentralHomology.thetaBaseCylinder (p : unitInterval × Fin 3) :
+    PeriodTorusHigherHomology.ProductTorus 2 :=
+  baseTorusPoint (orientedEdgeBasePoint p.1 p.2)
+
+@[simp]
+private theorem CuspCentralHomology.thetaBaseCylinder_apply (t : unitInterval) (j : Fin 3) :
+    thetaBaseCylinder (t, j) = baseTorusPoint (orientedEdgeBasePoint t j) :=
+  rfl
+
+private theorem CuspCentralHomology.thetaBaseCylinder_continuous : Continuous thetaBaseCylinder :=
+  continuous_prod_of_discrete_right.mpr fun j =>
+    baseTorusPoint_continuous.comp (orientedEdgeBasePoint_continuous j)
+
+@[simp]
+private theorem
+    CuspCentralHomology.baseTorusProjection_edgeCylinder (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (k : Fin 6) (t : unitInterval) (a : Circle) :
+    baseTorusProjection C r hr
+        (CuspCollapse.centralProject C r hr (edgeCylinder (C 0) k (t, a))) =
+      baseTorusPoint (dualSidePoint k t) := by
+  have h :
+    CuspCollapse.centralProject C r hr (edgeCylinder (C 0) k (t, a)) =
+      CuspHoneycomb.honeycombCollapseMap C r hr
+        (hexagonCharacterSection k a, (edgeArcBase (C 0) k t : (CuspHoneycombTiling.Plane))) := by
+    change
+      CuspCollapse.centralCollapseMap C r hr
+          (hexagonCharacterSection k a, edgeArcPositive (C 0) k t) =
+        CuspCollapse.centralCollapseMap C r hr
+          (hexagonCharacterSection k a,
+            CuspHoneycomb.honeycombHomeomorph (C 0)
+              (edgeArcBase (C 0) k t : (CuspHoneycombTiling.Plane)))
+    rw [honeycombHomeomorph_edgeArcBase]
+  rw [h, baseTorusProjection_honeycombCollapseMap, edgeArcBase_eq_dualSidePoint]
+
+private theorem
+    CuspCentralHomology.baseTorusProjection_doubleCylinder (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (p : unitInterval × ThreeCircles) :
+    baseTorusProjection C r hr (doubleCylinder C r hr p) =
+      thetaBaseCylinder (p.1, thetaCircleLabel p.2) := by
+  rcases p with ⟨t, a | (a | a)⟩ <;>
+    simp only [doubleCylinder_first, doubleCylinder_middle, doubleCylinder_last,
+      baseTorusProjection_edgeCylinder, thetaCircleLabel_inl, thetaCircleLabel_inr_inl,
+      thetaCircleLabel_inr_inr, thetaBaseCylinder_apply, orientedEdgeBasePoint_zero,
+      orientedEdgeBasePoint_one, orientedEdgeBasePoint_two]
+
+private theorem CuspCentralHomology.thetaBaseCylinder_respects (p q : unitInterval × Fin 3)
+    (h : (suspensionSetoid (Fin 3)).r p q) : thetaBaseCylinder p = thetaBaseCylinder q := by
+  have h' :
+    (suspensionSetoid ThreeCircles).r (p.1, thetaCircleInclusion p.2 1)
+      (q.1, thetaCircleInclusion q.2 1) := by
+    rcases h with ⟨ht, hzero | hone | hj⟩
+    · exact ⟨ht, Or.inl hzero⟩
+    · exact ⟨ht, Or.inr (Or.inl hone)⟩
+    · exact ⟨ht, Or.inr (Or.inr (congrArg (fun j => thetaCircleInclusion j 1) hj))⟩
+  have he :=
+    congrArg (baseTorusProjection (fun _ => 0) 1 zero_lt_one)
+      (doubleCylinder_respects (fun _ => 0) 1 zero_lt_one _ _ h')
+  simpa only [baseTorusProjection_doubleCylinder, thetaCircleLabel_inclusion] using he
+
+private def CuspCentralHomology.thetaBaseMapFun_mo1973_14442 :
+    Theta → PeriodTorusHigherHomology.ProductTorus 2 :=
+  Quotient.lift thetaBaseCylinder thetaBaseCylinder_respects
+
+private theorem CuspCentralHomology.thetaBaseMapFun_continuous_mo1973_14443 :
+    Continuous thetaBaseMapFun_mo1973_14442 :=
+  (Suspension.isQuotientMap_mk (X := Fin 3)).continuous_iff.mpr thetaBaseCylinder_continuous
+
+private def CuspCentralHomology.thetaBaseMap : C(Theta, PeriodTorusHigherHomology.ProductTorus 2) :=
+  ⟨thetaBaseMapFun_mo1973_14442, thetaBaseMapFun_continuous_mo1973_14443⟩
+
+@[simp]
+private theorem CuspCentralHomology.thetaBaseMap_mk (t : unitInterval) (j : Fin 3) :
+    thetaBaseMap (Suspension.mk t j) = thetaBaseCylinder (t, j) :=
+  rfl
+
+private theorem CuspCentralHomology.thetaBaseMap_mk_point (t : unitInterval) (j : Fin 3) :
+    thetaBaseMap (Suspension.mk t j) =
+      baseTorusPoint
+        (dualSidePoint (thetaEdgeIndex j) (if j = 1 then unitInterval.symm t else t)) :=
+  rfl
+
+private theorem CuspCentralHomology.thetaBaseMap_mk_zero (t : unitInterval) :
+    thetaBaseMap (Suspension.mk t 0) = baseTorusPoint (dualSidePoint 0 t) := by
+  simp only [thetaBaseMap_mk, thetaBaseCylinder_apply, orientedEdgeBasePoint_zero]
+
+private theorem CuspCentralHomology.thetaBaseMap_mk_one (t : unitInterval) :
+    thetaBaseMap (Suspension.mk t 1) = baseTorusPoint (dualSidePoint 1 (unitInterval.symm t)) := by
+  simp only [thetaBaseMap_mk, thetaBaseCylinder_apply, orientedEdgeBasePoint_one]
+
+private theorem CuspCentralHomology.thetaBaseMap_mk_two (t : unitInterval) :
+    thetaBaseMap (Suspension.mk t 2) = baseTorusPoint (dualSidePoint 2 t) := by
+  simp only [thetaBaseMap_mk, thetaBaseCylinder_apply, orientedEdgeBasePoint_two]
+
+private theorem CuspCentralHomology.thetaBaseMap_homology_eq_zero (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap thetaBaseMap (n + 2) = 0 := by
+  let := theta_homology_subsingleton n
+  exact Subsingleton.elim _ _
+
+private theorem CuspCentralHomology.baseTorusProjection_doubleSuspensionMap
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) (q : ThreeCircleSuspension) :
+    baseTorusProjection C r hr (doubleSuspensionMap C r hr q) =
+      thetaBaseMap (thetaForgetCircle q) := by
+  obtain ⟨⟨t, a⟩, rfl⟩ := Suspension.mk_surjective q
+  rw [doubleSuspensionMap_mk, baseTorusProjection_doubleCylinder, thetaForgetCircle_mk,
+    thetaBaseMap_mk]
+
+private theorem CuspCentralHomology.baseTorusProjection_boundary (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (hr1 : r < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 r))
+    (hR : ToricSpace.SmallDrift C r) (q : centralBoundary C r hr) :
+    baseTorusProjection C r hr (q : CuspRetraction.QuotientCentralFibre C r) =
+      thetaBaseMap (thetaForgetCircle (centralBoundarySuspensionHomeomorph C r hr hr1 hC hR q)) :=
+  by
+  obtain ⟨p, rfl⟩ := (centralBoundarySuspensionHomeomorph C r hr hr1 hC hR).symm.surjective q
+  rw [Homeomorph.apply_symm_apply, centralBoundarySuspensionHomeomorph_symm_coe]
+  exact baseTorusProjection_doubleSuspensionMap C r hr p
+
+private theorem CuspCentralHomology.baseTorusProjectionMap_comp_boundaryInclusion
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) (hr1 : r < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 r))
+    (hR : ToricSpace.SmallDrift C r) :
+    (baseTorusProjectionMap C r hr hC).comp (centralBoundaryInclusion C r hr) =
+      thetaBaseMap.comp
+        (thetaForgetCircle.comp
+          (centralBoundarySuspensionHomeomorph C r hr hr1 hC hR :
+            C(centralBoundary C r hr, ThreeCircleSuspension))) := by
+  apply ContinuousMap.ext
+  intro q
+  exact baseTorusProjection_boundary C r hr hr1 hC hR q
+
+private theorem CuspCentralHomology.baseTorusProjection_boundary_homology_eq_zero
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) (hr1 : r < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 r))
+    (hR : ToricSpace.SmallDrift C r) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap
+        ((baseTorusProjectionMap C r hr hC).comp (centralBoundaryInclusion C r hr)) (n + 2) =
+      0 := by
+  rw [baseTorusProjectionMap_comp_boundaryInclusion C r hr hr1 hC hR,
+    PeriodTorusHigherHomology.singularHomologyMap_comp, thetaBaseMap_homology_eq_zero,
+    LinearMap.zero_comp]
+
+private theorem CuspCentralHomology.baseTorusProjection_boundary_homology_two_eq_zero
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) (hr1 : r < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 r))
+    (hR : ToricSpace.SmallDrift C r) :
+    SingularMayerVietoris.singularHomologyMap
+        ((baseTorusProjectionMap C r hr hC).comp (centralBoundaryInclusion C r hr)) 2 =
+      0 :=
+  baseTorusProjection_boundary_homology_eq_zero C r hr hr1 hC hR 0
+
+private abbrev
+    CuspCentralHomology.baseTorusSectionHomologyMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 2) n →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) n :=
+  SingularMayerVietoris.singularHomologyMap (baseTorusSection C r hr) n
+
+private abbrev CuspCentralHomology.baseTorusProjectionHomologyMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r))
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) n →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 2) n :=
+  SingularMayerVietoris.singularHomologyMap (baseTorusProjectionMap C r hr hC) n
+
+@[simp]
+private theorem
+    CuspCentralHomology.baseTorusProjectionMap_comp_section (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    (baseTorusProjectionMap C r hr hC).comp (baseTorusSection C r hr) =
+      ContinuousMap.id (PeriodTorusHigherHomology.ProductTorus 2) :=
+  ContinuousMap.ext (baseTorusProjection_section C r hr)
+
+@[simp]
+private theorem CuspCentralHomology.baseTorusProjectionHomologyMap_comp_section
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (n : ℕ) :
+    (baseTorusProjectionHomologyMap C r hr hC n).comp (baseTorusSectionHomologyMap C r hr n) =
+      LinearMap.id := by
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp, baseTorusProjectionMap_comp_section,
+    PeriodTorusHigherHomology.singularHomologyMap_id]
+
+@[simp]
+private theorem CuspCentralHomology.baseTorusProjectionHomologyMap_section
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 2) n) :
+    baseTorusProjectionHomologyMap C r hr hC n (baseTorusSectionHomologyMap C r hr n a) = a :=
+  LinearMap.congr_fun (baseTorusProjectionHomologyMap_comp_section C r hr hC n) a
+
+private theorem CuspCentralHomology.baseTorusProjectionHomologyMap_surjective
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (n : ℕ) :
+    Function.Surjective (baseTorusProjectionHomologyMap C r hr hC n) :=
+  (show
+      Function.LeftInverse (baseTorusProjectionHomologyMap C r hr hC n)
+        (baseTorusSectionHomologyMap C r hr n)
+      from baseTorusProjectionHomologyMap_section C r hr hC n).surjective
+
+private def CuspCentralHomology.baseTorusH2Marking :
+    SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 2) 2 ≃ₗ[ℤ] ℤ :=
+  (PeriodTorusHigherHomology.productTorusHomologyEquiv 2 2).trans
+    (LinearEquiv.funUnique (Fin 1) ℤ ℤ)
+
+private def CuspCentralHomology.baseTorusH2Functional (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 2 →ₗ[ℤ] ℤ :=
+  baseTorusH2Marking.toLinearMap.comp (baseTorusProjectionHomologyMap C r hr hC 2)
+
+private theorem
+    CuspCentralHomology.baseTorusH2Functional_boundary (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r))
+    (hr1 : r < 1) (hR : ToricSpace.SmallDrift C r)
+    (a : SingularMayerVietoris.SingularHomology (centralBoundary C r hr) 2) :
+    baseTorusH2Functional C r hr hC
+        (SingularMayerVietoris.singularHomologyMap (centralBoundaryInclusion C r hr) 2 a) =
+      0 := by
+  change
+    baseTorusH2Marking
+        (((baseTorusProjectionHomologyMap C r hr hC 2).comp
+            (SingularMayerVietoris.singularHomologyMap (centralBoundaryInclusion C r hr) 2))
+          a) =
+      0
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    baseTorusProjection_boundary_homology_two_eq_zero C r hr hr1 hC hR, LinearMap.zero_apply,
+    map_zero]
+
+private theorem CuspCentralHomology.baseTorusProjection_homology_one_injective
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Function.Injective (baseTorusProjectionHomologyMap C r hr hC 1) := by
+  let := PeriodTorusHigherHomology.productTorus_homology_finite 2 1
+  let e :
+    SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 1 ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 2) 1 :=
+    (centralSingularH1Equiv C r hr hC).trans
+      (PeriodTorusHigherHomology.productTorusHomologyEquiv 2 1).symm
+  exact
+    IsNoetherian.injective_of_surjective_of_injective e.toLinearMap
+      (baseTorusProjectionHomologyMap C r hr hC 1) e.injective
+      (baseTorusProjectionHomologyMap_surjective C r hr hC 1)
+
+private theorem CuspCentralHomology.baseTorusSection_homology_one_surjective
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Function.Surjective (baseTorusSectionHomologyMap C r hr 1) := by
+  intro a
+  refine ⟨baseTorusProjectionHomologyMap C r hr hC 1 a, ?_⟩
+  apply baseTorusProjection_homology_one_injective C r hr hC
+  exact baseTorusProjectionHomologyMap_section C r hr hC 1 _
+
+private def CuspSpecialization.productBaseTorusSection :
+    C(PeriodTorusHigherHomology.ProductTorus 2,
+      ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2)
+    where
+  toFun b := (1, b)
+  continuous_toFun := continuous_const.prodMk continuous_id
+
+private theorem CuspSpecialization.productCollapse_comp_baseTorusSection
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) :
+    (productCollapse C r hr).comp productBaseTorusSection =
+      CuspCentralHomology.baseTorusSection C r hr :=
+  ContinuousMap.ext fun _ => rfl
+
+private theorem CuspSpecialization.productCollapse_homology_one_surjective
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Function.Surjective (SingularMayerVietoris.singularHomologyMap (productCollapse C r hr) 1) := by
+  intro a
+  obtain ⟨b, hb⟩ := CuspCentralHomology.baseTorusSection_homology_one_surjective C r hr hC a
+  refine ⟨SingularMayerVietoris.singularHomologyMap productBaseTorusSection 1 b, ?_⟩
+  change
+    ((SingularMayerVietoris.singularHomologyMap (productCollapse C r hr) 1).comp
+          (SingularMayerVietoris.singularHomologyMap productBaseTorusSection 1))
+        b =
+      a
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp, productCollapse_comp_baseTorusSection]
+  exact hb
+
+private theorem CuspSpecialization.markedCollapse_homology_one_surjective
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Function.Surjective (SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) 1) :=
+  markedCollapse_homology_surjective_of_product C r hr 1
+    (productCollapse_homology_one_surjective C r hr hC)
+
+private theorem
+    CuspSpecialization.markedCollapse_homology_one_kernel (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    LinearMap.ker (SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) 1) =
+      LinearMap.range (CuspCoinvariants.torusDifference 1) := by
+  let := CuspCentralHomology.centralSingularH1_free C r hr hC
+  let := CuspCentralHomology.centralSingularH1_finite C r hr hC
+  exact
+    CuspCoinvariants.kernel_eq_of_quotient_equiv
+      (LinearMap.range (CuspCoinvariants.torusDifference 1)) torusOneCoinvariantEquiv
+      (SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) 1)
+      (markedCollapse_homology_one_surjective C r hr hC)
+      (markedCollapse_homology_range_variation C r hr 1)
+      (CuspCentralHomology.centralSingularH1_finrank C r hr hC)
+
+private theorem CuspSpecialization.markedCollapse_homologyOne_surjective
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Function.Surjective (SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) 1) :=
+  markedCollapse_homology_one_surjective C r hr hC
+
+private theorem
+    CuspSpecialization.markedCollapse_homologyOne_kernel (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    LinearMap.ker (SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) 1) =
+      LinearMap.range (CuspCoinvariants.torusDifference 1) :=
+  markedCollapse_homology_one_kernel C r hr hC
+
+private theorem CuspCentralHomology.dualSidePoint_mem_frontier (k : Fin 6) (t : unitInterval) :
+    dualSidePoint k t ∈ frontier CuspHoneycombTiling.baseCell := by
+  rw [← edgeArcBase_eq_dualSidePoint (0 : Matrix (Fin 2) (Fin 2) ℂ) k t]
+  exact edgeArcBase_mem_frontier (0 : Matrix (Fin 2) (Fin 2) ℂ) k t
+
+private theorem
+    CuspCentralHomology.orientedEdgeBasePoint_mem_frontier (t : unitInterval) (j : Fin 3) :
+    orientedEdgeBasePoint t j ∈ frontier CuspHoneycombTiling.baseCell :=
+  dualSidePoint_mem_frontier (thetaEdgeIndex j) (if j = 1 then unitInterval.symm t else t)
+
+private def CuspCentralHomology.thetaProductMap :
+    C(ToricSpace.CompactFibreTorus × Theta,
+      ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2) :=
+  (ContinuousMap.id ToricSpace.CompactFibreTorus).prodMap thetaBaseMap
+
+@[simp]
+private theorem CuspCentralHomology.thetaProductMap_mk (u : ToricSpace.CompactFibreTorus)
+    (t : unitInterval) (j : Fin 3) :
+    thetaProductMap (u, Suspension.mk t j) = (u, baseTorusPoint (orientedEdgeBasePoint t j)) :=
+  rfl
+
+private theorem
+    CuspCentralHomology.productCollapse_thetaProductMap_mk (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (u : ToricSpace.CompactFibreTorus) (t : unitInterval) (j : Fin 3) :
+    CuspSpecialization.productCollapse C ε hε (thetaProductMap (u, Suspension.mk t j)) =
+      CuspHoneycomb.honeycombCollapseMap C ε hε
+        (u * CuspSpecialization.sourcePhaseCharacter (C 0) (orientedEdgeBasePoint t j),
+          orientedEdgeBasePoint t j) := by
+  rw [thetaProductMap_mk, baseTorusPoint_apply,
+    CuspSpecialization.productCollapse_coordinateProjection,
+    CuspSpecialization.realCuspVector_neg_realCuspVector]
+
+private theorem CuspCentralHomology.productCollapse_thetaProductMap_mem_centralBoundary
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (p : ToricSpace.CompactFibreTorus × Theta) :
+    CuspSpecialization.productCollapse C ε hε (thetaProductMap p) ∈ centralBoundary C ε hε := by
+  rcases p with ⟨u, q⟩
+  obtain ⟨⟨t, j⟩, rfl⟩ := Suspension.mk_surjective q
+  rw [productCollapse_thetaProductMap_mk, centralBoundary_eq_image]
+  exact
+    ⟨(u * CuspSpecialization.sourcePhaseCharacter (C 0) (orientedEdgeBasePoint t j),
+        orientedEdgeBasePoint t j),
+      ⟨Set.mem_univ _, orientedEdgeBasePoint_mem_frontier t j⟩, rfl⟩
+
+private def
+    CuspCentralHomology.boundaryLift (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    C(ToricSpace.CompactFibreTorus × Theta, centralBoundary C ε hε)
+    where
+  toFun
+    p :=
+    ⟨CuspSpecialization.productCollapse C ε hε (thetaProductMap p),
+      productCollapse_thetaProductMap_mem_centralBoundary C ε hε p⟩
+  continuous_toFun :=
+    ((CuspSpecialization.productCollapse C ε hε).continuous.comp
+          thetaProductMap.continuous).subtype_mk
+      _
+
+private theorem CuspCentralHomology.centralBoundaryInclusion_comp_boundaryLift
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    (centralBoundaryInclusion C ε hε).comp (boundaryLift C ε hε) =
+      (CuspSpecialization.productCollapse C ε hε).comp thetaProductMap :=
+  rfl
+
+@[simp]
+private theorem CuspCentralHomology.boundaryLift_mk_coe (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (u : ToricSpace.CompactFibreTorus) (t : unitInterval) (j : Fin 3) :
+    (boundaryLift C ε hε (u, Suspension.mk t j) : CuspRetraction.QuotientCentralFibre C ε) =
+      CuspHoneycomb.honeycombCollapseMap C ε hε
+        (u * CuspSpecialization.sourcePhaseCharacter (C 0) (orientedEdgeBasePoint t j),
+          orientedEdgeBasePoint t j) :=
+  productCollapse_thetaProductMap_mk C ε hε u t j
+
+private theorem CuspCentralHomology.centralProject_edgeCylinder_character_dualSide
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (k : Fin 6) (t : unitInterval)
+    (u : ToricSpace.CompactFibreTorus) :
+    CuspCollapse.centralProject C ε hε (edgeCylinder (C 0) k (t, hexagonCharacter k u)) =
+      CuspHoneycomb.honeycombCollapseMap C ε hε (u, dualSidePoint k t) := by
+  rw [edgeCylinder_character_all]
+  change
+    CuspCollapse.centralCollapseMap C ε hε (u, edgeArcPositive (C 0) k t) =
+      CuspCollapse.centralCollapseMap C ε hε
+        (u, CuspHoneycomb.honeycombHomeomorph (C 0) (dualSidePoint k t))
+  rw [← edgeArcBase_eq_dualSidePoint (C 0) k t, honeycombHomeomorph_edgeArcBase]
+
+private theorem CuspCentralHomology.doubleSuspensionMap_character_orientedEdge
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (u : ToricSpace.CompactFibreTorus)
+    (t : unitInterval) (j : Fin 3) :
+    doubleSuspensionMap C ε hε
+        (Suspension.mk t (thetaCircleInclusion j (hexagonCharacter (thetaEdgeIndex j) u))) =
+      CuspHoneycomb.honeycombCollapseMap C ε hε (u, orientedEdgeBasePoint t j) := by
+  fin_cases j
+  · exact centralProject_edgeCylinder_character_dualSide C ε hε 0 t u
+  · exact centralProject_edgeCylinder_character_dualSide C ε hε 1 (unitInterval.symm t) u
+  · exact centralProject_edgeCylinder_character_dualSide C ε hε 2 t u
+
+private def
+    CuspCentralHomology.thetaShearCylinder (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (s : unitInterval)
+    (u : ToricSpace.CompactFibreTorus) (t : unitInterval) (j : Fin 3) : ThreeCircleSuspension :=
+  Suspension.mk t
+    (thetaCircleInclusion j
+      (hexagonCharacter (thetaEdgeIndex j)
+        (u * CuspSpecialization.sourcePhaseCharacter C₀ ((s : ℝ) • orientedEdgeBasePoint t j))))
+
+private theorem CuspCentralHomology.thetaShearCylinder_respects (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (s : unitInterval) (u : ToricSpace.CompactFibreTorus) (p q : unitInterval × Fin 3)
+    (hpq : (suspensionSetoid (Fin 3)).r p q) :
+    thetaShearCylinder C₀ s u p.1 p.2 = thetaShearCylinder C₀ s u q.1 q.2 := by
+  apply (Suspension.mk_eq_mk_iff _ _ _ _).mpr
+  rcases hpq with ⟨ht, hzero | hone | hj⟩
+  · exact ⟨ht, Or.inl hzero⟩
+  · exact ⟨ht, Or.inr (Or.inl hone)⟩
+  · refine ⟨ht, Or.inr (Or.inr ?_)⟩
+    rw [ht, hj]
+
+private def CuspCentralHomology.thetaShearLiftFun_mo1973_14554 (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (p : (unitInterval × ToricSpace.CompactFibreTorus) × Theta) : ThreeCircleSuspension :=
+  Quotient.lift (s := suspensionSetoid (Fin 3))
+    (fun q => thetaShearCylinder C₀ p.1.1 p.1.2 q.1 q.2)
+    (thetaShearCylinder_respects C₀ p.1.1 p.1.2) p.2
+
+private theorem CuspCentralHomology.thetaShearCylinder_continuous (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    Continuous
+      (fun p : (unitInterval × ToricSpace.CompactFibreTorus) × (unitInterval × Fin 3) =>
+        thetaShearCylinder C₀ p.1.1 p.1.2 p.2.1 p.2.2) := by
+  have h :
+    Continuous
+      (fun p : ((unitInterval × ToricSpace.CompactFibreTorus) × unitInterval) × Fin 3 =>
+        Suspension.mk p.1.2
+          (thetaCircleInclusion p.2
+            (hexagonCharacter (thetaEdgeIndex p.2)
+              (p.1.1.2 *
+                CuspSpecialization.sourcePhaseCharacter C₀
+                  ((p.1.1.1 : ℝ) • orientedEdgeBasePoint p.1.2 p.2))))) := by
+    apply continuous_prod_of_discrete_right.mpr
+    intro j
+    exact
+      Suspension.continuous_mk.comp
+        (continuous_snd.prodMk
+          ((thetaCircleInclusion_continuous j).comp
+            ((edgeCharacter_continuous (ToricComponent.hexagonRay (thetaEdgeIndex j))).comp
+              ((continuous_snd.comp continuous_fst).mul
+                ((CuspSpecialization.sourcePhaseCharacter_continuous C₀).comp
+                  ((continuous_subtype_val.comp (continuous_fst.comp continuous_fst)).smul
+                    ((orientedEdgeBasePoint_continuous j).comp continuous_snd)))))))
+  exact
+    h.comp
+      ((continuous_fst.prodMk (continuous_fst.comp continuous_snd)).prodMk
+        (continuous_snd.comp continuous_snd))
+
+private theorem CuspCentralHomology.thetaShearLiftFun_continuous_mo1973_14557
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) : Continuous (thetaShearLiftFun_mo1973_14554 C₀) := by
+  apply (Suspension.isQuotientMap_mk (X := Fin 3)).continuous_lift_prod_right
+  change
+    Continuous
+      (fun p : (unitInterval × ToricSpace.CompactFibreTorus) × (unitInterval × Fin 3) =>
+        thetaShearCylinder C₀ p.1.1 p.1.2 p.2.1 p.2.2)
+  exact thetaShearCylinder_continuous C₀
+
+private def CuspCentralHomology.thetaShearMap (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    C(unitInterval × (ToricSpace.CompactFibreTorus × Theta), ThreeCircleSuspension)
+    where
+  toFun p := thetaShearLiftFun_mo1973_14554 C₀ ((p.1, p.2.1), p.2.2)
+  continuous_toFun :=
+    (thetaShearLiftFun_continuous_mo1973_14557 C₀).comp
+      ((continuous_fst.prodMk (continuous_fst.comp continuous_snd)).prodMk
+        (continuous_snd.comp continuous_snd))
+
+@[simp]
+private theorem
+    CuspCentralHomology.thetaShearMap_mk (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (s : unitInterval)
+    (u : ToricSpace.CompactFibreTorus) (t : unitInterval) (j : Fin 3) :
+    thetaShearMap C₀ (s, (u, Suspension.mk t j)) = thetaShearCylinder C₀ s u t j :=
+  rfl
+
+@[simp]
+private theorem CuspCentralHomology.thetaShearMap_zero (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (p : ToricSpace.CompactFibreTorus × Theta) :
+    thetaShearMap C₀ (0, p) = thetaCharacterCollapse p := by
+  rcases p with ⟨u, q⟩
+  obtain ⟨⟨t, j⟩, rfl⟩ := Suspension.mk_surjective q
+  rw [thetaShearMap_mk]
+  simp [thetaShearCylinder]
+
+private def CuspCentralHomology.shearedThetaCollapse (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    C(ToricSpace.CompactFibreTorus × Theta, ThreeCircleSuspension) :=
+  (thetaShearMap C₀).comp ⟨fun p => (1, p), continuous_const.prodMk continuous_id⟩
+
+@[simp]
+private theorem CuspCentralHomology.shearedThetaCollapse_mk (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (u : ToricSpace.CompactFibreTorus) (t : unitInterval) (j : Fin 3) :
+    shearedThetaCollapse C₀ (u, Suspension.mk t j) =
+      Suspension.mk t
+        (thetaCircleInclusion j
+          (hexagonCharacter (thetaEdgeIndex j)
+            (u * CuspSpecialization.sourcePhaseCharacter C₀ (orientedEdgeBasePoint t j)))) := by
+  change
+    Suspension.mk t
+        (thetaCircleInclusion j
+          (hexagonCharacter (thetaEdgeIndex j)
+            (u *
+              CuspSpecialization.sourcePhaseCharacter C₀
+                ((1 : ℝ) • orientedEdgeBasePoint t j)))) =
+      _
+  rw [one_smul]
+
+private def CuspCentralHomology.thetaShearHomotopy (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    thetaCharacterCollapse.Homotopy (shearedThetaCollapse C₀)
+    where
+  toContinuousMap := thetaShearMap C₀
+  map_zero_left := thetaShearMap_zero C₀
+  map_one_left _ := rfl
+
+private def CuspCentralHomology.rightPreimageHomeomorph (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (S : Set Y) : (Prod.snd ⁻¹' S : Set (X × Y)) ≃ₜ X × S
+    where
+  toFun p := (p.1.1, ⟨p.1.2, p.2⟩)
+  invFun p := ⟨(p.1, p.2), p.2.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun :=
+    (continuous_fst.comp continuous_subtype_val).prodMk
+      ((continuous_snd.comp continuous_subtype_val).subtype_mk _)
+  continuous_invFun :=
+    (continuous_fst.prodMk (continuous_subtype_val.comp continuous_snd)).subtype_mk _
+
+private def CuspCentralHomology.rightPreimageProjection (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (S : Set Y) : C((Prod.snd ⁻¹' S : Set (X × Y)), X) :=
+  ⟨fun p => p.1.1, continuous_fst.comp continuous_subtype_val⟩
+
+private def
+    CuspCentralHomology.rightPreimageContractibleHomotopyEquiv (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (S : Set Y) [ContractibleSpace S] :
+    (Prod.snd ⁻¹' S : Set (X × Y)) ≃ₕ X :=
+  (rightPreimageHomeomorph X Y S).toHomotopyEquiv.trans
+    (((ContinuousMap.HomotopyEquiv.refl X).prodCongr
+          (Classical.choice (ContractibleSpace.hequiv_unit S))).trans
+      (Homeomorph.prodUnique X Unit).toHomotopyEquiv)
+
+private theorem CuspCentralHomology.rightPreimageProjection_homology_injective (X Y : Type)
+    [TopologicalSpace X] [TopologicalSpace Y] (S : Set Y) [ContractibleSpace S] (n : ℕ) :
+    Function.Injective
+      (SingularMayerVietoris.singularHomologyMap (rightPreimageProjection X Y S) n) :=
+  (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+      (rightPreimageContractibleHomotopyEquiv X Y S) n).injective
+
+private def CuspCentralHomology.suspensionMiddleSection (Y : Type) [TopologicalSpace Y] :
+    C(Y, Suspension.middleBand Y) :=
+  ⟨fun y => Suspension.middleBandHomeomorph.symm (⟨1 / 2, by norm_num⟩, y),
+    Suspension.middleBandHomeomorph.symm.continuous.comp (continuous_const.prodMk continuous_id)⟩
+
+@[simp]
+private theorem
+    CuspCentralHomology.suspensionMiddleSection_coe (Y : Type) [TopologicalSpace Y] (y : Y) :
+    (suspensionMiddleSection Y y : Suspension Y) = Suspension.mk ⟨1 / 2, by norm_num⟩ y :=
+  rfl
+
+private theorem CuspCentralHomology.suspensionMiddleSection_label (Y : Type) [TopologicalSpace Y]
+    (y : Y) : Suspension.middleBandHomotopyEquiv (suspensionMiddleSection Y y) = y := by
+  change
+    (Suspension.middleBandHomeomorph
+          (Suspension.middleBandHomeomorph.symm (⟨1 / 2, by norm_num⟩, y))).2 =
+      y
+  rw [Homeomorph.apply_symm_apply]
+
+private def CuspCentralHomology.suspensionProductMiddleSection (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (y : Y) :
+    C(X, (Prod.snd ⁻¹' Suspension.middleBand Y : Set (X × Suspension Y))) :=
+  ⟨fun x => ⟨(x, suspensionMiddleSection Y y), (suspensionMiddleSection Y y).2⟩,
+    (continuous_id.prodMk continuous_const).subtype_mk _⟩
+
+private theorem CuspCentralHomology.contractibleTargetCoverMap_homology_surjective (X Y : Type)
+    [TopologicalSpace X] [TopologicalSpace Y] (f : C(X, Y)) (U V : Set X) (U' V' : Set Y)
+    (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (hU' : IsOpen U')
+    (hV' : IsOpen V') (hcover' : U' ∪ V' = Set.univ) [ContractibleSpace U'] [ContractibleSpace V']
+    (hfU : Set.MapsTo f U U') (hfV : Set.MapsTo f V V') (n : ℕ)
+    (hlift :
+      ∀ b : SingularMayerVietoris.SingularHomology (U' ∩ V' : Set Y) n,
+        ∃ c : SingularMayerVietoris.SingularHomology (U ∩ V : Set X) n,
+          SingularMayerVietoris.leftHomologyMap U V n c = 0 ∧
+            SingularMayerVietoris.singularHomologyMap
+                (SingularMayerVietoris.intersectionRestriction f U V U' V' hfU hfV) n c =
+              b) :
+    Function.Surjective (SingularMayerVietoris.singularHomologyMap f (n + 1)) := by
+  intro b
+  obtain ⟨c, hc, hcb⟩ :=
+    hlift (SingularMayerVietoris.connectingHomomorphism U' V' hU' hV' hcover' n b)
+  have hr :
+    c ∈ LinearMap.range (SingularMayerVietoris.connectingHomomorphism U V hU hV hcover n) := by
+    rw [SingularMayerVietoris.exact_at_intersection]
+    exact hc
+  obtain ⟨a, ha⟩ := hr
+  refine ⟨a, contractibleCoverConnecting_injective U' V' hU' hV' hcover' n ?_⟩
+  have hn :=
+    SingularMayerVietoris.connectingHomomorphism_naturality_apply f U V U' V' hfU hfV hU hV hcover
+      hU' hV' hcover' n a
+  rw [ha, hcb] at hn
+  exact hn.symm
+
+private abbrev CuspCentralHomology.ThetaBelt :=
+  thetaNorth ∩ thetaSouth
+
+private def CuspCentralHomology.thetaBeltSection (j : Fin 3) :
+    C(ToricSpace.CompactFibreTorus, ThetaBelt) :=
+  suspensionProductMiddleSection ToricSpace.CompactFibreTorus (Fin 3) j
+
+@[simp]
+private theorem
+    CuspCentralHomology.thetaBeltSection_coe (j : Fin 3) (u : ToricSpace.CompactFibreTorus) :
+    (thetaBeltSection j u : ToricSpace.CompactFibreTorus × Theta) =
+      (u, Suspension.mk ⟨1 / 2, by norm_num⟩ j) :=
+  rfl
+
+private def CuspCentralHomology.thetaBeltProjection : C(ThetaBelt, ToricSpace.CompactFibreTorus) :=
+  rightPreimageProjection ToricSpace.CompactFibreTorus Theta (Suspension.middleBand (Fin 3))
+
+@[simp]
+private theorem CuspCentralHomology.thetaBeltProjection_comp_section (j : Fin 3) :
+    thetaBeltProjection.comp (thetaBeltSection j) =
+      ContinuousMap.id ToricSpace.CompactFibreTorus :=
+  rfl
+
+@[simp]
+private theorem CuspCentralHomology.thetaBeltProjection_homology_section (j : Fin 3) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology ToricSpace.CompactFibreTorus n) :
+    SingularMayerVietoris.singularHomologyMap thetaBeltProjection n
+        (SingularMayerVietoris.singularHomologyMap (thetaBeltSection j) n a) =
+      a := by
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    thetaBeltProjection_comp_section, PeriodTorusHigherHomology.singularHomologyMap_id,
+    LinearMap.id_apply]
+
+private def CuspCentralHomology.thetaBeltSum
+    (v : Fin 3 → SingularMayerVietoris.SingularHomology ToricSpace.CompactFibreTorus 1) :
+    SingularMayerVietoris.SingularHomology ThetaBelt 1 :=
+  ∑ j, SingularMayerVietoris.singularHomologyMap (thetaBeltSection j) 1 (v j)
+
+@[simp]
+private theorem CuspCentralHomology.thetaBeltProjection_homology_sum
+    (v : Fin 3 → SingularMayerVietoris.SingularHomology ToricSpace.CompactFibreTorus 1) :
+    SingularMayerVietoris.singularHomologyMap thetaBeltProjection 1 (thetaBeltSum v) = ∑ j, v j :=
+  by simp only [thetaBeltSum, map_sum, thetaBeltProjection_homology_section]
+
+private theorem CuspCentralHomology.thetaBelt_mem_ker_of_projection_eq_zero (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology ThetaBelt n)
+    (ha : SingularMayerVietoris.singularHomologyMap thetaBeltProjection n a = 0) :
+    SingularMayerVietoris.leftHomologyMap thetaNorth thetaSouth n a = 0 := by
+  have hleft :
+    SingularMayerVietoris.singularHomologyMap
+        (ContinuousMap.inclusion (Set.inter_subset_left : ThetaBelt ⊆ thetaNorth)) n a =
+      0 := by
+    let proj : C(thetaNorth, ToricSpace.CompactFibreTorus) :=
+      rightPreimageProjection ToricSpace.CompactFibreTorus Theta Suspension.northOpen
+    apply
+      (show Function.Injective (SingularMayerVietoris.singularHomologyMap proj n) from
+        rightPreimageProjection_homology_injective ToricSpace.CompactFibreTorus Theta
+          Suspension.northOpen n)
+    rw [map_zero, ← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp]
+    exact ha
+  have hright :
+    SingularMayerVietoris.singularHomologyMap
+        (ContinuousMap.inclusion (Set.inter_subset_right : ThetaBelt ⊆ thetaSouth)) n a =
+      0 := by
+    let proj : C(thetaSouth, ToricSpace.CompactFibreTorus) :=
+      rightPreimageProjection ToricSpace.CompactFibreTorus Theta Suspension.southOpen
+    apply
+      (show Function.Injective (SingularMayerVietoris.singularHomologyMap proj n) from
+        rightPreimageProjection_homology_injective ToricSpace.CompactFibreTorus Theta
+          Suspension.southOpen n)
+    rw [map_zero, ← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp]
+    exact ha
+  rw [SingularMayerVietoris.leftHomologyMap_apply, hleft, hright, neg_zero]
+  rfl
+
+private theorem CuspCentralHomology.thetaBeltSum_mem_ker
+    (v : Fin 3 → SingularMayerVietoris.SingularHomology ToricSpace.CompactFibreTorus 1)
+    (hv : ∑ j, v j = 0) :
+    SingularMayerVietoris.leftHomologyMap thetaNorth thetaSouth 1 (thetaBeltSum v) = 0 := by
+  apply thetaBelt_mem_ker_of_projection_eq_zero
+  rw [thetaBeltProjection_homology_sum, hv]
+
+private def CuspCentralHomology.thetaCircleMap (j : Fin 3) : C(_root_.Circle, ThreeCircles) :=
+  ⟨thetaCircleInclusion j, thetaCircleInclusion_continuous j⟩
+
+private theorem CuspCentralHomology.thetaCircleMap_zero :
+    thetaCircleMap 0 =
+      PeriodTorusHigherHomology.sumInlMap _root_.Circle (_root_.Circle ⊕ _root_.Circle) :=
+  rfl
+
+private theorem CuspCentralHomology.thetaCircleMap_one :
+    thetaCircleMap 1 =
+      (PeriodTorusHigherHomology.sumInrMap _root_.Circle (_root_.Circle ⊕ _root_.Circle)).comp
+        (PeriodTorusHigherHomology.sumInlMap _root_.Circle _root_.Circle) :=
+  rfl
+
+private theorem CuspCentralHomology.thetaCircleMap_two :
+    thetaCircleMap 2 =
+      (PeriodTorusHigherHomology.sumInrMap _root_.Circle (_root_.Circle ⊕ _root_.Circle)).comp
+        (PeriodTorusHigherHomology.sumInrMap _root_.Circle _root_.Circle) :=
+  rfl
+
+private theorem CuspCentralHomology.threeCirclesHomologySplit_apply_mo1973_14596 (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology ThreeCircles n) :
+    threeCirclesHomologySplit n a =
+      ((PeriodTorusHigherHomology.sumHomologyEquiv _root_.Circle (_root_.Circle ⊕ _root_.Circle) n
+            a).1,
+        PeriodTorusHigherHomology.sumHomologyEquiv _root_.Circle _root_.Circle n
+          (PeriodTorusHigherHomology.sumHomologyEquiv _root_.Circle
+              (_root_.Circle ⊕ _root_.Circle) n a).2) :=
+  rfl
+
+private theorem CuspCentralHomology.thetaCircleMap_homologySplit (j : Fin 3) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology _root_.Circle n) :
+    threeCirclesHomologySplit n
+        (SingularMayerVietoris.singularHomologyMap (thetaCircleMap j) n a) =
+      ![(a, (0, 0)), (0, (a, 0)), (0, (0, a))] j := by
+  fin_cases j <;>
+    simp [thetaCircleMap_zero, thetaCircleMap_one, thetaCircleMap_two,
+      PeriodTorusHigherHomology.singularHomologyMap_comp,
+      threeCirclesHomologySplit_apply_mo1973_14596]
+  rfl
+
+private theorem CuspCentralHomology.threeCirclesHomologyOneEquiv_apply_mo1973_14598
+    (a : SingularMayerVietoris.SingularHomology ThreeCircles 1) :
+    threeCirclesHomologyOneEquiv a =
+      ![unitCircleHomologyOneEquiv (threeCirclesHomologySplit 1 a).1,
+        unitCircleHomologyOneEquiv (threeCirclesHomologySplit 1 a).2.1,
+        unitCircleHomologyOneEquiv (threeCirclesHomologySplit 1 a).2.2] :=
+  rfl
+
+private theorem CuspCentralHomology.thetaCircleMap_homologyOne (j : Fin 3)
+    (a : SingularMayerVietoris.SingularHomology _root_.Circle 1) :
+    threeCirclesHomologyOneEquiv
+        (SingularMayerVietoris.singularHomologyMap (thetaCircleMap j) 1 a) =
+      Pi.single j (unitCircleHomologyOneEquiv a) := by
+  rw [threeCirclesHomologyOneEquiv_apply_mo1973_14598, thetaCircleMap_homologySplit]
+  fin_cases j <;> funext k <;> fin_cases k <;> simp
+
+private noncomputable def CuspCentralHomology.thetaTargetBeltHomologyEquiv :
+    SingularMayerVietoris.SingularHomology (Suspension.middleBand ThreeCircles) 1 ≃ₗ[ℤ]
+      (Fin 3 → ℤ) :=
+  (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+        (Suspension.middleBandHomotopyEquiv (X := ThreeCircles)) 1).trans
+    threeCirclesHomologyOneEquiv
+
+private theorem CuspCentralHomology.thetaTargetBeltHomologyEquiv_middleSection
+    (a : SingularMayerVietoris.SingularHomology ThreeCircles 1) :
+    thetaTargetBeltHomologyEquiv
+        (SingularMayerVietoris.singularHomologyMap (suspensionMiddleSection ThreeCircles) 1 a) =
+      threeCirclesHomologyOneEquiv a := by
+  have hsection :
+    (Suspension.middleBandHomotopyEquiv (X := ThreeCircles)).toFun.comp
+        (suspensionMiddleSection ThreeCircles) =
+      ContinuousMap.id ThreeCircles := by
+    apply ContinuousMap.ext
+    exact suspensionMiddleSection_label ThreeCircles
+  change
+    threeCirclesHomologyOneEquiv
+        (((SingularMayerVietoris.singularHomologyMap
+                (Suspension.middleBandHomotopyEquiv (X := ThreeCircles)).toFun 1).comp
+            (SingularMayerVietoris.singularHomologyMap (suspensionMiddleSection ThreeCircles) 1))
+          a) =
+      _
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp, hsection,
+    PeriodTorusHigherHomology.singularHomologyMap_id]
+  rfl
+
+private def CuspCentralHomology.thetaEdgeCharacterMap (j : Fin 3) :
+    C(ToricSpace.CompactFibreTorus, _root_.Circle) :=
+  ⟨hexagonCharacter (thetaEdgeIndex j),
+    edgeCharacter_continuous (ToricComponent.hexagonRay (thetaEdgeIndex j))⟩
+
+private def CuspCentralHomology.thetaBeltMap : C(ThetaBelt, Suspension.middleBand ThreeCircles) :=
+  SingularMayerVietoris.intersectionRestriction thetaCharacterCollapse thetaNorth thetaSouth
+    Suspension.northOpen Suspension.southOpen thetaCharacterCollapse_mapsTo_north
+    thetaCharacterCollapse_mapsTo_south
+
+private theorem CuspCentralHomology.thetaBeltMap_comp_section (j : Fin 3) :
+    thetaBeltMap.comp (thetaBeltSection j) =
+      (suspensionMiddleSection ThreeCircles).comp
+        ((thetaCircleMap j).comp (thetaEdgeCharacterMap j)) := by
+  apply ContinuousMap.ext
+  intro u
+  apply Subtype.ext
+  change
+    thetaCharacterCollapse (thetaBeltSection j u : ToricSpace.CompactFibreTorus × Theta) =
+      (suspensionMiddleSection ThreeCircles (thetaCircleMap j (thetaEdgeCharacterMap j u)) :
+        ThreeCircleSuspension)
+  rw [thetaBeltSection_coe, suspensionMiddleSection_coe, thetaCharacterCollapse_mk]
+  rfl
+
+private theorem CuspCentralHomology.thetaBeltMap_homologyOne_section (j : Fin 3)
+    (a : SingularMayerVietoris.SingularHomology ToricSpace.CompactFibreTorus 1) :
+    thetaTargetBeltHomologyEquiv
+        (SingularMayerVietoris.singularHomologyMap thetaBeltMap 1
+          (SingularMayerVietoris.singularHomologyMap (thetaBeltSection j) 1 a)) =
+      Pi.single j
+        (unitCircleHomologyOneEquiv
+          (SingularMayerVietoris.singularHomologyMap (thetaEdgeCharacterMap j) 1 a)) := by
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    thetaBeltMap_comp_section, PeriodTorusHigherHomology.singularHomologyMap_comp,
+    LinearMap.comp_apply, thetaTargetBeltHomologyEquiv_middleSection,
+    PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply,
+    thetaCircleMap_homologyOne]
+
+private theorem CuspCentralHomology.thetaBeltMap_homologyOne_sum
+    (v : Fin 3 → SingularMayerVietoris.SingularHomology ToricSpace.CompactFibreTorus 1) :
+    thetaTargetBeltHomologyEquiv
+        (SingularMayerVietoris.singularHomologyMap thetaBeltMap 1 (thetaBeltSum v)) =
+      fun j =>
+      unitCircleHomologyOneEquiv
+        (SingularMayerVietoris.singularHomologyMap (thetaEdgeCharacterMap j) 1 (v j)) := by
+  simp only [thetaBeltSum, map_sum, thetaBeltMap_homologyOne_section]
+  funext j
+  simp
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def CuspCentralHomology.compactPhaseH1IndexEquiv : Fin 2 ≃ Fin (Nat.choose 2 1) :=
+  Fin.revPerm.trans (finCongr (by decide))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def CuspCentralHomology.compactPhaseH1OrderEquiv :
+    PeriodTorusHigherHomology.binomialModule 2 1 ≃ₗ[ℤ] (Fin 2 → ℤ) :=
+  ({    toFun v i := v (compactPhaseH1IndexEquiv i)
+        invFun v i := v (compactPhaseH1IndexEquiv.symm i)
+        left_inv v := by ext i; exact congrArg v (compactPhaseH1IndexEquiv.apply_symm_apply i)
+        right_inv v := by ext i; exact congrArg v (compactPhaseH1IndexEquiv.symm_apply_apply i)
+        map_add' _ _ := rfl } :
+      PeriodTorusHigherHomology.binomialModule 2 1 ≃+ (Fin 2 → ℤ)).toIntLinearEquiv
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def CuspCentralHomology.compactPhaseH1Equiv :
+    SingularMayerVietoris.SingularHomology ToricSpace.CompactFibreTorus 1 ≃ₗ[ℤ] (Fin 2 → ℤ) :=
+  ((PeriodTorusHigherHomology.homeomorphHomologyEquiv compactFibreTorusHomeomorph 1).trans
+        (PeriodTorusHigherHomology.productTorusHomologyEquiv 2 1)).trans
+    compactPhaseH1OrderEquiv
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def CuspCentralHomology.compactPhaseCircleMap (v : Fin 2 → ℤ) :
+    C(_root_.Circle, ToricSpace.CompactFibreTorus) :=
+  ⟨ToricSpace.edgeCompactPhase v, ToricSpace.edgeCompactPhase_continuous v⟩
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem CuspCentralHomology.compactPhaseCircleMap_coordinates (v : Fin 2 → ℤ) :
+    (compactFibreTorusHomeomorph :
+            C(ToricSpace.CompactFibreTorus, PeriodTorusHigherHomology.ProductTorus 2)).comp
+        ((compactPhaseCircleMap v).comp
+          (circleCoordinateHomeomorph.symm : C(AddCircle (1 : ℝ), _root_.Circle))) =
+      PeriodTorusHigherHomology.coordinateCircleMap v := by
+  apply ContinuousMap.ext
+  intro z
+  ext i
+  change circleCoordinateHomeomorph (circleCoordinateHomeomorph.symm z ^ v i) = v i • z
+  rw [circleCoordinateHomeomorph_zpow, Homeomorph.apply_symm_apply]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem CuspCentralHomology.compactPhaseCircleMap_positiveHomology (v : Fin 2 → ℤ) :
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv compactFibreTorusHomeomorph 1
+        (SingularMayerVietoris.singularHomologyMap (compactPhaseCircleMap v) 1
+          (unitCircleHomologyOneEquiv.symm 1)) =
+      FirstHurewicz.loopHomologyClass (PeriodTorusHigherHomology.coordinatePeriodLoop 2 v) := by
+  change
+    ((SingularMayerVietoris.singularHomologyMap
+              (compactFibreTorusHomeomorph :
+                C(ToricSpace.CompactFibreTorus, PeriodTorusHigherHomology.ProductTorus 2))
+              1).comp
+          ((SingularMayerVietoris.singularHomologyMap (compactPhaseCircleMap v) 1).comp
+            (SingularMayerVietoris.singularHomologyMap
+              (circleCoordinateHomeomorph.symm : C(AddCircle (1 : ℝ), _root_.Circle)) 1)))
+        (PeriodTorusHigherHomology.circleHomologyOneEquiv.symm 1) =
+      _
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp, compactPhaseCircleMap_coordinates,
+    PeriodTorusHigherHomology.circleHomologyOneEquiv_symm_one]
+  exact PeriodTorusHigherHomology.coordinateCircleMap_positiveHomology v
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem CuspCentralHomology.compactPhase_coordinateTorusClass (i : Fin 2) :
+    PeriodTorusHigherHomology.coordinateTorusClass 2 1 (compactPhaseH1IndexEquiv i) =
+      FirstHurewicz.loopHomologyClass
+        (PeriodTorusHigherHomology.coordinatePeriodLoop 2 (Pi.single i 1)) := by
+  rw [PeriodTorusHigherHomology.coordinateTorusClass,
+    PeriodTorusHigherHomology.productTorusTopClass_one,
+    PeriodTorusHigherHomology.coordinateTorusMap_eq_torusMatrixMap]
+  change
+    FirstHurewicz.inducedHomology
+        (PeriodTorusHigherHomology.torusMatrixMap
+          (PeriodTorusHigherHomology.coordinateTorusMatrix 2 1 (compactPhaseH1IndexEquiv i)))
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 1 (Pi.single 0 1))) =
+      _
+  rw [PeriodTorusHigherHomology.torusMatrixMap_coordinatePeriodHomology]
+  congr 2
+  fin_cases i <;> decide
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def CuspCentralHomology.compactPhaseCoordinateClass (i : Fin 2) :
+    SingularMayerVietoris.SingularHomology ToricSpace.CompactFibreTorus 1 :=
+  SingularMayerVietoris.singularHomologyMap (compactPhaseCircleMap (Pi.single i 1)) 1
+    (unitCircleHomologyOneEquiv.symm 1)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem CuspCentralHomology.compactPhaseH1Equiv_coordinateClass (i : Fin 2) :
+    compactPhaseH1Equiv (compactPhaseCoordinateClass i) = Pi.single i 1 := by
+  change
+    compactPhaseH1OrderEquiv
+        (PeriodTorusHigherHomology.productTorusHomologyEquiv 2 1
+          (PeriodTorusHigherHomology.homeomorphHomologyEquiv compactFibreTorusHomeomorph 1
+            (SingularMayerVietoris.singularHomologyMap (compactPhaseCircleMap (Pi.single i 1)) 1
+              (unitCircleHomologyOneEquiv.symm 1)))) =
+      _
+  rw [compactPhaseCircleMap_positiveHomology, ← compactPhase_coordinateTorusClass,
+    PeriodTorusHigherHomology.productTorusHomologyEquiv_coordinateTorusClass]
+  ext j
+  fin_cases i <;> fin_cases j <;> rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem CuspCentralHomology.compactPhaseH1Equiv_symm_single (i : Fin 2) :
+    compactPhaseH1Equiv.symm (Pi.single i 1) = compactPhaseCoordinateClass i := by
+  apply compactPhaseH1Equiv.injective
+  rw [LinearEquiv.apply_symm_apply, compactPhaseH1Equiv_coordinateClass]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem CuspCentralHomology.compactPhaseH1Equiv_symm_apply (v : Fin 2 → ℤ) :
+    compactPhaseH1Equiv.symm v =
+      v 0 • compactPhaseCoordinateClass 0 + v 1 • compactPhaseCoordinateClass 1 := by
+  have hv : v = v 0 • Pi.single 0 1 + v 1 • Pi.single 1 1 := by
+    ext i
+    fin_cases i <;> simp
+  conv_lhs => rw [hv]
+  rw [map_add, map_zsmul, map_zsmul, compactPhaseH1Equiv_symm_single,
+    compactPhaseH1Equiv_symm_single]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def CuspCentralHomology.compactPhaseCoordinateHomology :
+    (Fin 2 → ℤ) →ₗ[ℤ] SingularMayerVietoris.SingularHomology ToricSpace.CompactFibreTorus 1 :=
+  compactPhaseH1Equiv.symm.toLinearMap
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem CuspCentralHomology.compactPhaseCoordinateHomology_apply (v : Fin 2 → ℤ) :
+    compactPhaseCoordinateHomology v =
+      v 0 • compactPhaseCoordinateClass 0 + v 1 • compactPhaseCoordinateClass 1 :=
+  compactPhaseH1Equiv_symm_apply v
+
+private def CuspCentralHomology.circlePowerMap (k : ℤ) : C(_root_.Circle, _root_.Circle) :=
+  ⟨fun z => z ^ k, continuous_id.zpow k⟩
+
+private def CuspCentralHomology.additiveCirclePowerMap_mo1973_14639 (k : ℤ) :
+    C(AddCircle (1 : ℝ), AddCircle (1 : ℝ)) :=
+  ⟨fun z => k • z, continuous_id.zsmul k⟩
+
+private def CuspCentralHomology.firstCircleProjection_mo1973_14640 :
+    C(PeriodTorusHigherHomology.ProductTorus 4, AddCircle (1 : ℝ)) :=
+  ⟨fun x => x 0, continuous_apply 0⟩
+
+private theorem CuspCentralHomology.firstCircleProjection_positiveLoop_mo1973_14641 :
+    (PeriodTorusHigherHomology.coordinatePeriodLoop 4 (Pi.single (0 : Fin 4) 1)).map
+        firstCircleProjection_mo1973_14640.continuous =
+      PeriodTorusHigherHomology.CirclePaths.positiveLoop := by
+  apply Path.ext
+  funext t
+  change
+    PeriodTorusHigherHomology.coordinatePeriodLoop 4 (Pi.single (0 : Fin 4) 1) t 0 =
+      PeriodTorusHigherHomology.CirclePaths.positiveLoop t
+  simp only [PeriodTorusHigherHomology.coordinatePeriodLoop_apply, Pi.single_eq_same,
+    Int.cast_one, mul_one, PeriodTorusHigherHomology.CirclePaths.positiveLoop_apply]
+
+private theorem CuspCentralHomology.firstCircleProjection_scalarLoop_mo1973_14642 (k : ℤ) :
+    (PeriodTorusHigherHomology.coordinatePeriodLoop 4 (k • Pi.single (0 : Fin 4) 1)).map
+        firstCircleProjection_mo1973_14640.continuous =
+      (PeriodTorusHigherHomology.CirclePaths.positiveLoop.map
+            (additiveCirclePowerMap_mo1973_14639 k).continuous).cast
+        (by simp [additiveCirclePowerMap_mo1973_14639, firstCircleProjection_mo1973_14640])
+        (by simp [additiveCirclePowerMap_mo1973_14639, firstCircleProjection_mo1973_14640]) := by
+  apply Path.ext
+  funext t
+  change
+    PeriodTorusHigherHomology.coordinatePeriodLoop 4 (k • Pi.single (0 : Fin 4) 1) t 0 =
+      k • PeriodTorusHigherHomology.CirclePaths.positiveLoop t
+  rw [PeriodTorusHigherHomology.coordinatePeriodLoop_apply,
+    PeriodTorusHigherHomology.CirclePaths.positiveLoop_apply]
+  simp only [Pi.smul_apply, Pi.single_eq_same, smul_eq_mul, mul_one]
+  change (((t : ℝ) * (k : ℝ) : ℝ) : AddCircle (1 : ℝ)) = ((k • (t : ℝ) : ℝ) : AddCircle (1 : ℝ))
+  congr 1
+  simp only [zsmul_eq_mul, mul_comm]
+
+private theorem CuspCentralHomology.additiveCirclePowerMap_positiveClass_mo1973_14643 (k : ℤ) :
+    SingularMayerVietoris.singularHomologyMap (additiveCirclePowerMap_mo1973_14639 k) 1
+        (FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop) =
+      k • FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop := by
+  have h :=
+    congrArg (FirstHurewicz.inducedHomology firstCircleProjection_mo1973_14640)
+      (map_zsmul (PeriodTorusHigherHomology.coordinateH1 4) k (Pi.single (0 : Fin 4) 1))
+  rw [PeriodTorusHigherHomology.coordinateH1_four_apply (Elliptic.examplePeriod .four),
+    PeriodTorusHigherHomology.coordinateH1_single, map_zsmul,
+    FirstHurewicz.inducedHomology_loopHomologyClass,
+    FirstHurewicz.inducedHomology_loopHomologyClass,
+    firstCircleProjection_scalarLoop_mo1973_14642,
+    firstCircleProjection_positiveLoop_mo1973_14641] at h
+  rw [SingularMayerVietoris.singularHomologyMap_one,
+    FirstHurewicz.inducedHomology_loopHomologyClass]
+  exact h
+
+private theorem CuspCentralHomology.additiveCirclePowerMap_homology_mo1973_14644 (k : ℤ)
+    (a : SingularMayerVietoris.SingularHomology (AddCircle (1 : ℝ)) 1) :
+    PeriodTorusHigherHomology.circleHomologyOneEquiv
+        (SingularMayerVietoris.singularHomologyMap (additiveCirclePowerMap_mo1973_14639 k) 1 a) =
+      k * PeriodTorusHigherHomology.circleHomologyOneEquiv a := by
+  obtain ⟨m, rfl⟩ := PeriodTorusHigherHomology.circleHomologyOneEquiv.symm.surjective a
+  rw [LinearEquiv.apply_symm_apply, PeriodTorusHigherHomology.circleHomologyOneEquiv_symm_int,
+    map_zsmul, additiveCirclePowerMap_positiveClass_mo1973_14643, map_zsmul, map_zsmul,
+    PeriodTorusHigherHomology.circleHomologyOneEquiv_positiveLoop]
+  simp [mul_comm]
+
+private theorem CuspCentralHomology.circlePowerMap_coordinate_mo1973_14645 (k : ℤ) :
+    (circleCoordinateHomeomorph : C(_root_.Circle, AddCircle (1 : ℝ))).comp (circlePowerMap k) =
+      (additiveCirclePowerMap_mo1973_14639 k).comp
+        (circleCoordinateHomeomorph : C(_root_.Circle, AddCircle (1 : ℝ))) := by
+  apply ContinuousMap.ext
+  intro z
+  exact circleCoordinateHomeomorph_zpow z k
+
+private theorem CuspCentralHomology.unitCircleHomologyOneEquiv_circlePowerMap (k : ℤ)
+    (a : SingularMayerVietoris.SingularHomology _root_.Circle 1) :
+    unitCircleHomologyOneEquiv
+        (SingularMayerVietoris.singularHomologyMap (circlePowerMap k) 1 a) =
+      k * unitCircleHomologyOneEquiv a := by
+  change
+    PeriodTorusHigherHomology.circleHomologyOneEquiv
+        (SingularMayerVietoris.singularHomologyMap
+          (circleCoordinateHomeomorph : C(_root_.Circle, AddCircle (1 : ℝ))) 1
+          (SingularMayerVietoris.singularHomologyMap (circlePowerMap k) 1 a)) =
+      k *
+        PeriodTorusHigherHomology.circleHomologyOneEquiv
+          (SingularMayerVietoris.singularHomologyMap
+            (circleCoordinateHomeomorph : C(_root_.Circle, AddCircle (1 : ℝ))) 1 a)
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    circlePowerMap_coordinate_mo1973_14645, PeriodTorusHigherHomology.singularHomologyMap_comp,
+    LinearMap.comp_apply]
+  exact additiveCirclePowerMap_homology_mo1973_14644 k _
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def CuspCentralHomology.edgeCharacterMap (n : Fin 2 → ℤ) :
+    C(ToricSpace.CompactFibreTorus, _root_.Circle) :=
+  ⟨edgeCharacter n, edgeCharacter_continuous n⟩
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem CuspCentralHomology.edgeCharacterMap_comp_circle (n v : Fin 2 → ℤ) :
+    (edgeCharacterMap n).comp (compactPhaseCircleMap v) =
+      circlePowerMap (n 0 * v 1 - n 1 * v 0) := by
+  apply ContinuousMap.ext
+  intro z
+  exact edgeCharacter_edgeCompactPhase n v z
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem CuspCentralHomology.edgeCharacter_circleHomology (n v : Fin 2 → ℤ) :
+    unitCircleHomologyOneEquiv
+        (SingularMayerVietoris.singularHomologyMap (edgeCharacterMap n) 1
+          (SingularMayerVietoris.singularHomologyMap (compactPhaseCircleMap v) 1
+            (unitCircleHomologyOneEquiv.symm 1))) =
+      -n 1 * v 0 + n 0 * v 1 := by
+  change
+    unitCircleHomologyOneEquiv
+        (((SingularMayerVietoris.singularHomologyMap (edgeCharacterMap n) 1).comp
+            (SingularMayerVietoris.singularHomologyMap (compactPhaseCircleMap v) 1))
+          (unitCircleHomologyOneEquiv.symm 1)) =
+      _
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp, edgeCharacterMap_comp_circle,
+    unitCircleHomologyOneEquiv_circlePowerMap, LinearEquiv.apply_symm_apply, mul_one]
+  ring
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem CuspCentralHomology.edgeCharacter_coordinateClass_zero (n : Fin 2 → ℤ) :
+    unitCircleHomologyOneEquiv
+        (SingularMayerVietoris.singularHomologyMap (edgeCharacterMap n) 1
+          (compactPhaseCoordinateClass 0)) =
+      -n 1 := by
+  simpa only [compactPhaseCoordinateClass, Pi.single_eq_same,
+    Pi.single_eq_of_ne (by decide : (1 : Fin 2) ≠ 0), mul_one, MulZeroClass.mul_zero,
+    add_zero] using edgeCharacter_circleHomology n (Pi.single 0 1)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem CuspCentralHomology.edgeCharacter_coordinateClass_one (n : Fin 2 → ℤ) :
+    unitCircleHomologyOneEquiv
+        (SingularMayerVietoris.singularHomologyMap (edgeCharacterMap n) 1
+          (compactPhaseCoordinateClass 1)) =
+      n 0 := by
+  simpa only [compactPhaseCoordinateClass, Pi.single_eq_same,
+    Pi.single_eq_of_ne (by decide : (0 : Fin 2) ≠ 1), mul_one, MulZeroClass.mul_zero,
+    zero_add] using edgeCharacter_circleHomology n (Pi.single 1 1)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem CuspCentralHomology.edgeCharacter_coordinateHomology (n v : Fin 2 → ℤ) :
+    unitCircleHomologyOneEquiv
+        (SingularMayerVietoris.singularHomologyMap (edgeCharacterMap n) 1
+          (compactPhaseCoordinateHomology v)) =
+      -n 1 * v 0 + n 0 * v 1 := by
+  rw [compactPhaseCoordinateHomology_apply]
+  simp only [map_add, map_zsmul, edgeCharacter_coordinateClass_zero,
+    edgeCharacter_coordinateClass_one, zsmul_eq_mul, Int.cast_id]
+  ring
+
+private def CuspCentralHomology.thetaPhaseTripleSum : (Fin 3 → Fin 2 → ℤ) →ₗ[ℤ] (Fin 2 → ℤ)
+    where
+  toFun v := ∑ j, v j
+  map_add' v w := by simp only [Pi.add_apply, Finset.sum_add_distrib]
+  map_smul' c v := by simp only [Pi.smul_apply, RingHom.id_apply, Finset.smul_sum]
+
+private theorem CuspCentralHomology.thetaPhaseTripleSum_apply (v : Fin 3 → Fin 2 → ℤ) (i : Fin 2) :
+    thetaPhaseTripleSum v i = v 0 i + v 1 i + v 2 i := by
+  simp [thetaPhaseTripleSum, Fin.sum_univ_succ, add_assoc]
+
+private def CuspCentralHomology.thetaPhaseTripleCharacters : (Fin 3 → Fin 2 → ℤ) →ₗ[ℤ] (Fin 3 → ℤ)
+    where
+  toFun v := ![v 0 1, -(v 1 0), -(v 2 0) - v 2 1]
+  map_add' v
+    w := by
+    funext j
+    fin_cases j <;> simp <;> ring
+  map_smul' c
+    v := by
+    funext j
+    fin_cases j <;> simp
+    ring
+
+private theorem CuspCentralHomology.thetaPhaseTripleCharacters_eq_det (v : Fin 3 → Fin 2 → ℤ)
+    (j : Fin 3) :
+    thetaPhaseTripleCharacters v j =
+      ToricComponent.hexagonRay (j.castLE (by decide)) 0 * v j 1 -
+        ToricComponent.hexagonRay (j.castLE (by decide)) 1 * v j 0 := by
+  fin_cases j <;> simp [thetaPhaseTripleCharacters, ToricComponent.hexagonRay]
+  ring
+
+private def CuspCentralHomology.thetaPhaseTripleSection : (Fin 3 → ℤ) →ₗ[ℤ] (Fin 3 → Fin 2 → ℤ)
+    where
+  toFun z := ![![z 2 + z 1 - z 0, z 0], ![-z 1, 0], ![z 0 - z 2, -z 0] ]
+  map_add' z
+    w := by
+    funext j i
+    fin_cases j <;> fin_cases i <;> simp <;> ring
+  map_smul' c
+    z := by
+    funext j i
+    fin_cases j <;> fin_cases i <;> simp <;> ring
+
+private theorem CuspCentralHomology.thetaPhaseTripleSum_section (z : Fin 3 → ℤ) :
+    thetaPhaseTripleSum (thetaPhaseTripleSection z) = 0 := by
+  funext i
+  rw [thetaPhaseTripleSum_apply]
+  fin_cases i <;> simp [thetaPhaseTripleSection]
+  ring
+
+private theorem CuspCentralHomology.thetaPhaseTripleCharacters_section (z : Fin 3 → ℤ) :
+    thetaPhaseTripleCharacters (thetaPhaseTripleSection z) = z := by
+  funext j
+  fin_cases j <;> simp [thetaPhaseTripleCharacters, thetaPhaseTripleSection]
+
+private def CuspCentralHomology.thetaBeltPhaseClasses (z : Fin 3 → ℤ) (j : Fin 3) :
+    SingularMayerVietoris.SingularHomology ToricSpace.CompactFibreTorus 1 :=
+  compactPhaseCoordinateHomology (thetaPhaseTripleSection z j)
+
+private theorem CuspCentralHomology.thetaBeltPhaseClasses_sum (z : Fin 3 → ℤ) :
+    ∑ j, thetaBeltPhaseClasses z j = 0 := by
+  change (∑ j, compactPhaseCoordinateHomology (thetaPhaseTripleSection z j)) = 0
+  rw [← map_sum]
+  change compactPhaseCoordinateHomology (thetaPhaseTripleSum (thetaPhaseTripleSection z)) = 0
+  rw [thetaPhaseTripleSum_section, map_zero]
+
+private def CuspCentralHomology.thetaBeltLift (z : Fin 3 → ℤ) :
+    SingularMayerVietoris.SingularHomology ThetaBelt 1 :=
+  thetaBeltSum (thetaBeltPhaseClasses z)
+
+private theorem CuspCentralHomology.thetaBeltLift_mem_ker (z : Fin 3 → ℤ) :
+    SingularMayerVietoris.leftHomologyMap thetaNorth thetaSouth 1 (thetaBeltLift z) = 0 :=
+  thetaBeltSum_mem_ker (thetaBeltPhaseClasses z) (thetaBeltPhaseClasses_sum z)
+
+private theorem CuspCentralHomology.thetaBeltPhaseClasses_character (z : Fin 3 → ℤ) (j : Fin 3) :
+    unitCircleHomologyOneEquiv
+        (SingularMayerVietoris.singularHomologyMap (thetaEdgeCharacterMap j) 1
+          (thetaBeltPhaseClasses z j)) =
+      thetaPhaseTripleCharacters (thetaPhaseTripleSection z) j := by
+  rw [thetaPhaseTripleCharacters_eq_det]
+  calc
+    _ =
+        -ToricComponent.hexagonRay (thetaEdgeIndex j) 1 * thetaPhaseTripleSection z j 0 +
+          ToricComponent.hexagonRay (thetaEdgeIndex j) 0 * thetaPhaseTripleSection z j 1 :=
+      edgeCharacter_coordinateHomology (ToricComponent.hexagonRay (thetaEdgeIndex j))
+        (thetaPhaseTripleSection z j)
+    _ = _ := by
+      change
+        -ToricComponent.hexagonRay (thetaEdgeIndex j) 1 * thetaPhaseTripleSection z j 0 +
+            ToricComponent.hexagonRay (thetaEdgeIndex j) 0 * thetaPhaseTripleSection z j 1 =
+          ToricComponent.hexagonRay (thetaEdgeIndex j) 0 * thetaPhaseTripleSection z j 1 -
+            ToricComponent.hexagonRay (thetaEdgeIndex j) 1 * thetaPhaseTripleSection z j 0
+      ring
+
+private theorem CuspCentralHomology.thetaBeltLift_image (z : Fin 3 → ℤ) :
+    thetaTargetBeltHomologyEquiv
+        (SingularMayerVietoris.singularHomologyMap thetaBeltMap 1 (thetaBeltLift z)) =
+      z := by
+  rw [thetaBeltLift, thetaBeltMap_homologyOne_sum]
+  funext j
+  rw [thetaBeltPhaseClasses_character, thetaPhaseTripleCharacters_section]
+
+private theorem CuspCentralHomology.thetaBelt_kernel_lifts
+    (b : SingularMayerVietoris.SingularHomology (Suspension.middleBand ThreeCircles) 1) :
+    ∃ c : SingularMayerVietoris.SingularHomology ThetaBelt 1,
+      SingularMayerVietoris.leftHomologyMap thetaNorth thetaSouth 1 c = 0 ∧
+        SingularMayerVietoris.singularHomologyMap thetaBeltMap 1 c = b := by
+  refine ⟨thetaBeltLift (thetaTargetBeltHomologyEquiv b), thetaBeltLift_mem_ker _, ?_⟩
+  apply thetaTargetBeltHomologyEquiv.injective
+  exact thetaBeltLift_image (thetaTargetBeltHomologyEquiv b)
+
+private theorem CuspCentralHomology.thetaCharacterCollapse_homologyTwo_surjective :
+    Function.Surjective (SingularMayerVietoris.singularHomologyMap thetaCharacterCollapse 2) :=
+  contractibleTargetCoverMap_homology_surjective (ToricSpace.CompactFibreTorus × Theta)
+    ThreeCircleSuspension thetaCharacterCollapse thetaNorth thetaSouth Suspension.northOpen
+    Suspension.southOpen thetaNorth_isOpen thetaSouth_isOpen theta_open_cover
+    Suspension.northOpen_isOpen Suspension.southOpen_isOpen Suspension.open_cover
+    thetaCharacterCollapse_mapsTo_north thetaCharacterCollapse_mapsTo_south 1
+    thetaBelt_kernel_lifts
+
+private def
+    CuspCentralHomology.doubleSuspensionBoundaryContinuousMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) : C(ThreeCircleSuspension, centralBoundary C ε hε) :=
+  ⟨doubleSuspensionBoundaryMap C ε hε, doubleSuspensionBoundaryMap_continuous C ε hε⟩
+
+private theorem CuspCentralHomology.boundaryLift_coe_eq_doubleSuspensionMap
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (p : ToricSpace.CompactFibreTorus × Theta) :
+    (boundaryLift C ε hε p : CuspRetraction.QuotientCentralFibre C ε) =
+      doubleSuspensionMap C ε hε (shearedThetaCollapse (C 0) p) := by
+  rcases p with ⟨u, q⟩
+  obtain ⟨⟨t, j⟩, rfl⟩ := Suspension.mk_surjective q
+  rw [boundaryLift_mk_coe, shearedThetaCollapse_mk, doubleSuspensionMap_character_orientedEdge]
+
+private theorem CuspCentralHomology.boundaryLift_eq_doubleSuspensionBoundaryMap_comp
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    boundaryLift C ε hε =
+      (doubleSuspensionBoundaryContinuousMap C ε hε).comp (shearedThetaCollapse (C 0)) := by
+  apply ContinuousMap.ext
+  intro p
+  apply Subtype.ext
+  exact boundaryLift_coe_eq_doubleSuspensionMap C ε hε p
+
+private def
+    CuspCentralHomology.boundaryLiftCharacterHomotopy (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) :
+    ((doubleSuspensionBoundaryContinuousMap C ε hε).comp thetaCharacterCollapse).Homotopy
+      (boundaryLift C ε hε) :=
+  ((ContinuousMap.Homotopy.refl (doubleSuspensionBoundaryContinuousMap C ε hε)).comp
+        (thetaShearHomotopy (C 0))).cast
+    rfl (boundaryLift_eq_doubleSuspensionBoundaryMap_comp C ε hε).symm
+
+private theorem
+    CuspCentralHomology.boundaryLift_homology_eq (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (boundaryLift C ε hε) n =
+      (SingularMayerVietoris.singularHomologyMap (doubleSuspensionBoundaryContinuousMap C ε hε)
+            n).comp
+        (SingularMayerVietoris.singularHomologyMap thetaCharacterCollapse n) := by
+  rw [← PeriodTorusHigherHomology.homotopy_homologyMap (boundaryLiftCharacterHomotopy C ε hε) n]
+  exact
+    PeriodTorusHigherHomology.singularHomologyMap_comp thetaCharacterCollapse
+      (doubleSuspensionBoundaryContinuousMap C ε hε) n
+
+private theorem CuspCentralHomology.doubleSuspensionBoundaryContinuousMap_eq_homeomorph
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    doubleSuspensionBoundaryContinuousMap C ε hε =
+      (doubleSuspensionBoundaryHomeomorph C ε hε hε1 hC hR :
+        C(ThreeCircleSuspension, centralBoundary C ε hε)) :=
+  rfl
+
+private theorem
+    CuspCentralHomology.boundaryLift_homologyTwo_surjective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    Function.Surjective (SingularMayerVietoris.singularHomologyMap (boundaryLift C ε hε) 2) := by
+  rw [boundaryLift_homology_eq,
+    doubleSuspensionBoundaryContinuousMap_eq_homeomorph C ε hε hε1 hC hR]
+  exact
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+          (doubleSuspensionBoundaryHomeomorph C ε hε hε1 hC hR) 2).surjective.comp
+      thetaCharacterCollapse_homologyTwo_surjective
+
+private theorem CuspCentralHomology.boundaryInclusion_homologyTwo_range_le_productCollapse
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap (centralBoundaryInclusion C ε hε) 2) ≤
+      LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap (CuspSpecialization.productCollapse C ε hε)
+          2) := by
+  rintro _ ⟨b, rfl⟩
+  obtain ⟨c, hc⟩ := boundaryLift_homologyTwo_surjective C ε hε hε1 hC hR b
+  refine ⟨SingularMayerVietoris.singularHomologyMap thetaProductMap 2 c, ?_⟩
+  have h :=
+    congrArg (fun f => SingularMayerVietoris.singularHomologyMap f 2)
+      (centralBoundaryInclusion_comp_boundaryLift C ε hε)
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodTorusHigherHomology.singularHomologyMap_comp] at h
+  have he := LinearMap.congr_fun h c
+  change
+    SingularMayerVietoris.singularHomologyMap (centralBoundaryInclusion C ε hε) 2
+        (SingularMayerVietoris.singularHomologyMap (boundaryLift C ε hε) 2 c) =
+      SingularMayerVietoris.singularHomologyMap (CuspSpecialization.productCollapse C ε hε) 2
+        (SingularMayerVietoris.singularHomologyMap thetaProductMap 2 c) at he
+  rw [hc] at he
+  exact he.symm
+
+private def CuspCentralHomology.productBaseSection :
+    C(PeriodTorusHigherHomology.ProductTorus 2,
+      ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2) :=
+  ⟨fun t => (1, t), continuous_const.prodMk continuous_id⟩
+
+private theorem CuspCentralHomology.productCollapse_comp_productBaseSection
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    (CuspSpecialization.productCollapse C ε hε).comp productBaseSection =
+      baseTorusSection C ε hε :=
+  rfl
+
+private theorem CuspCentralHomology.baseTorusSection_homology_factorization
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (baseTorusSection C ε hε) n =
+      (SingularMayerVietoris.singularHomologyMap (CuspSpecialization.productCollapse C ε hε)
+            n).comp
+        (SingularMayerVietoris.singularHomologyMap productBaseSection n) := by
+  rw [← productCollapse_comp_productBaseSection,
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+
+private theorem CuspCentralHomology.baseTorusSection_homology_range_le_productCollapse
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (n : ℕ) :
+    LinearMap.range (SingularMayerVietoris.singularHomologyMap (baseTorusSection C ε hε) n) ≤
+      LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap (CuspSpecialization.productCollapse C ε hε)
+          n) := by
+  rintro _ ⟨x, rfl⟩
+  refine ⟨SingularMayerVietoris.singularHomologyMap productBaseSection n x, ?_⟩
+  exact (LinearMap.congr_fun (baseTorusSection_homology_factorization C ε hε n) x).symm
+
+private theorem
+    CuspCentralHomology.integerExtension_quotient_factorization {A B : Type*} [AddCommGroup A]
+    [AddCommGroup B] [Module ℤ A] [Module ℤ B] (i : A →ₗ[ℤ] B) (d p : B →ₗ[ℤ] ℤ)
+    (hi : Function.Injective i) (hd : Function.Surjective d)
+    (hexact : LinearMap.range i = LinearMap.ker d) (hpi : ∀ a, p (i a) = 0) (x : B) :
+    p x = d x * p (integerExtensionLift d hd) := by
+  calc
+    p x =
+        p
+          ((splitIntegerExtensionEquiv i d hi hd hexact).symm
+            (splitIntegerExtensionEquiv i d hi hd hexact x)) := by rw [LinearEquiv.symm_apply_apply]
+    _ = d x * p (integerExtensionLift d hd) := by
+      rw [splitIntegerExtensionEquiv_symm_apply, map_add, hpi, map_zsmul,
+        splitIntegerExtensionEquiv_snd]
+      simp only [zero_add, zsmul_eq_mul, Int.cast_id]
+
+private theorem CuspCentralHomology.integerExtension_quotient_coefficient_isUnit {A B : Type*}
+    [AddCommGroup A] [AddCommGroup B] [Module ℤ A] [Module ℤ B] (i : A →ₗ[ℤ] B) (d p : B →ₗ[ℤ] ℤ)
+    (hi : Function.Injective i) (hd : Function.Surjective d)
+    (hexact : LinearMap.range i = LinearMap.ker d) (hpi : ∀ a, p (i a) = 0)
+    (hp : Function.Surjective p) : IsUnit (p (integerExtensionLift d hd)) := by
+  obtain ⟨x, hx⟩ := hp 1
+  have he : d x * p (integerExtensionLift d hd) = 1 :=
+    (integerExtension_quotient_factorization i d p hi hd hexact hpi x).symm.trans hx
+  exact ⟨⟨p (integerExtensionLift d hd), d x, (mul_comm _ _).trans he, he⟩, rfl⟩
+
+private theorem CuspCentralHomology.integerExtension_replaceQuotient {A B : Type*} [AddCommGroup A]
+    [AddCommGroup B] [Module ℤ A] [Module ℤ B] (i : A →ₗ[ℤ] B) (d p : B →ₗ[ℤ] ℤ)
+    (hi : Function.Injective i) (hd : Function.Surjective d)
+    (hexact : LinearMap.range i = LinearMap.ker d) (hpi : ∀ a, p (i a) = 0)
+    (hp : Function.Surjective p) : LinearMap.range i = LinearMap.ker p := by
+  have hc : p (integerExtensionLift d hd) ≠ 0 :=
+    (integerExtension_quotient_coefficient_isUnit i d p hi hd hexact hpi hp).ne_zero
+  rw [hexact]
+  ext x
+  change d x = 0 ↔ p x = 0
+  rw [integerExtension_quotient_factorization i d p hi hd hexact hpi x, mul_eq_zero]
+  simp only [hc, or_false]
+
+private def
+    CuspCentralHomology.actualSectionAssembly {A B T : Type*} [AddCommGroup A] [AddCommGroup B]
+    [AddCommGroup T] [Module ℤ A] [Module ℤ B] [Module ℤ T] (i : A →ₗ[ℤ] B) (s : T →ₗ[ℤ] B) :
+    (A × T) →ₗ[ℤ] B :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom (i.coprod s).toAddMonoidHom
+
+private theorem
+    CuspCentralHomology.coprod_projection_of_exact_section {A B T : Type*} [AddCommGroup A]
+    [AddCommGroup B] [AddCommGroup T] [Module ℤ A] [Module ℤ B] [Module ℤ T] (i : A →ₗ[ℤ] B)
+    (p : B →ₗ[ℤ] T) (s : T →ₗ[ℤ] B) (hexact : LinearMap.range i = LinearMap.ker p)
+    (hps : ∀ t, p (s t) = t) (az : A × T) : p (i.coprod s az) = az.2 := by
+  have hi : p (i az.1) = 0 := by
+    have ha : i az.1 ∈ LinearMap.range i := ⟨az.1, rfl⟩
+    rw [hexact] at ha
+    exact ha
+  rw [LinearMap.coprod_apply, map_add, hi, hps, zero_add]
+
+private theorem
+    CuspCentralHomology.coprod_injective_of_exact_section {A B T : Type*} [AddCommGroup A]
+    [AddCommGroup B] [AddCommGroup T] [Module ℤ A] [Module ℤ B] [Module ℤ T] (i : A →ₗ[ℤ] B)
+    (p : B →ₗ[ℤ] T) (s : T →ₗ[ℤ] B) (hi : Function.Injective i)
+    (hexact : LinearMap.range i = LinearMap.ker p) (hps : ∀ t, p (s t) = t) :
+    Function.Injective (i.coprod s) := by
+  intro az au h
+  have hsnd : az.2 = au.2 := by
+    have hp := congrArg p h
+    simpa only [coprod_projection_of_exact_section i p s hexact hps] using hp
+  apply Prod.ext _ hsnd
+  apply hi
+  apply add_right_cancel (b := s au.2)
+  simpa only [LinearMap.coprod_apply, hsnd] using h
+
+public
+theorem
+    CuspCentralHomology.coprod_surjective_of_exact_section {A B T : Type*} [AddCommGroup A]
+    [AddCommGroup B] [AddCommGroup T] [Module ℤ A] [Module ℤ B] [Module ℤ T] (i : A →ₗ[ℤ] B)
+    (p : B →ₗ[ℤ] T) (s : T →ₗ[ℤ] B) (hexact : LinearMap.range i = LinearMap.ker p)
+    (hps : ∀ t, p (s t) = t) : Function.Surjective (i.coprod s) := by
+  intro b
+  have hk : b - s (p b) ∈ LinearMap.ker p := by
+    change p (b - s (p b)) = 0
+    rw [map_sub, hps, sub_self]
+  rw [← hexact] at hk
+  obtain ⟨a, ha⟩ := hk
+  refine ⟨(a, p b), ?_⟩
+  change i a + s (p b) = b
+  rw [ha, sub_add_cancel]
+
+private def
+    CuspCentralHomology.splitFromActualSection {A B T : Type*} [AddCommGroup A] [AddCommGroup B]
+    [AddCommGroup T] [Module ℤ A] [Module ℤ B] [Module ℤ T] (i : A →ₗ[ℤ] B) (p : B →ₗ[ℤ] T)
+    (s : T →ₗ[ℤ] B) (hi : Function.Injective i) (hexact : LinearMap.range i = LinearMap.ker p)
+    (hps : ∀ t, p (s t) = t) : (A × T) ≃ₗ[ℤ] B :=
+  LinearEquiv.ofBijective (actualSectionAssembly i s)
+    ⟨coprod_injective_of_exact_section i p s hi hexact hps,
+      coprod_surjective_of_exact_section i p s hexact hps⟩
+
+private abbrev CuspCentralHomology.boundaryH2Inclusion (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) :
+    SingularMayerVietoris.SingularHomology (centralBoundary C r hr) 2 →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 2 :=
+  SingularMayerVietoris.singularHomologyMap (centralBoundaryInclusion C r hr) 2
+
+private def
+    CuspCentralHomology.boundaryH2Quotient (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hr1 : r < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r))
+    (hR : ToricSpace.SmallDrift C r) :
+    SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 2 →ₗ[ℤ] ℤ :=
+  middleQuotientMap C r hr hr1 hC hR (1 / 2) (by norm_num) (by norm_num)
+
+private theorem CuspCentralHomology.boundaryH2Inclusion_injective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (hr1 : r < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r))
+    (hR : ToricSpace.SmallDrift C r) : Function.Injective (boundaryH2Inclusion C r hr) := by
+  let e := outerRegionBoundaryHomotopyEquiv C r hr (1 / 2) (by norm_num) (by norm_num) hr1 hC hR
+  have he :
+    (SingularMayerVietoris.subtypeInclusion (outerRegion C r hr (1 / 2))).comp e.symm.toFun =
+      centralBoundaryInclusion C r hr := by
+    apply ContinuousMap.ext
+    intro q
+    rfl
+  change
+    Function.Injective
+      (SingularMayerVietoris.singularHomologyMap (centralBoundaryInclusion C r hr) 2)
+  rw [← he, PeriodTorusHigherHomology.singularHomologyMap_comp]
+  intro x y hxy
+  have hE :
+    SingularMayerVietoris.singularHomologyMap e.symm.toFun 2 x =
+      SingularMayerVietoris.singularHomologyMap e.symm.toFun 2 y :=
+    (middleOuterInclusion_injective C r hr hr1 hC hR (1 / 2) (by norm_num) (by norm_num)) hxy
+  apply (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv e 2).symm.injective
+  simpa only [PeriodTorusHigherHomology.homotopyEquivHomologyEquiv_symm_apply] using hE
+
+private theorem
+    CuspCentralHomology.boundaryH2Inclusion_range_eq_outer (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (hr1 : r < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r))
+    (hR : ToricSpace.SmallDrift C r) :
+    LinearMap.range (boundaryH2Inclusion C r hr) =
+      LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap
+          (SingularMayerVietoris.subtypeInclusion (outerRegion C r hr (1 / 2))) 2) := by
+  let e := outerRegionBoundaryHomotopyEquiv C r hr (1 / 2) (by norm_num) (by norm_num) hr1 hC hR
+  have he :
+    (SingularMayerVietoris.subtypeInclusion (outerRegion C r hr (1 / 2))).comp e.symm.toFun =
+      centralBoundaryInclusion C r hr := by
+    apply ContinuousMap.ext
+    intro q
+    rfl
+  change
+    LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap (centralBoundaryInclusion C r hr) 2) =
+      _
+  rw [← he, PeriodTorusHigherHomology.singularHomologyMap_comp]
+  exact
+    LinearMap.range_comp_of_range_eq_top _
+      (LinearEquiv.range (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv e 2).symm)
+
+private theorem CuspCentralHomology.boundaryH2Quotient_surjective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (hr1 : r < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r))
+    (hR : ToricSpace.SmallDrift C r) :
+    Function.Surjective (boundaryH2Quotient C r hr hr1 hC hR) :=
+  middleQuotientMap_surjective C r hr hr1 hC hR (1 / 2) (by norm_num) (by norm_num)
+
+private theorem
+    CuspCentralHomology.boundaryH2Inclusion_range_eq_ker (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (hr1 : r < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r))
+    (hR : ToricSpace.SmallDrift C r) :
+    LinearMap.range (boundaryH2Inclusion C r hr) =
+      LinearMap.ker (boundaryH2Quotient C r hr hr1 hC hR) := by
+  rw [boundaryH2Inclusion_range_eq_outer C r hr hr1 hC hR]
+  exact middleSecondHomology_exact C r hr hr1 hC hR (1 / 2) (by norm_num) (by norm_num)
+
+private theorem
+    CuspCentralHomology.baseTorusH2Functional_surjective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Function.Surjective (baseTorusH2Functional C r hr hC) :=
+  baseTorusH2Marking.surjective.comp (baseTorusProjectionHomologyMap_surjective C r hr hC 2)
+
+private theorem
+    CuspCentralHomology.baseTorusH2Functional_ker (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    LinearMap.ker (baseTorusH2Functional C r hr hC) =
+      LinearMap.ker (baseTorusProjectionHomologyMap C r hr hC 2) := by
+  ext x
+  change
+    baseTorusH2Marking (baseTorusProjectionHomologyMap C r hr hC 2 x) = 0 ↔
+      baseTorusProjectionHomologyMap C r hr hC 2 x = 0
+  constructor
+  · intro h
+    apply baseTorusH2Marking.injective
+    simpa only [map_zero] using h
+  · intro h
+    rw [h, map_zero]
+
+private theorem CuspCentralHomology.boundaryH2Inclusion_range_eq_ker_baseFunctional
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) (hr1 : r < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r))
+    (hR : ToricSpace.SmallDrift C r) :
+    LinearMap.range (boundaryH2Inclusion C r hr) =
+      LinearMap.ker (baseTorusH2Functional C r hr hC) :=
+  integerExtension_replaceQuotient (boundaryH2Inclusion C r hr)
+    (boundaryH2Quotient C r hr hr1 hC hR) (baseTorusH2Functional C r hr hC)
+    (boundaryH2Inclusion_injective C r hr hr1 hC hR)
+    (boundaryH2Quotient_surjective C r hr hr1 hC hR)
+    (boundaryH2Inclusion_range_eq_ker C r hr hr1 hC hR)
+    (baseTorusH2Functional_boundary C r hr hC hr1 hR) (baseTorusH2Functional_surjective C r hr hC)
+
+private theorem
+    CuspCentralHomology.baseTorusProjectionHomologyMap_ker (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (hr1 : r < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r))
+    (hR : ToricSpace.SmallDrift C r) :
+    LinearMap.ker (baseTorusProjectionHomologyMap C r hr hC 2) =
+      LinearMap.range (boundaryH2Inclusion C r hr) := by
+  rw [← baseTorusH2Functional_ker, ←
+    boundaryH2Inclusion_range_eq_ker_baseFunctional C r hr hr1 hC hR]
+
+private def
+    CuspCentralHomology.baseTorusH2Split (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hr1 : r < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r))
+    (hR : ToricSpace.SmallDrift C r) :
+    (SingularMayerVietoris.SingularHomology (centralBoundary C r hr) 2 ×
+        SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 2) 2) ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 2 :=
+  splitFromActualSection (boundaryH2Inclusion C r hr) (baseTorusProjectionHomologyMap C r hr hC 2)
+    (baseTorusSectionHomologyMap C r hr 2) (boundaryH2Inclusion_injective C r hr hr1 hC hR)
+    (baseTorusProjectionHomologyMap_ker C r hr hr1 hC hR).symm
+    (baseTorusProjectionHomologyMap_section C r hr hC 2)
+
+private theorem CuspCentralHomology.baseTorusH2_generated (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hr1 : r < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r))
+    (hR : ToricSpace.SmallDrift C r)
+    (x : SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 2) :
+    ∃ a : SingularMayerVietoris.SingularHomology (centralBoundary C r hr) 2,
+      ∃ b : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 2) 2,
+        SingularMayerVietoris.singularHomologyMap (centralBoundaryInclusion C r hr) 2 a +
+            baseTorusSectionHomologyMap C r hr 2 b =
+          x := by
+  obtain ⟨⟨a, b⟩, h⟩ := (baseTorusH2Split C r hr hr1 hC hR).surjective x
+  exact ⟨a, b, h⟩
+
+private theorem CuspCentralHomology.productCollapse_homologyTwo_surjective
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    Function.Surjective
+      (SingularMayerVietoris.singularHomologyMap (CuspSpecialization.productCollapse C ε hε) 2) :=
+  by
+  intro x
+  obtain ⟨a, b, hab⟩ := baseTorusH2_generated C ε hε hε1 hC hR x
+  change
+    SingularMayerVietoris.singularHomologyMap (centralBoundaryInclusion C ε hε) 2 a +
+        SingularMayerVietoris.singularHomologyMap (baseTorusSection C ε hε) 2 b =
+      x at hab
+  have ha :
+    SingularMayerVietoris.singularHomologyMap (centralBoundaryInclusion C ε hε) 2 a ∈
+      LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap (CuspSpecialization.productCollapse C ε hε)
+          2) :=
+    boundaryInclusion_homologyTwo_range_le_productCollapse C ε hε hε1 hC hR ⟨a, rfl⟩
+  have hb :
+    SingularMayerVietoris.singularHomologyMap (baseTorusSection C ε hε) 2 b ∈
+      LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap (CuspSpecialization.productCollapse C ε hε)
+          2) :=
+    baseTorusSection_homology_range_le_productCollapse C ε hε 2 ⟨b, rfl⟩
+  obtain ⟨c, hc⟩ := ha
+  obtain ⟨d, hd⟩ := hb
+  refine ⟨c + d, ?_⟩
+  rw [map_add, hc, hd]
+  exact hab
+
+private theorem CuspCentralHomology.productCollapse_homologyTwo_surjective_of_holomorphic
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Function.Surjective
+      (SingularMayerVietoris.singularHomologyMap (CuspSpecialization.productCollapse C r hr) 2) :=
+  by
+  obtain ⟨δ, hδ, hδr, hδ1, hRCδ, _hRDδ⟩ :=
+    CuspRetraction.exists_common_frozen_radius C hr (fun i j => (hC i j).continuousOn)
+  have hCδ (i j) : ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 δ) :=
+    (hC i j).mono (Metric.ball_subset_ball hδr.le)
+  have he :=
+    congrArg (fun f => SingularMayerVietoris.singularHomologyMap f 2)
+      (centralRadiusHomeomorph_comp_productCollapse C r δ hδr.le hC hδ)
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp] at he
+  rw [← he]
+  exact
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+          (centralRadiusHomeomorph C r δ hδr.le hC hδ) 2).surjective.comp
+      (productCollapse_homologyTwo_surjective C δ hδ hδ1 hCδ hRCδ)
+
+private theorem CuspSpecialization.torusDifference_two_exterior
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 2) :
+    PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv
+        (CuspCoinvariants.torusDifference 2 a) =
+      CuspCoinvariants.exteriorSquareDifference
+        (PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv a) := by
+  change
+    PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀) 2
+            a -
+          a) =
+      exteriorPower.map 2 M₀.mulVecLin
+          (PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv a) -
+        PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv a
+  rw [map_sub, PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv_matrix]
+
+private theorem CuspSpecialization.markedCollapse_homologyTwo_surjective
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε)) :
+    Function.Surjective (SingularMayerVietoris.singularHomologyMap (markedCollapse C ε hε) 2) :=
+  markedCollapse_homology_surjective_of_product C ε hε 2
+    (CuspCentralHomology.productCollapse_homologyTwo_surjective_of_holomorphic C ε hε hC)
+
+private theorem
+    CuspSpecialization.markedCollapse_homologyTwo_kernel (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε)) :
+    LinearMap.ker (SingularMayerVietoris.singularHomologyMap (markedCollapse C ε hε) 2) =
+      LinearMap.range (CuspCoinvariants.torusDifference 2) := by
+  let := CuspCentralHomology.centralSingularH2_free C ε hε hC
+  let := CuspCentralHomology.centralSingularH2_finite C ε hε hC
+  exact
+    CuspCoinvariants.torusTwo_kernel_eq_of_invariant _
+      (markedCollapse_homologyTwo_surjective C ε hε hC)
+      (markedCollapse_homology_invariant C ε hε 2)
+      (CuspCentralHomology.centralSingularH2_finrank C ε hε hC)
+
+private theorem CuspSpecialization.markedCollapse_homologyTwo_eq_zero_iff
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 2) :
+    SingularMayerVietoris.singularHomologyMap (markedCollapse C ε hε) 2 a = 0 ↔
+      ∃ v : PeriodTorusHigherHomologyExterior.latticeExterior 2,
+        exteriorPower.map 2 M₀.mulVecLin v - v =
+          PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv a := by
+  change
+    a ∈ LinearMap.ker (SingularMayerVietoris.singularHomologyMap (markedCollapse C ε hε) 2) ↔
+      PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv a ∈
+        LinearMap.range CuspCoinvariants.exteriorSquareDifference
+  rw [markedCollapse_homologyTwo_kernel C ε hε hC]
+  exact
+    CuspCoinvariants.mem_range_iff_of_intertwines
+      PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv
+      (CuspCoinvariants.torusDifference 2) CuspCoinvariants.exteriorSquareDifference
+      torusDifference_two_exterior a
+
+private abbrev CuspCentralHomology.BaseCover.BaseTorus :=
+  PeriodTorusHigherHomology.ProductTorus 2
+
+private abbrev CuspCentralHomology.BaseCover.basePoint :=
+  CuspCentralHomology.baseTorusPoint
+
+private theorem CuspCentralHomology.BaseCover.basePoint_eq_iff (y z : (CuspHoneycombTiling.Plane)) :
+    basePoint y = basePoint z ↔
+      ∃ v : (CuspHoneycombTiling.Lattice), y = z + CuspHoneycombTiling.latticePoint v := by
+  rw [CuspCentralHomology.baseTorusPoint_eq_iff]
+  constructor
+  · rintro ⟨v, hv⟩
+    exact ⟨ToricSpace.cuspVector v, hv⟩
+  · rintro ⟨v, hv⟩
+    refine ⟨-ToricSpace.cuspVector v, ?_⟩
+    simpa only [ToricSpace.cuspVector_neg, ToricSpace.cuspVector_cuspVector, neg_neg] using hv
+
+private theorem CuspCentralHomology.BaseCover.basePoint_add_latticePoint
+    (v : (CuspHoneycombTiling.Lattice)) (y : (CuspHoneycombTiling.Plane)) :
+    basePoint (y + CuspHoneycombTiling.latticePoint v) = basePoint y :=
+  (basePoint_eq_iff _ _).mpr ⟨v, rfl⟩
+
+private theorem CuspCentralHomology.BaseCover.basePoint_sub_latticePoint
+    (v : (CuspHoneycombTiling.Lattice)) (y : (CuspHoneycombTiling.Plane)) :
+    basePoint (y - CuspHoneycombTiling.latticePoint v) = basePoint y := by
+  simpa only [CuspHoneycombTiling.latticePoint_neg, sub_eq_add_neg] using
+    basePoint_add_latticePoint (-v) y
+
+private def CuspCentralHomology.BaseCover.cellMap : C(CuspHoneycombTiling.baseCell, BaseTorus) :=
+  ⟨fun y => basePoint (y : (CuspHoneycombTiling.Plane)),
+    CuspCentralHomology.baseTorusPoint_continuous.comp continuous_subtype_val⟩
+
+private theorem CuspCentralHomology.BaseCover.cellMap_surjective : Function.Surjective cellMap := by
+  intro q
+  obtain ⟨y, hy⟩ := CuspCentralHomology.baseTorusPoint_surjective q
+  exact
+    ⟨⟨y - CuspHoneycombTiling.latticePoint (CuspHoneycombTiling.floorCenter y),
+        CuspHoneycombTiling.mem_cell_floorCenter y⟩,
+      (basePoint_sub_latticePoint (CuspHoneycombTiling.floorCenter y) y).trans hy⟩
+
+private theorem CuspCentralHomology.BaseCover.cellMap_eq_iff (y z : CuspHoneycombTiling.baseCell) :
+    cellMap y = cellMap z ↔
+      ∃ v : (CuspHoneycombTiling.Lattice),
+        (y : (CuspHoneycombTiling.Plane)) =
+          (z : (CuspHoneycombTiling.Plane)) + CuspHoneycombTiling.latticePoint v :=
+  basePoint_eq_iff y z
+
+private theorem CuspCentralHomology.BaseCover.cellMap_isProperMap : IsProperMap cellMap := by
+  let : CompactSpace CuspHoneycombTiling.baseCell :=
+    isCompact_iff_compactSpace.mp CuspHoneycombTiling.baseCell_isCompact
+  exact cellMap.continuous.isProperMap
+
+private theorem CuspCentralHomology.BaseCover.cellMap_isClosedMap : IsClosedMap cellMap :=
+  cellMap_isProperMap.isClosedMap
+
+private theorem
+    CuspCentralHomology.BaseCover.cellMap_isQuotientMap : Topology.IsQuotientMap cellMap :=
+  cellMap_isClosedMap.isQuotientMap cellMap.continuous cellMap_surjective
+
+private theorem
+    CuspCentralHomology.BaseCover.cellMap_eq_of_interior (y z : CuspHoneycombTiling.baseCell)
+    (hy : (y : (CuspHoneycombTiling.Plane)) ∈ interior CuspHoneycombTiling.baseCell)
+    (h : cellMap y = cellMap z) : y = z := by
+  obtain ⟨v, hv⟩ := (cellMap_eq_iff y z).mp h
+  have hyv : (y : (CuspHoneycombTiling.Plane)) ∈ CuspHoneycombTiling.cell v := by
+    rw [hv, CuspHoneycombTiling.mem_cell, add_sub_cancel_right]
+    exact z.property
+  have hv0 : v = 0 := ((CuspHoneycombTiling.mem_interior_baseCell_iff _).mp hy v).mp hyv
+  apply Subtype.ext
+  simpa only [hv0, CuspHoneycombTiling.latticePoint_zero, add_zero] using hv
+
+private theorem CuspCentralHomology.BaseCover.cellMap_interior_iff_of_eq
+    (y z : CuspHoneycombTiling.baseCell) (h : cellMap y = cellMap z) :
+    (y : (CuspHoneycombTiling.Plane)) ∈ interior CuspHoneycombTiling.baseCell ↔
+      (z : (CuspHoneycombTiling.Plane)) ∈ interior CuspHoneycombTiling.baseCell := by
+  constructor
+  · intro hy
+    simpa only [← cellMap_eq_of_interior y z hy h] using hy
+  · intro hz
+    simpa only [← cellMap_eq_of_interior z y hz h.symm] using hz
+
+private theorem
+    CuspCentralHomology.BaseCover.cellMap_eq_or_frontier (y z : CuspHoneycombTiling.baseCell)
+    (h : cellMap y = cellMap z) :
+    y = z ∨
+      ((y : (CuspHoneycombTiling.Plane)) ∈ frontier CuspHoneycombTiling.baseCell ∧
+        (z : (CuspHoneycombTiling.Plane)) ∈ frontier CuspHoneycombTiling.baseCell) := by
+  by_cases hy : (y : (CuspHoneycombTiling.Plane)) ∈ interior CuspHoneycombTiling.baseCell
+  · exact Or.inl (cellMap_eq_of_interior y z hy h)
+  · right
+    rw [CuspHoneycombTiling.baseCell_isClosed.frontier_eq]
+    refine ⟨⟨y.property, hy⟩, z.property, ?_⟩
+    intro hz
+    exact hy ((cellMap_interior_iff_of_eq y z h).mpr hz)
+
+private theorem CuspCentralHomology.BaseCover.cellGauge_eq_of_cellMap_eq
+    (y z : CuspHoneycombTiling.baseCell) (h : cellMap y = cellMap z) :
+    CuspCentralHomology.Radial.cellGauge (y : (CuspHoneycombTiling.Plane)) =
+      CuspCentralHomology.Radial.cellGauge (z : (CuspHoneycombTiling.Plane)) := by
+  rcases cellMap_eq_or_frontier y z h with rfl | ⟨hy, hz⟩
+  · rfl
+  · rw [(CuspCentralHomology.Radial.mem_frontier_baseCell_iff _).mp hy,
+      (CuspCentralHomology.Radial.mem_frontier_baseCell_iff _).mp hz]
+
+private def CuspCentralHomology.BaseCover.cellRadius : C(CuspHoneycombTiling.baseCell, ℝ) :=
+  ⟨fun y => CuspCentralHomology.Radial.cellGauge (y : (CuspHoneycombTiling.Plane)),
+    CuspCentralHomology.Radial.cellGauge_continuous.comp continuous_subtype_val⟩
+
+private def CuspCentralHomology.BaseCover.radius : C(BaseTorus, ℝ)
+    where
+  toFun := CuspHoneycombHexagon.CommonFibres.descend cellMap cellRadius cellMap_surjective
+  continuous_toFun :=
+    CuspHoneycombHexagon.CommonFibres.descend_continuous cellMap cellRadius cellMap_surjective
+      cellMap_isQuotientMap cellRadius.continuous cellGauge_eq_of_cellMap_eq
+
+@[simp]
+private theorem CuspCentralHomology.BaseCover.radius_cellMap (y : CuspHoneycombTiling.baseCell) :
+    radius (cellMap y) = CuspCentralHomology.Radial.cellGauge (y : (CuspHoneycombTiling.Plane)) :=
+  CuspHoneycombHexagon.CommonFibres.descend_apply cellMap cellRadius cellMap_surjective
+    cellGauge_eq_of_cellMap_eq y
+
+private def CuspCentralHomology.BaseCover.boundary : Set BaseTorus :=
+  {q | radius q = 1}
+
+private def CuspCentralHomology.BaseCover.innerRegion : Set BaseTorus :=
+  {q | radius q < 1}
+
+private def CuspCentralHomology.BaseCover.outerRegion (a : ℝ) : Set BaseTorus :=
+  {q | a < radius q}
+
+private theorem CuspCentralHomology.BaseCover.cellMap_mem_boundary_iff
+    (y : CuspHoneycombTiling.baseCell) :
+    cellMap y ∈ boundary ↔
+      (y : (CuspHoneycombTiling.Plane)) ∈ frontier CuspHoneycombTiling.baseCell := by
+  change radius (cellMap y) = 1 ↔ _
+  rw [radius_cellMap]
+  exact (CuspCentralHomology.Radial.mem_frontier_baseCell_iff _).symm
+
+private theorem CuspCentralHomology.BaseCover.cellMap_mem_innerRegion_iff
+    (y : CuspHoneycombTiling.baseCell) :
+    cellMap y ∈ innerRegion ↔
+      (y : (CuspHoneycombTiling.Plane)) ∈ interior CuspHoneycombTiling.baseCell := by
+  change radius (cellMap y) < 1 ↔ _
+  rw [radius_cellMap]
+  exact (CuspCentralHomology.Radial.mem_interior_baseCell_iff _).symm
+
+private theorem CuspCentralHomology.BaseCover.cellMap_mem_outerRegion_iff (a : ℝ)
+    (y : CuspHoneycombTiling.baseCell) :
+    cellMap y ∈ outerRegion a ↔
+      a < CuspCentralHomology.Radial.cellGauge (y : (CuspHoneycombTiling.Plane)) := by
+  change a < radius (cellMap y) ↔ _
+  rw [radius_cellMap]
+
+private theorem CuspCentralHomology.BaseCover.innerRegion_isOpen : IsOpen innerRegion :=
+  isOpen_lt radius.continuous continuous_const
+
+private theorem CuspCentralHomology.BaseCover.outerRegion_isOpen (a : ℝ) : IsOpen (outerRegion a) :=
+  isOpen_lt continuous_const radius.continuous
+
+private theorem CuspCentralHomology.BaseCover.boundary_subset_outerRegion (a : ℝ) (ha : a < 1) :
+    boundary ⊆ outerRegion a := by
+  intro q hq
+  change a < radius q
+  change radius q = 1 at hq
+  rwa [hq]
+
+private theorem CuspCentralHomology.BaseCover.outerRegion_union_innerRegion (a : ℝ) (ha : a < 1) :
+    outerRegion a ∪ innerRegion = Set.univ := by
+  apply Set.eq_univ_of_forall
+  intro q
+  by_cases hq : radius q < 1
+  · exact Or.inr hq
+  · exact Or.inl (ha.trans_le (le_of_not_gt hq))
+
+private theorem
+    CuspCentralHomology.BaseCover.dualSidePoint_mem_frontier (k : Fin 6) (t : unitInterval) :
+    CuspCentralHomology.dualSidePoint k t ∈ frontier CuspHoneycombTiling.baseCell := by
+  rw [← CuspCentralHomology.edgeArcBase_eq_dualSidePoint (0 : Matrix (Fin 2) (Fin 2) ℂ)]
+  exact CuspCentralHomology.edgeArcBase_mem_frontier 0 k t
+
+private theorem CuspCentralHomology.BaseCover.exists_dualSidePoint_of_mem_frontier
+    (y : (CuspHoneycombTiling.Plane)) (hy : y ∈ frontier CuspHoneycombTiling.baseCell) :
+    ∃ k : Fin 6, ∃ t : unitInterval, CuspCentralHomology.dualSidePoint k t = y := by
+  obtain ⟨k, t, ht⟩ :=
+    CuspCentralHomology.exists_edgeArcBase_of_mem_frontier (0 : Matrix (Fin 2) (Fin 2) ℂ) y hy
+  exact ⟨k, t, (CuspCentralHomology.edgeArcBase_eq_dualSidePoint 0 k t).symm.trans ht⟩
+
+private theorem
+    CuspCentralHomology.BaseCover.dualSidePoint_opposite (k : Fin 6) (t : unitInterval) :
+    CuspCentralHomology.dualSidePoint (k + 3) (unitInterval.symm t) =
+      CuspCentralHomology.dualSidePoint k t -
+        CuspHoneycombTiling.latticePoint (ToricComponent.hexagonRay k) :=
+  CuspHoneycombTiling.dual_sideInterval_opposite k t
+
+private theorem CuspCentralHomology.BaseCover.basePoint_dualSidePoint_opposite (k : Fin 6)
+    (t : unitInterval) :
+    CuspCentralHomology.baseTorusPoint
+        (CuspCentralHomology.dualSidePoint (k + 3) (unitInterval.symm t)) =
+      CuspCentralHomology.baseTorusPoint (CuspCentralHomology.dualSidePoint k t) := by
+  rw [dualSidePoint_opposite]
+  exact
+    basePoint_sub_latticePoint (ToricComponent.hexagonRay k)
+      (CuspCentralHomology.dualSidePoint k t)
+
+private theorem
+    CuspCentralHomology.BaseCover.thetaBaseMap_mem_boundary (q : CuspCentralHomology.Theta) :
+    CuspCentralHomology.thetaBaseMap q ∈ boundary := by
+  obtain ⟨⟨t, j⟩, rfl⟩ := CuspCentralHomology.Suspension.mk_surjective q
+  rw [CuspCentralHomology.thetaBaseMap_mk_point]
+  let y :=
+    CuspCentralHomology.dualSidePoint (CuspCentralHomology.thetaEdgeIndex j)
+      (if j = 1 then unitInterval.symm t else t)
+  have hy : y ∈ frontier CuspHoneycombTiling.baseCell := dualSidePoint_mem_frontier _ _
+  exact
+    (cellMap_mem_boundary_iff ⟨y, CuspHoneycombTiling.baseCell_isClosed.frontier_subset hy⟩).mpr
+      hy
+
+private theorem CuspCentralHomology.BaseCover.dualSidePoint_basePoint_mem_range (k : Fin 6)
+    (t : unitInterval) :
+    CuspCentralHomology.baseTorusPoint (CuspCentralHomology.dualSidePoint k t) ∈
+      Set.range CuspCentralHomology.thetaBaseMap := by
+  fin_cases k
+  · exact
+      ⟨CuspCentralHomology.Suspension.mk t (0 : Fin 3),
+        CuspCentralHomology.thetaBaseMap_mk_zero t⟩
+  · refine ⟨CuspCentralHomology.Suspension.mk (unitInterval.symm t) (1 : Fin 3), ?_⟩
+    rw [CuspCentralHomology.thetaBaseMap_mk_one, unitInterval.symm_symm]
+    rfl
+  · exact
+      ⟨CuspCentralHomology.Suspension.mk t (2 : Fin 3), CuspCentralHomology.thetaBaseMap_mk_two t⟩
+  · refine ⟨CuspCentralHomology.Suspension.mk (unitInterval.symm t) (0 : Fin 3), ?_⟩
+    rw [CuspCentralHomology.thetaBaseMap_mk_zero]
+    have hi : (0 : Fin 6) + 3 = ⟨3, by decide⟩ := by decide
+    simpa only [unitInterval.symm_symm, hi] using
+      (basePoint_dualSidePoint_opposite 0 (unitInterval.symm t)).symm
+  · refine ⟨CuspCentralHomology.Suspension.mk t (1 : Fin 3), ?_⟩
+    rw [CuspCentralHomology.thetaBaseMap_mk_one]
+    have hi : (1 : Fin 6) + 3 = ⟨4, by decide⟩ := by decide
+    simpa only [unitInterval.symm_symm, hi] using
+      (basePoint_dualSidePoint_opposite 1 (unitInterval.symm t)).symm
+  · refine ⟨CuspCentralHomology.Suspension.mk (unitInterval.symm t) (2 : Fin 3), ?_⟩
+    rw [CuspCentralHomology.thetaBaseMap_mk_two]
+    have hi : (2 : Fin 6) + 3 = ⟨5, by decide⟩ := by decide
+    simpa only [unitInterval.symm_symm, hi] using
+      (basePoint_dualSidePoint_opposite 2 (unitInterval.symm t)).symm
+
+private theorem CuspCentralHomology.BaseCover.range_thetaBaseMap :
+    Set.range CuspCentralHomology.thetaBaseMap = boundary := by
+  ext q
+  constructor
+  · rintro ⟨x, rfl⟩
+    exact thetaBaseMap_mem_boundary x
+  · intro hq
+    obtain ⟨y, rfl⟩ := cellMap_surjective q
+    obtain ⟨k, t, ht⟩ :=
+      exists_dualSidePoint_of_mem_frontier (y : (CuspHoneycombTiling.Plane))
+        ((cellMap_mem_boundary_iff y).mp hq)
+    change
+      CuspCentralHomology.baseTorusPoint (y : (CuspHoneycombTiling.Plane)) ∈
+        Set.range CuspCentralHomology.thetaBaseMap
+    rw [← ht]
+    exact dualSidePoint_basePoint_mem_range k t
+
+private def
+    CuspCentralHomology.BaseCover.thetaBoundaryMap : C(CuspCentralHomology.Theta, boundary) :=
+  ⟨fun q => ⟨CuspCentralHomology.thetaBaseMap q, thetaBaseMap_mem_boundary q⟩,
+    CuspCentralHomology.thetaBaseMap.continuous.subtype_mk _⟩
+
+private theorem CuspCentralHomology.BaseCover.thetaBoundaryMap_surjective :
+    Function.Surjective thetaBoundaryMap := by
+  intro q
+  have hq : (q : BaseTorus) ∈ Set.range CuspCentralHomology.thetaBaseMap :=
+    range_thetaBaseMap.symm.le q.2
+  obtain ⟨x, hx⟩ := hq
+  exact ⟨x, Subtype.ext hx⟩
+
+private theorem CuspCentralHomology.BaseCover.zeroCorrection_deckFibrePhase_mo1973_14847
+    (v : Fin 2 → ℤ) : CuspCollapse.deckFibrePhase (0 : Matrix (Fin 2) (Fin 2) ℂ) v = 1 := by
+  funext i
+  simp [CuspCollapse.deckFibrePhase, CuspPositive.frozenPhaseCoordinate_eq_exp]
+
+private theorem CuspCentralHomology.BaseCover.phaseOneCollapse_eq_of_base_eq_mo1973_14848
+    {y z : (CuspHoneycombTiling.Plane)}
+    (h : CuspCentralHomology.baseTorusPoint y = CuspCentralHomology.baseTorusPoint z) :
+    CuspHoneycomb.honeycombCollapseMap (fun _ => 0) 1 zero_lt_one (1, y) =
+      CuspHoneycomb.honeycombCollapseMap (fun _ => 0) 1 zero_lt_one (1, z) := by
+  obtain ⟨v, hv⟩ := (CuspCentralHomology.baseTorusPoint_eq_iff y z).mp h
+  apply (CuspHoneycomb.honeycombCollapseMap_eq_iff (fun _ => 0) 1 zero_lt_one _ _).mpr
+  refine ⟨v, hv, ?_⟩
+  simp only [zeroCorrection_deckFibrePhase_mo1973_14847, inv_one, mul_one]
+  exact
+    (MulAction.stabilizer ToricSpace.CompactFibreTorus
+        ((CuspHoneycomb.honeycombHomeomorph 0 y).1 : ToricSpace.Space)).one_mem
+
+private theorem CuspCentralHomology.BaseCover.phaseOne_edgeCylinder_mo1973_14849 (k : Fin 6)
+    (t : unitInterval) :
+    CuspCollapse.centralProject (fun _ => 0) 1 zero_lt_one
+        (CuspCentralHomology.edgeCylinder 0 k (t, 1)) =
+      CuspHoneycomb.honeycombCollapseMap (fun _ => 0) 1 zero_lt_one
+        (1, CuspCentralHomology.dualSidePoint k t) := by
+  have h :
+    CuspCollapse.centralProject (fun _ => 0) 1 zero_lt_one
+        (CuspCentralHomology.edgeCylinder 0 k (t, 1)) =
+      CuspHoneycomb.honeycombCollapseMap (fun _ => 0) 1 zero_lt_one
+        (CuspCentralHomology.hexagonCharacterSection k 1,
+          (CuspCentralHomology.edgeArcBase 0 k t : (CuspHoneycombTiling.Plane))) := by
+    change
+      CuspCollapse.centralCollapseMap (fun _ => 0) 1 zero_lt_one
+          (CuspCentralHomology.hexagonCharacterSection k 1,
+            CuspCentralHomology.edgeArcPositive 0 k t) =
+        CuspCollapse.centralCollapseMap (fun _ => 0) 1 zero_lt_one
+          (CuspCentralHomology.hexagonCharacterSection k 1,
+            CuspHoneycomb.honeycombHomeomorph 0
+              (CuspCentralHomology.edgeArcBase 0 k t : (CuspHoneycombTiling.Plane)))
+    rw [CuspCentralHomology.honeycombHomeomorph_edgeArcBase]
+  simpa only [map_one, CuspCentralHomology.edgeArcBase_eq_dualSidePoint] using h
+
+private theorem CuspCentralHomology.BaseCover.phaseOne_doubleCylinder_mo1973_14850
+    (t : unitInterval) (j : Fin 3) :
+    CuspCentralHomology.doubleCylinder (fun _ => 0) 1 zero_lt_one
+        (t, CuspCentralHomology.thetaCircleInclusion j 1) =
+      CuspHoneycomb.honeycombCollapseMap (fun _ => 0) 1 zero_lt_one
+        (1, CuspCentralHomology.orientedEdgeBasePoint t j) := by
+  fin_cases j
+  · exact phaseOne_edgeCylinder_mo1973_14849 0 t
+  · exact phaseOne_edgeCylinder_mo1973_14849 1 (unitInterval.symm t)
+  · exact phaseOne_edgeCylinder_mo1973_14849 2 t
+
+private theorem
+    CuspCentralHomology.BaseCover.thetaBaseCylinder_eq_iff (p q : unitInterval × Fin 3) :
+    CuspCentralHomology.thetaBaseCylinder p = CuspCentralHomology.thetaBaseCylinder q ↔
+      (CuspCentralHomology.suspensionSetoid (Fin 3)).r p q := by
+  rcases p with ⟨s, j⟩
+  rcases q with ⟨t, k⟩
+  constructor
+  · intro h
+    have he :
+      CuspCentralHomology.doubleCylinder (fun _ => 0) 1 zero_lt_one
+          (s, CuspCentralHomology.thetaCircleInclusion j 1) =
+        CuspCentralHomology.doubleCylinder (fun _ => 0) 1 zero_lt_one
+          (t, CuspCentralHomology.thetaCircleInclusion k 1) := by
+      rw [phaseOne_doubleCylinder_mo1973_14850, phaseOne_doubleCylinder_mo1973_14850]
+      exact phaseOneCollapse_eq_of_base_eq_mo1973_14848 h
+    obtain ⟨hst, hzero | hone | hlabel⟩ :=
+      (CuspCentralHomology.doubleCylinder_eq_iff (fun _ => 0) 1 zero_lt_one
+            (s, CuspCentralHomology.thetaCircleInclusion j 1)
+            (t, CuspCentralHomology.thetaCircleInclusion k 1)).mp
+        he
+    · exact ⟨hst, Or.inl hzero⟩
+    · exact ⟨hst, Or.inr (Or.inl hone)⟩
+    · refine ⟨hst, Or.inr (Or.inr ?_)⟩
+      simpa only [CuspCentralHomology.thetaCircleLabel_inclusion] using
+        congrArg CuspCentralHomology.thetaCircleLabel hlabel
+  · exact CuspCentralHomology.thetaBaseCylinder_respects _ _
+
+private theorem CuspCentralHomology.BaseCover.thetaBaseMap_injective :
+    Function.Injective CuspCentralHomology.thetaBaseMap := by
+  intro x y h
+  obtain ⟨⟨s, j⟩, rfl⟩ := CuspCentralHomology.Suspension.mk_surjective x
+  obtain ⟨⟨t, k⟩, rfl⟩ := CuspCentralHomology.Suspension.mk_surjective y
+  exact Quotient.sound ((thetaBaseCylinder_eq_iff (s, j) (t, k)).mp h)
+
+private theorem CuspCentralHomology.BaseCover.thetaBoundaryMap_injective :
+    Function.Injective thetaBoundaryMap := by
+  intro x y h
+  exact thetaBaseMap_injective (congrArg Subtype.val h)
+
+private def CuspCentralHomology.BaseCover.thetaBoundaryHomeomorph :
+    CuspCentralHomology.Theta ≃ₜ boundary :=
+  (thetaBoundaryMap.continuous.isClosedEmbedding
+        thetaBoundaryMap_injective).toIsEmbedding |>.toHomeomorphOfSurjective
+    thetaBoundaryMap_surjective
+
+private def CuspCentralHomology.BaseCover.boundaryThetaHomeomorph :
+    boundary ≃ₜ CuspCentralHomology.Theta :=
+  thetaBoundaryHomeomorph.symm
+
+private theorem CuspCentralHomology.BaseCover.thetaBaseMap_boundaryThetaHomeomorph (q : boundary) :
+    CuspCentralHomology.thetaBaseMap (boundaryThetaHomeomorph q) = (q : BaseTorus) :=
+  congrArg Subtype.val (thetaBoundaryHomeomorph.apply_symm_apply q)
+
+private def CuspCentralHomology.BaseCover.boundaryInclusion : C(boundary, BaseTorus) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private def CuspCentralHomology.BaseCover.frontierBoundaryMap :
+    C(frontier CuspHoneycombTiling.baseCell, boundary) :=
+  ⟨fun y =>
+    ⟨cellMap
+        ⟨(y : (CuspHoneycombTiling.Plane)),
+          CuspHoneycombTiling.baseCell_isClosed.frontier_subset y.2⟩,
+      (cellMap_mem_boundary_iff _).mpr y.2⟩,
+    (cellMap.continuous.comp (continuous_subtype_val.subtype_mk _)).subtype_mk _⟩
+
+private def CuspCentralHomology.BaseCover.circleBoundaryMap : C(Circle, boundary) :=
+  frontierBoundaryMap.comp
+    (CuspCentralHomology.Radial.frontierCellCircleHomeomorph.symm :
+      C(Circle, frontier CuspHoneycombTiling.baseCell))
+
+@[simp]
+private theorem CuspCentralHomology.BaseCover.circleBoundaryMap_coe (z : Circle) :
+    (circleBoundaryMap z : BaseTorus) =
+      CuspCentralHomology.baseTorusPoint
+        (CuspCentralHomology.Radial.frontierCellCircleHomeomorph.symm z :
+          (CuspHoneycombTiling.Plane)) :=
+  rfl
+
+private def CuspCentralHomology.BaseCover.circleThetaMap : C(Circle, CuspCentralHomology.Theta) :=
+  (boundaryThetaHomeomorph : C(boundary, CuspCentralHomology.Theta)).comp circleBoundaryMap
+
+private theorem CuspCentralHomology.BaseCover.thetaBaseMap_circleThetaMap :
+    CuspCentralHomology.thetaBaseMap.comp circleThetaMap =
+      boundaryInclusion.comp circleBoundaryMap := by
+  apply ContinuousMap.ext
+  intro z
+  exact thetaBaseMap_boundaryThetaHomeomorph (circleBoundaryMap z)
+
+private def CuspCentralHomology.BaseCover.collarCellInclusion (a : ℝ)
+    (p : CuspCentralHomology.Radial.OpenCollar a) : CuspHoneycombTiling.baseCell :=
+  ⟨(p : (CuspHoneycombTiling.Plane)), (CuspCentralHomology.Radial.mem_baseCell_iff _).mpr p.2.2⟩
+
+private theorem CuspCentralHomology.BaseCover.collarCellInclusion_continuous (a : ℝ) :
+    Continuous (collarCellInclusion a) :=
+  continuous_subtype_val.subtype_mk _
+
+private theorem CuspCentralHomology.BaseCover.collarCellInclusion_injective (a : ℝ) :
+    Function.Injective (collarCellInclusion a) := by
+  intro p q h
+  apply Subtype.ext
+  exact congrArg (fun y : CuspHoneycombTiling.baseCell => (y : (CuspHoneycombTiling.Plane))) h
+
+private def CuspCentralHomology.BaseCover.collarCellMap (a : ℝ)
+    (p : CuspCentralHomology.Radial.OpenCollar a) : outerRegion a :=
+  ⟨cellMap (collarCellInclusion a p), (cellMap_mem_outerRegion_iff a _).mpr p.2.1⟩
+
+@[simp]
+private theorem CuspCentralHomology.BaseCover.collarCellMap_coe (a : ℝ)
+    (p : CuspCentralHomology.Radial.OpenCollar a) :
+    (collarCellMap a p : BaseTorus) = basePoint (p : (CuspHoneycombTiling.Plane)) :=
+  rfl
+
+private theorem CuspCentralHomology.BaseCover.radius_collarCellMap (a : ℝ)
+    (p : CuspCentralHomology.Radial.OpenCollar a) :
+    radius (collarCellMap a p) =
+      CuspCentralHomology.Radial.cellGauge (p : (CuspHoneycombTiling.Plane)) :=
+  radius_cellMap (collarCellInclusion a p)
+
+private theorem CuspCentralHomology.BaseCover.collarCellMap_continuous (a : ℝ) :
+    Continuous (collarCellMap a) :=
+  (cellMap.continuous.comp (collarCellInclusion_continuous a)).subtype_mk _
+
+private theorem CuspCentralHomology.BaseCover.collarCellMap_surjective (a : ℝ) :
+    Function.Surjective (collarCellMap a) := by
+  rintro ⟨q, hq⟩
+  obtain ⟨y, hy⟩ := cellMap_surjective q
+  have hg : a < CuspCentralHomology.Radial.cellGauge (y : (CuspHoneycombTiling.Plane)) := by
+    apply (cellMap_mem_outerRegion_iff a y).mp
+    rwa [hy]
+  refine
+    ⟨⟨(y : (CuspHoneycombTiling.Plane)), hg,
+        (CuspCentralHomology.Radial.mem_baseCell_iff _).mp y.2⟩,
+      ?_⟩
+  apply Subtype.ext
+  exact hy
+
+private def CuspCentralHomology.BaseCover.collarPreimageHomeomorph (a : ℝ) :
+    CuspCentralHomology.Radial.OpenCollar a ≃ₜ (cellMap ⁻¹' outerRegion a)
+    where
+  toFun p := ⟨collarCellInclusion a p, (cellMap_mem_outerRegion_iff a _).mpr p.2.1⟩
+  invFun
+    p :=
+    ⟨(p.1 : (CuspHoneycombTiling.Plane)), (cellMap_mem_outerRegion_iff a p.1).mp p.2,
+      (CuspCentralHomology.Radial.mem_baseCell_iff _).mp p.1.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := (collarCellInclusion_continuous a).subtype_mk _
+  continuous_invFun := (continuous_subtype_val.comp continuous_subtype_val).subtype_mk _
+
+private theorem CuspCentralHomology.BaseCover.collarCellMap_isProperMap (a : ℝ) :
+    IsProperMap (collarCellMap a) := by
+  have hf := cellMap_isProperMap.restrictPreimage (outerRegion a)
+  have hc := hf.comp (collarPreimageHomeomorph a).isProperMap
+  have he :
+    (outerRegion a).restrictPreimage cellMap ∘ collarPreimageHomeomorph a = collarCellMap a := by
+    funext p
+    apply Subtype.ext
+    rfl
+  rw [he] at hc
+  exact hc
+
+private theorem CuspCentralHomology.BaseCover.collarCellMap_isClosedMap (a : ℝ) :
+    IsClosedMap (collarCellMap a) :=
+  (collarCellMap_isProperMap a).isClosedMap
+
+private theorem CuspCentralHomology.BaseCover.collarCellMap_isQuotientMap (a : ℝ) :
+    Topology.IsQuotientMap (collarCellMap a) :=
+  (collarCellMap_isClosedMap a).isQuotientMap (collarCellMap_continuous a)
+    (collarCellMap_surjective a)
+
+private theorem CuspCentralHomology.BaseCover.collarCellHomotopy_compatible (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) (s : unitInterval) (p q : CuspCentralHomology.Radial.OpenCollar a)
+    (h : collarCellMap a p = collarCellMap a q) :
+    collarCellMap a (CuspCentralHomology.Radial.outwardOpenCollarHomotopy a ha ha1 (s, p)) =
+      collarCellMap a (CuspCentralHomology.Radial.outwardOpenCollarHomotopy a ha ha1 (s, q)) := by
+  have he : cellMap (collarCellInclusion a p) = cellMap (collarCellInclusion a q) :=
+    congrArg Subtype.val h
+  rcases cellMap_eq_or_frontier (collarCellInclusion a p) (collarCellInclusion a q) he with hpq |
+    ⟨hp, hq⟩
+  · rw [collarCellInclusion_injective a hpq]
+  · rw [CuspCentralHomology.Radial.outwardOpenCollarHomotopy_fixed a ha ha1 s p hp,
+      CuspCentralHomology.Radial.outwardOpenCollarHomotopy_fixed a ha ha1 s q hq]
+    exact h
+
+private def CuspCentralHomology.BaseCover.outerRegionBoundaryInclusion (a : ℝ) (ha1 : a < 1) :
+    C(boundary, outerRegion a)
+    where
+  toFun x := ⟨x, boundary_subset_outerRegion a ha1 x.2⟩
+  continuous_toFun := continuous_subtype_val.subtype_mk _
+
+private def CuspCentralHomology.BaseCover.outerRegionDeformation (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1)
+    (s : unitInterval) (x : outerRegion a) : outerRegion a :=
+  CuspHoneycombHexagon.CommonFibres.descend (collarCellMap a)
+    (fun p =>
+      collarCellMap a (CuspCentralHomology.Radial.outwardOpenCollarHomotopy a ha ha1 (s, p)))
+    (collarCellMap_surjective a) x
+
+@[simp]
+private theorem
+    CuspCentralHomology.BaseCover.outerRegionDeformation_collarCellMap (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) (s : unitInterval) (p : CuspCentralHomology.Radial.OpenCollar a) :
+    outerRegionDeformation a ha ha1 s (collarCellMap a p) =
+      collarCellMap a (CuspCentralHomology.Radial.outwardOpenCollarHomotopy a ha ha1 (s, p)) :=
+  CuspHoneycombHexagon.CommonFibres.descend_apply (collarCellMap a)
+    (fun p =>
+      collarCellMap a (CuspCentralHomology.Radial.outwardOpenCollarHomotopy a ha ha1 (s, p)))
+    (collarCellMap_surjective a) (collarCellHomotopy_compatible a ha ha1 s) p
+
+private theorem CuspCentralHomology.BaseCover.outerRegionDeformation_collarCellMap_coe (a : ℝ)
+    (ha : 0 ≤ a) (ha1 : a < 1) (s : unitInterval) (p : CuspCentralHomology.Radial.OpenCollar a) :
+    (outerRegionDeformation a ha ha1 s (collarCellMap a p) : BaseTorus) =
+      basePoint
+        (((1 - (s : ℝ)) + (s : ℝ) / CuspCentralHomology.Radial.cellGauge p) •
+          (p : (CuspHoneycombTiling.Plane))) := by
+  rw [outerRegionDeformation_collarCellMap, collarCellMap_coe,
+    CuspCentralHomology.Radial.outwardOpenCollarHomotopy_coe]
+
+@[simp]
+private theorem CuspCentralHomology.BaseCover.outerRegionDeformation_zero (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) (x : outerRegion a) : outerRegionDeformation a ha ha1 0 x = x := by
+  obtain ⟨p, rfl⟩ := collarCellMap_surjective a x
+  rw [outerRegionDeformation_collarCellMap,
+    (CuspCentralHomology.Radial.outwardOpenCollarHomotopy a ha ha1).apply_zero]
+  rfl
+
+private theorem CuspCentralHomology.BaseCover.outerRegionDeformation_radius (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) (s : unitInterval) (x : outerRegion a) :
+    radius (outerRegionDeformation a ha ha1 s x) = (1 - (s : ℝ)) * radius x + (s : ℝ) := by
+  obtain ⟨p, rfl⟩ := collarCellMap_surjective a x
+  rw [outerRegionDeformation_collarCellMap, radius_collarCellMap, radius_collarCellMap]
+  exact CuspCentralHomology.Radial.outwardOpenCollarHomotopy_gauge a ha ha1 s p
+
+private theorem
+    CuspCentralHomology.BaseCover.outerRegionDeformation_one_mem_boundary (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) (x : outerRegion a) :
+    (outerRegionDeformation a ha ha1 1 x : BaseTorus) ∈ boundary := by
+  change radius (outerRegionDeformation a ha ha1 1 x) = 1
+  rw [outerRegionDeformation_radius]
+  simp
+
+private theorem CuspCentralHomology.BaseCover.outerRegionDeformation_fixed (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) (s : unitInterval) (x : outerRegion a) (hx : (x : BaseTorus) ∈ boundary) :
+    outerRegionDeformation a ha ha1 s x = x := by
+  obtain ⟨p, rfl⟩ := collarCellMap_surjective a x
+  have hp : (p : (CuspHoneycombTiling.Plane)) ∈ frontier CuspHoneycombTiling.baseCell := by
+    apply (CuspCentralHomology.Radial.mem_frontier_baseCell_iff _).mpr
+    change radius (collarCellMap a p) = 1 at hx
+    rwa [radius_collarCellMap] at hx
+  rw [outerRegionDeformation_collarCellMap,
+    CuspCentralHomology.Radial.outwardOpenCollarHomotopy_fixed a ha ha1 s p hp]
+
+private theorem CuspCentralHomology.BaseCover.outerRegionDeformation_continuous (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) :
+    Continuous
+      (fun p : unitInterval × outerRegion a => outerRegionDeformation a ha ha1 p.1 p.2) := by
+  apply (collarCellMap_isQuotientMap a).continuous_lift_prod_right
+  have hc :=
+    (collarCellMap_continuous a).comp
+      (CuspCentralHomology.Radial.outwardOpenCollarHomotopy a ha ha1).continuous
+  simpa only [outerRegionDeformation_collarCellMap, Function.comp_def, Prod.eta] using hc
+
+private def CuspCentralHomology.BaseCover.outerRegionRetraction (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    C(outerRegion a, boundary)
+    where
+  toFun
+    x := ⟨outerRegionDeformation a ha ha1 1 x, outerRegionDeformation_one_mem_boundary a ha ha1 x⟩
+  continuous_toFun :=
+    (continuous_subtype_val.comp
+          ((outerRegionDeformation_continuous a ha ha1).comp
+            (continuous_const.prodMk continuous_id))).subtype_mk
+      _
+
+@[simp]
+private theorem
+    CuspCentralHomology.BaseCover.outerRegionRetraction_coe (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1)
+    (x : outerRegion a) :
+    (outerRegionRetraction a ha ha1 x : BaseTorus) = outerRegionDeformation a ha ha1 1 x :=
+  rfl
+
+private theorem
+    CuspCentralHomology.BaseCover.outerRegionRetraction_collarCellMap (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) (p : CuspCentralHomology.Radial.OpenCollar a) :
+    (outerRegionRetraction a ha ha1 (collarCellMap a p) : BaseTorus) =
+      basePoint
+        ((CuspCentralHomology.Radial.cellGauge p)⁻¹ • (p : (CuspHoneycombTiling.Plane))) := by
+  rw [outerRegionRetraction_coe, outerRegionDeformation_collarCellMap_coe]
+  simp
+
+@[simp]
+private theorem
+    CuspCentralHomology.BaseCover.outerRegionRetraction_comp_inclusion (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) :
+    (outerRegionRetraction a ha ha1).comp (outerRegionBoundaryInclusion a ha1) =
+      ContinuousMap.id boundary := by
+  apply ContinuousMap.ext
+  intro x
+  apply Subtype.ext
+  change
+    (outerRegionDeformation a ha ha1 1 (outerRegionBoundaryInclusion a ha1 x) : BaseTorus) = x
+  exact
+    congrArg Subtype.val
+      (outerRegionDeformation_fixed a ha ha1 1 (outerRegionBoundaryInclusion a ha1 x) x.2)
+
+private def
+    CuspCentralHomology.BaseCover.outerRegionHomotopyRel (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    (ContinuousMap.id (outerRegion a)).HomotopyRel
+      ((outerRegionBoundaryInclusion a ha1).comp (outerRegionRetraction a ha ha1))
+      {x : outerRegion a | (x : BaseTorus) ∈ boundary}
+    where
+  toFun p := outerRegionDeformation a ha ha1 p.1 p.2
+  continuous_toFun := outerRegionDeformation_continuous a ha ha1
+  map_zero_left := outerRegionDeformation_zero a ha ha1
+  map_one_left _ := rfl
+  prop' := outerRegionDeformation_fixed a ha ha1
+
+private def CuspCentralHomology.BaseCover.outerRegionBoundaryHomotopyEquiv (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) : outerRegion a ≃ₕ boundary
+    where
+  toFun := outerRegionRetraction a ha ha1
+  invFun := outerRegionBoundaryInclusion a ha1
+  left_inv := ⟨(outerRegionHomotopyRel a ha ha1).toHomotopy.symm⟩
+  right_inv := by
+    refine ⟨?_⟩
+    rw [outerRegionRetraction_comp_inclusion]
+    exact ContinuousMap.Homotopy.refl _
+
+private def CuspCentralHomology.BaseCover.interiorCellInclusion :
+    C(CuspCentralHomology.Radial.InteriorCell, CuspHoneycombTiling.baseCell)
+    where
+  toFun y := ⟨(y : (CuspHoneycombTiling.Plane)), interior_subset y.property⟩
+  continuous_toFun := continuous_subtype_val.subtype_mk _
+
+private def CuspCentralHomology.BaseCover.interiorCellMap :
+    C(CuspCentralHomology.Radial.InteriorCell, BaseTorus) :=
+  cellMap.comp interiorCellInclusion
+
+private def CuspCentralHomology.BaseCover.interiorCellToInnerRegion :
+    C(CuspCentralHomology.Radial.InteriorCell, innerRegion)
+    where
+  toFun
+    y :=
+    ⟨cellMap (interiorCellInclusion y),
+      (cellMap_mem_innerRegion_iff (interiorCellInclusion y)).mpr y.property⟩
+  continuous_toFun := interiorCellMap.continuous.subtype_mk _
+
+private theorem CuspCentralHomology.BaseCover.interiorCellToInnerRegion_injective :
+    Function.Injective interiorCellToInnerRegion := by
+  intro y z h
+  have he : interiorCellInclusion y = interiorCellInclusion z :=
+    cellMap_eq_of_interior (interiorCellInclusion y) (interiorCellInclusion z) y.property
+      (congrArg Subtype.val h)
+  apply Subtype.ext
+  exact congrArg (fun x : CuspHoneycombTiling.baseCell => (x : (CuspHoneycombTiling.Plane))) he
+
+private theorem CuspCentralHomology.BaseCover.interiorCellToInnerRegion_surjective :
+    Function.Surjective interiorCellToInnerRegion := by
+  intro q
+  obtain ⟨y, hy⟩ := cellMap_surjective (q : BaseTorus)
+  have hyinner : (y : (CuspHoneycombTiling.Plane)) ∈ interior CuspHoneycombTiling.baseCell := by
+    apply (cellMap_mem_innerRegion_iff y).mp
+    rw [hy]
+    exact q.property
+  refine ⟨⟨(y : (CuspHoneycombTiling.Plane)), hyinner⟩, ?_⟩
+  apply Subtype.ext
+  exact hy
+
+private def CuspCentralHomology.BaseCover.interiorPreimageHomeomorph :
+    CuspCentralHomology.Radial.InteriorCell ≃ₜ (cellMap ⁻¹' innerRegion)
+    where
+  toFun
+    y :=
+    ⟨interiorCellInclusion y,
+      (cellMap_mem_innerRegion_iff (interiorCellInclusion y)).mpr y.property⟩
+  invFun
+    y := ⟨(y.1 : (CuspHoneycombTiling.Plane)), (cellMap_mem_innerRegion_iff y.1).mp y.property⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := interiorCellInclusion.continuous.subtype_mk _
+  continuous_invFun := by
+    apply Continuous.subtype_mk
+    exact continuous_subtype_val.comp continuous_subtype_val
+
+private theorem CuspCentralHomology.BaseCover.interiorCellToInnerRegion_isProperMap :
+    IsProperMap interiorCellToInnerRegion := by
+  have h :=
+    (cellMap_isProperMap.restrictPreimage innerRegion).comp interiorPreimageHomeomorph.isProperMap
+  have he :
+    innerRegion.restrictPreimage cellMap ∘ interiorPreimageHomeomorph =
+      interiorCellToInnerRegion := by
+    funext y
+    apply Subtype.ext
+    rfl
+  rw [he] at h
+  exact h
+
+private theorem CuspCentralHomology.BaseCover.interiorCellToInnerRegion_isClosedMap :
+    IsClosedMap interiorCellToInnerRegion :=
+  interiorCellToInnerRegion_isProperMap.isClosedMap
+
+private def CuspCentralHomology.BaseCover.interiorCellHomeomorph :
+    CuspCentralHomology.Radial.InteriorCell ≃ₜ innerRegion :=
+  Equiv.toHomeomorphOfContinuousClosed
+    (Equiv.ofBijective interiorCellToInnerRegion
+      ⟨interiorCellToInnerRegion_injective, interiorCellToInnerRegion_surjective⟩)
+    interiorCellToInnerRegion.continuous interiorCellToInnerRegion_isClosedMap
+
+@[simp]
+private theorem CuspCentralHomology.BaseCover.interiorCellHomeomorph_coe
+    (y : CuspCentralHomology.Radial.InteriorCell) :
+    (interiorCellHomeomorph y : BaseTorus) = cellMap (interiorCellInclusion y) :=
+  rfl
+
+private def CuspCentralHomology.BaseCover.innerRegionCellHomeomorph :
+    innerRegion ≃ₜ CuspCentralHomology.Radial.InteriorCell :=
+  interiorCellHomeomorph.symm
+
+private def CuspCentralHomology.BaseCover.innerRegionPointHomotopyEquiv : innerRegion ≃ₕ Unit :=
+  innerRegionCellHomeomorph.toHomotopyEquiv.trans
+    CuspCentralHomology.Radial.interiorCellPointHomotopyEquiv
+
+private instance CuspCentralHomology.BaseCover.innerRegion_contractibleSpace :
+    ContractibleSpace innerRegion :=
+  innerRegionPointHomotopyEquiv.contractibleSpace
+
+private def CuspCentralHomology.BaseCover.overlapRegion (a : ℝ) : Set BaseTorus :=
+  outerRegion a ∩ innerRegion
+
+private def
+    CuspCentralHomology.BaseCover.overlapIntoInner (a : ℝ) : C(overlapRegion a, innerRegion) :=
+  ⟨fun q => ⟨(q : BaseTorus), q.property.2⟩, continuous_subtype_val.subtype_mk _⟩
+
+private def
+    CuspCentralHomology.BaseCover.overlapIntoOuter (a : ℝ) : C(overlapRegion a, outerRegion a) :=
+  ⟨fun q => ⟨(q : BaseTorus), q.property.1⟩, continuous_subtype_val.subtype_mk _⟩
+
+private def CuspCentralHomology.BaseCover.annulusCellInclusion (a : ℝ) :
+    C(CuspCentralHomology.Radial.Annulus a, CuspCentralHomology.Radial.InteriorCell) :=
+  ⟨fun y =>
+    ⟨(y : (CuspHoneycombTiling.Plane)),
+      (CuspCentralHomology.Radial.mem_interior_baseCell_iff _).mpr y.property.2⟩,
+    continuous_subtype_val.subtype_mk _⟩
+
+@[simp]
+private theorem CuspCentralHomology.BaseCover.annulusCellInclusion_coe (a : ℝ)
+    (y : CuspCentralHomology.Radial.Annulus a) :
+    (annulusCellInclusion a y : (CuspHoneycombTiling.Plane)) =
+      (y : (CuspHoneycombTiling.Plane)) :=
+  rfl
+
+private theorem CuspCentralHomology.BaseCover.annulusCellInclusion_injective (a : ℝ) :
+    Function.Injective (annulusCellInclusion a) := by
+  intro y z h
+  apply Subtype.ext
+  exact
+    congrArg
+      (fun x : CuspCentralHomology.Radial.InteriorCell => (x : (CuspHoneycombTiling.Plane))) h
+
+private theorem CuspCentralHomology.BaseCover.interiorCellHomeomorph_radius
+    (y : CuspCentralHomology.Radial.InteriorCell) :
+    radius (interiorCellHomeomorph y : BaseTorus) =
+      CuspCentralHomology.Radial.cellGauge (y : (CuspHoneycombTiling.Plane)) := by
+  rw [interiorCellHomeomorph_coe, radius_cellMap]
+  rfl
+
+private def CuspCentralHomology.BaseCover.overlapCellMap (a : ℝ) :
+    C(CuspCentralHomology.Radial.Annulus a, overlapRegion a)
+    where
+  toFun
+    y :=
+    ⟨(interiorCellHomeomorph (annulusCellInclusion a y) : BaseTorus),
+      by
+      constructor
+      · change a < radius (interiorCellHomeomorph (annulusCellInclusion a y) : BaseTorus)
+        rw [interiorCellHomeomorph_radius, annulusCellInclusion_coe]
+        exact y.property.1
+      · exact (interiorCellHomeomorph (annulusCellInclusion a y)).property⟩
+  continuous_toFun :=
+    (continuous_subtype_val.comp
+          (interiorCellHomeomorph.continuous.comp (annulusCellInclusion a).continuous)).subtype_mk
+      _
+
+private theorem CuspCentralHomology.BaseCover.overlapCellMap_intoInner (a : ℝ)
+    (y : CuspCentralHomology.Radial.Annulus a) :
+    overlapIntoInner a (overlapCellMap a y) = interiorCellHomeomorph (annulusCellInclusion a y) :=
+  rfl
+
+private def CuspCentralHomology.BaseCover.overlapCellInverse (a : ℝ) :
+    C(overlapRegion a, CuspCentralHomology.Radial.Annulus a)
+    where
+  toFun
+    q :=
+    let y := interiorCellHomeomorph.symm (overlapIntoInner a q)
+    ⟨(y : (CuspHoneycombTiling.Plane)), by
+      constructor
+      · rw [← interiorCellHomeomorph_radius y]
+        dsimp only [y]
+        rw [Homeomorph.apply_symm_apply]
+        exact q.property.1
+      · exact (CuspCentralHomology.Radial.mem_interior_baseCell_iff _).mp y.property⟩
+  continuous_toFun :=
+    (continuous_subtype_val.comp
+          (interiorCellHomeomorph.symm.continuous.comp
+            (overlapIntoInner a).continuous)).subtype_mk
+      _
+
+private theorem
+    CuspCentralHomology.BaseCover.overlapCellInverse_interior (a : ℝ) (q : overlapRegion a) :
+    annulusCellInclusion a (overlapCellInverse a q) =
+      interiorCellHomeomorph.symm (overlapIntoInner a q) :=
+  rfl
+
+private def CuspCentralHomology.BaseCover.annulusOverlapHomeomorph (a : ℝ) :
+    CuspCentralHomology.Radial.Annulus a ≃ₜ overlapRegion a
+    where
+  toFun := overlapCellMap a
+  invFun := overlapCellInverse a
+  left_inv
+    y := by
+    apply annulusCellInclusion_injective a
+    rw [overlapCellInverse_interior, overlapCellMap_intoInner, Homeomorph.symm_apply_apply]
+  right_inv
+    q := by
+    apply Subtype.ext
+    change
+      (interiorCellHomeomorph (annulusCellInclusion a (overlapCellInverse a q)) : BaseTorus) =
+        (q : BaseTorus)
+    rw [overlapCellInverse_interior, Homeomorph.apply_symm_apply]
+    rfl
+  continuous_toFun := (overlapCellMap a).continuous
+  continuous_invFun := (overlapCellInverse a).continuous
+
+private def CuspCentralHomology.BaseCover.overlapHomeomorph (a : ℝ) (ha : 0 ≤ a) :
+    overlapRegion a ≃ₜ CuspCentralHomology.Radial.CellFrontier × Set.Ioo a 1 :=
+  (annulusOverlapHomeomorph a).symm.trans (CuspCentralHomology.Radial.annulusHomeomorph a ha)
+
+private def CuspCentralHomology.BaseCover.overlapDirection (a : ℝ) (ha : 0 ≤ a) :
+    C(overlapRegion a, CuspCentralHomology.Radial.CellFrontier) :=
+  ⟨fun q => (overlapHomeomorph a ha q).1, continuous_fst.comp (overlapHomeomorph a ha).continuous⟩
+
+private theorem CuspCentralHomology.BaseCover.overlapDirection_annulus (a : ℝ) (ha : 0 ≤ a)
+    (y : CuspCentralHomology.Radial.Annulus a) :
+    (overlapDirection a ha (annulusOverlapHomeomorph a y) : (CuspHoneycombTiling.Plane)) =
+      (CuspCentralHomology.Radial.cellGauge (y : (CuspHoneycombTiling.Plane)))⁻¹ •
+        (y : (CuspHoneycombTiling.Plane)) := by
+  change
+    ((CuspCentralHomology.Radial.annulusHomeomorph a ha
+            ((annulusOverlapHomeomorph a).symm (annulusOverlapHomeomorph a y))).1 :
+        (CuspHoneycombTiling.Plane)) =
+      _
+  rw [Homeomorph.symm_apply_apply]
+  rfl
+
+private def
+    CuspCentralHomology.BaseCover.overlapCircleHomotopyEquiv (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    overlapRegion a ≃ₕ _root_.Circle :=
+  (annulusOverlapHomeomorph a).symm.toHomotopyEquiv.trans
+    (CuspCentralHomology.Radial.annulusCircleHomotopyEquiv a ha ha1)
+
+private theorem
+    CuspCentralHomology.BaseCover.overlapCircleHomotopyEquiv_eq_direction (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) (q : overlapRegion a) :
+    overlapCircleHomotopyEquiv a ha ha1 q =
+      CuspCentralHomology.Radial.frontierCellCircleHomeomorph (overlapDirection a ha q) :=
+  rfl
+
+private theorem CuspCentralHomology.BaseCover.overlapIntoOuter_boundary_map (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) :
+    (outerRegionRetraction a ha ha1).comp (overlapIntoOuter a) =
+      circleBoundaryMap.comp (overlapCircleHomotopyEquiv a ha ha1).toFun := by
+  apply ContinuousMap.ext
+  intro q
+  obtain ⟨y, rfl⟩ := (annulusOverlapHomeomorph a).surjective q
+  apply Subtype.ext
+  have hin :
+    overlapIntoOuter a (annulusOverlapHomeomorph a y) =
+      collarCellMap a ⟨(y : (CuspHoneycombTiling.Plane)), y.2.1, y.2.2.le⟩ :=
+    rfl
+  change
+    (outerRegionRetraction a ha ha1 (overlapIntoOuter a (annulusOverlapHomeomorph a y)) :
+        BaseTorus) =
+      (circleBoundaryMap (overlapCircleHomotopyEquiv a ha ha1 (annulusOverlapHomeomorph a y)) :
+        BaseTorus)
+  rw [hin, outerRegionRetraction_collarCellMap, circleBoundaryMap_coe,
+    overlapCircleHomotopyEquiv_eq_direction, Homeomorph.symm_apply_apply,
+    overlapDirection_annulus]
+
+private def CuspCentralHomology.BaseCover.outerRegionThetaHomotopyEquiv (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) : outerRegion a ≃ₕ CuspCentralHomology.Theta :=
+  (outerRegionBoundaryHomotopyEquiv a ha ha1).trans boundaryThetaHomeomorph.toHomotopyEquiv
+
+private theorem CuspCentralHomology.BaseCover.overlapIntoOuter_theta_map (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) :
+    (outerRegionThetaHomotopyEquiv a ha ha1).toFun.comp (overlapIntoOuter a) =
+      circleThetaMap.comp (overlapCircleHomotopyEquiv a ha ha1).toFun := by
+  apply ContinuousMap.ext
+  intro q
+  exact
+    congrArg (fun f : C(overlapRegion a, boundary) => boundaryThetaHomeomorph (f q))
+      (overlapIntoOuter_boundary_map a ha ha1)
+
+private def CuspCentralHomology.BaseCover.baseBoundaryNullhomotopy :
+    (boundaryInclusion.comp circleBoundaryMap).Homotopy
+      (ContinuousMap.const Circle
+        (CuspCentralHomology.baseTorusPoint (0 : (CuspHoneycombTiling.Plane))))
+    where
+  toFun
+    p :=
+    CuspCentralHomology.baseTorusPoint
+      ((1 - (p.1 : ℝ)) •
+        (CuspCentralHomology.Radial.frontierCellCircleHomeomorph.symm p.2 :
+          (CuspHoneycombTiling.Plane)))
+  continuous_toFun :=
+    CuspCentralHomology.baseTorusPoint_continuous.comp
+      ((continuous_const.sub (continuous_subtype_val.comp continuous_fst)).smul
+        (continuous_subtype_val.comp
+          (CuspCentralHomology.Radial.frontierCellCircleHomeomorph.symm.continuous.comp
+            continuous_snd)))
+  map_zero_left
+    z := by
+    change
+      CuspCentralHomology.baseTorusPoint
+          ((1 - (0 : ℝ)) •
+            (CuspCentralHomology.Radial.frontierCellCircleHomeomorph.symm z :
+              (CuspHoneycombTiling.Plane))) =
+        _
+    rw [sub_zero, one_smul]
+    rfl
+  map_one_left
+    z := by
+    change
+      CuspCentralHomology.baseTorusPoint
+          ((1 - (1 : ℝ)) •
+            (CuspCentralHomology.Radial.frontierCellCircleHomeomorph.symm z :
+              (CuspHoneycombTiling.Plane))) =
+        _
+    rw [sub_self, zero_smul]
+    rfl
+
+private theorem CuspCentralHomology.BaseCover.baseBoundary_homotopic_const :
+    (boundaryInclusion.comp circleBoundaryMap).Homotopic
+      (ContinuousMap.const Circle
+        (CuspCentralHomology.baseTorusPoint (0 : (CuspHoneycombTiling.Plane)))) :=
+  ⟨baseBoundaryNullhomotopy⟩
+
+private theorem CuspCentralHomology.BaseCover.thetaBaseMap_circleThetaMap_homotopic_const :
+    (CuspCentralHomology.thetaBaseMap.comp circleThetaMap).Homotopic
+      (ContinuousMap.const Circle
+        (CuspCentralHomology.baseTorusPoint (0 : (CuspHoneycombTiling.Plane)))) := by
+  rw [thetaBaseMap_circleThetaMap]
+  exact baseBoundary_homotopic_const
+
+private abbrev CuspCentralHomology.BaseCover.PhaseBase :=
+  ToricSpace.CompactFibreTorus × BaseTorus
+
+private def CuspCentralHomology.BaseCover.phaseOuterRegion (a : ℝ) : Set PhaseBase :=
+  Prod.snd ⁻¹' outerRegion a
+
+private def CuspCentralHomology.BaseCover.phaseInnerRegion : Set PhaseBase :=
+  Prod.snd ⁻¹' innerRegion
+
+private def CuspCentralHomology.BaseCover.phaseOverlapRegion (a : ℝ) : Set PhaseBase :=
+  phaseOuterRegion a ∩ phaseInnerRegion
+
+private theorem CuspCentralHomology.BaseCover.phaseOuterRegion_isOpen (a : ℝ) :
+    IsOpen (phaseOuterRegion a) :=
+  (outerRegion_isOpen a).preimage continuous_snd
+
+private theorem CuspCentralHomology.BaseCover.phaseInnerRegion_isOpen : IsOpen phaseInnerRegion :=
+  innerRegion_isOpen.preimage continuous_snd
+
+private theorem CuspCentralHomology.BaseCover.phaseOuterRegion_union_phaseInnerRegion (a : ℝ)
+    (ha1 : a < 1) : phaseOuterRegion a ∪ phaseInnerRegion = Set.univ := by
+  change Prod.snd ⁻¹' outerRegion a ∪ Prod.snd ⁻¹' innerRegion = Set.univ
+  rw [← Set.preimage_union, outerRegion_union_innerRegion a ha1, Set.preimage_univ]
+
+private def CuspCentralHomology.BaseCover.phaseRegionProductHomeomorph_mo1973_14992
+    (s : Set BaseTorus) : (Prod.snd ⁻¹' s : Set PhaseBase) ≃ₜ ToricSpace.CompactFibreTorus × s
+    where
+  toFun p := (p.1.1, ⟨p.1.2, p.2⟩)
+  invFun p := ⟨(p.1, (p.2 : BaseTorus)), p.2.property⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun :=
+    (continuous_fst.comp continuous_subtype_val).prodMk
+      ((continuous_snd.comp continuous_subtype_val).subtype_mk _)
+  continuous_invFun :=
+    (continuous_fst.prodMk (continuous_subtype_val.comp continuous_snd)).subtype_mk _
+
+private def CuspCentralHomology.BaseCover.phaseOuterRegionHomeomorph (a : ℝ) :
+    phaseOuterRegion a ≃ₜ ToricSpace.CompactFibreTorus × outerRegion a :=
+  phaseRegionProductHomeomorph_mo1973_14992 (outerRegion a)
+
+private def CuspCentralHomology.BaseCover.phaseInnerRegionHomeomorph :
+    phaseInnerRegion ≃ₜ ToricSpace.CompactFibreTorus × innerRegion :=
+  phaseRegionProductHomeomorph_mo1973_14992 innerRegion
+
+private def CuspCentralHomology.BaseCover.phaseOverlapRegionHomeomorph (a : ℝ) :
+    phaseOverlapRegion a ≃ₜ ToricSpace.CompactFibreTorus × overlapRegion a :=
+  phaseRegionProductHomeomorph_mo1973_14992 (overlapRegion a)
+
+private def CuspCentralHomology.BaseCover.phaseOverlapIntoInner (a : ℝ) :
+    C(phaseOverlapRegion a, phaseInnerRegion) :=
+  ⟨fun p => ⟨(p : PhaseBase), p.property.2⟩, continuous_subtype_val.subtype_mk _⟩
+
+private def CuspCentralHomology.BaseCover.phaseOverlapIntoOuter (a : ℝ) :
+    C(phaseOverlapRegion a, phaseOuterRegion a) :=
+  ⟨fun p => ⟨(p : PhaseBase), p.property.1⟩, continuous_subtype_val.subtype_mk _⟩
+
+private def CuspCentralHomology.BaseCover.phaseOuterThetaHomotopyEquiv (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) :
+    phaseOuterRegion a ≃ₕ ToricSpace.CompactFibreTorus × CuspCentralHomology.Theta :=
+  (phaseOuterRegionHomeomorph a).toHomotopyEquiv.trans
+    ((ContinuousMap.HomotopyEquiv.refl ToricSpace.CompactFibreTorus).prodCongr
+      (outerRegionThetaHomotopyEquiv a ha ha1))
+
+private def CuspCentralHomology.BaseCover.phaseInnerHomotopyEquiv :
+    phaseInnerRegion ≃ₕ ToricSpace.CompactFibreTorus :=
+  phaseInnerRegionHomeomorph.toHomotopyEquiv.trans
+    (((ContinuousMap.HomotopyEquiv.refl ToricSpace.CompactFibreTorus).prodCongr
+          innerRegionPointHomotopyEquiv).trans
+      (Homeomorph.prodUnique ToricSpace.CompactFibreTorus Unit).toHomotopyEquiv)
+
+private def CuspCentralHomology.BaseCover.phaseOverlapCircleHomotopyEquiv (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) : phaseOverlapRegion a ≃ₕ ToricSpace.CompactFibreTorus × Circle :=
+  (phaseOverlapRegionHomeomorph a).toHomotopyEquiv.trans
+    ((ContinuousMap.HomotopyEquiv.refl ToricSpace.CompactFibreTorus).prodCongr
+      (overlapCircleHomotopyEquiv a ha ha1))
+
+private theorem CuspCentralHomology.BaseCover.phaseOverlapIntoInner_phase_map (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) :
+    phaseInnerHomotopyEquiv.toFun.comp (phaseOverlapIntoInner a) =
+      (ContinuousMap.fst :
+            C(ToricSpace.CompactFibreTorus × Circle, ToricSpace.CompactFibreTorus)).comp
+        (phaseOverlapCircleHomotopyEquiv a ha ha1).toFun := by
+  apply ContinuousMap.ext
+  intro p
+  rfl
+
+private theorem CuspCentralHomology.BaseCover.phaseOverlapIntoOuter_theta_map (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) :
+    (phaseOuterThetaHomotopyEquiv a ha ha1).toFun.comp (phaseOverlapIntoOuter a) =
+      ((ContinuousMap.id ToricSpace.CompactFibreTorus).prodMap circleThetaMap).comp
+        (phaseOverlapCircleHomotopyEquiv a ha ha1).toFun := by
+  apply ContinuousMap.ext
+  intro p
+  apply Prod.ext
+  · rfl
+  · exact
+      congrArg
+        (fun f : C(overlapRegion a, CuspCentralHomology.Theta) =>
+          f (phaseOverlapRegionHomeomorph a p).2)
+        (overlapIntoOuter_theta_map a ha ha1)
+
+private theorem CuspCentralHomology.SpecializationCover.productCollapse_basePoint
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (u : ToricSpace.CompactFibreTorus)
+    (y : (CuspHoneycombTiling.Plane)) :
+    CuspSpecialization.productCollapse C ε hε (u, CuspCentralHomology.BaseCover.basePoint y) =
+      CuspHoneycomb.honeycombCollapseMap C ε hε
+        (u * CuspSpecialization.sourcePhaseCharacter (C 0) y, y) := by
+  change
+    CuspSpecialization.productCollapse C ε hε
+        (u, PeriodTorusHigherHomology.coordinateProjection 2 (-ToricSpace.realCuspVector y)) =
+      _
+  rw [CuspSpecialization.productCollapse_coordinateProjection,
+    CuspSpecialization.realCuspVector_neg_realCuspVector]
+
+private theorem CuspCentralHomology.SpecializationCover.productCollapse_cellMap
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (u : ToricSpace.CompactFibreTorus)
+    (y : CuspHoneycombTiling.baseCell) :
+    CuspSpecialization.productCollapse C ε hε (u, CuspCentralHomology.BaseCover.cellMap y) =
+      CuspCentralHomology.fundamentalCellMap C ε hε
+        (u * CuspSpecialization.sourcePhaseCharacter (C 0) (y : (CuspHoneycombTiling.Plane)),
+          y) :=
+  productCollapse_basePoint C ε hε u y
+
+private theorem CuspCentralHomology.SpecializationCover.productCollapse_radius
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (p : CuspCentralHomology.BaseCover.PhaseBase) :
+    CuspCentralHomology.centralRadius C ε hε (CuspSpecialization.productCollapse C ε hε p) =
+      CuspCentralHomology.BaseCover.radius p.2 := by
+  rcases p with ⟨u, b⟩
+  obtain ⟨y, rfl⟩ := CuspCentralHomology.BaseCover.cellMap_surjective b
+  rw [productCollapse_cellMap, CuspCentralHomology.centralRadius_fundamentalCellMap,
+    CuspCentralHomology.BaseCover.radius_cellMap]
+
+@[simp]
+private theorem CuspCentralHomology.SpecializationCover.productCollapse_mem_outer_iff
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (a : ℝ)
+    (p : CuspCentralHomology.BaseCover.PhaseBase) :
+    CuspSpecialization.productCollapse C ε hε p ∈ CuspCentralHomology.outerRegion C ε hε a ↔
+      p ∈ CuspCentralHomology.BaseCover.phaseOuterRegion a := by
+  change
+    a < CuspCentralHomology.centralRadius C ε hε (CuspSpecialization.productCollapse C ε hε p) ↔
+      a < CuspCentralHomology.BaseCover.radius p.2
+  rw [productCollapse_radius]
+
+@[simp]
+private theorem CuspCentralHomology.SpecializationCover.productCollapse_mem_inner_iff
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (p : CuspCentralHomology.BaseCover.PhaseBase) :
+    CuspSpecialization.productCollapse C ε hε p ∈ CuspCentralHomology.innerRegion C ε hε ↔
+      p ∈ CuspCentralHomology.BaseCover.phaseInnerRegion := by
+  change
+    CuspCentralHomology.centralRadius C ε hε (CuspSpecialization.productCollapse C ε hε p) < 1 ↔
+      CuspCentralHomology.BaseCover.radius p.2 < 1
+  rw [productCollapse_radius]
+
+@[simp]
+private theorem CuspCentralHomology.SpecializationCover.productCollapse_mem_overlap_iff
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (a : ℝ)
+    (p : CuspCentralHomology.BaseCover.PhaseBase) :
+    CuspSpecialization.productCollapse C ε hε p ∈ CuspCentralHomology.overlapRegion C ε hε a ↔
+      p ∈ CuspCentralHomology.BaseCover.phaseOverlapRegion a := by
+  change (_ ∧ _) ↔ (_ ∧ _)
+  rw [productCollapse_mem_outer_iff, productCollapse_mem_inner_iff]
+
+private theorem CuspCentralHomology.SpecializationCover.productCollapse_mapsTo_outer
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (a : ℝ) :
+    Set.MapsTo (CuspSpecialization.productCollapse C ε hε)
+      (CuspCentralHomology.BaseCover.phaseOuterRegion a)
+      (CuspCentralHomology.outerRegion C ε hε a) :=
+  fun p hp => (productCollapse_mem_outer_iff C ε hε a p).mpr hp
+
+private theorem CuspCentralHomology.SpecializationCover.productCollapse_mapsTo_inner
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    Set.MapsTo (CuspSpecialization.productCollapse C ε hε)
+      CuspCentralHomology.BaseCover.phaseInnerRegion (CuspCentralHomology.innerRegion C ε hε) :=
+  fun p hp => (productCollapse_mem_inner_iff C ε hε p).mpr hp
+
+private def
+    CuspCentralHomology.SpecializationCover.overlapMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (a : ℝ) :
+    C(CuspCentralHomology.BaseCover.phaseOverlapRegion a,
+      CuspCentralHomology.overlapRegion C ε hε a)
+    where
+  toFun
+    p :=
+    ⟨CuspSpecialization.productCollapse C ε hε p,
+      (productCollapse_mem_overlap_iff C ε hε a p).mpr p.property⟩
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    exact (CuspSpecialization.productCollapse C ε hε).continuous.comp continuous_subtype_val
+
+@[simp]
+private theorem
+    CuspCentralHomology.SpecializationCover.overlapMap_coe (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (a : ℝ) (p : CuspCentralHomology.BaseCover.phaseOverlapRegion a) :
+    (overlapMap C ε hε a p : CuspRetraction.QuotientCentralFibre C ε) =
+      CuspSpecialization.productCollapse C ε hε p :=
+  rfl
+
+private theorem CuspCentralHomology.productCollapse_connecting_naturality
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha1 : a < 1) (n : ℕ)
+    (x : SingularMayerVietoris.SingularHomology BaseCover.PhaseBase (n + 1)) :
+    SingularMayerVietoris.singularHomologyMap (SpecializationCover.overlapMap C ε hε a) n
+        (SingularMayerVietoris.connectingHomomorphism (BaseCover.phaseOuterRegion a)
+          BaseCover.phaseInnerRegion (BaseCover.phaseOuterRegion_isOpen a)
+          BaseCover.phaseInnerRegion_isOpen
+          (BaseCover.phaseOuterRegion_union_phaseInnerRegion a ha1) n x) =
+      SingularMayerVietoris.connectingHomomorphism (outerRegion C ε hε a) (innerRegion C ε hε)
+        (outerRegion_isOpen C ε hε hε1 hC hR a) (innerRegion_isOpen C ε hε hε1 hC hR)
+        (outerRegion_union_innerRegion C ε hε a ha1) n
+        (SingularMayerVietoris.singularHomologyMap (CuspSpecialization.productCollapse C ε hε)
+          (n + 1) x) :=
+  SingularMayerVietoris.connectingHomomorphism_naturality_apply
+    (CuspSpecialization.productCollapse C ε hε) (BaseCover.phaseOuterRegion a)
+    BaseCover.phaseInnerRegion (outerRegion C ε hε a) (innerRegion C ε hε)
+    (SpecializationCover.productCollapse_mapsTo_outer C ε hε a)
+    (SpecializationCover.productCollapse_mapsTo_inner C ε hε)
+    (BaseCover.phaseOuterRegion_isOpen a) BaseCover.phaseInnerRegion_isOpen
+    (BaseCover.phaseOuterRegion_union_phaseInnerRegion a ha1)
+    (outerRegion_isOpen C ε hε hε1 hC hR a) (innerRegion_isOpen C ε hε hε1 hC hR)
+    (outerRegion_union_innerRegion C ε hε a ha1) n x
+
+private def CuspCentralHomology.SpecializationCover.phaseCellShear (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (s : Set (CuspHoneycombTiling.Plane)) :
+    (ToricSpace.CompactFibreTorus × s) ≃ₜ (ToricSpace.CompactFibreTorus × s)
+    where
+  toFun
+    p :=
+    (p.1 * CuspSpecialization.sourcePhaseCharacter C₀ (p.2 : (CuspHoneycombTiling.Plane)), p.2)
+  invFun
+    p :=
+    (p.1 * (CuspSpecialization.sourcePhaseCharacter C₀ (p.2 : (CuspHoneycombTiling.Plane)))⁻¹,
+      p.2)
+  left_inv p := by simp only [mul_inv_cancel_right, Prod.eta]
+  right_inv p := by simp only [mul_assoc, inv_mul_cancel, mul_one, Prod.eta]
+  continuous_toFun :=
+    (continuous_fst.mul
+          ((CuspSpecialization.sourcePhaseCharacter_continuous C₀).comp
+            (continuous_subtype_val.comp continuous_snd))).prodMk
+      continuous_snd
+  continuous_invFun :=
+    (continuous_fst.mul
+          (((CuspSpecialization.sourcePhaseCharacter_continuous C₀).comp
+              (continuous_subtype_val.comp continuous_snd)).inv)).prodMk
+      continuous_snd
+
+@[simp]
+private theorem CuspCentralHomology.SpecializationCover.phaseCellShear_apply
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (s : Set (CuspHoneycombTiling.Plane))
+    (p : ToricSpace.CompactFibreTorus × s) :
+    phaseCellShear C₀ s p =
+      (p.1 * CuspSpecialization.sourcePhaseCharacter C₀ (p.2 : (CuspHoneycombTiling.Plane)),
+        p.2) :=
+  rfl
+
+private def
+    CuspCentralHomology.SpecializationCover.phaseCellShearHomotopy (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (s : Set (CuspHoneycombTiling.Plane)) :
+    (ContinuousMap.id (ToricSpace.CompactFibreTorus × s)).Homotopy
+      (phaseCellShear C₀ s :
+        C(ToricSpace.CompactFibreTorus × s, ToricSpace.CompactFibreTorus × s))
+    where
+  toFun
+    p :=
+    (p.2.1 *
+        CuspSpecialization.sourcePhaseCharacter C₀
+          ((p.1 : ℝ) • (p.2.2 : (CuspHoneycombTiling.Plane))),
+      p.2.2)
+  continuous_toFun := by
+    have hy :
+      Continuous
+        (fun p : unitInterval × (ToricSpace.CompactFibreTorus × s) =>
+          (p.1 : ℝ) • (p.2.2 : (CuspHoneycombTiling.Plane))) :=
+      (continuous_subtype_val.comp continuous_fst).smul
+        (continuous_subtype_val.comp (continuous_snd.comp continuous_snd))
+    have hχ :
+      Continuous
+        (fun p : unitInterval × (ToricSpace.CompactFibreTorus × s) =>
+          CuspSpecialization.sourcePhaseCharacter C₀
+            ((p.1 : ℝ) • (p.2.2 : (CuspHoneycombTiling.Plane)))) := by
+      simpa only [Function.comp_def] using
+        (CuspSpecialization.sourcePhaseCharacter_continuous C₀).comp hy
+    exact
+      ((continuous_fst.comp continuous_snd).mul hχ).prodMk (continuous_snd.comp continuous_snd)
+  map_zero_left p := by simp [CuspSpecialization.sourcePhaseCharacter_zero]
+  map_one_left p := by simp [phaseCellShear_apply]
+
+private theorem CuspCentralHomology.BaseCover.overlapRegion_pathConnectedSpace (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) : PathConnectedSpace (overlapRegion a) := by
+  let : PathConnectedSpace CuspCentralHomology.Radial.CellFrontier :=
+    CuspCentralHomology.Radial.frontierCellCircleHomeomorph.symm.surjective.pathConnectedSpace
+      CuspCentralHomology.Radial.frontierCellCircleHomeomorph.symm.continuous
+  let : PathConnectedSpace (Set.Ioo a 1) :=
+    isPathConnected_iff_pathConnectedSpace.mp
+      ((convex_Ioo a 1).isPathConnected (Set.nonempty_Ioo.mpr ha1))
+  exact
+    (overlapHomeomorph a ha).symm.surjective.pathConnectedSpace
+      (overlapHomeomorph a ha).symm.continuous
+
+private theorem CuspCentralHomology.BaseCover.halfCoverLeftHomologyZero_injective :
+    Function.Injective
+      (SingularMayerVietoris.leftHomologyMap (CuspCentralHomology.BaseCover.outerRegion (1 / 2))
+        (CuspCentralHomology.BaseCover.innerRegion) 0) := by
+  let := overlapRegion_pathConnectedSpace (1 / 2) (by norm_num) (by norm_num)
+  let i :
+    C((CuspCentralHomology.BaseCover.overlapRegion (1 / 2)),
+      (CuspCentralHomology.BaseCover.innerRegion)) :=
+    ContinuousMap.inclusion
+      (Set.inter_subset_right :
+        (CuspCentralHomology.BaseCover.outerRegion (1 / 2)) ∩
+            (CuspCentralHomology.BaseCover.innerRegion) ⊆
+          (CuspCentralHomology.BaseCover.innerRegion))
+  intro x y hxy
+  have hi :
+    SingularMayerVietoris.singularHomologyMap i 0 x =
+      SingularMayerVietoris.singularHomologyMap i 0 y := by
+    have h := congrArg Prod.snd hxy
+    simp only [SingularMayerVietoris.leftHomologyMap_apply, neg_inj] at h
+    change
+      SingularMayerVietoris.singularHomologyMap i 0 x =
+        SingularMayerVietoris.singularHomologyMap i 0 y at h
+    exact h
+  apply
+    (PeriodTorusHigherHomology.connectedHomologyZeroEquiv
+        (CuspCentralHomology.BaseCover.overlapRegion (1 / 2))).injective
+  have h :=
+    congrArg
+      (PeriodTorusHigherHomology.connectedHomologyZeroEquiv
+        (CuspCentralHomology.BaseCover.innerRegion))
+      hi
+  exact
+    (PeriodTorusHigherHomology.connectedHomologyZeroEquiv_natural i x).symm.trans
+      (h.trans (PeriodTorusHigherHomology.connectedHomologyZeroEquiv_natural i y))
+
+private theorem CuspCentralHomology.BaseCover.halfCoverRightHomologyOne_surjective :
+    Function.Surjective
+      (SingularMayerVietoris.rightHomologyMap (CuspCentralHomology.BaseCover.outerRegion (1 / 2))
+        (CuspCentralHomology.BaseCover.innerRegion) 1) := by
+  let hU := outerRegion_isOpen (1 / 2)
+  let hV := innerRegion_isOpen
+  let hc := outerRegion_union_innerRegion (1 / 2) (by norm_num)
+  intro x
+  have hz :
+    SingularMayerVietoris.connectingHomomorphism
+        (CuspCentralHomology.BaseCover.outerRegion (1 / 2))
+        (CuspCentralHomology.BaseCover.innerRegion) hU hV hc 0 x =
+      0 := by
+    apply halfCoverLeftHomologyZero_injective
+    have h :=
+      LinearMap.congr_fun
+        (SingularMayerVietoris.connectingHomomorphism_comp_left
+          (CuspCentralHomology.BaseCover.outerRegion (1 / 2))
+          (CuspCentralHomology.BaseCover.innerRegion) hU hV hc 0)
+        x
+    simpa only [LinearMap.comp_apply, LinearMap.zero_apply, map_zero] using h
+  have hm :
+    x ∈
+      LinearMap.ker
+        (SingularMayerVietoris.connectingHomomorphism
+          (CuspCentralHomology.BaseCover.outerRegion (1 / 2))
+          (CuspCentralHomology.BaseCover.innerRegion) hU hV hc 0) :=
+    hz
+  rw [←
+    SingularMayerVietoris.exact_at_ambient (CuspCentralHomology.BaseCover.outerRegion (1 / 2))
+      (CuspCentralHomology.BaseCover.innerRegion) hU hV hc 0] at hm
+  exact hm
+
+private theorem CuspCentralHomology.BaseCover.thetaBaseMap_homology_one_surjective :
+    Function.Surjective
+      (SingularMayerVietoris.singularHomologyMap CuspCentralHomology.thetaBaseMap 1) := by
+  let :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology (CuspCentralHomology.BaseCover.innerRegion) 1) :=
+    PeriodTorusHigherHomology.contractible_homology_subsingleton
+      (CuspCentralHomology.BaseCover.innerRegion) 1 (by decide)
+  let e := outerRegionThetaHomotopyEquiv (1 / 2) (by norm_num) (by norm_num)
+  let E := PeriodTorusHigherHomology.homotopyEquivHomologyEquiv e 1
+  have he :
+    (SingularMayerVietoris.subtypeInclusion
+            (CuspCentralHomology.BaseCover.outerRegion (1 / 2))).comp
+        e.symm.toFun =
+      CuspCentralHomology.thetaBaseMap := by
+    apply ContinuousMap.ext
+    intro q
+    rfl
+  intro z
+  obtain ⟨⟨x, y⟩, hxy⟩ := halfCoverRightHomologyOne_surjective z
+  refine ⟨E x, ?_⟩
+  rw [← he, PeriodTorusHigherHomology.singularHomologyMap_comp]
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (SingularMayerVietoris.subtypeInclusion
+          (CuspCentralHomology.BaseCover.outerRegion (1 / 2)))
+        1 (E.symm (E x)) =
+      z
+  rw [E.symm_apply_apply]
+  have hy : y = 0 := Subsingleton.elim _ _
+  simpa only [SingularMayerVietoris.rightHomologyMap_apply, hy, map_zero, add_zero] using hxy
+
+private def CuspCentralHomology.BaseCover.thetaForgetSection :
+    C(CuspCentralHomology.Theta, CuspCentralHomology.ThreeCircleSuspension) :=
+  ⟨fun q => CuspCentralHomology.thetaCharacterCollapse (1, q),
+    CuspCentralHomology.thetaCharacterCollapse.continuous.comp
+      (continuous_const.prodMk continuous_id)⟩
+
+@[simp]
+private theorem
+    CuspCentralHomology.BaseCover.thetaForgetCircle_section (q : CuspCentralHomology.Theta) :
+    CuspCentralHomology.thetaForgetCircle (thetaForgetSection q) = q :=
+  CuspCentralHomology.thetaForgetCircle_collapse 1 q
+
+private theorem CuspCentralHomology.BaseCover.thetaForgetCircle_comp_section :
+    CuspCentralHomology.thetaForgetCircle.comp thetaForgetSection =
+      ContinuousMap.id CuspCentralHomology.Theta := by
+  apply ContinuousMap.ext
+  exact thetaForgetCircle_section
+
+private theorem CuspCentralHomology.BaseCover.thetaForgetCircle_homology_surjective (n : ℕ) :
+    Function.Surjective
+      (SingularMayerVietoris.singularHomologyMap CuspCentralHomology.thetaForgetCircle n) := by
+  have h :
+    (SingularMayerVietoris.singularHomologyMap CuspCentralHomology.thetaForgetCircle n).comp
+        (SingularMayerVietoris.singularHomologyMap thetaForgetSection n) =
+      LinearMap.id := by
+    rw [← PeriodTorusHigherHomology.singularHomologyMap_comp, thetaForgetCircle_comp_section,
+      PeriodTorusHigherHomology.singularHomologyMap_id]
+  intro x
+  exact
+    ⟨SingularMayerVietoris.singularHomologyMap thetaForgetSection n x, LinearMap.congr_fun h x⟩
+
+private theorem CuspCentralHomology.BaseCover.thetaBaseMap_comp_forget_homology_one_injective :
+    Function.Injective
+      ((SingularMayerVietoris.singularHomologyMap CuspCentralHomology.thetaBaseMap 1).comp
+        (SingularMayerVietoris.singularHomologyMap CuspCentralHomology.thetaForgetCircle 1)) := by
+  let : Module.Finite ℤ (SingularMayerVietoris.SingularHomology BaseTorus 1) :=
+    PeriodTorusHigherHomology.productTorus_homology_finite 2 1
+  let e : SingularMayerVietoris.SingularHomology BaseTorus 1 ≃ₗ[ℤ] (Fin 2 → ℤ) :=
+    PeriodTorusHigherHomology.productTorusHomologyEquiv 2 1
+  let i := CuspCentralHomology.threeCircleSuspensionHomologyOneEquiv.trans e.symm
+  exact
+    IsNoetherian.injective_of_surjective_of_injective i.toLinearMap _ i.injective
+      (thetaBaseMap_homology_one_surjective.comp (thetaForgetCircle_homology_surjective 1))
+
+private theorem CuspCentralHomology.BaseCover.thetaBaseMap_homology_one_injective :
+    Function.Injective
+      (SingularMayerVietoris.singularHomologyMap CuspCentralHomology.thetaBaseMap 1) := by
+  intro x y hxy
+  obtain ⟨x', rfl⟩ := thetaForgetCircle_homology_surjective 1 x
+  obtain ⟨y', rfl⟩ := thetaForgetCircle_homology_surjective 1 y
+  exact
+    congrArg (SingularMayerVietoris.singularHomologyMap CuspCentralHomology.thetaForgetCircle 1)
+      (thetaBaseMap_comp_forget_homology_one_injective hxy)
+
+private theorem CuspCentralHomology.BaseCover.circleThetaMap_homology_one_eq_zero :
+    SingularMayerVietoris.singularHomologyMap circleThetaMap 1 = 0 := by
+  have hzero :=
+    CuspCentralHomology.singularHomologyMap_eq_zero_of_nullhomotopic
+      (CuspCentralHomology.thetaBaseMap.comp circleThetaMap)
+      ⟨CuspCentralHomology.baseTorusPoint 0, thetaBaseMap_circleThetaMap_homotopic_const⟩ 1
+      (by decide)
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp] at hzero
+  apply LinearMap.ext
+  intro x
+  apply thetaBaseMap_homology_one_injective
+  simpa only [LinearMap.comp_apply, LinearMap.zero_apply, map_zero] using
+    LinearMap.congr_fun hzero x
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def CuspCentralHomology.productParameterSection {D : Type} [TopologicalSpace D] (X : Type)
+    [TopologicalSpace X] (d : D) : C(X, X × D) :=
+  (ContinuousMap.id X).prodMk (ContinuousMap.const X d)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem CuspCentralHomology.additiveProductParameter_homology_factor {X D : Type}
+    [TopologicalSpace X] [TopologicalSpace D] (β : C(AddCircle (1 : ℝ), D))
+    (hβ : SingularMayerVietoris.singularHomologyMap β 1 = 0) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (β.prodMap (ContinuousMap.id X)) (n + 1) =
+      (SingularMayerVietoris.singularHomologyMap
+            ((ContinuousMap.const X (β 0)).prodMk (ContinuousMap.id X)) (n + 1)).comp
+        (PeriodTorusHigherHomology.circleProjectionHomology X (n + 1)) := by
+  have hs (a : SingularMayerVietoris.SingularHomology X (n + 1)) :
+    SingularMayerVietoris.singularHomologyMap (β.prodMap (ContinuousMap.id X)) (n + 1)
+        (PeriodTorusHigherHomology.circleSectionHomology X (n + 1) a) =
+      SingularMayerVietoris.singularHomologyMap
+        ((ContinuousMap.const X (β 0)).prodMk (ContinuousMap.id X)) (n + 1) a := by
+    change
+      ((SingularMayerVietoris.singularHomologyMap (β.prodMap (ContinuousMap.id X)) (n + 1)).comp
+            (SingularMayerVietoris.singularHomologyMap
+              (PeriodTorusHigherHomology.CircleTopology.productSection X) (n + 1)))
+          a =
+        _
+    rw [← PeriodTorusHigherHomology.singularHomologyMap_comp]
+    rfl
+  apply LinearMap.ext
+  intro a
+  obtain ⟨p, rfl⟩ := (PeriodTorusHigherHomology.circleProductHomologyEquiv X n).symm.surjective a
+  have hp :
+    PeriodTorusHigherHomology.circleProjectionHomology X (n + 1)
+        ((PeriodTorusHigherHomology.circleProductHomologyEquiv X n).symm p) =
+      p.1 := by
+    change
+      (PeriodTorusHigherHomology.circleProductHomologyEquiv X n
+            ((PeriodTorusHigherHomology.circleProductHomologyEquiv X n).symm p)).1 =
+        p.1
+    rw [LinearEquiv.apply_symm_apply]
+  rw [LinearMap.comp_apply, hp,
+    PeriodTorusHigherHomology.circleProductHomologyEquiv_symm_eq_section_add_cross, map_add, hs,
+    parameterMap_positiveCircleCross_eq_zero β hβ, add_zero]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    CuspCentralHomology.productParameter_homology_factor {X D : Type} [TopologicalSpace X]
+    [TopologicalSpace D] (α : C(_root_.Circle, D))
+    (hα : SingularMayerVietoris.singularHomologyMap α 1 = 0) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap ((ContinuousMap.id X).prodMap α) (n + 1) =
+      (SingularMayerVietoris.singularHomologyMap (productParameterSection X (α 1)) (n + 1)).comp
+        (SingularMayerVietoris.singularHomologyMap (ContinuousMap.fst : C(X × _root_.Circle, X))
+          (n + 1)) := by
+  let β : C(AddCircle (1 : ℝ), D) :=
+    α.comp (circleCoordinateHomeomorph.symm : C(AddCircle (1 : ℝ), _root_.Circle))
+  have hβ : SingularMayerVietoris.singularHomologyMap β 1 = 0 := by
+    rw [show β = α.comp (circleCoordinateHomeomorph.symm : C(AddCircle (1 : ℝ), _root_.Circle))
+        from rfl,
+      PeriodTorusHigherHomology.singularHomologyMap_comp, hα, LinearMap.zero_comp]
+  let g : C(AddCircle (1 : ℝ) × X, X × _root_.Circle) :=
+    (circleParametrizedSourceHomeomorph X : C(AddCircle (1 : ℝ) × X, X × _root_.Circle))
+  have hmap :
+    ((ContinuousMap.id X).prodMap α).comp g =
+      (Homeomorph.prodComm D X : C(D × X, X × D)).comp (β.prodMap (ContinuousMap.id X)) :=
+    rfl
+  have hsection :
+    (Homeomorph.prodComm D X : C(D × X, X × D)).comp
+        ((ContinuousMap.const X (β 0)).prodMk (ContinuousMap.id X)) =
+      productParameterSection X (α 1) := by
+    apply ContinuousMap.ext
+    intro x
+    change (x, α (circleCoordinateHomeomorph.symm 0)) = (x, α 1)
+    rw [circleCoordinateHomeomorph_symm_apply, AddCircle.toCircle_zero]
+  have hprojection :
+    (SingularMayerVietoris.singularHomologyMap (ContinuousMap.fst : C(X × _root_.Circle, X))
+            (n + 1)).comp
+        (SingularMayerVietoris.singularHomologyMap g (n + 1)) =
+      PeriodTorusHigherHomology.circleProjectionHomology X (n + 1) := by
+    rw [← PeriodTorusHigherHomology.singularHomologyMap_comp]
+    rfl
+  have hpre :
+    (SingularMayerVietoris.singularHomologyMap ((ContinuousMap.id X).prodMap α) (n + 1)).comp
+        (SingularMayerVietoris.singularHomologyMap g (n + 1)) =
+      ((SingularMayerVietoris.singularHomologyMap (productParameterSection X (α 1)) (n + 1)).comp
+            (SingularMayerVietoris.singularHomologyMap
+              (ContinuousMap.fst : C(X × _root_.Circle, X)) (n + 1))).comp
+        (SingularMayerVietoris.singularHomologyMap g (n + 1)) := by
+    rw [← PeriodTorusHigherHomology.singularHomologyMap_comp, hmap,
+      PeriodTorusHigherHomology.singularHomologyMap_comp,
+      additiveProductParameter_homology_factor β hβ n, ← LinearMap.comp_assoc, ←
+      PeriodTorusHigherHomology.singularHomologyMap_comp, hsection, LinearMap.comp_assoc,
+      hprojection]
+  apply LinearMap.ext
+  intro a
+  obtain ⟨b, rfl⟩ :=
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv (circleParametrizedSourceHomeomorph X)
+          (n + 1)).surjective
+      a
+  exact LinearMap.congr_fun hpre b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem CuspCentralHomology.productParameter_homology_eq_zero_of_projection {X D : Type}
+    [TopologicalSpace X] [TopologicalSpace D] (α : C(_root_.Circle, D))
+    (hα : SingularMayerVietoris.singularHomologyMap α 1 = 0) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (X × _root_.Circle) (n + 1))
+    (ha :
+      SingularMayerVietoris.singularHomologyMap (ContinuousMap.fst : C(X × _root_.Circle, X))
+          (n + 1) a =
+        0) :
+    SingularMayerVietoris.singularHomologyMap ((ContinuousMap.id X).prodMap α) (n + 1) a = 0 := by
+  rw [productParameter_homology_factor α hα n, LinearMap.comp_apply, ha, map_zero]
+
+private def
+    CuspCentralHomology.BaseCover.phaseOverlapHomologyEquiv (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1)
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (phaseOverlapRegion a) n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (ToricSpace.CompactFibreTorus × Circle) n :=
+  PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (phaseOverlapCircleHomotopyEquiv a ha ha1)
+    n
+
+private def CuspCentralHomology.BaseCover.phaseOuterHomologyEquiv (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1)
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (phaseOuterRegion a) n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology
+        (ToricSpace.CompactFibreTorus × CuspCentralHomology.Theta) n :=
+  PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (phaseOuterThetaHomotopyEquiv a ha ha1) n
+
+private def CuspCentralHomology.BaseCover.phaseInnerHomologyEquiv (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (CuspCentralHomology.BaseCover.phaseInnerRegion)
+        n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology ToricSpace.CompactFibreTorus n :=
+  PeriodTorusHigherHomology.homotopyEquivHomologyEquiv phaseInnerHomotopyEquiv n
+
+private theorem CuspCentralHomology.BaseCover.phaseInnerProjection_natural (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) (n : ℕ) (z : SingularMayerVietoris.SingularHomology (phaseOverlapRegion a) n) :
+    phaseInnerHomologyEquiv n
+        (SingularMayerVietoris.singularHomologyMap (phaseOverlapIntoInner a) n z) =
+      SingularMayerVietoris.singularHomologyMap
+        (ContinuousMap.fst :
+          C(ToricSpace.CompactFibreTorus × Circle, ToricSpace.CompactFibreTorus))
+        n (phaseOverlapHomologyEquiv a ha ha1 n z) := by
+  have hm :=
+    congrArg
+      (fun f : C((phaseOverlapRegion a), ToricSpace.CompactFibreTorus) =>
+        SingularMayerVietoris.singularHomologyMap f n)
+      (phaseOverlapIntoInner_phase_map a ha ha1)
+  simpa only [PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply,
+    phaseInnerHomologyEquiv, phaseOverlapHomologyEquiv,
+    PeriodTorusHigherHomology.homotopyEquivHomologyEquiv_apply] using LinearMap.congr_fun hm z
+
+private theorem CuspCentralHomology.BaseCover.phaseOuterParameter_natural (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) (n : ℕ) (z : SingularMayerVietoris.SingularHomology (phaseOverlapRegion a) n) :
+    phaseOuterHomologyEquiv a ha ha1 n
+        (SingularMayerVietoris.singularHomologyMap (phaseOverlapIntoOuter a) n z) =
+      SingularMayerVietoris.singularHomologyMap
+        ((ContinuousMap.id ToricSpace.CompactFibreTorus).prodMap circleThetaMap) n
+        (phaseOverlapHomologyEquiv a ha ha1 n z) := by
+  have hm :=
+    congrArg
+      (fun f :
+          C((phaseOverlapRegion a), ToricSpace.CompactFibreTorus × CuspCentralHomology.Theta) =>
+        SingularMayerVietoris.singularHomologyMap f n)
+      (phaseOverlapIntoOuter_theta_map a ha ha1)
+  simpa only [PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply,
+    phaseOuterHomologyEquiv, phaseOverlapHomologyEquiv,
+    PeriodTorusHigherHomology.homotopyEquivHomologyEquiv_apply] using LinearMap.congr_fun hm z
+
+private theorem
+    CuspCentralHomology.BaseCover.phaseOverlapIntoOuter_homology_eq_zero_of_projection (a : ℝ)
+    (ha : 0 ≤ a) (ha1 : a < 1) (n : ℕ)
+    (z : SingularMayerVietoris.SingularHomology (phaseOverlapRegion a) (n + 1))
+    (hz :
+      SingularMayerVietoris.singularHomologyMap
+          (ContinuousMap.fst :
+            C(ToricSpace.CompactFibreTorus × Circle, ToricSpace.CompactFibreTorus))
+          (n + 1) (phaseOverlapHomologyEquiv a ha ha1 (n + 1) z) =
+        0) :
+    SingularMayerVietoris.singularHomologyMap (phaseOverlapIntoOuter a) (n + 1) z = 0 := by
+  apply (phaseOuterHomologyEquiv a ha ha1 (n + 1)).injective
+  rw [map_zero, phaseOuterParameter_natural]
+  exact
+    CuspCentralHomology.productParameter_homology_eq_zero_of_projection circleThetaMap
+      circleThetaMap_homology_one_eq_zero n _ hz
+
+private theorem CuspCentralHomology.BaseCover.phaseLeftHomologyMap_eq_zero_iff_projection (a : ℝ)
+    (ha : 0 ≤ a) (ha1 : a < 1) (n : ℕ)
+    (z : SingularMayerVietoris.SingularHomology (phaseOverlapRegion a) (n + 1)) :
+    SingularMayerVietoris.leftHomologyMap (phaseOuterRegion a)
+          (CuspCentralHomology.BaseCover.phaseInnerRegion) (n + 1) z =
+        0 ↔
+      SingularMayerVietoris.singularHomologyMap
+          (ContinuousMap.fst :
+            C(ToricSpace.CompactFibreTorus × Circle, ToricSpace.CompactFibreTorus))
+          (n + 1) (phaseOverlapHomologyEquiv a ha ha1 (n + 1) z) =
+        0 := by
+  have hleft :
+    SingularMayerVietoris.leftHomologyMap (phaseOuterRegion a)
+        (CuspCentralHomology.BaseCover.phaseInnerRegion) (n + 1) z =
+      (SingularMayerVietoris.singularHomologyMap (phaseOverlapIntoOuter a) (n + 1) z,
+        -SingularMayerVietoris.singularHomologyMap (phaseOverlapIntoInner a) (n + 1) z) :=
+    SingularMayerVietoris.leftHomologyMap_apply (phaseOuterRegion a)
+      (CuspCentralHomology.BaseCover.phaseInnerRegion) (n + 1) z
+  constructor
+  · intro hz
+    have hi : SingularMayerVietoris.singularHomologyMap (phaseOverlapIntoInner a) (n + 1) z = 0 :=
+      by
+      apply neg_eq_zero.mp
+      exact congrArg Prod.snd (hleft.symm.trans hz)
+    rw [← phaseInnerProjection_natural a ha ha1 (n + 1) z, hi, map_zero]
+  · intro hz
+    have hi : SingularMayerVietoris.singularHomologyMap (phaseOverlapIntoInner a) (n + 1) z = 0 :=
+      by
+      apply (phaseInnerHomologyEquiv (n + 1)).injective
+      rw [map_zero, phaseInnerProjection_natural a ha ha1 (n + 1) z]
+      exact hz
+    have ho := phaseOverlapIntoOuter_homology_eq_zero_of_projection a ha ha1 n z hz
+    exact hleft.trans (by rw [ho, hi, neg_zero]; rfl)
+
+private theorem
+    CuspCentralHomology.BaseCover.phaseConnecting_lift (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1)
+    (n : ℕ)
+    (x : SingularMayerVietoris.SingularHomology (ToricSpace.CompactFibreTorus × Circle) (n + 1))
+    (hx :
+      SingularMayerVietoris.singularHomologyMap
+          (ContinuousMap.fst :
+            C(ToricSpace.CompactFibreTorus × Circle, ToricSpace.CompactFibreTorus))
+          (n + 1) x =
+        0) :
+    ∃ y : SingularMayerVietoris.SingularHomology PhaseBase (n + 2),
+      phaseOverlapHomologyEquiv a ha ha1 (n + 1)
+          (SingularMayerVietoris.connectingHomomorphism (phaseOuterRegion a)
+            (CuspCentralHomology.BaseCover.phaseInnerRegion) (phaseOuterRegion_isOpen a)
+            phaseInnerRegion_isOpen (phaseOuterRegion_union_phaseInnerRegion a ha1) (n + 1) y) =
+        x := by
+  let e := phaseOverlapHomologyEquiv a ha ha1 (n + 1)
+  have hz :
+    e.symm x ∈
+      LinearMap.ker
+        (SingularMayerVietoris.leftHomologyMap (phaseOuterRegion a)
+          (CuspCentralHomology.BaseCover.phaseInnerRegion) (n + 1)) := by
+    apply (phaseLeftHomologyMap_eq_zero_iff_projection a ha ha1 n (e.symm x)).mpr
+    change
+      SingularMayerVietoris.singularHomologyMap
+          (ContinuousMap.fst :
+            C(ToricSpace.CompactFibreTorus × Circle, ToricSpace.CompactFibreTorus))
+          (n + 1) (e (e.symm x)) =
+        0
+    rw [e.apply_symm_apply]
+    exact hx
+  have hmem :=
+    (SingularMayerVietoris.exact_at_intersection (phaseOuterRegion a)
+          (CuspCentralHomology.BaseCover.phaseInnerRegion) (phaseOuterRegion_isOpen a)
+          phaseInnerRegion_isOpen (phaseOuterRegion_union_phaseInnerRegion a ha1) (n + 1)).symm.le
+      hz
+  obtain ⟨y, hy⟩ := hmem
+  exact ⟨y, (congrArg e hy).trans (e.apply_symm_apply x)⟩
+
+private abbrev CuspCentralHomology.SpecializationCover.annulusSet (a : ℝ) :
+    Set (CuspHoneycombTiling.Plane) :=
+  {y | a < CuspCentralHomology.Radial.cellGauge y ∧ CuspCentralHomology.Radial.cellGauge y < 1}
+
+private def CuspCentralHomology.SpecializationCover.sourceOverlapPhaseHomeomorph (a : ℝ) :
+    CuspCentralHomology.BaseCover.phaseOverlapRegion a ≃ₜ
+      CuspCentralHomology.OverlapPhaseCell a :=
+  (CuspCentralHomology.BaseCover.phaseOverlapRegionHomeomorph a).trans
+    ((Homeomorph.refl ToricSpace.CompactFibreTorus).prodCongr
+      (CuspCentralHomology.BaseCover.annulusOverlapHomeomorph a).symm)
+
+@[simp]
+private theorem
+    CuspCentralHomology.SpecializationCover.sourceOverlapPhaseHomeomorph_symm_coe (a : ℝ)
+    (p : CuspCentralHomology.OverlapPhaseCell a) :
+    ((sourceOverlapPhaseHomeomorph a).symm p : CuspCentralHomology.BaseCover.PhaseBase) =
+      (p.1, CuspCentralHomology.BaseCover.basePoint (p.2 : (CuspHoneycombTiling.Plane))) :=
+  rfl
+
+private theorem
+    CuspCentralHomology.SpecializationCover.sourceOverlapCircle_factor (a : ℝ) (ha : 0 ≤ a)
+    (ha1 : a < 1) :
+    (CuspCentralHomology.BaseCover.phaseOverlapCircleHomotopyEquiv a ha ha1).toFun =
+      (CuspCentralHomology.Radial.phaseAnnulusHomotopyEquiv ToricSpace.CompactFibreTorus a ha
+            ha1).toFun.comp
+        (sourceOverlapPhaseHomeomorph a :
+          C(CuspCentralHomology.BaseCover.phaseOverlapRegion a,
+            CuspCentralHomology.OverlapPhaseCell a)) :=
+  rfl
+
+private theorem CuspCentralHomology.SpecializationCover.phaseCellShear_homologyMap
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (s : Set (CuspHoneycombTiling.Plane)) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap
+        (phaseCellShear C₀ s :
+          C(ToricSpace.CompactFibreTorus × s, ToricSpace.CompactFibreTorus × s))
+        n =
+      LinearMap.id := by
+  have h := PeriodTorusHigherHomology.homotopy_homologyMap (phaseCellShearHomotopy C₀ s) n
+  rw [PeriodTorusHigherHomology.singularHomologyMap_id] at h
+  exact h.symm
+
+private def CuspCentralHomology.SpecializationCover.collapseOverlapHomeomorph
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) :
+    CuspCentralHomology.BaseCover.phaseOverlapRegion a ≃ₜ
+      CuspCentralHomology.overlapRegion C ε hε a :=
+  (sourceOverlapPhaseHomeomorph a).trans
+    ((phaseCellShear (C 0) (annulusSet a)).trans
+      (CuspCentralHomology.overlapPhaseHomeomorph C ε hε hε1 hC hR a))
+
+private theorem CuspCentralHomology.SpecializationCover.collapseOverlapHomeomorph_apply
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ)
+    (q : CuspCentralHomology.BaseCover.phaseOverlapRegion a) :
+    collapseOverlapHomeomorph C ε hε hε1 hC hR a q = overlapMap C ε hε a q := by
+  obtain ⟨p, rfl⟩ := (sourceOverlapPhaseHomeomorph a).symm.surjective q
+  apply Subtype.ext
+  rw [overlapMap_coe, sourceOverlapPhaseHomeomorph_symm_coe, productCollapse_basePoint]
+  change
+    (CuspCentralHomology.overlapPhaseHomeomorph C ε hε hε1 hC hR a
+          (phaseCellShear (C 0) (annulusSet a)
+            (sourceOverlapPhaseHomeomorph a ((sourceOverlapPhaseHomeomorph a).symm p))) :
+        CuspRetraction.QuotientCentralFibre C ε) =
+      _
+  rw [Homeomorph.apply_symm_apply, CuspCentralHomology.overlapPhaseHomeomorph_coe]
+  rfl
+
+private theorem CuspCentralHomology.SpecializationCover.overlapMap_phase_coordinates
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ)
+    (q : CuspCentralHomology.BaseCover.phaseOverlapRegion a) :
+    (CuspCentralHomology.overlapPhaseHomeomorph C ε hε hε1 hC hR a).symm (overlapMap C ε hε a q) =
+      phaseCellShear (C 0) (annulusSet a) (sourceOverlapPhaseHomeomorph a q) := by
+  apply (CuspCentralHomology.overlapPhaseHomeomorph C ε hε hε1 hC hR a).injective
+  rw [Homeomorph.apply_symm_apply]
+  exact (collapseOverlapHomeomorph_apply C ε hε hε1 hC hR a q).symm
+
+private theorem CuspCentralHomology.SpecializationCover.targetOverlapCircle_factor
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) :
+    (CuspCentralHomology.overlapCircleHomotopyEquiv C ε hε hε1 hC hR a ha ha1).toFun.comp
+        (overlapMap C ε hε a) =
+      (CuspCentralHomology.Radial.phaseAnnulusHomotopyEquiv ToricSpace.CompactFibreTorus a ha
+            ha1).toFun.comp
+        ((phaseCellShear (C 0) (annulusSet a) :
+              C(ToricSpace.CompactFibreTorus × annulusSet a,
+                ToricSpace.CompactFibreTorus × annulusSet a)).comp
+          (sourceOverlapPhaseHomeomorph a :
+            C(CuspCentralHomology.BaseCover.phaseOverlapRegion a,
+              CuspCentralHomology.OverlapPhaseCell a))) := by
+  apply ContinuousMap.ext
+  intro q
+  change
+    CuspCentralHomology.Radial.phaseAnnulusHomotopyEquiv ToricSpace.CompactFibreTorus a ha ha1
+        ((CuspCentralHomology.overlapPhaseHomeomorph C ε hε hε1 hC hR a).symm
+          (overlapMap C ε hε a q)) =
+      _
+  rw [overlapMap_phase_coordinates]
+  rfl
+
+private theorem CuspCentralHomology.SpecializationCover.overlapMap_homology_intertwining
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (n : ℕ) :
+    (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+            (CuspCentralHomology.overlapCircleHomotopyEquiv C ε hε hε1 hC hR a ha ha1)
+            n).toLinearMap.comp
+        (SingularMayerVietoris.singularHomologyMap (overlapMap C ε hε a) n) =
+      (CuspCentralHomology.BaseCover.phaseOverlapHomologyEquiv a ha ha1 n).toLinearMap := by
+  change
+    (SingularMayerVietoris.singularHomologyMap
+            (CuspCentralHomology.overlapCircleHomotopyEquiv C ε hε hε1 hC hR a ha ha1).toFun
+            n).comp
+        (SingularMayerVietoris.singularHomologyMap (overlapMap C ε hε a) n) =
+      SingularMayerVietoris.singularHomologyMap
+        (CuspCentralHomology.BaseCover.phaseOverlapCircleHomotopyEquiv a ha ha1).toFun n
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp, targetOverlapCircle_factor,
+    PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodTorusHigherHomology.singularHomologyMap_comp, phaseCellShear_homologyMap,
+    LinearMap.id_comp, sourceOverlapCircle_factor,
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+
+private theorem CuspCentralHomology.SpecializationCover.overlapMap_homology_coordinates
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (a : ℝ) (ha : 0 ≤ a) (ha1 : a < 1) (n : ℕ)
+    (x :
+      SingularMayerVietoris.SingularHomology (CuspCentralHomology.BaseCover.phaseOverlapRegion a)
+        n) :
+    PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+        (CuspCentralHomology.overlapCircleHomotopyEquiv C ε hε hε1 hC hR a ha ha1) n
+        (SingularMayerVietoris.singularHomologyMap (overlapMap C ε hε a) n x) =
+      CuspCentralHomology.BaseCover.phaseOverlapHomologyEquiv a ha ha1 n x :=
+  LinearMap.congr_fun (overlapMap_homology_intertwining C ε hε hε1 hC hR a ha ha1 n) x
+
+private theorem CuspCentralHomology.productCollapse_homology_three_add_surjective
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (n : ℕ) :
+    Function.Surjective
+      (SingularMayerVietoris.singularHomologyMap (CuspSpecialization.productCollapse C ε hε)
+        (n + 3)) := by
+  let a : ℝ := 1 / 2
+  have ha : 0 ≤ a := by norm_num [a]
+  have ha1 : a < 1 := by norm_num [a]
+  let U := outerRegion C ε hε a
+  let V := innerRegion C ε hε
+  let hU := outerRegion_isOpen C ε hε hε1 hC hR a
+  let hV := innerRegion_isOpen C ε hε hε1 hC hR
+  let hc := outerRegion_union_innerRegion C ε hε a ha1
+  let δT := SingularMayerVietoris.connectingHomomorphism U V hU hV hc (n + 2)
+  let δS :=
+    SingularMayerVietoris.connectingHomomorphism (BaseCover.phaseOuterRegion a)
+      BaseCover.phaseInnerRegion (BaseCover.phaseOuterRegion_isOpen a)
+      BaseCover.phaseInnerRegion_isOpen (BaseCover.phaseOuterRegion_union_phaseInnerRegion a ha1)
+      (n + 2)
+  let eT := middleOverlapHomologyEquiv C ε hε hε1 hC hR a ha ha1 (n + 2)
+  let : Subsingleton (SingularMayerVietoris.SingularHomology U (n + 3)) :=
+    outerRegion_homology_subsingleton C ε hε hε1 hC hR a ha ha1 n
+  let : Subsingleton (SingularMayerVietoris.SingularHomology V (n + 3)) :=
+    innerRegion_homology_subsingleton C ε hε hε1 hC hR n
+  have hδT : Function.Injective δT := coverConnecting_injective_of_vanishing U V hU hV hc (n + 2)
+  intro b
+  have hk : δT b ∈ LinearMap.ker (SingularMayerVietoris.leftHomologyMap U V (n + 2)) := by
+    change SingularMayerVietoris.leftHomologyMap U V (n + 2) (δT b) = 0
+    have h :=
+      LinearMap.congr_fun
+        (SingularMayerVietoris.connectingHomomorphism_comp_left U V hU hV hc (n + 2)) b
+    simpa only [LinearMap.comp_apply, LinearMap.zero_apply] using h
+  have hx :
+    SingularMayerVietoris.singularHomologyMap
+        (ContinuousMap.fst :
+          C(ToricSpace.CompactFibreTorus × Circle, ToricSpace.CompactFibreTorus))
+        (n + 2) (eT (δT b)) =
+      0 :=
+    (middleLeftHomology_mem_ker_iff C ε hε hε1 hC hR a ha ha1 (n + 1) (δT b)).mp hk
+  obtain ⟨s, hs⟩ := BaseCover.phaseConnecting_lift a ha ha1 (n + 1) (eT (δT b)) hx
+  refine ⟨s, hδT (eT.injective ?_)⟩
+  have hnat :
+    SingularMayerVietoris.singularHomologyMap (SpecializationCover.overlapMap C ε hε a) (n + 2)
+        (δS s) =
+      δT
+        (SingularMayerVietoris.singularHomologyMap (CuspSpecialization.productCollapse C ε hε)
+          (n + 3) s) :=
+    productCollapse_connecting_naturality C ε hε hε1 hC hR a ha1 (n + 2) s
+  calc
+    eT
+          (δT
+            (SingularMayerVietoris.singularHomologyMap (CuspSpecialization.productCollapse C ε hε)
+              (n + 3) s)) =
+        eT
+          (SingularMayerVietoris.singularHomologyMap (SpecializationCover.overlapMap C ε hε a)
+            (n + 2) (δS s)) :=
+      congrArg eT hnat.symm
+    _ = BaseCover.phaseOverlapHomologyEquiv a ha ha1 (n + 2) (δS s) :=
+      (SpecializationCover.overlapMap_homology_coordinates C ε hε hε1 hC hR a ha ha1 (n + 2)
+        (δS s))
+    _ = eT (δT b) := hs
+
+private theorem CuspCentralHomology.productCollapse_homology_three_add_surjective_of_holomorphic
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (n : ℕ) :
+    Function.Surjective
+      (SingularMayerVietoris.singularHomologyMap (CuspSpecialization.productCollapse C r hr)
+        (n + 3)) := by
+  obtain ⟨δ, hδ, hδr, hδ1, hRCδ, _hRDδ⟩ :=
+    CuspRetraction.exists_common_frozen_radius C hr (fun i j => (hC i j).continuousOn)
+  have hCδ (i j) : ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 δ) :=
+    (hC i j).mono (Metric.ball_subset_ball hδr.le)
+  have he :=
+    congrArg (fun f => SingularMayerVietoris.singularHomologyMap f (n + 3))
+      (centralRadiusHomeomorph_comp_productCollapse C r δ hδr.le hC hδ)
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp] at he
+  rw [← he]
+  exact
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+          (centralRadiusHomeomorph C r δ hδr.le hC hδ) (n + 3)).surjective.comp
+      (productCollapse_homology_three_add_surjective C δ hδ hδ1 hCδ hRCδ n)
+
+private theorem CuspCentralHomology.productCollapse_homologyThree_surjective_of_holomorphic
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Function.Surjective
+      (SingularMayerVietoris.singularHomologyMap (CuspSpecialization.productCollapse C r hr) 3) :=
+  productCollapse_homology_three_add_surjective_of_holomorphic C r hr hC 0
+
+private theorem CuspCentralHomology.productCollapse_homologyFour_surjective_of_holomorphic
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Function.Surjective
+      (SingularMayerVietoris.singularHomologyMap (CuspSpecialization.productCollapse C r hr) 4) :=
+  productCollapse_homology_three_add_surjective_of_holomorphic C r hr hC 1
+
+private theorem CuspSpecialization.torusDifference_three_exterior
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 3) :
+    PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv
+        (CuspCoinvariants.torusDifference 3 a) =
+      CuspCoinvariants.exteriorCubeDifference
+        (PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv a) := by
+  change
+    PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀) 3
+            a -
+          a) =
+      exteriorPower.map 3 M₀.mulVecLin
+          (PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv a) -
+        PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv a
+  rw [map_sub, PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv_matrix]
+
+private theorem CuspSpecialization.markedCollapse_homologyThree_surjective
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε)) :
+    Function.Surjective (SingularMayerVietoris.singularHomologyMap (markedCollapse C ε hε) 3) :=
+  markedCollapse_homology_surjective_of_product C ε hε 3
+    (CuspCentralHomology.productCollapse_homologyThree_surjective_of_holomorphic C ε hε hC)
+
+private theorem
+    CuspSpecialization.markedCollapse_homologyThree_kernel (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε)) :
+    LinearMap.ker (SingularMayerVietoris.singularHomologyMap (markedCollapse C ε hε) 3) =
+      LinearMap.range (CuspCoinvariants.torusDifference 3) := by
+  let := CuspCentralHomology.centralSingularH3_free C ε hε hC
+  let := CuspCentralHomology.centralSingularH3_finite C ε hε hC
+  exact
+    CuspCoinvariants.torusThree_kernel_eq_of_invariant _
+      (markedCollapse_homologyThree_surjective C ε hε hC)
+      (markedCollapse_homology_invariant C ε hε 3)
+      (CuspCentralHomology.centralSingularH3_finrank C ε hε hC)
+
+private theorem CuspSpecialization.markedCollapse_homologyThree_eq_zero_iff
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 3) :
+    SingularMayerVietoris.singularHomologyMap (markedCollapse C ε hε) 3 a = 0 ↔
+      ∃ v : PeriodTorusHigherHomologyExterior.latticeExterior 3,
+        exteriorPower.map 3 M₀.mulVecLin v - v =
+          PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv a := by
+  change
+    a ∈ LinearMap.ker (SingularMayerVietoris.singularHomologyMap (markedCollapse C ε hε) 3) ↔
+      PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv a ∈
+        LinearMap.range CuspCoinvariants.exteriorCubeDifference
+  rw [markedCollapse_homologyThree_kernel C ε hε hC]
+  exact
+    CuspCoinvariants.mem_range_iff_of_intertwines
+      PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv
+      (CuspCoinvariants.torusDifference 3) CuspCoinvariants.exteriorCubeDifference
+      torusDifference_three_exterior a
+
+private theorem CuspSpecialization.markedCollapse_homologyZero_augmentation
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 0) :
+    CuspCentralHomology.centralSingularH0Equiv C r hr
+        (SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) 0 a) =
+      PeriodTorusHigherHomology.connectedHomologyZeroEquiv
+        (PeriodTorusHigherHomology.ProductTorus 4) a :=
+  CuspCentralHomology.centralSingularH0Equiv_natural C r hr (markedCollapse C r hr) a
+
+private theorem CuspSpecialization.markedCollapse_homologyZero_bijective
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) :
+    Function.Bijective (SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) 0) := by
+  constructor
+  · intro a b hab
+    apply
+      (PeriodTorusHigherHomology.connectedHomologyZeroEquiv
+          (PeriodTorusHigherHomology.ProductTorus 4)).injective
+    rw [← markedCollapse_homologyZero_augmentation C r hr a, ←
+      markedCollapse_homologyZero_augmentation C r hr b, hab]
+  · intro b
+    obtain ⟨a, ha⟩ :=
+      (PeriodTorusHigherHomology.connectedHomologyZeroEquiv
+            (PeriodTorusHigherHomology.ProductTorus 4)).surjective
+        (CuspCentralHomology.centralSingularH0Equiv C r hr b)
+    refine ⟨a, ?_⟩
+    apply (CuspCentralHomology.centralSingularH0Equiv C r hr).injective
+    rw [markedCollapse_homologyZero_augmentation]
+    exact ha
+
+private theorem
+    CuspSpecialization.markedCollapse_homologyZero_kernel (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) :
+    LinearMap.ker (SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) 0) = ⊥ :=
+  LinearMap.ker_eq_bot.mpr (markedCollapse_homologyZero_bijective C r hr).injective
+
+private theorem
+    CuspSpecialization.markedMonodromy_homologyZero (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) :
+    SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀) 0 =
+      LinearMap.id := by
+  apply LinearMap.ext
+  intro a
+  apply (markedCollapse_homologyZero_bijective C r hr).injective
+  exact markedCollapse_homology_invariant C r hr 0 a
+
+private theorem CuspSpecialization.markedMonodromy_homologyZero_variation_zero
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) :
+    SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀) 0 -
+        LinearMap.id =
+      0 := by rw [markedMonodromy_homologyZero C r hr, sub_self]
+
+private theorem CuspSpecialization.markedMonodromy_homologyZero_variation_range
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) :
+    LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀)
+            0 -
+          LinearMap.id) =
+      ⊥ := by rw [markedMonodromy_homologyZero_variation_zero C r hr, LinearMap.range_zero]
+
+private theorem CuspSpecialization.markedCollapse_homologyZero_kernel_eq_variation
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) :
+    LinearMap.ker (SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) 0) =
+      LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀)
+            0 -
+          LinearMap.id) := by
+  rw [markedCollapse_homologyZero_kernel, markedMonodromy_homologyZero_variation_range C r hr]
+
+private theorem CuspSpecialization.markedCollapse_homologyFour_surjective
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Function.Surjective (SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) 4) :=
+  markedCollapse_homology_surjective_of_product C r hr 4
+    (CuspCentralHomology.productCollapse_homologyFour_surjective_of_holomorphic C r hr hC)
+
+private theorem CuspSpecialization.markedCollapse_homologyFour_bijective
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Function.Bijective (SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) 4) := by
+  let := PeriodTorusHigherHomology.productTorus_homology_free 4 4
+  let := PeriodTorusHigherHomology.productTorus_homology_finite 4 4
+  let := CuspCentralHomology.centralSingularH4_free C r hr hC
+  let := CuspCentralHomology.centralSingularH4_finite C r hr hC
+  apply
+    OrzechProperty.bijective_of_surjective_of_finrank_le
+      (SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) 4)
+      (markedCollapse_homologyFour_surjective C r hr hC)
+  rw [PeriodTorusHigherHomology.productTorus_homology_finrank,
+    CuspCentralHomology.centralSingularH4_finrank C r hr hC]
+  simp
+
+private theorem
+    CuspSpecialization.markedCollapse_homologyFour_kernel (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    LinearMap.ker (SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) 4) = ⊥ :=
+  LinearMap.ker_eq_bot.mpr (markedCollapse_homologyFour_bijective C r hr hC).injective
+
+private theorem
+    CuspSpecialization.markedMonodromy_homologyFour (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀) 4 =
+      LinearMap.id := by
+  apply LinearMap.ext
+  intro a
+  apply (markedCollapse_homologyFour_bijective C r hr hC).injective
+  exact markedCollapse_homology_invariant C r hr 4 a
+
+private theorem CuspSpecialization.markedMonodromy_homologyFour_variation_zero
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀) 4 -
+        LinearMap.id =
+      0 := by rw [markedMonodromy_homologyFour C r hr hC, sub_self]
+
+private theorem CuspSpecialization.markedMonodromy_homologyFour_variation_range
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀)
+            4 -
+          LinearMap.id) =
+      ⊥ := by rw [markedMonodromy_homologyFour_variation_zero C r hr hC, LinearMap.range_zero]
+
+private theorem CuspSpecialization.markedCollapse_homologyFour_kernel_eq_variation
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    LinearMap.ker (SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) 4) =
+      LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀)
+            4 -
+          LinearMap.id) := by
+  rw [markedCollapse_homologyFour_kernel C r hr hC,
+    markedMonodromy_homologyFour_variation_range C r hr hC]
+
+private theorem CuspSpecialization.markedCollapse_homologyHigher_bijective
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (n : ℕ) (hn : 4 < n) :
+    Function.Bijective (SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) n) := by
+  let := PeriodTorusHigherHomology.productTorus_homology_subsingleton_of_lt hn
+  let := CuspCentralHomology.centralSingularHomology_subsingleton_of_four_lt C r hr hC hn
+  exact ⟨fun _ _ _ => Subsingleton.elim _ _, fun b => ⟨0, Subsingleton.elim _ b⟩⟩
+
+private theorem
+    CuspSpecialization.markedCollapse_homologyHigher_kernel (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (n : ℕ)
+    (hn : 4 < n) :
+    LinearMap.ker (SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) n) = ⊥ :=
+  LinearMap.ker_eq_bot.mpr (markedCollapse_homologyHigher_bijective C r hr hC n hn).injective
+
+private theorem CuspSpecialization.markedCollapse_homologyHigher_kernel_eq_variation
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (n : ℕ) (hn : 4 < n) :
+    LinearMap.ker (SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) n) =
+      LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀)
+            n -
+          LinearMap.id) := by
+  let := PeriodTorusHigherHomology.productTorus_homology_subsingleton_of_lt hn
+  have hvariation :
+    SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀) n -
+        LinearMap.id =
+      0 := by
+    apply LinearMap.ext
+    intro a
+    exact Subsingleton.elim _ _
+  rw [markedCollapse_homologyHigher_kernel C r hr hC n hn, hvariation, LinearMap.range_zero]
+
+private theorem
+    CuspSpecialization.markedCollapse_homology_surjective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r))
+    (n : ℕ) :
+    Function.Surjective (SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) n) := by
+  rcases n with _ | (_ | (_ | n))
+  · exact (markedCollapse_homologyZero_bijective C r hr).surjective
+  · exact markedCollapse_homologyOne_surjective C r hr hC
+  · exact markedCollapse_homologyTwo_surjective C r hr hC
+  · exact
+      markedCollapse_homology_surjective_of_product C r hr (n + 3)
+        (CuspCentralHomology.productCollapse_homology_three_add_surjective_of_holomorphic C r hr
+          hC n)
+
+private theorem CuspSpecialization.markedCollapse_homology_kernel (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r))
+    (n : ℕ) :
+    LinearMap.ker (SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) n) =
+      LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀)
+            n -
+          LinearMap.id) := by
+  rcases n with _ | (_ | (_ | (_ | (_ | n))))
+  · exact markedCollapse_homologyZero_kernel_eq_variation C r hr
+  · simpa only [CuspCoinvariants.torusDifference] using
+      markedCollapse_homologyOne_kernel C r hr hC
+  · simpa only [CuspCoinvariants.torusDifference] using
+      markedCollapse_homologyTwo_kernel C r hr hC
+  · simpa only [CuspCoinvariants.torusDifference] using
+      markedCollapse_homologyThree_kernel C r hr hC
+  · exact markedCollapse_homologyFour_kernel_eq_variation C r hr hC
+  · exact markedCollapse_homologyHigher_kernel_eq_variation C r hr hC (n + 5) (by omega)
+
+private theorem
+    CuspSpecialization.markedCollapse_homology_eq_zero_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) n) :
+    SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) n a = 0 ↔
+      ∃ b : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) n,
+        SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀) n
+              b -
+            b =
+          a := by
+  change
+    a ∈ LinearMap.ker (SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) n) ↔ _
+  rw [markedCollapse_homology_kernel C r hr hC n]
+  rfl
+
+private theorem
+    CuspSpecialization.markedSpecialization_homology_map (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) {X : Type} [TopologicalSpace X]
+    (E : PeriodTorusHigherHomology.ProductTorus 4 ≃ₜ X)
+    (f : C(X, CuspRetraction.QuotientCentralFibre C r))
+    (h :
+      (markedCollapse C r hr).Homotopic
+        (f.comp (E : C(PeriodTorusHigherHomology.ProductTorus 4, X))))
+    (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    SingularMayerVietoris.singularHomologyMap f n a =
+      SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) n
+        ((PeriodTorusHigherHomology.homeomorphHomologyEquiv E n).symm a) := by
+  have heq := PeriodTorusHigherHomology.homotopic_homologyMap h n
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp] at heq
+  have ha :=
+    LinearMap.congr_fun heq ((PeriodTorusHigherHomology.homeomorphHomologyEquiv E n).symm a)
+  change
+    SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) n
+        ((PeriodTorusHigherHomology.homeomorphHomologyEquiv E n).symm a) =
+      SingularMayerVietoris.singularHomologyMap f n
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv E n
+          ((PeriodTorusHigherHomology.homeomorphHomologyEquiv E n).symm a)) at ha
+  rw [LinearEquiv.apply_symm_apply] at ha
+  exact ha.symm
+
+private theorem CuspSpecialization.markedSpecialization_homology_surjective
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) {X : Type}
+    [TopologicalSpace X] (E : PeriodTorusHigherHomology.ProductTorus 4 ≃ₜ X)
+    (f : C(X, CuspRetraction.QuotientCentralFibre C r))
+    (h :
+      (markedCollapse C r hr).Homotopic
+        (f.comp (E : C(PeriodTorusHigherHomology.ProductTorus 4, X))))
+    (n : ℕ) : Function.Surjective (SingularMayerVietoris.singularHomologyMap f n) := by
+  intro b
+  obtain ⟨a, ha⟩ := markedCollapse_homology_surjective C r hr hC n b
+  refine ⟨PeriodTorusHigherHomology.homeomorphHomologyEquiv E n a, ?_⟩
+  rw [markedSpecialization_homology_map C r hr E f h n, LinearEquiv.symm_apply_apply]
+  exact ha
+
+private theorem CuspSpecialization.markedSpecialization_homology_eq_zero_iff
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) {X : Type}
+    [TopologicalSpace X] (E : PeriodTorusHigherHomology.ProductTorus 4 ≃ₜ X)
+    (f : C(X, CuspRetraction.QuotientCentralFibre C r))
+    (h :
+      (markedCollapse C r hr).Homotopic
+        (f.comp (E : C(PeriodTorusHigherHomology.ProductTorus 4, X))))
+    (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    SingularMayerVietoris.singularHomologyMap f n a = 0 ↔
+      ∃ b : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) n,
+        SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀) n
+              b -
+            b =
+          (PeriodTorusHigherHomology.homeomorphHomologyEquiv E n).symm a := by
+  rw [markedSpecialization_homology_map C r hr E f h n,
+    markedCollapse_homology_eq_zero_iff C r hr hC n]
+
+private theorem CuspSpecialization.markedSpecialization_homologyTwo_eq_zero_iff
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) {X : Type}
+    [TopologicalSpace X] (E : PeriodTorusHigherHomology.ProductTorus 4 ≃ₜ X)
+    (f : C(X, CuspRetraction.QuotientCentralFibre C r))
+    (h :
+      (markedCollapse C r hr).Homotopic
+        (f.comp (E : C(PeriodTorusHigherHomology.ProductTorus 4, X))))
+    (a : SingularMayerVietoris.SingularHomology X 2) :
+    SingularMayerVietoris.singularHomologyMap f 2 a = 0 ↔
+      ∃ v : PeriodTorusHigherHomologyExterior.latticeExterior 2,
+        exteriorPower.map 2 M₀.mulVecLin v - v =
+          PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv
+            ((PeriodTorusHigherHomology.homeomorphHomologyEquiv E 2).symm a) := by
+  rw [markedSpecialization_homology_map C r hr E f h 2,
+    markedCollapse_homologyTwo_eq_zero_iff C r hr hC]
+
+private theorem CuspSpecialization.markedSpecialization_homologyThree_eq_zero_iff
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) {X : Type}
+    [TopologicalSpace X] (E : PeriodTorusHigherHomology.ProductTorus 4 ≃ₜ X)
+    (f : C(X, CuspRetraction.QuotientCentralFibre C r))
+    (h :
+      (markedCollapse C r hr).Homotopic
+        (f.comp (E : C(PeriodTorusHigherHomology.ProductTorus 4, X))))
+    (a : SingularMayerVietoris.SingularHomology X 3) :
+    SingularMayerVietoris.singularHomologyMap f 3 a = 0 ↔
+      ∃ v : PeriodTorusHigherHomologyExterior.latticeExterior 3,
+        exteriorPower.map 3 M₀.mulVecLin v - v =
+          PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv
+            ((PeriodTorusHigherHomology.homeomorphHomologyEquiv E 3).symm a) := by
+  rw [markedSpecialization_homology_map C r hr E f h 3,
+    markedCollapse_homologyThree_eq_zero_iff C r hr hC]
+
+private theorem CuspCentralHomology.exists_actual_specialization_homology
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    ∃ (η₀ : ℝ) (_hη₀ : 0 < η₀),
+      η₀ < r ∧
+        η₀ < 1 ∧
+          ∀ (t : ℂ) (ht : t ≠ 0),
+            ‖t‖ ≤ η₀ →
+              ∃ E :
+                PeriodTorusHigherHomology.ProductTorus 4 ≃ₜ
+                  CuspControlledRetraction.ActualQuotientFibre C r t,
+                ∀ (η : ℝ) (_hη : η ≤ η₀) (htη : ‖t‖ ≤ η) (hηr : η < r),
+                  ∃ hc :
+                    Continuous
+                      (CuspControlledRetraction.prescribedActualFibreCollapse C r hr hηr t ht
+                        htη),
+                    let f :
+                      C(CuspControlledRetraction.ActualQuotientFibre C r t,
+                        CuspRetraction.QuotientCentralFibre C r) :=
+                      ⟨CuspControlledRetraction.prescribedActualFibreCollapse C r hr hηr t ht htη,
+                        hc⟩
+                    (CuspSpecialization.markedCollapse C r hr).Homotopic
+                        (f.comp
+                          (E :
+                            C(PeriodTorusHigherHomology.ProductTorus 4,
+                              CuspControlledRetraction.ActualQuotientFibre C r t))) ∧
+                      (∀ n : ℕ,
+                          Function.Surjective (SingularMayerVietoris.singularHomologyMap f n) ∧
+                            ∀ a :
+                              SingularMayerVietoris.SingularHomology
+                                (CuspControlledRetraction.ActualQuotientFibre C r t) n,
+                              SingularMayerVietoris.singularHomologyMap f n a = 0 ↔
+                                ∃ b :
+                                  SingularMayerVietoris.SingularHomology
+                                    (PeriodTorusHigherHomology.ProductTorus 4) n,
+                                  SingularMayerVietoris.singularHomologyMap
+                                        (PeriodTorusHigherHomology.torusMatrixMap M₀) n b -
+                                      b =
+                                    (PeriodTorusHigherHomology.homeomorphHomologyEquiv E n).symm
+                                      a) ∧
+                        (∀ a :
+                            SingularMayerVietoris.SingularHomology
+                              (CuspControlledRetraction.ActualQuotientFibre C r t) 2,
+                            SingularMayerVietoris.singularHomologyMap f 2 a = 0 ↔
+                              ∃ v : PeriodTorusHigherHomologyExterior.latticeExterior 2,
+                                exteriorPower.map 2 M₀.mulVecLin v - v =
+                                  PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv
+                                    ((PeriodTorusHigherHomology.homeomorphHomologyEquiv E 2).symm
+                                      a)) ∧
+                          (∀ a :
+                            SingularMayerVietoris.SingularHomology
+                              (CuspControlledRetraction.ActualQuotientFibre C r t) 3,
+                            SingularMayerVietoris.singularHomologyMap f 3 a = 0 ↔
+                              ∃ v : PeriodTorusHigherHomologyExterior.latticeExterior 3,
+                                exteriorPower.map 3 M₀.mulVecLin v - v =
+                                  PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv
+                                    ((PeriodTorusHigherHomology.homeomorphHomologyEquiv E 3).symm
+                                      a)) := by
+  obtain ⟨η₀, hη₀, hη₀r, hη₀1, hmodels⟩ :=
+    CuspSpecialization.exists_original_marked_specialization_models C r hr hC
+  refine ⟨η₀, hη₀, hη₀r, hη₀1, ?_⟩
+  intro t ht ht₀
+  obtain ⟨E, hE⟩ := hmodels t ht ht₀
+  refine ⟨E, ?_⟩
+  intro η hη htη hηr
+  obtain ⟨hc, hh, _⟩ := hE η hη htη hηr
+  let f :
+    C(CuspControlledRetraction.ActualQuotientFibre C r t,
+      CuspRetraction.QuotientCentralFibre C r) :=
+    ⟨CuspControlledRetraction.prescribedActualFibreCollapse C r hr hηr t ht htη, hc⟩
+  refine ⟨hc, hh, ?_, ?_, ?_⟩
+  · intro n
+    exact
+      ⟨CuspSpecialization.markedSpecialization_homology_surjective C r hr hC E f hh n,
+        CuspSpecialization.markedSpecialization_homology_eq_zero_iff C r hr hC E f hh n⟩
+  · exact CuspSpecialization.markedSpecialization_homologyTwo_eq_zero_iff C r hr hC E f hh
+  · exact CuspSpecialization.markedSpecialization_homologyThree_eq_zero_iff C r hr hC E f hh
+
+private def CuspCentralHomology.retractionEndpointHomotopy {X A : Type} [TopologicalSpace X]
+    [TopologicalSpace A] (i : C(A, X)) (R S : C(X, A)) (hR : R.comp i = ContinuousMap.id A)
+    (H : (ContinuousMap.id X).Homotopy (i.comp S)) : R.Homotopy S
+    where
+  toFun p := R (H p)
+  continuous_toFun := R.continuous.comp H.continuous
+  map_zero_left x := congrArg R (H.map_zero_left x)
+  map_one_left x := (congrArg R (H.map_one_left x)).trans (ContinuousMap.congr_fun hR (S x))
+
+private def
+    CuspCentralHomology.actualFibreIntoClosed (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r η : ℝ) (t : ℂ)
+    (htη : ‖t‖ ≤ η) :
+    C(CuspControlledRetraction.ActualQuotientFibre C r t, CuspRetraction.ClosedQuotient C r η)
+    where
+  toFun q := ⟨q.1, by rw [q.2]; exact htη⟩
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    exact continuous_subtype_val
+
+private theorem CuspCentralHomology.exists_controlled_retraction_all_levels
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {r : ℝ} (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    ∃ η₀ : ℝ,
+      0 < η₀ ∧
+        η₀ < r ∧
+          η₀ < 1 ∧
+            ∀ (η : ℝ) (hη : 0 < η),
+              η ≤ η₀ →
+                ∀ (hηr : η < r) (t₀ : ℂ) (ht₀ : t₀ ≠ 0) (ht₀η : ‖t₀‖ ≤ η),
+                  ∃ R :
+                    C(CuspRetraction.ClosedQuotient C r η,
+                      CuspRetraction.QuotientCentralFibre C r),
+                    R.comp (CuspRetraction.quotientCentralIntoClosed C r η hη.le) =
+                        ContinuousMap.id (CuspRetraction.QuotientCentralFibre C r) ∧
+                      ∃ H :
+                        (ContinuousMap.id (CuspRetraction.ClosedQuotient C r η)).HomotopyRel
+                          ((CuspRetraction.quotientCentralIntoClosed C r η hη.le).comp R)
+                          {q : CuspRetraction.ClosedQuotient C r η |
+                            CuspQuotient.projection C r q = 0},
+                        (∀ s q,
+                            ‖CuspQuotient.projection C r (H (s, q))‖ ≤
+                              ‖CuspQuotient.projection C r q‖) ∧
+                          ∃ hc₀ :
+                            Continuous
+                              (CuspControlledRetraction.prescribedActualFibreCollapse C r hr hηr
+                                t₀ ht₀ ht₀η),
+                            R.comp (actualFibreIntoClosed C r η t₀ ht₀η) =
+                                ⟨CuspControlledRetraction.prescribedActualFibreCollapse C r hr hηr
+                                    t₀ ht₀ ht₀η,
+                                  hc₀⟩ ∧
+                              ∀ (t : ℂ) (ht : t ≠ 0) (htη : ‖t‖ ≤ η),
+                                ∃ hc :
+                                  Continuous
+                                    (CuspControlledRetraction.prescribedActualFibreCollapse C r hr
+                                      hηr t ht htη),
+                                  (R.comp (actualFibreIntoClosed C r η t htη)).Homotopic
+                                      ⟨CuspControlledRetraction.prescribedActualFibreCollapse C r
+                                          hr hηr t ht htη,
+                                        hc⟩ ∧
+                                    ∀ n,
+                                      SingularMayerVietoris.singularHomologyMap
+                                          (R.comp (actualFibreIntoClosed C r η t htη)) n =
+                                        SingularMayerVietoris.singularHomologyMap
+                                          ⟨CuspControlledRetraction.prescribedActualFibreCollapse
+                                              C r hr hηr t ht htη,
+                                            hc⟩
+                                          n := by
+  obtain ⟨η₀, hη₀, hη₀r, hη₀1, hret⟩ :=
+    CuspControlledRetraction.exists_controlled_actual_fibre_retraction C hr hC
+  refine ⟨η₀, hη₀, hη₀r, hη₀1, ?_⟩
+  intro η hη hηη₀ hηr t₀ ht₀ ht₀η
+  obtain ⟨R, hR, H, hmono, hendpoint⟩ := hret η hη hηη₀ t₀ ht₀ ht₀η
+  obtain ⟨hc₀, he₀, _hrep₀⟩ := hendpoint hηr
+  refine ⟨R, hR, H, hmono, hc₀, ?_, ?_⟩
+  · apply ContinuousMap.ext
+    intro q
+    exact he₀ q
+  · intro t ht htη
+    obtain ⟨S, _hS, HS, _hmonoS, hendpointS⟩ := hret η hη hηη₀ t ht htη
+    obtain ⟨hc, he, _hrep⟩ := hendpointS hηr
+    have hemap :
+      S.comp (actualFibreIntoClosed C r η t htη) =
+        (⟨CuspControlledRetraction.prescribedActualFibreCollapse C r hr hηr t ht htη, hc⟩ :
+          C(CuspControlledRetraction.ActualQuotientFibre C r t,
+            CuspRetraction.QuotientCentralFibre C r)) := by
+      apply ContinuousMap.ext
+      intro q
+      exact he q
+    let K :=
+      retractionEndpointHomotopy (CuspRetraction.quotientCentralIntoClosed C r η hη.le) R S hR
+        HS.toHomotopy
+    have hk :
+      (R.comp (actualFibreIntoClosed C r η t htη)).Homotopic
+        ⟨CuspControlledRetraction.prescribedActualFibreCollapse C r hr hηr t ht htη, hc⟩ :=
+      ⟨(K.comp (ContinuousMap.Homotopy.refl (actualFibreIntoClosed C r η t htη))).cast rfl hemap⟩
+    exact ⟨hc, hk, fun n => PeriodTorusHigherHomology.homotopic_homologyMap hk n⟩
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/CuspFibre/CuspNegation.lean b/LeanPool/HopfProblem/CuspFibre/CuspNegation.lean
new file mode 100644
index 000000000..c3fb1154c
--- /dev/null
+++ b/LeanPool/HopfProblem/CuspFibre/CuspNegation.lean
@@ -0,0 +1,175 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.PeriodFamily.Core9
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen2
+import all LeanPool.HopfProblem.CuspFibre.CuspBoundaryTopVanishing
+import all LeanPool.HopfProblem.PeriodFamily.Core2
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology3
+import all LeanPool.HopfProblem.PeriodFamily.Core9
+
+/-!
+# Hopf problem: cusp fibre · cusp negation
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def CuspNegation.fibreNeg : C(RealTorus₄, RealTorus₄) :=
+  ⟨Neg.neg, ContinuousNeg.continuous_neg⟩
+
+public
+theorem CuspNegation.monodromy_map_neg (x : RealTorus₄) :
+    ThreefoldOverlapMappingTorus.Cusp.monodromy (-x) =
+      -ThreefoldOverlapMappingTorus.Cusp.monodromy x := by
+  obtain ⟨v, rfl⟩ := standardLattice.mkQ_surjective x
+  change
+    SpecialPeriods.CuspFamily.cuspTorusHomeomorph 1 (-standardLattice.mkQ v) =
+      -SpecialPeriods.CuspFamily.cuspTorusHomeomorph 1 (standardLattice.mkQ v)
+  rw [← map_neg, SpecialPeriods.CuspFamily.cuspTorusHomeomorph_mkQ, map_neg, map_neg,
+    SpecialPeriods.CuspFamily.cuspTorusHomeomorph_mkQ]
+
+private theorem CuspNegation.fibreNeg_monodromy (x : RealTorus₄) :
+    fibreNeg (ThreefoldOverlapMappingTorus.Cusp.monodromy x) =
+      ThreefoldOverlapMappingTorus.Cusp.monodromy (fibreNeg x) :=
+  (monodromy_map_neg x).symm
+
+private def CuspNegation.boundaryNeg :
+    C(ThreefoldOverlapMappingTorus.Cusp.Boundary, ThreefoldOverlapMappingTorus.Cusp.Boundary) :=
+  CuspBoundaryGammaZero.mappingTorusMap ThreefoldOverlapMappingTorus.Cusp.monodromy
+    ThreefoldOverlapMappingTorus.Cusp.monodromy fibreNeg fibreNeg_monodromy
+
+@[simp]
+private theorem CuspNegation.boundaryNeg_mk (t : ℝ) (x : RealTorus₄) :
+    boundaryNeg (MappingTorus.mk ThreefoldOverlapMappingTorus.Cusp.monodromy (t, x)) =
+      MappingTorus.mk ThreefoldOverlapMappingTorus.Cusp.monodromy (t, -x) :=
+  rfl
+
+private theorem CuspNegation.quotientNegation_boundaryCylinder (D : SpecialPeriods.CuspFamily.Data)
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) (t : ℝ) (x : RealTorus₄) :
+    quotientNegation D.correction D.radius
+        (ThreefoldOverlapMappingTorus.Cusp.boundaryCylinder D h (t, x)).val =
+      (ThreefoldOverlapMappingTorus.Cusp.boundaryCylinder D h (t, -x)).val := by
+  obtain ⟨v, rfl⟩ := standardLattice.mkQ_surjective x
+  have hneg : -standardLattice.mkQ v = standardLattice.mkQ (-v) := (map_neg _ _).symm
+  rw [hneg, ThreefoldOverlapMappingTorus.Cusp.boundaryCylinder_realCoordinates,
+    ThreefoldOverlapMappingTorus.Cusp.boundaryCylinder_realCoordinates,
+    quotientNegation_puncturedCuspCover]
+  apply
+    congrArg
+      (fun p : CuspUniformization.LogCover D.radius =>
+        (CuspUniformization.puncturedCuspCover D.correction D.radius p).val)
+  apply Subtype.ext
+  change
+    ((ThreefoldOverlapMappingTorus.Cusp.logPoint D.radius D.radius_pos t h : ℂ),
+        -D.periods.periodEquiv
+            (ThreefoldOverlapMappingTorus.Cusp.logPoint D.radius D.radius_pos t h) v) =
+      ((ThreefoldOverlapMappingTorus.Cusp.logPoint D.radius D.radius_pos t h : ℂ),
+        D.periods.periodEquiv
+          (ThreefoldOverlapMappingTorus.Cusp.logPoint D.radius D.radius_pos t h) (-v))
+  rw [map_neg]
+
+private theorem CuspNegation.quotientNegation_boundaryInclusion (D : SpecialPeriods.CuspFamily.Data)
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius)
+    (x : ThreefoldOverlapMappingTorus.Cusp.Boundary) :
+    quotientNegation D.correction D.radius
+        (ThreefoldOverlapMappingTorus.Cusp.boundaryInclusion D h x).val =
+      (ThreefoldOverlapMappingTorus.Cusp.boundaryInclusion D h (boundaryNeg x)).val := by
+  obtain ⟨⟨t, y⟩, rfl⟩ := MappingTorus.mk_surjective ThreefoldOverlapMappingTorus.Cusp.monodromy x
+  rw [boundaryNeg_mk]
+  exact quotientNegation_boundaryCylinder D h t y
+
+private def CuspNegation.specialCapHomeomorph :
+    SpecialPeriods.Threefold.SpecialCuspPiece ≃ₜ SpecialPeriods.Threefold.SpecialCuspPiece :=
+  quotientHomeomorph SpecialPeriods.specialCuspData.correction
+    (SpecialPeriods.Threefold.specialBaseCover.radius Option.none)
+
+private def CuspNegation.specialCapMap :
+    C(SpecialPeriods.Threefold.SpecialCuspPiece, SpecialPeriods.Threefold.SpecialCuspPiece) :=
+  ⟨specialCapHomeomorph, specialCapHomeomorph.continuous⟩
+
+private theorem CuspNegation.specialCapMap_specialBoundaryToPiece
+    (x : ThreefoldOverlapMappingTorus.Cusp.Boundary) :
+    specialCapMap (ThreefoldOverlapMappingTorus.Cusp.specialBoundaryToPiece x) =
+      ThreefoldOverlapMappingTorus.Cusp.specialBoundaryToPiece (boundaryNeg x) := by
+  change
+    quotientNegation ThreefoldOverlapMappingTorus.Cusp.specialData.correction
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius
+        (ThreefoldOverlapMappingTorus.Cusp.boundaryInclusion
+            ThreefoldOverlapMappingTorus.Cusp.specialData
+            ThreefoldOverlapMappingTorus.Cusp.specialHeight x).val =
+      (ThreefoldOverlapMappingTorus.Cusp.boundaryInclusion
+          ThreefoldOverlapMappingTorus.Cusp.specialData
+          ThreefoldOverlapMappingTorus.Cusp.specialHeight (boundaryNeg x)).val
+  exact
+    quotientNegation_boundaryInclusion ThreefoldOverlapMappingTorus.Cusp.specialData
+      ThreefoldOverlapMappingTorus.Cusp.specialHeight x
+
+private theorem CuspNegation.boundaryToFilling_neg :
+    (ThreefoldOverlapMappingTorus.boundaryToFilling Option.none).comp boundaryNeg =
+      specialCapMap.comp (ThreefoldOverlapMappingTorus.boundaryToFilling Option.none) := by
+  rw [ThreefoldOverlapMappingTorus.boundaryToFilling_cusp]
+  apply ContinuousMap.ext
+  intro x
+  exact (specialCapMap_specialBoundaryToPiece x).symm
+
+private theorem PeriodFamily.Boundary.ThirdRelation.referenceClasses_cusp_regular_negation :
+    SingularMayerVietoris.singularHomologyMap
+        (familyNegation
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂))
+        3
+        (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none 3
+          (ThreefoldHomology.ThirdDegree.referenceClasses Option.none).val) =
+      ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none 3
+        (ThreefoldHomology.ThirdDegree.referenceClasses Option.none).val :=
+  cuspNegation_capKernel_regular_fixed CuspNegation.boundaryNeg CuspNegation.boundaryNeg_mk
+    CuspNegation.specialCapMap CuspNegation.boundaryToFilling_neg
+    (ThreefoldHomology.ThirdDegree.referenceClasses Option.none)
+
+private theorem PeriodFamily.Boundary.ThirdRelation.referenceClasses_regular :
+    ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 3
+        ThreefoldHomology.ThirdDegree.referenceClasses =
+      ThreefoldHomology.ThirdDegree.thirdFibreCyclicMap 1 :=
+  referenceClasses_regular_of_cusp_negation referenceClasses_cusp_regular_negation
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/CuspFibre/CuspPositiveRetraction.lean b/LeanPool/HopfProblem/CuspFibre/CuspPositiveRetraction.lean
new file mode 100644
index 000000000..0b0b69b56
--- /dev/null
+++ b/LeanPool/HopfProblem/CuspFibre/CuspPositiveRetraction.lean
@@ -0,0 +1,4009 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Foundations.Core3
+public import LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.Foundations.InvariantSubsetQuotient
+import all LeanPool.HopfProblem.Toric.ToricSpace2
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all Mathlib.Topology.Homotopy.Lifting
+
+/-!
+# Hopf problem: cusp fibre · cusp positive retraction
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def CuspRetraction.realToComplex : (Fin 2 → ℝ) →ₗ[ℝ] (Fin 2 → ℂ)
+    where
+  toFun v i := (v i : ℂ)
+  map_add' v w := by ext i; simp
+  map_smul' a v := by ext i; simp [Complex.real_smul]
+
+@[simp]
+private theorem CuspRetraction.realToComplex_apply (v : Fin 2 → ℝ) (i : Fin 2) :
+    realToComplex v i = (v i : ℂ) :=
+  rfl
+
+private theorem CuspRetraction.realToComplex_continuous : Continuous realToComplex := by
+  apply continuous_pi
+  intro i
+  exact Complex.continuous_ofReal.comp (continuous_apply i)
+
+@[simp]
+private theorem CuspRetraction.norm_realToComplex (v : Fin 2 → ℝ) : ‖realToComplex v‖ = ‖v‖ := by
+  apply le_antisymm
+  · apply (pi_norm_le_iff_of_nonneg (norm_nonneg _)).mpr
+    intro i
+    simpa only [realToComplex_apply, Complex.norm_real] using norm_le_pi_norm v i
+  · apply (pi_norm_le_iff_of_nonneg (norm_nonneg _)).mpr
+    intro i
+    simpa only [realToComplex_apply, Complex.norm_real] using norm_le_pi_norm (realToComplex v) i
+
+private def CuspRetraction.expFibreUnits (a : Fin 2 → ℂ) : Fin 2 → ℂˣ := fun i =>
+  Units.mk0 (CuspUniformization.exponential (a i)) (CuspUniformization.exponential_ne_zero _)
+
+@[simp]
+private theorem CuspRetraction.expFibreUnits_coe (a : Fin 2 → ℂ) (i : Fin 2) :
+    (expFibreUnits a i : ℂ) = CuspUniformization.exponential (a i) :=
+  rfl
+
+@[simp]
+private theorem CuspRetraction.expFibreUnits_zero : expFibreUnits 0 = 1 := by
+  ext i
+  simp [expFibreUnits]
+
+private theorem CuspRetraction.expFibreUnits_add (a b : Fin 2 → ℂ) :
+    expFibreUnits (a + b) = expFibreUnits a * expFibreUnits b := by
+  ext i
+  simp [expFibreUnits, CuspUniformization.exponential_add]
+
+private theorem CuspRetraction.expFibreUnits_continuous : Continuous expFibreUnits := by
+  apply continuous_pi
+  intro i
+  apply Units.continuous_iff.mpr
+  have h : Continuous (fun a : Fin 2 → ℂ => CuspUniformization.exponential (a i)) :=
+    CuspUniformization.exponential_holomorphic.continuous.comp (continuous_apply i)
+  exact ⟨h, h.inv₀ (fun a => CuspUniformization.exponential_ne_zero (a i))⟩
+
+private def
+    CuspRetraction.expFibreAction (a : Fin 2 → ℂ) (x : ToricSpace.Space) : ToricSpace.Space :=
+  ToricSpace.torusAction (ToricSpace.fibreMultiplier (expFibreUnits a)) x
+
+@[simp]
+private theorem
+    CuspRetraction.expFibreAction_zero (x : ToricSpace.Space) : expFibreAction 0 x = x := by
+  simp [expFibreAction]
+
+private theorem CuspRetraction.expFibreAction_add (a b : Fin 2 → ℂ) (x : ToricSpace.Space) :
+    expFibreAction a (expFibreAction b x) = expFibreAction (a + b) x := by
+  simp only [expFibreAction, ToricSpace.torusAction_mul, expFibreUnits_add,
+    ToricSpace.fibreMultiplier_mul]
+
+@[simp]
+private theorem CuspRetraction.time_expFibreAction (a : Fin 2 → ℂ) (x : ToricSpace.Space) :
+    ToricSpace.time (expFibreAction a x) = ToricSpace.time x :=
+  ToricSpace.time_fibreMultiplier _ _
+
+private theorem CuspRetraction.expFibreAction_continuous :
+    Continuous (fun p : (Fin 2 → ℂ) × ToricSpace.Space => expFibreAction p.1 p.2) := by
+  have h :
+    Continuous
+      (fun p : (Fin 2 → ℂ) × ToricSpace.Space =>
+        (ToricSpace.fibreMultiplier (expFibreUnits p.1), p.2)) :=
+    ((ToricSpace.fibreMultiplier_continuous.comp expFibreUnits_continuous).comp
+          continuous_fst).prodMk
+      continuous_snd
+  change
+    Continuous
+      ((fun p : ToricSpace.ActingTorus × ToricSpace.Space => ToricSpace.torusAction p.1 p.2) ∘
+        (fun p : (Fin 2 → ℂ) × ToricSpace.Space =>
+          (ToricSpace.fibreMultiplier (expFibreUnits p.1), p.2)))
+  exact Continuous.comp ToricSpace.torusAction_joint_continuous h
+
+private theorem CuspRetraction.expFibreAction_translate (a : Fin 2 → ℂ) (v : Fin 2 → ℤ)
+    (x : ToricSpace.Space) :
+    expFibreAction a (ToricSpace.translate v x) = ToricSpace.translate v (expFibreAction a x) :=
+  ToricSpace.fibreMultiplier_translate _ _ _
+
+private theorem
+    CuspRetraction.torusCoordinates_expFibreAction (a : Fin 2 → ℂ) {x : ToricSpace.Space}
+    (hx : x ∈ ToricSpace.openTorus) (i : Fin 2) :
+    ToricSpace.torusCoordinates (expFibreAction a x) i.castSucc =
+      CuspUniformization.exponential (a i) * ToricSpace.torusCoordinates x i.castSucc := by
+  rw [expFibreAction, ToricSpace.torusCoordinates_action _ hx]
+  fin_cases i <;> rfl
+
+private theorem CuspRetraction.position_expFibreAction (a : Fin 2 → ℂ) {x : ToricSpace.Space}
+    (hx : x ∈ ToricSpace.openTorus) :
+    ToricSpace.position (expFibreAction a x) =
+      ToricSpace.position x +
+        (Real.log ‖ToricSpace.time x‖)⁻¹ • (fun i => -2 * Real.pi * (a i).im) := by
+  ext i
+  simp only [ToricSpace.position, time_expFibreAction, ToricSpace.logCoordinates,
+    ToricSpace.logNorm, torusCoordinates_expFibreAction a hx, norm_mul, Pi.add_apply,
+    Pi.smul_apply, smul_eq_mul]
+  rw [Real.log_mul (norm_ne_zero_iff.mpr (CuspUniformization.exponential_ne_zero _))
+      (norm_ne_zero_iff.mpr (ToricSpace.torusCoordinates_nonzero hx _)),
+    CuspUniformization.log_norm_exponential]
+  ring
+
+private theorem CuspRetraction.twistedTranslate_eq_expFibreAction (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) (x : ToricSpace.Space) :
+    ToricSpace.twistedTranslate C v x =
+      expFibreAction (C (ToricSpace.time x) *ᵥ (fun i => (v i : ℂ)))
+        (ToricSpace.translate (ToricSpace.cuspVector v) x) := by
+  unfold ToricSpace.twistedTranslate ToricSpace.variableMultiplier
+  rw [ToricSpace.time_translate]
+  rfl
+
+@[simp]
+private theorem
+    CuspRetraction.position_of_time_zero {x : ToricSpace.Space} (hx : ToricSpace.time x = 0) :
+    ToricSpace.position x = 0 := by
+  ext i
+  simp [ToricSpace.position, hx]
+
+private def CuspRetraction.frozen (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (_t : ℂ) :
+    Matrix (Fin 2) (Fin 2) ℂ :=
+  C 0
+
+private def CuspRetraction.correction (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (x : ToricSpace.Space) :
+    Fin 2 → ℂ :=
+  (D (ToricSpace.time x) - C (ToricSpace.time x)) *ᵥ
+    realToComplex (ToricSpace.inverseDisplacement C (ToricSpace.time x) (ToricSpace.position x))
+
+private def CuspRetraction.changeTwist (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (x : ToricSpace.Space) :
+    ToricSpace.Space :=
+  expFibreAction (correction C D x) x
+
+@[simp]
+private theorem CuspRetraction.time_changeTwist (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (x : ToricSpace.Space) : ToricSpace.time (changeTwist C D x) = ToricSpace.time x :=
+  time_expFibreAction _ _
+
+@[simp]
+private theorem CuspRetraction.correction_of_time_zero (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {x : ToricSpace.Space} (hx : ToricSpace.time x = 0) : correction C D x = 0 := by
+  rw [correction, position_of_time_zero hx, map_zero, map_zero, Matrix.mulVec_zero]
+
+@[simp]
+private theorem CuspRetraction.changeTwist_of_time_zero (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {x : ToricSpace.Space} (hx : ToricSpace.time x = 0) : changeTwist C D x = x := by
+  rw [changeTwist, correction_of_time_zero C D hx, expFibreAction_zero]
+
+private def CuspRetraction.tubeChangeTwist (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (x : ToricSpace.Tube (CuspQuotient.disc ε)) : ToricSpace.Tube (CuspQuotient.disc ε) :=
+  ⟨changeTwist C D x,
+    by
+    change ToricSpace.time (changeTwist C D x) ∈ CuspQuotient.disc ε
+    rw [time_changeTwist]
+    exact x.2⟩
+
+private abbrev CuspRetraction.ClosedTube (η : ℝ) :=
+  { x : ToricSpace.Space // ‖ToricSpace.time x‖ ≤ η }
+
+private def CuspRetraction.closedTubeChangeTwist (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (η : ℝ)
+    (x : ClosedTube η) : ClosedTube η :=
+  ⟨changeTwist C D x, by
+    rw [time_changeTwist]
+    exact x.2⟩
+
+private def CuspRetraction.complexEntryNorm (A : Matrix (Fin 2) (Fin 2) ℂ) : ℝ :=
+  ‖fun i : Fin 2 => fun j : Fin 2 => A i j‖
+
+private theorem CuspRetraction.complexEntryNorm_nonneg (A : Matrix (Fin 2) (Fin 2) ℂ) :
+    0 ≤ complexEntryNorm A :=
+  norm_nonneg _
+
+private theorem
+    CuspRetraction.norm_complex_mulVec_le (A : Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℂ) :
+    ‖A *ᵥ v‖ ≤ 2 * complexEntryNorm A * ‖v‖ := by
+  apply
+    (pi_norm_le_iff_of_nonneg
+        (by
+          have := complexEntryNorm_nonneg A
+          positivity)).mpr
+  intro i
+  calc
+    ‖(A *ᵥ v) i‖ ≤ ∑ j, ‖A i j * v j‖ := by
+      change ‖∑ j, A i j * v j‖ ≤ _
+      exact norm_sum_le _ _
+    _ ≤ ∑ _j : Fin 2, complexEntryNorm A * ‖v‖ := by
+      apply Finset.sum_le_sum
+      intro j _
+      rw [norm_mul]
+      exact
+        mul_le_mul
+          ((norm_le_pi_norm (A i) j).trans
+            (norm_le_pi_norm (fun k : Fin 2 => fun l : Fin 2 => A k l) i))
+          (norm_le_pi_norm v j) (norm_nonneg _) (norm_nonneg _)
+    _ = 2 * complexEntryNorm A * ‖v‖ := by simp; ring
+
+private theorem CuspRetraction.correction_norm_le (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {x : ToricSpace.Space} (ht : Real.log ‖ToricSpace.time x‖ < 0)
+    (hR :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (ToricSpace.time x)) ≤
+        -Real.log ‖ToricSpace.time x‖ / 4) :
+    ‖correction C D x‖ ≤
+      4 * complexEntryNorm (D (ToricSpace.time x) - C (ToricSpace.time x)) *
+        ‖ToricSpace.position x‖ := by
+  have hA := complexEntryNorm_nonneg (D (ToricSpace.time x) - C (ToricSpace.time x))
+  calc
+    ‖correction C D x‖ ≤
+        2 * complexEntryNorm (D (ToricSpace.time x) - C (ToricSpace.time x)) *
+          ‖ToricSpace.inverseDisplacement C (ToricSpace.time x) (ToricSpace.position x)‖ := by
+      simpa only [correction, norm_realToComplex] using
+        norm_complex_mulVec_le (D (ToricSpace.time x) - C (ToricSpace.time x))
+          (realToComplex
+            (ToricSpace.inverseDisplacement C (ToricSpace.time x) (ToricSpace.position x)))
+    _ ≤
+        2 * complexEntryNorm (D (ToricSpace.time x) - C (ToricSpace.time x)) *
+          (2 * ‖ToricSpace.position x‖) := by
+      exact
+        mul_le_mul_of_nonneg_left (ToricSpace.inverseDisplacement_norm_le C ht hR _)
+          (by positivity)
+    _ =
+        4 * complexEntryNorm (D (ToricSpace.time x) - C (ToricSpace.time x)) *
+          ‖ToricSpace.position x‖ := by ring
+
+private theorem CuspRetraction.correction_continuousAt_central (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {ε : ℝ} (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContinuousAt (fun t => C t i j) 0)
+    (hD : ∀ i j, ContinuousAt (fun t => D t i j) 0) (hzero : C 0 = D 0)
+    (hR : ToricSpace.SmallDrift C ε) {x : ToricSpace.Space} (hx : ToricSpace.time x = 0) :
+    ContinuousAt (correction C D) x := by
+  obtain ⟨B, hB, hbound⟩ :=
+    ToricSpace.position_locally_bounded hε hε1 (x := x) (by simpa only [hx, norm_zero] using hε)
+  have htime : Filter.Tendsto ToricSpace.time (𝓝 x) (𝓝 0) := by
+    simpa only [hx] using (ToricSpace.time_holomorphic.continuous.continuousAt (x := x)).tendsto
+  have hdelta :
+    ContinuousAt (fun t : ℂ => fun i : Fin 2 => fun j : Fin 2 => D t i j - C t i j) 0 := by
+    apply continuousAt_pi.mpr
+    intro i
+    apply continuousAt_pi.mpr
+    intro j
+    exact (hD i j).sub (hC i j)
+  have hnorm :
+    Filter.Tendsto
+      (fun y : ToricSpace.Space =>
+        complexEntryNorm (D (ToricSpace.time y) - C (ToricSpace.time y)))
+      (𝓝 x) (𝓝 0) := by
+    have hz : (fun i : Fin 2 => fun j : Fin 2 => D 0 i j - C 0 i j) = 0 := by
+      ext i j
+      simp only [hzero, sub_self, Pi.zero_apply]
+    have h := hdelta.norm.tendsto.comp htime
+    rw [hz, norm_zero] at h
+    exact h
+  have hlim :
+    Filter.Tendsto
+      (fun y : ToricSpace.Space =>
+        4 * complexEntryNorm (D (ToricSpace.time y) - C (ToricSpace.time y)) * B)
+      (𝓝 x) (𝓝 0) := by
+    simpa only [MulZeroClass.mul_zero, MulZeroClass.zero_mul] using
+      (tendsto_const_nhds.mul hnorm).mul (tendsto_const_nhds (x := B))
+  have hb :
+    ∀ᶠ y in 𝓝 x,
+      ‖correction C D y‖ ≤
+        4 * complexEntryNorm (D (ToricSpace.time y) - C (ToricSpace.time y)) * B := by
+    filter_upwards [hbound] with y hy
+    by_cases hy0 : ToricSpace.time y = 0
+    · rw [correction_of_time_zero C D hy0, norm_zero]
+      have := complexEntryNorm_nonneg (D (ToricSpace.time y) - C (ToricSpace.time y))
+      positivity
+    · have hn : 0 < ‖ToricSpace.time y‖ := norm_pos_iff.mpr hy0
+      exact
+        (correction_norm_le C D (Real.log_neg hn (hy.1.trans hε1)) (hR _ hn hy.1)).trans
+          (mul_le_mul_of_nonneg_left hy.2
+            (by
+              have := complexEntryNorm_nonneg (D (ToricSpace.time y) - C (ToricSpace.time y))
+              positivity))
+  change Filter.Tendsto (correction C D) (𝓝 x) (𝓝 (correction C D x))
+  rw [correction_of_time_zero C D hx]
+  exact squeeze_zero_norm' hb hlim
+
+private theorem CuspRetraction.correction_continuousAt_of_time_ne_zero
+    (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε : ℝ} (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hD : ∀ i j, ContinuousOn (fun t => D t i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) {x : ToricSpace.Space} (hx0 : ToricSpace.time x ≠ 0)
+    (hxε : ‖ToricSpace.time x‖ < ε) : ContinuousAt (correction C D) x := by
+  have hmem : ToricSpace.time x ∈ Metric.ball (0 : ℂ) ε := by
+    simpa only [Metric.mem_ball, dist_zero_right] using hxε
+  have hC' (i j) : ContinuousAt (fun t => C t i j) (ToricSpace.time x) :=
+    (hC i j).continuousAt (Metric.isOpen_ball.mem_nhds hmem)
+  have hD' (i j) : ContinuousAt (fun t => D t i j) (ToricSpace.time x) :=
+    (hD i j).continuousAt (Metric.isOpen_ball.mem_nhds hmem)
+  have hn : 0 < ‖ToricSpace.time x‖ := norm_pos_iff.mpr hx0
+  have ht : Real.log ‖ToricSpace.time x‖ < 0 := Real.log_neg hn (hxε.trans hε1)
+  have htime : ContinuousAt ToricSpace.time x :=
+    ToricSpace.time_holomorphic.continuous.continuousAt
+  have hi :
+    ContinuousAt
+      (fun y : ToricSpace.Space =>
+        ToricSpace.inverseDisplacement C (ToricSpace.time y) (ToricSpace.position y))
+      x := by
+    exact
+      ContinuousAt.comp (f := fun y : ToricSpace.Space =>
+        (ToricSpace.time y, ToricSpace.position y)) (g := fun p : ℂ × (Fin 2 → ℝ) =>
+        ToricSpace.inverseDisplacement C p.1 p.2)
+        (ToricSpace.inverseDisplacement_continuousAt C hC' ht (hR _ hn hxε)
+          (ToricSpace.position x))
+        (htime.prodMk (ToricSpace.position_continuousAt hx0 ht.ne))
+  have hv :
+    ContinuousAt
+      (fun y : ToricSpace.Space =>
+        realToComplex
+          (ToricSpace.inverseDisplacement C (ToricSpace.time y) (ToricSpace.position y)))
+      x := by
+    exact
+      ContinuousAt.comp (f := fun y : ToricSpace.Space =>
+        ToricSpace.inverseDisplacement C (ToricSpace.time y) (ToricSpace.position y)) (g :=
+        fun u : Fin 2 → ℝ => realToComplex u) realToComplex_continuous.continuousAt hi
+  have hm :
+    ContinuousAt (fun y : ToricSpace.Space => D (ToricSpace.time y) - C (ToricSpace.time y)) x := by
+    apply continuousAt_pi.mpr
+    intro i
+    apply continuousAt_pi.mpr
+    intro j
+    exact ((hD' i j).comp htime).sub ((hC' i j).comp htime)
+  have hmul : Continuous (fun p : Matrix (Fin 2) (Fin 2) ℂ × (Fin 2 → ℂ) => p.1 *ᵥ p.2) :=
+    continuous_fst.matrix_mulVec continuous_snd
+  change
+    ContinuousAt
+      ((fun p : Matrix (Fin 2) (Fin 2) ℂ × (Fin 2 → ℂ) => p.1 *ᵥ p.2) ∘
+        (fun y : ToricSpace.Space =>
+          (D (ToricSpace.time y) - C (ToricSpace.time y),
+            realToComplex
+              (ToricSpace.inverseDisplacement C (ToricSpace.time y) (ToricSpace.position y)))))
+      x
+  exact ContinuousAt.comp hmul.continuousAt (hm.prodMk hv)
+
+private theorem CuspRetraction.correction_continuousAt (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε : ℝ}
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hD : ∀ i j, ContinuousOn (fun t => D t i j) (Metric.ball 0 ε)) (hzero : C 0 = D 0)
+    (hR : ToricSpace.SmallDrift C ε) {x : ToricSpace.Space} (hxε : ‖ToricSpace.time x‖ < ε) :
+    ContinuousAt (correction C D) x := by
+  by_cases hx0 : ToricSpace.time x = 0
+  · have hmem : (0 : ℂ) ∈ Metric.ball 0 ε := by simpa using hε
+    exact
+      correction_continuousAt_central C D hε hε1
+        (fun i j => (hC i j).continuousAt (Metric.isOpen_ball.mem_nhds hmem))
+        (fun i j => (hD i j).continuousAt (Metric.isOpen_ball.mem_nhds hmem)) hzero hR hx0
+  · exact correction_continuousAt_of_time_ne_zero C D hε1 hC hD hR hx0 hxε
+
+private theorem CuspRetraction.changeTwist_continuousAt (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε : ℝ}
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hD : ∀ i j, ContinuousOn (fun t => D t i j) (Metric.ball 0 ε)) (hzero : C 0 = D 0)
+    (hR : ToricSpace.SmallDrift C ε) {x : ToricSpace.Space} (hxε : ‖ToricSpace.time x‖ < ε) :
+    ContinuousAt (changeTwist C D) x := by
+  change
+    ContinuousAt
+      ((fun p : (Fin 2 → ℂ) × ToricSpace.Space => expFibreAction p.1 p.2) ∘
+        (fun y : ToricSpace.Space => (correction C D y, y)))
+      x
+  exact
+    ContinuousAt.comp expFibreAction_continuous.continuousAt
+      ((correction_continuousAt C D hε hε1 hC hD hzero hR hxε).prodMk continuousAt_id)
+
+private theorem CuspRetraction.changeTwist_continuousOn (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε : ℝ}
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hD : ∀ i j, ContinuousOn (fun t => D t i j) (Metric.ball 0 ε)) (hzero : C 0 = D 0)
+    (hR : ToricSpace.SmallDrift C ε) :
+    ContinuousOn (changeTwist C D) (ToricSpace.time ⁻¹' Metric.ball 0 ε) := by
+  intro x hx
+  have hxε : ‖ToricSpace.time x‖ < ε := by
+    simpa only [Set.mem_preimage, Metric.mem_ball, dist_zero_right] using hx
+  exact (changeTwist_continuousAt C D hε hε1 hC hD hzero hR hxε).continuousWithinAt
+
+private theorem
+    CuspRetraction.tubeChangeTwist_continuous (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε : ℝ}
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hD : ∀ i j, ContinuousOn (fun t => D t i j) (Metric.ball 0 ε)) (hzero : C 0 = D 0)
+    (hR : ToricSpace.SmallDrift C ε) : Continuous (tubeChangeTwist C D ε) :=
+  (changeTwist_continuousOn C D hε hε1 hC hD hzero hR).domRestrict.subtype_mk _
+
+private theorem
+    CuspRetraction.displacement_change_matrix (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (t : ℂ)
+    (u : Fin 2 → ℝ) :
+    ToricSpace.displacement C t u +
+        (fun i => (-2 * Real.pi) * (((D t - C t) *ᵥ (fun j => (u j : ℂ))) i).im / Real.log ‖t‖) =
+      ToricSpace.displacement D t u := by
+  ext i
+  simp only [ToricSpace.displacement, LinearMap.add_apply, LinearMap.smul_apply,
+    Matrix.mulVecLin_apply, Pi.add_apply, Pi.smul_apply, smul_eq_mul, Matrix.mulVec, dotProduct,
+    Fin.sum_univ_two, Matrix.sub_apply, Complex.add_im, Complex.mul_im, Complex.sub_re,
+    Complex.sub_im, Complex.ofReal_re, Complex.ofReal_im, MulZeroClass.mul_zero,
+    ToricSpace.driftMatrix, div_eq_mul_inv]
+  ring
+
+private theorem CuspRetraction.position_changeTwist (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {x : ToricSpace.Space} (hx : x ∈ ToricSpace.openTorus) (ht : Real.log ‖ToricSpace.time x‖ < 0)
+    (hC :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (ToricSpace.time x)) ≤
+        -Real.log ‖ToricSpace.time x‖ / 4) :
+    ToricSpace.position (changeTwist C D x) =
+      ToricSpace.displacement D (ToricSpace.time x)
+        (ToricSpace.inverseDisplacement C (ToricSpace.time x) (ToricSpace.position x)) := by
+  rw [changeTwist, position_expFibreAction _ hx]
+  have h :=
+    displacement_change_matrix C D (ToricSpace.time x)
+      (ToricSpace.inverseDisplacement C (ToricSpace.time x) (ToricSpace.position x))
+  rw [ToricSpace.displacement_inverseDisplacement C ht hC] at h
+  convert h using 1
+  congr 1
+  ext i
+  have hu :
+    realToComplex (ToricSpace.inverseDisplacement C (ToricSpace.time x) (ToricSpace.position x)) =
+      (fun j =>
+        ((ToricSpace.inverseDisplacement C (ToricSpace.time x) (ToricSpace.position x)) j : ℂ)) :=
+    by
+    ext j
+    rfl
+  simp only [correction, hu, Pi.smul_apply, smul_eq_mul, div_eq_mul_inv]
+  ring
+
+private theorem CuspRetraction.correction_reverse (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {x : ToricSpace.Space} (hx : x ∈ ToricSpace.openTorus) (ht : Real.log ‖ToricSpace.time x‖ < 0)
+    (hC :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (ToricSpace.time x)) ≤
+        -Real.log ‖ToricSpace.time x‖ / 4)
+    (hD :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix D (ToricSpace.time x)) ≤
+        -Real.log ‖ToricSpace.time x‖ / 4) :
+    correction D C (changeTwist C D x) = -correction C D x := by
+  unfold correction
+  rw [time_changeTwist, position_changeTwist C D hx ht hC,
+    ToricSpace.inverseDisplacement_displacement D ht hD]
+  rw [show
+      C (ToricSpace.time x) - D (ToricSpace.time x) =
+        -(D (ToricSpace.time x) - C (ToricSpace.time x))
+      by abel,
+    Matrix.neg_mulVec]
+
+private theorem CuspRetraction.changeTwist_inverse_on_torus (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {x : ToricSpace.Space} (hx : x ∈ ToricSpace.openTorus) (ht : Real.log ‖ToricSpace.time x‖ < 0)
+    (hC :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (ToricSpace.time x)) ≤
+        -Real.log ‖ToricSpace.time x‖ / 4)
+    (hD :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix D (ToricSpace.time x)) ≤
+        -Real.log ‖ToricSpace.time x‖ / 4) :
+    changeTwist D C (changeTwist C D x) = x := by
+  change expFibreAction (correction D C (changeTwist C D x)) (changeTwist C D x) = x
+  rw [correction_reverse C D hx ht hC hD]
+  change expFibreAction (-correction C D x) (expFibreAction (correction C D x) x) = x
+  rw [expFibreAction_add, neg_add_cancel, expFibreAction_zero]
+
+private theorem
+    CuspRetraction.changeTwist_inverse_on_disc (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε : ℝ}
+    (hε : ε < 1) (hC : ToricSpace.SmallDrift C ε) (hD : ToricSpace.SmallDrift D ε)
+    {x : ToricSpace.Space} (hx : ‖ToricSpace.time x‖ < ε) :
+    changeTwist D C (changeTwist C D x) = x := by
+  by_cases hx0 : ToricSpace.time x = 0
+  · rw [changeTwist_of_time_zero C D hx0, changeTwist_of_time_zero D C hx0]
+  · have hp : 0 < ‖ToricSpace.time x‖ := norm_pos_iff.mpr hx0
+    exact
+      changeTwist_inverse_on_torus C D ((ToricSpace.mem_openTorus_iff x).mpr hx0)
+        (Real.log_neg hp (hx.trans hε)) (hC _ hp hx) (hD _ hp hx)
+
+private theorem CuspRetraction.correction_twistedTranslate (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) {x : ToricSpace.Space} (hx : x ∈ ToricSpace.openTorus)
+    (ht : Real.log ‖ToricSpace.time x‖ < 0)
+    (hC :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (ToricSpace.time x)) ≤
+        -Real.log ‖ToricSpace.time x‖ / 4) :
+    correction C D (ToricSpace.twistedTranslate C v x) =
+      correction C D x +
+        (D (ToricSpace.time x) - C (ToricSpace.time x)) *ᵥ (fun i => (v i : ℂ)) := by
+  unfold correction
+  rw [ToricSpace.time_twistedTranslate,
+    ToricSpace.position_twistedTranslate_displacement C v hx ht.ne,
+    ToricSpace.inverseDisplacement_add, ToricSpace.inverseDisplacement_displacement C ht hC,
+    map_add, Matrix.mulVec_add]
+  congr 2
+
+private theorem CuspRetraction.changeTwist_equivariant_on_torus (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) {x : ToricSpace.Space} (hx : x ∈ ToricSpace.openTorus)
+    (ht : Real.log ‖ToricSpace.time x‖ < 0)
+    (hC :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (ToricSpace.time x)) ≤
+        -Real.log ‖ToricSpace.time x‖ / 4) :
+    changeTwist C D (ToricSpace.twistedTranslate C v x) =
+      ToricSpace.twistedTranslate D v (changeTwist C D x) := by
+  change
+    expFibreAction (correction C D (ToricSpace.twistedTranslate C v x))
+        (ToricSpace.twistedTranslate C v x) =
+      ToricSpace.twistedTranslate D v (expFibreAction (correction C D x) x)
+  rw [correction_twistedTranslate C D v hx ht hC, twistedTranslate_eq_expFibreAction C v x,
+    twistedTranslate_eq_expFibreAction D v (expFibreAction (correction C D x) x),
+    time_expFibreAction, ← expFibreAction_translate, expFibreAction_add, expFibreAction_add]
+  congr 1
+  rw [Matrix.sub_mulVec]
+  abel
+
+private theorem CuspRetraction.changeTwist_equivariant_on_disc (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (h₀ : C 0 = D 0) {ε : ℝ} (hε : ε < 1) (hC : ToricSpace.SmallDrift C ε) (v : Fin 2 → ℤ)
+    {x : ToricSpace.Space} (hx : ‖ToricSpace.time x‖ < ε) :
+    changeTwist C D (ToricSpace.twistedTranslate C v x) =
+      ToricSpace.twistedTranslate D v (changeTwist C D x) := by
+  by_cases hx0 : ToricSpace.time x = 0
+  · rw [changeTwist_of_time_zero C D (by simpa only [ToricSpace.time_twistedTranslate] using hx0),
+      changeTwist_of_time_zero C D hx0, twistedTranslate_eq_expFibreAction C v x,
+      twistedTranslate_eq_expFibreAction D v x, hx0, h₀]
+  · have hp : 0 < ‖ToricSpace.time x‖ := norm_pos_iff.mpr hx0
+    exact
+      changeTwist_equivariant_on_torus C D v ((ToricSpace.mem_openTorus_iff x).mpr hx0)
+        (Real.log_neg hp (hx.trans hε)) (hC _ hp hx)
+
+private theorem
+    CuspRetraction.changeTwist_frozen_equivariant (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε : ℝ}
+    (hε : ε < 1) (hC : ToricSpace.SmallDrift C ε) (v : Fin 2 → ℤ) {x : ToricSpace.Space}
+    (hx : ‖ToricSpace.time x‖ < ε) :
+    changeTwist C (frozen C) (ToricSpace.twistedTranslate C v x) =
+      ToricSpace.twistedTranslate (frozen C) v (changeTwist C (frozen C) x) :=
+  changeTwist_equivariant_on_disc C (frozen C) rfl hε hC v hx
+
+private theorem
+    CuspRetraction.position_unit_fibreAction (u : Fin 2 → ℂˣ) (hu : ∀ i, ‖(u i : ℂ)‖ = 1)
+    (x : ToricSpace.Space) :
+    ToricSpace.position (ToricSpace.torusAction (ToricSpace.fibreMultiplier u) x) =
+      ToricSpace.position x := by
+  by_cases hx0 : ToricSpace.time x = 0
+  · rw [position_of_time_zero (by simpa only [ToricSpace.time_fibreMultiplier] using hx0),
+      position_of_time_zero hx0]
+  · have hx := (ToricSpace.mem_openTorus_iff x).mpr hx0
+    ext i
+    simp only [ToricSpace.position, ToricSpace.time_fibreMultiplier, ToricSpace.logCoordinates,
+      ToricSpace.logNorm, ToricSpace.torusCoordinates_action _ hx, Pi.mul_apply]
+    fin_cases i <;> simp [ToricSpace.fibreMultiplier, hu]
+
+private theorem CuspRetraction.changeTwist_unit_fibreAction (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (u : Fin 2 → ℂˣ) (hu : ∀ i, ‖(u i : ℂ)‖ = 1) (x : ToricSpace.Space) :
+    changeTwist C D (ToricSpace.torusAction (ToricSpace.fibreMultiplier u) x) =
+      ToricSpace.torusAction (ToricSpace.fibreMultiplier u) (changeTwist C D x) := by
+  have hc :
+    correction C D (ToricSpace.torusAction (ToricSpace.fibreMultiplier u) x) = correction C D x :=
+    by simp only [correction, ToricSpace.time_fibreMultiplier, position_unit_fibreAction u hu]
+  simp only [changeTwist, hc, expFibreAction, ToricSpace.torusAction_mul]
+  rw [mul_comm]
+
+private def CuspRetraction.tubeHomeomorph (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε : ℝ} (hε : 0 < ε)
+    (hε1 : ε < 1) (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hD : ∀ i j, ContinuousOn (fun t => D t i j) (Metric.ball 0 ε)) (hzero : C 0 = D 0)
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift D ε) :
+    ToricSpace.Tube (CuspQuotient.disc ε) ≃ₜ ToricSpace.Tube (CuspQuotient.disc ε)
+    where
+  toFun := tubeChangeTwist C D ε
+  invFun := tubeChangeTwist D C ε
+  left_inv
+    x := by
+    apply Subtype.ext
+    exact
+      changeTwist_inverse_on_disc C D hε1 hRC hRD
+        (by
+          have hx : ToricSpace.time (x : ToricSpace.Space) ∈ Metric.ball 0 ε := x.2
+          simpa only [Metric.mem_ball, dist_zero_right] using hx)
+  right_inv
+    x := by
+    apply Subtype.ext
+    exact
+      changeTwist_inverse_on_disc D C hε1 hRD hRC
+        (by
+          have hx : ToricSpace.time (x : ToricSpace.Space) ∈ Metric.ball 0 ε := x.2
+          simpa only [Metric.mem_ball, dist_zero_right] using hx)
+  continuous_toFun := tubeChangeTwist_continuous C D hε hε1 hC hD hzero hRC
+  continuous_invFun := tubeChangeTwist_continuous D C hε hε1 hD hC hzero.symm hRD
+
+private theorem CuspRetraction.closedTubeChangeTwist_continuous (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hD : ∀ i j, ContinuousOn (fun t => D t i j) (Metric.ball 0 ε)) (hzero : C 0 = D 0)
+    (hR : ToricSpace.SmallDrift C ε) (hηε : η < ε) : Continuous (closedTubeChangeTwist C D η) := by
+  have h : ContinuousOn (changeTwist C D) {x : ToricSpace.Space | ‖ToricSpace.time x‖ ≤ η} :=
+    (changeTwist_continuousOn C D hε hε1 hC hD hzero hR).mono
+      (fun x hx => by
+        simpa only [Set.mem_preimage, Metric.mem_ball, dist_zero_right] using hx.trans_lt hηε)
+  exact h.domRestrict.subtype_mk _
+
+private def CuspRetraction.closedTubeHomeomorph (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ}
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hD : ∀ i j, ContinuousOn (fun t => D t i j) (Metric.ball 0 ε)) (hzero : C 0 = D 0)
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift D ε) (hηε : η < ε) :
+    ClosedTube η ≃ₜ ClosedTube η
+    where
+  toFun := closedTubeChangeTwist C D η
+  invFun := closedTubeChangeTwist D C η
+  left_inv x := Subtype.ext (changeTwist_inverse_on_disc C D hε1 hRC hRD (x.2.trans_lt hηε))
+  right_inv x := Subtype.ext (changeTwist_inverse_on_disc D C hε1 hRD hRC (x.2.trans_lt hηε))
+  continuous_toFun := closedTubeChangeTwist_continuous C D hε hε1 hC hD hzero hRC hηε
+  continuous_invFun := closedTubeChangeTwist_continuous D C hε hε1 hD hC hzero.symm hRD hηε
+
+private def
+    CuspRetraction.closedTranslate (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (η : ℝ) (v : Fin 2 → ℤ)
+    (x : ClosedTube η) : ClosedTube η :=
+  ⟨ToricSpace.twistedTranslate C v x, by simpa only [ToricSpace.time_twistedTranslate] using x.2⟩
+
+private def
+    CuspRetraction.closedFibreAction (η : ℝ) (u : Fin 2 → ℂˣ) (x : ClosedTube η) : ClosedTube η :=
+  ⟨ToricSpace.torusAction (ToricSpace.fibreMultiplier u) x, by
+    simpa only [ToricSpace.time_fibreMultiplier] using x.2⟩
+
+private theorem
+    CuspRetraction.closedTubeHomeomorph_base (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ}
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hD : ∀ i j, ContinuousOn (fun t => D t i j) (Metric.ball 0 ε)) (hzero : C 0 = D 0)
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift D ε) (hηε : η < ε)
+    (x : ClosedTube η) :
+    ToricSpace.time
+        (closedTubeHomeomorph C D hε hε1 hC hD hzero hRC hRD hηε x : ToricSpace.Space) =
+      ToricSpace.time x :=
+  time_changeTwist C D x
+
+private theorem
+    CuspRetraction.closedTubeHomeomorph_fixes_central (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hD : ∀ i j, ContinuousOn (fun t => D t i j) (Metric.ball 0 ε)) (hzero : C 0 = D 0)
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift D ε) (hηε : η < ε)
+    (x : ClosedTube η) (hx : ToricSpace.time (x : ToricSpace.Space) = 0) :
+    closedTubeHomeomorph C D hε hε1 hC hD hzero hRC hRD hηε x = x :=
+  Subtype.ext (changeTwist_of_time_zero C D hx)
+
+private theorem CuspRetraction.closedTubeHomeomorph_equivariant (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hD : ∀ i j, ContinuousOn (fun t => D t i j) (Metric.ball 0 ε)) (hzero : C 0 = D 0)
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift D ε) (hηε : η < ε)
+    (v : Fin 2 → ℤ) (x : ClosedTube η) :
+    closedTubeHomeomorph C D hε hε1 hC hD hzero hRC hRD hηε (closedTranslate C η v x) =
+      closedTranslate D η v (closedTubeHomeomorph C D hε hε1 hC hD hzero hRC hRD hηε x) :=
+  Subtype.ext (changeTwist_equivariant_on_disc C D hzero hε1 hRC v (x.2.trans_lt hηε))
+
+private theorem CuspRetraction.closedTubeHomeomorph_fibre_torus (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hD : ∀ i j, ContinuousOn (fun t => D t i j) (Metric.ball 0 ε)) (hzero : C 0 = D 0)
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift D ε) (hηε : η < ε)
+    (u : Fin 2 → ℂˣ) (hu : ∀ i, ‖(u i : ℂ)‖ = 1) (x : ClosedTube η) :
+    closedTubeHomeomorph C D hε hε1 hC hD hzero hRC hRD hηε (closedFibreAction η u x) =
+      closedFibreAction η u (closedTubeHomeomorph C D hε hε1 hC hD hzero hRC hRD hηε x) :=
+  Subtype.ext (changeTwist_unit_fibreAction C D u hu x)
+
+private theorem
+    CuspRetraction.exists_common_frozen_radius (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {r : ℝ}
+    (hr : 0 < r) (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 r)) :
+    ∃ ε : ℝ,
+      0 < ε ∧ ε < r ∧ ε < 1 ∧ ToricSpace.SmallDrift C ε ∧ ToricSpace.SmallDrift (frozen C) ε := by
+  have hC0 (i j) : ContinuousAt (fun t => C t i j) 0 :=
+    (hC i j).continuousAt (Metric.isOpen_ball.mem_nhds (by simpa using hr))
+  obtain ⟨δ, hδ, hδ1, hRδ⟩ := ToricSpace.exists_smallDrift_radius C hC0
+  obtain ⟨δ₀, hδ₀, _, hRδ₀⟩ :=
+    ToricSpace.exists_smallDrift_radius (frozen C) (fun _ _ => continuousAt_const)
+  refine
+    ⟨Min.min (r / 2) (Min.min δ δ₀), lt_min (half_pos hr) (lt_min hδ hδ₀),
+      (min_le_left _ _).trans_lt (half_lt_self hr),
+      ((min_le_right _ _).trans (min_le_left _ _)).trans_lt hδ1,
+      hRδ.mono ((min_le_right _ _).trans (min_le_left _ _)),
+      hRδ₀.mono ((min_le_right _ _).trans (min_le_right _ _))⟩
+
+private abbrev CuspRetraction.ClosedQuotient (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε η : ℝ) :=
+  { x : CuspQuotient.QuotientSpace C ε // ‖CuspQuotient.projection C ε x‖ ≤ η }
+
+private def
+    CuspRetraction.closedQuotientMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hηε : η < ε)
+    (x : ClosedTube η) : ClosedQuotient C ε η :=
+  ⟨CuspQuotient.quotientMap C ε
+      ⟨x, by
+        change ToricSpace.time (x : ToricSpace.Space) ∈ Metric.ball 0 ε
+        simpa only [Metric.mem_ball, dist_zero_right] using x.2.trans_lt hηε⟩,
+    x.2⟩
+
+@[simp]
+private theorem
+    CuspRetraction.closedQuotientMap_projection (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ}
+    (hηε : η < ε) (x : ClosedTube η) :
+    CuspQuotient.projection C ε (closedQuotientMap C hηε x) =
+      ToricSpace.time (x : ToricSpace.Space) :=
+  rfl
+
+private theorem
+    CuspRetraction.closedQuotientMap_surjective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ}
+    (hηε : η < ε) : Function.Surjective (closedQuotientMap C hηε) := by
+  rintro ⟨q, hq⟩
+  obtain ⟨x, rfl⟩ := Quotient.exists_rep q
+  exact ⟨⟨x, hq⟩, rfl⟩
+
+private def CuspRetraction.closedTubePreimageHomeomorph_mo1973_10381
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hηε : η < ε) :
+    ClosedTube η ≃ₜ
+      (CuspQuotient.quotientMap C ε ⁻¹'
+        {q : CuspQuotient.QuotientSpace C ε | ‖CuspQuotient.projection C ε q‖ ≤ η})
+    where
+  toFun
+    x :=
+    ⟨⟨x, by
+        change ToricSpace.time (x : ToricSpace.Space) ∈ Metric.ball 0 ε
+        simpa only [Metric.mem_ball, dist_zero_right] using x.2.trans_lt hηε⟩,
+      x.2⟩
+  invFun x := ⟨x.1.1, x.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    apply Continuous.subtype_mk
+    exact continuous_subtype_val
+  continuous_invFun := by
+    apply Continuous.subtype_mk
+    exact continuous_subtype_val.comp continuous_subtype_val
+
+private theorem
+    CuspRetraction.closedQuotientMap_isOpenQuotientMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hηε : η < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε)) :
+    IsOpenQuotientMap (closedQuotientMap C hηε) := by
+  let := ToricSpace.tubeAction C (CuspQuotient.disc ε)
+  let := CuspQuotient.continuous_action C ε hC
+  have hq : IsOpenQuotientMap (CuspQuotient.quotientMap C ε) :=
+    MulAction.isOpenQuotientMap_quotientMk
+  exact
+    (hq.restrictPreimage
+          {q : CuspQuotient.QuotientSpace C ε | ‖CuspQuotient.projection C ε q‖ ≤ η}).comp
+      (closedTubePreimageHomeomorph_mo1973_10381 C hηε).isOpenQuotientMap
+
+private theorem CuspRetraction.closedQuotientMap_eq_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ}
+    (hηε : η < ε) (x y : ClosedTube η) :
+    closedQuotientMap C hηε x = closedQuotientMap C hηε y ↔
+      ∃ v : Fin 2 → ℤ,
+        ToricSpace.twistedTranslate C v (y : ToricSpace.Space) = (x : ToricSpace.Space) := by
+  let := ToricSpace.tubeAction C (CuspQuotient.disc ε)
+  constructor
+  · intro h
+    have hrel := Quotient.exact (congrArg Subtype.val h)
+    change
+      (⟨(x : ToricSpace.Space), _⟩ : ToricSpace.Tube (CuspQuotient.disc ε)) ∈
+        MulAction.orbit CuspQuotient.LatticeGroup
+          (⟨(y : ToricSpace.Space), _⟩ : ToricSpace.Tube (CuspQuotient.disc ε)) at hrel
+    obtain ⟨g, hg⟩ := hrel
+    exact ⟨g.toAdd, congrArg Subtype.val hg⟩
+  · rintro ⟨v, hv⟩
+    apply Subtype.ext
+    apply Quotient.sound
+    change
+      (⟨(x : ToricSpace.Space), _⟩ : ToricSpace.Tube (CuspQuotient.disc ε)) ∈
+        MulAction.orbit CuspQuotient.LatticeGroup
+          (⟨(y : ToricSpace.Space), _⟩ : ToricSpace.Tube (CuspQuotient.disc ε))
+    exact ⟨Multiplicative.ofAdd v, Subtype.ext hv⟩
+
+private theorem CuspCentralHomology.cuspQuotientMap_surjective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (δ : ℝ) : Function.Surjective (CuspQuotient.quotientMap C δ) :=
+  Quotient.mk_surjective
+
+private abbrev CuspCentralHomology.OpenQuotient (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ : ℝ) :=
+  { q : CuspQuotient.QuotientSpace C r // ‖CuspQuotient.projection C r q‖ < δ }
+
+private def
+    CuspCentralHomology.openQuotientMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {r δ : ℝ} (hδr : δ ≤ r)
+    (x : ToricSpace.Tube (CuspQuotient.disc δ)) : OpenQuotient C r δ :=
+  ⟨CuspQuotient.quotientMap C r
+      ⟨x, by
+        have hx : ToricSpace.time (x : ToricSpace.Space) ∈ Metric.ball 0 δ := x.2
+        exact Metric.ball_subset_ball hδr hx⟩,
+    by
+    change ‖ToricSpace.time (x : ToricSpace.Space)‖ < δ
+    have hx : ToricSpace.time (x : ToricSpace.Space) ∈ Metric.ball 0 δ := x.2
+    simpa only [Metric.mem_ball, dist_zero_right] using hx⟩
+
+private theorem CuspCentralHomology.openQuotientMap_surjective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {r δ : ℝ} (hδr : δ ≤ r) : Function.Surjective (openQuotientMap C hδr) := by
+  rintro ⟨q, hq⟩
+  obtain ⟨x, rfl⟩ := Quotient.exists_rep q
+  change ‖ToricSpace.time (x : ToricSpace.Space)‖ < δ at hq
+  refine ⟨⟨x, ?_⟩, rfl⟩
+  change ToricSpace.time (x : ToricSpace.Space) ∈ Metric.ball 0 δ
+  simpa only [Metric.mem_ball, dist_zero_right] using hq
+
+private def CuspCentralHomology.openTubePreimageHomeomorph_mo1973_10400
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {r δ : ℝ} (hδr : δ ≤ r) :
+    ToricSpace.Tube (CuspQuotient.disc δ) ≃ₜ
+      (CuspQuotient.quotientMap C r ⁻¹'
+        {q : CuspQuotient.QuotientSpace C r | ‖CuspQuotient.projection C r q‖ < δ})
+    where
+  toFun
+    x :=
+    ⟨⟨x, Metric.ball_subset_ball hδr x.2⟩,
+      by
+      change ‖ToricSpace.time (x : ToricSpace.Space)‖ < δ
+      have hx : ToricSpace.time (x : ToricSpace.Space) ∈ Metric.ball 0 δ := x.2
+      simpa only [Metric.mem_ball, dist_zero_right] using hx⟩
+  invFun
+    x :=
+    ⟨x.1.1, by
+      change ToricSpace.time (x.1 : ToricSpace.Space) ∈ Metric.ball 0 δ
+      have hx : ‖ToricSpace.time (x.1 : ToricSpace.Space)‖ < δ := x.2
+      simpa only [Metric.mem_ball, dist_zero_right] using hx⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    apply Continuous.subtype_mk
+    exact continuous_subtype_val
+  continuous_invFun := by
+    apply Continuous.subtype_mk
+    exact continuous_subtype_val.comp continuous_subtype_val
+
+private theorem
+    CuspCentralHomology.openQuotientMap_isOpenQuotientMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {r δ : ℝ} (hδr : δ ≤ r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    IsOpenQuotientMap (openQuotientMap C hδr) := by
+  let := ToricSpace.tubeAction C (CuspQuotient.disc r)
+  let := CuspQuotient.continuous_action C r hC
+  have hq : IsOpenQuotientMap (CuspQuotient.quotientMap C r) :=
+    MulAction.isOpenQuotientMap_quotientMk
+  exact
+    (hq.restrictPreimage
+          {q : CuspQuotient.QuotientSpace C r | ‖CuspQuotient.projection C r q‖ < δ}).comp
+      (openTubePreimageHomeomorph_mo1973_10400 C hδr).isOpenQuotientMap
+
+private theorem
+    CuspCentralHomology.openQuotientMap_eq_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {r δ : ℝ}
+    (hδr : δ ≤ r) (x y : ToricSpace.Tube (CuspQuotient.disc δ)) :
+    openQuotientMap C hδr x = openQuotientMap C hδr y ↔
+      CuspQuotient.quotientMap C δ x = CuspQuotient.quotientMap C δ y := by
+  let := ToricSpace.tubeAction C (CuspQuotient.disc r)
+  let := ToricSpace.tubeAction C (CuspQuotient.disc δ)
+  constructor
+  · intro h
+    have hrel := Quotient.exact (congrArg Subtype.val h)
+    change
+      (⟨(x : ToricSpace.Space), _⟩ : ToricSpace.Tube (CuspQuotient.disc r)) ∈
+        MulAction.orbit CuspQuotient.LatticeGroup
+          (⟨(y : ToricSpace.Space), _⟩ : ToricSpace.Tube (CuspQuotient.disc r)) at hrel
+    obtain ⟨g, hg⟩ := hrel
+    have hg' :
+      ToricSpace.twistedTranslate C g.toAdd (y : ToricSpace.Space) = (x : ToricSpace.Space) :=
+      congrArg (fun z : ToricSpace.Tube (CuspQuotient.disc r) => (z : ToricSpace.Space)) hg
+    apply Quotient.sound
+    change x ∈ MulAction.orbit CuspQuotient.LatticeGroup y
+    exact ⟨g, Subtype.ext hg'⟩
+  · intro h
+    have hrel := Quotient.exact h
+    change x ∈ MulAction.orbit CuspQuotient.LatticeGroup y at hrel
+    obtain ⟨g, hg⟩ := hrel
+    have hg' :
+      ToricSpace.twistedTranslate C g.toAdd (y : ToricSpace.Space) = (x : ToricSpace.Space) :=
+      congrArg (fun z : ToricSpace.Tube (CuspQuotient.disc δ) => (z : ToricSpace.Space)) hg
+    apply Subtype.ext
+    apply Quotient.sound
+    change
+      (⟨(x : ToricSpace.Space), _⟩ : ToricSpace.Tube (CuspQuotient.disc r)) ∈
+        MulAction.orbit CuspQuotient.LatticeGroup
+          (⟨(y : ToricSpace.Space), _⟩ : ToricSpace.Tube (CuspQuotient.disc r))
+    exact ⟨g, Subtype.ext hg'⟩
+
+private def
+    CuspCentralHomology.openQuotientRadiusHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {r δ : ℝ}
+    (hδr : δ ≤ r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    CuspQuotient.QuotientSpace C δ ≃ₜ OpenQuotient C r δ
+    where
+  toFun :=
+    CuspHoneycombHexagon.CommonFibres.descend (CuspQuotient.quotientMap C δ)
+      (openQuotientMap C hδr) (cuspQuotientMap_surjective C δ)
+  invFun :=
+    CuspHoneycombHexagon.CommonFibres.descend (openQuotientMap C hδr)
+      (CuspQuotient.quotientMap C δ) (openQuotientMap_surjective C hδr)
+  left_inv
+    q := by
+    obtain ⟨x, rfl⟩ := cuspQuotientMap_surjective C δ q
+    rw [CuspHoneycombHexagon.CommonFibres.descend_apply _ _ _
+        (fun x y => (openQuotientMap_eq_iff C hδr x y).mpr),
+      CuspHoneycombHexagon.CommonFibres.descend_apply _ _ _
+        (fun x y => (openQuotientMap_eq_iff C hδr x y).mp)]
+  right_inv
+    q := by
+    obtain ⟨x, rfl⟩ := openQuotientMap_surjective C hδr q
+    rw [CuspHoneycombHexagon.CommonFibres.descend_apply _ _ _
+        (fun x y => (openQuotientMap_eq_iff C hδr x y).mp),
+      CuspHoneycombHexagon.CommonFibres.descend_apply _ _ _
+        (fun x y => (openQuotientMap_eq_iff C hδr x y).mpr)]
+  continuous_toFun :=
+    CuspHoneycombHexagon.CommonFibres.descend_continuous _ _ _ isQuotientMap_quotient_mk'
+      (openQuotientMap_isOpenQuotientMap C hδr hC).continuous
+      (fun x y => (openQuotientMap_eq_iff C hδr x y).mpr)
+  continuous_invFun :=
+    CuspHoneycombHexagon.CommonFibres.descend_continuous _ _ _
+      (openQuotientMap_isOpenQuotientMap C hδr hC).isQuotientMap
+      (CuspQuotient.quotientMap_continuous C δ) (fun x y => (openQuotientMap_eq_iff C hδr x y).mp)
+
+@[simp]
+private theorem CuspCentralHomology.openQuotientRadiusHomeomorph_quotientMap
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {r δ : ℝ} (hδr : δ ≤ r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r))
+    (x : ToricSpace.Tube (CuspQuotient.disc δ)) :
+    openQuotientRadiusHomeomorph C hδr hC (CuspQuotient.quotientMap C δ x) =
+      openQuotientMap C hδr x :=
+  CuspHoneycombHexagon.CommonFibres.descend_apply _ _ _
+    (fun x y => (openQuotientMap_eq_iff C hδr x y).mpr) x
+
+private theorem CuspCentralHomology.openQuotientRadiusHomeomorph_projection
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {r δ : ℝ} (hδr : δ ≤ r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r))
+    (q : CuspQuotient.QuotientSpace C δ) :
+    CuspQuotient.projection C r (openQuotientRadiusHomeomorph C hδr hC q) =
+      CuspQuotient.projection C δ q := by
+  obtain ⟨x, rfl⟩ := cuspQuotientMap_surjective C δ q
+  rw [openQuotientRadiusHomeomorph_quotientMap]
+  rfl
+
+private abbrev CuspPositiveRetraction.Orthant :=
+  { r : Fin 3 → ℝ // ∀ i, 0 ≤ r i }
+
+private theorem
+    CuspPositiveRetraction.orthant_isClosed : IsClosed {r : Fin 3 → ℝ | ∀ i, 0 ≤ r i} := by
+  simp only [Set.ofPred_forall]
+  exact isClosed_iInter fun i => isClosed_le continuous_const (continuous_apply i)
+
+private instance CuspPositiveRetraction.instLocal1 : ProperSpace Orthant :=
+  ProperSpace.of_isClosed orthant_isClosed
+
+private def CuspPositiveRetraction.height (r : Orthant) : ℝ :=
+  ∏ i, r.1 i
+
+private theorem CuspPositiveRetraction.height_nonneg (r : Orthant) : 0 ≤ height r :=
+  Finset.prod_nonneg fun i _ => r.2 i
+
+private theorem
+    CuspPositiveRetraction.height_eq_zero_iff (r : Orthant) : height r = 0 ↔ ∃ i, r.1 i = 0 :=
+  by simp only [height, Finset.prod_eq_zero_iff, Finset.mem_univ, true_and]
+
+private def CuspPositiveRetraction.minimum (r : Orthant) : ℝ :=
+  Min.min (r.1 0) (Min.min (r.1 1) (r.1 2))
+
+private theorem CuspPositiveRetraction.minimum_nonneg (r : Orthant) : 0 ≤ minimum r :=
+  le_min (r.2 0) (le_min (r.2 1) (r.2 2))
+
+private theorem
+    CuspPositiveRetraction.minimum_le (r : Orthant) (i : Fin 3) : minimum r ≤ r.1 i := by
+  fin_cases i
+  · exact min_le_left _ _
+  · exact (min_le_right _ _).trans (min_le_left _ _)
+  · exact (min_le_right _ _).trans (min_le_right _ _)
+
+private theorem CuspPositiveRetraction.minimum_eq_coordinate (r : Orthant) :
+    ∃ i : Fin 3, minimum r = r.1 i := by
+  rcases min_choice (r.1 0) (Min.min (r.1 1) (r.1 2)) with h | h
+  · exact ⟨0, h⟩
+  · rcases min_choice (r.1 1) (r.1 2) with h' | h'
+    · exact ⟨1, h.trans h'⟩
+    · exact ⟨2, h.trans h'⟩
+
+private theorem
+    CuspPositiveRetraction.minimum_eq_zero_iff (r : Orthant) : minimum r = 0 ↔ height r = 0 :=
+  by
+  constructor
+  · intro h
+    obtain ⟨i, hi⟩ := minimum_eq_coordinate r
+    exact (height_eq_zero_iff r).mpr ⟨i, hi.symm.trans h⟩
+  · intro h
+    obtain ⟨i, hi⟩ := (height_eq_zero_iff r).mp h
+    exact le_antisymm (by simpa only [hi] using minimum_le r i) (minimum_nonneg r)
+
+private theorem CuspPositiveRetraction.minimum_continuous : Continuous minimum :=
+  ((continuous_apply 0).comp continuous_subtype_val).min
+    (((continuous_apply 1).comp continuous_subtype_val).min
+      ((continuous_apply 2).comp continuous_subtype_val))
+
+private def CuspPositiveRetraction.shrink (s : unitInterval) (r : Orthant) : Orthant :=
+  ⟨fun i => r.1 i - (s : ℝ) * minimum r, fun i =>
+    sub_nonneg.mpr ((mul_le_of_le_one_left (minimum_nonneg r) s.2.2).trans (minimum_le r i))⟩
+
+@[simp]
+private theorem CuspPositiveRetraction.shrink_apply (s : unitInterval) (r : Orthant) (i : Fin 3) :
+    (shrink s r).1 i = r.1 i - (s : ℝ) * minimum r :=
+  rfl
+
+private theorem CuspPositiveRetraction.shrink_continuous :
+    Continuous (fun p : unitInterval × Orthant => shrink p.1 p.2) := by
+  apply Continuous.subtype_mk
+  apply continuous_pi
+  intro i
+  exact
+    ((continuous_apply i).comp (continuous_subtype_val.comp continuous_snd)).sub
+      ((continuous_subtype_val.comp continuous_fst).mul (minimum_continuous.comp continuous_snd))
+
+@[simp]
+private theorem CuspPositiveRetraction.shrink_zero (r : Orthant) : shrink 0 r = r := by
+  apply Subtype.ext
+  funext i
+  simp only [shrink_apply, Set.Icc.coe_zero, MulZeroClass.zero_mul, sub_zero]
+
+private theorem
+    CuspPositiveRetraction.shrink_one_height (r : Orthant) : height (shrink 1 r) = 0 := by
+  obtain ⟨i, hi⟩ := minimum_eq_coordinate r
+  apply (height_eq_zero_iff _).mpr
+  refine ⟨i, ?_⟩
+  simp only [shrink_apply, Set.Icc.coe_one, one_mul, hi, sub_self]
+
+private theorem
+    CuspPositiveRetraction.shrink_fixed (s : unitInterval) {r : Orthant} (hr : height r = 0) :
+    shrink s r = r := by
+  apply Subtype.ext
+  funext i
+  simp only [shrink_apply, (minimum_eq_zero_iff r).mpr hr, MulZeroClass.mul_zero, sub_zero]
+
+private theorem
+    CuspPositiveRetraction.shrink_coordinate_le (s : unitInterval) (r : Orthant) (i : Fin 3) :
+    (shrink s r).1 i ≤ r.1 i :=
+  sub_le_self _ (mul_nonneg s.2.1 (minimum_nonneg r))
+
+private theorem CuspPositiveRetraction.shrink_height_le (s : unitInterval) (r : Orthant) :
+    height (shrink s r) ≤ height r :=
+  Finset.prod_le_prod (fun i _ => (shrink s r).2 i) (fun i _ => shrink_coordinate_le s r i)
+
+private theorem CuspPositiveRetraction.shrink_dist_eq (s : unitInterval) (r : Orthant) :
+    Dist.dist (shrink s r) r = (s : ℝ) * minimum r := by
+  rw [Subtype.dist_eq, dist_eq_norm]
+  have he : (shrink s r).1 - r.1 = fun _ : Fin 3 => -((s : ℝ) * minimum r) := by
+    funext i
+    simp only [Pi.sub_apply, shrink_apply]
+    ring
+  rw [he, pi_norm_const, norm_neg, Real.norm_eq_abs,
+    abs_of_nonneg (mul_nonneg s.2.1 (minimum_nonneg r))]
+
+private theorem CuspPositiveRetraction.shrink_dist_le_minimum (s : unitInterval) (r : Orthant) :
+    Dist.dist (shrink s r) r ≤ minimum r := by
+  rw [shrink_dist_eq]
+  exact mul_le_of_le_one_left (minimum_nonneg r) s.2.2
+
+private theorem
+    CuspPositiveRetraction.minimum_le_dist_of_height_eq_zero (r : Orthant) {r₀ : Orthant}
+    (hr₀ : height r₀ = 0) : minimum r ≤ Dist.dist r r₀ := by
+  obtain ⟨i, hi⟩ := (height_eq_zero_iff r₀).mp hr₀
+  calc
+    minimum r ≤ r.1 i := minimum_le r i
+    _ = ‖(r.1 - r₀.1) i‖ := by
+      simp only [Pi.sub_apply, hi, sub_zero, Real.norm_eq_abs, abs_of_nonneg (r.2 i)]
+    _ ≤ ‖r.1 - r₀.1‖ := (norm_le_pi_norm _ i)
+    _ = Dist.dist r r₀ := (dist_eq_norm _ _).symm
+
+private theorem CuspPositiveRetraction.shrink_dist_le_twice_dist (s : unitInterval) (r : Orthant)
+    {r₀ : Orthant} (hr₀ : height r₀ = 0) : Dist.dist (shrink s r) r₀ ≤ 2 * Dist.dist r r₀ := by
+  calc
+    Dist.dist (shrink s r) r₀ ≤ Dist.dist (shrink s r) r + Dist.dist r r₀ := dist_triangle _ _ _
+    _ ≤ minimum r + Dist.dist r r₀ := (add_le_add (shrink_dist_le_minimum s r) le_rfl)
+    _ ≤ Dist.dist r r₀ + Dist.dist r r₀ :=
+      (add_le_add (minimum_le_dist_of_height_eq_zero r hr₀) le_rfl)
+    _ = 2 * Dist.dist r r₀ := (two_mul _).symm
+
+private def CuspPositiveRetraction.cutoff (r₀ : Orthant) (R : ℝ) (r : Orthant) : ℝ :=
+  Max.max 0 (Min.min 1 (4 - 12 * Dist.dist r r₀ / R))
+
+private theorem CuspPositiveRetraction.cutoff_nonneg (r₀ : Orthant) (R : ℝ) (r : Orthant) :
+    0 ≤ cutoff r₀ R r :=
+  le_max_left _ _
+
+private theorem CuspPositiveRetraction.cutoff_le_one (r₀ : Orthant) (R : ℝ) (r : Orthant) :
+    cutoff r₀ R r ≤ 1 :=
+  max_le zero_le_one (min_le_left _ _)
+
+private theorem CuspPositiveRetraction.cutoff_continuous (r₀ : Orthant) (R : ℝ) :
+    Continuous (cutoff r₀ R) :=
+  continuous_const.max
+    (continuous_const.min
+      (continuous_const.sub
+        ((continuous_const.mul (continuous_id.dist continuous_const)).div_const R)))
+
+private theorem CuspPositiveRetraction.cutoff_eq_one_of_dist_le (r₀ : Orthant) {R : ℝ} (hR : 0 < R)
+    {r : Orthant} (hr : Dist.dist r r₀ ≤ R / 4) : cutoff r₀ R r = 1 := by
+  have hdiv : 12 * Dist.dist r r₀ / R ≤ 3 := (div_le_iff₀ hR).mpr (by linarith)
+  have h : 1 ≤ 4 - 12 * Dist.dist r r₀ / R := by linarith
+  exact (congrArg (Max.max (0 : ℝ)) (min_eq_left h)).trans (max_eq_right zero_le_one)
+
+private theorem CuspPositiveRetraction.cutoff_eq_zero_of_le_dist (r₀ : Orthant) {R : ℝ} (hR : 0 < R)
+    {r : Orthant} (hr : R / 3 ≤ Dist.dist r r₀) : cutoff r₀ R r = 0 := by
+  have hdiv : 4 ≤ 12 * Dist.dist r r₀ / R := (le_div_iff₀ hR).mpr (by linarith)
+  have h : 4 - 12 * Dist.dist r r₀ / R ≤ 0 := by linarith
+  exact (congrArg (Max.max (0 : ℝ)) (min_eq_right (h.trans zero_le_one))).trans (max_eq_left h)
+
+private def
+    CuspPositiveRetraction.cutoffParameter (r₀ : Orthant) (R : ℝ) (r : Orthant) : unitInterval :=
+  ⟨cutoff r₀ R r, cutoff_nonneg r₀ R r, cutoff_le_one r₀ R r⟩
+
+private theorem CuspPositiveRetraction.cutoffParameter_eq_one_of_dist_le (r₀ : Orthant) {R : ℝ}
+    (hR : 0 < R) {r : Orthant} (hr : Dist.dist r r₀ ≤ R / 4) : cutoffParameter r₀ R r = 1 :=
+  Subtype.ext (cutoff_eq_one_of_dist_le r₀ hR hr)
+
+private theorem CuspPositiveRetraction.cutoffParameter_eq_zero_of_le_dist (r₀ : Orthant) {R : ℝ}
+    (hR : 0 < R) {r : Orthant} (hr : R / 3 ≤ Dist.dist r r₀) : cutoffParameter r₀ R r = 0 :=
+  Subtype.ext (cutoff_eq_zero_of_le_dist r₀ hR hr)
+
+private def
+    CuspPositiveRetraction.localShrink (r₀ : Orthant) (R : ℝ) (s : unitInterval) (r : Orthant) :
+    Orthant :=
+  shrink (s * cutoffParameter r₀ R r) r
+
+private theorem CuspPositiveRetraction.localShrink_continuous (r₀ : Orthant) (R : ℝ) :
+    Continuous (fun p : unitInterval × Orthant => localShrink r₀ R p.1 p.2) := by
+  have hp : Continuous (fun p : unitInterval × Orthant => p.1 * cutoffParameter r₀ R p.2) := by
+    apply Continuous.subtype_mk
+    exact
+      (continuous_subtype_val.comp continuous_fst).mul
+        ((cutoff_continuous r₀ R).comp continuous_snd)
+  exact shrink_continuous.comp (hp.prodMk continuous_snd)
+
+@[simp]
+private theorem CuspPositiveRetraction.localShrink_zero (r₀ : Orthant) (R : ℝ) (r : Orthant) :
+    localShrink r₀ R 0 r = r := by simp only [localShrink, MulZeroClass.zero_mul, shrink_zero]
+
+private theorem CuspPositiveRetraction.localShrink_fixed (r₀ : Orthant) (R : ℝ) (s : unitInterval)
+    {r : Orthant} (hr : height r = 0) : localShrink r₀ R s r = r :=
+  shrink_fixed _ hr
+
+private theorem
+    CuspPositiveRetraction.localShrink_height_le (r₀ : Orthant) (R : ℝ) (s : unitInterval)
+    (r : Orthant) : height (localShrink r₀ R s r) ≤ height r :=
+  shrink_height_le _ r
+
+private theorem
+    CuspPositiveRetraction.localShrink_dist_le_twice_dist {r₀ : Orthant} (hr₀ : height r₀ = 0)
+    (R : ℝ) (s : unitInterval) (r : Orthant) :
+    Dist.dist (localShrink r₀ R s r) r₀ ≤ 2 * Dist.dist r r₀ :=
+  shrink_dist_le_twice_dist _ r hr₀
+
+private theorem
+    CuspPositiveRetraction.localShrink_eq_self_of_le_dist (r₀ : Orthant) {R : ℝ} (hR : 0 < R)
+    (s : unitInterval) {r : Orthant} (hr : R / 3 ≤ Dist.dist r r₀) : localShrink r₀ R s r = r := by
+  rw [localShrink, cutoffParameter_eq_zero_of_le_dist r₀ hR hr, MulZeroClass.mul_zero,
+    shrink_zero]
+
+private theorem
+    CuspPositiveRetraction.localShrink_eq_self_of_not_mem_closedBall (r₀ : Orthant) {R : ℝ}
+    (hR : 0 < R) (s : unitInterval) {r : Orthant} (hr : r ∉ Metric.closedBall r₀ (R / 3)) :
+    localShrink r₀ R s r = r :=
+  localShrink_eq_self_of_le_dist r₀ hR s (not_le.mp hr).le
+
+private theorem CuspPositiveRetraction.localShrink_one_height_of_dist_le (r₀ : Orthant) {R : ℝ}
+    (hR : 0 < R) {r : Orthant} (hr : Dist.dist r r₀ ≤ R / 4) :
+    height (localShrink r₀ R 1 r) = 0 := by
+  rw [localShrink, cutoffParameter_eq_one_of_dist_le r₀ hR hr, one_mul]
+  exact shrink_one_height r
+
+private theorem CuspPositiveRetraction.localShrink_one_height_of_mem_ball (r₀ : Orthant) {R : ℝ}
+    (hR : 0 < R) {r : Orthant} (hr : r ∈ Metric.ball r₀ (R / 4)) :
+    height (localShrink r₀ R 1 r) = 0 :=
+  localShrink_one_height_of_dist_le r₀ hR hr.le
+
+private theorem CuspPositiveRetraction.localShrink_mapsTo_ball {r₀ : Orthant} (hr₀ : height r₀ = 0)
+    {R : ℝ} (hR : 0 < R) (s : unitInterval) :
+    Set.MapsTo (localShrink r₀ R s) (Metric.ball r₀ R) (Metric.ball r₀ R) := by
+  intro r hr
+  by_cases hd : Dist.dist r r₀ < R / 3
+  · have hb := localShrink_dist_le_twice_dist hr₀ R s r
+    change Dist.dist (localShrink r₀ R s r) r₀ < R
+    linarith
+  · rw [localShrink_eq_self_of_le_dist r₀ hR s (le_of_not_gt hd)]
+    exact hr
+
+private theorem
+    CuspPositiveRetraction.localShrink_map_ball {r₀ : Orthant} (hr₀ : height r₀ = 0) {R : ℝ}
+    (hR : 0 < R) (s : unitInterval) {r : Orthant} (hr : r ∈ Metric.ball r₀ R) :
+    localShrink r₀ R s r ∈ Metric.ball r₀ R :=
+  localShrink_mapsTo_ball hr₀ hR s hr
+
+private noncomputable def
+    CuspPositiveRetraction.Supported.extend {S X Y : Type*} [TopologicalSpace S]
+    [TopologicalSpace X] [TopologicalSpace Y] (e : OpenPartialHomeomorph X Y)
+    (H : C(S × e.source, e.source)) (p : S × Y) : Y := by
+  classical exact if hy : p.2 ∈ e.target then e (H (p.1, ⟨e.symm p.2, e.map_target hy⟩)) else p.2
+
+private theorem CuspPositiveRetraction.Supported.extend_target {S X Y : Type*} [TopologicalSpace S]
+    [TopologicalSpace X] [TopologicalSpace Y] (e : OpenPartialHomeomorph X Y)
+    (H : C(S × e.source, e.source)) (s : S) (y : Y) (hy : y ∈ e.target) :
+    CuspPositiveRetraction.Supported.extend e H (s, y) = e (H (s, ⟨e.symm y, e.map_target hy⟩)) :=
+  by exact dite_eq_left hy
+
+private theorem CuspPositiveRetraction.Supported.extend_not_mem_target {S X Y : Type*}
+    [TopologicalSpace S] [TopologicalSpace X] [TopologicalSpace Y] (e : OpenPartialHomeomorph X Y)
+    (H : C(S × e.source, e.source)) (s : S) (y : Y) (hy : y ∉ e.target) :
+    CuspPositiveRetraction.Supported.extend e H (s, y) = y := by exact dite_eq_right hy
+
+private theorem CuspPositiveRetraction.Supported.extend_chart {S X Y : Type*} [TopologicalSpace S]
+    [TopologicalSpace X] [TopologicalSpace Y] (e : OpenPartialHomeomorph X Y)
+    (H : C(S × e.source, e.source)) (s : S) (x : e.source) :
+    CuspPositiveRetraction.Supported.extend e H (s, e x) = e (H (s, x)) := by
+  rw [extend_target e H s (e x) (e.map_source x.2)]
+  exact congrArg (fun z : e.source => e (H (s, z))) (Subtype.ext (e.left_inv x.2))
+
+private theorem
+    CuspPositiveRetraction.Supported.extend_not_mem_image {S X Y : Type*} [TopologicalSpace S]
+    [TopologicalSpace X] [TopologicalSpace Y] (e : OpenPartialHomeomorph X Y)
+    (H : C(S × e.source, e.source)) (K : Set X)
+    (hfix : ∀ (s : S) (x : e.source), (x : X) ∉ K → H (s, x) = x) (s : S) (y : Y)
+    (hyK : y ∉ e '' K) : CuspPositiveRetraction.Supported.extend e H (s, y) = y := by
+  by_cases hy : y ∈ e.target
+  · rw [extend_target e H s y hy]
+    have hxK : e.symm y ∉ K := fun hx => hyK ⟨e.symm y, hx, e.right_inv hy⟩
+    rw [hfix s ⟨e.symm y, e.map_target hy⟩ hxK]
+    exact e.right_inv hy
+  · exact extend_not_mem_target e H s y hy
+
+private theorem CuspPositiveRetraction.Supported.extend_continuousOn_target {S X Y : Type*}
+    [TopologicalSpace S] [TopologicalSpace X] [TopologicalSpace Y] (e : OpenPartialHomeomorph X Y)
+    (H : C(S × e.source, e.source)) :
+    ContinuousOn (CuspPositiveRetraction.Supported.extend e H) (Prod.snd ⁻¹' e.target) := by
+  rw [continuousOn_iff_continuous_domRestrict]
+  let g : (Prod.snd ⁻¹' e.target : Set (S × Y)) → S × e.source := fun p =>
+    (p.1.1, e.toHomeomorphSourceTarget.symm ⟨p.1.2, p.2⟩)
+  have hg : Continuous g :=
+    (continuous_fst.comp continuous_subtype_val).prodMk
+      (e.toHomeomorphSourceTarget.symm.continuous.comp
+        ((continuous_snd.comp continuous_subtype_val).subtype_mk _))
+  have hc :=
+    continuous_subtype_val.comp
+      (e.toHomeomorphSourceTarget.continuous.comp (H.continuous.comp hg))
+  apply hc.congr
+  intro p
+  exact (extend_target e H p.1.1 p.1.2 p.2).symm
+
+private theorem
+    CuspPositiveRetraction.Supported.extend_continuous {S X Y : Type*} [TopologicalSpace S]
+    [TopologicalSpace X] [TopologicalSpace Y] [T2Space Y] (e : OpenPartialHomeomorph X Y)
+    (H : C(S × e.source, e.source)) (K : Set X) (hK : IsCompact K) (hKs : K ⊆ e.source)
+    (hfix : ∀ (s : S) (x : e.source), (x : X) ∉ K → H (s, x) = x) :
+    Continuous (CuspPositiveRetraction.Supported.extend e H) := by
+  have hclosed : IsClosed (e '' K) :=
+    (hK.image_of_continuousOn (e.continuousOn.mono hKs)).isClosed
+  have hout :
+    ContinuousOn (CuspPositiveRetraction.Supported.extend e H) (Prod.snd ⁻¹' (e '' K)ᶜ) :=
+    continuous_snd.continuousOn.congr fun p hp => extend_not_mem_image e H K hfix p.1 p.2 hp
+  have hcover : (Prod.snd ⁻¹' e.target : Set (S × Y)) ∪ (Prod.snd ⁻¹' (e '' K)ᶜ) = Set.univ := by
+    apply Set.eq_univ_of_forall
+    intro p
+    by_cases hp : p.2 ∈ e.target
+    · exact Or.inl hp
+    · right
+      rintro ⟨x, hx, hxy⟩
+      exact hp (hxy ▸ e.map_source (hKs hx))
+  rw [← continuousOn_univ, ← hcover]
+  exact
+    (extend_continuousOn_target e H).union_of_isOpen hout (e.open_target.preimage continuous_snd)
+      (hclosed.isOpen_compl.preimage continuous_snd)
+
+private noncomputable def CuspPositiveRetraction.Supported.embeddingLocalMap_mo1973_10473
+    {S X Y : Type*} [TopologicalSpace S] [TopologicalSpace X] [TopologicalSpace Y] [Nonempty X]
+    (e : X → Y) (he : Topology.IsOpenEmbedding e) (H : C(S × X, X)) :
+    C(S × (he.toOpenPartialHomeomorph e).source, (he.toOpenPartialHomeomorph e).source)
+    where
+  toFun p := ⟨H (p.1, p.2.1), Set.mem_univ _⟩
+  continuous_toFun :=
+    (H.continuous.comp
+          (continuous_fst.prodMk (continuous_subtype_val.comp continuous_snd))).subtype_mk
+      _
+
+private noncomputable def CuspPositiveRetraction.Supported.embeddingExtend {S X Y : Type*}
+    [TopologicalSpace S] [TopologicalSpace X] [TopologicalSpace Y] [Nonempty X] (e : X → Y)
+    (he : Topology.IsOpenEmbedding e) (H : C(S × X, X)) : S × Y → Y :=
+  CuspPositiveRetraction.Supported.extend (he.toOpenPartialHomeomorph e)
+    (embeddingLocalMap_mo1973_10473 e he H)
+
+private theorem CuspPositiveRetraction.Supported.embeddingExtend_chart {S X Y : Type*}
+    [TopologicalSpace S] [TopologicalSpace X] [TopologicalSpace Y] [Nonempty X] (e : X → Y)
+    (he : Topology.IsOpenEmbedding e) (H : C(S × X, X)) (s : S) (x : X) :
+    embeddingExtend e he H (s, e x) = e (H (s, x)) := by
+  let x' : (he.toOpenPartialHomeomorph e).source := ⟨x, Set.mem_univ _⟩
+  simpa only [embeddingExtend, embeddingLocalMap_mo1973_10473, ContinuousMap.coe_mk,
+    he.toOpenPartialHomeomorph_apply e] using
+    extend_chart (he.toOpenPartialHomeomorph e) (embeddingLocalMap_mo1973_10473 e he H) s x'
+
+private theorem CuspPositiveRetraction.Supported.embeddingExtend_not_mem_range {S X Y : Type*}
+    [TopologicalSpace S] [TopologicalSpace X] [TopologicalSpace Y] [Nonempty X] (e : X → Y)
+    (he : Topology.IsOpenEmbedding e) (H : C(S × X, X)) (s : S) (y : Y) (hy : y ∉ Set.range e) :
+    embeddingExtend e he H (s, y) = y := by
+  exact
+    extend_not_mem_target (he.toOpenPartialHomeomorph e) (embeddingLocalMap_mo1973_10473 e he H) s
+      y (by simpa only [he.toOpenPartialHomeomorph_target e] using hy)
+
+private theorem CuspPositiveRetraction.Supported.embeddingExtend_continuous {S X Y : Type*}
+    [TopologicalSpace S] [TopologicalSpace X] [TopologicalSpace Y] [Nonempty X] [T2Space Y]
+    (e : X → Y) (he : Topology.IsOpenEmbedding e) (H : C(S × X, X)) (K : Set X) (hK : IsCompact K)
+    (hfix : ∀ (s : S) (x : X), x ∉ K → H (s, x) = x) : Continuous (embeddingExtend e he H) := by
+  apply
+    extend_continuous (he.toOpenPartialHomeomorph e) (embeddingLocalMap_mo1973_10473 e he H) K hK
+  · rw [he.toOpenPartialHomeomorph_source e]
+    exact Set.subset_univ K
+  · intro s x hx
+    exact Subtype.ext (hfix s x hx)
+
+private noncomputable def CuspPositiveRetraction.Supported.embeddingMap {S X Y : Type*}
+    [TopologicalSpace S] [TopologicalSpace X] [TopologicalSpace Y] [Nonempty X] [T2Space Y]
+    (e : X → Y) (he : Topology.IsOpenEmbedding e) (H : C(S × X, X)) (K : Set X) (hK : IsCompact K)
+    (hfix : ∀ (s : S) (x : X), x ∉ K → H (s, x) = x) : C(S × Y, Y) :=
+  ⟨embeddingExtend e he H, embeddingExtend_continuous e he H K hK hfix⟩
+
+private theorem
+    CuspPositiveRetraction.Supported.embeddingExtend_id {S X Y : Type*} [TopologicalSpace S]
+    [TopologicalSpace X] [TopologicalSpace Y] [Nonempty X] (e : X → Y)
+    (he : Topology.IsOpenEmbedding e) (H : C(S × X, X)) (s : S) (hs : ∀ x : X, H (s, x) = x)
+    (y : Y) : embeddingExtend e he H (s, y) = y := by
+  by_cases hy : y ∈ Set.range e
+  · obtain ⟨x, rfl⟩ := hy
+    rw [embeddingExtend_chart e he H, hs]
+  · exact embeddingExtend_not_mem_range e he H s y hy
+
+private theorem CuspPositiveRetraction.Supported.embeddingExtend_fixed {S X Y : Type*}
+    [TopologicalSpace S] [TopologicalSpace X] [TopologicalSpace Y] [Nonempty X] (e : X → Y)
+    (he : Topology.IsOpenEmbedding e) (H : C(S × X, X)) (A : Set Y)
+    (hfix : ∀ (s : S) (x : X), e x ∈ A → H (s, x) = x) (s : S) (y : Y) (hyA : y ∈ A) :
+    embeddingExtend e he H (s, y) = y := by
+  by_cases hy : y ∈ Set.range e
+  · obtain ⟨x, rfl⟩ := hy
+    rw [embeddingExtend_chart e he H, hfix s x hyA]
+  · exact embeddingExtend_not_mem_range e he H s y hy
+
+private theorem
+    CuspPositiveRetraction.Supported.embeddingExtend_rel {S X Y : Type*} [TopologicalSpace S]
+    [TopologicalSpace X] [TopologicalSpace Y] [Nonempty X] (e : X → Y)
+    (he : Topology.IsOpenEmbedding e) (H : C(S × X, X)) (R : Y → Y → Prop) (hrefl : ∀ y, R y y)
+    (hlocal : ∀ (s : S) (x : X), R (e x) (e (H (s, x)))) (s : S) (y : Y) :
+    R y (embeddingExtend e he H (s, y)) := by
+  by_cases hy : y ∈ Set.range e
+  · obtain ⟨x, rfl⟩ := hy
+    rw [embeddingExtend_chart e he H]
+    exact hlocal s x
+  · rw [embeddingExtend_not_mem_range e he H s y hy]
+    exact hrefl y
+
+private theorem CuspPositiveRetraction.Supported.embeddingExtend_height_nonincrease {S X Y : Type*}
+    [TopologicalSpace S] [TopologicalSpace X] [TopologicalSpace Y] [Nonempty X] (e : X → Y)
+    (he : Topology.IsOpenEmbedding e) (H : C(S × X, X)) (f : Y → ℝ)
+    (hlocal : ∀ (s : S) (x : X), f (e (H (s, x))) ≤ f (e x)) (s : S) (y : Y) :
+    f (embeddingExtend e he H (s, y)) ≤ f y :=
+  embeddingExtend_rel e he H (fun y z => f z ≤ f y) (fun _ => le_rfl) hlocal s y
+
+private theorem
+    CuspRetraction.Patching.zeroSet_isCompact {X : Type*} [TopologicalSpace X] (f : C(X, ℝ))
+    {r : ℝ} (hr : 0 < r) (hc : IsCompact {x : X | f x ≤ r}) : IsCompact {x : X | f x = 0} := by
+  apply hc.of_isClosed_subset (isClosed_eq f.continuous continuous_const)
+  intro x hx
+  change f x ≤ r
+  rw [show f x = 0 from hx]
+  exact hr.le
+
+public
+theorem CuspRetraction.Patching.exists_positive_sublevel_subset_open {X : Type*}
+    [TopologicalSpace X] (f : C(X, ℝ)) (hf : ∀ x, 0 ≤ f x) {r : ℝ} (hr : 0 < r)
+    (hc : IsCompact {x : X | f x ≤ r}) {U : Set X} (hU : IsOpen U) (hS : {x : X | f x = 0} ⊆ U) :
+    ∃ η : ℝ, 0 < η ∧ η ≤ r ∧ {x : X | f x ≤ η} ⊆ U := by
+  have hK : IsCompact (f '' ({x : X | f x ≤ r} \ U)) := (hc.diff hU).image f.continuous
+  have hzero : (0 : ℝ) ∈ (f '' ({x : X | f x ≤ r} \ U))ᶜ := by
+    rintro ⟨x, hx, hfx⟩
+    exact hx.2 (hS hfx)
+  obtain ⟨a, b, hab, hsub⟩ :=
+    mem_nhds_iff_exists_Ioo_subset.mp (hK.isClosed.isOpen_compl.mem_nhds hzero)
+  refine ⟨Min.min r (b / 2), lt_min hr (half_pos hab.2), min_le_left _ _, ?_⟩
+  intro x hx
+  change f x ≤ Min.min r (b / 2) at hx
+  by_contra hxu
+  have hfx : f x < b := (hx.trans (min_le_right r (b / 2))).trans_lt (half_lt_self hab.2)
+  apply hsub ⟨hab.1.trans_le (hf x), hfx⟩
+  exact ⟨x, ⟨hx.trans (min_le_left r (b / 2)), hxu⟩, rfl⟩
+
+private structure CuspRetraction.Patching.LocalCollapse {X : Type*} [TopologicalSpace X]
+    (f : C(X, ℝ)) where
+  homotopy : C(unitInterval × X, X)
+  map_zero : ∀ x, homotopy (0, x) = x
+  fixes_zero : ∀ s x, f x = 0 → homotopy (s, x) = x
+  nonincreasing : ∀ s x, f (homotopy (s, x)) ≤ f x
+  collapseSet : Set X
+  isOpen_collapseSet : IsOpen collapseSet
+  map_one_zero : ∀ x ∈ collapseSet, f (homotopy (1, x)) = 0
+
+private def CuspRetraction.Patching.LocalCollapse.identity {X : Type*} [TopologicalSpace X]
+    (f : C(X, ℝ)) : CuspRetraction.Patching.LocalCollapse f
+    where
+  homotopy := ⟨Prod.snd, continuous_snd⟩
+  map_zero _ := rfl
+  fixes_zero _ _ _ := rfl
+  nonincreasing _ _ := le_rfl
+  collapseSet := ∅
+  isOpen_collapseSet := isOpen_empty
+  map_one_zero _ h := h.elim
+
+private def
+    CuspRetraction.Patching.LocalCollapse.comp {X : Type*} [TopologicalSpace X] {f : C(X, ℝ)}
+    (A B : CuspRetraction.Patching.LocalCollapse f) : CuspRetraction.Patching.LocalCollapse f
+    where
+  homotopy :=
+    ⟨fun p => B.homotopy (p.1, A.homotopy p),
+      B.homotopy.continuous.comp (continuous_fst.prodMk A.homotopy.continuous)⟩
+  map_zero
+    x := by
+    change B.homotopy (0, A.homotopy (0, x)) = x
+    rw [A.map_zero, B.map_zero]
+  fixes_zero s x
+    hx := by
+    change B.homotopy (s, A.homotopy (s, x)) = x
+    rw [A.fixes_zero s x hx, B.fixes_zero s x hx]
+  nonincreasing s x := (B.nonincreasing s (A.homotopy (s, x))).trans (A.nonincreasing s x)
+  collapseSet := A.collapseSet ∪ (fun x => A.homotopy (1, x)) ⁻¹' B.collapseSet
+  isOpen_collapseSet :=
+    A.isOpen_collapseSet.union
+      (B.isOpen_collapseSet.preimage
+        (A.homotopy.continuous.comp (continuous_const.prodMk continuous_id)))
+  map_one_zero x
+    hx := by
+    change f (B.homotopy (1, A.homotopy (1, x))) = 0
+    rcases hx with hx | hx
+    · rw [B.fixes_zero 1 _ (A.map_one_zero x hx)]
+      exact A.map_one_zero x hx
+    · exact B.map_one_zero (A.homotopy (1, x)) hx
+
+private theorem CuspRetraction.Patching.LocalCollapse.mem_comp_collapseSet_of_zero {X : Type*}
+    [TopologicalSpace X] {f : C(X, ℝ)} (A B : CuspRetraction.Patching.LocalCollapse f) {x : X}
+    (hx : f x = 0) (h : x ∈ A.collapseSet ∪ B.collapseSet) : x ∈ (A.comp B).collapseSet := by
+  rcases h with h | h
+  · exact Or.inl h
+  · apply Or.inr
+    change A.homotopy (1, x) ∈ B.collapseSet
+    rwa [A.fixes_zero 1 x hx]
+
+private def
+    CuspRetraction.Patching.LocalCollapse.combine {X : Type*} [TopologicalSpace X] {f : C(X, ℝ)}
+    {ι : Type*} (A : ι → CuspRetraction.Patching.LocalCollapse f) :
+    List ι → CuspRetraction.Patching.LocalCollapse f
+  | [] => identity f
+  | i :: l => (A i).comp (combine A l)
+
+private theorem CuspRetraction.Patching.LocalCollapse.mem_combine_collapseSet_of_zero {X : Type*}
+    [TopologicalSpace X] {f : C(X, ℝ)} {ι : Type*}
+    (A : ι → CuspRetraction.Patching.LocalCollapse f) (l : List ι) {x : X} (hx : f x = 0) {i : ι}
+    (hi : i ∈ l) (hxi : x ∈ (A i).collapseSet) : x ∈ (combine A l).collapseSet := by
+  induction l with
+  | nil => simp at hi
+  | cons a l ih =>
+    rcases List.mem_cons.mp hi with hi | hi
+    · subst i
+      exact mem_comp_collapseSet_of_zero (A a) (combine A l) hx (Or.inl hxi)
+    · exact mem_comp_collapseSet_of_zero (A a) (combine A l) hx (Or.inr (ih hi))
+
+private theorem CuspRetraction.Patching.exists_localCollapse_covering_zero {X : Type*}
+    [TopologicalSpace X] {f : C(X, ℝ)} {ι : Type*} (A : ι → LocalCollapse f)
+    (hcompact : IsCompact {x : X | f x = 0})
+    (hcover : {x : X | f x = 0} ⊆ ⋃ i, (A i).collapseSet) :
+    ∃ B : LocalCollapse f, {x : X | f x = 0} ⊆ B.collapseSet := by
+  classical
+  obtain ⟨s, hs⟩ :=
+    hcompact.elim_finite_subcover (fun i => (A i).collapseSet) (fun i => (A i).isOpen_collapseSet)
+      hcover
+  refine ⟨LocalCollapse.combine A s.toList, ?_⟩
+  intro x hx
+  obtain ⟨i, hi, hxi⟩ := Set.mem_iUnion₂.mp (hs hx)
+  exact
+    LocalCollapse.mem_combine_collapseSet_of_zero A s.toList hx
+      (by simpa only [Finset.mem_toList] using hi) hxi
+
+private theorem CuspRetraction.Patching.exists_localCollapse_covering_zero_of_local {X : Type*}
+    [TopologicalSpace X] {f : C(X, ℝ)} (hcompact : IsCompact {x : X | f x = 0})
+    (hlocal : ∀ x : X, f x = 0 → ∃ A : LocalCollapse f, x ∈ A.collapseSet) :
+    ∃ B : LocalCollapse f, {x : X | f x = 0} ⊆ B.collapseSet := by
+  classical
+  choose A hA using fun x : { x : X // f x = 0 } => hlocal x x.2
+  apply exists_localCollapse_covering_zero A hcompact
+  intro x hx
+  exact Set.mem_iUnion.mpr ⟨⟨x, hx⟩, hA ⟨x, hx⟩⟩
+
+private theorem CuspRetraction.Patching.exists_small_sublevel_localCollapse {X : Type*}
+    [TopologicalSpace X] (f : C(X, ℝ)) (hf : ∀ x, 0 ≤ f x) {r : ℝ} (hr : 0 < r)
+    (hc : IsCompact {x : X | f x ≤ r})
+    (hlocal : ∀ x : X, f x = 0 → ∃ A : LocalCollapse f, x ∈ A.collapseSet) :
+    ∃ η : ℝ, 0 < η ∧ η ≤ r ∧ ∃ A : LocalCollapse f, {x : X | f x ≤ η} ⊆ A.collapseSet := by
+  obtain ⟨A, hA⟩ := exists_localCollapse_covering_zero_of_local (zeroSet_isCompact f hr hc) hlocal
+  obtain ⟨η, hη, hηr, hηA⟩ :=
+    exists_positive_sublevel_subset_open f hf hr hc A.isOpen_collapseSet hA
+  exact ⟨η, hη, hηr, A, hηA⟩
+
+private theorem CuspPositiveRetraction.exists_localCollapse_of_orthant_chart {X : Type*}
+    [TopologicalSpace X] [T2Space X] (f : C(X, ℝ)) (e : OpenPartialHomeomorph Orthant X)
+    {r₀ : Orthant} (hr₀ : r₀ ∈ e.source) (hzero : height r₀ = 0)
+    (hheight : ∀ r ∈ e.source, f (e r) = height r) :
+    ∃ A : CuspRetraction.Patching.LocalCollapse f, e r₀ ∈ A.collapseSet := by
+  obtain ⟨R, hR, hball⟩ := Metric.isOpen_iff.mp e.open_source r₀ hr₀
+  let U := Metric.ball r₀ R
+  let : Nonempty U := ⟨⟨r₀, Metric.mem_ball_self hR⟩⟩
+  let ep : U → X := fun r => e r.1
+  have hep : Topology.IsOpenEmbedding ep := by
+    exact
+      e.isOpenEmbedding_restrict.comp
+        (Topology.IsOpenEmbedding.inclusion hball
+          (Metric.isOpen_ball.preimage continuous_subtype_val))
+  let H : C(unitInterval × U, U) :=
+    ⟨fun p => ⟨localShrink r₀ R p.1 p.2.1, localShrink_map_ball hzero hR p.1 p.2.2⟩,
+      ((localShrink_continuous r₀ R).comp
+            (continuous_fst.prodMk (continuous_subtype_val.comp continuous_snd))).subtype_mk
+        _⟩
+  let K : Set U := Subtype.val ⁻¹' Metric.closedBall r₀ (R / 3)
+  have hK : IsCompact K := by
+    apply
+      Topology.IsEmbedding.subtypeVal.isInducing.isCompact_preimage'
+        (ProperSpace.isCompact_closedBall r₀ (R / 3))
+    intro r hr
+    have hrU : r ∈ U := by
+      change Dist.dist r r₀ < R
+      have hd : Dist.dist r r₀ ≤ R / 3 := hr
+      linarith
+    exact ⟨⟨r, hrU⟩, rfl⟩
+  have hfix : ∀ (s : unitInterval) (r : U), r ∉ K → H (s, r) = r := by
+    intro s r hr
+    exact Subtype.ext (localShrink_eq_self_of_not_mem_closedBall r₀ hR s hr)
+  have hH0 : ∀ r : U, H (0, r) = r := by
+    intro r
+    exact Subtype.ext (localShrink_zero r₀ R r.1)
+  have hHfix : ∀ (s : unitInterval) (r : U), f (ep r) = 0 → H (s, r) = r := by
+    intro s r hr
+    have hz : height r.1 = 0 := (hheight r.1 (hball r.2)).symm.trans hr
+    exact Subtype.ext (localShrink_fixed r₀ R s hz)
+  have hHle : ∀ (s : unitInterval) (r : U), f (ep (H (s, r))) ≤ f (ep r) := by
+    intro s r
+    change f (e (H (s, r)).1) ≤ f (e r.1)
+    rw [hheight (H (s, r)).1 (hball (H (s, r)).2), hheight r.1 (hball r.2)]
+    exact localShrink_height_le r₀ R s r.1
+  let L : Set U := Subtype.val ⁻¹' Metric.ball r₀ (R / 4)
+  have hL : IsOpen L := Metric.isOpen_ball.preimage continuous_subtype_val
+  let A : CuspRetraction.Patching.LocalCollapse f :=
+    { homotopy := Supported.embeddingMap ep hep H K hK hfix
+      map_zero := Supported.embeddingExtend_id ep hep H 0 hH0
+      fixes_zero := fun s x hx =>
+        Supported.embeddingExtend_fixed ep hep H {y | f y = 0} hHfix s x hx
+      nonincreasing := Supported.embeddingExtend_height_nonincrease ep hep H f hHle
+      collapseSet := ep '' L
+      isOpen_collapseSet := hep.isOpenMap L hL
+      map_one_zero := by
+        rintro x ⟨r, hr, rfl⟩
+        change f (Supported.embeddingExtend ep hep H (1, ep r)) = 0
+        rw [Supported.embeddingExtend_chart]
+        change f (e (H (1, r)).1) = 0
+        rw [hheight (H (1, r)).1 (hball (H (1, r)).2)]
+        exact localShrink_one_height_of_mem_ball r₀ hR hr }
+  refine ⟨A, ⟨⟨r₀, Metric.mem_ball_self hR⟩, ?_, rfl⟩⟩
+  exact Metric.mem_ball_self (by linarith)
+
+private theorem CuspPositiveRetraction.exists_small_sublevel_collapse_of_orthant_charts {X : Type*}
+    [TopologicalSpace X] [T2Space X] (f : C(X, ℝ)) (hf : ∀ x, 0 ≤ f x) {r : ℝ} (hr : 0 < r)
+    (hcompact : IsCompact {x : X | f x ≤ r})
+    (hcharts :
+      ∀ x : X,
+        f x = 0 →
+          ∃ (e : OpenPartialHomeomorph Orthant X) (r₀ : Orthant),
+            r₀ ∈ e.source ∧ e r₀ = x ∧ ∀ r ∈ e.source, f (e r) = height r) :
+    ∃ η : ℝ,
+      0 < η ∧
+        η ≤ r ∧
+          ∃ A : CuspRetraction.Patching.LocalCollapse f, {x : X | f x ≤ η} ⊆ A.collapseSet := by
+  apply CuspRetraction.Patching.exists_small_sublevel_localCollapse f hf hr hcompact
+  intro x hx
+  obtain ⟨e, r₀, hr₀, he, hh⟩ := hcharts x hx
+  have hzero : height r₀ = 0 := (hh r₀ hr₀).symm.trans (he ▸ hx)
+  obtain ⟨A, hA⟩ := exists_localCollapse_of_orthant_chart f e hr₀ hzero hh
+  exact ⟨A, he ▸ hA⟩
+
+private def CuspPositiveRetraction.Covering.pullback {E B : Type*} [TopologicalSpace E]
+    [TopologicalSpace B] {q : E → B} (hq : IsCoveringMap q) (H : C(unitInterval × B, B)) :
+    C(unitInterval × E, B) where
+  toFun p := H (p.1, q p.2)
+  continuous_toFun :=
+    H.continuous.comp
+      (continuous_fst.prodMk (hq.isLocalHomeomorph.continuous.comp continuous_snd))
+
+private def
+    CuspPositiveRetraction.Covering.lift {E B : Type*} [TopologicalSpace E] [TopologicalSpace B]
+    {q : E → B} (hq : IsCoveringMap q) (H : C(unitInterval × B, B)) (hzero : ∀ b, H (0, b) = b) :
+    C(unitInterval × E, E) :=
+  hq.liftHomotopy (pullback hq H) (ContinuousMap.id E) (fun x => hzero (q x))
+
+@[simp]
+private theorem CuspPositiveRetraction.Covering.lift_zero {E B : Type*} [TopologicalSpace E]
+    [TopologicalSpace B] {q : E → B} (hq : IsCoveringMap q) (H : C(unitInterval × B, B))
+    (hzero : ∀ b, H (0, b) = b) (x : E) :
+    CuspPositiveRetraction.Covering.lift hq H hzero (0, x) = x :=
+  hq.liftHomotopy_zero _ _ _ x
+
+private theorem CuspPositiveRetraction.Covering.lift_projection {E B : Type*} [TopologicalSpace E]
+    [TopologicalSpace B] {q : E → B} (hq : IsCoveringMap q) (H : C(unitInterval × B, B))
+    (hzero : ∀ b, H (0, b) = b) (s : unitInterval) (x : E) :
+    q (CuspPositiveRetraction.Covering.lift hq H hzero (s, x)) = H (s, q x) :=
+  congr_fun (hq.liftHomotopy_lifts (pullback hq H) (ContinuousMap.id E) (fun y => hzero (q y)))
+    (s, x)
+
+private theorem CuspPositiveRetraction.Covering.lift_fixed {E B : Type*} [TopologicalSpace E]
+    [TopologicalSpace B] {q : E → B} (hq : IsCoveringMap q) (H : C(unitInterval × B, B))
+    (hzero : ∀ b, H (0, b) = b) (x : E) (hx : ∀ s : unitInterval, H (s, q x) = q x)
+    (s : unitInterval) : CuspPositiveRetraction.Covering.lift hq H hzero (s, x) = x := by
+  have hc :
+    Continuous (fun t : unitInterval => CuspPositiveRetraction.Covering.lift hq H hzero (t, x)) :=
+    (CuspPositiveRetraction.Covering.lift hq H hzero).continuous.comp
+      (continuous_id.prodMk continuous_const)
+  have h := hq.const_of_comp hc (fun t t' => by simp only [lift_projection hq H hzero, hx]) s 0
+  exact h.trans (lift_zero hq H hzero x)
+
+private theorem CuspPositiveRetraction.Covering.lift_equivariant {E B : Type*} [TopologicalSpace E]
+    [TopologicalSpace B] {q : E → B} (hq : IsCoveringMap q) (H : C(unitInterval × B, B))
+    (hzero : ∀ b, H (0, b) = b) {G : Type*} [Group G] [MulAction G E] [ContinuousConstSMul G E]
+    (hdeck : ∀ (g : G) (x : E), q (g • x) = q x) (g : G) (s : unitInterval) (x : E) :
+    CuspPositiveRetraction.Covering.lift hq H hzero (s, g • x) =
+      g • CuspPositiveRetraction.Covering.lift hq H hzero (s, x) := by
+  have hleft :
+    Continuous
+      (fun t : unitInterval => CuspPositiveRetraction.Covering.lift hq H hzero (t, g • x)) :=
+    (CuspPositiveRetraction.Covering.lift hq H hzero).continuous.comp
+      (continuous_id.prodMk continuous_const)
+  have hright :
+    Continuous
+      (fun t : unitInterval => g • CuspPositiveRetraction.Covering.lift hq H hzero (t, x)) :=
+    (ContinuousConstSMul.continuous_const_smul g).comp
+      ((CuspPositiveRetraction.Covering.lift hq H hzero).continuous.comp
+        (continuous_id.prodMk continuous_const))
+  have he :
+    q ∘ (fun t : unitInterval => CuspPositiveRetraction.Covering.lift hq H hzero (t, g • x)) =
+      q ∘ (fun t : unitInterval => g • CuspPositiveRetraction.Covering.lift hq H hzero (t, x)) := by
+    funext t
+    simp only [Function.comp_apply, lift_projection hq H hzero, hdeck]
+  exact congr_fun (hq.eq_of_comp_eq hleft hright he 0 (by simp only [lift_zero])) s
+
+private theorem CuspPositiveRetraction.Covering.lift_height_le {E B : Type*} [TopologicalSpace E]
+    [TopologicalSpace B] {q : E → B} (hq : IsCoveringMap q) (H : C(unitInterval × B, B))
+    (hzero : ∀ b, H (0, b) = b) (f : B → ℝ) (hsize : ∀ (s : unitInterval) b, f (H (s, b)) ≤ f b)
+    (s : unitInterval) (x : E) :
+    f (q (CuspPositiveRetraction.Covering.lift hq H hzero (s, x))) ≤ f (q x) := by
+  rw [lift_projection hq H hzero]
+  exact hsize s (q x)
+
+private def CuspPositiveRetraction.Covering.liftSublevel {E B : Type*} [TopologicalSpace E]
+    [TopologicalSpace B] {q : E → B} (hq : IsCoveringMap q) (H : C(unitInterval × B, B))
+    (hzero : ∀ b, H (0, b) = b) (f : B → ℝ) (η : ℝ)
+    (hsize : ∀ (s : unitInterval) b, f (H (s, b)) ≤ f b) :
+    C(unitInterval × { x : E // f (q x) ≤ η }, { x : E // f (q x) ≤ η })
+    where
+  toFun
+    p :=
+    ⟨CuspPositiveRetraction.Covering.lift hq H hzero (p.1, p.2.1),
+      (lift_height_le hq H hzero f hsize p.1 p.2.1).trans p.2.2⟩
+  continuous_toFun :=
+    ((CuspPositiveRetraction.Covering.lift hq H hzero).continuous.comp
+          (continuous_fst.prodMk (continuous_subtype_val.comp continuous_snd))).subtype_mk
+      _
+
+private def CuspPositive.positiveTwist (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (_t : ℂ) :
+    Matrix (Fin 2) (Fin 2) ℂ :=
+  Matrix.of fun i j => Complex.I * ((C₀ i j).im : ℂ)
+
+private theorem
+    CuspPositive.positiveTwist_holomorphic (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (i j : Fin 2) :
+    ContDiff ℂ ω (fun t => positiveTwist C₀ t i j) :=
+  contDiff_const
+
+@[simp]
+private theorem CuspPositive.driftMatrix_positiveTwist (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (t : ℂ) :
+    ToricSpace.driftMatrix (positiveTwist C₀) t = ToricSpace.driftMatrix (fun _ => C₀) 0 := by
+  ext i j
+  simp [ToricSpace.driftMatrix, positiveTwist, Complex.mul_im]
+
+private theorem CuspPositive.smallDrift_positiveTwist_iff (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    ToricSpace.SmallDrift (positiveTwist C₀) ε ↔ ToricSpace.SmallDrift (fun _ => C₀) ε := by
+  simp only [ToricSpace.SmallDrift, driftMatrix_positiveTwist]
+  rfl
+
+private theorem CuspPositive.smallDrift_positiveTwist (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {ε : ℝ}
+    (hR : ToricSpace.SmallDrift (fun _ => C₀) ε) : ToricSpace.SmallDrift (positiveTwist C₀) ε :=
+  (smallDrift_positiveTwist_iff C₀ ε).mpr hR
+
+private theorem
+    CuspPositive.exponentialMultiplier_positiveTwist_eq_norm (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) (t : ℂ) (i : Fin 2) :
+    (ToricSpace.exponentialMultiplier (positiveTwist C₀) v t i : ℂ) =
+      (‖(ToricSpace.exponentialMultiplier (fun _ => C₀) v 0 i : ℂ)‖ : ℂ) := by
+  simp only [ToricSpace.exponentialMultiplier, Units.val_mk0, Complex.norm_exp,
+    Complex.ofReal_exp]
+  congr 1
+  apply Complex.ext <;>
+    simp [positiveTwist, Matrix.mulVec, dotProduct, Fin.sum_univ_two, Complex.mul_re,
+      Complex.mul_im]
+
+private theorem
+    CuspPositive.exponentialMultiplier_positiveTwist_norm (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) (t : ℂ) (i : Fin 2) :
+    ‖(ToricSpace.exponentialMultiplier (positiveTwist C₀) v t i : ℂ)‖ =
+      ‖(ToricSpace.exponentialMultiplier (fun _ => C₀) v 0 i : ℂ)‖ := by
+  rw [exponentialMultiplier_positiveTwist_eq_norm]
+  simp
+
+private theorem CuspPositive.exponentialMultiplier_positiveTwist_ofReal_norm
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ) (t : ℂ) (i : Fin 2) :
+    (‖(ToricSpace.exponentialMultiplier (positiveTwist C₀) v t i : ℂ)‖ : ℂ) =
+      (ToricSpace.exponentialMultiplier (positiveTwist C₀) v t i : ℂ) := by
+  rw [exponentialMultiplier_positiveTwist_norm, exponentialMultiplier_positiveTwist_eq_norm]
+
+private theorem
+    CuspPositive.fibreMultiplier_positiveTwist_ofReal_norm (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) (t : ℂ) (i : Fin 3) :
+    (‖(ToricSpace.fibreMultiplier (ToricSpace.exponentialMultiplier (positiveTwist C₀) v t) i :
+            ℂ)‖ :
+        ℂ) =
+      (ToricSpace.fibreMultiplier (ToricSpace.exponentialMultiplier (positiveTwist C₀) v t) i :
+        ℂ) := by
+  fin_cases i
+  · exact exponentialMultiplier_positiveTwist_ofReal_norm C₀ v t 0
+  · exact exponentialMultiplier_positiveTwist_ofReal_norm C₀ v t 1
+  · simp [ToricSpace.fibreMultiplier]
+
+@[simp]
+private theorem CuspPositive.modulus_translate (v : Fin 2 → ℤ) (x : ToricSpace.Space) :
+    ToricSpace.modulus (ToricSpace.translate v x) =
+      ToricSpace.translate v (ToricSpace.modulus x) := by
+  obtain ⟨s, z, rfl⟩ := ToricSpace.inclusion_jointly_surjective x
+  simp only [ToricSpace.translate_inclusion, ToricSpace.modulus_inclusion]
+
+private theorem CuspPositive.coordinateModulus_mul {d : ℕ} (z w : ToricCharts.CoordinateSpace d) :
+    ToricCharts.coordinateModulus (z * w) =
+      ToricCharts.coordinateModulus z * ToricCharts.coordinateModulus w := by
+  funext i
+  simp [ToricCharts.coordinateModulus]
+
+private theorem CuspPositive.coordinateModulus_factors_of_nonnegative (s : ToricFan.Triangle)
+    (u : ToricSpace.ActingTorus) (hu : ∀ i, (‖(u i : ℂ)‖ : ℂ) = (u i : ℂ)) :
+    ToricCharts.coordinateModulus (ToricSpace.factors s u) = ToricSpace.factors s u := by
+  change ToricCharts.coordinateModulus (ToricCharts.monomial s.dual (fun i => (u i : ℂ))) = _
+  rw [← ToricCharts.monomial_coordinateModulus]
+  have he : ToricCharts.coordinateModulus (fun i => (u i : ℂ)) = fun i => (u i : ℂ) := by
+    funext i
+    exact hu i
+  rw [he]
+  rfl
+
+private theorem CuspPositive.coordinateModulus_scale_of_nonnegative (s : ToricFan.Triangle)
+    (u : ToricSpace.ActingTorus) (hu : ∀ i, (‖(u i : ℂ)‖ : ℂ) = (u i : ℂ))
+    (z : ToricCharts.CoordinateSpace 3) :
+    ToricCharts.coordinateModulus (ToricSpace.scale s u z) =
+      ToricSpace.scale s u (ToricCharts.coordinateModulus z) := by
+  rw [ToricSpace.scale, coordinateModulus_mul, coordinateModulus_factors_of_nonnegative s u hu]
+  rfl
+
+private theorem CuspPositive.modulus_torusAction_of_nonnegative (u : ToricSpace.ActingTorus)
+    (hu : ∀ i, (‖(u i : ℂ)‖ : ℂ) = (u i : ℂ)) (x : ToricSpace.Space) :
+    ToricSpace.modulus (ToricSpace.torusAction u x) =
+      ToricSpace.torusAction u (ToricSpace.modulus x) := by
+  obtain ⟨s, z, rfl⟩ := ToricSpace.inclusion_jointly_surjective x
+  simp only [ToricSpace.torusAction_inclusion, ToricSpace.modulus_inclusion,
+    coordinateModulus_scale_of_nonnegative s u hu]
+
+private theorem CuspPositive.twistedTranslate_positiveTwist_eq (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) (x : ToricSpace.Space) :
+    ToricSpace.twistedTranslate (positiveTwist C₀) v x =
+      ToricSpace.torusAction
+        (ToricSpace.fibreMultiplier (ToricSpace.exponentialMultiplier (positiveTwist C₀) v 0))
+        (ToricSpace.translate (ToricSpace.cuspVector v) x) :=
+  rfl
+
+private theorem CuspPositive.modulus_twistedTranslate_positiveTwist (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) (x : ToricSpace.Space) :
+    ToricSpace.modulus (ToricSpace.twistedTranslate (positiveTwist C₀) v x) =
+      ToricSpace.twistedTranslate (positiveTwist C₀) v (ToricSpace.modulus x) := by
+  rw [twistedTranslate_positiveTwist_eq,
+    modulus_torusAction_of_nonnegative _ (fibreMultiplier_positiveTwist_ofReal_norm C₀ v 0),
+    modulus_translate, twistedTranslate_positiveTwist_eq]
+
+private theorem CuspPositive.twistedTranslate_positiveTwist_preserves_positivePart
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ) :
+    Set.MapsTo (ToricSpace.twistedTranslate (positiveTwist C₀) v) ToricSpace.positivePart
+      ToricSpace.positivePart := by
+  intro x hx
+  change ToricSpace.modulus (ToricSpace.twistedTranslate (positiveTwist C₀) v x) = _
+  rw [modulus_twistedTranslate_positiveTwist]
+  exact congrArg (ToricSpace.twistedTranslate (positiveTwist C₀) v) hx
+
+@[simp]
+private theorem CuspPositive.twistedTranslate_positiveTwist_mem_positivePart_iff
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ) (x : ToricSpace.Space) :
+    ToricSpace.twistedTranslate (positiveTwist C₀) v x ∈ ToricSpace.positivePart ↔
+      x ∈ ToricSpace.positivePart := by
+  constructor
+  · intro hx
+    have h := twistedTranslate_positiveTwist_preserves_positivePart C₀ (-v) hx
+    simpa only [ToricSpace.twistedTranslate_add, neg_add_cancel,
+      ToricSpace.twistedTranslate_zero] using h
+  · intro hx
+    exact twistedTranslate_positiveTwist_preserves_positivePart C₀ v hx
+
+private abbrev CuspPositive.LatticeGroup :=
+  CuspQuotient.LatticeGroup
+
+private def CuspPositive.positiveTubeSet (ε : ℝ) : Set (ToricSpace.Tube (CuspQuotient.disc ε)) :=
+  Subtype.val ⁻¹' ToricSpace.positivePart
+
+private abbrev CuspPositive.PositiveTube (ε : ℝ) :=
+  positiveTubeSet ε
+
+private theorem CuspPositive.positiveTubeSet_isClosed (ε : ℝ) : IsClosed (positiveTubeSet ε) :=
+  ToricSpace.positivePart_isClosed.preimage continuous_subtype_val
+
+private instance CuspPositive.positiveTube_locallyCompactSpace (ε : ℝ) :
+    LocallyCompactSpace (PositiveTube ε) :=
+  (positiveTubeSet_isClosed ε).locallyCompactSpace
+
+private def
+    CuspPositive.positiveTubeToPositive (ε : ℝ) (x : PositiveTube ε) : ToricSpace.PositivePart :=
+  ⟨(x.1 : ToricSpace.Space), x.2⟩
+
+private theorem CuspPositive.positiveTube_norm_time_lt (ε : ℝ) (x : PositiveTube ε) :
+    ‖ToricSpace.time (x.1 : ToricSpace.Space)‖ < ε := by
+  have hx : ToricSpace.time (x.1 : ToricSpace.Space) ∈ Metric.ball 0 ε := x.1.2
+  simpa only [Metric.mem_ball, dist_zero_right] using hx
+
+private def CuspPositive.positiveTubeHomeomorph (ε : ℝ) :
+    PositiveTube ε ≃ₜ
+      { x : ToricSpace.PositivePart // ‖ToricSpace.time (x : ToricSpace.Space)‖ < ε }
+    where
+  toFun x := ⟨positiveTubeToPositive ε x, positiveTube_norm_time_lt ε x⟩
+  invFun
+    x :=
+    ⟨⟨(x.1 : ToricSpace.Space),
+        by
+        change ToricSpace.time (x.1 : ToricSpace.Space) ∈ Metric.ball 0 ε
+        simpa only [Metric.mem_ball, dist_zero_right] using x.2⟩,
+      x.1.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun :=
+    ((continuous_subtype_val.comp continuous_subtype_val).subtype_mk _).subtype_mk _
+  continuous_invFun :=
+    ((continuous_subtype_val.comp continuous_subtype_val).subtype_mk _).subtype_mk _
+
+private def
+    CuspPositive.positiveTubeTranslate (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (v : Fin 2 → ℤ)
+    (x : PositiveTube ε) : PositiveTube ε :=
+  ⟨ToricSpace.tubeTranslate (positiveTwist C₀) (CuspQuotient.disc ε) v x.1,
+    (twistedTranslate_positiveTwist_mem_positivePart_iff C₀ v (x.1 : ToricSpace.Space)).mpr x.2⟩
+
+@[instance_reducible]
+private def CuspPositive.positiveAction (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    MulAction LatticeGroup (PositiveTube ε)
+    where
+  smul g x := positiveTubeTranslate C₀ ε g.toAdd x
+  one_smul
+    x := by
+    apply Subtype.ext
+    apply Subtype.ext
+    exact ToricSpace.twistedTranslate_zero (positiveTwist C₀) (x.1 : ToricSpace.Space)
+  mul_smul g h
+    x := by
+    apply Subtype.ext
+    apply Subtype.ext
+    exact
+      (ToricSpace.twistedTranslate_add (positiveTwist C₀) g.toAdd h.toAdd
+          (x.1 : ToricSpace.Space)).symm
+
+private theorem CuspPositive.positiveAction_compatible (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    letI := ToricSpace.tubeAction (positiveTwist C₀) (CuspQuotient.disc ε)
+    letI := positiveAction C₀ ε
+    ∀ (g : LatticeGroup) (x : PositiveTube ε), (g • x).1 = g • x.1 := by
+  intros
+  rfl
+
+private theorem CuspPositive.positiveAction_continuous (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    letI := positiveAction C₀ ε
+    ContinuousConstSMul LatticeGroup (PositiveTube ε) := by
+  let := positiveAction C₀ ε
+  constructor
+  intro g
+  exact
+    ((ToricSpace.tubeTranslate_holomorphic (positiveTwist C₀) (CuspQuotient.disc ε) g.toAdd
+              (fun i j => (positiveTwist_holomorphic C₀ i j).contDiffOn)).continuous.comp
+          continuous_subtype_val).subtype_mk
+      _
+
+private theorem
+    CuspPositive.positiveAction_free (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (positiveTwist C₀) ε) :
+    letI := positiveAction C₀ ε
+    IsCancelSMul LatticeGroup (PositiveTube ε) := by
+  let := ToricSpace.tubeAction (positiveTwist C₀) (CuspQuotient.disc ε)
+  let :=
+    CuspQuotient.free_action (positiveTwist C₀) ε hε hε1
+      (fun i j => (positiveTwist_holomorphic C₀ i j).contDiffOn) hR
+  let := positiveAction C₀ ε
+  constructor
+  intro g h x he
+  exact IsCancelSMul.right_cancel g h x.1 (congrArg Subtype.val he)
+
+private theorem
+    CuspPositive.positiveAction_properlyDiscontinuous (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (positiveTwist C₀) ε) :
+    letI := positiveAction C₀ ε
+    ProperlyDiscontinuousSMul LatticeGroup (PositiveTube ε) := by
+  let := ToricSpace.tubeAction (positiveTwist C₀) (CuspQuotient.disc ε)
+  let :=
+    CuspQuotient.proper_action (positiveTwist C₀) ε hε hε1
+      (fun i j => (positiveTwist_holomorphic C₀ i j).contDiffOn) hR
+  let := positiveAction C₀ ε
+  constructor
+  intro K L hK hL
+  have hf :=
+    ProperlyDiscontinuousSMul.finite_disjoint_inter_image (Γ := LatticeGroup)
+      (hK.image continuous_subtype_val) (hL.image continuous_subtype_val)
+  apply hf.subset
+  rintro g ⟨z, ⟨y, hy, rfl⟩, hz⟩
+  refine ⟨(g • y).1, ⟨y.1, ⟨y, hy, rfl⟩, rfl⟩, ?_⟩
+  exact ⟨g • y, hz, rfl⟩
+
+private def
+    CuspPositive.relation (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) : Setoid (PositiveTube ε) :=
+  let := positiveAction C₀ ε
+  MulAction.orbitRel LatticeGroup (PositiveTube ε)
+
+private abbrev CuspPositive.QuotientSpace (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :=
+  Quotient (relation C₀ ε)
+
+private def CuspPositive.project (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    PositiveTube ε → QuotientSpace C₀ ε :=
+  Quotient.mk (relation C₀ ε)
+
+private theorem CuspPositive.project_surjective (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    Function.Surjective (project C₀ ε) :=
+  Quotient.mk_surjective
+
+@[simp]
+private theorem
+    CuspPositive.project_translate (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (v : Fin 2 → ℤ)
+    (x : PositiveTube ε) : project C₀ ε (positiveTubeTranslate C₀ ε v x) = project C₀ ε x := by
+  let := positiveAction C₀ ε
+  exact MulAction.orbitRel.Quotient.quotient_smul_eq (g := Multiplicative.ofAdd v) (a := x)
+
+private theorem CuspPositive.project_covering (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (positiveTwist C₀) ε) :
+    letI := positiveAction C₀ ε
+    IsQuotientCoveringMap (project C₀ ε) LatticeGroup := by
+  let := positiveAction C₀ ε
+  let := positiveAction_continuous C₀ ε
+  let := positiveAction_free C₀ ε hε hε1 hR
+  let := positiveAction_properlyDiscontinuous C₀ ε hε hε1 hR
+  exact isQuotientCoveringMap_quotientMk_of_properlyDiscontinuousSMul
+
+private theorem CuspPositive.quotient_t2Space (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (positiveTwist C₀) ε) :
+    T2Space (QuotientSpace C₀ ε) := by
+  let := positiveAction C₀ ε
+  let := positiveAction_continuous C₀ ε
+  let := positiveAction_properlyDiscontinuous C₀ ε hε hε1 hR
+  change T2Space (Quotient (MulAction.orbitRel LatticeGroup (PositiveTube ε)))
+  infer_instance
+
+private def CuspPositive.quotientInclusion (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    QuotientSpace C₀ ε → CuspQuotient.QuotientSpace (positiveTwist C₀) ε :=
+  Quotient.lift (fun x : PositiveTube ε => CuspQuotient.quotientMap (positiveTwist C₀) ε x.1)
+    (by
+      let := positiveAction C₀ ε
+      intro x y h
+      change x ∈ MulAction.orbit LatticeGroup y at h
+      obtain ⟨g, rfl⟩ := h
+      exact CuspQuotient.quotientMap_translate (positiveTwist C₀) ε g.toAdd y.1)
+
+private theorem CuspPositive.quotientInclusion_continuous (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    Continuous (quotientInclusion C₀ ε) :=
+  ((CuspQuotient.quotientMap_continuous (positiveTwist C₀) ε).comp
+        continuous_subtype_val).quotient_lift
+    _
+
+private def
+    CuspPositive.height (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (x : QuotientSpace C₀ ε) : ℝ :=
+  ‖CuspQuotient.projection (positiveTwist C₀) ε (quotientInclusion C₀ ε x)‖
+
+@[simp]
+private theorem
+    CuspPositive.height_project (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (x : PositiveTube ε) :
+    height C₀ ε (project C₀ ε x) = ‖ToricSpace.time (x.1 : ToricSpace.Space)‖ :=
+  rfl
+
+private theorem CuspPositive.height_continuous (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    Continuous (height C₀ ε) :=
+  ((CuspQuotient.projection_continuous (positiveTwist C₀) ε).comp
+      (quotientInclusion_continuous C₀ ε)).norm
+
+private theorem CuspPositive.height_nonneg (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (x : QuotientSpace C₀ ε) : 0 ≤ height C₀ ε x :=
+  norm_nonneg _
+
+private def CuspPositive.positiveImage (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    Set (CuspQuotient.QuotientSpace (positiveTwist C₀) ε) :=
+  CuspQuotient.quotientMap (positiveTwist C₀) ε '' positiveTubeSet ε
+
+private theorem
+    CuspPositive.positiveImage_isClosed (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (positiveTwist C₀) ε) :
+    IsClosed (positiveImage C₀ ε) := by
+  let := ToricSpace.tubeAction (positiveTwist C₀) (CuspQuotient.disc ε)
+  let := positiveAction C₀ ε
+  exact
+    InvariantSubsetQuotient.isClosed_image
+      (CuspQuotient.quotientMap_covering (positiveTwist C₀) ε hε hε1
+        (fun i j => (positiveTwist_holomorphic C₀ i j).contDiffOn) hR)
+      (positiveAction_compatible C₀ ε) (positiveTubeSet_isClosed ε)
+
+private def CuspPositive.quotientHomeomorph (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (positiveTwist C₀) ε) :
+    QuotientSpace C₀ ε ≃ₜ positiveImage C₀ ε := by
+  letI := ToricSpace.tubeAction (positiveTwist C₀) (CuspQuotient.disc ε)
+  letI := positiveAction C₀ ε
+  exact
+    InvariantSubsetQuotient.quotientHomeomorph
+      (CuspQuotient.quotientMap_covering (positiveTwist C₀) ε hε hε1
+        (fun i j => (positiveTwist_holomorphic C₀ i j).contDiffOn) hR)
+      (positiveAction_compatible C₀ ε)
+
+private theorem
+    CuspPositive.quotientHomeomorph_coe (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (positiveTwist C₀) ε) (x : QuotientSpace C₀ ε) :
+    (quotientHomeomorph C₀ ε hε hε1 hR x : CuspQuotient.QuotientSpace (positiveTwist C₀) ε) =
+      quotientInclusion C₀ ε x := by
+  obtain ⟨y, rfl⟩ := project_surjective C₀ ε x
+  rfl
+
+private theorem
+    CuspPositive.quotientInclusion_isClosedEmbedding (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (positiveTwist C₀) ε) :
+    Topology.IsClosedEmbedding (quotientInclusion C₀ ε) := by
+  have h :=
+    (positiveImage_isClosed C₀ ε hε hε1 hR).isClosedEmbedding_subtypeVal.comp
+      (quotientHomeomorph C₀ ε hε hε1 hR).isClosedEmbedding
+  have he : Subtype.val ∘ quotientHomeomorph C₀ ε hε hε1 hR = quotientInclusion C₀ ε :=
+    funext (quotientHomeomorph_coe C₀ ε hε hε1 hR)
+  rw [he] at h
+  exact h
+
+private theorem CuspPositive.height_sublevel_isCompact (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (positiveTwist C₀) ε) {η : ℝ}
+    (hηε : η < ε) : IsCompact {x : QuotientSpace C₀ ε | height C₀ ε x ≤ η} := by
+  obtain ⟨τ, hτ, hτε⟩ := exists_between (max_lt hηε hε)
+  have hτ0 : 0 < τ := (le_max_right η 0).trans_lt hτ
+  have hcompact :=
+    CuspQuotient.closedDisc_preimage_compact (positiveTwist C₀) ε hε hε1
+      (fun i j => (positiveTwist_holomorphic C₀ i j).contDiffOn) hR hτ0 hτε
+  have hpre :=
+    (quotientInclusion_isClosedEmbedding C₀ ε hε hε1 hR).isProperMap |>.isCompact_preimage
+      hcompact
+  apply hpre.of_isClosed_subset (isClosed_le (height_continuous C₀ ε) continuous_const)
+  intro x hx
+  change
+    CuspQuotient.projection (positiveTwist C₀) ε (quotientInclusion C₀ ε x) ∈
+      Metric.closedBall 0 τ
+  rw [Metric.mem_closedBall, dist_zero_right]
+  exact hx.trans ((le_max_left η 0).trans hτ.le)
+
+private def CuspPositive.orthantComplexHomeomorph :
+    CuspPositiveRetraction.Orthant ≃ₜ
+      (ToricCharts.nonnegativeCoordinates : Set (ToricCharts.CoordinateSpace 3))
+    where
+  toFun r := ⟨fun i => (r.1 i : ℂ), ⟨r.1, r.2, rfl⟩⟩
+  invFun
+    z :=
+    ⟨fun i => (z.1 i).re, by
+      obtain ⟨r, hr, hz⟩ := z.2
+      intro i
+      rw [hz]
+      exact hr i⟩
+  left_inv
+    r := by
+    apply Subtype.ext
+    rfl
+  right_inv
+    z := by
+    apply Subtype.ext
+    obtain ⟨r, hr, hz⟩ := z.2
+    simp only [hz, Complex.ofReal_re]
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    exact
+      continuous_pi fun i =>
+        Complex.continuous_ofReal.comp ((continuous_apply i).comp continuous_subtype_val)
+  continuous_invFun := by
+    apply Continuous.subtype_mk
+    exact
+      continuous_pi fun i =>
+        Complex.continuous_re.comp ((continuous_apply i).comp continuous_subtype_val)
+
+private theorem CuspPositive.inclusion_preimage_positivePart (s : ToricFan.Triangle) :
+    ToricSpace.inclusion s ⁻¹' ToricSpace.positivePart =
+      (ToricCharts.nonnegativeCoordinates : Set (ToricCharts.CoordinateSpace 3)) := by
+  ext z
+  exact ToricSpace.inclusion_mem_positivePart_iff s z
+
+private def
+    CuspPositive.positiveInclusion (s : ToricFan.Triangle) (r : CuspPositiveRetraction.Orthant) :
+    ToricSpace.PositivePart :=
+  ⟨ToricSpace.inclusion s (fun i => (r.1 i : ℂ)),
+    (ToricSpace.inclusion_mem_positivePart_iff s _).mpr ⟨r.1, r.2, rfl⟩⟩
+
+private theorem CuspPositive.positiveInclusion_openEmbedding (s : ToricFan.Triangle) :
+    Topology.IsOpenEmbedding (positiveInclusion s) := by
+  let e :
+    CuspPositiveRetraction.Orthant ≃ₜ (ToricSpace.inclusion s ⁻¹' ToricSpace.positivePart) :=
+    orthantComplexHomeomorph.trans (Homeomorph.setCongr (inclusion_preimage_positivePart s).symm)
+  have h :
+    Topology.IsOpenEmbedding
+      ((ToricSpace.positivePart.restrictPreimage (ToricSpace.inclusion s)) ∘ e) :=
+    ((ToricSpace.inclusion_openEmbedding s).restrictPreimage ToricSpace.positivePart).comp
+      e.isOpenEmbedding
+  have he :
+    ((ToricSpace.positivePart.restrictPreimage (ToricSpace.inclusion s)) ∘ e) =
+      positiveInclusion s := by
+    funext r
+    apply Subtype.ext
+    rfl
+  rwa [he] at h
+
+private def CuspPositive.positiveParametrization (s : ToricFan.Triangle) :
+    OpenPartialHomeomorph CuspPositiveRetraction.Orthant ToricSpace.PositivePart := by
+  letI : Nonempty CuspPositiveRetraction.Orthant := ⟨⟨fun _ => 0, fun _ => le_rfl⟩⟩
+  exact (positiveInclusion_openEmbedding s).toOpenPartialHomeomorph (positiveInclusion s)
+
+@[simp]
+private theorem CuspPositive.positiveParametrization_apply (s : ToricFan.Triangle)
+    (r : CuspPositiveRetraction.Orthant) : positiveParametrization s r = positiveInclusion s r :=
+  rfl
+
+@[simp]
+private theorem CuspPositive.positiveParametrization_target (s : ToricFan.Triangle) :
+    (positiveParametrization s).target = Set.range (positiveInclusion s) := by
+  simp [positiveParametrization]
+
+private theorem CuspPositive.positiveInclusion_positiveParametrization_symm (s : ToricFan.Triangle)
+    {x : ToricSpace.PositivePart} (hx : x ∈ Set.range (positiveInclusion s)) :
+    positiveInclusion s ((positiveParametrization s).symm x) = x := by
+  have h :=
+    (positiveParametrization s).right_inv
+      (show x ∈ (positiveParametrization s).target by
+        simpa only [positiveParametrization_target] using hx)
+  simpa only [positiveParametrization_apply] using h
+
+@[simp]
+private theorem CuspPositive.time_positiveInclusion (s : ToricFan.Triangle)
+    (r : CuspPositiveRetraction.Orthant) :
+    ToricSpace.time (positiveInclusion s r : ToricSpace.Space) =
+      (CuspPositiveRetraction.height r : ℂ) := by
+  simp [positiveInclusion, ToricFan.Triangle.time, CuspPositiveRetraction.height,
+    Fin.prod_univ_succ, mul_assoc]
+
+private theorem CuspPositive.norm_time_positiveInclusion (s : ToricFan.Triangle)
+    (r : CuspPositiveRetraction.Orthant) :
+    ‖ToricSpace.time (positiveInclusion s r : ToricSpace.Space)‖ =
+      CuspPositiveRetraction.height r := by
+  rw [time_positiveInclusion]
+  exact Complex.norm_of_nonneg (CuspPositiveRetraction.height_nonneg r)
+
+private theorem CuspPositive.positiveInclusion_jointly_surjective (x : ToricSpace.PositivePart) :
+    ∃ s r, positiveInclusion s r = x := by
+  obtain ⟨s, z, hz⟩ := ToricSpace.inclusion_jointly_surjective (x : ToricSpace.Space)
+  have hp : ToricSpace.inclusion s z ∈ ToricSpace.positivePart := hz.symm ▸ x.property
+  obtain ⟨r, hr, he⟩ := (ToricSpace.inclusion_mem_positivePart_iff s z).mp hp
+  refine ⟨s, ⟨r, hr⟩, ?_⟩
+  apply Subtype.ext
+  change ToricSpace.inclusion s (fun i => (r i : ℂ)) = (x : ToricSpace.Space)
+  rw [← he]
+  exact hz
+
+private def
+    CuspPositive.positiveOpenTube (ε : ℝ) : TopologicalSpace.Opens ToricSpace.PositivePart :=
+  ⟨{x | ‖ToricSpace.time (x : ToricSpace.Space)‖ < ε},
+    isOpen_lt (ToricSpace.time_holomorphic.continuous.comp continuous_subtype_val).norm
+      continuous_const⟩
+
+private def
+    CuspPositive.positiveTubeOpenHomeomorph (ε : ℝ) : PositiveTube ε ≃ₜ positiveOpenTube ε :=
+  positiveTubeHomeomorph ε
+
+private theorem CuspPositive.positiveOpenTube_nonempty (ε : ℝ) (hε : 0 < ε) :
+    Nonempty (positiveOpenTube ε) := by
+  refine ⟨⟨positiveInclusion ToricSpace.referenceTriangle ⟨0, fun _ => le_rfl⟩, ?_⟩⟩
+  change
+    ‖ToricSpace.time
+          (positiveInclusion ToricSpace.referenceTriangle ⟨0, fun _ => le_rfl⟩ :
+            ToricSpace.Space)‖ <
+      ε
+  rw [norm_time_positiveInclusion]
+  simpa [CuspPositiveRetraction.height] using hε
+
+private def CuspPositive.positiveTubeChart (ε : ℝ) (hε : 0 < ε) (s : ToricFan.Triangle) :
+    OpenPartialHomeomorph (PositiveTube ε) CuspPositiveRetraction.Orthant :=
+  (positiveTubeOpenHomeomorph ε).toOpenPartialHomeomorph.trans
+    ((positiveParametrization s).symm.subtypeRestr (positiveOpenTube_nonempty ε hε))
+
+@[simp]
+private theorem CuspPositive.positiveTubeChart_apply (ε : ℝ) (hε : 0 < ε) (s : ToricFan.Triangle)
+    (x : PositiveTube ε) :
+    positiveTubeChart ε hε s x = (positiveParametrization s).symm (positiveTubeToPositive ε x) :=
+  rfl
+
+private theorem CuspPositive.positiveTubeChart_source (ε : ℝ) (hε : 0 < ε) (s : ToricFan.Triangle) :
+    (positiveTubeChart ε hε s).source =
+      {x | positiveTubeToPositive ε x ∈ Set.range (positiveInclusion s)} := by
+  unfold positiveTubeChart
+  rw [OpenPartialHomeomorph.trans_source, OpenPartialHomeomorph.subtypeRestr_source]
+  ext x
+  change (x ∈ Set.univ ∧ positiveTubeToPositive ε x ∈ (positiveParametrization s).target) ↔ _
+  simp only [Set.mem_univ, true_and, positiveParametrization_target, Set.mem_ofPred_eq]
+
+private theorem
+    CuspPositive.exists_positiveTubeChart_source (ε : ℝ) (hε : 0 < ε) (x : PositiveTube ε) :
+    ∃ s : ToricFan.Triangle, x ∈ (positiveTubeChart ε hε s).source := by
+  obtain ⟨s, r, hr⟩ := positiveInclusion_jointly_surjective (positiveTubeToPositive ε x)
+  refine ⟨s, ?_⟩
+  rw [positiveTubeChart_source]
+  exact ⟨r, hr⟩
+
+private theorem
+    CuspPositive.positiveTubeChart_symm_positive (ε : ℝ) (hε : 0 < ε) (s : ToricFan.Triangle)
+    {r : CuspPositiveRetraction.Orthant} (hr : r ∈ (positiveTubeChart ε hε s).target) :
+    positiveTubeToPositive ε ((positiveTubeChart ε hε s).symm r) = positiveInclusion s r := by
+  have hx := (positiveTubeChart ε hε s).map_target hr
+  rw [positiveTubeChart_source] at hx
+  have he := positiveInclusion_positiveParametrization_symm s hx
+  have hinv := (positiveTubeChart ε hε s).right_inv hr
+  rw [positiveTubeChart_apply] at hinv
+  rw [hinv] at he
+  exact he.symm
+
+private theorem
+    CuspPositive.positiveTubeChart_height_symm (ε : ℝ) (hε : 0 < ε) (s : ToricFan.Triangle)
+    {r : CuspPositiveRetraction.Orthant} (hr : r ∈ (positiveTubeChart ε hε s).target) :
+    ‖ToricSpace.time (((positiveTubeChart ε hε s).symm r).1 : ToricSpace.Space)‖ =
+      CuspPositiveRetraction.height r := by
+  have h :=
+    congrArg (fun x : ToricSpace.PositivePart => ‖ToricSpace.time (x : ToricSpace.Space)‖)
+      (positiveTubeChart_symm_positive ε hε s hr)
+  exact h.trans (norm_time_positiveInclusion s r)
+
+private theorem CuspPositive.positiveTubeChart_height (ε : ℝ) (hε : 0 < ε) (s : ToricFan.Triangle)
+    {x : PositiveTube ε} (hx : x ∈ (positiveTubeChart ε hε s).source) :
+    ‖ToricSpace.time (x.1 : ToricSpace.Space)‖ =
+      CuspPositiveRetraction.height (positiveTubeChart ε hε s x) := by
+  have h := positiveTubeChart_height_symm ε hε s ((positiveTubeChart ε hε s).map_source hx)
+  rwa [(positiveTubeChart ε hε s).left_inv hx] at h
+
+private def
+    CuspPositive.quotientChart (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (positiveTwist C₀) ε) (a : PositiveTube ε)
+    (s : ToricFan.Triangle) :
+    OpenPartialHomeomorph (QuotientSpace C₀ ε) CuspPositiveRetraction.Orthant :=
+  letI := positiveAction C₀ ε
+  CoveringOrthant.localChart (project_covering C₀ ε hε hε1 hR) (positiveTubeChart ε hε s) a
+
+private theorem
+    CuspPositive.quotientChart_mem_source (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (positiveTwist C₀) ε) (a : PositiveTube ε)
+    (s : ToricFan.Triangle) (ha : a ∈ (positiveTubeChart ε hε s).source) :
+    project C₀ ε a ∈ (quotientChart C₀ ε hε hε1 hR a s).source := by
+  let := positiveAction C₀ ε
+  exact
+    CoveringOrthant.self_mem_localChart_source (project_covering C₀ ε hε hε1 hR)
+      (positiveTubeChart ε hε s) a ha
+
+private theorem CuspPositive.quotientChart_height_symm (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (positiveTwist C₀) ε)
+    (a : PositiveTube ε) (s : ToricFan.Triangle) {r : CuspPositiveRetraction.Orthant}
+    (hr : r ∈ (quotientChart C₀ ε hε hε1 hR a s).target) :
+    height C₀ ε ((quotientChart C₀ ε hε hε1 hR a s).symm r) = CuspPositiveRetraction.height r := by
+  let := positiveAction C₀ ε
+  apply
+    CoveringOrthant.localChart_coordinate_identity (project_covering C₀ ε hε hε1 hR)
+      (positiveTubeChart ε hε s) a (height C₀ ε) CuspPositiveRetraction.height ?_ r hr
+  intro x hx
+  rw [height_project]
+  exact positiveTubeChart_height ε hε s hx
+
+private theorem
+    CuspPositive.exists_quotientChart (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (positiveTwist C₀) ε) (x : QuotientSpace C₀ ε) :
+    ∃ e : OpenPartialHomeomorph (QuotientSpace C₀ ε) CuspPositiveRetraction.Orthant,
+      x ∈ e.source ∧ ∀ r ∈ e.target, height C₀ ε (e.symm r) = CuspPositiveRetraction.height r := by
+  obtain ⟨a, ha⟩ := project_surjective C₀ ε x
+  obtain ⟨s, hs⟩ := exists_positiveTubeChart_source ε hε a
+  refine ⟨quotientChart C₀ ε hε hε1 hR a s, ?_, ?_⟩
+  · rw [← ha]
+    exact quotientChart_mem_source C₀ ε hε hε1 hR a s hs
+  · intro r hr
+    exact quotientChart_height_symm C₀ ε hε hε1 hR a s hr
+
+private def CuspPositive.frozenPhaseCoordinate (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ)
+    (i : Fin 2) : Circle :=
+  ⟨(ToricSpace.exponentialMultiplier (fun _ => C₀) v 0 i : ℂ) /
+      (ToricSpace.exponentialMultiplier (positiveTwist C₀) v 0 i : ℂ),
+    by
+    apply mem_sphere_zero_iff_norm.mpr
+    rw [norm_div, exponentialMultiplier_positiveTwist_norm]
+    exact
+      div_self
+        (norm_ne_zero_iff.mpr (ToricSpace.exponentialMultiplier (fun _ => C₀) v 0 i).ne_zero)⟩
+
+@[simp]
+private theorem
+    CuspPositive.frozenPhaseCoordinate_coe (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ)
+    (i : Fin 2) :
+    (frozenPhaseCoordinate C₀ v i : ℂ) =
+      (ToricSpace.exponentialMultiplier (fun _ => C₀) v 0 i : ℂ) /
+        (ToricSpace.exponentialMultiplier (positiveTwist C₀) v 0 i : ℂ) :=
+  rfl
+
+private theorem
+    CuspPositive.frozenPhaseCoordinate_eq_exp (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ)
+    (i : Fin 2) :
+    frozenPhaseCoordinate C₀ v i =
+      Circle.exp (2 * Real.pi * ((C₀ *ᵥ (fun j => (v j : ℂ))) i).re) := by
+  apply Circle.ext
+  simp only [frozenPhaseCoordinate_coe, Circle.coe_exp, ToricSpace.exponentialMultiplier,
+    Units.val_mk0, ← Complex.exp_sub]
+  congr 1
+  apply Complex.ext <;>
+    simp [positiveTwist, Matrix.mulVec, dotProduct, Fin.sum_univ_two, Complex.mul_re,
+      Complex.mul_im]
+
+private def CuspPositive.frozenPhase (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ) :
+    ToricSpace.CompactTorus :=
+  ![frozenPhaseCoordinate C₀ v 0, frozenPhaseCoordinate C₀ v 1, 1]
+
+private theorem CuspPositive.compactTorusUnits_frozenPhase (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) :
+    ToricSpace.compactTorusUnits (frozenPhase C₀ v) =
+      ToricSpace.fibreMultiplier
+        (ToricSpace.exponentialMultiplier (fun _ => C₀) v 0 /
+          ToricSpace.exponentialMultiplier (positiveTwist C₀) v 0) := by
+  funext i
+  apply Units.ext
+  fin_cases i <;> simp [frozenPhase, ToricSpace.fibreMultiplier]
+
+private theorem CuspPositive.frozenMultiplier_phase_positive (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) :
+    ToricSpace.fibreMultiplier (ToricSpace.exponentialMultiplier (fun _ => C₀) v 0) =
+      ToricSpace.compactTorusUnits (frozenPhase C₀ v) *
+        ToricSpace.fibreMultiplier (ToricSpace.exponentialMultiplier (positiveTwist C₀) v 0) := by
+  rw [compactTorusUnits_frozenPhase, ← ToricSpace.fibreMultiplier_mul, div_mul_cancel]
+
+private theorem
+    CuspPositive.twistedTranslate_constant_eq (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ)
+    (x : ToricSpace.Space) :
+    ToricSpace.twistedTranslate (fun _ => C₀) v x =
+      ToricSpace.torusAction
+        (ToricSpace.fibreMultiplier (ToricSpace.exponentialMultiplier (fun _ => C₀) v 0))
+        (ToricSpace.translate (ToricSpace.cuspVector v) x) :=
+  rfl
+
+private def CuspPositive.phaseTransform (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ)
+    (u : ToricSpace.CompactTorus) : ToricSpace.CompactTorus :=
+  frozenPhase C₀ v * ToricSpace.phaseShear (ToricSpace.cuspVector v) u
+
+private theorem CuspPositive.twistedTranslate_constant_polar (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) (u : ToricSpace.CompactTorus) (x : ToricSpace.Space) :
+    ToricSpace.twistedTranslate (fun _ => C₀) v (ToricSpace.compactTorusAction u x) =
+      ToricSpace.compactTorusAction (phaseTransform C₀ v u)
+        (ToricSpace.twistedTranslate (positiveTwist C₀) v x) := by
+  rw [twistedTranslate_constant_eq, ToricSpace.translate_compactTorusAction,
+    twistedTranslate_positiveTwist_eq]
+  simp only [phaseTransform, ToricSpace.compactTorusAction, map_mul, ToricSpace.torusAction_mul]
+  rw [frozenMultiplier_phase_positive]
+  congr 1
+  ac_rfl
+
+private def
+    CuspPositive.closedPositiveTranslate (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (η : ℝ) (v : Fin 2 → ℤ)
+    (q : ToricSpace.ClosedPositiveTube η) : ToricSpace.ClosedPositiveTube η :=
+  ⟨⟨ToricSpace.twistedTranslate (positiveTwist C₀) v q.1,
+      twistedTranslate_positiveTwist_preserves_positivePart C₀ v q.1.2⟩,
+    by simpa only [ToricSpace.time_twistedTranslate] using q.2⟩
+
+@[simp]
+private theorem CuspPositive.closedPositiveTranslate_coe (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (η : ℝ)
+    (v : Fin 2 → ℤ) (q : ToricSpace.ClosedPositiveTube η) :
+    ((closedPositiveTranslate C₀ η v q).1 : ToricSpace.Space) =
+      ToricSpace.twistedTranslate (positiveTwist C₀) v q.1 :=
+  rfl
+
+private def CuspPositiveRetraction.quotientHeight (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    C(CuspPositive.QuotientSpace C₀ ε, ℝ) :=
+  ⟨CuspPositive.height C₀ ε, CuspPositive.height_continuous C₀ ε⟩
+
+private theorem
+    CuspPositiveRetraction.exists_positiveQuotient_collapse (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) :
+    ∃ η : ℝ,
+      0 < η ∧
+        η < ε ∧
+          ∃ A : CuspRetraction.Patching.LocalCollapse (quotientHeight C₀ ε),
+            {x | CuspPositive.height C₀ ε x ≤ η} ⊆ A.collapseSet := by
+  let := CuspPositive.quotient_t2Space C₀ ε hε hε1 hR
+  have hhalf : 0 < ε / 2 := half_pos hε
+  have hhalfε : ε / 2 < ε := half_lt_self hε
+  obtain ⟨η, hη, hηhalf, A, hA⟩ :=
+    exists_small_sublevel_collapse_of_orthant_charts (quotientHeight C₀ ε)
+      (CuspPositive.height_nonneg C₀ ε) hhalf
+      (CuspPositive.height_sublevel_isCompact C₀ ε hε hε1 hR hhalfε)
+      (by
+        intro x _hx
+        obtain ⟨e, hx, he⟩ := CuspPositive.exists_quotientChart C₀ ε hε hε1 hR x
+        refine ⟨e.symm, e x, e.map_source hx, e.left_inv hx, ?_⟩
+        exact he)
+  exact ⟨η, hη, hηhalf.trans_lt hhalfε, A, hA⟩
+
+private def CuspPositiveRetraction.closedPositiveSublevelHomeomorph (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) {η : ℝ} (hηε : η < ε) :
+    ToricSpace.ClosedPositiveTube η ≃ₜ
+      { x : CuspPositive.PositiveTube ε //
+        CuspPositive.height C₀ ε (CuspPositive.project C₀ ε x) ≤ η } := by
+  let F :
+    ToricSpace.ClosedPositiveTube η →
+      { x : CuspPositive.PositiveTube ε //
+        CuspPositive.height C₀ ε (CuspPositive.project C₀ ε x) ≤ η } :=
+    fun x =>
+    by
+    have hx : ToricSpace.time (x.1 : ToricSpace.Space) ∈ Metric.ball 0 ε := by
+      simpa only [Metric.mem_ball, dist_zero_right] using x.2.trans_lt hηε
+    exact ⟨⟨⟨(x.1 : ToricSpace.Space), hx⟩, x.1.2⟩, x.2⟩
+  let G :
+    { x : CuspPositive.PositiveTube ε //
+        CuspPositive.height C₀ ε (CuspPositive.project C₀ ε x) ≤ η } →
+      ToricSpace.ClosedPositiveTube η :=
+    fun x => ⟨⟨(x.1.1 : ToricSpace.Space), x.1.2⟩, x.2⟩
+  exact
+    { toFun := F
+      invFun := G
+      left_inv := fun _ => rfl
+      right_inv := fun _ => rfl
+      continuous_toFun :=
+        Continuous.subtype_mk
+          (((continuous_subtype_val.comp continuous_subtype_val).subtype_mk _).subtype_mk _) _
+      continuous_invFun :=
+        (((continuous_subtype_val.comp continuous_subtype_val).comp
+                  continuous_subtype_val).subtype_mk
+              _).subtype_mk
+          _ }
+
+private theorem CuspPositiveRetraction.closedPositiveSublevelHomeomorph_coe
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) {η : ℝ} (hηε : η < ε)
+    (x : ToricSpace.ClosedPositiveTube η) :
+    (((closedPositiveSublevelHomeomorph C₀ ε hηε x).1).1 : ToricSpace.Space) =
+      (x.1 : ToricSpace.Space) :=
+  rfl
+
+private theorem CuspPositiveRetraction.closedPositiveSublevelHomeomorph_translate
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) {η : ℝ} (hηε : η < ε) (v : Fin 2 → ℤ)
+    (x : ToricSpace.ClosedPositiveTube η) :
+    (closedPositiveSublevelHomeomorph C₀ ε hηε
+          (CuspPositive.closedPositiveTranslate C₀ η v x)).1 =
+      CuspPositive.positiveTubeTranslate C₀ ε v (closedPositiveSublevelHomeomorph C₀ ε hηε x).1 :=
+  rfl
+
+private theorem CuspPositiveRetraction.positiveCovering (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) :
+    IsCoveringMap (CuspPositive.project C₀ ε) := by
+  let := CuspPositive.positiveAction C₀ ε
+  exact (CuspPositive.project_covering C₀ ε hε hε1 hR).isCoveringMap
+
+private def CuspPositiveRetraction.positiveLift (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε)
+    (A : CuspRetraction.Patching.LocalCollapse (quotientHeight C₀ ε)) :
+    C(unitInterval × CuspPositive.PositiveTube ε, CuspPositive.PositiveTube ε) :=
+  Covering.lift (positiveCovering C₀ ε hε hε1 hR) A.homotopy A.map_zero
+
+@[simp]
+private theorem CuspPositiveRetraction.positiveLift_zero (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε)
+    (A : CuspRetraction.Patching.LocalCollapse (quotientHeight C₀ ε))
+    (x : CuspPositive.PositiveTube ε) : positiveLift C₀ ε hε hε1 hR A (0, x) = x :=
+  Covering.lift_zero (positiveCovering C₀ ε hε hε1 hR) A.homotopy A.map_zero x
+
+private theorem
+    CuspPositiveRetraction.positiveLift_projection (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε)
+    (A : CuspRetraction.Patching.LocalCollapse (quotientHeight C₀ ε)) (s : unitInterval)
+    (x : CuspPositive.PositiveTube ε) :
+    CuspPositive.project C₀ ε (positiveLift C₀ ε hε hε1 hR A (s, x)) =
+      A.homotopy (s, CuspPositive.project C₀ ε x) :=
+  Covering.lift_projection (positiveCovering C₀ ε hε hε1 hR) A.homotopy A.map_zero s x
+
+private theorem
+    CuspPositiveRetraction.positiveLift_equivariant (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε)
+    (A : CuspRetraction.Patching.LocalCollapse (quotientHeight C₀ ε)) (v : Fin 2 → ℤ)
+    (s : unitInterval) (x : CuspPositive.PositiveTube ε) :
+    positiveLift C₀ ε hε hε1 hR A (s, CuspPositive.positiveTubeTranslate C₀ ε v x) =
+      CuspPositive.positiveTubeTranslate C₀ ε v (positiveLift C₀ ε hε hε1 hR A (s, x)) := by
+  let := CuspPositive.positiveAction C₀ ε
+  let := CuspPositive.positiveAction_continuous C₀ ε
+  exact
+    Covering.lift_equivariant (positiveCovering C₀ ε hε hε1 hR) A.homotopy A.map_zero
+      (fun g x => CuspPositive.project_translate C₀ ε g.toAdd x) (Multiplicative.ofAdd v) s x
+
+private theorem CuspPositiveRetraction.positiveLift_fixed (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε)
+    (A : CuspRetraction.Patching.LocalCollapse (quotientHeight C₀ ε)) (s : unitInterval)
+    (x : CuspPositive.PositiveTube ε) (hx : ToricSpace.time (x.1 : ToricSpace.Space) = 0) :
+    positiveLift C₀ ε hε hε1 hR A (s, x) = x := by
+  apply Covering.lift_fixed (positiveCovering C₀ ε hε hε1 hR) A.homotopy A.map_zero x
+  intro t
+  apply A.fixes_zero
+  change ‖ToricSpace.time (x.1 : ToricSpace.Space)‖ = 0
+  simp only [hx, norm_zero]
+
+private theorem
+    CuspPositiveRetraction.positiveLift_nonincreasing (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε)
+    (A : CuspRetraction.Patching.LocalCollapse (quotientHeight C₀ ε)) (s : unitInterval)
+    (x : CuspPositive.PositiveTube ε) :
+    ‖ToricSpace.time ((positiveLift C₀ ε hε hε1 hR A (s, x)).1 : ToricSpace.Space)‖ ≤
+      ‖ToricSpace.time (x.1 : ToricSpace.Space)‖ :=
+  Covering.lift_height_le (positiveCovering C₀ ε hε hε1 hR) A.homotopy A.map_zero
+    (CuspPositive.height C₀ ε) A.nonincreasing s x
+
+private def CuspPositiveRetraction.positiveDeformation (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε)
+    (A : CuspRetraction.Patching.LocalCollapse (quotientHeight C₀ ε)) {η : ℝ} (hηε : η < ε) :
+    C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η) :=
+  let e := closedPositiveSublevelHomeomorph C₀ ε hηε
+  let L :=
+    Covering.liftSublevel (positiveCovering C₀ ε hε hε1 hR) A.homotopy A.map_zero
+      (CuspPositive.height C₀ ε) η A.nonincreasing
+  ⟨fun p => e.symm (L (p.1, e p.2)),
+    e.symm.continuous.comp
+      (L.continuous.comp (continuous_fst.prodMk (e.continuous.comp continuous_snd)))⟩
+
+private theorem
+    CuspPositiveRetraction.positiveDeformation_coe (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε)
+    (A : CuspRetraction.Patching.LocalCollapse (quotientHeight C₀ ε)) {η : ℝ} (hηε : η < ε)
+    (s : unitInterval) (x : ToricSpace.ClosedPositiveTube η) :
+    ((positiveDeformation C₀ ε hε hε1 hR A hηε (s, x)).1 : ToricSpace.Space) =
+      ((positiveLift C₀ ε hε hε1 hR A (s, (closedPositiveSublevelHomeomorph C₀ ε hηε x).1)).1 :
+        ToricSpace.Space) :=
+  rfl
+
+@[simp]
+private theorem
+    CuspPositiveRetraction.positiveDeformation_zero (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε)
+    (A : CuspRetraction.Patching.LocalCollapse (quotientHeight C₀ ε)) {η : ℝ} (hηε : η < ε)
+    (x : ToricSpace.ClosedPositiveTube η) : positiveDeformation C₀ ε hε hε1 hR A hηε (0, x) = x :=
+  by
+  apply Subtype.ext
+  apply Subtype.ext
+  rw [positiveDeformation_coe, positiveLift_zero]
+  rfl
+
+private theorem
+    CuspPositiveRetraction.positiveDeformation_fixed (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε)
+    (A : CuspRetraction.Patching.LocalCollapse (quotientHeight C₀ ε)) {η : ℝ} (hηε : η < ε)
+    (s : unitInterval) (x : ToricSpace.ClosedPositiveTube η)
+    (hx : ToricSpace.time (x.1 : ToricSpace.Space) = 0) :
+    positiveDeformation C₀ ε hε hε1 hR A hηε (s, x) = x := by
+  apply Subtype.ext
+  apply Subtype.ext
+  rw [positiveDeformation_coe]
+  have hy := (congrArg ToricSpace.time (closedPositiveSublevelHomeomorph_coe C₀ ε hηε x)).trans hx
+  have he :=
+    positiveLift_fixed C₀ ε hε hε1 hR A s (closedPositiveSublevelHomeomorph C₀ ε hηε x).1 hy
+  exact
+    (congrArg (fun y : CuspPositive.PositiveTube ε => (y.1 : ToricSpace.Space)) he).trans
+      (closedPositiveSublevelHomeomorph_coe C₀ ε hηε x)
+
+private theorem
+    CuspPositiveRetraction.positiveDeformation_nonincreasing (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε)
+    (A : CuspRetraction.Patching.LocalCollapse (quotientHeight C₀ ε)) {η : ℝ} (hηε : η < ε)
+    (s : unitInterval) (x : ToricSpace.ClosedPositiveTube η) :
+    ‖ToricSpace.time ((positiveDeformation C₀ ε hε hε1 hR A hηε (s, x)).1 : ToricSpace.Space)‖ ≤
+      ‖ToricSpace.time (x.1 : ToricSpace.Space)‖ :=
+  positiveLift_nonincreasing C₀ ε hε hε1 hR A s (closedPositiveSublevelHomeomorph C₀ ε hηε x).1
+
+private theorem
+    CuspPositiveRetraction.positiveDeformation_one_central (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε)
+    (A : CuspRetraction.Patching.LocalCollapse (quotientHeight C₀ ε)) {η : ℝ} (hηε : η < ε)
+    (hA : {x | CuspPositive.height C₀ ε x ≤ η} ⊆ A.collapseSet)
+    (x : ToricSpace.ClosedPositiveTube η) :
+    ToricSpace.time ((positiveDeformation C₀ ε hε hε1 hR A hηε (1, x)).1 : ToricSpace.Space) =
+      0 := by
+  apply norm_eq_zero.mp
+  rw [positiveDeformation_coe]
+  change
+    CuspPositive.height C₀ ε
+        (CuspPositive.project C₀ ε
+          (positiveLift C₀ ε hε hε1 hR A (1, (closedPositiveSublevelHomeomorph C₀ ε hηε x).1))) =
+      0
+  rw [positiveLift_projection]
+  exact A.map_one_zero _ (hA (closedPositiveSublevelHomeomorph C₀ ε hηε x).2)
+
+private theorem
+    CuspPositiveRetraction.positiveDeformation_equivariant (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε)
+    (A : CuspRetraction.Patching.LocalCollapse (quotientHeight C₀ ε)) {η : ℝ} (hηε : η < ε)
+    (s : unitInterval) (v : Fin 2 → ℤ) (x : ToricSpace.ClosedPositiveTube η) :
+    positiveDeformation C₀ ε hε hε1 hR A hηε (s, CuspPositive.closedPositiveTranslate C₀ η v x) =
+      CuspPositive.closedPositiveTranslate C₀ η v
+        (positiveDeformation C₀ ε hε hε1 hR A hηε (s, x)) := by
+  apply Subtype.ext
+  apply Subtype.ext
+  rw [positiveDeformation_coe, closedPositiveSublevelHomeomorph_translate,
+    positiveLift_equivariant, CuspPositive.closedPositiveTranslate_coe, positiveDeformation_coe]
+  rfl
+
+private theorem CuspPositiveRetraction.exists_positive_closed_deformation_below
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) :
+    ∃ η₀ : ℝ,
+      0 < η₀ ∧
+        η₀ < ε ∧
+          ∀ η : ℝ,
+            0 < η →
+              η ≤ η₀ →
+                ∃ P :
+                  C(unitInterval × ToricSpace.ClosedPositiveTube η,
+                    ToricSpace.ClosedPositiveTube η),
+                  (∀ q, P (0, q) = q) ∧
+                    (∀ s q,
+                      ToricSpace.time (q.1 : ToricSpace.Space) = 0 → P (s, q) = q) ∧
+                      (∀ q, ToricSpace.time ((P (1, q)).1 : ToricSpace.Space) = 0) ∧
+                        (∀ s v q,
+                            P (s, CuspPositive.closedPositiveTranslate C₀ η v q) =
+                              CuspPositive.closedPositiveTranslate C₀ η v (P (s, q))) ∧
+                          (∀ s q,
+                            ‖ToricSpace.time ((P (s, q)).1 : ToricSpace.Space)‖ ≤
+                              ‖ToricSpace.time (q.1 : ToricSpace.Space)‖) := by
+  obtain ⟨η₀, hη₀, hη₀ε, A, hA⟩ := exists_positiveQuotient_collapse C₀ ε hε hε1 hR
+  refine ⟨η₀, hη₀, hη₀ε, ?_⟩
+  intro η _hη hηη₀
+  have hηε : η < ε := hηη₀.trans_lt hη₀ε
+  have hAη : {x | CuspPositive.height C₀ ε x ≤ η} ⊆ A.collapseSet := fun _ hx =>
+    hA (hx.trans hηη₀)
+  refine
+    ⟨positiveDeformation C₀ ε hε hε1 hR A hηε, positiveDeformation_zero C₀ ε hε hε1 hR A hηε,
+      positiveDeformation_fixed C₀ ε hε hε1 hR A hηε,
+      positiveDeformation_one_central C₀ ε hε hε1 hR A hηε hAη,
+      positiveDeformation_equivariant C₀ ε hε hε1 hR A hηε,
+      positiveDeformation_nonincreasing C₀ ε hε hε1 hR A hηε⟩
+
+private def
+    CuspRetraction.closedCompactAction (η : ℝ) (u : ToricSpace.CompactTorus) (x : ClosedTube η) :
+    ClosedTube η :=
+  ⟨ToricSpace.compactTorusAction u x,
+    by
+    rw [ToricSpace.norm_time_compactTorusAction]
+    exact x.2⟩
+
+private theorem
+    CuspRetraction.closedCompactAction_closedPolarMap (η : ℝ) (u v : ToricSpace.CompactTorus)
+    (q : ToricSpace.ClosedPositiveTube η) :
+    closedCompactAction η u (ToricSpace.closedPolarMap η (v, q)) =
+      ToricSpace.closedPolarMap η (u * v, q) :=
+  Subtype.ext (ToricSpace.compactTorusAction_mul u v q.1)
+
+private theorem CuspRetraction.positiveHomotopy_polar_compatible {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hfix :
+      ∀ (s : unitInterval) (q : ToricSpace.ClosedPositiveTube η),
+        ToricSpace.time (q.1 : ToricSpace.Space) = 0 → P (s, q) = q)
+    (s : unitInterval) (u v : ToricSpace.CompactTorus) (q r : ToricSpace.ClosedPositiveTube η)
+    (h : ToricSpace.closedPolarMap η (u, q) = ToricSpace.closedPolarMap η (v, r)) :
+    ToricSpace.closedPolarMap η (u, P (s, q)) = ToricSpace.closedPolarMap η (v, P (s, r)) := by
+  have hqr : q = r := by
+    apply Subtype.ext
+    apply Subtype.ext
+    have hm :
+      ToricSpace.modulus (ToricSpace.compactTorusAction u q.1) =
+        ToricSpace.modulus (ToricSpace.compactTorusAction v r.1) :=
+      congrArg (fun x : ClosedTube η => ToricSpace.modulus (x : ToricSpace.Space)) h
+    rwa [ToricSpace.modulus_compactTorusAction, ToricSpace.modulus_compactTorusAction, q.1.2,
+      r.1.2] at hm
+  subst r
+  by_cases hq : ToricSpace.time (q.1 : ToricSpace.Space) = 0
+  · rw [hfix s q hq]
+    exact h
+  · have huv : u = v :=
+      ToricSpace.compactTorusAction_injective_of_time_ne_zero hq (congrArg Subtype.val h)
+    rw [huv]
+
+private def CuspRetraction.polarRepresentative_mo1973_10806 (η : ℝ) (x : ClosedTube η) :
+    ToricSpace.CompactTorus × ToricSpace.ClosedPositiveTube η :=
+  (ToricSpace.closedPolarMap_surjective η x).choose
+
+private theorem CuspRetraction.polarRepresentative_spec_mo1973_10807 (η : ℝ) (x : ClosedTube η) :
+    ToricSpace.closedPolarMap η (polarRepresentative_mo1973_10806 η x) = x :=
+  (ToricSpace.closedPolarMap_surjective η x).choose_spec
+
+private def CuspRetraction.polarSpread {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (s : unitInterval) (x : ClosedTube η) : ClosedTube η :=
+  let p := polarRepresentative_mo1973_10806 η x
+  ToricSpace.closedPolarMap η (p.1, P (s, p.2))
+
+private theorem CuspRetraction.polarSpread_closedPolarMap {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hfix :
+      ∀ (s : unitInterval) (q : ToricSpace.ClosedPositiveTube η),
+        ToricSpace.time (q.1 : ToricSpace.Space) = 0 → P (s, q) = q)
+    (s : unitInterval) (p : ToricSpace.CompactTorus × ToricSpace.ClosedPositiveTube η) :
+    polarSpread P s (ToricSpace.closedPolarMap η p) =
+      ToricSpace.closedPolarMap η (p.1, P (s, p.2)) := by
+  change
+    ToricSpace.closedPolarMap η
+        ((polarRepresentative_mo1973_10806 η (ToricSpace.closedPolarMap η p)).1,
+          P (s, (polarRepresentative_mo1973_10806 η (ToricSpace.closedPolarMap η p)).2)) =
+      _
+  exact
+    positiveHomotopy_polar_compatible P hfix s
+      (polarRepresentative_mo1973_10806 η (ToricSpace.closedPolarMap η p)).1 p.1
+      (polarRepresentative_mo1973_10806 η (ToricSpace.closedPolarMap η p)).2 p.2
+      (polarRepresentative_spec_mo1973_10807 η (ToricSpace.closedPolarMap η p))
+
+private theorem CuspRetraction.polarSpread_continuous {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hfix :
+      ∀ (s : unitInterval) (q : ToricSpace.ClosedPositiveTube η),
+        ToricSpace.time (q.1 : ToricSpace.Space) = 0 → P (s, q) = q) :
+    Continuous (fun p : unitInterval × ClosedTube η => polarSpread P p.1 p.2) := by
+  apply (ToricSpace.closedPolarMap_isQuotientMap η).continuous_lift_prod_right
+  have h :
+    Continuous
+      (fun p : unitInterval × (ToricSpace.CompactTorus × ToricSpace.ClosedPositiveTube η) =>
+        ToricSpace.closedPolarMap η (p.2.1, P (p.1, p.2.2))) :=
+    (ToricSpace.closedPolarMap_continuous η).comp
+      ((continuous_fst.comp continuous_snd).prodMk
+        (P.continuous.comp (continuous_fst.prodMk (continuous_snd.comp continuous_snd))))
+  simpa only [polarSpread_closedPolarMap P hfix] using h
+
+private theorem CuspRetraction.polarSpread_compactTorus_equivariant {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hfix :
+      ∀ (s : unitInterval) (q : ToricSpace.ClosedPositiveTube η),
+        ToricSpace.time (q.1 : ToricSpace.Space) = 0 → P (s, q) = q)
+    (s : unitInterval) (u : ToricSpace.CompactTorus) (x : ClosedTube η) :
+    polarSpread P s (closedCompactAction η u x) = closedCompactAction η u (polarSpread P s x) := by
+  obtain ⟨⟨v, q⟩, rfl⟩ := ToricSpace.closedPolarMap_surjective η x
+  rw [closedCompactAction_closedPolarMap, polarSpread_closedPolarMap P hfix,
+    polarSpread_closedPolarMap P hfix, closedCompactAction_closedPolarMap]
+
+private theorem CuspRetraction.polarSpread_zero {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hfix :
+      ∀ (s : unitInterval) (q : ToricSpace.ClosedPositiveTube η),
+        ToricSpace.time (q.1 : ToricSpace.Space) = 0 → P (s, q) = q)
+    (hzero : ∀ q : ToricSpace.ClosedPositiveTube η, P (0, q) = q) (x : ClosedTube η) :
+    polarSpread P 0 x = x := by
+  obtain ⟨p, rfl⟩ := ToricSpace.closedPolarMap_surjective η x
+  rw [polarSpread_closedPolarMap P hfix, hzero]
+
+private theorem CuspRetraction.polarSpread_fixed {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hfix :
+      ∀ (s : unitInterval) (q : ToricSpace.ClosedPositiveTube η),
+        ToricSpace.time (q.1 : ToricSpace.Space) = 0 → P (s, q) = q)
+    (s : unitInterval) (x : ClosedTube η) (hx : ToricSpace.time (x : ToricSpace.Space) = 0) :
+    polarSpread P s x = x := by
+  obtain ⟨⟨u, q⟩, rfl⟩ := ToricSpace.closedPolarMap_surjective η x
+  have hq : ToricSpace.time (q.1 : ToricSpace.Space) = 0 := by
+    have hn := congrArg Norm.norm hx
+    change ‖ToricSpace.time (ToricSpace.compactTorusAction u q.1)‖ = ‖(0 : ℂ)‖ at hn
+    rw [ToricSpace.norm_time_compactTorusAction, norm_zero] at hn
+    exact norm_eq_zero.mp hn
+  rw [polarSpread_closedPolarMap P hfix, hfix s q hq]
+
+private theorem CuspRetraction.polarSpread_one_central {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hfix :
+      ∀ (s : unitInterval) (q : ToricSpace.ClosedPositiveTube η),
+        ToricSpace.time (q.1 : ToricSpace.Space) = 0 → P (s, q) = q)
+    (hone :
+      ∀ q : ToricSpace.ClosedPositiveTube η,
+        ToricSpace.time ((P (1, q)).1 : ToricSpace.Space) = 0)
+    (x : ClosedTube η) : ToricSpace.time (polarSpread P 1 x : ToricSpace.Space) = 0 := by
+  obtain ⟨⟨u, q⟩, rfl⟩ := ToricSpace.closedPolarMap_surjective η x
+  rw [polarSpread_closedPolarMap P hfix]
+  change ToricSpace.time (ToricSpace.compactTorusAction u ((P (1, q)).1 : ToricSpace.Space)) = 0
+  simp only [ToricSpace.compactTorusAction, ToricSpace.time_torusAction, hone q,
+    MulZeroClass.mul_zero]
+
+private abbrev CuspRetraction.CentralFibre :=
+  { x : ToricSpace.Space // ToricSpace.time x = 0 }
+
+private def
+    CuspRetraction.centralIntoClosedTube (η : ℝ) (hη : 0 ≤ η) : C(CentralFibre, ClosedTube η)
+    where
+  toFun x := ⟨x, by rw [x.2, norm_zero]; exact hη⟩
+  continuous_toFun := continuous_subtype_val.subtype_mk _
+
+private theorem CuspPositive.closedTranslate_closedPolarMap (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (η : ℝ)
+    (v : Fin 2 → ℤ) (u : ToricSpace.CompactTorus) (q : ToricSpace.ClosedPositiveTube η) :
+    CuspRetraction.closedTranslate (fun _ => C₀) η v (ToricSpace.closedPolarMap η (u, q)) =
+      ToricSpace.closedPolarMap η (phaseTransform C₀ v u, closedPositiveTranslate C₀ η v q) :=
+  Subtype.ext (twistedTranslate_constant_polar C₀ v u q.1)
+
+private theorem
+    CuspRetraction.polarSpread_frozen_equivariant (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hfix :
+      ∀ (s : unitInterval) (q : ToricSpace.ClosedPositiveTube η),
+        ToricSpace.time (q.1 : ToricSpace.Space) = 0 → P (s, q) = q)
+    (hequiv :
+      ∀ (s : unitInterval) (v : Fin 2 → ℤ) (q : ToricSpace.ClosedPositiveTube η),
+        P (s, CuspPositive.closedPositiveTranslate C₀ η v q) =
+          CuspPositive.closedPositiveTranslate C₀ η v (P (s, q)))
+    (s : unitInterval) (v : Fin 2 → ℤ) (x : ClosedTube η) :
+    polarSpread P s (closedTranslate (fun _ => C₀) η v x) =
+      closedTranslate (fun _ => C₀) η v (polarSpread P s x) := by
+  obtain ⟨⟨u, q⟩, rfl⟩ := ToricSpace.closedPolarMap_surjective η x
+  rw [CuspPositive.closedTranslate_closedPolarMap, polarSpread_closedPolarMap P hfix,
+    polarSpread_closedPolarMap P hfix, CuspPositive.closedTranslate_closedPolarMap, hequiv]
+
+private theorem CuspRetraction.polarSpread_norm_time_le {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hfix :
+      ∀ (s : unitInterval) (q : ToricSpace.ClosedPositiveTube η),
+        ToricSpace.time (q.1 : ToricSpace.Space) = 0 → P (s, q) = q)
+    (hmono :
+      ∀ (s : unitInterval) (q : ToricSpace.ClosedPositiveTube η),
+        ‖ToricSpace.time ((P (s, q)).1 : ToricSpace.Space)‖ ≤
+          ‖ToricSpace.time (q.1 : ToricSpace.Space)‖)
+    (s : unitInterval) (x : ClosedTube η) :
+    ‖ToricSpace.time (polarSpread P s x : ToricSpace.Space)‖ ≤
+      ‖ToricSpace.time (x : ToricSpace.Space)‖ := by
+  obtain ⟨⟨u, q⟩, rfl⟩ := ToricSpace.closedPolarMap_surjective η x
+  rw [polarSpread_closedPolarMap P hfix]
+  simpa only [ToricSpace.closedPolarMap_coe, ToricSpace.norm_time_compactTorusAction] using
+    hmono s q
+
+private def CuspRetraction.compactFibrePhase (u : Fin 2 → ℂˣ) (hu : ∀ i, ‖(u i : ℂ)‖ = 1) :
+    ToricSpace.CompactTorus :=
+  ![⟨(u 0 : ℂ), mem_sphere_zero_iff_norm.mpr (hu 0)⟩,
+    ⟨(u 1 : ℂ), mem_sphere_zero_iff_norm.mpr (hu 1)⟩, 1]
+
+@[simp]
+private theorem CuspRetraction.compactTorusUnits_compactFibrePhase (u : Fin 2 → ℂˣ)
+    (hu : ∀ i, ‖(u i : ℂ)‖ = 1) :
+    ToricSpace.compactTorusUnits (compactFibrePhase u hu) = ToricSpace.fibreMultiplier u := by
+  funext i
+  apply Units.ext
+  fin_cases i <;> simp [compactFibrePhase, ToricSpace.fibreMultiplier]
+
+@[simp]
+private theorem CuspRetraction.closedCompactAction_compactFibrePhase (η : ℝ) (u : Fin 2 → ℂˣ)
+    (hu : ∀ i, ‖(u i : ℂ)‖ = 1) (x : ClosedTube η) :
+    closedCompactAction η (compactFibrePhase u hu) x = closedFibreAction η u x := by
+  apply Subtype.ext
+  change
+    ToricSpace.torusAction (ToricSpace.compactTorusUnits (compactFibrePhase u hu)) x =
+      ToricSpace.torusAction (ToricSpace.fibreMultiplier u) x
+  rw [compactTorusUnits_compactFibrePhase]
+
+private theorem CuspRetraction.polarSpread_fibre_torus_equivariant {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hfix :
+      ∀ (s : unitInterval) (q : ToricSpace.ClosedPositiveTube η),
+        ToricSpace.time (q.1 : ToricSpace.Space) = 0 → P (s, q) = q)
+    (s : unitInterval) (u : Fin 2 → ℂˣ) (hu : ∀ i, ‖(u i : ℂ)‖ = 1) (x : ClosedTube η) :
+    polarSpread P s (closedFibreAction η u x) = closedFibreAction η u (polarSpread P s x) := by
+  simpa only [closedCompactAction_compactFibrePhase] using
+    polarSpread_compactTorus_equivariant P hfix s (compactFibrePhase u hu) x
+
+private theorem CuspPositiveRetraction.exists_frozen_closed_deformation_below
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) :
+    ∃ η₀ : ℝ,
+      0 < η₀ ∧
+        η₀ < ε ∧
+          ∀ η : ℝ,
+            0 < η →
+              η ≤ η₀ →
+                ∃ H : C(unitInterval × CuspRetraction.ClosedTube η, CuspRetraction.ClosedTube η),
+                  (∀ x, H (0, x) = x) ∧
+                    (∀ s (x : CuspRetraction.ClosedTube η),
+                        ToricSpace.time (x : ToricSpace.Space) = 0 → H (s, x) = x) ∧
+                      (∀ x, ToricSpace.time (H (1, x) : ToricSpace.Space) = 0) ∧
+                        (∀ s v x,
+                            H (s, CuspRetraction.closedTranslate (fun _ => C₀) η v x) =
+                              CuspRetraction.closedTranslate (fun _ => C₀) η v (H (s, x))) ∧
+                          (∀ s u x,
+                              H (s, CuspRetraction.closedCompactAction η u x) =
+                                CuspRetraction.closedCompactAction η u (H (s, x))) ∧
+                            (∀ s (u : Fin 2 → ℂˣ),
+                                (∀ i, ‖(u i : ℂ)‖ = 1) →
+                                  ∀ x,
+                                    H (s, CuspRetraction.closedFibreAction η u x) =
+                                      CuspRetraction.closedFibreAction η u (H (s, x))) ∧
+                              (∀ s x,
+                                ‖ToricSpace.time (H (s, x) : ToricSpace.Space)‖ ≤
+                                  ‖ToricSpace.time (x : ToricSpace.Space)‖) := by
+  obtain ⟨η₀, hη₀, hη₀ε, hP⟩ := exists_positive_closed_deformation_below C₀ ε hε hε1 hR
+  refine ⟨η₀, hη₀, hη₀ε, ?_⟩
+  intro η hη hηη₀
+  obtain ⟨P, hzero, hfix, hone, hequiv, hmono⟩ := hP η hη hηη₀
+  let H : C(unitInterval × CuspRetraction.ClosedTube η, CuspRetraction.ClosedTube η) :=
+    ⟨fun p => CuspRetraction.polarSpread P p.1 p.2, CuspRetraction.polarSpread_continuous P hfix⟩
+  exact
+    ⟨H, CuspRetraction.polarSpread_zero P hfix hzero, CuspRetraction.polarSpread_fixed P hfix,
+      CuspRetraction.polarSpread_one_central P hfix hone,
+      CuspRetraction.polarSpread_frozen_equivariant C₀ P hfix hequiv,
+      CuspRetraction.polarSpread_compactTorus_equivariant P hfix,
+      CuspRetraction.polarSpread_fibre_torus_equivariant P hfix,
+      CuspRetraction.polarSpread_norm_time_le P hfix hmono⟩
+
+private def
+    CuspPositiveRetraction.closedFrozenStraightening (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ}
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (hηε : η < ε) : CuspRetraction.ClosedTube η ≃ₜ CuspRetraction.ClosedTube η :=
+  CuspRetraction.closedTubeHomeomorph C (CuspRetraction.frozen C) hε hε1 hC
+    (fun _ _ => continuousOn_const) rfl hRC hRD hηε
+
+private theorem
+    CuspPositiveRetraction.closedFrozenStraightening_base (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (hηε : η < ε) (x : CuspRetraction.ClosedTube η) :
+    ToricSpace.time ((closedFrozenStraightening C hε hε1 hC hRC hRD hηε) x : ToricSpace.Space) =
+      ToricSpace.time (x : ToricSpace.Space) :=
+  CuspRetraction.closedTubeHomeomorph_base C (CuspRetraction.frozen C) hε hε1 hC
+    (fun _ _ => continuousOn_const) rfl hRC hRD hηε x
+
+private theorem CuspPositiveRetraction.closedFrozenStraightening_symm_base
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (hηε : η < ε) (x : CuspRetraction.ClosedTube η) :
+    ToricSpace.time
+        (((closedFrozenStraightening C hε hε1 hC hRC hRD hηε)).symm x : ToricSpace.Space) =
+      ToricSpace.time (x : ToricSpace.Space) := by
+  have h :=
+    closedFrozenStraightening_base C hε hε1 hC hRC hRD hηε
+      (((closedFrozenStraightening C hε hε1 hC hRC hRD hηε)).symm x)
+  rw [((closedFrozenStraightening C hε hε1 hC hRC hRD hηε)).apply_symm_apply] at h
+  exact h.symm
+
+private theorem
+    CuspPositiveRetraction.closedFrozenStraightening_fixed (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (hηε : η < ε) (x : CuspRetraction.ClosedTube η)
+    (hx : ToricSpace.time (x : ToricSpace.Space) = 0) :
+    (closedFrozenStraightening C hε hε1 hC hRC hRD hηε) x = x :=
+  CuspRetraction.closedTubeHomeomorph_fixes_central C (CuspRetraction.frozen C) hε hε1 hC
+    (fun _ _ => continuousOn_const) rfl hRC hRD hηε x hx
+
+private theorem CuspPositiveRetraction.closedFrozenStraightening_equivariant
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (hηε : η < ε) (v : Fin 2 → ℤ) (x : CuspRetraction.ClosedTube η) :
+    (closedFrozenStraightening C hε hε1 hC hRC hRD hηε) (CuspRetraction.closedTranslate C η v x) =
+      CuspRetraction.closedTranslate (CuspRetraction.frozen C) η v
+        ((closedFrozenStraightening C hε hε1 hC hRC hRD hηε) x) :=
+  CuspRetraction.closedTubeHomeomorph_equivariant C (CuspRetraction.frozen C) hε hε1 hC
+    (fun _ _ => continuousOn_const) rfl hRC hRD hηε v x
+
+private theorem CuspPositiveRetraction.closedFrozenStraightening_symm_equivariant
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (hηε : η < ε) (v : Fin 2 → ℤ) (x : CuspRetraction.ClosedTube η) :
+    ((closedFrozenStraightening C hε hε1 hC hRC hRD hηε)).symm
+        (CuspRetraction.closedTranslate (CuspRetraction.frozen C) η v x) =
+      CuspRetraction.closedTranslate C η v
+        (((closedFrozenStraightening C hε hε1 hC hRC hRD hηε)).symm x) := by
+  apply ((closedFrozenStraightening C hε hε1 hC hRC hRD hηε)).injective
+  rw [((closedFrozenStraightening C hε hε1 hC hRC hRD hηε)).apply_symm_apply,
+    closedFrozenStraightening_equivariant,
+    ((closedFrozenStraightening C hε hε1 hC hRC hRD hηε)).apply_symm_apply]
+
+private theorem CuspPositiveRetraction.closedFrozenStraightening_fibre_torus
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (hηε : η < ε) (u : Fin 2 → ℂˣ) (hu : ∀ i, ‖(u i : ℂ)‖ = 1) (x : CuspRetraction.ClosedTube η) :
+    (closedFrozenStraightening C hε hε1 hC hRC hRD hηε) (CuspRetraction.closedFibreAction η u x) =
+      CuspRetraction.closedFibreAction η u
+        ((closedFrozenStraightening C hε hε1 hC hRC hRD hηε) x) :=
+  CuspRetraction.closedTubeHomeomorph_fibre_torus C (CuspRetraction.frozen C) hε hε1 hC
+    (fun _ _ => continuousOn_const) rfl hRC hRD hηε u hu x
+
+private theorem CuspPositiveRetraction.closedFrozenStraightening_symm_fibre_torus
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (hηε : η < ε) (u : Fin 2 → ℂˣ) (hu : ∀ i, ‖(u i : ℂ)‖ = 1) (x : CuspRetraction.ClosedTube η) :
+    ((closedFrozenStraightening C hε hε1 hC hRC hRD hηε)).symm
+        (CuspRetraction.closedFibreAction η u x) =
+      CuspRetraction.closedFibreAction η u
+        (((closedFrozenStraightening C hε hε1 hC hRC hRD hηε)).symm x) := by
+  apply ((closedFrozenStraightening C hε hε1 hC hRC hRD hηε)).injective
+  rw [((closedFrozenStraightening C hε hε1 hC hRC hRD hηε)).apply_symm_apply,
+    closedFrozenStraightening_fibre_torus C hε hε1 hC hRC hRD hηε u hu,
+    ((closedFrozenStraightening C hε hε1 hC hRC hRD hηε)).apply_symm_apply]
+
+private def CuspPositiveRetraction.straightenedHomotopy (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ}
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (hηε : η < ε)
+    (H : C(unitInterval × CuspRetraction.ClosedTube η, CuspRetraction.ClosedTube η)) :
+    C(unitInterval × CuspRetraction.ClosedTube η, CuspRetraction.ClosedTube η)
+    where
+  toFun
+    p :=
+    ((closedFrozenStraightening C hε hε1 hC hRC hRD hηε)).symm
+      (H (p.1, (closedFrozenStraightening C hε hε1 hC hRC hRD hηε) p.2))
+  continuous_toFun :=
+    ((closedFrozenStraightening C hε hε1 hC hRC hRD hηε)).symm.continuous.comp
+      (H.continuous.comp
+        (continuous_fst.prodMk
+          (((closedFrozenStraightening C hε hε1 hC hRC hRD hηε)).continuous.comp continuous_snd)))
+
+@[simp]
+private theorem CuspPositiveRetraction.straightenedHomotopy_apply (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (hηε : η < ε) (H : C(unitInterval × CuspRetraction.ClosedTube η, CuspRetraction.ClosedTube η))
+    (s : unitInterval) (x : CuspRetraction.ClosedTube η) :
+    straightenedHomotopy C hε hε1 hC hRC hRD hηε H (s, x) =
+      ((closedFrozenStraightening C hε hε1 hC hRC hRD hηε)).symm
+        (H (s, (closedFrozenStraightening C hε hε1 hC hRC hRD hηε) x)) :=
+  rfl
+
+private theorem CuspPositiveRetraction.straightenedHomotopy_time (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (hηε : η < ε) (H : C(unitInterval × CuspRetraction.ClosedTube η, CuspRetraction.ClosedTube η))
+    (s : unitInterval) (x : CuspRetraction.ClosedTube η) :
+    ToricSpace.time (straightenedHomotopy C hε hε1 hC hRC hRD hηε H (s, x) : ToricSpace.Space) =
+      ToricSpace.time
+        (H (s, (closedFrozenStraightening C hε hε1 hC hRC hRD hηε) x) : ToricSpace.Space) :=
+  closedFrozenStraightening_symm_base C hε hε1 hC hRC hRD hηε _
+
+private theorem CuspPositiveRetraction.straightenedHomotopy_zero (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (hηε : η < ε) (H : C(unitInterval × CuspRetraction.ClosedTube η, CuspRetraction.ClosedTube η))
+    (hzero : ∀ x : CuspRetraction.ClosedTube η, H (0, x) = x) (x : CuspRetraction.ClosedTube η) :
+    straightenedHomotopy C hε hε1 hC hRC hRD hηε H (0, x) = x := by
+  rw [straightenedHomotopy_apply, hzero,
+    ((closedFrozenStraightening C hε hε1 hC hRC hRD hηε)).symm_apply_apply]
+
+private theorem CuspPositiveRetraction.straightenedHomotopy_fixed (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (hηε : η < ε) (H : C(unitInterval × CuspRetraction.ClosedTube η, CuspRetraction.ClosedTube η))
+    (hfixed :
+      ∀ (s : unitInterval) (x : CuspRetraction.ClosedTube η),
+        ToricSpace.time (x : ToricSpace.Space) = 0 → H (s, x) = x)
+    (s : unitInterval) (x : CuspRetraction.ClosedTube η)
+    (hx : ToricSpace.time (x : ToricSpace.Space) = 0) :
+    straightenedHomotopy C hε hε1 hC hRC hRD hηε H (s, x) = x := by
+  have hGx :
+    ToricSpace.time ((closedFrozenStraightening C hε hε1 hC hRC hRD hηε) x : ToricSpace.Space) =
+      0 :=
+    (closedFrozenStraightening_base C hε hε1 hC hRC hRD hηε x).trans hx
+  rw [straightenedHomotopy_apply,
+    hfixed s ((closedFrozenStraightening C hε hε1 hC hRC hRD hηε) x) hGx,
+    ((closedFrozenStraightening C hε hε1 hC hRC hRD hηε)).symm_apply_apply]
+
+private theorem
+    CuspPositiveRetraction.straightenedHomotopy_one_central (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (hηε : η < ε) (H : C(unitInterval × CuspRetraction.ClosedTube η, CuspRetraction.ClosedTube η))
+    (hone : ∀ x : CuspRetraction.ClosedTube η, ToricSpace.time (H (1, x) : ToricSpace.Space) = 0)
+    (x : CuspRetraction.ClosedTube η) :
+    ToricSpace.time (straightenedHomotopy C hε hε1 hC hRC hRD hηε H (1, x) : ToricSpace.Space) =
+      0 := by
+  rw [straightenedHomotopy_time]
+  exact hone ((closedFrozenStraightening C hε hε1 hC hRC hRD hηε) x)
+
+private theorem CuspPositiveRetraction.straightenedHomotopy_norm_time_le
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (hηε : η < ε) (H : C(unitInterval × CuspRetraction.ClosedTube η, CuspRetraction.ClosedTube η))
+    (hnorm :
+      ∀ (s : unitInterval) (x : CuspRetraction.ClosedTube η),
+        ‖ToricSpace.time (H (s, x) : ToricSpace.Space)‖ ≤
+          ‖ToricSpace.time (x : ToricSpace.Space)‖)
+    (s : unitInterval) (x : CuspRetraction.ClosedTube η) :
+    ‖ToricSpace.time (straightenedHomotopy C hε hε1 hC hRC hRD hηε H (s, x) : ToricSpace.Space)‖ ≤
+      ‖ToricSpace.time (x : ToricSpace.Space)‖ := by
+  rw [straightenedHomotopy_time]
+  exact
+    (hnorm s ((closedFrozenStraightening C hε hε1 hC hRC hRD hηε) x)).trans_eq
+      (congrArg Norm.norm (closedFrozenStraightening_base C hε hε1 hC hRC hRD hηε x))
+
+private theorem
+    CuspPositiveRetraction.straightenedHomotopy_equivariant (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (hηε : η < ε) (H : C(unitInterval × CuspRetraction.ClosedTube η, CuspRetraction.ClosedTube η))
+    (hequiv :
+      ∀ (s : unitInterval) (v : Fin 2 → ℤ) (x : CuspRetraction.ClosedTube η),
+        H (s, CuspRetraction.closedTranslate (CuspRetraction.frozen C) η v x) =
+          CuspRetraction.closedTranslate (CuspRetraction.frozen C) η v (H (s, x)))
+    (s : unitInterval) (v : Fin 2 → ℤ) (x : CuspRetraction.ClosedTube η) :
+    straightenedHomotopy C hε hε1 hC hRC hRD hηε H (s, CuspRetraction.closedTranslate C η v x) =
+      CuspRetraction.closedTranslate C η v
+        (straightenedHomotopy C hε hε1 hC hRC hRD hηε H (s, x)) := by
+  simp only [straightenedHomotopy_apply, closedFrozenStraightening_equivariant, hequiv,
+    closedFrozenStraightening_symm_equivariant]
+
+private theorem CuspPositiveRetraction.straightenedHomotopy_fibre_torus_equivariant
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (hηε : η < ε) (H : C(unitInterval × CuspRetraction.ClosedTube η, CuspRetraction.ClosedTube η))
+    (hequiv :
+      ∀ (s : unitInterval) (u : Fin 2 → ℂˣ),
+        (∀ i, ‖(u i : ℂ)‖ = 1) →
+          ∀ x : CuspRetraction.ClosedTube η,
+            H (s, CuspRetraction.closedFibreAction η u x) =
+              CuspRetraction.closedFibreAction η u (H (s, x)))
+    (s : unitInterval) (u : Fin 2 → ℂˣ) (hu : ∀ i, ‖(u i : ℂ)‖ = 1)
+    (x : CuspRetraction.ClosedTube η) :
+    straightenedHomotopy C hε hε1 hC hRC hRD hηε H (s, CuspRetraction.closedFibreAction η u x) =
+      CuspRetraction.closedFibreAction η u
+        (straightenedHomotopy C hε hε1 hC hRC hRD hηε H (s, x)) := by
+  simp only [straightenedHomotopy_apply,
+    closedFrozenStraightening_fibre_torus C hε hε1 hC hRC hRD hηε u hu, hequiv s u hu,
+    closedFrozenStraightening_symm_fibre_torus C hε hε1 hC hRC hRD hηε u hu]
+
+private noncomputable def CuspRetraction.descentRepresentative_mo1973_10849
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hηε : η < ε) (q : ClosedQuotient C ε η) :
+    ClosedTube η :=
+  (closedQuotientMap_surjective C hηε q).choose
+
+private theorem CuspRetraction.descentRepresentative_spec_mo1973_10850
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hηε : η < ε) (q : ClosedQuotient C ε η) :
+    closedQuotientMap C hηε (descentRepresentative_mo1973_10849 C hηε q) = q :=
+  (closedQuotientMap_surjective C hηε q).choose_spec
+
+private noncomputable def CuspRetraction.closedHomotopyDescent (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hηε : η < ε) (H : C(unitInterval × ClosedTube η, ClosedTube η)) (s : unitInterval)
+    (q : ClosedQuotient C ε η) : ClosedQuotient C ε η :=
+  closedQuotientMap C hηε (H (s, descentRepresentative_mo1973_10849 C hηε q))
+
+private theorem CuspRetraction.closedHomotopyDescent_compatible (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hηε : η < ε) (H : C(unitInterval × ClosedTube η, ClosedTube η))
+    (hH :
+      ∀ (s : unitInterval) (v : Fin 2 → ℤ) (x : ClosedTube η),
+        H (s, closedTranslate C η v x) = closedTranslate C η v (H (s, x)))
+    (s : unitInterval) (x y : ClosedTube η)
+    (hxy : closedQuotientMap C hηε x = closedQuotientMap C hηε y) :
+    closedQuotientMap C hηε (H (s, x)) = closedQuotientMap C hηε (H (s, y)) := by
+  obtain ⟨v, hv⟩ := (closedQuotientMap_eq_iff C hηε x y).mp hxy
+  have hv' : closedTranslate C η v y = x := Subtype.ext hv
+  apply (closedQuotientMap_eq_iff C hηε _ _).mpr
+  refine ⟨v, ?_⟩
+  have he := hH s v y
+  rw [hv'] at he
+  exact (congrArg Subtype.val he).symm
+
+private theorem
+    CuspRetraction.closedHomotopyDescent_closedQuotientMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hηε : η < ε) (H : C(unitInterval × ClosedTube η, ClosedTube η))
+    (hH :
+      ∀ (s : unitInterval) (v : Fin 2 → ℤ) (x : ClosedTube η),
+        H (s, closedTranslate C η v x) = closedTranslate C η v (H (s, x)))
+    (s : unitInterval) (x : ClosedTube η) :
+    closedHomotopyDescent C hηε H s (closedQuotientMap C hηε x) =
+      closedQuotientMap C hηε (H (s, x)) :=
+  closedHomotopyDescent_compatible C hηε H hH s _ _
+    (descentRepresentative_spec_mo1973_10850 C hηε (closedQuotientMap C hηε x))
+
+private theorem CuspRetraction.closedHomotopyDescent_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hηε : η < ε) (H : C(unitInterval × ClosedTube η, ClosedTube η))
+    (hH :
+      ∀ (s : unitInterval) (v : Fin 2 → ℤ) (x : ClosedTube η),
+        H (s, closedTranslate C η v x) = closedTranslate C η v (H (s, x)))
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε)) :
+    Continuous
+      (fun p : unitInterval × ClosedQuotient C ε η => closedHomotopyDescent C hηε H p.1 p.2) := by
+  have hq := closedQuotientMap_isOpenQuotientMap C hηε hC
+  have hprod :
+    IsOpenQuotientMap (Prod.map (id : unitInterval → unitInterval) (closedQuotientMap C hηε)) :=
+    IsOpenQuotientMap.id.prodMap hq
+  apply hprod.continuous_comp_iff.mp
+  change
+    Continuous
+      (fun p : unitInterval × ClosedTube η =>
+        closedHomotopyDescent C hηε H p.1 (closedQuotientMap C hηε p.2))
+  simpa only [closedHomotopyDescent_closedQuotientMap C hηε H hH, Prod.mk.eta,
+    Function.comp_def] using hq.continuous.comp H.continuous
+
+private theorem
+    CuspRetraction.closedHomotopyDescent_zero (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ}
+    (hηε : η < ε) (H : C(unitInterval × ClosedTube η, ClosedTube η))
+    (hH :
+      ∀ (s : unitInterval) (v : Fin 2 → ℤ) (x : ClosedTube η),
+        H (s, closedTranslate C η v x) = closedTranslate C η v (H (s, x)))
+    (hzero : ∀ x : ClosedTube η, H (0, x) = x) (q : ClosedQuotient C ε η) :
+    closedHomotopyDescent C hηε H 0 q = q := by
+  obtain ⟨x, rfl⟩ := closedQuotientMap_surjective C hηε q
+  rw [closedHomotopyDescent_closedQuotientMap C hηε H hH, hzero]
+
+private theorem
+    CuspRetraction.closedHomotopyDescent_fixed (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ}
+    (hηε : η < ε) (H : C(unitInterval × ClosedTube η, ClosedTube η))
+    (hH :
+      ∀ (s : unitInterval) (v : Fin 2 → ℤ) (x : ClosedTube η),
+        H (s, closedTranslate C η v x) = closedTranslate C η v (H (s, x)))
+    (hfix :
+      ∀ (s : unitInterval) (x : ClosedTube η),
+        ToricSpace.time (x : ToricSpace.Space) = 0 → H (s, x) = x)
+    (s : unitInterval) (q : ClosedQuotient C ε η) (hq : CuspQuotient.projection C ε q = 0) :
+    closedHomotopyDescent C hηε H s q = q := by
+  obtain ⟨x, rfl⟩ := closedQuotientMap_surjective C hηε q
+  rw [closedHomotopyDescent_closedQuotientMap C hηε H hH, hfix s x hq]
+
+private theorem CuspRetraction.closedHomotopyDescent_one_central (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hηε : η < ε) (H : C(unitInterval × ClosedTube η, ClosedTube η))
+    (hH :
+      ∀ (s : unitInterval) (v : Fin 2 → ℤ) (x : ClosedTube η),
+        H (s, closedTranslate C η v x) = closedTranslate C η v (H (s, x)))
+    (hone : ∀ x : ClosedTube η, ToricSpace.time (H (1, x) : ToricSpace.Space) = 0)
+    (q : ClosedQuotient C ε η) :
+    CuspQuotient.projection C ε (closedHomotopyDescent C hηε H 1 q) = 0 := by
+  obtain ⟨x, rfl⟩ := closedQuotientMap_surjective C hηε q
+  rw [closedHomotopyDescent_closedQuotientMap C hηε H hH, closedQuotientMap_projection, hone]
+
+private theorem
+    CuspRetraction.closedHomotopyDescent_norm_nonincrease (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hηε : η < ε) (H : C(unitInterval × ClosedTube η, ClosedTube η))
+    (hH :
+      ∀ (s : unitInterval) (v : Fin 2 → ℤ) (x : ClosedTube η),
+        H (s, closedTranslate C η v x) = closedTranslate C η v (H (s, x)))
+    (hmono :
+      ∀ (s : unitInterval) (x : ClosedTube η),
+        ‖ToricSpace.time (H (s, x) : ToricSpace.Space)‖ ≤
+          ‖ToricSpace.time (x : ToricSpace.Space)‖)
+    (s : unitInterval) (q : ClosedQuotient C ε η) :
+    ‖CuspQuotient.projection C ε (closedHomotopyDescent C hηε H s q)‖ ≤
+      ‖CuspQuotient.projection C ε q‖ := by
+  obtain ⟨x, rfl⟩ := closedQuotientMap_surjective C hηε q
+  rw [closedHomotopyDescent_closedQuotientMap C hηε H hH, closedQuotientMap_projection,
+    closedQuotientMap_projection]
+  exact hmono s x
+
+private abbrev CuspRetraction.QuotientCentralFibre (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :=
+  { q : CuspQuotient.QuotientSpace C ε // CuspQuotient.projection C ε q = 0 }
+
+private def CuspRetraction.quotientCentralIntoClosed (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε η : ℝ)
+    (hη : 0 ≤ η) : C(QuotientCentralFibre C ε, ClosedQuotient C ε η)
+    where
+  toFun q := ⟨q, by rw [q.2, norm_zero]; exact hη⟩
+  continuous_toFun := continuous_subtype_val.subtype_mk _
+
+private noncomputable def CuspRetraction.closedHomotopyDescentRetraction
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hηε : η < ε)
+    (H : C(unitInterval × ClosedTube η, ClosedTube η))
+    (hH :
+      ∀ (s : unitInterval) (v : Fin 2 → ℤ) (x : ClosedTube η),
+        H (s, closedTranslate C η v x) = closedTranslate C η v (H (s, x)))
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hone : ∀ x : ClosedTube η, ToricSpace.time (H (1, x) : ToricSpace.Space) = 0) :
+    C(ClosedQuotient C ε η, QuotientCentralFibre C ε)
+    where
+  toFun
+    q := ⟨closedHomotopyDescent C hηε H 1 q, closedHomotopyDescent_one_central C hηε H hH hone q⟩
+  continuous_toFun :=
+    (continuous_subtype_val.comp
+          ((closedHomotopyDescent_continuous C hηε H hH hC).comp
+            (continuous_const.prodMk continuous_id))).subtype_mk
+      _
+
+private theorem CuspRetraction.closedHomotopyDescentRetraction_comp_inclusion
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hηε : η < ε)
+    (H : C(unitInterval × ClosedTube η, ClosedTube η))
+    (hH :
+      ∀ (s : unitInterval) (v : Fin 2 → ℤ) (x : ClosedTube η),
+        H (s, closedTranslate C η v x) = closedTranslate C η v (H (s, x)))
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hfix :
+      ∀ (s : unitInterval) (x : ClosedTube η),
+        ToricSpace.time (x : ToricSpace.Space) = 0 → H (s, x) = x)
+    (hone : ∀ x : ClosedTube η, ToricSpace.time (H (1, x) : ToricSpace.Space) = 0) (hη : 0 ≤ η) :
+    (closedHomotopyDescentRetraction C hηε H hH hC hone).comp
+        (quotientCentralIntoClosed C ε η hη) =
+      ContinuousMap.id (QuotientCentralFibre C ε) := by
+  apply ContinuousMap.ext
+  intro q
+  apply Subtype.ext
+  change
+    (closedHomotopyDescent C hηε H 1 (quotientCentralIntoClosed C ε η hη q) :
+        CuspQuotient.QuotientSpace C ε) =
+      (q : CuspQuotient.QuotientSpace C ε)
+  exact
+    congrArg Subtype.val
+      (closedHomotopyDescent_fixed C hηε H hH hfix 1 (quotientCentralIntoClosed C ε η hη q) q.2)
+
+private noncomputable def CuspRetraction.closedHomotopyDescentHomotopyRel
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hηε : η < ε)
+    (H : C(unitInterval × ClosedTube η, ClosedTube η))
+    (hH :
+      ∀ (s : unitInterval) (v : Fin 2 → ℤ) (x : ClosedTube η),
+        H (s, closedTranslate C η v x) = closedTranslate C η v (H (s, x)))
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hzero : ∀ x : ClosedTube η, H (0, x) = x)
+    (hfix :
+      ∀ (s : unitInterval) (x : ClosedTube η),
+        ToricSpace.time (x : ToricSpace.Space) = 0 → H (s, x) = x)
+    (hone : ∀ x : ClosedTube η, ToricSpace.time (H (1, x) : ToricSpace.Space) = 0) (hη : 0 ≤ η) :
+    (ContinuousMap.id (ClosedQuotient C ε η)).HomotopyRel
+      ((quotientCentralIntoClosed C ε η hη).comp
+        (closedHomotopyDescentRetraction C hηε H hH hC hone))
+      {q : ClosedQuotient C ε η | CuspQuotient.projection C ε q = 0}
+    where
+  toFun p := closedHomotopyDescent C hηε H p.1 p.2
+  continuous_toFun := closedHomotopyDescent_continuous C hηε H hH hC
+  map_zero_left := closedHomotopyDescent_zero C hηε H hH hzero
+  map_one_left _ := rfl
+  prop' s q hq := closedHomotopyDescent_fixed C hηε H hH hfix s q hq
+
+private theorem
+    CuspPositiveRetraction.exists_closed_tube_deformation (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {r : ℝ} (hr : 0 < r) (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 r)) :
+    ∃ η₀ : ℝ,
+      0 < η₀ ∧
+        η₀ < r ∧
+          η₀ < 1 ∧
+            ∀ η : ℝ,
+              0 < η →
+                η ≤ η₀ →
+                  ∃ H :
+                    C(unitInterval × CuspRetraction.ClosedTube η, CuspRetraction.ClosedTube η),
+                    (∀ x, H (0, x) = x) ∧
+                      (∀ s (x : CuspRetraction.ClosedTube η),
+                          ToricSpace.time (x : ToricSpace.Space) = 0 → H (s, x) = x) ∧
+                        (∀ x, ToricSpace.time (H (1, x) : ToricSpace.Space) = 0) ∧
+                          (∀ s v x,
+                              H (s, CuspRetraction.closedTranslate C η v x) =
+                                CuspRetraction.closedTranslate C η v (H (s, x))) ∧
+                            (∀ s (u : Fin 2 → ℂˣ),
+                                (∀ i, ‖(u i : ℂ)‖ = 1) →
+                                  ∀ x,
+                                    H (s, CuspRetraction.closedFibreAction η u x) =
+                                      CuspRetraction.closedFibreAction η u (H (s, x))) ∧
+                              (∀ s x,
+                                ‖ToricSpace.time (H (s, x) : ToricSpace.Space)‖ ≤
+                                  ‖ToricSpace.time (x : ToricSpace.Space)‖) := by
+  obtain ⟨ε, hε, hεr, hε1, hRC, hRD⟩ := CuspRetraction.exists_common_frozen_radius C hr hC
+  have hCε : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε) := fun i j =>
+    (hC i j).mono (Metric.ball_subset_ball hεr.le)
+  have hRP : ToricSpace.SmallDrift (CuspPositive.positiveTwist (C 0)) ε :=
+    CuspPositive.smallDrift_positiveTwist (C 0) hRD
+  obtain ⟨η₀, hη₀, hη₀ε, hH⟩ := exists_frozen_closed_deformation_below (C 0) ε hε hε1 hRP
+  refine ⟨η₀, hη₀, hη₀ε.trans hεr, hη₀ε.trans hε1, ?_⟩
+  intro η hη hηη₀
+  have hηε : η < ε := hηη₀.trans_lt hη₀ε
+  obtain ⟨H, hzero, hfix, hone, hequiv, _hcompact, hfibre, hmono⟩ := hH η hη hηη₀
+  refine
+    ⟨straightenedHomotopy C hε hε1 hCε hRC hRD hηε H,
+      straightenedHomotopy_zero C hε hε1 hCε hRC hRD hηε H hzero,
+      straightenedHomotopy_fixed C hε hε1 hCε hRC hRD hηε H hfix,
+      straightenedHomotopy_one_central C hε hε1 hCε hRC hRD hηε H hone,
+      straightenedHomotopy_equivariant C hε hε1 hCε hRC hRD hηε H hequiv,
+      straightenedHomotopy_fibre_torus_equivariant C hε hε1 hCε hRC hRD hηε H hfibre,
+      straightenedHomotopy_norm_time_le C hε hε1 hCε hRC hRD hηε H hmono⟩
+
+private theorem CuspPositiveRetraction.exists_closed_quotient_strongDeformationRetraction
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {r : ℝ} (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 r)) :
+    ∃ η₀ : ℝ,
+      0 < η₀ ∧
+        η₀ < r ∧
+          η₀ < 1 ∧
+            ∀ (η : ℝ) (hη : 0 < η),
+              η ≤ η₀ →
+                ∃ R :
+                  C(CuspRetraction.ClosedQuotient C r η, CuspRetraction.QuotientCentralFibre C r),
+                  R.comp (CuspRetraction.quotientCentralIntoClosed C r η hη.le) =
+                      ContinuousMap.id (CuspRetraction.QuotientCentralFibre C r) ∧
+                    ∃ H :
+                      (ContinuousMap.id (CuspRetraction.ClosedQuotient C r η)).HomotopyRel
+                        ((CuspRetraction.quotientCentralIntoClosed C r η hη.le).comp R)
+                        {q : CuspRetraction.ClosedQuotient C r η |
+                          CuspQuotient.projection C r q = 0},
+                      ∀ s q,
+                        ‖CuspQuotient.projection C r (H (s, q))‖ ≤
+                          ‖CuspQuotient.projection C r q‖ := by
+  obtain ⟨η₀, hη₀, hη₀r, hη₀1, hH⟩ :=
+    exists_closed_tube_deformation C hr (fun i j => (hC i j).continuousOn)
+  refine ⟨η₀, hη₀, hη₀r, hη₀1, ?_⟩
+  intro η hη hηη₀
+  have hηr : η < r := hηη₀.trans_lt hη₀r
+  obtain ⟨H, hzero, hfix, hone, hequiv, _hfibre, hmono⟩ := hH η hη hηη₀
+  refine
+    ⟨CuspRetraction.closedHomotopyDescentRetraction C hηr H hequiv hC hone,
+      CuspRetraction.closedHomotopyDescentRetraction_comp_inclusion C hηr H hequiv hC hfix hone
+        hη.le,
+      CuspRetraction.closedHomotopyDescentHomotopyRel C hηr H hequiv hC hzero hfix hone hη.le, ?_⟩
+  exact CuspRetraction.closedHomotopyDescent_norm_nonincrease C hηr H hequiv hmono
+
+private def CuspCentralHomology.centralIntoOpen (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ : ℝ)
+    (hδ : 0 < δ) : C(CuspRetraction.QuotientCentralFibre C r, OpenQuotient C r δ)
+    where
+  toFun
+    q :=
+    ⟨q.1, by
+      rw [q.2, norm_zero]
+      exact hδ⟩
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    exact continuous_subtype_val
+
+private def CuspCentralHomology.openIntoClosed (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ η : ℝ)
+    (hδη : δ ≤ η) : C(OpenQuotient C r δ, CuspRetraction.ClosedQuotient C r η)
+    where
+  toFun q := ⟨q, q.2.le.trans hδη⟩
+  continuous_toFun := continuous_subtype_val.subtype_mk _
+
+private def
+    CuspCentralHomology.restrictClosedRetraction (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ η : ℝ)
+    (hδη : δ ≤ η)
+    (R : C(CuspRetraction.ClosedQuotient C r η, CuspRetraction.QuotientCentralFibre C r)) :
+    C(OpenQuotient C r δ, CuspRetraction.QuotientCentralFibre C r) :=
+  R.comp (openIntoClosed C r δ η hδη)
+
+private theorem CuspCentralHomology.restrictClosedRetraction_comp_inclusion
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ η : ℝ) (hδ : 0 < δ) (hδη : δ ≤ η)
+    (R : C(CuspRetraction.ClosedQuotient C r η, CuspRetraction.QuotientCentralFibre C r))
+    (hR :
+      R.comp (CuspRetraction.quotientCentralIntoClosed C r η (hδ.le.trans hδη)) =
+        ContinuousMap.id (CuspRetraction.QuotientCentralFibre C r)) :
+    (restrictClosedRetraction C r δ η hδη R).comp (centralIntoOpen C r δ hδ) =
+      ContinuousMap.id (CuspRetraction.QuotientCentralFibre C r) := by
+  apply ContinuousMap.ext
+  intro q
+  exact ContinuousMap.congr_fun hR q
+
+private def
+    CuspCentralHomology.restrictClosedHomotopy (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ η : ℝ)
+    (hδ : 0 < δ) (hδη : δ ≤ η)
+    (R : C(CuspRetraction.ClosedQuotient C r η, CuspRetraction.QuotientCentralFibre C r))
+    (H :
+      (ContinuousMap.id (CuspRetraction.ClosedQuotient C r η)).HomotopyRel
+        ((CuspRetraction.quotientCentralIntoClosed C r η (hδ.le.trans hδη)).comp R)
+        {q : CuspRetraction.ClosedQuotient C r η | CuspQuotient.projection C r q = 0})
+    (hmono : ∀ s q, ‖CuspQuotient.projection C r (H (s, q))‖ ≤ ‖CuspQuotient.projection C r q‖) :
+    (ContinuousMap.id (OpenQuotient C r δ)).HomotopyRel
+      ((centralIntoOpen C r δ hδ).comp (restrictClosedRetraction C r δ η hδη R))
+      {q : OpenQuotient C r δ | CuspQuotient.projection C r q = 0}
+    where
+  toFun
+    p :=
+    ⟨H (p.1, openIntoClosed C r δ η hδη p.2),
+      (hmono p.1 (openIntoClosed C r δ η hδη p.2)).trans_lt p.2.2⟩
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    exact
+      continuous_subtype_val.comp
+        (H.continuous.comp
+          (continuous_fst.prodMk ((openIntoClosed C r δ η hδη).continuous.comp continuous_snd)))
+  map_zero_left
+    q := by
+    apply Subtype.ext
+    exact
+      congrArg
+        (fun x : CuspRetraction.ClosedQuotient C r η => (x : CuspQuotient.QuotientSpace C r))
+        (H.map_zero_left (openIntoClosed C r δ η hδη q))
+  map_one_left
+    q := by
+    apply Subtype.ext
+    exact
+      congrArg
+        (fun x : CuspRetraction.ClosedQuotient C r η => (x : CuspQuotient.QuotientSpace C r))
+        (H.map_one_left (openIntoClosed C r δ η hδη q))
+  prop' s q
+    hq := by
+    apply Subtype.ext
+    exact
+      congrArg
+        (fun x : CuspRetraction.ClosedQuotient C r η => (x : CuspQuotient.QuotientSpace C r))
+        (H.eq_fst s (show CuspQuotient.projection C r (openIntoClosed C r δ η hδη q) = 0 from hq))
+
+private def
+    CuspCentralHomology.openCentralHomotopyEquiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ η : ℝ)
+    (hδ : 0 < δ) (hδη : δ ≤ η)
+    (R : C(CuspRetraction.ClosedQuotient C r η, CuspRetraction.QuotientCentralFibre C r))
+    (hR :
+      R.comp (CuspRetraction.quotientCentralIntoClosed C r η (hδ.le.trans hδη)) =
+        ContinuousMap.id (CuspRetraction.QuotientCentralFibre C r))
+    (H :
+      (ContinuousMap.id (CuspRetraction.ClosedQuotient C r η)).HomotopyRel
+        ((CuspRetraction.quotientCentralIntoClosed C r η (hδ.le.trans hδη)).comp R)
+        {q : CuspRetraction.ClosedQuotient C r η | CuspQuotient.projection C r q = 0})
+    (hmono : ∀ s q, ‖CuspQuotient.projection C r (H (s, q))‖ ≤ ‖CuspQuotient.projection C r q‖) :
+    CuspRetraction.QuotientCentralFibre C r ≃ₕ OpenQuotient C r δ
+    where
+  toFun := centralIntoOpen C r δ hδ
+  invFun := restrictClosedRetraction C r δ η hδη R
+  left_inv := by rw [restrictClosedRetraction_comp_inclusion C r δ η hδ hδη R hR]
+  right_inv := ⟨(restrictClosedHomotopy C r δ η hδ hδη R H hmono).toHomotopy.symm⟩
+
+private def
+    CuspCentralHomology.centralIntoSmallerQuotient (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ : ℝ)
+    (hδ : 0 < δ) (hδr : δ ≤ r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    C(CuspRetraction.QuotientCentralFibre C r, CuspQuotient.QuotientSpace C δ) :=
+  ((openQuotientRadiusHomeomorph C hδr hC).symm :
+        C(OpenQuotient C r δ, CuspQuotient.QuotientSpace C δ)).comp
+    (centralIntoOpen C r δ hδ)
+
+private theorem
+    CuspCentralHomology.exists_centralHomotopyEquiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    ∃ δ₀ : ℝ,
+      0 < δ₀ ∧
+        δ₀ < r ∧
+          δ₀ < 1 ∧
+            ∀ (δ : ℝ) (hδ : 0 < δ),
+              δ ≤ δ₀ →
+                ∀ hδr : δ ≤ r,
+                  ∃ e : CuspRetraction.QuotientCentralFibre C r ≃ₕ CuspQuotient.QuotientSpace C δ,
+                    e.toFun = centralIntoSmallerQuotient C r δ hδ hδr hC := by
+  obtain ⟨δ₀, hδ₀, hδ₀r, hδ₀1, hex⟩ :=
+    CuspPositiveRetraction.exists_closed_quotient_strongDeformationRetraction C hr hC
+  refine ⟨δ₀, hδ₀, hδ₀r, hδ₀1, ?_⟩
+  intro δ hδ hδδ₀ hδr
+  obtain ⟨R, hR, H, hmono⟩ := hex δ₀ hδ₀ le_rfl
+  let e := openCentralHomotopyEquiv C r δ δ₀ hδ hδδ₀ R hR H hmono
+  refine ⟨e.trans (openQuotientRadiusHomeomorph C hδr hC).symm.toHomotopyEquiv, rfl⟩
+
+private abbrev CuspPositiveRetraction.PositiveCentralFibre :=
+  { q : ToricSpace.PositivePart // ToricSpace.time (q : ToricSpace.Space) = 0 }
+
+private def CuspPositiveRetraction.positiveCentralInclusion (η : ℝ) (hη : 0 ≤ η) :
+    C(PositiveCentralFibre, ToricSpace.ClosedPositiveTube η)
+    where
+  toFun q := ⟨q.1, by rw [q.2, norm_zero]; exact hη⟩
+  continuous_toFun := continuous_subtype_val.subtype_mk _
+
+private theorem CuspCollapse.exists_compactFibreAction_modulus {x : ToricSpace.Space}
+    (hx : ToricSpace.time x = 0) :
+    ∃ u : ToricSpace.CompactFibreTorus,
+      ToricSpace.compactFibreAction u (ToricSpace.modulus x) = x := by
+  obtain ⟨u, hu⟩ := ToricSpace.exists_compactTorusAction_modulus x
+  have hzero : ToricSpace.time (ToricSpace.modulus x) = 0 := by
+    simp only [ToricSpace.time_modulus, hx, norm_zero, Complex.ofReal_zero]
+  obtain ⟨v, hv⟩ := (ToricSpace.branchVertices_nonempty (ToricSpace.modulus x)).mpr hzero
+  let w : ToricSpace.CompactTorus := u * ToricSpace.rayCompactPhase v (u 2)⁻¹
+  have hw : w 2 = 1 := by
+    simp only [w, Pi.mul_apply, ToricSpace.rayCompactPhase_two, mul_inv_cancel]
+  let uf : ToricSpace.CompactFibreTorus := ![w 0, w 1]
+  have hf : ToricSpace.compactFibrePhase uf = w := by
+    funext i
+    fin_cases i
+    · rfl
+    · rfl
+    · exact hw.symm
+  refine ⟨uf, ?_⟩
+  rw [ToricSpace.compactFibreAction_eq_compact, hf]
+  change
+    ToricSpace.compactTorusAction (u * ToricSpace.rayCompactPhase v (u 2)⁻¹)
+        (ToricSpace.modulus x) =
+      x
+  rw [← ToricSpace.compactTorusAction_mul,
+    ToricSpace.rayCompactPhase_fixes_of_mem_rayDivisor v (u 2)⁻¹ hv]
+  exact hu
+
+private theorem CuspCollapse.positiveCentral_isClosed :
+    IsClosed {q : ToricSpace.PositivePart | ToricSpace.time (q : ToricSpace.Space) = 0} :=
+  isClosed_eq (ToricSpace.time_holomorphic.continuous.comp continuous_subtype_val)
+    continuous_const
+
+private theorem CuspCollapse.positiveCentralVal_isClosedEmbedding :
+    Topology.IsClosedEmbedding
+      (fun q : CuspPositiveRetraction.PositiveCentralFibre => (q.1 : ToricSpace.Space)) :=
+  ToricSpace.positivePart_isClosed.isClosedEmbedding_subtypeVal.comp
+    positiveCentral_isClosed.isClosedEmbedding_subtypeVal
+
+private def CuspCollapse.centralPolarMap
+    (p : ToricSpace.CompactFibreTorus × CuspPositiveRetraction.PositiveCentralFibre) :
+    CuspRetraction.CentralFibre :=
+  ⟨ToricSpace.compactFibreAction p.1 (p.2.1 : ToricSpace.Space), by
+    rw [ToricSpace.time_compactFibreAction, p.2.2]⟩
+
+@[simp]
+private theorem CuspCollapse.centralPolarMap_coe
+    (p : ToricSpace.CompactFibreTorus × CuspPositiveRetraction.PositiveCentralFibre) :
+    (centralPolarMap p : ToricSpace.Space) =
+      ToricSpace.compactFibreAction p.1 (p.2.1 : ToricSpace.Space) :=
+  rfl
+
+private theorem CuspCollapse.centralPolarMap_continuous : Continuous centralPolarMap :=
+  (ToricSpace.compactFibreAction_continuous.comp
+        (continuous_fst.prodMk
+          ((continuous_subtype_val.comp continuous_subtype_val).comp continuous_snd))).subtype_mk
+    _
+
+private theorem CuspCollapse.modulus_centralPolarMap
+    (p : ToricSpace.CompactFibreTorus × CuspPositiveRetraction.PositiveCentralFibre) :
+    ToricSpace.modulus (centralPolarMap p : ToricSpace.Space) = (p.2.1 : ToricSpace.Space) := by
+  rw [centralPolarMap_coe, ToricSpace.modulus_compactFibreAction]
+  exact p.2.1.2
+
+private def CuspCollapse.centralModulus (x : CuspRetraction.CentralFibre) :
+    CuspPositiveRetraction.PositiveCentralFibre :=
+  ⟨ToricSpace.modulusRetraction x, by
+    simp only [ToricSpace.modulusRetraction_coe, ToricSpace.time_modulus, x.2, norm_zero,
+      Complex.ofReal_zero]⟩
+
+@[simp]
+private theorem CuspCollapse.centralModulus_centralPolarMap
+    (p : ToricSpace.CompactFibreTorus × CuspPositiveRetraction.PositiveCentralFibre) :
+    centralModulus (centralPolarMap p) = p.2 :=
+  Subtype.ext (Subtype.ext (modulus_centralPolarMap p))
+
+private theorem CuspCollapse.centralPolarMap_surjective : Function.Surjective centralPolarMap := by
+  intro x
+  obtain ⟨u, hu⟩ := exists_compactFibreAction_modulus x.2
+  exact ⟨(u, centralModulus x), Subtype.ext hu⟩
+
+private theorem CuspCollapse.centralPolarMap_isProperMap : IsProperMap centralPolarMap := by
+  have hinc :
+    IsProperMap
+      (fun p : ToricSpace.CompactFibreTorus × CuspPositiveRetraction.PositiveCentralFibre =>
+        (p.1, (p.2.1 : ToricSpace.Space))) :=
+    ((Homeomorph.refl ToricSpace.CompactFibreTorus).isClosedEmbedding.prodMap
+        positiveCentralVal_isClosedEmbedding).isProperMap
+  have hcomp :
+    IsProperMap
+      ((Subtype.val : CuspRetraction.CentralFibre → ToricSpace.Space) ∘ centralPolarMap) :=
+    ToricSpace.compactFibreAction_isProperMap.comp hinc
+  exact
+    isProperMap_of_comp_of_inj centralPolarMap_continuous continuous_subtype_val hcomp
+      Subtype.val_injective
+
+private theorem CuspCollapse.centralPolarMap_isClosedMap : IsClosedMap centralPolarMap :=
+  centralPolarMap_isProperMap.isClosedMap
+
+private theorem
+    CuspCollapse.centralPolarMap_isQuotientMap : Topology.IsQuotientMap centralPolarMap :=
+  centralPolarMap_isClosedMap.isQuotientMap centralPolarMap_continuous centralPolarMap_surjective
+
+private theorem CuspCollapse.centralPolarMap_eq_iff
+    (p q : ToricSpace.CompactFibreTorus × CuspPositiveRetraction.PositiveCentralFibre) :
+    centralPolarMap p = centralPolarMap q ↔
+      p.2 = q.2 ∧
+        p.1⁻¹ * q.1 ∈
+          MulAction.stabilizer ToricSpace.CompactFibreTorus (p.2.1 : ToricSpace.Space) := by
+  rcases p with ⟨u, x⟩
+  rcases q with ⟨v, y⟩
+  constructor
+  · intro h
+    have hxy : x = y := by
+      simpa only [centralModulus_centralPolarMap] using congrArg centralModulus h
+    subst y
+    refine ⟨rfl, ?_⟩
+    rw [MulAction.mem_stabilizer_iff]
+    have he : u • (x.1 : ToricSpace.Space) = v • (x.1 : ToricSpace.Space) :=
+      congrArg Subtype.val h
+    rw [SemigroupAction.mul_smul, ← he, inv_smul_smul]
+  · rintro ⟨hxy, h⟩
+    change x = y at hxy
+    subst y
+    have hs := congrArg (fun z : ToricSpace.Space => u • z) (MulAction.mem_stabilizer_iff.mp h)
+    apply Subtype.ext
+    change u • (x.1 : ToricSpace.Space) = v • (x.1 : ToricSpace.Space)
+    simpa only [smul_smul, mul_inv_cancel_left] using hs.symm
+
+private def CuspCollapse.deckFibrePhase (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ) :
+    ToricSpace.CompactFibreTorus := fun i => CuspPositive.frozenPhaseCoordinate C₀ v i
+
+@[simp]
+private theorem CuspCollapse.deckFibrePhase_zero (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    deckFibrePhase C₀ 0 = 1 := by
+  funext i
+  apply Circle.ext
+  simp only [deckFibrePhase, CuspPositive.frozenPhaseCoordinate_coe,
+    ToricSpace.exponentialMultiplier_zero, Pi.one_apply, Units.val_one, one_div, inv_one,
+    Circle.coe_one]
+
+private theorem CuspCollapse.deckFibrePhase_add (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (v w : Fin 2 → ℤ) :
+    deckFibrePhase C₀ (v + w) = deckFibrePhase C₀ v * deckFibrePhase C₀ w := by
+  funext i
+  apply Circle.ext
+  simp only [deckFibrePhase, CuspPositive.frozenPhaseCoordinate_coe, Pi.mul_apply, Circle.coe_mul]
+  rw [ToricSpace.exponentialMultiplier_add, ToricSpace.exponentialMultiplier_add]
+  simp only [Pi.mul_apply, Units.val_mul, div_mul_div_comm]
+
+private theorem CuspCollapse.phaseTransform_compactFibrePhase (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) (u : ToricSpace.CompactFibreTorus) :
+    CuspPositive.phaseTransform C₀ v (ToricSpace.compactFibrePhase u) =
+      ToricSpace.compactFibrePhase (deckFibrePhase C₀ v * u) := by
+  funext i
+  fin_cases i <;>
+    simp [CuspPositive.phaseTransform, CuspPositive.frozenPhase, ToricSpace.phaseShear,
+      ToricSpace.compactFibrePhase, deckFibrePhase]
+
+private def CuspCollapse.positiveCentralTranslate (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ)
+    (q : CuspPositiveRetraction.PositiveCentralFibre) :
+    CuspPositiveRetraction.PositiveCentralFibre :=
+  ⟨⟨ToricSpace.twistedTranslate (CuspPositive.positiveTwist C₀) v (q.1 : ToricSpace.Space),
+      CuspPositive.twistedTranslate_positiveTwist_preserves_positivePart C₀ v q.1.2⟩,
+    by rw [ToricSpace.time_twistedTranslate, q.2]⟩
+
+@[simp]
+private theorem
+    CuspCollapse.positiveCentralTranslate_coe (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ)
+    (q : CuspPositiveRetraction.PositiveCentralFibre) :
+    ((positiveCentralTranslate C₀ v q).1 : ToricSpace.Space) =
+      ToricSpace.twistedTranslate (CuspPositive.positiveTwist C₀) v (q.1 : ToricSpace.Space) :=
+  rfl
+
+@[simp]
+private theorem CuspCollapse.positiveCentralTranslate_zero (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (q : CuspPositiveRetraction.PositiveCentralFibre) : positiveCentralTranslate C₀ 0 q = q :=
+  Subtype.ext (Subtype.ext (ToricSpace.twistedTranslate_zero (CuspPositive.positiveTwist C₀) q.1))
+
+private theorem CuspCollapse.positiveCentralTranslate_add (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v w : Fin 2 → ℤ) (q : CuspPositiveRetraction.PositiveCentralFibre) :
+    positiveCentralTranslate C₀ v (positiveCentralTranslate C₀ w q) =
+      positiveCentralTranslate C₀ (v + w) q :=
+  Subtype.ext
+    (Subtype.ext (ToricSpace.twistedTranslate_add (CuspPositive.positiveTwist C₀) v w q.1))
+
+private theorem CuspCollapse.positiveCentralTranslate_continuous (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) : Continuous (positiveCentralTranslate C₀ v) :=
+  (((ToricSpace.centralTranslationHomeomorph (CuspPositive.positiveTwist C₀) v).continuous.comp
+            (continuous_subtype_val.comp continuous_subtype_val)).subtype_mk
+        _).subtype_mk
+    _
+
+private def CuspCollapse.positiveCentralHomeomorph (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ) :
+    CuspPositiveRetraction.PositiveCentralFibre ≃ₜ CuspPositiveRetraction.PositiveCentralFibre
+    where
+  toFun := positiveCentralTranslate C₀ v
+  invFun := positiveCentralTranslate C₀ (-v)
+  left_inv
+    q := by rw [positiveCentralTranslate_add, neg_add_cancel, positiveCentralTranslate_zero]
+  right_inv
+    q := by rw [positiveCentralTranslate_add, add_neg_cancel, positiveCentralTranslate_zero]
+  continuous_toFun := positiveCentralTranslate_continuous C₀ v
+  continuous_invFun := positiveCentralTranslate_continuous C₀ (-v)
+
+private def CuspCollapse.phaseDeckMap (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ)
+    (p : ToricSpace.CompactFibreTorus × CuspPositiveRetraction.PositiveCentralFibre) :
+    ToricSpace.CompactFibreTorus × CuspPositiveRetraction.PositiveCentralFibre :=
+  (deckFibrePhase C₀ v * p.1, positiveCentralTranslate C₀ v p.2)
+
+private theorem CuspCollapse.twistedTranslate_central_eq_constant (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) {x : ToricSpace.Space} (hx : ToricSpace.time x = 0) :
+    ToricSpace.twistedTranslate C v x = ToricSpace.twistedTranslate (fun _ => C 0) v x := by
+  simp only [ToricSpace.twistedTranslate, ToricSpace.variableMultiplier,
+    ToricSpace.time_translate, hx]
+  rfl
+
+private theorem CuspCollapse.centralPolarMap_phaseDeckMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ)
+    (p : ToricSpace.CompactFibreTorus × CuspPositiveRetraction.PositiveCentralFibre) :
+    (centralPolarMap (phaseDeckMap (C 0) v p) : ToricSpace.Space) =
+      ToricSpace.twistedTranslate C v (centralPolarMap p : ToricSpace.Space) := by
+  rw [twistedTranslate_central_eq_constant C v (centralPolarMap p).2]
+  change
+    ToricSpace.compactFibreAction (deckFibrePhase (C 0) v * p.1)
+        ((positiveCentralTranslate (C 0) v p.2).1 : ToricSpace.Space) =
+      ToricSpace.twistedTranslate (fun _ => C 0) v
+        (ToricSpace.compactFibreAction p.1 (p.2.1 : ToricSpace.Space))
+  rw [ToricSpace.compactFibreAction_eq_compact, ToricSpace.compactFibreAction_eq_compact,
+    CuspPositive.twistedTranslate_constant_polar, phaseTransform_compactFibrePhase]
+  rfl
+
+private noncomputable def CuspCollapse.centralClosedZeroHomeomorph :
+    CuspRetraction.CentralFibre ≃ₜ CuspRetraction.ClosedTube 0 :=
+  Homeomorph.setCongr
+    (by
+      ext x
+      exact norm_le_zero_iff.symm)
+
+private noncomputable def CuspCollapse.quotientCentralClosedZeroHomeomorph
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    CuspRetraction.QuotientCentralFibre C ε ≃ₜ CuspRetraction.ClosedQuotient C ε 0 :=
+  Homeomorph.setCongr
+    (by
+      ext q
+      exact norm_le_zero_iff.symm)
+
+private noncomputable def CuspCollapse.centralProject (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (x : CuspRetraction.CentralFibre) : CuspRetraction.QuotientCentralFibre C ε :=
+  ⟨CuspQuotient.quotientMap C ε
+      ⟨x, by
+        change ToricSpace.time (x : ToricSpace.Space) ∈ Metric.ball 0 ε
+        rw [x.2]
+        simpa only [Metric.mem_ball, dist_self] using hε⟩,
+    x.2⟩
+
+private theorem CuspCollapse.centralProject_eq_comp (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) :
+    centralProject C ε hε =
+      (quotientCentralClosedZeroHomeomorph C ε).symm ∘
+        (CuspRetraction.closedQuotientMap C hε ∘ centralClosedZeroHomeomorph) :=
+  rfl
+
+private theorem CuspCollapse.centralProject_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : Continuous (centralProject C ε hε) := by
+  apply Continuous.subtype_mk
+  exact (CuspQuotient.quotientMap_continuous C ε).comp (continuous_subtype_val.subtype_mk _)
+
+private theorem CuspCollapse.centralProject_surjective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : Function.Surjective (centralProject C ε hε) := by
+  rw [centralProject_eq_comp]
+  exact
+    (quotientCentralClosedZeroHomeomorph C ε).symm.surjective.comp
+      ((CuspRetraction.closedQuotientMap_surjective C hε).comp
+        centralClosedZeroHomeomorph.surjective)
+
+private theorem
+    CuspCollapse.centralProject_isOpenQuotientMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε)) :
+    IsOpenQuotientMap (centralProject C ε hε) := by
+  rw [centralProject_eq_comp]
+  exact
+    (quotientCentralClosedZeroHomeomorph C ε).symm.isOpenQuotientMap.comp
+      ((CuspRetraction.closedQuotientMap_isOpenQuotientMap C hε hC).comp
+        centralClosedZeroHomeomorph.isOpenQuotientMap)
+
+private theorem CuspCollapse.centralProject_isQuotientMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε)) :
+    Topology.IsQuotientMap (centralProject C ε hε) :=
+  (centralProject_isOpenQuotientMap C ε hε hC).isQuotientMap
+
+private theorem
+    CuspCollapse.centralProject_eq_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (x y : CuspRetraction.CentralFibre) :
+    centralProject C ε hε x = centralProject C ε hε y ↔
+      ∃ v : Fin 2 → ℤ,
+        ToricSpace.twistedTranslate C v (y : ToricSpace.Space) = (x : ToricSpace.Space) := by
+  rw [← (quotientCentralClosedZeroHomeomorph C ε).injective.eq_iff]
+  change
+    CuspRetraction.closedQuotientMap C hε (centralClosedZeroHomeomorph x) =
+        CuspRetraction.closedQuotientMap C hε (centralClosedZeroHomeomorph y) ↔
+      _
+  exact CuspRetraction.closedQuotientMap_eq_iff C hε _ _
+
+private abbrev CuspCollapse.PhasePositiveSpace :=
+  ToricSpace.CompactFibreTorus × CuspPositiveRetraction.PositiveCentralFibre
+
+private def
+    CuspCollapse.centralCollapseMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    PhasePositiveSpace → CuspRetraction.QuotientCentralFibre C ε :=
+  centralProject C ε hε ∘ centralPolarMap
+
+private theorem
+    CuspCollapse.centralCollapseMap_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : Continuous (centralCollapseMap C ε hε) :=
+  (centralProject_continuous C ε hε).comp centralPolarMap_continuous
+
+private theorem
+    CuspCollapse.centralCollapseMap_surjective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : Function.Surjective (centralCollapseMap C ε hε) :=
+  (centralProject_surjective C ε hε).comp centralPolarMap_surjective
+
+private theorem
+    CuspCollapse.centralCollapseMap_isQuotientMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε)) :
+    Topology.IsQuotientMap (centralCollapseMap C ε hε) :=
+  (centralProject_isQuotientMap C ε hε hC).comp centralPolarMap_isQuotientMap
+
+private def CuspCollapse.centralCollapseRelation (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (p q : PhasePositiveSpace) : Prop :=
+  ∃ v : Fin 2 → ℤ,
+    p.2 = positiveCentralTranslate C₀ v q.2 ∧
+      p.1⁻¹ * (deckFibrePhase C₀ v * q.1) ∈
+        MulAction.stabilizer ToricSpace.CompactFibreTorus (p.2.1 : ToricSpace.Space)
+
+private theorem CuspCollapse.centralCollapseMap_eq_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (p q : PhasePositiveSpace) :
+    centralCollapseMap C ε hε p = centralCollapseMap C ε hε q ↔
+      centralCollapseRelation (C 0) p q := by
+  change centralProject C ε hε (centralPolarMap p) = centralProject C ε hε (centralPolarMap q) ↔ _
+  rw [centralProject_eq_iff]
+  constructor
+  · rintro ⟨v, hv⟩
+    have hpq : centralPolarMap p = centralPolarMap (phaseDeckMap (C 0) v q) := by
+      apply Subtype.ext
+      exact ((centralPolarMap_phaseDeckMap C v q).trans hv).symm
+    exact ⟨v, (centralPolarMap_eq_iff p (phaseDeckMap (C 0) v q)).mp hpq⟩
+  · rintro ⟨v, hv⟩
+    have hpq : centralPolarMap p = centralPolarMap (phaseDeckMap (C 0) v q) :=
+      (centralPolarMap_eq_iff p (phaseDeckMap (C 0) v q)).mpr hv
+    refine ⟨v, ?_⟩
+    rw [← centralPolarMap_phaseDeckMap C v q]
+    exact congrArg Subtype.val hpq.symm
+
+private def
+    CuspCollapse.centralCollapseSetoid (C₀ : Matrix (Fin 2) (Fin 2) ℂ) : Setoid PhasePositiveSpace
+    where
+  r := centralCollapseRelation C₀
+  iseqv := by
+    let f := centralCollapseMap (fun _ => C₀) 1 zero_lt_one
+    have he (p q : PhasePositiveSpace) : f p = f q ↔ centralCollapseRelation C₀ p q :=
+      centralCollapseMap_eq_iff (fun _ => C₀) 1 zero_lt_one p q
+    exact
+      { refl := fun p => (he p p).mp rfl
+        symm := fun {p q} h => (he q p).mp ((he p q).mpr h).symm
+        trans := fun {p q r} hpq hqr =>
+          (he p r).mp (((he p q).mpr hpq).trans ((he q r).mpr hqr)) }
+
+private abbrev CuspCollapse.CentralCollapseModel (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :=
+  Quotient (centralCollapseSetoid C₀)
+
+private def
+    CuspCollapse.centralCollapseModelMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    CentralCollapseModel (C 0) → CuspRetraction.QuotientCentralFibre C ε :=
+  Quotient.lift (centralCollapseMap C ε hε)
+    (fun p q h => (centralCollapseMap_eq_iff C ε hε p q).mpr h)
+
+private theorem
+    CuspCollapse.centralCollapseModelMap_bijective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : Function.Bijective (centralCollapseModelMap C ε hε) := by
+  constructor
+  · intro p q
+    induction p using Quotient.inductionOn with
+    | h p =>
+      induction q using Quotient.inductionOn with
+      | h q =>
+        intro h
+        exact Quotient.sound ((centralCollapseMap_eq_iff C ε hε p q).mp h)
+  · intro x
+    obtain ⟨p, hp⟩ := centralCollapseMap_surjective C ε hε x
+    exact ⟨Quotient.mk (centralCollapseSetoid (C 0)) p, hp⟩
+
+private def
+    CuspCollapse.centralCollapseEquiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    CentralCollapseModel (C 0) ≃ CuspRetraction.QuotientCentralFibre C ε :=
+  Equiv.ofBijective (centralCollapseModelMap C ε hε) (centralCollapseModelMap_bijective C ε hε)
+
+@[simp]
+private theorem
+    CuspCollapse.centralCollapseEquiv_symm_map (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (p : PhasePositiveSpace) :
+    (centralCollapseEquiv C ε hε).symm (centralCollapseMap C ε hε p) =
+      Quotient.mk (centralCollapseSetoid (C 0)) p := by
+  apply (centralCollapseEquiv C ε hε).injective
+  rw [Equiv.apply_symm_apply]
+  rfl
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/CuspFibre/CuspSpecialization.lean b/LeanPool/HopfProblem/CuspFibre/CuspSpecialization.lean
new file mode 100644
index 000000000..e7d2e8bec
--- /dev/null
+++ b/LeanPool/HopfProblem/CuspFibre/CuspSpecialization.lean
@@ -0,0 +1,4181 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.CuspFibre.CuspCentralHomology3
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.Foundations.InvariantSubsetQuotient
+import all LeanPool.HopfProblem.Toric.ToricSpace2
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.CuspFibre.CuspPositiveRetraction
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Toric.CuspHoneycombHexagon
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology7
+import all LeanPool.HopfProblem.CuspFibre.CuspCentralHomology3
+
+/-!
+# Hopf problem: cusp fibre · cusp specialization
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def
+    CuspControlledRetraction.Concatenation.connectingHomotopy {X Y : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] (P K : C(unitInterval × X, Y)) (hjoin : ∀ x, K (0, x) = P (1, x)) :
+    (slice P 1).Homotopy (slice K 1)
+    where
+  toContinuousMap := K
+  map_zero_left := hjoin
+  map_one_left _ := rfl
+
+private def CuspControlledRetraction.Concatenation.map {X Y : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] (P K : C(unitInterval × X, Y)) (hjoin : ∀ x, K (0, x) = P (1, x)) :
+    C(unitInterval × X, Y) :=
+  ((asHomotopy P).trans (connectingHomotopy P K hjoin)).toContinuousMap
+
+@[simp]
+private theorem CuspControlledRetraction.Concatenation.map_zero {X Y : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] (P K : C(unitInterval × X, Y)) (hjoin : ∀ x, K (0, x) = P (1, x))
+    (x : X) : CuspControlledRetraction.Concatenation.map P K hjoin (0, x) = P (0, x) :=
+  ContinuousMap.Homotopy.apply_zero _ x
+
+@[simp]
+private theorem CuspControlledRetraction.Concatenation.map_one {X Y : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] (P K : C(unitInterval × X, Y)) (hjoin : ∀ x, K (0, x) = P (1, x))
+    (x : X) : CuspControlledRetraction.Concatenation.map P K hjoin (1, x) = K (1, x) :=
+  ContinuousMap.Homotopy.apply_one _ x
+
+private theorem
+    CuspControlledRetraction.Concatenation.map_property {X Y : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] (P K : C(unitInterval × X, Y)) (hjoin : ∀ x, K (0, x) = P (1, x))
+    (R : C(X, Y) → Prop) (hP : ∀ s, R (slice P s)) (hK : ∀ s, R (slice K s)) (s : unitInterval) :
+    R (slice (CuspControlledRetraction.Concatenation.map P K hjoin) s) := by
+  let F : (slice P 0).HomotopyWith (slice P 1) R :=
+    { toHomotopy := asHomotopy P
+      prop' := hP }
+  let G : (slice P 1).HomotopyWith (slice K 1) R :=
+    { toHomotopy := connectingHomotopy P K hjoin
+      prop' := hK }
+  exact (F.trans G).prop s
+
+private theorem
+    CuspControlledRetraction.exists_positive_modification (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε)
+    (hηε : η < ε) (hη : 0 ≤ η) (ρ : ℝ) (hρ : 0 < ρ)
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hzero : ∀ q, P (0, q) = q)
+    (hfix :
+      ∀ s (q : ToricSpace.ClosedPositiveTube η),
+        ToricSpace.time (q.1 : ToricSpace.Space) = 0 → P (s, q) = q)
+    (hone :
+      ∀ q : ToricSpace.ClosedPositiveTube η,
+        ToricSpace.time ((P (1, q)).1 : ToricSpace.Space) = 0)
+    (hequiv :
+      ∀ s v q,
+        P (s, CuspPositive.closedPositiveTranslate C₀ η v q) =
+          CuspPositive.closedPositiveTranslate C₀ η v (P (s, q)))
+    (hmono : ∀ s q, positiveHeight (P (s, q)) ≤ positiveHeight q) :
+    ∃ Q : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η),
+      (∀ q, Q (0, q) = q) ∧
+        (∀ s (q : ToricSpace.ClosedPositiveTube η),
+            ToricSpace.time (q.1 : ToricSpace.Space) = 0 → Q (s, q) = q) ∧
+          (∀ q : ToricSpace.ClosedPositiveTube η,
+              ToricSpace.time ((Q (1, q)).1 : ToricSpace.Space) = 0) ∧
+            (∀ s v q,
+                Q (s, CuspPositive.closedPositiveTranslate C₀ η v q) =
+                  CuspPositive.closedPositiveTranslate C₀ η v (Q (s, q))) ∧
+              (∀ s q, positiveHeight (Q (s, q)) ≤ positiveHeight q) ∧
+                (∀ q,
+                    positiveHeight q = ρ →
+                      Q (1, q) =
+                        CuspPositiveRetraction.positiveCentralInclusion η hη
+                          (CuspHoneycomb.honeycombHomeomorph C₀
+                            (normalizedPosition C₀ (q.1 : ToricSpace.Space)))) ∧
+                  (∀ q, positiveHeight q ≤ ρ / 2 → Q (1, q) = P (1, q)) := by
+  let K := centralInterpolation P hone C₀ hε1 hR hηε hη ρ hρ
+  have hjoin : ∀ q, K (0, q) = P (1, q) := centralInterpolation_zero P hone C₀ hε1 hR hηε hη ρ hρ
+  let Q := Concatenation.map P K hjoin
+  let R : C(ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η) → Prop := fun f =>
+    (∀ q : ToricSpace.ClosedPositiveTube η,
+        ToricSpace.time (q.1 : ToricSpace.Space) = 0 → f q = q) ∧
+      (∀ v q,
+          f (CuspPositive.closedPositiveTranslate C₀ η v q) =
+            CuspPositive.closedPositiveTranslate C₀ η v (f q)) ∧
+        (∀ q, positiveHeight (f q) ≤ positiveHeight q)
+  have hQP (s : unitInterval) : R (Concatenation.slice Q s) := by
+    apply Concatenation.map_property P K hjoin R
+    · intro t
+      exact ⟨hfix t, hequiv t, hmono t⟩
+    · intro t
+      exact
+        ⟨centralInterpolation_fixed P hone C₀ hε1 hR hηε hη ρ hρ hfix t,
+          centralInterpolation_equivariant P hone C₀ hε1 hR hηε hη ρ hρ hequiv t,
+          centralInterpolation_nonincreasing P hone C₀ hε1 hR hηε hη ρ hρ t⟩
+  refine ⟨Q, ?_, ?_, ?_, ?_, ?_, ?_, ?_⟩
+  · intro q
+    exact (Concatenation.map_zero P K hjoin q).trans (hzero q)
+  · intro s q hq
+    exact (hQP s).1 q hq
+  · intro q
+    change ToricSpace.time (((Concatenation.map P K hjoin) (1, q)).1 : ToricSpace.Space) = 0
+    rw [Concatenation.map_one]
+    exact centralInterpolation_central P hone C₀ hε1 hR hηε hη ρ hρ 1 q
+  · intro s v q
+    exact (hQP s).2.1 v q
+  · intro s q
+    exact (hQP s).2.2 q
+  · intro q hq
+    exact
+      (Concatenation.map_one P K hjoin q).trans
+        (centralInterpolation_one_of_height_eq P hone C₀ hε1 hR hηε hη ρ hρ q hq)
+  · intro q hq
+    exact
+      (Concatenation.map_one P K hjoin q).trans
+        (centralInterpolation_eq_endpoint_of_height_le_half P hone C₀ hε1 hR hηε hη ρ hρ 1 q hq)
+
+private theorem CuspControlledRetraction.exists_positive_controlled_deformation_below
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) :
+    ∃ η₀ : ℝ,
+      0 < η₀ ∧
+        η₀ < ε ∧
+          ∀ (η : ℝ) (hη : 0 < η),
+            η ≤ η₀ →
+              ∀ ρ : ℝ,
+                0 < ρ →
+                  ρ ≤ η →
+                    ∃ P :
+                      C(unitInterval × ToricSpace.ClosedPositiveTube η,
+                        ToricSpace.ClosedPositiveTube η),
+                      (∀ q, P (0, q) = q) ∧
+                        (∀ s (q : ToricSpace.ClosedPositiveTube η),
+                            ToricSpace.time (q.1 : ToricSpace.Space) = 0 → P (s, q) = q) ∧
+                          (∀ q : ToricSpace.ClosedPositiveTube η,
+                              ToricSpace.time ((P (1, q)).1 : ToricSpace.Space) = 0) ∧
+                            (∀ s v q,
+                                P (s, CuspPositive.closedPositiveTranslate C₀ η v q) =
+                                  CuspPositive.closedPositiveTranslate C₀ η v (P (s, q))) ∧
+                              (∀ s q,
+                                  ‖ToricSpace.time ((P (s, q)).1 : ToricSpace.Space)‖ ≤
+                                    ‖ToricSpace.time (q.1 : ToricSpace.Space)‖) ∧
+                                (∀ q,
+                                  ‖ToricSpace.time (q.1 : ToricSpace.Space)‖ = ρ →
+                                    P (1, q) =
+                                      CuspPositiveRetraction.positiveCentralInclusion η hη.le
+                                        (CuspHoneycomb.honeycombHomeomorph C₀
+                                          (normalizedPosition C₀ (q.1 : ToricSpace.Space)))) := by
+  obtain ⟨η₀, hη₀, hη₀ε, hP⟩ :=
+    CuspPositiveRetraction.exists_positive_closed_deformation_below C₀ ε hε hε1 hR
+  refine ⟨η₀, hη₀, hη₀ε, ?_⟩
+  intro η hη hηη₀ ρ hρ _hρη
+  obtain ⟨P, hzero, hfix, hone, hequiv, hmono⟩ := hP η hη hηη₀
+  obtain ⟨Q, hQzero, hQfix, hQone, hQequiv, hQmono, hQend, _hQnear⟩ :=
+    exists_positive_modification C₀ hε1 hR (hηη₀.trans_lt hη₀ε) hη.le ρ hρ P hzero hfix hone
+      hequiv hmono
+  exact ⟨Q, hQzero, hQfix, hQone, hQequiv, hQmono, hQend⟩
+
+private def CuspControlledRetraction.polarDeformation {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hfix :
+      ∀ (s : unitInterval) (q : ToricSpace.ClosedPositiveTube η),
+        ToricSpace.time (q.1 : ToricSpace.Space) = 0 → P (s, q) = q) :
+    C(unitInterval × CuspRetraction.ClosedTube η, CuspRetraction.ClosedTube η) :=
+  ⟨fun p => CuspRetraction.polarSpread P p.1 p.2, CuspRetraction.polarSpread_continuous P hfix⟩
+
+private theorem CuspControlledRetraction.polarDeformation_closedPolarMap {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hfix :
+      ∀ (s : unitInterval) (q : ToricSpace.ClosedPositiveTube η),
+        ToricSpace.time (q.1 : ToricSpace.Space) = 0 → P (s, q) = q)
+    (s : unitInterval) (φ : ToricSpace.CompactTorus) (q : ToricSpace.ClosedPositiveTube η) :
+    polarDeformation P hfix (s, ToricSpace.closedPolarMap η (φ, q)) =
+      ToricSpace.closedPolarMap η (φ, P (s, q)) :=
+  CuspRetraction.polarSpread_closedPolarMap P hfix s (φ, q)
+
+private theorem CuspControlledRetraction.polarDeformation_properties (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hfix :
+      ∀ (s : unitInterval) (q : ToricSpace.ClosedPositiveTube η),
+        ToricSpace.time (q.1 : ToricSpace.Space) = 0 → P (s, q) = q)
+    (hzero : ∀ q : ToricSpace.ClosedPositiveTube η, P (0, q) = q)
+    (hone :
+      ∀ q : ToricSpace.ClosedPositiveTube η,
+        ToricSpace.time ((P (1, q)).1 : ToricSpace.Space) = 0)
+    (hequiv :
+      ∀ (s : unitInterval) (v : Fin 2 → ℤ) (q : ToricSpace.ClosedPositiveTube η),
+        P (s, CuspPositive.closedPositiveTranslate C₀ η v q) =
+          CuspPositive.closedPositiveTranslate C₀ η v (P (s, q)))
+    (hmono :
+      ∀ (s : unitInterval) (q : ToricSpace.ClosedPositiveTube η),
+        ‖ToricSpace.time ((P (s, q)).1 : ToricSpace.Space)‖ ≤
+          ‖ToricSpace.time (q.1 : ToricSpace.Space)‖) :
+    (∀ x, polarDeformation P hfix (0, x) = x) ∧
+      (∀ s (x : CuspRetraction.ClosedTube η),
+          ToricSpace.time (x : ToricSpace.Space) = 0 → polarDeformation P hfix (s, x) = x) ∧
+        (∀ x, ToricSpace.time (polarDeformation P hfix (1, x) : ToricSpace.Space) = 0) ∧
+          (∀ s v x,
+              polarDeformation P hfix (s, CuspRetraction.closedTranslate (fun _ => C₀) η v x) =
+                CuspRetraction.closedTranslate (fun _ => C₀) η v
+                  (polarDeformation P hfix (s, x))) ∧
+            (∀ s φ x,
+                polarDeformation P hfix (s, CuspRetraction.closedCompactAction η φ x) =
+                  CuspRetraction.closedCompactAction η φ (polarDeformation P hfix (s, x))) ∧
+              (∀ s (u : Fin 2 → ℂˣ),
+                  (∀ i, ‖(u i : ℂ)‖ = 1) →
+                    ∀ x,
+                      polarDeformation P hfix (s, CuspRetraction.closedFibreAction η u x) =
+                        CuspRetraction.closedFibreAction η u (polarDeformation P hfix (s, x))) ∧
+                (∀ s x,
+                  ‖ToricSpace.time (polarDeformation P hfix (s, x) : ToricSpace.Space)‖ ≤
+                    ‖ToricSpace.time (x : ToricSpace.Space)‖) :=
+  ⟨CuspRetraction.polarSpread_zero P hfix hzero, CuspRetraction.polarSpread_fixed P hfix,
+    CuspRetraction.polarSpread_one_central P hfix hone,
+    CuspRetraction.polarSpread_frozen_equivariant C₀ P hfix hequiv,
+    CuspRetraction.polarSpread_compactTorus_equivariant P hfix,
+    CuspRetraction.polarSpread_fibre_torus_equivariant P hfix,
+    CuspRetraction.polarSpread_norm_time_le P hfix hmono⟩
+
+private abbrev CuspControlledRetraction.PuncturedPositiveTube (η : ℝ) :=
+  { q : ToricSpace.ClosedPositiveTube η // ToricSpace.time (q.1 : ToricSpace.Space) ≠ 0 }
+
+private abbrev CuspControlledRetraction.PuncturedClosedTube (η : ℝ) :=
+  { x : CuspRetraction.ClosedTube η // ToricSpace.time (x : ToricSpace.Space) ≠ 0 }
+
+private theorem CuspControlledRetraction.puncturedPolarMap_mem_iff (η : ℝ)
+    (p : ToricSpace.CompactTorus × ToricSpace.ClosedPositiveTube η) :
+    ToricSpace.closedPolarMap η p ∈
+        {x : CuspRetraction.ClosedTube η | ToricSpace.time (x : ToricSpace.Space) ≠ 0} ↔
+      p.2 ∈
+        {q : ToricSpace.ClosedPositiveTube η | ToricSpace.time (q.1 : ToricSpace.Space) ≠ 0} := by
+  change
+    ToricSpace.time (ToricSpace.compactTorusAction p.1 (p.2.1 : ToricSpace.Space)) ≠ 0 ↔
+      ToricSpace.time (p.2.1 : ToricSpace.Space) ≠ 0
+  rw [← norm_ne_zero_iff, ToricSpace.norm_time_compactTorusAction, norm_ne_zero_iff]
+
+private def CuspControlledRetraction.puncturedPolarMap (η : ℝ) :
+    ToricSpace.CompactTorus × PuncturedPositiveTube η → PuncturedClosedTube η :=
+  ProductRestriction.productRestriction (ToricSpace.closedPolarMap η)
+    {q : ToricSpace.ClosedPositiveTube η | ToricSpace.time (q.1 : ToricSpace.Space) ≠ 0}
+    {x : CuspRetraction.ClosedTube η | ToricSpace.time (x : ToricSpace.Space) ≠ 0}
+    (puncturedPolarMap_mem_iff η)
+
+@[simp]
+private theorem CuspControlledRetraction.puncturedPolarMap_closed_coe (η : ℝ)
+    (p : ToricSpace.CompactTorus × PuncturedPositiveTube η) :
+    (puncturedPolarMap η p : CuspRetraction.ClosedTube η) =
+      ToricSpace.closedPolarMap η (p.1, p.2.1) :=
+  rfl
+
+private theorem CuspControlledRetraction.norm_time_puncturedPolarMap (η : ℝ)
+    (p : ToricSpace.CompactTorus × PuncturedPositiveTube η) :
+    ‖ToricSpace.time ((puncturedPolarMap η p).1 : ToricSpace.Space)‖ =
+      ‖ToricSpace.time (p.2.1.1 : ToricSpace.Space)‖ :=
+  ToricSpace.norm_time_compactTorusAction p.1 (p.2.1.1 : ToricSpace.Space)
+
+private theorem CuspControlledRetraction.puncturedPolarMap_continuous (η : ℝ) :
+    Continuous (puncturedPolarMap η) :=
+  ProductRestriction.productRestriction_continuous _ _ _ _
+    (ToricSpace.closedPolarMap_continuous η)
+
+private theorem CuspControlledRetraction.puncturedPolarMap_isClosedMap (η : ℝ) :
+    IsClosedMap (puncturedPolarMap η) :=
+  ProductRestriction.productRestriction_isClosedMap _ _ _ _
+    (ToricSpace.closedPolarMap_isClosedMap η)
+
+private theorem CuspControlledRetraction.puncturedPolarMap_surjective (η : ℝ) :
+    Function.Surjective (puncturedPolarMap η) :=
+  ProductRestriction.productRestriction_surjective _ _ _ _
+    (ToricSpace.closedPolarMap_surjective η)
+
+private theorem CuspControlledRetraction.puncturedPolarMap_injective (η : ℝ) :
+    Function.Injective (puncturedPolarMap η) := by
+  rintro ⟨u, q⟩ ⟨v, r⟩ h
+  have hclosed : ToricSpace.closedPolarMap η (u, q.1) = ToricSpace.closedPolarMap η (v, r.1) :=
+    congrArg Subtype.val h
+  have hqr : q = r := by
+    apply Subtype.ext
+    simpa only [ToricSpace.closedModulusRetraction_closedPolarMap] using
+      congrArg (ToricSpace.closedModulusRetraction η) hclosed
+  subst r
+  have huv : u = v :=
+    ToricSpace.compactTorusAction_injective_of_time_ne_zero q.property
+      (congrArg (fun x : CuspRetraction.ClosedTube η => (x : ToricSpace.Space)) hclosed)
+  exact Prod.ext huv rfl
+
+private theorem CuspControlledRetraction.puncturedPolarMap_bijective (η : ℝ) :
+    Function.Bijective (puncturedPolarMap η) :=
+  ⟨puncturedPolarMap_injective η, puncturedPolarMap_surjective η⟩
+
+private def CuspControlledRetraction.puncturedPolarHomeomorph (η : ℝ) :
+    (ToricSpace.CompactTorus × PuncturedPositiveTube η) ≃ₜ PuncturedClosedTube η :=
+  Equiv.toHomeomorphOfContinuousClosed
+    (Equiv.ofBijective (puncturedPolarMap η) (puncturedPolarMap_bijective η))
+    (puncturedPolarMap_continuous η) (puncturedPolarMap_isClosedMap η)
+
+@[simp]
+private theorem CuspControlledRetraction.puncturedPolarHomeomorph_symm_map (η : ℝ)
+    (p : ToricSpace.CompactTorus × PuncturedPositiveTube η) :
+    (puncturedPolarHomeomorph η).symm (puncturedPolarMap η p) = p :=
+  (puncturedPolarHomeomorph η).symm_apply_apply p
+
+@[simp]
+private theorem
+    CuspControlledRetraction.puncturedPolarMap_symm (η : ℝ) (x : PuncturedClosedTube η) :
+    puncturedPolarMap η ((puncturedPolarHomeomorph η).symm x) = x :=
+  (puncturedPolarHomeomorph η).apply_symm_apply x
+
+@[simp]
+private theorem CuspControlledRetraction.puncturedPolarHomeomorph_symm_positive_coe (η : ℝ)
+    (x : PuncturedClosedTube η) :
+    ((puncturedPolarHomeomorph η).symm x).2.1 = ToricSpace.closedModulusRetraction η x.1 := by
+  have h :=
+    congrArg (fun y : PuncturedClosedTube η => ToricSpace.closedModulusRetraction η y.1)
+      (puncturedPolarMap_symm η x)
+  simpa only [puncturedPolarMap_closed_coe,
+    ToricSpace.closedModulusRetraction_closedPolarMap] using h
+
+private def CuspControlledRetraction.centralCompactPolar
+    (p : ToricSpace.CompactTorus × CuspPositiveRetraction.PositiveCentralFibre) :
+    CuspRetraction.CentralFibre :=
+  ⟨ToricSpace.compactTorusAction p.1 (p.2.1 : ToricSpace.Space), by
+    simp only [ToricSpace.compactTorusAction, ToricSpace.time_torusAction, p.2.2,
+      MulZeroClass.mul_zero]⟩
+
+private theorem CuspControlledRetraction.centralCompactPolar_continuous :
+    Continuous centralCompactPolar :=
+  (ToricSpace.compactTorusAction_continuous.comp
+        (continuous_fst.prodMk
+          ((continuous_subtype_val.comp continuous_subtype_val).comp continuous_snd))).subtype_mk
+    _
+
+@[simp]
+private theorem CuspControlledRetraction.centralModulus_centralCompactPolar
+    (p : ToricSpace.CompactTorus × CuspPositiveRetraction.PositiveCentralFibre) :
+    CuspCollapse.centralModulus (centralCompactPolar p) = p.2 := by
+  apply Subtype.ext
+  apply Subtype.ext
+  change
+    ToricSpace.modulus (ToricSpace.compactTorusAction p.1 (p.2.1 : ToricSpace.Space)) =
+      (p.2.1 : ToricSpace.Space)
+  rw [ToricSpace.modulus_compactTorusAction]
+  exact p.2.1.2
+
+private def
+    CuspControlledRetraction.prescribedPositiveCollapse (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (η : ℝ)
+    (q : PuncturedPositiveTube η) : CuspPositiveRetraction.PositiveCentralFibre :=
+  CuspHoneycomb.honeycombHomeomorph C₀ (normalizedPosition C₀ (q.1.1 : ToricSpace.Space))
+
+private def CuspControlledRetraction.prescribedPolarCollapse (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (η : ℝ)
+    (p : ToricSpace.CompactTorus × PuncturedPositiveTube η) : CuspRetraction.CentralFibre :=
+  centralCompactPolar (p.1, prescribedPositiveCollapse C₀ η p.2)
+
+private def CuspControlledRetraction.prescribedCollapse (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (η : ℝ)
+    (x : PuncturedClosedTube η) : CuspRetraction.CentralFibre :=
+  prescribedPolarCollapse C₀ η ((puncturedPolarHomeomorph η).symm x)
+
+@[simp]
+private theorem CuspControlledRetraction.prescribedCollapse_puncturedPolarMap
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (η : ℝ)
+    (p : ToricSpace.CompactTorus × PuncturedPositiveTube η) :
+    prescribedCollapse C₀ η (puncturedPolarMap η p) = prescribedPolarCollapse C₀ η p := by
+  unfold prescribedCollapse
+  rw [puncturedPolarHomeomorph_symm_map]
+
+private theorem
+    CuspControlledRetraction.prescribedCollapse_polar (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (η : ℝ)
+    (u : ToricSpace.CompactTorus) (q : PuncturedPositiveTube η) :
+    (prescribedCollapse C₀ η (puncturedPolarMap η (u, q)) : ToricSpace.Space) =
+      ToricSpace.compactTorusAction u
+        ((CuspHoneycomb.honeycombHomeomorph C₀
+              (normalizedPosition C₀ (q.1.1 : ToricSpace.Space))).1 :
+          ToricSpace.Space) := by
+  rw [prescribedCollapse_puncturedPolarMap]
+  rfl
+
+@[simp]
+private theorem CuspControlledRetraction.prescribedCollapse_modulus (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (η : ℝ) (x : PuncturedClosedTube η) :
+    CuspCollapse.centralModulus (prescribedCollapse C₀ η x) =
+      prescribedPositiveCollapse C₀ η ((puncturedPolarHomeomorph η).symm x).2 :=
+  centralModulus_centralCompactPolar _
+
+private theorem CuspControlledRetraction.normalizedPosition_puncturedPositive_continuous
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (hηε : η < ε) :
+    Continuous
+      (fun q : PuncturedPositiveTube η => normalizedPosition C₀ (q.1.1 : ToricSpace.Space)) := by
+  apply continuous_iff_continuousAt.mpr
+  intro q
+  exact
+    (normalizedPosition_closedPositive_continuousAt C₀ hε1 hR hηε q.2).comp
+      continuous_subtype_val.continuousAt
+
+private theorem CuspControlledRetraction.prescribedPositiveCollapse_continuous
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (hηε : η < ε) :
+    Continuous (prescribedPositiveCollapse C₀ η) :=
+  (CuspHoneycomb.honeycombHomeomorph C₀).continuous.comp
+    (normalizedPosition_puncturedPositive_continuous C₀ hε1 hR hηε)
+
+private theorem CuspControlledRetraction.prescribedPolarCollapse_continuous
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (hηε : η < ε) :
+    Continuous (prescribedPolarCollapse C₀ η) :=
+  centralCompactPolar_continuous.comp
+    (continuous_fst.prodMk
+      ((prescribedPositiveCollapse_continuous C₀ hε1 hR hηε).comp continuous_snd))
+
+private theorem
+    CuspControlledRetraction.prescribedCollapse_continuous (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hε1 : ε < 1) (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε)
+    (hηε : η < ε) : Continuous (prescribedCollapse C₀ η) :=
+  (prescribedPolarCollapse_continuous C₀ hε1 hR hηε).comp
+    (puncturedPolarHomeomorph η).symm.continuous
+
+private theorem CuspControlledRetraction.polarDeformation_prescribedCollapse_of_puncturedEndpoint
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hfix :
+      ∀ (s : unitInterval) (q : ToricSpace.ClosedPositiveTube η),
+        ToricSpace.time (q.1 : ToricSpace.Space) = 0 → P (s, q) = q)
+    (ρ : ℝ) (hη : 0 ≤ η)
+    (hEnd :
+      ∀ q : PuncturedPositiveTube η,
+        ‖ToricSpace.time (q.1.1 : ToricSpace.Space)‖ = ρ →
+          P (1, q.1) =
+            CuspPositiveRetraction.positiveCentralInclusion η hη
+              (prescribedPositiveCollapse C₀ η q))
+    (x : PuncturedClosedTube η) (hx : ‖ToricSpace.time (x.1 : ToricSpace.Space)‖ = ρ) :
+    polarDeformation P hfix (1, x.1) =
+      CuspRetraction.centralIntoClosedTube η hη (prescribedCollapse C₀ η x) := by
+  obtain ⟨⟨φ, q⟩, rfl⟩ := puncturedPolarMap_surjective η x
+  have hq : ‖ToricSpace.time (q.1.1 : ToricSpace.Space)‖ = ρ := by
+    simpa only [norm_time_puncturedPolarMap] using hx
+  apply Subtype.ext
+  change
+    (polarDeformation P hfix (1, ToricSpace.closedPolarMap η (φ, q.1)) : ToricSpace.Space) =
+      (prescribedCollapse C₀ η (puncturedPolarMap η (φ, q)) : ToricSpace.Space)
+  rw [polarDeformation_closedPolarMap, hEnd q hq, prescribedCollapse_polar]
+  rfl
+
+private theorem CuspControlledRetraction.polarDeformation_prescribedCollapse
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {η : ℝ}
+    (P : C(unitInterval × ToricSpace.ClosedPositiveTube η, ToricSpace.ClosedPositiveTube η))
+    (hfix :
+      ∀ (s : unitInterval) (q : ToricSpace.ClosedPositiveTube η),
+        ToricSpace.time (q.1 : ToricSpace.Space) = 0 → P (s, q) = q)
+    (ρ : ℝ) (hη : 0 ≤ η)
+    (hEnd :
+      ∀ q : ToricSpace.ClosedPositiveTube η,
+        ‖ToricSpace.time (q.1 : ToricSpace.Space)‖ = ρ →
+          P (1, q) =
+            CuspPositiveRetraction.positiveCentralInclusion η hη
+              (CuspHoneycomb.honeycombHomeomorph C₀
+                (normalizedPosition C₀ (q.1 : ToricSpace.Space))))
+    (x : PuncturedClosedTube η) (hx : ‖ToricSpace.time (x.1 : ToricSpace.Space)‖ = ρ) :
+    polarDeformation P hfix (1, x.1) =
+      CuspRetraction.centralIntoClosedTube η hη (prescribedCollapse C₀ η x) :=
+  polarDeformation_prescribedCollapse_of_puncturedEndpoint C₀ P hfix ρ hη
+    (fun q hq => hEnd q.1 hq) x hx
+
+private theorem CuspControlledRetraction.exists_frozen_controlled_deformation_below
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) :
+    ∃ η₀ : ℝ,
+      0 < η₀ ∧
+        η₀ < ε ∧
+          ∀ (η : ℝ) (hη : 0 < η),
+            η ≤ η₀ →
+              ∀ ρ : ℝ,
+                0 < ρ →
+                  ρ ≤ η →
+                    ∃ H :
+                      C(unitInterval × CuspRetraction.ClosedTube η, CuspRetraction.ClosedTube η),
+                      (∀ x, H (0, x) = x) ∧
+                        (∀ s (x : CuspRetraction.ClosedTube η),
+                            ToricSpace.time (x : ToricSpace.Space) = 0 → H (s, x) = x) ∧
+                          (∀ x, ToricSpace.time (H (1, x) : ToricSpace.Space) = 0) ∧
+                            (∀ s v x,
+                                H (s, CuspRetraction.closedTranslate (fun _ => C₀) η v x) =
+                                  CuspRetraction.closedTranslate (fun _ => C₀) η v (H (s, x))) ∧
+                              (∀ s φ x,
+                                  H (s, CuspRetraction.closedCompactAction η φ x) =
+                                    CuspRetraction.closedCompactAction η φ (H (s, x))) ∧
+                                (∀ s (u : Fin 2 → ℂˣ),
+                                    (∀ i, ‖(u i : ℂ)‖ = 1) →
+                                      ∀ x,
+                                        H (s, CuspRetraction.closedFibreAction η u x) =
+                                          CuspRetraction.closedFibreAction η u (H (s, x))) ∧
+                                  (∀ s x,
+                                      ‖ToricSpace.time (H (s, x) : ToricSpace.Space)‖ ≤
+                                        ‖ToricSpace.time (x : ToricSpace.Space)‖) ∧
+                                    (∀ x : PuncturedClosedTube η,
+                                      ‖ToricSpace.time (x.1 : ToricSpace.Space)‖ = ρ →
+                                        H (1, x.1) =
+                                          CuspRetraction.centralIntoClosedTube η hη.le
+                                            (prescribedCollapse C₀ η x)) := by
+  obtain ⟨η₀, hη₀, hη₀ε, hP⟩ := exists_positive_controlled_deformation_below C₀ ε hε hε1 hR
+  refine ⟨η₀, hη₀, hη₀ε, ?_⟩
+  intro η hη hηη₀ ρ hρ hρη
+  obtain ⟨P, hzero, hfix, hone, hequiv, hmono, hEnd⟩ := hP η hη hηη₀ ρ hρ hρη
+  obtain ⟨hHzero, hHfix, hHone, hHequiv, hHcompact, hHfibre, hHmono⟩ :=
+    polarDeformation_properties C₀ P hfix hzero hone hequiv hmono
+  refine ⟨polarDeformation P hfix, hHzero, hHfix, hHone, hHequiv, hHcompact, hHfibre, hHmono, ?_⟩
+  exact polarDeformation_prescribedCollapse C₀ P hfix ρ hη.le hEnd
+
+private theorem CuspControlledRetraction.closedHomotopyDescentRetraction_endpoint_of_eq
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hηε : η < ε)
+    (H : C(unitInterval × CuspRetraction.ClosedTube η, CuspRetraction.ClosedTube η))
+    (hHequiv :
+      ∀ (s : unitInterval) (v : Fin 2 → ℤ) (x : CuspRetraction.ClosedTube η),
+        H (s, CuspRetraction.closedTranslate C η v x) =
+          CuspRetraction.closedTranslate C η v (H (s, x)))
+    (hCanalytic : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε))
+    (hone : ∀ x : CuspRetraction.ClosedTube η, ToricSpace.time (H (1, x) : ToricSpace.Space) = 0)
+    (hη : 0 ≤ η) (x : CuspRetraction.ClosedTube η) (y : CuspRetraction.CentralFibre)
+    (hEndx : H (1, x) = CuspRetraction.centralIntoClosedTube η hη y) :
+    (CuspRetraction.closedHomotopyDescentRetraction C hηε H hHequiv hCanalytic hone
+          (CuspRetraction.closedQuotientMap C hηε x) :
+        CuspQuotient.QuotientSpace C ε) =
+      (CuspRetraction.closedQuotientMap C hηε (CuspRetraction.centralIntoClosedTube η hη y) :
+        CuspQuotient.QuotientSpace C ε) := by
+  change
+    (CuspRetraction.closedHomotopyDescent C hηε H 1 (CuspRetraction.closedQuotientMap C hηε x) :
+        CuspQuotient.QuotientSpace C ε) =
+      _
+  rw [CuspRetraction.closedHomotopyDescent_closedQuotientMap C hηε H hHequiv, hEndx]
+
+private theorem CuspControlledRetraction.closedFrozenStraightening_symm_fixed
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hCcont : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (hηε : η < ε) (x : CuspRetraction.ClosedTube η)
+    (hx : ToricSpace.time (x : ToricSpace.Space) = 0) :
+    ((CuspPositiveRetraction.closedFrozenStraightening C hε hε1 hCcont hRC hRD hηε)).symm x = x :=
+  by
+  apply ((CuspPositiveRetraction.closedFrozenStraightening C hε hε1 hCcont hRC hRD hηε)).injective
+  rw [((CuspPositiveRetraction.closedFrozenStraightening C hε hε1 hCcont hRC hRD
+        hηε)).apply_symm_apply,
+    CuspPositiveRetraction.closedFrozenStraightening_fixed C hε hε1 hCcont hRC hRD hηε x hx]
+
+private theorem CuspControlledRetraction.straightenedHomotopy_endpoint_of_eq
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hCcont : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (hηε : η < ε) (H : C(unitInterval × CuspRetraction.ClosedTube η, CuspRetraction.ClosedTube η))
+    (hη : 0 ≤ η) (x : CuspRetraction.ClosedTube η) (y : CuspRetraction.CentralFibre)
+    (he :
+      H (1, (CuspPositiveRetraction.closedFrozenStraightening C hε hε1 hCcont hRC hRD hηε) x) =
+        CuspRetraction.centralIntoClosedTube η hη y) :
+    (CuspPositiveRetraction.straightenedHomotopy C hε hε1 hCcont hRC hRD hηε H) (1, x) =
+      CuspRetraction.centralIntoClosedTube η hη y := by
+  rw [CuspPositiveRetraction.straightenedHomotopy_apply, he]
+  exact
+    closedFrozenStraightening_symm_fixed C hε hε1 hCcont hRC hRD hηε
+      (CuspRetraction.centralIntoClosedTube η hη y) y.2
+
+private def
+    CuspControlledRetraction.puncturedStraightening (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (η : ℝ)
+    (x : PuncturedClosedTube η) : PuncturedClosedTube η :=
+  ⟨CuspRetraction.closedTubeChangeTwist C (CuspRetraction.frozen C) η x.1,
+    by
+    change
+      ToricSpace.time
+          (CuspRetraction.changeTwist C (CuspRetraction.frozen C) (x.1 : ToricSpace.Space)) ≠
+        0
+    rw [CuspRetraction.time_changeTwist]
+    exact x.2⟩
+
+private theorem
+    CuspControlledRetraction.puncturedStraightening_base (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (η : ℝ) (x : PuncturedClosedTube η) :
+    ToricSpace.time ((puncturedStraightening C η x).1 : ToricSpace.Space) =
+      ToricSpace.time (x.1 : ToricSpace.Space) :=
+  CuspRetraction.time_changeTwist C (CuspRetraction.frozen C) (x.1 : ToricSpace.Space)
+
+private def
+    CuspControlledRetraction.straightenedPrescribedCollapse (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (η : ℝ) : PuncturedClosedTube η → CuspRetraction.CentralFibre :=
+  prescribedCollapse (C 0) η ∘ puncturedStraightening C η
+
+private theorem CuspControlledRetraction.puncturedStraightening_continuous
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hηε : η < ε) : Continuous (puncturedStraightening C η) := by
+  apply Continuous.subtype_mk
+  exact
+    (CuspRetraction.closedTubeChangeTwist_continuous C (CuspRetraction.frozen C) hε hε1 hC
+          (fun _ _ => continuousOn_const) rfl hRC hηε).comp
+      continuous_subtype_val
+
+private theorem CuspControlledRetraction.straightenedPrescribedCollapse_continuous
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (hηε : η < ε) : Continuous (straightenedPrescribedCollapse C η) :=
+  (prescribedCollapse_continuous (C 0) hε1 (CuspPositive.smallDrift_positiveTwist (C 0) hRD)
+        hηε).comp
+    (puncturedStraightening_continuous C hε hε1 hC hRC hηε)
+
+private theorem CuspControlledRetraction.straightenedHomotopy_prescribed_endpoint
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (hηε : η < ε) (H : C(unitInterval × CuspRetraction.ClosedTube η, CuspRetraction.ClosedTube η))
+    (hη : 0 ≤ η) {ρ : ℝ}
+    (hEnd :
+      ∀ x : PuncturedClosedTube η,
+        ‖ToricSpace.time (x.1 : ToricSpace.Space)‖ = ρ →
+          H (1, x.1) = CuspRetraction.centralIntoClosedTube η hη (prescribedCollapse (C 0) η x))
+    (x : PuncturedClosedTube η) (hx : ‖ToricSpace.time (x.1 : ToricSpace.Space)‖ = ρ) :
+    CuspPositiveRetraction.straightenedHomotopy C hε hε1 hC hRC hRD hηε H (1, x.1) =
+      CuspRetraction.centralIntoClosedTube η hη (straightenedPrescribedCollapse C η x) := by
+  apply
+    straightenedHomotopy_endpoint_of_eq C hε hε1 hC hRC hRD hηε H hη x.1
+      (straightenedPrescribedCollapse C η x)
+  exact
+    hEnd (puncturedStraightening C η x)
+      ((congrArg Norm.norm (puncturedStraightening_base C η x)).trans hx)
+
+private theorem CuspControlledRetraction.exists_closed_tube_controlled_deformation
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {r : ℝ} (hr : 0 < r)
+    (hC : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 r)) :
+    ∃ η₀ : ℝ,
+      0 < η₀ ∧
+        η₀ < r ∧
+          η₀ < 1 ∧
+            ∀ (η : ℝ) (hη : 0 < η),
+              η ≤ η₀ →
+                ∀ ρ : ℝ,
+                  0 < ρ →
+                    ρ ≤ η →
+                      ∃ H :
+                        C(unitInterval × CuspRetraction.ClosedTube η,
+                          CuspRetraction.ClosedTube η),
+                        (∀ x, H (0, x) = x) ∧
+                          (∀ s (x : CuspRetraction.ClosedTube η),
+                              ToricSpace.time (x : ToricSpace.Space) = 0 → H (s, x) = x) ∧
+                            (∀ x, ToricSpace.time (H (1, x) : ToricSpace.Space) = 0) ∧
+                              (∀ s v x,
+                                  H (s, CuspRetraction.closedTranslate C η v x) =
+                                    CuspRetraction.closedTranslate C η v (H (s, x))) ∧
+                                (∀ s (u : Fin 2 → ℂˣ),
+                                    (∀ i, ‖(u i : ℂ)‖ = 1) →
+                                      ∀ x,
+                                        H (s, CuspRetraction.closedFibreAction η u x) =
+                                          CuspRetraction.closedFibreAction η u (H (s, x))) ∧
+                                  (∀ s x,
+                                      ‖ToricSpace.time (H (s, x) : ToricSpace.Space)‖ ≤
+                                        ‖ToricSpace.time (x : ToricSpace.Space)‖) ∧
+                                    (∀ x : PuncturedClosedTube η,
+                                      ‖ToricSpace.time (x.1 : ToricSpace.Space)‖ = ρ →
+                                        H (1, x.1) =
+                                          CuspRetraction.centralIntoClosedTube η hη.le
+                                            (straightenedPrescribedCollapse C η x)) := by
+  obtain ⟨ε, hε, hεr, hε1, hRC, hRD⟩ := CuspRetraction.exists_common_frozen_radius C hr hC
+  have hCε : ∀ i j, ContinuousOn (fun t => C t i j) (Metric.ball 0 ε) := fun i j =>
+    (hC i j).mono (Metric.ball_subset_ball hεr.le)
+  have hRP : ToricSpace.SmallDrift (CuspPositive.positiveTwist (C 0)) ε :=
+    CuspPositive.smallDrift_positiveTwist (C 0) hRD
+  obtain ⟨η₀, hη₀, hη₀ε, hH⟩ := exists_frozen_controlled_deformation_below (C 0) ε hε hε1 hRP
+  refine ⟨η₀, hη₀, hη₀ε.trans hεr, hη₀ε.trans hε1, ?_⟩
+  intro η hη hηη₀ ρ hρ hρη
+  have hηε : η < ε := hηη₀.trans_lt hη₀ε
+  obtain ⟨H, hzero, hfix, hone, hequiv, _hcompact, hfibre, hmono, hEnd⟩ := hH η hη hηη₀ ρ hρ hρη
+  refine
+    ⟨CuspPositiveRetraction.straightenedHomotopy C hε hε1 hCε hRC hRD hηε H,
+      CuspPositiveRetraction.straightenedHomotopy_zero C hε hε1 hCε hRC hRD hηε H hzero,
+      CuspPositiveRetraction.straightenedHomotopy_fixed C hε hε1 hCε hRC hRD hηε H hfix,
+      CuspPositiveRetraction.straightenedHomotopy_one_central C hε hε1 hCε hRC hRD hηε H hone,
+      CuspPositiveRetraction.straightenedHomotopy_equivariant C hε hε1 hCε hRC hRD hηε H hequiv,
+      CuspPositiveRetraction.straightenedHomotopy_fibre_torus_equivariant C hε hε1 hCε hRC hRD hηε
+        H hfibre,
+      CuspPositiveRetraction.straightenedHomotopy_norm_time_le C hε hε1 hCε hRC hRD hηε H hmono,
+      ?_⟩
+  exact straightenedHomotopy_prescribed_endpoint C hε hε1 hCε hRC hRD hηε H hη.le hEnd
+
+private theorem
+    CuspControlledRetraction.exists_closed_quotient_controlled_strongDeformationRetraction
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {r : ℝ} (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 r)) :
+    ∃ η₀ : ℝ,
+      0 < η₀ ∧
+        η₀ < r ∧
+          η₀ < 1 ∧
+            ∀ (η : ℝ) (hη : 0 < η),
+              η ≤ η₀ →
+                ∀ ρ : ℝ,
+                  0 < ρ →
+                    ρ ≤ η →
+                      ∃ R :
+                        C(CuspRetraction.ClosedQuotient C r η,
+                          CuspRetraction.QuotientCentralFibre C r),
+                        R.comp (CuspRetraction.quotientCentralIntoClosed C r η hη.le) =
+                            ContinuousMap.id (CuspRetraction.QuotientCentralFibre C r) ∧
+                          ∃ H :
+                            (ContinuousMap.id (CuspRetraction.ClosedQuotient C r η)).HomotopyRel
+                              ((CuspRetraction.quotientCentralIntoClosed C r η hη.le).comp R)
+                              {q : CuspRetraction.ClosedQuotient C r η |
+                                CuspQuotient.projection C r q = 0},
+                            (∀ s q,
+                                ‖CuspQuotient.projection C r (H (s, q))‖ ≤
+                                  ‖CuspQuotient.projection C r q‖) ∧
+                              (∀ (hηr : η < r) (x : PuncturedClosedTube η),
+                                ‖ToricSpace.time (x.1 : ToricSpace.Space)‖ = ρ →
+                                  R (CuspRetraction.closedQuotientMap C hηr x.1) =
+                                    CuspCollapse.centralProject C r hr
+                                      (straightenedPrescribedCollapse C η x)) := by
+  obtain ⟨η₀, hη₀, hη₀r, hη₀1, hH⟩ :=
+    exists_closed_tube_controlled_deformation C hr (fun i j => (hC i j).continuousOn)
+  refine ⟨η₀, hη₀, hη₀r, hη₀1, ?_⟩
+  intro η hη hηη₀ ρ hρ hρη
+  have hηr : η < r := hηη₀.trans_lt hη₀r
+  obtain ⟨H, hzero, hfix, hone, hequiv, _hfibre, hmono, hEnd⟩ := hH η hη hηη₀ ρ hρ hρη
+  refine
+    ⟨CuspRetraction.closedHomotopyDescentRetraction C hηr H hequiv hC hone,
+      CuspRetraction.closedHomotopyDescentRetraction_comp_inclusion C hηr H hequiv hC hfix hone
+        hη.le,
+      CuspRetraction.closedHomotopyDescentHomotopyRel C hηr H hequiv hC hzero hfix hone hη.le,
+      CuspRetraction.closedHomotopyDescent_norm_nonincrease C hηr H hequiv hmono, ?_⟩
+  intro hηr' x hx
+  apply Subtype.ext
+  exact
+    closedHomotopyDescentRetraction_endpoint_of_eq C hηr H hequiv hC hone hη.le x.1
+      (straightenedPrescribedCollapse C η x) (hEnd x hx)
+
+private abbrev CuspControlledRetraction.ToricLevel (η : ℝ) (t : ℂ) :=
+  { x : CuspRetraction.ClosedTube η // ToricSpace.time (x : ToricSpace.Space) = t }
+
+private abbrev CuspControlledRetraction.QuotientLevel (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r η : ℝ)
+    (t : ℂ) :=
+  { q : CuspRetraction.ClosedQuotient C r η // CuspQuotient.projection C r q = t }
+
+private noncomputable def
+    CuspControlledRetraction.levelProjection (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {r η : ℝ} (hηr : η < r) (t : ℂ) (x : ToricLevel η t) : QuotientLevel C r η t :=
+  ⟨CuspRetraction.closedQuotientMap C hηr x.1, x.2⟩
+
+private theorem
+    CuspControlledRetraction.levelProjection_surjective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {r η : ℝ} (hηr : η < r) (t : ℂ) : Function.Surjective (levelProjection C hηr t) := by
+  rintro ⟨q, hq⟩
+  obtain ⟨x, rfl⟩ := CuspRetraction.closedQuotientMap_surjective C hηr q
+  exact ⟨⟨x, hq⟩, rfl⟩
+
+private theorem CuspControlledRetraction.levelProjection_isOpenQuotientMap
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {r η : ℝ} (hηr : η < r) (t : ℂ)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    IsOpenQuotientMap (levelProjection C hηr t) :=
+  (CuspRetraction.closedQuotientMap_isOpenQuotientMap C hηr hC).restrictPreimage
+    {q : CuspRetraction.ClosedQuotient C r η | CuspQuotient.projection C r q = t}
+
+private theorem
+    CuspControlledRetraction.levelProjection_isQuotientMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {r η : ℝ} (hηr : η < r) (t : ℂ)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Topology.IsQuotientMap (levelProjection C hηr t) :=
+  (levelProjection_isOpenQuotientMap C hηr t hC).isQuotientMap
+
+private noncomputable def CuspControlledRetraction.levelTranslate (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (η : ℝ) (t : ℂ) (v : Fin 2 → ℤ) (x : ToricLevel η t) : ToricLevel η t :=
+  ⟨CuspRetraction.closedTranslate C η v x.1,
+    by
+    change ToricSpace.time (ToricSpace.twistedTranslate C v (x.1 : ToricSpace.Space)) = t
+    rw [ToricSpace.time_twistedTranslate]
+    exact x.2⟩
+
+private theorem CuspControlledRetraction.levelProjection_eq_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {r η : ℝ} (hηr : η < r) (t : ℂ) (x y : ToricLevel η t) :
+    levelProjection C hηr t x = levelProjection C hηr t y ↔
+      ∃ v : Fin 2 → ℤ, CuspRetraction.closedTranslate C η v y.1 = x.1 := by
+  constructor
+  · intro hxy
+    have hq :=
+      congrArg (fun q : QuotientLevel C r η t => (q : CuspRetraction.ClosedQuotient C r η)) hxy
+    obtain ⟨v, hv⟩ := (CuspRetraction.closedQuotientMap_eq_iff C hηr x.1 y.1).mp hq
+    exact ⟨v, Subtype.ext hv⟩
+  · rintro ⟨v, hv⟩
+    apply Subtype.ext
+    apply (CuspRetraction.closedQuotientMap_eq_iff C hηr x.1 y.1).mpr
+    exact ⟨v, congrArg (fun z : CuspRetraction.ClosedTube η => (z : ToricSpace.Space)) hv⟩
+
+private theorem CuspControlledRetraction.levelProjection_eq_iff_levelTranslate
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {r η : ℝ} (hηr : η < r) (t : ℂ) (x y : ToricLevel η t) :
+    levelProjection C hηr t x = levelProjection C hηr t y ↔
+      ∃ v : Fin 2 → ℤ, levelTranslate C η t v y = x := by
+  constructor
+  · intro hxy
+    obtain ⟨v, hv⟩ := (levelProjection_eq_iff C hηr t x y).mp hxy
+    exact ⟨v, Subtype.ext hv⟩
+  · rintro ⟨v, hv⟩
+    apply (levelProjection_eq_iff C hηr t x y).mpr
+    exact ⟨v, congrArg (fun z : ToricLevel η t => (z : CuspRetraction.ClosedTube η)) hv⟩
+
+private theorem CuspControlledRetraction.levelProjection_fibre_compatible_of_invariant
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {r η : ℝ} {Z : Type*} (hηr : η < r) (t : ℂ)
+    (f : ToricLevel η t → Z)
+    (hinv : ∀ (v : Fin 2 → ℤ) (x : ToricLevel η t), f (levelTranslate C η t v x) = f x) :
+    ∀ x y, levelProjection C hηr t x = levelProjection C hηr t y → f x = f y := by
+  intro x y hxy
+  obtain ⟨v, hv⟩ := (levelProjection_eq_iff_levelTranslate C hηr t x y).mp hxy
+  rw [← hv]
+  exact hinv v y
+
+private noncomputable def CuspControlledRetraction.levelDescend (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {r η : ℝ} {Z : Type*} (hηr : η < r) (t : ℂ) (f : ToricLevel η t → Z) :
+    QuotientLevel C r η t → Z :=
+  CuspHoneycombHexagon.CommonFibres.descend (levelProjection C hηr t) f
+    (levelProjection_surjective C hηr t)
+
+private theorem
+    CuspControlledRetraction.levelDescend_levelProjection (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {r η : ℝ} {Z : Type*} (hηr : η < r) (t : ℂ) (f : ToricLevel η t → Z)
+    (hcompat : ∀ x y, levelProjection C hηr t x = levelProjection C hηr t y → f x = f y)
+    (x : ToricLevel η t) : levelDescend C hηr t f (levelProjection C hηr t x) = f x :=
+  CuspHoneycombHexagon.CommonFibres.descend_apply (levelProjection C hηr t) f
+    (levelProjection_surjective C hηr t) hcompat x
+
+private theorem
+    CuspControlledRetraction.levelDescend_unique (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {r η : ℝ}
+    {Z : Type*} (hηr : η < r) (t : ℂ) (f : ToricLevel η t → Z)
+    (hcompat : ∀ x y, levelProjection C hηr t x = levelProjection C hηr t y → f x = f y)
+    (g : QuotientLevel C r η t → Z) (hg : ∀ x, g (levelProjection C hηr t x) = f x) :
+    g = levelDescend C hηr t f := by
+  funext q
+  obtain ⟨x, rfl⟩ := levelProjection_surjective C hηr t q
+  rw [hg, levelDescend_levelProjection C hηr t f hcompat]
+
+private theorem CuspControlledRetraction.levelDescend_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {r η : ℝ} {Z : Type*} [TopologicalSpace Z] (hηr : η < r) (t : ℂ) (f : ToricLevel η t → Z)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (hf : Continuous f)
+    (hcompat : ∀ x y, levelProjection C hηr t x = levelProjection C hηr t y → f x = f y) :
+    Continuous (levelDescend C hηr t f) :=
+  CuspHoneycombHexagon.CommonFibres.descend_continuous (levelProjection C hηr t) f
+    (levelProjection_surjective C hηr t) (levelProjection_isQuotientMap C hηr t hC) hf hcompat
+
+private abbrev
+    CuspControlledRetraction.ActualQuotientFibre (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (t : ℂ) :=
+  { q : CuspQuotient.QuotientSpace C r // CuspQuotient.projection C r q = t }
+
+private def CuspControlledRetraction.quotientLevelFibreHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r η : ℝ) (t : ℂ) (htη : ‖t‖ ≤ η) : QuotientLevel C r η t ≃ₜ ActualQuotientFibre C r t
+    where
+  toFun q := ⟨q.1.1, q.2⟩
+  invFun q := ⟨⟨q.1, by rw [q.2]; exact htη⟩, q.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := (continuous_subtype_val.comp continuous_subtype_val).subtype_mk _
+  continuous_invFun := by
+    apply Continuous.subtype_mk
+    exact continuous_subtype_val.subtype_mk _
+
+private def
+    CuspControlledRetraction.levelToPunctured (η : ℝ) (t : ℂ) (ht : t ≠ 0) (x : ToricLevel η t) :
+    PuncturedClosedTube η :=
+  ⟨x.1, fun hx => ht (x.2.symm.trans hx)⟩
+
+private def
+    CuspControlledRetraction.prescribedFibreUpstairs (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (η : ℝ) (t : ℂ) (ht : t ≠ 0) (x : ToricLevel η t) :
+    CuspRetraction.QuotientCentralFibre C r :=
+  CuspCollapse.centralProject C r hr
+    (straightenedPrescribedCollapse C η (levelToPunctured η t ht x))
+
+private def
+    CuspControlledRetraction.prescribedFibreCollapse (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) {η : ℝ} (hηr : η < r) (t : ℂ) (ht : t ≠ 0) :
+    QuotientLevel C r η t → CuspRetraction.QuotientCentralFibre C r :=
+  levelDescend C hηr t (prescribedFibreUpstairs C r hr η t ht)
+
+private def
+    CuspControlledRetraction.prescribedActualFibreCollapse (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) {η : ℝ} (hηr : η < r) (t : ℂ) (ht : t ≠ 0) (htη : ‖t‖ ≤ η) :
+    ActualQuotientFibre C r t → CuspRetraction.QuotientCentralFibre C r :=
+  prescribedFibreCollapse C r hr hηr t ht ∘ (quotientLevelFibreHomeomorph C r η t htη).symm
+
+private theorem CuspControlledRetraction.prescribedFibreCollapse_eq_of_endpoint
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) {η : ℝ} (hηr : η < r) (t : ℂ)
+    (ht : t ≠ 0)
+    (R : C(CuspRetraction.ClosedQuotient C r η, CuspRetraction.QuotientCentralFibre C r))
+    (hEnd :
+      ∀ x : PuncturedClosedTube η,
+        ‖ToricSpace.time (x.1 : ToricSpace.Space)‖ = ‖t‖ →
+          R (CuspRetraction.closedQuotientMap C hηr x.1) =
+            CuspCollapse.centralProject C r hr (straightenedPrescribedCollapse C η x)) :
+    (fun q : QuotientLevel C r η t => R q.1) = prescribedFibreCollapse C r hr hηr t ht := by
+  let f := prescribedFibreUpstairs C r hr η t ht
+  let g := fun q : QuotientLevel C r η t => R q.1
+  have hg (x : ToricLevel η t) : g (levelProjection C hηr t x) = f x :=
+    hEnd (levelToPunctured η t ht x) (congrArg Norm.norm x.2)
+  have hcompat : ∀ x y, levelProjection C hηr t x = levelProjection C hηr t y → f x = f y := by
+    intro x y hxy
+    exact (hg x).symm.trans ((congrArg g hxy).trans (hg y))
+  exact levelDescend_unique C hηr t f hcompat g hg
+
+private theorem CuspControlledRetraction.prescribedFibreCollapse_levelProjection_of_endpoint
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) {η : ℝ} (hηr : η < r) (t : ℂ)
+    (ht : t ≠ 0)
+    (R : C(CuspRetraction.ClosedQuotient C r η, CuspRetraction.QuotientCentralFibre C r))
+    (hEnd :
+      ∀ x : PuncturedClosedTube η,
+        ‖ToricSpace.time (x.1 : ToricSpace.Space)‖ = ‖t‖ →
+          R (CuspRetraction.closedQuotientMap C hηr x.1) =
+            CuspCollapse.centralProject C r hr (straightenedPrescribedCollapse C η x))
+    (x : ToricLevel η t) :
+    prescribedFibreCollapse C r hr hηr t ht (levelProjection C hηr t x) =
+      prescribedFibreUpstairs C r hr η t ht x := by
+  rw [← prescribedFibreCollapse_eq_of_endpoint C r hr hηr t ht R hEnd]
+  exact hEnd (levelToPunctured η t ht x) (congrArg Norm.norm x.2)
+
+private theorem CuspControlledRetraction.exists_controlled_actual_fibre_retraction
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {r : ℝ} (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    ∃ η₀ : ℝ,
+      0 < η₀ ∧
+        η₀ < r ∧
+          η₀ < 1 ∧
+            ∀ (η : ℝ) (hη : 0 < η),
+              η ≤ η₀ →
+                ∀ (t : ℂ) (ht : t ≠ 0) (htη : ‖t‖ ≤ η),
+                  ∃ R :
+                    C(CuspRetraction.ClosedQuotient C r η,
+                      CuspRetraction.QuotientCentralFibre C r),
+                    R.comp (CuspRetraction.quotientCentralIntoClosed C r η hη.le) =
+                        ContinuousMap.id (CuspRetraction.QuotientCentralFibre C r) ∧
+                      ∃ H :
+                        (ContinuousMap.id (CuspRetraction.ClosedQuotient C r η)).HomotopyRel
+                          ((CuspRetraction.quotientCentralIntoClosed C r η hη.le).comp R)
+                          {q : CuspRetraction.ClosedQuotient C r η |
+                            CuspQuotient.projection C r q = 0},
+                        (∀ s q,
+                            ‖CuspQuotient.projection C r (H (s, q))‖ ≤
+                              ‖CuspQuotient.projection C r q‖) ∧
+                          ∀ hηr : η < r,
+                            Continuous (prescribedActualFibreCollapse C r hr hηr t ht htη) ∧
+                              (∀ q : ActualQuotientFibre C r t,
+                                  R ((quotientLevelFibreHomeomorph C r η t htη).symm q).1 =
+                                    prescribedActualFibreCollapse C r hr hηr t ht htη q) ∧
+                                (∀ x : ToricLevel η t,
+                                  prescribedFibreCollapse C r hr hηr t ht
+                                      (levelProjection C hηr t x) =
+                                    prescribedFibreUpstairs C r hr η t ht x) := by
+  obtain ⟨η₀, hη₀, hη₀r, hη₀1, hR⟩ :=
+    exists_closed_quotient_controlled_strongDeformationRetraction C hr hC
+  refine ⟨η₀, hη₀, hη₀r, hη₀1, ?_⟩
+  intro η hη hηη₀ t ht htη
+  obtain ⟨R, hRinc, H, hmono, hEnd⟩ := hR η hη hηη₀ ‖t‖ (norm_pos_iff.mpr ht) htη
+  refine ⟨R, hRinc, H, hmono, ?_⟩
+  intro hηr
+  have he := prescribedFibreCollapse_eq_of_endpoint C r hr hηr t ht R (hEnd hηr)
+  refine ⟨?_, ?_, ?_⟩
+  · unfold prescribedActualFibreCollapse
+    rw [← he]
+    exact
+      (R.continuous.comp continuous_subtype_val).comp
+        (quotientLevelFibreHomeomorph C r η t htη).symm.continuous
+  · intro q
+    exact congrFun he ((quotientLevelFibreHomeomorph C r η t htη).symm q)
+  · exact prescribedFibreCollapse_levelProjection_of_endpoint C r hr hηr t ht R (hEnd hηr)
+
+private def CuspCentralHomology.fibreIntoOpen (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ : ℝ) (t : ℂ)
+    (htδ : ‖t‖ < δ) : C(CuspControlledRetraction.ActualQuotientFibre C r t, OpenQuotient C r δ)
+    where
+  toFun q := ⟨q.1, by rw [q.2]; exact htδ⟩
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    exact continuous_subtype_val
+
+private def
+    CuspCentralHomology.openLevelFibreHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ : ℝ)
+    (t : ℂ) (htδ : ‖t‖ < δ) :
+    { q : OpenQuotient C r δ // CuspQuotient.projection C r q = t } ≃ₜ
+      CuspControlledRetraction.ActualQuotientFibre C r t
+    where
+  toFun q := ⟨q.1.1, q.2⟩
+  invFun q := ⟨fibreIntoOpen C r δ t htδ q, q.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    exact continuous_subtype_val.comp continuous_subtype_val
+  continuous_invFun := by
+    apply Continuous.subtype_mk
+    exact (fibreIntoOpen C r δ t htδ).continuous
+
+private def
+    CuspCentralHomology.fibreRadiusHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ : ℝ) (t : ℂ)
+    (hδr : δ ≤ r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r))
+    (htδ : ‖t‖ < δ) :
+    CuspControlledRetraction.ActualQuotientFibre C δ t ≃ₜ
+      CuspControlledRetraction.ActualQuotientFibre C r t :=
+  ((openQuotientRadiusHomeomorph C hδr hC).subtype (p := fun q =>
+        CuspQuotient.projection C δ q = t) (q := fun q : OpenQuotient C r δ =>
+        CuspQuotient.projection C r q = t)
+        (fun q => by rw [openQuotientRadiusHomeomorph_projection])).trans
+    (openLevelFibreHomeomorph C r δ t htδ)
+
+private def CuspCentralHomology.centralRadiusHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ : ℝ)
+    (hδr : δ ≤ r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (hδ : 0 < δ) :
+    CuspRetraction.QuotientCentralFibre C δ ≃ₜ CuspRetraction.QuotientCentralFibre C r :=
+  fibreRadiusHomeomorph C r δ 0 hδr hC (by simpa only [norm_zero] using hδ)
+
+private def CuspCentralHomology.centralSingularH2Equiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 2 ≃ₗ[ℤ]
+      (Fin 4 → ℤ) := by
+  let δ : ℝ := Classical.choose (CuspQuotient.exists_admissible_radius C hr hC)
+  have hs :
+    0 < δ ∧
+      δ < r ∧
+        δ < 1 ∧
+          ToricSpace.SmallDrift C δ ∧
+            ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 δ) :=
+    Classical.choose_spec (CuspQuotient.exists_admissible_radius C hr hC)
+  exact
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+          (centralRadiusHomeomorph C r δ hs.2.1.le hC hs.1).symm 2).trans
+      (centralSingularH2Equiv_of_admissible C δ hs.1 hs.2.2.1 hs.2.2.2.2 hs.2.2.2.1)
+
+private def CuspCentralHomology.centralSingularH3Equiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 3 ≃ₗ[ℤ]
+      (Fin 2 → ℤ) := by
+  let δ : ℝ := Classical.choose (CuspQuotient.exists_admissible_radius C hr hC)
+  have hs :
+    0 < δ ∧
+      δ < r ∧
+        δ < 1 ∧
+          ToricSpace.SmallDrift C δ ∧
+            ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 δ) :=
+    Classical.choose_spec (CuspQuotient.exists_admissible_radius C hr hC)
+  exact
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+          (centralRadiusHomeomorph C r δ hs.2.1.le hC hs.1).symm 3).trans
+      (centralSingularH3Equiv_of_admissible C δ hs.1 hs.2.2.1 hs.2.2.2.2 hs.2.2.2.1)
+
+private theorem
+    CuspCentralHomology.centralSingularH2_free (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Module.Free ℤ
+      (SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 2) :=
+  Module.Free.of_equiv (centralSingularH2Equiv C r hr hC).symm
+
+private theorem
+    CuspCentralHomology.centralSingularH3_free (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Module.Free ℤ
+      (SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 3) :=
+  Module.Free.of_equiv (centralSingularH3Equiv C r hr hC).symm
+
+private theorem
+    CuspCentralHomology.centralSingularH2_finite (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Module.Finite ℤ
+      (SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 2) :=
+  Module.Finite.of_surjective (centralSingularH2Equiv C r hr hC).symm.toLinearMap
+    (centralSingularH2Equiv C r hr hC).symm.surjective
+
+private theorem
+    CuspCentralHomology.centralSingularH3_finite (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Module.Finite ℤ
+      (SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 3) :=
+  Module.Finite.of_surjective (centralSingularH3Equiv C r hr hC).symm.toLinearMap
+    (centralSingularH3Equiv C r hr hC).symm.surjective
+
+private theorem
+    CuspCentralHomology.centralSingularH2_finrank (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Module.finrank ℤ
+        (SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 2) =
+      4 := by
+  rw [(centralSingularH2Equiv C r hr hC).finrank_eq]
+  exact Module.finrank_fin_fun ℤ
+
+private theorem
+    CuspCentralHomology.centralSingularH3_finrank (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Module.finrank ℤ
+        (SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 3) =
+      2 := by
+  rw [(centralSingularH3Equiv C r hr hC).finrank_eq]
+  exact Module.finrank_fin_fun ℤ
+
+private def
+    CuspCentralHomology.centralSingularH4Equiv_of_admissible (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C ε) 4 ≃ₗ[ℤ] ℤ := by
+  letI := outerRegion_homology_subsingleton C ε hε hε1 hC hR (1 / 2) (by norm_num) (by norm_num) 1
+  letI := innerRegion_homology_subsingleton C ε hε hε1 hC hR 1
+  letI := outerRegion_homology_subsingleton C ε hε hε1 hC hR (1 / 2) (by norm_num) (by norm_num) 0
+  letI := innerRegion_homology_subsingleton C ε hε hε1 hC hR 0
+  exact
+    (coverConnectingEquivOfVanishing (outerRegion C ε hε (1 / 2)) (innerRegion C ε hε)
+          (outerRegion_isOpen C ε hε hε1 hC hR (1 / 2)) (innerRegion_isOpen C ε hε hε1 hC hR)
+          (outerRegion_union_innerRegion C ε hε (1 / 2) (by norm_num)) 3).trans
+      (overlapRegionHomologyThreeEquiv C ε hε hε1 hC hR (1 / 2) (by norm_num) (by norm_num))
+
+private theorem CuspCentralHomology.centralSingularHomology_subsingleton_of_admissible
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (n : ℕ) :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C ε)
+        (n + 5)) := by
+  let :=
+    outerRegion_homology_subsingleton C ε hε hε1 hC hR (1 / 2) (by norm_num) (by norm_num) (n + 2)
+  let := innerRegion_homology_subsingleton C ε hε hε1 hC hR (n + 2)
+  let :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology
+        ((outerRegion C ε hε (1 / 2)) ∩ (innerRegion C ε hε) :
+          Set (CuspRetraction.QuotientCentralFibre C ε))
+        (n + 4)) :=
+    overlapRegion_homology_subsingleton C ε hε hε1 hC hR (1 / 2) (by norm_num) (by norm_num) n
+  exact
+    coverHomology_subsingleton_of_vanishing (outerRegion C ε hε (1 / 2)) (innerRegion C ε hε)
+      (outerRegion_isOpen C ε hε hε1 hC hR (1 / 2)) (innerRegion_isOpen C ε hε hε1 hC hR)
+      (outerRegion_union_innerRegion C ε hε (1 / 2) (by norm_num)) (n + 4)
+
+private def CuspCentralHomology.centralSingularH4Equiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 4 ≃ₗ[ℤ] ℤ := by
+  let δ : ℝ := Classical.choose (CuspQuotient.exists_admissible_radius C hr hC)
+  have hs :
+    0 < δ ∧
+      δ < r ∧
+        δ < 1 ∧
+          ToricSpace.SmallDrift C δ ∧
+            ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 δ) :=
+    Classical.choose_spec (CuspQuotient.exists_admissible_radius C hr hC)
+  exact
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+          (centralRadiusHomeomorph C r δ hs.2.1.le hC hs.1).symm 4).trans
+      (centralSingularH4Equiv_of_admissible C δ hs.1 hs.2.2.1 hs.2.2.2.2 hs.2.2.2.1)
+
+private theorem CuspCentralHomology.centralSingularHomology_subsingleton
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (n : ℕ) :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r)
+        (n + 5)) := by
+  obtain ⟨δ, hδ, hδr, hδ1, hR, hCδ⟩ := CuspQuotient.exists_admissible_radius C hr hC
+  let := centralSingularHomology_subsingleton_of_admissible C δ hδ hδ1 hCδ hR n
+  exact
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+        (centralRadiusHomeomorph C r δ hδr.le hC hδ).symm (n + 5)).injective.subsingleton
+
+private theorem CuspCentralHomology.centralSingularHomology_subsingleton_of_four_lt
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) {n : ℕ} (hn : 4 < n) :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) n) := by
+  have he : (n - 5) + 5 = n := Nat.sub_add_cancel (by omega)
+  rw [← he]
+  exact centralSingularHomology_subsingleton C r hr hC (n - 5)
+
+private def
+    CuspCentralHomology.centralSingularHomologyHigherEquivZero (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r))
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) (n + 5) ≃ₗ[ℤ]
+      (Fin 0 → ℤ) := by
+  letI := centralSingularHomology_subsingleton C r hr hC n
+  exact LinearEquiv.ofSubsingleton _ _
+
+private theorem
+    CuspCentralHomology.centralSingularH4_free (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Module.Free ℤ
+      (SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 4) :=
+  Module.Free.of_equiv (centralSingularH4Equiv C r hr hC).symm
+
+private theorem
+    CuspCentralHomology.centralSingularH4_finite (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Module.Finite ℤ
+      (SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 4) :=
+  Module.Finite.of_surjective (centralSingularH4Equiv C r hr hC).symm.toLinearMap
+    (centralSingularH4Equiv C r hr hC).symm.surjective
+
+private theorem
+    CuspCentralHomology.centralSingularH4_finrank (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    Module.finrank ℤ
+        (SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) 4) =
+      1 := by
+  rw [(centralSingularH4Equiv C r hr hC).finrank_eq]
+  simp
+
+private def CuspCentralHomology.centralBetti : ℕ → ℕ
+  | 0 => 1
+  | 1 => 2
+  | 2 => 4
+  | 3 => 2
+  | 4 => 1
+  | _ => 0
+
+private def
+    CuspCentralHomology.centralSingularHomologyEquiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) n ≃ₗ[ℤ]
+      (Fin (centralBetti n) → ℤ) :=
+  match n with
+  | 0 => (centralSingularH0Equiv C r hr).trans (LinearEquiv.funUnique (Fin 1) ℤ ℤ).symm
+  | 1 => centralSingularH1Equiv C r hr hC
+  | 2 => centralSingularH2Equiv C r hr hC
+  | 3 => centralSingularH3Equiv C r hr hC
+  | 4 => (centralSingularH4Equiv C r hr hC).trans (LinearEquiv.funUnique (Fin 1) ℤ ℤ).symm
+  | n + 5 => centralSingularHomologyHigherEquivZero C r hr hC n
+
+private theorem CuspCentralHomology.centralSingularHomology_free (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r))
+    (n : ℕ) :
+    Module.Free ℤ
+      (SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) n) :=
+  Module.Free.of_equiv (centralSingularHomologyEquiv C r hr hC n).symm
+
+
+private theorem
+    CuspCentralHomology.centralSingularHomology_finrank (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r))
+    (n : ℕ) :
+    Module.finrank ℤ
+        (SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) n) =
+      centralBetti n := by
+  rw [(centralSingularHomologyEquiv C r hr hC n).finrank_eq]
+  exact Module.finrank_fin_fun ℤ
+
+
+private def
+    CuspCentralHomology.centralSingularEulerCharacteristic (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r : ℝ) : ℤ :=
+  ∑ i : Fin 5,
+    (-1 : ℤ) ^ (i : ℕ) *
+      (Module.finrank ℤ
+          (SingularMayerVietoris.SingularHomology (CuspRetraction.QuotientCentralFibre C r) i) :
+        ℤ)
+
+
+private abbrev CuspSpecialization.ToricFibre (t : ℂ) :=
+  { x : ToricSpace.Space // ToricSpace.time x = t }
+
+private abbrev CuspSpecialization.PositiveFibre (ρ : ℝ) :=
+  { q : ToricSpace.PositivePart // ToricSpace.time (q : ToricSpace.Space) = (ρ : ℂ) }
+
+@[simp]
+private theorem CuspSpecialization.time_positiveFibre (ρ : ℝ) (q : PositiveFibre ρ) :
+    ToricSpace.time (q.1 : ToricSpace.Space) = (ρ : ℂ) :=
+  q.2
+
+private theorem
+    CuspSpecialization.norm_time_positiveFibre (ρ : ℝ) (hρ : 0 ≤ ρ) (q : PositiveFibre ρ) :
+    ‖ToricSpace.time (q.1 : ToricSpace.Space)‖ = ρ := by rw [q.2, Complex.norm_of_nonneg hρ]
+
+private def
+    CuspSpecialization.positiveFibreInclusion (ρ : ℝ) : C(PositiveFibre ρ, ToricSpace.Space) :=
+  ⟨fun q => (q.1 : ToricSpace.Space), continuous_subtype_val.comp continuous_subtype_val⟩
+
+private def CuspSpecialization.toricFibreLevelHomeomorph (η : ℝ) (t : ℂ) (htη : ‖t‖ ≤ η) :
+    ToricFibre t ≃ₜ CuspControlledRetraction.ToricLevel η t
+    where
+  toFun x := ⟨⟨(x : ToricSpace.Space), by rw [x.2]; exact htη⟩, x.2⟩
+  invFun x := ⟨(x.1 : ToricSpace.Space), x.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    exact continuous_subtype_val.subtype_mk _
+  continuous_invFun := (continuous_subtype_val.comp continuous_subtype_val).subtype_mk _
+
+private theorem CuspSpecialization.positiveFibre_isClosed (ρ : ℝ) :
+    IsClosed {q : ToricSpace.PositivePart | ToricSpace.time (q : ToricSpace.Space) = (ρ : ℂ)} :=
+  isClosed_eq (ToricSpace.time_holomorphic.continuous.comp continuous_subtype_val)
+    continuous_const
+
+private theorem CuspSpecialization.positiveFibreVal_isClosedEmbedding (ρ : ℝ) :
+    Topology.IsClosedEmbedding (fun q : PositiveFibre ρ => (q.1 : ToricSpace.Space)) :=
+  ToricSpace.positivePart_isClosed.isClosedEmbedding_subtypeVal.comp
+    (positiveFibre_isClosed ρ).isClosedEmbedding_subtypeVal
+
+private def CuspSpecialization.positiveFibrePolarMap (ρ : ℝ)
+    (p : ToricSpace.CompactFibreTorus × PositiveFibre ρ) : ToricFibre (ρ : ℂ) :=
+  ⟨ToricSpace.compactFibreAction p.1 (p.2.1 : ToricSpace.Space), by
+    rw [ToricSpace.time_compactFibreAction, p.2.2]⟩
+
+@[simp]
+private theorem CuspSpecialization.positiveFibrePolarMap_coe (ρ : ℝ)
+    (p : ToricSpace.CompactFibreTorus × PositiveFibre ρ) :
+    (positiveFibrePolarMap ρ p : ToricSpace.Space) =
+      ToricSpace.compactFibreAction p.1 (p.2.1 : ToricSpace.Space) :=
+  rfl
+
+private theorem CuspSpecialization.positiveFibrePolarMap_continuous (ρ : ℝ) :
+    Continuous (positiveFibrePolarMap ρ) :=
+  (ToricSpace.compactFibreAction_continuous.comp
+        (continuous_fst.prodMk
+          ((continuous_subtype_val.comp continuous_subtype_val).comp continuous_snd))).subtype_mk
+    _
+
+private theorem CuspSpecialization.modulus_positiveFibrePolarMap (ρ : ℝ)
+    (p : ToricSpace.CompactFibreTorus × PositiveFibre ρ) :
+    ToricSpace.modulus (positiveFibrePolarMap ρ p : ToricSpace.Space) =
+      (p.2.1 : ToricSpace.Space) := by
+  rw [positiveFibrePolarMap_coe, ToricSpace.modulus_compactFibreAction]
+  exact p.2.1.2
+
+private def CuspSpecialization.positiveFibreModulus (ρ : ℝ) (hρ : 0 ≤ ρ) (x : ToricFibre (ρ : ℂ)) :
+    PositiveFibre ρ :=
+  ⟨ToricSpace.modulusRetraction (x : ToricSpace.Space), by
+    rw [ToricSpace.modulusRetraction_coe, ToricSpace.time_modulus, x.2,
+      Complex.norm_of_nonneg hρ]⟩
+
+@[simp]
+private theorem CuspSpecialization.positiveFibreModulus_polarMap (ρ : ℝ) (hρ : 0 ≤ ρ)
+    (p : ToricSpace.CompactFibreTorus × PositiveFibre ρ) :
+    positiveFibreModulus ρ hρ (positiveFibrePolarMap ρ p) = p.2 :=
+  Subtype.ext (Subtype.ext (modulus_positiveFibrePolarMap ρ p))
+
+private theorem CuspSpecialization.compactFibrePhase_injective :
+    Function.Injective ToricSpace.compactFibrePhase := by
+  intro u v huv
+  funext i
+  fin_cases i
+  · exact congrFun huv 0
+  · exact congrFun huv 1
+
+private theorem
+    CuspSpecialization.compactFibreAction_injective_of_time_ne_zero {x : ToricSpace.Space}
+    (hx : ToricSpace.time x ≠ 0) :
+    Function.Injective
+      (fun u : ToricSpace.CompactFibreTorus => ToricSpace.compactFibreAction u x) := by
+  intro u v huv
+  apply compactFibrePhase_injective
+  apply ToricSpace.compactTorusAction_injective_of_time_ne_zero hx
+  simpa only [← ToricSpace.compactFibreAction_eq_compact] using huv
+
+private theorem CuspSpecialization.positiveFibrePolarMap_injective (ρ : ℝ) (hρ : 0 < ρ) :
+    Function.Injective (positiveFibrePolarMap ρ) := by
+  rintro ⟨u, x⟩ ⟨v, y⟩ h
+  have hxy : x = y := by
+    have hm := congrArg (positiveFibreModulus ρ hρ.le) h
+    simpa only [positiveFibreModulus_polarMap] using hm
+  subst y
+  have hx : ToricSpace.time (x.1 : ToricSpace.Space) ≠ 0 := by
+    rw [x.2]
+    exact Complex.ofReal_ne_zero.mpr hρ.ne'
+  have huv : u = v := compactFibreAction_injective_of_time_ne_zero hx (congrArg Subtype.val h)
+  exact Prod.ext huv rfl
+
+private theorem
+    CuspSpecialization.compactTorusPhase_two_eq_one_of_positive_time (ρ : ℝ) (hρ : 0 < ρ)
+    {x : ToricSpace.Space} (hx : ToricSpace.time x = (ρ : ℂ)) (u : ToricSpace.CompactTorus)
+    (hu : ToricSpace.compactTorusAction u (ToricSpace.modulus x) = x) : u 2 = 1 := by
+  have hm : ToricSpace.time (ToricSpace.modulus x) = (ρ : ℂ) := by
+    rw [ToricSpace.time_modulus, hx, Complex.norm_of_nonneg hρ.le]
+  have ht := congrArg ToricSpace.time hu
+  rw [ToricSpace.compactTorusAction, ToricSpace.time_torusAction,
+    ToricSpace.compactTorusUnits_apply, hm, hx] at ht
+  apply Circle.ext
+  apply mul_right_cancel₀ (Complex.ofReal_ne_zero.mpr hρ.ne')
+  simpa only [Circle.coe_one, one_mul] using ht
+
+private theorem
+    CuspSpecialization.exists_compactFibreAction_modulus_of_positive_time (ρ : ℝ) (hρ : 0 < ρ)
+    {x : ToricSpace.Space} (hx : ToricSpace.time x = (ρ : ℂ)) :
+    ∃ u : ToricSpace.CompactFibreTorus,
+      ToricSpace.compactFibreAction u (ToricSpace.modulus x) = x := by
+  obtain ⟨u, hu⟩ := ToricSpace.exists_compactTorusAction_modulus x
+  have hu2 := compactTorusPhase_two_eq_one_of_positive_time ρ hρ hx u hu
+  let uf : ToricSpace.CompactFibreTorus := ![u 0, u 1]
+  have hf : ToricSpace.compactFibrePhase uf = u := by
+    funext i
+    fin_cases i
+    · rfl
+    · rfl
+    · exact hu2.symm
+  refine ⟨uf, ?_⟩
+  rw [ToricSpace.compactFibreAction_eq_compact, hf]
+  exact hu
+
+private theorem CuspSpecialization.positiveFibrePolarMap_surjective (ρ : ℝ) (hρ : 0 < ρ) :
+    Function.Surjective (positiveFibrePolarMap ρ) := by
+  intro x
+  obtain ⟨u, hu⟩ := exists_compactFibreAction_modulus_of_positive_time ρ hρ x.2
+  exact ⟨(u, positiveFibreModulus ρ hρ.le x), Subtype.ext hu⟩
+
+private theorem CuspSpecialization.positiveFibrePolarMap_isProperMap (ρ : ℝ) :
+    IsProperMap (positiveFibrePolarMap ρ) := by
+  have hinc :
+    IsProperMap
+      (fun p : ToricSpace.CompactFibreTorus × PositiveFibre ρ =>
+        (p.1, (p.2.1 : ToricSpace.Space))) :=
+    ((Homeomorph.refl ToricSpace.CompactFibreTorus).isClosedEmbedding.prodMap
+        (positiveFibreVal_isClosedEmbedding ρ)).isProperMap
+  have hcomp :
+    IsProperMap
+      ((Subtype.val : ToricFibre (ρ : ℂ) → ToricSpace.Space) ∘ positiveFibrePolarMap ρ) :=
+    ToricSpace.compactFibreAction_isProperMap.comp hinc
+  exact
+    isProperMap_of_comp_of_inj (positiveFibrePolarMap_continuous ρ) continuous_subtype_val hcomp
+      Subtype.val_injective
+
+private theorem CuspSpecialization.positiveFibrePolarMap_isClosedMap (ρ : ℝ) :
+    IsClosedMap (positiveFibrePolarMap ρ) :=
+  (positiveFibrePolarMap_isProperMap ρ).isClosedMap
+
+private def CuspSpecialization.positiveFibrePolarHomeomorph (ρ : ℝ) (hρ : 0 < ρ) :
+    (ToricSpace.CompactFibreTorus × PositiveFibre ρ) ≃ₜ ToricFibre (ρ : ℂ) :=
+  Equiv.toHomeomorphOfContinuousClosed
+    (Equiv.ofBijective (positiveFibrePolarMap ρ)
+      ⟨positiveFibrePolarMap_injective ρ hρ, positiveFibrePolarMap_surjective ρ hρ⟩)
+    (positiveFibrePolarMap_continuous ρ) (positiveFibrePolarMap_isClosedMap ρ)
+
+@[simp]
+private theorem CuspSpecialization.modulus_torusPoint (w : ToricCharts.CoordinateSpace 3) :
+    ToricSpace.modulus (CuspUniformization.torusPoint w) =
+      CuspUniformization.torusPoint (ToricCharts.coordinateModulus w) := by
+  simp only [CuspUniformization.torusPoint, ToricSpace.modulus_inclusion,
+    ToricCharts.monomial_coordinateModulus]
+
+private theorem CuspSpecialization.torusCoordinates_modulus {x : ToricSpace.Space}
+    (hx : x ∈ ToricSpace.openTorus) :
+    ToricSpace.torusCoordinates (ToricSpace.modulus x) =
+      ToricCharts.coordinateModulus (ToricSpace.torusCoordinates x) := by
+  obtain ⟨z, hz, rfl⟩ := hx
+  rw [ToricSpace.modulus_inclusion,
+    ToricSpace.torusCoordinates_inclusion _
+      ((ToricCharts.coordinateModulus_mem_torus_iff z).mpr hz),
+    ToricSpace.torusCoordinates_inclusion _ hz, ToricCharts.monomial_coordinateModulus]
+
+private theorem
+    CuspSpecialization.positivePart_torusCoordinates_eq_norm (q : ToricSpace.PositivePart)
+    (ht : ToricSpace.time (q : ToricSpace.Space) ≠ 0) (i : Fin 3) :
+    ToricSpace.torusCoordinates (q : ToricSpace.Space) i =
+      (‖ToricSpace.torusCoordinates (q : ToricSpace.Space) i‖ : ℂ) := by
+  have hx : (q : ToricSpace.Space) ∈ ToricSpace.openTorus :=
+    (ToricSpace.mem_openTorus_iff _).mpr ht
+  have hq : ToricSpace.modulus (q : ToricSpace.Space) = (q : ToricSpace.Space) := q.2
+  simpa only [hq, ToricCharts.coordinateModulus_apply] using
+    congrFun (torusCoordinates_modulus hx) i
+
+private theorem
+    CuspSpecialization.positivePart_torusCoordinates_norm_pos (q : ToricSpace.PositivePart)
+    (ht : ToricSpace.time (q : ToricSpace.Space) ≠ 0) (i : Fin 3) :
+    0 < ‖ToricSpace.torusCoordinates (q : ToricSpace.Space) i‖ :=
+  norm_pos_iff.mpr
+    (ToricSpace.torusCoordinates_nonzero ((ToricSpace.mem_openTorus_iff _).mpr ht) i)
+
+private theorem
+    CuspSpecialization.positiveFibre_time_ne_zero (ρ : ℝ) (hρ : 0 < ρ) (q : PositiveFibre ρ) :
+    ToricSpace.time (q.1 : ToricSpace.Space) ≠ 0 := by
+  rw [q.2]
+  exact Complex.ofReal_ne_zero.mpr hρ.ne'
+
+private def CuspSpecialization.positiveLogCoordinates (ρ : ℝ) (r : (CuspHoneycombTiling.Plane)) :
+    ToricCharts.CoordinateSpace 3 :=
+  ![(Real.exp (Real.log ρ * r 0) : ℂ), (Real.exp (Real.log ρ * r 1) : ℂ), (ρ : ℂ)]
+
+private theorem CuspSpecialization.positiveLogCoordinates_mem {ρ : ℝ} (hρ : 0 < ρ)
+    (r : (CuspHoneycombTiling.Plane)) : positiveLogCoordinates ρ r ∈ ToricCharts.torus := by
+  intro i
+  fin_cases i
+  · exact Complex.ofReal_ne_zero.mpr (Real.exp_ne_zero _)
+  · exact Complex.ofReal_ne_zero.mpr (Real.exp_ne_zero _)
+  · exact Complex.ofReal_ne_zero.mpr hρ.ne'
+
+private theorem CuspSpecialization.torusCoordinates_positiveLogPoint {ρ : ℝ} (hρ : 0 < ρ)
+    (r : (CuspHoneycombTiling.Plane)) :
+    ToricSpace.torusCoordinates (CuspUniformization.torusPoint (positiveLogCoordinates ρ r)) =
+      positiveLogCoordinates ρ r :=
+  CuspUniformization.torusCoordinates_torusPoint (positiveLogCoordinates_mem hρ r)
+
+private theorem CuspSpecialization.time_positiveLogPoint {ρ : ℝ} (hρ : 0 < ρ)
+    (r : (CuspHoneycombTiling.Plane)) :
+    ToricSpace.time (CuspUniformization.torusPoint (positiveLogCoordinates ρ r)) = (ρ : ℂ) := by
+  simpa [positiveLogCoordinates] using congrFun (torusCoordinates_positiveLogPoint hρ r) 2
+
+private theorem
+    CuspSpecialization.position_positiveLogPoint {ρ : ℝ} (hρ : 0 < ρ) (hlog : Real.log ρ ≠ 0)
+    (r : (CuspHoneycombTiling.Plane)) :
+    ToricSpace.position (CuspUniformization.torusPoint (positiveLogCoordinates ρ r)) = r := by
+  funext i
+  rw [ToricSpace.position, ToricSpace.logCoordinates, torusCoordinates_positiveLogPoint hρ r,
+    time_positiveLogPoint hρ r, Complex.norm_of_nonneg hρ.le]
+  fin_cases i
+  · change Real.log ‖(Real.exp (Real.log ρ * r 0) : ℂ)‖ / Real.log ρ = r 0
+    rw [Complex.norm_of_nonneg (Real.exp_nonneg _), Real.log_exp]
+    exact mul_div_cancel_left₀ _ hlog
+  · change Real.log ‖(Real.exp (Real.log ρ * r 1) : ℂ)‖ / Real.log ρ = r 1
+    rw [Complex.norm_of_nonneg (Real.exp_nonneg _), Real.log_exp]
+    exact mul_div_cancel_left₀ _ hlog
+
+private theorem CuspSpecialization.positiveLogCoordinates_continuous (ρ : ℝ) :
+    Continuous (positiveLogCoordinates ρ) := by
+  apply continuous_pi
+  intro i
+  fin_cases i
+  · exact
+      Complex.continuous_ofReal.comp
+        (Real.continuous_exp.comp (continuous_const.mul (continuous_apply 0)))
+  · exact
+      Complex.continuous_ofReal.comp
+        (Real.continuous_exp.comp (continuous_const.mul (continuous_apply 1)))
+  · exact continuous_const
+
+private theorem CuspSpecialization.positiveLogPoint_continuous {ρ : ℝ} (hρ : 0 < ρ) :
+    Continuous
+      (fun r : (CuspHoneycombTiling.Plane) =>
+        CuspUniformization.torusPoint (positiveLogCoordinates ρ r)) :=
+  CuspUniformization.torusChart.symm.continuousOn.comp_continuous
+    (positiveLogCoordinates_continuous ρ) (fun r => positiveLogCoordinates_mem hρ r)
+
+private theorem CuspSpecialization.positiveLogPoint_mem_positivePart {ρ : ℝ} (hρ : 0 < ρ)
+    (r : (CuspHoneycombTiling.Plane)) :
+    CuspUniformization.torusPoint (positiveLogCoordinates ρ r) ∈ ToricSpace.positivePart := by
+  change ToricSpace.modulus (CuspUniformization.torusPoint (positiveLogCoordinates ρ r)) = _
+  rw [modulus_torusPoint]
+  apply congrArg CuspUniformization.torusPoint
+  funext i
+  fin_cases i
+  · change (‖(Real.exp (Real.log ρ * r 0) : ℂ)‖ : ℂ) = (Real.exp (Real.log ρ * r 0) : ℂ)
+    rw [Complex.norm_of_nonneg (Real.exp_nonneg _)]
+  · change (‖(Real.exp (Real.log ρ * r 1) : ℂ)‖ : ℂ) = (Real.exp (Real.log ρ * r 1) : ℂ)
+    rw [Complex.norm_of_nonneg (Real.exp_nonneg _)]
+  · change (‖(ρ : ℂ)‖ : ℂ) = (ρ : ℂ)
+    rw [Complex.norm_of_nonneg hρ.le]
+
+private def CuspSpecialization.positivePositionPoint (ρ : ℝ) (hρ : 0 < ρ)
+    (r : (CuspHoneycombTiling.Plane)) : PositiveFibre ρ :=
+  ⟨⟨CuspUniformization.torusPoint (positiveLogCoordinates ρ r),
+      positiveLogPoint_mem_positivePart hρ r⟩,
+    time_positiveLogPoint hρ r⟩
+
+@[simp]
+private theorem CuspSpecialization.position_positivePositionPoint (ρ : ℝ) (hρ : 0 < ρ)
+    (hlog : Real.log ρ ≠ 0) (r : (CuspHoneycombTiling.Plane)) :
+    ToricSpace.position ((positivePositionPoint ρ hρ r).1 : ToricSpace.Space) = r :=
+  position_positiveLogPoint hρ hlog r
+
+private theorem CuspSpecialization.positivePositionPoint_continuous (ρ : ℝ) (hρ : 0 < ρ) :
+    Continuous (positivePositionPoint ρ hρ) := by
+  apply Continuous.subtype_mk
+  exact (positiveLogPoint_continuous hρ).subtype_mk _
+
+private theorem CuspSpecialization.position_positiveFibre_injective (ρ : ℝ) (hρ : 0 < ρ)
+    (hlog : Real.log ρ ≠ 0) :
+    Function.Injective
+      (fun q : PositiveFibre ρ => ToricSpace.position (q.1 : ToricSpace.Space)) := by
+  intro q r he
+  have hq := positiveFibre_time_ne_zero ρ hρ q
+  have hr := positiveFibre_time_ne_zero ρ hρ r
+  have hcoord (i : Fin 2) :
+    ToricSpace.torusCoordinates (q.1 : ToricSpace.Space) i.castSucc =
+      ToricSpace.torusCoordinates (r.1 : ToricSpace.Space) i.castSucc := by
+    have hl :
+      Real.log ‖ToricSpace.torusCoordinates (q.1 : ToricSpace.Space) i.castSucc‖ =
+        Real.log ‖ToricSpace.torusCoordinates (r.1 : ToricSpace.Space) i.castSucc‖ := by
+      have hi := congrFun he i
+      change
+        Real.log ‖ToricSpace.torusCoordinates (q.1 : ToricSpace.Space) i.castSucc‖ /
+            Real.log ‖ToricSpace.time (q.1 : ToricSpace.Space)‖ =
+          Real.log ‖ToricSpace.torusCoordinates (r.1 : ToricSpace.Space) i.castSucc‖ /
+            Real.log ‖ToricSpace.time (r.1 : ToricSpace.Space)‖ at hi
+      rw [norm_time_positiveFibre ρ hρ.le q, norm_time_positiveFibre ρ hρ.le r] at hi
+      have hm := congrArg (fun z : ℝ => z * Real.log ρ) hi
+      simpa only [div_mul_cancel₀ _ hlog] using hm
+    have hn := congrArg Real.exp hl
+    rw [Real.exp_log (positivePart_torusCoordinates_norm_pos q.1 hq i.castSucc),
+      Real.exp_log (positivePart_torusCoordinates_norm_pos r.1 hr i.castSucc)] at hn
+    rw [positivePart_torusCoordinates_eq_norm q.1 hq i.castSucc,
+      positivePart_torusCoordinates_eq_norm r.1 hr i.castSucc, hn]
+  apply Subtype.ext
+  apply Subtype.ext
+  apply
+    CuspUniformization.torusCoordinates_injective ((ToricSpace.mem_openTorus_iff _).mpr hq)
+      ((ToricSpace.mem_openTorus_iff _).mpr hr)
+  funext i
+  fin_cases i
+  · exact hcoord 0
+  · exact hcoord 1
+  · change
+      ToricSpace.torusCoordinates (q.1 : ToricSpace.Space) 2 =
+        ToricSpace.torusCoordinates (r.1 : ToricSpace.Space) 2
+    rw [ToricSpace.torusCoordinates_time, ToricSpace.torusCoordinates_time, q.2, r.2]
+
+private theorem
+    CuspSpecialization.realCuspVector_neg_realCuspVector (y : (CuspHoneycombTiling.Plane)) :
+    ToricSpace.realCuspVector (-ToricSpace.realCuspVector y) = y := by
+  ext i
+  fin_cases i <;> simp [ToricSpace.realCuspVector]
+
+private theorem
+    CuspSpecialization.neg_realCuspVector_realCuspVector (y : (CuspHoneycombTiling.Plane)) :
+    -ToricSpace.realCuspVector (ToricSpace.realCuspVector y) = y := by
+  rw [← map_neg, realCuspVector_neg_realCuspVector]
+
+private def CuspSpecialization.normalizedPositivePoint (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ)
+    (hρ : 0 < ρ) (y : (CuspHoneycombTiling.Plane)) : PositiveFibre ρ :=
+  positivePositionPoint ρ hρ
+    (ToricSpace.displacement (CuspPositive.positiveTwist C₀) (ρ : ℂ)
+      (-ToricSpace.realCuspVector y))
+
+private theorem
+    CuspSpecialization.normalizedPositivePoint_continuous (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (ρ : ℝ) (hρ : 0 < ρ) : Continuous (normalizedPositivePoint C₀ ρ hρ) :=
+  (positivePositionPoint_continuous ρ hρ).comp
+    ((ToricSpace.displacement (CuspPositive.positiveTwist C₀)
+          (ρ : ℂ)).continuous_of_finiteDimensional.comp
+      CuspControlledRetraction.realCuspVector_continuous.neg)
+
+private theorem CuspSpecialization.position_normalizedPositivePoint (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (ρ : ℝ) (hρ : 0 < ρ) (hlog : Real.log ρ ≠ 0) (y : (CuspHoneycombTiling.Plane)) :
+    ToricSpace.position ((normalizedPositivePoint C₀ ρ hρ y).1 : ToricSpace.Space) =
+      ToricSpace.displacement (CuspPositive.positiveTwist C₀) (ρ : ℂ)
+        (-ToricSpace.realCuspVector y) :=
+  position_positivePositionPoint ρ hρ hlog _
+
+private theorem CuspSpecialization.normalizedPosition_normalizedPositivePoint
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε)
+    (y : (CuspHoneycombTiling.Plane)) :
+    CuspControlledRetraction.normalizedPosition C₀
+        ((normalizedPositivePoint C₀ ρ hρ y).1 : ToricSpace.Space) =
+      y := by
+  have hlog : Real.log ρ < 0 := Real.log_neg hρ (hρε.trans hε1)
+  have hlogC : Real.log ‖(ρ : ℂ)‖ < 0 := by simpa only [Complex.norm_of_nonneg hρ.le] using hlog
+  rw [CuspControlledRetraction.normalizedPosition, time_positiveFibre,
+    position_normalizedPositivePoint C₀ ρ hρ hlog.ne,
+    ToricSpace.inverseDisplacement_displacement (CuspPositive.positiveTwist C₀) hlogC
+      (hR _ (by simpa only [Complex.norm_of_nonneg hρ.le] using hρ)
+        (by simpa only [Complex.norm_of_nonneg hρ.le] using hρε))]
+  exact realCuspVector_neg_realCuspVector y
+
+private theorem CuspSpecialization.normalizedPositivePoint_normalizedPosition
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (q : PositiveFibre ρ) :
+    normalizedPositivePoint C₀ ρ hρ
+        (CuspControlledRetraction.normalizedPosition C₀ (q.1 : ToricSpace.Space)) =
+      q := by
+  have hlog : Real.log ρ < 0 := Real.log_neg hρ (hρε.trans hε1)
+  have hlogC : Real.log ‖(ρ : ℂ)‖ < 0 := by simpa only [Complex.norm_of_nonneg hρ.le] using hlog
+  apply position_positiveFibre_injective ρ hρ hlog.ne
+  change
+    ToricSpace.position
+        ((normalizedPositivePoint C₀ ρ hρ
+              (CuspControlledRetraction.normalizedPosition C₀ (q.1 : ToricSpace.Space))).1 :
+          ToricSpace.Space) =
+      ToricSpace.position (q.1 : ToricSpace.Space)
+  rw [position_normalizedPositivePoint C₀ ρ hρ hlog.ne,
+    CuspControlledRetraction.normalizedPosition, q.2, neg_realCuspVector_realCuspVector]
+  exact
+    ToricSpace.displacement_inverseDisplacement (CuspPositive.positiveTwist C₀) hlogC
+      (hR _ (by simpa only [Complex.norm_of_nonneg hρ.le] using hρ)
+        (by simpa only [Complex.norm_of_nonneg hρ.le] using hρε))
+      _
+
+private theorem CuspSpecialization.normalizedPosition_positiveFibre_continuous
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) :
+    Continuous
+      (fun q : PositiveFibre ρ =>
+        CuspControlledRetraction.normalizedPosition C₀ (q.1 : ToricSpace.Space)) := by
+  apply continuous_iff_continuousAt.mpr
+  intro q
+  have ht : ‖ToricSpace.time (q.1 : ToricSpace.Space)‖ < ε := by
+    rw [norm_time_positiveFibre ρ hρ.le q]
+    exact hρε
+  exact
+    ContinuousAt.comp (f := fun r : PositiveFibre ρ => (r.1 : ToricSpace.Space)) (g :=
+      CuspControlledRetraction.normalizedPosition C₀)
+      (CuspControlledRetraction.normalizedPosition_continuousAt C₀ hε1 hR
+        (positiveFibre_time_ne_zero ρ hρ q) ht)
+      (positiveFibreInclusion ρ).continuous.continuousAt
+
+private def CuspSpecialization.normalizedPositiveHomeomorph (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ)
+    (hρ : 0 < ρ) (ε : ℝ) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) :
+    (CuspHoneycombTiling.Plane) ≃ₜ PositiveFibre ρ
+    where
+  toFun := normalizedPositivePoint C₀ ρ hρ
+  invFun q := CuspControlledRetraction.normalizedPosition C₀ (q.1 : ToricSpace.Space)
+  left_inv := normalizedPosition_normalizedPositivePoint C₀ ρ hρ ε hε1 hρε hR
+  right_inv := normalizedPositivePoint_normalizedPosition C₀ ρ hρ ε hε1 hρε hR
+  continuous_toFun := normalizedPositivePoint_continuous C₀ ρ hρ
+  continuous_invFun := normalizedPosition_positiveFibre_continuous C₀ ρ hρ ε hε1 hρε hR
+
+@[simp]
+private theorem
+    CuspSpecialization.normalizedPositiveHomeomorph_apply (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε)
+    (y : (CuspHoneycombTiling.Plane)) :
+    normalizedPositiveHomeomorph C₀ ρ hρ ε hε1 hρε hR y = normalizedPositivePoint C₀ ρ hρ y :=
+  rfl
+
+@[simp]
+private theorem
+    CuspSpecialization.normalizedPositiveHomeomorph_symm_apply (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (q : PositiveFibre ρ) :
+    (normalizedPositiveHomeomorph C₀ ρ hρ ε hε1 hρε hR).symm q =
+      CuspControlledRetraction.normalizedPosition C₀ (q.1 : ToricSpace.Space) :=
+  rfl
+
+private def CuspSpecialization.positiveFibreTranslate (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ)
+    (v : Fin 2 → ℤ) (q : PositiveFibre ρ) : PositiveFibre ρ :=
+  ⟨⟨ToricSpace.twistedTranslate (CuspPositive.positiveTwist C₀) v (q.1 : ToricSpace.Space),
+      CuspPositive.twistedTranslate_positiveTwist_preserves_positivePart C₀ v q.1.2⟩,
+    by rw [ToricSpace.time_twistedTranslate, q.2]⟩
+
+@[simp]
+private theorem
+    CuspSpecialization.positiveFibreTranslate_coe (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ)
+    (v : Fin 2 → ℤ) (q : PositiveFibre ρ) :
+    ((positiveFibreTranslate C₀ ρ v q).1 : ToricSpace.Space) =
+      ToricSpace.twistedTranslate (CuspPositive.positiveTwist C₀) v (q.1 : ToricSpace.Space) :=
+  rfl
+
+private theorem CuspSpecialization.normalizedPosition_positiveFibreTranslate
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (v : Fin 2 → ℤ)
+    (q : PositiveFibre ρ) :
+    CuspControlledRetraction.normalizedPosition C₀
+        ((positiveFibreTranslate C₀ ρ v q).1 : ToricSpace.Space) =
+      CuspControlledRetraction.normalizedPosition C₀ (q.1 : ToricSpace.Space) +
+        CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v) := by
+  have hq : ToricSpace.time (q.1 : ToricSpace.Space) ≠ 0 := by
+    rw [q.2]
+    exact Complex.ofReal_ne_zero.mpr hρ.ne'
+  have ht : ‖ToricSpace.time (q.1 : ToricSpace.Space)‖ < ε := by
+    rw [norm_time_positiveFibre ρ hρ.le q]
+    exact hρε
+  exact CuspControlledRetraction.normalizedPosition_twistedTranslate C₀ hε1 hR v hq ht
+
+private theorem CuspSpecialization.normalizedPositiveHomeomorph_equivariant
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (v : Fin 2 → ℤ)
+    (y : (CuspHoneycombTiling.Plane)) :
+    normalizedPositiveHomeomorph C₀ ρ hρ ε hε1 hρε hR
+        (y + CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v)) =
+      positiveFibreTranslate C₀ ρ v (normalizedPositiveHomeomorph C₀ ρ hρ ε hε1 hρε hR y) := by
+  apply (normalizedPositiveHomeomorph C₀ ρ hρ ε hε1 hρε hR).symm.injective
+  rw [Homeomorph.symm_apply_apply, normalizedPositiveHomeomorph_symm_apply,
+    normalizedPosition_positiveFibreTranslate C₀ ρ hρ ε hε1 hρε hR]
+  have hy := (normalizedPositiveHomeomorph C₀ ρ hρ ε hε1 hρε hR).symm_apply_apply y
+  rw [normalizedPositiveHomeomorph_symm_apply] at hy
+  rw [hy]
+
+private theorem
+    CuspSpecialization.normalizedPositivePoint_equivariant (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (v : Fin 2 → ℤ)
+    (y : (CuspHoneycombTiling.Plane)) :
+    normalizedPositivePoint C₀ ρ hρ
+        (y + CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v)) =
+      positiveFibreTranslate C₀ ρ v (normalizedPositivePoint C₀ ρ hρ y) := by
+  simpa only [normalizedPositiveHomeomorph_apply] using
+    normalizedPositiveHomeomorph_equivariant C₀ ρ hρ ε hε1 hρε hR v y
+
+private def
+    CuspSpecialization.frozenPhaseHomeomorph (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ) (hρ : 0 < ρ)
+    (ε : ℝ) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) :
+    CuspHoneycomb.PhasePlane ≃ₜ ToricFibre (ρ : ℂ) :=
+  ((Homeomorph.refl ToricSpace.CompactFibreTorus).prodCongr
+        (normalizedPositiveHomeomorph C₀ ρ hρ ε hε1 hρε hR)).trans
+    (positiveFibrePolarHomeomorph ρ hρ)
+
+private theorem
+    CuspSpecialization.frozenPhaseHomeomorph_coe_homeomorph (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε)
+    (p : CuspHoneycomb.PhasePlane) :
+    (frozenPhaseHomeomorph C₀ ρ hρ ε hε1 hρε hR p : ToricSpace.Space) =
+      ToricSpace.compactFibreAction p.1
+        ((normalizedPositiveHomeomorph C₀ ρ hρ ε hε1 hρε hR p.2).1 : ToricSpace.Space) :=
+  rfl
+
+@[simp]
+private theorem CuspSpecialization.frozenPhaseHomeomorph_coe (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ)
+    (hρ : 0 < ρ) (ε : ℝ) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε)
+    (p : CuspHoneycomb.PhasePlane) :
+    (frozenPhaseHomeomorph C₀ ρ hρ ε hε1 hρε hR p : ToricSpace.Space) =
+      ToricSpace.compactFibreAction p.1
+        ((normalizedPositivePoint C₀ ρ hρ p.2).1 : ToricSpace.Space) := by
+  rw [frozenPhaseHomeomorph_coe_homeomorph, normalizedPositiveHomeomorph_apply]
+
+@[simp]
+private theorem CuspSpecialization.sourceDeck_zero (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (p : CuspHoneycomb.PhasePlane) : CuspHoneycomb.honeycombDeckMap C₀ 0 p = p := by
+  simp only [CuspHoneycomb.honeycombDeckMap, CuspCollapse.deckFibrePhase_zero, one_mul,
+    ToricSpace.cuspVector_zero, CuspHoneycombTiling.latticePoint_zero, add_zero, Prod.eta]
+
+private theorem CuspSpecialization.sourceDeck_add (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (v w : Fin 2 → ℤ)
+    (p : CuspHoneycomb.PhasePlane) :
+    CuspHoneycomb.honeycombDeckMap C₀ v (CuspHoneycomb.honeycombDeckMap C₀ w p) =
+      CuspHoneycomb.honeycombDeckMap C₀ (v + w) p := by
+  apply Prod.ext
+  · change
+      CuspCollapse.deckFibrePhase C₀ v * (CuspCollapse.deckFibrePhase C₀ w * p.1) =
+        CuspCollapse.deckFibrePhase C₀ (v + w) * p.1
+    rw [CuspCollapse.deckFibrePhase_add, mul_assoc]
+  · change
+      (p.2 + CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector w)) +
+          CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v) =
+        p.2 + CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector (v + w))
+    rw [ToricSpace.cuspVector_add, CuspHoneycombTiling.latticePoint_add]
+    abel
+
+private def CuspSpecialization.sourceDeckSetoid (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    Setoid CuspHoneycomb.PhasePlane
+    where
+  r p q := ∃ v : Fin 2 → ℤ, CuspHoneycomb.honeycombDeckMap C₀ v q = p
+  iseqv :=
+    { refl := fun p => ⟨0, sourceDeck_zero C₀ p⟩
+      symm := by
+        rintro p q ⟨v, hv⟩
+        refine ⟨-v, ?_⟩
+        rw [← hv, sourceDeck_add, neg_add_cancel, sourceDeck_zero]
+      trans := by
+        rintro p q r ⟨v, hv⟩ ⟨w, hw⟩
+        refine ⟨v + w, ?_⟩
+        rw [← sourceDeck_add, hw, hv] }
+
+private abbrev CuspSpecialization.SourceModel (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :=
+  Quotient (sourceDeckSetoid C₀)
+
+private def CuspSpecialization.sourceProjection (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    CuspHoneycomb.PhasePlane → SourceModel C₀ :=
+  Quotient.mk (sourceDeckSetoid C₀)
+
+private theorem CuspSpecialization.sourceProjection_continuous (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    Continuous (sourceProjection C₀) :=
+  continuous_quotient_mk'
+
+private theorem CuspSpecialization.sourceProjection_surjective (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    Function.Surjective (sourceProjection C₀) :=
+  Quotient.mk_surjective
+
+private theorem CuspSpecialization.sourceProjection_isQuotientMap (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    Topology.IsQuotientMap (sourceProjection C₀) :=
+  isQuotientMap_quotient_mk'
+
+private theorem CuspSpecialization.sourceProjection_eq_iff (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (p q : CuspHoneycomb.PhasePlane) :
+    sourceProjection C₀ p = sourceProjection C₀ q ↔
+      ∃ v : Fin 2 → ℤ, CuspHoneycomb.honeycombDeckMap C₀ v q = p :=
+  ⟨Quotient.exact, fun h => @Quotient.sound CuspHoneycomb.PhasePlane (sourceDeckSetoid C₀) p q h⟩
+
+private theorem
+    CuspSpecialization.honeycombCollapseMap_sourceDeck (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (v : Fin 2 → ℤ) (p : CuspHoneycomb.PhasePlane) :
+    CuspHoneycomb.honeycombCollapseMap C ε hε (CuspHoneycomb.honeycombDeckMap (C 0) v p) =
+      CuspHoneycomb.honeycombCollapseMap C ε hε p := by
+  apply (CuspHoneycomb.honeycombCollapseMap_eq_iff C ε hε _ p).mpr
+  refine ⟨v, rfl, ?_⟩
+  change
+    (CuspCollapse.deckFibrePhase (C 0) v * p.1)⁻¹ * (CuspCollapse.deckFibrePhase (C 0) v * p.1) ∈
+      _
+  rw [inv_mul_cancel]
+  exact Subgroup.one_mem _
+
+private def
+    CuspSpecialization.sourceCollapse (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    C(SourceModel (C 0), CuspRetraction.QuotientCentralFibre C ε)
+    where
+  toFun :=
+    Quotient.lift (CuspHoneycomb.honeycombCollapseMap C ε hε)
+      (by
+        rintro p q ⟨v, hv⟩
+        rw [← hv]
+        exact honeycombCollapseMap_sourceDeck C ε hε v q)
+  continuous_toFun := (CuspHoneycomb.honeycombCollapseMap_continuous C ε hε).quotient_lift _
+
+@[simp]
+private theorem
+    CuspSpecialization.sourceCollapse_projection (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (p : CuspHoneycomb.PhasePlane) :
+    sourceCollapse C ε hε (sourceProjection (C 0) p) =
+      CuspHoneycomb.honeycombCollapseMap C ε hε p :=
+  rfl
+
+private theorem CuspSpecialization.circle_exp_two_pi : Circle.exp (2 * Real.pi) = 1 := by
+  apply Circle.ext
+  simpa only [Circle.coe_exp, Circle.coe_one, Complex.ofReal_mul, Complex.ofReal_ofNat] using
+    Complex.exp_two_pi_mul_I
+
+private def CuspSpecialization.planarPhase (y : (CuspHoneycombTiling.Plane)) :
+    ToricSpace.CompactFibreTorus := fun i => Circle.exp (2 * Real.pi * y i)
+
+private theorem CuspSpecialization.planarPhase_continuous : Continuous planarPhase := by
+  apply continuous_pi
+  intro i
+  exact Circle.exp.continuous.comp (continuous_const.mul (continuous_apply i))
+
+private theorem CuspSpecialization.circle_exp_add_integer (a y : ℝ) (n : ℤ) :
+    Circle.exp (a * (y + n)) = Circle.exp (a * y) * Circle.exp a ^ n := by
+  rw [mul_add, Circle.exp_add]
+  congr 1
+  rw [mul_comm, Circle.exp_intCast_mul]
+
+private theorem CuspSpecialization.planarPhase_add_latticePoint (y : (CuspHoneycombTiling.Plane))
+    (v : Fin 2 → ℤ) : planarPhase (y + CuspHoneycombTiling.latticePoint v) = planarPhase y := by
+  funext i
+  change Circle.exp (2 * Real.pi * (y i + (v i : ℝ))) = _
+  rw [circle_exp_add_integer, circle_exp_two_pi, one_zpow, mul_one]
+  rfl
+
+private def CuspSpecialization.compensatingPhase (r : ℝ) (p : CuspHoneycomb.PhasePlane) :
+    ToricSpace.CompactTorus :=
+  ![p.1 0 * Circle.exp (2 * Real.pi * r * p.2 0), p.1 1 * Circle.exp (2 * Real.pi * r * p.2 1),
+    Circle.exp (2 * Real.pi * r)]
+
+private theorem CuspSpecialization.compensatingPhase_continuous :
+    Continuous (fun p : ℝ × CuspHoneycomb.PhasePlane => compensatingPhase p.1 p.2) := by
+  apply continuous_pi
+  intro i
+  fin_cases i <;> simp only [compensatingPhase] <;> fun_prop
+
+@[simp]
+private theorem CuspSpecialization.compensatingPhase_zero (p : CuspHoneycomb.PhasePlane) :
+    compensatingPhase 0 p = ToricSpace.compactFibrePhase p.1 := by
+  funext i
+  fin_cases i <;> simp [compensatingPhase, ToricSpace.compactFibrePhase]
+
+@[simp]
+private theorem CuspSpecialization.compensatingPhase_one (p : CuspHoneycomb.PhasePlane) :
+    compensatingPhase 1 p = ToricSpace.compactFibrePhase (p.1 * planarPhase p.2) := by
+  funext i
+  fin_cases i <;> simp [compensatingPhase, ToricSpace.compactFibrePhase, planarPhase]
+
+private theorem
+    CuspSpecialization.compensatingPhase_deck (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ)
+    (r : ℝ) (p : CuspHoneycomb.PhasePlane) :
+    compensatingPhase r (CuspHoneycomb.honeycombDeckMap C₀ v p) =
+      CuspPositive.phaseTransform C₀ v (compensatingPhase r p) := by
+  funext i
+  fin_cases i
+  · change
+      (CuspCollapse.deckFibrePhase C₀ v 0 * p.1 0) *
+          Circle.exp (2 * Real.pi * r * (p.2 0 + (ToricSpace.cuspVector v 0 : ℝ))) =
+        CuspPositive.frozenPhaseCoordinate C₀ v 0 *
+          ((p.1 0 * Circle.exp (2 * Real.pi * r * p.2 0)) *
+            Circle.exp (2 * Real.pi * r) ^ ToricSpace.cuspVector v 0)
+    rw [circle_exp_add_integer]
+    simp only [CuspCollapse.deckFibrePhase, mul_assoc]
+  · change
+      (CuspCollapse.deckFibrePhase C₀ v 1 * p.1 1) *
+          Circle.exp (2 * Real.pi * r * (p.2 1 + (ToricSpace.cuspVector v 1 : ℝ))) =
+        CuspPositive.frozenPhaseCoordinate C₀ v 1 *
+          ((p.1 1 * Circle.exp (2 * Real.pi * r * p.2 1)) *
+            Circle.exp (2 * Real.pi * r) ^ ToricSpace.cuspVector v 1)
+    rw [circle_exp_add_integer]
+    simp only [CuspCollapse.deckFibrePhase, mul_assoc]
+  · simp [compensatingPhase, CuspPositive.phaseTransform, CuspPositive.frozenPhase,
+      ToricSpace.phaseShear]
+
+private def CuspSpecialization.rotatedLevel (ρ r : ℝ) : ℂ :=
+  (Circle.exp (2 * Real.pi * r) : ℂ) * (ρ : ℂ)
+
+@[simp]
+private theorem
+    CuspSpecialization.norm_rotatedLevel (ρ r : ℝ) (hρ : 0 ≤ ρ) : ‖rotatedLevel ρ r‖ = ρ := by
+  rw [rotatedLevel, norm_mul, Circle.norm_coe, one_mul, Complex.norm_of_nonneg hρ]
+
+private theorem
+    CuspSpecialization.rotatedLevel_ne_zero (ρ r : ℝ) (hρ : 0 < ρ) : rotatedLevel ρ r ≠ 0 := by
+  apply norm_ne_zero_iff.mp
+  rw [norm_rotatedLevel ρ r hρ.le]
+  exact hρ.ne'
+
+private theorem
+    CuspSpecialization.rotatedLevel_norm_lt (ρ r : ℝ) (hρ : 0 ≤ ρ) (ε : ℝ) (hρε : ρ < ε) :
+    ‖rotatedLevel ρ r‖ < ε := by rwa [norm_rotatedLevel ρ r hρ]
+
+private theorem
+    CuspSpecialization.rotatedLevel_norm_le (ρ r : ℝ) (hρ : 0 ≤ ρ) (η : ℝ) (hρη : ρ ≤ η) :
+    ‖rotatedLevel ρ r‖ ≤ η := by rwa [norm_rotatedLevel ρ r hρ]
+
+private def CuspSpecialization.baseRotationPhase (r : ℝ) : ToricSpace.CompactTorus :=
+  ![1, 1, Circle.exp (2 * Real.pi * r)]
+
+private def CuspSpecialization.baseRotationMap (ρ r : ℝ) (x : ToricFibre (ρ : ℂ)) :
+    ToricFibre (rotatedLevel ρ r) :=
+  ⟨ToricSpace.compactTorusAction (baseRotationPhase r) x,
+    by
+    rw [ToricSpace.compactTorusAction, ToricSpace.time_torusAction,
+      ToricSpace.compactTorusUnits_apply, x.2]
+    rfl⟩
+
+private def
+    CuspSpecialization.baseInverseRotationMap (ρ r : ℝ) (x : ToricFibre (rotatedLevel ρ r)) :
+    ToricFibre (ρ : ℂ) :=
+  ⟨ToricSpace.compactTorusAction (baseRotationPhase r)⁻¹ x,
+    by
+    rw [ToricSpace.compactTorusAction, ToricSpace.time_torusAction,
+      ToricSpace.compactTorusUnits_apply, x.2]
+    change
+      ((Circle.exp (2 * Real.pi * r))⁻¹ : Circle) *
+          ((Circle.exp (2 * Real.pi * r) : ℂ) * (ρ : ℂ)) =
+        (ρ : ℂ)
+    rw [Circle.coe_inv, inv_mul_cancel_left₀ (Circle.coe_ne_zero _)]⟩
+
+private theorem CuspSpecialization.baseRotationMap_continuous (ρ r : ℝ) :
+    Continuous (baseRotationMap ρ r) := by
+  have h :
+    Continuous
+      (fun x : ToricFibre (ρ : ℂ) =>
+        ToricSpace.compactTorusAction (baseRotationPhase r) (x : ToricSpace.Space)) := by
+    change Continuous (fun x : ToricFibre (ρ : ℂ) => baseRotationPhase r • (x : ToricSpace.Space))
+    exact
+      (continuous_const : Continuous (fun _ : ToricFibre (ρ : ℂ) => baseRotationPhase r)).smul
+        (continuous_subtype_val :
+          Continuous (fun x : ToricFibre (ρ : ℂ) => (x : ToricSpace.Space)))
+  exact h.subtype_mk _
+
+private theorem CuspSpecialization.baseInverseRotationMap_continuous (ρ r : ℝ) :
+    Continuous (baseInverseRotationMap ρ r) := by
+  have h :
+    Continuous
+      (fun x : ToricFibre (rotatedLevel ρ r) =>
+        ToricSpace.compactTorusAction (baseRotationPhase r)⁻¹ (x : ToricSpace.Space)) := by
+    change
+      Continuous
+        (fun x : ToricFibre (rotatedLevel ρ r) =>
+          (baseRotationPhase r)⁻¹ • (x : ToricSpace.Space))
+    exact
+      (continuous_const :
+            Continuous (fun _ : ToricFibre (rotatedLevel ρ r) => (baseRotationPhase r)⁻¹)).smul
+        (continuous_subtype_val :
+          Continuous (fun x : ToricFibre (rotatedLevel ρ r) => (x : ToricSpace.Space)))
+  exact h.subtype_mk _
+
+private def CuspSpecialization.baseRotationHomeomorph (ρ r : ℝ) :
+    ToricFibre (ρ : ℂ) ≃ₜ ToricFibre (rotatedLevel ρ r)
+    where
+  toFun := baseRotationMap ρ r
+  invFun := baseInverseRotationMap ρ r
+  left_inv
+    x := by
+    apply Subtype.ext
+    change
+      ToricSpace.compactTorusAction (baseRotationPhase r)⁻¹
+          (ToricSpace.compactTorusAction (baseRotationPhase r) (x : ToricSpace.Space)) =
+        (x : ToricSpace.Space)
+    rw [ToricSpace.compactTorusAction_mul, inv_mul_cancel, ToricSpace.compactTorusAction_one]
+  right_inv
+    x := by
+    apply Subtype.ext
+    change
+      ToricSpace.compactTorusAction (baseRotationPhase r)
+          (ToricSpace.compactTorusAction (baseRotationPhase r)⁻¹ (x : ToricSpace.Space)) =
+        (x : ToricSpace.Space)
+    rw [ToricSpace.compactTorusAction_mul, mul_inv_cancel, ToricSpace.compactTorusAction_one]
+  continuous_toFun := baseRotationMap_continuous ρ r
+  continuous_invFun := baseInverseRotationMap_continuous ρ r
+
+private def CuspSpecialization.partialPlanarPhase (r : ℝ) (y : (CuspHoneycombTiling.Plane)) :
+    ToricSpace.CompactFibreTorus := fun i => Circle.exp (2 * Real.pi * r * y i)
+
+private theorem CuspSpecialization.partialPlanarPhase_continuous (r : ℝ) :
+    Continuous (partialPlanarPhase r) := by
+  apply continuous_pi
+  intro i
+  exact Circle.exp.continuous.comp (continuous_const.mul (continuous_apply i))
+
+private def CuspSpecialization.partialPhaseHomeomorph (r : ℝ) :
+    CuspHoneycomb.PhasePlane ≃ₜ CuspHoneycomb.PhasePlane
+    where
+  toFun p := (p.1 * partialPlanarPhase r p.2, p.2)
+  invFun p := (p.1 * (partialPlanarPhase r p.2)⁻¹, p.2)
+  left_inv p := by simp
+  right_inv p := by simp
+  continuous_toFun :=
+    (continuous_fst.mul ((partialPlanarPhase_continuous r).comp continuous_snd)).prodMk
+      continuous_snd
+  continuous_invFun :=
+    (continuous_fst.mul (((partialPlanarPhase_continuous r).comp continuous_snd).inv)).prodMk
+      continuous_snd
+
+private theorem CuspSpecialization.baseRotationPhase_mul_partialPhase (r : ℝ)
+    (p : CuspHoneycomb.PhasePlane) :
+    baseRotationPhase r * ToricSpace.compactFibrePhase (p.1 * partialPlanarPhase r p.2) =
+      compensatingPhase r p := by
+  funext i
+  fin_cases i <;>
+    simp [baseRotationPhase, ToricSpace.compactFibrePhase, partialPlanarPhase, compensatingPhase]
+
+private def
+    CuspSpecialization.complexPhaseHomeomorph (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ) (hρ : 0 < ρ)
+    (ε : ℝ) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (r : ℝ) :
+    CuspHoneycomb.PhasePlane ≃ₜ ToricFibre (rotatedLevel ρ r) :=
+  ((partialPhaseHomeomorph r).trans (frozenPhaseHomeomorph C₀ ρ hρ ε hε1 hρε hR)).trans
+    (baseRotationHomeomorph ρ r)
+
+@[simp]
+private theorem
+    CuspSpecialization.complexPhaseHomeomorph_coe (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ)
+    (hρ : 0 < ρ) (ε : ℝ) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (r : ℝ)
+    (p : CuspHoneycomb.PhasePlane) :
+    (complexPhaseHomeomorph C₀ ρ hρ ε hε1 hρε hR r p : ToricSpace.Space) =
+      ToricSpace.compactTorusAction (compensatingPhase r p)
+        ((normalizedPositivePoint C₀ ρ hρ p.2).1 : ToricSpace.Space) := by
+  change
+    ToricSpace.compactTorusAction (baseRotationPhase r)
+        (frozenPhaseHomeomorph C₀ ρ hρ ε hε1 hρε hR (partialPhaseHomeomorph r p) :
+          ToricSpace.Space) =
+      _
+  rw [frozenPhaseHomeomorph_coe, ToricSpace.compactFibreAction_eq_compact,
+    ToricSpace.compactTorusAction_mul]
+  change
+    ToricSpace.compactTorusAction
+        (baseRotationPhase r * ToricSpace.compactFibrePhase (p.1 * partialPlanarPhase r p.2))
+        ((normalizedPositivePoint C₀ ρ hρ p.2).1 : ToricSpace.Space) =
+      _
+  rw [baseRotationPhase_mul_partialPhase]
+
+private theorem
+    CuspSpecialization.complexPhaseHomeomorph_deck (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ)
+    (hρ : 0 < ρ) (ε : ℝ) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (r : ℝ) (v : Fin 2 → ℤ)
+    (p : CuspHoneycomb.PhasePlane) :
+    (complexPhaseHomeomorph C₀ ρ hρ ε hε1 hρε hR r (CuspHoneycomb.honeycombDeckMap C₀ v p) :
+        ToricSpace.Space) =
+      ToricSpace.twistedTranslate (fun _ => C₀) v
+        (complexPhaseHomeomorph C₀ ρ hρ ε hε1 hρε hR r p : ToricSpace.Space) := by
+  rw [complexPhaseHomeomorph_coe, complexPhaseHomeomorph_coe, compensatingPhase_deck]
+  change
+    ToricSpace.compactTorusAction (CuspPositive.phaseTransform C₀ v (compensatingPhase r p))
+        ((normalizedPositivePoint C₀ ρ hρ
+              (p.2 + CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v))).1 :
+          ToricSpace.Space) =
+      _
+  rw [normalizedPositivePoint_equivariant C₀ ρ hρ ε hε1 hρε hR, positiveFibreTranslate_coe,
+    CuspPositive.twistedTranslate_constant_polar]
+
+private def CuspSpecialization.toricFibrePunctured (η : ℝ) (t : ℂ) (ht : t ≠ 0) (htη : ‖t‖ ≤ η)
+    (x : ToricFibre t) : CuspControlledRetraction.PuncturedClosedTube η :=
+  CuspControlledRetraction.levelToPunctured η t ht (toricFibreLevelHomeomorph η t htη x)
+
+private def CuspSpecialization.positiveFibrePunctured (ρ : ℝ) (hρ : 0 < ρ) (η : ℝ) (hρη : ρ ≤ η)
+    (q : PositiveFibre ρ) : CuspControlledRetraction.PuncturedPositiveTube η :=
+  ⟨⟨q.1, by rw [q.2, Complex.norm_of_nonneg hρ.le]; exact hρη⟩, by
+    rw [q.2]
+    exact Complex.ofReal_ne_zero.mpr hρ.ne'⟩
+
+private def CuspSpecialization.phasePlaneShear (p : CuspHoneycomb.PhasePlane) :
+    CuspHoneycomb.PhasePlane :=
+  (p.1 * planarPhase p.2, p.2)
+
+private theorem CuspSpecialization.phasePlaneShear_continuous : Continuous phasePlaneShear :=
+  (continuous_fst.mul (planarPhase_continuous.comp continuous_snd)).prodMk continuous_snd
+
+private theorem
+    CuspSpecialization.phasePlaneShear_deck (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ)
+    (p : CuspHoneycomb.PhasePlane) :
+    phasePlaneShear (CuspHoneycomb.honeycombDeckMap C₀ v p) =
+      CuspHoneycomb.honeycombDeckMap C₀ v (phasePlaneShear p) := by
+  apply Prod.ext
+  · change
+      (CuspCollapse.deckFibrePhase C₀ v * p.1) *
+          planarPhase (p.2 + CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v)) =
+        CuspCollapse.deckFibrePhase C₀ v * (p.1 * planarPhase p.2)
+    rw [planarPhase_add_latticePoint, mul_assoc]
+  · rfl
+
+private def CuspSpecialization.sourceShear (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    C(SourceModel C₀, SourceModel C₀)
+    where
+  toFun :=
+    Quotient.map phasePlaneShear
+      (by
+        rintro p q ⟨v, hv⟩
+        refine ⟨v, ?_⟩
+        rw [← phasePlaneShear_deck, hv])
+  continuous_toFun :=
+    ((sourceProjection_continuous C₀).comp phasePlaneShear_continuous).quotient_lift _
+
+@[simp]
+private theorem CuspSpecialization.sourceShear_projection (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (p : CuspHoneycomb.PhasePlane) :
+    sourceShear C₀ (sourceProjection C₀ p) = sourceProjection C₀ (phasePlaneShear p) :=
+  rfl
+
+private def CuspSpecialization.rotatingCentralPoint (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (p : CuspHoneycomb.PhasePlane) : CuspRetraction.CentralFibre :=
+  ⟨ToricSpace.compactTorusAction (compensatingPhase r p)
+      ((CuspHoneycomb.honeycombHomeomorph C₀ p.2).1 : ToricSpace.Space),
+    by
+    apply norm_eq_zero.mp
+    rw [ToricSpace.norm_time_compactTorusAction, (CuspHoneycomb.honeycombHomeomorph C₀ p.2).2,
+      norm_zero]⟩
+
+private theorem CuspSpecialization.rotatingCentralPoint_continuous (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    Continuous (fun p : ℝ × CuspHoneycomb.PhasePlane => rotatingCentralPoint C₀ p.1 p.2) := by
+  have hθ :
+    Continuous
+      (fun p : ℝ × CuspHoneycomb.PhasePlane => CuspHoneycomb.honeycombHomeomorph C₀ p.2.2) :=
+    (CuspHoneycomb.honeycombHomeomorph C₀).continuous.comp (continuous_snd.comp continuous_snd)
+  have hθp :
+    Continuous
+      (fun p : ℝ × CuspHoneycomb.PhasePlane => (CuspHoneycomb.honeycombHomeomorph C₀ p.2.2).1) :=
+    continuous_subtype_val.comp hθ
+  have hθx :
+    Continuous
+      (fun p : ℝ × CuspHoneycomb.PhasePlane =>
+        ((CuspHoneycomb.honeycombHomeomorph C₀ p.2.2).1 : ToricSpace.Space)) :=
+    continuous_subtype_val.comp hθp
+  apply Continuous.subtype_mk
+  change
+    Continuous
+      (fun p : ℝ × CuspHoneycomb.PhasePlane =>
+        compensatingPhase p.1 p.2 •
+          ((CuspHoneycomb.honeycombHomeomorph C₀ p.2.2).1 : ToricSpace.Space))
+  exact compensatingPhase_continuous.smul hθx
+
+@[simp]
+private theorem CuspSpecialization.rotatingCentralPoint_zero (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (p : CuspHoneycomb.PhasePlane) :
+    rotatingCentralPoint C₀ 0 p = CuspHoneycomb.honeycombPolarMap C₀ p := by
+  apply Subtype.ext
+  change ToricSpace.compactTorusAction (compensatingPhase 0 p) _ = _
+  rw [compensatingPhase_zero]
+  rfl
+
+@[simp]
+private theorem CuspSpecialization.rotatingCentralPoint_one (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (p : CuspHoneycomb.PhasePlane) :
+    rotatingCentralPoint C₀ 1 p = CuspHoneycomb.honeycombPolarMap C₀ (phasePlaneShear p) := by
+  apply Subtype.ext
+  change ToricSpace.compactTorusAction (compensatingPhase 1 p) _ = _
+  rw [compensatingPhase_one]
+  rfl
+
+private theorem CuspSpecialization.rotatingCentralPoint_deck (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) (r : ℝ) (p : CuspHoneycomb.PhasePlane) :
+    (rotatingCentralPoint (C 0) r (CuspHoneycomb.honeycombDeckMap (C 0) v p) : ToricSpace.Space) =
+      ToricSpace.twistedTranslate C v (rotatingCentralPoint (C 0) r p : ToricSpace.Space) := by
+  rw [CuspCollapse.twistedTranslate_central_eq_constant C v (rotatingCentralPoint (C 0) r p).2]
+  change
+    ToricSpace.compactTorusAction (compensatingPhase r (CuspHoneycomb.honeycombDeckMap (C 0) v p))
+        ((CuspHoneycomb.honeycombHomeomorph (C 0)
+              (p.2 + CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v))).1 :
+          ToricSpace.Space) =
+      ToricSpace.twistedTranslate (fun _ => C 0) v
+        (ToricSpace.compactTorusAction (compensatingPhase r p)
+          ((CuspHoneycomb.honeycombHomeomorph (C 0) p.2).1 : ToricSpace.Space))
+  rw [compensatingPhase_deck, CuspHoneycomb.honeycombHomeomorph_equivariant,
+    CuspCollapse.positiveCentralTranslate_coe, CuspPositive.twistedTranslate_constant_polar]
+
+private theorem CuspSpecialization.toricFibrePunctured_complexPhase (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (r : ℝ) (η : ℝ) (hρη : ρ ≤ η)
+    (p : CuspHoneycomb.PhasePlane) :
+    toricFibrePunctured η (rotatedLevel ρ r) (rotatedLevel_ne_zero ρ r hρ)
+        (rotatedLevel_norm_le ρ r hρ.le η hρη) (complexPhaseHomeomorph C₀ ρ hρ ε hε1 hρε hR r p) =
+      CuspControlledRetraction.puncturedPolarMap η
+        (compensatingPhase r p,
+          positiveFibrePunctured ρ hρ η hρη (normalizedPositivePoint C₀ ρ hρ p.2)) := by
+  apply Subtype.ext
+  apply Subtype.ext
+  exact complexPhaseHomeomorph_coe C₀ ρ hρ ε hε1 hρε hR r p
+
+private theorem
+    CuspSpecialization.prescribedCollapse_complexPhase (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ)
+    (hρ : 0 < ρ) (ε : ℝ) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (r : ℝ) (η : ℝ) (hρη : ρ ≤ η)
+    (p : CuspHoneycomb.PhasePlane) :
+    CuspControlledRetraction.prescribedCollapse C₀ η
+        (toricFibrePunctured η (rotatedLevel ρ r) (rotatedLevel_ne_zero ρ r hρ)
+          (rotatedLevel_norm_le ρ r hρ.le η hρη)
+          (complexPhaseHomeomorph C₀ ρ hρ ε hε1 hρε hR r p)) =
+      rotatingCentralPoint C₀ r p := by
+  apply Subtype.ext
+  rw [toricFibrePunctured_complexPhase C₀ ρ hρ ε hε1 hρε hR r η hρη p,
+    CuspControlledRetraction.prescribedCollapse_polar]
+  change
+    ToricSpace.compactTorusAction (compensatingPhase r p)
+        ((CuspHoneycomb.honeycombHomeomorph C₀
+              (CuspControlledRetraction.normalizedPosition C₀
+                ((normalizedPositivePoint C₀ ρ hρ p.2).1 : ToricSpace.Space))).1 :
+          ToricSpace.Space) =
+      ToricSpace.compactTorusAction (compensatingPhase r p)
+        ((CuspHoneycomb.honeycombHomeomorph C₀ p.2).1 : ToricSpace.Space)
+  have hy := (normalizedPositiveHomeomorph C₀ ρ hρ ε hε1 hρε hR).symm_apply_apply p.2
+  rw [normalizedPositiveHomeomorph_symm_apply, normalizedPositiveHomeomorph_apply] at hy
+  rw [hy]
+
+private def CuspSpecialization.fibreProjection (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (t : ℂ)
+    (htε : ‖t‖ < ε) : ToricFibre t → CuspControlledRetraction.ActualQuotientFibre C ε t :=
+  CuspControlledRetraction.quotientLevelFibreHomeomorph C ε ‖t‖ t le_rfl ∘
+    CuspControlledRetraction.levelProjection C htε t ∘ toricFibreLevelHomeomorph ‖t‖ t le_rfl
+
+@[simp]
+private theorem
+    CuspSpecialization.fibreProjection_coe (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (t : ℂ)
+    (htε : ‖t‖ < ε) (x : ToricFibre t) :
+    (fibreProjection C ε t htε x : CuspQuotient.QuotientSpace C ε) =
+      CuspQuotient.quotientMap C ε
+        ⟨(x : ToricSpace.Space),
+          by
+          change ToricSpace.time (x : ToricSpace.Space) ∈ Metric.ball 0 ε
+          rw [x.2]
+          simpa only [Metric.mem_ball, dist_zero_right] using htε⟩ :=
+  rfl
+
+private theorem
+    CuspSpecialization.fibreProjection_surjective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (t : ℂ) (htε : ‖t‖ < ε) : Function.Surjective (fibreProjection C ε t htε) :=
+  (CuspControlledRetraction.quotientLevelFibreHomeomorph C ε ‖t‖ t le_rfl).surjective.comp
+    ((CuspControlledRetraction.levelProjection_surjective C htε t).comp
+      (toricFibreLevelHomeomorph ‖t‖ t le_rfl).surjective)
+
+private theorem
+    CuspSpecialization.fibreProjection_isOpenQuotientMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (t : ℂ) (htε : ‖t‖ < ε)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε)) :
+    IsOpenQuotientMap (fibreProjection C ε t htε) :=
+  (CuspControlledRetraction.quotientLevelFibreHomeomorph C ε ‖t‖ t le_rfl).isOpenQuotientMap.comp
+    ((CuspControlledRetraction.levelProjection_isOpenQuotientMap C htε t hC).comp
+      (toricFibreLevelHomeomorph ‖t‖ t le_rfl).isOpenQuotientMap)
+
+private theorem CuspSpecialization.fibreProjection_eq_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (t : ℂ) (htε : ‖t‖ < ε) (x y : ToricFibre t) :
+    fibreProjection C ε t htε x = fibreProjection C ε t htε y ↔
+      ∃ v : Fin 2 → ℤ,
+        ToricSpace.twistedTranslate C v (y : ToricSpace.Space) = (x : ToricSpace.Space) := by
+  change
+    CuspControlledRetraction.quotientLevelFibreHomeomorph C ε ‖t‖ t le_rfl
+          (CuspControlledRetraction.levelProjection C htε t
+            (toricFibreLevelHomeomorph ‖t‖ t le_rfl x)) =
+        CuspControlledRetraction.quotientLevelFibreHomeomorph C ε ‖t‖ t le_rfl
+          (CuspControlledRetraction.levelProjection C htε t
+            (toricFibreLevelHomeomorph ‖t‖ t le_rfl y)) ↔
+      _
+  rw [(CuspControlledRetraction.quotientLevelFibreHomeomorph C ε ‖t‖ t le_rfl).injective.eq_iff,
+    CuspControlledRetraction.levelProjection_eq_iff]
+  apply exists_congr
+  intro v
+  exact
+    ⟨fun h => congrArg (fun z : CuspRetraction.ClosedTube ‖t‖ => (z : ToricSpace.Space)) h,
+      fun h => Subtype.ext h⟩
+
+private theorem
+    CuspSpecialization.fibreProjection_eq_levelProjection (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (t : ℂ) (htε : ‖t‖ < ε) (η : ℝ) (hηε : η < ε) (htη : ‖t‖ ≤ η) (x : ToricFibre t) :
+    fibreProjection C ε t htε x =
+      CuspControlledRetraction.quotientLevelFibreHomeomorph C ε η t htη
+        (CuspControlledRetraction.levelProjection C hηε t
+          (toricFibreLevelHomeomorph η t htη x)) :=
+  rfl
+
+private def CuspSpecialization.toricFibreChangeTwist (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (t : ℂ)
+    (x : ToricFibre t) : ToricFibre t :=
+  ⟨CuspRetraction.changeTwist C D x, (CuspRetraction.time_changeTwist C D x).trans x.2⟩
+
+private def CuspSpecialization.toricFibreChangeTwistHomeomorph (C D : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hD : ∀ i j, ContDiffOn ℂ ω (fun z => D z i j) (Metric.ball 0 ε)) (hzero : C 0 = D 0)
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift D ε) (t : ℂ) (htε : ‖t‖ < ε) :
+    ToricFibre t ≃ₜ ToricFibre t
+    where
+  toFun := toricFibreChangeTwist C D t
+  invFun := toricFibreChangeTwist D C t
+  left_inv
+    x :=
+    Subtype.ext
+      (CuspRetraction.changeTwist_inverse_on_disc C D hε1 hRC hRD
+        (by
+          rw [x.2]
+          exact htε))
+  right_inv
+    x :=
+    Subtype.ext
+      (CuspRetraction.changeTwist_inverse_on_disc D C hε1 hRD hRC
+        (by
+          rw [x.2]
+          exact htε))
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    exact
+      (CuspRetraction.changeTwist_continuousOn C D hε hε1 (fun i j => (hC i j).continuousOn)
+            (fun i j => (hD i j).continuousOn) hzero hRC).comp_continuous
+        continuous_subtype_val
+        (fun x => by
+          change ToricSpace.time (x : ToricSpace.Space) ∈ Metric.ball 0 ε
+          rw [x.2]
+          simpa only [Metric.mem_ball, dist_zero_right] using htε)
+  continuous_invFun := by
+    apply Continuous.subtype_mk
+    exact
+      (CuspRetraction.changeTwist_continuousOn D C hε hε1 (fun i j => (hD i j).continuousOn)
+            (fun i j => (hC i j).continuousOn) hzero.symm hRD).comp_continuous
+        continuous_subtype_val
+        (fun x => by
+          change ToricSpace.time (x : ToricSpace.Space) ∈ Metric.ball 0 ε
+          rw [x.2]
+          simpa only [Metric.mem_ball, dist_zero_right] using htε)
+
+private theorem
+    CuspSpecialization.centralRotation_sourceDeck (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (r : ℝ) (v : Fin 2 → ℤ) (p : CuspHoneycomb.PhasePlane) :
+    CuspCollapse.centralProject C ε hε
+        (rotatingCentralPoint (C 0) r (CuspHoneycomb.honeycombDeckMap (C 0) v p)) =
+      CuspCollapse.centralProject C ε hε (rotatingCentralPoint (C 0) r p) := by
+  apply (CuspCollapse.centralProject_eq_iff C ε hε _ _).mpr
+  exact ⟨v, (rotatingCentralPoint_deck C v r p).symm⟩
+
+private def
+    CuspSpecialization.sourceRotation (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (r : ℝ) : C(SourceModel (C 0), CuspRetraction.QuotientCentralFibre C ε)
+    where
+  toFun :=
+    Quotient.lift
+      (fun p : CuspHoneycomb.PhasePlane =>
+        CuspCollapse.centralProject C ε hε (rotatingCentralPoint (C 0) r p))
+      (by
+        rintro p q ⟨v, hv⟩
+        rw [← hv]
+        exact centralRotation_sourceDeck C ε hε r v q)
+  continuous_toFun :=
+    ((CuspCollapse.centralProject_continuous C ε hε).comp
+          ((rotatingCentralPoint_continuous (C 0)).comp
+            (continuous_const.prodMk continuous_id))).quotient_lift
+      _
+
+@[simp]
+private theorem
+    CuspSpecialization.sourceRotation_projection (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (r : ℝ) (p : CuspHoneycomb.PhasePlane) :
+    sourceRotation C ε hε r (sourceProjection (C 0) p) =
+      CuspCollapse.centralProject C ε hε (rotatingCentralPoint (C 0) r p) :=
+  rfl
+
+private theorem
+    CuspSpecialization.sourceRotation_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : Continuous (fun p : ℝ × SourceModel (C 0) => sourceRotation C ε hε p.1 p.2) := by
+  apply (sourceProjection_isQuotientMap (C 0)).continuous_lift_prod_right
+  simpa only [Function.comp_def, sourceRotation_projection] using
+    (CuspCollapse.centralProject_continuous C ε hε).comp (rotatingCentralPoint_continuous (C 0))
+
+@[simp]
+private theorem CuspSpecialization.sourceRotation_zero (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : sourceRotation C ε hε 0 = sourceCollapse C ε hε := by
+  apply ContinuousMap.ext
+  intro q
+  obtain ⟨p, rfl⟩ := sourceProjection_surjective (C 0) q
+  rw [sourceRotation_projection, rotatingCentralPoint_zero]
+  rfl
+
+@[simp]
+private theorem CuspSpecialization.sourceRotation_one (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : sourceRotation C ε hε 1 = (sourceCollapse C ε hε).comp (sourceShear (C 0)) := by
+  apply ContinuousMap.ext
+  intro q
+  obtain ⟨p, rfl⟩ := sourceProjection_surjective (C 0) q
+  rw [sourceRotation_projection, rotatingCentralPoint_one]
+  rfl
+
+private def CuspSpecialization.sourceRotationHomotopy (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (r : ℝ) : (sourceCollapse C ε hε).Homotopy (sourceRotation C ε hε r)
+    where
+  toFun p := sourceRotation C ε hε ((p.1 : ℝ) * r) p.2
+  continuous_toFun := by
+    have hs : Continuous (fun p : unitInterval × SourceModel (C 0) => ((p.1 : ℝ) * r, p.2)) :=
+      ((continuous_subtype_val.comp continuous_fst).mul continuous_const).prodMk continuous_snd
+    simpa only [Function.comp_def] using (sourceRotation_continuous C ε hε).comp hs
+  map_zero_left
+    q := by
+    change sourceRotation C ε hε (0 * r) q = sourceCollapse C ε hε q
+    rw [MulZeroClass.zero_mul, sourceRotation_zero]
+  map_one_left
+    q := by
+    change sourceRotation C ε hε (1 * r) q = sourceRotation C ε hε r q
+    rw [one_mul]
+
+private def
+    CuspSpecialization.varyingComplexPhaseHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ)
+    (hρ : 0 < ρ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) : CuspHoneycomb.PhasePlane ≃ₜ ToricFibre (rotatedLevel ρ r) :=
+  (complexPhaseHomeomorph (C 0) ρ hρ ε hε1 hρε (CuspPositive.smallDrift_positiveTwist (C 0) hRD)
+        r).trans
+    (toricFibreChangeTwistHomeomorph C (CuspRetraction.frozen C) ε hε hε1 hC
+        (fun _ _ => contDiffOn_const) rfl hRC hRD (rotatedLevel ρ r)
+        (rotatedLevel_norm_lt ρ r hρ.le ε hρε)).symm
+
+@[simp]
+private theorem
+    CuspSpecialization.varyingComplexPhaseHomeomorph_coe (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) (p : CuspHoneycomb.PhasePlane) :
+    (varyingComplexPhaseHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r p : ToricSpace.Space) =
+      CuspRetraction.changeTwist (CuspRetraction.frozen C) C
+        (complexPhaseHomeomorph (C 0) ρ hρ ε hε1 hρε
+            (CuspPositive.smallDrift_positiveTwist (C 0) hRD) r p :
+          ToricSpace.Space) :=
+  rfl
+
+private theorem CuspSpecialization.varyingComplexPhaseHomeomorph_straightened
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hρε : ρ < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) (p : CuspHoneycomb.PhasePlane) :
+    CuspRetraction.changeTwist C (CuspRetraction.frozen C)
+        (varyingComplexPhaseHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r p : ToricSpace.Space) =
+      (complexPhaseHomeomorph (C 0) ρ hρ ε hε1 hρε
+          (CuspPositive.smallDrift_positiveTwist (C 0) hRD) r p :
+        ToricSpace.Space) := by
+  rw [varyingComplexPhaseHomeomorph_coe]
+  apply CuspRetraction.changeTwist_inverse_on_disc (CuspRetraction.frozen C) C hε1 hRD hRC
+  rw [(complexPhaseHomeomorph (C 0) ρ hρ ε hε1 hρε
+        (CuspPositive.smallDrift_positiveTwist (C 0) hRD) r p).2]
+  exact rotatedLevel_norm_lt ρ r hρ.le ε hρε
+
+private theorem
+    CuspSpecialization.varyingComplexPhaseHomeomorph_deck (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) (v : Fin 2 → ℤ) (p : CuspHoneycomb.PhasePlane) :
+    (varyingComplexPhaseHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r
+          (CuspHoneycomb.honeycombDeckMap (C 0) v p) :
+        ToricSpace.Space) =
+      ToricSpace.twistedTranslate C v
+        (varyingComplexPhaseHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r p : ToricSpace.Space) := by
+  rw [varyingComplexPhaseHomeomorph_coe, varyingComplexPhaseHomeomorph_coe,
+    complexPhaseHomeomorph_deck]
+  apply CuspRetraction.changeTwist_equivariant_on_disc (CuspRetraction.frozen C) C rfl hε1 hRD
+  rw [(complexPhaseHomeomorph (C 0) ρ hρ ε hε1 hρε
+        (CuspPositive.smallDrift_positiveTwist (C 0) hRD) r p).2]
+  exact rotatedLevel_norm_lt ρ r hρ.le ε hρε
+
+private def CuspSpecialization.varyingComplexFibreMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ)
+    (hρ : 0 < ρ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) :
+    CuspHoneycomb.PhasePlane →
+      CuspControlledRetraction.ActualQuotientFibre C ε (rotatedLevel ρ r) :=
+  fibreProjection C ε (rotatedLevel ρ r) (rotatedLevel_norm_lt ρ r hρ.le ε hρε) ∘
+    varyingComplexPhaseHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r
+
+private theorem CuspSpecialization.varyingComplexFibreMap_isOpenQuotientMap
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hρε : ρ < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) : IsOpenQuotientMap (varyingComplexFibreMap C ρ hρ ε hε hε1 hρε hC hRC hRD r) :=
+  (fibreProjection_isOpenQuotientMap C ε (rotatedLevel ρ r) (rotatedLevel_norm_lt ρ r hρ.le ε hρε)
+        hC).comp
+    (varyingComplexPhaseHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r).isOpenQuotientMap
+
+private theorem
+    CuspSpecialization.varyingComplexFibreMap_isQuotientMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) : Topology.IsQuotientMap (varyingComplexFibreMap C ρ hρ ε hε hε1 hρε hC hRC hRD r) :=
+  (varyingComplexFibreMap_isOpenQuotientMap C ρ hρ ε hε hε1 hρε hC hRC hRD r).isQuotientMap
+
+private theorem CuspSpecialization.varyingComplexFibreMap_eq_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) (p q : CuspHoneycomb.PhasePlane) :
+    varyingComplexFibreMap C ρ hρ ε hε hε1 hρε hC hRC hRD r p =
+        varyingComplexFibreMap C ρ hρ ε hε hε1 hρε hC hRC hRD r q ↔
+      ∃ v : Fin 2 → ℤ, CuspHoneycomb.honeycombDeckMap (C 0) v q = p := by
+  change
+    fibreProjection C ε (rotatedLevel ρ r) _
+          (varyingComplexPhaseHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r p) =
+        fibreProjection C ε (rotatedLevel ρ r) _
+          (varyingComplexPhaseHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r q) ↔
+      _
+  rw [fibreProjection_eq_iff]
+  apply exists_congr
+  intro v
+  rw [← varyingComplexPhaseHomeomorph_deck C ρ hρ ε hε hε1 hρε hC hRC hRD r v q]
+  exact
+    ⟨fun h =>
+      (varyingComplexPhaseHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r).injective (Subtype.ext h),
+      fun h =>
+      congrArg
+        (fun z : CuspHoneycomb.PhasePlane =>
+          (varyingComplexPhaseHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r z : ToricSpace.Space))
+        h⟩
+
+private def
+    CuspSpecialization.varyingComplexSourceHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ)
+    (hρ : 0 < ρ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) :
+    SourceModel (C 0) ≃ₜ CuspControlledRetraction.ActualQuotientFibre C ε (rotatedLevel ρ r) :=
+  CuspHoneycombClosedCover.quotientHomeomorph (sourceProjection (C 0))
+    (varyingComplexFibreMap C ρ hρ ε hε hε1 hρε hC hRC hRD r)
+    (sourceProjection_isQuotientMap (C 0))
+    (varyingComplexFibreMap_isQuotientMap C ρ hρ ε hε hε1 hρε hC hRC hRD r)
+    (fun p q =>
+      (sourceProjection_eq_iff (C 0) p q).trans
+        (varyingComplexFibreMap_eq_iff C ρ hρ ε hε hε1 hρε hC hRC hRD r p q).symm)
+
+@[simp]
+private theorem CuspSpecialization.varyingComplexSourceHomeomorph_projection
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hρε : ρ < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) (p : CuspHoneycomb.PhasePlane) :
+    varyingComplexSourceHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r (sourceProjection (C 0) p) =
+      varyingComplexFibreMap C ρ hρ ε hε hε1 hρε hC hRC hRD r p :=
+  CuspHoneycombClosedCover.quotientHomeomorph_apply _ _ _ _ _ p
+
+private def CuspSpecialization.varyingComplexPhaseLevelHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) (η : ℝ) (hρη : ρ ≤ η) :
+    CuspHoneycomb.PhasePlane ≃ₜ CuspControlledRetraction.ToricLevel η (rotatedLevel ρ r) :=
+  (varyingComplexPhaseHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r).trans
+    (toricFibreLevelHomeomorph η (rotatedLevel ρ r) (rotatedLevel_norm_le ρ r hρ.le η hρη))
+
+private theorem CuspSpecialization.varyingComplexFibreMap_eq_levelProjection
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hρε : ρ < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) (η : ℝ) (hρη : ρ ≤ η) (hηε : η < ε) (p : CuspHoneycomb.PhasePlane) :
+    varyingComplexFibreMap C ρ hρ ε hε hε1 hρε hC hRC hRD r p =
+      CuspControlledRetraction.quotientLevelFibreHomeomorph C ε η (rotatedLevel ρ r)
+        (rotatedLevel_norm_le ρ r hρ.le η hρη)
+        (CuspControlledRetraction.levelProjection C hηε (rotatedLevel ρ r)
+          (varyingComplexPhaseLevelHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r η hρη p)) :=
+  fibreProjection_eq_levelProjection C ε (rotatedLevel ρ r) (rotatedLevel_norm_lt ρ r hρ.le ε hρε)
+    η hηε (rotatedLevel_norm_le ρ r hρ.le η hρη)
+    (varyingComplexPhaseHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r p)
+
+private theorem CuspSpecialization.puncturedStraightening_varyingComplexPhase
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hρε : ρ < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) (η : ℝ) (hρη : ρ ≤ η) (p : CuspHoneycomb.PhasePlane) :
+    CuspControlledRetraction.puncturedStraightening C η
+        (toricFibrePunctured η (rotatedLevel ρ r) (rotatedLevel_ne_zero ρ r hρ)
+          (rotatedLevel_norm_le ρ r hρ.le η hρη)
+          (varyingComplexPhaseHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r p)) =
+      toricFibrePunctured η (rotatedLevel ρ r) (rotatedLevel_ne_zero ρ r hρ)
+        (rotatedLevel_norm_le ρ r hρ.le η hρη)
+        (complexPhaseHomeomorph (C 0) ρ hρ ε hε1 hρε
+          (CuspPositive.smallDrift_positiveTwist (C 0) hRD) r p) := by
+  apply Subtype.ext
+  apply Subtype.ext
+  exact varyingComplexPhaseHomeomorph_straightened C ρ hρ ε hε hε1 hρε hC hRC hRD r p
+
+private theorem CuspSpecialization.prescribedFibreUpstairs_varyingComplexPhaseLevel
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hρε : ρ < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) (η : ℝ) (hρη : ρ ≤ η) (p : CuspHoneycomb.PhasePlane) :
+    CuspControlledRetraction.prescribedFibreUpstairs C ε hε η (rotatedLevel ρ r)
+        (rotatedLevel_ne_zero ρ r hρ)
+        (varyingComplexPhaseLevelHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r η hρη p) =
+      CuspCollapse.centralProject C ε hε (rotatingCentralPoint (C 0) r p) := by
+  change
+    CuspCollapse.centralProject C ε hε
+        (CuspControlledRetraction.prescribedCollapse (C 0) η
+          (CuspControlledRetraction.puncturedStraightening C η
+            (toricFibrePunctured η (rotatedLevel ρ r) (rotatedLevel_ne_zero ρ r hρ)
+              (rotatedLevel_norm_le ρ r hρ.le η hρη)
+              (varyingComplexPhaseHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r p)))) =
+      _
+  rw [puncturedStraightening_varyingComplexPhase C ρ hρ ε hε hε1 hρε hC hRC hRD r η hρη p,
+    prescribedCollapse_complexPhase (C 0) ρ hρ ε hε1 hρε
+      (CuspPositive.smallDrift_positiveTwist (C 0) hRD) r η hρη p]
+
+private theorem CuspSpecialization.prescribedFibreUpstairs_varyingComplex_compatible
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hρε : ρ < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) (η : ℝ) (hρη : ρ ≤ η) (hηε : η < ε)
+    (x y : CuspControlledRetraction.ToricLevel η (rotatedLevel ρ r))
+    (hxy :
+      CuspControlledRetraction.levelProjection C hηε (rotatedLevel ρ r) x =
+        CuspControlledRetraction.levelProjection C hηε (rotatedLevel ρ r) y) :
+    CuspControlledRetraction.prescribedFibreUpstairs C ε hε η (rotatedLevel ρ r)
+        (rotatedLevel_ne_zero ρ r hρ) x =
+      CuspControlledRetraction.prescribedFibreUpstairs C ε hε η (rotatedLevel ρ r)
+        (rotatedLevel_ne_zero ρ r hρ) y := by
+  obtain ⟨p, rfl⟩ :=
+    (varyingComplexPhaseLevelHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r η hρη).surjective x
+  obtain ⟨q, rfl⟩ :=
+    (varyingComplexPhaseLevelHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r η hρη).surjective y
+  have hf :
+    varyingComplexFibreMap C ρ hρ ε hε hε1 hρε hC hRC hRD r p =
+      varyingComplexFibreMap C ρ hρ ε hε hε1 hρε hC hRC hRD r q := by
+    rw [varyingComplexFibreMap_eq_levelProjection C ρ hρ ε hε hε1 hρε hC hRC hRD r η hρη hηε p,
+      varyingComplexFibreMap_eq_levelProjection C ρ hρ ε hε hε1 hρε hC hRC hRD r η hρη hηε q, hxy]
+  obtain ⟨v, hv⟩ := (varyingComplexFibreMap_eq_iff C ρ hρ ε hε hε1 hρε hC hRC hRD r p q).mp hf
+  rw [prescribedFibreUpstairs_varyingComplexPhaseLevel,
+    prescribedFibreUpstairs_varyingComplexPhaseLevel, ← hv, centralRotation_sourceDeck]
+
+private theorem CuspSpecialization.prescribedActualFibreCollapse_varyingComplexFibreMap
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hρε : ρ < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) (η : ℝ) (hρη : ρ ≤ η) (hηε : η < ε) (p : CuspHoneycomb.PhasePlane) :
+    CuspControlledRetraction.prescribedActualFibreCollapse C ε hε hηε (rotatedLevel ρ r)
+        (rotatedLevel_ne_zero ρ r hρ) (rotatedLevel_norm_le ρ r hρ.le η hρη)
+        (varyingComplexFibreMap C ρ hρ ε hε hε1 hρε hC hRC hRD r p) =
+      CuspCollapse.centralProject C ε hε (rotatingCentralPoint (C 0) r p) := by
+  rw [CuspControlledRetraction.prescribedActualFibreCollapse, Function.comp_apply,
+    varyingComplexFibreMap_eq_levelProjection C ρ hρ ε hε hε1 hρε hC hRC hRD r η hρη hηε p,
+    Homeomorph.symm_apply_apply]
+  change
+    CuspControlledRetraction.levelDescend C hηε (rotatedLevel ρ r)
+        (CuspControlledRetraction.prescribedFibreUpstairs C ε hε η (rotatedLevel ρ r)
+          (rotatedLevel_ne_zero ρ r hρ))
+        (CuspControlledRetraction.levelProjection C hηε (rotatedLevel ρ r)
+          (varyingComplexPhaseLevelHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r η hρη p)) =
+      _
+  rw [CuspControlledRetraction.levelDescend_levelProjection C hηε (rotatedLevel ρ r) _
+      (prescribedFibreUpstairs_varyingComplex_compatible C ρ hρ ε hε hε1 hρε hC hRC hRD r η hρη
+        hηε)]
+  exact prescribedFibreUpstairs_varyingComplexPhaseLevel C ρ hρ ε hε hε1 hρε hC hRC hRD r η hρη p
+
+private theorem CuspSpecialization.prescribedActualFibreCollapse_varyingComplexSourceHomeomorph
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hρε : ρ < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) (η : ℝ) (hρη : ρ ≤ η) (hηε : η < ε) (q : SourceModel (C 0)) :
+    CuspControlledRetraction.prescribedActualFibreCollapse C ε hε hηε (rotatedLevel ρ r)
+        (rotatedLevel_ne_zero ρ r hρ) (rotatedLevel_norm_le ρ r hρ.le η hρη)
+        (varyingComplexSourceHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r q) =
+      sourceRotation C ε hε r q := by
+  obtain ⟨p, rfl⟩ := sourceProjection_surjective (C 0) q
+  rw [varyingComplexSourceHomeomorph_projection, sourceRotation_projection]
+  exact
+    prescribedActualFibreCollapse_varyingComplexFibreMap C ρ hρ ε hε hε1 hρε hC hRC hRD r η hρη
+      hηε p
+
+private theorem CuspSpecialization.prescribedActualFibreCollapse_varyingComplex_continuous
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ) (hρ : 0 < ρ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hρε : ρ < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) (η : ℝ) (hρη : ρ ≤ η) (hηε : η < ε) :
+    Continuous
+      (CuspControlledRetraction.prescribedActualFibreCollapse C ε hε hηε (rotatedLevel ρ r)
+        (rotatedLevel_ne_zero ρ r hρ) (rotatedLevel_norm_le ρ r hρ.le η hρη)) := by
+  apply
+    (varyingComplexSourceHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD
+          r).isQuotientMap |>.continuous_iff.mpr
+  have he :
+    CuspControlledRetraction.prescribedActualFibreCollapse C ε hε hηε (rotatedLevel ρ r)
+          (rotatedLevel_ne_zero ρ r hρ) (rotatedLevel_norm_le ρ r hρ.le η hρη) ∘
+        varyingComplexSourceHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r =
+      sourceRotation C ε hε r :=
+    funext
+      (prescribedActualFibreCollapse_varyingComplexSourceHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD
+        r η hρη hηε)
+  rw [he]
+  exact (sourceRotation C ε hε r).continuous
+
+private def CuspSpecialization.varyingComplexCollapseMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ρ : ℝ)
+    (hρ : 0 < ρ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) (η : ℝ) (hρη : ρ ≤ η) (hηε : η < ε) :
+    C(CuspControlledRetraction.ActualQuotientFibre C ε (rotatedLevel ρ r),
+      CuspRetraction.QuotientCentralFibre C ε)
+    where
+  toFun :=
+    CuspControlledRetraction.prescribedActualFibreCollapse C ε hε hηε (rotatedLevel ρ r)
+      (rotatedLevel_ne_zero ρ r hρ) (rotatedLevel_norm_le ρ r hρ.le η hρη)
+  continuous_toFun :=
+    prescribedActualFibreCollapse_varyingComplex_continuous C ρ hρ ε hε hε1 hρε hC hRC hRD r η hρη
+      hηε
+
+private def CuspSpecialization.sourcePhaseArgument (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (y : (CuspHoneycombTiling.Plane)) : (CuspHoneycombTiling.Plane) :=
+  (fun i j => (C₀ i j).re) *ᵥ (-ToricSpace.realCuspVector y)
+
+private theorem CuspSpecialization.sourcePhaseArgument_add (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (y z : (CuspHoneycombTiling.Plane)) :
+    sourcePhaseArgument C₀ (y + z) = sourcePhaseArgument C₀ y + sourcePhaseArgument C₀ z := by
+  funext i
+  simp [sourcePhaseArgument, Matrix.mulVec, dotProduct, Fin.sum_univ_two,
+    ToricSpace.realCuspVector, mul_add, add_comm, add_left_comm, add_assoc]
+
+@[simp]
+private theorem CuspSpecialization.sourcePhaseArgument_zero (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    sourcePhaseArgument C₀ 0 = 0 := by
+  funext i
+  simp [sourcePhaseArgument, Matrix.mulVec, dotProduct, Fin.sum_univ_two,
+    ToricSpace.realCuspVector]
+
+private theorem CuspSpecialization.sourcePhaseArgument_continuous (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    Continuous (sourcePhaseArgument C₀) := by
+  unfold sourcePhaseArgument
+  simp only [ToricSpace.realCuspVector]
+  fun_prop
+
+private theorem
+    CuspSpecialization.sourcePhaseArgument_lattice_cuspVector (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) (i : Fin 2) :
+    sourcePhaseArgument C₀ (CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v)) i =
+      ((C₀ *ᵥ (fun j => (v j : ℂ))) i).re := by
+  simp [sourcePhaseArgument, Matrix.mulVec, dotProduct, Fin.sum_univ_two,
+    ToricSpace.realCuspVector, CuspHoneycombTiling.latticePoint, ToricSpace.cuspVector,
+    Complex.mul_re, add_comm]
+
+private def CuspSpecialization.sourcePhaseCharacter (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (y : (CuspHoneycombTiling.Plane)) : ToricSpace.CompactFibreTorus := fun i =>
+  Circle.exp (2 * Real.pi * sourcePhaseArgument C₀ y i)
+
+private theorem CuspSpecialization.sourcePhaseCharacter_continuous (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    Continuous (sourcePhaseCharacter C₀) := by
+  apply continuous_pi
+  intro i
+  exact
+    Circle.exp.continuous.comp
+      (continuous_const.mul ((continuous_apply i).comp (sourcePhaseArgument_continuous C₀)))
+
+@[simp]
+private theorem CuspSpecialization.sourcePhaseCharacter_zero (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    sourcePhaseCharacter C₀ 0 = 1 := by
+  funext i
+  simp [sourcePhaseCharacter]
+
+private theorem CuspSpecialization.sourcePhaseCharacter_add (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (y z : (CuspHoneycombTiling.Plane)) :
+    sourcePhaseCharacter C₀ (y + z) = sourcePhaseCharacter C₀ y * sourcePhaseCharacter C₀ z := by
+  funext i
+  simp only [sourcePhaseCharacter, sourcePhaseArgument_add, Pi.add_apply, mul_add, Circle.exp_add,
+    Pi.mul_apply]
+
+@[simp]
+private theorem
+    CuspSpecialization.sourcePhaseCharacter_lattice_cuspVector (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) :
+    sourcePhaseCharacter C₀ (CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v)) =
+      CuspCollapse.deckFibrePhase C₀ v := by
+  funext i
+  rw [sourcePhaseCharacter, sourcePhaseArgument_lattice_cuspVector, CuspCollapse.deckFibrePhase,
+    CuspPositive.frozenPhaseCoordinate_eq_exp]
+
+private theorem CuspSpecialization.sourcePhaseCharacter_deck (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) (y : (CuspHoneycombTiling.Plane)) :
+    sourcePhaseCharacter C₀ (y + CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v)) =
+      CuspCollapse.deckFibrePhase C₀ v * sourcePhaseCharacter C₀ y := by
+  rw [sourcePhaseCharacter_add, sourcePhaseCharacter_lattice_cuspVector, mul_comm]
+
+private def CuspSpecialization.sourcePhaseShear (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    CuspHoneycomb.PhasePlane ≃ₜ CuspHoneycomb.PhasePlane
+    where
+  toFun p := (p.1 * (sourcePhaseCharacter C₀ p.2)⁻¹, p.2)
+  invFun p := (p.1 * sourcePhaseCharacter C₀ p.2, p.2)
+  left_inv p := by simp only [mul_assoc, inv_mul_cancel, mul_one, Prod.eta]
+  right_inv p := by simp only [mul_inv_cancel_right, Prod.eta]
+  continuous_toFun :=
+    (continuous_fst.mul ((sourcePhaseCharacter_continuous C₀).comp continuous_snd).inv).prodMk
+      continuous_snd
+  continuous_invFun :=
+    (continuous_fst.mul ((sourcePhaseCharacter_continuous C₀).comp continuous_snd)).prodMk
+      continuous_snd
+
+@[simp]
+private theorem CuspSpecialization.sourcePhaseShear_apply (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (p : CuspHoneycomb.PhasePlane) :
+    sourcePhaseShear C₀ p = (p.1 * (sourcePhaseCharacter C₀ p.2)⁻¹, p.2) :=
+  rfl
+
+private theorem
+    CuspSpecialization.sourcePhaseShear_deck (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ)
+    (p : CuspHoneycomb.PhasePlane) :
+    sourcePhaseShear C₀ (CuspHoneycomb.honeycombDeckMap C₀ v p) =
+      ((sourcePhaseShear C₀ p).1,
+        p.2 + CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v)) := by
+  simp only [sourcePhaseShear_apply, CuspHoneycomb.honeycombDeckMap, sourcePhaseCharacter_deck]
+  apply Prod.ext
+  · simp only [mul_inv_rev]
+    calc
+      (CuspCollapse.deckFibrePhase C₀ v * p.1) *
+            ((sourcePhaseCharacter C₀ p.2)⁻¹ * (CuspCollapse.deckFibrePhase C₀ v)⁻¹) =
+          (CuspCollapse.deckFibrePhase C₀ v * (CuspCollapse.deckFibrePhase C₀ v)⁻¹) *
+            (p.1 * (sourcePhaseCharacter C₀ p.2)⁻¹) := by ac_rfl
+      _ = p.1 * (sourcePhaseCharacter C₀ p.2)⁻¹ := by rw [mul_inv_cancel, one_mul]
+  · rfl
+
+private def CuspSpecialization.sourceBaseMarking :
+    (CuspHoneycombTiling.Plane) ≃ₜ (CuspHoneycombTiling.Plane)
+    where
+  toFun y := -ToricSpace.realCuspVector y
+  invFun y := ToricSpace.realCuspVector y
+  left_inv
+    y := by
+    funext i
+    fin_cases i <;> simp [ToricSpace.realCuspVector]
+  right_inv
+    y := by
+    funext i
+    fin_cases i <;> simp [ToricSpace.realCuspVector]
+  continuous_toFun := by simp only [ToricSpace.realCuspVector]; fun_prop
+  continuous_invFun := by simp only [ToricSpace.realCuspVector]; fun_prop
+
+@[simp]
+private theorem CuspSpecialization.sourceBaseMarking_apply (y : (CuspHoneycombTiling.Plane)) :
+    sourceBaseMarking y = -ToricSpace.realCuspVector y :=
+  rfl
+
+private theorem CuspSpecialization.sourceBaseMarking_add (y z : (CuspHoneycombTiling.Plane)) :
+    sourceBaseMarking (y + z) = sourceBaseMarking y + sourceBaseMarking z := by
+  simp only [sourceBaseMarking_apply, map_add, neg_add]
+
+private theorem CuspSpecialization.sourceBaseMarking_lattice_cuspVector (v : Fin 2 → ℤ) :
+    sourceBaseMarking (CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v)) =
+      CuspHoneycombTiling.latticePoint v := by
+  funext i
+  fin_cases i <;>
+    simp [sourceBaseMarking_apply, ToricSpace.realCuspVector, CuspHoneycombTiling.latticePoint,
+      ToricSpace.cuspVector]
+
+private theorem CuspSpecialization.sourceBaseMarking_deck (v : Fin 2 → ℤ)
+    (y : (CuspHoneycombTiling.Plane)) :
+    sourceBaseMarking (y + CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v)) =
+      sourceBaseMarking y + CuspHoneycombTiling.latticePoint v := by
+  rw [sourceBaseMarking_add, sourceBaseMarking_lattice_cuspVector]
+
+private def CuspSpecialization.sourceMarkedShear (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    CuspHoneycomb.PhasePlane ≃ₜ CuspHoneycomb.PhasePlane :=
+  (sourcePhaseShear C₀).trans
+    ((Homeomorph.refl ToricSpace.CompactFibreTorus).prodCongr sourceBaseMarking)
+
+private theorem
+    CuspSpecialization.sourceMarkedShear_deck (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ)
+    (p : CuspHoneycomb.PhasePlane) :
+    sourceMarkedShear C₀ (CuspHoneycomb.honeycombDeckMap C₀ v p) =
+      ((sourceMarkedShear C₀ p).1,
+        (sourceMarkedShear C₀ p).2 + CuspHoneycombTiling.latticePoint v) := by
+  change
+    ((sourcePhaseShear C₀ (CuspHoneycomb.honeycombDeckMap C₀ v p)).1,
+        sourceBaseMarking (CuspHoneycomb.honeycombDeckMap C₀ v p).2) =
+      _
+  rw [sourcePhaseShear_deck]
+  change
+    ((sourceMarkedShear C₀ p).1,
+        sourceBaseMarking (p.2 + CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v))) =
+      _
+  rw [sourceBaseMarking_deck]
+  rfl
+
+public
+theorem CuspSpecialization.sourceCoordinateProjection_isOpenQuotientMap :
+    IsOpenQuotientMap (PeriodTorusHigherHomology.coordinateProjection 2) := by
+  exact
+    IsOpenQuotientMap.piMap
+      (fun _ : Fin 2 =>
+        (QuotientAddGroup.isOpenQuotientMap_mk : IsOpenQuotientMap ((↑) : ℝ → AddCircle (1 : ℝ))))
+
+private theorem
+    CuspSpecialization.sourceCoordinateProjection_eq_iff (y z : (CuspHoneycombTiling.Plane)) :
+    PeriodTorusHigherHomology.coordinateProjection 2 y =
+        PeriodTorusHigherHomology.coordinateProjection 2 z ↔
+      ∃ v : Fin 2 → ℤ, y = z + CuspHoneycombTiling.latticePoint v := by
+  constructor
+  · intro h
+    have hz : PeriodTorusHigherHomology.coordinateProjection 2 (y - z) = 0 := by
+      rw [map_sub, h, sub_self]
+    obtain ⟨v, hv⟩ := (PeriodTorusHigherHomology.coordinateProjection_eq_zero_iff 2 _).mp hz
+    refine ⟨v, ?_⟩
+    change y - z = CuspHoneycombTiling.latticePoint v at hv
+    calc
+      y = (y - z) + z := (sub_add_cancel y z).symm
+      _ = z + CuspHoneycombTiling.latticePoint v := by rw [hv, add_comm]
+  · rintro ⟨v, rfl⟩
+    have hz :
+      PeriodTorusHigherHomology.coordinateProjection 2 (CuspHoneycombTiling.latticePoint v) = 0 :=
+      (PeriodTorusHigherHomology.coordinateProjection_eq_zero_iff 2
+            (CuspHoneycombTiling.latticePoint v)).mpr
+        ⟨v, rfl⟩
+    rw [map_add, hz, add_zero]
+
+private def CuspSpecialization.sourceProductCoordinates (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    CuspHoneycomb.PhasePlane →
+      ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2 :=
+  Prod.map id (PeriodTorusHigherHomology.coordinateProjection 2) ∘ sourceMarkedShear C₀
+
+private theorem CuspSpecialization.sourceProductCoordinates_isOpenQuotientMap
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) : IsOpenQuotientMap (sourceProductCoordinates C₀) :=
+  (IsOpenQuotientMap.id.prodMap sourceCoordinateProjection_isOpenQuotientMap).comp
+    (sourceMarkedShear C₀).isOpenQuotientMap
+
+private theorem
+    CuspSpecialization.sourceProductCoordinates_surjective (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    Function.Surjective (sourceProductCoordinates C₀) :=
+  (sourceProductCoordinates_isOpenQuotientMap C₀).surjective
+
+private theorem CuspSpecialization.sourceProductCoordinates_deck (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) (p : CuspHoneycomb.PhasePlane) :
+    sourceProductCoordinates C₀ (CuspHoneycomb.honeycombDeckMap C₀ v p) =
+      sourceProductCoordinates C₀ p := by
+  change
+    Prod.map id (PeriodTorusHigherHomology.coordinateProjection 2)
+        (sourceMarkedShear C₀ (CuspHoneycomb.honeycombDeckMap C₀ v p)) =
+      _
+  rw [sourceMarkedShear_deck]
+  apply Prod.ext
+  · rfl
+  · change
+      PeriodTorusHigherHomology.coordinateProjection 2
+          ((sourceMarkedShear C₀ p).2 + CuspHoneycombTiling.latticePoint v) =
+        PeriodTorusHigherHomology.coordinateProjection 2 (sourceMarkedShear C₀ p).2
+    exact (sourceCoordinateProjection_eq_iff _ _).mpr ⟨v, rfl⟩
+
+private theorem CuspSpecialization.sourceProductCoordinates_eq_iff (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (p q : CuspHoneycomb.PhasePlane) :
+    sourceProductCoordinates C₀ p = sourceProductCoordinates C₀ q ↔
+      ∃ v : Fin 2 → ℤ, CuspHoneycomb.honeycombDeckMap C₀ v q = p := by
+  constructor
+  · intro h
+    have hphase : (sourceMarkedShear C₀ p).1 = (sourceMarkedShear C₀ q).1 :=
+      congrArg
+        (fun x : ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2 => x.1) h
+    have hbase :
+      PeriodTorusHigherHomology.coordinateProjection 2 (sourceMarkedShear C₀ p).2 =
+        PeriodTorusHigherHomology.coordinateProjection 2 (sourceMarkedShear C₀ q).2 :=
+      congrArg
+        (fun x : ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2 => x.2) h
+    obtain ⟨v, hv⟩ := (sourceCoordinateProjection_eq_iff _ _).mp hbase
+    refine ⟨v, (sourceMarkedShear C₀).injective ?_⟩
+    rw [sourceMarkedShear_deck]
+    apply Prod.ext
+    · exact hphase.symm
+    · exact hv.symm
+  · rintro ⟨v, hv⟩
+    rw [← hv, sourceProductCoordinates_deck]
+
+private def CuspSpecialization.sourceProductMap (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    SourceModel C₀ → ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2 :=
+  Quotient.lift (sourceProductCoordinates C₀)
+    (by
+      rintro p q ⟨v, hv⟩
+      rw [← hv]
+      exact sourceProductCoordinates_deck C₀ v q)
+
+private theorem CuspSpecialization.sourceProductMap_injective (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    Function.Injective (sourceProductMap C₀) := by
+  intro x y h
+  obtain ⟨p, rfl⟩ := sourceProjection_surjective C₀ x
+  obtain ⟨q, rfl⟩ := sourceProjection_surjective C₀ y
+  exact (sourceProjection_eq_iff C₀ p q).mpr ((sourceProductCoordinates_eq_iff C₀ p q).mp h)
+
+private theorem CuspSpecialization.sourceProductMap_surjective (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    Function.Surjective (sourceProductMap C₀) := by
+  intro x
+  obtain ⟨p, hp⟩ := sourceProductCoordinates_surjective C₀ x
+  exact ⟨sourceProjection C₀ p, hp⟩
+
+private theorem CuspSpecialization.sourceProductMap_isQuotientMap (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    Topology.IsQuotientMap (sourceProductMap C₀) :=
+  (sourceProjection_isQuotientMap C₀).of_comp_isQuotientMap
+    (sourceProductCoordinates_isOpenQuotientMap C₀).isQuotientMap
+
+private def CuspSpecialization.sourceProductHomeomorph (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    SourceModel C₀ ≃ₜ ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2 :=
+  (Equiv.ofBijective (sourceProductMap C₀)
+        ⟨sourceProductMap_injective C₀, sourceProductMap_surjective C₀⟩).toHomeomorph
+    (fun _ => (sourceProductMap_isQuotientMap C₀).isOpen_preimage)
+
+@[simp]
+private theorem
+    CuspSpecialization.sourceProductHomeomorph_projection (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (p : CuspHoneycomb.PhasePlane) :
+    sourceProductHomeomorph C₀ (sourceProjection C₀ p) =
+      (p.1 * (sourcePhaseCharacter C₀ p.2)⁻¹,
+        PeriodTorusHigherHomology.coordinateProjection 2 (-ToricSpace.realCuspVector p.2)) :=
+  rfl
+
+private theorem CuspSpecialization.sourceProductHomeomorph_symm_coordinateProjection
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (u : ToricSpace.CompactFibreTorus)
+    (y : (CuspHoneycombTiling.Plane)) :
+    (sourceProductHomeomorph C₀).symm (u, PeriodTorusHigherHomology.coordinateProjection 2 y) =
+      sourceProjection C₀
+        (u * sourcePhaseCharacter C₀ (ToricSpace.realCuspVector y),
+          ToricSpace.realCuspVector y) := by
+  apply (sourceProductHomeomorph C₀).injective
+  rw [Homeomorph.apply_symm_apply]
+  change
+    (u, PeriodTorusHigherHomology.coordinateProjection 2 y) =
+      sourceProductCoordinates C₀ ((sourceMarkedShear C₀).symm (u, y))
+  unfold sourceProductCoordinates
+  rw [Function.comp_apply, Homeomorph.apply_symm_apply]
+  rfl
+
+private def
+    CuspSpecialization.productCollapse (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    C(ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2,
+      CuspRetraction.QuotientCentralFibre C ε) :=
+  (sourceCollapse C ε hε).comp
+    ((sourceProductHomeomorph (C 0)).symm :
+      C(ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2,
+        SourceModel (C 0)))
+
+private theorem
+    CuspSpecialization.productCollapse_coordinateProjection (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (u : ToricSpace.CompactFibreTorus) (y : (CuspHoneycombTiling.Plane)) :
+    productCollapse C ε hε (u, PeriodTorusHigherHomology.coordinateProjection 2 y) =
+      CuspHoneycomb.honeycombCollapseMap C ε hε
+        (u * sourcePhaseCharacter (C 0) (ToricSpace.realCuspVector y),
+          ToricSpace.realCuspVector y) := by
+  change
+    sourceCollapse C ε hε
+        ((sourceProductHomeomorph (C 0)).symm
+          (u, PeriodTorusHigherHomology.coordinateProjection 2 y)) =
+      _
+  rw [sourceProductHomeomorph_symm_coordinateProjection, sourceCollapse_projection]
+
+private def
+    CuspSpecialization.productRotation (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (r : ℝ) :
+    C(ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2,
+      CuspRetraction.QuotientCentralFibre C ε) :=
+  (sourceRotation C ε hε r).comp
+    ((sourceProductHomeomorph (C 0)).symm :
+      C(ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2,
+        SourceModel (C 0)))
+
+private def CuspSpecialization.productRotationHomotopy (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (r : ℝ) : (productCollapse C ε hε).Homotopy (productRotation C ε hε r) :=
+  (sourceRotationHomotopy C ε hε r).compContinuousMap
+    ((sourceProductHomeomorph (C 0)).symm :
+      C(ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2,
+        SourceModel (C 0)))
+
+private theorem
+    CuspSpecialization.productRotation_homologyMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (r : ℝ) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (productRotation C ε hε r) n =
+      SingularMayerVietoris.singularHomologyMap (productCollapse C ε hε) n :=
+  (PeriodTorusHigherHomology.homotopy_homologyMap (productRotationHomotopy C ε hε r) n).symm
+
+private def
+    CuspSpecialization.varyingComplexProductFibreHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (ρ : ℝ) (hρ : 0 < ρ) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) :
+    (ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2) ≃ₜ
+      CuspControlledRetraction.ActualQuotientFibre C ε (rotatedLevel ρ r) :=
+  (sourceProductHomeomorph (C 0)).symm.trans
+    (varyingComplexSourceHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r)
+
+private theorem
+    CuspSpecialization.prescribedActualFibreCollapse_varyingComplexProductFibreHomeomorph
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (ρ : ℝ) (hρ : 0 < ρ) (hε1 : ε < 1)
+    (hρε : ρ < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) (η : ℝ) (hρη : ρ ≤ η) (hηε : η < ε)
+    (p : ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2) :
+    CuspControlledRetraction.prescribedActualFibreCollapse C ε hε hηε (rotatedLevel ρ r)
+        (rotatedLevel_ne_zero ρ r hρ) (rotatedLevel_norm_le ρ r hρ.le η hρη)
+        (varyingComplexProductFibreHomeomorph C ε hε ρ hρ hε1 hρε hC hRC hRD r p) =
+      productRotation C ε hε r p :=
+  prescribedActualFibreCollapse_varyingComplexSourceHomeomorph C ρ hρ ε hε hε1 hρε hC hRC hRD r η
+    hρη hηε ((sourceProductHomeomorph (C 0)).symm p)
+
+private theorem CuspSpecialization.varyingComplexCollapseMap_comp_product
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (ρ : ℝ) (hρ : 0 < ρ) (hε1 : ε < 1)
+    (hρε : ρ < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) (η : ℝ) (hρη : ρ ≤ η) (hηε : η < ε) :
+    (varyingComplexCollapseMap C ρ hρ ε hε hε1 hρε hC hRC hRD r η hρη hηε).comp
+        (varyingComplexProductFibreHomeomorph C ε hε ρ hρ hε1 hρε hC hRC hRD r :
+          C(ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2,
+            CuspControlledRetraction.ActualQuotientFibre C ε (rotatedLevel ρ r))) =
+      productRotation C ε hε r :=
+  ContinuousMap.ext
+    (prescribedActualFibreCollapse_varyingComplexProductFibreHomeomorph C ε hε ρ hρ hε1 hρε hC hRC
+      hRD r η hρη hηε)
+
+private def
+    CuspSpecialization.varyingComplexProductCollapseHomotopy (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (ρ : ℝ) (hρ : 0 < ρ) (hε1 : ε < 1) (hρε : ρ < ε)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) (η : ℝ) (hρη : ρ ≤ η) (hηε : η < ε) :
+    (productCollapse C ε hε).Homotopy
+      ((varyingComplexCollapseMap C ρ hρ ε hε hε1 hρε hC hRC hRD r η hρη hηε).comp
+        (varyingComplexProductFibreHomeomorph C ε hε ρ hρ hε1 hρε hC hRC hRD r :
+          C(ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2,
+            CuspControlledRetraction.ActualQuotientFibre C ε (rotatedLevel ρ r)))) := by
+  rw [varyingComplexCollapseMap_comp_product]
+  exact productRotationHomotopy C ε hε r
+
+private theorem CuspSpecialization.varyingComplexProductCollapseMap_homology
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (ρ : ℝ) (hρ : 0 < ρ) (hε1 : ε < 1)
+    (hρε : ρ < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (r : ℝ) (η : ℝ) (hρη : ρ ≤ η) (hηε : η < ε) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2) n) :
+    SingularMayerVietoris.singularHomologyMap
+        (varyingComplexCollapseMap C ρ hρ ε hε hε1 hρε hC hRC hRD r η hρη hηε) n
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+          (varyingComplexProductFibreHomeomorph C ε hε ρ hρ hε1 hρε hC hRC hRD r) n a) =
+      SingularMayerVietoris.singularHomologyMap (productCollapse C ε hε) n a := by
+  change
+    (SingularMayerVietoris.singularHomologyMap
+            (varyingComplexCollapseMap C ρ hρ ε hε hε1 hρε hC hRC hRD r η hρη hηε) n).comp
+        (SingularMayerVietoris.singularHomologyMap
+          (varyingComplexProductFibreHomeomorph C ε hε ρ hρ hε1 hρε hC hRC hRD r :
+            C(ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2,
+              CuspControlledRetraction.ActualQuotientFibre C ε (rotatedLevel ρ r)))
+          n)
+        a =
+      _
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    varyingComplexCollapseMap_comp_product, productRotation_homologyMap]
+
+private def CuspSpecialization.argumentTurns (t : ℂ) : ℝ :=
+  t.arg / (2 * Real.pi)
+
+private theorem CuspSpecialization.rotatedLevel_norm_argumentTurns (t : ℂ) :
+    rotatedLevel ‖t‖ (argumentTurns t) = t := by
+  have hπ : (2 : ℝ) * Real.pi ≠ 0 := mul_ne_zero (by norm_num) Real.pi_ne_zero
+  have he : 2 * Real.pi * (t.arg / (2 * Real.pi)) = t.arg := mul_div_cancel₀ t.arg hπ
+  rw [rotatedLevel, argumentTurns, he, Circle.coe_exp, mul_comm]
+  exact Complex.norm_mul_exp_arg_mul_I t
+
+private def CuspSpecialization.IsPrescribedProductModel (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (t : ℂ) (ht : t ≠ 0)
+    (e :
+      (ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2) ≃ₜ
+        CuspControlledRetraction.ActualQuotientFibre C ε t) :
+    Prop :=
+  ∀ (η : ℝ) (htη : ‖t‖ ≤ η) (hηε : η < ε),
+    ∃ hc :
+      Continuous (CuspControlledRetraction.prescribedActualFibreCollapse C ε hε hηε t ht htη),
+      (productCollapse C ε hε).Homotopic
+          ((⟨CuspControlledRetraction.prescribedActualFibreCollapse C ε hε hηε t ht htη, hc⟩ :
+                C(CuspControlledRetraction.ActualQuotientFibre C ε t,
+                  CuspRetraction.QuotientCentralFibre C ε)).comp
+            (e :
+              C(ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2,
+                CuspControlledRetraction.ActualQuotientFibre C ε t))) ∧
+        ∀ (n : ℕ)
+          (a :
+            SingularMayerVietoris.SingularHomology
+              (ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2) n),
+          SingularMayerVietoris.singularHomologyMap
+              (⟨CuspControlledRetraction.prescribedActualFibreCollapse C ε hε hηε t ht htη, hc⟩ :
+                C(CuspControlledRetraction.ActualQuotientFibre C ε t,
+                  CuspRetraction.QuotientCentralFibre C ε))
+              n (PeriodTorusHigherHomology.homeomorphHomologyEquiv e n a) =
+            SingularMayerVietoris.singularHomologyMap (productCollapse C ε hε) n a
+
+private theorem CuspSpecialization.varyingComplexProductFibreHomeomorph_isPrescribedProductModel
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (ρ : ℝ) (hρ : 0 < ρ) (hρε : ρ < ε) (r : ℝ) :
+    IsPrescribedProductModel C ε hε (rotatedLevel ρ r) (rotatedLevel_ne_zero ρ r hρ)
+      (varyingComplexProductFibreHomeomorph C ε hε ρ hρ hε1 hρε hC hRC hRD r) := by
+  intro η htη hηε
+  have hρη : ρ ≤ η := by rwa [norm_rotatedLevel ρ r hρ.le] at htη
+  refine
+    ⟨prescribedActualFibreCollapse_varyingComplex_continuous C ρ hρ ε hε hε1 hρε hC hRC hRD r η
+        hρη hηε,
+      ?_, ?_⟩
+  · exact ⟨varyingComplexProductCollapseHomotopy C ε hε ρ hρ hε1 hρε hC hRC hRD r η hρη hηε⟩
+  · intro n a
+    exact varyingComplexProductCollapseMap_homology C ε hε ρ hρ hε1 hρε hC hRC hRD r η hρη hηε n a
+
+private theorem CuspSpecialization.exists_product_model_at_nonzero_level
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hRC : ToricSpace.SmallDrift C ε) (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε)
+    (t : ℂ) (ht : t ≠ 0) (htε : ‖t‖ < ε) :
+    ∃ e :
+      (ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2) ≃ₜ
+        CuspControlledRetraction.ActualQuotientFibre C ε t,
+      IsPrescribedProductModel C ε hε t ht e := by
+  have hρ : 0 < ‖t‖ := norm_pos_iff.mpr ht
+  have hm :
+    ∃ e :
+      (ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2) ≃ₜ
+        CuspControlledRetraction.ActualQuotientFibre C ε (rotatedLevel ‖t‖ (argumentTurns t)),
+      IsPrescribedProductModel C ε hε (rotatedLevel ‖t‖ (argumentTurns t))
+        (rotatedLevel_ne_zero ‖t‖ (argumentTurns t) hρ) e :=
+    ⟨varyingComplexProductFibreHomeomorph C ε hε ‖t‖ hρ hε1 htε hC hRC hRD (argumentTurns t),
+      varyingComplexProductFibreHomeomorph_isPrescribedProductModel C ε hε hε1 hC hRC hRD ‖t‖ hρ
+        htε (argumentTurns t)⟩
+  have transfer (u : ℂ) (hu : u ≠ 0) (hut : u = t)
+    (huModel :
+      ∃ e :
+        (ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2) ≃ₜ
+          CuspControlledRetraction.ActualQuotientFibre C ε u,
+        IsPrescribedProductModel C ε hε u hu e) :
+    ∃ e :
+      (ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2) ≃ₜ
+        CuspControlledRetraction.ActualQuotientFibre C ε t,
+      IsPrescribedProductModel C ε hε t ht e := by
+    subst u
+    exact huModel
+  exact transfer _ _ (rotatedLevel_norm_argumentTurns t) hm
+
+@[simp]
+private theorem CuspCentralHomology.fibreRadiusHomeomorph_fibreProjection
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ : ℝ) (t : ℂ) (hδr : δ ≤ r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (htδ : ‖t‖ < δ)
+    (x : CuspSpecialization.ToricFibre t) :
+    fibreRadiusHomeomorph C r δ t hδr hC htδ (CuspSpecialization.fibreProjection C δ t htδ x) =
+      CuspSpecialization.fibreProjection C r t (htδ.trans_le hδr) x := by
+  apply Subtype.ext
+  change
+    (openQuotientRadiusHomeomorph C hδr hC (CuspSpecialization.fibreProjection C δ t htδ x).1).1 =
+      (CuspSpecialization.fibreProjection C r t (htδ.trans_le hδr) x).1
+  simp only [CuspSpecialization.fibreProjection_coe, openQuotientRadiusHomeomorph_quotientMap,
+    openQuotientMap]
+
+@[simp]
+private theorem CuspCentralHomology.centralRadiusHomeomorph_centralProject
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ : ℝ) (hδr : δ ≤ r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (hδ : 0 < δ)
+    (x : CuspRetraction.CentralFibre) :
+    centralRadiusHomeomorph C r δ hδr hC hδ (CuspCollapse.centralProject C δ hδ x) =
+      CuspCollapse.centralProject C r (hδ.trans_le hδr) x := by
+  apply Subtype.ext
+  change
+    (openQuotientRadiusHomeomorph C hδr hC (CuspCollapse.centralProject C δ hδ x).1).1 =
+      (CuspCollapse.centralProject C r (hδ.trans_le hδr) x).1
+  simp only [CuspCollapse.centralProject, openQuotientRadiusHomeomorph_quotientMap,
+    openQuotientMap]
+
+@[simp]
+private theorem CuspCentralHomology.centralRadiusHomeomorph_centralCollapseMap
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ : ℝ) (hδr : δ ≤ r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (hδ : 0 < δ)
+    (p : CuspCollapse.PhasePositiveSpace) :
+    centralRadiusHomeomorph C r δ hδr hC hδ (CuspCollapse.centralCollapseMap C δ hδ p) =
+      CuspCollapse.centralCollapseMap C r (hδ.trans_le hδr) p :=
+  centralRadiusHomeomorph_centralProject C r δ hδr hC hδ (CuspCollapse.centralPolarMap p)
+
+@[simp]
+private theorem CuspCentralHomology.centralRadiusHomeomorph_honeycombCollapseMap
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ : ℝ) (hδr : δ ≤ r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (hδ : 0 < δ)
+    (p : CuspHoneycomb.PhasePlane) :
+    centralRadiusHomeomorph C r δ hδr hC hδ (CuspHoneycomb.honeycombCollapseMap C δ hδ p) =
+      CuspHoneycomb.honeycombCollapseMap C r (hδ.trans_le hδr) p :=
+  centralRadiusHomeomorph_centralCollapseMap C r δ hδr hC hδ
+    (CuspHoneycomb.phaseCoordinatesHomeomorph (C 0) p)
+
+@[simp]
+private theorem CuspCentralHomology.centralRadiusHomeomorph_sourceCollapse
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ : ℝ) (hδr : δ ≤ r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (hδ : 0 < δ)
+    (q : CuspSpecialization.SourceModel (C 0)) :
+    centralRadiusHomeomorph C r δ hδr hC hδ (CuspSpecialization.sourceCollapse C δ hδ q) =
+      CuspSpecialization.sourceCollapse C r (hδ.trans_le hδr) q := by
+  induction q using Quotient.inductionOn with
+  | h p => exact centralRadiusHomeomorph_honeycombCollapseMap C r δ hδr hC hδ p
+
+@[simp]
+private theorem CuspCentralHomology.centralRadiusHomeomorph_productCollapse
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ : ℝ) (hδr : δ ≤ r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (hδ : 0 < δ)
+    (p : ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2) :
+    centralRadiusHomeomorph C r δ hδr hC hδ (CuspSpecialization.productCollapse C δ hδ p) =
+      CuspSpecialization.productCollapse C r (hδ.trans_le hδr) p :=
+  centralRadiusHomeomorph_sourceCollapse C r δ hδr hC hδ
+    ((CuspSpecialization.sourceProductHomeomorph (C 0)).symm p)
+
+private theorem CuspCentralHomology.centralRadiusHomeomorph_comp_productCollapse
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ : ℝ) (hδr : δ ≤ r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (hδ : 0 < δ) :
+    (centralRadiusHomeomorph C r δ hδr hC hδ :
+            C(CuspRetraction.QuotientCentralFibre C δ,
+              CuspRetraction.QuotientCentralFibre C r)).comp
+        (CuspSpecialization.productCollapse C δ hδ) =
+      CuspSpecialization.productCollapse C r (hδ.trans_le hδr) := by
+  apply ContinuousMap.ext
+  intro p
+  exact centralRadiusHomeomorph_productCollapse C r δ hδr hC hδ p
+
+private def
+    CuspControlledRetraction.puncturedPositiveTranslate (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (η : ℝ)
+    (v : Fin 2 → ℤ) (q : PuncturedPositiveTube η) : PuncturedPositiveTube η :=
+  ⟨CuspPositive.closedPositiveTranslate C₀ η v q.1,
+    by
+    change
+      ToricSpace.time
+          (ToricSpace.twistedTranslate (CuspPositive.positiveTwist C₀) v
+            (q.1.1 : ToricSpace.Space)) ≠
+        0
+    rw [ToricSpace.time_twistedTranslate]
+    exact q.2⟩
+
+private def
+    CuspControlledRetraction.puncturedFrozenTranslate (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (η : ℝ)
+    (v : Fin 2 → ℤ) (x : PuncturedClosedTube η) : PuncturedClosedTube η :=
+  ⟨CuspRetraction.closedTranslate (fun _ => C₀) η v x.1,
+    by
+    change
+      ToricSpace.time (ToricSpace.twistedTranslate (fun _ => C₀) v (x.1 : ToricSpace.Space)) ≠ 0
+    rw [ToricSpace.time_twistedTranslate]
+    exact x.2⟩
+
+private theorem
+    CuspControlledRetraction.puncturedFrozenTranslate_polar (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (η : ℝ) (v : Fin 2 → ℤ) (u : ToricSpace.CompactTorus) (q : PuncturedPositiveTube η) :
+    puncturedFrozenTranslate C₀ η v (puncturedPolarMap η (u, q)) =
+      puncturedPolarMap η
+        (CuspPositive.phaseTransform C₀ v u, puncturedPositiveTranslate C₀ η v q) :=
+  Subtype.ext
+    (Subtype.ext (CuspPositive.twistedTranslate_constant_polar C₀ v u (q.1.1 : ToricSpace.Space)))
+
+private theorem CuspControlledRetraction.prescribedPositiveCollapse_equivariant
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (hηε : η < ε) (v : Fin 2 → ℤ)
+    (q : PuncturedPositiveTube η) :
+    prescribedPositiveCollapse C₀ η (puncturedPositiveTranslate C₀ η v q) =
+      CuspCollapse.positiveCentralTranslate C₀ v (prescribedPositiveCollapse C₀ η q) := by
+  change
+    CuspHoneycomb.honeycombHomeomorph C₀
+        (normalizedPosition C₀
+          ((CuspPositive.closedPositiveTranslate C₀ η v q.1).1 : ToricSpace.Space)) =
+      CuspCollapse.positiveCentralTranslate C₀ v
+        (CuspHoneycomb.honeycombHomeomorph C₀ (normalizedPosition C₀ (q.1.1 : ToricSpace.Space)))
+  rw [normalizedPosition_closedPositive_twistedTranslate C₀ hε1 hR hηε v q.2,
+    CuspHoneycomb.honeycombHomeomorph_equivariant]
+
+private theorem CuspControlledRetraction.prescribedCollapse_frozen_equivariant
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε1 : ε < 1)
+    (hR : ToricSpace.SmallDrift (CuspPositive.positiveTwist C₀) ε) (hηε : η < ε) (v : Fin 2 → ℤ)
+    (x : PuncturedClosedTube η) :
+    (prescribedCollapse C₀ η (puncturedFrozenTranslate C₀ η v x) : ToricSpace.Space) =
+      ToricSpace.twistedTranslate (fun _ => C₀) v
+        (prescribedCollapse C₀ η x : ToricSpace.Space) := by
+  obtain ⟨⟨u, q⟩, rfl⟩ := puncturedPolarMap_surjective η x
+  rw [puncturedFrozenTranslate_polar, prescribedCollapse_puncturedPolarMap,
+    prescribedCollapse_puncturedPolarMap]
+  change
+    ToricSpace.compactTorusAction (CuspPositive.phaseTransform C₀ v u)
+        ((prescribedPositiveCollapse C₀ η (puncturedPositiveTranslate C₀ η v q)).1 :
+          ToricSpace.Space) =
+      ToricSpace.twistedTranslate (fun _ => C₀) v
+        (ToricSpace.compactTorusAction u
+          ((prescribedPositiveCollapse C₀ η q).1 : ToricSpace.Space))
+  rw [prescribedPositiveCollapse_equivariant C₀ hε1 hR hηε]
+  exact
+    (CuspPositive.twistedTranslate_constant_polar C₀ v u
+        ((prescribedPositiveCollapse C₀ η q).1 : ToricSpace.Space)).symm
+
+private def CuspSpecialization.puncturedTwistedTranslate (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (η : ℝ)
+    (v : Fin 2 → ℤ) (x : CuspControlledRetraction.PuncturedClosedTube η) :
+    CuspControlledRetraction.PuncturedClosedTube η :=
+  ⟨CuspRetraction.closedTranslate C η v x.1,
+    by
+    change ToricSpace.time (ToricSpace.twistedTranslate C v (x.1 : ToricSpace.Space)) ≠ 0
+    rw [ToricSpace.time_twistedTranslate]
+    exact x.2⟩
+
+private theorem CuspSpecialization.puncturedStraightening_twistedTranslate
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε1 : ε < 1) (hRC : ToricSpace.SmallDrift C ε)
+    (hηε : η < ε) (v : Fin 2 → ℤ) (x : CuspControlledRetraction.PuncturedClosedTube η) :
+    CuspControlledRetraction.puncturedStraightening C η (puncturedTwistedTranslate C η v x) =
+      CuspControlledRetraction.puncturedFrozenTranslate (C 0) η v
+        (CuspControlledRetraction.puncturedStraightening C η x) := by
+  apply Subtype.ext
+  apply Subtype.ext
+  exact CuspRetraction.changeTwist_frozen_equivariant C hε1 hRC v (x.1.2.trans_lt hηε)
+
+private theorem
+    CuspSpecialization.twistedTranslate_frozen_central (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) (x : CuspRetraction.CentralFibre) :
+    ToricSpace.twistedTranslate (CuspRetraction.frozen C) v (x : ToricSpace.Space) =
+      ToricSpace.twistedTranslate C v (x : ToricSpace.Space) := by
+  rw [CuspRetraction.twistedTranslate_eq_expFibreAction,
+    CuspRetraction.twistedTranslate_eq_expFibreAction, x.2]
+  rfl
+
+@[simp]
+private theorem
+    CuspSpecialization.levelToPunctured_levelTranslate (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (η : ℝ) (t : ℂ) (ht : t ≠ 0) (v : Fin 2 → ℤ) (x : CuspControlledRetraction.ToricLevel η t) :
+    CuspControlledRetraction.levelToPunctured η t ht
+        (CuspControlledRetraction.levelTranslate C η t v x) =
+      puncturedTwistedTranslate C η v (CuspControlledRetraction.levelToPunctured η t ht x) :=
+  rfl
+
+private theorem CuspSpecialization.straightenedPrescribedCollapse_equivariant
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε1 : ε < 1) (hRC : ToricSpace.SmallDrift C ε)
+    (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε) (hηε : η < ε) (v : Fin 2 → ℤ)
+    (x : CuspControlledRetraction.PuncturedClosedTube η) :
+    (CuspControlledRetraction.straightenedPrescribedCollapse C η
+          (puncturedTwistedTranslate C η v x) :
+        ToricSpace.Space) =
+      ToricSpace.twistedTranslate C v
+        (CuspControlledRetraction.straightenedPrescribedCollapse C η x : ToricSpace.Space) := by
+  change
+    (CuspControlledRetraction.prescribedCollapse (C 0) η
+          (CuspControlledRetraction.puncturedStraightening C η
+            (puncturedTwistedTranslate C η v x)) :
+        ToricSpace.Space) =
+      ToricSpace.twistedTranslate C v
+        (CuspControlledRetraction.prescribedCollapse (C 0) η
+            (CuspControlledRetraction.puncturedStraightening C η x) :
+          ToricSpace.Space)
+  rw [puncturedStraightening_twistedTranslate C hε1 hRC hηε,
+    CuspControlledRetraction.prescribedCollapse_frozen_equivariant (C 0) hε1
+      (CuspPositive.smallDrift_positiveTwist (C 0) hRD) hηε]
+  exact
+    twistedTranslate_frozen_central C v
+      (CuspControlledRetraction.prescribedCollapse (C 0) η
+        (CuspControlledRetraction.puncturedStraightening C η x))
+
+private theorem
+    CuspSpecialization.prescribedFibreUpstairs_invariant (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hε1 : ε < 1) (hRC : ToricSpace.SmallDrift C ε)
+    (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε) (hηε : η < ε) (r : ℝ) (hr : 0 < r)
+    (t : ℂ) (ht : t ≠ 0) (v : Fin 2 → ℤ) (x : CuspControlledRetraction.ToricLevel η t) :
+    CuspControlledRetraction.prescribedFibreUpstairs C r hr η t ht
+        (CuspControlledRetraction.levelTranslate C η t v x) =
+      CuspControlledRetraction.prescribedFibreUpstairs C r hr η t ht x := by
+  unfold CuspControlledRetraction.prescribedFibreUpstairs
+  rw [levelToPunctured_levelTranslate]
+  apply (CuspCollapse.centralProject_eq_iff C r hr _ _).mpr
+  exact
+    ⟨v,
+      (straightenedPrescribedCollapse_equivariant C hε1 hRC hRD hηε v
+          (CuspControlledRetraction.levelToPunctured η t ht x)).symm⟩
+
+private theorem
+    CuspSpecialization.prescribedFibreUpstairs_compatible (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    {ε η : ℝ} (hε1 : ε < 1) (hRC : ToricSpace.SmallDrift C ε)
+    (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε) (hηε : η < ε) (r : ℝ) (hr : 0 < r)
+    (hηr : η < r) (t : ℂ) (ht : t ≠ 0) :
+    ∀ x y : CuspControlledRetraction.ToricLevel η t,
+      CuspControlledRetraction.levelProjection C hηr t x =
+          CuspControlledRetraction.levelProjection C hηr t y →
+        CuspControlledRetraction.prescribedFibreUpstairs C r hr η t ht x =
+          CuspControlledRetraction.prescribedFibreUpstairs C r hr η t ht y :=
+  CuspControlledRetraction.levelProjection_fibre_compatible_of_invariant C hηr t
+    (CuspControlledRetraction.prescribedFibreUpstairs C r hr η t ht)
+    (prescribedFibreUpstairs_invariant C hε1 hRC hRD hηε r hr t ht)
+
+private theorem CuspSpecialization.prescribedFibreCollapse_levelProjection
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε1 : ε < 1) (hRC : ToricSpace.SmallDrift C ε)
+    (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε) (hηε : η < ε) (r : ℝ) (hr : 0 < r)
+    (hηr : η < r) (t : ℂ) (ht : t ≠ 0) (x : CuspControlledRetraction.ToricLevel η t) :
+    CuspControlledRetraction.prescribedFibreCollapse C r hr hηr t ht
+        (CuspControlledRetraction.levelProjection C hηr t x) =
+      CuspControlledRetraction.prescribedFibreUpstairs C r hr η t ht x :=
+  CuspControlledRetraction.levelDescend_levelProjection C hηr t
+    (CuspControlledRetraction.prescribedFibreUpstairs C r hr η t ht)
+    (prescribedFibreUpstairs_compatible C hε1 hRC hRD hηε r hr hηr t ht) x
+
+private theorem CuspSpecialization.prescribedActualFibreCollapse_fibreProjection
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε η : ℝ} (hε1 : ε < 1) (hRC : ToricSpace.SmallDrift C ε)
+    (hRD : ToricSpace.SmallDrift (CuspRetraction.frozen C) ε) (hηε : η < ε) (r : ℝ) (hr : 0 < r)
+    (hηr : η < r) (t : ℂ) (ht : t ≠ 0) (htη : ‖t‖ ≤ η) (x : ToricFibre t) :
+    CuspControlledRetraction.prescribedActualFibreCollapse C r hr hηr t ht htη
+        (fibreProjection C r t (htη.trans_lt hηr) x) =
+      CuspCollapse.centralProject C r hr
+        (CuspControlledRetraction.straightenedPrescribedCollapse C η
+          (toricFibrePunctured η t ht htη x)) := by
+  rw [fibreProjection_eq_levelProjection C r t (htη.trans_lt hηr) η hηr htη x]
+  change
+    CuspControlledRetraction.prescribedFibreCollapse C r hr hηr t ht
+        ((CuspControlledRetraction.quotientLevelFibreHomeomorph C r η t htη).symm
+          (CuspControlledRetraction.quotientLevelFibreHomeomorph C r η t htη
+            (CuspControlledRetraction.levelProjection C hηr t
+              (toricFibreLevelHomeomorph η t htη x)))) =
+      _
+  rw [Homeomorph.symm_apply_apply]
+  exact
+    prescribedFibreCollapse_levelProjection C hε1 hRC hRD hηε r hr hηr t ht
+      (toricFibreLevelHomeomorph η t htη x)
+
+private theorem CuspCentralHomology.prescribedActualFibreCollapse_radius
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ : ℝ) (hr : 0 < r) (hδ : 0 < δ) (hδr : δ ≤ r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (hδ1 : δ < 1)
+    (hRC : ToricSpace.SmallDrift C δ) (hRF : ToricSpace.SmallDrift (CuspRetraction.frozen C) δ)
+    (η : ℝ) (hηδ : η < δ) (t : ℂ) (ht : t ≠ 0) (htη : ‖t‖ ≤ η)
+    (q : CuspControlledRetraction.ActualQuotientFibre C δ t) :
+    CuspControlledRetraction.prescribedActualFibreCollapse C r hr (hηδ.trans_le hδr) t ht htη
+        (fibreRadiusHomeomorph C r δ t hδr hC (htη.trans_lt hηδ) q) =
+      centralRadiusHomeomorph C r δ hδr hC hδ
+        (CuspControlledRetraction.prescribedActualFibreCollapse C δ hδ hηδ t ht htη q) := by
+  obtain ⟨x, rfl⟩ := CuspSpecialization.fibreProjection_surjective C δ t (htη.trans_lt hηδ) q
+  rw [fibreRadiusHomeomorph_fibreProjection,
+    CuspSpecialization.prescribedActualFibreCollapse_fibreProjection C hδ1 hRC hRF hηδ r hr
+      (hηδ.trans_le hδr) t ht htη,
+    CuspSpecialization.prescribedActualFibreCollapse_fibreProjection C hδ1 hRC hRF hηδ δ hδ hηδ t
+      ht htη,
+    centralRadiusHomeomorph_centralProject]
+
+private theorem CuspCentralHomology.levelToPunctured_continuous (η : ℝ) (t : ℂ) (ht : t ≠ 0) :
+    Continuous (CuspControlledRetraction.levelToPunctured η t ht) := by
+  apply Continuous.subtype_mk
+  exact continuous_subtype_val
+
+private theorem CuspCentralHomology.prescribedFibreUpstairs_continuous_of_smallRadius
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r) {δ η : ℝ} (hδ : 0 < δ) (hδ1 : δ < 1)
+    (hCδ : ∀ i j, ContinuousOn (fun z => C z i j) (Metric.ball 0 δ))
+    (hRC : ToricSpace.SmallDrift C δ) (hRF : ToricSpace.SmallDrift (CuspRetraction.frozen C) δ)
+    (hηδ : η < δ) (t : ℂ) (ht : t ≠ 0) :
+    Continuous (CuspControlledRetraction.prescribedFibreUpstairs C r hr η t ht) := by
+  change
+    Continuous
+      (CuspCollapse.centralProject C r hr ∘
+        (CuspControlledRetraction.straightenedPrescribedCollapse C η ∘
+          CuspControlledRetraction.levelToPunctured η t ht))
+  have hc : Continuous (CuspControlledRetraction.straightenedPrescribedCollapse C η) :=
+    CuspControlledRetraction.straightenedPrescribedCollapse_continuous C hδ hδ1 hCδ hRC hRF hηδ
+  have hp : Continuous (CuspControlledRetraction.levelToPunctured η t ht) :=
+    levelToPunctured_continuous η t ht
+  have hi :
+    Continuous
+      (CuspControlledRetraction.straightenedPrescribedCollapse C η ∘
+        CuspControlledRetraction.levelToPunctured η t ht) :=
+    Continuous.comp (f := CuspControlledRetraction.levelToPunctured η t ht) (g :=
+      CuspControlledRetraction.straightenedPrescribedCollapse C η) hc hp
+  exact
+    Continuous.comp (f :=
+      CuspControlledRetraction.straightenedPrescribedCollapse C η ∘
+        CuspControlledRetraction.levelToPunctured η t ht)
+      (g := CuspCollapse.centralProject C r hr) (CuspCollapse.centralProject_continuous C r hr) hi
+
+private theorem CuspCentralHomology.prescribedFibreCollapse_continuous_of_smallRadius
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ : ℝ) (hr : 0 < r) (hδ : 0 < δ) (hδr : δ ≤ r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (hδ1 : δ < 1)
+    (hRC : ToricSpace.SmallDrift C δ) (hRF : ToricSpace.SmallDrift (CuspRetraction.frozen C) δ)
+    (η : ℝ) (hηδ : η < δ) (t : ℂ) (ht : t ≠ 0) :
+    Continuous
+      (CuspControlledRetraction.prescribedFibreCollapse C r hr (hηδ.trans_le hδr) t ht) := by
+  have hCδ (i j) : ContinuousOn (fun z => C z i j) (Metric.ball 0 δ) :=
+    ((hC i j).mono (Metric.ball_subset_ball hδr)).continuousOn
+  have hf : Continuous (CuspControlledRetraction.prescribedFibreUpstairs C r hr η t ht) :=
+    prescribedFibreUpstairs_continuous_of_smallRadius C r hr hδ hδ1 hCδ hRC hRF hηδ t ht
+  exact
+    CuspControlledRetraction.levelDescend_continuous C (hηδ.trans_le hδr) t
+      (CuspControlledRetraction.prescribedFibreUpstairs C r hr η t ht) hC hf
+      (CuspSpecialization.prescribedFibreUpstairs_compatible C hδ1 hRC hRF hηδ r hr
+        (hηδ.trans_le hδr) t ht)
+
+private theorem CuspCentralHomology.prescribedActualFibreCollapse_continuous_of_smallRadius
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ : ℝ) (hr : 0 < r) (hδ : 0 < δ) (hδr : δ ≤ r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (hδ1 : δ < 1)
+    (hRC : ToricSpace.SmallDrift C δ) (hRF : ToricSpace.SmallDrift (CuspRetraction.frozen C) δ)
+    (η : ℝ) (hηδ : η < δ) (t : ℂ) (ht : t ≠ 0) (htη : ‖t‖ ≤ η) :
+    Continuous
+      (CuspControlledRetraction.prescribedActualFibreCollapse C r hr (hηδ.trans_le hδr) t ht
+        htη) := by
+  change
+    Continuous
+      (CuspControlledRetraction.prescribedFibreCollapse C r hr (hηδ.trans_le hδr) t ht ∘
+        (CuspControlledRetraction.quotientLevelFibreHomeomorph C r η t htη).symm)
+  exact
+    (prescribedFibreCollapse_continuous_of_smallRadius C r δ hr hδ hδr hC hδ1 hRC hRF η hηδ t
+          ht).comp
+      (CuspControlledRetraction.quotientLevelFibreHomeomorph C r η t htη).symm.continuous
+
+private def CuspCentralHomology.smallRadiusActualFibreCollapseMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r δ : ℝ) (hr : 0 < r) (hδ : 0 < δ) (hδr : δ ≤ r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (hδ1 : δ < 1)
+    (hRC : ToricSpace.SmallDrift C δ) (hRF : ToricSpace.SmallDrift (CuspRetraction.frozen C) δ)
+    (η : ℝ) (hηδ : η < δ) (t : ℂ) (ht : t ≠ 0) (htη : ‖t‖ ≤ η) :
+    C(CuspControlledRetraction.ActualQuotientFibre C r t, CuspRetraction.QuotientCentralFibre C r)
+    where
+  toFun :=
+    CuspControlledRetraction.prescribedActualFibreCollapse C r hr (hηδ.trans_le hδr) t ht htη
+  continuous_toFun :=
+    prescribedActualFibreCollapse_continuous_of_smallRadius C r δ hr hδ hδr hC hδ1 hRC hRF η hηδ t
+      ht htη
+
+private def CuspSpecialization.sourceProductCoordinateHomeomorph :
+    (ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2) ≃ₜ
+      PeriodTorusHigherHomology.ProductTorus 4 :=
+  ((Homeomorph.prodComm ToricSpace.CompactFibreTorus
+            (PeriodTorusHigherHomology.ProductTorus 2)).trans
+        ((Homeomorph.refl (PeriodTorusHigherHomology.ProductTorus 2)).prodCongr
+          CuspCentralHomology.compactFibreTorusHomeomorph)).trans
+    (Fin.appendHomeomorph 2 2)
+
+@[simp]
+private theorem CuspSpecialization.sourceProductCoordinateHomeomorph_apply
+    (p : ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2) :
+    sourceProductCoordinateHomeomorph p =
+      ![p.2 0, p.2 1, CuspCentralHomology.compactFibreTorusHomeomorph p.1 0,
+        CuspCentralHomology.compactFibreTorusHomeomorph p.1 1] := by
+  funext i
+  fin_cases i <;> rfl
+
+private def CuspSpecialization.sourceCoordinateTorusHomeomorph (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    SourceModel C₀ ≃ₜ PeriodTorusHigherHomology.ProductTorus 4 :=
+  (sourceProductHomeomorph C₀).trans sourceProductCoordinateHomeomorph
+
+@[simp]
+private theorem CuspSpecialization.sourceCoordinateTorusHomeomorph_projection
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (p : CuspHoneycomb.PhasePlane) :
+    sourceCoordinateTorusHomeomorph C₀ (sourceProjection C₀ p) =
+      ![((-p.2 1 : ℝ) : AddCircle (1 : ℝ)), (p.2 0 : AddCircle (1 : ℝ)),
+        CuspCentralHomology.compactFibreTorusHomeomorph (p.1 * (sourcePhaseCharacter C₀ p.2)⁻¹) 0,
+        CuspCentralHomology.compactFibreTorusHomeomorph (p.1 * (sourcePhaseCharacter C₀ p.2)⁻¹)
+          1] := by
+  rw [sourceCoordinateTorusHomeomorph, Homeomorph.trans_apply, sourceProductHomeomorph_projection,
+    sourceProductCoordinateHomeomorph_apply]
+  simp [ToricSpace.realCuspVector]
+
+private theorem CuspSpecialization.compactFibreTorusHomeomorph_planarPhase
+    (y : (CuspHoneycombTiling.Plane)) :
+    CuspCentralHomology.compactFibreTorusHomeomorph (planarPhase y) =
+      PeriodTorusHigherHomology.coordinateProjection 2 y :=
+  CuspCentralHomology.compactFibreTorusHomeomorph_exp y
+
+private theorem CuspSpecialization.sourceTorusMatrix_M₀_apply
+    (x : PeriodTorusHigherHomology.ProductTorus 4) :
+    PeriodTorusHigherHomology.torusMatrixMap M₀ x = ![x 0, x 1, x 1 + x 2, -x 0 + x 3] := by
+  funext i
+  fin_cases i <;> simp [PeriodTorusHigherHomology.torusMatrixMap_apply, M₀, Fin.sum_univ_four]
+
+private theorem
+    CuspSpecialization.sourceCoordinateTorusHomeomorph_shear (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (x : SourceModel C₀) :
+    sourceCoordinateTorusHomeomorph C₀ (sourceShear C₀ x) =
+      PeriodTorusHigherHomology.torusMatrixMap M₀ (sourceCoordinateTorusHomeomorph C₀ x) := by
+  obtain ⟨p, rfl⟩ := sourceProjection_surjective C₀ x
+  rw [sourceShear_projection, sourceCoordinateTorusHomeomorph_projection,
+    sourceCoordinateTorusHomeomorph_projection, sourceTorusMatrix_M₀_apply]
+  have hp :
+    (p.1 * planarPhase p.2) * (sourcePhaseCharacter C₀ p.2)⁻¹ =
+      (p.1 * (sourcePhaseCharacter C₀ p.2)⁻¹) * planarPhase p.2 := by ac_rfl
+  simp only [phasePlaneShear, hp, CuspCentralHomology.compactFibreTorusHomeomorph_mul,
+    compactFibreTorusHomeomorph_planarPhase]
+  funext i
+  fin_cases i <;>
+    simp [PeriodTorusHigherHomology.coordinateProjection_apply, QuotientAddGroup.mk_neg, add_comm]
+
+private def
+    CuspSpecialization.markedCollapse (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    C(PeriodTorusHigherHomology.ProductTorus 4, CuspRetraction.QuotientCentralFibre C ε) :=
+  (sourceCollapse C ε hε).comp
+    ((sourceCoordinateTorusHomeomorph (C 0)).symm :
+      C(PeriodTorusHigherHomology.ProductTorus 4, SourceModel (C 0)))
+
+private theorem
+    CuspSpecialization.markedCollapse_eq_product (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) :
+    markedCollapse C ε hε =
+      (productCollapse C ε hε).comp
+        (sourceProductCoordinateHomeomorph.symm :
+          C(PeriodTorusHigherHomology.ProductTorus 4,
+            ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2)) :=
+  rfl
+
+private theorem CuspSpecialization.markedCollapse_comp_productCoordinates
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    (markedCollapse C ε hε).comp
+        (sourceProductCoordinateHomeomorph :
+          C(ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2,
+            PeriodTorusHigherHomology.ProductTorus 4)) =
+      productCollapse C ε hε := by
+  rw [markedCollapse_eq_product]
+  apply ContinuousMap.ext
+  intro x
+  change
+    productCollapse C ε hε
+        (sourceProductCoordinateHomeomorph.symm (sourceProductCoordinateHomeomorph x)) =
+      _
+  rw [Homeomorph.symm_apply_apply]
+
+private theorem CuspSpecialization.sourceCoordinateTorusHomeomorph_symm_matrix
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (x : PeriodTorusHigherHomology.ProductTorus 4) :
+    (sourceCoordinateTorusHomeomorph (C 0)).symm (PeriodTorusHigherHomology.torusMatrixMap M₀ x) =
+      sourceShear (C 0) ((sourceCoordinateTorusHomeomorph (C 0)).symm x) := by
+  apply (sourceCoordinateTorusHomeomorph (C 0)).injective
+  rw [Homeomorph.apply_symm_apply, sourceCoordinateTorusHomeomorph_shear,
+    Homeomorph.apply_symm_apply]
+
+private theorem
+    CuspSpecialization.markedCollapse_comp_matrix (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) :
+    (markedCollapse C ε hε).comp (PeriodTorusHigherHomology.torusMatrixMap M₀) =
+      ((sourceCollapse C ε hε).comp (sourceShear (C 0))).comp
+        ((sourceCoordinateTorusHomeomorph (C 0)).symm :
+          C(PeriodTorusHigherHomology.ProductTorus 4, SourceModel (C 0))) := by
+  apply ContinuousMap.ext
+  intro x
+  change
+    sourceCollapse C ε hε
+        ((sourceCoordinateTorusHomeomorph (C 0)).symm
+          (PeriodTorusHigherHomology.torusMatrixMap M₀ x)) =
+      _
+  rw [sourceCoordinateTorusHomeomorph_symm_matrix]
+  rfl
+
+private def
+    CuspSpecialization.markedCollapseMonodromyHomotopy (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) :
+    (markedCollapse C ε hε).Homotopy
+      ((markedCollapse C ε hε).comp (PeriodTorusHigherHomology.torusMatrixMap M₀)) := by
+  rw [markedCollapse_comp_matrix]
+  have h :=
+    (sourceRotationHomotopy C ε hε 1).compContinuousMap
+      ((sourceCoordinateTorusHomeomorph (C 0)).symm :
+        C(PeriodTorusHigherHomology.ProductTorus 4, SourceModel (C 0)))
+  simpa only [sourceRotation_one, markedCollapse] using h
+
+private theorem
+    CuspSpecialization.markedCollapse_homology_comp_matrix (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (n : ℕ) :
+    (SingularMayerVietoris.singularHomologyMap (markedCollapse C ε hε) n).comp
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀)
+          n) =
+      SingularMayerVietoris.singularHomologyMap (markedCollapse C ε hε) n := by
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp]
+  exact
+    (PeriodTorusHigherHomology.homotopy_homologyMap (markedCollapseMonodromyHomotopy C ε hε)
+        n).symm
+
+private theorem
+    CuspSpecialization.markedCollapse_homology_invariant (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) n) :
+    SingularMayerVietoris.singularHomologyMap (markedCollapse C ε hε) n
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀) n
+          a) =
+      SingularMayerVietoris.singularHomologyMap (markedCollapse C ε hε) n a :=
+  LinearMap.congr_fun (markedCollapse_homology_comp_matrix C ε hε n) a
+
+private theorem CuspSpecialization.markedCollapse_homology_range_variation
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (n : ℕ) :
+    LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀)
+            n -
+          LinearMap.id) ≤
+      LinearMap.ker (SingularMayerVietoris.singularHomologyMap (markedCollapse C ε hε) n) := by
+  rintro a ⟨b, rfl⟩
+  change
+    SingularMayerVietoris.singularHomologyMap (markedCollapse C ε hε) n
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀) n
+            b -
+          b) =
+      0
+  rw [map_sub, markedCollapse_homology_invariant, sub_self]
+
+private theorem
+    CuspSpecialization.markedCollapse_homology_product (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2) n) :
+    SingularMayerVietoris.singularHomologyMap (markedCollapse C ε hε) n
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv sourceProductCoordinateHomeomorph n
+          a) =
+      SingularMayerVietoris.singularHomologyMap (productCollapse C ε hε) n a := by
+  have h :=
+    congrArg (fun f => SingularMayerVietoris.singularHomologyMap f n)
+      (markedCollapse_comp_productCoordinates C ε hε)
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp] at h
+  exact LinearMap.congr_fun h a
+
+private theorem CuspSpecialization.markedCollapse_homology_surjective_of_product
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (n : ℕ)
+    (hf :
+      Function.Surjective
+        (SingularMayerVietoris.singularHomologyMap (productCollapse C ε hε) n)) :
+    Function.Surjective (SingularMayerVietoris.singularHomologyMap (markedCollapse C ε hε) n) := by
+  intro x
+  obtain ⟨a, rfl⟩ := hf x
+  exact
+    ⟨PeriodTorusHigherHomology.homeomorphHomologyEquiv sourceProductCoordinateHomeomorph n a,
+      markedCollapse_homology_product C ε hε n a⟩
+
+private def
+    CuspSpecialization.radiusMarkedHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ : ℝ) (t : ℂ)
+    (hδr : δ ≤ r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r))
+    (htδ : ‖t‖ < δ)
+    (e :
+      (ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2) ≃ₜ
+        CuspControlledRetraction.ActualQuotientFibre C δ t) :
+    PeriodTorusHigherHomology.ProductTorus 4 ≃ₜ
+      CuspControlledRetraction.ActualQuotientFibre C r t :=
+  sourceProductCoordinateHomeomorph.symm.trans
+    (e.trans (CuspCentralHomology.fibreRadiusHomeomorph C r δ t hδr hC htδ))
+
+private theorem
+    CuspSpecialization.radiusMarkedHomeomorph_homotopic (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r δ : ℝ) (hr : 0 < r) (hδ : 0 < δ) (hδr : δ ≤ r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (hδ1 : δ < 1)
+    (hRC : ToricSpace.SmallDrift C δ) (hRF : ToricSpace.SmallDrift (CuspRetraction.frozen C) δ)
+    (t : ℂ) (ht : t ≠ 0) (htδ : ‖t‖ < δ)
+    (e :
+      (ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2) ≃ₜ
+        CuspControlledRetraction.ActualQuotientFibre C δ t)
+    (he : IsPrescribedProductModel C δ hδ t ht e) (η : ℝ) (hηδ : η < δ) (htη : ‖t‖ ≤ η) :
+    (markedCollapse C r hr).Homotopic
+      ((CuspCentralHomology.smallRadiusActualFibreCollapseMap C r δ hr hδ hδr hC hδ1 hRC hRF η hηδ
+            t ht htη).comp
+        (radiusMarkedHomeomorph C r δ t hδr hC htδ e :
+          C(PeriodTorusHigherHomology.ProductTorus 4,
+            CuspControlledRetraction.ActualQuotientFibre C r t))) := by
+  obtain ⟨hc, hh, _⟩ := he η htη hηδ
+  let f :
+    C(CuspControlledRetraction.ActualQuotientFibre C δ t,
+      CuspRetraction.QuotientCentralFibre C δ) :=
+    ⟨CuspControlledRetraction.prescribedActualFibreCollapse C δ hδ hηδ t ht htη, hc⟩
+  let g :=
+    CuspCentralHomology.smallRadiusActualFibreCollapseMap C r δ hr hδ hδr hC hδ1 hRC hRF η hηδ t
+      ht htη
+  let eW : C(CuspRetraction.QuotientCentralFibre C δ, CuspRetraction.QuotientCentralFibre C r) :=
+    (CuspCentralHomology.centralRadiusHomeomorph C r δ hδr hC hδ :
+      C(CuspRetraction.QuotientCentralFibre C δ, CuspRetraction.QuotientCentralFibre C r))
+  let eF := CuspCentralHomology.fibreRadiusHomeomorph C r δ t hδr hC htδ
+  let eP :
+    (ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2) ≃ₜ
+      CuspControlledRetraction.ActualQuotientFibre C r t :=
+    e.trans eF
+  have hleft : eW.comp (productCollapse C δ hδ) = productCollapse C r hr :=
+    CuspCentralHomology.centralRadiusHomeomorph_comp_productCollapse C r δ hδr hC hδ
+  have hright :
+    eW.comp
+        (f.comp
+          (e :
+            C(ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2,
+              CuspControlledRetraction.ActualQuotientFibre C δ t))) =
+      g.comp
+        (eP :
+          C(ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2,
+            CuspControlledRetraction.ActualQuotientFibre C r t)) := by
+    apply ContinuousMap.ext
+    intro x
+    exact
+      (CuspCentralHomology.prescribedActualFibreCollapse_radius C r δ hr hδ hδr hC hδ1 hRC hRF η
+          hηδ t ht htη (e x)).symm
+  have hp :
+    (productCollapse C r hr).Homotopic
+      (g.comp
+        (eP :
+          C(ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2,
+            CuspControlledRetraction.ActualQuotientFibre C r t))) := by
+    have h := (ContinuousMap.Homotopic.refl eW).comp hh
+    change
+      (eW.comp (productCollapse C δ hδ)).Homotopic
+        (eW.comp
+          (f.comp
+            (e :
+              C(ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2,
+                CuspControlledRetraction.ActualQuotientFibre C δ t)))) at h
+    rwa [hleft, hright] at h
+  have h :=
+    hp.comp
+      (ContinuousMap.Homotopic.refl
+        (sourceProductCoordinateHomeomorph.symm :
+          C(PeriodTorusHigherHomology.ProductTorus 4,
+            ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2)))
+  have hmarked :
+    (productCollapse C r hr).comp
+        (sourceProductCoordinateHomeomorph.symm :
+          C(PeriodTorusHigherHomology.ProductTorus 4,
+            ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2)) =
+      markedCollapse C r hr :=
+    (markedCollapse_eq_product C r hr).symm
+  have hend :
+    (g.comp
+            (eP :
+              C(ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2,
+                CuspControlledRetraction.ActualQuotientFibre C r t))).comp
+        (sourceProductCoordinateHomeomorph.symm :
+          C(PeriodTorusHigherHomology.ProductTorus 4,
+            ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2)) =
+      g.comp
+        (radiusMarkedHomeomorph C r δ t hδr hC htδ e :
+          C(PeriodTorusHigherHomology.ProductTorus 4,
+            CuspControlledRetraction.ActualQuotientFibre C r t)) := by
+    apply ContinuousMap.ext
+    intro x
+    rfl
+  rwa [hmarked, hend] at h
+
+private theorem
+    CuspSpecialization.radiusMarkedHomeomorph_homology (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (r δ : ℝ) (hr : 0 < r) (hδ : 0 < δ) (hδr : δ ≤ r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (hδ1 : δ < 1)
+    (hRC : ToricSpace.SmallDrift C δ) (hRF : ToricSpace.SmallDrift (CuspRetraction.frozen C) δ)
+    (t : ℂ) (ht : t ≠ 0) (htδ : ‖t‖ < δ)
+    (e :
+      (ToricSpace.CompactFibreTorus × PeriodTorusHigherHomology.ProductTorus 2) ≃ₜ
+        CuspControlledRetraction.ActualQuotientFibre C δ t)
+    (he : IsPrescribedProductModel C δ hδ t ht e) (η : ℝ) (hηδ : η < δ) (htη : ‖t‖ ≤ η) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) n) :
+    SingularMayerVietoris.singularHomologyMap
+        (CuspCentralHomology.smallRadiusActualFibreCollapseMap C r δ hr hδ hδr hC hδ1 hRC hRF η
+          hηδ t ht htη)
+        n
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+          (radiusMarkedHomeomorph C r δ t hδr hC htδ e) n a) =
+      SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) n a := by
+  have h :=
+    PeriodTorusHigherHomology.homotopic_homologyMap
+      (radiusMarkedHomeomorph_homotopic C r δ hr hδ hδr hC hδ1 hRC hRF t ht htδ e he η hηδ htη) n
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp] at h
+  exact (LinearMap.congr_fun h a).symm
+
+private theorem CuspSpecialization.exists_original_marked_model_of_smallRadius
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r δ : ℝ) (hr : 0 < r) (hδ : 0 < δ) (hδr : δ ≤ r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) (hδ1 : δ < 1)
+    (hRC : ToricSpace.SmallDrift C δ) (hRF : ToricSpace.SmallDrift (CuspRetraction.frozen C) δ)
+    (t : ℂ) (ht : t ≠ 0) (htδ : ‖t‖ < δ) :
+    ∃ E :
+      PeriodTorusHigherHomology.ProductTorus 4 ≃ₜ
+        CuspControlledRetraction.ActualQuotientFibre C r t,
+      ∀ (η : ℝ) (hηδ : η < δ) (htη : ‖t‖ ≤ η),
+        (markedCollapse C r hr).Homotopic
+            ((CuspCentralHomology.smallRadiusActualFibreCollapseMap C r δ hr hδ hδr hC hδ1 hRC hRF
+                  η hηδ t ht htη).comp
+              (E :
+                C(PeriodTorusHigherHomology.ProductTorus 4,
+                  CuspControlledRetraction.ActualQuotientFibre C r t))) ∧
+          ∀ (n : ℕ)
+            (a :
+              SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4)
+                n),
+            SingularMayerVietoris.singularHomologyMap
+                (CuspCentralHomology.smallRadiusActualFibreCollapseMap C r δ hr hδ hδr hC hδ1 hRC
+                  hRF η hηδ t ht htη)
+                n (PeriodTorusHigherHomology.homeomorphHomologyEquiv E n a) =
+              SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) n a := by
+  have hCδ (i j) : ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 δ) :=
+    (hC i j).mono (Metric.ball_subset_ball hδr)
+  obtain ⟨e, he⟩ := exists_product_model_at_nonzero_level C δ hδ hδ1 hCδ hRC hRF t ht htδ
+  refine ⟨radiusMarkedHomeomorph C r δ t hδr hC htδ e, ?_⟩
+  intro η hηδ htη
+  exact
+    ⟨radiusMarkedHomeomorph_homotopic C r δ hr hδ hδr hC hδ1 hRC hRF t ht htδ e he η hηδ htη,
+      radiusMarkedHomeomorph_homology C r δ hr hδ hδr hC hδ1 hRC hRF t ht htδ e he η hηδ htη⟩
+
+private theorem CuspSpecialization.exists_original_marked_specialization_models
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (hr : 0 < r)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    ∃ (η₀ : ℝ) (_hη₀ : 0 < η₀),
+      η₀ < r ∧
+        η₀ < 1 ∧
+          ∀ (t : ℂ) (ht : t ≠ 0),
+            ‖t‖ ≤ η₀ →
+              ∃ E :
+                PeriodTorusHigherHomology.ProductTorus 4 ≃ₜ
+                  CuspControlledRetraction.ActualQuotientFibre C r t,
+                ∀ (η : ℝ) (_hη : η ≤ η₀) (htη : ‖t‖ ≤ η) (hηr : η < r),
+                  ∃ hc :
+                    Continuous
+                      (CuspControlledRetraction.prescribedActualFibreCollapse C r hr hηr t ht
+                        htη),
+                    (markedCollapse C r hr).Homotopic
+                        ((⟨CuspControlledRetraction.prescribedActualFibreCollapse C r hr hηr t ht
+                                  htη,
+                                hc⟩ :
+                              C(CuspControlledRetraction.ActualQuotientFibre C r t,
+                                CuspRetraction.QuotientCentralFibre C r)).comp
+                          (E :
+                            C(PeriodTorusHigherHomology.ProductTorus 4,
+                              CuspControlledRetraction.ActualQuotientFibre C r t))) ∧
+                      ∀ (n : ℕ)
+                        (a :
+                          SingularMayerVietoris.SingularHomology
+                            (PeriodTorusHigherHomology.ProductTorus 4) n),
+                        SingularMayerVietoris.singularHomologyMap
+                            (⟨CuspControlledRetraction.prescribedActualFibreCollapse C r hr hηr t
+                                  ht htη,
+                                hc⟩ :
+                              C(CuspControlledRetraction.ActualQuotientFibre C r t,
+                                CuspRetraction.QuotientCentralFibre C r))
+                            n (PeriodTorusHigherHomology.homeomorphHomologyEquiv E n a) =
+                          SingularMayerVietoris.singularHomologyMap (markedCollapse C r hr) n a :=
+  by
+  obtain ⟨δ, hδ, hδr, hδ1, hRC, hRF⟩ :=
+    CuspRetraction.exists_common_frozen_radius C hr (fun i j => (hC i j).continuousOn)
+  let η₀ : ℝ := δ / 2
+  have hη₀ : 0 < η₀ := half_pos hδ
+  have hη₀δ : η₀ < δ := half_lt_self hδ
+  refine ⟨η₀, hη₀, hη₀δ.trans hδr, hη₀δ.trans hδ1, ?_⟩
+  intro t ht ht₀
+  have htδ : ‖t‖ < δ := ht₀.trans_lt hη₀δ
+  obtain ⟨E, hE⟩ :=
+    exists_original_marked_model_of_smallRadius C r δ hr hδ hδr.le hC hδ1 hRC hRF t ht htδ
+  refine ⟨E, ?_⟩
+  intro η hη htη hηr
+  have hηδ : η < δ := hη.trans_lt hη₀δ
+  let f :=
+    CuspCentralHomology.smallRadiusActualFibreCollapseMap C r δ hr hδ hδr.le hC hδ1 hRC hRF η hηδ
+      t ht htη
+  refine ⟨f.continuous, ?_, ?_⟩
+  · exact (hE η hηδ htη).1
+  · exact (hE η hηδ htη).2
+
+private def CuspSpecialization.coordinateTorusH1Coordinates :
+    SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 1 ≃ₗ[ℤ]
+      (Fin 4 → ℤ) :=
+  (PeriodTorusHigherHomology.coordinateH1FourEquiv (Elliptic.examplePeriod .four)).symm
+
+@[simp]
+private theorem CuspSpecialization.coordinateTorusH1Coordinates_coordinateH1 (v : Fin 4 → ℤ) :
+    coordinateTorusH1Coordinates (PeriodTorusHigherHomology.coordinateH1 4 v) = v :=
+  (PeriodTorusHigherHomology.coordinateH1FourEquiv
+        (Elliptic.examplePeriod .four)).symm_apply_apply
+    v
+
+private theorem CuspSpecialization.coordinateTorusH1Coordinates_matrix (A : LatticeMatrix)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 1) :
+    coordinateTorusH1Coordinates
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap A) 1
+          a) =
+      A *ᵥ coordinateTorusH1Coordinates a := by
+  obtain ⟨v, hv⟩ :=
+    (PeriodTorusHigherHomology.coordinateH1FourEquiv (Elliptic.examplePeriod .four)).surjective a
+  change PeriodTorusHigherHomology.coordinateH1 4 v = a at hv
+  rw [← hv, SingularMayerVietoris.singularHomologyMap_one,
+    PeriodTorusHigherHomology.coordinateH1_matrix_natural (Elliptic.examplePeriod .four),
+    coordinateTorusH1Coordinates_coordinateH1, coordinateTorusH1Coordinates_coordinateH1]
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Elliptic/Core1.lean b/LeanPool/HopfProblem/Elliptic/Core1.lean
new file mode 100644
index 000000000..9d28b80ec
--- /dev/null
+++ b/LeanPool/HopfProblem/Elliptic/Core1.lean
@@ -0,0 +1,659 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Lattice.Core2
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap1
+import all LeanPool.HopfProblem.Lattice.Core2
+
+/-!
+# Hopf problem: elliptic · core 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+/-- The two elliptic fibre types, distinguished by monodromy order three or four. -/
+public
+inductive Elliptic.Kind where
+  | three
+  | four
+  deriving DecidableEq
+
+private instance Elliptic.instLocal1 : Fintype Kind :=
+  ⟨{.three, .four}, by intro j; cases j <;> simp⟩
+
+private def Elliptic.Kind.order : Elliptic.Kind → ℕ
+  | .three => 3
+  | .four => 4
+
+private def Elliptic.Kind.matrix : Elliptic.Kind → LatticeMatrix
+  | .three => A₁
+  | .four => A₂
+
+private def Elliptic.Kind.twist : Elliptic.Kind → Lattice
+  | .three => ε
+  | .four => -ε'
+
+private theorem Elliptic.Kind.order_pos (j : Elliptic.Kind) : 0 < j.order := by cases j <;> decide
+
+private theorem Elliptic.Kind.matrix_pow_order (j : Elliptic.Kind) : j.matrix ^ j.order = 1 := by
+  cases j <;> decide
+
+private theorem
+    Elliptic.Kind.matrix_fixes_twist (j : Elliptic.Kind) : j.matrix *ᵥ j.twist = j.twist := by
+  cases j <;> decide
+
+private def Elliptic.realCast (v : Lattice) : RealPlane₄ := fun i => (v i : ℝ)
+
+private def Elliptic.flatLinear (j : Kind) : RealPlane₄ →ₗ[ℝ] RealPlane₄ :=
+  (j.matrix.map (Int.castRingHom ℝ)).mulVecLin
+
+private def Elliptic.flatAffine (j : Kind) (v : Lattice) (x : RealPlane₄) : RealPlane₄ :=
+  flatLinear j x + (1 / (j.order : ℝ)) • realCast v
+
+private def Elliptic.FlatCongruent (x y : RealPlane₄) : Prop :=
+  ∃ v : Lattice, x - y = realCast v
+
+private def Elliptic.AdmissibleTwist (j : Kind) (v : Lattice) : Prop :=
+  j.matrix *ᵥ v = v ∧ if j = .three then ¬3 ∣ γ v else Odd (γ v)
+
+private theorem Elliptic.mainTwist_admissible (j : Kind) : AdmissibleTwist j j.twist := by
+  refine ⟨j.matrix_fixes_twist, ?_⟩
+  cases j <;> norm_num [Kind.twist, γ, ε, ε']
+
+private def Elliptic.periodEquiv (p : PeriodDomain) : RealPlane₄ ≃L[ℝ] ComplexPlane₂ :=
+  p.basis.equivFun.symm.toContinuousLinearEquiv
+
+private theorem Elliptic.periodEquiv_apply (p : PeriodDomain) (x : RealPlane₄) :
+    periodEquiv p x = ∑ i, x i • p.basis i :=
+  p.basis.equivFun_symm_apply x
+
+private theorem Elliptic.periodEquiv_matrix (p : PeriodDomain) (x : RealPlane₄) :
+    periodEquiv p x = p.val.matrix *ᵥ (fun i => (x i : ℂ)) := by
+  rw [periodEquiv_apply]
+  ext i
+  simp only [Finset.sum_apply, Pi.smul_apply, PeriodDomain.basis_apply, Matrix.mulVec, dotProduct]
+  apply Finset.sum_congr rfl
+  intro k _
+  change (x k : ℂ) * p.val.matrix i k = p.val.matrix i k * (x k : ℂ)
+  exact mul_comm _ _
+
+private theorem Elliptic.periodEquiv_realCast (p : PeriodDomain) (v : Lattice) :
+    periodEquiv p (realCast v) = ∑ i, v i • p.basis i := by
+  rw [periodEquiv_apply]
+  simp only [realCast, Int.cast_smul_eq_zsmul]
+
+private theorem Elliptic.periodEquiv_mem_lattice_iff (p : PeriodDomain) (x : RealPlane₄) :
+    periodEquiv p x ∈ p.lattice ↔ ∃ v : Lattice, x = realCast v := by
+  rw [p.lattice_eq_span_basis, Submodule.mem_span_range_iff_exists_fun]
+  constructor
+  · rintro ⟨v, hv⟩
+    refine ⟨v, (periodEquiv p).injective ?_⟩
+    rw [periodEquiv_realCast]
+    exact hv.symm
+  · rintro ⟨v, rfl⟩
+    exact ⟨v, (periodEquiv_realCast p v).symm⟩
+
+private def Elliptic.flatProjection (p : PeriodDomain) (x : RealPlane₄) : p.Torus :=
+  p.lattice.mkQ (periodEquiv p x)
+
+private theorem
+    Elliptic.flatProjection_continuous (p : PeriodDomain) : Continuous (flatProjection p) :=
+  p.lattice.continuous_mkQ.comp (periodEquiv p).continuous
+
+private theorem Elliptic.flatProjection_surjective (p : PeriodDomain) :
+    Function.Surjective (flatProjection p) :=
+  p.lattice.mkQ_surjective.comp (periodEquiv p).surjective
+
+private theorem Elliptic.flatProjection_eq_iff (p : PeriodDomain) (x y : RealPlane₄) :
+    flatProjection p x = flatProjection p y ↔ FlatCongruent x y := by
+  change
+    (Submodule.Quotient.mk (periodEquiv p x) : p.Torus) =
+        Submodule.Quotient.mk (periodEquiv p y) ↔
+      _
+  rw [Submodule.Quotient.eq, ← map_sub, periodEquiv_mem_lattice_iff]
+  rfl
+
+@[simp]
+private theorem Elliptic.flatProjection_add (p : PeriodDomain) (x y : RealPlane₄) :
+    flatProjection p (x + y) = flatProjection p x + flatProjection p y := by
+  simp only [flatProjection, map_add]
+
+@[simp]
+private theorem Elliptic.flatProjection_realCast (p : PeriodDomain) (v : Lattice) :
+    flatProjection p (realCast v) = 0 := by
+  apply (Submodule.Quotient.mk_eq_zero p.lattice).mpr
+  exact (periodEquiv_mem_lattice_iff p _).mpr ⟨v, rfl⟩
+
+private theorem Elliptic.flatLinear_realCast (j : Kind) (v : Lattice) :
+    flatLinear j (realCast v) = realCast (j.matrix *ᵥ v) := by
+  ext i
+  exact (RingHom.map_mulVec (Int.castRingHom ℝ) j.matrix v i).symm
+
+private theorem
+    Elliptic.flatLinear_fixes_realCast (j : Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    flatLinear j (realCast v) = realCast v := by rw [flatLinear_realCast, hv]
+
+private theorem
+    Elliptic.flatAffine_iterate (j : Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v) (r : ℕ)
+    (x : RealPlane₄) :
+    (flatAffine j v)^[r] x =
+      (j.matrix.map (Int.castRingHom ℝ)) ^ r *ᵥ x + ((r : ℝ) / (j.order : ℝ)) • realCast v := by
+  induction r with
+  | zero => simp
+  | succ r
+    ih =>
+    rw [Function.iterate_succ_apply', ih, flatAffine, map_add, map_smul,
+      flatLinear_fixes_realCast j v hv]
+    have hlin :
+      flatLinear j ((j.matrix.map (Int.castRingHom ℝ)) ^ r *ᵥ x) =
+        (j.matrix.map (Int.castRingHom ℝ)) ^ (r + 1) *ᵥ x := by
+      simp only [flatLinear, Matrix.mulVecLin_apply, Matrix.mulVec_mulVec, pow_succ']
+    rw [hlin, add_assoc, ← add_smul]
+    congr 2
+    push_cast
+    ring
+
+private theorem Elliptic.flatAffine_iterate_order (j : Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (x : RealPlane₄) : (flatAffine j v)^[j.order] x = x + realCast v := by
+  rw [flatAffine_iterate j v hv, ← Matrix.map_pow, j.matrix_pow_order]
+  have hm : (j.order : ℝ) ≠ 0 := by exact_mod_cast (Nat.ne_of_gt j.order_pos)
+  simp [hm]
+
+private theorem Elliptic.flatAffine_iterate_order_congruent (j : Kind) (v : Lattice)
+    (hv : j.matrix *ᵥ v = v) (x : RealPlane₄) :
+    FlatCongruent ((flatAffine j v)^[j.order] x) x := by
+  refine ⟨v, ?_⟩
+  rw [flatAffine_iterate_order j v hv]
+  abel
+
+@[simp]
+private theorem
+    Elliptic.flatLinear_gamma (j : Kind) (x : RealPlane₄) : flatLinear j x 0 = x 0 := by
+  cases j <;> simp [flatLinear, Kind.matrix, A₁, A₂, Matrix.mulVec, dotProduct, Fin.sum_univ_succ]
+
+private theorem
+    Elliptic.flatAffine_iterate_gamma (j : Kind) (v : Lattice) (r : ℕ) (x : RealPlane₄) :
+    (flatAffine j v)^[r] x 0 = x 0 + ((r : ℝ) / (j.order : ℝ)) * (γ v : ℝ) := by
+  induction r with
+  | zero => simp
+  | succ r ih =>
+    rw [Function.iterate_succ_apply']
+    change flatLinear j ((flatAffine j v)^[r] x) 0 + (1 / (j.order : ℝ)) * (γ v : ℝ) = _
+    rw [flatLinear_gamma, ih]
+    push_cast
+    ring
+
+private theorem Elliptic.flatAffine_iterate_not_congruent (j : Kind) (v : Lattice)
+    (hv : AdmissibleTwist j v) (r : ℕ) (hr : 0 < r) (hrm : r < j.order) (x : RealPlane₄) :
+    ¬FlatCongruent ((flatAffine j v)^[r] x) x := by
+  rintro ⟨w, hw⟩
+  have hgamma := congrFun hw 0
+  change (flatAffine j v)^[r] x 0 - x 0 = (w 0 : ℝ) at hgamma
+  rw [flatAffine_iterate_gamma] at hgamma
+  have hm : (j.order : ℝ) ≠ 0 := by exact_mod_cast (Nat.ne_of_gt j.order_pos)
+  have hreal : (r : ℝ) * (γ v : ℝ) = (j.order : ℝ) * (w 0 : ℝ) := by
+    field_simp at hgamma
+    nlinarith
+  have hint : (r : ℤ) * γ v = (j.order : ℤ) * w 0 := by exact_mod_cast hreal
+  cases j with
+  | three =>
+    have ha : ¬3 ∣ γ v := by simpa [AdmissibleTwist] using hv.2
+    change r < 3 at hrm
+    change (r : ℤ) * γ v = 3 * w 0 at hint
+    interval_cases r <;> norm_num at hint <;> omega
+  | four =>
+    have ha : Odd (γ v) := by simpa [AdmissibleTwist] using hv.2
+    rcases ha with ⟨a, ha⟩
+    change r < 4 at hrm
+    change (r : ℤ) * γ v = 4 * w 0 at hint
+    interval_cases r <;> norm_num at hint <;> omega
+
+private theorem Elliptic.bad_three_twist_has_fixed_point (v : Lattice) (hv : A₁ *ᵥ v = v)
+    (ha : (3 : ℤ) ∣ γ v) : ∃ x : RealPlane₄, FlatCongruent (flatAffine .three v x) x := by
+  obtain ⟨h₁, h₂⟩ := (A₁_fixed_iff v).mp hv
+  obtain ⟨m, hm⟩ := ha
+  have hm' : (v 0 : ℝ) = 3 * (m : ℝ) := by exact_mod_cast hm
+  refine ⟨![0, -(v 3 : ℝ) / 3, -((v 3 : ℝ) + 2 * (v 0 : ℝ)) / 3, 0], ![m, 0, v 3, 0], ?_⟩
+  ext i
+  fin_cases i <;>
+      simp [flatAffine, flatLinear, Kind.matrix, Kind.order, A₁, Matrix.mulVec, dotProduct,
+        Fin.sum_univ_succ, realCast, h₁, h₂, hm'] <;>
+    ring
+
+private theorem Elliptic.bad_four_twist_has_square_fixed_point (v : Lattice) (hv : A₂ *ᵥ v = v)
+    (ha : Even (γ v)) : ∃ x : RealPlane₄, FlatCongruent ((flatAffine .four v)^[2] x) x := by
+  obtain ⟨h₁, h₂⟩ := (A₂_fixed_iff v).mp hv
+  obtain ⟨m, hm⟩ := ha
+  have hm' : (v 0 : ℝ) = 2 * (m : ℝ) := by
+    change v 0 = m + m at hm
+    exact_mod_cast (show v 0 = 2 * m by omega)
+  refine ⟨![0, 3 * (v 0 : ℝ) / 4, -3 * (v 0 : ℝ) / 4 - (v 3 : ℝ) / 2, 0], ![m, 0, v 3, 0], ?_⟩
+  ext i
+  fin_cases i <;>
+      simp [Function.iterate_succ_apply, flatAffine, flatLinear, Kind.matrix, Kind.order, A₂,
+        Matrix.mulVec, dotProduct, Fin.sum_univ_succ, realCast, h₁, h₂, hm'] <;>
+    ring
+
+private theorem Elliptic.flatAffine_free_iff (j : Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    (∀ r : ℕ,
+        0 < r → r < j.order → ∀ x : RealPlane₄, ¬FlatCongruent ((flatAffine j v)^[r] x) x) ↔
+      AdmissibleTwist j v := by
+  constructor
+  · intro hfree
+    refine ⟨hv, ?_⟩
+    cases j with
+    | three =>
+      change ¬3 ∣ γ v
+      intro ha
+      obtain ⟨x, hx⟩ := bad_three_twist_has_fixed_point v hv ha
+      exact hfree 1 (by decide) (by decide) x (by simpa using hx)
+    | four =>
+      change Odd (γ v)
+      apply Int.not_even_iff_odd.mp
+      intro ha
+      obtain ⟨x, hx⟩ := bad_four_twist_has_square_fixed_point v hv ha
+      exact hfree 2 (by decide) (by decide) x hx
+  · intro ha r hr hrm x
+    exact flatAffine_iterate_not_congruent j v ha r hr hrm x
+
+private def Elliptic.periodStep (j : Kind) (p : PeriodDomain) : PeriodDomain :=
+  match j with
+  | .three => p.step₁
+  | .four => p.step₂
+
+private abbrev Elliptic.FixedPeriod (j : Kind) :=
+  { p : PeriodDomain // periodStep j p = p }
+
+private def Elliptic.examplePeriodPoint : Kind → PeriodPoint
+  | .three =>
+    ⟨(1 + Complex.I * (Real.sqrt 3 : ℂ)) / 2, (1 : ℂ) / 2 - Complex.I * (Real.sqrt 3 : ℂ) / 6,
+      -Complex.I⟩
+  | .four => ⟨Complex.I, (1 - Complex.I) / 2, -Complex.I⟩
+
+private theorem
+    Elliptic.examplePeriodPoint_tau_im_pos (j : Kind) : 0 < (examplePeriodPoint j).τ.im := by
+  cases j
+  · simp only [examplePeriodPoint, Complex.div_ofNat_im, Complex.add_im, Complex.one_im,
+      Complex.mul_im, Complex.I_re, Complex.I_im, Complex.ofReal_re, Complex.ofReal_im,
+      MulZeroClass.zero_mul, one_mul, zero_add]
+    positivity
+  · norm_num [examplePeriodPoint]
+
+@[simp]
+private theorem
+    Elliptic.examplePeriodPoint_beta_im (j : Kind) : (examplePeriodPoint j).β.im = -1 := by
+  cases j <;> norm_num [examplePeriodPoint]
+
+private theorem
+    Elliptic.examplePeriodPoint_admissible (j : Kind) : (examplePeriodPoint j).Admissible := by
+  refine ⟨examplePeriodPoint_tau_im_pos j, ?_⟩
+  have hn : 0 ≤ 6 * (examplePeriodPoint j).μ.im ^ 2 / (examplePeriodPoint j).τ.im :=
+    div_nonneg (mul_nonneg (by norm_num) (sq_nonneg _)) (examplePeriodPoint_tau_im_pos j).le
+  rw [PeriodPoint.discriminant, examplePeriodPoint_beta_im]
+  linarith
+
+private def Elliptic.examplePeriod (j : Kind) : PeriodDomain :=
+  ⟨examplePeriodPoint j, examplePeriodPoint_admissible j⟩
+
+private theorem Elliptic.examplePeriodPoint_three_fixed :
+    (examplePeriodPoint .three).step₁ = examplePeriodPoint .three := by
+  have hs : (Real.sqrt 3 : ℂ) ^ 2 = 3 := by
+    norm_cast
+    exact Real.sq_sqrt (by norm_num)
+  have ht : 1 + Complex.I * (Real.sqrt 3 : ℂ) ≠ 0 := by
+    intro h
+    have h' := congrArg Complex.re h
+    norm_num at h'
+  apply PeriodPoint.ext <;> dsimp [examplePeriodPoint, PeriodPoint.step₁] <;> field_simp [ht] <;>
+        ring_nf <;>
+      simp [Complex.I_sq, hs] <;>
+    ring
+
+private theorem Elliptic.examplePeriodPoint_four_fixed :
+    (examplePeriodPoint .four).step₂ = examplePeriodPoint .four := by
+  apply PeriodPoint.ext <;> apply Complex.ext <;>
+    norm_num [examplePeriodPoint, PeriodPoint.step₂, Complex.div_re, Complex.div_im,
+      Complex.mul_re, Complex.mul_im, Complex.normSq_apply, pow_two]
+
+private theorem Elliptic.examplePeriod_fixed (j : Kind) :
+    periodStep j (examplePeriod j) = examplePeriod j := by
+  cases j
+  · exact Subtype.ext examplePeriodPoint_three_fixed
+  · exact Subtype.ext examplePeriodPoint_four_fixed
+
+private def Elliptic.exampleFixedPeriod (j : Kind) : FixedPeriod j :=
+  ⟨examplePeriod j, examplePeriod_fixed j⟩
+
+private def Elliptic.linearMatrix (j : Kind) (p : PeriodDomain) : Matrix (Fin 2) (Fin 2) ℂ :=
+  match j with
+  | .three => p.val.R₁
+  | .four => p.val.R₂
+
+private def
+    Elliptic.linearEquiv (j : Kind) (p : FixedPeriod j) : ComplexPlane₂ ≃L[ℂ] ComplexPlane₂ :=
+  match j with
+  | .three => p.val.R₁Equiv
+  | .four => p.val.R₂Equiv
+
+private theorem Elliptic.linearEquiv_apply (j : Kind) (p : FixedPeriod j) (z : ComplexPlane₂) :
+    linearEquiv j p z = linearMatrix j p.val *ᵥ z := by
+  cases j
+  · exact p.val.R₁Equiv_apply z
+  · exact p.val.R₂Equiv_apply z
+
+private theorem Elliptic.linearEquiv_map_lattice (j : Kind) (p : FixedPeriod j) :
+    p.val.lattice.map ((linearEquiv j p).toLinearEquiv.restrictScalars ℤ).toLinearMap =
+      p.val.lattice := by
+  cases j
+  · exact p.val.R₁Equiv_map_lattice.trans (congrArg PeriodDomain.lattice p.property)
+  · exact p.val.R₂Equiv_map_lattice.trans (congrArg PeriodDomain.lattice p.property)
+
+private theorem Elliptic.linearMatrix_period_matrix (j : Kind) (p : FixedPeriod j) :
+    linearMatrix j p.val * p.val.val.matrix =
+      p.val.val.matrix * j.matrix.map (Int.castRingHom ℂ) := by
+  cases j
+  · have hp : p.val.val.step₁ = p.val.val := congrArg Subtype.val p.property
+    have hm := p.val.val.step₁_matrix (p.val.val.τ_ne_zero p.val.property.1)
+    rw [hp] at hm
+    have hTA : (T₁.map (Int.castRingHom ℂ)).transpose * A₁.map (Int.castRingHom ℂ) = 1 := by
+      have h : T₁.transpose * A₁ = 1 := by decide
+      simpa only [Matrix.map_mul, Matrix.transpose_map, Matrix.map_one, map_zero, map_one] using
+        congrArg (fun A : LatticeMatrix => A.map (Int.castRingHom ℂ)) h
+    simpa only [linearMatrix, Kind.matrix, Matrix.mul_assoc, hTA, Matrix.mul_one] using
+      (congrArg (fun A => A * A₁.map (Int.castRingHom ℂ)) hm).symm
+  · have hp : p.val.val.step₂ = p.val.val := congrArg Subtype.val p.property
+    have hm := p.val.val.step₂_matrix (p.val.val.τ_ne_zero p.val.property.1)
+    rw [hp] at hm
+    have hTA : (T₂.map (Int.castRingHom ℂ)).transpose * A₂.map (Int.castRingHom ℂ) = 1 := by
+      have h : T₂.transpose * A₂ = 1 := by decide
+      simpa only [Matrix.map_mul, Matrix.transpose_map, Matrix.map_one, map_zero, map_one] using
+        congrArg (fun A : LatticeMatrix => A.map (Int.castRingHom ℂ)) h
+    simpa only [linearMatrix, Kind.matrix, Matrix.mul_assoc, hTA, Matrix.mul_one] using
+      (congrArg (fun A => A * A₂.map (Int.castRingHom ℂ)) hm).symm
+
+private theorem Elliptic.flatLinear_complexCast (j : Kind) (x : RealPlane₄) :
+    (fun i => ((flatLinear j x) i : ℂ)) =
+      (j.matrix.map (Int.castRingHom ℂ)) *ᵥ (fun i => (x i : ℂ)) := by
+  ext i
+  simp [flatLinear, Matrix.mulVec, dotProduct]
+
+private theorem
+    Elliptic.linearEquiv_periodEquiv (j : Kind) (p : FixedPeriod j) (x : RealPlane₄) :
+    linearEquiv j p (periodEquiv p.val x) = periodEquiv p.val (flatLinear j x) := by
+  rw [linearEquiv_apply, periodEquiv_matrix, periodEquiv_matrix, flatLinear_complexCast,
+    Matrix.mulVec_mulVec, Matrix.mulVec_mulVec, linearMatrix_period_matrix]
+
+private def Elliptic.linearBiholomorph (j : Kind) (p : FixedPeriod j) :
+    Diffeomorph (modelWithCornersSelf ℂ ComplexPlane₂) (modelWithCornersSelf ℂ ComplexPlane₂)
+      p.val.Torus p.val.Torus ω :=
+  DiscreteQuotient.linearBiholomorph p.val.lattice p.val.lattice (linearEquiv j p)
+    (linearEquiv_map_lattice j p)
+
+private theorem Elliptic.linearBiholomorph_mkQ (j : Kind) (p : FixedPeriod j) (z : ComplexPlane₂) :
+    linearBiholomorph j p (p.val.lattice.mkQ z) = p.val.lattice.mkQ (linearEquiv j p z) :=
+  rfl
+
+private theorem Elliptic.linearBiholomorph_flatProjection (j : Kind) (p : FixedPeriod j)
+    (x : RealPlane₄) :
+    linearBiholomorph j p (flatProjection p.val x) = flatProjection p.val (flatLinear j x) := by
+  change linearBiholomorph j p (p.val.lattice.mkQ (periodEquiv p.val x)) = _
+  rw [linearBiholomorph_mkQ, linearEquiv_periodEquiv]
+  rfl
+
+private def Elliptic.torusTranslation (p : PeriodDomain) (a : p.Torus) :
+    Diffeomorph (modelWithCornersSelf ℂ ComplexPlane₂) (modelWithCornersSelf ℂ ComplexPlane₂)
+      p.Torus p.Torus ω
+    where
+  toFun x := x + a
+  invFun x := x - a
+  left_inv x := add_sub_cancel_right x a
+  right_inv x := sub_add_cancel x a
+  contMDiff_toFun := contMDiff_id.add contMDiff_const
+  contMDiff_invFun := contMDiff_id.sub contMDiff_const
+
+private def Elliptic.affineBiholomorph (j : Kind) (p : FixedPeriod j) (v : Lattice) :
+    Diffeomorph (modelWithCornersSelf ℂ ComplexPlane₂) (modelWithCornersSelf ℂ ComplexPlane₂)
+      p.val.Torus p.val.Torus ω :=
+  (linearBiholomorph j p).trans
+    (torusTranslation p.val (flatProjection p.val ((1 / (j.order : ℝ)) • realCast v)))
+
+private theorem Elliptic.affineBiholomorph_apply (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (x : p.val.Torus) :
+    affineBiholomorph j p v x =
+      linearBiholomorph j p x + flatProjection p.val ((1 / (j.order : ℝ)) • realCast v) :=
+  rfl
+
+private theorem
+    Elliptic.affineBiholomorph_flatProjection (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (x : RealPlane₄) :
+    affineBiholomorph j p v (flatProjection p.val x) = flatProjection p.val (flatAffine j v x) := by
+  rw [affineBiholomorph_apply, linearBiholomorph_flatProjection, flatAffine, flatProjection_add]
+
+private theorem Elliptic.affineBiholomorph_iterate_flatProjection (j : Kind) (p : FixedPeriod j)
+    (v : Lattice) (r : ℕ) (x : RealPlane₄) :
+    (affineBiholomorph j p v)^[r] (flatProjection p.val x) =
+      flatProjection p.val ((flatAffine j v)^[r] x) := by
+  induction r with
+  | zero => rfl
+  | succ r ih =>
+    rw [Function.iterate_succ_apply', Function.iterate_succ_apply', ih,
+      affineBiholomorph_flatProjection]
+
+private def Elliptic.affinePermutation (j : Kind) (p : FixedPeriod j) (v : Lattice) :
+    Equiv.Perm p.val.Torus :=
+  (affineBiholomorph j p v).toEquiv
+
+private theorem
+    Elliptic.affinePermutation_pow_flatProjection (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (r : ℕ) (x : RealPlane₄) :
+    (affinePermutation j p v ^ r) (flatProjection p.val x) =
+      flatProjection p.val ((flatAffine j v)^[r] x) := by
+  rw [Equiv.Perm.coe_pow]
+  exact affineBiholomorph_iterate_flatProjection j p v r x
+
+private theorem Elliptic.affinePermutation_pow_order (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : j.matrix *ᵥ v = v) : affinePermutation j p v ^ j.order = 1 := by
+  apply Equiv.ext
+  intro y
+  obtain ⟨x, rfl⟩ := flatProjection_surjective p.val y
+  change (affinePermutation j p v ^ j.order) (flatProjection p.val x) = flatProjection p.val x
+  rw [affinePermutation_pow_flatProjection]
+  exact (flatProjection_eq_iff p.val _ _).mpr (flatAffine_iterate_order_congruent j v hv x)
+
+private theorem Elliptic.affinePermutation_pow_ne (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) (r : ℕ) (hr : 0 < r) (hrm : r < j.order) (y : p.val.Torus) :
+    (affinePermutation j p v ^ r) y ≠ y := by
+  obtain ⟨x, rfl⟩ := flatProjection_surjective p.val y
+  rw [affinePermutation_pow_flatProjection]
+  exact fun h =>
+    flatAffine_iterate_not_congruent j v hv r hr hrm x ((flatProjection_eq_iff p.val _ _).mp h)
+
+private theorem Elliptic.affinePermutation_free_iff (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : j.matrix *ᵥ v = v) :
+    (∀ r, 0 < r → r < j.order → ∀ y : p.val.Torus, (affinePermutation j p v ^ r) y ≠ y) ↔
+      AdmissibleTwist j v := by
+  constructor
+  · intro h
+    apply (flatAffine_free_iff j v hv).mp
+    intro r hr hrm x hx
+    apply h r hr hrm (flatProjection p.val x)
+    rw [affinePermutation_pow_flatProjection]
+    exact (flatProjection_eq_iff p.val _ _).mpr hx
+  · intro ha
+    exact affinePermutation_pow_ne j p v ha
+
+private theorem Elliptic.sum_zsmul_basisFun_mo1973_9836 (v : Lattice) :
+    (∑ i, v i • Pi.basisFun ℝ (Fin 4) i) = realCast v := by
+  ext k
+  simp [Pi.basisFun_apply, realCast, Pi.single_apply]
+
+private theorem Elliptic.standardLattice_mem_iff (x : RealPlane₄) :
+    x ∈ standardLattice ↔ ∃ v : Lattice, x = realCast v := by
+  rw [standardLattice, Submodule.mem_span_range_iff_exists_fun]
+  constructor
+  · rintro ⟨v, hv⟩
+    exact ⟨v, hv.symm.trans (sum_zsmul_basisFun_mo1973_9836 v)⟩
+  · rintro ⟨v, rfl⟩
+    exact ⟨v, sum_zsmul_basisFun_mo1973_9836 v⟩
+
+private theorem Elliptic.flatTorus_mkQ_eq_iff (x y : RealPlane₄) :
+    standardLattice.mkQ x = standardLattice.mkQ y ↔ FlatCongruent x y := by
+  change (Submodule.Quotient.mk x : RealTorus₄) = Submodule.Quotient.mk y ↔ _
+  rw [Submodule.Quotient.eq, standardLattice_mem_iff]
+  rfl
+
+private theorem Elliptic.periodEquiv_map_standardLattice (p : PeriodDomain) :
+    standardLattice.map ((periodEquiv p).toLinearEquiv.restrictScalars ℤ).toLinearMap =
+      p.lattice := by
+  ext z
+  rw [Submodule.mem_map]
+  constructor
+  · rintro ⟨x, hx, rfl⟩
+    exact (periodEquiv_mem_lattice_iff p x).mpr ((standardLattice_mem_iff x).mp hx)
+  · intro hz
+    refine ⟨(periodEquiv p).symm z, ?_, (periodEquiv p).apply_symm_apply z⟩
+    apply (standardLattice_mem_iff _).mpr
+    apply (periodEquiv_mem_lattice_iff p _).mp
+    simpa only [ContinuousLinearEquiv.apply_symm_apply] using hz
+
+private def Elliptic.flatTorusPeriodHomeomorph (p : PeriodDomain) : RealTorus₄ ≃ₜ p.Torus
+    where
+  toEquiv :=
+    (Submodule.Quotient.equiv standardLattice p.lattice
+        ((periodEquiv p).toLinearEquiv.restrictScalars ℤ)
+        (periodEquiv_map_standardLattice p)).toEquiv
+  continuous_toFun := by
+    apply standardLattice.isQuotientMap_mkQ.continuous_iff.mpr
+    exact p.lattice.continuous_mkQ.comp (periodEquiv p).continuous
+  continuous_invFun := by
+    apply p.lattice.isQuotientMap_mkQ.continuous_iff.mpr
+    exact standardLattice.continuous_mkQ.comp (periodEquiv p).symm.continuous
+
+private theorem Elliptic.flatTorusPeriodHomeomorph_mkQ (p : PeriodDomain) (x : RealPlane₄) :
+    flatTorusPeriodHomeomorph p (standardLattice.mkQ x) = flatProjection p x :=
+  rfl
+
+@[simp]
+private theorem Elliptic.flatTorusPeriodHomeomorph_symm_flatProjection (p : PeriodDomain)
+    (x : RealPlane₄) :
+    (flatTorusPeriodHomeomorph p).symm (flatProjection p x) = standardLattice.mkQ x := by
+  rw [← flatTorusPeriodHomeomorph_mkQ, Homeomorph.symm_apply_apply]
+
+private def Elliptic.flatTorusAffine (j : Kind) (v : Lattice) : RealTorus₄ ≃ₜ RealTorus₄ :=
+  ((flatTorusPeriodHomeomorph (exampleFixedPeriod j).val).trans
+        (affineBiholomorph j (exampleFixedPeriod j) v).toHomeomorph).trans
+    (flatTorusPeriodHomeomorph (exampleFixedPeriod j).val).symm
+
+private theorem Elliptic.flatTorusAffine_mkQ (j : Kind) (v : Lattice) (x : RealPlane₄) :
+    flatTorusAffine j v (standardLattice.mkQ x) = standardLattice.mkQ (flatAffine j v x) := by
+  change
+    (flatTorusPeriodHomeomorph (exampleFixedPeriod j).val).symm
+        (affineBiholomorph j (exampleFixedPeriod j) v
+          (flatTorusPeriodHomeomorph (exampleFixedPeriod j).val (standardLattice.mkQ x))) =
+      _
+  rw [flatTorusPeriodHomeomorph_mkQ, affineBiholomorph_flatProjection,
+    flatTorusPeriodHomeomorph_symm_flatProjection]
+
+private theorem
+    Elliptic.flatTorusAffine_periodHomeomorph (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (y : RealTorus₄) :
+    flatTorusPeriodHomeomorph p.val (flatTorusAffine j v y) =
+      affineBiholomorph j p v (flatTorusPeriodHomeomorph p.val y) := by
+  obtain ⟨x, rfl⟩ := standardLattice.mkQ_surjective y
+  rw [flatTorusAffine_mkQ, flatTorusPeriodHomeomorph_mkQ, flatTorusPeriodHomeomorph_mkQ,
+    affineBiholomorph_flatProjection]
+
+private theorem Elliptic.flatTorusAffine_iterate_mkQ (j : Kind) (v : Lattice) (r : ℕ)
+    (x : RealPlane₄) :
+    (flatTorusAffine j v)^[r] (standardLattice.mkQ x) =
+      standardLattice.mkQ ((flatAffine j v)^[r] x) := by
+  induction r with
+  | zero => rfl
+  | succ r ih =>
+    rw [Function.iterate_succ_apply', Function.iterate_succ_apply', ih, flatTorusAffine_mkQ]
+
+private theorem
+    Elliptic.flatTorusAffine_iterate_order (j : Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (y : RealTorus₄) : (flatTorusAffine j v)^[j.order] y = y := by
+  obtain ⟨x, rfl⟩ := standardLattice.mkQ_surjective y
+  rw [flatTorusAffine_iterate_mkQ]
+  exact (flatTorus_mkQ_eq_iff _ _).mpr (flatAffine_iterate_order_congruent j v hv x)
+
+private theorem
+    Elliptic.flatTorusAffine_iterate_ne (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v)
+    (r : ℕ) (hr : 0 < r) (hrm : r < j.order) (y : RealTorus₄) : (flatTorusAffine j v)^[r] y ≠ y :=
+  by
+  obtain ⟨x, rfl⟩ := standardLattice.mkQ_surjective y
+  rw [flatTorusAffine_iterate_mkQ]
+  exact fun h =>
+    flatAffine_iterate_not_congruent j v hv r hr hrm x ((flatTorus_mkQ_eq_iff _ _).mp h)
+
+private def Elliptic.flatTorusPermutation (j : Kind) (v : Lattice) : Equiv.Perm RealTorus₄ :=
+  (flatTorusAffine j v).toEquiv
+
+private theorem Elliptic.flatTorusPermutation_pow_mkQ (j : Kind) (v : Lattice) (r : ℕ)
+    (x : RealPlane₄) :
+    (flatTorusPermutation j v ^ r) (standardLattice.mkQ x) =
+      standardLattice.mkQ ((flatAffine j v)^[r] x) := by
+  rw [Equiv.Perm.coe_pow]
+  exact flatTorusAffine_iterate_mkQ j v r x
+
+private theorem Elliptic.flatTorusPermutation_pow_order (j : Kind) (v : Lattice)
+    (hv : j.matrix *ᵥ v = v) : flatTorusPermutation j v ^ j.order = 1 := by
+  apply Equiv.ext
+  intro y
+  rw [Equiv.Perm.coe_pow]
+  exact flatTorusAffine_iterate_order j v hv y
+
+private theorem
+    Elliptic.flatTorusPermutation_pow_ne (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v)
+    (r : ℕ) (hr : 0 < r) (hrm : r < j.order) (y : RealTorus₄) :
+    (flatTorusPermutation j v ^ r) y ≠ y := by
+  rw [Equiv.Perm.coe_pow]
+  exact flatTorusAffine_iterate_ne j v hv r hr hrm y
+
+private theorem
+    Elliptic.flatTorusPermutation_free_iff (j : Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    (∀ r : ℕ, 0 < r → r < j.order → ∀ y : RealTorus₄, (flatTorusPermutation j v ^ r) y ≠ y) ↔
+      AdmissibleTwist j v := by
+  constructor
+  · intro h
+    apply (flatAffine_free_iff j v hv).mp
+    intro r hr hrm x hx
+    apply h r hr hrm (standardLattice.mkQ x)
+    rw [flatTorusPermutation_pow_mkQ]
+    exact (flatTorus_mkQ_eq_iff _ _).mpr hx
+  · intro ha
+    exact flatTorusPermutation_pow_ne j v ha
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Elliptic/Core2.lean b/LeanPool/HopfProblem/Elliptic/Core2.lean
new file mode 100644
index 000000000..fa500f3a0
--- /dev/null
+++ b/LeanPool/HopfProblem/Elliptic/Core2.lean
@@ -0,0 +1,1395 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Pi1.ThreefoldOverlapMappingTorus1
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap1
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Pi1.ThreefoldOverlapMappingTorus1
+
+/-!
+# Hopf problem: elliptic · core 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def Elliptic.familyPeriods (j : Kind) : HolomorphicPeriodMap ℂ SpecialPeriods.Disc :=
+  match j with
+  | .three => SpecialPeriods.threePeriodMap
+  | .four => SpecialPeriods.fourPeriodMap
+
+private def Elliptic.familyRotation (j : Kind) :
+    Diffeomorph (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) SpecialPeriods.Disc
+      SpecialPeriods.Disc ω :=
+  match j with
+  | .three => SpecialPeriods.threeRotation
+  | .four => SpecialPeriods.fourRotation
+
+private theorem
+    Elliptic.familyRotation_iterate_order (j : Kind) : (familyRotation j)^[j.order] = id := by
+  cases j
+  · exact SpecialPeriods.discRotateThree_iterate_order
+  · exact SpecialPeriods.discRotateFour_iterate_order
+
+private abbrev Elliptic.Family (j : Kind) :=
+  (familyPeriods j).TotalSpace
+
+private abbrev Elliptic.FamilyModel :=
+  ℂ × ComplexPlane₂
+
+@[instance_reducible]
+private def Elliptic.familyCoveringChartedSpace :
+    ChartedSpace FamilyModel (SpecialPeriods.Disc × ComplexPlane₂) :=
+  inferInstanceAs (ChartedSpace (ModelProd ℂ ComplexPlane₂) (SpecialPeriods.Disc × ComplexPlane₂))
+
+attribute [local instance] Elliptic.familyCoveringChartedSpace in
+private theorem Elliptic.familyCoveringManifold :
+    IsManifold (modelWithCornersSelf ℂ FamilyModel) ω (SpecialPeriods.Disc × ComplexPlane₂) := by
+  rw [modelWithCornersSelf_prod]
+  exact
+    IsManifold.prod (I := modelWithCornersSelf ℂ ℂ) (I' := modelWithCornersSelf ℂ ComplexPlane₂)
+      SpecialPeriods.Disc ComplexPlane₂
+
+attribute [local instance] Elliptic.familyCoveringChartedSpace Elliptic.familyCoveringManifold in
+private theorem Elliptic.familyPeriodEquiv_matrix (j : Kind) (z : SpecialPeriods.Disc)
+    (x : RealPlane₄) :
+    (familyPeriods j).periodEquiv z x =
+      ((familyPeriods j).point z).val.matrix *ᵥ (fun i => (x i : ℂ)) := by
+  rw [HolomorphicPeriodMap.periodEquiv_coordinates]
+  ext i
+  fin_cases i <;> simp [PeriodPoint.matrix, Matrix.mulVec, dotProduct, Fin.sum_univ_four]
+
+attribute [local instance] Elliptic.familyCoveringChartedSpace Elliptic.familyCoveringManifold in
+private theorem Elliptic.familyPeriods_matrix_covariance (j : Kind) (z : SpecialPeriods.Disc) :
+    ((familyPeriods j).point (familyRotation j z)).val.matrix * j.matrix.map (Int.castRingHom ℂ) =
+      linearMatrix j ((familyPeriods j).point z) * ((familyPeriods j).point z).val.matrix := by
+  cases j
+  · exact SpecialPeriods.threePeriodMap_matrix_covariance z
+  · exact SpecialPeriods.fourPeriodMap_matrix_covariance z
+
+attribute [local instance] Elliptic.familyCoveringChartedSpace Elliptic.familyCoveringManifold in
+private theorem Elliptic.familyPeriodEquiv_flatLinear (j : Kind) (z : SpecialPeriods.Disc)
+    (x : RealPlane₄) :
+    (familyPeriods j).periodEquiv (familyRotation j z) (flatLinear j x) =
+      linearMatrix j ((familyPeriods j).point z) *ᵥ (familyPeriods j).periodEquiv z x := by
+  rw [familyPeriodEquiv_matrix, flatLinear_complexCast, Matrix.mulVec_mulVec,
+    familyPeriodEquiv_matrix, Matrix.mulVec_mulVec, familyPeriods_matrix_covariance]
+
+attribute [local instance] Elliptic.familyCoveringChartedSpace Elliptic.familyCoveringManifold in
+private theorem Elliptic.familyPeriodEquiv_symm_linearMatrix (j : Kind) (z : SpecialPeriods.Disc)
+    (w : ComplexPlane₂) :
+    ((familyPeriods j).periodEquiv (familyRotation j z)).symm
+        (linearMatrix j ((familyPeriods j).point z) *ᵥ w) =
+      flatLinear j (((familyPeriods j).periodEquiv z).symm w) := by
+  apply ((familyPeriods j).periodEquiv (familyRotation j z)).injective
+  rw [LinearEquiv.apply_symm_apply, familyPeriodEquiv_flatLinear, LinearEquiv.apply_symm_apply]
+
+attribute [local instance] Elliptic.familyCoveringChartedSpace Elliptic.familyCoveringManifold in
+private def Elliptic.familyPermutation (j : Kind) (v : Lattice) : Equiv.Perm (Family j) :=
+  (familyRotation j).toEquiv.prodCongr (flatTorusAffine j v).toEquiv
+
+attribute [local instance] Elliptic.familyCoveringChartedSpace Elliptic.familyCoveringManifold in
+@[simp]
+private theorem Elliptic.familyPermutation_apply (j : Kind) (v : Lattice) (x : Family j) :
+    familyPermutation j v x = (familyRotation j x.1, flatTorusAffine j v x.2) :=
+  rfl
+
+attribute [local instance] Elliptic.familyCoveringChartedSpace Elliptic.familyCoveringManifold in
+private def Elliptic.familyLift (j : Kind) (v : Lattice) (x : SpecialPeriods.Disc × ComplexPlane₂) :
+    SpecialPeriods.Disc × ComplexPlane₂ :=
+  (familyRotation j x.1,
+    linearMatrix j ((familyPeriods j).point x.1) *ᵥ x.2 +
+      (familyPeriods j).periodEquiv (familyRotation j x.1) ((1 / (j.order : ℝ)) • realCast v))
+
+attribute [local instance] Elliptic.familyCoveringChartedSpace Elliptic.familyCoveringManifold in
+private theorem Elliptic.familyLift_quotientMap (j : Kind) (v : Lattice)
+    (x : SpecialPeriods.Disc × ComplexPlane₂) :
+    (familyPeriods j).quotientMap (familyLift j v x) =
+      familyPermutation j v ((familyPeriods j).quotientMap x) := by
+  change
+    (familyRotation j x.1,
+        standardLattice.mkQ
+          (((familyPeriods j).periodEquiv (familyRotation j x.1)).symm
+            (linearMatrix j ((familyPeriods j).point x.1) *ᵥ x.2 +
+              (familyPeriods j).periodEquiv (familyRotation j x.1)
+                ((1 / (j.order : ℝ)) • realCast v)))) =
+      (familyRotation j x.1,
+        flatTorusAffine j v (standardLattice.mkQ (((familyPeriods j).periodEquiv x.1).symm x.2)))
+  rw [flatTorusAffine_mkQ, map_add, LinearEquiv.symm_apply_apply,
+    familyPeriodEquiv_symm_linearMatrix]
+  rfl
+
+attribute [local instance] Elliptic.familyCoveringChartedSpace Elliptic.familyCoveringManifold in
+private theorem Elliptic.familyLinearLift_holomorphic (j : Kind) :
+    ContMDiff (modelWithCornersSelf ℂ FamilyModel) (modelWithCornersSelf ℂ ComplexPlane₂) ω
+      (fun x : SpecialPeriods.Disc × ComplexPlane₂ =>
+        linearMatrix j ((familyPeriods j).point x.1) *ᵥ x.2) := by
+  have hf :
+    ContMDiff (modelWithCornersSelf ℂ FamilyModel) (modelWithCornersSelf ℂ ℂ) ω
+      (Prod.fst : SpecialPeriods.Disc × ComplexPlane₂ → SpecialPeriods.Disc) := by
+    rw [modelWithCornersSelf_prod]
+    exact contMDiff_fst
+  have hs :
+    ContMDiff (modelWithCornersSelf ℂ FamilyModel) (modelWithCornersSelf ℂ ComplexPlane₂) ω
+      (Prod.snd : SpecialPeriods.Disc × ComplexPlane₂ → ComplexPlane₂) := by
+    rw [modelWithCornersSelf_prod]
+    exact contMDiff_snd
+  have hτ := (familyPeriods j).holomorphic_tau.comp hf
+  have hμ := (familyPeriods j).holomorphic_mu.comp hf
+  have hτ0 : ∀ x : SpecialPeriods.Disc × ComplexPlane₂, ((familyPeriods j).point x.1).val.τ ≠ 0 :=
+    fun x => ((familyPeriods j).point x.1).val.τ_ne_zero ((familyPeriods j).point x.1).property.1
+  have h₀ := (contMDiff_pi_space.mp hs) 0
+  have h₁ := (contMDiff_pi_space.mp hs) 1
+  cases j
+  · apply contMDiff_pi_space.mpr
+    intro i
+    fin_cases i
+    · convert (((contMDiff_const (c := (-1 : ℂ))).div₀ hτ hτ0).mul h₀) using 1
+      funext x
+      simp [linearMatrix, PeriodPoint.R₁, Matrix.mulVec, dotProduct, Fin.sum_univ_two,
+        Function.comp_def]
+    · convert (((((contMDiff_const (c := (1 : ℂ))).sub hμ).div₀ hτ hτ0).mul h₀).add h₁) using 1
+      funext x
+      simp [linearMatrix, PeriodPoint.R₁, Matrix.mulVec, dotProduct, Fin.sum_univ_two,
+        Function.comp_def]
+  · apply contMDiff_pi_space.mpr
+    intro i
+    fin_cases i
+    · convert (((contMDiff_const (c := (1 : ℂ))).div₀ hτ hτ0).mul h₀) using 1
+      funext x
+      simp [linearMatrix, PeriodPoint.R₂, Matrix.mulVec, dotProduct, Fin.sum_univ_two,
+        Function.comp_def]
+    · convert (((hμ.neg.div₀ hτ hτ0).mul h₀).add h₁) using 1
+      funext x
+      simp [linearMatrix, PeriodPoint.R₂, Matrix.mulVec, dotProduct, Fin.sum_univ_two,
+        Function.comp_def]
+
+attribute [local instance] Elliptic.familyCoveringChartedSpace Elliptic.familyCoveringManifold in
+private theorem Elliptic.familyLift_holomorphic (j : Kind) (v : Lattice) :
+    ContMDiff (modelWithCornersSelf ℂ FamilyModel) (modelWithCornersSelf ℂ FamilyModel) ω
+      (familyLift j v) := by
+  have hf :
+    ContMDiff (modelWithCornersSelf ℂ FamilyModel) (modelWithCornersSelf ℂ ℂ) ω
+      (fun x : SpecialPeriods.Disc × ComplexPlane₂ => familyRotation j x.1) := by
+    rw [modelWithCornersSelf_prod]
+    exact (familyRotation j).contMDiff_toFun.comp contMDiff_fst
+  have hw :=
+    (familyLinearLift_holomorphic j).add
+      (((familyPeriods j).holomorphic_periodEquiv_const ((1 / (j.order : ℝ)) • realCast v)).comp
+        hf)
+  rw [modelWithCornersSelf_prod] at hf hw ⊢
+  exact hf.prodMk hw
+
+attribute [local instance] Elliptic.familyCoveringChartedSpace Elliptic.familyCoveringManifold in
+private theorem Elliptic.familyPermutation_holomorphic (j : Kind) (v : Lattice) :
+    letI := (familyPeriods j).totalChartedSpace
+    ContMDiff (modelWithCornersSelf ℂ FamilyModel) (modelWithCornersSelf ℂ FamilyModel) ω
+      (familyPermutation j v) := by
+  let := (familyPeriods j).coveringAction
+  let := (familyPeriods j).totalChartedSpace
+  apply
+    CoveringQuotient.contMDiff_of_comp (E := FamilyModel) (familyPeriods j).quotientCoveringMap
+      (modelWithCornersSelf ℂ FamilyModel) ω
+  have h := ((familyPeriods j).quotientMap_holomorphic).comp (familyLift_holomorphic j v)
+  convert! h using 1
+  funext x
+  exact (familyLift_quotientMap j v x).symm
+
+private theorem Elliptic.LogGauge.exponential_neg_one_third :
+    CuspUniformization.exponential (-(1 / (3 : ℂ))) = -SpecialPeriods.rho := by
+  have hρ : Complex.exp ((Real.pi : ℂ) / 3 * Complex.I) = SpecialPeriods.rho := by
+    simpa only [Complex.ofReal_div, Complex.ofReal_ofNat] using SpecialPeriods.rho_eq_exp.symm
+  rw [CuspUniformization.exponential,
+    show
+      (2 * Real.pi * Complex.I : ℂ) * -(1 / 3) =
+        (Real.pi : ℂ) / 3 * Complex.I - Real.pi * Complex.I
+      by ring,
+    Complex.exp_sub_pi_mul_I, hρ]
+
+private theorem Elliptic.LogGauge.exponential_neg_one_fourth :
+    CuspUniformization.exponential (-(1 / (4 : ℂ))) = -Complex.I := by
+  rw [CuspUniformization.exponential,
+    show (2 * Real.pi * Complex.I : ℂ) * -(1 / 4) = -(Real.pi : ℂ) / 2 * Complex.I by ring,
+    Complex.exp_neg_pi_div_two_mul_I]
+
+private theorem Elliptic.LogGauge.familyRotation_val_exponential (j : Elliptic.Kind)
+    (z : SpecialPeriods.Disc) :
+    (Elliptic.familyRotation j z : ℂ) =
+      CuspUniformization.exponential (-(1 / (j.order : ℂ))) * (z : ℂ) := by
+  cases j
+  · change
+      -SpecialPeriods.rho * (z : ℂ) = CuspUniformization.exponential (-(1 / (3 : ℂ))) * (z : ℂ)
+    rw [exponential_neg_one_third]
+  · change -Complex.I * (z : ℂ) = CuspUniformization.exponential (-(1 / (4 : ℂ))) * (z : ℂ)
+    rw [exponential_neg_one_fourth]
+
+private theorem
+    Elliptic.LogGauge.familyRotation_ne_zero (j : Elliptic.Kind) (z : SpecialPeriods.Disc)
+    (hz : (z : ℂ) ≠ 0) : (Elliptic.familyRotation j z : ℂ) ≠ 0 := by
+  rw [familyRotation_val_exponential]
+  exact mul_ne_zero (CuspUniformization.exponential_ne_zero _) hz
+
+private theorem
+    Elliptic.LogGauge.familyRotation_logarithms (j : Elliptic.Kind) (z : SpecialPeriods.Disc)
+    (s r : ℂ) (hs : CuspUniformization.exponential s = (z : ℂ))
+    (hr : CuspUniformization.exponential r = (Elliptic.familyRotation j z : ℂ)) :
+    ∃ n : ℤ, r = s - 1 / (j.order : ℂ) + n := by
+  apply (CuspUniformization.exponential_eq_iff r (s - 1 / (j.order : ℂ))).mp
+  rw [hr, familyRotation_val_exponential, sub_eq_add_neg, CuspUniformization.exponential_add, hs]
+  exact mul_comm _ _
+
+private theorem
+    Elliptic.LogGauge.logarithm_familyRotation (j : Elliptic.Kind) (z : SpecialPeriods.Disc)
+    (hz : (z : ℂ) ≠ 0) :
+    ∃ n : ℤ,
+      CuspUniformization.logarithm (Elliptic.familyRotation j z : ℂ) =
+        CuspUniformization.logarithm (z : ℂ) - 1 / (j.order : ℂ) + n :=
+  familyRotation_logarithms j z _ _ (CuspUniformization.exponential_logarithm hz)
+    (CuspUniformization.exponential_logarithm (familyRotation_ne_zero j z hz))
+
+@[instance_reducible]
+private def Elliptic.CyclicAction.action {M : Type*} {m : ℕ} [NeZero m] (σ : Equiv.Perm M)
+    (hσ : σ ^ m = 1) : MulAction (Multiplicative (ZMod m)) M
+    where
+  smul g x := (σ ^ g.toAdd.val) x
+  one_smul
+    x := by
+    change (σ ^ (0 : ZMod m).val) x = x
+    simp
+  mul_smul g h
+    x := by
+    change (σ ^ (g.toAdd + h.toAdd).val) x = (σ ^ g.toAdd.val) ((σ ^ h.toAdd.val) x)
+    rw [ZMod.val_add, ← pow_eq_pow_mod _ hσ, pow_add]
+    rfl
+
+private def Elliptic.CyclicAction.generator (m : ℕ) : Multiplicative (ZMod m) :=
+  Multiplicative.ofAdd 1
+
+private theorem
+    Elliptic.CyclicAction.smul_eq_iterate {M : Type*} {m : ℕ} [NeZero m] (σ : Equiv.Perm M)
+    (hσ : σ ^ m = 1) (g : Multiplicative (ZMod m)) (x : M) :
+    letI := action σ hσ
+    g • x = (σ : M → M)^[g.toAdd.val] x := by
+  change (σ ^ g.toAdd.val) x = _
+  rw [Equiv.Perm.coe_pow]
+
+private theorem
+    Elliptic.CyclicAction.ofAdd_natCast_smul {M : Type*} {m : ℕ} [NeZero m] (σ : Equiv.Perm M)
+    (hσ : σ ^ m = 1) (r : ℕ) (x : M) :
+    letI := action σ hσ
+    Multiplicative.ofAdd (r : ZMod m) • x = (σ : M → M)^[r] x := by
+  change (σ ^ (r : ZMod m).val) x = _
+  rw [ZMod.val_natCast, ← pow_eq_pow_mod r hσ, Equiv.Perm.coe_pow]
+
+@[simp]
+private theorem
+    Elliptic.CyclicAction.generator_smul {M : Type*} {m : ℕ} [NeZero m] (σ : Equiv.Perm M)
+    (hσ : σ ^ m = 1) (x : M) :
+    letI := action σ hσ
+    generator m • x = σ x := by simpa [generator] using ofAdd_natCast_smul σ hσ 1 x
+
+private theorem Elliptic.CyclicAction.isCancelSMul {M : Type*} {m : ℕ} [NeZero m] (σ : Equiv.Perm M)
+    (hσ : σ ^ m = 1) (hfree : ∀ r : ℕ, 0 < r → r < m → ∀ x : M, (σ : M → M)^[r] x ≠ x) :
+    letI := action σ hσ
+    IsCancelSMul (Multiplicative (ZMod m)) M := by
+  let := action σ hσ
+  apply isCancelSMul_iff_eq_one_of_smul_eq.mpr
+  intro g x hx
+  have hval : g.toAdd.val = 0 := by
+    by_contra hval
+    exact
+      hfree g.toAdd.val (Nat.pos_of_ne_zero hval) (ZMod.val_lt _) x
+        ((smul_eq_iterate σ hσ g x).symm.trans hx)
+  apply Multiplicative.ext
+  exact (ZMod.val_eq_zero _).mp hval
+
+private theorem
+    Elliptic.CyclicAction.isCancelSMul_iff {M : Type*} {m : ℕ} [NeZero m] (σ : Equiv.Perm M)
+    (hσ : σ ^ m = 1) :
+    letI := action σ hσ
+    IsCancelSMul (Multiplicative (ZMod m)) M ↔
+      ∀ r : ℕ, 0 < r → r < m → ∀ x : M, (σ : M → M)^[r] x ≠ x := by
+  let := action σ hσ
+  constructor
+  · intro hcancel r hr hrm x hx
+    let := hcancel
+    have hg : Multiplicative.ofAdd (r : ZMod m) = (1 : Multiplicative (ZMod m)) :=
+      IsCancelSMul.eq_one_of_smul ((ofAdd_natCast_smul σ hσ r x).trans hx)
+    have hz : (r : ZMod m) = 0 := congrArg Multiplicative.toAdd hg
+    have hv := congrArg ZMod.val hz
+    rw [ZMod.val_natCast_of_lt hrm, ZMod.val_zero] at hv
+    omega
+  · exact isCancelSMul σ hσ
+
+private theorem Elliptic.CyclicAction.continuousConstSMul {M : Type*} {m : ℕ} [NeZero m]
+    [TopologicalSpace M] (σ : Equiv.Perm M) (hσ : σ ^ m = 1) (hcont : Continuous (σ : M → M)) :
+    letI := action σ hσ
+    ContinuousConstSMul (Multiplicative (ZMod m)) M := by
+  let := action σ hσ
+  refine ⟨fun g => ?_⟩
+  simpa only [smul_eq_iterate σ hσ] using hcont.iterate g.toAdd.val
+
+private theorem Elliptic.CyclicAction.smul_contMDiff {M : Type*} {m : ℕ} [NeZero m] {𝕜 E H : Type*}
+    [NontriviallyNormedField 𝕜] [NormedAddCommGroup E] [NormedSpace 𝕜 E] [TopologicalSpace H]
+    {I : ModelWithCorners 𝕜 E H} {n : ℕ∞ω} [TopologicalSpace M] [ChartedSpace H M]
+    (σ : Equiv.Perm M) (hσ : σ ^ m = 1) (hreg : ContMDiff I I n (σ : M → M))
+    (g : Multiplicative (ZMod m)) :
+    letI := action σ hσ
+    ContMDiff I I n (fun x : M => g • x) := by
+  let := action σ hσ
+  simpa only [smul_eq_iterate σ hσ] using hreg.iterate g.toAdd.val
+
+private abbrev Elliptic.FiniteQuotient.Space (G M : Type*) [Group G] [MulAction G M] :=
+  MulAction.orbitRel.Quotient G M
+
+private def
+    Elliptic.FiniteQuotient.project (G M : Type*) [Group G] [MulAction G M] : M → Space G M :=
+  Quotient.mk (MulAction.orbitRel G M)
+
+private theorem Elliptic.FiniteQuotient.project_surjective (G M : Type*) [Group G] [MulAction G M] :
+    Function.Surjective (project G M) :=
+  Quotient.mk_surjective
+
+private theorem
+    Elliptic.FiniteQuotient.project_eq_iff_mem_orbit (G M : Type*) [Group G] [MulAction G M]
+    (x y : M) : project G M x = project G M y ↔ x ∈ MulAction.orbit G y :=
+  Quotient.eq''
+
+@[simp]
+private theorem Elliptic.FiniteQuotient.project_smul (G M : Type*) [Group G] [MulAction G M] (g : G)
+    (x : M) : project G M (g • x) = project G M x :=
+  (project_eq_iff_mem_orbit G M _ _).mpr ⟨g, rfl⟩
+
+private theorem
+    Elliptic.FiniteQuotient.project_isQuotientMap (G M : Type*) [Group G] [MulAction G M]
+    [TopologicalSpace M] : Topology.IsQuotientMap (project G M) :=
+  isQuotientMap_quotient_mk'
+
+private theorem Elliptic.FiniteQuotient.project_continuous (G M : Type*) [Group G] [MulAction G M]
+    [TopologicalSpace M] : Continuous (project G M) :=
+  (project_isQuotientMap G M).continuous
+
+private theorem
+    Elliptic.FiniteQuotient.project_isOpenQuotientMap (G M : Type*) [Group G] [MulAction G M]
+    [TopologicalSpace M] [ContinuousConstSMul G M] : IsOpenQuotientMap (project G M) :=
+  MulAction.isOpenQuotientMap_quotientMk
+
+private theorem Elliptic.FiniteQuotient.spaceCompactSpace (G M : Type*) [Group G] [MulAction G M]
+    [TopologicalSpace M] [CompactSpace M] : CompactSpace (Space G M) :=
+  inferInstance
+
+private theorem Elliptic.FiniteQuotient.spaceSecondCountableTopology (G M : Type*) [Group G]
+    [MulAction G M] [TopologicalSpace M] [SecondCountableTopology M] [ContinuousConstSMul G M] :
+    SecondCountableTopology (Space G M) :=
+  (project_isQuotientMap G M).secondCountableTopology (project_isOpenQuotientMap G M).isOpenMap
+
+private theorem Elliptic.FiniteQuotient.spaceT2Space (G M : Type*) [Group G] [MulAction G M]
+    [TopologicalSpace M] [Finite G] [LocallyCompactSpace M] [T2Space M]
+    [ContinuousConstSMul G M] : T2Space (Space G M) :=
+  inferInstance
+
+private theorem Elliptic.FiniteQuotient.project_isQuotientCoveringMap (G M : Type*) [Group G]
+    [MulAction G M] [TopologicalSpace M] [Finite G] [LocallyCompactSpace M] [T2Space M]
+    [ContinuousConstSMul G M] [IsCancelSMul G M] : IsQuotientCoveringMap (project G M) G :=
+  isQuotientCoveringMap_quotientMk_of_properlyDiscontinuousSMul
+
+private theorem
+    Elliptic.FiniteQuotient.project_isCoveringMap (G M : Type*) [Group G] [MulAction G M]
+    [TopologicalSpace M] [Finite G] [LocallyCompactSpace M] [T2Space M] [ContinuousConstSMul G M]
+    [IsCancelSMul G M] : IsCoveringMap (project G M) :=
+  (project_isQuotientCoveringMap G M).isCoveringMap
+
+private def Elliptic.FiniteQuotient.fibreEquivGroup (G M : Type*) [Group G] [MulAction G M]
+    [TopologicalSpace M] [Finite G] [LocallyCompactSpace M] [T2Space M] [ContinuousConstSMul G M]
+    [IsCancelSMul G M] (x : Space G M) : (project G M ⁻¹' { x }) ≃ G :=
+  (project_isQuotientCoveringMap G M).fiberEquivGroup
+    ⟨(project_surjective G M x).choose, (project_surjective G M x).choose_spec⟩
+
+private theorem Elliptic.FiniteQuotient.fibre_card (G M : Type*) [Group G] [MulAction G M]
+    [TopologicalSpace M] [Finite G] [LocallyCompactSpace M] [T2Space M] [ContinuousConstSMul G M]
+    [IsCancelSMul G M] (x : Space G M) : Nat.card (project G M ⁻¹' { x }) = Nat.card G :=
+  Nat.card_congr (fibreEquivGroup G M x)
+
+@[instance_reducible]
+private def Elliptic.FiniteQuotient.chartedSpace (G M : Type*) [Group G] [MulAction G M] {E : Type*}
+    [NormedAddCommGroup E] [TopologicalSpace M] [ChartedSpace E M] [Finite G]
+    [LocallyCompactSpace M] [T2Space M] [ContinuousConstSMul G M] [IsCancelSMul G M] :
+    ChartedSpace E (Space G M) :=
+  CoveringQuotient.chartedSpace (E := E) (project_isQuotientCoveringMap G M)
+
+private theorem Elliptic.FiniteQuotient.project_holomorphic (G M : Type*) [Group G] [MulAction G M]
+    {E : Type*} [NormedAddCommGroup E] [NormedSpace ℂ E] [TopologicalSpace M] [ChartedSpace E M]
+    [Finite G] [LocallyCompactSpace M] [T2Space M] [ContinuousConstSMul G M] [IsCancelSMul G M]
+    [IsManifold (modelWithCornersSelf ℂ E) ω M]
+    (hG :
+      ∀ g : G,
+        ContMDiff (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (fun x : M => g • x)) :
+    letI := chartedSpace (E := E) G M
+    ContMDiff (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (project G M) :=
+  CoveringQuotient.contMDiff_project (project_isQuotientCoveringMap G M) ω hG
+
+private instance Elliptic.instLocal2 (j : Kind) : NeZero j.order :=
+  ⟨Nat.ne_of_gt j.order_pos⟩
+
+private abbrev Elliptic.CyclicGroup (j : Kind) :=
+  Multiplicative (ZMod j.order)
+
+@[instance_reducible]
+private def
+    Elliptic.affineAction (j : Kind) (p : FixedPeriod j) (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    MulAction (CyclicGroup j) p.val.Torus :=
+  CyclicAction.action (affinePermutation j p v) (affinePermutation_pow_order j p v hv)
+
+private theorem Elliptic.affineAction_generator_smul (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : j.matrix *ᵥ v = v) (x : p.val.Torus) :
+    letI := affineAction j p v hv
+    CyclicAction.generator j.order • x = affineBiholomorph j p v x :=
+  CyclicAction.generator_smul (affinePermutation j p v) (affinePermutation_pow_order j p v hv) x
+
+private theorem Elliptic.affineAction_free_iff (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : j.matrix *ᵥ v = v) :
+    letI := affineAction j p v hv
+    IsCancelSMul (CyclicGroup j) p.val.Torus ↔ AdmissibleTwist j v := by
+  refine
+    (CyclicAction.isCancelSMul_iff (affinePermutation j p v)
+          (affinePermutation_pow_order j p v hv)).trans
+      ?_
+  simpa only [Equiv.Perm.coe_pow] using affinePermutation_free_iff j p v hv
+
+private theorem Elliptic.affineAction_free (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) :
+    letI := affineAction j p v hv.1
+    IsCancelSMul (CyclicGroup j) p.val.Torus :=
+  (affineAction_free_iff j p v hv.1).mpr hv
+
+private theorem Elliptic.affineAction_continuous (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : j.matrix *ᵥ v = v) :
+    letI := affineAction j p v hv
+    ContinuousConstSMul (CyclicGroup j) p.val.Torus :=
+  CyclicAction.continuousConstSMul (affinePermutation j p v)
+    (affinePermutation_pow_order j p v hv) (affineBiholomorph j p v).continuous
+
+private abbrev
+    Elliptic.Surface (j : Kind) (p : FixedPeriod j) (v : Lattice) (hv : AdmissibleTwist j v) :=
+  @FiniteQuotient.Space (CyclicGroup j) p.val.Torus _ (affineAction j p v hv.1)
+
+private def Elliptic.surfaceProjection (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) : p.val.Torus → Surface j p v hv :=
+  @FiniteQuotient.project (CyclicGroup j) p.val.Torus _ (affineAction j p v hv.1)
+
+private theorem Elliptic.surfaceProjection_surjective (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) : Function.Surjective (surfaceProjection j p v hv) :=
+  Quotient.mk_surjective
+
+private theorem Elliptic.surfaceProjection_continuous (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) : Continuous (surfaceProjection j p v hv) := by
+  let := affineAction j p v hv.1
+  exact FiniteQuotient.project_continuous (CyclicGroup j) p.val.Torus
+
+private instance Elliptic.surfaceCompact (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) : CompactSpace (Surface j p v hv) := by
+  let := affineAction j p v hv.1
+  exact FiniteQuotient.spaceCompactSpace (CyclicGroup j) p.val.Torus
+
+private instance Elliptic.surfacePathConnected (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) : PathConnectedSpace (Surface j p v hv) :=
+  (surfaceProjection_surjective j p v hv).pathConnectedSpace
+    (surfaceProjection_continuous j p v hv)
+
+private theorem
+    Elliptic.surfaceProjection_isCoveringMap (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) : IsCoveringMap (surfaceProjection j p v hv) := by
+  let := affineAction j p v hv.1
+  let := affineAction_continuous j p v hv.1
+  let := affineAction_free j p v hv
+  exact FiniteQuotient.project_isCoveringMap (CyclicGroup j) p.val.Torus
+
+private theorem Elliptic.surfaceProjection_fibre_card (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) (y : Surface j p v hv) :
+    Nat.card (surfaceProjection j p v hv ⁻¹' { y }) = j.order := by
+  let := affineAction j p v hv.1
+  let := affineAction_continuous j p v hv.1
+  let := affineAction_free j p v hv
+  change Nat.card (FiniteQuotient.project (CyclicGroup j) p.val.Torus ⁻¹' { y }) = j.order
+  rw [FiniteQuotient.fibre_card (CyclicGroup j) p.val.Torus]
+  simp [CyclicGroup, Nat.card_eq_fintype_card, ZMod.card]
+
+private theorem Elliptic.pow_mem_unitDisc_iff (m : ℕ) (hm : 0 < m) (z : ℂ) :
+    z ^ m ∈ SpecialPeriods.unitDisc ↔ z ∈ SpecialPeriods.unitDisc := by
+  change Dist.dist (z ^ m) 0 < 1 ↔ Dist.dist z 0 < 1
+  rw [dist_zero_right, dist_zero_right, norm_pow]
+  exact pow_lt_one_iff_of_nonneg (norm_nonneg z) hm.ne'
+
+private theorem Elliptic.complexPower_preimage_unitDisc (m : ℕ) (hm : 0 < m) :
+    (fun z : ℂ => z ^ m) ⁻¹' (SpecialPeriods.unitDisc : Set ℂ) =
+      (SpecialPeriods.unitDisc : Set ℂ) := by
+  ext z
+  exact pow_mem_unitDisc_iff m hm z
+
+private def
+    Elliptic.discPower (m : ℕ) (hm : 0 < m) (z : SpecialPeriods.Disc) : SpecialPeriods.Disc :=
+  ⟨(z : ℂ) ^ m, (pow_mem_unitDisc_iff m hm z).mpr z.property⟩
+
+@[simp]
+private theorem Elliptic.discPower_coe (m : ℕ) (hm : 0 < m) (z : SpecialPeriods.Disc) :
+    (discPower m hm z : ℂ) = (z : ℂ) ^ m :=
+  rfl
+
+private theorem Elliptic.discPower_holomorphic (m : ℕ) (hm : 0 < m) :
+    ContMDiff 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) ω (discPower m hm) := by
+  intro z
+  have he :
+    ContMDiffAt 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) ω (fun w : SpecialPeriods.Disc => (discPower m hm w : ℂ)) z ↔
+      ContMDiffAt 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) ω (discPower m hm) z :=
+    ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+  exact he.mp ((contMDiff_subtype_val.pow m) z)
+
+private theorem Elliptic.discPower_continuous (m : ℕ) (hm : 0 < m) : Continuous (discPower m hm) :=
+  (discPower_holomorphic m hm).continuous
+
+private theorem Elliptic.discPower_surjective (m : ℕ) (hm : 0 < m) :
+    Function.Surjective (discPower m hm) := by
+  intro w
+  obtain ⟨z, hz⟩ := IsAlgClosed.exists_pow_nat_eq (w : ℂ) hm
+  have hmem : z ∈ SpecialPeriods.unitDisc := (pow_mem_unitDisc_iff m hm z).mp (hz ▸ w.property)
+  exact ⟨⟨z, hmem⟩, Subtype.ext hz⟩
+
+private theorem Elliptic.complexPower_isProperMap (m : ℕ) (hm : 0 < m) :
+    IsProperMap (fun z : ℂ => z ^ m) := by
+  have hp : 0 < (Polynomial.X ^ m : Polynomial ℂ).degree := by
+    rw [Polynomial.degree_X_pow]
+    exact_mod_cast hm
+  simpa only [Polynomial.eval_X_pow] using (Polynomial.X ^ m : Polynomial ℂ).isProperMap_eval hp
+
+private theorem
+    Elliptic.discPower_isProperMap (m : ℕ) (hm : 0 < m) : IsProperMap (discPower m hm) := by
+  let e : SpecialPeriods.Disc ≃ₜ ((fun z : ℂ => z ^ m) ⁻¹' (SpecialPeriods.unitDisc : Set ℂ)) :=
+    Homeomorph.setCongr (complexPower_preimage_unitDisc m hm).symm
+  have hp :=
+    ((complexPower_isProperMap m hm).restrictPreimage (SpecialPeriods.unitDisc : Set ℂ)).comp
+      e.isProperMap
+  have he :
+    (SpecialPeriods.unitDisc : Set ℂ).restrictPreimage (fun z : ℂ => z ^ m) ∘ e =
+      discPower m hm := by
+    funext z
+    rfl
+  rwa [he] at hp
+
+private def Elliptic.discZero : SpecialPeriods.Disc :=
+  ⟨0, by simp [SpecialPeriods.unitDisc]⟩
+
+private theorem Elliptic.discPower_coe_eq_zero_iff (m : ℕ) (hm : 0 < m) (z : SpecialPeriods.Disc) :
+    (discPower m hm z : ℂ) = 0 ↔ (z : ℂ) = 0 := by
+  simp only [discPower_coe, pow_eq_zero_iff hm.ne']
+
+@[simp]
+private theorem Elliptic.discPower_eq_zero_iff (m : ℕ) (hm : 0 < m) (z : SpecialPeriods.Disc) :
+    discPower m hm z = discZero ↔ z = discZero := by
+  rw [Subtype.ext_iff, Subtype.ext_iff]
+  exact discPower_coe_eq_zero_iff m hm z
+
+private theorem Elliptic.familyPermutation_iterate (j : Kind) (v : Lattice) (r : ℕ) (x : Family j) :
+    (familyPermutation j v)^[r] x = ((familyRotation j)^[r] x.1, (flatTorusAffine j v)^[r] x.2) :=
+  by
+  induction r with
+  | zero => rfl
+  | succ r ih => simp only [Function.iterate_succ_apply', ih, familyPermutation_apply]
+
+private theorem
+    Elliptic.familyPermutation_pow_apply (j : Kind) (v : Lattice) (r : ℕ) (x : Family j) :
+    (familyPermutation j v ^ r) x = ((familyRotation j)^[r] x.1, (flatTorusAffine j v)^[r] x.2) :=
+  by
+  rw [Equiv.Perm.coe_pow]
+  exact familyPermutation_iterate j v r x
+
+private theorem
+    Elliptic.familyPermutation_pow_order (j : Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    familyPermutation j v ^ j.order = 1 := by
+  apply Equiv.ext
+  intro x
+  rw [familyPermutation_pow_apply, familyRotation_iterate_order,
+    flatTorusAffine_iterate_order j v hv]
+  rfl
+
+private theorem
+    Elliptic.familyPermutation_pow_ne (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v)
+    (r : ℕ) (hr : 0 < r) (hrm : r < j.order) (x : Family j) : (familyPermutation j v ^ r) x ≠ x :=
+  by
+  intro hx
+  rw [familyPermutation_pow_apply] at hx
+  exact flatTorusAffine_iterate_ne j v hv r hr hrm x.2 (congrArg Prod.snd hx)
+
+@[simp]
+private theorem Elliptic.familyRotation_zero (j : Kind) : familyRotation j discZero = discZero := by
+  cases j <;> apply Subtype.ext
+  · change -SpecialPeriods.rho * (0 : ℂ) = 0
+    exact MulZeroClass.mul_zero _
+  · change -Complex.I * (0 : ℂ) = 0
+    exact MulZeroClass.mul_zero _
+
+private theorem Elliptic.familyRotation_iterate_fixed_iff (j : Kind) (r : ℕ) (hr : 0 < r)
+    (hrm : r < j.order) (z : SpecialPeriods.Disc) : (familyRotation j)^[r] z = z ↔ z = discZero :=
+  by
+  cases j
+  · exact SpecialPeriods.discRotateThree_iterate_fixed_iff r hr hrm z
+  · exact SpecialPeriods.discRotateFour_iterate_fixed_iff r hr hrm z
+
+private theorem
+    Elliptic.familyPermutation_free_iff (j : Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    (∀ r : ℕ, 0 < r → r < j.order → ∀ x : Family j, (familyPermutation j v ^ r) x ≠ x) ↔
+      AdmissibleTwist j v := by
+  constructor
+  · intro hf
+    apply (flatTorusPermutation_free_iff j v hv).mp
+    intro r hr hrm y hy
+    apply hf r hr hrm (discZero, y)
+    rw [familyPermutation_pow_apply]
+    apply Prod.ext (Function.iterate_fixed (familyRotation_zero j) r)
+    simpa only [Equiv.Perm.coe_pow, flatTorusPermutation, Homeomorph.coe_toEquiv] using hy
+  · intro ha
+    exact familyPermutation_pow_ne j v ha
+
+@[instance_reducible]
+private def Elliptic.familyAction (j : Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    MulAction (CyclicGroup j) (Family j) :=
+  CyclicAction.action (familyPermutation j v) (familyPermutation_pow_order j v hv)
+
+private theorem
+    Elliptic.familyAction_generator_smul (j : Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (x : Family j) :
+    letI := familyAction j v hv
+    CyclicAction.generator j.order • x = familyPermutation j v x :=
+  CyclicAction.generator_smul (familyPermutation j v) (familyPermutation_pow_order j v hv) x
+
+private theorem Elliptic.familyAction_apply (j : Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (g : CyclicGroup j) (x : Family j) :
+    letI := familyAction j v hv
+    g • x = ((familyRotation j)^[g.toAdd.val] x.1, (flatTorusAffine j v)^[g.toAdd.val] x.2) :=
+  (CyclicAction.smul_eq_iterate (familyPermutation j v) (familyPermutation_pow_order j v hv) g
+        x).trans
+    (familyPermutation_iterate j v g.toAdd.val x)
+
+private theorem Elliptic.familyAction_free_iff (j : Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    letI := familyAction j v hv
+    IsCancelSMul (CyclicGroup j) (Family j) ↔ AdmissibleTwist j v := by
+  refine
+    (CyclicAction.isCancelSMul_iff (familyPermutation j v)
+          (familyPermutation_pow_order j v hv)).trans
+      ?_
+  simpa only [Equiv.Perm.coe_pow] using familyPermutation_free_iff j v hv
+
+private theorem Elliptic.familyAction_free (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v) :
+    letI := familyAction j v hv.1
+    IsCancelSMul (CyclicGroup j) (Family j) :=
+  (familyAction_free_iff j v hv.1).mpr hv
+
+private theorem Elliptic.familyAction_holomorphic (j : Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (g : CyclicGroup j) :
+    letI := (familyPeriods j).totalChartedSpace
+    letI := familyAction j v hv
+    ContMDiff (modelWithCornersSelf ℂ FamilyModel) (modelWithCornersSelf ℂ FamilyModel) ω
+      (fun x : Family j => g • x) := by
+  let := (familyPeriods j).totalChartedSpace
+  exact
+    CyclicAction.smul_contMDiff (familyPermutation j v) (familyPermutation_pow_order j v hv)
+      (familyPermutation_holomorphic j v) g
+
+private theorem Elliptic.familyAction_continuous (j : Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    letI := familyAction j v hv
+    ContinuousConstSMul (CyclicGroup j) (Family j) := by
+  apply
+    CyclicAction.continuousConstSMul (familyPermutation j v) (familyPermutation_pow_order j v hv)
+  let := (familyPeriods j).totalChartedSpace
+  exact (familyPermutation_holomorphic j v).continuous
+
+private theorem Elliptic.discPower_familyRotation (j : Kind) (z : SpecialPeriods.Disc) :
+    discPower j.order j.order_pos (familyRotation j z) = discPower j.order j.order_pos z := by
+  cases j <;> apply Subtype.ext
+  · change (-SpecialPeriods.rho * (z : ℂ)) ^ 3 = (z : ℂ) ^ 3
+    rw [mul_pow, neg_pow, SpecialPeriods.rho_cube]
+    norm_num
+  · change (-Complex.I * (z : ℂ)) ^ 4 = (z : ℂ) ^ 4
+    norm_num [mul_pow]
+
+private theorem
+    Elliptic.discPower_familyRotation_iterate (j : Kind) (r : ℕ) (z : SpecialPeriods.Disc) :
+    discPower j.order j.order_pos ((familyRotation j)^[r] z) = discPower j.order j.order_pos z := by
+  induction r with
+  | zero => rfl
+  | succ r ih => rw [Function.iterate_succ_apply', discPower_familyRotation, ih]
+
+private theorem Elliptic.familyAction_discPower (j : Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (g : CyclicGroup j) (x : Family j) :
+    letI := familyAction j v hv
+    discPower j.order j.order_pos (g • x).1 = discPower j.order j.order_pos x.1 := by
+  let := familyAction j v hv
+  rw [familyAction_apply]
+  exact discPower_familyRotation_iterate j g.toAdd.val x.1
+
+private def Elliptic.FiniteQuotient.descend {G M B : Type*} [Group G] [MulAction G M] (f : M → B)
+    (hf : ∀ (g : G) (x : M), f (g • x) = f x) : Space G M → B :=
+  Quotient.lift f
+    (by
+      rintro x y ⟨g, hg⟩
+      rw [← hg]
+      exact hf g y)
+
+@[simp]
+private theorem Elliptic.FiniteQuotient.descend_project {G M B : Type*} [Group G] [MulAction G M]
+    (f : M → B) (hf : ∀ (g : G) (x : M), f (g • x) = f x) (x : M) :
+    descend f hf (project G M x) = f x :=
+  rfl
+
+private theorem Elliptic.FiniteQuotient.descend_surjective {G M B : Type*} [Group G] [MulAction G M]
+    (f : M → B) (hf : ∀ (g : G) (x : M), f (g • x) = f x) (hs : Function.Surjective f) :
+    Function.Surjective (descend f hf) := by
+  intro b
+  obtain ⟨x, hx⟩ := hs b
+  exact ⟨project G M x, hx⟩
+
+private theorem Elliptic.FiniteQuotient.descend_preimage_eq_image {G M B : Type*} [Group G]
+    [MulAction G M] (f : M → B) (hf : ∀ (g : G) (x : M), f (g • x) = f x) (K : Set B) :
+    descend f hf ⁻¹' K = project G M '' (f ⁻¹' K) := by
+  ext q
+  obtain ⟨x, rfl⟩ := project_surjective G M q
+  constructor
+  · intro hx
+    exact ⟨x, hx, rfl⟩
+  · rintro ⟨y, hy, hxy⟩
+    change descend f hf (project G M x) ∈ K
+    rw [← hxy, descend_project]
+    exact hy
+
+private theorem Elliptic.FiniteQuotient.descend_continuous {G M B : Type*} [Group G] [MulAction G M]
+    (f : M → B) (hf : ∀ (g : G) (x : M), f (g • x) = f x) [TopologicalSpace M]
+    [TopologicalSpace B] (hc : Continuous f) : Continuous (descend f hf) :=
+  (project_isQuotientMap G M).continuous_iff.mpr hc
+
+private theorem
+    Elliptic.FiniteQuotient.descend_isProperMap {G M B : Type*} [Group G] [MulAction G M]
+    (f : M → B) (hf : ∀ (g : G) (x : M), f (g • x) = f x) [TopologicalSpace M]
+    [TopologicalSpace B] (hp : IsProperMap f) : IsProperMap (descend f hf) :=
+  isProperMap_of_comp_of_surj (project_continuous G M) (descend_continuous f hf hp.continuous) hp
+    (project_surjective G M)
+
+private instance Elliptic.discLocallyCompact : LocallyCompactSpace SpecialPeriods.Disc :=
+  SpecialPeriods.unitDisc.isOpen.locallyCompactSpace
+
+private def Elliptic.upstairsProjection (j : Kind) (x : Family j) : SpecialPeriods.Disc :=
+  discPower j.order j.order_pos x.1
+
+private theorem
+    Elliptic.upstairsProjection_invariant (j : Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (g : CyclicGroup j) (x : Family j) :
+    letI := familyAction j v hv
+    upstairsProjection j (g • x) = upstairsProjection j x :=
+  familyAction_discPower j v hv g x
+
+private abbrev Elliptic.Filling (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v) :=
+  @FiniteQuotient.Space (CyclicGroup j) (Family j) _ (familyAction j v hv.1)
+
+private def Elliptic.fillingQuotient (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v) :
+    Family j → Filling j v hv :=
+  @FiniteQuotient.project (CyclicGroup j) (Family j) _ (familyAction j v hv.1)
+
+private theorem
+    Elliptic.fillingQuotient_surjective (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v) :
+    Function.Surjective (fillingQuotient j v hv) :=
+  Quotient.mk_surjective
+
+private theorem
+    Elliptic.fillingQuotient_continuous (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v) :
+    Continuous (fillingQuotient j v hv) := by
+  let := familyAction j v hv.1
+  exact FiniteQuotient.project_continuous (CyclicGroup j) (Family j)
+
+private instance Elliptic.fillingChartedSpace (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v) :
+    ChartedSpace FamilyModel (Filling j v hv) := by
+  letI := (familyPeriods j).totalChartedSpace
+  let := familyAction j v hv.1
+  let := familyAction_continuous j v hv.1
+  let := familyAction_free j v hv
+  exact FiniteQuotient.chartedSpace (E := FamilyModel) (CyclicGroup j) (Family j)
+
+private theorem Elliptic.fillingQuotient_isCoveringMap (j : Kind) (v : Lattice)
+    (hv : AdmissibleTwist j v) : IsCoveringMap (fillingQuotient j v hv) := by
+  let := familyAction j v hv.1
+  let := familyAction_continuous j v hv.1
+  let := familyAction_free j v hv
+  exact FiniteQuotient.project_isCoveringMap (CyclicGroup j) (Family j)
+
+private theorem
+    Elliptic.fillingQuotient_holomorphic (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v) :
+    letI := (familyPeriods j).totalChartedSpace
+    ContMDiff (modelWithCornersSelf ℂ FamilyModel) (modelWithCornersSelf ℂ FamilyModel) ω
+      (fillingQuotient j v hv) := by
+  let := (familyPeriods j).totalChartedSpace
+  let := (familyPeriods j).totalSpace_isManifold
+  let := familyAction j v hv.1
+  let := familyAction_continuous j v hv.1
+  let := familyAction_free j v hv
+  exact
+    FiniteQuotient.project_holomorphic (CyclicGroup j) (Family j)
+      (familyAction_holomorphic j v hv.1)
+
+private def Elliptic.fillingProjection (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v) :
+    Filling j v hv → SpecialPeriods.Disc := by
+  letI := familyAction j v hv.1
+  exact FiniteQuotient.descend (upstairsProjection j) (upstairsProjection_invariant j v hv.1)
+
+private abbrev Elliptic.HigherHomology.MappingTorusQuotient.Circle :=
+  MappingTorus.Circle
+
+private def
+    Elliptic.HigherHomology.MappingTorusQuotient.twist {X : Type*} [TopologicalSpace X] (m : ℕ)
+    (B : X ≃ₜ X) :
+    (Elliptic.HigherHomology.MappingTorusQuotient.Circle × X) ≃ₜ
+      (Elliptic.HigherHomology.MappingTorusQuotient.Circle × X) :=
+  (Homeomorph.addRight
+        (((1 : ℝ) / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle)).prodCongr
+    B
+
+@[simp]
+private theorem
+    Elliptic.HigherHomology.MappingTorusQuotient.twist_apply {X : Type*} [TopologicalSpace X]
+    (m : ℕ) (B : X ≃ₜ X) (a : Elliptic.HigherHomology.MappingTorusQuotient.Circle) (x : X) :
+    twist m B (a, x) =
+      (a + (((1 : ℝ) / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle), B x) :=
+  rfl
+
+private theorem Elliptic.HigherHomology.MappingTorusQuotient.twist_pow_apply {X : Type*}
+    [TopologicalSpace X] (m : ℕ) (B : X ≃ₜ X) (n : ℕ)
+    (a : Elliptic.HigherHomology.MappingTorusQuotient.Circle) (x : X) :
+    (twist m B ^ n) (a, x) =
+      (a + (((n : ℝ) / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle),
+        (B ^ n) x) := by
+  induction n with
+  | zero => simp
+  | succ n ih =>
+    rw [pow_succ', Homeomorph.mul_apply, ih, twist_apply]
+    apply Prod.ext
+    · change
+        a + (((n : ℝ) / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle) +
+            (((1 : ℝ) / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle) =
+          a + ((((n + 1 : ℕ) : ℝ) / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle)
+      rw [add_assoc, ← AddCircle.coe_add]
+      congr 2
+      push_cast
+      ring
+    · simp only [pow_succ', Homeomorph.mul_apply]
+
+private theorem Elliptic.HigherHomology.MappingTorusQuotient.twist_zpow_apply {X : Type*}
+    [TopologicalSpace X] (m : ℕ) (B : X ≃ₜ X) (n : ℤ)
+    (a : Elliptic.HigherHomology.MappingTorusQuotient.Circle) (x : X) :
+    (twist m B ^ n) (a, x) =
+      (a + (((n : ℝ) / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle),
+        (B ^ n) x) := by
+  cases n with
+  | ofNat
+    n =>
+    change
+      (twist m B ^ (n : ℤ)) (a, x) =
+        (a + ((((n : ℤ) : ℝ) / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle),
+          (B ^ (n : ℤ)) x)
+    simpa only [Int.cast_natCast, zpow_natCast] using twist_pow_apply m B n a x
+  | negSucc n =>
+    rw [zpow_negSucc]
+    apply (twist m B ^ (n + 1)).injective
+    change (twist m B ^ (n + 1)) ((twist m B ^ (n + 1)).symm (a, x)) = _
+    rw [Homeomorph.apply_symm_apply, twist_pow_apply]
+    apply Prod.ext
+    · change
+        a =
+          a +
+              ((((Int.negSucc n : ℤ) : ℝ) / m : ℝ) :
+                Elliptic.HigherHomology.MappingTorusQuotient.Circle) +
+            ((((n + 1 : ℕ) : ℝ) / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle)
+      have ht : (((Int.negSucc n : ℤ) : ℝ) / m : ℝ) + (((n + 1 : ℕ) : ℝ) / m : ℝ) = 0 := by
+        push_cast
+        ring
+      rw [add_assoc, ← AddCircle.coe_add, ht, AddCircle.coe_zero, add_zero]
+    · change x = (B ^ (n + 1)) ((B ^ (Int.negSucc n : ℤ)) x)
+      rw [zpow_negSucc, Homeomorph.inv_apply, Homeomorph.apply_symm_apply]
+
+private def Elliptic.HigherHomology.MappingTorusQuotient.homeomorphPermHom_mo1973_15464
+    {X : Type*} [TopologicalSpace X] : (X ≃ₜ X) →* Equiv.Perm X
+    where
+  toFun := Homeomorph.toEquiv
+  map_one' := rfl
+  map_mul' _ _ := rfl
+
+private theorem Elliptic.HigherHomology.MappingTorusQuotient.twist_pow_order {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) : twist m B ^ m = 1 := by
+  have hm : (m : ℝ) ≠ 0 := Nat.cast_ne_zero.mpr (NeZero.ne m)
+  have hc : ((1 : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle) = 0 := by
+    simpa only [Int.cast_one] using MappingTorus.circle_intCast 1
+  apply Homeomorph.ext
+  rintro ⟨a, x⟩
+  rw [twist_pow_apply]
+  simp only [div_self hm, hc, add_zero, hB, Homeomorph.one_apply]
+
+private theorem Elliptic.HigherHomology.MappingTorusQuotient.twistPerm_pow_order {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) :
+    (twist m B).toEquiv ^ m = 1 := by
+  change homeomorphPermHom_mo1973_15464 (twist m B) ^ m = 1
+  rw [← map_pow, twist_pow_order m B hB, map_one]
+
+@[instance_reducible]
+private def
+    Elliptic.HigherHomology.MappingTorusQuotient.productAction {X : Type*} [TopologicalSpace X]
+    (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) :
+    MulAction (Multiplicative (ZMod m))
+      (Elliptic.HigherHomology.MappingTorusQuotient.Circle × X) :=
+  Elliptic.CyclicAction.action (twist m B).toEquiv (twistPerm_pow_order m B hB)
+
+private theorem
+    Elliptic.HigherHomology.MappingTorusQuotient.productAction_continuousConstSMul {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) :
+    letI := productAction m B hB
+    ContinuousConstSMul (Multiplicative (ZMod m))
+      (Elliptic.HigherHomology.MappingTorusQuotient.Circle × X) := by
+  exact
+    Elliptic.CyclicAction.continuousConstSMul (twist m B).toEquiv (twistPerm_pow_order m B hB)
+      (twist m B).continuous
+
+private theorem
+    Elliptic.HigherHomology.MappingTorusQuotient.cyclicAction_ofAdd_intCast_smul {M : Type*}
+    (m : ℕ) [NeZero m] (σ : Equiv.Perm M) (hσ : σ ^ m = 1) (n : ℤ) (x : M) :
+    letI := Elliptic.CyclicAction.action σ hσ
+    Multiplicative.ofAdd (n : ZMod m) • x = (σ ^ n) x := by
+  change (σ ^ (n : ZMod m).val) x = (σ ^ n) x
+  rw [← zpow_natCast, ZMod.val_intCast, ← zpow_eq_zpow_emod' n hσ]
+
+private theorem Elliptic.HigherHomology.MappingTorusQuotient.ofAdd_intCast_smul {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) (n : ℤ)
+    (a : Elliptic.HigherHomology.MappingTorusQuotient.Circle) (x : X) :
+    letI := productAction m B hB
+    Multiplicative.ofAdd (n : ZMod m) • (a, x) =
+      (a + (((n : ℝ) / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle),
+        (B ^ n) x) := by
+  change ((twist m B).toEquiv ^ (n : ZMod m).val) (a, x) = _
+  rw [← zpow_natCast, ZMod.val_intCast, ← zpow_eq_zpow_emod' n (twistPerm_pow_order m B hB)]
+  have hp : (twist m B).toEquiv ^ n = (twist m B ^ n).toEquiv :=
+    (homeomorphPermHom_mo1973_15464.map_zpow (twist m B) n).symm
+  rw [hp]
+  exact twist_zpow_apply m B n a x
+
+private theorem Elliptic.HigherHomology.MappingTorusQuotient.fibre_zpow_add_mul_period {X : Type*}
+    [TopologicalSpace X] (m : ℕ) (B : X ≃ₜ X) (hB : B ^ m = 1) (k n : ℤ) :
+    B ^ (k + (m : ℤ) * n) = B ^ k := by
+  rw [zpow_add, zpow_mul, zpow_natCast, hB, one_zpow, mul_one]
+
+private theorem Elliptic.HigherHomology.MappingTorusQuotient.circle_scaled_eq_iff (m : ℕ) [NeZero m]
+    (s t : ℝ) (n : ℤ) :
+    ((s / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle) =
+        ((t / m + (n : ℝ) / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle) ↔
+      ∃ k : ℤ, s = t + ((n + (m : ℤ) * k : ℤ) : ℝ) := by
+  have hm : (m : ℝ) ≠ 0 := Nat.cast_ne_zero.mpr (NeZero.ne m)
+  constructor
+  · intro h
+    obtain ⟨k, hk⟩ := (MappingTorus.circle_coe_eq_iff _ _).mp h.symm
+    refine ⟨k, ?_⟩
+    push_cast
+    calc
+      s = (s / m) * m := (div_mul_cancel₀ s hm).symm
+      _ = (t / m + (n : ℝ) / m + (k : ℝ)) * m := by rw [hk]
+      _ = t + ((n : ℝ) + (m : ℝ) * k) := by
+        rw [add_mul, add_mul, div_mul_cancel₀ _ hm, div_mul_cancel₀ _ hm]
+        ring
+  · rintro ⟨k, hk⟩
+    apply Eq.symm
+    apply (MappingTorus.circle_coe_eq_iff _ _).mpr
+    refine ⟨k, ?_⟩
+    rw [hk]
+    push_cast
+    field_simp [hm]
+    ring
+
+private theorem Elliptic.HigherHomology.MappingTorusQuotient.symm_zpow_neg {X : Type*}
+    [TopologicalSpace X] (B : X ≃ₜ X) (n : ℤ) : B.symm ^ (-n) = B ^ n := by
+  change (B⁻¹) ^ (-n) = B ^ n
+  rw [inv_zpow, zpow_neg, inv_inv]
+
+private def Elliptic.LogGauge.quotientEquiv (G : Type*) [Group G] {M N : Type*} [MulAction G M]
+    [MulAction G N] (e : M ≃ N) (heq : ∀ (g : G) (x : M), e (g • x) = g • e x) :
+    Elliptic.FiniteQuotient.Space G M ≃ Elliptic.FiniteQuotient.Space G N :=
+  Quotient.congr e
+    (by
+      intro x y
+      change (x ∈ MulAction.orbit G y) ↔ (e x ∈ MulAction.orbit G (e y))
+      constructor
+      · rintro ⟨g, hg⟩
+        exact ⟨g, (heq g y).symm.trans (congrArg e hg)⟩
+      · rintro ⟨g, hg⟩
+        exact ⟨g, e.injective ((heq g y).trans hg)⟩)
+
+private theorem Elliptic.HigherHomology.MappingTorusQuotient.cyclicConjugacy_smul {M N : Type*}
+    [TopologicalSpace M] [TopologicalSpace N] {m : ℕ} [NeZero m] (σ : Equiv.Perm M)
+    (hσ : σ ^ m = 1) (τ : Equiv.Perm N) (hτ : τ ^ m = 1) (e : M ≃ₜ N)
+    (he : ∀ x, e (σ x) = τ (e x)) (g : Multiplicative (ZMod m)) (x : M) :
+    letI := Elliptic.CyclicAction.action σ hσ
+    letI := Elliptic.CyclicAction.action τ hτ
+    e (g • x) = g • e x := by
+  let := Elliptic.CyclicAction.action σ hσ
+  let := Elliptic.CyclicAction.action τ hτ
+  rw [Elliptic.CyclicAction.smul_eq_iterate σ hσ, Elliptic.CyclicAction.smul_eq_iterate τ hτ]
+  exact Function.Semiconj.iterate_right he g.toAdd.val x
+
+private def Elliptic.HigherHomology.MappingTorusQuotient.cyclicQuotientCongr {M N : Type*}
+    [TopologicalSpace M] [TopologicalSpace N] {m : ℕ} [NeZero m] (σ : Equiv.Perm M)
+    (hσ : σ ^ m = 1) (τ : Equiv.Perm N) (hτ : τ ^ m = 1) (e : M ≃ₜ N)
+    (he : ∀ x, e (σ x) = τ (e x)) :
+    letI := Elliptic.CyclicAction.action σ hσ
+    letI := Elliptic.CyclicAction.action τ hτ
+    Elliptic.FiniteQuotient.Space (Multiplicative (ZMod m)) M ≃ₜ
+      Elliptic.FiniteQuotient.Space (Multiplicative (ZMod m)) N := by
+  let := Elliptic.CyclicAction.action σ hσ
+  let := Elliptic.CyclicAction.action τ hτ
+  refine
+    { toEquiv :=
+        Elliptic.LogGauge.quotientEquiv (Multiplicative (ZMod m)) e.toEquiv
+          (cyclicConjugacy_smul σ hσ τ hτ e he)
+      continuous_toFun := ?_
+      continuous_invFun := ?_ }
+  · apply
+      (Elliptic.FiniteQuotient.project_isQuotientMap (Multiplicative (ZMod m))
+          M).continuous_iff.mpr
+    exact
+      (Elliptic.FiniteQuotient.project_continuous (Multiplicative (ZMod m)) N).comp e.continuous
+  · apply
+      (Elliptic.FiniteQuotient.project_isQuotientMap (Multiplicative (ZMod m))
+          N).continuous_iff.mpr
+    exact
+      (Elliptic.FiniteQuotient.project_continuous (Multiplicative (ZMod m)) M).comp
+        e.symm.continuous
+
+private abbrev Elliptic.HigherHomology.MappingTorusQuotient.ProductQuotient {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) :=
+  letI := productAction m B hB
+  Elliptic.FiniteQuotient.Space (Multiplicative (ZMod m))
+    (Elliptic.HigherHomology.MappingTorusQuotient.Circle × X)
+
+private def
+    Elliptic.HigherHomology.MappingTorusQuotient.project {X : Type*} [TopologicalSpace X] (m : ℕ)
+    [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1)
+    (p : Elliptic.HigherHomology.MappingTorusQuotient.Circle × X) : ProductQuotient m B hB := by
+  letI := productAction m B hB
+  exact
+    Elliptic.FiniteQuotient.project (Multiplicative (ZMod m))
+      (Elliptic.HigherHomology.MappingTorusQuotient.Circle × X) p
+
+private theorem Elliptic.HigherHomology.MappingTorusQuotient.project_surjective {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) :
+    Function.Surjective (project m B hB) := by
+  let := productAction m B hB
+  exact
+    Elliptic.FiniteQuotient.project_surjective (Multiplicative (ZMod m))
+      (Elliptic.HigherHomology.MappingTorusQuotient.Circle × X)
+
+private theorem Elliptic.HigherHomology.MappingTorusQuotient.project_continuous {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) :
+    Continuous (project m B hB) := by
+  let := productAction m B hB
+  exact
+    Elliptic.FiniteQuotient.project_continuous (Multiplicative (ZMod m))
+      (Elliptic.HigherHomology.MappingTorusQuotient.Circle × X)
+
+private theorem Elliptic.HigherHomology.MappingTorusQuotient.project_eq_iff {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1)
+    (p q : Elliptic.HigherHomology.MappingTorusQuotient.Circle × X) :
+    project m B hB p = project m B hB q ↔
+      ∃ n : ℤ,
+        p =
+          (q.1 + (((n : ℝ) / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle),
+            (B ^ n) q.2) := by
+  let := productAction m B hB
+  change
+    Elliptic.FiniteQuotient.project (Multiplicative (ZMod m))
+          (Elliptic.HigherHomology.MappingTorusQuotient.Circle × X) p =
+        Elliptic.FiniteQuotient.project (Multiplicative (ZMod m))
+          (Elliptic.HigherHomology.MappingTorusQuotient.Circle × X) q ↔
+      _
+  rw [Elliptic.FiniteQuotient.project_eq_iff_mem_orbit]
+  constructor
+  · rintro ⟨g, hg⟩
+    have he : Multiplicative.ofAdd ((g.toAdd.val : ℤ) : ZMod m) = g := by
+      apply Multiplicative.ext
+      simp
+    have hs := ofAdd_intCast_smul m B hB (g.toAdd.val : ℤ) q.1 q.2
+    rw [he] at hs
+    exact ⟨g.toAdd.val, hg.symm.trans hs⟩
+  · rintro ⟨n, hp⟩
+    refine ⟨Multiplicative.ofAdd (n : ZMod m), ?_⟩
+    change Multiplicative.ofAdd (n : ZMod m) • (q.1, q.2) = p
+    rw [ofAdd_intCast_smul]
+    exact hp.symm
+
+private def
+    Elliptic.HigherHomology.MappingTorusQuotient.cylinderMap {X : Type*} [TopologicalSpace X]
+    (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) (p : ℝ × X) : ProductQuotient m B hB :=
+  project m B hB (((p.1 / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle), p.2)
+
+private theorem Elliptic.HigherHomology.MappingTorusQuotient.cylinderMap_continuous {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) :
+    Continuous (cylinderMap m B hB) :=
+  (project_continuous m B hB).comp
+    (((AddCircle.continuous_mk' (1 : ℝ)).comp (continuous_fst.div_const (m : ℝ))).prodMk
+      continuous_snd)
+
+private theorem Elliptic.HigherHomology.MappingTorusQuotient.cylinderMap_deck {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) (n : ℤ) (p : ℝ × X) :
+    cylinderMap m B hB (MappingTorus.deck B.symm n p) = cylinderMap m B hB p := by
+  apply (project_eq_iff m B hB _ _).mpr
+  refine ⟨n, ?_⟩
+  apply Prod.ext
+  · change
+      (((p.1 + (n : ℝ)) / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle) =
+        ((p.1 / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle) +
+          (((n : ℝ) / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle)
+    rw [add_div, AddCircle.coe_add]
+  · change (B.symm ^ (-n)) p.2 = (B ^ n) p.2
+    rw [symm_zpow_neg]
+
+private def
+    Elliptic.HigherHomology.MappingTorusQuotient.mappingTorusMap {X : Type*} [TopologicalSpace X]
+    (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) :
+    MappingTorus.Torus B.symm → ProductQuotient m B hB :=
+  Quotient.lift (cylinderMap m B hB)
+    (by
+      rintro p q ⟨n, rfl⟩
+      exact (cylinderMap_deck m B hB n p).symm)
+
+@[simp]
+private theorem Elliptic.HigherHomology.MappingTorusQuotient.mappingTorusMap_mk {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) (t : ℝ) (x : X) :
+    mappingTorusMap m B hB (MappingTorus.mk B.symm (t, x)) =
+      project m B hB (((t / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle), x) :=
+  rfl
+
+private theorem Elliptic.HigherHomology.MappingTorusQuotient.mappingTorusMap_continuous {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) :
+    Continuous (mappingTorusMap m B hB) :=
+  (cylinderMap_continuous m B hB).quotient_lift _
+
+private theorem Elliptic.HigherHomology.MappingTorusQuotient.mappingTorusMap_injective {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) :
+    Function.Injective (mappingTorusMap m B hB) := by
+  intro p q h
+  obtain ⟨⟨t, x⟩, rfl⟩ := MappingTorus.mk_surjective B.symm p
+  obtain ⟨⟨s, y⟩, rfl⟩ := MappingTorus.mk_surjective B.symm q
+  change
+    project m B hB (((t / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle), x) =
+      project m B hB (((s / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle), y) at h
+  obtain ⟨n, hn⟩ := (project_eq_iff m B hB _ _).mp h
+  have hf := congrArg Prod.fst hn
+  change
+    ((t / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle) =
+      ((s / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle) +
+        (((n : ℝ) / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle) at hf
+  rw [← AddCircle.coe_add] at hf
+  obtain ⟨k, hk⟩ := (circle_scaled_eq_iff m t s n).mp hf
+  have hx : x = (B ^ n) y := congrArg Prod.snd hn
+  apply Eq.symm
+  apply (MappingTorus.mk_eq_mk_iff B.symm (s, y) (t, x)).mpr
+  refine ⟨n + (m : ℤ) * k, hk, ?_⟩
+  rw [symm_zpow_neg, fibre_zpow_add_mul_period m B hB]
+  exact hx
+
+private theorem Elliptic.HigherHomology.MappingTorusQuotient.mappingTorusMap_surjective {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) :
+    Function.Surjective (mappingTorusMap m B hB) := by
+  intro q
+  obtain ⟨⟨a, x⟩, rfl⟩ := project_surjective m B hB q
+  obtain ⟨t, rfl⟩ := QuotientAddGroup.mk_surjective a
+  refine ⟨MappingTorus.mk B.symm (t * m, x), ?_⟩
+  rw [mappingTorusMap_mk]
+  have hm : (m : ℝ) ≠ 0 := Nat.cast_ne_zero.mpr (NeZero.ne m)
+  simp only [div_eq_mul_inv, mul_assoc, mul_inv_cancel₀ hm, mul_one]
+
+private instance Elliptic.HigherHomology.MappingTorusQuotient.productQuotient_t2 {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) [CompactSpace X]
+    [T2Space X] : T2Space (ProductQuotient m B hB) := by
+  let := productAction m B hB
+  let := productAction_continuousConstSMul m B hB
+  exact
+    Elliptic.FiniteQuotient.spaceT2Space (Multiplicative (ZMod m))
+      (Elliptic.HigherHomology.MappingTorusQuotient.Circle × X)
+
+private def Elliptic.HigherHomology.MappingTorusQuotient.toProductHomeomorph {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) [CompactSpace X]
+    [T2Space X] : MappingTorus.Torus B.symm ≃ₜ ProductQuotient m B hB :=
+  Continuous.homeoOfEquivCompactToT2 (f :=
+    Equiv.ofBijective (mappingTorusMap m B hB)
+      ⟨mappingTorusMap_injective m B hB, mappingTorusMap_surjective m B hB⟩)
+    (mappingTorusMap_continuous m B hB)
+
+private def Elliptic.HigherHomology.MappingTorusQuotient.mappingTorusHomeomorph {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) [CompactSpace X]
+    [T2Space X] : ProductQuotient m B hB ≃ₜ MappingTorus.Torus B.symm :=
+  (toProductHomeomorph m B hB).symm
+
+@[simp]
+private theorem
+    Elliptic.HigherHomology.MappingTorusQuotient.mappingTorusHomeomorph_symm_mk {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) [CompactSpace X]
+    [T2Space X] (t : ℝ) (x : X) :
+    (mappingTorusHomeomorph m B hB).symm (MappingTorus.mk B.symm (t, x)) =
+      project m B hB (((t / m : ℝ) : Elliptic.HigherHomology.MappingTorusQuotient.Circle), x) :=
+  rfl
+
+private theorem
+    Elliptic.HigherHomology.MappingTorusQuotient.mappingTorusHomeomorph_project {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) [CompactSpace X]
+    [T2Space X] (t : ℝ) (x : X) :
+    mappingTorusHomeomorph m B hB
+        (project m B hB ((t : Elliptic.HigherHomology.MappingTorusQuotient.Circle), x)) =
+      MappingTorus.mk B.symm (t * m, x) := by
+  apply (mappingTorusHomeomorph m B hB).symm.injective
+  rw [Homeomorph.symm_apply_apply, mappingTorusHomeomorph_symm_mk]
+  have hm : (m : ℝ) ≠ 0 := Nat.cast_ne_zero.mpr (NeZero.ne m)
+  simp only [div_eq_mul_inv, mul_assoc, mul_inv_cancel₀ hm, mul_one]
+
+private theorem Elliptic.discPower_eq_iff_scalar_iterate (m : ℕ) (hm : 0 < m) (c : ℂ) (hc : ‖c‖ = 1)
+    (hroot : IsPrimitiveRoot c m) (z w : SpecialPeriods.Disc) :
+    discPower m hm z = discPower m hm w ↔ ∃ r < m, (SpecialPeriods.discScalar c hc)^[r] w = z := by
+  let : NeZero m := ⟨hm.ne'⟩
+  constructor
+  · intro he
+    have hp : (z : ℂ) ^ m = (w : ℂ) ^ m := congrArg Subtype.val he
+    by_cases hw : (w : ℂ) = 0
+    · have hz : (z : ℂ) = 0 :=
+        (pow_eq_zero_iff hm.ne').mp (by simpa only [hw, zero_pow hm.ne'] using hp)
+      exact ⟨0, hm, Subtype.ext (hw.trans hz.symm)⟩
+    · have hr : ((z : ℂ) / (w : ℂ)) ^ m = 1 := by rw [div_pow, hp, div_self (pow_ne_zero m hw)]
+      obtain ⟨r, hrm, hr⟩ := hroot.eq_pow_of_pow_eq_one hr
+      refine ⟨r, hrm, Subtype.ext ?_⟩
+      rw [SpecialPeriods.discScalar_iterate_val, hr, div_mul_cancel₀ _ hw]
+  · rintro ⟨r, _, rfl⟩
+    apply Subtype.ext
+    change ((SpecialPeriods.discScalar c hc)^[r] w : ℂ) ^ m = (w : ℂ) ^ m
+    rw [SpecialPeriods.discScalar_iterate_val, mul_pow, ← pow_mul, Nat.mul_comm r m, pow_mul,
+      hroot.pow_eq_one, one_pow, one_mul]
+
+private theorem Elliptic.neg_rho_isPrimitiveRoot : IsPrimitiveRoot (-SpecialPeriods.rho) 3 := by
+  apply IsPrimitiveRoot.mk_of_lt _ (by decide)
+  · calc
+      (-SpecialPeriods.rho) ^ 3 = -(SpecialPeriods.rho ^ 3) := by ring
+      _ = 1 := by rw [SpecialPeriods.rho_cube]; norm_num
+  · exact fun r hr hrm => SpecialPeriods.neg_rho_pow_ne_one hr hrm
+
+private theorem Elliptic.discPower_three_eq_iff (z w : SpecialPeriods.Disc) :
+    discPower 3 (by decide) z = discPower 3 (by decide) w ↔
+      ∃ r < 3, SpecialPeriods.discRotateThree^[r] w = z :=
+  discPower_eq_iff_scalar_iterate 3 (by decide) (-SpecialPeriods.rho)
+    (by simpa using SpecialPeriods.norm_rho) neg_rho_isPrimitiveRoot z w
+
+private theorem Elliptic.discPower_four_eq_iff (z w : SpecialPeriods.Disc) :
+    discPower 4 (by decide) z = discPower 4 (by decide) w ↔
+      ∃ r < 4, SpecialPeriods.discRotateFour^[r] w = z :=
+  discPower_eq_iff_scalar_iterate 4 (by decide) (-Complex.I) (by simp)
+    Complex.isPrimitiveRoot_neg_I z w
+
+private theorem Elliptic.discPower_eq_iff_familyRotation (j : Kind) (z w : SpecialPeriods.Disc) :
+    discPower j.order j.order_pos z = discPower j.order j.order_pos w ↔
+      ∃ r < j.order, (familyRotation j)^[r] w = z := by
+  cases j
+  · exact discPower_three_eq_iff z w
+  · exact discPower_four_eq_iff z w
+
+private theorem Elliptic.complexPower_hasDerivAt (m : ℕ) (z : ℂ) :
+    HasDerivAt (fun w : ℂ => w ^ m) ((m : ℂ) * z ^ (m - 1)) z :=
+  hasDerivAt_pow m z
+
+private theorem Elliptic.complexPower_holomorphic (m : ℕ) : ContDiff ℂ ω (fun z : ℂ => z ^ m) :=
+  contDiff_id.pow m
+
+private theorem
+    Elliptic.complexPower_coefficient_ne_zero (m : ℕ) (hm : 0 < m) (z : ℂ) (hz : z ≠ 0) :
+    (m : ℂ) * z ^ (m - 1) ≠ 0 :=
+  mul_ne_zero (by exact_mod_cast hm.ne') (pow_ne_zero _ hz)
+
+private def Elliptic.complexPowerChart (m : ℕ) (hm : 0 < m) (z : ℂ) (hz : z ≠ 0) :
+    OpenPartialHomeomorph ℂ ℂ :=
+  ((complexPower_holomorphic m).contDiffAt.toOpenPartialHomeomorph (fun w : ℂ => w ^ m)
+        ((complexPower_hasDerivAt m z).hasFDerivAt_equiv
+          (complexPower_coefficient_ne_zero m hm z hz))
+        (by simp)).restr
+    {w | w ≠ 0}
+
+private theorem Elliptic.mem_complexPowerChart_source (m : ℕ) (hm : 0 < m) (z : ℂ) (hz : z ≠ 0) :
+    z ∈ (complexPowerChart m hm z hz).source := by
+  have ho : IsOpen {w : ℂ | w ≠ 0} := isOpen_ne_fun continuous_id continuous_const
+  rw [complexPowerChart, OpenPartialHomeomorph.restr_source' _ _ ho]
+  exact
+    ⟨(complexPower_holomorphic m).contDiffAt.mem_toOpenPartialHomeomorph_source
+        ((complexPower_hasDerivAt m z).hasFDerivAt_equiv
+          (complexPower_coefficient_ne_zero m hm z hz))
+        (by simp),
+      hz⟩
+
+private theorem Elliptic.complexPowerChart_source_ne_zero (m : ℕ) (hm : 0 < m) (z : ℂ) (hz : z ≠ 0)
+    {w : ℂ} (hw : w ∈ (complexPowerChart m hm z hz).source) : w ≠ 0 := by
+  have ho : IsOpen {w : ℂ | w ≠ 0} := isOpen_ne_fun continuous_id continuous_const
+  rw [complexPowerChart, OpenPartialHomeomorph.restr_source' _ _ ho] at hw
+  exact hw.2
+
+private theorem Elliptic.complexPowerChart_holomorphic (m : ℕ) (hm : 0 < m) (z : ℂ) (hz : z ≠ 0) :
+    ContDiffOn ℂ ω (complexPowerChart m hm z hz) (complexPowerChart m hm z hz).source :=
+  (complexPower_holomorphic m).contDiffOn
+
+private theorem
+    Elliptic.complexPowerChart_symm_holomorphic (m : ℕ) (hm : 0 < m) (z : ℂ) (hz : z ≠ 0) :
+    ContDiffOn ℂ ω (complexPowerChart m hm z hz).symm (complexPowerChart m hm z hz).target := by
+  intro w hw
+  have hne :=
+    complexPowerChart_source_ne_zero m hm z hz ((complexPowerChart m hm z hz).map_target hw)
+  exact
+    ((complexPowerChart m hm z hz).contDiffAt_symm hw
+        ((complexPower_hasDerivAt m _).hasFDerivAt_equiv
+          (complexPower_coefficient_ne_zero m hm _ hne))
+        (complexPower_holomorphic m).contDiffAt).contDiffWithinAt
+
+public
+theorem Elliptic.complexPower_isLocalDiffeomorphAt (m : ℕ) (hm : 0 < m) (z : ℂ) (hz : z ≠ 0) :
+    IsLocalDiffeomorphAt (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) ω
+      (fun w : ℂ => w ^ m) z := by
+  refine
+    ⟨{  toPartialEquiv := (complexPowerChart m hm z hz).toPartialEquiv
+        open_source := (complexPowerChart m hm z hz).open_source
+        open_target := (complexPowerChart m hm z hz).open_target
+        contMDiffOn_toFun := (complexPowerChart_holomorphic m hm z hz).contMDiffOn
+        contMDiffOn_invFun := (complexPowerChart_symm_holomorphic m hm z hz).contMDiffOn },
+      mem_complexPowerChart_source m hm z hz, fun _ _ => rfl⟩
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Elliptic/Core3.lean b/LeanPool/HopfProblem/Elliptic/Core3.lean
new file mode 100644
index 000000000..9b6a58c94
--- /dev/null
+++ b/LeanPool/HopfProblem/Elliptic/Core3.lean
@@ -0,0 +1,524 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Uniformization.SpecialPeriods7
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap1
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods7
+
+/-!
+# Hopf problem: elliptic · core 3
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private structure Elliptic.Equivariant.Data (j : Elliptic.Kind) where
+  periods : HolomorphicPeriodMap ℂ SpecialPeriods.Disc
+  covariance :
+    ∀ z, periods.point (Elliptic.familyRotation j z) = Elliptic.periodStep j (periods.point z)
+
+private abbrev Elliptic.Equivariant.Data.TotalSpace {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) :=
+  D.periods.TotalSpace
+
+private def
+    Elliptic.Equivariant.Data.permutation {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) : Equiv.Perm D.TotalSpace :=
+  Elliptic.familyPermutation j v
+
+@[simp]
+private theorem Elliptic.Equivariant.Data.permutation_apply {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (x : D.TotalSpace) :
+    D.permutation v x = (Elliptic.familyRotation j x.1, Elliptic.flatTorusAffine j v x.2) :=
+  rfl
+
+private theorem Elliptic.Equivariant.Data.permutation_pow_order {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    D.permutation v ^ j.order = 1 :=
+  Elliptic.familyPermutation_pow_order j v hv
+
+@[instance_reducible]
+private def Elliptic.Equivariant.Data.action {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : j.matrix *ᵥ v = v) : MulAction (Elliptic.CyclicGroup j) D.TotalSpace :=
+  Elliptic.familyAction j v hv
+
+private theorem Elliptic.Equivariant.Data.action_apply {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (g : Elliptic.CyclicGroup j) (x : D.TotalSpace) :
+    letI := D.action v hv
+    g • x =
+      ((Elliptic.familyRotation j)^[g.toAdd.val] x.1,
+        (Elliptic.flatTorusAffine j v)^[g.toAdd.val] x.2) :=
+  Elliptic.familyAction_apply j v hv g x
+
+private theorem Elliptic.Equivariant.Data.action_free {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    letI := D.action v hv.1
+    IsCancelSMul (Elliptic.CyclicGroup j) D.TotalSpace :=
+  Elliptic.familyAction_free j v hv
+
+private theorem Elliptic.Equivariant.Data.action_continuous {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    letI := D.action v hv
+    ContinuousConstSMul (Elliptic.CyclicGroup j) D.TotalSpace :=
+  Elliptic.familyAction_continuous j v hv
+
+private theorem Elliptic.Equivariant.Data.action_discPower {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (g : Elliptic.CyclicGroup j) (x : D.TotalSpace) :
+    letI := D.action v hv
+    Elliptic.discPower j.order j.order_pos (g • x).1 =
+      Elliptic.discPower j.order j.order_pos x.1 :=
+  Elliptic.familyAction_discPower j v hv g x
+
+private def Elliptic.Equivariant.Data.centralPeriod {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) : Elliptic.FixedPeriod j :=
+  ⟨D.periods.point SpecialPeriods.discZero,
+    (D.covariance SpecialPeriods.discZero).symm.trans
+      (congrArg D.periods.point (Elliptic.familyRotation_zero j))⟩
+
+private theorem Elliptic.Equivariant.Data.periodEquiv_matrix {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (z : SpecialPeriods.Disc) (x : RealPlane₄) :
+    D.periods.periodEquiv z x = (D.periods.point z).val.matrix *ᵥ (fun i => (x i : ℂ)) := by
+  rw [HolomorphicPeriodMap.periodEquiv_coordinates]
+  ext i
+  fin_cases i <;> simp [PeriodPoint.matrix, Matrix.mulVec, dotProduct, Fin.sum_univ_four]
+
+private theorem Elliptic.Equivariant.Data.periodEquiv_eq_periodEquiv {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (z : SpecialPeriods.Disc) (x : RealPlane₄) :
+    D.periods.periodEquiv z x = Elliptic.periodEquiv (D.periods.point z) x := by
+  rw [D.periodEquiv_matrix, Elliptic.periodEquiv_matrix]
+
+private theorem Elliptic.Equivariant.Data.matrix_covariance {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (z : SpecialPeriods.Disc) :
+    (D.periods.point (Elliptic.familyRotation j z)).val.matrix *
+        j.matrix.map (Int.castRingHom ℂ) =
+      Elliptic.linearMatrix j (D.periods.point z) * (D.periods.point z).val.matrix := by
+  rw [D.covariance z]
+  cases j
+  · change
+      (D.periods.point z).val.step₁.matrix * A₁.map (Int.castRingHom ℂ) =
+        (D.periods.point z).val.R₁ * (D.periods.point z).val.matrix
+    rw [PeriodPoint.step₁_matrix _
+        ((D.periods.point z).val.τ_ne_zero (D.periods.point z).property.1),
+      Matrix.mul_assoc]
+    have h : (T₁.map (Int.castRingHom ℂ)).transpose * A₁.map (Int.castRingHom ℂ) = 1 := by
+      change T₁.transpose.map (Int.castRingHom ℂ) * A₁.map (Int.castRingHom ℂ) = 1
+      rw [← Matrix.map_mul, show T₁.transpose * A₁ = 1 by decide]
+      simp
+    rw [h, Matrix.mul_one]
+  · change
+      (D.periods.point z).val.step₂.matrix * A₂.map (Int.castRingHom ℂ) =
+        (D.periods.point z).val.R₂ * (D.periods.point z).val.matrix
+    rw [PeriodPoint.step₂_matrix _
+        ((D.periods.point z).val.τ_ne_zero (D.periods.point z).property.1),
+      Matrix.mul_assoc]
+    have h : (T₂.map (Int.castRingHom ℂ)).transpose * A₂.map (Int.castRingHom ℂ) = 1 := by
+      change T₂.transpose.map (Int.castRingHom ℂ) * A₂.map (Int.castRingHom ℂ) = 1
+      rw [← Matrix.map_mul, show T₂.transpose * A₂ = 1 by decide]
+      simp
+    rw [h, Matrix.mul_one]
+
+private theorem Elliptic.Equivariant.Data.periodEquiv_flatLinear {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (z : SpecialPeriods.Disc) (x : RealPlane₄) :
+    D.periods.periodEquiv (Elliptic.familyRotation j z) (Elliptic.flatLinear j x) =
+      Elliptic.linearMatrix j (D.periods.point z) *ᵥ D.periods.periodEquiv z x := by
+  rw [D.periodEquiv_matrix, Elliptic.flatLinear_complexCast, Matrix.mulVec_mulVec,
+    D.periodEquiv_matrix, Matrix.mulVec_mulVec, D.matrix_covariance]
+
+private theorem Elliptic.Equivariant.Data.periodEquiv_symm_linearMatrix {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (z : SpecialPeriods.Disc) (w : ComplexPlane₂) :
+    (D.periods.periodEquiv (Elliptic.familyRotation j z)).symm
+        (Elliptic.linearMatrix j (D.periods.point z) *ᵥ w) =
+      Elliptic.flatLinear j ((D.periods.periodEquiv z).symm w) := by
+  apply (D.periods.periodEquiv (Elliptic.familyRotation j z)).injective
+  rw [LinearEquiv.apply_symm_apply, D.periodEquiv_flatLinear, LinearEquiv.apply_symm_apply]
+
+@[instance_reducible]
+private def Elliptic.Equivariant.Data.equivariantCoveringChartedSpace :
+    ChartedSpace Elliptic.FamilyModel (SpecialPeriods.Disc × ComplexPlane₂) :=
+  inferInstanceAs (ChartedSpace (ModelProd ℂ ComplexPlane₂) (SpecialPeriods.Disc × ComplexPlane₂))
+
+attribute [local instance] Elliptic.Equivariant.Data.equivariantCoveringChartedSpace in
+private theorem Elliptic.Equivariant.Data.equivariantCoveringManifold :
+    IsManifold (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω
+      (SpecialPeriods.Disc × ComplexPlane₂) := by
+  rw [modelWithCornersSelf_prod]
+  exact
+    IsManifold.prod (I := modelWithCornersSelf ℂ ℂ) (I' := modelWithCornersSelf ℂ ComplexPlane₂)
+      SpecialPeriods.Disc ComplexPlane₂
+
+attribute [local instance] Elliptic.Equivariant.Data.equivariantCoveringChartedSpace
+    Elliptic.Equivariant.Data.equivariantCoveringManifold in
+private def
+    Elliptic.Equivariant.Data.complexLift {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (x : SpecialPeriods.Disc × ComplexPlane₂) :
+    SpecialPeriods.Disc × ComplexPlane₂ :=
+  (Elliptic.familyRotation j x.1,
+    Elliptic.linearMatrix j (D.periods.point x.1) *ᵥ x.2 +
+      D.periods.periodEquiv (Elliptic.familyRotation j x.1)
+        ((1 / (j.order : ℝ)) • Elliptic.realCast v))
+
+attribute [local instance] Elliptic.Equivariant.Data.equivariantCoveringChartedSpace
+    Elliptic.Equivariant.Data.equivariantCoveringManifold in
+private theorem Elliptic.Equivariant.Data.complexLift_quotientMap {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (x : SpecialPeriods.Disc × ComplexPlane₂) :
+    D.periods.quotientMap (D.complexLift v x) = D.permutation v (D.periods.quotientMap x) := by
+  change
+    (Elliptic.familyRotation j x.1,
+        standardLattice.mkQ
+          ((D.periods.periodEquiv (Elliptic.familyRotation j x.1)).symm
+            (Elliptic.linearMatrix j (D.periods.point x.1) *ᵥ x.2 +
+              D.periods.periodEquiv (Elliptic.familyRotation j x.1)
+                ((1 / (j.order : ℝ)) • Elliptic.realCast v)))) =
+      (Elliptic.familyRotation j x.1,
+        Elliptic.flatTorusAffine j v (standardLattice.mkQ ((D.periods.periodEquiv x.1).symm x.2)))
+  rw [Elliptic.flatTorusAffine_mkQ, map_add, LinearEquiv.symm_apply_apply,
+    D.periodEquiv_symm_linearMatrix]
+  rfl
+
+attribute [local instance] Elliptic.Equivariant.Data.equivariantCoveringChartedSpace
+    Elliptic.Equivariant.Data.equivariantCoveringManifold in
+private theorem Elliptic.Equivariant.Data.linearLift_holomorphic {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) :
+    ContMDiff (modelWithCornersSelf ℂ Elliptic.FamilyModel) (modelWithCornersSelf ℂ ComplexPlane₂)
+      ω
+      (fun x : SpecialPeriods.Disc × ComplexPlane₂ =>
+        Elliptic.linearMatrix j (D.periods.point x.1) *ᵥ x.2) := by
+  have hf :
+    ContMDiff (modelWithCornersSelf ℂ Elliptic.FamilyModel) (modelWithCornersSelf ℂ ℂ) ω
+      (Prod.fst : SpecialPeriods.Disc × ComplexPlane₂ → SpecialPeriods.Disc) := by
+    rw [modelWithCornersSelf_prod]
+    exact contMDiff_fst
+  have hs :
+    ContMDiff (modelWithCornersSelf ℂ Elliptic.FamilyModel) (modelWithCornersSelf ℂ ComplexPlane₂)
+      ω (Prod.snd : SpecialPeriods.Disc × ComplexPlane₂ → ComplexPlane₂) := by
+    rw [modelWithCornersSelf_prod]
+    exact contMDiff_snd
+  have hτ := D.periods.holomorphic_tau.comp hf
+  have hμ := D.periods.holomorphic_mu.comp hf
+  have hτ0 : ∀ x : SpecialPeriods.Disc × ComplexPlane₂, (D.periods.point x.1).val.τ ≠ 0 :=
+    fun x => (D.periods.point x.1).val.τ_ne_zero (D.periods.point x.1).property.1
+  have h₀ := (contMDiff_pi_space.mp hs) 0
+  have h₁ := (contMDiff_pi_space.mp hs) 1
+  cases j
+  · apply contMDiff_pi_space.mpr
+    intro i
+    fin_cases i
+    · convert (((contMDiff_const (c := (-1 : ℂ))).div₀ hτ hτ0).mul h₀) using 1
+      funext x
+      simp [Elliptic.linearMatrix, PeriodPoint.R₁, Matrix.mulVec, dotProduct, Fin.sum_univ_two,
+        Function.comp_def]
+    · convert (((((contMDiff_const (c := (1 : ℂ))).sub hμ).div₀ hτ hτ0).mul h₀).add h₁) using 1
+      funext x
+      simp [Elliptic.linearMatrix, PeriodPoint.R₁, Matrix.mulVec, dotProduct, Fin.sum_univ_two,
+        Function.comp_def]
+  · apply contMDiff_pi_space.mpr
+    intro i
+    fin_cases i
+    · convert (((contMDiff_const (c := (1 : ℂ))).div₀ hτ hτ0).mul h₀) using 1
+      funext x
+      simp [Elliptic.linearMatrix, PeriodPoint.R₂, Matrix.mulVec, dotProduct, Fin.sum_univ_two,
+        Function.comp_def]
+    · convert (((hμ.neg.div₀ hτ hτ0).mul h₀).add h₁) using 1
+      funext x
+      simp [Elliptic.linearMatrix, PeriodPoint.R₂, Matrix.mulVec, dotProduct, Fin.sum_univ_two,
+        Function.comp_def]
+
+attribute [local instance] Elliptic.Equivariant.Data.equivariantCoveringChartedSpace
+    Elliptic.Equivariant.Data.equivariantCoveringManifold in
+private theorem Elliptic.Equivariant.Data.complexLift_holomorphic {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) :
+    ContMDiff (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω (D.complexLift v) := by
+  have hf :
+    ContMDiff (modelWithCornersSelf ℂ Elliptic.FamilyModel) (modelWithCornersSelf ℂ ℂ) ω
+      (fun x : SpecialPeriods.Disc × ComplexPlane₂ => Elliptic.familyRotation j x.1) := by
+    rw [modelWithCornersSelf_prod]
+    exact (Elliptic.familyRotation j).contMDiff_toFun.comp contMDiff_fst
+  have hw :=
+    D.linearLift_holomorphic.add
+      ((D.periods.holomorphic_periodEquiv_const ((1 / (j.order : ℝ)) • Elliptic.realCast v)).comp
+        hf)
+  rw [modelWithCornersSelf_prod] at hf hw ⊢
+  exact hf.prodMk hw
+
+attribute [local instance] Elliptic.Equivariant.Data.equivariantCoveringChartedSpace
+    Elliptic.Equivariant.Data.equivariantCoveringManifold in
+private theorem Elliptic.Equivariant.Data.permutation_holomorphic {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) :
+    letI := D.periods.totalChartedSpace
+    ContMDiff (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω (D.permutation v) := by
+  let := D.periods.coveringAction
+  let := D.periods.totalChartedSpace
+  apply
+    CoveringQuotient.contMDiff_of_comp (E := Elliptic.FamilyModel) D.periods.quotientCoveringMap
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω
+  have h := D.periods.quotientMap_holomorphic.comp (D.complexLift_holomorphic v)
+  convert! h using 1
+  funext x
+  exact (D.complexLift_quotientMap v x).symm
+
+attribute [local instance] Elliptic.Equivariant.Data.equivariantCoveringChartedSpace
+    Elliptic.Equivariant.Data.equivariantCoveringManifold in
+private theorem Elliptic.Equivariant.Data.action_holomorphic {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (g : Elliptic.CyclicGroup j) :
+    letI := D.periods.totalChartedSpace
+    letI := D.action v hv
+    ContMDiff (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω (fun x : D.TotalSpace => g • x) := by
+  let := D.periods.totalChartedSpace
+  exact
+    Elliptic.CyclicAction.smul_contMDiff (D.permutation v) (D.permutation_pow_order v hv)
+      (D.permutation_holomorphic v) g
+
+public
+theorem
+    Elliptic.Equivariant.Data.discLocallyCompact : LocallyCompactSpace SpecialPeriods.Disc :=
+  SpecialPeriods.unitDisc.isOpen.locallyCompactSpace
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+private def Elliptic.Equivariant.Data.upstairsProjection {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (x : D.TotalSpace) : SpecialPeriods.Disc :=
+  Elliptic.discPower j.order j.order_pos x.1
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+private theorem Elliptic.Equivariant.Data.upstairsProjection_surjective {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) : Function.Surjective D.upstairsProjection :=
+  (Elliptic.discPower_surjective j.order j.order_pos).comp D.periods.projection_surjective
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+private theorem Elliptic.Equivariant.Data.upstairsProjection_proper {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) : IsProperMap D.upstairsProjection :=
+  (Elliptic.discPower_isProperMap j.order j.order_pos).comp D.periods.projection_proper
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+private theorem Elliptic.Equivariant.Data.upstairsProjection_invariant {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (g : Elliptic.CyclicGroup j) (x : D.TotalSpace) :
+    letI := D.action v hv
+    D.upstairsProjection (g • x) = D.upstairsProjection x :=
+  D.action_discPower v hv g x
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+private def Elliptic.Equivariant.Data.Space {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) : Type :=
+  @Elliptic.FiniteQuotient.Space (Elliptic.CyclicGroup j) D.TotalSpace _ (D.action v hv.1)
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+private instance Elliptic.Equivariant.Data.spaceTopology {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    TopologicalSpace (D.Space v hv) :=
+  inferInstanceAs
+    (TopologicalSpace
+      (@Elliptic.FiniteQuotient.Space (Elliptic.CyclicGroup j) D.TotalSpace _ (D.action v hv.1)))
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+private def Elliptic.Equivariant.Data.quotient {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) : D.TotalSpace → D.Space v hv :=
+  @Elliptic.FiniteQuotient.project (Elliptic.CyclicGroup j) D.TotalSpace _ (D.action v hv.1)
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+private theorem Elliptic.Equivariant.Data.quotient_surjective {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    Function.Surjective (D.quotient v hv) :=
+  Quotient.mk_surjective
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+private theorem Elliptic.Equivariant.Data.quotient_continuous {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    Continuous (D.quotient v hv) := by
+  let := D.action v hv.1
+  exact Elliptic.FiniteQuotient.project_continuous (Elliptic.CyclicGroup j) D.TotalSpace
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+private theorem Elliptic.Equivariant.Data.quotient_eq_iff_mem_orbit {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (x y : D.TotalSpace) :
+    letI := D.action v hv.1
+    D.quotient v hv x = D.quotient v hv y ↔ x ∈ MulAction.orbit (Elliptic.CyclicGroup j) y := by
+  let := D.action v hv.1
+  exact Elliptic.FiniteQuotient.project_eq_iff_mem_orbit (Elliptic.CyclicGroup j) D.TotalSpace x y
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+@[simp]
+private theorem Elliptic.Equivariant.Data.quotient_smul {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (g : Elliptic.CyclicGroup j) (x : D.TotalSpace) :
+    letI := D.action v hv.1
+    D.quotient v hv (g • x) = D.quotient v hv x := by
+  let := D.action v hv.1
+  exact Elliptic.FiniteQuotient.project_smul (Elliptic.CyclicGroup j) D.TotalSpace g x
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+private instance
+    Elliptic.Equivariant.Data.spaceT2 {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) : T2Space (D.Space v hv) := by
+  let := D.action v hv.1
+  let := D.action_continuous v hv.1
+  exact Elliptic.FiniteQuotient.spaceT2Space (Elliptic.CyclicGroup j) D.TotalSpace
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+private instance Elliptic.Equivariant.Data.spaceSecondCountable {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    SecondCountableTopology (D.Space v hv) := by
+  let := D.action v hv.1
+  let := D.action_continuous v hv.1
+  exact Elliptic.FiniteQuotient.spaceSecondCountableTopology (Elliptic.CyclicGroup j) D.TotalSpace
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+private theorem Elliptic.Equivariant.Data.quotientCoveringMap {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    letI := D.action v hv.1
+    IsQuotientCoveringMap (D.quotient v hv) (Elliptic.CyclicGroup j) := by
+  let := D.action v hv.1
+  let := D.action_continuous v hv.1
+  let := D.action_free v hv
+  exact
+    Elliptic.FiniteQuotient.project_isQuotientCoveringMap (Elliptic.CyclicGroup j) D.TotalSpace
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+private theorem Elliptic.Equivariant.Data.quotient_isCoveringMap {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    IsCoveringMap (D.quotient v hv) := by
+  let := D.action v hv.1
+  exact (D.quotientCoveringMap v hv).isCoveringMap
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+@[instance_reducible]
+private def
+    Elliptic.Equivariant.Data.chartedSpace {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    ChartedSpace Elliptic.FamilyModel (D.Space v hv) := by
+  let := D.periods.totalChartedSpace
+  let := D.action v hv.1
+  exact CoveringQuotient.chartedSpace (E := Elliptic.FamilyModel) (D.quotientCoveringMap v hv)
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+private theorem
+    Elliptic.Equivariant.Data.isManifold {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    letI := D.chartedSpace v hv
+    IsManifold (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω (D.Space v hv) := by
+  let := D.periods.totalChartedSpace
+  let := D.periods.totalSpace_isManifold
+  let := D.action v hv.1
+  exact CoveringQuotient.isManifold (D.quotientCoveringMap v hv) ω (D.action_holomorphic v hv.1)
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+private theorem Elliptic.Equivariant.Data.quotient_holomorphic {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    letI := D.periods.totalChartedSpace
+    letI := D.chartedSpace v hv
+    ContMDiff (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω (D.quotient v hv) := by
+  let := D.periods.totalChartedSpace
+  let := D.periods.totalSpace_isManifold
+  let := D.action v hv.1
+  exact
+    CoveringQuotient.contMDiff_project (D.quotientCoveringMap v hv) ω
+      (D.action_holomorphic v hv.1)
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+private theorem Elliptic.Equivariant.Data.quotient_fibre_card {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (y : D.Space v hv) : Nat.card (D.quotient v hv ⁻¹' { y }) = j.order := by
+  let := D.action v hv.1
+  let := D.action_continuous v hv.1
+  let := D.action_free v hv
+  calc
+    _ = Nat.card (Elliptic.CyclicGroup j) :=
+      Elliptic.FiniteQuotient.fibre_card (Elliptic.CyclicGroup j) D.TotalSpace y
+    _ = j.order := by simp [Elliptic.CyclicGroup, Nat.card_eq_fintype_card, ZMod.card]
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+private def
+    Elliptic.Equivariant.Data.projection {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) : D.Space v hv → SpecialPeriods.Disc := by
+  let := D.action v hv.1
+  exact
+    Elliptic.FiniteQuotient.descend D.upstairsProjection (D.upstairsProjection_invariant v hv.1)
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+@[simp]
+private theorem Elliptic.Equivariant.Data.projection_quotient {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (x : D.TotalSpace) :
+    D.projection v hv (D.quotient v hv x) = Elliptic.discPower j.order j.order_pos x.1 :=
+  rfl
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+private theorem Elliptic.Equivariant.Data.projection_surjective {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    Function.Surjective (D.projection v hv) := by
+  let := D.action v hv.1
+  exact
+    Elliptic.FiniteQuotient.descend_surjective D.upstairsProjection
+      (D.upstairsProjection_invariant v hv.1) D.upstairsProjection_surjective
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+private theorem Elliptic.Equivariant.Data.projection_proper {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    IsProperMap (D.projection v hv) := by
+  let := D.action v hv.1
+  exact
+    Elliptic.FiniteQuotient.descend_isProperMap D.upstairsProjection
+      (D.upstairsProjection_invariant v hv.1) D.upstairsProjection_proper
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+private theorem Elliptic.Equivariant.Data.projection_continuous {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    Continuous (D.projection v hv) :=
+  (D.projection_proper v hv).continuous
+
+attribute [local instance] Elliptic.Equivariant.Data.discLocallyCompact in
+private theorem Elliptic.Equivariant.Data.projection_central_fibre {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    D.projection v hv ⁻¹' { Elliptic.discZero } =
+      D.quotient v hv '' {x : D.TotalSpace | x.1 = Elliptic.discZero} := by
+  let := D.action v hv.1
+  change
+    Elliptic.FiniteQuotient.descend D.upstairsProjection
+          (D.upstairsProjection_invariant v hv.1) ⁻¹'
+        { Elliptic.discZero } =
+      _
+  rw [Elliptic.FiniteQuotient.descend_preimage_eq_image]
+  congr 1
+  ext x
+  exact Elliptic.discPower_eq_zero_iff j.order j.order_pos x.1
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Elliptic/Core4.lean b/LeanPool/HopfProblem/Elliptic/Core4.lean
new file mode 100644
index 000000000..000d162a7
--- /dev/null
+++ b/LeanPool/HopfProblem/Elliptic/Core4.lean
@@ -0,0 +1,1303 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Uniformization.CuspUniformization3
+public import LeanPool.HopfProblem.Recognition.Degree2
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap1
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.Recognition.Degree2
+import all LeanPool.HopfProblem.Elliptic.Core3
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization3
+
+/-!
+# Hopf problem: elliptic · core 4
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def Elliptic.LogGauge.baseOpen : TopologicalSpace.Opens SpecialPeriods.Disc :=
+  ⟨{z | (z : ℂ) ≠ 0}, isOpen_ne_fun continuous_subtype_val continuous_const⟩
+
+private abbrev Elliptic.LogGauge.BaseStar :=
+  baseOpen
+
+private def
+    Elliptic.LogGauge.familyOpen : TopologicalSpace.Opens (SpecialPeriods.Disc × RealTorus₄) :=
+  ⟨{x | (x.1 : ℂ) ≠ 0},
+    isOpen_ne_fun (continuous_subtype_val.comp continuous_fst) continuous_const⟩
+
+private abbrev Elliptic.LogGauge.FamilyStar (_P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc) :=
+  familyOpen
+
+private def
+    Elliptic.LogGauge.coverOpen : TopologicalSpace.Opens (SpecialPeriods.Disc × ComplexPlane₂) :=
+  ⟨{x | (x.1 : ℂ) ≠ 0},
+    isOpen_ne_fun (continuous_subtype_val.comp continuous_fst) continuous_const⟩
+
+private abbrev Elliptic.LogGauge.CoverStar :=
+  coverOpen
+
+private def
+    Elliptic.LogGauge.project (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc) (x : CoverStar) :
+    FamilyStar P :=
+  ⟨P.quotientMap x, x.2⟩
+
+private theorem
+    Elliptic.LogGauge.project_surjective (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc) :
+    Function.Surjective (project P) := by
+  intro x
+  obtain ⟨y, hy⟩ := P.quotientMap_surjective x.1
+  have hy0 : (y.1 : ℂ) ≠ 0 := by
+    have hb : y.1 = x.1.1 := congrArg Prod.fst hy
+    rw [hb]
+    exact x.2
+  exact ⟨⟨y, hy0⟩, Subtype.ext hy⟩
+
+private def
+    Elliptic.LogGauge.periodVector (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc) (v : Lattice)
+    (z : SpecialPeriods.Disc) : ComplexPlane₂ :=
+  P.periodEquiv z (Elliptic.realCast v)
+
+@[simp]
+private theorem Elliptic.LogGauge.periodVector_neg (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc)
+    (v : Lattice) (z : SpecialPeriods.Disc) : periodVector P (-v) z = -periodVector P v z := by
+  change P.periodEquiv z (Elliptic.realCast (-v)) = -P.periodEquiv z (Elliptic.realCast v)
+  rw [show Elliptic.realCast (-v) = -Elliptic.realCast v by ext i; simp [Elliptic.realCast],
+    map_neg]
+
+private theorem Elliptic.LogGauge.periodVector_mem_lattice
+    (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc) (v : Lattice) (z : SpecialPeriods.Disc) :
+    periodVector P v z ∈ (P.point z).lattice := by
+  rw [← P.periodEquiv_map_lattice z]
+  exact
+    Submodule.mem_map.mpr
+      ⟨Elliptic.realCast v, (Elliptic.standardLattice_mem_iff _).mpr ⟨v, rfl⟩, rfl⟩
+
+private theorem Elliptic.LogGauge.periodVector_holomorphic
+    (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc) (v : Lattice) :
+    ContMDiff (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ComplexPlane₂) ω
+      (periodVector P v) :=
+  P.holomorphic_periodEquiv_const (Elliptic.realCast v)
+
+private theorem Elliptic.LogGauge.quotientMap_integer_period
+    (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc) (v : Lattice) (z : SpecialPeriods.Disc)
+    (u : ComplexPlane₂) (a : ℂ) (n : ℤ) :
+    P.quotientMap (z, u + (a + n) • periodVector P v z) =
+      P.quotientMap (z, u + a • periodVector P v z) := by
+  rw [← P.fibreInclusion_mkQ, ← P.fibreInclusion_mkQ]
+  apply congrArg (P.fibreInclusion z)
+  apply (Submodule.Quotient.eq _).mpr
+  have hp := (P.point z).lattice.smul_mem n (periodVector_mem_lattice P v z)
+  convert hp using 1
+  rw [add_smul, Int.cast_smul_eq_zsmul]
+  abel
+
+private theorem Elliptic.LogGauge.quotientMap_eq_of_scalar_int
+    (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc) (v : Lattice) (z : SpecialPeriods.Disc)
+    (u : ComplexPlane₂) {a b : ℂ} (hab : ∃ n : ℤ, a = b + n) :
+    P.quotientMap (z, u + a • periodVector P v z) =
+      P.quotientMap (z, u + b • periodVector P v z) := by
+  obtain ⟨n, rfl⟩ := hab
+  exact quotientMap_integer_period P v z u b n
+
+private def Elliptic.LogGauge.sectionCoordinate (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc)
+    (v : Lattice) (z : SpecialPeriods.Disc) : RealTorus₄ :=
+  standardLattice.mkQ
+    ((P.periodEquiv z).symm (CuspUniformization.logarithm z • periodVector P v z))
+
+@[simp]
+private theorem
+    Elliptic.LogGauge.sectionCoordinate_neg (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc)
+    (v : Lattice) (z : SpecialPeriods.Disc) :
+    sectionCoordinate P (-v) z = -sectionCoordinate P v z := by
+  simp only [sectionCoordinate, periodVector_neg, smul_neg, map_neg]
+
+private def
+    Elliptic.LogGauge.gaugeMap (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc) (v : Lattice)
+    (x : FamilyStar P) : FamilyStar P :=
+  ⟨(x.1.1, x.1.2 + sectionCoordinate P v x.1.1), x.2⟩
+
+@[simp]
+private theorem
+    Elliptic.LogGauge.gaugeMap_neg_gaugeMap (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc)
+    (v : Lattice) (x : FamilyStar P) : gaugeMap P (-v) (gaugeMap P v x) = x := by
+  apply Subtype.ext
+  apply Prod.ext
+  · rfl
+  · change (x.1.2 + sectionCoordinate P v x.1.1) + sectionCoordinate P (-v) x.1.1 = x.1.2
+    rw [sectionCoordinate_neg, add_neg_cancel_right]
+
+private def
+    Elliptic.LogGauge.gaugeEquiv (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc) (v : Lattice) :
+    Equiv.Perm (FamilyStar P) where
+  toFun := gaugeMap P v
+  invFun := gaugeMap P (-v)
+  left_inv := gaugeMap_neg_gaugeMap P v
+  right_inv x := by simpa only [neg_neg] using gaugeMap_neg_gaugeMap P (-v) x
+
+private def
+    Elliptic.LogGauge.gaugeLift (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc) (v : Lattice)
+    (a : ℂ → ℂ) (x : CoverStar) : CoverStar :=
+  ⟨(x.1.1, x.1.2 + a x.1.1 • periodVector P v x.1.1), x.2⟩
+
+@[simp]
+private theorem Elliptic.LogGauge.gaugeMap_project (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc)
+    (v : Lattice) (x : CoverStar) :
+    gaugeMap P v (project P x) = project P (gaugeLift P v CuspUniformization.logarithm x) := by
+  apply Subtype.ext
+  apply Prod.ext
+  · rfl
+  change
+    standardLattice.mkQ ((P.periodEquiv x.1.1).symm x.1.2) +
+        standardLattice.mkQ
+          ((P.periodEquiv x.1.1).symm
+            (CuspUniformization.logarithm x.1.1 • periodVector P v x.1.1)) =
+      standardLattice.mkQ
+        ((P.periodEquiv x.1.1).symm
+          (x.1.2 + CuspUniformization.logarithm x.1.1 • periodVector P v x.1.1))
+  rw [map_add, map_add]
+
+private theorem Elliptic.LogGauge.gaugeMap_project_localLog
+    (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc) (v : Lattice) {z₀ : ℂ} (hz₀ : z₀ ≠ 0)
+    (x : CoverStar) :
+    gaugeMap P v (project P x) = project P (gaugeLift P v (CuspUniformization.localLog z₀) x) := by
+  rw [gaugeMap_project]
+  apply Subtype.ext
+  exact
+    quotientMap_eq_of_scalar_int P v x.1.1 x.1.2
+      (CuspUniformization.logarithm_eq_localLog_add_int hz₀ x.2)
+
+private def Elliptic.LogGauge.zeroSection (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc)
+    (z : BaseStar) : FamilyStar P :=
+  ⟨(z.1, 0), z.2⟩
+
+private def
+    Elliptic.LogGauge.sectionMap (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc) (v : Lattice) :
+    BaseStar → FamilyStar P :=
+  gaugeMap P v ∘ zeroSection P
+
+private theorem
+    Elliptic.LogGauge.sectionMap_formula (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc)
+    (v : Lattice) (z : BaseStar) :
+    (sectionMap P v z : P.TotalSpace) =
+      P.quotientMap (z.1, CuspUniformization.logarithm z.1 • periodVector P v z.1) := by
+  apply Prod.ext
+  · rfl
+  · exact zero_add _
+
+private def Elliptic.LogGauge.starPermutation {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) : Equiv.Perm (FamilyStar D.periods) :=
+  (D.permutation v).subtypeEquiv
+    (fun x => by
+      change (x.1 : ℂ) ≠ 0 ↔ (Elliptic.familyRotation j x.1 : ℂ) ≠ 0
+      rw [familyRotation_val_exponential, mul_ne_zero_iff]
+      exact ⟨fun hx => ⟨CuspUniformization.exponential_ne_zero _, hx⟩, fun hx => hx.2⟩)
+
+@[simp]
+private theorem Elliptic.LogGauge.starPermutation_coe {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (x : FamilyStar D.periods) :
+    (starPermutation D v x : D.TotalSpace) = D.permutation v x :=
+  rfl
+
+private def
+    Elliptic.LogGauge.starLift {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j) (v : Lattice)
+    (x : CoverStar) : CoverStar :=
+  ⟨D.complexLift v x, familyRotation_ne_zero j x.1.1 x.2⟩
+
+@[simp]
+private theorem Elliptic.LogGauge.starPermutation_project {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (x : CoverStar) :
+    starPermutation D v (project D.periods x) = project D.periods (starLift D v x) := by
+  apply Subtype.ext
+  exact (D.complexLift_quotientMap v x).symm
+
+private theorem Elliptic.LogGauge.periodVector_covariance {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (z : SpecialPeriods.Disc) :
+    Elliptic.linearMatrix j (D.periods.point z) *ᵥ periodVector D.periods v z =
+      periodVector D.periods v (Elliptic.familyRotation j z) := by
+  have h := D.periodEquiv_flatLinear z (Elliptic.realCast v)
+  rw [Elliptic.flatLinear_fixes_realCast j v hv] at h
+  exact h.symm
+
+private theorem Elliptic.LogGauge.complexLift_translation {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (z : SpecialPeriods.Disc) :
+    D.periods.periodEquiv z ((1 / (j.order : ℝ)) • Elliptic.realCast v) =
+      (1 / (j.order : ℂ)) • periodVector D.periods v z := by
+  rw [map_smul]
+  ext i
+  simp only [periodVector, Pi.smul_apply, Complex.real_smul, Complex.ofReal_div,
+    Complex.ofReal_one, Complex.ofReal_natCast, smul_eq_mul]
+
+private theorem Elliptic.LogGauge.complexLift_formula {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (z : SpecialPeriods.Disc)
+    (u : ComplexPlane₂) :
+    D.complexLift v (z, u) =
+      (Elliptic.familyRotation j z,
+        Elliptic.linearMatrix j (D.periods.point z) *ᵥ u +
+          (1 / (j.order : ℂ)) • periodVector D.periods v (Elliptic.familyRotation j z)) := by
+  unfold Elliptic.Equivariant.Data.complexLift
+  rw [complexLift_translation]
+
+private theorem
+    Elliptic.LogGauge.periodVector_zero {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (z : SpecialPeriods.Disc) : periodVector D.periods 0 z = 0 := by
+  change D.periods.periodEquiv z (Elliptic.realCast 0) = 0
+  rw [show Elliptic.realCast 0 = 0 by ext i; simp [Elliptic.realCast], map_zero]
+
+private theorem Elliptic.LogGauge.gaugeLift_starLift_project {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v) (x : CoverStar) :
+    project D.periods (gaugeLift D.periods v CuspUniformization.logarithm (starLift D v x)) =
+      project D.periods (starLift D 0 (gaugeLift D.periods v CuspUniformization.logarithm x)) := by
+  apply Subtype.ext
+  change
+    D.periods.quotientMap
+        (Elliptic.familyRotation j x.1.1,
+          (D.complexLift v x.1).2 +
+            CuspUniformization.logarithm (Elliptic.familyRotation j x.1.1 : ℂ) •
+              periodVector D.periods v (Elliptic.familyRotation j x.1.1)) =
+      D.periods.quotientMap
+        (D.complexLift 0
+          (x.1.1,
+            x.1.2 + CuspUniformization.logarithm (x.1.1 : ℂ) • periodVector D.periods v x.1.1))
+  rw [show x.1 = (x.1.1, x.1.2) by rfl, complexLift_formula, complexLift_formula]
+  simp only [periodVector_zero, smul_zero, add_zero, Matrix.mulVec_add, Matrix.mulVec_smul,
+    periodVector_covariance D v hv]
+  rw [add_assoc, ← add_smul]
+  apply
+    quotientMap_eq_of_scalar_int D.periods v (Elliptic.familyRotation j x.1.1)
+      (Elliptic.linearMatrix j (D.periods.point x.1.1) *ᵥ x.1.2)
+  obtain ⟨n, hn⟩ := logarithm_familyRotation j x.1.1 x.2
+  exact ⟨n, by rw [hn]; ring⟩
+
+private theorem Elliptic.LogGauge.gaugeMap_intertwines {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (x : FamilyStar D.periods) :
+    gaugeMap D.periods v (starPermutation D v x) = starPermutation D 0 (gaugeMap D.periods v x) :=
+  by
+  obtain ⟨y, rfl⟩ := project_surjective D.periods x
+  rw [starPermutation_project, gaugeMap_project, gaugeMap_project, starPermutation_project]
+  exact gaugeLift_starLift_project D v hv y
+
+private theorem Elliptic.LogGauge.starPermutation_iterate_coe {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (r : ℕ) (x : FamilyStar D.periods) :
+    ((starPermutation D v)^[r] x : D.TotalSpace) = (D.permutation v)^[r] x := by
+  induction r with
+  | zero => rfl
+  | succ r ih =>
+    rw [Function.iterate_succ_apply', Function.iterate_succ_apply', starPermutation_coe, ih]
+
+private theorem Elliptic.LogGauge.starPermutation_pow_order {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    starPermutation D v ^ j.order = 1 := by
+  apply Equiv.ext
+  intro x
+  apply Subtype.ext
+  change ((starPermutation D v ^ j.order) x : D.TotalSpace) = x
+  rw [Equiv.Perm.coe_pow, starPermutation_iterate_coe, ← Equiv.Perm.coe_pow,
+    D.permutation_pow_order v hv]
+  rfl
+
+@[instance_reducible]
+private def Elliptic.LogGauge.starAction {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    MulAction (Elliptic.CyclicGroup j) (FamilyStar D.periods) :=
+  Elliptic.CyclicAction.action (starPermutation D v) (starPermutation_pow_order D v hv)
+
+private theorem
+    Elliptic.LogGauge.starAction_coe {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : j.matrix *ᵥ v = v) (g : Elliptic.CyclicGroup j)
+    (x : FamilyStar D.periods) :
+    letI := D.action v hv
+    letI := starAction D v hv
+    ((g • x : FamilyStar D.periods) : D.TotalSpace) = g • (x : D.TotalSpace) := by
+  let := D.action v hv
+  let := starAction D v hv
+  change
+    ((starPermutation D v ^ g.toAdd.val) x : D.TotalSpace) =
+      (D.permutation v ^ g.toAdd.val) (x : D.TotalSpace)
+  rw [Equiv.Perm.coe_pow, starPermutation_iterate_coe, Equiv.Perm.coe_pow]
+
+private theorem Elliptic.LogGauge.gaugeMap_starAction {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (g : Elliptic.CyclicGroup j) (x : FamilyStar D.periods) :
+    gaugeMap D.periods v (@SMul.smul _ _ (starAction D v hv).toSMul g x) =
+      @SMul.smul _ _ (starAction D 0 (by simp)).toSMul g (gaugeMap D.periods v x) := by
+  have h : Function.Semiconj (gaugeMap D.periods v) (starPermutation D v) (starPermutation D 0) :=
+    gaugeMap_intertwines D v hv
+  change
+    gaugeMap D.periods v ((starPermutation D v ^ g.toAdd.val) x) =
+      (starPermutation D 0 ^ g.toAdd.val) (gaugeMap D.periods v x)
+  rw [Equiv.Perm.coe_pow, Equiv.Perm.coe_pow]
+  exact h.iterate_right g.toAdd.val x
+
+private theorem
+    Elliptic.LogGauge.starAction_free {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    letI := starAction D v hv
+    IsCancelSMul (Elliptic.CyclicGroup j) (FamilyStar D.periods) := by
+  let := starAction D v hv
+  apply isCancelSMul_iff_eq_one_of_smul_eq.mpr
+  intro g x hx
+  let := D.action v hv
+  have hc : g • (x : D.TotalSpace) = (x : D.TotalSpace) :=
+    (starAction_coe D v hv g x).symm.trans (congrArg Subtype.val hx)
+  have hb : (Elliptic.familyRotation j)^[g.toAdd.val] x.1.1 = x.1.1 := by
+    simpa only [D.action_apply v hv g] using congrArg Prod.fst hc
+  have hg : g.toAdd.val = 0 := by
+    by_contra hg
+    have hz :=
+      (Elliptic.familyRotation_iterate_fixed_iff j g.toAdd.val (Nat.pos_of_ne_zero hg)
+            (ZMod.val_lt _) x.1.1).mp
+        hb
+    exact x.2 (congrArg Subtype.val hz)
+  apply Multiplicative.ext
+  exact (ZMod.val_eq_zero _).mp hg
+
+private theorem Elliptic.LogGauge.starAction_holomorphic {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (g : Elliptic.CyclicGroup j) :
+    letI := D.periods.totalChartedSpace
+    letI := starAction D v hv
+    ContMDiff (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω (fun x : FamilyStar D.periods => g • x) := by
+  let := D.periods.totalChartedSpace
+  let := starAction D v hv
+  let := D.action v hv
+  intro x
+  have he :
+    ContMDiffAt (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+        (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω
+        (fun y : FamilyStar D.periods => ((g • y : FamilyStar D.periods) : D.TotalSpace)) x ↔
+      ContMDiffAt (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+        (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω (fun y : FamilyStar D.periods => g • y)
+        x :=
+    ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+  apply he.mp
+  have h :
+    ContMDiff (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω
+      (fun y : FamilyStar D.periods => g • (y : D.TotalSpace)) :=
+    (D.action_holomorphic v hv g).comp contMDiff_subtype_val
+  simpa only [starAction_coe] using h x
+
+private theorem Elliptic.LogGauge.starAction_continuous {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    letI := starAction D v hv
+    ContinuousConstSMul (Elliptic.CyclicGroup j) (FamilyStar D.periods) := by
+  let := D.periods.totalChartedSpace
+  let := starAction D v hv
+  exact ⟨fun g => (starAction_holomorphic D v hv g).continuous⟩
+
+@[instance_reducible]
+private def Elliptic.LogGauge.gaugeCoveringChartedSpace :
+    ChartedSpace Elliptic.FamilyModel (SpecialPeriods.Disc × ComplexPlane₂) :=
+  inferInstanceAs (ChartedSpace (ModelProd ℂ ComplexPlane₂) (SpecialPeriods.Disc × ComplexPlane₂))
+
+attribute [local instance] Elliptic.LogGauge.gaugeCoveringChartedSpace in
+private theorem Elliptic.LogGauge.gaugeCoveringManifold :
+    IsManifold (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω
+      (SpecialPeriods.Disc × ComplexPlane₂) := by
+  rw [modelWithCornersSelf_prod]
+  exact
+    IsManifold.prod (I := (modelWithCornersSelf ℂ ℂ)) (I' :=
+      (modelWithCornersSelf ℂ ComplexPlane₂)) SpecialPeriods.Disc ComplexPlane₂
+
+attribute [local instance] Elliptic.LogGauge.gaugeCoveringChartedSpace
+    Elliptic.LogGauge.gaugeCoveringManifold in
+private theorem Elliptic.LogGauge.project_isLocalDiffeomorph
+    (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc) :
+    letI := P.totalChartedSpace
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω (project P) := by
+  let := P.totalChartedSpace
+  let := P.coveringAction
+  have hq :
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω P.quotientMap :=
+    CoveringQuotient.project_isLocalDiffeomorph P.quotientCoveringMap P.coveringAction_holomorphic
+  exact
+    isLocalDiffeomorph_restrictOpens (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) hq coverOpen familyOpen (fun _ hx => hx)
+
+attribute [local instance] Elliptic.LogGauge.gaugeCoveringChartedSpace
+    Elliptic.LogGauge.gaugeCoveringManifold in
+private theorem
+    Elliptic.LogGauge.project_holomorphic (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc) :
+    letI := P.totalChartedSpace
+    ContMDiff (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω (project P) := by
+  let := P.totalChartedSpace
+  exact (project_isLocalDiffeomorph P).contMDiff
+
+attribute [local instance] Elliptic.LogGauge.gaugeCoveringChartedSpace
+    Elliptic.LogGauge.gaugeCoveringManifold in
+private theorem
+    Elliptic.LogGauge.gaugeLift_holomorphicAt (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc)
+    (v : Lattice) {a : ℂ → ℂ} {x : CoverStar} (ha : ContDiffAt ℂ ω a (x.1.1 : ℂ)) :
+    ContMDiffAt (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω (gaugeLift P v a) x := by
+  have hb :
+    ContMDiff (modelWithCornersSelf ℂ Elliptic.FamilyModel) (modelWithCornersSelf ℂ ℂ) ω
+      (fun y : CoverStar => y.1.1) := by
+    have hfst :
+      ContMDiff (modelWithCornersSelf ℂ Elliptic.FamilyModel) (modelWithCornersSelf ℂ ℂ) ω
+        (Prod.fst : SpecialPeriods.Disc × ComplexPlane₂ → SpecialPeriods.Disc) := by
+      rw [modelWithCornersSelf_prod]
+      exact contMDiff_fst
+    exact hfst.comp contMDiff_subtype_val
+  have hw :
+    ContMDiff (modelWithCornersSelf ℂ Elliptic.FamilyModel) (modelWithCornersSelf ℂ ComplexPlane₂)
+      ω (fun y : CoverStar => y.1.2) := by
+    have hsnd :
+      ContMDiff (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+        (modelWithCornersSelf ℂ ComplexPlane₂) ω
+        (Prod.snd : SpecialPeriods.Disc × ComplexPlane₂ → ComplexPlane₂) := by
+      rw [modelWithCornersSelf_prod]
+      exact contMDiff_snd
+    exact hsnd.comp contMDiff_subtype_val
+  have hbc :
+    ContMDiff (modelWithCornersSelf ℂ Elliptic.FamilyModel) (modelWithCornersSelf ℂ ℂ) ω
+      (fun y : CoverStar => (y.1.1 : ℂ)) :=
+    contMDiff_subtype_val.comp hb
+  have hscalar :
+    ContMDiffAt (modelWithCornersSelf ℂ Elliptic.FamilyModel) (modelWithCornersSelf ℂ ℂ) ω
+      (fun y : CoverStar => a y.1.1) x :=
+    ha.contMDiffAt.comp x hbc.contMDiffAt
+  have hp :
+    ContMDiff (modelWithCornersSelf ℂ Elliptic.FamilyModel) (modelWithCornersSelf ℂ ComplexPlane₂)
+      ω (fun y : CoverStar => periodVector P v y.1.1) :=
+    (periodVector_holomorphic P v).comp hb
+  have hsum :
+    ContMDiffAt (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ ComplexPlane₂) ω
+      (fun y : CoverStar => y.1.2 + a y.1.1 • periodVector P v y.1.1) x :=
+    hw.contMDiffAt.add (hscalar.smul hp.contMDiffAt)
+  have hpair :
+    ContMDiffAt (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω
+      (fun y : CoverStar => (y.1.1, y.1.2 + a y.1.1 • periodVector P v y.1.1)) x := by
+    simpa only [← modelWithCornersSelf_prod] using hb.contMDiffAt.prodMk hsum
+  have he :
+    ContMDiffAt (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+        (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω (Subtype.val ∘ gaugeLift P v a) x ↔
+      ContMDiffAt (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+        (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω (gaugeLift P v a) x :=
+    ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+  exact he.mp hpair
+
+attribute [local instance] Elliptic.LogGauge.gaugeCoveringChartedSpace
+    Elliptic.LogGauge.gaugeCoveringManifold in
+private theorem Elliptic.LogGauge.gaugeMap_comp_project_holomorphic
+    (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc) (v : Lattice) :
+    letI := P.totalChartedSpace
+    ContMDiff (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω (gaugeMap P v ∘ project P) := by
+  let := P.totalChartedSpace
+  intro x
+  have hl := gaugeLift_holomorphicAt P v (x := x) (CuspUniformization.localLog_contDiffAt x.2)
+  have h := (project_holomorphic P).contMDiffAt.comp x hl
+  apply h.congr_of_eventuallyEq
+  exact Filter.Eventually.of_forall (gaugeMap_project_localLog P v x.2)
+
+attribute [local instance] Elliptic.LogGauge.gaugeCoveringChartedSpace
+    Elliptic.LogGauge.gaugeCoveringManifold in
+private theorem
+    Elliptic.LogGauge.gaugeMap_holomorphic (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc)
+    (v : Lattice) :
+    letI := P.totalChartedSpace
+    ContMDiff (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω (gaugeMap P v) := by
+  let := P.totalChartedSpace
+  exact
+    contMDiff_of_comp_localDiffeomorph (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (project_isLocalDiffeomorph P) (project_surjective P)
+      (gaugeMap_comp_project_holomorphic P v)
+
+attribute [local instance] Elliptic.LogGauge.gaugeCoveringChartedSpace
+    Elliptic.LogGauge.gaugeCoveringManifold in
+private theorem
+    Elliptic.LogGauge.gaugeMap_continuous (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc)
+    (v : Lattice) : Continuous (gaugeMap P v) := by
+  let := P.totalChartedSpace
+  exact (gaugeMap_holomorphic P v).continuous
+
+private def
+    Elliptic.LogGauge.restrictedProject (G : Type*) [Group G] {M : Type*} [TopologicalSpace M]
+    [MulAction G M] (U : TopologicalSpace.Opens M)
+    (V : TopologicalSpace.Opens (Elliptic.FiniteQuotient.Space G M))
+    (hpre :
+      Elliptic.FiniteQuotient.project G M ⁻¹' (V : Set (Elliptic.FiniteQuotient.Space G M)) =
+        (U : Set M))
+    (x : U) : V :=
+  ⟨Elliptic.FiniteQuotient.project G M x,
+    by
+    change
+      (x : M) ∈
+        Elliptic.FiniteQuotient.project G M ⁻¹' (V : Set (Elliptic.FiniteQuotient.Space G M))
+    rw [hpre]
+    exact x.2⟩
+
+private theorem Elliptic.LogGauge.restrictedProject_surjective (G : Type*) [Group G] {M : Type*}
+    [TopologicalSpace M] [MulAction G M] (U : TopologicalSpace.Opens M)
+    (V : TopologicalSpace.Opens (Elliptic.FiniteQuotient.Space G M))
+    (hpre :
+      Elliptic.FiniteQuotient.project G M ⁻¹' (V : Set (Elliptic.FiniteQuotient.Space G M)) =
+        (U : Set M)) :
+    Function.Surjective (restrictedProject G U V hpre) := by
+  intro y
+  obtain ⟨x, hx⟩ := Elliptic.FiniteQuotient.project_surjective G M y.1
+  have hxU : x ∈ (U : Set M) := by
+    rw [← hpre]
+    change Elliptic.FiniteQuotient.project G M x ∈ (V : Set (Elliptic.FiniteQuotient.Space G M))
+    rw [hx]
+    exact y.2
+  exact ⟨⟨x, hxU⟩, Subtype.ext hx⟩
+
+private def
+    Elliptic.LogGauge.openQuotientEquiv (G : Type*) [Group G] {M : Type*} [TopologicalSpace M]
+    [MulAction G M] (U : TopologicalSpace.Opens M) [MulAction G U]
+    (V : TopologicalSpace.Opens (Elliptic.FiniteQuotient.Space G M))
+    (hcompat : ∀ (g : G) (x : U), ((g • x : U) : M) = g • (x : M))
+    (hpre :
+      Elliptic.FiniteQuotient.project G M ⁻¹' (V : Set (Elliptic.FiniteQuotient.Space G M)) =
+        (U : Set M)) :
+    Elliptic.FiniteQuotient.Space G U ≃ V :=
+  (Equiv.subtypeQuotientEquivQuotientSubtype (fun x : M => x ∈ (U : Set M)) (s₁ :=
+      MulAction.orbitRel G M) (s₂ := MulAction.orbitRel G U)
+      (fun y => y ∈ (V : Set (Elliptic.FiniteQuotient.Space G M)))
+      (by
+        intro x
+        change x ∈ (U : Set M) ↔ x ∈ Elliptic.FiniteQuotient.project G M ⁻¹' (V : Set _)
+        rw [hpre])
+      (by
+        intro x y
+        change (x ∈ MulAction.orbit G y) ↔ ((x : M) ∈ MulAction.orbit G (y : M))
+        constructor
+        · rintro ⟨g, hg⟩
+          exact ⟨g, (hcompat g y).symm.trans (congrArg Subtype.val hg)⟩
+        · rintro ⟨g, hg⟩
+          exact ⟨g, Subtype.ext ((hcompat g y).trans hg)⟩)).symm
+
+@[simp]
+private theorem Elliptic.LogGauge.openQuotientEquiv_project (G : Type*) [Group G] {M : Type*}
+    [TopologicalSpace M] [MulAction G M] (U : TopologicalSpace.Opens M) [MulAction G U]
+    (V : TopologicalSpace.Opens (Elliptic.FiniteQuotient.Space G M))
+    (hcompat : ∀ (g : G) (x : U), ((g • x : U) : M) = g • (x : M))
+    (hpre :
+      Elliptic.FiniteQuotient.project G M ⁻¹' (V : Set (Elliptic.FiniteQuotient.Space G M)) =
+        (U : Set M))
+    (x : U) :
+    openQuotientEquiv G U V hcompat hpre (Elliptic.FiniteQuotient.project G U x) =
+      restrictedProject G U V hpre x :=
+  rfl
+
+@[simp]
+private theorem Elliptic.LogGauge.openQuotientEquiv_symm_restrictedProject (G : Type*) [Group G]
+    {M : Type*} [TopologicalSpace M] [MulAction G M] (U : TopologicalSpace.Opens M)
+    [MulAction G U] (V : TopologicalSpace.Opens (Elliptic.FiniteQuotient.Space G M))
+    (hcompat : ∀ (g : G) (x : U), ((g • x : U) : M) = g • (x : M))
+    (hpre :
+      Elliptic.FiniteQuotient.project G M ⁻¹' (V : Set (Elliptic.FiniteQuotient.Space G M)) =
+        (U : Set M))
+    (x : U) :
+    (openQuotientEquiv G U V hcompat hpre).symm (restrictedProject G U V hpre x) =
+      Elliptic.FiniteQuotient.project G U x := by
+  rw [← openQuotientEquiv_project G U V hcompat hpre x, Equiv.symm_apply_apply]
+
+private theorem Elliptic.LogGauge.subtypeAction_isCancelSMul (G : Type*) [Group G] {M : Type*}
+    [TopologicalSpace M] [MulAction G M] (U : TopologicalSpace.Opens M) [MulAction G U]
+    (hcompat : ∀ (g : G) (x : U), ((g • x : U) : M) = g • (x : M)) [IsCancelSMul G M] :
+    IsCancelSMul G U where
+  right_cancel' g h x
+    he := by
+    apply IsCancelSMul.right_cancel g h (x : M)
+    simpa only [hcompat] using congrArg Subtype.val he
+
+private theorem Elliptic.LogGauge.subtypeAction_holomorphic (G : Type*) [Group G] {M : Type*}
+    [TopologicalSpace M] [MulAction G M] (U : TopologicalSpace.Opens M) [MulAction G U]
+    (hcompat : ∀ (g : G) (x : U), ((g • x : U) : M) = g • (x : M)) {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℂ E] [ChartedSpace E M]
+    (hM :
+      ∀ g : G,
+        ContMDiff (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (fun x : M => g • x))
+    (g : G) :
+    ContMDiff (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (fun x : U => g • x) := by
+  intro x
+  have hi :
+    ContMDiffAt (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω
+        (fun y : U => ((g • y : U) : M)) x ↔
+      ContMDiffAt (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (fun y : U => g • y)
+        x :=
+    ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+  apply hi.mp
+  simpa only [hcompat, Function.comp_def] using
+    ((hM g).comp contMDiff_subtype_val).contMDiffAt (x := x)
+
+public
+theorem
+    Elliptic.LogGauge.subtypeAction_continuousConstSMul (G : Type*) [Group G] {M : Type*}
+    [TopologicalSpace M] [MulAction G M] (U : TopologicalSpace.Opens M) [MulAction G U]
+    (hcompat : ∀ (g : G) (x : U), ((g • x : U) : M) = g • (x : M)) {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℂ E] [ChartedSpace E M]
+    (hM :
+      ∀ g : G,
+        ContMDiff (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (fun x : M => g • x)) :
+    ContinuousConstSMul G U where
+  continuous_const_smul g := (subtypeAction_holomorphic G U hcompat hM g).continuous
+
+private theorem
+    Elliptic.LogGauge.restrictedProject_isLocalDiffeomorph (G : Type*) [Group G] {M : Type*}
+    [TopologicalSpace M] [MulAction G M] (U : TopologicalSpace.Opens M)
+    (V : TopologicalSpace.Opens (Elliptic.FiniteQuotient.Space G M))
+    (hpre :
+      Elliptic.FiniteQuotient.project G M ⁻¹' (V : Set (Elliptic.FiniteQuotient.Space G M)) =
+        (U : Set M))
+    {E : Type*} [NormedAddCommGroup E] [NormedSpace ℂ E] [ChartedSpace E M]
+    (hM :
+      ∀ g : G,
+        ContMDiff (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (fun x : M => g • x))
+    [Finite G] [LocallyCompactSpace M] [T2Space M] [ContinuousConstSMul G M] [IsCancelSMul G M]
+    [IsManifold (modelWithCornersSelf ℂ E) ω M] :
+    letI := Elliptic.FiniteQuotient.chartedSpace (E := E) G M
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω
+      (restrictedProject G U V hpre) := by
+  let := Elliptic.FiniteQuotient.chartedSpace (E := E) G M
+  have hUV : Set.MapsTo (Elliptic.FiniteQuotient.project G M) (U : Set M) (V : Set _) := by
+    intro x hx
+    change x ∈ Elliptic.FiniteQuotient.project G M ⁻¹' (V : Set _)
+    rwa [hpre]
+  exact
+    isLocalDiffeomorph_restrictOpens (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E)
+      (CoveringQuotient.project_isLocalDiffeomorph
+        (Elliptic.FiniteQuotient.project_isQuotientCoveringMap G M) hM)
+      U V hUV
+
+private def Elliptic.LogGauge.openQuotientBiholomorph (G : Type*) [Group G] {M : Type*}
+    [TopologicalSpace M] [MulAction G M] (U : TopologicalSpace.Opens M) [MulAction G U]
+    (V : TopologicalSpace.Opens (Elliptic.FiniteQuotient.Space G M))
+    (hcompat : ∀ (g : G) (x : U), ((g • x : U) : M) = g • (x : M))
+    (hpre :
+      Elliptic.FiniteQuotient.project G M ⁻¹' (V : Set (Elliptic.FiniteQuotient.Space G M)) =
+        (U : Set M))
+    {E : Type*} [NormedAddCommGroup E] [NormedSpace ℂ E] [ChartedSpace E M]
+    (hM :
+      ∀ g : G,
+        ContMDiff (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (fun x : M => g • x))
+    [Finite G] [LocallyCompactSpace M] [T2Space M] [ContinuousConstSMul G M] [IsCancelSMul G M]
+    [IsManifold (modelWithCornersSelf ℂ E) ω M] :
+    letI : LocallyCompactSpace U := U.isOpen.locallyCompactSpace
+    letI := subtypeAction_continuousConstSMul G U hcompat hM
+    letI := subtypeAction_isCancelSMul G U hcompat
+    letI := Elliptic.FiniteQuotient.chartedSpace (E := E) G M
+    letI := Elliptic.FiniteQuotient.chartedSpace (E := E) G U
+    Diffeomorph (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E)
+      (Elliptic.FiniteQuotient.Space G U) V ω := by
+  letI : LocallyCompactSpace U := U.isOpen.locallyCompactSpace
+  let := subtypeAction_continuousConstSMul G U hcompat hM
+  let := subtypeAction_isCancelSMul G U hcompat
+  let := Elliptic.FiniteQuotient.chartedSpace (E := E) G M
+  let := Elliptic.FiniteQuotient.chartedSpace (E := E) G U
+  have hr := restrictedProject_isLocalDiffeomorph G U V hpre hM
+  refine
+    { toEquiv := openQuotientEquiv G U V hcompat hpre
+      contMDiff_toFun := ?_
+      contMDiff_invFun := ?_ }
+  · apply
+      CoveringQuotient.contMDiff_of_comp
+        (Elliptic.FiniteQuotient.project_isQuotientCoveringMap G U) (modelWithCornersSelf ℂ E) ω
+    exact hr.contMDiff
+  · apply
+      contMDiff_of_comp_localDiffeomorph (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E)
+        (modelWithCornersSelf ℂ E) hr (restrictedProject_surjective G U V hpre)
+    have he :
+      (openQuotientEquiv G U V hcompat hpre).symm ∘ restrictedProject G U V hpre =
+        Elliptic.FiniteQuotient.project G U := by
+      funext x
+      exact openQuotientEquiv_symm_restrictedProject G U V hcompat hpre x
+    rw [he]
+    exact
+      Elliptic.FiniteQuotient.project_holomorphic G U (subtypeAction_holomorphic G U hcompat hM)
+
+private theorem Elliptic.LogGauge.discLocallyCompact : LocallyCompactSpace SpecialPeriods.Disc :=
+  SpecialPeriods.unitDisc.isOpen.locallyCompactSpace
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact in
+private theorem Elliptic.LogGauge.familyStarLocallyCompact : LocallyCompactSpace familyOpen :=
+  familyOpen.isOpen.locallyCompactSpace
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+private def Elliptic.LogGauge.StarQuotient {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : j.matrix *ᵥ v = v) : Type :=
+  @Elliptic.FiniteQuotient.Space (Elliptic.CyclicGroup j) (FamilyStar D.periods) _
+    (starAction D v hv)
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+private instance
+    Elliptic.LogGauge.starTopology {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : j.matrix *ᵥ v = v) : TopologicalSpace (StarQuotient D v hv) :=
+  inferInstanceAs
+    (TopologicalSpace
+      (@Elliptic.FiniteQuotient.Space (Elliptic.CyclicGroup j) (FamilyStar D.periods) _
+        (starAction D v hv)))
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+private def Elliptic.LogGauge.starProject {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : j.matrix *ᵥ v = v) : FamilyStar D.periods → StarQuotient D v hv :=
+  @Elliptic.FiniteQuotient.project (Elliptic.CyclicGroup j) (FamilyStar D.periods) _
+    (starAction D v hv)
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+private theorem Elliptic.LogGauge.starProject_surjective {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    Function.Surjective (starProject D v hv) :=
+  Quotient.mk_surjective
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+private theorem
+    Elliptic.LogGauge.starCoveringMap {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    letI := starAction D v hv
+    IsQuotientCoveringMap (starProject D v hv) (Elliptic.CyclicGroup j) := by
+  let := starAction D v hv
+  let := starAction_continuous D v hv
+  let := starAction_free D v hv
+  exact
+    Elliptic.FiniteQuotient.project_isQuotientCoveringMap (Elliptic.CyclicGroup j)
+      (FamilyStar D.periods)
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+@[instance_reducible]
+private def Elliptic.LogGauge.starChartedSpace {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    ChartedSpace Elliptic.FamilyModel (StarQuotient D v hv) := by
+  let := D.periods.totalChartedSpace
+  let := starAction D v hv
+  exact CoveringQuotient.chartedSpace (E := Elliptic.FamilyModel) (starCoveringMap D v hv)
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+private theorem Elliptic.LogGauge.starProject_holomorphic {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    letI := D.periods.totalChartedSpace
+    letI := starChartedSpace D v hv
+    ContMDiff (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω (starProject D v hv) := by
+  let := D.periods.totalChartedSpace
+  let := D.periods.totalSpace_isManifold
+  let := starAction D v hv
+  exact
+    CoveringQuotient.contMDiff_project (starCoveringMap D v hv) ω (starAction_holomorphic D v hv)
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+private abbrev
+    Elliptic.LogGauge.TautologicalStar {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j) :=
+  StarQuotient D 0 (Matrix.mulVec_zero j.matrix)
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+private def
+    Elliptic.LogGauge.gaugeQuotientEquiv {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : j.matrix *ᵥ v = v) : StarQuotient D v hv ≃ TautologicalStar D :=
+  @quotientEquiv (Elliptic.CyclicGroup j) _ (FamilyStar D.periods) (FamilyStar D.periods)
+    (starAction D v hv) (starAction D 0 (Matrix.mulVec_zero j.matrix)) (gaugeEquiv D.periods v)
+    (gaugeMap_starAction D v hv)
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+private def Elliptic.LogGauge.gaugeQuotientBiholomorph {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    letI := starChartedSpace D v hv
+    letI := starChartedSpace D 0 (Matrix.mulVec_zero j.matrix)
+    Diffeomorph (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) (StarQuotient D v hv) (TautologicalStar D)
+      ω := by
+  let := D.periods.totalChartedSpace
+  let := D.periods.totalSpace_isManifold
+  let := starChartedSpace D v hv
+  let := starChartedSpace D 0 (Matrix.mulVec_zero j.matrix)
+  refine
+    { toEquiv := gaugeQuotientEquiv D v hv
+      contMDiff_toFun := ?_
+      contMDiff_invFun := ?_ }
+  · let := starAction D v hv
+    apply
+      CoveringQuotient.contMDiff_of_comp (starCoveringMap D v hv)
+        (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω
+    exact
+      (starProject_holomorphic D 0 (Matrix.mulVec_zero j.matrix)).comp
+        (gaugeMap_holomorphic D.periods v)
+  · let := starAction D 0 (Matrix.mulVec_zero j.matrix)
+    apply
+      CoveringQuotient.contMDiff_of_comp (starCoveringMap D 0 (Matrix.mulVec_zero j.matrix))
+        (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω
+    exact (starProject_holomorphic D v hv).comp (gaugeMap_holomorphic D.periods (-v))
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+private def
+    Elliptic.LogGauge.starUpstairsProjection {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (x : FamilyStar D.periods) : BaseStar :=
+  ⟨Elliptic.discPower j.order j.order_pos x.1.1,
+    by
+    change (x.1.1 : ℂ) ^ j.order ≠ 0
+    exact pow_ne_zero _ x.2⟩
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+private theorem Elliptic.LogGauge.starUpstairsProjection_invariant {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (g : Elliptic.CyclicGroup j) (x : FamilyStar D.periods) :
+    letI := starAction D v hv
+    starUpstairsProjection D (g • x) = starUpstairsProjection D x := by
+  let := D.action v hv
+  let := starAction D v hv
+  apply Subtype.ext
+  change
+    Elliptic.discPower j.order j.order_pos ((g • x : FamilyStar D.periods) : D.TotalSpace).1 =
+      Elliptic.discPower j.order j.order_pos (x : D.TotalSpace).1
+  rw [starAction_coe D v hv]
+  exact D.action_discPower v hv g x
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+private def Elliptic.LogGauge.starProjection {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : j.matrix *ᵥ v = v) : StarQuotient D v hv → BaseStar := by
+  let := starAction D v hv
+  exact
+    Elliptic.FiniteQuotient.descend (starUpstairsProjection D)
+      (starUpstairsProjection_invariant D v hv)
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+private def Elliptic.LogGauge.fillingOpen {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) : TopologicalSpace.Opens (D.Space v hv) :=
+  ⟨{x | (D.projection v hv x : ℂ) ≠ 0},
+    isOpen_ne_fun (continuous_subtype_val.comp (D.projection_continuous v hv)) continuous_const⟩
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+private abbrev Elliptic.LogGauge.FillingStar {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :=
+  fillingOpen D v hv
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+@[simp]
+private theorem Elliptic.LogGauge.quotient_preimage_fillingOpen {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    (D.quotient v hv) ⁻¹' (fillingOpen D v hv : Set (D.Space v hv)) =
+      (familyOpen : Set D.TotalSpace) := by
+  ext x
+  change (D.projection v hv (D.quotient v hv x) : ℂ) ≠ 0 ↔ (x.1 : ℂ) ≠ 0
+  simp only [D.projection_quotient, Elliptic.discPower_coe, ne_eq,
+    pow_eq_zero_iff j.order_pos.ne']
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+private def
+    Elliptic.LogGauge.fillingStarProject {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (x : FamilyStar D.periods) :
+    FillingStar D v hv :=
+  ⟨D.quotient v hv x, by
+    change (D.projection v hv (D.quotient v hv x) : ℂ) ≠ 0
+    rw [D.projection_quotient, Elliptic.discPower_coe]
+    exact pow_ne_zero _ x.2⟩
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+private theorem Elliptic.LogGauge.fillingStarProject_surjective {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    Function.Surjective (fillingStarProject D v hv) := by
+  let := D.action v hv.1
+  exact
+    restrictedProject_surjective (Elliptic.CyclicGroup j) familyOpen (fillingOpen D v hv)
+      (quotient_preimage_fillingOpen D v hv)
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+private def
+    Elliptic.LogGauge.fillingStarProjection {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (x : FillingStar D v hv) : BaseStar :=
+  ⟨D.projection v hv x, x.2⟩
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+private def
+    Elliptic.LogGauge.fillingOpenComparison {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    letI := starChartedSpace D v hv.1
+    letI := D.chartedSpace v hv
+    Diffeomorph (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) (StarQuotient D v hv.1) (FillingStar D v hv)
+      ω := by
+  let := D.periods.totalChartedSpace
+  let := D.periods.totalSpace_isManifold
+  let := D.action v hv.1
+  let := D.action_continuous v hv.1
+  let := D.action_free v hv
+  let := starAction D v hv.1
+  exact
+    openQuotientBiholomorph (Elliptic.CyclicGroup j) familyOpen (fillingOpen D v hv)
+      (starAction_coe D v hv.1) (quotient_preimage_fillingOpen D v hv)
+      (D.action_holomorphic v hv.1)
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+private def Elliptic.LogGauge.fillingToTautologicalBiholomorph {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    letI := D.chartedSpace v hv
+    letI := starChartedSpace D 0 (Matrix.mulVec_zero j.matrix)
+    Diffeomorph (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) (FillingStar D v hv) (TautologicalStar D) ω :=
+  by
+  let := D.chartedSpace v hv
+  let := starChartedSpace D v hv.1
+  let := starChartedSpace D 0 (Matrix.mulVec_zero j.matrix)
+  exact (fillingOpenComparison D v hv).symm.trans (gaugeQuotientBiholomorph D v hv.1)
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+@[simp]
+private theorem Elliptic.LogGauge.fillingToTautologicalBiholomorph_project {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (x : FamilyStar D.periods) :
+    fillingToTautologicalBiholomorph D v hv (fillingStarProject D v hv x) =
+      starProject D 0 (Matrix.mulVec_zero j.matrix) (gaugeMap D.periods v x) :=
+  rfl
+
+attribute [local instance] Elliptic.LogGauge.discLocallyCompact
+    Elliptic.LogGauge.familyStarLocallyCompact in
+private theorem Elliptic.LogGauge.fillingToTautologicalBiholomorph_base {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (x : FillingStar D v hv) :
+    starProjection D 0 (Matrix.mulVec_zero j.matrix) (fillingToTautologicalBiholomorph D v hv x) =
+      fillingStarProjection D v hv x := by
+  obtain ⟨y, rfl⟩ := fillingStarProject_surjective D v hv x
+  rfl
+
+private theorem Elliptic.LogGauge.sectionMap_formula_of_exponential
+    (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc) (v : Lattice) (z : BaseStar) (s : ℂ)
+    (hs : CuspUniformization.exponential s = (z.1 : ℂ)) :
+    (sectionMap P v z : P.TotalSpace) = P.quotientMap (z.1, s • periodVector P v z.1) := by
+  rw [sectionMap_formula]
+  have hlogs : ∃ n : ℤ, CuspUniformization.logarithm (z.1 : ℂ) = s + n :=
+    (CuspUniformization.exponential_eq_iff _ _).mp
+      ((CuspUniformization.exponential_logarithm z.2).trans hs.symm)
+  simpa only [zero_add] using quotientMap_eq_of_scalar_int P v z.1 0 hlogs
+
+private theorem Elliptic.LogGauge.gaugeMap_project_of_exponential
+    (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc) (v : Lattice) (x : CoverStar) (s : ℂ)
+    (hs : CuspUniformization.exponential s = (x.1.1 : ℂ)) :
+    (gaugeMap P v (project P x) : P.TotalSpace) =
+      P.quotientMap (x.1.1, x.1.2 + s • periodVector P v x.1.1) := by
+  rw [gaugeMap_project]
+  exact
+    quotientMap_eq_of_scalar_int P v x.1.1 x.1.2
+      ((CuspUniformization.exponential_eq_iff _ _).mp
+        ((CuspUniformization.exponential_logarithm x.2).trans hs.symm))
+
+private def Elliptic.LogGauge.mainFillingToTautologicalBiholomorph {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) :
+    letI := D.chartedSpace j.twist (Elliptic.mainTwist_admissible j)
+    letI := starChartedSpace D 0 (Matrix.mulVec_zero j.matrix)
+    Diffeomorph (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (FillingStar D j.twist (Elliptic.mainTwist_admissible j)) (TautologicalStar D) ω :=
+  fillingToTautologicalBiholomorph D j.twist (Elliptic.mainTwist_admissible j)
+
+private theorem Elliptic.LogGauge.mainFillingToTautologicalBiholomorph_base {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j)
+    (x : FillingStar D j.twist (Elliptic.mainTwist_admissible j)) :
+    starProjection D 0 (Matrix.mulVec_zero j.matrix) (mainFillingToTautologicalBiholomorph D x) =
+      fillingStarProjection D j.twist (Elliptic.mainTwist_admissible j) x :=
+  fillingToTautologicalBiholomorph_base D j.twist (Elliptic.mainTwist_admissible j) x
+
+private def
+    Elliptic.discRadial (t : unitInterval) (z : SpecialPeriods.Disc) : SpecialPeriods.Disc :=
+  ⟨(1 - (t : ℝ)) • (z : ℂ),
+    by
+    have ha : 0 ≤ 1 - (t : ℝ) := sub_nonneg.mpr t.property.2
+    have ha1 : 1 - (t : ℝ) ≤ 1 := by linarith [t.property.1]
+    have hn : ‖(1 - (t : ℝ)) • (z : ℂ)‖ < 1 := by
+      rw [norm_smul, Real.norm_eq_abs, abs_of_nonneg ha]
+      exact
+        (mul_le_of_le_one_left (norm_nonneg _) ha1).trans_lt (SpecialPeriods.disc_norm_lt_one z)
+    simpa [SpecialPeriods.unitDisc] using hn⟩
+
+private theorem Elliptic.discRadial_continuous :
+    Continuous (fun p : unitInterval × SpecialPeriods.Disc => discRadial p.1 p.2) :=
+  ((continuous_const.sub (continuous_subtype_val.comp continuous_fst)).smul
+        (continuous_subtype_val.comp continuous_snd)).subtype_mk
+    _
+
+@[simp]
+private theorem Elliptic.discRadial_zero (z : SpecialPeriods.Disc) : discRadial 0 z = z := by
+  apply Subtype.ext
+  simp [discRadial]
+
+@[simp]
+private theorem Elliptic.discRadial_one (z : SpecialPeriods.Disc) : discRadial 1 z = discZero := by
+  apply Subtype.ext
+  simp [discRadial, discZero]
+
+@[simp]
+private theorem
+    Elliptic.discRadial_discZero (t : unitInterval) : discRadial t discZero = discZero := by
+  apply Subtype.ext
+  simp [discRadial, discZero]
+
+private theorem Elliptic.discRadial_familyRotation (j : Kind) (t : unitInterval)
+    (z : SpecialPeriods.Disc) :
+    discRadial t (familyRotation j z) = familyRotation j (discRadial t z) := by
+  cases j <;> apply Subtype.ext
+  · change
+      (1 - (t : ℝ)) • (-SpecialPeriods.rho * (z : ℂ)) =
+        -SpecialPeriods.rho * ((1 - (t : ℝ)) • (z : ℂ))
+    simp only [Complex.real_smul]
+    ring
+  · change (1 - (t : ℝ)) • (-Complex.I * (z : ℂ)) = -Complex.I * ((1 - (t : ℝ)) • (z : ℂ))
+    simp only [Complex.real_smul]
+    ring
+
+private theorem Elliptic.discRadial_familyRotation_iterate (j : Kind) (t : unitInterval) (n : ℕ)
+    (z : SpecialPeriods.Disc) :
+    discRadial t ((familyRotation j)^[n] z) = (familyRotation j)^[n] (discRadial t z) := by
+  induction n with
+  | zero => rfl
+  | succ n ih =>
+    rw [Function.iterate_succ_apply', Function.iterate_succ_apply', discRadial_familyRotation, ih]
+
+private def Elliptic.familyRadial (j : Kind) (t : unitInterval) (x : Family j) : Family j :=
+  (discRadial t x.1, x.2)
+
+private theorem Elliptic.familyRadial_continuous (j : Kind) :
+    Continuous (fun p : unitInterval × Family j => familyRadial j p.1 p.2) :=
+  (discRadial_continuous.comp (continuous_fst.prodMk (continuous_fst.comp continuous_snd))).prodMk
+    (continuous_snd.comp continuous_snd)
+
+@[simp]
+private theorem Elliptic.familyRadial_zero (j : Kind) (x : Family j) : familyRadial j 0 x = x := by
+  exact Prod.ext (discRadial_zero x.1) rfl
+
+@[simp]
+private theorem Elliptic.familyRadial_one (j : Kind) (x : Family j) :
+    familyRadial j 1 x = (discZero, x.2) := by exact Prod.ext (discRadial_one x.1) rfl
+
+private theorem Elliptic.familyRadial_fixed (j : Kind) (t : unitInterval) (x : Family j)
+    (hx : x.1 = discZero) : familyRadial j t x = x := by
+  exact Prod.ext (by change discRadial t x.1 = x.1; rw [hx, discRadial_discZero]) rfl
+
+private theorem Elliptic.familyRadial_equivariant (j : Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (g : CyclicGroup j) (t : unitInterval) (x : Family j) :
+    letI := familyAction j v hv
+    familyRadial j t (g • x) = g • familyRadial j t x := by
+  let := familyAction j v hv
+  rw [familyAction_apply, familyAction_apply]
+  exact Prod.ext (discRadial_familyRotation_iterate j t g.toAdd.val x.1) rfl
+
+private def Elliptic.fillingRadial (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v)
+    (t : unitInterval) : Filling j v hv → Filling j v hv := by
+  letI := familyAction j v hv.1
+  exact
+    FiniteQuotient.descend (fun x => fillingQuotient j v hv (familyRadial j t x))
+      (fun g x => by
+        rw [familyRadial_equivariant]
+        exact FiniteQuotient.project_smul (CyclicGroup j) (Family j) g _)
+
+@[simp]
+private theorem
+    Elliptic.fillingRadial_fillingQuotient (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v)
+    (t : unitInterval) (x : Family j) :
+    fillingRadial j v hv t (fillingQuotient j v hv x) =
+      fillingQuotient j v hv (familyRadial j t x) :=
+  rfl
+
+private theorem
+    Elliptic.fillingRadial_continuous (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v) :
+    Continuous (fun p : unitInterval × Filling j v hv => fillingRadial j v hv p.1 p.2) := by
+  have hq : Topology.IsQuotientMap (fillingQuotient j v hv) := isQuotientMap_quotient_mk'
+  apply hq.continuous_lift_prod_right
+  exact (fillingQuotient_continuous j v hv).comp (familyRadial_continuous j)
+
+@[simp]
+private theorem Elliptic.fillingRadial_zero (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v)
+    (x : Filling j v hv) : fillingRadial j v hv 0 x = x := by
+  obtain ⟨y, rfl⟩ := fillingQuotient_surjective j v hv x
+  rw [fillingRadial_fillingQuotient, familyRadial_zero]
+
+private theorem
+    Elliptic.fillingRadial_one_mem_central (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v)
+    (x : Filling j v hv) : fillingRadial j v hv 1 x ∈ fillingProjection j v hv ⁻¹' { discZero } :=
+  by
+  obtain ⟨y, rfl⟩ := fillingQuotient_surjective j v hv x
+  rw [fillingRadial_fillingQuotient, familyRadial_one]
+  exact (discPower_eq_zero_iff j.order j.order_pos discZero).mpr rfl
+
+private theorem Elliptic.fillingRadial_fixed (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v)
+    (t : unitInterval) (x : Filling j v hv) (hx : fillingProjection j v hv x = discZero) :
+    fillingRadial j v hv t x = x := by
+  obtain ⟨y, rfl⟩ := fillingQuotient_surjective j v hv x
+  change discPower j.order j.order_pos y.1 = discZero at hx
+  rw [fillingRadial_fillingQuotient,
+    familyRadial_fixed j t y ((discPower_eq_zero_iff j.order j.order_pos y.1).mp hx)]
+
+private def
+    Elliptic.fillingCentralSubtypeInclusion (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v) :
+    ContinuousMap (fillingProjection j v hv ⁻¹' { discZero }) (Filling j v hv) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private def Elliptic.fillingCentralRetraction (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v) :
+    ContinuousMap (Filling j v hv) (fillingProjection j v hv ⁻¹' { discZero }) :=
+  ⟨fun x => ⟨fillingRadial j v hv 1 x, fillingRadial_one_mem_central j v hv x⟩,
+    ((fillingRadial_continuous j v hv).comp (continuous_const.prodMk continuous_id)).subtype_mk _⟩
+
+private def Elliptic.torusFibreMap (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v)
+    (z : SpecialPeriods.Disc) : ((familyPeriods j).point z).Torus → Filling j v hv :=
+  fillingQuotient j v hv ∘ (familyPeriods j).fibreInclusion z
+
+private theorem
+    Elliptic.torusFibreMap_holomorphic (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v)
+    (z : SpecialPeriods.Disc) :
+    ContMDiff (modelWithCornersSelf ℂ ComplexPlane₂) (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      ω (torusFibreMap j v hv z) := by
+  let := (familyPeriods j).totalChartedSpace
+  exact (fillingQuotient_holomorphic j v hv).comp ((familyPeriods j).fibreInclusion_holomorphic z)
+
+private theorem
+    Elliptic.torusFibreMap_continuous (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v)
+    (z : SpecialPeriods.Disc) : Continuous (torusFibreMap j v hv z) :=
+  (torusFibreMap_holomorphic j v hv z).continuous
+
+@[simp]
+private theorem Elliptic.fillingProjection_torusFibreMap (j : Kind) (v : Lattice)
+    (hv : AdmissibleTwist j v) (z : SpecialPeriods.Disc) (x : ((familyPeriods j).point z).Torus) :
+    fillingProjection j v hv (torusFibreMap j v hv z x) = discPower j.order j.order_pos z :=
+  rfl
+
+private theorem Elliptic.range_torusFibreMap (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v)
+    (z : SpecialPeriods.Disc) :
+    Set.range (torusFibreMap j v hv z) =
+      fillingProjection j v hv ⁻¹' {discPower j.order j.order_pos z} := by
+  let := familyAction j v hv.1
+  ext q
+  constructor
+  · rintro ⟨x, rfl⟩
+    exact fillingProjection_torusFibreMap j v hv z x
+  · intro hq
+    obtain ⟨x, rfl⟩ := fillingQuotient_surjective j v hv q
+    have hp : discPower j.order j.order_pos x.1 = discPower j.order j.order_pos z := hq
+    obtain ⟨r, hr, hrot⟩ := (discPower_eq_iff_familyRotation j z x.1).mp hp.symm
+    let g : CyclicGroup j := Multiplicative.ofAdd (r : ZMod j.order)
+    have hg : g.toAdd.val = r := ZMod.val_natCast_of_lt hr
+    have hbase : (g • x).1 = z := by
+      rw [familyAction_apply, hg]
+      exact hrot
+    have hx : g • x ∈ Set.range ((familyPeriods j).fibreInclusion z) := by
+      rw [(familyPeriods j).range_fibreInclusion]
+      exact hbase
+    obtain ⟨y, hy⟩ := hx
+    refine ⟨y, ?_⟩
+    change fillingQuotient j v hv ((familyPeriods j).fibreInclusion z y) = _
+    rw [hy]
+    exact FiniteQuotient.project_smul (CyclicGroup j) (Family j) g x
+
+private theorem Elliptic.fillingProjection_fibre_connected (j : Kind) (v : Lattice)
+    (hv : AdmissibleTwist j v) (b : SpecialPeriods.Disc) :
+    IsConnected (fillingProjection j v hv ⁻¹' { b }) := by
+  obtain ⟨z, rfl⟩ := discPower_surjective j.order j.order_pos b
+  rw [← range_torusFibreMap j v hv z]
+  exact isConnected_range (torusFibreMap_continuous j v hv z)
+
+private def Elliptic.Equivariant.Data.fillingHomeomorph {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    D.Space v hv ≃ₜ Elliptic.Filling j v hv :=
+  Homeomorph.refl _
+
+private theorem Elliptic.Equivariant.Data.projection_fibre_isConnected {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (b : SpecialPeriods.Disc) : IsConnected (D.projection v hv ⁻¹' { b }) :=
+  Elliptic.fillingProjection_fibre_connected j v hv b
+
+private def
+    Elliptic.Equivariant.Data.fillingRadial {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (t : unitInterval) :
+    D.Space v hv → D.Space v hv :=
+  Elliptic.fillingRadial j v hv t
+
+@[simp]
+private theorem Elliptic.Equivariant.Data.fillingRadial_quotient {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (t : unitInterval) (x : D.TotalSpace) :
+    D.fillingRadial v hv t (D.quotient v hv x) =
+      D.quotient v hv (Elliptic.discRadial t x.1, x.2) :=
+  rfl
+
+private theorem Elliptic.Equivariant.Data.fillingRadial_continuous {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    Continuous (fun p : unitInterval × D.Space v hv => D.fillingRadial v hv p.1 p.2) :=
+  Elliptic.fillingRadial_continuous j v hv
+
+@[simp]
+private theorem Elliptic.Equivariant.Data.fillingRadial_zero {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (x : D.Space v hv) : D.fillingRadial v hv 0 x = x :=
+  Elliptic.fillingRadial_zero j v hv x
+
+private theorem Elliptic.Equivariant.Data.fillingRadial_fixed {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (t : unitInterval) (x : D.Space v hv) (hx : D.projection v hv x = Elliptic.discZero) :
+    D.fillingRadial v hv t x = x :=
+  Elliptic.fillingRadial_fixed j v hv t x hx
+
+private def Elliptic.Equivariant.Data.fillingCentralSubtypeInclusion {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    ContinuousMap (D.projection v hv ⁻¹' { Elliptic.discZero }) (D.Space v hv) :=
+  Elliptic.fillingCentralSubtypeInclusion j v hv
+
+private def Elliptic.Equivariant.Data.fillingCentralRetraction {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    ContinuousMap (D.Space v hv) (D.projection v hv ⁻¹' { Elliptic.discZero }) :=
+  Elliptic.fillingCentralRetraction j v hv
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Elliptic/Core5.lean b/LeanPool/HopfProblem/Elliptic/Core5.lean
new file mode 100644
index 000000000..4f968d344
--- /dev/null
+++ b/LeanPool/HopfProblem/Elliptic/Core5.lean
@@ -0,0 +1,3176 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Foundations.TwoOpenTransition
+public import LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen2
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology3
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology4
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap1
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology7
+import all LeanPool.HopfProblem.Elliptic.Core3
+import all LeanPool.HopfProblem.Elliptic.Core4
+import all LeanPool.HopfProblem.Foundations.TwoOpenTransition
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen2
+
+/-!
+# Hopf problem: elliptic · core 5
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private abbrev Elliptic.HigherHomology.FibreLattice :=
+  Fin 3 → ℤ
+
+private abbrev Elliptic.HigherHomology.FibreMatrix :=
+  Matrix (Fin 3) (Fin 3) ℤ
+
+private def Elliptic.HigherHomology.fibreMatrix : Elliptic.Kind → FibreMatrix
+  | .three => !![0, 1, 0; -1, -1, 0; 1, 0, 1]
+  | .four => !![0, -1, 0; 1, 0, 0; 0, 1, 1]
+
+private theorem
+    Elliptic.HigherHomology.fibreMatrix_det (j : Elliptic.Kind) : (fibreMatrix j).det = 1 := by
+  cases j <;> decide
+
+private theorem Elliptic.HigherHomology.fibreMatrix_pow_order (j : Elliptic.Kind) :
+    (fibreMatrix j) ^ j.order = 1 := by cases j <;> decide
+
+private def Elliptic.HigherHomology.fibreSL (j : Elliptic.Kind) : SL(3, ℤ) :=
+  ⟨fibreMatrix j, fibreMatrix_det j⟩
+
+private def Elliptic.HigherHomology.fibrePair : Fin 3 → Fin 2 → Fin 3 :=
+  ![![0, 1], ![0, 2], ![1, 2] ]
+
+private def Elliptic.HigherHomology.fibreSquareMatrix : Elliptic.Kind → FibreMatrix
+  | .three => !![1, 0, 0; -1, 0, 1; 1, -1, -1]
+  | .four => !![1, 0, 0; 0, 0, -1; 1, 1, 0]
+
+private theorem Elliptic.HigherHomology.fibreSquareMatrix_minor (j : Elliptic.Kind) (i k : Fin 3) :
+    fibreSquareMatrix j i k =
+      fibreMatrix j (fibrePair i 0) (fibrePair k 0) *
+          fibreMatrix j (fibrePair i 1) (fibrePair k 1) -
+        fibreMatrix j (fibrePair i 0) (fibrePair k 1) *
+          fibreMatrix j (fibrePair i 1) (fibrePair k 0) := by
+  cases j <;> fin_cases i <;> fin_cases k <;> decide
+
+private theorem Elliptic.HigherHomology.fibreSquareMatrix_det (j : Elliptic.Kind) :
+    (fibreSquareMatrix j).det = 1 := by cases j <;> decide
+
+private def Elliptic.HigherHomology.twistBasisMatrix : Elliptic.Kind → LatticeMatrix
+  | .three => !![1, 0, 0, 0; 2, 1, 0, 0; -4, 0, 1, 0; 0, 0, 0, 1]
+  | .four => !![-1, 0, 0, 0; -3, 1, 0, 0; 3, 0, 1, 0; 0, 0, 0, 1]
+
+private def Elliptic.HigherHomology.twistBasisInvMatrix : Elliptic.Kind → LatticeMatrix
+  | .three => !![1, 0, 0, 0; -2, 1, 0, 0; 4, 0, 1, 0; 0, 0, 0, 1]
+  | .four => !![-1, 0, 0, 0; -3, 1, 0, 0; 3, 0, 1, 0; 0, 0, 0, 1]
+
+private theorem
+    Elliptic.HigherHomology.twistBasisInvMatrix_mul_twistBasisMatrix (j : Elliptic.Kind) :
+    twistBasisInvMatrix j * twistBasisMatrix j = 1 := by cases j <;> decide
+
+private theorem
+    Elliptic.HigherHomology.twistBasisMatrix_mul_twistBasisInvMatrix (j : Elliptic.Kind) :
+    twistBasisMatrix j * twistBasisInvMatrix j = 1 := by cases j <;> decide
+
+private abbrev Elliptic.HigherHomology.FibreCoordinates :=
+  Fin 3 → ℝ
+
+private def Elliptic.HigherHomology.fibreLinear (j : Elliptic.Kind) :
+    FibreCoordinates →ₗ[ℝ] FibreCoordinates :=
+  ((fibreMatrix j).map (Int.castRingHom ℝ)).mulVecLin
+
+private def Elliptic.HigherHomology.splitRealCoordinates (j : Elliptic.Kind) :
+    RealPlane₄ ≃L[ℝ] ℝ × FibreCoordinates :=
+  LinearEquiv.toContinuousLinearEquiv
+    { toFun := fun x =>
+        ((j.twist 0 : ℝ) * x 0, fun i =>
+          x i.succ - ((j.twist 0 : ℝ) * x 0) * (j.twist i.succ : ℝ))
+      invFun := fun x => x.1 • Elliptic.realCast j.twist + Fin.cons 0 x.2
+      left_inv := by
+        intro x
+        funext i
+        refine Fin.cases ?_ (fun k => ?_) i
+        · cases j <;> simp [Elliptic.Kind.twist, Elliptic.realCast, ε, ε']
+        · simp [Elliptic.realCast]
+      right_inv := by
+        rintro ⟨t, k⟩
+        apply Prod.ext
+        · cases j <;> simp [Elliptic.Kind.twist, Elliptic.realCast, ε, ε']
+        · funext i
+          simp only [Pi.add_apply, Pi.smul_apply, smul_eq_mul, Fin.cons_zero, Fin.cons_succ]
+          cases j <;> fin_cases i <;> simp [Elliptic.Kind.twist, Elliptic.realCast, ε, ε']
+      map_add' := by
+        intro x y
+        apply Prod.ext
+        · simp [mul_add]
+        · funext i
+          simp only [Pi.add_apply, Prod.mk_add_mk]
+          ring
+      map_smul' := by
+        intro r x
+        apply Prod.ext
+        · simp only [Pi.smul_apply, smul_eq_mul, Prod.smul_mk, RingHom.id_apply]
+          ring
+        · funext i
+          simp only [Pi.smul_apply, smul_eq_mul, Prod.smul_mk, RingHom.id_apply]
+          ring }
+
+@[simp]
+private theorem Elliptic.HigherHomology.splitRealCoordinates_apply (j : Elliptic.Kind)
+    (x : RealPlane₄) :
+    splitRealCoordinates j x =
+      ((j.twist 0 : ℝ) * x 0, fun i =>
+        x i.succ - ((j.twist 0 : ℝ) * x 0) * (j.twist i.succ : ℝ)) :=
+  rfl
+
+@[simp]
+private theorem Elliptic.HigherHomology.splitRealCoordinates_symm_apply (j : Elliptic.Kind)
+    (x : ℝ × FibreCoordinates) :
+    (splitRealCoordinates j).symm x = x.1 • Elliptic.realCast j.twist + Fin.cons 0 x.2 :=
+  rfl
+
+private theorem
+    Elliptic.HigherHomology.flatLinear_fibre (j : Elliptic.Kind) (k : FibreCoordinates) :
+    Elliptic.flatLinear j (Fin.cons 0 k) = Fin.cons 0 (fibreLinear j k) := by
+  ext i
+  refine Fin.cases ?_ (fun a => ?_) i
+  · cases j <;>
+      simp [Elliptic.flatLinear, Elliptic.Kind.matrix, A₁, A₂, Matrix.mulVec, dotProduct,
+        Fin.sum_univ_succ]
+  · rw [Fin.cons_succ]
+    cases j <;> fin_cases a <;>
+      simp [Elliptic.flatLinear, fibreLinear, fibreMatrix, Elliptic.Kind.matrix, A₁, A₂,
+        Matrix.mulVec, dotProduct, Fin.sum_univ_succ]
+
+private theorem Elliptic.HigherHomology.flatLinear_twist (j : Elliptic.Kind) :
+    Elliptic.flatLinear j (Elliptic.realCast j.twist) = Elliptic.realCast j.twist := by
+  rw [Elliptic.flatLinear_realCast, j.matrix_fixes_twist]
+
+private theorem Elliptic.HigherHomology.splitRealCoordinates_flatAffine (j : Elliptic.Kind)
+    (x : RealPlane₄) :
+    splitRealCoordinates j (Elliptic.flatAffine j j.twist x) =
+      ((splitRealCoordinates j x).1 + 1 / (j.order : ℝ),
+        fibreLinear j (splitRealCoordinates j x).2) := by
+  obtain ⟨⟨t, k⟩, rfl⟩ := (splitRealCoordinates j).symm.surjective x
+  simp only [ContinuousLinearEquiv.apply_symm_apply]
+  apply (splitRealCoordinates j).symm.injective
+  simp only [ContinuousLinearEquiv.symm_apply_apply, splitRealCoordinates_symm_apply,
+    Elliptic.flatAffine, map_add, map_smul, flatLinear_twist, flatLinear_fibre]
+  simp only [add_smul]
+  abel
+
+private def Elliptic.HigherHomology.matrixTorusHomeomorph {n : ℕ} (A B : Matrix (Fin n) (Fin n) ℤ)
+    (hBA : B * A = 1) (hAB : A * B = 1) :
+    PeriodTorusHigherHomology.ProductTorus n ≃ₜ PeriodTorusHigherHomology.ProductTorus n
+    where
+  toFun := PeriodTorusHigherHomology.torusMatrixMap A
+  invFun := PeriodTorusHigherHomology.torusMatrixMap B
+  left_inv
+    x := by
+    change
+      ((PeriodTorusHigherHomology.torusMatrixMap B).comp
+            (PeriodTorusHigherHomology.torusMatrixMap A))
+          x =
+        x
+    rw [← PeriodTorusHigherHomology.torusMatrixMap_mul, hBA,
+      PeriodTorusHigherHomology.torusMatrixMap_one]
+    rfl
+  right_inv
+    x := by
+    change
+      ((PeriodTorusHigherHomology.torusMatrixMap A).comp
+            (PeriodTorusHigherHomology.torusMatrixMap B))
+          x =
+        x
+    rw [← PeriodTorusHigherHomology.torusMatrixMap_mul, hAB,
+      PeriodTorusHigherHomology.torusMatrixMap_one]
+    rfl
+  continuous_toFun := PeriodTorusHigherHomology.torusMatrixLinearMap_continuous A
+  continuous_invFun := PeriodTorusHigherHomology.torusMatrixLinearMap_continuous B
+
+private def Elliptic.HigherHomology.fibreTorusHomeomorph (j : Elliptic.Kind) :
+    PeriodTorusHigherHomology.ProductTorus 3 ≃ₜ PeriodTorusHigherHomology.ProductTorus 3 :=
+  matrixTorusHomeomorph (fibreMatrix j) (((fibreSL j)⁻¹ : SL(3, ℤ)) : FibreMatrix)
+    (congrArg (fun C : SL(3, ℤ) => C.val) (inv_mul_cancel (fibreSL j)))
+    (congrArg (fun C : SL(3, ℤ) => C.val) (mul_inv_cancel (fibreSL j)))
+
+@[simp]
+private theorem Elliptic.HigherHomology.fibreTorusHomeomorph_apply (j : Elliptic.Kind)
+    (x : PeriodTorusHigherHomology.ProductTorus 3) :
+    fibreTorusHomeomorph j x = PeriodTorusHigherHomology.torusMatrixMap (fibreMatrix j) x :=
+  rfl
+
+private theorem
+    Elliptic.HigherHomology.fibreTorusHomeomorph_coordinateProjection (j : Elliptic.Kind)
+    (k : FibreCoordinates) :
+    fibreTorusHomeomorph j (PeriodTorusHigherHomology.coordinateProjection 3 k) =
+      PeriodTorusHigherHomology.coordinateProjection 3 (fibreLinear j k) :=
+  PeriodTorusHigherHomology.torusMatrixMap_coordinateProjection (fibreMatrix j) k
+
+private theorem Elliptic.HigherHomology.twistBasisInvMatrix_real_mulVec (j : Elliptic.Kind)
+    (x : RealPlane₄) :
+    (twistBasisInvMatrix j).map (Int.castRingHom ℝ) *ᵥ x =
+      Fin.cons (splitRealCoordinates j x).1 (splitRealCoordinates j x).2 := by
+  ext i
+  refine Fin.cases ?_ (fun a => ?_) i
+  · cases j <;>
+      simp [twistBasisInvMatrix, splitRealCoordinates_apply, Elliptic.Kind.twist, ε, ε',
+        Matrix.mulVec, dotProduct, Fin.sum_univ_succ]
+  · rw [Fin.cons_succ]
+    cases j <;> fin_cases a <;>
+        simp [twistBasisInvMatrix, splitRealCoordinates_apply, Elliptic.Kind.twist, ε, ε',
+          Matrix.mulVec, dotProduct, Fin.sum_univ_succ] <;>
+      ring
+
+private def Elliptic.HigherHomology.splitFlatTorusHomeomorph (j : Elliptic.Kind) :
+    RealTorus₄ ≃ₜ AddCircle (1 : ℝ) × PeriodTorusHigherHomology.ProductTorus 3 :=
+  PeriodTorusHigherHomology.flatTorusCircleHomeomorph.trans
+    ((matrixTorusHomeomorph (twistBasisInvMatrix j) (twistBasisMatrix j)
+          (twistBasisMatrix_mul_twistBasisInvMatrix j)
+          (twistBasisInvMatrix_mul_twistBasisMatrix j)).trans
+      (PeriodTorusHigherHomology.productTorusSuccHomeomorph 3))
+
+private theorem Elliptic.HigherHomology.splitFlatTorusHomeomorph_mkQ (j : Elliptic.Kind)
+    (x : RealPlane₄) :
+    splitFlatTorusHomeomorph j (standardLattice.mkQ x) =
+      (((splitRealCoordinates j x).1 : AddCircle (1 : ℝ)),
+        PeriodTorusHigherHomology.coordinateProjection 3 (splitRealCoordinates j x).2) := by
+  change
+    PeriodTorusHigherHomology.productTorusSuccHomeomorph 3
+        (PeriodTorusHigherHomology.torusMatrixMap (twistBasisInvMatrix j)
+          (PeriodTorusHigherHomology.coordinateProjection 4 x)) =
+      _
+  rw [PeriodTorusHigherHomology.torusMatrixMap_coordinateProjection,
+    twistBasisInvMatrix_real_mulVec]
+  apply Prod.ext
+  · rfl
+  · funext i
+    rfl
+
+private theorem Elliptic.HigherHomology.splitFlatTorusHomeomorph_symm_coordinateProjection
+    (j : Elliptic.Kind) (t : ℝ) (k : FibreCoordinates) :
+    (splitFlatTorusHomeomorph j).symm
+        ((t : AddCircle (1 : ℝ)), PeriodTorusHigherHomology.coordinateProjection 3 k) =
+      standardLattice.mkQ ((splitRealCoordinates j).symm (t, k)) := by
+  apply (splitFlatTorusHomeomorph j).injective
+  rw [Homeomorph.apply_symm_apply, splitFlatTorusHomeomorph_mkQ,
+    ContinuousLinearEquiv.apply_symm_apply]
+
+private theorem Elliptic.HigherHomology.splitFlatTorusHomeomorph_flatTorusAffine (j : Elliptic.Kind)
+    (x : RealTorus₄) :
+    splitFlatTorusHomeomorph j (Elliptic.flatTorusAffine j j.twist x) =
+      ((splitFlatTorusHomeomorph j x).1 + ((1 / (j.order : ℝ) : ℝ) : AddCircle (1 : ℝ)),
+        fibreTorusHomeomorph j (splitFlatTorusHomeomorph j x).2) := by
+  obtain ⟨v, rfl⟩ := standardLattice.mkQ_surjective x
+  simp only [Elliptic.flatTorusAffine_mkQ, splitFlatTorusHomeomorph_mkQ,
+    splitRealCoordinates_flatAffine, AddCircle.coe_add, fibreTorusHomeomorph_coordinateProjection]
+
+private theorem
+    Elliptic.HigherHomology.flatTorusAffine_splitFlatTorusHomeomorph_symm (j : Elliptic.Kind)
+    (t : AddCircle (1 : ℝ)) (k : PeriodTorusHigherHomology.ProductTorus 3) :
+    Elliptic.flatTorusAffine j j.twist ((splitFlatTorusHomeomorph j).symm (t, k)) =
+      (splitFlatTorusHomeomorph j).symm
+        (t + ((1 / (j.order : ℝ) : ℝ) : AddCircle (1 : ℝ)), fibreTorusHomeomorph j k) := by
+  apply (splitFlatTorusHomeomorph j).injective
+  rw [splitFlatTorusHomeomorph_flatTorusAffine, Homeomorph.apply_symm_apply,
+    Homeomorph.apply_symm_apply]
+
+private def
+    Elliptic.HigherHomology.splitPeriodTorusHomeomorph (j : Elliptic.Kind) (p : PeriodDomain) :
+    p.Torus ≃ₜ AddCircle (1 : ℝ) × PeriodTorusHigherHomology.ProductTorus 3 :=
+  (Elliptic.flatTorusPeriodHomeomorph p).symm.trans (splitFlatTorusHomeomorph j)
+
+private theorem
+    Elliptic.HigherHomology.splitPeriodTorusHomeomorph_affineBiholomorph (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (x : p.val.Torus) :
+    splitPeriodTorusHomeomorph j p.val (Elliptic.affineBiholomorph j p j.twist x) =
+      ((splitPeriodTorusHomeomorph j p.val x).1 + ((1 / (j.order : ℝ) : ℝ) : AddCircle (1 : ℝ)),
+        fibreTorusHomeomorph j (splitPeriodTorusHomeomorph j p.val x).2) := by
+  obtain ⟨y, rfl⟩ := (Elliptic.flatTorusPeriodHomeomorph p.val).surjective x
+  rw [← Elliptic.flatTorusAffine_periodHomeomorph]
+  simp only [splitPeriodTorusHomeomorph, Homeomorph.trans_apply, Homeomorph.symm_apply_apply]
+  exact splitFlatTorusHomeomorph_flatTorusAffine j y
+
+private def Elliptic.HigherHomology.fibreDifference (j : Elliptic.Kind) :
+    FibreLattice →ₗ[ℤ] FibreLattice :=
+  (fibreMatrix j - 1).mulVecLin
+
+private theorem Elliptic.HigherHomology.fibreDifference_three_apply (v : FibreLattice) :
+    fibreDifference .three v = ![v 1 - v 0, -v 0 - 2 * v 1, v 0] := by
+  ext i
+  fin_cases i <;> simp [fibreDifference, fibreMatrix, dotProduct, Fin.sum_univ_succ]
+  all_goals ring
+
+private theorem Elliptic.HigherHomology.fibreDifference_four_apply (v : FibreLattice) :
+    fibreDifference .four v = ![-v 0 - v 1, v 0 - v 1, v 1] := by
+  ext i
+  fin_cases i <;> simp [fibreDifference, fibreMatrix, dotProduct, Fin.sum_univ_succ]
+  all_goals ring
+
+private theorem Elliptic.HigherHomology.fibreDifference_mem_ker_iff (j : Elliptic.Kind)
+    (v : FibreLattice) : v ∈ LinearMap.ker (fibreDifference j) ↔ v 0 = 0 ∧ v 1 = 0 := by
+  rw [LinearMap.mem_ker]
+  cases j with
+  | three =>
+    rw [fibreDifference_three_apply]
+    constructor
+    · intro hv
+      have h0 := congrFun hv 0
+      have h2 := congrFun hv 2
+      change v 1 - v 0 = 0 at h0
+      change v 0 = 0 at h2
+      omega
+    · rintro ⟨h0, h1⟩
+      ext i
+      fin_cases i <;> simp [h0, h1]
+  | four =>
+    rw [fibreDifference_four_apply]
+    constructor
+    · intro hv
+      have h0 := congrFun hv 0
+      have h2 := congrFun hv 2
+      change -v 0 - v 1 = 0 at h0
+      change v 1 = 0 at h2
+      omega
+    · rintro ⟨h0, h1⟩
+      ext i
+      fin_cases i <;> simp [h0, h1]
+
+private def Elliptic.HigherHomology.fibreKernelVector : FibreLattice :=
+  ![0, 0, 1]
+
+private def Elliptic.HigherHomology.fibreKernelEquivInt (j : Elliptic.Kind) :
+    LinearMap.ker (fibreDifference j) ≃ₗ[ℤ] ℤ
+    where
+  toFun v := v.1 2
+  invFun k := ⟨![0, 0, k], (fibreDifference_mem_ker_iff j _).mpr (by simp)⟩
+  left_inv
+    v := by
+    apply Subtype.ext
+    obtain ⟨h0, h1⟩ := (fibreDifference_mem_ker_iff j v.1).mp v.2
+    ext i
+    fin_cases i <;> simp [h0, h1]
+  right_inv k := rfl
+  map_add' v w := rfl
+  map_smul' k v := rfl
+
+private def
+    Elliptic.HigherHomology.fibreCoinvariantCoordinate (j : Elliptic.Kind) : FibreLattice →ₗ[ℤ] ℤ
+    where
+  toFun
+    v :=
+    match j with
+    | .three => 2 * v 0 + v 1 + 3 * v 2
+    | .four => v 0 + v 1 + 2 * v 2
+  map_add' v w := by cases j <;> simp only [Pi.add_apply] <;> ring
+  map_smul' k
+    v := by cases j <;> simp only [Pi.smul_apply, smul_eq_mul, RingHom.id_apply] <;> ring
+
+@[simp]
+private theorem
+    Elliptic.HigherHomology.fibreCoinvariantCoordinate_section (j : Elliptic.Kind) (k : ℤ) :
+    fibreCoinvariantCoordinate j ![0, k, 0] = k := by
+  cases j <;> simp [fibreCoinvariantCoordinate]
+
+private theorem Elliptic.HigherHomology.fibreCoinvariantCoordinate_surjective (j : Elliptic.Kind) :
+    Function.Surjective (fibreCoinvariantCoordinate j) := fun k =>
+  ⟨![0, k, 0], fibreCoinvariantCoordinate_section j k⟩
+
+@[simp]
+private theorem Elliptic.HigherHomology.fibreCoinvariantCoordinate_difference (j : Elliptic.Kind)
+    (v : FibreLattice) : fibreCoinvariantCoordinate j (fibreDifference j v) = 0 := by
+  cases j <;>
+      simp [fibreCoinvariantCoordinate, fibreDifference_three_apply,
+        fibreDifference_four_apply] <;>
+    ring
+
+private def Elliptic.HigherHomology.fibreRangePreimage (j : Elliptic.Kind) (v : FibreLattice) :
+    FibreLattice :=
+  match j with
+  | .three => ![v 2, v 0 + v 2, 0]
+  | .four => ![-v 0 - v 2, v 2, 0]
+
+private theorem Elliptic.HigherHomology.fibreDifference_rangePreimage (j : Elliptic.Kind)
+    (v : FibreLattice) (hv : fibreCoinvariantCoordinate j v = 0) :
+    fibreDifference j (fibreRangePreimage j v) = v := by
+  cases j with
+  | three =>
+    change 2 * v 0 + v 1 + 3 * v 2 = 0 at hv
+    rw [fibreDifference_three_apply]
+    ext i
+    fin_cases i <;> simp [fibreRangePreimage]
+    all_goals omega
+  | four =>
+    change v 0 + v 1 + 2 * v 2 = 0 at hv
+    rw [fibreDifference_four_apply]
+    ext i
+    fin_cases i <;> simp [fibreRangePreimage]
+    all_goals omega
+
+private theorem
+    Elliptic.HigherHomology.fibreDifference_range_iff (j : Elliptic.Kind) (v : FibreLattice) :
+    v ∈ LinearMap.range (fibreDifference j) ↔ fibreCoinvariantCoordinate j v = 0 := by
+  constructor
+  · rintro ⟨w, rfl⟩
+    exact fibreCoinvariantCoordinate_difference j w
+  · intro hv
+    exact ⟨fibreRangePreimage j v, fibreDifference_rangePreimage j v hv⟩
+
+private theorem Elliptic.HigherHomology.fibreDifference_range_eq_ker (j : Elliptic.Kind) :
+    LinearMap.range (fibreDifference j) = LinearMap.ker (fibreCoinvariantCoordinate j) := by
+  ext v
+  exact fibreDifference_range_iff j v
+
+private def Elliptic.HigherHomology.fibreCokernelEquivInt (j : Elliptic.Kind) :
+    (FibreLattice ⧸ LinearMap.range (fibreDifference j)) ≃ₗ[ℤ] ℤ :=
+  (Submodule.quotEquivOfEq _ _ (fibreDifference_range_eq_ker j)).trans
+    ((fibreCoinvariantCoordinate j).quotKerEquivOfSurjective
+      (fibreCoinvariantCoordinate_surjective j))
+
+private def Elliptic.HigherHomology.fibreSquareDifference (j : Elliptic.Kind) :
+    FibreLattice →ₗ[ℤ] FibreLattice :=
+  (fibreSquareMatrix j - 1).mulVecLin
+
+@[simp]
+private theorem Elliptic.HigherHomology.fibreSquareDifference_three_apply (v : FibreLattice) :
+    fibreSquareDifference .three v = ![0, -v 0 - v 1 + v 2, v 0 - v 1 - 2 * v 2] := by
+  ext i
+  fin_cases i <;>
+    simp [fibreSquareDifference, fibreSquareMatrix, dotProduct, Fin.sum_univ_succ, sub_eq_add_neg]
+  all_goals ring
+
+@[simp]
+private theorem Elliptic.HigherHomology.fibreSquareDifference_four_apply (v : FibreLattice) :
+    fibreSquareDifference .four v = ![0, -v 1 - v 2, v 0 + v 1 - v 2] := by
+  ext i
+  fin_cases i <;>
+    simp [fibreSquareDifference, fibreSquareMatrix, dotProduct, Fin.sum_univ_succ, sub_eq_add_neg]
+  ring
+
+@[simp]
+private theorem Elliptic.HigherHomology.fibreSquareDifference_apply_zero (j : Elliptic.Kind)
+    (v : FibreLattice) : fibreSquareDifference j v 0 = 0 := by cases j <;> simp
+
+private def Elliptic.HigherHomology.fibreSquareKernelVector : Elliptic.Kind → FibreLattice
+  | .three => ![3, -1, 2]
+  | .four => ![2, -1, 1]
+
+@[simp]
+private theorem Elliptic.HigherHomology.fibreSquareKernelVector_one (j : Elliptic.Kind) :
+    fibreSquareKernelVector j 1 = -1 := by cases j <;> rfl
+
+@[simp]
+private theorem Elliptic.HigherHomology.fibreSquareDifference_kernelVector (j : Elliptic.Kind) :
+    fibreSquareDifference j (fibreSquareKernelVector j) = 0 := by
+  cases j <;> ext i <;> fin_cases i <;> simp [fibreSquareKernelVector]
+
+private theorem Elliptic.HigherHomology.fibreSquareDifference_mem_ker_iff (j : Elliptic.Kind)
+    (v : FibreLattice) :
+    v ∈ LinearMap.ker (fibreSquareDifference j) ↔ v = (-v 1) • fibreSquareKernelVector j := by
+  constructor
+  · intro hv
+    have h : fibreSquareDifference j v = 0 := hv
+    cases j
+    · have h₁ : -v 0 - v 1 + v 2 = 0 := by simpa [fibreSquareKernelVector] using congrFun h 1
+      have h₂ : v 0 - v 1 - 2 * v 2 = 0 := by simpa [fibreSquareKernelVector] using congrFun h 2
+      ext i
+      fin_cases i <;> simp [fibreSquareKernelVector] <;> omega
+    · have h₁ : -v 1 - v 2 = 0 := by simpa [fibreSquareKernelVector] using congrFun h 1
+      have h₂ : v 0 + v 1 - v 2 = 0 := by simpa [fibreSquareKernelVector] using congrFun h 2
+      ext i
+      fin_cases i <;> simp [fibreSquareKernelVector] <;> omega
+  · intro hv
+    rw [LinearMap.mem_ker, hv, map_smul, fibreSquareDifference_kernelVector, smul_zero]
+
+private def Elliptic.HigherHomology.fibreSquareKernelEquivInt (j : Elliptic.Kind) :
+    LinearMap.ker (fibreSquareDifference j) ≃ₗ[ℤ] ℤ
+    where
+  toFun v := -(v : FibreLattice) 1
+  invFun
+    k :=
+    ⟨k • fibreSquareKernelVector j, by
+      rw [LinearMap.mem_ker, map_smul, fibreSquareDifference_kernelVector, smul_zero]⟩
+  left_inv
+    v := by
+    apply Subtype.ext
+    exact ((fibreSquareDifference_mem_ker_iff j v).mp v.property).symm
+  right_inv
+    k := by
+    change -(k • fibreSquareKernelVector j) 1 = k
+    simp
+  map_add' v
+    w := by
+    change
+      -((v : FibreLattice) 1 + (w : FibreLattice) 1) =
+        -(v : FibreLattice) 1 + -(w : FibreLattice) 1
+    exact neg_add _ _
+  map_smul' k
+    v := by
+    change -(k * (v : FibreLattice) 1) = k * (-(v : FibreLattice) 1)
+    ring
+
+private def
+    Elliptic.HigherHomology.fibreSquareRangePreimage (j : Elliptic.Kind) (w : FibreLattice) :
+    FibreLattice :=
+  match j with
+  | .three => ![-2 * w 1 - w 2, 0, -w 1 - w 2]
+  | .four => ![w 1 + w 2, -w 1, 0]
+
+private theorem Elliptic.HigherHomology.fibreSquareDifference_rangePreimage (j : Elliptic.Kind)
+    (w : FibreLattice) (hw : w 0 = 0) :
+    fibreSquareDifference j (fibreSquareRangePreimage j w) = w := by
+  cases j <;> ext i <;> fin_cases i <;> simp [fibreSquareRangePreimage, hw] <;> ring
+
+private theorem Elliptic.HigherHomology.fibreSquareDifference_range_iff (j : Elliptic.Kind)
+    (w : FibreLattice) : w ∈ LinearMap.range (fibreSquareDifference j) ↔ w 0 = 0 := by
+  constructor
+  · rintro ⟨v, rfl⟩
+    exact fibreSquareDifference_apply_zero j v
+  · intro hw
+    exact ⟨fibreSquareRangePreimage j w, fibreSquareDifference_rangePreimage j w hw⟩
+
+private def Elliptic.HigherHomology.fibreSquareFirstCoordinate : FibreLattice →ₗ[ℤ] ℤ :=
+  LinearMap.proj 0
+
+@[simp]
+private theorem Elliptic.HigherHomology.fibreSquareFirstCoordinate_apply (w : FibreLattice) :
+    fibreSquareFirstCoordinate w = w 0 :=
+  rfl
+
+private theorem Elliptic.HigherHomology.fibreSquareFirstCoordinate_surjective :
+    Function.Surjective fibreSquareFirstCoordinate := by
+  intro k
+  exact ⟨![k, 0, 0], rfl⟩
+
+private theorem Elliptic.HigherHomology.fibreSquareDifference_range_eq_ker (j : Elliptic.Kind) :
+    LinearMap.range (fibreSquareDifference j) = LinearMap.ker fibreSquareFirstCoordinate := by
+  ext w
+  rw [fibreSquareDifference_range_iff, LinearMap.mem_ker, fibreSquareFirstCoordinate_apply]
+
+private def Elliptic.HigherHomology.fibreSquareCokernelEquivInt (j : Elliptic.Kind) :
+    (FibreLattice ⧸ LinearMap.range (fibreSquareDifference j)) ≃ₗ[ℤ] ℤ :=
+  (Submodule.quotEquivOfEq _ _ (fibreSquareDifference_range_eq_ker j)).trans
+    (fibreSquareFirstCoordinate.quotKerEquivOfSurjective fibreSquareFirstCoordinate_surjective)
+
+private theorem Elliptic.HigherHomology.matrixInverseDifference_mul (M : FibreMatrix)
+    (hM : IsUnit M.det) : (1 - M⁻¹) * M = M - 1 := by
+  rw [sub_mul, one_mul, Matrix.nonsing_inv_mul M hM]
+
+private theorem Elliptic.HigherHomology.matrixInverseDifference_ker_eq (M : FibreMatrix)
+    (hM : IsUnit M.det) : LinearMap.ker (1 - M⁻¹).mulVecLin = LinearMap.ker (M - 1).mulVecLin := by
+  ext v
+  simp only [LinearMap.mem_ker, Matrix.mulVecLin_apply, Matrix.sub_mulVec, Matrix.one_mulVec,
+    sub_eq_zero]
+  constructor
+  · intro hv
+    have h := congrArg (fun w : FibreLattice => M *ᵥ w) hv
+    simpa only [Matrix.mulVec_mulVec, Matrix.mul_nonsing_inv M hM, Matrix.one_mulVec] using h
+  · intro hv
+    have h := congrArg (fun w : FibreLattice => M⁻¹ *ᵥ w) hv
+    simpa only [Matrix.mulVec_mulVec, Matrix.nonsing_inv_mul M hM, Matrix.one_mulVec] using h
+
+private theorem Elliptic.HigherHomology.matrixInverseDifference_range_eq (M : FibreMatrix)
+    (hM : IsUnit M.det) :
+    LinearMap.range (1 - M⁻¹).mulVecLin = LinearMap.range (M - 1).mulVecLin := by
+  ext v
+  constructor
+  · rintro ⟨w, hw⟩
+    refine ⟨M⁻¹ *ᵥ w, ?_⟩
+    change (M - 1) *ᵥ M⁻¹ *ᵥ w = v
+    rw [Matrix.mulVec_mulVec, sub_mul, Matrix.mul_nonsing_inv M hM, one_mul]
+    exact hw
+  · rintro ⟨w, hw⟩
+    refine ⟨M *ᵥ w, ?_⟩
+    change (1 - M⁻¹) *ᵥ M *ᵥ w = v
+    rw [Matrix.mulVec_mulVec, matrixInverseDifference_mul M hM]
+    exact hw
+
+private def Elliptic.HigherHomology.fibreInverseDifference (j : Elliptic.Kind) :
+    FibreLattice →ₗ[ℤ] FibreLattice :=
+  (1 - (fibreMatrix j)⁻¹).mulVecLin
+
+private def Elliptic.HigherHomology.fibreSquareInverseDifference (j : Elliptic.Kind) :
+    FibreLattice →ₗ[ℤ] FibreLattice :=
+  (1 - (fibreSquareMatrix j)⁻¹).mulVecLin
+
+private theorem Elliptic.HigherHomology.fibreInverseDifference_ker_eq (j : Elliptic.Kind) :
+    LinearMap.ker (fibreInverseDifference j) = LinearMap.ker (fibreDifference j) :=
+  matrixInverseDifference_ker_eq _ (by simp [fibreMatrix_det])
+
+private theorem Elliptic.HigherHomology.fibreInverseDifference_range_eq (j : Elliptic.Kind) :
+    LinearMap.range (fibreInverseDifference j) = LinearMap.range (fibreDifference j) :=
+  matrixInverseDifference_range_eq _ (by simp [fibreMatrix_det])
+
+private theorem Elliptic.HigherHomology.fibreSquareInverseDifference_ker_eq (j : Elliptic.Kind) :
+    LinearMap.ker (fibreSquareInverseDifference j) = LinearMap.ker (fibreSquareDifference j) :=
+  matrixInverseDifference_ker_eq _ (by simp [fibreSquareMatrix_det])
+
+private theorem Elliptic.HigherHomology.fibreSquareInverseDifference_range_eq (j : Elliptic.Kind) :
+    LinearMap.range (fibreSquareInverseDifference j) =
+      LinearMap.range (fibreSquareDifference j) :=
+  matrixInverseDifference_range_eq _ (by simp [fibreSquareMatrix_det])
+
+private def Elliptic.HigherHomology.fibreInverseKernelEquivInt (j : Elliptic.Kind) :
+    LinearMap.ker (fibreInverseDifference j) ≃ₗ[ℤ] ℤ :=
+  (LinearEquiv.ofEq _ _ (fibreInverseDifference_ker_eq j)).trans (fibreKernelEquivInt j)
+
+private def Elliptic.HigherHomology.fibreInverseCokernelEquivInt (j : Elliptic.Kind) :
+    (FibreLattice ⧸ LinearMap.range (fibreInverseDifference j)) ≃ₗ[ℤ] ℤ :=
+  (Submodule.quotEquivOfEq _ _ (fibreInverseDifference_range_eq j)).trans
+    (fibreCokernelEquivInt j)
+
+private def Elliptic.HigherHomology.fibreSquareInverseKernelEquivInt (j : Elliptic.Kind) :
+    LinearMap.ker (fibreSquareInverseDifference j) ≃ₗ[ℤ] ℤ :=
+  (LinearEquiv.ofEq _ _ (fibreSquareInverseDifference_ker_eq j)).trans
+    (fibreSquareKernelEquivInt j)
+
+private def Elliptic.HigherHomology.fibreSquareInverseCokernelEquivInt (j : Elliptic.Kind) :
+    (FibreLattice ⧸ LinearMap.range (fibreSquareInverseDifference j)) ≃ₗ[ℤ] ℤ :=
+  (Submodule.quotEquivOfEq _ _ (fibreSquareInverseDifference_range_eq j)).trans
+    (fibreSquareCokernelEquivInt j)
+
+private def Elliptic.HigherHomology.inclusionMatrix_mo1973_21667 : Matrix (Fin 4) (Fin 3) ℤ :=
+  !![0, 0, 0; 1, 0, 0; 0, 1, 0; 0, 0, 1]
+
+private def Elliptic.HigherHomology.projectionMatrix_mo1973_21668 : Matrix (Fin 3) (Fin 4) ℤ :=
+  !![0, 1, 0, 0; 0, 0, 1, 0; 0, 0, 0, 1]
+
+private theorem Elliptic.HigherHomology.projection_inclusion_mo1973_21669 :
+    projectionMatrix_mo1973_21668 * inclusionMatrix_mo1973_21667 = 1 := by decide
+
+private theorem Elliptic.HigherHomology.projection_inclusion_mulVec_mo1973_21670
+    (v : FibreLattice) :
+    projectionMatrix_mo1973_21668 *ᵥ (inclusionMatrix_mo1973_21667 *ᵥ v) = v := by
+  rw [Matrix.mulVec_mulVec, projection_inclusion_mo1973_21669, Matrix.one_mulVec]
+
+private theorem Elliptic.HigherHomology.projected_coordinateH1_four_mo1973_21671 :
+    (FirstHurewicz.inducedHomology
+            (PeriodTorusHigherHomology.torusMatrixMap projectionMatrix_mo1973_21668)).comp
+        ((PeriodTorusHigherHomology.coordinateH1 4).comp inclusionMatrix_mo1973_21667.mulVecLin) =
+      PeriodTorusHigherHomology.coordinateH1 3 := by
+  apply (Pi.basisFun ℤ (Fin 3)).ext
+  intro i
+  simp only [LinearMap.comp_apply, Matrix.mulVecLin_apply]
+  rw [PeriodTorusHigherHomology.coordinateH1_four_apply (Elliptic.examplePeriod .four),
+    PeriodTorusHigherHomology.torusMatrixMap_coordinatePeriodHomology,
+    projection_inclusion_mulVec_mo1973_21670, PeriodTorusHigherHomology.coordinateH1_basis]
+  simp only [Pi.basisFun_apply]
+
+private theorem Elliptic.HigherHomology.coordinateH1_three_apply (v : FibreLattice) :
+    PeriodTorusHigherHomology.coordinateH1 3 v =
+      FirstHurewicz.loopHomologyClass (PeriodTorusHigherHomology.coordinatePeriodLoop 3 v) := by
+  rw [← projected_coordinateH1_four_mo1973_21671]
+  change
+    FirstHurewicz.inducedHomology
+        (PeriodTorusHigherHomology.torusMatrixMap projectionMatrix_mo1973_21668)
+        (PeriodTorusHigherHomology.coordinateH1 4 (inclusionMatrix_mo1973_21667 *ᵥ v)) =
+      _
+  rw [PeriodTorusHigherHomology.coordinateH1_four_apply (Elliptic.examplePeriod .four),
+    PeriodTorusHigherHomology.torusMatrixMap_coordinatePeriodHomology,
+    projection_inclusion_mulVec_mo1973_21670]
+
+private theorem Elliptic.HigherHomology.projection_inclusion_homology_mo1973_21673
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 1) :
+    FirstHurewicz.inducedHomology
+        (PeriodTorusHigherHomology.torusMatrixMap projectionMatrix_mo1973_21668)
+        (FirstHurewicz.inducedHomology
+          (PeriodTorusHigherHomology.torusMatrixMap inclusionMatrix_mo1973_21667) a) =
+      a := by
+  calc
+    _ =
+        FirstHurewicz.inducedHomology
+          ((PeriodTorusHigherHomology.torusMatrixMap projectionMatrix_mo1973_21668).comp
+            (PeriodTorusHigherHomology.torusMatrixMap inclusionMatrix_mo1973_21667))
+          a := by rw [FirstHurewicz.inducedHomology_comp, LinearMap.comp_apply]
+    _ = a := by
+      rw [← PeriodTorusHigherHomology.torusMatrixMap_mul, projection_inclusion_mo1973_21669,
+        PeriodTorusHigherHomology.torusMatrixMap_one, FirstHurewicz.inducedHomology_id,
+        LinearMap.id_apply]
+
+private theorem Elliptic.HigherHomology.coordinateH1_three_bijective :
+    Function.Bijective (PeriodTorusHigherHomology.coordinateH1 3) := by
+  constructor
+  · intro v w hvw
+    have h :=
+      congrArg
+        (FirstHurewicz.inducedHomology
+          (PeriodTorusHigherHomology.torusMatrixMap inclusionMatrix_mo1973_21667))
+        hvw
+    rw [coordinateH1_three_apply, coordinateH1_three_apply,
+      PeriodTorusHigherHomology.torusMatrixMap_coordinatePeriodHomology,
+      PeriodTorusHigherHomology.torusMatrixMap_coordinatePeriodHomology] at h
+    have h' : inclusionMatrix_mo1973_21667 *ᵥ v = inclusionMatrix_mo1973_21667 *ᵥ w :=
+      (PeriodTorusHigherHomology.coordinateH1_four_bijective
+            (Elliptic.examplePeriod .four)).injective
+        (by
+          simpa only [PeriodTorusHigherHomology.coordinateH1_four_apply
+                (Elliptic.examplePeriod .four)] using
+            h)
+    have h'' := congrArg (fun u => projectionMatrix_mo1973_21668 *ᵥ u) h'
+    simpa only [projection_inclusion_mulVec_mo1973_21670] using h''
+  · intro a
+    obtain ⟨v, hv⟩ :=
+      (PeriodTorusHigherHomology.coordinateH1_four_bijective
+            (Elliptic.examplePeriod .four)).surjective
+        (FirstHurewicz.inducedHomology
+          (PeriodTorusHigherHomology.torusMatrixMap inclusionMatrix_mo1973_21667) a)
+    refine ⟨projectionMatrix_mo1973_21668 *ᵥ v, ?_⟩
+    calc
+      _ =
+          FirstHurewicz.inducedHomology
+            (PeriodTorusHigherHomology.torusMatrixMap projectionMatrix_mo1973_21668)
+            (PeriodTorusHigherHomology.coordinateH1 4 v) := by
+        rw [coordinateH1_three_apply,
+          PeriodTorusHigherHomology.coordinateH1_four_apply (Elliptic.examplePeriod .four),
+          PeriodTorusHigherHomology.torusMatrixMap_coordinatePeriodHomology]
+      _ = a := by rw [hv, projection_inclusion_homology_mo1973_21673]
+
+private theorem Elliptic.HigherHomology.coordinateH1_three_matrix_natural (A : FibreMatrix)
+    (v : FibreLattice) :
+    SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap A) 1
+        (PeriodTorusHigherHomology.coordinateH1 3 v) =
+      PeriodTorusHigherHomology.coordinateH1 3 (A *ᵥ v) := by
+  rw [SingularMayerVietoris.singularHomologyMap_one, coordinateH1_three_apply,
+    coordinateH1_three_apply, PeriodTorusHigherHomology.torusMatrixMap_coordinatePeriodHomology]
+
+private def Elliptic.HigherHomology.torusH1Equiv :
+    SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 1 ≃ₗ[ℤ]
+      FibreLattice :=
+  (LinearEquiv.ofBijective (PeriodTorusHigherHomology.coordinateH1 3)
+      coordinateH1_three_bijective).symm
+
+private theorem Elliptic.HigherHomology.torusH1Equiv_symm_apply_loop (v : FibreLattice) :
+    torusH1Equiv.symm v =
+      FirstHurewicz.loopHomologyClass (PeriodTorusHigherHomology.coordinatePeriodLoop 3 v) :=
+  coordinateH1_three_apply v
+
+@[simp]
+private theorem Elliptic.HigherHomology.torusH1Equiv_coordinateH1 (v : FibreLattice) :
+    torusH1Equiv (PeriodTorusHigherHomology.coordinateH1 3 v) = v :=
+  torusH1Equiv.apply_symm_apply v
+
+private theorem Elliptic.HigherHomology.torusH1Equiv_matrix_natural (A : FibreMatrix)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 1) :
+    torusH1Equiv
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap A) 1
+          a) =
+      A *ᵥ torusH1Equiv a := by
+  obtain ⟨v, rfl⟩ := coordinateH1_three_bijective.surjective a
+  rw [coordinateH1_three_matrix_natural, torusH1Equiv_coordinateH1, torusH1Equiv_coordinateH1]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def Elliptic.HigherHomology.markedWedgeTwo (G : Type) [TopologicalSpace G] [AddCommGroup G]
+    [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] {M : Type*}
+    [AddCommGroup M] [Module ℤ M] (c : M →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1) :
+    (⋀[ℤ]^2 M) →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 2 :=
+  (PeriodTorusHigherHomologyPontryagin.homologyWedgeTwo G).comp (exteriorPower.map 2 c)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    Elliptic.HigherHomology.markedWedgeThree (G : Type) [TopologicalSpace G] [AddCommGroup G]
+    [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] {M : Type*}
+    [AddCommGroup M] [Module ℤ M] (c : M →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1) :
+    (⋀[ℤ]^3 M) →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 3 :=
+  (PeriodTorusHigherHomologyPontryagin.homologyWedgeThree G).comp (exteriorPower.map 3 c)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem Elliptic.HigherHomology.markedWedgeTwo_apply_ιMulti (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] {M : Type*}
+    [AddCommGroup M] [Module ℤ M] (c : M →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1)
+    (v : Fin 2 → M) :
+    markedWedgeTwo G c (exteriorPower.ιMulti ℤ 2 v) =
+      PeriodTorusHigherHomologyPontryagin.product11 G (c (v 0)) (c (v 1)) := by
+  change
+    PeriodTorusHigherHomologyPontryagin.homologyWedgeTwo G
+        (exteriorPower.map 2 c (exteriorPower.ιMulti ℤ 2 v)) =
+      _
+  rw [exteriorPower.map_apply_ιMulti,
+    PeriodTorusHigherHomologyPontryagin.homologyWedgeTwo_apply_ιMulti]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem
+    Elliptic.HigherHomology.markedWedgeThree_apply_ιMulti (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] {M : Type*}
+    [AddCommGroup M] [Module ℤ M] (c : M →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1)
+    (v : Fin 3 → M) :
+    markedWedgeThree G c (exteriorPower.ιMulti ℤ 3 v) =
+      PeriodTorusHigherHomologyPontryagin.tripleProduct G (c (v 0)) (c (v 1)) (c (v 2)) := by
+  change
+    PeriodTorusHigherHomologyPontryagin.homologyWedgeThree G
+        (exteriorPower.map 3 c (exteriorPower.ιMulti ℤ 3 v)) =
+      _
+  rw [exteriorPower.map_apply_ιMulti,
+    PeriodTorusHigherHomologyPontryagin.homologyWedgeThree_apply_ιMulti]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    Elliptic.HigherHomology.product11_mem_range_markedWedgeTwo (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] {M : Type*}
+    [AddCommGroup M] [Module ℤ M] (c : M →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1)
+    (hc : Function.Surjective c) (a b : SingularMayerVietoris.SingularHomology G 1) :
+    PeriodTorusHigherHomologyPontryagin.product11 G a b ∈ LinearMap.range (markedWedgeTwo G c) := by
+  obtain ⟨v, rfl⟩ := hc a
+  obtain ⟨w, rfl⟩ := hc b
+  refine ⟨exteriorPower.ιMulti ℤ 2 ![v, w], ?_⟩
+  simp
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem Elliptic.HigherHomology.tripleProduct_mem_range_markedWedgeThree (G : Type)
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] {M : Type*}
+    [AddCommGroup M] [Module ℤ M] (c : M →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1)
+    (hc : Function.Surjective c) (a b d : SingularMayerVietoris.SingularHomology G 1) :
+    PeriodTorusHigherHomologyPontryagin.tripleProduct G a b d ∈
+      LinearMap.range (markedWedgeThree G c) := by
+  obtain ⟨v, rfl⟩ := hc a
+  obtain ⟨w, rfl⟩ := hc b
+  obtain ⟨u, rfl⟩ := hc d
+  refine ⟨exteriorPower.ιMulti ℤ 3 ![v, w, u], ?_⟩
+  simp
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem Elliptic.HigherHomology.markedWedgeTwo_natural {G H : Type} [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G] [TopologicalSpace H] [AddCommGroup H]
+    [IsTopologicalAddGroup H]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology H 2)] {M N : Type*}
+    [AddCommGroup M] [Module ℤ M] [AddCommGroup N] [Module ℤ N] (f : C(G, H))
+    (hf : ∀ x y, f (x + y) = f x + f y) (c : M →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1)
+    (d : N →ₗ[ℤ] SingularMayerVietoris.SingularHomology H 1) (A : M →ₗ[ℤ] N)
+    (hmark : ∀ v, SingularMayerVietoris.singularHomologyMap f 1 (c v) = d (A v)) :
+    (SingularMayerVietoris.singularHomologyMap f 2).comp (markedWedgeTwo G c) =
+      (markedWedgeTwo H d).comp (exteriorPower.map 2 A) := by
+  apply exteriorPower.linearMap_ext
+  apply AlternatingMap.ext
+  intro v
+  change
+    SingularMayerVietoris.singularHomologyMap f 2
+        (markedWedgeTwo G c (exteriorPower.ιMulti ℤ 2 v)) =
+      markedWedgeTwo H d (exteriorPower.map 2 A (exteriorPower.ιMulti ℤ 2 v))
+  rw [exteriorPower.map_apply_ιMulti, markedWedgeTwo_apply_ιMulti, markedWedgeTwo_apply_ιMulti,
+    PeriodTorusHigherHomologyPontryagin.product_natural f hf 1, hmark, hmark]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem Elliptic.HigherHomology.markedWedgeThree_natural {G H : Type} [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G] [TopologicalSpace H] [AddCommGroup H]
+    [IsTopologicalAddGroup H]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology H 2)] {M N : Type*}
+    [AddCommGroup M] [Module ℤ M] [AddCommGroup N] [Module ℤ N] (f : C(G, H))
+    (hf : ∀ x y, f (x + y) = f x + f y) (c : M →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1)
+    (d : N →ₗ[ℤ] SingularMayerVietoris.SingularHomology H 1) (A : M →ₗ[ℤ] N)
+    (hmark : ∀ v, SingularMayerVietoris.singularHomologyMap f 1 (c v) = d (A v)) :
+    (SingularMayerVietoris.singularHomologyMap f 3).comp (markedWedgeThree G c) =
+      (markedWedgeThree H d).comp (exteriorPower.map 3 A) := by
+  apply exteriorPower.linearMap_ext
+  apply AlternatingMap.ext
+  intro v
+  change
+    SingularMayerVietoris.singularHomologyMap f 3
+        (markedWedgeThree G c (exteriorPower.ιMulti ℤ 3 v)) =
+      markedWedgeThree H d (exteriorPower.map 3 A (exteriorPower.ιMulti ℤ 3 v))
+  rw [exteriorPower.map_apply_ιMulti, markedWedgeThree_apply_ιMulti,
+    markedWedgeThree_apply_ιMulti, PeriodTorusHigherHomologyPontryagin.tripleProduct_natural f hf,
+    hmark, hmark, hmark]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem Elliptic.HigherHomology.map_topClass_two_mem_range_markedWedgeTwo {G : Type}
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] {M : Type*}
+    [AddCommGroup M] [Module ℤ M] (c : M →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1)
+    (hc : Function.Surjective c) (f : C(PeriodTorusHigherHomology.ProductTorus 2, G))
+    (hf : ∀ x y, f (x + y) = f x + f y) :
+    SingularMayerVietoris.singularHomologyMap f 2
+        (PeriodTorusHigherHomology.productTorusTopClass 2) ∈
+      LinearMap.range (markedWedgeTwo G c) := by
+  obtain ⟨a, b, hab⟩ := PeriodTorusHigherHomology.productTorusTopClass_two_is_product
+  rw [hab, PeriodTorusHigherHomologyPontryagin.product_natural f hf 1]
+  exact product11_mem_range_markedWedgeTwo G c hc _ _
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem Elliptic.HigherHomology.map_topClass_three_mem_range_markedWedgeThree {G : Type}
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] {M : Type*}
+    [AddCommGroup M] [Module ℤ M] (c : M →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1)
+    (hc : Function.Surjective c) (f : C(PeriodTorusHigherHomology.ProductTorus 3, G))
+    (hf : ∀ x y, f (x + y) = f x + f y) :
+    SingularMayerVietoris.singularHomologyMap f 3
+        (PeriodTorusHigherHomology.productTorusTopClass 3) ∈
+      LinearMap.range (markedWedgeThree G c) := by
+  obtain ⟨a, b, d, habd⟩ := PeriodTorusHigherHomology.productTorusTopClass_three_is_tripleProduct
+  rw [habd, PeriodTorusHigherHomologyPontryagin.tripleProduct_natural f hf]
+  exact tripleProduct_mem_range_markedWedgeThree G c hc _ _ _
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    Elliptic.HigherHomology.coordinateTorusClassAlong_mem_range_markedWedgeTwo {G : Type}
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] {M : Type*}
+    [AddCommGroup M] [Module ℤ M] {r : ℕ} (e : G ≃ₜ PeriodTorusHigherHomology.ProductTorus r)
+    (he : ∀ x y, e (x + y) = e x + e y) (c : M →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1)
+    (hc : Function.Surjective c) (i : Fin (r.choose 2)) :
+    PeriodTorusHigherHomology.coordinateTorusClassAlong e 2 i ∈
+      LinearMap.range (markedWedgeTwo G c) :=
+  map_topClass_two_mem_range_markedWedgeTwo c hc
+    (PeriodTorusHigherHomology.coordinateTorusMapAlong e 2 i)
+    (PeriodTorusHigherHomology.coordinateTorusMapAlong_add e he 2 i)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    Elliptic.HigherHomology.coordinateTorusClassAlong_mem_range_markedWedgeThree {G : Type}
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] {M : Type*}
+    [AddCommGroup M] [Module ℤ M] {r : ℕ} (e : G ≃ₜ PeriodTorusHigherHomology.ProductTorus r)
+    (he : ∀ x y, e (x + y) = e x + e y) (c : M →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1)
+    (hc : Function.Surjective c) (i : Fin (r.choose 3)) :
+    PeriodTorusHigherHomology.coordinateTorusClassAlong e 3 i ∈
+      LinearMap.range (markedWedgeThree G c) :=
+  map_topClass_three_mem_range_markedWedgeThree c hc
+    (PeriodTorusHigherHomology.coordinateTorusMapAlong e 3 i)
+    (PeriodTorusHigherHomology.coordinateTorusMapAlong_add e he 3 i)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem Elliptic.HigherHomology.markedWedgeTwo_surjective_of_torusHomeomorph {G : Type}
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] {M : Type*}
+    [AddCommGroup M] [Module ℤ M] {r : ℕ} (e : G ≃ₜ PeriodTorusHigherHomology.ProductTorus r)
+    (he : ∀ x y, e (x + y) = e x + e y) (c : M →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1)
+    (hc : Function.Surjective c) : Function.Surjective (markedWedgeTwo G c) :=
+  PeriodTorusHigherHomology.surjective_of_coordinateTorusClassAlong_mem_range e 2
+    (markedWedgeTwo G c) (coordinateTorusClassAlong_mem_range_markedWedgeTwo e he c hc)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem Elliptic.HigherHomology.markedWedgeThree_surjective_of_torusHomeomorph {G : Type}
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] {M : Type*}
+    [AddCommGroup M] [Module ℤ M] {r : ℕ} (e : G ≃ₜ PeriodTorusHigherHomology.ProductTorus r)
+    (he : ∀ x y, e (x + y) = e x + e y) (c : M →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1)
+    (hc : Function.Surjective c) : Function.Surjective (markedWedgeThree G c) :=
+  PeriodTorusHigherHomology.surjective_of_coordinateTorusClassAlong_mem_range e 3
+    (markedWedgeThree G c) (coordinateTorusClassAlong_mem_range_markedWedgeThree e he c hc)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def Elliptic.HigherHomology.torusWedgeTwo :
+    (⋀[ℤ]^2 FibreLattice) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 2 := by
+  letI := PeriodTorusHigherHomology.productTorus_homology_torsionFree 3 2
+  exact
+    markedWedgeTwo (PeriodTorusHigherHomology.ProductTorus 3)
+      (PeriodTorusHigherHomology.coordinateH1 3)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def Elliptic.HigherHomology.torusWedgeThree :
+    (⋀[ℤ]^3 FibreLattice) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3 := by
+  letI := PeriodTorusHigherHomology.productTorus_homology_torsionFree 3 2
+  exact
+    markedWedgeThree (PeriodTorusHigherHomology.ProductTorus 3)
+      (PeriodTorusHigherHomology.coordinateH1 3)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem Elliptic.HigherHomology.torusWedgeTwo_ιMulti (v : Fin 2 → FibreLattice) :
+    torusWedgeTwo (exteriorPower.ιMulti ℤ 2 v) =
+      PeriodTorusHigherHomologyPontryagin.product11 (PeriodTorusHigherHomology.ProductTorus 3)
+        (PeriodTorusHigherHomology.coordinateH1 3 (v 0))
+        (PeriodTorusHigherHomology.coordinateH1 3 (v 1)) := by
+  let := PeriodTorusHigherHomology.productTorus_homology_torsionFree 3 2
+  exact
+    markedWedgeTwo_apply_ιMulti (PeriodTorusHigherHomology.ProductTorus 3)
+      (PeriodTorusHigherHomology.coordinateH1 3) v
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem Elliptic.HigherHomology.torusWedgeThree_ιMulti (v : Fin 3 → FibreLattice) :
+    torusWedgeThree (exteriorPower.ιMulti ℤ 3 v) =
+      PeriodTorusHigherHomologyPontryagin.tripleProduct (PeriodTorusHigherHomology.ProductTorus 3)
+        (PeriodTorusHigherHomology.coordinateH1 3 (v 0))
+        (PeriodTorusHigherHomology.coordinateH1 3 (v 1))
+        (PeriodTorusHigherHomology.coordinateH1 3 (v 2)) := by
+  let := PeriodTorusHigherHomology.productTorus_homology_torsionFree 3 2
+  exact
+    markedWedgeThree_apply_ιMulti (PeriodTorusHigherHomology.ProductTorus 3)
+      (PeriodTorusHigherHomology.coordinateH1 3) v
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem Elliptic.HigherHomology.torusWedgeTwo_ιMulti_loops (v : Fin 2 → FibreLattice) :
+    torusWedgeTwo (exteriorPower.ιMulti ℤ 2 v) =
+      PeriodTorusHigherHomologyPontryagin.product11 (PeriodTorusHigherHomology.ProductTorus 3)
+        (FirstHurewicz.loopHomologyClass (PeriodTorusHigherHomology.coordinatePeriodLoop 3 (v 0)))
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 3 (v 1))) := by
+  rw [torusWedgeTwo_ιMulti, coordinateH1_three_apply, coordinateH1_three_apply]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem Elliptic.HigherHomology.torusWedgeThree_ιMulti_loops (v : Fin 3 → FibreLattice) :
+    torusWedgeThree (exteriorPower.ιMulti ℤ 3 v) =
+      PeriodTorusHigherHomologyPontryagin.tripleProduct (PeriodTorusHigherHomology.ProductTorus 3)
+        (FirstHurewicz.loopHomologyClass (PeriodTorusHigherHomology.coordinatePeriodLoop 3 (v 0)))
+        (FirstHurewicz.loopHomologyClass (PeriodTorusHigherHomology.coordinatePeriodLoop 3 (v 1)))
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 3 (v 2))) := by
+  rw [torusWedgeThree_ιMulti, coordinateH1_three_apply, coordinateH1_three_apply,
+    coordinateH1_three_apply]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem Elliptic.HigherHomology.torusWedgeTwo_natural
+    (f : C(PeriodTorusHigherHomology.ProductTorus 3, PeriodTorusHigherHomology.ProductTorus 3))
+    (hf : ∀ x y, f (x + y) = f x + f y) (A : FibreLattice →ₗ[ℤ] FibreLattice)
+    (hmark :
+      ∀ v,
+        SingularMayerVietoris.singularHomologyMap f 1
+            (PeriodTorusHigherHomology.coordinateH1 3 v) =
+          PeriodTorusHigherHomology.coordinateH1 3 (A v)) :
+    (SingularMayerVietoris.singularHomologyMap f 2).comp torusWedgeTwo =
+      torusWedgeTwo.comp (exteriorPower.map 2 A) := by
+  let := PeriodTorusHigherHomology.productTorus_homology_torsionFree 3 2
+  exact
+    markedWedgeTwo_natural f hf (PeriodTorusHigherHomology.coordinateH1 3)
+      (PeriodTorusHigherHomology.coordinateH1 3) A hmark
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem Elliptic.HigherHomology.torusWedgeThree_natural
+    (f : C(PeriodTorusHigherHomology.ProductTorus 3, PeriodTorusHigherHomology.ProductTorus 3))
+    (hf : ∀ x y, f (x + y) = f x + f y) (A : FibreLattice →ₗ[ℤ] FibreLattice)
+    (hmark :
+      ∀ v,
+        SingularMayerVietoris.singularHomologyMap f 1
+            (PeriodTorusHigherHomology.coordinateH1 3 v) =
+          PeriodTorusHigherHomology.coordinateH1 3 (A v)) :
+    (SingularMayerVietoris.singularHomologyMap f 3).comp torusWedgeThree =
+      torusWedgeThree.comp (exteriorPower.map 3 A) := by
+  let := PeriodTorusHigherHomology.productTorus_homology_torsionFree 3 2
+  exact
+    markedWedgeThree_natural f hf (PeriodTorusHigherHomology.coordinateH1 3)
+      (PeriodTorusHigherHomology.coordinateH1 3) A hmark
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    Elliptic.HigherHomology.torusWedgeTwo_surjective : Function.Surjective torusWedgeTwo := by
+  let := PeriodTorusHigherHomology.productTorus_homology_torsionFree 3 2
+  exact
+    markedWedgeTwo_surjective_of_torusHomeomorph
+      (Homeomorph.refl (PeriodTorusHigherHomology.ProductTorus 3)) (fun _ _ => rfl)
+      (PeriodTorusHigherHomology.coordinateH1 3) coordinateH1_three_bijective.surjective
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem Elliptic.HigherHomology.torusWedgeThree_surjective :
+    Function.Surjective torusWedgeThree := by
+  let := PeriodTorusHigherHomology.productTorus_homology_torsionFree 3 2
+  exact
+    markedWedgeThree_surjective_of_torusHomeomorph
+      (Homeomorph.refl (PeriodTorusHigherHomology.ProductTorus 3)) (fun _ _ => rfl)
+      (PeriodTorusHigherHomology.coordinateH1 3) coordinateH1_three_bijective.surjective
+
+private abbrev Elliptic.HigherHomology.torusExterior (n : ℕ) :=
+  ⋀[ℤ]^n FibreLattice
+
+private def Elliptic.HigherHomology.torusLatticeBasis : Module.Basis (Fin 3) ℤ FibreLattice :=
+  Pi.basisFun ℤ (Fin 3)
+
+private def Elliptic.HigherHomology.torusExteriorBasis (n : ℕ) :
+    Module.Basis (Set.powersetCard (Fin 3) n) ℤ (torusExterior n) :=
+  PeriodTorusHigherHomologyExterior.standardExteriorBasis 3 n
+
+private theorem
+    Elliptic.HigherHomology.fibrePair_strictMono (i : Fin 3) : StrictMono (fibrePair i) := by
+  fin_cases i <;> decide
+
+private theorem
+    Elliptic.HigherHomology.fibrePair_injective : Function.Injective fibrePair := by decide
+
+private def Elliptic.HigherHomology.torusPairEmbedding (i : Fin 3) : Fin 2 ↪o Fin 3 :=
+  OrderEmbedding.ofStrictMono (fibrePair i) (fibrePair_strictMono i)
+
+private def Elliptic.HigherHomology.torusTripleEmbedding (_i : Fin 1) : Fin 3 ↪o Fin 3 :=
+  OrderEmbedding.ofStrictMono id strictMono_id
+
+private def Elliptic.HigherHomology.torusPairSubset (i : Fin 3) : Set.powersetCard (Fin 3) 2 :=
+  Set.powersetCard.ofFinEmbEquiv (torusPairEmbedding i)
+
+private def Elliptic.HigherHomology.torusTripleSubset (i : Fin 1) : Set.powersetCard (Fin 3) 3 :=
+  Set.powersetCard.ofFinEmbEquiv (torusTripleEmbedding i)
+
+@[simp]
+private theorem Elliptic.HigherHomology.torusPairSubset_ordered (i : Fin 3) :
+    (Set.powersetCard.ofFinEmbEquiv.symm (torusPairSubset i) : Fin 2 → Fin 3) = fibrePair i := by
+  rw [torusPairSubset, Equiv.symm_apply_apply]
+  rfl
+
+@[simp]
+private theorem Elliptic.HigherHomology.torusTripleSubset_ordered (i : Fin 1) :
+    (Set.powersetCard.ofFinEmbEquiv.symm (torusTripleSubset i) : Fin 3 → Fin 3) = id := by
+  rw [torusTripleSubset, Equiv.symm_apply_apply]
+  rfl
+
+private theorem
+    Elliptic.HigherHomology.torusPairSubset_injective : Function.Injective torusPairSubset := by
+  intro i j hij
+  apply fibrePair_injective
+  simpa only [torusPairSubset_ordered] using
+    congrArg (fun s => (Set.powersetCard.ofFinEmbEquiv.symm s : Fin 2 → Fin 3)) hij
+
+private theorem Elliptic.HigherHomology.torusTripleSubset_injective :
+    Function.Injective torusTripleSubset := by
+  intro i j _
+  exact Subsingleton.elim i j
+
+private theorem
+    Elliptic.HigherHomology.torusPairSubset_bijective : Function.Bijective torusPairSubset := by
+  apply (Fintype.bijective_iff_injective_and_card _).mpr
+  refine ⟨torusPairSubset_injective, ?_⟩
+  simpa only [Nat.card_eq_fintype_card, Fintype.card_fin, show Nat.choose 3 2 = 3 by decide] using
+    (Set.powersetCard.card (Fin 3) 2).symm
+
+private theorem Elliptic.HigherHomology.torusTripleSubset_bijective :
+    Function.Bijective torusTripleSubset := by
+  apply (Fintype.bijective_iff_injective_and_card _).mpr
+  refine ⟨torusTripleSubset_injective, ?_⟩
+  simpa only [Nat.card_eq_fintype_card, Fintype.card_fin, show Nat.choose 3 3 = 1 by decide] using
+    (Set.powersetCard.card (Fin 3) 3).symm
+
+private def Elliptic.HigherHomology.torusPairSubsetEquiv : Fin 3 ≃ Set.powersetCard (Fin 3) 2 :=
+  Equiv.ofBijective torusPairSubset torusPairSubset_bijective
+
+private def Elliptic.HigherHomology.torusTripleSubsetEquiv : Fin 1 ≃ Set.powersetCard (Fin 3) 3 :=
+  Equiv.ofBijective torusTripleSubset torusTripleSubset_bijective
+
+private def Elliptic.HigherHomology.torusSquareBasis : Module.Basis (Fin 3) ℤ (torusExterior 2) :=
+  (torusExteriorBasis 2).reindex torusPairSubsetEquiv.symm
+
+private def Elliptic.HigherHomology.torusCubeBasis : Module.Basis (Fin 1) ℤ (torusExterior 3) :=
+  (torusExteriorBasis 3).reindex torusTripleSubsetEquiv.symm
+
+private theorem Elliptic.HigherHomology.torusSquareBasis_apply (i : Fin 3) :
+    torusSquareBasis i = exteriorPower.ιMulti ℤ 2 (torusLatticeBasis ∘ fibrePair i) := by
+  rw [torusSquareBasis, Module.Basis.reindex_apply]
+  change (Pi.basisFun ℤ (Fin 3)).exteriorPower 2 (torusPairSubset i) = _
+  rw [exteriorPower.basis_apply, exteriorPower.ιMulti_family, torusPairSubset_ordered]
+  rfl
+
+private theorem Elliptic.HigherHomology.torusCubeBasis_apply (i : Fin 1) :
+    torusCubeBasis i = exteriorPower.ιMulti ℤ 3 torusLatticeBasis := by
+  rw [torusCubeBasis, Module.Basis.reindex_apply]
+  change (Pi.basisFun ℤ (Fin 3)).exteriorPower 3 (torusTripleSubset i) = _
+  rw [exteriorPower.basis_apply, exteriorPower.ιMulti_family, torusTripleSubset_ordered]
+  rfl
+
+private def Elliptic.HigherHomology.torusSquareCoordinates : torusExterior 2 ≃ₗ[ℤ] (Fin 3 → ℤ) :=
+  torusSquareBasis.equivFun
+
+private def
+    Elliptic.HigherHomology.torusCubeVectorCoordinates : torusExterior 3 ≃ₗ[ℤ] (Fin 1 → ℤ) :=
+  torusCubeBasis.equivFun
+
+private def Elliptic.HigherHomology.torusCubeCoordinates : torusExterior 3 ≃ₗ[ℤ] ℤ :=
+  torusCubeVectorCoordinates.trans (LinearEquiv.piUnique ℤ (fun _ : Fin 1 => ℤ))
+
+@[simp]
+private theorem
+    Elliptic.HigherHomology.torusSquareCoordinates_apply (x : torusExterior 2) (i : Fin 3) :
+    torusSquareCoordinates x i = torusSquareBasis.repr x i :=
+  congrFun (torusSquareBasis.equivFun_apply x) i
+
+@[simp]
+private theorem Elliptic.HigherHomology.torusCubeCoordinates_apply (x : torusExterior 3) :
+    torusCubeCoordinates x = torusCubeBasis.repr x 0 :=
+  congrFun (torusCubeBasis.equivFun_apply x) 0
+
+@[simp]
+private theorem Elliptic.HigherHomology.torusSquareCoordinates_basis (i : Fin 3) :
+    torusSquareCoordinates (torusSquareBasis i) = Pi.single i 1 := by
+  ext j
+  simp only [torusSquareCoordinates_apply, Module.Basis.repr_self, Finsupp.single_eq_pi_single]
+
+private theorem Elliptic.HigherHomology.torusCubeCoordinates_basis (i : Fin 1) :
+    torusCubeCoordinates (torusCubeBasis i) = 1 := by
+  have hi : i = 0 := Subsingleton.elim _ _
+  rw [hi, torusCubeCoordinates_apply, Module.Basis.repr_self, Finsupp.single_eq_same]
+
+private instance
+    Elliptic.HigherHomology.torusExteriorFree (n : ℕ) : Module.Free ℤ (torusExterior n) :=
+  inferInstance
+
+private instance Elliptic.HigherHomology.torusExteriorFinite (n : ℕ) :
+    Module.Finite ℤ (torusExterior n) :=
+  inferInstance
+
+private theorem Elliptic.HigherHomology.torusExterior_finrank (n : ℕ) :
+    Module.finrank ℤ (torusExterior n) = Nat.choose 3 n := by
+  rw [exteriorPower.finrank_eq, Module.finrank_eq_card_basis torusLatticeBasis, Fintype.card_fin]
+
+private def Elliptic.HigherHomology.torusSquareMatrix (A : FibreMatrix) : FibreMatrix := fun i j =>
+  A (fibrePair i 0) (fibrePair j 0) * A (fibrePair i 1) (fibrePair j 1) -
+    A (fibrePair i 0) (fibrePair j 1) * A (fibrePair i 1) (fibrePair j 0)
+
+private theorem Elliptic.HigherHomology.torusSquareMatrix_eq_det_submatrix (A : FibreMatrix)
+    (i j : Fin 3) : torusSquareMatrix A i j = (A.submatrix (fibrePair i) (fibrePair j)).det := by
+  rw [Matrix.det_fin_two]
+  rfl
+
+@[simp]
+private theorem Elliptic.HigherHomology.torusSquareMatrix_fibreMatrix (j : Elliptic.Kind) :
+    torusSquareMatrix (fibreMatrix j) = fibreSquareMatrix j := by
+  ext i k
+  exact (fibreSquareMatrix_minor j i k).symm
+
+private def Elliptic.HigherHomology.torusExteriorMap (n : ℕ) (A : FibreMatrix) :
+    torusExterior n →ₗ[ℤ] torusExterior n :=
+  exteriorPower.map n A.mulVecLin
+
+@[simp]
+private theorem Elliptic.HigherHomology.torusExteriorMap_one (n : ℕ) :
+    torusExteriorMap n 1 = LinearMap.id := by
+  simp only [torusExteriorMap, Matrix.mulVecLin_one, exteriorPower.map_id]
+
+private theorem Elliptic.HigherHomology.torusExteriorMap_mul (n : ℕ) (A B : FibreMatrix) :
+    torusExteriorMap n (A * B) = (torusExteriorMap n A).comp (torusExteriorMap n B) := by
+  simp only [torusExteriorMap, Matrix.mulVecLin_mul, exteriorPower.map_comp]
+
+private theorem Elliptic.HigherHomology.torusSquareMap_coefficient (A : FibreMatrix) (i j : Fin 3) :
+    torusSquareBasis.repr (torusExteriorMap 2 A (torusSquareBasis j)) i =
+      torusSquareMatrix A i j := by
+  rw [torusSquareBasis, Module.Basis.repr_reindex_apply, Module.Basis.reindex_apply]
+  change
+    (PeriodTorusHigherHomologyExterior.standardExteriorBasis 3 2).repr
+        (exteriorPower.map 2 A.mulVecLin
+          (PeriodTorusHigherHomologyExterior.standardExteriorBasis 3 2 (torusPairSubset j)))
+        (torusPairSubset i) =
+      _
+  rw [PeriodTorusHigherHomologyExterior.standardExterior_map_coefficient, torusPairSubset_ordered,
+    torusPairSubset_ordered]
+  exact (torusSquareMatrix_eq_det_submatrix A i j).symm
+
+private theorem Elliptic.HigherHomology.torusCubeMap_coefficient (A : FibreMatrix) (i j : Fin 1) :
+    torusCubeBasis.repr (torusExteriorMap 3 A (torusCubeBasis j)) i = A.det := by
+  rw [torusCubeBasis, Module.Basis.repr_reindex_apply, Module.Basis.reindex_apply]
+  change
+    (PeriodTorusHigherHomologyExterior.standardExteriorBasis 3 3).repr
+        (exteriorPower.map 3 A.mulVecLin
+          (PeriodTorusHigherHomologyExterior.standardExteriorBasis 3 3 (torusTripleSubset j)))
+        (torusTripleSubset i) =
+      _
+  rw [PeriodTorusHigherHomologyExterior.standardExterior_map_coefficient,
+    torusTripleSubset_ordered, torusTripleSubset_ordered]
+  rfl
+
+private theorem Elliptic.HigherHomology.torusSquareMap_toMatrix (A : FibreMatrix) :
+    LinearMap.toMatrix torusSquareBasis torusSquareBasis (torusExteriorMap 2 A) =
+      torusSquareMatrix A := by
+  ext i j
+  rw [LinearMap.toMatrix_apply]
+  exact torusSquareMap_coefficient A i j
+
+private theorem Elliptic.HigherHomology.torusCubeMap_toMatrix (A : FibreMatrix) :
+    LinearMap.toMatrix torusCubeBasis torusCubeBasis (torusExteriorMap 3 A) =
+      (fun _ _ : Fin 1 => A.det) := by
+  ext i j
+  rw [LinearMap.toMatrix_apply]
+  exact torusCubeMap_coefficient A i j
+
+private theorem Elliptic.HigherHomology.torusSquareCoordinates_map (A : FibreMatrix)
+    (x : torusExterior 2) :
+    torusSquareCoordinates (torusExteriorMap 2 A x) =
+      torusSquareMatrix A *ᵥ torusSquareCoordinates x := by
+  have h :=
+    LinearMap.toMatrix_mulVec_repr torusSquareBasis torusSquareBasis (torusExteriorMap 2 A) x
+  rw [torusSquareMap_toMatrix] at h
+  simpa only [torusSquareCoordinates, Module.Basis.equivFun_apply] using h.symm
+
+private theorem
+    Elliptic.HigherHomology.torusCubeCoordinates_map (A : FibreMatrix) (x : torusExterior 3) :
+    torusCubeCoordinates (torusExteriorMap 3 A x) = A.det * torusCubeCoordinates x := by
+  rw [torusCubeCoordinates_apply, torusCubeCoordinates_apply]
+  have h := LinearMap.toMatrix_mulVec_repr torusCubeBasis torusCubeBasis (torusExteriorMap 3 A) x
+  rw [torusCubeMap_toMatrix] at h
+  simpa only [Matrix.mulVec, dotProduct, Fin.sum_univ_one] using (congrFun h 0).symm
+
+@[simp]
+private theorem Elliptic.HigherHomology.torusSquareMatrix_one : torusSquareMatrix 1 = 1 := by
+  rw [← torusSquareMap_toMatrix, torusExteriorMap_one, LinearMap.toMatrix_id]
+
+private theorem Elliptic.HigherHomology.torusSquareMatrix_mul (A B : FibreMatrix) :
+    torusSquareMatrix (A * B) = torusSquareMatrix A * torusSquareMatrix B := by
+  rw [← torusSquareMap_toMatrix, torusExteriorMap_mul,
+    LinearMap.toMatrix_comp torusSquareBasis torusSquareBasis torusSquareBasis,
+    torusSquareMap_toMatrix, torusSquareMap_toMatrix]
+
+private theorem
+    Elliptic.HigherHomology.torusWedgeTwo_bijective : Function.Bijective torusWedgeTwo := by
+  let := PeriodTorusHigherHomology.productTorus_homology_free 3 2
+  let := PeriodTorusHigherHomology.productTorus_homology_finite 3 2
+  apply
+    OrzechProperty.bijective_of_surjective_of_finrank_le torusWedgeTwo torusWedgeTwo_surjective
+  rw [torusExterior_finrank, PeriodTorusHigherHomology.productTorus_homology_finrank]
+
+private theorem
+    Elliptic.HigherHomology.torusWedgeThree_bijective : Function.Bijective torusWedgeThree := by
+  let := PeriodTorusHigherHomology.productTorus_homology_free 3 3
+  let := PeriodTorusHigherHomology.productTorus_homology_finite 3 3
+  apply
+    OrzechProperty.bijective_of_surjective_of_finrank_le torusWedgeThree
+      torusWedgeThree_surjective
+  rw [torusExterior_finrank, PeriodTorusHigherHomology.productTorus_homology_finrank]
+
+private def Elliptic.HigherHomology.torusWedgeTwoEquiv :
+    torusExterior 2 ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 2 :=
+  LinearEquiv.ofBijective torusWedgeTwo torusWedgeTwo_bijective
+
+private def Elliptic.HigherHomology.torusWedgeThreeEquiv :
+    torusExterior 3 ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3 :=
+  LinearEquiv.ofBijective torusWedgeThree torusWedgeThree_bijective
+
+private def Elliptic.HigherHomology.torusH2ExteriorEquiv :
+    SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 2 ≃ₗ[ℤ]
+      torusExterior 2 :=
+  torusWedgeTwoEquiv.symm
+
+private def Elliptic.HigherHomology.torusH3ExteriorEquiv :
+    SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3 ≃ₗ[ℤ]
+      torusExterior 3 :=
+  torusWedgeThreeEquiv.symm
+
+@[simp]
+private theorem Elliptic.HigherHomology.torusH2ExteriorEquiv_wedge (v : torusExterior 2) :
+    torusH2ExteriorEquiv (torusWedgeTwo v) = v :=
+  torusWedgeTwoEquiv.symm_apply_apply v
+
+@[simp]
+private theorem Elliptic.HigherHomology.torusH3ExteriorEquiv_wedge (v : torusExterior 3) :
+    torusH3ExteriorEquiv (torusWedgeThree v) = v :=
+  torusWedgeThreeEquiv.symm_apply_apply v
+
+private theorem
+    Elliptic.HigherHomology.torusH2ExteriorEquiv_symm_ιMulti (v : Fin 2 → FibreLattice) :
+    torusH2ExteriorEquiv.symm (exteriorPower.ιMulti ℤ 2 v) =
+      PeriodTorusHigherHomologyPontryagin.product11 (PeriodTorusHigherHomology.ProductTorus 3)
+        (FirstHurewicz.loopHomologyClass (PeriodTorusHigherHomology.coordinatePeriodLoop 3 (v 0)))
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 3 (v 1))) :=
+  torusWedgeTwo_ιMulti_loops v
+
+private theorem
+    Elliptic.HigherHomology.torusH3ExteriorEquiv_symm_ιMulti (v : Fin 3 → FibreLattice) :
+    torusH3ExteriorEquiv.symm (exteriorPower.ιMulti ℤ 3 v) =
+      PeriodTorusHigherHomologyPontryagin.tripleProduct (PeriodTorusHigherHomology.ProductTorus 3)
+        (FirstHurewicz.loopHomologyClass (PeriodTorusHigherHomology.coordinatePeriodLoop 3 (v 0)))
+        (FirstHurewicz.loopHomologyClass (PeriodTorusHigherHomology.coordinatePeriodLoop 3 (v 1)))
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 3 (v 2))) :=
+  torusWedgeThree_ιMulti_loops v
+
+private theorem Elliptic.HigherHomology.torusH2ExteriorEquiv_natural
+    (f : C(PeriodTorusHigherHomology.ProductTorus 3, PeriodTorusHigherHomology.ProductTorus 3))
+    (hf : ∀ x y, f (x + y) = f x + f y) (A : FibreLattice →ₗ[ℤ] FibreLattice)
+    (hmark :
+      ∀ v,
+        SingularMayerVietoris.singularHomologyMap f 1
+            (PeriodTorusHigherHomology.coordinateH1 3 v) =
+          PeriodTorusHigherHomology.coordinateH1 3 (A v))
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 2) :
+    torusH2ExteriorEquiv (SingularMayerVietoris.singularHomologyMap f 2 a) =
+      exteriorPower.map 2 A (torusH2ExteriorEquiv a) := by
+  obtain ⟨v, rfl⟩ := torusWedgeTwo_surjective a
+  have h := LinearMap.congr_fun (torusWedgeTwo_natural f hf A hmark) v
+  change
+    SingularMayerVietoris.singularHomologyMap f 2 (torusWedgeTwo v) =
+      torusWedgeTwo (exteriorPower.map 2 A v) at h
+  rw [h, torusH2ExteriorEquiv_wedge, torusH2ExteriorEquiv_wedge]
+
+private theorem Elliptic.HigherHomology.torusH3ExteriorEquiv_natural
+    (f : C(PeriodTorusHigherHomology.ProductTorus 3, PeriodTorusHigherHomology.ProductTorus 3))
+    (hf : ∀ x y, f (x + y) = f x + f y) (A : FibreLattice →ₗ[ℤ] FibreLattice)
+    (hmark :
+      ∀ v,
+        SingularMayerVietoris.singularHomologyMap f 1
+            (PeriodTorusHigherHomology.coordinateH1 3 v) =
+          PeriodTorusHigherHomology.coordinateH1 3 (A v))
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3) :
+    torusH3ExteriorEquiv (SingularMayerVietoris.singularHomologyMap f 3 a) =
+      exteriorPower.map 3 A (torusH3ExteriorEquiv a) := by
+  obtain ⟨v, rfl⟩ := torusWedgeThree_surjective a
+  have h := LinearMap.congr_fun (torusWedgeThree_natural f hf A hmark) v
+  change
+    SingularMayerVietoris.singularHomologyMap f 3 (torusWedgeThree v) =
+      torusWedgeThree (exteriorPower.map 3 A v) at h
+  rw [h, torusH3ExteriorEquiv_wedge, torusH3ExteriorEquiv_wedge]
+
+private theorem Elliptic.HigherHomology.torusH2ExteriorEquiv_matrix_natural (A : FibreMatrix)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 2) :
+    torusH2ExteriorEquiv
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap A) 2
+          a) =
+      exteriorPower.map 2 A.mulVecLin (torusH2ExteriorEquiv a) :=
+  torusH2ExteriorEquiv_natural (PeriodTorusHigherHomology.torusMatrixMap A)
+    (PeriodTorusHigherHomology.torusMatrixMap_add A) A.mulVecLin
+    (coordinateH1_three_matrix_natural A) a
+
+private theorem Elliptic.HigherHomology.torusH3ExteriorEquiv_matrix_natural (A : FibreMatrix)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3) :
+    torusH3ExteriorEquiv
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap A) 3
+          a) =
+      exteriorPower.map 3 A.mulVecLin (torusH3ExteriorEquiv a) :=
+  torusH3ExteriorEquiv_natural (PeriodTorusHigherHomology.torusMatrixMap A)
+    (PeriodTorusHigherHomology.torusMatrixMap_add A) A.mulVecLin
+    (coordinateH1_three_matrix_natural A) a
+
+private def Elliptic.HigherHomology.torusH2Coordinates :
+    SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 2 ≃ₗ[ℤ]
+      (Fin 3 → ℤ) :=
+  torusH2ExteriorEquiv.trans torusSquareCoordinates
+
+private def Elliptic.HigherHomology.torusH3Coordinates :
+    SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3 ≃ₗ[ℤ] ℤ :=
+  torusH3ExteriorEquiv.trans torusCubeCoordinates
+
+private theorem Elliptic.HigherHomology.torusH2Coordinates_matrix_natural (A : FibreMatrix)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 2) :
+    torusH2Coordinates
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap A) 2
+          a) =
+      torusSquareMatrix A *ᵥ torusH2Coordinates a := by
+  change
+    torusSquareCoordinates
+        (torusH2ExteriorEquiv
+          (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap A)
+            2 a)) =
+      _
+  rw [torusH2ExteriorEquiv_matrix_natural]
+  exact torusSquareCoordinates_map A (torusH2ExteriorEquiv a)
+
+private theorem Elliptic.HigherHomology.torusH3Coordinates_matrix_natural (A : FibreMatrix)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3) :
+    torusH3Coordinates
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap A) 3
+          a) =
+      A.det * torusH3Coordinates a := by
+  change
+    torusCubeCoordinates
+        (torusH3ExteriorEquiv
+          (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap A)
+            3 a)) =
+      _
+  rw [torusH3ExteriorEquiv_matrix_natural]
+  exact torusCubeCoordinates_map A (torusH3ExteriorEquiv a)
+
+private theorem Elliptic.HigherHomology.torusH2Coordinates_symm_basis (i : Fin 3) :
+    torusH2Coordinates.symm (Pi.single i 1) =
+      PeriodTorusHigherHomologyPontryagin.product11 (PeriodTorusHigherHomology.ProductTorus 3)
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 3 (Pi.single (fibrePair i 0) 1)))
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 3 (Pi.single (fibrePair i 1) 1))) := by
+  change torusH2ExteriorEquiv.symm (torusSquareCoordinates.symm (Pi.single i 1)) = _
+  rw [← torusSquareCoordinates_basis i, LinearEquiv.symm_apply_apply, torusSquareBasis_apply,
+    torusH2ExteriorEquiv_symm_ιMulti]
+  simp only [Function.comp_apply, torusLatticeBasis, Pi.basisFun_apply]
+
+private theorem Elliptic.HigherHomology.torusH3Coordinates_symm_one :
+    torusH3Coordinates.symm 1 =
+      PeriodTorusHigherHomologyPontryagin.tripleProduct (PeriodTorusHigherHomology.ProductTorus 3)
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 3 (Pi.single 0 1)))
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 3 (Pi.single 1 1)))
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 3 (Pi.single 2 1))) := by
+  change torusH3ExteriorEquiv.symm (torusCubeCoordinates.symm 1) = _
+  have h : torusCubeCoordinates.symm 1 = torusCubeBasis (0 : Fin 1) := by
+    rw [← torusCubeCoordinates_basis (0 : Fin 1), LinearEquiv.symm_apply_apply]
+  rw [h, torusCubeBasis_apply, torusH3ExteriorEquiv_symm_ιMulti]
+  simp only [torusLatticeBasis, Pi.basisFun_apply]
+
+private theorem Elliptic.HigherHomology.torusH2Coordinates_fibreMatrix (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 2) :
+    torusH2Coordinates
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.torusMatrixMap (fibreMatrix j)) 2 a) =
+      fibreSquareMatrix j *ᵥ torusH2Coordinates a := by
+  rw [torusH2Coordinates_matrix_natural, torusSquareMatrix_fibreMatrix]
+
+private theorem Elliptic.HigherHomology.torusH3Coordinates_fibreMatrix (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3) :
+    torusH3Coordinates
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.torusMatrixMap (fibreMatrix j)) 3 a) =
+      torusH3Coordinates a := by rw [torusH3Coordinates_matrix_natural, fibreMatrix_det, one_mul]
+
+private theorem Elliptic.HigherHomology.fibreTorusHomeomorph_pow_apply (j : Elliptic.Kind) (n : ℕ)
+    (x : PeriodTorusHigherHomology.ProductTorus 3) :
+    (fibreTorusHomeomorph j ^ n) x =
+      PeriodTorusHigherHomology.torusMatrixMap (fibreMatrix j ^ n) x := by
+  induction n generalizing x with
+  | zero =>
+    simp only [pow_zero, Homeomorph.one_apply, PeriodTorusHigherHomology.torusMatrixMap_one]; rfl
+  | succ n
+    ih =>
+    rw [pow_succ, Homeomorph.mul_apply, ih, fibreTorusHomeomorph_apply, pow_succ,
+      PeriodTorusHigherHomology.torusMatrixMap_mul]
+    rfl
+
+private theorem Elliptic.HigherHomology.fibreTorusHomeomorph_pow_order (j : Elliptic.Kind) :
+    fibreTorusHomeomorph j ^ j.order = 1 := by
+  ext x
+  rw [fibreTorusHomeomorph_pow_apply, fibreMatrix_pow_order,
+    PeriodTorusHigherHomology.torusMatrixMap_one]
+  rfl
+
+private theorem Elliptic.HigherHomology.fibreSL_inv_val (j : Elliptic.Kind) :
+    (((fibreSL j)⁻¹ : SL(3, ℤ)) : FibreMatrix) = (fibreMatrix j)⁻¹ := by
+  have hleft : (((fibreSL j)⁻¹ : SL(3, ℤ)) : FibreMatrix) * fibreMatrix j = 1 :=
+    congrArg (fun C : SL(3, ℤ) => C.val) (inv_mul_cancel (fibreSL j))
+  calc
+    (((fibreSL j)⁻¹ : SL(3, ℤ)) : FibreMatrix) = (((fibreSL j)⁻¹ : SL(3, ℤ)) : FibreMatrix) * 1 :=
+      (mul_one _).symm
+    _ = (((fibreSL j)⁻¹ : SL(3, ℤ)) : FibreMatrix) * (fibreMatrix j * (fibreMatrix j)⁻¹) := by
+      rw [Matrix.mul_nonsing_inv _ (by simp [fibreMatrix_det])]
+    _ = (fibreMatrix j)⁻¹ := by rw [← mul_assoc, hleft, one_mul]
+
+private theorem Elliptic.HigherHomology.torusSquareMatrix_fibreMatrix_inv (j : Elliptic.Kind) :
+    torusSquareMatrix ((fibreMatrix j)⁻¹) = (fibreSquareMatrix j)⁻¹ := by
+  have hleft : torusSquareMatrix ((fibreMatrix j)⁻¹) * fibreSquareMatrix j = 1 := by
+    rw [← torusSquareMatrix_fibreMatrix, ← torusSquareMatrix_mul,
+      Matrix.nonsing_inv_mul _ (by simp [fibreMatrix_det]), torusSquareMatrix_one]
+  calc
+    torusSquareMatrix ((fibreMatrix j)⁻¹) = torusSquareMatrix ((fibreMatrix j)⁻¹) * 1 :=
+      (mul_one _).symm
+    _ = torusSquareMatrix ((fibreMatrix j)⁻¹) * (fibreSquareMatrix j * (fibreSquareMatrix j)⁻¹) :=
+      by rw [Matrix.mul_nonsing_inv _ (by simp [fibreSquareMatrix_det])]
+    _ = (fibreSquareMatrix j)⁻¹ := by rw [← mul_assoc, hleft, one_mul]
+
+private theorem Elliptic.HigherHomology.fibreMatrix_inv_det (j : Elliptic.Kind) :
+    (fibreMatrix j)⁻¹.det = 1 := by
+  have h := Matrix.det_nonsing_inv_mul_det (fibreMatrix j) (by simp [fibreMatrix_det])
+  simpa only [fibreMatrix_det, mul_one] using h
+
+private abbrev Elliptic.HigherHomology.mappingTorusModel (j : Elliptic.Kind) :=
+  MappingTorus.Torus (fibreTorusHomeomorph j).symm
+
+private theorem Elliptic.HigherHomology.mappingTorusMonodromy_one (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 1) :
+    torusH1Equiv (MappingTorusHomology.monodromyHomologyMap (fibreTorusHomeomorph j).symm 1 a) =
+      (fibreMatrix j)⁻¹ *ᵥ torusH1Equiv a := by
+  change
+    torusH1Equiv
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.torusMatrixMap (((fibreSL j)⁻¹ : SL(3, ℤ)) : FibreMatrix)) 1
+          a) =
+      _
+  rw [fibreSL_inv_val, torusH1Equiv_matrix_natural]
+
+private theorem Elliptic.HigherHomology.mappingTorusMonodromy_two (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 2) :
+    torusH2Coordinates
+        (MappingTorusHomology.monodromyHomologyMap (fibreTorusHomeomorph j).symm 2 a) =
+      (fibreSquareMatrix j)⁻¹ *ᵥ torusH2Coordinates a := by
+  change
+    torusH2Coordinates
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.torusMatrixMap (((fibreSL j)⁻¹ : SL(3, ℤ)) : FibreMatrix)) 2
+          a) =
+      _
+  rw [fibreSL_inv_val, torusH2Coordinates_matrix_natural, torusSquareMatrix_fibreMatrix_inv]
+
+private theorem Elliptic.HigherHomology.mappingTorusMonodromy_three (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3) :
+    torusH3Coordinates
+        (MappingTorusHomology.monodromyHomologyMap (fibreTorusHomeomorph j).symm 3 a) =
+      torusH3Coordinates a := by
+  change
+    torusH3Coordinates
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.torusMatrixMap (((fibreSL j)⁻¹ : SL(3, ℤ)) : FibreMatrix)) 3
+          a) =
+      _
+  rw [fibreSL_inv_val, torusH3Coordinates_matrix_natural, fibreMatrix_inv_det, one_mul]
+
+private theorem Elliptic.HigherHomology.mappingTorusDifference_one (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 1) :
+    torusH1Equiv (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm 1 a) =
+      fibreInverseDifference j (torusH1Equiv a) := by
+  change
+    torusH1Equiv
+        (a - MappingTorusHomology.monodromyHomologyMap (fibreTorusHomeomorph j).symm 1 a) =
+      _
+  rw [map_sub, mappingTorusMonodromy_one]
+  simp only [fibreInverseDifference, Matrix.mulVecLin_apply, Matrix.sub_mulVec, Matrix.one_mulVec]
+
+private theorem Elliptic.HigherHomology.mappingTorusDifference_two (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 2) :
+    torusH2Coordinates (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm 2 a) =
+      fibreSquareInverseDifference j (torusH2Coordinates a) := by
+  change
+    torusH2Coordinates
+        (a - MappingTorusHomology.monodromyHomologyMap (fibreTorusHomeomorph j).symm 2 a) =
+      _
+  rw [map_sub, mappingTorusMonodromy_two]
+  simp only [fibreSquareInverseDifference, Matrix.mulVecLin_apply, Matrix.sub_mulVec,
+    Matrix.one_mulVec]
+
+private theorem Elliptic.HigherHomology.mappingTorusDifference_three (j : Elliptic.Kind) :
+    MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm 3 = 0 := by
+  ext a
+  apply torusH3Coordinates.injective
+  change
+    torusH3Coordinates
+        (a - MappingTorusHomology.monodromyHomologyMap (fibreTorusHomeomorph j).symm 3 a) =
+      torusH3Coordinates 0
+  rw [map_sub, mappingTorusMonodromy_three, sub_self, map_zero]
+
+private abbrev Elliptic.HigherHomology.surfaceProductQuotient (j : Elliptic.Kind) :=
+  MappingTorusQuotient.ProductQuotient j.order (fibreTorusHomeomorph j)
+    (fibreTorusHomeomorph_pow_order j)
+
+private def Elliptic.HigherHomology.surfaceSplitQuotientHomeomorph (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) :
+    Elliptic.Surface j p j.twist (Elliptic.mainTwist_admissible j) ≃ₜ surfaceProductQuotient j :=
+  MappingTorusQuotient.cyclicQuotientCongr (Elliptic.affinePermutation j p j.twist)
+    (Elliptic.affinePermutation_pow_order j p j.twist j.matrix_fixes_twist)
+    (MappingTorusQuotient.twist j.order (fibreTorusHomeomorph j)).toEquiv
+    (MappingTorusQuotient.twistPerm_pow_order j.order (fibreTorusHomeomorph j)
+      (fibreTorusHomeomorph_pow_order j))
+    (splitPeriodTorusHomeomorph j p.val)
+    (fun x => splitPeriodTorusHomeomorph_affineBiholomorph j p x)
+
+@[simp]
+private theorem
+    Elliptic.HigherHomology.surfaceSplitQuotientHomeomorph_projection (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (x : p.val.Torus) :
+    surfaceSplitQuotientHomeomorph j p
+        (Elliptic.surfaceProjection j p j.twist (Elliptic.mainTwist_admissible j) x) =
+      MappingTorusQuotient.project j.order (fibreTorusHomeomorph j)
+        (fibreTorusHomeomorph_pow_order j) (splitPeriodTorusHomeomorph j p.val x) :=
+  rfl
+
+@[simp]
+private theorem
+    Elliptic.HigherHomology.surfaceSplitQuotientHomeomorph_symm_project (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j)
+    (x : MappingTorus.Circle × PeriodTorusHigherHomology.ProductTorus 3) :
+    (surfaceSplitQuotientHomeomorph j p).symm
+        (MappingTorusQuotient.project j.order (fibreTorusHomeomorph j)
+          (fibreTorusHomeomorph_pow_order j) x) =
+      Elliptic.surfaceProjection j p j.twist (Elliptic.mainTwist_admissible j)
+        ((splitPeriodTorusHomeomorph j p.val).symm x) :=
+  rfl
+
+private def Elliptic.HigherHomology.surfaceMappingTorusHomeomorph (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) :
+    Elliptic.Surface j p j.twist (Elliptic.mainTwist_admissible j) ≃ₜ mappingTorusModel j :=
+  (surfaceSplitQuotientHomeomorph j p).trans
+    (MappingTorusQuotient.mappingTorusHomeomorph j.order (fibreTorusHomeomorph j)
+      (fibreTorusHomeomorph_pow_order j))
+
+private theorem
+    Elliptic.HigherHomology.surfaceMappingTorusHomeomorph_splitPeriodTorus (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (t : ℝ) (x : PeriodTorusHigherHomology.ProductTorus 3) :
+    surfaceMappingTorusHomeomorph j p
+        (Elliptic.surfaceProjection j p j.twist (Elliptic.mainTwist_admissible j)
+          ((splitPeriodTorusHomeomorph j p.val).symm ((t : MappingTorus.Circle), x))) =
+      MappingTorus.mk (fibreTorusHomeomorph j).symm (t * j.order, x) := by
+  rw [surfaceMappingTorusHomeomorph, Homeomorph.trans_apply,
+    surfaceSplitQuotientHomeomorph_projection, Homeomorph.apply_symm_apply,
+    MappingTorusQuotient.mappingTorusHomeomorph_project]
+
+private theorem Elliptic.HigherHomology.surfaceMappingTorusHomeomorph_symm_mk (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (t : ℝ) (x : PeriodTorusHigherHomology.ProductTorus 3) :
+    (surfaceMappingTorusHomeomorph j p).symm
+        (MappingTorus.mk (fibreTorusHomeomorph j).symm (t, x)) =
+      Elliptic.surfaceProjection j p j.twist (Elliptic.mainTwist_admissible j)
+        ((splitPeriodTorusHomeomorph j p.val).symm
+          (((t / j.order : ℝ) : MappingTorus.Circle), x)) := by
+  change
+    (surfaceSplitQuotientHomeomorph j p).symm
+        ((MappingTorusQuotient.mappingTorusHomeomorph j.order (fibreTorusHomeomorph j)
+              (fibreTorusHomeomorph_pow_order j)).symm
+          (MappingTorus.mk (fibreTorusHomeomorph j).symm (t, x))) =
+      _
+  rw [MappingTorusQuotient.mappingTorusHomeomorph_symm_mk,
+    surfaceSplitQuotientHomeomorph_symm_project]
+
+private def Elliptic.Equivariant.Data.centralInclusion {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) : D.centralPeriod.val.Torus → D.TotalSpace :=
+  D.periods.fibreInclusion SpecialPeriods.discZero
+
+private theorem Elliptic.Equivariant.Data.centralInclusion_injective {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) : Function.Injective D.centralInclusion :=
+  D.periods.fibreInclusion_injective SpecialPeriods.discZero
+
+private theorem Elliptic.Equivariant.Data.centralInclusion_continuous {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) : Continuous D.centralInclusion :=
+  continuous_const.prodMk (D.periods.torusHomeomorph SpecialPeriods.discZero).symm.continuous
+
+private theorem Elliptic.Equivariant.Data.centralInclusion_mkQ {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (z : ComplexPlane₂) :
+    D.centralInclusion (D.centralPeriod.val.lattice.mkQ z) =
+      D.periods.quotientMap (SpecialPeriods.discZero, z) :=
+  D.periods.fibreInclusion_mkQ SpecialPeriods.discZero z
+
+private theorem Elliptic.Equivariant.Data.range_centralInclusion {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) :
+    Set.range D.centralInclusion = D.periods.projection ⁻¹' { SpecialPeriods.discZero } :=
+  D.periods.range_fibreInclusion SpecialPeriods.discZero
+
+private theorem Elliptic.Equivariant.Data.mem_range_centralInclusion_iff {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (x : D.TotalSpace) :
+    x ∈ Set.range D.centralInclusion ↔ x.1 = SpecialPeriods.discZero := by
+  rw [D.range_centralInclusion]
+  rfl
+
+private theorem Elliptic.Equivariant.Data.centralInclusion_flatProjection {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (x : RealPlane₄) :
+    D.centralInclusion (Elliptic.flatProjection D.centralPeriod.val x) =
+      (SpecialPeriods.discZero, standardLattice.mkQ x) := by
+  rw [Elliptic.flatProjection, D.centralInclusion_mkQ]
+  change
+    (SpecialPeriods.discZero,
+        standardLattice.mkQ
+          ((D.periods.periodEquiv SpecialPeriods.discZero).symm
+            (Elliptic.periodEquiv (D.periods.point SpecialPeriods.discZero) x))) =
+      _
+  rw [← D.periodEquiv_eq_periodEquiv, LinearEquiv.symm_apply_apply]
+
+private theorem Elliptic.Equivariant.Data.permutation_centralInclusion {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (x : D.centralPeriod.val.Torus) :
+    D.permutation v (D.centralInclusion x) =
+      D.centralInclusion (Elliptic.affineBiholomorph j D.centralPeriod v x) := by
+  obtain ⟨y, rfl⟩ := Elliptic.flatProjection_surjective D.centralPeriod.val x
+  rw [D.centralInclusion_flatProjection, D.permutation_apply,
+    Elliptic.affineBiholomorph_flatProjection, D.centralInclusion_flatProjection]
+  exact Prod.ext (Elliptic.familyRotation_zero j) (Elliptic.flatTorusAffine_mkQ j v y)
+
+private theorem Elliptic.Equivariant.Data.permutation_iterate_centralInclusion {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (n : ℕ) (x : D.centralPeriod.val.Torus) :
+    (D.permutation v)^[n] (D.centralInclusion x) =
+      D.centralInclusion ((Elliptic.affineBiholomorph j D.centralPeriod v)^[n] x) := by
+  induction n with
+  | zero => rfl
+  | succ n ih =>
+    rw [Function.iterate_succ_apply', Function.iterate_succ_apply', ih,
+      D.permutation_centralInclusion]
+
+private theorem Elliptic.Equivariant.Data.permutation_pow_centralInclusion {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (n : ℕ) (x : D.centralPeriod.val.Torus) :
+    (D.permutation v ^ n) (D.centralInclusion x) =
+      D.centralInclusion ((Elliptic.affinePermutation j D.centralPeriod v ^ n) x) := by
+  rw [Equiv.Perm.coe_pow, Equiv.Perm.coe_pow]
+  exact D.permutation_iterate_centralInclusion v n x
+
+private theorem Elliptic.Equivariant.Data.centralInclusion_smul {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (g : Elliptic.CyclicGroup j) (x : D.centralPeriod.val.Torus) :
+    letI := Elliptic.affineAction j D.centralPeriod v hv
+    letI := D.action v hv
+    D.centralInclusion (g • x) = g • D.centralInclusion x := by
+  let := Elliptic.affineAction j D.centralPeriod v hv
+  let := D.action v hv
+  change
+    D.centralInclusion ((Elliptic.affinePermutation j D.centralPeriod v ^ g.toAdd.val) x) =
+      (D.permutation v ^ g.toAdd.val) (D.centralInclusion x)
+  exact (D.permutation_pow_centralInclusion v g.toAdd.val x).symm
+
+private theorem Elliptic.Equivariant.Data.centralInclusion_quotient_invariant {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (g : Elliptic.CyclicGroup j) (x : D.centralPeriod.val.Torus) :
+    letI := Elliptic.affineAction j D.centralPeriod v hv.1
+    D.quotient v hv (D.centralInclusion (g • x)) = D.quotient v hv (D.centralInclusion x) := by
+  let := Elliptic.affineAction j D.centralPeriod v hv.1
+  let := D.action v hv.1
+  rw [D.centralInclusion_smul]
+  exact D.quotient_smul v hv g (D.centralInclusion x)
+
+private def Elliptic.Equivariant.Data.centralFibreInclusion {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    Elliptic.Surface j D.centralPeriod v hv → D.Space v hv := by
+  let := Elliptic.affineAction j D.centralPeriod v hv.1
+  exact
+    Elliptic.FiniteQuotient.descend (D.quotient v hv ∘ D.centralInclusion)
+      (D.centralInclusion_quotient_invariant v hv)
+
+@[simp]
+private theorem
+    Elliptic.Equivariant.Data.centralFibreInclusion_surfaceProjection {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (x : D.centralPeriod.val.Torus) :
+    D.centralFibreInclusion v hv (Elliptic.surfaceProjection j D.centralPeriod v hv x) =
+      D.quotient v hv (D.centralInclusion x) :=
+  rfl
+
+private theorem Elliptic.Equivariant.Data.centralFibreInclusion_continuous {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    Continuous (D.centralFibreInclusion v hv) := by
+  let := Elliptic.affineAction j D.centralPeriod v hv.1
+  exact
+    Elliptic.FiniteQuotient.descend_continuous (D.quotient v hv ∘ D.centralInclusion)
+      (D.centralInclusion_quotient_invariant v hv)
+      ((D.quotient_continuous v hv).comp D.centralInclusion_continuous)
+
+private theorem Elliptic.Equivariant.Data.centralFibreInclusion_injective {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    Function.Injective (D.centralFibreInclusion v hv) := by
+  intro a b hab
+  obtain ⟨x, rfl⟩ := Elliptic.surfaceProjection_surjective j D.centralPeriod v hv a
+  obtain ⟨y, rfl⟩ := Elliptic.surfaceProjection_surjective j D.centralPeriod v hv b
+  rw [D.centralFibreInclusion_surfaceProjection, D.centralFibreInclusion_surfaceProjection] at hab
+  let := Elliptic.affineAction j D.centralPeriod v hv.1
+  let := D.action v hv.1
+  obtain ⟨g, hg⟩ := (D.quotient_eq_iff_mem_orbit v hv _ _).mp hab
+  apply
+    (Elliptic.FiniteQuotient.project_eq_iff_mem_orbit (Elliptic.CyclicGroup j)
+        D.centralPeriod.val.Torus x y).mpr
+  refine ⟨g, D.centralInclusion_injective ?_⟩
+  rw [D.centralInclusion_smul]
+  exact hg
+
+private theorem
+    Elliptic.Equivariant.Data.centralFibreInclusion_isClosedEmbedding {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    Topology.IsClosedEmbedding (D.centralFibreInclusion v hv) :=
+  (D.centralFibreInclusion_continuous v hv).isClosedEmbedding
+    (D.centralFibreInclusion_injective v hv)
+
+private theorem Elliptic.Equivariant.Data.range_centralFibreInclusion {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    Set.range (D.centralFibreInclusion v hv) = D.projection v hv ⁻¹' { Elliptic.discZero } := by
+  rw [D.projection_central_fibre]
+  ext q
+  constructor
+  · rintro ⟨s, rfl⟩
+    obtain ⟨x, rfl⟩ := Elliptic.surfaceProjection_surjective j D.centralPeriod v hv s
+    exact ⟨D.centralInclusion x, rfl, (D.centralFibreInclusion_surfaceProjection v hv x).symm⟩
+  · rintro ⟨x, hx, rfl⟩
+    obtain ⟨y, hy⟩ := (D.mem_range_centralInclusion_iff x).mpr hx
+    refine ⟨Elliptic.surfaceProjection j D.centralPeriod v hv y, ?_⟩
+    rw [D.centralFibreInclusion_surfaceProjection, hy]
+
+@[simp]
+private theorem Elliptic.Equivariant.Data.projection_centralFibreInclusion {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (x : Elliptic.Surface j D.centralPeriod v hv) :
+    D.projection v hv (D.centralFibreInclusion v hv x) = Elliptic.discZero := by
+  have hx := Set.mem_range_self (f := D.centralFibreInclusion v hv) x
+  rw [D.range_centralFibreInclusion] at hx
+  exact hx
+
+private def Elliptic.Equivariant.Data.centralFibreHomeomorph {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    Elliptic.Surface j D.centralPeriod v hv ≃ₜ D.projection v hv ⁻¹' { Elliptic.discZero } :=
+  (D.centralFibreInclusion_isClosedEmbedding v hv).isEmbedding.toHomeomorph.trans
+    (Homeomorph.setCongr (D.range_centralFibreInclusion v hv))
+
+private def Elliptic.Equivariant.Data.surfaceIntoFilling {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    ContinuousMap (Elliptic.Surface j D.centralPeriod v hv) (D.Space v hv) :=
+  ⟨D.centralFibreInclusion v hv, D.centralFibreInclusion_continuous v hv⟩
+
+private def Elliptic.Equivariant.Data.fillingSurfaceRetraction {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    ContinuousMap (D.Space v hv) (Elliptic.Surface j D.centralPeriod v hv) :=
+  ContinuousMap.comp
+    ⟨(D.centralFibreHomeomorph v hv).symm, (D.centralFibreHomeomorph v hv).symm.continuous⟩
+    (D.fillingCentralRetraction v hv)
+
+@[simp]
+private theorem
+    Elliptic.Equivariant.Data.fillingSurfaceRetraction_comp_inclusion {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    (D.fillingSurfaceRetraction v hv).comp (D.surfaceIntoFilling v hv) = ContinuousMap.id _ := by
+  ext x
+  have he :
+    D.fillingCentralRetraction v hv (D.centralFibreInclusion v hv x) =
+      D.centralFibreHomeomorph v hv x := by
+    apply Subtype.ext
+    exact D.fillingRadial_fixed v hv 1 _ (D.projection_centralFibreInclusion v hv x)
+  change
+    (D.centralFibreHomeomorph v hv).symm
+        (D.fillingCentralRetraction v hv (D.centralFibreInclusion v hv x)) =
+      x
+  rw [he, Homeomorph.symm_apply_apply]
+
+private theorem Elliptic.Equivariant.Data.surfaceIntoFilling_comp_retraction {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    (D.surfaceIntoFilling v hv).comp (D.fillingSurfaceRetraction v hv) =
+      (D.fillingCentralSubtypeInclusion v hv).comp (D.fillingCentralRetraction v hv) := by
+  ext x
+  exact
+    congrArg Subtype.val
+      ((D.centralFibreHomeomorph v hv).apply_symm_apply (D.fillingCentralRetraction v hv x))
+
+private def Elliptic.Equivariant.Data.fillingSurfaceStrongDeformationRetraction {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    (ContinuousMap.id (D.Space v hv)).HomotopyRel
+      ((D.surfaceIntoFilling v hv).comp (D.fillingSurfaceRetraction v hv))
+      (Set.range (D.surfaceIntoFilling v hv))
+    where
+  toFun p := D.fillingRadial v hv p.1 p.2
+  continuous_toFun := D.fillingRadial_continuous v hv
+  map_zero_left := D.fillingRadial_zero v hv
+  map_one_left
+    x :=
+    congrArg (fun f : ContinuousMap (D.Space v hv) (D.Space v hv) => f x)
+      (D.surfaceIntoFilling_comp_retraction v hv).symm
+  prop' t x
+    hx := by
+    obtain ⟨y, rfl⟩ := hx
+    exact D.fillingRadial_fixed v hv t _ (D.projection_centralFibreInclusion v hv y)
+
+private theorem Elliptic.HigherHomology.threeTorusMappingTorus_homology_subsingleton
+    (f : PeriodTorusHigherHomology.ProductTorus 3 ≃ₜ PeriodTorusHigherHomology.ProductTorus 3)
+    {n : ℕ} (hn : 4 < n) :
+    Subsingleton (SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) n) := by
+  obtain ⟨k, rfl⟩ := Nat.exists_eq_succ_of_ne_zero (show n ≠ 0 by omega)
+  have :=
+    PeriodTorusHigherHomology.productTorus_homology_subsingleton_of_lt (show 3 < k + 1 by omega)
+  have := PeriodTorusHigherHomology.productTorus_homology_subsingleton_of_lt (show 3 < k by omega)
+  have hzero :
+    ∀ a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) (k + 1), a = 0 := by
+    intro a
+    have ha : a ∈ LinearMap.ker (MappingTorusHomology.wangBoundary f k) := by
+      change MappingTorusHomology.wangBoundary f k a = 0
+      exact Subsingleton.elim _ _
+    rw [← MappingTorusHomology.wang_exact_at_mappingTorus f k] at ha
+    obtain ⟨x, hx⟩ := ha
+    have hx0 : x = 0 := Subsingleton.elim _ _
+    rw [hx0, map_zero] at hx
+    exact hx.symm
+  exact ⟨fun a b => (hzero a).trans (hzero b).symm⟩
+
+private theorem
+    Elliptic.HigherHomology.conjugacy_ker_mem_iff {M N : Type*} [AddCommGroup M] [Module ℤ M]
+    [AddCommGroup N] [Module ℤ N] (e : M ≃ₗ[ℤ] N) (L : M →ₗ[ℤ] M) (A : N →ₗ[ℤ] N)
+    (h : ∀ x, e (L x) = A (e x)) (x : M) : x ∈ LinearMap.ker L ↔ e x ∈ LinearMap.ker A := by
+  change L x = 0 ↔ A (e x) = 0
+  rw [← h x, e.map_eq_zero_iff]
+
+private theorem Elliptic.HigherHomology.conjugacy_range_mem_iff {M N : Type*} [AddCommGroup M]
+    [Module ℤ M] [AddCommGroup N] [Module ℤ N] (e : M ≃ₗ[ℤ] N) (L : M →ₗ[ℤ] M) (A : N →ₗ[ℤ] N)
+    (h : ∀ x, e (L x) = A (e x)) (x : M) : x ∈ LinearMap.range L ↔ e x ∈ LinearMap.range A := by
+  constructor
+  · rintro ⟨y, rfl⟩
+    exact ⟨e y, (h y).symm⟩
+  · rintro ⟨y, hy⟩
+    refine ⟨e.symm y, ?_⟩
+    apply e.injective
+    rw [h, e.apply_symm_apply]
+    exact hy
+
+private theorem
+    Elliptic.HigherHomology.conjugacy_map_ker {M N : Type*} [AddCommGroup M] [Module ℤ M]
+    [AddCommGroup N] [Module ℤ N] (e : M ≃ₗ[ℤ] N) (L : M →ₗ[ℤ] M) (A : N →ₗ[ℤ] N)
+    (h : ∀ x, e (L x) = A (e x)) : (LinearMap.ker L).map e.toLinearMap = LinearMap.ker A := by
+  ext y
+  rw [Submodule.mem_map]
+  constructor
+  · rintro ⟨x, hx, rfl⟩
+    exact (conjugacy_ker_mem_iff e L A h x).mp hx
+  · intro hy
+    refine ⟨e.symm y, ?_, e.apply_symm_apply y⟩
+    apply (conjugacy_ker_mem_iff e L A h (e.symm y)).mpr
+    simpa only [e.apply_symm_apply] using hy
+
+private theorem
+    Elliptic.HigherHomology.conjugacy_map_range {M N : Type*} [AddCommGroup M] [Module ℤ M]
+    [AddCommGroup N] [Module ℤ N] (e : M ≃ₗ[ℤ] N) (L : M →ₗ[ℤ] M) (A : N →ₗ[ℤ] N)
+    (h : ∀ x, e (L x) = A (e x)) : (LinearMap.range L).map e.toLinearMap = LinearMap.range A := by
+  ext y
+  rw [Submodule.mem_map]
+  constructor
+  · rintro ⟨x, hx, rfl⟩
+    exact (conjugacy_range_mem_iff e L A h x).mp hx
+  · intro hy
+    refine ⟨e.symm y, ?_, e.apply_symm_apply y⟩
+    apply (conjugacy_range_mem_iff e L A h (e.symm y)).mpr
+    simpa only [e.apply_symm_apply] using hy
+
+private def Elliptic.HigherHomology.conjugacyKernelEquiv {M N : Type*} [AddCommGroup M] [Module ℤ M]
+    [AddCommGroup N] [Module ℤ N] (e : M ≃ₗ[ℤ] N) (L : M →ₗ[ℤ] M) (A : N →ₗ[ℤ] N)
+    (h : ∀ x, e (L x) = A (e x)) : LinearMap.ker L ≃ₗ[ℤ] LinearMap.ker A :=
+  (@LinearEquiv.toAddEquiv _ _ _ _ _ _ _ _ _ _ _ _ (LinearMap.ker L).module
+      (LinearMap.ker A).module (e.ofSubmodules _ _ (conjugacy_map_ker e L A h))).toIntLinearEquiv
+
+private def
+    Elliptic.HigherHomology.conjugacyCokernelEquiv {M N : Type*} [AddCommGroup M] [Module ℤ M]
+    [AddCommGroup N] [Module ℤ N] (e : M ≃ₗ[ℤ] N) (L : M →ₗ[ℤ] M) (A : N →ₗ[ℤ] N)
+    (h : ∀ x, e (L x) = A (e x)) : (M ⧸ LinearMap.range L) ≃ₗ[ℤ] (N ⧸ LinearMap.range A) :=
+  (@LinearEquiv.toAddEquiv _ _ _ _ _ _ _ _ _ _ _ _ (Submodule.Quotient.module (LinearMap.range L))
+      (Submodule.Quotient.module (LinearMap.range A))
+      (Submodule.Quotient.equiv _ _ e (conjugacy_map_range e L A h))).toIntLinearEquiv
+
+private def
+    Elliptic.HigherHomology.shortExtensionLiftOne {M : Type*} [AddCommGroup M] [modM : Module ℤ M]
+    (d : M →ₗ[ℤ] ℤ) (hd : Function.Surjective d) : M :=
+  Classical.choose (hd 1)
+
+@[simp]
+private theorem Elliptic.HigherHomology.shortExtensionLiftOne_boundary {M : Type*} [AddCommGroup M]
+    [modM : Module ℤ M] (d : M →ₗ[ℤ] ℤ) (hd : Function.Surjective d) :
+    d (shortExtensionLiftOne d hd) = 1 :=
+  Classical.choose_spec (hd 1)
+
+private theorem
+    Elliptic.HigherHomology.shortExtension_boundary_inclusion {A M : Type*} [AddCommGroup A]
+    [Module ℤ A] [AddCommGroup M] [modM : Module ℤ M] (i : A →ₗ[ℤ] M) (d : M →ₗ[ℤ] ℤ)
+    (hexact : LinearMap.range i = LinearMap.ker d) (a : A) : d (i a) = 0 := by
+  have ha : i a ∈ LinearMap.range i := ⟨a, rfl⟩
+  rw [hexact] at ha
+  exact ha
+
+private def
+    Elliptic.HigherHomology.shortExtensionAssembly {A M : Type*} [AddCommGroup A] [Module ℤ A]
+    [AddCommGroup M] [modM : Module ℤ M] (i : A →ₗ[ℤ] M) (u : M) : A × ℤ →ₗ[ℤ] M
+    where
+  toFun x := i x.1 + x.2 • u
+  map_add' x
+    y := by
+    simp only [Prod.fst_add, Prod.snd_add, map_add, add_zsmul]
+    abel
+  map_smul' r
+    x := by
+    change i (r • x.1) + (r * x.2) • u = modM.smul r (i x.1 + x.2 • u)
+    rw [int_smul_eq_zsmul]
+    simp [map_zsmul, mul_zsmul, zsmul_add]
+
+@[simp]
+private theorem Elliptic.HigherHomology.shortExtensionAssembly_apply {A M : Type*} [AddCommGroup A]
+    [Module ℤ A] [AddCommGroup M] [modM : Module ℤ M] (i : A →ₗ[ℤ] M) (u : M) (x : A × ℤ) :
+    shortExtensionAssembly i u x = i x.1 + x.2 • u :=
+  rfl
+
+private theorem
+    Elliptic.HigherHomology.shortExtensionAssembly_boundary {A M : Type*} [AddCommGroup A]
+    [Module ℤ A] [AddCommGroup M] [modM : Module ℤ M] (i : A →ₗ[ℤ] M) (d : M →ₗ[ℤ] ℤ)
+    (hexact : LinearMap.range i = LinearMap.ker d) (u : M) (hu : d u = 1) (x : A × ℤ) :
+    d (shortExtensionAssembly i u x) = x.2 := by
+  simp [shortExtensionAssembly_apply, shortExtension_boundary_inclusion i d hexact, hu]
+
+private theorem
+    Elliptic.HigherHomology.shortExtensionAssembly_injective {A M : Type*} [AddCommGroup A]
+    [Module ℤ A] [AddCommGroup M] [modM : Module ℤ M] (i : A →ₗ[ℤ] M) (d : M →ₗ[ℤ] ℤ)
+    (hi : Function.Injective i) (hexact : LinearMap.range i = LinearMap.ker d) (u : M)
+    (hu : d u = 1) : Function.Injective (shortExtensionAssembly i u) := by
+  intro x y hxy
+  have hs : x.2 = y.2 := by
+    have h := congrArg d hxy
+    simpa only [shortExtensionAssembly_boundary i d hexact u hu] using h
+  have ha : x.1 = y.1 := by
+    apply hi
+    apply add_right_cancel (b := x.2 • u)
+    simpa only [shortExtensionAssembly_apply, hs] using hxy
+  exact Prod.ext ha hs
+
+private theorem
+    Elliptic.HigherHomology.shortExtensionAssembly_surjective {A M : Type*} [AddCommGroup A]
+    [Module ℤ A] [AddCommGroup M] [modM : Module ℤ M] (i : A →ₗ[ℤ] M) (d : M →ₗ[ℤ] ℤ)
+    (hexact : LinearMap.range i = LinearMap.ker d) (u : M) (hu : d u = 1) :
+    Function.Surjective (shortExtensionAssembly i u) := by
+  intro x
+  have hx : x - d x • u ∈ LinearMap.range i := by
+    rw [hexact]
+    change d (x - d x • u) = 0
+    simp [hu]
+  obtain ⟨a, ha⟩ := hx
+  refine ⟨(a, d x), ?_⟩
+  change i a + d x • u = x
+  rw [ha, sub_add_cancel]
+
+private def
+    Elliptic.HigherHomology.shortExtensionProductEquiv {A M : Type*} [AddCommGroup A] [Module ℤ A]
+    [AddCommGroup M] [modM : Module ℤ M] (i : A →ₗ[ℤ] M) (d : M →ₗ[ℤ] ℤ)
+    (hi : Function.Injective i) (hd : Function.Surjective d)
+    (hexact : LinearMap.range i = LinearMap.ker d) : M ≃ₗ[ℤ] A × ℤ :=
+  (LinearEquiv.ofBijective (shortExtensionAssembly i (shortExtensionLiftOne d hd))
+      ⟨shortExtensionAssembly_injective i d hi hexact _ (shortExtensionLiftOne_boundary d hd),
+        shortExtensionAssembly_surjective i d hexact _
+          (shortExtensionLiftOne_boundary d hd)⟩).symm
+
+@[simp]
+private theorem Elliptic.HigherHomology.shortExtensionProductEquiv_symm_apply {A M : Type*}
+    [AddCommGroup A] [Module ℤ A] [AddCommGroup M] [modM : Module ℤ M] (i : A →ₗ[ℤ] M)
+    (d : M →ₗ[ℤ] ℤ) (hi : Function.Injective i) (hd : Function.Surjective d)
+    (hexact : LinearMap.range i = LinearMap.ker d) (x : A × ℤ) :
+    (shortExtensionProductEquiv i d hi hd hexact).symm x =
+      i x.1 + x.2 • shortExtensionLiftOne d hd :=
+  rfl
+
+@[simp]
+private theorem
+    Elliptic.HigherHomology.shortExtensionProductEquiv_snd {A M : Type*} [AddCommGroup A]
+    [Module ℤ A] [AddCommGroup M] [modM : Module ℤ M] (i : A →ₗ[ℤ] M) (d : M →ₗ[ℤ] ℤ)
+    (hi : Function.Injective i) (hd : Function.Surjective d)
+    (hexact : LinearMap.range i = LinearMap.ker d) (x : M) :
+    (shortExtensionProductEquiv i d hi hd hexact x).2 = d x := by
+  obtain ⟨y, rfl⟩ := (shortExtensionProductEquiv i d hi hd hexact).symm.surjective x
+  rw [LinearEquiv.apply_symm_apply, shortExtensionProductEquiv_symm_apply]
+  simp [shortExtension_boundary_inclusion i d hexact]
+
+@[simp]
+private theorem Elliptic.HigherHomology.shortExtensionProductEquiv_inclusion {A M : Type*}
+    [AddCommGroup A] [Module ℤ A] [AddCommGroup M] [modM : Module ℤ M] (i : A →ₗ[ℤ] M)
+    (d : M →ₗ[ℤ] ℤ) (hi : Function.Injective i) (hd : Function.Surjective d)
+    (hexact : LinearMap.range i = LinearMap.ker d) (a : A) :
+    shortExtensionProductEquiv i d hi hd hexact (i a) = (a, 0) := by
+  apply (shortExtensionProductEquiv i d hi hd hexact).symm.injective
+  simp
+
+
+private def Elliptic.HigherHomology.shortExtensionEndpointCoordinates {A : Type*} [AddCommGroup A]
+    [Module ℤ A] (eA : A ≃ₗ[ℤ] ℤ) : (A × ℤ) ≃ₗ[ℤ] (Fin 2 → ℤ)
+    where
+  toFun x := ![eA x.1, x.2]
+  invFun x := (eA.symm (x 0), x 1)
+  left_inv x := by simp
+  right_inv x := by ext k; fin_cases k <;> simp
+  map_add' x y := by ext k; fin_cases k <;> simp
+  map_smul' n x := by ext k; fin_cases k <;> simp
+
+public
+theorem Elliptic.HigherHomology.shortExtension_normalized_boundary_ker {M : Type*}
+    [AddCommGroup M] [modM : Module ℤ M] {B : Type*} [AddCommGroup B] [Module ℤ B] (d : M →ₗ[ℤ] B)
+    (eB : B ≃ₗ[ℤ] ℤ) : LinearMap.ker (eB.toLinearMap.comp d) = LinearMap.ker d := by
+  ext x
+  change eB (d x) = 0 ↔ d x = 0
+  exact eB.map_eq_zero_iff
+
+private def
+    Elliptic.HigherHomology.shortExtensionFinTwoEquivOfEndpoints {A M : Type*} [AddCommGroup A]
+    [Module ℤ A] [AddCommGroup M] [modM : Module ℤ M] {B : Type*} [AddCommGroup B] [Module ℤ B]
+    (i : A →ₗ[ℤ] M) (d : M →ₗ[ℤ] B) (eA : A ≃ₗ[ℤ] ℤ) (eB : B ≃ₗ[ℤ] ℤ) (hi : Function.Injective i)
+    (hd : Function.Surjective d) (hexact : LinearMap.range i = LinearMap.ker d) :
+    M ≃ₗ[ℤ] (Fin 2 → ℤ) :=
+  (shortExtensionProductEquiv i (eB.toLinearMap.comp d) hi (eB.surjective.comp hd)
+        (hexact.trans (shortExtension_normalized_boundary_ker d eB).symm)).trans
+    (shortExtensionEndpointCoordinates eA)
+
+@[simp]
+private theorem Elliptic.HigherHomology.shortExtensionFinTwoEquivOfEndpoints_one {A M : Type*}
+    [AddCommGroup A] [Module ℤ A] [AddCommGroup M] [modM : Module ℤ M] {B : Type*}
+    [AddCommGroup B] [Module ℤ B] (i : A →ₗ[ℤ] M) (d : M →ₗ[ℤ] B) (eA : A ≃ₗ[ℤ] ℤ)
+    (eB : B ≃ₗ[ℤ] ℤ) (hi : Function.Injective i) (hd : Function.Surjective d)
+    (hexact : LinearMap.range i = LinearMap.ker d) (x : M) :
+    shortExtensionFinTwoEquivOfEndpoints i d eA eB hi hd hexact x 1 = eB (d x) :=
+  shortExtensionProductEquiv_snd i (eB.toLinearMap.comp d) hi (eB.surjective.comp hd)
+    (hexact.trans (shortExtension_normalized_boundary_ker d eB).symm) x
+
+@[simp]
+private theorem Elliptic.HigherHomology.shortExtensionFinTwoEquivOfEndpoints_inclusion {A M : Type*}
+    [AddCommGroup A] [Module ℤ A] [AddCommGroup M] [modM : Module ℤ M] {B : Type*}
+    [AddCommGroup B] [Module ℤ B] (i : A →ₗ[ℤ] M) (d : M →ₗ[ℤ] B) (eA : A ≃ₗ[ℤ] ℤ)
+    (eB : B ≃ₗ[ℤ] ℤ) (hi : Function.Injective i) (hd : Function.Surjective d)
+    (hexact : LinearMap.range i = LinearMap.ker d) (a : A) :
+    shortExtensionFinTwoEquivOfEndpoints i d eA eB hi hd hexact (i a) = ![eA a, 0] := by
+  change
+    shortExtensionEndpointCoordinates eA
+        (shortExtensionProductEquiv i (eB.toLinearMap.comp d) hi (eB.surjective.comp hd)
+          (hexact.trans (shortExtension_normalized_boundary_ker d eB).symm) (i a)) =
+      _
+  rw [shortExtensionProductEquiv_inclusion]
+  rfl
+
+private def Elliptic.HigherHomology.mappingTorusKernelOneEquiv (j : Elliptic.Kind) :
+    LinearMap.ker (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm 1) ≃ₗ[ℤ] ℤ :=
+  (conjugacyKernelEquiv torusH1Equiv _ _ (mappingTorusDifference_one j)).trans
+    (fibreInverseKernelEquivInt j)
+
+private def Elliptic.HigherHomology.mappingTorusCokernelOneEquiv (j : Elliptic.Kind) :
+    (SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 1 ⧸
+        LinearMap.range
+          (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm 1)) ≃ₗ[ℤ]
+      ℤ :=
+  (conjugacyCokernelEquiv torusH1Equiv _ _ (mappingTorusDifference_one j)).trans
+    (fibreInverseCokernelEquivInt j)
+
+@[simp]
+private theorem Elliptic.HigherHomology.mappingTorusCokernelOneEquiv_mk (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 1) :
+    mappingTorusCokernelOneEquiv j (Submodule.Quotient.mk a) =
+      fibreCoinvariantCoordinate j (torusH1Equiv a) :=
+  rfl
+
+private def Elliptic.HigherHomology.mappingTorusKernelTwoEquiv (j : Elliptic.Kind) :
+    LinearMap.ker (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm 2) ≃ₗ[ℤ] ℤ :=
+  (conjugacyKernelEquiv torusH2Coordinates _ _ (mappingTorusDifference_two j)).trans
+    (fibreSquareInverseKernelEquivInt j)
+
+private def Elliptic.HigherHomology.mappingTorusCokernelTwoEquiv (j : Elliptic.Kind) :
+    (SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 2 ⧸
+        LinearMap.range
+          (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm 2)) ≃ₗ[ℤ]
+      ℤ :=
+  (conjugacyCokernelEquiv torusH2Coordinates _ _ (mappingTorusDifference_two j)).trans
+    (fibreSquareInverseCokernelEquivInt j)
+
+@[simp]
+private theorem Elliptic.HigherHomology.mappingTorusCokernelTwoEquiv_mk (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 2) :
+    mappingTorusCokernelTwoEquiv j (Submodule.Quotient.mk a) = torusH2Coordinates a 0 :=
+  rfl
+
+private def Elliptic.HigherHomology.mappingTorusKernelThreeEquiv (j : Elliptic.Kind) :
+    LinearMap.ker (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm 3) ≃ₗ[ℤ] ℤ :=
+  by
+  letI :=
+    (LinearMap.ker (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm 3)).module
+  letI :=
+    (⊤ :
+        Submodule ℤ
+          (SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3)
+            3)).module
+  exact
+    (((LinearEquiv.ofEq
+                (LinearMap.ker
+                  (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm 3))
+                (⊤ :
+                  Submodule ℤ
+                    (SingularMayerVietoris.SingularHomology
+                      (PeriodTorusHigherHomology.ProductTorus 3) 3))
+                (by rw [mappingTorusDifference_three, LinearMap.ker_zero])).toAddEquiv.trans
+            Submodule.topEquiv.toAddEquiv).trans
+        torusH3Coordinates.toAddEquiv).toIntLinearEquiv
+
+private def Elliptic.HigherHomology.mappingTorusCokernelThreeEquiv (j : Elliptic.Kind) :
+    (SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3 ⧸
+        LinearMap.range
+          (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm 3)) ≃ₗ[ℤ]
+      ℤ := by
+  letI :=
+    Submodule.Quotient.module
+      (LinearMap.range (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm 3))
+  exact
+    ((Submodule.quotEquivOfEqBot
+            (LinearMap.range
+              (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm 3))
+            (by rw [mappingTorusDifference_three, LinearMap.range_zero])).toAddEquiv.trans
+        torusH3Coordinates.toAddEquiv).toIntLinearEquiv
+
+@[simp]
+private theorem Elliptic.HigherHomology.mappingTorusCokernelThreeEquiv_mk (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3) :
+    mappingTorusCokernelThreeEquiv j (Submodule.Quotient.mk a) = torusH3Coordinates a :=
+  rfl
+
+private def Elliptic.HigherHomology.mappingTorusH2Equiv (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology (mappingTorusModel j) 2 ≃ₗ[ℤ] (Fin 2 → ℤ) :=
+  shortExtensionFinTwoEquivOfEndpoints
+    (MappingTorusHomology.cokernelInclusion (fibreTorusHomeomorph j).symm 2)
+    (MappingTorusHomology.kernelBoundary (fibreTorusHomeomorph j).symm 1)
+    (mappingTorusCokernelTwoEquiv j) (mappingTorusKernelOneEquiv j)
+    (MappingTorusHomology.cokernelInclusion_injective _ _)
+    (MappingTorusHomology.kernelBoundary_surjective _ _)
+    (MappingTorusHomology.cokernelInclusion_range_eq_ker_kernelBoundary _ _)
+
+private theorem Elliptic.HigherHomology.mappingTorusH2Equiv_boundary (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (mappingTorusModel j) 2) :
+    mappingTorusH2Equiv j a 1 =
+      torusH1Equiv (MappingTorusHomology.wangBoundary (fibreTorusHomeomorph j).symm 1 a) 2 := by
+  exact shortExtensionFinTwoEquivOfEndpoints_one _ _ _ _ _ _ _ a
+
+private theorem Elliptic.HigherHomology.mappingTorusH2Equiv_fibre (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 2) :
+    mappingTorusH2Equiv j
+        (MappingTorusHomology.fibreHomologyMap (fibreTorusHomeomorph j).symm 2 a) =
+      ![torusH2Coordinates a 0, 0] := by
+  change
+    mappingTorusH2Equiv j
+        (MappingTorusHomology.cokernelInclusion (fibreTorusHomeomorph j).symm 2
+          (Submodule.Quotient.mk a)) =
+      _
+  rw [mappingTorusH2Equiv, shortExtensionFinTwoEquivOfEndpoints_inclusion,
+    mappingTorusCokernelTwoEquiv_mk]
+
+private def Elliptic.HigherHomology.mappingTorusH3Equiv (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology (mappingTorusModel j) 3 ≃ₗ[ℤ] (Fin 2 → ℤ) :=
+  shortExtensionFinTwoEquivOfEndpoints
+    (MappingTorusHomology.cokernelInclusion (fibreTorusHomeomorph j).symm 3)
+    (MappingTorusHomology.kernelBoundary (fibreTorusHomeomorph j).symm 2)
+    (mappingTorusCokernelThreeEquiv j) (mappingTorusKernelTwoEquiv j)
+    (MappingTorusHomology.cokernelInclusion_injective _ _)
+    (MappingTorusHomology.kernelBoundary_surjective _ _)
+    (MappingTorusHomology.cokernelInclusion_range_eq_ker_kernelBoundary _ _)
+
+private theorem Elliptic.HigherHomology.mappingTorusH3Equiv_boundary (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (mappingTorusModel j) 3) :
+    mappingTorusH3Equiv j a 1 =
+      -(torusH2Coordinates (MappingTorusHomology.wangBoundary (fibreTorusHomeomorph j).symm 2 a)
+          1) := by exact shortExtensionFinTwoEquivOfEndpoints_one _ _ _ _ _ _ _ a
+
+private theorem Elliptic.HigherHomology.mappingTorusH3Equiv_fibre (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3) :
+    mappingTorusH3Equiv j
+        (MappingTorusHomology.fibreHomologyMap (fibreTorusHomeomorph j).symm 3 a) =
+      ![torusH3Coordinates a, 0] := by
+  change
+    mappingTorusH3Equiv j
+        (MappingTorusHomology.cokernelInclusion (fibreTorusHomeomorph j).symm 3
+          (Submodule.Quotient.mk a)) =
+      _
+  rw [mappingTorusH3Equiv, shortExtensionFinTwoEquivOfEndpoints_inclusion,
+    mappingTorusCokernelThreeEquiv_mk]
+
+private theorem
+    Elliptic.HigherHomology.mappingTorusKernelBoundary_three_injective (j : Elliptic.Kind) :
+    Function.Injective (MappingTorusHomology.kernelBoundary (fibreTorusHomeomorph j).symm 3) := by
+  have :=
+    PeriodTorusHigherHomology.productTorus_homology_subsingleton_of_lt (show 3 < 4 by decide)
+  intro a b hab
+  have hzero : MappingTorusHomology.wangBoundary (fibreTorusHomeomorph j).symm 3 (a - b) = 0 := by
+    rw [map_sub]
+    exact sub_eq_zero.mpr (congrArg Subtype.val hab)
+  have hmem :
+    a - b ∈ LinearMap.ker (MappingTorusHomology.wangBoundary (fibreTorusHomeomorph j).symm 3) :=
+    hzero
+  rw [← MappingTorusHomology.wang_exact_at_mappingTorus] at hmem
+  obtain ⟨v, hv⟩ := hmem
+  have hv0 : v = 0 := Subsingleton.elim _ _
+  rw [hv0, map_zero] at hv
+  exact sub_eq_zero.mp hv.symm
+
+private def Elliptic.HigherHomology.mappingTorusH4Equiv (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology (mappingTorusModel j) 4 ≃ₗ[ℤ] ℤ :=
+  (LinearEquiv.ofBijective (MappingTorusHomology.kernelBoundary (fibreTorusHomeomorph j).symm 3)
+        ⟨mappingTorusKernelBoundary_three_injective j,
+          MappingTorusHomology.kernelBoundary_surjective _ _⟩).trans
+    (mappingTorusKernelThreeEquiv j)
+
+private theorem Elliptic.HigherHomology.mappingTorusH4Equiv_boundary (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (mappingTorusModel j) 4) :
+    mappingTorusH4Equiv j a =
+      torusH3Coordinates (MappingTorusHomology.wangBoundary (fibreTorusHomeomorph j).symm 3 a) :=
+  rfl
+
+private abbrev Elliptic.HigherHomology.torusH0Coordinates :
+    SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 0 ≃ₗ[ℤ] ℤ :=
+  PeriodTorusHigherHomology.connectedHomologyZeroEquiv (PeriodTorusHigherHomology.ProductTorus 3)
+
+private theorem Elliptic.HigherHomology.torusH0Coordinates_pointClass
+    (x : PeriodTorusHigherHomology.ProductTorus 3) :
+    torusH0Coordinates (PeriodTorusHigherHomology.pointClass x) = 1 :=
+  PeriodTorusHigherHomology.connectedHomologyZeroEquiv_pointClass x
+
+private theorem Elliptic.HigherHomology.mappingTorusMonodromy_zero (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 0) :
+    torusH0Coordinates
+        (MappingTorusHomology.monodromyHomologyMap (fibreTorusHomeomorph j).symm 0 a) =
+      torusH0Coordinates a :=
+  PeriodTorusHigherHomology.connectedHomologyZeroEquiv_natural
+    ((fibreTorusHomeomorph j).symm :
+      C(PeriodTorusHigherHomology.ProductTorus 3, PeriodTorusHigherHomology.ProductTorus 3))
+    a
+
+private theorem Elliptic.HigherHomology.mappingTorusDifference_zero (j : Elliptic.Kind) :
+    MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm 0 = 0 := by
+  ext a
+  apply torusH0Coordinates.injective
+  change
+    torusH0Coordinates
+        (a - MappingTorusHomology.monodromyHomologyMap (fibreTorusHomeomorph j).symm 0 a) =
+      torusH0Coordinates 0
+  rw [map_sub, mappingTorusMonodromy_zero, sub_self, map_zero]
+
+private def Elliptic.HigherHomology.mappingTorusKernelZeroEquiv (j : Elliptic.Kind) :
+    LinearMap.ker (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm 0) ≃ₗ[ℤ] ℤ :=
+  by
+  letI :=
+    (LinearMap.ker (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm 0)).module
+  letI :=
+    (⊤ :
+        Submodule ℤ
+          (SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3)
+            0)).module
+  exact
+    (((LinearEquiv.ofEq
+                (LinearMap.ker
+                  (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm 0))
+                (⊤ :
+                  Submodule ℤ
+                    (SingularMayerVietoris.SingularHomology
+                      (PeriodTorusHigherHomology.ProductTorus 3) 0))
+                (by rw [mappingTorusDifference_zero, LinearMap.ker_zero])).toAddEquiv.trans
+            Submodule.topEquiv.toAddEquiv).trans
+        torusH0Coordinates.toAddEquiv).toIntLinearEquiv
+
+private def Elliptic.HigherHomology.mappingTorusCokernelZeroEquiv (j : Elliptic.Kind) :
+    (SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 0 ⧸
+        LinearMap.range
+          (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm 0)) ≃ₗ[ℤ]
+      ℤ := by
+  letI :=
+    Submodule.Quotient.module
+      (LinearMap.range (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm 0))
+  exact
+    ((Submodule.quotEquivOfEqBot
+            (LinearMap.range
+              (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm 0))
+            (by rw [mappingTorusDifference_zero, LinearMap.range_zero])).toAddEquiv.trans
+        torusH0Coordinates.toAddEquiv).toIntLinearEquiv
+
+private def Elliptic.HigherHomology.mappingTorusH0Equiv (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology (mappingTorusModel j) 0 ≃ₗ[ℤ] ℤ :=
+  (MappingTorusHomology.degreeZeroHomologyEquiv (fibreTorusHomeomorph j).symm).trans
+    (mappingTorusCokernelZeroEquiv j)
+
+private def Elliptic.HigherHomology.mappingTorusH1Equiv (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology (mappingTorusModel j) 1 ≃ₗ[ℤ] (Fin 2 → ℤ) :=
+  shortExtensionFinTwoEquivOfEndpoints
+    (MappingTorusHomology.cokernelInclusion (fibreTorusHomeomorph j).symm 1)
+    (MappingTorusHomology.kernelBoundary (fibreTorusHomeomorph j).symm 0)
+    (mappingTorusCokernelOneEquiv j) (mappingTorusKernelZeroEquiv j)
+    (MappingTorusHomology.cokernelInclusion_injective _ _)
+    (MappingTorusHomology.kernelBoundary_surjective _ _)
+    (MappingTorusHomology.cokernelInclusion_range_eq_ker_kernelBoundary _ _)
+
+private theorem Elliptic.HigherHomology.mappingTorusH1Equiv_boundary (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (mappingTorusModel j) 1) :
+    mappingTorusH1Equiv j a 1 =
+      torusH0Coordinates (MappingTorusHomology.wangBoundary (fibreTorusHomeomorph j).symm 0 a) := by
+  exact shortExtensionFinTwoEquivOfEndpoints_one _ _ _ _ _ _ _ a
+
+private theorem Elliptic.HigherHomology.mappingTorusH1Equiv_fibre (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 1) :
+    mappingTorusH1Equiv j
+        (MappingTorusHomology.fibreHomologyMap (fibreTorusHomeomorph j).symm 1 a) =
+      ![fibreCoinvariantCoordinate j (torusH1Equiv a), 0] := by
+  change
+    mappingTorusH1Equiv j
+        (MappingTorusHomology.cokernelInclusion (fibreTorusHomeomorph j).symm 1
+          (Submodule.Quotient.mk a)) =
+      _
+  rw [mappingTorusH1Equiv, shortExtensionFinTwoEquivOfEndpoints_inclusion,
+    mappingTorusCokernelOneEquiv_mk]
+
+private def Elliptic.psiOne : Lattice →ₗ[ℤ] ℤ
+    where
+  toFun w := 2 * w 1 + w 2 + 3 * w 3
+  map_add' w z := by simp only [Pi.add_apply]; ring
+  map_smul' a w := by simp only [Pi.smul_apply, smul_eq_mul, RingHom.id_apply]; ring
+
+private def Elliptic.psiTwo : Lattice →ₗ[ℤ] ℤ
+    where
+  toFun w := w 1 + w 2 + 2 * w 3
+  map_add' w z := by simp only [Pi.add_apply]; ring
+  map_smul' a w := by simp only [Pi.smul_apply, smul_eq_mul, RingHom.id_apply]; ring
+
+private def Elliptic.psi : Kind → Lattice →ₗ[ℤ] ℤ
+  | .three => psiOne
+  | .four => psiTwo
+
+private def Elliptic.coinvariantMap (j : Kind) : Lattice →ₗ[ℤ] (Fin 2 → ℤ)
+    where
+  toFun w := ![γ w, psi j w]
+  map_add' w z := by ext k; fin_cases k <;> simp [γ]
+  map_smul' a
+    w := by
+    ext k
+    fin_cases k
+    · rfl
+    · exact (psi j).map_smul a w
+
+private def Elliptic.coinvariantSection (j : Kind) : (Fin 2 → ℤ) →ₗ[ℤ] Lattice
+    where
+  toFun
+    c :=
+    match j with
+    | .three => ![c 0, 0, c 1, 0]
+    | .four => ![c 0, c 1, 0, 0]
+  map_add' c d := by cases j <;> ext k <;> fin_cases k <;> simp
+  map_smul' a c := by cases j <;> ext k <;> fin_cases k <;> simp
+
+@[simp]
+private theorem Elliptic.coinvariantMap_section (j : Kind) (c : Fin 2 → ℤ) :
+    coinvariantMap j (coinvariantSection j c) = c := by
+  cases j <;> ext k <;> fin_cases k <;>
+    simp [coinvariantMap, coinvariantSection, γ, psi, psiOne, psiTwo]
+
+private theorem
+    Elliptic.coinvariantMap_surjective (j : Kind) : Function.Surjective (coinvariantMap j) :=
+  fun c => ⟨coinvariantSection j c, coinvariantMap_section j c⟩
+
+private def Elliptic.coinvariantDifference (j : Kind) : Lattice →ₗ[ℤ] Lattice :=
+  (j.matrix - 1).mulVecLin
+
+private theorem Elliptic.coinvariantDifference_apply (j : Kind) (w : Lattice) :
+    coinvariantDifference j w = j.matrix *ᵥ w - w := by simp [coinvariantDifference]
+
+private theorem Elliptic.coinvariantMap_monodromy (j : Kind) (w : Lattice) :
+    coinvariantMap j (j.matrix *ᵥ w) = coinvariantMap j w := by
+  cases j <;> ext k <;> fin_cases k <;>
+      simp [coinvariantMap, γ, psi, psiOne, psiTwo, Kind.matrix, A₁, A₂, dotProduct,
+        Fin.sum_univ_succ] <;>
+    ring
+
+@[simp]
+private theorem Elliptic.coinvariantMap_difference (j : Kind) (w : Lattice) :
+    coinvariantMap j (coinvariantDifference j w) = 0 := by
+  rw [coinvariantDifference_apply, map_sub, coinvariantMap_monodromy, sub_self]
+
+private def Elliptic.coinvariantKernelLift (j : Kind) (w : Lattice) : Lattice :=
+  match j with
+  | .three => ![0, w 3, w 1 + w 3, 0]
+  | .four => ![0, -w 1 - w 3, w 3, 0]
+
+private theorem Elliptic.coinvariantDifference_kernelLift (j : Kind) (w : Lattice)
+    (hw : coinvariantMap j w = 0) : coinvariantDifference j (coinvariantKernelLift j w) = w := by
+  have h0 : w 0 = 0 := congrFun hw 0
+  have hψ : psi j w = 0 := congrFun hw 1
+  cases j with
+  | three =>
+    change 2 * w 1 + w 2 + 3 * w 3 = 0 at hψ
+    ext k
+    fin_cases k <;> simp [coinvariantDifference, coinvariantKernelLift, Kind.matrix, A₁] <;> omega
+  | four =>
+    change w 1 + w 2 + 2 * w 3 = 0 at hψ
+    ext k
+    fin_cases k <;> simp [coinvariantDifference, coinvariantKernelLift, Kind.matrix, A₂] <;> omega
+
+private theorem Elliptic.coinvariantMap_ker_eq_range (j : Kind) :
+    LinearMap.ker (coinvariantMap j) = LinearMap.range (coinvariantDifference j) := by
+  ext w
+  change coinvariantMap j w = 0 ↔ ∃ u, coinvariantDifference j u = w
+  constructor
+  · intro hw
+    exact ⟨coinvariantKernelLift j w, coinvariantDifference_kernelLift j w hw⟩
+  · rintro ⟨u, rfl⟩
+    exact coinvariantMap_difference j u
+
+private abbrev Elliptic.AffineAutomorphism :=
+  RealPlane₄ ≃ᵃ[ℝ] RealPlane₄
+
+private theorem
+    Elliptic.matrix_pow_pred_mul (j : Kind) : j.matrix ^ (j.order - 1) * j.matrix = 1 := by
+  rw [← pow_succ, Nat.sub_add_cancel j.order_pos, j.matrix_pow_order]
+
+private theorem
+    Elliptic.matrix_mul_pow_pred (j : Kind) : j.matrix * j.matrix ^ (j.order - 1) = 1 := by
+  rw [← pow_succ', Nat.sub_add_cancel j.order_pos, j.matrix_pow_order]
+
+private theorem Elliptic.realMatrix_pow_pred_mul_mo1973_22121 (j : Kind) :
+    (j.matrix.map (Int.castRingHom ℝ)) ^ (j.order - 1) * j.matrix.map (Int.castRingHom ℝ) = 1 := by
+  rw [← Matrix.map_pow, ← Matrix.map_mul, matrix_pow_pred_mul]
+  simp
+
+private theorem Elliptic.realMatrix_mul_pow_pred_mo1973_22122 (j : Kind) :
+    j.matrix.map (Int.castRingHom ℝ) * (j.matrix.map (Int.castRingHom ℝ)) ^ (j.order - 1) = 1 := by
+  rw [← Matrix.map_pow, ← Matrix.map_mul, matrix_mul_pow_pred]
+  simp
+
+private def Elliptic.flatLinearEquiv (j : Kind) : RealPlane₄ ≃ₗ[ℝ] RealPlane₄
+    where
+  __ := flatLinear j
+  invFun x := (j.matrix.map (Int.castRingHom ℝ)) ^ (j.order - 1) *ᵥ x
+  left_inv
+    x := by
+    change
+      (j.matrix.map (Int.castRingHom ℝ)) ^ (j.order - 1) *ᵥ
+          (j.matrix.map (Int.castRingHom ℝ) *ᵥ x) =
+        x
+    rw [Matrix.mulVec_mulVec, realMatrix_pow_pred_mul_mo1973_22121, Matrix.one_mulVec]
+  right_inv
+    x := by
+    change
+      j.matrix.map (Int.castRingHom ℝ) *ᵥ
+          ((j.matrix.map (Int.castRingHom ℝ)) ^ (j.order - 1) *ᵥ x) =
+        x
+    rw [Matrix.mulVec_mulVec, realMatrix_mul_pow_pred_mo1973_22122, Matrix.one_mulVec]
+
+private def Elliptic.realCastAddHom : Lattice →+ RealPlane₄
+    where
+  toFun := realCast
+  map_zero' := by ext k; simp [realCast]
+  map_add' w z := by ext k; simp [realCast]
+
+private def Elliptic.integerTranslationHom : Multiplicative Lattice →* AffineAutomorphism :=
+  (AffineEquiv.constVAddHom ℝ RealPlane₄).comp realCastAddHom.toMultiplicative
+
+private def Elliptic.integerTranslation (w : Lattice) : AffineAutomorphism :=
+  integerTranslationHom (Multiplicative.ofAdd w)
+
+@[simp]
+private theorem Elliptic.integerTranslation_apply (w : Lattice) (x : RealPlane₄) :
+    integerTranslation w x = realCast w + x :=
+  rfl
+
+@[simp]
+private theorem Elliptic.integerTranslation_zero : integerTranslation 0 = 1 :=
+  integerTranslationHom.map_one
+
+private theorem Elliptic.integerTranslation_add (w z : Lattice) :
+    integerTranslation (w + z) = integerTranslation w * integerTranslation z :=
+  integerTranslationHom.map_mul (Multiplicative.ofAdd w) (Multiplicative.ofAdd z)
+
+@[simp]
+private theorem Elliptic.integerTranslation_neg (w : Lattice) :
+    integerTranslation (-w) = (integerTranslation w)⁻¹ :=
+  integerTranslationHom.map_inv (Multiplicative.ofAdd w)
+
+private def Elliptic.affineGenerator (j : Kind) (v : Lattice) : AffineAutomorphism
+    where
+  toFun := flatAffine j v
+  invFun x := (flatLinearEquiv j).symm (x - (1 / (j.order : ℝ)) • realCast v)
+  left_inv
+    x := by
+    change
+      (flatLinearEquiv j).symm
+          ((flatLinearEquiv j x + (1 / (j.order : ℝ)) • realCast v) -
+            (1 / (j.order : ℝ)) • realCast v) =
+        x
+    rw [add_sub_cancel_right, LinearEquiv.symm_apply_apply]
+  right_inv
+    x := by
+    change
+      flatLinearEquiv j ((flatLinearEquiv j).symm (x - (1 / (j.order : ℝ)) • realCast v)) +
+          (1 / (j.order : ℝ)) • realCast v =
+        x
+    rw [LinearEquiv.apply_symm_apply, sub_add_cancel]
+  linear := flatLinearEquiv j
+  map_vadd' x
+    w := by
+    change
+      flatLinear j (w + x) + (1 / (j.order : ℝ)) • realCast v =
+        flatLinear j w + (flatLinear j x + (1 / (j.order : ℝ)) • realCast v)
+    rw [map_add, add_assoc]
+
+@[simp]
+private theorem Elliptic.affineGenerator_apply (j : Kind) (v : Lattice) (x : RealPlane₄) :
+    affineGenerator j v x = flatAffine j v x :=
+  rfl
+
+private theorem
+    Elliptic.affineAutomorphism_mul_apply (f g : AffineAutomorphism) (x : RealPlane₄) :
+    (f * g) x = f (g x) :=
+  rfl
+
+private theorem Elliptic.affineAutomorphism_pow_apply (f : AffineAutomorphism) (n : ℕ)
+    (x : RealPlane₄) : (f ^ n) x = (f : RealPlane₄ → RealPlane₄)^[n] x := by
+  induction n with
+  | zero => rfl
+  | succ n ih => rw [pow_succ', affineAutomorphism_mul_apply, ih, Function.iterate_succ_apply']
+
+private theorem Elliptic.affineGenerator_pow_apply (j : Kind) (v : Lattice) (n : ℕ)
+    (x : RealPlane₄) : (affineGenerator j v ^ n) x = (flatAffine j v)^[n] x :=
+  affineAutomorphism_pow_apply _ _ _
+
+private theorem Elliptic.affineGenerator_translation (j : Kind) (v w : Lattice) :
+    affineGenerator j v * integerTranslation w =
+      integerTranslation (j.matrix *ᵥ w) * affineGenerator j v := by
+  ext x
+  simp only [affineAutomorphism_mul_apply, affineGenerator_apply, integerTranslation_apply,
+    flatAffine, map_add, flatLinear_realCast, add_assoc]
+
+private theorem
+    Elliptic.affineGenerator_pow_order (j : Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    affineGenerator j v ^ j.order = integerTranslation v := by
+  ext x
+  rw [affineGenerator_pow_apply, flatAffine_iterate_order j v hv, integerTranslation_apply,
+    add_comm]
+
+private theorem Elliptic.affineGenerator_pow_translation (j : Kind) (v w : Lattice) (n : ℕ) :
+    affineGenerator j v ^ n * integerTranslation w =
+      integerTranslation (j.matrix ^ n *ᵥ w) * affineGenerator j v ^ n := by
+  induction n with
+  | zero => simp
+  | succ n ih =>
+    calc
+      affineGenerator j v ^ (n + 1) * integerTranslation w =
+          affineGenerator j v * (affineGenerator j v ^ n * integerTranslation w) := by
+        rw [pow_succ', mul_assoc]
+      _ =
+          affineGenerator j v *
+            (integerTranslation (j.matrix ^ n *ᵥ w) * affineGenerator j v ^ n) := by rw [ih]
+      _ =
+          (affineGenerator j v * integerTranslation (j.matrix ^ n *ᵥ w)) *
+            affineGenerator j v ^ n :=
+        (mul_assoc _ _ _).symm
+      _ =
+          (integerTranslation (j.matrix *ᵥ (j.matrix ^ n *ᵥ w)) * affineGenerator j v) *
+            affineGenerator j v ^ n := by rw [affineGenerator_translation]
+      _ = integerTranslation (j.matrix ^ (n + 1) *ᵥ w) * affineGenerator j v ^ (n + 1) := by
+        rw [mul_assoc, ← pow_succ', Matrix.mulVec_mulVec, ← pow_succ']
+
+private theorem Elliptic.affineAutomorphism_continuous (f : AffineAutomorphism) : Continuous f :=
+  f.continuous_of_finiteDimensional
+
+private theorem Elliptic.flatProjection_isCoveringMap (p : PeriodDomain) :
+    IsCoveringMap (flatProjection p) := by
+  have hq : IsAddQuotientCoveringMap p.lattice.mkQ p.lattice.toAddSubgroup := by
+    apply p.lattice.toAddSubgroup.isAddQuotientCoveringMap_of_comm
+    change IsDiscrete (p.lattice : Set ComplexPlane₂)
+    let : DiscreteTopology (p.lattice : Set ComplexPlane₂) := p.lattice_discrete
+    exact DiscreteTopology.isDiscrete
+  exact hq.isCoveringMap.comp_homeomorph (periodEquiv p).toHomeomorph
+
+private def Elliptic.affineCoverProjection (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) : RealPlane₄ → Surface j p v hv :=
+  surfaceProjection j p v hv ∘ flatProjection p.val
+
+private theorem
+    Elliptic.affineCoverProjection_continuous (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) : Continuous (affineCoverProjection j p v hv) :=
+  (surfaceProjection_continuous j p v hv).comp (flatProjection_continuous p.val)
+
+private theorem
+    Elliptic.affineCoverProjection_surjective (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) : Function.Surjective (affineCoverProjection j p v hv) :=
+  (surfaceProjection_surjective j p v hv).comp (flatProjection_surjective p.val)
+
+private theorem Elliptic.affineCoverProjection_eq_iff_flatCongruent (j : Kind) (p : FixedPeriod j)
+    (v : Lattice) (hv : AdmissibleTwist j v) (x y : RealPlane₄) :
+    affineCoverProjection j p v hv x = affineCoverProjection j p v hv y ↔
+      ∃ r : ℕ, r < j.order ∧ FlatCongruent x ((flatAffine j v)^[r] y) := by
+  let := affineAction j p v hv.1
+  change
+    FiniteQuotient.project (CyclicGroup j) p.val.Torus (flatProjection p.val x) =
+        FiniteQuotient.project (CyclicGroup j) p.val.Torus (flatProjection p.val y) ↔
+      _
+  rw [FiniteQuotient.project_eq_iff_mem_orbit]
+  constructor
+  · rintro ⟨g, hg⟩
+    refine ⟨g.toAdd.val, ZMod.val_lt _, (flatProjection_eq_iff p.val _ _).mp ?_⟩
+    have hA :
+      g • flatProjection p.val y = flatProjection p.val ((flatAffine j v)^[g.toAdd.val] y) :=
+      affinePermutation_pow_flatProjection j p v g.toAdd.val y
+    exact hg.symm.trans hA
+  · rintro ⟨r, hr, hxy⟩
+    refine ⟨Multiplicative.ofAdd (r : ZMod j.order), ?_⟩
+    change
+      (affinePermutation j p v ^ (r : ZMod j.order).val) (flatProjection p.val y) =
+        flatProjection p.val x
+    rw [ZMod.val_natCast_of_lt hr, affinePermutation_pow_flatProjection]
+    exact ((flatProjection_eq_iff p.val _ _).mpr hxy).symm
+
+private theorem Elliptic.affineCoverProjection_eq_iff_translate (j : Kind) (p : FixedPeriod j)
+    (v : Lattice) (hv : AdmissibleTwist j v) (x y : RealPlane₄) :
+    affineCoverProjection j p v hv x = affineCoverProjection j p v hv y ↔
+      ∃ r : ℕ, r < j.order ∧ ∃ w : Lattice, x = realCast w + (flatAffine j v)^[r] y := by
+  rw [affineCoverProjection_eq_iff_flatCongruent]
+  simp only [FlatCongruent, sub_eq_iff_eq_add]
+
+private theorem Elliptic.realCast_injective : Function.Injective realCast := by
+  intro w z h
+  funext i
+  have hi := congrFun h i
+  change (w i : ℝ) = (z i : ℝ) at hi
+  exact_mod_cast hi
+
+private theorem Elliptic.affineTranslate_unique (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) (x : RealPlane₄) (r s : Fin j.order) (w z : Lattice)
+    (h : realCast w + (flatAffine j v)^[r.val] x = realCast z + (flatAffine j v)^[s.val] x) :
+    r = s ∧ w = z := by
+  let := affineAction j p v hv.1
+  let := affineAction_free j p v hv
+  have hproj := congrArg (flatProjection p.val) h
+  simp only [flatProjection_add, flatProjection_realCast, zero_add] at hproj
+  have hsmul :
+    Multiplicative.ofAdd (r.val : ZMod j.order) • flatProjection p.val x =
+      Multiplicative.ofAdd (s.val : ZMod j.order) • flatProjection p.val x := by
+    change
+      (affinePermutation j p v ^ (r.val : ZMod j.order).val) (flatProjection p.val x) =
+        (affinePermutation j p v ^ (s.val : ZMod j.order).val) (flatProjection p.val x)
+    rw [ZMod.val_natCast_of_lt r.isLt, ZMod.val_natCast_of_lt s.isLt,
+      affinePermutation_pow_flatProjection, affinePermutation_pow_flatProjection]
+    exact hproj
+  have hg := IsCancelSMul.right_cancel _ _ (flatProjection p.val x) hsmul
+  have hval := congrArg (fun g : CyclicGroup j => g.toAdd.val) hg
+  change (r.val : ZMod j.order).val = (s.val : ZMod j.order).val at hval
+  rw [ZMod.val_natCast_of_lt r.isLt, ZMod.val_natCast_of_lt s.isLt] at hval
+  have hrs : r = s := Fin.ext hval
+  subst s
+  exact ⟨rfl, realCast_injective (add_right_cancel h)⟩
+
+private theorem Elliptic.surfaceProjection_fibre_finite (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) (x : Surface j p v hv) :
+    Finite (surfaceProjection j p v hv ⁻¹' { x }) := by
+  apply Nat.finite_of_card_ne_zero
+  rw [surfaceProjection_fibre_card]
+  exact Nat.ne_of_gt j.order_pos
+
+private theorem
+    Elliptic.affineCoverProjection_isCoveringMap (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) : IsCoveringMap (affineCoverProjection j p v hv) :=
+  CoveringComposition.covering_comp_of_finite_fibres (flatProjection_isCoveringMap p.val)
+    (surfaceProjection_isCoveringMap j p v hv) (surfaceProjection_fibre_finite j p v hv)
+
+private def Elliptic.affineNormalForm (j : Kind) (v w : Lattice) (r : ℕ) : AffineAutomorphism :=
+  integerTranslation w * affineGenerator j v ^ r
+
+private theorem
+    Elliptic.affineNormalForm_apply (j : Kind) (v w : Lattice) (r : ℕ) (x : RealPlane₄) :
+    affineNormalForm j v w r x = realCast w + (flatAffine j v)^[r] x := by
+  rw [affineNormalForm, affineAutomorphism_mul_apply, integerTranslation_apply,
+    affineGenerator_pow_apply]
+
+private theorem Elliptic.affineNormalForm_mul (j : Kind) (v w z : Lattice) (r s : ℕ) :
+    affineNormalForm j v w r * affineNormalForm j v z s =
+      affineNormalForm j v (w + j.matrix ^ r *ᵥ z) (r + s) := by
+  unfold affineNormalForm
+  calc
+    (integerTranslation w * affineGenerator j v ^ r) *
+          (integerTranslation z * affineGenerator j v ^ s) =
+        integerTranslation w * (affineGenerator j v ^ r * integerTranslation z) *
+          affineGenerator j v ^ s := by simp only [mul_assoc]
+    _ =
+        (integerTranslation w * integerTranslation (j.matrix ^ r *ᵥ z)) *
+          (affineGenerator j v ^ r * affineGenerator j v ^ s) := by
+      rw [affineGenerator_pow_translation]
+      simp only [mul_assoc]
+    _ = integerTranslation (w + j.matrix ^ r *ᵥ z) * affineGenerator j v ^ (r + s) := by
+      rw [← integerTranslation_add, ← pow_add]
+
+private theorem
+    Elliptic.affineNormalForm_reduce_order (j : Kind) (v w : Lattice) (hv : j.matrix *ᵥ v = v)
+    (n : ℕ) (hn : j.order ≤ n) :
+    affineNormalForm j v w n = affineNormalForm j v (w + v) (n - j.order) := by
+  unfold affineNormalForm
+  rw [integerTranslation_add, ← affineGenerator_pow_order j v hv, mul_assoc, ← pow_add,
+    Nat.add_sub_of_le hn]
+
+private def Elliptic.affineNormalFormsSubgroup (j : Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    Subgroup AffineAutomorphism
+    where
+  carrier := {g | ∃ w : Lattice, ∃ r : Fin j.order, g = affineNormalForm j v w r.val}
+  one_mem' := ⟨0, ⟨0, j.order_pos⟩, by simp [affineNormalForm]⟩
+  mul_mem' := by
+    rintro f g ⟨w, r, rfl⟩ ⟨z, s, rfl⟩
+    by_cases h : r.val + s.val < j.order
+    · exact
+        ⟨w + j.matrix ^ r.val *ᵥ z, ⟨r.val + s.val, h⟩, affineNormalForm_mul j v w z r.val s.val⟩
+    · have hge : j.order ≤ r.val + s.val := Nat.le_of_not_gt h
+      have hlt : r.val + s.val - j.order < j.order := by omega
+      exact
+        ⟨w + j.matrix ^ r.val *ᵥ z + v, ⟨r.val + s.val - j.order, hlt⟩,
+          (affineNormalForm_mul j v w z r.val s.val).trans
+            (affineNormalForm_reduce_order j v _ hv _ hge)⟩
+  inv_mem' := by
+    rintro f ⟨w, r, rfl⟩
+    by_cases hr : r.val = 0
+    · refine ⟨-w, ⟨0, j.order_pos⟩, ?_⟩
+      simp [affineNormalForm, hr]
+    · have hk : j.order - r.val < j.order := by omega
+      let k := j.order - r.val
+      have hrk : r.val + k = j.order := Nat.add_sub_of_le r.isLt.le
+      refine ⟨j.matrix ^ k *ᵥ (-v - w), ⟨k, hk⟩, ?_⟩
+      apply inv_eq_of_mul_eq_one_right
+      rw [affineNormalForm_mul, Matrix.mulVec_mulVec, ← pow_add, hrk, j.matrix_pow_order,
+        Matrix.one_mulVec]
+      have hw : w + (-v - w) = -v := by abel
+      rw [hw, affineNormalForm, affineGenerator_pow_order j v hv, integerTranslation_neg,
+        inv_mul_cancel]
+
+private def Elliptic.affineDeckSubgroup (j : Kind) (v : Lattice) : Subgroup AffineAutomorphism :=
+  Subgroup.closure (Set.range integerTranslation ∪ {affineGenerator j v})
+
+private theorem Elliptic.integerTranslation_mem_affineDeckSubgroup (j : Kind) (v w : Lattice) :
+    integerTranslation w ∈ affineDeckSubgroup j v :=
+  Subgroup.subset_closure (Or.inl (Set.mem_range_self w))
+
+private theorem Elliptic.affineGenerator_mem_affineDeckSubgroup (j : Kind) (v : Lattice) :
+    affineGenerator j v ∈ affineDeckSubgroup j v :=
+  Subgroup.subset_closure (Or.inr rfl)
+
+private theorem
+    Elliptic.affineNormalForm_mem_affineDeckSubgroup (j : Kind) (v w : Lattice) (r : ℕ) :
+    affineNormalForm j v w r ∈ affineDeckSubgroup j v :=
+  (affineDeckSubgroup j v).mul_mem (integerTranslation_mem_affineDeckSubgroup j v w)
+    ((affineDeckSubgroup j v).pow_mem (affineGenerator_mem_affineDeckSubgroup j v) r)
+
+private theorem Elliptic.affineDeckSubgroup_eq_normalForms (j : Kind) (v : Lattice)
+    (hv : j.matrix *ᵥ v = v) : affineDeckSubgroup j v = affineNormalFormsSubgroup j v hv := by
+  apply le_antisymm
+  · apply (Subgroup.closure_le _).mpr
+    intro g hg
+    rcases hg with ⟨w, rfl⟩ | rfl
+    · exact ⟨w, ⟨0, j.order_pos⟩, by simp [affineNormalForm]⟩
+    · have hm : 1 < j.order := by cases j <;> decide
+      exact ⟨0, ⟨1, hm⟩, by simp [affineNormalForm]⟩
+  · rintro g ⟨w, r, rfl⟩
+    exact affineNormalForm_mem_affineDeckSubgroup j v w r.val
+
+private theorem
+    Elliptic.mem_affineDeckSubgroup_iff (j : Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (g : AffineAutomorphism) :
+    g ∈ affineDeckSubgroup j v ↔
+      ∃ w : Lattice, ∃ r : Fin j.order, g = affineNormalForm j v w r.val := by
+  rw [affineDeckSubgroup_eq_normalForms j v hv]
+  rfl
+
+private abbrev Elliptic.AffineDeckGroup (j : Kind) (v : Lattice) :=
+  affineDeckSubgroup j v
+
+private def Elliptic.deckTranslationHom (j : Kind) (v : Lattice) :
+    Multiplicative Lattice →* AffineDeckGroup j v :=
+  integerTranslationHom.codRestrict (affineDeckSubgroup j v)
+    (fun w => integerTranslation_mem_affineDeckSubgroup j v w.toAdd)
+
+private def Elliptic.deckGenerator (j : Kind) (v : Lattice) : AffineDeckGroup j v :=
+  ⟨affineGenerator j v, affineGenerator_mem_affineDeckSubgroup j v⟩
+
+private def Elliptic.deckNormalForm (j : Kind) (v : Lattice) (a : Lattice × Fin j.order) :
+    AffineDeckGroup j v :=
+  deckTranslationHom j v (Multiplicative.ofAdd a.1) * deckGenerator j v ^ a.2.val
+
+private theorem
+    Elliptic.deckNormalForm_surjective (j : Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    Function.Surjective (deckNormalForm j v) := by
+  intro g
+  obtain ⟨w, r, hr⟩ := (mem_affineDeckSubgroup_iff j v hv g).mp g.property
+  exact ⟨(w, r), Subtype.ext hr.symm⟩
+
+private theorem Elliptic.deckGenerator_pow_order (j : Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v) :
+    deckGenerator j v ^ j.order = deckTranslationHom j v (Multiplicative.ofAdd v) :=
+  Subtype.ext (affineGenerator_pow_order j v hv)
+
+private instance Elliptic.affineDeckGroupMulAction (j : Kind) (v : Lattice) :
+    MulAction (AffineDeckGroup j v) RealPlane₄
+    where
+  smul g x := (g : AffineAutomorphism) x
+  one_smul _ := rfl
+  mul_smul _ _ _ := rfl
+
+private instance Elliptic.affineDeckGroupContinuousConstSMul (j : Kind) (v : Lattice) :
+    ContinuousConstSMul (AffineDeckGroup j v) RealPlane₄ where
+  continuous_const_smul g := affineAutomorphism_continuous g.val
+
+private theorem Elliptic.affineDeckGroup_eval_injective (j : Kind) (v : Lattice)
+    (hv : AdmissibleTwist j v) (x : RealPlane₄) :
+    Function.Injective (fun g : AffineDeckGroup j v => g • x) := by
+  intro g h hgh
+  obtain ⟨a, rfl⟩ := deckNormalForm_surjective j v hv.1 g
+  obtain ⟨b, rfl⟩ := deckNormalForm_surjective j v hv.1 h
+  have he : affineNormalForm j v a.1 a.2.val x = affineNormalForm j v b.1 b.2.val x := hgh
+  rw [affineNormalForm_apply, affineNormalForm_apply] at he
+  have hu := affineTranslate_unique j (exampleFixedPeriod j) v hv x a.2 b.2 a.1 b.1 he
+  exact congrArg (deckNormalForm j v) (Prod.ext hu.2 hu.1)
+
+private theorem Elliptic.affineDeckGroup_free (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v) :
+    IsCancelSMul (AffineDeckGroup j v) RealPlane₄ where
+  right_cancel' _ _ x hgh := affineDeckGroup_eval_injective j v hv x hgh
+
+private theorem
+    Elliptic.affineCoverProjection_orbit_iff (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) (x y : RealPlane₄) :
+    affineCoverProjection j p v hv x = affineCoverProjection j p v hv y ↔
+      x ∈ MulAction.orbit (AffineDeckGroup j v) y := by
+  rw [affineCoverProjection_eq_iff_translate]
+  constructor
+  · rintro ⟨r, hr, w, hx⟩
+    refine ⟨deckNormalForm j v (w, ⟨r, hr⟩), ?_⟩
+    change affineNormalForm j v w r y = x
+    rw [affineNormalForm_apply]
+    exact hx.symm
+  · rintro ⟨g, hg⟩
+    obtain ⟨a, rfl⟩ := deckNormalForm_surjective j v hv.1 g
+    refine ⟨a.2.val, a.2.isLt, a.1, ?_⟩
+    have he : affineNormalForm j v a.1 a.2.val y = x := hg
+    exact he.symm.trans (affineNormalForm_apply j v a.1 a.2.val y)
+
+private theorem Elliptic.affineCoverProjection_isQuotientCoveringMap (j : Kind) (p : FixedPeriod j)
+    (v : Lattice) (hv : AdmissibleTwist j v) :
+    IsQuotientCoveringMap (affineCoverProjection j p v hv) (AffineDeckGroup j v) := by
+  let := affineDeckGroup_free j v hv
+  exact
+    quotientCoveringMap_of_localHomeomorph
+      (affineCoverProjection_isCoveringMap j p v hv).isLocalHomeomorph
+      (affineCoverProjection_surjective j p v hv) (affineCoverProjection_orbit_iff j p v hv)
+
+private def
+    Elliptic.surfaceFundamentalGroupDeckOppositeEquiv (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) (y : RealPlane₄) :
+    FundamentalGroup (Surface j p v hv) (affineCoverProjection j p v hv y) ≃*
+      (AffineDeckGroup j v)ᵐᵒᵖ :=
+  (affineCoverProjection_isQuotientCoveringMap j p v hv).fundamentalGroupEquiv ⟨y, rfl⟩
+
+private def Elliptic.surfaceFundamentalGroupDeckEquiv (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) (y : RealPlane₄) :
+    FundamentalGroup (Surface j p v hv) (affineCoverProjection j p v hv y) ≃*
+      AffineDeckGroup j v :=
+  (surfaceFundamentalGroupDeckOppositeEquiv j p v hv y).trans
+    (MulEquiv.inv' (AffineDeckGroup j v)).symm
+
+private theorem Elliptic.surfaceFundamentalGroupDeckEquiv_monodromy (j : Kind) (p : FixedPeriod j)
+    (v : Lattice) (hv : AdmissibleTwist j v) (y : RealPlane₄)
+    (γ : FundamentalGroup (Surface j p v hv) (affineCoverProjection j p v hv y)) :
+    (surfaceFundamentalGroupDeckEquiv j p v hv y γ)⁻¹ • y =
+      ((affineCoverProjection_isQuotientCoveringMap j p v hv).isCoveringMap.monodromy γ ⟨y, rfl⟩ :
+        RealPlane₄) := by
+  let hq := affineCoverProjection_isQuotientCoveringMap j p v hv
+  change ((hq.fundamentalGroupToMulOpposite ⟨y, rfl⟩ γ).unop⁻¹)⁻¹ • y = _
+  rw [inv_inv]
+  exact hq.unop_fundamentalGroupToMulOpposite_smul
+
+private def Elliptic.HigherHomology.periodCover (j : Elliptic.Kind) (p : Elliptic.FixedPeriod j)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    C(p.val.Torus, Elliptic.Surface j p v hv) :=
+  ⟨Elliptic.surfaceProjection j p v hv, Elliptic.surfaceProjection_continuous j p v hv⟩
+
+private def Elliptic.HigherHomology.surfaceMappingTorusHomologyEquiv (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology
+        (Elliptic.Surface j p j.twist (Elliptic.mainTwist_admissible j)) n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (mappingTorusModel j) n :=
+  PeriodTorusHigherHomology.homeomorphHomologyEquiv (surfaceMappingTorusHomeomorph j p) n
+
+private def
+    Elliptic.HigherHomology.surfaceH2Equiv (j : Elliptic.Kind) (p : Elliptic.FixedPeriod j) :
+    SingularMayerVietoris.SingularHomology
+        (Elliptic.Surface j p j.twist (Elliptic.mainTwist_admissible j)) 2 ≃ₗ[ℤ]
+      (Fin 2 → ℤ) :=
+  (surfaceMappingTorusHomologyEquiv j p 2).trans (mappingTorusH2Equiv j)
+
+private def
+    Elliptic.HigherHomology.surfaceH3Equiv (j : Elliptic.Kind) (p : Elliptic.FixedPeriod j) :
+    SingularMayerVietoris.SingularHomology
+        (Elliptic.Surface j p j.twist (Elliptic.mainTwist_admissible j)) 3 ≃ₗ[ℤ]
+      (Fin 2 → ℤ) :=
+  (surfaceMappingTorusHomologyEquiv j p 3).trans (mappingTorusH3Equiv j)
+
+private def
+    Elliptic.HigherHomology.surfaceH4Equiv (j : Elliptic.Kind) (p : Elliptic.FixedPeriod j) :
+    SingularMayerVietoris.SingularHomology
+        (Elliptic.Surface j p j.twist (Elliptic.mainTwist_admissible j)) 4 ≃ₗ[ℤ]
+      ℤ :=
+  (surfaceMappingTorusHomologyEquiv j p 4).trans (mappingTorusH4Equiv j)
+
+private def Elliptic.HigherHomology.ellipticBettiNumber : ℕ → ℕ
+  | 0 => 1
+  | 1 => 2
+  | 2 => 2
+  | 3 => 2
+  | 4 => 1
+  | _ + 5 => 0
+
+private theorem Elliptic.HigherHomology.ellipticBettiNumber_eq_zero_of_lt {n : ℕ} (hn : 4 < n) :
+    ellipticBettiNumber n = 0 := by
+  obtain ⟨k, rfl⟩ : ∃ k, n = k + 5 := ⟨n - 5, by omega⟩
+  rfl
+
+private def Elliptic.HigherHomology.mappingTorusHomologyCoordinates (j : Elliptic.Kind) :
+    (n : ℕ) →
+      SingularMayerVietoris.SingularHomology (mappingTorusModel j) n ≃ₗ[ℤ]
+        (Fin (ellipticBettiNumber n) → ℤ)
+  | 0 => (mappingTorusH0Equiv j).trans (LinearEquiv.funUnique (Fin 1) ℤ ℤ).symm
+  | 1 => mappingTorusH1Equiv j
+  | 2 => mappingTorusH2Equiv j
+  | 3 => mappingTorusH3Equiv j
+  | 4 => (mappingTorusH4Equiv j).trans (LinearEquiv.funUnique (Fin 1) ℤ ℤ).symm
+  | n + 5 =>
+    by
+    have :=
+      threeTorusMappingTorus_homology_subsingleton (fibreTorusHomeomorph j).symm
+        (show 4 < n + 5 by omega)
+    exact LinearEquiv.ofSubsingleton _ (Fin 0 → ℤ)
+
+private def Elliptic.HigherHomology.surfaceHomologyCoordinates (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology
+        (Elliptic.Surface j p j.twist (Elliptic.mainTwist_admissible j)) n ≃ₗ[ℤ]
+      (Fin (ellipticBettiNumber n) → ℤ) :=
+  (surfaceMappingTorusHomologyEquiv j p n).trans (mappingTorusHomologyCoordinates j n)
+
+private abbrev Elliptic.CanonicalBundle.Model :=
+  ComplexPlane₂
+
+
+private theorem
+    Elliptic.fillingRadial_projection_coe (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v)
+    (u : unitInterval) (x : Filling j v hv) :
+    (fillingProjection j v hv (fillingRadial j v hv u x) : ℂ) =
+      (((1 - (u : ℝ) : ℝ) : ℂ) ^ j.order) * (fillingProjection j v hv x : ℂ) := by
+  obtain ⟨y, rfl⟩ := fillingQuotient_surjective j v hv x
+  rw [fillingRadial_fillingQuotient]
+  change
+    ((1 - (u : ℝ)) • (y.1 : ℂ)) ^ j.order =
+      (((1 - (u : ℝ) : ℝ) : ℂ) ^ j.order) * (y.1 : ℂ) ^ j.order
+  rw [Complex.real_smul, mul_pow]
+
+private theorem
+    Elliptic.fillingRadial_projection_norm (j : Kind) (v : Lattice) (hv : AdmissibleTwist j v)
+    (u : unitInterval) (x : Filling j v hv) :
+    ‖(fillingProjection j v hv (fillingRadial j v hv u x) : ℂ)‖ =
+      (1 - (u : ℝ)) ^ j.order * ‖(fillingProjection j v hv x : ℂ)‖ := by
+  rw [fillingRadial_projection_coe, norm_mul, norm_pow, Complex.norm_real, Real.norm_eq_abs,
+    abs_of_nonneg (sub_nonneg.mpr u.property.2)]
+
+private theorem Elliptic.fillingRadial_projection_norm_le (j : Kind) (v : Lattice)
+    (hv : AdmissibleTwist j v) (u : unitInterval) (x : Filling j v hv) :
+    ‖(fillingProjection j v hv (fillingRadial j v hv u x) : ℂ)‖ ≤
+      ‖(fillingProjection j v hv x : ℂ)‖ := by
+  rw [fillingRadial_projection_norm]
+  exact
+    mul_le_of_le_one_left (norm_nonneg _)
+      (pow_le_one₀ (sub_nonneg.mpr u.property.2) (by linarith [u.property.1]))
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Elliptic/Core6.lean b/LeanPool/HopfProblem/Elliptic/Core6.lean
new file mode 100644
index 000000000..4c2f17bf4
--- /dev/null
+++ b/LeanPool/HopfProblem/Elliptic/Core6.lean
@@ -0,0 +1,658 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.PeriodFamily.Core3
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap1
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.Elliptic.Core3
+import all LeanPool.HopfProblem.Elliptic.Core4
+import all LeanPool.HopfProblem.Elliptic.Core5
+import all LeanPool.HopfProblem.PeriodFamily.Core3
+
+/-!
+# Hopf problem: elliptic · core 6
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def
+    Elliptic.LogGauge.logMeridianParameter (j : Elliptic.Kind) (s₀ : ℂ) (t : (unitInterval)) :
+    ℂ :=
+  s₀ - ((t : ℝ) : ℂ) / (j.order : ℂ)
+
+private theorem Elliptic.LogGauge.logMeridianParameter_continuous (j : Elliptic.Kind) (s₀ : ℂ) :
+    Continuous (logMeridianParameter j s₀) := by
+  unfold logMeridianParameter
+  fun_prop
+
+@[simp]
+private theorem Elliptic.LogGauge.logMeridianParameter_zero (j : Elliptic.Kind) (s₀ : ℂ) :
+    logMeridianParameter j s₀ 0 = s₀ := by simp [logMeridianParameter]
+
+@[simp]
+private theorem Elliptic.LogGauge.logMeridianParameter_one (j : Elliptic.Kind) (s₀ : ℂ) :
+    logMeridianParameter j s₀ 1 = s₀ - 1 / (j.order : ℂ) := by simp [logMeridianParameter]
+
+@[simp]
+private theorem Elliptic.LogGauge.logMeridianParameter_im (j : Elliptic.Kind) (s₀ : ℂ)
+    (t : (unitInterval)) : (logMeridianParameter j s₀ t).im = s₀.im := by
+  simp [logMeridianParameter, Complex.div_im]
+
+private theorem Elliptic.LogGauge.logMeridianParameter_exponential_norm (j : Elliptic.Kind) (s₀ : ℂ)
+    (t : (unitInterval)) :
+    ‖CuspUniformization.exponential (logMeridianParameter j s₀ t)‖ =
+      ‖CuspUniformization.exponential s₀‖ := by
+  simp [CuspUniformization.exponential, Complex.norm_exp, Complex.mul_re, Complex.mul_im]
+
+private def Elliptic.LogGauge.logMeridianRoot (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (t : (unitInterval)) : SpecialPeriods.Disc :=
+  ⟨CuspUniformization.exponential (logMeridianParameter j s₀ t),
+    by
+    change Dist.dist (CuspUniformization.exponential (logMeridianParameter j s₀ t)) 0 < 1
+    rw [dist_zero_right]
+    apply SpecialPeriods.TauCusp.exponential_norm_lt_one_of_upperHalfPlane
+    simpa only [logMeridianParameter_im] using hs₀⟩
+
+@[simp]
+private theorem Elliptic.LogGauge.logMeridianRoot_coe (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (t : (unitInterval)) :
+    (logMeridianRoot j s₀ hs₀ t : ℂ) =
+      CuspUniformization.exponential (logMeridianParameter j s₀ t) :=
+  rfl
+
+private theorem Elliptic.LogGauge.logMeridianRoot_continuous (j : Elliptic.Kind) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im) : Continuous (logMeridianRoot j s₀ hs₀) :=
+  (CuspUniformization.exponential_holomorphic.continuous.comp
+        (logMeridianParameter_continuous j s₀)).subtype_mk
+    _
+
+private theorem
+    Elliptic.LogGauge.logMeridianRoot_ne_zero (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (t : (unitInterval)) : (logMeridianRoot j s₀ hs₀ t : ℂ) ≠ 0 :=
+  CuspUniformization.exponential_ne_zero _
+
+private theorem
+    Elliptic.LogGauge.logMeridianRoot_zero (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im) :
+    (logMeridianRoot j s₀ hs₀ 0 : ℂ) = CuspUniformization.exponential s₀ := by simp
+
+@[simp]
+private theorem
+    Elliptic.LogGauge.logMeridianRoot_one (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im) :
+    logMeridianRoot j s₀ hs₀ 1 = Elliptic.familyRotation j (logMeridianRoot j s₀ hs₀ 0) := by
+  apply Subtype.ext
+  rw [familyRotation_val_exponential, logMeridianRoot_zero, logMeridianRoot_coe,
+    logMeridianParameter_one, sub_eq_add_neg, CuspUniformization.exponential_add]
+  exact mul_comm _ _
+
+private theorem
+    Elliptic.LogGauge.logMeridianRoot_norm (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (t : (unitInterval)) :
+    ‖(logMeridianRoot j s₀ hs₀ t : ℂ)‖ = ‖CuspUniformization.exponential s₀‖ :=
+  logMeridianParameter_exponential_norm j s₀ t
+
+private theorem
+    Elliptic.LogGauge.logMeridianRoot_pow_norm (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (n : ℕ) (t : (unitInterval)) :
+    ‖(logMeridianRoot j s₀ hs₀ t : ℂ) ^ n‖ = ‖CuspUniformization.exponential s₀‖ ^ n := by
+  rw [norm_pow, logMeridianRoot_norm]
+
+private def Elliptic.LogGauge.negativeLogFlat {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (z : SpecialPeriods.Disc) (s : ℂ) : RealPlane₄ :=
+  (D.periods.periodEquiv z).symm (-s • periodVector D.periods v z)
+
+private theorem Elliptic.LogGauge.negativeLogFlat_rotation {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (z : SpecialPeriods.Disc) (s : ℂ) :
+    negativeLogFlat D v (Elliptic.familyRotation j z) (s - 1 / (j.order : ℂ)) =
+      Elliptic.flatAffine j v (negativeLogFlat D v z s) := by
+  apply (D.periods.periodEquiv (Elliptic.familyRotation j z)).injective
+  simp only [negativeLogFlat, LinearEquiv.apply_symm_apply, Elliptic.flatAffine, map_add,
+    D.periodEquiv_flatLinear, complexLift_translation, Matrix.mulVec_smul,
+    periodVector_covariance D v hv]
+  rw [← add_smul]
+  congr 1
+  ring
+
+private def
+    Elliptic.LogGauge.logMeridianComplex {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (s₀ : ℂ) (hs₀ : 0 < s₀.im) (t : (unitInterval)) : ComplexPlane₂ :=
+  -logMeridianParameter j s₀ t • periodVector D.periods v (logMeridianRoot j s₀ hs₀ t)
+
+private theorem Elliptic.LogGauge.logMeridianComplex_continuous {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (s₀ : ℂ) (hs₀ : 0 < s₀.im) :
+    Continuous (logMeridianComplex D v s₀ hs₀) :=
+  (logMeridianParameter_continuous j s₀).neg.smul
+    ((periodVector_holomorphic D.periods v).continuous.comp (logMeridianRoot_continuous j s₀ hs₀))
+
+private def Elliptic.LogGauge.logMeridianFlat {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (s₀ : ℂ) (hs₀ : 0 < s₀.im) (t : (unitInterval)) : RealPlane₄ :=
+  negativeLogFlat D v (logMeridianRoot j s₀ hs₀ t) (logMeridianParameter j s₀ t)
+
+private theorem Elliptic.LogGauge.logMeridianFlat_continuous {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (s₀ : ℂ) (hs₀ : 0 < s₀.im) :
+    Continuous (logMeridianFlat D v s₀ hs₀) := by
+  change
+    Continuous
+      ((fun q : SpecialPeriods.Disc × ComplexPlane₂ => (D.periods.periodEquiv q.1).symm q.2) ∘
+        (fun t : (unitInterval) => (logMeridianRoot j s₀ hs₀ t, logMeridianComplex D v s₀ hs₀ t)))
+  apply D.periods.continuous_periodEquiv_symm.comp
+  exact (logMeridianRoot_continuous j s₀ hs₀).prodMk (logMeridianComplex_continuous D v s₀ hs₀)
+
+private theorem Elliptic.LogGauge.logMeridianFlat_one {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im) :
+    logMeridianFlat D v s₀ hs₀ 1 = Elliptic.flatAffine j v (logMeridianFlat D v s₀ hs₀ 0) := by
+  simp only [logMeridianFlat, logMeridianRoot_one, logMeridianParameter_one,
+    logMeridianParameter_zero]
+  exact negativeLogFlat_rotation D v hv _ _
+
+private def
+    Elliptic.LogGauge.logMeridianFlatPath {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : j.matrix *ᵥ v = v) (s₀ : ℂ) (hs₀ : 0 < s₀.im) :
+    Path (logMeridianFlat D v s₀ hs₀ 0) (Elliptic.flatAffine j v (logMeridianFlat D v s₀ hs₀ 0))
+    where
+  toFun := logMeridianFlat D v s₀ hs₀
+  continuous_toFun := logMeridianFlat_continuous D v s₀ hs₀
+  source' := rfl
+  target' := logMeridianFlat_one D v hv s₀ hs₀
+
+private def
+    Elliptic.LogGauge.logMeridianFamily {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (s₀ : ℂ) (hs₀ : 0 < s₀.im) (t : (unitInterval)) : D.TotalSpace :=
+  (logMeridianRoot j s₀ hs₀ t, standardLattice.mkQ (logMeridianFlat D v s₀ hs₀ t))
+
+private theorem Elliptic.LogGauge.logMeridianFamily_continuous {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (s₀ : ℂ) (hs₀ : 0 < s₀.im) :
+    Continuous (logMeridianFamily D v s₀ hs₀) :=
+  (logMeridianRoot_continuous j s₀ hs₀).prodMk
+    (standardLattice.continuous_mkQ.comp (logMeridianFlat_continuous D v s₀ hs₀))
+
+private theorem Elliptic.LogGauge.logMeridianFamily_one {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im) :
+    logMeridianFamily D v s₀ hs₀ 1 = D.permutation v (logMeridianFamily D v s₀ hs₀ 0) := by
+  simp only [logMeridianFamily, D.permutation_apply, logMeridianRoot_one,
+    logMeridianFlat_one D v hv, Elliptic.flatTorusAffine_mkQ]
+
+private theorem Elliptic.LogGauge.quotient_permutation {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (x : D.TotalSpace) : D.quotient v hv (D.permutation v x) = D.quotient v hv x := by
+  let := D.action v hv.1
+  have hg : Elliptic.CyclicAction.generator j.order • x = D.permutation v x :=
+    Elliptic.familyAction_generator_smul j v hv.1 x
+  rw [← hg]
+  exact D.quotient_smul v hv (Elliptic.CyclicAction.generator j.order) x
+
+private def Elliptic.LogGauge.logMeridianLoop {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (s₀ : ℂ) (hs₀ : 0 < s₀.im) :
+    Path (D.quotient v hv (logMeridianFamily D v s₀ hs₀ 0))
+      (D.quotient v hv (logMeridianFamily D v s₀ hs₀ 0))
+    where
+  toFun t := D.quotient v hv (logMeridianFamily D v s₀ hs₀ t)
+  continuous_toFun := (D.quotient_continuous v hv).comp (logMeridianFamily_continuous D v s₀ hs₀)
+  source' := rfl
+  target' :=
+    (congrArg (D.quotient v hv) (logMeridianFamily_one D v hv.1 s₀ hs₀)).trans
+      (quotient_permutation D v hv _)
+
+private def Elliptic.LogGauge.logMeridianRootStar {j : Elliptic.Kind} (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (t : (unitInterval)) : BaseStar :=
+  ⟨logMeridianRoot j s₀ hs₀ t, logMeridianRoot_ne_zero j s₀ hs₀ t⟩
+
+private theorem Elliptic.LogGauge.logMeridianRootStar_continuous {j : Elliptic.Kind} (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im) : Continuous (logMeridianRootStar (j := j) s₀ hs₀) :=
+  (logMeridianRoot_continuous j s₀ hs₀).subtype_mk _
+
+private def Elliptic.LogGauge.logMeridianComplexPoint {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (t : (unitInterval)) : CoverStar :=
+  ⟨(logMeridianRoot j s₀ hs₀ t, logMeridianComplex D v s₀ hs₀ t),
+    logMeridianRoot_ne_zero j s₀ hs₀ t⟩
+
+private def
+    Elliptic.LogGauge.logMeridianFamilyStar {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (s₀ : ℂ) (hs₀ : 0 < s₀.im) (t : (unitInterval)) : FamilyStar D.periods :=
+  ⟨logMeridianFamily D v s₀ hs₀ t, logMeridianRoot_ne_zero j s₀ hs₀ t⟩
+
+private theorem Elliptic.LogGauge.logMeridianFamilyStar_eq_project {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (t : (unitInterval)) :
+    logMeridianFamilyStar D v s₀ hs₀ t =
+      project D.periods (logMeridianComplexPoint D v s₀ hs₀ t) :=
+  rfl
+
+private theorem Elliptic.LogGauge.gaugeMap_logMeridianFamilyStar {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (t : (unitInterval)) :
+    gaugeMap D.periods v (logMeridianFamilyStar D v s₀ hs₀ t) =
+      zeroSection D.periods (logMeridianRootStar (j := j) s₀ hs₀ t) := by
+  apply Subtype.ext
+  rw [logMeridianFamilyStar_eq_project,
+    gaugeMap_project_of_exponential D.periods v (logMeridianComplexPoint D v s₀ hs₀ t)
+      (logMeridianParameter j s₀ t) rfl]
+  change
+    D.periods.quotientMap
+        (logMeridianRoot j s₀ hs₀ t,
+          logMeridianComplex D v s₀ hs₀ t +
+            logMeridianParameter j s₀ t • periodVector D.periods v (logMeridianRoot j s₀ hs₀ t)) =
+      (logMeridianRoot j s₀ hs₀ t, 0)
+  simp only [logMeridianComplex, neg_smul, neg_add_cancel]
+  change
+    (logMeridianRoot j s₀ hs₀ t, standardLattice.mkQ ((D.periods.periodEquiv _).symm 0)) =
+      (logMeridianRoot j s₀ hs₀ t, 0)
+  simp only [map_zero]
+
+private def Elliptic.LogGauge.logMeridianFillingPoint {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im) (t : (unitInterval)) : FillingStar D v hv :=
+  fillingStarProject D v hv (logMeridianFamilyStar D v s₀ hs₀ t)
+
+private def
+    Elliptic.LogGauge.tautologicalZeroPoint {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (s₀ : ℂ) (hs₀ : 0 < s₀.im) (t : (unitInterval)) : TautologicalStar D :=
+  starProject D 0 (Matrix.mulVec_zero j.matrix)
+    (zeroSection D.periods (logMeridianRootStar (j := j) s₀ hs₀ t))
+
+private theorem Elliptic.LogGauge.fillingToTautological_logMeridian {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im) (t : (unitInterval)) :
+    fillingToTautologicalBiholomorph D v hv (logMeridianFillingPoint D v hv s₀ hs₀ t) =
+      tautologicalZeroPoint D s₀ hs₀ t := by
+  rw [logMeridianFillingPoint, fillingToTautologicalBiholomorph_project,
+    gaugeMap_logMeridianFamilyStar]
+  rfl
+
+private theorem Elliptic.affineCoverProjection_deck (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) (y : RealPlane₄) (g : AffineDeckGroup j v) :
+    affineCoverProjection j p v hv (g • y) = affineCoverProjection j p v hv y :=
+  (affineCoverProjection_orbit_iff j p v hv _ _).mpr ⟨g, rfl⟩
+
+private def Elliptic.affineDeckPathLoop (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) (y : RealPlane₄) (g : AffineDeckGroup j v)
+    (q : Path y (g • y)) :
+    Path (affineCoverProjection j p v hv y) (affineCoverProjection j p v hv y) :=
+  (q.map (affineCoverProjection_continuous j p v hv)).cast rfl
+    (affineCoverProjection_deck j p v hv y g).symm
+
+private theorem Elliptic.affineDeckPathLoop_monodromy (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) (y : RealPlane₄) (g : AffineDeckGroup j v)
+    (q : Path y (g • y)) :
+    (affineCoverProjection_isQuotientCoveringMap j p v hv).isCoveringMap.monodromy
+        (FundamentalGroup.fromPath ⟦affineDeckPathLoop j p v hv y g q⟧) ⟨y, rfl⟩ =
+      ⟨g • y, affineCoverProjection_deck j p v hv y g⟩ := by
+  let hq := affineCoverProjection_isQuotientCoveringMap j p v hv
+  apply hq.isCoveringMap.monodromy_eq_of_map_eq (Path.Homotopic.Quotient.mk q)
+  apply congrArg Path.Homotopic.Quotient.mk
+  ext t
+  rfl
+
+private theorem Elliptic.surfaceFundamentalGroupDeckEquiv_affineDeckPathLoop (j : Kind)
+    (p : FixedPeriod j) (v : Lattice) (hv : AdmissibleTwist j v) (y : RealPlane₄)
+    (g : AffineDeckGroup j v) (q : Path y (g • y)) :
+    surfaceFundamentalGroupDeckEquiv j p v hv y
+        (FundamentalGroup.fromPath ⟦affineDeckPathLoop j p v hv y g q⟧) =
+      g⁻¹ := by
+  apply inv_injective
+  rw [inv_inv]
+  apply affineDeckGroup_eval_injective j v hv y
+  exact
+    (surfaceFundamentalGroupDeckEquiv_monodromy j p v hv y _).trans
+      (congrArg Subtype.val (affineDeckPathLoop_monodromy j p v hv y g q))
+
+private def Elliptic.affineGeneratorPathLoop (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) (y : RealPlane₄) (q : Path y (flatAffine j v y)) :
+    Path (affineCoverProjection j p v hv y) (affineCoverProjection j p v hv y) :=
+  affineDeckPathLoop j p v hv y (deckGenerator j v) q
+
+private theorem Elliptic.surfaceFundamentalGroupDeckEquiv_affineGeneratorPathLoop (j : Kind)
+    (p : FixedPeriod j) (v : Lattice) (hv : AdmissibleTwist j v) (y : RealPlane₄)
+    (q : Path y (flatAffine j v y)) :
+    surfaceFundamentalGroupDeckEquiv j p v hv y
+        (FundamentalGroup.fromPath ⟦affineGeneratorPathLoop j p v hv y q⟧) =
+      (deckGenerator j v)⁻¹ :=
+  surfaceFundamentalGroupDeckEquiv_affineDeckPathLoop j p v hv y (deckGenerator j v) q
+
+private def Elliptic.affineTranslationPath (y : RealPlane₄) (w : Lattice) :
+    Path y (y + realCast w) :=
+  Path.segment y (y + realCast w)
+
+private theorem Elliptic.affineTranslationPath_apply (y : RealPlane₄) (w : Lattice)
+    (t : unitInterval) : affineTranslationPath y w t = y + (t : ℝ) • realCast w := by
+  change AffineMap.lineMap y (y + realCast w) (t : ℝ) = _
+  rw [AffineMap.lineMap_apply_module]
+  module
+
+private theorem Elliptic.deckTranslationHom_smul (j : Kind) (v : Lattice) (y : RealPlane₄)
+    (w : Lattice) : deckTranslationHom j v (Multiplicative.ofAdd w) • y = y + realCast w :=
+  add_comm _ _
+
+private def Elliptic.affineTranslationLoop (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) (y : RealPlane₄) (w : Lattice) :
+    Path (affineCoverProjection j p v hv y) (affineCoverProjection j p v hv y) :=
+  affineDeckPathLoop j p v hv y (deckTranslationHom j v (Multiplicative.ofAdd w))
+    ((affineTranslationPath y w).cast rfl (deckTranslationHom_smul j v y w))
+
+@[simp]
+private theorem Elliptic.affineTranslationLoop_apply (j : Kind) (p : FixedPeriod j) (v : Lattice)
+    (hv : AdmissibleTwist j v) (y : RealPlane₄) (w : Lattice) (t : unitInterval) :
+    affineTranslationLoop j p v hv y w t =
+      affineCoverProjection j p v hv (y + (t : ℝ) • realCast w) := by
+  change affineCoverProjection j p v hv (affineTranslationPath y w t) = _
+  rw [affineTranslationPath_apply]
+
+private theorem Elliptic.surfaceFundamentalGroupDeckEquiv_affineTranslationLoop (j : Kind)
+    (p : FixedPeriod j) (v : Lattice) (hv : AdmissibleTwist j v) (y : RealPlane₄)
+    (w : Lattice) :
+    surfaceFundamentalGroupDeckEquiv j p v hv y
+        (FundamentalGroup.fromPath ⟦affineTranslationLoop j p v hv y w⟧) =
+      deckTranslationHom j v (Multiplicative.ofAdd (-w)) := by
+  change
+    surfaceFundamentalGroupDeckEquiv j p v hv y
+        (FundamentalGroup.fromPath ⟦affineDeckPathLoop j p v hv y _ _⟧) =
+      _
+  rw [surfaceFundamentalGroupDeckEquiv_affineDeckPathLoop]
+  exact (map_inv (deckTranslationHom j v) (Multiplicative.ofAdd w)).symm
+
+private theorem Elliptic.LogGauge.fillingSurfaceRetraction_quotient_flat {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (z : SpecialPeriods.Disc) (x : RealPlane₄) :
+    D.fillingSurfaceRetraction v hv (D.quotient v hv (z, standardLattice.mkQ x)) =
+      Elliptic.affineCoverProjection j D.centralPeriod v hv x := by
+  apply D.centralFibreInclusion_injective v hv
+  have h :=
+    congrArg
+      (fun f : C(D.Space v hv, D.Space v hv) => f (D.quotient v hv (z, standardLattice.mkQ x)))
+      (D.surfaceIntoFilling_comp_retraction v hv)
+  change
+    D.centralFibreInclusion v hv
+        (D.fillingSurfaceRetraction v hv (D.quotient v hv (z, standardLattice.mkQ x))) =
+      D.fillingRadial v hv 1 (D.quotient v hv (z, standardLattice.mkQ x)) at h
+  rw [h, D.fillingRadial_quotient, Elliptic.discRadial_one]
+  change
+    D.quotient v hv (Elliptic.discZero, standardLattice.mkQ x) =
+      D.centralFibreInclusion v hv
+        (Elliptic.surfaceProjection j D.centralPeriod v hv
+          (Elliptic.flatProjection D.centralPeriod.val x))
+  rw [D.centralFibreInclusion_surfaceProjection, D.centralInclusion_flatProjection]
+  rfl
+
+public
+theorem Elliptic.LogGauge.fundamentalGroup_cast_loop {Y : Type*} [TopologicalSpace Y] {a b : Y}
+    (h : a = b) (γ : Path a a) :
+    MulEquiv.cast (M := FundamentalGroup Y) h (FundamentalGroup.fromPath ⟦γ⟧) =
+      FundamentalGroup.fromPath ⟦γ.cast h.symm h.symm⟧ := by
+  cases h
+  rfl
+
+private def
+    Elliptic.LogGauge.retractedFlatLoop {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (z : SpecialPeriods.Disc)
+    (x : RealPlane₄)
+    (γ :
+      Path (D.quotient v hv (z, standardLattice.mkQ x))
+        (D.quotient v hv (z, standardLattice.mkQ x))) :
+    Path (Elliptic.affineCoverProjection j D.centralPeriod v hv x)
+      (Elliptic.affineCoverProjection j D.centralPeriod v hv x) :=
+  (γ.map (D.fillingSurfaceRetraction v hv).continuous).cast
+    (fillingSurfaceRetraction_quotient_flat D v hv z x).symm
+    (fillingSurfaceRetraction_quotient_flat D v hv z x).symm
+
+private def
+    Elliptic.LogGauge.logMeridianSurfaceLoop {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (s₀ : ℂ) (hs₀ : 0 < s₀.im) :
+    Path (Elliptic.affineCoverProjection j D.centralPeriod v hv (logMeridianFlat D v s₀ hs₀ 0))
+      (Elliptic.affineCoverProjection j D.centralPeriod v hv (logMeridianFlat D v s₀ hs₀ 0)) :=
+  retractedFlatLoop D v hv (logMeridianRoot j s₀ hs₀ 0) (logMeridianFlat D v s₀ hs₀ 0)
+    (logMeridianLoop D v hv s₀ hs₀)
+
+@[simp]
+private theorem Elliptic.LogGauge.logMeridianSurfaceLoop_apply {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im) (t : (unitInterval)) :
+    logMeridianSurfaceLoop D v hv s₀ hs₀ t =
+      Elliptic.affineCoverProjection j D.centralPeriod v hv (logMeridianFlat D v s₀ hs₀ t) :=
+  fillingSurfaceRetraction_quotient_flat D v hv (logMeridianRoot j s₀ hs₀ t)
+    (logMeridianFlat D v s₀ hs₀ t)
+
+private theorem
+    Elliptic.LogGauge.logMeridianSurfaceLoop_eq_affineGeneratorPathLoop {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im) :
+    logMeridianSurfaceLoop D v hv s₀ hs₀ =
+      Elliptic.affineGeneratorPathLoop j D.centralPeriod v hv (logMeridianFlat D v s₀ hs₀ 0)
+        (logMeridianFlatPath D v hv.1 s₀ hs₀) := by
+  ext t
+  exact logMeridianSurfaceLoop_apply D v hv s₀ hs₀ t
+
+private theorem Elliptic.LogGauge.surfaceFundamentalGroupDeckEquiv_logMeridian {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im) :
+    Elliptic.surfaceFundamentalGroupDeckEquiv j D.centralPeriod v hv
+        (logMeridianFlat D v s₀ hs₀ 0)
+        (FundamentalGroup.fromPath ⟦logMeridianSurfaceLoop D v hv s₀ hs₀⟧) =
+      (Elliptic.deckGenerator j v)⁻¹ := by
+  rw [logMeridianSurfaceLoop_eq_affineGeneratorPathLoop]
+  exact
+    Elliptic.surfaceFundamentalGroupDeckEquiv_affineGeneratorPathLoop j D.centralPeriod v hv _ _
+
+private theorem Elliptic.LogGauge.standardLattice_mkQ_realCast (w : Lattice) :
+    standardLattice.mkQ (Elliptic.realCast w) = 0 :=
+  (Submodule.Quotient.mk_eq_zero standardLattice).mpr
+    ((Elliptic.standardLattice_mem_iff _).mpr ⟨w, rfl⟩)
+
+private def
+    Elliptic.LogGauge.fibreTranslationFamily {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (z : SpecialPeriods.Disc) (x : RealPlane₄) (w : Lattice) (t : (unitInterval)) :
+    D.TotalSpace :=
+  (z, standardLattice.mkQ (x + (t : ℝ) • Elliptic.realCast w))
+
+private theorem Elliptic.LogGauge.fibreTranslationFamily_continuous {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (z : SpecialPeriods.Disc) (x : RealPlane₄)
+    (w : Lattice) : Continuous (fibreTranslationFamily D z x w) :=
+  continuous_const.prodMk
+    (standardLattice.continuous_mkQ.comp
+      (continuous_const.add (continuous_subtype_val.smul continuous_const)))
+
+@[simp]
+private theorem Elliptic.LogGauge.fibreTranslationFamily_zero {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (z : SpecialPeriods.Disc) (x : RealPlane₄)
+    (w : Lattice) : fibreTranslationFamily D z x w 0 = (z, standardLattice.mkQ x) := by
+  simp [fibreTranslationFamily]
+
+@[simp]
+private theorem Elliptic.LogGauge.fibreTranslationFamily_one {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (z : SpecialPeriods.Disc) (x : RealPlane₄)
+    (w : Lattice) : fibreTranslationFamily D z x w 1 = (z, standardLattice.mkQ x) := by
+  change (z, standardLattice.mkQ (x + (1 : ℝ) • Elliptic.realCast w)) = (z, standardLattice.mkQ x)
+  rw [one_smul, map_add, standardLattice_mkQ_realCast, add_zero]
+
+private theorem Elliptic.LogGauge.periodEquiv_fibreTranslation {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (z : SpecialPeriods.Disc) (x : RealPlane₄)
+    (w : Lattice) (t : (unitInterval)) :
+    D.periods.periodEquiv z (x + (t : ℝ) • Elliptic.realCast w) =
+      D.periods.periodEquiv z x + (t : ℂ) • periodVector D.periods w z := by
+  simp only [map_add, map_smul, periodVector, RCLike.real_smul_eq_coe_smul (K := ℂ)]
+  rfl
+
+private theorem Elliptic.LogGauge.fibreTranslationFamily_complex_formula {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (z : SpecialPeriods.Disc) (x : RealPlane₄)
+    (w : Lattice) (t : (unitInterval)) :
+    fibreTranslationFamily D z x w t =
+      D.periods.quotientMap
+        (z, D.periods.periodEquiv z x + (t : ℂ) • periodVector D.periods w z) := by
+  rw [← periodEquiv_fibreTranslation]
+  change
+    (z, standardLattice.mkQ (x + (t : ℝ) • Elliptic.realCast w)) =
+      (z,
+        standardLattice.mkQ
+          ((D.periods.periodEquiv z).symm
+            (D.periods.periodEquiv z (x + (t : ℝ) • Elliptic.realCast w))))
+  rw [LinearEquiv.symm_apply_apply]
+
+private def
+    Elliptic.LogGauge.fibreTranslationLoop {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (z : SpecialPeriods.Disc)
+    (x : RealPlane₄) (w : Lattice) :
+    Path (D.quotient v hv (z, standardLattice.mkQ x)) (D.quotient v hv (z, standardLattice.mkQ x))
+    where
+  toFun t := D.quotient v hv (fibreTranslationFamily D z x w t)
+  continuous_toFun :=
+    (D.quotient_continuous v hv).comp (fibreTranslationFamily_continuous D z x w)
+  source' := congrArg (D.quotient v hv) (fibreTranslationFamily_zero D z x w)
+  target' := congrArg (D.quotient v hv) (fibreTranslationFamily_one D z x w)
+
+private def Elliptic.LogGauge.fibreTranslationSurfaceLoop {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (z : SpecialPeriods.Disc) (x : RealPlane₄) (w : Lattice) :
+    Path (Elliptic.affineCoverProjection j D.centralPeriod v hv x)
+      (Elliptic.affineCoverProjection j D.centralPeriod v hv x) :=
+  retractedFlatLoop D v hv z x (fibreTranslationLoop D v hv z x w)
+
+private theorem Elliptic.LogGauge.fibreTranslationSurfaceLoop_eq {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (z : SpecialPeriods.Disc) (x : RealPlane₄) (w : Lattice) :
+    fibreTranslationSurfaceLoop D v hv z x w =
+      Elliptic.affineTranslationLoop j D.centralPeriod v hv x w := by
+  ext t
+  change
+    D.fillingSurfaceRetraction v hv
+        (D.quotient v hv (z, standardLattice.mkQ (x + (t : ℝ) • Elliptic.realCast w))) =
+      Elliptic.affineTranslationLoop j D.centralPeriod v hv x w t
+  rw [fillingSurfaceRetraction_quotient_flat, Elliptic.affineTranslationLoop_apply]
+
+private theorem Elliptic.LogGauge.fibreTranslationSurfaceLoop_deck {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (z : SpecialPeriods.Disc) (x : RealPlane₄) (w : Lattice) :
+    Elliptic.surfaceFundamentalGroupDeckEquiv j D.centralPeriod v hv x
+        (FundamentalGroup.fromPath ⟦fibreTranslationSurfaceLoop D v hv z x w⟧) =
+      Elliptic.deckTranslationHom j v (Multiplicative.ofAdd (-w)) := by
+  rw [fibreTranslationSurfaceLoop_eq]
+  exact Elliptic.surfaceFundamentalGroupDeckEquiv_affineTranslationLoop j D.centralPeriod v hv x w
+
+private def Elliptic.LogGauge.fibreTranslationFamilyStar {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (z : BaseStar) (x : RealPlane₄) (w : Lattice)
+    (t : (unitInterval)) : FamilyStar D.periods :=
+  ⟨fibreTranslationFamily D z.1 x w t, z.2⟩
+
+private theorem Elliptic.LogGauge.gaugeMap_fibreTranslationFamilyStar_formula {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (z : BaseStar) (x : RealPlane₄)
+    (w : Lattice) (s : ℂ) (hs : CuspUniformization.exponential s = (z.1 : ℂ))
+    (t : (unitInterval)) :
+    (gaugeMap D.periods v (fibreTranslationFamilyStar D z x w t) : D.TotalSpace) =
+      D.periods.quotientMap
+        (z.1,
+          D.periods.periodEquiv z.1 x + (t : ℂ) • periodVector D.periods w z.1 +
+            s • periodVector D.periods v z.1) := by
+  let a : CoverStar :=
+    ⟨(z.1, D.periods.periodEquiv z.1 x + (t : ℂ) • periodVector D.periods w z.1), z.2⟩
+  have ha : fibreTranslationFamilyStar D z x w t = project D.periods a :=
+    Subtype.ext (fibreTranslationFamily_complex_formula D z.1 x w t)
+  rw [ha]
+  exact gaugeMap_project_of_exponential D.periods v a s hs
+
+private theorem
+    Elliptic.LogGauge.gaugeMap_fibreTranslationFamilyStar_negativeLog {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (z : BaseStar) (w : Lattice) (s : ℂ)
+    (hs : CuspUniformization.exponential s = (z.1 : ℂ)) (t : (unitInterval)) :
+    gaugeMap D.periods v
+        (fibreTranslationFamilyStar D z
+          ((D.periods.periodEquiv z.1).symm (-s • periodVector D.periods v z.1)) w t) =
+      fibreTranslationFamilyStar D z 0 w t := by
+  apply Subtype.ext
+  rw [gaugeMap_fibreTranslationFamilyStar_formula D v z _ w s hs]
+  change D.periods.quotientMap _ = fibreTranslationFamily D z.1 0 w t
+  rw [fibreTranslationFamily_complex_formula]
+  congr 1
+  apply congrArg (fun u : ComplexPlane₂ => (z.1, u))
+  simp only [LinearEquiv.apply_symm_apply, map_zero, zero_add, neg_smul]
+  abel
+
+private def Elliptic.LogGauge.fibreTranslationFillingPoint {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (z : BaseStar) (x : RealPlane₄) (w : Lattice) (t : (unitInterval)) :
+    FillingStar D v hv :=
+  fillingStarProject D v hv (fibreTranslationFamilyStar D z x w t)
+
+private theorem Elliptic.LogGauge.fillingToTautological_fibreTranslation {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (z : BaseStar) (w : Lattice) (s : ℂ) (hs : CuspUniformization.exponential s = (z.1 : ℂ))
+    (t : (unitInterval)) :
+    fillingToTautologicalBiholomorph D v hv
+        (fibreTranslationFillingPoint D v hv z
+          ((D.periods.periodEquiv z.1).symm (-s • periodVector D.periods v z.1)) w t) =
+      starProject D 0 (Matrix.mulVec_zero j.matrix) (fibreTranslationFamilyStar D z 0 w t) := by
+  rw [fibreTranslationFillingPoint, fillingToTautologicalBiholomorph_project,
+    gaugeMap_fibreTranslationFamilyStar_negativeLog D v z w s hs]
+
+private theorem
+    Elliptic.LogGauge.exists_logMeridian_parameters (j : Elliptic.Kind) (r : ℝ) (hr : 0 < r) :
+    ∃ s : ℂ, 0 < s.im ∧ ‖CuspUniformization.exponential s‖ ^ j.order < r := by
+  let a : ℝ := Min.min r 1 / 2
+  have ha0 : 0 < a := half_pos (lt_min hr zero_lt_one)
+  have ha1 : a < 1 := by
+    have h := min_le_right r (1 : ℝ)
+    dsimp only [a]
+    linarith
+  have har : a < r := by
+    have h := min_le_left r (1 : ℝ)
+    dsimp only [a] at ha0 ⊢
+    linarith
+  have hane : (a : ℂ) ≠ 0 := by exact_mod_cast ha0.ne'
+  have hnorm : ‖CuspUniformization.exponential (CuspUniformization.logarithm (a : ℂ))‖ = a := by
+    rw [CuspUniformization.exponential_logarithm hane, Complex.norm_real, Real.norm_eq_abs,
+      abs_of_pos ha0]
+  have hpow : a ^ j.order ≤ a := by
+    obtain ⟨n, hn⟩ := Nat.exists_eq_succ_of_ne_zero j.order_pos.ne'
+    rw [hn, pow_succ]
+    exact (mul_le_mul_of_nonneg_right (pow_le_one₀ ha0.le ha1.le) ha0.le).trans_eq (one_mul a)
+  refine ⟨CuspUniformization.logarithm (a : ℂ), ?_, ?_⟩
+  · exact
+      SpecialPeriods.TauCusp.upperHalfPlane_of_exponential_norm_lt_one (by rw [hnorm]; exact ha1)
+  · rw [hnorm]
+    exact hpow.trans_lt har
+
+private theorem EllipticRetractionTopology.fundamentalGroup_map_bijective {X Y : Type*}
+    [TopologicalSpace X] [TopologicalSpace Y] (e : X ≃ₕ Y) (x : X) :
+    Function.Bijective (FundamentalGroup.map e.toFun x) := by
+  let E := FundamentalGroupoidFunctor.equivOfHomotopyEquiv e
+  exact E.fullyFaithfulFunctor.map_bijective (FundamentalGroupoid.mk x) (FundamentalGroupoid.mk x)
+
+private def EllipticRetractionTopology.fundamentalGroupEquivAt {X Y : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] (e : X ≃ₕ Y) (x : X) :
+    FundamentalGroup X x ≃* FundamentalGroup Y (e x) :=
+  MulEquiv.ofBijective (FundamentalGroup.map e.toFun x) (fundamentalGroup_map_bijective e x)
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Elliptic/Core7.lean b/LeanPool/HopfProblem/Elliptic/Core7.lean
new file mode 100644
index 000000000..15ade5645
--- /dev/null
+++ b/LeanPool/HopfProblem/Elliptic/Core7.lean
@@ -0,0 +1,610 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Pi1.MappingTorusHomology
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology3
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen2
+import all LeanPool.HopfProblem.Elliptic.Core5
+import all LeanPool.HopfProblem.Pi1.MappingTorusHomology
+
+/-!
+# Hopf problem: elliptic · core 7
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def Elliptic.HigherHomology.CoverAlgebra.secondMap {M : Type*} [AddCommGroup M] [Module ℤ M]
+    (L : M →ₗ[ℤ] (Fin 2 → ℤ)) : M →ₗ[ℤ] ℤ :=
+  (LinearMap.proj 1).comp L
+
+private def Elliptic.HigherHomology.fibreIntoPeriodTorus (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) : C(PeriodTorusHigherHomology.ProductTorus 3, p.val.Torus)
+    where
+  toFun x := (splitPeriodTorusHomeomorph j p.val).symm (0, x)
+  continuous_toFun :=
+    (splitPeriodTorusHomeomorph j p.val).symm.continuous.comp
+      (continuous_const.prodMk continuous_id)
+
+private def
+    Elliptic.HigherHomology.fibreIntoSurface (j : Elliptic.Kind) (p : Elliptic.FixedPeriod j) :
+    C(PeriodTorusHigherHomology.ProductTorus 3,
+      Elliptic.Surface j p j.twist (Elliptic.mainTwist_admissible j)) :=
+  (periodCover j p j.twist (Elliptic.mainTwist_admissible j)).comp (fibreIntoPeriodTorus j p)
+
+private theorem Elliptic.HigherHomology.surfaceMappingTorusHomeomorph_comp_fibreIntoSurface
+    (j : Elliptic.Kind) (p : Elliptic.FixedPeriod j) :
+    (surfaceMappingTorusHomeomorph j p :
+            C(Elliptic.Surface j p j.twist (Elliptic.mainTwist_admissible j),
+              mappingTorusModel j)).comp
+        (fibreIntoSurface j p) =
+      MappingTorus.HomologyCover.fibreInclusion (fibreTorusHomeomorph j).symm := by
+  ext x
+  change
+    surfaceMappingTorusHomeomorph j p
+        (Elliptic.surfaceProjection j p j.twist (Elliptic.mainTwist_admissible j)
+          ((splitPeriodTorusHomeomorph j p.val).symm (0, x))) =
+      MappingTorus.mk (fibreTorusHomeomorph j).symm (0, x)
+  simpa only [AddCircle.coe_zero, MulZeroClass.zero_mul] using
+    surfaceMappingTorusHomeomorph_splitPeriodTorus j p (0 : ℝ) x
+
+private theorem Elliptic.HigherHomology.surfaceMappingTorusHomology_fibre_map (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ) :
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv (surfaceMappingTorusHomeomorph j p)
+            n).toLinearMap.comp
+        (SingularMayerVietoris.singularHomologyMap (fibreIntoSurface j p) n) =
+      MappingTorusHomology.fibreHomologyMap (fibreTorusHomeomorph j).symm n := by
+  rw [PeriodTorusHigherHomology.homeomorphHomologyEquiv_toLinearMap, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp,
+    surfaceMappingTorusHomeomorph_comp_fibreIntoSurface]
+
+private theorem Elliptic.HigherHomology.surfaceMappingTorusHomology_fibre (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) n) :
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv (surfaceMappingTorusHomeomorph j p) n
+        (SingularMayerVietoris.singularHomologyMap (fibreIntoSurface j p) n a) =
+      MappingTorusHomology.fibreHomologyMap (fibreTorusHomeomorph j).symm n a :=
+  DFunLike.congr_fun (surfaceMappingTorusHomology_fibre_map j p n) a
+
+private def Elliptic.HigherHomology.mappingTorusProductCover (j : Elliptic.Kind) :
+    C(MappingTorus.Circle × PeriodTorusHigherHomology.ProductTorus 3, mappingTorusModel j) :=
+  (MappingTorusQuotient.mappingTorusHomeomorph j.order (fibreTorusHomeomorph j)
+          (fibreTorusHomeomorph_pow_order j) :
+        C(surfaceProductQuotient j, mappingTorusModel j)).comp
+    ⟨MappingTorusQuotient.project j.order (fibreTorusHomeomorph j)
+        (fibreTorusHomeomorph_pow_order j),
+      MappingTorusQuotient.project_continuous j.order (fibreTorusHomeomorph j)
+        (fibreTorusHomeomorph_pow_order j)⟩
+
+private theorem
+    Elliptic.HigherHomology.surfaceMappingTorusHomeomorph_comp_periodCover (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) :
+    (surfaceMappingTorusHomeomorph j p :
+            C(Elliptic.Surface j p j.twist (Elliptic.mainTwist_admissible j),
+              mappingTorusModel j)).comp
+        (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) =
+      (mappingTorusProductCover j).comp
+        (splitPeriodTorusHomeomorph j p.val :
+          C(p.val.Torus, MappingTorus.Circle × PeriodTorusHigherHomology.ProductTorus 3)) :=
+  rfl
+
+private theorem
+    Elliptic.HigherHomology.surfaceMappingTorusHomology_periodCover_map (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ) :
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv (surfaceMappingTorusHomeomorph j p)
+            n).toLinearMap.comp
+        (SingularMayerVietoris.singularHomologyMap
+          (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) n) =
+      (SingularMayerVietoris.singularHomologyMap (mappingTorusProductCover j) n).comp
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv (splitPeriodTorusHomeomorph j p.val)
+            n).toLinearMap := by
+  rw [PeriodTorusHigherHomology.homeomorphHomologyEquiv_toLinearMap, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp,
+    surfaceMappingTorusHomeomorph_comp_periodCover,
+    PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv_toLinearMap]
+
+private theorem Elliptic.HigherHomology.surfaceMappingTorusHomology_periodCover (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology p.val.Torus n) :
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv (surfaceMappingTorusHomeomorph j p) n
+        (SingularMayerVietoris.singularHomologyMap
+          (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) n a) =
+      SingularMayerVietoris.singularHomologyMap (mappingTorusProductCover j) n
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv (splitPeriodTorusHomeomorph j p.val) n
+          a) :=
+  DFunLike.congr_fun (surfaceMappingTorusHomology_periodCover_map j p n) a
+
+private theorem Elliptic.HigherHomology.surfaceH2Equiv_fibre (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 2) :
+    surfaceH2Equiv j p (SingularMayerVietoris.singularHomologyMap (fibreIntoSurface j p) 2 a) =
+      ![torusH2Coordinates a 0, 0] := by
+  change
+    mappingTorusH2Equiv j
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv (surfaceMappingTorusHomeomorph j p) 2
+          (SingularMayerVietoris.singularHomologyMap (fibreIntoSurface j p) 2 a)) =
+      _
+  rw [surfaceMappingTorusHomology_fibre, mappingTorusH2Equiv_fibre]
+
+private theorem Elliptic.HigherHomology.surfaceH3Equiv_fibre (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3) :
+    surfaceH3Equiv j p (SingularMayerVietoris.singularHomologyMap (fibreIntoSurface j p) 3 a) =
+      ![torusH3Coordinates a, 0] := by
+  change
+    mappingTorusH3Equiv j
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv (surfaceMappingTorusHomeomorph j p) 3
+          (SingularMayerVietoris.singularHomologyMap (fibreIntoSurface j p) 3 a)) =
+      _
+  rw [surfaceMappingTorusHomology_fibre, mappingTorusH3Equiv_fibre]
+
+private theorem Elliptic.HigherHomology.surfaceH2Equiv_periodCover_fibre (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 2) :
+    surfaceH2Equiv j p
+        (SingularMayerVietoris.singularHomologyMap
+          (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) 2
+          (SingularMayerVietoris.singularHomologyMap (fibreIntoPeriodTorus j p) 2 a)) =
+      ![torusH2Coordinates a 0, 0] := by
+  change
+    surfaceH2Equiv j p
+        (((SingularMayerVietoris.singularHomologyMap
+                (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) 2).comp
+            (SingularMayerVietoris.singularHomologyMap (fibreIntoPeriodTorus j p) 2))
+          a) =
+      _
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp]
+  exact surfaceH2Equiv_fibre j p a
+
+private theorem Elliptic.HigherHomology.surfaceH3Equiv_periodCover_fibre (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3) :
+    surfaceH3Equiv j p
+        (SingularMayerVietoris.singularHomologyMap
+          (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) 3
+          (SingularMayerVietoris.singularHomologyMap (fibreIntoPeriodTorus j p) 3 a)) =
+      ![torusH3Coordinates a, 0] := by
+  change
+    surfaceH3Equiv j p
+        (((SingularMayerVietoris.singularHomologyMap
+                (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) 3).comp
+            (SingularMayerVietoris.singularHomologyMap (fibreIntoPeriodTorus j p) 3))
+          a) =
+      _
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp]
+  exact surfaceH3Equiv_fibre j p a
+
+private def Elliptic.HigherHomology.surfacePeriodCoverH2Coordinates (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) :
+    SingularMayerVietoris.SingularHomology p.val.Torus 2 →ₗ[ℤ] (Fin 2 → ℤ) :=
+  (surfaceH2Equiv j p).toLinearMap.comp
+    (SingularMayerVietoris.singularHomologyMap
+      (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) 2)
+
+private def Elliptic.HigherHomology.surfacePeriodCoverH3Coordinates (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) :
+    SingularMayerVietoris.SingularHomology p.val.Torus 3 →ₗ[ℤ] (Fin 2 → ℤ) :=
+  (surfaceH3Equiv j p).toLinearMap.comp
+    (SingularMayerVietoris.singularHomologyMap
+      (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) 3)
+
+private def Elliptic.HigherHomology.surfacePeriodCoverH4Coordinates (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) : SingularMayerVietoris.SingularHomology p.val.Torus 4 →ₗ[ℤ] ℤ :=
+  (surfaceH4Equiv j p).toLinearMap.comp
+    (SingularMayerVietoris.singularHomologyMap
+      (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) 4)
+
+/-- The index contributed by the norm map for each elliptic fibre type. -/
+public
+def Elliptic.HigherHomology.fibreNormIndex : Elliptic.Kind → ℕ
+  | .three => 1
+  | .four => 2
+
+@[simp]
+private theorem Elliptic.HigherHomology.fibreNormIndex_three : fibreNormIndex .three = 1 :=
+  rfl
+
+@[simp]
+private theorem Elliptic.HigherHomology.fibreNormIndex_four : fibreNormIndex .four = 2 :=
+  rfl
+
+private theorem
+    Elliptic.HigherHomology.fibreNormIndex_pos (j : Elliptic.Kind) : 0 < fibreNormIndex j := by
+  cases j <;> decide
+
+public
+theorem Elliptic.HigherHomology.fibreNormIndex_int_ne_zero (j : Elliptic.Kind) :
+    (fibreNormIndex j : ℤ) ≠ 0 := by exact_mod_cast (fibreNormIndex_pos j).ne'
+
+private def Elliptic.HigherHomology.fibreNormMatrix (j : Elliptic.Kind) : FibreMatrix :=
+  ∑ k ∈ Finset.range j.order, (fibreMatrix j) ^ k
+
+private def Elliptic.HigherHomology.fibreSquareNormMatrix (j : Elliptic.Kind) : FibreMatrix :=
+  ∑ k ∈ Finset.range j.order, (fibreSquareMatrix j) ^ k
+
+@[simp]
+private theorem Elliptic.HigherHomology.fibreNormMatrix_three :
+    fibreNormMatrix .three = !![0, 0, 0; 0, 0, 0; 2, 1, 3] := by decide
+
+@[simp]
+private theorem Elliptic.HigherHomology.fibreNormMatrix_four :
+    fibreNormMatrix .four = !![0, 0, 0; 0, 0, 0; 2, 2, 4] := by decide
+
+@[simp]
+private theorem Elliptic.HigherHomology.fibreSquareNormMatrix_three :
+    fibreSquareNormMatrix .three = !![3, 0, 0; -1, 0, 0; 2, 0, 0] := by decide
+
+@[simp]
+private theorem Elliptic.HigherHomology.fibreSquareNormMatrix_four :
+    fibreSquareNormMatrix .four = !![4, 0, 0; -2, 0, 0; 2, 0, 0] := by decide
+
+private def
+    Elliptic.HigherHomology.fibreNorm (j : Elliptic.Kind) : FibreLattice →ₗ[ℤ] FibreLattice :=
+  (fibreNormMatrix j).mulVecLin
+
+private theorem Elliptic.HigherHomology.fibreNorm_apply (j : Elliptic.Kind) (v : FibreLattice) :
+    fibreNorm j v =
+      ((fibreNormIndex j : ℤ) * fibreCoinvariantCoordinate j v) • fibreKernelVector := by
+  cases j <;> ext i <;> fin_cases i <;>
+    simp [fibreCoinvariantCoordinate, fibreNorm, fibreKernelVector, dotProduct, Fin.sum_univ_succ]
+  all_goals ring
+
+@[simp]
+private theorem Elliptic.HigherHomology.fibreNorm_apply_two (j : Elliptic.Kind) (v : FibreLattice) :
+    fibreNorm j v 2 = (fibreNormIndex j : ℤ) * fibreCoinvariantCoordinate j v := by
+  rw [fibreNorm_apply]
+  simp [fibreKernelVector]
+
+private def Elliptic.HigherHomology.fibreSquareNorm (j : Elliptic.Kind) :
+    FibreLattice →ₗ[ℤ] FibreLattice :=
+  (fibreSquareNormMatrix j).mulVecLin
+
+@[simp]
+private theorem
+    Elliptic.HigherHomology.fibreSquareNorm_apply (j : Elliptic.Kind) (v : FibreLattice) :
+    fibreSquareNorm j v = ((fibreNormIndex j : ℤ) * v 0) • fibreSquareKernelVector j := by
+  cases j <;> ext i <;> fin_cases i <;>
+    simp [fibreSquareKernelVector, fibreSquareNorm, dotProduct, Fin.sum_univ_succ]
+  all_goals ring
+
+private theorem
+    Elliptic.HigherHomology.fibreSquareNorm_mem_ker (j : Elliptic.Kind) (v : FibreLattice) :
+    fibreSquareNorm j v ∈ LinearMap.ker (fibreSquareDifference j) := by
+  rw [LinearMap.mem_ker, fibreSquareNorm_apply, map_smul, fibreSquareDifference_kernelVector,
+    smul_zero]
+
+private def Elliptic.HigherHomology.fibreSquareNormToKernel (j : Elliptic.Kind) :
+    FibreLattice →ₗ[ℤ] LinearMap.ker (fibreSquareDifference j) :=
+  (fibreSquareNorm j).codRestrict _ (fibreSquareNorm_mem_ker j)
+
+private def Elliptic.HigherHomology.fibreSquareNormCoordinate (j : Elliptic.Kind) :
+    FibreLattice →ₗ[ℤ] ℤ :=
+  (fibreSquareKernelEquivInt j).toLinearMap.comp (fibreSquareNormToKernel j)
+
+private theorem Elliptic.HigherHomology.fibreSquareNormCoordinate_eq_neg_second (j : Elliptic.Kind)
+    (v : FibreLattice) : fibreSquareNormCoordinate j v = -(fibreSquareNorm j v) 1 :=
+  rfl
+
+@[simp]
+private theorem Elliptic.HigherHomology.fibreSquareNormCoordinate_apply (j : Elliptic.Kind)
+    (v : FibreLattice) : fibreSquareNormCoordinate j v = (fibreNormIndex j : ℤ) * v 0 := by
+  rw [fibreSquareNormCoordinate_eq_neg_second, fibreSquareNorm_apply]
+  simp
+
+private theorem Elliptic.HigherHomology.markedLinearPower {M : Type*} [AddCommGroup M] [Module ℤ M]
+    (e : M ≃ₗ[ℤ] FibreLattice) (f : M →ₗ[ℤ] M) (A : FibreMatrix) (h : ∀ a, e (f a) = A *ᵥ e a)
+    (k : ℕ) (a : M) : e ((f ^ k) a) = A ^ k *ᵥ e a := by
+  induction k generalizing a with
+  | zero => simp only [pow_zero, Module.End.one_apply, Matrix.one_mulVec]
+  | succ k ih => rw [pow_succ, Module.End.mul_apply, ih, h, pow_succ, Matrix.mulVec_mulVec]
+
+private def Elliptic.HigherHomology.fibreHomologyNorm (j : Elliptic.Kind) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) n →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) n :=
+  ∑ k ∈ Finset.range j.order,
+    (MappingTorusHomology.monodromyHomologyMap (fibreTorusHomeomorph j) n) ^ k
+
+private theorem Elliptic.HigherHomology.fibreHomologyMonodromy_one (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 1) :
+    torusH1Equiv (MappingTorusHomology.monodromyHomologyMap (fibreTorusHomeomorph j) 1 a) =
+      fibreMatrix j *ᵥ torusH1Equiv a :=
+  torusH1Equiv_matrix_natural (fibreMatrix j) a
+
+private theorem Elliptic.HigherHomology.fibreHomologyMonodromy_two (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 2) :
+    torusH2Coordinates (MappingTorusHomology.monodromyHomologyMap (fibreTorusHomeomorph j) 2 a) =
+      fibreSquareMatrix j *ᵥ torusH2Coordinates a :=
+  torusH2Coordinates_fibreMatrix j a
+
+private theorem Elliptic.HigherHomology.fibreHomologyMonodromy_three (j : Elliptic.Kind) :
+    MappingTorusHomology.monodromyHomologyMap (fibreTorusHomeomorph j) 3 = 1 := by
+  ext a
+  apply torusH3Coordinates.injective
+  exact torusH3Coordinates_fibreMatrix j a
+
+private theorem Elliptic.HigherHomology.fibreHomologyNorm_one (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 1) :
+    torusH1Equiv (fibreHomologyNorm j 1 a) = fibreNorm j (torusH1Equiv a) := by
+  simp only [fibreHomologyNorm, LinearMap.sum_apply, map_sum, fibreNorm, Matrix.mulVecLin_apply,
+    fibreNormMatrix]
+  apply Finset.sum_congr rfl
+  intro k hk
+  exact markedLinearPower torusH1Equiv _ _ (fibreHomologyMonodromy_one j) k a
+
+private theorem Elliptic.HigherHomology.fibreHomologyNorm_two (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 2) :
+    torusH2Coordinates (fibreHomologyNorm j 2 a) = fibreSquareNorm j (torusH2Coordinates a) := by
+  simp only [fibreHomologyNorm, LinearMap.sum_apply, map_sum, fibreSquareNorm,
+    Matrix.mulVecLin_apply, fibreSquareNormMatrix]
+  apply Finset.sum_congr rfl
+  intro k hk
+  exact markedLinearPower torusH2Coordinates _ _ (fibreHomologyMonodromy_two j) k a
+
+private theorem Elliptic.HigherHomology.fibreHomologyNorm_three (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3) :
+    torusH3Coordinates (fibreHomologyNorm j 3 a) = (j.order : ℤ) * torusH3Coordinates a := by
+  simp [fibreHomologyNorm, fibreHomologyMonodromy_three]
+
+private def Elliptic.HigherHomology.fibreHomologyNormOneCoordinate (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 1 →ₗ[ℤ] ℤ :=
+  (LinearMap.proj (2 : Fin 3)).comp (torusH1Equiv.toLinearMap.comp (fibreHomologyNorm j 1))
+
+private theorem Elliptic.HigherHomology.fibreHomologyNormOneCoordinate_apply (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 1) :
+    fibreHomologyNormOneCoordinate j a =
+      (fibreNormIndex j : ℤ) * fibreCoinvariantCoordinate j (torusH1Equiv a) := by
+  change torusH1Equiv (fibreHomologyNorm j 1 a) 2 = _
+  rw [fibreHomologyNorm_one, fibreNorm_apply_two]
+
+private def Elliptic.HigherHomology.fibreHomologyNormTwoCoordinate (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 2 →ₗ[ℤ] ℤ :=
+  (-LinearMap.proj (1 : Fin 3)).comp (torusH2Coordinates.toLinearMap.comp (fibreHomologyNorm j 2))
+
+private theorem Elliptic.HigherHomology.fibreHomologyNormTwoCoordinate_apply (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 2) :
+    fibreHomologyNormTwoCoordinate j a = (fibreNormIndex j : ℤ) * torusH2Coordinates a 0 := by
+  change -(torusH2Coordinates (fibreHomologyNorm j 2 a) 1) = _
+  rw [fibreHomologyNorm_two]
+  exact fibreSquareNormCoordinate_apply j (torusH2Coordinates a)
+
+private def Elliptic.HigherHomology.fibreHomologyNormThreeCoordinate (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3 →ₗ[ℤ] ℤ :=
+  torusH3Coordinates.toLinearMap.comp (fibreHomologyNorm j 3)
+
+private theorem Elliptic.HigherHomology.fibreHomologyNormThreeCoordinate_apply (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3) :
+    fibreHomologyNormThreeCoordinate j a = (j.order : ℤ) * torusH3Coordinates a :=
+  fibreHomologyNorm_three j a
+
+@[simp]
+private theorem
+    Elliptic.HigherHomology.mappingTorusProductCover_eq_productCover (j : Elliptic.Kind) :
+    mappingTorusProductCover j =
+      MappingTorusHomology.Covering.productCover j.order (fibreTorusHomeomorph j)
+        (fibreTorusHomeomorph_pow_order j) :=
+  rfl
+
+private theorem
+    Elliptic.HigherHomology.fibreHomologyNorm_eq_homologyNorm (j : Elliptic.Kind) (n : ℕ) :
+    fibreHomologyNorm j n =
+      MappingTorusHomology.Covering.homologyNorm j.order (fibreTorusHomeomorph j) n :=
+  (MappingTorusHomology.Covering.homologyNorm_eq_sum_powers j.order (fibreTorusHomeomorph j)
+      n).symm
+
+private def Elliptic.HigherHomology.surfacePeriodCoverCircleBoundary (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology p.val.Torus (n + 1) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) n :=
+  (PeriodTorusHigherHomology.circleBoundary (PeriodTorusHigherHomology.ProductTorus 3) n).comp
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv (splitPeriodTorusHomeomorph j p.val)
+        (n + 1)).toLinearMap
+
+@[simp]
+private theorem Elliptic.HigherHomology.surfacePeriodCoverCircleBoundary_apply (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology p.val.Torus (n + 1)) :
+    surfacePeriodCoverCircleBoundary j p n a =
+      PeriodTorusHigherHomology.circleBoundary (PeriodTorusHigherHomology.ProductTorus 3) n
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv (splitPeriodTorusHomeomorph j p.val)
+          (n + 1) a) :=
+  rfl
+
+private theorem Elliptic.HigherHomology.surfacePeriodCover_wangBoundary (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology p.val.Torus (n + 1)) :
+    MappingTorusHomology.wangBoundary (fibreTorusHomeomorph j).symm n
+        (surfaceMappingTorusHomologyEquiv j p (n + 1)
+          (SingularMayerVietoris.singularHomologyMap
+            (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) (n + 1) a)) =
+      fibreHomologyNorm j n (surfacePeriodCoverCircleBoundary j p n a) := by
+  change
+    MappingTorusHomology.wangBoundary (fibreTorusHomeomorph j).symm n
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv (surfaceMappingTorusHomeomorph j p)
+          (n + 1)
+          (SingularMayerVietoris.singularHomologyMap
+            (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) (n + 1) a)) =
+      _
+  rw [surfaceMappingTorusHomology_periodCover, mappingTorusProductCover_eq_productCover]
+  change
+    MappingTorusHomology.wangBoundary (fibreTorusHomeomorph j).symm n
+        (MappingTorusHomology.Covering.productCoverHomology j.order (fibreTorusHomeomorph j)
+          (fibreTorusHomeomorph_pow_order j) (n + 1)
+          (PeriodTorusHigherHomology.homeomorphHomologyEquiv (splitPeriodTorusHomeomorph j p.val)
+            (n + 1) a)) =
+      _
+  rw [MappingTorusHomology.Covering.wangBoundary_productCover_apply, ←
+    fibreHomologyNorm_eq_homologyNorm]
+  rfl
+
+private theorem
+    Elliptic.HigherHomology.surfacePeriodCoverH2Coordinates_secondMap (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) :
+    CoverAlgebra.secondMap (surfacePeriodCoverH2Coordinates j p) =
+      (fibreHomologyNormOneCoordinate j).comp (surfacePeriodCoverCircleBoundary j p 1) := by
+  ext a
+  change
+    mappingTorusH2Equiv j
+        (surfaceMappingTorusHomologyEquiv j p 2
+          (SingularMayerVietoris.singularHomologyMap
+            (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) 2 a))
+        1 =
+      _
+  rw [mappingTorusH2Equiv_boundary, surfacePeriodCover_wangBoundary]
+  rfl
+
+private theorem
+    Elliptic.HigherHomology.surfacePeriodCoverH3Coordinates_secondMap (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) :
+    CoverAlgebra.secondMap (surfacePeriodCoverH3Coordinates j p) =
+      (fibreHomologyNormTwoCoordinate j).comp (surfacePeriodCoverCircleBoundary j p 2) := by
+  ext a
+  change
+    mappingTorusH3Equiv j
+        (surfaceMappingTorusHomologyEquiv j p 3
+          (SingularMayerVietoris.singularHomologyMap
+            (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) 3 a))
+        1 =
+      _
+  rw [mappingTorusH3Equiv_boundary, surfacePeriodCover_wangBoundary]
+  rfl
+
+private theorem Elliptic.HigherHomology.surfacePeriodCoverH4Coordinates_eq_norm (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) :
+    surfacePeriodCoverH4Coordinates j p =
+      (fibreHomologyNormThreeCoordinate j).comp (surfacePeriodCoverCircleBoundary j p 3) := by
+  ext a
+  change
+    mappingTorusH4Equiv j
+        (surfaceMappingTorusHomologyEquiv j p 4
+          (SingularMayerVietoris.singularHomologyMap
+            (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) 4 a)) =
+      torusH3Coordinates (fibreHomologyNorm j 3 (surfacePeriodCoverCircleBoundary j p 3 a))
+  rw [mappingTorusH4Equiv_boundary, surfacePeriodCover_wangBoundary]
+
+private theorem Elliptic.HigherHomology.surfacePeriodCoverH4Coordinates_apply (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (a : SingularMayerVietoris.SingularHomology p.val.Torus 4) :
+    surfacePeriodCoverH4Coordinates j p a =
+      (j.order : ℤ) * torusH3Coordinates (surfacePeriodCoverCircleBoundary j p 3 a) := by
+  rw [surfacePeriodCoverH4Coordinates_eq_norm, LinearMap.comp_apply,
+    fibreHomologyNormThreeCoordinate_apply]
+
+
+private def
+    Elliptic.HigherHomology.surfaceH1Equiv (j : Elliptic.Kind) (p : Elliptic.FixedPeriod j) :
+    SingularMayerVietoris.SingularHomology
+        (Elliptic.Surface j p j.twist (Elliptic.mainTwist_admissible j)) 1 ≃ₗ[ℤ]
+      (Fin 2 → ℤ) :=
+  (surfaceMappingTorusHomologyEquiv j p 1).trans (mappingTorusH1Equiv j)
+
+private theorem Elliptic.HigherHomology.surfaceH1Equiv_fibre (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 1) :
+    surfaceH1Equiv j p (SingularMayerVietoris.singularHomologyMap (fibreIntoSurface j p) 1 a) =
+      ![fibreCoinvariantCoordinate j (torusH1Equiv a), 0] := by
+  change
+    mappingTorusH1Equiv j
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv (surfaceMappingTorusHomeomorph j p) 1
+          (SingularMayerVietoris.singularHomologyMap (fibreIntoSurface j p) 1 a)) =
+      _
+  rw [surfaceMappingTorusHomology_fibre, mappingTorusH1Equiv_fibre]
+
+private theorem Elliptic.HigherHomology.surfaceH1Equiv_periodCover_fibre (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 1) :
+    surfaceH1Equiv j p
+        (SingularMayerVietoris.singularHomologyMap
+          (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) 1
+          (SingularMayerVietoris.singularHomologyMap (fibreIntoPeriodTorus j p) 1 a)) =
+      ![fibreCoinvariantCoordinate j (torusH1Equiv a), 0] := by
+  change
+    surfaceH1Equiv j p
+        (((SingularMayerVietoris.singularHomologyMap
+                (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) 1).comp
+            (SingularMayerVietoris.singularHomologyMap (fibreIntoPeriodTorus j p) 1))
+          a) =
+      _
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp]
+  exact surfaceH1Equiv_fibre j p a
+
+private theorem Elliptic.HigherHomology.fibreHomologyMonodromy_zero (j : Elliptic.Kind) :
+    MappingTorusHomology.monodromyHomologyMap (fibreTorusHomeomorph j) 0 = 1 := by
+  ext a
+  apply torusH0Coordinates.injective
+  exact
+    PeriodTorusHigherHomology.connectedHomologyZeroEquiv_natural
+      (fibreTorusHomeomorph j :
+        C(PeriodTorusHigherHomology.ProductTorus 3, PeriodTorusHigherHomology.ProductTorus 3))
+      a
+
+private theorem Elliptic.HigherHomology.fibreHomologyNorm_zero (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 0) :
+    torusH0Coordinates (fibreHomologyNorm j 0 a) = (j.order : ℤ) * torusH0Coordinates a := by
+  simp [fibreHomologyNorm, fibreHomologyMonodromy_zero]
+
+private def Elliptic.HigherHomology.fibreHomologyNormZeroCoordinate (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 0 →ₗ[ℤ] ℤ :=
+  torusH0Coordinates.toLinearMap.comp (fibreHomologyNorm j 0)
+
+private theorem Elliptic.HigherHomology.fibreHomologyNormZeroCoordinate_apply (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 0) :
+    fibreHomologyNormZeroCoordinate j a = (j.order : ℤ) * torusH0Coordinates a :=
+  fibreHomologyNorm_zero j a
+
+private def Elliptic.HigherHomology.surfacePeriodCoverH1Coordinates (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) :
+    SingularMayerVietoris.SingularHomology p.val.Torus 1 →ₗ[ℤ] (Fin 2 → ℤ) :=
+  (surfaceH1Equiv j p).toLinearMap.comp
+    (SingularMayerVietoris.singularHomologyMap
+      (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) 1)
+
+private theorem
+    Elliptic.HigherHomology.surfacePeriodCoverH1Coordinates_secondMap (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) :
+    CoverAlgebra.secondMap (surfacePeriodCoverH1Coordinates j p) =
+      (fibreHomologyNormZeroCoordinate j).comp (surfacePeriodCoverCircleBoundary j p 0) := by
+  ext a
+  change
+    mappingTorusH1Equiv j
+        (surfaceMappingTorusHomologyEquiv j p 1
+          (SingularMayerVietoris.singularHomologyMap
+            (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) 1 a))
+        1 =
+      _
+  rw [mappingTorusH1Equiv_boundary, surfacePeriodCover_wangBoundary]
+  rfl
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Elliptic/Core8.lean b/LeanPool/HopfProblem/Elliptic/Core8.lean
new file mode 100644
index 000000000..22ba061c8
--- /dev/null
+++ b/LeanPool/HopfProblem/Elliptic/Core8.lean
@@ -0,0 +1,959 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Threefold.SpecialPeriods11
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology3
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen2
+import all LeanPool.HopfProblem.Elliptic.Core5
+import all LeanPool.HopfProblem.Elliptic.Core7
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods11
+
+/-!
+# Hopf problem: elliptic · core 8
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def Elliptic.HigherHomology.periodAffineHomeomorph (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) : p.val.Torus ≃ₜ p.val.Torus :=
+  (Elliptic.affineBiholomorph j p j.twist).toHomeomorph
+
+private def Elliptic.HigherHomology.periodCircleHomologyEquiv (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology p.val.Torus (n + 1) ≃ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) (n + 1) ×
+        SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) n) :=
+  (PeriodTorusHigherHomology.homeomorphHomologyEquiv (splitPeriodTorusHomeomorph j p.val)
+        (n + 1)).trans
+    (PeriodTorusHigherHomology.circleProductHomologyEquiv
+      (PeriodTorusHigherHomology.ProductTorus 3) n)
+
+private theorem Elliptic.HigherHomology.splitPeriodTorusHomeomorph_comp_fibreIntoPeriodTorus
+    (j : Elliptic.Kind) (p : Elliptic.FixedPeriod j) :
+    (splitPeriodTorusHomeomorph j p.val :
+            C(p.val.Torus,
+              (PeriodTorusHigherHomology.CircleTopology.Circle) ×
+                PeriodTorusHigherHomology.ProductTorus 3)).comp
+        (fibreIntoPeriodTorus j p) =
+      PeriodTorusHigherHomology.CircleTopology.productSection
+        (PeriodTorusHigherHomology.ProductTorus 3) := by
+  apply ContinuousMap.ext
+  intro x
+  change
+    splitPeriodTorusHomeomorph j p.val ((splitPeriodTorusHomeomorph j p.val).symm (0, x)) = (0, x)
+  exact (splitPeriodTorusHomeomorph j p.val).apply_symm_apply (0, x)
+
+private theorem Elliptic.HigherHomology.splitPeriodTorusHomology_fibre_map (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ) :
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv (splitPeriodTorusHomeomorph j p.val)
+            n).toLinearMap.comp
+        (SingularMayerVietoris.singularHomologyMap (fibreIntoPeriodTorus j p) n) =
+      PeriodTorusHigherHomology.circleSectionHomology (PeriodTorusHigherHomology.ProductTorus 3)
+        n := by
+  rw [PeriodTorusHigherHomology.homeomorphHomologyEquiv_toLinearMap, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp,
+    splitPeriodTorusHomeomorph_comp_fibreIntoPeriodTorus]
+
+private theorem Elliptic.HigherHomology.splitPeriodTorusHomology_fibre (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) n) :
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv (splitPeriodTorusHomeomorph j p.val) n
+        (SingularMayerVietoris.singularHomologyMap (fibreIntoPeriodTorus j p) n a) =
+      PeriodTorusHigherHomology.circleSectionHomology (PeriodTorusHigherHomology.ProductTorus 3) n
+        a :=
+  DFunLike.congr_fun (splitPeriodTorusHomology_fibre_map j p n) a
+
+@[simp]
+private theorem Elliptic.HigherHomology.periodCircleHomologyEquiv_fibre (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) (n + 1)) :
+    periodCircleHomologyEquiv j p n
+        (SingularMayerVietoris.singularHomologyMap (fibreIntoPeriodTorus j p) (n + 1) a) =
+      (a, 0) := by
+  change
+    PeriodTorusHigherHomology.circleProductHomologyEquiv
+        (PeriodTorusHigherHomology.ProductTorus 3) n
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv (splitPeriodTorusHomeomorph j p.val)
+          (n + 1)
+          (SingularMayerVietoris.singularHomologyMap (fibreIntoPeriodTorus j p) (n + 1) a)) =
+      _
+  rw [splitPeriodTorusHomology_fibre,
+    PeriodTorusHigherHomology.circleProductHomologyEquiv_section]
+
+private abbrev Elliptic.HigherHomology.DeckHomology.Circle :=
+  MappingTorus.Circle
+
+private abbrev Elliptic.HigherHomology.DeckHomology.fibreProductMap {X : Type} [TopologicalSpace X]
+    (B : C(X, X)) :
+    C(Elliptic.HigherHomology.DeckHomology.Circle × X,
+      Elliptic.HigherHomology.DeckHomology.Circle × X) :=
+  PeriodTorusHigherHomology.circleProductMap B
+
+private def
+    Elliptic.HigherHomology.DeckHomology.translatedProductMap {X : Type} [TopologicalSpace X]
+    (s : ℝ) (B : C(X, X)) :
+    C(Elliptic.HigherHomology.DeckHomology.Circle × X,
+      Elliptic.HigherHomology.DeckHomology.Circle × X)
+    where
+  toFun p := (p.1 + (s : Elliptic.HigherHomology.DeckHomology.Circle), B p.2)
+  continuous_toFun :=
+    (continuous_fst.add continuous_const).prodMk (B.continuous.comp continuous_snd)
+
+private def Elliptic.HigherHomology.DeckHomology.productTranslationHomotopy {X : Type}
+    [TopologicalSpace X] (s : ℝ) (B : C(X, X)) :
+    (fibreProductMap B).Homotopy (translatedProductMap s B)
+    where
+  toFun
+    p := (p.2.1 + ((((p.1 : ℝ) * s : ℝ)) : Elliptic.HigherHomology.DeckHomology.Circle), B p.2.2)
+  continuous_toFun := by
+    have ht :
+      Continuous
+        (fun p : unitInterval × (Elliptic.HigherHomology.DeckHomology.Circle × X) =>
+          (p.1 : ℝ) * s) :=
+      (continuous_subtype_val.comp continuous_fst).mul_const s
+    have hc :
+      Continuous
+        (fun p : unitInterval × (Elliptic.HigherHomology.DeckHomology.Circle × X) =>
+          (((p.1 : ℝ) * s : ℝ) : Elliptic.HigherHomology.DeckHomology.Circle)) :=
+      (AddCircle.continuous_mk' (1 : ℝ)).comp ht
+    exact
+      ((continuous_fst.comp continuous_snd).add hc).prodMk
+        (B.continuous.comp (continuous_snd.comp continuous_snd))
+  map_zero_left
+    p := by
+    change
+      (p.1 + (((((0 : unitInterval) : ℝ) * s : ℝ)) : Elliptic.HigherHomology.DeckHomology.Circle),
+          B p.2) =
+        (p.1, B p.2)
+    simp
+  map_one_left
+    p := by
+    change
+      (p.1 + (((((1 : unitInterval) : ℝ) * s : ℝ)) : Elliptic.HigherHomology.DeckHomology.Circle),
+          B p.2) =
+        (p.1 + (s : Elliptic.HigherHomology.DeckHomology.Circle), B p.2)
+    simp
+
+private def Elliptic.HigherHomology.DeckHomology.productTranslationChainHomotopy {X : Type}
+    [TopologicalSpace X] (s : ℝ) (B : C(X, X)) :
+    _root_.Homotopy (FirstHurewicz.singularChainMap (fibreProductMap B))
+      (FirstHurewicz.singularChainMap (translatedProductMap s B)) :=
+  PeriodTorusHigherHomology.singularChainHomotopy (productTranslationHomotopy s B)
+
+private theorem Elliptic.HigherHomology.DeckHomology.productTranslation_homologyMap {X : Type}
+    [TopologicalSpace X] (s : ℝ) (B : C(X, X)) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (fibreProductMap B) n =
+      SingularMayerVietoris.singularHomologyMap (translatedProductMap s B) n :=
+  congrArg ModuleCat.Hom.hom ((productTranslationChainHomotopy s B).homologyMap_eq n)
+
+private theorem Elliptic.HigherHomology.DeckHomology.translatedProductMap_homologyMap {X : Type}
+    [TopologicalSpace X] (s : ℝ) (B : C(X, X)) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (translatedProductMap s B) n =
+      SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.circleProductMap B)
+        n :=
+  (productTranslation_homologyMap s B n).symm
+
+private theorem Elliptic.HigherHomology.splitPeriodTorusHomeomorph_comp_affine (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) :
+    (splitPeriodTorusHomeomorph j p.val :
+            C(p.val.Torus,
+              PeriodTorusHigherHomology.CircleTopology.Circle ×
+                PeriodTorusHigherHomology.ProductTorus 3)).comp
+        (periodAffineHomeomorph j p : C(p.val.Torus, p.val.Torus)) =
+      (DeckHomology.translatedProductMap (1 / (j.order : ℝ))
+            (fibreTorusHomeomorph j :
+              C(PeriodTorusHigherHomology.ProductTorus 3,
+                PeriodTorusHigherHomology.ProductTorus 3))).comp
+        (splitPeriodTorusHomeomorph j p.val :
+          C(p.val.Torus,
+            PeriodTorusHigherHomology.CircleTopology.Circle ×
+              PeriodTorusHigherHomology.ProductTorus 3)) := by
+  apply ContinuousMap.ext
+  intro x
+  exact splitPeriodTorusHomeomorph_affineBiholomorph j p x
+
+private theorem Elliptic.HigherHomology.splitPeriodTorusHomology_affine_map (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ) :
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv (splitPeriodTorusHomeomorph j p.val)
+            n).toLinearMap.comp
+        (SingularMayerVietoris.singularHomologyMap
+          (periodAffineHomeomorph j p : C(p.val.Torus, p.val.Torus)) n) =
+      (SingularMayerVietoris.singularHomologyMap
+            (PeriodTorusHigherHomology.circleProductMap
+              (fibreTorusHomeomorph j :
+                C(PeriodTorusHigherHomology.ProductTorus 3,
+                  PeriodTorusHigherHomology.ProductTorus 3)))
+            n).comp
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv (splitPeriodTorusHomeomorph j p.val)
+            n).toLinearMap := by
+  simp only [PeriodTorusHigherHomology.homeomorphHomologyEquiv_toLinearMap]
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    splitPeriodTorusHomeomorph_comp_affine, PeriodTorusHigherHomology.singularHomologyMap_comp,
+    DeckHomology.translatedProductMap_homologyMap]
+
+private theorem Elliptic.HigherHomology.splitPeriodTorusHomology_affine (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology p.val.Torus n) :
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv (splitPeriodTorusHomeomorph j p.val) n
+        (SingularMayerVietoris.singularHomologyMap
+          (periodAffineHomeomorph j p : C(p.val.Torus, p.val.Torus)) n a) =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.circleProductMap
+          (fibreTorusHomeomorph j :
+            C(PeriodTorusHigherHomology.ProductTorus 3,
+              PeriodTorusHigherHomology.ProductTorus 3)))
+        n
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv (splitPeriodTorusHomeomorph j p.val) n
+          a) :=
+  DFunLike.congr_fun (splitPeriodTorusHomology_affine_map j p n) a
+
+private theorem Elliptic.HigherHomology.periodCircleHomologyEquiv_affine (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology p.val.Torus (n + 1)) :
+    periodCircleHomologyEquiv j p n
+        (SingularMayerVietoris.singularHomologyMap
+          (periodAffineHomeomorph j p : C(p.val.Torus, p.val.Torus)) (n + 1) a) =
+      (SingularMayerVietoris.singularHomologyMap
+          (fibreTorusHomeomorph j :
+            C(PeriodTorusHigherHomology.ProductTorus 3, PeriodTorusHigherHomology.ProductTorus 3))
+          (n + 1) (periodCircleHomologyEquiv j p n a).1,
+        SingularMayerVietoris.singularHomologyMap
+          (fibreTorusHomeomorph j :
+            C(PeriodTorusHigherHomology.ProductTorus 3, PeriodTorusHigherHomology.ProductTorus 3))
+          n (periodCircleHomologyEquiv j p n a).2) := by
+  change
+    PeriodTorusHigherHomology.circleProductHomologyEquiv
+        (PeriodTorusHigherHomology.ProductTorus 3) n
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv (splitPeriodTorusHomeomorph j p.val)
+          (n + 1)
+          (SingularMayerVietoris.singularHomologyMap
+            (periodAffineHomeomorph j p : C(p.val.Torus, p.val.Torus)) (n + 1) a)) =
+      _
+  rw [splitPeriodTorusHomology_affine]
+  exact
+    PeriodTorusHigherHomology.circleProductHomologyEquiv_naturality
+      (fibreTorusHomeomorph j :
+        C(PeriodTorusHigherHomology.ProductTorus 3, PeriodTorusHigherHomology.ProductTorus 3))
+      n _
+
+private theorem Elliptic.HigherHomology.periodCircleHomologyEquiv_affine_symm (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology p.val.Torus (n + 1)) :
+    periodCircleHomologyEquiv j p n
+        (SingularMayerVietoris.singularHomologyMap
+          ((periodAffineHomeomorph j p).symm : C(p.val.Torus, p.val.Torus)) (n + 1) a) =
+      (SingularMayerVietoris.singularHomologyMap
+          ((fibreTorusHomeomorph j).symm :
+            C(PeriodTorusHigherHomology.ProductTorus 3, PeriodTorusHigherHomology.ProductTorus 3))
+          (n + 1) (periodCircleHomologyEquiv j p n a).1,
+        SingularMayerVietoris.singularHomologyMap
+          ((fibreTorusHomeomorph j).symm :
+            C(PeriodTorusHigherHomology.ProductTorus 3, PeriodTorusHigherHomology.ProductTorus 3))
+          n (periodCircleHomologyEquiv j p n a).2) := by
+  let A := PeriodTorusHigherHomology.homeomorphHomologyEquiv (periodAffineHomeomorph j p) (n + 1)
+  let D :=
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv (fibreTorusHomeomorph j) (n + 1)).prodCongr
+      (PeriodTorusHigherHomology.homeomorphHomologyEquiv (fibreTorusHomeomorph j) n)
+  have h := periodCircleHomologyEquiv_affine j p n (A.symm a)
+  change
+    periodCircleHomologyEquiv j p n (A (A.symm a)) =
+      D (periodCircleHomologyEquiv j p n (A.symm a)) at h
+  rw [LinearEquiv.apply_symm_apply] at h
+  change periodCircleHomologyEquiv j p n (A.symm a) = D.symm (periodCircleHomologyEquiv j p n a)
+  apply D.injective
+  simpa only [LinearEquiv.apply_symm_apply] using h.symm
+
+private def
+    Elliptic.HigherHomology.periodDeckDifference (j : Elliptic.Kind) (p : Elliptic.FixedPeriod j)
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology p.val.Torus n →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology p.val.Torus n :=
+  LinearMap.id -
+    SingularMayerVietoris.singularHomologyMap
+      ((periodAffineHomeomorph j p).symm : C(p.val.Torus, p.val.Torus)) n
+
+@[simp]
+private theorem Elliptic.HigherHomology.periodDeckDifference_apply (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology p.val.Torus n) :
+    periodDeckDifference j p n a =
+      a -
+        SingularMayerVietoris.singularHomologyMap
+          ((periodAffineHomeomorph j p).symm : C(p.val.Torus, p.val.Torus)) n a :=
+  rfl
+
+private theorem
+    Elliptic.HigherHomology.periodCircleHomologyEquiv_periodDeckDifference (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology p.val.Torus (n + 1)) :
+    periodCircleHomologyEquiv j p n (periodDeckDifference j p (n + 1) a) =
+      (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm (n + 1)
+          (periodCircleHomologyEquiv j p n a).1,
+        MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm n
+          (periodCircleHomologyEquiv j p n a).2) := by
+  rw [periodDeckDifference_apply, map_sub, periodCircleHomologyEquiv_affine_symm]
+  rfl
+
+@[instance_reducible]
+private def
+    Elliptic.HigherHomology.cokernelProductModule {M N : Type*} [AddCommGroup M] [Module ℤ M]
+    [AddCommGroup N] [Module ℤ N] : Module ℤ (M × N) :=
+  Prod.instModule
+
+attribute [local instance] Elliptic.HigherHomology.cokernelProductModule in
+private def Elliptic.HigherHomology.prodCokernelEquiv {M N : Type*} [AddCommGroup M] [Module ℤ M]
+    [AddCommGroup N] [Module ℤ N] (f : M →ₗ[ℤ] M) (g : N →ₗ[ℤ] N) :
+    ((M × N) ⧸ LinearMap.range (f.prodMap g)) ≃ₗ[ℤ]
+      (M ⧸ LinearMap.range f) × (N ⧸ LinearMap.range g) :=
+  ((QuotientAddGroup.quotientAddEquivOfEq
+          (show
+            (LinearMap.range (f.prodMap g)).toAddSubgroup =
+              (LinearMap.range f).toAddSubgroup.prod (LinearMap.range g).toAddSubgroup
+            from congrArg Submodule.toAddSubgroup (LinearMap.range_prodMap f g))).trans
+      (QuotientAddGroup.prodAddEquiv (LinearMap.range f).toAddSubgroup
+        (LinearMap.range g).toAddSubgroup)).toIntLinearEquiv
+
+attribute [local instance] Elliptic.HigherHomology.cokernelProductModule in
+private theorem
+    Elliptic.HigherHomology.triangularFinTwo_apply (F : (Fin 2 → ℤ) →ₗ[ℤ] (Fin 2 → ℤ)) (d : ℤ)
+    (hfirst : F ![1, 0] = ![1, 0]) (hsecond : ∀ v, F v 1 = d * v 1) (v : Fin 2 → ℤ) :
+    F v = ![v 0 + (F ![0, 1]) 0 * v 1, d * v 1] := by
+  have hv : v = v 0 • ![1, 0] + v 1 • ![0, 1] := by
+    ext i
+    fin_cases i <;> simp [Pi.add_apply]
+  have hF : F v = v 0 • ![1, 0] + v 1 • F ![0, 1] := by
+    calc
+      F v = F (v 0 • ![1, 0] + v 1 • ![0, 1]) := congrArg F hv
+      _ = v 0 • ![1, 0] + v 1 • F ![0, 1] := by rw [map_add, map_smul, map_smul, hfirst]
+  ext i
+  fin_cases i
+  · simpa [Pi.add_apply, Pi.smul_apply, smul_eq_mul, mul_comm] using congrFun hF 0
+  · exact hsecond v
+
+attribute [local instance] Elliptic.HigherHomology.cokernelProductModule in
+public
+theorem
+    Elliptic.HigherHomology.triangularFinTwo_injective (F : (Fin 2 → ℤ) →ₗ[ℤ] (Fin 2 → ℤ))
+    (d : ℤ) (hfirst : F ![1, 0] = ![1, 0]) (hsecond : ∀ v, F v 1 = d * v 1) (hd : d ≠ 0) :
+    Function.Injective F := by
+  intro v w h
+  have hm : d * v 1 = d * w 1 := by rw [← hsecond v, ← hsecond w, h]
+  have h₁ : v 1 = w 1 := mul_left_cancel₀ hd hm
+  rw [triangularFinTwo_apply F d hfirst hsecond v,
+    triangularFinTwo_apply F d hfirst hsecond w] at h
+  have h₀ := congrFun h 0
+  change v 0 + (F ![0, 1]) 0 * v 1 = w 0 + (F ![0, 1]) 0 * w 1 at h₀
+  rw [h₁] at h₀
+  have h₀' : v 0 = w 0 := add_right_cancel h₀
+  ext i
+  fin_cases i
+  · exact h₀'
+  · exact h₁
+
+private abbrev Elliptic.HigherHomology.PeriodDeckCoinvariants (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ) :=
+  SingularMayerVietoris.SingularHomology p.val.Torus n ⧸
+    LinearMap.range (periodDeckDifference j p n)
+
+private def Elliptic.HigherHomology.periodDeckCoinvariantsEquivProd (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ) :
+    PeriodDeckCoinvariants j p (n + 1) ≃ₗ[ℤ]
+      ((SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3)
+            (n + 1) ⧸
+          LinearMap.range
+            (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm (n + 1))) ×
+        (SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) n ⧸
+          LinearMap.range
+            (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm n))) :=
+  ((conjugacyCokernelEquiv (periodCircleHomologyEquiv j p n) (periodDeckDifference j p (n + 1))
+          (((MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm
+                  (n + 1)).toAddMonoidHom.prodMap
+              (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm
+                  n).toAddMonoidHom).toIntLinearMap)
+          (periodCircleHomologyEquiv_periodDeckDifference j p n)).toAddEquiv.trans
+      (prodCokernelEquiv
+          (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm (n + 1))
+          (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm
+            n)).toAddEquiv).toIntLinearEquiv
+
+private def Elliptic.HigherHomology.periodDeckCoinvariantsH1Equiv (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) : PeriodDeckCoinvariants j p 1 ≃ₗ[ℤ] (Fin 2 → ℤ) :=
+  ((periodDeckCoinvariantsEquivProd j p 0).toAddEquiv.trans
+      (((mappingTorusCokernelOneEquiv j).toAddEquiv.prodCongr
+            (mappingTorusCokernelZeroEquiv j).toAddEquiv).trans
+        (LinearEquiv.finTwoArrow ℤ ℤ).symm.toAddEquiv)).toIntLinearEquiv
+
+private def Elliptic.HigherHomology.periodDeckCoinvariantsH2Equiv (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) : PeriodDeckCoinvariants j p 2 ≃ₗ[ℤ] (Fin 2 → ℤ) :=
+  ((periodDeckCoinvariantsEquivProd j p 1).toAddEquiv.trans
+      (((mappingTorusCokernelTwoEquiv j).toAddEquiv.prodCongr
+            (mappingTorusCokernelOneEquiv j).toAddEquiv).trans
+        (LinearEquiv.finTwoArrow ℤ ℤ).symm.toAddEquiv)).toIntLinearEquiv
+
+private def Elliptic.HigherHomology.periodDeckCoinvariantsH3Equiv (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) : PeriodDeckCoinvariants j p 3 ≃ₗ[ℤ] (Fin 2 → ℤ) :=
+  ((periodDeckCoinvariantsEquivProd j p 2).toAddEquiv.trans
+      (((mappingTorusCokernelThreeEquiv j).toAddEquiv.prodCongr
+            (mappingTorusCokernelTwoEquiv j).toAddEquiv).trans
+        (LinearEquiv.finTwoArrow ℤ ℤ).symm.toAddEquiv)).toIntLinearEquiv
+
+private def Elliptic.HigherHomology.periodDeckCoinvariantsH4Equiv (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) : PeriodDeckCoinvariants j p 4 ≃ₗ[ℤ] ℤ := by
+  have :=
+    PeriodTorusHigherHomology.productTorus_homology_subsingleton_of_lt (show 3 < 4 by decide)
+  letI :
+    Unique
+      (SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 4 ⧸
+        LinearMap.range (MappingTorusHomology.wangDifference (fibreTorusHomeomorph j).symm 4)) :=
+    uniqueOfSubsingleton 0
+  exact
+    ((periodDeckCoinvariantsEquivProd j p 3).toAddEquiv.trans
+        (AddEquiv.uniqueProd.trans
+          (mappingTorusCokernelThreeEquiv j).toAddEquiv)).toIntLinearEquiv
+
+@[simp]
+private theorem Elliptic.HigherHomology.periodDeckCoinvariantsH1Equiv_mk (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (a : SingularMayerVietoris.SingularHomology p.val.Torus 1) :
+    periodDeckCoinvariantsH1Equiv j p (Submodule.Quotient.mk a) =
+      ![fibreCoinvariantCoordinate j (torusH1Equiv (periodCircleHomologyEquiv j p 0 a).1),
+        torusH0Coordinates (periodCircleHomologyEquiv j p 0 a).2] :=
+  rfl
+
+@[simp]
+private theorem Elliptic.HigherHomology.periodDeckCoinvariantsH2Equiv_mk (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (a : SingularMayerVietoris.SingularHomology p.val.Torus 2) :
+    periodDeckCoinvariantsH2Equiv j p (Submodule.Quotient.mk a) =
+      ![torusH2Coordinates (periodCircleHomologyEquiv j p 1 a).1 0,
+        fibreCoinvariantCoordinate j (torusH1Equiv (periodCircleHomologyEquiv j p 1 a).2)] :=
+  rfl
+
+@[simp]
+private theorem Elliptic.HigherHomology.periodDeckCoinvariantsH3Equiv_mk (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (a : SingularMayerVietoris.SingularHomology p.val.Torus 3) :
+    periodDeckCoinvariantsH3Equiv j p (Submodule.Quotient.mk a) =
+      ![torusH3Coordinates (periodCircleHomologyEquiv j p 2 a).1,
+        torusH2Coordinates (periodCircleHomologyEquiv j p 2 a).2 0] :=
+  rfl
+
+@[simp]
+private theorem Elliptic.HigherHomology.periodDeckCoinvariantsH4Equiv_mk (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (a : SingularMayerVietoris.SingularHomology p.val.Torus 4) :
+    periodDeckCoinvariantsH4Equiv j p (Submodule.Quotient.mk a) =
+      torusH3Coordinates (periodCircleHomologyEquiv j p 3 a).2 :=
+  rfl
+
+private theorem Elliptic.HigherHomology.periodDeckCoinvariantsH1Equiv_fibre (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 1) :
+    periodDeckCoinvariantsH1Equiv j p
+        (Submodule.Quotient.mk
+          (SingularMayerVietoris.singularHomologyMap (fibreIntoPeriodTorus j p) 1 a)) =
+      ![fibreCoinvariantCoordinate j (torusH1Equiv a), 0] := by
+  simp only [periodDeckCoinvariantsH1Equiv_mk, periodCircleHomologyEquiv_fibre, map_zero]
+
+private theorem Elliptic.HigherHomology.periodDeckCoinvariantsH2Equiv_fibre (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 2) :
+    periodDeckCoinvariantsH2Equiv j p
+        (Submodule.Quotient.mk
+          (SingularMayerVietoris.singularHomologyMap (fibreIntoPeriodTorus j p) 2 a)) =
+      ![torusH2Coordinates a 0, 0] := by
+  simp only [periodDeckCoinvariantsH2Equiv_mk, periodCircleHomologyEquiv_fibre, map_zero]
+
+private theorem Elliptic.HigherHomology.periodDeckCoinvariantsH3Equiv_fibre (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3) :
+    periodDeckCoinvariantsH3Equiv j p
+        (Submodule.Quotient.mk
+          (SingularMayerVietoris.singularHomologyMap (fibreIntoPeriodTorus j p) 3 a)) =
+      ![torusH3Coordinates a, 0] := by
+  simp only [periodDeckCoinvariantsH3Equiv_mk, periodCircleHomologyEquiv_fibre, map_zero,
+    Pi.zero_apply]
+
+private theorem Elliptic.HigherHomology.periodCover_affine_eq (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (x : p.val.Torus) :
+    periodCover j p v hv (Elliptic.affineBiholomorph j p v x) = periodCover j p v hv x := by
+  let := Elliptic.affineAction j p v hv.1
+  rw [← Elliptic.affineAction_generator_smul j p v hv.1 x]
+  exact
+    Elliptic.FiniteQuotient.project_smul (Elliptic.CyclicGroup j) p.val.Torus
+      (Elliptic.CyclicAction.generator j.order) x
+
+private theorem Elliptic.HigherHomology.periodCover_affine_symm_eq (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (x : p.val.Torus) :
+    periodCover j p v hv ((Elliptic.affineBiholomorph j p v).toHomeomorph.symm x) =
+      periodCover j p v hv x := by
+  have h :=
+    periodCover_affine_eq j p v hv ((Elliptic.affineBiholomorph j p v).toHomeomorph.symm x)
+  change
+    periodCover j p v hv
+        ((Elliptic.affineBiholomorph j p v).toHomeomorph
+          ((Elliptic.affineBiholomorph j p v).toHomeomorph.symm x)) =
+      _ at h
+  rw [Homeomorph.apply_symm_apply] at h
+  exact h.symm
+
+private theorem Elliptic.HigherHomology.periodCover_comp_affine_symm (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    (periodCover j p v hv).comp
+        ((Elliptic.affineBiholomorph j p v).toHomeomorph.symm : C(p.val.Torus, p.val.Torus)) =
+      periodCover j p v hv := by
+  ext x
+  exact periodCover_affine_symm_eq j p v hv x
+
+private theorem Elliptic.HigherHomology.periodCover_homology_affine_symm_comp (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (n : ℕ) :
+    (SingularMayerVietoris.singularHomologyMap (periodCover j p v hv) n).comp
+        (SingularMayerVietoris.singularHomologyMap
+          ((Elliptic.affineBiholomorph j p v).toHomeomorph.symm : C(p.val.Torus, p.val.Torus))
+          n) =
+      SingularMayerVietoris.singularHomologyMap (periodCover j p v hv) n := by
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp, periodCover_comp_affine_symm]
+
+private theorem
+    Elliptic.HigherHomology.periodCover_homology_comp_affineDifference (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (n : ℕ) :
+    (SingularMayerVietoris.singularHomologyMap (periodCover j p v hv) n).comp
+        (LinearMap.id -
+          SingularMayerVietoris.singularHomologyMap
+            ((Elliptic.affineBiholomorph j p v).toHomeomorph.symm : C(p.val.Torus, p.val.Torus))
+            n) =
+      0 := by
+  rw [LinearMap.comp_sub, LinearMap.comp_id, periodCover_homology_affine_symm_comp, sub_self]
+
+private theorem
+    Elliptic.HigherHomology.periodCover_homology_comp_periodDeckDifference (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ) :
+    (SingularMayerVietoris.singularHomologyMap
+            (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) n).comp
+        (periodDeckDifference j p n) =
+      0 :=
+  periodCover_homology_comp_affineDifference j p j.twist (Elliptic.mainTwist_admissible j) n
+
+private theorem
+    Elliptic.HigherHomology.periodCover_homology_periodDeckDifference (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology p.val.Torus n) :
+    SingularMayerVietoris.singularHomologyMap
+        (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) n
+        (periodDeckDifference j p n a) =
+      0 :=
+  DFunLike.congr_fun (periodCover_homology_comp_periodDeckDifference j p n) a
+
+private theorem
+    Elliptic.HigherHomology.periodDeckDifference_range_le_periodCover_ker (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ) :
+    LinearMap.range (periodDeckDifference j p n) ≤
+      LinearMap.ker
+        (SingularMayerVietoris.singularHomologyMap
+          (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) n) := by
+  rintro a ⟨b, rfl⟩
+  exact periodCover_homology_periodDeckDifference j p n b
+
+private def Elliptic.HigherHomology.periodCoverFromDeckCoinvariants (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ) :
+    (SingularMayerVietoris.SingularHomology p.val.Torus n ⧸
+        LinearMap.range (periodDeckDifference j p n)) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology
+        (Elliptic.Surface j p j.twist (Elliptic.mainTwist_admissible j)) n
+    where
+  toFun :=
+    (LinearMap.range (periodDeckDifference j p n)).liftQ
+      (SingularMayerVietoris.singularHomologyMap
+        (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) n)
+      (periodDeckDifference_range_le_periodCover_ker j p n)
+  map_add' a b := map_add _ a b
+  map_smul' r
+    a := by
+    let f :=
+      (LinearMap.range (periodDeckDifference j p n)).liftQ
+        (SingularMayerVietoris.singularHomologyMap
+          (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) n)
+        (periodDeckDifference_range_le_periodCover_ker j p n)
+    change
+      f (r • a) =
+        (SingularMayerVietoris.SingularHomology
+              (Elliptic.Surface j p j.twist (Elliptic.mainTwist_admissible j)) n).isModule.smul
+          r (f a)
+    rw [int_smul_eq_zsmul]
+    exact map_zsmul f r a
+
+@[simp]
+private theorem Elliptic.HigherHomology.periodCoverFromDeckCoinvariants_mk (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology p.val.Torus n) :
+    periodCoverFromDeckCoinvariants j p n (Submodule.Quotient.mk a) =
+      SingularMayerVietoris.singularHomologyMap
+        (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) n a :=
+  rfl
+
+private def Elliptic.HigherHomology.periodCoverCoinvariantH1Map (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) : (Fin 2 → ℤ) →ₗ[ℤ] (Fin 2 → ℤ) :=
+  (surfaceH1Equiv j p).toLinearMap.comp
+    ((periodCoverFromDeckCoinvariants j p 1).comp
+      (periodDeckCoinvariantsH1Equiv j p).symm.toLinearMap)
+
+private def Elliptic.HigherHomology.periodCoverCoinvariantH2Map (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) : (Fin 2 → ℤ) →ₗ[ℤ] (Fin 2 → ℤ) :=
+  (surfaceH2Equiv j p).toLinearMap.comp
+    ((periodCoverFromDeckCoinvariants j p 2).comp
+      (periodDeckCoinvariantsH2Equiv j p).symm.toLinearMap)
+
+private def Elliptic.HigherHomology.periodCoverCoinvariantH3Map (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) : (Fin 2 → ℤ) →ₗ[ℤ] (Fin 2 → ℤ) :=
+  (surfaceH3Equiv j p).toLinearMap.comp
+    ((periodCoverFromDeckCoinvariants j p 3).comp
+      (periodDeckCoinvariantsH3Equiv j p).symm.toLinearMap)
+
+private theorem Elliptic.HigherHomology.periodCoverCoinvariantH1Map_firstAxis (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (t : ℤ) : periodCoverCoinvariantH1Map j p ![t, 0] = ![t, 0] := by
+  obtain ⟨v, hv⟩ := fibreCoinvariantCoordinate_surjective j t
+  let a := torusH1Equiv.symm v
+  have ha : fibreCoinvariantCoordinate j (torusH1Equiv a) = t := by
+    simpa only [a, LinearEquiv.apply_symm_apply] using hv
+  have hs :
+    periodDeckCoinvariantsH1Equiv j p
+        (Submodule.Quotient.mk
+          (SingularMayerVietoris.singularHomologyMap (fibreIntoPeriodTorus j p) 1 a)) =
+      ![t, 0] := by rw [periodDeckCoinvariantsH1Equiv_fibre, ha]
+  change
+    surfaceH1Equiv j p
+        (periodCoverFromDeckCoinvariants j p 1
+          ((periodDeckCoinvariantsH1Equiv j p).symm ![t, 0])) =
+      _
+  conv_lhs => rw [← hs]
+  rw [LinearEquiv.symm_apply_apply, periodCoverFromDeckCoinvariants_mk,
+    surfaceH1Equiv_periodCover_fibre, ha]
+
+private theorem Elliptic.HigherHomology.periodCoverCoinvariantH2Map_firstAxis (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (t : ℤ) : periodCoverCoinvariantH2Map j p ![t, 0] = ![t, 0] := by
+  let a := torusH2Coordinates.symm ![t, 0, 0]
+  have ha : torusH2Coordinates a 0 = t := by
+    rw [show a = torusH2Coordinates.symm ![t, 0, 0] from rfl, LinearEquiv.apply_symm_apply]
+    rfl
+  have hs :
+    periodDeckCoinvariantsH2Equiv j p
+        (Submodule.Quotient.mk
+          (SingularMayerVietoris.singularHomologyMap (fibreIntoPeriodTorus j p) 2 a)) =
+      ![t, 0] := by rw [periodDeckCoinvariantsH2Equiv_fibre, ha]
+  change
+    surfaceH2Equiv j p
+        (periodCoverFromDeckCoinvariants j p 2
+          ((periodDeckCoinvariantsH2Equiv j p).symm ![t, 0])) =
+      _
+  conv_lhs => rw [← hs]
+  rw [LinearEquiv.symm_apply_apply, periodCoverFromDeckCoinvariants_mk,
+    surfaceH2Equiv_periodCover_fibre, ha]
+
+private theorem Elliptic.HigherHomology.periodCoverCoinvariantH3Map_firstAxis (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (t : ℤ) : periodCoverCoinvariantH3Map j p ![t, 0] = ![t, 0] := by
+  let a := torusH3Coordinates.symm t
+  have ha : torusH3Coordinates a = t := LinearEquiv.apply_symm_apply _ t
+  have hs :
+    periodDeckCoinvariantsH3Equiv j p
+        (Submodule.Quotient.mk
+          (SingularMayerVietoris.singularHomologyMap (fibreIntoPeriodTorus j p) 3 a)) =
+      ![t, 0] := by rw [periodDeckCoinvariantsH3Equiv_fibre, ha]
+  change
+    surfaceH3Equiv j p
+        (periodCoverFromDeckCoinvariants j p 3
+          ((periodDeckCoinvariantsH3Equiv j p).symm ![t, 0])) =
+      _
+  conv_lhs => rw [← hs]
+  rw [LinearEquiv.symm_apply_apply, periodCoverFromDeckCoinvariants_mk,
+    surfaceH3Equiv_periodCover_fibre, ha]
+
+private theorem
+    Elliptic.HigherHomology.periodCoverFromDeckCoinvariants_h1_second (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (a : PeriodDeckCoinvariants j p 1) :
+    surfaceH1Equiv j p (periodCoverFromDeckCoinvariants j p 1 a) 1 =
+      (j.order : ℤ) * periodDeckCoinvariantsH1Equiv j p a 1 := by
+  obtain ⟨b, rfl⟩ :=
+    Submodule.Quotient.mk_surjective (LinearMap.range (periodDeckDifference j p 1)) a
+  rw [periodCoverFromDeckCoinvariants_mk, periodDeckCoinvariantsH1Equiv_mk]
+  change
+    surfacePeriodCoverH1Coordinates j p b 1 =
+      (j.order : ℤ) * torusH0Coordinates (surfacePeriodCoverCircleBoundary j p 0 b)
+  have h := DFunLike.congr_fun (surfacePeriodCoverH1Coordinates_secondMap j p) b
+  change
+    surfacePeriodCoverH1Coordinates j p b 1 =
+      fibreHomologyNormZeroCoordinate j (surfacePeriodCoverCircleBoundary j p 0 b) at h
+  rw [h, fibreHomologyNormZeroCoordinate_apply]
+
+private theorem
+    Elliptic.HigherHomology.periodCoverFromDeckCoinvariants_h2_second (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (a : PeriodDeckCoinvariants j p 2) :
+    surfaceH2Equiv j p (periodCoverFromDeckCoinvariants j p 2 a) 1 =
+      (fibreNormIndex j : ℤ) * periodDeckCoinvariantsH2Equiv j p a 1 := by
+  obtain ⟨b, rfl⟩ :=
+    Submodule.Quotient.mk_surjective (LinearMap.range (periodDeckDifference j p 2)) a
+  rw [periodCoverFromDeckCoinvariants_mk, periodDeckCoinvariantsH2Equiv_mk]
+  change
+    surfacePeriodCoverH2Coordinates j p b 1 =
+      (fibreNormIndex j : ℤ) *
+        fibreCoinvariantCoordinate j (torusH1Equiv (surfacePeriodCoverCircleBoundary j p 1 b))
+  have h := DFunLike.congr_fun (surfacePeriodCoverH2Coordinates_secondMap j p) b
+  change
+    surfacePeriodCoverH2Coordinates j p b 1 =
+      fibreHomologyNormOneCoordinate j (surfacePeriodCoverCircleBoundary j p 1 b) at h
+  rw [h, fibreHomologyNormOneCoordinate_apply]
+
+private theorem
+    Elliptic.HigherHomology.periodCoverFromDeckCoinvariants_h3_second (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (a : PeriodDeckCoinvariants j p 3) :
+    surfaceH3Equiv j p (periodCoverFromDeckCoinvariants j p 3 a) 1 =
+      (fibreNormIndex j : ℤ) * periodDeckCoinvariantsH3Equiv j p a 1 := by
+  obtain ⟨b, rfl⟩ :=
+    Submodule.Quotient.mk_surjective (LinearMap.range (periodDeckDifference j p 3)) a
+  rw [periodCoverFromDeckCoinvariants_mk, periodDeckCoinvariantsH3Equiv_mk]
+  change
+    surfacePeriodCoverH3Coordinates j p b 1 =
+      (fibreNormIndex j : ℤ) * torusH2Coordinates (surfacePeriodCoverCircleBoundary j p 2 b) 0
+  have h := DFunLike.congr_fun (surfacePeriodCoverH3Coordinates_secondMap j p) b
+  change
+    surfacePeriodCoverH3Coordinates j p b 1 =
+      fibreHomologyNormTwoCoordinate j (surfacePeriodCoverCircleBoundary j p 2 b) at h
+  rw [h, fibreHomologyNormTwoCoordinate_apply]
+
+private theorem Elliptic.HigherHomology.periodCoverCoinvariantH1Map_second (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (v : Fin 2 → ℤ) :
+    periodCoverCoinvariantH1Map j p v 1 = (j.order : ℤ) * v 1 := by
+  change
+    surfaceH1Equiv j p
+        (periodCoverFromDeckCoinvariants j p 1 ((periodDeckCoinvariantsH1Equiv j p).symm v)) 1 =
+      _
+  rw [periodCoverFromDeckCoinvariants_h1_second, LinearEquiv.apply_symm_apply]
+
+private theorem Elliptic.HigherHomology.periodCoverCoinvariantH2Map_second (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (v : Fin 2 → ℤ) :
+    periodCoverCoinvariantH2Map j p v 1 = (fibreNormIndex j : ℤ) * v 1 := by
+  change
+    surfaceH2Equiv j p
+        (periodCoverFromDeckCoinvariants j p 2 ((periodDeckCoinvariantsH2Equiv j p).symm v)) 1 =
+      _
+  rw [periodCoverFromDeckCoinvariants_h2_second, LinearEquiv.apply_symm_apply]
+
+private theorem Elliptic.HigherHomology.periodCoverCoinvariantH3Map_second (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (v : Fin 2 → ℤ) :
+    periodCoverCoinvariantH3Map j p v 1 = (fibreNormIndex j : ℤ) * v 1 := by
+  change
+    surfaceH3Equiv j p
+        (periodCoverFromDeckCoinvariants j p 3 ((periodDeckCoinvariantsH3Equiv j p).symm v)) 1 =
+      _
+  rw [periodCoverFromDeckCoinvariants_h3_second, LinearEquiv.apply_symm_apply]
+
+private theorem Elliptic.HigherHomology.periodCoverCoinvariantH1Map_injective (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) : Function.Injective (periodCoverCoinvariantH1Map j p) :=
+  triangularFinTwo_injective _ _ (periodCoverCoinvariantH1Map_firstAxis j p 1)
+    (periodCoverCoinvariantH1Map_second j p) (by exact_mod_cast j.order_pos.ne')
+
+private theorem Elliptic.HigherHomology.periodCoverCoinvariantH2Map_injective (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) : Function.Injective (periodCoverCoinvariantH2Map j p) :=
+  triangularFinTwo_injective _ _ (periodCoverCoinvariantH2Map_firstAxis j p 1)
+    (periodCoverCoinvariantH2Map_second j p) (by exact_mod_cast (fibreNormIndex_pos j).ne')
+
+private theorem Elliptic.HigherHomology.periodCoverCoinvariantH3Map_injective (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) : Function.Injective (periodCoverCoinvariantH3Map j p) :=
+  triangularFinTwo_injective _ _ (periodCoverCoinvariantH3Map_firstAxis j p 1)
+    (periodCoverCoinvariantH3Map_second j p) (by exact_mod_cast (fibreNormIndex_pos j).ne')
+
+private theorem
+    Elliptic.HigherHomology.periodCoverFromDeckCoinvariants_h1_injective (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) : Function.Injective (periodCoverFromDeckCoinvariants j p 1) := by
+  intro a b h
+  apply (periodDeckCoinvariantsH1Equiv j p).injective
+  apply periodCoverCoinvariantH1Map_injective j p
+  change
+    surfaceH1Equiv j p
+        (periodCoverFromDeckCoinvariants j p 1
+          ((periodDeckCoinvariantsH1Equiv j p).symm (periodDeckCoinvariantsH1Equiv j p a))) =
+      surfaceH1Equiv j p
+        (periodCoverFromDeckCoinvariants j p 1
+          ((periodDeckCoinvariantsH1Equiv j p).symm (periodDeckCoinvariantsH1Equiv j p b)))
+  rw [LinearEquiv.symm_apply_apply, LinearEquiv.symm_apply_apply, h]
+
+private theorem
+    Elliptic.HigherHomology.periodCoverFromDeckCoinvariants_h2_injective (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) : Function.Injective (periodCoverFromDeckCoinvariants j p 2) := by
+  intro a b h
+  apply (periodDeckCoinvariantsH2Equiv j p).injective
+  apply periodCoverCoinvariantH2Map_injective j p
+  change
+    surfaceH2Equiv j p
+        (periodCoverFromDeckCoinvariants j p 2
+          ((periodDeckCoinvariantsH2Equiv j p).symm (periodDeckCoinvariantsH2Equiv j p a))) =
+      surfaceH2Equiv j p
+        (periodCoverFromDeckCoinvariants j p 2
+          ((periodDeckCoinvariantsH2Equiv j p).symm (periodDeckCoinvariantsH2Equiv j p b)))
+  rw [LinearEquiv.symm_apply_apply, LinearEquiv.symm_apply_apply, h]
+
+private theorem
+    Elliptic.HigherHomology.periodCoverFromDeckCoinvariants_h3_injective (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) : Function.Injective (periodCoverFromDeckCoinvariants j p 3) := by
+  intro a b h
+  apply (periodDeckCoinvariantsH3Equiv j p).injective
+  apply periodCoverCoinvariantH3Map_injective j p
+  change
+    surfaceH3Equiv j p
+        (periodCoverFromDeckCoinvariants j p 3
+          ((periodDeckCoinvariantsH3Equiv j p).symm (periodDeckCoinvariantsH3Equiv j p a))) =
+      surfaceH3Equiv j p
+        (periodCoverFromDeckCoinvariants j p 3
+          ((periodDeckCoinvariantsH3Equiv j p).symm (periodDeckCoinvariantsH3Equiv j p b)))
+  rw [LinearEquiv.symm_apply_apply, LinearEquiv.symm_apply_apply, h]
+
+private theorem
+    Elliptic.HigherHomology.periodCoverFromDeckCoinvariants_h4_coordinate (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (a : PeriodDeckCoinvariants j p 4) :
+    surfaceH4Equiv j p (periodCoverFromDeckCoinvariants j p 4 a) =
+      (j.order : ℤ) * periodDeckCoinvariantsH4Equiv j p a := by
+  obtain ⟨b, rfl⟩ :=
+    Submodule.Quotient.mk_surjective (LinearMap.range (periodDeckDifference j p 4)) a
+  rw [periodCoverFromDeckCoinvariants_mk, periodDeckCoinvariantsH4Equiv_mk]
+  change
+    surfacePeriodCoverH4Coordinates j p b =
+      (j.order : ℤ) * torusH3Coordinates (surfacePeriodCoverCircleBoundary j p 3 b)
+  exact surfacePeriodCoverH4Coordinates_apply j p b
+
+private theorem
+    Elliptic.HigherHomology.periodCoverFromDeckCoinvariants_h4_injective (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) : Function.Injective (periodCoverFromDeckCoinvariants j p 4) := by
+  intro a b h
+  apply (periodDeckCoinvariantsH4Equiv j p).injective
+  apply mul_left_cancel₀ (show (j.order : ℤ) ≠ 0 by exact_mod_cast j.order_pos.ne')
+  rw [← periodCoverFromDeckCoinvariants_h4_coordinate, ←
+    periodCoverFromDeckCoinvariants_h4_coordinate, h]
+
+private theorem
+  Elliptic.HigherHomology.periodCover_ker_eq_deckDifference_range_of_injective_mo1973_29635
+    (j : Elliptic.Kind) (p : Elliptic.FixedPeriod j) (n : ℕ)
+    (h : Function.Injective (periodCoverFromDeckCoinvariants j p n)) :
+    LinearMap.ker
+        (SingularMayerVietoris.singularHomologyMap
+          (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) n) =
+      LinearMap.range (periodDeckDifference j p n) := by
+  apply le_antisymm _ (periodDeckDifference_range_le_periodCover_ker j p n)
+  intro a ha
+  apply (Submodule.Quotient.mk_eq_zero (LinearMap.range (periodDeckDifference j p n))).mp
+  apply h
+  rw [periodCoverFromDeckCoinvariants_mk, map_zero]
+  exact ha
+
+private theorem
+    Elliptic.HigherHomology.periodCover_h1_ker_eq_deckDifference_range (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) :
+    LinearMap.ker
+        (SingularMayerVietoris.singularHomologyMap
+          (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) 1) =
+      LinearMap.range (periodDeckDifference j p 1) :=
+  periodCover_ker_eq_deckDifference_range_of_injective_mo1973_29635 j p 1
+    (periodCoverFromDeckCoinvariants_h1_injective j p)
+
+private theorem
+    Elliptic.HigherHomology.periodCover_h2_ker_eq_deckDifference_range (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) :
+    LinearMap.ker
+        (SingularMayerVietoris.singularHomologyMap
+          (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) 2) =
+      LinearMap.range (periodDeckDifference j p 2) :=
+  periodCover_ker_eq_deckDifference_range_of_injective_mo1973_29635 j p 2
+    (periodCoverFromDeckCoinvariants_h2_injective j p)
+
+private theorem
+    Elliptic.HigherHomology.periodCover_h3_ker_eq_deckDifference_range (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) :
+    LinearMap.ker
+        (SingularMayerVietoris.singularHomologyMap
+          (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) 3) =
+      LinearMap.range (periodDeckDifference j p 3) :=
+  periodCover_ker_eq_deckDifference_range_of_injective_mo1973_29635 j p 3
+    (periodCoverFromDeckCoinvariants_h3_injective j p)
+
+private theorem
+    Elliptic.HigherHomology.periodCover_h4_ker_eq_deckDifference_range (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) :
+    LinearMap.ker
+        (SingularMayerVietoris.singularHomologyMap
+          (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) 4) =
+      LinearMap.range (periodDeckDifference j p 4) :=
+  periodCover_ker_eq_deckDifference_range_of_injective_mo1973_29635 j p 4
+    (periodCoverFromDeckCoinvariants_h4_injective j p)
+
+private theorem Elliptic.HigherHomology.periodCover_h0_injective (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) :
+    Function.Injective
+      (SingularMayerVietoris.singularHomologyMap
+        (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) 0) := by
+  intro a b hab
+  apply (PeriodTorusHigherHomology.connectedHomologyZeroEquiv p.val.Torus).injective
+  have h :=
+    congrArg
+      (PeriodTorusHigherHomology.connectedHomologyZeroEquiv
+        (Elliptic.Surface j p j.twist (Elliptic.mainTwist_admissible j)))
+      hab
+  exact
+    (PeriodTorusHigherHomology.connectedHomologyZeroEquiv_natural
+          (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) a).symm.trans
+      (h.trans
+        (PeriodTorusHigherHomology.connectedHomologyZeroEquiv_natural
+          (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) b))
+
+private theorem Elliptic.HigherHomology.periodDeckDifference_zero (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) : periodDeckDifference j p 0 = 0 := by
+  ext a
+  rw [periodDeckDifference_apply]
+  apply sub_eq_zero.mpr
+  apply (PeriodTorusHigherHomology.connectedHomologyZeroEquiv p.val.Torus).injective
+  exact
+    (PeriodTorusHigherHomology.connectedHomologyZeroEquiv_natural
+        ((periodAffineHomeomorph j p).symm : C(p.val.Torus, p.val.Torus)) a).symm
+
+private theorem
+    Elliptic.HigherHomology.periodCover_h0_ker_eq_deckDifference_range (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) :
+    LinearMap.ker
+        (SingularMayerVietoris.singularHomologyMap
+          (periodCover j p j.twist (Elliptic.mainTwist_admissible j)) 0) =
+      LinearMap.range (periodDeckDifference j p 0) := by
+  rw [LinearMap.ker_eq_bot.mpr (periodCover_h0_injective j p), periodDeckDifference_zero,
+    LinearMap.range_zero]
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Foundations/CanonicalProduct.lean b/LeanPool/HopfProblem/Foundations/CanonicalProduct.lean
new file mode 100644
index 000000000..25fb3f239
--- /dev/null
+++ b/LeanPool/HopfProblem/Foundations/CanonicalProduct.lean
@@ -0,0 +1,83 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Hurewicz.ThirdHurewicz
+import all LeanPool.HopfProblem.Hurewicz.ThirdHurewicz
+
+/-!
+# Hopf problem: foundations · canonical product
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def CanonicalProduct.prodLine {E F M N : Type*} [NormedAddCommGroup E] [NormedSpace ℂ E]
+    [NormedAddCommGroup F] [NormedSpace ℂ F] [TopologicalSpace M] [ChartedSpace E M]
+    [TopologicalSpace N] [ChartedSpace F N]
+    (e : PartialDiffeomorph (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ F) M N ω) :
+    PartialDiffeomorph (((modelWithCornersSelf ℂ E)).prod (modelWithCornersSelf ℂ ℂ))
+      (((modelWithCornersSelf ℂ F)).prod (modelWithCornersSelf ℂ ℂ)) (M × ℂ) (N × ℂ) ω
+    where
+  toFun p := (e p.1, p.2)
+  invFun p := (e.symm p.1, p.2)
+  source := e.source ×ˢ Set.univ
+  target := e.target ×ˢ Set.univ
+  map_source' _ h := ⟨e.map_source h.1, Set.mem_univ _⟩
+  map_target' _ h := ⟨e.map_target h.1, Set.mem_univ _⟩
+  left_inv' _ h := Prod.ext (e.left_inv h.1) rfl
+  right_inv' _ h := Prod.ext (e.right_inv h.1) rfl
+  open_source := e.open_source.prod isOpen_univ
+  open_target := e.open_target.prod isOpen_univ
+  contMDiffOn_toFun :=
+    (e.contMDiffOn_toFun.comp contMDiffOn_fst (fun _ h => h.1)).prodMk contMDiffOn_snd
+  contMDiffOn_invFun :=
+    (e.contMDiffOn_invFun.comp contMDiffOn_fst (fun _ h => h.1)).prodMk contMDiffOn_snd
+
+private theorem
+    CanonicalProduct.isLocalDiffeomorphAt_prodLine {E F M N : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [NormedAddCommGroup F] [NormedSpace ℂ F] [TopologicalSpace M]
+    [ChartedSpace E M] [TopologicalSpace N] [ChartedSpace F N] {f : M → N} {p : M × ℂ}
+    (hf : IsLocalDiffeomorphAt (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ F) ω f p.1) :
+    IsLocalDiffeomorphAt (((modelWithCornersSelf ℂ E)).prod (modelWithCornersSelf ℂ ℂ))
+      (((modelWithCornersSelf ℂ F)).prod (modelWithCornersSelf ℂ ℂ)) ω
+      (fun q : M × ℂ => (f q.1, q.2)) p := by
+  obtain ⟨e, he, hfe⟩ := hf
+  refine ⟨prodLine e, ⟨he, Set.mem_univ _⟩, ?_⟩
+  intro q hq
+  exact Prod.ext (hfe hq.1) rfl
+
+public
+theorem CanonicalProduct.isLocalDiffeomorph_prodLine {E F M N : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [NormedAddCommGroup F] [NormedSpace ℂ F] [TopologicalSpace M]
+    [ChartedSpace E M] [TopologicalSpace N] [ChartedSpace F N] {f : M → N}
+    (hf : IsLocalDiffeomorph (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ F) ω f) :
+    IsLocalDiffeomorph (((modelWithCornersSelf ℂ E)).prod (modelWithCornersSelf ℂ ℂ))
+      (((modelWithCornersSelf ℂ F)).prod (modelWithCornersSelf ℂ ℂ)) ω
+      (fun q : M × ℂ => (f q.1, q.2)) :=
+  fun p => isLocalDiffeomorphAt_prodLine (hf p.1)
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Foundations/Complex.lean b/LeanPool/HopfProblem/Foundations/Complex.lean
new file mode 100644
index 000000000..258fed2de
--- /dev/null
+++ b/LeanPool/HopfProblem/Foundations/Complex.lean
@@ -0,0 +1,955 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Toric.DiagonalQuotient1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods6
+import all LeanPool.HopfProblem.Toric.DiagonalQuotient1
+
+/-!
+# Hopf problem: foundations · complex
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def TriangleRiemannNormalization.discCoordinate {K : Type*} [TopologicalSpace K]
+    (e : K ≃ₜ Metric.closedBall (0 : ℂ) 1) (x : K) : ℂ :=
+  e x
+
+private theorem
+    TriangleRiemannNormalization.discCoordinate_injective {K : Type*} [TopologicalSpace K]
+    (e : K ≃ₜ Metric.closedBall (0 : ℂ) 1) : Function.Injective (discCoordinate e) := by
+  intro x y he
+  exact e.injective (Subtype.ext he)
+
+private theorem TriangleRiemannNormalization.discCoordinate_ne {K : Type*} [TopologicalSpace K]
+    (e : K ≃ₜ Metric.closedBall (0 : ℂ) 1) {x y : K} (hxy : x ≠ y) :
+    discCoordinate e x ≠ discCoordinate e y := fun he => hxy (discCoordinate_injective e he)
+
+private theorem TriangleRiemannNormalization.discCoordinate_norm_le {K : Type*} [TopologicalSpace K]
+    (e : K ≃ₜ Metric.closedBall (0 : ℂ) 1) (x : K) : ‖discCoordinate e x‖ ≤ 1 := by
+  simpa only [discCoordinate, Metric.mem_closedBall, dist_zero_right] using (e x).property
+
+private def TriangleRiemannNormalization.punctureMap {K : Type*} [TopologicalSpace K]
+    (e : K ≃ₜ Metric.closedBall (0 : ℂ) 1) (pinf : K) (x : {x : K | x ≠ pinf}) :
+    RiemannSphere.closedDiscWithoutPole (discCoordinate e pinf) :=
+  ⟨discCoordinate e x, discCoordinate_norm_le e x, discCoordinate_ne e x.property⟩
+
+private theorem
+    TriangleRiemannNormalization.punctureMap_isEmbedding {K : Type*} [TopologicalSpace K]
+    (e : K ≃ₜ Metric.closedBall (0 : ℂ) 1) (pinf : K) :
+    Topology.IsEmbedding (punctureMap e pinf) := by
+  have hs :
+    Topology.IsEmbedding
+      (Subtype.val : RiemannSphere.closedDiscWithoutPole (discCoordinate e pinf) → ℂ) :=
+    Topology.IsEmbedding.subtypeVal
+  have he : Topology.IsEmbedding (fun x : {x : K | x ≠ pinf} => e (x : K)) :=
+    e.isEmbedding.comp Topology.IsEmbedding.subtypeVal
+  have hv : Topology.IsEmbedding (Subtype.val : Metric.closedBall (0 : ℂ) 1 → ℂ) :=
+    Topology.IsEmbedding.subtypeVal
+  have hcomp : Topology.IsEmbedding (fun x : {x : K | x ≠ pinf} => (e (x : K) : ℂ)) := hv.comp he
+  exact hs.of_comp_iff.mp hcomp
+
+private theorem TriangleRiemannNormalization.punctureMap_surjective {K : Type*} [TopologicalSpace K]
+    (e : K ≃ₜ Metric.closedBall (0 : ℂ) 1) (pinf : K) :
+    Function.Surjective (punctureMap e pinf) := by
+  intro z
+  let y : Metric.closedBall (0 : ℂ) 1 :=
+    ⟨z, by simpa only [Metric.mem_closedBall, dist_zero_right] using z.property.1⟩
+  have hx : e.symm y ≠ pinf := by
+    intro he
+    apply z.property.2
+    have h := congrArg (discCoordinate e) he
+    simpa only [discCoordinate, Homeomorph.apply_symm_apply] using h
+  refine ⟨⟨e.symm y, hx⟩, ?_⟩
+  apply Subtype.ext
+  exact congrArg (fun w : Metric.closedBall (0 : ℂ) 1 => (w : ℂ)) (e.apply_symm_apply y)
+
+private def TriangleRiemannNormalization.punctureHomeomorph {K : Type*} [TopologicalSpace K]
+    (e : K ≃ₜ Metric.closedBall (0 : ℂ) 1) (pinf : K) :
+    {x : K | x ≠ pinf} ≃ₜ RiemannSphere.closedDiscWithoutPole (discCoordinate e pinf) :=
+  (punctureMap_isEmbedding e pinf).toHomeomorphOfSurjective (punctureMap_surjective e pinf)
+
+private def TriangleRiemannNormalization.normalizationHomeomorph {K : Type*} [TopologicalSpace K]
+    (e : K ≃ₜ Metric.closedBall (0 : ℂ) 1) (p0 p1 pinf : K) (h01 : p0 ≠ p1) (h0inf : p0 ≠ pinf)
+    (h1inf : p1 ≠ pinf) (h0 : ‖discCoordinate e p0‖ = 1) (h1 : ‖discCoordinate e p1‖ = 1)
+    (hinf : ‖discCoordinate e pinf‖ = 1) :
+    {x : K | x ≠ pinf} ≃ₜ
+      RiemannSphere.closedOrientedHalfPlane
+        (RiemannSphere.MobiusCircle.orientation (discCoordinate e p0) (discCoordinate e p1)
+          (discCoordinate e pinf)) :=
+  (punctureHomeomorph e pinf).trans
+    (RiemannSphere.closedDiscHalfPlaneHomeomorph (discCoordinate_ne e h01)
+      (discCoordinate_ne e h0inf) (discCoordinate_ne e h1inf) h0 h1 hinf)
+
+@[simp]
+private theorem TriangleRiemannNormalization.normalizationHomeomorph_apply {K : Type*}
+    [TopologicalSpace K] (e : K ≃ₜ Metric.closedBall (0 : ℂ) 1) (p0 p1 pinf : K) (h01 : p0 ≠ p1)
+    (h0inf : p0 ≠ pinf) (h1inf : p1 ≠ pinf) (h0 : ‖discCoordinate e p0‖ = 1)
+    (h1 : ‖discCoordinate e p1‖ = 1) (hinf : ‖discCoordinate e pinf‖ = 1)
+    (x : {x : K | x ≠ pinf}) :
+    (normalizationHomeomorph e p0 p1 pinf h01 h0inf h1inf h0 h1 hinf x : ℂ) =
+      RiemannSphere.MobiusCircle.crossRatio (discCoordinate e p0) (discCoordinate e p1)
+        (discCoordinate e pinf) (discCoordinate e x) := by
+  exact
+    RiemannSphere.closedDiscHalfPlaneHomeomorph_apply (discCoordinate_ne e h01)
+      (discCoordinate_ne e h0inf) (discCoordinate_ne e h1inf) h0 h1 hinf
+      (punctureHomeomorph e pinf x)
+
+private theorem TriangleRiemannNormalization.normalizationHomeomorph_first {K : Type*}
+    [TopologicalSpace K] (e : K ≃ₜ Metric.closedBall (0 : ℂ) 1) (p0 p1 pinf : K) (h01 : p0 ≠ p1)
+    (h0inf : p0 ≠ pinf) (h1inf : p1 ≠ pinf) (h0 : ‖discCoordinate e p0‖ = 1)
+    (h1 : ‖discCoordinate e p1‖ = 1) (hinf : ‖discCoordinate e pinf‖ = 1) :
+    (normalizationHomeomorph e p0 p1 pinf h01 h0inf h1inf h0 h1 hinf ⟨p0, h0inf⟩ : ℂ) = 0 := by
+  rw [normalizationHomeomorph_apply]
+  exact RiemannSphere.MobiusCircle.crossRatio_at_zero _ _ _
+
+private theorem TriangleRiemannNormalization.normalizationHomeomorph_second {K : Type*}
+    [TopologicalSpace K] (e : K ≃ₜ Metric.closedBall (0 : ℂ) 1) (p0 p1 pinf : K) (h01 : p0 ≠ p1)
+    (h0inf : p0 ≠ pinf) (h1inf : p1 ≠ pinf) (h0 : ‖discCoordinate e p0‖ = 1)
+    (h1 : ‖discCoordinate e p1‖ = 1) (hinf : ‖discCoordinate e pinf‖ = 1) :
+    (normalizationHomeomorph e p0 p1 pinf h01 h0inf h1inf h0 h1 hinf ⟨p1, h1inf⟩ : ℂ) = 1 := by
+  rw [normalizationHomeomorph_apply]
+  exact
+    RiemannSphere.MobiusCircle.crossRatio_at_one (discCoordinate_ne e h01.symm)
+      (discCoordinate_ne e h1inf)
+
+private theorem TriangleRiemannNormalization.normalizationHomeomorph_strict_iff {K : Type*}
+    [TopologicalSpace K] (e : K ≃ₜ Metric.closedBall (0 : ℂ) 1) (p0 p1 pinf : K) (h01 : p0 ≠ p1)
+    (h0inf : p0 ≠ pinf) (h1inf : p1 ≠ pinf) (h0 : ‖discCoordinate e p0‖ = 1)
+    (h1 : ‖discCoordinate e p1‖ = 1) (hinf : ‖discCoordinate e pinf‖ = 1)
+    (x : {x : K | x ≠ pinf}) :
+    0 <
+        RiemannSphere.MobiusCircle.orientation (discCoordinate e p0) (discCoordinate e p1)
+            (discCoordinate e pinf) *
+          (normalizationHomeomorph e p0 p1 pinf h01 h0inf h1inf h0 h1 hinf x : ℂ).im ↔
+      ‖discCoordinate e x‖ < 1 := by
+  exact
+    RiemannSphere.closedDiscHalfPlaneHomeomorph_strict_iff (discCoordinate_ne e h01)
+      (discCoordinate_ne e h0inf) (discCoordinate_ne e h1inf) h0 h1 hinf
+      (punctureHomeomorph e pinf x)
+
+private theorem TriangleRiemannNormalization.normalization_orientation_ne_zero {K : Type*}
+    [TopologicalSpace K] (e : K ≃ₜ Metric.closedBall (0 : ℂ) 1) (p0 p1 pinf : K) (h01 : p0 ≠ p1)
+    (h0inf : p0 ≠ pinf) (h1inf : p1 ≠ pinf) (h0 : ‖discCoordinate e p0‖ = 1)
+    (h1 : ‖discCoordinate e p1‖ = 1) (hinf : ‖discCoordinate e pinf‖ = 1) :
+    RiemannSphere.MobiusCircle.orientation (discCoordinate e p0) (discCoordinate e p1)
+        (discCoordinate e pinf) ≠
+      0 :=
+  RiemannSphere.MobiusCircle.orientation_ne_zero h0 h1 hinf (discCoordinate_ne e h01.symm)
+    (discCoordinate_ne e h1inf) (discCoordinate_ne e h0inf)
+
+private theorem _root_.AnalyticOnNhd.exists_finset_eq_prod_smul_nonzero {𝕜 E : Type*}
+    [NontriviallyNormedField 𝕜] [NormedAddCommGroup E] [NormedSpace 𝕜 E] {f : 𝕜 → E} {s : Set 𝕜}
+    (hfs : AnalyticOnNhd 𝕜 f s) (hs_comp : IsCompact s) (hs_conn : IsPreconnected s)
+    (hf₀ : ¬Set.EqOn f 0 s) :
+    ∃ (t : Finset 𝕜),
+      (∀ x, x ∈ t ↔ x ∈ s ∧ f x = 0) ∧
+        ∃ (g : 𝕜 → E),
+          AnalyticOnNhd 𝕜 g s ∧
+            (f = fun z ↦ (∏ x ∈ t, (z - x) ^ analyticOrderNatAt f x) • g z) ∧
+              (∀ z ∈ s, g z ≠ 0) := by
+  have hf_top :
+    ∀ {f : 𝕜 → E}, AnalyticOnNhd 𝕜 f s → ¬Set.EqOn f 0 s → ∀ x ∈ s, analyticOrderAt f x ≠ ⊤ := by
+    intro f hfs hf₀ x hx hfx
+    rw [analyticOrderAt_eq_top] at hfx
+    exact hf₀ <| hfs.eqOn_zero_of_preconnected_of_eventuallyEq_zero hs_conn hx hfx
+  obtain ⟨t, hts⟩ : ∃ t : Finset 𝕜, ∀ x, x ∈ t ↔ x ∈ s ∧ f x = 0 := by
+    use
+      hs_comp.finite_sdiff_of_mem_codiscreteWithin
+          hfs.codiscreteWithin_setOfPred_analyticOrderAt_eq_zero_or_top |>.toFinset
+    simp only [Set.Finite.mem_toFinset, Set.mem_sdiff, Set.mem_ofPred_eq, not_or,
+      analyticOrderAt_eq_zero, and_congr_right_iff]
+    push Not
+    intro x hx
+    simp [hfs _ hx, hf_top hfs hf₀ x hx]
+  use t, hts
+  induction t using Finset.cons_induction generalizing f with
+  | empty =>
+    use f, hfs
+    simpa using hts
+  | cons a t hat iht =>
+    simp only [Finset.mem_cons] at hts
+    have has : a ∈ s := (hts a).mp (.inl rfl) |>.1
+    obtain ⟨g, hga, hg₀, hfg⟩ :
+      ∃ g, AnalyticOnNhd 𝕜 g s ∧ g a ≠ 0 ∧ f = fun z ↦ (z - a) ^ analyticOrderNatAt f a • g z := by
+      classical
+      rcases hfs a has |>.analyticOrderAt_ne_top |>.mp (hf_top hfs hf₀ a has) with
+        ⟨g, hga, hg₀, hfg⟩
+      set g' := Function.update (fun z ↦ (z - a) ^ (-analyticOrderNatAt f a : ℤ) • f z) a (g a)
+      have hgg' : g =ᶠ[𝓝 a] g' := by
+        refine hfg.mono fun z hz ↦ ?_
+        rcases eq_or_ne z a with rfl | hza
+        · simp [g']
+        · simp [g', hza, hz, sub_eq_zero]
+      refine ⟨g', ?_, ?_, ?_⟩
+      · intro z hz
+        rcases eq_or_ne z a with rfl | hza
+        · exact hga.congr hgg'
+        · have : g' =ᶠ[𝓝 z] fun z ↦ (z - a) ^ (-analyticOrderNatAt f a : ℤ) • f z :=
+            eventually_ne_nhds hza |>.mono fun w hw ↦ by simp [g', hw]
+          rw [analyticAt_congr this]
+          refine .smul (.zpow ?_ (by rwa [sub_ne_zero])) (hfs z hz)
+          fun_prop
+      · simp [g', hg₀]
+      · ext z
+        rcases eq_or_ne z a with rfl | hza
+        · simpa [g'] using hfg.self_of_nhds
+        · simp [g', hza, sub_eq_zero]
+    have hgt : ∀ z, z ∈ t ↔ z ∈ s ∧ g z = 0 := by
+      rw [hfg] at hts
+      intro z
+      rcases eq_or_ne z a with rfl | hza
+      · simp [hg₀, hat]
+      · simpa [hza, sub_eq_zero] using hts z
+    have hgs₀ : ¬Set.EqOn g 0 s := by
+      intro hgs₀
+      exact hg₀ <| hgs₀ has
+    rcases iht hga hgs₀ hgt with ⟨g', hg's, hgg', hg'₀⟩
+    use g', hg's, ?_, hg'₀
+    ext z
+    rw [congrFun hfg, congrFun hgg', Finset.prod_cons, SemigroupAction.mul_smul]
+    congr 2
+    refine Finset.prod_congr rfl fun x hx ↦ ?_
+    congr 1
+    conv_rhs => rw [hfg, analyticOrderNatAt]
+    rw [← Pi.smul_def', analyticOrderAt_smul]
+    · suffices analyticOrderAt (fun z ↦ (z - a) ^ analyticOrderNatAt f a) x = 0 by
+        rw [this]
+        simp [analyticOrderNatAt]
+      rw [analyticOrderAt_eq_zero]
+      right
+      simp [sub_eq_zero, ne_of_mem_of_not_mem hx hat]
+    · fun_prop
+    · exact hga _ <| ((hts _).mp <| .inr hx).1
+
+private theorem
+    _root_.Complex.circleIntegral_logDeriv_eq_finsum_analyticOrderNatAdd {f : ℂ → ℂ} {c : ℂ}
+    {R : ℝ} (hf : AnalyticOnNhd ℂ f (Metric.closedBall c R))
+    (hf₀ : ∀ z ∈ Metric.sphere c R, f z ≠ 0) (hR : 0 ≤ R) :
+    ∮ z in C(c, R), logDeriv f z =
+      (2 * (Real.pi) * Complex.I) * ∑ᶠ z ∈ Metric.ball c R, analyticOrderNatAt f z := by
+  rcases
+    hf.exists_finset_eq_prod_smul_nonzero (ProperSpace.isCompact_closedBall _ _)
+      Metric.isPreconnected_closedBall
+      (fun hf₀' ↦
+        ((NormedSpace.sphere_nonempty (x := c)).mpr hR).elim fun x hx ↦
+          hf₀ x hx <| hf₀' <| Metric.sphere_subset_closedBall hx) with
+    ⟨t, htR, g, hgR, hfg, hg₀⟩
+  have hne : ∀ z ∈ Metric.sphere c R, ∀ w ∈ t, z - w ≠ 0 := by
+    intro z hz w hw
+    rw [sub_ne_zero]
+    rintro rfl
+    rw [htR] at hw
+    exact hf₀ _ hz hw.2
+  have ht_sub : ↑t ⊆ Metric.ball c R := by
+    intro w hw
+    rw [Finset.mem_coe, htR, ← Metric.sphere_union_ball, Set.mem_union] at hw
+    exact hw.1.resolve_left fun hw' ↦ hf₀ w hw' hw.2
+  have hleft :
+    Set.EqOn (logDeriv f) (fun z ↦ (∑ w ∈ t, analyticOrderNatAt f w / (z - w)) + logDeriv g z)
+      (Metric.sphere c R) := by
+    intro z hz
+    conv_lhs => rw [hfg]
+    simp only [smul_eq_mul]
+    rw [logDeriv_mul, logDeriv_prod]
+    · congr 1
+      refine Finset.sum_congr rfl fun w hw ↦ ?_
+      rw [logDeriv_fun_pow (by fun_prop), logDeriv, Pi.div_apply, deriv_sub_const, deriv_id'']
+      simp [div_eq_mul_inv]
+    · intro w hw
+      apply pow_ne_zero
+      exact hne z hz w hw
+    · intros
+      fun_prop
+    · rw [Finset.prod_ne_zero_iff]
+      exact fun w hw ↦ pow_ne_zero _ (hne z hz w hw)
+    · exact hg₀ z (Metric.sphere_subset_closedBall hz)
+    · fun_prop
+    · exact hgR _ (Metric.sphere_subset_closedBall hz) |>.differentiableAt
+  rw [finsum_mem_eq_sum_of_subset (t := t), circleIntegral.integral_congr hR hleft]
+  · have hdg : AnalyticOnNhd ℂ (logDeriv g) (Metric.closedBall c R) := hgR.deriv.div hgR hg₀
+    have hi : ∀ w ∈ t, CircleIntegrable (fun z ↦ analyticOrderNatAt f w / (z - w)) c R := by
+      intro w hw
+      simp only [div_eq_mul_inv]
+      refine .const_mul (circleIntegrable_sub_inv_iff.mpr <| .inr fun hw' ↦ ?_) _
+      rw [abs_of_nonneg hR] at hw'
+      exact hne w hw' w hw (sub_self _)
+    rw [circleIntegral.integral_add, circleIntegral.integral_fun_sum,
+      DiffContOnCl.circleIntegral_eq_zero hR, add_zero, Nat.cast_sum, Finset.mul_sum]
+    · refine Finset.sum_congr rfl fun w hw ↦ ?_
+      rw [Complex.circleIntegral_div_sub_of_differentiable_on_off_countable Set.countable_empty]
+      · exact ht_sub hw
+      · fun_prop
+      · intros; fun_prop
+    · exact hdg.differentiableOn.diffContOnCl_ball subset_rfl
+    · exact hi
+    · exact .fun_sum _ hi
+    · exact hdg.continuousOn.mono Metric.sphere_subset_closedBall |>.circleIntegrable hR
+  · rintro z ⟨hzc, hz⟩
+    rw [Function.mem_support, analyticOrderNatAt, ne_eq, ENat.toNat_eq_zero, not_or,
+      analyticOrderAt_eq_zero, not_or, Classical.not_not, ne_eq, Classical.not_not] at hz
+    replace hz := hz.1.2
+    rw [hfg, smul_eq_zero, Finset.prod_eq_zero_iff] at hz
+    rcases hz.resolve_right (hg₀ z <| Metric.ball_subset_closedBall hzc) with ⟨w, hwt, hzw⟩
+    exact (sub_eq_zero.mp (eq_zero_of_pow_eq_zero hzw)).symm ▸ hwt
+  · exact ht_sub
+
+private theorem _root_.Complex.eqOn_zero_or_forall_ne_zero_of_tendstoLocallyUniformlyOn {ι : Type*}
+    {U : Set ℂ} {l : Filter ι} [l.NeBot] [l.IsCountablyGenerated] {F : ι → ℂ → ℂ} {f : ℂ → ℂ}
+    (hUo : IsOpen U) (hUc : IsPreconnected U) (hF : ∀ᶠ i in l, ∀ x ∈ U, F i x ≠ 0)
+    (hFd : ∀ᶠ i in l, DifferentiableOn ℂ (F i) U) (hf : TendstoLocallyUniformlyOn F f l U) :
+    Set.EqOn f 0 U ∨ ∀ x ∈ U, f x ≠ 0 := by
+  have hfd : DifferentiableOn ℂ f U := hf.differentiableOn hFd hUo
+  rw [Classical.or_iff_not_imp_left]
+  intro hf₀ c hc hfc
+  rcases hfd.analyticAt (hUo.mem_nhds hc) |>.eventually_eq_zero_or_eventually_ne_zero with hfc₀ |
+    hfc₀
+  · exact
+      hf₀ <| hfd.analyticOnNhd hUo |>.eqOn_zero_of_preconnected_of_eventuallyEq_zero hUc hc hfc₀
+  · obtain ⟨R, hR₀, hRU, hfR⟩ :
+      ∃ R > 0, Metric.closedBall c R ⊆ U ∧ ∀ w ∈ Metric.sphere c R, f w ≠ 0 := by
+      rw [eventually_nhdsWithin_iff] at hfc₀
+      rcases
+        Metric.nhds_basis_closedBall.eventually_iff.mp (hfc₀.and <| hUo.eventually_mem hc) with
+        ⟨R, hR₀, hR⟩
+      refine
+        ⟨R, hR₀, fun w hw => (hR hw).2, fun w hw =>
+          (hR <| Metric.sphere_subset_closedBall hw).1 ?_⟩
+      exact Metric.ne_of_mem_sphere hw hR₀.ne'
+    have hRU' : Metric.sphere c R ⊆ U := Metric.sphere_subset_closedBall.trans hRU
+    have hlogDeriv :
+      TendstoUniformlyOn (fun i => logDeriv (F i)) (logDeriv f) l (Metric.sphere c R) := by
+      simp only [logDeriv]
+      have h := (hf.deriv hFd hUo).mono hRU'
+      rw [← tendstoLocallyUniformlyOn_iff_tendstoUniformlyOn_of_compact (isCompact_sphere c R)]
+      refine h.fun_div₀ (hf.mono hRU') ?_ ?_ ?_
+      · exact hfd.analyticOnNhd hUo |>.deriv |>.continuousOn |>.mono hRU'
+      · exact hfd.continuousOn.mono hRU'
+      · exact hfR
+    have hcirc :
+      Filter.Tendsto (fun i => ∮ z in C(c, R), logDeriv (F i) z) l
+        (𝓝 (∮ z in C(c, R), logDeriv f z)) := by
+      apply hlogDeriv.tendsto_circleIntegral_of_continuousOn hR₀.le
+      filter_upwards [hF, hFd] with i hi₀ hiD
+      refine .div ?_ (hiD.continuousOn.mono hRU') ?_
+      · exact hiD.analyticOnNhd hUo |>.deriv |>.continuousOn |>.mono hRU'
+      · exact fun x hx => hi₀ x (hRU' hx)
+    have H₀ : ∀ᶠ i in l, ∮ (z : ℂ) in C(c, R), logDeriv (F i) z = 0 := by
+      filter_upwards [hF, hFd] with i hi hid
+      apply DiffContOnCl.circleIntegral_eq_zero hR₀.le
+      exact (hid.deriv hUo).div hid hi |>.diffContOnCl_ball hRU
+    have hzero := hcirc.congr' H₀
+    rw [tendsto_const_nhds_iff, eq_comm,
+      Complex.circleIntegral_logDeriv_eq_finsum_analyticOrderNatAdd, mul_eq_zero] at hzero
+    · replace hzero := hzero.resolve_left (by simp)
+      norm_cast at hzero
+      refine ne_of_gt ?_ hzero
+      apply finsum_cond_pos
+      · simp
+      · use c
+        suffices ∃ᶠ (x : ℂ) in 𝓝 c, f x ≠ 0 by
+          simpa [pos_iff_ne_zero, analyticOrderNatAt, analyticOrderAt_eq_zero, hfc,
+            analyticOrderAt_eq_top, hfd.analyticAt (hUo.mem_nhds hc), hR₀]
+        rw [eventually_nhdsWithin_iff] at hfc₀
+        refine Filter.Frequently.mp ?_ hfc₀
+        rw [Filter.frequently_iff_neBot, Set.ofPred_mem_eq, ← nhdsWithin]
+        infer_instance
+      · have hanalytic := (hfd.analyticOnNhd hUo).mono hRU
+        have hfinite :=
+          (ProperSpace.isCompact_closedBall c R).finite_sdiff_of_mem_codiscreteWithin
+            hanalytic.codiscreteWithin_setOfPred_analyticOrderAt_eq_zero_or_top
+        refine hfinite.subset ?_
+        simp +contextual [Set.subset_def, analyticOrderNatAt, le_of_lt]
+    · exact hfd.analyticOnNhd hUo |>.mono hRU
+    · exact hfR
+    · exact hR₀.le
+
+private theorem
+    _root_.Complex.eqOn_const_or_injOn_of_tendstoLocallyUniformlyOn {ι : Type*} {U : Set ℂ}
+    {l : Filter ι} [l.NeBot] [l.IsCountablyGenerated] {F : ι → ℂ → ℂ} {f : ℂ → ℂ} (hUo : IsOpen U)
+    (hUc : IsPreconnected U) (hF : ∀ᶠ i in l, Set.InjOn (F i) U)
+    (hFd : ∀ᶠ i in l, DifferentiableOn ℂ (F i) U) (hf : TendstoLocallyUniformlyOn F f l U) :
+    (∃ C, ∀ x ∈ U, f x = C) ∨ Set.InjOn f U := by
+  rw [Classical.or_iff_not_imp_left]
+  intro hfU x hx y hy hxy
+  by_contra! hne
+  obtain ⟨r, hr₀, hrU, hry⟩ : ∃ r > 0, Metric.ball x r ⊆ U ∧ y ∉ Metric.ball x r := by
+    simp_rw [← Set.subset_compl_singleton_iff, ← Set.subset_inter_iff, ← Metric.mem_nhds_iff]
+    simp [hUo.mem_nhds hx, hne]
+  have hf_sub :
+    TendstoLocallyUniformlyOn (fun i z => F i z - F i y) (f · - f y) l (Metric.ball x r) := by
+    refine
+      (hf.mono hrU).fun_sub <|
+        (Filter.Tendsto.tendstoUniformly_const ?_).tendstoUniformlyOn.tendstoLocallyUniformlyOn
+    exact hf.tendsto_at hy
+  refine
+    Complex.eqOn_zero_or_forall_ne_zero_of_tendstoLocallyUniformlyOn Metric.isOpen_ball
+        Metric.isPreconnected_ball (hF.mono fun i hi z hz => ?_) ?_ hf_sub |>.resolve_left
+      ?_ x (by simpa) (by rwa [sub_eq_zero])
+  · rw [sub_ne_zero, hi.ne_iff (hrU hz) hy]
+    exact ne_of_mem_of_not_mem hz hry
+  · exact hFd.mono fun i hi => hi.mono hrU |>.sub_const _
+  · intro heq
+    refine hfU ⟨f y, ?_⟩
+    refine
+      hf.differentiableOn hFd hUo |>.analyticOnNhd hUo |>.eqOn_of_preconnected_of_eventuallyEq
+        analyticOnNhd_const hUc hx ?_
+    exact
+      heq.eventuallyEq_of_mem (Metric.ball_mem_nhds _ hr₀) |>.mono fun z hz => sub_eq_zero.mp hz
+
+private theorem
+    _root_.Complex.exists_injective_not_dense_image_deriv_ne_zero {U : Set ℂ} (hUo : IsOpen U)
+    (hUc : IsSimplyConnected U) (hU : U ≠ Set.univ) :
+    ∃ f : ℂ → ℂ, Function.Injective f ∧ ¬Dense (f '' U) ∧ ∀ z ∈ U, deriv f z ≠ 0 := by
+  wlog hU₀ : 0 ∉ U
+  · rw [Set.ne_univ_iff_exists_notMem] at hU
+    rcases hU with ⟨a, ha⟩
+    specialize
+      this (hUo.vadd (-a)) (by simpa) (by simp [hU])
+        (by simpa [Set.mem_vadd_set_iff_neg_vadd_mem])
+    rcases this with ⟨f, hf_inj, hf_dense, hdf⟩
+    refine ⟨f ∘ (-a + ·), hf_inj.comp (add_right_injective (-a)), ?_, fun z hz ↦ ?_⟩
+    · simpa only [← Set.image_vadd, Set.image_image] using! hf_dense
+    · simpa [Function.comp_def, deriv_comp_const_add] using hdf (-a + z) (Set.mapsTo_image _ _ hz)
+  rcases
+    Complex.exists_continuousOn_pow_eq hUc hUo continuousOn_id (by rwa [Set.image_id])
+      two_ne_zero with
+    ⟨f, hfc, hf_inv⟩
+  replace hf_inv : Function.LeftInverse (· ^ 2) f := hf_inv
+  have hf₀ : ∀ z ∈ U, f z ≠ 0 := by
+    intro z hz hfz
+    simpa [hfz, (ne_of_mem_of_not_mem hz hU₀).symm] using hf_inv z
+  have hdf : ∀ z ∈ U, HasStrictDerivAt f (2 * f z)⁻¹ z := by
+    intro z hz
+    apply HasStrictDerivAt.of_local_left_inverse
+    · exact hfc.continuousAt <| hUo.mem_nhds hz
+    · simpa using hasStrictDerivAt_pow 2 (f z)
+    · simpa using hf₀ z hz
+    · exact .of_forall hf_inv
+  refine ⟨f, hf_inv.injective, ?_, fun z hz ↦ ?_⟩
+  · simp only [Dense, Classical.not_forall, mem_closure_iff_frequently, Filter.not_frequently]
+    rcases hUc.nonempty with ⟨x, hx⟩
+    use -f x
+    have : f '' U ∈ 𝓝 (f x) := by
+      rw [← (hdf x hx).map_nhds_eq (by simpa using hf₀ x hx)]
+      exact Filter.image_mem_map <| hUo.mem_nhds hx
+    rw [nhds_neg, Filter.eventually_neg]
+    filter_upwards [this]
+    rintro _ ⟨a, ha, rfl⟩ ⟨b, hb, hab⟩
+    obtain rfl : a = b := by
+      rw [← hf_inv b, hab]
+      simp [hf_inv a]
+    refine hf₀ a ha ?_
+    linear_combination hab / 2
+  · simpa [(hdf z hz).hasDerivAt.deriv] using hf₀ z hz
+
+private lemma _root_.Complex.exists_mapsTo_unitBall_injOn_deriv_ne_zero {U : Set ℂ} (hUo : IsOpen U)
+    (hUc : IsSimplyConnected U) (hU : U ≠ Set.univ) :
+    ∃ f : ℂ → ℂ, Set.MapsTo f U (Metric.ball 0 1) ∧ Set.InjOn f U ∧ ∀ z ∈ U, deriv f z ≠ 0 := by
+  rcases Complex.exists_injective_not_dense_image_deriv_ne_zero hUo hUc hU with
+    ⟨f, hf_inj, hfd, hdf⟩
+  obtain ⟨x, ε, hε₀, hε⟩ : ∃ (x : ℂ) (ε : ℝ), 0 < ε ∧ ∀ a ∈ U, ε < Dist.dist (f a) x := by
+    simpa [Dense, mem_closure_iff_nhds_basis Metric.nhds_basis_closedBall] using hfd
+  have hfx : ∀ z ∈ U, f z ≠ x := fun z hz ↦ by simpa using hε₀.trans (hε z hz)
+  use fun z ↦ ε / (f z - x)
+  refine ⟨?mapsTo, ?injOn, ?deriv⟩
+  case mapsTo =>
+    intro z hz
+    rw [mem_ball_zero_iff, norm_div, Complex.norm_real, Real.norm_of_nonneg hε₀.le, div_lt_one₀]
+    · simpa [dist_eq_norm] using hε z hz
+    · simpa [sub_eq_zero] using hfx z hz
+  case injOn =>
+    intro z hz w hw heq
+    simpa [div_eq_mul_inv, hε₀.ne', hf_inj.eq_iff] using heq
+  case deriv =>
+    intro z hz
+    have hdz : DifferentiableAt ℂ f z := differentiableAt_of_deriv_ne_zero (hdf z hz)
+    rw [(hasDerivAt_const _ _).fun_div (hdz.hasDerivAt.sub_const _) _ |>.deriv] <;>
+      simp [*, ne_of_gt, sub_eq_zero]
+
+private lemma _root_.Complex.UnitDisc.shift_den_ne_zero (z w : 𝔻) : 1 + conj (z : ℂ) * w ≠ 0 :=
+  (Star.star z * w).one_add_coe_ne_zero
+
+private theorem _root_.Complex.UnitDisc.norm_shiftFun_le_mo1973_19129 (z w : 𝔻) :
+    ‖(z + w : ℂ) / (1 + conj ↑z * w)‖ ≤ (‖(z : ℂ)‖ + ‖(w : ℂ)‖) / (1 + ‖(z : ℂ)‖ * ‖(w : ℂ)‖) := by
+  have hz := z.sq_norm_lt_one
+  have hw := w.sq_norm_lt_one
+  have hzw : z.re * w.re + z.im * w.im ≤ ‖(z : ℂ)‖ * ‖(w : ℂ)‖ := by
+    rw [Complex.norm_def, Complex.norm_def, ← Real.sqrt_mul, Complex.normSq_apply,
+      Complex.normSq_apply]
+    · apply Real.le_sqrt_of_sq_le
+      linear_combination (norm :=
+        { apply le_of_eq; simp; ring
+        })
+        sq_nonneg (z.re * w.im - z.im * w.re)
+    · apply Complex.normSq_nonneg
+  rw [norm_div, div_le_div_iff₀, ← sq_le_sq₀]
+  · rw [← sub_nonneg] at hzw
+    simp [mul_pow, RCLike.norm_sq_eq_def, add_sq] at hz hw ⊢
+    linear_combination 2 * mul_nonneg hzw (mul_nonneg (sub_nonneg.2 hz.le) (sub_nonneg.2 hw.le))
+  any_goals positivity
+  simpa using Complex.UnitDisc.shift_den_ne_zero z w
+
+private def _root_.Complex.UnitDisc.shiftFun_mo1973_19130 (z w : 𝔻) : 𝔻 :=
+  Complex.UnitDisc.mk ((z + w : ℂ) / (1 + conj ↑z * w)) <|
+    by
+    refine (Complex.UnitDisc.norm_shiftFun_le_mo1973_19129 _ _).trans_lt ?_
+    rw [div_lt_one (by positivity)]
+    nlinarith only [z.norm_lt_one, w.norm_lt_one]
+
+private theorem _root_.Complex.UnitDisc.coe_shiftFun_mo1973_19131 (z w : 𝔻) :
+    (Complex.UnitDisc.shiftFun_mo1973_19130 z w : ℂ) = (z + w) / (1 + conj ↑z * w) :=
+  rfl
+
+private theorem _root_.Complex.UnitDisc.shiftFun_eq_iff_mo1973_19132 {z w u : 𝔻} :
+    Complex.UnitDisc.shiftFun_mo1973_19130 z w = u ↔ (z + w : ℂ) = u + u * conj ↑z * w := by
+  rw [← Complex.UnitDisc.coe_inj, Complex.UnitDisc.coe_shiftFun_mo1973_19131,
+    div_eq_iff (Complex.UnitDisc.shift_den_ne_zero _ _)]
+  ring_nf
+
+private theorem _root_.Complex.UnitDisc.shiftFun_neg_apply_shiftFun_mo1973_19133 (z w : 𝔻) :
+    Complex.UnitDisc.shiftFun_mo1973_19130 (-z) (Complex.UnitDisc.shiftFun_mo1973_19130 z w) =
+      w := by
+  rw [Complex.UnitDisc.shiftFun_eq_iff_mo1973_19132, Complex.UnitDisc.coe_shiftFun_mo1973_19131,
+    add_div_eq_mul_add_div, ← mul_div_assoc, add_div_eq_mul_add_div]
+  · simp; ring
+  all_goals exact Complex.UnitDisc.shift_den_ne_zero z w
+
+private def _root_.Complex.UnitDisc.shift (z : 𝔻) : 𝔻 ≃ 𝔻
+    where
+  toFun := Complex.UnitDisc.shiftFun_mo1973_19130 z
+  invFun := Complex.UnitDisc.shiftFun_mo1973_19130 (-z)
+  left_inv := Complex.UnitDisc.shiftFun_neg_apply_shiftFun_mo1973_19133 _
+  right_inv := by
+    intro w
+    simpa using Complex.UnitDisc.shiftFun_neg_apply_shiftFun_mo1973_19133 (-z) w
+
+private theorem _root_.Complex.UnitDisc.coe_shift (z w : 𝔻) :
+    (Complex.UnitDisc.shift z w : ℂ) = (z + w) / (1 + conj ↑z * w) := by rfl
+
+private theorem _root_.Complex.UnitDisc.shift_eq_iff {z w u : 𝔻} :
+    Complex.UnitDisc.shift z w = u ↔ (z + w : ℂ) = u + u * conj ↑z * w :=
+  Complex.UnitDisc.shiftFun_eq_iff_mo1973_19132
+
+private theorem _root_.Complex.UnitDisc.symm_shift (z : 𝔻) :
+    (Complex.UnitDisc.shift z).symm = Complex.UnitDisc.shift (-z) := by
+  ext1
+  rfl
+
+@[simp]
+private theorem
+    _root_.Complex.UnitDisc.shift_apply_zero (z : 𝔻) : Complex.UnitDisc.shift z 0 = z := by
+  simp [Complex.UnitDisc.shift_eq_iff]
+
+@[simp]
+private theorem _root_.Complex.UnitDisc.shift_eq_zero_iff {z w : 𝔻} :
+    Complex.UnitDisc.shift z w = 0 ↔ w = -z := by
+  rw [← Equiv.eq_symm_apply, Complex.UnitDisc.symm_shift, Complex.UnitDisc.shift_apply_zero]
+
+@[simp]
+private theorem _root_.Complex.UnitDisc.shift_neg_apply_self (z : 𝔻) :
+    Complex.UnitDisc.shift (-z) z = 0 := by simp
+
+@[simp]
+private theorem _root_.Complex.UnitDisc.shift_neg_apply_shift (z w : 𝔻) :
+    Complex.UnitDisc.shift (-z) (Complex.UnitDisc.shift z w) = w := by
+  rw [← Complex.UnitDisc.symm_shift, Equiv.symm_apply_apply]
+
+@[fun_prop]
+private theorem _root_.Complex.UnitDisc.continuous_shift (z : 𝔻) :
+    Continuous (Complex.UnitDisc.shift z) := by
+  rw [Complex.UnitDisc.isEmbedding_coe.continuous_iff]
+  change Continuous (fun w : 𝔻 ↦ (Complex.UnitDisc.shift z w : ℂ))
+  simp only [Complex.UnitDisc.coe_shift]
+  exact
+    (continuous_const.add Complex.UnitDisc.continuous_coe).div
+      (continuous_const.add (continuous_const.mul Complex.UnitDisc.continuous_coe))
+      (Complex.UnitDisc.shift_den_ne_zero z)
+
+private theorem
+    _root_.Complex.UnitDisc.hasDerivWithinAt_shift_comp {f : ℂ → Complex.UnitDisc} {z f' : ℂ}
+    {s : Set ℂ} (w : Complex.UnitDisc) (hf : HasDerivWithinAt (fun x ↦ ↑(f x)) f' s z) :
+    HasDerivWithinAt (fun x ↦ w.shift (f x) : ℂ → ℂ)
+      ((1 - ‖(w : ℂ)‖ ^ 2) / (1 + conj ↑w * f z) ^ 2 * f') s z := by
+  simp only [Complex.UnitDisc.coe_shift]
+  refine
+    ((hf.const_add (w : ℂ)).fun_div ((hf.const_mul (conj (w : ℂ))).const_add 1)
+          (Complex.UnitDisc.shift_den_ne_zero w (f z))).congr_deriv
+      ?_
+  rw [← Complex.mul_conj']
+  ring
+
+private theorem _root_.Complex.UnitDisc.hasDerivAt_shift_comp {f : ℂ → Complex.UnitDisc} {z f' : ℂ}
+    (w : Complex.UnitDisc) (hf : HasDerivAt (fun x ↦ ↑(f x)) f' z) :
+    HasDerivAt (fun x ↦ w.shift (f x) : ℂ → ℂ)
+      ((1 - ‖(w : ℂ)‖ ^ 2) / (1 + conj ↑w * f z) ^ 2 * f') z :=
+  (Complex.UnitDisc.hasDerivWithinAt_shift_comp w hf.hasDerivWithinAt).hasDerivAt Filter.univ_mem
+
+@[simp]
+private theorem
+    _root_.Complex.UnitDisc.differentiableWithinAt_shift_comp_iff {f : ℂ → Complex.UnitDisc}
+    {z : ℂ} {s : Set ℂ} (w : Complex.UnitDisc) :
+    DifferentiableWithinAt ℂ (fun x ↦ w.shift (f x) : ℂ → ℂ) s z ↔
+      DifferentiableWithinAt ℂ (f · : ℂ → ℂ) s z := by
+  refine
+    ⟨fun h ↦ ?_, fun h ↦
+      (Complex.UnitDisc.hasDerivWithinAt_shift_comp w h.hasDerivWithinAt).differentiableWithinAt⟩
+  simpa using
+    (Complex.UnitDisc.hasDerivWithinAt_shift_comp (-w) h.hasDerivWithinAt).differentiableWithinAt
+
+@[simp]
+private theorem _root_.Complex.UnitDisc.differentiableOn_shift_comp_iff {f : ℂ → Complex.UnitDisc}
+    {s : Set ℂ} (w : Complex.UnitDisc) :
+    DifferentiableOn ℂ (fun x ↦ w.shift (f x) : ℂ → ℂ) s ↔ DifferentiableOn ℂ (f · : ℂ → ℂ) s := by
+  simp [DifferentiableOn]
+
+@[simp]
+private theorem
+    _root_.Complex.UnitDisc.differentiableAt_shift_comp_iff {f : ℂ → Complex.UnitDisc} {z : ℂ}
+    (w : Complex.UnitDisc) :
+    DifferentiableAt ℂ (fun x ↦ w.shift (f x) : ℂ → ℂ) z ↔ DifferentiableAt ℂ (f · : ℂ → ℂ) z := by
+  refine
+    ⟨fun h ↦ ?_, fun h ↦ (Complex.UnitDisc.hasDerivAt_shift_comp w h.hasDerivAt).differentiableAt⟩
+  simpa using (Complex.UnitDisc.hasDerivAt_shift_comp (-w) h.hasDerivAt).differentiableAt
+
+@[simp]
+private theorem _root_.Complex.UnitDisc.deriv_shift_comp (f : ℂ → Complex.UnitDisc) (z : ℂ)
+    (w : Complex.UnitDisc) :
+    deriv (fun x ↦ w.shift (f x) : ℂ → ℂ) z =
+      (1 - ‖(w : ℂ)‖ ^ 2) / (1 + conj ↑w * f z) ^ 2 * deriv (f · : ℂ → ℂ) z := by
+  by_cases hfd : DifferentiableAt ℂ (f · : ℂ → ℂ) z
+  · exact (Complex.UnitDisc.hasDerivAt_shift_comp w hfd.hasDerivAt).deriv
+  · rw [deriv_zero_of_not_differentiableAt hfd, deriv_zero_of_not_differentiableAt,
+      MulZeroClass.mul_zero]
+    simpa using hfd
+
+private theorem _root_.Complex.UnitDisc.deriv_shift_comp_eq_zero (f : ℂ → Complex.UnitDisc) (z : ℂ)
+    (w : Complex.UnitDisc) :
+    deriv (fun x ↦ w.shift (f x) : ℂ → ℂ) z = 0 ↔ deriv (f · : ℂ → ℂ) z = 0 := by
+  simp only [Complex.UnitDisc.deriv_shift_comp, mul_eq_zero, div_eq_zero_iff,
+    pow_eq_zero_iff two_ne_zero, Complex.UnitDisc.shift_den_ne_zero, or_false]
+  apply or_iff_right
+  exact mod_cast sub_ne_zero.mpr w.sq_norm_lt_one.ne'
+
+private theorem _root_.Complex.exists_map_unitDisc_injOn_deriv_ne_zero₀ {U : Set ℂ} (hUo : IsOpen U)
+    (hUc : IsSimplyConnected U) (hU : U ≠ Set.univ) (x : ℂ) :
+    ∃ f : ℂ → Complex.UnitDisc,
+      f x = 0 ∧ Set.InjOn f U ∧ (∀ z ∈ U, deriv (Complex.UnitDisc.coe ∘ f) z ≠ 0) := by
+  classical
+  obtain ⟨f, hf_inj, hf_deriv⟩ :
+    ∃ f : ℂ → Complex.UnitDisc, Set.InjOn f U ∧ ∀ z ∈ U, deriv (Complex.UnitDisc.coe ∘ f) z ≠ 0 :=
+    by
+    rcases Complex.exists_mapsTo_unitBall_injOn_deriv_ne_zero hUo hUc hU with
+      ⟨f, hfU, hf_inj, hdf⟩
+    use fun z ↦ if hz : z ∈ U then .mk (f z) (by simpa using hfU hz) else 0
+    constructor
+    · simp +contextual [Set.InjOn, Complex.UnitDisc.mk_inj, hf_inj.eq_iff]
+    · intro z hz
+      convert hdf z hz using 1
+      apply Filter.EventuallyEq.deriv_eq
+      filter_upwards [hUo.mem_nhds hz] with w hw
+      simp [hw]
+  use fun z ↦ (-f x).shift (f z)
+  refine ⟨?_, (-f x).shift.injective.comp_injOn hf_inj, ?_⟩
+  · simp
+  · simpa only [Function.comp_def, ne_eq, Complex.UnitDisc.deriv_shift_comp_eq_zero]
+
+private theorem _root_.Complex.exist_map_unitDisc_injOn_norm_deriv_gt_preserves_nonzero
+    {U : Set ℂ} (hUo : IsOpen U) (hUc : IsSimplyConnected U) (hU : U ≠ Set.univ)
+    {x : ℂ} (hx : x ∈ U) {f : ℂ → Complex.UnitDisc}
+    (hdf : DifferentiableOn ℂ (Complex.UnitDisc.coe ∘ f) U) (hf₀ : f x = 0) (hf_inj : Set.InjOn f U)
+    (hsurj : ¬Set.SurjOn f U Set.univ) :
+    ∃ g : ℂ → Complex.UnitDisc, g x = 0 ∧ Set.InjOn g U ∧
+      DifferentiableOn ℂ (Complex.UnitDisc.coe ∘ g) U ∧
+      ‖deriv (Complex.UnitDisc.coe ∘ f) x‖ < ‖deriv (Complex.UnitDisc.coe ∘ g) x‖ ∧
+      ((∀ z ∈ U, deriv (Complex.UnitDisc.coe ∘ f) z ≠ 0) →
+        ∀ z ∈ U, deriv (Complex.UnitDisc.coe ∘ g) z ≠ 0) := by
+  by_cases hdf₀ : deriv (Complex.UnitDisc.coe ∘ f) x = 0
+  · rcases Complex.exists_map_unitDisc_injOn_deriv_ne_zero₀ hUo hUc hU x with ⟨g, hg₀, hg_inj, hdg⟩
+    refine ⟨g, hg₀, hg_inj, fun z hz ↦ ?_, ?_, fun _ => hdg⟩
+    · exact (differentiableAt_of_deriv_ne_zero (hdg z hz)).differentiableWithinAt
+    · simpa [hdf₀] using hdg x hx
+  obtain ⟨c, hc⟩ : ∃ c, ∀ z ∈ U, f z ≠ c := by
+    simpa [Set.SurjOn, Set.eq_univ_iff_forall] using hsurj
+  have hcf : ContinuousOn f U := by
+    rw [Complex.UnitDisc.isEmbedding_coe.continuousOn_iff]
+    exact hdf.continuousOn
+  rcases Complex.UnitDisc.exists_continuousOn_pow_eq hUc hUo
+    ((-c).continuous_shift.comp_continuousOn hcf) (by simpa) 2 with ⟨g, hgc, hgf⟩
+  have hg₀ : ∀ z ∈ U, g z ≠ 0 := by
+    intro z hz
+    suffices g z ^ (2 : ℕ+) ≠ 0 by simpa using this
+    simp [hgf, hc z hz]
+  have hdg : ∀ z ∈ U, HasDerivAt (g · : ℂ → ℂ)
+      ((1 - ‖(c : ℂ)‖ ^ 2) / (2 * g z * (1 - conj ↑c * f z) ^ 2) *
+        deriv (f · : ℂ → ℂ) z) z := by
+    intro z hz
+    refine ((hasDerivAt_pow 2 _).of_comp_left
+      (Complex.UnitDisc.continuous_coe.continuousAt.comp <| hgc.continuousAt <| hUo.mem_nhds hz)
+      (Complex.UnitDisc.hasDerivAt_shift_comp _ <| (hdf.hasDerivAt <| hUo.mem_nhds hz))
+      (by simp [hg₀ z hz])
+      (.of_forall fun a ↦ congr(Complex.UnitDisc.coe $(hgf a)))).congr_deriv ?_
+    simp [Function.comp_def, field]
+    ring
+  have hg_sq_norm (z : ℂ) : ‖(g z : ℂ)‖ ^ 2 = ‖((-c).shift (f z) : ℂ)‖ := by
+    rw [← norm_pow, ← PNat.val_ofNat, ← Complex.UnitDisc.coe_pow, hgf, Function.comp_apply]
+  have hg_norm (z : ℂ) : ‖(g z : ℂ)‖ = (Real.sqrt) ‖((-c).shift (f z) : ℂ)‖ := by
+    rw [← Real.sqrt_sq (norm_nonneg _), hg_sq_norm]
+  refine ⟨(-g x).shift ∘ g, ?map_x, ?injOn, ?deriv, ?norm_deriv, ?preserve⟩
+  case map_x => simp
+  case injOn =>
+    refine (-g x).shift.injective.comp_injOn fun z hz w hw hzw ↦ ?_
+    simpa [hgf, hf_inj.eq_iff hz hw] using congr($hzw ^ (2 : ℕ+))
+  case deriv =>
+    exact (-g x).differentiableOn_shift_comp_iff.mpr fun z hz ↦
+      (hdg z hz).differentiableAt.differentiableWithinAt
+  case norm_deriv =>
+    have hkey : ‖deriv (Complex.UnitDisc.coe ∘ ⇑(-g x).shift ∘ g) x‖ =
+        ‖deriv (f · : ℂ → ℂ) x‖ * ((Real.sqrt) ‖(c : ℂ)‖ + (Real.sqrt) ‖(c⁻¹ : ℂ)‖) / 2 := by
+      have hgx : ‖(g x : ℂ)‖ = (Real.sqrt) ‖(c : ℂ)‖ := by simp [hg_norm, hf₀]
+      simp only [Function.comp_def, Complex.UnitDisc.deriv_shift_comp, (hdg x hx).deriv,
+        norm_mul, norm_div, ← mul_assoc, Complex.conj_mul',
+        Complex.UnitDisc.coe_neg, map_neg, neg_mul]
+      conv_rhs => rw [mul_comm, mul_div_right_comm]
+      congr 1
+      norm_cast
+      have hpos₁ : 0 < 1 - ‖(c : ℂ)‖ := sub_pos.2 c.norm_lt_one
+      have hpos₂ : 0 < 1 - ‖(c : ℂ)‖ ^ 2 := sub_pos.2 c.sq_norm_lt_one
+      simp [field, hgx, hf₀, ← sub_eq_add_neg, abs_of_pos, hpos₁, hpos₂]
+      ring
+    rw [hkey, mul_div_assoc]
+    apply lt_mul_of_one_lt_right
+    · simpa using hdf₀
+    · have hc₀ : 0 < ‖(c : ℂ)‖ := by simpa [hf₀] using (hc x hx).symm
+      suffices (Real.sqrt) ‖(c : ℂ)‖ * 2 < ‖(c : ℂ)‖ + 1 by simpa [field] using this
+      have : (Real.sqrt) ‖(c : ℂ)‖ ≠ 1 := by simp [c.norm_ne_one]
+      rw [← sub_ne_zero, ← sq_pos_iff, sub_sq, Real.sq_sqrt] at this
+      · linear_combination this
+      · apply norm_nonneg
+  case preserve =>
+    intro hnonzero z hz
+    change deriv (fun a => ((-g x).shift (g a) : ℂ)) z ≠ 0
+    rw [ne_eq, Complex.UnitDisc.deriv_shift_comp_eq_zero, (hdg z hz).deriv]
+    apply mul_ne_zero
+    · apply div_ne_zero
+      · exact mod_cast sub_ne_zero.mpr c.sq_norm_lt_one.ne'
+      · refine mul_ne_zero (mul_ne_zero (by norm_num) ?_) (pow_ne_zero _ ?_)
+        · simpa using hg₀ z hz
+        · simpa only [Complex.UnitDisc.coe_neg, map_neg, neg_mul, ← sub_eq_add_neg] using
+            Complex.UnitDisc.shift_den_ne_zero (-c) (f z)
+    · exact hnonzero z hz
+
+private theorem _root_.Complex.exist_map_unitDisc_injOn_deriv_ne_zero_norm_deriv_gt {U : Set ℂ}
+    (hUo : IsOpen U) (hUc : IsSimplyConnected U) (hU : U ≠ Set.univ) {x : ℂ} (hx : x ∈ U)
+    {f : ℂ → Complex.UnitDisc} (hdf : DifferentiableOn ℂ (Complex.UnitDisc.coe ∘ f) U)
+    (hf₀ : f x = 0) (hf_inj : Set.InjOn f U) (hsurj : ¬Set.SurjOn f U Set.univ)
+    (hnonzero : ∀ z ∈ U, deriv (Complex.UnitDisc.coe ∘ f) z ≠ 0) :
+    ∃ g : ℂ → Complex.UnitDisc,
+      g x = 0 ∧
+        Set.InjOn g U ∧
+          DifferentiableOn ℂ (Complex.UnitDisc.coe ∘ g) U ∧
+            (∀ z ∈ U, deriv (Complex.UnitDisc.coe ∘ g) z ≠ 0) ∧
+              ‖deriv (Complex.UnitDisc.coe ∘ f) x‖ < ‖deriv (Complex.UnitDisc.coe ∘ g) x‖ := by
+  obtain ⟨g, hg₀, hgi, hgd, hgt, hpres⟩ :=
+    Complex.exist_map_unitDisc_injOn_norm_deriv_gt_preserves_nonzero hUo hUc hU hx hdf hf₀ hf_inj
+      hsurj
+  exact ⟨g, hg₀, hgi, hgd, hpres hnonzero, hgt⟩
+
+private def SchwarzReflection.rectangleIntegral (f : ℂ → ℂ) (z w : ℂ) : ℂ :=
+  (∫ x : ℝ in z.re..w.re, f (x + z.im * Complex.I)) -
+        (∫ x : ℝ in z.re..w.re, f (x + w.im * Complex.I)) +
+      Complex.I * (∫ y : ℝ in z.im..w.im, f (w.re + y * Complex.I)) -
+    Complex.I * (∫ y : ℝ in z.im..w.im, f (z.re + y * Complex.I))
+
+private theorem SchwarzReflection.rectangleIntegral_eq_wedges (f : ℂ → ℂ) (z w : ℂ) :
+    rectangleIntegral f z w = Complex.wedgeIntegral z w f + Complex.wedgeIntegral w z f := by
+  rw [Complex.wedgeIntegral_add_wedgeIntegral_eq]
+  rfl
+
+private theorem SchwarzReflection.horizontal_line_mem_rectangle {z w : ℂ} {x y : ℝ}
+    (hx : x ∈ [[z.re, w.re]]) (hy : y ∈ [[z.im, w.im]]) :
+    (x : ℂ) + y * Complex.I ∈ Complex.Rectangle z w := by
+  simpa only [Complex.Rectangle, Complex.mem_reProdIm, Complex.add_re, Complex.ofReal_re,
+    Complex.mul_re, Complex.ofReal_im, Complex.I_re, Complex.I_im, MulZeroClass.mul_zero,
+    MulZeroClass.zero_mul, sub_zero, add_zero, Complex.add_im, Complex.mul_im, mul_one,
+    zero_add] using And.intro hx hy
+
+private theorem SchwarzReflection.continuousOn_vertical_integrable {f : ℂ → ℂ} {z w : ℂ}
+    (hf : ContinuousOn f (Complex.Rectangle z w)) {x : ℝ} (hx : x ∈ [[z.re, w.re]]) {a b : ℝ}
+    (hab : [[a, b]] ⊆ [[z.im, w.im]]) :
+    IntervalIntegrable (fun y : ℝ => f (x + y * Complex.I)) MeasureTheory.MeasureSpace.volume a
+      b := by
+  apply ContinuousOn.intervalIntegrable
+  apply hf.comp (by fun_prop)
+  intro y hy
+  exact horizontal_line_mem_rectangle hx (hab hy)
+
+private theorem SchwarzReflection.rectangleIntegral_split {f : ℂ → ℂ} {z w : ℂ}
+    (hf : ContinuousOn f (Complex.Rectangle z w)) {a : ℝ} (ha : a ∈ [[z.im, w.im]]) :
+    rectangleIntegral f z w =
+      rectangleIntegral f z (w.re + a * Complex.I) +
+        rectangleIntegral f (z.re + a * Complex.I) w := by
+  have hz : [[z.im, a]] ⊆ [[z.im, w.im]] := Set.uIcc_subset_uIcc (Set.left_mem_uIcc) ha
+  have hw : [[a, w.im]] ⊆ [[z.im, w.im]] := Set.uIcc_subset_uIcc ha (Set.right_mem_uIcc)
+  have hright :=
+    intervalIntegral.integral_add_adjacent_intervals
+      (continuousOn_vertical_integrable hf (Set.right_mem_uIcc) hz)
+      (continuousOn_vertical_integrable hf (Set.right_mem_uIcc) hw)
+  have hleft :=
+    intervalIntegral.integral_add_adjacent_intervals
+      (continuousOn_vertical_integrable hf (Set.left_mem_uIcc) hz)
+      (continuousOn_vertical_integrable hf (Set.left_mem_uIcc) hw)
+  simp only [rectangleIntegral, Complex.add_re, Complex.ofReal_re, Complex.mul_re,
+    Complex.ofReal_im, Complex.I_re, Complex.I_im, MulZeroClass.mul_zero, sub_zero, add_zero,
+    Complex.add_im, Complex.mul_im, mul_one, zero_add]
+  rw [← hright, ← hleft]
+  ring
+
+private theorem SchwarzReflection.rectangle_split_lower_subset {z w : ℂ} {a : ℝ}
+    (ha : a ∈ [[z.im, w.im]]) :
+    Complex.Rectangle z (w.re + a * Complex.I) ⊆ Complex.Rectangle z w := by
+  have hsub : [[z.im, a]] ⊆ [[z.im, w.im]] := Set.uIcc_subset_uIcc Set.left_mem_uIcc ha
+  intro x hx
+  simp only [Complex.Rectangle, Complex.mem_reProdIm, Complex.add_re, Complex.ofReal_re,
+    Complex.mul_re, Complex.ofReal_im, Complex.I_re, Complex.I_im, MulZeroClass.mul_zero,
+    sub_zero, add_zero, Complex.add_im, Complex.mul_im, mul_one, zero_add] at hx ⊢
+  exact ⟨hx.1, hsub hx.2⟩
+
+private theorem SchwarzReflection.rectangle_split_upper_subset {z w : ℂ} {a : ℝ}
+    (ha : a ∈ [[z.im, w.im]]) :
+    Complex.Rectangle (z.re + a * Complex.I) w ⊆ Complex.Rectangle z w := by
+  have hsub : [[a, w.im]] ⊆ [[z.im, w.im]] := Set.uIcc_subset_uIcc ha Set.right_mem_uIcc
+  intro x hx
+  simp only [Complex.Rectangle, Complex.mem_reProdIm, Complex.add_re, Complex.ofReal_re,
+    Complex.mul_re, Complex.ofReal_im, Complex.I_re, Complex.I_im, MulZeroClass.mul_zero,
+    sub_zero, add_zero, Complex.add_im, Complex.mul_im, mul_one, zero_add] at hx ⊢
+  exact ⟨hx.1, hsub hx.2⟩
+
+private theorem
+    SchwarzReflection.rectangleIntegral_eq_zero_of_axis_not_interior {f : ℂ → ℂ} {z w : ℂ}
+    (hf : ContinuousOn f (Complex.Rectangle z w))
+    (hd : ∀ x ∈ Complex.Rectangle z w, x.im ≠ 0 → DifferentiableAt ℂ f x)
+    (haxis : (0 : ℝ) ∉ Set.Ioo (Min.min z.im w.im) (Max.max z.im w.im)) :
+    rectangleIntegral f z w = 0 := by
+  apply
+    Complex.integral_boundary_rect_eq_zero_of_differentiable_on_off_countable f z w ∅
+      Set.countable_empty hf
+  intro x hx
+  have hx' := hx.1
+  simp only [Complex.mem_reProdIm, Set.mem_Ioo] at hx'
+  apply hd x
+  · exact ⟨⟨hx'.1.1.le, hx'.1.2.le⟩, ⟨hx'.2.1.le, hx'.2.2.le⟩⟩
+  · intro hzero
+    apply haxis
+    simpa only [hzero, Set.mem_Ioo] using hx'.2
+
+private theorem SchwarzReflection.zero_not_mem_open_interval_to_zero (a : ℝ) :
+    (0 : ℝ) ∉ Set.Ioo (Min.min a 0) (Max.max a 0) := by
+  rcases le_total a 0 with h | h
+  · simp [min_eq_left h, max_eq_right h]
+  · simp [min_eq_right h, max_eq_left h]
+
+public
+theorem SchwarzReflection.differentiableOn_of_continuousOn_off_real {U : Set ℂ} (hU : IsOpen U)
+    {f : ℂ → ℂ} (hf : ContinuousOn f U) (hd : ∀ z ∈ U, z.im ≠ 0 → DifferentiableAt ℂ f z) :
+    DifferentiableOn ℂ f U := by
+  apply (Complex.isConservativeOn_and_continuousOn_iff_isDifferentiableOn hU).mp
+  refine ⟨?_, hf⟩
+  intro z w hzw
+  rw [← add_eq_zero_iff_eq_neg, ← rectangleIntegral_eq_wedges]
+  have hc := hf.mono hzw
+  have hd' : ∀ x ∈ Complex.Rectangle z w, x.im ≠ 0 → DifferentiableAt ℂ f x := fun x hx =>
+    hd x (hzw hx)
+  by_cases haxis : (0 : ℝ) ∈ Set.Ioo (Min.min z.im w.im) (Max.max z.im w.im)
+  · have haxis' : (0 : ℝ) ∈ [[z.im, w.im]] := ⟨haxis.1.le, haxis.2.le⟩
+    rw [rectangleIntegral_split hc haxis']
+    have hlow := rectangle_split_lower_subset (z := z) (w := w) haxis'
+    have hhigh := rectangle_split_upper_subset (z := z) (w := w) haxis'
+    have h₁ : rectangleIntegral f z (w.re + (0 : ℝ) * Complex.I) = 0 := by
+      apply
+        rectangleIntegral_eq_zero_of_axis_not_interior (hc.mono hlow)
+          (fun x hx => hd' x (hlow hx))
+      simpa using zero_not_mem_open_interval_to_zero z.im
+    have h₂ : rectangleIntegral f (z.re + (0 : ℝ) * Complex.I) w = 0 := by
+      apply
+        rectangleIntegral_eq_zero_of_axis_not_interior (hc.mono hhigh)
+          (fun x hx => hd' x (hhigh hx))
+      simpa [min_comm, max_comm] using zero_not_mem_open_interval_to_zero w.im
+    rw [h₁, h₂, add_zero]
+  · exact rectangleIntegral_eq_zero_of_axis_not_interior hc hd' haxis
+
+private theorem SchwarzReflection.analyticOnNhd_of_continuousOn_off_real {U : Set ℂ} (hU : IsOpen U)
+    {f : ℂ → ℂ} (hf : ContinuousOn f U) (hd : ∀ z ∈ U, z.im ≠ 0 → DifferentiableAt ℂ f z) :
+    AnalyticOnNhd ℂ f U :=
+  (differentiableOn_of_continuousOn_off_real hU hf hd).analyticOnNhd hU
+
+private def SchwarzReflection.pasteUpper (f g : ℂ → ℂ) (z : ℂ) : ℂ :=
+  if 0 ≤ z.im then f z else g z
+
+@[simp]
+private theorem SchwarzReflection.pasteUpper_of_nonneg (f g : ℂ → ℂ) {z : ℂ} (hz : 0 ≤ z.im) :
+    pasteUpper f g z = f z :=
+  ite_eq_left hz
+
+@[simp]
+private theorem SchwarzReflection.pasteUpper_of_neg (f g : ℂ → ℂ) {z : ℂ} (hz : z.im < 0) :
+    pasteUpper f g z = g z :=
+  ite_eq_right (not_le.mpr hz)
+
+private theorem SchwarzReflection.continuousOn_pasteUpper {U : Set ℂ} {f g : ℂ → ℂ}
+    (hf : ContinuousOn f (U ∩ {z | 0 ≤ z.im})) (hg : ContinuousOn g (U ∩ {z | z.im ≤ 0}))
+    (hfg : ∀ z ∈ U, z.im = 0 → f z = g z) : ContinuousOn (pasteUpper f g) U := by
+  change ContinuousOn (fun z => if 0 ≤ z.im then f z else g z) U
+  apply ContinuousOn.if
+  · intro z hz
+    exact hfg z hz.1 ((frontier_le_subset_eq continuous_const Complex.continuous_im hz.2).symm)
+  · simpa only [closure_le_eq continuous_const Complex.continuous_im] using hf
+  · apply hg.mono
+    intro z hz
+    refine ⟨hz.1, ?_⟩
+    apply closure_lt_subset_le Complex.continuous_im continuous_const
+    simpa only [not_le] using hz.2
+
+private theorem SchwarzReflection.analyticOnNhd_pasteUpper {U : Set ℂ} (hU : IsOpen U) {f g : ℂ → ℂ}
+    (hfc : ContinuousOn f (U ∩ {z | 0 ≤ z.im})) (hgc : ContinuousOn g (U ∩ {z | z.im ≤ 0}))
+    (hfd : ∀ z ∈ U, 0 < z.im → DifferentiableAt ℂ f z)
+    (hgd : ∀ z ∈ U, z.im < 0 → DifferentiableAt ℂ g z) (hfg : ∀ z ∈ U, z.im = 0 → f z = g z) :
+    AnalyticOnNhd ℂ (pasteUpper f g) U := by
+  apply analyticOnNhd_of_continuousOn_off_real hU (continuousOn_pasteUpper hfc hgc hfg)
+  intro z hz hn
+  rcases lt_or_gt_of_ne hn with hneg | hpos
+  · apply (hgd z hz hneg).congr_of_eventuallyEq
+    filter_upwards [Complex.continuous_im.continuousAt.eventually_lt continuousAt_const hneg] with
+      w hw
+    exact pasteUpper_of_neg f g hw
+  · apply (hfd z hz hpos).congr_of_eventuallyEq
+    filter_upwards [continuousAt_const.eventually_lt Complex.continuous_im.continuousAt hpos] with
+      w hw
+    exact pasteUpper_of_nonneg f g hw.le
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Foundations/Core1.lean b/LeanPool/HopfProblem/Foundations/Core1.lean
new file mode 100644
index 000000000..b499938e9
--- /dev/null
+++ b/LeanPool/HopfProblem/Foundations/Core1.lean
@@ -0,0 +1,43 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Uniformization.HolomorphicCousin
+import all LeanPool.HopfProblem.Uniformization.HolomorphicCousin
+
+/-!
+# Hopf problem: foundations · core 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+/-- Integer matrices acting on the rank-four lattice used throughout the construction. -/
+public
+abbrev LatticeMatrix :=
+  Matrix (Fin 4) (Fin 4) ℤ
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Foundations/Core2.lean b/LeanPool/HopfProblem/Foundations/Core2.lean
new file mode 100644
index 000000000..ff5d1e262
--- /dev/null
+++ b/LeanPool/HopfProblem/Foundations/Core2.lean
@@ -0,0 +1,655 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Recognition.Smale1
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.Recognition.Smale1
+
+/-!
+# Hopf problem: foundations · core 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def ε : Lattice :=
+  ![1, 2, -4, 0]
+
+private def ε' : Lattice :=
+  ![1, 3, -3, 0]
+
+private def γ (v : Lattice) : ℤ :=
+  v 0
+
+private theorem det_T₁ : T₁.det = 1 := by decide
+
+private theorem det_T₂ : T₂.det = 1 := by decide
+
+private theorem γ_ε' : γ ε' = 1 :=
+  rfl
+
+private theorem contDiffOn_of_sub_mem_discrete {E : Type*} [NormedAddCommGroup E] [NormedSpace ℂ E]
+    (L : Submodule ℤ E) [DiscreteTopology L] {f : E → E} {s : Set E} (hf : ContinuousOn f s)
+    (hL : ∀ x ∈ s, f x - x ∈ L) (n : ℕ∞ω) : ContDiffOn ℂ n f s := by
+  let g : s → L := fun x => ⟨f x - x, hL x x.property⟩
+  have hg : Continuous g := (hf.domRestrict.sub continuous_subtype_val).subtype_mk _
+  have hg' : IsLocallyConstant g := (IsLocallyConstant.iff_continuous g).mpr hg
+  intro x hx
+  have heq : ∀ᶠ y in 𝓝[s] x, f y - y = f x - x := by
+    apply (eventually_nhds_subtype_iff s ⟨x, hx⟩ _).mp
+    exact (hg'.eventually_eq ⟨x, hx⟩).mono fun y hy => congrArg Subtype.val hy
+  apply
+    (contDiff_id.add contDiff_const).contDiffWithinAt.congr_of_eventuallyEq_of_mem (s := s) (f :=
+      fun y => y + (f x - x)) ?_ hx
+  exact heq.mono fun y hy => (sub_eq_iff_eq_add.mp hy).trans (add_comm _ _)
+
+private theorem DiscreteQuotient.quotient_localHomeomorph {E : Type*} [NormedAddCommGroup E]
+    (L : Submodule ℤ E) [DiscreteTopology L] : IsLocalHomeomorph (L.mkQ : E → E ⧸ L) := by
+  have : DiscreteTopology L.toAddSubgroup := inferInstanceAs (DiscreteTopology L)
+  exact
+    (AddSubgroup.isAddQuotientCoveringMap_of_comm L.toAddSubgroup
+        DiscreteTopology.isDiscrete).isCoveringMap.isLocalHomeomorph
+
+private def DiscreteQuotient.representative {E : Type*} [NormedAddCommGroup E] (L : Submodule ℤ E)
+    (x : E ⧸ L) : E :=
+  (L.mkQ_surjective x).choose
+
+private theorem
+    DiscreteQuotient.mkQ_representative {E : Type*} [NormedAddCommGroup E] (L : Submodule ℤ E)
+    (x : E ⧸ L) : L.mkQ (representative L x) = x :=
+  (L.mkQ_surjective x).choose_spec
+
+private def DiscreteQuotient.chart {E : Type*} [NormedAddCommGroup E] (L : Submodule ℤ E)
+    [DiscreteTopology L] (x : E ⧸ L) : OpenPartialHomeomorph (E ⧸ L) E :=
+  (quotient_localHomeomorph L).localInverseAt (representative L x)
+
+private instance
+    DiscreteQuotient.chartedSpace {E : Type*} [NormedAddCommGroup E] (L : Submodule ℤ E)
+    [DiscreteTopology L] : ChartedSpace E (E ⧸ L)
+    where
+  atlas := Set.range (chart L)
+  chartAt := chart L
+  mem_chart_source
+    x := by
+    have h :=
+      (quotient_localHomeomorph L).apply_self_mem_localInverseAt_source (x := representative L x)
+    simpa only [chart, mkQ_representative] using h
+  chart_mem_atlas x := Set.mem_range_self x
+
+@[simp]
+private theorem DiscreteQuotient.chart_symm {E : Type*} [NormedAddCommGroup E] (L : Submodule ℤ E)
+    [DiscreteTopology L] (x : E ⧸ L) : (chart L x).symm = (L.mkQ : E → E ⧸ L) :=
+  (quotient_localHomeomorph L).localInverseAt_symm (representative L x)
+
+private theorem DiscreteQuotient.mkQ_chart {E : Type*} [NormedAddCommGroup E] (L : Submodule ℤ E)
+    [DiscreteTopology L] (x y : E ⧸ L) (hy : y ∈ (chart L x).source) : L.mkQ (chart L x y) = y :=
+  (quotient_localHomeomorph L).apply_localInverseAt_of_mem hy
+
+private theorem
+    DiscreteQuotient.transition_sub_mem {E : Type*} [NormedAddCommGroup E] (L : Submodule ℤ E)
+    [DiscreteTopology L] (x y : E ⧸ L) (z : E)
+    (hz : z ∈ ((chart L x).symm.trans (chart L y)).source) :
+    ((chart L x).symm.trans (chart L y)) z - z ∈ L := by
+  apply (Submodule.Quotient.eq L).mp
+  change L.mkQ (((chart L x).symm.trans (chart L y)) z) = L.mkQ z
+  rw [OpenPartialHomeomorph.trans_apply, chart_symm]
+  apply mkQ_chart
+  simpa only [OpenPartialHomeomorph.symm_symm, chart_symm, Set.mem_preimage] using hz.2
+
+private instance DiscreteQuotient.isManifold {E : Type*} [NormedAddCommGroup E] [NormedSpace ℂ E]
+    (L : Submodule ℤ E) [DiscreteTopology L] (n : ℕ∞ω) :
+    IsManifold (modelWithCornersSelf ℂ E) n (E ⧸ L) := by
+  apply isManifold_of_contDiffOn
+  intro e e' he he'
+  obtain ⟨x, rfl⟩ := he
+  obtain ⟨y, rfl⟩ := he'
+  have h :=
+    contDiffOn_of_sub_mem_discrete L ((chart L x).symm.trans (chart L y)).continuousOn
+      (transition_sub_mem L x y) n
+  simpa using h
+
+private theorem DiscreteQuotient.contMDiff_mkQ {E : Type*} [NormedAddCommGroup E] [NormedSpace ℂ E]
+    (L : Submodule ℤ E) [DiscreteTopology L] (n : ℕ∞ω) :
+    ContMDiff (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) n (L.mkQ : E → E ⧸ L) := by
+  apply contMDiff_iff.mpr
+  refine ⟨L.continuous_mkQ, ?_⟩
+  intro x y
+  have h : ContDiffOn ℂ n (chart L y ∘ L.mkQ) (L.mkQ ⁻¹' (chart L y).source) := by
+    apply contDiffOn_of_sub_mem_discrete L
+    · exact (chart L y).continuousOn.comp L.continuous_mkQ.continuousOn (fun z hz => hz)
+    · intro z hz
+      exact (Submodule.Quotient.eq L).mp (mkQ_chart L y (L.mkQ z) hz)
+  have hchart : chartAt E y = chart L y := rfl
+  simpa [extChartAt, OpenPartialHomeomorph.extend, hchart, chartAt_self_eq] using h
+
+private theorem DiscreteQuotient.contMDiff_of_comp_mkQ {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] (L : Submodule ℤ E) [DiscreteTopology L] {F H M : Type*}
+    [NormedAddCommGroup F] [NormedSpace ℂ F] [TopologicalSpace H] [TopologicalSpace M]
+    [ChartedSpace H M] (I : ModelWithCorners ℂ F H) (n : ℕ∞ω) {f : E ⧸ L → M}
+    (hf : ContMDiff (modelWithCornersSelf ℂ E) I n (f ∘ L.mkQ)) :
+    ContMDiff (modelWithCornersSelf ℂ E) I n f := by
+  intro x
+  rw [contMDiffAt_iff_source]
+  have hchart : chartAt E x = chart L x := rfl
+  simpa [extChartAt, OpenPartialHomeomorph.extend, hchart, chart_symm] using
+    (hf.contMDiffAt.contMDiffWithinAt (s := Set.univ) (x := chart L x x))
+
+private instance DiscreteQuotient.lieAddGroup {E : Type*} [NormedAddCommGroup E] [NormedSpace ℂ E]
+    (L : Submodule ℤ E) [DiscreteTopology L] (n : ℕ∞ω) :
+    LieAddGroup (modelWithCornersSelf ℂ E) n (E ⧸ L)
+    where
+  contMDiff_add := by
+    have h :
+      ContMDiff (modelWithCornersSelf ℂ (E × E)) (modelWithCornersSelf ℂ E) n
+        (fun z : E × E => L.mkQ (z.1 + z.2)) :=
+      (contMDiff_mkQ L n).comp (contDiff_fst.add contDiff_snd).contMDiff
+    intro x
+    rw [contMDiffAt_iff_source]
+    have hchart : ∀ y : E ⧸ L, chartAt E y = chart L y := fun _ => rfl
+    have hs :
+      ((extChartAt ((modelWithCornersSelf ℂ E).prod (modelWithCornersSelf ℂ E)) x).symm :
+          E × E → (E ⧸ L) × (E ⧸ L)) =
+        fun z => (L.mkQ z.1, L.mkQ z.2) := by
+      rw [extChartAt_prod, PartialEquiv.prod_coe_symm]
+      simp only [extChartAt_coe_symm, hchart, chart_symm, modelWithCornersSelf_coe_symm,
+        Function.comp_def, id_eq]
+    have ht :
+      extChartAt ((modelWithCornersSelf ℂ E).prod (modelWithCornersSelf ℂ E)) x x =
+        (chart L x.1 x.1, chart L x.2 x.2) :=
+      rfl
+    have hr : Set.range ((modelWithCornersSelf ℂ E).prod (modelWithCornersSelf ℂ E)) = Set.univ :=
+      Set.range_eq_univ.mpr fun z => ⟨z, rfl⟩
+    rw [hs, ht, hr]
+    simpa only [Function.comp_def, map_add] using
+      (h.contMDiffAt.contMDiffWithinAt (s := Set.univ) (x := (chart L x.1 x.1, chart L x.2 x.2)))
+  contMDiff_neg := by
+    apply contMDiff_of_comp_mkQ L (modelWithCornersSelf ℂ E) n
+    simpa [Function.comp_def, map_neg] using
+      (contMDiff_mkQ L n).comp (contDiff_neg : ContDiff ℂ n (fun z : E => -z)).contMDiff
+
+/-- The two-dimensional complex coordinate space. -/
+public
+abbrev ComplexPlane₂ :=
+  Fin 2 → ℂ
+
+private def complexCoordinates : (Fin 4 → ℝ) ≃ₗ[ℝ] ComplexPlane₂
+    where
+  toFun x := ![⟨x 0, x 1⟩, ⟨x 2, x 3⟩]
+  invFun z := ![(z 0).re, (z 0).im, (z 1).re, (z 1).im]
+  left_inv x := by ext i; fin_cases i <;> rfl
+  right_inv z := by ext i; fin_cases i <;> rfl
+  map_add' x y := by ext i; fin_cases i <;> rfl
+  map_smul' r
+    x := by
+    ext i : 1
+    fin_cases i <;> apply Complex.ext <;> simp [Complex.mul_re, Complex.mul_im]
+
+private abbrev RealPair₂ :=
+  (Fin 2 → ℝ) × (Fin 2 → ℝ)
+
+private def
+    DiscreteQuotient.linearBiholomorph {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℂ E]
+    [NormedAddCommGroup F] [NormedSpace ℂ F] (L : Submodule ℤ E) (K : Submodule ℤ F)
+    [DiscreteTopology L] [DiscreteTopology K] (e : E ≃L[ℂ] F)
+    (h : L.map (e.toLinearEquiv.restrictScalars ℤ).toLinearMap = K) :
+    Diffeomorph (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ F) (E ⧸ L) (F ⧸ K) ω
+    where
+  toEquiv := (Submodule.Quotient.equiv L K (e.toLinearEquiv.restrictScalars ℤ) h).toEquiv
+  contMDiff_toFun := by
+    apply contMDiff_of_comp_mkQ
+    exact (contMDiff_mkQ K ω).comp e.contDiff.contMDiff
+  contMDiff_invFun := by
+    apply contMDiff_of_comp_mkQ
+    exact (contMDiff_mkQ L ω).comp e.symm.contDiff.contMDiff
+
+private def columnLattice (P : Matrix (Fin 2) (Fin 4) ℂ) : Submodule ℤ ComplexPlane₂ :=
+  Submodule.span ℤ (Set.range P.col)
+
+private theorem column_mul_mem (P : Matrix (Fin 2) (Fin 4) ℂ) (A : LatticeMatrix) (j : Fin 4) :
+    (P * A.map (Int.castRingHom ℂ)).col j ∈ columnLattice P := by
+  have he : (P * A.map (Int.castRingHom ℂ)).col j = ∑ k, A k j • P.col k := by
+    ext i
+    simp [Matrix.mul_apply, Matrix.col, Matrix.transpose_apply, zsmul_eq_mul, mul_comm]
+  rw [he]
+  exact
+    Submodule.sum_mem _ fun k _ =>
+      Submodule.smul_mem _ _ (Submodule.subset_span (Set.mem_range_self k))
+
+private theorem columnLattice_mul_le (P : Matrix (Fin 2) (Fin 4) ℂ) (A : LatticeMatrix) :
+    columnLattice (P * A.map (Int.castRingHom ℂ)) ≤ columnLattice P := by
+  apply Submodule.span_le.mpr
+  rintro _ ⟨j, rfl⟩
+  exact column_mul_mem P A j
+
+private theorem columnLattice_mul_eq (P : Matrix (Fin 2) (Fin 4) ℂ) (A B : LatticeMatrix)
+    (hAB : A * B = 1) : columnLattice (P * A.map (Int.castRingHom ℂ)) = columnLattice P := by
+  apply le_antisymm (columnLattice_mul_le P A)
+  have hP : (P * A.map (Int.castRingHom ℂ)) * B.map (Int.castRingHom ℂ) = P := by
+    rw [Matrix.mul_assoc, ← Matrix.map_mul, hAB]
+    simp
+  have h := columnLattice_mul_le (P * A.map (Int.castRingHom ℂ)) B
+  rwa [hP] at h
+
+private theorem map_columnLattice (P : Matrix (Fin 2) (Fin 4) ℂ) (R : Matrix (Fin 2) (Fin 2) ℂ) :
+    (columnLattice P).map (R.mulVecLin.restrictScalars ℤ) = columnLattice (R * P) := by
+  rw [columnLattice, columnLattice, Submodule.map_span]
+  congr 1
+  rw [← Set.range_comp]
+  congr 1
+
+private theorem eventuallyEq_of_localHomeomorph_comp_eq {X Y Z : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] [TopologicalSpace Z] {q : X → Y} (hq : IsLocalHomeomorph q) {f g : Z → X}
+    {z : Z} (hf : ContinuousAt f z) (hg : ContinuousAt g z) (hz : f z = g z)
+    (he : ∀ᶠ w in 𝓝 z, q (f w) = q (g w)) : f =ᶠ[𝓝 z] g := by
+  let e := hq.localInverseAt (f z)
+  have hU : e.target ∈ 𝓝 (f z) := e.open_target.mem_nhds hq.self_mem_localInverseAt_target
+  have hfU : ∀ᶠ w in 𝓝 z, f w ∈ e.target := hf hU
+  have hgU : ∀ᶠ w in 𝓝 z, g w ∈ e.target := hg (hz ▸ hU)
+  filter_upwards [hfU, hgU, he] with w hfw hgw hw
+  exact hq.injOn_localInverseAt_target hfw hgw hw
+
+private theorem quotientCoveringMap_of_localHomeomorph {X Y G : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] [Group G] [MulAction G X] [ContinuousConstSMul G X] [IsCancelSMul G X]
+    {q : X → Y} (hq : IsLocalHomeomorph q) (hs : Function.Surjective q)
+    (ho : ∀ x y, q x = q y ↔ x ∈ MulAction.orbit G y) : IsQuotientCoveringMap q G
+    where
+  toIsQuotientMap := hq.isOpenMap.isQuotientMap hq.continuous hs
+  continuous_const_smul := ContinuousConstSMul.continuous_const_smul
+  apply_eq_iff_mem_orbit := ho _ _
+  disjoint
+    x := by
+    let e := hq.localInverseAt x
+    refine ⟨e.target, e.open_target.mem_nhds hq.self_mem_localInverseAt_target, ?_⟩
+    rintro g ⟨z, ⟨w, hw, rfl⟩, hgw⟩
+    have heq : q (g • w) = q w := (ho _ _).mpr ⟨g, rfl⟩
+    have heq' : g • w = (1 : G) • w := by
+      simpa only [one_smul] using hq.injOn_localInverseAt_target hgw hw heq
+    exact IsCancelSMul.right_cancel _ _ w heq'
+
+private theorem localHomeomorph_prod_id {B X Y : Type*} [TopologicalSpace B] [TopologicalSpace X]
+    [TopologicalSpace Y] {q : X → Y} (hq : IsLocalHomeomorph q) :
+    IsLocalHomeomorph (fun z : B × X => (z.1, q z.2)) := by
+  intro x
+  obtain ⟨e, he, hqe⟩ := hq x.2
+  refine ⟨(OpenPartialHomeomorph.refl B).prod e, ⟨Set.mem_univ _, he⟩, ?_⟩
+  funext y
+  exact congrArg (Prod.mk y.1) (congrFun hqe y.2)
+
+private def
+    CoveringQuotient.representative {M Q G : Type*} [TopologicalSpace M] [TopologicalSpace Q]
+    [Group G] [MulAction G M] {q : M → Q} (hq : IsQuotientCoveringMap q G) (x : Q) : M :=
+  (hq.surjective x).choose
+
+private theorem CoveringQuotient.project_representative {M Q G : Type*} [TopologicalSpace M]
+    [TopologicalSpace Q] [Group G] [MulAction G M] {q : M → Q} (hq : IsQuotientCoveringMap q G)
+    (x : Q) : q (representative hq x) = x :=
+  (hq.surjective x).choose_spec
+
+private def CoveringQuotient.localInverse {M Q G : Type*} [TopologicalSpace M] [TopologicalSpace Q]
+    [Group G] [MulAction G M] {q : M → Q} (hq : IsQuotientCoveringMap q G) (x : M) :
+    OpenPartialHomeomorph Q M :=
+  hq.isCoveringMap.isLocalHomeomorph.localInverseAt x
+
+@[simp]
+private theorem CoveringQuotient.localInverse_symm {M Q G : Type*} [TopologicalSpace M]
+    [TopologicalSpace Q] [Group G] [MulAction G M] {q : M → Q} (hq : IsQuotientCoveringMap q G)
+    (x : M) : (localInverse hq x).symm = q :=
+  hq.isCoveringMap.isLocalHomeomorph.localInverseAt_symm x
+
+private theorem CoveringQuotient.project_localInverse {M Q G : Type*} [TopologicalSpace M]
+    [TopologicalSpace Q] [Group G] [MulAction G M] {q : M → Q} (hq : IsQuotientCoveringMap q G)
+    (x : M) {y : Q} (hy : y ∈ (localInverse hq x).source) : q (localInverse hq x y) = y :=
+  hq.isCoveringMap.isLocalHomeomorph.apply_localInverseAt_of_mem hy
+
+private theorem CoveringQuotient.contMDiffOn_lift {E M Q G : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [TopologicalSpace M] [ChartedSpace E M] [TopologicalSpace Q] [Group G]
+    [MulAction G M] {q : M → Q} (hq : IsQuotientCoveringMap q G) (n : ℕ∞ω)
+    (hG :
+      ∀ g : G,
+        ContMDiff (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) n (fun x : M => g • x))
+    (a : M) :
+    ContMDiffOn (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) n (localInverse hq a ∘ q)
+      (q ⁻¹' (localInverse hq a).source) := by
+  intro x hx
+  have hcont : ContinuousAt (localInverse hq a ∘ q) x :=
+    ((localInverse hq a).continuousAt hx).comp hq.continuous.continuousAt
+  obtain ⟨g, hg⟩ := hq.apply_eq_iff_mem_orbit.mp (project_localInverse hq a hx)
+  have hsource : ∀ᶠ y in 𝓝 x, q y ∈ (localInverse hq a).source :=
+    hq.continuous.continuousAt ((localInverse hq a).open_source.mem_nhds hx)
+  have heq : (localInverse hq a ∘ q) =ᶠ[𝓝 x] (fun y => g • y) := by
+    apply
+      eventuallyEq_of_localHomeomorph_comp_eq hq.isCoveringMap.isLocalHomeomorph hcont
+        (hG g).continuous.continuousAt hg.symm
+    exact hsource.mono fun y hy => (project_localInverse hq a hy).trans (hq.map_smul g).symm
+  exact ((hG g).contMDiffAt.congr_of_eventuallyEq heq).contMDiffWithinAt
+
+private def CoveringQuotient.chart {E M Q G : Type*} [NormedAddCommGroup E] [TopologicalSpace M]
+    [ChartedSpace E M] [TopologicalSpace Q] [Group G] [MulAction G M] {q : M → Q}
+    (hq : IsQuotientCoveringMap q G) (x : Q) : OpenPartialHomeomorph Q E :=
+  (localInverse hq (representative hq x)).trans (chartAt E (representative hq x))
+
+@[instance_reducible]
+private def
+    CoveringQuotient.chartedSpace {E M Q G : Type*} [NormedAddCommGroup E] [TopologicalSpace M]
+    [ChartedSpace E M] [TopologicalSpace Q] [Group G] [MulAction G M] {q : M → Q}
+    (hq : IsQuotientCoveringMap q G) : ChartedSpace E Q
+    where
+  atlas := Set.range (chart (E := E) hq)
+  chartAt := chart (E := E) hq
+  mem_chart_source
+    x := by
+    change
+      x ∈ (localInverse hq (representative hq x)).source ∧
+        localInverse hq (representative hq x) x ∈ (chartAt E (representative hq x)).source
+    constructor
+    · have h :=
+        hq.isCoveringMap.isLocalHomeomorph.apply_self_mem_localInverseAt_source (x :=
+          representative hq x)
+      simpa only [localInverse, project_representative] using h
+    · have h : localInverse hq (representative hq x) x = representative hq x := by
+        simpa only [localInverse, project_representative] using
+          hq.isCoveringMap.isLocalHomeomorph.localInverseAt_apply_self (x := representative hq x)
+      rw [h]
+      exact mem_chart_source E (representative hq x)
+  chart_mem_atlas x := Set.mem_range_self x
+
+private theorem
+    CoveringQuotient.chart_symm {E M Q G : Type*} [NormedAddCommGroup E] [TopologicalSpace M]
+    [ChartedSpace E M] [TopologicalSpace Q] [Group G] [MulAction G M] {q : M → Q}
+    (hq : IsQuotientCoveringMap q G) (x : Q) :
+    ((chart (E := E) hq x).symm : E → Q) = q ∘ (chartAt E (representative hq x)).symm := by
+  funext z
+  change
+    (localInverse hq (representative hq x)).symm ((chartAt E (representative hq x)).symm z) = _
+  rw [localInverse_symm]
+  rfl
+
+private theorem CoveringQuotient.transition_eq {E M Q G : Type*} [NormedAddCommGroup E]
+    [TopologicalSpace M] [ChartedSpace E M] [TopologicalSpace Q] [Group G] [MulAction G M]
+    {q : M → Q} (hq : IsQuotientCoveringMap q G) (x y : Q) :
+    (((chart (E := E) hq x).symm.trans (chart (E := E) hq y)) : E → E) =
+      chartAt E (representative hq y) ∘
+        (localInverse hq (representative hq y) ∘ q) ∘ (chartAt E (representative hq x)).symm := by
+  funext z
+  simp only [OpenPartialHomeomorph.trans_apply, chart_symm, Function.comp_apply]
+  rfl
+
+private theorem CoveringQuotient.contDiffOn_transition {E M Q G : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [TopologicalSpace M] [ChartedSpace E M] [TopologicalSpace Q] [Group G]
+    [MulAction G M] {q : M → Q} (hq : IsQuotientCoveringMap q G) (n : ℕ∞ω)
+    [IsManifold (modelWithCornersSelf ℂ E) n M]
+    (hG :
+      ∀ g : G,
+        ContMDiff (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) n (fun x : M => g • x))
+    (x y : Q) :
+    ContDiffOn ℂ n ((chart (E := E) hq x).symm.trans (chart (E := E) hq y))
+      ((chart (E := E) hq x).symm.trans (chart (E := E) hq y)).source := by
+  intro z hz
+  have hza : z ∈ (chartAt E (representative hq x)).target := hz.1.1
+  have hy : q ((chartAt E (representative hq x)).symm z) ∈ (chart (E := E) hq y).source := by
+    simpa only [OpenPartialHomeomorph.symm_symm, chart_symm, Function.comp_apply,
+      Set.mem_preimage] using hz.2
+  have ha := (chartAt E (representative hq x)).map_target hza
+  have hb :
+    localInverse hq (representative hq y) (q ((chartAt E (representative hq x)).symm z)) ∈
+      (chartAt E (representative hq y)).source :=
+    hy.2
+  have hmid :=
+    (contMDiffOn_lift hq n hG (representative hq y)).contMDiffAt
+      (((localInverse hq (representative hq y)).open_source.preimage hq.continuous).mem_nhds hy.1)
+  have hc := ((contMDiffAt_iff_of_mem_source ha hb).mp hmid).2
+  have hc' :
+    ContDiffAt ℂ n
+      (chartAt E (representative hq y) ∘
+        (localInverse hq (representative hq y) ∘ q) ∘ (chartAt E (representative hq x)).symm)
+      z := by
+    simpa [extChartAt, OpenPartialHomeomorph.extend, contDiffWithinAt_univ,
+      (chartAt E (representative hq x)).right_inv hza] using hc
+  rw [transition_eq]
+  exact hc'.contDiffWithinAt
+
+private theorem
+    CoveringQuotient.isManifold {E M Q G : Type*} [NormedAddCommGroup E] [NormedSpace ℂ E]
+    [TopologicalSpace M] [ChartedSpace E M] [TopologicalSpace Q] [Group G] [MulAction G M]
+    {q : M → Q} (hq : IsQuotientCoveringMap q G) (n : ℕ∞ω)
+    [IsManifold (modelWithCornersSelf ℂ E) n M]
+    (hG :
+      ∀ g : G,
+        ContMDiff (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) n (fun x : M => g • x)) :
+    letI := chartedSpace (E := E) hq
+    IsManifold (modelWithCornersSelf ℂ E) n Q := by
+  let := chartedSpace (E := E) hq
+  apply isManifold_of_contDiffOn
+  rintro e e' ⟨x, rfl⟩ ⟨y, rfl⟩
+  simpa using contDiffOn_transition hq n hG x y
+
+private theorem CoveringQuotient.contMDiff_project {E M Q G : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [TopologicalSpace M] [ChartedSpace E M] [TopologicalSpace Q] [Group G]
+    [MulAction G M] {q : M → Q} (hq : IsQuotientCoveringMap q G) (n : ℕ∞ω)
+    [IsManifold (modelWithCornersSelf ℂ E) n M]
+    (hG :
+      ∀ g : G,
+        ContMDiff (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) n (fun x : M => g • x)) :
+    letI := chartedSpace (E := E) hq
+    ContMDiff (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) n q := by
+  let := chartedSpace (E := E) hq
+  let := isManifold hq n hG
+  intro x
+  have hy : q x ∈ (chart (E := E) hq (q x)).source := mem_chart_source E (q x)
+  have hmid :=
+    (contMDiffOn_lift hq n hG (representative hq (q x))).contMDiffAt
+      (((localInverse hq (representative hq (q x))).open_source.preimage hq.continuous).mem_nhds
+        hy.1)
+  have hc :
+    ContMDiffAt (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) n
+      (chartAt E (representative hq (q x))) (localInverse hq (representative hq (q x)) (q x)) := by
+    simpa [extChartAt, OpenPartialHomeomorph.extend] using
+      (contMDiffAt_extChartAt' (I := modelWithCornersSelf ℂ E) (n := n) hy.2)
+  apply
+    (contMDiffAt_iff_target_of_mem_source (I := modelWithCornersSelf ℂ E) (I' :=
+        modelWithCornersSelf ℂ E) (mem_chart_source E (q x))).mpr
+  refine ⟨hq.continuous.continuousAt, ?_⟩
+  have hchart : chartAt E (q x) = chart (E := E) hq (q x) := rfl
+  simpa [extChartAt, OpenPartialHomeomorph.extend, hchart, chart, Function.comp_def] using
+    hc.comp x hmid
+
+private theorem CoveringQuotient.contMDiff_of_comp {E M Q G : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [TopologicalSpace M] [ChartedSpace E M] [TopologicalSpace Q] [Group G]
+    [MulAction G M] {q : M → Q} (hq : IsQuotientCoveringMap q G) {F H N : Type*}
+    [NormedAddCommGroup F] [NormedSpace ℂ F] [TopologicalSpace H] [TopologicalSpace N]
+    [ChartedSpace H N] (I : ModelWithCorners ℂ F H) (n : ℕ∞ω)
+    [IsManifold (modelWithCornersSelf ℂ E) n M] {f : Q → N}
+    (hf : ContMDiff (modelWithCornersSelf ℂ E) I n (f ∘ q)) :
+    letI := chartedSpace (E := E) hq
+    ContMDiff (modelWithCornersSelf ℂ E) I n f := by
+  let := chartedSpace (E := E) hq
+  intro x
+  rw [contMDiffAt_iff_source]
+  have hx : x ∈ (chart (E := E) hq x).source := mem_chart_source E x
+  have hsrc :=
+    (contMDiffAt_iff_source_of_mem_source (I := modelWithCornersSelf ℂ E) (I' := I) hx.2).mp
+      (hf.contMDiffAt (x := localInverse hq (representative hq x) x))
+  have hchart : chartAt E x = chart (E := E) hq x := rfl
+  simpa [extChartAt, OpenPartialHomeomorph.extend, hchart, chart, Function.comp_def] using hsrc
+
+private theorem CoveringQuotient.contMDiffOn_of_comp {E M Q G : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [TopologicalSpace M] [ChartedSpace E M] [TopologicalSpace Q] [Group G]
+    [MulAction G M] {q : M → Q} (hq : IsQuotientCoveringMap q G) {F H N : Type*}
+    [NormedAddCommGroup F] [NormedSpace ℂ F] [TopologicalSpace H] [TopologicalSpace N]
+    [ChartedSpace H N] (I : ModelWithCorners ℂ F H) (n : ℕ∞ω)
+    [IsManifold (modelWithCornersSelf ℂ E) n M] {f : Q → N} {U : Set Q} (hU : IsOpen U)
+    (hf : ContMDiffOn (modelWithCornersSelf ℂ E) I n (f ∘ q) (q ⁻¹' U)) :
+    letI := chartedSpace (E := E) hq
+    ContMDiffOn (modelWithCornersSelf ℂ E) I n f U := by
+  let := chartedSpace (E := E) hq
+  intro x hxU
+  apply ContMDiffAt.contMDiffWithinAt
+  rw [contMDiffAt_iff_source]
+  have hx : x ∈ (chart (E := E) hq x).source := mem_chart_source E x
+  have hpre : localInverse hq (representative hq x) x ∈ q ⁻¹' U := by
+    change q (localInverse hq (representative hq x) x) ∈ U
+    rw [project_localInverse hq _ hx.1]
+    exact hxU
+  have hf' := hf.contMDiffAt ((hU.preimage hq.continuous).mem_nhds hpre)
+  have hsrc :=
+    (contMDiffAt_iff_source_of_mem_source (I := modelWithCornersSelf ℂ E) (I' := I) hx.2).mp hf'
+  have hchart : chartAt E x = chart (E := E) hq x := rfl
+  simpa [extChartAt, OpenPartialHomeomorph.extend, hchart, chart, Function.comp_def] using hsrc
+
+private theorem CoveringQuotient.localInverse_holomorphic {E M Q G : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [TopologicalSpace M] [ChartedSpace E M] [TopologicalSpace Q] [Group G]
+    [MulAction G M] {q : M → Q} (hq : IsQuotientCoveringMap q G) (n : ℕ∞ω)
+    [IsManifold (modelWithCornersSelf ℂ E) n M]
+    (hG :
+      ∀ g : G,
+        ContMDiff (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) n (fun x : M => g • x))
+    (a : M) :
+    letI := chartedSpace (E := E) hq
+    ContMDiffOn (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) n (localInverse hq a)
+      (localInverse hq a).source :=
+  contMDiffOn_of_comp hq (modelWithCornersSelf ℂ E) n (localInverse hq a).open_source
+    (contMDiffOn_lift hq n hG a)
+
+private theorem CoveringQuotient.project_isLocalDiffeomorph {E M Q G : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [TopologicalSpace M] [ChartedSpace E M] [TopologicalSpace Q] [Group G]
+    [MulAction G M] {q : M → Q} (hq : IsQuotientCoveringMap q G)
+    [IsManifold (modelWithCornersSelf ℂ E) ω M]
+    (hG :
+      ∀ g : G,
+        ContMDiff (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (fun x : M => g • x)) :
+    letI := chartedSpace (E := E) hq
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω q := by
+  let := chartedSpace (E := E) hq
+  intro x
+  let Φ : PartialDiffeomorph (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) M Q ω :=
+    { toPartialEquiv := (localInverse hq x).symm.toPartialEquiv
+      open_source := (localInverse hq x).open_target
+      open_target := (localInverse hq x).open_source
+      contMDiffOn_toFun := by
+        change
+          ContMDiffOn (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω
+            (localInverse hq x).symm (localInverse hq x).target
+        rw [localInverse_symm]
+        exact (contMDiff_project hq ω hG).contMDiffOn
+      contMDiffOn_invFun := localInverse_holomorphic hq ω hG x }
+  refine ⟨Φ, hq.isCoveringMap.isLocalHomeomorph.self_mem_localInverseAt_target, ?_⟩
+  intro y _
+  change q y = (localInverse hq x).symm y
+  rw [localInverse_symm]
+
+private def
+    opensInclusionPartialDiffeomorph {E H M : Type*} [NormedAddCommGroup E] [NormedSpace ℂ E]
+    [TopologicalSpace H] [TopologicalSpace M] [ChartedSpace H M] (I : ModelWithCorners ℂ E H)
+    (U : TopologicalSpace.Opens M) (hU : Nonempty U) : PartialDiffeomorph I I U M ω := by
+  let e := U.openPartialHomeomorphSubtypeCoe hU
+  refine
+    { toPartialEquiv := e.toPartialEquiv
+      open_source := e.open_source
+      open_target := e.open_target
+      contMDiffOn_toFun := contMDiff_subtype_val.contMDiffOn
+      contMDiffOn_invFun := ?_ }
+  intro x hx
+  have hxU : x ∈ U := by simpa [e] using hx
+  have he : (Subtype.val ∘ e.symm) =ᶠ[𝓝 x] id := by
+    filter_upwards [U.isOpen.mem_nhds hxU] with y hy
+    exact
+      e.right_inv
+        (by
+          simpa only [e, TopologicalSpace.Opens.openPartialHomeomorphSubtypeCoe_target] using hy)
+  have hs : ContMDiffAt I I ω (Subtype.val ∘ e.symm) x := contMDiffAt_id.congr_of_eventuallyEq he
+  have hi : ContMDiffAt I I ω (Subtype.val ∘ e.symm) x ↔ ContMDiffAt I I ω e.symm x :=
+    ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+  exact (hi.mp hs).contMDiffWithinAt
+
+private theorem
+    isLocalDiffeomorph_subtypeVal {E H M : Type*} [NormedAddCommGroup E] [NormedSpace ℂ E]
+    [TopologicalSpace H] [TopologicalSpace M] [ChartedSpace H M] (I : ModelWithCorners ℂ E H)
+    (U : TopologicalSpace.Opens M) : IsLocalDiffeomorph I I ω (Subtype.val : U → M) := by
+  intro x
+  refine ⟨opensInclusionPartialDiffeomorph I U ⟨x⟩, Set.mem_univ _, ?_⟩
+  intro y _
+  rfl
+
+private theorem isLocalDiffeomorphAt_codRestrictOpens {E F H K M N : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [NormedAddCommGroup F] [NormedSpace ℂ F] [TopologicalSpace H]
+    [TopologicalSpace K] [TopologicalSpace M] [ChartedSpace H M] [TopologicalSpace N]
+    [ChartedSpace K N] (I : ModelWithCorners ℂ E H) (J : ModelWithCorners ℂ F K) {f : M → N}
+    {x : M} (hf : IsLocalDiffeomorphAt I J ω f x) (V : TopologicalSpace.Opens N)
+    (hV : ∀ x, f x ∈ V) : IsLocalDiffeomorphAt I J ω (fun y => (⟨f y, hV y⟩ : V)) x := by
+  obtain ⟨Φ, hx, he⟩ := hf
+  let eV := opensInclusionPartialDiffeomorph J V ⟨⟨f x, hV x⟩⟩
+  let Ψ := Φ.trans eV.symm
+  have hxV : Φ x ∈ V := by
+    rw [← he hx]
+    exact hV x
+  have hxV' : Φ x ∈ (V.openPartialHomeomorphSubtypeCoe ⟨⟨f x, hV x⟩⟩).target := by simpa using hxV
+  refine ⟨Ψ, ⟨hx, hxV'⟩, ?_⟩
+  intro y hy
+  have hyV : Φ y ∈ (V.openPartialHomeomorphSubtypeCoe ⟨⟨f x, hV x⟩⟩).target := hy.2
+  apply Subtype.ext
+  change f y = ((V.openPartialHomeomorphSubtypeCoe ⟨⟨f x, hV x⟩⟩).symm (Φ y) : N)
+  have hv := (V.openPartialHomeomorphSubtypeCoe ⟨⟨f x, hV x⟩⟩).right_inv hyV
+  exact (he hy.1).trans hv.symm
+
+private theorem isLocalDiffeomorph_codRestrictOpens {E F H K M N : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [NormedAddCommGroup F] [NormedSpace ℂ F] [TopologicalSpace H]
+    [TopologicalSpace K] [TopologicalSpace M] [ChartedSpace H M] [TopologicalSpace N]
+    [ChartedSpace K N] (I : ModelWithCorners ℂ E H) (J : ModelWithCorners ℂ F K) {f : M → N}
+    (hf : IsLocalDiffeomorph I J ω f) (V : TopologicalSpace.Opens N) (hV : ∀ x, f x ∈ V) :
+    IsLocalDiffeomorph I J ω (fun x => (⟨f x, hV x⟩ : V)) := fun x =>
+  isLocalDiffeomorphAt_codRestrictOpens I J (hf x) V hV
+
+private theorem isLocalDiffeomorphAt_restrictOpens {E F H K M N : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [NormedAddCommGroup F] [NormedSpace ℂ F] [TopologicalSpace H]
+    [TopologicalSpace K] [TopologicalSpace M] [ChartedSpace H M] [TopologicalSpace N]
+    [ChartedSpace K N] (I : ModelWithCorners ℂ E H) (J : ModelWithCorners ℂ F K) {f : M → N}
+    {x : M} (hf : IsLocalDiffeomorphAt I J ω f x) (U : TopologicalSpace.Opens M)
+    (V : TopologicalSpace.Opens N) (hUV : Set.MapsTo f (U : Set M) (V : Set N)) (hx : x ∈ U) :
+    IsLocalDiffeomorphAt I J ω (fun y : U => (⟨f y, hUV y.2⟩ : V)) ⟨x, hx⟩ := by
+  have hU : IsLocalDiffeomorphAt I J ω (fun y : U => f y) ⟨x, hx⟩ :=
+    (isLocalDiffeomorph_subtypeVal I U ⟨x, hx⟩).comp (K := J) (P := N) hf
+  exact isLocalDiffeomorphAt_codRestrictOpens I J hU V (fun y => hUV y.2)
+
+private theorem isLocalDiffeomorph_restrictOpens {E F H K M N : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [NormedAddCommGroup F] [NormedSpace ℂ F] [TopologicalSpace H]
+    [TopologicalSpace K] [TopologicalSpace M] [ChartedSpace H M] [TopologicalSpace N]
+    [ChartedSpace K N] (I : ModelWithCorners ℂ E H) (J : ModelWithCorners ℂ F K) {f : M → N}
+    (hf : IsLocalDiffeomorph I J ω f) (U : TopologicalSpace.Opens M)
+    (V : TopologicalSpace.Opens N) (hUV : Set.MapsTo f (U : Set M) (V : Set N)) :
+    IsLocalDiffeomorph I J ω (fun x : U => (⟨f x, hUV x.2⟩ : V)) := by
+  have hU : IsLocalDiffeomorph I J ω (fun x : U => f x) := by
+    intro x
+    exact (isLocalDiffeomorph_subtypeVal I U x).comp (K := J) (P := N) (hf x)
+  exact isLocalDiffeomorph_codRestrictOpens I J hU V (fun x => hUV x.2)
+
+/-- The four-dimensional real coordinate space underlying `ComplexPlane₂`. -/
+public
+abbrev RealPlane₄ :=
+  Fin 4 → ℝ
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Foundations/Core3.lean b/LeanPool/HopfProblem/Foundations/Core3.lean
new file mode 100644
index 000000000..d25efc8c7
--- /dev/null
+++ b/LeanPool/HopfProblem/Foundations/Core3.lean
@@ -0,0 +1,93 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Hurewicz.SecondHurewicz
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Hurewicz.SecondHurewicz
+
+/-!
+# Hopf problem: foundations · core 3
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+/-- The standard integral lattice spanned by the coordinate basis of `RealPlane₄`. -/
+public
+def standardLattice : Submodule ℤ RealPlane₄ :=
+  Submodule.span ℤ (Set.range (Pi.basisFun ℝ (Fin 4)))
+
+private instance standardLattice_discrete : DiscreteTopology standardLattice :=
+  inferInstanceAs (DiscreteTopology (Submodule.span ℤ (Set.range (Pi.basisFun ℝ (Fin 4)))))
+
+private instance standardLattice_isZLattice : IsZLattice ℝ standardLattice :=
+  inferInstanceAs (IsZLattice ℝ (Submodule.span ℤ (Set.range (Pi.basisFun ℝ (Fin 4)))))
+
+private instance standardLattice_closed : IsClosed (standardLattice : Set RealPlane₄) := by
+  have : DiscreteTopology standardLattice.toAddSubgroup :=
+    inferInstanceAs (DiscreteTopology standardLattice)
+  exact AddSubgroup.isClosed_of_discrete (H := standardLattice.toAddSubgroup)
+
+/-- The four-dimensional real torus obtained from the standard lattice quotient. -/
+public
+abbrev RealTorus₄ :=
+  RealPlane₄ ⧸ standardLattice
+
+private instance realTorus_secondCountable : SecondCountableTopology RealTorus₄ :=
+  standardLattice.isQuotientMap_mkQ.secondCountableTopology standardLattice.isOpenMap_mkQ
+
+private instance realTorus_pathConnected : PathConnectedSpace RealTorus₄ :=
+  standardLattice.mkQ_surjective.pathConnectedSpace standardLattice.continuous_mkQ
+
+private instance realTorus_compact : CompactSpace RealTorus₄ := by
+  have hper : ∀ z w, w ∈ standardLattice → standardLattice.mkQ (z + w) = standardLattice.mkQ z := by
+    intro z w hw
+    have hw' : standardLattice.mkQ w = 0 := (Submodule.Quotient.mk_eq_zero standardLattice).mpr hw
+    rw [map_add, hw', add_zero]
+  have h :=
+    IsZLattice.isCompact_range_of_periodic standardLattice standardLattice.mkQ
+      standardLattice.continuous_mkQ hper
+  exact ⟨by simpa only [Set.range_eq_univ.mpr standardLattice.mkQ_surjective] using h⟩
+
+private theorem
+    contMDiff_of_comp_localDiffeomorph {E F F' H K K' M N P : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [NormedAddCommGroup F] [NormedSpace ℂ F] [NormedAddCommGroup F']
+    [NormedSpace ℂ F'] [TopologicalSpace H] [TopologicalSpace K] [TopologicalSpace K']
+    [TopologicalSpace M] [ChartedSpace H M] [TopologicalSpace N] [ChartedSpace K N]
+    [TopologicalSpace P] [ChartedSpace K' P] (I : ModelWithCorners ℂ E H)
+    (J : ModelWithCorners ℂ F K) (L : ModelWithCorners ℂ F' K') {f : M → N}
+    (hf : IsLocalDiffeomorph I J ω f) (hsurj : Function.Surjective f) {g : N → P}
+    (hgf : ContMDiff I L ω (g ∘ f)) : ContMDiff J L ω g := by
+  intro y
+  obtain ⟨x, rfl⟩ := hsurj y
+  have h := hgf.contMDiffAt.comp (f x) (hf x).localInverse_contMDiffAt
+  apply h.congr_of_eventuallyEq
+  filter_upwards [(hf x).localInverse_eventuallyEq_right] with z hz
+  change g z = g (f ((hf x).localInverse z))
+  rw [show f ((hf x).localInverse z) = z from hz]
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Foundations/Core4.lean b/LeanPool/HopfProblem/Foundations/Core4.lean
new file mode 100644
index 000000000..33e97e71d
--- /dev/null
+++ b/LeanPool/HopfProblem/Foundations/Core4.lean
@@ -0,0 +1,89 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Toric.CuspHoneycombHexagon
+import all LeanPool.HopfProblem.Toric.CuspHoneycombHexagon
+
+/-!
+# Hopf problem: foundations · core 4
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem
+    covering_monodromy_naturality {E F X Y : Type*} [TopologicalSpace E] [TopologicalSpace F]
+    [TopologicalSpace X] [TopologicalSpace Y] {p : E → X} {q : F → Y} (hp : IsCoveringMap p)
+    (hq : IsCoveringMap q) (r : ContinuousMap E F) (f : ContinuousMap X Y)
+    (hcomm : ∀ z, q (r z) = f (p z)) (e : E) (γ : Path.Homotopic.Quotient (p e) (p e)) :
+    (hq.monodromy (γ.map f) ⟨r e, hcomm e⟩ : F) = r (hp.monodromy γ ⟨e, rfl⟩ : E) := by
+  let e' : p ⁻¹' {p e} := hp.monodromy γ ⟨e, rfl⟩
+  let f' : q ⁻¹' {f (p e)} := ⟨r e', (hcomm e').trans (congrArg f e'.property)⟩
+  have hc : (ContinuousMap.mk q hq.continuous).comp r = f.comp ⟨p, hp.continuous⟩ :=
+    ContinuousMap.ext hcomm
+  have he : hq.monodromy (γ.map f) ⟨r e, hcomm e⟩ = f' := by
+    apply hq.monodromy_eq_of_map_eq ((hp.liftPathQuotient γ ⟨e, rfl⟩).map r)
+    apply eq_of_heq
+    have hmap {f₁ f₂ : ContinuousMap E Y} (h : f₁ = f₂) :
+      HEq ((hp.liftPathQuotient γ ⟨e, rfl⟩).map f₁) ((hp.liftPathQuotient γ ⟨e, rfl⟩).map f₂) := by
+      subst f₂
+      rfl
+    apply (heq_of_eq Path.Homotopic.Quotient.map_comp.symm).trans
+    apply (hmap hc).trans
+    rw [Path.Homotopic.Quotient.map_comp, hp.map_liftPathQuotient]
+    have hm :
+      (γ.cast rfl (show p e' = p e from e'.property)).map f =
+        (γ.map f).cast rfl (congrArg f e'.property) :=
+      Path.Homotopic.Quotient.map_cast γ
+    apply (heq_of_eq hm).trans
+    exact
+      Path.Homotopic.Quotient.cast_heq _ _ |>.trans (Path.Homotopic.Quotient.cast_heq _ _).symm
+  exact congrArg Subtype.val he
+
+/-- The multiplicative equivalence on fundamental groups induced by a homeomorphism. -/
+public
+def homeomorphFundamentalGroupEquiv {X Y : Type*} [TopologicalSpace X] [TopologicalSpace Y]
+    (e : X ≃ₜ Y) (x : X) : FundamentalGroup X x ≃* FundamentalGroup Y (e x)
+    where
+  __ := FundamentalGroup.map ⟨e, e.continuous⟩ x
+  invFun := FundamentalGroup.mapOfEq ⟨e.symm, e.symm.continuous⟩ (e.symm_apply_apply x)
+  left_inv
+    γ := by
+    rw [FundamentalGroup.mapOfEq_apply]
+    obtain ⟨γ⟩ := γ
+    apply congrArg Path.Homotopic.Quotient.mk
+    ext t
+    exact e.symm_apply_apply (γ t)
+  right_inv
+    γ := by
+    rw [FundamentalGroup.mapOfEq_apply]
+    obtain ⟨γ⟩ := γ
+    apply congrArg Path.Homotopic.Quotient.mk
+    ext t
+    exact e.apply_symm_apply (γ t)
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Foundations/Core5.lean b/LeanPool/HopfProblem/Foundations/Core5.lean
new file mode 100644
index 000000000..dba0b2de3
--- /dev/null
+++ b/LeanPool/HopfProblem/Foundations/Core5.lean
@@ -0,0 +1,52 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Foundations.TrianglePeriodFamilyHomologySplitting
+import all LeanPool.HopfProblem.Foundations.TrianglePeriodFamilyHomologySplitting
+
+/-!
+# Hopf problem: foundations · core 5
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+/-- The linear combination of local twisting numbers used by the gluing construction. -/
+public
+def twistOrder (ℓ₀ ℓ₁ ℓ₂ : ℤ) : ℤ :=
+  12 * ℓ₀ - 4 * ℓ₁ - 3 * ℓ₂
+
+public
+theorem main_twist_value : twistOrder 0 1 (-1) = -1 := by decide
+
+private def twistRelators (a b d : ℤ) : Fin 5 → FreeGroup (Fin 3) :=
+  let c := FreeGroup.of (0 : Fin 3)
+  let x := FreeGroup.of (1 : Fin 3)
+  let y := FreeGroup.of (2 : Fin 3)
+  ![c * x * (x * c)⁻¹, c * y * (y * c)⁻¹, x * y * (c ^ a)⁻¹, x ^ 3 * (c ^ b)⁻¹, y ^ 4 * (c ^ d)⁻¹]
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Foundations/EuclideanSphere.lean b/LeanPool/HopfProblem/Foundations/EuclideanSphere.lean
new file mode 100644
index 000000000..cd4559e30
--- /dev/null
+++ b/LeanPool/HopfProblem/Foundations/EuclideanSphere.lean
@@ -0,0 +1,357 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Threefold.SpecialPeriods8
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods8
+
+/-!
+# Hopf problem: foundations · euclidean sphere
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem
+    _root_.PartialEquiv.image_source_minus_singleton_eq {α β : Type*} (e : PartialEquiv α β)
+    {a : α} (h : a ∈ e.source) : e '' (e.source \ { a }) = e.target \ {e a} := by
+  rw [Set.image_sdiff_of_injOn, PartialEquiv.image_source_eq_target, Set.image_singleton]
+  · exact e.injOn
+  · exact Set.singleton_subset_iff.mpr h
+
+private theorem _root_.PartialEquiv.symm_image_target_minus_singleton_eq {α β : Type*}
+    (e : PartialEquiv α β) {b : β} (h : b ∈ e.target) :
+    e.symm '' (e.target \ { b }) = e.source \ {e.symm b} :=
+  e.symm.image_source_minus_singleton_eq h
+
+private theorem
+    _root_.Path.exists_partition_unitInterval_of_open_cover {X : Type u} [TopologicalSpace X]
+    {ι : Type v} {c : ι → Set X} {a : X} (hc₁ : ∀ i, IsOpen (c i)) (hc₂ : Set.univ ⊆ ⋃ i, c i)
+    (γ : Path a a) :
+    ∃ (n : ℕ) (t : Fin (n + 2) → (unitInterval)),
+      t 0 = 0 ∧
+        t (Fin.last (n + 1)) = 1 ∧
+          ∀ k : Fin (n + 1), ∃ i, γ '' (Set.uIcc (t k.castSucc) (t k.succ)) ⊆ c i := by
+  have ⟨t, ht₀, ht_mono, ⟨n, ht₁⟩, ht_sub⟩ :=
+    exists_monotone_Icc_subset_open_cover_unitInterval
+      (fun i ↦ IsOpen.preimage (Path.continuous γ) (hc₁ i))
+      (fun s _ ↦ (Set.preimage_iUnion ▸ hc₂ (Set.mem_univ _)))
+  use n, t ∘ Fin.toNat
+  suffices ∀ (k : Fin (n + 1)), ∃ i, Set.uIcc (t ↑k) (t (↑k + 1)) ⊆ ⇑γ ⁻¹' c i by simpa [ht₀, ht₁]
+  intro k
+  have ⟨i, hi⟩ := ht_sub k
+  use i
+  rwa [Set.uIcc_of_le (ht_mono (Nat.le_add_right _ _))]
+
+private theorem
+    _root_.Path.exists_path_range_of_isPathConnected_inter {X : Type u} [TopologicalSpace X]
+    {ι : Type v} {c : ι → Set X} {a : X} (hc₃ : ∀ i j, IsPathConnected (c i ∩ c j))
+    (ha : ∀ i, a ∈ c i) {n : ℕ} (τ : Fin (n + 1) → ι) (p : Fin (n + 2) → X)
+    (hτ₁ : ∀ k, p k.castSucc ∈ c (τ k)) (hτ₂ : ∀ k, p k.succ ∈ c (τ k)) :
+    ∀ k : Fin n,
+      ∃ g : Path a (p k.succ.castSucc), Set.range g ⊆ c (τ k.castSucc) ∩ c (τ k.succ) := by
+  intro k
+  have ⟨γ, hγ⟩ :=
+    (hc₃ (τ k.castSucc) (τ k.succ)).joinedIn a ⟨ha (τ k.castSucc), ha (τ k.succ)⟩
+      (p k.castSucc.succ) ⟨hτ₂ k.castSucc, hτ₁ k.succ⟩
+  use γ
+  exact Set.range_subset_iff.mpr hγ
+
+private lemma _root_.Path.Homotopic.cancel_junction_mo1973_3458 {X : Type u} [TopologicalSpace X]
+    {a b c d e f : X} (p : Path a b) (q : Path b c) (r : Path d c) (s : Path c e) (t : Path e f) :
+    ((p ≫ₚ q ≫ₚ r.symm) ≫ₚ (r ≫ₚ s ≫ₚ t)).Homotopic (p ≫ₚ (q ≫ₚ s) ≫ₚ t) := by
+  apply Path.Homotopic.Quotient.exact
+  simp only [Path.Homotopic.Quotient.mk_trans, Path.Homotopic.Quotient.mk_symm,
+    Path.Homotopic.Quotient.trans_assoc]
+  rw [←
+    Path.Homotopic.Quotient.trans_assoc (Path.Homotopic.Quotient.mk r).symm
+      (Path.Homotopic.Quotient.mk r),
+    Path.Homotopic.Quotient.symm_trans, Path.Homotopic.Quotient.refl_trans]
+
+private lemma
+    _root_.Path.Homotopic.concat_trans_trans_symm {X : Type u} [TopologicalSpace X] {n : ℕ}
+    (p q : Fin (n + 1) → X) (F : ∀ k : Fin n, Path (p k.castSucc) (p k.succ))
+    (G : ∀ k : Fin (n + 1), Path (q k) (p k)) :
+    (Path.concat q (fun k ↦ (G k.castSucc) ≫ₚ (F k) ≫ₚ (G k.succ).symm)).Homotopic
+      ((G 0) ≫ₚ (Path.concat p F) ≫ₚ (G (Fin.last n)).symm) := by
+  induction n with
+  | zero =>
+    simp only [Path.concat_zero, ← FundamentalGroupoid.fromPath_eq_iff_homotopic]
+    aesop_cat
+  | succ n
+    hn =>
+    have ih :=
+      hn (p ∘ Fin.castSucc) (q ∘ Fin.castSucc) (fun k ↦ F k.castSucc) (fun k ↦ G k.castSucc)
+    rw [Path.concat_succ q, Path.concat_succ p]
+    exact
+      (ih.hcomp (Path.Homotopic.refl _)).trans
+        (Path.Homotopic.cancel_junction_mo1973_3458 (G 0)
+          (Path.concat (p ∘ Fin.castSucc) (fun k ↦ F k.castSucc)) (G (Fin.last n).castSucc)
+          (F (Fin.last n)) (G (Fin.last (n + 1))).symm)
+
+private lemma _root_.Path.Homotopic.cast_trans_trans_homotopic_of_homotopic_cast_mo1973_3460
+    {X : Type u} [TopologicalSpace X] {x x₀ x₁ : X} {h₀ : x₀ = x} {h₁ : x₁ = x} {p : Path x₀ x₁}
+    {q : Path x x} (h : p.Homotopic (q.cast h₀ h₁)) :
+    (((Path.refl x).cast rfl h₀) ≫ₚ p ≫ₚ ((Path.refl x).cast h₁ rfl)).Homotopic q := by
+  subst_vars
+  exact
+    Path.Homotopic.trans
+      (Path.Homotopic.trans ⟨Path.Homotopy.reflTrans _⟩ ⟨Path.Homotopy.transRefl _⟩) h
+
+private theorem _root_.Path.Homotopic.exists_loops_homotopic_concat_of_open_cover {X : Type u}
+    [TopologicalSpace X] {ι : Type v} {c : ι → Set X} {a : X} (hc₁ : ∀ i, IsOpen (c i))
+    (hc₂ : Set.univ ⊆ ⋃ i, c i) (hc₃ : ∀ i j, IsPathConnected (c i ∩ c j)) (ha : ∀ i, a ∈ c i)
+    (γ : Path a a) :
+    ∃ (n : ℕ) (D : Fin (n + 1) → Path a a),
+      Path.Homotopic (Path.concat (fun _ ↦ a) D) γ ∧ (∀ k, ∃ i : ι, Set.range (D k) ⊆ c i) := by
+  have ⟨n, t, ht₀, ht₁, ht_range⟩ := Path.exists_partition_unitInterval_of_open_cover hc₁ hc₂ γ
+  choose τ hτ using ht_range
+  have :=
+    Path.exists_path_range_of_isPathConnected_inter hc₃ ha τ (γ ∘ t)
+      (fun k ↦ hτ k (Set.mem_image_of_mem γ Set.left_mem_uIcc))
+      (fun k ↦ hτ k (Set.mem_image_of_mem γ Set.right_mem_uIcc))
+  choose G hG using this
+  let G' :=
+    Fin.snoc (α := fun k ↦ Path a (γ (t k)))
+      (Fin.cons (α := fun k ↦ Path a (γ (t k.castSucc))) ((Path.refl a).cast rfl (ht₀ ▸ γ.source))
+        G)
+      ((Path.refl a).cast rfl (ht₁ ▸ γ.target))
+  have hG'₀ : G' 0 = (Path.refl a).cast rfl (ht₀ ▸ γ.source) :=
+    (Fin.snoc_apply_zero _ _).trans (Fin.cons_zero _ _)
+  have hG'₁ : G' (Fin.last (n + 1)) = (Path.refl a).cast rfl (ht₁ ▸ γ.target) := Fin.snoc_last _ _
+  have hG'_range₀ k : Set.range (G' k.castSucc) ⊆ c (τ k) := by
+    unfold G'
+    rw [Fin.snoc_castSucc]
+    cases k using Fin.cases with
+    | zero =>
+      change Set.range (fun _ : (unitInterval) ↦ a) ⊆ c (τ 0)
+      simpa only [Set.range_const, Set.singleton_subset_iff] using ha (τ 0)
+    | succ j => exact (Set.subset_inter_iff.mp (hG j)).right
+  have hG'_range₁ k : Set.range (G' k.succ) ⊆ c (τ k) := by
+    unfold G'
+    cases k using Fin.lastCases with
+    | cast =>
+      rw [Fin.succ_castSucc, Fin.snoc_castSucc]
+      exact (Set.subset_inter_iff.mp (hG _)).left
+    | last =>
+      rw [Fin.succ_last, Fin.snoc_last]
+      change Set.range (fun _ : (unitInterval) ↦ a) ⊆ c (τ (Fin.last n))
+      simpa only [Set.range_const, Set.singleton_subset_iff] using ha (τ (Fin.last n))
+  use n, fun k ↦ (G' k.castSucc) ≫ₚ (γ.subpath (t k.castSucc) (t k.succ)) ≫ₚ (G' k.succ).symm
+  constructor
+  · apply Path.Homotopic.trans (Path.Homotopic.concat_trans_trans_symm _ _ _ _)
+    rw [hG'₀, hG'₁, ← Path.cast_symm, Path.refl_symm]
+    refine
+      Path.Homotopic.cast_trans_trans_homotopic_of_homotopic_cast_mo1973_3460
+        (Path.Homotopic.trans (Path.Homotopic.concat_subpath _ _) ?_)
+    rw! (castMode := .all) [ht₀, ht₁, Path.subpath_zero_one]
+    rfl
+  · intro k
+    use τ k
+    grind [Path.trans_range, Path.symm_range, Set.union_subset, Path.range_subpath]
+
+private instance EuclideanSphere.instLocal1 {n : ℕ} :
+    Nonempty ((fun (n : ℕ) => Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1) n) :=
+  Set.Nonempty.to_subtype (NormedSpace.sphere_nonempty.mpr (by norm_num))
+
+private instance EuclideanSphere.instLocal2 {n : ℕ} :
+    Infinite ((fun (n : ℕ) => Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1) (n + 1)) := by
+  rw [← Set.infinite_univ_iff]
+  have v : (fun (n : ℕ) => Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1) (n + 1) :=
+    Nonempty.some inferInstance
+  apply Set.Infinite.of_image (stereographic' (n + 1) v)
+  rw [Set.image_univ]
+  apply
+    Set.Infinite.mono (PartialEquiv.target_subset_range (stereographic' (n + 1) v).toPartialEquiv)
+  rw [stereographic'_target]
+  exact Set.infinite_univ
+
+private instance EuclideanSphere.instLocal3 (n : ℕ) :
+    PathConnectedSpace
+      ((fun (n : ℕ) => Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1) (n + 1)) := by
+  rw [← isPathConnected_iff_pathConnectedSpace]
+  apply isPathConnected_sphere
+  · rw [← Module.finrank_eq_rank, finrank_euclideanSpace_fin]
+    exact Nat.one_lt_ofNat
+  · exact zero_le_one' ℝ
+
+private instance EuclideanSphere.instContractibleSpace1 {n : ℕ}
+    (v : (fun (n : ℕ) => Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1) n) :
+    ContractibleSpace
+      ({ v }ᶜ : Set ((fun (n : ℕ) => Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1) n)) := by
+  let proj := stereographic' n v
+  have : ContractibleSpace proj.target := by
+    rw [stereographic'_target]
+    exact Homeomorph.contractibleSpace (Homeomorph.Set.univ (EuclideanSpace ℝ (Fin n)))
+  convert Homeomorph.contractibleSpace proj.toHomeomorphSourceTarget <;>
+    exact (stereographic'_source v).symm
+
+private theorem EuclideanSphere.isPathConnected_compl_singleton {n : ℕ}
+    (v : (fun (n : ℕ) => Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1) (n + 1)) :
+    IsPathConnected ({ v }ᶜ) := by
+  rw [isPathConnected_iff_pathConnectedSpace]
+  infer_instance
+
+private lemma EuclideanSphere.stereographic'_symm_zero {n : ℕ}
+    (v : (fun (n : ℕ) => Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1) n) :
+    (stereographic' n v).toPartialEquiv.symm 0 = -v := by
+  ext
+  simp [stereographic', stereographic, stereoInvFun]
+
+private theorem EuclideanSphere.isPathConnected_compl_singleton_inter_neg {n : ℕ}
+    (v : (fun (n : ℕ) => Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1) (n + 2)) :
+    IsPathConnected ({ v }ᶜ ∩ {-v}ᶜ) := by
+  let proj := stereographic' (n + 2) v
+  have : proj.toPartialEquiv.symm '' (proj.target \ {0}) = { v }ᶜ ∩ {-v}ᶜ := by
+    rw [PartialEquiv.symm_image_target_minus_singleton_eq, stereographic'_source,
+      stereographic'_symm_zero, Set.sdiff_eq]
+    rw [stereographic'_target]
+    exact Set.mem_univ 0
+  rw [← this]
+  apply IsPathConnected.image'
+  · rw [stereographic'_target, ← Set.compl_eq_univ_sdiff]
+    exact
+      isPathConnected_compl_singleton_of_one_lt_rank
+        (by rw [← Module.finrank_eq_rank, finrank_euclideanSpace_fin]; exact Nat.one_lt_ofNat) 0
+  · exact ContinuousOn.mono proj.continuousOn_invFun Set.sdiff_subset
+
+private abbrev EuclideanSphere.c_mo1973_3470 {n : ℕ}
+    (v : (fun (n : ℕ) => Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1) n) :
+    Fin 2 → Set ((fun (n : ℕ) => Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1) n) :=
+  Fin.cases { v }ᶜ (fun _ ↦ {-v}ᶜ)
+
+private lemma EuclideanSphere.hc₁_mo1973_3471 {n : ℕ}
+    (v : (fun (n : ℕ) => Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1) n) :
+    ∀ i, IsOpen (c_mo1973_3470 v i) := by apply Fin.cases <;> simp
+
+private lemma EuclideanSphere.hc₂_mo1973_3472 {n : ℕ}
+    (v : (fun (n : ℕ) => Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1) n) :
+    Set.univ ⊆ ⋃ i, c_mo1973_3470 v i := by
+  intro s _
+  rcases eq_or_ne s v with rfl | h
+  · rw [Set.mem_iUnion]
+    use 1
+    change
+      s ∈ ({-s}ᶜ : Set ((fun (n : ℕ) => Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1) n))
+    rw [Set.mem_compl_iff, Set.mem_singleton_iff, ← Ne, ← Subtype.coe_ne_coe, coe_neg_sphere]
+    intro hv
+    apply (ne_zero_of_mem_unit_sphere s)
+    ext k
+    rw [PiLp.zero_apply, ← CharZero.eq_neg_self_iff, ← PiLp.neg_apply, ← hv]
+  · rw [Set.mem_iUnion]
+    use 0
+    exact h
+
+private lemma EuclideanSphere.hc₃_mo1973_3473 {n : ℕ}
+    (v : (fun (n : ℕ) => Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1) (n + 2)) :
+    ∀ i j, IsPathConnected (c_mo1973_3470 v i ∩ c_mo1973_3470 v j) := by
+  apply Fin.cases
+  · apply Fin.cases
+    · simp only [Fin.cases_zero, Set.inter_self]
+      exact isPathConnected_compl_singleton v
+    · intro _
+      simp only [Fin.cases_zero, Fin.cases_succ]
+      exact isPathConnected_compl_singleton_inter_neg v
+  · intro _
+    apply Fin.cases
+    · simp only [Fin.cases_succ, Fin.cases_zero, Set.inter_comm]
+      exact isPathConnected_compl_singleton_inter_neg v
+    · intro _
+      simp only [Fin.cases_succ, Set.inter_self]
+      exact isPathConnected_compl_singleton (-v)
+
+private lemma EuclideanSphere.hx_mo1973_3474 {n : ℕ}
+    (x : (fun (n : ℕ) => Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1) (n + 1)) :
+    ∃ v, ∀ i : Fin 2, x ∈ c_mo1973_3470 v i := by
+  have ⟨v, hv⟩ := Infinite.exists_notMem_finset {x, -x}
+  use v
+  apply Fin.cases
+  · simp only [Fin.cases_zero, Set.mem_compl_singleton_iff]
+    intro h
+    apply hv
+    rw [Finset.mem_insert]
+    exact Or.inl h.symm
+  · simp only [Fin.cases_succ, Set.mem_compl_singleton_iff]
+    intro _ h
+    apply hv
+    rw [Finset.mem_insert, Finset.mem_singleton, h]
+    exact Or.inr (neg_neg v).symm
+
+public
+theorem EuclideanSphere.homotopic_refl_of_not_surjective {n : ℕ}
+    {v : (fun (n : ℕ) => Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1) n} (γ : Path v v)
+    (h : ¬(Function.Surjective γ)) : γ.Homotopic (Path.refl v) := by
+  unfold Function.Surjective at h
+  push Not at h
+  obtain ⟨w, hw⟩ := h
+  let w_compl : Set ((fun (n : ℕ) => Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1) n) :=
+    { w }ᶜ
+  let v' : w_compl :=
+    ⟨v, by
+      rw [Set.mem_compl_singleton_iff]
+      convert hw 0
+      exact γ.source.symm⟩
+  let f : (unitInterval) → γ ⁻¹' { w }ᶜ := fun x ↦ ⟨x, hw x⟩
+  let γ' : Path v' v' :=
+    { toFun := γ.restrictPreimage { w }ᶜ ∘ f
+      source' := by
+        rw [Function.comp_apply, ContinuousMap.restrictPreimage_apply]; ext
+        simp [f, v']
+      target' := by
+        rw [Function.comp_apply, ContinuousMap.restrictPreimage_apply]; ext
+        simp [f, v'] }
+  have h : SimplyConnectedSpace w_compl := inferInstance
+  let incl :
+    C(w_compl, (fun (n : ℕ) => Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1) n) :=
+    ⟨Subtype.val, continuous_subtype_val⟩
+  exact Path.Homotopic.map ((simply_connected_iff_loops_nullhomotopic.mp h).right v' γ') incl
+
+private protected theorem EuclideanSphere.simplyConnectedSpace (n : ℕ) :
+    SimplyConnectedSpace
+      ((fun (n : ℕ) => Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1) (n + 2)) := by
+  rw [simply_connected_iff_loops_nullhomotopic]
+  constructor
+  · infer_instance
+  · intro x p
+    let ⟨v, hv⟩ := hx_mo1973_3474 x
+    have ⟨m, D, hDh, hDr⟩ :=
+      Path.Homotopic.exists_loops_homotopic_concat_of_open_cover (hc₁_mo1973_3471 v)
+        (hc₂_mo1973_3472 v) (hc₃_mo1973_3473 v) hv p
+    apply Path.Homotopic.trans hDh.symm
+    rw [← Path.concat_refl]
+    apply Path.Homotopic.concat_hcomp
+    intro k
+    have ⟨i, hi⟩ := hDr k
+    fin_cases i
+    · simp only [Fin.zero_eta, Fin.cases_zero] at hi
+      apply homotopic_refl_of_not_surjective
+      exact fun h ↦ hi (h v) rfl
+    · have : (1 : Fin 2) = Fin.succ 0 := rfl
+      simp only [Fin.mk_one, this, Fin.cases_succ] at hi
+      apply homotopic_refl_of_not_surjective
+      exact fun a ↦ hi (a (-v)) rfl
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Foundations/FibreTopology.lean b/LeanPool/HopfProblem/Foundations/FibreTopology.lean
new file mode 100644
index 000000000..fa7d86168
--- /dev/null
+++ b/LeanPool/HopfProblem/Foundations/FibreTopology.lean
@@ -0,0 +1,161 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Elliptic.Core4
+import all LeanPool.HopfProblem.Elliptic.Core4
+
+/-!
+# Hopf problem: foundations · fibre topology
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem isLocalDiffeomorphAt_of_comp_localDiffeomorph {E F F' H K K' M N R : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℂ E] [NormedAddCommGroup F] [NormedSpace ℂ F]
+    [NormedAddCommGroup F'] [NormedSpace ℂ F'] [TopologicalSpace H] [TopologicalSpace K]
+    [TopologicalSpace K'] [TopologicalSpace M] [ChartedSpace H M] [TopologicalSpace N]
+    [ChartedSpace K N] [TopologicalSpace R] [ChartedSpace K' R] (I : ModelWithCorners ℂ E H)
+    (J : ModelWithCorners ℂ F K) (L : ModelWithCorners ℂ F' K') {f : M → N} {g : N → R} {x : M}
+    (hf : IsLocalDiffeomorphAt I J ω f x) (hgf : IsLocalDiffeomorphAt I L ω (g ∘ f) x) :
+    IsLocalDiffeomorphAt J L ω g (f x) := by
+  obtain ⟨φ, hx, he⟩ := hgf
+  have hinv : hf.localInverse (f x) = x := hf.localInverse_left_inv hf.localInverse_mem_target
+  refine ⟨hf.localInverse.trans φ, ⟨hf.localInverse_mem_source, ?_⟩, ?_⟩
+  · change hf.localInverse (f x) ∈ φ.source
+    rwa [hinv]
+  · intro y hy
+    change g y = φ (hf.localInverse y)
+    exact (congrArg g (hf.localInverse_right_inv hy.1).symm).trans (he hy.2)
+
+private theorem
+    isLocalDiffeomorph_of_comp_surjective {E F F' H K K' M N R : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [NormedAddCommGroup F] [NormedSpace ℂ F] [NormedAddCommGroup F']
+    [NormedSpace ℂ F'] [TopologicalSpace H] [TopologicalSpace K] [TopologicalSpace K']
+    [TopologicalSpace M] [ChartedSpace H M] [TopologicalSpace N] [ChartedSpace K N]
+    [TopologicalSpace R] [ChartedSpace K' R] (I : ModelWithCorners ℂ E H)
+    (J : ModelWithCorners ℂ F K) (L : ModelWithCorners ℂ F' K') {f : M → N} {g : N → R}
+    (hf : IsLocalDiffeomorph I J ω f) (hsurj : Function.Surjective f)
+    (hgf : IsLocalDiffeomorph I L ω (g ∘ f)) : IsLocalDiffeomorph J L ω g := by
+  intro y
+  obtain ⟨x, rfl⟩ := hsurj y
+  exact isLocalDiffeomorphAt_of_comp_localDiffeomorph I J L (hf x) (hgf x)
+
+private theorem retraction_leftInverse {A X : Type*} [TopologicalSpace A] [TopologicalSpace X]
+    (i : C(A, X)) (r : C(X, A)) (hir : r.comp i = ContinuousMap.id A) :
+    Function.LeftInverse r i := fun a => congrArg (fun f : C(A, A) => f a) hir
+
+private def
+    retractionHomotopyEquiv {A X : Type*} [TopologicalSpace A] [TopologicalSpace X] (i : C(A, X))
+    (r : C(X, A)) (hir : r.comp i = ContinuousMap.id A)
+    (H : (ContinuousMap.id X).HomotopyRel (i.comp r) (Set.range i)) :
+    ContinuousMap.HomotopyEquiv A X where
+  toFun := i
+  invFun := r
+  left_inv := by rw [hir]
+  right_inv := ⟨H.toHomotopy.symm⟩
+
+private def
+    FibreTopology.restrictPreimageFibreHomeomorph {X Y : Type*} [TopologicalSpace X] (f : X → Y)
+    (S : Set Y) (b : S) : (S.restrictPreimage f ⁻¹' { b }) ≃ₜ (f ⁻¹' {(b : Y)}) := by
+  let forward : (S.restrictPreimage f ⁻¹' { b }) → (f ⁻¹' {(b : Y)}) := fun x =>
+    ⟨x.val.val, congrArg (fun y : S => (y : Y)) x.property⟩
+  let backward : (f ⁻¹' {(b : Y)}) → (S.restrictPreimage f ⁻¹' { b }) := fun x =>
+    ⟨⟨x.val, by
+        change f x.val ∈ S
+        rw [show f x.val = b.val from x.property]
+        exact b.property⟩,
+      Subtype.ext x.property⟩
+  refine
+    { toFun := forward
+      invFun := backward
+      left_inv := fun _ => rfl
+      right_inv := fun _ => rfl
+      continuous_toFun := ?_
+      continuous_invFun := ?_ }
+  · exact (continuous_subtype_val.comp continuous_subtype_val).subtype_mk _
+  · apply Continuous.subtype_mk
+    apply Continuous.subtype_mk
+    exact continuous_subtype_val
+
+private theorem FibreTopology.restrictPreimage_fibre_isConnected {X Y : Type*} [TopologicalSpace X]
+    (f : X → Y) (S : Set Y) (b : S) (h : IsConnected (f ⁻¹' {(b : Y)})) :
+    IsConnected (S.restrictPreimage f ⁻¹' { b }) :=
+  isConnected_iff_connectedSpace.mpr
+    ((restrictPreimageFibreHomeomorph f S b).connectedSpace_iff.mpr
+      (isConnected_iff_connectedSpace.mp h))
+
+private theorem
+    FibreTopology.preimage_singleton_comp_injective {X Y Z : Type*} (f : X → Y) (g : Y → Z)
+    (hg : Function.Injective g) (b : Y) : (g ∘ f) ⁻¹' {g b} = f ⁻¹' { b } := by
+  ext x
+  exact hg.eq_iff
+
+private theorem FibreTopology.fibre_isConnected_comp_injective {X Y Z : Type*} [TopologicalSpace X]
+    (f : X → Y) (g : Y → Z) (hg : Function.Injective g) (b : Y) (h : IsConnected (f ⁻¹' { b })) :
+    IsConnected ((g ∘ f) ⁻¹' {g b}) := by
+  rw [preimage_singleton_comp_injective f g hg b]
+  exact h
+
+public
+theorem FibreTopology.fibre_isConnected_comp_homeomorph {X Y Z : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] [TopologicalSpace Z] (f : X → Y) (e : Y ≃ₜ Z) (b : Z)
+    (h : IsConnected (f ⁻¹' {e.symm b})) : IsConnected ((e ∘ f) ⁻¹' { b }) := by
+  have he := fibre_isConnected_comp_injective f e e.injective (e.symm b) h
+  simpa only [e.apply_symm_apply] using he
+
+private theorem FibreTopology.isConnected_preimage_of_closed_of_connected_fibres {X Y : Type*}
+    [TopologicalSpace X] [TopologicalSpace Y] {f : X → Y} (hf : Continuous f)
+    (hclosed : IsClosedMap f) (hconn : ∀ y, IsConnected (f ⁻¹' { y })) {s : Set Y}
+    (hs : IsConnected s) : IsConnected (f ⁻¹' s) := by
+  have hsurj : Function.Surjective f := fun y => (hconn y).nonempty
+  have hq : Topology.IsQuotientMap (s.restrictPreimage f) :=
+    (hclosed.restrictPreimage s).isQuotientMap hf.restrictPreimage (hsurj.restrictPreimage s)
+  have hlocal : ∀ y : s, IsConnected (s.restrictPreimage f ⁻¹' { y }) := fun y =>
+    restrictPreimage_fibre_isConnected f s y (hconn y)
+  let : ConnectedSpace s := isConnected_iff_connectedSpace.mp hs
+  apply isConnected_iff_connectedSpace.mpr
+  apply connectedSpace_iff_univ.mpr
+  simpa only [Set.preimage_univ] using
+    hq.isCoinducing.isConnected_preimage_of_isClosed hlocal isClosed_univ
+      (isConnected_univ : IsConnected (Set.univ : Set s))
+
+private theorem FibreTopology.isConnected_preimage_of_proper_of_connected_fibres {X Y : Type*}
+    [TopologicalSpace X] [TopologicalSpace Y] {f : X → Y} (hproper : IsProperMap f)
+    (hconn : ∀ y, IsConnected (f ⁻¹' { y })) {s : Set Y} (hs : IsConnected s) :
+    IsConnected (f ⁻¹' s) :=
+  isConnected_preimage_of_closed_of_connected_fibres hproper.continuous hproper.isClosedMap hconn
+    hs
+
+private theorem FibreTopology.isPathConnected_preimage_of_proper_of_connected_fibres {X Y : Type*}
+    [TopologicalSpace X] [TopologicalSpace Y] {f : X → Y} [LocallyPathConnectedSpace X]
+    (hproper : IsProperMap f) (hconn : ∀ y, IsConnected (f ⁻¹' { y })) {s : Set Y}
+    (hsopen : IsOpen s) (hs : IsConnected s) : IsPathConnected (f ⁻¹' s) :=
+  ((hsopen.preimage hproper.continuous).isConnected_iff_isPathConnected).mp
+    (isConnected_preimage_of_proper_of_connected_fibres hproper hconn hs)
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Foundations/InvariantSubsetQuotient.lean b/LeanPool/HopfProblem/Foundations/InvariantSubsetQuotient.lean
new file mode 100644
index 000000000..d34781c23
--- /dev/null
+++ b/LeanPool/HopfProblem/Foundations/InvariantSubsetQuotient.lean
@@ -0,0 +1,266 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.HomologyTheory.FirstHurewicz2
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz2
+
+/-!
+# Hopf problem: foundations · invariant subset quotient
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def ProductRestriction.productPreimageHomeomorph {K X Y : Type*} [TopologicalSpace K]
+    [TopologicalSpace X] (f : K × X → Y) (B : Set X) (C : Set Y) (hpre : ∀ p, f p ∈ C ↔ p.2 ∈ B) :
+    K × B ≃ₜ (f ⁻¹' C)
+    where
+  toFun p := ⟨(p.1, (p.2 : X)), (hpre _).mpr p.2.property⟩
+  invFun p := (p.1.1, ⟨p.1.2, (hpre _).mp p.property⟩)
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun :=
+    (continuous_fst.prodMk (continuous_subtype_val.comp continuous_snd)).subtype_mk _
+  continuous_invFun :=
+    (continuous_fst.comp continuous_subtype_val).prodMk
+      ((continuous_snd.comp continuous_subtype_val).subtype_mk _)
+
+private def
+    ProductRestriction.productRestriction {K X Y : Type*} (f : K × X → Y) (B : Set X) (C : Set Y)
+    (hpre : ∀ p, f p ∈ C ↔ p.2 ∈ B) (p : K × B) : C :=
+  ⟨f (p.1, (p.2 : X)), (hpre _).mpr p.2.property⟩
+
+private theorem
+    ProductRestriction.productRestriction_continuous {K X Y : Type*} [TopologicalSpace K]
+    [TopologicalSpace X] [TopologicalSpace Y] (f : K × X → Y) (B : Set X) (C : Set Y)
+    (hpre : ∀ p, f p ∈ C ↔ p.2 ∈ B) (hf : Continuous f) :
+    Continuous (productRestriction f B C hpre) :=
+  hf.restrictPreimage.comp (productPreimageHomeomorph f B C hpre).continuous
+
+private theorem
+    ProductRestriction.productRestriction_isClosedMap {K X Y : Type*} [TopologicalSpace K]
+    [TopologicalSpace X] [TopologicalSpace Y] (f : K × X → Y) (B : Set X) (C : Set Y)
+    (hpre : ∀ p, f p ∈ C ↔ p.2 ∈ B) (hf : IsClosedMap f) :
+    IsClosedMap (productRestriction f B C hpre) :=
+  (hf.restrictPreimage C).comp (productPreimageHomeomorph f B C hpre).isClosedMap
+
+private theorem
+    ProductRestriction.productRestriction_surjective {K X Y : Type*} [TopologicalSpace K]
+    [TopologicalSpace X] (f : K × X → Y) (B : Set X) (C : Set Y) (hpre : ∀ p, f p ∈ C ↔ p.2 ∈ B)
+    (hf : Function.Surjective f) : Function.Surjective (productRestriction f B C hpre) :=
+  (hf.restrictPreimage C).comp (productPreimageHomeomorph f B C hpre).surjective
+
+private def
+    InvariantSubsetQuotient.imageProject {M Q : Type*} (q : M → Q) (S : Set M) (x : S) : q '' S :=
+  ⟨q x, x, x.2, rfl⟩
+
+private theorem
+    InvariantSubsetQuotient.imageProject_surjective {M Q : Type*} {q : M → Q} {S : Set M} :
+    Function.Surjective (imageProject q S) := by
+  rintro ⟨y, x, hx, rfl⟩
+  exact ⟨⟨x, hx⟩, rfl⟩
+
+private theorem
+    InvariantSubsetQuotient.imageProject_continuous {M Q : Type*} {q : M → Q} {S : Set M}
+    [TopologicalSpace M] [TopologicalSpace Q] (hq : Continuous q) :
+    Continuous (imageProject q S) :=
+  (hq.comp continuous_subtype_val).subtype_mk _
+
+private theorem InvariantSubsetQuotient.preimage_image_eq {M Q : Type*} {q : M → Q} {S : Set M}
+    [TopologicalSpace M] [TopologicalSpace Q] {G : Type*} [Group G] [MulAction G M]
+    [MulAction G S] (hq : IsQuotientCoveringMap q G)
+    (hcompat : ∀ (g : G) (x : S), ((g • x : S) : M) = g • (x : M)) : q ⁻¹' (q '' S) = S := by
+  ext x
+  constructor
+  · rintro ⟨y, hy, hxy⟩
+    obtain ⟨g, hg⟩ := hq.apply_eq_iff_mem_orbit.mp hxy.symm
+    have he : ((g • (⟨y, hy⟩ : S) : S) : M) = x := (hcompat g ⟨y, hy⟩).trans hg
+    exact he ▸ (g • (⟨y, hy⟩ : S)).2
+  · intro hx
+    exact ⟨x, hx, rfl⟩
+
+private def InvariantSubsetQuotient.preimageImageHomeomorph {M Q : Type*} {q : M → Q} {S : Set M}
+    [TopologicalSpace M] [TopologicalSpace Q] {G : Type*} [Group G] [MulAction G M]
+    [MulAction G S] (hq : IsQuotientCoveringMap q G)
+    (hcompat : ∀ (g : G) (x : S), ((g • x : S) : M) = g • (x : M)) : S ≃ₜ q ⁻¹' (q '' S) :=
+  Homeomorph.setCongr (InvariantSubsetQuotient.preimage_image_eq hq hcompat).symm
+
+private theorem
+    InvariantSubsetQuotient.imageProject_isCoveringMap {M Q : Type*} {q : M → Q} {S : Set M}
+    [TopologicalSpace M] [TopologicalSpace Q] {G : Type*} [Group G] [MulAction G M]
+    [MulAction G S] (hq : IsQuotientCoveringMap q G)
+    (hcompat : ∀ (g : G) (x : S), ((g • x : S) : M) = g • (x : M)) :
+    IsCoveringMap (imageProject q S) := by
+  exact
+    (hq.isCoveringMap.restrictPreimage (q '' S)).comp_homeomorph
+      (preimageImageHomeomorph hq hcompat)
+
+private theorem InvariantSubsetQuotient.subtypeAction_continuousConstSMul {M Q : Type*} {q : M → Q}
+    {S : Set M} [TopologicalSpace M] [TopologicalSpace Q] {G : Type*} [Group G] [MulAction G M]
+    [MulAction G S] (hq : IsQuotientCoveringMap q G)
+    (hcompat : ∀ (g : G) (x : S), ((g • x : S) : M) = g • (x : M)) : ContinuousConstSMul G S where
+  continuous_const_smul
+    g := by
+    apply Topology.IsInducing.subtypeVal.continuous_iff.mpr
+    simpa only [Function.comp_def, hcompat] using
+      (hq.continuous_const_smul g).comp continuous_subtype_val
+
+private theorem InvariantSubsetQuotient.imageProject_eq_iff_mem_orbit {M Q : Type*} {q : M → Q}
+    {S : Set M} [TopologicalSpace M] [TopologicalSpace Q] {G : Type*} [Group G] [MulAction G M]
+    [MulAction G S] (hq : IsQuotientCoveringMap q G)
+    (hcompat : ∀ (g : G) (x : S), ((g • x : S) : M) = g • (x : M)) {x y : S} :
+    imageProject q S x = imageProject q S y ↔ x ∈ MulAction.orbit G y := by
+  rw [Subtype.ext_iff]
+  change q x = q y ↔ _
+  rw [hq.apply_eq_iff_mem_orbit]
+  constructor
+  · rintro ⟨g, hg⟩
+    exact ⟨g, Subtype.ext ((hcompat g y).trans hg)⟩
+  · rintro ⟨g, hg⟩
+    exact ⟨g, (hcompat g y).symm.trans (congrArg Subtype.val hg)⟩
+
+private theorem InvariantSubsetQuotient.imageProject_isQuotientCoveringMap {M Q : Type*} {q : M → Q}
+    {S : Set M} [TopologicalSpace M] [TopologicalSpace Q] {G : Type*} [Group G] [MulAction G M]
+    [MulAction G S] (hq : IsQuotientCoveringMap q G)
+    (hcompat : ∀ (g : G) (x : S), ((g • x : S) : M) = g • (x : M)) :
+    IsQuotientCoveringMap (imageProject q S) G
+    where
+  __ := (imageProject_isCoveringMap hq hcompat).isQuotientMap imageProject_surjective
+  __ := subtypeAction_continuousConstSMul hq hcompat
+  apply_eq_iff_mem_orbit := imageProject_eq_iff_mem_orbit hq hcompat
+  disjoint
+    x := by
+    obtain ⟨U, hU, hdisj⟩ := hq.disjoint (x : M)
+    refine
+      ⟨Subtype.val ⁻¹' U, continuous_subtype_val.continuousAt.preimage_mem_nhds hU, fun g hg =>
+        ?_⟩
+    obtain ⟨y, ⟨z, hz, hzy⟩, hy⟩ := hg
+    apply hdisj g
+    refine ⟨(y : M), ⟨(z : M), hz, ?_⟩, hy⟩
+    exact (hcompat g z).symm.trans (congrArg Subtype.val hzy)
+
+private def InvariantSubsetQuotient.quotientEquiv {M Q : Type*} {q : M → Q} {S : Set M}
+    [TopologicalSpace M] [TopologicalSpace Q] {G : Type*} [Group G] [MulAction G M]
+    [MulAction G S] (hq : IsQuotientCoveringMap q G)
+    (hcompat : ∀ (g : G) (x : S), ((g • x : S) : M) = g • (x : M)) :
+    Quotient (MulAction.orbitRel G S) ≃ q '' S :=
+  (Quotient.congrRight (fun _ _ => (imageProject_eq_iff_mem_orbit hq hcompat).symm)).trans
+    (Setoid.quotientKerEquivOfSurjective (imageProject q S) imageProject_surjective)
+
+@[simp]
+private theorem InvariantSubsetQuotient.quotientEquiv_mk {M Q : Type*} {q : M → Q} {S : Set M}
+    [TopologicalSpace M] [TopologicalSpace Q] {G : Type*} [Group G] [MulAction G M]
+    [MulAction G S] (hq : IsQuotientCoveringMap q G)
+    (hcompat : ∀ (g : G) (x : S), ((g • x : S) : M) = g • (x : M)) (x : S) :
+    quotientEquiv hq hcompat (Quotient.mk (MulAction.orbitRel G S) x) = imageProject q S x :=
+  rfl
+
+@[simp]
+private theorem InvariantSubsetQuotient.quotientEquiv_symm_imageProject {M Q : Type*} {q : M → Q}
+    {S : Set M} [TopologicalSpace M] [TopologicalSpace Q] {G : Type*} [Group G] [MulAction G M]
+    [MulAction G S] (hq : IsQuotientCoveringMap q G)
+    (hcompat : ∀ (g : G) (x : S), ((g • x : S) : M) = g • (x : M)) (x : S) :
+    (quotientEquiv hq hcompat).symm (imageProject q S x) =
+      Quotient.mk (MulAction.orbitRel G S) x := by
+  rw [← quotientEquiv_mk hq hcompat x, Equiv.symm_apply_apply]
+
+private def InvariantSubsetQuotient.quotientHomeomorph {M Q : Type*} {q : M → Q} {S : Set M}
+    [TopologicalSpace M] [TopologicalSpace Q] {G : Type*} [Group G] [MulAction G M]
+    [MulAction G S] (hq : IsQuotientCoveringMap q G)
+    (hcompat : ∀ (g : G) (x : S), ((g • x : S) : M) = g • (x : M)) :
+    Quotient (MulAction.orbitRel G S) ≃ₜ q '' S
+    where
+  toEquiv := quotientEquiv hq hcompat
+  continuous_toFun :=
+    isQuotientMap_quotient_mk'.continuous_iff.mpr (imageProject_continuous hq.continuous)
+  continuous_invFun := by
+    apply (imageProject_isQuotientCoveringMap hq hcompat).toIsQuotientMap.continuous_iff.mpr
+    change Continuous ((quotientEquiv hq hcompat).symm ∘ imageProject q S)
+    have he :
+      (quotientEquiv hq hcompat).symm ∘ imageProject q S = Quotient.mk (MulAction.orbitRel G S) :=
+      by
+      funext x
+      exact quotientEquiv_symm_imageProject hq hcompat x
+    rw [he]
+    exact continuous_quotient_mk'
+
+public
+theorem InvariantSubsetQuotient.isClosed_image {M Q : Type*} {q : M → Q} {S : Set M}
+    [TopologicalSpace M] [TopologicalSpace Q] {G : Type*} [Group G] [MulAction G M]
+    [MulAction G S] (hq : IsQuotientCoveringMap q G)
+    (hcompat : ∀ (g : G) (x : S), ((g • x : S) : M) = g • (x : M)) (hS : IsClosed S) :
+    IsClosed (q '' S) := by
+  apply hq.isCoinducing.isClosed_preimage.mp
+  rwa [InvariantSubsetQuotient.preimage_image_eq hq hcompat]
+
+private def CoveringOrthant.localChart {G M Q H : Type*} [Group G] [TopologicalSpace M]
+    [TopologicalSpace Q] [TopologicalSpace H] [MulAction G M] {q : M → Q}
+    (hq : IsQuotientCoveringMap q G) (e : OpenPartialHomeomorph M H) (a : M) :
+    OpenPartialHomeomorph Q H :=
+  (hq.isCoveringMap.isLocalHomeomorph.localInverseAt a).trans e
+
+private theorem CoveringOrthant.self_mem_localChart_source {G M Q H : Type*} [Group G]
+    [TopologicalSpace M] [TopologicalSpace Q] [TopologicalSpace H] [MulAction G M] {q : M → Q}
+    (hq : IsQuotientCoveringMap q G) (e : OpenPartialHomeomorph M H) (a : M) (ha : a ∈ e.source) :
+    q a ∈ (localChart hq e a).source := by
+  change
+    q a ∈ (hq.isCoveringMap.isLocalHomeomorph.localInverseAt a).source ∧
+      hq.isCoveringMap.isLocalHomeomorph.localInverseAt a (q a) ∈ e.source
+  exact
+    ⟨hq.isCoveringMap.isLocalHomeomorph.apply_self_mem_localInverseAt_source, by
+      simpa only [IsLocalHomeomorph.localInverseAt_apply_self] using ha⟩
+
+private theorem CoveringOrthant.localChart_symm {G M Q H : Type*} [Group G] [TopologicalSpace M]
+    [TopologicalSpace Q] [TopologicalSpace H] [MulAction G M] {q : M → Q}
+    (hq : IsQuotientCoveringMap q G) (e : OpenPartialHomeomorph M H) (a : M) :
+    ((localChart hq e a).symm : H → Q) = q ∘ e.symm := by
+  simp only [localChart, OpenPartialHomeomorph.coe_trans_symm,
+    IsLocalHomeomorph.localInverseAt_symm]
+
+@[simp]
+private theorem
+    CoveringOrthant.localChart_symm_apply {G M Q H : Type*} [Group G] [TopologicalSpace M]
+    [TopologicalSpace Q] [TopologicalSpace H] [MulAction G M] {q : M → Q}
+    (hq : IsQuotientCoveringMap q G) (e : OpenPartialHomeomorph M H) (a : M) (z : H) :
+    (localChart hq e a).symm z = q (e.symm z) := by rw [localChart_symm, Function.comp_apply]
+
+private theorem
+    CoveringOrthant.localChart_target_subset {G M Q H : Type*} [Group G] [TopologicalSpace M]
+    [TopologicalSpace Q] [TopologicalSpace H] [MulAction G M] {q : M → Q}
+    (hq : IsQuotientCoveringMap q G) (e : OpenPartialHomeomorph M H) (a : M) :
+    (localChart hq e a).target ⊆ e.target := fun _ hz => hz.1
+
+private theorem CoveringOrthant.localChart_coordinate_identity {G M Q H : Type*} [Group G]
+    [TopologicalSpace M] [TopologicalSpace Q] [TopologicalSpace H] [MulAction G M] {q : M → Q}
+    (hq : IsQuotientCoveringMap q G) (e : OpenPartialHomeomorph M H) (a : M) {R : Type*}
+    (f : Q → R) (F : H → R) (he : ∀ x ∈ e.source, f (q x) = F (e x)) :
+    ∀ z ∈ (localChart hq e a).target, f ((localChart hq e a).symm z) = F z := by
+  intro z hz
+  have hze := localChart_target_subset hq e a hz
+  rw [localChart_symm_apply, he (e.symm z) (e.map_target hze), e.right_inv hze]
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Foundations/LineBundleTransport.lean b/LeanPool/HopfProblem/Foundations/LineBundleTransport.lean
new file mode 100644
index 000000000..dc2389de7
--- /dev/null
+++ b/LeanPool/HopfProblem/Foundations/LineBundleTransport.lean
@@ -0,0 +1,92 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.Uniformization.HolomorphicCousin
+import all LeanPool.HopfProblem.Foundations.Core1
+
+/-!
+# Hopf problem: foundations · line bundle transport
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem
+    LineBundleTransport.exists_smooth_cutoff_near_closed {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {K U : Set E} (hK : IsClosed K) (hU : IsOpen U)
+    (hKU : K ⊆ U) :
+    ∃ χ : E → ℝ,
+      ContDiff ℝ ∞ χ ∧
+        tsupport χ ⊆ U ∧ ∃ W : Set E, IsOpen W ∧ K ⊆ W ∧ W ⊆ U ∧ Set.EqOn χ (fun _ => 1) W := by
+  classical
+  let O : Bool → Set E := fun b => if b then Kᶜ else U
+  have hOo (b : Bool) : IsOpen (O b) := by
+    cases b
+    · exact hU
+    · exact hK.isOpen_compl
+  have hOc : Set.univ ⊆ ⋃ b, O b := by
+    intro x _
+    by_cases hx : x ∈ U
+    · exact Set.mem_iUnion.mpr ⟨Bool.false, hx⟩
+    · exact Set.mem_iUnion.mpr ⟨Bool.true, fun hk => hx (hKU hk)⟩
+  obtain ⟨W, hWo, hKW, hWU, ρ, hρ, hρone, -, -⟩ :=
+    HolomorphicCousin.exists_smoothPartitionOfUnity_eq_one_near_closed (modelWithCornersSelf ℝ E)
+      O hOo hOc Bool.false hK hKU
+  exact ⟨ρ Bool.false, (ρ Bool.false).contMDiff.contDiff, hρ Bool.false, W, hWo, hKW, hWU, hρone⟩
+
+private theorem LineBundleTransport.exists_smooth_extension_near_closed {E F : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {K U : Set E} {f : E → F} (hK : IsClosed K) (hU : IsOpen U) (hKU : K ⊆ U)
+    (hf : ContDiffOn ℝ ∞ f U) :
+    ∃ G : E → F, ContDiff ℝ ∞ G ∧ ∃ W : Set E, IsOpen W ∧ K ⊆ W ∧ W ⊆ U ∧ Set.EqOn G f W := by
+  obtain ⟨χ, hχ, hχU, W, hWo, hKW, hWU, hχone⟩ := exists_smooth_cutoff_near_closed hK hU hKU
+  let G : E → F := fun x => χ x • f x
+  have hG : ContMDiff (modelWithCornersSelf ℝ E) (modelWithCornersSelf ℝ F) ∞ G := by
+    apply contMDiff_of_tsupport
+    intro x hx
+    have hxU : x ∈ U := hχU (tsupport_smul_subset_left χ f hx)
+    exact hχ.contMDiff.contMDiffAt.smul ((hf.contDiffAt (hU.mem_nhds hxU)).contMDiffAt)
+  refine ⟨G, hG.contDiff, W, hWo, hKW, hWU, ?_⟩
+  intro x hx
+  change χ x • f x = f x
+  rw [hχone hx, one_smul]
+
+public
+theorem LineBundleTransport.exists_interval_cutoff (a b : ℝ) :
+    ∃ χ : ℝ → ℝ, ContDiff ℝ ∞ χ ∧ HasCompactSupport χ ∧ Set.EqOn χ (fun _ => 1) (Set.uIcc a b) := by
+  obtain ⟨R, -, hR⟩ :=
+    (isCompact_uIcc : IsCompact (Set.uIcc a b)).isBounded.subset_ball_lt (0 : ℝ) 0
+  obtain ⟨χ, hχ, hχU, W, -, hKW, -, hχone⟩ :=
+    exists_smooth_cutoff_near_closed (isCompact_uIcc : IsCompact (Set.uIcc a b)).isClosed
+      Metric.isOpen_ball hR
+  refine ⟨χ, hχ, ?_, hχone.mono hKW⟩
+  exact
+    (ProperSpace.isCompact_closedBall (0 : ℝ) R).of_isClosed_subset (isClosed_tsupport χ)
+      (hχU.trans Metric.ball_subset_closedBall)
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Foundations/LocalOrbitQuotient.lean b/LeanPool/HopfProblem/Foundations/LocalOrbitQuotient.lean
new file mode 100644
index 000000000..ffab0192b
--- /dev/null
+++ b/LeanPool/HopfProblem/Foundations/LocalOrbitQuotient.lean
@@ -0,0 +1,633 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Elliptic.Core2
+
+/-!
+# Hopf problem: foundations · local orbit quotient
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem BranchedQuotientAtlas.project_localInverse_eventuallyEq {E M Q : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℂ E] [TopologicalSpace M] [ChartedSpace E M]
+    [TopologicalSpace Q] {q : M → Q} (hq : Continuous q) (e : OpenPartialHomeomorph Q E) {z : E}
+    (hz : z ∈ e.target) {a : M} (ha : q a = e.symm z)
+    (hf :
+      IsLocalDiffeomorphAt (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (e ∘ q) a) :
+    q ∘ hf.localInverse =ᶠ[𝓝 z] e.symm := by
+  have hcoord : (e ∘ q) a = z := by simp only [Function.comp_apply, ha, e.right_inv hz]
+  have hinv : hf.localInverse z = a := by
+    rw [← hcoord]
+    exact hf.localInverse_left_inv hf.localInverse_mem_target
+  have hcont : ContinuousAt (q ∘ hf.localInverse) z := by
+    have h := hq.continuousAt.comp hf.localInverse_contMDiffAt.continuousAt
+    simpa only [hcoord] using h
+  have hsource : ∀ᶠ w in 𝓝 z, q (hf.localInverse w) ∈ e.source :=
+    hcont
+      (e.open_source.mem_nhds
+        (by simpa only [Function.comp_apply, hinv, ha] using e.map_target hz))
+  have hright : ∀ᶠ w in 𝓝 z, e (q (hf.localInverse w)) = w := by
+    rw [← hcoord]
+    exact hf.localInverse_eventuallyEq_right
+  filter_upwards [hsource, hright] with w hw he
+  change q (hf.localInverse w) = e.symm w
+  exact (e.left_inv hw).symm.trans (congrArg e.symm he)
+
+private theorem
+    BranchedQuotientAtlas.contDiffAt_transition_of_lift {E M Q : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [TopologicalSpace M] [ChartedSpace E M] [TopologicalSpace Q] {q : M → Q}
+    (hq : Continuous q) (e f : OpenPartialHomeomorph Q E)
+    (hhol :
+      ContMDiffOn (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (f ∘ q)
+        (q ⁻¹' f.source))
+    {z : E} (hz : z ∈ (e.symm.trans f).source) {a : M} (ha : q a = e.symm z)
+    (hf :
+      IsLocalDiffeomorphAt (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (e ∘ q) a) :
+    ContDiffAt ℂ ω (e.symm.trans f) z := by
+  have hcoord : (e ∘ q) a = z := by simp only [Function.comp_apply, ha, e.right_inv hz.1]
+  have hinv : hf.localInverse z = a := by
+    rw [← hcoord]
+    exact hf.localInverse_left_inv hf.localInverse_mem_target
+  have hfirst :
+    ContMDiffAt (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω hf.localInverse z := by
+    simpa only [hcoord] using hf.localInverse_contMDiffAt
+  have hsecond : ContMDiffAt (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (f ∘ q) a :=
+    hhol.contMDiffAt
+      ((f.open_source.preimage hq).mem_nhds
+        (by
+          change q a ∈ f.source
+          rw [ha]
+          exact hz.2))
+  have hcomp : ContDiffAt ℂ ω ((f ∘ q) ∘ hf.localInverse) z :=
+    (hsecond.comp_of_eq hfirst hinv).contDiffAt
+  apply hcomp.congr_of_eventuallyEq
+  filter_upwards [project_localInverse_eventuallyEq hq e hz.1 ha hf] with w hw
+  change f (e.symm w) = f (q (hf.localInverse w))
+  exact congrArg f hw.symm
+
+private structure
+    BranchedQuotientAtlas.Data {E M Q : Type*} [NormedAddCommGroup E] [NormedSpace ℂ E]
+    [TopologicalSpace M] [ChartedSpace E M] [TopologicalSpace Q] (q : M → Q) (ι : Type*) where
+  chart : ι → OpenPartialHomeomorph Q E
+  cover : ∀ x : Q, ∃ i, x ∈ (chart i).source
+  continuous_project : Continuous q
+  pullback_contMDiff :
+    ∀ i,
+      ContMDiffOn (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (chart i ∘ q)
+        (q ⁻¹' (chart i).source)
+  overlap_lift :
+    ∀ i j,
+      i ≠ j →
+        ∀ z ∈ ((chart i).symm.trans (chart j)).source,
+          ∃ a : M,
+            q a = (chart i).symm z ∧
+              IsLocalDiffeomorphAt (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω
+                (chart i ∘ q) a
+
+private def
+    BranchedQuotientAtlas.Data.indexAt {E M Q : Type*} [NormedAddCommGroup E] [NormedSpace ℂ E]
+    [TopologicalSpace M] [ChartedSpace E M] [TopologicalSpace Q] {q : M → Q} {ι : Type*}
+    (D : BranchedQuotientAtlas.Data (E := E) q ι) (x : Q) : ι :=
+  (D.cover x).choose
+
+private theorem BranchedQuotientAtlas.Data.mem_chart_source {E M Q : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [TopologicalSpace M] [ChartedSpace E M] [TopologicalSpace Q] {q : M → Q}
+    {ι : Type*} (D : BranchedQuotientAtlas.Data (E := E) q ι) (x : Q) :
+    x ∈ (D.chart (D.indexAt x)).source :=
+  (D.cover x).choose_spec
+
+@[instance_reducible]
+private def BranchedQuotientAtlas.Data.chartedSpace {E M Q : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [TopologicalSpace M] [ChartedSpace E M] [TopologicalSpace Q] {q : M → Q}
+    {ι : Type*} (D : BranchedQuotientAtlas.Data (E := E) q ι) : ChartedSpace E Q
+    where
+  atlas := Set.range D.chart
+  chartAt x := D.chart (D.indexAt x)
+  mem_chart_source := D.mem_chart_source
+  chart_mem_atlas x := Set.mem_range_self (D.indexAt x)
+
+private theorem BranchedQuotientAtlas.Data.chart_mem_atlas {E M Q : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [TopologicalSpace M] [ChartedSpace E M] [TopologicalSpace Q] {q : M → Q}
+    {ι : Type*} (D : BranchedQuotientAtlas.Data (E := E) q ι) (i : ι) :
+    letI := D.chartedSpace
+    D.chart i ∈ atlas E Q :=
+  Set.mem_range_self i
+
+private theorem BranchedQuotientAtlas.Data.chartAt_eq {E M Q : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [TopologicalSpace M] [ChartedSpace E M] [TopologicalSpace Q] {q : M → Q}
+    {ι : Type*} (D : BranchedQuotientAtlas.Data (E := E) q ι) (x : Q) :
+    letI := D.chartedSpace
+    chartAt E x = D.chart (D.indexAt x) :=
+  rfl
+
+private theorem
+    BranchedQuotientAtlas.Data.contDiffOn_transition {E M Q : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [TopologicalSpace M] [ChartedSpace E M] [TopologicalSpace Q] {q : M → Q}
+    {ι : Type*} (D : BranchedQuotientAtlas.Data (E := E) q ι) (i j : ι) :
+    ContDiffOn ℂ ω ((D.chart i).symm.trans (D.chart j))
+      ((D.chart i).symm.trans (D.chart j)).source := by
+  intro z hz
+  by_cases hij : i = j
+  · subst j
+    apply contDiffWithinAt_id.congr_of_mem ?_ hz
+    intro w hw
+    exact (D.chart i).right_inv hw.1
+  · obtain ⟨a, ha, hf⟩ := D.overlap_lift i j hij z hz
+    exact
+      (BranchedQuotientAtlas.contDiffAt_transition_of_lift D.continuous_project (D.chart i)
+          (D.chart j) (D.pullback_contMDiff j) hz ha hf).contDiffWithinAt
+
+private theorem BranchedQuotientAtlas.Data.isManifold {E M Q : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [TopologicalSpace M] [ChartedSpace E M] [TopologicalSpace Q] {q : M → Q}
+    {ι : Type*} (D : BranchedQuotientAtlas.Data (E := E) q ι) :
+    letI := D.chartedSpace
+    IsManifold (modelWithCornersSelf ℂ E) ω Q := by
+  let := D.chartedSpace
+  apply isManifold_of_contDiffOn
+  rintro e f ⟨i, rfl⟩ ⟨j, rfl⟩
+  simpa using D.contDiffOn_transition i j
+
+private theorem BranchedQuotientAtlas.Data.contMDiff_project {E M Q : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [TopologicalSpace M] [ChartedSpace E M] [TopologicalSpace Q] {q : M → Q}
+    {ι : Type*} (D : BranchedQuotientAtlas.Data (E := E) q ι) :
+    letI := D.chartedSpace
+    ContMDiff (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω q := by
+  let := D.chartedSpace
+  let := D.isManifold
+  intro a
+  have hsource := D.mem_chart_source (q a)
+  have hhol :=
+    (D.pullback_contMDiff (D.indexAt (q a))).contMDiffAt
+      (((D.chart (D.indexAt (q a))).open_source.preimage D.continuous_project).mem_nhds hsource)
+  apply
+    (contMDiffAt_iff_target_of_mem_source (I := (modelWithCornersSelf ℂ E)) (I' :=
+        (modelWithCornersSelf ℂ E)) (D.mem_chart_source (q a))).mpr
+  refine ⟨D.continuous_project.continuousAt, ?_⟩
+  simpa [extChartAt, OpenPartialHomeomorph.extend, D.chartAt_eq, Function.comp_def] using hhol
+
+private def OnePointAtlas.inclusionChart {Q : Type*} [TopologicalSpace Q] [Nonempty Q] :
+    OpenPartialHomeomorph Q (OnePoint Q) :=
+  OnePoint.isOpenEmbedding_coe.toOpenPartialHomeomorph ((↑) : Q → OnePoint Q)
+
+@[simp]
+private theorem OnePointAtlas.inclusionChart_source {Q : Type*} [TopologicalSpace Q] [Nonempty Q] :
+    (inclusionChart (Q := Q)).source = Set.univ :=
+  OnePoint.isOpenEmbedding_coe.toOpenPartialHomeomorph_source _
+
+@[simp]
+private theorem OnePointAtlas.inclusionChart_target {Q : Type*} [TopologicalSpace Q] [Nonempty Q] :
+    (inclusionChart (Q := Q)).target = Set.range ((↑) : Q → OnePoint Q) :=
+  OnePoint.isOpenEmbedding_coe.toOpenPartialHomeomorph_target _
+
+@[simp]
+private theorem OnePointAtlas.inclusionChart_symm_coe {Q : Type*} [TopologicalSpace Q] [Nonempty Q]
+    (q : Q) : (inclusionChart (Q := Q)).symm (q : OnePoint Q) = q :=
+  (inclusionChart (Q := Q)).left_inv (by simp)
+
+private def OnePointAtlas.oldChart {Q : Type*} [TopologicalSpace Q] [Nonempty Q] [ChartedSpace ℂ Q]
+    (q : Q) : OpenPartialHomeomorph (OnePoint Q) ℂ :=
+  (inclusionChart (Q := Q)).symm.trans (chartAt ℂ q)
+
+@[simp]
+private theorem OnePointAtlas.oldChart_coe {Q : Type*} [TopologicalSpace Q] [Nonempty Q]
+    [ChartedSpace ℂ Q] (q x : Q) : oldChart q (x : OnePoint Q) = chartAt ℂ q x := by
+  change chartAt ℂ q ((inclusionChart (Q := Q)).symm (x : OnePoint Q)) = _
+  rw [inclusionChart_symm_coe]
+
+private theorem OnePointAtlas.oldChart_comp_coe {Q : Type*} [TopologicalSpace Q] [Nonempty Q]
+    [ChartedSpace ℂ Q] (q : Q) : oldChart q ∘ ((↑) : Q → OnePoint Q) = chartAt ℂ q := by
+  funext x
+  exact oldChart_coe q x
+
+@[simp]
+private theorem OnePointAtlas.coe_mem_oldChart_source {Q : Type*} [TopologicalSpace Q] [Nonempty Q]
+    [ChartedSpace ℂ Q] (q x : Q) :
+    (x : OnePoint Q) ∈ (oldChart q).source ↔ x ∈ (chartAt ℂ q).source := by
+  change
+    ((x : OnePoint Q) ∈ (inclusionChart (Q := Q)).target ∧
+        (inclusionChart (Q := Q)).symm (x : OnePoint Q) ∈ (chartAt ℂ q).source) ↔
+      _
+  simp only [inclusionChart_target, Set.mem_range_self, inclusionChart_symm_coe, true_and]
+
+private theorem OnePointAtlas.oldChart_preimage_source {Q : Type*} [TopologicalSpace Q] [Nonempty Q]
+    [ChartedSpace ℂ Q] (q : Q) :
+    ((↑) : Q → OnePoint Q) ⁻¹' (oldChart q).source = (chartAt ℂ q).source := by
+  ext x
+  exact coe_mem_oldChart_source q x
+
+private theorem
+    OnePointAtlas.infty_not_mem_oldChart_source {Q : Type*} [TopologicalSpace Q] [Nonempty Q]
+    [ChartedSpace ℂ Q] (q : Q) : ((OnePoint.infty) : OnePoint Q) ∉ (oldChart q).source := by
+  intro hx
+  have hr : ((OnePoint.infty) : OnePoint Q) ∈ Set.range ((↑) : Q → OnePoint Q) :=
+    inclusionChart_target (Q := Q) ▸ hx.1
+  obtain ⟨x, hx⟩ := hr
+  exact OnePoint.coe_ne_infty x hx
+
+private theorem
+    OnePointAtlas.oldChart_pullback_holomorphic {Q : Type*} [TopologicalSpace Q] [Nonempty Q]
+    [ChartedSpace ℂ Q] [IsManifold 𝓘(ℂ) ω Q] (q : Q) :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (oldChart q ∘ ((↑) : Q → OnePoint Q))
+      (((↑) : Q → OnePoint Q) ⁻¹' (oldChart q).source) := by
+  rw [oldChart_comp_coe, oldChart_preimage_source]
+  exact contMDiffOn_chart
+
+private theorem OnePointAtlas.oldChart_pullback_localDiffeomorph {Q : Type*} [TopologicalSpace Q]
+    [Nonempty Q] [ChartedSpace ℂ Q] [IsManifold 𝓘(ℂ) ω Q] (q x : Q)
+    (hx : (x : OnePoint Q) ∈ (oldChart q).source) :
+    IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω (oldChart q ∘ ((↑) : Q → OnePoint Q)) x := by
+  rw [oldChart_comp_coe]
+  refine
+    ⟨{  toPartialEquiv := (chartAt ℂ q).toPartialEquiv
+        open_source := (chartAt ℂ q).open_source
+        open_target := (chartAt ℂ q).open_target
+        contMDiffOn_toFun := contMDiffOn_chart
+        contMDiffOn_invFun := contMDiffOn_chart_symm }, ?_, ?_⟩
+  · exact (coe_mem_oldChart_source q x).mp hx
+  · exact Set.eqOn_refl _ _
+
+private def OnePointAtlas.chart {Q : Type*} [TopologicalSpace Q] [Nonempty Q] [ChartedSpace ℂ Q]
+    (e : OpenPartialHomeomorph (OnePoint Q) ℂ) : Option Q → OpenPartialHomeomorph (OnePoint Q) ℂ
+  | none => e
+  | some q => oldChart q
+
+private theorem
+    OnePointAtlas.chart_cover {Q : Type*} [TopologicalSpace Q] [Nonempty Q] [ChartedSpace ℂ Q]
+    (e : OpenPartialHomeomorph (OnePoint Q) ℂ) (he : ((OnePoint.infty) : OnePoint Q) ∈ e.source)
+    (x : OnePoint Q) : ∃ i, x ∈ (chart e i).source := by
+  induction x using OnePoint.rec
+  · exact ⟨Option.none, he⟩
+  · rename_i q
+    exact ⟨Option.some q, (coe_mem_oldChart_source q q).mpr (mem_chart_source ℂ q)⟩
+
+private theorem OnePointAtlas.overlap_ne_infty {Q : Type*} [TopologicalSpace Q] [Nonempty Q]
+    [ChartedSpace ℂ Q] (e : OpenPartialHomeomorph (OnePoint Q) ℂ) (i j : Option Q) (hij : i ≠ j)
+    (z : ℂ) (hz : z ∈ ((chart e i).symm.trans (chart e j)).source) :
+    (chart e i).symm z ≠ ((OnePoint.infty) : OnePoint Q) := by
+  intro hinfty
+  cases i with
+  | some q =>
+    apply infty_not_mem_oldChart_source q
+    rw [← hinfty]
+    exact (oldChart q).map_target hz.1
+  | none =>
+    cases j with
+    | none => exact hij rfl
+    | some q =>
+      apply infty_not_mem_oldChart_source q
+      rw [← hinfty]
+      exact hz.2
+
+private def OnePointAtlas.data {Q : Type*} [TopologicalSpace Q] [Nonempty Q] [ChartedSpace ℂ Q]
+    (e : OpenPartialHomeomorph (OnePoint Q) ℂ) [IsManifold 𝓘(ℂ) ω Q]
+    (he : ((OnePoint.infty) : OnePoint Q) ∈ e.source)
+    (hholo :
+      ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (e ∘ ((↑) : Q → OnePoint Q)) (((↑) : Q → OnePoint Q) ⁻¹' e.source))
+    (hlocal :
+      ∀ x : Q,
+        (x : OnePoint Q) ∈ e.source →
+          IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω (e ∘ ((↑) : Q → OnePoint Q)) x) :
+    BranchedQuotientAtlas.Data (E := ℂ) ((↑) : Q → OnePoint Q) (Option Q)
+    where
+  chart := chart e
+  cover := chart_cover e he
+  continuous_project := OnePoint.continuous_coe
+  pullback_contMDiff
+    i := by
+    cases i with
+    | none => exact hholo
+    | some q => exact oldChart_pullback_holomorphic q
+  overlap_lift i j hij z
+    hz := by
+    have hne := overlap_ne_infty e i j hij z hz
+    obtain ⟨x, hx⟩ : ∃ x : Q, (x : OnePoint Q) = (chart e i).symm z := by
+      induction h : (chart e i).symm z using OnePoint.rec
+      · exact (hne h).elim
+      · rename_i x
+        exact ⟨x, rfl⟩
+    have hsource : (x : OnePoint Q) ∈ (chart e i).source := by
+      rw [hx]
+      exact (chart e i).map_target hz.1
+    refine ⟨x, hx, ?_⟩
+    cases i with
+    | none => exact hlocal x hsource
+    | some q => exact oldChart_pullback_localDiffeomorph q x hsource
+
+private def FreeActionLocus.locus (G X : Type*) [Group G] [MulAction G X] : Set X :=
+  {x | ∀ g : G, g • x = x → g = 1}
+
+private abbrev FreeActionLocus.Space (G X : Type*) [Group G] [MulAction G X] :=
+  { x : X // x ∈ locus G X }
+
+private theorem
+    FreeActionLocus.smul_mem_locus (G X : Type*) [Group G] [MulAction G X] (g : G) {x : X}
+    (hx : x ∈ locus G X) : g • x ∈ locus G X := by
+  intro h hh
+  have he : g⁻¹ * h * g = 1 :=
+    hx _
+      (by
+        simpa only [SemigroupAction.mul_smul, inv_smul_smul] using congrArg (fun y => g⁻¹ • y) hh)
+  simpa only [mul_assoc, mul_inv_cancel, mul_one, mul_inv_cancel_left, inv_mul_cancel,
+    one_mul] using congrArg (fun k : G => g * k * g⁻¹) he
+
+private theorem FreeActionLocus.smul_mem_locus_iff (G X : Type*) [Group G] [MulAction G X] (g : G)
+    (x : X) : g • x ∈ locus G X ↔ x ∈ locus G X := by
+  refine ⟨fun hx => ?_, smul_mem_locus G X g⟩
+  simpa only [inv_smul_smul] using smul_mem_locus G X g⁻¹ hx
+
+private instance FreeActionLocus.mulAction (G X : Type*) [Group G] [MulAction G X] :
+    MulAction G (Space G X)
+    where
+  smul g x := ⟨g • x.val, smul_mem_locus G X g x.property⟩
+  one_smul x := Subtype.ext (one_smul G x.val)
+  mul_smul g h x := Subtype.ext (SemigroupAction.mul_smul g h x.val)
+
+private instance FreeActionLocus.isCancelSMul (G X : Type*) [Group G] [MulAction G X] :
+    IsCancelSMul G (Space G X) := by
+  apply isCancelSMul_iff_eq_one_of_smul_eq.mpr
+  intro g x hx
+  exact x.property g (congrArg Subtype.val hx)
+
+private instance FreeActionLocus.continuousConstSMul (G X : Type*) [Group G] [MulAction G X]
+    [TopologicalSpace X] [ContinuousConstSMul G X] : ContinuousConstSMul G (Space G X) where
+  continuous_const_smul
+    g := ((ContinuousConstSMul.continuous_const_smul g).comp continuous_subtype_val).subtype_mk _
+
+private instance FreeActionLocus.properlyDiscontinuousSMul (G X : Type*) [Group G] [MulAction G X]
+    [TopologicalSpace X] [ProperlyDiscontinuousSMul G X] : ProperlyDiscontinuousSMul G (Space G X)
+    where
+  finite_disjoint_inter_image {K L} hK
+    hL := by
+    apply
+      (ProperlyDiscontinuousSMul.finite_disjoint_inter_image (Γ := G)
+          (hK.image continuous_subtype_val) (hL.image continuous_subtype_val)).subset
+    rintro g ⟨y, ⟨x, hx, hxy⟩, hy⟩
+    exact ⟨y.val, ⟨x.val, ⟨x, hx, rfl⟩, congrArg Subtype.val hxy⟩, ⟨y, hy, rfl⟩⟩
+
+private theorem FreeActionLocus.isOfFinOrder_of_smul_eq (G X : Type*) [Group G] [MulAction G X]
+    [TopologicalSpace X] [ProperlyDiscontinuousSMul G X] (g : G) (x : X) (hg : g • x = x) :
+    IsOfFinOrder g := by
+  let := (ProperlyDiscontinuousSMul.finite_stabilizer (Γ := G) x).fintype
+  exact
+    (MulAction.stabilizer G x).subtype.isOfFinOrder
+      (isOfFinOrder_of_finite (⟨g, hg⟩ : MulAction.stabilizer G x))
+
+private theorem
+    FreeActionLocus.isOpen_locus (G X : Type*) [Group G] [MulAction G X] [TopologicalSpace X]
+    [T2Space X] [LocallyCompactSpace X] [ContinuousConstSMul G X]
+    [ProperlyDiscontinuousSMul G X] : IsOpen (locus G X) := by
+  rw [isOpen_iff_mem_nhds]
+  intro x hx
+  obtain ⟨U, hU, hdis⟩ := ProperlyDiscontinuousSMul.exists_nhds_image_smul_eq_self G x
+  apply Filter.mem_of_superset hU
+  intro y hy g hgy
+  exact hx g (hdis g ⟨y, ⟨y, hy, hgy⟩, hy⟩)
+
+private def
+    FreeActionLocus.opens (G X : Type*) [Group G] [MulAction G X] [TopologicalSpace X] [T2Space X]
+    [LocallyCompactSpace X] [ContinuousConstSMul G X] [ProperlyDiscontinuousSMul G X] :
+    TopologicalSpace.Opens X :=
+  ⟨locus G X, isOpen_locus G X⟩
+
+private instance FreeActionLocus.chartedSpace (G X E : Type*) [Group G] [TopologicalSpace X]
+    [MulAction G X] [T2Space X] [LocallyCompactSpace X] [ContinuousConstSMul G X]
+    [ProperlyDiscontinuousSMul G X] [NormedAddCommGroup E] [ChartedSpace E X] :
+    ChartedSpace E (Space G X) :=
+  inferInstanceAs (ChartedSpace E (opens G X))
+
+private theorem FreeActionLocus.smul_contMDiff (G X E : Type*) [Group G] [TopologicalSpace X]
+    [MulAction G X] [T2Space X] [LocallyCompactSpace X] [ContinuousConstSMul G X]
+    [ProperlyDiscontinuousSMul G X] [NormedAddCommGroup E] [NormedSpace ℂ E] [ChartedSpace E X]
+    (n : ℕ∞ω)
+    (hG :
+      ∀ g : G,
+        ContMDiff (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) n (fun x : X => g • x))
+    (g : G) :
+    ContMDiff (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) n
+      (fun x : Space G X => g • x) := by
+  intro x
+  have he :
+    ContMDiffAt (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) n
+        (fun y : Space G X => ((g • y : Space G X) : X)) x ↔
+      ContMDiffAt (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) n
+        (fun y : Space G X => g • y) x :=
+    ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff (U := opens G X)
+      (fun y : Space G X => g • y) Set.univ x
+  exact he.mp (((hG g).comp (contMDiff_subtype_val (U := opens G X))) x)
+
+@[instance_reducible]
+private def LocalOrbitQuotient.restrictedAction {G X : Type*} [Group G] [TopologicalSpace X]
+    [MulAction G X] (H : Subgroup G) (U : TopologicalSpace.Opens X)
+    (hU : ∀ h : H, Set.MapsTo (fun x : X => (h : G) • x) U U) : MulAction H U
+    where
+  smul h x := ⟨(h : G) • (x : X), hU h x.property⟩
+  one_smul x := Subtype.ext (one_smul G (x : X))
+  mul_smul h k x := Subtype.ext (SemigroupAction.mul_smul (h : G) (k : G) (x : X))
+
+private abbrev LocalOrbitQuotient.LocalQuotient {G X : Type*} [Group G] [TopologicalSpace X]
+    [MulAction G X] (H : Subgroup G) (U : TopologicalSpace.Opens X)
+    (hU : ∀ h : H, Set.MapsTo (fun x : X => (h : G) • x) U U) :=
+  letI := restrictedAction H U hU
+  Quotient (MulAction.orbitRel H U)
+
+private def LocalOrbitQuotient.localProjection {G X : Type*} [Group G] [TopologicalSpace X]
+    [MulAction G X] (H : Subgroup G) (U : TopologicalSpace.Opens X)
+    (hU : ∀ h : H, Set.MapsTo (fun x : X => (h : G) • x) U U) : U → LocalQuotient H U hU :=
+  Quotient.mk _
+
+private theorem
+    LocalOrbitQuotient.localProjection_eq_iff {G X : Type*} [Group G] [TopologicalSpace X]
+    [MulAction G X] (H : Subgroup G) (U : TopologicalSpace.Opens X)
+    (hU : ∀ h : H, Set.MapsTo (fun x : X => (h : G) • x) U U) (x y : U) :
+    localProjection H U hU x = localProjection H U hU y ↔ ∃ h : H, (h : G) • (y : X) = (x : X) := by
+  let := restrictedAction H U hU
+  rw [localProjection, Quotient.eq]
+  change (∃ h : H, h • y = x) ↔ _
+  exact exists_congr fun h => Subtype.ext_iff
+
+private theorem
+    LocalOrbitQuotient.localProjection_surjective {G X : Type*} [Group G] [TopologicalSpace X]
+    [MulAction G X] (H : Subgroup G) (U : TopologicalSpace.Opens X)
+    (hU : ∀ h : H, Set.MapsTo (fun x : X => (h : G) • x) U U) :
+    Function.Surjective (localProjection H U hU) :=
+  Quotient.mk_surjective
+
+private theorem
+    LocalOrbitQuotient.localProjection_continuous {G X : Type*} [Group G] [TopologicalSpace X]
+    [MulAction G X] (H : Subgroup G) (U : TopologicalSpace.Opens X)
+    (hU : ∀ h : H, Set.MapsTo (fun x : X => (h : G) • x) U U) :
+    Continuous (localProjection H U hU) :=
+  continuous_quotient_mk'
+
+private def
+    LocalOrbitQuotient.imageOpen {G X : Type*} [Group G] [TopologicalSpace X] [MulAction G X]
+    (U : TopologicalSpace.Opens X) [ContinuousConstSMul G X] :
+    TopologicalSpace.Opens (Quotient (MulAction.orbitRel G X)) :=
+  ⟨Quotient.mk (MulAction.orbitRel G X) '' (U : Set X),
+    MulAction.isOpenQuotientMap_quotientMk.isOpenMap _ U.isOpen⟩
+
+private def LocalOrbitQuotient.imageProjection {G X : Type*} [Group G] [TopologicalSpace X]
+    [MulAction G X] (U : TopologicalSpace.Opens X) [ContinuousConstSMul G X] :
+    U → imageOpen (G := G) U := fun x => ⟨Quotient.mk _ (x : X), x, x.property, rfl⟩
+
+private theorem
+    LocalOrbitQuotient.imageProjection_surjective {G X : Type*} [Group G] [TopologicalSpace X]
+    [MulAction G X] (U : TopologicalSpace.Opens X) [ContinuousConstSMul G X] :
+    Function.Surjective (imageProjection (G := G) U) := by
+  rintro ⟨q, x, hx, rfl⟩
+  exact ⟨⟨x, hx⟩, rfl⟩
+
+private theorem
+    LocalOrbitQuotient.imageProjection_continuous {G X : Type*} [Group G] [TopologicalSpace X]
+    [MulAction G X] (U : TopologicalSpace.Opens X) [ContinuousConstSMul G X] :
+    Continuous (imageProjection (G := G) U) :=
+  (continuous_quotient_mk'.comp continuous_subtype_val).subtype_mk _
+
+private theorem
+    LocalOrbitQuotient.imageProjection_isOpenMap {G X : Type*} [Group G] [TopologicalSpace X]
+    [MulAction G X] (U : TopologicalSpace.Opens X) [ContinuousConstSMul G X] :
+    IsOpenMap (imageProjection (G := G) U) :=
+  (MulAction.isOpenQuotientMap_quotientMk.isOpenMap.comp
+        U.isOpen.isOpenMap_subtype_val).subtype_mk
+    _
+
+private theorem LocalOrbitQuotient.imageProjection_isOpenQuotientMap {G X : Type*} [Group G]
+    [TopologicalSpace X] [MulAction G X] (U : TopologicalSpace.Opens X)
+    [ContinuousConstSMul G X] : IsOpenQuotientMap (imageProjection (G := G) U) :=
+  ⟨imageProjection_surjective U, imageProjection_continuous U, imageProjection_isOpenMap U⟩
+
+private def
+    LocalOrbitQuotient.localToImage {G X : Type*} [Group G] [TopologicalSpace X] [MulAction G X]
+    (H : Subgroup G) (U : TopologicalSpace.Opens X)
+    (hU : ∀ h : H, Set.MapsTo (fun x : X => (h : G) • x) U U) [ContinuousConstSMul G X] :
+    LocalQuotient H U hU → imageOpen (G := G) U :=
+  Quotient.lift (imageProjection (G := G) U) fun x y h =>
+    by
+    apply Subtype.ext
+    apply Quotient.sound
+    obtain ⟨g, hg⟩ := h
+    exact ⟨(g : G), congrArg Subtype.val hg⟩
+
+private theorem
+    LocalOrbitQuotient.localToImage_continuous {G X : Type*} [Group G] [TopologicalSpace X]
+    [MulAction G X] (H : Subgroup G) (U : TopologicalSpace.Opens X)
+    (hU : ∀ h : H, Set.MapsTo (fun x : X => (h : G) • x) U U) [ContinuousConstSMul G X] :
+    Continuous (localToImage H U hU) :=
+  (imageProjection_continuous U).quotient_lift _
+
+private theorem
+    LocalOrbitQuotient.localToImage_surjective {G X : Type*} [Group G] [TopologicalSpace X]
+    [MulAction G X] (H : Subgroup G) (U : TopologicalSpace.Opens X)
+    (hU : ∀ h : H, Set.MapsTo (fun x : X => (h : G) • x) U U) [ContinuousConstSMul G X] :
+    Function.Surjective (localToImage H U hU) := by
+  intro q
+  obtain ⟨x, rfl⟩ := imageProjection_surjective U q
+  exact ⟨localProjection H U hU x, rfl⟩
+
+private theorem
+    LocalOrbitQuotient.localToImage_isOpenMap {G X : Type*} [Group G] [TopologicalSpace X]
+    [MulAction G X] (H : Subgroup G) (U : TopologicalSpace.Opens X)
+    (hU : ∀ h : H, Set.MapsTo (fun x : X => (h : G) • x) U U) [ContinuousConstSMul G X] :
+    IsOpenMap (localToImage H U hU) :=
+  IsOpenMap.of_comp (localProjection_continuous H U hU) (localProjection_surjective H U hU)
+    (imageProjection_isOpenMap U)
+
+private theorem
+    LocalOrbitQuotient.localToImage_injective {G X : Type*} [Group G] [TopologicalSpace X]
+    [MulAction G X] (H : Subgroup G) (U : TopologicalSpace.Opens X)
+    (hU : ∀ h : H, Set.MapsTo (fun x : X => (h : G) • x) U U) [ContinuousConstSMul G X]
+    (hreturn : ∀ g : G, (((g • ·) '' (U : Set X)) ∩ U).Nonempty → g ∈ H) :
+    Function.Injective (localToImage H U hU) := by
+  intro q r
+  refine Quotient.inductionOn₂ q r ?_
+  intro x y h
+  have hxy :
+    Quotient.mk (MulAction.orbitRel G X) (x : X) = Quotient.mk (MulAction.orbitRel G X) (y : X) :=
+    congrArg Subtype.val h
+  obtain ⟨g, hg⟩ := Quotient.exact hxy
+  have hgH : g ∈ H := hreturn g ⟨x, ⟨y, y.property, hg⟩, x.property⟩
+  exact (localProjection_eq_iff H U hU x y).mpr ⟨⟨g, hgH⟩, hg⟩
+
+private def LocalOrbitQuotient.localHomeomorph {G X : Type*} [Group G] [TopologicalSpace X]
+    [MulAction G X] (H : Subgroup G) (U : TopologicalSpace.Opens X)
+    (hU : ∀ h : H, Set.MapsTo (fun x : X => (h : G) • x) U U) [ContinuousConstSMul G X]
+    (hreturn : ∀ g : G, (((g • ·) '' (U : Set X)) ∩ U).Nonempty → g ∈ H) :
+    LocalQuotient H U hU ≃ₜ imageOpen (G := G) U :=
+  Equiv.toHomeomorphOfContinuousOpen
+    (Equiv.ofBijective (localToImage H U hU)
+      ⟨localToImage_injective H U hU hreturn, localToImage_surjective H U hU⟩)
+    (localToImage_continuous H U hU) (localToImage_isOpenMap H U hU)
+
+private theorem
+    isLocalDiffeomorphAt_of_comp_opensSubtypeVal {E F H K M N : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [NormedAddCommGroup F] [NormedSpace ℂ F] [TopologicalSpace H]
+    [TopologicalSpace K] [TopologicalSpace M] [ChartedSpace H M] [TopologicalSpace N]
+    [ChartedSpace K N] (I : ModelWithCorners ℂ E H) (J : ModelWithCorners ℂ F K)
+    (U : TopologicalSpace.Opens M) {f : M → N} (x : U)
+    (hf : IsLocalDiffeomorphAt I J ω (f ∘ (Subtype.val : U → M)) x) :
+    IsLocalDiffeomorphAt I J ω f (x : M) := by
+  obtain ⟨φ, hx, he⟩ := hf
+  let e := opensInclusionPartialDiffeomorph I U ⟨x⟩
+  have hxU : (x : M) ∈ e.target := by
+    change (x : M) ∈ (U.openPartialHomeomorphSubtypeCoe ⟨x⟩).target
+    rw [TopologicalSpace.Opens.openPartialHomeomorphSubtypeCoe_target]
+    change (x : M) ∈ U
+    exact x.property
+  have hinv : e.symm (x : M) = x := e.left_inv (Set.mem_univ x)
+  refine ⟨e.symm.trans φ, ⟨hxU, ?_⟩, ?_⟩
+  · change e.symm (x : M) ∈ φ.source
+    rw [hinv]
+    exact hx
+  intro y hy
+  have hval : ((e.symm y : U) : M) = y := e.right_inv hy.1
+  change f y = φ (e.symm y)
+  exact (congrArg f hval.symm).trans (he hy.2)
+
+public
+theorem isLocalDiffeomorphAt_congr_of_eventuallyEq {E F H K M N : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [NormedAddCommGroup F] [NormedSpace ℂ F] [TopologicalSpace H]
+    [TopologicalSpace K] [TopologicalSpace M] [ChartedSpace H M] [TopologicalSpace N]
+    [ChartedSpace K N] {I : ModelWithCorners ℂ E H} {J : ModelWithCorners ℂ F K} {n : ℕ∞ω}
+    {f g : M → N} {x : M} (hf : IsLocalDiffeomorphAt I J n f x) (hgf : g =ᶠ[𝓝 x] f) :
+    IsLocalDiffeomorphAt I J n g x := by
+  obtain ⟨U, hUf, hU, hxU⟩ := mem_nhds_iff.mp hgf
+  obtain ⟨Φ, hx, hΦ⟩ := hf
+  let Ψ : PartialDiffeomorph I J M N n :=
+    { toPartialEquiv := (Φ.toOpenPartialHomeomorph.restrOpen U hU).toPartialEquiv
+      open_source := (Φ.toOpenPartialHomeomorph.restrOpen U hU).open_source
+      open_target := (Φ.toOpenPartialHomeomorph.restrOpen U hU).open_target
+      contMDiffOn_toFun := Φ.contMDiffOn_toFun.mono Set.inter_subset_left
+      contMDiffOn_invFun := Φ.contMDiffOn_invFun.mono Set.inter_subset_left }
+  refine ⟨Ψ, ⟨hx, hxU⟩, ?_⟩
+  intro y hy
+  exact (hUf hy.2).trans (hΦ hy.1)
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Foundations/PeriodTorusTypeOneOne.lean b/LeanPool/HopfProblem/Foundations/PeriodTorusTypeOneOne.lean
new file mode 100644
index 000000000..8c4657000
--- /dev/null
+++ b/LeanPool/HopfProblem/Foundations/PeriodTorusTypeOneOne.lean
@@ -0,0 +1,106 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Elliptic.Core7
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology4
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+import all LeanPool.HopfProblem.Lattice.Core2
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology7
+import all LeanPool.HopfProblem.Elliptic.Core7
+
+/-!
+# Hopf problem: foundations · period torus type one one
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def PeriodTorusTypeOneOne.coordinateValue {R : Type*} [CommRing R] (E : Fin 6 → R)
+    (x y : Fin 4 → R) : R :=
+  E 0 * (x 0 * y 1 - x 1 * y 0) + E 1 * (x 0 * y 2 - x 2 * y 0) + E 2 * (x 0 * y 3 - x 3 * y 0) +
+        E 3 * (x 1 * y 2 - x 2 * y 1) +
+      E 4 * (x 1 * y 3 - x 3 * y 1) +
+    E 5 * (x 2 * y 3 - x 3 * y 2)
+
+/-- The ordered coordinate pair represented by each exterior-square basis index. -/
+public
+def PeriodTorusTypeOneOne.coefficientPair : Fin 6 → Fin 4 × Fin 4 :=
+  ![(0, 1), (0, 2), (0, 3), (1, 2), (1, 3), (2, 3)]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+public
+theorem PeriodTorusCohomologyCup.pairIndices_eq_coefficientPair (k : Fin 6) :
+    LocalSystemMatrices.pairIndices k =
+      ![(PeriodTorusTypeOneOne.coefficientPair k).1,
+        (PeriodTorusTypeOneOne.coefficientPair k).2] := by fin_cases k <;> rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusCohomologyCup.coordinateTorusH2Coordinates_basis_pair (k : Fin 6) :
+    PeriodTorusHigherHomology.coordinateTorusH2Coordinates
+        (PeriodTorusHigherHomologyPontryagin.product11 (PeriodTorusHigherHomology.ProductTorus 4)
+          (FirstHurewicz.loopHomologyClass
+            (PeriodTorusHigherHomology.coordinatePeriodLoop 4
+              (Pi.single (PeriodTorusTypeOneOne.coefficientPair k).1 1)))
+          (FirstHurewicz.loopHomologyClass
+            (PeriodTorusHigherHomology.coordinatePeriodLoop 4
+              (Pi.single (PeriodTorusTypeOneOne.coefficientPair k).2 1)))) =
+      Pi.single k 1 := by
+  have hp :
+    PeriodTorusHigherHomology.coordinateTorusWedgeTwo
+        (PeriodTorusHigherHomologyExterior.squareBasis k) =
+      PeriodTorusHigherHomologyPontryagin.product11 (PeriodTorusHigherHomology.ProductTorus 4)
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 4
+            (Pi.single (PeriodTorusTypeOneOne.coefficientPair k).1 1)))
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 4
+            (Pi.single (PeriodTorusTypeOneOne.coefficientPair k).2 1))) := by
+    rw [PeriodTorusHigherHomologyExterior.squareBasis_apply,
+      PeriodTorusHigherHomology.coordinateTorusWedgeTwo_apply_ιMulti_periodLoops
+        (Elliptic.examplePeriod .four),
+      pairIndices_eq_coefficientPair]
+    simp only [Function.comp_apply, Matrix.cons_val_zero, Matrix.cons_val_one,
+      PeriodTorusHigherHomologyExterior.latticeBasis, Pi.basisFun_apply]
+  rw [← hp]
+  change
+    PeriodTorusHigherHomologyExterior.squareCoordinates
+        (PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv
+          (PeriodTorusHigherHomology.coordinateTorusWedgeTwo
+            (PeriodTorusHigherHomologyExterior.squareBasis k))) =
+      _
+  rw [PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv_wedge]
+  ext l
+  simp [PeriodTorusHigherHomologyExterior.squareCoordinates_apply, Finsupp.single_apply,
+    Pi.single_apply, eq_comm]
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Foundations/SplitGroupExtension.lean b/LeanPool/HopfProblem/Foundations/SplitGroupExtension.lean
new file mode 100644
index 000000000..d69f6114c
--- /dev/null
+++ b/LeanPool/HopfProblem/Foundations/SplitGroupExtension.lean
@@ -0,0 +1,284 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Uniformization.SpecialPeriods8
+public import LeanPool.HopfProblem.Toric.DiagonalQuotient2
+import all LeanPool.HopfProblem.Foundations.TwoOpenTransition
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods8
+import all LeanPool.HopfProblem.Toric.DiagonalQuotient2
+
+/-!
+# Hopf problem: foundations · split group extension
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def FreeMeridianMarking.orientedClass (reverse b : Bool) :
+    FundamentalGroup SpecialPeriods.Triangle.TwicePuncturedPlane
+      SpecialPeriods.Triangle.meridianBasepoint :=
+  if reverse then (SpecialPeriods.Triangle.meridianClass b)⁻¹
+  else SpecialPeriods.Triangle.meridianClass b
+
+@[simp]
+private theorem FreeMeridianMarking.orientedClass_true (b : Bool) :
+    orientedClass Bool.true b = (SpecialPeriods.Triangle.meridianClass b)⁻¹ :=
+  rfl
+
+private def FreeMeridianMarking.orientedEquiv (reverse : Bool) :
+    FundamentalGroup SpecialPeriods.Triangle.TwicePuncturedPlane
+        SpecialPeriods.Triangle.meridianBasepoint ≃*
+      FreeGroup Bool :=
+  reorient SpecialPeriods.Triangle.twicePuncturedFundamentalGroupFreeEquiv reverse
+
+@[simp]
+private theorem FreeMeridianMarking.orientedEquiv_symm_of (reverse b : Bool) :
+    (orientedEquiv reverse).symm (FreeGroup.of b) = orientedClass reverse b := by
+  simp only [orientedEquiv, reorient_symm_of,
+    SpecialPeriods.Triangle.twicePuncturedFundamentalGroupFreeEquiv_symm_of, orientedClass]
+
+@[simp]
+private theorem FreeMeridianMarking.orientedEquiv_orientedClass (reverse b : Bool) :
+    orientedEquiv reverse (orientedClass reverse b) = FreeGroup.of b := by
+  rw [← orientedEquiv_symm_of, MulEquiv.apply_symm_apply]
+
+private theorem fundamentalGroup_basepoint_change_apply {X : Type*} [TopologicalSpace X] {x₀ x₁ : X}
+    (p : Path x₀ x₁) (γ : FundamentalGroup X x₀) :
+    FundamentalGroup.fundamentalGroupMulEquivOfPath p γ =
+      (Path.Homotopic.Quotient.mk p).symm.trans (γ.trans (Path.Homotopic.Quotient.mk p)) :=
+  rfl
+
+private theorem fundamentalGroup_basepoint_change_mk {X : Type*} [TopologicalSpace X] {x₀ x₁ : X}
+    (p : Path x₀ x₁) (γ : Path x₀ x₀) :
+    FundamentalGroup.fundamentalGroupMulEquivOfPath p (Path.Homotopic.Quotient.mk γ) =
+      Path.Homotopic.Quotient.mk (p.symm.trans (γ.trans p)) :=
+  rfl
+
+private theorem fundamentalGroup_basepoint_naturality {X Y : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] {x₀ x₁ : X} (f : C(X, Y)) (p : Path x₀ x₁) :
+    (FundamentalGroup.fundamentalGroupMulEquivOfPath (p.map f.continuous)).toMonoidHom.comp
+        (FundamentalGroup.map f x₀) =
+      (FundamentalGroup.map f x₁).comp
+        (FundamentalGroup.fundamentalGroupMulEquivOfPath p).toMonoidHom := by
+  apply MonoidHom.ext
+  intro γ
+  induction γ using Path.Homotopic.Quotient.ind with
+  | mk
+    γ =>
+    change
+      Path.Homotopic.Quotient.mk
+          ((p.map f.continuous).symm.trans ((γ.map f.continuous).trans (p.map f.continuous))) =
+        Path.Homotopic.Quotient.mk ((p.symm.trans (γ.trans p)).map f.continuous)
+    apply congrArg Path.Homotopic.Quotient.mk
+    rw [Path.map_trans, Path.map_trans, Path.map_symm]
+
+private theorem fundamentalGroup_basepoint_naturality_apply {X Y : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] {x₀ x₁ : X} (f : C(X, Y)) (p : Path x₀ x₁) (γ : FundamentalGroup X x₀) :
+    FundamentalGroup.fundamentalGroupMulEquivOfPath (p.map f.continuous)
+        (FundamentalGroup.map f x₀ γ) =
+      FundamentalGroup.map f x₁ (FundamentalGroup.fundamentalGroupMulEquivOfPath p γ) :=
+  DFunLike.congr_fun (fundamentalGroup_basepoint_naturality f p) γ
+
+private theorem fundamentalGroup_map_surjective_at_of_path {X Y : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] {x₀ x₁ : X} (f : C(X, Y)) (p : Path x₀ x₁)
+    (hf : Function.Surjective (FundamentalGroup.map f x₀)) :
+    Function.Surjective (FundamentalGroup.map f x₁) := by
+  intro γ
+  obtain ⟨δ, rfl⟩ :=
+    (FundamentalGroup.fundamentalGroupMulEquivOfPath (p.map f.continuous)).surjective γ
+  obtain ⟨ε, hε⟩ := hf δ
+  refine ⟨FundamentalGroup.fundamentalGroupMulEquivOfPath p ε, ?_⟩
+  exact
+    (fundamentalGroup_basepoint_naturality_apply f p ε).symm.trans
+      (congrArg (FundamentalGroup.fundamentalGroupMulEquivOfPath (p.map f.continuous)) hε)
+
+public
+theorem fundamentalGroup_map_surjective_at_of_pathConnected {X Y : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] [PathConnectedSpace X] (f : C(X, Y)) (x₀ x₁ : X)
+    (hf : Function.Surjective (FundamentalGroup.map f x₀)) :
+    Function.Surjective (FundamentalGroup.map f x₁) :=
+  fundamentalGroup_map_surjective_at_of_path f (PathConnectedSpace.somePath x₀ x₁) hf
+
+private theorem covering_exists_restricted_loop_homotopic {E X : Type*} [TopologicalSpace E]
+    [TopologicalSpace X] [SimplyConnectedSpace E] {p : E → X} (hp : IsCoveringMap p) (S : Set X)
+    (hS : IsPathConnected (p ⁻¹' S)) (e : E) (he : p e ∈ S) (γ : Path (p e) (p e)) :
+    ∃ δ : Path (⟨p e, he⟩ : S) ⟨p e, he⟩, (δ.map continuous_subtype_val).Homotopic γ := by
+  obtain ⟨Γ, hΓ, hΓ₀⟩ := hp.exists_path_lifts γ e γ.source
+  have hΓ₁ : p (Γ 1) = p e := (congr_fun hΓ 1).trans γ.target
+  let Γ' : Path e (Γ 1) := ⟨Γ, hΓ₀, rfl⟩
+  obtain ⟨Δ, hΔ⟩ :=
+    hS.joinedIn e he (Γ 1)
+      (by
+        change p (Γ 1) ∈ S
+        rwa [hΓ₁])
+  let δ : Path (⟨p e, he⟩ : S) ⟨p e, he⟩ :=
+    { toFun t := ⟨p (Δ t), hΔ t⟩
+      continuous_toFun := (hp.continuous.comp Δ.continuous).subtype_mk _
+      source' := Subtype.ext (congrArg p Δ.source)
+      target' := Subtype.ext ((congrArg p Δ.target).trans hΓ₁) }
+  have hδ : δ.map continuous_subtype_val = (Δ.map hp.continuous).cast rfl hΓ₁.symm := by
+    ext t
+    rfl
+  have hγ : (Γ'.map hp.continuous).cast rfl hΓ₁.symm = γ := by
+    ext t
+    exact congr_fun hΓ t
+  have H :=
+    ((SimplyConnectedSpace.paths_homotopic Δ Γ').map (⟨p, hp.continuous⟩ : C(E, X))).pathCast rfl
+      hΓ₁.symm
+  exact ⟨δ, by simpa only [← hδ, hγ] using H⟩
+
+private theorem
+    covering_restriction_fundamentalGroup_map_surjective_at {E X : Type*} [TopologicalSpace E]
+    [TopologicalSpace X] [SimplyConnectedSpace E] {p : E → X} (hp : IsCoveringMap p) (S : Set X)
+    (hS : IsPathConnected (p ⁻¹' S)) (e : E) (he : p e ∈ S) :
+    Function.Surjective
+      (FundamentalGroup.map (⟨Subtype.val, continuous_subtype_val⟩ : C(S, X)) ⟨p e, he⟩) := by
+  intro γ
+  induction γ using Path.Homotopic.Quotient.ind with
+  | mk γ =>
+    obtain ⟨δ, hδ⟩ := covering_exists_restricted_loop_homotopic hp S hS e he γ
+    exact ⟨Path.Homotopic.Quotient.mk δ, Path.Homotopic.Quotient.eq.mpr hδ⟩
+
+private theorem
+    covering_restriction_fundamentalGroup_map_surjective {E X : Type*} [TopologicalSpace E]
+    [TopologicalSpace X] [SimplyConnectedSpace E] {p : E → X} (hp : IsCoveringMap p)
+    (hps : Function.Surjective p) (S : Set X) (hS : IsPathConnected (p ⁻¹' S)) (x : S) :
+    Function.Surjective
+      (FundamentalGroup.map (⟨Subtype.val, continuous_subtype_val⟩ : C(S, X)) x) := by
+  rcases x with ⟨x, hx⟩
+  obtain ⟨e, rfl⟩ := hps x
+  exact covering_restriction_fundamentalGroup_map_surjective_at hp S hS e hx
+
+private def SplitGroupExtension.hom {N E H : Type*} [Group N] [Group E] [Group H] (i : N →* E)
+    (s : H →* E) (φ : H →* MulAut N) (hconj : ∀ h n, i (φ h n) = s h * i n * (s h)⁻¹) :
+    N ⋊[φ] H →* E :=
+  SemidirectProduct.lift i s
+    (fun h => by
+      ext n
+      exact hconj h n)
+
+@[simp]
+private theorem
+    SplitGroupExtension.hom_apply {N E H : Type*} [Group N] [Group E] [Group H] (i : N →* E)
+    (s : H →* E) (φ : H →* MulAut N) (hconj : ∀ h n, i (φ h n) = s h * i n * (s h)⁻¹)
+    (x : N ⋊[φ] H) : hom i s φ hconj x = i x.left * s x.right :=
+  rfl
+
+private theorem
+    SplitGroupExtension.projection_inclusion {N E H : Type*} [Group N] [Group E] [Group H]
+    (i : N →* E) (p : E →* H) (hex : i.range = p.ker) (n : N) : p (i n) = 1 := by
+  apply MonoidHom.mem_ker.mp
+  rw [← hex]
+  exact ⟨n, rfl⟩
+
+private theorem
+    SplitGroupExtension.projection_section {E H : Type*} [Group E] [Group H] (p : E →* H)
+    (s : H →* E) (hs : p.comp s = MonoidHom.id H) (h : H) : p (s h) = h :=
+  DFunLike.congr_fun hs h
+
+private theorem SplitGroupExtension.projection_hom {N E H : Type*} [Group N] [Group E] [Group H]
+    (i : N →* E) (p : E →* H) (s : H →* E) (φ : H →* MulAut N) (hs : p.comp s = MonoidHom.id H)
+    (hex : i.range = p.ker) (hconj : ∀ h n, i (φ h n) = s h * i n * (s h)⁻¹) (x : N ⋊[φ] H) :
+    p (hom i s φ hconj x) = x.right := by
+  rw [hom_apply, map_mul, projection_inclusion i p hex, projection_section p s hs, one_mul]
+
+private theorem SplitGroupExtension.hom_injective {N E H : Type*} [Group N] [Group E] [Group H]
+    (i : N →* E) (p : E →* H) (s : H →* E) (φ : H →* MulAut N) (hi : Function.Injective i)
+    (hs : p.comp s = MonoidHom.id H) (hex : i.range = p.ker)
+    (hconj : ∀ h n, i (φ h n) = s h * i n * (s h)⁻¹) : Function.Injective (hom i s φ hconj) := by
+  intro x y hxy
+  have hr : x.right = y.right := by
+    simpa only [projection_hom i p s φ hs hex hconj] using congrArg p hxy
+  have hl : i x.left = i y.left := by
+    rw [hom_apply, hom_apply, hr] at hxy
+    exact mul_right_cancel hxy
+  exact SemidirectProduct.ext (hi hl) hr
+
+private theorem SplitGroupExtension.hom_surjective {N E H : Type*} [Group N] [Group E] [Group H]
+    (i : N →* E) (p : E →* H) (s : H →* E) (φ : H →* MulAut N) (hs : p.comp s = MonoidHom.id H)
+    (hex : i.range = p.ker) (hconj : ∀ h n, i (φ h n) = s h * i n * (s h)⁻¹) :
+    Function.Surjective (hom i s φ hconj) := by
+  intro e
+  have he : e * (s (p e))⁻¹ ∈ i.range := by
+    rw [hex, MonoidHom.mem_ker, map_mul, map_inv, projection_section p s hs]
+    exact mul_inv_cancel (p e)
+  obtain ⟨n, hn⟩ := he
+  refine ⟨⟨n, p e⟩, ?_⟩
+  change i n * s (p e) = e
+  rw [hn, inv_mul_cancel_right]
+
+private theorem SplitGroupExtension.hom_bijective {N E H : Type*} [Group N] [Group E] [Group H]
+    (i : N →* E) (p : E →* H) (s : H →* E) (φ : H →* MulAut N) (hi : Function.Injective i)
+    (hs : p.comp s = MonoidHom.id H) (hex : i.range = p.ker)
+    (hconj : ∀ h n, i (φ h n) = s h * i n * (s h)⁻¹) : Function.Bijective (hom i s φ hconj) :=
+  ⟨hom_injective i p s φ hi hs hex hconj, hom_surjective i p s φ hs hex hconj⟩
+
+private def SplitGroupExtension.mulEquiv {N E H : Type*} [Group N] [Group E] [Group H] (i : N →* E)
+    (p : E →* H) (s : H →* E) (φ : H →* MulAut N) (hi : Function.Injective i)
+    (hs : p.comp s = MonoidHom.id H) (hex : i.range = p.ker)
+    (hconj : ∀ h n, i (φ h n) = s h * i n * (s h)⁻¹) : N ⋊[φ] H ≃* E :=
+  MulEquiv.ofBijective (hom i s φ hconj) (hom_bijective i p s φ hi hs hex hconj)
+
+@[simp]
+private theorem SplitGroupExtension.mulEquiv_inl {N E H : Type*} [Group N] [Group E] [Group H]
+    (i : N →* E) (p : E →* H) (s : H →* E) (φ : H →* MulAut N) (hi : Function.Injective i)
+    (hs : p.comp s = MonoidHom.id H) (hex : i.range = p.ker)
+    (hconj : ∀ h n, i (φ h n) = s h * i n * (s h)⁻¹) (n : N) :
+    mulEquiv i p s φ hi hs hex hconj (SemidirectProduct.inl n) = i n := by
+  change hom i s φ hconj (SemidirectProduct.inl n) = _
+  simp
+
+@[simp]
+private theorem SplitGroupExtension.mulEquiv_inr {N E H : Type*} [Group N] [Group E] [Group H]
+    (i : N →* E) (p : E →* H) (s : H →* E) (φ : H →* MulAut N) (hi : Function.Injective i)
+    (hs : p.comp s = MonoidHom.id H) (hex : i.range = p.ker)
+    (hconj : ∀ h n, i (φ h n) = s h * i n * (s h)⁻¹) (h : H) :
+    mulEquiv i p s φ hi hs hex hconj (SemidirectProduct.inr h) = s h := by
+  change hom i s φ hconj (SemidirectProduct.inr h) = _
+  simp
+
+@[simp]
+private theorem
+    SplitGroupExtension.mulEquiv_symm_inclusion {N E H : Type*} [Group N] [Group E] [Group H]
+    (i : N →* E) (p : E →* H) (s : H →* E) (φ : H →* MulAut N) (hi : Function.Injective i)
+    (hs : p.comp s = MonoidHom.id H) (hex : i.range = p.ker)
+    (hconj : ∀ h n, i (φ h n) = s h * i n * (s h)⁻¹) (n : N) :
+    (mulEquiv i p s φ hi hs hex hconj).symm (i n) = SemidirectProduct.inl n := by
+  apply (mulEquiv i p s φ hi hs hex hconj).injective
+  rw [MulEquiv.apply_symm_apply, mulEquiv_inl]
+
+@[simp]
+private theorem
+    SplitGroupExtension.mulEquiv_symm_section {N E H : Type*} [Group N] [Group E] [Group H]
+    (i : N →* E) (p : E →* H) (s : H →* E) (φ : H →* MulAut N) (hi : Function.Injective i)
+    (hs : p.comp s = MonoidHom.id H) (hex : i.range = p.ker)
+    (hconj : ∀ h n, i (φ h n) = s h * i n * (s h)⁻¹) (h : H) :
+    (mulEquiv i p s φ hi hs hex hconj).symm (s h) = SemidirectProduct.inr h := by
+  apply (mulEquiv i p s φ hi hs hex hconj).injective
+  rw [MulEquiv.apply_symm_apply, mulEquiv_inr]
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Foundations/TrianglePeriodFamilyHomologySplitting.lean b/LeanPool/HopfProblem/Foundations/TrianglePeriodFamilyHomologySplitting.lean
new file mode 100644
index 000000000..ae8ce5e66
--- /dev/null
+++ b/LeanPool/HopfProblem/Foundations/TrianglePeriodFamilyHomologySplitting.lean
@@ -0,0 +1,123 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology9
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology9
+
+/-!
+# Hopf problem: foundations · triangle period family homology splitting
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+/-- A linear right inverse to a surjective map with free codomain. -/
+public
+def TrianglePeriodFamilyHomologySplitting.freeRightSection {M K : Type*} [AddCommGroup M]
+    [AddCommGroup K] [Module ℤ M] [Module ℤ K] [Module.Free ℤ K] (g : M →ₗ[ℤ] K)
+    (hg : Function.Surjective g) : K →ₗ[ℤ] M :=
+  Classical.choose (Module.projective_lifting_property g (LinearMap.id : K →ₗ[ℤ] K) hg)
+
+private theorem
+    TrianglePeriodFamilyHomologySplitting.freeRightSection_comp {M K : Type*} [AddCommGroup M]
+    [AddCommGroup K] [Module ℤ M] [Module ℤ K] [Module.Free ℤ K] (g : M →ₗ[ℤ] K)
+    (hg : Function.Surjective g) : g.comp (freeRightSection g hg) = LinearMap.id :=
+  Classical.choose_spec (Module.projective_lifting_property g (LinearMap.id : K →ₗ[ℤ] K) hg)
+
+@[simp]
+public
+theorem TrianglePeriodFamilyHomologySplitting.freeRightSection_rightInverse {M K : Type*}
+    [AddCommGroup M] [AddCommGroup K] [Module ℤ M] [Module ℤ K] [Module.Free ℤ K] (g : M →ₗ[ℤ] K)
+    (hg : Function.Surjective g) (k : K) : g (freeRightSection g hg k) = k :=
+  LinearMap.congr_fun (freeRightSection_comp g hg) k
+
+private def TrianglePeriodFamilyHomologySplitting.freeRightSumMap {L M K : Type*} [AddCommGroup L]
+    [AddCommGroup M] [AddCommGroup K] [Module ℤ L] [Module ℤ M] [Module ℤ K] [Module.Free ℤ K]
+    (f : L →ₗ[ℤ] M) (g : M →ₗ[ℤ] K) (hg : Function.Surjective g) : (L × K) →ₗ[ℤ] M :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun x := f x.1 + freeRightSection g hg x.2
+      map_zero' := by simp
+      map_add' x
+        y := by
+        dsimp
+        rw [map_add, map_add]
+        exact add_add_add_comm _ _ _ _ }
+
+@[simp]
+private theorem TrianglePeriodFamilyHomologySplitting.freeRightSumMap_apply {L M K : Type*}
+    [AddCommGroup L] [AddCommGroup M] [AddCommGroup K] [Module ℤ L] [Module ℤ M] [Module ℤ K]
+    [Module.Free ℤ K] (f : L →ₗ[ℤ] M) (g : M →ₗ[ℤ] K) (hg : Function.Surjective g) (x : L × K) :
+    freeRightSumMap f g hg x = f x.1 + freeRightSection g hg x.2 :=
+  rfl
+
+private theorem TrianglePeriodFamilyHomologySplitting.freeRightSumMap_injective {L M K : Type*}
+    [AddCommGroup L] [AddCommGroup M] [AddCommGroup K] [Module ℤ L] [Module ℤ M] [Module ℤ K]
+    [Module.Free ℤ K] (f : L →ₗ[ℤ] M) (g : M →ₗ[ℤ] K) (hex : Function.Exact f g)
+    (hf : Function.Injective f) (hg : Function.Surjective g) :
+    Function.Injective (freeRightSumMap f g hg) := by
+  rintro ⟨a, k⟩ ⟨a', k'⟩ h
+  change f a + freeRightSection g hg k = f a' + freeRightSection g hg k' at h
+  have hk : k = k' := by
+    have h' := congrArg g h
+    simpa only [map_add, hex.apply_apply_eq_zero, freeRightSection_rightInverse, zero_add] using
+      h'
+  subst k'
+  exact Prod.ext (hf (add_right_cancel h)) rfl
+
+private theorem TrianglePeriodFamilyHomologySplitting.freeRightSumMap_surjective {L M K : Type*}
+    [AddCommGroup L] [AddCommGroup M] [AddCommGroup K] [Module ℤ L] [Module ℤ M] [Module ℤ K]
+    [Module.Free ℤ K] (f : L →ₗ[ℤ] M) (g : M →ₗ[ℤ] K) (hex : Function.Exact f g)
+    (hg : Function.Surjective g) : Function.Surjective (freeRightSumMap f g hg) := by
+  intro m
+  have hm : g (m - freeRightSection g hg (g m)) = 0 := by
+    rw [map_sub, freeRightSection_rightInverse, sub_self]
+  obtain ⟨a, ha⟩ := (hex _).mp hm
+  refine ⟨(a, g m), ?_⟩
+  rw [freeRightSumMap_apply, ha, sub_add_cancel]
+
+private def
+    TrianglePeriodFamilyHomologySplitting.freeRightSplitEquiv {L M K : Type*} [AddCommGroup L]
+    [AddCommGroup M] [AddCommGroup K] [Module ℤ L] [Module ℤ M] [Module ℤ K] [Module.Free ℤ K]
+    (f : L →ₗ[ℤ] M) (g : M →ₗ[ℤ] K) (hex : Function.Exact f g) (hf : Function.Injective f)
+    (hg : Function.Surjective g) : M ≃ₗ[ℤ] (L × K) :=
+  (LinearEquiv.ofBijective (freeRightSumMap f g hg)
+      ⟨freeRightSumMap_injective f g hex hf hg, freeRightSumMap_surjective f g hex hg⟩).symm
+
+private def TrianglePeriodFamilyHomologyFreeCoordinates.freeCoordinateSumEquiv (a b : ℕ) :
+    ((Fin a → ℤ) × (Fin b → ℤ)) ≃ₗ[ℤ] (Fin (a + b) → ℤ) :=
+  (((LinearEquiv.sumArrowLequivProdArrow (Fin a) (Fin b) ℤ ℤ).symm.toAddEquiv).trans
+      (LinearEquiv.piCongrLeft' ℤ (fun _ : Fin a ⊕ Fin b => ℤ)
+          (finSumFinEquiv : Fin a ⊕ Fin b ≃ Fin (a + b))).toAddEquiv).toIntLinearEquiv
+
+private def TrianglePeriodFamilyHomologyFreeCoordinates.integerFreeCoordinateEquiv (b : ℕ) :
+    (ℤ × (Fin b → ℤ)) ≃ₗ[ℤ] (Fin (1 + b) → ℤ) :=
+  ((((LinearEquiv.funUnique (Fin 1) ℤ ℤ).symm.toAddEquiv.prodCongr
+          (AddEquiv.refl (Fin b → ℤ))).trans
+      (freeCoordinateSumEquiv 1 b).toAddEquiv)).toIntLinearEquiv
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Foundations/TriangleRegularBaseFundamentalGroup.lean b/LeanPool/HopfProblem/Foundations/TriangleRegularBaseFundamentalGroup.lean
new file mode 100644
index 000000000..8d7189e9b
--- /dev/null
+++ b/LeanPool/HopfProblem/Foundations/TriangleRegularBaseFundamentalGroup.lean
@@ -0,0 +1,483 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+public import LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+
+/-!
+# Hopf problem: foundations · triangle regular base fundamental group
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem SimplyConnectedCover.homotopic_of_mem {X : Type*} [TopologicalSpace X] {s : Set X}
+    (hs : IsSimplyConnected s) {x y : X} (p q : Path x y) (hp : ∀ t, p t ∈ s)
+    (hq : ∀ t, q t ∈ s) : Path.Homotopic p q := by
+  let : SimplyConnectedSpace s := hs
+  have hx : x ∈ s := by simpa using hp 0
+  have hy : y ∈ s := by simpa using hp 1
+  let p' : Path (⟨x, hx⟩ : s) ⟨y, hy⟩ :=
+    { toFun := fun t => ⟨p t, hp t⟩
+      continuous_toFun := p.continuous.subtype_mk _
+      source' := by apply Subtype.ext; exact p.source
+      target' := by apply Subtype.ext; exact p.target }
+  let q' : Path (⟨x, hx⟩ : s) ⟨y, hy⟩ :=
+    { toFun := fun t => ⟨q t, hq t⟩
+      continuous_toFun := q.continuous.subtype_mk _
+      source' := by apply Subtype.ext; exact q.source
+      target' := by apply Subtype.ext; exact q.target }
+  have h :=
+    (SimplyConnectedSpace.paths_homotopic p' q').map
+      (⟨Subtype.val, continuous_subtype_val⟩ : ContinuousMap s X)
+  have hp' : p'.map continuous_subtype_val = p := by ext t; rfl
+  have hq' : q'.map continuous_subtype_val = q := by ext t; rfl
+  exact hp' ▸ hq' ▸ h
+
+public
+theorem SimplyConnectedCover.trans_mem {X : Type*} [TopologicalSpace X] {s : Set X} {x y z : X}
+    (p : Path x y) (q : Path y z) (hp : ∀ t, p t ∈ s) (hq : ∀ t, q t ∈ s) :
+    ∀ t, p.trans q t ∈ s := by
+  apply Set.range_subset_iff.mp
+  rw [Path.trans_range]
+  exact Set.union_subset (Set.range_subset_iff.mpr hp) (Set.range_subset_iff.mpr hq)
+
+private def
+    SimplyConnectedCover.chartPath {X : Type*} [TopologicalSpace X] {ι : Type*} (U : ι → Set X)
+    (hs : ∀ i, IsSimplyConnected (U i)) (o : X) (ho : ∀ i, o ∈ U i) (i : ι) (x : X)
+    (hx : x ∈ U i) : Path o x :=
+  ((hs i).isPathConnected.joinedIn o (ho i) x hx).somePath
+
+private theorem SimplyConnectedCover.chartPath_mem {X : Type*} [TopologicalSpace X] {ι : Type*}
+    (U : ι → Set X) (hs : ∀ i, IsSimplyConnected (U i)) (o : X) (ho : ∀ i, o ∈ U i) (i : ι)
+    (x : X) (hx : x ∈ U i) (t : (unitInterval)) : chartPath U hs o ho i x hx t ∈ U i :=
+  JoinedIn.somePath_mem _ t
+
+private theorem
+    SimplyConnectedCover.chartPath_homotopic {X : Type*} [TopologicalSpace X] {ι : Type*}
+    (U : ι → Set X) (hs : ∀ i, IsSimplyConnected (U i)) (o : X) (ho : ∀ i, o ∈ U i)
+    (hinter : ∀ i j, IsPathConnected (U i ∩ U j)) (i j : ι) (x : X) (hi : x ∈ U i)
+    (hj : x ∈ U j) : Path.Homotopic (chartPath U hs o ho i x hi) (chartPath U hs o ho j x hj) := by
+  let h := (hinter i j).joinedIn o ⟨ho i, ho j⟩ x ⟨hi, hj⟩
+  exact
+    (homotopic_of_mem (hs i) _ h.somePath (chartPath_mem U hs o ho i x hi)
+          (fun t => (h.somePath_mem t).1)).trans
+      (homotopic_of_mem (hs j) h.somePath _ (fun t => (h.somePath_mem t).2)
+        (chartPath_mem U hs o ho j x hj))
+
+private theorem SimplyConnectedCover.quotient_cast_trans {X : Type*} [TopologicalSpace X]
+    {o x y o' x' y' : X} (p : Path.Homotopic.Quotient o x) (q : Path.Homotopic.Quotient x y)
+    (ho : o' = o) (hx : x' = x) (hy : y' = y) :
+    (p.trans q).cast ho hy = (p.cast ho hx).trans (q.cast hx hy) := by
+  cases ho
+  cases hx
+  cases hy
+  simp
+
+private theorem SimplyConnectedCover.quotient_cast_section {X : Type*} [TopologicalSpace X] {o : X}
+    (F : ∀ z, Path.Homotopic.Quotient o z) {x y : X} (h : x = y) : (F y).cast rfl h = F x := by
+  cases h
+  simp
+
+private theorem
+    SimplyConnectedCover.section_subpath_zero_one {X : Type*} [TopologicalSpace X] {o x y : X}
+    (F : ∀ z, Path.Homotopic.Quotient o z) (p : Path x y)
+    (h :
+      Path.Homotopic.Quotient.trans (F (p 0)) (Path.Homotopic.Quotient.mk (p.subpath 0 1)) =
+        F (p 1)) :
+    Path.Homotopic.Quotient.trans (F x) (Path.Homotopic.Quotient.mk p) = F y := by
+  have hp :
+    (Path.Homotopic.Quotient.mk (p.subpath 0 1)).cast p.source.symm p.target.symm =
+      Path.Homotopic.Quotient.mk p := by
+    rw [← Path.Homotopic.Quotient.mk_cast, Path.subpath_zero_one]
+    rfl
+  have h' := congrArg (fun q : Path.Homotopic.Quotient o (p 1) => q.cast rfl p.target.symm) h
+  rw [quotient_cast_trans _ _ rfl p.source.symm p.target.symm,
+    quotient_cast_section F p.source.symm, hp, quotient_cast_section F p.target.symm] at h'
+  exact h'
+
+private theorem SimplyConnectedCover.section_trans_of_open_cover {X : Type*} [TopologicalSpace X]
+    {ι : Type*} (U : ι → Set X) (hopen : ∀ i, IsOpen (U i)) (hcover : ⋃ i, U i = Set.univ) (o : X)
+    (F : ∀ x, Path.Homotopic.Quotient o x)
+    (hF :
+      ∀ i {x y : X} (p : Path x y),
+        (∀ t, p t ∈ U i) →
+          Path.Homotopic.Quotient.trans (F x) (Path.Homotopic.Quotient.mk p) = F y)
+    {x y : X} (p : Path x y) :
+    Path.Homotopic.Quotient.trans (F x) (Path.Homotopic.Quotient.mk p) = F y := by
+  have hpre : Set.univ ⊆ ⋃ i, p ⁻¹' U i := by
+    rw [← Set.preimage_iUnion, hcover, Set.preimage_univ]
+  obtain ⟨t, ht0, hmono, ⟨n, hn⟩, hsub⟩ :=
+    exists_monotone_Icc_subset_open_cover_unitInterval (fun i => (hopen i).preimage p.continuous)
+      hpre
+  have hwalk :
+    ∀ k : ℕ,
+      Path.Homotopic.Quotient.trans (F (p 0)) (Path.Homotopic.Quotient.mk (p.subpath 0 (t k))) =
+        F (p (t k)) := by
+    intro k
+    induction k with
+    | zero =>
+      rw [ht0, Path.subpath_self, Path.Homotopic.Quotient.mk_refl,
+        Path.Homotopic.Quotient.trans_refl]
+    | succ k ih =>
+      obtain ⟨i, hi⟩ := hsub k
+      have hmem : ∀ s, p.subpath (t k) (t (k + 1)) s ∈ U i := by
+        apply Set.range_subset_iff.mp
+        rw [p.range_subpath_of_le _ _ (hmono (Nat.le_succ k))]
+        exact Set.image_subset_iff.mpr hi
+      have hconcat :
+        Path.Homotopic.Quotient.trans (Path.Homotopic.Quotient.mk (p.subpath 0 (t k)))
+            (Path.Homotopic.Quotient.mk (p.subpath (t k) (t (k + 1)))) =
+          Path.Homotopic.Quotient.mk (p.subpath 0 (t (k + 1))) := by
+        rw [← Path.Homotopic.Quotient.mk_trans, Path.Homotopic.Quotient.eq]
+        exact ⟨Path.Homotopy.subpathTransSubpath p 0 (t k) (t (k + 1))⟩
+      calc
+        Path.Homotopic.Quotient.trans (F (p 0))
+              (Path.Homotopic.Quotient.mk (p.subpath 0 (t (k + 1)))) =
+            Path.Homotopic.Quotient.trans
+              (Path.Homotopic.Quotient.trans (F (p 0))
+                (Path.Homotopic.Quotient.mk (p.subpath 0 (t k))))
+              (Path.Homotopic.Quotient.mk (p.subpath (t k) (t (k + 1)))) := by
+          rw [Path.Homotopic.Quotient.trans_assoc, hconcat]
+        _ =
+            Path.Homotopic.Quotient.trans (F (p (t k)))
+              (Path.Homotopic.Quotient.mk (p.subpath (t k) (t (k + 1)))) := by rw [ih]
+        _ = F (p (t (k + 1))) := hF i _ hmem
+  have h := hwalk n
+  rw [hn n le_rfl] at h
+  exact section_subpath_zero_one F p h
+
+private theorem
+    simplyConnectedSpace_of_open_cover {X ι : Type*} [TopologicalSpace X] (U : ι → Set X)
+    (hopen : ∀ i, IsOpen (U i)) (hcover : ⋃ i, U i = Set.univ)
+    (hsimply : ∀ i, IsSimplyConnected (U i)) (o : X) (ho : ∀ i, o ∈ U i)
+    (hinter : ∀ i j, IsPathConnected (U i ∩ U j)) : SimplyConnectedSpace X := by
+  classical
+  have hcov : ∀ x : X, ∃ i, x ∈ U i := by
+    intro x
+    apply Set.mem_iUnion.mp
+    rw [hcover]
+    trivial
+  let idx (x : X) : ι := (hcov x).choose
+  have hidx (x : X) : x ∈ U (idx x) := (hcov x).choose_spec
+  let c (x : X) : Path o x := SimplyConnectedCover.chartPath U hsimply o ho (idx x) x (hidx x)
+  let F (x : X) : Path.Homotopic.Quotient o x := Path.Homotopic.Quotient.mk (c x)
+  have hFi (i : ι) (x : X) (hx : x ∈ U i) :
+    F x = Path.Homotopic.Quotient.mk (SimplyConnectedCover.chartPath U hsimply o ho i x hx) := by
+    apply Path.Homotopic.Quotient.eq.mpr
+    exact SimplyConnectedCover.chartPath_homotopic U hsimply o ho hinter (idx x) i x (hidx x) hx
+  have hF (i : ι) {x y : X} (p : Path x y) (hp : ∀ t, p t ∈ U i) :
+    (F x).trans (Path.Homotopic.Quotient.mk p) = F y := by
+    have hx : x ∈ U i := by simpa using hp 0
+    have hy : y ∈ U i := by simpa using hp 1
+    rw [hFi i x hx, hFi i y hy, ← Path.Homotopic.Quotient.mk_trans, Path.Homotopic.Quotient.eq]
+    exact
+      SimplyConnectedCover.homotopic_of_mem (hsimply i) _ _
+        (SimplyConnectedCover.trans_mem _ _
+          (SimplyConnectedCover.chartPath_mem U hsimply o ho i x hx) hp)
+        (SimplyConnectedCover.chartPath_mem U hsimply o ho i y hy)
+  have hpc : PathConnectedSpace X :=
+    { nonempty := ⟨o⟩
+      joined := fun x y => ⟨(c x).symm.trans (c y)⟩ }
+  apply simply_connected_iff_paths_homotopic'.mpr
+  refine ⟨hpc, ?_⟩
+  intro x y p q
+  have hp := SimplyConnectedCover.section_trans_of_open_cover U hopen hcover o F hF p
+  have hq := SimplyConnectedCover.section_trans_of_open_cover U hopen hcover o F hF q
+  apply Path.Homotopic.Quotient.eq.mp
+  have h :=
+    congrArg (fun r : Path.Homotopic.Quotient o y => (F x).symm.trans r) (hp.trans hq.symm)
+  simpa only [← Path.Homotopic.Quotient.trans_assoc, Path.Homotopic.Quotient.symm_trans,
+    Path.Homotopic.Quotient.refl_trans] using h
+
+private theorem TriangleRegularBaseFundamentalGroup.pathClass_property_cast {X : Type*}
+    [TopologicalSpace X] (P : ∀ {x y : X}, Path.Homotopic.Quotient x y → Prop) {x y x' y' : X}
+    (q : Path.Homotopic.Quotient x y) (hx : x' = x) (hy : y' = y) (hq : P q) : P (q.cast hx hy) :=
+  by
+  cases hx
+  cases hy
+  simpa using hq
+
+private theorem TriangleRegularBaseFundamentalGroup.pathClass_induction_of_open_cover {X : Type*}
+    [TopologicalSpace X] {ι : Type*} (U : ι → Set X) (hopen : ∀ i, IsOpen (U i))
+    (hcover : ⋃ i, U i = Set.univ) (P : ∀ {x y : X}, Path.Homotopic.Quotient x y → Prop)
+    (h_refl : ∀ x, P (Path.Homotopic.Quotient.refl x))
+    (h_trans :
+      ∀ {x y z : X} {p : Path.Homotopic.Quotient x y} {q : Path.Homotopic.Quotient y z},
+        P p → P q → P (p.trans q))
+    (h_local :
+      ∀ i {x y : X} (p : Path x y), Set.range p ⊆ U i → P (Path.Homotopic.Quotient.mk p)) :
+    ∀ {x y : X} (q : Path.Homotopic.Quotient x y), P q := by
+  intro x y q
+  obtain ⟨p⟩ := q
+  have hpre : Set.univ ⊆ ⋃ i, p ⁻¹' U i := by
+    rw [← Set.preimage_iUnion, hcover, Set.preimage_univ]
+  obtain ⟨t, ht0, hmono, ⟨n, hn⟩, hsub⟩ :=
+    exists_monotone_Icc_subset_open_cover_unitInterval (fun i => (hopen i).preimage p.continuous)
+      hpre
+  have hwalk : ∀ k : ℕ, P (Path.Homotopic.Quotient.mk (p.subpath 0 (t k))) := by
+    intro k
+    induction k with
+    | zero =>
+      rw [ht0, Path.subpath_self, Path.Homotopic.Quotient.mk_refl]
+      exact h_refl (p 0)
+    | succ k ih =>
+      obtain ⟨i, hi⟩ := hsub k
+      have hmem : Set.range (p.subpath (t k) (t (k + 1))) ⊆ U i := by
+        rw [p.range_subpath_of_le _ _ (hmono (Nat.le_succ k))]
+        exact Set.image_subset_iff.mpr hi
+      have hconcat :
+        Path.Homotopic.Quotient.trans (Path.Homotopic.Quotient.mk (p.subpath 0 (t k)))
+            (Path.Homotopic.Quotient.mk (p.subpath (t k) (t (k + 1)))) =
+          Path.Homotopic.Quotient.mk (p.subpath 0 (t (k + 1))) := by
+        rw [← Path.Homotopic.Quotient.mk_trans, Path.Homotopic.Quotient.eq]
+        exact ⟨Path.Homotopy.subpathTransSubpath p 0 (t k) (t (k + 1))⟩
+      rw [← hconcat]
+      exact h_trans ih (h_local i _ hmem)
+  have hfull := hwalk n
+  rw [hn n le_rfl] at hfull
+  have hp :
+    (Path.Homotopic.Quotient.mk (p.subpath 0 1)).cast p.source.symm p.target.symm =
+      Path.Homotopic.Quotient.mk p := by
+    rw [← Path.Homotopic.Quotient.mk_cast, Path.subpath_zero_one]
+    rfl
+  have htransport := pathClass_property_cast P _ p.source.symm p.target.symm hfull
+  rwa [hp] at htransport
+
+private theorem TriangleRegularBaseFundamentalGroup.quotient_symm_trans_cancel {X : Type*}
+    [TopologicalSpace X] {x y z : X} (p : Path.Homotopic.Quotient x y)
+    (q : Path.Homotopic.Quotient y z) : p.symm.trans (p.trans q) = q := by
+  rw [← Path.Homotopic.Quotient.trans_assoc, Path.Homotopic.Quotient.symm_trans,
+    Path.Homotopic.Quotient.refl_trans]
+
+private theorem TriangleRegularBaseFundamentalGroup.quotient_trans_right_cancel {X : Type*}
+    [TopologicalSpace X] {x y z : X} {p q : Path.Homotopic.Quotient x y}
+    (r : Path.Homotopic.Quotient y z) (h : p.trans r = q.trans r) : p = q := by
+  have h' := congrArg (fun a : Path.Homotopic.Quotient x z => a.trans r.symm) h
+  simpa only [Path.Homotopic.Quotient.trans_assoc, Path.Homotopic.Quotient.trans_symm,
+    Path.Homotopic.Quotient.trans_refl] using h'
+
+private def TriangleRegularBaseFundamentalGroup.basedLoop {X : Type*} [TopologicalSpace X] {o : X}
+    (F : ∀ x, Path.Homotopic.Quotient o x) {x y : X} (p : Path.Homotopic.Quotient x y) :
+    FundamentalGroup X o :=
+  ((F x).trans p).trans (F y).symm
+
+private def
+    TriangleRegularBaseFundamentalGroup.pathDifference {X : Type*} [TopologicalSpace X] {o x : X}
+    (p q : Path.Homotopic.Quotient o x) : FundamentalGroup X o :=
+  p.trans q.symm
+
+@[simp]
+private theorem TriangleRegularBaseFundamentalGroup.basedLoop_refl {X : Type*} [TopologicalSpace X]
+    {o : X} (F : ∀ x, Path.Homotopic.Quotient o x) (x : X) :
+    basedLoop F (Path.Homotopic.Quotient.refl x) = 1 := by
+  simp only [basedLoop, Path.Homotopic.Quotient.trans_refl, Path.Homotopic.Quotient.trans_symm,
+    FundamentalGroup.one_def]
+
+private theorem TriangleRegularBaseFundamentalGroup.basedLoop_trans {X : Type*} [TopologicalSpace X]
+    {o x y z : X} (F : ∀ x, Path.Homotopic.Quotient o x) (p : Path.Homotopic.Quotient x y)
+    (q : Path.Homotopic.Quotient y z) : basedLoop F (p.trans q) = basedLoop F q * basedLoop F p :=
+  by
+  simp only [basedLoop, FundamentalGroup.mul_def, Path.Homotopic.Quotient.trans_assoc,
+    quotient_symm_trans_cancel]
+
+private theorem
+    TriangleRegularBaseFundamentalGroup.basedLoop_comparison {X : Type*} [TopologicalSpace X]
+    {o x y : X} (F : ∀ z, Path.Homotopic.Quotient o z) (a : Path.Homotopic.Quotient o x)
+    (b : Path.Homotopic.Quotient o y) (p : Path.Homotopic.Quotient x y) (h : a.trans p = b) :
+    basedLoop F p = (pathDifference (F y) b)⁻¹ * pathDifference (F x) a := by
+  apply
+    (@eq_inv_mul_iff_mul_eq (FundamentalGroup X o) _ (basedLoop F p) (pathDifference (F y) b)
+        (pathDifference (F x) a)).2
+  apply quotient_trans_right_cancel b
+  simp only [basedLoop, pathDifference, FundamentalGroup.mul_def,
+    Path.Homotopic.Quotient.trans_assoc, quotient_symm_trans_cancel,
+    Path.Homotopic.Quotient.symm_trans, Path.Homotopic.Quotient.trans_refl]
+  rw [← h, quotient_symm_trans_cancel]
+
+private structure TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover (X : Type*)
+    [TopologicalSpace X] where
+  U : TopologicalSpace.Opens X
+  V : TopologicalSpace.Opens X
+  cover : (U : Set X) ∪ V = Set.univ
+  simplyU : IsSimplyConnected (U : Set X)
+  simplyV : IsSimplyConnected (V : Set X)
+  base : X
+  baseU : base ∈ U
+  baseV : base ∈ V
+
+private def TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover.pathU {X : Type*}
+    [TopologicalSpace X] (D : TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover X)
+    (x : X) (hx : x ∈ D.U) : Path D.base x :=
+  (D.simplyU.isPathConnected.joinedIn D.base D.baseU x hx).somePath
+
+private def TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover.pathV {X : Type*}
+    [TopologicalSpace X] (D : TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover X)
+    (x : X) (hx : x ∈ D.V) : Path D.base x :=
+  (D.simplyV.isPathConnected.joinedIn D.base D.baseV x hx).somePath
+
+private theorem TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover.pathU_mem {X : Type*}
+    [TopologicalSpace X] (D : TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover X)
+    (x : X) (hx : x ∈ D.U) (t : (unitInterval)) : D.pathU x hx t ∈ D.U :=
+  JoinedIn.somePath_mem _ t
+
+private theorem TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover.pathV_mem {X : Type*}
+    [TopologicalSpace X] (D : TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover X)
+    (x : X) (hx : x ∈ D.V) (t : (unitInterval)) : D.pathV x hx t ∈ D.V :=
+  JoinedIn.somePath_mem _ t
+
+private theorem TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover.pathU_trans {X : Type*}
+    [TopologicalSpace X] (D : TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover X)
+    {x y : X} (hx : x ∈ D.U) (hy : y ∈ D.U) (p : Path x y) (hp : ∀ t, p t ∈ D.U) :
+    (Path.Homotopic.Quotient.mk (D.pathU x hx)).trans (Path.Homotopic.Quotient.mk p) =
+      Path.Homotopic.Quotient.mk (D.pathU y hy) := by
+  rw [← Path.Homotopic.Quotient.mk_trans, Path.Homotopic.Quotient.eq]
+  exact
+    SimplyConnectedCover.homotopic_of_mem D.simplyU _ _
+      (SimplyConnectedCover.trans_mem _ _ (D.pathU_mem x hx) hp) (D.pathU_mem y hy)
+
+private theorem TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover.pathV_trans {X : Type*}
+    [TopologicalSpace X] (D : TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover X)
+    {x y : X} (hx : x ∈ D.V) (hy : y ∈ D.V) (p : Path x y) (hp : ∀ t, p t ∈ D.V) :
+    (Path.Homotopic.Quotient.mk (D.pathV x hx)).trans (Path.Homotopic.Quotient.mk p) =
+      Path.Homotopic.Quotient.mk (D.pathV y hy) := by
+  rw [← Path.Homotopic.Quotient.mk_trans, Path.Homotopic.Quotient.eq]
+  exact
+    SimplyConnectedCover.homotopic_of_mem D.simplyV _ _
+      (SimplyConnectedCover.trans_mem _ _ (D.pathV_mem x hx) hp) (D.pathV_mem y hy)
+
+private def TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover.switchClass {X : Type*}
+    [TopologicalSpace X] (D : TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover X)
+    (x : X) (hxU : x ∈ D.U) (hxV : x ∈ D.V) : FundamentalGroup X D.base :=
+  (Path.Homotopic.Quotient.mk (D.pathU x hxU)).trans
+    (Path.Homotopic.Quotient.mk (D.pathV x hxV)).symm
+
+private theorem
+    TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover.switchClass_eq_of_joinedIn
+    {X : Type*} [TopologicalSpace X]
+    (D : TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover X) {x y : X} (hxU : x ∈ D.U)
+    (hxV : x ∈ D.V) (hyU : y ∈ D.U) (hyV : y ∈ D.V) (hxy : JoinedIn ((D.U : Set X) ∩ D.V) x y) :
+    D.switchClass x hxU hxV = D.switchClass y hyU hyV := by
+  let p := hxy.somePath
+  have hU := D.pathU_trans hxU hyU p (fun t => (hxy.somePath_mem t).1)
+  have hV := D.pathV_trans hxV hyV p (fun t => (hxy.somePath_mem t).2)
+  apply
+    TriangleRegularBaseFundamentalGroup.quotient_trans_right_cancel
+      (Path.Homotopic.Quotient.mk (D.pathV y hyV))
+  change
+    ((Path.Homotopic.Quotient.mk (D.pathU x hxU)).trans
+            (Path.Homotopic.Quotient.mk (D.pathV x hxV)).symm).trans
+        (Path.Homotopic.Quotient.mk (D.pathV y hyV)) =
+      ((Path.Homotopic.Quotient.mk (D.pathU y hyU)).trans
+            (Path.Homotopic.Quotient.mk (D.pathV y hyV)).symm).trans
+        (Path.Homotopic.Quotient.mk (D.pathV y hyV))
+  rw [Path.Homotopic.Quotient.trans_assoc, ← hV,
+    TriangleRegularBaseFundamentalGroup.quotient_symm_trans_cancel, hU]
+  simp only [Path.Homotopic.Quotient.trans_assoc, Path.Homotopic.Quotient.symm_trans,
+    Path.Homotopic.Quotient.trans_refl]
+
+@[simp]
+private theorem
+    TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover.switchClass_base {X : Type*}
+    [TopologicalSpace X] (D : TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover X) :
+    D.switchClass D.base D.baseU D.baseV = 1 := by
+  have hU :
+    Path.Homotopic.Quotient.mk (D.pathU D.base D.baseU) = Path.Homotopic.Quotient.refl D.base := by
+    apply Path.Homotopic.Quotient.eq.mpr
+    exact SimplyConnectedCover.homotopic_of_mem D.simplyU _ _ (D.pathU_mem _ _) (fun _ => D.baseU)
+  have hV :
+    Path.Homotopic.Quotient.mk (D.pathV D.base D.baseV) = Path.Homotopic.Quotient.refl D.base := by
+    apply Path.Homotopic.Quotient.eq.mpr
+    exact SimplyConnectedCover.homotopic_of_mem D.simplyV _ _ (D.pathV_mem _ _) (fun _ => D.baseV)
+  simp only [switchClass, hU, hV, Path.Homotopic.Quotient.trans_symm, FundamentalGroup.one_def]
+
+private theorem
+    fundamentalGroup_eq_one_of_path {X : Type*} [TopologicalSpace X] {x y : X} (p : Path x y)
+    (hx : ∀ g : FundamentalGroup X x, g = 1) (g : FundamentalGroup X y) : g = 1 := by
+  let e := FundamentalGroup.fundamentalGroupMulEquivOfPath p
+  obtain ⟨h, rfl⟩ := e.surjective g
+  rw [hx h, map_one]
+
+private theorem simplyConnectedSpace_iff_fundamentalGroup_eq_one {X : Type*} [TopologicalSpace X]
+    [PathConnectedSpace X] (x : X) : SimplyConnectedSpace X ↔ ∀ g : FundamentalGroup X x, g = 1 :=
+  by
+  constructor
+  · intro h
+    let : SimplyConnectedSpace X := h
+    exact fun _ => Subsingleton.elim _ _
+  · intro hx
+    apply simply_connected_iff_loops_nullhomotopic.mpr
+    refine ⟨inferInstance, ?_⟩
+    intro y γ
+    exact
+      Path.Homotopic.Quotient.eq.mp
+        (fundamentalGroup_eq_one_of_path (PathConnectedSpace.somePath x y) hx
+          (Path.Homotopic.Quotient.mk γ))
+
+private theorem simplyConnectedSpace_of_fundamentalGroup_eq_one {X : Type*} [TopologicalSpace X]
+    [PathConnectedSpace X] (x : X) (hx : ∀ g : FundamentalGroup X x, g = 1) :
+    SimplyConnectedSpace X :=
+  (simplyConnectedSpace_iff_fundamentalGroup_eq_one x).mpr hx
+
+private theorem PeriodTorusLineBundle.ChernCocycle.simplexFace_comp {n : ℕ} {i j : Fin (n + 2)}
+    (h : i ≤ j) :
+    (FirstHurewicz.simplexFace (n + 1) j.succ).comp (FirstHurewicz.simplexFace n i) =
+      (FirstHurewicz.simplexFace (n + 1) i.castSucc).comp (FirstHurewicz.simplexFace n j) := by
+  have hf :=
+    congrArg
+      (fun f : (SimplexCategory.mk (n)) ⟶ (SimplexCategory.mk (n + 2)) =>
+        (SimplexCategory.toTop₀.map f).hom)
+      (SimplexCategory.δ_comp_δ h)
+  have hl :=
+    congrArg
+      (fun f :
+          SimplexCategory.toTop₀.obj (SimplexCategory.mk (n)) ⟶
+            SimplexCategory.toTop₀.obj (SimplexCategory.mk (n + 2)) =>
+        f.hom)
+      (SimplexCategory.toTop₀.map_comp (SimplexCategory.δ i) (SimplexCategory.δ j.succ))
+  have hr :=
+    congrArg
+      (fun f :
+          SimplexCategory.toTop₀.obj (SimplexCategory.mk (n)) ⟶
+            SimplexCategory.toTop₀.obj (SimplexCategory.mk (n + 2)) =>
+        f.hom)
+      (SimplexCategory.toTop₀.map_comp (SimplexCategory.δ j) (SimplexCategory.δ i.castSucc))
+  exact hl.symm.trans (hf.trans hr)
+
+private theorem PeriodTorusLineBundle.ChernCocycle.singularSimplex_face_face {X : Type*}
+    [TopologicalSpace X] {n : ℕ} (σ : C(FirstHurewicz.Simplex (n + 2), X)) {i j : Fin (n + 2)}
+    (h : i ≤ j) :
+    (σ.comp (FirstHurewicz.simplexFace (n + 1) j.succ)).comp (FirstHurewicz.simplexFace n i) =
+      (σ.comp (FirstHurewicz.simplexFace (n + 1) i.castSucc)).comp
+        (FirstHurewicz.simplexFace n j) := by
+  simpa only [ContinuousMap.comp_assoc] using
+    congrArg (fun f : C(FirstHurewicz.Simplex n, FirstHurewicz.Simplex (n + 2)) => σ.comp f)
+      (simplexFace_comp h)
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Foundations/TwoAffineCharts.lean b/LeanPool/HopfProblem/Foundations/TwoAffineCharts.lean
new file mode 100644
index 000000000..64ad425b1
--- /dev/null
+++ b/LeanPool/HopfProblem/Foundations/TwoAffineCharts.lean
@@ -0,0 +1,304 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Recognition.Smale3
+import all LeanPool.HopfProblem.Recognition.Smale3
+
+/-!
+# Hopf problem: foundations · two affine charts
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+/-- Two complex affine charts related by inversion on their common punctured domain. -/
+public
+structure TwoAffineCharts (Y : Type*) [TopologicalSpace Y] where
+  /-- The left affine chart. -/
+  left : ℂ → Y
+  /-- The right affine chart. -/
+  right : ℂ → Y
+  continuous_left : Continuous left
+  continuous_right : Continuous right
+  left_injective : Function.Injective left
+  right_injective : Function.Injective right
+  inversion : ∀ z : ℂ, z ≠ 0 → left z = right z⁻¹
+  endpoints_ne : left 0 ≠ right 0
+  covered : ∀ y : Y, (∃ z, left z = y) ∨ ∃ z, right z = y
+
+private theorem TwoAffineCharts.left_ne_right_zero {Y : Type*} [TopologicalSpace Y]
+    (A : TwoAffineCharts Y) (z : ℂ) : A.left z ≠ A.right 0 := by
+  by_cases hz : z = 0
+  · subst z
+    exact A.endpoints_ne
+  · intro h
+    have h' := A.right_injective ((A.inversion z hz).symm.trans h)
+    exact inv_ne_zero hz h'
+
+private theorem
+    TwoAffineCharts.cross_eq_iff {Y : Type*} [TopologicalSpace Y] (A : TwoAffineCharts Y)
+    (z w : ℂ) : A.left z = A.right w ↔ z ≠ 0 ∧ w = z⁻¹ := by
+  constructor
+  · intro h
+    have hw : w ≠ 0 := by
+      rintro rfl
+      exact A.left_ne_right_zero z h
+    have hi : A.left w⁻¹ = A.right w := by simpa using A.inversion w⁻¹ (inv_ne_zero hw)
+    have hz : z = w⁻¹ := A.left_injective (h.trans hi.symm)
+    refine ⟨by rw [hz]; exact inv_ne_zero hw, ?_⟩
+    rw [hz, inv_inv]
+  · rintro ⟨hz, rfl⟩
+    exact A.inversion z hz
+
+private def TwoAffineCharts.symm {Y : Type*} [TopologicalSpace Y] (A : TwoAffineCharts Y) :
+    TwoAffineCharts Y where
+  left := A.right
+  right := A.left
+  continuous_left := A.continuous_right
+  continuous_right := A.continuous_left
+  left_injective := A.right_injective
+  right_injective := A.left_injective
+  inversion z hz := by simpa using (A.inversion z⁻¹ (inv_ne_zero hz)).symm
+  endpoints_ne := A.endpoints_ne.symm
+  covered y := (A.covered y).symm
+
+private def TwoAffineCharts.extension {Y : Type*} [TopologicalSpace Y] (A : TwoAffineCharts Y)
+    (p : OnePoint ℂ) : Y :=
+  p.elim (A.right 0) A.left
+
+private theorem TwoAffineCharts.extension_injective {Y : Type*} [TopologicalSpace Y]
+    (A : TwoAffineCharts Y) : Function.Injective A.extension := by
+  intro p q h
+  induction p using OnePoint.rec with
+  | infty =>
+    induction q using OnePoint.rec with
+    | infty => rfl
+    | coe w => exact False.elim (A.left_ne_right_zero w h.symm)
+  | coe z =>
+    induction q using OnePoint.rec with
+    | infty => exact False.elim (A.left_ne_right_zero z h)
+    | coe w => exact congrArg ((↑) : ℂ → OnePoint ℂ) (A.left_injective h)
+
+private theorem TwoAffineCharts.extension_surjective {Y : Type*} [TopologicalSpace Y]
+    (A : TwoAffineCharts Y) : Function.Surjective A.extension := by
+  intro y
+  obtain ⟨z, hz⟩ | ⟨w, hw⟩ := A.covered y
+  · exact ⟨(z : OnePoint ℂ), hz⟩
+  · by_cases hw0 : w = 0
+    · subst w
+      exact ⟨(OnePoint.infty), hw⟩
+    · refine ⟨(w⁻¹ : ℂ), ?_⟩
+      change A.left w⁻¹ = y
+      have hi : A.left w⁻¹ = A.right w := by simpa using A.inversion w⁻¹ (inv_ne_zero hw0)
+      exact hi.trans hw
+
+private theorem TwoAffineCharts.extension_continuous {Y : Type*} [TopologicalSpace Y]
+    (A : TwoAffineCharts Y) : Continuous A.extension := by
+  rw [OnePoint.continuous_iff]
+  constructor
+  · change Filter.Tendsto A.left (Filter.coclosedCompact ℂ) (𝓝 (A.right 0))
+    rw [Filter.coclosedCompact_eq_cocompact, ← Metric.cobounded_eq_cocompact]
+    have h : Filter.Tendsto (fun z : ℂ => A.right z⁻¹) (Bornology.cobounded ℂ) (𝓝 (A.right 0)) :=
+      A.continuous_right.continuousAt.tendsto.comp Filter.tendsto_inv₀_cobounded
+    apply h.congr'
+    filter_upwards [Bornology.eventually_ne_cobounded (0 : ℂ)] with z hz
+    exact (A.inversion z hz).symm
+  · exact A.continuous_left
+
+private def TwoAffineCharts.homeomorph {Y : Type*} [TopologicalSpace Y] (A : TwoAffineCharts Y)
+    [T2Space Y] : OnePoint ℂ ≃ₜ Y :=
+  Continuous.homeoOfEquivCompactToT2 (f :=
+    Equiv.ofBijective A.extension ⟨A.extension_injective, A.extension_surjective⟩)
+    A.extension_continuous
+
+private theorem TwoAffineCharts.left_isOpenEmbedding {Y : Type*} [TopologicalSpace Y]
+    (A : TwoAffineCharts Y) [T2Space Y] : Topology.IsOpenEmbedding A.left := by
+  have h := A.homeomorph.isOpenEmbedding.comp (OnePoint.isOpenEmbedding_coe (X := ℂ))
+  exact h
+
+private theorem TwoAffineCharts.right_isOpenEmbedding {Y : Type*} [TopologicalSpace Y]
+    (A : TwoAffineCharts Y) [T2Space Y] : Topology.IsOpenEmbedding A.right :=
+  A.symm.left_isOpenEmbedding
+
+private theorem
+    TwoAffineCharts.range_left {Y : Type*} [TopologicalSpace Y] (A : TwoAffineCharts Y) :
+    Set.range A.left = {A.right 0}ᶜ := by
+  ext y
+  constructor
+  · rintro ⟨z, rfl⟩
+    exact A.left_ne_right_zero z
+  · intro hy
+    change y ≠ A.right 0 at hy
+    obtain ⟨z, hz⟩ | ⟨w, hw⟩ := A.covered y
+    · exact ⟨z, hz⟩
+    · have hw0 : w ≠ 0 := fun h => hy (by rw [← hw, h])
+      refine ⟨w⁻¹, ?_⟩
+      have hi : A.left w⁻¹ = A.right w := by simpa using A.inversion w⁻¹ (inv_ne_zero hw0)
+      exact hi.trans hw
+
+public
+theorem TwoAffineCharts.range_right {Y : Type*} [TopologicalSpace Y] (A : TwoAffineCharts Y) :
+    Set.range A.right = {A.left 0}ᶜ :=
+  A.symm.range_left
+
+private def TwoAffineCharts.affineMap {Y : Type*} [TopologicalSpace Y] (A : TwoAffineCharts Y)
+    (b : Bool) : ℂ → Y :=
+  if b then A.right else A.left
+
+private theorem
+    TwoAffineCharts.affineMap_isOpenEmbedding {Y : Type*} [TopologicalSpace Y] [T2Space Y]
+    (A : TwoAffineCharts Y) (b : Bool) : Topology.IsOpenEmbedding (A.affineMap b) := by
+  cases b
+  · exact A.left_isOpenEmbedding
+  · exact A.right_isOpenEmbedding
+
+private theorem TwoAffineCharts.affineMap_cross_eq_iff {Y : Type*} [TopologicalSpace Y]
+    (A : TwoAffineCharts Y) (b : Bool) (z w : ℂ) :
+    A.affineMap b z = A.affineMap (!b) w ↔ z ≠ 0 ∧ w = z⁻¹ := by
+  cases b
+  · exact A.cross_eq_iff z w
+  · exact A.symm.cross_eq_iff z w
+
+private theorem TwoAffineCharts.affineMap_inversion {Y : Type*} [TopologicalSpace Y]
+    (A : TwoAffineCharts Y) (b : Bool) (z : ℂ) (hz : z ≠ 0) :
+    A.affineMap b z = A.affineMap (!b) z⁻¹ :=
+  (A.affineMap_cross_eq_iff b z z⁻¹).mpr ⟨hz, rfl⟩
+
+private def TwoAffineCharts.parametrization {Y : Type*} [TopologicalSpace Y] [T2Space Y]
+    (A : TwoAffineCharts Y) (b : Bool) : OpenPartialHomeomorph ℂ Y :=
+  (A.affineMap_isOpenEmbedding b).toOpenPartialHomeomorph (A.affineMap b)
+
+@[simp]
+private theorem TwoAffineCharts.parametrization_target {Y : Type*} [TopologicalSpace Y] [T2Space Y]
+    (A : TwoAffineCharts Y) (b : Bool) :
+    (A.parametrization b).target = Set.range (A.affineMap b) := by simp [parametrization]
+
+@[simp]
+private theorem
+    TwoAffineCharts.parametrization_symm_apply {Y : Type*} [TopologicalSpace Y] [T2Space Y]
+    (A : TwoAffineCharts Y) (b : Bool) (z : ℂ) :
+    (A.parametrization b).symm (A.affineMap b z) = z :=
+  (A.parametrization b).left_inv (Set.mem_univ z)
+
+private theorem TwoAffineCharts.transition_cross {Y : Type*} [TopologicalSpace Y] [T2Space Y]
+    (A : TwoAffineCharts Y) (b : Bool) (z : ℂ)
+    (hz : z ∈ ((A.parametrization b).trans (A.parametrization (!b)).symm).source) :
+    z ≠ 0 ∧ ((A.parametrization b).trans (A.parametrization (!b)).symm) z = z⁻¹ := by
+  have hparam (b : Bool) (z : ℂ) : A.parametrization b z = A.affineMap b z := rfl
+  have hy : A.affineMap b z ∈ Set.range (A.affineMap (!b)) := by simpa [hparam] using hz.2
+  obtain ⟨w, hw⟩ := hy
+  have hn := ((A.affineMap_cross_eq_iff b z w).mp hw.symm).1
+  refine ⟨hn, ?_⟩
+  change (A.parametrization (!b)).symm (A.affineMap b z) = z⁻¹
+  rw [A.affineMap_inversion b z hn, parametrization_symm_apply]
+
+private theorem TwoAffineCharts.transition_holomorphic {Y : Type*} [TopologicalSpace Y] [T2Space Y]
+    (A : TwoAffineCharts Y) (b c : Bool) :
+    ContDiffOn ℂ ω ((A.parametrization b).trans (A.parametrization c).symm)
+      ((A.parametrization b).trans (A.parametrization c).symm).source := by
+  by_cases hbc : b = c
+  · subst c
+    apply contDiffOn_id.congr
+    intro z _
+    exact A.parametrization_symm_apply b z
+  · have hc : c = !b := by cases b <;> cases c <;> simp_all
+    subst c
+    have hi :
+      ContDiffOn ℂ ω (fun z : ℂ => z⁻¹)
+        ((A.parametrization b).trans (A.parametrization (!b)).symm).source := by
+      intro z hz
+      exact (contDiffAt_inv ℂ (A.transition_cross b z hz).1).contDiffWithinAt
+    exact hi.congr (fun z hz => (A.transition_cross b z hz).2)
+
+private def TwoAffineCharts.preferredChart {Y : Type*} [TopologicalSpace Y] (A : TwoAffineCharts Y)
+    (y : Y) : Bool := by classical exact if y ∈ Set.range A.left then Bool.false else Bool.true
+
+private theorem
+    TwoAffineCharts.preferred_mem {Y : Type*} [TopologicalSpace Y] (A : TwoAffineCharts Y)
+    (y : Y) : y ∈ Set.range (A.affineMap (A.preferredChart y)) := by
+  classical
+  by_cases hy : y ∈ Set.range A.left
+  · simp [preferredChart, hy, affineMap]
+  · obtain h | h := A.covered y
+    · exact False.elim (hy h)
+    · simpa [preferredChart, hy, affineMap] using h
+
+@[instance_reducible]
+private def TwoAffineCharts.chartedSpace {Y : Type*} [TopologicalSpace Y] [T2Space Y]
+    (A : TwoAffineCharts Y) : ChartedSpace ℂ Y
+    where
+  atlas := Set.range (fun b : Bool => (A.parametrization b).symm)
+  chartAt y := (A.parametrization (A.preferredChart y)).symm
+  mem_chart_source
+    y := by
+    change y ∈ (A.parametrization (A.preferredChart y)).target
+    rw [parametrization_target]
+    exact A.preferred_mem y
+  chart_mem_atlas _ := Set.mem_range_self _
+
+private theorem TwoAffineCharts.isManifold {Y : Type*} [TopologicalSpace Y] [T2Space Y]
+    (A : TwoAffineCharts Y) :
+    letI := A.chartedSpace
+    IsManifold (modelWithCornersSelf ℂ ℂ) ω Y := by
+  let := A.chartedSpace
+  apply isManifold_of_contDiffOn
+  intro e e' he he'
+  obtain ⟨b, rfl⟩ := he
+  obtain ⟨c, rfl⟩ := he'
+  simpa using A.transition_holomorphic b c
+
+private theorem TwoAffineCharts.affineMap_holomorphic {Y : Type*} [TopologicalSpace Y] [T2Space Y]
+    (A : TwoAffineCharts Y) (b : Bool) :
+    letI := A.chartedSpace
+    ContMDiff (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) ω (A.affineMap b) := by
+  let := A.chartedSpace
+  let := A.isManifold
+  have he : (A.parametrization b).symm ∈ IsManifold.maximalAtlas (modelWithCornersSelf ℂ ℂ) ω Y :=
+    IsManifold.subset_maximalAtlas (Set.mem_range_self b)
+  have h := contMDiffOn_symm_of_mem_maximalAtlas he
+  change
+    ContMDiffOn (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) ω (A.affineMap b)
+      Set.univ at h
+  exact contMDiffOn_univ.mp h
+
+private theorem
+    TwoAffineCharts.contMDiff_of_comp_affineMaps {Y : Type*} [TopologicalSpace Y] [T2Space Y]
+    (A : TwoAffineCharts Y) {F H N : Type*} [NormedAddCommGroup F] [NormedSpace ℂ F]
+    [TopologicalSpace H] [TopologicalSpace N] [ChartedSpace H N] (I : ModelWithCorners ℂ F H)
+    (f : Y → N) (hf : ∀ b, ContMDiff (modelWithCornersSelf ℂ ℂ) I ω (f ∘ A.affineMap b)) :
+    letI := A.chartedSpace
+    ContMDiff (modelWithCornersSelf ℂ ℂ) I ω f := by
+  have hparam (b : Bool) (z : ℂ) : A.parametrization b z = A.affineMap b z := rfl
+  let := A.chartedSpace
+  intro y
+  rw [contMDiffAt_iff_source]
+  have hchart : chartAt ℂ y = (A.parametrization (A.preferredChart y)).symm := rfl
+  simpa [hparam, extChartAt, OpenPartialHomeomorph.extend, hchart, Function.comp_def] using
+    (hf (A.preferredChart y)).contMDiffAt.contMDiffWithinAt (s := Set.univ) (x :=
+      (A.parametrization (A.preferredChart y)).symm y)
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Foundations/TwoOpenTransition.lean b/LeanPool/HopfProblem/Foundations/TwoOpenTransition.lean
new file mode 100644
index 000000000..f6f8fb838
--- /dev/null
+++ b/LeanPool/HopfProblem/Foundations/TwoOpenTransition.lean
@@ -0,0 +1,848 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology1
+import all LeanPool.HopfProblem.Foundations.TriangleRegularBaseFundamentalGroup
+import all LeanPool.HopfProblem.Foundations.FibreTopology
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology1
+
+/-!
+# Hopf problem: foundations · two open transition
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private structure
+    CoveringComposition.SheetFamily {E X : Type*} [TopologicalSpace E] [TopologicalSpace X]
+    (f : E → X) (x : X) (I : Type*) where
+  base : Set X
+  mem_base : x ∈ base
+  isOpen_base : IsOpen base
+  sheet : I → Set E
+  isOpen_sheet : ∀ i, IsOpen (sheet i)
+  disjoint : Pairwise (Disjoint on sheet)
+  bijOn : ∀ i, Set.BijOn f (sheet i) base
+  preimage_eq : f ⁻¹' base = ⋃ i, sheet i
+
+private theorem CoveringComposition.exists_sheet_family {E X I : Type*} [TopologicalSpace E]
+    [TopologicalSpace X] [TopologicalSpace I] {f : E → X} {x : X} (h : IsEvenlyCovered f x I) :
+    ∃ V : Set X,
+      x ∈ V ∧
+        IsOpen V ∧
+          ∃ U : I → Set E,
+            (∀ i, IsOpen (U i)) ∧
+              Pairwise (Disjoint on U) ∧ (∀ i, Set.BijOn f (U i) V) ∧ f ⁻¹' V = ⋃ i, U i := by
+  rcases h with ⟨hd, V, hxV, hV, hfV, H, hH⟩
+  let : DiscreteTopology I := hd
+  let U : I → Set E := fun i ↦ Subtype.val '' {e : f ⁻¹' V | (H e).2 = i}
+  refine ⟨V, hxV, hV, U, ?_, ?_, ?_, ?_⟩
+  · intro i
+    apply hfV.isOpenMap_subtype_val
+    exact (isOpen_discrete ({ i } : Set I)).preimage (continuous_snd.comp H.continuous)
+  · intro i j hij
+    apply Set.disjoint_left.mpr
+    rintro e ⟨a, ha, rfl⟩ ⟨b, hb, hab⟩
+    have hab' : b = a := Subtype.ext hab
+    subst b
+    exact hij (ha.symm.trans hb)
+  · intro i
+    refine ⟨?_, ?_, ?_⟩
+    · rintro e ⟨a, ha, rfl⟩
+      exact a.property
+    · rintro e ⟨a, ha, rfl⟩ e' ⟨b, hb, rfl⟩ hab
+      apply congrArg Subtype.val
+      apply H.injective
+      apply Prod.ext
+      · apply Subtype.ext
+        simpa only [hH] using hab
+      · exact ha.trans hb.symm
+    · intro y hy
+      let a : f ⁻¹' V := H.symm (⟨y, hy⟩, i)
+      refine ⟨a, ⟨a, ?_, rfl⟩, ?_⟩
+      · change (H (H.symm (⟨y, hy⟩, i))).2 = i
+        simp
+      · rw [← hH]
+        change (H (H.symm (⟨y, hy⟩, i))).1.1 = y
+        simp
+  · ext e
+    constructor
+    · intro he
+      exact Set.mem_iUnion.mpr ⟨(H ⟨e, he⟩).2, ⟨⟨e, he⟩, rfl, rfl⟩⟩
+    · intro he
+      obtain ⟨i, a, ha, rfl⟩ := Set.mem_iUnion.mp he
+      exact a.property
+
+private theorem CoveringComposition.nonempty_sheetFamily {E X I : Type*} [TopologicalSpace E]
+    [TopologicalSpace X] [TopologicalSpace I] {f : E → X} {x : X} (h : IsEvenlyCovered f x I) :
+    Nonempty (SheetFamily f x I) := by
+  obtain ⟨V, hx, hV, U, hU, hdisj, hbij, hexh⟩ := exists_sheet_family h
+  exact ⟨⟨V, hx, hV, U, hU, hdisj, hbij, hexh⟩⟩
+
+private theorem CoveringComposition.evenlyCovered_of_sheets {E X I : Type*} [TopologicalSpace E]
+    [TopologicalSpace X] [TopologicalSpace I] [DiscreteTopology I] {f : E → X} {x : X}
+    (hf : Continuous f) (hfo : IsOpenMap f) (V : Set X) (hx : x ∈ V) (hV : IsOpen V)
+    (U : I → Set E) (hU : ∀ i, IsOpen (U i)) (hinj : ∀ i, (U i).InjOn f)
+    (hsurj : ∀ i, (U i).SurjOn f V) (hdisj : Pairwise (Disjoint on U))
+    (hexh : f ⁻¹' V ⊆ ⋃ i, U i) : IsEvenlyCovered f x I := by
+  classical
+    cases isEmpty_or_nonempty I with
+  | inl hI =>
+    exact
+      .of_preimage_eq_empty I (hV.mem_nhds hx)
+        (Set.eq_empty_of_subset_empty (by simpa using hexh))
+  | inr hI =>
+    obtain ⟨e, _, _⟩ := hsurj (Classical.arbitrary I) hx
+    let : Nonempty E := ⟨e⟩
+    have hopen (i : I) {W : Set X} (hWV : W ⊆ V) : IsOpen W ↔ IsOpen (f ⁻¹' W ∩ U i) := by
+      refine ⟨fun hW => (hW.preimage hf).inter (hU i), fun hW => ?_⟩
+      have himage : f '' (f ⁻¹' W ∩ U i) = W := by
+        apply Set.Subset.antisymm
+        · rintro _ ⟨z, hz, rfl⟩
+          exact hz.1
+        · intro y hy
+          obtain ⟨z, hz, hzy⟩ := hsurj i (hWV hy)
+          exact ⟨z, ⟨by simpa only [Set.mem_preimage, hzy] using hy, hz⟩, hzy⟩
+      rw [← himage]
+      exact hfo _ hW
+    exact .of_trivialization (t := hV.trivializationDiscrete U V hopen hinj hsurj hdisj hexh) hx
+
+private theorem CoveringComposition.evenlyCovered_comp_of_sheet_families {E B X I : Type*}
+    [TopologicalSpace E] [TopologicalSpace B] [TopologicalSpace X] [Finite I] {J : I → Type*}
+    [∀ i, TopologicalSpace (J i)] [∀ i, DiscreteTopology (J i)] {f : E → B} {g : B → X} {x : X}
+    (hf : Continuous f) (hfo : IsOpenMap f) (hg : Continuous g) (hgo : IsOpenMap g)
+    (S : SheetFamily g x I) (b : I → B) (hb : ∀ i, b i ∈ S.sheet i) (hgb : ∀ i, g (b i) = x)
+    (T : ∀ i, SheetFamily f (b i) (J i)) : IsEvenlyCovered (g ∘ f) x (Sigma J) := by
+  classical
+  let W : Set X := S.base ∩ ⋂ i, g '' (S.sheet i ∩ (T i).base)
+  have hxW : x ∈ W := by
+    refine ⟨S.mem_base, Set.mem_iInter.mpr fun i => ?_⟩
+    exact ⟨b i, ⟨hb i, (T i).mem_base⟩, hgb i⟩
+  have hW : IsOpen W :=
+    S.isOpen_base.inter
+      (isOpen_iInter_of_finite fun i => hgo _ ((S.isOpen_sheet i).inter (T i).isOpen_base))
+  let U : Sigma J → Set E := fun ij => f ⁻¹' S.sheet ij.1 ∩ (T ij.1).sheet ij.2
+  apply evenlyCovered_of_sheets (hg.comp hf) (hgo.comp hfo) W hxW hW U
+  · intro ij
+    exact ((S.isOpen_sheet ij.1).preimage hf).inter ((T ij.1).isOpen_sheet ij.2)
+  · intro ij e he e' he' hee'
+    exact ((T ij.1).bijOn ij.2).injOn he.2 he'.2 ((S.bijOn ij.1).injOn he.1 he'.1 hee')
+  · rintro ⟨i, j⟩ y hy
+    obtain ⟨b', hb', hby⟩ := Set.mem_iInter.mp hy.2 i
+    obtain ⟨e, he, hfe⟩ := ((T i).bijOn j).surjOn hb'.2
+    refine ⟨e, ⟨?_, he⟩, (congrArg g hfe).trans hby⟩
+    change f e ∈ S.sheet i
+    rw [hfe]
+    exact hb'.1
+  · rintro ⟨i, j⟩ ⟨i', j'⟩ hne
+    apply Set.disjoint_left.mpr
+    intro e he he'
+    by_cases hii : i = i'
+    · cases hii
+      have hjj : j ≠ j' := by
+        intro h
+        cases h
+        exact hne rfl
+      exact ((T i).disjoint hjj).le_bot ⟨he.2, he'.2⟩
+    · exact (S.disjoint hii).le_bot ⟨he.1, he'.1⟩
+  · intro e he
+    change g (f e) ∈ W at he
+    have houter : f e ∈ g ⁻¹' S.base := he.1
+    rw [S.preimage_eq] at houter
+    obtain ⟨i, hi⟩ := Set.mem_iUnion.mp houter
+    obtain ⟨b', hb', hgEq⟩ := Set.mem_iInter.mp he.2 i
+    have heq : f e = b' := (S.bijOn i).injOn hi hb'.1 hgEq.symm
+    have hinner : e ∈ f ⁻¹' (T i).base := by
+      change f e ∈ (T i).base
+      rw [heq]
+      exact hb'.2
+    rw [(T i).preimage_eq] at hinner
+    obtain ⟨j, hj⟩ := Set.mem_iUnion.mp hinner
+    exact Set.mem_iUnion.mpr ⟨⟨i, j⟩, ⟨hi, hj⟩⟩
+
+public
+theorem CoveringComposition.covering_comp_of_finite_fibres {E B X : Type*} [TopologicalSpace E]
+    [TopologicalSpace B] [TopologicalSpace X] {f : E → B} {g : B → X} (hf : IsCoveringMap f)
+    (hg : IsCoveringMap g) (hfin : ∀ x, Finite (g ⁻¹' { x })) : IsCoveringMap (g ∘ f) := by
+  classical
+  intro x
+  let I := g ⁻¹' { x }
+  let : Finite I := hfin x
+  let S : SheetFamily g x I := Classical.choice (nonempty_sheetFamily (hg x))
+  have hbex : ∀ i : I, ∃ b ∈ S.sheet i, g b = x := fun i => (S.bijOn i).surjOn S.mem_base
+  choose b hb hgb using hbex
+  let : ∀ i : I, DiscreteTopology (f ⁻¹' {b i}) := fun i => (hf (b i)).1
+  let T : ∀ i : I, SheetFamily f (b i) (f ⁻¹' {b i}) := fun i =>
+    Classical.choice (nonempty_sheetFamily (hf (b i)))
+  exact
+    (evenlyCovered_comp_of_sheet_families hf.continuous hf.isOpenMap hg.continuous hg.isOpenMap S
+        b hb hgb T).to_isEvenlyCovered_preimage
+
+private structure HolomorphicCharacterBundle.TransitionData (M : Type*) [TopologicalSpace M]
+    (ι : Type*) where
+  baseSet : ι → Set M
+  isOpen_baseSet : ∀ i, IsOpen (baseSet i)
+  indexAt : M → ι
+  mem_baseSet_at : ∀ x, x ∈ baseSet (indexAt x)
+  transition : ι → ι → M → ℂˣ
+  transition_self : ∀ i x, x ∈ baseSet i → transition i i x = 1
+  transition_comp :
+    ∀ i j k x,
+      x ∈ baseSet i ∩ baseSet j ∩ baseSet k →
+        transition j k x * transition i j x = transition i k x
+  continuousOn_transition :
+    ∀ i j, ContinuousOn (fun x => (transition i j x : ℂ)) (baseSet i ∩ baseSet j)
+
+private def HolomorphicCharacterBundle.TransitionData.core {M ι : Type*} [TopologicalSpace M]
+    (A : HolomorphicCharacterBundle.TransitionData M ι) : VectorBundleCore ℂ M ℂ ι
+    where
+  baseSet := A.baseSet
+  isOpen_baseSet := A.isOpen_baseSet
+  indexAt := A.indexAt
+  mem_baseSet_at := A.mem_baseSet_at
+  coordChange i j x := (A.transition i j x : ℂ) • ContinuousLinearMap.id ℂ ℂ
+  coordChange_self i x hx v := by simp [A.transition_self i x hx]
+  continuousOn_coordChange i j := (A.continuousOn_transition i j).smul continuousOn_const
+  coordChange_comp i j k x hx
+    v := by
+    change
+      (A.transition j k x : ℂ) * ((A.transition i j x : ℂ) * v) = (A.transition i k x : ℂ) * v
+    rw [← mul_assoc, ← Units.val_mul, A.transition_comp i j k x hx]
+
+
+
+private def restrictedRetractionInclusion {A X : Type*} [TopologicalSpace A] [TopologicalSpace X]
+    (i : C(A, X)) (K : Set X) (hinc : Set.range i ⊆ K) : C(A, K)
+    where
+  toFun a := ⟨i a, hinc ⟨a, rfl⟩⟩
+  continuous_toFun := i.continuous.subtype_mk _
+
+private def
+    restrictedRetraction {A X : Type*} [TopologicalSpace A] [TopologicalSpace X] (r : C(X, A))
+    (K : Set X) : C(K, A) where
+  toFun x := r x
+  continuous_toFun := r.continuous.comp continuous_subtype_val
+
+private theorem restrictedRetraction_comp_inclusion {A X : Type*} [TopologicalSpace A]
+    [TopologicalSpace X] (i : C(A, X)) (r : C(X, A)) (hir : r.comp i = ContinuousMap.id A)
+    (K : Set X) (hinc : Set.range i ⊆ K) :
+    (restrictedRetraction r K).comp (restrictedRetractionInclusion i K hinc) =
+      ContinuousMap.id A := by
+  ext a
+  exact retraction_leftInverse i r hir a
+
+private def restrictedRetractionHomotopy {A X : Type*} [TopologicalSpace A] [TopologicalSpace X]
+    (i : C(A, X)) (r : C(X, A)) (H : (ContinuousMap.id X).HomotopyRel (i.comp r) (Set.range i))
+    (K : Set X) (hinc : Set.range i ⊆ K) (hstable : ∀ t x, x ∈ K → H (t, x) ∈ K) :
+    (ContinuousMap.id K).HomotopyRel
+      ((restrictedRetractionInclusion i K hinc).comp (restrictedRetraction r K))
+      (Set.range (restrictedRetractionInclusion i K hinc))
+    where
+  toFun tx := ⟨H (tx.1, tx.2.val), hstable tx.1 tx.2.val tx.2.property⟩
+  continuous_toFun :=
+    (H.continuous.comp
+          (continuous_fst.prodMk (continuous_subtype_val.comp continuous_snd))).subtype_mk
+      _
+  map_zero_left x := Subtype.ext (H.map_zero_left x.val)
+  map_one_left x := Subtype.ext (H.map_one_left x.val)
+  prop' t x
+    hx := by
+    apply Subtype.ext
+    apply H.eq_fst t
+    obtain ⟨a, rfl⟩ := hx
+    exact ⟨a, rfl⟩
+
+private theorem
+    TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover.memV_of_not_memU {X : Type*}
+    [TopologicalSpace X] (D : TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover X)
+    {x : X} (hx : x ∉ D.U) : x ∈ D.V := by
+  have h : x ∈ (D.U : Set X) ∪ D.V := by rw [D.cover]; trivial
+  exact h.resolve_left hx
+
+private def TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover.basedSection {X : Type*}
+    [TopologicalSpace X] (D : TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover X)
+    (x : X) : Path.Homotopic.Quotient D.base x := by
+  classical
+    exact
+    if hx : x ∈ D.U then Path.Homotopic.Quotient.mk (D.pathU x hx)
+    else Path.Homotopic.Quotient.mk (D.pathV x (D.memV_of_not_memU hx))
+
+private theorem
+    TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover.basedSection_eq_U {X : Type*}
+    [TopologicalSpace X] (D : TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover X)
+    {x : X} (hx : x ∈ D.U) : D.basedSection x = Path.Homotopic.Quotient.mk (D.pathU x hx) := by
+  simp only [basedSection, dite_eq_left hx]
+
+private theorem
+    TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover.basedSection_eq_V {X : Type*}
+    [TopologicalSpace X] (D : TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover X)
+    {x : X} (hxU : x ∉ D.U) (hxV : x ∈ D.V) :
+    D.basedSection x = Path.Homotopic.Quotient.mk (D.pathV x hxV) := by
+  simp only [basedSection, dite_eq_right hxU]
+
+@[simp]
+private theorem
+    TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover.basedSection_base {X : Type*}
+    [TopologicalSpace X] (D : TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover X) :
+    D.basedSection D.base = Path.Homotopic.Quotient.refl D.base := by
+  rw [D.basedSection_eq_U D.baseU]
+  apply Path.Homotopic.Quotient.eq.mpr
+  exact SimplyConnectedCover.homotopic_of_mem D.simplyU _ _ (D.pathU_mem _ _) (fun _ => D.baseU)
+
+private theorem
+    TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover.comparisonU_mem {X : Type*}
+    [TopologicalSpace X] (D : TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover X)
+    (H : Subgroup (FundamentalGroup X D.base)) {x : X} (hx : x ∈ D.U) :
+    TriangleRegularBaseFundamentalGroup.pathDifference (D.basedSection x)
+        (Path.Homotopic.Quotient.mk (D.pathU x hx)) ∈
+      H := by
+  rw [D.basedSection_eq_U hx]
+  simpa only [TriangleRegularBaseFundamentalGroup.pathDifference,
+    Path.Homotopic.Quotient.trans_symm, FundamentalGroup.one_def] using H.one_mem
+
+private theorem
+    TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover.comparisonV_mem {X : Type*}
+    [TopologicalSpace X] (D : TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover X)
+    (H : Subgroup (FundamentalGroup X D.base))
+    (hH : ∀ x (hxU : x ∈ D.U) (hxV : x ∈ D.V), D.switchClass x hxU hxV ∈ H) {x : X}
+    (hx : x ∈ D.V) :
+    TriangleRegularBaseFundamentalGroup.pathDifference (D.basedSection x)
+        (Path.Homotopic.Quotient.mk (D.pathV x hx)) ∈
+      H := by
+  by_cases hxU : x ∈ D.U
+  · rw [D.basedSection_eq_U hxU]
+    exact hH x hxU hx
+  · rw [D.basedSection_eq_V hxU hx]
+    simpa only [TriangleRegularBaseFundamentalGroup.pathDifference,
+      Path.Homotopic.Quotient.trans_symm, FundamentalGroup.one_def] using H.one_mem
+
+private theorem
+    TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover.basedLoop_mem_of_path_in_U
+    {X : Type*} [TopologicalSpace X]
+    (D : TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover X)
+    (H : Subgroup (FundamentalGroup X D.base)) {x y : X} (p : Path x y) (hp : ∀ t, p t ∈ D.U) :
+    TriangleRegularBaseFundamentalGroup.basedLoop D.basedSection (Path.Homotopic.Quotient.mk p) ∈
+      H := by
+  have hx : x ∈ D.U := by simpa using hp 0
+  have hy : y ∈ D.U := by simpa using hp 1
+  rw [TriangleRegularBaseFundamentalGroup.basedLoop_comparison D.basedSection
+      (Path.Homotopic.Quotient.mk (D.pathU x hx)) (Path.Homotopic.Quotient.mk (D.pathU y hy))
+      (Path.Homotopic.Quotient.mk p) (D.pathU_trans hx hy p hp)]
+  exact H.mul_mem (H.inv_mem (D.comparisonU_mem H hy)) (D.comparisonU_mem H hx)
+
+private theorem
+    TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover.basedLoop_mem_of_path_in_V
+    {X : Type*} [TopologicalSpace X]
+    (D : TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover X)
+    (H : Subgroup (FundamentalGroup X D.base))
+    (hH : ∀ x (hxU : x ∈ D.U) (hxV : x ∈ D.V), D.switchClass x hxU hxV ∈ H) {x y : X}
+    (p : Path x y) (hp : ∀ t, p t ∈ D.V) :
+    TriangleRegularBaseFundamentalGroup.basedLoop D.basedSection (Path.Homotopic.Quotient.mk p) ∈
+      H := by
+  have hx : x ∈ D.V := by simpa using hp 0
+  have hy : y ∈ D.V := by simpa using hp 1
+  rw [TriangleRegularBaseFundamentalGroup.basedLoop_comparison D.basedSection
+      (Path.Homotopic.Quotient.mk (D.pathV x hx)) (Path.Homotopic.Quotient.mk (D.pathV y hy))
+      (Path.Homotopic.Quotient.mk p) (D.pathV_trans hx hy p hp)]
+  exact H.mul_mem (H.inv_mem (D.comparisonV_mem H hH hy)) (D.comparisonV_mem H hH hx)
+
+private theorem
+  TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover.subgroup_eq_top_of_switchClass_mem
+    {X : Type*} [TopologicalSpace X]
+    (D : TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover X)
+    (H : Subgroup (FundamentalGroup X D.base))
+    (hH : ∀ x (hxU : x ∈ D.U) (hxV : x ∈ D.V), D.switchClass x hxU hxV ∈ H) : H = ⊤ := by
+  let W : Bool → Set X := fun b => if b then D.V else D.U
+  have hopen : ∀ b, IsOpen (W b) := by
+    intro b
+    cases b
+    · exact D.U.isOpen
+    · exact D.V.isOpen
+  have hcover : ⋃ b, W b = Set.univ := by
+    apply Set.eq_univ_of_forall
+    intro x
+    have hx : x ∈ (D.U : Set X) ∪ D.V := by rw [D.cover]; trivial
+    rcases hx with hx | hx
+    · exact Set.mem_iUnion.mpr ⟨Bool.false, hx⟩
+    · exact Set.mem_iUnion.mpr ⟨Bool.true, hx⟩
+  have hall :
+    ∀ {x y : X} (q : Path.Homotopic.Quotient x y),
+      TriangleRegularBaseFundamentalGroup.basedLoop D.basedSection q ∈ H := by
+    apply
+      TriangleRegularBaseFundamentalGroup.pathClass_induction_of_open_cover W hopen hcover
+        (fun q => TriangleRegularBaseFundamentalGroup.basedLoop D.basedSection q ∈ H)
+    · intro x
+      rw [TriangleRegularBaseFundamentalGroup.basedLoop_refl]
+      exact H.one_mem
+    · intro x y z p q hp hq
+      rw [TriangleRegularBaseFundamentalGroup.basedLoop_trans]
+      exact H.mul_mem hq hp
+    · intro b x y p hp
+      cases b
+      · exact D.basedLoop_mem_of_path_in_U H p (fun t => hp ⟨t, rfl⟩)
+      · exact D.basedLoop_mem_of_path_in_V H hH p (fun t => hp ⟨t, rfl⟩)
+  apply top_unique
+  intro q _
+  have hq := hall q
+  have hrefl : (Path.Homotopic.Quotient.refl D.base).symm = Path.Homotopic.Quotient.refl D.base :=
+    by
+    change (1 : FundamentalGroup X D.base)⁻¹ = 1
+    exact inv_one
+  simpa only [TriangleRegularBaseFundamentalGroup.basedLoop, D.basedSection_base,
+    Path.Homotopic.Quotient.refl_trans, hrefl, Path.Homotopic.Quotient.trans_refl] using hq
+
+private theorem TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover.switchClass_eq_of_paths
+    {X : Type*} [TopologicalSpace X]
+    (D : TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover X) {x : X} (hxU : x ∈ D.U)
+    (hxV : x ∈ D.V) (p q : Path D.base x) (hp : ∀ t, p t ∈ D.U) (hq : ∀ t, q t ∈ D.V) :
+    D.switchClass x hxU hxV =
+      FundamentalGroup.fromPath (Path.Homotopic.Quotient.mk (p.trans q.symm)) := by
+  have hU : Path.Homotopic.Quotient.mk (D.pathU x hxU) = Path.Homotopic.Quotient.mk p :=
+    Path.Homotopic.Quotient.eq.mpr
+      (SimplyConnectedCover.homotopic_of_mem D.simplyU _ _ (D.pathU_mem x hxU) hp)
+  have hV : Path.Homotopic.Quotient.mk (D.pathV x hxV) = Path.Homotopic.Quotient.mk q :=
+    Path.Homotopic.Quotient.eq.mpr
+      (SimplyConnectedCover.homotopic_of_mem D.simplyV _ _ (D.pathV_mem x hxV) hq)
+  simp only [switchClass, hU, hV, FundamentalGroup.fromPath, FundamentalGroup.fromArrow,
+    Path.Homotopic.Quotient.mk_trans, Path.Homotopic.Quotient.mk_symm]
+
+private structure TwoOpenTransition (X G : Type*) [TopologicalSpace X] [TopologicalSpace G] where
+  U : TopologicalSpace.Opens X
+  V : TopologicalSpace.Opens X
+  cover : (U : Set X) ∪ (V : Set X) = Set.univ
+  transition : X → G
+  continuousOn_transition : ContinuousOn transition ((U : Set X) ∩ (V : Set X))
+
+private def TwoOpenTransition.baseSet {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    (D : TwoOpenTransition X G) : Bool → Set X
+  | false => D.U
+  | true => D.V
+
+@[simp]
+private theorem
+    TwoOpenTransition.baseSet_false {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    (D : TwoOpenTransition X G) : D.baseSet Bool.false = (D.U : Set X) :=
+  rfl
+
+@[simp]
+private theorem
+    TwoOpenTransition.baseSet_true {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    (D : TwoOpenTransition X G) : D.baseSet Bool.true = (D.V : Set X) :=
+  rfl
+
+private def TwoOpenTransition.indexAt {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    (D : TwoOpenTransition X G) (x : X) : Bool := by
+  classical exact if x ∈ D.U then Bool.false else Bool.true
+
+@[simp]
+private theorem
+    TwoOpenTransition.indexAt_of_mem_U {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    (D : TwoOpenTransition X G) {x : X} (hx : x ∈ D.U) : D.indexAt x = Bool.false := by
+  simp [indexAt, hx]
+
+@[simp]
+private theorem TwoOpenTransition.indexAt_of_not_mem_U {X G : Type*} [TopologicalSpace X]
+    [TopologicalSpace G] (D : TwoOpenTransition X G) {x : X} (hx : x ∉ D.U) :
+    D.indexAt x = Bool.true := by simp [indexAt, hx]
+
+private theorem TwoOpenTransition.mem_baseSet_indexAt {X G : Type*} [TopologicalSpace X]
+    [TopologicalSpace G] (D : TwoOpenTransition X G) (x : X) : x ∈ D.baseSet (D.indexAt x) := by
+  by_cases hx : x ∈ D.U
+  · simpa only [D.indexAt_of_mem_U hx, baseSet_false, SetLike.mem_coe] using hx
+  · have hcover : x ∈ (D.U : Set X) ∪ (D.V : Set X) := by
+      rw [D.cover]
+      exact Set.mem_univ x
+    simpa only [D.indexAt_of_not_mem_U hx, baseSet_true] using hcover.resolve_left hx
+
+private def TwoOpenTransition.coordChange {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    (D : TwoOpenTransition X G) [Group G] : Bool → Bool → X → G → G
+  | false, Bool.false, _, w => w
+  | false, Bool.true, x, w => w * D.transition x
+  | true, Bool.false, x, w => w * (D.transition x)⁻¹
+  | true, Bool.true, _, w => w
+
+@[simp]
+private theorem
+    TwoOpenTransition.coordChange_self {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    (D : TwoOpenTransition X G) [Group G] (i : Bool) (x : X) (w : G) :
+    D.coordChange i i x w = w := by cases i <;> rfl
+
+private theorem
+    TwoOpenTransition.coordChange_comp {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    (D : TwoOpenTransition X G) [Group G] (i j k : Bool) (x : X) (w : G) :
+    D.coordChange j k x (D.coordChange i j x w) = D.coordChange i k x w := by
+  cases i <;> cases j <;> cases k <;> simp [coordChange, mul_assoc]
+
+private theorem TwoOpenTransition.coordChange_mul_left {X G : Type*} [TopologicalSpace X]
+    [TopologicalSpace G] (D : TwoOpenTransition X G) [Group G] (i j : Bool) (x : X) (g w : G) :
+    D.coordChange i j x (g * w) = g * D.coordChange i j x w := by
+  cases i <;> cases j <;> simp [coordChange, mul_assoc]
+
+private theorem TwoOpenTransition.continuousOn_coordChange {X G : Type*} [TopologicalSpace X]
+    [TopologicalSpace G] (D : TwoOpenTransition X G) [Group G] [DiscreteTopology G] (i j : Bool) :
+    ContinuousOn (fun p : X × G => D.coordChange i j p.1 p.2)
+      ((D.baseSet i ∩ D.baseSet j) ×ˢ Set.univ) := by
+  cases i <;> cases j
+  · exact continuous_snd.continuousOn
+  · exact
+      continuous_snd.continuousOn.mul
+        (D.continuousOn_transition.comp continuous_fst.continuousOn (fun _ hp => hp.1))
+  · exact
+      continuous_snd.continuousOn.mul
+        (D.continuousOn_transition.comp continuous_fst.continuousOn
+            (fun _ hp => ⟨hp.1.2, hp.1.1⟩)).inv
+  · exact continuous_snd.continuousOn
+
+private def TwoOpenTransition.core {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    (D : TwoOpenTransition X G) [Group G] [DiscreteTopology G] : FiberBundleCore Bool X G
+    where
+  baseSet := D.baseSet
+  isOpen_baseSet := by
+    intro i
+    cases i
+    · exact D.U.isOpen
+    · exact D.V.isOpen
+  indexAt := D.indexAt
+  mem_baseSet_at := D.mem_baseSet_indexAt
+  coordChange := D.coordChange
+  coordChange_self := fun i x _ w => D.coordChange_self i x w
+  continuousOn_coordChange := D.continuousOn_coordChange
+  coordChange_comp := fun i j k x _ w => D.coordChange_comp i j k x w
+
+private abbrev TwoOpenTransition.TotalSpace {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    (D : TwoOpenTransition X G) [Group G] [DiscreteTopology G] :=
+  D.core.TotalSpace
+
+private abbrev TwoOpenTransition.proj {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    (D : TwoOpenTransition X G) [Group G] [DiscreteTopology G] : D.TotalSpace → X :=
+  D.core.proj
+
+private abbrev TwoOpenTransition.localTrivU {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    (D : TwoOpenTransition X G) [Group G] [DiscreteTopology G] : Bundle.Trivialization G D.proj :=
+  D.core.localTriv Bool.false
+
+private abbrev TwoOpenTransition.localTrivV {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    (D : TwoOpenTransition X G) [Group G] [DiscreteTopology G] : Bundle.Trivialization G D.proj :=
+  D.core.localTriv Bool.true
+
+private def TwoOpenTransition.pointU {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    (D : TwoOpenTransition X G) [Group G] [DiscreteTopology G] (x : X) (g : G) : D.TotalSpace :=
+  D.localTrivU.toOpenPartialHomeomorph.symm (x, g)
+
+private def TwoOpenTransition.pointV {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    (D : TwoOpenTransition X G) [Group G] [DiscreteTopology G] (x : X) (g : G) : D.TotalSpace :=
+  D.localTrivV.toOpenPartialHomeomorph.symm (x, g)
+
+@[simp]
+private theorem
+    TwoOpenTransition.proj_pointU {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    (D : TwoOpenTransition X G) [Group G] [DiscreteTopology G] (x : X) (g : G) :
+    D.proj (D.pointU x g) = x :=
+  rfl
+
+@[simp]
+private theorem
+    TwoOpenTransition.proj_pointV {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    (D : TwoOpenTransition X G) [Group G] [DiscreteTopology G] (x : X) (g : G) :
+    D.proj (D.pointV x g) = x :=
+  rfl
+
+private theorem
+    TwoOpenTransition.pointU_eq_pointV {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    (D : TwoOpenTransition X G) [Group G] [DiscreteTopology G] (x : X) (g : G)
+    (hx : x ∈ (D.U : Set X) ∩ (D.V : Set X)) : D.pointU x g = D.pointV x (g * D.transition x) := by
+  change
+    (⟨x, D.core.coordChange Bool.false (D.core.indexAt x) x g⟩ : D.TotalSpace) =
+      ⟨x, D.core.coordChange Bool.true (D.core.indexAt x) x (g * D.transition x)⟩
+  apply congrArg (fun w : G => (⟨x, w⟩ : D.TotalSpace))
+  exact
+    (D.core.coordChange_comp Bool.false Bool.true (D.core.indexAt x) x
+        ⟨⟨hx.1, hx.2⟩, D.core.mem_baseSet_at x⟩ g).symm
+
+private theorem
+    TwoOpenTransition.isCoveringMap {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    (D : TwoOpenTransition X G) [Group G] [DiscreteTopology G] : IsCoveringMap D.proj := by
+  exact FiberBundle.isCoveringMap (F := G) (E := D.core.Fiber)
+
+private instance
+    TwoOpenTransition.totalMulAction {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    [Group G] [DiscreteTopology G] (D : TwoOpenTransition X G) : MulAction G D.TotalSpace
+    where
+  smul g p := ⟨p.proj, g * (show G from p.2)⟩
+  one_smul
+    p := by
+    rcases p with ⟨b, v⟩
+    change G at v
+    change (⟨b, 1 * v⟩ : D.TotalSpace) = ⟨b, v⟩
+    exact congrArg (fun w : G => (⟨b, w⟩ : D.TotalSpace)) (one_mul v)
+  mul_smul g h
+    p := by
+    rcases p with ⟨b, v⟩
+    change G at v
+    change (⟨b, (g * h) * v⟩ : D.TotalSpace) = ⟨b, g * (h * v)⟩
+    exact congrArg (fun w : G => (⟨b, w⟩ : D.TotalSpace)) (mul_assoc g h v)
+
+private theorem
+    TwoOpenTransition.localTriv_smul {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    [Group G] [DiscreteTopology G] (D : TwoOpenTransition X G) (i : Bool) (g : G)
+    (p : D.TotalSpace) : D.core.localTriv i (g • p) = (D.proj p, g * (D.core.localTriv i p).2) := by
+  apply Prod.ext
+  · rfl
+  exact D.coordChange_mul_left _ _ _ _ _
+
+@[simp]
+private theorem
+    TwoOpenTransition.smul_pointU {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    [Group G] [DiscreteTopology G] (D : TwoOpenTransition X G) (g : G) (x : X) (w : G) :
+    g • D.pointU x w = D.pointU x (g * w) := by
+  change
+    (⟨x, g * D.coordChange Bool.false (D.indexAt x) x w⟩ : D.TotalSpace) =
+      ⟨x, D.coordChange Bool.false (D.indexAt x) x (g * w)⟩
+  exact
+    congrArg (fun v : G => (⟨x, v⟩ : D.TotalSpace))
+      (D.coordChange_mul_left Bool.false (D.indexAt x) x g w).symm
+
+private instance TwoOpenTransition.totalContinuousConstSMul {X G : Type*} [TopologicalSpace X]
+    [TopologicalSpace G] [Group G] [DiscreteTopology G] (D : TwoOpenTransition X G) :
+    ContinuousConstSMul G D.TotalSpace where
+  continuous_const_smul
+    g := by
+    apply continuous_iff_continuousAt.mpr
+    intro p
+    let e := D.core.localTriv (D.core.indexAt p.proj)
+    have he : D.proj p ∈ e.baseSet := D.core.mem_baseSet_at p.proj
+    have hecont : ContinuousAt e p := e.continuousAt (e.mem_source.mpr he)
+    apply
+      e.continuousAt_of_comp_left
+        (show ContinuousAt (D.proj ∘ (g • ·)) p from D.core.continuous_proj.continuousAt) he
+    convert
+      D.core.continuous_proj.continuousAt.prodMk
+        ((show ContinuousAt (fun _ : D.TotalSpace => g) p from continuousAt_const).mul
+          hecont.snd) using
+      1
+    funext q
+    exact D.localTriv_smul _ _ _
+
+private instance TwoOpenTransition.totalIsCancelSMul {X G : Type*} [TopologicalSpace X]
+    [TopologicalSpace G] [Group G] [DiscreteTopology G] (D : TwoOpenTransition X G) :
+    IsCancelSMul G D.TotalSpace where
+  right_cancel' g h p
+    he := by
+    have he' := congrArg (fun q : D.TotalSpace => (q.2 : G)) he
+    exact mul_right_cancel he'
+
+private theorem TwoOpenTransition.proj_eq_iff_mem_orbit {X G : Type*} [TopologicalSpace X]
+    [TopologicalSpace G] [Group G] [DiscreteTopology G] (D : TwoOpenTransition X G)
+    {p q : D.TotalSpace} : D.proj p = D.proj q ↔ p ∈ MulAction.orbit G q := by
+  constructor
+  · cases p with
+    | mk b w =>
+      cases q with
+      | mk c v =>
+        change G at w v
+        intro h
+        change b = c at h
+        subst c
+        refine ⟨w * v⁻¹, ?_⟩
+        change (⟨b, (w * v⁻¹) * v⟩ : D.TotalSpace) = ⟨b, w⟩
+        exact congrArg (fun z : G => (⟨b, z⟩ : D.TotalSpace)) (inv_mul_cancel_right w v)
+  · rintro ⟨g, rfl⟩
+    rfl
+
+private theorem TwoOpenTransition.isQuotientCoveringMap {X G : Type*} [TopologicalSpace X]
+    [TopologicalSpace G] [Group G] [DiscreteTopology G] (D : TwoOpenTransition X G) :
+    IsQuotientCoveringMap D.proj G := by
+  apply (isQuotientCoveringMap_iff_isCoveringMap_and D.proj G).mpr
+  exact
+    ⟨D.isCoveringMap, fun x => ⟨D.pointU x 1, D.proj_pointU x 1⟩, inferInstance, inferInstance,
+      D.proj_eq_iff_mem_orbit⟩
+
+private def TwoOpenTransition.chartPath_mo1973_23734 {E X F : Type*} [TopologicalSpace E]
+    [TopologicalSpace X] [TopologicalSpace F] {p : E → X} (e : Bundle.Trivialization F p)
+    {b c : X} (γ : Path b c) (hγ : ∀ s, γ s ∈ e.baseSet) (v : F) :
+    Path (e.toOpenPartialHomeomorph.symm (b, v)) (e.toOpenPartialHomeomorph.symm (c, v))
+    where
+  toFun s := e.toOpenPartialHomeomorph.symm (γ s, v)
+  continuous_toFun := e.continuousOn_symm_prodMk_left.comp_continuous γ.continuous hγ
+  source' := by simp
+  target' := by simp
+
+private theorem TwoOpenTransition.chartPath_monodromy_mo1973_23735 {E X F : Type*}
+    [TopologicalSpace E] [TopologicalSpace X] [TopologicalSpace F] {p : E → X}
+    (hp : IsCoveringMap p) (e : Bundle.Trivialization F p) {b c : X} (γ : Path b c)
+    (hγ : ∀ s, γ s ∈ e.baseSet) (hb : b ∈ e.baseSet) (hc : c ∈ e.baseSet) (v : F) :
+    hp.monodromy (.mk γ) ⟨e.toOpenPartialHomeomorph.symm (b, v), e.proj_symm_apply' hb⟩ =
+      ⟨e.toOpenPartialHomeomorph.symm (c, v), e.proj_symm_apply' hc⟩ := by
+  apply hp.monodromy_eq_of_map_eq (.mk (chartPath_mo1973_23734 e γ hγ v))
+  apply congrArg Path.Homotopic.Quotient.mk
+  ext s
+  exact e.proj_symm_apply' (hγ s)
+
+private def TwoOpenTransition.fiberPointU {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    [Group G] [DiscreteTopology G] (D : TwoOpenTransition X G) (b : X) (g : G) :
+    D.proj ⁻¹' { b } :=
+  ⟨D.pointU b g, D.proj_pointU b g⟩
+
+private def TwoOpenTransition.fiberPointV {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    [Group G] [DiscreteTopology G] (D : TwoOpenTransition X G) (b : X) (g : G) :
+    D.proj ⁻¹' { b } :=
+  ⟨D.pointV b g, D.proj_pointV b g⟩
+
+@[simp]
+private theorem
+    TwoOpenTransition.fiberPointU_val {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    [Group G] [DiscreteTopology G] (D : TwoOpenTransition X G) (b : X) (g : G) :
+    (D.fiberPointU b g : D.TotalSpace) = D.pointU b g :=
+  rfl
+
+private theorem
+    TwoOpenTransition.pointV_eq_pointU {X G : Type*} [TopologicalSpace X] [TopologicalSpace G]
+    [Group G] [DiscreteTopology G] (D : TwoOpenTransition X G) (b : X) (g : G)
+    (hb : b ∈ (D.U : Set X) ∩ (D.V : Set X)) :
+    D.pointV b g = D.pointU b (g * (D.transition b)⁻¹) := by
+  simpa only [inv_mul_cancel_right] using (D.pointU_eq_pointV b (g * (D.transition b)⁻¹) hb).symm
+
+private theorem TwoOpenTransition.fiberPointU_eq_fiberPointV {X G : Type*} [TopologicalSpace X]
+    [TopologicalSpace G] [Group G] [DiscreteTopology G] (D : TwoOpenTransition X G) (b : X)
+    (g : G) (hb : b ∈ (D.U : Set X) ∩ (D.V : Set X)) :
+    D.fiberPointU b g = D.fiberPointV b (g * D.transition b) :=
+  Subtype.ext (D.pointU_eq_pointV b g hb)
+
+private theorem TwoOpenTransition.fiberPointV_eq_fiberPointU {X G : Type*} [TopologicalSpace X]
+    [TopologicalSpace G] [Group G] [DiscreteTopology G] (D : TwoOpenTransition X G) (b : X)
+    (g : G) (hb : b ∈ (D.U : Set X) ∩ (D.V : Set X)) :
+    D.fiberPointV b g = D.fiberPointU b (g * (D.transition b)⁻¹) :=
+  Subtype.ext (D.pointV_eq_pointU b g hb)
+
+private theorem TwoOpenTransition.monodromy_of_path_U {X G : Type*} [TopologicalSpace X]
+    [TopologicalSpace G] [Group G] [DiscreteTopology G] (D : TwoOpenTransition X G) {b c : X}
+    (α : Path b c) (hα : ∀ s, α s ∈ D.U) (g : G) :
+    D.isCoveringMap.monodromy (.mk α) (D.fiberPointU b g) = D.fiberPointU c g := by
+  have hbase : D.localTrivU.baseSet = D.U := rfl
+  exact
+    chartPath_monodromy_mo1973_23735 D.isCoveringMap D.localTrivU α hα
+      (by simpa [hbase] using hα 0) (by simpa [hbase] using hα 1) g
+
+private theorem TwoOpenTransition.monodromy_of_path_V {X G : Type*} [TopologicalSpace X]
+    [TopologicalSpace G] [Group G] [DiscreteTopology G] (D : TwoOpenTransition X G) {b c : X}
+    (β : Path b c) (hβ : ∀ s, β s ∈ D.V) (g : G) :
+    D.isCoveringMap.monodromy (.mk β) (D.fiberPointV b g) = D.fiberPointV c g := by
+  have hbase : D.localTrivV.baseSet = D.V := rfl
+  exact
+    chartPath_monodromy_mo1973_23735 D.isCoveringMap D.localTrivV β hβ
+      (by simpa [hbase] using hβ 0) (by simpa [hbase] using hβ 1) g
+
+private theorem TwoOpenTransition.monodromy_trans_U_V {X G : Type*} [TopologicalSpace X]
+    [TopologicalSpace G] [Group G] [DiscreteTopology G] (D : TwoOpenTransition X G) {b c : X}
+    (hb : b ∈ (D.U : Set X) ∩ (D.V : Set X)) (hc : c ∈ (D.U : Set X) ∩ (D.V : Set X))
+    (α : Path b c) (β : Path c b) (hα : ∀ s, α s ∈ D.U) (hβ : ∀ s, β s ∈ D.V) (g : G) :
+    D.isCoveringMap.monodromy (.mk (α.trans β)) (D.fiberPointU b g) =
+      D.fiberPointU b ((g * D.transition c) * (D.transition b)⁻¹) := by
+  rw [Path.Homotopic.Quotient.mk_trans, D.isCoveringMap.monodromy_trans_apply,
+    D.monodromy_of_path_U α hα g, D.fiberPointU_eq_fiberPointV c g hc, D.monodromy_of_path_V β hβ,
+    D.fiberPointV_eq_fiberPointU b _ hb]
+
+private def
+    TwoOpenTransition.basepointU {X G : Type*} [TopologicalSpace X] [TopologicalSpace G] [Group G]
+    [DiscreteTopology G] (D : TwoOpenTransition X G) (b : X) (hb : b ∈ D.U) : D.proj ⁻¹' { b } :=
+  ⟨D.pointU b 1, D.localTrivU.proj_symm_apply' hb⟩
+
+@[simp]
+private theorem TwoOpenTransition.basepointU_eq_fiberPointU {X G : Type*} [TopologicalSpace X]
+    [TopologicalSpace G] [Group G] [DiscreteTopology G] (D : TwoOpenTransition X G) (b : X)
+    (hb : b ∈ D.U) : D.basepointU b hb = D.fiberPointU b 1 :=
+  rfl
+
+private def TwoOpenTransition.fundamentalGroupToMulOpposite {X G : Type*} [TopologicalSpace X]
+    [TopologicalSpace G] [Group G] [DiscreteTopology G] (D : TwoOpenTransition X G) (b : X)
+    (hb : b ∈ D.U) : FundamentalGroup X b →* Gᵐᵒᵖ :=
+  D.isQuotientCoveringMap.fundamentalGroupToMulOpposite (D.basepointU b hb)
+
+private theorem TwoOpenTransition.fundamentalGroupToMulOpposite_trans_U_V {X G : Type*}
+    [TopologicalSpace X] [TopologicalSpace G] [Group G] [DiscreteTopology G]
+    (D : TwoOpenTransition X G) {b c : X} (hb : b ∈ (D.U : Set X) ∩ (D.V : Set X))
+    (hc : c ∈ (D.U : Set X) ∩ (D.V : Set X)) (α : Path b c) (β : Path c b) (hα : ∀ s, α s ∈ D.U)
+    (hβ : ∀ s, β s ∈ D.V) :
+    D.fundamentalGroupToMulOpposite b hb.1 (.mk (α.trans β)) =
+      MulOpposite.op (D.transition c * (D.transition b)⁻¹) := by
+  apply (D.isQuotientCoveringMap.fundamentalGroupToMulOpposite_apply_eq_Iff).mpr
+  have hm := congrArg Subtype.val (D.monodromy_trans_U_V hb hc α β hα hβ 1)
+  simpa only [MulOpposite.unop_op, basepointU_eq_fiberPointU, smul_pointU, mul_one, one_mul,
+    fiberPointU_val] using hm.symm
+
+private def FreeMeridianMarking.inversionHom_mo1973_23782 : FreeGroup Bool →* FreeGroup Bool :=
+  FreeGroup.lift (fun b => (FreeGroup.of b)⁻¹)
+
+@[simp]
+private theorem FreeMeridianMarking.inversionHom_of_mo1973_23783 (b : Bool) :
+    inversionHom_mo1973_23782 (FreeGroup.of b) = (FreeGroup.of b)⁻¹ :=
+  FreeGroup.lift_apply_of
+
+private theorem FreeMeridianMarking.inversionHom_involutive_mo1973_23784 :
+    Function.Involutive inversionHom_mo1973_23782 := by
+  have h :
+    inversionHom_mo1973_23782.comp inversionHom_mo1973_23782 = MonoidHom.id (FreeGroup Bool) := by
+    apply FreeGroup.ext_hom
+    intro b
+    simp only [MonoidHom.comp_apply, inversionHom_of_mo1973_23783, map_inv, inv_inv,
+      MonoidHom.id_apply]
+  exact fun w => DFunLike.congr_fun h w
+
+private def FreeMeridianMarking.invertGenerators : FreeGroup Bool ≃* FreeGroup Bool
+    where
+  __ := inversionHom_mo1973_23782
+  invFun := inversionHom_mo1973_23782
+  left_inv := inversionHom_involutive_mo1973_23784
+  right_inv := inversionHom_involutive_mo1973_23784
+
+@[simp]
+private theorem FreeMeridianMarking.invertGenerators_of (b : Bool) :
+    invertGenerators (FreeGroup.of b) = (FreeGroup.of b)⁻¹ :=
+  inversionHom_of_mo1973_23783 b
+
+@[simp]
+private theorem
+    FreeMeridianMarking.invertGenerators_symm : invertGenerators.symm = invertGenerators := by
+  ext w
+  rfl
+
+private def FreeMeridianMarking.conditionalInversion : Bool → (FreeGroup Bool ≃* FreeGroup Bool)
+  | false => MulEquiv.refl _
+  | true => invertGenerators
+
+private def FreeMeridianMarking.reorient {K : Type*} [Group K] (e : K ≃* FreeGroup Bool)
+    (reverse : Bool) : K ≃* FreeGroup Bool :=
+  e.trans (conditionalInversion reverse)
+
+@[simp]
+private theorem FreeMeridianMarking.reorient_symm_of {K : Type*} [Group K] (e : K ≃* FreeGroup Bool)
+    (reverse b : Bool) :
+    (reorient e reverse).symm (FreeGroup.of b) =
+      if reverse then (e.symm (FreeGroup.of b))⁻¹ else e.symm (FreeGroup.of b) := by
+  cases reverse <;> simp [conditionalInversion, reorient]
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/HomologyOfX/CuspCoinvariants.lean b/LeanPool/HopfProblem/HomologyOfX/CuspCoinvariants.lean
new file mode 100644
index 000000000..35c4dd644
--- /dev/null
+++ b/LeanPool/HopfProblem/HomologyOfX/CuspCoinvariants.lean
@@ -0,0 +1,1270 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Recognition.Degree1
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.CuspFibre.CuspPositiveRetraction
+import all LeanPool.HopfProblem.Lattice.Core2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology7
+import all LeanPool.HopfProblem.CuspFibre.CuspSpecialization
+import all LeanPool.HopfProblem.Recognition.Degree1
+
+/-!
+# Hopf problem: homology of x · cusp coinvariants
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def TrianglePeriodFamilyHomologyAlgebra.columnEquiv (H : Type*) [AddCommGroup H] :
+    (H × (H × H)) ≃ₗ[ℤ] (H × (H × H)) :=
+  ({    toFun := fun x => (x.1 + x.2.1 + x.2.2, x.2)
+        invFun := fun x => (x.1 - x.2.1 - x.2.2, x.2)
+        left_inv := by
+          rintro ⟨a, b, c⟩
+          apply Prod.ext
+          · dsimp; abel
+          · rfl
+        right_inv := by
+          rintro ⟨a, b, c⟩
+          apply Prod.ext
+          · dsimp; abel
+          · rfl
+        map_add' := by
+          rintro ⟨a, b, c⟩ ⟨a', b', c'⟩
+          apply Prod.ext
+          · dsimp; abel
+          · rfl } :
+      (H × (H × H)) ≃+ (H × (H × H))).toIntLinearEquiv
+
+@[simp]
+private theorem
+    TrianglePeriodFamilyHomologyAlgebra.columnEquiv_symm_apply (H : Type*) [AddCommGroup H]
+    (x : H × (H × H)) : (columnEquiv H).symm x = (x.1 - x.2.1 - x.2.2, x.2) :=
+  rfl
+
+private def TrianglePeriodFamilyHomologyAlgebra.rowEquiv (H : Type*) [AddCommGroup H] :
+    (H × H) ≃ₗ[ℤ] (H × H) :=
+  ({    toFun := fun x => (x.1, -x.1 - x.2)
+        invFun := fun x => (x.1, -x.1 - x.2)
+        left_inv := by
+          rintro ⟨a, b⟩
+          apply Prod.ext
+          · rfl
+          · dsimp; abel
+        right_inv := by
+          rintro ⟨a, b⟩
+          apply Prod.ext
+          · rfl
+          · dsimp; abel
+        map_add' := by
+          rintro ⟨a, b⟩ ⟨a', b'⟩
+          apply Prod.ext
+          · rfl
+          · dsimp; abel } :
+      (H × H) ≃+ (H × H)).toIntLinearEquiv
+
+@[simp]
+private theorem TrianglePeriodFamilyHomologyAlgebra.rowEquiv_apply (H : Type*) [AddCommGroup H]
+    (x : H × H) : rowEquiv H x = (x.1, -x.1 - x.2) :=
+  rfl
+
+private def TrianglePeriodFamilyHomologyAlgebra.delta {H : Type*} [AddCommGroup H] [Module ℤ H]
+    (P Q : H →ₗ[ℤ] H) : (H × H) →ₗ[ℤ] H :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun x := (P x.1 - x.1) + (Q x.2 - x.2)
+      map_zero' := by simp
+      map_add' x
+        y := by
+        dsimp
+        rw [map_add, map_add]
+        abel }
+
+@[simp]
+private theorem
+    TrianglePeriodFamilyHomologyAlgebra.delta_apply {H : Type*} [AddCommGroup H] [Module ℤ H]
+    (P Q : H →ₗ[ℤ] H) (x : H × H) : delta P Q x = (P x.1 - x.1) + (Q x.2 - x.2) :=
+  rfl
+
+private def TrianglePeriodFamilyHomologyAlgebra.overlapMap {H : Type*} [AddCommGroup H] [Module ℤ H]
+    (P Q : H →ₗ[ℤ] H) : (H × (H × H)) →ₗ[ℤ] (H × H) :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun x := (x.1 + x.2.1 + x.2.2, -(x.1 + P x.2.1 + Q x.2.2))
+      map_zero' := by simp
+      map_add' x
+        y := by
+        apply Prod.ext
+        · dsimp; abel
+        · dsimp
+          rw [map_add, map_add]
+          abel }
+
+@[simp]
+private theorem TrianglePeriodFamilyHomologyAlgebra.overlapMap_apply {H : Type*} [AddCommGroup H]
+    [Module ℤ H] (P Q : H →ₗ[ℤ] H) (x : H × (H × H)) :
+    overlapMap P Q x = (x.1 + x.2.1 + x.2.2, -(x.1 + P x.2.1 + Q x.2.2)) :=
+  rfl
+
+private theorem TrianglePeriodFamilyHomologyAlgebra.row_overlapMap {H : Type*} [AddCommGroup H]
+    [Module ℤ H] (P Q : H →ₗ[ℤ] H) (x : H × (H × H)) :
+    rowEquiv H (overlapMap P Q x) = (x.1 + x.2.1 + x.2.2, delta P Q x.2) := by
+  apply Prod.ext
+  · rfl
+  · change
+      -(x.1 + x.2.1 + x.2.2) - -(x.1 + P x.2.1 + Q x.2.2) = (P x.2.1 - x.2.1) + (Q x.2.2 - x.2.2)
+    abel
+
+private theorem TrianglePeriodFamilyHomologyAlgebra.row_overlapMap_column_symm {H : Type*}
+    [AddCommGroup H] [Module ℤ H] (P Q : H →ₗ[ℤ] H) (x : H × (H × H)) :
+    rowEquiv H (overlapMap P Q ((columnEquiv H).symm x)) = (x.1, delta P Q x.2) := by
+  rw [row_overlapMap, columnEquiv_symm_apply]
+  apply Prod.ext
+  · dsimp; abel
+  · rfl
+
+private theorem
+    TrianglePeriodFamilyHomologyAlgebra.overlapMap_eq_zero_iff {H : Type*} [AddCommGroup H]
+    [Module ℤ H] (P Q : H →ₗ[ℤ] H) (x : H × (H × H)) :
+    overlapMap P Q x = 0 ↔ x.1 + x.2.1 + x.2.2 = 0 ∧ delta P Q x.2 = 0 := by
+  constructor
+  · intro h
+    have hr := congrArg (rowEquiv H) h
+    rw [row_overlapMap, map_zero] at hr
+    exact ⟨congrArg Prod.fst hr, congrArg Prod.snd hr⟩
+  · rintro ⟨hs, hd⟩
+    apply (rowEquiv H).injective
+    rw [row_overlapMap, map_zero]
+    exact Prod.ext hs hd
+
+private theorem
+    TrianglePeriodFamilyHomologyAlgebra.overlapMap_mem_range_iff {H : Type*} [AddCommGroup H]
+    [Module ℤ H] (P Q : H →ₗ[ℤ] H) (y : H × H) :
+    y ∈ LinearMap.range (overlapMap P Q) ↔ -y.1 - y.2 ∈ LinearMap.range (delta P Q) := by
+  constructor
+  · rintro ⟨x, rfl⟩
+    refine ⟨x.2, ?_⟩
+    exact (congrArg Prod.snd (row_overlapMap P Q x)).symm
+  · rintro ⟨bc, hbc⟩
+    refine ⟨(columnEquiv H).symm (y.1, bc), ?_⟩
+    apply (rowEquiv H).injective
+    rw [row_overlapMap_column_symm, rowEquiv_apply, hbc]
+
+private def TrianglePeriodFamilyHomologyLattice.deltaOne : (Lattice × Lattice) →ₗ[ℤ] Lattice :=
+  TrianglePeriodFamilyHomologyAlgebra.delta A₁.mulVecLin A₂.mulVecLin
+
+private def TrianglePeriodFamilyHomologyLattice.deltaThree : (Lattice × Lattice) →ₗ[ℤ] Lattice :=
+  TrianglePeriodFamilyHomologyAlgebra.delta PeriodTorusHigherHomologyExterior.cubeA₁.mulVecLin
+    PeriodTorusHigherHomologyExterior.cubeA₂.mulVecLin
+
+private def TrianglePeriodFamilyHomologyLattice.functionalOdd : Lattice →ₗ[ℤ] ℤ :=
+  LinearMap.proj 0
+
+private theorem TrianglePeriodFamilyHomologyLattice.functionalOdd_surjective :
+    Function.Surjective functionalOdd := by
+  intro a
+  exact ⟨![a, 0, 0, 0], rfl⟩
+
+private theorem TrianglePeriodFamilyHomologyLattice.deltaOne_apply (b c : Lattice) :
+    deltaOne (b, c) =
+      ![0, 6 * b 0 - b 1 + b 2 - c 1 - c 2, -6 * b 0 - b 1 - 2 * b 2 - 6 * c 0 + c 1 - c 2,
+        -2 * b 0 + b 1 + 3 * c 0 + c 2] := by
+  change (A₁ *ᵥ b - b) + (A₂ *ᵥ c - c) = _
+  ext i
+  fin_cases i <;> simp [A₁, A₂, dotProduct, Fin.sum_univ_succ, Matrix.vecHead, Matrix.vecTail] <;>
+    ring
+
+private theorem TrianglePeriodFamilyHomologyLattice.deltaThree_apply (b c : Lattice) :
+    deltaThree (b, c) =
+      ![0, -b 0 - b 1 + b 2 - c 1 - c 2, b 0 - b 1 - 2 * b 2 + c 0 + c 1 - c 2,
+        -2 * b 0 - 6 * b 1 + 3 * c 0 - 6 * c 2] := by
+  change
+    (PeriodTorusHigherHomologyExterior.cubeA₁ *ᵥ b - b) +
+        (PeriodTorusHigherHomologyExterior.cubeA₂ *ᵥ c - c) =
+      _
+  rw [PeriodTorusHigherHomologyExterior.cubeA₁_eq, PeriodTorusHigherHomologyExterior.cubeA₂_eq]
+  ext i
+  fin_cases i <;> simp [dotProduct, Fin.sum_univ_succ, Matrix.vecHead, Matrix.vecTail] <;> ring
+
+private def TrianglePeriodFamilyHomologyLattice.preimageOne (x : Lattice) : Lattice × Lattice :=
+  (![0, x 3, -x 1 - x 2 - 2 * x 3, 0], ![0, -2 * x 1 - x 2 - 3 * x 3, 0, 0])
+
+private def TrianglePeriodFamilyHomologyLattice.preimageThree (x : Lattice) : Lattice × Lattice :=
+  (![x 3, 0, x 3 - x 1 - x 2, 0], ![x 3, -2 * x 1 - x 2, 0, 0])
+
+private theorem TrianglePeriodFamilyHomologyLattice.deltaOne_preimage (x : Lattice) :
+    deltaOne (preimageOne x) = ![0, x 1, x 2, x 3] := by
+  rw [preimageOne, deltaOne_apply]
+  ext i
+  fin_cases i <;> simp <;> ring
+
+private theorem TrianglePeriodFamilyHomologyLattice.deltaThree_preimage (x : Lattice) :
+    deltaThree (preimageThree x) = ![0, x 1, x 2, x 3] := by
+  rw [preimageThree, deltaThree_apply]
+  ext i
+  fin_cases i <;> simp <;> ring
+
+private theorem TrianglePeriodFamilyHomologyLattice.deltaOne_range :
+    LinearMap.range deltaOne = LinearMap.ker functionalOdd := by
+  ext x
+  constructor
+  · rintro ⟨⟨b, c⟩, rfl⟩
+    change functionalOdd (deltaOne (b, c)) = 0
+    rw [deltaOne_apply]
+    rfl
+  · intro hx
+    have hx0 : x 0 = 0 := hx
+    refine ⟨preimageOne x, ?_⟩
+    rw [deltaOne_preimage]
+    ext i
+    fin_cases i <;> simp [hx0]
+
+private theorem TrianglePeriodFamilyHomologyLattice.deltaThree_range :
+    LinearMap.range deltaThree = LinearMap.ker functionalOdd := by
+  ext x
+  constructor
+  · rintro ⟨⟨b, c⟩, rfl⟩
+    change functionalOdd (deltaThree (b, c)) = 0
+    rw [deltaThree_apply]
+    rfl
+  · intro hx
+    have hx0 : x 0 = 0 := hx
+    refine ⟨preimageThree x, ?_⟩
+    rw [deltaThree_preimage]
+    ext i
+    fin_cases i <;> simp [hx0]
+
+private def TrianglePeriodFamilyHomologyLattice.cokernelOneEquiv :
+    (Lattice ⧸ LinearMap.range deltaOne) ≃ₗ[ℤ] ℤ :=
+  (Submodule.quotEquivOfEq _ _ deltaOne_range).trans
+    (functionalOdd.quotKerEquivOfSurjective functionalOdd_surjective)
+
+private def TrianglePeriodFamilyHomologyLattice.cokernelThreeEquiv :
+    (Lattice ⧸ LinearMap.range deltaThree) ≃ₗ[ℤ] ℤ :=
+  (Submodule.quotEquivOfEq _ _ deltaThree_range).trans
+    (functionalOdd.quotKerEquivOfSurjective functionalOdd_surjective)
+
+@[simp]
+private theorem TrianglePeriodFamilyHomologyLattice.cokernelThreeEquiv_mk (x : Lattice) :
+    cokernelThreeEquiv (Submodule.Quotient.mk x) = x 0 := by
+  simp [cokernelThreeEquiv]
+  rfl
+
+private theorem ThreefoldHomology.SecondSource.kernel_coordinates (x y : Lattice)
+    (h : TrianglePeriodFamilyHomologyLattice.deltaOne (x, y) = 0) :
+    x 2 = -4 * x 0 ∧ y 1 = 3 * y 0 ∧ y 2 = 2 * x 0 - x 1 - 3 * y 0 := by
+  rw [TrianglePeriodFamilyHomologyLattice.deltaOne_apply] at h
+  have h₁ := congrFun h 1
+  have h₂ := congrFun h 2
+  have h₃ := congrFun h 3
+  change 6 * x 0 - x 1 + x 2 - y 1 - y 2 = 0 at h₁
+  change -6 * x 0 - x 1 - 2 * x 2 - 6 * y 0 + y 1 - y 2 = 0 at h₂
+  change -2 * x 0 + x 1 + 3 * y 0 + y 2 = 0 at h₃
+  omega
+
+private def ThreefoldHomology.SecondSource.deltaVector : Lattice :=
+  ![0, 0, 0, 1]
+
+private def
+    ThreefoldHomology.SecondSource.threeCoordinates (κ₃ κ₄ : ℤ) (x y : Lattice) : Fin 2 → ℤ :=
+  ![x 3 + (x 1 - 2 * x 0) + (κ₄ * y 0 - y 3) + κ₃ * x 0, x 0]
+
+private def ThreefoldHomology.SecondSource.fourCoordinates (y : Lattice) : Fin 2 → ℤ :=
+  ![0, -y 0]
+
+private def ThreefoldHomology.SecondSource.cuspCoordinates (κ₄ : ℤ) (x y : Lattice) : Lattice :=
+  ![0, 0, x 1 - 2 * x 0, κ₄ * y 0 - y 3]
+
+private def ThreefoldHomology.SecondSource.threeWangVector (κ₃ : ℤ) (a : Fin 2 → ℤ) : Lattice :=
+  a 1 • ε + (a 0 - κ₃ * a 1) • deltaVector
+
+private def ThreefoldHomology.SecondSource.fourWangVector (κ₄ : ℤ) (a : Fin 2 → ℤ) : Lattice :=
+  a 1 • (-ε') + (2 * a 0 - κ₄ * a 1) • deltaVector
+
+private theorem
+    ThreefoldHomology.SecondSource.threeCoordinates_reconstruct (κ₃ κ₄ : ℤ) (x y : Lattice)
+    (h : TrianglePeriodFamilyHomologyLattice.deltaOne (x, y) = 0) :
+    threeWangVector κ₃ (threeCoordinates κ₃ κ₄ x y) - A₂ *ᵥ cuspCoordinates κ₄ x y = x := by
+  have hx₂ := (kernel_coordinates x y h).1
+  ext i
+  fin_cases i <;>
+      simp [threeWangVector, threeCoordinates, cuspCoordinates, deltaVector, ε, A₂, hx₂] <;>
+    ring
+
+private theorem ThreefoldHomology.SecondSource.fourCoordinates_reconstruct (κ₄ : ℤ) (x y : Lattice)
+    (h : TrianglePeriodFamilyHomologyLattice.deltaOne (x, y) = 0) :
+    fourWangVector κ₄ (fourCoordinates y) - cuspCoordinates κ₄ x y = y := by
+  have hy₁ := (kernel_coordinates x y h).2.1
+  have hy₂ := (kernel_coordinates x y h).2.2
+  ext i
+  fin_cases i <;>
+      simp [fourWangVector, fourCoordinates, cuspCoordinates, deltaVector, ε', hy₁, hy₂] <;>
+    ring
+
+private theorem ThreefoldHomology.SecondSource.cuspCoordinates_fixed (κ₄ : ℤ) (x y : Lattice) :
+    M₀ *ᵥ cuspCoordinates κ₄ x y = cuspCoordinates κ₄ x y := by
+  ext i
+  fin_cases i <;> simp [cuspCoordinates, M₀, Matrix.mulVec, dotProduct, Fin.sum_univ_succ]
+
+private abbrev ThreefoldHomologyFinitenessCusp.FullSpace (D : SpecialPeriods.CuspFamily.Data) :=
+  CuspQuotient.QuotientSpace D.correction D.radius
+
+private def ThreefoldHomologyFinitenessCusp.parameterNorm (D : SpecialPeriods.CuspFamily.Data) :
+    C(FullSpace D, ℝ) :=
+  ⟨fun x => ‖CuspQuotient.projection D.correction D.radius x‖,
+    (CuspQuotient.projection_continuous D.correction D.radius).norm⟩
+
+private theorem ThreefoldHomologyFinitenessCusp.exponential_norm_mo1973_10230 (s : ℂ) :
+    ‖CuspUniformization.exponential s‖ = Real.exp (-2 * Real.pi * s.im) :=
+  (Real.exp_log (norm_pos_iff.mpr (CuspUniformization.exponential_ne_zero s))).symm.trans
+    (congrArg Real.exp (CuspUniformization.log_norm_exponential s))
+
+private theorem ThreefoldHomologyFinitenessCusp.parameterNorm_product_symm
+    (D : SpecialPeriods.CuspFamily.Data)
+    (p :
+      ThreefoldOverlapMappingTorus.Cusp.Height D.radius ×
+        ThreefoldOverlapMappingTorus.Cusp.Boundary) :
+    parameterNorm D ((ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D).symm p) =
+      Real.exp (-2 * Real.pi * (p.1 : ℝ)) := by
+  rcases p with ⟨h, y⟩
+  obtain ⟨⟨t, x⟩, rfl⟩ := MappingTorus.mk_surjective ThreefoldOverlapMappingTorus.Cusp.monodromy y
+  change
+    ‖CuspQuotient.projection D.correction D.radius
+          (ThreefoldOverlapMappingTorus.Cusp.puncturedFamilyHomeomorph D
+            ((ThreefoldOverlapMappingTorus.Cusp.familyProductHomeomorph D).symm
+              (h, MappingTorus.mk ThreefoldOverlapMappingTorus.Cusp.monodromy (t, x))))‖ =
+      _
+  rw [ThreefoldOverlapMappingTorus.Cusp.familyProductHomeomorph_symm_mk,
+    ThreefoldOverlapMappingTorus.Cusp.puncturedFamilyHomeomorph_base, D.projection_quotient]
+  change
+    ‖CuspUniformization.exponential
+          (ThreefoldOverlapMappingTorus.Cusp.logPoint D.radius D.radius_pos t h)‖ =
+      _
+  rw [exponential_norm_mo1973_10230, ThreefoldOverlapMappingTorus.Cusp.logPoint_im]
+
+private theorem ThreefoldHomologyFinitenessCusp.parameterNorm_punctured
+    (D : SpecialPeriods.CuspFamily.Data)
+    (x : CuspUniformization.PuncturedQuotient D.correction D.radius) :
+    parameterNorm D x =
+      Real.exp
+        (-2 * Real.pi *
+          ((ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D x).1 : ℝ)) := by
+  have h :=
+    parameterNorm_product_symm D
+      (ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D x)
+  rwa [Homeomorph.symm_apply_apply] at h
+
+private def ThreefoldHomologyFinitenessCusp.heightCutoff (r H : ℝ) :
+    C(unitInterval × ThreefoldOverlapMappingTorus.Cusp.Height r,
+      ThreefoldOverlapMappingTorus.Cusp.Height r)
+    where
+  toFun
+    p :=
+    ⟨(p.2 : ℝ) + (p.1 : ℝ) * (Max.max (p.2 : ℝ) H - (p.2 : ℝ)),
+      lt_of_lt_of_le p.2.property
+        (le_add_of_nonneg_right (mul_nonneg p.1.property.1 (sub_nonneg.mpr (le_max_left _ _))))⟩
+  continuous_toFun :=
+    ((continuous_subtype_val.comp continuous_snd).add
+          ((continuous_subtype_val.comp continuous_fst).mul
+            (((continuous_subtype_val.comp continuous_snd).max continuous_const).sub
+              (continuous_subtype_val.comp continuous_snd)))).subtype_mk
+      _
+
+@[simp]
+private theorem ThreefoldHomologyFinitenessCusp.heightCutoff_zero (r H : ℝ)
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height r) : heightCutoff r H (0, h) = h := by
+  apply Subtype.ext
+  change (h : ℝ) + 0 * (Max.max (h : ℝ) H - (h : ℝ)) = (h : ℝ)
+  simp
+
+private theorem ThreefoldHomologyFinitenessCusp.heightCutoff_one (r H : ℝ)
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height r) :
+    (heightCutoff r H (1, h) : ℝ) = Max.max (h : ℝ) H := by
+  change (h : ℝ) + 1 * (Max.max (h : ℝ) H - (h : ℝ)) = _
+  ring
+
+private theorem ThreefoldHomologyFinitenessCusp.heightCutoff_ge (r H : ℝ) (t : unitInterval)
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height r) : (h : ℝ) ≤ (heightCutoff r H (t, h) : ℝ) :=
+  le_add_of_nonneg_right (mul_nonneg t.property.1 (sub_nonneg.mpr (le_max_left _ _)))
+
+private theorem ThreefoldHomologyFinitenessCusp.heightCutoff_fixed (r H : ℝ) (t : unitInterval)
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height r) (hh : H ≤ (h : ℝ)) :
+    heightCutoff r H (t, h) = h := by
+  apply Subtype.ext
+  change (h : ℝ) + (t : ℝ) * (Max.max (h : ℝ) H - (h : ℝ)) = (h : ℝ)
+  rw [max_eq_left hh, sub_self, MulZeroClass.mul_zero, add_zero]
+
+private def
+    ThreefoldHomologyFinitenessCusp.puncturedHeightCutoff (D : SpecialPeriods.CuspFamily.Data)
+    (H : ℝ) :
+    C(unitInterval × CuspUniformization.PuncturedQuotient D.correction D.radius,
+      CuspUniformization.PuncturedQuotient D.correction D.radius)
+    where
+  toFun
+    p :=
+    (ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D).symm
+      (heightCutoff D.radius H
+          (p.1, (ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D p.2).1),
+        (ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D p.2).2)
+  continuous_toFun :=
+    (ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D).symm.continuous.comp
+      (((heightCutoff D.radius H).continuous.comp
+            (continuous_fst.prodMk
+              (continuous_fst.comp
+                ((ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D).continuous.comp
+                  continuous_snd)))).prodMk
+        (continuous_snd.comp
+          ((ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D).continuous.comp
+            continuous_snd)))
+
+private theorem ThreefoldHomologyFinitenessCusp.puncturedHeightCutoff_product
+    (D : SpecialPeriods.CuspFamily.Data) (H : ℝ) (t : unitInterval)
+    (x : CuspUniformization.PuncturedQuotient D.correction D.radius) :
+    ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D
+        (puncturedHeightCutoff D H (t, x)) =
+      (heightCutoff D.radius H
+          (t, (ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D x).1),
+        (ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D x).2) :=
+  (ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D).apply_symm_apply _
+
+@[simp]
+private theorem ThreefoldHomologyFinitenessCusp.puncturedHeightCutoff_zero
+    (D : SpecialPeriods.CuspFamily.Data) (H : ℝ)
+    (x : CuspUniformization.PuncturedQuotient D.correction D.radius) :
+    puncturedHeightCutoff D H (0, x) = x := by
+  apply (ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D).injective
+  rw [puncturedHeightCutoff_product, heightCutoff_zero]
+
+private theorem ThreefoldHomologyFinitenessCusp.puncturedHeightCutoff_parameterNorm
+    (D : SpecialPeriods.CuspFamily.Data) (H : ℝ) (t : unitInterval)
+    (x : CuspUniformization.PuncturedQuotient D.correction D.radius) :
+    parameterNorm D (puncturedHeightCutoff D H (t, x)) =
+      Real.exp
+        (-2 * Real.pi *
+          (heightCutoff D.radius H
+              (t, (ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D x).1) :
+            ℝ)) := by exact parameterNorm_product_symm D _
+
+private theorem ThreefoldHomologyFinitenessCusp.puncturedHeightCutoff_norm_nonincrease
+    (D : SpecialPeriods.CuspFamily.Data) (H : ℝ) (t : unitInterval)
+    (x : CuspUniformization.PuncturedQuotient D.correction D.radius) :
+    parameterNorm D (puncturedHeightCutoff D H (t, x)) ≤ parameterNorm D x := by
+  rw [puncturedHeightCutoff_parameterNorm, parameterNorm_punctured]
+  apply Real.exp_le_exp.mpr
+  have hh :=
+    heightCutoff_ge D.radius H t
+      (ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D x).1
+  nlinarith [Real.pi_pos]
+
+private def ThreefoldHomologyFinitenessCusp.cutoffRadius (H : ℝ) : ℝ :=
+  Real.exp (-2 * Real.pi * H)
+
+private theorem ThreefoldHomologyFinitenessCusp.cutoffRadius_pos (H : ℝ) : 0 < cutoffRadius H :=
+  Real.exp_pos _
+
+private theorem ThreefoldHomologyFinitenessCusp.puncturedHeightCutoff_one_norm_le
+    (D : SpecialPeriods.CuspFamily.Data) (H : ℝ)
+    (x : CuspUniformization.PuncturedQuotient D.correction D.radius) :
+    parameterNorm D (puncturedHeightCutoff D H (1, x)) ≤ cutoffRadius H := by
+  rw [puncturedHeightCutoff_parameterNorm, heightCutoff_one]
+  apply Real.exp_le_exp.mpr
+  have hh :=
+    le_max_right ((ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D x).1 : ℝ) H
+  nlinarith [Real.pi_pos]
+
+private theorem ThreefoldHomologyFinitenessCusp.puncturedHeightCutoff_fixed
+    (D : SpecialPeriods.CuspFamily.Data) (H : ℝ) (t : unitInterval)
+    (x : CuspUniformization.PuncturedQuotient D.correction D.radius)
+    (hx : parameterNorm D x < cutoffRadius H) : puncturedHeightCutoff D H (t, x) = x := by
+  have hh : H ≤ ((ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D x).1 : ℝ) := by
+    rw [parameterNorm_punctured] at hx
+    have he := Real.exp_lt_exp.mp hx
+    nlinarith [Real.pi_pos]
+  apply (ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D).injective
+  rw [puncturedHeightCutoff_product, heightCutoff_fixed D.radius H t _ hh]
+
+private theorem ThreefoldHomologyFinitenessCusp.cutoffRadius_threshold_lt {δ : ℝ} (hδ : 0 < δ) :
+    cutoffRadius (ThreefoldOverlapMappingTorus.Cusp.heightThreshold δ + 1) < δ := by
+  apply (Real.log_lt_log_iff (cutoffRadius_pos _) hδ).mp
+  change
+    Real.log
+        (Real.exp (-2 * Real.pi * (ThreefoldOverlapMappingTorus.Cusp.heightThreshold δ + 1))) <
+      Real.log δ
+  rw [Real.log_exp]
+  have ht : 2 * Real.pi * ThreefoldOverlapMappingTorus.Cusp.heightThreshold δ = -Real.log δ := by
+    unfold ThreefoldOverlapMappingTorus.Cusp.heightThreshold
+    exact mul_div_cancel₀ _ (ne_of_gt (mul_pos (by norm_num) Real.pi_pos))
+  nlinarith [Real.pi_pos]
+
+private abbrev ThreefoldHomologyFinitenessRetraction.Positive {X : Type*} [TopologicalSpace X]
+    (ρ : C(X, ℝ)) :=
+  { x : X // 0 < ρ x }
+
+private abbrev ThreefoldHomologyFinitenessRetraction.Sublevel {X : Type*} [TopologicalSpace X]
+    (ρ : C(X, ℝ)) (δ : ℝ) :=
+  { x : X // ρ x < δ }
+
+private def ThreefoldHomologyFinitenessRetraction.extensionFun {X : Type*} [TopologicalSpace X]
+    (ρ : C(X, ℝ)) (H : C((unitInterval) × Positive ρ, Positive ρ)) (s : (unitInterval) × X) : X :=
+  by classical exact if hx : 0 < ρ s.2 then (H (s.1, ⟨s.2, hx⟩)).val else s.2
+
+private theorem ThreefoldHomologyFinitenessRetraction.extensionFun_apply_of_pos {X : Type*}
+    [TopologicalSpace X] (ρ : C(X, ℝ)) (H : C((unitInterval) × Positive ρ, Positive ρ))
+    (s : (unitInterval) × X) (hs : 0 < ρ s.2) : extensionFun ρ H s = (H (s.1, ⟨s.2, hs⟩)).val := by
+  classical simp only [extensionFun, dite_eq_left hs]
+
+private theorem ThreefoldHomologyFinitenessRetraction.extensionFun_apply_of_nonpos {X : Type*}
+    [TopologicalSpace X] (ρ : C(X, ℝ)) (H : C((unitInterval) × Positive ρ, Positive ρ))
+    (s : (unitInterval) × X) (hs : ρ s.2 ≤ 0) : extensionFun ρ H s = s.2 := by
+  classical simp only [extensionFun, dite_eq_right (not_lt_of_ge hs)]
+
+private theorem ThreefoldHomologyFinitenessRetraction.extensionFun_apply_of_small {X : Type*}
+    [TopologicalSpace X] (ρ : C(X, ℝ)) (H : C((unitInterval) × Positive ρ, Positive ρ)) (η : ℝ)
+    (hfix : ∀ (t : (unitInterval)) (x : Positive ρ), ρ x.val < η → H (t, x) = x)
+    (s : (unitInterval) × X) (hs : ρ s.2 < η) : extensionFun ρ H s = s.2 := by
+  by_cases hp : 0 < ρ s.2
+  · rw [extensionFun_apply_of_pos ρ H s hp, hfix s.1 ⟨s.2, hp⟩ hs]
+  · exact extensionFun_apply_of_nonpos ρ H s (le_of_not_gt hp)
+
+private theorem ThreefoldHomologyFinitenessRetraction.extensionFun_continuousOn_positive {X : Type*}
+    [TopologicalSpace X] (ρ : C(X, ℝ)) (H : C((unitInterval) × Positive ρ, Positive ρ)) :
+    ContinuousOn (extensionFun ρ H) {s : (unitInterval) × X | 0 < ρ s.2} := by
+  apply continuousOn_iff_continuous_domRestrict.mpr
+  have hpair :
+    Continuous
+      (fun s : { s : (unitInterval) × X // 0 < ρ s.2 } =>
+        (s.val.1, (⟨s.val.2, s.property⟩ : Positive ρ))) :=
+    continuous_subtype_val.fst.prodMk (continuous_subtype_val.snd.subtype_mk _)
+  exact
+    (continuous_subtype_val.comp (H.continuous.comp hpair)).congr
+      (fun s => (extensionFun_apply_of_pos ρ H s.val s.property).symm)
+
+private theorem ThreefoldHomologyFinitenessRetraction.extensionFun_continuousOn_small {X : Type*}
+    [TopologicalSpace X] (ρ : C(X, ℝ)) (H : C((unitInterval) × Positive ρ, Positive ρ)) (η : ℝ)
+    (hfix : ∀ (t : (unitInterval)) (x : Positive ρ), ρ x.val < η → H (t, x) = x) :
+    ContinuousOn (extensionFun ρ H) {s : (unitInterval) × X | ρ s.2 < η} :=
+  continuous_snd.continuousOn.congr (fun s hs => extensionFun_apply_of_small ρ H η hfix s hs)
+
+private theorem ThreefoldHomologyFinitenessRetraction.extensionFun_continuous {X : Type*}
+    [TopologicalSpace X] (ρ : C(X, ℝ)) (H : C((unitInterval) × Positive ρ, Positive ρ)) (η : ℝ)
+    (hη : 0 < η) (hfix : ∀ (t : (unitInterval)) (x : Positive ρ), ρ x.val < η → H (t, x) = x) :
+    Continuous (extensionFun ρ H) := by
+  have hρ : Continuous (fun s : (unitInterval) × X => ρ s.2) := ρ.continuous.comp continuous_snd
+  have hopen : IsOpen {s : (unitInterval) × X | 0 < ρ s.2} := isOpen_lt continuous_const hρ
+  have hsmall : IsOpen {s : (unitInterval) × X | ρ s.2 < η} := isOpen_lt hρ continuous_const
+  apply continuous_iff_continuousAt.mpr
+  intro s
+  by_cases hs : 0 < ρ s.2
+  · exact (extensionFun_continuousOn_positive ρ H).continuousAt (hopen.mem_nhds hs)
+  · exact
+      (extensionFun_continuousOn_small ρ H η hfix).continuousAt
+        (hsmall.mem_nhds ((le_of_not_gt hs).trans_lt hη))
+
+private def
+    ThreefoldHomologyFinitenessRetraction.extension {X : Type*} [TopologicalSpace X] (ρ : C(X, ℝ))
+    (H : C((unitInterval) × Positive ρ, Positive ρ)) (η : ℝ) (hη : 0 < η)
+    (hfix : ∀ (t : (unitInterval)) (x : Positive ρ), ρ x.val < η → H (t, x) = x) :
+    C((unitInterval) × X, X) :=
+  ⟨extensionFun ρ H, extensionFun_continuous ρ H η hη hfix⟩
+
+private theorem ThreefoldHomologyFinitenessRetraction.extension_apply_of_pos {X : Type*}
+    [TopologicalSpace X] (ρ : C(X, ℝ)) (H : C((unitInterval) × Positive ρ, Positive ρ)) (η : ℝ)
+    (hη : 0 < η) (hfix : ∀ (t : (unitInterval)) (x : Positive ρ), ρ x.val < η → H (t, x) = x)
+    (s : (unitInterval) × X) (hs : 0 < ρ s.2) :
+    extension ρ H η hη hfix s = (H (s.1, ⟨s.2, hs⟩)).val :=
+  extensionFun_apply_of_pos ρ H s hs
+
+private theorem ThreefoldHomologyFinitenessRetraction.extension_apply_of_nonpos {X : Type*}
+    [TopologicalSpace X] (ρ : C(X, ℝ)) (H : C((unitInterval) × Positive ρ, Positive ρ)) (η : ℝ)
+    (hη : 0 < η) (hfix : ∀ (t : (unitInterval)) (x : Positive ρ), ρ x.val < η → H (t, x) = x)
+    (s : (unitInterval) × X) (hs : ρ s.2 ≤ 0) : extension ρ H η hη hfix s = s.2 :=
+  extensionFun_apply_of_nonpos ρ H s hs
+
+private theorem ThreefoldHomologyFinitenessRetraction.extension_apply_of_small {X : Type*}
+    [TopologicalSpace X] (ρ : C(X, ℝ)) (H : C((unitInterval) × Positive ρ, Positive ρ)) (η : ℝ)
+    (hη : 0 < η) (hfix : ∀ (t : (unitInterval)) (x : Positive ρ), ρ x.val < η → H (t, x) = x)
+    (s : (unitInterval) × X) (hs : ρ s.2 < η) : extension ρ H η hη hfix s = s.2 :=
+  extensionFun_apply_of_small ρ H η hfix s hs
+
+private theorem
+    ThreefoldHomologyFinitenessRetraction.extension_zero {X : Type*} [TopologicalSpace X]
+    (ρ : C(X, ℝ)) (H : C(unitInterval × Positive ρ, Positive ρ)) (η : ℝ) (hη : 0 < η)
+    (hfix : ∀ (t : unitInterval) (x : Positive ρ), ρ x.val < η → H (t, x) = x)
+    (hzero : ∀ x : Positive ρ, H (0, x) = x) (x : X) : extension ρ H η hη hfix (0, x) = x := by
+  by_cases hx : 0 < ρ x
+  · exact
+      (extension_apply_of_pos ρ H η hη hfix (0, x) hx).trans
+        (congrArg Subtype.val (hzero ⟨x, hx⟩))
+  · exact extension_apply_of_nonpos ρ H η hη hfix (0, x) (le_of_not_gt hx)
+
+private theorem
+    ThreefoldHomologyFinitenessRetraction.extension_radius_le {X : Type*} [TopologicalSpace X]
+    (ρ : C(X, ℝ)) (H : C(unitInterval × Positive ρ, Positive ρ)) (η : ℝ) (hη : 0 < η)
+    (hfix : ∀ (t : unitInterval) (x : Positive ρ), ρ x.val < η → H (t, x) = x)
+    (hmono : ∀ (t : unitInterval) (x : Positive ρ), ρ (H (t, x)).val ≤ ρ x.val)
+    (s : unitInterval × X) : ρ (extension ρ H η hη hfix s) ≤ ρ s.2 := by
+  by_cases hs : 0 < ρ s.2
+  · rw [extension_apply_of_pos ρ H η hη hfix s hs]
+    exact hmono s.1 ⟨s.2, hs⟩
+  · exact (congrArg ρ (extension_apply_of_nonpos ρ H η hη hfix s (le_of_not_gt hs))).le
+
+private theorem
+    ThreefoldHomologyFinitenessRetraction.extension_one_lt {X : Type*} [TopologicalSpace X]
+    (ρ : C(X, ℝ)) (H : C(unitInterval × Positive ρ, Positive ρ)) (η : ℝ) (hη : 0 < η)
+    (hfix : ∀ (t : unitInterval) (x : Positive ρ), ρ x.val < η → H (t, x) = x) (δ : ℝ)
+    (hηδ : η ≤ δ) (hone : ∀ x : Positive ρ, ρ (H (1, x)).val < δ) (x : X) :
+    ρ (extension ρ H η hη hfix (1, x)) < δ := by
+  by_cases hx : 0 < ρ x
+  · rw [extension_apply_of_pos ρ H η hη hfix (1, x) hx]
+    exact hone ⟨x, hx⟩
+  · rw [extension_apply_of_nonpos ρ H η hη hfix (1, x) (le_of_not_gt hx)]
+    exact (le_of_not_gt hx).trans_lt (hη.trans_le hηδ)
+
+private theorem ThreefoldHomologyFinitenessRetraction.extension_stays_sublevel {X : Type*}
+    [TopologicalSpace X] (ρ : C(X, ℝ)) (H : C(unitInterval × Positive ρ, Positive ρ)) (η : ℝ)
+    (hη : 0 < η) (hfix : ∀ (t : unitInterval) (x : Positive ρ), ρ x.val < η → H (t, x) = x)
+    (hmono : ∀ (t : unitInterval) (x : Positive ρ), ρ (H (t, x)).val ≤ ρ x.val) (δ : ℝ)
+    (s : unitInterval × Sublevel ρ δ) : ρ (extension ρ H η hη hfix (s.1, s.2.val)) < δ :=
+  (extension_radius_le ρ H η hη hfix hmono (s.1, s.2.val)).trans_lt s.2.property
+
+private def ThreefoldHomologyFinitenessRetraction.sublevelInclusion {X : Type*} [TopologicalSpace X]
+    (ρ : C(X, ℝ)) (δ : ℝ) : C(Sublevel ρ δ, X) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private def ThreefoldHomologyFinitenessRetraction.sublevelMap {X : Type*} [TopologicalSpace X]
+    (ρ : C(X, ℝ)) (H : C(unitInterval × Positive ρ, Positive ρ)) (η : ℝ) (hη : 0 < η)
+    (hfix : ∀ (t : unitInterval) (x : Positive ρ), ρ x.val < η → H (t, x) = x) (δ : ℝ)
+    (hηδ : η ≤ δ) (hone : ∀ x : Positive ρ, ρ (H (1, x)).val < δ) : C(X, Sublevel ρ δ)
+    where
+  toFun x := ⟨extension ρ H η hη hfix (1, x), extension_one_lt ρ H η hη hfix δ hηδ hone x⟩
+  continuous_toFun :=
+    ((extension ρ H η hη hfix).continuous.comp (continuous_const.prodMk continuous_id)).subtype_mk
+      _
+
+private def ThreefoldHomologyFinitenessRetraction.extendedHomotopy {X : Type*} [TopologicalSpace X]
+    (ρ : C(X, ℝ)) (H : C(unitInterval × Positive ρ, Positive ρ)) (η : ℝ) (hη : 0 < η)
+    (hfix : ∀ (t : unitInterval) (x : Positive ρ), ρ x.val < η → H (t, x) = x)
+    (hzero : ∀ x : Positive ρ, H (0, x) = x) (δ : ℝ) (hηδ : η ≤ δ)
+    (hone : ∀ x : Positive ρ, ρ (H (1, x)).val < δ) :
+    (ContinuousMap.id X).HomotopyRel
+      ((sublevelInclusion ρ δ).comp (sublevelMap ρ H η hη hfix δ hηδ hone)) {x : X | ρ x < η}
+    where
+  toFun := extension ρ H η hη hfix
+  continuous_toFun := (extension ρ H η hη hfix).continuous
+  map_zero_left := extension_zero ρ H η hη hfix hzero
+  map_one_left _ := rfl
+  prop' t x hx := extension_apply_of_small ρ H η hη hfix (t, x) hx
+
+private def
+    ThreefoldHomologyFinitenessRetraction.restrictedHomotopy {X : Type*} [TopologicalSpace X]
+    (ρ : C(X, ℝ)) (H : C(unitInterval × Positive ρ, Positive ρ)) (η : ℝ) (hη : 0 < η)
+    (hfix : ∀ (t : unitInterval) (x : Positive ρ), ρ x.val < η → H (t, x) = x)
+    (hzero : ∀ x : Positive ρ, H (0, x) = x)
+    (hmono : ∀ (t : unitInterval) (x : Positive ρ), ρ (H (t, x)).val ≤ ρ x.val) (δ : ℝ)
+    (hηδ : η ≤ δ) (hone : ∀ x : Positive ρ, ρ (H (1, x)).val < δ) :
+    (ContinuousMap.id (Sublevel ρ δ)).HomotopyRel
+      ((sublevelMap ρ H η hη hfix δ hηδ hone).comp (sublevelInclusion ρ δ))
+      {x : Sublevel ρ δ | ρ x.val < η}
+    where
+  toFun
+    s :=
+    ⟨extension ρ H η hη hfix (s.1, s.2.val), extension_stays_sublevel ρ H η hη hfix hmono δ s⟩
+  continuous_toFun :=
+    ((extension ρ H η hη hfix).continuous.comp
+          (continuous_fst.prodMk (continuous_subtype_val.comp continuous_snd))).subtype_mk
+      _
+  map_zero_left
+    x := by
+    apply Subtype.ext
+    exact extension_zero ρ H η hη hfix hzero x.val
+  map_one_left _ := rfl
+  prop' t x
+    hx := by
+    apply Subtype.ext
+    exact extension_apply_of_small ρ H η hη hfix (t, x.val) hx
+
+private def
+    ThreefoldHomologyFinitenessRetraction.sublevelHomotopyEquiv {X : Type*} [TopologicalSpace X]
+    (ρ : C(X, ℝ)) (H : C(unitInterval × Positive ρ, Positive ρ)) (η : ℝ) (hη : 0 < η)
+    (hfix : ∀ (t : unitInterval) (x : Positive ρ), ρ x.val < η → H (t, x) = x)
+    (hzero : ∀ x : Positive ρ, H (0, x) = x)
+    (hmono : ∀ (t : unitInterval) (x : Positive ρ), ρ (H (t, x)).val ≤ ρ x.val) (δ : ℝ)
+    (hηδ : η ≤ δ) (hone : ∀ x : Positive ρ, ρ (H (1, x)).val < δ) : X ≃ₕ Sublevel ρ δ
+    where
+  toFun := sublevelMap ρ H η hη hfix δ hηδ hone
+  invFun := sublevelInclusion ρ δ
+  left_inv := ⟨(extendedHomotopy ρ H η hη hfix hzero δ hηδ hone).toHomotopy.symm⟩
+  right_inv := ⟨(restrictedHomotopy ρ H η hη hfix hzero hmono δ hηδ hone).toHomotopy.symm⟩
+
+private def ThreefoldHomologyFinitenessCusp.positivePuncturedHomeomorph
+    (D : SpecialPeriods.CuspFamily.Data) :
+    ThreefoldHomologyFinitenessRetraction.Positive (parameterNorm D) ≃ₜ
+      CuspUniformization.PuncturedQuotient D.correction D.radius
+    where
+  toFun
+    x :=
+    ⟨x.val,
+      norm_pos_iff.mp
+        (show 0 < ‖CuspQuotient.projection D.correction D.radius x.val‖ from x.property)⟩
+  invFun x := ⟨x.val, norm_pos_iff.mpr x.property⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := continuous_subtype_val.subtype_mk _
+  continuous_invFun := continuous_subtype_val.subtype_mk _
+
+private def
+    ThreefoldHomologyFinitenessCusp.positiveHeightCutoff (D : SpecialPeriods.CuspFamily.Data)
+    (H : ℝ) :
+    C(unitInterval × ThreefoldHomologyFinitenessRetraction.Positive (parameterNorm D),
+      ThreefoldHomologyFinitenessRetraction.Positive (parameterNorm D))
+    where
+  toFun
+    p :=
+    (positivePuncturedHomeomorph D).symm
+      (puncturedHeightCutoff D H (p.1, positivePuncturedHomeomorph D p.2))
+  continuous_toFun :=
+    (positivePuncturedHomeomorph D).symm.continuous.comp
+      ((puncturedHeightCutoff D H).continuous.comp
+        (continuous_fst.prodMk ((positivePuncturedHomeomorph D).continuous.comp continuous_snd)))
+
+@[simp]
+private theorem ThreefoldHomologyFinitenessCusp.positiveHeightCutoff_zero
+    (D : SpecialPeriods.CuspFamily.Data) (H : ℝ)
+    (x : ThreefoldHomologyFinitenessRetraction.Positive (parameterNorm D)) :
+    positiveHeightCutoff D H (0, x) = x := by
+  change
+    (positivePuncturedHomeomorph D).symm
+        (puncturedHeightCutoff D H (0, positivePuncturedHomeomorph D x)) =
+      x
+  rw [puncturedHeightCutoff_zero, Homeomorph.symm_apply_apply]
+
+private theorem ThreefoldHomologyFinitenessCusp.positiveHeightCutoff_norm_nonincrease
+    (D : SpecialPeriods.CuspFamily.Data) (H : ℝ) (t : unitInterval)
+    (x : ThreefoldHomologyFinitenessRetraction.Positive (parameterNorm D)) :
+    parameterNorm D (positiveHeightCutoff D H (t, x)).val ≤ parameterNorm D x.val :=
+  puncturedHeightCutoff_norm_nonincrease D H t (positivePuncturedHomeomorph D x)
+
+private theorem ThreefoldHomologyFinitenessCusp.positiveHeightCutoff_one_norm_le
+    (D : SpecialPeriods.CuspFamily.Data) (H : ℝ)
+    (x : ThreefoldHomologyFinitenessRetraction.Positive (parameterNorm D)) :
+    parameterNorm D (positiveHeightCutoff D H (1, x)).val ≤ cutoffRadius H :=
+  puncturedHeightCutoff_one_norm_le D H (positivePuncturedHomeomorph D x)
+
+private theorem ThreefoldHomologyFinitenessCusp.positiveHeightCutoff_fixed
+    (D : SpecialPeriods.CuspFamily.Data) (H : ℝ) (t : unitInterval)
+    (x : ThreefoldHomologyFinitenessRetraction.Positive (parameterNorm D))
+    (hx : parameterNorm D x.val < cutoffRadius H) : positiveHeightCutoff D H (t, x) = x := by
+  change
+    (positivePuncturedHomeomorph D).symm
+        (puncturedHeightCutoff D H (t, positivePuncturedHomeomorph D x)) =
+      x
+  rw [puncturedHeightCutoff_fixed D H t _ hx, Homeomorph.symm_apply_apply]
+
+private def
+    ThreefoldHomologyFinitenessCusp.fullSublevelHomotopyEquiv (D : SpecialPeriods.CuspFamily.Data)
+    (δ : ℝ) (hδ : 0 < δ) :
+    FullSpace D ≃ₕ CuspCentralHomology.OpenQuotient D.correction D.radius δ :=
+  ThreefoldHomologyFinitenessRetraction.sublevelHomotopyEquiv (parameterNorm D)
+    (positiveHeightCutoff D (ThreefoldOverlapMappingTorus.Cusp.heightThreshold δ + 1))
+    (cutoffRadius (ThreefoldOverlapMappingTorus.Cusp.heightThreshold δ + 1)) (cutoffRadius_pos _)
+    (positiveHeightCutoff_fixed D _) (positiveHeightCutoff_zero D _)
+    (positiveHeightCutoff_norm_nonincrease D _) δ (cutoffRadius_threshold_lt hδ).le
+    (fun x => (positiveHeightCutoff_one_norm_le D _ x).trans_lt (cutoffRadius_threshold_lt hδ))
+
+private def
+    ThreefoldHomologyFinitenessCusp.fullCentralInclusion (D : SpecialPeriods.CuspFamily.Data) :
+    C(CuspRetraction.QuotientCentralFibre D.correction D.radius, FullSpace D) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private theorem ThreefoldHomologyFinitenessCusp.exists_fullCentralHomotopyEquiv
+    (D : SpecialPeriods.CuspFamily.Data) :
+    ∃ e : CuspRetraction.QuotientCentralFibre D.correction D.radius ≃ₕ FullSpace D,
+      e.toFun = fullCentralInclusion D := by
+  obtain ⟨δ, hδ, hδr, _hδ1, he⟩ :=
+    CuspCentralHomology.exists_centralHomotopyEquiv D.correction D.radius D.radius_pos
+      D.holomorphic
+  obtain ⟨e, he⟩ := he δ hδ le_rfl hδr.le
+  let eR := CuspCentralHomology.openQuotientRadiusHomeomorph D.correction hδr.le D.holomorphic
+  let eF := fullSublevelHomotopyEquiv D δ hδ
+  refine ⟨(e.trans eR.toHomotopyEquiv).trans eF.symm, ?_⟩
+  apply ContinuousMap.ext
+  intro x
+  change (eR (e x)).val = x.val
+  have hx := ContinuousMap.congr_fun he x
+  change e x = eR.symm (CuspCentralHomology.centralIntoOpen D.correction D.radius δ hδ x) at hx
+  rw [hx, Homeomorph.apply_symm_apply]
+  rfl
+
+private def ThreefoldHomologyFinitenessCusp.fullCentralHomotopyEquiv
+    (D : SpecialPeriods.CuspFamily.Data) :
+    CuspRetraction.QuotientCentralFibre D.correction D.radius ≃ₕ FullSpace D :=
+  Classical.choose (exists_fullCentralHomotopyEquiv D)
+
+@[simp]
+private theorem ThreefoldHomologyFinitenessCusp.fullCentralHomotopyEquiv_toFun
+    (D : SpecialPeriods.CuspFamily.Data) :
+    (fullCentralHomotopyEquiv D).toFun = fullCentralInclusion D :=
+  Classical.choose_spec (exists_fullCentralHomotopyEquiv D)
+
+private def
+    ThreefoldHomologyFinitenessCusp.fullCentralHomologyEquiv (D : SpecialPeriods.CuspFamily.Data)
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology
+        (CuspRetraction.QuotientCentralFibre D.correction D.radius) n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (FullSpace D) n :=
+  PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (fullCentralHomotopyEquiv D) n
+
+@[simp]
+private theorem ThreefoldHomologyFinitenessCusp.fullCentralHomologyEquiv_toLinearMap
+    (D : SpecialPeriods.CuspFamily.Data) (n : ℕ) :
+    (fullCentralHomologyEquiv D n).toLinearMap =
+      SingularMayerVietoris.singularHomologyMap (fullCentralInclusion D) n := by
+  change SingularMayerVietoris.singularHomologyMap (fullCentralHomotopyEquiv D).toFun n = _
+  rw [fullCentralHomotopyEquiv_toFun]
+
+private def
+    ThreefoldHomologyFinitenessCusp.fullHomologyCoordinates (D : SpecialPeriods.CuspFamily.Data)
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (FullSpace D) n ≃ₗ[ℤ]
+      (Fin (CuspCentralHomology.centralBetti n) → ℤ) :=
+  (fullCentralHomologyEquiv D n).symm.trans
+    (CuspCentralHomology.centralSingularHomologyEquiv D.correction D.radius D.radius_pos
+      D.holomorphic n)
+
+private theorem
+    ThreefoldHomologyFinitenessCusp.fullHomology_free (D : SpecialPeriods.CuspFamily.Data)
+    (n : ℕ) : Module.Free ℤ (SingularMayerVietoris.SingularHomology (FullSpace D) n) :=
+  Module.Free.of_equiv (fullHomologyCoordinates D n).symm
+
+private theorem
+    ThreefoldHomologyFinitenessCusp.fullHomology_finite (D : SpecialPeriods.CuspFamily.Data)
+    (n : ℕ) : Module.Finite ℤ (SingularMayerVietoris.SingularHomology (FullSpace D) n) :=
+  Module.Finite.of_surjective (fullHomologyCoordinates D n).symm.toLinearMap
+    (fullHomologyCoordinates D n).symm.surjective
+
+private theorem
+    ThreefoldHomologyFinitenessCusp.fullHomology_finrank (D : SpecialPeriods.CuspFamily.Data)
+    (n : ℕ) :
+    Module.finrank ℤ (SingularMayerVietoris.SingularHomology (FullSpace D) n) =
+      CuspCentralHomology.centralBetti n := by
+  rw [(fullHomologyCoordinates D n).finrank_eq]
+  exact Module.finrank_fin_fun ℤ
+
+private theorem ThreefoldHomologyFinitenessCusp.fullHomology_subsingleton_of_four_lt
+    (D : SpecialPeriods.CuspFamily.Data) {n : ℕ} (hn : 4 < n) :
+    Subsingleton (SingularMayerVietoris.SingularHomology (FullSpace D) n) := by
+  have :=
+    CuspCentralHomology.centralSingularHomology_subsingleton_of_four_lt D.correction D.radius
+      D.radius_pos D.holomorphic hn
+  refine ⟨fun a b => (fullCentralHomologyEquiv D n).symm.injective ?_⟩
+  exact Subsingleton.elim _ _
+
+private def CuspCoinvariants.oneDifference : (Fin 4 → ℤ) →ₗ[ℤ] (Fin 4 → ℤ) :=
+  (M₀ - 1).mulVecLin
+
+private def CuspCoinvariants.squareDifference : (Fin 6 → ℤ) →ₗ[ℤ] (Fin 6 → ℤ) :=
+  (PeriodTorusHigherHomologyExterior.squareM₀ - 1).mulVecLin
+
+private def CuspCoinvariants.cubeDifference : (Fin 4 → ℤ) →ₗ[ℤ] (Fin 4 → ℤ) :=
+  (PeriodTorusHigherHomologyExterior.cubeM₀ - 1).mulVecLin
+
+@[simp]
+private theorem CuspCoinvariants.squareDifference_apply (v : Fin 6 → ℤ) :
+    squareDifference v = ![0, v 0, 0, 0, v 0, v 0 + v 1 + v 4] := by
+  ext i
+  fin_cases i <;>
+    simp [squareDifference, PeriodTorusHigherHomologyExterior.squareM₀_eq, dotProduct,
+      Fin.sum_univ_succ]
+  ring
+
+private theorem CuspCoinvariants.cubeM₀_eq_M₀ : PeriodTorusHigherHomologyExterior.cubeM₀ = M₀ := by
+  rw [PeriodTorusHigherHomologyExterior.cubeM₀_eq]
+  rfl
+
+private theorem
+    CuspCoinvariants.cubeDifference_eq_oneDifference : cubeDifference = oneDifference := by
+  rw [cubeDifference, oneDifference, cubeM₀_eq_M₀]
+
+private def CuspCoinvariants.squareProjection : (Fin 6 → ℤ) →ₗ[ℤ] (Fin 4 → ℤ)
+    where
+  toFun v := ![v 0, v 2, v 3, v 4 - v 1]
+  map_add' v
+    w := by
+    ext i
+    fin_cases i <;> simp
+    ring
+  map_smul' c
+    v := by
+    ext i
+    fin_cases i <;> simp
+    ring
+
+private def CuspCoinvariants.squareSection : (Fin 4 → ℤ) →ₗ[ℤ] (Fin 6 → ℤ)
+    where
+  toFun z := ![z 0, 0, z 1, z 2, z 3, 0]
+  map_add' v
+    w := by
+    ext i
+    fin_cases i <;> simp
+  map_smul' c
+    v := by
+    ext i
+    fin_cases i <;> simp
+
+@[simp]
+private theorem CuspCoinvariants.squareProjection_section (z : Fin 4 → ℤ) :
+    squareProjection (squareSection z) = z := by
+  ext i
+  fin_cases i <;> simp [squareProjection, squareSection]
+
+private theorem
+    CuspCoinvariants.squareProjection_surjective : Function.Surjective squareProjection :=
+  fun z => ⟨squareSection z, squareProjection_section z⟩
+
+private theorem CuspCoinvariants.squareDifference_range_iff (v : Fin 6 → ℤ) :
+    v ∈ LinearMap.range squareDifference ↔ v 0 = 0 ∧ v 2 = 0 ∧ v 3 = 0 ∧ v 4 = v 1 := by
+  change (∃ w, squareDifference w = v) ↔ _
+  constructor
+  · rintro ⟨w, rfl⟩
+    simp
+  · rintro ⟨h0, h2, h3, h41⟩
+    refine ⟨![v 1, v 5 - v 1, 0, 0, 0, 0], ?_⟩
+    rw [squareDifference_apply]
+    ext i
+    fin_cases i <;> simp [h0, h2, h3, h41]
+
+private theorem CuspCoinvariants.squareProjection_eq_zero_iff (v : Fin 6 → ℤ) :
+    squareProjection v = 0 ↔ v 0 = 0 ∧ v 2 = 0 ∧ v 3 = 0 ∧ v 4 = v 1 := by
+  constructor
+  · intro h
+    have h0 := congrFun h 0
+    have h1 := congrFun h 1
+    have h2 := congrFun h 2
+    have h3 := congrFun h 3
+    change v 0 = 0 at h0
+    change v 2 = 0 at h1
+    change v 3 = 0 at h2
+    change v 4 - v 1 = 0 at h3
+    exact ⟨h0, h1, h2, sub_eq_zero.mp h3⟩
+  · rintro ⟨h0, h2, h3, h41⟩
+    ext i
+    fin_cases i <;> simp [squareProjection, h0, h2, h3, h41]
+
+private theorem CuspCoinvariants.squareProjection_ker_eq_range :
+    LinearMap.ker squareProjection = LinearMap.range squareDifference := by
+  ext v
+  rw [LinearMap.mem_ker, squareProjection_eq_zero_iff, squareDifference_range_iff]
+
+private def CuspCoinvariants.squareCoinvariantEquiv :
+    ((Fin 6 → ℤ) ⧸ LinearMap.range squareDifference) ≃ₗ[ℤ] (Fin 4 → ℤ) :=
+  (Submodule.quotEquivOfEq _ _ squareProjection_ker_eq_range.symm).trans
+    (squareProjection.quotKerEquivOfSurjective squareProjection_surjective)
+
+private def CuspCoinvariants.oneProjection : (Fin 4 → ℤ) →ₗ[ℤ] (Fin 2 → ℤ)
+    where
+  toFun v := ![v 0, v 1]
+  map_add' v
+    w := by
+    ext i
+    fin_cases i <;> rfl
+  map_smul' c
+    v := by
+    ext i
+    fin_cases i <;> rfl
+
+private def CuspCoinvariants.oneSection : (Fin 2 → ℤ) →ₗ[ℤ] (Fin 4 → ℤ)
+    where
+  toFun z := ![z 0, z 1, 0, 0]
+  map_add' v
+    w := by
+    ext i
+    fin_cases i <;> simp
+  map_smul' c
+    v := by
+    ext i
+    fin_cases i <;> simp
+
+@[simp]
+private theorem CuspCoinvariants.oneProjection_section (z : Fin 2 → ℤ) :
+    oneProjection (oneSection z) = z := by
+  ext i
+  fin_cases i <;> rfl
+
+private theorem
+    CuspCoinvariants.oneProjection_surjective : Function.Surjective oneProjection := fun z =>
+  ⟨oneSection z, oneProjection_section z⟩
+
+private theorem CuspCoinvariants.oneDifference_range_iff (v : Fin 4 → ℤ) :
+    v ∈ LinearMap.range oneDifference ↔ v 0 = 0 ∧ v 1 = 0 :=
+  M₀_sub_one_range v
+
+private theorem CuspCoinvariants.oneProjection_eq_zero_iff (v : Fin 4 → ℤ) :
+    oneProjection v = 0 ↔ v 0 = 0 ∧ v 1 = 0 := by
+  constructor
+  · intro h
+    exact ⟨congrFun h 0, congrFun h 1⟩
+  · rintro ⟨h0, h1⟩
+    ext i
+    fin_cases i <;> simp [oneProjection, h0, h1]
+
+private theorem CuspCoinvariants.oneProjection_ker_eq_range :
+    LinearMap.ker oneProjection = LinearMap.range oneDifference := by
+  ext v
+  rw [LinearMap.mem_ker, oneProjection_eq_zero_iff, oneDifference_range_iff]
+
+private def CuspCoinvariants.oneCoinvariantEquiv :
+    ((Fin 4 → ℤ) ⧸ LinearMap.range oneDifference) ≃ₗ[ℤ] (Fin 2 → ℤ) :=
+  (Submodule.quotEquivOfEq _ _ oneProjection_ker_eq_range.symm).trans
+    (oneProjection.quotKerEquivOfSurjective oneProjection_surjective)
+
+private abbrev CuspCoinvariants.cubeProjection :=
+  oneProjection
+
+private theorem CuspCoinvariants.cubeProjection_surjective : Function.Surjective cubeProjection :=
+  oneProjection_surjective
+
+private theorem CuspCoinvariants.cubeProjection_ker_eq_range :
+    LinearMap.ker cubeProjection = LinearMap.range cubeDifference := by
+  rw [cubeDifference_eq_oneDifference]
+  exact oneProjection_ker_eq_range
+
+private def CuspCoinvariants.cubeCoinvariantEquiv :
+    ((Fin 4 → ℤ) ⧸ LinearMap.range cubeDifference) ≃ₗ[ℤ] (Fin 2 → ℤ) :=
+  (Submodule.quotEquivOfEq _ _ cubeProjection_ker_eq_range.symm).trans
+    (cubeProjection.quotKerEquivOfSurjective cubeProjection_surjective)
+
+private theorem
+    CuspCoinvariants.map_range_of_intertwines {M N : Type*} [AddCommGroup M] [Module ℤ M]
+    [AddCommGroup N] [Module ℤ N] (e : M ≃ₗ[ℤ] N) (A : M →ₗ[ℤ] M) (B : N →ₗ[ℤ] N)
+    (h : ∀ x, e (A x) = B (e x)) : (LinearMap.range A).map e.toLinearMap = LinearMap.range B := by
+  ext y
+  constructor
+  · rintro ⟨x, ⟨z, rfl⟩, rfl⟩
+    exact ⟨e z, (h z).symm⟩
+  · rintro ⟨z, rfl⟩
+    refine ⟨A (e.symm z), ⟨e.symm z, rfl⟩, ?_⟩
+    change e (A (e.symm z)) = B z
+    rw [h, LinearEquiv.apply_symm_apply]
+
+private def CuspCoinvariants.quotientRangeEquiv {M N : Type*} [AddCommGroup M] [Module ℤ M]
+    [AddCommGroup N] [Module ℤ N] (e : M ≃ₗ[ℤ] N) (A : M →ₗ[ℤ] M) (B : N →ₗ[ℤ] N)
+    (h : ∀ x, e (A x) = B (e x)) : (M ⧸ LinearMap.range A) ≃ₗ[ℤ] (N ⧸ LinearMap.range B) := by
+  let q :=
+    Submodule.Quotient.equiv (LinearMap.range A) (LinearMap.range B) e
+      (map_range_of_intertwines e A B h)
+  let qa : (M ⧸ LinearMap.range A) ≃+ (N ⧸ LinearMap.range B) := by
+    letI := Submodule.Quotient.module (LinearMap.range A)
+    letI := Submodule.Quotient.module (LinearMap.range B)
+    exact q.toAddEquiv
+  exact qa.toIntLinearEquiv
+
+public
+theorem CuspCoinvariants.mem_range_iff_of_intertwines {M N : Type*} [AddCommGroup M] [Module ℤ M]
+    [AddCommGroup N] [Module ℤ N] (e : M ≃ₗ[ℤ] N) (A : M →ₗ[ℤ] M) (B : N →ₗ[ℤ] N)
+    (h : ∀ x, e (A x) = B (e x)) (x : M) : x ∈ LinearMap.range A ↔ e x ∈ LinearMap.range B := by
+  constructor
+  · rintro ⟨z, rfl⟩
+    exact ⟨e z, (h z).symm⟩
+  · rintro ⟨z, hz⟩
+    refine ⟨e.symm z, e.injective ?_⟩
+    rw [h, LinearEquiv.apply_symm_apply, hz]
+
+private def CuspCoinvariants.torusDifference (q : ℕ) :
+    SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) q →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) q :=
+  SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀) q -
+    LinearMap.id
+
+@[simp]
+private theorem CuspCoinvariants.torusDifference_apply (q : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) q) :
+    torusDifference q a =
+      SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀) q
+          a -
+        a :=
+  rfl
+
+private theorem CuspCoinvariants.torusDifference_two_coordinates
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 2) :
+    PeriodTorusHigherHomology.coordinateTorusH2Coordinates (torusDifference 2 a) =
+      squareDifference (PeriodTorusHigherHomology.coordinateTorusH2Coordinates a) := by
+  rw [torusDifference_apply, map_sub,
+    PeriodTorusHigherHomology.coordinateTorusH2Coordinates_matrix]
+  simp only [squareDifference, Matrix.mulVecLin_apply, Matrix.sub_mulVec, Matrix.one_mulVec,
+    PeriodTorusHigherHomologyExterior.squareM₀]
+
+private theorem CuspCoinvariants.torusDifference_three_coordinates
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 3) :
+    PeriodTorusHigherHomology.coordinateTorusH3Coordinates (torusDifference 3 a) =
+      cubeDifference (PeriodTorusHigherHomology.coordinateTorusH3Coordinates a) := by
+  rw [torusDifference_apply, map_sub,
+    PeriodTorusHigherHomology.coordinateTorusH3Coordinates_matrix]
+  simp only [cubeDifference, Matrix.mulVecLin_apply, Matrix.sub_mulVec, Matrix.one_mulVec,
+    PeriodTorusHigherHomologyExterior.cubeM₀]
+
+private abbrev CuspCoinvariants.TorusCoinvariants (q : ℕ) :=
+  SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) q ⧸
+    LinearMap.range (torusDifference q)
+
+private def CuspCoinvariants.torusTwoCoinvariantEquiv : TorusCoinvariants 2 ≃ₗ[ℤ] (Fin 4 → ℤ) :=
+  ((quotientRangeEquiv PeriodTorusHigherHomology.coordinateTorusH2Coordinates (torusDifference 2)
+          squareDifference torusDifference_two_coordinates).toAddEquiv.trans
+      squareCoinvariantEquiv.toAddEquiv).toIntLinearEquiv
+
+private def CuspCoinvariants.torusThreeCoinvariantEquiv : TorusCoinvariants 3 ≃ₗ[ℤ] (Fin 2 → ℤ) :=
+  ((quotientRangeEquiv PeriodTorusHigherHomology.coordinateTorusH3Coordinates (torusDifference 3)
+          cubeDifference torusDifference_three_coordinates).toAddEquiv.trans
+      cubeCoinvariantEquiv.toAddEquiv).toIntLinearEquiv
+
+private def CuspCoinvariants.integerLinearMapOfAdd_mo1973_14485 {M N : Type*} [AddCommGroup M]
+    [Module ℤ M] [AddCommGroup N] [Module ℤ N] (g : M →+ N) : M →ₗ[ℤ] N
+    where
+  toFun := g
+  map_add' := g.map_add
+  map_smul' c x := by simpa only [Int.cast_id, RingHom.id_apply] using map_intCast_smul g ℤ ℤ c x
+
+private def
+    CuspCoinvariants.quotientLiftMap {M N : Type*} [AddCommGroup M] [Module ℤ M] [AddCommGroup N]
+    [Module ℤ N] (S : Submodule ℤ M) (f : M →ₗ[ℤ] N) (hS : S ≤ LinearMap.ker f) :
+    (M ⧸ S) →ₗ[ℤ] N :=
+  integerLinearMapOfAdd_mo1973_14485 (S.liftQ f hS).toAddMonoidHom
+
+private theorem CuspCoinvariants.quotientLift_surjective {M N : Type*} [AddCommGroup M] [Module ℤ M]
+    [AddCommGroup N] [Module ℤ N] (S : Submodule ℤ M) (f : M →ₗ[ℤ] N) (hf : Function.Surjective f)
+    (hS : S ≤ LinearMap.ker f) : Function.Surjective (S.liftQ f hS) := by
+  intro y
+  obtain ⟨x, rfl⟩ := hf y
+  exact ⟨Submodule.Quotient.mk x, rfl⟩
+
+private theorem CuspCoinvariants.quotientLift_bijective_of_finrank {M N : Type*} [AddCommGroup M]
+    [Module ℤ M] [AddCommGroup N] [Module ℤ N] [Module.Free ℤ N] [Module.Finite ℤ N]
+    (S : Submodule ℤ M) {r : ℕ} (e : (M ⧸ S) ≃ₗ[ℤ] (Fin r → ℤ)) (f : M →ₗ[ℤ] N)
+    (hf : Function.Surjective f) (hS : S ≤ LinearMap.ker f) (hrank : Module.finrank ℤ N = r) :
+    Function.Bijective (S.liftQ f hS) := by
+  let g : (Fin r → ℤ) →ₗ[ℤ] N := (quotientLiftMap S f hS).comp e.symm.toLinearMap
+  have hgs : Function.Surjective g := (quotientLift_surjective S f hf hS).comp e.symm.surjective
+  have hgb : Function.Bijective g := by
+    apply OrzechProperty.bijective_of_surjective_of_finrank_le g hgs
+    rw [Module.finrank_fin_fun, hrank]
+  refine ⟨?_, quotientLift_surjective S f hf hS⟩
+  intro x y hxy
+  apply e.injective
+  apply hgb.injective
+  change S.liftQ f hS (e.symm (e x)) = S.liftQ f hS (e.symm (e y))
+  simpa only [LinearEquiv.symm_apply_apply] using hxy
+
+private theorem
+    CuspCoinvariants.kernel_eq_of_quotient_equiv {M N : Type*} [AddCommGroup M] [Module ℤ M]
+    [AddCommGroup N] [Module ℤ N] [Module.Free ℤ N] [Module.Finite ℤ N] (S : Submodule ℤ M)
+    {r : ℕ} (e : (M ⧸ S) ≃ₗ[ℤ] (Fin r → ℤ)) (f : M →ₗ[ℤ] N) (hf : Function.Surjective f)
+    (hS : S ≤ LinearMap.ker f) (hrank : Module.finrank ℤ N = r) : LinearMap.ker f = S := by
+  apply le_antisymm ?_ hS
+  intro x hx
+  apply (Submodule.Quotient.mk_eq_zero S).mp
+  apply (quotientLift_bijective_of_finrank S e f hf hS hrank).injective
+  rw [Submodule.liftQ_apply, map_zero]
+  exact hx
+
+private def CuspCoinvariants.exteriorSquareDifference :
+    PeriodTorusHigherHomologyExterior.latticeExterior 2 →ₗ[ℤ]
+      PeriodTorusHigherHomologyExterior.latticeExterior 2 :=
+  exteriorPower.map 2 M₀.mulVecLin - LinearMap.id
+
+private def CuspCoinvariants.exteriorCubeDifference :
+    PeriodTorusHigherHomologyExterior.latticeExterior 3 →ₗ[ℤ]
+      PeriodTorusHigherHomologyExterior.latticeExterior 3 :=
+  exteriorPower.map 3 M₀.mulVecLin - LinearMap.id
+
+private theorem CuspCoinvariants.range_difference_le_ker_of_invariant {M N : Type*} [AddCommGroup M]
+    [Module ℤ M] [AddCommGroup N] [Module ℤ N] (A : M →ₗ[ℤ] M) (f : M →ₗ[ℤ] N)
+    (h : ∀ x, f (A x) = f x) : LinearMap.range (A - LinearMap.id) ≤ LinearMap.ker f := by
+  rintro x ⟨y, rfl⟩
+  change f (A y - y) = 0
+  rw [map_sub, h, sub_self]
+
+private theorem CuspCoinvariants.torusTwo_kernel_eq {N : Type*} [AddCommGroup N] [Module ℤ N]
+    [Module.Free ℤ N] [Module.Finite ℤ N]
+    (f :
+      SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 2 →ₗ[ℤ] N)
+    (hf : Function.Surjective f) (hS : LinearMap.range (torusDifference 2) ≤ LinearMap.ker f)
+    (hrank : Module.finrank ℤ N = 4) : LinearMap.ker f = LinearMap.range (torusDifference 2) :=
+  kernel_eq_of_quotient_equiv _ torusTwoCoinvariantEquiv f hf hS hrank
+
+private theorem CuspCoinvariants.torusThree_kernel_eq {N : Type*} [AddCommGroup N] [Module ℤ N]
+    [Module.Free ℤ N] [Module.Finite ℤ N]
+    (f :
+      SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 3 →ₗ[ℤ] N)
+    (hf : Function.Surjective f) (hS : LinearMap.range (torusDifference 3) ≤ LinearMap.ker f)
+    (hrank : Module.finrank ℤ N = 2) : LinearMap.ker f = LinearMap.range (torusDifference 3) :=
+  kernel_eq_of_quotient_equiv _ torusThreeCoinvariantEquiv f hf hS hrank
+
+private theorem
+    CuspCoinvariants.torusTwo_kernel_eq_of_invariant {N : Type*} [AddCommGroup N] [Module ℤ N]
+    [Module.Free ℤ N] [Module.Finite ℤ N]
+    (f :
+      SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 2 →ₗ[ℤ] N)
+    (hf : Function.Surjective f)
+    (hinv :
+      ∀ x,
+        f
+            (SingularMayerVietoris.singularHomologyMap
+              (PeriodTorusHigherHomology.torusMatrixMap M₀) 2 x) =
+          f x)
+    (hrank : Module.finrank ℤ N = 4) : LinearMap.ker f = LinearMap.range (torusDifference 2) :=
+  torusTwo_kernel_eq f hf (range_difference_le_ker_of_invariant _ f hinv) hrank
+
+private theorem CuspCoinvariants.torusThree_kernel_eq_of_invariant {N : Type*} [AddCommGroup N]
+    [Module ℤ N] [Module.Free ℤ N] [Module.Finite ℤ N]
+    (f :
+      SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 3 →ₗ[ℤ] N)
+    (hf : Function.Surjective f)
+    (hinv :
+      ∀ x,
+        f
+            (SingularMayerVietoris.singularHomologyMap
+              (PeriodTorusHigherHomology.torusMatrixMap M₀) 3 x) =
+          f x)
+    (hrank : Module.finrank ℤ N = 2) : LinearMap.ker f = LinearMap.range (torusDifference 3) :=
+  torusThree_kernel_eq f hf (range_difference_le_ker_of_invariant _ f hinv) hrank
+
+private def
+    ThreefoldHomologyCuspFibre.actualFibreInclusion (D : SpecialPeriods.CuspFamily.Data) (t : ℂ) :
+    C(CuspControlledRetraction.ActualQuotientFibre D.correction D.radius t,
+      ThreefoldHomologyFinitenessCusp.FullSpace D) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/HomologyOfX/SmallChainBiprod.lean b/LeanPool/HopfProblem/HomologyOfX/SmallChainBiprod.lean
new file mode 100644
index 000000000..9f838efb7
--- /dev/null
+++ b/LeanPool/HopfProblem/HomologyOfX/SmallChainBiprod.lean
@@ -0,0 +1,251 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+
+/-!
+# Hopf problem: homology of x · small chain biprod
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem SmallChainBiprod.fst_lift_apply {A B I : ModuleCat.{0} ℤ} (a : I ⟶ A) (b : I ⟶ B)
+    (z : I) :
+    (CategoryTheory.Limits.biprod.fst : A ⊞ B ⟶ A).hom
+        ((CategoryTheory.Limits.biprod.lift a b).hom z) =
+      a.hom z := by
+  exact congrArg (fun f : I ⟶ A => f.hom z) (CategoryTheory.Limits.biprod.lift_fst a b)
+
+private theorem SmallChainBiprod.snd_lift_apply {A B I : ModuleCat.{0} ℤ} (a : I ⟶ A) (b : I ⟶ B)
+    (z : I) :
+    (CategoryTheory.Limits.biprod.snd : A ⊞ B ⟶ B).hom
+        ((CategoryTheory.Limits.biprod.lift a b).hom z) =
+      b.hom z := by
+  exact congrArg (fun f : I ⟶ B => f.hom z) (CategoryTheory.Limits.biprod.lift_snd a b)
+
+private theorem SmallChainBiprod.desc_inl_apply {A B S : ModuleCat.{0} ℤ} (u : A ⟶ S) (v : B ⟶ S)
+    (x : A) :
+    (CategoryTheory.Limits.biprod.desc u v).hom
+        ((CategoryTheory.Limits.biprod.inl : A ⟶ A ⊞ B).hom x) =
+      u.hom x := by
+  exact congrArg (fun f : A ⟶ S => f.hom x) (CategoryTheory.Limits.biprod.inl_desc u v)
+
+private theorem SmallChainBiprod.desc_inr_apply {A B S : ModuleCat.{0} ℤ} (u : A ⟶ S) (v : B ⟶ S)
+    (y : B) :
+    (CategoryTheory.Limits.biprod.desc u v).hom
+        ((CategoryTheory.Limits.biprod.inr : B ⟶ A ⊞ B).hom y) =
+      v.hom y := by
+  exact congrArg (fun f : B ⟶ S => f.hom y) (CategoryTheory.Limits.biprod.inr_desc u v)
+
+private theorem SmallChainBiprod.total_apply {A B : ModuleCat.{0} ℤ} (z : (A ⊞ B : ModuleCat ℤ)) :
+    (CategoryTheory.Limits.biprod.inl : A ⟶ A ⊞ B).hom
+          ((CategoryTheory.Limits.biprod.fst : A ⊞ B ⟶ A).hom z) +
+        (CategoryTheory.Limits.biprod.inr : B ⟶ A ⊞ B).hom
+          ((CategoryTheory.Limits.biprod.snd : A ⊞ B ⟶ B).hom z) =
+      z := by exact congrArg (fun f : A ⊞ B ⟶ A ⊞ B => f.hom z) CategoryTheory.Limits.biprod.total
+
+private theorem SmallChainBiprod.element_ext {A B : ModuleCat.{0} ℤ} {z z' : (A ⊞ B : ModuleCat ℤ)}
+    (hfst :
+      (CategoryTheory.Limits.biprod.fst : A ⊞ B ⟶ A).hom z =
+        (CategoryTheory.Limits.biprod.fst : A ⊞ B ⟶ A).hom z')
+    (hsnd :
+      (CategoryTheory.Limits.biprod.snd : A ⊞ B ⟶ B).hom z =
+        (CategoryTheory.Limits.biprod.snd : A ⊞ B ⟶ B).hom z') :
+    z = z' := by
+  calc
+    z =
+        (CategoryTheory.Limits.biprod.inl : A ⟶ A ⊞ B).hom
+            ((CategoryTheory.Limits.biprod.fst : A ⊞ B ⟶ A).hom z) +
+          (CategoryTheory.Limits.biprod.inr : B ⟶ A ⊞ B).hom
+            ((CategoryTheory.Limits.biprod.snd : A ⊞ B ⟶ B).hom z) :=
+      (total_apply z).symm
+    _ =
+        (CategoryTheory.Limits.biprod.inl : A ⟶ A ⊞ B).hom
+            ((CategoryTheory.Limits.biprod.fst : A ⊞ B ⟶ A).hom z') +
+          (CategoryTheory.Limits.biprod.inr : B ⟶ A ⊞ B).hom
+            ((CategoryTheory.Limits.biprod.snd : A ⊞ B ⟶ B).hom z') := by rw [hfst, hsnd]
+    _ = z' := total_apply z'
+
+private theorem SmallChainBiprod.desc_apply {A B S : ModuleCat.{0} ℤ} (u : A ⟶ S) (v : B ⟶ S)
+    (z : (A ⊞ B : ModuleCat ℤ)) :
+    (CategoryTheory.Limits.biprod.desc u v).hom z =
+      u.hom ((CategoryTheory.Limits.biprod.fst : A ⊞ B ⟶ A).hom z) +
+        v.hom ((CategoryTheory.Limits.biprod.snd : A ⊞ B ⟶ B).hom z) := by
+  calc
+    (CategoryTheory.Limits.biprod.desc u v).hom z =
+        (CategoryTheory.Limits.biprod.desc u v).hom
+          ((CategoryTheory.Limits.biprod.inl : A ⟶ A ⊞ B).hom
+              ((CategoryTheory.Limits.biprod.fst : A ⊞ B ⟶ A).hom z) +
+            (CategoryTheory.Limits.biprod.inr : B ⟶ A ⊞ B).hom
+              ((CategoryTheory.Limits.biprod.snd : A ⊞ B ⟶ B).hom z)) :=
+      congrArg (CategoryTheory.Limits.biprod.desc u v).hom (total_apply z).symm
+    _ = _ := by rw [map_add, desc_inl_apply, desc_inr_apply]
+
+private def
+    SmallChainBiprod.shortComplex {A B I S : ModuleCat.{0} ℤ} (a : I ⟶ A) (b : I ⟶ B) (u : A ⟶ S)
+    (v : B ⟶ S) (w : a ≫ u = b ≫ v) : CategoryTheory.ShortComplex (ModuleCat.{0} ℤ) :=
+  CategoryTheory.ShortComplex.mk (CategoryTheory.Limits.biprod.lift a (-b))
+    (CategoryTheory.Limits.biprod.desc u v)
+    (by
+      rw [CategoryTheory.Limits.biprod.lift_desc, CategoryTheory.Preadditive.neg_comp, w,
+        add_neg_cancel])
+
+private theorem SmallChainBiprod.left_injective {A B I : ModuleCat.{0} ℤ} (a : I ⟶ A) (b : I ⟶ B)
+    (ha : Function.Injective a.hom) :
+    Function.Injective (CategoryTheory.Limits.biprod.lift a (-b)).hom := by
+  intro z z' h
+  apply ha
+  have hf := congrArg (CategoryTheory.Limits.biprod.fst : A ⊞ B ⟶ A).hom h
+  simpa only [fst_lift_apply] using hf
+
+private theorem SmallChainBiprod.right_surjective {A B S : ModuleCat.{0} ℤ} (u : A ⟶ S) (v : B ⟶ S)
+    (hjoint : ∀ s : S, ∃ x : A, ∃ y : B, u.hom x + v.hom y = s) :
+    Function.Surjective (CategoryTheory.Limits.biprod.desc u v).hom := by
+  intro s
+  obtain ⟨x, y, hxy⟩ := hjoint s
+  refine
+    ⟨(CategoryTheory.Limits.biprod.inl : A ⟶ A ⊞ B).hom x +
+        (CategoryTheory.Limits.biprod.inr : B ⟶ A ⊞ B).hom y,
+      ?_⟩
+  simpa only [map_add, desc_inl_apply, desc_inr_apply] using hxy
+
+private theorem
+    SmallChainBiprod.exact {A B I S : ModuleCat.{0} ℤ} (a : I ⟶ A) (b : I ⟶ B) (u : A ⟶ S)
+    (v : B ⟶ S) (w : a ≫ u = b ≫ v)
+    (hoverlap : ∀ (x : A) (y : B), u.hom x = v.hom y → ∃ z : I, a.hom z = x ∧ b.hom z = y) :
+    (shortComplex a b u v w).Exact := by
+  apply (CategoryTheory.ShortComplex.moduleCat_exact_iff _).mpr
+  intro q hq
+  change (CategoryTheory.Limits.biprod.desc u v).hom q = 0 at hq
+  have hsum :
+    u.hom ((CategoryTheory.Limits.biprod.fst : A ⊞ B ⟶ A).hom q) +
+        v.hom ((CategoryTheory.Limits.biprod.snd : A ⊞ B ⟶ B).hom q) =
+      0 :=
+    (desc_apply u v q).symm.trans hq
+  have heq :
+    u.hom ((CategoryTheory.Limits.biprod.fst : A ⊞ B ⟶ A).hom q) =
+      v.hom (-(CategoryTheory.Limits.biprod.snd : A ⊞ B ⟶ B).hom q) := by
+    rw [map_neg]
+    exact eq_neg_iff_add_eq_zero.mpr hsum
+  obtain ⟨z, haz, hbz⟩ := hoverlap _ _ heq
+  refine ⟨z, ?_⟩
+  change (CategoryTheory.Limits.biprod.lift a (-b)).hom z = q
+  apply element_ext
+  · simpa only [fst_lift_apply] using haz
+  · rw [snd_lift_apply]
+    change -b.hom z = (CategoryTheory.Limits.biprod.snd : A ⊞ B ⟶ B).hom q
+    rw [hbz, neg_neg]
+
+private theorem SmallChainBiprod.shortExact {A B I S : ModuleCat.{0} ℤ} (a : I ⟶ A) (b : I ⟶ B)
+    (u : A ⟶ S) (v : B ⟶ S) (w : a ≫ u = b ≫ v) (ha : Function.Injective a.hom)
+    (hjoint : ∀ s : S, ∃ x : A, ∃ y : B, u.hom x + v.hom y = s)
+    (hoverlap : ∀ (x : A) (y : B), u.hom x = v.hom y → ∃ z : I, a.hom z = x ∧ b.hom z = y) :
+    (shortComplex a b u v w).ShortExact
+    where
+  exact := exact a b u v w hoverlap
+  mono_f := (ModuleCat.mono_iff_injective _).mpr (left_injective a b ha)
+  epi_g := (ModuleCat.epi_iff_surjective _).mpr (right_surjective u v hjoint)
+
+private theorem SmallChainBiprod.lift_f_biprodXIso_hom {K L J : ChainComplex (ModuleCat.{0} ℤ) ℕ}
+    (a : J ⟶ K) (b : J ⟶ L) (n : ℕ) :
+    (CategoryTheory.Limits.biprod.lift a b).f n ≫ (HomologicalComplex.biprodXIso K L n).hom =
+      CategoryTheory.Limits.biprod.lift (a.f n) (b.f n) := by
+  apply CategoryTheory.Limits.biprod.hom_ext
+  · simp only [CategoryTheory.Category.assoc, HomologicalComplex.biprodXIso_hom_fst,
+      HomologicalComplex.biprod_lift_fst_f, CategoryTheory.Limits.biprod.lift_fst]
+  · simp only [CategoryTheory.Category.assoc, HomologicalComplex.biprodXIso_hom_snd,
+      HomologicalComplex.biprod_lift_snd_f, CategoryTheory.Limits.biprod.lift_snd]
+
+private theorem SmallChainBiprod.biprodXIso_inv_desc_f {K L T : ChainComplex (ModuleCat.{0} ℤ) ℕ}
+    (u : K ⟶ T) (v : L ⟶ T) (n : ℕ) :
+    (HomologicalComplex.biprodXIso K L n).inv ≫ (CategoryTheory.Limits.biprod.desc u v).f n =
+      CategoryTheory.Limits.biprod.desc (u.f n) (v.f n) := by
+  apply CategoryTheory.Limits.biprod.hom_ext'
+  · simp only [← CategoryTheory.Category.assoc, HomologicalComplex.inl_biprodXIso_inv,
+      HomologicalComplex.biprod_inl_desc_f, CategoryTheory.Limits.biprod.inl_desc]
+  · simp only [← CategoryTheory.Category.assoc, HomologicalComplex.inr_biprodXIso_inv,
+      HomologicalComplex.biprod_inr_desc_f, CategoryTheory.Limits.biprod.inr_desc]
+
+private theorem SmallChainBiprod.biprodXIso_hom_desc_f {K L T : ChainComplex (ModuleCat.{0} ℤ) ℕ}
+    (u : K ⟶ T) (v : L ⟶ T) (n : ℕ) :
+    (HomologicalComplex.biprodXIso K L n).hom ≫
+        CategoryTheory.Limits.biprod.desc (u.f n) (v.f n) =
+      (CategoryTheory.Limits.biprod.desc u v).f n := by
+  rw [← biprodXIso_inv_desc_f u v n, CategoryTheory.Iso.hom_inv_id_assoc]
+
+private def SmallChainBiprod.shortComplexOfComplexes {K L J T : ChainComplex (ModuleCat.{0} ℤ) ℕ}
+    (a : J ⟶ K) (b : J ⟶ L) (u : K ⟶ T) (v : L ⟶ T) (w : a ≫ u = b ≫ v) :
+    CategoryTheory.ShortComplex (ChainComplex (ModuleCat.{0} ℤ) ℕ) :=
+  CategoryTheory.ShortComplex.mk (CategoryTheory.Limits.biprod.lift a (-b))
+    (CategoryTheory.Limits.biprod.desc u v)
+    (by
+      rw [CategoryTheory.Limits.biprod.lift_desc, CategoryTheory.Preadditive.neg_comp, w,
+        add_neg_cancel])
+
+public
+theorem SmallChainBiprod.square_f {K L J T : ChainComplex (ModuleCat.{0} ℤ) ℕ} (a : J ⟶ K)
+    (b : J ⟶ L) (u : K ⟶ T) (v : L ⟶ T) (w : a ≫ u = b ≫ v) (n : ℕ) :
+    a.f n ≫ u.f n = b.f n ≫ v.f n :=
+  congrArg (fun f : J ⟶ T => f.f n) w
+
+private def
+    SmallChainBiprod.shortComplexOfComplexesEvalIso {K L J T : ChainComplex (ModuleCat.{0} ℤ) ℕ}
+    (a : J ⟶ K) (b : J ⟶ L) (u : K ⟶ T) (v : L ⟶ T) (w : a ≫ u = b ≫ v) (n : ℕ) :
+    (shortComplexOfComplexes a b u v w).map
+        (HomologicalComplex.eval (ModuleCat.{0} ℤ) (ComplexShape.down ℕ) n) ≅
+      shortComplex (a.f n) (b.f n) (u.f n) (v.f n) (square_f a b u v w n) := by
+  refine
+    CategoryTheory.ShortComplex.isoMk (CategoryTheory.Iso.refl _)
+      (HomologicalComplex.biprodXIso K L n) (CategoryTheory.Iso.refl _) ?_ ?_
+  · change
+      𝟙 _ ≫ CategoryTheory.Limits.biprod.lift (a.f n) (-(b.f n)) =
+        (CategoryTheory.Limits.biprod.lift a (-b)).f n ≫ (HomologicalComplex.biprodXIso K L n).hom
+    simpa only [CategoryTheory.Category.id_comp, HomologicalComplex.neg_f_apply] using
+      (lift_f_biprodXIso_hom a (-b) n).symm
+  · change
+      (HomologicalComplex.biprodXIso K L n).hom ≫
+          CategoryTheory.Limits.biprod.desc (u.f n) (v.f n) =
+        (CategoryTheory.Limits.biprod.desc u v).f n ≫ 𝟙 _
+    simpa only [CategoryTheory.Category.comp_id] using biprodXIso_hom_desc_f u v n
+
+private theorem SmallChainBiprod.shortExactOfComplexes {K L J T : ChainComplex (ModuleCat.{0} ℤ) ℕ}
+    (a : J ⟶ K) (b : J ⟶ L) (u : K ⟶ T) (v : L ⟶ T) (w : a ≫ u = b ≫ v)
+    (ha : ∀ n : ℕ, Function.Injective (a.f n).hom)
+    (hjoint : ∀ (n : ℕ) (s : T.X n), ∃ x : K.X n, ∃ y : L.X n, (u.f n).hom x + (v.f n).hom y = s)
+    (hoverlap :
+      ∀ (n : ℕ) (x : K.X n) (y : L.X n),
+        (u.f n).hom x = (v.f n).hom y → ∃ z : J.X n, (a.f n).hom z = x ∧ (b.f n).hom z = y) :
+    (shortComplexOfComplexes a b u v w).ShortExact := by
+  apply HomologicalComplex.shortExact_of_degreewise_shortExact
+  intro n
+  exact
+    CategoryTheory.ShortComplex.shortExact_of_iso
+      (shortComplexOfComplexesEvalIso a b u v w n).symm
+      (shortExact (a.f n) (b.f n) (u.f n) (v.f n) (square_f a b u v w n) (ha n) (hjoint n)
+        (hoverlap n))
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/HomologyOfX/ThreefoldGluing1.lean b/LeanPool/HopfProblem/HomologyOfX/ThreefoldGluing1.lean
new file mode 100644
index 000000000..8fc3be34e
--- /dev/null
+++ b/LeanPool/HopfProblem/HomologyOfX/ThreefoldGluing1.lean
@@ -0,0 +1,758 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.CuspFibre.CuspCentralHomology4
+public import LeanPool.HopfProblem.Elliptic.Core3
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.CuspFibre.CuspPositiveRetraction
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology7
+import all LeanPool.HopfProblem.CuspFibre.CuspSpecialization
+import all LeanPool.HopfProblem.HomologyOfX.CuspCoinvariants
+import all LeanPool.HopfProblem.CuspFibre.CuspCentralHomology4
+import all LeanPool.HopfProblem.Elliptic.Core3
+
+/-!
+# Hopf problem: homology of x · threefold gluing 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def
+    ThreefoldHomologyCuspFibre.fibreCentralHomotopy (D : SpecialPeriods.CuspFamily.Data) (η : ℝ)
+    (hη : 0 ≤ η)
+    (R :
+      C(CuspRetraction.ClosedQuotient D.correction D.radius η,
+        CuspRetraction.QuotientCentralFibre D.correction D.radius))
+    (H :
+      (ContinuousMap.id (CuspRetraction.ClosedQuotient D.correction D.radius η)).Homotopy
+        ((CuspRetraction.quotientCentralIntoClosed D.correction D.radius η hη).comp R))
+    (t : ℂ) (htη : ‖t‖ ≤ η) :
+    (actualFibreInclusion D t).Homotopy
+      ((ThreefoldHomologyFinitenessCusp.fullCentralInclusion D).comp
+        (R.comp (CuspCentralHomology.actualFibreIntoClosed D.correction D.radius η t htη)))
+    where
+  toFun
+    p :=
+    (H (p.1, CuspCentralHomology.actualFibreIntoClosed D.correction D.radius η t htη p.2)).val
+  continuous_toFun :=
+    continuous_subtype_val.comp
+      (H.continuous.comp
+        (continuous_fst.prodMk
+          ((CuspCentralHomology.actualFibreIntoClosed D.correction D.radius η t
+                htη).continuous.comp
+            continuous_snd)))
+  map_zero_left
+    q :=
+    congrArg Subtype.val
+      (H.map_zero_left
+        (CuspCentralHomology.actualFibreIntoClosed D.correction D.radius η t htη q))
+  map_one_left
+    q :=
+    congrArg Subtype.val
+      (H.map_one_left (CuspCentralHomology.actualFibreIntoClosed D.correction D.radius η t htη q))
+
+private theorem ThreefoldHomologyCuspFibre.exists_smallFibreInclusion_homology_surjective
+    (D : SpecialPeriods.CuspFamily.Data) :
+    ∃ δ : ℝ,
+      0 < δ ∧
+        δ < D.radius ∧
+          ∀ (t : ℂ),
+            t ≠ 0 →
+              ‖t‖ ≤ δ →
+                ∀ n : ℕ,
+                  Function.Surjective
+                    (SingularMayerVietoris.singularHomologyMap (actualFibreInclusion D t) n) := by
+  obtain ⟨δs, hδs, hδsr, _hδs1, hspec⟩ :=
+    CuspCentralHomology.exists_actual_specialization_homology D.correction D.radius D.radius_pos
+      D.holomorphic
+  obtain ⟨δr, hδr, _hδrr, _hδr1, hret⟩ :=
+    CuspCentralHomology.exists_controlled_retraction_all_levels D.correction D.radius_pos
+      D.holomorphic
+  let δ := Min.min δs δr
+  have hδ : 0 < δ := lt_min hδs hδr
+  have hδradius : δ < D.radius := (min_le_left δs δr).trans_lt hδsr
+  refine ⟨δ, hδ, hδradius, ?_⟩
+  intro t ht htδ n
+  obtain ⟨E, hE⟩ := hspec t ht (htδ.trans (min_le_left δs δr))
+  obtain ⟨hc, _hmarked, hsurj, _h2, _h3⟩ := hE δ (min_le_left δs δr) htδ hδradius
+  let c :
+    C(CuspControlledRetraction.ActualQuotientFibre D.correction D.radius t,
+      CuspRetraction.QuotientCentralFibre D.correction D.radius) :=
+    ⟨CuspControlledRetraction.prescribedActualFibreCollapse D.correction D.radius D.radius_pos
+        hδradius t ht htδ,
+      hc⟩
+  obtain ⟨R, _hR, H, _hmono, hc', hend, _hall⟩ := hret δ hδ (min_le_right δs δr) hδradius t ht htδ
+  have hend' :
+    R.comp (CuspCentralHomology.actualFibreIntoClosed D.correction D.radius δ t htδ) = c := hend
+  have hm :
+    SingularMayerVietoris.singularHomologyMap (actualFibreInclusion D t) n =
+      (SingularMayerVietoris.singularHomologyMap
+            (ThreefoldHomologyFinitenessCusp.fullCentralInclusion D) n).comp
+        (SingularMayerVietoris.singularHomologyMap c n) := by
+    rw [PeriodTorusHigherHomology.homotopy_homologyMap
+        (fibreCentralHomotopy D δ hδ.le R H.toHomotopy t htδ) n,
+      hend', PeriodTorusHigherHomology.singularHomologyMap_comp]
+  rw [hm, ← ThreefoldHomologyFinitenessCusp.fullCentralHomologyEquiv_toLinearMap]
+  exact (ThreefoldHomologyFinitenessCusp.fullCentralHomologyEquiv D n).surjective.comp (hsurj n).1
+
+private def ThreefoldHomologyCuspFibre.heightParameter (D : SpecialPeriods.CuspFamily.Data)
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) : ℂ :=
+  CuspUniformization.exponential
+    (ThreefoldOverlapMappingTorus.Cusp.logPoint D.radius D.radius_pos 0 h)
+
+private theorem
+    ThreefoldHomologyCuspFibre.heightParameter_ne_zero (D : SpecialPeriods.CuspFamily.Data)
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) : heightParameter D h ≠ 0 :=
+  CuspUniformization.exponential_ne_zero _
+
+private theorem ThreefoldHomologyCuspFibre.heightParameter_norm (D : SpecialPeriods.CuspFamily.Data)
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) :
+    ‖heightParameter D h‖ = Real.exp (-2 * Real.pi * (h : ℝ)) := by
+  change
+    ‖CuspUniformization.exponential
+          (ThreefoldOverlapMappingTorus.Cusp.logPoint D.radius D.radius_pos 0 h)‖ =
+      _
+  calc
+    _ =
+        Real.exp
+          (Real.log
+            ‖CuspUniformization.exponential
+                (ThreefoldOverlapMappingTorus.Cusp.logPoint D.radius D.radius_pos 0 h)‖) :=
+      (Real.exp_log (norm_pos_iff.mpr (CuspUniformization.exponential_ne_zero _))).symm
+    _ = _ := by
+      rw [CuspUniformization.log_norm_exponential, ThreefoldOverlapMappingTorus.Cusp.logPoint_im]
+
+private def ThreefoldHomologyCuspFibre.fibreToFull (D : SpecialPeriods.CuspFamily.Data)
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) :
+    C(RealTorus₄, ThreefoldHomologyFinitenessCusp.FullSpace D) :=
+  (⟨Subtype.val, continuous_subtype_val⟩ :
+        C(CuspUniformization.PuncturedQuotient D.correction D.radius,
+          ThreefoldHomologyFinitenessCusp.FullSpace D)).comp
+    (ThreefoldOverlapMappingTorus.Cusp.fibreToPunctured D h)
+
+private theorem
+    ThreefoldHomologyCuspFibre.fibreToFull_projection (D : SpecialPeriods.CuspFamily.Data)
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) (x : RealTorus₄) :
+    CuspQuotient.projection D.correction D.radius (fibreToFull D h x) = heightParameter D h :=
+  ThreefoldOverlapMappingTorus.Cusp.boundaryCylinder_base D h 0 x
+
+private theorem ThreefoldHomologyCuspFibre.fibreToFull_realCoordinates
+    (D : SpecialPeriods.CuspFamily.Data) (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius)
+    (x : RealPlane₄) :
+    fibreToFull D h (standardLattice.mkQ x) =
+      (CuspUniformization.puncturedCuspCover D.correction D.radius
+          ⟨((ThreefoldOverlapMappingTorus.Cusp.logPoint D.radius D.radius_pos 0 h : ℂ),
+              D.periods.periodEquiv
+                (ThreefoldOverlapMappingTorus.Cusp.logPoint D.radius D.radius_pos 0 h) x),
+            (ThreefoldOverlapMappingTorus.Cusp.logPoint D.radius D.radius_pos 0
+                h).property⟩).val :=
+  congrArg Subtype.val (ThreefoldOverlapMappingTorus.Cusp.fibreToPunctured_realCoordinates D h x)
+
+private def ThreefoldHomologyCuspFibre.fibreAtHeight (D : SpecialPeriods.CuspFamily.Data)
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) :
+    C(RealTorus₄,
+      CuspControlledRetraction.ActualQuotientFibre D.correction D.radius (heightParameter D h))
+    where
+  toFun x := ⟨fibreToFull D h x, fibreToFull_projection D h x⟩
+  continuous_toFun := (fibreToFull D h).continuous.subtype_mk _
+
+private theorem
+    ThreefoldHomologyCuspFibre.fibreToPunctured_product (D : SpecialPeriods.CuspFamily.Data)
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) (x : RealTorus₄) :
+    ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D
+        (ThreefoldOverlapMappingTorus.Cusp.fibreToPunctured D h x) =
+      (h,
+        MappingTorus.HomologyCover.fibreInclusion ThreefoldOverlapMappingTorus.Cusp.monodromy
+          x) :=
+  (ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D).apply_symm_apply _
+
+private theorem
+    ThreefoldHomologyCuspFibre.fibreAtHeight_injective (D : SpecialPeriods.CuspFamily.Data)
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) :
+    Function.Injective (fibreAtHeight D h) := by
+  intro x y hxy
+  have hfull : fibreToFull D h x = fibreToFull D h y :=
+    congrArg
+      (fun q :
+          CuspControlledRetraction.ActualQuotientFibre D.correction D.radius
+            (heightParameter D h) =>
+        q.val)
+      hxy
+  have hp :
+    ThreefoldOverlapMappingTorus.Cusp.fibreToPunctured D h x =
+      ThreefoldOverlapMappingTorus.Cusp.fibreToPunctured D h y :=
+    Subtype.ext hfull
+  have hm :=
+    congrArg Prod.snd
+      (congrArg (ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D) hp)
+  rw [fibreToPunctured_product, fibreToPunctured_product] at hm
+  change
+    MappingTorus.mk ThreefoldOverlapMappingTorus.Cusp.monodromy (0, x) =
+      MappingTorus.mk ThreefoldOverlapMappingTorus.Cusp.monodromy (0, y) at hm
+  obtain ⟨k, hk, he⟩ :=
+    (MappingTorus.mk_eq_mk_iff ThreefoldOverlapMappingTorus.Cusp.monodromy _ _).mp hm
+  have hk0 : k = 0 := by
+    have hk' : (k : ℝ) = 0 := by
+      change (0 : ℝ) = 0 + (k : ℝ) at hk
+      linarith
+    exact_mod_cast hk'
+  subst k
+  simpa using he.symm
+
+private theorem
+    ThreefoldHomologyCuspFibre.fibreAtHeight_surjective (D : SpecialPeriods.CuspFamily.Data)
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) :
+    Function.Surjective (fibreAtHeight D h) := by
+  intro q
+  let s := ThreefoldOverlapMappingTorus.Cusp.logPoint D.radius D.radius_pos 0 h
+  have hs : ‖CuspUniformization.exponential (s : ℂ)‖ < D.radius :=
+    (SpecialPeriods.CuspFamily.mem_logBase _ _).mp s.property
+  have hq :
+    q.val ∈
+      Set.range
+        (CuspUniformization.fibreMap D.correction D.radius s hs (D.logarithmic_height s)
+          (D.logarithmic_drift s)) := by
+    rw [CuspUniformization.fibreMap_range]
+    exact q.property
+  obtain ⟨y, hy⟩ := hq
+  obtain ⟨z, rfl⟩ :=
+    (CuspUniformization.periodData D.correction s (D.logarithmic_height s)
+          (D.logarithmic_drift s)).lattice.mkQ_surjective
+      y
+  refine ⟨standardLattice.mkQ ((D.periods.periodEquiv s).symm z), Subtype.ext ?_⟩
+  change fibreToFull D h (standardLattice.mkQ ((D.periods.periodEquiv s).symm z)) = q.val
+  rw [fibreToFull_realCoordinates]
+  change
+    CuspUniformization.fibreCover D.correction D.radius s hs
+        (D.periods.periodEquiv s ((D.periods.periodEquiv s).symm z)) =
+      q.val
+  rw [LinearEquiv.apply_symm_apply]
+  exact hy
+
+private def ThreefoldHomologyCuspFibre.heightFibreHomeomorph (D : SpecialPeriods.CuspFamily.Data)
+    (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) :
+    RealTorus₄ ≃ₜ
+      CuspControlledRetraction.ActualQuotientFibre D.correction D.radius (heightParameter D h) := by
+  letI :=
+    CuspQuotient.quotient_t2Space D.correction D.radius D.radius_pos D.radius_lt_one D.holomorphic
+      D.smallDrift
+  exact
+    Continuous.homeoOfEquivCompactToT2 (f :=
+      Equiv.ofBijective (fibreAtHeight D h)
+        ⟨fibreAtHeight_injective D h, fibreAtHeight_surjective D h⟩)
+      (fibreAtHeight D h).continuous
+
+private theorem ThreefoldHomologyCuspFibre.heightFibreHomeomorph_inclusion
+    (D : SpecialPeriods.CuspFamily.Data) (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) :
+    (actualFibreInclusion D (heightParameter D h)).comp
+        (heightFibreHomeomorph D h : C(RealTorus₄, _)) =
+      fibreToFull D h :=
+  rfl
+
+private def ThreefoldHomologyCuspFibre.fibreHeightHomotopy (D : SpecialPeriods.CuspFamily.Data)
+    (h₀ h₁ : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) :
+    (fibreToFull D h₀).Homotopy (fibreToFull D h₁)
+    where
+  toFun
+    p :=
+    ((ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D).symm
+        (ThreefoldOverlapMappingTorus.Cusp.heightContraction D.radius h₀ (p.1, h₁),
+          MappingTorus.HomologyCover.fibreInclusion ThreefoldOverlapMappingTorus.Cusp.monodromy
+            p.2)).val
+  continuous_toFun :=
+    continuous_subtype_val.comp
+      ((ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D).symm.continuous.comp
+        (((ThreefoldOverlapMappingTorus.Cusp.heightContraction D.radius h₀).continuous.comp
+              (continuous_fst.prodMk continuous_const)).prodMk
+          ((MappingTorus.HomologyCover.fibreInclusion
+                ThreefoldOverlapMappingTorus.Cusp.monodromy).continuous.comp
+            continuous_snd)))
+  map_zero_left
+    x :=
+    congrArg
+      (fun h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius =>
+        ((ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D).symm
+            (h,
+              MappingTorus.HomologyCover.fibreInclusion
+                ThreefoldOverlapMappingTorus.Cusp.monodromy x)).val)
+      ((ThreefoldOverlapMappingTorus.Cusp.heightContraction D.radius h₀).map_zero_left h₁)
+  map_one_left
+    x :=
+    congrArg
+      (fun h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius =>
+        ((ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph D).symm
+            (h,
+              MappingTorus.HomologyCover.fibreInclusion
+                ThreefoldOverlapMappingTorus.Cusp.monodromy x)).val)
+      ((ThreefoldOverlapMappingTorus.Cusp.heightContraction D.radius h₀).map_one_left h₁)
+
+/-- Compatible local pieces and transition maps for gluing a threefold over a base. -/
+public
+structure ThreefoldGluing.Data (B : Type u) [TopologicalSpace B] where
+  /-- The index type of the local pieces. -/
+  J : Type u
+  /-- The open base patch indexed by each local piece. -/
+  patch : J → TopologicalSpace.Opens B
+  cover : TopologicalSpace.IsOpenCover patch
+  /-- The topological space lying over each base patch. -/
+  piece : J → TopCat.{u}
+  /-- The projection from each local piece to the base. -/
+  toBase : ∀ i, C(piece i, B)
+  toBase_mem : ∀ i x, toBase i x ∈ patch i
+  /-- The partial homeomorphism identifying a pair of local pieces. -/
+  transition : ∀ i j, OpenPartialHomeomorph (piece i) (piece j)
+  source_eq : ∀ i j, (transition i j).source = toBase i ⁻¹' (patch j : Set B)
+  self_eq : ∀ i, transition i i = OpenPartialHomeomorph.refl (piece i)
+  symm_eq : ∀ i j, (transition i j).symm = transition j i
+  preserves_base : ∀ i j x, x ∈ (transition i j).source → toBase j (transition i j x) = toBase i x
+  cocycle :
+    ∀ i j k x,
+      x ∈ (transition i j).source →
+        transition i j x ∈ (transition j k).source →
+          transition j k (transition i j x) = transition i k x
+
+public
+theorem ThreefoldGluing.Data.transition_map_source {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) (i j : D.J) {x : D.piece i}
+    (hx : x ∈ (D.transition i j).source) : D.transition i j x ∈ (D.transition j i).source := by
+  rw [← D.symm_eq i j]
+  exact (D.transition i j).map_source hx
+
+public
+theorem ThreefoldGluing.Data.transition_inter {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) (i j k : D.J) {x : D.piece i}
+    (hx : x ∈ (D.transition i j).source) (hk : x ∈ (D.transition i k).source) :
+    D.transition i j x ∈ (D.transition j k).source := by
+  rw [D.source_eq] at hk ⊢
+  change D.toBase j (D.transition i j x) ∈ D.patch k
+  rw [D.preserves_base i j x hx]
+  exact hk
+
+/-- The core `TopCat` gluing datum associated to threefold gluing data. -/
+public
+abbrev ThreefoldGluing.Data.gluingCore {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) : TopCat.GlueData.MkCore
+    where
+  J := D.J
+  U := D.piece
+  V i j := ⟨(D.transition i j).source, (D.transition i j).open_source⟩
+  t i
+    j :=
+    TopCat.ofHom
+      { toFun := fun x => ⟨D.transition i j x, D.transition_map_source i j x.property⟩
+        continuous_toFun := (D.transition i j).continuousOn.domRestrict.subtype_mk _ }
+  V_id i := by apply TopologicalSpace.Opens.ext; simp [D.self_eq]
+  t_id
+    i := by
+    funext x
+    exact
+      Subtype.ext
+        (congrArg (fun e : OpenPartialHomeomorph (D.piece i) (D.piece i) => e x.val)
+          (D.self_eq i))
+  t_inter := by
+    intro i j k x hx
+    exact D.transition_inter i j k x.property hx
+  cocycle i j k x hx := D.cocycle i j k x x.property (D.transition_inter i j k x.property hx)
+
+/-- The `TopCat` gluing datum associated to threefold gluing data. -/
+public
+abbrev ThreefoldGluing.Data.gluing {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) : TopCat.GlueData :=
+  TopCat.GlueData.mk' D.gluingCore
+
+/-- The topological space obtained by gluing the local pieces. -/
+public
+abbrev ThreefoldGluing.Data.Space {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) :=
+  D.gluing.toGlueData.glued
+
+private def
+    ThreefoldGluing.Data.inclusion {B : Type u} [TopologicalSpace B] (D : ThreefoldGluing.Data B)
+    (i : D.J) : D.piece i → D.Space :=
+  D.gluing.toGlueData.ι i
+
+private theorem ThreefoldGluing.Data.inclusion_openEmbedding {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) (i : D.J) : Topology.IsOpenEmbedding (D.inclusion i) :=
+  D.gluing.ι_isOpenEmbedding i
+
+private theorem ThreefoldGluing.Data.inclusion_jointly_surjective {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) (x : D.Space) : ∃ i z, D.inclusion i z = x :=
+  D.gluing.ι_jointly_surjective x
+
+private theorem ThreefoldGluing.Data.inclusion_eq_iff {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) (i j : D.J) (x : D.piece i) (y : D.piece j) :
+    D.inclusion i x = D.inclusion j y ↔ x ∈ (D.transition i j).source ∧ D.transition i j x = y := by
+  refine (D.gluing.ι_eq_iff_rel i j x y).trans ?_
+  constructor
+  · rintro ⟨⟨z, hz⟩, hzx, hzy⟩
+    change z = x at hzx
+    change D.transition i j z = y at hzy
+    subst z
+    exact ⟨hz, hzy⟩
+  · rintro ⟨hx, hxy⟩
+    exact ⟨⟨x, hx⟩, rfl, hxy⟩
+
+private def ThreefoldGluing.Data.representative {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) (x : D.Space) : Σ i, D.piece i :=
+  ⟨(D.inclusion_jointly_surjective x).choose,
+    (D.inclusion_jointly_surjective x).choose_spec.choose⟩
+
+private theorem ThreefoldGluing.Data.inclusion_representative {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) (x : D.Space) :
+    D.inclusion (D.representative x).1 (D.representative x).2 = x :=
+  (D.inclusion_jointly_surjective x).choose_spec.choose_spec
+
+private def
+    ThreefoldGluing.Data.projection {B : Type u} [TopologicalSpace B] (D : ThreefoldGluing.Data B)
+    (x : D.Space) : B :=
+  D.toBase (D.representative x).1 (D.representative x).2
+
+@[simp]
+private theorem ThreefoldGluing.Data.projection_inclusion {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) (i : D.J) (x : D.piece i) :
+    D.projection (D.inclusion i x) = D.toBase i x := by
+  let r := D.representative (D.inclusion i x)
+  have h := (D.inclusion_eq_iff r.1 i r.2 x).mp (D.inclusion_representative _)
+  change D.toBase r.1 r.2 = D.toBase i x
+  rw [← h.2]
+  exact (D.preserves_base r.1 i r.2 h.1).symm
+
+private theorem ThreefoldGluing.Data.projection_continuous {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) : Continuous D.projection := by
+  rw [continuous_def]
+  intro U hU
+  rw [D.gluing.isOpen_iff]
+  change ∀ i : D.J, IsOpen (D.inclusion i ⁻¹' (D.projection ⁻¹' U))
+  intro i
+  convert hU.preimage (D.toBase i).continuous using 1
+  ext x
+  change D.projection (D.inclusion i x) ∈ U ↔ D.toBase i x ∈ U
+  rw [D.projection_inclusion]
+
+private theorem ThreefoldGluing.Data.inclusion_range {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) (i : D.J) :
+    Set.range (D.inclusion i) = D.projection ⁻¹' (D.patch i : Set B) := by
+  ext x
+  constructor
+  · rintro ⟨z, rfl⟩
+    change D.projection (D.inclusion i z) ∈ D.patch i
+    rw [D.projection_inclusion]
+    exact D.toBase_mem i z
+  · intro hx
+    obtain ⟨j, z, rfl⟩ := D.inclusion_jointly_surjective x
+    have hz : z ∈ (D.transition j i).source := by
+      rw [D.source_eq]
+      simpa only [Set.mem_preimage, projection_inclusion] using hx
+    exact ⟨D.transition j i z, ((D.inclusion_eq_iff j i z _).mpr ⟨hz, rfl⟩).symm⟩
+
+private def ThreefoldGluing.Data.localProjection {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) (i : D.J) : C(D.piece i, D.patch i)
+    where
+  toFun x := ⟨D.toBase i x, D.toBase_mem i x⟩
+  continuous_toFun := (D.toBase i).continuous.subtype_mk _
+
+private def ThreefoldGluing.Data.patchHomeomorph {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) (i : D.J) :
+    D.piece i ≃ₜ (D.projection ⁻¹' (D.patch i : Set B)) :=
+  (D.inclusion_openEmbedding i).isEmbedding.toHomeomorph.trans
+    (Homeomorph.setCongr (D.inclusion_range i))
+
+private theorem ThreefoldGluing.Data.patchHomeomorph_projection {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) (i : D.J) (x : D.piece i) :
+    (D.patch i : Set B).restrictPreimage D.projection (D.patchHomeomorph i x) =
+      D.localProjection i x := by
+  apply Subtype.ext
+  exact D.projection_inclusion i x
+
+private instance ThreefoldGluing.Data.spaceT2 {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) [T2Space B] [∀ i, T2Space (D.piece i)] : T2Space D.Space := by
+  constructor
+  intro x y hxy
+  by_cases hb : D.projection x = D.projection y
+  · obtain ⟨i, hi⟩ := D.cover.exists_mem (D.projection x)
+    have hx : x ∈ Set.range (D.inclusion i) := by rw [D.inclusion_range]; exact hi
+    have hy : y ∈ Set.range (D.inclusion i) := by
+      rw [D.inclusion_range]
+      change D.projection y ∈ D.patch i
+      rw [← hb]
+      exact hi
+    obtain ⟨a, rfl⟩ := hx
+    obtain ⟨b, rfl⟩ := hy
+    have hab : a ≠ b := fun h => hxy (congrArg (D.inclusion i) h)
+    obtain ⟨U, V, hU, hV, ha, hb, hUV⟩ := t2_separation hab
+    refine
+      ⟨D.inclusion i '' U, D.inclusion i '' V, (D.inclusion_openEmbedding i).isOpenMap _ hU,
+        (D.inclusion_openEmbedding i).isOpenMap _ hV, Set.mem_image_of_mem _ ha,
+        Set.mem_image_of_mem _ hb, ?_⟩
+    apply Set.disjoint_left.mpr
+    rintro z ⟨a', ha', hza⟩ ⟨b', hb', hzb⟩
+    have hab' := (D.inclusion_openEmbedding i).injective (hza.trans hzb.symm)
+    exact (Set.disjoint_left.mp hUV) ha' (hab'.symm ▸ hb')
+  · obtain ⟨U, V, hU, hV, hx, hy, hUV⟩ := t2_separation hb
+    exact
+      ⟨D.projection ⁻¹' U, D.projection ⁻¹' V, hU.preimage D.projection_continuous,
+        hV.preimage D.projection_continuous, hx, hy, hUV.preimage D.projection⟩
+
+private def ThreefoldGluing.Data.parametrization {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) [∀ i, Nonempty (D.piece i)] (i : D.J) :
+    OpenPartialHomeomorph (D.piece i) D.Space :=
+  (D.inclusion_openEmbedding i).toOpenPartialHomeomorph (D.inclusion i)
+
+@[simp]
+private theorem ThreefoldGluing.Data.parametrization_target {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) [∀ i, Nonempty (D.piece i)] (i : D.J) :
+    (D.parametrization i).target = Set.range (D.inclusion i) := by simp [parametrization]
+
+private theorem ThreefoldGluing.Data.parametrization_transition {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) [∀ i, Nonempty (D.piece i)] (i j : D.J) {x : D.piece i}
+    (hx : D.inclusion i x ∈ Set.range (D.inclusion j)) :
+    x ∈ (D.transition i j).source ∧
+      (D.parametrization j).symm (D.inclusion i x) = D.transition i j x := by
+  obtain ⟨y, hy⟩ := hx
+  have he := (D.inclusion_eq_iff i j x y).mp hy.symm
+  refine ⟨he.1, ?_⟩
+  rw [← hy]
+  exact ((D.inclusion_openEmbedding j).toOpenPartialHomeomorph_left_inv).trans he.2.symm
+
+@[simp]
+private theorem
+    ThreefoldGluing.Data.parametrization_symm_inclusion {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) [∀ i, Nonempty (D.piece i)] (i : D.J) (x : D.piece i) :
+    (D.parametrization i).symm (D.inclusion i x) = x :=
+  (D.parametrization i).left_inv (Set.mem_univ x)
+
+private def
+    ThreefoldGluing.Data.gluedChart {B : Type u} [TopologicalSpace B] (D : ThreefoldGluing.Data B)
+    [∀ i, Nonempty (D.piece i)] {E : Type*} [NormedAddCommGroup E]
+    [∀ i, ChartedSpace E (D.piece i)] (i : D.J) (x : D.piece i) :
+    OpenPartialHomeomorph D.Space E :=
+  (D.parametrization i).symm.trans (chartAt E x)
+
+private theorem ThreefoldGluing.Data.gluedChart_symm {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) [∀ i, Nonempty (D.piece i)] {E : Type*} [NormedAddCommGroup E]
+    [∀ i, ChartedSpace E (D.piece i)] (i : D.J) (x : D.piece i) :
+    ((D.gluedChart i x).symm : E → D.Space) = D.inclusion i ∘ (chartAt E x).symm := by
+  funext z
+  rfl
+
+@[simp]
+private theorem ThreefoldGluing.Data.gluedChart_inclusion {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) [∀ i, Nonempty (D.piece i)] {E : Type*} [NormedAddCommGroup E]
+    [∀ i, ChartedSpace E (D.piece i)] (i : D.J) (x y : D.piece i) :
+    D.gluedChart i x (D.inclusion i y) = chartAt E x y := by
+  change chartAt E x ((D.parametrization i).symm (D.inclusion i y)) = _
+  rw [parametrization_symm_inclusion]
+
+private theorem
+    ThreefoldGluing.Data.gluedChart_inclusion_mem_source {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) [∀ i, Nonempty (D.piece i)] {E : Type*} [NormedAddCommGroup E]
+    [∀ i, ChartedSpace E (D.piece i)] (i : D.J) (x : D.piece i) :
+    D.inclusion i x ∈ (D.gluedChart (E := E) i x).source := by
+  change
+    D.inclusion i x ∈ (D.parametrization i).target ∧
+      (D.parametrization i).symm (D.inclusion i x) ∈ (chartAt E x).source
+  rw [parametrization_target, parametrization_symm_inclusion]
+  exact ⟨Set.mem_range_self x, mem_chart_source E x⟩
+
+@[instance_reducible]
+private def ThreefoldGluing.Data.chartedSpace {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) [∀ i, Nonempty (D.piece i)] {E : Type*} [NormedAddCommGroup E]
+    [∀ i, ChartedSpace E (D.piece i)] : ChartedSpace E D.Space
+    where
+  atlas := Set.range (fun r : Σ i, D.piece i => D.gluedChart (E := E) r.1 r.2)
+  chartAt x := D.gluedChart (D.representative x).1 (D.representative x).2
+  mem_chart_source
+    x := by
+    simpa only [inclusion_representative] using
+      D.gluedChart_inclusion_mem_source (E := E) (D.representative x).1 (D.representative x).2
+  chart_mem_atlas x := Set.mem_range_self (D.representative x)
+
+private theorem ThreefoldGluing.Data.gluedChart_mem_atlas {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) [∀ i, Nonempty (D.piece i)] {E : Type*} [NormedAddCommGroup E]
+    [∀ i, ChartedSpace E (D.piece i)] (i : D.J) (x : D.piece i) :
+    letI := D.chartedSpace (E := E)
+    D.gluedChart i x ∈ atlas E D.Space :=
+  Set.mem_range_self (⟨i, x⟩ : Σ i, D.piece i)
+
+private theorem ThreefoldGluing.Data.gluedChart_transition_apply {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) [∀ i, Nonempty (D.piece i)] {E : Type*} [NormedAddCommGroup E]
+    [∀ i, ChartedSpace E (D.piece i)] (i j : D.J) (x : D.piece i) (y : D.piece j) {z : E}
+    (hz : z ∈ ((D.gluedChart (E := E) i x).symm.trans (D.gluedChart (E := E) j y)).source) :
+    ((D.gluedChart (E := E) i x).symm.trans (D.gluedChart (E := E) j y)) z =
+      chartAt E y (D.transition i j ((chartAt E x).symm z)) := by
+  have hinc : D.inclusion i ((chartAt E x).symm z) ∈ (D.gluedChart (E := E) j y).source := hz.2
+  have hrange : D.inclusion i ((chartAt E x).symm z) ∈ Set.range (D.inclusion j) := by
+    simpa only [OpenPartialHomeomorph.symm_symm, parametrization_target] using hinc.1
+  have he := (D.parametrization_transition i j hrange).2
+  change chartAt E y ((D.parametrization j).symm (D.inclusion i ((chartAt E x).symm z))) = _
+  rw [he]
+
+private theorem ThreefoldGluing.Data.contMDiffOn_of_comp_inclusion {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) [∀ i, Nonempty (D.piece i)] {E : Type*} [NormedAddCommGroup E]
+    [∀ i, ChartedSpace E (D.piece i)] [NormedSpace ℂ E]
+    [∀ i, IsManifold (modelWithCornersSelf ℂ E) ω (D.piece i)] {F H N : Type*}
+    [NormedAddCommGroup F] [NormedSpace ℂ F] [TopologicalSpace H] [TopologicalSpace N]
+    [ChartedSpace H N] (I : ModelWithCorners ℂ F H) (f : D.Space → N) {U : Set D.Space}
+    (hU : IsOpen U)
+    (hf :
+      ∀ i, ContMDiffOn (modelWithCornersSelf ℂ E) I ω (f ∘ D.inclusion i) (D.inclusion i ⁻¹' U)) :
+    letI := D.chartedSpace (E := E)
+    ContMDiffOn (modelWithCornersSelf ℂ E) I ω f U := by
+  have hparam (i : D.J) (z : D.piece i) : D.parametrization i z = D.inclusion i z := rfl
+  let := D.chartedSpace (E := E)
+  intro x hxU
+  apply ContMDiffAt.contMDiffWithinAt
+  rw [contMDiffAt_iff_source]
+  have hx : x ∈ (D.gluedChart (E := E) (D.representative x).1 (D.representative x).2).source :=
+    mem_chart_source E x
+  have hre :
+    D.inclusion (D.representative x).1 ((D.parametrization (D.representative x).1).symm x) = x :=
+    (D.parametrization (D.representative x).1).right_inv hx.1
+  have hpre :
+    (D.parametrization (D.representative x).1).symm x ∈
+      D.inclusion (D.representative x).1 ⁻¹' U := by
+    change D.inclusion _ _ ∈ U
+    rwa [hre]
+  have hlocal :=
+    (hf (D.representative x).1).contMDiffAt
+      ((hU.preimage (D.inclusion_openEmbedding _).continuous).mem_nhds hpre)
+  have hsrc :=
+    (contMDiffAt_iff_source_of_mem_source (I := modelWithCornersSelf ℂ E) (I' := I) hx.2).mp
+      hlocal
+  have hchart : chartAt E x = D.gluedChart (D.representative x).1 (D.representative x).2 := rfl
+  simpa [hparam, extChartAt, OpenPartialHomeomorph.extend, hchart, gluedChart,
+    Function.comp_def] using hsrc
+
+private theorem
+    ThreefoldGluing.Data.gluedChart_transition_holomorphic {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) [∀ i, Nonempty (D.piece i)] {E : Type*} [NormedAddCommGroup E]
+    [∀ i, ChartedSpace E (D.piece i)] [NormedSpace ℂ E]
+    [∀ i, IsManifold (modelWithCornersSelf ℂ E) ω (D.piece i)]
+    (hhol :
+      ∀ i j,
+        ContMDiffOn (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (D.transition i j)
+          (D.transition i j).source)
+    (i j : D.J) (x : D.piece i) (y : D.piece j) :
+    ContDiffOn ℂ ω ((D.gluedChart (E := E) i x).symm.trans (D.gluedChart (E := E) j y))
+      ((D.gluedChart (E := E) i x).symm.trans (D.gluedChart (E := E) j y)).source := by
+  intro z hz
+  have hza : z ∈ (chartAt E x).target := hz.1.1
+  have hinc : D.inclusion i ((chartAt E x).symm z) ∈ (D.gluedChart (E := E) j y).source := hz.2
+  have hrange : D.inclusion i ((chartAt E x).symm z) ∈ Set.range (D.inclusion j) := by
+    simpa only [OpenPartialHomeomorph.symm_symm, parametrization_target] using hinc.1
+  obtain ⟨htr, he⟩ := D.parametrization_transition i j hrange
+  have ha := (chartAt E x).map_target hza
+  have hb : D.transition i j ((chartAt E x).symm z) ∈ (chartAt E y).source := by
+    rw [← he]
+    exact hinc.2
+  have hmid := (hhol i j).contMDiffAt ((D.transition i j).open_source.mem_nhds htr)
+  have hc := ((contMDiffAt_iff_of_mem_source ha hb).mp hmid).2
+  have hc' : ContDiffAt ℂ ω (chartAt E y ∘ D.transition i j ∘ (chartAt E x).symm) z := by
+    simpa [extChartAt, OpenPartialHomeomorph.extend, contDiffWithinAt_univ,
+      (chartAt E x).right_inv hza] using hc
+  apply hc'.contDiffWithinAt.congr_of_mem ?_ hz
+  intro w hw
+  exact D.gluedChart_transition_apply i j x y hw
+
+private theorem ThreefoldGluing.Data.isManifold {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) [∀ i, Nonempty (D.piece i)] {E : Type*} [NormedAddCommGroup E]
+    [∀ i, ChartedSpace E (D.piece i)] [NormedSpace ℂ E]
+    [∀ i, IsManifold (modelWithCornersSelf ℂ E) ω (D.piece i)]
+    (hhol :
+      ∀ i j,
+        ContMDiffOn (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (D.transition i j)
+          (D.transition i j).source) :
+    letI := D.chartedSpace (E := E)
+    IsManifold (modelWithCornersSelf ℂ E) ω D.Space := by
+  let := D.chartedSpace (E := E)
+  apply isManifold_of_contDiffOn
+  rintro e e' ⟨⟨i, x⟩, rfl⟩ ⟨⟨j, y⟩, rfl⟩
+  simpa using D.gluedChart_transition_holomorphic hhol i j x y
+
+private theorem ThreefoldGluing.Data.inclusion_holomorphic {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) [∀ i, Nonempty (D.piece i)] {E : Type*} [NormedAddCommGroup E]
+    [∀ i, ChartedSpace E (D.piece i)] [NormedSpace ℂ E]
+    [∀ i, IsManifold (modelWithCornersSelf ℂ E) ω (D.piece i)]
+    (hhol :
+      ∀ i j,
+        ContMDiffOn (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (D.transition i j)
+          (D.transition i j).source)
+    (i : D.J) :
+    letI := D.chartedSpace (E := E)
+    ContMDiff (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (D.inclusion i) := by
+  let := D.chartedSpace (E := E)
+  let := D.isManifold hhol
+  intro x
+  have he :=
+    IsManifold.subset_maximalAtlas (I := modelWithCornersSelf ℂ E) (n := ω)
+      (D.gluedChart_mem_atlas i x)
+  have ht : chartAt E x x ∈ (D.gluedChart (E := E) i x).target := by
+    simpa only [gluedChart_inclusion] using
+      (D.gluedChart (E := E) i x).map_source (D.gluedChart_inclusion_mem_source i x)
+  have hsymm := contMDiffAt_symm_of_mem_maximalAtlas he ht
+  have hc : ContMDiffAt (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (chartAt E x) x :=
+    contMDiffOn_chart.contMDiffAt ((chartAt E x).open_source.mem_nhds (mem_chart_source E x))
+  apply (hsymm.comp x hc).congr_of_eventuallyEq
+  filter_upwards [(chartAt E x).open_source.mem_nhds (mem_chart_source E x)] with y hy
+  change D.inclusion i y = (D.gluedChart (E := E) i x).symm (chartAt E x y)
+  rw [gluedChart_symm, Function.comp_apply, (chartAt E x).left_inv hy]
+
+private theorem
+    ThreefoldGluing.Data.parametrization_symm_holomorphic {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) [∀ i, Nonempty (D.piece i)] {E : Type*} [NormedAddCommGroup E]
+    [∀ i, ChartedSpace E (D.piece i)] [NormedSpace ℂ E]
+    [∀ i, IsManifold (modelWithCornersSelf ℂ E) ω (D.piece i)]
+    (hhol :
+      ∀ i j,
+        ContMDiffOn (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (D.transition i j)
+          (D.transition i j).source)
+    (i : D.J) :
+    letI := D.chartedSpace (E := E)
+    ContMDiffOn (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (D.parametrization i).symm
+      (D.parametrization i).target := by
+  let := D.chartedSpace (E := E)
+  rw [parametrization_target]
+  apply
+    D.contMDiffOn_of_comp_inclusion (modelWithCornersSelf ℂ E) (D.parametrization i).symm
+      (D.inclusion_openEmbedding i).isOpen_range
+  intro j
+  exact
+    ((hhol j i).mono (fun x hx => (D.parametrization_transition j i hx).1)).congr
+      (fun x hx => (D.parametrization_transition j i hx).2)
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/HomologyOfX/ThreefoldGluing2.lean b/LeanPool/HopfProblem/HomologyOfX/ThreefoldGluing2.lean
new file mode 100644
index 000000000..5c476f01d
--- /dev/null
+++ b/LeanPool/HopfProblem/HomologyOfX/ThreefoldGluing2.lean
@@ -0,0 +1,218 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldGluing1
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+
+/-!
+# Hopf problem: homology of x · threefold gluing 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem ThreefoldGluing.Data.restrictedProjection_eq {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) (i : D.J) :
+    (D.patch i : Set B).restrictPreimage D.projection =
+      D.localProjection i ∘ (D.patchHomeomorph i).symm := by
+  funext x
+  simpa only [Function.comp_apply, Homeomorph.apply_symm_apply] using
+    D.patchHomeomorph_projection i ((D.patchHomeomorph i).symm x)
+
+private theorem ThreefoldGluing.Data.restrictedProjection_proper {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) (i : D.J) (hi : IsProperMap (D.localProjection i)) :
+    IsProperMap ((D.patch i : Set B).restrictPreimage D.projection) := by
+  rw [D.restrictedProjection_eq]
+  exact hi.comp (D.patchHomeomorph i).symm.isProperMap
+
+private theorem
+    ThreefoldGluing.Data.projection_fibre_eq_localImage {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) (i : D.J) (b : D.patch i) :
+    D.projection ⁻¹' {(b : B)} = D.inclusion i '' (D.localProjection i ⁻¹' { b }) := by
+  ext x
+  constructor
+  · intro hx
+    change D.projection x = (b : B) at hx
+    have hi : x ∈ Set.range (D.inclusion i) := by
+      rw [D.inclusion_range]
+      change D.projection x ∈ D.patch i
+      rw [hx]
+      exact b.property
+    obtain ⟨z, rfl⟩ := hi
+    refine ⟨z, ?_, rfl⟩
+    change D.localProjection i z = b
+    apply Subtype.ext
+    exact (D.projection_inclusion i z).symm.trans hx
+  · rintro ⟨z, hz, rfl⟩
+    change D.localProjection i z = b at hz
+    change D.projection (D.inclusion i z) = (b : B)
+    exact (D.projection_inclusion i z).trans (congrArg Subtype.val hz)
+
+private theorem ThreefoldGluing.Data.projection_fibre_compact {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) (hproper : ∀ i : D.J, IsProperMap (D.localProjection i))
+    (b : B) : IsCompact (D.projection ⁻¹' { b }) := by
+  obtain ⟨i, hi⟩ := D.cover.exists_mem b
+  rw [D.projection_fibre_eq_localImage i ⟨b, hi⟩]
+  exact
+    ((hproper i).isCompact_preimage isCompact_singleton).image
+      (D.inclusion_openEmbedding i).continuous
+
+private theorem ThreefoldGluing.Data.projection_proper {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) (hproper : ∀ i : D.J, IsProperMap (D.localProjection i)) :
+    IsProperMap D.projection := by
+  apply isProperMap_iff_isClosedMap_and_compact_fibers.mpr
+  refine ⟨D.projection_continuous, ?_, D.projection_fibre_compact hproper⟩
+  apply D.cover.isClosedMap_iff_restrictPreimage.mpr
+  intro i
+  exact (D.restrictedProjection_proper i (hproper i)).isClosedMap
+
+private theorem ThreefoldGluing.Data.compactSpace {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) [CompactSpace B]
+    (hproper : ∀ i : D.J, IsProperMap (D.localProjection i)) : CompactSpace D.Space := by
+  constructor
+  simpa only [Set.preimage_univ] using
+    (D.projection_proper hproper).isCompact_preimage
+      (isCompact_univ : IsCompact (Set.univ : Set B))
+
+public
+theorem ThreefoldGluing.Data.secondCountableSpace_of_compactBase {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) [CompactSpace B] [∀ i, SecondCountableTopology (D.piece i)] :
+    SecondCountableTopology D.Space := by
+  classical
+  obtain ⟨s, hs⟩ := D.cover.exists_finite_of_compactSpace
+  let : ∀ i : s, SecondCountableTopology (Set.range (D.inclusion i.val)) := fun i =>
+    (D.inclusion_openEmbedding i.val).isEmbedding.toHomeomorph.symm.secondCountableTopology
+  apply
+    TopologicalSpace.secondCountableTopology_of_countable_cover (U := fun i : s =>
+      Set.range (D.inclusion i.val)) (fun i => (D.inclusion_openEmbedding i.val).isOpen_range)
+  apply Set.eq_univ_of_forall
+  intro x
+  obtain ⟨i, hi⟩ := hs.exists_mem (D.projection x)
+  refine Set.mem_iUnion.mpr ⟨i, ?_⟩
+  rw [D.inclusion_range]
+  exact hi
+
+private def
+    ThreefoldGluing.Data.Compatible {B : Type u} [TopologicalSpace B] (D : ThreefoldGluing.Data B)
+    {Y : Type*} (f : ∀ i, D.piece i → Y) : Prop :=
+  ∀ i j x, x ∈ (D.transition i j).source → f j (D.transition i j x) = f i x
+
+private def
+    ThreefoldGluing.Data.descend {B : Type u} [TopologicalSpace B] (D : ThreefoldGluing.Data B)
+    {Y : Type*} (f : ∀ i, D.piece i → Y) (_hf : D.Compatible f) (x : D.Space) : Y :=
+  f (D.representative x).1 (D.representative x).2
+
+@[simp]
+private theorem ThreefoldGluing.Data.descend_inclusion {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) {Y : Type*} (f : ∀ i, D.piece i → Y) (hf : D.Compatible f)
+    (i : D.J) (x : D.piece i) : D.descend f hf (D.inclusion i x) = f i x := by
+  let r := D.representative (D.inclusion i x)
+  have h := (D.inclusion_eq_iff r.1 i r.2 x).mp (D.inclusion_representative _)
+  change f r.1 r.2 = f i x
+  rw [← h.2]
+  exact (hf r.1 i r.2 h.1).symm
+
+private def ThreefoldGluing.Data.liftedPatch {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) (i : D.J) : TopologicalSpace.Opens D.Space :=
+  ⟨D.projection ⁻¹' (D.patch i : Set B), (D.patch i).isOpen.preimage D.projection_continuous⟩
+
+private theorem ThreefoldGluing.Data.patchHomeomorph_symm_eq_parametrization {B : Type u}
+    [TopologicalSpace B] (D : ThreefoldGluing.Data B) [∀ i, Nonempty (D.piece i)] (i : D.J)
+    (x : D.liftedPatch i) : (D.patchHomeomorph i).symm x = (D.parametrization i).symm x.val := by
+  have hx : D.inclusion i ((D.patchHomeomorph i).symm x) = x.val :=
+    congrArg Subtype.val ((D.patchHomeomorph i).apply_symm_apply x)
+  rw [← hx, D.parametrization_symm_inclusion]
+
+private def ThreefoldGluing.Data.patchBiholomorph {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) [∀ i, Nonempty (D.piece i)] {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [∀ i, ChartedSpace E (D.piece i)]
+    [∀ i, IsManifold (modelWithCornersSelf ℂ E) ω (D.piece i)]
+    (hhol :
+      ∀ i j,
+        ContMDiffOn (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (D.transition i j)
+          (D.transition i j).source)
+    (i : D.J) :
+    letI := D.chartedSpace (E := E)
+    Diffeomorph (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) (D.piece i)
+      (D.liftedPatch i) ω := by
+  letI := D.chartedSpace (E := E)
+  let e : D.piece i ≃ₜ D.liftedPatch i := D.patchHomeomorph i
+  refine
+    { toEquiv := e.toEquiv
+      contMDiff_toFun := ?_
+      contMDiff_invFun := ?_ }
+  · intro x
+    have he :
+      ContMDiffAt (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω
+          (fun z : D.piece i => ((e z).val : D.Space)) x ↔
+        ContMDiffAt (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω e x :=
+      ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+    exact he.mp ((D.inclusion_holomorphic hhol i) x)
+  · intro x
+    have hx : x.val ∈ (D.parametrization i).target := by
+      rw [D.parametrization_target, D.inclusion_range]
+      exact x.property
+    have h :=
+      ((D.parametrization_symm_holomorphic hhol i).contMDiffAt
+            ((D.parametrization i).open_target.mem_nhds hx)).comp
+        x contMDiff_subtype_val.contMDiffAt
+    convert h using 1
+    funext y
+    exact D.patchHomeomorph_symm_eq_parametrization i y
+
+private theorem ThreefoldGluing.Data.projection_fibre_isConnected {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B)
+    (hlocal : ∀ i (b : D.patch i), IsConnected (D.localProjection i ⁻¹' { b })) (b : B) :
+    IsConnected (D.projection ⁻¹' { b }) := by
+  obtain ⟨i, hi⟩ := D.cover.exists_mem b
+  rw [D.projection_fibre_eq_localImage i ⟨b, hi⟩]
+  exact
+    (hlocal i ⟨b, hi⟩).image (D.inclusion i) (D.inclusion_openEmbedding i).continuous.continuousOn
+
+private theorem ThreefoldGluing.Data.projection_surjective_of_connected_fibres {B : Type u}
+    [TopologicalSpace B] (D : ThreefoldGluing.Data B)
+    (hlocal : ∀ i (b : D.patch i), IsConnected (D.localProjection i ⁻¹' { b })) :
+    Function.Surjective D.projection := by
+  intro b
+  obtain ⟨x, hx⟩ := (D.projection_fibre_isConnected hlocal b).nonempty
+  exact ⟨x, hx⟩
+
+private theorem ThreefoldGluing.Data.connectedSpace {B : Type u} [TopologicalSpace B]
+    (D : ThreefoldGluing.Data B) [ConnectedSpace B]
+    (hproper : ∀ i : D.J, IsProperMap (D.localProjection i))
+    (hlocal : ∀ i (b : D.patch i), IsConnected (D.localProjection i ⁻¹' { b })) :
+    ConnectedSpace D.Space := by
+  have hq : Topology.IsQuotientMap D.projection :=
+    (D.projection_proper hproper).isClosedMap.isQuotientMap D.projection_continuous
+      (D.projection_surjective_of_connected_fibres hlocal)
+  apply connectedSpace_iff_univ.mpr
+  simpa only [Set.preimage_univ] using
+    hq.isCoinducing.isConnected_preimage_of_isClosed (D.projection_fibre_isConnected hlocal)
+      isClosed_univ (isConnected_univ : IsConnected (Set.univ : Set B))
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/HomologyOfX/ThreefoldHomology1.lean b/LeanPool/HopfProblem/HomologyOfX/ThreefoldHomology1.lean
new file mode 100644
index 000000000..f5c897e5c
--- /dev/null
+++ b/LeanPool/HopfProblem/HomologyOfX/ThreefoldHomology1.lean
@@ -0,0 +1,189 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Threefold.SpecialPeriods8
+public import LeanPool.HopfProblem.Recognition.Smale6
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.CuspFibre.CuspSpecialization
+import all LeanPool.HopfProblem.HomologyOfX.CuspCoinvariants
+import all LeanPool.HopfProblem.PeriodFamily.Core2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldGluing1
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods8
+import all LeanPool.HopfProblem.Recognition.Smale6
+
+/-!
+# Hopf problem: homology of x · threefold homology 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def ThreefoldHomology.originalPatchHomeomorph (i : SpecialPeriods.Threefold.Index) :
+    SpecialPeriods.Threefold.localPiece i ≃ₜ SpecialPeriods.Threefold.liftedPatch i :=
+  SpecialPeriods.Threefold.gluingData.patchHomeomorph i
+
+private def ThreefoldHomology.originalRegularPatchHomeomorph :
+    SpecialPeriods.Threefold.SpecialRegularFamily ≃ₜ
+      SpecialPeriods.Threefold.liftedPatch Option.none :=
+  originalPatchHomeomorph Option.none
+
+private def ThreefoldHomology.originalPieceInclusion (i : SpecialPeriods.Threefold.Index) :
+    C(SpecialPeriods.Threefold.localPiece i, SpecialPeriods.Threefold.Space) :=
+  ⟨SpecialPeriods.Threefold.inclusion i,
+    (SpecialPeriods.Threefold.inclusion_openEmbedding i).continuous⟩
+
+private def ThreefoldHomology.originalRegularInclusion :
+    C(SpecialPeriods.Threefold.SpecialRegularFamily, SpecialPeriods.Threefold.Space) :=
+  originalPieceInclusion Option.none
+
+private def ThreefoldHomology.overlapToRegularFamily (i : SpecialPeriods.Threefold.Puncture) :
+    C(SpecialPeriods.Threefold.RegularOverlap i, SpecialPeriods.Threefold.SpecialRegularFamily) :=
+  (originalRegularPatchHomeomorph.symm :
+        C(SpecialPeriods.Threefold.liftedPatch Option.none,
+          SpecialPeriods.Threefold.SpecialRegularFamily)).comp
+    (ContinuousMap.inclusion
+      (Set.inter_subset_left :
+        (SpecialPeriods.Threefold.liftedPatch Option.none : Set SpecialPeriods.Threefold.Space) ∩
+            SpecialPeriods.Threefold.liftedPatch (Option.some i) ⊆
+          SpecialPeriods.Threefold.liftedPatch Option.none))
+
+private def ThreefoldHomology.overlapToFilling (i : SpecialPeriods.Threefold.Puncture) :
+    C(SpecialPeriods.Threefold.RegularOverlap i,
+      SpecialPeriods.Threefold.localPiece (Option.some i)) :=
+  ((originalPatchHomeomorph (Option.some i)).symm :
+        C(SpecialPeriods.Threefold.liftedPatch (Option.some i),
+          SpecialPeriods.Threefold.localPiece (Option.some i))).comp
+    (SpecialPeriods.Threefold.overlapFillingInclusion i)
+
+@[simp]
+private theorem
+    ThreefoldHomology.inclusion_overlapToRegularFamily (i : SpecialPeriods.Threefold.Puncture)
+    (x : SpecialPeriods.Threefold.RegularOverlap i) :
+    SpecialPeriods.Threefold.inclusion Option.none (overlapToRegularFamily i x) = x.val :=
+  congrArg Subtype.val (originalRegularPatchHomeomorph.apply_symm_apply ⟨x.val, x.property.1⟩)
+
+@[simp]
+private theorem ThreefoldHomology.inclusion_overlapToFilling (i : SpecialPeriods.Threefold.Puncture)
+    (x : SpecialPeriods.Threefold.RegularOverlap i) :
+    SpecialPeriods.Threefold.inclusion (Option.some i) (overlapToFilling i x) = x.val :=
+  congrArg Subtype.val
+    ((originalPatchHomeomorph (Option.some i)).apply_symm_apply ⟨x.val, x.property.2⟩)
+
+public
+theorem ThreefoldHomology.exact_of_linearEquiv_squares {A B C A' B' C' : Type*} [AddCommGroup A]
+    [Module ℤ A] [AddCommGroup B] [Module ℤ B] [AddCommGroup C] [Module ℤ C] [AddCommGroup A']
+    [Module ℤ A'] [AddCommGroup B'] [Module ℤ B'] [AddCommGroup C'] [Module ℤ C'] (f : A →ₗ[ℤ] B)
+    (g : B →ₗ[ℤ] C) (f' : A' →ₗ[ℤ] B') (g' : B' →ₗ[ℤ] C') (eA : A ≃ₗ[ℤ] A') (eB : B ≃ₗ[ℤ] B')
+    (eC : C ≃ₗ[ℤ] C') (hf : f'.comp eA.toLinearMap = eB.toLinearMap.comp f)
+    (hg : g'.comp eB.toLinearMap = eC.toLinearMap.comp g) (hexact : Function.Exact f g) :
+    Function.Exact f' g' := by
+  intro b
+  constructor
+  · intro hb
+    have hgb : g (eB.symm b) = 0 := by
+      apply eC.injective
+      have h := LinearMap.congr_fun hg (eB.symm b)
+      change g' (eB (eB.symm b)) = eC (g (eB.symm b)) at h
+      rw [LinearEquiv.apply_symm_apply, hb] at h
+      exact h.symm.trans (map_zero eC).symm
+    obtain ⟨a, ha⟩ := (hexact (eB.symm b)).mp hgb
+    refine ⟨eA a, ?_⟩
+    have h := LinearMap.congr_fun hf a
+    change f' (eA a) = eB (f a) at h
+    exact h.trans ((congrArg eB ha).trans (eB.apply_symm_apply b))
+  · rintro ⟨a', rfl⟩
+    obtain ⟨a, rfl⟩ := eA.surjective a'
+    have hfa := LinearMap.congr_fun hf a
+    change f' (eA a) = eB (f a) at hfa
+    rw [hfa]
+    have hga := LinearMap.congr_fun hg (f a)
+    change g' (eB (f a)) = eC (g (f a)) at hga
+    rw [hga, hexact.apply_apply_eq_zero, map_zero]
+
+private theorem
+    ThreefoldHomologyCuspFibre.exists_smallHeight (D : SpecialPeriods.CuspFamily.Data) {δ : ℝ}
+    (hδ : 0 < δ) :
+    ∃ h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius, ‖heightParameter D h‖ < δ := by
+  let h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius :=
+    ⟨Max.max (ThreefoldOverlapMappingTorus.Cusp.heightThreshold D.radius)
+          (ThreefoldOverlapMappingTorus.Cusp.heightThreshold δ) +
+        1,
+      by
+      change
+        ThreefoldOverlapMappingTorus.Cusp.heightThreshold D.radius <
+          Max.max (ThreefoldOverlapMappingTorus.Cusp.heightThreshold D.radius)
+              (ThreefoldOverlapMappingTorus.Cusp.heightThreshold δ) +
+            1
+      exact (le_max_left _ _).trans_lt (lt_add_one _)⟩
+  refine ⟨h, ?_⟩
+  have hh : ThreefoldOverlapMappingTorus.Cusp.heightThreshold δ + 1 ≤ (h : ℝ) := by
+    change
+      ThreefoldOverlapMappingTorus.Cusp.heightThreshold δ + 1 ≤
+        Max.max (ThreefoldOverlapMappingTorus.Cusp.heightThreshold D.radius)
+            (ThreefoldOverlapMappingTorus.Cusp.heightThreshold δ) +
+          1
+    linarith [le_max_right (ThreefoldOverlapMappingTorus.Cusp.heightThreshold D.radius)
+        (ThreefoldOverlapMappingTorus.Cusp.heightThreshold δ)]
+  rw [heightParameter_norm]
+  calc
+    Real.exp (-2 * Real.pi * (h : ℝ)) ≤
+        Real.exp (-2 * Real.pi * (ThreefoldOverlapMappingTorus.Cusp.heightThreshold δ + 1)) :=
+      Real.exp_le_exp.mpr (by nlinarith [Real.pi_pos])
+    _ < δ := ThreefoldHomologyFinitenessCusp.cutoffRadius_threshold_lt hδ
+
+private theorem
+    ThreefoldHomologyCuspFibre.fibreToFull_homology_eq (D : SpecialPeriods.CuspFamily.Data)
+    (h₀ h₁ : ThreefoldOverlapMappingTorus.Cusp.Height D.radius) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (fibreToFull D h₀) n =
+      SingularMayerVietoris.singularHomologyMap (fibreToFull D h₁) n :=
+  PeriodTorusHigherHomology.homotopy_homologyMap (fibreHeightHomotopy D h₀ h₁) n
+
+private theorem ThreefoldHomologyCuspFibre.fibreToFull_homology_surjective
+    (D : SpecialPeriods.CuspFamily.Data) (h : ThreefoldOverlapMappingTorus.Cusp.Height D.radius)
+    (n : ℕ) :
+    Function.Surjective (SingularMayerVietoris.singularHomologyMap (fibreToFull D h) n) := by
+  obtain ⟨δ, hδ, _hδr, hsmall⟩ := exists_smallFibreInclusion_homology_surjective D
+  obtain ⟨h', hh'⟩ := exists_smallHeight D hδ
+  rw [fibreToFull_homology_eq D h h' n, ← heightFibreHomeomorph_inclusion,
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+  exact
+    (hsmall (heightParameter D h') (heightParameter_ne_zero D h') hh'.le n).comp
+      (PeriodTorusHigherHomology.homeomorphHomologyEquiv (heightFibreHomeomorph D h')
+          n).surjective
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/HomologyOfX/ThreefoldHomology2.lean b/LeanPool/HopfProblem/HomologyOfX/ThreefoldHomology2.lean
new file mode 100644
index 000000000..c21dbdb91
--- /dev/null
+++ b/LeanPool/HopfProblem/HomologyOfX/ThreefoldHomology2.lean
@@ -0,0 +1,208 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Threefold.SpecialPeriods9
+public import LeanPool.HopfProblem.Foundations.SplitGroupExtension
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.Lattice.Core2
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import all LeanPool.HopfProblem.Elliptic.Core3
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldGluing1
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods8
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology1
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen2
+import all LeanPool.HopfProblem.Elliptic.Core5
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods9
+import all LeanPool.HopfProblem.Foundations.SplitGroupExtension
+
+/-!
+# Hopf problem: homology of x · threefold homology 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem ThreefoldHomologyCuspFibre.specialFibreToPiece_eq :
+    ThreefoldOverlapMappingTorus.Cusp.specialFibreToPiece =
+      fibreToFull ThreefoldOverlapMappingTorus.Cusp.specialData
+        ThreefoldOverlapMappingTorus.Cusp.specialHeight :=
+  rfl
+
+private theorem ThreefoldHomologyCuspFibre.fibreToFilling_eq :
+    ThreefoldOverlapMappingTorus.fibreToFilling Option.none =
+      ThreefoldOverlapMappingTorus.Cusp.specialFibreToPiece := by
+  rw [ThreefoldOverlapMappingTorus.fibreToFilling,
+    ThreefoldOverlapMappingTorus.boundaryToFilling_cusp]
+  rfl
+
+private theorem ThreefoldHomologyCuspFibre.fibreToFilling_homology_surjective (n : ℕ) :
+    Function.Surjective
+      (SingularMayerVietoris.singularHomologyMap
+        (ThreefoldOverlapMappingTorus.fibreToFilling Option.none) n) := by
+  rw [fibreToFilling_eq, specialFibreToPiece_eq]
+  exact
+    fibreToFull_homology_surjective ThreefoldOverlapMappingTorus.Cusp.specialData
+      ThreefoldOverlapMappingTorus.Cusp.specialHeight n
+
+private theorem ThreefoldHomologyCuspFibre.boundaryFillingHomologyMap_surjective (n : ℕ) :
+    Function.Surjective (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none n) :=
+  by
+  intro a
+  obtain ⟨b, hb⟩ := fibreToFilling_homology_surjective n a
+  refine
+    ⟨SingularMayerVietoris.singularHomologyMap
+        (MappingTorus.HomologyCover.fibreInclusion
+          (ThreefoldOverlapMappingTorus.monodromy Option.none))
+        n b,
+      ?_⟩
+  exact
+    (LinearMap.congr_fun
+          (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap_fibre Option.none n) b).trans
+      hb
+
+private def ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv (j : Elliptic.Kind)
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.Threefold.localPiece (Option.some (Option.some j))) n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.EllipticFilling.SpecialCentralSurface j) n :=
+  (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+      (SpecialPeriods.Threefold.EllipticGeometry.pieceSurfaceHomotopyEquiv j) n).symm
+
+private def ThreefoldHomology.Finiteness.ellipticPieceHomologyEquiv (j : Elliptic.Kind) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.Threefold.localPiece (Option.some (Option.some j))) n ≃ₗ[ℤ]
+      (Fin (Elliptic.HigherHomology.ellipticBettiNumber n) → ℤ) :=
+  (ellipticPieceRetractionHomologyEquiv j n).trans
+    (SpecialPeriods.EllipticFilling.specialCentralSurfaceHomologyCoordinates j n)
+
+private theorem
+    ThreefoldHomology.Finiteness.ellipticPieceHomology_free (j : Elliptic.Kind) (n : ℕ) :
+    Module.Free ℤ
+      (SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.Threefold.localPiece (Option.some (Option.some j))) n) :=
+  Module.Free.of_equiv (ellipticPieceHomologyEquiv j n).symm
+
+private theorem
+    ThreefoldHomology.Finiteness.ellipticPieceHomology_finite (j : Elliptic.Kind) (n : ℕ) :
+    Module.Finite ℤ
+      (SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.Threefold.localPiece (Option.some (Option.some j))) n) :=
+  Module.Finite.of_surjective (ellipticPieceHomologyEquiv j n).symm.toLinearMap
+    (ellipticPieceHomologyEquiv j n).symm.surjective
+
+private theorem
+    ThreefoldHomology.Finiteness.ellipticPieceHomology_finrank (j : Elliptic.Kind) (n : ℕ) :
+    Module.finrank ℤ
+        (SingularMayerVietoris.SingularHomology
+          (SpecialPeriods.Threefold.localPiece (Option.some (Option.some j))) n) =
+      Elliptic.HigherHomology.ellipticBettiNumber n := by
+  rw [(ellipticPieceHomologyEquiv j n).finrank_eq]
+  simp
+
+private theorem ThreefoldHomology.Finiteness.ellipticPieceHomology_subsingleton (j : Elliptic.Kind)
+    {n : ℕ} (hn : 4 < n) :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.Threefold.localPiece (Option.some (Option.some j))) n) := by
+  have : Subsingleton (Fin (Elliptic.HigherHomology.ellipticBettiNumber n) → ℤ) := by
+    rw [Elliptic.HigherHomology.ellipticBettiNumber_eq_zero_of_lt hn]
+    infer_instance
+  exact (ellipticPieceHomologyEquiv j n).injective.subsingleton
+
+private def ThreefoldHomology.BoundaryFirst.latticeMonodromy : Option Elliptic.Kind → LatticeMatrix
+  | none => M₀
+  | some j => j.matrix
+
+private def ThreefoldHomology.BoundaryFirst.latticeDifference (i : Option Elliptic.Kind) :
+    Lattice →ₗ[ℤ] Lattice :=
+  -((latticeMonodromy i - 1).mulVecLin)
+
+private theorem ThreefoldHomology.BoundaryFirst.latticeDifference_apply (i : Option Elliptic.Kind)
+    (w : Lattice) : latticeDifference i w = w - latticeMonodromy i *ᵥ w := by
+  simp [latticeDifference]
+
+private def ThreefoldHomology.BoundaryFirst.cuspCoinvariantMap : Lattice →ₗ[ℤ] (Fin 2 → ℤ)
+    where
+  toFun w := ![w 0, w 1]
+  map_add' w z := by ext k; fin_cases k <;> rfl
+  map_smul' a w := by ext k; fin_cases k <;> rfl
+
+/-- The lattice coinvariant map for a cusp or elliptic boundary component. -/
+public
+def ThreefoldHomology.BoundaryFirst.latticeCoinvariantMap :
+    Option Elliptic.Kind → Lattice →ₗ[ℤ] (Fin 2 → ℤ)
+  | none => cuspCoinvariantMap
+  | some j => Elliptic.coinvariantMap j
+
+public
+theorem ThreefoldHomology.BoundaryFirst.latticeCoinvariantMap_surjective
+    (i : Option Elliptic.Kind) : Function.Surjective (latticeCoinvariantMap i) := by
+  cases i with
+  | none =>
+    intro c
+    refine ⟨![c 0, c 1, 0, 0], ?_⟩
+    ext k
+    fin_cases k <;> rfl
+  | some j => exact Elliptic.coinvariantMap_surjective j
+
+private theorem ThreefoldHomology.BoundaryFirst.latticeDifference_range (i : Option Elliptic.Kind) :
+    LinearMap.range (latticeDifference i) = LinearMap.ker (latticeCoinvariantMap i) := by
+  rw [latticeDifference, LinearMap.range_neg]
+  cases i with
+  | none =>
+    ext w
+    change (∃ v : Lattice, (M₀ - 1) *ᵥ v = w) ↔ cuspCoinvariantMap w = 0
+    rw [M₀_sub_one_range]
+    constructor
+    · rintro ⟨h0, h1⟩
+      ext k
+      fin_cases k <;> assumption
+    · intro h
+      exact ⟨congrFun h 0, congrFun h 1⟩
+  | some j => exact (Elliptic.coinvariantMap_ker_eq_range j).symm
+
+private def ThreefoldHomology.BoundaryFirst.latticeCokernelEquiv (i : Option Elliptic.Kind) :
+    (Lattice ⧸ LinearMap.range (latticeDifference i)) ≃ₗ[ℤ] (Fin 2 → ℤ) :=
+  (Submodule.quotEquivOfEq _ _ (latticeDifference_range i)).trans
+    ((latticeCoinvariantMap i).quotKerEquivOfSurjective (latticeCoinvariantMap_surjective i))
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/HomologyOfX/ThreefoldHomology3.lean b/LeanPool/HopfProblem/HomologyOfX/ThreefoldHomology3.lean
new file mode 100644
index 000000000..c4427acb1
--- /dev/null
+++ b/LeanPool/HopfProblem/HomologyOfX/ThreefoldHomology3.lean
@@ -0,0 +1,5440 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.HomologyOfX.ThreefoldHomologyStarCoproduct
+public import LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology5
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology4
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap1
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+import all LeanPool.HopfProblem.Lattice.Core2
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods3
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology7
+import all LeanPool.HopfProblem.CuspFibre.CuspSpecialization
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods6
+import all LeanPool.HopfProblem.HomologyOfX.CuspCoinvariants
+import all LeanPool.HopfProblem.PeriodFamily.Core2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import all LeanPool.HopfProblem.Elliptic.Core3
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods8
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology1
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen2
+import all LeanPool.HopfProblem.Elliptic.Core5
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods9
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology2
+import all LeanPool.HopfProblem.Pi1.ThreefoldOverlapMappingTorus2
+import all LeanPool.HopfProblem.PeriodFamily.Core3
+import all LeanPool.HopfProblem.HomologyOfX.TrianglePeriodFamilyHomologyAlgebra
+import all LeanPool.HopfProblem.PeriodFamily.Core4
+import all LeanPool.HopfProblem.HomologyOfX.TrianglePeriodFamilyHomologyLattice
+import all LeanPool.HopfProblem.PeriodFamily.Core5
+import all LeanPool.HopfProblem.Elliptic.Core7
+import all LeanPool.HopfProblem.PeriodFamily.Core6
+import all LeanPool.HopfProblem.PeriodFamily.Core7
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods11
+import all LeanPool.HopfProblem.Elliptic.Core8
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology5
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldHomologyStarCoproduct
+
+/-!
+# Hopf problem: homology of x · threefold homology 3
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem ThreefoldHomology.Finiteness.regularHomology_free (n : ℕ) :
+    Module.Free ℤ
+      (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily n) :=
+  PeriodFamily.Canonical.specialRegularHomology_free n
+
+private theorem ThreefoldHomology.Finiteness.regularHomology_finite (n : ℕ) :
+    Module.Finite ℤ
+      (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily n) :=
+  PeriodFamily.Canonical.specialRegularHomology_finite n
+
+private theorem ThreefoldHomology.Finiteness.regularHomology_finrank (n : ℕ) :
+    Module.finrank ℤ
+        (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily n) =
+      PeriodFamily.Homology.familyBetti n :=
+  PeriodFamily.Canonical.specialRegularHomology_finrank n
+
+private theorem ThreefoldHomology.Finiteness.regularHomology_isZero {n : ℕ} (hn : 5 < n) :
+    CategoryTheory.Limits.IsZero
+      (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily n) :=
+  PeriodFamily.Canonical.specialRegularHomology_isZero_of_lt hn
+
+private theorem ThreefoldHomology.Finiteness.regularHomology_subsingleton {n : ℕ} (hn : 5 < n) :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily n) :=
+  ModuleCat.isZero_iff_subsingleton.mp (regularHomology_isZero hn)
+
+private theorem
+    ThreefoldHomologyFinitenessAlgebra.noetherian_of_exact {B H C : Type u} [AddCommGroup B]
+    [AddCommGroup H] [AddCommGroup C] [Module ℤ B] [Module ℤ H] [Module ℤ C] (f : B →ₗ[ℤ] H)
+    (g : H →ₗ[ℤ] C) (h : Function.Exact f g) [Module.Finite ℤ B] [Module.Finite ℤ C] :
+    IsNoetherian ℤ H :=
+  isNoetherian_of_range_eq_ker f g h.linearMap_ker_eq.symm
+
+private theorem ThreefoldHomologyFinitenessAlgebra.finite_of_exact {B H C : Type u} [AddCommGroup B]
+    [AddCommGroup H] [AddCommGroup C] [Module ℤ B] [Module ℤ H] [Module ℤ C] (f : B →ₗ[ℤ] H)
+    (g : H →ₗ[ℤ] C) (h : Function.Exact f g) [Module.Finite ℤ B] [Module.Finite ℤ C] :
+    Module.Finite ℤ H := by
+  have := noetherian_of_exact f g h
+  infer_instance
+
+private theorem
+    ThreefoldHomologyFinitenessAlgebra.eq_zero_of_exact {B H C : Type u} [AddCommGroup B]
+    [AddCommGroup H] [AddCommGroup C] [Module ℤ B] [Module ℤ H] [Module ℤ C] (f : B →ₗ[ℤ] H)
+    (g : H →ₗ[ℤ] C) (h : Function.Exact f g) [Subsingleton B] [Subsingleton C] (a : H) : a = 0 := by
+  obtain ⟨b, hb⟩ := (h a).mp (Subsingleton.elim (g a) 0)
+  exact hb.symm.trans ((congrArg f (Subsingleton.elim b 0)).trans (map_zero f))
+
+public
+theorem
+    ThreefoldHomologyFinitenessAlgebra.subsingleton_of_exact {B H C : Type u} [AddCommGroup B]
+    [AddCommGroup H] [AddCommGroup C] [Module ℤ B] [Module ℤ H] [Module ℤ C] (f : B →ₗ[ℤ] H)
+    (g : H →ₗ[ℤ] C) (h : Function.Exact f g) [Subsingleton B] [Subsingleton C] : Subsingleton H :=
+  ⟨fun a b => (eq_zero_of_exact f g h a).trans (eq_zero_of_exact f g h b).symm⟩
+
+private theorem
+    ThreefoldHomologyFinitenessMappingTorus.fibre_wang_exact (f : RealTorus₄ ≃ₜ RealTorus₄)
+    (n : ℕ) :
+    Function.Exact (MappingTorusHomology.fibreHomologyMap f (n + 1))
+      (MappingTorusHomology.wangBoundary f n) :=
+  LinearMap.exact_iff.mpr (MappingTorusHomology.wang_exact_at_mappingTorus f n).symm
+
+private theorem
+    ThreefoldHomologyFinitenessMappingTorus.homology_finite (f : RealTorus₄ ≃ₜ RealTorus₄)
+    (n : ℕ) : Module.Finite ℤ (SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) n) :=
+  by
+  cases n with
+  | zero =>
+    let := PeriodTorusHigherHomology.realTorus_homology_finite 0
+    exact
+      Module.Finite.of_surjective (MappingTorusHomology.fibreHomologyMap f 0)
+        (MappingTorusHomology.fibreHomologyMap_zero_surjective f)
+  | succ n =>
+    let := PeriodTorusHigherHomology.realTorus_homology_finite (n + 1)
+    let := PeriodTorusHigherHomology.realTorus_homology_finite n
+    exact
+      ThreefoldHomologyFinitenessAlgebra.finite_of_exact
+        (MappingTorusHomology.fibreHomologyMap f (n + 1)) (MappingTorusHomology.wangBoundary f n)
+        (fibre_wang_exact f n)
+
+private theorem ThreefoldHomologyFinitenessMappingTorus.homology_subsingleton_of_lt
+    (f : RealTorus₄ ≃ₜ RealTorus₄) {n : ℕ} (hn : 5 < n) :
+    Subsingleton (SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) n) := by
+  cases n with
+  | zero => omega
+  | succ
+    n =>
+    let := PeriodTorusHigherHomology.realTorus_homology_subsingleton_of_lt (n := n + 1) (by omega)
+    let := PeriodTorusHigherHomology.realTorus_homology_subsingleton_of_lt (n := n) (by omega)
+    exact
+      ThreefoldHomologyFinitenessAlgebra.subsingleton_of_exact
+        (MappingTorusHomology.fibreHomologyMap f (n + 1)) (MappingTorusHomology.wangBoundary f n)
+        (fibre_wang_exact f n)
+
+private abbrev ThreefoldHomology.StarOverlapHomology (n : ℕ) :=
+  ∀ i : SpecialPeriods.Threefold.Puncture,
+    SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) n
+
+private abbrev ThreefoldHomology.StarFillingHomology (n : ℕ) :=
+  ∀ i : SpecialPeriods.Threefold.Puncture,
+    SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.localPiece (Option.some i)) n
+
+private abbrev ThreefoldHomology.StarPairHomology (n : ℕ) :=
+  SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily n ×
+    StarFillingHomology n
+
+private def ThreefoldHomology.starOverlapToRegularHomologyMap (n : ℕ) :
+    StarOverlapHomology n →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily n
+    where
+  toFun
+    a :=
+    ∑ i : SpecialPeriods.Threefold.Puncture,
+      SingularMayerVietoris.singularHomologyMap (overlapToRegularFamily i) n (a i)
+  map_add' a b := by simp only [Pi.add_apply, map_add, Finset.sum_add_distrib]
+  map_smul' r
+    a := by
+    simp only [Pi.smul_apply, map_zsmul, Finset.smul_sum, RingHom.id_apply]
+    apply Finset.sum_congr rfl
+    intro i _
+    exact (int_smul_eq_zsmul ..).symm
+
+private def ThreefoldHomology.starOverlapToFillingsHomologyMap (n : ℕ) :
+    StarOverlapHomology n →ₗ[ℤ] StarFillingHomology n
+    where
+  toFun a i := SingularMayerVietoris.singularHomologyMap (overlapToFilling i) n (a i)
+  map_add' a b := by ext i; exact map_add _ _ _
+  map_smul' r
+    a := by
+    ext i
+    simp only [Pi.smul_apply, map_zsmul, RingHom.id_apply]
+
+private def ThreefoldHomology.starLeftHomologyMap (n : ℕ) :
+    StarOverlapHomology n →ₗ[ℤ] StarPairHomology n :=
+  ((starOverlapToRegularHomologyMap n).toAddMonoidHom.prod
+      (-(starOverlapToFillingsHomologyMap n).toAddMonoidHom)).toIntLinearMap
+
+private def ThreefoldHomology.starFillingsToSpaceHomologyMap (n : ℕ) :
+    StarFillingHomology n →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space n
+    where
+  toFun
+    a :=
+    ∑ i : SpecialPeriods.Threefold.Puncture,
+      SingularMayerVietoris.singularHomologyMap (originalPieceInclusion (Option.some i)) n (a i)
+  map_add' a b := by simp only [Pi.add_apply, map_add, Finset.sum_add_distrib]
+  map_smul' r
+    a := by
+    simp only [Pi.smul_apply, map_zsmul, Finset.smul_sum, RingHom.id_apply]
+    apply Finset.sum_congr rfl
+    intro i _
+    exact (int_smul_eq_zsmul ..).symm
+
+private def ThreefoldHomology.starRightHomologyMap (n : ℕ) :
+    StarPairHomology n →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space n := by
+  let f :=
+    (SingularMayerVietoris.singularHomologyMap originalRegularInclusion n).toAddMonoidHom.coprod
+      (starFillingsToSpaceHomologyMap n).toAddMonoidHom
+  exact
+    { toFun := f
+      map_add' := f.map_add
+      map_smul' r
+        a := by
+        convert! f.map_zsmul r a using 1
+        exact int_smul_eq_zsmul .. }
+
+@[simp]
+private theorem ThreefoldHomology.starOverlapToRegularHomologyMap_apply (n : ℕ)
+    (a : StarOverlapHomology n) :
+    starOverlapToRegularHomologyMap n a =
+      ∑ i : SpecialPeriods.Threefold.Puncture,
+        SingularMayerVietoris.singularHomologyMap (overlapToRegularFamily i) n (a i) :=
+  rfl
+
+@[simp]
+private theorem ThreefoldHomology.starLeftHomologyMap_apply (n : ℕ) (a : StarOverlapHomology n) :
+    starLeftHomologyMap n a =
+      (∑ i : SpecialPeriods.Threefold.Puncture,
+          SingularMayerVietoris.singularHomologyMap (overlapToRegularFamily i) n (a i),
+        fun i => -SingularMayerVietoris.singularHomologyMap (overlapToFilling i) n (a i)) :=
+  rfl
+
+@[simp]
+private theorem ThreefoldHomology.starFillingsToSpaceHomologyMap_apply (n : ℕ)
+    (a : StarFillingHomology n) :
+    starFillingsToSpaceHomologyMap n a =
+      ∑ i : SpecialPeriods.Threefold.Puncture,
+        SingularMayerVietoris.singularHomologyMap (originalPieceInclusion (Option.some i)) n
+          (a i) :=
+  rfl
+
+private theorem ThreefoldHomology.starLeftHomologyMap_single (n : ℕ)
+    (i : SpecialPeriods.Threefold.Puncture)
+    (a : SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) n) :
+    starLeftHomologyMap n (Pi.single i a) =
+      (SingularMayerVietoris.singularHomologyMap (overlapToRegularFamily i) n a,
+        Pi.single i (-SingularMayerVietoris.singularHomologyMap (overlapToFilling i) n a)) := by
+  rw [starLeftHomologyMap_apply]
+  apply Prod.ext
+  · rw [Finset.sum_eq_single i]
+    · rw [Pi.single_eq_same]
+    · intro j _ hji
+      rw [Pi.single_eq_of_ne hji, map_zero]
+    · simp
+  · funext j
+    by_cases h : j = i
+    · subst j
+      simp
+    · simp [Pi.single_eq_of_ne h]
+
+private theorem ThreefoldHomology.starRightHomologyMap_single (n : ℕ)
+    (i : SpecialPeriods.Threefold.Puncture)
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily n)
+    (b :
+      SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.localPiece (Option.some i))
+        n) :
+    starRightHomologyMap n (a, Pi.single i b) =
+      SingularMayerVietoris.singularHomologyMap originalRegularInclusion n a +
+        SingularMayerVietoris.singularHomologyMap (originalPieceInclusion (Option.some i)) n b := by
+  change
+    SingularMayerVietoris.singularHomologyMap originalRegularInclusion n a +
+        starFillingsToSpaceHomologyMap n (Pi.single i b) =
+      _
+  rw [starFillingsToSpaceHomologyMap_apply, Finset.sum_eq_single i]
+  · rw [Pi.single_eq_same]
+  · intro j _ hji
+    rw [Pi.single_eq_of_ne hji, map_zero]
+  · simp
+
+private def ThreefoldHomology.Finiteness.cuspPieceHomologyEquiv (n : ℕ) :
+    SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.Threefold.localPiece (Option.some Option.none)) n ≃ₗ[ℤ]
+      (Fin (CuspCentralHomology.centralBetti n) → ℤ) :=
+  ThreefoldHomologyFinitenessCusp.fullHomologyCoordinates
+    ThreefoldOverlapMappingTorus.Cusp.specialData n
+
+private theorem ThreefoldHomology.Finiteness.cuspPieceHomology_free (n : ℕ) :
+    Module.Free ℤ
+      (SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.Threefold.localPiece (Option.some Option.none)) n) :=
+  Module.Free.of_equiv (cuspPieceHomologyEquiv n).symm
+
+private theorem ThreefoldHomology.Finiteness.cuspPieceHomology_finite (n : ℕ) :
+    Module.Finite ℤ
+      (SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.Threefold.localPiece (Option.some Option.none)) n) :=
+  Module.Finite.of_surjective (cuspPieceHomologyEquiv n).symm.toLinearMap
+    (cuspPieceHomologyEquiv n).symm.surjective
+
+private theorem ThreefoldHomology.Finiteness.cuspPieceHomology_finrank (n : ℕ) :
+    Module.finrank ℤ
+        (SingularMayerVietoris.SingularHomology
+          (SpecialPeriods.Threefold.localPiece (Option.some Option.none)) n) =
+      CuspCentralHomology.centralBetti n := by
+  rw [(cuspPieceHomologyEquiv n).finrank_eq]
+  exact Module.finrank_fin_fun ℤ
+
+private theorem ThreefoldHomology.Finiteness.cuspPieceHomology_subsingleton {n : ℕ} (hn : 4 < n) :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.Threefold.localPiece (Option.some Option.none)) n) :=
+  ThreefoldHomologyFinitenessCusp.fullHomology_subsingleton_of_four_lt
+    ThreefoldOverlapMappingTorus.Cusp.specialData hn
+
+private theorem ThreefoldHomology.Finiteness.fillingHomology_finite
+    (i : SpecialPeriods.Threefold.Puncture) (n : ℕ) :
+    Module.Finite ℤ
+      (SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.Threefold.localPiece (Option.some i)) n) := by
+  cases i with
+  | none => exact cuspPieceHomology_finite n
+  | some j => exact ellipticPieceHomology_finite j n
+
+private theorem ThreefoldHomology.Finiteness.fillingHomology_subsingleton
+    (i : SpecialPeriods.Threefold.Puncture) {n : ℕ} (hn : 4 < n) :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.Threefold.localPiece (Option.some i)) n) := by
+  cases i with
+  | none => exact cuspPieceHomology_subsingleton hn
+  | some j => exact ellipticPieceHomology_subsingleton j hn
+
+private theorem ThreefoldHomology.Finiteness.overlapHomology_finite
+    (i : SpecialPeriods.Threefold.Puncture) (n : ℕ) :
+    Module.Finite ℤ
+      (SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) n) := by
+  have :=
+    ThreefoldHomologyFinitenessMappingTorus.homology_finite
+      (ThreefoldOverlapMappingTorus.monodromy i) n
+  exact
+    Module.Finite.of_surjective
+      (ThreefoldOverlapMappingTorus.overlapHomologyEquiv i n).symm.toLinearMap
+      (ThreefoldOverlapMappingTorus.overlapHomologyEquiv i n).symm.surjective
+
+private theorem ThreefoldHomology.Finiteness.overlapHomology_subsingleton
+    (i : SpecialPeriods.Threefold.Puncture) {n : ℕ} (hn : 5 < n) :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) n) := by
+  have :=
+    ThreefoldHomologyFinitenessMappingTorus.homology_subsingleton_of_lt
+      (ThreefoldOverlapMappingTorus.monodromy i) hn
+  refine ⟨fun a b => (ThreefoldOverlapMappingTorus.overlapHomologyEquiv i n).injective ?_⟩
+  exact Subsingleton.elim _ _
+
+private theorem ThreefoldHomology.Finiteness.starFillingHomology_finite (n : ℕ) :
+    Module.Finite ℤ (ThreefoldHomology.StarFillingHomology n) := by
+  have :
+    ∀ i : SpecialPeriods.Threefold.Puncture,
+      Module.Finite ℤ
+        (SingularMayerVietoris.SingularHomology
+          (SpecialPeriods.Threefold.localPiece (Option.some i)) n) :=
+    fun i => fillingHomology_finite i n
+  exact
+    finite_pi_int
+      (fun i : SpecialPeriods.Threefold.Puncture =>
+        SingularMayerVietoris.SingularHomology
+          (SpecialPeriods.Threefold.localPiece (Option.some i)) n)
+
+private theorem ThreefoldHomology.Finiteness.starOverlapHomology_finite (n : ℕ) :
+    Module.Finite ℤ (ThreefoldHomology.StarOverlapHomology n) := by
+  have :
+    ∀ i : SpecialPeriods.Threefold.Puncture,
+      Module.Finite ℤ
+        (SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) n) :=
+    fun i => overlapHomology_finite i n
+  exact
+    finite_pi_int
+      (fun i : SpecialPeriods.Threefold.Puncture =>
+        SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) n)
+
+private theorem ThreefoldHomology.Finiteness.starPairHomology_finite (n : ℕ) :
+    Module.Finite ℤ (ThreefoldHomology.StarPairHomology n) := by
+  have := regularHomology_finite n
+  have := starFillingHomology_finite n
+  exact
+    finite_prod_int
+      (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily n)
+      (ThreefoldHomology.StarFillingHomology n)
+
+private theorem ThreefoldHomology.Finiteness.starFillingHomology_subsingleton {n : ℕ} (hn : 4 < n) :
+    Subsingleton (ThreefoldHomology.StarFillingHomology n) := by
+  have :
+    ∀ i : SpecialPeriods.Threefold.Puncture,
+      Subsingleton
+        (SingularMayerVietoris.SingularHomology
+          (SpecialPeriods.Threefold.localPiece (Option.some i)) n) :=
+    fun i => fillingHomology_subsingleton i hn
+  infer_instance
+
+private theorem ThreefoldHomology.Finiteness.starOverlapHomology_subsingleton {n : ℕ} (hn : 5 < n) :
+    Subsingleton (ThreefoldHomology.StarOverlapHomology n) := by
+  have :
+    ∀ i : SpecialPeriods.Threefold.Puncture,
+      Subsingleton
+        (SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) n) :=
+    fun i => overlapHomology_subsingleton i hn
+  infer_instance
+
+private theorem ThreefoldHomology.Finiteness.starPairHomology_subsingleton {n : ℕ} (hn : 5 < n) :
+    Subsingleton (ThreefoldHomology.StarPairHomology n) := by
+  have := regularHomology_subsingleton hn
+  have := starFillingHomology_subsingleton (by omega : 4 < n)
+  infer_instance
+
+private def ThreefoldHomology.disjointOpenUnionHomeomorph {ι X : Type*} [TopologicalSpace X]
+    (U : ι → TopologicalSpace.Opens X)
+    (h : Pairwise (fun i j => Disjoint (U i : Set X) (U j : Set X))) :
+    (Σ i, U i) ≃ₜ (⋃ i, (U i : Set X)) := by
+  refine
+    (Equiv.ofBijective _
+          (Set.sigmaToiUnion_bijective (fun i => (U i : Set X)) h)).toHomeomorphOfContinuousOpen
+      ?_ ?_
+  · exact continuous_sigma (fun i => continuous_subtype_val.subtype_mk _)
+  · exact isOpenMap_sigma.mpr (fun i => (U i).isOpen.isOpenMap_subtype_val.subtype_mk _)
+
+private def
+    ThreefoldHomology.starFillings : TopologicalSpace.Opens SpecialPeriods.Threefold.Space :=
+  ⟨⋃ i : SpecialPeriods.Threefold.Puncture,
+      (SpecialPeriods.Threefold.liftedPatch (Option.some i) : Set SpecialPeriods.Threefold.Space),
+    isOpen_iUnion (fun i => (SpecialPeriods.Threefold.liftedPatch (Option.some i)).isOpen)⟩
+
+private def ThreefoldHomology.starOverlap : TopologicalSpace.Opens SpecialPeriods.Threefold.Space :=
+  SpecialPeriods.Threefold.liftedPatch Option.none ⊓ starFillings
+
+@[simp]
+private theorem ThreefoldHomology.mem_starFillings (x : SpecialPeriods.Threefold.Space) :
+    x ∈ starFillings ↔
+      ∃ i : SpecialPeriods.Threefold.Puncture,
+        x ∈ SpecialPeriods.Threefold.liftedPatch (Option.some i) :=
+  Set.mem_iUnion
+
+private theorem ThreefoldHomology.filling_le_starFillings (i : SpecialPeriods.Threefold.Puncture) :
+    (SpecialPeriods.Threefold.liftedPatch (Option.some i) : Set SpecialPeriods.Threefold.Space) ⊆
+      starFillings := by
+  intro x hx
+  exact (mem_starFillings x).mpr ⟨i, hx⟩
+
+private theorem ThreefoldHomology.star_cover :
+    (SpecialPeriods.Threefold.liftedPatch Option.none : Set SpecialPeriods.Threefold.Space) ∪
+        starFillings =
+      Set.univ := by
+  apply Set.Subset.antisymm (Set.subset_univ _)
+  intro x _
+  have hx :
+    x ∈
+      ⋃ i : SpecialPeriods.Threefold.Index,
+        (SpecialPeriods.Threefold.liftedPatch i : Set SpecialPeriods.Threefold.Space) := by
+    rw [SpecialPeriods.Threefold.liftedPatch_iUnion]
+    trivial
+  obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hx
+  cases i with
+  | none => exact Or.inl hi
+  | some i => exact Or.inr (filling_le_starFillings i hi)
+
+private theorem ThreefoldHomology.starOverlap_eq_iUnion :
+    (starOverlap : Set SpecialPeriods.Threefold.Space) =
+      ⋃ i : SpecialPeriods.Threefold.Puncture,
+        (SpecialPeriods.Threefold.RegularOverlap i : Set SpecialPeriods.Threefold.Space) := by
+  change
+    (SpecialPeriods.Threefold.liftedPatch Option.none : Set SpecialPeriods.Threefold.Space) ∩
+        (⋃ i : SpecialPeriods.Threefold.Puncture,
+          (SpecialPeriods.Threefold.liftedPatch (Option.some i) :
+            Set SpecialPeriods.Threefold.Space)) =
+      ⋃ i : SpecialPeriods.Threefold.Puncture,
+        (SpecialPeriods.Threefold.liftedPatch Option.none : Set SpecialPeriods.Threefold.Space) ∩
+          SpecialPeriods.Threefold.liftedPatch (Option.some i)
+  exact Set.inter_iUnion _ _
+
+private theorem ThreefoldHomology.regularOverlap_pairwise_disjoint :
+    Pairwise
+      (fun i j : SpecialPeriods.Threefold.Puncture =>
+        Disjoint (SpecialPeriods.Threefold.RegularOverlap i : Set SpecialPeriods.Threefold.Space)
+          (SpecialPeriods.Threefold.RegularOverlap j : Set SpecialPeriods.Threefold.Space)) := by
+  intro i j hij
+  exact
+    (SpecialPeriods.Threefold.liftedFilling_disjoint hij).mono Set.inter_subset_right
+      Set.inter_subset_right
+
+private def ThreefoldHomology.sigmaOriginalFillingHomeomorph :
+    (Σ i : SpecialPeriods.Threefold.Puncture,
+        SpecialPeriods.Threefold.localPiece (Option.some i)) ≃ₜ
+      (Σ i : SpecialPeriods.Threefold.Puncture,
+        SpecialPeriods.Threefold.liftedPatch (Option.some i))
+    where
+  toEquiv := Equiv.sigmaCongrRight (fun i => (originalPatchHomeomorph (Option.some i)).toEquiv)
+  continuous_toFun :=
+    continuous_sigma
+      (fun i => continuous_sigmaMk.comp (originalPatchHomeomorph (Option.some i)).continuous)
+  continuous_invFun :=
+    continuous_sigma
+      (fun i => continuous_sigmaMk.comp (originalPatchHomeomorph (Option.some i)).symm.continuous)
+
+private def ThreefoldHomology.starFillingsHomeomorph :
+    (Σ i : SpecialPeriods.Threefold.Puncture,
+        SpecialPeriods.Threefold.localPiece (Option.some i)) ≃ₜ
+      starFillings :=
+  sigmaOriginalFillingHomeomorph.trans
+    (disjointOpenUnionHomeomorph
+      (fun i : SpecialPeriods.Threefold.Puncture =>
+        SpecialPeriods.Threefold.liftedPatch (Option.some i))
+      (fun _ _ hij => SpecialPeriods.Threefold.liftedFilling_disjoint hij))
+
+private def ThreefoldHomology.starOverlapHomeomorph :
+    (Σ i : SpecialPeriods.Threefold.Puncture, SpecialPeriods.Threefold.RegularOverlap i) ≃ₜ
+      starOverlap :=
+  (disjointOpenUnionHomeomorph
+        (fun i : SpecialPeriods.Threefold.Puncture =>
+          SpecialPeriods.Threefold.liftedPatch Option.none ⊓
+            SpecialPeriods.Threefold.liftedPatch (Option.some i))
+        regularOverlap_pairwise_disjoint).trans
+    (Homeomorph.setCongr starOverlap_eq_iUnion.symm)
+
+private def ThreefoldHomology.fillingToStar (i : SpecialPeriods.Threefold.Puncture) :
+    C(SpecialPeriods.Threefold.localPiece (Option.some i), starFillings) :=
+  (ContinuousMap.inclusion (filling_le_starFillings i)).comp
+    (originalPatchHomeomorph (Option.some i) :
+      C(SpecialPeriods.Threefold.localPiece (Option.some i),
+        SpecialPeriods.Threefold.liftedPatch (Option.some i)))
+
+private def ThreefoldHomology.overlapToStar (i : SpecialPeriods.Threefold.Puncture) :
+    C(SpecialPeriods.Threefold.RegularOverlap i, starOverlap) :=
+  ⟨fun x => ⟨x.val, x.property.1, filling_le_starFillings i x.property.2⟩,
+    continuous_subtype_val.subtype_mk _⟩
+
+private def ThreefoldHomology.starOverlapToRegularPatch :
+    C(starOverlap, SpecialPeriods.Threefold.liftedPatch Option.none) :=
+  ContinuousMap.inclusion Set.inter_subset_left
+
+private def ThreefoldHomology.starOverlapToFillings : C(starOverlap, starFillings) :=
+  ContinuousMap.inclusion Set.inter_subset_right
+
+private def ThreefoldHomology.starOverlapToRegular :
+    C(starOverlap, SpecialPeriods.Threefold.SpecialRegularFamily) :=
+  (originalRegularPatchHomeomorph.symm :
+        C(SpecialPeriods.Threefold.liftedPatch Option.none,
+          SpecialPeriods.Threefold.SpecialRegularFamily)).comp
+    starOverlapToRegularPatch
+
+private theorem ThreefoldHomology.starOverlapToRegular_overlapToStar
+    (i : SpecialPeriods.Threefold.Puncture) :
+    starOverlapToRegular.comp (overlapToStar i) = overlapToRegularFamily i :=
+  rfl
+
+private theorem ThreefoldHomology.starOverlapToFillings_overlapToStar
+    (i : SpecialPeriods.Threefold.Puncture) :
+    starOverlapToFillings.comp (overlapToStar i) = (fillingToStar i).comp (overlapToFilling i) := by
+  apply ContinuousMap.ext
+  intro x
+  apply Subtype.ext
+  exact (inclusion_overlapToFilling i x).symm
+
+private theorem ThreefoldHomology.fillingToStar_ambient (i : SpecialPeriods.Threefold.Puncture) :
+    (SingularMayerVietoris.subtypeInclusion
+            (starFillings : Set SpecialPeriods.Threefold.Space)).comp
+        (fillingToStar i) =
+      originalPieceInclusion (Option.some i) :=
+  rfl
+
+private theorem
+    ThreefoldHomology.starFillingsHomeomorph_sigmaMk (i : SpecialPeriods.Threefold.Puncture) :
+    (starFillingsHomeomorph :
+            C((Σ j : SpecialPeriods.Threefold.Puncture,
+                SpecialPeriods.Threefold.localPiece (Option.some j)),
+              starFillings)).comp
+        (ContinuousMap.sigmaMk i) =
+      fillingToStar i := by
+  apply ContinuousMap.ext
+  intro x
+  apply Subtype.ext
+  rfl
+
+private theorem
+    ThreefoldHomology.starOverlapHomeomorph_sigmaMk (i : SpecialPeriods.Threefold.Puncture) :
+    (starOverlapHomeomorph :
+            C((Σ j : SpecialPeriods.Threefold.Puncture,
+                SpecialPeriods.Threefold.RegularOverlap j),
+              starOverlap)).comp
+        (ContinuousMap.sigmaMk i) =
+      overlapToStar i := by
+  apply ContinuousMap.ext
+  intro x
+  apply Subtype.ext
+  rfl
+
+private def ThreefoldHomology.starRegularHomologyEquiv (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.liftedPatch Option.none)
+        n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily n :=
+  PeriodTorusHigherHomology.homeomorphHomologyEquiv originalRegularPatchHomeomorph.symm n
+
+private def ThreefoldHomology.starFillingsHomologyEquiv (n : ℕ) :
+    SingularMayerVietoris.SingularHomology starFillings n ≃ₗ[ℤ] StarFillingHomology n :=
+  ((PeriodTorusHigherHomology.homeomorphHomologyEquiv starFillingsHomeomorph.symm
+          n).toAddEquiv.trans
+      (ThreefoldHomologyStarCoproduct.sigmaHomologyEquiv
+          (fun i : SpecialPeriods.Threefold.Puncture =>
+            SpecialPeriods.Threefold.localPiece (Option.some i))
+          n).toAddEquiv).toIntLinearEquiv
+
+private def ThreefoldHomology.starOverlapHomologyEquiv (n : ℕ) :
+    SingularMayerVietoris.SingularHomology starOverlap n ≃ₗ[ℤ] StarOverlapHomology n :=
+  ((PeriodTorusHigherHomology.homeomorphHomologyEquiv starOverlapHomeomorph.symm
+          n).toAddEquiv.trans
+      (ThreefoldHomologyStarCoproduct.sigmaHomologyEquiv
+          (fun i : SpecialPeriods.Threefold.Puncture => SpecialPeriods.Threefold.RegularOverlap i)
+          n).toAddEquiv).toIntLinearEquiv
+
+private def ThreefoldHomology.starPairHomologyEquiv (n : ℕ) :
+    (SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.liftedPatch Option.none) n ×
+        SingularMayerVietoris.SingularHomology starFillings n) ≃ₗ[ℤ]
+      StarPairHomology n :=
+  ((starRegularHomologyEquiv n).toAddEquiv.prodCongr
+      (starFillingsHomologyEquiv n).toAddEquiv).toIntLinearEquiv
+
+@[simp]
+private theorem ThreefoldHomology.starRegularHomologyEquiv_apply (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.liftedPatch Option.none)
+        n) :
+    starRegularHomologyEquiv n a =
+      SingularMayerVietoris.singularHomologyMap
+        (originalRegularPatchHomeomorph.symm :
+          C(SpecialPeriods.Threefold.liftedPatch Option.none,
+            SpecialPeriods.Threefold.SpecialRegularFamily))
+        n a :=
+  rfl
+
+@[simp]
+private theorem ThreefoldHomology.starFillingsHomologyEquiv_symm_apply (n : ℕ)
+    (a : StarFillingHomology n) :
+    (starFillingsHomologyEquiv n).symm a =
+      SingularMayerVietoris.singularHomologyMap
+        (starFillingsHomeomorph :
+          C((Σ i : SpecialPeriods.Threefold.Puncture,
+              SpecialPeriods.Threefold.localPiece (Option.some i)),
+            starFillings))
+        n
+        ((ThreefoldHomologyStarCoproduct.sigmaHomologyEquiv
+              (fun i : SpecialPeriods.Threefold.Puncture =>
+                SpecialPeriods.Threefold.localPiece (Option.some i))
+              n).symm
+          a) :=
+  rfl
+
+@[simp]
+private theorem ThreefoldHomology.starOverlapHomologyEquiv_symm_apply (n : ℕ)
+    (a : StarOverlapHomology n) :
+    (starOverlapHomologyEquiv n).symm a =
+      SingularMayerVietoris.singularHomologyMap
+        (starOverlapHomeomorph :
+          C((Σ i : SpecialPeriods.Threefold.Puncture, SpecialPeriods.Threefold.RegularOverlap i),
+            starOverlap))
+        n
+        ((ThreefoldHomologyStarCoproduct.sigmaHomologyEquiv
+              (fun i : SpecialPeriods.Threefold.Puncture =>
+                SpecialPeriods.Threefold.RegularOverlap i)
+              n).symm
+          a) :=
+  rfl
+
+private theorem ThreefoldHomology.starFillingsHomologyEquiv_symm_single (n : ℕ)
+    (i : SpecialPeriods.Threefold.Puncture)
+    (a :
+      SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.localPiece (Option.some i))
+        n) :
+    (starFillingsHomologyEquiv n).symm (Pi.single i a) =
+      SingularMayerVietoris.singularHomologyMap (fillingToStar i) n a := by
+  rw [starFillingsHomologyEquiv_symm_apply,
+    ThreefoldHomologyStarCoproduct.sigmaHomologyEquiv_symm_single]
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (starFillingsHomeomorph :
+          C((Σ i : SpecialPeriods.Threefold.Puncture,
+              SpecialPeriods.Threefold.localPiece (Option.some i)),
+            starFillings))
+        n (SingularMayerVietoris.singularHomologyMap (ContinuousMap.sigmaMk i) n a) =
+      _
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    starFillingsHomeomorph_sigmaMk]
+
+private theorem ThreefoldHomology.starOverlapHomologyEquiv_symm_single (n : ℕ)
+    (i : SpecialPeriods.Threefold.Puncture)
+    (a : SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) n) :
+    (starOverlapHomologyEquiv n).symm (Pi.single i a) =
+      SingularMayerVietoris.singularHomologyMap (overlapToStar i) n a := by
+  rw [starOverlapHomologyEquiv_symm_apply,
+    ThreefoldHomologyStarCoproduct.sigmaHomologyEquiv_symm_single]
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (starOverlapHomeomorph :
+          C((Σ i : SpecialPeriods.Threefold.Puncture, SpecialPeriods.Threefold.RegularOverlap i),
+            starOverlap))
+        n (SingularMayerVietoris.singularHomologyMap (ContinuousMap.sigmaMk i) n a) =
+      _
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    starOverlapHomeomorph_sigmaMk]
+
+@[simp]
+private theorem ThreefoldHomology.starFillingsHomologyEquiv_inclusion (n : ℕ)
+    (i : SpecialPeriods.Threefold.Puncture)
+    (a :
+      SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.localPiece (Option.some i))
+        n) :
+    starFillingsHomologyEquiv n
+        (SingularMayerVietoris.singularHomologyMap (fillingToStar i) n a) =
+      Pi.single i a := by
+  apply (starFillingsHomologyEquiv n).symm.injective
+  rw [LinearEquiv.symm_apply_apply, starFillingsHomologyEquiv_symm_single]
+
+@[simp]
+private theorem ThreefoldHomology.starOverlapHomologyEquiv_inclusion (n : ℕ)
+    (i : SpecialPeriods.Threefold.Puncture)
+    (a : SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) n) :
+    starOverlapHomologyEquiv n (SingularMayerVietoris.singularHomologyMap (overlapToStar i) n a) =
+      Pi.single i a := by
+  apply (starOverlapHomologyEquiv n).symm.injective
+  rw [LinearEquiv.symm_apply_apply, starOverlapHomologyEquiv_symm_single]
+
+private theorem
+    ThreefoldHomology.starFillingsHomologyEquiv_symm_sum (n : ℕ) (a : StarFillingHomology n) :
+    (starFillingsHomologyEquiv n).symm a =
+      ∑ i : SpecialPeriods.Threefold.Puncture,
+        SingularMayerVietoris.singularHomologyMap (fillingToStar i) n (a i) := by
+  conv_lhs => rw [← Finset.univ_sum_single a]
+  rw [map_sum]
+  apply Finset.sum_congr rfl
+  intro i _
+  exact starFillingsHomologyEquiv_symm_single n i (a i)
+
+private theorem
+    ThreefoldHomology.starOverlapHomologyEquiv_symm_sum (n : ℕ) (a : StarOverlapHomology n) :
+    (starOverlapHomologyEquiv n).symm a =
+      ∑ i : SpecialPeriods.Threefold.Puncture,
+        SingularMayerVietoris.singularHomologyMap (overlapToStar i) n (a i) := by
+  conv_lhs => rw [← Finset.univ_sum_single a]
+  rw [map_sum]
+  apply Finset.sum_congr rfl
+  intro i _
+  exact starOverlapHomologyEquiv_symm_single n i (a i)
+
+private theorem ThreefoldHomology.starFillingsHomologyEquiv_decomposition (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology starFillings n) :
+    a =
+      ∑ i : SpecialPeriods.Threefold.Puncture,
+        SingularMayerVietoris.singularHomologyMap (fillingToStar i) n
+          (starFillingsHomologyEquiv n a i) := by
+  have h := starFillingsHomologyEquiv_symm_sum n (starFillingsHomologyEquiv n a)
+  rwa [LinearEquiv.symm_apply_apply] at h
+
+private theorem ThreefoldHomology.starOverlapHomologyEquiv_decomposition (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology starOverlap n) :
+    a =
+      ∑ i : SpecialPeriods.Threefold.Puncture,
+        SingularMayerVietoris.singularHomologyMap (overlapToStar i) n
+          (starOverlapHomologyEquiv n a i) := by
+  have h := starOverlapHomologyEquiv_symm_sum n (starOverlapHomologyEquiv n a)
+  rwa [LinearEquiv.symm_apply_apply] at h
+
+private theorem ThreefoldHomology.starFillingsHomology_hom_ext (n : ℕ) {M : Type} [AddCommGroup M]
+    [Module ℤ M] (f g : SingularMayerVietoris.SingularHomology starFillings n →ₗ[ℤ] M)
+    (h :
+      ∀ (i : SpecialPeriods.Threefold.Puncture)
+        (a :
+          SingularMayerVietoris.SingularHomology
+            (SpecialPeriods.Threefold.localPiece (Option.some i)) n),
+        f (SingularMayerVietoris.singularHomologyMap (fillingToStar i) n a) =
+          g (SingularMayerVietoris.singularHomologyMap (fillingToStar i) n a)) :
+    f = g := by
+  apply LinearMap.ext
+  intro a
+  rw [starFillingsHomologyEquiv_decomposition n a, map_sum, map_sum]
+  exact Finset.sum_congr rfl (fun i _ => h i _)
+
+private theorem ThreefoldHomology.starOverlapHomology_hom_ext (n : ℕ) {M : Type} [AddCommGroup M]
+    [Module ℤ M] (f g : SingularMayerVietoris.SingularHomology starOverlap n →ₗ[ℤ] M)
+    (h :
+      ∀ (i : SpecialPeriods.Threefold.Puncture)
+        (a :
+          SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) n),
+        f (SingularMayerVietoris.singularHomologyMap (overlapToStar i) n a) =
+          g (SingularMayerVietoris.singularHomologyMap (overlapToStar i) n a)) :
+    f = g := by
+  apply LinearMap.ext
+  intro a
+  rw [starOverlapHomologyEquiv_decomposition n a, map_sum, map_sum]
+  exact Finset.sum_congr rfl (fun i _ => h i _)
+
+private theorem ThreefoldHomology.starRegularHomologyEquiv_ambient (n : ℕ) :
+    (SingularMayerVietoris.singularHomologyMap originalRegularInclusion n).comp
+        (starRegularHomologyEquiv n).toLinearMap =
+      SingularMayerVietoris.singularHomologyMap
+        (SingularMayerVietoris.subtypeInclusion
+          (SpecialPeriods.Threefold.liftedPatch Option.none : Set SpecialPeriods.Threefold.Space))
+        n := by
+  change
+    (SingularMayerVietoris.singularHomologyMap originalRegularInclusion n).comp
+        (SingularMayerVietoris.singularHomologyMap
+          (originalRegularPatchHomeomorph.symm :
+            C(SpecialPeriods.Threefold.liftedPatch Option.none,
+              SpecialPeriods.Threefold.SpecialRegularFamily))
+          n) =
+      _
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp]
+  apply
+    congrArg
+      (fun f :
+          C(SpecialPeriods.Threefold.liftedPatch Option.none, SpecialPeriods.Threefold.Space) =>
+        SingularMayerVietoris.singularHomologyMap f n)
+  apply ContinuousMap.ext
+  intro x
+  exact congrArg Subtype.val (originalRegularPatchHomeomorph.apply_symm_apply x)
+
+private theorem ThreefoldHomology.starFillingsToSpaceHomologyMap_single (n : ℕ)
+    (i : SpecialPeriods.Threefold.Puncture)
+    (a :
+      SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.localPiece (Option.some i))
+        n) :
+    starFillingsToSpaceHomologyMap n (Pi.single i a) =
+      SingularMayerVietoris.singularHomologyMap (originalPieceInclusion (Option.some i)) n a := by
+  have h :=
+    starRightHomologyMap_single n i
+      (0 : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily n)
+      a
+  change
+    SingularMayerVietoris.singularHomologyMap originalRegularInclusion n 0 +
+        starFillingsToSpaceHomologyMap n (Pi.single i a) =
+      SingularMayerVietoris.singularHomologyMap originalRegularInclusion n 0 +
+        SingularMayerVietoris.singularHomologyMap (originalPieceInclusion (Option.some i)) n
+          a at h
+  simpa only [map_zero, zero_add] using h
+
+private theorem ThreefoldHomology.starFillingsHomologyEquiv_ambient (n : ℕ) :
+    (starFillingsToSpaceHomologyMap n).comp (starFillingsHomologyEquiv n).toLinearMap =
+      SingularMayerVietoris.singularHomologyMap
+        (SingularMayerVietoris.subtypeInclusion
+          (starFillings : Set SpecialPeriods.Threefold.Space))
+        n := by
+  apply starFillingsHomology_hom_ext n
+  intro i a
+  simp only [LinearMap.comp_apply, LinearEquiv.coe_coe, starFillingsHomologyEquiv_inclusion,
+    starFillingsToSpaceHomologyMap_single]
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    fillingToStar_ambient]
+
+private theorem ThreefoldHomology.starRegularHomologyEquiv_overlapToStar (n : ℕ)
+    (i : SpecialPeriods.Threefold.Puncture)
+    (a : SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) n) :
+    starRegularHomologyEquiv n
+        (SingularMayerVietoris.singularHomologyMap starOverlapToRegularPatch n
+          (SingularMayerVietoris.singularHomologyMap (overlapToStar i) n a)) =
+      SingularMayerVietoris.singularHomologyMap (overlapToRegularFamily i) n a := by
+  rw [starRegularHomologyEquiv_apply, ← LinearMap.comp_apply, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+  change
+    SingularMayerVietoris.singularHomologyMap starOverlapToRegular n
+        (SingularMayerVietoris.singularHomologyMap (overlapToStar i) n a) =
+      _
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    starOverlapToRegular_overlapToStar]
+
+private theorem ThreefoldHomology.starFillingsHomologyEquiv_overlapToStar (n : ℕ)
+    (i : SpecialPeriods.Threefold.Puncture)
+    (a : SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) n) :
+    starFillingsHomologyEquiv n
+        (SingularMayerVietoris.singularHomologyMap starOverlapToFillings n
+          (SingularMayerVietoris.singularHomologyMap (overlapToStar i) n a)) =
+      Pi.single i (SingularMayerVietoris.singularHomologyMap (overlapToFilling i) n a) := by
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    starOverlapToFillings_overlapToStar, PeriodTorusHigherHomology.singularHomologyMap_comp,
+    LinearMap.comp_apply, starFillingsHomologyEquiv_inclusion]
+
+private theorem ThreefoldHomology.starLeftHomologyMap_comparison (n : ℕ) :
+    (starLeftHomologyMap n).comp (starOverlapHomologyEquiv n).toLinearMap =
+      (starPairHomologyEquiv n).toLinearMap.comp
+        (SingularMayerVietoris.leftHomologyMap
+          (SpecialPeriods.Threefold.liftedPatch Option.none : Set SpecialPeriods.Threefold.Space)
+          (starFillings : Set SpecialPeriods.Threefold.Space) n) := by
+  apply starOverlapHomology_hom_ext n
+  intro i a
+  have hr :
+    starPairHomologyEquiv n
+        (SingularMayerVietoris.leftHomologyMap
+          (SpecialPeriods.Threefold.liftedPatch Option.none : Set SpecialPeriods.Threefold.Space)
+          (starFillings : Set SpecialPeriods.Threefold.Space) n
+          (SingularMayerVietoris.singularHomologyMap (overlapToStar i) n a)) =
+      (SingularMayerVietoris.singularHomologyMap (overlapToRegularFamily i) n a,
+        Pi.single i (-SingularMayerVietoris.singularHomologyMap (overlapToFilling i) n a)) := by
+    have hraw :=
+      SingularMayerVietoris.leftHomologyMap_apply
+        (SpecialPeriods.Threefold.liftedPatch Option.none : Set SpecialPeriods.Threefold.Space)
+        (starFillings : Set SpecialPeriods.Threefold.Space) n
+        (SingularMayerVietoris.singularHomologyMap (overlapToStar i) n a)
+    refine (congrArg (starPairHomologyEquiv n) hraw).trans ?_
+    change
+      (starRegularHomologyEquiv n
+            (SingularMayerVietoris.singularHomologyMap starOverlapToRegularPatch n
+              (SingularMayerVietoris.singularHomologyMap (overlapToStar i) n a)),
+          starFillingsHomologyEquiv n
+            (-SingularMayerVietoris.singularHomologyMap starOverlapToFillings n
+                (SingularMayerVietoris.singularHomologyMap (overlapToStar i) n a))) =
+        _
+    rw [map_neg, starRegularHomologyEquiv_overlapToStar, starFillingsHomologyEquiv_overlapToStar,
+      Pi.single_neg]
+  exact
+    (congrArg (starLeftHomologyMap n) (starOverlapHomologyEquiv_inclusion n i a)).trans
+      ((starLeftHomologyMap_single n i a).trans hr.symm)
+
+private theorem ThreefoldHomology.starRightHomologyMap_comparison (n : ℕ) :
+    (starRightHomologyMap n).comp (starPairHomologyEquiv n).toLinearMap =
+      SingularMayerVietoris.rightHomologyMap
+        (SpecialPeriods.Threefold.liftedPatch Option.none : Set SpecialPeriods.Threefold.Space)
+        (starFillings : Set SpecialPeriods.Threefold.Space) n := by
+  apply LinearMap.ext
+  intro a
+  change
+    SingularMayerVietoris.singularHomologyMap originalRegularInclusion n
+          (starRegularHomologyEquiv n a.1) +
+        starFillingsToSpaceHomologyMap n (starFillingsHomologyEquiv n a.2) =
+      _
+  rw [SingularMayerVietoris.rightHomologyMap_apply]
+  exact
+    congrArg₂ (· + ·) (LinearMap.congr_fun (starRegularHomologyEquiv_ambient n) a.1)
+      (LinearMap.congr_fun (starFillingsHomologyEquiv_ambient n) a.2)
+
+private def ThreefoldHomology.rawStarConnectingHomomorphism (n : ℕ) :
+    SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space (n + 1) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology starOverlap n :=
+  SingularMayerVietoris.connectingHomomorphism
+    ((SpecialPeriods.Threefold.liftedPatch none : Set SpecialPeriods.Threefold.Space))
+    ((ThreefoldHomology.starFillings : Set SpecialPeriods.Threefold.Space))
+    (SpecialPeriods.Threefold.liftedPatch Option.none).isOpen starFillings.isOpen star_cover n
+
+private def ThreefoldHomology.starConnectingHomomorphism (n : ℕ) :
+    SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space (n + 1) →ₗ[ℤ]
+      StarOverlapHomology n :=
+  (starOverlapHomologyEquiv n).toLinearMap.comp (rawStarConnectingHomomorphism n)
+
+private theorem ThreefoldHomology.star_exact_at_pair (n : ℕ) :
+    Function.Exact (starLeftHomologyMap n) (starRightHomologyMap n) := by
+  have hraw :
+    Function.Exact
+      (SingularMayerVietoris.leftHomologyMap
+        ((SpecialPeriods.Threefold.liftedPatch none : Set SpecialPeriods.Threefold.Space))
+        ((ThreefoldHomology.starFillings : Set SpecialPeriods.Threefold.Space)) n)
+      (SingularMayerVietoris.rightHomologyMap
+        ((SpecialPeriods.Threefold.liftedPatch none : Set SpecialPeriods.Threefold.Space))
+        ((ThreefoldHomology.starFillings : Set SpecialPeriods.Threefold.Space)) n) :=
+    LinearMap.exact_iff.mpr
+      (SingularMayerVietoris.exact_at_pair
+          ((SpecialPeriods.Threefold.liftedPatch none : Set SpecialPeriods.Threefold.Space))
+          ((ThreefoldHomology.starFillings : Set SpecialPeriods.Threefold.Space))
+          (SpecialPeriods.Threefold.liftedPatch Option.none).isOpen starFillings.isOpen star_cover
+          n).symm
+  apply
+    exact_of_linearEquiv_squares _ _ _ _ (starOverlapHomologyEquiv n) (starPairHomologyEquiv n)
+      (LinearEquiv.refl ℤ _) (starLeftHomologyMap_comparison n) _ hraw
+  simpa only [LinearEquiv.refl_toLinearMap, LinearMap.id_comp] using
+    starRightHomologyMap_comparison n
+
+private theorem ThreefoldHomology.star_exact_at_intersection (n : ℕ) :
+    Function.Exact (starConnectingHomomorphism n) (starLeftHomologyMap n) := by
+  have hraw :
+    Function.Exact (rawStarConnectingHomomorphism n)
+      (SingularMayerVietoris.leftHomologyMap
+        ((SpecialPeriods.Threefold.liftedPatch none : Set SpecialPeriods.Threefold.Space))
+        ((ThreefoldHomology.starFillings : Set SpecialPeriods.Threefold.Space)) n) :=
+    LinearMap.exact_iff.mpr
+      (SingularMayerVietoris.exact_at_intersection
+          ((SpecialPeriods.Threefold.liftedPatch none : Set SpecialPeriods.Threefold.Space))
+          ((ThreefoldHomology.starFillings : Set SpecialPeriods.Threefold.Space))
+          (SpecialPeriods.Threefold.liftedPatch Option.none).isOpen starFillings.isOpen star_cover
+          n).symm
+  apply
+    exact_of_linearEquiv_squares _ _ _ _ (LinearEquiv.refl ℤ _) (starOverlapHomologyEquiv n)
+      (starPairHomologyEquiv n) _ (starLeftHomologyMap_comparison n) hraw
+  simp only [LinearEquiv.refl_toLinearMap, LinearMap.comp_id, starConnectingHomomorphism]
+
+private theorem ThreefoldHomology.star_exact_at_ambient (n : ℕ) :
+    Function.Exact (starRightHomologyMap (n + 1)) (starConnectingHomomorphism n) := by
+  have hraw :
+    Function.Exact
+      (SingularMayerVietoris.rightHomologyMap
+        ((SpecialPeriods.Threefold.liftedPatch none : Set SpecialPeriods.Threefold.Space))
+        ((ThreefoldHomology.starFillings : Set SpecialPeriods.Threefold.Space)) (n + 1))
+      (rawStarConnectingHomomorphism n) :=
+    LinearMap.exact_iff.mpr
+      (SingularMayerVietoris.exact_at_ambient
+          ((SpecialPeriods.Threefold.liftedPatch none : Set SpecialPeriods.Threefold.Space))
+          ((ThreefoldHomology.starFillings : Set SpecialPeriods.Threefold.Space))
+          (SpecialPeriods.Threefold.liftedPatch Option.none).isOpen starFillings.isOpen star_cover
+          n).symm
+  apply
+    exact_of_linearEquiv_squares _ _ _ _ (starPairHomologyEquiv (n + 1)) (LinearEquiv.refl ℤ _)
+      (starOverlapHomologyEquiv n) _ _ hraw
+  · simpa only [LinearEquiv.refl_toLinearMap, LinearMap.id_comp] using
+      starRightHomologyMap_comparison (n + 1)
+  · simp only [LinearEquiv.refl_toLinearMap, LinearMap.comp_id, starConnectingHomomorphism]
+
+private theorem ThreefoldHomology.starLeftHomologyMap_one_surjective :
+    Function.Surjective (starLeftHomologyMap 1) := by
+  intro a
+  apply (star_exact_at_pair 1 a).mp
+  exact SpecialPeriods.Threefold.LowDegrees.singularH1_eq_zero _
+
+private theorem ThreefoldHomology.SecondDegree.puncture_card :
+    Fintype.card SpecialPeriods.Threefold.Puncture = 3 := by decide
+
+private theorem ThreefoldHomology.SecondDegree.overlapFirst_free :
+    Module.Free ℤ (ThreefoldHomology.StarOverlapHomology 1) := by
+  have :
+    ∀ i : SpecialPeriods.Threefold.Puncture,
+      Module.Free ℤ
+        (SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) 1) :=
+    ThreefoldHomology.BoundaryFirst.overlapH1_free
+  exact
+    ThreefoldHomologyFreeProducts.free_pi_int
+      (fun i : SpecialPeriods.Threefold.Puncture =>
+        SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) 1)
+
+private theorem ThreefoldHomology.SecondDegree.overlapFirst_finrank :
+    Module.finrank ℤ (ThreefoldHomology.StarOverlapHomology 1) = 9 := by
+  have :
+    ∀ i : SpecialPeriods.Threefold.Puncture,
+      Module.Free ℤ
+        (SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) 1) :=
+    ThreefoldHomology.BoundaryFirst.overlapH1_free
+  have :
+    ∀ i : SpecialPeriods.Threefold.Puncture,
+      Module.Finite ℤ
+        (SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) 1) :=
+    ThreefoldHomology.BoundaryFirst.overlapH1_finite
+  rw [ThreefoldHomologyFreeProducts.finrank_pi_int
+      (fun i : SpecialPeriods.Threefold.Puncture =>
+        SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) 1)]
+  simp only [ThreefoldHomology.BoundaryFirst.overlapH1_finrank, Finset.sum_const,
+    Finset.card_univ, puncture_card]
+  decide
+
+private theorem
+    ThreefoldHomology.SecondDegree.fillingFirst_free (i : SpecialPeriods.Threefold.Puncture) :
+    Module.Free ℤ
+      (SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.Threefold.localPiece (Option.some i)) 1) := by
+  cases i with
+  | none => exact ThreefoldHomology.Finiteness.cuspPieceHomology_free 1
+  | some j => exact ThreefoldHomology.Finiteness.ellipticPieceHomology_free j 1
+
+private theorem ThreefoldHomology.SecondDegree.fillingFirst_finrank
+    (i : SpecialPeriods.Threefold.Puncture) :
+    Module.finrank ℤ
+        (SingularMayerVietoris.SingularHomology
+          (SpecialPeriods.Threefold.localPiece (Option.some i)) 1) =
+      2 := by
+  cases i with
+  | none => exact ThreefoldHomology.Finiteness.cuspPieceHomology_finrank 1
+  | some j => exact ThreefoldHomology.Finiteness.ellipticPieceHomology_finrank j 1
+
+private theorem ThreefoldHomology.SecondDegree.fillingsFirst_free :
+    Module.Free ℤ (ThreefoldHomology.StarFillingHomology 1) := by
+  have :
+    ∀ i : SpecialPeriods.Threefold.Puncture,
+      Module.Free ℤ
+        (SingularMayerVietoris.SingularHomology
+          (SpecialPeriods.Threefold.localPiece (Option.some i)) 1) :=
+    fillingFirst_free
+  exact
+    ThreefoldHomologyFreeProducts.free_pi_int
+      (fun i : SpecialPeriods.Threefold.Puncture =>
+        SingularMayerVietoris.SingularHomology
+          (SpecialPeriods.Threefold.localPiece (Option.some i)) 1)
+
+private theorem ThreefoldHomology.SecondDegree.fillingsFirst_finrank :
+    Module.finrank ℤ (ThreefoldHomology.StarFillingHomology 1) = 6 := by
+  have :
+    ∀ i : SpecialPeriods.Threefold.Puncture,
+      Module.Free ℤ
+        (SingularMayerVietoris.SingularHomology
+          (SpecialPeriods.Threefold.localPiece (Option.some i)) 1) :=
+    fillingFirst_free
+  have :
+    ∀ i : SpecialPeriods.Threefold.Puncture,
+      Module.Finite ℤ
+        (SingularMayerVietoris.SingularHomology
+          (SpecialPeriods.Threefold.localPiece (Option.some i)) 1) :=
+    fun i => ThreefoldHomology.Finiteness.fillingHomology_finite i 1
+  rw [ThreefoldHomologyFreeProducts.finrank_pi_int
+      (fun i : SpecialPeriods.Threefold.Puncture =>
+        SingularMayerVietoris.SingularHomology
+          (SpecialPeriods.Threefold.localPiece (Option.some i)) 1)]
+  simp only [fillingFirst_finrank, Finset.sum_const, Finset.card_univ, puncture_card]
+  decide
+
+private theorem ThreefoldHomology.SecondDegree.pairFirst_free :
+    Module.Free ℤ (ThreefoldHomology.StarPairHomology 1) := by
+  have := ThreefoldHomology.Finiteness.regularHomology_free 1
+  have := fillingsFirst_free
+  exact
+    ThreefoldHomologyFreeProducts.free_prod_int
+      (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily 1)
+      (ThreefoldHomology.StarFillingHomology 1)
+
+private theorem ThreefoldHomology.SecondDegree.pairFirst_finrank :
+    Module.finrank ℤ (ThreefoldHomology.StarPairHomology 1) = 9 := by
+  have := ThreefoldHomology.Finiteness.regularHomology_free 1
+  have := ThreefoldHomology.Finiteness.regularHomology_finite 1
+  have := fillingsFirst_free
+  have := ThreefoldHomology.Finiteness.starFillingHomology_finite 1
+  rw [ThreefoldHomologyFreeProducts.finrank_prod_int
+      (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily 1)
+      (ThreefoldHomology.StarFillingHomology 1),
+    ThreefoldHomology.Finiteness.regularHomology_finrank, fillingsFirst_finrank]
+  rfl
+
+private theorem ThreefoldHomology.SecondDegree.starLeft_one_bijective :
+    Function.Bijective (ThreefoldHomology.starLeftHomologyMap 1) := by
+  have := overlapFirst_free
+  have := pairFirst_free
+  have := ThreefoldHomology.Finiteness.starOverlapHomology_finite 1
+  have := ThreefoldHomology.Finiteness.starPairHomology_finite 1
+  apply
+    OrzechProperty.bijective_of_surjective_of_finrank_le (ThreefoldHomology.starLeftHomologyMap 1)
+      ThreefoldHomology.starLeftHomologyMap_one_surjective
+  rw [overlapFirst_finrank, pairFirst_finrank]
+
+private theorem ThreefoldHomology.SecondDegree.connecting_one_eq_zero :
+    ThreefoldHomology.starConnectingHomomorphism 1 = 0 := by
+  apply LinearMap.ext
+  intro a
+  change ThreefoldHomology.starConnectingHomomorphism 1 a = 0
+  apply starLeft_one_bijective.injective
+  simpa only [map_zero] using
+    (ThreefoldHomology.star_exact_at_intersection 1).apply_apply_eq_zero a
+
+private theorem ThreefoldHomology.SecondDegree.starRight_two_surjective :
+    Function.Surjective (ThreefoldHomology.starRightHomologyMap 2) := by
+  intro a
+  apply (ThreefoldHomology.star_exact_at_ambient 1 a).mp
+  rw [connecting_one_eq_zero, LinearMap.zero_apply]
+
+private theorem ThreefoldHomology.CapElimination.boundaryFillingHomologyMap_surjective
+    (i : SpecialPeriods.Threefold.Puncture) (n : ℕ) :
+    Function.Surjective (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap i n) := by
+  cases i with
+  | none => exact ThreefoldHomologyCuspFibre.boundaryFillingHomologyMap_surjective n
+  | some j =>
+    exact PeriodFamily.Boundary.EllipticCapProduct.boundaryFillingHomologyMap_surjective j n
+
+private theorem ThreefoldHomology.CapElimination.overlapToFilling_homology_surjective
+    (i : SpecialPeriods.Threefold.Puncture) (n : ℕ) :
+    Function.Surjective
+      (SingularMayerVietoris.singularHomologyMap (ThreefoldHomology.overlapToFilling i) n) := by
+  intro a
+  obtain ⟨b, hb⟩ := boundaryFillingHomologyMap_surjective i n a
+  refine ⟨(ThreefoldOverlapMappingTorus.overlapHomologyEquiv i n).symm b, ?_⟩
+  exact
+    (LinearMap.congr_fun (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap_eq i n)
+          b).symm.trans
+      hb
+
+private theorem
+    ThreefoldHomology.CapElimination.starOverlapToFillingsHomologyMap_surjective (n : ℕ) :
+    Function.Surjective (ThreefoldHomology.starOverlapToFillingsHomologyMap n) := by
+  classical
+  intro a
+  choose b hb using fun i : SpecialPeriods.Threefold.Puncture =>
+    overlapToFilling_homology_surjective i n (a i)
+  refine ⟨b, ?_⟩
+  funext i
+  exact hb i
+
+private def ThreefoldHomology.CapElimination.capKernelRegularMap (n : ℕ) :
+    LinearMap.ker (ThreefoldHomology.starOverlapToFillingsHomologyMap n) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily n :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun a := ThreefoldHomology.starOverlapToRegularHomologyMap n a.val
+      map_zero' := (ThreefoldHomology.starOverlapToRegularHomologyMap n).map_zero
+      map_add' a b := (ThreefoldHomology.starOverlapToRegularHomologyMap n).map_add a.val b.val }
+
+private def ThreefoldHomology.CapElimination.capKernelRegularImage (n : ℕ) :
+    Submodule ℤ
+      (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily n) :=
+  LinearMap.range (capKernelRegularMap n)
+
+private theorem ThreefoldHomology.CapElimination.starLeft_regular_fillings (n : ℕ)
+    (a : ThreefoldHomology.StarOverlapHomology n) :
+    ThreefoldHomology.starLeftHomologyMap n a =
+      (ThreefoldHomology.starOverlapToRegularHomologyMap n a,
+        -ThreefoldHomology.starOverlapToFillingsHomologyMap n a) :=
+  rfl
+
+@[simp]
+private theorem ThreefoldHomology.CapElimination.starRight_regular (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily n) :
+    ThreefoldHomology.starRightHomologyMap n (a, 0) =
+      SingularMayerVietoris.singularHomologyMap ThreefoldHomology.originalRegularInclusion n a := by
+  change
+    SingularMayerVietoris.singularHomologyMap ThreefoldHomology.originalRegularInclusion n a +
+        ThreefoldHomology.starFillingsToSpaceHomologyMap n 0 =
+      _
+  rw [map_zero, add_zero]
+
+private theorem ThreefoldHomology.CapElimination.regularInclusion_kernel (n : ℕ) :
+    LinearMap.ker
+        (SingularMayerVietoris.singularHomologyMap ThreefoldHomology.originalRegularInclusion n) =
+      capKernelRegularImage n := by
+  ext a
+  change
+    SingularMayerVietoris.singularHomologyMap ThreefoldHomology.originalRegularInclusion n a = 0 ↔
+      ∃ b : LinearMap.ker (ThreefoldHomology.starOverlapToFillingsHomologyMap n),
+        capKernelRegularMap n b = a
+  constructor
+  · intro ha
+    have hright : ThreefoldHomology.starRightHomologyMap n (a, 0) = 0 :=
+      (starRight_regular n a).trans ha
+    obtain ⟨b, hb⟩ := (ThreefoldHomology.star_exact_at_pair n (a, 0)).mp hright
+    have hreg : ThreefoldHomology.starOverlapToRegularHomologyMap n b = a := congrArg Prod.fst hb
+    have hcap : ThreefoldHomology.starOverlapToFillingsHomologyMap n b = 0 := by
+      have hneg : -ThreefoldHomology.starOverlapToFillingsHomologyMap n b = 0 :=
+        congrArg Prod.snd hb
+      exact neg_eq_zero.mp hneg
+    exact ⟨⟨b, hcap⟩, hreg⟩
+  · rintro ⟨b, hb⟩
+    have hcap : ThreefoldHomology.starOverlapToFillingsHomologyMap n b.val = 0 := b.property
+    have hleft : ThreefoldHomology.starLeftHomologyMap n b.val = (a, 0) := by
+      rw [starLeft_regular_fillings, hcap, neg_zero]
+      exact Prod.ext hb rfl
+    have hright := (ThreefoldHomology.star_exact_at_pair n).apply_apply_eq_zero b.val
+    rw [hleft, starRight_regular] at hright
+    exact hright
+
+private theorem ThreefoldHomology.CapElimination.regularInclusion_two_surjective :
+    Function.Surjective
+      (SingularMayerVietoris.singularHomologyMap ThreefoldHomology.originalRegularInclusion 2) := by
+  intro x
+  obtain ⟨p, hp⟩ := ThreefoldHomology.SecondDegree.starRight_two_surjective x
+  obtain ⟨a, ha⟩ := starOverlapToFillingsHomologyMap_surjective 2 (-p.2)
+  have hshape :
+    p - ThreefoldHomology.starLeftHomologyMap 2 a =
+      (p.1 - ThreefoldHomology.starOverlapToRegularHomologyMap 2 a, 0) := by
+    rw [starLeft_regular_fillings]
+    apply Prod.ext
+    · rfl
+    · change p.2 - -ThreefoldHomology.starOverlapToFillingsHomologyMap 2 a = 0
+      rw [ha, neg_neg, sub_self]
+  refine ⟨p.1 - ThreefoldHomology.starOverlapToRegularHomologyMap 2 a, ?_⟩
+  calc
+    SingularMayerVietoris.singularHomologyMap ThreefoldHomology.originalRegularInclusion 2
+          (p.1 - ThreefoldHomology.starOverlapToRegularHomologyMap 2 a) =
+        ThreefoldHomology.starRightHomologyMap 2
+          (p.1 - ThreefoldHomology.starOverlapToRegularHomologyMap 2 a, 0) :=
+      (starRight_regular 2 _).symm
+    _ =
+        ThreefoldHomology.starRightHomologyMap 2
+          (p - ThreefoldHomology.starLeftHomologyMap 2 a) :=
+      (congrArg (ThreefoldHomology.starRightHomologyMap 2) hshape.symm)
+    _ =
+        ThreefoldHomology.starRightHomologyMap 2 p -
+          ThreefoldHomology.starRightHomologyMap 2 (ThreefoldHomology.starLeftHomologyMap 2 a) :=
+      (map_sub _ _ _)
+    _ = x := by rw [hp, (ThreefoldHomology.star_exact_at_pair 2).apply_apply_eq_zero a, sub_zero]
+
+private abbrev
+    ThreefoldHomology.CapElimination.NativeCapKernel (i : SpecialPeriods.Threefold.Puncture)
+    (n : ℕ) :=
+  LinearMap.ker (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap i n)
+
+private def ThreefoldHomology.CapElimination.nativeCapKernelRegularMap (n : ℕ) :
+    (∀ i : SpecialPeriods.Threefold.Puncture, NativeCapKernel i n) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily n :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun
+        a :=
+        ∑ i : SpecialPeriods.Threefold.Puncture,
+          ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap i n (a i).val
+      map_zero' := by
+        simp only [Pi.zero_apply, Submodule.coe_zero, map_zero, Finset.sum_const_zero]
+      map_add' a
+        b := by simp only [Pi.add_apply, Submodule.coe_add, map_add, Finset.sum_add_distrib] }
+
+@[simp]
+private theorem ThreefoldHomology.CapElimination.nativeCapKernelRegularMap_apply (n : ℕ)
+    (a : ∀ i : SpecialPeriods.Threefold.Puncture, NativeCapKernel i n) :
+    nativeCapKernelRegularMap n a =
+      ∑ i : SpecialPeriods.Threefold.Puncture,
+        ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap i n (a i).val :=
+  rfl
+
+private def ThreefoldHomology.CapElimination.nativeCapKernelEquiv (n : ℕ) :
+    LinearMap.ker (ThreefoldHomology.starOverlapToFillingsHomologyMap n) ≃ₗ[ℤ]
+      (∀ i : SpecialPeriods.Threefold.Puncture, NativeCapKernel i n) :=
+  ({    toFun a
+          i :=
+          ⟨ThreefoldOverlapMappingTorus.overlapHomologyEquiv i n (a.val i),
+            by
+            have h :=
+              LinearMap.congr_fun
+                (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap_retraction i n) (a.val i)
+            exact h.trans (congrFun a.property i)⟩
+        invFun
+          a :=
+          ⟨fun i => (ThreefoldOverlapMappingTorus.overlapHomologyEquiv i n).symm (a i).val,
+            by
+            funext i
+            have h :=
+              LinearMap.congr_fun
+                (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap_retraction i n)
+                ((ThreefoldOverlapMappingTorus.overlapHomologyEquiv i n).symm (a i).val)
+            have hz :=
+              (congrArg (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap i n)
+                    ((ThreefoldOverlapMappingTorus.overlapHomologyEquiv i n).apply_symm_apply
+                      (a i).val)).trans
+                (a i).property
+            exact h.symm.trans hz⟩
+        left_inv
+          a := by
+          apply Subtype.ext
+          funext i
+          exact (ThreefoldOverlapMappingTorus.overlapHomologyEquiv i n).symm_apply_apply (a.val i)
+        right_inv
+          a := by
+          funext i
+          apply Subtype.ext
+          exact (ThreefoldOverlapMappingTorus.overlapHomologyEquiv i n).apply_symm_apply (a i).val
+        map_add' a
+          b := by
+          funext i
+          apply Subtype.ext
+          exact
+            (ThreefoldOverlapMappingTorus.overlapHomologyEquiv i n).map_add (a.val i)
+              (b.val i) } :
+      LinearMap.ker (ThreefoldHomology.starOverlapToFillingsHomologyMap n) ≃+
+        (∀ i : SpecialPeriods.Threefold.Puncture, NativeCapKernel i n)).toIntLinearEquiv
+
+private theorem ThreefoldHomology.CapElimination.nativeCapKernelRegularMap_equiv (n : ℕ)
+    (a : LinearMap.ker (ThreefoldHomology.starOverlapToFillingsHomologyMap n)) :
+    nativeCapKernelRegularMap n (nativeCapKernelEquiv n a) = capKernelRegularMap n a := by
+  change
+    (∑ i : SpecialPeriods.Threefold.Puncture,
+        ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap i n
+          (ThreefoldOverlapMappingTorus.overlapHomologyEquiv i n (a.val i))) =
+      ∑ i : SpecialPeriods.Threefold.Puncture,
+        SingularMayerVietoris.singularHomologyMap (ThreefoldHomology.overlapToRegularFamily i) n
+          (a.val i)
+  apply Finset.sum_congr rfl
+  intro i _
+  exact
+    LinearMap.congr_fun (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap_retraction i n)
+      (a.val i)
+
+private theorem ThreefoldHomology.CapElimination.nativeCapKernelRegularMap_range (n : ℕ) :
+    LinearMap.range (nativeCapKernelRegularMap n) = capKernelRegularImage n := by
+  ext r
+  constructor
+  · rintro ⟨a, ha⟩
+    refine ⟨(nativeCapKernelEquiv n).symm a, ?_⟩
+    rw [← nativeCapKernelRegularMap_equiv, LinearEquiv.apply_symm_apply]
+    exact ha
+  · rintro ⟨a, ha⟩
+    exact ⟨nativeCapKernelEquiv n a, (nativeCapKernelRegularMap_equiv n a).trans ha⟩
+
+private theorem ThreefoldHomology.CapElimination.regularInclusion_native_kernel (n : ℕ) :
+    LinearMap.ker
+        (SingularMayerVietoris.singularHomologyMap ThreefoldHomology.originalRegularInclusion n) =
+      LinearMap.range (nativeCapKernelRegularMap n) :=
+  (regularInclusion_kernel n).trans (nativeCapKernelRegularMap_range n).symm
+
+private theorem ThreefoldHomology.CapElimination.regularInclusion_eq_zero_iff_native (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily n) :
+    SingularMayerVietoris.singularHomologyMap ThreefoldHomology.originalRegularInclusion n a = 0 ↔
+      ∃ b : ∀ i : SpecialPeriods.Threefold.Puncture, NativeCapKernel i n,
+        nativeCapKernelRegularMap n b = a := by
+  change
+    a ∈
+        LinearMap.ker
+          (SingularMayerVietoris.singularHomologyMap ThreefoldHomology.originalRegularInclusion
+            n) ↔
+      _
+  rw [regularInclusion_native_kernel]
+  rfl
+
+private theorem
+    ThreefoldHomology.CapElimination.homologyTwo_subsingleton_iff_nativeCapKernel_surjective :
+    Subsingleton (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 2) ↔
+      Function.Surjective (nativeCapKernelRegularMap 2) := by
+  constructor
+  · intro h a
+    exact (regularInclusion_eq_zero_iff_native 2 a).mp (h.elim _ _)
+  · intro h
+    have hz (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 2) :
+      a = 0 := by
+      obtain ⟨b, rfl⟩ := regularInclusion_two_surjective a
+      exact (regularInclusion_eq_zero_iff_native 2 b).mpr (h b)
+    exact ⟨fun a b => (hz a).trans (hz b).symm⟩
+
+private theorem ThreefoldHomology.FourthWang.commonCubeInvariant_iff (v : Fin 4 → ℤ) :
+    (PeriodTorusHigherHomologyExterior.cubeA₁ *ᵥ v = v ∧
+        PeriodTorusHigherHomologyExterior.cubeA₂ *ᵥ v = v) ↔
+      v = Pi.single 3 (v 3) := by
+  constructor
+  · rintro ⟨h₁, h₂⟩
+    have h11 := congrFun h₁ 1
+    have h13 := congrFun h₁ 3
+    have h21 := congrFun h₂ 1
+    simp [PeriodTorusHigherHomologyExterior.cubeA₁_eq,
+      PeriodTorusHigherHomologyExterior.cubeA₂_eq, Matrix.mulVec, dotProduct,
+      Fin.sum_univ_succ] at h11 h13 h21
+    have hz : v 0 = 0 ∧ v 1 = 0 ∧ v 2 = 0 := by omega
+    ext i
+    fin_cases i <;> simp [hz.1, hz.2.1, hz.2.2]
+  · intro h
+    rw [h]
+    constructor <;> ext i <;> fin_cases i <;>
+      simp [PeriodTorusHigherHomologyExterior.cubeA₁_eq,
+        PeriodTorusHigherHomologyExterior.cubeA₂_eq, Matrix.mulVec, dotProduct, Fin.sum_univ_succ]
+
+private theorem ThreefoldHomology.FourthWang.commonThirdInvariant_iff
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 3) :
+    (PeriodFamily.Homology.generatorHomologyEquiv Bool.false 3 a = a ∧
+        PeriodFamily.Homology.generatorHomologyEquiv Bool.true 3 a = a) ↔
+      PeriodFamily.FlatTorus.singularH3Coordinates a =
+        Pi.single 3 (PeriodFamily.FlatTorus.singularH3Coordinates a 3) := by
+  rw [← commonCubeInvariant_iff]
+  constructor
+  · rintro ⟨h₁, h₂⟩
+    constructor
+    · have h := congrArg PeriodFamily.FlatTorus.singularH3Coordinates h₁
+      simpa only [PeriodFamily.HomologyDifference.generatorHomologyThree_coordinates,
+        Bool.false_eq_true, ite_false] using h
+    · have h := congrArg PeriodFamily.FlatTorus.singularH3Coordinates h₂
+      simpa only [PeriodFamily.HomologyDifference.generatorHomologyThree_coordinates,
+        ite_true] using h
+  · rintro ⟨h₁, h₂⟩
+    constructor
+    · apply PeriodFamily.FlatTorus.singularH3Coordinates.injective
+      simpa only [PeriodFamily.HomologyDifference.generatorHomologyThree_coordinates,
+        Bool.false_eq_true, ite_false] using h₁
+    · apply PeriodFamily.FlatTorus.singularH3Coordinates.injective
+      simpa only [PeriodFamily.HomologyDifference.generatorHomologyThree_coordinates,
+        ite_true] using h₂
+
+private def ThreefoldHomology.FourthWang.regularSourcePair (n : ℕ) :
+    SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily
+        (n + 1) →ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+        SingularMayerVietoris.SingularHomology RealTorus₄ n) :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun := fun a =>
+        (PeriodFamily.Homology.sourceKernelProjection
+            (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)
+            n a).val
+      map_zero' :=
+        congrArg Subtype.val
+          (map_zero
+            (PeriodFamily.Homology.sourceKernelProjection
+              (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                SpecialPeriods.specialPeriodMap_generator₁
+                SpecialPeriods.specialPeriodMap_generator₂)
+              n))
+      map_add' := fun a b =>
+        congrArg Subtype.val
+          (map_add
+            (PeriodFamily.Homology.sourceKernelProjection
+              (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                SpecialPeriods.specialPeriodMap_generator₁
+                SpecialPeriods.specialPeriodMap_generator₂)
+              n)
+            a b) }
+
+@[simp]
+private theorem ThreefoldHomology.FourthWang.regularSourcePair_apply (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily
+        (n + 1)) :
+    regularSourcePair n a =
+      (PeriodFamily.Homology.sourceKernelProjection
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          n a).val :=
+  rfl
+
+private def
+    ThreefoldHomology.FourthWang.overlapWangHomologyMap (i : SpecialPeriods.Threefold.Puncture)
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i)
+        (n + 1) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology RealTorus₄ n :=
+  (MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy i) n).comp
+    (ThreefoldOverlapMappingTorus.overlapHomologyEquiv i (n + 1)).toLinearMap
+
+private def
+    ThreefoldHomology.FourthWang.sourceColumn (i : SpecialPeriods.Threefold.Puncture) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+      SingularMayerVietoris.SingularHomology RealTorus₄ n :=
+  match i with
+  | none =>
+    (-PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleGenerator₁⁻¹ n a, -a)
+  | some .three => (a, 0)
+  | some .four => (0, a)
+
+private theorem ThreefoldHomology.FourthWang.regularSourcePair_boundary
+    (i : SpecialPeriods.Threefold.Puncture) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology (ThreefoldOverlapMappingTorus.Boundary i) (n + 1)) :
+    regularSourcePair n (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap i (n + 1) a) =
+      sourceColumn i n
+        (MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy i) n a) := by
+  rw [regularSourcePair_apply]
+  cases i with
+  | none =>
+    simpa only [sourceColumn, ThreefoldOverlapMappingTorus.monodromy] using!
+      (PeriodFamily.Boundary.Cusp.boundary_sourceKernelProjection n a)
+  | some j =>
+    cases j with
+    | three =>
+      simpa only [sourceColumn, ThreefoldOverlapMappingTorus.monodromy] using!
+        (PeriodFamily.Boundary.ellipticThreeBoundary_sourceKernelProjection n a)
+    | four =>
+      simpa only [sourceColumn, ThreefoldOverlapMappingTorus.monodromy] using!
+        (PeriodFamily.Boundary.ellipticFourBoundary_sourceKernelProjection n a)
+
+private theorem ThreefoldHomology.FourthWang.regularSourcePair_overlap
+    (i : SpecialPeriods.Threefold.Puncture) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i)
+        (n + 1)) :
+    regularSourcePair n
+        (SingularMayerVietoris.singularHomologyMap (ThreefoldHomology.overlapToRegularFamily i)
+          (n + 1) a) =
+      sourceColumn i n (overlapWangHomologyMap i n a) := by
+  have h :=
+    LinearMap.congr_fun
+      (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap_retraction i (n + 1)) a
+  change
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap i (n + 1)
+        (ThreefoldOverlapMappingTorus.overlapHomologyEquiv i (n + 1) a) =
+      SingularMayerVietoris.singularHomologyMap (ThreefoldHomology.overlapToRegularFamily i)
+        (n + 1) a at h
+  rw [← h]
+  exact regularSourcePair_boundary i n _
+
+private theorem ThreefoldHomology.FourthWang.regularSourcePair_star (n : ℕ)
+    (a : ThreefoldHomology.StarOverlapHomology (n + 1)) :
+    regularSourcePair n (ThreefoldHomology.starOverlapToRegularHomologyMap (n + 1) a) =
+      (overlapWangHomologyMap (Option.some .three) n (a (Option.some .three)) -
+          PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleGenerator₁⁻¹ n
+            (overlapWangHomologyMap Option.none n (a Option.none)),
+        overlapWangHomologyMap (Option.some .four) n (a (Option.some .four)) -
+          overlapWangHomologyMap Option.none n (a Option.none)) := by
+  classical
+  rw [ThreefoldHomology.starOverlapToRegularHomologyMap_apply, map_sum]
+  simp only [regularSourcePair_overlap]
+  rw [Fintype.sum_option]
+  have hu : (Finset.univ : Finset Elliptic.Kind) = {.three, .four} := by
+    ext j
+    cases j <;> simp
+  rw [hu, Finset.sum_pair (by decide : Elliptic.Kind.three ≠ .four)]
+  simp only [sourceColumn, Prod.mk_add_mk, add_zero, zero_add, sub_eq_add_neg]
+  exact Prod.ext (add_comm _ _) (add_comm _ _)
+
+private theorem ThreefoldHomology.FourthWang.wang_cancellation (n : ℕ)
+    (a : ThreefoldHomology.StarOverlapHomology (n + 1))
+    (ha : ThreefoldHomology.starOverlapToRegularHomologyMap (n + 1) a = 0) :
+    overlapWangHomologyMap (Option.some .three) n (a (Option.some .three)) =
+        overlapWangHomologyMap Option.none n (a Option.none) ∧
+      overlapWangHomologyMap (Option.some .four) n (a (Option.some .four)) =
+          overlapWangHomologyMap Option.none n (a Option.none) ∧
+        PeriodFamily.Homology.generatorHomologyEquiv Bool.false n
+              (overlapWangHomologyMap Option.none n (a Option.none)) =
+            overlapWangHomologyMap Option.none n (a Option.none) ∧
+          PeriodFamily.Homology.generatorHomologyEquiv Bool.true n
+              (overlapWangHomologyMap Option.none n (a Option.none)) =
+            overlapWangHomologyMap Option.none n (a Option.none) := by
+  let w₀ := overlapWangHomologyMap Option.none n (a Option.none)
+  let w₃ := overlapWangHomologyMap (Option.some .three) n (a (Option.some .three))
+  let w₄ := overlapWangHomologyMap (Option.some .four) n (a (Option.some .four))
+  have h := regularSourcePair_star n a
+  rw [ha, map_zero] at h
+  have h₃ :
+    w₃ = PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleGenerator₁⁻¹ n w₀ :=
+    sub_eq_zero.mp (congrArg Prod.fst h).symm
+  have h₄ : w₄ = w₀ := sub_eq_zero.mp (congrArg Prod.snd h).symm
+  have hf₃ : PeriodFamily.Homology.generatorHomologyEquiv Bool.false n w₃ = w₃ :=
+    PeriodFamily.Boundary.ellipticWangBoundary_generator_fixed .three Elliptic.Kind.three.twist n
+      (ThreefoldOverlapMappingTorus.overlapHomologyEquiv (Option.some .three) (n + 1) _)
+  have hf₄ : PeriodFamily.Homology.generatorHomologyEquiv Bool.true n w₄ = w₄ :=
+    PeriodFamily.Boundary.ellipticWangBoundary_generator_fixed .four Elliptic.Kind.four.twist n
+      (ThreefoldOverlapMappingTorus.overlapHomologyEquiv (Option.some .four) (n + 1) _)
+  have he₃ : w₃ = w₀ := by
+    rw [PeriodFamily.Homology.triangleHomologyEquiv_inv] at h₃
+    calc
+      w₃ = PeriodFamily.Homology.generatorHomologyEquiv Bool.false n w₃ := hf₃.symm
+      _ =
+          PeriodFamily.Homology.generatorHomologyEquiv Bool.false n
+            ((PeriodFamily.Homology.generatorHomologyEquiv Bool.false n).symm w₀) :=
+        (congrArg (PeriodFamily.Homology.generatorHomologyEquiv Bool.false n) h₃)
+      _ = w₀ := LinearEquiv.apply_symm_apply _ _
+  refine ⟨he₃, h₄, ?_, ?_⟩
+  · simpa only [he₃] using hf₃
+  · simpa only [h₄] using hf₄
+
+private def ThreefoldHomology.CapElimination.nativeCapKernelSourceMap (n : ℕ) :
+    (∀ i : SpecialPeriods.Threefold.Puncture, NativeCapKernel i (n + 1)) →ₗ[ℤ]
+      LinearMap.ker (PeriodFamily.Homology.sourceDifference n) :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun
+        a :=
+        PeriodFamily.Homology.sourceKernelProjection
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          n (nativeCapKernelRegularMap (n + 1) a)
+      map_zero' := by rw [map_zero, map_zero]
+      map_add' a b := by rw [map_add, map_add] }
+
+@[simp]
+private theorem ThreefoldHomology.CapElimination.nativeCapKernelSourceMap_apply (n : ℕ)
+    (a : ∀ i : SpecialPeriods.Threefold.Puncture, NativeCapKernel i (n + 1)) :
+    nativeCapKernelSourceMap n a =
+      PeriodFamily.Homology.sourceKernelProjection
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        n (nativeCapKernelRegularMap (n + 1) a) :=
+  rfl
+
+private def ThreefoldHomology.CapElimination.nativeCapKernelWangValue (n : ℕ)
+    (a : ∀ i : SpecialPeriods.Threefold.Puncture, NativeCapKernel i (n + 1))
+    (i : SpecialPeriods.Threefold.Puncture) :
+    SingularMayerVietoris.SingularHomology RealTorus₄ n :=
+  MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy i) n (a i).val
+
+private theorem ThreefoldHomology.CapElimination.nativeCapKernelSourceMap_val (n : ℕ)
+    (a : ∀ i : SpecialPeriods.Threefold.Puncture, NativeCapKernel i (n + 1)) :
+    (nativeCapKernelSourceMap n a).val =
+      (nativeCapKernelWangValue n a (Option.some .three) -
+          PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleGenerator₁⁻¹ n
+            (nativeCapKernelWangValue n a Option.none),
+        nativeCapKernelWangValue n a (Option.some .four) -
+          nativeCapKernelWangValue n a Option.none) := by
+  classical
+  change
+    ThreefoldHomology.FourthWang.regularSourcePair n (nativeCapKernelRegularMap (n + 1) a) = _
+  rw [nativeCapKernelRegularMap_apply, map_sum]
+  simp only [ThreefoldHomology.FourthWang.regularSourcePair_boundary]
+  rw [Fintype.sum_option]
+  have hu : (Finset.univ : Finset Elliptic.Kind) = {.three, .four} := by
+    ext j
+    cases j <;> simp
+  rw [hu, Finset.sum_pair (by decide : Elliptic.Kind.three ≠ .four)]
+  simp only [ThreefoldHomology.FourthWang.sourceColumn, nativeCapKernelWangValue, Prod.mk_add_mk,
+    add_zero, zero_add, sub_eq_add_neg]
+  exact Prod.ext (add_comm _ _) (add_comm _ _)
+
+private theorem ThreefoldHomology.CapElimination.nativeCapKernelWangValue_first_inv (n : ℕ)
+    (a : ∀ i : SpecialPeriods.Threefold.Puncture, NativeCapKernel i (n + 1)) :
+    PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleGenerator₁⁻¹ n
+        (nativeCapKernelWangValue n a Option.none) =
+      PeriodFamily.Homology.generatorHomologyEquiv Bool.true n
+        (nativeCapKernelWangValue n a Option.none) := by
+  have h :=
+    congrArg (PeriodFamily.Homology.generatorHomologyEquiv Bool.true n)
+      (PeriodFamily.Boundary.Cusp.wangBoundary_inverse_word n (a Option.none).val)
+  simpa only [LinearEquiv.apply_symm_apply, nativeCapKernelWangValue] using! h
+
+private theorem ThreefoldHomology.CapElimination.nativeCapKernelSourceMap_val_second (n : ℕ)
+    (a : ∀ i : SpecialPeriods.Threefold.Puncture, NativeCapKernel i (n + 1)) :
+    (nativeCapKernelSourceMap n a).val =
+      (nativeCapKernelWangValue n a (Option.some .three) -
+          PeriodFamily.Homology.generatorHomologyEquiv Bool.true n
+            (nativeCapKernelWangValue n a Option.none),
+        nativeCapKernelWangValue n a (Option.some .four) -
+          nativeCapKernelWangValue n a Option.none) := by
+  rw [nativeCapKernelSourceMap_val, nativeCapKernelWangValue_first_inv]
+
+private theorem ThreefoldHomology.CapElimination.nativeCapKernelSourceMap_one_coordinates
+    (a : ∀ i : SpecialPeriods.Threefold.Puncture, NativeCapKernel i 2) :
+    (PeriodFamily.FlatTorus.singularH1Equiv (nativeCapKernelSourceMap 1 a).val.1,
+        PeriodFamily.FlatTorus.singularH1Equiv (nativeCapKernelSourceMap 1 a).val.2) =
+      (PeriodFamily.FlatTorus.singularH1Equiv
+            (nativeCapKernelWangValue 1 a (Option.some .three)) -
+          A₂ *ᵥ PeriodFamily.FlatTorus.singularH1Equiv (nativeCapKernelWangValue 1 a Option.none),
+        PeriodFamily.FlatTorus.singularH1Equiv
+            (nativeCapKernelWangValue 1 a (Option.some .four)) -
+          PeriodFamily.FlatTorus.singularH1Equiv (nativeCapKernelWangValue 1 a Option.none)) := by
+  rw [nativeCapKernelSourceMap_val_second]
+  simp only [map_sub, PeriodFamily.HomologyDifference.generatorHomologyOne_true_coordinates]
+
+private theorem ThreefoldHomology.CapElimination.nativeCapKernelSourceMap_three_coordinates
+    (a : ∀ i : SpecialPeriods.Threefold.Puncture, NativeCapKernel i 4) :
+    (PeriodFamily.FlatTorus.singularH3Coordinates (nativeCapKernelSourceMap 3 a).val.1,
+        PeriodFamily.FlatTorus.singularH3Coordinates (nativeCapKernelSourceMap 3 a).val.2) =
+      (PeriodFamily.FlatTorus.singularH3Coordinates
+            (nativeCapKernelWangValue 3 a (Option.some .three)) -
+          PeriodTorusHigherHomologyExterior.cubeA₂ *ᵥ
+            PeriodFamily.FlatTorus.singularH3Coordinates
+              (nativeCapKernelWangValue 3 a Option.none),
+        PeriodFamily.FlatTorus.singularH3Coordinates
+            (nativeCapKernelWangValue 3 a (Option.some .four)) -
+          PeriodFamily.FlatTorus.singularH3Coordinates
+            (nativeCapKernelWangValue 3 a Option.none)) := by
+  rw [nativeCapKernelSourceMap_val_second]
+  simp only [map_sub, PeriodFamily.HomologyDifference.generatorHomologyThree_coordinates, ite_true]
+
+private def ThreefoldHomologyCuspFibre.cuspFibreCoinvariantMap (n : ℕ) :
+    (SingularMayerVietoris.SingularHomology RealTorus₄ n ⧸
+        LinearMap.range
+          (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy none)
+            n)) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.Threefold.localPiece (Option.some Option.none)) n :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun
+        a :=
+        ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none n
+          (MappingTorusHomology.cokernelInclusion (ThreefoldOverlapMappingTorus.monodromy none) n
+            a)
+      map_zero' := by rw [map_zero, map_zero]
+      map_add' a b := by rw [map_add, map_add] }
+
+@[simp]
+private theorem ThreefoldHomologyCuspFibre.cuspFibreCoinvariantMap_apply (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology RealTorus₄ n ⧸
+        LinearMap.range
+          (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy none) n)) :
+    cuspFibreCoinvariantMap n a =
+      ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none n
+        (MappingTorusHomology.cokernelInclusion (ThreefoldOverlapMappingTorus.monodromy none) n
+          a) :=
+  rfl
+
+private theorem ThreefoldHomologyCuspFibre.cuspFibreCoinvariantMap_mk (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    cuspFibreCoinvariantMap n (Submodule.Quotient.mk a) =
+      SingularMayerVietoris.singularHomologyMap
+        (ThreefoldOverlapMappingTorus.fibreToFilling Option.none) n a := by
+  rw [cuspFibreCoinvariantMap_apply, MappingTorusHomology.cokernelInclusion_mk]
+  exact
+    LinearMap.congr_fun
+      (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap_fibre Option.none n) a
+
+private theorem ThreefoldHomologyCuspFibre.cuspFibreCoinvariantMap_surjective (n : ℕ) :
+    Function.Surjective (cuspFibreCoinvariantMap n) := by
+  intro a
+  obtain ⟨b, hb⟩ := fibreToFilling_homology_surjective n a
+  exact ⟨Submodule.Quotient.mk b, (cuspFibreCoinvariantMap_mk n b).trans hb⟩
+
+private theorem ThreefoldHomologyCuspFibre.cuspWangDifference_le_fibreCap_kernel (n : ℕ) :
+    LinearMap.range
+        (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy none) n) ≤
+      LinearMap.ker
+        (SingularMayerVietoris.singularHomologyMap
+          (ThreefoldOverlapMappingTorus.fibreToFilling Option.none) n) := by
+  intro a ha
+  have hq :
+    (Submodule.Quotient.mk a :
+        SingularMayerVietoris.SingularHomology RealTorus₄ n ⧸
+          LinearMap.range
+            (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy none)
+              n)) =
+      0 :=
+    (Submodule.Quotient.mk_eq_zero _).mpr ha
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (ThreefoldOverlapMappingTorus.fibreToFilling Option.none) n a =
+      0
+  rw [← cuspFibreCoinvariantMap_mk, hq, map_zero]
+
+private abbrev ThreefoldHomologyCuspFibre.CuspWangCokernel (n : ℕ) :=
+  SingularMayerVietoris.SingularHomology RealTorus₄ n ⧸
+    LinearMap.range
+      (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy none) n)
+
+private def ThreefoldHomologyCuspFibre.cuspTorusHomologyEquiv (n : ℕ) :
+    SingularMayerVietoris.SingularHomology RealTorus₄ n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) n :=
+  PeriodTorusHigherHomology.homeomorphHomologyEquiv
+    PeriodTorusHigherHomology.flatTorusCircleHomeomorph n
+
+private theorem ThreefoldHomologyCuspFibre.cuspTorusHomologyEquiv_monodromy (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    cuspTorusHomologyEquiv n
+        (MappingTorusHomology.monodromyHomologyMap (ThreefoldOverlapMappingTorus.monodromy none) n
+          a) =
+      SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀) n
+        (cuspTorusHomologyEquiv n a) := by
+  have h :=
+    PeriodFamily.FlatTorus.flatTorusCircleHomology_triangle_apply
+      SpecialPeriods.triangleCuspGenerator n a
+  rw [SpecialPeriods.triangleDualRepresentation_cusp_matrix] at h
+  have hm := LinearMap.congr_fun (PeriodFamily.Boundary.Cusp.monodromyHomology_triangle n) a
+  exact (congrArg (cuspTorusHomologyEquiv n) hm).trans h
+
+private theorem ThreefoldHomologyCuspFibre.cuspWangDifference_conjugacy (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    cuspTorusHomologyEquiv n
+        (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy none) n a) =
+      (-CuspCoinvariants.torusDifference n) (cuspTorusHomologyEquiv n a) := by
+  change
+    cuspTorusHomologyEquiv n
+        (a -
+          MappingTorusHomology.monodromyHomologyMap (ThreefoldOverlapMappingTorus.monodromy none)
+            n a) =
+      _
+  rw [map_sub, cuspTorusHomologyEquiv_monodromy, LinearMap.neg_apply,
+    CuspCoinvariants.torusDifference_apply]
+  abel
+
+private theorem ThreefoldHomologyCuspFibre.cuspWangDifference_range_map (n : ℕ) :
+    (LinearMap.range
+            (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy none)
+              n)).map
+        (cuspTorusHomologyEquiv n).toLinearMap =
+      LinearMap.range (CuspCoinvariants.torusDifference n) := by
+  have h :=
+    CuspCoinvariants.map_range_of_intertwines (cuspTorusHomologyEquiv n)
+      (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy none) n)
+      (-CuspCoinvariants.torusDifference n) (cuspWangDifference_conjugacy n)
+  rw [LinearMap.range_neg] at h
+  exact h
+
+private def ThreefoldHomologyCuspFibre.cuspWangCokernelTorusAddEquiv_mo1973_27172 (n : ℕ) :
+    CuspWangCokernel n ≃+ CuspCoinvariants.TorusCoinvariants n := by
+  letI :=
+    Submodule.Quotient.module
+      (LinearMap.range
+        (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy none) n))
+  letI := Submodule.Quotient.module (LinearMap.range (CuspCoinvariants.torusDifference n))
+  exact
+    (Submodule.Quotient.equiv
+        (LinearMap.range
+          (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy none) n))
+        (LinearMap.range (CuspCoinvariants.torusDifference n)) (cuspTorusHomologyEquiv n)
+        (cuspWangDifference_range_map n)).toAddEquiv
+
+private def ThreefoldHomologyCuspFibre.cuspWangCokernelTorusEquiv (n : ℕ) :
+    CuspWangCokernel n ≃ₗ[ℤ] CuspCoinvariants.TorusCoinvariants n :=
+  (cuspWangCokernelTorusAddEquiv_mo1973_27172 n).toIntLinearEquiv
+
+private def
+    ThreefoldHomologyCuspFibre.cuspWangCokernelTwoEquiv : CuspWangCokernel 2 ≃ₗ[ℤ] (Fin 4 → ℤ) :=
+  ((cuspWangCokernelTorusEquiv 2).toAddEquiv.trans
+      CuspCoinvariants.torusTwoCoinvariantEquiv.toAddEquiv).toIntLinearEquiv
+
+private def ThreefoldHomologyCuspFibre.cuspWangCokernelThreeEquiv :
+    CuspWangCokernel 3 ≃ₗ[ℤ] (Fin 2 → ℤ) :=
+  ((cuspWangCokernelTorusEquiv 3).toAddEquiv.trans
+      CuspCoinvariants.torusThreeCoinvariantEquiv.toAddEquiv).toIntLinearEquiv
+
+private theorem ThreefoldHomologyCuspFibre.cuspWangDifference_zero :
+    MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy none) 0 = 0 :=
+  ThreefoldHomology.BoundaryFirst.boundaryWangDifference_zero Option.none
+
+private theorem ThreefoldHomologyCuspFibre.cuspWangDifference_four :
+    MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy none) 4 = 0 := by
+  apply LinearMap.ext
+  intro a
+  apply (cuspTorusHomologyEquiv 4).injective
+  rw [LinearMap.zero_apply, map_zero, cuspWangDifference_conjugacy, LinearMap.neg_apply,
+    CuspCoinvariants.torusDifference_apply, PeriodFamily.Homology.torusMatrixMap_M₀_homologyFour,
+    LinearMap.id_apply, sub_self, neg_zero]
+
+private def ThreefoldHomologyCuspFibre.cuspWangCokernelOfZeroAddEquiv_mo1973_27182 (n : ℕ)
+    (h :
+      MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy none) n = 0) :
+    CuspWangCokernel n ≃+ SingularMayerVietoris.SingularHomology RealTorus₄ n := by
+  letI :=
+    Submodule.Quotient.module
+      (LinearMap.range
+        (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy none) n))
+  exact
+    ((LinearMap.range
+            (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy none)
+              n)).quotEquivOfEqBot
+        (by rw [h, LinearMap.range_zero])).toAddEquiv
+
+private def ThreefoldHomologyCuspFibre.cuspWangCokernelZeroEquiv : CuspWangCokernel 0 ≃ₗ[ℤ] ℤ :=
+  ((cuspWangCokernelOfZeroAddEquiv_mo1973_27182 0 cuspWangDifference_zero).trans
+      (PeriodTorusHigherHomology.connectedHomologyZeroEquiv
+          RealTorus₄).toAddEquiv).toIntLinearEquiv
+
+private def
+    ThreefoldHomologyCuspFibre.cuspWangCokernelOneEquiv : CuspWangCokernel 1 ≃ₗ[ℤ] (Fin 2 → ℤ) :=
+  (ThreefoldHomology.BoundaryFirst.boundaryCokernelOneEquiv
+      Option.none).toAddEquiv.toIntLinearEquiv
+
+private def ThreefoldHomologyCuspFibre.cuspWangCokernelFourEquiv : CuspWangCokernel 4 ≃ₗ[ℤ] ℤ :=
+  ((cuspWangCokernelOfZeroAddEquiv_mo1973_27182 4 cuspWangDifference_four).trans
+      PeriodTorusHigherHomology.realTorusH4Equiv.toAddEquiv).toIntLinearEquiv
+
+private theorem
+    ThreefoldHomologyCuspFibre.cuspWangCokernel_subsingleton_of_four_lt {n : ℕ} (hn : 4 < n) :
+    Subsingleton (CuspWangCokernel n) := by
+  have := PeriodTorusHigherHomology.realTorus_homology_subsingleton_of_lt hn
+  infer_instance
+
+private def ThreefoldHomologyCuspFibre.cuspWangCokernelEquiv (n : ℕ) :
+    CuspWangCokernel n ≃ₗ[ℤ] (Fin (CuspCentralHomology.centralBetti n) → ℤ) :=
+  match n with
+  | 0 => cuspWangCokernelZeroEquiv.trans (LinearEquiv.funUnique (Fin 1) ℤ ℤ).symm
+  | 1 => cuspWangCokernelOneEquiv
+  | 2 => cuspWangCokernelTwoEquiv
+  | 3 => cuspWangCokernelThreeEquiv
+  | 4 => cuspWangCokernelFourEquiv.trans (LinearEquiv.funUnique (Fin 1) ℤ ℤ).symm
+  | n + 5 =>
+    by
+    have := cuspWangCokernel_subsingleton_of_four_lt (show 4 < n + 5 by omega)
+    change CuspWangCokernel (n + 5) ≃ₗ[ℤ] (Fin 0 → ℤ)
+    exact LinearEquiv.ofSubsingleton _ _
+
+private theorem ThreefoldHomologyCuspFibre.cuspWangCokernel_free (n : ℕ) :
+    Module.Free ℤ (CuspWangCokernel n) :=
+  Module.Free.of_equiv (cuspWangCokernelEquiv n).symm
+
+private theorem ThreefoldHomologyCuspFibre.cuspWangCokernel_finite (n : ℕ) :
+    Module.Finite ℤ (CuspWangCokernel n) :=
+  Module.Finite.of_surjective (cuspWangCokernelEquiv n).symm.toLinearMap
+    (cuspWangCokernelEquiv n).symm.surjective
+
+private theorem ThreefoldHomologyCuspFibre.cuspWangCokernel_finrank (n : ℕ) :
+    Module.finrank ℤ (CuspWangCokernel n) = CuspCentralHomology.centralBetti n := by
+  rw [(cuspWangCokernelEquiv n).finrank_eq]
+  exact Module.finrank_fin_fun ℤ
+
+private theorem ThreefoldHomologyCuspFibre.cuspFibreCoinvariantMap_bijective (n : ℕ) :
+    Function.Bijective (cuspFibreCoinvariantMap n) := by
+  have := cuspWangCokernel_free n
+  have := cuspWangCokernel_finite n
+  have :
+    Module.Free ℤ
+      (SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.Threefold.localPiece (Option.some Option.none)) n) :=
+    ThreefoldHomologyFinitenessCusp.fullHomology_free
+      ThreefoldOverlapMappingTorus.Cusp.specialData n
+  have :
+    Module.Finite ℤ
+      (SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.Threefold.localPiece (Option.some Option.none)) n) :=
+    ThreefoldHomologyFinitenessCusp.fullHomology_finite
+      ThreefoldOverlapMappingTorus.Cusp.specialData n
+  have hr :
+    Module.finrank ℤ
+        (SingularMayerVietoris.SingularHomology
+          (SpecialPeriods.Threefold.localPiece (Option.some Option.none)) n) =
+      CuspCentralHomology.centralBetti n :=
+    ThreefoldHomologyFinitenessCusp.fullHomology_finrank
+      ThreefoldOverlapMappingTorus.Cusp.specialData n
+  apply
+    OrzechProperty.bijective_of_surjective_of_finrank_le (cuspFibreCoinvariantMap n)
+      (cuspFibreCoinvariantMap_surjective n)
+  rw [cuspWangCokernel_finrank, hr]
+
+private def ThreefoldHomologyCuspFibre.cuspFibreCoinvariantEquiv (n : ℕ) :
+    CuspWangCokernel n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.Threefold.localPiece (Option.some Option.none)) n :=
+  LinearEquiv.ofBijective (cuspFibreCoinvariantMap n) (cuspFibreCoinvariantMap_bijective n)
+
+private theorem
+    ThreefoldHomologyCuspFibre.fibreToFilling_cusp_kernel_eq_wangDifference_range (n : ℕ) :
+    LinearMap.ker
+        (SingularMayerVietoris.singularHomologyMap
+          (ThreefoldOverlapMappingTorus.fibreToFilling Option.none) n) =
+      LinearMap.range
+        (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy none) n) := by
+  apply le_antisymm ?_ (cuspWangDifference_le_fibreCap_kernel n)
+  intro a ha
+  apply (Submodule.Quotient.mk_eq_zero _).mp
+  apply (cuspFibreCoinvariantMap_bijective n).injective
+  rw [cuspFibreCoinvariantMap_mk, map_zero]
+  exact ha
+
+private theorem ThreefoldHomologyCuspFibre.fibreToFilling_cusp_eq_zero_iff_fibreHomologyMap_eq_zero
+    (n : ℕ) (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    SingularMayerVietoris.singularHomologyMap
+          (ThreefoldOverlapMappingTorus.fibreToFilling Option.none) n a =
+        0 ↔
+      MappingTorusHomology.fibreHomologyMap (ThreefoldOverlapMappingTorus.monodromy none) n a =
+        0 := by
+  change
+    a ∈
+        LinearMap.ker
+          (SingularMayerVietoris.singularHomologyMap
+            (ThreefoldOverlapMappingTorus.fibreToFilling Option.none) n) ↔
+      a ∈
+        LinearMap.ker
+          (MappingTorusHomology.fibreHomologyMap (ThreefoldOverlapMappingTorus.monodromy none) n)
+  rw [fibreToFilling_cusp_kernel_eq_wangDifference_range,
+    MappingTorusHomology.wang_exact_at_fibre]
+
+private theorem ThreefoldHomologyCuspFibre.cuspCap_wang_eq_zero (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology (ThreefoldOverlapMappingTorus.Boundary Option.none)
+        (n + 1))
+    (hcap : ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none (n + 1) a = 0)
+    (hwang :
+      MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy none) n a = 0) :
+    a = 0 := by
+  have ha :
+    a ∈
+      LinearMap.range
+        (MappingTorusHomology.fibreHomologyMap (ThreefoldOverlapMappingTorus.monodromy none)
+          (n + 1)) := by
+    rw [MappingTorusHomology.wang_exact_at_mappingTorus
+        (ThreefoldOverlapMappingTorus.monodromy none) n]
+    exact hwang
+  obtain ⟨b, rfl⟩ := ha
+  apply (fibreToFilling_cusp_eq_zero_iff_fibreHomologyMap_eq_zero (n + 1) b).mp
+  exact
+    (LinearMap.congr_fun
+          (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap_fibre Option.none (n + 1))
+          b).symm.trans
+      hcap
+
+private theorem ThreefoldHomologyCuspFibre.cuspCap_wang_ext (n : ℕ)
+    (a b :
+      SingularMayerVietoris.SingularHomology (ThreefoldOverlapMappingTorus.Boundary Option.none)
+        (n + 1))
+    (hcap :
+      ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none (n + 1) a =
+        ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none (n + 1) b)
+    (hwang :
+      MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy none) n a =
+        MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy none) n b) :
+    a = b := by
+  apply sub_eq_zero.mp
+  apply cuspCap_wang_eq_zero n (a - b)
+  · rw [map_sub, hcap, sub_self]
+  · rw [map_sub, hwang, sub_self]
+
+private def ThreefoldHomologyCuspFibre.cuspCapKernelWangDegreeMap (n : ℕ) :
+    LinearMap.ker
+        (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none (n + 1)) →ₗ[ℤ]
+      LinearMap.ker
+        (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy none) n) :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun
+        a :=
+        MappingTorusHomology.kernelBoundary (ThreefoldOverlapMappingTorus.monodromy none) n a.val
+      map_zero' :=
+        (MappingTorusHomology.kernelBoundary (ThreefoldOverlapMappingTorus.monodromy none)
+            n).map_zero
+      map_add' a
+        b :=
+        (MappingTorusHomology.kernelBoundary (ThreefoldOverlapMappingTorus.monodromy none)
+              n).map_add
+          a.val b.val }
+
+private theorem ThreefoldHomologyCuspFibre.cuspCapKernelWangDegreeMap_injective (n : ℕ) :
+    Function.Injective (cuspCapKernelWangDegreeMap n) := by
+  intro a b hab
+  apply Subtype.ext
+  apply cuspCap_wang_ext n a.val b.val
+  · exact a.property.trans b.property.symm
+  · exact congrArg Subtype.val hab
+
+private theorem ThreefoldHomologyCuspFibre.cuspWang_cokernelInclusion_zero (n : ℕ)
+    (a : CuspWangCokernel (n + 1)) :
+    MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy none) n
+        (MappingTorusHomology.cokernelInclusion (ThreefoldOverlapMappingTorus.monodromy none)
+          (n + 1) a) =
+      0 := by
+  have ha :
+    MappingTorusHomology.cokernelInclusion (ThreefoldOverlapMappingTorus.monodromy none) (n + 1)
+        a ∈
+      LinearMap.range
+        (MappingTorusHomology.cokernelInclusion (ThreefoldOverlapMappingTorus.monodromy none)
+          (n + 1)) :=
+    ⟨a, rfl⟩
+  rw [MappingTorusHomology.cokernelInclusion_range_eq_ker_kernelBoundary
+      (ThreefoldOverlapMappingTorus.monodromy none) n] at ha
+  exact congrArg Subtype.val ha
+
+private def ThreefoldHomologyCuspFibre.cuspCapCorrectionDegree (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology (ThreefoldOverlapMappingTorus.Boundary Option.none)
+        (n + 1)) :
+    LinearMap.ker (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none (n + 1)) :=
+  ⟨a -
+      MappingTorusHomology.cokernelInclusion (ThreefoldOverlapMappingTorus.monodromy none) (n + 1)
+        ((cuspFibreCoinvariantEquiv (n + 1)).symm
+          (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none (n + 1) a)),
+    by
+    change ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none (n + 1) (a - _) = 0
+    rw [map_sub]
+    exact
+      sub_eq_zero.mpr
+        ((cuspFibreCoinvariantEquiv (n + 1)).apply_symm_apply
+            (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none (n + 1) a)).symm⟩
+
+private theorem ThreefoldHomologyCuspFibre.cuspCapCorrectionDegree_wang (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology (ThreefoldOverlapMappingTorus.Boundary Option.none)
+        (n + 1)) :
+    cuspCapKernelWangDegreeMap n (cuspCapCorrectionDegree n a) =
+      MappingTorusHomology.kernelBoundary (ThreefoldOverlapMappingTorus.monodromy none) n a := by
+  apply Subtype.ext
+  change
+    MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy none) n
+        (a -
+          MappingTorusHomology.cokernelInclusion (ThreefoldOverlapMappingTorus.monodromy none)
+            (n + 1) _) =
+      MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy none) n a
+  rw [map_sub, cuspWang_cokernelInclusion_zero, sub_zero]
+
+private theorem ThreefoldHomologyCuspFibre.cuspCapKernelWangDegreeMap_surjective (n : ℕ) :
+    Function.Surjective (cuspCapKernelWangDegreeMap n) := by
+  intro a
+  obtain ⟨b, hb⟩ :=
+    MappingTorusHomology.kernelBoundary_surjective (ThreefoldOverlapMappingTorus.monodromy none) n
+      a
+  exact ⟨cuspCapCorrectionDegree n b, (cuspCapCorrectionDegree_wang n b).trans hb⟩
+
+private def ThreefoldHomologyCuspFibre.cuspCapKernelWangEquivDegree (n : ℕ) :
+    LinearMap.ker
+        (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none (n + 1)) ≃ₗ[ℤ]
+      LinearMap.ker
+        (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy none) n) :=
+  LinearEquiv.ofBijective (cuspCapKernelWangDegreeMap n)
+    ⟨cuspCapKernelWangDegreeMap_injective n, cuspCapKernelWangDegreeMap_surjective n⟩
+
+private theorem ThreefoldHomologyCuspFibre.cuspCapKernelWangEquivDegree_symm_wang (n : ℕ)
+    (a :
+      LinearMap.ker
+        (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy none) n)) :
+    MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy none) n
+        ((cuspCapKernelWangEquivDegree n).symm a).val =
+      a.val :=
+  congrArg Subtype.val ((cuspCapKernelWangEquivDegree n).apply_symm_apply a)
+
+private def ThreefoldHomology.CapElimination.ellipticOneClass (j : Elliptic.Kind) (a : Fin 2 → ℤ) :
+    NativeCapKernel (Option.some j) 2 :=
+  (PeriodFamily.Boundary.EllipticCapProduct.boundaryCapKernelEquiv j 1).symm
+    ((Elliptic.HigherHomology.surfaceH1Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).symm
+      a)
+
+private theorem ThreefoldHomology.CapElimination.ellipticOneClass_wang (j : Elliptic.Kind)
+    (a : Fin 2 → ℤ) :
+    PeriodFamily.FlatTorus.singularH1Equiv
+        (MappingTorusHomology.wangBoundary
+          (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) 1 (ellipticOneClass j a).val) =
+      a 1 • j.twist +
+        ((Elliptic.HigherHomology.fibreNormIndex j : ℤ) * a 0 -
+            PeriodFamily.Boundary.EllipticCapKernelWang.h1ShearCorrection j * a 1) •
+          PeriodFamily.Boundary.EllipticCapKernelWang.deltaVector := by
+  have h :=
+    PeriodFamily.Boundary.EllipticCapKernelWang.capKernel_wang_h1_coordinates j
+      ((Elliptic.HigherHomology.surfaceH1Equiv j
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).symm
+        a)
+  simpa only [LinearEquiv.apply_symm_apply, ellipticOneClass] using! h
+
+private def
+    ThreefoldHomology.CapElimination.ellipticThreeClass (j : Elliptic.Kind) (a : Fin 2 → ℤ) :
+    NativeCapKernel (Option.some j) 4 :=
+  (PeriodFamily.Boundary.EllipticCapProduct.boundaryCapH4KernelEquiv j).symm a
+
+private theorem ThreefoldHomology.CapElimination.ellipticThreeClass_wang (j : Elliptic.Kind)
+    (a : Fin 2 → ℤ) :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (MappingTorusHomology.wangBoundary
+          (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) 3
+          (ellipticThreeClass j a).val) =
+      PeriodFamily.Boundary.EllipticCapKernelWang.topWangMatrix j
+          (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearThree j) *ᵥ
+        a :=
+  PeriodFamily.Boundary.EllipticCapKernelWang.capKernelWangH4Coordinates_symm j a
+
+private theorem ThreefoldHomology.CapElimination.cuspMonodromy_three_coordinates
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 3) :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (MappingTorusHomology.monodromyHomologyMap
+          (ThreefoldOverlapMappingTorus.monodromy Option.none) 3 a) =
+      PeriodTorusHigherHomologyExterior.cubeM₀ *ᵥ
+        PeriodFamily.FlatTorus.singularH3Coordinates a := by
+  have h := LinearMap.congr_fun (PeriodFamily.Boundary.Cusp.monodromyHomology_triangle 3) a
+  have h' :
+    MappingTorusHomology.monodromyHomologyMap (ThreefoldOverlapMappingTorus.monodromy Option.none)
+        3 a =
+      PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleCuspGenerator 3 a :=
+    h
+  rw [h']
+  change
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (SingularMayerVietoris.singularHomologyMap
+          (SpecialPeriods.triangleTorusHomeomorph SpecialPeriods.triangleCuspGenerator :
+            C(RealTorus₄, RealTorus₄))
+          3 a) =
+      _
+  rw [PeriodFamily.FlatTorus.singularH3Coordinates_inducedHomology_triangle,
+    SpecialPeriods.triangleDualRepresentation_cusp_matrix]
+  rfl
+
+private def ThreefoldHomology.CapElimination.cuspOneInvariant (v : Lattice) (hv : M₀ *ᵥ v = v) :
+    LinearMap.ker
+      (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy Option.none)
+        1) :=
+  ⟨PeriodFamily.FlatTorus.singularH1Equiv.symm v,
+    by
+    apply PeriodFamily.FlatTorus.singularH1Equiv.injective
+    change
+      PeriodFamily.FlatTorus.singularH1Equiv
+          (PeriodFamily.FlatTorus.singularH1Equiv.symm v -
+            MappingTorusHomology.monodromyHomologyMap
+              (ThreefoldOverlapMappingTorus.monodromy Option.none) 1
+              (PeriodFamily.FlatTorus.singularH1Equiv.symm v)) =
+        _
+    rw [map_sub, ThreefoldHomology.BoundaryFirst.boundaryMonodromy_one_coordinates,
+      LinearEquiv.apply_symm_apply, map_zero]
+    exact sub_eq_zero.mpr hv.symm⟩
+
+private def ThreefoldHomology.CapElimination.cuspThreeInvariant (v : Lattice)
+    (hv : PeriodTorusHigherHomologyExterior.cubeM₀ *ᵥ v = v) :
+    LinearMap.ker
+      (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy Option.none)
+        3) :=
+  ⟨PeriodFamily.FlatTorus.singularH3Coordinates.symm v,
+    by
+    apply PeriodFamily.FlatTorus.singularH3Coordinates.injective
+    change
+      PeriodFamily.FlatTorus.singularH3Coordinates
+          (PeriodFamily.FlatTorus.singularH3Coordinates.symm v -
+            MappingTorusHomology.monodromyHomologyMap
+              (ThreefoldOverlapMappingTorus.monodromy Option.none) 3
+              (PeriodFamily.FlatTorus.singularH3Coordinates.symm v)) =
+        _
+    rw [map_sub, cuspMonodromy_three_coordinates, LinearEquiv.apply_symm_apply, map_zero]
+    exact sub_eq_zero.mpr hv.symm⟩
+
+private def ThreefoldHomology.CapElimination.cuspOneClass (v : Lattice) (hv : M₀ *ᵥ v = v) :
+    NativeCapKernel Option.none 2 :=
+  (ThreefoldHomologyCuspFibre.cuspCapKernelWangEquivDegree 1).symm (cuspOneInvariant v hv)
+
+private theorem
+    ThreefoldHomology.CapElimination.cuspOneClass_wang (v : Lattice) (hv : M₀ *ᵥ v = v) :
+    PeriodFamily.FlatTorus.singularH1Equiv
+        (MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy Option.none) 1
+          (cuspOneClass v hv).val) =
+      v := by
+  change
+    PeriodFamily.FlatTorus.singularH1Equiv
+        (MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy Option.none) 1
+          ((ThreefoldHomologyCuspFibre.cuspCapKernelWangEquivDegree 1).symm
+              (cuspOneInvariant v hv)).val) =
+      v
+  rw [ThreefoldHomologyCuspFibre.cuspCapKernelWangEquivDegree_symm_wang]
+  exact LinearEquiv.apply_symm_apply _ _
+
+private def ThreefoldHomology.CapElimination.cuspThreeClass (v : Lattice)
+    (hv : PeriodTorusHigherHomologyExterior.cubeM₀ *ᵥ v = v) : NativeCapKernel Option.none 4 :=
+  (ThreefoldHomologyCuspFibre.cuspCapKernelWangEquivDegree 3).symm (cuspThreeInvariant v hv)
+
+private theorem ThreefoldHomology.CapElimination.cuspThreeClass_wang (v : Lattice)
+    (hv : PeriodTorusHigherHomologyExterior.cubeM₀ *ᵥ v = v) :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy Option.none) 3
+          (cuspThreeClass v hv).val) =
+      v := by
+  change
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy Option.none) 3
+          ((ThreefoldHomologyCuspFibre.cuspCapKernelWangEquivDegree 3).symm
+              (cuspThreeInvariant v hv)).val) =
+      v
+  rw [ThreefoldHomologyCuspFibre.cuspCapKernelWangEquivDegree_symm_wang]
+  exact LinearEquiv.apply_symm_apply _ _
+
+private def ThreefoldHomology.SecondSource.nativeSourceClasses (x y : Lattice) :
+    ∀ i : SpecialPeriods.Threefold.Puncture, ThreefoldHomology.CapElimination.NativeCapKernel i 2
+  | none =>
+    ThreefoldHomology.CapElimination.cuspOneClass
+      (cuspCoordinates
+        (PeriodFamily.Boundary.EllipticCapKernelWang.h1ShearCorrection Elliptic.Kind.four) x y)
+      (cuspCoordinates_fixed
+        (PeriodFamily.Boundary.EllipticCapKernelWang.h1ShearCorrection Elliptic.Kind.four) x y)
+  | some .three =>
+    ThreefoldHomology.CapElimination.ellipticOneClass .three
+      (threeCoordinates
+        (PeriodFamily.Boundary.EllipticCapKernelWang.h1ShearCorrection Elliptic.Kind.three)
+        (PeriodFamily.Boundary.EllipticCapKernelWang.h1ShearCorrection Elliptic.Kind.four) x y)
+  | some .four => ThreefoldHomology.CapElimination.ellipticOneClass .four (fourCoordinates y)
+
+private theorem ThreefoldHomology.SecondSource.nativeSourceClasses_wang_three (x y : Lattice) :
+    PeriodFamily.FlatTorus.singularH1Equiv
+        (ThreefoldHomology.CapElimination.nativeCapKernelWangValue 1 (nativeSourceClasses x y)
+          (Option.some .three)) =
+      threeWangVector
+        (PeriodFamily.Boundary.EllipticCapKernelWang.h1ShearCorrection Elliptic.Kind.three)
+        (threeCoordinates
+          (PeriodFamily.Boundary.EllipticCapKernelWang.h1ShearCorrection Elliptic.Kind.three)
+          (PeriodFamily.Boundary.EllipticCapKernelWang.h1ShearCorrection Elliptic.Kind.four) x
+          y) := by
+  have h :=
+    ThreefoldHomology.CapElimination.ellipticOneClass_wang .three
+      (threeCoordinates
+        (PeriodFamily.Boundary.EllipticCapKernelWang.h1ShearCorrection Elliptic.Kind.three)
+        (PeriodFamily.Boundary.EllipticCapKernelWang.h1ShearCorrection Elliptic.Kind.four) x y)
+  simpa only [Elliptic.HigherHomology.fibreNormIndex_three, Nat.cast_one, one_mul,
+    Elliptic.Kind.twist, threeWangVector] using! h
+
+private theorem ThreefoldHomology.SecondSource.nativeSourceClasses_wang_four (x y : Lattice) :
+    PeriodFamily.FlatTorus.singularH1Equiv
+        (ThreefoldHomology.CapElimination.nativeCapKernelWangValue 1 (nativeSourceClasses x y)
+          (Option.some .four)) =
+      fourWangVector
+        (PeriodFamily.Boundary.EllipticCapKernelWang.h1ShearCorrection Elliptic.Kind.four)
+        (fourCoordinates y) := by
+  have h := ThreefoldHomology.CapElimination.ellipticOneClass_wang .four (fourCoordinates y)
+  simpa only [Elliptic.HigherHomology.fibreNormIndex_four, Nat.cast_ofNat, Elliptic.Kind.twist,
+    fourWangVector] using! h
+
+private theorem ThreefoldHomology.SecondSource.nativeSourceClasses_wang_cusp (x y : Lattice) :
+    PeriodFamily.FlatTorus.singularH1Equiv
+        (ThreefoldHomology.CapElimination.nativeCapKernelWangValue 1 (nativeSourceClasses x y)
+          Option.none) =
+      cuspCoordinates
+        (PeriodFamily.Boundary.EllipticCapKernelWang.h1ShearCorrection Elliptic.Kind.four) x y :=
+  ThreefoldHomology.CapElimination.cuspOneClass_wang _ _
+
+private theorem
+    ThreefoldHomology.SecondSource.nativeSourceClasses_source_coordinates (x y : Lattice)
+    (hxy : TrianglePeriodFamilyHomologyLattice.deltaOne (x, y) = 0) :
+    (PeriodFamily.FlatTorus.singularH1Equiv
+          (ThreefoldHomology.CapElimination.nativeCapKernelSourceMap 1
+                (nativeSourceClasses x y)).val.1,
+        PeriodFamily.FlatTorus.singularH1Equiv
+          (ThreefoldHomology.CapElimination.nativeCapKernelSourceMap 1
+                (nativeSourceClasses x y)).val.2) =
+      (x, y) := by
+  rw [ThreefoldHomology.CapElimination.nativeCapKernelSourceMap_one_coordinates]
+  simp only [nativeSourceClasses_wang_three, nativeSourceClasses_wang_four,
+    nativeSourceClasses_wang_cusp]
+  exact
+    Prod.ext
+      (threeCoordinates_reconstruct
+        (PeriodFamily.Boundary.EllipticCapKernelWang.h1ShearCorrection Elliptic.Kind.three)
+        (PeriodFamily.Boundary.EllipticCapKernelWang.h1ShearCorrection Elliptic.Kind.four) x y
+        hxy)
+      (fourCoordinates_reconstruct
+        (PeriodFamily.Boundary.EllipticCapKernelWang.h1ShearCorrection Elliptic.Kind.four) x y
+        hxy)
+
+private theorem ThreefoldHomology.SecondSource.nativeCapKernelSourceMap_one_surjective :
+    Function.Surjective (ThreefoldHomology.CapElimination.nativeCapKernelSourceMap 1) := by
+  intro a
+  have hxy :
+    TrianglePeriodFamilyHomologyLattice.deltaOne
+        (PeriodFamily.FlatTorus.singularH1Equiv a.val.1,
+          PeriodFamily.FlatTorus.singularH1Equiv a.val.2) =
+      0 := by
+    have h := PeriodFamily.HomologyDifference.sourceDifferenceOne_coordinates a.val
+    rw [show PeriodFamily.Homology.sourceDifference 1 a.val = 0 from a.property, map_zero] at h
+    exact h.symm
+  have h :=
+    nativeSourceClasses_source_coordinates (PeriodFamily.FlatTorus.singularH1Equiv a.val.1)
+      (PeriodFamily.FlatTorus.singularH1Equiv a.val.2) hxy
+  refine
+    ⟨nativeSourceClasses (PeriodFamily.FlatTorus.singularH1Equiv a.val.1)
+        (PeriodFamily.FlatTorus.singularH1Equiv a.val.2),
+      ?_⟩
+  apply Subtype.ext
+  apply Prod.ext
+  · exact PeriodFamily.FlatTorus.singularH1Equiv.injective (congrArg Prod.fst h)
+  · exact PeriodFamily.FlatTorus.singularH1Equiv.injective (congrArg Prod.snd h)
+
+private theorem ThreefoldHomology.CapElimination.exists_fibre_capKernel_decomposition (n : ℕ)
+    (hs : Function.Surjective (nativeCapKernelSourceMap n))
+    (r :
+      SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily
+        (n + 1)) :
+    ∃ b : SingularMayerVietoris.SingularHomology RealTorus₄ (n + 1),
+      ∃ a : ∀ i : SpecialPeriods.Threefold.Puncture, NativeCapKernel i (n + 1),
+        SingularMayerVietoris.singularHomologyMap
+              (PeriodFamily.Homology.familyFibreInclusion
+                (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                  SpecialPeriods.specialPeriodMap_generator₁
+                  SpecialPeriods.specialPeriodMap_generator₂)
+                PeriodFamily.Homology.normalizedSlitBaseLift)
+              (n + 1) b +
+            nativeCapKernelRegularMap (n + 1) a =
+          r := by
+  obtain ⟨a, ha⟩ :=
+    hs
+      (PeriodFamily.Homology.sourceKernelProjection
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        n r)
+  have hr :
+    r - nativeCapKernelRegularMap (n + 1) a ∈
+      LinearMap.ker
+        (PeriodFamily.Homology.sourceKernelProjection
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          n) := by
+    change
+      PeriodFamily.Homology.sourceKernelProjection
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          n (r - nativeCapKernelRegularMap (n + 1) a) =
+        0
+    rw [map_sub, ← nativeCapKernelSourceMap_apply, ha, sub_self]
+  rw [PeriodFamily.Homology.sourceKernelProjection_kernel] at hr
+  obtain ⟨b, hb⟩ := hr
+  exact ⟨b, a, hb ▸ sub_add_cancel r (nativeCapKernelRegularMap (n + 1) a)⟩
+
+private theorem ThreefoldHomology.CapElimination.nativeCapKernelRegularMap_surjective_of_fibre_range
+    (n : ℕ) (hs : Function.Surjective (nativeCapKernelSourceMap n))
+    (hf :
+      LinearMap.range
+          (SingularMayerVietoris.singularHomologyMap
+            (PeriodFamily.Homology.familyFibreInclusion
+              (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                SpecialPeriods.specialPeriodMap_generator₁
+                SpecialPeriods.specialPeriodMap_generator₂)
+              PeriodFamily.Homology.normalizedSlitBaseLift)
+            (n + 1)) ≤
+        LinearMap.range (nativeCapKernelRegularMap (n + 1))) :
+    Function.Surjective (nativeCapKernelRegularMap (n + 1)) := by
+  intro r
+  obtain ⟨b, a, hr⟩ := exists_fibre_capKernel_decomposition n hs r
+  obtain ⟨c, hc⟩ := hf ⟨b, rfl⟩
+  refine ⟨c + a, ?_⟩
+  rw [map_add, hc]
+  exact hr
+
+private def ThreefoldHomology.CapElimination.regularFibreIntoSpace :
+    C(RealTorus₄, SpecialPeriods.Threefold.Space) :=
+  ThreefoldHomology.originalRegularInclusion.comp
+    (PeriodFamily.Homology.familyFibreInclusion
+      (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+      PeriodFamily.Homology.normalizedSlitBaseLift)
+
+private theorem ThreefoldHomology.CapElimination.regularFibreIntoSpace_homology (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap regularFibreIntoSpace n =
+      (SingularMayerVietoris.singularHomologyMap ThreefoldHomology.originalRegularInclusion
+            n).comp
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodFamily.Homology.familyFibreInclusion
+            (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)
+            PeriodFamily.Homology.normalizedSlitBaseLift)
+          n) :=
+  PeriodTorusHigherHomology.singularHomologyMap_comp _ _ _
+
+private theorem ThreefoldHomology.CapElimination.regularFibreIntoSpace_homology_surjective (n : ℕ)
+    (hs : Function.Surjective (nativeCapKernelSourceMap n))
+    (hr :
+      Function.Surjective
+        (SingularMayerVietoris.singularHomologyMap ThreefoldHomology.originalRegularInclusion
+          (n + 1))) :
+    Function.Surjective
+      (SingularMayerVietoris.singularHomologyMap regularFibreIntoSpace (n + 1)) := by
+  intro x
+  obtain ⟨r, hr⟩ := hr x
+  obtain ⟨b, a, hb⟩ := exists_fibre_capKernel_decomposition n hs r
+  have hz :
+    SingularMayerVietoris.singularHomologyMap ThreefoldHomology.originalRegularInclusion (n + 1)
+        (nativeCapKernelRegularMap (n + 1) a) =
+      0 :=
+    (regularInclusion_eq_zero_iff_native (n + 1) _).mpr ⟨a, rfl⟩
+  refine ⟨b, ?_⟩
+  rw [regularFibreIntoSpace_homology, LinearMap.comp_apply]
+  have h :=
+    congrArg
+      (SingularMayerVietoris.singularHomologyMap ThreefoldHomology.originalRegularInclusion
+        (n + 1))
+      hb
+  rw [map_add, hz, add_zero, hr] at h
+  exact h
+
+private theorem ThreefoldHomology.CapElimination.starLeft_surjective_of_nativeCapKernel (n : ℕ)
+    (h : Function.Surjective (nativeCapKernelRegularMap n)) :
+    Function.Surjective (ThreefoldHomology.starLeftHomologyMap n) := by
+  intro p
+  obtain ⟨b, hb⟩ := starOverlapToFillingsHomologyMap_surjective n (-p.2)
+  have hrel :
+    p.1 - ThreefoldHomology.starOverlapToRegularHomologyMap n b ∈
+      LinearMap.range (nativeCapKernelRegularMap n) :=
+    h (p.1 - ThreefoldHomology.starOverlapToRegularHomologyMap n b)
+  rw [nativeCapKernelRegularMap_range] at hrel
+  obtain ⟨c, hc⟩ := hrel
+  have hc' :
+    ThreefoldHomology.starOverlapToRegularHomologyMap n c.val =
+      p.1 - ThreefoldHomology.starOverlapToRegularHomologyMap n b :=
+    hc
+  refine ⟨c.val + b, ?_⟩
+  rw [starLeft_regular_fillings]
+  apply Prod.ext
+  · change ThreefoldHomology.starOverlapToRegularHomologyMap n (c.val + b) = p.1
+    rw [map_add, hc', sub_add_cancel]
+  · change -ThreefoldHomology.starOverlapToFillingsHomologyMap n (c.val + b) = p.2
+    rw [map_add, c.property, zero_add, hb, neg_neg]
+
+private theorem ThreefoldHomology.SecondDegree.regularFibre_homologyTwo_surjective :
+    Function.Surjective
+      (SingularMayerVietoris.singularHomologyMap
+        ThreefoldHomology.CapElimination.regularFibreIntoSpace 2) :=
+  ThreefoldHomology.CapElimination.regularFibreIntoSpace_homology_surjective 1
+    ThreefoldHomology.SecondSource.nativeCapKernelSourceMap_one_surjective
+    ThreefoldHomology.CapElimination.regularInclusion_two_surjective
+
+private def ThreefoldHomology.SecondDegree.homologyTwoCyclicMap :
+    ℤ →ₗ[ℤ] SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 2 :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun
+        z :=
+        SingularMayerVietoris.singularHomologyMap ThreefoldHomology.originalRegularInclusion 2
+          (PeriodFamily.Homology.sourceCoinvariantInclusion
+            (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)
+            2 (PeriodFamily.HomologyDifference.cokernelTwoEquiv.symm z))
+      map_zero' := by rw [map_zero, map_zero, map_zero]
+      map_add' a b := by rw [map_add, map_add, map_add] }
+
+private theorem ThreefoldHomology.SecondDegree.homologyTwoCyclicMap_quotient
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 2) :
+    homologyTwoCyclicMap
+        (PeriodFamily.HomologyDifference.cokernelTwoEquiv (Submodule.Quotient.mk a)) =
+      SingularMayerVietoris.singularHomologyMap
+        ThreefoldHomology.CapElimination.regularFibreIntoSpace 2 a := by
+  change
+    SingularMayerVietoris.singularHomologyMap ThreefoldHomology.originalRegularInclusion 2
+        (PeriodFamily.Homology.sourceCoinvariantInclusion
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          2
+          (PeriodFamily.HomologyDifference.cokernelTwoEquiv.symm
+            (PeriodFamily.HomologyDifference.cokernelTwoEquiv (Submodule.Quotient.mk a)))) =
+      _
+  rw [LinearEquiv.symm_apply_apply, PeriodFamily.Homology.sourceCoinvariantInclusion_mk,
+    ThreefoldHomology.CapElimination.regularFibreIntoSpace_homology, LinearMap.comp_apply]
+
+private theorem ThreefoldHomology.SecondDegree.homologyTwoCyclicMap_surjective :
+    Function.Surjective homologyTwoCyclicMap := by
+  intro x
+  obtain ⟨a, ha⟩ := regularFibre_homologyTwo_surjective x
+  exact
+    ⟨PeriodFamily.HomologyDifference.cokernelTwoEquiv (Submodule.Quotient.mk a),
+      (homologyTwoCyclicMap_quotient a).trans ha⟩
+
+private theorem ThreefoldHomology.SecondDegree.regularFibre_homologyTwo_coordinates
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 2) :
+    SingularMayerVietoris.singularHomologyMap
+        ThreefoldHomology.CapElimination.regularFibreIntoSpace 2 a =
+      homologyTwoCyclicMap
+        (6 * PeriodFamily.FlatTorus.singularH2Coordinates a 2 +
+          PeriodFamily.FlatTorus.singularH2Coordinates a 3) := by
+  rw [← PeriodFamily.HomologyDifference.cokernelTwoEquiv_mk]
+  exact (homologyTwoCyclicMap_quotient a).symm
+
+private def ThreefoldHomology.SecondDegree.homologyTwoGenerator :
+    SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 2 :=
+  homologyTwoCyclicMap 1
+
+private theorem ThreefoldHomology.SecondDegree.homologyTwoCyclicMap_eq_smul (z : ℤ) :
+    homologyTwoCyclicMap z = z • homologyTwoGenerator := by
+  simpa [homologyTwoGenerator] using map_zsmul homologyTwoCyclicMap z (1 : ℤ)
+
+private theorem ThreefoldHomology.SecondDegree.homologyTwo_subsingleton_iff_generator_eq_zero :
+    Subsingleton (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 2) ↔
+      homologyTwoGenerator = 0 := by
+  constructor
+  · intro h
+    exact h.elim _ _
+  · intro h
+    have hz (x : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 2) :
+      x = 0 := by
+      obtain ⟨z, rfl⟩ := homologyTwoCyclicMap_surjective x
+      rw [homologyTwoCyclicMap_eq_smul, h]
+      exact
+        @zsmul_zero (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 2) _ z
+    exact ⟨fun x y => (hz x).trans (hz y).symm⟩
+
+private def ThreefoldHomology.EllipticFibre.centralRealCover (j : Elliptic.Kind) :
+    C(RealTorus₄, ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface j) :=
+  (Elliptic.HigherHomology.periodCover j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+        (Elliptic.mainTwist_admissible j)).comp
+    ⟨Elliptic.flatTorusPeriodHomeomorph
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod.val,
+      (Elliptic.flatTorusPeriodHomeomorph
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod.val).continuous⟩
+
+private theorem ThreefoldHomology.EllipticFibre.centralBoundary_fibre (j : Elliptic.Kind) :
+    (ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryToCentral j).comp
+        (MappingTorus.HomologyCover.fibreInclusion
+          (ThreefoldOverlapMappingTorus.monodromy (Option.some j))) =
+      centralRealCover j := by
+  apply ContinuousMap.ext
+  intro x
+  exact ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryToCentral_mk j 0 x
+
+private theorem
+    ThreefoldHomology.EllipticFibre.fibreToFilling_centralRetraction (j : Elliptic.Kind) :
+    (SpecialPeriods.Threefold.EllipticGeometry.pieceSurfaceRetraction j).comp
+        (ThreefoldOverlapMappingTorus.fibreToFilling (Option.some j)) =
+      centralRealCover j := by
+  rw [ThreefoldOverlapMappingTorus.fibreToFilling,
+    ThreefoldOverlapMappingTorus.boundaryToFilling_elliptic]
+  exact centralBoundary_fibre j
+
+private def ThreefoldHomology.EllipticFibre.centralPeriodHomologyEquiv (j : Elliptic.Kind) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology RealTorus₄ n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod.val.Torus n :=
+  PeriodTorusHigherHomology.homeomorphHomologyEquiv
+    (Elliptic.flatTorusPeriodHomeomorph
+      (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod.val)
+    n
+
+private theorem
+    ThreefoldHomology.EllipticFibre.fibreToFilling_homology_retraction (j : Elliptic.Kind)
+    (n : ℕ) :
+    (ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j n).toLinearMap.comp
+        (SingularMayerVietoris.singularHomologyMap
+          (ThreefoldOverlapMappingTorus.fibreToFilling (Option.some j)) n) =
+      (SingularMayerVietoris.singularHomologyMap
+            (Elliptic.HigherHomology.periodCover j
+              (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+              (Elliptic.mainTwist_admissible j))
+            n).comp
+        (centralPeriodHomologyEquiv j n).toLinearMap := by
+  have h₁ :=
+    PeriodTorusHigherHomology.singularHomologyMap_comp
+      (ThreefoldOverlapMappingTorus.fibreToFilling (Option.some j))
+      (SpecialPeriods.Threefold.EllipticGeometry.pieceSurfaceRetraction j) n
+  have h₀ :=
+    congrArg
+      (fun f : C(RealTorus₄, SpecialPeriods.EllipticFilling.SpecialCentralSurface j) =>
+        SingularMayerVietoris.singularHomologyMap f n)
+      (fibreToFilling_centralRetraction j)
+  have h₂ :=
+    PeriodTorusHigherHomology.singularHomologyMap_comp
+      (⟨Elliptic.flatTorusPeriodHomeomorph
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod.val,
+          (Elliptic.flatTorusPeriodHomeomorph
+              (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod.val).continuous⟩ :
+        C(RealTorus₄,
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod.val.Torus))
+      (Elliptic.HigherHomology.periodCover j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+        (Elliptic.mainTwist_admissible j))
+      n
+  exact h₁.symm.trans (h₀.trans h₂)
+
+private theorem
+    ThreefoldHomology.EllipticFibre.fibreToFilling_homology_eq_zero_iff (j : Elliptic.Kind)
+    (n : ℕ) (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    SingularMayerVietoris.singularHomologyMap
+          (ThreefoldOverlapMappingTorus.fibreToFilling (Option.some j)) n a =
+        0 ↔
+      SingularMayerVietoris.singularHomologyMap
+          (Elliptic.HigherHomology.periodCover j
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+            (Elliptic.mainTwist_admissible j))
+          n (centralPeriodHomologyEquiv j n a) =
+        0 := by
+  have h := LinearMap.congr_fun (fibreToFilling_homology_retraction j n) a
+  change
+    ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j n
+        (SingularMayerVietoris.singularHomologyMap
+          (ThreefoldOverlapMappingTorus.fibreToFilling (Option.some j)) n a) =
+      SingularMayerVietoris.singularHomologyMap
+        (Elliptic.HigherHomology.periodCover j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+          (Elliptic.mainTwist_admissible j))
+        n (centralPeriodHomologyEquiv j n a) at h
+  rw [← h]
+  exact
+    (ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j n).map_eq_zero_iff.symm
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold in
+private def ThreefoldHomology.DeltaSweep.realParameterAddHom : ℝ →+ Additive ℂˣ
+    where
+  toFun
+    t :=
+    Additive.ofMul
+      (SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential (t : ℂ))
+  map_zero' := by
+    change
+      SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential ((0 : ℝ) : ℂ) = 1
+    exact SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential_zero
+  map_add' s
+    t := by
+    change
+      SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential
+          ((s + t : ℝ) : ℂ) =
+        SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential (s : ℂ) *
+          SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential (t : ℂ)
+    rw [Complex.ofReal_add,
+      SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential_add]
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold in
+private def ThreefoldHomology.DeltaSweep.circleParameterAddHom :
+    (PeriodTorusHigherHomology.CircleTopology.Circle) →+ Additive ℂˣ :=
+  QuotientAddGroup.lift (AddSubgroup.zmultiples (1 : ℝ)) realParameterAddHom
+    (by
+      intro t ht
+      obtain ⟨k, hk⟩ := AddSubgroup.mem_zmultiples_iff.mp ht
+      have he : t = (k : ℝ) := by simpa only [zsmul_one] using hk.symm
+      change SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential (t : ℂ) = 1
+      rw [he]
+      simpa only [Complex.ofReal_intCast] using
+        SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential_int k)
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold in
+private def ThreefoldHomology.DeltaSweep.circleParameter
+    (t : (PeriodTorusHigherHomology.CircleTopology.Circle)) : ℂˣ :=
+  Additive.toMul (circleParameterAddHom t)
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold in
+@[simp]
+private theorem ThreefoldHomology.DeltaSweep.circleParameter_real (t : ℝ) :
+    circleParameter (t : (PeriodTorusHigherHomology.CircleTopology.Circle)) =
+      SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential (t : ℂ) :=
+  rfl
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold in
+private theorem
+    ThreefoldHomology.DeltaSweep.circleParameter_continuous : Continuous circleParameter := by
+  apply (QuotientAddGroup.isQuotientMap_mk (AddSubgroup.zmultiples (1 : ℝ))).continuous_iff.mpr
+  exact
+    SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential_continuous.comp
+      Complex.continuous_ofReal
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold in
+private def ThreefoldHomology.DeltaSweep.actionMap :
+    C((PeriodTorusHigherHomology.CircleTopology.Circle) × SpecialPeriods.Threefold.Space,
+      SpecialPeriods.Threefold.Space) :=
+  ⟨fun p => SpecialPeriods.Threefold.VerticalAction.actionBiholomorph (circleParameter p.1) p.2,
+    by
+    let := SpecialPeriods.Threefold.VerticalAction.action
+    exact
+      SpecialPeriods.Threefold.VerticalAction.action_holomorphic.continuous.comp
+        ((circleParameter_continuous.comp continuous_fst).prodMk continuous_snd)⟩
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold in
+@[simp]
+private theorem ThreefoldHomology.DeltaSweep.actionMap_apply
+    (t : (PeriodTorusHigherHomology.CircleTopology.Circle)) (x : SpecialPeriods.Threefold.Space) :
+    actionMap (t, x) =
+      SpecialPeriods.Threefold.VerticalAction.actionBiholomorph (circleParameter t) x :=
+  rfl
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold in
+private theorem
+    ThreefoldHomology.DeltaSweep.actionMap_real (t : ℝ) (x : SpecialPeriods.Threefold.Space) :
+    actionMap ((t : (PeriodTorusHigherHomology.CircleTopology.Circle)), x) =
+      SpecialPeriods.Threefold.VerticalAction.flow (t : ℂ) x := by
+  rw [actionMap_apply, circleParameter_real,
+    SpecialPeriods.Threefold.VerticalAction.actionBiholomorph_exponential]
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold in
+private def ThreefoldHomology.DeltaSweep.centralInclusionMap (j : Elliptic.Kind) :
+    C(SpecialPeriods.EllipticFilling.SpecialCentralSurface j, SpecialPeriods.Threefold.Space) :=
+  ⟨SpecialPeriods.Threefold.EllipticGeometry.centralSurfaceInclusion j,
+    SpecialPeriods.Threefold.EllipticGeometry.centralSurfaceInclusion_continuous j⟩
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold in
+private theorem ThreefoldHomology.DeltaSweep.actionMap_central_mem_fibre (j : Elliptic.Kind)
+    (t : (PeriodTorusHigherHomology.CircleTopology.Circle))
+    (x : SpecialPeriods.EllipticFilling.SpecialCentralSurface j) :
+    actionMap (t, centralInclusionMap j x) ∈
+      SpecialPeriods.Threefold.projectionSphere ⁻¹'
+        {SpecialPeriods.Threefold.EllipticGeometry.sphereValue j} := by
+  let := SpecialPeriods.Threefold.VerticalAction.action
+  change
+    SpecialPeriods.Threefold.projectionSphere (actionMap (t, centralInclusionMap j x)) =
+      SpecialPeriods.Threefold.EllipticGeometry.sphereValue j
+  exact
+    (SpecialPeriods.Threefold.VerticalAction.projectionSphere_action (circleParameter t)
+          (centralInclusionMap j x)).trans
+      (SpecialPeriods.Threefold.EllipticGeometry.projectionSphere_centralSurfaceInclusion j x)
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold in
+private def ThreefoldHomology.DeltaSweep.centralActionMap (j : Elliptic.Kind) :
+    C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+        SpecialPeriods.EllipticFilling.SpecialCentralSurface j,
+      SpecialPeriods.EllipticFilling.SpecialCentralSurface j)
+    where
+  toFun
+    p :=
+    (SpecialPeriods.Threefold.EllipticGeometry.centralSurfaceFibreHomeomorph j).symm
+      ⟨actionMap (p.1, centralInclusionMap j p.2), actionMap_central_mem_fibre j p.1 p.2⟩
+  continuous_toFun :=
+    (SpecialPeriods.Threefold.EllipticGeometry.centralSurfaceFibreHomeomorph
+          j).symm.continuous.comp
+      ((actionMap.continuous.comp
+            (continuous_fst.prodMk
+              ((centralInclusionMap j).continuous.comp continuous_snd))).subtype_mk
+        _)
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold in
+private theorem ThreefoldHomology.DeltaSweep.centralInclusionMap_actionMap (j : Elliptic.Kind)
+    (t : (PeriodTorusHigherHomology.CircleTopology.Circle))
+    (x : SpecialPeriods.EllipticFilling.SpecialCentralSurface j) :
+    centralInclusionMap j (centralActionMap j (t, x)) = actionMap (t, centralInclusionMap j x) :=
+  SpecialPeriods.Threefold.EllipticGeometry.centralSurfaceFibreHomeomorph_symm_inclusion j _
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold in
+private theorem ThreefoldHomology.DeltaSweep.actionMap_centralInclusion (j : Elliptic.Kind)
+    (t : (PeriodTorusHigherHomology.CircleTopology.Circle))
+    (x : SpecialPeriods.EllipticFilling.SpecialCentralSurface j) :
+    actionMap (t, centralInclusionMap j x) = centralInclusionMap j (centralActionMap j (t, x)) :=
+  (centralInclusionMap_actionMap j t x).symm
+
+private def ThreefoldHomology.DeltaSweep.deltaLattice : Lattice :=
+  ![0, 0, 0, 1]
+
+@[simp]
+private theorem ThreefoldHomology.DeltaSweep.realCast_deltaLattice :
+    Elliptic.realCast deltaLattice = Pi.basisFun ℝ (Fin 4) 3 := by
+  ext i
+  fin_cases i <;> simp [Elliptic.realCast, deltaLattice, Pi.basisFun_apply]
+
+private def ThreefoldHomology.DeltaSweep.deltaCircle :
+    C((PeriodTorusHigherHomology.CircleTopology.Circle), RealTorus₄) :=
+  (PeriodTorusHigherHomology.flatTorusCircleHomeomorph.symm :
+        C(PeriodTorusHigherHomology.ProductTorus 4, RealTorus₄)).comp
+    (PeriodTorusHigherHomology.coordinateCircleMap deltaLattice)
+
+@[simp]
+private theorem ThreefoldHomology.DeltaSweep.flatTorusCircleHomeomorph_deltaCircle
+    (t : (PeriodTorusHigherHomology.CircleTopology.Circle)) :
+    PeriodTorusHigherHomology.flatTorusCircleHomeomorph (deltaCircle t) =
+      PeriodTorusHigherHomology.coordinateCircleMap deltaLattice t :=
+  PeriodTorusHigherHomology.flatTorusCircleHomeomorph.apply_symm_apply _
+
+private theorem ThreefoldHomology.DeltaSweep.deltaCircle_real_apply (t : ℝ) :
+    deltaCircle (t : (PeriodTorusHigherHomology.CircleTopology.Circle)) =
+      standardLattice.mkQ (t • Pi.basisFun ℝ (Fin 4) 3) := by
+  apply PeriodTorusHigherHomology.flatTorusCircleHomeomorph.injective
+  rw [flatTorusCircleHomeomorph_deltaCircle,
+    PeriodTorusHigherHomology.flatTorusCircleHomeomorph_mkQ]
+  ext i
+  fin_cases i <;>
+    simp [PeriodTorusHigherHomology.coordinateCircleMap_apply, deltaLattice,
+      PeriodTorusHigherHomology.coordinateProjection_apply, Pi.basisFun_apply]
+
+@[simp]
+private theorem ThreefoldHomology.DeltaSweep.deltaCircle_zero : deltaCircle 0 = 0 := by
+  apply PeriodTorusHigherHomology.flatTorusCircleHomeomorph.injective
+  rw [flatTorusCircleHomeomorph_deltaCircle, PeriodTorusHigherHomology.coordinateCircleMap_zero,
+    PeriodFamily.FlatTorus.flatTorusCircleHomeomorph_zero]
+
+private theorem ThreefoldHomology.DeltaSweep.deltaCircle_positiveLoop :
+    PeriodTorusHigherHomology.CirclePaths.positiveLoop.map deltaCircle.continuous =
+      (PeriodFamily.FlatTorus.periodLoop deltaLattice).cast deltaCircle_zero deltaCircle_zero := by
+  apply Path.ext
+  funext t
+  change
+    deltaCircle (PeriodTorusHigherHomology.CirclePaths.positiveLoop t) =
+      PeriodFamily.FlatTorus.periodLoop deltaLattice t
+  rw [PeriodTorusHigherHomology.CirclePaths.positiveLoop_apply, deltaCircle_real_apply,
+    PeriodFamily.FlatTorus.periodLoop_apply, realCast_deltaLattice]
+
+private theorem ThreefoldHomology.DeltaSweep.deltaCircle_positiveLoop_homology :
+    FirstHurewicz.inducedHomology deltaCircle
+        (FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop) =
+      PeriodFamily.FlatTorus.singularH1Equiv.symm deltaLattice := by
+  rw [FirstHurewicz.inducedHomology_loopHomologyClass, deltaCircle_positiveLoop,
+    PeriodFamily.FlatTorus.singularH1Equiv_symm_apply]
+  rfl
+
+private theorem ThreefoldHomology.DeltaSweep.deltaCircle_positiveLoop_singularHomology :
+    SingularMayerVietoris.singularHomologyMap deltaCircle 1
+        (FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop) =
+      PeriodFamily.FlatTorus.singularH1Equiv.symm deltaLattice :=
+  deltaCircle_positiveLoop_homology
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold in
+private def ThreefoldHomology.DeltaSweep.centralPeriodCoordinateHomeomorph (j : Elliptic.Kind) :
+    RealTorus₄ ≃ₜ SpecialPeriods.EllipticFilling.SpecialCentralPeriodTorus j :=
+  Elliptic.flatTorusPeriodHomeomorph
+    (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod.val
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold in
+private def ThreefoldHomology.DeltaSweep.centralFlatPeriodCover (j : Elliptic.Kind) :
+    C(RealTorus₄, SpecialPeriods.EllipticFilling.SpecialCentralSurface j) :=
+  (SpecialPeriods.EllipticFilling.specialCentralPeriodCover j).comp
+    (centralPeriodCoordinateHomeomorph j :
+      C(RealTorus₄, SpecialPeriods.EllipticFilling.SpecialCentralPeriodTorus j))
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold in
+private theorem
+    ThreefoldHomology.DeltaSweep.specialCentralInclusion_flatPeriodCover (j : Elliptic.Kind)
+    (y : RealTorus₄) :
+    SpecialPeriods.EllipticFilling.specialCentralInclusion j (centralFlatPeriodCover j y) =
+      (SpecialPeriods.EllipticFilling.specialLocalData j).quotient j.twist
+        (Elliptic.mainTwist_admissible j) (SpecialPeriods.discZero, y) := by
+  obtain ⟨x, rfl⟩ := standardLattice.mkQ_surjective y
+  change
+    (SpecialPeriods.EllipticFilling.specialLocalData j).centralFibreInclusion j.twist
+        (Elliptic.mainTwist_admissible j)
+        (Elliptic.surfaceProjection j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+          (Elliptic.mainTwist_admissible j)
+          (Elliptic.flatProjection
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod.val x)) =
+      _
+  rw [Elliptic.Equivariant.Data.centralFibreInclusion_surfaceProjection,
+    Elliptic.Equivariant.Data.centralInclusion_flatProjection]
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold in
+private theorem
+    ThreefoldHomology.DeltaSweep.specialFlow_flatPeriodCover_real (j : Elliptic.Kind) (t : ℝ)
+    (y : RealTorus₄) :
+    SpecialPeriods.Threefold.VerticalAction.Elliptic.specialFlow j (t : ℂ)
+        (SpecialPeriods.Threefold.EllipticGeometry.pieceCentralInclusion j
+          (centralFlatPeriodCover j y)) =
+      SpecialPeriods.Threefold.EllipticGeometry.pieceCentralInclusion j
+        (centralFlatPeriodCover j
+          (deltaCircle (t : (PeriodTorusHigherHomology.CircleTopology.Circle)) + y)) := by
+  have hp :
+    SpecialPeriods.Threefold.VerticalAction.Period.flow
+        (SpecialPeriods.EllipticFilling.specialLocalData j).periods (t : ℂ)
+        (SpecialPeriods.discZero, y) =
+      (SpecialPeriods.discZero,
+        deltaCircle (t : (PeriodTorusHigherHomology.CircleTopology.Circle)) + y) := by
+    rw [deltaCircle_real_apply]
+    simp only [SpecialPeriods.Threefold.VerticalAction.Period.flow,
+      SpecialPeriods.Threefold.FiniteActionFixed.Period.inverse_vector_real]
+    exact Prod.ext rfl (add_comm _ _)
+  apply Subtype.ext
+  change
+    SpecialPeriods.Threefold.VerticalAction.Elliptic.specialFullFlow j (t : ℂ)
+        (SpecialPeriods.EllipticFilling.specialCentralInclusion j (centralFlatPeriodCover j y)) =
+      SpecialPeriods.EllipticFilling.specialCentralInclusion j
+        (centralFlatPeriodCover j
+          (deltaCircle (t : (PeriodTorusHigherHomology.CircleTopology.Circle)) + y))
+  rw [specialCentralInclusion_flatPeriodCover,
+    SpecialPeriods.Threefold.VerticalAction.Elliptic.specialFullFlow_quotient, hp,
+    specialCentralInclusion_flatPeriodCover]
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold in
+private theorem
+    ThreefoldHomology.DeltaSweep.actionMap_real_centralFlatPeriodCover (j : Elliptic.Kind)
+    (t : ℝ) (y : RealTorus₄) :
+    actionMap
+        ((t : (PeriodTorusHigherHomology.CircleTopology.Circle)),
+          centralInclusionMap j (centralFlatPeriodCover j y)) =
+      centralInclusionMap j
+        (centralFlatPeriodCover j
+          (deltaCircle (t : (PeriodTorusHigherHomology.CircleTopology.Circle)) + y)) := by
+  rw [actionMap_real]
+  change
+    SpecialPeriods.Threefold.VerticalAction.flow (t : ℂ)
+        (SpecialPeriods.Threefold.EllipticGeometry.inclusion j
+          (SpecialPeriods.Threefold.EllipticGeometry.pieceCentralInclusion j
+            (centralFlatPeriodCover j y))) =
+      _
+  rw [SpecialPeriods.Threefold.VerticalAction.flow_elliptic, specialFlow_flatPeriodCover_real]
+  rfl
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold in
+private theorem ThreefoldHomology.DeltaSweep.actionMap_centralFlatPeriodCover (j : Elliptic.Kind)
+    (t : (PeriodTorusHigherHomology.CircleTopology.Circle)) (y : RealTorus₄) :
+    actionMap (t, centralInclusionMap j (centralFlatPeriodCover j y)) =
+      centralInclusionMap j (centralFlatPeriodCover j (deltaCircle t + y)) := by
+  obtain ⟨s, rfl⟩ := QuotientAddGroup.mk_surjective t
+  exact actionMap_real_centralFlatPeriodCover j s y
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold in
+private theorem ThreefoldHomology.DeltaSweep.centralActionMap_flatPeriodCover (j : Elliptic.Kind)
+    (t : (PeriodTorusHigherHomology.CircleTopology.Circle)) (y : RealTorus₄) :
+    centralActionMap j (t, centralFlatPeriodCover j y) =
+      centralFlatPeriodCover j (deltaCircle t + y) := by
+  apply SpecialPeriods.Threefold.EllipticGeometry.centralSurfaceInclusion_injective j
+  change
+    centralInclusionMap j (centralActionMap j (t, centralFlatPeriodCover j y)) =
+      centralInclusionMap j (centralFlatPeriodCover j (deltaCircle t + y))
+  rw [centralInclusionMap_actionMap]
+  exact actionMap_centralFlatPeriodCover j t y
+
+private theorem ThreefoldHomology.CentralFibreCompatibility.globalFibre_maps_agree
+    (i : SpecialPeriods.Threefold.Puncture) :
+    ThreefoldHomology.originalRegularInclusion.comp
+        (ThreefoldOverlapMappingTorus.fibreToRegularFamily i) =
+      (ThreefoldHomology.originalPieceInclusion (Option.some i)).comp
+        (ThreefoldOverlapMappingTorus.fibreToFilling i) := by
+  have h :=
+    congrArg
+      (fun f : C(ThreefoldOverlapMappingTorus.Boundary i, SpecialPeriods.Threefold.Space) =>
+        f.comp
+          (MappingTorus.HomologyCover.fibreInclusion (ThreefoldOverlapMappingTorus.monodromy i)))
+      (ThreefoldOverlapMappingTorus.boundary_maps_agree i)
+  simpa only [ThreefoldOverlapMappingTorus.fibreToRegularFamily,
+    ThreefoldOverlapMappingTorus.fibreToFilling, ContinuousMap.comp_assoc] using h
+
+private theorem ThreefoldHomology.CentralFibreCompatibility.regularFibreIntoSpace_homology_filling
+    (i : SpecialPeriods.Threefold.Puncture) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap
+        ThreefoldHomology.CapElimination.regularFibreIntoSpace n =
+      (SingularMayerVietoris.singularHomologyMap
+            (ThreefoldHomology.originalPieceInclusion (Option.some i)) n).comp
+        (SingularMayerVietoris.singularHomologyMap (ThreefoldOverlapMappingTorus.fibreToFilling i)
+          n) := by
+  rw [ThreefoldHomology.CapElimination.regularFibreIntoSpace_homology, ←
+    PeriodFamily.Boundary.fibreToRegularFamily_homology_common i n, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp, globalFibre_maps_agree,
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+
+private theorem
+    ThreefoldHomology.CentralFibreCompatibility.fibreToFilling_homology_centralRetraction
+    (j : Elliptic.Kind) (n : ℕ) :
+    (ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j n).toLinearMap.comp
+        (SingularMayerVietoris.singularHomologyMap
+          (ThreefoldOverlapMappingTorus.fibreToFilling (Option.some j)) n) =
+      SingularMayerVietoris.singularHomologyMap
+        (ThreefoldHomology.EllipticFibre.centralRealCover j) n := by
+  have h :=
+    congrArg
+      (fun f : C(RealTorus₄, SpecialPeriods.EllipticFilling.SpecialCentralSurface j) =>
+        SingularMayerVietoris.singularHomologyMap f n)
+      (ThreefoldHomology.EllipticFibre.fibreToFilling_centralRetraction j)
+  exact
+    (PeriodTorusHigherHomology.singularHomologyMap_comp
+          (ThreefoldOverlapMappingTorus.fibreToFilling (Option.some j))
+          (SpecialPeriods.Threefold.EllipticGeometry.pieceSurfaceRetraction j) n).symm.trans
+      h
+
+private theorem ThreefoldHomology.CentralFibreCompatibility.fibreToFilling_homology_central
+    (j : Elliptic.Kind) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap
+        (ThreefoldOverlapMappingTorus.fibreToFilling (Option.some j)) n =
+      (SingularMayerVietoris.singularHomologyMap
+            (SpecialPeriods.Threefold.EllipticGeometry.centralSurfaceIntoPiece j) n).comp
+        (SingularMayerVietoris.singularHomologyMap
+          (ThreefoldHomology.EllipticFibre.centralRealCover j) n) := by
+  apply LinearMap.ext
+  intro a
+  have h :=
+    congrArg (ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j n).symm
+      (LinearMap.congr_fun (fibreToFilling_homology_centralRetraction j n) a)
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (ThreefoldOverlapMappingTorus.fibreToFilling (Option.some j)) n a =
+      (ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j n).symm
+        (SingularMayerVietoris.singularHomologyMap
+          (ThreefoldHomology.EllipticFibre.centralRealCover j) n a)
+  exact
+    ((ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j n).symm_apply_apply
+          _).symm.trans
+      h
+
+private theorem
+    ThreefoldHomology.CentralFibreCompatibility.regularFibreIntoSpace_homology_eq_central
+    (j : Elliptic.Kind) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap
+        ThreefoldHomology.CapElimination.regularFibreIntoSpace n =
+      (SingularMayerVietoris.singularHomologyMap
+            (ThreefoldHomology.DeltaSweep.centralInclusionMap j) n).comp
+        (SingularMayerVietoris.singularHomologyMap
+          (ThreefoldHomology.DeltaSweep.centralFlatPeriodCover j) n) := by
+  have hi :
+    SingularMayerVietoris.singularHomologyMap (ThreefoldHomology.DeltaSweep.centralInclusionMap j)
+        n =
+      (SingularMayerVietoris.singularHomologyMap
+            (ThreefoldHomology.originalPieceInclusion (Option.some (Option.some j))) n).comp
+        (SingularMayerVietoris.singularHomologyMap
+          (SpecialPeriods.Threefold.EllipticGeometry.centralSurfaceIntoPiece j) n) :=
+    PeriodTorusHigherHomology.singularHomologyMap_comp
+      (SpecialPeriods.Threefold.EllipticGeometry.centralSurfaceIntoPiece j)
+      (ThreefoldHomology.originalPieceInclusion (Option.some (Option.some j))) n
+  apply LinearMap.ext
+  intro a
+  calc
+    SingularMayerVietoris.singularHomologyMap
+          ThreefoldHomology.CapElimination.regularFibreIntoSpace n a =
+        SingularMayerVietoris.singularHomologyMap
+          (ThreefoldHomology.originalPieceInclusion (Option.some (Option.some j))) n
+          (SingularMayerVietoris.singularHomologyMap
+            (ThreefoldOverlapMappingTorus.fibreToFilling (Option.some j)) n a) :=
+      LinearMap.congr_fun (regularFibreIntoSpace_homology_filling (Option.some j) n) a
+    _ =
+        SingularMayerVietoris.singularHomologyMap
+          (ThreefoldHomology.originalPieceInclusion (Option.some (Option.some j))) n
+          (SingularMayerVietoris.singularHomologyMap
+            (SpecialPeriods.Threefold.EllipticGeometry.centralSurfaceIntoPiece j) n
+            (SingularMayerVietoris.singularHomologyMap
+              (ThreefoldHomology.EllipticFibre.centralRealCover j) n a)) :=
+      (congrArg
+        (SingularMayerVietoris.singularHomologyMap
+          (ThreefoldHomology.originalPieceInclusion (Option.some (Option.some j))) n)
+        (LinearMap.congr_fun (fibreToFilling_homology_central j n) a))
+    _ =
+        SingularMayerVietoris.singularHomologyMap
+          (ThreefoldHomology.DeltaSweep.centralInclusionMap j) n
+          (SingularMayerVietoris.singularHomologyMap
+            (ThreefoldHomology.DeltaSweep.centralFlatPeriodCover j) n a) :=
+      (LinearMap.congr_fun hi
+          (SingularMayerVietoris.singularHomologyMap
+            (ThreefoldHomology.EllipticFibre.centralRealCover j) n a)).symm
+
+private theorem
+  ThreefoldHomology.CentralFibreCompatibility.regularFibreIntoSpace_homology_eq_central_apply
+    (j : Elliptic.Kind) (n : ℕ) (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    SingularMayerVietoris.singularHomologyMap
+        ThreefoldHomology.CapElimination.regularFibreIntoSpace n a =
+      SingularMayerVietoris.singularHomologyMap
+        (ThreefoldHomology.DeltaSweep.centralInclusionMap j) n
+        (SingularMayerVietoris.singularHomologyMap
+          (ThreefoldHomology.DeltaSweep.centralFlatPeriodCover j) n a) :=
+  LinearMap.congr_fun (regularFibreIntoSpace_homology_eq_central j n) a
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def ThreefoldHomology.DeltaSweep.sweep {X : Type} [TopologicalSpace X]
+    (a : C((PeriodTorusHigherHomology.CircleTopology.Circle) × X, X)) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology X n →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology X (n + 1) :=
+  (SingularMayerVietoris.singularHomologyMap a (n + 1)).comp
+    (PeriodTorusHigherHomology.positiveCircleCross X n)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem ThreefoldHomology.DeltaSweep.sweep_apply {X : Type} [TopologicalSpace X]
+    (a : C((PeriodTorusHigherHomology.CircleTopology.Circle) × X, X)) (n : ℕ)
+    (v : SingularMayerVietoris.SingularHomology X n) :
+    sweep a n v =
+      SingularMayerVietoris.singularHomologyMap a (n + 1)
+        (PeriodTorusHigherHomology.positiveCircleCross X n v) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    ThreefoldHomology.DeltaSweep.positiveCircleCross_natural {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (n : ℕ) (v : SingularMayerVietoris.SingularHomology X n) :
+    SingularMayerVietoris.singularHomologyMap
+        ((ContinuousMap.id (PeriodTorusHigherHomology.CircleTopology.Circle)).prodMap f) (n + 1)
+        (PeriodTorusHigherHomology.positiveCircleCross X n v) =
+      PeriodTorusHigherHomology.positiveCircleCross Y n
+        (SingularMayerVietoris.singularHomologyMap f n v) := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductHomology_natural
+      (ContinuousMap.id (PeriodTorusHigherHomology.CircleTopology.Circle)) f n
+      (FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop) v
+  change
+    SingularMayerVietoris.singularHomologyMap
+        ((ContinuousMap.id (PeriodTorusHigherHomology.CircleTopology.Circle)).prodMap f) (n + 1)
+        (PeriodTorusHigherHomology.positiveCircleCross X n v) =
+      PeriodTorusHigherHomology.crossProductHomology
+        (PeriodTorusHigherHomology.CircleTopology.Circle) Y n
+        (SingularMayerVietoris.singularHomologyMap
+          (ContinuousMap.id (PeriodTorusHigherHomology.CircleTopology.Circle)) 1
+          (FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop))
+        (SingularMayerVietoris.singularHomologyMap f n v) at h
+  simpa only [PeriodTorusHigherHomology.positiveCircleCross,
+    PeriodTorusHigherHomology.singularHomologyMap_id, LinearMap.id_apply] using h
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem ThreefoldHomology.DeltaSweep.sweep_natural {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (aX : C((PeriodTorusHigherHomology.CircleTopology.Circle) × X, X))
+    (aY : C((PeriodTorusHigherHomology.CircleTopology.Circle) × Y, Y)) (f : C(X, Y))
+    (h :
+      aY.comp ((ContinuousMap.id (PeriodTorusHigherHomology.CircleTopology.Circle)).prodMap f) =
+        f.comp aX)
+    (n : ℕ) (v : SingularMayerVietoris.SingularHomology X n) :
+    sweep aY n (SingularMayerVietoris.singularHomologyMap f n v) =
+      SingularMayerVietoris.singularHomologyMap f (n + 1) (sweep aX n v) := by
+  calc
+    _ =
+        SingularMayerVietoris.singularHomologyMap aY (n + 1)
+          (SingularMayerVietoris.singularHomologyMap
+            ((ContinuousMap.id (PeriodTorusHigherHomology.CircleTopology.Circle)).prodMap f)
+            (n + 1) (PeriodTorusHigherHomology.positiveCircleCross X n v)) := by
+      rw [sweep_apply, positiveCircleCross_natural]
+    _ =
+        SingularMayerVietoris.singularHomologyMap
+          (aY.comp
+            ((ContinuousMap.id (PeriodTorusHigherHomology.CircleTopology.Circle)).prodMap f))
+          (n + 1) (PeriodTorusHigherHomology.positiveCircleCross X n v) := by
+      rw [PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply]
+    _ =
+        SingularMayerVietoris.singularHomologyMap (f.comp aX) (n + 1)
+          (PeriodTorusHigherHomology.positiveCircleCross X n v) := by rw [h]
+    _ = _ := by
+      rw [PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply, sweep_apply]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem ThreefoldHomology.DeltaSweep.sweep_natural_of_equivariant {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y]
+    (aX : C((PeriodTorusHigherHomology.CircleTopology.Circle) × X, X))
+    (aY : C((PeriodTorusHigherHomology.CircleTopology.Circle) × Y, Y)) (f : C(X, Y))
+    (h : ∀ t x, aY (t, f x) = f (aX (t, x))) (n : ℕ)
+    (v : SingularMayerVietoris.SingularHomology X n) :
+    sweep aY n (SingularMayerVietoris.singularHomologyMap f n v) =
+      SingularMayerVietoris.singularHomologyMap f (n + 1) (sweep aX n v) := by
+  apply sweep_natural aX aY f ?_ n v
+  apply ContinuousMap.ext
+  intro p
+  exact h p.1 p.2
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    ThreefoldHomology.DeltaSweep.additionSweepMap {G : Type} [TopologicalSpace G] [AddCommGroup G]
+    [IsTopologicalAddGroup G] (b : C((PeriodTorusHigherHomology.CircleTopology.Circle), G)) :
+    C((PeriodTorusHigherHomology.CircleTopology.Circle) × G, G) :=
+  (PeriodTorusHigherHomologyPontryagin.additionMap G).comp (b.prodMap (ContinuousMap.id G))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem ThreefoldHomology.DeltaSweep.sweep_addition {G : Type} [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    (b : C((PeriodTorusHigherHomology.CircleTopology.Circle), G)) (n : ℕ)
+    (v : SingularMayerVietoris.SingularHomology G n) :
+    sweep (additionSweepMap b) n v =
+      PeriodTorusHigherHomologyPontryagin.product G n
+        (SingularMayerVietoris.singularHomologyMap b 1
+          (FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop))
+        v := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductHomology_natural b (ContinuousMap.id G) n
+      (FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop) v
+  change
+    SingularMayerVietoris.singularHomologyMap (b.prodMap (ContinuousMap.id G)) (n + 1)
+        (PeriodTorusHigherHomology.positiveCircleCross G n v) =
+      PeriodTorusHigherHomology.crossProductHomology G G n
+        (SingularMayerVietoris.singularHomologyMap b 1
+          (FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop))
+        (SingularMayerVietoris.singularHomologyMap (ContinuousMap.id G) n v) at h
+  rw [PeriodTorusHigherHomology.singularHomologyMap_id, LinearMap.id_apply] at h
+  rw [sweep_apply, additionSweepMap, PeriodTorusHigherHomology.singularHomologyMap_comp,
+    LinearMap.comp_apply, h, PeriodTorusHigherHomologyPontryagin.product_apply]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem ThreefoldHomology.DeltaSweep.sweep_equivariant_addition_of_comp_eq {X : Type}
+    [TopologicalSpace X] {G : Type} [TopologicalSpace G] [AddCommGroup G]
+    [IsTopologicalAddGroup G] (a : C((PeriodTorusHigherHomology.CircleTopology.Circle) × X, X))
+    (b : C((PeriodTorusHigherHomology.CircleTopology.Circle), G)) (i : C(G, X))
+    (h :
+      a.comp ((ContinuousMap.id (PeriodTorusHigherHomology.CircleTopology.Circle)).prodMap i) =
+        i.comp (additionSweepMap b))
+    (n : ℕ) (v : SingularMayerVietoris.SingularHomology G n) :
+    sweep a n (SingularMayerVietoris.singularHomologyMap i n v) =
+      SingularMayerVietoris.singularHomologyMap i (n + 1)
+        (PeriodTorusHigherHomologyPontryagin.product G n
+          (SingularMayerVietoris.singularHomologyMap b 1
+            (FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop))
+          v) := by rw [sweep_natural (additionSweepMap b) a i h, sweep_addition]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    ThreefoldHomology.DeltaSweep.sweep_equivariant_addition {X : Type} [TopologicalSpace X]
+    {G : Type} [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    (a : C((PeriodTorusHigherHomology.CircleTopology.Circle) × X, X))
+    (b : C((PeriodTorusHigherHomology.CircleTopology.Circle), G)) (i : C(G, X))
+    (h : ∀ t y, a (t, i y) = i (b t + y)) (n : ℕ)
+    (v : SingularMayerVietoris.SingularHomology G n) :
+    sweep a n (SingularMayerVietoris.singularHomologyMap i n v) =
+      SingularMayerVietoris.singularHomologyMap i (n + 1)
+        (PeriodTorusHigherHomologyPontryagin.product G n
+          (SingularMayerVietoris.singularHomologyMap b 1
+            (FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop))
+          v) := by
+  apply sweep_equivariant_addition_of_comp_eq a b i ?_ n v
+  apply ContinuousMap.ext
+  intro p
+  exact h p.1 p.2
+
+private def ThreefoldHomology.DeltaSweep.globalSweep (n : ℕ) :
+    SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space n →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space (n + 1) :=
+  sweep actionMap n
+
+private theorem ThreefoldHomology.DeltaSweep.globalSweep_one_apply_eq_zero
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 1) :
+    globalSweep 1 a = 0 := by
+  rw [SpecialPeriods.Threefold.LowDegrees.singularH1_eq_zero a, map_zero]
+
+private def ThreefoldHomology.DeltaSweep.centralSweep (j : Elliptic.Kind) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.EllipticFilling.SpecialCentralSurface j) n →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.EllipticFilling.SpecialCentralSurface j) (n + 1) :=
+  sweep (centralActionMap j) n
+
+private theorem
+    ThreefoldHomology.DeltaSweep.globalSweep_centralInclusion (j : Elliptic.Kind) (n : ℕ)
+    (v :
+      SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.EllipticFilling.SpecialCentralSurface j) n) :
+    globalSweep n (SingularMayerVietoris.singularHomologyMap (centralInclusionMap j) n v) =
+      SingularMayerVietoris.singularHomologyMap (centralInclusionMap j) (n + 1)
+        (centralSweep j n v) :=
+  sweep_natural_of_equivariant (centralActionMap j) actionMap (centralInclusionMap j)
+    (actionMap_centralInclusion j) n v
+
+private theorem ThreefoldHomology.DeltaSweep.centralSweep_global_eq_zero (j : Elliptic.Kind)
+    (v :
+      SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.EllipticFilling.SpecialCentralSurface j) 1) :
+    SingularMayerVietoris.singularHomologyMap (centralInclusionMap j) 2 (centralSweep j 1 v) =
+      0 := by
+  rw [← globalSweep_centralInclusion j 1 v]
+  exact globalSweep_one_apply_eq_zero _
+
+private theorem
+    ThreefoldHomology.DeltaSweep.centralSweep_flatPeriodCover (j : Elliptic.Kind) (n : ℕ)
+    (v : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    centralSweep j n (SingularMayerVietoris.singularHomologyMap (centralFlatPeriodCover j) n v) =
+      SingularMayerVietoris.singularHomologyMap (centralFlatPeriodCover j) (n + 1)
+        (PeriodTorusHigherHomologyPontryagin.product RealTorus₄ n
+          (PeriodFamily.FlatTorus.singularH1Equiv.symm deltaLattice) v) := by
+  have h :=
+    sweep_equivariant_addition (centralActionMap j) deltaCircle (centralFlatPeriodCover j)
+      (centralActionMap_flatPeriodCover j) n v
+  rw [deltaCircle_positiveLoop_singularHomology] at h
+  exact h
+
+private theorem ThreefoldHomology.DeltaSweep.flat_product11_exterior (a b : Lattice) :
+    PeriodFamily.FlatTorus.singularH2Equiv
+        (PeriodTorusHigherHomologyPontryagin.product11 RealTorus₄
+          (PeriodFamily.FlatTorus.singularH1Equiv.symm a)
+          (PeriodFamily.FlatTorus.singularH1Equiv.symm b)) =
+      exteriorPower.ιMulti ℤ 2 ![a, b] := by
+  rw [PeriodFamily.FlatTorus.singularH2Equiv_apply,
+    PeriodTorusHigherHomologyPontryagin.product_natural _
+      PeriodTorusHigherHomology.flatTorusCircleHomeomorph_add 1,
+    PeriodFamily.FlatTorus.coordinateH1_flatMarking,
+    PeriodFamily.FlatTorus.coordinateH1_flatMarking]
+  calc
+    _ =
+        PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv
+          (PeriodTorusHigherHomology.coordinateTorusWedgeTwo
+            (exteriorPower.ιMulti ℤ 2 ![a, b])) :=
+      congrArg PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv
+        (PeriodTorusHigherHomology.coordinateTorusWedgeTwo_apply_ιMulti ![a, b]).symm
+    _ = _ := PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv_wedge _
+
+private theorem ThreefoldHomology.DeltaSweep.flat_product11_coordinates (a b : Lattice) :
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        (PeriodTorusHigherHomologyPontryagin.product11 RealTorus₄
+          (PeriodFamily.FlatTorus.singularH1Equiv.symm a)
+          (PeriodFamily.FlatTorus.singularH1Equiv.symm b)) =
+      ![a 0 * b 1 - a 1 * b 0, a 0 * b 2 - a 2 * b 0, a 0 * b 3 - a 3 * b 0,
+        a 1 * b 2 - a 2 * b 1, a 1 * b 3 - a 3 * b 1, a 2 * b 3 - a 3 * b 2] := by
+  rw [PeriodFamily.FlatTorus.singularH2Coordinates_apply, flat_product11_exterior]
+  funext i
+  rw [PeriodTorusHigherHomologyExterior.squareCoordinates_apply,
+    PeriodTorusHigherHomologyExterior.squareBasis, Module.Basis.repr_reindex_apply]
+  change
+    ((Pi.basisFun ℤ (Fin 4)).exteriorPower 2).repr (exteriorPower.ιMulti ℤ 2 ![a, b])
+        (PeriodTorusHigherHomologyExterior.pairSubset i) =
+      _
+  rw [exteriorPower.basis_repr_apply, exteriorPower.ιMultiDual_apply_ιMulti]
+  simp only [PeriodTorusHigherHomologyExterior.pairSubset_ordered, Module.Basis.coord_apply,
+    Pi.basisFun_repr]
+  fin_cases i <;> simp [LocalSystemMatrices.pairIndices, Matrix.det_fin_two, mul_comm]
+
+private theorem ThreefoldHomology.DeltaSweep.flat_delta_product11_coordinates (v : Lattice) :
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        (PeriodTorusHigherHomologyPontryagin.product11 RealTorus₄
+          (PeriodFamily.FlatTorus.singularH1Equiv.symm ![0, 0, 0, 1])
+          (PeriodFamily.FlatTorus.singularH1Equiv.symm v)) =
+      ![0, 0, -v 0, 0, -v 1, -v 2] := by
+  rw [flat_product11_coordinates]
+  simp
+
+private theorem
+    ThreefoldHomology.DeltaSweep.centralFlatPeriodCover_eq_surfaceCover (j : Elliptic.Kind) :
+    centralFlatPeriodCover j = PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover j := by
+  rw [PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover_eq_periodCover]
+  rfl
+
+private theorem ThreefoldHomology.DeltaSweep.originalAffineNorm_delta_splitFibreClassOne
+    (j : Elliptic.Kind) :
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        (PeriodFamily.Boundary.EllipticCapKernelWang.originalAffineNorm j 2
+          (PeriodTorusHigherHomologyPontryagin.product11 RealTorus₄
+            (PeriodFamily.FlatTorus.singularH1Equiv.symm deltaLattice)
+            (PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreClassOne j))) =
+      0 := by
+  have hf :
+    PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreClassOne j =
+      PeriodFamily.FlatTorus.singularH1Equiv.symm ![0, 0, 1, 0] := by
+    apply PeriodFamily.FlatTorus.singularH1Equiv.injective
+    rw [PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreClassOne_coordinates,
+      LinearEquiv.apply_symm_apply]
+  rw [hf, PeriodFamily.Boundary.EllipticCapKernelWang.originalAffineNorm_h2_coordinates,
+    deltaLattice, flat_delta_product11_coordinates]
+  cases j
+  · rw [PeriodFamily.Boundary.EllipticCapKernelWang.originalNormMatrixTwo_three]
+    decide
+  · rw [PeriodFamily.Boundary.EllipticCapKernelWang.originalNormMatrixTwo_four]
+    decide
+
+private theorem ThreefoldHomology.DeltaSweep.originalAffineNorm_delta_splitCircleClassOne
+    (j : Elliptic.Kind) :
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        (PeriodFamily.Boundary.EllipticCapKernelWang.originalAffineNorm j 2
+          (PeriodTorusHigherHomologyPontryagin.product11 RealTorus₄
+            (PeriodFamily.FlatTorus.singularH1Equiv.symm deltaLattice)
+            (PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassOne j))) =
+      -(j.order : ℤ) • PeriodFamily.Boundary.EllipticCapKernelWang.twistDeltaVector j := by
+  have hc :
+    PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassOne j =
+      PeriodFamily.FlatTorus.singularH1Equiv.symm j.twist := by
+    apply PeriodFamily.FlatTorus.singularH1Equiv.injective
+    rw [PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassOne_coordinates,
+      LinearEquiv.apply_symm_apply]
+  rw [hc, PeriodFamily.Boundary.EllipticCapKernelWang.originalAffineNorm_h2_coordinates,
+    deltaLattice, flat_delta_product11_coordinates]
+  cases j
+  · rw [PeriodFamily.Boundary.EllipticCapKernelWang.originalNormMatrixTwo_three]
+    decide
+  · rw [PeriodFamily.Boundary.EllipticCapKernelWang.originalNormMatrixTwo_four]
+    decide
+
+private theorem
+    ThreefoldHomology.DeltaSweep.centralSweep_h2Coordinates_surfaceCover (j : Elliptic.Kind)
+    (v : SingularMayerVietoris.SingularHomology RealTorus₄ 1) :
+    PeriodFamily.Boundary.EllipticCapKernelWang.h2Coordinates j
+        (centralSweep j 1
+          (SingularMayerVietoris.singularHomologyMap
+            (PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover j) 1 v)) =
+      PeriodFamily.FlatTorus.singularH2Coordinates
+        (PeriodFamily.Boundary.EllipticCapKernelWang.originalAffineNorm j 2
+          (PeriodTorusHigherHomologyPontryagin.product11 RealTorus₄
+            (PeriodFamily.FlatTorus.singularH1Equiv.symm deltaLattice) v)) := by
+  rw [← centralFlatPeriodCover_eq_surfaceCover, centralSweep_flatPeriodCover,
+    centralFlatPeriodCover_eq_surfaceCover,
+    PeriodFamily.Boundary.EllipticCapKernelWang.h2Coordinates_surfaceCover]
+
+private theorem ThreefoldHomology.DeltaSweep.centralSweep_h2Coordinates (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.EllipticFilling.SpecialCentralSurface j) 1) :
+    PeriodFamily.Boundary.EllipticCapKernelWang.h2Coordinates j (centralSweep j 1 a) =
+      -Elliptic.HigherHomology.surfaceH1Equiv j
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1 •
+        PeriodFamily.Boundary.EllipticCapKernelWang.twistDeltaVector j := by
+  have h :=
+    PeriodFamily.Boundary.EllipticCapKernelWang.map_cover_columns
+      (Elliptic.HigherHomology.surfaceH1Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod)
+      ((PeriodFamily.Boundary.EllipticCapKernelWang.h2Coordinates j).comp (centralSweep j 1))
+      (SingularMayerVietoris.singularHomologyMap
+        (PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover j) 1
+        (PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreClassOne j))
+      (SingularMayerVietoris.singularHomologyMap
+        (PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover j) 1
+        (PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassOne j))
+      a (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearOne j) (j.order : ℤ)
+      (PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover_splitFibreClassOne j)
+      (PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover_splitCircleClassOne j)
+  simp only [LinearMap.comp_apply, centralSweep_h2Coordinates_surfaceCover,
+    originalAffineNorm_delta_splitFibreClassOne, originalAffineNorm_delta_splitCircleClassOne,
+    smul_zero, zero_add] at h
+  ext i
+  apply mul_left_cancel₀ (show (j.order : ℤ) ≠ 0 by cases j <;> decide)
+  have hi := congrFun h i
+  change
+    (j.order : ℤ) *
+        PeriodFamily.Boundary.EllipticCapKernelWang.h2Coordinates j (centralSweep j 1 a) i =
+      Elliptic.HigherHomology.surfaceH1Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1 *
+        (-(j.order : ℤ) * PeriodFamily.Boundary.EllipticCapKernelWang.twistDeltaVector j i) at hi
+  change
+    (j.order : ℤ) *
+        PeriodFamily.Boundary.EllipticCapKernelWang.h2Coordinates j (centralSweep j 1 a) i =
+      (j.order : ℤ) *
+        (-Elliptic.HigherHomology.surfaceH1Equiv j
+              (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1 *
+          PeriodFamily.Boundary.EllipticCapKernelWang.twistDeltaVector j i)
+  rw [hi]
+  ring
+
+private theorem ThreefoldHomology.DeltaSweep.centralSweep_secondCoordinate (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.EllipticFilling.SpecialCentralSurface j) 1) :
+    Elliptic.HigherHomology.surfaceH2Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod (centralSweep j 1 a) 1 =
+      -Elliptic.HigherHomology.surfaceH1Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1 := by
+  apply mul_right_cancel₀ (show j.twist 0 ≠ 0 by cases j <;> decide)
+  have h := congrFun (centralSweep_h2Coordinates j a) (2 : Fin 6)
+  rw [PeriodFamily.Boundary.EllipticCapKernelWang.h2Coordinates_formula] at h
+  simpa [PeriodFamily.Boundary.EllipticCapKernelWang.fibreInvariantPairVector,
+    PeriodFamily.Boundary.EllipticCapKernelWang.twistDeltaVector] using h
+
+private theorem
+    ThreefoldHomology.DeltaSweep.centralSweep_firstCoordinate_mul_index (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.EllipticFilling.SpecialCentralSurface j) 1) :
+    (Elliptic.HigherHomology.fibreNormIndex j : ℤ) *
+        Elliptic.HigherHomology.surfaceH2Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod (centralSweep j 1 a)
+          0 =
+      -PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo j *
+        Elliptic.HigherHomology.surfaceH1Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1 := by
+  have h := congrFun (centralSweep_h2Coordinates j a) (3 : Fin 6)
+  rw [PeriodFamily.Boundary.EllipticCapKernelWang.h2Coordinates_formula] at h
+  have hzero :
+    ((Elliptic.HigherHomology.fibreNormIndex j : ℤ) *
+            Elliptic.HigherHomology.surfaceH2Equiv j
+              (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+              (centralSweep j 1 a) 0 -
+          PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo j *
+            Elliptic.HigherHomology.surfaceH2Equiv j
+              (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+              (centralSweep j 1 a) 1) *
+        Elliptic.HigherHomology.fibreSquareKernelVector j 0 =
+      0 := by
+    simpa [PeriodFamily.Boundary.EllipticCapKernelWang.fibreInvariantPairVector,
+      PeriodFamily.Boundary.EllipticCapKernelWang.twistDeltaVector] using h
+  have hcoef :=
+    (mul_eq_zero.mp hzero).resolve_right
+      (show Elliptic.HigherHomology.fibreSquareKernelVector j 0 ≠ 0 by cases j <;> decide)
+  rw [centralSweep_secondCoordinate] at hcoef
+  linarith only [hcoef]
+
+private theorem ThreefoldHomology.DeltaSweep.fibreNormIndex_dvd_sourceShearTwo (j : Elliptic.Kind) :
+    (Elliptic.HigherHomology.fibreNormIndex j : ℤ) ∣
+      PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo j := by
+  let a :=
+    (Elliptic.HigherHomology.surfaceH1Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).symm
+      ![0, 1]
+  have h := centralSweep_firstCoordinate_mul_index j a
+  have ha :
+    Elliptic.HigherHomology.surfaceH1Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1 =
+      1 := by simp [a]
+  rw [ha, mul_one] at h
+  refine
+    ⟨-Elliptic.HigherHomology.surfaceH2Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod (centralSweep j 1 a)
+          0,
+      ?_⟩
+  rw [mul_neg, h, neg_neg]
+
+private def ThreefoldHomology.DeltaSweep.centralSweepShearCorrection (j : Elliptic.Kind) : ℤ :=
+  PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo j /
+    (Elliptic.HigherHomology.fibreNormIndex j : ℤ)
+
+private theorem ThreefoldHomology.DeltaSweep.fibreNormIndex_mul_centralSweepShearCorrection
+    (j : Elliptic.Kind) :
+    (Elliptic.HigherHomology.fibreNormIndex j : ℤ) * centralSweepShearCorrection j =
+      PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo j := by
+  rw [mul_comm]
+  exact Int.ediv_mul_cancel (fibreNormIndex_dvd_sourceShearTwo j)
+
+private theorem ThreefoldHomology.DeltaSweep.centralSweep_firstCoordinate (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.EllipticFilling.SpecialCentralSurface j) 1) :
+    Elliptic.HigherHomology.surfaceH2Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod (centralSweep j 1 a) 0 =
+      -centralSweepShearCorrection j *
+        Elliptic.HigherHomology.surfaceH1Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1 := by
+  apply mul_left_cancel₀ (Elliptic.HigherHomology.fibreNormIndex_int_ne_zero j)
+  rw [centralSweep_firstCoordinate_mul_index, ← fibreNormIndex_mul_centralSweepShearCorrection]
+  ring
+
+private theorem ThreefoldHomology.DeltaSweep.centralSweep_coordinates (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.EllipticFilling.SpecialCentralSurface j) 1) :
+    Elliptic.HigherHomology.surfaceH2Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod (centralSweep j 1 a) =
+      ![-centralSweepShearCorrection j *
+          Elliptic.HigherHomology.surfaceH1Equiv j
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1,
+        -Elliptic.HigherHomology.surfaceH1Equiv j
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1] := by
+  ext i
+  fin_cases i
+  · exact centralSweep_firstCoordinate j a
+  · exact centralSweep_secondCoordinate j a
+
+private theorem ThreefoldHomology.DeltaSweep.neg_centralSweep_second_axis_coordinates
+    (j : Elliptic.Kind) :
+    Elliptic.HigherHomology.surfaceH2Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+        (-centralSweep j 1
+            ((Elliptic.HigherHomology.surfaceH1Equiv j
+                  (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).symm
+              ![0, 1])) =
+      ![centralSweepShearCorrection j, 1] := by
+  rw [map_neg, centralSweep_coordinates, LinearEquiv.apply_symm_apply]
+  ext i
+  fin_cases i <;> simp
+
+private theorem ThreefoldHomology.DeltaSweep.neg_centralSweep_second_axis_global_eq_zero
+    (j : Elliptic.Kind) :
+    SingularMayerVietoris.singularHomologyMap (centralInclusionMap j) 2
+        (-centralSweep j 1
+            ((Elliptic.HigherHomology.surfaceH1Equiv j
+                  (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).symm
+              ![0, 1])) =
+      0 := by rw [map_neg, centralSweep_global_eq_zero, neg_zero]
+
+private theorem ThreefoldHomology.DeltaSweep.exists_centralKernelClass_unit_secondCoordinate
+    (j : Elliptic.Kind) :
+    ∃ a :
+      SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.EllipticFilling.SpecialCentralSurface j) 2,
+      Elliptic.HigherHomology.surfaceH2Equiv j
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a =
+          ![centralSweepShearCorrection j, 1] ∧
+        SingularMayerVietoris.singularHomologyMap (centralInclusionMap j) 2 a = 0 :=
+  ⟨-centralSweep j 1
+        ((Elliptic.HigherHomology.surfaceH1Equiv j
+              (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).symm
+          ![0, 1]),
+    neg_centralSweep_second_axis_coordinates j, neg_centralSweep_second_axis_global_eq_zero j⟩
+
+private theorem ThreefoldHomology.Finiteness.homology_subsingleton_of_lt {n : ℕ} (hn : 6 < n) :
+    Subsingleton (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space n) := by
+  cases n with
+  | zero => omega
+  | succ n =>
+    have := starPairHomology_subsingleton (by omega : 5 < n + 1)
+    have := starOverlapHomology_subsingleton (by omega : 5 < n)
+    exact
+      ThreefoldHomologyFinitenessAlgebra.subsingleton_of_exact
+        (ThreefoldHomology.starRightHomologyMap (n + 1))
+        (ThreefoldHomology.starConnectingHomomorphism n)
+        (ThreefoldHomology.star_exact_at_ambient n)
+
+private theorem ThreefoldHomology.SecondDegree.centralCover_splitCircle_global_eq_zero
+    (j : Elliptic.Kind) :
+    SingularMayerVietoris.singularHomologyMap (ThreefoldHomology.DeltaSweep.centralInclusionMap j)
+        2
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover j) 2
+          (PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassTwo j)) =
+      0 := by
+  obtain ⟨a, ha, hz⟩ :=
+    ThreefoldHomology.DeltaSweep.exists_centralKernelClass_unit_secondCoordinate j
+  have hclass :
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover j) 2
+        (PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassTwo j) =
+      (Elliptic.HigherHomology.fibreNormIndex j : ℤ) • a := by
+    apply
+      (Elliptic.HigherHomology.surfaceH2Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).injective
+    rw [PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover_splitCircleClassTwo]
+    have hm :=
+      map_zsmul
+        (Elliptic.HigherHomology.surfaceH2Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod)
+        (Elliptic.HigherHomology.fibreNormIndex j : ℤ) a
+    rw [ha] at hm
+    rw [hm]
+    ext i
+    fin_cases i
+    · simpa using
+        (ThreefoldHomology.DeltaSweep.fibreNormIndex_mul_centralSweepShearCorrection j).symm
+    · simp
+  rw [hclass]
+  have hm :=
+    map_zsmul
+      (SingularMayerVietoris.singularHomologyMap
+        (ThreefoldHomology.DeltaSweep.centralInclusionMap j) 2)
+      (Elliptic.HigherHomology.fibreNormIndex j : ℤ) a
+  rw [hz] at hm
+  exact
+    hm.trans
+      (@zsmul_zero (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 2) _
+        (Elliptic.HigherHomology.fibreNormIndex j : ℤ))
+
+private theorem ThreefoldHomology.SecondDegree.regularFibre_splitCircle_global_eq_zero
+    (j : Elliptic.Kind) :
+    SingularMayerVietoris.singularHomologyMap
+        ThreefoldHomology.CapElimination.regularFibreIntoSpace 2
+        (PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassTwo j) =
+      0 := by
+  rw [ThreefoldHomology.CentralFibreCompatibility.regularFibreIntoSpace_homology_eq_central_apply,
+    ThreefoldHomology.DeltaSweep.centralFlatPeriodCover_eq_surfaceCover]
+  exact centralCover_splitCircle_global_eq_zero j
+
+private theorem
+    ThreefoldHomology.SecondDegree.homologyTwoCyclicMap_twist_u_eq_zero (j : Elliptic.Kind) :
+    homologyTwoCyclicMap (j.twist 1) = 0 := by
+  have h :=
+    (regularFibre_homologyTwo_coordinates
+          (PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassTwo j)).symm.trans
+      (regularFibre_splitCircle_global_eq_zero j)
+  have hc :
+    6 *
+          PeriodFamily.FlatTorus.singularH2Coordinates
+            (PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassTwo j) 2 +
+        PeriodFamily.FlatTorus.singularH2Coordinates
+          (PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassTwo j) 3 =
+      j.twist 1 := by
+    rw [PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassTwo_coordinates]
+    simp
+  exact (congrArg homologyTwoCyclicMap hc).symm.trans h
+
+private theorem ThreefoldHomology.SecondDegree.homologyTwoCyclicMap_two_eq_zero :
+    homologyTwoCyclicMap 2 = 0 := by
+  simpa [Elliptic.Kind.twist, ε] using homologyTwoCyclicMap_twist_u_eq_zero Elliptic.Kind.three
+
+private theorem ThreefoldHomology.SecondDegree.homologyTwoCyclicMap_neg_three_eq_zero :
+    homologyTwoCyclicMap (-3) = 0 := by
+  simpa [Elliptic.Kind.twist, ε'] using homologyTwoCyclicMap_twist_u_eq_zero Elliptic.Kind.four
+
+private theorem
+    ThreefoldHomology.SecondDegree.homologyTwoGenerator_eq_zero : homologyTwoGenerator = 0 := by
+  change homologyTwoCyclicMap 1 = 0
+  rw [show (1 : ℤ) = 2 + 2 + -3 by decide, map_add, map_add, homologyTwoCyclicMap_two_eq_zero,
+    homologyTwoCyclicMap_neg_three_eq_zero]
+  simp only [add_zero]
+
+private theorem ThreefoldHomology.SecondDegree.homologyTwo_subsingleton :
+    Subsingleton (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 2) :=
+  homologyTwo_subsingleton_iff_generator_eq_zero.mpr homologyTwoGenerator_eq_zero
+
+private theorem ThreefoldHomology.SecondDegree.nativeCapKernelRegularMap_two_surjective :
+    Function.Surjective (ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 2) :=
+  ThreefoldHomology.CapElimination.homologyTwo_subsingleton_iff_nativeCapKernel_surjective.mp
+    homologyTwo_subsingleton
+
+private theorem ThreefoldHomology.SecondDegree.cuspWangOne_first_two_zero
+    (a :
+      LinearMap.ker
+        (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy Option.none)
+          1)) :
+    PeriodFamily.FlatTorus.singularH1Equiv a.val 0 = 0 ∧
+      PeriodFamily.FlatTorus.singularH1Equiv a.val 1 = 0 := by
+  have ha :
+    MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy Option.none) 1
+        a.val =
+      0 :=
+    a.property
+  have h :=
+    (ThreefoldHomology.BoundaryFirst.boundaryWangDifference_one_coordinates Option.none
+          a.val).symm.trans
+      ((congrArg PeriodFamily.FlatTorus.singularH1Equiv ha).trans
+        PeriodFamily.FlatTorus.singularH1Equiv.map_zero)
+  change -((M₀ - 1) *ᵥ PeriodFamily.FlatTorus.singularH1Equiv a.val) = 0 at h
+  exact (M₀_sub_one_kernel _).mp (neg_eq_zero.mp h)
+
+private theorem ThreefoldHomology.SecondDegree.cuspPlane_fixed_mo1973_29384 (a : Fin 2 → ℤ) :
+    M₀ *ᵥ ![0, 0, a 0, a 1] = ![0, 0, a 0, a 1] := by
+  ext i
+  fin_cases i <;> simp [M₀, Matrix.mulVec, dotProduct, Fin.sum_univ_succ]
+
+private def ThreefoldHomology.SecondDegree.cuspWangOneEquiv :
+    LinearMap.ker
+        (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy Option.none)
+          1) ≃ₗ[ℤ]
+      (Fin 2 → ℤ) :=
+  ({    toFun
+          a :=
+          ![PeriodFamily.FlatTorus.singularH1Equiv a.val 2,
+            PeriodFamily.FlatTorus.singularH1Equiv a.val 3]
+        invFun
+          a :=
+          ThreefoldHomology.CapElimination.cuspOneInvariant ![0, 0, a 0, a 1]
+            (cuspPlane_fixed_mo1973_29384 a)
+        left_inv
+          a := by
+          apply Subtype.ext
+          apply PeriodFamily.FlatTorus.singularH1Equiv.injective
+          change
+            PeriodFamily.FlatTorus.singularH1Equiv
+                (PeriodFamily.FlatTorus.singularH1Equiv.symm
+                  ![0, 0, PeriodFamily.FlatTorus.singularH1Equiv a.val 2,
+                    PeriodFamily.FlatTorus.singularH1Equiv a.val 3]) =
+              PeriodFamily.FlatTorus.singularH1Equiv a.val
+          rw [LinearEquiv.apply_symm_apply]
+          obtain ⟨h₀, h₁⟩ := cuspWangOne_first_two_zero a
+          ext i
+          fin_cases i <;> simp [h₀, h₁]
+        right_inv
+          a := by
+          change
+            ![PeriodFamily.FlatTorus.singularH1Equiv
+                  (PeriodFamily.FlatTorus.singularH1Equiv.symm ![0, 0, a 0, a 1]) 2,
+                PeriodFamily.FlatTorus.singularH1Equiv
+                  (PeriodFamily.FlatTorus.singularH1Equiv.symm ![0, 0, a 0, a 1]) 3] =
+              a
+          rw [LinearEquiv.apply_symm_apply]
+          ext i
+          fin_cases i <;> rfl
+        map_add' a
+          b := by
+          ext i
+          fin_cases i <;> simp [map_add] } :
+      LinearMap.ker
+          (MappingTorusHomology.wangDifference
+            (ThreefoldOverlapMappingTorus.monodromy Option.none) 1) ≃+
+        (Fin 2 → ℤ)).toIntLinearEquiv
+
+private def ThreefoldHomology.SecondDegree.nativeCapKernelTwoEquiv
+    (i : SpecialPeriods.Threefold.Puncture) :
+    ThreefoldHomology.CapElimination.NativeCapKernel i 2 ≃ₗ[ℤ] (Fin 2 → ℤ) := by
+  cases i with
+  | none =>
+    exact
+      ((ThreefoldHomologyCuspFibre.cuspCapKernelWangEquivDegree 1).toAddEquiv.trans
+          cuspWangOneEquiv.toAddEquiv).toIntLinearEquiv
+  | some j =>
+    exact
+      ((PeriodFamily.Boundary.EllipticCapProduct.boundaryCapKernelEquiv j 1).toAddEquiv.trans
+          (Elliptic.HigherHomology.surfaceH1Equiv j
+              (SpecialPeriods.EllipticFilling.specialLocalData
+                  j).centralPeriod).toAddEquiv).toIntLinearEquiv
+
+private theorem ThreefoldHomology.SecondDegree.nativeCapKernelTwo_free
+    (i : SpecialPeriods.Threefold.Puncture) :
+    Module.Free ℤ (ThreefoldHomology.CapElimination.NativeCapKernel i 2) :=
+  Module.Free.of_equiv (nativeCapKernelTwoEquiv i).symm
+
+private theorem ThreefoldHomology.SecondDegree.nativeCapKernelTwo_finite
+    (i : SpecialPeriods.Threefold.Puncture) :
+    Module.Finite ℤ (ThreefoldHomology.CapElimination.NativeCapKernel i 2) :=
+  Module.Finite.of_surjective (nativeCapKernelTwoEquiv i).symm.toLinearMap
+    (nativeCapKernelTwoEquiv i).symm.surjective
+
+private theorem ThreefoldHomology.SecondDegree.nativeCapKernelTwo_finrank
+    (i : SpecialPeriods.Threefold.Puncture) :
+    Module.finrank ℤ (ThreefoldHomology.CapElimination.NativeCapKernel i 2) = 2 := by
+  rw [(nativeCapKernelTwoEquiv i).finrank_eq]
+  simp
+
+private theorem ThreefoldHomology.SecondDegree.nativeCapKernelsTwo_free :
+    Module.Free ℤ
+      (∀ i : SpecialPeriods.Threefold.Puncture,
+        ThreefoldHomology.CapElimination.NativeCapKernel i 2) := by
+  have :
+    ∀ i : SpecialPeriods.Threefold.Puncture,
+      Module.Free ℤ (ThreefoldHomology.CapElimination.NativeCapKernel i 2) :=
+    nativeCapKernelTwo_free
+  exact
+    ThreefoldHomologyFreeProducts.free_pi_int
+      (fun i : SpecialPeriods.Threefold.Puncture =>
+        ThreefoldHomology.CapElimination.NativeCapKernel i 2)
+
+private theorem ThreefoldHomology.SecondDegree.nativeCapKernelsTwo_finite :
+    Module.Finite ℤ
+      (∀ i : SpecialPeriods.Threefold.Puncture,
+        ThreefoldHomology.CapElimination.NativeCapKernel i 2) := by
+  have :
+    ∀ i : SpecialPeriods.Threefold.Puncture,
+      Module.Finite ℤ (ThreefoldHomology.CapElimination.NativeCapKernel i 2) :=
+    nativeCapKernelTwo_finite
+  exact
+    ThreefoldHomology.Finiteness.finite_pi_int
+      (fun i : SpecialPeriods.Threefold.Puncture =>
+        ThreefoldHomology.CapElimination.NativeCapKernel i 2)
+
+private theorem ThreefoldHomology.SecondDegree.nativeCapKernelsTwo_finrank :
+    Module.finrank ℤ
+        (∀ i : SpecialPeriods.Threefold.Puncture,
+          ThreefoldHomology.CapElimination.NativeCapKernel i 2) =
+      6 := by
+  have :
+    ∀ i : SpecialPeriods.Threefold.Puncture,
+      Module.Free ℤ (ThreefoldHomology.CapElimination.NativeCapKernel i 2) :=
+    nativeCapKernelTwo_free
+  have :
+    ∀ i : SpecialPeriods.Threefold.Puncture,
+      Module.Finite ℤ (ThreefoldHomology.CapElimination.NativeCapKernel i 2) :=
+    nativeCapKernelTwo_finite
+  rw [ThreefoldHomologyFreeProducts.finrank_pi_int
+      (fun i : SpecialPeriods.Threefold.Puncture =>
+        ThreefoldHomology.CapElimination.NativeCapKernel i 2)]
+  simp only [nativeCapKernelTwo_finrank, Finset.sum_const, Finset.card_univ, puncture_card]
+  decide
+
+private theorem ThreefoldHomology.SecondDegree.nativeCapKernelRegularMap_two_bijective :
+    Function.Bijective (ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 2) := by
+  have := nativeCapKernelsTwo_free
+  have := nativeCapKernelsTwo_finite
+  have := ThreefoldHomology.Finiteness.regularHomology_free 2
+  have := ThreefoldHomology.Finiteness.regularHomology_finite 2
+  apply
+    OrzechProperty.bijective_of_surjective_of_finrank_le
+      (ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 2)
+      nativeCapKernelRegularMap_two_surjective
+  rw [nativeCapKernelsTwo_finrank, ThreefoldHomology.Finiteness.regularHomology_finrank]
+  exact le_rfl
+
+private theorem ThreefoldHomology.SecondDegree.starLeft_two_injective :
+    Function.Injective (ThreefoldHomology.starLeftHomologyMap 2) := by
+  intro a b hab
+  have hz : ThreefoldHomology.starLeftHomologyMap 2 (a - b) = 0 := by rw [map_sub, hab, sub_self]
+  have hreg : ThreefoldHomology.starOverlapToRegularHomologyMap 2 (a - b) = 0 :=
+    congrArg Prod.fst hz
+  have hcap : ThreefoldHomology.starOverlapToFillingsHomologyMap 2 (a - b) = 0 := by
+    have h := congrArg Prod.snd hz
+    change -ThreefoldHomology.starOverlapToFillingsHomologyMap 2 (a - b) = 0 at h
+    exact neg_eq_zero.mp h
+  let c : LinearMap.ker (ThreefoldHomology.starOverlapToFillingsHomologyMap 2) := ⟨a - b, hcap⟩
+  have hc :
+    ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 2
+        (ThreefoldHomology.CapElimination.nativeCapKernelEquiv 2 c) =
+      0 :=
+    (ThreefoldHomology.CapElimination.nativeCapKernelRegularMap_equiv 2 c).trans hreg
+  have he : ThreefoldHomology.CapElimination.nativeCapKernelEquiv 2 c = 0 :=
+    nativeCapKernelRegularMap_two_bijective.injective
+      (hc.trans (ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 2).map_zero.symm)
+  have hc0 : c = 0 :=
+    (ThreefoldHomology.CapElimination.nativeCapKernelEquiv 2).injective
+      (he.trans (ThreefoldHomology.CapElimination.nativeCapKernelEquiv 2).map_zero.symm)
+  have hab0 : a - b = 0 :=
+    congrArg
+      (fun x : LinearMap.ker (ThreefoldHomology.starOverlapToFillingsHomologyMap 2) => x.val) hc0
+  exact sub_eq_zero.mp hab0
+
+private theorem ThreefoldHomology.ThirdDegree.connecting_two_eq_zero :
+    ThreefoldHomology.starConnectingHomomorphism 2 = 0 := by
+  apply LinearMap.ext
+  intro a
+  change ThreefoldHomology.starConnectingHomomorphism 2 a = 0
+  apply ThreefoldHomology.SecondDegree.starLeft_two_injective
+  simpa only [map_zero] using
+    (ThreefoldHomology.star_exact_at_intersection 2).apply_apply_eq_zero a
+
+private theorem ThreefoldHomology.ThirdDegree.starRight_three_surjective :
+    Function.Surjective (ThreefoldHomology.starRightHomologyMap 3) := by
+  intro a
+  apply (ThreefoldHomology.star_exact_at_ambient 2 a).mp
+  rw [connecting_two_eq_zero, LinearMap.zero_apply]
+
+private def ThreefoldHomology.ThirdSource.threeWangVector (c3 : ℤ) (a : Fin 2 → ℤ) : Fin 6 → ℤ :=
+  (a 0 - c3 * a 1) • ![0, 0, 0, 3, -1, 2] + a 1 • ![0, 0, 1, 0, 2, -4]
+
+private def ThreefoldHomology.ThirdSource.fourWangVector (c4 : ℤ) (a : Fin 2 → ℤ) : Fin 6 → ℤ :=
+  (2 * a 0 - c4 * a 1) • ![0, 0, 0, 2, -1, 1] + a 1 • ![0, 0, -1, 0, -3, 3]
+
+private theorem ThreefoldHomology.ThirdSource.threeWangVector_apply (c3 : ℤ) (a : Fin 2 → ℤ) :
+    threeWangVector c3 a =
+      ![0, 0, a 1, 3 * (a 0 - c3 * a 1), -(a 0 - c3 * a 1) + 2 * a 1,
+        2 * (a 0 - c3 * a 1) - 4 * a 1] := by
+  ext i
+  fin_cases i <;> simp [threeWangVector] <;> ring
+
+private theorem ThreefoldHomology.ThirdSource.fourWangVector_apply (c4 : ℤ) (a : Fin 2 → ℤ) :
+    fourWangVector c4 a =
+      ![0, 0, -a 1, 2 * (2 * a 0 - c4 * a 1), -(2 * a 0 - c4 * a 1) - 3 * a 1,
+        (2 * a 0 - c4 * a 1) + 3 * a 1] := by
+  ext i
+  fin_cases i <;> simp [fourWangVector] <;> ring
+
+private theorem ThreefoldHomology.ThirdSource.fourWangVector_fixed (c4 : ℤ) (a : Fin 2 → ℤ) :
+    PeriodTorusHigherHomologyExterior.squareA₂ *ᵥ fourWangVector c4 a = fourWangVector c4 a := by
+  rw [fourWangVector_apply, PeriodTorusHigherHomologyExterior.squareA₂_eq]
+  ext i
+  fin_cases i <;> simp [Matrix.mulVec, dotProduct, Fin.sum_univ_succ] <;> ring
+
+private def ThreefoldHomology.ThirdSource.cuspVector (b c d e : ℤ) : Fin 6 → ℤ :=
+  ![0, b, c, d, -b, e]
+
+private theorem ThreefoldHomology.ThirdSource.squareM₀_fixed_iff (v : Fin 6 → ℤ) :
+    PeriodTorusHigherHomologyExterior.squareM₀ *ᵥ v = v ↔ v 0 = 0 ∧ v 4 = -v 1 := by
+  constructor
+  · intro h
+    have h₁ := congrFun h (1 : Fin 6)
+    have h₅ := congrFun h (5 : Fin 6)
+    simp [PeriodTorusHigherHomologyExterior.squareM₀_eq, Matrix.mulVec, dotProduct,
+      Fin.sum_univ_succ] at h₁ h₅
+    omega
+  · rintro ⟨h₀, h₄⟩
+    ext i
+    fin_cases i <;>
+      simp [PeriodTorusHigherHomologyExterior.squareM₀_eq, Matrix.mulVec, dotProduct,
+        Fin.sum_univ_succ, h₀, h₄]
+
+private theorem ThreefoldHomology.ThirdSource.cuspVector_fixed (b c d e : ℤ) :
+    PeriodTorusHigherHomologyExterior.squareM₀ *ᵥ cuspVector b c d e = cuspVector b c d e := by
+  apply (squareM₀_fixed_iff _).mpr
+  exact ⟨rfl, rfl⟩
+
+private theorem ThreefoldHomology.ThirdSource.squareA₂_cuspVector (b c d e : ℤ) :
+    PeriodTorusHigherHomologyExterior.squareA₂ *ᵥ cuspVector b c d e =
+      ![-b, 0, b + c, d - 6 * b, 3 * b - e, d - 7 * b - 6 * c] := by
+  rw [PeriodTorusHigherHomologyExterior.squareA₂_eq]
+  ext i
+  fin_cases i <;> simp [cuspVector, Matrix.mulVec, dotProduct, Fin.sum_univ_succ] <;> ring
+
+private def
+    ThreefoldHomology.ThirdSource.sourcePair (c3 c4 : ℤ) (a3 a4 : Fin 2 → ℤ) (v : Fin 6 → ℤ) :
+    (Fin 6 → ℤ) × (Fin 6 → ℤ) :=
+  (threeWangVector c3 a3 - PeriodTorusHigherHomologyExterior.squareA₂ *ᵥ v,
+    fourWangVector c4 a4 - v)
+
+private theorem ThreefoldHomology.ThirdSource.kernel_coordinates (x y : Fin 6 → ℤ)
+    (hxy : (x, y) ∈ LinearMap.ker TrianglePeriodFamilyHomologyLattice.deltaTwo) :
+    x 1 = 0 ∧
+      y 0 = 0 ∧
+        y 1 = -x 0 ∧
+          y 3 = 5 * x 0 + 12 * x 2 - 2 * x 3 + 3 * x 5 + 6 * y 2 - 2 * y 4 ∧
+            y 5 = 3 * x 0 + 6 * x 2 - x 3 - x 4 + x 5 - y 4 := by
+  have h := LinearMap.mem_ker.mp hxy
+  rw [TrianglePeriodFamilyHomologyLattice.deltaTwo_apply] at h
+  have h₀ := congrFun h (0 : Fin 6)
+  have h₁ := congrFun h (1 : Fin 6)
+  have h₂ := congrFun h (2 : Fin 6)
+  have h₄ := congrFun h (4 : Fin 6)
+  have h₅ := congrFun h (5 : Fin 6)
+  change -x 0 + x 1 - y 0 - y 1 = 0 at h₀
+  change -x 0 - 2 * x 1 + y 0 - y 1 = 0 at h₁
+  change x 0 + y 1 = 0 at h₂
+  change 6 * x 0 + 2 * x 1 + 6 * x 2 - x 3 - x 4 + x 5 + 3 * y 1 - y 4 - y 5 = 0 at h₄
+  change
+    -8 * x 0 - 2 * x 1 - 6 * x 2 + x 3 - x 4 - 2 * x 5 - 3 * y 0 - 6 * y 1 - 6 * y 2 + y 3 + y 4 -
+        y 5 =
+      0 at h₅
+  omega
+
+private def ThreefoldHomology.ThirdSource.sourceC_mo1973_29424 (x y : Fin 6 → ℤ) : ℤ :=
+  x 0 - y 4 - y 2
+
+private def ThreefoldHomology.ThirdSource.sourceBThree_mo1973_29425 (x y : Fin 6 → ℤ) : ℤ :=
+  x 2 + x 0 + sourceC_mo1973_29424 x y
+
+private def ThreefoldHomology.ThirdSource.sourceBFour_mo1973_29426 (x y : Fin 6 → ℤ) : ℤ :=
+  -y 2 - sourceC_mo1973_29424 x y
+
+private def ThreefoldHomology.ThirdSource.sourceAlpha_mo1973_29427 (x y : Fin 6 → ℤ) : ℤ :=
+  x 3 - x 5 - 4 * x 2 - 3 * x 0 + 2 * sourceC_mo1973_29424 x y
+
+private def ThreefoldHomology.ThirdSource.threeCoordinates (c3 : ℤ) (x y : Fin 6 → ℤ) : Fin 2 → ℤ :=
+  ![sourceAlpha_mo1973_29427 x y + c3 * sourceBThree_mo1973_29425 x y,
+    sourceBThree_mo1973_29425 x y]
+
+private def ThreefoldHomology.ThirdSource.fourCoordinates (k4 : ℤ) (x y : Fin 6 → ℤ) : Fin 2 → ℤ :=
+  ![(2 - k4) * (x 0 - y 4), sourceBFour_mo1973_29426 x y]
+
+private def ThreefoldHomology.ThirdSource.cuspCoordinates (x y : Fin 6 → ℤ) : Fin 6 → ℤ :=
+  cuspVector (x 0) (sourceC_mo1973_29424 x y) (3 * sourceAlpha_mo1973_29427 x y + 6 * x 0 - x 3)
+    (x 4 + sourceAlpha_mo1973_29427 x y - 2 * sourceBThree_mo1973_29425 x y + 3 * x 0)
+
+private theorem ThreefoldHomology.ThirdSource.cuspCoordinates_fixed (x y : Fin 6 → ℤ) :
+    PeriodTorusHigherHomologyExterior.squareM₀ *ᵥ cuspCoordinates x y = cuspCoordinates x y :=
+  cuspVector_fixed _ _ _ _
+
+private theorem ThreefoldHomology.ThirdSource.threeCoordinates_source (c3 : ℤ) (x y : Fin 6 → ℤ)
+    (hxy : (x, y) ∈ LinearMap.ker TrianglePeriodFamilyHomologyLattice.deltaTwo) :
+    threeWangVector c3 (threeCoordinates c3 x y) -
+        PeriodTorusHigherHomologyExterior.squareA₂ *ᵥ cuspCoordinates x y =
+      x := by
+  have hx₁ := (kernel_coordinates x y hxy).1
+  rw [threeWangVector_apply, cuspCoordinates, squareA₂_cuspVector]
+  ext i
+  fin_cases i <;>
+      simp [threeCoordinates, sourceAlpha_mo1973_29427, sourceBThree_mo1973_29425,
+        sourceC_mo1973_29424, hx₁] <;>
+    ring
+
+private theorem ThreefoldHomology.ThirdSource.fourCoordinates_source (k4 : ℤ) (x y : Fin 6 → ℤ)
+    (hxy : (x, y) ∈ LinearMap.ker TrianglePeriodFamilyHomologyLattice.deltaTwo) :
+    fourWangVector (2 * k4) (fourCoordinates k4 x y) - cuspCoordinates x y = y := by
+  obtain ⟨_, hy₀, hy₁, hy₃, hy₅⟩ := kernel_coordinates x y hxy
+  rw [fourWangVector_apply, cuspCoordinates]
+  ext i
+  fin_cases i <;>
+      simp [fourCoordinates, cuspVector, sourceAlpha_mo1973_29427, sourceBThree_mo1973_29425,
+        sourceBFour_mo1973_29426, sourceC_mo1973_29424, hy₀, hy₁, hy₃, hy₅] <;>
+    ring
+
+private def ThreefoldHomology.ThirdSource.kernelThreeCoordinates (c3 k : ℤ) : Fin 2 → ℤ :=
+  ![(2 * c3 + 4) * k, 2 * k]
+
+private def ThreefoldHomology.ThirdSource.kernelFourCoordinates (k4 k : ℤ) : Fin 2 → ℤ :=
+  ![(3 - 2 * k4) * k, -2 * k]
+
+private def ThreefoldHomology.ThirdSource.kernelCuspCoordinates (k : ℤ) : Fin 6 → ℤ :=
+  cuspVector 0 (2 * k) (12 * k) 0
+
+private theorem ThreefoldHomology.ThirdSource.kernelCoordinates_source_zero (c3 k4 k : ℤ) :
+    sourcePair c3 (2 * k4) (kernelThreeCoordinates c3 k) (kernelFourCoordinates k4 k)
+        (kernelCuspCoordinates k) =
+      0 := by
+  rw [sourcePair, threeWangVector_apply, fourWangVector_apply, kernelCuspCoordinates,
+    squareA₂_cuspVector]
+  apply Prod.ext <;> funext i <;> fin_cases i <;>
+      simp [kernelThreeCoordinates, kernelFourCoordinates, cuspVector] <;>
+    ring
+
+private theorem ThreefoldHomology.ThirdSource.sourcePair_eq_zero_iff (c3 k4 : ℤ) (a3 a4 : Fin 2 → ℤ)
+    (v : Fin 6 → ℤ) :
+    sourcePair c3 (2 * k4) a3 a4 v = 0 ↔
+      ∃ k : ℤ,
+        a3 = kernelThreeCoordinates c3 k ∧
+          a4 = kernelFourCoordinates k4 k ∧ v = kernelCuspCoordinates k := by
+  constructor
+  · intro h
+    have hz₃ : threeWangVector c3 a3 - PeriodTorusHigherHomologyExterior.squareA₂ *ᵥ v = 0 :=
+      congrArg Prod.fst h
+    have hz₄ : fourWangVector (2 * k4) a4 - v = 0 := congrArg Prod.snd h
+    have hv : v = fourWangVector (2 * k4) a4 := (sub_eq_zero.mp hz₄).symm
+    have heq : threeWangVector c3 a3 = fourWangVector (2 * k4) a4 := by
+      have heq := sub_eq_zero.mp hz₃
+      rw [hv, fourWangVector_fixed] at heq
+      exact heq
+    rw [threeWangVector_apply, fourWangVector_apply] at heq
+    have h₂ := congrFun heq (2 : Fin 6)
+    have h₃ := congrFun heq (3 : Fin 6)
+    have h₄ := congrFun heq (4 : Fin 6)
+    change a3 1 = -a4 1 at h₂
+    change 3 * (a3 0 - c3 * a3 1) = 2 * (2 * a4 0 - (2 * k4) * a4 1) at h₃
+    change -(a3 0 - c3 * a3 1) + 2 * a3 1 = -(2 * a4 0 - (2 * k4) * a4 1) - 3 * a4 1 at h₄
+    have hb₄ : a4 1 = -a3 1 := by omega
+    rw [hb₄] at h₃ h₄
+    have hα : a3 0 - c3 * a3 1 = 2 * a3 1 := by linear_combination h₃ + 2 * h₄
+    have hβ : 2 * a4 0 + 2 * k4 * a3 1 = 3 * a3 1 := by linear_combination h₄ + hα
+    have heven : (2 : ℤ) ∣ a3 1 := by
+      refine ⟨a4 0 + (k4 - 1) * a3 1, ?_⟩
+      linear_combination -hβ
+    obtain ⟨k, hk⟩ := heven
+    have ha₃ : a3 = kernelThreeCoordinates c3 k := by
+      ext i
+      fin_cases i
+      · change a3 0 = (2 * c3 + 4) * k
+        rw [hk] at hα
+        linear_combination hα
+      · exact hk
+    have ha₄ : a4 = kernelFourCoordinates k4 k := by
+      ext i
+      fin_cases i
+      · change a4 0 = (3 - 2 * k4) * k
+        apply mul_left_cancel₀ (by decide : (2 : ℤ) ≠ 0)
+        rw [hk] at hβ
+        linear_combination hβ
+      · change a4 1 = -2 * k
+        rw [hb₄, hk]
+        ring
+    have hv' : v = kernelCuspCoordinates k := by
+      rw [hv, ha₄, fourWangVector_apply]
+      ext i
+      fin_cases i <;> simp [kernelFourCoordinates, kernelCuspCoordinates, cuspVector] <;> ring
+    exact ⟨k, ha₃, ha₄, hv'⟩
+  · rintro ⟨k, rfl, rfl, rfl⟩
+    exact kernelCoordinates_source_zero c3 k4 k
+
+private def ThreefoldHomology.ThirdDegree.ellipticTwoClass (j : Elliptic.Kind) (a : Fin 2 → ℤ) :
+    ThreefoldHomology.CapElimination.NativeCapKernel (Option.some j) 3 :=
+  (PeriodFamily.Boundary.EllipticCapProduct.boundaryCapKernelEquiv j 2).symm
+    ((Elliptic.HigherHomology.surfaceH2Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).symm
+      a)
+
+private theorem
+    ThreefoldHomology.ThirdDegree.ellipticTwoClass_wang (j : Elliptic.Kind) (a : Fin 2 → ℤ) :
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        (MappingTorusHomology.wangBoundary
+          (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) 2 (ellipticTwoClass j a).val) =
+      ((Elliptic.HigherHomology.fibreNormIndex j : ℤ) * a 0 -
+            PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo j * a 1) •
+          PeriodFamily.Boundary.EllipticCapKernelWang.fibreInvariantPairVector j +
+        a 1 • PeriodFamily.Boundary.EllipticCapKernelWang.twistDeltaVector j := by
+  have h :=
+    PeriodFamily.Boundary.EllipticCapKernelWang.capKernel_wang_h2_coordinates j
+      ((Elliptic.HigherHomology.surfaceH2Equiv j
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).symm
+        a)
+  simpa only [LinearEquiv.apply_symm_apply, ellipticTwoClass] using! h
+
+private theorem ThreefoldHomology.ThirdDegree.cuspMonodromy_two_coordinates
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 2) :
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        (MappingTorusHomology.monodromyHomologyMap
+          (ThreefoldOverlapMappingTorus.monodromy Option.none) 2 a) =
+      PeriodTorusHigherHomologyExterior.squareM₀ *ᵥ
+        PeriodFamily.FlatTorus.singularH2Coordinates a := by
+  have h := LinearMap.congr_fun (PeriodFamily.Boundary.Cusp.monodromyHomology_triangle 2) a
+  have h' :
+    MappingTorusHomology.monodromyHomologyMap (ThreefoldOverlapMappingTorus.monodromy Option.none)
+        2 a =
+      PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleCuspGenerator 2 a :=
+    h
+  rw [h']
+  change
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        (SingularMayerVietoris.singularHomologyMap
+          (SpecialPeriods.triangleTorusHomeomorph SpecialPeriods.triangleCuspGenerator :
+            C(RealTorus₄, RealTorus₄))
+          2 a) =
+      _
+  rw [PeriodFamily.FlatTorus.singularH2Coordinates_inducedHomology_triangle,
+    SpecialPeriods.triangleDualRepresentation_cusp_matrix]
+  rfl
+
+private def ThreefoldHomology.ThirdDegree.cuspTwoInvariant (v : Fin 6 → ℤ)
+    (hv : PeriodTorusHigherHomologyExterior.squareM₀ *ᵥ v = v) :
+    LinearMap.ker
+      (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy Option.none)
+        2) :=
+  ⟨PeriodFamily.FlatTorus.singularH2Coordinates.symm v,
+    by
+    apply PeriodFamily.FlatTorus.singularH2Coordinates.injective
+    change
+      PeriodFamily.FlatTorus.singularH2Coordinates
+          (PeriodFamily.FlatTorus.singularH2Coordinates.symm v -
+            MappingTorusHomology.monodromyHomologyMap
+              (ThreefoldOverlapMappingTorus.monodromy Option.none) 2
+              (PeriodFamily.FlatTorus.singularH2Coordinates.symm v)) =
+        _
+    rw [map_sub, cuspMonodromy_two_coordinates, LinearEquiv.apply_symm_apply, map_zero]
+    exact sub_eq_zero.mpr hv.symm⟩
+
+private def ThreefoldHomology.ThirdDegree.cuspTwoClass (v : Fin 6 → ℤ)
+    (hv : PeriodTorusHigherHomologyExterior.squareM₀ *ᵥ v = v) :
+    ThreefoldHomology.CapElimination.NativeCapKernel Option.none 3 :=
+  (ThreefoldHomologyCuspFibre.cuspCapKernelWangEquivDegree 2).symm (cuspTwoInvariant v hv)
+
+private theorem ThreefoldHomology.ThirdDegree.cuspTwoClass_wang (v : Fin 6 → ℤ)
+    (hv : PeriodTorusHigherHomologyExterior.squareM₀ *ᵥ v = v) :
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        (MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy Option.none) 2
+          (cuspTwoClass v hv).val) =
+      v := by
+  change
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        (MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy Option.none) 2
+          ((ThreefoldHomologyCuspFibre.cuspCapKernelWangEquivDegree 2).symm
+              (cuspTwoInvariant v hv)).val) =
+      v
+  rw [ThreefoldHomologyCuspFibre.cuspCapKernelWangEquivDegree_symm_wang]
+  exact LinearEquiv.apply_symm_apply _ _
+
+private theorem ThreefoldHomology.ThirdDegree.nativeCapKernelSourceMap_two_coordinates
+    (a :
+      ∀ i : SpecialPeriods.Threefold.Puncture,
+        ThreefoldHomology.CapElimination.NativeCapKernel i 3) :
+    (PeriodFamily.FlatTorus.singularH2Coordinates
+          (ThreefoldHomology.CapElimination.nativeCapKernelSourceMap 2 a).val.1,
+        PeriodFamily.FlatTorus.singularH2Coordinates
+          (ThreefoldHomology.CapElimination.nativeCapKernelSourceMap 2 a).val.2) =
+      (PeriodFamily.FlatTorus.singularH2Coordinates
+            (ThreefoldHomology.CapElimination.nativeCapKernelWangValue 2 a (Option.some .three)) -
+          PeriodTorusHigherHomologyExterior.squareA₂ *ᵥ
+            PeriodFamily.FlatTorus.singularH2Coordinates
+              (ThreefoldHomology.CapElimination.nativeCapKernelWangValue 2 a Option.none),
+        PeriodFamily.FlatTorus.singularH2Coordinates
+            (ThreefoldHomology.CapElimination.nativeCapKernelWangValue 2 a (Option.some .four)) -
+          PeriodFamily.FlatTorus.singularH2Coordinates
+            (ThreefoldHomology.CapElimination.nativeCapKernelWangValue 2 a Option.none)) := by
+  rw [ThreefoldHomology.CapElimination.nativeCapKernelSourceMap_val_second]
+  simp only [map_sub, PeriodFamily.HomologyDifference.generatorHomologyTwo_coordinates, ite_true]
+
+private def ThreefoldHomology.ThirdDegree.commonWangVector : Fin 6 → ℤ :=
+  ![0, 0, 2, 12, 0, 0]
+
+private theorem ThreefoldHomology.ThirdDegree.commonWangVector_cusp_fixed :
+    PeriodTorusHigherHomologyExterior.squareM₀ *ᵥ commonWangVector = commonWangVector := by
+  rw [PeriodTorusHigherHomologyExterior.squareM₀_eq]
+  decide
+
+private theorem ThreefoldHomology.ThirdDegree.commonWangVector_second_fixed :
+    PeriodTorusHigherHomologyExterior.squareA₂ *ᵥ commonWangVector = commonWangVector := by
+  rw [PeriodTorusHigherHomologyExterior.squareA₂_eq]
+  decide
+
+private def ThreefoldHomology.ThirdDegree.referenceClasses :
+    ∀ i : SpecialPeriods.Threefold.Puncture, ThreefoldHomology.CapElimination.NativeCapKernel i 3
+  | none => cuspTwoClass commonWangVector commonWangVector_cusp_fixed
+  | some .three =>
+    ellipticTwoClass .three
+      ![2 * PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo .three + 4, 2]
+  | some .four =>
+    ellipticTwoClass .four
+      ![3 - PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo .four, -2]
+
+private theorem ThreefoldHomology.ThirdDegree.referenceClasses_wang
+    (i : SpecialPeriods.Threefold.Puncture) :
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        (ThreefoldHomology.CapElimination.nativeCapKernelWangValue 2 referenceClasses i) =
+      commonWangVector := by
+  cases i with
+  | none => exact cuspTwoClass_wang _ _
+  | some
+    j =>
+    cases j <;>
+      change
+        PeriodFamily.FlatTorus.singularH2Coordinates
+            (MappingTorusHomology.wangBoundary
+              (ThreefoldOverlapMappingTorus.monodromy (Option.some _)) 2
+              (ellipticTwoClass _ _).val) =
+          _
+    all_goals rw [ellipticTwoClass_wang]
+    all_goals
+      ext i
+      fin_cases i <;>
+          simp [Elliptic.HigherHomology.fibreNormIndex,
+            PeriodFamily.Boundary.EllipticCapKernelWang.fibreInvariantPairVector,
+            Elliptic.HigherHomology.fibreSquareKernelVector,
+            PeriodFamily.Boundary.EllipticCapKernelWang.twistDeltaVector, Elliptic.Kind.twist, ε,
+            ε', commonWangVector] <;>
+        ring
+
+private theorem ThreefoldHomology.ThirdDegree.referenceClasses_source_eq_zero :
+    ThreefoldHomology.CapElimination.nativeCapKernelSourceMap 2 referenceClasses = 0 := by
+  have h := nativeCapKernelSourceMap_two_coordinates referenceClasses
+  simp only [referenceClasses_wang, commonWangVector_second_fixed, sub_self] at h
+  apply Subtype.ext
+  apply Prod.ext
+  · apply PeriodFamily.FlatTorus.singularH2Coordinates.injective
+    exact (congrArg Prod.fst h).trans (map_zero _).symm
+  · apply PeriodFamily.FlatTorus.singularH2Coordinates.injective
+    exact (congrArg Prod.snd h).trans (map_zero _).symm
+
+private theorem ThreefoldHomology.ThirdSource.twice_fourShearCorrection :
+    2 * (ThreefoldHomology.DeltaSweep.centralSweepShearCorrection Elliptic.Kind.four) =
+      PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo .four := by
+  simpa only [Elliptic.HigherHomology.fibreNormIndex_four, Nat.cast_ofNat] using
+    ThreefoldHomology.DeltaSweep.fibreNormIndex_mul_centralSweepShearCorrection Elliptic.Kind.four
+
+private theorem ThreefoldHomology.ThirdSource.ellipticTwoClass_wang_three (a : Fin 2 → ℤ) :
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        (MappingTorusHomology.wangBoundary
+          (ThreefoldOverlapMappingTorus.monodromy (Option.some .three)) 2
+          (ThreefoldHomology.ThirdDegree.ellipticTwoClass .three a).val) =
+      threeWangVector
+        (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo Elliptic.Kind.three) a := by
+  have h := ThreefoldHomology.ThirdDegree.ellipticTwoClass_wang .three a
+  simpa only [Elliptic.HigherHomology.fibreNormIndex_three, Nat.cast_one, one_mul,
+    PeriodFamily.Boundary.EllipticCapKernelWang.fibreInvariantPairVector,
+    Elliptic.HigherHomology.fibreSquareKernelVector,
+    PeriodFamily.Boundary.EllipticCapKernelWang.twistDeltaVector, Elliptic.Kind.twist, ε,
+    threeWangVector] using! h
+
+private theorem ThreefoldHomology.ThirdSource.ellipticTwoClass_wang_four (a : Fin 2 → ℤ) :
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        (MappingTorusHomology.wangBoundary
+          (ThreefoldOverlapMappingTorus.monodromy (Option.some .four)) 2
+          (ThreefoldHomology.ThirdDegree.ellipticTwoClass .four a).val) =
+      fourWangVector
+        (2 * (ThreefoldHomology.DeltaSweep.centralSweepShearCorrection Elliptic.Kind.four)) a := by
+  have h := ThreefoldHomology.ThirdDegree.ellipticTwoClass_wang .four a
+  rw [← twice_fourShearCorrection] at h
+  simpa only [Elliptic.HigherHomology.fibreNormIndex_four, Nat.cast_ofNat,
+    PeriodFamily.Boundary.EllipticCapKernelWang.fibreInvariantPairVector,
+    Elliptic.HigherHomology.fibreSquareKernelVector,
+    PeriodFamily.Boundary.EllipticCapKernelWang.twistDeltaVector, Elliptic.Kind.twist, ε',
+    fourWangVector] using! h
+
+private def ThreefoldHomology.ThirdSource.nativeSourceClasses (x y : Fin 6 → ℤ) :
+    ∀ i : SpecialPeriods.Threefold.Puncture, ThreefoldHomology.CapElimination.NativeCapKernel i 3
+  | none =>
+    ThreefoldHomology.ThirdDegree.cuspTwoClass (cuspCoordinates x y) (cuspCoordinates_fixed x y)
+  | some .three =>
+    ThreefoldHomology.ThirdDegree.ellipticTwoClass .three
+      (threeCoordinates
+        (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo Elliptic.Kind.three) x y)
+  | some .four =>
+    ThreefoldHomology.ThirdDegree.ellipticTwoClass .four
+      (fourCoordinates
+        (ThreefoldHomology.DeltaSweep.centralSweepShearCorrection Elliptic.Kind.four) x y)
+
+private theorem ThreefoldHomology.ThirdSource.nativeSourceClasses_wang_three (x y : Fin 6 → ℤ) :
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        (ThreefoldHomology.CapElimination.nativeCapKernelWangValue 2 (nativeSourceClasses x y)
+          (Option.some .three)) =
+      threeWangVector
+        (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo Elliptic.Kind.three)
+        (threeCoordinates
+          (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo Elliptic.Kind.three) x y) :=
+  ellipticTwoClass_wang_three _
+
+private theorem ThreefoldHomology.ThirdSource.nativeSourceClasses_wang_four (x y : Fin 6 → ℤ) :
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        (ThreefoldHomology.CapElimination.nativeCapKernelWangValue 2 (nativeSourceClasses x y)
+          (Option.some .four)) =
+      fourWangVector
+        (2 * (ThreefoldHomology.DeltaSweep.centralSweepShearCorrection Elliptic.Kind.four))
+        (fourCoordinates
+          (ThreefoldHomology.DeltaSweep.centralSweepShearCorrection Elliptic.Kind.four) x y) :=
+  ellipticTwoClass_wang_four _
+
+private theorem ThreefoldHomology.ThirdSource.nativeSourceClasses_wang_cusp (x y : Fin 6 → ℤ) :
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        (ThreefoldHomology.CapElimination.nativeCapKernelWangValue 2 (nativeSourceClasses x y)
+          Option.none) =
+      cuspCoordinates x y :=
+  ThreefoldHomology.ThirdDegree.cuspTwoClass_wang _ _
+
+private theorem
+    ThreefoldHomology.ThirdSource.nativeSourceClasses_source_coordinates (x y : Fin 6 → ℤ)
+    (hxy : (x, y) ∈ LinearMap.ker TrianglePeriodFamilyHomologyLattice.deltaTwo) :
+    (PeriodFamily.FlatTorus.singularH2Coordinates
+          (ThreefoldHomology.CapElimination.nativeCapKernelSourceMap 2
+                (nativeSourceClasses x y)).val.1,
+        PeriodFamily.FlatTorus.singularH2Coordinates
+          (ThreefoldHomology.CapElimination.nativeCapKernelSourceMap 2
+                (nativeSourceClasses x y)).val.2) =
+      (x, y) := by
+  rw [ThreefoldHomology.ThirdDegree.nativeCapKernelSourceMap_two_coordinates]
+  simp only [nativeSourceClasses_wang_three, nativeSourceClasses_wang_four,
+    nativeSourceClasses_wang_cusp]
+  exact
+    Prod.ext
+      (threeCoordinates_source
+        (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo Elliptic.Kind.three) x y hxy)
+      (fourCoordinates_source
+        (ThreefoldHomology.DeltaSweep.centralSweepShearCorrection Elliptic.Kind.four) x y hxy)
+
+private theorem ThreefoldHomology.ThirdSource.nativeCapKernelSourceMap_two_surjective :
+    Function.Surjective (ThreefoldHomology.CapElimination.nativeCapKernelSourceMap 2) := by
+  intro a
+  have hxy :
+    (PeriodFamily.FlatTorus.singularH2Coordinates a.val.1,
+        PeriodFamily.FlatTorus.singularH2Coordinates a.val.2) ∈
+      LinearMap.ker TrianglePeriodFamilyHomologyLattice.deltaTwo := by
+    change
+      TrianglePeriodFamilyHomologyLattice.deltaTwo
+          (PeriodFamily.FlatTorus.singularH2Coordinates a.val.1,
+            PeriodFamily.FlatTorus.singularH2Coordinates a.val.2) =
+        0
+    have h := PeriodFamily.HomologyDifference.sourceDifferenceTwo_coordinates a.val
+    rw [show PeriodFamily.Homology.sourceDifference 2 a.val = 0 from a.property, map_zero] at h
+    exact h.symm
+  have h :=
+    nativeSourceClasses_source_coordinates (PeriodFamily.FlatTorus.singularH2Coordinates a.val.1)
+      (PeriodFamily.FlatTorus.singularH2Coordinates a.val.2) hxy
+  refine
+    ⟨nativeSourceClasses (PeriodFamily.FlatTorus.singularH2Coordinates a.val.1)
+        (PeriodFamily.FlatTorus.singularH2Coordinates a.val.2),
+      ?_⟩
+  apply Subtype.ext
+  apply Prod.ext
+  · exact PeriodFamily.FlatTorus.singularH2Coordinates.injective (congrArg Prod.fst h)
+  · exact PeriodFamily.FlatTorus.singularH2Coordinates.injective (congrArg Prod.snd h)
+
+private def ThreefoldHomology.ThirdSource.capKernelWangCoordinates
+    (i : SpecialPeriods.Threefold.Puncture) :
+    ThreefoldHomology.CapElimination.NativeCapKernel i 3 →ₗ[ℤ] (Fin 6 → ℤ) :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun
+        a :=
+        PeriodFamily.FlatTorus.singularH2Coordinates
+          (MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy i) 2 a.val)
+      map_zero' := by rw [Submodule.coe_zero, map_zero, map_zero]
+      map_add' a b := by rw [Submodule.coe_add, map_add, map_add] }
+
+private theorem ThreefoldHomology.ThirdSource.capKernelWangCoordinates_injective
+    (i : SpecialPeriods.Threefold.Puncture) : Function.Injective (capKernelWangCoordinates i) := by
+  cases i with
+  | none =>
+    intro a b h
+    apply (ThreefoldHomologyCuspFibre.cuspCapKernelWangEquivDegree 2).injective
+    apply Subtype.ext
+    exact PeriodFamily.FlatTorus.singularH2Coordinates.injective h
+  | some j =>
+    intro a b h
+    apply PeriodFamily.Boundary.EllipticCapKernelWang.capKernelWang_two_injective j
+    exact PeriodFamily.FlatTorus.singularH2Coordinates.injective h
+
+private theorem ThreefoldHomology.ThirdSource.ellipticTwoClass_surjective (j : Elliptic.Kind) :
+    Function.Surjective (ThreefoldHomology.ThirdDegree.ellipticTwoClass j) := by
+  intro a
+  refine
+    ⟨Elliptic.HigherHomology.surfaceH2Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+        (PeriodFamily.Boundary.EllipticCapProduct.boundaryCapKernelEquiv j 2 a),
+      ?_⟩
+  simp only [ThreefoldHomology.ThirdDegree.ellipticTwoClass, LinearEquiv.symm_apply_apply]
+
+private theorem ThreefoldHomology.ThirdSource.capKernelWangCoordinates_reference
+    (i : SpecialPeriods.Threefold.Puncture) :
+    capKernelWangCoordinates i (ThreefoldHomology.ThirdDegree.referenceClasses i) =
+      ThreefoldHomology.ThirdDegree.commonWangVector :=
+  ThreefoldHomology.ThirdDegree.referenceClasses_wang i
+
+private theorem ThreefoldHomology.ThirdSource.kernelCoordinates_wang_values (c3 k4 k : ℤ) :
+    threeWangVector c3 (kernelThreeCoordinates c3 k) =
+        k • ThreefoldHomology.ThirdDegree.commonWangVector ∧
+      fourWangVector (2 * k4) (kernelFourCoordinates k4 k) =
+          k • ThreefoldHomology.ThirdDegree.commonWangVector ∧
+        kernelCuspCoordinates k = k • ThreefoldHomology.ThirdDegree.commonWangVector := by
+  constructor
+  · rw [threeWangVector_apply]
+    ext i
+    fin_cases i <;>
+        simp [kernelThreeCoordinates, ThreefoldHomology.ThirdDegree.commonWangVector] <;>
+      ring
+  constructor
+  · rw [fourWangVector_apply]
+    ext i
+    fin_cases i <;>
+        simp [kernelFourCoordinates, ThreefoldHomology.ThirdDegree.commonWangVector] <;>
+      ring
+  · ext i
+    fin_cases i <;>
+        simp [kernelCuspCoordinates, cuspVector,
+          ThreefoldHomology.ThirdDegree.commonWangVector] <;>
+      ring
+
+private theorem ThreefoldHomology.ThirdSource.nativeCapKernelSourceMap_two_eq_zero_exists
+    (a :
+      ∀ i : SpecialPeriods.Threefold.Puncture,
+        ThreefoldHomology.CapElimination.NativeCapKernel i 3)
+    (ha : ThreefoldHomology.CapElimination.nativeCapKernelSourceMap 2 a = 0) :
+    ∃ k : ℤ, a = k • ThreefoldHomology.ThirdDegree.referenceClasses := by
+  obtain ⟨b3, hb3⟩ := ellipticTwoClass_surjective .three (a (Option.some .three))
+  obtain ⟨b4, hb4⟩ := ellipticTwoClass_surjective .four (a (Option.some .four))
+  let v := capKernelWangCoordinates Option.none (a Option.none)
+  have h₃ :
+    capKernelWangCoordinates (Option.some .three) (a (Option.some .three)) =
+      threeWangVector
+        (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo Elliptic.Kind.three) b3 := by
+    rw [← hb3]
+    exact ellipticTwoClass_wang_three b3
+  have h₄ :
+    capKernelWangCoordinates (Option.some .four) (a (Option.some .four)) =
+      fourWangVector
+        (2 * (ThreefoldHomology.DeltaSweep.centralSweepShearCorrection Elliptic.Kind.four)) b4 := by
+    rw [← hb4]
+    exact ellipticTwoClass_wang_four b4
+  have hpair :
+    sourcePair (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo Elliptic.Kind.three)
+        (2 * (ThreefoldHomology.DeltaSweep.centralSweepShearCorrection Elliptic.Kind.four)) b3 b4
+        v =
+      0 := by
+    have hz :
+      (PeriodFamily.FlatTorus.singularH2Coordinates
+            (ThreefoldHomology.CapElimination.nativeCapKernelSourceMap 2 a).val.1,
+          PeriodFamily.FlatTorus.singularH2Coordinates
+            (ThreefoldHomology.CapElimination.nativeCapKernelSourceMap 2 a).val.2) =
+        (0, 0) := by
+      rw [ha]
+      exact Prod.ext (map_zero _) (map_zero _)
+    have hs :=
+      (ThreefoldHomology.ThirdDegree.nativeCapKernelSourceMap_two_coordinates a).symm.trans hz
+    change
+      (capKernelWangCoordinates (Option.some .three) (a (Option.some .three)) -
+            PeriodTorusHigherHomologyExterior.squareA₂ *ᵥ v,
+          capKernelWangCoordinates (Option.some .four) (a (Option.some .four)) - v) =
+        0 at hs
+    rw [h₃, h₄] at hs
+    exact hs
+  obtain ⟨k, hk₃, hk₄, hkv⟩ :=
+    (sourcePair_eq_zero_iff
+          (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo Elliptic.Kind.three)
+          (ThreefoldHomology.DeltaSweep.centralSweepShearCorrection Elliptic.Kind.four) b3 b4
+          v).mp
+      hpair
+  have hw :=
+    kernelCoordinates_wang_values
+      (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo Elliptic.Kind.three)
+      (ThreefoldHomology.DeltaSweep.centralSweepShearCorrection Elliptic.Kind.four) k
+  have hvalues :
+    ∀ i : SpecialPeriods.Threefold.Puncture,
+      capKernelWangCoordinates i (a i) = k • ThreefoldHomology.ThirdDegree.commonWangVector := by
+    intro i
+    cases i with
+    | none => exact hkv.trans hw.2.2
+    | some j =>
+      cases j with
+      | three =>
+        exact
+          h₃.trans
+            ((congrArg
+                  (threeWangVector
+                    (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo
+                      Elliptic.Kind.three))
+                  hk₃).trans
+              hw.1)
+      | four =>
+        exact
+          h₄.trans
+            ((congrArg
+                  (fourWangVector
+                    (2 *
+                      (ThreefoldHomology.DeltaSweep.centralSweepShearCorrection
+                        Elliptic.Kind.four)))
+                  hk₄).trans
+              hw.2.1)
+  refine ⟨k, ?_⟩
+  funext i
+  apply capKernelWangCoordinates_injective i
+  rw [Pi.smul_apply, map_smul, capKernelWangCoordinates_reference]
+  exact hvalues i
+
+private theorem ThreefoldHomology.ThirdSource.referenceClasses_smul_injective :
+    Function.Injective (fun k : ℤ => k • ThreefoldHomology.ThirdDegree.referenceClasses) := by
+  intro k l h
+  have hw :=
+    congrArg
+      (fun a :
+          ∀ i : SpecialPeriods.Threefold.Puncture,
+            ThreefoldHomology.CapElimination.NativeCapKernel i 3 =>
+        capKernelWangCoordinates Option.none (a Option.none))
+      h
+  simp only [Pi.smul_apply, map_smul, capKernelWangCoordinates_reference] at hw
+  have h₂ : k * 2 = l * 2 := by
+    simpa [ThreefoldHomology.ThirdDegree.commonWangVector] using congrFun hw (2 : Fin 6)
+  omega
+
+private def ThreefoldHomology.ThirdDegree.thirdFibreCyclicMap :
+    ℤ →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily 3 :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun
+        z :=
+        PeriodFamily.Homology.sourceCoinvariantInclusion
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          3 (PeriodFamily.HomologyDifference.cokernelThreeEquiv.symm z)
+      map_zero' := by rw [map_zero, map_zero]
+      map_add' a b := by rw [map_add, map_add] }
+
+private theorem ThreefoldHomology.ThirdDegree.thirdFibreCyclicMap_injective :
+    Function.Injective thirdFibreCyclicMap := by
+  intro a b h
+  apply PeriodFamily.HomologyDifference.cokernelThreeEquiv.symm.injective
+  exact
+    PeriodFamily.Homology.sourceCoinvariantInclusion_injective
+      (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+      3 h
+
+private theorem ThreefoldHomology.ThirdDegree.thirdFibreCyclicMap_quotient
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 3) :
+    thirdFibreCyclicMap
+        (PeriodFamily.HomologyDifference.cokernelThreeEquiv (Submodule.Quotient.mk a)) =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodFamily.Homology.familyFibreInclusion
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          PeriodFamily.Homology.normalizedSlitBaseLift)
+        3 a := by
+  change
+    PeriodFamily.Homology.sourceCoinvariantInclusion
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        3
+        (PeriodFamily.HomologyDifference.cokernelThreeEquiv.symm
+          (PeriodFamily.HomologyDifference.cokernelThreeEquiv (Submodule.Quotient.mk a))) =
+      _
+  rw [LinearEquiv.symm_apply_apply, PeriodFamily.Homology.sourceCoinvariantInclusion_mk]
+
+private theorem ThreefoldHomology.ThirdDegree.thirdFibreCyclicMap_apply (z : ℤ) :
+    thirdFibreCyclicMap z =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodFamily.Homology.familyFibreInclusion
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          PeriodFamily.Homology.normalizedSlitBaseLift)
+        3 (PeriodFamily.FlatTorus.singularH3Coordinates.symm ![z, 0, 0, 0]) := by
+  change
+    PeriodFamily.Homology.sourceCoinvariantInclusion
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        3 (PeriodFamily.HomologyDifference.cokernelThreeEquiv.symm z) =
+      _
+  rw [PeriodFamily.HomologyDifference.cokernelThreeEquiv_symm_apply,
+    PeriodFamily.Homology.sourceCoinvariantInclusion_mk]
+
+private theorem ThreefoldHomology.ThirdDegree.thirdFibre_cyclic_coordinates
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 3) :
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodFamily.Homology.familyFibreInclusion
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          PeriodFamily.Homology.normalizedSlitBaseLift)
+        3 a =
+      thirdFibreCyclicMap (PeriodFamily.FlatTorus.singularH3Coordinates a 0) := by
+  rw [← PeriodFamily.HomologyDifference.cokernelThreeEquiv_mk]
+  exact (thirdFibreCyclicMap_quotient a).symm
+
+private theorem ThreefoldHomology.ThirdDegree.thirdFibreCyclicMap_source_eq_zero (z : ℤ) :
+    PeriodFamily.Homology.sourceKernelProjection
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        2 (thirdFibreCyclicMap z) =
+      0 :=
+  (PeriodFamily.Homology.sourceCoinvariantInclusion_kernelProjection_exact
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        2).apply_apply_eq_zero
+    (PeriodFamily.HomologyDifference.cokernelThreeEquiv.symm z)
+
+private theorem ThreefoldHomology.ThirdDegree.thirdFibreCyclicMap_eq_zero_iff (z : ℤ) :
+    thirdFibreCyclicMap z = 0 ↔ z = 0 := by
+  constructor
+  · intro h
+    exact thirdFibreCyclicMap_injective (h.trans (map_zero _).symm)
+  · rintro rfl
+    exact map_zero _
+
+private theorem ThreefoldHomology.ThirdDegree.thirdFibre_range_eq :
+    LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodFamily.Homology.familyFibreInclusion
+            (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)
+            PeriodFamily.Homology.normalizedSlitBaseLift)
+          3) =
+      LinearMap.range thirdFibreCyclicMap := by
+  apply le_antisymm
+  · rintro x ⟨a, rfl⟩
+    exact
+      ⟨PeriodFamily.FlatTorus.singularH3Coordinates a 0, (thirdFibre_cyclic_coordinates a).symm⟩
+  · rintro x ⟨z, rfl⟩
+    exact
+      ⟨PeriodFamily.FlatTorus.singularH3Coordinates.symm ![z, 0, 0, 0],
+        (thirdFibreCyclicMap_apply z).symm⟩
+
+private theorem ThreefoldHomology.ThirdDegree.regularInclusion_three_surjective :
+    Function.Surjective
+      (SingularMayerVietoris.singularHomologyMap ThreefoldHomology.originalRegularInclusion 3) := by
+  intro x
+  obtain ⟨p, hp⟩ := starRight_three_surjective x
+  obtain ⟨a, ha⟩ :=
+    ThreefoldHomology.CapElimination.starOverlapToFillingsHomologyMap_surjective 3 (-p.2)
+  have hshape :
+    p - ThreefoldHomology.starLeftHomologyMap 3 a =
+      (p.1 - ThreefoldHomology.starOverlapToRegularHomologyMap 3 a, 0) := by
+    rw [ThreefoldHomology.CapElimination.starLeft_regular_fillings]
+    apply Prod.ext
+    · rfl
+    · change p.2 - -ThreefoldHomology.starOverlapToFillingsHomologyMap 3 a = 0
+      rw [ha, neg_neg, sub_self]
+  refine ⟨p.1 - ThreefoldHomology.starOverlapToRegularHomologyMap 3 a, ?_⟩
+  calc
+    SingularMayerVietoris.singularHomologyMap ThreefoldHomology.originalRegularInclusion 3
+          (p.1 - ThreefoldHomology.starOverlapToRegularHomologyMap 3 a) =
+        ThreefoldHomology.starRightHomologyMap 3
+          (p.1 - ThreefoldHomology.starOverlapToRegularHomologyMap 3 a, 0) :=
+      (ThreefoldHomology.CapElimination.starRight_regular 3 _).symm
+    _ =
+        ThreefoldHomology.starRightHomologyMap 3
+          (p - ThreefoldHomology.starLeftHomologyMap 3 a) :=
+      (congrArg (ThreefoldHomology.starRightHomologyMap 3) hshape.symm)
+    _ =
+        ThreefoldHomology.starRightHomologyMap 3 p -
+          ThreefoldHomology.starRightHomologyMap 3 (ThreefoldHomology.starLeftHomologyMap 3 a) :=
+      (map_sub _ _ _)
+    _ = x := by rw [hp, (ThreefoldHomology.star_exact_at_pair 3).apply_apply_eq_zero a, sub_zero]
+
+private theorem ThreefoldHomology.ThirdDegree.regularFibre_homologyThree_surjective :
+    Function.Surjective
+      (SingularMayerVietoris.singularHomologyMap
+        ThreefoldHomology.CapElimination.regularFibreIntoSpace 3) :=
+  ThreefoldHomology.CapElimination.regularFibreIntoSpace_homology_surjective 2
+    ThreefoldHomology.ThirdSource.nativeCapKernelSourceMap_two_surjective
+    regularInclusion_three_surjective
+
+private def ThreefoldHomology.ThirdDegree.homologyThreeCyclicMap :
+    ℤ →ₗ[ℤ] SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 3 :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun
+        z :=
+        SingularMayerVietoris.singularHomologyMap ThreefoldHomology.originalRegularInclusion 3
+          (thirdFibreCyclicMap z)
+      map_zero' := by rw [map_zero, map_zero]
+      map_add' a b := by rw [map_add, map_add] }
+
+@[simp]
+private theorem ThreefoldHomology.ThirdDegree.homologyThreeCyclicMap_regular (z : ℤ) :
+    homologyThreeCyclicMap z =
+      SingularMayerVietoris.singularHomologyMap ThreefoldHomology.originalRegularInclusion 3
+        (thirdFibreCyclicMap z) :=
+  rfl
+
+private theorem ThreefoldHomology.ThirdDegree.regularFibre_homologyThree_coordinates
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 3) :
+    SingularMayerVietoris.singularHomologyMap
+        ThreefoldHomology.CapElimination.regularFibreIntoSpace 3 a =
+      homologyThreeCyclicMap (PeriodFamily.FlatTorus.singularH3Coordinates a 0) := by
+  rw [ThreefoldHomology.CapElimination.regularFibreIntoSpace_homology, LinearMap.comp_apply,
+    thirdFibre_cyclic_coordinates, homologyThreeCyclicMap_regular]
+
+private theorem ThreefoldHomology.ThirdDegree.homologyThreeCyclicMap_surjective :
+    Function.Surjective homologyThreeCyclicMap := by
+  intro x
+  obtain ⟨a, ha⟩ := regularFibre_homologyThree_surjective x
+  exact
+    ⟨PeriodFamily.FlatTorus.singularH3Coordinates a 0,
+      (regularFibre_homologyThree_coordinates a).symm.trans ha⟩
+
+private def ThreefoldHomology.ThirdDegree.homologyThreeGenerator :
+    SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 3 :=
+  homologyThreeCyclicMap 1
+
+private theorem ThreefoldHomology.ThirdDegree.homologyThreeCyclicMap_eq_smul (z : ℤ) :
+    homologyThreeCyclicMap z = z • homologyThreeGenerator := by
+  simpa [homologyThreeGenerator] using map_zsmul homologyThreeCyclicMap z (1 : ℤ)
+
+private theorem ThreefoldHomology.ThirdDegree.homologyThree_subsingleton_iff_generator_eq_zero :
+    Subsingleton (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 3) ↔
+      homologyThreeGenerator = 0 := by
+  constructor
+  · intro h
+    exact h.elim _ _
+  · intro h
+    have hz (x : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 3) :
+      x = 0 := by
+      obtain ⟨z, rfl⟩ := homologyThreeCyclicMap_surjective x
+      rw [homologyThreeCyclicMap_eq_smul, h]
+      exact
+        @zsmul_zero (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 3) _ z
+    exact ⟨fun x y => (hz x).trans (hz y).symm⟩
+
+private theorem ThreefoldHomology.ThirdDegree.existsUnique_referenceFibreCoefficient :
+    ∃! z : ℤ,
+      thirdFibreCyclicMap z =
+        ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 3 referenceClasses := by
+  have hr :
+    ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 3 referenceClasses ∈
+      LinearMap.ker
+        (PeriodFamily.Homology.sourceKernelProjection
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          2) :=
+    referenceClasses_source_eq_zero
+  rw [PeriodFamily.Homology.sourceKernelProjection_kernel, thirdFibre_range_eq] at hr
+  obtain ⟨z, hz⟩ := hr
+  refine ⟨z, hz, ?_⟩
+  intro w hw
+  exact thirdFibreCyclicMap_injective (hw.trans hz.symm)
+
+private def ThreefoldHomology.ThirdDegree.referenceFibreCoefficient : ℤ :=
+  Classical.choose existsUnique_referenceFibreCoefficient
+
+private theorem ThreefoldHomology.ThirdDegree.referenceFibreCoefficient_spec :
+    thirdFibreCyclicMap referenceFibreCoefficient =
+      ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 3 referenceClasses :=
+  (Classical.choose_spec existsUnique_referenceFibreCoefficient).1
+
+private theorem ThreefoldHomology.ThirdDegree.referenceFibreCoefficient_eq_iff (z : ℤ) :
+    referenceFibreCoefficient = z ↔
+      ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 3 referenceClasses =
+        thirdFibreCyclicMap z := by
+  rw [← referenceFibreCoefficient_spec]
+  exact thirdFibreCyclicMap_injective.eq_iff.symm
+
+private theorem ThreefoldHomology.ThirdDegree.nativeCapKernelRegularMap_smul_reference (k : ℤ) :
+    ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 3 (k • referenceClasses) =
+      thirdFibreCyclicMap (k * referenceFibreCoefficient) := by
+  rw [map_zsmul, ← referenceFibreCoefficient_spec, ← map_zsmul]
+  rfl
+
+private theorem ThreefoldHomology.ThirdDegree.homologyThreeCyclicMap_referenceFibreCoefficient :
+    homologyThreeCyclicMap referenceFibreCoefficient = 0 := by
+  rw [homologyThreeCyclicMap_regular, referenceFibreCoefficient_spec]
+  exact
+    (ThreefoldHomology.CapElimination.regularInclusion_eq_zero_iff_native 3 _).mpr
+      ⟨referenceClasses, rfl⟩
+
+private theorem ThreefoldHomology.ThirdDegree.homologyThreeCyclicMap_eq_zero_iff (z : ℤ) :
+    homologyThreeCyclicMap z = 0 ↔ ∃ k : ℤ, k * referenceFibreCoefficient = z := by
+  constructor
+  · intro hz
+    obtain ⟨a, ha⟩ :=
+      (ThreefoldHomology.CapElimination.regularInclusion_eq_zero_iff_native 3
+            (thirdFibreCyclicMap z)).mp
+        hz
+    have hs : ThreefoldHomology.CapElimination.nativeCapKernelSourceMap 2 a = 0 :=
+      (congrArg
+            (PeriodFamily.Homology.sourceKernelProjection
+              (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                SpecialPeriods.specialPeriodMap_generator₁
+                SpecialPeriods.specialPeriodMap_generator₂)
+              2)
+            ha).trans
+        (thirdFibreCyclicMap_source_eq_zero z)
+    obtain ⟨k, rfl⟩ :=
+      ThreefoldHomology.ThirdSource.nativeCapKernelSourceMap_two_eq_zero_exists a hs
+    rw [nativeCapKernelRegularMap_smul_reference] at ha
+    exact ⟨k, thirdFibreCyclicMap_injective ha⟩
+  · rintro ⟨k, rfl⟩
+    change homologyThreeCyclicMap (k • referenceFibreCoefficient) = 0
+    rw [map_zsmul, homologyThreeCyclicMap_referenceFibreCoefficient]
+    exact
+      @zsmul_zero (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 3) _ k
+
+private theorem ThreefoldHomology.ThirdDegree.nativeCapKernelRegularMap_three_eq_zero_iff
+    (a :
+      ∀ i : SpecialPeriods.Threefold.Puncture,
+        ThreefoldHomology.CapElimination.NativeCapKernel i 3) :
+    ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 3 a = 0 ↔
+      ∃ k : ℤ, a = k • referenceClasses ∧ k * referenceFibreCoefficient = 0 := by
+  constructor
+  · intro ha
+    have hs : ThreefoldHomology.CapElimination.nativeCapKernelSourceMap 2 a = 0 := by
+      rw [ThreefoldHomology.CapElimination.nativeCapKernelSourceMap_apply, ha, map_zero]
+    obtain ⟨k, hk⟩ :=
+      ThreefoldHomology.ThirdSource.nativeCapKernelSourceMap_two_eq_zero_exists a hs
+    refine ⟨k, hk, ?_⟩
+    rw [hk, nativeCapKernelRegularMap_smul_reference] at ha
+    exact (thirdFibreCyclicMap_eq_zero_iff _).mp ha
+  · rintro ⟨k, rfl, hk⟩
+    rw [nativeCapKernelRegularMap_smul_reference, hk, map_zero]
+
+private theorem ThreefoldHomology.FourthSource.deltaThree_kernel_coordinates (x y : Lattice)
+    (hxy : (x, y) ∈ LinearMap.ker TrianglePeriodFamilyHomologyLattice.deltaThree) :
+    y 0 = -2 * y 1 ∧ x 0 = -3 * (x 1 + y 1 + y 2) ∧ x 2 = -2 * (x 1 + y 1 + y 2) := by
+  have h := LinearMap.mem_ker.mp hxy
+  rw [TrianglePeriodFamilyHomologyLattice.deltaThree_apply] at h
+  have h₁ := congrFun h (1 : Fin 4)
+  have h₂ := congrFun h (2 : Fin 4)
+  have h₃ := congrFun h (3 : Fin 4)
+  change -x 0 - x 1 + x 2 - y 1 - y 2 = 0 at h₁
+  change x 0 - x 1 - 2 * x 2 + y 0 + y 1 - y 2 = 0 at h₂
+  change -2 * x 0 - 6 * x 1 + 3 * y 0 - 6 * y 2 = 0 at h₃
+  omega
+
+private theorem ThreefoldHomology.FourthSource.cubeA₂_cuspVector (c d : ℤ) :
+    PeriodTorusHigherHomologyExterior.cubeA₂ *ᵥ ![0, 0, c, d] = ![0, -c, 0, d - 6 * c] := by
+  rw [PeriodTorusHigherHomologyExterior.cubeA₂_eq]
+  ext i
+  fin_cases i <;> simp [Matrix.mulVec, dotProduct, Fin.sum_univ_succ]
+  ring
+
+private theorem ThreefoldHomology.FourthSource.cubeM₀_cuspVector (c d : ℤ) :
+    PeriodTorusHigherHomologyExterior.cubeM₀ *ᵥ ![0, 0, c, d] = ![0, 0, c, d] := by
+  rw [PeriodTorusHigherHomologyExterior.cubeM₀_eq]
+  ext i
+  fin_cases i <;> simp [Matrix.mulVec, dotProduct, Fin.sum_univ_succ]
+
+private def ThreefoldHomology.FourthSource.sourceU_mo1973_29516 (c3 : ℤ) (x y : Lattice) : ℤ :=
+  x 3 + 3 * c3 * (-x 1 - y 1 - y 2) - 6 * (-y 2 - y 1)
+
+private def ThreefoldHomology.FourthSource.sourceV_mo1973_29517 (c4 : ℤ) (y : Lattice) : ℤ :=
+  y 3 + 2 * c4 * y 1
+
+private def
+    ThreefoldHomology.FourthSource.threeCoordinates (c3 c4 : ℤ) (x y : Lattice) : Fin 2 → ℤ :=
+  ![sourceV_mo1973_29517 c4 y - sourceU_mo1973_29516 c3 x y, -x 1 - y 1 - y 2]
+
+private def
+    ThreefoldHomology.FourthSource.fourCoordinates (c3 c4 : ℤ) (x y : Lattice) : Fin 2 → ℤ :=
+  ![sourceV_mo1973_29517 c4 y - sourceU_mo1973_29516 c3 x y, y 1]
+
+private def ThreefoldHomology.FourthSource.cuspCoordinates (c3 c4 : ℤ) (x y : Lattice) : Lattice :=
+  ![0, 0, -y 2 - y 1, 3 * sourceV_mo1973_29517 c4 y - 4 * sourceU_mo1973_29516 c3 x y]
+
+private theorem ThreefoldHomology.FourthSource.cuspCoordinates_fixed (c3 c4 : ℤ) (x y : Lattice) :
+    PeriodTorusHigherHomologyExterior.cubeM₀ *ᵥ cuspCoordinates c3 c4 x y =
+      cuspCoordinates c3 c4 x y :=
+  cubeM₀_cuspVector _ _
+
+private theorem ThreefoldHomology.FourthSource.threeCoordinates_source (c3 c4 : ℤ) (x y : Lattice)
+    (hxy : (x, y) ∈ LinearMap.ker TrianglePeriodFamilyHomologyLattice.deltaThree) :
+    PeriodFamily.Boundary.EllipticCapKernelWang.topWangMatrix .three c3 *ᵥ
+          threeCoordinates c3 c4 x y -
+        PeriodTorusHigherHomologyExterior.cubeA₂ *ᵥ cuspCoordinates c3 c4 x y =
+      x := by
+  obtain ⟨_, hx₀, hx₂⟩ := deltaThree_kernel_coordinates x y hxy
+  rw [PeriodFamily.Boundary.EllipticCapKernelWang.topWangMatrix_mulVec_three, cuspCoordinates,
+    cubeA₂_cuspVector]
+  ext i
+  fin_cases i <;>
+      simp [threeCoordinates, sourceU_mo1973_29516, sourceV_mo1973_29517, hx₀, hx₂] <;>
+    ring
+
+private theorem ThreefoldHomology.FourthSource.fourCoordinates_source (c3 c4 : ℤ) (x y : Lattice)
+    (hxy : (x, y) ∈ LinearMap.ker TrianglePeriodFamilyHomologyLattice.deltaThree) :
+    PeriodFamily.Boundary.EllipticCapKernelWang.topWangMatrix .four c4 *ᵥ
+          fourCoordinates c3 c4 x y -
+        cuspCoordinates c3 c4 x y =
+      y := by
+  have hy₀ := (deltaThree_kernel_coordinates x y hxy).1
+  rw [PeriodFamily.Boundary.EllipticCapKernelWang.topWangMatrix_mulVec_four, cuspCoordinates]
+  ext i
+  fin_cases i <;> simp [fourCoordinates, sourceU_mo1973_29516, sourceV_mo1973_29517, hy₀] <;> ring
+
+private def ThreefoldHomology.FourthSource.nativeSourceClasses (x y : Lattice) :
+    ∀ i : SpecialPeriods.Threefold.Puncture, ThreefoldHomology.CapElimination.NativeCapKernel i 4
+  | none =>
+    ThreefoldHomology.CapElimination.cuspThreeClass
+      (cuspCoordinates
+        (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearThree Elliptic.Kind.three)
+        (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearThree Elliptic.Kind.four) x y)
+      (cuspCoordinates_fixed
+        (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearThree Elliptic.Kind.three)
+        (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearThree Elliptic.Kind.four) x y)
+  | some .three =>
+    ThreefoldHomology.CapElimination.ellipticThreeClass .three
+      (threeCoordinates
+        (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearThree Elliptic.Kind.three)
+        (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearThree Elliptic.Kind.four) x y)
+  | some .four =>
+    ThreefoldHomology.CapElimination.ellipticThreeClass .four
+      (fourCoordinates
+        (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearThree Elliptic.Kind.three)
+        (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearThree Elliptic.Kind.four) x y)
+
+private theorem ThreefoldHomology.FourthSource.nativeSourceClasses_wang_three (x y : Lattice) :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (ThreefoldHomology.CapElimination.nativeCapKernelWangValue 3 (nativeSourceClasses x y)
+          (Option.some .three)) =
+      PeriodFamily.Boundary.EllipticCapKernelWang.topWangMatrix .three
+          (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearThree Elliptic.Kind.three) *ᵥ
+        threeCoordinates
+          (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearThree Elliptic.Kind.three)
+          (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearThree Elliptic.Kind.four) x y :=
+  ThreefoldHomology.CapElimination.ellipticThreeClass_wang .three _
+
+private theorem ThreefoldHomology.FourthSource.nativeSourceClasses_wang_four (x y : Lattice) :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (ThreefoldHomology.CapElimination.nativeCapKernelWangValue 3 (nativeSourceClasses x y)
+          (Option.some .four)) =
+      PeriodFamily.Boundary.EllipticCapKernelWang.topWangMatrix .four
+          (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearThree Elliptic.Kind.four) *ᵥ
+        fourCoordinates
+          (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearThree Elliptic.Kind.three)
+          (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearThree Elliptic.Kind.four) x y :=
+  ThreefoldHomology.CapElimination.ellipticThreeClass_wang .four _
+
+private theorem ThreefoldHomology.FourthSource.nativeSourceClasses_wang_cusp (x y : Lattice) :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (ThreefoldHomology.CapElimination.nativeCapKernelWangValue 3 (nativeSourceClasses x y)
+          Option.none) =
+      cuspCoordinates
+        (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearThree Elliptic.Kind.three)
+        (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearThree Elliptic.Kind.four) x y :=
+  ThreefoldHomology.CapElimination.cuspThreeClass_wang _ _
+
+private theorem
+    ThreefoldHomology.FourthSource.nativeSourceClasses_source_coordinates (x y : Lattice)
+    (hxy : (x, y) ∈ LinearMap.ker TrianglePeriodFamilyHomologyLattice.deltaThree) :
+    (PeriodFamily.FlatTorus.singularH3Coordinates
+          (ThreefoldHomology.CapElimination.nativeCapKernelSourceMap 3
+                (nativeSourceClasses x y)).val.1,
+        PeriodFamily.FlatTorus.singularH3Coordinates
+          (ThreefoldHomology.CapElimination.nativeCapKernelSourceMap 3
+                (nativeSourceClasses x y)).val.2) =
+      (x, y) := by
+  rw [ThreefoldHomology.CapElimination.nativeCapKernelSourceMap_three_coordinates]
+  simp only [nativeSourceClasses_wang_three, nativeSourceClasses_wang_four,
+    nativeSourceClasses_wang_cusp]
+  exact
+    Prod.ext
+      (threeCoordinates_source
+        (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearThree Elliptic.Kind.three)
+        (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearThree Elliptic.Kind.four) x y hxy)
+      (fourCoordinates_source
+        (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearThree Elliptic.Kind.three)
+        (PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearThree Elliptic.Kind.four) x y hxy)
+
+private theorem ThreefoldHomology.FourthSource.nativeCapKernelSourceMap_three_surjective :
+    Function.Surjective (ThreefoldHomology.CapElimination.nativeCapKernelSourceMap 3) := by
+  intro a
+  have hxy :
+    (PeriodFamily.FlatTorus.singularH3Coordinates a.val.1,
+        PeriodFamily.FlatTorus.singularH3Coordinates a.val.2) ∈
+      LinearMap.ker TrianglePeriodFamilyHomologyLattice.deltaThree := by
+    change
+      TrianglePeriodFamilyHomologyLattice.deltaThree
+          (PeriodFamily.FlatTorus.singularH3Coordinates a.val.1,
+            PeriodFamily.FlatTorus.singularH3Coordinates a.val.2) =
+        0
+    have h := PeriodFamily.HomologyDifference.sourceDifferenceThree_coordinates a.val
+    rw [show PeriodFamily.Homology.sourceDifference 3 a.val = 0 from a.property, map_zero] at h
+    exact h.symm
+  have h :=
+    nativeSourceClasses_source_coordinates (PeriodFamily.FlatTorus.singularH3Coordinates a.val.1)
+      (PeriodFamily.FlatTorus.singularH3Coordinates a.val.2) hxy
+  refine
+    ⟨nativeSourceClasses (PeriodFamily.FlatTorus.singularH3Coordinates a.val.1)
+        (PeriodFamily.FlatTorus.singularH3Coordinates a.val.2),
+      ?_⟩
+  apply Subtype.ext
+  apply Prod.ext
+  · exact PeriodFamily.FlatTorus.singularH3Coordinates.injective (congrArg Prod.fst h)
+  · exact PeriodFamily.FlatTorus.singularH3Coordinates.injective (congrArg Prod.snd h)
+
+private theorem
+    ThreefoldHomology.EllipticFibre.wangDifference_symm_range {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (n : ℕ) :
+    LinearMap.range (MappingTorusHomology.wangDifference f.symm n) =
+      LinearMap.range (MappingTorusHomology.wangDifference f n) := by
+  let e := PeriodTorusHigherHomology.homeomorphHomologyEquiv f n
+  ext a
+  constructor
+  · rintro ⟨b, rfl⟩
+    refine ⟨-e.symm b, ?_⟩
+    change -e.symm b - e (-e.symm b) = b - e.symm b
+    rw [map_neg, LinearEquiv.apply_symm_apply]
+    abel
+  · rintro ⟨b, rfl⟩
+    refine ⟨-e b, ?_⟩
+    change -e b - e.symm (-e b) = b - e b
+    rw [map_neg, LinearEquiv.symm_apply_apply]
+    abel
+
+private theorem ThreefoldHomology.EllipticFibre.periodCover_ker_eq_deckDifference_range
+    (j : Elliptic.Kind) (p : Elliptic.FixedPeriod j) (n : ℕ) :
+    LinearMap.ker
+        (SingularMayerVietoris.singularHomologyMap
+          (Elliptic.HigherHomology.periodCover j p j.twist (Elliptic.mainTwist_admissible j)) n) =
+      LinearMap.range (Elliptic.HigherHomology.periodDeckDifference j p n) := by
+  by_cases hn : n ≤ 4
+  · interval_cases n
+    · exact Elliptic.HigherHomology.periodCover_h0_ker_eq_deckDifference_range j p
+    · exact Elliptic.HigherHomology.periodCover_h1_ker_eq_deckDifference_range j p
+    · exact Elliptic.HigherHomology.periodCover_h2_ker_eq_deckDifference_range j p
+    · exact Elliptic.HigherHomology.periodCover_h3_ker_eq_deckDifference_range j p
+    · exact Elliptic.HigherHomology.periodCover_h4_ker_eq_deckDifference_range j p
+  · have :=
+      PeriodTorusHigherHomology.periodTorus_homology_subsingleton_of_lt p.val
+        (Nat.lt_of_not_ge hn)
+    ext a
+    rw [Subsingleton.elim a 0]
+    simp only [Submodule.zero_mem]
+
+private theorem ThreefoldHomology.EllipticFibre.periodHomologyEquiv_affine (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv (Elliptic.flatTorusPeriodHomeomorph p.val) n
+        (SingularMayerVietoris.singularHomologyMap
+          (Elliptic.flatTorusAffine j j.twist : C(RealTorus₄, RealTorus₄)) n a) =
+      SingularMayerVietoris.singularHomologyMap
+        (Elliptic.HigherHomology.periodAffineHomeomorph j p : C(p.val.Torus, p.val.Torus)) n
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+          (Elliptic.flatTorusPeriodHomeomorph p.val) n a) := by
+  have h :
+    (Elliptic.flatTorusPeriodHomeomorph p.val : C(RealTorus₄, p.val.Torus)).comp
+        (Elliptic.flatTorusAffine j j.twist : C(RealTorus₄, RealTorus₄)) =
+      (Elliptic.HigherHomology.periodAffineHomeomorph j p : C(p.val.Torus, p.val.Torus)).comp
+        (Elliptic.flatTorusPeriodHomeomorph p.val : C(RealTorus₄, p.val.Torus)) := by
+    ext x
+    exact Elliptic.flatTorusAffine_periodHomeomorph j p j.twist x
+  have hh :=
+    congrArg (fun u : C(RealTorus₄, p.val.Torus) => SingularMayerVietoris.singularHomologyMap u n)
+      h
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodTorusHigherHomology.singularHomologyMap_comp] at hh
+  exact LinearMap.congr_fun hh a
+
+private theorem ThreefoldHomology.EllipticFibre.periodHomologyEquiv_affine_symm (j : Elliptic.Kind)
+    (p : Elliptic.FixedPeriod j) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv (Elliptic.flatTorusPeriodHomeomorph p.val) n
+        (SingularMayerVietoris.singularHomologyMap
+          ((Elliptic.flatTorusAffine j j.twist).symm : C(RealTorus₄, RealTorus₄)) n a) =
+      SingularMayerVietoris.singularHomologyMap
+        ((Elliptic.HigherHomology.periodAffineHomeomorph j p).symm : C(p.val.Torus, p.val.Torus))
+        n
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+          (Elliptic.flatTorusPeriodHomeomorph p.val) n a) := by
+  let A :=
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv (Elliptic.flatTorusAffine j j.twist) n
+  let B :=
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv
+      (Elliptic.HigherHomology.periodAffineHomeomorph j p) n
+  let E :=
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv (Elliptic.flatTorusPeriodHomeomorph p.val) n
+  have h := periodHomologyEquiv_affine j p n (A.symm a)
+  change E (A (A.symm a)) = B (E (A.symm a)) at h
+  rw [LinearEquiv.apply_symm_apply] at h
+  change E (A.symm a) = B.symm (E a)
+  apply B.injective
+  simpa only [LinearEquiv.apply_symm_apply] using h.symm
+
+private theorem ThreefoldHomology.EllipticFibre.periodHomologyEquiv_inverseWangDifference
+    (j : Elliptic.Kind) (p : Elliptic.FixedPeriod j) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv (Elliptic.flatTorusPeriodHomeomorph p.val) n
+        (MappingTorusHomology.wangDifference (Elliptic.flatTorusAffine j j.twist).symm n a) =
+      Elliptic.HigherHomology.periodDeckDifference j p n
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+          (Elliptic.flatTorusPeriodHomeomorph p.val) n a) := by
+  rw [MappingTorusHomology.wangDifference_apply, map_sub,
+    Elliptic.HigherHomology.periodDeckDifference_apply, periodHomologyEquiv_affine_symm]
+
+private theorem ThreefoldHomology.EllipticFibre.periodHomologyEquiv_mem_deckDifference_range_iff
+    (j : Elliptic.Kind) (p : Elliptic.FixedPeriod j) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv (Elliptic.flatTorusPeriodHomeomorph p.val) n
+          a ∈
+        LinearMap.range (Elliptic.HigherHomology.periodDeckDifference j p n) ↔
+      a ∈
+        LinearMap.range
+          (MappingTorusHomology.wangDifference (Elliptic.flatTorusAffine j j.twist) n) := by
+  rw [← wangDifference_symm_range (Elliptic.flatTorusAffine j j.twist) n]
+  let E :=
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv (Elliptic.flatTorusPeriodHomeomorph p.val) n
+  constructor
+  · rintro ⟨b, hb⟩
+    refine ⟨E.symm b, E.injective ?_⟩
+    change
+      PeriodTorusHigherHomology.homeomorphHomologyEquiv (Elliptic.flatTorusPeriodHomeomorph p.val)
+          n
+          (MappingTorusHomology.wangDifference (Elliptic.flatTorusAffine j j.twist).symm n
+            (E.symm b)) =
+        E a
+    rw [periodHomologyEquiv_inverseWangDifference]
+    change Elliptic.HigherHomology.periodDeckDifference j p n (E (E.symm b)) = E a
+    rw [LinearEquiv.apply_symm_apply]
+    exact hb
+  · rintro ⟨b, rfl⟩
+    exact ⟨E b, (periodHomologyEquiv_inverseWangDifference j p n b).symm⟩
+
+private theorem ThreefoldHomology.EllipticFibre.fibreToFilling_ker_eq_wangDifference_range
+    (j : Elliptic.Kind) (n : ℕ) :
+    LinearMap.ker
+        (SingularMayerVietoris.singularHomologyMap
+          (ThreefoldOverlapMappingTorus.fibreToFilling (Option.some j)) n) =
+      LinearMap.range
+        (MappingTorusHomology.wangDifference
+          (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) n) := by
+  ext a
+  change
+    SingularMayerVietoris.singularHomologyMap
+          (ThreefoldOverlapMappingTorus.fibreToFilling (Option.some j)) n a =
+        0 ↔
+      _
+  rw [fibreToFilling_homology_eq_zero_iff]
+  change
+    centralPeriodHomologyEquiv j n a ∈
+        LinearMap.ker
+          (SingularMayerVietoris.singularHomologyMap
+            (Elliptic.HigherHomology.periodCover j
+              (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+              (Elliptic.mainTwist_admissible j))
+            n) ↔
+      _
+  rw [periodCover_ker_eq_deckDifference_range]
+  exact
+    periodHomologyEquiv_mem_deckDifference_range_iff j
+      (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod n a
+
+private theorem ThreefoldHomology.EllipticFibre.fibreToFilling_eq_zero_iff_fibreHomologyMap_eq_zero
+    (j : Elliptic.Kind) (n : ℕ) (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    SingularMayerVietoris.singularHomologyMap
+          (ThreefoldOverlapMappingTorus.fibreToFilling (Option.some j)) n a =
+        0 ↔
+      MappingTorusHomology.fibreHomologyMap
+          (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) n a =
+        0 := by
+  change
+    a ∈
+        LinearMap.ker
+          (SingularMayerVietoris.singularHomologyMap
+            (ThreefoldOverlapMappingTorus.fibreToFilling (Option.some j)) n) ↔
+      a ∈
+        LinearMap.ker
+          (MappingTorusHomology.fibreHomologyMap
+            (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) n)
+  rw [fibreToFilling_ker_eq_wangDifference_range, MappingTorusHomology.wang_exact_at_fibre]
+
+private theorem
+    ThreefoldHomology.EllipticFibre.boundaryFilling_wang_eq_zero (j : Elliptic.Kind) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (ThreefoldOverlapMappingTorus.Boundary (Option.some j)) (n + 1))
+    (hcap : ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) (n + 1) a = 0)
+    (hwang :
+      MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) n
+          a =
+        0) :
+    a = 0 := by
+  have ha :
+    a ∈
+      LinearMap.range
+        (MappingTorusHomology.fibreHomologyMap
+          (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) (n + 1)) := by
+    rw [MappingTorusHomology.wang_exact_at_mappingTorus]
+    exact hwang
+  obtain ⟨b, rfl⟩ := ha
+  have hf :=
+    LinearMap.congr_fun
+      (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap_fibre (Option.some j) (n + 1)) b
+  change
+    ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) (n + 1)
+        (MappingTorusHomology.fibreHomologyMap
+          (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) (n + 1) b) =
+      SingularMayerVietoris.singularHomologyMap
+        (ThreefoldOverlapMappingTorus.fibreToFilling (Option.some j)) (n + 1) b at hf
+  exact (fibreToFilling_eq_zero_iff_fibreHomologyMap_eq_zero j (n + 1) b).mp (hf.symm.trans hcap)
+
+private theorem ThreefoldHomology.EllipticFibre.boundaryFilling_wang_injective (j : Elliptic.Kind)
+    (n : ℕ) :
+    Function.Injective
+      (fun a :
+          SingularMayerVietoris.SingularHomology
+            (ThreefoldOverlapMappingTorus.Boundary (Option.some j)) (n + 1) =>
+        (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) (n + 1) a,
+          MappingTorusHomology.wangBoundary
+            (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) n a)) := by
+  intro a b h
+  have hc :
+    ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) (n + 1) a =
+      ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) (n + 1) b :=
+    congrArg Prod.fst h
+  have hw :
+    MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) n
+        a =
+      MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) n
+        b :=
+    congrArg Prod.snd h
+  apply sub_eq_zero.mp
+  apply boundaryFilling_wang_eq_zero j n
+  · rw [map_sub, hc, sub_self]
+  · rw [map_sub, hw, sub_self]
+
+private theorem ThreefoldHomology.EllipticFibre.boundaryFilling_four_wang_three_injective
+    (j : Elliptic.Kind) :
+    Function.Injective
+      (fun a :
+          SingularMayerVietoris.SingularHomology
+            (ThreefoldOverlapMappingTorus.Boundary (Option.some j)) 4 =>
+        (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) 4 a,
+          MappingTorusHomology.wangBoundary
+            (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) 3 a)) :=
+  boundaryFilling_wang_injective j 3
+
+private theorem
+    ThreefoldHomology.EllipticFibre.overlapFilling_wang_eq_zero (j : Elliptic.Kind) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.Threefold.RegularOverlap (Option.some j)) (n + 1))
+    (hcap :
+      SingularMayerVietoris.singularHomologyMap
+          (ThreefoldHomology.overlapToFilling (Option.some j)) (n + 1) a =
+        0)
+    (hwang :
+      MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) n
+          (ThreefoldOverlapMappingTorus.overlapHomologyEquiv (Option.some j) (n + 1) a) =
+        0) :
+    a = 0 := by
+  apply (ThreefoldOverlapMappingTorus.overlapHomologyEquiv (Option.some j) (n + 1)).injective
+  rw [map_zero]
+  apply boundaryFilling_wang_eq_zero j n
+  · have hf :=
+      LinearMap.congr_fun
+        (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap_retraction (Option.some j)
+          (n + 1))
+        a
+    change
+      ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) (n + 1)
+          (ThreefoldOverlapMappingTorus.overlapHomologyEquiv (Option.some j) (n + 1) a) =
+        SingularMayerVietoris.singularHomologyMap
+          (ThreefoldHomology.overlapToFilling (Option.some j)) (n + 1) a at hf
+    exact hf.trans hcap
+  · exact hwang
+
+private def ThreefoldHomology.FourthFibre.positiveFibreClass :
+    SingularMayerVietoris.SingularHomology RealTorus₄ 4 :=
+  PeriodTorusHigherHomology.realTorusH4Equiv.symm 1
+
+@[simp]
+private theorem ThreefoldHomology.FourthFibre.positiveFibreClass_coordinates :
+    PeriodTorusHigherHomology.realTorusH4Equiv positiveFibreClass = 1 :=
+  PeriodTorusHigherHomology.realTorusH4Equiv.apply_symm_apply 1
+
+private def ThreefoldHomology.FourthFibre.nativeUnitCapSection (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology (ThreefoldOverlapMappingTorus.Boundary (Option.some j))
+      4 :=
+  PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass j
+
+private theorem ThreefoldHomology.FourthFibre.wang_three_fibre_four
+    (i : SpecialPeriods.Threefold.Puncture)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 4) :
+    MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy i) 3
+        (MappingTorusHomology.fibreHomologyMap (ThreefoldOverlapMappingTorus.monodromy i) 4 a) =
+      0 := by
+  have ha :
+    MappingTorusHomology.fibreHomologyMap (ThreefoldOverlapMappingTorus.monodromy i) 4 a ∈
+      LinearMap.range
+        (MappingTorusHomology.fibreHomologyMap (ThreefoldOverlapMappingTorus.monodromy i) 4) :=
+    ⟨a, rfl⟩
+  rw [MappingTorusHomology.wang_exact_at_mappingTorus (ThreefoldOverlapMappingTorus.monodromy i)
+      3] at ha
+  exact ha
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/HomologyOfX/ThreefoldHomology4.lean b/LeanPool/HopfProblem/HomologyOfX/ThreefoldHomology4.lean
new file mode 100644
index 000000000..e49213f0c
--- /dev/null
+++ b/LeanPool/HopfProblem/HomologyOfX/ThreefoldHomology4.lean
@@ -0,0 +1,1647 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Hurewicz.SixthHurewicz
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology7
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods6
+import all LeanPool.HopfProblem.HomologyOfX.CuspCoinvariants
+import all LeanPool.HopfProblem.PeriodFamily.Core2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import all LeanPool.HopfProblem.Elliptic.Core3
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods8
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology1
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen2
+import all LeanPool.HopfProblem.Elliptic.Core5
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods9
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology2
+import all LeanPool.HopfProblem.PeriodFamily.Core4
+import all LeanPool.HopfProblem.PeriodFamily.Core5
+import all LeanPool.HopfProblem.PeriodFamily.Core6
+import all LeanPool.HopfProblem.PeriodFamily.Core7
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology3
+import all LeanPool.HopfProblem.PeriodFamily.Core8
+import all LeanPool.HopfProblem.CuspFibre.CuspBoundaryTopVanishing
+import all LeanPool.HopfProblem.PeriodFamily.Core9
+import all LeanPool.HopfProblem.CuspFibre.CuspNegation
+import all LeanPool.HopfProblem.Hurewicz.SixthHurewicz
+
+/-!
+# Hopf problem: homology of x · threefold homology 4
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem ThreefoldHomology.FourthFibre.ellipticFirstAxis_eq (j : Elliptic.Kind) :
+    (ThreefoldHomology.CapElimination.ellipticThreeClass j ![1, 0]).val =
+      γ j.twist •
+          MappingTorusHomology.fibreHomologyMap
+            (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) 4 positiveFibreClass -
+        (j.order : ℤ) • nativeUnitCapSection j := by
+  apply ThreefoldHomology.EllipticFibre.boundaryFilling_four_wang_three_injective j
+  apply Prod.ext
+  · calc
+      ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) 4
+            (ThreefoldHomology.CapElimination.ellipticThreeClass j ![1, 0]).val =
+          0 :=
+        (ThreefoldHomology.CapElimination.ellipticThreeClass j ![1, 0]).property
+      _ =
+          ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) 4
+            (γ j.twist •
+                MappingTorusHomology.fibreHomologyMap
+                  (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) 4 positiveFibreClass -
+              (j.order : ℤ) • nativeUnitCapSection j) := by
+        symm
+        let c :
+          SingularMayerVietoris.SingularHomology
+              (ThreefoldOverlapMappingTorus.Boundary (Option.some j)) 4 →ₗ[ℤ]
+            ℤ :=
+          (Elliptic.HigherHomology.surfaceH4Equiv j
+                (SpecialPeriods.EllipticFilling.specialLocalData
+                    j).centralPeriod).toLinearMap.comp
+            ((ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j
+                  4).toLinearMap.comp
+              (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) 4))
+        have hf :
+          c
+              (MappingTorusHomology.fibreHomologyMap
+                (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) 4 positiveFibreClass) =
+            (j.order : ℤ) * γ j.twist := by
+          have h :=
+            PeriodFamily.Boundary.EllipticTopFibre.boundaryFilling_fibre_h4_coordinates j
+              positiveFibreClass
+          rw [positiveFibreClass_coordinates, mul_one] at h
+          exact h
+        have hu : c (nativeUnitCapSection j) = 1 :=
+          PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass_filling j
+        apply (ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j 4).injective
+        apply
+          (Elliptic.HigherHomology.surfaceH4Equiv j
+              (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).injective
+        change c (_ - _) = _
+        rw [map_zero, map_zero, map_sub, map_zsmul, map_zsmul, hf, hu]
+        cases j <;> norm_num [Elliptic.Kind.order, Elliptic.Kind.twist, γ, ε, ε']
+  · apply PeriodFamily.FlatTorus.singularH3Coordinates.injective
+    let w :
+      SingularMayerVietoris.SingularHomology
+          (ThreefoldOverlapMappingTorus.Boundary (Option.some j)) 4 →ₗ[ℤ]
+        Lattice :=
+      PeriodFamily.FlatTorus.singularH3Coordinates.toLinearMap.comp
+        (MappingTorusHomology.wangBoundary
+          (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) 3)
+    have hk :
+      w (ThreefoldHomology.CapElimination.ellipticThreeClass j ![1, 0]).val =
+        (j.order : ℤ) • ![0, 0, 0, 1] :=
+      PeriodFamily.Boundary.EllipticCapKernelWang.capKernelWangH4Coordinates_first_axis j
+    have hf :
+      w
+          (MappingTorusHomology.fibreHomologyMap
+            (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) 4 positiveFibreClass) =
+        0 :=
+      (congrArg PeriodFamily.FlatTorus.singularH3Coordinates
+            (wang_three_fibre_four (Option.some j) positiveFibreClass)).trans
+        PeriodFamily.FlatTorus.singularH3Coordinates.map_zero
+    have hu : w (nativeUnitCapSection j) = -Pi.single (3 : Fin 4) 1 :=
+      PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass_wang j
+    change w _ = w (_ - _)
+    rw [hk, map_sub, map_zsmul, map_zsmul, hf, hu]
+    have haxis : (Pi.single (3 : Fin 4) (1 : ℤ) : Lattice) = ![0, 0, 0, 1] := by
+      ext i
+      fin_cases i <;> simp
+    simp [haxis]
+
+private theorem ThreefoldHomology.FourthFibre.ellipticThreeFirstAxis_eq :
+    (ThreefoldHomology.CapElimination.ellipticThreeClass .three ![1, 0]).val =
+      MappingTorusHomology.fibreHomologyMap
+          (ThreefoldOverlapMappingTorus.monodromy (Option.some Elliptic.Kind.three)) 4
+          positiveFibreClass -
+        (3 : ℤ) • nativeUnitCapSection .three := by
+  simpa [Elliptic.Kind.order, Elliptic.Kind.twist, γ, ε] using ellipticFirstAxis_eq .three
+
+private theorem ThreefoldHomology.FourthFibre.ellipticFourFirstAxis_eq :
+    (ThreefoldHomology.CapElimination.ellipticThreeClass .four ![1, 0]).val =
+      -MappingTorusHomology.fibreHomologyMap
+            (ThreefoldOverlapMappingTorus.monodromy (Option.some Elliptic.Kind.four)) 4
+            positiveFibreClass -
+        (4 : ℤ) • nativeUnitCapSection .four := by
+  simpa [Elliptic.Kind.order, Elliptic.Kind.twist, γ, ε'] using ellipticFirstAxis_eq .four
+
+private def ThreefoldHomology.FourthFibre.cuspClass :
+    ThreefoldHomology.CapElimination.NativeCapKernel Option.none 4 :=
+  ⟨CuspBoundaryGammaZero.nativeClass,
+    CuspBoundaryTopVanishing.boundaryFillingHomologyMap_nativeClass_eq_zero⟩
+
+private def ThreefoldHomology.FourthFibre.nativeFibrePreimage :
+    ∀ i : SpecialPeriods.Threefold.Puncture, ThreefoldHomology.CapElimination.NativeCapKernel i 4
+  | none => (12 : ℤ) • cuspClass
+  | some .three => (4 : ℤ) • ThreefoldHomology.CapElimination.ellipticThreeClass .three ![1, 0]
+  | some .four => (3 : ℤ) • ThreefoldHomology.CapElimination.ellipticThreeClass .four ![1, 0]
+
+private theorem ThreefoldHomology.FourthFibre.ellipticThreeFirstAxis_regular :
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some Elliptic.Kind.three) 4
+        (ThreefoldHomology.CapElimination.ellipticThreeClass .three ![1, 0]).val =
+      SingularMayerVietoris.singularHomologyMap
+          (PeriodFamily.Homology.familyFibreInclusion
+            (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)
+            PeriodFamily.Homology.normalizedSlitBaseLift)
+          4 positiveFibreClass -
+        (3 : ℤ) •
+          ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap
+            (Option.some Elliptic.Kind.three) 4
+            (PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass .three) := by
+  have h :=
+    congrArg
+      (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some Elliptic.Kind.three)
+        4)
+      ellipticThreeFirstAxis_eq
+  rw [map_sub, map_zsmul,
+    PeriodFamily.Boundary.boundaryRegularHomologyMap_common_fibre_apply] at h
+  exact h
+
+private theorem ThreefoldHomology.FourthFibre.ellipticFourFirstAxis_regular :
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some Elliptic.Kind.four) 4
+        (ThreefoldHomology.CapElimination.ellipticThreeClass .four ![1, 0]).val =
+      -SingularMayerVietoris.singularHomologyMap
+            (PeriodFamily.Homology.familyFibreInclusion
+              (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                SpecialPeriods.specialPeriodMap_generator₁
+                SpecialPeriods.specialPeriodMap_generator₂)
+              PeriodFamily.Homology.normalizedSlitBaseLift)
+            4 positiveFibreClass -
+        (4 : ℤ) •
+          ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some Elliptic.Kind.four)
+            4 (PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass .four) := by
+  have h :=
+    congrArg
+      (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some Elliptic.Kind.four) 4)
+      ellipticFourFirstAxis_eq
+  rw [map_sub, map_neg, map_zsmul,
+    PeriodFamily.Boundary.boundaryRegularHomologyMap_common_fibre_apply] at h
+  exact h
+
+private theorem ThreefoldHomology.FourthFibre.nativeFibrePreimage_map :
+    ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 4 nativeFibrePreimage =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodFamily.Homology.familyFibreInclusion
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          PeriodFamily.Homology.normalizedSlitBaseLift)
+        4 positiveFibreClass := by
+  classical
+  rw [ThreefoldHomology.CapElimination.nativeCapKernelRegularMap_apply, Fintype.sum_option]
+  have hu : (Finset.univ : Finset Elliptic.Kind) = {.three, .four} := by
+    ext j
+    cases j <;> simp
+  rw [hu, Finset.sum_pair (by decide : Elliptic.Kind.three ≠ .four)]
+  have hc :
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none 4 cuspClass.val =
+      ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some Elliptic.Kind.three) 4
+          (PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass .three) +
+        ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some Elliptic.Kind.four) 4
+          (PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass .four) :=
+    PeriodFamily.Boundary.FourthRelation.nativeClass_regular_eq_capSections
+  change
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none 4
+          ((12 : ℤ) • cuspClass.val) +
+        (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some Elliptic.Kind.three)
+            4
+            ((4 : ℤ) • (ThreefoldHomology.CapElimination.ellipticThreeClass .three ![1, 0]).val) +
+          ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some Elliptic.Kind.four)
+            4
+            ((3 : ℤ) • (ThreefoldHomology.CapElimination.ellipticThreeClass .four ![1, 0]).val)) =
+      _
+  rw [map_zsmul, map_zsmul, map_zsmul, hc, ellipticThreeFirstAxis_regular,
+    ellipticFourFirstAxis_regular]
+  abel
+
+private def ThreefoldHomology.FourthFibre.nativeFibrePreimageOf
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 4) :
+    ∀ i : SpecialPeriods.Threefold.Puncture,
+      ThreefoldHomology.CapElimination.NativeCapKernel i 4 :=
+  PeriodTorusHigherHomology.realTorusH4Equiv a • nativeFibrePreimage
+
+private theorem ThreefoldHomology.FourthFibre.positiveFibreClass_spans
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 4) :
+    PeriodTorusHigherHomology.realTorusH4Equiv a • positiveFibreClass = a := by
+  apply PeriodTorusHigherHomology.realTorusH4Equiv.injective
+  rw [map_zsmul, positiveFibreClass_coordinates]
+  simp
+
+private theorem ThreefoldHomology.FourthFibre.nativeFibrePreimageOf_map
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 4) :
+    ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 4 (nativeFibrePreimageOf a) =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodFamily.Homology.familyFibreInclusion
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          PeriodFamily.Homology.normalizedSlitBaseLift)
+        4 a := by
+  calc
+    ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 4 (nativeFibrePreimageOf a) =
+        PeriodTorusHigherHomology.realTorusH4Equiv a •
+          ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 4 nativeFibrePreimage :=
+      map_zsmul (ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 4)
+        (PeriodTorusHigherHomology.realTorusH4Equiv a) nativeFibrePreimage
+    _ =
+        PeriodTorusHigherHomology.realTorusH4Equiv a •
+          SingularMayerVietoris.singularHomologyMap
+            (PeriodFamily.Homology.familyFibreInclusion
+              (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                SpecialPeriods.specialPeriodMap_generator₁
+                SpecialPeriods.specialPeriodMap_generator₂)
+              PeriodFamily.Homology.normalizedSlitBaseLift)
+            4 positiveFibreClass :=
+      (congrArg (fun b => PeriodTorusHigherHomology.realTorusH4Equiv a • b)
+        nativeFibrePreimage_map)
+    _ =
+        SingularMayerVietoris.singularHomologyMap
+          (PeriodFamily.Homology.familyFibreInclusion
+            (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)
+            PeriodFamily.Homology.normalizedSlitBaseLift)
+          4 (PeriodTorusHigherHomology.realTorusH4Equiv a • positiveFibreClass) :=
+      (map_zsmul
+          (SingularMayerVietoris.singularHomologyMap
+            (PeriodFamily.Homology.familyFibreInclusion
+              (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                SpecialPeriods.specialPeriodMap_generator₁
+                SpecialPeriods.specialPeriodMap_generator₂)
+              PeriodFamily.Homology.normalizedSlitBaseLift)
+            4)
+          (PeriodTorusHigherHomology.realTorusH4Equiv a) positiveFibreClass).symm
+    _ =
+        SingularMayerVietoris.singularHomologyMap
+          (PeriodFamily.Homology.familyFibreInclusion
+            (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)
+            PeriodFamily.Homology.normalizedSlitBaseLift)
+          4 a :=
+      congrArg
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodFamily.Homology.familyFibreInclusion
+            (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)
+            PeriodFamily.Homology.normalizedSlitBaseLift)
+          4)
+        (positiveFibreClass_spans a)
+
+private theorem ThreefoldHomology.FourthFibre.fibre_mem_range
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 4) :
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodFamily.Homology.familyFibreInclusion
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          PeriodFamily.Homology.normalizedSlitBaseLift)
+        4 a ∈
+      LinearMap.range (ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 4) :=
+  ⟨nativeFibrePreimageOf a, nativeFibrePreimageOf_map a⟩
+
+private theorem ThreefoldHomology.FourthFibre.fibre_range_le :
+    LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodFamily.Homology.familyFibreInclusion
+            (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)
+            PeriodFamily.Homology.normalizedSlitBaseLift)
+          4) ≤
+      LinearMap.range (ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 4) := by
+  rintro _ ⟨a, rfl⟩
+  exact fibre_mem_range a
+
+private theorem ThreefoldHomology.FifthDegree.signed_residual_coordinate_zero (k u v d : ℤ)
+    (hthree : 3 * u = k) (hfour : -4 * v = k) (hregular : u + v = d * k) : k = 0 := by
+  have h : (12 * d - 1) * k = 0 := by linear_combination 4 * hthree - 3 * hfour - 12 * hregular
+  have hn : 12 * d - 1 ≠ 0 := by omega
+  exact (mul_eq_zero.mp h).resolve_left hn
+
+private theorem ThreefoldHomology.TopDegree.connecting_five_injective :
+    Function.Injective (ThreefoldHomology.starConnectingHomomorphism 5) := by
+  have := ThreefoldHomology.Finiteness.starPairHomology_subsingleton (by decide : 5 < 6)
+  intro a b hab
+  have hz : ThreefoldHomology.starConnectingHomomorphism 5 (a - b) = 0 := by
+    rw [map_sub, hab, sub_self]
+  obtain ⟨c, hc⟩ := (ThreefoldHomology.star_exact_at_ambient 5 (a - b)).mp hz
+  have hc₀ : c = 0 := Subsingleton.elim _ _
+  rw [hc₀, map_zero] at hc
+  exact sub_eq_zero.mp hc.symm
+
+private def ThreefoldHomology.TopDegree.connectingIntoKernel :
+    SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 6 →ₗ[ℤ]
+      LinearMap.ker (ThreefoldHomology.starLeftHomologyMap 5) :=
+  (ThreefoldHomology.starConnectingHomomorphism 5).codRestrict
+    (LinearMap.ker (ThreefoldHomology.starLeftHomologyMap 5))
+    (fun a => (ThreefoldHomology.star_exact_at_intersection 5).apply_apply_eq_zero a)
+
+private theorem ThreefoldHomology.TopDegree.connectingIntoKernel_bijective :
+    Function.Bijective connectingIntoKernel := by
+  constructor
+  · intro a b hab
+    exact connecting_five_injective (congrArg Subtype.val hab)
+  · intro a
+    obtain ⟨b, hb⟩ := (ThreefoldHomology.star_exact_at_intersection 5 a.val).mp a.property
+    exact ⟨b, Subtype.ext hb⟩
+
+private def ThreefoldHomology.TopDegree.homologySixKernelEquiv :
+    SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 6 ≃ₗ[ℤ]
+      LinearMap.ker (ThreefoldHomology.starLeftHomologyMap 5) :=
+  LinearEquiv.ofBijective connectingIntoKernel connectingIntoKernel_bijective
+
+private theorem ThreefoldHomology.TopDegree.starLeft_five_eq_zero_iff
+    (a : ThreefoldHomology.StarOverlapHomology 5) :
+    ThreefoldHomology.starLeftHomologyMap 5 a = 0 ↔
+      ThreefoldHomology.starOverlapToRegularHomologyMap 5 a = 0 := by
+  have := ThreefoldHomology.Finiteness.starFillingHomology_subsingleton (by decide : 4 < 5)
+  change
+    (ThreefoldHomology.starOverlapToRegularHomologyMap 5 a,
+          -ThreefoldHomology.starOverlapToFillingsHomologyMap 5 a) =
+        (0, 0) ↔
+      _
+  constructor
+  · intro h
+    exact congrArg Prod.fst h
+  · intro h
+    exact Prod.ext h (Subsingleton.elim _ _)
+
+private def ThreefoldHomology.TopDegree.attachmentKernelEquiv :
+    LinearMap.ker (ThreefoldHomology.starLeftHomologyMap 5) ≃ₗ[ℤ]
+      LinearMap.ker (ThreefoldHomology.starOverlapToRegularHomologyMap 5)
+    where
+  toFun a := ⟨a.val, (starLeft_five_eq_zero_iff a.val).mp a.property⟩
+  invFun a := ⟨a.val, (starLeft_five_eq_zero_iff a.val).mpr a.property⟩
+  map_add' _ _ := rfl
+  map_smul' _ _ := rfl
+  left_inv _ := rfl
+  right_inv _ := rfl
+
+private def ThreefoldHomology.TopDegree.homologySixRegularKernelEquiv :
+    SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 6 ≃ₗ[ℤ]
+      LinearMap.ker (ThreefoldHomology.starOverlapToRegularHomologyMap 5) :=
+  homologySixKernelEquiv.trans attachmentKernelEquiv
+
+private abbrev ThreefoldHomology.TopDegree.EllipticOverlapFifth :=
+  ∀ j : Elliptic.Kind,
+    SingularMayerVietoris.SingularHomology
+      (SpecialPeriods.Threefold.RegularOverlap (Option.some j)) 5
+
+private def ThreefoldHomology.TopDegree.groupedOverlapFifthEquiv :
+    ThreefoldHomology.StarOverlapHomology 5 ≃ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology
+          (SpecialPeriods.Threefold.RegularOverlap Option.none) 5 ×
+        EllipticOverlapFifth) :=
+  ({ Equiv.piOptionEquivProd with map_add' := fun _ _ => rfl } :
+      ThreefoldHomology.StarOverlapHomology 5 ≃+
+        (SingularMayerVietoris.SingularHomology
+            (SpecialPeriods.Threefold.RegularOverlap Option.none) 5 ×
+          EllipticOverlapFifth)).toIntLinearEquiv
+
+private def ThreefoldHomology.TopDegree.ellipticAttachmentFifth :
+    EllipticOverlapFifth →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily 5
+    where
+  toFun
+    a :=
+    ∑ j : Elliptic.Kind,
+      SingularMayerVietoris.singularHomologyMap
+        (ThreefoldHomology.overlapToRegularFamily (Option.some j)) 5 (a j)
+  map_add' a b := by simp only [Pi.add_apply, map_add, Finset.sum_add_distrib]
+  map_smul' r
+    a := by
+    simp only [Pi.smul_apply, map_zsmul, Finset.smul_sum, RingHom.id_apply]
+    apply Finset.sum_congr rfl
+    intro j _
+    exact (int_smul_eq_zsmul ..).symm
+
+@[simp]
+private theorem
+    ThreefoldHomology.TopDegree.ellipticAttachmentFifth_apply (a : EllipticOverlapFifth) :
+    ellipticAttachmentFifth a =
+      ∑ j : Elliptic.Kind,
+        SingularMayerVietoris.singularHomologyMap
+          (ThreefoldHomology.overlapToRegularFamily (Option.some j)) 5 (a j) :=
+  rfl
+
+private def ThreefoldHomology.TopDegree.groupedAttachmentFifth :
+    (SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap Option.none)
+          5 ×
+        EllipticOverlapFifth) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily 5 :=
+  (ThreefoldHomology.starOverlapToRegularHomologyMap 5).comp
+    groupedOverlapFifthEquiv.symm.toLinearMap
+
+@[simp]
+private theorem ThreefoldHomology.TopDegree.groupedAttachmentFifth_apply
+    (a :
+      SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap Option.none)
+        5)
+    (b : EllipticOverlapFifth) :
+    groupedAttachmentFifth (a, b) =
+      SingularMayerVietoris.singularHomologyMap
+          (ThreefoldHomology.overlapToRegularFamily Option.none) 5 a +
+        ellipticAttachmentFifth b := by
+  change
+    (∑ i : SpecialPeriods.Threefold.Puncture,
+        SingularMayerVietoris.singularHomologyMap (ThreefoldHomology.overlapToRegularFamily i) 5
+          (groupedOverlapFifthEquiv.symm (a, b) i)) =
+      _
+  rw [Fintype.sum_option]
+  rfl
+
+private def ThreefoldHomology.TopDegree.groupedAttachmentKernelEquiv :
+    LinearMap.ker (ThreefoldHomology.starOverlapToRegularHomologyMap 5) ≃ₗ[ℤ]
+      LinearMap.ker groupedAttachmentFifth :=
+  ({    toFun := fun a =>
+          ⟨groupedOverlapFifthEquiv a.val,
+            by
+            change
+              ThreefoldHomology.starOverlapToRegularHomologyMap 5
+                  (groupedOverlapFifthEquiv.symm (groupedOverlapFifthEquiv a.val)) =
+                0
+            rw [LinearEquiv.symm_apply_apply]
+            exact a.property⟩
+        invFun := fun a => ⟨groupedOverlapFifthEquiv.symm a.val, a.property⟩
+        left_inv := fun a => Subtype.ext (LinearEquiv.symm_apply_apply _ a.val)
+        right_inv := fun a => Subtype.ext (LinearEquiv.apply_symm_apply _ a.val)
+        map_add' := fun a b => Subtype.ext (map_add groupedOverlapFifthEquiv a.val b.val) } :
+      LinearMap.ker (ThreefoldHomology.starOverlapToRegularHomologyMap 5) ≃+
+        LinearMap.ker groupedAttachmentFifth).toIntLinearEquiv
+
+private def ThreefoldHomology.TopDegree.homologySixGroupedKernelEquiv :
+    SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 6 ≃ₗ[ℤ]
+      LinearMap.ker groupedAttachmentFifth :=
+  homologySixRegularKernelEquiv.trans groupedAttachmentKernelEquiv
+
+@[simp]
+private theorem ThreefoldHomology.TopDegree.homologySixGroupedKernelEquiv_val
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 6) :
+    (homologySixGroupedKernelEquiv a :
+        SingularMayerVietoris.SingularHomology
+            (SpecialPeriods.Threefold.RegularOverlap Option.none) 5 ×
+          EllipticOverlapFifth) =
+      (ThreefoldHomology.starConnectingHomomorphism 5 a Option.none, fun j =>
+        ThreefoldHomology.starConnectingHomomorphism 5 a (Option.some j)) :=
+  rfl
+
+private theorem ThreefoldHomology.TopDegree.triangleTopHomologyMap_identity
+    (g : SpecialPeriods.TriangleGroup) :
+    SingularMayerVietoris.singularHomologyMap
+        (SpecialPeriods.triangleTorusHomeomorph g : C(RealTorus₄, RealTorus₄)) 4 =
+      LinearMap.id := by
+  change (PeriodFamily.Homology.triangleHomologyEquiv g 4).toLinearMap = _
+  rw [PeriodFamily.HomologyDifference.triangleHomologyFour_identity]
+  rfl
+
+private theorem ThreefoldHomology.TopDegree.boundaryMonodromy_four_identity
+    (i : SpecialPeriods.Threefold.Puncture) :
+    MappingTorusHomology.monodromyHomologyMap (ThreefoldOverlapMappingTorus.monodromy i) 4 =
+      LinearMap.id := by
+  cases i with
+  |
+    none =>
+    change
+      SingularMayerVietoris.singularHomologyMap
+          (SpecialPeriods.CuspFamily.cuspTorusHomeomorph 1 : C(RealTorus₄, RealTorus₄)) 4 =
+        _
+    rw [← SpecialPeriods.triangleTorusHomeomorph_cusp_zpow 1]
+    exact triangleTopHomologyMap_identity _
+  | some
+    j =>
+    change
+      SingularMayerVietoris.singularHomologyMap
+          (Elliptic.flatTorusAffine j j.twist : C(RealTorus₄, RealTorus₄)) 4 =
+        _
+    rw [PeriodFamily.Boundary.flatTorusAffine_homology_triangle,
+      PeriodFamily.HomologyDifference.triangleHomologyFour_identity]
+    rfl
+
+private def ThreefoldHomology.TopDegree.boundaryFifthEquiv (i : SpecialPeriods.Threefold.Puncture) :
+    SingularMayerVietoris.SingularHomology (ThreefoldOverlapMappingTorus.Boundary i) 5 ≃ₗ[ℤ] ℤ :=
+  (PeriodFamily.Boundary.H5ToH4WangEquiv (ThreefoldOverlapMappingTorus.monodromy i)
+        (boundaryMonodromy_four_identity i)).trans
+    PeriodTorusHigherHomology.realTorusH4Equiv
+
+@[simp]
+private theorem ThreefoldHomology.TopDegree.boundaryFifthEquiv_apply
+    (i : SpecialPeriods.Threefold.Puncture)
+    (a : SingularMayerVietoris.SingularHomology (ThreefoldOverlapMappingTorus.Boundary i) 5) :
+    boundaryFifthEquiv i a =
+      PeriodTorusHigherHomology.realTorusH4Equiv
+        (MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy i) 4 a) :=
+  rfl
+
+private def ThreefoldHomology.TopDegree.overlapFifthEquiv (i : SpecialPeriods.Threefold.Puncture) :
+    SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) 5 ≃ₗ[ℤ]
+      ℤ :=
+  (ThreefoldOverlapMappingTorus.overlapHomologyEquiv i 5).trans (boundaryFifthEquiv i)
+
+@[simp]
+private theorem ThreefoldHomology.TopDegree.overlapFifthEquiv_apply
+    (i : SpecialPeriods.Threefold.Puncture)
+    (a : SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) 5) :
+    overlapFifthEquiv i a =
+      boundaryFifthEquiv i (ThreefoldOverlapMappingTorus.overlapHomologyEquiv i 5 a) :=
+  LinearEquiv.trans_apply a
+
+private def ThreefoldHomology.TopDegree.regularFifthEquiv :
+    SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily 5 ≃ₗ[ℤ]
+      (ℤ × ℤ) :=
+  PeriodFamily.Homology.familyH5ProductEquiv
+    (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+      SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+
+@[simp]
+private theorem ThreefoldHomology.TopDegree.regularFifthEquiv_apply
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily 5) :
+    regularFifthEquiv a =
+      (PeriodTorusHigherHomology.realTorusH4Equiv
+          (PeriodFamily.Homology.sourceKernelProjection
+                (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                  SpecialPeriods.specialPeriodMap_generator₁
+                  SpecialPeriods.specialPeriodMap_generator₂)
+                4 a).val.1,
+        PeriodTorusHigherHomology.realTorusH4Equiv
+          (PeriodFamily.Homology.sourceKernelProjection
+                (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                  SpecialPeriods.specialPeriodMap_generator₁
+                  SpecialPeriods.specialPeriodMap_generator₂)
+                4 a).val.2) :=
+  rfl
+
+private def
+    ThreefoldHomology.TopDegree.ellipticFifthCoordinates : EllipticOverlapFifth ≃ₗ[ℤ] (ℤ × ℤ) :=
+  ({    toFun := fun a =>
+          (overlapFifthEquiv (Option.some .three) (a .three),
+            overlapFifthEquiv (Option.some .four) (a .four))
+        invFun := fun a j =>
+          match j with
+          | .three => (overlapFifthEquiv (Option.some .three)).symm a.1
+          | .four => (overlapFifthEquiv (Option.some .four)).symm a.2
+        left_inv := by
+          intro a
+          funext j
+          cases j <;> exact LinearEquiv.symm_apply_apply _ _
+        right_inv := fun a =>
+          Prod.ext (LinearEquiv.apply_symm_apply _ a.1) (LinearEquiv.apply_symm_apply _ a.2)
+        map_add' := fun a b => Prod.ext (map_add _ _ _) (map_add _ _ _) } :
+      EllipticOverlapFifth ≃+ (ℤ × ℤ)).toIntLinearEquiv
+
+@[simp]
+private theorem
+    ThreefoldHomology.TopDegree.ellipticFifthCoordinates_apply (a : EllipticOverlapFifth) :
+    ellipticFifthCoordinates a =
+      (overlapFifthEquiv (Option.some .three) (a .three),
+        overlapFifthEquiv (Option.some .four) (a .four)) :=
+  rfl
+
+private theorem ThreefoldHomology.TopDegree.boundaryThree_fifth_column
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (ThreefoldOverlapMappingTorus.Boundary (Option.some .three)) 5) :
+    regularFifthEquiv
+        (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some .three) 5 a) =
+      (boundaryFifthEquiv (Option.some .three) a, 0) := by
+  rw [regularFifthEquiv_apply, boundaryFifthEquiv_apply]
+  have h :=
+    congrArg
+      (fun p :
+          SingularMayerVietoris.SingularHomology RealTorus₄ 4 ×
+            SingularMayerVietoris.SingularHomology RealTorus₄ 4 =>
+        (PeriodTorusHigherHomology.realTorusH4Equiv p.1,
+          PeriodTorusHigherHomology.realTorusH4Equiv p.2))
+      (PeriodFamily.Boundary.ellipticThreeBoundary_sourceKernelProjection 4 a)
+  simpa only [map_zero, ThreefoldOverlapMappingTorus.monodromy] using! h
+
+private theorem ThreefoldHomology.TopDegree.boundaryFour_fifth_column
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (ThreefoldOverlapMappingTorus.Boundary (Option.some .four)) 5) :
+    regularFifthEquiv
+        (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some .four) 5 a) =
+      (0, boundaryFifthEquiv (Option.some .four) a) := by
+  rw [regularFifthEquiv_apply, boundaryFifthEquiv_apply]
+  have h :=
+    congrArg
+      (fun p :
+          SingularMayerVietoris.SingularHomology RealTorus₄ 4 ×
+            SingularMayerVietoris.SingularHomology RealTorus₄ 4 =>
+        (PeriodTorusHigherHomology.realTorusH4Equiv p.1,
+          PeriodTorusHigherHomology.realTorusH4Equiv p.2))
+      (PeriodFamily.Boundary.ellipticFourBoundary_sourceKernelProjection 4 a)
+  simpa only [map_zero, ThreefoldOverlapMappingTorus.monodromy] using! h
+
+private theorem ThreefoldHomology.TopDegree.overlapThree_fifth_column
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.Threefold.RegularOverlap (Option.some .three)) 5) :
+    regularFifthEquiv
+        (SingularMayerVietoris.singularHomologyMap
+          (ThreefoldHomology.overlapToRegularFamily (Option.some .three)) 5 a) =
+      (overlapFifthEquiv (Option.some .three) a, 0) := by
+  have h :=
+    LinearMap.congr_fun
+      (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap_retraction (Option.some .three) 5)
+      a
+  change
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some .three) 5
+        (ThreefoldOverlapMappingTorus.overlapHomologyEquiv (Option.some .three) 5 a) =
+      SingularMayerVietoris.singularHomologyMap
+        (ThreefoldHomology.overlapToRegularFamily (Option.some .three)) 5 a at h
+  rw [overlapFifthEquiv_apply, ← h]
+  exact boundaryThree_fifth_column _
+
+private theorem ThreefoldHomology.TopDegree.overlapFour_fifth_column
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.Threefold.RegularOverlap (Option.some .four)) 5) :
+    regularFifthEquiv
+        (SingularMayerVietoris.singularHomologyMap
+          (ThreefoldHomology.overlapToRegularFamily (Option.some .four)) 5 a) =
+      (0, overlapFifthEquiv (Option.some .four) a) := by
+  have h :=
+    LinearMap.congr_fun
+      (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap_retraction (Option.some .four) 5) a
+  change
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some .four) 5
+        (ThreefoldOverlapMappingTorus.overlapHomologyEquiv (Option.some .four) 5 a) =
+      SingularMayerVietoris.singularHomologyMap
+        (ThreefoldHomology.overlapToRegularFamily (Option.some .four)) 5 a at h
+  rw [overlapFifthEquiv_apply, ← h]
+  exact boundaryFour_fifth_column _
+
+private theorem ThreefoldHomology.TopDegree.ellipticAttachmentFifth_coordinates
+    (a : EllipticOverlapFifth) :
+    regularFifthEquiv (ellipticAttachmentFifth a) = ellipticFifthCoordinates a := by
+  classical
+  rw [ellipticAttachmentFifth_apply, map_sum]
+  have hu : (Finset.univ : Finset Elliptic.Kind) = {.three, .four} := by
+    ext j
+    cases j <;> simp
+  rw [hu, Finset.sum_pair (by decide : Elliptic.Kind.three ≠ .four), overlapThree_fifth_column,
+    overlapFour_fifth_column, ellipticFifthCoordinates_apply]
+  exact Prod.ext (add_zero _) (zero_add _)
+
+private def ThreefoldHomology.TopDegree.ellipticAttachmentFifthEquiv :
+    EllipticOverlapFifth ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily 5 :=
+  ellipticFifthCoordinates.trans regularFifthEquiv.symm
+
+private theorem ThreefoldHomology.TopDegree.ellipticAttachmentFifthEquiv_toLinearMap :
+    ellipticAttachmentFifthEquiv.toLinearMap = ellipticAttachmentFifth := by
+  apply LinearMap.ext
+  intro a
+  apply regularFifthEquiv.injective
+  change regularFifthEquiv (regularFifthEquiv.symm (ellipticFifthCoordinates a)) = _
+  rw [LinearEquiv.apply_symm_apply, ellipticAttachmentFifth_coordinates]
+
+public
+theorem
+    ThreefoldHomologyTopDegreeAlgebra.surjective_of_columnIso {A B D : Type*} [AddCommGroup A]
+    [AddCommGroup B] [AddCommGroup D] [Module ℤ A] [Module ℤ B] [Module ℤ D] [Module ℤ (A × B)]
+    (F : (A × B) →ₗ[ℤ] D) (f : A →ₗ[ℤ] D) (e : B ≃ₗ[ℤ] D) (hF : ∀ a b, F (a, b) = f a + e b) :
+    Function.Surjective F := by
+  intro d
+  refine ⟨(0, e.symm d), ?_⟩
+  rw [hF, map_zero, LinearEquiv.apply_symm_apply, zero_add]
+
+private def ThreefoldHomologyTopDegreeAlgebra.kernelProjectionAddEquiv_mo1973_30150
+    {A B D : Type*} [AddCommGroup A] [AddCommGroup B] [AddCommGroup D] [Module ℤ A] [Module ℤ B]
+    [Module ℤ D] [Module ℤ (A × B)] (F : (A × B) →ₗ[ℤ] D) (f : A →ₗ[ℤ] D) (e : B ≃ₗ[ℤ] D)
+    (hF : ∀ a b, F (a, b) = f a + e b) : LinearMap.ker F ≃+ A
+    where
+  toFun x := x.val.1
+  invFun
+    a :=
+    ⟨(a, -e.symm (f a)), by
+      change F (a, -e.symm (f a)) = 0
+      rw [hF, map_neg, LinearEquiv.apply_symm_apply, add_neg_cancel]⟩
+  left_inv
+    x := by
+    apply Subtype.ext
+    change (x.val.1, -e.symm (f x.val.1)) = x.val
+    refine Prod.ext (by rfl) ?_
+    apply e.injective
+    change e (-e.symm (f x.val.1)) = e x.val.2
+    rw [map_neg, LinearEquiv.apply_symm_apply]
+    have hx : f x.val.1 + e x.val.2 = 0 := (hF x.val.1 x.val.2).symm.trans x.property
+    calc
+      -f x.val.1 = -f x.val.1 + 0 := (add_zero _).symm
+      _ = -f x.val.1 + (f x.val.1 + e x.val.2) := (congrArg (fun d => -f x.val.1 + d) hx.symm)
+      _ = e x.val.2 := by rw [← add_assoc, neg_add_cancel, zero_add]
+  right_inv _ := rfl
+  map_add' _ _ := rfl
+
+private def
+    ThreefoldHomologyTopDegreeAlgebra.kernelEquivOfColumnIso {A B D : Type*} [AddCommGroup A]
+    [AddCommGroup B] [AddCommGroup D] [Module ℤ A] [Module ℤ B] [Module ℤ D] [Module ℤ (A × B)]
+    (F : (A × B) →ₗ[ℤ] D) (f : A →ₗ[ℤ] D) (e : B ≃ₗ[ℤ] D) (hF : ∀ a b, F (a, b) = f a + e b)
+    [Module ℤ (LinearMap.ker F)] : LinearMap.ker F ≃ₗ[ℤ] A :=
+  (kernelProjectionAddEquiv_mo1973_30150 F f e hF).toIntLinearEquiv
+
+private theorem ThreefoldHomology.TopDegree.groupedAttachmentFifth_columnIso
+    (a :
+      SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap Option.none)
+        5)
+    (b : EllipticOverlapFifth) :
+    groupedAttachmentFifth (a, b) =
+      SingularMayerVietoris.singularHomologyMap
+          (ThreefoldHomology.overlapToRegularFamily Option.none) 5 a +
+        ellipticAttachmentFifthEquiv b := by
+  change
+    groupedAttachmentFifth (a, b) =
+      SingularMayerVietoris.singularHomologyMap
+          (ThreefoldHomology.overlapToRegularFamily Option.none) 5 a +
+        ellipticAttachmentFifthEquiv.toLinearMap b
+  rw [ellipticAttachmentFifthEquiv_toLinearMap, groupedAttachmentFifth_apply]
+
+private def ThreefoldHomology.TopDegree.homologySixCuspEquiv :
+    SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 6 ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap Option.none)
+        5 :=
+  (homologySixGroupedKernelEquiv.toAddEquiv.trans
+      (ThreefoldHomologyTopDegreeAlgebra.kernelEquivOfColumnIso groupedAttachmentFifth
+          (SingularMayerVietoris.singularHomologyMap
+            (ThreefoldHomology.overlapToRegularFamily Option.none) 5)
+          ellipticAttachmentFifthEquiv
+          groupedAttachmentFifth_columnIso).toAddEquiv).toIntLinearEquiv
+
+@[simp]
+private theorem ThreefoldHomology.TopDegree.homologySixCuspEquiv_apply
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 6) :
+    homologySixCuspEquiv a = ThreefoldHomology.starConnectingHomomorphism 5 a Option.none := by
+  change
+    (homologySixGroupedKernelEquiv a :
+          SingularMayerVietoris.SingularHomology
+              (SpecialPeriods.Threefold.RegularOverlap Option.none) 5 ×
+            EllipticOverlapFifth).1 =
+      _
+  rw [homologySixGroupedKernelEquiv_val]
+
+private def ThreefoldHomology.TopDegree.homologySixEquiv :
+    SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 6 ≃ₗ[ℤ] ℤ :=
+  homologySixCuspEquiv.trans (overlapFifthEquiv Option.none)
+
+@[simp]
+private theorem ThreefoldHomology.TopDegree.homologySixEquiv_apply
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 6) :
+    homologySixEquiv a =
+      overlapFifthEquiv Option.none
+        (ThreefoldHomology.starConnectingHomomorphism 5 a Option.none) := by
+  change overlapFifthEquiv Option.none (homologySixCuspEquiv a) = _
+  rw [homologySixCuspEquiv_apply]
+
+private def ThreefoldHomology.TopDegree.topClass :
+    SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 6 :=
+  homologySixEquiv.symm 1
+
+private theorem
+    ThreefoldHomology.TopDegree.homologySixEquiv_topClass : homologySixEquiv topClass = 1 :=
+  LinearEquiv.apply_symm_apply _ _
+
+private theorem ThreefoldHomology.TopDegree.eq_smul_topClass
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 6) :
+    a = homologySixEquiv a • topClass := by
+  apply homologySixEquiv.injective
+  rw [map_zsmul, homologySixEquiv_topClass]
+  simp
+
+private theorem ThreefoldHomology.FifthDegree.regularAttachment_five_surjective :
+    Function.Surjective (ThreefoldHomology.starOverlapToRegularHomologyMap 5) := by
+  have hs :=
+    ThreefoldHomologyTopDegreeAlgebra.surjective_of_columnIso
+      ThreefoldHomology.TopDegree.groupedAttachmentFifth
+      (SingularMayerVietoris.singularHomologyMap
+        (ThreefoldHomology.overlapToRegularFamily Option.none) 5)
+      ThreefoldHomology.TopDegree.ellipticAttachmentFifthEquiv
+      ThreefoldHomology.TopDegree.groupedAttachmentFifth_columnIso
+  intro a
+  obtain ⟨b, hb⟩ := hs a
+  exact ⟨ThreefoldHomology.TopDegree.groupedOverlapFifthEquiv.symm b, hb⟩
+
+private theorem ThreefoldHomology.FifthDegree.starLeft_five_surjective :
+    Function.Surjective (ThreefoldHomology.starLeftHomologyMap 5) := by
+  have := ThreefoldHomology.Finiteness.starFillingHomology_subsingleton (by decide : 4 < 5)
+  intro a
+  obtain ⟨b, hb⟩ := regularAttachment_five_surjective a.1
+  refine ⟨b, ?_⟩
+  apply Prod.ext
+  · exact hb
+  · exact Subsingleton.elim _ _
+
+private theorem ThreefoldHomology.FifthDegree.starRight_five_eq_zero :
+    ThreefoldHomology.starRightHomologyMap 5 = 0 := by
+  apply LinearMap.ext
+  intro a
+  obtain ⟨b, rfl⟩ := starLeft_five_surjective a
+  exact (ThreefoldHomology.star_exact_at_pair 5).apply_apply_eq_zero b
+
+private theorem ThreefoldHomology.FifthDegree.connecting_four_injective :
+    Function.Injective (ThreefoldHomology.starConnectingHomomorphism 4) := by
+  intro a b hab
+  have hz : ThreefoldHomology.starConnectingHomomorphism 4 (a - b) = 0 := by
+    rw [map_sub, hab, sub_self]
+  obtain ⟨c, hc⟩ := (ThreefoldHomology.star_exact_at_ambient 4 (a - b)).mp hz
+  rw [starRight_five_eq_zero, LinearMap.zero_apply] at hc
+  exact sub_eq_zero.mp hc.symm
+
+private theorem ThreefoldHomologyCuspFibre.fibreToFilling_four_bijective :
+    Function.Bijective
+      (SingularMayerVietoris.singularHomologyMap
+        (ThreefoldOverlapMappingTorus.fibreToFilling Option.none) 4) := by
+  have := PeriodTorusHigherHomology.realTorus_homology_free 4
+  have := PeriodTorusHigherHomology.realTorus_homology_finite 4
+  have :
+    Module.Free ℤ
+      (SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.Threefold.localPiece (Option.some Option.none)) 4) :=
+    ThreefoldHomologyFinitenessCusp.fullHomology_free
+      ThreefoldOverlapMappingTorus.Cusp.specialData 4
+  have :
+    Module.Finite ℤ
+      (SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.Threefold.localPiece (Option.some Option.none)) 4) :=
+    ThreefoldHomologyFinitenessCusp.fullHomology_finite
+      ThreefoldOverlapMappingTorus.Cusp.specialData 4
+  have hcap :
+    Module.finrank ℤ
+        (SingularMayerVietoris.SingularHomology
+          (SpecialPeriods.Threefold.localPiece (Option.some Option.none)) 4) =
+      1 :=
+    ThreefoldHomologyFinitenessCusp.fullHomology_finrank
+      ThreefoldOverlapMappingTorus.Cusp.specialData 4
+  apply
+    OrzechProperty.bijective_of_surjective_of_finrank_le
+      (SingularMayerVietoris.singularHomologyMap
+        (ThreefoldOverlapMappingTorus.fibreToFilling Option.none) 4)
+      (fibreToFilling_homology_surjective 4)
+  rw [PeriodTorusHigherHomology.realTorus_homology_finrank, hcap]
+  decide
+
+private def ThreefoldHomologyCuspFibre.cuspFibreFourEquiv :
+    SingularMayerVietoris.SingularHomology RealTorus₄ 4 ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology
+        (SpecialPeriods.Threefold.localPiece (Option.some Option.none)) 4 :=
+  LinearEquiv.ofBijective
+    (SingularMayerVietoris.singularHomologyMap
+      (ThreefoldOverlapMappingTorus.fibreToFilling Option.none) 4)
+    fibreToFilling_four_bijective
+
+private theorem ThreefoldHomologyCuspFibre.cuspCap_four_fibre
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 4) :
+    ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none 4
+        (MappingTorusHomology.fibreHomologyMap (ThreefoldOverlapMappingTorus.monodromy none) 4
+          a) =
+      cuspFibreFourEquiv a :=
+  LinearMap.congr_fun
+    (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap_fibre Option.none 4) a
+
+private theorem ThreefoldHomologyCuspFibre.cuspCap_wang_four_eq_zero
+    (a :
+      SingularMayerVietoris.SingularHomology (ThreefoldOverlapMappingTorus.Boundary Option.none)
+        4)
+    (hcap : ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none 4 a = 0)
+    (hwang :
+      MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy none) 3 a = 0) :
+    a = 0 := by
+  have ha :
+    a ∈
+      LinearMap.range
+        (MappingTorusHomology.fibreHomologyMap (ThreefoldOverlapMappingTorus.monodromy none) 4) :=
+    by
+    rw [MappingTorusHomology.wang_exact_at_mappingTorus
+        (ThreefoldOverlapMappingTorus.monodromy none) 3]
+    exact hwang
+  obtain ⟨b, hb⟩ := ha
+  have hb0 : cuspFibreFourEquiv b = 0 :=
+    (cuspCap_four_fibre b).symm.trans
+      ((congrArg (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none 4) hb).trans
+        hcap)
+  have hb' : b = 0 := cuspFibreFourEquiv.injective (hb0.trans cuspFibreFourEquiv.map_zero.symm)
+  rw [hb', map_zero] at hb
+  exact hb.symm
+
+private theorem ThreefoldHomology.FourthWang.overlap_wang_coordinates
+    (a : ThreefoldHomology.StarOverlapHomology 4)
+    (ha : ThreefoldHomology.starOverlapToRegularHomologyMap 4 a = 0)
+    (i : SpecialPeriods.Threefold.Puncture) :
+    PeriodFamily.FlatTorus.singularH3Coordinates (overlapWangHomologyMap i 3 (a i)) =
+      Pi.single 3
+        (PeriodFamily.FlatTorus.singularH3Coordinates
+          (overlapWangHomologyMap Option.none 3 (a Option.none)) 3) := by
+  have h := wang_cancellation 3 a ha
+  have hc :=
+    (commonThirdInvariant_iff (overlapWangHomologyMap Option.none 3 (a Option.none))).mp
+      ⟨h.2.2.1, h.2.2.2⟩
+  cases i with
+  | none => exact hc
+  | some j =>
+    cases j with
+    | three => rw [h.1]; exact hc
+    | four => rw [h.2.1]; exact hc
+
+private def ThreefoldHomology.FourthWang.fifthWangCoordinate :
+    SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 5 →ₗ[ℤ] ℤ :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun := fun a =>
+        PeriodFamily.FlatTorus.singularH3Coordinates
+          (overlapWangHomologyMap Option.none 3
+            (ThreefoldHomology.starConnectingHomomorphism 4 a Option.none))
+          3
+      map_zero' := by simp only [map_zero, Pi.zero_apply]
+      map_add' := by intro a b; simp only [map_add, Pi.add_apply] }
+
+private theorem ThreefoldHomology.FourthWang.connecting_four_regular_zero
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 5) :
+    ThreefoldHomology.starOverlapToRegularHomologyMap 4
+        (ThreefoldHomology.starConnectingHomomorphism 4 a) =
+      0 :=
+  congrArg Prod.fst ((ThreefoldHomology.star_exact_at_intersection 4).apply_apply_eq_zero a)
+
+private theorem ThreefoldHomology.FourthWang.connecting_four_cap_zero
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 5)
+    (i : SpecialPeriods.Threefold.Puncture) :
+    SingularMayerVietoris.singularHomologyMap (ThreefoldHomology.overlapToFilling i) 4
+        (ThreefoldHomology.starConnectingHomomorphism 4 a i) =
+      0 := by
+  have h :=
+    congrFun
+      (congrArg Prod.snd ((ThreefoldHomology.star_exact_at_intersection 4).apply_apply_eq_zero a))
+      i
+  exact neg_eq_zero.mp h
+
+private theorem ThreefoldHomology.FourthWang.fifthWangCoordinate_coordinates
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 5)
+    (i : SpecialPeriods.Threefold.Puncture) :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (overlapWangHomologyMap i 3 (ThreefoldHomology.starConnectingHomomorphism 4 a i)) =
+      Pi.single 3 (fifthWangCoordinate a) :=
+  overlap_wang_coordinates (ThreefoldHomology.starConnectingHomomorphism 4 a)
+    (connecting_four_regular_zero a) i
+
+private theorem ThreefoldHomology.FourthWang.fifthWangCoordinate_eq_zero
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 5)
+    (ha : fifthWangCoordinate a = 0) : a = 0 := by
+  have hw (i : SpecialPeriods.Threefold.Puncture) :
+    overlapWangHomologyMap i 3 (ThreefoldHomology.starConnectingHomomorphism 4 a i) = 0 := by
+    apply PeriodFamily.FlatTorus.singularH3Coordinates.injective
+    rw [fifthWangCoordinate_coordinates, ha, map_zero]
+    simp
+  have hd : ThreefoldHomology.starConnectingHomomorphism 4 a = 0 := by
+    funext i
+    cases i with
+    |
+      none =>
+      apply (ThreefoldOverlapMappingTorus.overlapHomologyEquiv Option.none 4).injective
+      rw [Pi.zero_apply, map_zero]
+      apply ThreefoldHomologyCuspFibre.cuspCap_wang_four_eq_zero
+      · have h :=
+          LinearMap.congr_fun
+            (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap_retraction Option.none 4)
+            (ThreefoldHomology.starConnectingHomomorphism 4 a Option.none)
+        change
+          ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none 4
+              (ThreefoldOverlapMappingTorus.overlapHomologyEquiv Option.none 4
+                (ThreefoldHomology.starConnectingHomomorphism 4 a Option.none)) =
+            SingularMayerVietoris.singularHomologyMap
+              (ThreefoldHomology.overlapToFilling Option.none) 4
+              (ThreefoldHomology.starConnectingHomomorphism 4 a Option.none) at h
+        exact h.trans (connecting_four_cap_zero a Option.none)
+      · exact hw Option.none
+    | some j =>
+      exact
+        ThreefoldHomology.EllipticFibre.overlapFilling_wang_eq_zero j 3 _
+          (connecting_four_cap_zero a (Option.some j)) (hw (Option.some j))
+  apply ThreefoldHomology.FifthDegree.connecting_four_injective
+  rw [hd, map_zero]
+
+private def ThreefoldHomology.FifthDegree.nativeFifthBoundary
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 5)
+    (i : SpecialPeriods.Threefold.Puncture) :
+    SingularMayerVietoris.SingularHomology (ThreefoldOverlapMappingTorus.Boundary i) 4 :=
+  ThreefoldOverlapMappingTorus.overlapHomologyEquiv i 4
+    (ThreefoldHomology.starConnectingHomomorphism 4 a i)
+
+private theorem ThreefoldHomology.FifthDegree.nativeFifthBoundary_wang_coordinates
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 5)
+    (i : SpecialPeriods.Threefold.Puncture) :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy i) 3
+          (nativeFifthBoundary a i)) =
+      Pi.single 3 (ThreefoldHomology.FourthWang.fifthWangCoordinate a) :=
+  ThreefoldHomology.FourthWang.fifthWangCoordinate_coordinates a i
+
+private theorem ThreefoldHomology.FifthDegree.nativeFifthBoundary_cap_zero
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 5)
+    (i : SpecialPeriods.Threefold.Puncture) :
+    ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap i 4 (nativeFifthBoundary a i) = 0 := by
+  have h :=
+    LinearMap.congr_fun (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap_retraction i 4)
+      (ThreefoldHomology.starConnectingHomomorphism 4 a i)
+  exact h.trans (ThreefoldHomology.FourthWang.connecting_four_cap_zero a i)
+
+private theorem ThreefoldHomology.FifthDegree.nativeFifthBoundary_regular_sum_zero
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 5) :
+    (∑ i : SpecialPeriods.Threefold.Puncture,
+        ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap i 4 (nativeFifthBoundary a i)) =
+      0 := by
+  calc
+    _ =
+        ∑ i : SpecialPeriods.Threefold.Puncture,
+          SingularMayerVietoris.singularHomologyMap (ThreefoldHomology.overlapToRegularFamily i) 4
+            (ThreefoldHomology.starConnectingHomomorphism 4 a i) := by
+      apply Finset.sum_congr rfl
+      intro i _
+      exact
+        LinearMap.congr_fun
+          (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap_retraction i 4) _
+    _ = 0 := ThreefoldHomology.FourthWang.connecting_four_regular_zero a
+
+private def ThreefoldHomology.FifthDegree.fifthReferenceBoundary :
+    (i : SpecialPeriods.Threefold.Puncture) →
+      SingularMayerVietoris.SingularHomology (ThreefoldOverlapMappingTorus.Boundary i) 4
+  | none => CuspBoundaryGammaZero.nativeClass
+  | some j => -PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass j
+
+@[simp]
+private theorem ThreefoldHomology.FifthDegree.fifthReferenceBoundary_cusp :
+    fifthReferenceBoundary Option.none = CuspBoundaryGammaZero.nativeClass :=
+  rfl
+
+private theorem ThreefoldHomology.FifthDegree.fifthReferenceBoundary_wang_coordinates
+    (i : SpecialPeriods.Threefold.Puncture) :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy i) 3
+          (fifthReferenceBoundary i)) =
+      Pi.single (3 : Fin 4) 1 := by
+  cases i with
+  | none => exact CuspBoundaryGammaZero.nativeClass_wang_coordinates
+  | some
+    j =>
+    change
+      PeriodFamily.FlatTorus.singularH3Coordinates
+          (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) 3
+            (-PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass j)) =
+        _
+    rw [map_neg, map_neg, PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass_wang,
+      neg_neg]
+
+private theorem ThreefoldHomology.FifthDegree.nativeFifthBoundary_sub_reference_wang_zero
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 5)
+    (i : SpecialPeriods.Threefold.Puncture) :
+    MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy i) 3
+        (nativeFifthBoundary a i -
+          ThreefoldHomology.FourthWang.fifthWangCoordinate a • fifthReferenceBoundary i) =
+      0 := by
+  apply PeriodFamily.FlatTorus.singularH3Coordinates.injective
+  rw [map_sub, map_zsmul, map_sub, map_zsmul, nativeFifthBoundary_wang_coordinates,
+    fifthReferenceBoundary_wang_coordinates, map_zero]
+  ext j
+  by_cases hj : j = 3
+  · subst j
+    simp
+  · simp [Pi.single_eq_of_ne hj]
+
+private theorem ThreefoldHomology.FifthDegree.exists_fifth_boundary_fibres
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 5) :
+    ∃ b : SpecialPeriods.Threefold.Puncture → SingularMayerVietoris.SingularHomology RealTorus₄ 4,
+      ∀ i,
+        MappingTorusHomology.fibreHomologyMap (ThreefoldOverlapMappingTorus.monodromy i) 4 (b i) =
+          nativeFifthBoundary a i -
+            ThreefoldHomology.FourthWang.fifthWangCoordinate a • fifthReferenceBoundary i := by
+  have h (i : SpecialPeriods.Threefold.Puncture) :
+    nativeFifthBoundary a i -
+        ThreefoldHomology.FourthWang.fifthWangCoordinate a • fifthReferenceBoundary i ∈
+      LinearMap.range
+        (MappingTorusHomology.fibreHomologyMap (ThreefoldOverlapMappingTorus.monodromy i) 4) := by
+    rw [MappingTorusHomology.wang_exact_at_mappingTorus (ThreefoldOverlapMappingTorus.monodromy i)
+        3]
+    exact nativeFifthBoundary_sub_reference_wang_zero a i
+  choose b hb using h
+  exact ⟨b, hb⟩
+
+private def ThreefoldHomology.FifthDegree.cuspResidualCoefficient : ℤ :=
+  PeriodTorusHigherHomology.realTorusH4Equiv
+    (ThreefoldHomologyCuspFibre.cuspFibreFourEquiv.symm
+      (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none 4
+        CuspBoundaryGammaZero.nativeClass))
+
+private theorem ThreefoldHomology.FifthDegree.cuspFibre_coordinate_of_decomposition
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 5)
+    (b : SingularMayerVietoris.SingularHomology RealTorus₄ 4)
+    (hb :
+      MappingTorusHomology.fibreHomologyMap (ThreefoldOverlapMappingTorus.monodromy Option.none) 4
+          b =
+        nativeFifthBoundary a Option.none -
+          ThreefoldHomology.FourthWang.fifthWangCoordinate a •
+            fifthReferenceBoundary Option.none) :
+    PeriodTorusHigherHomology.realTorusH4Equiv b =
+      -(ThreefoldHomology.FourthWang.fifthWangCoordinate a * cuspResidualCoefficient) := by
+  have h := congrArg (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none 4) hb
+  rw [ThreefoldHomologyCuspFibre.cuspCap_four_fibre, map_sub, map_zsmul,
+    nativeFifthBoundary_cap_zero, fifthReferenceBoundary_cusp, zero_sub] at h
+  have hc :=
+    congrArg
+      (fun x =>
+        PeriodTorusHigherHomology.realTorusH4Equiv
+          (ThreefoldHomologyCuspFibre.cuspFibreFourEquiv.symm x))
+      h
+  simpa only [LinearEquiv.symm_apply_apply, map_neg, map_zsmul, smul_eq_mul,
+    cuspResidualCoefficient] using hc
+
+private theorem ThreefoldHomology.FifthDegree.ellipticFibre_coordinate_of_decomposition
+    (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 5)
+    (b : SingularMayerVietoris.SingularHomology RealTorus₄ 4)
+    (hb :
+      MappingTorusHomology.fibreHomologyMap
+          (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) 4 b =
+        nativeFifthBoundary a (Option.some j) -
+          ThreefoldHomology.FourthWang.fifthWangCoordinate a •
+            fifthReferenceBoundary (Option.some j)) :
+    (j.order : ℤ) * γ j.twist * PeriodTorusHigherHomology.realTorusH4Equiv b =
+      ThreefoldHomology.FourthWang.fifthWangCoordinate a := by
+  let c :
+    SingularMayerVietoris.SingularHomology (ThreefoldOverlapMappingTorus.Boundary (Option.some j))
+        4 →ₗ[ℤ]
+      ℤ :=
+    (Elliptic.HigherHomology.surfaceH4Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).toLinearMap.comp
+      ((ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j 4).toLinearMap.comp
+        (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) 4))
+  have hunit : c (PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass j) = 1 :=
+    PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass_filling j
+  have href : c (fifthReferenceBoundary (Option.some j)) = -1 :=
+    (map_neg c (PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass j)).trans
+      (congrArg Neg.neg hunit)
+  have hzero : c (nativeFifthBoundary a (Option.some j)) = 0 := by
+    change
+      Elliptic.HigherHomology.surfaceH4Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+          (ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j 4
+            (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) 4
+              (nativeFifthBoundary a (Option.some j)))) =
+        0
+    rw [nativeFifthBoundary_cap_zero, map_zero, map_zero]
+  have hfibre :
+    c
+        (MappingTorusHomology.fibreHomologyMap
+          (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) 4 b) =
+      (j.order : ℤ) * γ j.twist * PeriodTorusHigherHomology.realTorusH4Equiv b :=
+    PeriodFamily.Boundary.EllipticTopFibre.boundaryFilling_fibre_h4_coordinates j b
+  have h := congrArg c hb
+  rw [hfibre, map_sub, map_zsmul, hzero, href] at h
+  simpa using h
+
+private theorem ThreefoldHomology.FifthDegree.threeFibre_coordinate_of_decomposition
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 5)
+    (b : SingularMayerVietoris.SingularHomology RealTorus₄ 4)
+    (hb :
+      MappingTorusHomology.fibreHomologyMap
+          (ThreefoldOverlapMappingTorus.monodromy (Option.some Elliptic.Kind.three)) 4 b =
+        nativeFifthBoundary a (Option.some .three) -
+          ThreefoldHomology.FourthWang.fifthWangCoordinate a •
+            fifthReferenceBoundary (Option.some .three)) :
+    3 * PeriodTorusHigherHomology.realTorusH4Equiv b =
+      ThreefoldHomology.FourthWang.fifthWangCoordinate a := by
+  simpa [Elliptic.Kind.order, Elliptic.Kind.twist, γ, ε] using
+    ellipticFibre_coordinate_of_decomposition .three a b hb
+
+private theorem ThreefoldHomology.FifthDegree.fourFibre_coordinate_of_decomposition
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 5)
+    (b : SingularMayerVietoris.SingularHomology RealTorus₄ 4)
+    (hb :
+      MappingTorusHomology.fibreHomologyMap
+          (ThreefoldOverlapMappingTorus.monodromy (Option.some Elliptic.Kind.four)) 4 b =
+        nativeFifthBoundary a (Option.some .four) -
+          ThreefoldHomology.FourthWang.fifthWangCoordinate a •
+            fifthReferenceBoundary (Option.some .four)) :
+    -4 * PeriodTorusHigherHomology.realTorusH4Equiv b =
+      ThreefoldHomology.FourthWang.fifthWangCoordinate a := by
+  simpa [Elliptic.Kind.order, Elliptic.Kind.twist, γ, ε'] using
+    ellipticFibre_coordinate_of_decomposition .four a b hb
+
+private theorem ThreefoldHomology.FifthDegree.fifthReferenceBoundary_regular_sum_zero :
+    (∑ i : SpecialPeriods.Threefold.Puncture,
+        ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap i 4 (fifthReferenceBoundary i)) =
+      0 := by
+  classical
+  have he (j : Elliptic.Kind) :
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some j) 4
+        (fifthReferenceBoundary (Option.some j)) =
+      -ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some j) 4
+          (PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass j) :=
+    map_neg (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some j) 4)
+      (PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass j)
+  rw [Fintype.sum_option]
+  have hu : (Finset.univ : Finset Elliptic.Kind) = {.three, .four} := by
+    ext j
+    cases j <;> simp
+  rw [hu, Finset.sum_pair (by decide : Elliptic.Kind.three ≠ .four)]
+  rw [fifthReferenceBoundary_cusp, he, he]
+  rw [PeriodFamily.Boundary.FourthRelation.nativeClass_regular_eq_capSections]
+  abel
+
+private theorem ThreefoldHomology.FifthDegree.fifth_boundary_fibres_sum_zero
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 5)
+    (b : SpecialPeriods.Threefold.Puncture → SingularMayerVietoris.SingularHomology RealTorus₄ 4)
+    (hb :
+      ∀ i,
+        MappingTorusHomology.fibreHomologyMap (ThreefoldOverlapMappingTorus.monodromy i) 4 (b i) =
+          nativeFifthBoundary a i -
+            ThreefoldHomology.FourthWang.fifthWangCoordinate a • fifthReferenceBoundary i) :
+    (∑ i : SpecialPeriods.Threefold.Puncture, b i) = 0 := by
+  apply
+    PeriodFamily.Boundary.normalizedFamilyFibreHomologyFour_injective
+      (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+  rw [map_sum, map_zero]
+  calc
+    _ =
+        ∑ i : SpecialPeriods.Threefold.Puncture,
+          ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap i 4
+            (MappingTorusHomology.fibreHomologyMap (ThreefoldOverlapMappingTorus.monodromy i) 4
+              (b i)) := by
+      apply Finset.sum_congr rfl
+      intro i _
+      exact (PeriodFamily.Boundary.boundaryRegularHomologyMap_common_fibre_apply i 4 (b i)).symm
+    _ =
+        ∑ i : SpecialPeriods.Threefold.Puncture,
+          ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap i 4
+            (nativeFifthBoundary a i -
+              ThreefoldHomology.FourthWang.fifthWangCoordinate a • fifthReferenceBoundary i) := by
+      apply Finset.sum_congr rfl
+      intro i _
+      rw [hb i]
+    _ =
+        (∑ i : SpecialPeriods.Threefold.Puncture,
+            ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap i 4
+              (nativeFifthBoundary a i)) -
+          ThreefoldHomology.FourthWang.fifthWangCoordinate a •
+            ∑ i : SpecialPeriods.Threefold.Puncture,
+              ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap i 4
+                (fifthReferenceBoundary i) := by
+      have hs (i : SpecialPeriods.Threefold.Puncture) :
+        ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap i 4
+            (ThreefoldHomology.FourthWang.fifthWangCoordinate a • fifthReferenceBoundary i) =
+          ThreefoldHomology.FourthWang.fifthWangCoordinate a •
+            ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap i 4
+              (fifthReferenceBoundary i) :=
+        map_zsmul (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap i 4)
+          (ThreefoldHomology.FourthWang.fifthWangCoordinate a) (fifthReferenceBoundary i)
+      simp only [map_sub, hs, Finset.sum_sub_distrib]
+      congr 1
+      exact
+        (map_sum
+            (zsmulAddGroupHom (α :=
+              SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily
+                4)
+              (ThreefoldHomology.FourthWang.fifthWangCoordinate a))
+            (fun i : SpecialPeriods.Threefold.Puncture =>
+              ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap i 4
+                (fifthReferenceBoundary i))
+            Finset.univ).symm
+    _ = 0 := by
+      rw [nativeFifthBoundary_regular_sum_zero, fifthReferenceBoundary_regular_sum_zero]
+      have hz :=
+        @zsmul_zero
+          (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily 4)
+          _ (ThreefoldHomology.FourthWang.fifthWangCoordinate a)
+      exact
+        (congrArg
+              (fun x :
+                  SingularMayerVietoris.SingularHomology
+                    SpecialPeriods.Threefold.SpecialRegularFamily 4 =>
+                0 - x)
+              hz).trans
+          (sub_self 0)
+
+private theorem ThreefoldHomology.FifthDegree.fifth_boundary_fibre_coordinates_sum_zero
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 5)
+    (b : SpecialPeriods.Threefold.Puncture → SingularMayerVietoris.SingularHomology RealTorus₄ 4)
+    (hb :
+      ∀ i,
+        MappingTorusHomology.fibreHomologyMap (ThreefoldOverlapMappingTorus.monodromy i) 4 (b i) =
+          nativeFifthBoundary a i -
+            ThreefoldHomology.FourthWang.fifthWangCoordinate a • fifthReferenceBoundary i) :
+    PeriodTorusHigherHomology.realTorusH4Equiv (b (Option.some .three)) +
+          PeriodTorusHigherHomology.realTorusH4Equiv (b (Option.some .four)) +
+        PeriodTorusHigherHomology.realTorusH4Equiv (b Option.none) =
+      0 := by
+  have h :=
+    congrArg PeriodTorusHigherHomology.realTorusH4Equiv (fifth_boundary_fibres_sum_zero a b hb)
+  rw [map_sum, map_zero, Fintype.sum_option] at h
+  have hu : (Finset.univ : Finset Elliptic.Kind) = {.three, .four} := by
+    ext j
+    cases j <;> simp
+  rw [hu, Finset.sum_pair (by decide : Elliptic.Kind.three ≠ .four)] at h
+  omega
+
+private theorem ThreefoldHomology.FifthDegree.fifthWangCoordinate_vanishes
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 5) :
+    ThreefoldHomology.FourthWang.fifthWangCoordinate a = 0 := by
+  obtain ⟨b, hb⟩ := exists_fifth_boundary_fibres a
+  have hthree :=
+    threeFibre_coordinate_of_decomposition a (b (Option.some .three)) (hb (Option.some .three))
+  have hfour :=
+    fourFibre_coordinate_of_decomposition a (b (Option.some .four)) (hb (Option.some .four))
+  have hcusp := cuspFibre_coordinate_of_decomposition a (b Option.none) (hb Option.none)
+  have hsum := fifth_boundary_fibre_coordinates_sum_zero a b hb
+  have hregular :
+    PeriodTorusHigherHomology.realTorusH4Equiv (b (Option.some .three)) +
+        PeriodTorusHigherHomology.realTorusH4Equiv (b (Option.some .four)) =
+      cuspResidualCoefficient * ThreefoldHomology.FourthWang.fifthWangCoordinate a := by
+    linear_combination hsum - hcusp
+  exact
+    signed_residual_coordinate_zero (ThreefoldHomology.FourthWang.fifthWangCoordinate a)
+      (PeriodTorusHigherHomology.realTorusH4Equiv (b (Option.some .three)))
+      (PeriodTorusHigherHomology.realTorusH4Equiv (b (Option.some .four))) cuspResidualCoefficient
+      hthree hfour hregular
+
+private theorem ThreefoldHomology.FifthDegree.homologyFive_eq_zero
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 5) : a = 0 :=
+  ThreefoldHomology.FourthWang.fifthWangCoordinate_eq_zero a (fifthWangCoordinate_vanishes a)
+
+private theorem ThreefoldHomology.FifthDegree.homologyFive_subsingleton :
+    Subsingleton (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 5) :=
+  ⟨fun a b => (homologyFive_eq_zero a).trans (homologyFive_eq_zero b).symm⟩
+
+private theorem ThreefoldHomology.FourthDegree.nativeCapKernelRegularMap_four_surjective :
+    Function.Surjective (ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 4) :=
+  ThreefoldHomology.CapElimination.nativeCapKernelRegularMap_surjective_of_fibre_range 3
+    ThreefoldHomology.FourthSource.nativeCapKernelSourceMap_three_surjective
+    ThreefoldHomology.FourthFibre.fibre_range_le
+
+private theorem ThreefoldHomology.FourthDegree.starLeft_four_surjective :
+    Function.Surjective (ThreefoldHomology.starLeftHomologyMap 4) :=
+  ThreefoldHomology.CapElimination.starLeft_surjective_of_nativeCapKernel 4
+    nativeCapKernelRegularMap_four_surjective
+
+private theorem ThreefoldHomology.FourthDegree.starRight_four_eq_zero :
+    ThreefoldHomology.starRightHomologyMap 4 = 0 := by
+  apply LinearMap.ext
+  intro a
+  obtain ⟨b, rfl⟩ := starLeft_four_surjective a
+  exact (ThreefoldHomology.star_exact_at_pair 4).apply_apply_eq_zero b
+
+private theorem ThreefoldHomology.FourthDegree.connecting_three_injective :
+    Function.Injective (ThreefoldHomology.starConnectingHomomorphism 3) := by
+  intro a b hab
+  have hz : ThreefoldHomology.starConnectingHomomorphism 3 (a - b) = 0 := by
+    rw [map_sub, hab, sub_self]
+  obtain ⟨c, hc⟩ := (ThreefoldHomology.star_exact_at_ambient 3 (a - b)).mp hz
+  rw [starRight_four_eq_zero, LinearMap.zero_apply] at hc
+  exact sub_eq_zero.mp hc.symm
+
+private def ThreefoldHomology.FourthDegree.connectingIntoKernel :
+    SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 4 →ₗ[ℤ]
+      LinearMap.ker (ThreefoldHomology.starLeftHomologyMap 3) :=
+  (ThreefoldHomology.starConnectingHomomorphism 3).codRestrict
+    (LinearMap.ker (ThreefoldHomology.starLeftHomologyMap 3))
+    (fun a => (ThreefoldHomology.star_exact_at_intersection 3).apply_apply_eq_zero a)
+
+private theorem ThreefoldHomology.FourthDegree.connectingIntoKernel_bijective :
+    Function.Bijective connectingIntoKernel := by
+  constructor
+  · intro a b hab
+    exact connecting_three_injective (congrArg Subtype.val hab)
+  · intro a
+    obtain ⟨b, hb⟩ := (ThreefoldHomology.star_exact_at_intersection 3 a.val).mp a.property
+    exact ⟨b, Subtype.ext hb⟩
+
+private def ThreefoldHomology.FourthDegree.homologyFourKernelEquiv :
+    SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 4 ≃ₗ[ℤ]
+      LinearMap.ker (ThreefoldHomology.starLeftHomologyMap 3) :=
+  LinearEquiv.ofBijective connectingIntoKernel connectingIntoKernel_bijective
+
+private def ThreefoldHomology.ThirdDegree.starKernelIntoCapKernel (n : ℕ)
+    (a : LinearMap.ker (ThreefoldHomology.starLeftHomologyMap n)) :
+    LinearMap.ker (ThreefoldHomology.starOverlapToFillingsHomologyMap n) :=
+  ⟨a.val,
+    by
+    have h : -ThreefoldHomology.starOverlapToFillingsHomologyMap n a.val = 0 :=
+      congrArg Prod.snd a.property
+    exact neg_eq_zero.mp h⟩
+
+private def ThreefoldHomology.ThirdDegree.starKernelToNative (n : ℕ) :
+    LinearMap.ker (ThreefoldHomology.starLeftHomologyMap n) →ₗ[ℤ]
+      LinearMap.ker (ThreefoldHomology.CapElimination.nativeCapKernelRegularMap n) :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun
+        a :=
+        ⟨ThreefoldHomology.CapElimination.nativeCapKernelEquiv n (starKernelIntoCapKernel n a),
+          by
+          change
+            ThreefoldHomology.CapElimination.nativeCapKernelRegularMap n
+                (ThreefoldHomology.CapElimination.nativeCapKernelEquiv n
+                  (starKernelIntoCapKernel n a)) =
+              0
+          rw [ThreefoldHomology.CapElimination.nativeCapKernelRegularMap_equiv]
+          exact congrArg Prod.fst a.property⟩
+      map_zero' := by
+        apply Subtype.ext
+        exact (ThreefoldHomology.CapElimination.nativeCapKernelEquiv n).map_zero
+      map_add' a
+        b := by
+        apply Subtype.ext
+        exact
+          (ThreefoldHomology.CapElimination.nativeCapKernelEquiv n).map_add
+            (starKernelIntoCapKernel n a) (starKernelIntoCapKernel n b) }
+
+private theorem ThreefoldHomology.ThirdDegree.starKernelToNative_injective (n : ℕ) :
+    Function.Injective (starKernelToNative n) := by
+  intro a b hab
+  apply Subtype.ext
+  have h :=
+    (ThreefoldHomology.CapElimination.nativeCapKernelEquiv n).injective (congrArg Subtype.val hab)
+  exact
+    congrArg
+      (fun c : LinearMap.ker (ThreefoldHomology.starOverlapToFillingsHomologyMap n) => c.val) h
+
+private theorem ThreefoldHomology.ThirdDegree.starKernelToNative_surjective (n : ℕ) :
+    Function.Surjective (starKernelToNative n) := by
+  intro a
+  let b := (ThreefoldHomology.CapElimination.nativeCapKernelEquiv n).symm a.val
+  have hreg : ThreefoldHomology.starOverlapToRegularHomologyMap n b.val = 0 := by
+    have h := ThreefoldHomology.CapElimination.nativeCapKernelRegularMap_equiv n b
+    change
+      ThreefoldHomology.CapElimination.nativeCapKernelRegularMap n
+          (ThreefoldHomology.CapElimination.nativeCapKernelEquiv n
+            ((ThreefoldHomology.CapElimination.nativeCapKernelEquiv n).symm a.val)) =
+        _ at h
+    rw [LinearEquiv.apply_symm_apply] at h
+    exact h.symm.trans a.property
+  refine ⟨⟨b.val, ?_⟩, ?_⟩
+  · change ThreefoldHomology.starLeftHomologyMap n b.val = 0
+    rw [ThreefoldHomology.CapElimination.starLeft_regular_fillings, hreg, b.property, neg_zero]
+    rfl
+  · apply Subtype.ext
+    exact (ThreefoldHomology.CapElimination.nativeCapKernelEquiv n).apply_symm_apply a.val
+
+private def ThreefoldHomology.ThirdDegree.starKernelNativeEquiv (n : ℕ) :
+    LinearMap.ker (ThreefoldHomology.starLeftHomologyMap n) ≃ₗ[ℤ]
+      LinearMap.ker (ThreefoldHomology.CapElimination.nativeCapKernelRegularMap n) :=
+  LinearEquiv.ofBijective (starKernelToNative n)
+    ⟨starKernelToNative_injective n, starKernelToNative_surjective n⟩
+
+private def ThreefoldHomology.ThirdDegree.residualMultiplication : ℤ →ₗ[ℤ] ℤ :=
+  LinearMap.toSpanSingleton ℤ ℤ referenceFibreCoefficient
+
+private def ThreefoldHomology.ThirdDegree.residualKernelToNative :
+    LinearMap.ker residualMultiplication →ₗ[ℤ]
+      LinearMap.ker (ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 3) :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun
+        a :=
+        ⟨a.val • referenceClasses,
+          by
+          change
+            ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 3
+                (a.val • referenceClasses) =
+              0
+          rw [nativeCapKernelRegularMap_smul_reference]
+          have ha : a.val * referenceFibreCoefficient = 0 := a.property
+          rw [ha, map_zero]⟩
+      map_zero' := by
+        apply Subtype.ext
+        exact zero_smul ℤ referenceClasses
+      map_add' a
+        b := by
+        apply Subtype.ext
+        exact add_smul a.val b.val referenceClasses }
+
+private theorem ThreefoldHomology.ThirdDegree.residualKernelToNative_injective :
+    Function.Injective residualKernelToNative := by
+  intro a b hab
+  apply Subtype.ext
+  exact ThreefoldHomology.ThirdSource.referenceClasses_smul_injective (congrArg Subtype.val hab)
+
+private theorem ThreefoldHomology.ThirdDegree.residualKernelToNative_surjective :
+    Function.Surjective residualKernelToNative := by
+  intro a
+  obtain ⟨k, hk, hz⟩ := (nativeCapKernelRegularMap_three_eq_zero_iff a.val).mp a.property
+  exact ⟨⟨k, hz⟩, Subtype.ext hk.symm⟩
+
+private def ThreefoldHomology.ThirdDegree.residualNativeKernelEquiv :
+    LinearMap.ker residualMultiplication ≃ₗ[ℤ]
+      LinearMap.ker (ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 3) :=
+  LinearEquiv.ofBijective residualKernelToNative
+    ⟨residualKernelToNative_injective, residualKernelToNative_surjective⟩
+
+private def ThreefoldHomology.ThirdDegree.homologyFourResidualKernelEquiv :
+    SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 4 ≃ₗ[ℤ]
+      LinearMap.ker residualMultiplication :=
+  (ThreefoldHomology.FourthDegree.homologyFourKernelEquiv.toAddEquiv.trans
+      ((starKernelNativeEquiv 3).toAddEquiv.trans
+        residualNativeKernelEquiv.symm.toAddEquiv)).toIntLinearEquiv
+
+private def ThreefoldHomology.ThirdDegree.homologyFourCoefficientMap :
+    SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 4 →ₗ[ℤ] ℤ :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun a := (homologyFourResidualKernelEquiv a).val
+      map_zero' := by rw [map_zero, Submodule.coe_zero]
+      map_add' a b := by rw [map_add, Submodule.coe_add] }
+
+private theorem ThreefoldHomology.ThirdDegree.homologyFourCoefficientMap_injective :
+    Function.Injective homologyFourCoefficientMap := by
+  intro a b hab
+  exact homologyFourResidualKernelEquiv.injective (Subtype.ext hab)
+
+private theorem ThreefoldHomology.ThirdDegree.homologyFourCoefficientMap_mul
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 4) :
+    homologyFourCoefficientMap a * referenceFibreCoefficient = 0 :=
+  (homologyFourResidualKernelEquiv a).property
+
+private theorem
+  ThreefoldHomology.ThirdDegree.homologyThree_subsingleton_iff_referenceFibreCoefficient_isUnit :
+    Subsingleton (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 3) ↔
+      IsUnit referenceFibreCoefficient := by
+  rw [homologyThree_subsingleton_iff_generator_eq_zero]
+  change homologyThreeCyclicMap 1 = 0 ↔ IsUnit referenceFibreCoefficient
+  rw [homologyThreeCyclicMap_eq_zero_iff, isUnit_iff_exists_inv']
+
+private theorem
+  ThreefoldHomology.ThirdDegree.homologyFour_subsingleton_iff_referenceFibreCoefficient_ne_zero :
+    Subsingleton (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 4) ↔
+      referenceFibreCoefficient ≠ 0 := by
+  constructor
+  · intro hss hr
+    let a : LinearMap.ker residualMultiplication :=
+      ⟨1, by
+        change 1 * referenceFibreCoefficient = 0
+        rw [hr, MulZeroClass.mul_zero]⟩
+    have h :=
+      hss.elim (homologyFourResidualKernelEquiv.symm a) (homologyFourResidualKernelEquiv.symm 0)
+    have ha : a = 0 := homologyFourResidualKernelEquiv.symm.injective h
+    have hone : (1 : ℤ) = 0 := congrArg Subtype.val ha
+    exact one_ne_zero hone
+  · intro hr
+    have hz (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 4) :
+      a = 0 := by
+      apply homologyFourCoefficientMap_injective
+      rw [map_zero]
+      exact (mul_eq_zero.mp (homologyFourCoefficientMap_mul a)).resolve_right hr
+    exact ⟨fun a b => (hz a).trans (hz b).symm⟩
+
+private theorem ThreefoldHomology.ThirdDegree.referenceFibreCoefficient_eq_one :
+    referenceFibreCoefficient = 1 :=
+  (referenceFibreCoefficient_eq_iff 1).mpr
+    PeriodFamily.Boundary.ThirdRelation.referenceClasses_regular
+
+private theorem ThreefoldHomology.ThirdDegree.referenceFibreCoefficient_isUnit :
+    IsUnit referenceFibreCoefficient := by
+  rw [referenceFibreCoefficient_eq_one]
+  exact isUnit_one
+
+private theorem ThreefoldHomology.ThirdDegree.homologyThree_subsingleton :
+    Subsingleton (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 3) :=
+  homologyThree_subsingleton_iff_referenceFibreCoefficient_isUnit.mpr
+    referenceFibreCoefficient_isUnit
+
+private theorem ThreefoldHomology.FourthDegree.homologyFour_subsingleton :
+    Subsingleton (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 4) :=
+  ThreefoldHomology.ThirdDegree.homologyFour_subsingleton_iff_referenceFibreCoefficient_ne_zero.mpr
+    ThreefoldHomology.ThirdDegree.referenceFibreCoefficient_isUnit.ne_zero
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/HomologyOfX/ThreefoldHomologyStarCoproduct.lean b/LeanPool/HopfProblem/HomologyOfX/ThreefoldHomologyStarCoproduct.lean
new file mode 100644
index 000000000..e1ff860bf
--- /dev/null
+++ b/LeanPool/HopfProblem/HomologyOfX/ThreefoldHomologyStarCoproduct.lean
@@ -0,0 +1,425 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.MainTheorem.SixSphereCube1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.MainTheorem.SixSphereCube1
+
+/-!
+# Hopf problem: homology of x · threefold homology star coproduct
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem ThreefoldHomologyStarCoproduct.singularChainsFiniteBiproducts :
+    CategoryTheory.Limits.HasFiniteBiproducts (ChainComplex (ModuleCat.{0} ℤ) ℕ) :=
+  CategoryTheory.Limits.HasFiniteBiproducts.of_hasFiniteProducts
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.singularChainsFiniteBiproducts in
+private def ThreefoldHomologyStarCoproduct.sigmaInclusion {ι : Type} (X : ι → Type)
+    [∀ i, TopologicalSpace (X i)] (i : ι) : C(X i, Σ i, X i) :=
+  ⟨Sigma.mk i, continuous_sigmaMk⟩
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.singularChainsFiniteBiproducts in
+private theorem ThreefoldHomologyStarCoproduct.singularSimplex_sigma_split {ι : Type} (X : ι → Type)
+    [∀ i, TopologicalSpace (X i)] (n : ℕ) (σ : FirstHurewicz.SingularSimplex (Σ i, X i) n) :
+    ∃ (i : ι) (τ : FirstHurewicz.SingularSimplex (X i) n), σ = (sigmaInclusion X i).comp τ := by
+  obtain ⟨i, g, hg, heq⟩ := σ.continuous.exists_lift_sigma
+  exact ⟨i, ⟨g, hg⟩, ContinuousMap.ext (congrFun heq)⟩
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.singularChainsFiniteBiproducts in
+private def ThreefoldHomologyStarCoproduct.sigmaSimplexMap {ι : Type} (X : ι → Type)
+    [∀ i, TopologicalSpace (X i)] (n : ℕ) :
+    (Σ i, FirstHurewicz.SingularSimplex (X i) n) → FirstHurewicz.SingularSimplex (Σ i, X i) n :=
+  fun σ => (sigmaInclusion X σ.1).comp σ.2
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.singularChainsFiniteBiproducts in
+private theorem ThreefoldHomologyStarCoproduct.sigmaSimplexMap_injective {ι : Type} (X : ι → Type)
+    [∀ i, TopologicalSpace (X i)] (n : ℕ) : Function.Injective (sigmaSimplexMap X n) := by
+  classical
+  let z : stdSimplex ℝ (Fin (n + 1)) := Classical.choice inferInstance
+  rintro ⟨i, σ⟩ ⟨j, τ⟩ h
+  have hij : i = j := congrArg (fun f => (f z).1) h
+  subst j
+  congr 1
+  exact ContinuousMap.ext fun t => sigma_mk_injective (congrArg (fun f => f t) h)
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.singularChainsFiniteBiproducts in
+private theorem ThreefoldHomologyStarCoproduct.sigmaSimplexMap_surjective {ι : Type} (X : ι → Type)
+    [∀ i, TopologicalSpace (X i)] (n : ℕ) : Function.Surjective (sigmaSimplexMap X n) := by
+  intro σ
+  obtain ⟨i, τ, hτ⟩ := singularSimplex_sigma_split X n σ
+  exact ⟨⟨i, τ⟩, hτ.symm⟩
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.singularChainsFiniteBiproducts in
+private def ThreefoldHomologyStarCoproduct.sigmaSimplexEquiv {ι : Type} (X : ι → Type)
+    [∀ i, TopologicalSpace (X i)] (n : ℕ) :
+    (Σ i, FirstHurewicz.SingularSimplex (X i) n) ≃ FirstHurewicz.SingularSimplex (Σ i, X i) n :=
+  Equiv.ofBijective (sigmaSimplexMap X n)
+    ⟨sigmaSimplexMap_injective X n, sigmaSimplexMap_surjective X n⟩
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.singularChainsFiniteBiproducts in
+@[simp]
+private theorem
+    ThreefoldHomologyStarCoproduct.sigmaSimplexEquiv_symm_inclusion {ι : Type} (X : ι → Type)
+    [∀ i, TopologicalSpace (X i)] (n : ℕ) (i : ι) (σ : FirstHurewicz.SingularSimplex (X i) n) :
+    (sigmaSimplexEquiv X n).symm ((sigmaInclusion X i).comp σ) = ⟨i, σ⟩ :=
+  (sigmaSimplexEquiv X n).symm_apply_apply ⟨i, σ⟩
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.singularChainsFiniteBiproducts in
+private theorem ThreefoldHomologyStarCoproduct.sigmaChains_hom_ext {ι : Type} (X : ι → Type)
+    [∀ i, TopologicalSpace (X i)] (n : ℕ) {M : ModuleCat ℤ}
+    (f g : FirstHurewicz.Chains (Σ i, X i) n ⟶ M)
+    (h :
+      ∀ i,
+        (FirstHurewicz.singularChainMap (sigmaInclusion X i)).f n ≫ f =
+          (FirstHurewicz.singularChainMap (sigmaInclusion X i)).f n ≫ g) :
+    f = g := by
+  apply ModuleCat.hom_ext
+  apply FirstHurewicz.chainMap_ext (Σ i, X i) n
+  intro σ
+  obtain ⟨i, τ, rfl⟩ := singularSimplex_sigma_split X n σ
+  simpa only [ModuleCat.hom_comp, LinearMap.comp_apply, FirstHurewicz.inducedChain_simplex] using
+    congrArg (fun k => k.hom (FirstHurewicz.simplexChain (X i) n τ)) (h i)
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.singularChainsFiniteBiproducts in
+private def ThreefoldHomologyStarCoproduct.sigmaChainComplexMap {ι : Type} (X : ι → Type)
+    [∀ i, TopologicalSpace (X i)] [Fintype ι] :
+    (⨁ fun i => FirstHurewicz.singularComplex (X i)) ⟶ FirstHurewicz.singularComplex (Σ i, X i) :=
+  CategoryTheory.Limits.biproduct.desc fun i =>
+    FirstHurewicz.singularChainMap (sigmaInclusion X i)
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.singularChainsFiniteBiproducts in
+@[simp]
+private theorem
+    ThreefoldHomologyStarCoproduct.sigmaChainComplexMap_inclusion {ι : Type} (X : ι → Type)
+    [∀ i, TopologicalSpace (X i)] [Fintype ι] (i : ι) :
+    CategoryTheory.Limits.biproduct.ι (fun i => FirstHurewicz.singularComplex (X i)) i ≫
+        sigmaChainComplexMap X =
+      FirstHurewicz.singularChainMap (sigmaInclusion X i) :=
+  CategoryTheory.Limits.biproduct.ι_desc _ i
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.singularChainsFiniteBiproducts in
+private def ThreefoldHomologyStarCoproduct.sigmaChainInverseDegree_mo1973_5500 {ι : Type}
+    (X : ι → Type) [∀ i, TopologicalSpace (X i)] [Fintype ι] (n : ℕ) :
+    FirstHurewicz.Chains (Σ i, X i) n →ₗ[ℤ]
+      (⨁ fun i => FirstHurewicz.singularComplex (X i)).X n :=
+  FirstHurewicz.chainLift (Σ i, X i) n fun σ =>
+    let τ := (sigmaSimplexEquiv X n).symm σ
+    ((CategoryTheory.Limits.biproduct.ι (fun i => FirstHurewicz.singularComplex (X i)) τ.1).f
+          n).hom
+      (FirstHurewicz.simplexChain (X τ.1) n τ.2)
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.singularChainsFiniteBiproducts in
+private theorem ThreefoldHomologyStarCoproduct.sigmaChainInverseDegree_inclusion_mo1973_5501
+    {ι : Type} (X : ι → Type) [∀ i, TopologicalSpace (X i)] [Fintype ι] (n : ℕ) (i : ι)
+    (σ : FirstHurewicz.SingularSimplex (X i) n) :
+    sigmaChainInverseDegree_mo1973_5500 X n
+        (FirstHurewicz.simplexChain (Σ i, X i) n ((sigmaInclusion X i).comp σ)) =
+      ((CategoryTheory.Limits.biproduct.ι (fun i => FirstHurewicz.singularComplex (X i)) i).f
+            n).hom
+        (FirstHurewicz.simplexChain (X i) n σ) := by
+  simpa only [sigmaChainInverseDegree_mo1973_5500, FirstHurewicz.chainLift_simplex] using
+    congrArg
+      (fun τ : Σ i, FirstHurewicz.SingularSimplex (X i) n =>
+        ((CategoryTheory.Limits.biproduct.ι (fun i => FirstHurewicz.singularComplex (X i)) τ.1).f
+              n).hom
+          (FirstHurewicz.simplexChain (X τ.1) n τ.2))
+      (sigmaSimplexEquiv_symm_inclusion X n i σ)
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.singularChainsFiniteBiproducts in
+private theorem ThreefoldHomologyStarCoproduct.sigmaChainInverseDegree_comp_inclusion_mo1973_5502
+    {ι : Type} (X : ι → Type) [∀ i, TopologicalSpace (X i)] [Fintype ι] (n : ℕ) (i : ι) :
+    (FirstHurewicz.singularChainMap (sigmaInclusion X i)).f n ≫
+        ModuleCat.ofHom (sigmaChainInverseDegree_mo1973_5500 X n) =
+      (CategoryTheory.Limits.biproduct.ι (fun i => FirstHurewicz.singularComplex (X i)) i).f n := by
+  apply ModuleCat.hom_ext
+  apply FirstHurewicz.chainMap_ext (X i) n
+  intro σ
+  change
+    sigmaChainInverseDegree_mo1973_5500 X n
+        (FirstHurewicz.inducedChain (sigmaInclusion X i) n
+          (FirstHurewicz.simplexChain (X i) n σ)) =
+      _
+  rw [FirstHurewicz.inducedChain_simplex, sigmaChainInverseDegree_inclusion_mo1973_5501]
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.singularChainsFiniteBiproducts in
+private def ThreefoldHomologyStarCoproduct.sigmaChainComplexInverse {ι : Type} (X : ι → Type)
+    [∀ i, TopologicalSpace (X i)] [Fintype ι] :
+    FirstHurewicz.singularComplex (Σ i, X i) ⟶ (⨁ fun i => FirstHurewicz.singularComplex (X i))
+    where
+  f n := ModuleCat.ofHom (sigmaChainInverseDegree_mo1973_5500 X n)
+  comm' n m
+    _ := by
+    apply sigmaChains_hom_ext X n
+    intro i
+    calc
+      _ =
+          ((FirstHurewicz.singularChainMap (sigmaInclusion X i)).f n ≫
+              ModuleCat.ofHom (sigmaChainInverseDegree_mo1973_5500 X n)) ≫
+            (⨁ fun i => FirstHurewicz.singularComplex (X i)).d n m :=
+        (CategoryTheory.Category.assoc _ _ _).symm
+      _ =
+          (CategoryTheory.Limits.biproduct.ι (fun i => FirstHurewicz.singularComplex (X i)) i).f
+              n ≫
+            (⨁ fun i => FirstHurewicz.singularComplex (X i)).d n m :=
+        (congrArg
+          (fun f :
+              FirstHurewicz.Chains (X i) n ⟶
+                (⨁ fun i => FirstHurewicz.singularComplex (X i)).X n =>
+            f ≫ (⨁ fun i => FirstHurewicz.singularComplex (X i)).d n m)
+          (sigmaChainInverseDegree_comp_inclusion_mo1973_5502 X n i))
+      _ =
+          (FirstHurewicz.singularComplex (X i)).d n m ≫
+            (CategoryTheory.Limits.biproduct.ι (fun i => FirstHurewicz.singularComplex (X i)) i).f
+              m :=
+        ((CategoryTheory.Limits.biproduct.ι (fun i => FirstHurewicz.singularComplex (X i)) i).comm
+          n m)
+      _ =
+          (FirstHurewicz.singularComplex (X i)).d n m ≫
+            ((FirstHurewicz.singularChainMap (sigmaInclusion X i)).f m ≫
+              ModuleCat.ofHom (sigmaChainInverseDegree_mo1973_5500 X m)) :=
+        (congrArg
+            (fun f :
+                FirstHurewicz.Chains (X i) m ⟶
+                  (⨁ fun i => FirstHurewicz.singularComplex (X i)).X m =>
+              (FirstHurewicz.singularComplex (X i)).d n m ≫ f)
+            (sigmaChainInverseDegree_comp_inclusion_mo1973_5502 X m i)).symm
+      _ =
+          ((FirstHurewicz.singularComplex (X i)).d n m ≫
+              (FirstHurewicz.singularChainMap (sigmaInclusion X i)).f m) ≫
+            ModuleCat.ofHom (sigmaChainInverseDegree_mo1973_5500 X m) :=
+        (CategoryTheory.Category.assoc _ _ _).symm
+      _ =
+          ((FirstHurewicz.singularChainMap (sigmaInclusion X i)).f n ≫
+              (FirstHurewicz.singularComplex (Σ i, X i)).d n m) ≫
+            ModuleCat.ofHom (sigmaChainInverseDegree_mo1973_5500 X m) :=
+        (congrArg
+          (fun f : FirstHurewicz.Chains (X i) n ⟶ FirstHurewicz.Chains (Σ i, X i) m =>
+            f ≫ ModuleCat.ofHom (sigmaChainInverseDegree_mo1973_5500 X m))
+          ((FirstHurewicz.singularChainMap (sigmaInclusion X i)).comm n m).symm)
+      _ = _ := CategoryTheory.Category.assoc _ _ _
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.singularChainsFiniteBiproducts in
+@[simp]
+private theorem ThreefoldHomologyStarCoproduct.sigmaChainComplexInverse_inclusion {ι : Type}
+    (X : ι → Type) [∀ i, TopologicalSpace (X i)] [Fintype ι] (i : ι) :
+    FirstHurewicz.singularChainMap (sigmaInclusion X i) ≫ sigmaChainComplexInverse X =
+      CategoryTheory.Limits.biproduct.ι (fun i => FirstHurewicz.singularComplex (X i)) i := by
+  apply HomologicalComplex.Hom.ext
+  funext n
+  exact sigmaChainInverseDegree_comp_inclusion_mo1973_5502 X n i
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.singularChainsFiniteBiproducts in
+private theorem
+    ThreefoldHomologyStarCoproduct.sigmaChainComplexMap_comp_inverse {ι : Type} (X : ι → Type)
+    [∀ i, TopologicalSpace (X i)] [Fintype ι] :
+    sigmaChainComplexMap X ≫ sigmaChainComplexInverse X =
+      𝟙 (⨁ fun i => FirstHurewicz.singularComplex (X i)) := by
+  apply CategoryTheory.Limits.biproduct.hom_ext'
+  intro i
+  rw [← CategoryTheory.Category.assoc, sigmaChainComplexMap_inclusion,
+    sigmaChainComplexInverse_inclusion, CategoryTheory.Category.comp_id]
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.singularChainsFiniteBiproducts in
+private theorem
+    ThreefoldHomologyStarCoproduct.sigmaChainComplexInverse_comp_map {ι : Type} (X : ι → Type)
+    [∀ i, TopologicalSpace (X i)] [Fintype ι] :
+    sigmaChainComplexInverse X ≫ sigmaChainComplexMap X =
+      𝟙 (FirstHurewicz.singularComplex (Σ i, X i)) := by
+  apply HomologicalComplex.Hom.ext
+  funext n
+  apply sigmaChains_hom_ext X n
+  intro i
+  have h :
+    FirstHurewicz.singularChainMap (sigmaInclusion X i) ≫
+        (sigmaChainComplexInverse X ≫ sigmaChainComplexMap X) =
+      FirstHurewicz.singularChainMap (sigmaInclusion X i) := by
+    rw [← CategoryTheory.Category.assoc, sigmaChainComplexInverse_inclusion,
+      sigmaChainComplexMap_inclusion]
+  exact (congrArg (fun f => f.f n) h).trans (CategoryTheory.Category.comp_id _).symm
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.singularChainsFiniteBiproducts in
+private def ThreefoldHomologyStarCoproduct.sigmaChainComplexIso {ι : Type} (X : ι → Type)
+    [∀ i, TopologicalSpace (X i)] [Fintype ι] :
+    (⨁ fun i => FirstHurewicz.singularComplex (X i)) ≅ FirstHurewicz.singularComplex (Σ i, X i)
+    where
+  hom := sigmaChainComplexMap X
+  inv := sigmaChainComplexInverse X
+  hom_inv_id := sigmaChainComplexMap_comp_inverse X
+  inv_hom_id := sigmaChainComplexInverse_comp_map X
+
+public
+theorem ThreefoldHomologyStarCoproduct.homologyFiniteBiproducts :
+    CategoryTheory.Limits.HasFiniteBiproducts (ChainComplex (ModuleCat.{0} ℤ) ℕ) :=
+  CategoryTheory.Limits.HasFiniteBiproducts.of_hasFiniteProducts
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.homologyFiniteBiproducts in
+private theorem ThreefoldHomologyStarCoproduct.homology_π_ι_self_mo1973_5511 {ι : Type} [Finite ι]
+    (K : ι → ChainComplex (ModuleCat.{0} ℤ) ℕ) (n : ℕ) (i : ι) (a : (K i).homology n) :
+    (HomologicalComplex.homologyMap (CategoryTheory.Limits.biproduct.π K i) n).hom
+        ((HomologicalComplex.homologyMap (CategoryTheory.Limits.biproduct.ι K i) n).hom a) =
+      a := by
+  have h :=
+    HomologicalComplex.homologyMap_comp (CategoryTheory.Limits.biproduct.ι K i)
+      (CategoryTheory.Limits.biproduct.π K i) n
+  rw [CategoryTheory.Limits.biproduct.ι_π_self, HomologicalComplex.homologyMap_id] at h
+  exact (congrArg (fun f => f.hom a) h).symm
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.homologyFiniteBiproducts in
+private theorem ThreefoldHomologyStarCoproduct.homology_π_ι_ne_mo1973_5512 {ι : Type} [Finite ι]
+    (K : ι → ChainComplex (ModuleCat.{0} ℤ) ℕ) (n : ℕ) {i j : ι} (hij : i ≠ j)
+    (a : (K i).homology n) :
+    (HomologicalComplex.homologyMap (CategoryTheory.Limits.biproduct.π K j) n).hom
+        ((HomologicalComplex.homologyMap (CategoryTheory.Limits.biproduct.ι K i) n).hom a) =
+      0 := by
+  have h :=
+    HomologicalComplex.homologyMap_comp (CategoryTheory.Limits.biproduct.ι K i)
+      (CategoryTheory.Limits.biproduct.π K j) n
+  rw [CategoryTheory.Limits.biproduct.ι_π_ne K hij, HomologicalComplex.homologyMap_zero] at h
+  exact (congrArg (fun f => f.hom a) h).symm
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.homologyFiniteBiproducts in
+private theorem ThreefoldHomologyStarCoproduct.homology_biproduct_total_mo1973_5513 {ι : Type}
+    [Fintype ι] (K : ι → ChainComplex (ModuleCat.{0} ℤ) ℕ) (n : ℕ) (a : (⨁ K).homology n) :
+    ∑ i,
+        (HomologicalComplex.homologyMap (CategoryTheory.Limits.biproduct.ι K i) n).hom
+          ((HomologicalComplex.homologyMap (CategoryTheory.Limits.biproduct.π K i) n).hom a) =
+      a := by
+  have h :
+    HomologicalComplex.homologyMap
+        (∑ i, CategoryTheory.Limits.biproduct.π K i ≫ CategoryTheory.Limits.biproduct.ι K i) n =
+      𝟙 ((⨁ K).homology n) := by
+    rw [CategoryTheory.Limits.biproduct.total, HomologicalComplex.homologyMap_id]
+  change
+    (HomologicalComplex.homologyFunctor (ModuleCat ℤ) (ComplexShape.down ℕ) n).map
+        (∑ i, CategoryTheory.Limits.biproduct.π K i ≫ CategoryTheory.Limits.biproduct.ι K i) =
+      _ at h
+  rw [CategoryTheory.Functor.map_sum] at h
+  change
+    (∑ i,
+        HomologicalComplex.homologyMap
+          (CategoryTheory.Limits.biproduct.π K i ≫ CategoryTheory.Limits.biproduct.ι K i) n) =
+      _ at h
+  simpa only [HomologicalComplex.homologyMap_comp, ModuleCat.hom_sum, LinearMap.sum_apply,
+    ModuleCat.hom_comp, LinearMap.comp_apply, ModuleCat.hom_id, LinearMap.id_apply] using
+    congrArg (fun f => f.hom a) h
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.homologyFiniteBiproducts in
+private def ThreefoldHomologyStarCoproduct.homologyBiproductEquiv {ι : Type} [Fintype ι]
+    (K : ι → ChainComplex (ModuleCat.{0} ℤ) ℕ) (n : ℕ) :
+    (⨁ K).homology n ≃ₗ[ℤ] (∀ i, (K i).homology n) := by
+  classical
+    exact
+    ({    toFun a
+            i := (HomologicalComplex.homologyMap (CategoryTheory.Limits.biproduct.π K i) n).hom a
+          invFun
+            a :=
+            ∑ i,
+              (HomologicalComplex.homologyMap (CategoryTheory.Limits.biproduct.ι K i) n).hom (a i)
+          left_inv := homology_biproduct_total_mo1973_5513 K n
+          right_inv
+            a := by
+            funext i
+            change
+              (HomologicalComplex.homologyMap (CategoryTheory.Limits.biproduct.π K i) n).hom
+                  (∑ j,
+                    (HomologicalComplex.homologyMap (CategoryTheory.Limits.biproduct.ι K j) n).hom
+                      (a j)) =
+                a i
+            rw [map_sum, Finset.sum_eq_single i]
+            · exact homology_π_ι_self_mo1973_5511 K n i (a i)
+            · intro j _ hji
+              exact homology_π_ι_ne_mo1973_5512 K n hji (a j)
+            · simp
+          map_add' a
+            b := by
+            funext i
+            exact
+              map_add
+                (HomologicalComplex.homologyMap (CategoryTheory.Limits.biproduct.π K i) n).hom a
+                b } :
+        (⨁ K).homology n ≃+ (∀ i, (K i).homology n)).toIntLinearEquiv
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.homologyFiniteBiproducts in
+private theorem
+    ThreefoldHomologyStarCoproduct.homologyBiproductEquiv_symm_apply {ι : Type} [Fintype ι]
+    (K : ι → ChainComplex (ModuleCat.{0} ℤ) ℕ) (n : ℕ) (a : ∀ i, (K i).homology n) :
+    (homologyBiproductEquiv K n).symm a =
+      ∑ i, (HomologicalComplex.homologyMap (CategoryTheory.Limits.biproduct.ι K i) n).hom (a i) :=
+  rfl
+
+attribute [local instance] ThreefoldHomologyStarCoproduct.homologyFiniteBiproducts in
+private theorem ThreefoldHomologyStarCoproduct.homologyBiproductEquiv_desc {ι : Type} [Fintype ι]
+    {K : ι → ChainComplex (ModuleCat.{0} ℤ) ℕ} (n : ℕ) {L : ChainComplex (ModuleCat.{0} ℤ) ℕ}
+    (f : ∀ i, K i ⟶ L) (a : ∀ i, (K i).homology n) :
+    (HomologicalComplex.homologyMap (CategoryTheory.Limits.biproduct.desc f) n).hom
+        ((homologyBiproductEquiv K n).symm a) =
+      ∑ i, (HomologicalComplex.homologyMap (f i) n).hom (a i) := by
+  rw [homologyBiproductEquiv_symm_apply, map_sum]
+  apply Finset.sum_congr rfl
+  intro i _
+  have h :=
+    HomologicalComplex.homologyMap_comp (CategoryTheory.Limits.biproduct.ι K i)
+      (CategoryTheory.Limits.biproduct.desc f) n
+  rw [CategoryTheory.Limits.biproduct.ι_desc] at h
+  exact (congrArg (fun k => k.hom (a i)) h).symm
+
+private def ThreefoldHomologyStarCoproduct.sigmaHomologyEquiv {ι : Type} [Fintype ι] (X : ι → Type)
+    [∀ i, TopologicalSpace (X i)] (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (Σ i, X i) n ≃ₗ[ℤ]
+      (∀ i, SingularMayerVietoris.SingularHomology (X i) n) :=
+  ((HomologicalComplex.homologyFunctor (ModuleCat ℤ) (ComplexShape.down ℕ) n).mapIso
+        (sigmaChainComplexIso X)).symm.toLinearEquiv.trans
+    (homologyBiproductEquiv (fun i => FirstHurewicz.singularComplex (X i)) n)
+
+private theorem ThreefoldHomologyStarCoproduct.sigmaHomologyEquiv_symm_apply {ι : Type} [Fintype ι]
+    (X : ι → Type) [∀ i, TopologicalSpace (X i)] (n : ℕ)
+    (a : ∀ i, SingularMayerVietoris.SingularHomology (X i) n) :
+    (sigmaHomologyEquiv X n).symm a =
+      ∑ i, SingularMayerVietoris.singularHomologyMap (sigmaInclusion X i) n (a i) := by
+  change
+    (HomologicalComplex.homologyMap (sigmaChainComplexMap X) n).hom
+        ((homologyBiproductEquiv (fun i => FirstHurewicz.singularComplex (X i)) n).symm a) =
+      _
+  exact
+    homologyBiproductEquiv_desc n (fun i => FirstHurewicz.singularChainMap (sigmaInclusion X i)) a
+
+@[simp]
+private theorem ThreefoldHomologyStarCoproduct.sigmaHomologyEquiv_symm_single {ι : Type} [Fintype ι]
+    (X : ι → Type) [∀ i, TopologicalSpace (X i)] [DecidableEq ι] (n : ℕ) (i : ι)
+    (a : SingularMayerVietoris.SingularHomology (X i) n) :
+    (sigmaHomologyEquiv X n).symm (Pi.single i a) =
+      SingularMayerVietoris.singularHomologyMap (sigmaInclusion X i) n a := by
+  rw [sigmaHomologyEquiv_symm_apply, Finset.sum_eq_single i]
+  · rw [Pi.single_eq_same]
+  · intro j _ hji
+    rw [Pi.single_eq_of_ne hji, map_zero]
+  · simp
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/HomologyOfX/TrianglePeriodFamilyHomologyAlgebra.lean b/LeanPool/HopfProblem/HomologyOfX/TrianglePeriodFamilyHomologyAlgebra.lean
new file mode 100644
index 000000000..1bb8a7462
--- /dev/null
+++ b/LeanPool/HopfProblem/HomologyOfX/TrianglePeriodFamilyHomologyAlgebra.lean
@@ -0,0 +1,287 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Threefold.SpecialPeriods10
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.HomologyOfX.CuspCoinvariants
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods10
+
+/-!
+# Hopf problem: homology of x · triangle period family homology algebra
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def
+    TrianglePeriodFamilyHomologyAlgebra.diagonalCokernelProjection {H K : Type*} [AddCommGroup H]
+    [Module ℤ H] [AddCommGroup K] [Module ℤ K] (f : K →ₗ[ℤ] H) :
+    (H × H) →ₗ[ℤ] H ⧸ LinearMap.range f :=
+  (LinearMap.range f).mkQ.comp (LinearMap.snd ℤ H H)
+
+@[instance_reducible]
+private def TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule {B : Type u} [AddCommGroup B]
+    [Module ℤ B] (p : Submodule ℤ B) : Module ℤ (B ⧸ p) :=
+  Submodule.Quotient.module p
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule in
+@[instance_reducible]
+private def
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule {D : Type u} [AddCommGroup D] [Module ℤ D]
+    (p : Submodule ℤ D) : Module ℤ p :=
+  Submodule.module p
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def TrianglePeriodFamilyHomologyAlgebra.cokernelToMiddle {A B C : Type u} [AddCommGroup A]
+    [AddCommGroup B] [AddCommGroup C] [Module ℤ A] [Module ℤ B] [Module ℤ C] (f : A →ₗ[ℤ] B)
+    (j : B →ₗ[ℤ] C) (hfj : Function.Exact f j) : (B ⧸ LinearMap.range f) →ₗ[ℤ] C :=
+  (LinearMap.range f).liftQ j hfj.linearMap_ker_eq.ge
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private theorem TrianglePeriodFamilyHomologyAlgebra.cokernelToMiddle_injective {A B C : Type u}
+    [AddCommGroup A] [AddCommGroup B] [AddCommGroup C] [Module ℤ A] [Module ℤ B] [Module ℤ C]
+    (f : A →ₗ[ℤ] B) (j : B →ₗ[ℤ] C) (hfj : Function.Exact f j) :
+    Function.Injective (cokernelToMiddle f j hfj) := by
+  apply LinearMap.ker_eq_bot.mp
+  exact (LinearMap.range f).ker_liftQ_eq_bot j _ hfj.linearMap_ker_eq.le
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def TrianglePeriodFamilyHomologyAlgebra.middleToKernel {C D E : Type u} [AddCommGroup C]
+    [AddCommGroup D] [AddCommGroup E] [Module ℤ C] [Module ℤ D] [Module ℤ E] (δ : C →ₗ[ℤ] D)
+    (d : D →ₗ[ℤ] E) (hδd : Function.Exact δ d) : C →ₗ[ℤ] LinearMap.ker d :=
+  δ.codRestrict (LinearMap.ker d) hδd.apply_apply_eq_zero
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private theorem TrianglePeriodFamilyHomologyAlgebra.middleToKernel_surjective {C D E : Type u}
+    [AddCommGroup C] [AddCommGroup D] [AddCommGroup E] [Module ℤ C] [Module ℤ D] [Module ℤ E]
+    (δ : C →ₗ[ℤ] D) (d : D →ₗ[ℤ] E) (hδd : Function.Exact δ d) :
+    Function.Surjective (middleToKernel δ d hδd) := by
+  intro y
+  obtain ⟨c, hc⟩ := (hδd y.1).mp y.2
+  exact ⟨c, Subtype.ext hc⟩
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private theorem TrianglePeriodFamilyHomologyAlgebra.middleToKernel_comp_cokernelToMiddle
+    {A B C D E : Type u} [AddCommGroup A] [AddCommGroup B] [AddCommGroup C] [AddCommGroup D]
+    [AddCommGroup E] [Module ℤ A] [Module ℤ B] [Module ℤ C] [Module ℤ D] [Module ℤ E]
+    (f : A →ₗ[ℤ] B) (j : B →ₗ[ℤ] C) (δ : C →ₗ[ℤ] D) (d : D →ₗ[ℤ] E) (hfj : Function.Exact f j)
+    (hjδ : Function.Exact j δ) (hδd : Function.Exact δ d) :
+    (middleToKernel δ d hδd).comp (cokernelToMiddle f j hfj) = 0 := by
+  apply LinearMap.ext
+  intro q
+  obtain ⟨b, rfl⟩ := (LinearMap.range f).mkQ_surjective q
+  apply Subtype.ext
+  change δ (j b) = 0
+  exact hjδ.apply_apply_eq_zero b
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private theorem TrianglePeriodFamilyHomologyAlgebra.cokernelToMiddle_middleToKernel_exact
+    {A B C D E : Type u} [AddCommGroup A] [AddCommGroup B] [AddCommGroup C] [AddCommGroup D]
+    [AddCommGroup E] [Module ℤ A] [Module ℤ B] [Module ℤ C] [Module ℤ D] [Module ℤ E]
+    (f : A →ₗ[ℤ] B) (j : B →ₗ[ℤ] C) (δ : C →ₗ[ℤ] D) (d : D →ₗ[ℤ] E) (hfj : Function.Exact f j)
+    (hjδ : Function.Exact j δ) (hδd : Function.Exact δ d) :
+    Function.Exact (cokernelToMiddle f j hfj) (middleToKernel δ d hδd) := by
+  intro c
+  constructor
+  · intro hc
+    have hδc : δ c = 0 := congrArg Subtype.val hc
+    obtain ⟨b, hb⟩ := (hjδ c).mp hδc
+    exact ⟨(LinearMap.range f).mkQ b, hb⟩
+  · rintro ⟨q, rfl⟩
+    exact LinearMap.congr_fun (middleToKernel_comp_cokernelToMiddle f j δ d hfj hjδ hδd) q
+
+private def
+    TrianglePeriodFamilyHomologyAlgebra.overlapKerEquiv {H : Type*} [AddCommGroup H] [Module ℤ H]
+    (P Q : H →ₗ[ℤ] H) : LinearMap.ker (overlapMap P Q) ≃ₗ[ℤ] LinearMap.ker (delta P Q) :=
+  ({    toFun x := ⟨x.val.2, ((overlapMap_eq_zero_iff P Q x.val).mp x.property).2⟩
+        invFun
+          y :=
+          ⟨(-y.val.1 - y.val.2, y.val),
+            (overlapMap_eq_zero_iff P Q _).mpr ⟨by dsimp; abel, y.property⟩⟩
+        left_inv
+          x := by
+          apply Subtype.ext
+          apply Prod.ext
+          · have h := ((overlapMap_eq_zero_iff P Q x.val).mp x.property).1
+            change -x.val.2.1 - x.val.2.2 = x.val.1
+            calc
+              -x.val.2.1 - x.val.2.2 = x.val.1 - (x.val.1 + x.val.2.1 + x.val.2.2) := by abel
+              _ = x.val.1 := by rw [h, sub_zero]
+          · rfl
+        right_inv _ := rfl
+        map_add' _ _ := rfl } :
+      LinearMap.ker (overlapMap P Q) ≃+ LinearMap.ker (delta P Q)).toIntLinearEquiv
+
+private def
+    TrianglePeriodFamilyHomologyAlgebra.overlapCokernelProjection {H : Type*} [AddCommGroup H]
+    [Module ℤ H] (P Q : H →ₗ[ℤ] H) : (H × H) →ₗ[ℤ] H ⧸ LinearMap.range (delta P Q) :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    ((diagonalCokernelProjection (delta P Q)).toAddMonoidHom.comp
+      (rowEquiv H).toAddEquiv.toAddMonoidHom)
+
+@[simp]
+private theorem TrianglePeriodFamilyHomologyAlgebra.overlapCokernelProjection_apply {H : Type*}
+    [AddCommGroup H] [Module ℤ H] (P Q : H →ₗ[ℤ] H) (y : H × H) :
+    overlapCokernelProjection P Q y = Submodule.Quotient.mk (-y.1 - y.2) :=
+  rfl
+
+private theorem TrianglePeriodFamilyHomologyAlgebra.overlapCokernelProjection_surjective {H : Type*}
+    [AddCommGroup H] [Module ℤ H] (P Q : H →ₗ[ℤ] H) :
+    Function.Surjective (overlapCokernelProjection P Q) := by
+  intro q
+  obtain ⟨y, rfl⟩ := (LinearMap.range (delta P Q)).mkQ_surjective q
+  refine ⟨(0, -y), ?_⟩
+  simp only [overlapCokernelProjection_apply, neg_zero, zero_sub, neg_neg]
+  rfl
+
+private theorem TrianglePeriodFamilyHomologyAlgebra.overlapMap_range_eq_ker_projection {H : Type*}
+    [AddCommGroup H] [Module ℤ H] (P Q : H →ₗ[ℤ] H) :
+    LinearMap.range (overlapMap P Q) = LinearMap.ker (overlapCokernelProjection P Q) := by
+  ext y
+  rw [overlapMap_mem_range_iff]
+  change
+    -y.1 - y.2 ∈ LinearMap.range (delta P Q) ↔
+      (Submodule.Quotient.mk (-y.1 - y.2) : H ⧸ LinearMap.range (delta P Q)) = 0
+  exact (Submodule.Quotient.mk_eq_zero (p := LinearMap.range (delta P Q)) (x := -y.1 - y.2)).symm
+
+private def TrianglePeriodFamilyHomologyAlgebra.overlapCokernelEquiv {H : Type*} [AddCommGroup H]
+    [Module ℤ H] (P Q : H →ₗ[ℤ] H) :
+    ((H × H) ⧸ LinearMap.range (overlapMap P Q)) ≃ₗ[ℤ] H ⧸ LinearMap.range (delta P Q) :=
+  ((Submodule.quotEquivOfEq _ _ (overlapMap_range_eq_ker_projection P Q)).toAddEquiv.trans
+      ((overlapCokernelProjection P Q).quotKerEquivOfSurjective
+          (overlapCokernelProjection_surjective P Q)).toAddEquiv).toIntLinearEquiv
+
+@[simp]
+private theorem
+    TrianglePeriodFamilyHomologyAlgebra.overlapCokernelEquiv_mk {H : Type*} [AddCommGroup H]
+    [Module ℤ H] (P Q : H →ₗ[ℤ] H) (y : H × H) :
+    overlapCokernelEquiv P Q (Submodule.Quotient.mk y) = Submodule.Quotient.mk (-y.1 - y.2) := by
+  change
+    (overlapCokernelProjection P Q).quotKerEquivOfSurjective
+        (overlapCokernelProjection_surjective P Q)
+        (Submodule.quotEquivOfEq _ _ (overlapMap_range_eq_ker_projection P Q)
+          (Submodule.Quotient.mk y)) =
+      _
+  rw [Submodule.quotEquivOfEq_mk, LinearMap.quotKerEquivOfSurjective_apply_mk,
+    overlapCokernelProjection_apply]
+
+@[simp]
+private theorem TrianglePeriodFamilyHomologyAlgebra.overlapCokernelEquiv_symm_mk {H : Type*}
+    [AddCommGroup H] [Module ℤ H] (P Q : H →ₗ[ℤ] H) (y : H) :
+    (overlapCokernelEquiv P Q).symm (Submodule.Quotient.mk y) = Submodule.Quotient.mk (0, -y) := by
+  apply (overlapCokernelEquiv P Q).injective
+  rw [LinearEquiv.apply_symm_apply, overlapCokernelEquiv_mk]
+  simp only [neg_zero, zero_sub, neg_neg]
+
+private def TrianglePeriodFamilyHomologyAlgebra.inverseFirstCoordinate {H : Type*} [AddCommGroup H]
+    [Module ℤ H] (P : H ≃ₗ[ℤ] H) : (H × H) ≃ₗ[ℤ] (H × H) :=
+  ({    toFun x := (-P.symm x.1, x.2)
+        invFun x := (-P x.1, x.2)
+        left_inv x := by simp
+        right_inv x := by simp
+        map_add' x y := by simp [map_add, add_comm] } : (H × H) ≃+ (H × H)).toIntLinearEquiv
+
+private def TrianglePeriodFamilyHomologyAlgebra.inverseSecondCoordinate {H : Type*} [AddCommGroup H]
+    [Module ℤ H] (Q : H ≃ₗ[ℤ] H) : (H × H) ≃ₗ[ℤ] (H × H) :=
+  ({    toFun x := (x.1, -Q.symm x.2)
+        invFun x := (x.1, -Q x.2)
+        left_inv x := by simp
+        right_inv x := by simp
+        map_add' x y := by simp [map_add, add_comm] } : (H × H) ≃+ (H × H)).toIntLinearEquiv
+
+@[simp]
+private theorem TrianglePeriodFamilyHomologyAlgebra.inverseFirstCoordinate_apply {H : Type*}
+    [AddCommGroup H] [Module ℤ H] (P : H ≃ₗ[ℤ] H) (x : H × H) :
+    inverseFirstCoordinate P x = (-P.symm x.1, x.2) :=
+  rfl
+
+@[simp]
+private theorem TrianglePeriodFamilyHomologyAlgebra.inverseSecondCoordinate_apply {H : Type*}
+    [AddCommGroup H] [Module ℤ H] (Q : H ≃ₗ[ℤ] H) (x : H × H) :
+    inverseSecondCoordinate Q x = (x.1, -Q.symm x.2) :=
+  rfl
+
+private theorem TrianglePeriodFamilyHomologyAlgebra.delta_inverse_first {H : Type*} [AddCommGroup H]
+    [Module ℤ H] (P : H ≃ₗ[ℤ] H) (Q : H →ₗ[ℤ] H) (x : H × H) :
+    delta P.toLinearMap Q (inverseFirstCoordinate P x) = delta P.symm.toLinearMap Q x := by
+  simp only [delta_apply, inverseFirstCoordinate_apply, LinearEquiv.coe_coe, map_neg,
+    LinearEquiv.apply_symm_apply]
+  abel
+
+private theorem
+    TrianglePeriodFamilyHomologyAlgebra.delta_inverse_second {H : Type*} [AddCommGroup H]
+    [Module ℤ H] (P : H →ₗ[ℤ] H) (Q : H ≃ₗ[ℤ] H) (x : H × H) :
+    delta P Q.toLinearMap (inverseSecondCoordinate Q x) = delta P Q.symm.toLinearMap x := by
+  simp only [delta_apply, inverseSecondCoordinate_apply, LinearEquiv.coe_coe, map_neg,
+    LinearEquiv.apply_symm_apply]
+  abel
+
+public
+theorem TrianglePeriodFamilyHomologyAlgebra.range_eq_of_coordinates {H : Type*} [AddCommGroup H]
+    [Module ℤ H] (f g : (H × H) →ₗ[ℤ] H) (e : (H × H) ≃ₗ[ℤ] (H × H)) (he : ∀ x, f (e x) = g x) :
+    LinearMap.range g = LinearMap.range f := by
+  ext y
+  constructor
+  · rintro ⟨x, rfl⟩
+    exact ⟨e x, he x⟩
+  · rintro ⟨x, rfl⟩
+    refine ⟨e.symm x, ?_⟩
+    rw [← he, LinearEquiv.apply_symm_apply]
+
+private def
+    TrianglePeriodFamilyHomologyAlgebra.kernelEquivOfCoordinates {H : Type*} [AddCommGroup H]
+    [Module ℤ H] (f g : (H × H) →ₗ[ℤ] H) (e : (H × H) ≃ₗ[ℤ] (H × H)) (he : ∀ x, f (e x) = g x) :
+    LinearMap.ker g ≃ₗ[ℤ] LinearMap.ker f :=
+  ({    toFun x := ⟨e x.val, by rw [LinearMap.mem_ker, he]; exact x.property⟩
+        invFun
+          y :=
+          ⟨e.symm y.val,
+            by
+            rw [LinearMap.mem_ker, ← he, LinearEquiv.apply_symm_apply]
+            exact y.property⟩
+        left_inv x := Subtype.ext (e.symm_apply_apply x.val)
+        right_inv y := Subtype.ext (e.apply_symm_apply y.val)
+        map_add' x y := Subtype.ext (e.map_add x.val y.val) } :
+      LinearMap.ker g ≃+ LinearMap.ker f).toIntLinearEquiv
+
+private def TrianglePeriodFamilyHomologyAlgebra.integralQuotientCongr {H : Type*} [AddCommGroup H]
+    [Module ℤ H] (S T : Submodule ℤ H) (h : S = T) : (H ⧸ S) ≃ₗ[ℤ] (H ⧸ T) :=
+  ({    toEquiv :=
+          @Quotient.congr H H (Submodule.quotientRel S) (Submodule.quotientRel T) (Equiv.refl H)
+            (fun _ _ => by rw [h]; rfl)
+        map_add' := by
+          rintro ⟨x⟩ ⟨y⟩
+          rfl } :
+      (H ⧸ S) ≃+ (H ⧸ T)).toIntLinearEquiv
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/HomologyOfX/TrianglePeriodFamilyHomologyLattice.lean b/LeanPool/HopfProblem/HomologyOfX/TrianglePeriodFamilyHomologyLattice.lean
new file mode 100644
index 000000000..4ceda6087
--- /dev/null
+++ b/LeanPool/HopfProblem/HomologyOfX/TrianglePeriodFamilyHomologyLattice.lean
@@ -0,0 +1,659 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Foundations.TrianglePeriodFamilyHomologySplitting
+public import LeanPool.HopfProblem.PeriodFamily.Core4
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology3
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods6
+import all LeanPool.HopfProblem.HomologyOfX.CuspCoinvariants
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods8
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen2
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology2
+import all LeanPool.HopfProblem.PeriodFamily.Core3
+import all LeanPool.HopfProblem.HomologyOfX.TrianglePeriodFamilyHomologyAlgebra
+import all LeanPool.HopfProblem.Foundations.TrianglePeriodFamilyHomologySplitting
+import all LeanPool.HopfProblem.PeriodFamily.Core4
+
+/-!
+# Hopf problem: homology of x · triangle period family homology lattice
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem ThreefoldHomology.BoundaryFirst.boundaryMonodromy_one_coordinates
+    (i : SpecialPeriods.Threefold.Puncture)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 1) :
+    PeriodFamily.FlatTorus.singularH1Equiv
+        (MappingTorusHomology.monodromyHomologyMap (ThreefoldOverlapMappingTorus.monodromy i) 1
+          a) =
+      latticeMonodromy i *ᵥ PeriodFamily.FlatTorus.singularH1Equiv a := by
+  cases i with
+  |
+    none =>
+    change
+      PeriodFamily.FlatTorus.singularH1Equiv
+          (SingularMayerVietoris.singularHomologyMap
+            (SpecialPeriods.CuspFamily.cuspTorusHomeomorph 1 : C(RealTorus₄, RealTorus₄)) 1 a) =
+        M₀ *ᵥ PeriodFamily.FlatTorus.singularH1Equiv a
+    rw [← SpecialPeriods.triangleTorusHomeomorph_cusp_zpow 1]
+    change
+      PeriodFamily.FlatTorus.singularH1Equiv
+          (FirstHurewicz.inducedHomology
+            (SpecialPeriods.triangleTorusHomeomorph
+                (SpecialPeriods.triangleCuspGenerator ^ (1 : ℤ)) :
+              C(RealTorus₄, RealTorus₄))
+            a) =
+        _
+    rw [PeriodFamily.FlatTorus.singularH1Equiv_inducedHomology_triangle,
+      SpecialPeriods.triangleDualRepresentation_cusp_zpow_matrix,
+      SpecialPeriods.CuspFamily.cuspIntegralMatrix_one]
+  | some
+    j =>
+    change
+      PeriodFamily.FlatTorus.singularH1Equiv
+          (SingularMayerVietoris.singularHomologyMap
+            (Elliptic.flatTorusAffine j j.twist : C(RealTorus₄, RealTorus₄)) 1 a) =
+        j.matrix *ᵥ PeriodFamily.FlatTorus.singularH1Equiv a
+    rw [PeriodFamily.Boundary.flatTorusAffine_homology_triangle]
+    change
+      PeriodFamily.FlatTorus.singularH1Equiv
+          (FirstHurewicz.inducedHomology
+            (SpecialPeriods.triangleTorusHomeomorph
+                (SpecialPeriods.Triangle.ellipticGenerator j) :
+              C(RealTorus₄, RealTorus₄))
+            a) =
+        _
+    rw [PeriodFamily.FlatTorus.singularH1Equiv_inducedHomology_triangle]
+    cases j
+    · rw [SpecialPeriods.Triangle.ellipticGenerator,
+        SpecialPeriods.triangleDualRepresentation_generator₁_matrix]
+      rfl
+    · rw [SpecialPeriods.Triangle.ellipticGenerator,
+        SpecialPeriods.triangleDualRepresentation_generator₂_matrix]
+      rfl
+
+private theorem ThreefoldHomology.BoundaryFirst.boundaryWangDifference_one_coordinates
+    (i : SpecialPeriods.Threefold.Puncture)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 1) :
+    PeriodFamily.FlatTorus.singularH1Equiv
+        (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy i) 1 a) =
+      latticeDifference i (PeriodFamily.FlatTorus.singularH1Equiv a) := by
+  change
+    PeriodFamily.FlatTorus.singularH1Equiv
+        (a -
+          MappingTorusHomology.monodromyHomologyMap (ThreefoldOverlapMappingTorus.monodromy i) 1
+            a) =
+      _
+  rw [map_sub, boundaryMonodromy_one_coordinates, latticeDifference_apply]
+
+private def ThreefoldHomology.BoundaryFirst.boundaryCokernelOneCoordinatesAddEquiv_mo1973_25077
+    (i : SpecialPeriods.Threefold.Puncture) :
+    (SingularMayerVietoris.SingularHomology RealTorus₄ 1 ⧸
+        LinearMap.range
+          (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy i) 1)) ≃+
+      (Lattice ⧸ LinearMap.range (latticeDifference i)) := by
+  letI :=
+    Submodule.Quotient.module
+      (LinearMap.range
+        (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy i) 1))
+  letI := Submodule.Quotient.module (LinearMap.range (latticeDifference i))
+  exact
+    (PeriodFamily.HomologyDifference.cokernelEquivOfCommuting
+        (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy i) 1)
+        (latticeDifference i) PeriodFamily.FlatTorus.singularH1Equiv
+        PeriodFamily.FlatTorus.singularH1Equiv
+        (boundaryWangDifference_one_coordinates i)).toAddEquiv
+
+private def ThreefoldHomology.BoundaryFirst.boundaryCokernelOneCoordinates
+    (i : SpecialPeriods.Threefold.Puncture) :
+    (SingularMayerVietoris.SingularHomology RealTorus₄ 1 ⧸
+        LinearMap.range
+          (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy i)
+            1)) ≃ₗ[ℤ]
+      (Lattice ⧸ LinearMap.range (latticeDifference i)) :=
+  (boundaryCokernelOneCoordinatesAddEquiv_mo1973_25077 i).toIntLinearEquiv
+
+private def ThreefoldHomology.BoundaryFirst.latticeCokernelAddEquiv_mo1973_25080
+    (i : SpecialPeriods.Threefold.Puncture) :
+    (Lattice ⧸ LinearMap.range (latticeDifference i)) ≃+ (Fin 2 → ℤ) := by
+  letI := Submodule.Quotient.module (LinearMap.range (latticeDifference i))
+  exact (latticeCokernelEquiv i).toAddEquiv
+
+private def ThreefoldHomology.BoundaryFirst.boundaryCokernelOneEquiv
+    (i : SpecialPeriods.Threefold.Puncture) :
+    (SingularMayerVietoris.SingularHomology RealTorus₄ 1 ⧸
+        LinearMap.range
+          (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy i)
+            1)) ≃ₗ[ℤ]
+      (Fin 2 → ℤ) :=
+  ((boundaryCokernelOneCoordinates i).toAddEquiv.trans
+      (latticeCokernelAddEquiv_mo1973_25080 i)).toIntLinearEquiv
+
+private theorem ThreefoldHomology.BoundaryFirst.boundaryMonodromy_zero_identity
+    (i : SpecialPeriods.Threefold.Puncture) :
+    MappingTorusHomology.monodromyHomologyMap (ThreefoldOverlapMappingTorus.monodromy i) 0 =
+      LinearMap.id := by
+  apply LinearMap.ext
+  intro a
+  apply (PeriodTorusHigherHomology.connectedHomologyZeroEquiv RealTorus₄).injective
+  exact
+    PeriodTorusHigherHomology.connectedHomologyZeroEquiv_natural
+      (ThreefoldOverlapMappingTorus.monodromy i : C(RealTorus₄, RealTorus₄)) a
+
+private theorem ThreefoldHomology.BoundaryFirst.boundaryWangDifference_zero
+    (i : SpecialPeriods.Threefold.Puncture) :
+    MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy i) 0 = 0 := by
+  apply LinearMap.ext
+  intro a
+  change
+    a - MappingTorusHomology.monodromyHomologyMap (ThreefoldOverlapMappingTorus.monodromy i) 0 a =
+      0
+  rw [boundaryMonodromy_zero_identity, LinearMap.id_apply, sub_self]
+
+private def ThreefoldHomology.BoundaryFirst.boundaryKernelZeroEquiv
+    (i : SpecialPeriods.Threefold.Puncture) :
+    LinearMap.ker
+        (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy i) 0) ≃ₗ[ℤ]
+      ℤ :=
+  ({    toFun a := PeriodTorusHigherHomology.connectedHomologyZeroEquiv RealTorus₄ a.val
+        invFun
+          z :=
+          ⟨(PeriodTorusHigherHomology.connectedHomologyZeroEquiv RealTorus₄).symm z,
+            by
+            rw [boundaryWangDifference_zero, LinearMap.ker_zero]
+            trivial⟩
+        left_inv
+          a :=
+          Subtype.ext
+            ((PeriodTorusHigherHomology.connectedHomologyZeroEquiv RealTorus₄).symm_apply_apply
+              a.val)
+        right_inv
+          z :=
+          (PeriodTorusHigherHomology.connectedHomologyZeroEquiv RealTorus₄).apply_symm_apply z
+        map_add' a
+          b :=
+          (PeriodTorusHigherHomology.connectedHomologyZeroEquiv RealTorus₄).map_add a.val
+            b.val } :
+      LinearMap.ker
+          (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy i) 0) ≃+
+        ℤ).toIntLinearEquiv
+
+private def
+    ThreefoldHomology.BoundaryFirst.boundaryH1SplitEquiv (i : SpecialPeriods.Threefold.Puncture) :
+    SingularMayerVietoris.SingularHomology (ThreefoldOverlapMappingTorus.Boundary i) 1 ≃ₗ[ℤ]
+      ((SingularMayerVietoris.SingularHomology RealTorus₄ 1 ⧸
+          LinearMap.range
+            (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy i) 1)) ×
+        LinearMap.ker
+          (MappingTorusHomology.wangDifference (ThreefoldOverlapMappingTorus.monodromy i) 0)) := by
+  letI := Module.Free.of_equiv (boundaryKernelZeroEquiv i).toAddEquiv.symm.toIntLinearEquiv
+  exact
+    TrianglePeriodFamilyHomologySplitting.freeRightSplitEquiv
+      (MappingTorusHomology.cokernelInclusion (ThreefoldOverlapMappingTorus.monodromy i) 1)
+      (MappingTorusHomology.kernelBoundary (ThreefoldOverlapMappingTorus.monodromy i) 0)
+      (LinearMap.exact_iff.mpr
+        (MappingTorusHomology.cokernelInclusion_range_eq_ker_kernelBoundary
+            (ThreefoldOverlapMappingTorus.monodromy i) 0).symm)
+      (MappingTorusHomology.cokernelInclusion_injective (ThreefoldOverlapMappingTorus.monodromy i)
+        1)
+      (MappingTorusHomology.kernelBoundary_surjective (ThreefoldOverlapMappingTorus.monodromy i)
+        0)
+
+private def ThreefoldHomology.BoundaryFirst.boundaryH1ProductEquiv
+    (i : SpecialPeriods.Threefold.Puncture) :
+    SingularMayerVietoris.SingularHomology (ThreefoldOverlapMappingTorus.Boundary i) 1 ≃ₗ[ℤ]
+      ((Fin 2 → ℤ) × ℤ) :=
+  ((boundaryH1SplitEquiv i).toAddEquiv.trans
+      ((boundaryCokernelOneEquiv i).toAddEquiv.prodCongr
+        (boundaryKernelZeroEquiv i).toAddEquiv)).toIntLinearEquiv
+
+private def
+    ThreefoldHomology.BoundaryFirst.twoFibreOneBaseEquiv : ((Fin 2 → ℤ) × ℤ) ≃ₗ[ℤ] (Fin 3 → ℤ) :=
+  (((AddEquiv.refl (Fin 2 → ℤ)).prodCongr
+          (LinearEquiv.funUnique (Fin 1) ℤ ℤ).symm.toAddEquiv).trans
+      (TrianglePeriodFamilyHomologyFreeCoordinates.freeCoordinateSumEquiv 2
+          1).toAddEquiv).toIntLinearEquiv
+
+private def
+    ThreefoldHomology.BoundaryFirst.boundaryH1Equiv (i : SpecialPeriods.Threefold.Puncture) :
+    SingularMayerVietoris.SingularHomology (ThreefoldOverlapMappingTorus.Boundary i) 1 ≃ₗ[ℤ]
+      (Fin 3 → ℤ) :=
+  (boundaryH1ProductEquiv i).trans twoFibreOneBaseEquiv
+
+private def ThreefoldHomology.BoundaryFirst.overlapH1Equiv (i : SpecialPeriods.Threefold.Puncture) :
+    SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) 1 ≃ₗ[ℤ]
+      (Fin 3 → ℤ) :=
+  (ThreefoldOverlapMappingTorus.overlapHomologyEquiv i 1).trans (boundaryH1Equiv i)
+
+private theorem
+    ThreefoldHomology.BoundaryFirst.overlapH1_free (i : SpecialPeriods.Threefold.Puncture) :
+    Module.Free ℤ
+      (SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) 1) :=
+  Module.Free.of_equiv (overlapH1Equiv i).symm
+
+private theorem
+    ThreefoldHomology.BoundaryFirst.overlapH1_finite (i : SpecialPeriods.Threefold.Puncture) :
+    Module.Finite ℤ
+      (SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) 1) :=
+  Module.Finite.of_surjective (overlapH1Equiv i).symm.toLinearMap
+    (overlapH1Equiv i).symm.surjective
+
+private theorem ThreefoldHomology.BoundaryFirst.overlapH1_finrank
+    (i : SpecialPeriods.Threefold.Puncture) :
+    Module.finrank ℤ
+        (SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) 1) =
+      3 := by
+  rw [(overlapH1Equiv i).finrank_eq]
+  simp
+
+private theorem ThreefoldHomology.Finiteness.finite_pi_int {ι : Type*} [Finite ι] (M : ι → Type*)
+    [∀ i, AddCommGroup (M i)] [∀ i, Module ℤ (M i)] [∀ i, Module.Finite ℤ (M i)]
+    [piModule : Module ℤ (∀ i, M i)] : Module.Finite ℤ (∀ i, M i) := by
+  have h : piModule = Pi.module ι M ℤ := Subsingleton.elim _ _
+  cases h
+  exact Module.Finite.pi
+
+private theorem ThreefoldHomology.Finiteness.finite_prod_int (M N : Type*) [AddCommGroup M]
+    [AddCommGroup N] [Module ℤ M] [Module ℤ N] [Module.Finite ℤ M] [Module.Finite ℤ N]
+    [prodModule : Module ℤ (M × N)] : Module.Finite ℤ (M × N) := by
+  have h : prodModule = (Prod.instModule : Module ℤ (M × N)) := Subsingleton.elim _ _
+  cases h
+  exact Module.Finite.prod
+
+private theorem ThreefoldHomologyFreeProducts.free_pi_int {ι : Type*} [Finite ι] (M : ι → Type*)
+    [∀ i, AddCommGroup (M i)] [∀ i, Module ℤ (M i)] [∀ i, Module.Free ℤ (M i)]
+    [piModule : Module ℤ (∀ i, M i)] : Module.Free ℤ (∀ i, M i) := by
+  have h : piModule = Pi.module ι M ℤ := Subsingleton.elim _ _
+  cases h
+  infer_instance
+
+private theorem ThreefoldHomologyFreeProducts.free_prod_int (M N : Type*) [AddCommGroup M]
+    [AddCommGroup N] [Module ℤ M] [Module ℤ N] [Module.Free ℤ M] [Module.Free ℤ N]
+    [prodModule : Module ℤ (M × N)] : Module.Free ℤ (M × N) := by
+  have h : prodModule = (Prod.instModule : Module ℤ (M × N)) := Subsingleton.elim _ _
+  cases h
+  infer_instance
+
+public
+theorem ThreefoldHomologyFreeProducts.finrank_pi_int {ι : Type*} [Fintype ι] (M : ι → Type*)
+    [∀ i, AddCommGroup (M i)] [∀ i, Module ℤ (M i)] [∀ i, Module.Free ℤ (M i)]
+    [∀ i, Module.Finite ℤ (M i)] [piModule : Module ℤ (∀ i, M i)] :
+    Module.finrank ℤ (∀ i, M i) = ∑ i, Module.finrank ℤ (M i) := by
+  have h : piModule = Pi.module ι M ℤ := Subsingleton.elim _ _
+  cases h
+  exact Module.finrank_pi_fintype ℤ
+
+private theorem ThreefoldHomologyFreeProducts.finrank_prod_int (M N : Type*) [AddCommGroup M]
+    [AddCommGroup N] [Module ℤ M] [Module ℤ N] [Module.Free ℤ M] [Module.Free ℤ N]
+    [Module.Finite ℤ M] [Module.Finite ℤ N] [prodModule : Module ℤ (M × N)] :
+    Module.finrank ℤ (M × N) = Module.finrank ℤ M + Module.finrank ℤ N := by
+  have h : prodModule = (Prod.instModule : Module ℤ (M × N)) := Subsingleton.elim _ _
+  cases h
+  exact Module.finrank_prod
+
+private def TrianglePeriodFamilyHomologyAlgebra.reducedCokernelToMiddle {High Middle : Type u}
+    [AddCommGroup High] [AddCommGroup Middle] [Module ℤ High] [Module ℤ Middle]
+    (P Q : High →ₗ[ℤ] High) (j : (High × High) →ₗ[ℤ] Middle)
+    (hj : Function.Exact (overlapMap P Q) j) :
+    (High ⧸ LinearMap.range (delta P Q)) →ₗ[ℤ] Middle :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    ((cokernelToMiddle (overlapMap P Q) j hj).toAddMonoidHom.comp
+      (overlapCokernelEquiv P Q).symm.toAddEquiv.toAddMonoidHom)
+
+@[simp]
+private theorem
+    TrianglePeriodFamilyHomologyAlgebra.reducedCokernelToMiddle_apply {High Middle : Type u}
+    [AddCommGroup High] [AddCommGroup Middle] [Module ℤ High] [Module ℤ Middle]
+    (P Q : High →ₗ[ℤ] High) (j : (High × High) →ₗ[ℤ] Middle)
+    (hj : Function.Exact (overlapMap P Q) j) (q : High ⧸ LinearMap.range (delta P Q)) :
+    reducedCokernelToMiddle P Q j hj q =
+      cokernelToMiddle (overlapMap P Q) j hj ((overlapCokernelEquiv P Q).symm q) :=
+  rfl
+
+private theorem
+    TrianglePeriodFamilyHomologyAlgebra.reducedCokernelToMiddle_mk {High Middle : Type u}
+    [AddCommGroup High] [AddCommGroup Middle] [Module ℤ High] [Module ℤ Middle]
+    (P Q : High →ₗ[ℤ] High) (j : (High × High) →ₗ[ℤ] Middle)
+    (hj : Function.Exact (overlapMap P Q) j) (y : High) :
+    reducedCokernelToMiddle P Q j hj (Submodule.Quotient.mk y) = j (0, -y) := by
+  rw [reducedCokernelToMiddle_apply, overlapCokernelEquiv_symm_mk]
+  rfl
+
+private theorem TrianglePeriodFamilyHomologyAlgebra.reducedCokernelToMiddle_injective
+    {High Middle : Type u} [AddCommGroup High] [AddCommGroup Middle] [Module ℤ High]
+    [Module ℤ Middle] (P Q : High →ₗ[ℤ] High) (j : (High × High) →ₗ[ℤ] Middle)
+    (hj : Function.Exact (overlapMap P Q) j) :
+    Function.Injective (reducedCokernelToMiddle P Q j hj) :=
+  (cokernelToMiddle_injective (overlapMap P Q) j hj).comp
+    (overlapCokernelEquiv P Q).symm.injective
+
+private def TrianglePeriodFamilyHomologyAlgebra.middleToReducedKernel {Low Middle : Type u}
+    [AddCommGroup Low] [AddCommGroup Middle] [Module ℤ Low] [Module ℤ Middle]
+    (P Q : Low →ₗ[ℤ] Low) (δ : Middle →ₗ[ℤ] (Low × (Low × Low)))
+    (hδ : Function.Exact δ (overlapMap P Q)) : Middle →ₗ[ℤ] LinearMap.ker (delta P Q) :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    ((overlapKerEquiv P Q).toAddEquiv.toAddMonoidHom.comp
+      (middleToKernel δ (overlapMap P Q) hδ).toAddMonoidHom)
+
+@[simp]
+private theorem
+    TrianglePeriodFamilyHomologyAlgebra.middleToReducedKernel_apply {Low Middle : Type u}
+    [AddCommGroup Low] [AddCommGroup Middle] [Module ℤ Low] [Module ℤ Middle]
+    (P Q : Low →ₗ[ℤ] Low) (δ : Middle →ₗ[ℤ] (Low × (Low × Low)))
+    (hδ : Function.Exact δ (overlapMap P Q)) (m : Middle) :
+    middleToReducedKernel P Q δ hδ m =
+      overlapKerEquiv P Q (middleToKernel δ (overlapMap P Q) hδ m) :=
+  rfl
+
+private theorem
+    TrianglePeriodFamilyHomologyAlgebra.middleToReducedKernel_surjective {Low Middle : Type u}
+    [AddCommGroup Low] [AddCommGroup Middle] [Module ℤ Low] [Module ℤ Middle]
+    (P Q : Low →ₗ[ℤ] Low) (δ : Middle →ₗ[ℤ] (Low × (Low × Low)))
+    (hδ : Function.Exact δ (overlapMap P Q)) :
+    Function.Surjective (middleToReducedKernel P Q δ hδ) :=
+  (overlapKerEquiv P Q).surjective.comp (middleToKernel_surjective δ (overlapMap P Q) hδ)
+
+private theorem
+    TrianglePeriodFamilyHomologyAlgebra.reducedExtension_exact {High Low Middle : Type u}
+    [AddCommGroup High] [AddCommGroup Low] [AddCommGroup Middle] [Module ℤ High] [Module ℤ Low]
+    [Module ℤ Middle] (PHigh QHigh : High →ₗ[ℤ] High) (PLow QLow : Low →ₗ[ℤ] Low)
+    (j : (High × High) →ₗ[ℤ] Middle) (δ : Middle →ₗ[ℤ] (Low × (Low × Low)))
+    (hj : Function.Exact (overlapMap PHigh QHigh) j) (hjδ : Function.Exact j δ)
+    (hδ : Function.Exact δ (overlapMap PLow QLow)) :
+    Function.Exact (reducedCokernelToMiddle PHigh QHigh j hj)
+      (middleToReducedKernel PLow QLow δ hδ) := by
+  have hex :=
+    cokernelToMiddle_middleToKernel_exact (overlapMap PHigh QHigh) j δ (overlapMap PLow QLow) hj
+      hjδ hδ
+  intro m
+  constructor
+  · intro hm
+    have hzero : middleToKernel δ (overlapMap PLow QLow) hδ m = 0 := by
+      apply (overlapKerEquiv PLow QLow).injective
+      exact hm.trans (overlapKerEquiv PLow QLow).map_zero.symm
+    obtain ⟨q, hq⟩ := (hex m).mp hzero
+    refine ⟨overlapCokernelEquiv PHigh QHigh q, ?_⟩
+    rw [reducedCokernelToMiddle_apply, LinearEquiv.symm_apply_apply]
+    exact hq
+  · rintro ⟨q, rfl⟩
+    have hzero :
+      middleToKernel δ (overlapMap PLow QLow) hδ (reducedCokernelToMiddle PHigh QHigh j hj q) =
+        0 :=
+      (hex _).mpr ⟨(overlapCokernelEquiv PHigh QHigh).symm q, rfl⟩
+    rw [middleToReducedKernel_apply, hzero, map_zero]
+
+private def TrianglePeriodFamilyHomologyLattice.deltaTwo :
+    ((Fin 6 → ℤ) × (Fin 6 → ℤ)) →ₗ[ℤ] (Fin 6 → ℤ) :=
+  TrianglePeriodFamilyHomologyAlgebra.delta PeriodTorusHigherHomologyExterior.squareA₁.mulVecLin
+    PeriodTorusHigherHomologyExterior.squareA₂.mulVecLin
+
+private theorem TrianglePeriodFamilyHomologyLattice.deltaTwo_apply (b c : Fin 6 → ℤ) :
+    deltaTwo (b, c) =
+      ![-b 0 + b 1 - c 0 - c 1, -b 0 - 2 * b 1 + c 0 - c 1, b 0 + c 1, -6 * b 0 - 6 * c 1,
+        6 * b 0 + 2 * b 1 + 6 * b 2 - b 3 - b 4 + b 5 + 3 * c 1 - c 4 - c 5,
+        -8 * b 0 - 2 * b 1 - 6 * b 2 + b 3 - b 4 - 2 * b 5 - 3 * c 0 - 6 * c 1 - 6 * c 2 + c 3 +
+            c 4 -
+          c 5] := by
+  change
+    (PeriodTorusHigherHomologyExterior.squareA₁.mulVecLin b - b) +
+        (PeriodTorusHigherHomologyExterior.squareA₂.mulVecLin c - c) =
+      _
+  rw [PeriodTorusHigherHomologyExterior.squareA₁_eq,
+    PeriodTorusHigherHomologyExterior.squareA₂_eq]
+  ext i
+  fin_cases i <;> simp [dotProduct, Fin.sum_univ_succ, Matrix.vecHead, Matrix.vecTail] <;> ring
+
+private def TrianglePeriodFamilyHomologyLattice.functionalTwo : (Fin 6 → ℤ) →ₗ[ℤ] ℤ
+    where
+  toFun x := 6 * x 2 + x 3
+  map_add' x y := by simp; ring
+  map_smul' n x := by simp; ring
+
+@[simp]
+private theorem TrianglePeriodFamilyHomologyLattice.functionalTwo_apply (x : Fin 6 → ℤ) :
+    functionalTwo x = 6 * x 2 + x 3 :=
+  rfl
+
+private theorem TrianglePeriodFamilyHomologyLattice.functionalTwo_single_three (z : ℤ) :
+    functionalTwo ![0, 0, 0, z, 0, 0] = z := by simp
+
+private theorem TrianglePeriodFamilyHomologyLattice.functionalTwo_surjective :
+    Function.Surjective functionalTwo := by
+  intro z
+  exact ⟨![0, 0, 0, z, 0, 0], functionalTwo_single_three z⟩
+
+private def TrianglePeriodFamilyHomologyLattice.deltaTwoLift :
+    (Fin 6 → ℤ) →ₗ[ℤ] ((Fin 6 → ℤ) × (Fin 6 → ℤ)) :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun
+        x :=
+        (![0, -x 0 - x 1 - 2 * x 2, 0, -2 * x 0 - 2 * x 1 - x 2 - x 4, 0, 0],
+          ![-2 * x 0 - x 1 - 3 * x 2, x 2, 0, -6 * x 0 - 3 * x 1 - 6 * x 2 + x 4 + x 5, 0, 0])
+      map_zero' := by apply Prod.ext <;> funext i <;> fin_cases i <;> simp
+      map_add' x y := by apply Prod.ext <;> funext i <;> fin_cases i <;> simp <;> ring }
+
+@[simp]
+private theorem TrianglePeriodFamilyHomologyLattice.deltaTwoLift_apply (x : Fin 6 → ℤ) :
+    deltaTwoLift x =
+      (![0, -x 0 - x 1 - 2 * x 2, 0, -2 * x 0 - 2 * x 1 - x 2 - x 4, 0, 0],
+        ![-2 * x 0 - x 1 - 3 * x 2, x 2, 0, -6 * x 0 - 3 * x 1 - 6 * x 2 + x 4 + x 5, 0, 0]) :=
+  rfl
+
+private theorem TrianglePeriodFamilyHomologyLattice.deltaTwo_deltaTwoLift (x : Fin 6 → ℤ) :
+    deltaTwo (deltaTwoLift x) = ![x 0, x 1, x 2, -6 * x 2, x 4, x 5] := by
+  rw [deltaTwoLift_apply, deltaTwo_apply]
+  ext i
+  fin_cases i <;> simp <;> ring
+
+private theorem TrianglePeriodFamilyHomologyLattice.deltaTwo_lift (x : Fin 6 → ℤ)
+    (hx : functionalTwo x = 0) : deltaTwo (deltaTwoLift x) = x := by
+  rw [deltaTwo_deltaTwoLift]
+  have hx3 : -6 * x 2 = x 3 := by
+    change 6 * x 2 + x 3 = 0 at hx
+    omega
+  ext i
+  fin_cases i <;> simp [hx3]
+
+private theorem TrianglePeriodFamilyHomologyLattice.functionalTwo_deltaTwo
+    (x : (Fin 6 → ℤ) × (Fin 6 → ℤ)) : functionalTwo (deltaTwo x) = 0 := by
+  rcases x with ⟨b, c⟩
+  rw [deltaTwo_apply, functionalTwo_apply]
+  simp
+  ring
+
+private theorem TrianglePeriodFamilyHomologyLattice.deltaTwo_range_eq_ker :
+    LinearMap.range deltaTwo = LinearMap.ker functionalTwo := by
+  ext x
+  constructor
+  · rintro ⟨y, rfl⟩
+    exact functionalTwo_deltaTwo y
+  · intro hx
+    exact ⟨deltaTwoLift x, deltaTwo_lift x hx⟩
+
+private def TrianglePeriodFamilyHomologyLattice.cokernelTwoEquiv :
+    ((Fin 6 → ℤ) ⧸ LinearMap.range deltaTwo) ≃ₗ[ℤ] ℤ :=
+  ((Submodule.quotEquivOfEq _ _ deltaTwo_range_eq_ker).toAddEquiv.trans
+      (functionalTwo.quotKerEquivOfSurjective
+          functionalTwo_surjective).toAddEquiv).toIntLinearEquiv
+
+@[simp]
+private theorem TrianglePeriodFamilyHomologyLattice.cokernelTwoEquiv_mk (x : Fin 6 → ℤ) :
+    cokernelTwoEquiv (Submodule.Quotient.mk x) = functionalTwo x := by
+  change
+    functionalTwo.quotKerEquivOfSurjective functionalTwo_surjective
+        (Submodule.quotEquivOfEq _ _ deltaTwo_range_eq_ker (Submodule.Quotient.mk x)) =
+      _
+  rw [Submodule.quotEquivOfEq_mk, LinearMap.quotKerEquivOfSurjective_apply_mk]
+
+@[simp]
+private theorem TrianglePeriodFamilyHomologyLattice.det_A₁ : A₁.det = 1 := by
+  rw [A₁_eq_transpose_sq, Matrix.det_transpose, Matrix.det_pow, det_T₁, one_pow]
+
+@[simp]
+private theorem TrianglePeriodFamilyHomologyLattice.det_A₂ : A₂.det = 1 := by
+  rw [A₂_eq_transpose_cube, Matrix.det_transpose, Matrix.det_pow, det_T₂, one_pow]
+
+private def TrianglePeriodFamilyHomologyLattice.deltaZero : (ℤ × ℤ) →ₗ[ℤ] ℤ :=
+  TrianglePeriodFamilyHomologyAlgebra.delta (LinearMap.id : ℤ →ₗ[ℤ] ℤ) (LinearMap.id : ℤ →ₗ[ℤ] ℤ)
+
+@[simp]
+private theorem TrianglePeriodFamilyHomologyLattice.deltaZero_eq_zero : deltaZero = 0 := by
+  apply LinearMap.ext
+  intro x
+  simp [deltaZero, TrianglePeriodFamilyHomologyAlgebra.delta_apply]
+
+private def TrianglePeriodFamilyHomologyLattice.deltaFour : (ℤ × ℤ) →ₗ[ℤ] ℤ :=
+  TrianglePeriodFamilyHomologyAlgebra.delta (A₁.det • (LinearMap.id : ℤ →ₗ[ℤ] ℤ))
+    (A₂.det • (LinearMap.id : ℤ →ₗ[ℤ] ℤ))
+
+@[simp]
+private theorem TrianglePeriodFamilyHomologyLattice.deltaFour_eq_zero : deltaFour = 0 := by
+  rw [deltaFour, det_A₁, det_A₂, one_smul]
+  exact deltaZero_eq_zero
+
+private def
+    TrianglePeriodFamilyHomologyLattice.kernelZeroEquiv : LinearMap.ker deltaZero ≃ₗ[ℤ] (ℤ × ℤ) :=
+  ({    toFun x := x.val
+        invFun x := ⟨x, by simp⟩
+        left_inv _ := Subtype.ext rfl
+        right_inv _ := rfl
+        map_add' _ _ := rfl } : LinearMap.ker deltaZero ≃+ (ℤ × ℤ)).toIntLinearEquiv
+
+private def
+    TrianglePeriodFamilyHomologyLattice.kernelFourEquiv : LinearMap.ker deltaFour ≃ₗ[ℤ] (ℤ × ℤ) :=
+  ({    toFun x := x.val
+        invFun x := ⟨x, by simp⟩
+        left_inv _ := Subtype.ext rfl
+        right_inv _ := rfl
+        map_add' _ _ := rfl } : LinearMap.ker deltaFour ≃+ (ℤ × ℤ)).toIntLinearEquiv
+
+
+private def TrianglePeriodFamilyHomologyLattice.cokernelFourEquiv :
+    (ℤ ⧸ LinearMap.range deltaFour) ≃ₗ[ℤ] ℤ :=
+  ((LinearMap.range deltaFour).quotEquivOfEqBot (by simp)).toAddEquiv.toIntLinearEquiv
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private theorem TrianglePeriodFamilyHomologyLattice.kernel_finite_of_finite {M N : Type u}
+    [AddCommGroup M] [AddCommGroup N] [Module ℤ M] [Module ℤ N] [Module.Finite ℤ M]
+    (f : M →ₗ[ℤ] N) : Module.Finite ℤ (LinearMap.ker f) :=
+  inferInstance
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private theorem TrianglePeriodFamilyHomologyLattice.kernel_free_of_finite_free {M N : Type u}
+    [AddCommGroup M] [AddCommGroup N] [Module ℤ M] [Module ℤ N] [Module.Finite ℤ M]
+    [Module.Free ℤ M] (f : M →ₗ[ℤ] N) : Module.Free ℤ (LinearMap.ker f) := by
+  let := kernel_finite_of_finite f
+  infer_instance
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private theorem
+    TrianglePeriodFamilyHomologyLattice.kernel_finrank_add_of_cokernelEquiv {M N : Type u}
+    [AddCommGroup M] [AddCommGroup N] [Module ℤ M] [Module ℤ N] [Module.Finite ℤ M]
+    [Module.Finite ℤ N] (f : M →ₗ[ℤ] N) (e : (N ⧸ LinearMap.range f) ≃ₗ[ℤ] ℤ) :
+    Module.finrank ℤ (LinearMap.ker f) + Module.finrank ℤ N = Module.finrank ℤ M + 1 := by
+  have hsource := (LinearMap.ker f).finrank_quotient_add_finrank
+  have htarget := (LinearMap.range f).finrank_quotient_add_finrank
+  have hquot : Module.finrank ℤ (M ⧸ LinearMap.ker f) = Module.finrank ℤ (LinearMap.range f) :=
+    f.quotKerEquivRange.finrank_eq
+  have hcoker : Module.finrank ℤ (N ⧸ LinearMap.range f) = 1 := by
+    rw [e.finrank_eq]
+    simp
+  omega
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def
+    TrianglePeriodFamilyHomologyLattice.kernelEquivOfFinrankEq {M N : Type u} [AddCommGroup M]
+    [AddCommGroup N] [Module ℤ M] [Module ℤ N] [Module.Finite ℤ M] [Module.Free ℤ M]
+    (f : M →ₗ[ℤ] N) (r : ℕ) (hr : Module.finrank ℤ (LinearMap.ker f) = r) :
+    LinearMap.ker f ≃ₗ[ℤ] (Fin r → ℤ) := by
+  let := kernel_finite_of_finite f
+  let := kernel_free_of_finite_free f
+  apply LinearEquiv.ofFinrankEq
+  simpa using hr
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private theorem TrianglePeriodFamilyHomologyLattice.kernelOne_finrank :
+    Module.finrank ℤ (LinearMap.ker deltaOne) = 5 := by
+  have h := kernel_finrank_add_of_cokernelEquiv deltaOne cokernelOneEquiv
+  norm_num [Module.finrank_prod, Module.finrank_fin_fun] at h
+  omega
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private theorem TrianglePeriodFamilyHomologyLattice.kernelTwo_finrank :
+    Module.finrank ℤ (LinearMap.ker deltaTwo) = 7 := by
+  have h := kernel_finrank_add_of_cokernelEquiv deltaTwo cokernelTwoEquiv
+  norm_num [Module.finrank_prod, Module.finrank_fin_fun] at h
+  omega
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private theorem TrianglePeriodFamilyHomologyLattice.kernelThree_finrank :
+    Module.finrank ℤ (LinearMap.ker deltaThree) = 5 := by
+  have h := kernel_finrank_add_of_cokernelEquiv deltaThree cokernelThreeEquiv
+  norm_num [Module.finrank_prod, Module.finrank_fin_fun] at h
+  omega
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def TrianglePeriodFamilyHomologyLattice.kernelOneEquiv :
+    LinearMap.ker deltaOne ≃ₗ[ℤ] (Fin 5 → ℤ) :=
+  kernelEquivOfFinrankEq deltaOne 5 kernelOne_finrank
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def TrianglePeriodFamilyHomologyLattice.kernelTwoEquiv :
+    LinearMap.ker deltaTwo ≃ₗ[ℤ] (Fin 7 → ℤ) :=
+  kernelEquivOfFinrankEq deltaTwo 7 kernelTwo_finrank
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def TrianglePeriodFamilyHomologyLattice.kernelThreeEquiv :
+    LinearMap.ker deltaThree ≃ₗ[ℤ] (Fin 5 → ℤ) :=
+  kernelEquivOfFinrankEq deltaThree 5 kernelThree_finrank
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/HomologyTheory/FirstHurewicz1.lean b/LeanPool/HopfProblem/HomologyTheory/FirstHurewicz1.lean
new file mode 100644
index 000000000..9b29e04f4
--- /dev/null
+++ b/LeanPool/HopfProblem/HomologyTheory/FirstHurewicz1.lean
@@ -0,0 +1,315 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology3
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology3
+
+/-!
+# Hopf problem: homology theory · first hurewicz 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+public
+theorem SphereHomology.singularHomologyMap_zero_injective {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] [PathConnectedSpace X] [PathConnectedSpace Y] (f : C(X, Y)) :
+    Function.Injective (SingularMayerVietoris.singularHomologyMap f 0) := by
+  intro a b h
+  apply (PeriodTorusHigherHomology.connectedHomologyZeroEquiv X).injective
+  simpa only [PeriodTorusHigherHomology.connectedHomologyZeroEquiv_natural] using
+    congrArg (PeriodTorusHigherHomology.connectedHomologyZeroEquiv Y) h
+
+private theorem SphereHomology.singularHomologyMap_zero_surjective {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] [PathConnectedSpace X] [PathConnectedSpace Y] (f : C(X, Y)) :
+    Function.Surjective (SingularMayerVietoris.singularHomologyMap f 0) := by
+  intro b
+  refine
+    ⟨(PeriodTorusHigherHomology.connectedHomologyZeroEquiv X).symm
+        (PeriodTorusHigherHomology.connectedHomologyZeroEquiv Y b),
+      ?_⟩
+  apply (PeriodTorusHigherHomology.connectedHomologyZeroEquiv Y).injective
+  rw [PeriodTorusHigherHomology.connectedHomologyZeroEquiv_natural, LinearEquiv.apply_symm_apply]
+
+private theorem SphereHomology.singularHomologyMap_zero_bijective {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] [PathConnectedSpace X] [PathConnectedSpace Y] (f : C(X, Y)) :
+    Function.Bijective (SingularMayerVietoris.singularHomologyMap f 0) :=
+  ⟨singularHomologyMap_zero_injective f, singularHomologyMap_zero_surjective f⟩
+
+private theorem SphereHomology.leftHomologyMap_zero_injective {X : Type} [TopologicalSpace X]
+    (U V : Set X) [PathConnectedSpace (U ∩ V : Set X)] [PathConnectedSpace U] :
+    Function.Injective (SingularMayerVietoris.leftHomologyMap U V 0) := by
+  intro a b h
+  apply
+    singularHomologyMap_zero_injective
+      (ContinuousMap.inclusion (Set.inter_subset_left : U ∩ V ⊆ U))
+  simpa only [SingularMayerVietoris.leftHomologyMap_apply] using congrArg Prod.fst h
+
+private theorem
+    SphereHomology.leftHomologyMap_zero_ker {X : Type} [TopologicalSpace X] (U V : Set X)
+    [PathConnectedSpace (U ∩ V : Set X)] [PathConnectedSpace U] :
+    LinearMap.ker (SingularMayerVietoris.leftHomologyMap U V 0) = ⊥ :=
+  LinearMap.ker_eq_bot.mpr (leftHomologyMap_zero_injective U V)
+
+private def FirstHurewicz.lowerTriangleMap : C(Simplex 2, unitInterval × unitInterval)
+    where
+  toFun s := (simplexCoordinate 2 2 s, unitInterval.symm (simplexCoordinate 2 0 s))
+  continuous_toFun :=
+    (simplexCoordinate 2 2).continuous.prodMk
+      (unitInterval.continuous_symm.comp (simplexCoordinate 2 0).continuous)
+
+private def FirstHurewicz.upperTriangleMap : C(Simplex 2, unitInterval × unitInterval)
+    where
+  toFun s := (unitInterval.symm (simplexCoordinate 2 0 s), simplexCoordinate 2 2 s)
+  continuous_toFun :=
+    (unitInterval.continuous_symm.comp (simplexCoordinate 2 0).continuous).prodMk
+      (simplexCoordinate 2 2).continuous
+
+private theorem FirstHurewicz.lowerTriangle_face_zero (s : Simplex 1) :
+    lowerTriangleMap (simplexFace 1 0 s) = (simplexCoordinate 1 1 s, 1) := by
+  apply Prod.ext <;> apply Subtype.ext
+  · change simplexFace 1 0 s 2 = s 1
+    exact congrFun (simplexFace_one_zero s) 2
+  · change 1 - simplexFace 1 0 s 0 = 1
+    rw [simplexFace_apply_self]
+    ring
+
+private theorem FirstHurewicz.lowerTriangle_face_one (s : Simplex 1) :
+    lowerTriangleMap (simplexFace 1 1 s) = (simplexCoordinate 1 1 s, simplexCoordinate 1 1 s) := by
+  apply Prod.ext <;> apply Subtype.ext
+  · change simplexFace 1 1 s 2 = s 1
+    exact congrFun (simplexFace_one_one s) 2
+  · change 1 - simplexFace 1 1 s 0 = s 1
+    have h0 : simplexFace 1 1 s 0 = s 0 := congrFun (simplexFace_one_one s) 0
+    rw [h0]
+    linarith [stdSimplex.add_eq_one s]
+
+private theorem FirstHurewicz.lowerTriangle_face_two (s : Simplex 1) :
+    lowerTriangleMap (simplexFace 1 2 s) = (0, simplexCoordinate 1 1 s) := by
+  apply Prod.ext <;> apply Subtype.ext
+  · change simplexFace 1 2 s 2 = 0
+    exact simplexFace_apply_self 1 2 s
+  · change 1 - simplexFace 1 2 s 0 = s 1
+    have h0 : simplexFace 1 2 s 0 = s 0 := congrFun (simplexFace_one_two s) 0
+    rw [h0]
+    linarith [stdSimplex.add_eq_one s]
+
+private theorem FirstHurewicz.upperTriangle_face_zero (s : Simplex 1) :
+    upperTriangleMap (simplexFace 1 0 s) = (1, simplexCoordinate 1 1 s) := by
+  apply Prod.ext <;> apply Subtype.ext
+  · change 1 - simplexFace 1 0 s 0 = 1
+    rw [simplexFace_apply_self]
+    ring
+  · change simplexFace 1 0 s 2 = s 1
+    exact congrFun (simplexFace_one_zero s) 2
+
+private theorem FirstHurewicz.upperTriangle_face_one (s : Simplex 1) :
+    upperTriangleMap (simplexFace 1 1 s) = (simplexCoordinate 1 1 s, simplexCoordinate 1 1 s) := by
+  apply Prod.ext <;> apply Subtype.ext
+  · change 1 - simplexFace 1 1 s 0 = s 1
+    have h0 : simplexFace 1 1 s 0 = s 0 := congrFun (simplexFace_one_one s) 0
+    rw [h0]
+    linarith [stdSimplex.add_eq_one s]
+  · change simplexFace 1 1 s 2 = s 1
+    exact congrFun (simplexFace_one_one s) 2
+
+private theorem FirstHurewicz.upperTriangle_face_two (s : Simplex 1) :
+    upperTriangleMap (simplexFace 1 2 s) = (simplexCoordinate 1 1 s, 0) := by
+  apply Prod.ext <;> apply Subtype.ext
+  · change 1 - simplexFace 1 2 s 0 = s 1
+    have h0 : simplexFace 1 2 s 0 = s 0 := congrFun (simplexFace_one_two s) 0
+    rw [h0]
+    linarith [stdSimplex.add_eq_one s]
+  · change simplexFace 1 2 s 2 = 0
+    exact simplexFace_apply_self 1 2 s
+
+private def
+    FirstHurewicz.homotopyLowerSimplex {X : Type*} [TopologicalSpace X] {x y : X} {p q : Path x y}
+    (H : p.Homotopy q) : C(Simplex 2, X) :=
+  H.toHomotopy.toContinuousMap.comp lowerTriangleMap
+
+private def
+    FirstHurewicz.homotopyUpperSimplex {X : Type*} [TopologicalSpace X] {x y : X} {p q : Path x y}
+    (H : p.Homotopy q) : C(Simplex 2, X) :=
+  H.toHomotopy.toContinuousMap.comp upperTriangleMap
+
+private def FirstHurewicz.homotopyDiagonalSimplex {X : Type*} [TopologicalSpace X] {x y : X}
+    {p q : Path x y} (H : p.Homotopy q) : C(Simplex 1, X)
+    where
+  toFun s := H (simplexCoordinate 1 1 s, simplexCoordinate 1 1 s)
+  continuous_toFun :=
+    H.continuous.comp
+      ((simplexCoordinate 1 1).continuous.prodMk (simplexCoordinate 1 1).continuous)
+
+@[simp]
+private theorem
+    FirstHurewicz.homotopyLowerSimplex_face_zero {X : Type*} [TopologicalSpace X] {x y : X}
+    {p q : Path x y} (H : p.Homotopy q) :
+    (homotopyLowerSimplex H).comp (simplexFace 1 0) = ContinuousMap.const (Simplex 1) y := by
+  apply ContinuousMap.ext
+  intro s
+  change H (lowerTriangleMap (simplexFace 1 0 s)) = y
+  rw [lowerTriangle_face_zero, H.target]
+
+@[simp]
+private theorem
+    FirstHurewicz.homotopyLowerSimplex_face_one {X : Type*} [TopologicalSpace X] {x y : X}
+    {p q : Path x y} (H : p.Homotopy q) :
+    (homotopyLowerSimplex H).comp (simplexFace 1 1) = homotopyDiagonalSimplex H := by
+  apply ContinuousMap.ext
+  intro s
+  change H (lowerTriangleMap (simplexFace 1 1 s)) = _
+  rw [lowerTriangle_face_one]
+  rfl
+
+@[simp]
+private theorem
+    FirstHurewicz.homotopyLowerSimplex_face_two {X : Type*} [TopologicalSpace X] {x y : X}
+    {p q : Path x y} (H : p.Homotopy q) :
+    (homotopyLowerSimplex H).comp (simplexFace 1 2) = pathSimplex p := by
+  apply ContinuousMap.ext
+  intro s
+  change H (lowerTriangleMap (simplexFace 1 2 s)) = pathSimplex p s
+  rw [lowerTriangle_face_two]
+  exact H.map_zero_left _
+
+@[simp]
+private theorem
+    FirstHurewicz.homotopyUpperSimplex_face_zero {X : Type*} [TopologicalSpace X] {x y : X}
+    {p q : Path x y} (H : p.Homotopy q) :
+    (homotopyUpperSimplex H).comp (simplexFace 1 0) = pathSimplex q := by
+  apply ContinuousMap.ext
+  intro s
+  change H (upperTriangleMap (simplexFace 1 0 s)) = pathSimplex q s
+  rw [upperTriangle_face_zero]
+  exact H.map_one_left _
+
+@[simp]
+private theorem
+    FirstHurewicz.homotopyUpperSimplex_face_one {X : Type*} [TopologicalSpace X] {x y : X}
+    {p q : Path x y} (H : p.Homotopy q) :
+    (homotopyUpperSimplex H).comp (simplexFace 1 1) = homotopyDiagonalSimplex H := by
+  apply ContinuousMap.ext
+  intro s
+  change H (upperTriangleMap (simplexFace 1 1 s)) = _
+  rw [upperTriangle_face_one]
+  rfl
+
+@[simp]
+private theorem
+    FirstHurewicz.homotopyUpperSimplex_face_two {X : Type*} [TopologicalSpace X] {x y : X}
+    {p q : Path x y} (H : p.Homotopy q) :
+    (homotopyUpperSimplex H).comp (simplexFace 1 2) = ContinuousMap.const (Simplex 1) x := by
+  apply ContinuousMap.ext
+  intro s
+  change H (upperTriangleMap (simplexFace 1 2 s)) = x
+  rw [upperTriangle_face_two, H.source]
+
+private def FirstHurewicz.pointChain {X : Type} [TopologicalSpace X] (x : X) : Chains X 0 :=
+  simplexChain X 0 (ContinuousMap.const (Simplex 0) x)
+
+private def FirstHurewicz.pathChain {X : Type} [TopologicalSpace X] {x y : X} (p : Path x y) :
+    Chains X 1 :=
+  simplexChain X 1 (pathSimplex p)
+
+private theorem FirstHurewicz.boundaryOne_pathChain {X : Type} [TopologicalSpace X] {x y : X}
+    (p : Path x y) : boundaryOne X (pathChain p) = pointChain y - pointChain x := by
+  rw [pathChain, boundaryOne_simplex, pathSimplex_face_zero, pathSimplex_face_one]
+  rfl
+
+private theorem
+    FirstHurewicz.boundaryOne_loop {X : Type} [TopologicalSpace X] {x : X} (p : Path x x) :
+    boundaryOne X (pathChain p) = 0 := by rw [boundaryOne_pathChain, sub_self]
+
+private def FirstHurewicz.concatChain {X : Type} [TopologicalSpace X] {x y z : X} (p : Path x y)
+    (q : Path y z) : Chains X 2 :=
+  simplexChain X 2 (concatSimplex p q)
+
+private theorem FirstHurewicz.boundaryTwo_concatChain {X : Type} [TopologicalSpace X] {x y z : X}
+    (p : Path x y) (q : Path y z) :
+    boundaryTwo X (concatChain p q) = pathChain q - pathChain (p.trans q) + pathChain p := by
+  rw [concatChain, boundaryTwo_simplex, concatSimplex_face_zero, concatSimplex_face_one,
+    concatSimplex_face_two]
+  rfl
+
+private def FirstHurewicz.constantEdgeChain {X : Type} [TopologicalSpace X] (x : X) : Chains X 1 :=
+  simplexChain X 1 (ContinuousMap.const (Simplex 1) x)
+
+private def
+    FirstHurewicz.constantTriangleChain {X : Type} [TopologicalSpace X] (x : X) : Chains X 2 :=
+  simplexChain X 2 (ContinuousMap.const (Simplex 2) x)
+
+private theorem
+    FirstHurewicz.boundaryTwo_constantTriangleChain {X : Type} [TopologicalSpace X] (x : X) :
+    boundaryTwo X (constantTriangleChain x) = constantEdgeChain x := by
+  rw [constantTriangleChain, boundaryTwo_simplex]
+  change constantEdgeChain x - constantEdgeChain x + constantEdgeChain x = _
+  abel
+
+@[simp]
+private theorem FirstHurewicz.pathChain_refl {X : Type} [TopologicalSpace X] (x : X) :
+    pathChain (Path.refl x) = constantEdgeChain x :=
+  rfl
+
+private def FirstHurewicz.homotopyChain {X : Type} [TopologicalSpace X] {x y : X} {p q : Path x y}
+    (H : p.Homotopy q) : Chains X 2 :=
+  simplexChain X 2 (homotopyLowerSimplex H) - simplexChain X 2 (homotopyUpperSimplex H)
+
+private theorem FirstHurewicz.boundaryTwo_homotopyChain {X : Type} [TopologicalSpace X] {x y : X}
+    {p q : Path x y} (H : p.Homotopy q) :
+    boundaryTwo X (homotopyChain H) =
+      pathChain p - pathChain q + constantEdgeChain y - constantEdgeChain x := by
+  rw [homotopyChain, map_sub, boundaryTwo_simplex, boundaryTwo_simplex,
+    homotopyLowerSimplex_face_zero, homotopyLowerSimplex_face_one, homotopyLowerSimplex_face_two,
+    homotopyUpperSimplex_face_zero, homotopyUpperSimplex_face_one, homotopyUpperSimplex_face_two]
+  change
+    constantEdgeChain y - simplexChain X 1 (homotopyDiagonalSimplex H) + pathChain p -
+        (pathChain q - simplexChain X 1 (homotopyDiagonalSimplex H) + constantEdgeChain x) =
+      _
+  abel
+
+private def FirstHurewicz.correctedHomotopyChain {X : Type} [TopologicalSpace X] {x y : X}
+    {p q : Path x y} (H : p.Homotopy q) : Chains X 2 :=
+  homotopyChain H - constantTriangleChain y + constantTriangleChain x
+
+private theorem
+    FirstHurewicz.boundaryTwo_correctedHomotopyChain {X : Type} [TopologicalSpace X] {x y : X}
+    {p q : Path x y} (H : p.Homotopy q) :
+    boundaryTwo X (correctedHomotopyChain H) = pathChain p - pathChain q := by
+  rw [correctedHomotopyChain, map_add, map_sub, boundaryTwo_homotopyChain,
+    boundaryTwo_constantTriangleChain, boundaryTwo_constantTriangleChain]
+  abel
+
+private theorem FirstHurewicz.boundaryTwo_loopHomotopy {X : Type} [TopologicalSpace X] {x : X}
+    {p q : Path x x} (H : p.Homotopy q) :
+    boundaryTwo X (homotopyChain H) = pathChain p - pathChain q := by
+  rw [boundaryTwo_homotopyChain]
+  abel
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/HomologyTheory/FirstHurewicz2.lean b/LeanPool/HopfProblem/HomologyTheory/FirstHurewicz2.lean
new file mode 100644
index 000000000..c6beacd08
--- /dev/null
+++ b/LeanPool/HopfProblem/HomologyTheory/FirstHurewicz2.lean
@@ -0,0 +1,173 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen1
+public import LeanPool.HopfProblem.HomologyTheory.SphereHomology3
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Foundations.TriangleRegularBaseFundamentalGroup
+import all LeanPool.HopfProblem.CuspFibre.CuspCentralHomology2
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology1
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen1
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology3
+
+/-!
+# Hopf problem: homology theory · first hurewicz 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem SphereHomology.twoOpenCover_pathConnectedSpace {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) : PathConnectedSpace X := by
+  apply pathConnectedSpace_iff_univ.mpr
+  rw [← D.cover]
+  exact D.pathConnectedU.union D.pathConnectedV ⟨D.base, D.baseU, D.baseV⟩
+
+private theorem SphereHomology.twoOpenCover_fundamentalGroup_eq_one {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) [SimplyConnectedSpace D.U]
+    [SimplyConnectedSpace D.V] (g : FundamentalGroup X D.base) : g = 1 := by
+  have h :
+    MonoidHom.id (FundamentalGroup X D.base) =
+      (1 : FundamentalGroup X D.base →* FundamentalGroup X D.base) := by
+    apply D.hom_ext
+    · ext a
+      have ha : a = 1 := Subsingleton.elim _ _
+      change D.inclusionHomU a = 1
+      rw [ha, map_one]
+    · ext a
+      have ha : a = 1 := Subsingleton.elim _ _
+      change D.inclusionHomV a = 1
+      rw [ha, map_one]
+  exact DFunLike.congr_fun h g
+
+public
+theorem SphereHomology.twoOpenCover_simplyConnectedSpace {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) [SimplyConnectedSpace D.U]
+    [SimplyConnectedSpace D.V] : SimplyConnectedSpace X := by
+  let := twoOpenCover_pathConnectedSpace D
+  exact
+    simplyConnectedSpace_of_fundamentalGroup_eq_one D.base
+      (twoOpenCover_fundamentalGroup_eq_one D)
+
+private def
+    SphereHomology.suspensionConeCover (X : Type) [TopologicalSpace X] [PathConnectedSpace X]
+    (x : X) : FundamentalGroupVanKampen.TwoOpenCover (CuspCentralHomology.Suspension X)
+    where
+  U := ⟨CuspCentralHomology.Suspension.northOpen, CuspCentralHomology.Suspension.northOpen_isOpen⟩
+  V := ⟨CuspCentralHomology.Suspension.southOpen, CuspCentralHomology.Suspension.southOpen_isOpen⟩
+  cover := CuspCentralHomology.Suspension.open_cover
+  pathConnectedU := by
+    change
+      IsPathConnected
+        (CuspCentralHomology.Suspension.northOpen : Set (CuspCentralHomology.Suspension X))
+    exact isPathConnected_iff_pathConnectedSpace.mpr inferInstance
+  pathConnectedV := by
+    change
+      IsPathConnected
+        (CuspCentralHomology.Suspension.southOpen : Set (CuspCentralHomology.Suspension X))
+    exact isPathConnected_iff_pathConnectedSpace.mpr inferInstance
+  pathConnectedIntersection := by
+    change IsPathConnected (CuspCentralHomology.Suspension.middleBand X)
+    exact isPathConnected_iff_pathConnectedSpace.mpr inferInstance
+  base := CuspCentralHomology.Suspension.mk ⟨1 / 2, by norm_num⟩ x
+  baseU := by
+    change (1 / 2 : ℝ) < 3 / 4
+    norm_num
+  baseV := by
+    change (1 / 4 : ℝ) < 1 / 2
+    norm_num
+
+private instance SphereHomology.suspension_simplyConnectedSpace (X : Type) [TopologicalSpace X]
+    [PathConnectedSpace X] : SimplyConnectedSpace (CuspCentralHomology.Suspension X) := by
+  let D := suspensionConeCover X (Classical.choice (inferInstance : Nonempty X))
+  let : SimplyConnectedSpace D.U := by
+    change
+      SimplyConnectedSpace
+        (CuspCentralHomology.Suspension.northOpen : Set (CuspCentralHomology.Suspension X))
+    infer_instance
+  let : SimplyConnectedSpace D.V := by
+    change
+      SimplyConnectedSpace
+        (CuspCentralHomology.Suspension.southOpen : Set (CuspCentralHomology.Suspension X))
+    infer_instance
+  exact twoOpenCover_simplyConnectedSpace D
+
+private instance SphereHomology.unitSphere_simplyConnectedSpace (n : ℕ) :
+    SimplyConnectedSpace (UnitSphere (n + 2)) :=
+  (suspensionSphereHomeomorph (n + 1)).symm.toHomotopyEquiv.simplyConnectedSpace
+
+@[simp]
+private theorem FirstHurewicz.simplexFace_vertex (n : ℕ) (i : Fin (n + 2)) (k : Fin (n + 1)) :
+    simplexFace n i (stdSimplex.vertex (S := ℝ) k) = stdSimplex.vertex (S := ℝ) (i.succAbove k) :=
+  by rw [simplexFace_apply, stdSimplex.map_vertex]
+
+private theorem FirstHurewicz.simplex_contractible (n : ℕ) : ContractibleSpace (Simplex n) :=
+  (convex_stdSimplex ℝ (Fin (n + 1))).contractibleSpace
+    ⟨(stdSimplex.vertex (S := ℝ) (0 : Fin (n + 1))).val,
+      (stdSimplex.vertex (S := ℝ) (0 : Fin (n + 1))).property⟩
+
+private theorem
+    FirstHurewicz.simplex_simplyConnected (n : ℕ) : SimplyConnectedSpace (Simplex n) := by
+  let _ := simplex_contractible n
+  infer_instance
+
+private def FirstHurewicz.triangleFacePath {X : Type*} [TopologicalSpace X] (σ : C(Simplex 2, X))
+    (i : Fin 3) :
+    Path (σ (stdSimplex.vertex (S := ℝ) (i.succAbove (0 : Fin 2))))
+      (σ (stdSimplex.vertex (S := ℝ) (i.succAbove (1 : Fin 2)))) :=
+  (simplexPath (σ.comp (simplexFace 1 i))).cast (congrArg σ (simplexFace_vertex 1 i 0)).symm
+    (congrArg σ (simplexFace_vertex 1 i 1)).symm
+
+private abbrev FirstHurewicz.triangleEdge01 {X : Type*} [TopologicalSpace X] (σ : C(Simplex 2, X)) :
+    Path (σ (stdSimplex.vertex (S := ℝ) (0 : Fin 3)))
+      (σ (stdSimplex.vertex (S := ℝ) (1 : Fin 3))) :=
+  triangleFacePath σ 2
+
+private abbrev FirstHurewicz.triangleEdge12 {X : Type*} [TopologicalSpace X] (σ : C(Simplex 2, X)) :
+    Path (σ (stdSimplex.vertex (S := ℝ) (1 : Fin 3)))
+      (σ (stdSimplex.vertex (S := ℝ) (2 : Fin 3))) :=
+  triangleFacePath σ 0
+
+private abbrev FirstHurewicz.triangleEdge02 {X : Type*} [TopologicalSpace X] (σ : C(Simplex 2, X)) :
+    Path (σ (stdSimplex.vertex (S := ℝ) (0 : Fin 3)))
+      (σ (stdSimplex.vertex (S := ℝ) (2 : Fin 3))) :=
+  triangleFacePath σ 1
+
+private theorem FirstHurewicz.triangleEdges_homotopic {X : Type*} [TopologicalSpace X]
+    (σ : C(Simplex 2, X)) :
+    ((triangleEdge01 σ).trans (triangleEdge12 σ)).Homotopic (triangleEdge02 σ) := by
+  let _ := simplex_simplyConnected 2
+  have h :=
+    SimplyConnectedSpace.paths_homotopic
+      ((triangleEdge01 (ContinuousMap.id (Simplex 2))).trans
+        (triangleEdge12 (ContinuousMap.id (Simplex 2))))
+      (triangleEdge02 (ContinuousMap.id (Simplex 2)))
+  have hmap := h.map σ
+  rw [Path.map_trans] at hmap
+  exact hmap
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/HomologyTheory/FirstHurewicz3.lean b/LeanPool/HopfProblem/HomologyTheory/FirstHurewicz3.lean
new file mode 100644
index 000000000..3b2499e41
--- /dev/null
+++ b/LeanPool/HopfProblem/HomologyTheory/FirstHurewicz3.lean
@@ -0,0 +1,822 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology1
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz1
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology3
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz2
+import all LeanPool.HopfProblem.Hurewicz.SecondHurewicz
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap1
+
+/-!
+# Hopf problem: homology theory · first hurewicz 3
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem SphereHomology.unitSphere_piTwo_subsingleton (n : ℕ) (x : UnitSphere (n + 3)) :
+    Subsingleton (π_ 2 (UnitSphere (n + 3)) x) := by
+  let := unitSphere_homology_subsingleton (n + 2) 2 (by decide) (by omega)
+  exact (SecondHurewicz.SimplyConnected.hurewiczPi2Equiv x).injective.subsingleton
+
+private abbrev FirstHurewicz.AbelianPi1 (X : Type*) [TopologicalSpace X] (b : X) :=
+  Additive (Abelianization (FundamentalGroup X b))
+
+private def FirstHurewicz.loopQuotient {X : Type*} [TopologicalSpace X] {b : X} (p : Path b b) :
+    FundamentalGroup X b :=
+  Path.Homotopic.Quotient.mk p
+
+private def FirstHurewicz.loopClass {X : Type*} [TopologicalSpace X] {b : X} (p : Path b b) :
+    AbelianPi1 X b :=
+  Additive.ofMul (Abelianization.of (loopQuotient p))
+
+private theorem FirstHurewicz.loopClass_surjective {X : Type*} [TopologicalSpace X] {b : X} :
+    Function.Surjective (loopClass (b := b)) := by
+  intro a
+  obtain ⟨g, hg⟩ := Quotient.exists_rep a.toMul
+  change Abelianization.of g = a.toMul at hg
+  obtain ⟨p, hp⟩ := Path.Homotopic.Quotient.mk_surjective g
+  have hp' : loopQuotient p = g := hp
+  refine ⟨p, ?_⟩
+  rw [loopClass, hp', hg]
+  rfl
+
+private theorem FirstHurewicz.loopQuotient_trans {X : Type*} [TopologicalSpace X] {b : X}
+    (p q : Path b b) : loopQuotient (p.trans q) = loopQuotient q * loopQuotient p :=
+  rfl
+
+private theorem
+    FirstHurewicz.loopQuotient_symm {X : Type*} [TopologicalSpace X] {b : X} (p : Path b b) :
+    loopQuotient p.symm = (loopQuotient p)⁻¹ :=
+  rfl
+
+private theorem FirstHurewicz.loopClass_homotopic {X : Type*} [TopologicalSpace X] {b : X}
+    {p q : Path b b} (h : p.Homotopic q) : loopClass p = loopClass q :=
+  congrArg (fun g : FundamentalGroup X b => Additive.ofMul (Abelianization.of g))
+    (Path.Homotopic.Quotient.eq.mpr h)
+
+private theorem
+    FirstHurewicz.loopClass_trans {X : Type*} [TopologicalSpace X] {b : X} (p q : Path b b) :
+    loopClass (p.trans q) = loopClass p + loopClass q := by
+  rw [loopClass, loopQuotient_trans, map_mul, ofMul_mul, add_comm]
+  rfl
+
+@[simp]
+private theorem
+    FirstHurewicz.loopClass_symm {X : Type*} [TopologicalSpace X] {b : X} (p : Path b b) :
+    loopClass p.symm = -loopClass p := by
+  rw [loopClass, loopQuotient_symm, map_inv, ofMul_inv]
+  rfl
+
+private def
+    FirstHurewicz.basedLoop {X : Type*} [TopologicalSpace X] {b x y : X} (r : ∀ x : X, Path b x)
+    (p : Path x y) : Path b b :=
+  (r x).trans (p.trans (r y).symm)
+
+private def FirstHurewicz.basedLoopQuotient {X : Type*} [TopologicalSpace X] {b x y : X}
+    (r : ∀ x : X, Path b x) (p : Path x y) : FundamentalGroup X b :=
+  Path.Homotopic.Quotient.mk (basedLoop r p)
+
+private def FirstHurewicz.basedLoopClass {X : Type*} [TopologicalSpace X] {b x y : X}
+    (r : ∀ x : X, Path b x) (p : Path x y) : AbelianPi1 X b :=
+  loopClass (basedLoop r p)
+
+private theorem FirstHurewicz.basedLoopClass_eq {X : Type*} [TopologicalSpace X] {b x y : X}
+    (r : ∀ x : X, Path b x) (p : Path x y) :
+    basedLoopClass r p = Additive.ofMul (Abelianization.of (basedLoopQuotient r p)) :=
+  rfl
+
+private theorem FirstHurewicz.basedLoop_homotopic {X : Type*} [TopologicalSpace X] {b x y : X}
+    (r : ∀ x : X, Path b x) {p q : Path x y} (h : p.Homotopic q) :
+    (basedLoop r p).Homotopic (basedLoop r q) :=
+  (Path.Homotopic.refl (r x)).hcomp (h.hcomp (Path.Homotopic.refl (r y).symm))
+
+private theorem FirstHurewicz.basedLoopClass_homotopic {X : Type*} [TopologicalSpace X] {b x y : X}
+    (r : ∀ x : X, Path b x) {p q : Path x y} (h : p.Homotopic q) :
+    basedLoopClass r p = basedLoopClass r q :=
+  loopClass_homotopic (basedLoop_homotopic r h)
+
+private theorem FirstHurewicz.basedLoopQuotient_trans {X : Type*} [TopologicalSpace X] {b x y z : X}
+    (r : ∀ x : X, Path b x) (p : Path x y) (q : Path y z) :
+    basedLoopQuotient r (p.trans q) = basedLoopQuotient r q * basedLoopQuotient r p := by
+  simp only [basedLoopQuotient, basedLoop, Path.Homotopic.Quotient.mk_trans,
+    Path.Homotopic.Quotient.mk_symm, FundamentalGroup.mul_def,
+    Path.Homotopic.Quotient.trans_assoc]
+  rw [←
+    Path.Homotopic.Quotient.trans_assoc (Path.Homotopic.Quotient.mk (r y)).symm
+      (Path.Homotopic.Quotient.mk (r y)),
+    Path.Homotopic.Quotient.symm_trans, Path.Homotopic.Quotient.refl_trans]
+
+private theorem FirstHurewicz.basedLoopClass_trans {X : Type*} [TopologicalSpace X] {b x y z : X}
+    (r : ∀ x : X, Path b x) (p : Path x y) (q : Path y z) :
+    basedLoopClass r (p.trans q) = basedLoopClass r p + basedLoopClass r q := by
+  rw [basedLoopClass_eq, basedLoopQuotient_trans, map_mul, ofMul_mul, add_comm, ←
+    basedLoopClass_eq, ← basedLoopClass_eq]
+
+@[simp]
+private theorem FirstHurewicz.basedLoopClass_loop {X : Type*} [TopologicalSpace X] {b : X}
+    (r : ∀ x : X, Path b x) (p : Path b b) : basedLoopClass r p = loopClass p := by
+  rw [basedLoopClass, basedLoop, loopClass_trans, loopClass_trans, loopClass_symm]
+  abel
+
+private theorem FirstHurewicz.basedLoopClass_triangle {X : Type*} [TopologicalSpace X] {b x y z : X}
+    (r : ∀ x : X, Path b x) (p₀₁ : Path x y) (p₁₂ : Path y z) (p₀₂ : Path x z)
+    (h : (p₀₁.trans p₁₂).Homotopic p₀₂) :
+    basedLoopClass r p₀₁ + basedLoopClass r p₁₂ = basedLoopClass r p₀₂ := by
+  rw [← basedLoopClass_trans]
+  exact basedLoopClass_homotopic r h
+
+private theorem FirstHurewicz.basedLoopClass_triangle_boundary {X : Type*} [TopologicalSpace X]
+    {b x y z : X} (r : ∀ x : X, Path b x) (p₀₁ : Path x y) (p₁₂ : Path y z) (p₀₂ : Path x z)
+    (h : (p₀₁.trans p₁₂).Homotopic p₀₂) :
+    basedLoopClass r p₁₂ - basedLoopClass r p₀₂ + basedLoopClass r p₀₁ = 0 := by
+  rw [← basedLoopClass_triangle r p₀₁ p₁₂ p₀₂ h]
+  abel
+
+private def FirstHurewicz.pathClass {X : Type} [TopologicalSpace X] {x y : X} (p : Path x y) :
+    Opchains X :=
+  chainClass X (pathChain p)
+
+private theorem FirstHurewicz.pathClass_homotopy {X : Type} [TopologicalSpace X] {x y : X}
+    {p q : Path x y} (H : p.Homotopy q) : pathClass p = pathClass q :=
+  (chainClass_eq_iff X _ _).mpr ⟨correctedHomotopyChain H, boundaryTwo_correctedHomotopyChain H⟩
+
+private theorem FirstHurewicz.pathClass_homotopic {X : Type} [TopologicalSpace X] {x y : X}
+    {p q : Path x y} (h : p.Homotopic q) : pathClass p = pathClass q := by
+  obtain ⟨H⟩ := h
+  exact pathClass_homotopy H
+
+@[simp]
+private theorem FirstHurewicz.pathClass_refl {X : Type} [TopologicalSpace X] (x : X) :
+    pathClass (Path.refl x) = 0 := by
+  change chainClass X (pathChain (Path.refl x)) = 0
+  rw [pathChain_refl, ← boundaryTwo_constantTriangleChain]
+  exact chainClass_boundary X _
+
+private theorem
+    FirstHurewicz.pathClass_trans {X : Type} [TopologicalSpace X] {x y z : X} (p : Path x y)
+    (q : Path y z) : pathClass (p.trans q) = pathClass p + pathClass q := by
+  have h := chainClass_boundary X (concatChain p q)
+  rw [boundaryTwo_concatChain, map_add, map_sub] at h
+  change pathClass q - pathClass (p.trans q) + pathClass p = 0 at h
+  apply sub_eq_zero.mp
+  calc
+    pathClass (p.trans q) - (pathClass p + pathClass q) =
+        -(pathClass q - pathClass (p.trans q) + pathClass p) := by abel
+    _ = 0 := by rw [h, neg_zero]
+
+@[simp]
+private theorem
+    FirstHurewicz.pathClass_symm {X : Type} [TopologicalSpace X] {x y : X} (p : Path x y) :
+    pathClass p.symm = -pathClass p := by
+  have h := pathClass_homotopic (Path.Homotopic.trans_symm p)
+  rw [pathClass_trans, pathClass_refl] at h
+  exact eq_neg_of_add_eq_zero_right h
+
+@[simp]
+private theorem
+    FirstHurewicz.pathClass_cast {X : Type} [TopologicalSpace X] {x y : X} (p : Path x y)
+    {x' y' : X} (hx : x' = x) (hy : y' = y) : pathClass (p.cast hx hy) = pathClass p :=
+  rfl
+
+/-- The singular one-cycle represented by a based loop. -/
+public
+def
+    FirstHurewicz.loopCycle {X : Type} [TopologicalSpace X] {x : X} (p : Path x x) : Cycles1 X :=
+  mkCycle1 X (pathChain p) (boundaryOne_loop p)
+
+@[simp]
+private theorem FirstHurewicz.loopCycle_val {X : Type} [TopologicalSpace X] {x : X} (p : Path x x) :
+    (loopCycle p).1 = pathChain p :=
+  rfl
+
+/-- The first singular-homology class represented by a based loop. -/
+public
+def FirstHurewicz.loopHomologyClass {X : Type} [TopologicalSpace X] {x : X} (p : Path x x) :
+    SingularH1 X :=
+  cycleClass X (loopCycle p)
+
+@[simp]
+private theorem FirstHurewicz.homologyToChainClass_loopHomologyClass {X : Type} [TopologicalSpace X]
+    {x : X} (p : Path x x) : homologyToChainClass X (loopHomologyClass p) = pathClass p := by
+  rw [loopHomologyClass, homologyToChainClass_cycleClass]
+  rfl
+
+private theorem FirstHurewicz.loopHomologyClass_homotopic {X : Type} [TopologicalSpace X] {x : X}
+    {p q : Path x x} (h : p.Homotopic q) : loopHomologyClass p = loopHomologyClass q := by
+  apply homologyToChainClass_injective X
+  rw [homologyToChainClass_loopHomologyClass, homologyToChainClass_loopHomologyClass]
+  exact pathClass_homotopic h
+
+@[simp]
+private theorem FirstHurewicz.loopHomologyClass_refl {X : Type} [TopologicalSpace X] (x : X) :
+    loopHomologyClass (Path.refl x) = 0 := by
+  apply homologyToChainClass_injective X
+  rw [homologyToChainClass_loopHomologyClass, pathClass_refl, map_zero]
+
+private theorem FirstHurewicz.loopHomologyClass_trans {X : Type} [TopologicalSpace X] {x : X}
+    (p q : Path x x) :
+    loopHomologyClass (p.trans q) = loopHomologyClass p + loopHomologyClass q := by
+  apply homologyToChainClass_injective X
+  rw [homologyToChainClass_loopHomologyClass, map_add, homologyToChainClass_loopHomologyClass,
+    homologyToChainClass_loopHomologyClass, pathClass_trans]
+
+private def FirstHurewicz.hurewiczFunction {X : Type} [TopologicalSpace X] (b : X) :
+    FundamentalGroup X b → SingularH1 X :=
+  Quotient.lift (fun p : Path b b => loopHomologyClass p)
+    (fun _ _ h => loopHomologyClass_homotopic h)
+
+private def FirstHurewicz.hurewiczPi1 {X : Type} [TopologicalSpace X] (b : X) :
+    FundamentalGroup X b →* Multiplicative (SingularH1 X)
+    where
+  toFun g := Multiplicative.ofAdd (hurewiczFunction b g)
+  map_one' := congrArg Multiplicative.ofAdd (loopHomologyClass_refl b)
+  map_mul' g
+    h := by
+    obtain ⟨p, rfl⟩ := Path.Homotopic.Quotient.mk_surjective g
+    obtain ⟨q, rfl⟩ := Path.Homotopic.Quotient.mk_surjective h
+    change
+      Multiplicative.ofAdd (loopHomologyClass (q.trans p)) =
+        Multiplicative.ofAdd (loopHomologyClass p + loopHomologyClass q)
+    rw [loopHomologyClass_trans, add_comm]
+
+private def FirstHurewicz.hurewiczMap {X : Type} [TopologicalSpace X] (b : X) :
+    AbelianPi1 X b →ₗ[ℤ] SingularH1 X
+    where
+  toFun := (Abelianization.lift (hurewiczPi1 b)).toAdditiveLeft
+  map_add' := (Abelianization.lift (hurewiczPi1 b)).toAdditiveLeft.map_add
+  map_smul' n
+    a := by
+    simpa using map_intCast_smul (Abelianization.lift (hurewiczPi1 b)).toAdditiveLeft ℤ ℤ n a
+
+@[simp]
+private theorem FirstHurewicz.hurewiczMap_loopClass {X : Type} [TopologicalSpace X] (b : X)
+    (p : Path b b) : hurewiczMap b (loopClass p) = loopHomologyClass p :=
+  rfl
+
+private theorem
+    FirstHurewicz.homologyToChainClass_hurewiczMap_loopClass {X : Type} [TopologicalSpace X]
+    (b : X) (p : Path b b) : homologyToChainClass X (hurewiczMap b (loopClass p)) = pathClass p :=
+  by rw [hurewiczMap_loopClass, homologyToChainClass_loopHomologyClass]
+
+private theorem
+    FirstHurewicz.hurewiczMap_basedLoopClass {X : Type} [TopologicalSpace X] {x y : X} (b : X)
+    (r : ∀ a : X, Path b a) (p : Path x y) :
+    homologyToChainClass X (hurewiczMap b (basedLoopClass r p)) =
+      pathClass (r x) + pathClass p - pathClass (r y) := by
+  change homologyToChainClass X (hurewiczMap b (loopClass (basedLoop r p))) = _
+  rw [homologyToChainClass_hurewiczMap_loopClass]
+  change pathClass ((r x).trans (p.trans (r y).symm)) = _
+  rw [pathClass_trans, pathClass_trans, pathClass_symm]
+  abel
+
+private theorem FirstHurewicz.basedLoopClass_cast {X : Type} [TopologicalSpace X] {b x y : X}
+    (r : ∀ x : X, Path b x) (p : Path x y) {x' y' : X} (hx : x' = x) (hy : y' = y) :
+    basedLoopClass r (p.cast hx hy) = basedLoopClass r p := by
+  cases hx
+  cases hy
+  rfl
+
+private theorem FirstHurewicz.simplexPath_pathSimplex_cast {X : Type} [TopologicalSpace X] {x y : X}
+    (p : Path x y) :
+    simplexPath (pathSimplex p) = p.cast (pathSimplex_vertex_zero p) (pathSimplex_vertex_one p) :=
+  by
+  apply Path.ext
+  funext t
+  change p (stdSimplexHomeomorphUnitInterval (stdSimplexHomeomorphUnitInterval.symm t)) = p t
+  rw [Homeomorph.apply_symm_apply]
+
+@[simp]
+private theorem FirstHurewicz.basedLoopClass_simplexPath_pathSimplex {X : Type} [TopologicalSpace X]
+    {b x y : X} (r : ∀ x : X, Path b x) (p : Path x y) :
+    basedLoopClass r (simplexPath (pathSimplex p)) = basedLoopClass r p := by
+  rw [simplexPath_pathSimplex_cast, basedLoopClass_cast]
+
+private theorem
+    FirstHurewicz.basedLoopClass_triangleFacePath {X : Type} [TopologicalSpace X] {b : X}
+    (r : ∀ x : X, Path b x) (σ : SingularSimplex X 2) (i : Fin 3) :
+    basedLoopClass r (triangleFacePath σ i) =
+      basedLoopClass r (simplexPath (σ.comp (simplexFace 1 i))) :=
+  basedLoopClass_cast r (simplexPath (σ.comp (simplexFace 1 i))) _ _
+
+private def FirstHurewicz.edgeLoopCochain {X : Type} [TopologicalSpace X] {b : X}
+    (r : ∀ x : X, Path b x) : Chains X 1 →ₗ[ℤ] AbelianPi1 X b :=
+  chainLift X 1 (fun σ => basedLoopClass r (simplexPath σ))
+
+@[simp]
+private theorem FirstHurewicz.edgeLoopCochain_simplex {X : Type} [TopologicalSpace X] {b : X}
+    (r : ∀ x : X, Path b x) (σ : SingularSimplex X 1) :
+    edgeLoopCochain r (simplexChain X 1 σ) = basedLoopClass r (simplexPath σ) :=
+  chainLift_simplex X 1 (fun σ => basedLoopClass r (simplexPath σ)) σ
+
+private theorem
+    FirstHurewicz.edgeLoopCochain_pathSimplex {X : Type} [TopologicalSpace X] {b x y : X}
+    (r : ∀ x : X, Path b x) (p : Path x y) :
+    edgeLoopCochain r (simplexChain X 1 (pathSimplex p)) = basedLoopClass r p := by
+  rw [edgeLoopCochain_simplex, basedLoopClass_simplexPath_pathSimplex]
+
+private theorem FirstHurewicz.edgeLoopCochain_loopSimplex {X : Type} [TopologicalSpace X] {b : X}
+    (r : ∀ x : X, Path b x) (p : Path b b) :
+    edgeLoopCochain r (simplexChain X 1 (pathSimplex p)) = loopClass p := by
+  rw [edgeLoopCochain_pathSimplex, basedLoopClass_loop]
+
+private theorem
+    FirstHurewicz.edgeLoopCochain_boundaryTwo_simplex {X : Type} [TopologicalSpace X] {b : X}
+    (r : ∀ x : X, Path b x) (σ : SingularSimplex X 2) :
+    edgeLoopCochain r (boundaryTwo X (simplexChain X 2 σ)) = 0 := by
+  simp only [boundaryTwo_simplex, map_add, map_sub, edgeLoopCochain_simplex]
+  change
+    basedLoopClass r (simplexPath (σ.comp (simplexFace 1 0))) -
+          basedLoopClass r (simplexPath (σ.comp (simplexFace 1 1))) +
+        basedLoopClass r (simplexPath (σ.comp (simplexFace 1 2))) =
+      0
+  have he :=
+    congrArg₂ (fun a c : AbelianPi1 X b => a + c)
+      (congrArg₂ (fun a c : AbelianPi1 X b => a - c) (basedLoopClass_triangleFacePath r σ 0)
+        (basedLoopClass_triangleFacePath r σ 1))
+      (basedLoopClass_triangleFacePath r σ 2)
+  exact
+    he.symm.trans
+      (basedLoopClass_triangle_boundary r (triangleEdge01 σ) (triangleEdge12 σ) (triangleEdge02 σ)
+        (triangleEdges_homotopic σ))
+
+private theorem
+    FirstHurewicz.edgeLoopCochain_comp_boundaryTwo {X : Type} [TopologicalSpace X] {b : X}
+    (r : ∀ x : X, Path b x) : (edgeLoopCochain r).comp (boundaryTwo X) = 0 := by
+  apply chainMap_ext X 2
+  intro σ
+  exact edgeLoopCochain_boundaryTwo_simplex r σ
+
+private theorem FirstHurewicz.edgeLoopCochain_boundaryTwo {X : Type} [TopologicalSpace X] {b : X}
+    (r : ∀ x : X, Path b x) (c : Chains X 2) : edgeLoopCochain r (boundaryTwo X c) = 0 :=
+  LinearMap.congr_fun (edgeLoopCochain_comp_boundaryTwo r) c
+
+private def FirstHurewicz.inverseHurewiczMap {X : Type} [TopologicalSpace X] {b : X}
+    (r : ∀ x : X, Path b x) : SingularH1 X →ₗ[ℤ] AbelianPi1 X b :=
+  homologyDescOfChain X (edgeLoopCochain r) (edgeLoopCochain_boundaryTwo r)
+
+@[simp]
+private theorem FirstHurewicz.inverseHurewiczMap_cycleClass {X : Type} [TopologicalSpace X] {b : X}
+    (r : ∀ x : X, Path b x) (c : Cycles1 X) :
+    inverseHurewiczMap r (cycleClass X c) = edgeLoopCochain r c.1 :=
+  homologyDescOfChain_cycleClass X (edgeLoopCochain r) (edgeLoopCochain_boundaryTwo r) c
+
+private def
+    FirstHurewicz.basePathChain {X : Type} [TopologicalSpace X] {b : X} (r : ∀ x : X, Path b x) :
+    Chains X 0 →ₗ[ℤ] Chains X 1 :=
+  chainLift X 0 (fun σ => pathChain (r (σ (stdSimplex.vertex (S := ℝ) (0 : Fin 1)))))
+
+@[simp]
+private theorem FirstHurewicz.basePathChain_pointChain {X : Type} [TopologicalSpace X] {b : X}
+    (r : ∀ x : X, Path b x) (x : X) : basePathChain r (pointChain x) = pathChain (r x) :=
+  chainLift_simplex X 0 _ (ContinuousMap.const (Simplex 0) x)
+
+private theorem FirstHurewicz.edgeClosure_pathChain {X : Type} [TopologicalSpace X] {b x y : X}
+    (r : ∀ x : X, Path b x) (p : Path x y) :
+    homologyToChainClass X (hurewiczMap b (edgeLoopCochain r (pathChain p))) =
+      chainClass X (pathChain p) - chainClass X (basePathChain r (boundaryOne X (pathChain p))) :=
+  by
+  have he : edgeLoopCochain r (pathChain p) = basedLoopClass r p :=
+    edgeLoopCochain_pathSimplex r p
+  rw [he, hurewiczMap_basedLoopClass, boundaryOne_pathChain, map_sub, basePathChain_pointChain,
+    basePathChain_pointChain, map_sub]
+  change
+    pathClass (r x) + pathClass p - pathClass (r y) =
+      pathClass p - (pathClass (r y) - pathClass (r x))
+  abel
+
+private theorem FirstHurewicz.edgeClosure_chain_identity {X : Type} [TopologicalSpace X] {b : X}
+    (r : ∀ x : X, Path b x) :
+    (homologyToChainClass X).comp ((hurewiczMap b).comp (edgeLoopCochain r)) =
+      chainClass X - (chainClass X).comp ((basePathChain r).comp (boundaryOne X)) := by
+  apply chainMap_ext X 1
+  intro σ
+  have h := edgeClosure_pathChain r (simplexPath σ)
+  simpa only [pathChain, pathSimplex_simplexPath, LinearMap.comp_apply, LinearMap.sub_apply] using
+    h
+
+private theorem FirstHurewicz.edgeClosure_cycle {X : Type} [TopologicalSpace X] {b : X}
+    (r : ∀ x : X, Path b x) (c : Cycles1 X) :
+    homologyToChainClass X (hurewiczMap b (edgeLoopCochain r c.1)) = chainClass X c.1 := by
+  have h := LinearMap.congr_fun (edgeClosure_chain_identity r) c.1
+  change
+    homologyToChainClass X (hurewiczMap b (edgeLoopCochain r c.1)) =
+      chainClass X c.1 - chainClass X (basePathChain r (boundaryOne X c.1)) at h
+  simpa only [cycles1_boundary, map_zero, sub_zero] using h
+
+@[simp]
+private theorem
+    FirstHurewicz.inverseHurewiczMap_loopHomologyClass {X : Type} [TopologicalSpace X] {b : X}
+    (r : ∀ x : X, Path b x) (p : Path b b) :
+    inverseHurewiczMap r (loopHomologyClass p) = loopClass p := by
+  rw [loopHomologyClass, inverseHurewiczMap_cycleClass, loopCycle_val]
+  exact edgeLoopCochain_loopSimplex r p
+
+private theorem FirstHurewicz.inverseHurewiczMap_hurewiczMap {X : Type} [TopologicalSpace X] {b : X}
+    (r : ∀ x : X, Path b x) (a : AbelianPi1 X b) : inverseHurewiczMap r (hurewiczMap b a) = a := by
+  obtain ⟨p, rfl⟩ := loopClass_surjective a
+  rw [hurewiczMap_loopClass, inverseHurewiczMap_loopHomologyClass]
+
+private theorem FirstHurewicz.hurewiczMap_inverseHurewiczMap {X : Type} [TopologicalSpace X] {b : X}
+    (r : ∀ x : X, Path b x) (a : SingularH1 X) : hurewiczMap b (inverseHurewiczMap r a) = a := by
+  obtain ⟨c, rfl⟩ := cycleClass_surjective X a
+  apply homologyToChainClass_injective X
+  rw [inverseHurewiczMap_cycleClass, homologyToChainClass_cycleClass]
+  exact edgeClosure_cycle r c
+
+private def FirstHurewicz.firstHurewiczEquivOfPaths {X : Type} [TopologicalSpace X] {b : X}
+    (r : ∀ x : X, Path b x) : AbelianPi1 X b ≃ₗ[ℤ] SingularH1 X
+    where
+  toLinearMap := hurewiczMap b
+  invFun := inverseHurewiczMap r
+  left_inv := inverseHurewiczMap_hurewiczMap r
+  right_inv := hurewiczMap_inverseHurewiczMap r
+
+private def FirstHurewicz.firstHurewiczEquiv {X : Type} [TopologicalSpace X] (b : X)
+    [PathConnectedSpace X] : AbelianPi1 X b ≃ₗ[ℤ] SingularH1 X :=
+  firstHurewiczEquivOfPaths (PathConnectedSpace.somePath b)
+
+@[simp]
+private theorem FirstHurewicz.firstHurewiczEquiv_loopClass {X : Type} [TopologicalSpace X] (b : X)
+    [PathConnectedSpace X] (p : Path b b) :
+    firstHurewiczEquiv b (loopClass p) = loopHomologyClass p :=
+  hurewiczMap_loopClass b p
+
+private theorem FirstHurewicz.loopHomologyClass_surjective {X : Type} [TopologicalSpace X] (b : X)
+    [PathConnectedSpace X] : Function.Surjective (loopHomologyClass (x := b)) := by
+  intro a
+  obtain ⟨c, hc⟩ := (firstHurewiczEquiv b).surjective a
+  obtain ⟨p, hp⟩ := loopClass_surjective c
+  refine ⟨p, ?_⟩
+  rw [← firstHurewiczEquiv_loopClass, hp, hc]
+
+private def FirstHurewicz.abelianPi1EquivOfPi1 {X : Type} [TopologicalSpace X] (b : X) {A : Type*}
+    [AddCommGroup A] [Module ℤ A] (e : FundamentalGroup X b ≃* Multiplicative A) :
+    AbelianPi1 X b ≃ₗ[ℤ] A :=
+  (e.abelianizationCongr.trans
+      (Abelianization.equivOfComm (H := Multiplicative A)).symm).toAdditiveLeft.toIntLinearEquiv
+
+@[simp]
+private theorem
+    FirstHurewicz.abelianPi1EquivOfPi1_of {X : Type} [TopologicalSpace X] (b : X) {A : Type*}
+    [AddCommGroup A] [Module ℤ A] (e : FundamentalGroup X b ≃* Multiplicative A)
+    (g : FundamentalGroup X b) :
+    abelianPi1EquivOfPi1 b e (Additive.ofMul (Abelianization.of g)) = (e g).toAdd :=
+  rfl
+
+private def FirstHurewicz.singularH1EquivOfPi1 {X : Type} [TopologicalSpace X] (b : X) {A : Type*}
+    [AddCommGroup A] [Module ℤ A] [PathConnectedSpace X]
+    (e : FundamentalGroup X b ≃* Multiplicative A) : SingularH1 X ≃ₗ[ℤ] A :=
+  (firstHurewiczEquiv b).symm.trans (abelianPi1EquivOfPi1 b e)
+
+@[simp]
+private theorem FirstHurewicz.singularH1EquivOfPi1_hurewiczFunction {X : Type} [TopologicalSpace X]
+    (b : X) {A : Type*} [AddCommGroup A] [Module ℤ A] [PathConnectedSpace X]
+    (e : FundamentalGroup X b ≃* Multiplicative A) (g : FundamentalGroup X b) :
+    singularH1EquivOfPi1 b e (hurewiczFunction b g) = (e g).toAdd := by
+  change
+    abelianPi1EquivOfPi1 b e
+        ((firstHurewiczEquiv b).symm
+          (firstHurewiczEquiv b (Additive.ofMul (Abelianization.of g)))) =
+      _
+  rw [LinearEquiv.symm_apply_apply, abelianPi1EquivOfPi1_of]
+
+@[simp]
+private theorem FirstHurewicz.singularH1EquivOfPi1_loopHomologyClass {X : Type} [TopologicalSpace X]
+    (b : X) {A : Type*} [AddCommGroup A] [Module ℤ A] [PathConnectedSpace X]
+    (e : FundamentalGroup X b ≃* Multiplicative A) (p : Path b b) :
+    singularH1EquivOfPi1 b e (loopHomologyClass p) = (e (loopQuotient p)).toAdd :=
+  singularH1EquivOfPi1_hurewiczFunction b e (loopQuotient p)
+
+private theorem FirstHurewicz.pathSimplex_map {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    {x y : X} (f : C(X, Y)) (p : Path x y) :
+    pathSimplex (p.map f.continuous) = f.comp (pathSimplex p) :=
+  rfl
+
+@[simp]
+private theorem FirstHurewicz.inducedChain_pathChain {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] {x y : X} (f : C(X, Y)) (p : Path x y) :
+    inducedChain f 1 (pathChain p) = pathChain (p.map f.continuous) := by
+  simp only [pathChain, inducedChain_simplex, pathSimplex_map]
+
+@[simp]
+private theorem FirstHurewicz.inducedCycles_loopCycle {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (b : X) (p : Path b b) :
+    inducedCycles f (loopCycle p) = loopCycle (p.map f.continuous) := by
+  apply Subtype.ext
+  rw [inducedCycles_val, loopCycle_val, loopCycle_val, inducedChain_pathChain]
+
+@[simp]
+private theorem FirstHurewicz.inducedHomology_loopHomologyClass {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (b : X) (p : Path b b) :
+    inducedHomology f (loopHomologyClass p) = loopHomologyClass (p.map f.continuous) := by
+  rw [loopHomologyClass, inducedHomology_cycleClass, inducedCycles_loopCycle]
+  rfl
+
+private def
+    SingularMayerVietoris.coverRestriction {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (f : C(X, Y)) (A : Set X) (B : Set Y) (hf : Set.MapsTo f A B) : C(A, B) :=
+  ⟨fun x => ⟨f x, hf x.property⟩, (f.continuous.comp continuous_subtype_val).subtype_mk _⟩
+
+private def SingularMayerVietoris.intersectionRestriction {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (U V : Set X) (U' V' : Set Y) (hfU : Set.MapsTo f U U')
+    (hfV : Set.MapsTo f V V') : C((U ∩ V : Set X), (U' ∩ V' : Set Y)) :=
+  coverRestriction f (U ∩ V) (U' ∩ V') (fun _ hx => ⟨hfU hx.1, hfV hx.2⟩)
+
+private theorem SingularMayerVietoris.coverRestriction_ambient {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (A : Set X) (B : Set Y) (hf : Set.MapsTo f A B) :
+    FirstHurewicz.singularChainMap (coverRestriction f A B hf) ≫
+        FirstHurewicz.singularChainMap (subtypeInclusion B) =
+      FirstHurewicz.singularChainMap (subtypeInclusion A) ≫ FirstHurewicz.singularChainMap f := by
+  let F := ((AlgebraicTopology.singularChainComplexFunctor (ModuleCat ℤ)).obj (ModuleCat.of ℤ ℤ))
+  have h₁ :=
+    F.map_comp (TopCat.ofHom (coverRestriction f A B hf)) (TopCat.ofHom (subtypeInclusion B))
+  have h₂ := F.map_comp (TopCat.ofHom (subtypeInclusion A)) (TopCat.ofHom f)
+  exact h₁.symm.trans h₂
+
+private theorem
+    SingularMayerVietoris.coverRestriction_intersection_left {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (U V : Set X) (U' V' : Set Y) (hfU : Set.MapsTo f U U')
+    (hfV : Set.MapsTo f V V') :
+    intersectionToLeft U V ≫ FirstHurewicz.singularChainMap (coverRestriction f U U' hfU) =
+      FirstHurewicz.singularChainMap (intersectionRestriction f U V U' V' hfU hfV) ≫
+        intersectionToLeft U' V' := by
+  let F := ((AlgebraicTopology.singularChainComplexFunctor (ModuleCat ℤ)).obj (ModuleCat.of ℤ ℤ))
+  have h₁ :=
+    F.map_comp (TopCat.ofHom (ContinuousMap.inclusion (Set.inter_subset_left : U ∩ V ⊆ U)))
+      (TopCat.ofHom (coverRestriction f U U' hfU))
+  have h₂ :=
+    F.map_comp (TopCat.ofHom (intersectionRestriction f U V U' V' hfU hfV))
+      (TopCat.ofHom (ContinuousMap.inclusion (Set.inter_subset_left : U' ∩ V' ⊆ U')))
+  exact h₁.symm.trans h₂
+
+private theorem SingularMayerVietoris.coverRestriction_intersection_right {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : C(X, Y)) (U V : Set X) (U' V' : Set Y)
+    (hfU : Set.MapsTo f U U') (hfV : Set.MapsTo f V V') :
+    intersectionToRight U V ≫ FirstHurewicz.singularChainMap (coverRestriction f V V' hfV) =
+      FirstHurewicz.singularChainMap (intersectionRestriction f U V U' V' hfU hfV) ≫
+        intersectionToRight U' V' := by
+  let F := ((AlgebraicTopology.singularChainComplexFunctor (ModuleCat ℤ)).obj (ModuleCat.of ℤ ℤ))
+  have h₁ :=
+    F.map_comp (TopCat.ofHom (ContinuousMap.inclusion (Set.inter_subset_right : U ∩ V ⊆ V)))
+      (TopCat.ofHom (coverRestriction f V V' hfV))
+  have h₂ :=
+    F.map_comp (TopCat.ofHom (intersectionRestriction f U V U' V' hfU hfV))
+      (TopCat.ofHom (ContinuousMap.inclusion (Set.inter_subset_right : U' ∩ V' ⊆ V')))
+  exact h₁.symm.trans h₂
+
+private theorem
+    SingularMayerVietoris.inducedChain_mem_small_of_mapsTo {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (U V : Set X) (U' V' : Set Y) (hfU : Set.MapsTo f U U')
+    (hfV : Set.MapsTo f V V') (n : ℕ) (c : FirstHurewicz.Chains X n)
+    (hc : c ∈ smallChainSubmodule U V n) :
+    FirstHurewicz.inducedChain f n c ∈ smallChainSubmodule U' V' n := by
+  have hle :
+    smallChainSubmodule U V n ≤
+      (smallChainSubmodule U' V' n).comap (FirstHurewicz.inducedChain f n) := by
+    rw [smallChainSubmodule_eq_span]
+    apply Submodule.span_le.mpr
+    rintro _ ⟨σ, hσ, rfl⟩
+    change
+      FirstHurewicz.inducedChain f n (FirstHurewicz.simplexChain X n σ) ∈
+        smallChainSubmodule U' V' n
+    rw [FirstHurewicz.inducedChain_simplex]
+    apply simplexChain_mem_small
+    rcases hσ with hσ | hσ
+    · left
+      rintro _ ⟨s, rfl⟩
+      exact hfU (hσ ⟨s, rfl⟩)
+    · right
+      rintro _ ⟨s, rfl⟩
+      exact hfV (hσ ⟨s, rfl⟩)
+  exact hle hc
+
+private def
+    SingularMayerVietoris.smallMapOfMapsTo {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (f : C(X, Y)) (U V : Set X) (U' V' : Set Y) (hfU : Set.MapsTo f U U')
+    (hfV : Set.MapsTo f V V') : smallComplex U V ⟶ smallComplex U' V' :=
+  liftToSmall U' V' (smallInclusion U V ≫ FirstHurewicz.singularChainMap f)
+    (fun n c => inducedChain_mem_small_of_mapsTo f U V U' V' hfU hfV n c.1 c.2)
+
+@[simp]
+private theorem SingularMayerVietoris.smallMapOfMapsTo_inclusion {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (U V : Set X) (U' V' : Set Y) (hfU : Set.MapsTo f U U')
+    (hfV : Set.MapsTo f V V') :
+    smallMapOfMapsTo f U V U' V' hfU hfV ≫ smallInclusion U' V' =
+      smallInclusion U V ≫ FirstHurewicz.singularChainMap f :=
+  liftToSmall_inclusion U' V' _ _
+
+private theorem SingularMayerVietoris.toSmallLeft_smallMapOfMapsTo {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (U V : Set X) (U' V' : Set Y) (hfU : Set.MapsTo f U U')
+    (hfV : Set.MapsTo f V V') :
+    toSmallLeft U V ≫ smallMapOfMapsTo f U V U' V' hfU hfV =
+      FirstHurewicz.singularChainMap (coverRestriction f U U' hfU) ≫ toSmallLeft U' V' := by
+  apply (CategoryTheory.cancel_mono (smallInclusion U' V')).mp
+  calc
+    (toSmallLeft U V ≫ smallMapOfMapsTo f U V U' V' hfU hfV) ≫ smallInclusion U' V' =
+        toSmallLeft U V ≫ (smallMapOfMapsTo f U V U' V' hfU hfV ≫ smallInclusion U' V') :=
+      CategoryTheory.Category.assoc _ _ _
+    _ = toSmallLeft U V ≫ (smallInclusion U V ≫ FirstHurewicz.singularChainMap f) :=
+      (congrArg (toSmallLeft U V ≫ ·) (smallMapOfMapsTo_inclusion f U V U' V' hfU hfV))
+    _ = (toSmallLeft U V ≫ smallInclusion U V) ≫ FirstHurewicz.singularChainMap f :=
+      (CategoryTheory.Category.assoc _ _ _).symm
+    _ = FirstHurewicz.singularChainMap (subtypeInclusion U) ≫ FirstHurewicz.singularChainMap f :=
+      (congrArg (· ≫ FirstHurewicz.singularChainMap f) (toSmallLeft_inclusion U V))
+    _ =
+        FirstHurewicz.singularChainMap (coverRestriction f U U' hfU) ≫
+          FirstHurewicz.singularChainMap (subtypeInclusion U') :=
+      (coverRestriction_ambient f U U' hfU).symm
+    _ =
+        FirstHurewicz.singularChainMap (coverRestriction f U U' hfU) ≫
+          (toSmallLeft U' V' ≫ smallInclusion U' V') :=
+      (congrArg (FirstHurewicz.singularChainMap (coverRestriction f U U' hfU) ≫ ·)
+        (toSmallLeft_inclusion U' V').symm)
+    _ =
+        (FirstHurewicz.singularChainMap (coverRestriction f U U' hfU) ≫ toSmallLeft U' V') ≫
+          smallInclusion U' V' :=
+      (CategoryTheory.Category.assoc _ _ _).symm
+
+private theorem
+    SingularMayerVietoris.toSmallRight_smallMapOfMapsTo {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (U V : Set X) (U' V' : Set Y) (hfU : Set.MapsTo f U U')
+    (hfV : Set.MapsTo f V V') :
+    toSmallRight U V ≫ smallMapOfMapsTo f U V U' V' hfU hfV =
+      FirstHurewicz.singularChainMap (coverRestriction f V V' hfV) ≫ toSmallRight U' V' := by
+  apply (CategoryTheory.cancel_mono (smallInclusion U' V')).mp
+  calc
+    (toSmallRight U V ≫ smallMapOfMapsTo f U V U' V' hfU hfV) ≫ smallInclusion U' V' =
+        toSmallRight U V ≫ (smallMapOfMapsTo f U V U' V' hfU hfV ≫ smallInclusion U' V') :=
+      CategoryTheory.Category.assoc _ _ _
+    _ = toSmallRight U V ≫ (smallInclusion U V ≫ FirstHurewicz.singularChainMap f) :=
+      (congrArg (toSmallRight U V ≫ ·) (smallMapOfMapsTo_inclusion f U V U' V' hfU hfV))
+    _ = (toSmallRight U V ≫ smallInclusion U V) ≫ FirstHurewicz.singularChainMap f :=
+      (CategoryTheory.Category.assoc _ _ _).symm
+    _ = FirstHurewicz.singularChainMap (subtypeInclusion V) ≫ FirstHurewicz.singularChainMap f :=
+      (congrArg (· ≫ FirstHurewicz.singularChainMap f) (toSmallRight_inclusion U V))
+    _ =
+        FirstHurewicz.singularChainMap (coverRestriction f V V' hfV) ≫
+          FirstHurewicz.singularChainMap (subtypeInclusion V') :=
+      (coverRestriction_ambient f V V' hfV).symm
+    _ =
+        FirstHurewicz.singularChainMap (coverRestriction f V V' hfV) ≫
+          (toSmallRight U' V' ≫ smallInclusion U' V') :=
+      (congrArg (FirstHurewicz.singularChainMap (coverRestriction f V V' hfV) ≫ ·)
+        (toSmallRight_inclusion U' V').symm)
+    _ =
+        (FirstHurewicz.singularChainMap (coverRestriction f V V' hfV) ≫ toSmallRight U' V') ≫
+          smallInclusion U' V' :=
+      (CategoryTheory.Category.assoc _ _ _).symm
+
+private def
+    SingularMayerVietoris.coverMiddleMap {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (f : C(X, Y)) (U V : Set X) (U' V' : Set Y) (hfU : Set.MapsTo f U U')
+    (hfV : Set.MapsTo f V V') : middleComplex U V ⟶ middleComplex U' V' :=
+  CategoryTheory.Limits.biprod.map (FirstHurewicz.singularChainMap (coverRestriction f U U' hfU))
+    (FirstHurewicz.singularChainMap (coverRestriction f V V' hfV))
+
+private theorem
+    SingularMayerVietoris.intersectionRestriction_leftMap {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (U V : Set X) (U' V' : Set Y) (hfU : Set.MapsTo f U U')
+    (hfV : Set.MapsTo f V V') :
+    FirstHurewicz.singularChainMap (intersectionRestriction f U V U' V' hfU hfV) ≫ leftMap U' V' =
+      leftMap U V ≫ coverMiddleMap f U V U' V' hfU hfV := by
+  change
+    FirstHurewicz.singularChainMap (intersectionRestriction f U V U' V' hfU hfV) ≫
+        CategoryTheory.Limits.biprod.lift (intersectionToLeft U' V')
+          (-(intersectionToRight U' V')) =
+      CategoryTheory.Limits.biprod.lift (intersectionToLeft U V) (-(intersectionToRight U V)) ≫
+        CategoryTheory.Limits.biprod.map
+          (FirstHurewicz.singularChainMap (coverRestriction f U U' hfU))
+          (FirstHurewicz.singularChainMap (coverRestriction f V V' hfV))
+  apply CategoryTheory.Limits.biprod.hom_ext
+  · simp only [CategoryTheory.Category.assoc, CategoryTheory.Limits.biprod.lift_fst,
+      CategoryTheory.Limits.biprod.map_fst, CategoryTheory.Limits.biprod.lift_fst_assoc]
+    exact (coverRestriction_intersection_left f U V U' V' hfU hfV).symm
+  · simp only [CategoryTheory.Category.assoc, CategoryTheory.Limits.biprod.lift_snd,
+      CategoryTheory.Limits.biprod.map_snd, CategoryTheory.Limits.biprod.lift_snd_assoc,
+      CategoryTheory.Preadditive.comp_neg, CategoryTheory.Preadditive.neg_comp]
+    exact congrArg Neg.neg (coverRestriction_intersection_right f U V U' V' hfU hfV).symm
+
+private theorem SingularMayerVietoris.coverMiddleMap_rightMap {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (U V : Set X) (U' V' : Set Y) (hfU : Set.MapsTo f U U')
+    (hfV : Set.MapsTo f V V') :
+    coverMiddleMap f U V U' V' hfU hfV ≫ rightMap U' V' =
+      rightMap U V ≫ smallMapOfMapsTo f U V U' V' hfU hfV := by
+  change
+    CategoryTheory.Limits.biprod.map
+          (FirstHurewicz.singularChainMap (coverRestriction f U U' hfU))
+          (FirstHurewicz.singularChainMap (coverRestriction f V V' hfV)) ≫
+        CategoryTheory.Limits.biprod.desc (toSmallLeft U' V') (toSmallRight U' V') =
+      CategoryTheory.Limits.biprod.desc (toSmallLeft U V) (toSmallRight U V) ≫
+        smallMapOfMapsTo f U V U' V' hfU hfV
+  apply CategoryTheory.Limits.biprod.hom_ext'
+  · simp only [CategoryTheory.Limits.biprod.inl_map_assoc,
+      CategoryTheory.Limits.biprod.inl_desc_assoc, CategoryTheory.Limits.biprod.inl_desc]
+    exact (toSmallLeft_smallMapOfMapsTo f U V U' V' hfU hfV).symm
+  · simp only [CategoryTheory.Limits.biprod.inr_map_assoc,
+      CategoryTheory.Limits.biprod.inr_desc_assoc, CategoryTheory.Limits.biprod.inr_desc]
+    exact (toSmallRight_smallMapOfMapsTo f U V U' V' hfU hfV).symm
+
+private def SingularMayerVietoris.chainSequenceMapOfMapsTo {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (U V : Set X) (U' V' : Set Y) (hfU : Set.MapsTo f U U')
+    (hfV : Set.MapsTo f V V') : chainSequence U V ⟶ chainSequence U' V'
+    where
+  τ₁ := FirstHurewicz.singularChainMap (intersectionRestriction f U V U' V' hfU hfV)
+  τ₂ := coverMiddleMap f U V U' V' hfU hfV
+  τ₃ := smallMapOfMapsTo f U V U' V' hfU hfV
+  comm₁₂ := intersectionRestriction_leftMap f U V U' V' hfU hfV
+  comm₂₃ := coverMiddleMap_rightMap f U V U' V' hfU hfV
+
+private theorem SingularMayerVietoris.smallHomologyComparison_naturality_of_comm {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : C(X, Y)) (U V : Set X) (U' V' : Set Y)
+    (g : smallComplex U V ⟶ smallComplex U' V')
+    (hg : g ≫ smallInclusion U' V' = smallInclusion U V ≫ FirstHurewicz.singularChainMap f)
+    (n : ℕ) (a : SmallHomology U V n) :
+    smallHomologyComparison U' V' n (homologyLinearMap g n a) =
+      singularHomologyMap f n (smallHomologyComparison U V n a) := by
+  have h := congrArg (fun q => homologyLinearMap q n) hg
+  rw [homologyLinearMap_comp, homologyLinearMap_comp] at h
+  exact LinearMap.congr_fun h a
+
+private theorem SingularMayerVietoris.connectingHomomorphism_naturality_of_sequenceMap {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : C(X, Y)) (U V : Set X) (U' V' : Set Y)
+    (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (hU' : IsOpen U')
+    (hV' : IsOpen V') (hcover' : U' ∪ V' = Set.univ) (φ : chainSequence U V ⟶ chainSequence U' V')
+    (hφ : φ.τ₃ ≫ smallInclusion U' V' = smallInclusion U V ≫ FirstHurewicz.singularChainMap f)
+    (n : ℕ) :
+    (homologyLinearMap φ.τ₁ n).comp (connectingHomomorphism U V hU hV hcover n) =
+      (connectingHomomorphism U' V' hU' hV' hcover' n).comp (singularHomologyMap f (n + 1)) := by
+  apply LinearMap.ext
+  intro a
+  obtain ⟨b, hb⟩ := (smallHomologyEquiv U V hU hV hcover (n + 1)).surjective a
+  have hb' : smallHomologyComparison U V (n + 1) b = a := hb
+  change
+    homologyLinearMap φ.τ₁ n (connectingHomomorphism U V hU hV hcover n a) =
+      connectingHomomorphism U' V' hU' hV' hcover' n (singularHomologyMap f (n + 1) a)
+  rw [← hb', connectingHomomorphism_comparison]
+  have hδ :
+    homologyLinearMap φ.τ₁ n (smallConnectingMap U V n b) =
+      smallConnectingMap U' V' n (homologyLinearMap φ.τ₃ (n + 1) b) :=
+    LinearMap.congr_fun
+      (connectingMap_naturality (chainSequence_shortExact U V) φ (chainSequence_shortExact U' V')
+        n)
+      b
+  have hc :=
+    (connectingHomomorphism_comparison U' V' hU' hV' hcover' n
+        (homologyLinearMap φ.τ₃ (n + 1) b)).symm
+  have hn :=
+    congrArg (connectingHomomorphism U' V' hU' hV' hcover' n)
+      (smallHomologyComparison_naturality_of_comm f U V U' V' φ.τ₃ hφ (n + 1) b)
+  exact hδ.trans (hc.trans hn)
+
+private theorem
+    SingularMayerVietoris.connectingHomomorphism_naturality {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (U V : Set X) (U' V' : Set Y) (hfU : Set.MapsTo f U U')
+    (hfV : Set.MapsTo f V V') (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ)
+    (hU' : IsOpen U') (hV' : IsOpen V') (hcover' : U' ∪ V' = Set.univ) (n : ℕ) :
+    (singularHomologyMap (intersectionRestriction f U V U' V' hfU hfV) n).comp
+        (connectingHomomorphism U V hU hV hcover n) =
+      (connectingHomomorphism U' V' hU' hV' hcover' n).comp (singularHomologyMap f (n + 1)) :=
+  connectingHomomorphism_naturality_of_sequenceMap f U V U' V' hU hV hcover hU' hV' hcover'
+    (chainSequenceMapOfMapsTo f U V U' V' hfU hfV)
+    (smallMapOfMapsTo_inclusion f U V U' V' hfU hfV) n
+
+private theorem SingularMayerVietoris.connectingHomomorphism_naturality_apply {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : C(X, Y)) (U V : Set X) (U' V' : Set Y)
+    (hfU : Set.MapsTo f U U') (hfV : Set.MapsTo f V V') (hU : IsOpen U) (hV : IsOpen V)
+    (hcover : U ∪ V = Set.univ) (hU' : IsOpen U') (hV' : IsOpen V') (hcover' : U' ∪ V' = Set.univ)
+    (n : ℕ) (a : SingularHomology X (n + 1)) :
+    singularHomologyMap (intersectionRestriction f U V U' V' hfU hfV) n
+        (connectingHomomorphism U V hU hV hcover n a) =
+      connectingHomomorphism U' V' hU' hV' hcover' n (singularHomologyMap f (n + 1) a) :=
+  LinearMap.congr_fun
+    (connectingHomomorphism_naturality f U V U' V' hfU hfV hU hV hcover hU' hV' hcover' n) a
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/HomologyTheory/SingularMayerVietoris.lean b/LeanPool/HopfProblem/HomologyTheory/SingularMayerVietoris.lean
new file mode 100644
index 000000000..7a3ee3dce
--- /dev/null
+++ b/LeanPool/HopfProblem/HomologyTheory/SingularMayerVietoris.lean
@@ -0,0 +1,3722 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.HomologyOfX.SmallChainBiprod
+import all LeanPool.HopfProblem.HomologyOfX.SmallChainBiprod
+
+/-!
+# Hopf problem: homology theory · singular mayer vietoris
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private abbrev FirstHurewicz.Simplex (n : ℕ) :=
+  stdSimplex ℝ (Fin (n + 1))
+
+private def FirstHurewicz.simplexFace (n : ℕ) (i : Fin (n + 2)) : C(Simplex n, Simplex (n + 1)) :=
+  ⟨stdSimplex.map (SimplexCategory.δ i).toOrderHom,
+    stdSimplex.continuous_map (SimplexCategory.δ i).toOrderHom⟩
+
+private theorem FirstHurewicz.simplexFace_apply (n : ℕ) (i : Fin (n + 2)) (s : Simplex n) :
+    simplexFace n i s = stdSimplex.map i.succAbove s :=
+  rfl
+
+private def FirstHurewicz.simplexCoordinate (n : ℕ) (i : Fin (n + 1)) : C(Simplex n, unitInterval)
+    where
+  toFun s := ⟨s i, stdSimplex.zero_le s i, stdSimplex.le_one s i⟩
+  continuous_toFun := ((continuous_apply i).comp continuous_subtype_val).subtype_mk _
+
+@[simp]
+private theorem FirstHurewicz.simplexFace_apply_self (n : ℕ) (i : Fin (n + 2)) (s : Simplex n) :
+    simplexFace n i s i = 0 := by
+  change FunOnFinite.linearMap ℝ ℝ i.succAbove (s : Fin (n + 1) → ℝ) i = 0
+  rw [FunOnFinite.linearMap_apply_apply]
+  apply Finset.sum_eq_zero
+  intro k hk
+  exact False.elim (Fin.succAbove_ne i k (Finset.mem_filter.mp hk).2)
+
+@[simp]
+private theorem FirstHurewicz.simplexFace_apply_succAbove (n : ℕ) (i : Fin (n + 2)) (s : Simplex n)
+    (k : Fin (n + 1)) : simplexFace n i s (i.succAbove k) = s k := by
+  change FunOnFinite.linearMap ℝ ℝ i.succAbove (s : Fin (n + 1) → ℝ) (i.succAbove k) = s k
+  simp [FunOnFinite.linearMap_apply_apply, Fin.succAbove_right_injective.eq_iff,
+    Finset.sum_filter]
+
+private theorem FirstHurewicz.simplexFace_one_zero (s : Simplex 1) :
+    (simplexFace 1 0 s : Fin 3 → ℝ) = ![0, s 0, s 1] := by
+  funext k
+  fin_cases k
+  · exact simplexFace_apply_self 1 0 s
+  · exact simplexFace_apply_succAbove 1 0 s 0
+  · exact simplexFace_apply_succAbove 1 0 s 1
+
+private theorem FirstHurewicz.simplexFace_one_one (s : Simplex 1) :
+    (simplexFace 1 1 s : Fin 3 → ℝ) = ![s 0, 0, s 1] := by
+  funext k
+  fin_cases k
+  · exact simplexFace_apply_succAbove 1 1 s 0
+  · exact simplexFace_apply_self 1 1 s
+  · exact simplexFace_apply_succAbove 1 1 s 1
+
+private theorem FirstHurewicz.simplexFace_one_two (s : Simplex 1) :
+    (simplexFace 1 2 s : Fin 3 → ℝ) = ![s 0, s 1, 0] := by
+  funext k
+  fin_cases k
+  · exact simplexFace_apply_succAbove 1 2 s 0
+  · exact simplexFace_apply_succAbove 1 2 s 1
+  · exact simplexFace_apply_self 1 2 s
+
+private theorem FirstHurewicz.simplexZero_eq_vertex (s : Simplex 0) :
+    s = stdSimplex.vertex (S := ℝ) (0 : Fin 1) := by
+  let : Unique (Fin (0 + 1)) := inferInstanceAs (Unique (Fin 1))
+  apply Subtype.ext
+  funext k
+  fin_cases k
+  change s 0 = 1
+  exact stdSimplex.eq_one_of_unique (s : stdSimplex ℝ (Fin 1)) (0 : Fin 1)
+
+@[simp]
+private theorem FirstHurewicz.simplexFace_zero_zero (s : Simplex 0) :
+    simplexFace 0 0 s = stdSimplex.vertex (S := ℝ) (1 : Fin 2) := by
+  rw [simplexZero_eq_vertex s, simplexFace_apply, stdSimplex.map_vertex]
+  rfl
+
+@[simp]
+private theorem FirstHurewicz.simplexFace_zero_one (s : Simplex 0) :
+    simplexFace 0 1 s = stdSimplex.vertex (S := ℝ) (0 : Fin 2) := by
+  rw [simplexZero_eq_vertex s, simplexFace_apply, stdSimplex.map_vertex]
+  rfl
+
+private def FirstHurewicz.pathSimplex {X : Type*} [TopologicalSpace X] {x y : X} (p : Path x y) :
+    C(Simplex 1, X) :=
+  p.toContinuousMap.comp
+    ⟨stdSimplexHomeomorphUnitInterval, stdSimplexHomeomorphUnitInterval.continuous⟩
+
+@[simp]
+private theorem FirstHurewicz.pathSimplex_vertex_zero {X : Type*} [TopologicalSpace X] {x y : X}
+    (p : Path x y) : pathSimplex p (stdSimplex.vertex (S := ℝ) (0 : Fin 2)) = x := by
+  change p (stdSimplexHomeomorphUnitInterval _) = x
+  rw [stdSimplexHomeomorphUnitInterval_zero, p.source]
+
+@[simp]
+private theorem FirstHurewicz.pathSimplex_vertex_one {X : Type*} [TopologicalSpace X] {x y : X}
+    (p : Path x y) : pathSimplex p (stdSimplex.vertex (S := ℝ) (1 : Fin 2)) = y := by
+  change p (stdSimplexHomeomorphUnitInterval _) = y
+  rw [stdSimplexHomeomorphUnitInterval_one, p.target]
+
+@[simp]
+private theorem FirstHurewicz.pathSimplex_face_zero {X : Type*} [TopologicalSpace X] {x y : X}
+    (p : Path x y) : (pathSimplex p).comp (simplexFace 0 0) = ContinuousMap.const (Simplex 0) y :=
+  by
+  apply ContinuousMap.ext
+  intro s
+  change pathSimplex p (simplexFace 0 0 s) = y
+  rw [simplexFace_zero_zero, pathSimplex_vertex_one]
+
+@[simp]
+private theorem FirstHurewicz.pathSimplex_face_one {X : Type*} [TopologicalSpace X] {x y : X}
+    (p : Path x y) : (pathSimplex p).comp (simplexFace 0 1) = ContinuousMap.const (Simplex 0) x :=
+  by
+  apply ContinuousMap.ext
+  intro s
+  change pathSimplex p (simplexFace 0 1 s) = x
+  rw [simplexFace_zero_one, pathSimplex_vertex_zero]
+
+private def FirstHurewicz.simplexPath {X : Type*} [TopologicalSpace X] (σ : C(Simplex 1, X)) :
+    Path (σ (stdSimplex.vertex (S := ℝ) (0 : Fin 2))) (σ (stdSimplex.vertex (S := ℝ) (1 : Fin 2)))
+    where
+  toFun t := σ (stdSimplexHomeomorphUnitInterval.symm t)
+  continuous_toFun := σ.continuous.comp stdSimplexHomeomorphUnitInterval.symm.continuous
+  source' :=
+    congrArg σ
+      (stdSimplexHomeomorphUnitInterval.symm_apply_eq.mpr
+        stdSimplexHomeomorphUnitInterval_zero.symm)
+  target' :=
+    congrArg σ
+      (stdSimplexHomeomorphUnitInterval.symm_apply_eq.mpr
+        stdSimplexHomeomorphUnitInterval_one.symm)
+
+@[simp]
+private theorem FirstHurewicz.pathSimplex_simplexPath {X : Type*} [TopologicalSpace X]
+    (σ : C(Simplex 1, X)) : pathSimplex (simplexPath σ) = σ := by
+  apply ContinuousMap.ext
+  intro s
+  change σ (stdSimplexHomeomorphUnitInterval.symm (stdSimplexHomeomorphUnitInterval s)) = σ s
+  rw [Homeomorph.symm_apply_apply]
+
+private def FirstHurewicz.concatTime : C(Simplex 2, unitInterval)
+    where
+  toFun
+    s :=
+    ⟨s 1 / 2 + s 2, by
+      have h0 := stdSimplex.zero_le s 0
+      have h1 := stdSimplex.zero_le s 1
+      have h2 := stdSimplex.zero_le s 2
+      have hs := stdSimplex.sum_eq_one s
+      simp only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero] at hs
+      change s 0 + (s 1 + s 2) = 1 at hs
+      constructor <;> linarith⟩
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    exact
+      ((continuous_apply (1 : Fin 3)).comp continuous_subtype_val).div_const 2 |>.add
+        ((continuous_apply (2 : Fin 3)).comp continuous_subtype_val)
+
+private def FirstHurewicz.concatSimplex {X : Type*} [TopologicalSpace X] {x y z : X} (p : Path x y)
+    (q : Path y z) : C(Simplex 2, X) :=
+  (p.trans q).toContinuousMap.comp concatTime
+
+private theorem FirstHurewicz.concatSimplex_apply {X : Type*} [TopologicalSpace X] {x y z : X}
+    (p : Path x y) (q : Path y z) (s : Simplex 2) :
+    concatSimplex p q s = (p.trans q).extend (s 1 / 2 + s 2) :=
+  (Path.extend_apply (p.trans q) (concatTime s).property).symm
+
+@[simp]
+private theorem FirstHurewicz.concatSimplex_face_zero {X : Type*} [TopologicalSpace X] {x y z : X}
+    (p : Path x y) (q : Path y z) : (concatSimplex p q).comp (simplexFace 1 0) = pathSimplex q := by
+  apply ContinuousMap.ext
+  intro s
+  change concatSimplex p q (simplexFace 1 0 s) = pathSimplex q s
+  rw [concatSimplex_apply]
+  have h1 : simplexFace 1 0 s 1 = s 0 := simplexFace_apply_succAbove 1 0 s 0
+  have h2 : simplexFace 1 0 s 2 = s 1 := simplexFace_apply_succAbove 1 0 s 1
+  rw [h1, h2]
+  have hs := stdSimplex.add_eq_one s
+  have hnonneg := stdSimplex.zero_le s 1
+  rw [Path.extend_trans_of_half_le p q (show 1 / 2 ≤ s 0 / 2 + s 1 by linarith)]
+  have he : 2 * (s 0 / 2 + s 1) - 1 = s 1 := by linarith
+  rw [he]
+  exact Path.extend_apply q (simplexCoordinate 1 1 s).property
+
+@[simp]
+private theorem FirstHurewicz.concatSimplex_face_one {X : Type*} [TopologicalSpace X] {x y z : X}
+    (p : Path x y) (q : Path y z) :
+    (concatSimplex p q).comp (simplexFace 1 1) = pathSimplex (p.trans q) := by
+  apply ContinuousMap.ext
+  intro s
+  change concatSimplex p q (simplexFace 1 1 s) = pathSimplex (p.trans q) s
+  rw [concatSimplex_apply, simplexFace_apply_self]
+  have h2 : simplexFace 1 1 s 2 = s 1 := simplexFace_apply_succAbove 1 1 s 1
+  rw [h2, zero_div, zero_add]
+  exact Path.extend_apply (p.trans q) (simplexCoordinate 1 1 s).property
+
+@[simp]
+private theorem FirstHurewicz.concatSimplex_face_two {X : Type*} [TopologicalSpace X] {x y z : X}
+    (p : Path x y) (q : Path y z) : (concatSimplex p q).comp (simplexFace 1 2) = pathSimplex p := by
+  apply ContinuousMap.ext
+  intro s
+  change concatSimplex p q (simplexFace 1 2 s) = pathSimplex p s
+  rw [concatSimplex_apply, simplexFace_apply_self]
+  have h1 : simplexFace 1 2 s 1 = s 1 := simplexFace_apply_succAbove 1 2 s 1
+  rw [h1, add_zero]
+  have hle := stdSimplex.le_one s 1
+  rw [Path.extend_trans_of_le_half p q (show s 1 / 2 ≤ 1 / 2 by linarith)]
+  rw [show 2 * (s 1 / 2) = s 1 by ring]
+  exact Path.extend_apply p (simplexCoordinate 1 1 s).property
+
+/-- The integral singular chain complex of a topological space. -/
+public
+abbrev FirstHurewicz.singularComplex (X : Type) [TopologicalSpace X] :
+    ChainComplex (ModuleCat ℤ) ℕ :=
+  (TopCat.toSSet.obj (TopCat.of X)).chainComplex (ModuleCat.of ℤ ℤ)
+
+/-- The degree-`n` group of integral singular chains. -/
+public
+abbrev FirstHurewicz.Chains (X : Type) [TopologicalSpace X] (n : ℕ) :=
+  (singularComplex X).X n
+
+/-- The first integral singular homology group. -/
+public
+abbrev FirstHurewicz.SingularH1 (X : Type) [TopologicalSpace X] :=
+  (singularComplex X).homology 1
+
+private abbrev FirstHurewicz.SingularSimplex (X : Type) [TopologicalSpace X] (n : ℕ) :=
+  C(stdSimplex ℝ (Fin (n + 1)), X)
+
+private def
+    FirstHurewicz.simplexIndex (X : Type) [TopologicalSpace X] (n : ℕ) (σ : SingularSimplex X n) :
+    (TopCat.toSSet.obj (TopCat.of X)).obj (Opposite.op (SimplexCategory.mk (n))) :=
+  ((TopCat.of X).toSSetObjEquiv (.op (SimplexCategory.mk (n)))).symm σ
+
+private def
+    FirstHurewicz.simplexChain (X : Type) [TopologicalSpace X] (n : ℕ) (σ : SingularSimplex X n) :
+    Chains X n :=
+  ((TopCat.toSSet.obj (TopCat.of X)).ιChainComplex (R := ModuleCat.of ℤ ℤ) (simplexIndex X n σ)) 1
+
+private abbrev
+    FirstHurewicz.boundaryOne (X : Type) [TopologicalSpace X] : Chains X 1 →ₗ[ℤ] Chains X 0 :=
+  (singularComplex X).d 1 0 |>.hom
+
+private abbrev
+    FirstHurewicz.boundaryTwo (X : Type) [TopologicalSpace X] : Chains X 2 →ₗ[ℤ] Chains X 1 :=
+  (singularComplex X).d 2 1 |>.hom
+
+private theorem FirstHurewicz.simplexIndex_face (X : Type) [TopologicalSpace X] (n : ℕ)
+    (σ : SingularSimplex X (n + 1)) (i : Fin (n + 2)) :
+    (TopCat.toSSet.obj (TopCat.of X)).δ i (simplexIndex X (n + 1) σ) =
+      simplexIndex X n (σ.comp (simplexFace n i)) := by rfl
+
+private theorem FirstHurewicz.boundary_simplex (X : Type) [TopologicalSpace X] (n : ℕ)
+    (σ : SingularSimplex X (n + 1)) :
+    (singularComplex X).d (n + 1) n (simplexChain X (n + 1) σ) =
+      ∑ i : Fin (n + 2), (-1 : ℤ) ^ i.val • simplexChain X n (σ.comp (simplexFace n i)) := by
+  have h :=
+    (TopCat.toSSet.obj (TopCat.of X)).ιChainComplex_d (R := ModuleCat.of ℤ ℤ)
+      (simplexIndex X (n + 1) σ)
+  let ev : (ModuleCat.of ℤ ℤ ⟶ Chains X n) →+ Chains X n :=
+    { toFun := fun f => f.hom 1
+      map_zero' := rfl
+      map_add' := fun _ _ => rfl }
+  have he := congrArg ev h
+  rw [map_sum] at he
+  simp only [map_zsmul, simplexIndex_face] at he
+  exact he
+
+private theorem FirstHurewicz.boundaryOne_simplex (X : Type) [TopologicalSpace X]
+    (σ : SingularSimplex X 1) :
+    boundaryOne X (simplexChain X 1 σ) =
+      simplexChain X 0 (σ.comp (simplexFace 0 0)) - simplexChain X 0 (σ.comp (simplexFace 0 1)) :=
+  by simpa [Fin.sum_univ_succ, sub_eq_add_neg] using boundary_simplex X 0 σ
+
+private theorem FirstHurewicz.boundaryTwo_simplex (X : Type) [TopologicalSpace X]
+    (σ : SingularSimplex X 2) :
+    boundaryTwo X (simplexChain X 2 σ) =
+      simplexChain X 1 (σ.comp (simplexFace 1 0)) - simplexChain X 1 (σ.comp (simplexFace 1 1)) +
+        simplexChain X 1 (σ.comp (simplexFace 1 2)) := by
+  simpa [Fin.sum_univ_succ, sub_eq_add_neg, add_assoc] using boundary_simplex X 1 σ
+
+private def
+    FirstHurewicz.chainLift (X : Type) [TopologicalSpace X] (n : ℕ) {M : Type} [AddCommGroup M]
+    [Module ℤ M] (f : SingularSimplex X n → M) : Chains X n →ₗ[ℤ] M :=
+  (CategoryTheory.Limits.Sigma.desc
+        (fun s : (TopCat.toSSet.obj (TopCat.of X)).obj (Opposite.op (SimplexCategory.mk (n))) =>
+          ModuleCat.ofHom
+            (LinearMap.toSpanSingleton ℤ M
+              (f ((TopCat.of X).toSSetObjEquiv (.op (SimplexCategory.mk (n))) s)))) :
+      Chains X n ⟶ ModuleCat.of ℤ M).hom
+
+@[simp]
+private theorem FirstHurewicz.chainLift_simplex (X : Type) [TopologicalSpace X] (n : ℕ) {M : Type}
+    [AddCommGroup M] [Module ℤ M] (f : SingularSimplex X n → M) (σ : SingularSimplex X n) :
+    chainLift X n f (simplexChain X n σ) = f σ := by
+  have h :=
+    CategoryTheory.Limits.Sigma.ι_desc
+      (fun s : (TopCat.toSSet.obj (TopCat.of X)).obj (Opposite.op (SimplexCategory.mk (n))) =>
+        ModuleCat.ofHom
+          (LinearMap.toSpanSingleton ℤ M
+            (f ((TopCat.of X).toSSetObjEquiv (.op (SimplexCategory.mk (n))) s))))
+      (simplexIndex X n σ)
+  have he := congrArg (fun g : ModuleCat.of ℤ ℤ ⟶ ModuleCat.of ℤ M => g.hom 1) h
+  change
+    chainLift X n f (simplexChain X n σ) =
+      (LinearMap.toSpanSingleton ℤ M
+          (f ((TopCat.of X).toSSetObjEquiv (.op (SimplexCategory.mk (n))) (simplexIndex X n σ))))
+        1 at he
+  simpa only [LinearMap.toSpanSingleton_apply_one, simplexIndex, Equiv.apply_symm_apply] using he
+
+private theorem FirstHurewicz.chainMap_ext (X : Type) [TopologicalSpace X] (n : ℕ) {M : Type}
+    [AddCommGroup M] [Module ℤ M] {f g : Chains X n →ₗ[ℤ] M}
+    (h : ∀ σ : SingularSimplex X n, f (simplexChain X n σ) = g (simplexChain X n σ)) : f = g := by
+  have hcat : (ModuleCat.ofHom f : Chains X n ⟶ ModuleCat.of ℤ M) = ModuleCat.ofHom g := by
+    apply SSet.chainComplex_hom_ext
+    intro s
+    apply ModuleCat.hom_ext
+    apply LinearMap.ext_ring
+    change
+      f (((TopCat.toSSet.obj (TopCat.of X)).ιChainComplex (R := ModuleCat.of ℤ ℤ) s).hom 1) =
+        g (((TopCat.toSSet.obj (TopCat.of X)).ιChainComplex (R := ModuleCat.of ℤ ℤ) s).hom 1)
+    have hs := h ((TopCat.of X).toSSetObjEquiv (.op (SimplexCategory.mk (n))) s)
+    simpa only [simplexChain, simplexIndex, Equiv.symm_apply_apply] using hs
+  exact congrArg ModuleCat.Hom.hom hcat
+
+/-- The kernel defining cycles in a short complex. -/
+public
+abbrev FirstHurewicz.ChainHomology.ShortCycle
+    (S : CategoryTheory.ShortComplex (ModuleCat.{0} ℤ)) :=
+  LinearMap.ker S.g.hom
+
+/-- The natural integer-module structure on short-complex cycles. -/
+@[instance_reducible]
+public
+def FirstHurewicz.ChainHomology.shortCycleModule
+    (S : CategoryTheory.ShortComplex (ModuleCat.{0} ℤ)) : Module ℤ (ShortCycle S) :=
+  (LinearMap.ker S.g.hom).module
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private abbrev FirstHurewicz.ChainHomology.ShortBoundaries
+    (S : CategoryTheory.ShortComplex (ModuleCat.{0} ℤ)) : Submodule ℤ (ShortCycle S) :=
+  LinearMap.range S.moduleCatToCycles
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private def FirstHurewicz.ChainHomology.shortCycleClass
+    (S : CategoryTheory.ShortComplex (ModuleCat.{0} ℤ)) : ShortCycle S →ₗ[ℤ] S.homology :=
+  S.moduleCatHomologyIso.inv.hom.comp (ShortBoundaries S).mkQ
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private theorem FirstHurewicz.ChainHomology.shortCycleClass_surjective
+    (S : CategoryTheory.ShortComplex (ModuleCat.{0} ℤ)) :
+    Function.Surjective (shortCycleClass S) :=
+  ((ModuleCat.epi_iff_surjective S.moduleCatHomologyIso.inv).mp inferInstance).comp
+    (ShortBoundaries S).mkQ_surjective
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private theorem FirstHurewicz.ChainHomology.shortCycleClass_eq_zero_iff
+    (S : CategoryTheory.ShortComplex (ModuleCat.{0} ℤ)) (c : ShortCycle S) :
+    shortCycleClass S c = 0 ↔ ∃ b : S.X₁, S.f b = c.1 := by
+  have hinj : Function.Injective S.moduleCatHomologyIso.inv :=
+    (ModuleCat.mono_iff_injective _).mp inferInstance
+  constructor
+  · intro h
+    have hq : (Submodule.Quotient.mk c : ShortCycle S ⧸ ShortBoundaries S) = 0 :=
+      hinj (h.trans S.moduleCatHomologyIso.inv.hom.map_zero.symm)
+    obtain ⟨b, hb⟩ := (Submodule.Quotient.mk_eq_zero (ShortBoundaries S)).mp hq
+    exact ⟨b, congrArg Subtype.val hb⟩
+  · rintro ⟨b, hb⟩
+    have hc : c ∈ ShortBoundaries S := ⟨b, Subtype.ext hb⟩
+    have hq := (Submodule.Quotient.mk_eq_zero (ShortBoundaries S)).mpr hc
+    exact
+      (congrArg S.moduleCatHomologyIso.inv.hom hq).trans S.moduleCatHomologyIso.inv.hom.map_zero
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private abbrev FirstHurewicz.ChainHomology.ShortOpchains
+    (S : CategoryTheory.ShortComplex (ModuleCat.{0} ℤ)) :=
+  S.X₂ ⧸ LinearMap.range S.f.hom
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+@[instance_reducible]
+private def FirstHurewicz.ChainHomology.shortOpchainsModule
+    (S : CategoryTheory.ShortComplex (ModuleCat.{0} ℤ)) : Module ℤ (ShortOpchains S) :=
+  Submodule.Quotient.module (LinearMap.range S.f.hom)
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule in
+private def FirstHurewicz.ChainHomology.shortHomologyToChainClass
+    (S : CategoryTheory.ShortComplex (ModuleCat.{0} ℤ)) : S.homology →ₗ[ℤ] ShortOpchains S :=
+  (S.homologyι ≫ S.moduleCatOpcyclesIso.hom).hom
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule in
+private theorem FirstHurewicz.ChainHomology.shortHomologyToChainClass_injective
+    (S : CategoryTheory.ShortComplex (ModuleCat.{0} ℤ)) :
+    Function.Injective (shortHomologyToChainClass S) :=
+  (ModuleCat.mono_iff_injective (S.homologyι ≫ S.moduleCatOpcyclesIso.hom)).mp inferInstance
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule in
+private theorem FirstHurewicz.ChainHomology.shortHomologyToChainClass_cycleClass
+    (S : CategoryTheory.ShortComplex (ModuleCat.{0} ℤ)) (c : ShortCycle S) :
+    shortHomologyToChainClass S (shortCycleClass S c) =
+      (Submodule.Quotient.mk c.1 : ShortOpchains S) := by
+  have hcat :
+    S.moduleCatLeftHomologyData.π ≫
+        S.moduleCatHomologyIso.inv ≫ S.homologyι ≫ S.moduleCatOpcyclesIso.hom =
+      S.moduleCatLeftHomologyData.i ≫ ModuleCat.ofHom (LinearMap.range S.f.hom).mkQ := by
+    rw [← S.moduleCatCyclesIso_inv_π_assoc, S.homology_π_ι_assoc,
+      S.moduleCatCyclesIso_inv_iCycles_assoc, S.pOpcycles_comp_moduleCatOpcyclesIso_hom]
+  exact congrArg (fun f => f.hom c) hcat
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortOpchainsModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule in
+/-- The one-cycles of a chain complex. -/
+public
+abbrev FirstHurewicz.ChainHomology.Cycle1 (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) :=
+  ShortCycle (K.sc 1)
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortOpchainsModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule in
+private abbrev FirstHurewicz.ChainHomology.Boundaries1 (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) :
+    Submodule ℤ (Cycle1 K) :=
+  ShortBoundaries (K.sc 1)
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortOpchainsModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule in
+/-- The linear map sending a one-cycle to its homology class. -/
+public
+def FirstHurewicz.ChainHomology.cycleClass (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) :
+    Cycle1 K →ₗ[ℤ] K.homology 1 :=
+  shortCycleClass (K.sc 1)
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortOpchainsModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule in
+private theorem
+    FirstHurewicz.ChainHomology.cycleClass_surjective (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) :
+    Function.Surjective (cycleClass K) :=
+  shortCycleClass_surjective (K.sc 1)
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortOpchainsModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule in
+private def FirstHurewicz.ChainHomology.mkCycle1 (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) (z : K.X 1)
+    (hz : (K.d 1 0).hom z = 0) : Cycle1 K :=
+  ⟨z, by
+    change (K.d 1 ((ComplexShape.down ℕ).next 1)).hom z = 0
+    have hn : (ComplexShape.down ℕ).next 1 = 0 := (ComplexShape.down ℕ).next_eq' (by simp)
+    rw [hn]
+    exact hz⟩
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortOpchainsModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule in
+private theorem
+    FirstHurewicz.ChainHomology.cycleClass_eq_zero_iff (K : ChainComplex (ModuleCat.{0} ℤ) ℕ)
+    (c : Cycle1 K) : cycleClass K c = 0 ↔ ∃ b : K.X 2, (K.d 2 1).hom b = c.1 := by
+  change shortCycleClass (K.sc 1) c = 0 ↔ _
+  rw [shortCycleClass_eq_zero_iff]
+  change
+    (∃ b : K.X ((ComplexShape.down ℕ).prev 1),
+        (K.d ((ComplexShape.down ℕ).prev 1) 1).hom b = c.1) ↔
+      _
+  have hp : (ComplexShape.down ℕ).prev 1 = 2 := (ComplexShape.down ℕ).prev_eq' (by simp)
+  rw [hp]
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortOpchainsModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule in
+private def FirstHurewicz.ChainHomology.boundaryCycle1 (K : ChainComplex (ModuleCat.{0} ℤ) ℕ)
+    (b : K.X 2) : Cycle1 K :=
+  mkCycle1 K ((K.d 2 1).hom b) (congrArg (fun f : K.X 2 ⟶ K.X 0 => f.hom b) (K.d_comp_d 2 1 0))
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortOpchainsModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule in
+private abbrev FirstHurewicz.ChainHomology.Opchains (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) :=
+  K.X 1 ⧸ LinearMap.range (K.d 2 1).hom
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortOpchainsModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule in
+@[instance_reducible]
+private def FirstHurewicz.ChainHomology.opchainsModule (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) :
+    Module ℤ (Opchains K) :=
+  Submodule.Quotient.module (LinearMap.range (K.d 2 1).hom)
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortOpchainsModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule FirstHurewicz.ChainHomology.opchainsModule in
+private def FirstHurewicz.ChainHomology.chainClass (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) :
+    K.X 1 →ₗ[ℤ] Opchains K :=
+  (LinearMap.range (K.d 2 1).hom).mkQ
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortOpchainsModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule FirstHurewicz.ChainHomology.opchainsModule in
+@[simp]
+private theorem
+    FirstHurewicz.ChainHomology.chainClass_boundary (K : ChainComplex (ModuleCat.{0} ℤ) ℕ)
+    (b : K.X 2) : chainClass K ((K.d 2 1).hom b) = 0 :=
+  (Submodule.Quotient.mk_eq_zero (LinearMap.range (K.d 2 1).hom)).mpr ⟨b, rfl⟩
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortOpchainsModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule FirstHurewicz.ChainHomology.opchainsModule in
+private theorem FirstHurewicz.ChainHomology.chainClass_eq_iff (K : ChainComplex (ModuleCat.{0} ℤ) ℕ)
+    (x y : K.X 1) : chainClass K x = chainClass K y ↔ ∃ b : K.X 2, (K.d 2 1).hom b = x - y :=
+  Submodule.Quotient.eq _
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortOpchainsModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule FirstHurewicz.ChainHomology.opchainsModule in
+private theorem FirstHurewicz.ChainHomology.range_sc_one_f (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) :
+    LinearMap.range (K.sc 1).f.hom = LinearMap.range (K.d 2 1).hom := by
+  change LinearMap.range (K.d ((ComplexShape.down ℕ).prev 1) 1).hom = _
+  have hp : (ComplexShape.down ℕ).prev 1 = 2 := (ComplexShape.down ℕ).prev_eq' (by simp)
+  rw [hp]
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortOpchainsModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule FirstHurewicz.ChainHomology.opchainsModule in
+private def FirstHurewicz.ChainHomology.opchainsEquiv (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) :
+    ShortOpchains (K.sc 1) ≃ₗ[ℤ] Opchains K :=
+  Submodule.quotEquivOfEq _ _ (range_sc_one_f K)
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortOpchainsModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule FirstHurewicz.ChainHomology.opchainsModule in
+private def
+    FirstHurewicz.ChainHomology.homologyToChainClass (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) :
+    K.homology 1 →ₗ[ℤ] Opchains K :=
+  (opchainsEquiv K).toLinearMap.comp (shortHomologyToChainClass (K.sc 1))
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortOpchainsModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule FirstHurewicz.ChainHomology.opchainsModule in
+private theorem FirstHurewicz.ChainHomology.homologyToChainClass_injective
+    (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) : Function.Injective (homologyToChainClass K) :=
+  (opchainsEquiv K).injective.comp (shortHomologyToChainClass_injective (K.sc 1))
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortOpchainsModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule FirstHurewicz.ChainHomology.opchainsModule in
+@[simp]
+private theorem FirstHurewicz.ChainHomology.homologyToChainClass_cycleClass
+    (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) (c : Cycle1 K) :
+    homologyToChainClass K (cycleClass K c) = chainClass K c.1 := by
+  change opchainsEquiv K (shortHomologyToChainClass (K.sc 1) (shortCycleClass (K.sc 1) c)) = _
+  rw [shortHomologyToChainClass_cycleClass]
+  rfl
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortOpchainsModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule FirstHurewicz.ChainHomology.opchainsModule in
+private theorem
+    FirstHurewicz.ChainHomology.boundaries1_le_ker (K : ChainComplex (ModuleCat.{0} ℤ) ℕ)
+    {M : Type*} [AddCommGroup M] [Module ℤ M] (f : Cycle1 K →ₗ[ℤ] M)
+    (hf : ∀ b : K.X 2, f (boundaryCycle1 K b) = 0) : Boundaries1 K ≤ LinearMap.ker f := by
+  rintro c ⟨b, hb⟩
+  have hc : cycleClass K c = 0 :=
+    (shortCycleClass_eq_zero_iff (K.sc 1) c).mpr ⟨b, congrArg Subtype.val hb⟩
+  obtain ⟨b', hb'⟩ := (cycleClass_eq_zero_iff K c).mp hc
+  have he : boundaryCycle1 K b' = c := Subtype.ext hb'
+  exact (congrArg f he).symm.trans (hf b')
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortOpchainsModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule FirstHurewicz.ChainHomology.opchainsModule in
+private def
+    FirstHurewicz.ChainHomology.homologyDesc (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) {M : Type*}
+    [AddCommGroup M] [Module ℤ M] (f : Cycle1 K →ₗ[ℤ] M)
+    (hf : ∀ b : K.X 2, f (boundaryCycle1 K b) = 0) : K.homology 1 →ₗ[ℤ] M :=
+  ((Boundaries1 K).liftQ f (boundaries1_le_ker K f hf)).comp (K.sc 1).moduleCatHomologyIso.hom.hom
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortOpchainsModule in
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule FirstHurewicz.ChainHomology.opchainsModule in
+@[simp]
+private theorem
+    FirstHurewicz.ChainHomology.homologyDesc_cycleClass (K : ChainComplex (ModuleCat.{0} ℤ) ℕ)
+    {M : Type*} [AddCommGroup M] [Module ℤ M] (f : Cycle1 K →ₗ[ℤ] M)
+    (hf : ∀ b : K.X 2, f (boundaryCycle1 K b) = 0) (c : Cycle1 K) :
+    homologyDesc K f hf (cycleClass K c) = f c := by
+  have h :=
+    congrArg (fun q => q.hom (Submodule.Quotient.mk c)) (K.sc 1).moduleCatHomologyIso.inv_hom_id
+  exact congrArg ((Boundaries1 K).liftQ f (boundaries1_le_ker K f hf)) h
+
+/-- The group of singular one-cycles of a topological space. -/
+public
+abbrev FirstHurewicz.Cycles1 (X : Type) [TopologicalSpace X] :=
+  ChainHomology.Cycle1 (singularComplex X)
+
+public
+instance FirstHurewicz.cycles1Module (X : Type) [TopologicalSpace X] : Module ℤ (Cycles1 X) :=
+  ChainHomology.shortCycleModule ((singularComplex X).sc 1)
+
+private def FirstHurewicz.cycleVal (X : Type) [TopologicalSpace X] : Cycles1 X →ₗ[ℤ] Chains X 1 :=
+  (LinearMap.ker ((singularComplex X).sc 1).g.hom).subtype
+
+private def FirstHurewicz.mkCycle1 (X : Type) [TopologicalSpace X] (c : Chains X 1)
+    (hc : boundaryOne X c = 0) : Cycles1 X :=
+  ChainHomology.mkCycle1 (singularComplex X) c hc
+
+private theorem FirstHurewicz.cycles1_boundary (X : Type) [TopologicalSpace X] (c : Cycles1 X) :
+    boundaryOne X c.1 = 0 := by
+  have hc := c.2
+  change ((singularComplex X).d 1 ((ComplexShape.down ℕ).next 1)).hom c.1 = 0 at hc
+  have hn : (ComplexShape.down ℕ).next 1 = 0 := (ComplexShape.down ℕ).next_eq' (by simp)
+  rw [hn] at hc
+  exact hc
+
+/-- The linear map from singular one-cycles to first homology. -/
+public
+abbrev FirstHurewicz.cycleClass (X : Type) [TopologicalSpace X] : Cycles1 X →ₗ[ℤ] SingularH1 X :=
+  ChainHomology.cycleClass (singularComplex X)
+
+private theorem FirstHurewicz.cycleClass_surjective (X : Type) [TopologicalSpace X] :
+    Function.Surjective (cycleClass X) :=
+  ChainHomology.cycleClass_surjective (singularComplex X)
+
+private def
+    FirstHurewicz.boundaryCycle (X : Type) [TopologicalSpace X] (b : Chains X 2) : Cycles1 X :=
+  ChainHomology.boundaryCycle1 (singularComplex X) b
+
+private abbrev FirstHurewicz.Opchains (X : Type) [TopologicalSpace X] :=
+  ChainHomology.Opchains (singularComplex X)
+
+private instance
+    FirstHurewicz.opchainsModule (X : Type) [TopologicalSpace X] : Module ℤ (Opchains X) :=
+  ChainHomology.opchainsModule (singularComplex X)
+
+private abbrev
+    FirstHurewicz.chainClass (X : Type) [TopologicalSpace X] : Chains X 1 →ₗ[ℤ] Opchains X :=
+  ChainHomology.chainClass (singularComplex X)
+
+private theorem FirstHurewicz.chainClass_boundary (X : Type) [TopologicalSpace X] (b : Chains X 2) :
+    chainClass X (boundaryTwo X b) = 0 :=
+  ChainHomology.chainClass_boundary (singularComplex X) b
+
+private theorem FirstHurewicz.chainClass_eq_iff (X : Type) [TopologicalSpace X] (x y : Chains X 1) :
+    chainClass X x = chainClass X y ↔ ∃ b : Chains X 2, boundaryTwo X b = x - y :=
+  ChainHomology.chainClass_eq_iff (singularComplex X) x y
+
+private abbrev FirstHurewicz.homologyToChainClass (X : Type) [TopologicalSpace X] :
+    SingularH1 X →ₗ[ℤ] Opchains X :=
+  ChainHomology.homologyToChainClass (singularComplex X)
+
+private theorem FirstHurewicz.homologyToChainClass_injective (X : Type) [TopologicalSpace X] :
+    Function.Injective (homologyToChainClass X) :=
+  ChainHomology.homologyToChainClass_injective (singularComplex X)
+
+private theorem FirstHurewicz.homologyToChainClass_cycleClass (X : Type) [TopologicalSpace X]
+    (c : Cycles1 X) : homologyToChainClass X (cycleClass X c) = chainClass X c.1 :=
+  ChainHomology.homologyToChainClass_cycleClass (singularComplex X) c
+
+private def FirstHurewicz.homologyDesc (X : Type) [TopologicalSpace X] {M : Type*} [AddCommGroup M]
+    [Module ℤ M] (f : Cycles1 X →ₗ[ℤ] M) (hf : ∀ b : Chains X 2, f (boundaryCycle X b) = 0) :
+    SingularH1 X →ₗ[ℤ] M :=
+  ChainHomology.homologyDesc (singularComplex X) f hf
+
+@[simp]
+private theorem FirstHurewicz.homologyDesc_cycleClass (X : Type) [TopologicalSpace X] {M : Type*}
+    [AddCommGroup M] [Module ℤ M] (f : Cycles1 X →ₗ[ℤ] M)
+    (hf : ∀ b : Chains X 2, f (boundaryCycle X b) = 0) (c : Cycles1 X) :
+    homologyDesc X f hf (cycleClass X c) = f c :=
+  ChainHomology.homologyDesc_cycleClass (singularComplex X) f hf c
+
+private def
+    FirstHurewicz.homologyDescOfChain (X : Type) [TopologicalSpace X] {M : Type*} [AddCommGroup M]
+    [Module ℤ M] (f : Chains X 1 →ₗ[ℤ] M) (hf : ∀ b : Chains X 2, f (boundaryTwo X b) = 0) :
+    SingularH1 X →ₗ[ℤ] M :=
+  homologyDesc X (f.comp (cycleVal X)) hf
+
+@[simp]
+private theorem
+    FirstHurewicz.homologyDescOfChain_cycleClass (X : Type) [TopologicalSpace X] {M : Type*}
+    [AddCommGroup M] [Module ℤ M] (f : Chains X 1 →ₗ[ℤ] M)
+    (hf : ∀ b : Chains X 2, f (boundaryTwo X b) = 0) (c : Cycles1 X) :
+    homologyDescOfChain X f hf (cycleClass X c) = f c.1 :=
+  homologyDesc_cycleClass X (f.comp (cycleVal X)) hf c
+
+/-- The chain map on singular complexes induced by a continuous map. -/
+public
+abbrev FirstHurewicz.singularChainMap {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (f : C(X, Y)) : singularComplex X ⟶ singularComplex Y :=
+  SSet.chainComplexMap (TopCat.toSSet.map (TopCat.ofHom f)) (ModuleCat.of ℤ ℤ)
+
+private abbrev FirstHurewicz.inducedChain {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (f : C(X, Y)) (n : ℕ) : Chains X n →ₗ[ℤ] Chains Y n :=
+  ((singularChainMap f).f n).hom
+
+private abbrev FirstHurewicz.inducedHomology {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (f : C(X, Y)) : SingularH1 X →ₗ[ℤ] SingularH1 Y :=
+  (HomologicalComplex.homologyMap (singularChainMap f) 1).hom
+
+@[simp]
+private theorem
+    FirstHurewicz.inducedChain_simplex {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (f : C(X, Y)) (n : ℕ) (σ : SingularSimplex X n) :
+    inducedChain f n (simplexChain X n σ) = simplexChain Y n (f.comp σ) := by
+  have h :=
+    SSet.ι_chainComplexMap_f (TopCat.toSSet.obj (TopCat.of X)) (TopCat.toSSet.obj (TopCat.of Y))
+      (TopCat.toSSet.map (TopCat.ofHom f)) (ModuleCat.of ℤ ℤ) (simplexIndex X n σ)
+  have he := congrArg (fun g : ModuleCat.of ℤ ℤ ⟶ Chains Y n => g.hom 1) h
+  change inducedChain f n (simplexChain X n σ) = simplexChain Y n (f.comp σ) at he
+  exact he
+
+private theorem
+    FirstHurewicz.inducedChain_boundary {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (f : C(X, Y)) (i j : ℕ) (c : Chains X i) :
+    inducedChain f j (((singularComplex X).d i j).hom c) =
+      ((singularComplex Y).d i j).hom (inducedChain f i c) :=
+  congrArg (fun g : Chains X i ⟶ Chains Y j => g.hom c) ((singularChainMap f).comm i j).symm
+
+@[simp]
+private theorem FirstHurewicz.inducedChain_id {X : Type} [TopologicalSpace X] (n : ℕ) :
+    inducedChain (ContinuousMap.id X) n = LinearMap.id := by
+  apply chainMap_ext X n
+  intro σ
+  simp only [inducedChain_simplex, LinearMap.id_apply]
+  rfl
+
+private theorem
+    FirstHurewicz.inducedChain_comp {X Y Z : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    [TopologicalSpace Z] (f : C(X, Y)) (g : C(Y, Z)) (n : ℕ) :
+    inducedChain (g.comp f) n = (inducedChain g n).comp (inducedChain f n) := by
+  apply chainMap_ext X n
+  intro σ
+  simp only [LinearMap.comp_apply, inducedChain_simplex]
+  rfl
+
+private theorem FirstHurewicz.inducedHomology_id {X : Type} [TopologicalSpace X] :
+    inducedHomology (ContinuousMap.id X) = LinearMap.id := by
+  have h :=
+    ((AlgebraicTopology.singularHomologyFunctor (ModuleCat ℤ) 1).obj (ModuleCat.of ℤ ℤ)).map_id
+      (TopCat.of X)
+  exact congrArg ModuleCat.Hom.hom h
+
+private theorem FirstHurewicz.inducedHomology_comp {X Y Z : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] [TopologicalSpace Z] (f : C(X, Y)) (g : C(Y, Z)) :
+    inducedHomology (g.comp f) = (inducedHomology g).comp (inducedHomology f) := by
+  have h :=
+    ((AlgebraicTopology.singularHomologyFunctor (ModuleCat ℤ) 1).obj (ModuleCat.of ℤ ℤ)).map_comp
+      (TopCat.ofHom f) (TopCat.ofHom g)
+  exact congrArg ModuleCat.Hom.hom h
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule FirstHurewicz.ChainHomology.opchainsModule in
+private abbrev
+    FirstHurewicz.ChainHomology.shortMap {K L : ChainComplex (ModuleCat.{0} ℤ) ℕ} (F : K ⟶ L) :
+    K.sc 1 ⟶ L.sc 1 :=
+  (HomologicalComplex.shortComplexFunctor (ModuleCat.{0} ℤ) (ComplexShape.down ℕ) 1).map F
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule FirstHurewicz.ChainHomology.opchainsModule in
+private def
+    FirstHurewicz.ChainHomology.mapCycles {K L : ChainComplex (ModuleCat.{0} ℤ) ℕ} (F : K ⟶ L) :
+    Cycle1 K →ₗ[ℤ] Cycle1 L :=
+  ((K.sc 1).moduleCatCyclesIso.inv ≫
+      CategoryTheory.ShortComplex.cyclesMap (shortMap F) ≫ (L.sc 1).moduleCatCyclesIso.hom).hom
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule FirstHurewicz.ChainHomology.opchainsModule in
+@[simp]
+private theorem FirstHurewicz.ChainHomology.mapCycles_val {K L : ChainComplex (ModuleCat.{0} ℤ) ℕ}
+    (F : K ⟶ L) (c : Cycle1 K) : (mapCycles F c).1 = (F.f 1).hom c.1 := by
+  have hcat :
+    (K.sc 1).moduleCatCyclesIso.inv ≫
+        CategoryTheory.ShortComplex.cyclesMap (shortMap F) ≫
+          (L.sc 1).moduleCatCyclesIso.hom ≫ (L.sc 1).moduleCatLeftHomologyData.i =
+      (K.sc 1).moduleCatLeftHomologyData.i ≫ (shortMap F).τ₂ := by
+    rw [(L.sc 1).moduleCatCyclesIso_hom_i, CategoryTheory.ShortComplex.cyclesMap_i,
+      (K.sc 1).moduleCatCyclesIso_inv_iCycles_assoc]
+  exact congrArg (fun f => f.hom c) hcat
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule
+    FirstHurewicz.ChainHomology.shortOpchainsModule FirstHurewicz.ChainHomology.opchainsModule in
+private theorem FirstHurewicz.ChainHomology.homologyMap_cycleClass
+    {K L : ChainComplex (ModuleCat.{0} ℤ) ℕ} (F : K ⟶ L) (c : Cycle1 K) :
+    (HomologicalComplex.homologyMap F 1).hom (cycleClass K c) = cycleClass L (mapCycles F c) := by
+  have hcat :
+    (K.sc 1).moduleCatLeftHomologyData.π ≫
+        (K.sc 1).moduleCatHomologyIso.inv ≫ CategoryTheory.ShortComplex.homologyMap (shortMap F) =
+      ((K.sc 1).moduleCatCyclesIso.inv ≫
+          CategoryTheory.ShortComplex.cyclesMap (shortMap F) ≫ (L.sc 1).moduleCatCyclesIso.hom) ≫
+        (L.sc 1).moduleCatLeftHomologyData.π ≫ (L.sc 1).moduleCatHomologyIso.inv := by
+    simp only [CategoryTheory.Category.assoc, ← (K.sc 1).moduleCatCyclesIso_inv_π_assoc,
+      ← (L.sc 1).moduleCatCyclesIso_inv_π, CategoryTheory.Iso.hom_inv_id_assoc]
+    rw [CategoryTheory.ShortComplex.homologyπ_naturality]
+  exact congrArg (fun f => f.hom c) hcat
+
+private def FirstHurewicz.inducedCycles {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (f : C(X, Y)) : Cycles1 X →ₗ[ℤ] Cycles1 Y :=
+  ChainHomology.mapCycles (singularChainMap f)
+
+@[simp]
+private theorem
+    FirstHurewicz.inducedCycles_val {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (f : C(X, Y)) (c : Cycles1 X) : (inducedCycles f c).1 = inducedChain f 1 c.1 :=
+  ChainHomology.mapCycles_val (singularChainMap f) c
+
+@[simp]
+private theorem FirstHurewicz.inducedHomology_cycleClass {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (c : Cycles1 X) :
+    inducedHomology f (cycleClass X c) = cycleClass Y (inducedCycles f c) :=
+  ChainHomology.homologyMap_cycleClass (singularChainMap f) c
+
+private def
+    SingularMayerVietoris.supportedChainSubmodule {X : Type} [TopologicalSpace X] (U : Set X)
+    (n : ℕ) : Submodule ℤ (FirstHurewicz.Chains X n) :=
+  Submodule.span ℤ
+    (FirstHurewicz.simplexChain X n '' {σ : FirstHurewicz.SingularSimplex X n | Set.range σ ⊆ U})
+
+private def SingularMayerVietoris.smallChainSubmodule {X : Type} [TopologicalSpace X] (U V : Set X)
+    (n : ℕ) : Submodule ℤ (FirstHurewicz.Chains X n) :=
+  supportedChainSubmodule U n ⊔ supportedChainSubmodule V n
+
+private theorem SingularMayerVietoris.smallChainSubmodule_eq_span {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) :
+    smallChainSubmodule U V n =
+      Submodule.span ℤ
+        (FirstHurewicz.simplexChain X n ''
+          {σ : FirstHurewicz.SingularSimplex X n | Set.range σ ⊆ U ∨ Set.range σ ⊆ V}) := by
+  rw [smallChainSubmodule, supportedChainSubmodule, supportedChainSubmodule, ←
+    Submodule.span_union, ← Set.image_union]
+  rfl
+
+private theorem SingularMayerVietoris.simplexChain_mem_supported {X : Type} [TopologicalSpace X]
+    (U : Set X) (n : ℕ) (σ : FirstHurewicz.SingularSimplex X n) (hσ : Set.range σ ⊆ U) :
+    FirstHurewicz.simplexChain X n σ ∈ supportedChainSubmodule U n :=
+  Submodule.subset_span ⟨σ, hσ, rfl⟩
+
+private theorem
+    SingularMayerVietoris.simplexChain_mem_small {X : Type} [TopologicalSpace X] (U V : Set X)
+    (n : ℕ) (σ : FirstHurewicz.SingularSimplex X n) (hσ : Set.range σ ⊆ U ∨ Set.range σ ⊆ V) :
+    FirstHurewicz.simplexChain X n σ ∈ smallChainSubmodule U V n := by
+  rw [smallChainSubmodule_eq_span]
+  exact Submodule.subset_span ⟨σ, hσ, rfl⟩
+
+private theorem
+    SingularMayerVietoris.simplex_face_supported {X : Type} [TopologicalSpace X] (U : Set X)
+    (n : ℕ) (σ : FirstHurewicz.SingularSimplex X (n + 1)) (hσ : Set.range σ ⊆ U)
+    (i : Fin (n + 2)) : Set.range (σ.comp (FirstHurewicz.simplexFace n i)) ⊆ U := by
+  rintro x ⟨s, rfl⟩
+  exact hσ ⟨FirstHurewicz.simplexFace n i s, rfl⟩
+
+private theorem SingularMayerVietoris.boundary_mem_small_succ {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) (c : FirstHurewicz.Chains X (n + 1))
+    (hc : c ∈ smallChainSubmodule U V (n + 1)) :
+    ((FirstHurewicz.singularComplex X).d (n + 1) n).hom c ∈ smallChainSubmodule U V n := by
+  have hle :
+    smallChainSubmodule U V (n + 1) ≤
+      (smallChainSubmodule U V n).comap ((FirstHurewicz.singularComplex X).d (n + 1) n).hom := by
+    rw [smallChainSubmodule_eq_span]
+    apply Submodule.span_le.mpr
+    rintro _ ⟨σ, hσ, rfl⟩
+    change
+      (FirstHurewicz.singularComplex X).d (n + 1) n (FirstHurewicz.simplexChain X (n + 1) σ) ∈
+        smallChainSubmodule U V n
+    rw [FirstHurewicz.boundary_simplex]
+    apply Submodule.sum_mem
+    intro i hi
+    apply (smallChainSubmodule U V n).toAddSubgroup.zsmul_mem
+    apply simplexChain_mem_small
+    exact
+      hσ.imp (fun h => simplex_face_supported U n σ h i)
+        (fun h => simplex_face_supported V n σ h i)
+  exact hle hc
+
+private theorem
+    SingularMayerVietoris.boundary_mem_small {X : Type} [TopologicalSpace X] (U V : Set X)
+    (i j : ℕ) (c : FirstHurewicz.Chains X i) (hc : c ∈ smallChainSubmodule U V i) :
+    ((FirstHurewicz.singularComplex X).d i j).hom c ∈ smallChainSubmodule U V j := by
+  by_cases hij : (ComplexShape.down ℕ).Rel i j
+  · have he : j + 1 = i := hij
+    subst i
+    exact boundary_mem_small_succ U V j c hc
+  · have he :=
+      congrArg (fun f : FirstHurewicz.Chains X i ⟶ FirstHurewicz.Chains X j => f.hom c)
+        ((FirstHurewicz.singularComplex X).shape i j hij)
+    rw [he]
+    exact Submodule.zero_mem _
+
+private instance
+    SingularMayerVietoris.smallChainModule {X : Type} [TopologicalSpace X] (U V : Set X)
+    (n : ℕ) : Module ℤ (smallChainSubmodule U V n) :=
+  (smallChainSubmodule U V n).module
+
+private def SingularMayerVietoris.smallDifferential {X : Type} [TopologicalSpace X] (U V : Set X)
+    (i j : ℕ) : smallChainSubmodule U V i →ₗ[ℤ] smallChainSubmodule U V j :=
+  (((FirstHurewicz.singularComplex X).d i j).hom.comp
+        (smallChainSubmodule U V i).subtype).codRestrict
+    _ (fun c => boundary_mem_small U V i j c.1 c.2)
+
+private def SingularMayerVietoris.smallComplex {X : Type} [TopologicalSpace X] (U V : Set X) :
+    ChainComplex (ModuleCat ℤ) ℕ
+    where
+  X n := ModuleCat.of ℤ (smallChainSubmodule U V n)
+  d i j := ModuleCat.ofHom (smallDifferential U V i j)
+  shape i j
+    hij := by
+    apply ModuleCat.hom_ext
+    apply LinearMap.ext
+    intro c
+    apply Subtype.ext
+    exact
+      congrArg (fun f : FirstHurewicz.Chains X i ⟶ FirstHurewicz.Chains X j => f.hom c.1)
+        ((FirstHurewicz.singularComplex X).shape i j hij)
+  d_comp_d' i j k hij
+    hjk := by
+    apply ModuleCat.hom_ext
+    apply LinearMap.ext
+    intro c
+    apply Subtype.ext
+    exact
+      congrArg (fun f : FirstHurewicz.Chains X i ⟶ FirstHurewicz.Chains X k => f.hom c.1)
+        ((FirstHurewicz.singularComplex X).d_comp_d i j k)
+
+private def SingularMayerVietoris.smallInclusion {X : Type} [TopologicalSpace X] (U V : Set X) :
+    smallComplex U V ⟶ FirstHurewicz.singularComplex X
+    where
+  f n := ModuleCat.ofHom (smallChainSubmodule U V n).subtype
+  comm' i j
+    hij := by
+    apply ModuleCat.hom_ext
+    apply LinearMap.ext
+    intro c
+    rfl
+
+private theorem SingularMayerVietoris.smallInclusion_f_injective {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) : Function.Injective ((smallInclusion U V).f n) :=
+  Subtype.val_injective
+
+private instance
+    SingularMayerVietoris.smallInclusion_mono {X : Type} [TopologicalSpace X] (U V : Set X) :
+    CategoryTheory.Mono (smallInclusion U V) :=
+  HomologicalComplex.mono_of_mono_f _
+    (fun n => (ModuleCat.mono_iff_injective _).mpr (smallInclusion_f_injective U V n))
+
+private def SingularMayerVietoris.liftToSmall {X : Type} [TopologicalSpace X] (U V : Set X)
+    {K : ChainComplex (ModuleCat ℤ) ℕ} (f : K ⟶ FirstHurewicz.singularComplex X)
+    (hf : ∀ n (c : K.X n), (f.f n).hom c ∈ smallChainSubmodule U V n) : K ⟶ smallComplex U V
+    where
+  f n := ModuleCat.ofHom ((f.f n).hom.codRestrict _ (hf n))
+  comm' i j
+    hij := by
+    apply ModuleCat.hom_ext
+    apply LinearMap.ext
+    intro c
+    apply Subtype.ext
+    exact congrArg (fun g : K.X i ⟶ FirstHurewicz.Chains X j => g.hom c) (f.comm i j)
+
+@[simp]
+private theorem
+    SingularMayerVietoris.liftToSmall_inclusion {X : Type} [TopologicalSpace X] (U V : Set X)
+    {K : ChainComplex (ModuleCat ℤ) ℕ} (f : K ⟶ FirstHurewicz.singularComplex X)
+    (hf : ∀ n (c : K.X n), (f.f n).hom c ∈ smallChainSubmodule U V n) :
+    liftToSmall U V f hf ≫ smallInclusion U V = f := by
+  apply HomologicalComplex.hom_ext
+  intro n
+  apply ModuleCat.hom_ext
+  rfl
+
+private def FirstHurewicz.chainsRepr (X : Type) [TopologicalSpace X] (n : ℕ) :
+    Chains X n →ₗ[ℤ] (SingularSimplex X n →₀ ℤ) :=
+  chainLift X n (fun σ => Finsupp.single σ 1)
+
+@[simp]
+private theorem FirstHurewicz.chainsRepr_simplex (X : Type) [TopologicalSpace X] (n : ℕ)
+    (σ : SingularSimplex X n) : chainsRepr X n (simplexChain X n σ) = Finsupp.single σ 1 :=
+  chainLift_simplex X n _ σ
+
+private def FirstHurewicz.chainsFromFinsupp (X : Type) [TopologicalSpace X] (n : ℕ) :
+    (SingularSimplex X n →₀ ℤ) →ₗ[ℤ] Chains X n :=
+  Finsupp.linearCombination ℤ (simplexChain X n)
+
+@[simp]
+private theorem FirstHurewicz.chainsFromFinsupp_single (X : Type) [TopologicalSpace X] (n : ℕ)
+    (σ : SingularSimplex X n) (a : ℤ) :
+    chainsFromFinsupp X n (Finsupp.single σ a) = a • simplexChain X n σ :=
+  (Finsupp.linearCombination_single ℤ (v := simplexChain X n) a σ).trans
+    (int_smul_eq_zsmul (Chains X n).isModule a (simplexChain X n σ))
+
+private theorem FirstHurewicz.chainsFromFinsupp_comp_repr (X : Type) [TopologicalSpace X] (n : ℕ) :
+    (chainsFromFinsupp X n).comp (chainsRepr X n) = LinearMap.id := by
+  apply chainMap_ext X n
+  intro σ
+  simp only [LinearMap.comp_apply, chainsRepr_simplex, chainsFromFinsupp_single, one_smul,
+    LinearMap.id_apply]
+
+private theorem FirstHurewicz.chainsRepr_comp_fromFinsupp (X : Type) [TopologicalSpace X] (n : ℕ) :
+    (chainsRepr X n).comp (chainsFromFinsupp X n) = LinearMap.id := by
+  apply Finsupp.lhom_ext
+  intro σ a
+  simp only [LinearMap.comp_apply, chainsFromFinsupp_single, map_zsmul, chainsRepr_simplex,
+    Finsupp.smul_single, smul_eq_mul, mul_one, LinearMap.id_apply]
+
+private def FirstHurewicz.chainsEquivFinsupp (X : Type) [TopologicalSpace X] (n : ℕ) :
+    Chains X n ≃ₗ[ℤ] (SingularSimplex X n →₀ ℤ)
+    where
+  toLinearMap := chainsRepr X n
+  invFun := chainsFromFinsupp X n
+  left_inv c := LinearMap.congr_fun (chainsFromFinsupp_comp_repr X n) c
+  right_inv c := LinearMap.congr_fun (chainsRepr_comp_fromFinsupp X n) c
+
+private def FirstHurewicz.chainBasis (X : Type) [TopologicalSpace X] (n : ℕ) :
+    Module.Basis (SingularSimplex X n) ℤ (Chains X n) :=
+  Module.Basis.ofRepr (chainsEquivFinsupp X n)
+
+@[simp]
+private theorem FirstHurewicz.chainBasis_repr (X : Type) [TopologicalSpace X] (n : ℕ) :
+    (chainBasis X n).repr = chainsEquivFinsupp X n :=
+  rfl
+
+@[simp]
+private theorem FirstHurewicz.chainBasis_apply (X : Type) [TopologicalSpace X] (n : ℕ)
+    (σ : SingularSimplex X n) : chainBasis X n σ = simplexChain X n σ := by
+  change chainsFromFinsupp X n (Finsupp.single σ 1) = _
+  rw [chainsFromFinsupp_single, one_smul]
+
+private theorem FirstHurewicz.chainBasis_coe (X : Type) [TopologicalSpace X] (n : ℕ) :
+    ⇑(chainBasis X n) = simplexChain X n :=
+  funext (chainBasis_apply X n)
+
+private theorem FirstHurewicz.simplexChain_span (X : Type) [TopologicalSpace X] (n : ℕ) :
+    Submodule.span ℤ (Set.range (simplexChain X n)) = ⊤ := by
+  simpa only [chainBasis_coe] using (chainBasis X n).span_eq
+
+private theorem FirstHurewicz.mem_simplex_span_iff (X : Type) [TopologicalSpace X] (n : ℕ)
+    (S : Set (SingularSimplex X n)) (c : Chains X n) :
+    c ∈ Submodule.span ℤ (simplexChain X n '' S) ↔ ↑(chainsEquivFinsupp X n c).support ⊆ S := by
+  simpa only [chainBasis_coe, chainBasis_repr] using
+    (chainBasis X n).mem_span_image (m := c) (s := S)
+
+private theorem FirstHurewicz.simplex_span_inter (X : Type) [TopologicalSpace X] (n : ℕ)
+    (S T : Set (SingularSimplex X n)) :
+    Submodule.span ℤ (simplexChain X n '' S) ⊓ Submodule.span ℤ (simplexChain X n '' T) =
+      Submodule.span ℤ (simplexChain X n '' (S ∩ T)) := by
+  ext c
+  simp only [Submodule.mem_inf, mem_simplex_span_iff, Set.subset_inter_iff]
+
+private def SingularMayerVietoris.subtypeInclusion {X : Type} [TopologicalSpace X] (U : Set X) :
+    C(U, X) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private def
+    SingularMayerVietoris.restrictSimplex {X : Type} [TopologicalSpace X] (U : Set X) (n : ℕ)
+    (σ : FirstHurewicz.SingularSimplex X n) (hσ : Set.range σ ⊆ U) :
+    FirstHurewicz.SingularSimplex U n :=
+  ⟨fun p => ⟨σ p, hσ ⟨p, rfl⟩⟩, σ.continuous.subtype_mk _⟩
+
+@[simp]
+private theorem SingularMayerVietoris.subtypeInclusion_comp_restrictSimplex {X : Type}
+    [TopologicalSpace X] (U : Set X) (n : ℕ) (σ : FirstHurewicz.SingularSimplex X n)
+    (hσ : Set.range σ ⊆ U) : (subtypeInclusion U).comp (restrictSimplex U n σ hσ) = σ := by
+  ext p
+  rfl
+
+private theorem SingularMayerVietoris.range_subtypeInclusion_comp {X : Type} [TopologicalSpace X]
+    (U : Set X) (n : ℕ) (σ : FirstHurewicz.SingularSimplex U n) :
+    Set.range ((subtypeInclusion U).comp σ) ⊆ U := by
+  rintro x ⟨p, rfl⟩
+  exact (σ p).2
+
+@[simp]
+private theorem SingularMayerVietoris.restrictSimplex_inclusion {X : Type} [TopologicalSpace X]
+    (U : Set X) (n : ℕ) (σ : FirstHurewicz.SingularSimplex U n)
+    (hσ : Set.range ((subtypeInclusion U).comp σ) ⊆ U) :
+    restrictSimplex U n ((subtypeInclusion U).comp σ) hσ = σ := by
+  ext p
+  rfl
+
+private def
+    SingularMayerVietoris.simplexRetraction {X : Type} [TopologicalSpace X] (U : Set X) (n : ℕ)
+    (σ : FirstHurewicz.SingularSimplex X n) : FirstHurewicz.Chains U n := by
+  classical
+    exact
+    if hσ : Set.range σ ⊆ U then FirstHurewicz.simplexChain U n (restrictSimplex U n σ hσ) else 0
+
+private def SingularMayerVietoris.subtypeChainRetraction {X : Type} [TopologicalSpace X] (U : Set X)
+    (n : ℕ) : FirstHurewicz.Chains X n →ₗ[ℤ] FirstHurewicz.Chains U n :=
+  FirstHurewicz.chainLift X n (simplexRetraction U n)
+
+private theorem SingularMayerVietoris.subtypeChainRetraction_inclusion_simplex {X : Type}
+    [TopologicalSpace X] (U : Set X) (n : ℕ) (σ : FirstHurewicz.SingularSimplex U n) :
+    subtypeChainRetraction U n
+        (FirstHurewicz.inducedChain (subtypeInclusion U) n (FirstHurewicz.simplexChain U n σ)) =
+      FirstHurewicz.simplexChain U n σ := by
+  rw [FirstHurewicz.inducedChain_simplex]
+  change FirstHurewicz.chainLift X n (simplexRetraction U n) _ = _
+  rw [FirstHurewicz.chainLift_simplex]
+  simp only [simplexRetraction, dite_eq_left (range_subtypeInclusion_comp U n σ),
+    restrictSimplex_inclusion]
+
+private theorem SingularMayerVietoris.subtypeChainRetraction_comp {X : Type} [TopologicalSpace X]
+    (U : Set X) (n : ℕ) :
+    (subtypeChainRetraction U n).comp (FirstHurewicz.inducedChain (subtypeInclusion U) n) =
+      LinearMap.id := by
+  apply FirstHurewicz.chainMap_ext U n
+  intro σ
+  exact subtypeChainRetraction_inclusion_simplex U n σ
+
+private theorem
+    SingularMayerVietoris.subtypeInclusion_chain_injective {X : Type} [TopologicalSpace X]
+    (U : Set X) (n : ℕ) :
+    Function.Injective (FirstHurewicz.inducedChain (subtypeInclusion U) n) :=
+  (show
+      Function.LeftInverse (subtypeChainRetraction U n)
+        (FirstHurewicz.inducedChain (subtypeInclusion U) n)
+      from fun c => LinearMap.congr_fun (subtypeChainRetraction_comp U n) c).injective
+
+private theorem
+    SingularMayerVietoris.subtypeInclusion_generator_image {X : Type} [TopologicalSpace X]
+    (U : Set X) (n : ℕ) :
+    FirstHurewicz.inducedChain (subtypeInclusion U) n ''
+        Set.range (FirstHurewicz.simplexChain U n) =
+      FirstHurewicz.simplexChain X n ''
+        {σ : FirstHurewicz.SingularSimplex X n | Set.range σ ⊆ U} := by
+  ext c
+  constructor
+  · rintro ⟨_, ⟨σ, rfl⟩, rfl⟩
+    exact
+      ⟨(subtypeInclusion U).comp σ, range_subtypeInclusion_comp U n σ,
+        (FirstHurewicz.inducedChain_simplex (subtypeInclusion U) n σ).symm⟩
+  · rintro ⟨σ, hσ, rfl⟩
+    refine ⟨FirstHurewicz.simplexChain U n (restrictSimplex U n σ hσ), ⟨_, rfl⟩, ?_⟩
+    rw [FirstHurewicz.inducedChain_simplex, subtypeInclusion_comp_restrictSimplex]
+
+private theorem SingularMayerVietoris.subtypeInclusion_chain_range {X : Type} [TopologicalSpace X]
+    (U : Set X) (n : ℕ) :
+    LinearMap.range (FirstHurewicz.inducedChain (subtypeInclusion U) n) =
+      supportedChainSubmodule U n := by
+  rw [LinearMap.range_eq_map, ← FirstHurewicz.simplexChain_span U n, Submodule.map_span,
+    subtypeInclusion_generator_image]
+  rfl
+
+private theorem SingularMayerVietoris.supportedChainSubmodule_inf {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) :
+    supportedChainSubmodule U n ⊓ supportedChainSubmodule V n =
+      supportedChainSubmodule (U ∩ V) n := by
+  have hsets :
+    ({σ : FirstHurewicz.SingularSimplex X n | Set.range σ ⊆ U} ∩
+        {σ : FirstHurewicz.SingularSimplex X n | Set.range σ ⊆ V}) =
+      {σ : FirstHurewicz.SingularSimplex X n | Set.range σ ⊆ U ∩ V} := by
+    ext σ
+    simp only [Set.mem_inter_iff, Set.mem_ofPred_eq, Set.subset_inter_iff]
+  unfold supportedChainSubmodule
+  rw [FirstHurewicz.simplex_span_inter, hsets]
+
+private theorem SingularMayerVietoris.subtypeInclusion_chain_mem {X : Type} [TopologicalSpace X]
+    (U : Set X) (n : ℕ) (c : FirstHurewicz.Chains U n) :
+    FirstHurewicz.inducedChain (subtypeInclusion U) n c ∈ supportedChainSubmodule U n := by
+  rw [← subtypeInclusion_chain_range U n]
+  exact ⟨c, rfl⟩
+
+private def SingularMayerVietoris.toSmallLeft {X : Type} [TopologicalSpace X] (U V : Set X) :
+    FirstHurewicz.singularComplex U ⟶ smallComplex U V :=
+  liftToSmall U V (FirstHurewicz.singularChainMap (subtypeInclusion U))
+    (fun n c =>
+      (show supportedChainSubmodule U n ≤ smallChainSubmodule U V n from le_sup_left)
+        (subtypeInclusion_chain_mem U n c))
+
+private def SingularMayerVietoris.toSmallRight {X : Type} [TopologicalSpace X] (U V : Set X) :
+    FirstHurewicz.singularComplex V ⟶ smallComplex U V :=
+  liftToSmall U V (FirstHurewicz.singularChainMap (subtypeInclusion V))
+    (fun n c =>
+      (show supportedChainSubmodule V n ≤ smallChainSubmodule U V n from le_sup_right)
+        (subtypeInclusion_chain_mem V n c))
+
+@[simp]
+private theorem SingularMayerVietoris.toSmallLeft_inclusion {X : Type} [TopologicalSpace X]
+    (U V : Set X) :
+    toSmallLeft U V ≫ smallInclusion U V = FirstHurewicz.singularChainMap (subtypeInclusion U) :=
+  liftToSmall_inclusion U V _ _
+
+@[simp]
+private theorem SingularMayerVietoris.toSmallRight_inclusion {X : Type} [TopologicalSpace X]
+    (U V : Set X) :
+    toSmallRight U V ≫ smallInclusion U V = FirstHurewicz.singularChainMap (subtypeInclusion V) :=
+  liftToSmall_inclusion U V _ _
+
+private theorem SingularMayerVietoris.toSmall_jointly_surjective {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) (s : (smallComplex U V).X n) :
+    ∃ x : FirstHurewicz.Chains U n,
+      ∃ y : FirstHurewicz.Chains V n,
+        ((toSmallLeft U V).f n).hom x + ((toSmallRight U V).f n).hom y = s := by
+  obtain ⟨c, hc, d, hd, hcd⟩ := Submodule.mem_sup.mp s.2
+  rw [← subtypeInclusion_chain_range U n] at hc
+  rw [← subtypeInclusion_chain_range V n] at hd
+  obtain ⟨x, hx⟩ := hc
+  obtain ⟨y, hy⟩ := hd
+  refine ⟨x, y, ?_⟩
+  apply Subtype.ext
+  change
+    FirstHurewicz.inducedChain (subtypeInclusion U) n x +
+        FirstHurewicz.inducedChain (subtypeInclusion V) n y =
+      s.1
+  rw [hx, hy]
+  exact hcd
+
+private def SingularMayerVietoris.intersectionToLeft {X : Type} [TopologicalSpace X] (U V : Set X) :
+    FirstHurewicz.singularComplex (U ∩ V : Set X) ⟶ FirstHurewicz.singularComplex U :=
+  FirstHurewicz.singularChainMap (ContinuousMap.inclusion (Set.inter_subset_left : U ∩ V ⊆ U))
+
+private def
+    SingularMayerVietoris.intersectionToRight {X : Type} [TopologicalSpace X] (U V : Set X) :
+    FirstHurewicz.singularComplex (U ∩ V : Set X) ⟶ FirstHurewicz.singularComplex V :=
+  FirstHurewicz.singularChainMap (ContinuousMap.inclusion (Set.inter_subset_right : U ∩ V ⊆ V))
+
+private theorem SingularMayerVietoris.intersectionToLeft_ambient {X : Type} [TopologicalSpace X]
+    (U V : Set X) :
+    intersectionToLeft U V ≫ FirstHurewicz.singularChainMap (subtypeInclusion U) =
+      FirstHurewicz.singularChainMap (subtypeInclusion (U ∩ V)) := by
+  have h :=
+    ((AlgebraicTopology.singularChainComplexFunctor (ModuleCat ℤ)).obj
+          (ModuleCat.of ℤ ℤ)).map_comp
+      (TopCat.ofHom (ContinuousMap.inclusion (Set.inter_subset_left : U ∩ V ⊆ U)))
+      (TopCat.ofHom (subtypeInclusion U))
+  exact h.symm
+
+private theorem SingularMayerVietoris.intersectionToRight_ambient {X : Type} [TopologicalSpace X]
+    (U V : Set X) :
+    intersectionToRight U V ≫ FirstHurewicz.singularChainMap (subtypeInclusion V) =
+      FirstHurewicz.singularChainMap (subtypeInclusion (U ∩ V)) := by
+  have h :=
+    ((AlgebraicTopology.singularChainComplexFunctor (ModuleCat ℤ)).obj
+          (ModuleCat.of ℤ ℤ)).map_comp
+      (TopCat.ofHom (ContinuousMap.inclusion (Set.inter_subset_right : U ∩ V ⊆ V)))
+      (TopCat.ofHom (subtypeInclusion V))
+  exact h.symm
+
+@[simp]
+private theorem
+    SingularMayerVietoris.intersectionToLeft_ambient_apply {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) (c : FirstHurewicz.Chains (U ∩ V : Set X) n) :
+    FirstHurewicz.inducedChain (subtypeInclusion U) n (((intersectionToLeft U V).f n).hom c) =
+      FirstHurewicz.inducedChain (subtypeInclusion (U ∩ V)) n c :=
+  congrArg (fun f => (f.f n).hom c) (intersectionToLeft_ambient U V)
+
+@[simp]
+private theorem
+    SingularMayerVietoris.intersectionToRight_ambient_apply {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) (c : FirstHurewicz.Chains (U ∩ V : Set X) n) :
+    FirstHurewicz.inducedChain (subtypeInclusion V) n (((intersectionToRight U V).f n).hom c) =
+      FirstHurewicz.inducedChain (subtypeInclusion (U ∩ V)) n c :=
+  congrArg (fun f => (f.f n).hom c) (intersectionToRight_ambient U V)
+
+private theorem SingularMayerVietoris.intersectionToLeft_f_injective {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) : Function.Injective ((intersectionToLeft U V).f n).hom := by
+  intro a b hab
+  apply subtypeInclusion_chain_injective (U ∩ V) n
+  calc
+    _ =
+        FirstHurewicz.inducedChain (subtypeInclusion U) n
+          (((intersectionToLeft U V).f n).hom a) :=
+      (intersectionToLeft_ambient_apply U V n a).symm
+    _ =
+        FirstHurewicz.inducedChain (subtypeInclusion U) n
+          (((intersectionToLeft U V).f n).hom b) :=
+      (congrArg (FirstHurewicz.inducedChain (subtypeInclusion U) n) hab)
+    _ = _ := intersectionToLeft_ambient_apply U V n b
+
+private theorem SingularMayerVietoris.intersection_toSmall_comm {X : Type} [TopologicalSpace X]
+    (U V : Set X) :
+    intersectionToLeft U V ≫ toSmallLeft U V = intersectionToRight U V ≫ toSmallRight U V := by
+  apply (CategoryTheory.cancel_mono (smallInclusion U V)).mp
+  simp only [CategoryTheory.Category.assoc, toSmallLeft_inclusion, toSmallRight_inclusion,
+    intersectionToLeft_ambient, intersectionToRight_ambient]
+
+private theorem
+    SingularMayerVietoris.toSmall_overlap_lift {X : Type} [TopologicalSpace X] (U V : Set X)
+    (n : ℕ) (x : FirstHurewicz.Chains U n) (y : FirstHurewicz.Chains V n)
+    (hxy : ((toSmallLeft U V).f n).hom x = ((toSmallRight U V).f n).hom y) :
+    ∃ z : FirstHurewicz.Chains (U ∩ V : Set X) n,
+      ((intersectionToLeft U V).f n).hom z = x ∧ ((intersectionToRight U V).f n).hom z = y := by
+  have hxy' :
+    FirstHurewicz.inducedChain (subtypeInclusion U) n x =
+      FirstHurewicz.inducedChain (subtypeInclusion V) n y :=
+    congrArg (fun s : (smallComplex U V).X n => s.1) hxy
+  have hy : FirstHurewicz.inducedChain (subtypeInclusion U) n x ∈ supportedChainSubmodule V n := by
+    rw [hxy']
+    exact subtypeInclusion_chain_mem V n y
+  have hi :
+    FirstHurewicz.inducedChain (subtypeInclusion U) n x ∈
+      supportedChainSubmodule U n ⊓ supportedChainSubmodule V n :=
+    ⟨subtypeInclusion_chain_mem U n x, hy⟩
+  rw [supportedChainSubmodule_inf, ← subtypeInclusion_chain_range (U ∩ V) n] at hi
+  obtain ⟨z, hz⟩ := hi
+  refine ⟨z, ?_, ?_⟩
+  · apply subtypeInclusion_chain_injective U n
+    rw [intersectionToLeft_ambient_apply]
+    exact hz
+  · apply subtypeInclusion_chain_injective V n
+    rw [intersectionToRight_ambient_apply]
+    exact hz.trans hxy'
+
+private def SingularMayerVietoris.middleComplex {X : Type} [TopologicalSpace X] (U V : Set X) :
+    ChainComplex (ModuleCat ℤ) ℕ :=
+  FirstHurewicz.singularComplex U ⊞ FirstHurewicz.singularComplex V
+
+private def SingularMayerVietoris.leftMap {X : Type} [TopologicalSpace X] (U V : Set X) :
+    FirstHurewicz.singularComplex (U ∩ V : Set X) ⟶ middleComplex U V :=
+  CategoryTheory.Limits.biprod.lift (intersectionToLeft U V) (-(intersectionToRight U V))
+
+private def SingularMayerVietoris.rightMap {X : Type} [TopologicalSpace X] (U V : Set X) :
+    middleComplex U V ⟶ smallComplex U V :=
+  CategoryTheory.Limits.biprod.desc (toSmallLeft U V) (toSmallRight U V)
+
+@[simp]
+private theorem SingularMayerVietoris.leftMap_fst {X : Type} [TopologicalSpace X] (U V : Set X) :
+    leftMap U V ≫
+        (CategoryTheory.Limits.biprod.fst : middleComplex U V ⟶ FirstHurewicz.singularComplex U) =
+      intersectionToLeft U V :=
+  CategoryTheory.Limits.biprod.lift_fst _ _
+
+@[simp]
+private theorem SingularMayerVietoris.leftMap_snd {X : Type} [TopologicalSpace X] (U V : Set X) :
+    leftMap U V ≫
+        (CategoryTheory.Limits.biprod.snd : middleComplex U V ⟶ FirstHurewicz.singularComplex V) =
+      -(intersectionToRight U V) :=
+  CategoryTheory.Limits.biprod.lift_snd _ _
+
+@[simp]
+private theorem SingularMayerVietoris.inl_rightMap {X : Type} [TopologicalSpace X] (U V : Set X) :
+    (CategoryTheory.Limits.biprod.inl : FirstHurewicz.singularComplex U ⟶ middleComplex U V) ≫
+        rightMap U V =
+      toSmallLeft U V :=
+  CategoryTheory.Limits.biprod.inl_desc _ _
+
+@[simp]
+private theorem SingularMayerVietoris.inr_rightMap {X : Type} [TopologicalSpace X] (U V : Set X) :
+    (CategoryTheory.Limits.biprod.inr : FirstHurewicz.singularComplex V ⟶ middleComplex U V) ≫
+        rightMap U V =
+      toSmallRight U V :=
+  CategoryTheory.Limits.biprod.inr_desc _ _
+
+private theorem
+    SingularMayerVietoris.leftMap_rightMap {X : Type} [TopologicalSpace X] (U V : Set X) :
+    leftMap U V ≫ rightMap U V = 0 := by
+  change
+    CategoryTheory.CategoryStruct.comp (CategoryTheory.Limits.biprod.lift _ _)
+        (CategoryTheory.Limits.biprod.desc _ _) =
+      0
+  rw [CategoryTheory.Limits.biprod.lift_desc, CategoryTheory.Preadditive.neg_comp,
+    intersection_toSmall_comm, add_neg_cancel]
+
+private def SingularMayerVietoris.chainSequence {X : Type} [TopologicalSpace X] (U V : Set X) :
+    CategoryTheory.ShortComplex (ChainComplex (ModuleCat ℤ) ℕ) :=
+  CategoryTheory.ShortComplex.mk (leftMap U V) (rightMap U V) (leftMap_rightMap U V)
+
+private theorem SingularMayerVietoris.chainSequence_shortExact {X : Type} [TopologicalSpace X]
+    (U V : Set X) : (chainSequence U V).ShortExact :=
+  SmallChainBiprod.shortExactOfComplexes (intersectionToLeft U V) (intersectionToRight U V)
+    (toSmallLeft U V) (toSmallRight U V) (intersection_toSmall_comm U V)
+    (intersectionToLeft_f_injective U V) (toSmall_jointly_surjective U V)
+    (toSmall_overlap_lift U V)
+
+/-- The linear map on homology induced by a chain map. -/
+public
+abbrev SingularMayerVietoris.homologyLinearMap {K L : ChainComplex (ModuleCat.{0} ℤ) ℕ}
+    (f : K ⟶ L) (n : ℕ) : K.homology n →ₗ[ℤ] L.homology n :=
+  (HomologicalComplex.homologyMap f n).hom
+
+private theorem
+    SingularMayerVietoris.homologyLinearMap_comp {K L M : ChainComplex (ModuleCat.{0} ℤ) ℕ}
+    (f : K ⟶ L) (g : L ⟶ M) (n : ℕ) :
+    homologyLinearMap (f ≫ g) n = (homologyLinearMap g n).comp (homologyLinearMap f n) :=
+  congrArg ModuleCat.Hom.hom (HomologicalComplex.homologyMap_comp f g n)
+
+@[simp]
+private theorem SingularMayerVietoris.homologyLinearMap_neg {K L : ChainComplex (ModuleCat.{0} ℤ) ℕ}
+    (f : K ⟶ L) (n : ℕ) : homologyLinearMap (-f) n = -homologyLinearMap f n :=
+  congrArg ModuleCat.Hom.hom (HomologicalComplex.homologyMap_neg f n)
+
+private def SingularMayerVietoris.connectingMap
+    {S : CategoryTheory.ShortComplex (ChainComplex (ModuleCat.{0} ℤ) ℕ)} (hS : S.ShortExact)
+    (n : ℕ) : S.X₃.homology (n + 1) →ₗ[ℤ] S.X₁.homology n :=
+  (hS.δ (n + 1) n (by simp)).hom
+
+private theorem SingularMayerVietoris.exact_at_leftHomology
+    {S : CategoryTheory.ShortComplex (ChainComplex (ModuleCat.{0} ℤ) ℕ)} (hS : S.ShortExact)
+    (n : ℕ) : LinearMap.range (connectingMap hS n) = LinearMap.ker (homologyLinearMap S.f n) :=
+  (hS.homology_exact₁ (n + 1) n (by simp)).moduleCat_range_eq_ker
+
+private theorem SingularMayerVietoris.exact_at_middleHomology
+    {S : CategoryTheory.ShortComplex (ChainComplex (ModuleCat.{0} ℤ) ℕ)} (hS : S.ShortExact)
+    (n : ℕ) :
+    LinearMap.range (homologyLinearMap S.f n) = LinearMap.ker (homologyLinearMap S.g n) :=
+  (hS.homology_exact₂ n).moduleCat_range_eq_ker
+
+private theorem SingularMayerVietoris.exact_at_rightHomology
+    {S : CategoryTheory.ShortComplex (ChainComplex (ModuleCat.{0} ℤ) ℕ)} (hS : S.ShortExact)
+    (n : ℕ) :
+    LinearMap.range (homologyLinearMap S.g (n + 1)) = LinearMap.ker (connectingMap hS n) :=
+  (hS.homology_exact₃ (n + 1) n (by simp)).moduleCat_range_eq_ker
+
+private theorem SingularMayerVietoris.homologyLinearMap_second_zero_surjective
+    {S : CategoryTheory.ShortComplex (ChainComplex (ModuleCat.{0} ℤ) ℕ)} (hS : S.ShortExact) :
+    Function.Surjective (homologyLinearMap S.g 0) := by
+  have := hS.epi_g
+  have := HomologicalComplex.epi_homologyMap_of_epi_of_not_rel S.g 0 (by intro j; simp)
+  exact (ModuleCat.epi_iff_surjective _).mp inferInstance
+
+private theorem SingularMayerVietoris.connectingMap_naturality
+    {S T : CategoryTheory.ShortComplex (ChainComplex (ModuleCat.{0} ℤ) ℕ)} (hS : S.ShortExact)
+    (φ : S ⟶ T) (hT : T.ShortExact) (n : ℕ) :
+    (homologyLinearMap φ.τ₁ n).comp (connectingMap hS n) =
+      (connectingMap hT n).comp (homologyLinearMap φ.τ₃ (n + 1)) :=
+  congrArg ModuleCat.Hom.hom
+    (HomologicalComplex.HomologySequence.δ_naturality φ hS hT (n + 1) n (by simp))
+
+private def
+    SingularMayerVietoris.homologyClassOfCycle (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) {i : ℕ}
+    (z : K.X i) (j : ℕ) (hj : (ComplexShape.down ℕ).next i = j) (hz : (K.d i j).hom z = 0) :
+    K.homology i :=
+  (K.homologyπ i).hom (K.cyclesMk z j hj hz)
+
+private theorem SingularMayerVietoris.connectingMap_lift_is_cycle
+    {S : CategoryTheory.ShortComplex (ChainComplex (ModuleCat.{0} ℤ) ℕ)} (hS : S.ShortExact)
+    (n : ℕ) (z₂ : S.X₂.X (n + 1)) (z₁ : S.X₁.X n)
+    (hz₁ : (S.f.f n).hom z₁ = (S.X₂.d (n + 1) n).hom z₂) (k : ℕ) : (S.X₁.d n k).hom z₁ = 0 :=
+  hS.d_eq_zero_of_f_eq_d_apply (n + 1) n z₂ z₁ hz₁ k
+
+private theorem SingularMayerVietoris.connectingMap_homologyClassOfCycle
+    {S : CategoryTheory.ShortComplex (ChainComplex (ModuleCat.{0} ℤ) ℕ)} (hS : S.ShortExact)
+    (n : ℕ) (z₃ : S.X₃.X (n + 1)) (hz₃ : (S.X₃.d (n + 1) n).hom z₃ = 0) (z₂ : S.X₂.X (n + 1))
+    (hz₂ : (S.g.f (n + 1)).hom z₂ = z₃) (z₁ : S.X₁.X n)
+    (hz₁ : (S.f.f n).hom z₁ = (S.X₂.d (n + 1) n).hom z₂) :
+    connectingMap hS n
+        (homologyClassOfCycle S.X₃ z₃ n ((ComplexShape.down ℕ).next_eq' (by simp)) hz₃) =
+      homologyClassOfCycle S.X₁ z₁ ((ComplexShape.down ℕ).next n) rfl
+        (connectingMap_lift_is_cycle hS n z₂ z₁ hz₁ _) :=
+  hS.δ_apply (n + 1) n (by simp) z₃ hz₃ z₂ hz₂ z₁ hz₁ _ rfl
+
+private theorem SingularMayerVietoris.homology_fst_inl_mo1973_2361
+    (K L : ChainComplex (ModuleCat.{0} ℤ) ℕ) (n : ℕ) (a : K.homology n) :
+    (HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.fst : K ⊞ L ⟶ K) n).hom
+        ((HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.inl : K ⟶ K ⊞ L) n).hom
+          a) =
+      a := by
+  have h :=
+    HomologicalComplex.homologyMap_comp (CategoryTheory.Limits.biprod.inl : K ⟶ K ⊞ L)
+      CategoryTheory.Limits.biprod.fst n
+  rw [CategoryTheory.Limits.biprod.inl_fst, HomologicalComplex.homologyMap_id] at h
+  exact (congrArg (fun f => f.hom a) h).symm
+
+private theorem SingularMayerVietoris.homology_snd_inl_mo1973_2362
+    (K L : ChainComplex (ModuleCat.{0} ℤ) ℕ) (n : ℕ) (a : K.homology n) :
+    (HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.snd : K ⊞ L ⟶ L) n).hom
+        ((HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.inl : K ⟶ K ⊞ L) n).hom
+          a) =
+      0 := by
+  have h :=
+    HomologicalComplex.homologyMap_comp (CategoryTheory.Limits.biprod.inl : K ⟶ K ⊞ L)
+      CategoryTheory.Limits.biprod.snd n
+  rw [CategoryTheory.Limits.biprod.inl_snd, HomologicalComplex.homologyMap_zero] at h
+  exact (congrArg (fun f => f.hom a) h).symm
+
+private theorem SingularMayerVietoris.homology_fst_inr_mo1973_2363
+    (K L : ChainComplex (ModuleCat.{0} ℤ) ℕ) (n : ℕ) (b : L.homology n) :
+    (HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.fst : K ⊞ L ⟶ K) n).hom
+        ((HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.inr : L ⟶ K ⊞ L) n).hom
+          b) =
+      0 := by
+  have h :=
+    HomologicalComplex.homologyMap_comp (CategoryTheory.Limits.biprod.inr : L ⟶ K ⊞ L)
+      CategoryTheory.Limits.biprod.fst n
+  rw [CategoryTheory.Limits.biprod.inr_fst, HomologicalComplex.homologyMap_zero] at h
+  exact (congrArg (fun f => f.hom b) h).symm
+
+private theorem SingularMayerVietoris.homology_snd_inr_mo1973_2364
+    (K L : ChainComplex (ModuleCat.{0} ℤ) ℕ) (n : ℕ) (b : L.homology n) :
+    (HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.snd : K ⊞ L ⟶ L) n).hom
+        ((HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.inr : L ⟶ K ⊞ L) n).hom
+          b) =
+      b := by
+  have h :=
+    HomologicalComplex.homologyMap_comp (CategoryTheory.Limits.biprod.inr : L ⟶ K ⊞ L)
+      CategoryTheory.Limits.biprod.snd n
+  rw [CategoryTheory.Limits.biprod.inr_snd, HomologicalComplex.homologyMap_id] at h
+  exact (congrArg (fun f => f.hom b) h).symm
+
+private theorem SingularMayerVietoris.homology_biprod_total_mo1973_2365
+    (K L : ChainComplex (ModuleCat.{0} ℤ) ℕ) (n : ℕ) (a : (K ⊞ L).homology n) :
+    (HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.inl : K ⟶ K ⊞ L) n).hom
+          ((HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.fst : K ⊞ L ⟶ K) n).hom
+            a) +
+        (HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.inr : L ⟶ K ⊞ L) n).hom
+          ((HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.snd : K ⊞ L ⟶ L) n).hom
+            a) =
+      a := by
+  have h :
+    HomologicalComplex.homologyMap
+        (CategoryTheory.CategoryStruct.comp CategoryTheory.Limits.biprod.fst
+              CategoryTheory.Limits.biprod.inl +
+            CategoryTheory.CategoryStruct.comp CategoryTheory.Limits.biprod.snd
+              CategoryTheory.Limits.biprod.inr :
+          K ⊞ L ⟶ K ⊞ L)
+        n =
+      𝟙 ((K ⊞ L).homology n) := by
+    rw [CategoryTheory.Limits.biprod.total, HomologicalComplex.homologyMap_id]
+  rw [HomologicalComplex.homologyMap_add, HomologicalComplex.homologyMap_comp,
+    HomologicalComplex.homologyMap_comp] at h
+  exact congrArg (fun f => f.hom a) h
+
+private def
+    SingularMayerVietoris.homologyBiprodEquiv (K L : ChainComplex (ModuleCat.{0} ℤ) ℕ) (n : ℕ) :
+    (K ⊞ L).homology n ≃ₗ[ℤ] (K.homology n × L.homology n) :=
+  ({    toFun
+          a :=
+          ((HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.fst : K ⊞ L ⟶ K) n).hom
+              a,
+            (HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.snd : K ⊞ L ⟶ L) n).hom
+              a)
+        invFun
+          a :=
+          (HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.inl : K ⟶ K ⊞ L) n).hom
+              a.1 +
+            (HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.inr : L ⟶ K ⊞ L) n).hom
+              a.2
+        left_inv := homology_biprod_total_mo1973_2365 K L n
+        right_inv
+          a := by
+          apply Prod.ext
+          · change
+              (HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.fst : K ⊞ L ⟶ K)
+                      n).hom
+                  ((HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.inl : K ⟶ K ⊞ L)
+                          n).hom
+                      a.1 +
+                    (HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.inr : L ⟶ K ⊞ L)
+                          n).hom
+                      a.2) =
+                a.1
+            rw [map_add, homology_fst_inl_mo1973_2361, homology_fst_inr_mo1973_2363, add_zero]
+          · change
+              (HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.snd : K ⊞ L ⟶ L)
+                      n).hom
+                  ((HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.inl : K ⟶ K ⊞ L)
+                          n).hom
+                      a.1 +
+                    (HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.inr : L ⟶ K ⊞ L)
+                          n).hom
+                      a.2) =
+                a.2
+            rw [map_add, homology_snd_inl_mo1973_2362, homology_snd_inr_mo1973_2364, zero_add]
+        map_add' a
+          b := by
+          change (_, _) = (_, _)
+          rw [map_add, map_add] } :
+      (K ⊞ L).homology n ≃+ (K.homology n × L.homology n)).toIntLinearEquiv
+
+private theorem SingularMayerVietoris.homologyBiprodEquiv_symm_apply
+    (K L : ChainComplex (ModuleCat.{0} ℤ) ℕ) (n : ℕ) (a : K.homology n × L.homology n) :
+    (homologyBiprodEquiv K L n).symm a =
+      (HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.inl : K ⟶ K ⊞ L) n).hom a.1 +
+        (HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.inr : L ⟶ K ⊞ L) n).hom
+          a.2 :=
+  rfl
+
+private theorem
+    SingularMayerVietoris.homologyBiprodEquiv_desc {K : ChainComplex (ModuleCat.{0} ℤ) ℕ}
+    {L : ChainComplex (ModuleCat.{0} ℤ) ℕ} (n : ℕ) {A : ChainComplex (ModuleCat.{0} ℤ) ℕ}
+    (f : K ⟶ A) (g : L ⟶ A) (a : K.homology n × L.homology n) :
+    (HomologicalComplex.homologyMap (CategoryTheory.Limits.biprod.desc f g) n).hom
+        ((homologyBiprodEquiv K L n).symm a) =
+      (HomologicalComplex.homologyMap f n).hom a.1 +
+        (HomologicalComplex.homologyMap g n).hom a.2 := by
+  rw [homologyBiprodEquiv_symm_apply, map_add]
+  congr 1
+  · have h :=
+      HomologicalComplex.homologyMap_comp (CategoryTheory.Limits.biprod.inl : K ⟶ K ⊞ L)
+        (CategoryTheory.Limits.biprod.desc f g) n
+    rw [CategoryTheory.Limits.biprod.inl_desc] at h
+    exact (congrArg (fun k => k.hom a.1) h).symm
+  · have h :=
+      HomologicalComplex.homologyMap_comp (CategoryTheory.Limits.biprod.inr : L ⟶ K ⊞ L)
+        (CategoryTheory.Limits.biprod.desc f g) n
+    rw [CategoryTheory.Limits.biprod.inr_desc] at h
+    exact (congrArg (fun k => k.hom a.2) h).symm
+
+private def SingularMayerVietoris.biprodSequenceFirstMap {A K L : ChainComplex (ModuleCat.{0} ℤ) ℕ}
+    (f : A ⟶ K ⊞ L) (n : ℕ) : A.homology n →ₗ[ℤ] (K.homology n × L.homology n) :=
+  (homologyBiprodEquiv K L n).toLinearMap.comp (homologyLinearMap f n)
+
+private def SingularMayerVietoris.biprodSequenceSecondMap {K L B : ChainComplex (ModuleCat.{0} ℤ) ℕ}
+    (g : K ⊞ L ⟶ B) (n : ℕ) : (K.homology n × L.homology n) →ₗ[ℤ] B.homology n :=
+  (homologyLinearMap g n).comp (homologyBiprodEquiv K L n).symm.toLinearMap
+
+private theorem SingularMayerVietoris.biprodSequenceSecondMap_desc
+    {K L B : ChainComplex (ModuleCat.{0} ℤ) ℕ} (f : K ⟶ B) (g : L ⟶ B) (n : ℕ)
+    (a : K.homology n × L.homology n) :
+    biprodSequenceSecondMap (CategoryTheory.Limits.biprod.desc f g) n a =
+      homologyLinearMap f n a.1 + homologyLinearMap g n a.2 :=
+  homologyBiprodEquiv_desc n f g a
+
+private theorem SingularMayerVietoris.biprodSequence_exact_at_leftHomology
+    {A K L B : ChainComplex (ModuleCat.{0} ℤ) ℕ} {f : A ⟶ K ⊞ L} {g : K ⊞ L ⟶ B} {hfg : f ≫ g = 0}
+    (hS : (CategoryTheory.ShortComplex.mk f g hfg).ShortExact) (n : ℕ) :
+    LinearMap.range (connectingMap hS n) = LinearMap.ker (biprodSequenceFirstMap f n) := by
+  rw [exact_at_leftHomology hS n]
+  ext a
+  change homologyLinearMap f n a = 0 ↔ homologyBiprodEquiv K L n (homologyLinearMap f n a) = 0
+  constructor
+  · intro h
+    rw [h, map_zero]
+  · intro h
+    exact (homologyBiprodEquiv K L n).injective (h.trans (map_zero _).symm)
+
+private theorem SingularMayerVietoris.biprodSequence_exact_at_middleHomology
+    {A K L B : ChainComplex (ModuleCat.{0} ℤ) ℕ} {f : A ⟶ K ⊞ L} {g : K ⊞ L ⟶ B} {hfg : f ≫ g = 0}
+    (hS : (CategoryTheory.ShortComplex.mk f g hfg).ShortExact) (n : ℕ) :
+    LinearMap.range (biprodSequenceFirstMap f n) = LinearMap.ker (biprodSequenceSecondMap g n) := by
+  ext a
+  change
+    (∃ b, homologyBiprodEquiv K L n (homologyLinearMap f n b) = a) ↔
+      homologyLinearMap g n ((homologyBiprodEquiv K L n).symm a) = 0
+  constructor
+  · rintro ⟨b, rfl⟩
+    rw [LinearEquiv.symm_apply_apply]
+    have hb : homologyLinearMap f n b ∈ LinearMap.range (homologyLinearMap f n) := ⟨b, rfl⟩
+    rw [exact_at_middleHomology hS n] at hb
+    exact hb
+  · intro ha
+    have hb : (homologyBiprodEquiv K L n).symm a ∈ LinearMap.range (homologyLinearMap f n) := by
+      rw [exact_at_middleHomology hS n]
+      exact ha
+    obtain ⟨b, hb⟩ := hb
+    exact
+      ⟨b,
+        (congrArg (homologyBiprodEquiv K L n) hb).trans
+          ((homologyBiprodEquiv K L n).apply_symm_apply a)⟩
+
+private theorem SingularMayerVietoris.biprodSequence_exact_at_rightHomology
+    {A K L B : ChainComplex (ModuleCat.{0} ℤ) ℕ} {f : A ⟶ K ⊞ L} {g : K ⊞ L ⟶ B} {hfg : f ≫ g = 0}
+    (hS : (CategoryTheory.ShortComplex.mk f g hfg).ShortExact) (n : ℕ) :
+    LinearMap.range (biprodSequenceSecondMap g (n + 1)) = LinearMap.ker (connectingMap hS n) := by
+  rw [← exact_at_rightHomology hS n]
+  ext b
+  change
+    (∃ a, homologyLinearMap g (n + 1) ((homologyBiprodEquiv K L (n + 1)).symm a) = b) ↔
+      ∃ a, homologyLinearMap g (n + 1) a = b
+  constructor
+  · rintro ⟨a, ha⟩
+    exact ⟨(homologyBiprodEquiv K L (n + 1)).symm a, ha⟩
+  · rintro ⟨a, ha⟩
+    refine ⟨homologyBiprodEquiv K L (n + 1) a, ?_⟩
+    rwa [LinearEquiv.symm_apply_apply]
+
+private theorem SingularMayerVietoris.biprodSequence_second_zero_surjective
+    {A K L B : ChainComplex (ModuleCat.{0} ℤ) ℕ} {f : A ⟶ K ⊞ L} {g : K ⊞ L ⟶ B} {hfg : f ≫ g = 0}
+    (hS : (CategoryTheory.ShortComplex.mk f g hfg).ShortExact) :
+    Function.Surjective (biprodSequenceSecondMap g 0) :=
+  (homologyLinearMap_second_zero_surjective hS).comp (homologyBiprodEquiv K L 0).symm.surjective
+
+/-- Integral singular homology in a specified degree. -/
+public
+abbrev SingularMayerVietoris.SingularHomology (Y : Type) [TopologicalSpace Y] (n : ℕ) :=
+  (FirstHurewicz.singularComplex Y).homology n
+
+/-- The map on singular homology induced by a continuous map. -/
+public
+abbrev SingularMayerVietoris.singularHomologyMap {Y Z : Type} [TopologicalSpace Y]
+    [TopologicalSpace Z] (f : C(Y, Z)) (n : ℕ) :
+    SingularHomology Y n →ₗ[ℤ] SingularHomology Z n :=
+  homologyLinearMap (FirstHurewicz.singularChainMap f) n
+
+@[simp]
+private theorem SingularMayerVietoris.singularHomologyMap_one {Y Z : Type} [TopologicalSpace Y]
+    [TopologicalSpace Z] (f : C(Y, Z)) :
+    singularHomologyMap f 1 = FirstHurewicz.inducedHomology f :=
+  rfl
+
+private abbrev SingularMayerVietoris.SmallHomology {X : Type} [TopologicalSpace X] (U V : Set X)
+    (n : ℕ) :=
+  (smallComplex U V).homology n
+
+private def SingularMayerVietoris.smallLeftHomologyMap {X : Type} [TopologicalSpace X] (U V : Set X)
+    (n : ℕ) :
+    SingularHomology (U ∩ V : Set X) n →ₗ[ℤ] (SingularHomology U n × SingularHomology V n) :=
+  biprodSequenceFirstMap (leftMap U V) n
+
+private def
+    SingularMayerVietoris.smallRightHomologyMap {X : Type} [TopologicalSpace X] (U V : Set X)
+    (n : ℕ) : (SingularHomology U n × SingularHomology V n) →ₗ[ℤ] SmallHomology U V n :=
+  biprodSequenceSecondMap (rightMap U V) n
+
+private def SingularMayerVietoris.smallConnectingMap {X : Type} [TopologicalSpace X] (U V : Set X)
+    (n : ℕ) : SmallHomology U V (n + 1) →ₗ[ℤ] SingularHomology (U ∩ V : Set X) n :=
+  connectingMap (chainSequence_shortExact U V) n
+
+private def
+    SingularMayerVietoris.smallHomologyComparison {X : Type} [TopologicalSpace X] (U V : Set X)
+    (n : ℕ) : SmallHomology U V n →ₗ[ℤ] SingularHomology X n :=
+  homologyLinearMap (smallInclusion U V) n
+
+private theorem
+    SingularMayerVietoris.smallLeftHomologyMap_components {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) (a : SingularHomology (U ∩ V : Set X) n) :
+    smallLeftHomologyMap U V n a =
+      (homologyLinearMap
+          (leftMap U V ≫
+            (CategoryTheory.Limits.biprod.fst :
+              middleComplex U V ⟶ FirstHurewicz.singularComplex U))
+          n a,
+        homologyLinearMap
+          (leftMap U V ≫
+            (CategoryTheory.Limits.biprod.snd :
+              middleComplex U V ⟶ FirstHurewicz.singularComplex V))
+          n a) := by
+  apply Prod.ext
+  · exact
+      (LinearMap.congr_fun
+          (homologyLinearMap_comp (leftMap U V) CategoryTheory.Limits.biprod.fst n) a).symm
+  · exact
+      (LinearMap.congr_fun
+          (homologyLinearMap_comp (leftMap U V) CategoryTheory.Limits.biprod.snd n) a).symm
+
+private theorem
+    SingularMayerVietoris.smallRightHomologyMap_components {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) (a : SingularHomology U n × SingularHomology V n) :
+    smallRightHomologyMap U V n a =
+      homologyLinearMap
+          ((CategoryTheory.Limits.biprod.inl :
+              FirstHurewicz.singularComplex U ⟶ middleComplex U V) ≫
+            rightMap U V)
+          n a.1 +
+        homologyLinearMap
+          ((CategoryTheory.Limits.biprod.inr :
+              FirstHurewicz.singularComplex V ⟶ middleComplex U V) ≫
+            rightMap U V)
+          n a.2 := by
+  rw [inl_rightMap, inr_rightMap]
+  exact biprodSequenceSecondMap_desc (toSmallLeft U V) (toSmallRight U V) n a
+
+private theorem SingularMayerVietoris.smallLeftHomologyMap_apply {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) (a : SingularHomology (U ∩ V : Set X) n) :
+    smallLeftHomologyMap U V n a =
+      (singularHomologyMap (ContinuousMap.inclusion (Set.inter_subset_left : U ∩ V ⊆ U)) n a,
+        -singularHomologyMap (ContinuousMap.inclusion (Set.inter_subset_right : U ∩ V ⊆ V)) n
+            a) := by
+  rw [smallLeftHomologyMap_components, leftMap_fst, leftMap_snd, homologyLinearMap_neg]
+  rfl
+
+private theorem SingularMayerVietoris.smallRightHomologyMap_apply {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) (a : SingularHomology U n × SingularHomology V n) :
+    smallRightHomologyMap U V n a =
+      homologyLinearMap (toSmallLeft U V) n a.1 + homologyLinearMap (toSmallRight U V) n a.2 := by
+  rw [smallRightHomologyMap_components, inl_rightMap, inr_rightMap]
+
+private theorem SingularMayerVietoris.smallHomologyComparison_right {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) (a : SingularHomology U n × SingularHomology V n) :
+    smallHomologyComparison U V n (smallRightHomologyMap U V n a) =
+      singularHomologyMap (subtypeInclusion U) n a.1 +
+        singularHomologyMap (subtypeInclusion V) n a.2 := by
+  rw [smallRightHomologyMap_apply, map_add]
+  apply congrArg₂ (· + ·)
+  · change
+      homologyLinearMap (smallInclusion U V) n (homologyLinearMap (toSmallLeft U V) n a.1) = _
+    rw [← LinearMap.comp_apply, ← homologyLinearMap_comp, toSmallLeft_inclusion]
+  · change
+      homologyLinearMap (smallInclusion U V) n (homologyLinearMap (toSmallRight U V) n a.2) = _
+    rw [← LinearMap.comp_apply, ← homologyLinearMap_comp, toSmallRight_inclusion]
+
+private theorem SingularMayerVietoris.small_exact_at_intersection {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) :
+    LinearMap.range (smallConnectingMap U V n) = LinearMap.ker (smallLeftHomologyMap U V n) :=
+  biprodSequence_exact_at_leftHomology (chainSequence_shortExact U V) n
+
+private theorem
+    SingularMayerVietoris.small_exact_at_pair {X : Type} [TopologicalSpace X] (U V : Set X)
+    (n : ℕ) :
+    LinearMap.range (smallLeftHomologyMap U V n) = LinearMap.ker (smallRightHomologyMap U V n) :=
+  biprodSequence_exact_at_middleHomology (chainSequence_shortExact U V) n
+
+private theorem SingularMayerVietoris.small_exact_at_smallHomology {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) :
+    LinearMap.range (smallRightHomologyMap U V (n + 1)) =
+      LinearMap.ker (smallConnectingMap U V n) :=
+  biprodSequence_exact_at_rightHomology (chainSequence_shortExact U V) n
+
+private theorem SingularMayerVietoris.smallRightHomologyMap_zero_surjective {X : Type}
+    [TopologicalSpace X] (U V : Set X) : Function.Surjective (smallRightHomologyMap U V 0) :=
+  biprodSequence_second_zero_surjective (chainSequence_shortExact U V)
+
+private theorem
+    SingularMayerVietoris.smallLeftHomologyMap_comp_right {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) : (smallRightHomologyMap U V n).comp (smallLeftHomologyMap U V n) = 0 :=
+  by
+  apply LinearMap.ext
+  intro a
+  have ha : smallLeftHomologyMap U V n a ∈ LinearMap.range (smallLeftHomologyMap U V n) :=
+    ⟨a, rfl⟩
+  rw [small_exact_at_pair] at ha
+  exact ha
+
+private theorem SingularMayerVietoris.rightTransport_range_eq_ker {A P B C : Type*} [AddCommGroup A]
+    [Module ℤ A] [AddCommGroup P] [Module ℤ P] [AddCommGroup B] [Module ℤ B] [AddCommGroup C]
+    [Module ℤ C] (e : B ≃ₗ[ℤ] C) (g : P →ₗ[ℤ] B) (δ : B →ₗ[ℤ] A)
+    (h : LinearMap.range g = LinearMap.ker δ) :
+    LinearMap.range (e.toLinearMap.comp g) = LinearMap.ker (δ.comp e.symm.toLinearMap) := by
+  ext c
+  change (∃ p, e (g p) = c) ↔ δ (e.symm c) = 0
+  constructor
+  · rintro ⟨p, rfl⟩
+    rw [LinearEquiv.symm_apply_apply]
+    have hp : g p ∈ LinearMap.range g := ⟨p, rfl⟩
+    rw [h] at hp
+    exact hp
+  · intro hc
+    have hp : e.symm c ∈ LinearMap.range g := by
+      rw [h]
+      exact hc
+    obtain ⟨p, hp⟩ := hp
+    exact ⟨p, (congrArg e hp).trans (e.apply_symm_apply c)⟩
+
+private theorem
+    SingularMayerVietoris.rightTransport_connecting_range {A B C : Type*} [AddCommGroup A]
+    [Module ℤ A] [AddCommGroup B] [Module ℤ B] [AddCommGroup C] [Module ℤ C] (e : B ≃ₗ[ℤ] C)
+    (δ : B →ₗ[ℤ] A) : LinearMap.range (δ.comp e.symm.toLinearMap) = LinearMap.range δ :=
+  e.symm.range_comp δ
+
+private theorem SingularMayerVietoris.rightTransport_second_ker {P B C : Type*} [AddCommGroup P]
+    [Module ℤ P] [AddCommGroup B] [Module ℤ B] [AddCommGroup C] [Module ℤ C] (e : B ≃ₗ[ℤ] C)
+    (g : P →ₗ[ℤ] B) : LinearMap.ker (e.toLinearMap.comp g) = LinearMap.ker g :=
+  e.ker_comp g
+
+private theorem
+    SingularMayerVietoris.rightTransport_second_surjective {P B C : Type*} [AddCommGroup P]
+    [Module ℤ P] [AddCommGroup B] [Module ℤ B] [AddCommGroup C] [Module ℤ C] (e : B ≃ₗ[ℤ] C)
+    (g : P →ₗ[ℤ] B) (hg : Function.Surjective g) : Function.Surjective (e.toLinearMap.comp g) :=
+  e.surjective.comp hg
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private abbrev SingularMayerVietoris.ModuleHomology.Cycle (K : ChainComplex (ModuleCat.{0} ℤ) ℕ)
+    (n : ℕ) :=
+  LinearMap.ker (K.d n ((ComplexShape.down ℕ).next n)).hom
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private instance
+    SingularMayerVietoris.ModuleHomology.cycleModule (K : ChainComplex (ModuleCat.{0} ℤ) ℕ)
+    (n : ℕ) : Module ℤ (SingularMayerVietoris.ModuleHomology.Cycle K n) :=
+  (SingularMayerVietoris.ModuleHomology.Cycle K n).module
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private theorem SingularMayerVietoris.ModuleHomology.next_nat (n : ℕ) :
+    (ComplexShape.down ℕ).next n = n - 1 := by cases n <;> simp
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private theorem SingularMayerVietoris.ModuleHomology.cycle_condition
+    (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) (n : ℕ)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle K n) : (K.d n (n - 1)).hom c.1 = 0 := by
+  rw [← next_nat n]
+  exact c.2
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private def
+    SingularMayerVietoris.ModuleHomology.mkCycle (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) (n : ℕ)
+    (c : K.X n) (hc : (K.d n (n - 1)).hom c = 0) :
+    SingularMayerVietoris.ModuleHomology.Cycle K n :=
+  ⟨c, by
+    change (K.d n ((ComplexShape.down ℕ).next n)).hom c = 0
+    rw [next_nat n]
+    exact hc⟩
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private def SingularMayerVietoris.ModuleHomology.cycleClass (K : ChainComplex (ModuleCat.{0} ℤ) ℕ)
+    (n : ℕ) : SingularMayerVietoris.ModuleHomology.Cycle K n →ₗ[ℤ] K.homology n :=
+  FirstHurewicz.ChainHomology.shortCycleClass (K.sc n)
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private theorem SingularMayerVietoris.ModuleHomology.cycleClass_surjective
+    (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) (n : ℕ) : Function.Surjective (cycleClass K n) :=
+  FirstHurewicz.ChainHomology.shortCycleClass_surjective (K.sc n)
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private theorem SingularMayerVietoris.ModuleHomology.cycleClass_eq_zero_iff
+    (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) (n : ℕ)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle K n) :
+    cycleClass K n c = 0 ↔ ∃ b : K.X (n + 1), (K.d (n + 1) n).hom b = c.1 := by
+  refine (FirstHurewicz.ChainHomology.shortCycleClass_eq_zero_iff (K.sc n) c).trans ?_
+  change
+    (∃ b : K.X ((ComplexShape.down ℕ).prev n),
+        (K.d ((ComplexShape.down ℕ).prev n) n).hom b = c.1) ↔
+      _
+  rw [ChainComplex.prev]
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private theorem SingularMayerVietoris.ModuleHomology.cycleClass_eq_iff
+    (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) (n : ℕ)
+    (c d : SingularMayerVietoris.ModuleHomology.Cycle K n) :
+    cycleClass K n c = cycleClass K n d ↔ ∃ b : K.X (n + 1), (K.d (n + 1) n).hom b = c.1 - d.1 := by
+  simpa only [map_sub, sub_eq_zero, Submodule.coe_sub] using cycleClass_eq_zero_iff K n (c - d)
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private def
+    SingularMayerVietoris.ModuleHomology.boundaryCycle (K : ChainComplex (ModuleCat.{0} ℤ) ℕ)
+    (n : ℕ) (b : K.X (n + 1)) : SingularMayerVietoris.ModuleHomology.Cycle K n :=
+  mkCycle K n ((K.d (n + 1) n).hom b)
+    (congrArg (fun f : K.X (n + 1) ⟶ K.X (n - 1) => f.hom b) (K.d_comp_d (n + 1) n (n - 1)))
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private abbrev
+    SingularMayerVietoris.ModuleHomology.shortMap {K L : ChainComplex (ModuleCat.{0} ℤ) ℕ}
+    (f : L ⟶ K) (n : ℕ) : L.sc n ⟶ K.sc n :=
+  (HomologicalComplex.shortComplexFunctor (ModuleCat.{0} ℤ) (ComplexShape.down ℕ) n).map f
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private def SingularMayerVietoris.ModuleHomology.mapCycles {K L : ChainComplex (ModuleCat.{0} ℤ) ℕ}
+    (f : L ⟶ K) (n : ℕ) :
+    SingularMayerVietoris.ModuleHomology.Cycle L n →ₗ[ℤ]
+      SingularMayerVietoris.ModuleHomology.Cycle K n :=
+  ((L.sc n).moduleCatCyclesIso.inv ≫
+      CategoryTheory.ShortComplex.cyclesMap (shortMap f n) ≫ (K.sc n).moduleCatCyclesIso.hom).hom
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+@[simp]
+private theorem SingularMayerVietoris.ModuleHomology.mapCycles_val
+    {K L : ChainComplex (ModuleCat.{0} ℤ) ℕ} (f : L ⟶ K) (n : ℕ)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle L n) :
+    (mapCycles f n c).1 = (f.f n).hom c.1 := by
+  have hcat :
+    (L.sc n).moduleCatCyclesIso.inv ≫
+        CategoryTheory.ShortComplex.cyclesMap (shortMap f n) ≫
+          (K.sc n).moduleCatCyclesIso.hom ≫ (K.sc n).moduleCatLeftHomologyData.i =
+      (L.sc n).moduleCatLeftHomologyData.i ≫ (shortMap f n).τ₂ := by
+    rw [(K.sc n).moduleCatCyclesIso_hom_i, CategoryTheory.ShortComplex.cyclesMap_i,
+      (L.sc n).moduleCatCyclesIso_inv_iCycles_assoc]
+  exact congrArg (fun g => g.hom c) hcat
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private theorem SingularMayerVietoris.ModuleHomology.homologyMap_cycleClass
+    {K L : ChainComplex (ModuleCat.{0} ℤ) ℕ} (f : L ⟶ K) (n : ℕ)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle L n) :
+    (HomologicalComplex.homologyMap f n).hom (cycleClass L n c) =
+      cycleClass K n (mapCycles f n c) := by
+  have hcat :
+    (L.sc n).moduleCatLeftHomologyData.π ≫
+        (L.sc n).moduleCatHomologyIso.inv ≫
+          CategoryTheory.ShortComplex.homologyMap (shortMap f n) =
+      ((L.sc n).moduleCatCyclesIso.inv ≫
+          CategoryTheory.ShortComplex.cyclesMap (shortMap f n) ≫
+            (K.sc n).moduleCatCyclesIso.hom) ≫
+        (K.sc n).moduleCatLeftHomologyData.π ≫ (K.sc n).moduleCatHomologyIso.inv := by
+    simp only [CategoryTheory.Category.assoc, ← (L.sc n).moduleCatCyclesIso_inv_π_assoc,
+      ← (K.sc n).moduleCatCyclesIso_inv_π, CategoryTheory.Iso.hom_inv_id_assoc]
+    rw [CategoryTheory.ShortComplex.homologyπ_naturality]
+  exact congrArg (fun g => g.hom c) hcat
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private theorem SingularMayerVietoris.ModuleHomology.homologyMap_surjective_of_cycle_lifting
+    {K L : ChainComplex (ModuleCat.{0} ℤ) ℕ} (f : L ⟶ K) (n : ℕ)
+    (hlift :
+      ∀ c : SingularMayerVietoris.ModuleHomology.Cycle K n,
+        ∃ z : SingularMayerVietoris.ModuleHomology.Cycle L n,
+          ∃ b : K.X (n + 1), (K.d (n + 1) n).hom b = (c.1 : K.X n) - (f.f n).hom z.1) :
+    Function.Surjective (HomologicalComplex.homologyMap f n).hom := by
+  intro h
+  obtain ⟨c, rfl⟩ := cycleClass_surjective K n h
+  obtain ⟨z, b, hb⟩ := hlift c
+  refine ⟨cycleClass L n z, ?_⟩
+  rw [homologyMap_cycleClass]
+  apply Eq.symm
+  apply (cycleClass_eq_iff K n c (mapCycles f n z)).mpr
+  exact ⟨b, by simpa only [mapCycles_val] using hb⟩
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private theorem SingularMayerVietoris.ModuleHomology.homologyMap_injective_of_boundary_lifting
+    {K L : ChainComplex (ModuleCat.{0} ℤ) ℕ} (f : L ⟶ K) (n : ℕ)
+    (hlift :
+      ∀ c : SingularMayerVietoris.ModuleHomology.Cycle L n,
+        ∀ b : K.X (n + 1),
+          (K.d (n + 1) n).hom b = (f.f n).hom c.1 →
+            ∃ a : L.X (n + 1), (L.d (n + 1) n).hom a = c.1) :
+    Function.Injective (HomologicalComplex.homologyMap f n).hom := by
+  intro x y hxy
+  obtain ⟨c, rfl⟩ := cycleClass_surjective L n x
+  obtain ⟨d, rfl⟩ := cycleClass_surjective L n y
+  have hz : (HomologicalComplex.homologyMap f n).hom (cycleClass L n (c - d)) = 0 := by
+    simp only [map_sub]
+    rw [hxy, sub_self]
+  rw [homologyMap_cycleClass] at hz
+  obtain ⟨b, hb⟩ := (cycleClass_eq_zero_iff K n (mapCycles f n (c - d))).mp hz
+  apply (cycleClass_eq_iff L n c d).mpr
+  exact hlift (c - d) b (hb.trans (mapCycles_val f n (c - d)))
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private theorem SingularMayerVietoris.ModuleHomology.quasiIsoAt_of_cycle_boundary_lifting
+    {K L : ChainComplex (ModuleCat.{0} ℤ) ℕ} (f : L ⟶ K) (n : ℕ)
+    (hsurj :
+      ∀ c : SingularMayerVietoris.ModuleHomology.Cycle K n,
+        ∃ z : SingularMayerVietoris.ModuleHomology.Cycle L n,
+          ∃ b : K.X (n + 1), (K.d (n + 1) n).hom b = (c.1 : K.X n) - (f.f n).hom z.1)
+    (hinj :
+      ∀ c : SingularMayerVietoris.ModuleHomology.Cycle L n,
+        ∀ b : K.X (n + 1),
+          (K.d (n + 1) n).hom b = (f.f n).hom c.1 →
+            ∃ a : L.X (n + 1), (L.d (n + 1) n).hom a = c.1) :
+    QuasiIsoAt f n := by
+  rw [quasiIsoAt_iff_isIso_homologyMap]
+  apply (CategoryTheory.ConcreteCategory.isIso_iff_bijective _).mpr
+  exact
+    ⟨homologyMap_injective_of_boundary_lifting f n hinj,
+      homologyMap_surjective_of_cycle_lifting f n hsurj⟩
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private theorem SingularMayerVietoris.ModuleHomology.quasiIso_of_cycle_boundary_lifting
+    {K L : ChainComplex (ModuleCat.{0} ℤ) ℕ} (f : L ⟶ K)
+    (hsurj :
+      ∀ n,
+        ∀ c : SingularMayerVietoris.ModuleHomology.Cycle K n,
+          ∃ z : SingularMayerVietoris.ModuleHomology.Cycle L n,
+            ∃ b : K.X (n + 1), (K.d (n + 1) n).hom b = (c.1 : K.X n) - (f.f n).hom z.1)
+    (hinj :
+      ∀ n,
+        ∀ c : SingularMayerVietoris.ModuleHomology.Cycle L n,
+          ∀ b : K.X (n + 1),
+            (K.d (n + 1) n).hom b = (f.f n).hom c.1 →
+              ∃ a : L.X (n + 1), (L.d (n + 1) n).hom a = c.1) :
+    QuasiIso f := by
+  rw [quasiIso_iff]
+  intro n
+  exact quasiIsoAt_of_cycle_boundary_lifting f n (hsurj n) (hinj n)
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private theorem SingularMayerVietoris.ModuleHomology.cycle_of_boundary_relation
+    {K L : ChainComplex (ModuleCat.{0} ℤ) ℕ} (f : L ⟶ K) (n : ℕ)
+    (hf : Function.Injective (f.f (n - 1)).hom) (c : K.X n) (hc : (K.d n (n - 1)).hom c = 0)
+    (z : L.X n) (b : K.X (n + 1)) (hb : (K.d (n + 1) n).hom b = c - (f.f n).hom z) :
+    (L.d n (n - 1)).hom z = 0 := by
+  have hdd : (K.d n (n - 1)).hom ((K.d (n + 1) n).hom b) = 0 :=
+    congrArg (fun g : K.X (n + 1) ⟶ K.X (n - 1) => g.hom b) (K.d_comp_d (n + 1) n (n - 1))
+  have he := congrArg (K.d n (n - 1)).hom hb
+  rw [hdd, map_sub, hc, zero_sub] at he
+  have hz : (K.d n (n - 1)).hom ((f.f n).hom z) = 0 := neg_eq_zero.mp he.symm
+  apply hf
+  rw [map_zero]
+  exact (congrArg (fun g : L.X n ⟶ K.X (n - 1) => g.hom z) (f.comm n (n - 1))).symm.trans hz
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private theorem SingularMayerVietoris.ModuleHomology.quasiIso_of_injective_chain_conditions
+    {K L : ChainComplex (ModuleCat.{0} ℤ) ℕ} (f : L ⟶ K)
+    (hf : ∀ n, Function.Injective (f.f n).hom)
+    (hsurj :
+      ∀ n,
+        ∀ c : K.X n,
+          (K.d n (n - 1)).hom c = 0 →
+            ∃ z : L.X n, ∃ b : K.X (n + 1), (K.d (n + 1) n).hom b = c - (f.f n).hom z)
+    (hinj :
+      ∀ n,
+        ∀ c : L.X n,
+          (L.d n (n - 1)).hom c = 0 →
+            ∀ b : K.X (n + 1),
+              (K.d (n + 1) n).hom b = (f.f n).hom c →
+                ∃ a : L.X (n + 1), (L.d (n + 1) n).hom a = c) :
+    QuasiIso f := by
+  apply quasiIso_of_cycle_boundary_lifting f
+  · intro n c
+    obtain ⟨z, b, hb⟩ := hsurj n c.1 (cycle_condition K n c)
+    refine ⟨mkCycle L n z ?_, b, hb⟩
+    exact cycle_of_boundary_relation f n (hf (n - 1)) c.1 (cycle_condition K n c) z b hb
+  · intro n c b hb
+    exact hinj n c.1 (cycle_condition L n c) b hb
+
+private def
+    SingularMayerVietoris.affineSimplex {n p : ℕ} (v : Fin (n + 1) → FirstHurewicz.Simplex p) :
+    C(FirstHurewicz.Simplex n, FirstHurewicz.Simplex p)
+    where
+  toFun
+    t :=
+    ⟨∑ i, t i • (v i : Fin (p + 1) → ℝ),
+      (convex_stdSimplex ℝ (Fin (p + 1))).sum_mem (fun i _ => stdSimplex.zero_le t i)
+        (stdSimplex.sum_eq_one t) (fun i _ => (v i).property)⟩
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    exact
+      continuous_finsetSum _
+        (fun i _ => ((continuous_apply i).comp continuous_subtype_val).smul continuous_const)
+
+@[simp]
+private theorem SingularMayerVietoris.affineSimplex_coordinate {n p : ℕ}
+    (v : Fin (n + 1) → FirstHurewicz.Simplex p) (t : FirstHurewicz.Simplex n) (j : Fin (p + 1)) :
+    affineSimplex v t j = ∑ i, t i * v i j := by
+  change (∑ i, t i • (v i : Fin (p + 1) → ℝ)) j = _
+  simp only [Finset.sum_apply, Pi.smul_apply, smul_eq_mul]
+
+@[simp]
+private theorem SingularMayerVietoris.affineSimplex_vertex {n p : ℕ}
+    (v : Fin (n + 1) → FirstHurewicz.Simplex p) (i : Fin (n + 1)) :
+    affineSimplex v (stdSimplex.vertex (S := ℝ) i) = v i := by
+  apply Subtype.ext
+  change
+    (∑ j : Fin (n + 1), ((Pi.single i (1 : ℝ) : Fin (n + 1) → ℝ) j) • (v j : Fin (p + 1) → ℝ)) =
+      (v i : Fin (p + 1) → ℝ)
+  simp [Pi.single_apply]
+
+private def SingularMayerVietoris.stdVertices (n : ℕ) : Fin (n + 1) → FirstHurewicz.Simplex n :=
+  stdSimplex.vertex
+
+@[simp]
+private theorem SingularMayerVietoris.affineSimplex_stdVertices (n : ℕ) :
+    affineSimplex (stdVertices n) = ContinuousMap.id (FirstHurewicz.Simplex n) := by
+  apply ContinuousMap.ext
+  intro t
+  apply Subtype.ext
+  funext j
+  change (∑ i, t i • Pi.single i (1 : ℝ)) j = t j
+  simp [Finset.sum_apply, Pi.smul_apply, Pi.single_apply]
+
+private theorem SingularMayerVietoris.affineSimplex_face {n p : ℕ}
+    (v : Fin (n + 2) → FirstHurewicz.Simplex p) (i : Fin (n + 2)) :
+    (affineSimplex v).comp (FirstHurewicz.simplexFace n i) =
+      affineSimplex (fun j => v (i.succAbove j)) := by
+  apply ContinuousMap.ext
+  intro t
+  apply Subtype.ext
+  change
+    (∑ j : Fin (n + 2), FirstHurewicz.simplexFace n i t j • (v j : Fin (p + 1) → ℝ)) =
+      ∑ j : Fin (n + 1), t j • (v (i.succAbove j) : Fin (p + 1) → ℝ)
+  rw [Fin.sum_univ_succAbove _ i]
+  simp only [FirstHurewicz.simplexFace_apply_self, zero_smul,
+    FirstHurewicz.simplexFace_apply_succAbove, zero_add]
+
+private theorem SingularMayerVietoris.affineSimplex_comp {m n p : ℕ}
+    (v : Fin (n + 1) → FirstHurewicz.Simplex p) (w : Fin (m + 1) → FirstHurewicz.Simplex n) :
+    (affineSimplex v).comp (affineSimplex w) = affineSimplex (fun j => affineSimplex v (w j)) := by
+  apply ContinuousMap.ext
+  intro t
+  apply Subtype.ext
+  funext k
+  change
+    affineSimplex v (affineSimplex w t) k = affineSimplex (fun j => affineSimplex v (w j)) t k
+  simp only [affineSimplex_coordinate, Finset.sum_mul, Finset.mul_sum, mul_assoc]
+  exact Finset.sum_comm
+
+private theorem SingularMayerVietoris.affineSimplex_mem_convexHull {n p : ℕ}
+    (v : Fin (n + 1) → FirstHurewicz.Simplex p) (t : FirstHurewicz.Simplex n) :
+    (affineSimplex v t : Fin (p + 1) → ℝ) ∈
+      convexHull ℝ (Set.range fun i => (v i : Fin (p + 1) → ℝ)) := by
+  change (∑ i, t i • (v i : Fin (p + 1) → ℝ)) ∈ _
+  apply (convex_convexHull ℝ _).sum_mem
+  · intro i _
+    exact stdSimplex.zero_le t i
+  · exact stdSimplex.sum_eq_one t
+  · intro i _
+    exact subset_convexHull ℝ _ (Set.mem_range_self i)
+
+private def SingularMayerVietoris.simplexBarycenter {n p : ℕ}
+    (v : Fin (n + 1) → FirstHurewicz.Simplex p) : FirstHurewicz.Simplex p :=
+  affineSimplex v (stdSimplex.barycenter : FirstHurewicz.Simplex n)
+
+private theorem SingularMayerVietoris.simplexBarycenter_coe {n p : ℕ}
+    (v : Fin (n + 1) → FirstHurewicz.Simplex p) :
+    (simplexBarycenter v : Fin (p + 1) → ℝ) =
+      ((n + 1 : ℕ) : ℝ)⁻¹ • ∑ i, (v i : Fin (p + 1) → ℝ) := by
+  change (∑ i, (Fintype.card (Fin (n + 1)) : ℝ)⁻¹ • (v i : Fin (p + 1) → ℝ)) = _
+  simp only [Fintype.card_fin, Finset.smul_sum]
+
+private theorem SingularMayerVietoris.affineSimplex_simplexBarycenter {m n p : ℕ}
+    (v : Fin (n + 1) → FirstHurewicz.Simplex p) (w : Fin (m + 1) → FirstHurewicz.Simplex n) :
+    affineSimplex v (simplexBarycenter w) = simplexBarycenter (fun j => affineSimplex v (w j)) :=
+  ContinuousMap.congr_fun (affineSimplex_comp v w)
+    (stdSimplex.barycenter : FirstHurewicz.Simplex m)
+
+/-- Formal integer combinations of ordered `n`-tuples of vertices. -/
+public
+abbrev SingularMayerVietoris.FormalChains (V : Type*) (n : ℕ) :=
+  (Fin n → V) →₀ ℤ
+
+private def
+    SingularMayerVietoris.formalSimplex {V : Type*} {n : ℕ} (v : Fin n → V) : FormalChains V n :=
+  Finsupp.single v 1
+
+private def SingularMayerVietoris.formalLift {V M : Type*} {n : ℕ} [AddCommGroup M] [Module ℤ M]
+    (f : (Fin n → V) → M) : FormalChains V n →ₗ[ℤ] M :=
+  Finsupp.linearCombination ℤ f
+
+@[simp]
+private theorem SingularMayerVietoris.formalLift_simplex {V M : Type*} {n : ℕ} [AddCommGroup M]
+    [modM : Module ℤ M] (f : (Fin n → V) → M) (v : Fin n → V) :
+    formalLift f (formalSimplex v) = f v := by
+  exact (Finsupp.linearCombination_single ℤ 1 v).trans (modM.one_smul (f v))
+
+private theorem
+    SingularMayerVietoris.formalChains_ext {V M : Type*} {n : ℕ} [AddCommGroup M] [Module ℤ M]
+    {f g : FormalChains V n →ₗ[ℤ] M} (h : ∀ v, f (formalSimplex v) = g (formalSimplex v)) :
+    f = g := by
+  apply Finsupp.lhom_ext
+  intro v z
+  have hs : Finsupp.single v z = z • formalSimplex v := by
+    simp [formalSimplex, Finsupp.smul_single]
+  rw [hs, f.map_smul, g.map_smul, h]
+
+private def SingularMayerVietoris.formalMap {V W : Type*} (f : V → W) (n : ℕ) :
+    FormalChains V n →ₗ[ℤ] FormalChains W n :=
+  Finsupp.lmapDomain ℤ ℤ (fun v => f ∘ v)
+
+@[simp]
+private theorem SingularMayerVietoris.formalMap_simplex {V W : Type*} (f : V → W) {n : ℕ}
+    (v : Fin n → V) : formalMap f n (formalSimplex v) = formalSimplex (f ∘ v) := by
+  simp [formalMap, formalSimplex]
+
+private def SingularMayerVietoris.formalCone {V : Type*} (a : V) (n : ℕ) :
+    FormalChains V n →ₗ[ℤ] FormalChains V (n + 1) :=
+  Finsupp.lmapDomain ℤ ℤ (fun v => Fin.cons a v)
+
+@[simp]
+private theorem
+    SingularMayerVietoris.formalCone_simplex {V : Type*} (a : V) {n : ℕ} (v : Fin n → V) :
+    formalCone a n (formalSimplex v) = formalSimplex (Fin.cons a v) := by
+  simp [formalCone, formalSimplex]
+
+private def SingularMayerVietoris.formalBoundary {V : Type*} (n : ℕ) :
+    FormalChains V (n + 1) →ₗ[ℤ] FormalChains V n :=
+  formalLift fun v => ∑ i : Fin (n + 1), (-1 : ℤ) ^ i.val • formalSimplex (v ∘ i.succAbove)
+
+@[simp]
+private theorem
+    SingularMayerVietoris.formalBoundary_simplex {V : Type*} (n : ℕ) (v : Fin (n + 1) → V) :
+    formalBoundary n (formalSimplex v) =
+      ∑ i : Fin (n + 1), (-1 : ℤ) ^ i.val • formalSimplex (v ∘ i.succAbove) :=
+  formalLift_simplex _ _
+
+private theorem SingularMayerVietoris.formalBoundary_cone_zero {V : Type*} (a : V)
+    (c : FormalChains V 0) : formalBoundary 0 (formalCone a 0 c) = c := by
+  have h : (formalBoundary 0).comp (formalCone a 0) = LinearMap.id := by
+    apply formalChains_ext
+    intro v
+    simp only [LinearMap.comp_apply, formalCone_simplex, formalBoundary_simplex,
+      LinearMap.id_apply]
+    change
+      (∑ i : Fin 1, (-1 : ℤ) ^ i.val • formalSimplex (Fin.cons a v ∘ i.succAbove)) =
+        formalSimplex v
+    simp only [Fin.sum_univ_one, Fin.val_zero, pow_zero, one_smul]
+    congr 1
+  exact LinearMap.congr_fun h c
+
+private theorem SingularMayerVietoris.formalBoundary_cone {V : Type*} (a : V) (n : ℕ)
+    (c : FormalChains V (n + 1)) :
+    formalBoundary (n + 1) (formalCone a (n + 1) c) = c - formalCone a n (formalBoundary n c) := by
+  have h :
+    (formalBoundary (n + 1)).comp (formalCone a (n + 1)) =
+      LinearMap.id - (formalCone a n).comp (formalBoundary n) := by
+    apply formalChains_ext
+    intro v
+    simp only [LinearMap.comp_apply, LinearMap.sub_apply, LinearMap.id_apply, formalCone_simplex,
+      formalBoundary_simplex]
+    rw [Fin.sum_univ_succ]
+    simp only [Fin.val_zero, pow_zero, one_smul]
+    have hz : Fin.cons a v ∘ (0 : Fin (n + 2)).succAbove = v := by
+      funext i
+      simp
+    rw [hz, sub_eq_add_neg]
+    congr 1
+    rw [map_sum, ← Finset.sum_neg_distrib]
+    apply Finset.sum_congr rfl
+    intro i hi
+    simp only [Fin.val_succ, pow_succ, mul_neg_one, neg_smul, Fin.cons_comp_succ_succAbove,
+      map_smul, formalCone_simplex]
+    rfl
+  exact LinearMap.congr_fun h c
+
+private theorem SingularMayerVietoris.formalBoundary_comp {V : Type*} (n : ℕ) :
+    (formalBoundary (V := V) n).comp (formalBoundary (n + 1)) = 0 := by
+  induction n with
+  | zero =>
+    apply formalChains_ext
+    intro v
+    change formalBoundary 0 (formalBoundary 1 (formalSimplex v)) = 0
+    have hv : formalSimplex v = formalCone (v 0) 1 (formalSimplex (Fin.tail v)) := by
+      rw [formalCone_simplex, Fin.cons_self_tail]
+    rw [hv, formalBoundary_cone, map_sub, formalBoundary_cone_zero, sub_self]
+  | succ n ih =>
+    apply formalChains_ext
+    intro v
+    change formalBoundary (n + 1) (formalBoundary (n + 2) (formalSimplex v)) = 0
+    have hv : formalSimplex v = formalCone (v 0) (n + 2) (formalSimplex (Fin.tail v)) := by
+      rw [formalCone_simplex, Fin.cons_self_tail]
+    have hb := LinearMap.congr_fun ih (formalSimplex (Fin.tail v))
+    change formalBoundary n (formalBoundary (n + 1) (formalSimplex (Fin.tail v))) = 0 at hb
+    rw [hv, formalBoundary_cone, map_sub, formalBoundary_cone, hb, map_zero, sub_zero, sub_self]
+
+@[simp]
+private theorem SingularMayerVietoris.formalBoundary_boundary {V : Type*} (n : ℕ)
+    (c : FormalChains V (n + 2)) : formalBoundary n (formalBoundary (n + 1) c) = 0 :=
+  LinearMap.congr_fun (formalBoundary_comp n) c
+
+private theorem SingularMayerVietoris.formalMap_boundary {V W : Type*} (f : V → W) (n : ℕ)
+    (c : FormalChains V (n + 1)) :
+    formalMap f n (formalBoundary n c) = formalBoundary n (formalMap f (n + 1) c) := by
+  have h :
+    (formalMap f n).comp (formalBoundary n) = (formalBoundary n).comp (formalMap f (n + 1)) := by
+    apply formalChains_ext
+    intro v
+    simp only [LinearMap.comp_apply, formalBoundary_simplex, map_sum, map_smul, formalMap_simplex,
+      Function.comp_assoc]
+  exact LinearMap.congr_fun h c
+
+private theorem SingularMayerVietoris.formalMap_cone {V W : Type*} (f : V → W) (a : V) (n : ℕ)
+    (c : FormalChains V n) :
+    formalMap f (n + 1) (formalCone a n c) = formalCone (f a) n (formalMap f n c) := by
+  have h :
+    (formalMap f (n + 1)).comp (formalCone a n) = (formalCone (f a) n).comp (formalMap f n) := by
+    apply formalChains_ext
+    intro v
+    simp only [LinearMap.comp_apply, formalCone_simplex, formalMap_simplex]
+    congr 1
+    funext i
+    refine Fin.cases ?_ (fun j => ?_) i <;> rfl
+  exact LinearMap.congr_fun h c
+
+private abbrev SingularMayerVietoris.FormalCenter (V : Type*) :=
+  ∀ n : ℕ, (Fin (n + 1) → V) → V
+
+private def SingularMayerVietoris.formalSubdivision {V : Type*} (center : FormalCenter V) :
+    (n : ℕ) → FormalChains V n →ₗ[ℤ] FormalChains V n
+  | 0 => LinearMap.id
+  | n + 1 =>
+    formalLift fun v =>
+      formalCone (center n v) n (formalSubdivision center n (formalBoundary n (formalSimplex v)))
+
+@[simp]
+private theorem SingularMayerVietoris.formalSubdivision_zero {V : Type*} (center : FormalCenter V)
+    (c : FormalChains V 0) : formalSubdivision center 0 c = c :=
+  rfl
+
+@[simp]
+private theorem
+    SingularMayerVietoris.formalSubdivision_simplex_succ {V : Type*} (center : FormalCenter V)
+    (n : ℕ) (v : Fin (n + 1) → V) :
+    formalSubdivision center (n + 1) (formalSimplex v) =
+      formalCone (center n v) n
+        (formalSubdivision center n (formalBoundary n (formalSimplex v))) :=
+  formalLift_simplex _ _
+
+private theorem
+    SingularMayerVietoris.formalBoundary_subdivision {V : Type*} (center : FormalCenter V) :
+    ∀ (n : ℕ) (c : FormalChains V (n + 1)),
+      formalBoundary n (formalSubdivision center (n + 1) c) =
+        formalSubdivision center n (formalBoundary n c) := by
+  intro n
+  induction n with
+  | zero =>
+    intro c
+    have h :
+      (formalBoundary 0).comp (formalSubdivision center 1) =
+        (formalSubdivision center 0).comp (formalBoundary 0) := by
+      apply formalChains_ext
+      intro v
+      simp only [LinearMap.comp_apply, formalSubdivision_simplex_succ, formalBoundary_cone_zero]
+    exact LinearMap.congr_fun h c
+  | succ n ih =>
+    intro c
+    have h :
+      (formalBoundary (n + 1)).comp (formalSubdivision center (n + 2)) =
+        (formalSubdivision center (n + 1)).comp (formalBoundary (n + 1)) := by
+      apply formalChains_ext
+      intro v
+      simp only [LinearMap.comp_apply, formalSubdivision_simplex_succ]
+      rw [formalBoundary_cone, ih, formalBoundary_boundary, map_zero, map_zero, sub_zero]
+    exact LinearMap.congr_fun h c
+
+private theorem SingularMayerVietoris.formalMap_subdivision {V W : Type*} (center : FormalCenter V)
+    (center' : FormalCenter W) (f : V → W) (hf : ∀ n v, f (center n v) = center' n (f ∘ v)) :
+    ∀ (n : ℕ) (c : FormalChains V n),
+      formalMap f n (formalSubdivision center n c) =
+        formalSubdivision center' n (formalMap f n c) := by
+  intro n
+  induction n with
+  | zero => intro c; rfl
+  | succ n ih =>
+    intro c
+    have h :
+      (formalMap f (n + 1)).comp (formalSubdivision center (n + 1)) =
+        (formalSubdivision center' (n + 1)).comp (formalMap f (n + 1)) := by
+      apply formalChains_ext
+      intro v
+      simp only [LinearMap.comp_apply, formalSubdivision_simplex_succ, formalMap_simplex]
+      rw [formalMap_cone, ih, formalMap_boundary, formalMap_simplex, hf]
+    exact LinearMap.congr_fun h c
+
+private def SingularMayerVietoris.simplexCenter (p : ℕ) : FormalCenter (FirstHurewicz.Simplex p) :=
+  fun _ v => simplexBarycenter v
+
+private def SingularMayerVietoris.affineChainMap (p n : ℕ) :
+    FormalChains (FirstHurewicz.Simplex p) (n + 1) →ₗ[ℤ]
+      FirstHurewicz.Chains (FirstHurewicz.Simplex p) n :=
+  formalLift fun v => FirstHurewicz.simplexChain (FirstHurewicz.Simplex p) n (affineSimplex v)
+
+@[simp]
+private theorem SingularMayerVietoris.affineChainMap_simplex (p n : ℕ)
+    (v : Fin (n + 1) → FirstHurewicz.Simplex p) :
+    affineChainMap p n (formalSimplex v) =
+      FirstHurewicz.simplexChain (FirstHurewicz.Simplex p) n (affineSimplex v) :=
+  formalLift_simplex _ _
+
+private theorem SingularMayerVietoris.affineChainMap_boundary (p n : ℕ)
+    (c : FormalChains (FirstHurewicz.Simplex p) (n + 2)) :
+    ((FirstHurewicz.singularComplex (FirstHurewicz.Simplex p)).d (n + 1) n).hom
+        (affineChainMap p (n + 1) c) =
+      affineChainMap p n (formalBoundary (n + 1) c) := by
+  have h :
+    (((FirstHurewicz.singularComplex (FirstHurewicz.Simplex p)).d (n + 1) n).hom).comp
+        (affineChainMap p (n + 1)) =
+      (affineChainMap p n).comp (formalBoundary (n + 1)) := by
+    apply formalChains_ext
+    intro v
+    change
+      ((FirstHurewicz.singularComplex (FirstHurewicz.Simplex p)).d (n + 1) n).hom
+          (affineChainMap p (n + 1) (formalSimplex v)) =
+        _
+    rw [affineChainMap_simplex, FirstHurewicz.boundary_simplex]
+    change _ = affineChainMap p n (formalBoundary (n + 1) (formalSimplex v))
+    rw [formalBoundary_simplex, map_sum]
+    apply Finset.sum_congr rfl
+    intro i hi
+    rw [map_zsmul, affineChainMap_simplex, affineSimplex_face]
+    rfl
+  exact LinearMap.congr_fun h c
+
+private theorem SingularMayerVietoris.inducedChain_affineChainMap {m n p : ℕ}
+    (v : Fin (n + 1) → FirstHurewicz.Simplex p)
+    (c : FormalChains (FirstHurewicz.Simplex n) (m + 1)) :
+    FirstHurewicz.inducedChain (affineSimplex v) m (affineChainMap n m c) =
+      affineChainMap p m (formalMap (affineSimplex v) (m + 1) c) := by
+  have h :
+    (FirstHurewicz.inducedChain (affineSimplex v) m).comp (affineChainMap n m) =
+      (affineChainMap p m).comp (formalMap (affineSimplex v) (m + 1)) := by
+    apply formalChains_ext
+    intro w
+    simp only [LinearMap.comp_apply, affineChainMap_simplex, FirstHurewicz.inducedChain_simplex,
+      formalMap_simplex, affineSimplex_comp]
+    rfl
+  exact LinearMap.congr_fun h c
+
+private theorem SingularMayerVietoris.affineChainMap_stdVertices (n : ℕ) :
+    affineChainMap n n (formalSimplex (stdVertices n)) =
+      FirstHurewicz.simplexChain (FirstHurewicz.Simplex n) n
+        (ContinuousMap.id (FirstHurewicz.Simplex n)) := by
+  rw [affineChainMap_simplex, affineSimplex_stdVertices]
+
+private theorem SingularMayerVietoris.affineSimplex_preserves_center {n p : ℕ}
+    (v : Fin (n + 1) → FirstHurewicz.Simplex p) (m : ℕ)
+    (w : Fin (m + 1) → FirstHurewicz.Simplex n) :
+    affineSimplex v (simplexCenter n m w) = simplexCenter p m (affineSimplex v ∘ w) :=
+  affineSimplex_simplexBarycenter v w
+
+private def SingularMayerVietoris.formalSubdivisionHomotopy {V : Type*} (center : FormalCenter V) :
+    (n : ℕ) → FormalChains V n →ₗ[ℤ] FormalChains V (n + 1)
+  | 0 => 0
+  | n + 1 =>
+    formalLift fun v =>
+      formalCone (v 0) (n + 1)
+        (formalSimplex v - formalSubdivision center (n + 1) (formalSimplex v) -
+          formalSubdivisionHomotopy center n (formalBoundary n (formalSimplex v)))
+
+@[simp]
+private theorem
+    SingularMayerVietoris.formalSubdivisionHomotopy_zero {V : Type*} (center : FormalCenter V)
+    (c : FormalChains V 0) : formalSubdivisionHomotopy center 0 c = 0 :=
+  rfl
+
+@[simp]
+private theorem SingularMayerVietoris.formalSubdivisionHomotopy_simplex_succ {V : Type*}
+    (center : FormalCenter V) (n : ℕ) (v : Fin (n + 1) → V) :
+    formalSubdivisionHomotopy center (n + 1) (formalSimplex v) =
+      formalCone (v 0) (n + 1)
+        (formalSimplex v - formalSubdivision center (n + 1) (formalSimplex v) -
+          formalSubdivisionHomotopy center n (formalBoundary n (formalSimplex v))) :=
+  formalLift_simplex _ _
+
+private theorem SingularMayerVietoris.formalSubdivisionHomotopy_boundary {V : Type*}
+    (center : FormalCenter V) :
+    ∀ (n : ℕ) (c : FormalChains V (n + 1)),
+      formalBoundary (n + 1) (formalSubdivisionHomotopy center (n + 1) c) +
+          formalSubdivisionHomotopy center n (formalBoundary n c) =
+        c - formalSubdivision center (n + 1) c := by
+  intro n
+  induction n with
+  | zero =>
+    intro c
+    have h :
+      (formalBoundary 1).comp (formalSubdivisionHomotopy center 1) +
+          (formalSubdivisionHomotopy center 0).comp (formalBoundary 0) =
+        LinearMap.id - formalSubdivision center 1 := by
+      apply formalChains_ext
+      intro v
+      change
+        formalBoundary 1 (formalSubdivisionHomotopy center 1 (formalSimplex v)) +
+            formalSubdivisionHomotopy center 0 (formalBoundary 0 (formalSimplex v)) =
+          formalSimplex v - formalSubdivision center 1 (formalSimplex v)
+      have hc :
+        formalBoundary 0
+            (formalSimplex v - formalSubdivision center 1 (formalSimplex v) -
+              formalSubdivisionHomotopy center 0 (formalBoundary 0 (formalSimplex v))) =
+          0 := by
+        simp only [map_sub, formalBoundary_subdivision, formalSubdivision_zero,
+          formalSubdivisionHomotopy_zero, sub_self, sub_zero]
+      rw [formalSubdivisionHomotopy_simplex_succ, formalBoundary_cone, hc, map_zero, sub_zero,
+        sub_add_cancel]
+    exact LinearMap.congr_fun h c
+  | succ n ih =>
+    intro c
+    have h :
+      (formalBoundary (n + 2)).comp (formalSubdivisionHomotopy center (n + 2)) +
+          (formalSubdivisionHomotopy center (n + 1)).comp (formalBoundary (n + 1)) =
+        LinearMap.id - formalSubdivision center (n + 2) := by
+      apply formalChains_ext
+      intro v
+      change
+        formalBoundary (n + 2) (formalSubdivisionHomotopy center (n + 2) (formalSimplex v)) +
+            formalSubdivisionHomotopy center (n + 1) (formalBoundary (n + 1) (formalSimplex v)) =
+          formalSimplex v - formalSubdivision center (n + 2) (formalSimplex v)
+      have hp :
+        formalBoundary (n + 1)
+            (formalSubdivisionHomotopy center (n + 1)
+              (formalBoundary (n + 1) (formalSimplex v))) =
+          formalBoundary (n + 1) (formalSimplex v) -
+            formalSubdivision center (n + 1) (formalBoundary (n + 1) (formalSimplex v)) := by
+        simpa only [formalBoundary_boundary, map_zero, add_zero] using
+          ih (formalBoundary (n + 1) (formalSimplex v))
+      have hc :
+        formalBoundary (n + 1)
+            (formalSimplex v - formalSubdivision center (n + 2) (formalSimplex v) -
+              formalSubdivisionHomotopy center (n + 1)
+                (formalBoundary (n + 1) (formalSimplex v))) =
+          0 := by rw [map_sub, map_sub, formalBoundary_subdivision, hp, sub_self]
+      rw [formalSubdivisionHomotopy_simplex_succ, formalBoundary_cone, hc, map_zero, sub_zero,
+        sub_add_cancel]
+    exact LinearMap.congr_fun h c
+
+private theorem SingularMayerVietoris.formalMap_subdivisionHomotopy {V W : Type*}
+    (center : FormalCenter V) (center' : FormalCenter W) (f : V → W)
+    (hf : ∀ n v, f (center n v) = center' n (f ∘ v)) :
+    ∀ (n : ℕ) (c : FormalChains V n),
+      formalMap f (n + 1) (formalSubdivisionHomotopy center n c) =
+        formalSubdivisionHomotopy center' n (formalMap f n c) := by
+  intro n
+  induction n with
+  | zero => intro c; simp
+  | succ n ih =>
+    intro c
+    have h :
+      (formalMap f (n + 2)).comp (formalSubdivisionHomotopy center (n + 1)) =
+        (formalSubdivisionHomotopy center' (n + 1)).comp (formalMap f (n + 1)) := by
+      apply formalChains_ext
+      intro v
+      simp only [LinearMap.comp_apply, formalSubdivisionHomotopy_simplex_succ, formalMap_simplex]
+      rw [formalMap_cone]
+      congr 1
+      rw [map_sub, map_sub, formalMap_simplex, formalMap_subdivision center center' f hf, ih,
+        formalMap_boundary, formalMap_simplex]
+    exact LinearMap.congr_fun h c
+
+private theorem SingularMayerVietoris.formalBoundary_subdivision_iterate {V : Type*}
+    (center : FormalCenter V) (k n : ℕ) (c : FormalChains V (n + 1)) :
+    formalBoundary n ((formalSubdivision center (n + 1))^[k] c) =
+      (formalSubdivision center n)^[k] (formalBoundary n c) := by
+  induction k with
+  | zero => rfl
+  | succ k ih =>
+    rw [Function.iterate_succ_apply', Function.iterate_succ_apply', formalBoundary_subdivision,
+      ih]
+
+private theorem SingularMayerVietoris.formalMap_subdivision_iterate {V W : Type*}
+    (center : FormalCenter V) (center' : FormalCenter W) (f : V → W)
+    (hf : ∀ n v, f (center n v) = center' n (f ∘ v)) (k n : ℕ) (c : FormalChains V n) :
+    formalMap f n ((formalSubdivision center n)^[k] c) =
+      (formalSubdivision center' n)^[k] (formalMap f n c) := by
+  induction k with
+  | zero => rfl
+  | succ k ih =>
+    rw [Function.iterate_succ_apply', Function.iterate_succ_apply',
+      formalMap_subdivision center center' f hf, ih]
+
+private def
+    SingularMayerVietoris.formalSubdivisionIteratedHomotopy {V : Type*} (center : FormalCenter V)
+    (k n : ℕ) : FormalChains V n →ₗ[ℤ] FormalChains V (n + 1) :=
+  ∑ j ∈ Finset.range k,
+    (formalSubdivisionHomotopy center n).comp ((formalSubdivision center n) ^ j)
+
+private theorem SingularMayerVietoris.formalSubdivisionIteratedHomotopy_apply {V : Type*}
+    (center : FormalCenter V) (k n : ℕ) (c : FormalChains V n) :
+    formalSubdivisionIteratedHomotopy center k n c =
+      ∑ j ∈ Finset.range k,
+        formalSubdivisionHomotopy center n ((formalSubdivision center n)^[j] c) := by
+  simp only [formalSubdivisionIteratedHomotopy, LinearMap.sum_apply, LinearMap.comp_apply,
+    Module.End.pow_apply]
+
+@[simp]
+private theorem SingularMayerVietoris.formalSubdivisionIteratedHomotopy_zero {V : Type*}
+    (center : FormalCenter V) (n : ℕ) (c : FormalChains V n) :
+    formalSubdivisionIteratedHomotopy center 0 n c = 0 := by
+  simp [formalSubdivisionIteratedHomotopy]
+
+private theorem SingularMayerVietoris.formalSubdivisionIteratedHomotopy_succ {V : Type*}
+    (center : FormalCenter V) (k n : ℕ) (c : FormalChains V n) :
+    formalSubdivisionIteratedHomotopy center (k + 1) n c =
+      formalSubdivisionIteratedHomotopy center k n c +
+        formalSubdivisionHomotopy center n ((formalSubdivision center n)^[k] c) := by
+  simp only [formalSubdivisionIteratedHomotopy_apply, Finset.sum_range_succ]
+
+@[simp]
+private theorem SingularMayerVietoris.formalSubdivisionIteratedHomotopy_degree_zero {V : Type*}
+    (center : FormalCenter V) (k : ℕ) (c : FormalChains V 0) :
+    formalSubdivisionIteratedHomotopy center k 0 c = 0 := by
+  simp [formalSubdivisionIteratedHomotopy_apply]
+
+private theorem SingularMayerVietoris.formalSubdivisionIteratedHomotopy_boundary {V : Type*}
+    (center : FormalCenter V) (k n : ℕ) (c : FormalChains V (n + 1)) :
+    formalBoundary (n + 1) (formalSubdivisionIteratedHomotopy center k (n + 1) c) +
+        formalSubdivisionIteratedHomotopy center k n (formalBoundary n c) =
+      c - (formalSubdivision center (n + 1))^[k] c := by
+  induction k with
+  | zero => simp
+  | succ k
+    ih =>
+    rw [formalSubdivisionIteratedHomotopy_succ, formalSubdivisionIteratedHomotopy_succ, map_add]
+    have hh :=
+      formalSubdivisionHomotopy_boundary center n ((formalSubdivision center (n + 1))^[k] c)
+    rw [formalBoundary_subdivision_iterate] at hh
+    calc
+      _ =
+          (formalBoundary (n + 1) (formalSubdivisionIteratedHomotopy center k (n + 1) c) +
+              formalSubdivisionIteratedHomotopy center k n (formalBoundary n c)) +
+            (formalBoundary (n + 1)
+                (formalSubdivisionHomotopy center (n + 1)
+                  ((formalSubdivision center (n + 1))^[k] c)) +
+              formalSubdivisionHomotopy center n
+                ((formalSubdivision center n)^[k] (formalBoundary n c))) := by abel
+      _ =
+          (c - (formalSubdivision center (n + 1))^[k] c) +
+            ((formalSubdivision center (n + 1))^[k] c -
+              formalSubdivision center (n + 1) ((formalSubdivision center (n + 1))^[k] c)) := by
+        rw [ih, hh]
+      _ = c - (formalSubdivision center (n + 1))^[k + 1] c := by
+        rw [Function.iterate_succ_apply']
+        abel
+
+private theorem SingularMayerVietoris.formalMap_subdivisionIteratedHomotopy {V W : Type*}
+    (center : FormalCenter V) (center' : FormalCenter W) (f : V → W)
+    (hf : ∀ n v, f (center n v) = center' n (f ∘ v)) (k n : ℕ) (c : FormalChains V n) :
+    formalMap f (n + 1) (formalSubdivisionIteratedHomotopy center k n c) =
+      formalSubdivisionIteratedHomotopy center' k n (formalMap f n c) := by
+  simp only [formalSubdivisionIteratedHomotopy_apply, map_sum]
+  apply Finset.sum_congr rfl
+  intro j hj
+  rw [formalMap_subdivisionHomotopy center center' f hf,
+    formalMap_subdivision_iterate center center' f hf]
+
+private def SingularMayerVietoris.subdivision (X : Type) [TopologicalSpace X] (k n : ℕ) :
+    FirstHurewicz.Chains X n →ₗ[ℤ] FirstHurewicz.Chains X n :=
+  FirstHurewicz.chainLift X n fun σ =>
+    FirstHurewicz.inducedChain σ n
+      (affineChainMap n n
+        ((formalSubdivision (simplexCenter n) (n + 1))^[k] (formalSimplex (stdVertices n))))
+
+@[simp]
+private theorem SingularMayerVietoris.subdivision_simplex (X : Type) [TopologicalSpace X] (k n : ℕ)
+    (σ : FirstHurewicz.SingularSimplex X n) :
+    subdivision X k n (FirstHurewicz.simplexChain X n σ) =
+      FirstHurewicz.inducedChain σ n
+        (affineChainMap n n
+          ((formalSubdivision (simplexCenter n) (n + 1))^[k] (formalSimplex (stdVertices n)))) :=
+  FirstHurewicz.chainLift_simplex X n _ σ
+
+private theorem SingularMayerVietoris.inducedChain_subdivision {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (k n : ℕ) (c : FirstHurewicz.Chains X n) :
+    FirstHurewicz.inducedChain f n (subdivision X k n c) =
+      subdivision Y k n (FirstHurewicz.inducedChain f n c) := by
+  have h :
+    (FirstHurewicz.inducedChain f n).comp (subdivision X k n) =
+      (subdivision Y k n).comp (FirstHurewicz.inducedChain f n) := by
+    apply FirstHurewicz.chainMap_ext X n
+    intro σ
+    simp only [LinearMap.comp_apply, subdivision_simplex, FirstHurewicz.inducedChain_simplex]
+    rw [FirstHurewicz.inducedChain_comp]
+    rfl
+  exact LinearMap.congr_fun h c
+
+private theorem SingularMayerVietoris.affineSimplex_comp_stdVertices {n p : ℕ}
+    (v : Fin (n + 1) → FirstHurewicz.Simplex p) : affineSimplex v ∘ stdVertices n = v := by
+  funext i
+  exact affineSimplex_vertex v i
+
+private theorem SingularMayerVietoris.subdivision_affineChainMap (p k n : ℕ)
+    (c : FormalChains (FirstHurewicz.Simplex p) (n + 1)) :
+    subdivision (FirstHurewicz.Simplex p) k n (affineChainMap p n c) =
+      affineChainMap p n ((formalSubdivision (simplexCenter p) (n + 1))^[k] c) := by
+  have h :
+    (subdivision (FirstHurewicz.Simplex p) k n).comp (affineChainMap p n) =
+      (affineChainMap p n).comp ((formalSubdivision (simplexCenter p) (n + 1)) ^ k) := by
+    apply formalChains_ext
+    intro v
+    simp only [LinearMap.comp_apply, affineChainMap_simplex, subdivision_simplex,
+      Module.End.pow_apply]
+    rw [inducedChain_affineChainMap,
+      formalMap_subdivision_iterate (simplexCenter n) (simplexCenter p) (affineSimplex v)
+        (affineSimplex_preserves_center v),
+      formalMap_simplex, affineSimplex_comp_stdVertices]
+  simpa only [LinearMap.comp_apply, Module.End.pow_apply] using LinearMap.congr_fun h c
+
+private theorem SingularMayerVietoris.subdivision_boundary {X : Type} [TopologicalSpace X] (k n : ℕ)
+    (c : FirstHurewicz.Chains X (n + 1)) :
+    ((FirstHurewicz.singularComplex X).d (n + 1) n).hom (subdivision X k (n + 1) c) =
+      subdivision X k n (((FirstHurewicz.singularComplex X).d (n + 1) n).hom c) := by
+  have h :
+    (((FirstHurewicz.singularComplex X).d (n + 1) n).hom).comp (subdivision X k (n + 1)) =
+      (subdivision X k n).comp ((FirstHurewicz.singularComplex X).d (n + 1) n).hom := by
+    apply FirstHurewicz.chainMap_ext X (n + 1)
+    intro σ
+    change
+      ((FirstHurewicz.singularComplex X).d (n + 1) n).hom
+          (subdivision X k (n + 1) (FirstHurewicz.simplexChain X (n + 1) σ)) =
+        _
+    rw [subdivision_simplex, ← FirstHurewicz.inducedChain_boundary, affineChainMap_boundary,
+      formalBoundary_subdivision_iterate, ← subdivision_affineChainMap, inducedChain_subdivision,
+      ← affineChainMap_boundary, FirstHurewicz.inducedChain_boundary, affineChainMap_stdVertices,
+      FirstHurewicz.inducedChain_simplex, ContinuousMap.comp_id]
+    rfl
+  exact LinearMap.congr_fun h c
+
+private def SingularMayerVietoris.subdivisionHomotopy (X : Type) [TopologicalSpace X] (k n : ℕ) :
+    FirstHurewicz.Chains X n →ₗ[ℤ] FirstHurewicz.Chains X (n + 1) :=
+  FirstHurewicz.chainLift X n fun σ =>
+    FirstHurewicz.inducedChain σ (n + 1)
+      (affineChainMap n (n + 1)
+        (formalSubdivisionIteratedHomotopy (simplexCenter n) k (n + 1)
+          (formalSimplex (stdVertices n))))
+
+@[simp]
+private theorem SingularMayerVietoris.subdivisionHomotopy_simplex (X : Type) [TopologicalSpace X]
+    (k n : ℕ) (σ : FirstHurewicz.SingularSimplex X n) :
+    subdivisionHomotopy X k n (FirstHurewicz.simplexChain X n σ) =
+      FirstHurewicz.inducedChain σ (n + 1)
+        (affineChainMap n (n + 1)
+          (formalSubdivisionIteratedHomotopy (simplexCenter n) k (n + 1)
+            (formalSimplex (stdVertices n)))) :=
+  FirstHurewicz.chainLift_simplex X n _ σ
+
+private theorem
+    SingularMayerVietoris.inducedChain_subdivisionHomotopy {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (k n : ℕ) (c : FirstHurewicz.Chains X n) :
+    FirstHurewicz.inducedChain f (n + 1) (subdivisionHomotopy X k n c) =
+      subdivisionHomotopy Y k n (FirstHurewicz.inducedChain f n c) := by
+  have h :
+    (FirstHurewicz.inducedChain f (n + 1)).comp (subdivisionHomotopy X k n) =
+      (subdivisionHomotopy Y k n).comp (FirstHurewicz.inducedChain f n) := by
+    apply FirstHurewicz.chainMap_ext X n
+    intro σ
+    simp only [LinearMap.comp_apply, subdivisionHomotopy_simplex,
+      FirstHurewicz.inducedChain_simplex]
+    rw [FirstHurewicz.inducedChain_comp]
+    rfl
+  exact LinearMap.congr_fun h c
+
+private theorem SingularMayerVietoris.subdivisionHomotopy_affineChainMap (p k n : ℕ)
+    (c : FormalChains (FirstHurewicz.Simplex p) (n + 1)) :
+    subdivisionHomotopy (FirstHurewicz.Simplex p) k n (affineChainMap p n c) =
+      affineChainMap p (n + 1)
+        (formalSubdivisionIteratedHomotopy (simplexCenter p) k (n + 1) c) := by
+  have h :
+    (subdivisionHomotopy (FirstHurewicz.Simplex p) k n).comp (affineChainMap p n) =
+      (affineChainMap p (n + 1)).comp
+        (formalSubdivisionIteratedHomotopy (simplexCenter p) k (n + 1)) := by
+    apply formalChains_ext
+    intro v
+    simp only [LinearMap.comp_apply, affineChainMap_simplex, subdivisionHomotopy_simplex]
+    rw [inducedChain_affineChainMap,
+      formalMap_subdivisionIteratedHomotopy (simplexCenter n) (simplexCenter p) (affineSimplex v)
+        (affineSimplex_preserves_center v),
+      formalMap_simplex, affineSimplex_comp_stdVertices]
+  exact LinearMap.congr_fun h c
+
+private theorem SingularMayerVietoris.subdivisionHomotopy_boundary_zero_affineChainMap (p k : ℕ)
+    (c : FormalChains (FirstHurewicz.Simplex p) 1) :
+    ((FirstHurewicz.singularComplex (FirstHurewicz.Simplex p)).d 1 0).hom
+        (subdivisionHomotopy (FirstHurewicz.Simplex p) k 0 (affineChainMap p 0 c)) =
+      affineChainMap p 0 c - subdivision (FirstHurewicz.Simplex p) k 0 (affineChainMap p 0 c) := by
+  rw [subdivisionHomotopy_affineChainMap, affineChainMap_boundary, subdivision_affineChainMap, ←
+    map_sub]
+  apply congrArg (affineChainMap p 0)
+  simpa only [formalSubdivisionIteratedHomotopy_degree_zero, add_zero] using
+    formalSubdivisionIteratedHomotopy_boundary (simplexCenter p) k 0 c
+
+private theorem SingularMayerVietoris.subdivisionHomotopy_boundary_affineChainMap (p k n : ℕ)
+    (c : FormalChains (FirstHurewicz.Simplex p) (n + 2)) :
+    ((FirstHurewicz.singularComplex (FirstHurewicz.Simplex p)).d (n + 2) (n + 1)).hom
+          (subdivisionHomotopy (FirstHurewicz.Simplex p) k (n + 1) (affineChainMap p (n + 1) c)) +
+        subdivisionHomotopy (FirstHurewicz.Simplex p) k n
+          (((FirstHurewicz.singularComplex (FirstHurewicz.Simplex p)).d (n + 1) n).hom
+            (affineChainMap p (n + 1) c)) =
+      affineChainMap p (n + 1) c -
+        subdivision (FirstHurewicz.Simplex p) k (n + 1) (affineChainMap p (n + 1) c) := by
+  rw [subdivisionHomotopy_affineChainMap, affineChainMap_boundary, affineChainMap_boundary,
+    subdivisionHomotopy_affineChainMap, subdivision_affineChainMap, ← map_add, ← map_sub]
+  exact
+    congrArg (affineChainMap p (n + 1))
+      (formalSubdivisionIteratedHomotopy_boundary (simplexCenter p) k (n + 1) c)
+
+private theorem
+    SingularMayerVietoris.subdivisionHomotopy_boundary_zero {X : Type} [TopologicalSpace X]
+    (k : ℕ) (c : FirstHurewicz.Chains X 0) :
+    ((FirstHurewicz.singularComplex X).d 1 0).hom (subdivisionHomotopy X k 0 c) =
+      c - subdivision X k 0 c := by
+  have h :
+    (((FirstHurewicz.singularComplex X).d 1 0).hom).comp (subdivisionHomotopy X k 0) =
+      LinearMap.id - subdivision X k 0 := by
+    apply FirstHurewicz.chainMap_ext X 0
+    intro σ
+    have hstd :=
+      subdivisionHomotopy_boundary_zero_affineChainMap 0 k (formalSimplex (stdVertices 0))
+    have hσ := congrArg (FirstHurewicz.inducedChain σ 0) hstd
+    simpa only [map_sub, FirstHurewicz.inducedChain_boundary, inducedChain_subdivisionHomotopy,
+      inducedChain_subdivision, affineChainMap_stdVertices, FirstHurewicz.inducedChain_simplex,
+      ContinuousMap.comp_id, LinearMap.comp_apply, LinearMap.sub_apply, LinearMap.id_apply] using
+      hσ
+  exact LinearMap.congr_fun h c
+
+private theorem SingularMayerVietoris.subdivisionHomotopy_boundary {X : Type} [TopologicalSpace X]
+    (k n : ℕ) (c : FirstHurewicz.Chains X (n + 1)) :
+    ((FirstHurewicz.singularComplex X).d (n + 2) (n + 1)).hom
+          (subdivisionHomotopy X k (n + 1) c) +
+        subdivisionHomotopy X k n (((FirstHurewicz.singularComplex X).d (n + 1) n).hom c) =
+      c - subdivision X k (n + 1) c := by
+  have h :
+    (((FirstHurewicz.singularComplex X).d (n + 2) (n + 1)).hom).comp
+          (subdivisionHomotopy X k (n + 1)) +
+        (subdivisionHomotopy X k n).comp (((FirstHurewicz.singularComplex X).d (n + 1) n).hom) =
+      LinearMap.id - subdivision X k (n + 1) := by
+    apply FirstHurewicz.chainMap_ext X (n + 1)
+    intro σ
+    have hstd :=
+      subdivisionHomotopy_boundary_affineChainMap (n + 1) k n
+        (formalSimplex (stdVertices (n + 1)))
+    have hσ := congrArg (FirstHurewicz.inducedChain σ (n + 1)) hstd
+    simpa only [map_add, map_sub, FirstHurewicz.inducedChain_boundary,
+      inducedChain_subdivisionHomotopy, inducedChain_subdivision, affineChainMap_stdVertices,
+      FirstHurewicz.inducedChain_simplex, ContinuousMap.comp_id, LinearMap.comp_apply,
+      LinearMap.add_apply, LinearMap.sub_apply, LinearMap.id_apply] using hσ
+  exact LinearMap.congr_fun h c
+
+private theorem SingularMayerVietoris.subdivisionHomotopy_boundary_of_cycle {X : Type}
+    [TopologicalSpace X] (k n : ℕ) (c : FirstHurewicz.Chains X n)
+    (hc : ((FirstHurewicz.singularComplex X).d n (n - 1)).hom c = 0) :
+    ((FirstHurewicz.singularComplex X).d (n + 1) n).hom (subdivisionHomotopy X k n c) =
+      c - subdivision X k n c := by
+  cases n with
+  | zero => exact subdivisionHomotopy_boundary_zero k c
+  | succ
+    n =>
+    have hc' : ((FirstHurewicz.singularComplex X).d (n + 1) n).hom c = 0 := by
+      simpa only [Nat.succ_sub_one] using hc
+    simpa only [hc', map_zero, add_zero] using subdivisionHomotopy_boundary k n c
+
+/-- The submodule of formal chains whose vertices lie in a specified set. -/
+public
+def SingularMayerVietoris.formalChainsSupported {V : Type*} (S : Set V) (n : ℕ) :
+    Submodule ℤ (FormalChains V n) :=
+  Finsupp.supported ℤ ℤ {v | ∀ i, v i ∈ S}
+
+private theorem SingularMayerVietoris.mem_formalChainsSupported_iff {V : Type*} {n : ℕ} {S : Set V}
+    {c : FormalChains V n} : c ∈ formalChainsSupported S n ↔ ∀ v ∈ c.support, ∀ i, v i ∈ S :=
+  Iff.rfl
+
+private theorem SingularMayerVietoris.formalChainsSupported_mono {V : Type*} {n : ℕ} {S T : Set V}
+    (h : S ⊆ T) : formalChainsSupported S n ≤ formalChainsSupported T n := by
+  intro c hc v hv i
+  exact h (hc hv i)
+
+@[simp]
+private theorem SingularMayerVietoris.formalChainsSupported_univ {V : Type*} (n : ℕ) :
+    formalChainsSupported (Set.univ : Set V) n = ⊤ := by
+  apply top_unique
+  intro c _ v hv i
+  exact Set.mem_univ _
+
+@[simp]
+private theorem
+    SingularMayerVietoris.formalSimplex_mem_supported_iff {V : Type*} {n : ℕ} {S : Set V}
+    (v : Fin n → V) : formalSimplex v ∈ formalChainsSupported S n ↔ ∀ i, v i ∈ S := by
+  classical simp [formalSimplex, formalChainsSupported, Finsupp.mem_supported]
+
+private theorem SingularMayerVietoris.formalSimplex_mem_supported {V : Type*} {n : ℕ} {S : Set V}
+    {v : Fin n → V} (hv : ∀ i, v i ∈ S) : formalSimplex v ∈ formalChainsSupported S n :=
+  (formalSimplex_mem_supported_iff v).mpr hv
+
+private theorem SingularMayerVietoris.formalChainsSupported_le {V : Type*} {n : ℕ} {S : Set V}
+    {P : Submodule ℤ (FormalChains V n)} (h : ∀ v, (∀ i, v i ∈ S) → formalSimplex v ∈ P) :
+    formalChainsSupported S n ≤ P := by
+  rw [formalChainsSupported, Finsupp.supported_eq_span_single]
+  apply Submodule.span_le.mpr
+  rintro _ ⟨v, hv, rfl⟩
+  exact h v hv
+
+private theorem SingularMayerVietoris.formalLinearMap_mem_of_supported {V M : Type*} {n : ℕ}
+    [AddCommGroup M] [Module ℤ M] {S : Set V} (f : FormalChains V n →ₗ[ℤ] M) (P : Submodule ℤ M)
+    {c : FormalChains V n} (hc : c ∈ formalChainsSupported S n)
+    (h : ∀ v, (∀ i, v i ∈ S) → f (formalSimplex v) ∈ P) : f c ∈ P := by
+  exact (formalChainsSupported_le (P := P.comap f) h) hc
+
+private theorem SingularMayerVietoris.formalBoundary_mem_supported {V : Type*} {S : Set V} (n : ℕ)
+    {c : FormalChains V (n + 1)} (hc : c ∈ formalChainsSupported S (n + 1)) :
+    formalBoundary n c ∈ formalChainsSupported S n := by
+  apply formalLinearMap_mem_of_supported (formalBoundary n) (formalChainsSupported S n) hc
+  intro v hv
+  rw [formalBoundary_simplex]
+  apply Submodule.sum_mem
+  intro i hi
+  apply Submodule.smul_mem
+  exact formalSimplex_mem_supported fun j => hv (i.succAbove j)
+
+private theorem
+    SingularMayerVietoris.formalCone_mem_supported {V : Type*} {n : ℕ} {S : Set V} {a : V}
+    (ha : a ∈ S) {c : FormalChains V n} (hc : c ∈ formalChainsSupported S n) :
+    formalCone a n c ∈ formalChainsSupported S (n + 1) := by
+  apply formalLinearMap_mem_of_supported (formalCone a n) (formalChainsSupported S (n + 1)) hc
+  intro v hv
+  rw [formalCone_simplex]
+  apply formalSimplex_mem_supported
+  intro i
+  exact Fin.cases ha hv i
+
+private theorem SingularMayerVietoris.formalMap_mem_supported {V W : Type*} {n : ℕ} {S : Set V}
+    {T : Set W} (f : V → W) (hf : Set.MapsTo f S T) {c : FormalChains V n}
+    (hc : c ∈ formalChainsSupported S n) : formalMap f n c ∈ formalChainsSupported T n := by
+  apply formalLinearMap_mem_of_supported (formalMap f n) (formalChainsSupported T n) hc
+  intro v hv
+  rw [formalMap_simplex]
+  exact formalSimplex_mem_supported fun i => hf (hv i)
+
+private theorem SingularMayerVietoris.formalSubdivision_mem_supported {V : Type*}
+    (center : FormalCenter V) {S : Set V} (hcenter : ∀ k v, (∀ i, v i ∈ S) → center k v ∈ S) :
+    ∀ (n : ℕ) {c : FormalChains V n},
+      c ∈ formalChainsSupported S n → formalSubdivision center n c ∈ formalChainsSupported S n := by
+  intro n
+  induction n with
+  | zero =>
+    intro c hc
+    exact hc
+  | succ n ih =>
+    intro c hc
+    apply
+      formalLinearMap_mem_of_supported (formalSubdivision center (n + 1))
+        (formalChainsSupported S (n + 1)) hc
+    intro v hv
+    rw [formalSubdivision_simplex_succ]
+    exact
+      formalCone_mem_supported (hcenter n v hv)
+        (ih (formalBoundary_mem_supported n (formalSimplex_mem_supported hv)))
+
+private theorem SingularMayerVietoris.formalCone_support_exists {V : Type*} {n : ℕ} (a : V)
+    {c : FormalChains V n} {w : Fin (n + 1) → V} (hw : w ∈ (formalCone a n c).support) :
+    ∃ v ∈ c.support, w = Fin.cons a v := by
+  classical
+  change w ∈ (Finsupp.mapDomain (Fin.cons a) c).support at hw
+  obtain ⟨v, hv, heq⟩ := Finset.mem_image.mp (Finsupp.mapDomain_support hw)
+  exact ⟨v, hv, heq.symm⟩
+
+private theorem SingularMayerVietoris.formalLift_support_exists {V W : Type*} {n : ℕ} {m : ℕ}
+    (f : (Fin n → V) → FormalChains W m) {c : FormalChains V n} {w : Fin m → W}
+    (hw : w ∈ (formalLift f c).support) : ∃ v ∈ c.support, w ∈ (f v).support := by
+  classical
+  change w ∈ (c.sum fun v z => z • f v).support at hw
+  obtain ⟨v, hv, hterm⟩ := Finset.mem_biUnion.mp (Finsupp.support_sum hw)
+  exact ⟨v, hv, Finsupp.support_smul hterm⟩
+
+private theorem SingularMayerVietoris.formalLinearMap_support_exists {V W : Type*} {n : ℕ} {m : ℕ}
+    (f : FormalChains V n →ₗ[ℤ] FormalChains W m) {c : FormalChains V n} {w : Fin m → W}
+    (hw : w ∈ (f c).support) : ∃ v ∈ c.support, w ∈ (f (formalSimplex v)).support := by
+  have hf : f = formalLift (fun v => f (formalSimplex v)) := by
+    apply formalChains_ext
+    intro v
+    simp only [formalLift_simplex]
+  rw [hf] at hw
+  exact formalLift_support_exists _ hw
+
+private theorem SingularMayerVietoris.formalBoundary_support_exists {V : Type*} (n : ℕ)
+    (v : Fin (n + 1) → V) {w : Fin n → V}
+    (hw : w ∈ (formalBoundary n (formalSimplex v)).support) :
+    ∃ i : Fin (n + 1), w = v ∘ i.succAbove := by
+  classical
+  rw [formalBoundary_simplex] at hw
+  obtain ⟨i, hi, hterm⟩ := Finset.mem_biUnion.mp (Finsupp.support_finsetSum hw)
+  refine ⟨i, ?_⟩
+  have hs : w ∈ (formalSimplex (v ∘ i.succAbove)).support := Finsupp.support_smul hterm
+  simpa [formalSimplex] using hs
+
+private theorem SingularMayerVietoris.formalLinearMap_mem_of_support {V M : Type*} [AddCommGroup M]
+    [Module ℤ M] {n : ℕ} (f : FormalChains V n →ₗ[ℤ] M) (P : Submodule ℤ M) (c : FormalChains V n)
+    (hf : ∀ v ∈ c.support, f (formalSimplex v) ∈ P) : f c ∈ P := by
+  have h : Finsupp.supported ℤ ℤ (c.support : Set (Fin n → V)) ≤ P.comap f := by
+    rw [Finsupp.supported_eq_span_single]
+    apply Submodule.span_le.mpr
+    rintro _ ⟨v, hv, rfl⟩
+    exact hf v hv
+  exact h (fun _ hv => hv)
+
+private theorem SingularMayerVietoris.singularLinearMap_mem_of_support {M : Type*} [AddCommGroup M]
+    [Module ℤ M] {X : Type} [TopologicalSpace X] (n : ℕ) (f : FirstHurewicz.Chains X n →ₗ[ℤ] M)
+    (P : Submodule ℤ M) (c : FirstHurewicz.Chains X n)
+    (hf :
+      ∀ σ ∈ (FirstHurewicz.chainsEquivFinsupp X n c).support,
+        f (FirstHurewicz.simplexChain X n σ) ∈ P) :
+    f c ∈ P := by
+  let S : Set (FirstHurewicz.SingularSimplex X n) :=
+    (FirstHurewicz.chainsEquivFinsupp X n c).support
+  have hc : c ∈ Submodule.span ℤ (FirstHurewicz.simplexChain X n '' S) :=
+    (FirstHurewicz.mem_simplex_span_iff X n S c).mpr (Set.Subset.refl _)
+  have h : Submodule.span ℤ (FirstHurewicz.simplexChain X n '' S) ≤ P.comap f := by
+    apply Submodule.span_le.mpr
+    rintro _ ⟨σ, hσ, rfl⟩
+    exact hf σ hσ
+  exact h hc
+
+private theorem SingularMayerVietoris.singularLinearMap_mem_of_small {M : Type*} [AddCommGroup M]
+    [Module ℤ M] {X : Type} [TopologicalSpace X] (U V : Set X) (n : ℕ)
+    (f : FirstHurewicz.Chains X n →ₗ[ℤ] M) (P : Submodule ℤ M) (c : FirstHurewicz.Chains X n)
+    (hc : c ∈ smallChainSubmodule U V n)
+    (hf :
+      ∀ σ : FirstHurewicz.SingularSimplex X n,
+        (Set.range σ ⊆ U ∨ Set.range σ ⊆ V) → f (FirstHurewicz.simplexChain X n σ) ∈ P) :
+    f c ∈ P := by
+  have h : smallChainSubmodule U V n ≤ P.comap f := by
+    rw [smallChainSubmodule_eq_span]
+    apply Submodule.span_le.mpr
+    rintro _ ⟨σ, hσ, rfl⟩
+    exact hf σ hσ
+  exact h hc
+
+private theorem SingularMayerVietoris.realizedChain_mem_supported {X : Type} [TopologicalSpace X]
+    (U : Set X) (p n : ℕ) (σ : C(FirstHurewicz.Simplex p, X)) (hσ : Set.range σ ⊆ U)
+    (c : FormalChains (FirstHurewicz.Simplex p) (n + 1)) :
+    FirstHurewicz.inducedChain σ n (affineChainMap p n c) ∈ supportedChainSubmodule U n := by
+  apply
+    formalLinearMap_mem_of_support ((FirstHurewicz.inducedChain σ n).comp (affineChainMap p n))
+      (supportedChainSubmodule U n) c
+  intro v hv
+  simp only [LinearMap.comp_apply, affineChainMap_simplex, FirstHurewicz.inducedChain_simplex]
+  apply simplexChain_mem_supported
+  rintro x ⟨t, rfl⟩
+  exact hσ ⟨affineSimplex v t, rfl⟩
+
+private theorem SingularMayerVietoris.realizedChain_mem_small {X : Type} [TopologicalSpace X]
+    (U V : Set X) (p n : ℕ) (σ : C(FirstHurewicz.Simplex p, X))
+    (hσ : Set.range σ ⊆ U ∨ Set.range σ ⊆ V)
+    (c : FormalChains (FirstHurewicz.Simplex p) (n + 1)) :
+    FirstHurewicz.inducedChain σ n (affineChainMap p n c) ∈ smallChainSubmodule U V n := by
+  rcases hσ with hσ | hσ
+  · exact
+      (le_sup_left : supportedChainSubmodule U n ≤ smallChainSubmodule U V n)
+        (realizedChain_mem_supported U p n σ hσ c)
+  · exact
+      (le_sup_right : supportedChainSubmodule V n ≤ smallChainSubmodule U V n)
+        (realizedChain_mem_supported V p n σ hσ c)
+
+private theorem
+    SingularMayerVietoris.realizedChain_mem_small_of_support {X : Type} [TopologicalSpace X]
+    (U V : Set X) (p n : ℕ) (σ : C(FirstHurewicz.Simplex p, X))
+    (c : FormalChains (FirstHurewicz.Simplex p) (n + 1))
+    (hc :
+      ∀ v ∈ c.support,
+        Set.range (σ.comp (affineSimplex v)) ⊆ U ∨ Set.range (σ.comp (affineSimplex v)) ⊆ V) :
+    FirstHurewicz.inducedChain σ n (affineChainMap p n c) ∈ smallChainSubmodule U V n := by
+  apply
+    formalLinearMap_mem_of_support ((FirstHurewicz.inducedChain σ n).comp (affineChainMap p n))
+      (smallChainSubmodule U V n) c
+  intro v hv
+  simp only [LinearMap.comp_apply, affineChainMap_simplex, FirstHurewicz.inducedChain_simplex]
+  exact simplexChain_mem_small U V n (σ.comp (affineSimplex v)) (hc v hv)
+
+private def SingularMayerVietoris.vertexBarycenter {E : Type*} [SeminormedAddCommGroup E]
+    [NormedSpace ℝ E] {n : ℕ} (v : Fin (n + 1) → E) : E :=
+  (1 / ((n : ℝ) + 1)) • ∑ i, v i
+
+private theorem SingularMayerVietoris.vertexBarycenter_mem_of_convex {E : Type*}
+    [SeminormedAddCommGroup E] [NormedSpace ℝ E] {n : ℕ} (v : Fin (n + 1) → E) {s : Set E}
+    (hs : Convex ℝ s) (hv : ∀ i, v i ∈ s) : vertexBarycenter v ∈ s := by
+  simpa [vertexBarycenter, Finset.centerMass, Nat.cast_add, Nat.cast_one, one_div] using
+    hs.centerMass_mem (t := Finset.univ) (w := fun _ : Fin (n + 1) => (1 : ℝ)) (z := v)
+      (by intro i hi; exact zero_le_one)
+      (by simpa using (Nat.cast_pos.mpr (Nat.succ_pos n) : (0 : ℝ) < ((n + 1 : ℕ) : ℝ)))
+      (by intro i hi; exact hv i)
+
+private theorem SingularMayerVietoris.vertexBarycenter_sub {E : Type*} [SeminormedAddCommGroup E]
+    [NormedSpace ℝ E] {n : ℕ} (v : Fin (n + 1) → E) (x : E) :
+    vertexBarycenter v - x = (1 / ((n : ℝ) + 1)) • ∑ i, (v i - x) := by
+  have hn : (n : ℝ) + 1 ≠ 0 := by positivity
+  simp only [vertexBarycenter, Finset.sum_sub_distrib, Finset.sum_const, Finset.card_univ,
+    Fintype.card_fin, smul_sub]
+  rw [← Nat.cast_smul_eq_nsmul ℝ, smul_smul]
+  simp [hn]
+
+private theorem SingularMayerVietoris.sum_norm_vertex_sub_le {E : Type*} [SeminormedAddCommGroup E]
+    {n : ℕ} (v : Fin (n + 1) → E) {D : ℝ} (hpair : ∀ i j, Dist.dist (v i) (v j) ≤ D)
+    (j : Fin (n + 1)) : (∑ i, ‖v i - v j‖) ≤ (n : ℝ) * D := by
+  calc
+    (∑ i, ‖v i - v j‖) = ∑ i ∈ Finset.univ.erase j, ‖v i - v j‖ := by
+      simpa only [sub_self, norm_zero, add_zero] using
+        (Finset.sum_erase_add Finset.univ (fun i => ‖v i - v j‖) (Finset.mem_univ j)).symm
+    _ ≤ ∑ _i ∈ Finset.univ.erase j, D := by
+      apply Finset.sum_le_sum
+      intro i _hi
+      simpa only [dist_eq_norm] using hpair i j
+    _ = (n : ℝ) * D := by simp
+
+private theorem SingularMayerVietoris.dist_vertexBarycenter_vertex_le {E : Type*}
+    [SeminormedAddCommGroup E] [NormedSpace ℝ E] {n : ℕ} (v : Fin (n + 1) → E) {D : ℝ}
+    (hpair : ∀ i j, Dist.dist (v i) (v j) ≤ D) (j : Fin (n + 1)) :
+    Dist.dist (vertexBarycenter v) (v j) ≤ (n : ℝ) / ((n : ℝ) + 1) * D := by
+  have hc : 0 ≤ 1 / ((n : ℝ) + 1) := by positivity
+  rw [dist_eq_norm, vertexBarycenter_sub, norm_smul, Real.norm_of_nonneg hc]
+  calc
+    _ ≤ (1 / ((n : ℝ) + 1)) * ∑ i, ‖v i - v j‖ := mul_le_mul_of_nonneg_left (norm_sum_le _ _) hc
+    _ ≤ (1 / ((n : ℝ) + 1)) * ((n : ℝ) * D) :=
+      (mul_le_mul_of_nonneg_left (sum_norm_vertex_sub_le v hpair j) hc)
+    _ = (n : ℝ) / ((n : ℝ) + 1) * D := by ring
+
+private theorem SingularMayerVietoris.dist_vertexBarycenter_convexHull_le {E : Type*}
+    [SeminormedAddCommGroup E] [NormedSpace ℝ E] {n : ℕ} (v : Fin (n + 1) → E) {D : ℝ}
+    (hpair : ∀ i j, Dist.dist (v i) (v j) ≤ D) {x : E} (hx : x ∈ convexHull ℝ (Set.range v)) :
+    Dist.dist (vertexBarycenter v) x ≤ (n : ℝ) / ((n : ℝ) + 1) * D := by
+  have hball :
+    Set.range v ⊆ Metric.closedBall (vertexBarycenter v) ((n : ℝ) / ((n : ℝ) + 1) * D) := by
+    rintro _ ⟨j, rfl⟩
+    rw [Metric.mem_closedBall, dist_comm]
+    exact dist_vertexBarycenter_vertex_le v hpair j
+  have h := convexHull_min hball (convex_closedBall _ _) hx
+  simpa only [Metric.mem_closedBall, dist_comm] using h
+
+private theorem
+    SingularMayerVietoris.dist_convexHull_range_le {E : Type*} [SeminormedAddCommGroup E]
+    [NormedSpace ℝ E] {n : ℕ} (v : Fin (n + 1) → E) {D : ℝ}
+    (hpair : ∀ i j, Dist.dist (v i) (v j) ≤ D) {x y : E} (hx : x ∈ convexHull ℝ (Set.range v))
+    (hy : y ∈ convexHull ℝ (Set.range v)) : Dist.dist x y ≤ D := by
+  obtain ⟨_, ⟨i, rfl⟩, _, ⟨j, rfl⟩, h⟩ := convexHull_exists_dist_ge2 hx hy
+  exact h.trans (hpair i j)
+
+private theorem SingularMayerVietoris.exists_lebesgue_number_two_pairwise {K X : Type*}
+    [PseudoMetricSpace K] [CompactSpace K] [TopologicalSpace X] (σ : C(K, X)) {U V : Set X}
+    (hU : IsOpen U) (hV : IsOpen V) (hcover : Set.range σ ⊆ U ∪ V) :
+    ∃ δ > 0, ∀ s : Set K, (∀ x ∈ s, ∀ y ∈ s, Dist.dist x y ≤ δ) → σ '' s ⊆ U ∨ σ '' s ⊆ V := by
+  let W : Bool → Set K := fun b => if b then σ ⁻¹' U else σ ⁻¹' V
+  have hW : ∀ b, IsOpen (W b) := by
+    intro b
+    cases b
+    · exact hV.preimage σ.continuous
+    · exact hU.preimage σ.continuous
+  have hWcover : (Set.univ : Set K) ⊆ ⋃ b, W b := by
+    intro x _
+    rcases hcover ⟨x, rfl⟩ with hx | hx
+    · exact Set.mem_iUnion.mpr ⟨Bool.true, hx⟩
+    · exact Set.mem_iUnion.mpr ⟨Bool.false, hx⟩
+  obtain ⟨ε, hε, hball⟩ := lebesgue_number_lemma_of_metric isCompact_univ hW hWcover
+  refine ⟨ε / 2, half_pos hε, ?_⟩
+  intro s hdist
+  by_cases hs : s.Nonempty
+  · obtain ⟨x, hx⟩ := hs
+    obtain ⟨b, hb⟩ := hball x (Set.mem_univ x)
+    have hsub : s ⊆ Metric.ball x ε := by
+      intro y hy
+      exact (hdist y hy x hx).trans_lt (half_lt_self hε)
+    cases b
+    · right
+      rintro _ ⟨y, hy, rfl⟩
+      exact hb (hsub hy)
+    · left
+      rintro _ ⟨y, hy, rfl⟩
+      exact hb (hsub hy)
+  · left
+    rw [Set.not_nonempty_iff_eq_empty.mp hs, Set.image_empty]
+    exact Set.empty_subset _
+
+private theorem SingularMayerVietoris.exists_lebesgue_number_two {K X : Type*} [PseudoMetricSpace K]
+    [CompactSpace K] [TopologicalSpace X] (σ : C(K, X)) {U V : Set X} (hU : IsOpen U)
+    (hV : IsOpen V) (hcover : Set.range σ ⊆ U ∪ V) :
+    ∃ δ > 0, ∀ s : Set K, Metric.diam s ≤ δ → σ '' s ⊆ U ∨ σ '' s ⊆ V := by
+  obtain ⟨δ, hδ, hsmall⟩ := exists_lebesgue_number_two_pairwise σ hU hV hcover
+  refine ⟨δ, hδ, fun s hs => hsmall s ?_⟩
+  intro x hx y hy
+  exact (Metric.dist_le_diam_of_mem Metric.isBounded_of_compactSpace hx hy).trans hs
+
+private def SingularMayerVietoris.meshFactor (n : ℕ) : ℝ :=
+  (n : ℝ) / ((n : ℝ) + 1)
+
+private theorem SingularMayerVietoris.meshFactor_nonneg (n : ℕ) : 0 ≤ meshFactor n := by
+  exact div_nonneg (Nat.cast_nonneg n) (by positivity)
+
+private theorem SingularMayerVietoris.meshFactor_lt_one (n : ℕ) : meshFactor n < 1 := by
+  apply (div_lt_one (by positivity : (0 : ℝ) < (n : ℝ) + 1)).mpr
+  linarith
+
+private theorem SingularMayerVietoris.meshFactor_mono : Monotone meshFactor := by
+  intro n m hnm
+  dsimp [meshFactor]
+  apply (div_le_div_iff₀ (by positivity) (by positivity)).mpr
+  have hnm' : (n : ℝ) ≤ (m : ℝ) := by exact_mod_cast hnm
+  nlinarith
+
+private theorem SingularMayerVietoris.meshFactor_pow_tendsto (n : ℕ) :
+    Filter.Tendsto (fun k : ℕ => meshFactor n ^ k) Filter.atTop (𝓝 0) :=
+  tendsto_pow_atTop_nhds_zero_of_lt_one (meshFactor_nonneg n) (meshFactor_lt_one n)
+
+private theorem SingularMayerVietoris.meshFactor_pow_mul_tendsto (n : ℕ) (D : ℝ) :
+    Filter.Tendsto (fun k : ℕ => meshFactor n ^ k * D) Filter.atTop (𝓝 0) := by
+  simpa only [MulZeroClass.zero_mul] using (meshFactor_pow_tendsto n).mul_const D
+
+private theorem SingularMayerVietoris.eventually_meshFactor_pow_mul_lt (n : ℕ) (D : ℝ) {δ : ℝ}
+    (hδ : 0 < δ) : ∃ N : ℕ, ∀ k ≥ N, meshFactor n ^ k * D < δ := by
+  apply Filter.eventually_atTop.mp
+  exact (meshFactor_pow_mul_tendsto n D).eventually (eventually_lt_nhds hδ)
+
+private theorem SingularMayerVietoris.simplex_lebesgue_number_two {X : Type*} [TopologicalSpace X]
+    {U V : Set X} {n : ℕ} (σ : C(FirstHurewicz.Simplex n, X)) (hU : IsOpen U) (hV : IsOpen V)
+    (hcover : Set.range σ ⊆ U ∪ V) :
+    ∃ δ > 0, ∀ s : Set (FirstHurewicz.Simplex n), Metric.diam s ≤ δ → σ '' s ⊆ U ∨ σ '' s ⊆ V :=
+  exists_lebesgue_number_two σ hU hV hcover
+
+private theorem SingularMayerVietoris.simplex_lebesgue_number_subsimplices {X : Type*}
+    [TopologicalSpace X] {U V : Set X} {n : ℕ} (σ : C(FirstHurewicz.Simplex n, X)) (hU : IsOpen U)
+    (hV : IsOpen V) (hcover : Set.range σ ⊆ U ∪ V) :
+    ∃ δ > 0,
+      ∀ (m : ℕ) (f : C(FirstHurewicz.Simplex m, FirstHurewicz.Simplex n)),
+        Metric.diam (Set.range f) ≤ δ → Set.range (σ.comp f) ⊆ U ∨ Set.range (σ.comp f) ⊆ V := by
+  obtain ⟨δ, hδ, hsmall⟩ := simplex_lebesgue_number_two σ hU hV hcover
+  refine ⟨δ, hδ, ?_⟩
+  intro m f hf
+  simpa only [ContinuousMap.coe_comp, Set.range_comp] using hsmall (Set.range f) hf
+
+private theorem SingularMayerVietoris.simplex_eventually_small_of_diameter {X : Type*}
+    [TopologicalSpace X] {U V : Set X} {n : ℕ} (σ : C(FirstHurewicz.Simplex n, X)) (hU : IsOpen U)
+    (hV : IsOpen V) (hcover : Set.range σ ⊆ U ∪ V) (D : ℝ) :
+    ∃ N : ℕ,
+      ∀ k ≥ N,
+        ∀ (m : ℕ) (f : C(FirstHurewicz.Simplex m, FirstHurewicz.Simplex n)),
+          Metric.diam (Set.range f) ≤ meshFactor n ^ k * D →
+            Set.range (σ.comp f) ⊆ U ∨ Set.range (σ.comp f) ⊆ V := by
+  obtain ⟨δ, hδ, hsmall⟩ := simplex_lebesgue_number_subsimplices σ hU hV hcover
+  obtain ⟨N, hN⟩ := eventually_meshFactor_pow_mul_lt n D hδ
+  refine ⟨N, ?_⟩
+  intro k hk m f hf
+  exact hsmall m f (hf.trans (hN k hk).le)
+
+private theorem SingularMayerVietoris.finite_family_eventually_small_of_diameter {X : Type*}
+    [TopologicalSpace X] {U V : Set X} {n : ℕ} (s : Finset C(FirstHurewicz.Simplex n, X))
+    (hU : IsOpen U) (hV : IsOpen V) (hcover : ∀ σ ∈ s, Set.range σ ⊆ U ∪ V) (D : ℝ) :
+    ∃ N : ℕ,
+      ∀ k ≥ N,
+        ∀ σ ∈ s,
+          ∀ (m : ℕ) (f : C(FirstHurewicz.Simplex m, FirstHurewicz.Simplex n)),
+            Metric.diam (Set.range f) ≤ meshFactor n ^ k * D →
+              Set.range (σ.comp f) ⊆ U ∨ Set.range (σ.comp f) ⊆ V := by
+  classical
+    induction s using Finset.induction_on with
+  | empty => exact ⟨0, fun _ _ _ hσ => False.elim (Finset.notMem_empty _ hσ)⟩
+  | @insert σ s hσ
+    ih =>
+    obtain ⟨Nσ, hNσ⟩ :=
+      simplex_eventually_small_of_diameter σ hU hV (hcover σ (Finset.mem_insert_self σ s)) D
+    obtain ⟨Ns, hNs⟩ := ih (fun τ hτ => hcover τ (Finset.mem_insert_of_mem hτ))
+    refine ⟨Max.max Nσ Ns, ?_⟩
+    intro k hk τ hτ m f hf
+    rcases Finset.mem_insert.mp hτ with rfl | hτ
+    · exact hNσ k ((le_max_left _ _).trans hk) m f hf
+    · exact hNs k ((le_max_right _ _).trans hk) τ hτ m f hf
+
+private theorem SingularMayerVietoris.simplexBarycenter_eq_vertexBarycenter {n p : ℕ}
+    (v : Fin (n + 1) → FirstHurewicz.Simplex p) :
+    (simplexBarycenter v : Fin (p + 1) → ℝ) =
+      vertexBarycenter (fun i => (v i : Fin (p + 1) → ℝ)) := by
+  rw [simplexBarycenter_coe]
+  simp only [vertexBarycenter, Nat.cast_add, Nat.cast_one, one_div]
+
+private theorem SingularMayerVietoris.dist_affineSimplex_le {n p : ℕ}
+    (v : Fin (n + 1) → FirstHurewicz.Simplex p) {D : ℝ} (hpair : ∀ i j, Dist.dist (v i) (v j) ≤ D)
+    (t u : FirstHurewicz.Simplex n) : Dist.dist (affineSimplex v t) (affineSimplex v u) ≤ D :=
+  dist_convexHull_range_le (fun i => (v i : Fin (p + 1) → ℝ)) hpair
+    (affineSimplex_mem_convexHull v t) (affineSimplex_mem_convexHull v u)
+
+private theorem SingularMayerVietoris.affineSimplex_diam_le {n p : ℕ}
+    (v : Fin (n + 1) → FirstHurewicz.Simplex p) {D : ℝ}
+    (hpair : ∀ i j, Dist.dist (v i) (v j) ≤ D) : Metric.diam (Set.range (affineSimplex v)) ≤ D := by
+  apply Metric.diam_le_of_forall_dist_le_of_nonempty (Set.range_nonempty (affineSimplex v))
+  rintro _ ⟨t, rfl⟩ _ ⟨u, rfl⟩
+  exact dist_affineSimplex_le v hpair t u
+
+private theorem SingularMayerVietoris.finite_family_eventually_small_of_vertices {p : ℕ} {X : Type*}
+    [TopologicalSpace X] {U V : Set X} (s : Finset C(FirstHurewicz.Simplex p, X)) (hU : IsOpen U)
+    (hV : IsOpen V) (hcover : ∀ σ ∈ s, Set.range σ ⊆ U ∪ V) (D : ℝ) :
+    ∃ N : ℕ,
+      ∀ k ≥ N,
+        ∀ σ ∈ s,
+          ∀ (m : ℕ) (v : Fin (m + 1) → FirstHurewicz.Simplex p),
+            (∀ i j, Dist.dist (v i) (v j) ≤ meshFactor p ^ k * D) →
+              Set.range (σ.comp (affineSimplex v)) ⊆ U ∨
+                Set.range (σ.comp (affineSimplex v)) ⊆ V := by
+  obtain ⟨N, hN⟩ := finite_family_eventually_small_of_diameter s hU hV hcover D
+  refine ⟨N, ?_⟩
+  intro k hk σ hσ m v hv
+  exact hN k hk σ hσ m (affineSimplex v) (affineSimplex_diam_le v hv)
+
+private theorem
+    SingularMayerVietoris.formalCenter_mem_of_convex {V E : Type*} [SeminormedAddCommGroup E]
+    [NormedSpace ℝ E] (center : FormalCenter V) (coords : V → E)
+    (hcenter : ∀ n (v : Fin (n + 1) → V), coords (center n v) = vertexBarycenter (coords ∘ v))
+    {S : Set E} (hS : Convex ℝ S) (n : ℕ) (v : Fin (n + 1) → V) (hv : ∀ i, coords (v i) ∈ S) :
+    coords (center n v) ∈ S := by
+  rw [hcenter]
+  exact vertexBarycenter_mem_of_convex (coords ∘ v) hS hv
+
+private theorem
+    SingularMayerVietoris.formalSubdivision_simplex_vertices_mem_convexHull {V E : Type*}
+    [SeminormedAddCommGroup E] [NormedSpace ℝ E] (center : FormalCenter V) (coords : V → E)
+    (hcenter : ∀ n (v : Fin (n + 1) → V), coords (center n v) = vertexBarycenter (coords ∘ v))
+    {n : ℕ} (v : Fin n → V) {w : Fin n → V}
+    (hw : w ∈ (formalSubdivision center n (formalSimplex v)).support) (i : Fin n) :
+    coords (w i) ∈ convexHull ℝ (Set.range (coords ∘ v)) := by
+  let S : Set V := coords ⁻¹' convexHull ℝ (Set.range (coords ∘ v))
+  have hv : formalSimplex v ∈ formalChainsSupported S n := by
+    apply formalSimplex_mem_supported
+    intro j
+    exact subset_convexHull ℝ _ (Set.mem_range_self j)
+  have hS : ∀ k (u : Fin (k + 1) → V), (∀ j, u j ∈ S) → center k u ∈ S := by
+    intro k u hu
+    exact formalCenter_mem_of_convex center coords hcenter (convex_convexHull ℝ _) k u hu
+  have hsub := formalSubdivision_mem_supported center hS n hv
+  exact (mem_formalChainsSupported_iff.mp hsub) w hw i
+
+private theorem SingularMayerVietoris.formalSubdivision_simplex_mesh {V E : Type*}
+    [SeminormedAddCommGroup E] [NormedSpace ℝ E] (center : FormalCenter V) (coords : V → E)
+    (hcenter : ∀ n (v : Fin (n + 1) → V), coords (center n v) = vertexBarycenter (coords ∘ v))
+    (n : ℕ) :
+    ∀ (v : Fin (n + 1) → V) {D : ℝ},
+      (∀ i j, Dist.dist (coords (v i)) (coords (v j)) ≤ D) →
+        ∀ {w : Fin (n + 1) → V},
+          w ∈ (formalSubdivision center (n + 1) (formalSimplex v)).support →
+            ∀ i j, Dist.dist (coords (w i)) (coords (w j)) ≤ meshFactor n * D := by
+  induction n with
+  | zero =>
+    intro v D hpair w hw i j
+    let : Subsingleton (Fin (0 + 1)) := inferInstanceAs (Subsingleton (Fin 1))
+    have hij : i = j := Subsingleton.elim _ _
+    subst j
+    simp [meshFactor]
+  | succ n ih =>
+    intro v D hpair w hw
+    have hD : 0 ≤ D := by simpa only [dist_self] using hpair 0 0
+    have hHull := formalSubdivision_simplex_vertices_mem_convexHull center coords hcenter v hw
+    rw [formalSubdivision_simplex_succ] at hw
+    obtain ⟨u, hu, rfl⟩ := formalCone_support_exists (center (n + 1) v) hw
+    obtain ⟨face, hface, hu⟩ :=
+      formalLinearMap_support_exists (formalSubdivision center (n + 1)) hu
+    obtain ⟨r, rfl⟩ := formalBoundary_support_exists (n + 1) v hface
+    have huMesh := ih (v ∘ r.succAbove) (fun i j => hpair (r.succAbove i) (r.succAbove j)) hu
+    intro i j
+    refine Fin.cases ?_ (fun i => ?_) i
+    · refine Fin.cases ?_ (fun j => ?_) j
+      · simpa only [Fin.cons_zero, dist_self] using mul_nonneg (meshFactor_nonneg (n + 1)) hD
+      · change Dist.dist (coords (center (n + 1) v)) (coords (u j)) ≤ meshFactor (n + 1) * D
+        rw [hcenter]
+        exact dist_vertexBarycenter_convexHull_le (coords ∘ v) hpair (hHull j.succ)
+    · refine Fin.cases ?_ (fun j => ?_) j
+      · change Dist.dist (coords (u i)) (coords (center (n + 1) v)) ≤ meshFactor (n + 1) * D
+        rw [dist_comm, hcenter]
+        exact dist_vertexBarycenter_convexHull_le (coords ∘ v) hpair (hHull i.succ)
+      · change Dist.dist (coords (u i)) (coords (u j)) ≤ meshFactor (n + 1) * D
+        exact (huMesh i j).trans (mul_le_mul_of_nonneg_right (meshFactor_mono (Nat.le_succ n)) hD)
+
+private theorem
+    SingularMayerVietoris.formalSubdivision_mesh {V E : Type*} [SeminormedAddCommGroup E]
+    [NormedSpace ℝ E] (center : FormalCenter V) (coords : V → E)
+    (hcenter : ∀ n (v : Fin (n + 1) → V), coords (center n v) = vertexBarycenter (coords ∘ v))
+    (n : ℕ) (c : FormalChains V (n + 1)) {D : ℝ}
+    (hc : ∀ v ∈ c.support, ∀ i j, Dist.dist (coords (v i)) (coords (v j)) ≤ D) :
+    ∀ w ∈ (formalSubdivision center (n + 1) c).support,
+      ∀ i j, Dist.dist (coords (w i)) (coords (w j)) ≤ meshFactor n * D := by
+  intro w hw
+  obtain ⟨v, hv, hw⟩ := formalLinearMap_support_exists (formalSubdivision center (n + 1)) hw
+  exact formalSubdivision_simplex_mesh center coords hcenter n v (hc v hv) hw
+
+private theorem SingularMayerVietoris.formalSubdivision_iterate_mesh {V E : Type*}
+    [SeminormedAddCommGroup E] [NormedSpace ℝ E] (center : FormalCenter V) (coords : V → E)
+    (hcenter : ∀ n (v : Fin (n + 1) → V), coords (center n v) = vertexBarycenter (coords ∘ v))
+    (n k : ℕ) (c : FormalChains V (n + 1)) {D : ℝ}
+    (hc : ∀ v ∈ c.support, ∀ i j, Dist.dist (coords (v i)) (coords (v j)) ≤ D) :
+    ∀ w ∈ ((formalSubdivision center (n + 1))^[k] c).support,
+      ∀ i j, Dist.dist (coords (w i)) (coords (w j)) ≤ meshFactor n ^ k * D := by
+  induction k with
+  | zero => simpa only [Function.iterate_zero_apply, pow_zero, one_mul] using hc
+  | succ k ih =>
+    rw [Function.iterate_succ_apply']
+    intro w hw i j
+    have h :=
+      formalSubdivision_mesh center coords hcenter n ((formalSubdivision center (n + 1))^[k] c) ih
+        w hw i j
+    simpa only [pow_succ, mul_assoc, mul_left_comm] using h
+
+private theorem SingularMayerVietoris.simplex_dist_le_one {p : ℕ} (x y : FirstHurewicz.Simplex p) :
+    Dist.dist x y ≤ 1 :=
+  (Metric.dist_le_diam_of_mem (bounded_stdSimplex (Fin (p + 1))) x.property y.property).trans
+    diam_stdSimplex_le
+
+private theorem SingularMayerVietoris.simplex_formalSubdivision_iterate_mesh {p n : ℕ} (k : ℕ)
+    (c : FormalChains (FirstHurewicz.Simplex p) (n + 1)) :
+    ∀ w ∈ ((formalSubdivision (fun _ v => simplexBarycenter v) (n + 1))^[k] c).support,
+      ∀ i j, Dist.dist (w i) (w j) ≤ meshFactor n ^ k := by
+  have h :=
+    formalSubdivision_iterate_mesh
+      (fun n (v : Fin (n + 1) → FirstHurewicz.Simplex p) => simplexBarycenter v)
+      (fun x : FirstHurewicz.Simplex p => (x : Fin (p + 1) → ℝ))
+      (fun _ v => simplexBarycenter_eq_vertexBarycenter v) n k c (D := 1)
+      (fun v _ i j => simplex_dist_le_one (v i) (v j))
+  intro w hw i j
+  change Dist.dist (w i : Fin (p + 1) → ℝ) (w j : Fin (p + 1) → ℝ) ≤ meshFactor n ^ k
+  simpa only [mul_one] using h w hw i j
+
+private theorem
+    SingularMayerVietoris.finite_family_formalSubdivision_eventually_small {p : ℕ} {X : Type*}
+    [TopologicalSpace X] {U V : Set X} (s : Finset C(FirstHurewicz.Simplex p, X)) (hU : IsOpen U)
+    (hV : IsOpen V) (hcover : ∀ σ ∈ s, Set.range σ ⊆ U ∪ V) :
+    ∃ N : ℕ,
+      ∀ k ≥ N,
+        ∀ σ ∈ s,
+          ∀ c : FormalChains (FirstHurewicz.Simplex p) (p + 1),
+            ∀ w ∈ ((formalSubdivision (fun _ v => simplexBarycenter v) (p + 1))^[k] c).support,
+              Set.range (σ.comp (affineSimplex w)) ⊆ U ∨
+                Set.range (σ.comp (affineSimplex w)) ⊆ V := by
+  obtain ⟨N, hN⟩ := finite_family_eventually_small_of_vertices s hU hV hcover 1
+  refine ⟨N, ?_⟩
+  intro k hk σ hσ c w hw
+  apply hN k hk σ hσ p w
+  simpa only [mul_one] using simplex_formalSubdivision_iterate_mesh k c w hw
+
+private theorem SingularMayerVietoris.subdivisionHomotopy_mem_small {X : Type} [TopologicalSpace X]
+    (U V : Set X) (k n : ℕ) (c : FirstHurewicz.Chains X n) (hc : c ∈ smallChainSubmodule U V n) :
+    subdivisionHomotopy X k n c ∈ smallChainSubmodule U V (n + 1) := by
+  apply
+    singularLinearMap_mem_of_small U V n (subdivisionHomotopy X k n)
+      (smallChainSubmodule U V (n + 1)) c hc
+  intro σ hσ
+  rw [subdivisionHomotopy_simplex]
+  exact realizedChain_mem_small U V n (n + 1) σ hσ _
+
+private theorem
+    SingularMayerVietoris.eventually_subdivision_mem_small {X : Type} [TopologicalSpace X]
+    (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (n : ℕ)
+    (c : FirstHurewicz.Chains X n) :
+    ∃ N : ℕ, ∀ k ≥ N, subdivision X k n c ∈ smallChainSubmodule U V n := by
+  classical
+  have hc : ∀ σ ∈ (FirstHurewicz.chainsEquivFinsupp X n c).support, Set.range σ ⊆ U ∪ V := by
+    intro σ hσ
+    rw [hcover]
+    exact Set.subset_univ _
+  obtain ⟨N, hN⟩ :=
+    finite_family_formalSubdivision_eventually_small
+      (FirstHurewicz.chainsEquivFinsupp X n c).support hU hV hc
+  refine ⟨N, ?_⟩
+  intro k hk
+  apply singularLinearMap_mem_of_support n (subdivision X k n) (smallChainSubmodule U V n) c
+  intro σ hσ
+  rw [subdivision_simplex]
+  apply realizedChain_mem_small_of_support U V n n σ
+  intro v hv
+  exact hN k hk σ hσ (formalSimplex (stdVertices n)) v hv
+
+private theorem SingularMayerVietoris.smallInclusion_quasiIso_of_deformation {X : Type}
+    [TopologicalSpace X] (U V : Set X)
+    (s : ∀ _k n : ℕ, FirstHurewicz.Chains X n →ₗ[ℤ] FirstHurewicz.Chains X n)
+    (h : ∀ _k n : ℕ, FirstHurewicz.Chains X n →ₗ[ℤ] FirstHurewicz.Chains X (n + 1))
+    (hs :
+      ∀ k n,
+        ∀ c : FirstHurewicz.Chains X (n + 1),
+          ((FirstHurewicz.singularComplex X).d (n + 1) n).hom (s k (n + 1) c) =
+            s k n (((FirstHurewicz.singularComplex X).d (n + 1) n).hom c))
+    (hh :
+      ∀ k n,
+        ∀ c : FirstHurewicz.Chains X n,
+          ((FirstHurewicz.singularComplex X).d n (n - 1)).hom c = 0 →
+            ((FirstHurewicz.singularComplex X).d (n + 1) n).hom (h k n c) = c - s k n c)
+    (hsmall :
+      ∀ k n,
+        ∀ c : FirstHurewicz.Chains X n,
+          c ∈ smallChainSubmodule U V n → h k n c ∈ smallChainSubmodule U V (n + 1))
+    (heventually :
+      ∀ n, ∀ c : FirstHurewicz.Chains X n, ∃ k, s k n c ∈ smallChainSubmodule U V n) :
+    QuasiIso (smallInclusion U V) := by
+  apply ModuleHomology.quasiIso_of_injective_chain_conditions (smallInclusion U V)
+  · intro n
+    exact smallInclusion_f_injective U V n
+  · intro n c hc
+    obtain ⟨k, hk⟩ := heventually n c
+    exact ⟨⟨s k n c, hk⟩, h k n c, hh k n c hc⟩
+  · intro n c hc b hb
+    have hc' : ((FirstHurewicz.singularComplex X).d n (n - 1)).hom c.1 = 0 :=
+      congrArg (fun z : (smallComplex U V).X (n - 1) => z.1) hc
+    change ((FirstHurewicz.singularComplex X).d (n + 1) n).hom b = c.1 at hb
+    obtain ⟨k, hk⟩ := heventually (n + 1) b
+    refine
+      ⟨⟨s k (n + 1) b + h k n c.1,
+          (smallChainSubmodule U V (n + 1)).add_mem hk (hsmall k n c.1 c.2)⟩,
+        ?_⟩
+    apply Subtype.ext
+    change ((FirstHurewicz.singularComplex X).d (n + 1) n).hom (s k (n + 1) b + h k n c.1) = c.1
+    rw [map_add, hs, hb, hh k n c.1 hc']
+    rw [← add_sub_assoc, add_comm, add_sub_cancel_right]
+
+private theorem SingularMayerVietoris.smallInclusion_quasiIso {X : Type} [TopologicalSpace X]
+    (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) :
+    QuasiIso (smallInclusion U V) := by
+  apply smallInclusion_quasiIso_of_deformation U V (subdivision X) (subdivisionHomotopy X)
+  · exact fun k n c => subdivision_boundary k n c
+  · exact fun k n c hc => subdivisionHomotopy_boundary_of_cycle k n c hc
+  · exact fun k n c hc => subdivisionHomotopy_mem_small U V k n c hc
+  · intro n c
+    obtain ⟨N, hN⟩ := eventually_subdivision_mem_small U V hU hV hcover n c
+    exact ⟨N, hN N le_rfl⟩
+
+private def SingularMayerVietoris.smallHomologyIso {X : Type} [TopologicalSpace X] (U V : Set X)
+    (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (n : ℕ) :
+    (smallComplex U V).homology n ≅ (FirstHurewicz.singularComplex X).homology n := by
+  letI := smallInclusion_quasiIso U V hU hV hcover
+  exact isoOfQuasiIsoAt (smallInclusion U V) n
+
+private def SingularMayerVietoris.smallHomologyEquiv {X : Type} [TopologicalSpace X] (U V : Set X)
+    (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (n : ℕ) :
+    (smallComplex U V).homology n ≃ₗ[ℤ] (FirstHurewicz.singularComplex X).homology n :=
+  (smallHomologyIso U V hU hV hcover n).toLinearEquiv
+
+@[simp]
+private theorem SingularMayerVietoris.smallHomologyEquiv_toLinearMap {X : Type} [TopologicalSpace X]
+    (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (n : ℕ) :
+    (smallHomologyEquiv U V hU hV hcover n).toLinearMap =
+      (HomologicalComplex.homologyMap (smallInclusion U V) n).hom :=
+  rfl
+
+private abbrev SingularMayerVietoris.leftHomologyMap {X : Type} [TopologicalSpace X] (U V : Set X)
+    (n : ℕ) :
+    SingularHomology (U ∩ V : Set X) n →ₗ[ℤ] (SingularHomology U n × SingularHomology V n) :=
+  smallLeftHomologyMap U V n
+
+private def
+    SingularMayerVietoris.rightHomologyMap {X : Type} [TopologicalSpace X] (U V : Set X) (n : ℕ) :
+    (SingularHomology U n × SingularHomology V n) →ₗ[ℤ] SingularHomology X n := by
+  let f :=
+    (singularHomologyMap (subtypeInclusion U) n).toAddMonoidHom.coprod
+      (singularHomologyMap (subtypeInclusion V) n).toAddMonoidHom
+  exact
+    { toFun := f
+      map_add' := f.map_add
+      map_smul' r
+        a := by
+        convert! f.map_zsmul r a using 1
+        exact int_smul_eq_zsmul .. }
+
+private theorem
+    SingularMayerVietoris.leftHomologyMap_apply {X : Type} [TopologicalSpace X] (U V : Set X)
+    (n : ℕ) (a : SingularHomology (U ∩ V : Set X) n) :
+    leftHomologyMap U V n a =
+      (singularHomologyMap (ContinuousMap.inclusion (Set.inter_subset_left : U ∩ V ⊆ U)) n a,
+        -singularHomologyMap (ContinuousMap.inclusion (Set.inter_subset_right : U ∩ V ⊆ V)) n
+            a) :=
+  smallLeftHomologyMap_apply U V n a
+
+@[simp]
+private theorem
+    SingularMayerVietoris.rightHomologyMap_apply {X : Type} [TopologicalSpace X] (U V : Set X)
+    (n : ℕ) (a : SingularHomology U n × SingularHomology V n) :
+    rightHomologyMap U V n a =
+      singularHomologyMap (subtypeInclusion U) n a.1 +
+        singularHomologyMap (subtypeInclusion V) n a.2 :=
+  rfl
+
+private theorem SingularMayerVietoris.rightHomologyMap_eq_comparison {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) :
+    rightHomologyMap U V n = (smallHomologyComparison U V n).comp (smallRightHomologyMap U V n) :=
+  by
+  apply LinearMap.ext
+  intro a
+  exact (smallHomologyComparison_right U V n a).symm
+
+private theorem SingularMayerVietoris.leftHomologyMap_comp_right {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) : (rightHomologyMap U V n).comp (leftHomologyMap U V n) = 0 := by
+  apply LinearMap.ext
+  intro a
+  have ha := LinearMap.congr_fun (smallLeftHomologyMap_comp_right U V n) a
+  change smallRightHomologyMap U V n (smallLeftHomologyMap U V n a) = 0 at ha
+  rw [rightHomologyMap_eq_comparison]
+  change
+    smallHomologyComparison U V n (smallRightHomologyMap U V n (smallLeftHomologyMap U V n a)) = 0
+  rw [ha, map_zero]
+
+private theorem
+    SingularMayerVietoris.smallHomologyEquiv_eq_comparison {X : Type} [TopologicalSpace X]
+    (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (n : ℕ) :
+    (smallHomologyEquiv U V hU hV hcover n).toLinearMap = smallHomologyComparison U V n :=
+  smallHomologyEquiv_toLinearMap U V hU hV hcover n
+
+private def
+    SingularMayerVietoris.connectingHomomorphism {X : Type} [TopologicalSpace X] (U V : Set X)
+    (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (n : ℕ) :
+    SingularHomology X (n + 1) →ₗ[ℤ] SingularHomology (U ∩ V : Set X) n :=
+  (smallConnectingMap U V n).comp (smallHomologyEquiv U V hU hV hcover (n + 1)).symm.toLinearMap
+
+private theorem
+    SingularMayerVietoris.connectingHomomorphism_comparison {X : Type} [TopologicalSpace X]
+    (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (n : ℕ)
+    (a : SmallHomology U V (n + 1)) :
+    connectingHomomorphism U V hU hV hcover n (smallHomologyComparison U V (n + 1) a) =
+      smallConnectingMap U V n a := by
+  rw [← smallHomologyEquiv_eq_comparison U V hU hV hcover]
+  exact
+    congrArg (smallConnectingMap U V n)
+      ((smallHomologyEquiv U V hU hV hcover (n + 1)).symm_apply_apply a)
+
+private theorem SingularMayerVietoris.rightHomologyMap_eq_transport {X : Type} [TopologicalSpace X]
+    (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (n : ℕ) :
+    rightHomologyMap U V n =
+      (smallHomologyEquiv U V hU hV hcover n).toLinearMap.comp (smallRightHomologyMap U V n) := by
+  rw [smallHomologyEquiv_eq_comparison, rightHomologyMap_eq_comparison]
+
+private theorem
+    SingularMayerVietoris.exact_at_intersection {X : Type} [TopologicalSpace X] (U V : Set X)
+    (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (n : ℕ) :
+    LinearMap.range (connectingHomomorphism U V hU hV hcover n) =
+      LinearMap.ker (leftHomologyMap U V n) := by
+  rw [connectingHomomorphism, rightTransport_connecting_range]
+  exact small_exact_at_intersection U V n
+
+private theorem SingularMayerVietoris.exact_at_pair {X : Type} [TopologicalSpace X] (U V : Set X)
+    (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (n : ℕ) :
+    LinearMap.range (leftHomologyMap U V n) = LinearMap.ker (rightHomologyMap U V n) := by
+  rw [rightHomologyMap_eq_transport U V hU hV hcover, rightTransport_second_ker]
+  exact small_exact_at_pair U V n
+
+private theorem SingularMayerVietoris.exact_at_ambient {X : Type} [TopologicalSpace X] (U V : Set X)
+    (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (n : ℕ) :
+    LinearMap.range (rightHomologyMap U V (n + 1)) =
+      LinearMap.ker (connectingHomomorphism U V hU hV hcover n) := by
+  rw [rightHomologyMap_eq_transport U V hU hV hcover]
+  exact
+    rightTransport_range_eq_ker (smallHomologyEquiv U V hU hV hcover (n + 1))
+      (smallRightHomologyMap U V (n + 1)) (smallConnectingMap U V n)
+      (small_exact_at_smallHomology U V n)
+
+private theorem
+    SingularMayerVietoris.rightHomologyMap_zero_surjective {X : Type} [TopologicalSpace X]
+    (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) :
+    Function.Surjective (rightHomologyMap U V 0) := by
+  rw [rightHomologyMap_eq_transport U V hU hV hcover]
+  exact
+    rightTransport_second_surjective (smallHomologyEquiv U V hU hV hcover 0)
+      (smallRightHomologyMap U V 0) (smallRightHomologyMap_zero_surjective U V)
+
+private theorem
+    SingularMayerVietoris.connectingHomomorphism_comp_left {X : Type} [TopologicalSpace X]
+    (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (n : ℕ) :
+    (leftHomologyMap U V n).comp (connectingHomomorphism U V hU hV hcover n) = 0 := by
+  apply LinearMap.ext
+  intro a
+  have ha :
+    connectingHomomorphism U V hU hV hcover n a ∈
+      LinearMap.range (connectingHomomorphism U V hU hV hcover n) :=
+    ⟨a, rfl⟩
+  rw [exact_at_intersection] at ha
+  exact ha
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/HomologyTheory/SphereHomology1.lean b/LeanPool/HopfProblem/HomologyTheory/SphereHomology1.lean
new file mode 100644
index 000000000..5ba1f17a6
--- /dev/null
+++ b/LeanPool/HopfProblem/HomologyTheory/SphereHomology1.lean
@@ -0,0 +1,413 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.CuspFibre.CuspCentralHomology2
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.CuspFibre.CuspCentralHomology2
+
+/-!
+# Hopf problem: homology theory · sphere homology 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+/-- The unit `n`-sphere in Euclidean `(n+1)`-space. -/
+public
+abbrev SphereHomology.UnitSphere (n : ℕ) :=
+  Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1
+
+private theorem SphereHomology.unitSphere_norm {n : ℕ} (x : UnitSphere n) : ‖x.val‖ = 1 := by
+  simpa only [Metric.mem_sphere, dist_zero_right] using x.property
+
+private def SphereHomology.basePoint (n : ℕ) : UnitSphere n :=
+  ⟨PiLp.single 2 (0 : Fin (n + 1)) (1 : ℝ), by simp⟩
+
+private instance SphereHomology.unitSphere_nonempty (n : ℕ) : Nonempty (UnitSphere n) :=
+  ⟨basePoint n⟩
+
+private instance SphereHomology.unitSphere_compactSpace (n : ℕ) : CompactSpace (UnitSphere n) :=
+  inferInstance
+
+private def SphereHomology.Latitude.height (t : unitInterval) : ℝ :=
+  2 * (t : ℝ) - 1
+
+private def SphereHomology.Latitude.radius (t : unitInterval) : ℝ :=
+  Real.sqrt (1 - height t ^ 2)
+
+private theorem SphereHomology.Latitude.height_sq_le_one (t : unitInterval) : height t ^ 2 ≤ 1 := by
+  have h0 := t.property.1
+  have h1 := t.property.2
+  dsimp [height]
+  nlinarith
+
+private theorem
+    SphereHomology.Latitude.radius_sq (t : unitInterval) : radius t ^ 2 = 1 - height t ^ 2 :=
+  Real.sq_sqrt (sub_nonneg.mpr (height_sq_le_one t))
+
+private theorem SphereHomology.Latitude.radius_nonneg (t : unitInterval) : 0 ≤ radius t :=
+  Real.sqrt_nonneg _
+
+@[simp]
+private theorem SphereHomology.Latitude.height_zero : height 0 = -1 := by norm_num [height]
+
+@[simp]
+private theorem SphereHomology.Latitude.height_one : height 1 = 1 := by norm_num [height]
+
+@[simp]
+private theorem SphereHomology.Latitude.radius_zero : radius 0 = 0 := by simp [radius]
+
+@[simp]
+private theorem SphereHomology.Latitude.radius_one : radius 1 = 0 := by simp [radius]
+
+private theorem SphereHomology.Latitude.height_injective : Function.Injective height := by
+  intro t s h
+  apply Subtype.ext
+  dsimp [height] at h
+  linarith
+
+private theorem SphereHomology.Latitude.radius_pos_of_interior (t : unitInterval) (h0 : t ≠ 0)
+    (h1 : t ≠ 1) : 0 < radius t := by
+  have ht0 : 0 < (t : ℝ) :=
+    lt_of_le_of_ne t.property.1
+      (by
+        intro h
+        exact h0 (Subtype.ext h.symm))
+  have ht1 : (t : ℝ) < 1 :=
+    lt_of_le_of_ne t.property.2
+      (by
+        intro h
+        exact h1 (Subtype.ext h))
+  apply Real.sqrt_pos.mpr
+  dsimp [height]
+  nlinarith
+
+@[continuity, fun_prop]
+private theorem SphereHomology.Latitude.height_continuous : Continuous height := by
+  unfold height
+  fun_prop
+
+@[continuity, fun_prop]
+private theorem SphereHomology.Latitude.radius_continuous : Continuous radius := by
+  unfold radius
+  exact Real.continuous_sqrt.comp (continuous_const.sub (height_continuous.pow 2))
+
+private def
+    SphereHomology.Latitude.vector (n : ℕ) (t : unitInterval) (x : SphereHomology.UnitSphere n) :
+    EuclideanSpace ℝ (Fin (n + 2)) :=
+  WithLp.toLp 2 (Fin.cons (height t) (fun i => radius t * x.val i))
+
+@[simp]
+private theorem SphereHomology.Latitude.vector_zero (n : ℕ) (t : unitInterval)
+    (x : SphereHomology.UnitSphere n) : vector n t x 0 = height t :=
+  rfl
+
+@[simp]
+private theorem SphereHomology.Latitude.vector_succ (n : ℕ) (t : unitInterval)
+    (x : SphereHomology.UnitSphere n) (i : Fin (n + 1)) :
+    vector n t x i.succ = radius t * x.val i :=
+  rfl
+
+private theorem SphereHomology.Latitude.vector_norm_sq (n : ℕ) (t : unitInterval)
+    (x : SphereHomology.UnitSphere n) : ‖vector n t x‖ ^ 2 = 1 := by
+  rw [EuclideanSpace.real_norm_sq_eq, Fin.sum_univ_succ]
+  simp only [vector_zero, vector_succ, mul_pow]
+  rw [← Finset.mul_sum, ← EuclideanSpace.real_norm_sq_eq, SphereHomology.unitSphere_norm]
+  rw [one_pow, mul_one, radius_sq]
+  ring
+
+private theorem SphereHomology.Latitude.vector_mem_sphere (n : ℕ) (t : unitInterval)
+    (x : SphereHomology.UnitSphere n) :
+    vector n t x ∈ Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 2))) 1 := by
+  have hn := vector_norm_sq n t x
+  have hnorm : ‖vector n t x‖ = 1 := by nlinarith [norm_nonneg (vector n t x)]
+  simpa only [Metric.mem_sphere, dist_zero_right] using hnorm
+
+private def
+    SphereHomology.Latitude.point (n : ℕ) (t : unitInterval) (x : SphereHomology.UnitSphere n) :
+    SphereHomology.UnitSphere (n + 1) :=
+  ⟨vector n t x, vector_mem_sphere n t x⟩
+
+@[continuity, fun_prop]
+private theorem SphereHomology.Latitude.vector_continuous (n : ℕ) :
+    Continuous (fun p : unitInterval × SphereHomology.UnitSphere n => vector n p.1 p.2) := by
+  apply (PiLp.continuous_toLp 2 (fun _ : Fin (n + 2) => ℝ)).comp
+  apply continuous_pi
+  intro i
+  refine Fin.cases ?_ (fun j => ?_) i
+  · exact height_continuous.comp continuous_fst
+  · exact
+      (radius_continuous.comp continuous_fst).mul
+        ((PiLp.continuous_apply 2 (fun _ : Fin (n + 1) => ℝ) j).comp
+          (continuous_subtype_val.comp continuous_snd))
+
+@[continuity, fun_prop]
+private theorem SphereHomology.Latitude.point_continuous (n : ℕ) :
+    Continuous (fun p : unitInterval × SphereHomology.UnitSphere n => point n p.1 p.2) :=
+  (vector_continuous n).subtype_mk _
+
+private theorem SphereHomology.Latitude.point_zero_eq (n : ℕ) (x y : SphereHomology.UnitSphere n) :
+    point n 0 x = point n 0 y := by
+  ext i
+  refine Fin.cases ?_ (fun j => ?_) i
+  · rfl
+  · change radius 0 * x.val j = radius 0 * y.val j
+    rw [radius_zero, MulZeroClass.zero_mul, MulZeroClass.zero_mul]
+
+private theorem SphereHomology.Latitude.point_one_eq (n : ℕ) (x y : SphereHomology.UnitSphere n) :
+    point n 1 x = point n 1 y := by
+  ext i
+  refine Fin.cases ?_ (fun j => ?_) i
+  · rfl
+  · change radius 1 * x.val j = radius 1 * y.val j
+    rw [radius_one, MulZeroClass.zero_mul, MulZeroClass.zero_mul]
+
+private theorem SphereHomology.Latitude.point_eq_iff (n : ℕ) (t s : unitInterval)
+    (x y : SphereHomology.UnitSphere n) :
+    point n t x = point n s y ↔ t = s ∧ (t = 0 ∨ t = 1 ∨ x = y) := by
+  constructor
+  · intro h
+    have hh := congrArg (fun p : SphereHomology.UnitSphere (n + 1) => p.val 0) h
+    change height t = height s at hh
+    have ht : t = s := height_injective hh
+    subst s
+    refine ⟨rfl, ?_⟩
+    by_cases h0 : t = 0
+    · exact Or.inl h0
+    by_cases h1 : t = 1
+    · exact Or.inr (Or.inl h1)
+    refine Or.inr (Or.inr ?_)
+    ext i
+    have hi := congrArg (fun p : SphereHomology.UnitSphere (n + 1) => p.val i.succ) h
+    change radius t * x.val i = radius t * y.val i at hi
+    exact mul_left_cancel₀ (ne_of_gt (radius_pos_of_interior t h0 h1)) hi
+  · rintro ⟨rfl, h0 | h1 | rfl⟩
+    · subst t
+      exact point_zero_eq n x y
+    · subst t
+      exact point_one_eq n x y
+    · rfl
+
+private def SphereHomology.Latitude.tail (n : ℕ) (y : SphereHomology.UnitSphere (n + 1)) :
+    EuclideanSpace ℝ (Fin (n + 1)) :=
+  WithLp.toLp 2 (fun i => y.val i.succ)
+
+@[simp]
+private theorem SphereHomology.Latitude.tail_apply (n : ℕ) (y : SphereHomology.UnitSphere (n + 1))
+    (i : Fin (n + 1)) : tail n y i = y.val i.succ :=
+  rfl
+
+private theorem SphereHomology.Latitude.head_tail_norm_sq (n : ℕ)
+    (y : SphereHomology.UnitSphere (n + 1)) : y.val 0 ^ 2 + ‖tail n y‖ ^ 2 = 1 := by
+  have h : ‖y.val‖ ^ 2 = 1 := by rw [SphereHomology.unitSphere_norm, one_pow]
+  rw [EuclideanSpace.real_norm_sq_eq, Fin.sum_univ_succ] at h
+  rw [EuclideanSpace.real_norm_sq_eq]
+  simpa only [tail_apply] using h
+
+private theorem
+    SphereHomology.Latitude.head_bounds (n : ℕ) (y : SphereHomology.UnitSphere (n + 1)) :
+    -1 ≤ y.val 0 ∧ y.val 0 ≤ 1 := by
+  have h := head_tail_norm_sq n y
+  constructor
+  · nlinarith [sq_nonneg ‖tail n y‖, sq_nonneg (y.val 0 + 1)]
+  · nlinarith [sq_nonneg ‖tail n y‖, sq_nonneg (y.val 0 - 1)]
+
+private def SphereHomology.Latitude.parameter (n : ℕ) (y : SphereHomology.UnitSphere (n + 1)) :
+    unitInterval :=
+  ⟨(y.val 0 + 1) / 2, by
+    have h := head_bounds n y
+    constructor <;> linarith [h.1, h.2]⟩
+
+@[simp]
+private theorem
+    SphereHomology.Latitude.height_parameter (n : ℕ) (y : SphereHomology.UnitSphere (n + 1)) :
+    height (parameter n y) = y.val 0 := by
+  change 2 * ((y.val 0 + 1) / 2) - 1 = y.val 0
+  ring
+
+private theorem SphereHomology.Latitude.radius_parameter_eq_norm_tail (n : ℕ)
+    (y : SphereHomology.UnitSphere (n + 1)) : radius (parameter n y) = ‖tail n y‖ := by
+  apply (sq_eq_sq₀ (radius_nonneg _) (norm_nonneg _)).mp
+  rw [radius_sq, height_parameter]
+  linarith [head_tail_norm_sq n y]
+
+private theorem SphereHomology.Latitude.point_surjective (n : ℕ) :
+    Function.Surjective (fun p : unitInterval × SphereHomology.UnitSphere n => point n p.1 p.2) :=
+  by
+  intro y
+  let t := parameter n y
+  have hr := radius_parameter_eq_norm_tail n y
+  by_cases hzero : radius t = 0
+  · have ht : tail n y = 0 := norm_eq_zero.mp (hr.symm.trans hzero)
+    refine ⟨(t, SphereHomology.basePoint n), ?_⟩
+    ext i
+    refine Fin.cases ?_ (fun j => ?_) i
+    · exact height_parameter n y
+    · change radius t * (SphereHomology.basePoint n).val j = y.val j.succ
+      rw [hzero, MulZeroClass.zero_mul]
+      have hj := congrArg (fun v : EuclideanSpace ℝ (Fin (n + 1)) => v j) ht
+      change y.val j.succ = 0 at hj
+      exact hj.symm
+  · let v : EuclideanSpace ℝ (Fin (n + 1)) := (radius t)⁻¹ • tail n y
+    have hv : ‖v‖ = 1 := by
+      calc
+        ‖v‖ = |(radius t)⁻¹| * ‖tail n y‖ := norm_smul _ _
+        _ = (radius t)⁻¹ * radius t := by rw [abs_inv, abs_of_nonneg (radius_nonneg t), ← hr]
+        _ = 1 := inv_mul_cancel₀ hzero
+    let x : SphereHomology.UnitSphere n :=
+      ⟨v, by simpa only [Metric.mem_sphere, dist_zero_right] using hv⟩
+    refine ⟨(t, x), ?_⟩
+    ext i
+    refine Fin.cases ?_ (fun j => ?_) i
+    · exact height_parameter n y
+    · change radius t * ((radius t)⁻¹ * tail n y j) = y.val j.succ
+      rw [← mul_assoc, mul_inv_cancel₀ hzero, one_mul, tail_apply]
+
+private def SphereHomology.suspensionSphereMap (n : ℕ) :
+    CuspCentralHomology.Suspension (UnitSphere n) → UnitSphere (n + 1) :=
+  Quotient.lift (fun p => Latitude.point n p.1 p.2)
+    (fun p q h => (Latitude.point_eq_iff n p.1 q.1 p.2 q.2).mpr h)
+
+@[continuity, fun_prop]
+private theorem SphereHomology.suspensionSphereMap_continuous (n : ℕ) :
+    Continuous (suspensionSphereMap n) :=
+  CuspCentralHomology.Suspension.isQuotientMap_mk.continuous_iff.mpr (Latitude.point_continuous n)
+
+private theorem SphereHomology.suspensionSphereMap_injective (n : ℕ) :
+    Function.Injective (suspensionSphereMap n) := by
+  intro a b
+  induction a using Quotient.inductionOn with
+  | _ p =>
+    induction b using Quotient.inductionOn with
+    | _ q =>
+      intro h
+      exact Quotient.sound ((Latitude.point_eq_iff n p.1 q.1 p.2 q.2).mp h)
+
+private theorem SphereHomology.suspensionSphereMap_surjective (n : ℕ) :
+    Function.Surjective (suspensionSphereMap n) := by
+  intro y
+  obtain ⟨⟨t, x⟩, h⟩ := Latitude.point_surjective n y
+  exact ⟨CuspCentralHomology.Suspension.mk t x, h⟩
+
+private def SphereHomology.suspensionSphereHomeomorph (n : ℕ) :
+    CuspCentralHomology.Suspension (UnitSphere n) ≃ₜ UnitSphere (n + 1) :=
+  Continuous.homeoOfEquivCompactToT2 (f :=
+    Equiv.ofBijective (suspensionSphereMap n)
+      ⟨suspensionSphereMap_injective n, suspensionSphereMap_surjective n⟩)
+    (suspensionSphereMap_continuous n)
+
+@[simp]
+private theorem SphereHomology.suspensionSphereHomeomorph_mk (n : ℕ) (t : unitInterval)
+    (x : UnitSphere n) :
+    suspensionSphereHomeomorph n (CuspCentralHomology.Suspension.mk t x) = Latitude.point n t x :=
+  rfl
+
+private instance SphereHomology.unitSphere_pathConnectedSpace (n : ℕ) :
+    PathConnectedSpace (UnitSphere (n + 1)) :=
+  (suspensionSphereHomeomorph n).surjective.pathConnectedSpace
+    (suspensionSphereHomeomorph n).continuous
+
+private def
+    SphereHomology.suspensionHomologyHigherEquiv (X : Type) [TopologicalSpace X] [Nonempty X]
+    (k : ℕ) :
+    SingularMayerVietoris.SingularHomology (CuspCentralHomology.Suspension X) (k + 2) ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology X (k + 1) :=
+  (CuspCentralHomology.contractibleCoverHomologyHigherEquiv
+        CuspCentralHomology.Suspension.northOpen CuspCentralHomology.Suspension.southOpen
+        CuspCentralHomology.Suspension.northOpen_isOpen
+        CuspCentralHomology.Suspension.southOpen_isOpen CuspCentralHomology.Suspension.open_cover
+        k).trans
+    (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+      CuspCentralHomology.Suspension.middleBandHomotopyEquiv (k + 1))
+
+private def SphereHomology.unitSphereHomologySuspensionEquiv (n k : ℕ) :
+    SingularMayerVietoris.SingularHomology (UnitSphere (n + 1)) (k + 2) ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (UnitSphere n) (k + 1) :=
+  (PeriodTorusHigherHomology.homeomorphHomologyEquiv (suspensionSphereHomeomorph n).symm
+        (k + 2)).trans
+    (suspensionHomologyHigherEquiv (UnitSphere n) k)
+
+private def SphereHomology.euclideanPlaneComplexIsometry : EuclideanSpace ℝ (Fin 2) ≃ₗᵢ[ℝ] ℂ :=
+  Complex.orthonormalBasisOneI.repr.symm
+
+private theorem
+    SphereHomology.euclideanPlaneComplexIsometry_mem_sphere (x : EuclideanSpace ℝ (Fin 2))
+    (r : ℝ) :
+    euclideanPlaneComplexIsometry x ∈ Metric.sphere (0 : ℂ) r ↔
+      x ∈ Metric.sphere (0 : EuclideanSpace ℝ (Fin 2)) r := by
+  simp only [mem_sphere_zero_iff_norm, LinearIsometryEquiv.norm_map]
+
+private def SphereHomology.sphereCircleHomeomorph :
+    Metric.sphere (0 : EuclideanSpace ℝ (Fin 2)) 1 ≃ₜ _root_.Circle :=
+  euclideanPlaneComplexIsometry.toHomeomorph.subtype
+    (fun x => (euclideanPlaneComplexIsometry_mem_sphere x 1).symm)
+
+private def SphereHomology.sphereCircleHomologyEquiv (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (Metric.sphere (0 : EuclideanSpace ℝ (Fin 2)) 1)
+        n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology _root_.Circle n :=
+  PeriodTorusHigherHomology.homeomorphHomologyEquiv sphereCircleHomeomorph n
+
+private theorem SingularMayerVietoris.ModuleHomology.cyclesMk_eq_moduleCatCyclesIso_inv
+    (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) (n : ℕ)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle K n) (j : ℕ)
+    (hj : (ComplexShape.down ℕ).next n = j) (hc : (K.d n j).hom c.1 = 0) :
+    K.cyclesMk c.1 j hj hc = ((K.sc n).moduleCatCyclesIso.inv).hom c := by
+  apply (ModuleCat.mono_iff_injective (K.iCycles n)).mp inferInstance
+  have h₁ : (K.iCycles n).hom (K.cyclesMk c.1 j hj hc) = c.1 := K.i_cyclesMk c.1 j hj hc
+  have h₂ := congrArg (fun f => f.hom c) ((K.sc n).moduleCatCyclesIso_inv_iCycles)
+  exact h₁.trans h₂.symm
+
+private theorem SingularMayerVietoris.ModuleHomology.cycleClass_eq_homologyClassOfCycle_of_next
+    (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) (n : ℕ)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle K n) (j : ℕ)
+    (hj : (ComplexShape.down ℕ).next n = j) (hc : (K.d n j).hom c.1 = 0) :
+    cycleClass K n c = SingularMayerVietoris.homologyClassOfCycle K c.1 j hj hc := by
+  rw [SingularMayerVietoris.homologyClassOfCycle, cyclesMk_eq_moduleCatCyclesIso_inv]
+  exact (congrArg (fun f => f.hom c) ((K.sc n).moduleCatCyclesIso_inv_π)).symm
+
+private theorem SingularMayerVietoris.ModuleHomology.cycleClass_eq_homologyClassOfCycle
+    (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) (n : ℕ)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle K n) :
+    cycleClass K n c =
+      SingularMayerVietoris.homologyClassOfCycle K c.1 (n - 1) (next_nat n)
+        (cycle_condition K n c) :=
+  cycleClass_eq_homologyClassOfCycle_of_next K n c (n - 1) (next_nat n) (cycle_condition K n c)
+
+private def SphereHomology.unitCircleAddCircleHomeomorph :
+    _root_.Circle ≃ₜ PeriodTorusHigherHomology.CircleTopology.Circle :=
+  (AddCircle.homeomorphCircle (T := (1 : ℝ)) one_ne_zero).symm
+
+private def SphereHomology.unitCircleHomologyEquiv (n : ℕ) :
+    SingularMayerVietoris.SingularHomology _root_.Circle n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology PeriodTorusHigherHomology.CircleTopology.Circle n :=
+  PeriodTorusHigherHomology.homeomorphHomologyEquiv unitCircleAddCircleHomeomorph n
+
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/HomologyTheory/SphereHomology2.lean b/LeanPool/HopfProblem/HomologyTheory/SphereHomology2.lean
new file mode 100644
index 000000000..e02cdfa7b
--- /dev/null
+++ b/LeanPool/HopfProblem/HomologyTheory/SphereHomology2.lean
@@ -0,0 +1,80 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.HomologyTheory.FirstHurewicz1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology3
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz1
+
+/-!
+# Hopf problem: homology theory · sphere homology 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def SphereHomology.unitCircleHomologyOneEquiv :
+    SingularMayerVietoris.SingularHomology _root_.Circle 1 ≃ₗ[ℤ] ℤ :=
+  (unitCircleHomologyEquiv 1).trans PeriodTorusHigherHomology.circleHomologyOneEquiv
+
+private theorem SphereHomology.unitCircle_homology_subsingleton (n : ℕ) :
+    Subsingleton (SingularMayerVietoris.SingularHomology _root_.Circle (n + 2)) := by
+  let := PeriodTorusHigherHomology.circle_homology_subsingleton n
+  exact (unitCircleHomologyEquiv (n + 2)).injective.subsingleton
+
+
+private def SphereHomology.sphereCircleHomologyOneEquiv :
+    SingularMayerVietoris.SingularHomology (Metric.sphere (0 : EuclideanSpace ℝ (Fin 2)) 1)
+        1 ≃ₗ[ℤ]
+      ℤ :=
+  (sphereCircleHomologyEquiv 1).trans unitCircleHomologyOneEquiv
+
+public
+theorem SphereHomology.sphereCircle_homology_subsingleton (n : ℕ) :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology (Metric.sphere (0 : EuclideanSpace ℝ (Fin 2)) 1)
+        (n + 2)) := by
+  let := unitCircle_homology_subsingleton n
+  exact (sphereCircleHomologyEquiv (n + 2)).injective.subsingleton
+
+private def SphereHomology.unitSphereHomologyZeroEquiv (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (UnitSphere (n + 1)) 0 ≃ₗ[ℤ] ℤ :=
+  PeriodTorusHigherHomology.connectedHomologyZeroEquiv (UnitSphere (n + 1))
+
+private def SphereHomology.unitSphereHomologyTopEquiv :
+    (n : ℕ) → SingularMayerVietoris.SingularHomology (UnitSphere (n + 1)) (n + 1) ≃ₗ[ℤ] ℤ
+  | 0 => sphereCircleHomologyOneEquiv
+  | n + 1 => (unitSphereHomologySuspensionEquiv (n + 1) n).trans (unitSphereHomologyTopEquiv n)
+
+private def SphereHomology.unitSphereTopClass (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (UnitSphere (n + 1)) (n + 1) :=
+  (unitSphereHomologyTopEquiv n).symm 1
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/HomologyTheory/SphereHomology3.lean b/LeanPool/HopfProblem/HomologyTheory/SphereHomology3.lean
new file mode 100644
index 000000000..a76922f50
--- /dev/null
+++ b/LeanPool/HopfProblem/HomologyTheory/SphereHomology3.lean
@@ -0,0 +1,119 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology4
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.CuspFibre.CuspCentralHomology2
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology1
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz1
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology4
+
+/-!
+# Hopf problem: homology theory · sphere homology 3
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private instance
+    SphereHomology.suspension_middleBand_pathConnectedSpace (X : Type) [TopologicalSpace X]
+    [PathConnectedSpace X] : PathConnectedSpace (CuspCentralHomology.Suspension.middleBand X) :=
+  (CuspCentralHomology.Suspension.middleBandHomeomorph (X :=
+        X)).symm.surjective.pathConnectedSpace
+    (CuspCentralHomology.Suspension.middleBandHomeomorph (X := X)).symm.continuous
+
+private def
+    SphereHomology.suspensionHomologyOneEquivKernel (X : Type) [TopologicalSpace X] [Nonempty X] :
+    SingularMayerVietoris.SingularHomology (CuspCentralHomology.Suspension X) 1 ≃ₗ[ℤ]
+      LinearMap.ker
+        (SingularMayerVietoris.leftHomologyMap
+          ((CuspCentralHomology.Suspension.northOpen : Set (CuspCentralHomology.Suspension X)))
+          ((CuspCentralHomology.Suspension.southOpen : Set (CuspCentralHomology.Suspension X)))
+          0) :=
+  CuspCentralHomology.contractibleCoverHomologyOneEquivKernel
+    ((CuspCentralHomology.Suspension.northOpen : Set (CuspCentralHomology.Suspension X)))
+    ((CuspCentralHomology.Suspension.southOpen : Set (CuspCentralHomology.Suspension X)))
+    CuspCentralHomology.Suspension.northOpen_isOpen
+    CuspCentralHomology.Suspension.southOpen_isOpen CuspCentralHomology.Suspension.open_cover
+
+private theorem SphereHomology.suspensionLeftHomologyMap_zero_ker (X : Type) [TopologicalSpace X]
+    [PathConnectedSpace X] :
+    LinearMap.ker
+        (SingularMayerVietoris.leftHomologyMap
+          ((CuspCentralHomology.Suspension.northOpen : Set (CuspCentralHomology.Suspension X)))
+          ((CuspCentralHomology.Suspension.southOpen : Set (CuspCentralHomology.Suspension X)))
+          0) =
+      ⊥ :=
+  leftHomologyMap_zero_ker
+    ((CuspCentralHomology.Suspension.northOpen : Set (CuspCentralHomology.Suspension X)))
+    ((CuspCentralHomology.Suspension.southOpen : Set (CuspCentralHomology.Suspension X)))
+
+private theorem SphereHomology.suspension_homology_one_subsingleton (X : Type) [TopologicalSpace X]
+    [PathConnectedSpace X] :
+    Subsingleton (SingularMayerVietoris.SingularHomology (CuspCentralHomology.Suspension X) 1) := by
+  let :
+    Subsingleton
+      (LinearMap.ker
+        (SingularMayerVietoris.leftHomologyMap
+          ((CuspCentralHomology.Suspension.northOpen : Set (CuspCentralHomology.Suspension X)))
+          ((CuspCentralHomology.Suspension.southOpen : Set (CuspCentralHomology.Suspension X)))
+          0)) := by
+    rw [suspensionLeftHomologyMap_zero_ker X]
+    infer_instance
+  exact (suspensionHomologyOneEquivKernel X).injective.subsingleton
+
+private theorem SphereHomology.unitSphere_homology_one_subsingleton (n : ℕ) :
+    Subsingleton (SingularMayerVietoris.SingularHomology (UnitSphere (n + 2)) 1) := by
+  let := suspension_homology_one_subsingleton (UnitSphere (n + 1))
+  exact
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv (suspensionSphereHomeomorph (n + 1)).symm
+        1).injective.subsingleton
+
+public
+theorem SphereHomology.unitSphere_homology_subsingleton (n k : ℕ) (hk : k ≠ 0) (hkn : k ≠ n + 1) :
+    Subsingleton (SingularMayerVietoris.SingularHomology (UnitSphere (n + 1)) k) := by
+  induction n generalizing k with
+  | zero =>
+    cases k with
+    | zero => exact (hk rfl).elim
+    | succ k =>
+      cases k with
+      | zero => exact (hkn rfl).elim
+      | succ k => exact sphereCircle_homology_subsingleton k
+  | succ n ih =>
+    cases k with
+    | zero => exact (hk rfl).elim
+    | succ k =>
+      cases k with
+      | zero => exact unitSphere_homology_one_subsingleton n
+      | succ k =>
+        let := ih (k + 1) (Nat.succ_ne_zero _) (by omega)
+        exact (unitSphereHomologySuspensionEquiv (n + 1) k).injective.subsingleton
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Hurewicz/HigherHurewicz1.lean b/LeanPool/HopfProblem/Hurewicz/HigherHurewicz1.lean
new file mode 100644
index 000000000..2763e3b99
--- /dev/null
+++ b/LeanPool/HopfProblem/Hurewicz/HigherHurewicz1.lean
@@ -0,0 +1,5706 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology3
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology4
+import all LeanPool.HopfProblem.Hurewicz.SecondHurewicz
+import all LeanPool.HopfProblem.Hurewicz.ThirdHurewicz
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology5
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology3
+import all Mathlib.Data.Fin.Tuple.Sort
+
+/-!
+# Hopf problem: hurewicz · higher hurewicz 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem
+    ThirdHurewicz.basedFourSimplex_signed_relation {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    ∑ i : Fin 5, (-1 : ℤ) ^ i.val • basedThreeSimplexClass (basedFourSimplexFace τ i) = 0 := by
+  have h := basedFourSimplex_boundary_relation τ
+  simpa [Fin.sum_univ_succ, sub_eq_add_neg, add_assoc] using h
+
+private theorem
+    ThirdHurewicz.normalizedThreeSimplex_boundary_relation {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 4) :
+    ∑ i : Fin 5,
+        (-1 : ℤ) ^ i.val •
+          basedThreeSimplexClass
+            (normalizedThreeSimplex x (smp.comp (FirstHurewicz.simplexFace 3 i))) =
+      0 := by
+  simpa only [normalizedFourSimplex_face] using
+    basedFourSimplex_signed_relation (normalizedFourSimplex x smp)
+
+private theorem ThirdHurewicz.threeSimplexClassOperator_boundary {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] (b : FirstHurewicz.Chains X 4) :
+    threeSimplexClassOperator x (((FirstHurewicz.singularComplex X).d 4 3).hom b) = 0 := by
+  have h : (threeSimplexClassOperator x).comp ((FirstHurewicz.singularComplex X).d 4 3).hom = 0 :=
+    by
+    apply FirstHurewicz.chainMap_ext X 4
+    intro smp
+    simp only [LinearMap.comp_apply, FirstHurewicz.boundary_simplex, map_sum, map_zsmul,
+      threeSimplexClassOperator_simplex, LinearMap.zero_apply]
+    exact normalizedThreeSimplex_boundary_relation x smp
+  exact LinearMap.congr_fun h b
+
+private def ThirdHurewicz.cylinderHomotopy {A X : Type} [TopologicalSpace A] [TopologicalSpace X]
+    (H : C((unitInterval) × A, X)) :
+    ContinuousMap.Homotopy (SecondHurewicz.SimplyConnected.timeSlice H 0)
+      (SecondHurewicz.SimplyConnected.timeSlice H 1)
+    where
+  toContinuousMap := H
+  map_zero_left _ := rfl
+  map_one_left _ := rfl
+
+private theorem ThirdHurewicz.homotopyTrans_compContinuousMap {A B X : Type} [TopologicalSpace A]
+    [TopologicalSpace B] [TopologicalSpace X] {f₀ f₁ f₂ : C(A, X)} (F : f₀.Homotopy f₁)
+    (G : f₁.Homotopy f₂) (f : C(B, A)) :
+    (F.trans G).toContinuousMap.comp ((ContinuousMap.id (unitInterval)).prodMap f) =
+      ((F.compContinuousMap f).trans (G.compContinuousMap f)).toContinuousMap := by
+  ext z
+  change (F.trans G) (z.1, f z.2) = ((F.compContinuousMap f).trans (G.compContinuousMap f)) z
+  simp only [ContinuousMap.Homotopy.trans_apply]
+  split_ifs <;> rfl
+
+private theorem
+    ThirdHurewicz.homotopyTrans_const {A X : Type} [TopologicalSpace A] [TopologicalSpace X]
+    {f₀ f₁ f₂ : C(A, X)} (F : f₀.Homotopy f₁) (G : f₁.Homotopy f₂) (x : X)
+    (hF : F.toContinuousMap = ContinuousMap.const ((unitInterval) × A) x)
+    (hG : G.toContinuousMap = ContinuousMap.const ((unitInterval) × A) x) :
+    (F.trans G).toContinuousMap = ContinuousMap.const ((unitInterval) × A) x := by
+  ext z
+  change (F.trans G) z = x
+  rw [ContinuousMap.Homotopy.trans_apply]
+  split_ifs
+  · exact ContinuousMap.congr_fun hF _
+  · exact ContinuousMap.congr_fun hG _
+
+private theorem
+    ThirdHurewicz.homotopyTrans_congr {A X : Type} [TopologicalSpace A] [TopologicalSpace X]
+    {f₀ f₁ f₂ g₀ g₁ g₂ : C(A, X)} (F : f₀.Homotopy f₁) (G : f₁.Homotopy f₂) (F' : g₀.Homotopy g₁)
+    (G' : g₁.Homotopy g₂) (hF : F.toContinuousMap = F'.toContinuousMap)
+    (hG : G.toContinuousMap = G'.toContinuousMap) :
+    (F.trans G).toContinuousMap = (F'.trans G').toContinuousMap := by
+  ext z
+  change (F.trans G) z = (F'.trans G') z
+  simp only [ContinuousMap.Homotopy.trans_apply]
+  split_ifs
+  · exact ContinuousMap.congr_fun hF _
+  · exact ContinuousMap.congr_fun hG _
+
+private def ThirdHurewicz.simplexFamilyHomotopy {X : Type} [TopologicalSpace X] {n : ℕ}
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (h₀ : ∀ smp s, H smp (0, s) = smp s) (smp : FirstHurewicz.SingularSimplex X n) :
+    smp.Homotopy (SecondHurewicz.SimplyConnected.timeSlice (H smp) 1) :=
+  (cylinderHomotopy (H smp)).cast (by ext s; exact h₀ smp s) rfl
+
+private def ThirdHurewicz.composeSimplexHomotopies {X : Type} [TopologicalSpace X] {n : ℕ}
+    (H G : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (hH₀ : ∀ smp s, H smp (0, s) = smp s) (hG₀ : ∀ smp s, G smp (0, s) = smp s)
+    (smp : FirstHurewicz.SingularSimplex X n) : C((unitInterval) × FirstHurewicz.Simplex n, X) :=
+  ((simplexFamilyHomotopy H hH₀ smp).trans
+      (simplexFamilyHomotopy G hG₀
+        (SecondHurewicz.SimplyConnected.timeSlice (H smp) 1))).toContinuousMap
+
+@[simp]
+private theorem ThirdHurewicz.composeSimplexHomotopies_zero {X : Type} [TopologicalSpace X] {n : ℕ}
+    (H G : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (hH₀ : ∀ smp s, H smp (0, s) = smp s) (hG₀ : ∀ smp s, G smp (0, s) = smp s)
+    (smp : FirstHurewicz.SingularSimplex X n) (s : FirstHurewicz.Simplex n) :
+    composeSimplexHomotopies H G hH₀ hG₀ smp (0, s) = smp s :=
+  ContinuousMap.Homotopy.apply_zero _ s
+
+@[simp]
+private theorem ThirdHurewicz.composeSimplexHomotopies_one {X : Type} [TopologicalSpace X] {n : ℕ}
+    (H G : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (hH₀ : ∀ smp s, H smp (0, s) = smp s) (hG₀ : ∀ smp s, G smp (0, s) = smp s)
+    (smp : FirstHurewicz.SingularSimplex X n) (s : FirstHurewicz.Simplex n) :
+    composeSimplexHomotopies H G hH₀ hG₀ smp (1, s) =
+      G (SecondHurewicz.SimplyConnected.timeSlice (H smp) 1) (1, s) :=
+  ContinuousMap.Homotopy.apply_one _ s
+
+@[simp]
+private theorem ThirdHurewicz.timeSlice_composeSimplexHomotopies_one {X : Type} [TopologicalSpace X]
+    {n : ℕ}
+    (H G : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (hH₀ : ∀ smp s, H smp (0, s) = smp s) (hG₀ : ∀ smp s, G smp (0, s) = smp s)
+    (smp : FirstHurewicz.SingularSimplex X n) :
+    SecondHurewicz.SimplyConnected.timeSlice (composeSimplexHomotopies H G hH₀ hG₀ smp) 1 =
+      SecondHurewicz.SimplyConnected.timeSlice
+        (G (SecondHurewicz.SimplyConnected.timeSlice (H smp) 1)) 1 := by
+  ext s
+  exact composeSimplexHomotopies_one H G hH₀ hG₀ smp s
+
+private theorem ThirdHurewicz.composeSimplexHomotopies_face {X : Type} [TopologicalSpace X] {n : ℕ}
+    (H G : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' G' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (hH₀ : ∀ smp s, H smp (0, s) = smp s) (hG₀ : ∀ smp s, G smp (0, s) = smp s)
+    (hH'₀ : ∀ smp s, H' smp (0, s) = smp s) (hG'₀ : ∀ smp s, G' smp (0, s) = smp s)
+    (hH : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H H')
+    (hG : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n G G') :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n
+      (composeSimplexHomotopies H G hH₀ hG₀) (composeSimplexHomotopies H' G' hH'₀ hG'₀) := by
+  intro smp i
+  unfold composeSimplexHomotopies
+  rw [homotopyTrans_compContinuousMap]
+  apply homotopyTrans_congr
+  · change
+      (H' smp).comp ((ContinuousMap.id (unitInterval)).prodMap (FirstHurewicz.simplexFace n i)) =
+        H (smp.comp (FirstHurewicz.simplexFace n i))
+    exact hH smp i
+  · change
+      (G' (SecondHurewicz.SimplyConnected.timeSlice (H' smp) 1)).comp
+          ((ContinuousMap.id (unitInterval)).prodMap (FirstHurewicz.simplexFace n i)) =
+        G
+          (SecondHurewicz.SimplyConnected.timeSlice (H (smp.comp (FirstHurewicz.simplexFace n i)))
+            1)
+    rw [hG (SecondHurewicz.SimplyConnected.timeSlice (H' smp) 1) i,
+      SecondHurewicz.SimplyConnected.timeSlice_face hH smp i 1]
+
+private theorem ThirdHurewicz.composeSimplexHomotopies_const {X : Type} [TopologicalSpace X] {n : ℕ}
+    (H G : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (hH₀ : ∀ smp s, H smp (0, s) = smp s) (hG₀ : ∀ smp s, G smp (0, s) = smp s) (x : X)
+    (hH :
+      H (ContinuousMap.const (FirstHurewicz.Simplex n) x) =
+        ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex n) x)
+    (hG :
+      G (ContinuousMap.const (FirstHurewicz.Simplex n) x) =
+        ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex n) x) :
+    composeSimplexHomotopies H G hH₀ hG₀ (ContinuousMap.const (FirstHurewicz.Simplex n) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex n) x := by
+  have h₁ :
+    SecondHurewicz.SimplyConnected.timeSlice (H (ContinuousMap.const (FirstHurewicz.Simplex n) x))
+        1 =
+      ContinuousMap.const (FirstHurewicz.Simplex n) x := by
+    rw [hH]
+    rfl
+  unfold composeSimplexHomotopies
+  apply homotopyTrans_const
+  · exact hH
+  · change
+      G
+          (SecondHurewicz.SimplyConnected.timeSlice
+            (H (ContinuousMap.const (FirstHurewicz.Simplex n) x)) 1) =
+        _
+    rw [h₁]
+    exact hG
+
+private def ThirdHurewicz.vertexEdgeTriangleHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) :
+    FirstHurewicz.SingularSimplex X 2 → C((unitInterval) × FirstHurewicz.Simplex 2, X) :=
+  composeSimplexHomotopies (SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy x 2)
+    (SecondHurewicz.SimplyConnected.triangleEdgeStraighteningHomotopy x)
+    (SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy_zero x 2)
+    (SecondHurewicz.SimplyConnected.triangleEdgeStraighteningHomotopy_zero x)
+
+private def ThirdHurewicz.vertexEdgeThreeSimplexHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) :
+    FirstHurewicz.SingularSimplex X 3 → C((unitInterval) × FirstHurewicz.Simplex 3, X) :=
+  composeSimplexHomotopies (SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy x 3)
+    (SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy x)
+    (SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy_zero x 3)
+    (SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy_zero x)
+
+@[simp]
+private theorem ThirdHurewicz.vertexEdgeTriangleHomotopy_zero {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (smp : FirstHurewicz.SingularSimplex X 2)
+    (s : FirstHurewicz.Simplex 2) : vertexEdgeTriangleHomotopy x smp (0, s) = smp s :=
+  composeSimplexHomotopies_zero _ _ _ _ smp s
+
+@[simp]
+private theorem ThirdHurewicz.vertexEdgeThreeSimplexHomotopy_zero {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (smp : FirstHurewicz.SingularSimplex X 3)
+    (s : FirstHurewicz.Simplex 3) : vertexEdgeThreeSimplexHomotopy x smp (0, s) = smp s :=
+  composeSimplexHomotopies_zero _ _ _ _ smp s
+
+private theorem ThirdHurewicz.vertexEdgeHomotopy_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 2 (vertexEdgeTriangleHomotopy x)
+      (vertexEdgeThreeSimplexHomotopy x) :=
+  composeSimplexHomotopies_face (SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy x 2)
+    (SecondHurewicz.SimplyConnected.triangleEdgeStraighteningHomotopy x)
+    (SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy x 3)
+    (SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy x)
+    (SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy_zero x 2)
+    (SecondHurewicz.SimplyConnected.triangleEdgeStraighteningHomotopy_zero x)
+    (SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy_zero x 3)
+    (SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy_zero x)
+    (SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy_face x 2)
+    (SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy_face x)
+
+@[simp]
+private theorem ThirdHurewicz.vertexEdgeTriangleHomotopy_const {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) :
+    vertexEdgeTriangleHomotopy x (ContinuousMap.const (FirstHurewicz.Simplex 2) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 2) x :=
+  composeSimplexHomotopies_const (SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy x 2)
+    (SecondHurewicz.SimplyConnected.triangleEdgeStraighteningHomotopy x)
+    (SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy_zero x 2)
+    (SecondHurewicz.SimplyConnected.triangleEdgeStraighteningHomotopy_zero x) x
+    (SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy_const x 2)
+    (edgeTriangleHomotopy_const x)
+
+@[simp]
+private theorem
+    ThirdHurewicz.vertexEdgeThreeSimplexHomotopy_endpoint {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (smp : FirstHurewicz.SingularSimplex X 3) :
+    SecondHurewicz.SimplyConnected.timeSlice (vertexEdgeThreeSimplexHomotopy x smp) 1 =
+      SecondHurewicz.SimplyConnected.normalizedTetrahedronMap x smp := by
+  rw [vertexEdgeThreeSimplexHomotopy, timeSlice_composeSimplexHomotopies_one]
+  rfl
+
+private def ThirdHurewicz.normalizationTriangleHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] :
+    FirstHurewicz.SingularSimplex X 2 → C((unitInterval) × FirstHurewicz.Simplex 2, X) :=
+  composeSimplexHomotopies (vertexEdgeTriangleHomotopy x) (triangleStraighteningHomotopy x)
+    (vertexEdgeTriangleHomotopy_zero x) (triangleStraighteningHomotopy_zero x)
+
+private def ThirdHurewicz.normalizationThreeSimplexHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] :
+    FirstHurewicz.SingularSimplex X 3 → C((unitInterval) × FirstHurewicz.Simplex 3, X) :=
+  composeSimplexHomotopies (vertexEdgeThreeSimplexHomotopy x) (triangleThreeSimplexHomotopy x)
+    (vertexEdgeThreeSimplexHomotopy_zero x) (triangleThreeSimplexHomotopy_zero x)
+
+@[simp]
+private theorem ThirdHurewicz.normalizationThreeSimplexHomotopy_zero {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 3) (s : FirstHurewicz.Simplex 3) :
+    normalizationThreeSimplexHomotopy x smp (0, s) = smp s :=
+  composeSimplexHomotopies_zero _ _ _ _ smp s
+
+private theorem ThirdHurewicz.normalizationHomotopy_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 2 (normalizationTriangleHomotopy x)
+      (normalizationThreeSimplexHomotopy x) :=
+  composeSimplexHomotopies_face (vertexEdgeTriangleHomotopy x) (triangleStraighteningHomotopy x)
+    (vertexEdgeThreeSimplexHomotopy x) (triangleThreeSimplexHomotopy x)
+    (vertexEdgeTriangleHomotopy_zero x) (triangleStraighteningHomotopy_zero x)
+    (vertexEdgeThreeSimplexHomotopy_zero x) (triangleThreeSimplexHomotopy_zero x)
+    (vertexEdgeHomotopy_face x) (triangleThreeSimplexHomotopy_face x)
+
+@[simp]
+private theorem ThirdHurewicz.normalizationTriangleHomotopy_const {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] :
+    normalizationTriangleHomotopy x (ContinuousMap.const (FirstHurewicz.Simplex 2) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 2) x :=
+  composeSimplexHomotopies_const (vertexEdgeTriangleHomotopy x) (triangleStraighteningHomotopy x)
+    (vertexEdgeTriangleHomotopy_zero x) (triangleStraighteningHomotopy_zero x) x
+    (vertexEdgeTriangleHomotopy_const x) (triangleStraighteningHomotopy_const x)
+
+@[simp]
+private theorem
+    ThirdHurewicz.normalizationThreeSimplexHomotopy_endpoint {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 3) :
+    SecondHurewicz.SimplyConnected.timeSlice (normalizationThreeSimplexHomotopy x smp) 1 =
+      (normalizedThreeSimplex x smp).val := by
+  rw [normalizationThreeSimplexHomotopy, timeSlice_composeSimplexHomotopies_one,
+    vertexEdgeThreeSimplexHomotopy_endpoint]
+  rfl
+
+private abbrev ThirdHurewicz.CubeTriangulation.SortedCoordinates {α : Type*} [LinearOrder α]
+    (u : Fin 3 → α) (e : Equiv.Perm (Fin 3)) : Prop :=
+  u (e 2) ≤ u (e 1) ∧ u (e 1) ≤ u (e 0)
+
+private theorem ThirdHurewicz.CubeTriangulation.exists_sortedPermutation {α : Type*} [LinearOrder α]
+    (u : Fin 3 → α) : ∃ e : Equiv.Perm (Fin 3), SortedCoordinates u e := by
+  rcases le_total (u 0) (u 1) with h01 | h10
+  · rcases le_total (u 1) (u 2) with h12 | h21
+    · refine ⟨Equiv.swap 0 2, ?_⟩
+      simpa [SortedCoordinates, Equiv.swap_apply_def] using And.intro h01 h12
+    · rcases le_total (u 0) (u 2) with h02 | h20
+      · refine ⟨(Equiv.swap 0 1).trans (Equiv.swap 0 2), ?_⟩
+        simpa [SortedCoordinates, Equiv.swap_apply_def] using And.intro h02 h21
+      · refine ⟨Equiv.swap 0 1, ?_⟩
+        simpa [SortedCoordinates, Equiv.swap_apply_def] using And.intro h20 h01
+  · rcases le_total (u 0) (u 2) with h02 | h20
+    · refine ⟨(Equiv.swap 0 2).trans (Equiv.swap 0 1), ?_⟩
+      simpa [SortedCoordinates, Equiv.swap_apply_def] using And.intro h10 h02
+    · rcases le_total (u 1) (u 2) with h12 | h21
+      · refine ⟨Equiv.swap 1 2, ?_⟩
+        simpa [SortedCoordinates, Equiv.swap_apply_def] using And.intro h12 h20
+      · exact ⟨Equiv.refl (Fin 3), h21, h10⟩
+
+private def ThirdHurewicz.CubeTriangulation.cubeOrderedRegion (e : Equiv.Perm (Fin 3)) :
+    Set ThirdHurewicz.Geometry.Cube3 :=
+  {u | SortedCoordinates u e}
+
+private theorem ThirdHurewicz.CubeTriangulation.continuous_cubeCoordinate (i : Fin 3) :
+    Continuous (fun u : ThirdHurewicz.Geometry.Cube3 => (u i : ℝ)) :=
+  continuous_subtype_val.comp (continuous_apply i)
+
+private def ThirdHurewicz.CubeTriangulation.cubeBarycentric (e : Equiv.Perm (Fin 3))
+    (u : ThirdHurewicz.Geometry.Cube3) : Fin 4 → ℝ :=
+  ![1 - (u (e 0) : ℝ), (u (e 0) : ℝ) - u (e 1), (u (e 1) : ℝ) - u (e 2), (u (e 2) : ℝ)]
+
+private theorem ThirdHurewicz.CubeTriangulation.cubeBarycentric_nonneg (e : Equiv.Perm (Fin 3))
+    (u : ThirdHurewicz.Geometry.Cube3) (h : SortedCoordinates u e) (i : Fin 4) :
+    0 ≤ cubeBarycentric e u i := by
+  fin_cases i
+  · exact sub_nonneg.mpr (u (e 0)).property.2
+  · exact sub_nonneg.mpr h.2
+  · exact sub_nonneg.mpr h.1
+  · exact (u (e 2)).property.1
+
+private theorem ThirdHurewicz.CubeTriangulation.cubeBarycentric_sum (e : Equiv.Perm (Fin 3))
+    (u : ThirdHurewicz.Geometry.Cube3) : ∑ i, cubeBarycentric e u i = 1 := by
+  simp [cubeBarycentric, Fin.sum_univ_succ]
+
+private def ThirdHurewicz.CubeTriangulation.cubeTetrahedronInverse (e : Equiv.Perm (Fin 3)) :
+    C(↥(cubeOrderedRegion e), FirstHurewicz.Simplex 3)
+    where
+  toFun
+    u :=
+    ⟨cubeBarycentric e u.val,
+      ⟨cubeBarycentric_nonneg e u.val u.property, cubeBarycentric_sum e u.val⟩⟩
+  continuous_toFun := by
+    have hc (i : Fin 3) : Continuous (fun u : ↥(cubeOrderedRegion e) => (u.val i : ℝ)) :=
+      (continuous_cubeCoordinate i).comp continuous_subtype_val
+    apply Continuous.subtype_mk
+    apply continuous_pi
+    intro i
+    fin_cases i
+    · exact continuous_const.sub (hc (e 0))
+    · exact (hc (e 0)).sub (hc (e 1))
+    · exact (hc (e 1)).sub (hc (e 2))
+    · exact hc (e 2)
+
+private theorem ThirdHurewicz.CubeTriangulation.cubeTetrahedron_sorted (e : Equiv.Perm (Fin 3))
+    (s : FirstHurewicz.Simplex 3) :
+    SortedCoordinates (ThirdHurewicz.Geometry.cubeTetrahedron e s) e :=
+  ⟨ThirdHurewicz.Geometry.cubeTetrahedron_order_second e s,
+    ThirdHurewicz.Geometry.cubeTetrahedron_order_first e s⟩
+
+@[simp]
+private theorem ThirdHurewicz.CubeTriangulation.cubeTetrahedron_inverse (e : Equiv.Perm (Fin 3))
+    (u : ↥(cubeOrderedRegion e)) :
+    ThirdHurewicz.Geometry.cubeTetrahedron e (cubeTetrahedronInverse e u) = u.val := by
+  funext k
+  obtain ⟨j, rfl⟩ := e.surjective k
+  apply Subtype.ext
+  fin_cases j
+  · change
+      (ThirdHurewicz.Geometry.cubeTetrahedron e (cubeTetrahedronInverse e u) (e 0) : ℝ) =
+        (u.val (e 0) : ℝ)
+    rw [ThirdHurewicz.Geometry.cubeTetrahedron_coordinate_zero]
+    change
+      ((u.val (e 0) : ℝ) - u.val (e 1)) + ((u.val (e 1) : ℝ) - u.val (e 2)) + u.val (e 2) =
+        (u.val (e 0) : ℝ)
+    ring
+  · change
+      (ThirdHurewicz.Geometry.cubeTetrahedron e (cubeTetrahedronInverse e u) (e 1) : ℝ) =
+        (u.val (e 1) : ℝ)
+    rw [ThirdHurewicz.Geometry.cubeTetrahedron_coordinate_one]
+    change ((u.val (e 1) : ℝ) - u.val (e 2)) + u.val (e 2) = (u.val (e 1) : ℝ)
+    ring
+  · change
+      (ThirdHurewicz.Geometry.cubeTetrahedron e (cubeTetrahedronInverse e u) (e 2) : ℝ) =
+        (u.val (e 2) : ℝ)
+    rw [ThirdHurewicz.Geometry.cubeTetrahedron_coordinate_two]
+    rfl
+
+@[simp]
+private theorem ThirdHurewicz.CubeTriangulation.cubeTetrahedronInverse_tetrahedron
+    (e : Equiv.Perm (Fin 3)) (s : FirstHurewicz.Simplex 3) :
+    cubeTetrahedronInverse e
+        ⟨ThirdHurewicz.Geometry.cubeTetrahedron e s, cubeTetrahedron_sorted e s⟩ =
+      s := by
+  apply Subtype.ext
+  funext i
+  change cubeBarycentric e (ThirdHurewicz.Geometry.cubeTetrahedron e s) i = s i
+  fin_cases i
+  · change 1 - (ThirdHurewicz.Geometry.cubeTetrahedron e s (e 0) : ℝ) = s 0
+    rw [ThirdHurewicz.Geometry.cubeTetrahedron_coordinate_zero]
+    have hs := stdSimplex.sum_eq_one s
+    simp only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero] at hs
+    change s 0 + (s 1 + (s 2 + s 3)) = 1 at hs
+    linarith
+  · change
+      (ThirdHurewicz.Geometry.cubeTetrahedron e s (e 0) : ℝ) -
+          ThirdHurewicz.Geometry.cubeTetrahedron e s (e 1) =
+        s 1
+    rw [ThirdHurewicz.Geometry.cubeTetrahedron_coordinate_zero,
+      ThirdHurewicz.Geometry.cubeTetrahedron_coordinate_one]
+    ring
+  · change
+      (ThirdHurewicz.Geometry.cubeTetrahedron e s (e 1) : ℝ) -
+          ThirdHurewicz.Geometry.cubeTetrahedron e s (e 2) =
+        s 2
+    rw [ThirdHurewicz.Geometry.cubeTetrahedron_coordinate_one,
+      ThirdHurewicz.Geometry.cubeTetrahedron_coordinate_two]
+    ring
+  · change (ThirdHurewicz.Geometry.cubeTetrahedron e s (e 2) : ℝ) = s 3
+    exact ThirdHurewicz.Geometry.cubeTetrahedron_coordinate_two e s
+
+private theorem ThirdHurewicz.CubeTriangulation.cubeTetrahedron_injective (e : Equiv.Perm (Fin 3)) :
+    Function.Injective (ThirdHurewicz.Geometry.cubeTetrahedron e) := by
+  intro s t h
+  have hh :
+    (⟨ThirdHurewicz.Geometry.cubeTetrahedron e s, cubeTetrahedron_sorted e s⟩ :
+        ↥(cubeOrderedRegion e)) =
+      ⟨ThirdHurewicz.Geometry.cubeTetrahedron e t, cubeTetrahedron_sorted e t⟩ :=
+    Subtype.ext h
+  simpa only [cubeTetrahedronInverse_tetrahedron] using congrArg (cubeTetrahedronInverse e) hh
+
+private theorem ThirdHurewicz.CubeTriangulation.exists_cubeTetrahedron
+    (u : ThirdHurewicz.Geometry.Cube3) :
+    ∃ e : Equiv.Perm (Fin 3),
+      ∃ s : FirstHurewicz.Simplex 3, ThirdHurewicz.Geometry.cubeTetrahedron e s = u := by
+  obtain ⟨e, he⟩ := exists_sortedPermutation u
+  exact ⟨e, cubeTetrahedronInverse e ⟨u, he⟩, cubeTetrahedron_inverse e ⟨u, he⟩⟩
+
+private def ThirdHurewicz.CubeTriangulation.cubeTetrahedronCylinder (e : Equiv.Perm (Fin 3)) :
+    C((unitInterval) × FirstHurewicz.Simplex 3, (unitInterval) × ThirdHurewicz.Geometry.Cube3) :=
+  (ContinuousMap.id (unitInterval)).prodMap (ThirdHurewicz.Geometry.cubeTetrahedron e)
+
+private def ThirdHurewicz.CubeTriangulation.cubeCylinderCover :
+    C((Σ _e : Equiv.Perm (Fin 3), (unitInterval) × FirstHurewicz.Simplex 3),
+      (unitInterval) × ThirdHurewicz.Geometry.Cube3)
+    where
+  toFun a := cubeTetrahedronCylinder a.fst a.snd
+  continuous_toFun := continuous_sigma fun e => (cubeTetrahedronCylinder e).continuous
+
+private theorem ThirdHurewicz.CubeTriangulation.cubeCylinderCover_surjective :
+    Function.Surjective cubeCylinderCover := by
+  rintro ⟨r, u⟩
+  obtain ⟨e, s, rfl⟩ := exists_cubeTetrahedron u
+  exact ⟨⟨e, (r, s)⟩, rfl⟩
+
+private theorem ThirdHurewicz.CubeTriangulation.cubeCylinderCover_isQuotientMap :
+    Topology.IsQuotientMap cubeCylinderCover :=
+  Topology.IsQuotientMap.of_surjective_continuous cubeCylinderCover_surjective
+    cubeCylinderCover.continuous
+
+private def ThirdHurewicz.CubeGluing.CubeCompatible {X : Type} [TopologicalSpace X]
+    (F : Equiv.Perm (Fin 3) → C((unitInterval) × FirstHurewicz.Simplex 3, X)) : Prop :=
+  ∀ (e f : Equiv.Perm (Fin 3)) (s t : FirstHurewicz.Simplex 3),
+    ThirdHurewicz.Geometry.cubeTetrahedron e s = ThirdHurewicz.Geometry.cubeTetrahedron f t →
+      ∀ r : (unitInterval), F e (r, s) = F f (r, t)
+
+private def ThirdHurewicz.CubeGluing.cubeFamilyMap {X : Type} [TopologicalSpace X]
+    (F : Equiv.Perm (Fin 3) → C((unitInterval) × FirstHurewicz.Simplex 3, X)) :
+    C((Σ _e : Equiv.Perm (Fin 3), (unitInterval) × FirstHurewicz.Simplex 3), X)
+    where
+  toFun a := F a.fst a.snd
+  continuous_toFun := continuous_sigma fun e => (F e).continuous
+
+private theorem
+    ThirdHurewicz.CubeGluing.cubeFamilyMap_factorsThrough {X : Type} [TopologicalSpace X]
+    (F : Equiv.Perm (Fin 3) → C((unitInterval) × FirstHurewicz.Simplex 3, X))
+    (hF : CubeCompatible F) :
+    Function.FactorsThrough (cubeFamilyMap F) ThirdHurewicz.CubeTriangulation.cubeCylinderCover :=
+  by
+  rintro ⟨e, r, s⟩ ⟨f, q, t⟩ h
+  have hr : r = q := congrArg Prod.fst h
+  have hs :
+    ThirdHurewicz.Geometry.cubeTetrahedron e s = ThirdHurewicz.Geometry.cubeTetrahedron f t :=
+    congrArg Prod.snd h
+  subst q
+  exact hF e f s t hs r
+
+private def ThirdHurewicz.CubeGluing.glueCubeHomotopies {X : Type} [TopologicalSpace X]
+    (F : Equiv.Perm (Fin 3) → C((unitInterval) × FirstHurewicz.Simplex 3, X))
+    (hF : CubeCompatible F) : C((unitInterval) × ThirdHurewicz.Geometry.Cube3, X) :=
+  ThirdHurewicz.CubeTriangulation.cubeCylinderCover_isQuotientMap.lift (cubeFamilyMap F)
+    (cubeFamilyMap_factorsThrough F hF)
+
+@[simp]
+private theorem ThirdHurewicz.CubeGluing.glueCubeHomotopies_cell {X : Type} [TopologicalSpace X]
+    (F : Equiv.Perm (Fin 3) → C((unitInterval) × FirstHurewicz.Simplex 3, X))
+    (hF : CubeCompatible F) (e : Equiv.Perm (Fin 3)) (r : (unitInterval))
+    (s : FirstHurewicz.Simplex 3) :
+    glueCubeHomotopies F hF (r, ThirdHurewicz.Geometry.cubeTetrahedron e s) = F e (r, s) :=
+  DFunLike.congr_fun
+    (ThirdHurewicz.CubeTriangulation.cubeCylinderCover_isQuotientMap.lift_comp (cubeFamilyMap F)
+      (cubeFamilyMap_factorsThrough F hF))
+    ⟨e, (r, s)⟩
+
+private theorem ThirdHurewicz.CubeGluing.glueCubeHomotopies_time {X : Type} [TopologicalSpace X]
+    (F : Equiv.Perm (Fin 3) → C((unitInterval) × FirstHurewicz.Simplex 3, X))
+    (hF : CubeCompatible F) (r : (unitInterval)) (g : ThirdHurewicz.Geometry.Cube3 → X)
+    (h :
+      ∀ (e : Equiv.Perm (Fin 3)) (s : FirstHurewicz.Simplex 3),
+        F e (r, s) = g (ThirdHurewicz.Geometry.cubeTetrahedron e s))
+    (u : ThirdHurewicz.Geometry.Cube3) : glueCubeHomotopies F hF (r, u) = g u := by
+  obtain ⟨e, s, rfl⟩ := ThirdHurewicz.CubeTriangulation.exists_cubeTetrahedron u
+  exact (glueCubeHomotopies_cell F hF e r s).trans (h e s)
+
+private theorem ThirdHurewicz.CubeGluing.glueCubeHomotopies_zero {X : Type} [TopologicalSpace X]
+    (F : Equiv.Perm (Fin 3) → C((unitInterval) × FirstHurewicz.Simplex 3, X))
+    (hF : CubeCompatible F) (g : C(ThirdHurewicz.Geometry.Cube3, X))
+    (h :
+      ∀ (e : Equiv.Perm (Fin 3)) (s : FirstHurewicz.Simplex 3),
+        F e (0, s) = g (ThirdHurewicz.Geometry.cubeTetrahedron e s))
+    (u : ThirdHurewicz.Geometry.Cube3) : glueCubeHomotopies F hF (0, u) = g u :=
+  glueCubeHomotopies_time F hF 0 g h u
+
+private theorem
+    ThirdHurewicz.CubeTriangulation.cubeTetrahedron_mem_boundary_iff (e : Equiv.Perm (Fin 3))
+    (s : FirstHurewicz.Simplex 3) :
+    ThirdHurewicz.Geometry.cubeTetrahedron e s ∈ Cube.boundary (Fin 3) ↔ s 0 = 0 ∨ s 3 = 0 := by
+  constructor
+  · rintro ⟨i, hi⟩
+    obtain ⟨j, rfl⟩ := e.surjective i
+    have h0 := stdSimplex.zero_le s 0
+    have h1 := stdSimplex.zero_le s 1
+    have h2 := stdSimplex.zero_le s 2
+    have h3 := stdSimplex.zero_le s 3
+    have hs := stdSimplex.sum_eq_one s
+    simp only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero] at hs
+    change s 0 + (s 1 + (s 2 + s 3)) = 1 at hs
+    fin_cases j
+    · rcases hi with hi | hi
+      · right
+        have hr := congrArg (fun t : (unitInterval) => (t : ℝ)) hi
+        change (ThirdHurewicz.Geometry.cubeTetrahedron e s (e 0) : ℝ) = 0 at hr
+        rw [ThirdHurewicz.Geometry.cubeTetrahedron_coordinate_zero] at hr
+        linarith
+      · left
+        have hr := congrArg (fun t : (unitInterval) => (t : ℝ)) hi
+        change (ThirdHurewicz.Geometry.cubeTetrahedron e s (e 0) : ℝ) = 1 at hr
+        rw [ThirdHurewicz.Geometry.cubeTetrahedron_coordinate_zero] at hr
+        linarith
+    · rcases hi with hi | hi
+      · right
+        have hr := congrArg (fun t : (unitInterval) => (t : ℝ)) hi
+        change (ThirdHurewicz.Geometry.cubeTetrahedron e s (e 1) : ℝ) = 0 at hr
+        rw [ThirdHurewicz.Geometry.cubeTetrahedron_coordinate_one] at hr
+        linarith
+      · left
+        have hr := congrArg (fun t : (unitInterval) => (t : ℝ)) hi
+        change (ThirdHurewicz.Geometry.cubeTetrahedron e s (e 1) : ℝ) = 1 at hr
+        rw [ThirdHurewicz.Geometry.cubeTetrahedron_coordinate_one] at hr
+        linarith
+    · rcases hi with hi | hi
+      · right
+        have hr := congrArg (fun t : (unitInterval) => (t : ℝ)) hi
+        change (ThirdHurewicz.Geometry.cubeTetrahedron e s (e 2) : ℝ) = 0 at hr
+        rwa [ThirdHurewicz.Geometry.cubeTetrahedron_coordinate_two] at hr
+      · left
+        have hr := congrArg (fun t : (unitInterval) => (t : ℝ)) hi
+        change (ThirdHurewicz.Geometry.cubeTetrahedron e s (e 2) : ℝ) = 1 at hr
+        rw [ThirdHurewicz.Geometry.cubeTetrahedron_coordinate_two] at hr
+        linarith
+  · rintro (hs | hs)
+    · have ht :=
+        ThirdHurewicz.Geometry.cubeTetrahedron_face_zero_boundary e
+          (SecondHurewicz.SimplyConnected.simplexFaceInverse 2 0 ⟨s, hs⟩)
+      simpa only [SecondHurewicz.SimplyConnected.simplexFace_inverse] using ht
+    · have ht :=
+        ThirdHurewicz.Geometry.cubeTetrahedron_face_three_boundary e
+          (SecondHurewicz.SimplyConnected.simplexFaceInverse 2 3 ⟨s, hs⟩)
+      simpa only [SecondHurewicz.SimplyConnected.simplexFace_inverse] using ht
+
+private theorem ThirdHurewicz.CubeTriangulation.cubeTetrahedron_tie_first (e : Equiv.Perm (Fin 3))
+    (s : FirstHurewicz.Simplex 3)
+    (h :
+      ThirdHurewicz.Geometry.cubeTetrahedron e s (e 0) =
+        ThirdHurewicz.Geometry.cubeTetrahedron e s (e 1)) :
+    s 1 = 0 := by
+  have hr := congrArg (fun t : (unitInterval) => (t : ℝ)) h
+  rw [ThirdHurewicz.Geometry.cubeTetrahedron_coordinate_zero,
+    ThirdHurewicz.Geometry.cubeTetrahedron_coordinate_one] at hr
+  linarith
+
+private theorem ThirdHurewicz.CubeTriangulation.cubeTetrahedron_tie_second (e : Equiv.Perm (Fin 3))
+    (s : FirstHurewicz.Simplex 3)
+    (h :
+      ThirdHurewicz.Geometry.cubeTetrahedron e s (e 1) =
+        ThirdHurewicz.Geometry.cubeTetrahedron e s (e 2)) :
+    s 2 = 0 := by
+  have hr := congrArg (fun t : (unitInterval) => (t : ℝ)) h
+  rw [ThirdHurewicz.Geometry.cubeTetrahedron_coordinate_one,
+    ThirdHurewicz.Geometry.cubeTetrahedron_coordinate_two] at hr
+  linarith
+
+private theorem
+    ThirdHurewicz.CubeGluing.cubeOriginal_face_zero {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (e : Equiv.Perm (Fin 3)) :
+    (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron e)).comp (FirstHurewicz.simplexFace 2 0) =
+      ContinuousMap.const (FirstHurewicz.Simplex 2) x := by
+  ext s
+  exact GenLoop.boundary p _ (ThirdHurewicz.Geometry.cubeTetrahedron_face_zero_boundary e s)
+
+private theorem
+    ThirdHurewicz.CubeGluing.cubeOriginal_face_three {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (e : Equiv.Perm (Fin 3)) :
+    (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron e)).comp (FirstHurewicz.simplexFace 2 3) =
+      ContinuousMap.const (FirstHurewicz.Simplex 2) x := by
+  ext s
+  exact GenLoop.boundary p _ (ThirdHurewicz.Geometry.cubeTetrahedron_face_three_boundary e s)
+
+private theorem ThirdHurewicz.CubeGluing.cubeOriginal_face_one_swap {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 3) X x) (e : Equiv.Perm (Fin 3)) :
+    (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron e)).comp (FirstHurewicz.simplexFace 2 1) =
+      (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron ((Equiv.swap 0 1).trans e))).comp
+        (FirstHurewicz.simplexFace 2 1) := by
+  simpa only [ContinuousMap.comp_assoc] using
+    congrArg (fun f : C(FirstHurewicz.Simplex 2, ThirdHurewicz.Geometry.Cube3) => p.val.comp f)
+      (ThirdHurewicz.Geometry.cubeTetrahedron_face_one_swap e)
+
+private theorem ThirdHurewicz.CubeGluing.cubeOriginal_face_two_swap {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 3) X x) (e : Equiv.Perm (Fin 3)) :
+    (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron e)).comp (FirstHurewicz.simplexFace 2 2) =
+      (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron ((Equiv.swap 1 2).trans e))).comp
+        (FirstHurewicz.simplexFace 2 2) := by
+  simpa only [ContinuousMap.comp_assoc] using
+    congrArg (fun f : C(FirstHurewicz.Simplex 2, ThirdHurewicz.Geometry.Cube3) => p.val.comp f)
+      (ThirdHurewicz.Geometry.cubeTetrahedron_face_two_swap e)
+
+private theorem
+    ThirdHurewicz.CubeGluing.coherentCubeCell_face {X : Type} [TopologicalSpace X] {x : X}
+    (H₂ : C(FirstHurewicz.Simplex 2, X) → C((unitInterval) × FirstHurewicz.Simplex 2, X))
+    (H₃ : C(FirstHurewicz.Simplex 3, X) → C((unitInterval) × FirstHurewicz.Simplex 3, X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 2 H₂ H₃)
+    (p : GenLoop (Fin 3) X x) (e : Equiv.Perm (Fin 3)) (i : Fin 4) (r : (unitInterval))
+    (s : FirstHurewicz.Simplex 2) :
+    H₃ (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron e))
+        (r, FirstHurewicz.simplexFace 2 i s) =
+      H₂
+        ((p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron e)).comp
+          (FirstHurewicz.simplexFace 2 i))
+        (r, s) :=
+  DFunLike.congr_fun (hface (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron e)) i) (r, s)
+
+private theorem
+    ThirdHurewicz.CubeGluing.coherentCubeCell_one_swap {X : Type} [TopologicalSpace X] {x : X}
+    (H₂ : C(FirstHurewicz.Simplex 2, X) → C((unitInterval) × FirstHurewicz.Simplex 2, X))
+    (H₃ : C(FirstHurewicz.Simplex 3, X) → C((unitInterval) × FirstHurewicz.Simplex 3, X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 2 H₂ H₃)
+    (p : GenLoop (Fin 3) X x) (e : Equiv.Perm (Fin 3)) (r : (unitInterval))
+    (s : FirstHurewicz.Simplex 3) (hs : s 1 = 0) :
+    H₃ (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron e)) (r, s) =
+      H₃ (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron ((Equiv.swap 0 1).trans e)))
+        (r, s) := by
+  let t := SecondHurewicz.SimplyConnected.simplexFaceInverse 2 1 ⟨s, hs⟩
+  have ht : FirstHurewicz.simplexFace 2 1 t = s :=
+    SecondHurewicz.SimplyConnected.simplexFace_inverse 2 1 ⟨s, hs⟩
+  rw [← ht, coherentCubeCell_face H₂ H₃ hface, coherentCubeCell_face H₂ H₃ hface,
+    cubeOriginal_face_one_swap]
+
+private theorem
+    ThirdHurewicz.CubeGluing.coherentCubeCell_two_swap {X : Type} [TopologicalSpace X] {x : X}
+    (H₂ : C(FirstHurewicz.Simplex 2, X) → C((unitInterval) × FirstHurewicz.Simplex 2, X))
+    (H₃ : C(FirstHurewicz.Simplex 3, X) → C((unitInterval) × FirstHurewicz.Simplex 3, X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 2 H₂ H₃)
+    (p : GenLoop (Fin 3) X x) (e : Equiv.Perm (Fin 3)) (r : (unitInterval))
+    (s : FirstHurewicz.Simplex 3) (hs : s 2 = 0) :
+    H₃ (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron e)) (r, s) =
+      H₃ (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron ((Equiv.swap 1 2).trans e)))
+        (r, s) := by
+  let t := SecondHurewicz.SimplyConnected.simplexFaceInverse 2 2 ⟨s, hs⟩
+  have ht : FirstHurewicz.simplexFace 2 2 t = s :=
+    SecondHurewicz.SimplyConnected.simplexFace_inverse 2 2 ⟨s, hs⟩
+  rw [← ht, coherentCubeCell_face H₂ H₃ hface, coherentCubeCell_face H₂ H₃ hface,
+    cubeOriginal_face_two_swap]
+
+private theorem
+    ThirdHurewicz.CubeGluing.coherentCubeCell_boundary {X : Type} [TopologicalSpace X] {x : X}
+    (H₂ : C(FirstHurewicz.Simplex 2, X) → C((unitInterval) × FirstHurewicz.Simplex 2, X))
+    (H₃ : C(FirstHurewicz.Simplex 3, X) → C((unitInterval) × FirstHurewicz.Simplex 3, X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 2 H₂ H₃)
+    (hconst :
+      H₂ (ContinuousMap.const (FirstHurewicz.Simplex 2) x) =
+        ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 2) x)
+    (p : GenLoop (Fin 3) X x) (e : Equiv.Perm (Fin 3)) (r : (unitInterval))
+    (s : FirstHurewicz.Simplex 3)
+    (hs : ThirdHurewicz.Geometry.cubeTetrahedron e s ∈ Cube.boundary (Fin 3)) :
+    H₃ (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron e)) (r, s) = x := by
+  rcases (ThirdHurewicz.CubeTriangulation.cubeTetrahedron_mem_boundary_iff e s).mp hs with hs | hs
+  · let t := SecondHurewicz.SimplyConnected.simplexFaceInverse 2 0 ⟨s, hs⟩
+    have ht : FirstHurewicz.simplexFace 2 0 t = s :=
+      SecondHurewicz.SimplyConnected.simplexFace_inverse 2 0 ⟨s, hs⟩
+    rw [← ht, coherentCubeCell_face H₂ H₃ hface, cubeOriginal_face_zero, hconst]
+    rfl
+  · let t := SecondHurewicz.SimplyConnected.simplexFaceInverse 2 3 ⟨s, hs⟩
+    have ht : FirstHurewicz.simplexFace 2 3 t = s :=
+      SecondHurewicz.SimplyConnected.simplexFace_inverse 2 3 ⟨s, hs⟩
+    rw [← ht, coherentCubeCell_face H₂ H₃ hface, cubeOriginal_face_three, hconst]
+    rfl
+
+private theorem
+    ThirdHurewicz.CubeTriangulation.SortedCoordinates.le_first {α : Type*} [LinearOrder α]
+    {u : Fin 3 → α} {e : Equiv.Perm (Fin 3)}
+    (he : ThirdHurewicz.CubeTriangulation.SortedCoordinates u e) (i : Fin 3) : u i ≤ u (e 0) := by
+  obtain ⟨j, rfl⟩ := e.surjective i
+  fin_cases j
+  · exact le_rfl
+  · exact he.2
+  · exact he.1.trans he.2
+
+private theorem ThirdHurewicz.CubeTriangulation.sorted_first_value_eq {α : Type*} [LinearOrder α]
+    (u : Fin 3 → α) {e f : Equiv.Perm (Fin 3)} (he : SortedCoordinates u e)
+    (hf : SortedCoordinates u f) : u (e 0) = u (f 0) :=
+  le_antisymm (hf.le_first (e 0)) (he.le_first (f 0))
+
+private theorem ThirdHurewicz.CubeTriangulation.SortedCoordinates.swap01 {α : Type*} [LinearOrder α]
+    {u : Fin 3 → α} {e : Equiv.Perm (Fin 3)}
+    (he : ThirdHurewicz.CubeTriangulation.SortedCoordinates u e) (ht : u (e 0) = u (e 1)) :
+    ThirdHurewicz.CubeTriangulation.SortedCoordinates u ((Equiv.swap 0 1).trans e) := by
+  simpa [ThirdHurewicz.CubeTriangulation.SortedCoordinates, Equiv.swap_apply_def] using
+    And.intro (he.1.trans he.2) ht.le
+
+private theorem ThirdHurewicz.CubeTriangulation.SortedCoordinates.swap12 {α : Type*} [LinearOrder α]
+    {u : Fin 3 → α} {e : Equiv.Perm (Fin 3)}
+    (he : ThirdHurewicz.CubeTriangulation.SortedCoordinates u e) (ht : u (e 1) = u (e 2)) :
+    ThirdHurewicz.CubeTriangulation.SortedCoordinates u ((Equiv.swap 1 2).trans e) := by
+  simpa [ThirdHurewicz.CubeTriangulation.SortedCoordinates, Equiv.swap_apply_def] using
+    And.intro ht.le (he.1.trans he.2)
+
+private theorem ThirdHurewicz.CubeTriangulation.permutation_ext_zero_one_mo1973_7620
+    {e f : Equiv.Perm (Fin 3)} (h0 : e 0 = f 0) (h1 : e 1 = f 1) : e = f := by
+  apply Equiv.ext
+  intro i
+  fin_cases i
+  · exact h0
+  · exact h1
+  · obtain ⟨j, hj⟩ := f.surjective (e 2)
+    fin_cases j
+    · exact ((by decide : (0 : Fin 3) ≠ 2) (e.injective (h0.trans hj))).elim
+    · exact ((by decide : (1 : Fin 3) ≠ 2) (e.injective (h1.trans hj))).elim
+    · exact hj.symm
+
+private theorem ThirdHurewicz.CubeTriangulation.eq_of_sorted_same_first_mo1973_7621 {α : Type*}
+    [LinearOrder α] (u : Fin 3 → α) {A : Type*} (F : Equiv.Perm (Fin 3) → A)
+    (h12 : ∀ e, SortedCoordinates u e → u (e 1) = u (e 2) → F e = F ((Equiv.swap 1 2).trans e))
+    {e f : Equiv.Perm (Fin 3)} (he : SortedCoordinates u e) (hf : SortedCoordinates u f)
+    (h0 : e 0 = f 0) : F e = F f := by
+  obtain ⟨i, hi⟩ := e.surjective (f 1)
+  fin_cases i
+  · exact ((by decide : (0 : Fin 3) ≠ 1) (f.injective (h0.symm.trans hi))).elim
+  · exact congrArg F (permutation_ext_zero_one_mo1973_7620 h0 hi)
+  · have hp : (Equiv.swap 1 2).trans e = f :=
+      permutation_ext_zero_one_mo1973_7620 (by simpa [Equiv.swap_apply_def] using h0)
+        (by simpa [Equiv.swap_apply_def] using hi)
+    have hrev : u (e 1) ≤ u (e 2) := by
+      have hh := hf.1
+      rw [← hp] at hh
+      simpa [Equiv.swap_apply_def] using hh
+    exact (h12 e he (le_antisymm hrev he.1)).trans (congrArg F hp)
+
+private theorem ThirdHurewicz.CubeTriangulation.eq_of_sorted_adjacent {α : Type*} [LinearOrder α]
+    (u : Fin 3 → α) {A : Type*} (F : Equiv.Perm (Fin 3) → A)
+    (h01 : ∀ e, SortedCoordinates u e → u (e 0) = u (e 1) → F e = F ((Equiv.swap 0 1).trans e))
+    (h12 : ∀ e, SortedCoordinates u e → u (e 1) = u (e 2) → F e = F ((Equiv.swap 1 2).trans e))
+    {e f : Equiv.Perm (Fin 3)} (he : SortedCoordinates u e) (hf : SortedCoordinates u f) :
+    F e = F f := by
+  obtain ⟨i, hi⟩ := e.surjective (f 0)
+  fin_cases i
+  · exact eq_of_sorted_same_first_mo1973_7621 u F h12 he hf hi
+  · change e 1 = f 0 at hi
+    have ht : u (e 0) = u (e 1) := by
+      rw [hi]
+      exact sorted_first_value_eq u he hf
+    have hg := he.swap01 ht
+    have hg0 : ((Equiv.swap 0 1).trans e) 0 = f 0 := by simpa [Equiv.swap_apply_def] using hi
+    exact (h01 e he ht).trans (eq_of_sorted_same_first_mo1973_7621 u F h12 hg hf hg0)
+  · change e 2 = f 0 at hi
+    have ht : u (e 0) = u (e 2) := by
+      rw [hi]
+      exact sorted_first_value_eq u he hf
+    have ht12 : u (e 1) = u (e 2) := le_antisymm (he.2.trans ht.le) he.1
+    have hg := he.swap12 ht12
+    have ht01 : u (((Equiv.swap 1 2).trans e) 0) = u (((Equiv.swap 1 2).trans e) 1) := by
+      simpa [Equiv.swap_apply_def] using ht
+    have hh := hg.swap01 ht01
+    have hh0 : ((Equiv.swap 0 1).trans ((Equiv.swap 1 2).trans e)) 0 = f 0 := by
+      simpa [Equiv.swap_apply_def] using hi
+    exact
+      (h12 e he ht12).trans
+        ((h01 _ hg ht01).trans (eq_of_sorted_same_first_mo1973_7621 u F h12 hh hf hh0))
+
+private theorem ThirdHurewicz.CubeTriangulation.sorted_values_eq {α : Type*} [LinearOrder α]
+    (u : Fin 3 → α) {e f : Equiv.Perm (Fin 3)} (he : SortedCoordinates u e)
+    (hf : SortedCoordinates u f) : ∀ i : Fin 3, u (e i) = u (f i) := by
+  have hfun : (fun i => u (e i)) = (fun i => u (f i)) :=
+    eq_of_sorted_adjacent u (fun g i => u (g i))
+      (fun g _ ht => by
+        funext i
+        fin_cases i <;> simp [Equiv.swap_apply_def, ht])
+      (fun g _ ht => by
+        funext i
+        fin_cases i <;> simp [Equiv.swap_apply_def, ht])
+      he hf
+  exact congrFun hfun
+
+private theorem ThirdHurewicz.CubeTriangulation.cubeBarycentric_eq_of_sorted
+    (u : ThirdHurewicz.Geometry.Cube3) {e f : Equiv.Perm (Fin 3)} (he : SortedCoordinates u e)
+    (hf : SortedCoordinates u f) : cubeBarycentric e u = cubeBarycentric f u := by
+  simp only [cubeBarycentric, sorted_values_eq u he hf 0, sorted_values_eq u he hf 1,
+    sorted_values_eq u he hf 2]
+
+private theorem ThirdHurewicz.CubeTriangulation.cubeTetrahedronInverse_sorted_eq
+    (u : ThirdHurewicz.Geometry.Cube3) {e f : Equiv.Perm (Fin 3)} (he : SortedCoordinates u e)
+    (hf : SortedCoordinates u f) :
+    cubeTetrahedronInverse e ⟨u, he⟩ = cubeTetrahedronInverse f ⟨u, hf⟩ :=
+  Subtype.ext (cubeBarycentric_eq_of_sorted u he hf)
+
+private theorem
+    ThirdHurewicz.CubeTriangulation.cubeTetrahedron_eq_of_sorted (e f : Equiv.Perm (Fin 3))
+    (s : FirstHurewicz.Simplex 3)
+    (hf : SortedCoordinates (ThirdHurewicz.Geometry.cubeTetrahedron e s) f) :
+    ThirdHurewicz.Geometry.cubeTetrahedron f s = ThirdHurewicz.Geometry.cubeTetrahedron e s := by
+  have hp : cubeTetrahedronInverse f ⟨ThirdHurewicz.Geometry.cubeTetrahedron e s, hf⟩ = s :=
+    (cubeTetrahedronInverse_sorted_eq (ThirdHurewicz.Geometry.cubeTetrahedron e s) hf
+          (cubeTetrahedron_sorted e s)).trans
+      (cubeTetrahedronInverse_tetrahedron e s)
+  simpa only [hp] using cubeTetrahedron_inverse f ⟨ThirdHurewicz.Geometry.cubeTetrahedron e s, hf⟩
+
+private theorem ThirdHurewicz.CubeTriangulation.cubeTetrahedron_overlap_preimage
+    (e f : Equiv.Perm (Fin 3)) (s t : FirstHurewicz.Simplex 3)
+    (h :
+      ThirdHurewicz.Geometry.cubeTetrahedron e s = ThirdHurewicz.Geometry.cubeTetrahedron f t) :
+    s = t := by
+  have hf : SortedCoordinates (ThirdHurewicz.Geometry.cubeTetrahedron e s) f := by
+    rw [h]
+    exact cubeTetrahedron_sorted f t
+  exact cubeTetrahedron_injective f ((cubeTetrahedron_eq_of_sorted e f s hf).trans h)
+
+private theorem
+    ThirdHurewicz.CubeGluing.coherentCubeFamily_compatible {X : Type} [TopologicalSpace X]
+    {x : X} (H₂ : C(FirstHurewicz.Simplex 2, X) → C((unitInterval) × FirstHurewicz.Simplex 2, X))
+    (H₃ : C(FirstHurewicz.Simplex 3, X) → C((unitInterval) × FirstHurewicz.Simplex 3, X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 2 H₂ H₃)
+    (p : GenLoop (Fin 3) X x) :
+    CubeCompatible (fun e => H₃ (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron e))) := by
+  intro e f s t h r
+  have hst := ThirdHurewicz.CubeTriangulation.cubeTetrahedron_overlap_preimage e f s t h
+  subst t
+  have hf :
+    ThirdHurewicz.CubeTriangulation.SortedCoordinates (ThirdHurewicz.Geometry.cubeTetrahedron e s)
+      f := by
+    rw [h]
+    exact ThirdHurewicz.CubeTriangulation.cubeTetrahedron_sorted f s
+  apply
+    ThirdHurewicz.CubeTriangulation.eq_of_sorted_adjacent
+      (ThirdHurewicz.Geometry.cubeTetrahedron e s)
+      (fun g => H₃ (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron g)) (r, s)) ?_ ?_
+      (ThirdHurewicz.CubeTriangulation.cubeTetrahedron_sorted e s) hf
+  · intro g hg ht
+    apply coherentCubeCell_one_swap H₂ H₃ hface p g r s
+    apply ThirdHurewicz.CubeTriangulation.cubeTetrahedron_tie_first g s
+    simpa only [ThirdHurewicz.CubeTriangulation.cubeTetrahedron_eq_of_sorted e g s hg] using ht
+  · intro g hg ht
+    apply coherentCubeCell_two_swap H₂ H₃ hface p g r s
+    apply ThirdHurewicz.CubeTriangulation.cubeTetrahedron_tie_second g s
+    simpa only [ThirdHurewicz.CubeTriangulation.cubeTetrahedron_eq_of_sorted e g s hg] using ht
+
+private def ThirdHurewicz.CubeGluing.coherentCubeHomotopyMap {X : Type} [TopologicalSpace X] {x : X}
+    (H₂ : C(FirstHurewicz.Simplex 2, X) → C((unitInterval) × FirstHurewicz.Simplex 2, X))
+    (H₃ : C(FirstHurewicz.Simplex 3, X) → C((unitInterval) × FirstHurewicz.Simplex 3, X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 2 H₂ H₃)
+    (p : GenLoop (Fin 3) X x) : C((unitInterval) × ThirdHurewicz.Geometry.Cube3, X) :=
+  glueCubeHomotopies (fun e => H₃ (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron e)))
+    (coherentCubeFamily_compatible H₂ H₃ hface p)
+
+@[simp]
+private theorem
+    ThirdHurewicz.CubeGluing.coherentCubeHomotopyMap_cell {X : Type} [TopologicalSpace X]
+    {x : X} (H₂ : C(FirstHurewicz.Simplex 2, X) → C((unitInterval) × FirstHurewicz.Simplex 2, X))
+    (H₃ : C(FirstHurewicz.Simplex 3, X) → C((unitInterval) × FirstHurewicz.Simplex 3, X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 2 H₂ H₃)
+    (p : GenLoop (Fin 3) X x) (e : Equiv.Perm (Fin 3)) (r : (unitInterval))
+    (s : FirstHurewicz.Simplex 3) :
+    coherentCubeHomotopyMap H₂ H₃ hface p (r, ThirdHurewicz.Geometry.cubeTetrahedron e s) =
+      H₃ (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron e)) (r, s) :=
+  glueCubeHomotopies_cell _ _ e r s
+
+private theorem
+    ThirdHurewicz.CubeGluing.coherentCubeHomotopyMap_zero {X : Type} [TopologicalSpace X]
+    {x : X} (H₂ : C(FirstHurewicz.Simplex 2, X) → C((unitInterval) × FirstHurewicz.Simplex 2, X))
+    (H₃ : C(FirstHurewicz.Simplex 3, X) → C((unitInterval) × FirstHurewicz.Simplex 3, X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 2 H₂ H₃)
+    (hzero :
+      ∀ (smp : C(FirstHurewicz.Simplex 3, X)) (s : FirstHurewicz.Simplex 3),
+        H₃ smp (0, s) = smp s)
+    (p : GenLoop (Fin 3) X x) (u : ThirdHurewicz.Geometry.Cube3) :
+    coherentCubeHomotopyMap H₂ H₃ hface p (0, u) = p u :=
+  glueCubeHomotopies_zero _ _ p.val
+    (fun e s => hzero (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron e)) s) u
+
+private theorem
+    ThirdHurewicz.CubeGluing.coherentCubeHomotopyMap_boundary {X : Type} [TopologicalSpace X]
+    {x : X} (H₂ : C(FirstHurewicz.Simplex 2, X) → C((unitInterval) × FirstHurewicz.Simplex 2, X))
+    (H₃ : C(FirstHurewicz.Simplex 3, X) → C((unitInterval) × FirstHurewicz.Simplex 3, X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 2 H₂ H₃)
+    (hconst :
+      H₂ (ContinuousMap.const (FirstHurewicz.Simplex 2) x) =
+        ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 2) x)
+    (p : GenLoop (Fin 3) X x) (r : (unitInterval)) (u : ThirdHurewicz.Geometry.Cube3)
+    (hu : u ∈ Cube.boundary (Fin 3)) : coherentCubeHomotopyMap H₂ H₃ hface p (r, u) = x := by
+  obtain ⟨e, s, rfl⟩ := ThirdHurewicz.CubeTriangulation.exists_cubeTetrahedron u
+  rw [coherentCubeHomotopyMap_cell]
+  exact coherentCubeCell_boundary H₂ H₃ hface hconst p e r s hu
+
+private def ThirdHurewicz.CubeGluing.coherentCubeEndpoint {X : Type} [TopologicalSpace X] {x : X}
+    (H₂ : C(FirstHurewicz.Simplex 2, X) → C((unitInterval) × FirstHurewicz.Simplex 2, X))
+    (H₃ : C(FirstHurewicz.Simplex 3, X) → C((unitInterval) × FirstHurewicz.Simplex 3, X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 2 H₂ H₃)
+    (hconst :
+      H₂ (ContinuousMap.const (FirstHurewicz.Simplex 2) x) =
+        ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 2) x)
+    (p : GenLoop (Fin 3) X x) : GenLoop (Fin 3) X x :=
+  ⟨SecondHurewicz.SimplyConnected.timeSlice (coherentCubeHomotopyMap H₂ H₃ hface p) 1, fun u hu =>
+    coherentCubeHomotopyMap_boundary H₂ H₃ hface hconst p 1 u hu⟩
+
+private theorem
+    ThirdHurewicz.CubeGluing.coherentCubeEndpoint_cell {X : Type} [TopologicalSpace X] {x : X}
+    (H₂ : C(FirstHurewicz.Simplex 2, X) → C((unitInterval) × FirstHurewicz.Simplex 2, X))
+    (H₃ : C(FirstHurewicz.Simplex 3, X) → C((unitInterval) × FirstHurewicz.Simplex 3, X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 2 H₂ H₃)
+    (hconst :
+      H₂ (ContinuousMap.const (FirstHurewicz.Simplex 2) x) =
+        ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 2) x)
+    (p : GenLoop (Fin 3) X x) (e : Equiv.Perm (Fin 3)) :
+    (coherentCubeEndpoint H₂ H₃ hface hconst p).val.comp
+        (ThirdHurewicz.Geometry.cubeTetrahedron e) =
+      SecondHurewicz.SimplyConnected.timeSlice
+        (H₃ (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron e))) 1 := by
+  ext s
+  exact coherentCubeHomotopyMap_cell H₂ H₃ hface p e 1 s
+
+private def ThirdHurewicz.CubeGluing.coherentCubeHomotopy {X : Type} [TopologicalSpace X] {x : X}
+    (H₂ : C(FirstHurewicz.Simplex 2, X) → C((unitInterval) × FirstHurewicz.Simplex 2, X))
+    (H₃ : C(FirstHurewicz.Simplex 3, X) → C((unitInterval) × FirstHurewicz.Simplex 3, X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 2 H₂ H₃)
+    (hconst :
+      H₂ (ContinuousMap.const (FirstHurewicz.Simplex 2) x) =
+        ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 2) x)
+    (hzero :
+      ∀ (smp : C(FirstHurewicz.Simplex 3, X)) (s : FirstHurewicz.Simplex 3),
+        H₃ smp (0, s) = smp s)
+    (p : GenLoop (Fin 3) X x) :
+    p.val.HomotopyRel (coherentCubeEndpoint H₂ H₃ hface hconst p).val (Cube.boundary (Fin 3))
+    where
+  toHomotopy :=
+    { toContinuousMap := coherentCubeHomotopyMap H₂ H₃ hface p
+      map_zero_left := coherentCubeHomotopyMap_zero H₂ H₃ hface hzero p
+      map_one_left _ := rfl }
+  prop' r u
+    hu :=
+    (coherentCubeHomotopyMap_boundary H₂ H₃ hface hconst p r u hu).trans
+      (GenLoop.boundary p u hu).symm
+
+private theorem ThirdHurewicz.cubeTetrahedron_coordinate_equality_boundary (e : Equiv.Perm (Fin 3))
+    (s : FirstHurewicz.Simplex 3) (i j : Fin 3) (hij : i ≠ j)
+    (hu : Geometry.cubeTetrahedron e s i = Geometry.cubeTetrahedron e s j) :
+    s ∈ threeSimplexBoundary := by
+  obtain ⟨a, rfl⟩ := e.surjective i
+  obtain ⟨b, rfl⟩ := e.surjective j
+  have hab : a ≠ b := fun h => hij (congrArg e h)
+  have hcoords :
+    (fun k : Fin 3 => (Geometry.cubeTetrahedron e s (e k) : ℝ)) =
+      ![s 1 + s 2 + s 3, s 2 + s 3, s 3] := by
+    funext k
+    fin_cases k
+    · exact Geometry.cubeTetrahedron_coordinate_zero e s
+    · exact Geometry.cubeTetrahedron_coordinate_one e s
+    · exact Geometry.cubeTetrahedron_coordinate_two e s
+  have hv := congrArg (fun t : (unitInterval) => (t : ℝ)) hu
+  change
+    (fun k : Fin 3 => (Geometry.cubeTetrahedron e s (e k) : ℝ)) a =
+      (fun k : Fin 3 => (Geometry.cubeTetrahedron e s (e k) : ℝ)) b at hv
+  rw [hcoords] at hv
+  fin_cases a <;> fin_cases b
+  all_goals try exact (hab rfl).elim
+  all_goals
+    dsimp at hv
+    first
+    | exact ⟨1, by linarith [stdSimplex.zero_le s 1, stdSimplex.zero_le s 2]⟩
+    | exact ⟨2, by linarith [stdSimplex.zero_le s 1, stdSimplex.zero_le s 2]⟩
+
+private def
+    ThirdHurewicz.normalizedCube {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X] (x : X)
+    [Subsingleton (π_ 2 X x)] (p : GenLoop (Fin 3) X x) : GenLoop (Fin 3) X x :=
+  CubeGluing.coherentCubeEndpoint (normalizationTriangleHomotopy x)
+    (normalizationThreeSimplexHomotopy x) (normalizationHomotopy_face x)
+    (normalizationTriangleHomotopy_const x) p
+
+private theorem
+    ThirdHurewicz.normalizedCube_cell {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] (p : GenLoop (Fin 3) X x) (e : Equiv.Perm (Fin 3)) :
+    (normalizedCube x p).val.comp (Geometry.cubeTetrahedron e) =
+      (normalizedThreeSimplex x (p.val.comp (Geometry.cubeTetrahedron e))).val := by
+  exact
+    (CubeGluing.coherentCubeEndpoint_cell (normalizationTriangleHomotopy x)
+          (normalizationThreeSimplexHomotopy x) (normalizationHomotopy_face x)
+          (normalizationTriangleHomotopy_const x) p e).trans
+      (normalizationThreeSimplexHomotopy_endpoint x _)
+
+private def ThirdHurewicz.normalizationCubeHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] (p : GenLoop (Fin 3) X x) :
+    p.val.HomotopyRel (normalizedCube x p).val (Cube.boundary (Fin 3)) :=
+  CubeGluing.coherentCubeHomotopy (normalizationTriangleHomotopy x)
+    (normalizationThreeSimplexHomotopy x) (normalizationHomotopy_face x)
+    (normalizationTriangleHomotopy_const x) (normalizationThreeSimplexHomotopy_zero x) p
+
+private theorem ThirdHurewicz.normalizedCube_cell_boundary {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] (p : GenLoop (Fin 3) X x)
+    (e : Equiv.Perm (Fin 3)) (s : FirstHurewicz.Simplex 3) (hs : s ∈ threeSimplexBoundary) :
+    normalizedCube x p (Geometry.cubeTetrahedron e s) = x := by
+  have h := congrArg (fun f : C(FirstHurewicz.Simplex 3, X) => f s) (normalizedCube_cell x p e)
+  exact
+    h.trans ((normalizedThreeSimplex x (p.val.comp (Geometry.cubeTetrahedron e))).property s hs)
+
+private theorem ThirdHurewicz.normalizedCube_internalBased {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] (p : GenLoop (Fin 3) X x) :
+    NativeCubeInternalBased (normalizedCube x p) := by
+  intro u i j hij hu
+  obtain ⟨e, s, rfl⟩ := CubeTriangulation.exists_cubeTetrahedron u
+  exact
+    normalizedCube_cell_boundary x p e s
+      (cubeTetrahedron_coordinate_equality_boundary e s i j hij hu)
+
+private theorem
+    ThirdHurewicz.threeSimplexClassOperator_cubeChain_sum {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] (p : GenLoop (Fin 3) X x) :
+    threeSimplexClassOperator x (cubeChain p) =
+      ∑ e : Equiv.Perm (Fin 3),
+        Geometry.cubeOrientation e •
+          basedThreeSimplexClass
+            (normalizedThreeSimplex x (p.val.comp (Geometry.cubeTetrahedron e))) := by
+  rw [CubeSubdivision.cubeChain_eq_sum_tetrahedra]
+  simp only [map_sum, map_zsmul, threeSimplexClassOperator_simplex]
+
+private theorem ThirdHurewicz.normalizedCube_tetrahedron {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] (p : GenLoop (Fin 3) X x)
+    (e : Equiv.Perm (Fin 3)) :
+    nativeBasedCubeTetrahedron (normalizedCube x p) (normalizedCube_internalBased x p) e =
+      normalizedThreeSimplex x (p.val.comp (Geometry.cubeTetrahedron e)) := by
+  apply Subtype.ext
+  exact normalizedCube_cell x p e
+
+private theorem ThirdHurewicz.threeSimplexClassOperator_cubeChain {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] (p : GenLoop (Fin 3) X x) :
+    threeSimplexClassOperator x (cubeChain p) = Additive.ofMul (⟦p⟧ : π_ 3 X x) := by
+  have h :=
+    nativeCubeSubdivision_homotopy_class p (normalizedCube x p) (normalizationCubeHomotopy x p)
+      (normalizedCube_internalBased x p)
+  simp only [normalizedCube_tetrahedron] at h
+  exact (threeSimplexClassOperator_cubeChain_sum x p).trans h.symm
+
+private def
+    ThirdHurewicz.hurewiczInverse {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X] (x : X)
+    [Subsingleton (π_ 2 X x)] :
+    SingularMayerVietoris.SingularHomology X 3 →ₗ[ℤ] Additive (π_ 3 X x) :=
+  thirdHomologyDesc (threeSimplexClassOperator x) (threeSimplexClassOperator_boundary x)
+
+@[simp]
+private theorem ThirdHurewicz.hurewiczInverse_cycleClass {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)]
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3) :
+    hurewiczInverse x
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 3 c) =
+      threeSimplexClassOperator x c.val :=
+  thirdHomologyDesc_cycleClass _ _ c
+
+private theorem ThirdHurewicz.hurewiczMap_comp_hurewiczInverse {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] :
+    (hurewiczMap x).comp (hurewiczInverse x) = LinearMap.id :=
+  comp_thirdHomologyDesc_eq_id (threeSimplexClassOperator x)
+    (threeSimplexClassOperator_boundary x) (hurewiczMap x)
+    (hurewiczMap_threeSimplexClassOperator_cycle x)
+
+@[simp]
+private theorem ThirdHurewicz.hurewiczMap_hurewiczInverse {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)]
+    (c : SingularMayerVietoris.SingularHomology X 3) : hurewiczMap x (hurewiczInverse x c) = c :=
+  LinearMap.congr_fun (hurewiczMap_comp_hurewiczInverse x) c
+
+private theorem ThirdHurewicz.hurewiczInverse_hurewiczMap_mk {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] (p : GenLoop (Fin 3) X x) :
+    hurewiczInverse x (hurewiczMap x (Additive.ofMul (⟦p⟧ : π_ 3 X x))) =
+      Additive.ofMul (⟦p⟧ : π_ 3 X x) := by
+  rw [hurewiczMap_representative, hurewiczInverse_cycleClass]
+  exact threeSimplexClassOperator_cubeChain x p
+
+@[simp]
+private theorem ThirdHurewicz.hurewiczInverse_hurewiczMap {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] (a : Additive (π_ 3 X x)) :
+    hurewiczInverse x (hurewiczMap x a) = a := by
+  change
+    hurewiczInverse x (hurewiczMap x (Additive.ofMul (Additive.toMul a))) =
+      Additive.ofMul (Additive.toMul a)
+  refine Quotient.inductionOn (Additive.toMul a) ?_
+  intro p
+  exact hurewiczInverse_hurewiczMap_mk x p
+
+private theorem ThirdHurewicz.hurewiczInverse_comp_hurewiczMap {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] :
+    (hurewiczInverse x).comp (hurewiczMap x) = LinearMap.id := by
+  ext a
+  exact hurewiczInverse_hurewiczMap x a
+
+
+private def ThirdHurewicz.hurewiczPi3Equiv {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] :
+    π_ 3 X x ≃* Multiplicative (SingularMayerVietoris.SingularHomology X 3)
+    where
+  __ := hurewiczPi3 x
+  invFun c := Additive.toMul (hurewiczInverse x (Multiplicative.toAdd c))
+  left_inv a := congrArg Additive.toMul (hurewiczInverse_hurewiczMap x (Additive.ofMul a))
+  right_inv
+    c := congrArg Multiplicative.ofAdd (hurewiczMap_hurewiczInverse x (Multiplicative.toAdd c))
+
+@[simp]
+private theorem FourthHurewicz.lowerThreeSimplexHomotopy_const {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] :
+    ThirdHurewicz.normalizationThreeSimplexHomotopy x
+        (ContinuousMap.const (FirstHurewicz.Simplex 3) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 3) x := by
+  have hVE :
+    ThirdHurewicz.vertexEdgeThreeSimplexHomotopy x
+        (ContinuousMap.const (FirstHurewicz.Simplex 3) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 3) x :=
+    ThirdHurewicz.composeSimplexHomotopies_const
+      (SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy x 3)
+      (SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy x)
+      (SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy_zero x 3)
+      (SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy_zero x) x
+      (SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy_const x 3)
+      (ThirdHurewicz.edgeTetrahedronHomotopy_const x)
+  exact
+    ThirdHurewicz.composeSimplexHomotopies_const (ThirdHurewicz.vertexEdgeThreeSimplexHomotopy x)
+      (ThirdHurewicz.triangleThreeSimplexHomotopy x)
+      (ThirdHurewicz.vertexEdgeThreeSimplexHomotopy_zero x)
+      (ThirdHurewicz.triangleThreeSimplexHomotopy_zero x) x hVE
+      (ThirdHurewicz.triangleThreeSimplexHomotopy_const x)
+
+private def FourthHurewicz.lowerFourSimplexHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 4) : C((unitInterval) × FirstHurewicz.Simplex 4, X) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy
+    (ThirdHurewicz.normalizationTriangleHomotopy x)
+    (ThirdHurewicz.normalizationThreeSimplexHomotopy x)
+    (ThirdHurewicz.normalizationHomotopy_face x)
+    (ThirdHurewicz.normalizationThreeSimplexHomotopy_zero x) smp
+
+@[simp]
+private theorem FourthHurewicz.lowerFourSimplexHomotopy_zero {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 4) (s : FirstHurewicz.Simplex 4) :
+    lowerFourSimplexHomotopy x smp (0, s) = smp s :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_zero _ _ _ _ smp s
+
+private theorem FourthHurewicz.lowerFourSimplexHomotopy_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 3
+      (ThirdHurewicz.normalizationThreeSimplexHomotopy x) (lowerFourSimplexHomotopy x) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_face
+    (ThirdHurewicz.normalizationTriangleHomotopy x)
+    (ThirdHurewicz.normalizationThreeSimplexHomotopy x)
+    (ThirdHurewicz.normalizationHomotopy_face x)
+    (ThirdHurewicz.normalizationThreeSimplexHomotopy_zero x)
+
+@[simp]
+private theorem FourthHurewicz.lowerFourSimplexHomotopy_const {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] :
+    lowerFourSimplexHomotopy x (ContinuousMap.const (FirstHurewicz.Simplex 4) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 4) x :=
+  ThirdHurewicz.extendCoherentSimplexHomotopy_const
+    (ThirdHurewicz.normalizationTriangleHomotopy x)
+    (ThirdHurewicz.normalizationThreeSimplexHomotopy x)
+    (ThirdHurewicz.normalizationHomotopy_face x)
+    (ThirdHurewicz.normalizationThreeSimplexHomotopy_zero x) x (lowerThreeSimplexHomotopy_const x)
+
+private def FourthHurewicz.lowerFiveSimplexHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 5) : C((unitInterval) × FirstHurewicz.Simplex 5, X) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy
+    (ThirdHurewicz.normalizationThreeSimplexHomotopy x) (lowerFourSimplexHomotopy x)
+    (lowerFourSimplexHomotopy_face x) (lowerFourSimplexHomotopy_zero x) smp
+
+@[simp]
+private theorem FourthHurewicz.lowerFiveSimplexHomotopy_zero {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 5) (s : FirstHurewicz.Simplex 5) :
+    lowerFiveSimplexHomotopy x smp (0, s) = smp s :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_zero _ _ _ _ smp s
+
+private theorem FourthHurewicz.lowerFiveSimplexHomotopy_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 4 (lowerFourSimplexHomotopy x)
+      (lowerFiveSimplexHomotopy x) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_face
+    (ThirdHurewicz.normalizationThreeSimplexHomotopy x) (lowerFourSimplexHomotopy x)
+    (lowerFourSimplexHomotopy_face x) (lowerFourSimplexHomotopy_zero x)
+
+@[simp]
+private theorem FourthHurewicz.lowerFiveSimplexHomotopy_const {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] :
+    lowerFiveSimplexHomotopy x (ContinuousMap.const (FirstHurewicz.Simplex 5) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 5) x :=
+  ThirdHurewicz.extendCoherentSimplexHomotopy_const
+    (ThirdHurewicz.normalizationThreeSimplexHomotopy x) (lowerFourSimplexHomotopy x)
+    (lowerFourSimplexHomotopy_face x) (lowerFourSimplexHomotopy_zero x) x
+    (lowerFourSimplexHomotopy_const x)
+
+private def HigherHurewicz.nativeCubeNullHomotopy {n : ℕ} {X : Type*} [TopologicalSpace X] {x : X}
+    [hπ : Subsingleton (π_ n X x)] (p : GenLoop (Fin n) X x) :
+    p.val.HomotopyRel (ContinuousMap.const (Fin n → (unitInterval)) x) (Cube.boundary (Fin n)) :=
+  Classical.choice
+    (show GenLoop.Homotopic p GenLoop.const from
+      Quotient.exact (@Subsingleton.elim (π_ n X x) hπ ⟦p⟧ ⟦GenLoop.const⟧))
+
+private def
+    HigherHurewicz.nativeCubeNullHomotopy_comp {n : ℕ} {X : Type*} [TopologicalSpace X] {x : X}
+    {A : Type*} [TopologicalSpace A] [Subsingleton (π_ n X x)] (p : GenLoop (Fin n) X x)
+    (r : C(A, Fin n → (unitInterval))) (S : Set A) (hr : Set.MapsTo r S (Cube.boundary (Fin n))) :
+    (p.val.comp r).HomotopyRel (ContinuousMap.const A x) S
+    where
+  toFun z := nativeCubeNullHomotopy p (z.1, r z.2)
+  continuous_toFun :=
+    (nativeCubeNullHomotopy p).continuous.comp
+      (continuous_fst.prodMk (r.continuous.comp continuous_snd))
+  map_zero_left a := (nativeCubeNullHomotopy p).apply_zero (r a)
+  map_one_left a := (nativeCubeNullHomotopy p).apply_one (r a)
+  prop' t _ ha := (nativeCubeNullHomotopy p).eq_fst t (hr ha)
+
+private def HigherHurewicz.basedSimplexNativeLoop {n : ℕ} {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedSimplex n x) : GenLoop (Fin n) X x :=
+  ⟨τ.val.comp ⟨(simplexCubeHomeomorph n).symm, (simplexCubeHomeomorph n).symm.continuous⟩,
+    fun u hu => τ.property _ ((simplexCubeHomeomorph_symm_boundary_iff n u).mpr hu)⟩
+
+private theorem HigherHurewicz.basedSimplexNativeLoop_comp_homeomorph {n : ℕ} {X : Type}
+    [TopologicalSpace X] {x : X} (τ : BasedSimplex n x) :
+    (basedSimplexNativeLoop τ).val.comp
+        ⟨simplexCubeHomeomorph n, (simplexCubeHomeomorph n).continuous⟩ =
+      τ.val := by
+  apply ContinuousMap.ext
+  intro s
+  change τ.val ((simplexCubeHomeomorph n).symm (simplexCubeHomeomorph n s)) = τ.val s
+  rw [Homeomorph.symm_apply_apply]
+
+private def
+    HigherHurewicz.simplexNullHomotopyUnnormalized {n : ℕ} {X : Type} [TopologicalSpace X] {x : X}
+    [Subsingleton (π_ n X x)] (τ : BasedSimplex n x) :
+    τ.val.HomotopyRel (ContinuousMap.const (FirstHurewicz.Simplex n) x)
+      (SecondHurewicz.SimplyConnected.simplexBoundary n) :=
+  ContinuousMap.HomotopyRel.cast
+    (nativeCubeNullHomotopy_comp (basedSimplexNativeLoop τ)
+      ⟨simplexCubeHomeomorph n, (simplexCubeHomeomorph n).continuous⟩
+      (SecondHurewicz.SimplyConnected.simplexBoundary n)
+      (fun s hs => (simplexCubeHomeomorph_boundary_iff n s).mpr hs))
+    (basedSimplexNativeLoop_comp_homeomorph τ) rfl
+
+private def HigherHurewicz.simplexNullHomotopy {n : ℕ} {X : Type} [TopologicalSpace X] {x : X}
+    [Subsingleton (π_ n X x)] (τ : BasedSimplex n x) :
+    τ.val.HomotopyRel (ContinuousMap.const (FirstHurewicz.Simplex n) x)
+      (SecondHurewicz.SimplyConnected.simplexBoundary n) := by
+  classical
+    exact
+    if h : τ = constantBasedSimplex n x then
+      ContinuousMap.HomotopyRel.cast
+        (ContinuousMap.HomotopyRel.refl (ContinuousMap.const (FirstHurewicz.Simplex n) x)
+          (SecondHurewicz.SimplyConnected.simplexBoundary n))
+        (congrArg (fun υ : BasedSimplex n x => υ.val) h).symm rfl
+    else simplexNullHomotopyUnnormalized τ
+
+private theorem
+    HigherHurewicz.simplexNullHomotopy_zero {n : ℕ} {X : Type} [TopologicalSpace X] {x : X}
+    [Subsingleton (π_ n X x)] (τ : BasedSimplex n x) (s : FirstHurewicz.Simplex n) :
+    simplexNullHomotopy τ (0, s) = τ.val s :=
+  (simplexNullHomotopy τ).apply_zero s
+
+private theorem
+    HigherHurewicz.simplexNullHomotopy_one {n : ℕ} {X : Type} [TopologicalSpace X] {x : X}
+    [Subsingleton (π_ n X x)] (τ : BasedSimplex n x) (s : FirstHurewicz.Simplex n) :
+    simplexNullHomotopy τ (1, s) = x :=
+  (simplexNullHomotopy τ).apply_one s
+
+@[simp]
+private theorem HigherHurewicz.simplexNullHomotopy_constant {X : Type} [TopologicalSpace X] (n : ℕ)
+    (x : X) [Subsingleton (π_ n X x)] :
+    simplexNullHomotopy (constantBasedSimplex n x) =
+      ContinuousMap.HomotopyRel.refl (ContinuousMap.const (FirstHurewicz.Simplex n) x)
+        (SecondHurewicz.SimplyConnected.simplexBoundary n) := by
+  classical
+  unfold simplexNullHomotopy
+  rw [dite_eq_left rfl]
+  rfl
+
+private theorem HigherHurewicz.simplexNullHomotopy_constant_toContinuousMap {X : Type}
+    [TopologicalSpace X] (n : ℕ) (x : X) [Subsingleton (π_ n X x)] :
+    (simplexNullHomotopy (constantBasedSimplex n x)).toContinuousMap =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex n) x := by
+  rw [simplexNullHomotopy_constant]
+  rfl
+
+private def
+    HigherHurewicz.simplexStraighteningHomotopy {X : Type} [TopologicalSpace X] (n : ℕ) (x : X)
+    [Subsingleton (π_ n X x)] (smp : FirstHurewicz.SingularSimplex X n) :
+    C((unitInterval) × FirstHurewicz.Simplex n, X) := by
+  classical
+    exact
+    if h : ∀ s ∈ SecondHurewicz.SimplyConnected.simplexBoundary n, smp s = x then
+      (simplexNullHomotopy (⟨smp, h⟩ : BasedSimplex n x)).toContinuousMap
+    else SecondHurewicz.SimplyConnected.stationarySimplexHomotopy n smp
+
+@[simp]
+private theorem
+    HigherHurewicz.simplexStraighteningHomotopy_zero {X : Type} [TopologicalSpace X] (n : ℕ)
+    (x : X) [Subsingleton (π_ n X x)] (smp : FirstHurewicz.SingularSimplex X n)
+    (s : FirstHurewicz.Simplex n) : simplexStraighteningHomotopy n x smp (0, s) = smp s := by
+  classical
+  unfold simplexStraighteningHomotopy
+  split
+  · rename_i h
+    exact simplexNullHomotopy_zero (⟨smp, h⟩ : BasedSimplex n x) s
+  · rfl
+
+private theorem
+    HigherHurewicz.simplexStraighteningHomotopy_one {X : Type} [TopologicalSpace X] (n : ℕ)
+    (x : X) [Subsingleton (π_ n X x)] (smp : FirstHurewicz.SingularSimplex X n)
+    (h : ∀ s ∈ SecondHurewicz.SimplyConnected.simplexBoundary n, smp s = x)
+    (s : FirstHurewicz.Simplex n) : simplexStraighteningHomotopy n x smp (1, s) = x := by
+  classical
+  rw [simplexStraighteningHomotopy, dite_eq_left h]
+  exact simplexNullHomotopy_one (⟨smp, h⟩ : BasedSimplex n x) s
+
+private theorem HigherHurewicz.simplexStraighteningHomotopy_boundary {X : Type} [TopologicalSpace X]
+    (n : ℕ) (x : X) [Subsingleton (π_ n X x)] (smp : FirstHurewicz.SingularSimplex X n)
+    (r : (unitInterval)) (s : FirstHurewicz.Simplex n)
+    (hs : s ∈ SecondHurewicz.SimplyConnected.simplexBoundary n) :
+    simplexStraighteningHomotopy n x smp (r, s) = smp s := by
+  classical
+  unfold simplexStraighteningHomotopy
+  split
+  · rename_i h
+    exact (simplexNullHomotopy (⟨smp, h⟩ : BasedSimplex n x)).eq_fst r hs
+  · rfl
+
+@[simp]
+private theorem
+    HigherHurewicz.simplexStraighteningHomotopy_const {X : Type} [TopologicalSpace X] (n : ℕ)
+    (x : X) [Subsingleton (π_ n X x)] :
+    simplexStraighteningHomotopy n x (ContinuousMap.const (FirstHurewicz.Simplex n) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex n) x := by
+  classical
+  have h :
+    ∀ s ∈ SecondHurewicz.SimplyConnected.simplexBoundary n,
+      (ContinuousMap.const (FirstHurewicz.Simplex n) x) s = x :=
+    fun _ _ => rfl
+  rw [simplexStraighteningHomotopy, dite_eq_left h]
+  exact simplexNullHomotopy_constant_toContinuousMap n x
+
+private theorem
+    HigherHurewicz.simplexStraighteningHomotopy_face {X : Type} [TopologicalSpace X] (n : ℕ)
+    (x : X) [Subsingleton (π_ (n + 1) X x)] :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n
+      (SecondHurewicz.SimplyConnected.stationarySimplexHomotopy n)
+      (simplexStraighteningHomotopy (n + 1) x) := by
+  intro smp i
+  ext u
+  change
+    simplexStraighteningHomotopy (n + 1) x smp (u.1, FirstHurewicz.simplexFace n i u.2) =
+      smp (FirstHurewicz.simplexFace n i u.2)
+  exact
+    simplexStraighteningHomotopy_boundary (n + 1) x smp u.1 _
+      ⟨i, FirstHurewicz.simplexFace_apply_self n i u.2⟩
+
+private def FourthHurewicz.threeFourSimplexHomotopy {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 3 X x)] (smp : FirstHurewicz.SingularSimplex X 4) :
+    C((unitInterval) × FirstHurewicz.Simplex 4, X) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy
+    (SecondHurewicz.SimplyConnected.stationarySimplexHomotopy 2)
+    (HigherHurewicz.simplexStraighteningHomotopy 3 x)
+    (HigherHurewicz.simplexStraighteningHomotopy_face 2 x)
+    (HigherHurewicz.simplexStraighteningHomotopy_zero 3 x) smp
+
+@[simp]
+private theorem FourthHurewicz.threeFourSimplexHomotopy_zero {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 3 X x)] (smp : FirstHurewicz.SingularSimplex X 4)
+    (s : FirstHurewicz.Simplex 4) : threeFourSimplexHomotopy x smp (0, s) = smp s :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_zero _ _ _ _ smp s
+
+private theorem FourthHurewicz.threeFourSimplexHomotopy_face {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 3 X x)] :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 3
+      (HigherHurewicz.simplexStraighteningHomotopy 3 x) (threeFourSimplexHomotopy x) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_face
+    (SecondHurewicz.SimplyConnected.stationarySimplexHomotopy 2)
+    (HigherHurewicz.simplexStraighteningHomotopy 3 x)
+    (HigherHurewicz.simplexStraighteningHomotopy_face 2 x)
+    (HigherHurewicz.simplexStraighteningHomotopy_zero 3 x)
+
+@[simp]
+private theorem
+    FourthHurewicz.threeFourSimplexHomotopy_const {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 3 X x)] :
+    threeFourSimplexHomotopy x (ContinuousMap.const (FirstHurewicz.Simplex 4) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 4) x :=
+  ThirdHurewicz.extendCoherentSimplexHomotopy_const
+    (SecondHurewicz.SimplyConnected.stationarySimplexHomotopy 2)
+    (HigherHurewicz.simplexStraighteningHomotopy 3 x)
+    (HigherHurewicz.simplexStraighteningHomotopy_face 2 x)
+    (HigherHurewicz.simplexStraighteningHomotopy_zero 3 x) x
+    (HigherHurewicz.simplexStraighteningHomotopy_const 3 x)
+
+private def FourthHurewicz.threeFiveSimplexHomotopy {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 3 X x)] (smp : FirstHurewicz.SingularSimplex X 5) :
+    C((unitInterval) × FirstHurewicz.Simplex 5, X) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy
+    (HigherHurewicz.simplexStraighteningHomotopy 3 x) (threeFourSimplexHomotopy x)
+    (threeFourSimplexHomotopy_face x) (threeFourSimplexHomotopy_zero x) smp
+
+@[simp]
+private theorem FourthHurewicz.threeFiveSimplexHomotopy_zero {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 3 X x)] (smp : FirstHurewicz.SingularSimplex X 5)
+    (s : FirstHurewicz.Simplex 5) : threeFiveSimplexHomotopy x smp (0, s) = smp s :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_zero _ _ _ _ smp s
+
+private theorem FourthHurewicz.threeFiveSimplexHomotopy_face {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 3 X x)] :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 4 (threeFourSimplexHomotopy x)
+      (threeFiveSimplexHomotopy x) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_face
+    (HigherHurewicz.simplexStraighteningHomotopy 3 x) (threeFourSimplexHomotopy x)
+    (threeFourSimplexHomotopy_face x) (threeFourSimplexHomotopy_zero x)
+
+@[simp]
+private theorem
+    FourthHurewicz.threeFiveSimplexHomotopy_const {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 3 X x)] :
+    threeFiveSimplexHomotopy x (ContinuousMap.const (FirstHurewicz.Simplex 5) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 5) x :=
+  ThirdHurewicz.extendCoherentSimplexHomotopy_const
+    (HigherHurewicz.simplexStraighteningHomotopy 3 x) (threeFourSimplexHomotopy x)
+    (threeFourSimplexHomotopy_face x) (threeFourSimplexHomotopy_zero x) x
+    (threeFourSimplexHomotopy_const x)
+
+private def FourthHurewicz.normalizationThreeSimplexHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] :
+    FirstHurewicz.SingularSimplex X 3 → C((unitInterval) × FirstHurewicz.Simplex 3, X) :=
+  ThirdHurewicz.composeSimplexHomotopies (ThirdHurewicz.normalizationThreeSimplexHomotopy x)
+    (HigherHurewicz.simplexStraighteningHomotopy 3 x)
+    (ThirdHurewicz.normalizationThreeSimplexHomotopy_zero x)
+    (HigherHurewicz.simplexStraighteningHomotopy_zero 3 x)
+
+private def FourthHurewicz.normalizationFourSimplexHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] :
+    FirstHurewicz.SingularSimplex X 4 → C((unitInterval) × FirstHurewicz.Simplex 4, X) :=
+  ThirdHurewicz.composeSimplexHomotopies (lowerFourSimplexHomotopy x) (threeFourSimplexHomotopy x)
+    (lowerFourSimplexHomotopy_zero x) (threeFourSimplexHomotopy_zero x)
+
+private def FourthHurewicz.normalizationFiveSimplexHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] :
+    FirstHurewicz.SingularSimplex X 5 → C((unitInterval) × FirstHurewicz.Simplex 5, X) :=
+  ThirdHurewicz.composeSimplexHomotopies (lowerFiveSimplexHomotopy x) (threeFiveSimplexHomotopy x)
+    (lowerFiveSimplexHomotopy_zero x) (threeFiveSimplexHomotopy_zero x)
+
+@[simp]
+private theorem FourthHurewicz.normalizationFourSimplexHomotopy_zero {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 4) (s : FirstHurewicz.Simplex 4) :
+    normalizationFourSimplexHomotopy x smp (0, s) = smp s :=
+  ThirdHurewicz.composeSimplexHomotopies_zero _ _ _ _ smp s
+
+@[simp]
+private theorem FourthHurewicz.normalizationFiveSimplexHomotopy_zero {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 5) (s : FirstHurewicz.Simplex 5) :
+    normalizationFiveSimplexHomotopy x smp (0, s) = smp s :=
+  ThirdHurewicz.composeSimplexHomotopies_zero _ _ _ _ smp s
+
+private theorem FourthHurewicz.normalizationHomotopy_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 3
+      (normalizationThreeSimplexHomotopy x) (normalizationFourSimplexHomotopy x) :=
+  ThirdHurewicz.composeSimplexHomotopies_face (ThirdHurewicz.normalizationThreeSimplexHomotopy x)
+    (HigherHurewicz.simplexStraighteningHomotopy 3 x) (lowerFourSimplexHomotopy x)
+    (threeFourSimplexHomotopy x) (ThirdHurewicz.normalizationThreeSimplexHomotopy_zero x)
+    (HigherHurewicz.simplexStraighteningHomotopy_zero 3 x) (lowerFourSimplexHomotopy_zero x)
+    (threeFourSimplexHomotopy_zero x) (lowerFourSimplexHomotopy_face x)
+    (threeFourSimplexHomotopy_face x)
+
+private theorem FourthHurewicz.normalizationFiveHomotopy_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 4 (normalizationFourSimplexHomotopy x)
+      (normalizationFiveSimplexHomotopy x) :=
+  ThirdHurewicz.composeSimplexHomotopies_face (lowerFourSimplexHomotopy x)
+    (threeFourSimplexHomotopy x) (lowerFiveSimplexHomotopy x) (threeFiveSimplexHomotopy x)
+    (lowerFourSimplexHomotopy_zero x) (threeFourSimplexHomotopy_zero x)
+    (lowerFiveSimplexHomotopy_zero x) (threeFiveSimplexHomotopy_zero x)
+    (lowerFiveSimplexHomotopy_face x) (threeFiveSimplexHomotopy_face x)
+
+@[simp]
+private theorem
+    FourthHurewicz.normalizationThreeSimplexHomotopy_const {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] :
+    normalizationThreeSimplexHomotopy x (ContinuousMap.const (FirstHurewicz.Simplex 3) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 3) x :=
+  ThirdHurewicz.composeSimplexHomotopies_const (ThirdHurewicz.normalizationThreeSimplexHomotopy x)
+    (HigherHurewicz.simplexStraighteningHomotopy 3 x)
+    (ThirdHurewicz.normalizationThreeSimplexHomotopy_zero x)
+    (HigherHurewicz.simplexStraighteningHomotopy_zero 3 x) x (lowerThreeSimplexHomotopy_const x)
+    (HigherHurewicz.simplexStraighteningHomotopy_const 3 x)
+
+@[simp]
+private theorem
+    FourthHurewicz.normalizationFourSimplexHomotopy_const {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] :
+    normalizationFourSimplexHomotopy x (ContinuousMap.const (FirstHurewicz.Simplex 4) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 4) x :=
+  ThirdHurewicz.composeSimplexHomotopies_const (lowerFourSimplexHomotopy x)
+    (threeFourSimplexHomotopy x) (lowerFourSimplexHomotopy_zero x)
+    (threeFourSimplexHomotopy_zero x) x (lowerFourSimplexHomotopy_const x)
+    (threeFourSimplexHomotopy_const x)
+
+@[simp]
+private theorem
+    FourthHurewicz.normalizationFiveSimplexHomotopy_const {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] :
+    normalizationFiveSimplexHomotopy x (ContinuousMap.const (FirstHurewicz.Simplex 5) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 5) x :=
+  ThirdHurewicz.composeSimplexHomotopies_const (lowerFiveSimplexHomotopy x)
+    (threeFiveSimplexHomotopy x) (lowerFiveSimplexHomotopy_zero x)
+    (threeFiveSimplexHomotopy_zero x) x (lowerFiveSimplexHomotopy_const x)
+    (threeFiveSimplexHomotopy_const x)
+
+@[simp]
+private theorem
+    FourthHurewicz.normalizationThreeSimplexHomotopy_endpoint {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 3) :
+    SecondHurewicz.SimplyConnected.timeSlice (normalizationThreeSimplexHomotopy x smp) 1 =
+      ContinuousMap.const (FirstHurewicz.Simplex 3) x := by
+  rw [normalizationThreeSimplexHomotopy, ThirdHurewicz.timeSlice_composeSimplexHomotopies_one,
+    ThirdHurewicz.normalizationThreeSimplexHomotopy_endpoint]
+  ext s
+  exact
+    HigherHurewicz.simplexStraighteningHomotopy_one 3 x
+      (ThirdHurewicz.normalizedThreeSimplex x smp).val
+      (ThirdHurewicz.normalizedThreeSimplex x smp).property s
+
+private def
+    HigherHurewicz.SimplexGeometry.prefixMinimum {n : ℕ} (u : Fin n → (unitInterval)) (k : ℕ) :
+    (unitInterval) :=
+  (Finset.univ.filter fun i : Fin n => i.val < k).inf u
+
+@[simp]
+private theorem
+    HigherHurewicz.SimplexGeometry.prefixMinimum_zero {n : ℕ} (u : Fin n → (unitInterval)) :
+    prefixMinimum u 0 = 1 := by
+  simp [prefixMinimum]
+  rfl
+
+private theorem HigherHurewicz.SimplexGeometry.prefixMinimum_antitone {n : ℕ}
+    (u : Fin n → (unitInterval)) : Antitone (prefixMinimum u) := by
+  intro k l hkl
+  apply Finset.inf_mono
+  intro i hi
+  simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hi ⊢
+  exact hi.trans_le hkl
+
+private theorem HigherHurewicz.SimplexGeometry.prefixMinimum_le_coordinate {n : ℕ}
+    (u : Fin n → (unitInterval)) (k : ℕ) (i : Fin n) (hi : i.val < k) : prefixMinimum u k ≤ u i :=
+  Finset.inf_le (Finset.mem_filter.mpr ⟨Finset.mem_univ i, hi⟩)
+
+private theorem
+    HigherHurewicz.SimplexGeometry.prefixMinimum_succ {n : ℕ} (u : Fin n → (unitInterval))
+    (k : ℕ) (hk : k < n) : prefixMinimum u (k + 1) = Min.min (prefixMinimum u k) (u ⟨k, hk⟩) := by
+  have hs :
+    (Finset.univ.filter fun i : Fin n => i.val < k + 1) =
+      Insert.insert ⟨k, hk⟩ (Finset.univ.filter fun i : Fin n => i.val < k) := by
+    ext i
+    simp only [Finset.mem_filter, Finset.mem_univ, true_and, Finset.mem_insert, Fin.ext_iff]
+    omega
+  unfold prefixMinimum
+  rw [hs, Finset.inf_insert]
+  exact min_comm _ _
+
+private theorem HigherHurewicz.SimplexGeometry.continuous_prefixMinimum (n k : ℕ) :
+    Continuous (fun u : Fin n → (unitInterval) => prefixMinimum u k) :=
+  Continuous.finset_inf_apply (fun i _ => continuous_apply i)
+
+private def
+    HigherHurewicz.SimplexGeometry.extendedMinimum {n : ℕ} (u : Fin n → (unitInterval)) (k : ℕ) :
+    (unitInterval) :=
+  if k ≤ n then prefixMinimum u k else 0
+
+private theorem
+    HigherHurewicz.SimplexGeometry.extendedMinimum_of_le {n : ℕ} (u : Fin n → (unitInterval))
+    (k : ℕ) (hk : k ≤ n) : extendedMinimum u k = prefixMinimum u k :=
+  ite_eq_left hk
+
+@[simp]
+private theorem
+    HigherHurewicz.SimplexGeometry.extendedMinimum_zero {n : ℕ} (u : Fin n → (unitInterval)) :
+    extendedMinimum u 0 = 1 := by simp [extendedMinimum]
+
+@[simp]
+private theorem HigherHurewicz.SimplexGeometry.extendedMinimum_last_succ {n : ℕ}
+    (u : Fin n → (unitInterval)) : extendedMinimum u (n + 1) = 0 := by simp [extendedMinimum]
+
+private theorem HigherHurewicz.SimplexGeometry.extendedMinimum_antitone {n : ℕ}
+    (u : Fin n → (unitInterval)) : Antitone (extendedMinimum u) := by
+  intro k l hkl
+  by_cases hl : l ≤ n
+  · have hk := hkl.trans hl
+    simpa only [extendedMinimum, ite_eq_left hk, ite_eq_left hl] using prefixMinimum_antitone u hkl
+  · rw [show extendedMinimum u l = 0 from ite_eq_right hl]
+    exact bot_le
+
+private theorem HigherHurewicz.SimplexGeometry.continuous_extendedMinimum (n k : ℕ) :
+    Continuous (fun u : Fin n → (unitInterval) => extendedMinimum u k) := by
+  by_cases hk : k ≤ n
+  · simpa only [extendedMinimum, ite_eq_left hk] using continuous_prefixMinimum n k
+  · simpa only [extendedMinimum, ite_eq_right hk] using
+      (continuous_const : Continuous (fun _ : Fin n → (unitInterval) => (0 : (unitInterval))))
+
+private def HigherHurewicz.SimplexGeometry.simplexQuotient (n : ℕ) :
+    C(Fin n → (unitInterval), FirstHurewicz.Simplex n)
+    where
+  toFun
+    u :=
+    ⟨fun i => (extendedMinimum u i.val : ℝ) - (extendedMinimum u (i.val + 1) : ℝ),
+      by
+      constructor
+      · intro i
+        exact sub_nonneg.mpr (extendedMinimum_antitone u (Nat.le_succ i.val))
+      · calc
+          (∑ i : Fin (n + 1),
+                ((extendedMinimum u i.val : ℝ) - (extendedMinimum u (i.val + 1) : ℝ))) =
+              ∑ i ∈ Finset.range (n + 1),
+                ((extendedMinimum u i : ℝ) - (extendedMinimum u (i + 1) : ℝ)) :=
+            Fin.sum_univ_eq_sum_range
+              (fun k : ℕ => (extendedMinimum u k : ℝ) - (extendedMinimum u (k + 1) : ℝ)) (n + 1)
+          _ = (extendedMinimum u 0 : ℝ) - (extendedMinimum u (n + 1) : ℝ) :=
+            (Finset.sum_range_sub' _ _)
+          _ = 1 := by simp⟩
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    apply continuous_pi
+    intro i
+    exact
+      (continuous_subtype_val.comp (continuous_extendedMinimum n i.val)).sub
+        (continuous_subtype_val.comp (continuous_extendedMinimum n (i.val + 1)))
+
+private theorem
+    HigherHurewicz.SimplexGeometry.simplexQuotient_apply {n : ℕ} (u : Fin n → (unitInterval))
+    (i : Fin (n + 1)) :
+    simplexQuotient n u i = (extendedMinimum u i.val : ℝ) - (extendedMinimum u (i.val + 1) : ℝ) :=
+  rfl
+
+private theorem HigherHurewicz.SimplexGeometry.simplexQuotient_castSucc {n : ℕ}
+    (u : Fin n → (unitInterval)) (i : Fin n) :
+    simplexQuotient n u i.castSucc =
+      (prefixMinimum u i.val : ℝ) - (prefixMinimum u (i.val + 1) : ℝ) := by
+  rw [simplexQuotient_apply]
+  exact
+    congrArg₂ (fun a b : (unitInterval) => (a : ℝ) - (b : ℝ))
+      (extendedMinimum_of_le u i.val i.isLt.le) (extendedMinimum_of_le u (i.val + 1) i.isLt)
+
+@[simp]
+private theorem
+    HigherHurewicz.SimplexGeometry.simplexQuotient_last {n : ℕ} (u : Fin n → (unitInterval)) :
+    simplexQuotient n u (Fin.last n) = (prefixMinimum u n : ℝ) := by
+  rw [simplexQuotient_apply]
+  simp only [Fin.val_last, extendedMinimum_last_succ, extendedMinimum_of_le u n le_rfl]
+  exact sub_zero _
+
+private theorem HigherHurewicz.SimplexGeometry.simplexQuotient_boundary_of_zero {n : ℕ}
+    (u : Fin n → (unitInterval)) (i : Fin n) (hi : u i = 0) :
+    simplexQuotient n u ∈ SecondHurewicz.SimplyConnected.simplexBoundary n := by
+  have hp : prefixMinimum u n = 0 :=
+    le_antisymm (hi ▸ prefixMinimum_le_coordinate u n i i.isLt) bot_le
+  exact ⟨Fin.last n, by rw [simplexQuotient_last, hp]; rfl⟩
+
+private theorem HigherHurewicz.SimplexGeometry.simplexQuotient_boundary_of_one {n : ℕ}
+    (u : Fin n → (unitInterval)) (i : Fin n) (hi : u i = 1) :
+    simplexQuotient n u ∈ SecondHurewicz.SimplyConnected.simplexBoundary n := by
+  refine ⟨i.castSucc, ?_⟩
+  rw [simplexQuotient_castSucc, prefixMinimum_succ u i.val i.isLt]
+  change
+    (prefixMinimum u i.val : ℝ) - (Min.min (prefixMinimum u i.val) (u i) : (unitInterval)) = 0
+  rw [hi, min_eq_left (show prefixMinimum u i.val ≤ 1 from (prefixMinimum u i.val).property.2)]
+  exact sub_self _
+
+private theorem HigherHurewicz.SimplexGeometry.simplexQuotient_boundary {n : ℕ}
+    (u : Fin n → (unitInterval)) (hu : u ∈ Cube.boundary (Fin n)) :
+    simplexQuotient n u ∈ SecondHurewicz.SimplyConnected.simplexBoundary n := by
+  obtain ⟨i, hi | hi⟩ := hu
+  · exact simplexQuotient_boundary_of_zero u i hi
+  · exact simplexQuotient_boundary_of_one u i hi
+
+private def HigherHurewicz.SimplexGeometry.BasedSimplex (n : ℕ) {X : Type*} [TopologicalSpace X]
+    (x : X) :=
+  { τ : C(FirstHurewicz.Simplex n, X) //
+    ∀ s ∈ SecondHurewicz.SimplyConnected.simplexBoundary n, τ s = x }
+
+private def HigherHurewicz.SimplexGeometry.basedSimplexLoop {X : Type*} [TopologicalSpace X] {x : X}
+    {n : ℕ} (τ : BasedSimplex n x) : GenLoop (Fin n) X x :=
+  ⟨τ.val.comp (simplexQuotient n), fun u hu => τ.property _ (simplexQuotient_boundary u hu)⟩
+
+private def
+    HigherHurewicz.SimplexGeometry.basedSimplexClass {X : Type*} [TopologicalSpace X] {x : X}
+    {n : ℕ} (τ : BasedSimplex n x) : Additive (π_ n X x) :=
+  Additive.ofMul (⟦basedSimplexLoop τ⟧ : π_ n X x)
+
+private theorem
+    HigherHurewicz.SimplexGeometry.basedSimplex_face {X : Type*} [TopologicalSpace X] {x : X}
+    {n : ℕ} (τ : BasedSimplex (n + 1) x) (i : Fin (n + 2)) :
+    τ.val.comp (FirstHurewicz.simplexFace n i) =
+      ContinuousMap.const (FirstHurewicz.Simplex n) x := by
+  apply ContinuousMap.ext
+  intro s
+  exact τ.property _ ⟨i, FirstHurewicz.simplexFace_apply_self n i s⟩
+
+private abbrev FourthHurewicz.fourSimplexBoundary : Set (FirstHurewicz.Simplex 4) :=
+  SecondHurewicz.SimplyConnected.simplexBoundary 4
+
+private abbrev FourthHurewicz.BasedFourSimplex {X : Type*} [TopologicalSpace X] (x : X) :=
+  HigherHurewicz.SimplexGeometry.BasedSimplex 4 x
+
+private abbrev FourthHurewicz.basedFourSimplexLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) : GenLoop (Fin 4) X x :=
+  HigherHurewicz.SimplexGeometry.basedSimplexLoop τ
+
+private abbrev FourthHurewicz.basedFourSimplexClass {X : Type*} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) : Additive (π_ 4 X x) :=
+  HigherHurewicz.SimplexGeometry.basedSimplexClass τ
+
+private theorem FourthHurewicz.basedFourSimplex_face {X : Type*} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) (i : Fin 5) :
+    τ.val.comp (FirstHurewicz.simplexFace 3 i) =
+      ContinuousMap.const (FirstHurewicz.Simplex 3) x :=
+  HigherHurewicz.SimplexGeometry.basedSimplex_face τ i
+
+private theorem HigherHurewicz.simplexEndpoint_face_constant {X : Type} [TopologicalSpace X] {n : ℕ}
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H H') (x : X)
+    (hone :
+      ∀ smp,
+        SecondHurewicz.SimplyConnected.timeSlice (H smp) 1 =
+          ContinuousMap.const (FirstHurewicz.Simplex n) x)
+    (smp : FirstHurewicz.SingularSimplex X (n + 1)) (i : Fin (n + 2)) :
+    (SecondHurewicz.SimplyConnected.timeSlice (H' smp) 1).comp (FirstHurewicz.simplexFace n i) =
+      ContinuousMap.const (FirstHurewicz.Simplex n) x :=
+  (SecondHurewicz.SimplyConnected.timeSlice_face hface smp i 1).trans (hone _)
+
+private theorem HigherHurewicz.simplexEndpoint_boundary {X : Type} [TopologicalSpace X] {n : ℕ}
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H H') (x : X)
+    (hone :
+      ∀ smp,
+        SecondHurewicz.SimplyConnected.timeSlice (H smp) 1 =
+          ContinuousMap.const (FirstHurewicz.Simplex n) x)
+    (smp : FirstHurewicz.SingularSimplex X (n + 1)) (s : FirstHurewicz.Simplex (n + 1))
+    (hs : s ∈ SecondHurewicz.SimplyConnected.simplexBoundary (n + 1)) :
+    SecondHurewicz.SimplyConnected.timeSlice (H' smp) 1 s = x := by
+  obtain ⟨i, t, ht⟩ :=
+    SecondHurewicz.SimplyConnected.simplexBoundary_exists_face n
+      (⟨s, hs⟩ : SecondHurewicz.SimplyConnected.SimplexBoundary (n + 1))
+  have he : FirstHurewicz.simplexFace n i t = s := congrArg Subtype.val ht
+  rw [← he]
+  exact
+    congrArg (fun f : C(FirstHurewicz.Simplex n, X) => f t)
+      (simplexEndpoint_face_constant H H' hface x hone smp i)
+
+private def
+    FourthHurewicz.normalizedFourSimplex {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 4) : BasedFourSimplex x :=
+  ⟨SecondHurewicz.SimplyConnected.timeSlice (normalizationFourSimplexHomotopy x smp) 1,
+    HigherHurewicz.simplexEndpoint_boundary (normalizationThreeSimplexHomotopy x)
+      (normalizationFourSimplexHomotopy x) (normalizationHomotopy_face x) x
+      (normalizationThreeSimplexHomotopy_endpoint x) smp⟩
+
+private theorem
+    FourthHurewicz.normalizationFourSimplexHomotopy_endpoint {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 4) :
+    SecondHurewicz.SimplyConnected.timeSlice (normalizationFourSimplexHomotopy x smp) 1 =
+      (normalizedFourSimplex x smp).val :=
+  rfl
+
+private def FourthHurewicz.normalizedFiveSimplexMap {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 5) : FirstHurewicz.SingularSimplex X 5 :=
+  SecondHurewicz.SimplyConnected.timeSlice (normalizationFiveSimplexHomotopy x smp) 1
+
+private theorem FourthHurewicz.normalizedFiveSimplexMap_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 5) (i : Fin 6) :
+    (normalizedFiveSimplexMap x smp).comp (FirstHurewicz.simplexFace 4 i) =
+      (normalizedFourSimplex x (smp.comp (FirstHurewicz.simplexFace 4 i))).val :=
+  SecondHurewicz.SimplyConnected.timeSlice_face (normalizationFiveHomotopy_face x) smp i 1
+
+private theorem
+    FourthHurewicz.normalizedFiveSimplexMap_face_boundary {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 5) (i : Fin 6) (s : FirstHurewicz.Simplex 4)
+    (hs : s ∈ fourSimplexBoundary) :
+    normalizedFiveSimplexMap x smp (FirstHurewicz.simplexFace 4 i s) = x := by
+  have hf :=
+    congrArg (fun f : C(FirstHurewicz.Simplex 4, X) => f s)
+      (normalizedFiveSimplexMap_face x smp i)
+  exact
+    hf.trans ((normalizedFourSimplex x (smp.comp (FirstHurewicz.simplexFace 4 i))).property s hs)
+
+private def FourthHurewicz.fourSimplexClassOperator {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] :
+    FirstHurewicz.Chains X 4 →ₗ[ℤ] Additive (π_ 4 X x) :=
+  FirstHurewicz.chainLift X 4 fun smp => basedFourSimplexClass (normalizedFourSimplex x smp)
+
+@[simp]
+private theorem FourthHurewicz.fourSimplexClassOperator_simplex {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 4) :
+    fourSimplexClassOperator x (FirstHurewicz.simplexChain X 4 smp) =
+      basedFourSimplexClass (normalizedFourSimplex x smp) :=
+  FirstHurewicz.chainLift_simplex X 4 _ smp
+
+private def HigherHurewicz.straightenedCycle {X : Type} [TopologicalSpace X] (n : ℕ)
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (h : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H H')
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) (n + 1)) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) (n + 1) :=
+  SingularMayerVietoris.ModuleHomology.mkCycle (FirstHurewicz.singularComplex X) (n + 1)
+    (SecondHurewicz.SimplyConnected.simplexEndpointOperator (n + 1) H' 1 c.1)
+    (by
+      have hc : ((FirstHurewicz.singularComplex X).d (n + 1) n).hom c.1 = 0 := by
+        exact
+          SingularMayerVietoris.ModuleHomology.cycle_condition (FirstHurewicz.singularComplex X)
+            (n + 1) c
+      rw [Nat.add_sub_cancel,
+        SecondHurewicz.SimplyConnected.simplexEndpointOperator_boundary n H H' h, hc, map_zero])
+
+@[simp]
+private theorem HigherHurewicz.straightenedCycle_val {X : Type} [TopologicalSpace X] (n : ℕ)
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (h : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H H')
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) (n + 1)) :
+    (straightenedCycle n H H' h c).1 =
+      SecondHurewicz.SimplyConnected.simplexEndpointOperator (n + 1) H' 1 c.1 :=
+  rfl
+
+private theorem HigherHurewicz.straightenedCycle_boundary {X : Type} [TopologicalSpace X] (n : ℕ)
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (h : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H H')
+    (h₀ : ∀ smp, SecondHurewicz.SimplyConnected.timeSlice (H' smp) 0 = smp)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) (n + 1)) :
+    ((FirstHurewicz.singularComplex X).d (n + 2) (n + 1)).hom
+        (SecondHurewicz.SimplyConnected.simplexPrismOperator (n + 1) H' c.1) =
+      (straightenedCycle n H H' h c).1 - c.1 := by
+  have hc : ((FirstHurewicz.singularComplex X).d (n + 1) n).hom c.1 = 0 := by
+    exact
+      SingularMayerVietoris.ModuleHomology.cycle_condition (FirstHurewicz.singularComplex X)
+        (n + 1) c
+  rw [SecondHurewicz.SimplyConnected.simplexPrismOperator_boundary n H H' h,
+    SecondHurewicz.SimplyConnected.simplexEndpointOperator_zero (n + 1) H' h₀, hc, map_zero,
+    sub_zero]
+  rfl
+
+private theorem HigherHurewicz.straightenedCycle_class {X : Type} [TopologicalSpace X] (n : ℕ)
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (h : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H H')
+    (h₀ : ∀ smp, SecondHurewicz.SimplyConnected.timeSlice (H' smp) 0 = smp)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) (n + 1)) :
+    SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) (n + 1)
+        (straightenedCycle n H H' h c) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) (n + 1)
+        c := by
+  apply
+    (SingularMayerVietoris.ModuleHomology.cycleClass_eq_iff (FirstHurewicz.singularComplex X)
+        (n + 1) _ _).mpr
+  exact
+    ⟨SecondHurewicz.SimplyConnected.simplexPrismOperator (n + 1) H' c.1,
+      straightenedCycle_boundary n H H' h h₀ c⟩
+
+private def
+    FourthHurewicz.normalizedFourChain {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] :
+    FirstHurewicz.Chains X 4 →ₗ[ℤ] FirstHurewicz.Chains X 4 :=
+  FirstHurewicz.chainLift X 4 fun smp =>
+    FirstHurewicz.simplexChain X 4 (normalizedFourSimplex x smp).val
+
+private def
+    FourthHurewicz.normalizedFourCycle {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 4) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 4 :=
+  HigherHurewicz.straightenedCycle 3 (normalizationThreeSimplexHomotopy x)
+    (normalizationFourSimplexHomotopy x) (normalizationHomotopy_face x) c
+
+@[simp]
+private theorem FourthHurewicz.normalizedFourCycle_val {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 4) :
+    (normalizedFourCycle x c).val = normalizedFourChain x c.val :=
+  rfl
+
+private theorem FourthHurewicz.normalizedFourCycle_class {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 4) :
+    SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 4
+        (normalizedFourCycle x c) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 4 c := by
+  apply
+    HigherHurewicz.straightenedCycle_class 3 (normalizationThreeSimplexHomotopy x)
+      (normalizationFourSimplexHomotopy x) (normalizationHomotopy_face x) _ c
+  intro smp
+  ext s
+  exact normalizationFourSimplexHomotopy_zero x smp s
+
+private def HigherHurewicz.singularHomologyDesc {X : Type} [TopologicalSpace X] {M : Type*}
+    [AddCommGroup M] [Module ℤ M] (n : ℕ) (F : FirstHurewicz.Chains X n →ₗ[ℤ] M)
+    (hF :
+      ∀ b : FirstHurewicz.Chains X (n + 1),
+        F (((FirstHurewicz.singularComplex X).d (n + 1) n).hom b) = 0) :
+    SingularMayerVietoris.SingularHomology X n →ₗ[ℤ] M :=
+  PeriodTorusHigherHomology.homologyDesc (FirstHurewicz.singularComplex X) n
+    (F.comp
+      (SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n).subtype)
+    (fun b => hF b)
+
+@[simp]
+private theorem
+    HigherHurewicz.singularHomologyDesc_cycleClass {X : Type} [TopologicalSpace X] {M : Type*}
+    [AddCommGroup M] [Module ℤ M] (n : ℕ) (F : FirstHurewicz.Chains X n →ₗ[ℤ] M)
+    (hF :
+      ∀ b : FirstHurewicz.Chains X (n + 1),
+        F (((FirstHurewicz.singularComplex X).d (n + 1) n).hom b) = 0)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    singularHomologyDesc n F hF
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n c) =
+      F c.1 :=
+  PeriodTorusHigherHomology.homologyDesc_cycleClass (FirstHurewicz.singularComplex X) n _ _ c
+
+private theorem
+    HigherHurewicz.comp_singularHomologyDesc_eq_id {X : Type} [TopologicalSpace X] {M : Type*}
+    [AddCommGroup M] [Module ℤ M] (n : ℕ) (F : FirstHurewicz.Chains X n →ₗ[ℤ] M)
+    (hF :
+      ∀ b : FirstHurewicz.Chains X (n + 1),
+        F (((FirstHurewicz.singularComplex X).d (n + 1) n).hom b) = 0)
+    (g : M →ₗ[ℤ] SingularMayerVietoris.SingularHomology X n)
+    (hg :
+      ∀ c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n,
+        g (F c.1) =
+          SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n c) :
+    g.comp (singularHomologyDesc n F hF) = LinearMap.id := by
+  apply PeriodTorusHigherHomology.homologyLinearMap_ext (FirstHurewicz.singularComplex X) n
+  intro c
+  simpa only [LinearMap.comp_apply, singularHomologyDesc_cycleClass, LinearMap.id_apply] using
+    hg c
+
+private theorem HigherHurewicz.boundarySignSum_even (n : ℕ) (hn : Even (n + 1)) :
+    (∑ i : Fin (n + 2), (-1 : ℤ) ^ i.val) = 1 := by
+  rw [Fin.sum_neg_one_pow]
+  have h : ¬Even (n + 2) := Nat.not_even_iff_odd.mpr hn.add_one
+  exact ite_eq_right h
+
+private theorem HigherHurewicz.boundarySignSum_odd (n : ℕ) (hn : Odd (n + 1)) :
+    (∑ i : Fin (n + 2), (-1 : ℤ) ^ i.val) = 0 := by
+  rw [Fin.sum_neg_one_pow]
+  have h : Even (n + 2) := hn.add_one
+  exact ite_eq_left h
+
+private def HigherHurewicz.constantSimplexChain {X : Type} [TopologicalSpace X] (n : ℕ) (x : X) :
+    FirstHurewicz.Chains X n :=
+  FirstHurewicz.simplexChain X n (ContinuousMap.const (FirstHurewicz.Simplex n) x)
+
+private theorem HigherHurewicz.boundary_constantSimplexChain {X : Type} [TopologicalSpace X] (n : ℕ)
+    (x : X) :
+    ((FirstHurewicz.singularComplex X).d (n + 1) n).hom (constantSimplexChain (n + 1) x) =
+      (∑ i : Fin (n + 2), (-1 : ℤ) ^ i.val) • constantSimplexChain n x := by
+  rw [constantSimplexChain, FirstHurewicz.boundary_simplex]
+  change (∑ i : Fin (n + 2), (-1 : ℤ) ^ i.val • constantSimplexChain n x) = _
+  exact
+    (map_sum (zmultiplesHom (FirstHurewicz.Chains X n) (constantSimplexChain n x))
+        (fun i : Fin (n + 2) => (-1 : ℤ) ^ i.val) Finset.univ).symm
+
+private theorem
+    HigherHurewicz.boundary_constantSimplexChain_even {X : Type} [TopologicalSpace X] (n : ℕ)
+    (x : X) (hn : Even (n + 1)) :
+    ((FirstHurewicz.singularComplex X).d (n + 1) n).hom (constantSimplexChain (n + 1) x) =
+      constantSimplexChain n x := by
+  rw [boundary_constantSimplexChain, boundarySignSum_even n hn, one_smul]
+
+private theorem
+    HigherHurewicz.boundary_constantSimplexChain_odd {X : Type} [TopologicalSpace X] (n : ℕ)
+    (x : X) (hn : Odd (n + 1)) :
+    ((FirstHurewicz.singularComplex X).d (n + 1) n).hom (constantSimplexChain (n + 1) x) = 0 := by
+  rw [boundary_constantSimplexChain, boundarySignSum_odd n hn, zero_smul]
+
+private theorem HigherHurewicz.constantSimplexChain_cycle_condition {X : Type} [TopologicalSpace X]
+    (n : ℕ) (x : X) (hn : Odd n) :
+    ((FirstHurewicz.singularComplex X).d n (n - 1)).hom (constantSimplexChain n x) = 0 := by
+  cases n with
+  | zero => simp at hn
+  | succ n => exact boundary_constantSimplexChain_odd n x hn
+
+private def HigherHurewicz.constantSimplexCycle {X : Type} [TopologicalSpace X] (n : ℕ) (x : X)
+    (hn : Odd n) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n :=
+  SingularMayerVietoris.ModuleHomology.mkCycle (FirstHurewicz.singularComplex X) n
+    (constantSimplexChain n x) (constantSimplexChain_cycle_condition n x hn)
+
+@[simp]
+private theorem
+    HigherHurewicz.constantSimplexCycle_val {X : Type} [TopologicalSpace X] (n : ℕ) (x : X)
+    (hn : Odd n) : (constantSimplexCycle n x hn).1 = constantSimplexChain n x :=
+  rfl
+
+@[simp]
+private theorem
+    HigherHurewicz.constantSimplexCycle_class {X : Type} [TopologicalSpace X] (n : ℕ) (x : X)
+    (hn : Odd n) :
+    SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n
+        (constantSimplexCycle n x hn) =
+      0 := by
+  apply
+    (SingularMayerVietoris.ModuleHomology.cycleClass_eq_zero_iff (FirstHurewicz.singularComplex X)
+        n _).mpr
+  exact ⟨constantSimplexChain (n + 1) x, boundary_constantSimplexChain_even n x hn.add_one⟩
+
+private def HigherHurewicz.correctedSimplexChain {X : Type} [TopologicalSpace X] (n : ℕ) (x : X)
+    (smp : FirstHurewicz.SingularSimplex X n) : FirstHurewicz.Chains X n :=
+  FirstHurewicz.simplexChain X n smp - constantSimplexChain n x
+
+private theorem
+    HigherHurewicz.correctedSimplexChain_boundary {X : Type} [TopologicalSpace X] (n : ℕ)
+    (x : X) (smp : FirstHurewicz.SingularSimplex X (n + 1))
+    (hfaces :
+      ∀ i : Fin (n + 2),
+        smp.comp (FirstHurewicz.simplexFace n i) =
+          ContinuousMap.const (FirstHurewicz.Simplex n) x) :
+    ((FirstHurewicz.singularComplex X).d (n + 1) n).hom (correctedSimplexChain (n + 1) x smp) =
+      0 := by
+  rw [correctedSimplexChain, map_sub, constantSimplexChain, FirstHurewicz.boundary_simplex,
+    FirstHurewicz.boundary_simplex]
+  simp only [hfaces, ContinuousMap.const_comp, sub_self]
+
+private def HigherHurewicz.correctedSimplexCycle {X : Type} [TopologicalSpace X] (n : ℕ) (x : X)
+    (smp : FirstHurewicz.SingularSimplex X (n + 1))
+    (hfaces :
+      ∀ i : Fin (n + 2),
+        smp.comp (FirstHurewicz.simplexFace n i) =
+          ContinuousMap.const (FirstHurewicz.Simplex n) x) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) (n + 1) :=
+  SingularMayerVietoris.ModuleHomology.mkCycle (FirstHurewicz.singularComplex X) (n + 1)
+    (correctedSimplexChain (n + 1) x smp) (correctedSimplexChain_boundary n x smp hfaces)
+
+@[simp]
+private theorem
+    HigherHurewicz.correctedSimplexCycle_val {X : Type} [TopologicalSpace X] (n : ℕ) (x : X)
+    (smp : FirstHurewicz.SingularSimplex X (n + 1))
+    (hfaces :
+      ∀ i : Fin (n + 2),
+        smp.comp (FirstHurewicz.simplexFace n i) =
+          ContinuousMap.const (FirstHurewicz.Simplex n) x) :
+    (correctedSimplexCycle n x smp hfaces).1 =
+      FirstHurewicz.simplexChain X (n + 1) smp - constantSimplexChain (n + 1) x :=
+  rfl
+
+private def FourthHurewicz.basedFourSimplexChain {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) : FirstHurewicz.Chains X 4 :=
+  HigherHurewicz.correctedSimplexChain 4 x τ.val
+
+@[simp]
+private theorem FourthHurewicz.basedFourSimplexChain_eq {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    basedFourSimplexChain τ =
+      FirstHurewicz.simplexChain X 4 τ.val -
+        FirstHurewicz.simplexChain X 4 (ContinuousMap.const (FirstHurewicz.Simplex 4) x) :=
+  rfl
+
+private def FourthHurewicz.basedFourSimplexCycle {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 4 :=
+  HigherHurewicz.correctedSimplexCycle 3 x τ.val (basedFourSimplex_face τ)
+
+@[simp]
+private theorem FourthHurewicz.basedFourSimplexCycle_val {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) : (basedFourSimplexCycle τ).1 = basedFourSimplexChain τ :=
+  rfl
+
+private theorem HigherHurewicz.chainAugmentation_boundary (X : Type) [TopologicalSpace X] (n : ℕ)
+    (c : FirstHurewicz.Chains X (n + 1)) :
+    SecondHurewicz.SimplyConnected.chainAugmentation X n
+        (((FirstHurewicz.singularComplex X).d (n + 1) n).hom c) =
+      (∑ i : Fin (n + 2), (-1 : ℤ) ^ i.val) •
+        SecondHurewicz.SimplyConnected.chainAugmentation X (n + 1) c := by
+  have h :
+    (SecondHurewicz.SimplyConnected.chainAugmentation X n).comp
+        ((FirstHurewicz.singularComplex X).d (n + 1) n).hom =
+      (∑ i : Fin (n + 2), (-1 : ℤ) ^ i.val) •
+        SecondHurewicz.SimplyConnected.chainAugmentation X (n + 1) := by
+    apply FirstHurewicz.chainMap_ext X (n + 1)
+    intro smp
+    simp only [LinearMap.comp_apply, FirstHurewicz.boundary_simplex, map_sum, map_zsmul,
+      SecondHurewicz.SimplyConnected.chainAugmentation_simplex, LinearMap.smul_apply,
+      zsmul_eq_mul, mul_one, Int.cast_id]
+  exact LinearMap.congr_fun h c
+
+private theorem
+    HigherHurewicz.chainAugmentation_boundary_even (X : Type) [TopologicalSpace X] (n : ℕ)
+    (hn : Even (n + 1)) (c : FirstHurewicz.Chains X (n + 1)) :
+    SecondHurewicz.SimplyConnected.chainAugmentation X n
+        (((FirstHurewicz.singularComplex X).d (n + 1) n).hom c) =
+      SecondHurewicz.SimplyConnected.chainAugmentation X (n + 1) c := by
+  rw [chainAugmentation_boundary, boundarySignSum_even n hn, one_smul]
+
+private theorem HigherHurewicz.chainAugmentation_evenCycle (X : Type) [TopologicalSpace X] (n : ℕ)
+    (hn : Even n) (hpos : 0 < n)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    SecondHurewicz.SimplyConnected.chainAugmentation X n c.1 = 0 := by
+  cases n with
+  | zero => exact False.elim (Nat.lt_irrefl 0 hpos)
+  | succ n =>
+    rw [← chainAugmentation_boundary_even X n hn]
+    have hc : ((FirstHurewicz.singularComplex X).d (n + 1) n).hom c.1 = 0 :=
+      SingularMayerVietoris.ModuleHomology.cycle_condition (FirstHurewicz.singularComplex X)
+        (n + 1) c
+    rw [hc, map_zero]
+
+private theorem
+    HigherHurewicz.chainLift_sub_constant_evenCycle (X : Type) [TopologicalSpace X] {M : Type}
+    [AddCommGroup M] [Module ℤ M] (n : ℕ) (hn : Even n) (hpos : 0 < n)
+    (f : FirstHurewicz.SingularSimplex X n → M) (m : M)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    FirstHurewicz.chainLift X n (fun smp => f smp - m) c.1 = FirstHurewicz.chainLift X n f c.1 := by
+  rw [SecondHurewicz.SimplyConnected.chainLift_sub_constant,
+    chainAugmentation_evenCycle X n hn hpos, zero_smul, sub_zero]
+
+private def FourthHurewicz.normalizedFourSimplexCycleOperator {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] :
+    FirstHurewicz.Chains X 4 →ₗ[ℤ]
+      SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 4 :=
+  FirstHurewicz.chainLift X 4 fun smp => basedFourSimplexCycle (normalizedFourSimplex x smp)
+
+@[simp]
+private theorem
+    FourthHurewicz.normalizedFourSimplexCycleOperator_simplex {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 4) :
+    normalizedFourSimplexCycleOperator x (FirstHurewicz.simplexChain X 4 smp) =
+      basedFourSimplexCycle (normalizedFourSimplex x smp) :=
+  FirstHurewicz.chainLift_simplex X 4 _ smp
+
+private theorem
+    FourthHurewicz.normalizedFourSimplexCycleOperator_val {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (c : FirstHurewicz.Chains X 4) :
+    (normalizedFourSimplexCycleOperator x c).val =
+      FirstHurewicz.chainLift X 4
+        (fun smp =>
+          FirstHurewicz.simplexChain X 4 (normalizedFourSimplex x smp).val -
+            FirstHurewicz.simplexChain X 4 (ContinuousMap.const (FirstHurewicz.Simplex 4) x))
+        c := by
+  have h :
+    (SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 4).subtype.comp
+        (normalizedFourSimplexCycleOperator x) =
+      FirstHurewicz.chainLift X 4
+        (fun smp =>
+          FirstHurewicz.simplexChain X 4 (normalizedFourSimplex x smp).val -
+            FirstHurewicz.simplexChain X 4 (ContinuousMap.const (FirstHurewicz.Simplex 4) x)) := by
+    apply FirstHurewicz.chainMap_ext X 4
+    intro smp
+    simp only [LinearMap.comp_apply, normalizedFourSimplexCycleOperator_simplex,
+      Submodule.subtype_apply, basedFourSimplexCycle_val, basedFourSimplexChain_eq,
+      FirstHurewicz.chainLift_simplex]
+  exact LinearMap.congr_fun h c
+
+private theorem
+    FourthHurewicz.normalizedFourSimplexCycleOperator_cycle {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 4) :
+    normalizedFourSimplexCycleOperator x c.val = normalizedFourCycle x c := by
+  apply Subtype.ext
+  rw [normalizedFourSimplexCycleOperator_val,
+    HigherHurewicz.chainLift_sub_constant_evenCycle X 4 (by decide) (by decide),
+    normalizedFourCycle_val]
+  rfl
+
+private theorem
+    FourthHurewicz.normalizedFourSimplexCycleOperator_class {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 4) :
+    SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 4
+        (normalizedFourSimplexCycleOperator x c.val) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 4 c := by
+  rw [normalizedFourSimplexCycleOperator_cycle, normalizedFourCycle_class]
+
+private abbrev HigherHurewicz.CubeTriangulation.CubeN (n : ℕ) :=
+  Fin n → (unitInterval)
+
+private def
+    HigherHurewicz.CubeTriangulation.cubeAffineSimplex {m n : ℕ} (v : Fin (m + 1) → CubeN n) :
+    C(FirstHurewicz.Simplex m, CubeN n)
+    where
+  toFun s
+    i :=
+    ⟨∑ j, s j * (v j i : ℝ), by
+      constructor
+      · exact Finset.sum_nonneg fun j _ => mul_nonneg (stdSimplex.zero_le s j) (v j i).property.1
+      · calc
+          ∑ j, s j * (v j i : ℝ) ≤ ∑ j, s j * 1 :=
+            Finset.sum_le_sum fun j _ =>
+              mul_le_mul_of_nonneg_left (v j i).property.2 (stdSimplex.zero_le s j)
+          _ = 1 := by simp only [mul_one, stdSimplex.sum_eq_one]⟩
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    apply Continuous.subtype_mk
+    exact
+      continuous_finsetSum _ fun j _ =>
+        ((continuous_apply j).comp continuous_subtype_val).mul continuous_const
+
+@[simp]
+private theorem HigherHurewicz.CubeTriangulation.cubeAffineSimplex_coordinate {m n : ℕ}
+    (v : Fin (m + 1) → CubeN n) (s : FirstHurewicz.Simplex m) (i : Fin n) :
+    (cubeAffineSimplex v s i : ℝ) = ∑ j, s j * (v j i : ℝ) :=
+  rfl
+
+@[simp]
+private theorem HigherHurewicz.CubeTriangulation.cubeAffineSimplex_vertex {m n : ℕ}
+    (v : Fin (m + 1) → CubeN n) (j : Fin (m + 1)) :
+    cubeAffineSimplex v (SingularMayerVietoris.stdVertices m j) = v j := by
+  funext i
+  apply Subtype.ext
+  simp [cubeAffineSimplex_coordinate, SingularMayerVietoris.stdVertices, stdSimplex.vertex,
+    Pi.single_apply]
+
+private theorem HigherHurewicz.CubeTriangulation.cubeAffineSimplex_face {m n : ℕ}
+    (v : Fin (m + 2) → CubeN n) (i : Fin (m + 2)) :
+    (cubeAffineSimplex v).comp (FirstHurewicz.simplexFace m i) =
+      cubeAffineSimplex (fun j => v (i.succAbove j)) := by
+  ext s k
+  change
+    (∑ j : Fin (m + 2), FirstHurewicz.simplexFace m i s j * (v j k : ℝ)) =
+      ∑ j : Fin (m + 1), s j * (v (i.succAbove j) k : ℝ)
+  rw [Fin.sum_univ_succAbove _ i]
+  simp only [FirstHurewicz.simplexFace_apply_self, MulZeroClass.zero_mul,
+    FirstHurewicz.simplexFace_apply_succAbove, zero_add]
+
+private theorem HigherHurewicz.CubeTriangulation.cubeAffineSimplex_constant_coordinate {m n : ℕ}
+    (v : Fin (m + 1) → CubeN n) (i : Fin n) (c : (unitInterval)) (h : ∀ j, v j i = c)
+    (s : FirstHurewicz.Simplex m) : cubeAffineSimplex v s i = c := by
+  apply Subtype.ext
+  simp only [cubeAffineSimplex_coordinate, h, ← Finset.sum_mul, stdSimplex.sum_eq_one, one_mul]
+
+private def HigherHurewicz.CubeTriangulation.cubeVertex {n : ℕ} (e : Equiv.Perm (Fin n))
+    (k : Fin (n + 1)) : CubeN n := fun i => if (e.symm i).val < k.val then 1 else 0
+
+private def HigherHurewicz.CubeTriangulation.cubeSimplex {n : ℕ} (e : Equiv.Perm (Fin n)) :
+    C(FirstHurewicz.Simplex n, CubeN n) :=
+  cubeAffineSimplex (cubeVertex e)
+
+private theorem
+    HigherHurewicz.CubeTriangulation.cubeSimplex_coordinate {n : ℕ} (e : Equiv.Perm (Fin n))
+    (s : FirstHurewicz.Simplex n) (i : Fin n) :
+    (cubeSimplex e s (e i) : ℝ) = ∑ k : Fin (n + 1), if i.val < k.val then s k else 0 := by
+  simp only [cubeSimplex, cubeAffineSimplex_coordinate, cubeVertex, Equiv.symm_apply_apply]
+  apply Finset.sum_congr rfl
+  intro k _
+  split_ifs <;> simp
+
+private theorem
+    HigherHurewicz.CubeTriangulation.cubeSimplex_antitone {n : ℕ} (e : Equiv.Perm (Fin n))
+    (s : FirstHurewicz.Simplex n) : Antitone (fun i => cubeSimplex e s (e i)) := by
+  intro i j hij
+  change (cubeSimplex e s (e j) : ℝ) ≤ (cubeSimplex e s (e i) : ℝ)
+  rw [cubeSimplex_coordinate, cubeSimplex_coordinate]
+  apply Finset.sum_le_sum
+  intro k _
+  by_cases hj : j.val < k.val
+  · have hi : i.val < k.val := lt_of_le_of_lt hij hj
+    simp only [ite_eq_left hj, ite_eq_left hi, le_refl]
+  · simp only [ite_eq_right hj]
+    split_ifs
+    · exact stdSimplex.zero_le s k
+    · exact le_refl 0
+
+private def HigherHurewicz.CubeTriangulation.cubeOrientation {n : ℕ} (e : Equiv.Perm (Fin n)) : ℤ :=
+  Equiv.Perm.sign e
+
+@[simp]
+private theorem HigherHurewicz.CubeTriangulation.cubeOrientation_refl (n : ℕ) :
+    cubeOrientation (Equiv.refl (Fin n)) = 1 := by simp [cubeOrientation]
+
+private theorem
+    HigherHurewicz.CubeTriangulation.cubeOrientation_swap {n : ℕ} (e : Equiv.Perm (Fin n))
+    {i j : Fin n} (h : i ≠ j) : cubeOrientation ((Equiv.swap i j).trans e) = -cubeOrientation e :=
+  by simp [cubeOrientation, Equiv.Perm.sign_trans, Equiv.Perm.sign_swap h]
+
+private abbrev
+    HigherHurewicz.CubeTriangulation.SortedCoordinates {n : ℕ} {α : Type*} [LinearOrder α]
+    (u : Fin n → α) (e : Equiv.Perm (Fin n)) : Prop :=
+  Antitone (fun i => u (e i))
+
+private def HigherHurewicz.CubeTriangulation.sortedPermutation {n : ℕ} {α : Type*} [LinearOrder α]
+    (u : Fin n → α) : Equiv.Perm (Fin n) :=
+  Tuple.sort (fun i => OrderDual.toDual (u i))
+
+private theorem HigherHurewicz.CubeTriangulation.sortedPermutation_sorted {n : ℕ} {α : Type*}
+    [LinearOrder α] (u : Fin n → α) : SortedCoordinates u (sortedPermutation u) :=
+  Tuple.monotone_sort (fun i => OrderDual.toDual (u i))
+
+private theorem HigherHurewicz.CubeTriangulation.exists_sortedPermutation {n : ℕ} {α : Type*}
+    [LinearOrder α] (u : Fin n → α) : ∃ e : Equiv.Perm (Fin n), SortedCoordinates u e :=
+  ⟨sortedPermutation u, sortedPermutation_sorted u⟩
+
+private theorem
+    HigherHurewicz.CubeTriangulation.sorted_values_eq {n : ℕ} {α : Type*} [LinearOrder α]
+    (u : Fin n → α) {e f : Equiv.Perm (Fin n)} (he : SortedCoordinates u e)
+    (hf : SortedCoordinates u f) : ∀ i : Fin n, u (e i) = u (f i) :=
+  congrFun (Tuple.unique_antitone he hf)
+
+private theorem HigherHurewicz.CubeTriangulation.sum_fin_differences {n : ℕ} (a : Fin (n + 1) → ℝ) :
+    ∑ i : Fin n, (a i.castSucc - a i.succ) = a 0 - a (Fin.last n) := by
+  rw [Finset.sum_sub_distrib]
+  have h₀ := Fin.sum_univ_succ a
+  have h₁ := Fin.sum_univ_castSucc a
+  linarith
+
+private theorem
+    HigherHurewicz.CubeTriangulation.sum_fin_differences_tail (n : ℕ) (a : Fin (n + 1) → ℝ)
+    (i : Fin n) :
+    ∑ k : Fin n, (if i.val ≤ k.val then a k.castSucc - a k.succ else 0) =
+      a i.castSucc - a (Fin.last n) := by
+  induction n with
+  | zero => exact Fin.elim0 i
+  | succ n ih =>
+    cases i using Fin.cases with
+    | zero =>
+      simpa only [Fin.val_zero, Nat.zero_le, ite_eq_left, Fin.castSucc_zero] using
+        sum_fin_differences a
+    | succ i =>
+      rw [Fin.sum_univ_succ]
+      simp only [Fin.val_zero, Fin.val_succ, Nat.add_one_le_iff, Nat.not_lt_zero, ite_false,
+        Nat.lt_succ_iff, zero_add, Fin.castSucc_succ]
+      simpa only [Fin.succ_last] using ih (fun k => a k.succ) i
+
+private def
+    HigherHurewicz.CubeTriangulation.cubeExtendedCoordinates {n : ℕ} (e : Equiv.Perm (Fin n))
+    (u : CubeN n) : Fin (n + 2) → ℝ :=
+  Fin.cons 1 (Fin.snoc (fun i => (u (e i) : ℝ)) 0)
+
+@[simp]
+private theorem HigherHurewicz.CubeTriangulation.cubeExtendedCoordinates_zero {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (u : CubeN n) : cubeExtendedCoordinates e u 0 = 1 := by
+  simp only [cubeExtendedCoordinates, Fin.cons_zero]
+
+@[simp]
+private theorem HigherHurewicz.CubeTriangulation.cubeExtendedCoordinates_last {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (u : CubeN n) : cubeExtendedCoordinates e u (Fin.last (n + 1)) = 0 :=
+  by
+  change cubeExtendedCoordinates e u (Fin.last n).succ = 0
+  unfold cubeExtendedCoordinates
+  simp only [Fin.cons_succ, Fin.snoc_last]
+
+@[simp]
+private theorem HigherHurewicz.CubeTriangulation.cubeExtendedCoordinates_inner {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (u : CubeN n) (i : Fin n) :
+    cubeExtendedCoordinates e u i.castSucc.succ = (u (e i) : ℝ) := by
+  simp only [cubeExtendedCoordinates, Fin.cons_succ, Fin.snoc_castSucc]
+
+private theorem HigherHurewicz.CubeTriangulation.cubeExtendedCoordinates_nonneg {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (u : CubeN n) (i : Fin (n + 2)) :
+    0 ≤ cubeExtendedCoordinates e u i := by
+  cases i using Fin.cases with
+  | zero => simp only [cubeExtendedCoordinates_zero, zero_le_one]
+  | succ i =>
+    cases i using Fin.lastCases with
+    | last => simp only [cubeExtendedCoordinates, Fin.cons_succ, Fin.snoc_last, le_refl]
+    | cast i => simpa only [cubeExtendedCoordinates_inner] using (u (e i)).property.1
+
+private theorem HigherHurewicz.CubeTriangulation.cubeExtendedCoordinates_le_one {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (u : CubeN n) (i : Fin (n + 2)) :
+    cubeExtendedCoordinates e u i ≤ 1 := by
+  cases i using Fin.cases with
+  | zero => simp only [cubeExtendedCoordinates_zero, le_refl]
+  | succ i =>
+    cases i using Fin.lastCases with
+    | last => simp only [cubeExtendedCoordinates, Fin.cons_succ, Fin.snoc_last, zero_le_one]
+    | cast i => simpa only [cubeExtendedCoordinates_inner] using (u (e i)).property.2
+
+private theorem HigherHurewicz.CubeTriangulation.cubeExtendedCoordinates_antitone {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (u : CubeN n) (h : SortedCoordinates u e) :
+    Antitone (cubeExtendedCoordinates e u) := by
+  intro i j hij
+  cases i using Fin.cases with
+  | zero => exact cubeExtendedCoordinates_le_one e u j
+  | succ i =>
+    cases j using Fin.cases with
+    | zero =>
+      have hh : i.val + 1 ≤ 0 := (Fin.le_iff_val_le_val).mp hij
+      omega
+    | succ j =>
+      cases j using Fin.lastCases with
+      | last =>
+        simpa only [Fin.succ_last, cubeExtendedCoordinates_last] using
+          cubeExtendedCoordinates_nonneg e u i.succ
+      | cast j =>
+        cases i using Fin.lastCases with
+        | last =>
+          have hj : j.val < n := j.isLt
+          have hh := (Fin.le_iff_val_le_val).mp hij
+          simp only [Fin.val_succ, Fin.val_last, Fin.val_castSucc] at hh
+          omega
+        | cast
+          i =>
+          have hh : i ≤ j := by
+            simpa only [Fin.succ_le_succ_iff, Fin.castSucc_le_castSucc_iff] using hij
+          have hreal : (u (e j) : ℝ) ≤ (u (e i) : ℝ) := h hh
+          simpa only [cubeExtendedCoordinates_inner] using hreal
+
+private def HigherHurewicz.CubeTriangulation.cubeBarycentric {n : ℕ} (e : Equiv.Perm (Fin n))
+    (u : CubeN n) : Fin (n + 1) → ℝ := fun i =>
+  cubeExtendedCoordinates e u i.castSucc - cubeExtendedCoordinates e u i.succ
+
+@[simp]
+private theorem HigherHurewicz.CubeTriangulation.cubeBarycentric_zero {n : ℕ}
+    (e : Equiv.Perm (Fin (n + 1))) (u : CubeN (n + 1)) :
+    cubeBarycentric e u 0 = 1 - (u (e 0) : ℝ) := by
+  simp only [cubeBarycentric, Fin.castSucc_zero, cubeExtendedCoordinates, Fin.cons_zero,
+    Fin.cons_succ, Fin.snoc_apply_zero]
+
+@[simp]
+private theorem HigherHurewicz.CubeTriangulation.cubeBarycentric_last {n : ℕ}
+    (e : Equiv.Perm (Fin (n + 1))) (u : CubeN (n + 1)) :
+    cubeBarycentric e u (Fin.last (n + 1)) = (u (e (Fin.last n)) : ℝ) := by
+  change
+    cubeExtendedCoordinates e u (Fin.last n).castSucc.succ -
+        cubeExtendedCoordinates e u (Fin.last (n + 2)) =
+      _
+  simp only [cubeExtendedCoordinates_inner, cubeExtendedCoordinates_last, sub_zero]
+
+private theorem HigherHurewicz.CubeTriangulation.cubeBarycentric_inner {n : ℕ}
+    (e : Equiv.Perm (Fin (n + 1))) (u : CubeN (n + 1)) (i : Fin n) :
+    cubeBarycentric e u i.succ.castSucc = (u (e i.castSucc) : ℝ) - (u (e i.succ) : ℝ) := by
+  change
+    cubeExtendedCoordinates e u i.castSucc.castSucc.succ -
+        cubeExtendedCoordinates e u i.succ.castSucc.succ =
+      _
+  simp only [cubeExtendedCoordinates_inner]
+
+private theorem
+    HigherHurewicz.CubeTriangulation.cubeBarycentric_nonneg {n : ℕ} (e : Equiv.Perm (Fin n))
+    (u : CubeN n) (h : SortedCoordinates u e) (i : Fin (n + 1)) : 0 ≤ cubeBarycentric e u i :=
+  sub_nonneg.mpr (cubeExtendedCoordinates_antitone e u h (Nat.le_succ i.val))
+
+private theorem
+    HigherHurewicz.CubeTriangulation.cubeBarycentric_sum {n : ℕ} (e : Equiv.Perm (Fin n))
+    (u : CubeN n) : ∑ i, cubeBarycentric e u i = 1 := by
+  unfold cubeBarycentric
+  rw [sum_fin_differences]
+  simp only [cubeExtendedCoordinates_zero, cubeExtendedCoordinates_last, sub_zero]
+
+private theorem
+    HigherHurewicz.CubeTriangulation.cubeBarycentric_tail {n : ℕ} (e : Equiv.Perm (Fin n))
+    (u : CubeN n) (i : Fin n) :
+    ∑ k : Fin (n + 1), (if i.val < k.val then cubeBarycentric e u k else 0) = (u (e i) : ℝ) := by
+  have h := sum_fin_differences_tail (n + 1) (cubeExtendedCoordinates e u) i.succ
+  simpa only [Fin.val_succ, Nat.succ_le_iff, cubeBarycentric, Fin.castSucc_succ,
+    cubeExtendedCoordinates_inner, cubeExtendedCoordinates_last, sub_zero] using h
+
+private theorem HigherHurewicz.SimplexGeometry.cubeSimplex_quotient_coordinate {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (u : Fin n → (unitInterval)) (i : Fin n) :
+    (HigherHurewicz.CubeTriangulation.cubeSimplex e (simplexQuotient n u) (e i) : ℝ) =
+      (prefixMinimum u (i.val + 1) : ℝ) := by
+  rw [HigherHurewicz.CubeTriangulation.cubeSimplex_coordinate]
+  have h :=
+    HigherHurewicz.CubeTriangulation.sum_fin_differences_tail (n + 1)
+      (fun k : Fin (n + 2) => (extendedMinimum u k.val : ℝ)) i.succ
+  simpa only [simplexQuotient_apply, Fin.val_castSucc, Fin.val_succ, Nat.succ_le_iff,
+    Fin.val_last, extendedMinimum_last_succ, show ((0 : (unitInterval)) : ℝ) = 0 from rfl,
+    sub_zero, extendedMinimum_of_le u (i.val + 1) i.isLt] using h
+
+private theorem HigherHurewicz.CubeTriangulation.cubeSimplex_coordinate_zero {n : ℕ}
+    (e : Equiv.Perm (Fin (n + 1))) (s : FirstHurewicz.Simplex (n + 1)) :
+    (cubeSimplex e s (e 0) : ℝ) = 1 - s 0 := by
+  rw [cubeSimplex_coordinate, Fin.sum_univ_succ]
+  simp only [Fin.val_zero, Nat.lt_irrefl, ite_false, Fin.val_succ, Nat.zero_lt_succ, ite_true,
+    zero_add]
+  have hs := stdSimplex.sum_eq_one s
+  rw [Fin.sum_univ_succ] at hs
+  linarith
+
+private theorem HigherHurewicz.CubeTriangulation.cubeSimplex_coordinate_last {n : ℕ}
+    (e : Equiv.Perm (Fin (n + 1))) (s : FirstHurewicz.Simplex (n + 1)) :
+    (cubeSimplex e s (e (Fin.last n)) : ℝ) = s (Fin.last (n + 1)) := by
+  rw [cubeSimplex_coordinate, Fin.sum_univ_castSucc]
+  simp only [Fin.val_last, Fin.val_castSucc, Nat.lt_succ_self, ite_true]
+  have hz : (∑ k : Fin (n + 1), if n < k.val then s k.castSucc else 0) = 0 := by
+    apply Finset.sum_eq_zero
+    intro k _
+    exact ite_eq_right (Nat.not_lt.mpr (Nat.le_of_lt_succ k.isLt))
+  rw [hz, zero_add]
+
+private theorem HigherHurewicz.CubeTriangulation.cubeSimplex_adjacent_difference {n : ℕ}
+    (e : Equiv.Perm (Fin (n + 1))) (s : FirstHurewicz.Simplex (n + 1)) (i : Fin n) :
+    (cubeSimplex e s (e i.castSucc) : ℝ) - (cubeSimplex e s (e i.succ) : ℝ) = s i.succ.castSucc :=
+  by
+  rw [cubeSimplex_coordinate, cubeSimplex_coordinate, ← Finset.sum_sub_distrib]
+  calc
+    ∑ k : Fin (n + 2),
+          ((if i.castSucc.val < k.val then s k else 0) -
+            (if i.succ.val < k.val then s k else 0)) =
+        ∑ k : Fin (n + 2), if k = i.succ.castSucc then s k else 0 := by
+      apply Finset.sum_congr rfl
+      intro k _
+      by_cases hk : k = i.succ.castSucc
+      · subst k
+        simp
+      · have hv : k.val ≠ i.val + 1 := by
+          intro h
+          apply hk
+          exact Fin.ext h
+        by_cases h : i.val < k.val
+        · have h' : i.val + 1 < k.val := by omega
+          simp only [Fin.val_castSucc, Fin.val_succ, ite_eq_left h, ite_eq_left h',
+            ite_eq_right hk, sub_self]
+        · have h' : ¬i.val + 1 < k.val := by omega
+          simp only [Fin.val_castSucc, Fin.val_succ, ite_eq_right h, ite_eq_right h',
+            ite_eq_right hk, sub_zero]
+    _ = s i.succ.castSucc := by simp
+
+private def HigherHurewicz.CubeTriangulation.cubeOrderedRegion {n : ℕ} (e : Equiv.Perm (Fin n)) :
+    Set (CubeN n) :=
+  {u | SortedCoordinates u e}
+
+private theorem HigherHurewicz.CubeTriangulation.continuous_cubeCoordinate {n : ℕ} (i : Fin n) :
+    Continuous (fun u : CubeN n => (u i : ℝ)) :=
+  continuous_subtype_val.comp (continuous_apply i)
+
+private theorem HigherHurewicz.CubeTriangulation.continuous_cubeExtendedCoordinates {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (i : Fin (n + 2)) :
+    Continuous (fun u : CubeN n => cubeExtendedCoordinates e u i) := by
+  cases i using Fin.cases with
+  | zero =>
+    simpa only [cubeExtendedCoordinates_zero] using
+      (continuous_const : Continuous (fun _ : CubeN n => (1 : ℝ)))
+  | succ i =>
+    cases i using Fin.lastCases with
+    | last =>
+      simpa only [Fin.succ_last, cubeExtendedCoordinates_last] using
+        (continuous_const : Continuous (fun _ : CubeN n => (0 : ℝ)))
+    | cast i => simpa only [cubeExtendedCoordinates_inner] using continuous_cubeCoordinate (e i)
+
+private theorem HigherHurewicz.CubeTriangulation.continuous_cubeBarycentric {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (i : Fin (n + 1)) :
+    Continuous (fun u : CubeN n => cubeBarycentric e u i) :=
+  (continuous_cubeExtendedCoordinates e i.castSucc).sub
+    (continuous_cubeExtendedCoordinates e i.succ)
+
+private def HigherHurewicz.CubeTriangulation.cubeSimplexInverse {n : ℕ} (e : Equiv.Perm (Fin n)) :
+    C(↥(cubeOrderedRegion e), FirstHurewicz.Simplex n)
+    where
+  toFun
+    u :=
+    ⟨cubeBarycentric e u.val,
+      ⟨cubeBarycentric_nonneg e u.val u.property, cubeBarycentric_sum e u.val⟩⟩
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    apply continuous_pi
+    intro i
+    exact (continuous_cubeBarycentric e i).comp continuous_subtype_val
+
+private theorem HigherHurewicz.CubeTriangulation.cubeSimplex_sorted {n : ℕ} (e : Equiv.Perm (Fin n))
+    (s : FirstHurewicz.Simplex n) : SortedCoordinates (cubeSimplex e s) e :=
+  cubeSimplex_antitone e s
+
+@[simp]
+private theorem
+    HigherHurewicz.CubeTriangulation.cubeSimplex_inverse {n : ℕ} (e : Equiv.Perm (Fin n))
+    (u : ↥(cubeOrderedRegion e)) : cubeSimplex e (cubeSimplexInverse e u) = u.val := by
+  funext k
+  obtain ⟨i, rfl⟩ := e.surjective k
+  apply Subtype.ext
+  rw [cubeSimplex_coordinate]
+  exact cubeBarycentric_tail e u.val i
+
+@[simp]
+private theorem HigherHurewicz.CubeTriangulation.cubeSimplexInverse_simplex {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (s : FirstHurewicz.Simplex n) :
+    cubeSimplexInverse e ⟨cubeSimplex e s, cubeSimplex_sorted e s⟩ = s := by
+  cases n with
+  | zero =>
+    exact
+      (FirstHurewicz.simplexZero_eq_vertex _).trans (FirstHurewicz.simplexZero_eq_vertex s).symm
+  | succ n =>
+    apply Subtype.ext
+    funext i
+    change cubeBarycentric e (cubeSimplex e s) i = s i
+    cases i using Fin.cases with
+    | zero =>
+      rw [cubeBarycentric_zero, cubeSimplex_coordinate_zero]
+      ring
+    | succ i =>
+      cases i using Fin.lastCases with
+      | last =>
+        simpa only [Fin.succ_last, cubeBarycentric_last] using cubeSimplex_coordinate_last e s
+      | cast i =>
+        simpa only [← Fin.castSucc_succ, cubeBarycentric_inner] using
+          cubeSimplex_adjacent_difference e s i
+
+private theorem
+    HigherHurewicz.CubeTriangulation.cubeSimplex_injective {n : ℕ} (e : Equiv.Perm (Fin n)) :
+    Function.Injective (cubeSimplex e) := by
+  intro s t h
+  have hh :
+    (⟨cubeSimplex e s, cubeSimplex_sorted e s⟩ : ↥(cubeOrderedRegion e)) =
+      ⟨cubeSimplex e t, cubeSimplex_sorted e t⟩ :=
+    Subtype.ext h
+  simpa only [cubeSimplexInverse_simplex] using congrArg (cubeSimplexInverse e) hh
+
+private theorem HigherHurewicz.SimplexGeometry.prefixMinimum_of_antitone {n : ℕ}
+    (u : Fin n → (unitInterval)) (hu : Antitone u) (i : Fin n) :
+    prefixMinimum u (i.val + 1) = u i := by
+  apply le_antisymm (prefixMinimum_le_coordinate u (i.val + 1) i (Nat.lt_succ_self _))
+  unfold prefixMinimum
+  apply Finset.le_inf
+  intro j hj
+  simp only [Finset.mem_filter, Finset.mem_univ, true_and] at hj
+  exact hu (Nat.le_of_lt_succ hj)
+
+private theorem HigherHurewicz.SimplexGeometry.cubeSimplex_quotient_of_antitone {n : ℕ}
+    (u : Fin n → (unitInterval)) (hu : Antitone u) :
+    HigherHurewicz.CubeTriangulation.cubeSimplex (Equiv.refl (Fin n)) (simplexQuotient n u) = u :=
+  by
+  funext i
+  apply Subtype.ext
+  simpa only [Equiv.refl_apply, prefixMinimum_of_antitone u hu i] using
+    cubeSimplex_quotient_coordinate (Equiv.refl (Fin n)) u i
+
+private theorem HigherHurewicz.SimplexGeometry.simplexQuotient_cubeSimplex_refl (n : ℕ) :
+    (simplexQuotient n).comp (HigherHurewicz.CubeTriangulation.cubeSimplex (Equiv.refl (Fin n))) =
+      ContinuousMap.id (FirstHurewicz.Simplex n) := by
+  apply ContinuousMap.ext
+  intro s
+  apply HigherHurewicz.CubeTriangulation.cubeSimplex_injective (Equiv.refl (Fin n))
+  exact
+    cubeSimplex_quotient_of_antitone _
+      (HigherHurewicz.CubeTriangulation.cubeSimplex_antitone (Equiv.refl (Fin n)) s)
+
+private theorem HigherHurewicz.SimplexGeometry.simplexQuotient_boundary_of_coordinate_le {n : ℕ}
+    (u : Fin n → (unitInterval)) (i j : Fin n) (hij : i < j) (hu : u i ≤ u j) :
+    simplexQuotient n u ∈ SecondHurewicz.SimplyConnected.simplexBoundary n := by
+  refine ⟨j.castSucc, ?_⟩
+  rw [simplexQuotient_castSucc, prefixMinimum_succ u j.val j.isLt]
+  have hp : prefixMinimum u j.val ≤ u j := (prefixMinimum_le_coordinate u j.val i hij).trans hu
+  rw [min_eq_left hp]
+  exact sub_self _
+
+private theorem HigherHurewicz.SimplexGeometry.cubeSimplex_coordinate_inversion {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (he : e ≠ Equiv.refl (Fin n)) (s : FirstHurewicz.Simplex n) :
+    ∃ i j : Fin n,
+      i < j ∧
+        HigherHurewicz.CubeTriangulation.cubeSimplex e s i ≤
+          HigherHurewicz.CubeTriangulation.cubeSimplex e s j := by
+  by_contra h
+  have hu : StrictAnti (HigherHurewicz.CubeTriangulation.cubeSimplex e s) := by
+    intro i j hij
+    exact lt_of_not_ge (fun hle => h ⟨i, j, hij, hle⟩)
+  have hm : Monotone e := by
+    intro i j hij
+    exact hu.le_iff_ge.mp (HigherHurewicz.CubeTriangulation.cubeSimplex_antitone e s hij)
+  apply he
+  apply Equiv.ext
+  intro i
+  exact (hm.strictMono_of_injective e.injective).apply_eq
+
+private theorem HigherHurewicz.SimplexGeometry.simplexQuotient_cubeSimplex_boundary {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (he : e ≠ Equiv.refl (Fin n)) (s : FirstHurewicz.Simplex n) :
+    simplexQuotient n (HigherHurewicz.CubeTriangulation.cubeSimplex e s) ∈
+      SecondHurewicz.SimplyConnected.simplexBoundary n := by
+  obtain ⟨i, j, hij, hu⟩ := cubeSimplex_coordinate_inversion e he s
+  exact simplexQuotient_boundary_of_coordinate_le _ i j hij hu
+
+private theorem HigherHurewicz.SimplexGeometry.basedSimplexLoop_cubeSimplex_refl {X : Type*}
+    [TopologicalSpace X] {x : X} {n : ℕ} (τ : BasedSimplex n x) :
+    (basedSimplexLoop τ).val.comp
+        (HigherHurewicz.CubeTriangulation.cubeSimplex (Equiv.refl (Fin n))) =
+      τ.val := by
+  change (τ.val.comp (simplexQuotient n)).comp _ = _
+  rw [ContinuousMap.comp_assoc, simplexQuotient_cubeSimplex_refl, ContinuousMap.comp_id]
+
+private theorem HigherHurewicz.SimplexGeometry.basedSimplexLoop_cubeSimplex_other {X : Type*}
+    [TopologicalSpace X] {x : X} {n : ℕ} (τ : BasedSimplex n x) (e : Equiv.Perm (Fin n))
+    (he : e ≠ Equiv.refl (Fin n)) :
+    (basedSimplexLoop τ).val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e) =
+      ContinuousMap.const (FirstHurewicz.Simplex n) x := by
+  apply ContinuousMap.ext
+  intro s
+  exact τ.property _ (simplexQuotient_cubeSimplex_boundary e he s)
+
+private theorem HigherHurewicz.SimplexGeometry.cubeOrientation_sum (n : ℕ) :
+    ∑ e : Equiv.Perm (Fin (n + 2)), HigherHurewicz.CubeTriangulation.cubeOrientation e = 0 := by
+  have hij : (0 : Fin (n + 2)) ≠ 1 := Fin.zero_ne_one
+  have h :=
+    Equiv.sum_comp (Equiv.mulRight (Equiv.swap (0 : Fin (n + 2)) 1))
+      (HigherHurewicz.CubeTriangulation.cubeOrientation (n := n + 2))
+  change
+    (∑ e : Equiv.Perm (Fin (n + 2)),
+        HigherHurewicz.CubeTriangulation.cubeOrientation ((Equiv.swap 0 1).trans e)) =
+      ∑ e : Equiv.Perm (Fin (n + 2)), HigherHurewicz.CubeTriangulation.cubeOrientation e at h
+  simp_rw [HigherHurewicz.CubeTriangulation.cubeOrientation_swap _ hij] at h
+  rw [Finset.sum_neg_distrib] at h
+  omega
+
+private theorem HigherHurewicz.SimplexGeometry.basedSimplex_simplexChain_sum {X : Type}
+    [TopologicalSpace X] {x : X} {n : ℕ} (τ : BasedSimplex (n + 2) x) :
+    (∑ e : Equiv.Perm (Fin (n + 2)),
+        HigherHurewicz.CubeTriangulation.cubeOrientation e •
+          FirstHurewicz.simplexChain X (n + 2)
+            ((basedSimplexLoop τ).val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e))) =
+      HigherHurewicz.correctedSimplexChain (n + 2) x τ.val := by
+  classical
+  let c := HigherHurewicz.constantSimplexChain (n + 2) x
+  have heq (e : Equiv.Perm (Fin (n + 2))) :
+    HigherHurewicz.CubeTriangulation.cubeOrientation e •
+        FirstHurewicz.simplexChain X (n + 2)
+          ((basedSimplexLoop τ).val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e)) =
+      (if e = Equiv.refl (Fin (n + 2)) then HigherHurewicz.correctedSimplexChain (n + 2) x τ.val
+        else 0) +
+        HigherHurewicz.CubeTriangulation.cubeOrientation e • c := by
+    by_cases he : e = Equiv.refl (Fin (n + 2))
+    · subst e
+      rw [basedSimplexLoop_cubeSimplex_refl,
+        HigherHurewicz.CubeTriangulation.cubeOrientation_refl, one_smul, ite_eq_left rfl, one_smul]
+      change
+        FirstHurewicz.simplexChain X (n + 2) τ.val =
+          (FirstHurewicz.simplexChain X (n + 2) τ.val - c) + c
+      exact (sub_add_cancel _ _).symm
+    · rw [basedSimplexLoop_cubeSimplex_other τ e he, ite_eq_right he, zero_add]
+      rfl
+  calc
+    _ =
+        ∑ e : Equiv.Perm (Fin (n + 2)),
+          ((if e = Equiv.refl (Fin (n + 2)) then
+              HigherHurewicz.correctedSimplexChain (n + 2) x τ.val
+            else 0) +
+            HigherHurewicz.CubeTriangulation.cubeOrientation e • c) :=
+      Finset.sum_congr rfl (fun e _ => heq e)
+    _ =
+        HigherHurewicz.correctedSimplexChain (n + 2) x τ.val +
+          (∑ e : Equiv.Perm (Fin (n + 2)), HigherHurewicz.CubeTriangulation.cubeOrientation e) •
+            c := by
+      rw [Finset.sum_add_distrib]
+      have hc :
+        (∑ e : Equiv.Perm (Fin (n + 2)), HigherHurewicz.CubeTriangulation.cubeOrientation e) • c =
+          ∑ e : Equiv.Perm (Fin (n + 2)),
+            HigherHurewicz.CubeTriangulation.cubeOrientation e • c := by
+        let f : ℤ →+ FirstHurewicz.Chains X (n + 2) :=
+          { toFun := fun k => k • c
+            map_zero' := zero_zsmul c
+            map_add' := fun a b => add_zsmul c a b }
+        exact map_sum f HigherHurewicz.CubeTriangulation.cubeOrientation Finset.univ
+      rw [← hc]
+      simp
+    _ = HigherHurewicz.correctedSimplexChain (n + 2) x τ.val := by
+      rw [cubeOrientation_sum n, zero_smul, add_zero]
+
+private theorem
+    FourthHurewicz.basedFourSimplex_simplexChain_sum {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    (∑ e : Equiv.Perm (Fin 4),
+        HigherHurewicz.CubeTriangulation.cubeOrientation e •
+          FirstHurewicz.simplexChain X 4
+            ((basedFourSimplexLoop τ).val.comp
+              (HigherHurewicz.CubeTriangulation.cubeSimplex e))) =
+      basedFourSimplexChain τ :=
+  HigherHurewicz.SimplexGeometry.basedSimplex_simplexChain_sum τ
+
+private theorem
+    FourthHurewicz.CubeSubdivision.signed_sum_eq_zero_of_swap_invariant {n : ℕ} {A : Type*}
+    [AddCommGroup A] (i j : Fin n) (hij : i ≠ j) (f : Equiv.Perm (Fin n) → A)
+    (hf : ∀ e, f ((Equiv.swap i j).trans e) = f e) :
+    ∑ e, HigherHurewicz.CubeTriangulation.cubeOrientation e • f e = 0 := by
+  classical
+  apply Finset.sum_ninvolution (fun e => (Equiv.swap i j).trans e)
+  · intro e
+    rw [HigherHurewicz.CubeTriangulation.cubeOrientation_swap e hij, hf, neg_smul, add_neg_cancel]
+  · intro e _ he
+    have h := congrArg (fun k : Equiv.Perm (Fin n) => k i) he
+    have h' : e j = e i := by simpa using h
+    exact hij (e.injective h').symm
+  · intro e
+    exact Finset.mem_univ _
+  · intro e
+    ext k
+    simp
+
+private theorem
+    FourthHurewicz.CubeSubdivision.signed_sum_constant_eq_zero {n : ℕ} [Nontrivial (Fin n)]
+    {A : Type*} [AddCommGroup A] (a : A) :
+    ∑ e : Equiv.Perm (Fin n), HigherHurewicz.CubeTriangulation.cubeOrientation e • a = 0 := by
+  obtain ⟨i, j, hij⟩ := exists_pair_ne (Fin n)
+  exact signed_sum_eq_zero_of_swap_invariant i j hij (fun _ => a) (fun _ => rfl)
+
+private theorem HigherHurewicz.CubeTriangulation.cubeVertex_swap_of_ne {n : ℕ}
+    (e : Equiv.Perm (Fin (n + 1))) (i : Fin n) (k : Fin (n + 2)) (hk : k ≠ i.succ.castSucc) :
+    cubeVertex e k = cubeVertex ((Equiv.swap i.castSucc i.succ).trans e) k := by
+  funext coord
+  change
+    (if (e.symm coord).val < k.val then (1 : (unitInterval)) else 0) =
+      if ((Equiv.swap i.castSucc i.succ) (e.symm coord)).val < k.val then 1 else 0
+  have hk' : k.val ≠ i.val + 1 := by
+    intro h
+    exact hk (Fin.ext h)
+  by_cases h₀ : e.symm coord = i.castSucc
+  · rw [h₀, Equiv.swap_apply_left]
+    simp only [Fin.val_castSucc, Fin.val_succ]
+    have h : i.val < k.val ↔ i.val + 1 < k.val := by omega
+    simp only [h]
+  by_cases h₁ : e.symm coord = i.succ
+  · rw [h₁, Equiv.swap_apply_right]
+    simp only [Fin.val_castSucc, Fin.val_succ]
+    have h : i.val + 1 < k.val ↔ i.val < k.val := by omega
+    simp only [h]
+  · rw [Equiv.swap_apply_of_ne_of_ne h₀ h₁]
+
+private theorem HigherHurewicz.CubeTriangulation.cubeSimplex_face_swap {n : ℕ}
+    (e : Equiv.Perm (Fin (n + 1))) (i : Fin n) :
+    (cubeSimplex e).comp (FirstHurewicz.simplexFace n i.succ.castSucc) =
+      (cubeSimplex ((Equiv.swap i.castSucc i.succ).trans e)).comp
+        (FirstHurewicz.simplexFace n i.succ.castSucc) := by
+  simp only [cubeSimplex, cubeAffineSimplex_face]
+  congr 1
+  funext j
+  exact cubeVertex_swap_of_ne e i _ (Fin.succAbove_ne _ _)
+
+private theorem HigherHurewicz.CubeTriangulation.cubeSimplex_face_zero_coordinate {n : ℕ}
+    (e : Equiv.Perm (Fin (n + 1))) (s : FirstHurewicz.Simplex n) :
+    cubeSimplex e (FirstHurewicz.simplexFace n 0 s) (e 0) = 1 := by
+  change ((cubeAffineSimplex (cubeVertex e)).comp (FirstHurewicz.simplexFace n 0)) s (e 0) = 1
+  rw [cubeAffineSimplex_face]
+  apply cubeAffineSimplex_constant_coordinate
+  intro j
+  simp [cubeVertex]
+
+private theorem HigherHurewicz.CubeTriangulation.cubeSimplex_face_last_coordinate {n : ℕ}
+    (e : Equiv.Perm (Fin (n + 1))) (s : FirstHurewicz.Simplex n) :
+    cubeSimplex e (FirstHurewicz.simplexFace n (Fin.last (n + 1)) s) (e (Fin.last n)) = 0 := by
+  change
+    ((cubeAffineSimplex (cubeVertex e)).comp (FirstHurewicz.simplexFace n (Fin.last (n + 1)))) s
+        (e (Fin.last n)) =
+      0
+  rw [cubeAffineSimplex_face]
+  apply cubeAffineSimplex_constant_coordinate
+  intro j
+  simp only [cubeVertex, Equiv.symm_apply_apply, Fin.succAbove_last, Fin.val_castSucc,
+    Fin.val_last]
+  exact ite_eq_right (Nat.not_lt.mpr (Nat.le_of_lt_succ j.isLt))
+
+private theorem HigherHurewicz.CubeTriangulation.cubeSimplex_face_zero_boundary {n : ℕ}
+    (e : Equiv.Perm (Fin (n + 1))) (s : FirstHurewicz.Simplex n) :
+    cubeSimplex e (FirstHurewicz.simplexFace n 0 s) ∈ Cube.boundary (Fin (n + 1)) :=
+  ⟨e 0, Or.inr (cubeSimplex_face_zero_coordinate e s)⟩
+
+private theorem HigherHurewicz.CubeTriangulation.cubeSimplex_face_last_boundary {n : ℕ}
+    (e : Equiv.Perm (Fin (n + 1))) (s : FirstHurewicz.Simplex n) :
+    cubeSimplex e (FirstHurewicz.simplexFace n (Fin.last (n + 1)) s) ∈
+      Cube.boundary (Fin (n + 1)) :=
+  ⟨e (Fin.last n), Or.inl (cubeSimplex_face_last_coordinate e s)⟩
+
+private def FourthHurewicz.CubeSubdivision.prismCubeVertex {n : ℕ} (e : Equiv.Perm (Fin n))
+    (z : Fin 2 × Fin (n + 1)) : HigherHurewicz.CubeTriangulation.CubeN (n + 1) :=
+  Fin.cases (FirstHurewicz.pathSimplex Path.id (SingularMayerVietoris.stdVertices 1 z.1))
+    (HigherHurewicz.CubeTriangulation.cubeVertex e z.2)
+
+@[simp]
+private theorem FourthHurewicz.CubeSubdivision.prismCubeVertex_succ {n : ℕ} (e : Equiv.Perm (Fin n))
+    (z : Fin 2 × Fin (n + 1)) (i : Fin n) :
+    prismCubeVertex e z i.succ = HigherHurewicz.CubeTriangulation.cubeVertex e z.2 i :=
+  rfl
+
+private def FourthHurewicz.CubeSubdivision.prismCubeSimplex {m n : ℕ} (e : Equiv.Perm (Fin n))
+    (v : Fin (m + 1) → Fin 2 × Fin (n + 1)) :
+    C(FirstHurewicz.Simplex m, HigherHurewicz.CubeTriangulation.CubeN (n + 1)) :=
+  HigherHurewicz.CubeTriangulation.cubeAffineSimplex (fun j => prismCubeVertex e (v j))
+
+private theorem FourthHurewicz.CubeSubdivision.prismCubeVertex_swap_of_ne {n : ℕ}
+    (e : Equiv.Perm (Fin (n + 1))) (i : Fin n) (z : Fin 2 × Fin (n + 2))
+    (hz : z.2 ≠ i.succ.castSucc) :
+    prismCubeVertex e z = prismCubeVertex ((Equiv.swap i.castSucc i.succ).trans e) z := by
+  funext coord
+  refine Fin.cases ?_ (fun k => ?_) coord
+  · rfl
+  · exact congrFun (HigherHurewicz.CubeTriangulation.cubeVertex_swap_of_ne e i z.2 hz) k
+
+private theorem FourthHurewicz.CubeSubdivision.prismCubeSimplex_swap_of_omitted {m n : ℕ}
+    (e : Equiv.Perm (Fin (n + 1))) (i : Fin n) (v : Fin (m + 1) → Fin 2 × Fin (n + 2))
+    (hv : ∀ j, (v j).2 ≠ i.succ.castSucc) :
+    prismCubeSimplex e v = prismCubeSimplex ((Equiv.swap i.castSucc i.succ).trans e) v := by
+  apply congrArg HigherHurewicz.CubeTriangulation.cubeAffineSimplex
+  funext j
+  exact prismCubeVertex_swap_of_ne e i (v j) (hv j)
+
+private theorem FourthHurewicz.CubeSubdivision.prismCubeSimplex_zero_of_left_zero {m n : ℕ}
+    (e : Equiv.Perm (Fin n)) (v : Fin (m + 1) → Fin 2 × Fin (n + 1)) (hv : ∀ j, (v j).1 = 0)
+    (s : FirstHurewicz.Simplex m) : prismCubeSimplex e v s 0 = 0 := by
+  apply HigherHurewicz.CubeTriangulation.cubeAffineSimplex_constant_coordinate
+  intro j
+  simp [prismCubeVertex, hv j, SingularMayerVietoris.stdVertices]
+
+private theorem FourthHurewicz.CubeSubdivision.prismCubeSimplex_zero_of_last_omitted {m n : ℕ}
+    (e : Equiv.Perm (Fin (n + 1))) (v : Fin (m + 1) → Fin 2 × Fin (n + 2))
+    (hv : ∀ j, (v j).2 ≠ Fin.last (n + 1)) (s : FirstHurewicz.Simplex m) :
+    prismCubeSimplex e v s (e (Fin.last n)).succ = 0 := by
+  apply HigherHurewicz.CubeTriangulation.cubeAffineSimplex_constant_coordinate
+  intro j
+  simp only [prismCubeVertex_succ, HigherHurewicz.CubeTriangulation.cubeVertex,
+    Equiv.symm_apply_apply, Fin.val_last]
+  apply ite_eq_right
+  have hne : (v j).2.val ≠ n + 1 := by
+    intro h
+    exact hv j (Fin.ext h)
+  have hlt := (v j).2.isLt
+  omega
+
+private def
+    FourthHurewicz.CubeSubdivision.prismCubeRealization {X : Type} [TopologicalSpace X] {n : ℕ}
+    (p : C(HigherHurewicz.CubeTriangulation.CubeN (n + 1), X)) (e : Equiv.Perm (Fin n)) (m : ℕ) :
+    SingularMayerVietoris.FormalChains (Fin 2 × Fin (n + 1)) (m + 1) →ₗ[ℤ]
+      FirstHurewicz.Chains X m :=
+  SingularMayerVietoris.formalLift fun v =>
+    FirstHurewicz.simplexChain X m (p.comp (prismCubeSimplex e v))
+
+@[simp]
+private theorem FourthHurewicz.CubeSubdivision.prismCubeRealization_simplex {X : Type}
+    [TopologicalSpace X] {n : ℕ} (p : C(HigherHurewicz.CubeTriangulation.CubeN (n + 1), X))
+    (e : Equiv.Perm (Fin n)) (m : ℕ) (v : Fin (m + 1) → Fin 2 × Fin (n + 1)) :
+    prismCubeRealization p e m (SingularMayerVietoris.formalSimplex v) =
+      FirstHurewicz.simplexChain X m (p.comp (prismCubeSimplex e v)) :=
+  SingularMayerVietoris.formalLift_simplex _ _
+
+private def FourthHurewicz.CubeSubdivision.orientedPrismRealization {X : Type} [TopologicalSpace X]
+    {n : ℕ} (p : C(HigherHurewicz.CubeTriangulation.CubeN (n + 1), X)) (m : ℕ) :
+    SingularMayerVietoris.FormalChains (Fin 2 × Fin (n + 1)) (m + 1) →ₗ[ℤ]
+      FirstHurewicz.Chains X m :=
+  SingularMayerVietoris.formalLift fun v =>
+    ∑ e : Equiv.Perm (Fin n),
+      HigherHurewicz.CubeTriangulation.cubeOrientation e •
+        FirstHurewicz.simplexChain X m (p.comp (prismCubeSimplex e v))
+
+@[simp]
+private theorem FourthHurewicz.CubeSubdivision.orientedPrismRealization_simplex {X : Type}
+    [TopologicalSpace X] {n : ℕ} (p : C(HigherHurewicz.CubeTriangulation.CubeN (n + 1), X))
+    (m : ℕ) (v : Fin (m + 1) → Fin 2 × Fin (n + 1)) :
+    orientedPrismRealization p m (SingularMayerVietoris.formalSimplex v) =
+      ∑ e : Equiv.Perm (Fin n),
+        HigherHurewicz.CubeTriangulation.cubeOrientation e •
+          FirstHurewicz.simplexChain X m (p.comp (prismCubeSimplex e v)) :=
+  SingularMayerVietoris.formalLift_simplex _ _
+
+private abbrev FourthHurewicz.Remaining :=
+  { j : Fin 4 // j ≠ 0 }
+
+private def
+    FourthHurewicz.remainingCoordinates : C(Fin 3 → (unitInterval), Remaining → (unitInterval))
+    where
+  toFun u j := u (j.val.pred j.property)
+  continuous_toFun := by fun_prop
+
+@[simp]
+private theorem FourthHurewicz.remainingCoordinates_succ (u : Fin 3 → (unitInterval)) (i : Fin 3) :
+    remainingCoordinates u ⟨i.succ, Fin.succ_ne_zero i⟩ = u i := by simp [remainingCoordinates]
+
+private theorem FourthHurewicz.remainingCoordinates_boundary {u : Fin 3 → (unitInterval)}
+    (h : u ∈ Cube.boundary (Fin 3)) : remainingCoordinates u ∈ Cube.boundary Remaining := by
+  obtain ⟨i, hi⟩ := h
+  exact ⟨⟨i.succ, Fin.succ_ne_zero i⟩, by simpa using hi⟩
+
+private abbrev FourthHurewicz.BasedLoopSpace {X : Type} [TopologicalSpace X] (x : X) :=
+  GenLoop Remaining X x
+
+private def FourthHurewicz.evaluation {X : Type} [TopologicalSpace X] (x : X) :
+    C(BasedLoopSpace x × (Fin 3 → (unitInterval)), X)
+    where
+  toFun z := z.1 (remainingCoordinates z.2)
+  continuous_toFun := by fun_prop
+
+private theorem FourthHurewicz.evaluation_boundary {X : Type} [TopologicalSpace X] (x : X)
+    (p : BasedLoopSpace x) (u : Fin 3 → (unitInterval)) (hu : u ∈ Cube.boundary (Fin 3)) :
+    evaluation x (p, u) = x :=
+  GenLoop.boundary p _ (remainingCoordinates_boundary hu)
+
+private theorem FourthHurewicz.evaluation_comp_boundary {X : Type} [TopologicalSpace X] {A : Type}
+    [TopologicalSpace A] (x : X) (f : C(A, Fin 3 → (unitInterval)))
+    (hf : ∀ a, f a ∈ Cube.boundary (Fin 3)) :
+    (evaluation x).comp ((ContinuousMap.id (BasedLoopSpace x)).prodMap f) =
+      ContinuousMap.const (BasedLoopSpace x × A) x := by
+  ext z
+  exact evaluation_boundary x z.1 (f z.2) (hf z.2)
+
+private def FourthHurewicz.cubeCoordinates :
+    C((unitInterval) × (Fin 3 → (unitInterval)), Fin 4 → (unitInterval))
+    where
+  toFun z := Cube.insertAt (0 : Fin 4) (z.1, remainingCoordinates z.2)
+  continuous_toFun := by fun_prop
+
+@[simp]
+private theorem
+    FourthHurewicz.cubeCoordinates_zero (z : (unitInterval) × (Fin 3 → (unitInterval))) :
+    cubeCoordinates z 0 = z.1 := by
+  simp [cubeCoordinates, Cube.insertAt, Homeomorph.funSplitAt_symm_apply]
+
+@[simp]
+private theorem FourthHurewicz.cubeCoordinates_succ (z : (unitInterval) × (Fin 3 → (unitInterval)))
+    (i : Fin 3) : cubeCoordinates z i.succ = z.2 i := by
+  simp [cubeCoordinates, Cube.insertAt, Homeomorph.funSplitAt_symm_apply, remainingCoordinates]
+
+private def
+    FourthHurewicz.cubeMap {X : Type} [TopologicalSpace X] {x : X} (p : GenLoop (Fin 4) X x) :
+    C((unitInterval) × (Fin 3 → (unitInterval)), X) :=
+  p.val.comp cubeCoordinates
+
+private theorem FourthHurewicz.evaluation_comp_toLoop {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 4) X x) :
+    (evaluation x).comp
+        ((GenLoop.toLoop (0 : Fin 4) p).toContinuousMap.prodMap
+          (ContinuousMap.id (Fin 3 → (unitInterval)))) =
+      cubeMap p := by
+  ext z
+  rfl
+
+private theorem FourthHurewicz.CubeSubdivision.cubeCoordinates_boundary_right (s : (unitInterval))
+    {u : Fin 3 → (unitInterval)} (hu : u ∈ Cube.boundary (Fin 3)) :
+    FourthHurewicz.cubeCoordinates (s, u) ∈ Cube.boundary (Fin 4) := by
+  obtain ⟨i, hi⟩ := hu
+  exact ⟨i.succ, by simpa only [FourthHurewicz.cubeCoordinates_succ] using hi⟩
+
+private def FourthHurewicz.CubeSubdivision.curryLoop {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 4) X x) :
+    GenLoop (Fin 3) C((unitInterval), X) (ContinuousMap.const (unitInterval) x) :=
+  ⟨((FourthHurewicz.cubeMap p).comp ContinuousMap.prodSwap).curry,
+    by
+    intro u hu
+    apply ContinuousMap.ext
+    intro s
+    exact GenLoop.boundary p _ (cubeCoordinates_boundary_right s hu)⟩
+
+private def FourthHurewicz.CubeSubdivision.evalLeft (X : Type) [TopologicalSpace X] :
+    C((unitInterval) × C((unitInterval), X), X)
+    where
+  toFun z := z.2 z.1
+  continuous_toFun := by fun_prop
+
+private theorem
+    FourthHurewicz.CubeSubdivision.evalLeft_comp_curryLoop {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 4) X x) :
+    (evalLeft X).comp ((ContinuousMap.id (unitInterval)).prodMap (curryLoop p).val) =
+      FourthHurewicz.cubeMap p := by
+  ext z
+  rfl
+
+private theorem FourthHurewicz.CubeSubdivision.cubeAffineSimplex_comp {k m n : ℕ}
+    (v : Fin (n + 1) → HigherHurewicz.CubeTriangulation.CubeN k)
+    (w : Fin (m + 1) → FirstHurewicz.Simplex n) :
+    (HigherHurewicz.CubeTriangulation.cubeAffineSimplex v).comp
+        (SingularMayerVietoris.affineSimplex w) =
+      HigherHurewicz.CubeTriangulation.cubeAffineSimplex
+        (fun j => HigherHurewicz.CubeTriangulation.cubeAffineSimplex v (w j)) := by
+  ext t i
+  change
+    (HigherHurewicz.CubeTriangulation.cubeAffineSimplex v
+          (SingularMayerVietoris.affineSimplex w t) i :
+        ℝ) =
+      (HigherHurewicz.CubeTriangulation.cubeAffineSimplex
+          (fun j => HigherHurewicz.CubeTriangulation.cubeAffineSimplex v (w j)) t i :
+        ℝ)
+  simp only [HigherHurewicz.CubeTriangulation.cubeAffineSimplex_coordinate,
+    SingularMayerVietoris.affineSimplex_coordinate, Finset.sum_mul, Finset.mul_sum, mul_assoc]
+  exact Finset.sum_comm
+
+private theorem FourthHurewicz.CubeSubdivision.cubeAffineSimplex_comp_selectedVertices {k m n : ℕ}
+    (v : Fin (n + 1) → HigherHurewicz.CubeTriangulation.CubeN k) (a : Fin (m + 1) → Fin (n + 1)) :
+    (HigherHurewicz.CubeTriangulation.cubeAffineSimplex v).comp
+        (SingularMayerVietoris.affineSimplex
+          (fun j => SingularMayerVietoris.stdVertices n (a j))) =
+      HigherHurewicz.CubeTriangulation.cubeAffineSimplex (fun j => v (a j)) := by
+  rw [cubeAffineSimplex_comp]
+  simp only [HigherHurewicz.CubeTriangulation.cubeAffineSimplex_vertex]
+
+private def FourthHurewicz.CubeSubdivision.prismCubeMap {n : ℕ} (e : Equiv.Perm (Fin n)) :
+    C(FirstHurewicz.Simplex 1 × FirstHurewicz.Simplex n,
+      HigherHurewicz.CubeTriangulation.CubeN (n + 1))
+    where
+  toFun
+    z :=
+    Fin.cases (FirstHurewicz.pathSimplex Path.id z.1)
+      (HigherHurewicz.CubeTriangulation.cubeSimplex e z.2)
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    refine Fin.cases ?_ (fun j => ?_) i
+    · exact (FirstHurewicz.pathSimplex Path.id).continuous.comp continuous_fst
+    · exact
+        (continuous_apply j).comp
+          ((HigherHurewicz.CubeTriangulation.cubeSimplex e).continuous.comp continuous_snd)
+
+private theorem
+    FourthHurewicz.CubeSubdivision.prismCubeMap_affine {m n : ℕ} (e : Equiv.Perm (Fin n))
+    (v : Fin (m + 1) → Fin 2 × Fin (n + 1)) :
+    (prismCubeMap e).comp
+        (PeriodTorusHigherHomology.productAffineSimplex
+          (fun j =>
+            (SingularMayerVietoris.stdVertices 1 (v j).1,
+              SingularMayerVietoris.stdVertices n (v j).2))) =
+      prismCubeSimplex e v := by
+  apply ContinuousMap.ext
+  intro t
+  funext i
+  refine Fin.cases ?_ (fun k => ?_) i
+  · apply Subtype.ext
+    change
+      SingularMayerVietoris.affineSimplex (fun j => SingularMayerVietoris.stdVertices 1 (v j).1) t
+          1 =
+        ∑ j, t j * SingularMayerVietoris.stdVertices 1 (v j).1 1
+    exact SingularMayerVietoris.affineSimplex_coordinate _ _ _
+  · change
+      ((HigherHurewicz.CubeTriangulation.cubeAffineSimplex
+                (HigherHurewicz.CubeTriangulation.cubeVertex e)).comp
+            (SingularMayerVietoris.affineSimplex
+              (fun j => SingularMayerVietoris.stdVertices n (v j).2)))
+          t k =
+        _
+    rw [cubeAffineSimplex_comp_selectedVertices]
+    rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def FourthHurewicz.remainingCubeSideFirst (t : (unitInterval)) :
+    C(Fin 2 → (unitInterval), Fin 3 → (unitInterval)) :=
+  ThirdHurewicz.cubeCoordinates.comp (PeriodTorusHigherHomology.crossInsertLeft t)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def FourthHurewicz.remainingCubeSide (f : C((unitInterval), Fin 2 → (unitInterval))) :
+    C((unitInterval) × (unitInterval), Fin 3 → (unitInterval)) :=
+  ThirdHurewicz.cubeCoordinates.comp ((ContinuousMap.id (unitInterval)).prodMap f)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    FourthHurewicz.remainingCubeSideFirst_boundary (t : (unitInterval)) (ht : t = 0 ∨ t = 1)
+    (u : Fin 2 → (unitInterval)) : remainingCubeSideFirst t u ∈ Cube.boundary (Fin 3) := by
+  refine ⟨0, ?_⟩
+  change ThirdHurewicz.cubeCoordinates (t, u) 0 = 0 ∨ ThirdHurewicz.cubeCoordinates (t, u) 0 = 1
+  simpa only [ThirdHurewicz.cubeCoordinates_zero] using ht
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    FourthHurewicz.remainingCubeSide_boundary (f : C((unitInterval), Fin 2 → (unitInterval)))
+    (hf : ∀ t, f t ∈ Cube.boundary (Fin 2)) (z : (unitInterval) × (unitInterval)) :
+    remainingCubeSide f z ∈ Cube.boundary (Fin 3) := by
+  obtain ⟨i, hi⟩ := hf z.2
+  refine ⟨i.succ, ?_⟩
+  change
+    ThirdHurewicz.cubeCoordinates (z.1, f z.2) i.succ = 0 ∨
+      ThirdHurewicz.cubeCoordinates (z.1, f z.2) i.succ = 1
+  simpa only [ThirdHurewicz.cubeCoordinates_succ] using hi
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    FourthHurewicz.remainingCubeSide_chain (f : C((unitInterval), Fin 2 → (unitInterval))) :
+    FirstHurewicz.inducedChain ThirdHurewicz.cubeCoordinates 2
+        (PeriodTorusHigherHomology.crossProductEdge (unitInterval) (Fin 2 → (unitInterval)) 1
+          SecondHurewicz.intervalChain
+          (FirstHurewicz.inducedChain f 1 SecondHurewicz.intervalChain)) =
+      FirstHurewicz.inducedChain (remainingCubeSide f) 2 SecondHurewicz.productSquareChain := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductEdge_natural (ContinuousMap.id (unitInterval)) f 1
+      SecondHurewicz.intervalChain SecondHurewicz.intervalChain
+  rw [FirstHurewicz.inducedChain_id, LinearMap.id_apply] at h
+  rw [← h]
+  change
+    ((FirstHurewicz.inducedChain ThirdHurewicz.cubeCoordinates 2).comp
+          (FirstHurewicz.inducedChain ((ContinuousMap.id (unitInterval)).prodMap f) 2))
+        SecondHurewicz.productSquareChain =
+      _
+  rw [← FirstHurewicz.inducedChain_comp]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FourthHurewicz.remainingCubeChain_boundary :
+    ((FirstHurewicz.singularComplex (Fin 3 → (unitInterval))).d 3 2).hom
+        ThirdHurewicz.fundamentalCubeChain =
+      FirstHurewicz.inducedChain (remainingCubeSideFirst 1) 2
+            SecondHurewicz.fundamentalSquareChain -
+          FirstHurewicz.inducedChain (remainingCubeSideFirst 0) 2
+            SecondHurewicz.fundamentalSquareChain -
+        (FirstHurewicz.inducedChain (remainingCubeSide (ThirdHurewicz.squareSideLeft 1)) 2
+              SecondHurewicz.productSquareChain -
+            FirstHurewicz.inducedChain (remainingCubeSide (ThirdHurewicz.squareSideLeft 0)) 2
+              SecondHurewicz.productSquareChain -
+          (FirstHurewicz.inducedChain (remainingCubeSide (ThirdHurewicz.squareSideRight 1)) 2
+              SecondHurewicz.productSquareChain -
+            FirstHurewicz.inducedChain (remainingCubeSide (ThirdHurewicz.squareSideRight 0)) 2
+              SecondHurewicz.productSquareChain)) := by
+  have hpoint (t : (unitInterval)) :
+    PeriodTorusHigherHomology.crossProductZeroLeft (unitInterval) (Fin 2 → (unitInterval)) 2
+        (FirstHurewicz.pointChain t) SecondHurewicz.fundamentalSquareChain =
+      FirstHurewicz.inducedChain (PeriodTorusHigherHomology.crossInsertLeft t) 2
+        SecondHurewicz.fundamentalSquareChain := by
+    rw [FirstHurewicz.pointChain, PeriodTorusHigherHomology.crossProductZeroLeft_simplex_left]
+    rfl
+  have hfirst (t : (unitInterval)) :
+    FirstHurewicz.inducedChain ThirdHurewicz.cubeCoordinates 2
+        (FirstHurewicz.inducedChain (PeriodTorusHigherHomology.crossInsertLeft t) 2
+          SecondHurewicz.fundamentalSquareChain) =
+      FirstHurewicz.inducedChain (remainingCubeSideFirst t) 2
+        SecondHurewicz.fundamentalSquareChain := by
+    rw [remainingCubeSideFirst, FirstHurewicz.inducedChain_comp]
+    rfl
+  rw [ThirdHurewicz.fundamentalCubeChain, ← FirstHurewicz.inducedChain_boundary]
+  change
+    FirstHurewicz.inducedChain ThirdHurewicz.cubeCoordinates 2
+        (((FirstHurewicz.singularComplex ((unitInterval) × (Fin 2 → (unitInterval)))).d 3 2).hom
+          (PeriodTorusHigherHomology.crossProductEdge (unitInterval) (Fin 2 → (unitInterval)) 2
+            SecondHurewicz.intervalChain SecondHurewicz.fundamentalSquareChain)) =
+      _
+  rw [PeriodTorusHigherHomology.crossProductEdge_boundary 1]
+  change
+    FirstHurewicz.inducedChain ThirdHurewicz.cubeCoordinates 2
+        (PeriodTorusHigherHomology.crossProductZeroLeft (unitInterval) (Fin 2 → (unitInterval)) 2
+            (FirstHurewicz.boundaryOne (unitInterval) SecondHurewicz.intervalChain)
+            SecondHurewicz.fundamentalSquareChain -
+          PeriodTorusHigherHomology.crossProductEdge (unitInterval) (Fin 2 → (unitInterval)) 1
+            SecondHurewicz.intervalChain
+            (FirstHurewicz.boundaryTwo (Fin 2 → (unitInterval))
+              SecondHurewicz.fundamentalSquareChain)) =
+      _
+  rw [SecondHurewicz.intervalChain_boundary, ThirdHurewicz.fundamentalSquareChain_boundary]
+  simp only [map_sub, LinearMap.sub_apply, hpoint, hfirst, remainingCubeSide_chain]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FourthHurewicz.evaluated_edge_boundaryMap {X A : Type} [TopologicalSpace X]
+    [TopologicalSpace A] (x : X) (a : FirstHurewicz.Chains (BasedLoopSpace x) 1)
+    (b : FirstHurewicz.Chains A 2) (f : C(A, Fin 3 → (unitInterval)))
+    (hf : ∀ t, f t ∈ Cube.boundary (Fin 3)) :
+    FirstHurewicz.inducedChain (evaluation x) 3
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 3 → (unitInterval)) 2
+          a (FirstHurewicz.inducedChain f 2 b)) =
+      FirstHurewicz.inducedChain (ContinuousMap.const (BasedLoopSpace x × A) x) 3
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) A 2 a b) := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductEdge_natural (ContinuousMap.id (BasedLoopSpace x)) f 2 a
+      b
+  rw [FirstHurewicz.inducedChain_id, LinearMap.id_apply] at h
+  rw [← h]
+  change
+    ((FirstHurewicz.inducedChain (evaluation x) 3).comp
+          (FirstHurewicz.inducedChain ((ContinuousMap.id (BasedLoopSpace x)).prodMap f) 3))
+        _ =
+      _
+  rw [← FirstHurewicz.inducedChain_comp, evaluation_comp_boundary x f hf]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FourthHurewicz.evaluated_triangle_boundaryMap {X A : Type} [TopologicalSpace X]
+    [TopologicalSpace A] (x : X) (a : FirstHurewicz.Chains (BasedLoopSpace x) 2)
+    (b : FirstHurewicz.Chains A 2) (f : C(A, Fin 3 → (unitInterval)))
+    (hf : ∀ t, f t ∈ Cube.boundary (Fin 3)) :
+    FirstHurewicz.inducedChain (evaluation x) 4
+        (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x)
+          (Fin 3 → (unitInterval)) 2 a (FirstHurewicz.inducedChain f 2 b)) =
+      FirstHurewicz.inducedChain (ContinuousMap.const (BasedLoopSpace x × A) x) 4
+        (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x) A 2 a b) := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductTriangle_natural (ContinuousMap.id (BasedLoopSpace x)) f
+      2 a b
+  rw [FirstHurewicz.inducedChain_id, LinearMap.id_apply] at h
+  rw [← h]
+  change
+    ((FirstHurewicz.inducedChain (evaluation x) 4).comp
+          (FirstHurewicz.inducedChain ((ContinuousMap.id (BasedLoopSpace x)).prodMap f) 4))
+        _ =
+      _
+  rw [← FirstHurewicz.inducedChain_comp, evaluation_comp_boundary x f hf]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    FourthHurewicz.evaluated_edge_cubeBoundary_cancel {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 1) :
+    FirstHurewicz.inducedChain (evaluation x) 3
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 3 → (unitInterval)) 2
+          a
+          (((FirstHurewicz.singularComplex (Fin 3 → (unitInterval))).d 3 2).hom
+            ThirdHurewicz.fundamentalCubeChain)) =
+      0 := by
+  have hF (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_edge_boundaryMap x a SecondHurewicz.fundamentalSquareChain
+      (remainingCubeSideFirst t) (remainingCubeSideFirst_boundary t ht)
+  have hL (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_edge_boundaryMap x a SecondHurewicz.productSquareChain
+      (remainingCubeSide (ThirdHurewicz.squareSideLeft t))
+      (remainingCubeSide_boundary _ (ThirdHurewicz.squareSideLeft_boundary t ht))
+  have hR (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_edge_boundaryMap x a SecondHurewicz.productSquareChain
+      (remainingCubeSide (ThirdHurewicz.squareSideRight t))
+      (remainingCubeSide_boundary _ (ThirdHurewicz.squareSideRight_boundary t ht))
+  simp only [remainingCubeChain_boundary, map_sub, hF 1 (Or.inr rfl), hF 0 (Or.inl rfl),
+    hL 1 (Or.inr rfl), hL 0 (Or.inl rfl), hR 1 (Or.inr rfl), hR 0 (Or.inl rfl), sub_self]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    FourthHurewicz.evaluated_triangle_cubeBoundary_cancel {X : Type} [TopologicalSpace X]
+    (x : X) (a : FirstHurewicz.Chains (BasedLoopSpace x) 2) :
+    FirstHurewicz.inducedChain (evaluation x) 4
+        (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x)
+          (Fin 3 → (unitInterval)) 2 a
+          (((FirstHurewicz.singularComplex (Fin 3 → (unitInterval))).d 3 2).hom
+            ThirdHurewicz.fundamentalCubeChain)) =
+      0 := by
+  have hF (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_triangle_boundaryMap x a SecondHurewicz.fundamentalSquareChain
+      (remainingCubeSideFirst t) (remainingCubeSideFirst_boundary t ht)
+  have hL (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_triangle_boundaryMap x a SecondHurewicz.productSquareChain
+      (remainingCubeSide (ThirdHurewicz.squareSideLeft t))
+      (remainingCubeSide_boundary _ (ThirdHurewicz.squareSideLeft_boundary t ht))
+  have hR (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_triangle_boundaryMap x a SecondHurewicz.productSquareChain
+      (remainingCubeSide (ThirdHurewicz.squareSideRight t))
+      (remainingCubeSide_boundary _ (ThirdHurewicz.squareSideRight_boundary t ht))
+  simp only [remainingCubeChain_boundary, map_sub, hF 1 (Or.inr rfl), hF 0 (Or.inl rfl),
+    hL 1 (Or.inr rfl), hL 0 (Or.inl rfl), hR 1 (Or.inr rfl), hR 0 (Or.inl rfl), sub_self]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def FourthHurewicz.suspensionOne {X : Type} [TopologicalSpace X] (x : X) :
+    FirstHurewicz.Chains (BasedLoopSpace x) 1 →ₗ[ℤ] FirstHurewicz.Chains X 4 :=
+  (FirstHurewicz.inducedChain (evaluation x) 4).comp
+    (PeriodTorusHigherHomology.integerBilinearRightApply
+      (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 3 → (unitInterval)) 3)
+      ThirdHurewicz.fundamentalCubeChain)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem FourthHurewicz.suspensionOne_apply {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 1) :
+    suspensionOne x a =
+      FirstHurewicz.inducedChain (evaluation x) 4
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 3 → (unitInterval)) 3
+          a ThirdHurewicz.fundamentalCubeChain) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def FourthHurewicz.suspensionTwo {X : Type} [TopologicalSpace X] (x : X) :
+    FirstHurewicz.Chains (BasedLoopSpace x) 2 →ₗ[ℤ] FirstHurewicz.Chains X 5 :=
+  (FirstHurewicz.inducedChain (evaluation x) 5).comp
+    (PeriodTorusHigherHomology.integerBilinearRightApply
+      (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x) (Fin 3 → (unitInterval))
+        3)
+      ThirdHurewicz.fundamentalCubeChain)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem FourthHurewicz.suspensionTwo_apply {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 2) :
+    suspensionTwo x a =
+      FirstHurewicz.inducedChain (evaluation x) 5
+        (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x)
+          (Fin 3 → (unitInterval)) 3 a ThirdHurewicz.fundamentalCubeChain) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    FourthHurewicz.boundaryFour_suspensionOne_of_cycle {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 1)
+    (ha : FirstHurewicz.boundaryOne (BasedLoopSpace x) a = 0) :
+    ((FirstHurewicz.singularComplex X).d 4 3).hom (suspensionOne x a) = 0 := by
+  rw [suspensionOne_apply, ← FirstHurewicz.inducedChain_boundary,
+    PeriodTorusHigherHomology.crossProductEdge_boundary 2]
+  change
+    FirstHurewicz.inducedChain (evaluation x) 3
+        (PeriodTorusHigherHomology.crossProductZeroLeft (BasedLoopSpace x)
+            (Fin 3 → (unitInterval)) 3 (FirstHurewicz.boundaryOne (BasedLoopSpace x) a)
+            ThirdHurewicz.fundamentalCubeChain -
+          PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 3 → (unitInterval)) 2
+            a
+            (((FirstHurewicz.singularComplex (Fin 3 → (unitInterval))).d 3 2).hom
+              ThirdHurewicz.fundamentalCubeChain)) =
+      0
+  rw [ha, map_zero, LinearMap.zero_apply, zero_sub, map_neg, evaluated_edge_cubeBoundary_cancel,
+    neg_zero]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FourthHurewicz.boundaryFive_suspensionTwo {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 2) :
+    ((FirstHurewicz.singularComplex X).d 5 4).hom (suspensionTwo x a) =
+      suspensionOne x (FirstHurewicz.boundaryTwo (BasedLoopSpace x) a) := by
+  rw [suspensionTwo_apply, ← FirstHurewicz.inducedChain_boundary,
+    PeriodTorusHigherHomology.crossProductTriangle_boundary 2]
+  change
+    FirstHurewicz.inducedChain (evaluation x) 4
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 3 → (unitInterval)) 3
+            (FirstHurewicz.boundaryTwo (BasedLoopSpace x) a) ThirdHurewicz.fundamentalCubeChain +
+          PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x)
+            (Fin 3 → (unitInterval)) 2 a
+            (((FirstHurewicz.singularComplex (Fin 3 → (unitInterval))).d 3 2).hom
+              ThirdHurewicz.fundamentalCubeChain)) =
+      _
+  rw [map_add, evaluated_triangle_cubeBoundary_cancel, add_zero]
+  rfl
+
+private def FourthHurewicz.pathCubeCycle {X : Type} [TopologicalSpace X] (x : X)
+    (p : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 4 :=
+  SingularMayerVietoris.ModuleHomology.mkCycle (FirstHurewicz.singularComplex X) 4
+    (suspensionOne x (FirstHurewicz.pathChain p))
+    (boundaryFour_suspensionOne_of_cycle x (FirstHurewicz.pathChain p)
+      (FirstHurewicz.boundaryOne_loop p))
+
+@[simp]
+private theorem FourthHurewicz.pathCubeCycle_val {X : Type} [TopologicalSpace X] (x : X)
+    (p : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    (pathCubeCycle x p).1 = suspensionOne x (FirstHurewicz.pathChain p) :=
+  rfl
+
+private def FourthHurewicz.pathCubeClass {X : Type} [TopologicalSpace X] (x : X)
+    (p : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    SingularMayerVietoris.SingularHomology X 4 :=
+  SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 4
+    (pathCubeCycle x p)
+
+private theorem FourthHurewicz.pathCube_homotopy_boundary {X : Type} [TopologicalSpace X] (x : X)
+    {p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const} (H : p.Homotopy q) :
+    ((FirstHurewicz.singularComplex X).d 5 4).hom
+        (suspensionTwo x (FirstHurewicz.homotopyChain H)) =
+      (pathCubeCycle x p).1 - (pathCubeCycle x q).1 := by
+  rw [boundaryFive_suspensionTwo, FirstHurewicz.boundaryTwo_loopHomotopy, map_sub]
+  rfl
+
+private theorem FourthHurewicz.pathCubeClass_homotopy {X : Type} [TopologicalSpace X] (x : X)
+    {p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const} (H : p.Homotopy q) :
+    pathCubeClass x p = pathCubeClass x q :=
+  (SingularMayerVietoris.ModuleHomology.cycleClass_eq_iff (FirstHurewicz.singularComplex X) 4 _
+        _).mpr
+    ⟨suspensionTwo x (FirstHurewicz.homotopyChain H), pathCube_homotopy_boundary x H⟩
+
+private theorem FourthHurewicz.pathCubeClass_homotopic {X : Type} [TopologicalSpace X] (x : X)
+    {p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const} (h : p.Homotopic q) :
+    pathCubeClass x p = pathCubeClass x q := by
+  obtain ⟨H⟩ := h
+  exact pathCubeClass_homotopy x H
+
+@[simp]
+private theorem FourthHurewicz.pathCubeClass_refl {X : Type} [TopologicalSpace X] (x : X) :
+    pathCubeClass x (Path.refl (GenLoop.const : BasedLoopSpace x)) = 0 := by
+  apply
+    (SingularMayerVietoris.ModuleHomology.cycleClass_eq_zero_iff (FirstHurewicz.singularComplex X)
+        4 _).mpr
+  refine
+    ⟨suspensionTwo x (FirstHurewicz.constantTriangleChain (GenLoop.const : BasedLoopSpace x)), ?_⟩
+  rw [boundaryFive_suspensionTwo, FirstHurewicz.boundaryTwo_constantTriangleChain]
+  rfl
+
+private theorem FourthHurewicz.pathCube_concat_boundary {X : Type} [TopologicalSpace X] (x : X)
+    (p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    ((FirstHurewicz.singularComplex X).d 5 4).hom
+        (-suspensionTwo x (FirstHurewicz.concatChain p q)) =
+      (pathCubeCycle x (p.trans q)).1 - ((pathCubeCycle x p).1 + (pathCubeCycle x q).1) := by
+  rw [map_neg, boundaryFive_suspensionTwo, FirstHurewicz.boundaryTwo_concatChain, map_add,
+    map_sub]
+  simp only [pathCubeCycle_val]
+  abel
+
+private theorem FourthHurewicz.pathCubeClass_trans {X : Type} [TopologicalSpace X] (x : X)
+    (p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    pathCubeClass x (p.trans q) = pathCubeClass x p + pathCubeClass x q := by
+  unfold pathCubeClass
+  rw [← map_add]
+  apply
+    (SingularMayerVietoris.ModuleHomology.cycleClass_eq_iff (FirstHurewicz.singularComplex X) 4 _
+        _).mpr
+  exact ⟨-suspensionTwo x (FirstHurewicz.concatChain p q), pathCube_concat_boundary x p q⟩
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def FourthHurewicz.productCubeChain :
+    FirstHurewicz.Chains ((unitInterval) × (Fin 3 → (unitInterval))) 4 :=
+  PeriodTorusHigherHomology.crossProductEdge (unitInterval) (Fin 3 → (unitInterval)) 3
+    SecondHurewicz.intervalChain ThirdHurewicz.fundamentalCubeChain
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def FourthHurewicz.fundamentalCubeChain : FirstHurewicz.Chains (Fin 4 → (unitInterval)) 4 :=
+  FirstHurewicz.inducedChain cubeCoordinates 4 productCubeChain
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FourthHurewicz.suspensionOne_toLoop {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 4) X x) :
+    suspensionOne x (FirstHurewicz.pathChain (GenLoop.toLoop (0 : Fin 4) p)) =
+      FirstHurewicz.inducedChain (cubeMap p) 4 productCubeChain := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductEdge_natural
+      (GenLoop.toLoop (0 : Fin 4) p).toContinuousMap (ContinuousMap.id (Fin 3 → (unitInterval))) 3
+      SecondHurewicz.intervalChain ThirdHurewicz.fundamentalCubeChain
+  rw [SecondHurewicz.induced_intervalChain, FirstHurewicz.inducedChain_id,
+    LinearMap.id_apply] at h
+  rw [suspensionOne_apply, ← h]
+  change
+    ((FirstHurewicz.inducedChain (evaluation x) 4).comp
+          (FirstHurewicz.inducedChain
+            ((GenLoop.toLoop (0 : Fin 4) p).toContinuousMap.prodMap
+              (ContinuousMap.id (Fin 3 → (unitInterval))))
+            4))
+        productCubeChain =
+      _
+  rw [← FirstHurewicz.inducedChain_comp, evaluation_comp_toLoop]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    FourthHurewicz.cubeChain {X : Type} [TopologicalSpace X] {x : X} (p : GenLoop (Fin 4) X x) :
+    FirstHurewicz.Chains X 4 :=
+  suspensionOne x (FirstHurewicz.pathChain (GenLoop.toLoop (0 : Fin 4) p))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FourthHurewicz.cubeChain_eq_induced {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 4) X x) :
+    cubeChain p = FirstHurewicz.inducedChain p.val 4 fundamentalCubeChain := by
+  rw [cubeChain, suspensionOne_toLoop]
+  change
+    FirstHurewicz.inducedChain (p.val.comp cubeCoordinates) 4 productCubeChain =
+      ((FirstHurewicz.inducedChain p.val 4).comp (FirstHurewicz.inducedChain cubeCoordinates 4))
+        productCubeChain
+  rw [FirstHurewicz.inducedChain_comp]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    FourthHurewicz.cubeCycle {X : Type} [TopologicalSpace X] {x : X} (p : GenLoop (Fin 4) X x) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 4 :=
+  pathCubeCycle x (GenLoop.toLoop (0 : Fin 4) p)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def FourthHurewicz.cubeHomologyClass {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 4) X x) : SingularMayerVietoris.SingularHomology X 4 :=
+  SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 4
+    (cubeCycle p)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    FourthHurewicz.cubeHomologyClass_eq_pathCubeClass {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 4) X x) :
+    cubeHomologyClass p = pathCubeClass x (GenLoop.toLoop (0 : Fin 4) p) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FourthHurewicz.cubeHomologyClass_homotopic {X : Type} [TopologicalSpace X] {x : X}
+    {p q : GenLoop (Fin 4) X x} (h : GenLoop.Homotopic p q) :
+    cubeHomologyClass p = cubeHomologyClass q :=
+  pathCubeClass_homotopic x (GenLoop.homotopicTo (0 : Fin 4) h)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FourthHurewicz.toLoop_const {X : Type} [TopologicalSpace X] {x : X} :
+    GenLoop.toLoop (0 : Fin 4) (GenLoop.const : GenLoop (Fin 4) X x) =
+      Path.refl (GenLoop.const : BasedLoopSpace x) := by
+  apply Path.ext
+  funext t
+  apply GenLoop.ext
+  intro u
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem FourthHurewicz.cubeHomologyClass_const {X : Type} [TopologicalSpace X] {x : X} :
+    cubeHomologyClass (GenLoop.const : GenLoop (Fin 4) X x) = 0 := by
+  rw [cubeHomologyClass_eq_pathCubeClass, toLoop_const, pathCubeClass_refl]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FourthHurewicz.toLoop_transAt {X : Type} [TopologicalSpace X] {x : X}
+    (p q : GenLoop (Fin 4) X x) :
+    GenLoop.toLoop (0 : Fin 4) (GenLoop.transAt (0 : Fin 4) p q) =
+      (GenLoop.toLoop (0 : Fin 4) p).trans (GenLoop.toLoop (0 : Fin 4) q) := by
+  have h :=
+    congrArg (GenLoop.toLoop (0 : Fin 4))
+      (GenLoop.fromLoop_trans_toLoop (i := (0 : Fin 4)) (p := p) (q := q))
+  rw [GenLoop.to_from] at h
+  exact h.symm
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FourthHurewicz.cubeHomologyClass_transAt {X : Type} [TopologicalSpace X] {x : X}
+    (p q : GenLoop (Fin 4) X x) :
+    cubeHomologyClass (GenLoop.transAt (0 : Fin 4) p q) =
+      cubeHomologyClass p + cubeHomologyClass q := by
+  simp only [cubeHomologyClass_eq_pathCubeClass, toLoop_transAt, pathCubeClass_trans]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FourthHurewicz.CubeSubdivision.evalLeft_crossProductEdge_curryLoop {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 4) X x) (n : ℕ)
+    (b : FirstHurewicz.Chains (Fin 3 → (unitInterval)) n) :
+    FirstHurewicz.inducedChain (evalLeft X) (n + 1)
+        (PeriodTorusHigherHomology.crossProductEdge (unitInterval) C((unitInterval), X) n
+          SecondHurewicz.intervalChain (FirstHurewicz.inducedChain (curryLoop p).val n b)) =
+      FirstHurewicz.inducedChain (FourthHurewicz.cubeMap p) (n + 1)
+        (PeriodTorusHigherHomology.crossProductEdge (unitInterval) (Fin 3 → (unitInterval)) n
+          SecondHurewicz.intervalChain b) := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductEdge_natural (ContinuousMap.id (unitInterval))
+      (curryLoop p).val n SecondHurewicz.intervalChain b
+  rw [FirstHurewicz.inducedChain_id, LinearMap.id_apply] at h
+  rw [← h]
+  change
+    ((FirstHurewicz.inducedChain (evalLeft X) (n + 1)).comp
+          (FirstHurewicz.inducedChain
+            ((ContinuousMap.id (unitInterval)).prodMap (curryLoop p).val) (n + 1)))
+        _ =
+      _
+  rw [← FirstHurewicz.inducedChain_comp, evalLeft_comp_curryLoop]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FourthHurewicz.CubeSubdivision.cubeChain_eq_curriedCrossProduct {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 4) X x) :
+    FourthHurewicz.cubeChain p =
+      FirstHurewicz.inducedChain (evalLeft X) 4
+        (PeriodTorusHigherHomology.crossProductEdge (unitInterval) C((unitInterval), X) 3
+          SecondHurewicz.intervalChain (ThirdHurewicz.cubeChain (curryLoop p))) := by
+  rw [ThirdHurewicz.cubeChain_eq_induced, evalLeft_crossProductEdge_curryLoop,
+    FourthHurewicz.cubeChain_eq_induced, FourthHurewicz.fundamentalCubeChain]
+  change
+    (FirstHurewicz.inducedChain p.val 4)
+        ((FirstHurewicz.inducedChain FourthHurewicz.cubeCoordinates 4)
+          FourthHurewicz.productCubeChain) =
+      (FirstHurewicz.inducedChain (p.val.comp FourthHurewicz.cubeCoordinates) 4)
+        FourthHurewicz.productCubeChain
+  rw [FirstHurewicz.inducedChain_comp]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def FourthHurewicz.CubeSubdivision.intervalTetrahedronChain {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 4) X x) (e : Equiv.Perm (Fin 3)) : FirstHurewicz.Chains X 4 :=
+  FirstHurewicz.inducedChain (evalLeft X) 4
+    (PeriodTorusHigherHomology.crossProductEdge (unitInterval) C((unitInterval), X) 3
+      SecondHurewicz.intervalChain
+      (FirstHurewicz.simplexChain C((unitInterval), X) 3
+        ((curryLoop p).val.comp (ThirdHurewicz.Geometry.cubeTetrahedron e))))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FourthHurewicz.CubeSubdivision.intervalTetrahedronChain_eq_original {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 4) X x) (e : Equiv.Perm (Fin 3)) :
+    intervalTetrahedronChain p e =
+      FirstHurewicz.inducedChain (FourthHurewicz.cubeMap p) 4
+        (PeriodTorusHigherHomology.crossProductEdge (unitInterval) (Fin 3 → (unitInterval)) 3
+          SecondHurewicz.intervalChain
+          (FirstHurewicz.simplexChain (Fin 3 → (unitInterval)) 3
+            (ThirdHurewicz.Geometry.cubeTetrahedron e))) := by
+  rw [intervalTetrahedronChain, ← FirstHurewicz.inducedChain_simplex,
+    evalLeft_crossProductEdge_curryLoop]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    FourthHurewicz.CubeSubdivision.cubeChain_eq_sum_prisms {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 4) X x) :
+    FourthHurewicz.cubeChain p =
+      ∑ e : Equiv.Perm (Fin 3),
+        ThirdHurewicz.Geometry.cubeOrientation e • intervalTetrahedronChain p e := by
+  rw [cubeChain_eq_curriedCrossProduct, ThirdHurewicz.CubeSubdivision.cubeChain_eq_sum_tetrahedra]
+  simp only [map_sum, map_zsmul, intervalTetrahedronChain]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FourthHurewicz.CubeSubdivision.prismCubeRealization_eq_induced {X : Type}
+    [TopologicalSpace X] {n : ℕ} (p : C(HigherHurewicz.CubeTriangulation.CubeN (n + 1), X))
+    (e : Equiv.Perm (Fin n)) (m : ℕ) :
+    prismCubeRealization p e m =
+      (FirstHurewicz.inducedChain (p.comp (prismCubeMap e)) m).comp
+        ((PeriodTorusHigherHomology.productAffineChainMap 1 n m).comp
+          (SingularMayerVietoris.formalMap
+            (Prod.map (SingularMayerVietoris.stdVertices 1) (SingularMayerVietoris.stdVertices n))
+            (m + 1))) := by
+  apply SingularMayerVietoris.formalChains_ext
+  intro v
+  simp only [prismCubeRealization_simplex, LinearMap.comp_apply,
+    SingularMayerVietoris.formalMap_simplex,
+    PeriodTorusHigherHomology.productAffineChainMap_simplex, FirstHurewicz.inducedChain_simplex]
+  apply congrArg (FirstHurewicz.simplexChain X m)
+  change
+    p.comp (prismCubeSimplex e v) =
+      p.comp
+        ((prismCubeMap e).comp
+          (PeriodTorusHigherHomology.productAffineSimplex
+            (fun j =>
+              (SingularMayerVietoris.stdVertices 1 (v j).1,
+                SingularMayerVietoris.stdVertices n (v j).2))))
+  rw [prismCubeMap_affine]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FourthHurewicz.CubeSubdivision.prismCubeRealization_edgeCrossProduct {X : Type}
+    [TopologicalSpace X] {n : ℕ} (p : C(HigherHurewicz.CubeTriangulation.CubeN (n + 1), X))
+    (e : Equiv.Perm (Fin n)) :
+    prismCubeRealization p e (n + 1)
+        (PeriodTorusHigherHomology.formalEdgeCrossProduct n
+          (SingularMayerVietoris.formalSimplex (fun i : Fin 2 => i))
+          (SingularMayerVietoris.formalSimplex (fun j : Fin (n + 1) => j))) =
+      FirstHurewicz.inducedChain (p.comp (prismCubeMap e)) (n + 1)
+        (PeriodTorusHigherHomology.productAffineChainMap 1 n (n + 1)
+          (PeriodTorusHigherHomology.formalEdgeCrossProduct n
+            (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+            (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices n)))) := by
+  rw [prismCubeRealization_eq_induced]
+  simp only [LinearMap.comp_apply]
+  rw [PeriodTorusHigherHomology.formalMap_edgeCrossProduct]
+  simp only [SingularMayerVietoris.formalMap_simplex, Function.comp_def]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FourthHurewicz.CubeSubdivision.prismCubeMap_three (e : Equiv.Perm (Fin 3)) :
+    FourthHurewicz.cubeCoordinates.comp
+        ((FirstHurewicz.pathSimplex Path.id).prodMap (ThirdHurewicz.Geometry.cubeTetrahedron e)) =
+      prismCubeMap e := by
+  apply ContinuousMap.ext
+  intro z
+  funext i
+  refine Fin.cases ?_ (fun j => ?_) i
+  · exact FourthHurewicz.cubeCoordinates_zero _
+  · change
+      FourthHurewicz.cubeCoordinates
+          (FirstHurewicz.pathSimplex Path.id z.1, ThirdHurewicz.Geometry.cubeTetrahedron e z.2)
+          j.succ =
+        _
+    rw [FourthHurewicz.cubeCoordinates_succ]
+    rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    FourthHurewicz.CubeSubdivision.intervalTetrahedronChain_eq_prismCubeRealization {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 4) X x) (e : Equiv.Perm (Fin 3)) :
+    intervalTetrahedronChain p e =
+      prismCubeRealization p.val e 4
+        (PeriodTorusHigherHomology.formalEdgeCrossProduct 3
+          (SingularMayerVietoris.formalSimplex (fun i : Fin 2 => i))
+          (SingularMayerVietoris.formalSimplex (fun j : Fin 4 => j))) := by
+  rw [intervalTetrahedronChain_eq_original, SecondHurewicz.intervalChain, FirstHurewicz.pathChain,
+    PeriodTorusHigherHomology.crossProductEdge_simplex, prismCubeRealization_edgeCrossProduct]
+  change
+    ((FirstHurewicz.inducedChain (FourthHurewicz.cubeMap p) 4).comp
+          (FirstHurewicz.inducedChain
+            ((FirstHurewicz.pathSimplex Path.id).prodMap
+              (ThirdHurewicz.Geometry.cubeTetrahedron e))
+            4))
+        _ =
+      _
+  rw [← FirstHurewicz.inducedChain_comp]
+  change
+    FirstHurewicz.inducedChain
+        (p.val.comp
+          (FourthHurewicz.cubeCoordinates.comp
+            ((FirstHurewicz.pathSimplex Path.id).prodMap
+              (ThirdHurewicz.Geometry.cubeTetrahedron e))))
+        4 _ =
+      _
+  rw [prismCubeMap_three]
+
+private def FourthHurewicz.CubeSubdivision.badPrism (q m : ℕ) :
+    Submodule ℤ (SingularMayerVietoris.FormalChains (Fin 2 × Fin (q + 1)) m) :=
+  SingularMayerVietoris.formalChainsSupported {z | z.1 = 0} m ⊔
+    ⨆ i : { i : Fin (q + 1) // i ≠ 0 },
+      SingularMayerVietoris.formalChainsSupported {z | z.2 ≠ i.val} m
+
+private theorem FourthHurewicz.CubeSubdivision.mem_badPrism_of_left_zero {q m : ℕ}
+    {c : SingularMayerVietoris.FormalChains (Fin 2 × Fin (q + 1)) m}
+    (hc : c ∈ SingularMayerVietoris.formalChainsSupported {z | z.1 = 0} m) : c ∈ badPrism q m :=
+  Submodule.mem_sup_left hc
+
+private theorem FourthHurewicz.CubeSubdivision.mem_badPrism_of_omit {q m : ℕ} (i : Fin (q + 1))
+    (hi : i ≠ 0) {c : SingularMayerVietoris.FormalChains (Fin 2 × Fin (q + 1)) m}
+    (hc : c ∈ SingularMayerVietoris.formalChainsSupported {z | z.2 ≠ i} m) : c ∈ badPrism q m :=
+  Submodule.mem_sup_right (Submodule.mem_iSup_of_mem ⟨i, hi⟩ hc)
+
+private theorem FourthHurewicz.CubeSubdivision.badPrism_le {q m : ℕ}
+    {P : Submodule ℤ (SingularMayerVietoris.FormalChains (Fin 2 × Fin (q + 1)) m)}
+    (hzero : SingularMayerVietoris.formalChainsSupported {z | z.1 = 0} m ≤ P)
+    (homit :
+      ∀ i : Fin (q + 1),
+        i ≠ 0 → SingularMayerVietoris.formalChainsSupported {z | z.2 ≠ i} m ≤ P) :
+    badPrism q m ≤ P :=
+  sup_le hzero (iSup_le fun i => homit i.val i.property)
+
+private theorem
+    FourthHurewicz.CubeSubdivision.badPrism_le_ker {q m : ℕ} {M : Type*} [AddCommGroup M]
+    [Module ℤ M] (f : SingularMayerVietoris.FormalChains (Fin 2 × Fin (q + 1)) m →ₗ[ℤ] M)
+    (hzero : ∀ v, (∀ j, (v j).1 = 0) → f (SingularMayerVietoris.formalSimplex v) = 0)
+    (homit :
+      ∀ i : Fin (q + 1),
+        i ≠ 0 → ∀ v, (∀ j, (v j).2 ≠ i) → f (SingularMayerVietoris.formalSimplex v) = 0) :
+    badPrism q m ≤ LinearMap.ker f := by
+  apply badPrism_le
+  · exact SingularMayerVietoris.formalChainsSupported_le hzero
+  · intro i hi
+    exact SingularMayerVietoris.formalChainsSupported_le (homit i hi)
+
+private theorem FourthHurewicz.CubeSubdivision.formalCone_mem_badPrism {q m : ℕ}
+    {c : SingularMayerVietoris.FormalChains (Fin 2 × Fin (q + 1)) m} (hc : c ∈ badPrism q m) :
+    SingularMayerVietoris.formalCone (0, 0) m c ∈ badPrism q (m + 1) := by
+  have hle :
+    badPrism q m ≤ (badPrism q (m + 1)).comap (SingularMayerVietoris.formalCone (0, 0) m) := by
+    apply badPrism_le
+    · intro d hd
+      exact
+        mem_badPrism_of_left_zero
+          (SingularMayerVietoris.formalCone_mem_supported (S :=
+            {z : Fin 2 × Fin (q + 1) | z.1 = 0}) (a := (0, 0)) rfl hd)
+    · intro i hi d hd
+      exact
+        mem_badPrism_of_omit i hi (SingularMayerVietoris.formalCone_mem_supported (Ne.symm hi) hd)
+  exact hle hc
+
+private theorem FourthHurewicz.CubeSubdivision.formalMap_succ_mem_badPrism {q m : ℕ}
+    {c : SingularMayerVietoris.FormalChains (Fin 2 × Fin (q + 1)) m} (hc : c ∈ badPrism q m) :
+    SingularMayerVietoris.formalMap (Prod.map id (Fin.succ : Fin (q + 1) → Fin (q + 2))) m c ∈
+      badPrism (q + 1) m := by
+  have hle :
+    badPrism q m ≤
+      (badPrism (q + 1) m).comap
+        (SingularMayerVietoris.formalMap (Prod.map id (Fin.succ : Fin (q + 1) → Fin (q + 2)))
+          m) := by
+    apply badPrism_le
+    · intro d hd
+      apply mem_badPrism_of_left_zero
+      exact
+        SingularMayerVietoris.formalMap_mem_supported (S := {z : Fin 2 × Fin (q + 1) | z.1 = 0})
+          (T := {z : Fin 2 × Fin (q + 2) | z.1 = 0}) (Prod.map id Fin.succ) (fun _ hz => hz) hd
+    · intro i hi d hd
+      apply mem_badPrism_of_omit i.succ (Fin.succ_ne_zero i)
+      exact
+        SingularMayerVietoris.formalMap_mem_supported (S := {z : Fin 2 × Fin (q + 1) | z.2 ≠ i})
+          (T := {z : Fin 2 × Fin (q + 2) | z.2 ≠ i.succ}) (Prod.map id Fin.succ)
+          (fun _ hz h => hz (Fin.succ_injective _ h)) hd
+  exact hle hc
+
+private theorem FourthHurewicz.CubeSubdivision.formalEdgeCrossProduct_mem_badPrism_of_omit {q r : ℕ}
+    (i : Fin (q + 1)) (hi : i ≠ 0) (c : SingularMayerVietoris.FormalChains (Fin 2) 2)
+    {d : SingularMayerVietoris.FormalChains (Fin (q + 1)) (r + 1)}
+    (hd : d ∈ SingularMayerVietoris.formalChainsSupported {j | j ≠ i} (r + 1)) :
+    PeriodTorusHigherHomology.formalEdgeCrossProduct r c d ∈ badPrism q (r + 2) := by
+  apply mem_badPrism_of_omit i hi
+  apply
+    SingularMayerVietoris.formalChainsSupported_mono (S :=
+      (Set.univ : Set (Fin 2)) ×ˢ {j : Fin (q + 1) | j ≠ i}) (fun _ hz => hz.2)
+  exact
+    PeriodTorusHigherHomology.formalEdgeCrossProduct_mem_supported r (S := Set.univ) (by simp) hd
+
+private def FourthHurewicz.CubeSubdivision.retainedFirstBoundary {W : Type*} (q : ℕ) :
+    SingularMayerVietoris.FormalChains W (q + 2) →ₗ[ℤ]
+      SingularMayerVietoris.FormalChains W (q + 1) :=
+  SingularMayerVietoris.formalLift fun w =>
+    ∑ i : Fin (q + 1),
+      (-1 : ℤ) ^ (i.val + 1) • SingularMayerVietoris.formalSimplex (w ∘ i.succ.succAbove)
+
+@[simp]
+private theorem FourthHurewicz.CubeSubdivision.retainedFirstBoundary_simplex {W : Type*} (q : ℕ)
+    (w : Fin (q + 2) → W) :
+    retainedFirstBoundary q (SingularMayerVietoris.formalSimplex w) =
+      ∑ i : Fin (q + 1),
+        (-1 : ℤ) ^ (i.val + 1) • SingularMayerVietoris.formalSimplex (w ∘ i.succ.succAbove) :=
+  SingularMayerVietoris.formalLift_simplex _ _
+
+private theorem
+    FourthHurewicz.CubeSubdivision.formalBoundary_firstFace_split_simplex {W : Type*} (q : ℕ)
+    (w : Fin (q + 2) → W) :
+    SingularMayerVietoris.formalBoundary (q + 1) (SingularMayerVietoris.formalSimplex w) =
+      SingularMayerVietoris.formalSimplex (Fin.tail w) +
+        retainedFirstBoundary q (SingularMayerVietoris.formalSimplex w) := by
+  rw [SingularMayerVietoris.formalBoundary_simplex, Fin.sum_univ_succ,
+    retainedFirstBoundary_simplex]
+  simp only [Fin.val_zero, pow_zero, one_smul, Fin.val_succ, Fin.succAbove_zero]
+  rfl
+
+private def
+    FourthHurewicz.CubeSubdivision.shufflePrismVertices {V W : Type*} {q : ℕ} (v : Fin 2 → V)
+    (w : Fin (q + 1) → W) (i : Fin (q + 1)) : Fin (q + 2) → V × W := fun k =>
+  (if k ≤ i.castSucc then v 0 else v 1, w (i.predAbove k))
+
+@[simp]
+private theorem FourthHurewicz.CubeSubdivision.shufflePrismVertices_first {V W : Type*} {q : ℕ}
+    (v : Fin 2 → V) (w : Fin (q + 1) → W) (i : Fin (q + 1)) :
+    shufflePrismVertices v w i 0 = (v 0, w 0) := by simp [shufflePrismVertices]
+
+private theorem FourthHurewicz.CubeSubdivision.shufflePrismVertices_zero_index {V W : Type*} {q : ℕ}
+    (v : Fin 2 → V) (w : Fin (q + 1) → W) :
+    shufflePrismVertices v w 0 = Fin.cons (v 0, w 0) (fun j => (v 1, w j)) := by
+  funext k
+  refine Fin.cases ?_ (fun j => ?_) k
+  · simp
+  · simp [shufflePrismVertices]
+
+private theorem FourthHurewicz.CubeSubdivision.shufflePrismVertices_succ_index {V W : Type*} {q : ℕ}
+    (v : Fin 2 → V) (w : Fin (q + 2) → W) (i : Fin (q + 1)) :
+    shufflePrismVertices v w i.succ =
+      Fin.cons (v 0, w 0) (shufflePrismVertices v (Fin.tail w) i) := by
+  funext k
+  refine Fin.cases ?_ (fun j => ?_) k
+  · simp
+  · simp [shufflePrismVertices, Fin.tail, Fin.le_castSucc_iff]
+
+private theorem FourthHurewicz.CubeSubdivision.shufflePrismVertices_map {V W V' W' : Type*} {q : ℕ}
+    (f : V → V') (g : W → W') (v : Fin 2 → V) (w : Fin (q + 1) → W) (i : Fin (q + 1)) :
+    Prod.map f g ∘ shufflePrismVertices v w i = shufflePrismVertices (f ∘ v) (g ∘ w) i := by
+  funext k
+  simp only [shufflePrismVertices, Function.comp_apply, Prod.map_apply]
+  split_ifs <;> rfl
+
+private def FourthHurewicz.CubeSubdivision.standardPrism {V W : Type*} (q : ℕ) (v : Fin 2 → V)
+    (w : Fin (q + 1) → W) : SingularMayerVietoris.FormalChains (V × W) (q + 2) :=
+  ∑ i : Fin (q + 1),
+    (-1 : ℤ) ^ i.val • SingularMayerVietoris.formalSimplex (shufflePrismVertices v w i)
+
+private theorem FourthHurewicz.CubeSubdivision.standardPrism_zero {V W : Type*} (v : Fin 2 → V)
+    (w : Fin 1 → W) :
+    standardPrism 0 v w = SingularMayerVietoris.formalSimplex (fun i => (v i, w 0)) := by
+  rw [standardPrism, Fin.sum_univ_one]
+  simp only [Fin.val_zero, pow_zero, one_smul, shufflePrismVertices_zero_index]
+  congr 1
+  funext i
+  refine Fin.cases ?_ (fun j => ?_) i
+  · rfl
+  · rw [Fin.eq_zero j]
+    rfl
+
+private theorem
+    FourthHurewicz.CubeSubdivision.standardPrism_succ {V W : Type*} (q : ℕ) (v : Fin 2 → V)
+    (w : Fin (q + 2) → W) :
+    standardPrism (q + 1) v w =
+      SingularMayerVietoris.formalCone (v 0, w 0) (q + 2)
+        (SingularMayerVietoris.formalMap (fun z => (v 1, z)) (q + 2)
+            (SingularMayerVietoris.formalSimplex w) -
+          standardPrism q v (Fin.tail w)) := by
+  rw [standardPrism, Fin.sum_univ_succ]
+  simp only [Fin.val_zero, pow_zero, one_smul, shufflePrismVertices_zero_index, map_sub,
+    SingularMayerVietoris.formalMap_simplex, SingularMayerVietoris.formalCone_simplex,
+    standardPrism, map_sum, map_smul, SingularMayerVietoris.formalCone_simplex]
+  rw [sub_eq_add_neg, ← Finset.sum_neg_distrib]
+  congr 1
+  apply Finset.sum_congr rfl
+  intro i hi
+  simp only [Fin.val_succ, pow_succ, mul_neg_one, neg_smul, shufflePrismVertices_succ_index]
+
+private theorem
+    FourthHurewicz.CubeSubdivision.formalMap_standardPrism {V W V' W' : Type*} (f : V → V')
+    (g : W → W') (q : ℕ) (v : Fin 2 → V) (w : Fin (q + 1) → W) :
+    SingularMayerVietoris.formalMap (Prod.map f g) (q + 2) (standardPrism q v w) =
+      standardPrism q (f ∘ v) (g ∘ w) := by
+  simp only [standardPrism, map_sum, map_smul, SingularMayerVietoris.formalMap_simplex,
+    shufflePrismVertices_map]
+
+private def FourthHurewicz.CubeSubdivision.prismDiscrepancy {V W : Type*} (q : ℕ) (v : Fin 2 → V)
+    (w : Fin (q + 1) → W) : SingularMayerVietoris.FormalChains (V × W) (q + 2) :=
+  PeriodTorusHigherHomology.formalEdgeCrossProduct q (SingularMayerVietoris.formalSimplex v)
+      (SingularMayerVietoris.formalSimplex w) -
+    standardPrism q v w
+
+@[simp]
+private theorem FourthHurewicz.CubeSubdivision.prismDiscrepancy_zero {V W : Type*} (v : Fin 2 → V)
+    (w : Fin 1 → W) : prismDiscrepancy 0 v w = 0 := by
+  simp only [prismDiscrepancy,
+    PeriodTorusHigherHomology.formalEdgeCrossProduct_zero_simplex_right,
+    SingularMayerVietoris.formalMap_simplex, standardPrism_zero, Function.comp_def, sub_self]
+
+private theorem
+    FourthHurewicz.CubeSubdivision.formalMap_prismDiscrepancy {V W V' W' : Type*} (f : V → V')
+    (g : W → W') (q : ℕ) (v : Fin 2 → V) (w : Fin (q + 1) → W) :
+    SingularMayerVietoris.formalMap (Prod.map f g) (q + 2) (prismDiscrepancy q v w) =
+      prismDiscrepancy q (f ∘ v) (g ∘ w) := by
+  simp only [prismDiscrepancy, map_sub, PeriodTorusHigherHomology.formalMap_edgeCrossProduct,
+    formalMap_standardPrism, SingularMayerVietoris.formalMap_simplex]
+
+private def FourthHurewicz.CubeSubdivision.canonicalPrismDiscrepancy (q : ℕ) :
+    SingularMayerVietoris.FormalChains (Fin 2 × Fin (q + 1)) (q + 2) :=
+  prismDiscrepancy q (fun i => i) (fun j => j)
+
+@[simp]
+private theorem FourthHurewicz.CubeSubdivision.canonicalPrismDiscrepancy_zero :
+    canonicalPrismDiscrepancy 0 = 0 :=
+  prismDiscrepancy_zero _ _
+
+private theorem
+    FourthHurewicz.CubeSubdivision.prismDiscrepancy_eq_map_canonical {V W : Type*} (q : ℕ)
+    (v : Fin 2 → V) (w : Fin (q + 1) → W) :
+    prismDiscrepancy q v w =
+      SingularMayerVietoris.formalMap (Prod.map v w) (q + 2) (canonicalPrismDiscrepancy q) := by
+  simpa only [canonicalPrismDiscrepancy, Function.comp_def] using
+    (formalMap_prismDiscrepancy v w q (fun i => i) (fun j => j)).symm
+
+private theorem
+    FourthHurewicz.CubeSubdivision.prismDiscrepancy_succ {V W : Type*} (q : ℕ) (v : Fin 2 → V)
+    (w : Fin (q + 2) → W) :
+    prismDiscrepancy (q + 1) v w =
+      SingularMayerVietoris.formalCone (v 0, w 0) (q + 2)
+        (-SingularMayerVietoris.formalMap (fun z => (v 0, z)) (q + 2)
+                (SingularMayerVietoris.formalSimplex w) -
+            PeriodTorusHigherHomology.formalEdgeCrossProduct q
+              (SingularMayerVietoris.formalSimplex v)
+              (SingularMayerVietoris.formalBoundary (q + 1)
+                (SingularMayerVietoris.formalSimplex w)) +
+          standardPrism q v (Fin.tail w)) := by
+  rw [prismDiscrepancy, PeriodTorusHigherHomology.formalEdgeCrossProduct_simplex_succ,
+    PeriodTorusHigherHomology.formalPointCrossProduct_edge_boundary, standardPrism_succ]
+  simp only [map_sub, map_add, map_neg]
+  abel
+
+private theorem FourthHurewicz.CubeSubdivision.prismDiscrepancy_succ_retained {V W : Type*} (q : ℕ)
+    (v : Fin 2 → V) (w : Fin (q + 2) → W) :
+    prismDiscrepancy (q + 1) v w =
+      SingularMayerVietoris.formalCone (v 0, w 0) (q + 2)
+        (-SingularMayerVietoris.formalMap (fun z => (v 0, z)) (q + 2)
+                (SingularMayerVietoris.formalSimplex w) -
+            prismDiscrepancy q v (Fin.tail w) -
+          PeriodTorusHigherHomology.formalEdgeCrossProduct q
+            (SingularMayerVietoris.formalSimplex v)
+            (retainedFirstBoundary q (SingularMayerVietoris.formalSimplex w))) := by
+  rw [prismDiscrepancy_succ, formalBoundary_firstFace_split_simplex, map_add, prismDiscrepancy]
+  simp only [map_sub, map_add, map_neg]
+  abel
+
+private theorem FourthHurewicz.CubeSubdivision.canonicalPrismDiscrepancy_succ (q : ℕ) :
+    canonicalPrismDiscrepancy (q + 1) =
+      SingularMayerVietoris.formalCone ((0 : Fin 2), (0 : Fin (q + 2))) (q + 2)
+        (-SingularMayerVietoris.formalSimplex (fun j : Fin (q + 2) => ((0 : Fin 2), j)) -
+            SingularMayerVietoris.formalMap (Prod.map (fun i : Fin 2 => i) Fin.succ) (q + 2)
+              (canonicalPrismDiscrepancy q) -
+          ∑ i : Fin (q + 1),
+            (-1 : ℤ) ^ (i.val + 1) •
+              PeriodTorusHigherHomology.formalEdgeCrossProduct q
+                (SingularMayerVietoris.formalSimplex (fun j : Fin 2 => j))
+                (SingularMayerVietoris.formalSimplex i.succ.succAbove)) := by
+  change prismDiscrepancy (q + 1) (fun i : Fin 2 => i) (fun j : Fin (q + 2) => j) = _
+  rw [prismDiscrepancy_succ_retained, prismDiscrepancy_eq_map_canonical]
+  simp only [retainedFirstBoundary_simplex, map_sum, map_smul,
+    SingularMayerVietoris.formalMap_simplex, Function.comp_def]
+  rfl
+
+private theorem FourthHurewicz.CubeSubdivision.canonicalPrismDiscrepancy_mem_badPrism (q : ℕ) :
+    canonicalPrismDiscrepancy q ∈ badPrism q (q + 2) := by
+  induction q with
+  | zero =>
+    rw [canonicalPrismDiscrepancy_zero]
+    exact Submodule.zero_mem _
+  | succ q ih =>
+    rw [canonicalPrismDiscrepancy_succ]
+    apply formalCone_mem_badPrism
+    apply Submodule.sub_mem
+    · apply Submodule.sub_mem
+      · apply Submodule.neg_mem
+        exact
+          mem_badPrism_of_left_zero
+            (SingularMayerVietoris.formalSimplex_mem_supported fun _ => rfl)
+      · exact formalMap_succ_mem_badPrism ih
+    · apply Submodule.sum_mem
+      intro i hi
+      apply Submodule.smul_mem
+      exact
+        formalEdgeCrossProduct_mem_badPrism_of_omit i.succ (Fin.succ_ne_zero i) _
+          (SingularMayerVietoris.formalSimplex_mem_supported fun j => Fin.succAbove_ne i.succ j)
+
+private theorem FourthHurewicz.CubeSubdivision.orientedPrismRealization_left_zero {X : Type}
+    [TopologicalSpace X] {x : X} {m n : ℕ} (p : GenLoop (Fin (n + 3)) X x)
+    (v : Fin (m + 1) → Fin 2 × Fin (n + 3)) (hv : ∀ j, (v j).1 = 0) :
+    orientedPrismRealization p.val m (SingularMayerVietoris.formalSimplex v) = 0 := by
+  have hconst (e : Equiv.Perm (Fin (n + 2))) :
+    p.val.comp (prismCubeSimplex e v) = ContinuousMap.const (FirstHurewicz.Simplex m) x := by
+    ext s
+    exact GenLoop.boundary p _ ⟨0, Or.inl (prismCubeSimplex_zero_of_left_zero e v hv s)⟩
+  simp only [orientedPrismRealization_simplex, hconst]
+  exact signed_sum_constant_eq_zero _
+
+private theorem FourthHurewicz.CubeSubdivision.orientedPrismRealization_last_omitted {X : Type}
+    [TopologicalSpace X] {x : X} {m n : ℕ} (p : GenLoop (Fin (n + 3)) X x)
+    (v : Fin (m + 1) → Fin 2 × Fin (n + 3)) (hv : ∀ j, (v j).2 ≠ Fin.last (n + 2)) :
+    orientedPrismRealization p.val m (SingularMayerVietoris.formalSimplex v) = 0 := by
+  have hconst (e : Equiv.Perm (Fin (n + 2))) :
+    p.val.comp (prismCubeSimplex e v) = ContinuousMap.const (FirstHurewicz.Simplex m) x := by
+    ext s
+    exact
+      GenLoop.boundary p _
+        ⟨(e (Fin.last (n + 1))).succ, Or.inl (prismCubeSimplex_zero_of_last_omitted e v hv s)⟩
+  simp only [orientedPrismRealization_simplex, hconst]
+  exact signed_sum_constant_eq_zero _
+
+private theorem FourthHurewicz.CubeSubdivision.orientedPrismRealization_interior_omitted {X : Type}
+    [TopologicalSpace X] {x : X} {m n : ℕ} (p : GenLoop (Fin (n + 3)) X x) (i : Fin (n + 1))
+    (v : Fin (m + 1) → Fin 2 × Fin (n + 3)) (hv : ∀ j, (v j).2 ≠ i.succ.castSucc) :
+    orientedPrismRealization p.val m (SingularMayerVietoris.formalSimplex v) = 0 := by
+  rw [orientedPrismRealization_simplex]
+  apply
+    signed_sum_eq_zero_of_swap_invariant i.castSucc i.succ
+      (by
+        intro h
+        have := congrArg Fin.val h
+        simp only [Fin.val_castSucc, Fin.val_succ] at this
+        omega)
+  intro e
+  exact
+    congrArg (fun f => FirstHurewicz.simplexChain X m (p.val.comp f))
+      (prismCubeSimplex_swap_of_omitted e i v hv).symm
+
+private theorem FourthHurewicz.CubeSubdivision.orientedPrismRealization_nonzero_omitted {X : Type}
+    [TopologicalSpace X] {x : X} {m n : ℕ} (p : GenLoop (Fin (n + 3)) X x) (i : Fin (n + 3))
+    (hi : i ≠ 0) (v : Fin (m + 1) → Fin 2 × Fin (n + 3)) (hv : ∀ j, (v j).2 ≠ i) :
+    orientedPrismRealization p.val m (SingularMayerVietoris.formalSimplex v) = 0 := by
+  by_cases hlast : i = Fin.last (n + 2)
+  · subst i
+    exact orientedPrismRealization_last_omitted p v hv
+  have hi0 : i.val ≠ 0 := by
+    intro h
+    exact hi (Fin.ext h)
+  have hilast : i.val ≠ n + 2 := by
+    intro h
+    exact hlast (Fin.ext h)
+  have hi_lt := i.isLt
+  let j : Fin (n + 1) := ⟨i.val - 1, by omega⟩
+  have hj : j.succ.castSucc = i := by
+    apply Fin.ext
+    dsimp [j]
+    omega
+  apply orientedPrismRealization_interior_omitted p j v
+  simpa only [hj] using hv
+
+private theorem FourthHurewicz.CubeSubdivision.badPrism_le_ker_orientedPrismRealization {X : Type}
+    [TopologicalSpace X] {x : X} {n : ℕ} (p : GenLoop (Fin (n + 3)) X x) (m : ℕ) :
+    badPrism (n + 2) (m + 1) ≤ LinearMap.ker (orientedPrismRealization p.val m) :=
+  badPrism_le_ker _ (fun v hv => orientedPrismRealization_left_zero p v hv)
+    (fun i hi v hv => orientedPrismRealization_nonzero_omitted p i hi v hv)
+
+private theorem FourthHurewicz.CubeSubdivision.orientedPrismRealization_canonicalPrismDiscrepancy
+    {X : Type} [TopologicalSpace X] {x : X} {n : ℕ} (p : GenLoop (Fin (n + 3)) X x) :
+    orientedPrismRealization p.val (n + 3) (canonicalPrismDiscrepancy (n + 2)) = 0 :=
+  badPrism_le_ker_orientedPrismRealization p (n + 3)
+    (canonicalPrismDiscrepancy_mem_badPrism (n + 2))
+
+private theorem FourthHurewicz.CubeSubdivision.orientedPrismRealization_edge_eq_standard {X : Type}
+    [TopologicalSpace X] {x : X} {n : ℕ} (p : GenLoop (Fin (n + 3)) X x) :
+    orientedPrismRealization p.val (n + 3)
+        (PeriodTorusHigherHomology.formalEdgeCrossProduct (n + 2)
+          (SingularMayerVietoris.formalSimplex (fun i : Fin 2 => i))
+          (SingularMayerVietoris.formalSimplex (fun j : Fin (n + 3) => j))) =
+      orientedPrismRealization p.val (n + 3)
+        (standardPrism (n + 2) (fun i : Fin 2 => i) (fun j : Fin (n + 3) => j)) := by
+  apply sub_eq_zero.mp
+  rw [← map_sub]
+  exact orientedPrismRealization_canonicalPrismDiscrepancy p
+
+private theorem FourthHurewicz.CubeSubdivision.linearMap_zsmul_apply_mo1973_8057 {M N : Type*}
+    [AddCommGroup M] [AddCommGroup N] [Module ℤ M] [Module ℤ N] (r : ℤ) (f : M →ₗ[ℤ] N) (a : M) :
+    (r • f) a = r • f a :=
+  map_zsmul (LinearMap.evalAddMonoidHom a) r f
+
+private theorem FourthHurewicz.CubeSubdivision.orientedPrismRealization_eq_sum {X : Type}
+    [TopologicalSpace X] {n : ℕ} (p : C(HigherHurewicz.CubeTriangulation.CubeN (n + 1), X))
+    (m : ℕ) (c : SingularMayerVietoris.FormalChains (Fin 2 × Fin (n + 1)) (m + 1)) :
+    orientedPrismRealization p m c =
+      ∑ e : Equiv.Perm (Fin n),
+        HigherHurewicz.CubeTriangulation.cubeOrientation e • prismCubeRealization p e m c := by
+  classical
+  have h :
+    orientedPrismRealization p m =
+      ∑ e : Equiv.Perm (Fin n),
+        HigherHurewicz.CubeTriangulation.cubeOrientation e • prismCubeRealization p e m := by
+    apply SingularMayerVietoris.formalChains_ext
+    intro v
+    simp only [orientedPrismRealization_simplex, LinearMap.sum_apply,
+      linearMap_zsmul_apply_mo1973_8057, prismCubeRealization_simplex]
+  simpa only [LinearMap.sum_apply, linearMap_zsmul_apply_mo1973_8057] using
+    LinearMap.congr_fun h c
+
+private def FourthHurewicz.CubeSubdivision.PermutationInsertion.insert {n : ℕ} (k : Fin (n + 1))
+    (e : Equiv.Perm (Fin n)) : Equiv.Perm (Fin (n + 1)) :=
+  Equiv.Perm.decomposeFin.symm (0, e) * k.cycleRange
+
+@[simp]
+private theorem FourthHurewicz.CubeSubdivision.PermutationInsertion.insert_apply_self {n : ℕ}
+    (k : Fin (n + 1)) (e : Equiv.Perm (Fin n)) :
+    FourthHurewicz.CubeSubdivision.PermutationInsertion.insert k e k = 0 := by
+  simp [FourthHurewicz.CubeSubdivision.PermutationInsertion.insert]
+
+@[simp]
+private theorem FourthHurewicz.CubeSubdivision.PermutationInsertion.insert_apply_succAbove {n : ℕ}
+    (k : Fin (n + 1)) (e : Equiv.Perm (Fin n)) (j : Fin n) :
+    FourthHurewicz.CubeSubdivision.PermutationInsertion.insert k e (k.succAbove j) = (e j).succ :=
+  by simp [FourthHurewicz.CubeSubdivision.PermutationInsertion.insert]
+
+@[simp]
+private theorem FourthHurewicz.CubeSubdivision.PermutationInsertion.insert_symm_apply_zero {n : ℕ}
+    (k : Fin (n + 1)) (e : Equiv.Perm (Fin n)) :
+    (FourthHurewicz.CubeSubdivision.PermutationInsertion.insert k e).symm 0 = k := by
+  apply (FourthHurewicz.CubeSubdivision.PermutationInsertion.insert k e).injective
+  simp
+
+@[simp]
+private theorem FourthHurewicz.CubeSubdivision.PermutationInsertion.insert_symm_apply_succ {n : ℕ}
+    (k : Fin (n + 1)) (e : Equiv.Perm (Fin n)) (j : Fin n) :
+    (FourthHurewicz.CubeSubdivision.PermutationInsertion.insert k e).symm j.succ =
+      k.succAbove (e.symm j) := by
+  apply (FourthHurewicz.CubeSubdivision.PermutationInsertion.insert k e).injective
+  simp
+
+@[simp]
+private theorem
+    FourthHurewicz.CubeSubdivision.PermutationInsertion.sign_insert {n : ℕ} (k : Fin (n + 1))
+    (e : Equiv.Perm (Fin n)) :
+    Equiv.Perm.sign (FourthHurewicz.CubeSubdivision.PermutationInsertion.insert k e) =
+      (-1) ^ (k : ℕ) * Equiv.Perm.sign e := by
+  simp [FourthHurewicz.CubeSubdivision.PermutationInsertion.insert, mul_comm]
+
+private theorem FourthHurewicz.CubeSubdivision.PermutationInsertion.sign_insert_int {n : ℕ}
+    (k : Fin (n + 1)) (e : Equiv.Perm (Fin n)) :
+    (Equiv.Perm.sign (FourthHurewicz.CubeSubdivision.PermutationInsertion.insert k e) : ℤ) =
+      (-1 : ℤ) ^ (k : ℕ) * (Equiv.Perm.sign e : ℤ) := by simp
+
+private theorem
+    FourthHurewicz.CubeSubdivision.lt_predAbove_iff_succAbove_lt {n : ℕ} (k : Fin (n + 1))
+    (j : Fin n) (r : Fin (n + 2)) : j.val < (k.predAbove r).val ↔ (k.succAbove j).val < r.val := by
+  simp only [Fin.succAbove, Fin.predAbove, Fin.lt_def, Fin.val_castSucc, apply_dite Fin.val,
+    Fin.val_pred, Fin.coe_castPred, dite_eq_ite, apply_ite Fin.val, Fin.val_succ]
+  split_ifs <;> omega
+
+private theorem
+    FourthHurewicz.CubeSubdivision.prismCubeVertex_shuffle {n : ℕ} (e : Equiv.Perm (Fin n))
+    (k : Fin (n + 1)) (r : Fin (n + 2)) :
+    prismCubeVertex e (shufflePrismVertices (fun i : Fin 2 => i) (fun j : Fin (n + 1) => j) k r) =
+      HigherHurewicz.CubeTriangulation.cubeVertex (PermutationInsertion.insert k e) r := by
+  funext coord
+  refine Fin.cases ?_ (fun j => ?_) coord
+  · by_cases h : r ≤ k.castSucc
+    · have h' : ¬k.val < r.val := by
+        simpa only [prismCubeVertex, Fin.le_def, Fin.val_castSucc, not_lt] using h
+      simp [prismCubeVertex, shufflePrismVertices, h, HigherHurewicz.CubeTriangulation.cubeVertex,
+        h', SingularMayerVietoris.stdVertices]
+    · have h' : k.val < r.val := by
+        simpa only [prismCubeVertex, Fin.le_def, Fin.val_castSucc, not_le] using h
+      simp [prismCubeVertex, shufflePrismVertices, h, HigherHurewicz.CubeTriangulation.cubeVertex,
+        h', SingularMayerVietoris.stdVertices]
+  · simp only [shufflePrismVertices, prismCubeVertex_succ,
+      HigherHurewicz.CubeTriangulation.cubeVertex, PermutationInsertion.insert_symm_apply_succ]
+    simp only [lt_predAbove_iff_succAbove_lt]
+
+private theorem
+    FourthHurewicz.CubeSubdivision.prismCubeSimplex_shuffle {n : ℕ} (e : Equiv.Perm (Fin n))
+    (k : Fin (n + 1)) :
+    prismCubeSimplex e (shufflePrismVertices (fun i : Fin 2 => i) (fun j : Fin (n + 1) => j) k) =
+      HigherHurewicz.CubeTriangulation.cubeSimplex (PermutationInsertion.insert k e) := by
+  apply congrArg HigherHurewicz.CubeTriangulation.cubeAffineSimplex
+  funext r
+  exact prismCubeVertex_shuffle e k r
+
+private theorem FourthHurewicz.CubeSubdivision.PermutationInsertion.insert_injective {n : ℕ} :
+    Function.Injective
+      (fun p : Fin (n + 1) × Equiv.Perm (Fin n) =>
+        FourthHurewicz.CubeSubdivision.PermutationInsertion.insert p.1 p.2) := by
+  rintro ⟨k, e⟩ ⟨l, f⟩ h
+  have hk : k = l := by simpa using congrArg (fun σ : Equiv.Perm (Fin (n + 1)) => σ.symm 0) h
+  subst l
+  refine Prod.ext rfl ?_
+  apply Equiv.ext
+  intro j
+  apply Fin.succ_injective n
+  simpa using congrArg (fun σ : Equiv.Perm (Fin (n + 1)) => σ (k.succAbove j)) h
+
+private theorem FourthHurewicz.CubeSubdivision.PermutationInsertion.insert_bijective {n : ℕ} :
+    Function.Bijective
+      (fun p : Fin (n + 1) × Equiv.Perm (Fin n) =>
+        FourthHurewicz.CubeSubdivision.PermutationInsertion.insert p.1 p.2) := by
+  apply (Fintype.bijective_iff_injective_and_card _).mpr
+  exact ⟨insert_injective, by simp [Fintype.card_perm, Nat.factorial_succ]⟩
+
+private theorem FourthHurewicz.CubeSubdivision.PermutationInsertion.sum_insert {n : ℕ} {A : Type*}
+    [AddCommMonoid A] (f : Equiv.Perm (Fin (n + 1)) → A) :
+    (∑ k : Fin (n + 1),
+        ∑ e : Equiv.Perm (Fin n),
+          f (FourthHurewicz.CubeSubdivision.PermutationInsertion.insert k e)) =
+      ∑ σ : Equiv.Perm (Fin (n + 1)), f σ := by
+  rw [← Fintype.sum_prod_type']
+  exact insert_bijective.sum_comp f
+
+private theorem
+    FourthHurewicz.CubeSubdivision.PermutationInsertion.sum_sign_insert {n : ℕ} {A : Type*}
+    [AddCommGroup A] (f : Equiv.Perm (Fin (n + 1)) → A) :
+    (∑ k : Fin (n + 1),
+        ∑ e : Equiv.Perm (Fin n),
+          ((-1 : ℤ) ^ (k : ℕ) * (Equiv.Perm.sign e : ℤ)) •
+            f (FourthHurewicz.CubeSubdivision.PermutationInsertion.insert k e)) =
+      ∑ σ : Equiv.Perm (Fin (n + 1)), (Equiv.Perm.sign σ : ℤ) • f σ := by
+  simpa only [sign_insert_int] using sum_insert (fun σ => (Equiv.Perm.sign σ : ℤ) • f σ)
+
+private theorem FourthHurewicz.CubeSubdivision.PermutationInsertion.sum_sign_smul_insert {n : ℕ}
+    {A : Type*} [AddCommGroup A] (f : Equiv.Perm (Fin (n + 1)) → A) :
+    (∑ k : Fin (n + 1),
+        ∑ e : Equiv.Perm (Fin n),
+          (-1 : ℤ) ^ (k : ℕ) •
+            ((Equiv.Perm.sign e : ℤ) •
+              f (FourthHurewicz.CubeSubdivision.PermutationInsertion.insert k e))) =
+      ∑ σ : Equiv.Perm (Fin (n + 1)), (Equiv.Perm.sign σ : ℤ) • f σ := by
+  simpa only [SemigroupAction.mul_smul] using sum_sign_insert f
+
+private theorem FourthHurewicz.CubeSubdivision.orientedPrismRealization_standardPrism {X : Type}
+    [TopologicalSpace X] {n : ℕ} (p : C(HigherHurewicz.CubeTriangulation.CubeN (n + 1), X)) :
+    orientedPrismRealization p (n + 1)
+        (standardPrism n (fun i : Fin 2 => i) (fun j : Fin (n + 1) => j)) =
+      ∑ perm : Equiv.Perm (Fin (n + 1)),
+        HigherHurewicz.CubeTriangulation.cubeOrientation perm •
+          FirstHurewicz.simplexChain X (n + 1)
+            (p.comp (HigherHurewicz.CubeTriangulation.cubeSimplex perm)) := by
+  simp only [standardPrism, map_sum, map_zsmul, orientedPrismRealization_simplex,
+    prismCubeSimplex_shuffle, ← Finset.sum_zsmul,
+    HigherHurewicz.CubeTriangulation.cubeOrientation]
+  exact
+    PermutationInsertion.sum_sign_smul_insert
+      (fun perm =>
+        FirstHurewicz.simplexChain X (n + 1)
+          (p.comp (HigherHurewicz.CubeTriangulation.cubeSimplex perm)))
+
+private theorem FourthHurewicz.CubeSubdivision.cubeChain_eq_orientedPrismRealization {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 4) X x) :
+    FourthHurewicz.cubeChain p =
+      orientedPrismRealization p.val 4
+        (PeriodTorusHigherHomology.formalEdgeCrossProduct 3
+          (SingularMayerVietoris.formalSimplex (fun i : Fin 2 => i))
+          (SingularMayerVietoris.formalSimplex (fun j : Fin 4 => j))) := by
+  rw [cubeChain_eq_sum_prisms, orientedPrismRealization_eq_sum]
+  simp only [intervalTetrahedronChain_eq_prismCubeRealization,
+    ThirdHurewicz.Geometry.cubeOrientation, HigherHurewicz.CubeTriangulation.cubeOrientation]
+
+private theorem
+    FourthHurewicz.CubeSubdivision.cubeChain_eq_sum_simplices {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 4) X x) :
+    FourthHurewicz.cubeChain p =
+      ∑ e : Equiv.Perm (Fin 4),
+        HigherHurewicz.CubeTriangulation.cubeOrientation e •
+          FirstHurewicz.simplexChain X 4
+            (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e)) := by
+  rw [cubeChain_eq_orientedPrismRealization, orientedPrismRealization_edge_eq_standard (n := 1) p,
+    orientedPrismRealization_standardPrism]
+
+private def FourthHurewicz.hurewiczFunction {X : Type} [TopologicalSpace X] (x : X) :
+    π_ 4 X x → SingularMayerVietoris.SingularHomology X 4 :=
+  Quotient.lift cubeHomologyClass (fun _ _ h => cubeHomologyClass_homotopic h)
+
+private def FourthHurewicz.hurewiczPi4 {X : Type} [TopologicalSpace X] (x : X) :
+    π_ 4 X x →* Multiplicative (SingularMayerVietoris.SingularHomology X 4)
+    where
+  toFun a := Multiplicative.ofAdd (hurewiczFunction x a)
+  map_one' := congrArg Multiplicative.ofAdd (cubeHomologyClass_const (x := x))
+  map_mul' a
+    b := by
+    refine Quotient.inductionOn₂ a b fun p q => ?_
+    refine
+      (congrArg (fun c : π_ 4 X x => Multiplicative.ofAdd (hurewiczFunction x c))
+            (HomotopyGroup.mul_spec (i := (0 : Fin 4)) (p := p) (q := q))).trans
+        ?_
+    change
+      Multiplicative.ofAdd (cubeHomologyClass (GenLoop.transAt (0 : Fin 4) q p)) =
+        Multiplicative.ofAdd (cubeHomologyClass p + cubeHomologyClass q)
+    rw [cubeHomologyClass_transAt, add_comm]
+
+private def FourthHurewicz.hurewiczMap {X : Type} [TopologicalSpace X] (x : X) :
+    Additive (π_ 4 X x) →ₗ[ℤ] SingularMayerVietoris.SingularHomology X 4
+    where
+  toFun := (hurewiczPi4 x).toAdditiveLeft
+  map_add' := (hurewiczPi4 x).toAdditiveLeft.map_add
+  map_smul' n a := by simpa using map_intCast_smul (hurewiczPi4 x).toAdditiveLeft ℤ ℤ n a
+
+private theorem FourthHurewicz.hurewiczMap_representative {X : Type} [TopologicalSpace X] (x : X)
+    (p : GenLoop (Fin 4) X x) :
+    hurewiczMap x (Additive.ofMul (⟦p⟧ : π_ 4 X x)) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 4
+        (cubeCycle p) :=
+  rfl
+
+private theorem
+    FourthHurewicz.cubeChain_basedFourSimplexLoop {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) : cubeChain (basedFourSimplexLoop τ) = basedFourSimplexChain τ := by
+  rw [CubeSubdivision.cubeChain_eq_sum_simplices, basedFourSimplex_simplexChain_sum]
+
+private theorem
+    FourthHurewicz.cubeCycle_basedFourSimplexLoop {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) : cubeCycle (basedFourSimplexLoop τ) = basedFourSimplexCycle τ := by
+  apply Subtype.ext
+  exact cubeChain_basedFourSimplexLoop τ
+
+private theorem
+    FourthHurewicz.hurewicz_basedFourSimplexClass {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    hurewiczMap x (basedFourSimplexClass τ) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 4
+        (basedFourSimplexCycle τ) := by
+  change
+    SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 4
+        (cubeCycle (basedFourSimplexLoop τ)) =
+      _
+  rw [cubeCycle_basedFourSimplexLoop]
+
+private theorem
+    FourthHurewicz.hurewiczMap_comp_fourSimplexClassOperator {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] :
+    (hurewiczMap x).comp (fourSimplexClassOperator x) =
+      (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 4).comp
+        (normalizedFourSimplexCycleOperator x) := by
+  apply FirstHurewicz.chainMap_ext X 4
+  intro smp
+  simp only [LinearMap.comp_apply, fourSimplexClassOperator_simplex,
+    normalizedFourSimplexCycleOperator_simplex]
+  exact hurewicz_basedFourSimplexClass (normalizedFourSimplex x smp)
+
+private theorem
+    FourthHurewicz.hurewiczMap_fourSimplexClassOperator_cycle {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 4) :
+    hurewiczMap x (fourSimplexClassOperator x c.val) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 4 c := by
+  have h := LinearMap.congr_fun (hurewiczMap_comp_fourSimplexClassOperator x) c.val
+  change
+    hurewiczMap x (fourSimplexClassOperator x c.val) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 4
+        (normalizedFourSimplexCycleOperator x c.val) at h
+  exact h.trans (normalizedFourSimplexCycleOperator_class x c)
+
+private def
+    HigherHurewicz.CubicalBoundary.cubeFacet (n : ℕ) (i : Fin (n + 1)) (ε : (unitInterval)) :
+    C(Fin n → (unitInterval), Fin (n + 1) → (unitInterval))
+    where
+  toFun u := Fin.insertNth (α := fun _ => (unitInterval)) i ε u
+  continuous_toFun := by
+    apply continuous_pi
+    intro j
+    refine Fin.succAboveCases i ?_ (fun k => ?_) j
+    · simpa only [Fin.insertNth_apply_same] using
+        (continuous_const : Continuous fun _ : Fin n → (unitInterval) => ε)
+    · simpa only [Fin.insertNth_apply_succAbove] using
+        (continuous_apply k : Continuous fun u : Fin n → (unitInterval) => u k)
+
+@[simp]
+private theorem HigherHurewicz.CubicalBoundary.cubeFacet_apply_self (n : ℕ) (i : Fin (n + 1))
+    (ε : (unitInterval)) (u : Fin n → (unitInterval)) : cubeFacet n i ε u i = ε :=
+  Fin.insertNth_apply_same (α := fun _ => (unitInterval)) i ε u
+
+@[simp]
+private theorem HigherHurewicz.CubicalBoundary.cubeFacet_apply_succAbove (n : ℕ) (i : Fin (n + 1))
+    (ε : (unitInterval)) (u : Fin n → (unitInterval)) (j : Fin n) :
+    cubeFacet n i ε u (i.succAbove j) = u j :=
+  Fin.insertNth_apply_succAbove (α := fun _ => (unitInterval)) i ε u j
+
+private def
+    HigherHurewicz.SimplexGeometry.simplexTwoBoundary (n : ℕ) : Set (FirstHurewicz.Simplex n) :=
+  {s | ∃ i j : Fin (n + 1), i ≠ j ∧ s i = 0 ∧ s j = 0}
+
+private theorem HigherHurewicz.SimplexGeometry.simplexFace_simplexBoundary (n : ℕ) (i : Fin (n + 2))
+    (s : FirstHurewicz.Simplex n) (hs : s ∈ SecondHurewicz.SimplyConnected.simplexBoundary n) :
+    FirstHurewicz.simplexFace n i s ∈ simplexTwoBoundary (n + 1) := by
+  obtain ⟨j, hj⟩ := hs
+  exact
+    ⟨i, i.succAbove j, (Fin.succAbove_ne i j).symm, FirstHurewicz.simplexFace_apply_self n i s,
+      (FirstHurewicz.simplexFace_apply_succAbove n i s j).trans hj⟩
+
+private theorem HigherHurewicz.SimplexGeometry.prefixMinimum_eq_zero_of_coordinate {n : ℕ}
+    (u : Fin n → (unitInterval)) (i : Fin n) (hi : u i = 0) (k : ℕ) (hik : i.val < k) :
+    prefixMinimum u k = 0 :=
+  le_antisymm (hi ▸ prefixMinimum_le_coordinate u k i hik) bot_le
+
+private theorem HigherHurewicz.SimplexGeometry.simplexQuotient_last_eq_zero_of_zero {n : ℕ}
+    (u : Fin n → (unitInterval)) (i : Fin n) (hi : u i = 0) :
+    simplexQuotient n u (Fin.last n) = 0 := by
+  rw [simplexQuotient_last, prefixMinimum_eq_zero_of_coordinate u i hi n i.isLt]
+  rfl
+
+private theorem HigherHurewicz.SimplexGeometry.simplexQuotient_castSucc_eq_zero_of_one {n : ℕ}
+    (u : Fin n → (unitInterval)) (i : Fin n) (hi : u i = 1) :
+    simplexQuotient n u i.castSucc = 0 := by
+  rw [simplexQuotient_castSucc, prefixMinimum_succ u i.val i.isLt]
+  change
+    (prefixMinimum u i.val : ℝ) - (Min.min (prefixMinimum u i.val) (u i) : (unitInterval)) = 0
+  rw [hi, min_eq_left (show prefixMinimum u i.val ≤ 1 from (prefixMinimum u i.val).property.2)]
+  exact sub_self _
+
+private theorem
+    HigherHurewicz.SimplexGeometry.simplexQuotient_castSucc_eq_zero_of_earlier_zero {n : ℕ}
+    (u : Fin n → (unitInterval)) (i j : Fin n) (hij : i < j) (hi : u i = 0) :
+    simplexQuotient n u j.castSucc = 0 := by
+  rw [simplexQuotient_castSucc, prefixMinimum_eq_zero_of_coordinate u i hi j.val hij,
+    prefixMinimum_eq_zero_of_coordinate u i hi (j.val + 1)
+      ((show i.val < j.val from hij).trans_le (Nat.le_succ j.val))]
+  exact sub_self _
+
+private theorem HigherHurewicz.SimplexGeometry.simplexQuotient_codimTwo {n : ℕ}
+    (u : Fin n → (unitInterval))
+    (hu : ∃ i j : Fin n, i ≠ j ∧ (u i = 0 ∨ u i = 1) ∧ (u j = 0 ∨ u j = 1)) :
+    simplexQuotient n u ∈ simplexTwoBoundary n := by
+  obtain ⟨i, j, hij, hi | hi, hj | hj⟩ := hu
+  · rcases lt_or_gt_of_ne hij with hij' | hji'
+    · exact
+        ⟨j.castSucc, Fin.last n, Fin.castSucc_ne_last j,
+          simplexQuotient_castSucc_eq_zero_of_earlier_zero u i j hij' hi,
+          simplexQuotient_last_eq_zero_of_zero u i hi⟩
+    · exact
+        ⟨i.castSucc, Fin.last n, Fin.castSucc_ne_last i,
+          simplexQuotient_castSucc_eq_zero_of_earlier_zero u j i hji' hj,
+          simplexQuotient_last_eq_zero_of_zero u j hj⟩
+  · exact
+      ⟨j.castSucc, Fin.last n, Fin.castSucc_ne_last j,
+        simplexQuotient_castSucc_eq_zero_of_one u j hj,
+        simplexQuotient_last_eq_zero_of_zero u i hi⟩
+  · exact
+      ⟨i.castSucc, Fin.last n, Fin.castSucc_ne_last i,
+        simplexQuotient_castSucc_eq_zero_of_one u i hi,
+        simplexQuotient_last_eq_zero_of_zero u j hj⟩
+  · exact
+      ⟨i.castSucc, j.castSucc, fun h => hij (Fin.castSucc_injective n h),
+        simplexQuotient_castSucc_eq_zero_of_one u i hi,
+        simplexQuotient_castSucc_eq_zero_of_one u j hj⟩
+
+private theorem HigherHurewicz.SimplexGeometry.simplexQuotient_bottom_not_last_twoBoundary (n : ℕ)
+    (i : Fin (n + 1)) (hi : i ≠ Fin.last n) (u : Fin n → (unitInterval)) :
+    simplexQuotient (n + 1) (HigherHurewicz.CubicalBoundary.cubeFacet n i 0 u) ∈
+      simplexTwoBoundary (n + 1) := by
+  have hil : i < Fin.last n := lt_of_le_of_ne (Fin.le_last i) hi
+  exact
+    ⟨(Fin.last n).castSucc, Fin.last (n + 1), Fin.castSucc_ne_last _,
+      simplexQuotient_castSucc_eq_zero_of_earlier_zero
+        (HigherHurewicz.CubicalBoundary.cubeFacet n i 0 u) i (Fin.last n) hil
+        (HigherHurewicz.CubicalBoundary.cubeFacet_apply_self n i 0 u),
+      simplexQuotient_last_eq_zero_of_zero (HigherHurewicz.CubicalBoundary.cubeFacet n i 0 u) i
+        (HigherHurewicz.CubicalBoundary.cubeFacet_apply_self n i 0 u)⟩
+
+private def
+    HigherHurewicz.SimplexGeometry.BasedSimplexBoundary (n : ℕ) {X : Type*} [TopologicalSpace X]
+    (x : X) :=
+  { τ : C(FirstHurewicz.Simplex n, X) // ∀ s ∈ simplexTwoBoundary n, τ s = x }
+
+private def HigherHurewicz.SimplexGeometry.basedSimplexBoundaryFace {X : Type*} [TopologicalSpace X]
+    {x : X} {n : ℕ} (τ : BasedSimplexBoundary (n + 1) x) (i : Fin (n + 2)) : BasedSimplex n x :=
+  ⟨τ.val.comp (FirstHurewicz.simplexFace n i), fun s hs =>
+    τ.property _ (simplexFace_simplexBoundary n i s hs)⟩
+
+private def
+    HigherHurewicz.SimplexGeometry.BasedSimplexBoundary.ofFaces {X : Type*} [TopologicalSpace X]
+    {x : X} {n : ℕ} (τ : C(FirstHurewicz.Simplex (n + 1), X))
+    (h :
+      ∀ i : Fin (n + 2),
+        ∀ s ∈ SecondHurewicz.SimplyConnected.simplexBoundary n,
+          (τ.comp (FirstHurewicz.simplexFace n i)) s = x) :
+    HigherHurewicz.SimplexGeometry.BasedSimplexBoundary (n + 1) x :=
+  ⟨τ, by
+    intro s hs
+    obtain ⟨i, j, hij, hi, hj⟩ := hs
+    obtain ⟨k, hk⟩ := Fin.exists_succAbove_eq hij.symm
+    let t := SecondHurewicz.SimplyConnected.simplexFaceInverse n i ⟨s, hi⟩
+    have ht : t ∈ SecondHurewicz.SimplyConnected.simplexBoundary n := by
+      refine ⟨k, ?_⟩
+      change s (i.succAbove k) = 0
+      rw [hk]
+      exact hj
+    have he := h i t ht
+    change τ (FirstHurewicz.simplexFace n i t) = x at he
+    rw [show FirstHurewicz.simplexFace n i t = s from
+        SecondHurewicz.SimplyConnected.simplexFace_inverse n i ⟨s, hi⟩] at he
+    exact he⟩
+
+private abbrev FourthHurewicz.BasedFiveSimplex {X : Type*} [TopologicalSpace X] (x : X) :=
+  HigherHurewicz.SimplexGeometry.BasedSimplexBoundary 5 x
+
+private abbrev FourthHurewicz.basedFiveSimplexFace {X : Type*} [TopologicalSpace X] {x : X}
+    (τ : BasedFiveSimplex x) (i : Fin 6) : BasedFourSimplex x :=
+  HigherHurewicz.SimplexGeometry.basedSimplexBoundaryFace τ i
+
+private def FourthHurewicz.BasedFiveSimplex.ofFaces {X : Type*} [TopologicalSpace X] {x : X}
+    (τ : C(FirstHurewicz.Simplex 5, X))
+    (h :
+      ∀ i : Fin 6,
+        ∀ s ∈ FourthHurewicz.fourSimplexBoundary,
+          (τ.comp (FirstHurewicz.simplexFace 4 i)) s = x) :
+    FourthHurewicz.BasedFiveSimplex x :=
+  HigherHurewicz.SimplexGeometry.BasedSimplexBoundary.ofFaces τ h
+
+private def
+    FourthHurewicz.normalizedFiveSimplex {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 5) : BasedFiveSimplex x :=
+  BasedFiveSimplex.ofFaces (normalizedFiveSimplexMap x smp)
+    (normalizedFiveSimplexMap_face_boundary x smp)
+
+@[simp]
+private theorem FourthHurewicz.normalizedFiveSimplex_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 5) (i : Fin 6) :
+    basedFiveSimplexFace (normalizedFiveSimplex x smp) i =
+      normalizedFourSimplex x (smp.comp (FirstHurewicz.simplexFace 4 i)) := by
+  apply Subtype.ext
+  exact normalizedFiveSimplexMap_face x smp i
+
+private def HigherHurewicz.NativeSubdivision.nativeCubePair {N : Type*} (i j : N) :
+    C(N → (unitInterval), Fin 2 → (unitInterval))
+    where
+  toFun u := ![u i, u j]
+  continuous_toFun := by
+    apply continuous_pi
+    intro k
+    fin_cases k <;> exact continuous_apply _
+
+private def
+    HigherHurewicz.NativeSubdivision.nativeCubeQuarterTurnHomotopyMap {N : Type*} [DecidableEq N]
+    (i j : N) : C((unitInterval) × (N → (unitInterval)), N → (unitInterval))
+    where
+  toFun z
+    k :=
+    if k = i then
+      SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap (z.1, nativeCubePair i j z.2) 0
+    else
+      if k = j then
+        SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap (z.1, nativeCubePair i j z.2) 1
+      else z.2 k
+  continuous_toFun := by
+    apply continuous_pi
+    intro k
+    by_cases hi : k = i
+    · simp only [ite_eq_left hi]
+      exact
+        (continuous_apply (0 : Fin 2)).comp
+          (SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap.continuous.comp
+            (continuous_fst.prodMk ((nativeCubePair i j).continuous.comp continuous_snd)))
+    · by_cases hj : k = j
+      · simp only [ite_eq_right hi, ite_eq_left hj]
+        exact
+          (continuous_apply (1 : Fin 2)).comp
+            (SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap.continuous.comp
+              (continuous_fst.prodMk ((nativeCubePair i j).continuous.comp continuous_snd)))
+      · simp only [ite_eq_right hi, ite_eq_right hj]
+        exact (continuous_apply k).comp continuous_snd
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.nativeCubeQuarterTurnHomotopyMap_zero {N : Type*}
+    [DecidableEq N] (i j : N) (u : N → (unitInterval)) :
+    nativeCubeQuarterTurnHomotopyMap i j (0, u) = u := by
+  funext k
+  change
+    (if k = i then
+        SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap (0, nativeCubePair i j u) 0
+      else
+        if k = j then
+          SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap (0, nativeCubePair i j u) 1
+        else u k) =
+      u k
+  simp only [SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap_zero]
+  change (if k = i then u i else if k = j then u j else u k) = u k
+  split_ifs with hi hj <;> simp_all
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.nativeCubeQuarterTurnHomotopyMap_one {N : Type*}
+    [DecidableEq N] (i j : N) (u : N → (unitInterval)) :
+    nativeCubeQuarterTurnHomotopyMap i j (1, u) = fun k =>
+      if k = i then u j else if k = j then (unitInterval.symm) (u i) else u k := by
+  funext k
+  simp [nativeCubeQuarterTurnHomotopyMap, nativeCubePair]
+
+private theorem
+    HigherHurewicz.NativeSubdivision.nativeCubeQuarterTurnHomotopyMap_boundary {N : Type*}
+    [DecidableEq N] (i j : N) (hij : i ≠ j) (t : (unitInterval)) (u : N → (unitInterval))
+    (hu : u ∈ Cube.boundary N) : nativeCubeQuarterTurnHomotopyMap i j (t, u) ∈ Cube.boundary N := by
+  have hp (h : nativeCubePair i j u ∈ Cube.boundary (Fin 2)) :
+    nativeCubeQuarterTurnHomotopyMap i j (t, u) ∈ Cube.boundary N := by
+    obtain ⟨k, hk⟩ :=
+      SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap_boundary t (nativeCubePair i j u) h
+    fin_cases k
+    · exact ⟨i, by simpa [nativeCubeQuarterTurnHomotopyMap] using hk⟩
+    · exact ⟨j, by simpa [nativeCubeQuarterTurnHomotopyMap, hij.symm] using hk⟩
+  obtain ⟨k, hk⟩ := hu
+  by_cases hi : k = i
+  · subst k
+    exact hp ⟨0, by simpa [nativeCubePair] using hk⟩
+  · by_cases hj : k = j
+    · subst k
+      exact hp ⟨1, by simpa [nativeCubePair] using hk⟩
+    · exact ⟨k, by simpa [nativeCubeQuarterTurnHomotopyMap, hi, hj] using hk⟩
+
+private def HigherHurewicz.NativeSubdivision.nativeCubeQuarterTurnLoop {N : Type*} [DecidableEq N]
+    {X : Type*} [TopologicalSpace X] {x : X} (p : GenLoop N X x) (i j : N) (hij : i ≠ j) :
+    GenLoop N X x :=
+  ⟨⟨fun u => p (nativeCubeQuarterTurnHomotopyMap i j (1, u)),
+      p.val.continuous.comp
+        ((nativeCubeQuarterTurnHomotopyMap i j).continuous.comp
+          (continuous_const.prodMk continuous_id))⟩,
+    fun u hu => p.property _ (nativeCubeQuarterTurnHomotopyMap_boundary i j hij 1 u hu)⟩
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.nativeCubeQuarterTurnLoop_apply {N : Type*}
+    [DecidableEq N] {X : Type*} [TopologicalSpace X] {x : X} (p : GenLoop N X x) (i j : N)
+    (hij : i ≠ j) (u : N → (unitInterval)) :
+    nativeCubeQuarterTurnLoop p i j hij u =
+      p (fun k => if k = i then u j else if k = j then (unitInterval.symm) (u i) else u k) := by
+  change p (nativeCubeQuarterTurnHomotopyMap i j (1, u)) = _
+  rw [nativeCubeQuarterTurnHomotopyMap_one]
+
+private def
+    HigherHurewicz.NativeSubdivision.nativeCubeQuarterTurnHomotopy {N : Type*} [DecidableEq N]
+    {X : Type*} [TopologicalSpace X] {x : X} (p : GenLoop N X x) (i j : N) (hij : i ≠ j) :
+    p.val.HomotopyRel (nativeCubeQuarterTurnLoop p i j hij).val (Cube.boundary N)
+    where
+  toFun z := p (nativeCubeQuarterTurnHomotopyMap i j z)
+  continuous_toFun := p.val.continuous.comp (nativeCubeQuarterTurnHomotopyMap i j).continuous
+  map_zero_left u := congrArg p (nativeCubeQuarterTurnHomotopyMap_zero i j u)
+  map_one_left _ := rfl
+  prop' t u
+    hu :=
+    (p.property _ (nativeCubeQuarterTurnHomotopyMap_boundary i j hij t u hu)).trans
+      (p.property u hu).symm
+
+private abbrev HigherHurewicz.NativeSubdivision.NativeCube (N : Type*) :=
+  N → (unitInterval)
+
+private def HigherHurewicz.NativeSubdivision.nativeClass {N X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop N X x) : Additive (HomotopyGroup N X x) :=
+  Additive.ofMul (⟦p⟧ : HomotopyGroup N X x)
+
+private theorem
+    HigherHurewicz.NativeSubdivision.nativeClass_homotopic {N X : Type*} [TopologicalSpace X]
+    {x : X} {p q : GenLoop N X x} (h : GenLoop.Homotopic p q) : nativeClass p = nativeClass q :=
+  congrArg (fun a : HomotopyGroup N X x => Additive.ofMul a) (Quotient.sound h)
+
+private theorem
+    HigherHurewicz.NativeSubdivision.nativeClass_transAt {N X : Type*} [TopologicalSpace X]
+    {x : X} [DecidableEq N] [Nontrivial N] (i : N) (p q : GenLoop N X x) :
+    nativeClass (GenLoop.transAt i p q) = nativeClass p + nativeClass q :=
+  congrArg Additive.ofMul
+    ((HomotopyGroup.mul_spec (i := i) (p := q) (q := p)).symm.trans (mul_comm _ _))
+
+private theorem
+    HigherHurewicz.NativeSubdivision.nativeClass_symmAt {N X : Type*} [TopologicalSpace X]
+    {x : X} [DecidableEq N] [Nonempty N] (i : N) (p : GenLoop N X x) :
+    nativeClass (GenLoop.symmAt i p) = -nativeClass p :=
+  congrArg Additive.ofMul (HomotopyGroup.inv_spec (i := i) (p := p)).symm
+
+@[simp]
+private theorem
+    HigherHurewicz.NativeSubdivision.nativeClass_const {N X : Type*} [TopologicalSpace X]
+    {x : X} [DecidableEq N] [Nonempty N] : nativeClass (GenLoop.const : GenLoop N X x) = 0 :=
+  rfl
+
+private def
+    HigherHurewicz.NativeSubdivision.NativeCubeInternalBased {N X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop N X x) : Prop :=
+  ∀ u : NativeCube N, ∀ i j : N, i ≠ j → u i = u j → p u = x
+
+private inductive
+    HigherHurewicz.NativeSubdivision.NativeCubeSameFlat {N : Type*} (a b : NativeCube N) :
+    Prop
+  | zero (i : N) (ha : a i = 0) (hb : b i = 0)
+  | one (i : N) (ha : a i = 1) (hb : b i = 1)
+  | equal (i j : N) (hij : i ≠ j) (ha : a i = a j) (hb : b i = b j)
+
+private def HigherHurewicz.NativeSubdivision.nativeCubeBlend {N : Type*} (t : (unitInterval))
+    (a b : NativeCube N) : NativeCube N := fun i => Set.Icc.convexComb (a i) (b i) t
+
+@[simp]
+private theorem
+    HigherHurewicz.NativeSubdivision.nativeCubeBlend_zero {N : Type*} (a b : NativeCube N) :
+    nativeCubeBlend 0 a b = a := by
+  funext i
+  exact Set.Icc.convexComb_zero _ _
+
+@[simp]
+private theorem
+    HigherHurewicz.NativeSubdivision.nativeCubeBlend_one {N : Type*} (a b : NativeCube N) :
+    nativeCubeBlend 1 a b = b := by
+  funext i
+  exact Set.Icc.convexComb_one _ _
+
+private def HigherHurewicz.NativeSubdivision.nativeCubeBlendMap {N : Type*}
+    (f g : C(NativeCube N, NativeCube N)) : C((unitInterval) × NativeCube N, NativeCube N)
+    where
+  toFun u := nativeCubeBlend u.1 (f u.2) (g u.2)
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    exact
+      Set.Icc.continuous_convexComb_prod.comp
+        (((continuous_apply i).comp (f.continuous.comp continuous_snd)).prodMk
+          (((continuous_apply i).comp (g.continuous.comp continuous_snd)).prodMk continuous_fst))
+
+private theorem
+    HigherHurewicz.NativeSubdivision.nativeCubeBlend_based {N X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop N X x) (hp : NativeCubeInternalBased p) {a b : NativeCube N}
+    (h : NativeCubeSameFlat a b) (t : (unitInterval)) : p (nativeCubeBlend t a b) = x := by
+  cases h with
+  | zero i ha hb => exact p.property _ ⟨i, Or.inl (by simp [nativeCubeBlend, ha, hb])⟩
+  | one i ha hb => exact p.property _ ⟨i, Or.inr (by simp [nativeCubeBlend, ha, hb])⟩
+  | equal i j hij ha hb => exact hp _ i j hij (by simp only [nativeCubeBlend, ha, hb])
+
+private def
+    HigherHurewicz.NativeSubdivision.nativeCubePullbackLoop {N X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop N X x) (f : C(NativeCube N, NativeCube N))
+    (hf : ∀ u ∈ Cube.boundary N, p (f u) = x) : GenLoop N X x :=
+  ⟨p.val.comp f, hf⟩
+
+private def
+    HigherHurewicz.NativeSubdivision.nativeCubeLinearHomotopy {N X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop N X x) (hp : NativeCubeInternalBased p)
+    (f g : C(NativeCube N, NativeCube N)) (hf : ∀ u ∈ Cube.boundary N, p (f u) = x)
+    (hg : ∀ u ∈ Cube.boundary N, p (g u) = x)
+    (hfg : ∀ u ∈ Cube.boundary N, NativeCubeSameFlat (f u) (g u)) :
+    (nativeCubePullbackLoop p f hf).val.HomotopyRel (nativeCubePullbackLoop p g hg).val
+      (Cube.boundary N)
+    where
+  toFun u := p (nativeCubeBlend u.1 (f u.2) (g u.2))
+  continuous_toFun := p.val.continuous.comp (nativeCubeBlendMap f g).continuous
+  map_zero_left
+    u := by
+    change p (nativeCubeBlend 0 (f u) (g u)) = p (f u)
+    rw [nativeCubeBlend_zero]
+  map_one_left
+    u := by
+    change p (nativeCubeBlend 1 (f u) (g u)) = p (g u)
+    rw [nativeCubeBlend_one]
+  prop' t u hu := (nativeCubeBlend_based p hp (hfg u hu) t).trans (hf u hu).symm
+
+private def HigherHurewicz.NativeSubdivision.permuteCubeCoordinates {N : Type*} (e : Equiv.Perm N) :
+    C(N → (unitInterval), N → (unitInterval))
+    where
+  toFun u i := u (e i)
+  continuous_toFun := by fun_prop
+
+private theorem HigherHurewicz.NativeSubdivision.permuteCubeCoordinates_boundary {N : Type*}
+    (e : Equiv.Perm N) (u : N → (unitInterval)) (hu : u ∈ Cube.boundary N) :
+    permuteCubeCoordinates e u ∈ Cube.boundary N := by
+  obtain ⟨i, hi⟩ := hu
+  exact ⟨e.symm i, by simpa [permuteCubeCoordinates] using hi⟩
+
+private def
+    HigherHurewicz.NativeSubdivision.permuteCubeLoop {N : Type*} {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop N X x) (e : Equiv.Perm N) : GenLoop N X x :=
+  ⟨p.val.comp (permuteCubeCoordinates e), fun u hu =>
+    p.property _ (permuteCubeCoordinates_boundary e u hu)⟩
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.permuteCubeLoop_apply {N : Type*} {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop N X x) (e : Equiv.Perm N) (u : N → (unitInterval)) :
+    permuteCubeLoop p e u = p (fun i => u (e i)) :=
+  rfl
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.permuteCubeLoop_one {N : Type*} {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop N X x) : permuteCubeLoop p 1 = p := by
+  apply GenLoop.ext
+  intro u
+  rfl
+
+private theorem HigherHurewicz.NativeSubdivision.permuteCubeLoop_mul {N : Type*} {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop N X x) (e f : Equiv.Perm N) :
+    permuteCubeLoop p (e * f) = permuteCubeLoop (permuteCubeLoop p f) e := by
+  apply GenLoop.ext
+  intro u
+  rfl
+
+private theorem
+    HigherHurewicz.NativeSubdivision.nativeCubeQuarterTurnLoop_eq_symmAt_permute {N : Type*}
+    {X : Type*} [TopologicalSpace X] {x : X} [DecidableEq N] (p : GenLoop N X x) (i j : N)
+    (hij : i ≠ j) :
+    nativeCubeQuarterTurnLoop p i j hij = GenLoop.symmAt i (permuteCubeLoop p (Equiv.swap i j)) :=
+  by
+  apply GenLoop.ext
+  intro u
+  rw [nativeCubeQuarterTurnLoop_apply]
+  change
+    p (fun k => if k = i then u j else if k = j then (unitInterval.symm) (u i) else u k) =
+      p
+        (fun k =>
+          if Equiv.swap i j k = i then (unitInterval.symm) (u i) else u (Equiv.swap i j k))
+  congr 1
+  funext k
+  by_cases hi : k = i
+  · subst k
+    simp [hij.symm]
+  · by_cases hj : k = j
+    · subst k
+      simp [hij.symm]
+    · simp [hi, hj, Equiv.swap_apply_of_ne_of_ne hi hj]
+
+private theorem HigherHurewicz.NativeSubdivision.nativeClass_quarterTurn {N : Type*} {X : Type*}
+    [TopologicalSpace X] {x : X} [DecidableEq N] (p : GenLoop N X x) (i j : N) (hij : i ≠ j) :
+    nativeClass (nativeCubeQuarterTurnLoop p i j hij) = nativeClass p :=
+  (nativeClass_homotopic ⟨nativeCubeQuarterTurnHomotopy p i j hij⟩).symm
+
+private theorem HigherHurewicz.NativeSubdivision.permuteCubeLoop_swap_additiveClass {N : Type*}
+    {X : Type*} [TopologicalSpace X] {x : X} [DecidableEq N] [Nontrivial N] (p : GenLoop N X x)
+    (i j : N) (hij : i ≠ j) : nativeClass (permuteCubeLoop p (Equiv.swap i j)) = -nativeClass p :=
+  by
+  have h := nativeClass_quarterTurn p i j hij
+  rw [nativeCubeQuarterTurnLoop_eq_symmAt_permute, nativeClass_symmAt] at h
+  simpa only [neg_neg] using congrArg Neg.neg h
+
+private theorem
+    HigherHurewicz.NativeSubdivision.permuteCubeLoop_additiveClass {N : Type*} {X : Type*}
+    [TopologicalSpace X] {x : X} [DecidableEq N] [Nontrivial N] [Fintype N] (p : GenLoop N X x)
+    (e : Equiv.Perm N) :
+    nativeClass (permuteCubeLoop p e) = ((Equiv.Perm.sign e : ℤˣ) : ℤ) • nativeClass p := by
+  induction e using Equiv.Perm.swap_induction_on with
+  | one => simp
+  | swap_mul e i j hij
+    ih =>
+    rw [permuteCubeLoop_mul, permuteCubeLoop_swap_additiveClass _ i j hij, ih]
+    simp [Equiv.Perm.sign_mul, Equiv.Perm.sign_swap hij]
+
+private def HigherHurewicz.CubicalBoundary.BasedCubicalCell (n : ℕ) {X : Type*} [TopologicalSpace X]
+    (x : X) :=
+  { F : C(Fin n → (unitInterval), X) //
+    ∀ u i j, i ≠ j → (u i = 0 ∨ u i = 1) → (u j = 0 ∨ u j = 1) → F u = x }
+
+private def
+    HigherHurewicz.CubicalBoundary.cubicalFace {X : Type*} [TopologicalSpace X] {x : X} {n : ℕ}
+    (F : BasedCubicalCell (n + 1) x) (i : Fin (n + 1)) (ε : (unitInterval)) (hε : ε = 0 ∨ ε = 1) :
+    GenLoop (Fin n) X x :=
+  ⟨F.val.comp (cubeFacet n i ε), fun u ⟨j, hj⟩ =>
+    by
+    apply F.property _ i (i.succAbove j) (Fin.ne_succAbove i j)
+    · simpa only [cubeFacet_apply_self] using hε
+    · simpa only [cubeFacet_apply_succAbove] using hj⟩
+
+@[simp]
+private theorem
+    HigherHurewicz.CubicalBoundary.cubicalFace_apply {X : Type*} [TopologicalSpace X] {x : X}
+    {n : ℕ} (F : BasedCubicalCell (n + 1) x) (i : Fin (n + 1)) (ε : (unitInterval))
+    (hε : ε = 0 ∨ ε = 1) (u : Fin n → (unitInterval)) :
+    cubicalFace F i ε hε u = F.val (cubeFacet n i ε u) :=
+  rfl
+
+private abbrev
+    HigherHurewicz.CubicalBoundary.cubicalLowerFace {X : Type*} [TopologicalSpace X] {x : X}
+    {n : ℕ} (F : BasedCubicalCell (n + 1) x) (i : Fin (n + 1)) : GenLoop (Fin n) X x :=
+  cubicalFace F i 0 (Or.inl rfl)
+
+private abbrev
+    HigherHurewicz.CubicalBoundary.cubicalUpperFace {X : Type*} [TopologicalSpace X] {x : X}
+    {n : ℕ} (F : BasedCubicalCell (n + 1) x) (i : Fin (n + 1)) : GenLoop (Fin n) X x :=
+  cubicalFace F i 1 (Or.inr rfl)
+
+private structure
+    HigherHurewicz.CubicalBoundary.CubicalEvaluator {X : Type*} [TopologicalSpace X] (n : ℕ)
+    (x : X) (A : Type*) [AddCommGroup A] where
+  evaluate : GenLoop (Fin n) X x → A
+  map_const : evaluate GenLoop.const = 0
+  map_homotopic : ∀ {p q}, GenLoop.Homotopic p q → evaluate p = evaluate q
+  map_transAt : ∀ i p q, evaluate (GenLoop.transAt i p q) = evaluate p + evaluate q
+  map_symmAt : ∀ i p, evaluate (GenLoop.symmAt i p) = -evaluate p
+  map_swap :
+    ∀ p i j,
+      i ≠ j →
+        evaluate (HigherHurewicz.NativeSubdivision.permuteCubeLoop p (Equiv.swap i j)) =
+          -evaluate p
+
+private instance HigherHurewicz.CubicalBoundary.instCoeFun1 {X : Type*} [TopologicalSpace X] {n : ℕ}
+    {x : X} {A : Type*} [AddCommGroup A] :
+    CoeFun (CubicalEvaluator n x A) (fun _ => GenLoop (Fin n) X x → A) :=
+  ⟨CubicalEvaluator.evaluate⟩
+
+private theorem HigherHurewicz.CubicalBoundary.CubicalEvaluator.map_permutation {X : Type*}
+    [TopologicalSpace X] {n : ℕ} {x : X} {A : Type*} [AddCommGroup A]
+    (E : HigherHurewicz.CubicalBoundary.CubicalEvaluator n x A) (p : GenLoop (Fin n) X x)
+    (e : Equiv.Perm (Fin n)) :
+    E (HigherHurewicz.NativeSubdivision.permuteCubeLoop p e) =
+      ((Equiv.Perm.sign e : ℤˣ) : ℤ) • E p := by
+  induction e using Equiv.Perm.swap_induction_on with
+  | one => simp
+  | swap_mul e i j hij
+    ih =>
+    rw [HigherHurewicz.NativeSubdivision.permuteCubeLoop_mul, E.map_swap _ i j hij, ih]
+    simp [Equiv.Perm.sign_mul, Equiv.Perm.sign_swap hij]
+
+private theorem HigherHurewicz.CubicalBoundary.CubicalEvaluator.map_finRotate {X : Type*}
+    [TopologicalSpace X] {n : ℕ} {x : X} {A : Type*} [AddCommGroup A]
+    (E : HigherHurewicz.CubicalBoundary.CubicalEvaluator n x A) (p : GenLoop (Fin n) X x) :
+    E (HigherHurewicz.NativeSubdivision.permuteCubeLoop p (finRotate n)) =
+      (-1 : ℤ) ^ (n - 1) • E p := by
+  rw [E.map_permutation, sign_finRotate]
+  simp
+
+private def
+    HigherHurewicz.CubicalBoundary.cubicalBoundaryValue {X : Type*} [TopologicalSpace X] {n : ℕ}
+    {x : X} {A : Type*} [AddCommGroup A] (E : CubicalEvaluator n x A)
+    (F : BasedCubicalCell (n + 1) x) : A :=
+  ∑ i : Fin (n + 1), (-1 : ℤ) ^ i.val • (E (cubicalUpperFace F i) - E (cubicalLowerFace F i))
+
+private def
+    HigherHurewicz.CubicalBoundary.nativeCubicalEvaluator {X : Type*} [TopologicalSpace X] (n : ℕ)
+    (x : X) : CubicalEvaluator (n + 2) x (Additive (π_ (n + 2) X x))
+    where
+  evaluate := HigherHurewicz.NativeSubdivision.nativeClass
+  map_const := HigherHurewicz.NativeSubdivision.nativeClass_const
+  map_homotopic := HigherHurewicz.NativeSubdivision.nativeClass_homotopic
+  map_transAt := HigherHurewicz.NativeSubdivision.nativeClass_transAt
+  map_symmAt := HigherHurewicz.NativeSubdivision.nativeClass_symmAt
+  map_swap := HigherHurewicz.NativeSubdivision.permuteCubeLoop_swap_additiveClass
+
+private theorem HigherHurewicz.SimplexGeometry.succAbove_lt_prefix_iff_mo1973_8180 {n : ℕ}
+    (i : Fin (n + 1)) (j : Fin n) (k : ℕ) (h : k ≤ i.val) : (i.succAbove j).val < k ↔ j.val < k :=
+  by
+  by_cases hji : j.castSucc < i
+  · rw [Fin.succAbove_of_castSucc_lt i j hji]
+    rfl
+  · rw [Fin.succAbove_of_le_castSucc i j (le_of_not_gt hji)]
+    simp only [Fin.lt_def, Fin.val_castSucc] at hji
+    simp only [Fin.val_succ]
+    omega
+
+private theorem HigherHurewicz.SimplexGeometry.succAbove_lt_prefix_succ_iff_mo1973_8181 {n : ℕ}
+    (i : Fin (n + 1)) (j : Fin n) (k : ℕ) (h : i.val ≤ k) :
+    (i.succAbove j).val < k + 1 ↔ j.val < k := by
+  by_cases hji : j.castSucc < i
+  · rw [Fin.succAbove_of_castSucc_lt i j hji]
+    simp only [Fin.lt_def, Fin.val_castSucc] at hji
+    simp only [Fin.val_castSucc]
+    omega
+  · rw [Fin.succAbove_of_le_castSucc i j (le_of_not_gt hji)]
+    simp only [Fin.val_succ, Nat.add_lt_add_iff_right]
+
+private theorem HigherHurewicz.SimplexGeometry.prefixMinimum_insertNth_le {n : ℕ} (i : Fin (n + 1))
+    (ε : (unitInterval)) (u : Fin n → (unitInterval)) (k : ℕ) (h : k ≤ i.val) :
+    prefixMinimum (Fin.insertNth i ε u) k = prefixMinimum u k := by
+  apply eq_of_forall_le_iff
+  intro a
+  simp only [prefixMinimum, Finset.le_inf_iff, Finset.mem_filter, Finset.mem_univ, true_and]
+  rw [Fin.forall_iff_succAbove i]
+  simp only [Fin.insertNth_apply_same, Fin.insertNth_apply_succAbove,
+    succAbove_lt_prefix_iff_mo1973_8180 i _ k h, not_lt_of_ge h, false_implies, true_and]
+
+private theorem
+    HigherHurewicz.SimplexGeometry.prefixMinimum_insertNth_succ {n : ℕ} (i : Fin (n + 1))
+    (ε : (unitInterval)) (u : Fin n → (unitInterval)) (k : ℕ) (h : i.val ≤ k) :
+    prefixMinimum (Fin.insertNth i ε u) (k + 1) = Min.min ε (prefixMinimum u k) := by
+  apply eq_of_forall_le_iff
+  intro a
+  simp only [prefixMinimum, Finset.le_inf_iff, Finset.mem_filter, Finset.mem_univ, true_and,
+    le_min_iff]
+  rw [Fin.forall_iff_succAbove i]
+  simp only [Fin.insertNth_apply_same, Fin.insertNth_apply_succAbove,
+    succAbove_lt_prefix_succ_iff_mo1973_8181 i _ k h, Nat.lt_succ_of_le h, true_implies]
+
+private theorem
+    HigherHurewicz.SimplexGeometry.prefixMinimum_insertNth_one_le {n : ℕ} (i : Fin (n + 1))
+    (u : Fin n → (unitInterval)) (k : ℕ) (h : k ≤ i.val) :
+    prefixMinimum (Fin.insertNth i 1 u) k = prefixMinimum u k :=
+  prefixMinimum_insertNth_le i 1 u k h
+
+private theorem
+    HigherHurewicz.SimplexGeometry.prefixMinimum_insertNth_one_succ {n : ℕ} (i : Fin (n + 1))
+    (u : Fin n → (unitInterval)) (k : ℕ) (h : i.val ≤ k) :
+    prefixMinimum (Fin.insertNth i 1 u) (k + 1) = prefixMinimum u k := by
+  rw [prefixMinimum_insertNth_succ i 1 u k h]
+  exact min_eq_right (show prefixMinimum u k ≤ (⊤ : (unitInterval)) from le_top)
+
+private theorem HigherHurewicz.SimplexGeometry.prefixMinimum_insertNth_last_le {n : ℕ}
+    (u : Fin n → (unitInterval)) (ε : (unitInterval)) (k : ℕ) (hk : k ≤ n) :
+    prefixMinimum (Fin.insertNth (Fin.last n) ε u) k = prefixMinimum u k :=
+  prefixMinimum_insertNth_le (Fin.last n) ε u k hk
+
+private theorem
+    HigherHurewicz.SimplexGeometry.extendedMinimum_cubeFacet_one_le {n : ℕ} (i : Fin (n + 1))
+    (u : Fin n → (unitInterval)) (k : ℕ) (hk : k ≤ i.val) :
+    extendedMinimum (HigherHurewicz.CubicalBoundary.cubeFacet n i 1 u) k = extendedMinimum u k := by
+  have hkn : k ≤ n := hk.trans (Nat.le_of_lt_succ i.isLt)
+  rw [extendedMinimum_of_le _ k (hkn.trans (Nat.le_succ n)), extendedMinimum_of_le u k hkn]
+  exact prefixMinimum_insertNth_one_le i u k hk
+
+private theorem HigherHurewicz.SimplexGeometry.extendedMinimum_cubeFacet_one_succ {n : ℕ}
+    (i : Fin (n + 1)) (u : Fin n → (unitInterval)) (k : ℕ) (hk : i.val ≤ k) :
+    extendedMinimum (HigherHurewicz.CubicalBoundary.cubeFacet n i 1 u) (k + 1) =
+      extendedMinimum u k := by
+  by_cases hkn : k ≤ n
+  · rw [extendedMinimum_of_le _ (k + 1) (Nat.succ_le_succ hkn), extendedMinimum_of_le u k hkn]
+    exact prefixMinimum_insertNth_one_succ i u k hk
+  · simp only [extendedMinimum, ite_eq_right hkn,
+      ite_eq_right (show ¬k + 1 ≤ n + 1 from fun h => hkn (Nat.succ_le_succ_iff.mp h))]
+
+private theorem HigherHurewicz.SimplexGeometry.extendedMinimum_cubeFacet_last_zero {n : ℕ}
+    (u : Fin n → (unitInterval)) (k : ℕ) :
+    extendedMinimum (HigherHurewicz.CubicalBoundary.cubeFacet n (Fin.last n) 0 u) k =
+      extendedMinimum u k := by
+  by_cases hkn : k ≤ n
+  · rw [extendedMinimum_of_le _ k (hkn.trans (Nat.le_succ n)), extendedMinimum_of_le u k hkn]
+    exact prefixMinimum_insertNth_last_le u 0 k hkn
+  · by_cases hks : k ≤ n + 1
+    · have hk : k = n + 1 := by omega
+      subst k
+      rw [extendedMinimum_of_le _ (n + 1) le_rfl, extendedMinimum_last_succ]
+      change prefixMinimum (Fin.insertNth (Fin.last n) 0 u) (n + 1) = 0
+      rw [prefixMinimum_insertNth_succ (Fin.last n) 0 u n le_rfl]
+      exact min_eq_left (show (0 : (unitInterval)) ≤ prefixMinimum u n from bot_le)
+    · simp only [extendedMinimum, ite_eq_right hkn, ite_eq_right hks]
+
+private theorem HigherHurewicz.SimplexGeometry.simplexQuotient_cubeFacet_one_apply (n : ℕ)
+    (i : Fin (n + 1)) (u : Fin n → (unitInterval)) :
+    simplexQuotient (n + 1) (HigherHurewicz.CubicalBoundary.cubeFacet n i 1 u) =
+      FirstHurewicz.simplexFace n i.castSucc (simplexQuotient n u) := by
+  apply Subtype.ext
+  funext k
+  change
+    simplexQuotient (n + 1) (HigherHurewicz.CubicalBoundary.cubeFacet n i 1 u) k =
+      FirstHurewicz.simplexFace n i.castSucc (simplexQuotient n u) k
+  refine Fin.succAboveCases i.castSucc ?_ (fun j => ?_) k
+  · rw [FirstHurewicz.simplexFace_apply_self]
+    exact
+      simplexQuotient_castSucc_eq_zero_of_one _ i
+        (HigherHurewicz.CubicalBoundary.cubeFacet_apply_self n i 1 u)
+  · rw [FirstHurewicz.simplexFace_apply_succAbove]
+    by_cases hji : j < i
+    · rw [Fin.succAbove_of_castSucc_lt i.castSucc j (show j.castSucc < i.castSucc from hji)]
+      simp only [simplexQuotient_apply, Fin.val_castSucc]
+      rw [extendedMinimum_cubeFacet_one_le i u j.val (le_of_lt hji),
+        extendedMinimum_cubeFacet_one_le i u (j.val + 1) (Nat.succ_le_of_lt hji)]
+    · rw [Fin.succAbove_of_le_castSucc i.castSucc j
+          (show i.castSucc ≤ j.castSucc from le_of_not_gt hji)]
+      simp only [simplexQuotient_apply, Fin.val_succ]
+      rw [extendedMinimum_cubeFacet_one_succ i u j.val (le_of_not_gt hji),
+        extendedMinimum_cubeFacet_one_succ i u (j.val + 1)
+          ((show i.val ≤ j.val from le_of_not_gt hji).trans (Nat.le_succ j.val))]
+
+private theorem HigherHurewicz.SimplexGeometry.simplexQuotient_cubeFacet_last_zero_apply (n : ℕ)
+    (u : Fin n → (unitInterval)) :
+    simplexQuotient (n + 1) (HigherHurewicz.CubicalBoundary.cubeFacet n (Fin.last n) 0 u) =
+      FirstHurewicz.simplexFace n (Fin.last (n + 1)) (simplexQuotient n u) := by
+  apply Subtype.ext
+  funext k
+  change
+    simplexQuotient (n + 1) (HigherHurewicz.CubicalBoundary.cubeFacet n (Fin.last n) 0 u) k =
+      FirstHurewicz.simplexFace n (Fin.last (n + 1)) (simplexQuotient n u) k
+  refine Fin.lastCases ?_ (fun j => ?_) k
+  · rw [FirstHurewicz.simplexFace_apply_self]
+    exact
+      simplexQuotient_last_eq_zero_of_zero _ (Fin.last n)
+        (HigherHurewicz.CubicalBoundary.cubeFacet_apply_self n (Fin.last n) 0 u)
+  · rw [show j.castSucc = (Fin.last (n + 1)).succAbove j by simp,
+      FirstHurewicz.simplexFace_apply_succAbove]
+    simp only [Fin.succAbove_last, simplexQuotient_apply, Fin.val_castSucc,
+      extendedMinimum_cubeFacet_last_zero]
+
+private def
+    HigherHurewicz.SimplexGeometry.simplexBoundaryCube {X : Type*} [TopologicalSpace X] {x : X}
+    {n : ℕ} (τ : BasedSimplexBoundary n x) :
+    HigherHurewicz.CubicalBoundary.BasedCubicalCell n x :=
+  ⟨τ.val.comp (simplexQuotient n), fun u i j hij hi hj =>
+    τ.property _ (simplexQuotient_codimTwo u ⟨i, j, hij, hi, hj⟩)⟩
+
+private theorem
+    HigherHurewicz.SimplexGeometry.simplexBoundaryCube_upper {X : Type*} [TopologicalSpace X]
+    {x : X} {n : ℕ} (τ : BasedSimplexBoundary (n + 1) x) (i : Fin (n + 1)) :
+    HigherHurewicz.CubicalBoundary.cubicalUpperFace (simplexBoundaryCube τ) i =
+      basedSimplexLoop (basedSimplexBoundaryFace τ i.castSucc) := by
+  apply GenLoop.ext
+  intro u
+  change
+    τ.val (simplexQuotient (n + 1) (HigherHurewicz.CubicalBoundary.cubeFacet n i 1 u)) =
+      τ.val (FirstHurewicz.simplexFace n i.castSucc (simplexQuotient n u))
+  rw [simplexQuotient_cubeFacet_one_apply]
+
+private theorem HigherHurewicz.SimplexGeometry.simplexBoundaryCube_lower_last {X : Type*}
+    [TopologicalSpace X] {x : X} {n : ℕ} (τ : BasedSimplexBoundary (n + 1) x) :
+    HigherHurewicz.CubicalBoundary.cubicalLowerFace (simplexBoundaryCube τ) (Fin.last n) =
+      basedSimplexLoop (basedSimplexBoundaryFace τ (Fin.last (n + 1))) := by
+  apply GenLoop.ext
+  intro u
+  change
+    τ.val
+        (simplexQuotient (n + 1) (HigherHurewicz.CubicalBoundary.cubeFacet n (Fin.last n) 0 u)) =
+      τ.val (FirstHurewicz.simplexFace n (Fin.last (n + 1)) (simplexQuotient n u))
+  rw [simplexQuotient_cubeFacet_last_zero_apply]
+
+private theorem HigherHurewicz.SimplexGeometry.simplexBoundaryCube_lower_constant {X : Type*}
+    [TopologicalSpace X] {x : X} {n : ℕ} (τ : BasedSimplexBoundary (n + 1) x) (i : Fin (n + 1))
+    (hi : i ≠ Fin.last n) :
+    HigherHurewicz.CubicalBoundary.cubicalLowerFace (simplexBoundaryCube τ) i = GenLoop.const := by
+  apply GenLoop.ext
+  intro u
+  exact τ.property _ (simplexQuotient_bottom_not_last_twoBoundary n i hi u)
+
+private theorem HigherHurewicz.SimplexGeometry.simplexBoundaryCube_boundaryValue {X : Type*}
+    [TopologicalSpace X] {x : X} {A : Type*} [AddCommGroup A] {n : ℕ}
+    (E : HigherHurewicz.CubicalBoundary.CubicalEvaluator n x A)
+    (τ : BasedSimplexBoundary (n + 1) x) :
+    HigherHurewicz.CubicalBoundary.cubicalBoundaryValue E (simplexBoundaryCube τ) =
+      ∑ i : Fin (n + 2), (-1 : ℤ) ^ i.val • E (basedSimplexLoop (basedSimplexBoundaryFace τ i)) :=
+  by
+  have hzero (i : Fin n) :
+    E (HigherHurewicz.CubicalBoundary.cubicalLowerFace (simplexBoundaryCube τ) i.castSucc) = 0 := by
+    rw [simplexBoundaryCube_lower_constant τ i.castSucc (Fin.castSucc_ne_last i)]
+    exact E.map_const
+  have hlower :
+    (∑ i : Fin (n + 1),
+        (-1 : ℤ) ^ i.val •
+          E (HigherHurewicz.CubicalBoundary.cubicalLowerFace (simplexBoundaryCube τ) i)) =
+      (-1 : ℤ) ^ n • E (basedSimplexLoop (basedSimplexBoundaryFace τ (Fin.last (n + 1)))) := by
+    rw [Fin.sum_univ_castSucc]
+    simp only [hzero, smul_zero, Finset.sum_const_zero, zero_add, Fin.val_last,
+      simplexBoundaryCube_lower_last]
+  unfold HigherHurewicz.CubicalBoundary.cubicalBoundaryValue
+  simp_rw [simplexBoundaryCube_upper, smul_sub]
+  rw [Finset.sum_sub_distrib, hlower]
+  conv_rhs => rw [Fin.sum_univ_castSucc]
+  simp only [Fin.val_castSucc, Fin.val_last, pow_succ', neg_mul, one_mul, neg_smul,
+    sub_eq_add_neg]
+
+private def HigherHurewicz.CubicalBoundary.whiskerStartTrack :
+    Path ((0 : (unitInterval)), (0 : (unitInterval))) ((0 : (unitInterval)), (1 : (unitInterval)))
+    where
+  toFun s := (0, s)
+  continuous_toFun := by fun_prop
+  source' := rfl
+  target' := rfl
+
+private def HigherHurewicz.CubicalBoundary.whiskerMiddleTrack :
+    Path ((0 : (unitInterval)), (1 : (unitInterval))) ((1 : (unitInterval)), (1 : (unitInterval)))
+    where
+  toFun s := (s, 1)
+  continuous_toFun := by fun_prop
+  source' := rfl
+  target' := rfl
+
+private def HigherHurewicz.CubicalBoundary.whiskerFinishTrack :
+    Path ((1 : (unitInterval)), (0 : (unitInterval))) ((1 : (unitInterval)), (1 : (unitInterval)))
+    where
+  toFun s := (1, s)
+  continuous_toFun := by fun_prop
+  source' := rfl
+  target' := rfl
+
+private def HigherHurewicz.CubicalBoundary.whiskerTrack :
+    Path ((0 : (unitInterval)), (0 : (unitInterval)))
+      ((1 : (unitInterval)), (0 : (unitInterval))) :=
+  whiskerStartTrack.trans (whiskerMiddleTrack.trans whiskerFinishTrack.symm)
+
+private theorem HigherHurewicz.CubicalBoundary.whiskerTrack_boundary (s : (unitInterval)) :
+    ((whiskerTrack s).1 = 0 ∨ (whiskerTrack s).1 = 1) ∨ (whiskerTrack s).2 = 1 := by
+  unfold whiskerTrack
+  rw [Path.trans_apply]
+  split_ifs
+  · exact Or.inl (Or.inl rfl)
+  · rw [Path.trans_apply]
+    split_ifs
+    · exact Or.inr rfl
+    · exact Or.inl (Or.inr rfl)
+
+private def HigherHurewicz.CubicalBoundary.whiskerMap (n : ℕ) :
+    C((Fin (n + 1) → (unitInterval)) × (unitInterval), Fin (n + 2) → (unitInterval))
+    where
+  toFun
+    z :=
+    Fin.cons (whiskerTrack z.2).1
+      (Fin.snoc (Fin.init z.1) ((whiskerTrack z.2).2 * z.1 (Fin.last n)))
+  continuous_toFun := by
+    apply Continuous.finCons
+    · exact (whiskerTrack.continuous.comp continuous_snd).fst
+    · apply Continuous.finSnoc
+      · apply continuous_pi
+        intro i
+        exact (continuous_apply i.castSucc).comp continuous_fst
+      · apply Continuous.subtype_mk
+        exact
+          (continuous_subtype_val.comp (whiskerTrack.continuous.comp continuous_snd).snd).mul
+            (continuous_subtype_val.comp ((continuous_apply (Fin.last n)).comp continuous_fst))
+
+@[simp]
+private theorem
+    HigherHurewicz.CubicalBoundary.whiskerMap_apply (n : ℕ) (u : Fin (n + 1) → (unitInterval))
+    (s : (unitInterval)) :
+    whiskerMap n (u, s) =
+      Fin.cons (whiskerTrack s).1 (Fin.snoc (Fin.init u) ((whiskerTrack s).2 * u (Fin.last n))) :=
+  rfl
+
+@[simp]
+private theorem
+    HigherHurewicz.CubicalBoundary.whiskerMap_first (n : ℕ) (u : Fin (n + 1) → (unitInterval))
+    (s : (unitInterval)) : whiskerMap n (u, s) 0 = (whiskerTrack s).1 := by simp
+
+@[simp]
+private theorem HigherHurewicz.CubicalBoundary.whiskerMap_middle (n : ℕ)
+    (u : Fin (n + 1) → (unitInterval)) (s : (unitInterval)) (i : Fin n) :
+    whiskerMap n (u, s) i.castSucc.succ = u i.castSucc := by simp [Fin.init]
+
+private theorem HigherHurewicz.CubicalBoundary.whiskerMap_start (n : ℕ)
+    (u : Fin (n + 1) → (unitInterval)) :
+    whiskerMap n (u, 0) = Fin.cons 0 (Fin.snoc (Fin.init u) 0) := by simp
+
+private theorem HigherHurewicz.CubicalBoundary.whiskerMap_finish (n : ℕ)
+    (u : Fin (n + 1) → (unitInterval)) :
+    whiskerMap n (u, 1) = Fin.cons 1 (Fin.snoc (Fin.init u) 0) := by simp
+
+private theorem HigherHurewicz.CubicalBoundary.whiskerMap_last_zero (n : ℕ)
+    (u : Fin (n + 1) → (unitInterval)) (s : (unitInterval)) (hu : u (Fin.last n) = 0) :
+    whiskerMap n (u, s) (Fin.last n).succ = 0 := by simp [hu]
+
+private theorem HigherHurewicz.CubicalBoundary.whiskerCorner_based {n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} (F : BasedCubicalCell (n + 2) x) (ε : (unitInterval))
+    (hε : ε = 0 ∨ ε = 1) (v : Fin n → (unitInterval)) : F.val (Fin.cons ε (Fin.snoc v 0)) = x := by
+  apply F.property _ 0 (Fin.last n).succ (by simp)
+  · simpa only [Fin.cons_zero] using hε
+  · exact Or.inl (by simp)
+
+private theorem HigherHurewicz.CubicalBoundary.whiskerMap_based_of_two_prefix {n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} (F : BasedCubicalCell (n + 2) x)
+    (u : Fin (n + 1) → (unitInterval)) (s : (unitInterval)) (i j : Fin n) (hij : i ≠ j)
+    (hi : u i.castSucc = 0 ∨ u i.castSucc = 1) (hj : u j.castSucc = 0 ∨ u j.castSucc = 1) :
+    F.val (whiskerMap n (u, s)) = x := by
+  apply F.property _ i.castSucc.succ j.castSucc.succ (by simpa using hij)
+  · simpa only [whiskerMap_middle] using hi
+  · simpa only [whiskerMap_middle] using hj
+
+private theorem HigherHurewicz.CubicalBoundary.whiskerMap_based_of_prefix_last {n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} (F : BasedCubicalCell (n + 2) x)
+    (u : Fin (n + 1) → (unitInterval)) (s : (unitInterval)) (i : Fin n)
+    (hi : u i.castSucc = 0 ∨ u i.castSucc = 1) (hz : u (Fin.last n) = 0 ∨ u (Fin.last n) = 1) :
+    F.val (whiskerMap n (u, s)) = x := by
+  rcases hz with hz | hz
+  · apply F.property _ i.castSucc.succ (Fin.last n).succ (by simp)
+    · simpa only [whiskerMap_middle] using hi
+    · exact Or.inl (whiskerMap_last_zero n u s hz)
+  · rcases whiskerTrack_boundary s with ht | hr
+    · apply F.property _ 0 i.castSucc.succ (Fin.succ_ne_zero i.castSucc).symm
+      · simpa only [whiskerMap_first] using ht
+      · simpa only [whiskerMap_middle] using hi
+    · apply F.property _ i.castSucc.succ (Fin.last n).succ (by simp)
+      · simpa only [whiskerMap_middle] using hi
+      · exact Or.inr (by simp [hr, hz])
+
+private theorem HigherHurewicz.CubicalBoundary.whiskerMap_codimTwo_based {n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} (F : BasedCubicalCell (n + 2) x)
+    (u : Fin (n + 1) → (unitInterval)) (s : (unitInterval)) (i j : Fin (n + 1)) (hij : i ≠ j)
+    (hi : u i = 0 ∨ u i = 1) (hj : u j = 0 ∨ u j = 1) : F.val (whiskerMap n (u, s)) = x := by
+  cases i using Fin.lastCases with
+  | last =>
+    cases j using Fin.lastCases with
+    | last => exact (hij rfl).elim
+    | cast j => exact whiskerMap_based_of_prefix_last F u s j hj hi
+  | cast i =>
+    cases j using Fin.lastCases with
+    | last => exact whiskerMap_based_of_prefix_last F u s i hi hj
+    | cast j => exact whiskerMap_based_of_two_prefix F u s i j (by simpa using hij) hi hj
+
+private theorem HigherHurewicz.CubicalBoundary.cubeFacet_succ_cons (n : ℕ) (i : Fin (n + 1))
+    (ε s : (unitInterval)) (u : Fin n → (unitInterval)) :
+    cubeFacet (n + 1) i.succ ε (Fin.cons s u) = Fin.cons s (cubeFacet n i ε u) :=
+  Fin.insertNth_succ_cons i ε s u
+
+private theorem HigherHurewicz.CubicalBoundary.whiskerFacetNormal_arm_based {n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} (F : BasedCubicalCell (n + 2) x) (i : Fin (n + 1))
+    (ε : (unitInterval)) (hε : ε = 0 ∨ ε = 1) (h : i ≠ Fin.last n ∨ ε = 0)
+    (u : Fin n → (unitInterval)) (a : (unitInterval)) (ha : a = 0 ∨ a = 1) (r : (unitInterval)) :
+    F.val
+        (Fin.cons a
+          (Fin.snoc (Fin.init (cubeFacet n i ε u)) (r * cubeFacet n i ε u (Fin.last n)))) =
+      x := by
+  cases i using Fin.lastCases with
+  | last =>
+    have hzero : ε = 0 := h.resolve_left (not_not_intro rfl)
+    subst ε
+    apply F.property _ 0 (Fin.last n).succ (by simp)
+    · simpa only [Fin.cons_zero] using ha
+    · exact Or.inl (by simp)
+  | cast i =>
+    apply F.property _ 0 i.castSucc.succ (Fin.succ_ne_zero i.castSucc).symm
+    · simpa only [Fin.cons_zero] using ha
+    · simpa [Fin.init] using hε
+
+private def
+    HigherHurewicz.CubicalBoundary.whiskeredLoop {n : ℕ} {X : Type*} [TopologicalSpace X] {x : X}
+    (F : BasedCubicalCell (n + 2) x) (u : Fin (n + 1) → (unitInterval)) : GenLoop (Fin 1) X x :=
+  ⟨⟨fun q => F.val (whiskerMap n (u, q 0)), by fun_prop⟩,
+    by
+    intro q hq
+    obtain ⟨i, hi⟩ := hq
+    have he : i = 0 := Subsingleton.elim _ _
+    subst i
+    rcases hi with hi | hi
+    · change F.val (whiskerMap n (u, q 0)) = x
+      rw [hi, whiskerMap_start]
+      exact whiskerCorner_based F 0 (Or.inl rfl) (Fin.init u)
+    · change F.val (whiskerMap n (u, q 0)) = x
+      rw [hi, whiskerMap_finish]
+      exact whiskerCorner_based F 1 (Or.inr rfl) (Fin.init u)⟩
+
+private def HigherHurewicz.CubicalBoundary.whiskeredLoopMap {n : ℕ} {X : Type*} [TopologicalSpace X]
+    {x : X} (F : BasedCubicalCell (n + 2) x) :
+    C(Fin (n + 1) → (unitInterval), GenLoop (Fin 1) X x)
+    where
+  toFun := whiskeredLoop F
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    apply ContinuousMap.continuous_of_continuous_uncurry
+    change
+      Continuous
+        (fun z : (Fin (n + 1) → (unitInterval)) × (Fin 1 → (unitInterval)) =>
+          F.val (whiskerMap n (z.1, z.2 0)))
+    exact F.val.continuous.comp ((whiskerMap n).continuous.comp (by fun_prop))
+
+private def
+    HigherHurewicz.CubicalBoundary.whiskeredCell {n : ℕ} {X : Type*} [TopologicalSpace X] {x : X}
+    (F : BasedCubicalCell (n + 2) x) :
+    BasedCubicalCell (n + 1) (GenLoop.const : GenLoop (Fin 1) X x) :=
+  ⟨whiskeredLoopMap F, by
+    intro u i j hij hi hj
+    apply GenLoop.ext
+    intro q
+    exact whiskerMap_codimTwo_based F u (q 0) i j hij hi hj⟩
+
+@[simp]
+private theorem HigherHurewicz.CubicalBoundary.whiskeredCell_apply {n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} (F : BasedCubicalCell (n + 2) x)
+    (u : Fin (n + 1) → (unitInterval)) (q : Fin 1 → (unitInterval)) :
+    (whiskeredCell F).val u q = F.val (whiskerMap n (u, q 0)) :=
+  rfl
+
+private theorem HigherHurewicz.CubicalBoundary.whiskerTrack_concat (s : (unitInterval)) :
+    whiskerTrack s =
+      if (s : ℝ) ≤ 1 / 2 then (0, Set.projIcc 0 1 zero_le_one (2 * (s : ℝ)))
+      else
+        let t := Set.projIcc 0 1 zero_le_one (2 * (s : ℝ) - 1)
+        if (t : ℝ) ≤ 1 / 2 then (Set.projIcc 0 1 zero_le_one (2 * (t : ℝ)), 1)
+        else (1, (unitInterval.symm) (Set.projIcc 0 1 zero_le_one (2 * (t : ℝ) - 1))) :=
+  rfl
+
+private theorem HigherHurewicz.CubicalBoundary.whiskerMap_concat (n : ℕ)
+    (u : Fin (n + 1) → (unitInterval)) (s : (unitInterval)) :
+    whiskerMap n (u, s) =
+      if (s : ℝ) ≤ 1 / 2 then
+        Fin.cons 0
+          (Fin.snoc (Fin.init u) (Set.projIcc 0 1 zero_le_one (2 * (s : ℝ)) * u (Fin.last n)))
+      else
+        let t := Set.projIcc 0 1 zero_le_one (2 * (s : ℝ) - 1)
+        if (t : ℝ) ≤ 1 / 2 then Fin.cons (Set.projIcc 0 1 zero_le_one (2 * (t : ℝ))) u
+        else
+          Fin.cons 1
+            (Fin.snoc (Fin.init u)
+              ((unitInterval.symm) (Set.projIcc 0 1 zero_le_one (2 * (t : ℝ) - 1)) *
+                u (Fin.last n))) := by
+  rw [whiskerMap_apply, whiskerTrack_concat]
+  dsimp only
+  split_ifs
+  · rfl
+  · simp only [one_mul, Fin.snoc_init_self]
+  · rfl
+
+private def
+    HigherHurewicz.CubicalBoundary.uncurryLoop {X : Type*} [TopologicalSpace X] {x : X} {n : ℕ}
+    (p : GenLoop (Fin n) (GenLoop (Fin 1) X x) GenLoop.const) : GenLoop (Fin (n + 1)) X x :=
+  ⟨⟨fun u => p (fun i => u i.succ) (fun _ => u 0), by fun_prop⟩,
+    by
+    intro u hu
+    obtain ⟨i, hi⟩ := hu
+    cases i using Fin.cases with
+    | zero => exact GenLoop.boundary (p (fun i => u i.succ)) (fun _ => u 0) ⟨0, hi⟩
+    | succ j =>
+      change p (fun i => u i.succ) (fun _ => u 0) = x
+      rw [GenLoop.boundary p _ ⟨j, hi⟩]
+      rfl⟩
+
+@[simp]
+private theorem
+    HigherHurewicz.CubicalBoundary.uncurryLoop_apply {X : Type*} [TopologicalSpace X] {x : X}
+    {n : ℕ} (p : GenLoop (Fin n) (GenLoop (Fin 1) X x) GenLoop.const)
+    (u : Fin (n + 1) → (unitInterval)) : uncurryLoop p u = p (fun i => u i.succ) (fun _ => u 0) :=
+  rfl
+
+@[simp]
+private theorem
+    HigherHurewicz.CubicalBoundary.uncurryLoop_const {X : Type*} [TopologicalSpace X] {x : X}
+    {n : ℕ} :
+    uncurryLoop (GenLoop.const : GenLoop (Fin n) (GenLoop (Fin 1) X x) GenLoop.const) =
+      (GenLoop.const : GenLoop (Fin (n + 1)) X x) := by
+  apply GenLoop.ext
+  intro u
+  rfl
+
+private def
+    HigherHurewicz.CubicalBoundary.uncurryLoopHomotopy {X : Type*} [TopologicalSpace X] {x : X}
+    {n : ℕ} {p q : GenLoop (Fin n) (GenLoop (Fin 1) X x) GenLoop.const}
+    (H : p.val.HomotopyRel q.val (Cube.boundary (Fin n))) :
+    (uncurryLoop p).val.HomotopyRel (uncurryLoop q).val (Cube.boundary (Fin (n + 1)))
+    where
+  toFun z := H (z.1, fun i => z.2 i.succ) (fun _ => z.2 0)
+  continuous_toFun := by fun_prop
+  map_zero_left
+    u := by
+    change H (0, fun i => u i.succ) (fun _ => u 0) = _
+    rw [ContinuousMap.HomotopyWith.apply_zero]
+    rfl
+  map_one_left
+    u := by
+    change H (1, fun i => u i.succ) (fun _ => u 0) = _
+    rw [ContinuousMap.HomotopyWith.apply_one]
+    rfl
+  prop' t u
+    hu := by
+    change H (t, fun i => u i.succ) (fun _ => u 0) = uncurryLoop p u
+    rw [GenLoop.boundary (uncurryLoop p) u hu]
+    obtain ⟨i, hi⟩ := hu
+    cases i using Fin.cases with
+    | zero => exact GenLoop.boundary (H (t, fun i => u i.succ)) (fun _ => u 0) ⟨0, hi⟩
+    | succ j =>
+      rw [H.eq_fst t ⟨j, hi⟩]
+      change p (fun i => u i.succ) (fun _ => u 0) = x
+      rw [GenLoop.boundary p _ ⟨j, hi⟩]
+      rfl
+
+private theorem
+    HigherHurewicz.CubicalBoundary.uncurryLoop_homotopic {X : Type*} [TopologicalSpace X]
+    {x : X} {n : ℕ} {p q : GenLoop (Fin n) (GenLoop (Fin 1) X x) GenLoop.const}
+    (h : GenLoop.Homotopic p q) : GenLoop.Homotopic (uncurryLoop p) (uncurryLoop q) := by
+  obtain ⟨H⟩ := h
+  exact ⟨uncurryLoopHomotopy H⟩
+
+private theorem HigherHurewicz.CubicalBoundary.whiskeredCell_face_normal {n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} (F : BasedCubicalCell (n + 2) x) (i : Fin (n + 1))
+    (ε : (unitInterval)) (hε : ε = 0 ∨ ε = 1) (h : i ≠ Fin.last n ∨ ε = 0) :
+    uncurryLoop (cubicalFace (whiskeredCell F) i ε hε) =
+      GenLoop.transAt 0 GenLoop.const
+        (GenLoop.transAt 0 (cubicalFace F i.succ ε hε) GenLoop.const) := by
+  apply GenLoop.ext
+  intro u
+  have hcons (s : (unitInterval)) : Function.update u 0 s = Fin.cons s (fun j => u j.succ) := by
+    funext j
+    cases j using Fin.cases with
+    | zero => simp
+    | succ j => simp
+  change
+    F.val (whiskerMap n (cubeFacet n i ε (fun j => u j.succ), u 0)) =
+      GenLoop.transAt 0 GenLoop.const
+        (GenLoop.transAt 0 (cubicalFace F i.succ ε hε) GenLoop.const) u
+  rw [whiskerMap_concat]
+  simp only [GenLoop.transAt, GenLoop.coe_copy, GenLoop.const_apply, Function.update_self,
+    Function.update_idem]
+  split_ifs with hs ht
+  · exact whiskerFacetNormal_arm_based F i ε hε h _ 0 (Or.inl rfl) _
+  · rw [cubicalFace_apply, hcons, cubeFacet_succ_cons]
+  · exact whiskerFacetNormal_arm_based F i ε hε h _ 1 (Or.inr rfl) _
+
+private theorem HigherHurewicz.CubicalBoundary.whiskerFacet_rotate_coordinates {n : ℕ}
+    (u : Fin (n + 1) → (unitInterval)) :
+    (fun i => u (finRotate (n + 1) i)) = Fin.snoc (Fin.tail u) (u 0) := by
+  simpa only [Fin.cons_self_tail] using (Fin.snoc_eq_cons_rotate (Fin.tail u) (u 0)).symm
+
+private theorem
+    HigherHurewicz.CubicalBoundary.whiskerFacet_zero_coordinates {n : ℕ} (ε : (unitInterval))
+    (u : Fin (n + 1) → (unitInterval)) : cubeFacet (n + 1) 0 ε u = Fin.cons ε u :=
+  Fin.insertNth_zero' ε u
+
+private theorem
+    HigherHurewicz.CubicalBoundary.whiskerFacet_last_coordinates {n : ℕ} (ε : (unitInterval))
+    (u : Fin n → (unitInterval)) : cubeFacet n (Fin.last n) ε u = Fin.snoc u ε :=
+  Fin.insertNth_last' ε u
+
+private theorem HigherHurewicz.CubicalBoundary.whiskerFacet_rotated_face_apply {n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} (F : BasedCubicalCell (n + 2) x) (ε : (unitInterval))
+    (hε : ε = 0 ∨ ε = 1) (u : Fin (n + 1) → (unitInterval)) :
+    HigherHurewicz.NativeSubdivision.permuteCubeLoop (cubicalFace F 0 ε hε) (finRotate (n + 1))
+        u =
+      F.val (Fin.cons ε (Fin.snoc (Fin.tail u) (u 0))) := by
+  rw [HigherHurewicz.NativeSubdivision.permuteCubeLoop_apply, cubicalFace_apply,
+    whiskerFacet_zero_coordinates, whiskerFacet_rotate_coordinates]
+
+private theorem HigherHurewicz.CubicalBoundary.whiskerFacet_last_upper_apply {n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} (F : BasedCubicalCell (n + 2) x)
+    (u : Fin (n + 1) → (unitInterval)) :
+    cubicalUpperFace F (Fin.last (n + 1)) u = F.val (Fin.cons (u 0) (Fin.snoc (Fin.tail u) 1)) := by
+  rw [cubicalFace_apply, whiskerFacet_last_coordinates, Fin.cons_snoc_eq_snoc_cons,
+    Fin.cons_self_tail]
+
+public
+theorem HigherHurewicz.CubicalBoundary.whiskerFacet_symmAt_zero_apply {n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin (n + 1)) X x)
+    (u : Fin (n + 1) → (unitInterval)) :
+    GenLoop.symmAt 0 p u = p (Function.update u 0 ((unitInterval.symm) (u 0))) := by
+  change p (fun j => if j = 0 then (unitInterval.symm) (u 0) else u j) = _
+  congr 1
+  funext j
+  simp only [Function.update_apply]
+
+private theorem HigherHurewicz.CubicalBoundary.whiskerFacet_reflected_rotated_face_apply {n : ℕ}
+    {X : Type*} [TopologicalSpace X] {x : X} (F : BasedCubicalCell (n + 2) x) (ε : (unitInterval))
+    (hε : ε = 0 ∨ ε = 1) (u : Fin (n + 1) → (unitInterval)) :
+    GenLoop.symmAt 0
+        (HigherHurewicz.NativeSubdivision.permuteCubeLoop (cubicalFace F 0 ε hε)
+          (finRotate (n + 1)))
+        u =
+      F.val (Fin.cons ε (Fin.snoc (Fin.tail u) ((unitInterval.symm) (u 0)))) := by
+  rw [whiskerFacet_symmAt_zero_apply, whiskerFacet_rotated_face_apply]
+  simp only [Fin.tail_update_zero, Function.update_self]
+
+private theorem
+    HigherHurewicz.CubicalBoundary.whiskerFacet_last_upper_uncurry_apply {n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} (F : BasedCubicalCell (n + 2) x)
+    (u : Fin (n + 1) → (unitInterval)) :
+    uncurryLoop (cubicalUpperFace (whiskeredCell F) (Fin.last n)) u =
+      F.val (Fin.cons (whiskerTrack (u 0)).1 (Fin.snoc (Fin.tail u) (whiskerTrack (u 0)).2)) := by
+  rw [uncurryLoop_apply, cubicalFace_apply, whiskeredCell_apply, whiskerFacet_last_coordinates,
+    whiskerMap_apply]
+  simp only [Fin.init_snoc, Fin.snoc_last, mul_one]
+  rfl
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Hurewicz/HigherHurewicz2.lean b/LeanPool/HopfProblem/Hurewicz/HigherHurewicz2.lean
new file mode 100644
index 000000000..1a38b9bc8
--- /dev/null
+++ b/LeanPool/HopfProblem/Hurewicz/HigherHurewicz2.lean
@@ -0,0 +1,4308 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Hurewicz.HigherHurewicz1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology4
+import all LeanPool.HopfProblem.Hurewicz.SecondHurewicz
+import all LeanPool.HopfProblem.Hurewicz.ThirdHurewicz
+import all LeanPool.HopfProblem.Hurewicz.HigherHurewicz1
+
+/-!
+# Hopf problem: hurewicz · higher hurewicz 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem HigherHurewicz.CubicalBoundary.whiskerFacet_transAt_zero_apply {n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} (p q : GenLoop (Fin (n + 1)) X x)
+    (u : Fin (n + 1) → (unitInterval)) :
+    GenLoop.transAt 0 p q u =
+      if (u 0 : ℝ) ≤ 1 / 2 then
+        p (Function.update u 0 (Set.projIcc 0 1 zero_le_one (2 * (u 0 : ℝ))))
+      else q (Function.update u 0 (Set.projIcc 0 1 zero_le_one (2 * (u 0 : ℝ) - 1))) :=
+  rfl
+
+private theorem HigherHurewicz.CubicalBoundary.whiskeredCell_face_last_upper {n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} (F : BasedCubicalCell (n + 2) x) :
+    uncurryLoop (cubicalUpperFace (whiskeredCell F) (Fin.last n)) =
+      GenLoop.transAt 0
+        (HigherHurewicz.NativeSubdivision.permuteCubeLoop (cubicalLowerFace F 0)
+          (finRotate (n + 1)))
+        (GenLoop.transAt 0 (cubicalUpperFace F (Fin.last (n + 1)))
+          (GenLoop.symmAt 0
+            (HigherHurewicz.NativeSubdivision.permuteCubeLoop (cubicalUpperFace F 0)
+              (finRotate (n + 1))))) := by
+  apply GenLoop.ext
+  intro u
+  rw [whiskerFacet_last_upper_uncurry_apply, whiskerTrack_concat, whiskerFacet_transAt_zero_apply]
+  by_cases h₀ : (u 0 : ℝ) ≤ 1 / 2
+  · simp only [ite_eq_left h₀, whiskerFacet_rotated_face_apply, Fin.tail_update_zero,
+      Function.update_self]
+  · simp only [ite_eq_right h₀]
+    rw [whiskerFacet_transAt_zero_apply]
+    simp only [Function.update_self]
+    split_ifs
+    · rw [whiskerFacet_last_upper_apply]
+      simp only [Fin.tail_update_zero, Function.update_self]
+    · rw [whiskerFacet_reflected_rotated_face_apply]
+      simp only [Fin.tail_update_zero, Function.update_self]
+
+private theorem HigherHurewicz.CubicalBoundary.uncurryTail_update_succ {n : ℕ}
+    (u : Fin (n + 1) → (unitInterval)) (i : Fin n) (t : (unitInterval)) :
+    (fun j : Fin n => Function.update u i.succ t j.succ) =
+      Function.update (fun j : Fin n => u j.succ) i t := by
+  funext j
+  simp only [Function.update_apply, Fin.succ_inj]
+
+@[simp]
+private theorem HigherHurewicz.CubicalBoundary.uncurryHead_update_succ {n : ℕ}
+    (u : Fin (n + 1) → (unitInterval)) (i : Fin n) (t : (unitInterval)) :
+    Function.update u i.succ t 0 = u 0 := by
+  simp only [Function.update_apply, (Fin.succ_ne_zero i).symm, ite_false]
+
+private theorem HigherHurewicz.CubicalBoundary.uncurryLoop_transAt {n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} (i : Fin n)
+    (p q : GenLoop (Fin n) (GenLoop (Fin 1) X x) GenLoop.const) :
+    uncurryLoop (GenLoop.transAt i p q) =
+      GenLoop.transAt i.succ (uncurryLoop p) (uncurryLoop q) := by
+  apply GenLoop.ext
+  intro u
+  change
+    ((if (u i.succ : ℝ) ≤ 1 / 2 then _ else _) : GenLoop (Fin 1) X x) (fun _ => u 0) =
+      if (u i.succ : ℝ) ≤ 1 / 2 then _ else _
+  split_ifs <;> simp only [uncurryLoop_apply, uncurryTail_update_succ, uncurryHead_update_succ]
+
+private theorem
+    HigherHurewicz.CubicalBoundary.uncurryLoop_symmAt {n : ℕ} {X : Type*} [TopologicalSpace X]
+    {x : X} (i : Fin n) (p : GenLoop (Fin n) (GenLoop (Fin 1) X x) GenLoop.const) :
+    uncurryLoop (GenLoop.symmAt i p) = GenLoop.symmAt i.succ (uncurryLoop p) := by
+  apply GenLoop.ext
+  intro u
+  change
+    p (fun j => if j = i then (unitInterval.symm) (u i.succ) else u j.succ) (fun _ => u 0) =
+      p (fun j => if j.succ = i.succ then (unitInterval.symm) (u i.succ) else u j.succ)
+        (fun _ => if (0 : Fin (n + 1)) = i.succ then (unitInterval.symm) (u i.succ) else u 0)
+  simp only [Fin.succ_inj, (Fin.succ_ne_zero i).symm, ite_false]
+
+private theorem
+    HigherHurewicz.CubicalBoundary.uncurryLoop_swap {X : Type*} [TopologicalSpace X] {x : X}
+    {n : ℕ} (p : GenLoop (Fin n) (GenLoop (Fin 1) X x) GenLoop.const) (i j : Fin n) :
+    uncurryLoop (HigherHurewicz.NativeSubdivision.permuteCubeLoop p (Equiv.swap i j)) =
+      HigherHurewicz.NativeSubdivision.permuteCubeLoop (uncurryLoop p)
+        (Equiv.swap i.succ j.succ) := by
+  have hzero : Equiv.swap i.succ j.succ (0 : Fin (n + 1)) = 0 :=
+    Equiv.swap_apply_of_ne_of_ne (Fin.succ_ne_zero i).symm (Fin.succ_ne_zero j).symm
+  have hsucc (k : Fin n) : Equiv.swap i.succ j.succ k.succ = (Equiv.swap i j k).succ := by
+    by_cases hki : k = i
+    · subst k
+      simp
+    by_cases hkj : k = j
+    · subst k
+      simp
+    have hki' : k.succ ≠ i.succ := fun h => hki (Fin.succ_inj.mp h)
+    have hkj' : k.succ ≠ j.succ := fun h => hkj (Fin.succ_inj.mp h)
+    rw [Equiv.swap_apply_of_ne_of_ne hki' hkj', Equiv.swap_apply_of_ne_of_ne hki hkj]
+  apply GenLoop.ext
+  intro u
+  change
+    p (fun k => u (Equiv.swap i j k).succ) (fun _ => u 0) =
+      p (fun k => u (Equiv.swap i.succ j.succ k.succ)) (fun _ => u (Equiv.swap i.succ j.succ 0))
+  simp only [hsucc, hzero]
+
+private def HigherHurewicz.CubicalBoundary.CubicalEvaluator.uncurry {n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} {A : Type*} [AddCommGroup A]
+    (E : HigherHurewicz.CubicalBoundary.CubicalEvaluator (n + 1) x A) :
+    HigherHurewicz.CubicalBoundary.CubicalEvaluator n (GenLoop.const : GenLoop (Fin 1) X x) A
+    where
+  evaluate p := E (HigherHurewicz.CubicalBoundary.uncurryLoop p)
+  map_const := by rw [HigherHurewicz.CubicalBoundary.uncurryLoop_const]; exact E.map_const
+  map_homotopic h := E.map_homotopic (HigherHurewicz.CubicalBoundary.uncurryLoop_homotopic h)
+  map_transAt i p
+    q := by
+    rw [HigherHurewicz.CubicalBoundary.uncurryLoop_transAt]
+    exact E.map_transAt i.succ _ _
+  map_symmAt i
+    p := by
+    rw [HigherHurewicz.CubicalBoundary.uncurryLoop_symmAt]
+    exact E.map_symmAt i.succ _
+  map_swap p i j
+    hij := by
+    rw [HigherHurewicz.CubicalBoundary.uncurryLoop_swap]
+    exact E.map_swap _ i.succ j.succ (fun h => hij (Fin.succ_inj.mp h))
+
+@[simp]
+private theorem HigherHurewicz.CubicalBoundary.CubicalEvaluator.uncurry_apply {n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} {A : Type*} [AddCommGroup A]
+    (E : HigherHurewicz.CubicalBoundary.CubicalEvaluator (n + 1) x A)
+    (p : GenLoop (Fin n) (GenLoop (Fin 1) X x) GenLoop.const) :
+    E.uncurry p = E (HigherHurewicz.CubicalBoundary.uncurryLoop p) :=
+  rfl
+
+private theorem HigherHurewicz.CubicalBoundary.CubicalEvaluator.map_constantClosingPaths {n : ℕ}
+    {X : Type*} [TopologicalSpace X] {x : X} {A : Type*} [AddCommGroup A]
+    (E : HigherHurewicz.CubicalBoundary.CubicalEvaluator (n + 1) x A)
+    (p : GenLoop (Fin (n + 1)) X x) :
+    E (GenLoop.transAt 0 GenLoop.const (GenLoop.transAt 0 p GenLoop.const)) = E p := by
+  rw [E.map_transAt, E.map_transAt, E.map_const, zero_add, add_zero]
+
+private theorem
+    HigherHurewicz.CubicalBoundary.CubicalEvaluator.map_cyclicClosingPaths {n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} {A : Type*} [AddCommGroup A]
+    (E : HigherHurewicz.CubicalBoundary.CubicalEvaluator (n + 1) x A)
+    (l p r : GenLoop (Fin (n + 1)) X x) :
+    E
+        (GenLoop.transAt 0
+          (HigherHurewicz.NativeSubdivision.permuteCubeLoop l (finRotate (n + 1)))
+          (GenLoop.transAt 0 p
+            (GenLoop.symmAt 0
+              (HigherHurewicz.NativeSubdivision.permuteCubeLoop r (finRotate (n + 1)))))) =
+      E p - (-1 : ℤ) ^ n • (E r - E l) := by
+  rw [E.map_transAt, E.map_transAt, E.map_symmAt, E.map_finRotate, E.map_finRotate]
+  simp only [Nat.add_sub_cancel, smul_sub]
+  abel
+
+private theorem HigherHurewicz.CubicalBoundary.alternatingSign_smul_involution {A : Type*}
+    [AddCommGroup A] (n : ℕ) (a : A) : (-1 : ℤ) ^ n • ((-1 : ℤ) ^ n • a) = a := by
+  rw [smul_smul, ← mul_pow]
+  simp
+
+private theorem
+    HigherHurewicz.CubicalBoundary.alternatingSum_head {A : Type*} [AddCommGroup A] (n : ℕ)
+    (a : Fin (n + 2) → A) :
+    (∑ i : Fin (n + 2), (-1 : ℤ) ^ i.val • a i) =
+      a 0 - ∑ i : Fin (n + 1), (-1 : ℤ) ^ i.val • a i.succ := by
+  rw [Fin.sum_univ_succ]
+  simp only [Fin.val_zero, pow_zero, one_smul, Fin.val_succ, pow_succ', neg_mul, one_mul,
+    neg_smul, Finset.sum_neg_distrib, sub_eq_add_neg]
+
+private theorem HigherHurewicz.CubicalBoundary.alternatingSum_dimension_reduction {A : Type*}
+    [AddCommGroup A] (n : ℕ) (a : Fin (n + 2) → A) (b : Fin (n + 1) → A)
+    (hmid : ∀ i : Fin n, b i.castSucc = a i.castSucc.succ)
+    (hlast : b (Fin.last n) = a (Fin.last (n + 1)) - (-1 : ℤ) ^ n • a 0) :
+    (∑ i : Fin (n + 2), (-1 : ℤ) ^ i.val • a i) = -(∑ i : Fin (n + 1), (-1 : ℤ) ^ i.val • b i) := by
+  have htail :
+    (∑ i : Fin (n + 1), (-1 : ℤ) ^ i.val • b i) =
+      (∑ i : Fin (n + 1), (-1 : ℤ) ^ i.val • a i.succ) - a 0 := by
+    rw [Fin.sum_univ_castSucc, Fin.sum_univ_castSucc]
+    simp only [hmid, hlast, Fin.val_castSucc, Fin.val_last, Fin.succ_last, smul_sub,
+      alternatingSign_smul_involution]
+    abel
+  rw [alternatingSum_head, htail]
+  abel
+
+private theorem HigherHurewicz.CubicalBoundary.whiskeredCell_lower_value {n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} {A : Type*} [AddCommGroup A] (E : CubicalEvaluator (n + 1) x A)
+    (F : BasedCubicalCell (n + 2) x) (i : Fin (n + 1)) :
+    E.uncurry (cubicalLowerFace (whiskeredCell F) i) = E (cubicalLowerFace F i.succ) := by
+  rw [CubicalEvaluator.uncurry_apply, whiskeredCell_face_normal F i 0 (Or.inl rfl) (Or.inr rfl)]
+  exact E.map_constantClosingPaths _
+
+private theorem HigherHurewicz.CubicalBoundary.whiskeredCell_upper_value {n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} {A : Type*} [AddCommGroup A] (E : CubicalEvaluator (n + 1) x A)
+    (F : BasedCubicalCell (n + 2) x) (i : Fin n) :
+    E.uncurry (cubicalUpperFace (whiskeredCell F) i.castSucc) =
+      E (cubicalUpperFace F i.castSucc.succ) := by
+  rw [CubicalEvaluator.uncurry_apply,
+    whiskeredCell_face_normal F i.castSucc 1 (Or.inr rfl) (Or.inl (Fin.castSucc_ne_last i))]
+  exact E.map_constantClosingPaths _
+
+private theorem HigherHurewicz.CubicalBoundary.whiskeredCell_last_upper_value {n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} {A : Type*} [AddCommGroup A] (E : CubicalEvaluator (n + 1) x A)
+    (F : BasedCubicalCell (n + 2) x) :
+    E.uncurry (cubicalUpperFace (whiskeredCell F) (Fin.last n)) =
+      E (cubicalUpperFace F (Fin.last (n + 1))) -
+        (-1 : ℤ) ^ n • (E (cubicalUpperFace F 0) - E (cubicalLowerFace F 0)) := by
+  rw [CubicalEvaluator.uncurry_apply, whiskeredCell_face_last_upper]
+  exact E.map_cyclicClosingPaths _ _ _
+
+private theorem HigherHurewicz.CubicalBoundary.cubicalBoundaryValue_dimension_reduction {n : ℕ}
+    {X : Type*} [TopologicalSpace X] {x : X} {A : Type*} [AddCommGroup A]
+    (E : CubicalEvaluator (n + 1) x A) (F : BasedCubicalCell (n + 2) x) :
+    cubicalBoundaryValue E F = -cubicalBoundaryValue E.uncurry (whiskeredCell F) := by
+  unfold cubicalBoundaryValue
+  apply alternatingSum_dimension_reduction n
+  · intro i
+    rw [whiskeredCell_upper_value, whiskeredCell_lower_value]
+  · rw [whiskeredCell_last_upper_value, whiskeredCell_lower_value, Fin.succ_last]
+    abel
+
+private def HigherHurewicz.CubicalBoundary.squareLowerRoute :
+    C(Fin 1 → (unitInterval), Fin 2 → (unitInterval))
+    where
+  toFun
+    u :=
+    ![Set.projIcc 0 1 zero_le_one (2 * (u 0 : ℝ)),
+      Set.projIcc 0 1 zero_le_one (2 * (u 0 : ℝ) - 1)]
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    fin_cases i <;> dsimp
+    · exact continuous_projIcc.comp (by fun_prop)
+    · exact continuous_projIcc.comp (by fun_prop)
+
+private def HigherHurewicz.CubicalBoundary.squareUpperRoute :
+    C(Fin 1 → (unitInterval), Fin 2 → (unitInterval))
+    where
+  toFun
+    u :=
+    ![Set.projIcc 0 1 zero_le_one (2 * (u 0 : ℝ) - 1),
+      Set.projIcc 0 1 zero_le_one (2 * (u 0 : ℝ))]
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    fin_cases i <;> dsimp
+    · exact continuous_projIcc.comp (by fun_prop)
+    · exact continuous_projIcc.comp (by fun_prop)
+
+@[simp]
+private theorem HigherHurewicz.CubicalBoundary.squareLowerRoute_zero (u : Fin 1 → (unitInterval))
+    (hu : u 0 = 0) : squareLowerRoute u = fun _ => 0 := by
+  funext i
+  fin_cases i <;> apply Subtype.ext <;> norm_num [squareLowerRoute, hu, Set.projIcc]
+
+@[simp]
+private theorem HigherHurewicz.CubicalBoundary.squareLowerRoute_one (u : Fin 1 → (unitInterval))
+    (hu : u 0 = 1) : squareLowerRoute u = fun _ => 1 := by
+  funext i
+  fin_cases i <;> apply Subtype.ext <;> norm_num [squareLowerRoute, hu, Set.projIcc]
+
+@[simp]
+private theorem HigherHurewicz.CubicalBoundary.squareUpperRoute_zero (u : Fin 1 → (unitInterval))
+    (hu : u 0 = 0) : squareUpperRoute u = fun _ => 0 := by
+  funext i
+  fin_cases i <;> apply Subtype.ext <;> norm_num [squareUpperRoute, hu, Set.projIcc]
+
+@[simp]
+private theorem HigherHurewicz.CubicalBoundary.squareUpperRoute_one (u : Fin 1 → (unitInterval))
+    (hu : u 0 = 1) : squareUpperRoute u = fun _ => 1 := by
+  funext i
+  fin_cases i <;> apply Subtype.ext <;> norm_num [squareUpperRoute, hu, Set.projIcc]
+
+private theorem HigherHurewicz.CubicalBoundary.squareLowerRoute_of_le (u : Fin 1 → (unitInterval))
+    (hu : (u 0 : ℝ) ≤ 1 / 2) :
+    squareLowerRoute u = ![Set.projIcc 0 1 zero_le_one (2 * (u 0 : ℝ)), 0] := by
+  funext i
+  fin_cases i
+  · rfl
+  · exact Set.projIcc_of_le_left zero_le_one (by linarith)
+
+private theorem
+    HigherHurewicz.CubicalBoundary.squareLowerRoute_of_not_le (u : Fin 1 → (unitInterval))
+    (hu : ¬(u 0 : ℝ) ≤ 1 / 2) :
+    squareLowerRoute u = ![1, Set.projIcc 0 1 zero_le_one (2 * (u 0 : ℝ) - 1)] := by
+  funext i
+  fin_cases i
+  · exact Set.projIcc_of_right_le zero_le_one (by linarith)
+  · rfl
+
+private theorem HigherHurewicz.CubicalBoundary.squareUpperRoute_of_le (u : Fin 1 → (unitInterval))
+    (hu : (u 0 : ℝ) ≤ 1 / 2) :
+    squareUpperRoute u = ![0, Set.projIcc 0 1 zero_le_one (2 * (u 0 : ℝ))] := by
+  funext i
+  fin_cases i
+  · exact Set.projIcc_of_le_left zero_le_one (by linarith)
+  · rfl
+
+private theorem
+    HigherHurewicz.CubicalBoundary.squareUpperRoute_of_not_le (u : Fin 1 → (unitInterval))
+    (hu : ¬(u 0 : ℝ) ≤ 1 / 2) :
+    squareUpperRoute u = ![Set.projIcc 0 1 zero_le_one (2 * (u 0 : ℝ) - 1), 1] := by
+  funext i
+  fin_cases i
+  · rfl
+  · exact Set.projIcc_of_right_le zero_le_one (by linarith)
+
+private def HigherHurewicz.CubicalBoundary.squareRoutesBlend :
+    C((unitInterval) × (Fin 1 → (unitInterval)), Fin 2 → (unitInterval))
+    where
+  toFun
+    u :=
+    HigherHurewicz.NativeSubdivision.nativeCubeBlend u.1 (squareLowerRoute u.2)
+      (squareUpperRoute u.2)
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    exact
+      Set.Icc.continuous_convexComb_prod.comp
+        (((continuous_apply i).comp (squareLowerRoute.continuous.comp continuous_snd)).prodMk
+          (((continuous_apply i).comp (squareUpperRoute.continuous.comp continuous_snd)).prodMk
+            continuous_fst))
+
+@[simp]
+private theorem HigherHurewicz.CubicalBoundary.squareRoutesBlend_zero (u : Fin 1 → (unitInterval)) :
+    squareRoutesBlend (0, u) = squareLowerRoute u :=
+  HigherHurewicz.NativeSubdivision.nativeCubeBlend_zero _ _
+
+@[simp]
+private theorem HigherHurewicz.CubicalBoundary.squareRoutesBlend_one (u : Fin 1 → (unitInterval)) :
+    squareRoutesBlend (1, u) = squareUpperRoute u :=
+  HigherHurewicz.NativeSubdivision.nativeCubeBlend_one _ _
+
+private theorem HigherHurewicz.CubicalBoundary.squareRoutesBlend_endpoint_zero (t : (unitInterval))
+    (u : Fin 1 → (unitInterval)) (hu : u 0 = 0) : squareRoutesBlend (t, u) = fun _ => 0 := by
+  funext i
+  simp [squareRoutesBlend, HigherHurewicz.NativeSubdivision.nativeCubeBlend,
+    squareLowerRoute_zero u hu, squareUpperRoute_zero u hu]
+
+private theorem HigherHurewicz.CubicalBoundary.squareRoutesBlend_endpoint_one (t : (unitInterval))
+    (u : Fin 1 → (unitInterval)) (hu : u 0 = 1) : squareRoutesBlend (t, u) = fun _ => 1 := by
+  funext i
+  simp [squareRoutesBlend, HigherHurewicz.NativeSubdivision.nativeCubeBlend,
+    squareLowerRoute_one u hu, squareUpperRoute_one u hu]
+
+private theorem HigherHurewicz.CubicalBoundary.squareFacet_zero (ε : (unitInterval))
+    (u : Fin 1 → (unitInterval)) : cubeFacet 1 0 ε u = ![ε, u 0] := by
+  funext i
+  fin_cases i
+  · exact cubeFacet_apply_self 1 0 ε u
+  · change cubeFacet 1 0 ε u ((0 : Fin 2).succAbove 0) = u 0
+    exact cubeFacet_apply_succAbove 1 0 ε u 0
+
+private theorem HigherHurewicz.CubicalBoundary.squareFacet_one (ε : (unitInterval))
+    (u : Fin 1 → (unitInterval)) : cubeFacet 1 1 ε u = ![u 0, ε] := by
+  funext i
+  fin_cases i
+  · change cubeFacet 1 1 ε u ((1 : Fin 2).succAbove 0) = u 0
+    exact cubeFacet_apply_succAbove 1 1 ε u 0
+  · exact cubeFacet_apply_self 1 1 ε u
+
+private theorem HigherHurewicz.CubicalBoundary.squareLowerRoute_transAt_apply {X : Type*}
+    [TopologicalSpace X] {x : X} (F : BasedCubicalCell 2 x) (u : Fin 1 → (unitInterval)) :
+    GenLoop.transAt 0 (cubicalLowerFace F 1) (cubicalUpperFace F 0) u =
+      F.val (squareLowerRoute u) := by
+  change
+    (if (u 0 : ℝ) ≤ 1 / 2 then
+        F.val
+          (cubeFacet 1 1 0 (Function.update u 0 (Set.projIcc 0 1 zero_le_one (2 * (u 0 : ℝ)))))
+      else
+        F.val
+          (cubeFacet 1 0 1
+            (Function.update u 0 (Set.projIcc 0 1 zero_le_one (2 * (u 0 : ℝ) - 1))))) =
+      _
+  by_cases hu : (u 0 : ℝ) ≤ 1 / 2
+  · rw [ite_eq_left hu, squareLowerRoute_of_le u hu]
+    simp only [squareFacet_one, Function.update_self]
+  · rw [ite_eq_right hu, squareLowerRoute_of_not_le u hu]
+    simp only [squareFacet_zero, Function.update_self]
+
+private theorem HigherHurewicz.CubicalBoundary.squareUpperRoute_transAt_apply {X : Type*}
+    [TopologicalSpace X] {x : X} (F : BasedCubicalCell 2 x) (u : Fin 1 → (unitInterval)) :
+    GenLoop.transAt 0 (cubicalLowerFace F 0) (cubicalUpperFace F 1) u =
+      F.val (squareUpperRoute u) := by
+  change
+    (if (u 0 : ℝ) ≤ 1 / 2 then
+        F.val
+          (cubeFacet 1 0 0 (Function.update u 0 (Set.projIcc 0 1 zero_le_one (2 * (u 0 : ℝ)))))
+      else
+        F.val
+          (cubeFacet 1 1 1
+            (Function.update u 0 (Set.projIcc 0 1 zero_le_one (2 * (u 0 : ℝ) - 1))))) =
+      _
+  by_cases hu : (u 0 : ℝ) ≤ 1 / 2
+  · rw [ite_eq_left hu, squareUpperRoute_of_le u hu]
+    simp only [squareFacet_zero, Function.update_self]
+  · rw [ite_eq_right hu, squareUpperRoute_of_not_le u hu]
+    simp only [squareFacet_one, Function.update_self]
+
+private def
+    HigherHurewicz.CubicalBoundary.squareCubicalFacesHomotopy {X : Type*} [TopologicalSpace X]
+    {x : X} (F : BasedCubicalCell 2 x) :
+    (GenLoop.transAt 0 (cubicalLowerFace F 1) (cubicalUpperFace F 0)).val.HomotopyRel
+      (GenLoop.transAt 0 (cubicalLowerFace F 0) (cubicalUpperFace F 1)).val
+      (Cube.boundary (Fin 1))
+    where
+  toFun z := F.val (squareRoutesBlend z)
+  continuous_toFun := F.val.continuous.comp squareRoutesBlend.continuous
+  map_zero_left
+    u := by
+    rw [squareRoutesBlend_zero]
+    exact (squareLowerRoute_transAt_apply F u).symm
+  map_one_left
+    u := by
+    rw [squareRoutesBlend_one]
+    exact (squareUpperRoute_transAt_apply F u).symm
+  prop' t u
+    hu := by
+    change
+      F.val (squareRoutesBlend (t, u)) =
+        GenLoop.transAt 0 (cubicalLowerFace F 1) (cubicalUpperFace F 0) u
+    refine
+      Eq.trans (b := x) ?_
+        ((GenLoop.transAt 0 (cubicalLowerFace F 1) (cubicalUpperFace F 0)).property u hu).symm
+    obtain ⟨i, hi⟩ := hu
+    have hi0 : u 0 = 0 ∨ u 0 = 1 := by simpa only [Fin.fin_one_eq_zero] using hi
+    rcases hi0 with hi0 | hi0
+    · exact
+        (congrArg F.val (squareRoutesBlend_endpoint_zero t u hi0)).trans
+          (F.property (fun _ => 0) 0 1 (by decide) (Or.inl rfl) (Or.inl rfl))
+    · exact
+        (congrArg F.val (squareRoutesBlend_endpoint_one t u hi0)).trans
+          (F.property (fun _ => 1) 0 1 (by decide) (Or.inr rfl) (Or.inr rfl))
+
+private theorem HigherHurewicz.CubicalBoundary.squareCubicalFaces_homotopic {X : Type*}
+    [TopologicalSpace X] {x : X} (F : BasedCubicalCell 2 x) :
+    GenLoop.Homotopic (GenLoop.transAt 0 (cubicalLowerFace F 1) (cubicalUpperFace F 0))
+      (GenLoop.transAt 0 (cubicalLowerFace F 0) (cubicalUpperFace F 1)) :=
+  ⟨squareCubicalFacesHomotopy F⟩
+
+private theorem HigherHurewicz.CubicalBoundary.cubicalBoundaryValue_square {X : Type*}
+    [TopologicalSpace X] {x : X} {A : Type*} [AddCommGroup A] (E : CubicalEvaluator 1 x A)
+    (F : BasedCubicalCell 2 x) : cubicalBoundaryValue E F = 0 := by
+  have h := E.map_homotopic (squareCubicalFaces_homotopic F)
+  rw [E.map_transAt, E.map_transAt] at h
+  unfold cubicalBoundaryValue
+  simp only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero, Fin.val_zero, Fin.val_succ,
+    Nat.zero_add, pow_zero, pow_one, one_zsmul, neg_one_zsmul, ← sub_eq_add_neg]
+  change
+    (E (cubicalUpperFace F 0) - E (cubicalLowerFace F 0)) -
+        (E (cubicalUpperFace F 1) - E (cubicalLowerFace F 1)) =
+      0
+  apply sub_eq_zero.mpr
+  apply sub_eq_sub_iff_add_eq_add.mpr
+  simpa only [add_comm] using h
+
+private theorem HigherHurewicz.CubicalBoundary.cubicalBoundaryValue_eq_zero (n : ℕ) :
+    ∀ {X : Type u} [TopologicalSpace X] {x : X} {A : Type v} [AddCommGroup A]
+      (E : CubicalEvaluator (n + 1) x A) (F : BasedCubicalCell (n + 2) x),
+      cubicalBoundaryValue E F = 0 := by
+  induction n with
+  | zero =>
+    intro X _ x A _ E F
+    exact cubicalBoundaryValue_square E F
+  | succ n ih =>
+    intro X _ x A _ E F
+    rw [cubicalBoundaryValue_dimension_reduction, ih E.uncurry (whiskeredCell F), neg_zero]
+
+private theorem HigherHurewicz.SimplexGeometry.basedSimplexBoundary_evaluation {X : Type*}
+    [TopologicalSpace X] {x : X} {A : Type*} [AddCommGroup A] {n : ℕ}
+    (E : HigherHurewicz.CubicalBoundary.CubicalEvaluator (n + 1) x A)
+    (τ : BasedSimplexBoundary (n + 2) x) :
+    (∑ i : Fin (n + 3), (-1 : ℤ) ^ i.val • E (basedSimplexLoop (basedSimplexBoundaryFace τ i))) =
+      0 := by
+  rw [← simplexBoundaryCube_boundaryValue]
+  exact HigherHurewicz.CubicalBoundary.cubicalBoundaryValue_eq_zero n E (simplexBoundaryCube τ)
+
+private theorem HigherHurewicz.SimplexGeometry.basedSimplexBoundary_signed_relation {X : Type*}
+    [TopologicalSpace X] {x : X} {n : ℕ} (τ : BasedSimplexBoundary (n + 3) x) :
+    (∑ i : Fin (n + 4), (-1 : ℤ) ^ i.val • basedSimplexClass (basedSimplexBoundaryFace τ i)) =
+      0 :=
+  basedSimplexBoundary_evaluation (HigherHurewicz.CubicalBoundary.nativeCubicalEvaluator n x) τ
+
+private theorem
+    FourthHurewicz.basedFiveSimplex_signed_relation {X : Type*} [TopologicalSpace X] {x : X}
+    (τ : BasedFiveSimplex x) :
+    (∑ i : Fin 6, (-1 : ℤ) ^ i.val • basedFourSimplexClass (basedFiveSimplexFace τ i)) = 0 :=
+  HigherHurewicz.SimplexGeometry.basedSimplexBoundary_signed_relation (n := 2) τ
+
+private theorem
+    FourthHurewicz.normalizedFourSimplex_boundary_relation {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 5) :
+    ∑ i : Fin 6,
+        (-1 : ℤ) ^ i.val •
+          basedFourSimplexClass
+            (normalizedFourSimplex x (smp.comp (FirstHurewicz.simplexFace 4 i))) =
+      0 := by
+  simpa only [normalizedFiveSimplex_face] using
+    basedFiveSimplex_signed_relation (normalizedFiveSimplex x smp)
+
+private theorem FourthHurewicz.fourSimplexClassOperator_boundary {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (b : FirstHurewicz.Chains X 5) :
+    fourSimplexClassOperator x (((FirstHurewicz.singularComplex X).d 5 4).hom b) = 0 := by
+  have h : (fourSimplexClassOperator x).comp ((FirstHurewicz.singularComplex X).d 5 4).hom = 0 := by
+    apply FirstHurewicz.chainMap_ext X 5
+    intro smp
+    simp only [LinearMap.comp_apply, FirstHurewicz.boundary_simplex, map_sum, map_zsmul,
+      fourSimplexClassOperator_simplex, LinearMap.zero_apply]
+    exact normalizedFourSimplex_boundary_relation x smp
+  exact LinearMap.congr_fun h b
+
+private theorem HigherHurewicz.CubeTriangulation.exists_cubeSimplex {n : ℕ} (u : CubeN n) :
+    ∃ e : Equiv.Perm (Fin n), ∃ s : FirstHurewicz.Simplex n, cubeSimplex e s = u := by
+  obtain ⟨e, he⟩ := exists_sortedPermutation u
+  exact ⟨e, cubeSimplexInverse e ⟨u, he⟩, cubeSimplex_inverse e ⟨u, he⟩⟩
+
+private def HigherHurewicz.CubeTriangulation.cubeSimplexCylinder {n : ℕ} (e : Equiv.Perm (Fin n)) :
+    C((unitInterval) × FirstHurewicz.Simplex n, (unitInterval) × CubeN n) :=
+  (ContinuousMap.id (unitInterval)).prodMap (cubeSimplex e)
+
+private def HigherHurewicz.CubeTriangulation.cubeCylinderCover (n : ℕ) :
+    C((Σ _e : Equiv.Perm (Fin n), (unitInterval) × FirstHurewicz.Simplex n),
+      (unitInterval) × CubeN n)
+    where
+  toFun a := cubeSimplexCylinder a.fst a.snd
+  continuous_toFun := continuous_sigma fun e => (cubeSimplexCylinder e).continuous
+
+private theorem HigherHurewicz.CubeTriangulation.cubeCylinderCover_surjective (n : ℕ) :
+    Function.Surjective (cubeCylinderCover n) := by
+  rintro ⟨r, u⟩
+  obtain ⟨e, s, rfl⟩ := exists_cubeSimplex u
+  exact ⟨⟨e, (r, s)⟩, rfl⟩
+
+private theorem HigherHurewicz.CubeTriangulation.cubeCylinderCover_isQuotientMap (n : ℕ) :
+    Topology.IsQuotientMap (cubeCylinderCover n) :=
+  Topology.IsQuotientMap.of_surjective_continuous (cubeCylinderCover_surjective n)
+    (cubeCylinderCover n).continuous
+
+private def HigherHurewicz.CubeGluing.CubeCompatible {n : ℕ} {X : Type} [TopologicalSpace X]
+    (F : Equiv.Perm (Fin n) → C((unitInterval) × FirstHurewicz.Simplex n, X)) : Prop :=
+  ∀ (e f : Equiv.Perm (Fin n)) (s t : FirstHurewicz.Simplex n),
+    HigherHurewicz.CubeTriangulation.cubeSimplex e s =
+        HigherHurewicz.CubeTriangulation.cubeSimplex f t →
+      ∀ r : (unitInterval), F e (r, s) = F f (r, t)
+
+private def HigherHurewicz.CubeGluing.cubeFamilyMap {n : ℕ} {X : Type} [TopologicalSpace X]
+    (F : Equiv.Perm (Fin n) → C((unitInterval) × FirstHurewicz.Simplex n, X)) :
+    C((Σ _e : Equiv.Perm (Fin n), (unitInterval) × FirstHurewicz.Simplex n), X)
+    where
+  toFun a := F a.fst a.snd
+  continuous_toFun := continuous_sigma fun e => (F e).continuous
+
+private theorem HigherHurewicz.CubeGluing.cubeFamilyMap_factorsThrough {n : ℕ} {X : Type}
+    [TopologicalSpace X] (F : Equiv.Perm (Fin n) → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (hF : CubeCompatible F) :
+    Function.FactorsThrough (cubeFamilyMap F)
+      (HigherHurewicz.CubeTriangulation.cubeCylinderCover n) := by
+  rintro ⟨e, r, s⟩ ⟨f, q, t⟩ h
+  have hr : r = q := congrArg Prod.fst h
+  have hs :
+    HigherHurewicz.CubeTriangulation.cubeSimplex e s =
+      HigherHurewicz.CubeTriangulation.cubeSimplex f t :=
+    congrArg Prod.snd h
+  subst q
+  exact hF e f s t hs r
+
+private def HigherHurewicz.CubeGluing.glueCubeHomotopies {n : ℕ} {X : Type} [TopologicalSpace X]
+    (F : Equiv.Perm (Fin n) → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (hF : CubeCompatible F) : C((unitInterval) × HigherHurewicz.CubeTriangulation.CubeN n, X) :=
+  (HigherHurewicz.CubeTriangulation.cubeCylinderCover_isQuotientMap n).lift (cubeFamilyMap F)
+    (cubeFamilyMap_factorsThrough F hF)
+
+@[simp]
+private theorem
+    HigherHurewicz.CubeGluing.glueCubeHomotopies_cell {n : ℕ} {X : Type} [TopologicalSpace X]
+    (F : Equiv.Perm (Fin n) → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (hF : CubeCompatible F) (e : Equiv.Perm (Fin n)) (r : (unitInterval))
+    (s : FirstHurewicz.Simplex n) :
+    glueCubeHomotopies F hF (r, HigherHurewicz.CubeTriangulation.cubeSimplex e s) = F e (r, s) :=
+  DFunLike.congr_fun
+    ((HigherHurewicz.CubeTriangulation.cubeCylinderCover_isQuotientMap n).lift_comp
+      (cubeFamilyMap F) (cubeFamilyMap_factorsThrough F hF))
+    ⟨e, (r, s)⟩
+
+private theorem
+    HigherHurewicz.CubeGluing.glueCubeHomotopies_time {n : ℕ} {X : Type} [TopologicalSpace X]
+    (F : Equiv.Perm (Fin n) → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (hF : CubeCompatible F) (r : (unitInterval))
+    (g : HigherHurewicz.CubeTriangulation.CubeN n → X)
+    (h :
+      ∀ (e : Equiv.Perm (Fin n)) (s : FirstHurewicz.Simplex n),
+        F e (r, s) = g (HigherHurewicz.CubeTriangulation.cubeSimplex e s))
+    (u : HigherHurewicz.CubeTriangulation.CubeN n) : glueCubeHomotopies F hF (r, u) = g u := by
+  obtain ⟨e, s, rfl⟩ := HigherHurewicz.CubeTriangulation.exists_cubeSimplex u
+  exact (glueCubeHomotopies_cell F hF e r s).trans (h e s)
+
+private theorem
+    HigherHurewicz.CubeGluing.glueCubeHomotopies_zero {n : ℕ} {X : Type} [TopologicalSpace X]
+    (F : Equiv.Perm (Fin n) → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (hF : CubeCompatible F) (g : C(HigherHurewicz.CubeTriangulation.CubeN n, X))
+    (h :
+      ∀ (e : Equiv.Perm (Fin n)) (s : FirstHurewicz.Simplex n),
+        F e (0, s) = g (HigherHurewicz.CubeTriangulation.cubeSimplex e s))
+    (u : HigherHurewicz.CubeTriangulation.CubeN n) : glueCubeHomotopies F hF (0, u) = g u :=
+  glueCubeHomotopies_time F hF 0 g h u
+
+private theorem HigherHurewicz.CubeTriangulation.cubeSimplex_mem_boundary_iff {n : ℕ}
+    (e : Equiv.Perm (Fin (n + 1))) (s : FirstHurewicz.Simplex (n + 1)) :
+    cubeSimplex e s ∈ Cube.boundary (Fin (n + 1)) ↔ s 0 = 0 ∨ s (Fin.last (n + 1)) = 0 := by
+  constructor
+  · rintro ⟨i, hi⟩
+    obtain ⟨j, rfl⟩ := e.surjective i
+    rcases hi with hi | hi
+    · right
+      have hlast : (cubeSimplex e s (e (Fin.last n)) : ℝ) ≤ (cubeSimplex e s (e j) : ℝ) :=
+        cubeSimplex_antitone e s (Fin.le_last j)
+      have hr := congrArg (fun t : (unitInterval) => (t : ℝ)) hi
+      change (cubeSimplex e s (e j) : ℝ) = 0 at hr
+      rw [cubeSimplex_coordinate_last, hr] at hlast
+      exact le_antisymm hlast (stdSimplex.zero_le s (Fin.last (n + 1)))
+    · left
+      have hfirst : (cubeSimplex e s (e j) : ℝ) ≤ (cubeSimplex e s (e 0) : ℝ) :=
+        cubeSimplex_antitone e s (Fin.zero_le j)
+      have hr := congrArg (fun t : (unitInterval) => (t : ℝ)) hi
+      change (cubeSimplex e s (e j) : ℝ) = 1 at hr
+      rw [cubeSimplex_coordinate_zero, hr] at hfirst
+      linarith [stdSimplex.zero_le s 0]
+  · rintro (hs | hs)
+    · refine ⟨e 0, Or.inr ?_⟩
+      apply Subtype.ext
+      change (cubeSimplex e s (e 0) : ℝ) = 1
+      rw [cubeSimplex_coordinate_zero, hs, sub_zero]
+    · refine ⟨e (Fin.last n), Or.inl ?_⟩
+      apply Subtype.ext
+      change (cubeSimplex e s (e (Fin.last n)) : ℝ) = 0
+      rw [cubeSimplex_coordinate_last, hs]
+
+private theorem
+    HigherHurewicz.CubeTriangulation.cubeSimplex_tie {n : ℕ} (e : Equiv.Perm (Fin (n + 1)))
+    (s : FirstHurewicz.Simplex (n + 1)) (i : Fin n)
+    (h : cubeSimplex e s (e i.castSucc) = cubeSimplex e s (e i.succ)) : s i.succ.castSucc = 0 := by
+  have hd := cubeSimplex_adjacent_difference e s i
+  rw [h, sub_self] at hd
+  exact hd.symm
+
+private theorem HigherHurewicz.CubeTriangulation.cubeSimplex_tie_iff {n : ℕ}
+    (e : Equiv.Perm (Fin (n + 1))) (s : FirstHurewicz.Simplex (n + 1)) (i : Fin n) :
+    cubeSimplex e s (e i.castSucc) = cubeSimplex e s (e i.succ) ↔ s i.succ.castSucc = 0 := by
+  refine ⟨cubeSimplex_tie e s i, ?_⟩
+  intro hs
+  apply Subtype.ext
+  have hd := cubeSimplex_adjacent_difference e s i
+  rw [hs] at hd
+  exact sub_eq_zero.mp hd
+
+private theorem
+    HigherHurewicz.CubeGluing.cubeOriginal_face_zero {n : ℕ} {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin (n + 1)) X x) (e : Equiv.Perm (Fin (n + 1))) :
+    (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e)).comp
+        (FirstHurewicz.simplexFace n 0) =
+      ContinuousMap.const (FirstHurewicz.Simplex n) x := by
+  ext s
+  exact GenLoop.boundary p _ (HigherHurewicz.CubeTriangulation.cubeSimplex_face_zero_boundary e s)
+
+private theorem
+    HigherHurewicz.CubeGluing.cubeOriginal_face_last {n : ℕ} {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin (n + 1)) X x) (e : Equiv.Perm (Fin (n + 1))) :
+    (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e)).comp
+        (FirstHurewicz.simplexFace n (Fin.last (n + 1))) =
+      ContinuousMap.const (FirstHurewicz.Simplex n) x := by
+  ext s
+  exact GenLoop.boundary p _ (HigherHurewicz.CubeTriangulation.cubeSimplex_face_last_boundary e s)
+
+private theorem
+    HigherHurewicz.CubeGluing.cubeOriginal_face_swap {n : ℕ} {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin (n + 1)) X x) (e : Equiv.Perm (Fin (n + 1))) (i : Fin n) :
+    (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e)).comp
+        (FirstHurewicz.simplexFace n i.succ.castSucc) =
+      (p.val.comp
+            (HigherHurewicz.CubeTriangulation.cubeSimplex
+              ((Equiv.swap i.castSucc i.succ).trans e))).comp
+        (FirstHurewicz.simplexFace n i.succ.castSucc) := by
+  simpa only [ContinuousMap.comp_assoc] using
+    congrArg
+      (fun f : C(FirstHurewicz.Simplex n, HigherHurewicz.CubeTriangulation.CubeN (n + 1)) =>
+        p.val.comp f)
+      (HigherHurewicz.CubeTriangulation.cubeSimplex_face_swap e i)
+
+private theorem
+    HigherHurewicz.CubeGluing.coherentCubeCell_face {n : ℕ} {X : Type} [TopologicalSpace X]
+    {x : X} (H₀ : C(FirstHurewicz.Simplex n, X) → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H₁ :
+      C(FirstHurewicz.Simplex (n + 1), X) → C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H₀ H₁)
+    (p : GenLoop (Fin (n + 1)) X x) (e : Equiv.Perm (Fin (n + 1))) (i : Fin (n + 2))
+    (r : (unitInterval)) (s : FirstHurewicz.Simplex n) :
+    H₁ (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e))
+        (r, FirstHurewicz.simplexFace n i s) =
+      H₀
+        ((p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e)).comp
+          (FirstHurewicz.simplexFace n i))
+        (r, s) :=
+  DFunLike.congr_fun (hface (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e)) i)
+    (r, s)
+
+private theorem
+    HigherHurewicz.CubeGluing.coherentCubeCell_swap {n : ℕ} {X : Type} [TopologicalSpace X]
+    {x : X} (H₀ : C(FirstHurewicz.Simplex n, X) → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H₁ :
+      C(FirstHurewicz.Simplex (n + 1), X) → C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H₀ H₁)
+    (p : GenLoop (Fin (n + 1)) X x) (e : Equiv.Perm (Fin (n + 1))) (i : Fin n)
+    (r : (unitInterval)) (s : FirstHurewicz.Simplex (n + 1)) (hs : s i.succ.castSucc = 0) :
+    H₁ (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e)) (r, s) =
+      H₁
+        (p.val.comp
+          (HigherHurewicz.CubeTriangulation.cubeSimplex ((Equiv.swap i.castSucc i.succ).trans e)))
+        (r, s) := by
+  let t := SecondHurewicz.SimplyConnected.simplexFaceInverse n i.succ.castSucc ⟨s, hs⟩
+  have ht : FirstHurewicz.simplexFace n i.succ.castSucc t = s :=
+    SecondHurewicz.SimplyConnected.simplexFace_inverse n i.succ.castSucc ⟨s, hs⟩
+  rw [← ht, coherentCubeCell_face H₀ H₁ hface, coherentCubeCell_face H₀ H₁ hface,
+    cubeOriginal_face_swap]
+
+private theorem HigherHurewicz.CubeGluing.coherentCubeCell_boundary {n : ℕ} {X : Type}
+    [TopologicalSpace X] {x : X}
+    (H₀ : C(FirstHurewicz.Simplex n, X) → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H₁ :
+      C(FirstHurewicz.Simplex (n + 1), X) → C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H₀ H₁)
+    (hconst :
+      H₀ (ContinuousMap.const (FirstHurewicz.Simplex n) x) =
+        ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex n) x)
+    (p : GenLoop (Fin (n + 1)) X x) (e : Equiv.Perm (Fin (n + 1))) (r : (unitInterval))
+    (s : FirstHurewicz.Simplex (n + 1))
+    (hs : HigherHurewicz.CubeTriangulation.cubeSimplex e s ∈ Cube.boundary (Fin (n + 1))) :
+    H₁ (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e)) (r, s) = x := by
+  rcases (HigherHurewicz.CubeTriangulation.cubeSimplex_mem_boundary_iff e s).mp hs with hs | hs
+  · let t := SecondHurewicz.SimplyConnected.simplexFaceInverse n 0 ⟨s, hs⟩
+    have ht : FirstHurewicz.simplexFace n 0 t = s :=
+      SecondHurewicz.SimplyConnected.simplexFace_inverse n 0 ⟨s, hs⟩
+    rw [← ht, coherentCubeCell_face H₀ H₁ hface, cubeOriginal_face_zero, hconst]
+    rfl
+  · let t := SecondHurewicz.SimplyConnected.simplexFaceInverse n (Fin.last (n + 1)) ⟨s, hs⟩
+    have ht : FirstHurewicz.simplexFace n (Fin.last (n + 1)) t = s :=
+      SecondHurewicz.SimplyConnected.simplexFace_inverse n (Fin.last (n + 1)) ⟨s, hs⟩
+    rw [← ht, coherentCubeCell_face H₀ H₁ hface, cubeOriginal_face_last, hconst]
+    rfl
+
+private theorem HigherHurewicz.CubeTriangulation.cubeSimplex_eq_of_sorted {n : ℕ}
+    (e f : Equiv.Perm (Fin n)) (s : FirstHurewicz.Simplex n)
+    (hf : SortedCoordinates (cubeSimplex e s) f) : cubeSimplex f s = cubeSimplex e s := by
+  funext k
+  obtain ⟨i, rfl⟩ := f.surjective k
+  apply Subtype.ext
+  calc
+    (cubeSimplex f s (f i) : ℝ) = ∑ k : Fin (n + 1), if i.val < k.val then s k else 0 :=
+      cubeSimplex_coordinate f s i
+    _ = (cubeSimplex e s (e i) : ℝ) := (cubeSimplex_coordinate e s i).symm
+    _ = (cubeSimplex e s (f i) : ℝ) :=
+      congrArg Subtype.val (sorted_values_eq (cubeSimplex e s) (cubeSimplex_sorted e s) hf i)
+
+private theorem HigherHurewicz.CubeTriangulation.cubeSimplex_overlap_preimage {n : ℕ}
+    (e f : Equiv.Perm (Fin n)) (s t : FirstHurewicz.Simplex n)
+    (h : cubeSimplex e s = cubeSimplex f t) : s = t := by
+  have hf : SortedCoordinates (cubeSimplex e s) f := by
+    rw [h]
+    exact cubeSimplex_sorted f t
+  exact cubeSimplex_injective f ((cubeSimplex_eq_of_sorted e f s hf).trans h)
+
+private theorem HigherHurewicz.CubeTriangulation.coordinate_swap_of_tie {n : ℕ} {α : Type*}
+    {u : Fin n → α} {e : Equiv.Perm (Fin n)} {a b : Fin n} (hab : u (e a) = u (e b)) (i : Fin n) :
+    u (((Equiv.swap a b).trans e) i) = u (e i) :=
+  Equiv.apply_swap_eq_self (v := fun j => u (e j)) hab i
+
+private theorem HigherHurewicz.CubeTriangulation.sortedCoordinates_swap_of_tie {n : ℕ} {α : Type*}
+    [LinearOrder α] {u : Fin n → α} {e : Equiv.Perm (Fin n)} (he : SortedCoordinates u e)
+    {a b : Fin n} (hab : u (e a) = u (e b)) : SortedCoordinates u ((Equiv.swap a b).trans e) := by
+  intro i j hij
+  simpa only [coordinate_swap_of_tie hab] using he hij
+
+private theorem HigherHurewicz.CubeTriangulation.swap_trans_swap_trans_swap_mo1973_8327 {n : ℕ}
+    {a b c : Fin n} (hab : a ≠ b) (hac : a ≠ c) :
+    ((Equiv.swap b c).trans (Equiv.swap a b)).trans (Equiv.swap b c) = Equiv.swap a c := by
+  simpa only [Equiv.symm_swap, Equiv.swap_apply_of_ne_of_ne hab hac, Equiv.swap_apply_left] using
+    Equiv.symm_trans_swap_trans a b (Equiv.swap b c)
+
+private theorem HigherHurewicz.CubeTriangulation.eq_swap_of_sorted_tie_of_lt_mo1973_8328 {n : ℕ}
+    {α : Type*} [LinearOrder α] (u : Fin (n + 1) → α) {A : Type*}
+    (F : Equiv.Perm (Fin (n + 1)) → A)
+    (hswap :
+      ∀ e,
+        SortedCoordinates u e →
+          ∀ i : Fin n,
+            u (e i.castSucc) = u (e i.succ) → F e = F ((Equiv.swap i.castSucc i.succ).trans e))
+    (b : Fin (n + 1)) :
+    ∀ (a : Fin (n + 1)) (e : Equiv.Perm (Fin (n + 1))),
+      a < b → SortedCoordinates u e → u (e a) = u (e b) → F e = F ((Equiv.swap a b).trans e) := by
+  induction b using Fin.induction with
+  | zero =>
+    intro a e hab
+    exact (Fin.not_lt_zero a hab).elim
+  | succ b ih =>
+    intro a e hab he ht
+    obtain rfl | hlt := (Fin.le_castSucc_iff.mpr hab).eq_or_lt
+    · exact hswap e he b ht
+    have hmid : u (e b.castSucc) = u (e b.succ) :=
+      le_antisymm ((he hlt.le).trans ht.le) (he Fin.castSucc_lt_succ.le)
+    have hleft : u (e a) = u (e b.castSucc) := ht.trans hmid.symm
+    let e₁ := (Equiv.swap b.castSucc b.succ).trans e
+    have h₁ : SortedCoordinates u e₁ := sortedCoordinates_swap_of_tie he hmid
+    have hv₁ (i : Fin (n + 1)) : u (e₁ i) = u (e i) := coordinate_swap_of_tie hmid i
+    have ht₁ : u (e₁ a) = u (e₁ b.castSucc) := by
+      rw [hv₁, hv₁]
+      exact hleft
+    let e₂ := (Equiv.swap a b.castSucc).trans e₁
+    have h₂ : SortedCoordinates u e₂ := sortedCoordinates_swap_of_tie h₁ ht₁
+    have hv₂ (i : Fin (n + 1)) : u (e₂ i) = u (e₁ i) := coordinate_swap_of_tie ht₁ i
+    have ht₂ : u (e₂ b.castSucc) = u (e₂ b.succ) := by
+      rw [hv₂, hv₂, hv₁, hv₁]
+      exact hmid
+    calc
+      F e = F e₁ := hswap e he b hmid
+      _ = F e₂ := (ih a e₁ hlt h₁ ht₁)
+      _ = F ((Equiv.swap b.castSucc b.succ).trans e₂) := (hswap e₂ h₂ b ht₂)
+      _ = F ((Equiv.swap a b.succ).trans e) := by
+        apply congrArg F
+        dsimp only [e₂, e₁]
+        rw [← Equiv.trans_assoc, ← Equiv.trans_assoc,
+          swap_trans_swap_trans_swap_mo1973_8327 hlt.ne hab.ne]
+
+private theorem
+    HigherHurewicz.CubeTriangulation.eq_swap_of_sorted_tie {n : ℕ} {α : Type*} [LinearOrder α]
+    (u : Fin (n + 1) → α) {A : Type*} (F : Equiv.Perm (Fin (n + 1)) → A)
+    (hswap :
+      ∀ e,
+        SortedCoordinates u e →
+          ∀ i : Fin n,
+            u (e i.castSucc) = u (e i.succ) → F e = F ((Equiv.swap i.castSucc i.succ).trans e))
+    {e : Equiv.Perm (Fin (n + 1))} (he : SortedCoordinates u e) (a b : Fin (n + 1))
+    (hab : u (e a) = u (e b)) : F e = F ((Equiv.swap a b).trans e) := by
+  rcases lt_trichotomy a b with hlt | rfl | hgt
+  · exact eq_swap_of_sorted_tie_of_lt_mo1973_8328 u F hswap b a e hlt he hab
+  · simp
+  · simpa only [Equiv.swap_comm b a] using
+      eq_swap_of_sorted_tie_of_lt_mo1973_8328 u F hswap a b e hgt he hab.symm
+
+private theorem HigherHurewicz.CubeTriangulation.label_swap_apply_mo1973_8330 {ι β : Type*}
+    [DecidableEq ι] (v : ι → β) {a b : ι} (hab : v a = v b) (z : ι) :
+    v (Equiv.swap a b z) = v z := by
+  by_cases hza : z = a
+  · subst z
+    simpa only [Equiv.swap_apply_left] using hab.symm
+  by_cases hzb : z = b
+  · subst z
+    simpa only [Equiv.swap_apply_right] using hab
+  rw [Equiv.swap_apply_of_ne_of_ne hza hzb]
+
+private theorem HigherHurewicz.CubeTriangulation.valuePreservingPermutation_induction {ι β : Type*}
+    [DecidableEq ι] [Finite ι] (v : ι → β) {P : Equiv.Perm ι → Prop} (hone : P 1)
+    (hswap :
+      ∀ (r : Equiv.Perm ι) (a b : ι),
+        v a = v b → (∀ i, v (r i) = v i) → P r → P (Equiv.swap a b * r))
+    (r : Equiv.Perm ι) (hr : ∀ i, v (r i) = v i) : P r := by
+  classical
+  let _ := Fintype.ofFinite ι
+  suffices h : ∀ k : ℕ, ∀ q : Equiv.Perm ι, q.support.card = k → (∀ i, v (q i) = v i) → P q from
+    h _ r rfl hr
+  intro k
+  induction k using Nat.strong_induction_on with
+  | h k ih =>
+    intro q hq hvalues
+    by_cases hqone : q = 1
+    · simpa only [hqone] using hone
+    have hmoved : ∃ a, q a ≠ a := by
+      by_contra! hn
+      exact hqone (Equiv.ext hn)
+    obtain ⟨a, ha⟩ := hmoved
+    let q' := Equiv.swap a (q a) * q
+    have hlt : q'.support.card < k := by
+      rw [← hq]
+      exact Equiv.Perm.card_support_swap_mul ha
+    have hvalues' : ∀ i, v (q' i) = v i := by
+      intro i
+      change v (Equiv.swap a (q a) (q i)) = v i
+      exact (label_swap_apply_mo1973_8330 v (hvalues a).symm (q i)).trans (hvalues i)
+    have hstep :=
+      hswap q' a (q a) (hvalues a).symm hvalues' (ih q'.support.card hlt q' rfl hvalues')
+    simpa only [q', Equiv.swap_mul_self_mul] using hstep
+
+private theorem HigherHurewicz.CubeTriangulation.eq_of_value_preserving_swaps {ι β : Type*}
+    [DecidableEq ι] [Finite ι] (v : ι → β) {A : Type*} (G : Equiv.Perm ι → A)
+    (hswap :
+      ∀ (r : Equiv.Perm ι),
+        (∀ i, v (r i) = v i) → ∀ a b, v a = v b → G r = G (Equiv.swap a b * r))
+    (r : Equiv.Perm ι) (hr : ∀ i, v (r i) = v i) : G 1 = G r :=
+  valuePreservingPermutation_induction v (P := fun q => G 1 = G q) rfl
+    (fun q a b hab hq ih => ih.trans (hswap q hq a b hab)) r hr
+
+private theorem
+    HigherHurewicz.CubeTriangulation.eq_of_sorted_adjacent {n : ℕ} {α : Type*} [LinearOrder α]
+    (u : Fin (n + 1) → α) {A : Type*} (F : Equiv.Perm (Fin (n + 1)) → A)
+    (hswap :
+      ∀ e,
+        SortedCoordinates u e →
+          ∀ i : Fin n,
+            u (e i.castSucc) = u (e i.succ) → F e = F ((Equiv.swap i.castSucc i.succ).trans e))
+    {e f : Equiv.Perm (Fin (n + 1))} (he : SortedCoordinates u e) (hf : SortedCoordinates u f) :
+    F e = F f := by
+  have hr : ∀ i, u (e ((f.trans e.symm) i)) = u (e i) := by
+    intro i
+    simpa only [Equiv.trans_apply, Equiv.apply_symm_apply] using (sorted_values_eq u he hf i).symm
+  have hG : F ((1 : Equiv.Perm (Fin (n + 1))).trans e) = F ((f.trans e.symm).trans e) :=
+    eq_of_value_preserving_swaps (fun i => u (e i)) (fun r => F (r.trans e))
+      (by
+        intro r hvalues a b hab
+        have hsorted : SortedCoordinates u (r.trans e) := by
+          intro i j hij
+          change u (e (r j)) ≤ u (e (r i))
+          rw [hvalues, hvalues]
+          exact he hij
+        have ht : u ((r.trans e) (r.symm a)) = u ((r.trans e) (r.symm b)) := by
+          simpa only [Equiv.trans_apply, Equiv.apply_symm_apply] using hab
+        have hh := eq_swap_of_sorted_tie u F hswap hsorted (r.symm a) (r.symm b) ht
+        refine hh.trans (congrArg F ?_)
+        apply Equiv.ext
+        intro i
+        change e ((r * Equiv.swap (r.symm a) (r.symm b)) i) = e ((Equiv.swap a b * r) i)
+        exact
+          congrArg (fun q : Equiv.Perm (Fin (n + 1)) => e (q i))
+            (Equiv.swap_mul_eq_mul_swap r a b).symm)
+      (f.trans e.symm) hr
+  simpa only [Equiv.Perm.one_def, Equiv.refl_trans, Equiv.trans_assoc, Equiv.symm_trans_self,
+    Equiv.trans_refl] using hG
+
+private theorem HigherHurewicz.CubeGluing.coherentCubeFamily_compatible {n : ℕ} {X : Type}
+    [TopologicalSpace X] {x : X}
+    (H₀ : C(FirstHurewicz.Simplex n, X) → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H₁ :
+      C(FirstHurewicz.Simplex (n + 1), X) → C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H₀ H₁)
+    (p : GenLoop (Fin (n + 1)) X x) :
+    CubeCompatible (fun e => H₁ (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e))) := by
+  intro e f s t h r
+  have hst := HigherHurewicz.CubeTriangulation.cubeSimplex_overlap_preimage e f s t h
+  subst t
+  have hf :
+    HigherHurewicz.CubeTriangulation.SortedCoordinates
+      (HigherHurewicz.CubeTriangulation.cubeSimplex e s) f := by
+    rw [h]
+    exact HigherHurewicz.CubeTriangulation.cubeSimplex_sorted f s
+  apply
+    HigherHurewicz.CubeTriangulation.eq_of_sorted_adjacent
+      (HigherHurewicz.CubeTriangulation.cubeSimplex e s)
+      (fun g => H₁ (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex g)) (r, s)) ?_
+      (HigherHurewicz.CubeTriangulation.cubeSimplex_sorted e s) hf
+  intro g hg i ht
+  apply coherentCubeCell_swap H₀ H₁ hface p g i r s
+  apply HigherHurewicz.CubeTriangulation.cubeSimplex_tie g s i
+  simpa only [HigherHurewicz.CubeTriangulation.cubeSimplex_eq_of_sorted e g s hg] using ht
+
+private def
+    HigherHurewicz.CubeGluing.coherentCubeHomotopyMap {n : ℕ} {X : Type} [TopologicalSpace X]
+    {x : X} (H₀ : C(FirstHurewicz.Simplex n, X) → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H₁ :
+      C(FirstHurewicz.Simplex (n + 1), X) → C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H₀ H₁)
+    (p : GenLoop (Fin (n + 1)) X x) :
+    C((unitInterval) × HigherHurewicz.CubeTriangulation.CubeN (n + 1), X) :=
+  glueCubeHomotopies (fun e => H₁ (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e)))
+    (coherentCubeFamily_compatible H₀ H₁ hface p)
+
+@[simp]
+private theorem HigherHurewicz.CubeGluing.coherentCubeHomotopyMap_cell {n : ℕ} {X : Type}
+    [TopologicalSpace X] {x : X}
+    (H₀ : C(FirstHurewicz.Simplex n, X) → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H₁ :
+      C(FirstHurewicz.Simplex (n + 1), X) → C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H₀ H₁)
+    (p : GenLoop (Fin (n + 1)) X x) (e : Equiv.Perm (Fin (n + 1))) (r : (unitInterval))
+    (s : FirstHurewicz.Simplex (n + 1)) :
+    coherentCubeHomotopyMap H₀ H₁ hface p (r, HigherHurewicz.CubeTriangulation.cubeSimplex e s) =
+      H₁ (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e)) (r, s) :=
+  glueCubeHomotopies_cell _ _ e r s
+
+private theorem HigherHurewicz.CubeGluing.coherentCubeHomotopyMap_zero {n : ℕ} {X : Type}
+    [TopologicalSpace X] {x : X}
+    (H₀ : C(FirstHurewicz.Simplex n, X) → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H₁ :
+      C(FirstHurewicz.Simplex (n + 1), X) → C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H₀ H₁)
+    (hzero :
+      ∀ (smp : C(FirstHurewicz.Simplex (n + 1), X)) (s : FirstHurewicz.Simplex (n + 1)),
+        H₁ smp (0, s) = smp s)
+    (p : GenLoop (Fin (n + 1)) X x) (u : HigherHurewicz.CubeTriangulation.CubeN (n + 1)) :
+    coherentCubeHomotopyMap H₀ H₁ hface p (0, u) = p u :=
+  glueCubeHomotopies_zero _ _ p.val
+    (fun e s => hzero (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e)) s) u
+
+private theorem HigherHurewicz.CubeGluing.coherentCubeHomotopyMap_boundary {n : ℕ} {X : Type}
+    [TopologicalSpace X] {x : X}
+    (H₀ : C(FirstHurewicz.Simplex n, X) → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H₁ :
+      C(FirstHurewicz.Simplex (n + 1), X) → C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H₀ H₁)
+    (hconst :
+      H₀ (ContinuousMap.const (FirstHurewicz.Simplex n) x) =
+        ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex n) x)
+    (p : GenLoop (Fin (n + 1)) X x) (r : (unitInterval))
+    (u : HigherHurewicz.CubeTriangulation.CubeN (n + 1)) (hu : u ∈ Cube.boundary (Fin (n + 1))) :
+    coherentCubeHomotopyMap H₀ H₁ hface p (r, u) = x := by
+  obtain ⟨e, s, rfl⟩ := HigherHurewicz.CubeTriangulation.exists_cubeSimplex u
+  rw [coherentCubeHomotopyMap_cell]
+  exact coherentCubeCell_boundary H₀ H₁ hface hconst p e r s hu
+
+private def
+    HigherHurewicz.CubeGluing.coherentCubeEndpoint {n : ℕ} {X : Type} [TopologicalSpace X] {x : X}
+    (H₀ : C(FirstHurewicz.Simplex n, X) → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H₁ :
+      C(FirstHurewicz.Simplex (n + 1), X) → C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H₀ H₁)
+    (hconst :
+      H₀ (ContinuousMap.const (FirstHurewicz.Simplex n) x) =
+        ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex n) x)
+    (p : GenLoop (Fin (n + 1)) X x) : GenLoop (Fin (n + 1)) X x :=
+  ⟨SecondHurewicz.SimplyConnected.timeSlice (coherentCubeHomotopyMap H₀ H₁ hface p) 1, fun u hu =>
+    coherentCubeHomotopyMap_boundary H₀ H₁ hface hconst p 1 u hu⟩
+
+private theorem HigherHurewicz.CubeGluing.coherentCubeEndpoint_cell {n : ℕ} {X : Type}
+    [TopologicalSpace X] {x : X}
+    (H₀ : C(FirstHurewicz.Simplex n, X) → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H₁ :
+      C(FirstHurewicz.Simplex (n + 1), X) → C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H₀ H₁)
+    (hconst :
+      H₀ (ContinuousMap.const (FirstHurewicz.Simplex n) x) =
+        ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex n) x)
+    (p : GenLoop (Fin (n + 1)) X x) (e : Equiv.Perm (Fin (n + 1))) :
+    (coherentCubeEndpoint H₀ H₁ hface hconst p).val.comp
+        (HigherHurewicz.CubeTriangulation.cubeSimplex e) =
+      SecondHurewicz.SimplyConnected.timeSlice
+        (H₁ (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e))) 1 := by
+  ext s
+  exact coherentCubeHomotopyMap_cell H₀ H₁ hface p e 1 s
+
+private def
+    HigherHurewicz.CubeGluing.coherentCubeHomotopy {n : ℕ} {X : Type} [TopologicalSpace X] {x : X}
+    (H₀ : C(FirstHurewicz.Simplex n, X) → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H₁ :
+      C(FirstHurewicz.Simplex (n + 1), X) → C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H₀ H₁)
+    (hconst :
+      H₀ (ContinuousMap.const (FirstHurewicz.Simplex n) x) =
+        ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex n) x)
+    (hzero :
+      ∀ (smp : C(FirstHurewicz.Simplex (n + 1), X)) (s : FirstHurewicz.Simplex (n + 1)),
+        H₁ smp (0, s) = smp s)
+    (p : GenLoop (Fin (n + 1)) X x) :
+    p.val.HomotopyRel (coherentCubeEndpoint H₀ H₁ hface hconst p).val
+      (Cube.boundary (Fin (n + 1)))
+    where
+  toHomotopy :=
+    { toContinuousMap := coherentCubeHomotopyMap H₀ H₁ hface p
+      map_zero_left := coherentCubeHomotopyMap_zero H₀ H₁ hface hzero p
+      map_one_left _ := rfl }
+  prop' r u
+    hu :=
+    (coherentCubeHomotopyMap_boundary H₀ H₁ hface hconst p r u hu).trans
+      (GenLoop.boundary p u hu).symm
+
+private theorem
+    HigherHurewicz.simplex_coordinate_zero_of_tail_eq {n : ℕ} (s : FirstHurewicz.Simplex n)
+    {i j : Fin n} (hij : i < j)
+    (h :
+      (∑ k : Fin (n + 1), if i.val < k.val then s k else 0) =
+        ∑ k : Fin (n + 1), if j.val < k.val then s k else 0) :
+    s i.succ = 0 := by
+  classical
+  let A := Finset.univ.filter (fun k : Fin (n + 1) => i.val < k.val)
+  let B := Finset.univ.filter (fun k : Fin (n + 1) => j.val < k.val)
+  have hAB : (∑ k ∈ A, s k) = ∑ k ∈ B, s k := by simpa only [A, B, Finset.sum_filter] using h
+  have hiB : i.succ ∉ B := by
+    simp only [B, Finset.mem_filter, Finset.mem_univ, true_and, Fin.val_succ, not_lt]
+    exact hij
+  have hsub : Insert.insert i.succ B ⊆ A := by
+    intro k hk
+    rcases Finset.mem_insert.mp hk with hk | hk
+    · subst k
+      simp [A]
+    · have hjk : j.val < k.val := (Finset.mem_filter.mp hk).2
+      exact Finset.mem_filter.mpr ⟨Finset.mem_univ _, lt_trans hij hjk⟩
+  have hle : s i.succ + ∑ k ∈ B, s k ≤ ∑ k ∈ A, s k := by
+    calc
+      s i.succ + ∑ k ∈ B, s k = ∑ k ∈ Insert.insert i.succ B, s k := (Finset.sum_insert hiB).symm
+      _ ≤ ∑ k ∈ A, s k :=
+        Finset.sum_le_sum_of_subset_of_nonneg hsub (fun k _ _ => stdSimplex.zero_le s k)
+  exact le_antisymm (by linarith) (stdSimplex.zero_le s i.succ)
+
+private theorem HigherHurewicz.cubeSimplex_ordered_coordinate_equality_boundary {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (s : FirstHurewicz.Simplex n) {i j : Fin n} (hij : i ≠ j)
+    (h : CubeTriangulation.cubeSimplex e s (e i) = CubeTriangulation.cubeSimplex e s (e j)) :
+    s ∈ SecondHurewicz.SimplyConnected.simplexBoundary n := by
+  have hreal := congrArg (fun t : (unitInterval) => (t : ℝ)) h
+  rw [CubeTriangulation.cubeSimplex_coordinate, CubeTriangulation.cubeSimplex_coordinate] at hreal
+  rcases lt_or_gt_of_ne hij with hlt | hgt
+  · exact ⟨i.succ, simplex_coordinate_zero_of_tail_eq s hlt hreal⟩
+  · exact ⟨j.succ, simplex_coordinate_zero_of_tail_eq s hgt hreal.symm⟩
+
+private theorem
+    HigherHurewicz.cubeSimplex_coordinate_equality_boundary {n : ℕ} (e : Equiv.Perm (Fin n))
+    (s : FirstHurewicz.Simplex n) {i j : Fin n} (hij : i ≠ j)
+    (h : CubeTriangulation.cubeSimplex e s i = CubeTriangulation.cubeSimplex e s j) :
+    s ∈ SecondHurewicz.SimplyConnected.simplexBoundary n := by
+  apply cubeSimplex_ordered_coordinate_equality_boundary e s (e.symm.injective.ne hij)
+  simpa only [Equiv.apply_symm_apply] using h
+
+private theorem
+    HigherHurewicz.coherentCubeEndpoint_cell_boundary {n : ℕ} {X : Type} [TopologicalSpace X]
+    {x : X}
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H H')
+    (hconst :
+      H (ContinuousMap.const (FirstHurewicz.Simplex n) x) =
+        ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex n) x)
+    (hone :
+      ∀ smp,
+        SecondHurewicz.SimplyConnected.timeSlice (H smp) 1 =
+          ContinuousMap.const (FirstHurewicz.Simplex n) x)
+    (p : GenLoop (Fin (n + 1)) X x) (e : Equiv.Perm (Fin (n + 1)))
+    (s : FirstHurewicz.Simplex (n + 1))
+    (hs : s ∈ SecondHurewicz.SimplyConnected.simplexBoundary (n + 1)) :
+    CubeGluing.coherentCubeEndpoint H H' hface hconst p (CubeTriangulation.cubeSimplex e s) = x :=
+  by
+  have he :=
+    congrArg (fun f : C(FirstHurewicz.Simplex (n + 1), X) => f s)
+      (CubeGluing.coherentCubeEndpoint_cell H H' hface hconst p e)
+  exact he.trans (simplexEndpoint_boundary H H' hface x hone _ s hs)
+
+private theorem
+    HigherHurewicz.coherentCubeEndpoint_internalBased {n : ℕ} {X : Type} [TopologicalSpace X]
+    {x : X}
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H H')
+    (hconst :
+      H (ContinuousMap.const (FirstHurewicz.Simplex n) x) =
+        ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex n) x)
+    (hone :
+      ∀ smp,
+        SecondHurewicz.SimplyConnected.timeSlice (H smp) 1 =
+          ContinuousMap.const (FirstHurewicz.Simplex n) x)
+    (p : GenLoop (Fin (n + 1)) X x) (u : Fin (n + 1) → (unitInterval)) (i j : Fin (n + 1))
+    (hij : i ≠ j) (hu : u i = u j) : CubeGluing.coherentCubeEndpoint H H' hface hconst p u = x := by
+  obtain ⟨e, s, rfl⟩ := CubeTriangulation.exists_cubeSimplex u
+  exact
+    coherentCubeEndpoint_cell_boundary H H' hface hconst hone p e s
+      (cubeSimplex_coordinate_equality_boundary e s hij hu)
+
+private def
+    FourthHurewicz.normalizedCube {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X] (x : X)
+    [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] (p : GenLoop (Fin 4) X x) :
+    GenLoop (Fin 4) X x :=
+  HigherHurewicz.CubeGluing.coherentCubeEndpoint (normalizationThreeSimplexHomotopy x)
+    (normalizationFourSimplexHomotopy x) (normalizationHomotopy_face x)
+    (normalizationThreeSimplexHomotopy_const x) p
+
+private theorem FourthHurewicz.normalizedCube_cell {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (p : GenLoop (Fin 4) X x) (e : Equiv.Perm (Fin 4)) :
+    (normalizedCube x p).val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e) =
+      (normalizedFourSimplex x
+          (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e))).val :=
+  HigherHurewicz.CubeGluing.coherentCubeEndpoint_cell (normalizationThreeSimplexHomotopy x)
+    (normalizationFourSimplexHomotopy x) (normalizationHomotopy_face x)
+    (normalizationThreeSimplexHomotopy_const x) p e
+
+private def FourthHurewicz.normalizationCubeHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (p : GenLoop (Fin 4) X x) :
+    p.val.HomotopyRel (normalizedCube x p).val (Cube.boundary (Fin 4)) :=
+  HigherHurewicz.CubeGluing.coherentCubeHomotopy (normalizationThreeSimplexHomotopy x)
+    (normalizationFourSimplexHomotopy x) (normalizationHomotopy_face x)
+    (normalizationThreeSimplexHomotopy_const x) (normalizationFourSimplexHomotopy_zero x) p
+
+private theorem FourthHurewicz.normalizedCube_internalBased {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (p : GenLoop (Fin 4) X x) (u : Fin 4 → (unitInterval)) (i j : Fin 4) (hij : i ≠ j)
+    (hu : u i = u j) : normalizedCube x p u = x :=
+  HigherHurewicz.coherentCubeEndpoint_internalBased (normalizationThreeSimplexHomotopy x)
+    (normalizationFourSimplexHomotopy x) (normalizationHomotopy_face x)
+    (normalizationThreeSimplexHomotopy_const x) (normalizationThreeSimplexHomotopy_endpoint x) p u
+    i j hij hu
+
+private theorem HigherHurewicz.CubeTriangulation.cubeSimplex_simplexBoundary {n : ℕ}
+    (e : Equiv.Perm (Fin (n + 1))) (s : FirstHurewicz.Simplex (n + 1))
+    (hs : s ∈ SecondHurewicz.SimplyConnected.simplexBoundary (n + 1)) :
+    cubeSimplex e s ∈ Cube.boundary (Fin (n + 1)) ∨
+      ∃ i j : Fin (n + 1), i ≠ j ∧ cubeSimplex e s i = cubeSimplex e s j := by
+  obtain ⟨k, hk⟩ := hs
+  cases k using Fin.cases with
+  | zero => exact Or.inl ((cubeSimplex_mem_boundary_iff e s).mpr (Or.inl hk))
+  | succ k =>
+    cases k using Fin.lastCases with
+    | last =>
+      apply Or.inl
+      apply (cubeSimplex_mem_boundary_iff e s).mpr
+      exact Or.inr (by simpa only [Fin.succ_last] using hk)
+    | cast i =>
+      apply Or.inr
+      refine ⟨e i.castSucc, e i.succ, ?_, ?_⟩
+      · intro h
+        have hval := congrArg Fin.val (e.injective h)
+        simp only [Fin.val_castSucc, Fin.val_succ] at hval
+        omega
+      · apply (cubeSimplex_tie_iff e s i).mpr
+        simpa only [Fin.castSucc_succ] using hk
+
+private def
+    HigherHurewicz.NativeSubdivision.nativeCubeSimplexQuotient {n : ℕ} (e : Equiv.Perm (Fin n)) :
+    C(NativeCube (Fin n), NativeCube (Fin n)) :=
+  (HigherHurewicz.CubeTriangulation.cubeSimplex e).comp
+    (HigherHurewicz.SimplexGeometry.simplexQuotient n)
+
+private theorem
+    HigherHurewicz.NativeSubdivision.nativeCubeSimplex_based {X : Type*} [TopologicalSpace X]
+    {x : X} {n : ℕ} (p : GenLoop (Fin n) X x) (hp : NativeCubeInternalBased p)
+    (e : Equiv.Perm (Fin n)) (s : FirstHurewicz.Simplex n)
+    (hs : s ∈ SecondHurewicz.SimplyConnected.simplexBoundary n) :
+    p (HigherHurewicz.CubeTriangulation.cubeSimplex e s) = x := by
+  cases n with
+  | zero =>
+    obtain ⟨i, hi⟩ := hs
+    have hi0 : i = 0 := Fin.ext (by omega)
+    subst i
+    have hsum : s 0 = 1 := by
+      simpa only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero] using stdSimplex.sum_eq_one s
+    exact False.elim (by linarith)
+  | succ
+    n =>
+    rcases HigherHurewicz.CubeTriangulation.cubeSimplex_simplexBoundary e s hs with h |
+      ⟨i, j, hij, h⟩
+    · exact p.property _ h
+    · exact hp _ i j hij h
+
+private def HigherHurewicz.NativeSubdivision.nativeBasedCubeSimplex {X : Type*} [TopologicalSpace X]
+    {x : X} {n : ℕ} (p : GenLoop (Fin n) X x) (hp : NativeCubeInternalBased p)
+    (e : Equiv.Perm (Fin n)) : HigherHurewicz.SimplexGeometry.BasedSimplex n x :=
+  ⟨p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e), nativeCubeSimplex_based p hp e⟩
+
+private theorem HigherHurewicz.NativeSubdivision.nativeCubeSimplexQuotient_based {X : Type*}
+    [TopologicalSpace X] {x : X} {n : ℕ} (p : GenLoop (Fin n) X x)
+    (hp : NativeCubeInternalBased p) (e : Equiv.Perm (Fin n)) (u : NativeCube (Fin n))
+    (hu : u ∈ Cube.boundary (Fin n)) : p (nativeCubeSimplexQuotient e u) = x :=
+  nativeCubeSimplex_based p hp e _ (HigherHurewicz.SimplexGeometry.simplexQuotient_boundary u hu)
+
+private theorem FourthHurewicz.normalizedCube_simplex {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (p : GenLoop (Fin 4) X x) (e : Equiv.Perm (Fin 4)) :
+    HigherHurewicz.NativeSubdivision.nativeBasedCubeSimplex (normalizedCube x p)
+        (normalizedCube_internalBased x p) e =
+      normalizedFourSimplex x (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e)) := by
+  apply Subtype.ext
+  exact normalizedCube_cell x p e
+
+private theorem
+    FourthHurewicz.fourSimplexClassOperator_cubeChain_sum {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (p : GenLoop (Fin 4) X x) :
+    fourSimplexClassOperator x (cubeChain p) =
+      ∑ e : Equiv.Perm (Fin 4),
+        HigherHurewicz.CubeTriangulation.cubeOrientation e •
+          basedFourSimplexClass
+            (normalizedFourSimplex x
+              (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e))) := by
+  rw [CubeSubdivision.cubeChain_eq_sum_simplices, map_sum]
+  apply Finset.sum_congr rfl
+  intro e _
+  rw [map_zsmul, fourSimplexClassOperator_simplex]
+
+private def HigherHurewicz.NativeSubdivision.insertPermutation {n : ℕ} (e : Equiv.Perm (Fin n))
+    (r : Fin (n + 1)) : Equiv.Perm (Fin (n + 1)) :=
+  (finSuccEquiv' r).trans (e.optionCongr.trans finSuccEquivLast.symm)
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.insertPermutation_apply_at {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (r : Fin (n + 1)) : insertPermutation e r r = Fin.last n := by
+  simp [insertPermutation]
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.insertPermutation_apply_succAbove {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (r : Fin (n + 1)) (j : Fin n) :
+    insertPermutation e r (r.succAbove j) = (e j).castSucc := by simp [insertPermutation]
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.insertPermutation_symm_last {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (r : Fin (n + 1)) : (insertPermutation e r).symm (Fin.last n) = r := by
+  apply (insertPermutation e r).injective
+  simp
+
+private theorem HigherHurewicz.NativeSubdivision.insertPermutation_pair_injective {n : ℕ} :
+    Function.Injective
+      (fun er : Equiv.Perm (Fin n) × Fin (n + 1) => insertPermutation er.1 er.2) := by
+  rintro ⟨e, r⟩ ⟨f, s⟩ h
+  have hrs : r = s := by
+    simpa using congrArg (fun E : Equiv.Perm (Fin (n + 1)) => E.symm (Fin.last n)) h
+  subst s
+  have hef : e = f := by
+    apply Equiv.ext
+    intro j
+    apply Fin.castSucc_injective n
+    simpa using congrArg (fun E : Equiv.Perm (Fin (n + 1)) => E (r.succAbove j)) h
+  exact congrArg (fun e : Equiv.Perm (Fin n) => (e, r)) hef
+
+private theorem HigherHurewicz.NativeSubdivision.optionCongr_removeNone_of_none {α β : Type*}
+    (e : Option α ≃ Option β) (h : e Option.none = Option.none) : e.removeNone.optionCongr = e := by
+  apply Equiv.ext
+  intro a
+  cases a with
+  | none => simpa using h.symm
+  | some a =>
+    change Option.some (e.removeNone a) = e (Option.some a)
+    cases ha : e (Option.some a) with
+    | none =>
+      have : Option.some a = Option.none := e.injective (ha.trans h.symm)
+      cases this
+    | some b => simpa only [ha] using e.removeNone_some ⟨b, ha⟩
+
+private def HigherHurewicz.NativeSubdivision.deletePermutationOption {n : ℕ}
+    (E : Equiv.Perm (Fin (n + 1))) : Equiv.Perm (Option (Fin n)) :=
+  (finSuccEquiv' (E.symm (Fin.last n))).symm.trans (E.trans finSuccEquivLast)
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.deletePermutationOption_none {n : ℕ}
+    (E : Equiv.Perm (Fin (n + 1))) : deletePermutationOption E Option.none = Option.none := by
+  simp [deletePermutationOption]
+
+private def
+    HigherHurewicz.NativeSubdivision.deletePermutation {n : ℕ} (E : Equiv.Perm (Fin (n + 1))) :
+    Equiv.Perm (Fin n) :=
+  (deletePermutationOption E).removeNone
+
+private theorem HigherHurewicz.NativeSubdivision.deletePermutation_castSucc {n : ℕ}
+    (E : Equiv.Perm (Fin (n + 1))) (j : Fin n) :
+    (deletePermutation E j).castSucc = E ((E.symm (Fin.last n)).succAbove j) := by
+  have h :=
+    congrArg (fun e : Equiv.Perm (Option (Fin n)) => e (Option.some j))
+      (optionCongr_removeNone_of_none (deletePermutationOption E)
+        (deletePermutationOption_none E))
+  have h' := congrArg finSuccEquivLast.symm h
+  simpa only [deletePermutation, Equiv.optionCongr_apply, Option.map_some,
+    finSuccEquivLast_symm_some, deletePermutationOption, Equiv.trans_apply,
+    finSuccEquiv'_symm_some, Equiv.symm_apply_apply] using h'
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.insertPermutation_deletePermutation {n : ℕ}
+    (E : Equiv.Perm (Fin (n + 1))) :
+    insertPermutation (deletePermutation E) (E.symm (Fin.last n)) = E := by
+  ext i
+  refine Fin.succAboveCases (E.symm (Fin.last n)) ?_ (fun j => ?_) i
+  · simp
+  · rw [insertPermutation_apply_succAbove, deletePermutation_castSucc]
+
+private def HigherHurewicz.NativeSubdivision.insertPermutationEquiv (n : ℕ) :
+    (Equiv.Perm (Fin n) × Fin (n + 1)) ≃ Equiv.Perm (Fin (n + 1))
+    where
+  toFun er := insertPermutation er.1 er.2
+  invFun E := (deletePermutation E, E.symm (Fin.last n))
+  left_inv
+    er :=
+    insertPermutation_pair_injective
+      (insertPermutation_deletePermutation (insertPermutation er.1 er.2))
+  right_inv := insertPermutation_deletePermutation
+
+private theorem HigherHurewicz.NativeSubdivision.sum_insertPermutation {n : ℕ} {A : Type*}
+    [AddCommMonoid A] (F : Equiv.Perm (Fin (n + 1)) → A) :
+    ∑ E, F E = ∑ e : Equiv.Perm (Fin n), ∑ r : Fin (n + 1), F (insertPermutation e r) := by
+  rw [← (insertPermutationEquiv n).sum_comp F, Fintype.sum_prod_type]
+  rfl
+
+private structure HigherHurewicz.NativeSubdivision.NativeChamberChart {n : ℕ}
+    (e : Equiv.Perm (Fin n)) where
+  toContinuousMap : C(NativeCube (Fin n), NativeCube (Fin n))
+  zero_last : ∀ u i, i.val + 1 = n → u (e i) = 0 → toContinuousMap u (e i) = 0
+  zero_adjacent :
+    ∀ u i j, i.val + 1 = j.val → u (e i) = 0 → toContinuousMap u (e i) = toContinuousMap u (e j)
+  one_first : ∀ u i, i.val = 0 → u (e i) = 1 → toContinuousMap u (e i) = 1
+  one_adjacent :
+    ∀ u i j, j.val + 1 = i.val → u (e i) = 1 → toContinuousMap u (e i) = toContinuousMap u (e j)
+
+private def HigherHurewicz.NativeSubdivision.chamberLower {n : ℕ} (e : Equiv.Perm (Fin n))
+    (r : Fin (n + 1)) (chart : NativeChamberChart e) : C(NativeCube (Fin n), (unitInterval)) :=
+  if h : r.val < n then (ContinuousMap.eval (e ⟨r.val, h⟩)).comp chart.toContinuousMap
+  else ContinuousMap.const _ 0
+
+private def HigherHurewicz.NativeSubdivision.chamberUpper {n : ℕ} (e : Equiv.Perm (Fin n))
+    (r : Fin (n + 1)) (chart : NativeChamberChart e) : C(NativeCube (Fin n), (unitInterval)) :=
+  if h : 0 < r.val then (ContinuousMap.eval (e ⟨r.val - 1, by omega⟩)).comp chart.toContinuousMap
+  else ContinuousMap.const _ 1
+
+private theorem
+    HigherHurewicz.NativeSubdivision.chamberLower_of_rank {n : ℕ} (e : Equiv.Perm (Fin n))
+    (r : Fin (n + 1)) (chart : NativeChamberChart e) (u : NativeCube (Fin n)) (k : Fin n)
+    (h : r.val = k.val) : chamberLower e r chart u = chart.toContinuousMap u (e k) := by
+  have hr : r.val < n := h ▸ k.isLt
+  have hk : (⟨r.val, hr⟩ : Fin n) = k := Fin.ext h
+  simp [chamberLower, hr, hk]
+
+private theorem HigherHurewicz.NativeSubdivision.chamberLower_last {n : ℕ} (e : Equiv.Perm (Fin n))
+    (r : Fin (n + 1)) (chart : NativeChamberChart e) (u : NativeCube (Fin n)) (h : r.val = n) :
+    chamberLower e r chart u = 0 := by simp [chamberLower, h]
+
+private theorem
+    HigherHurewicz.NativeSubdivision.chamberUpper_of_rank {n : ℕ} (e : Equiv.Perm (Fin n))
+    (r : Fin (n + 1)) (chart : NativeChamberChart e) (u : NativeCube (Fin n)) (k : Fin n)
+    (h : r.val = k.val + 1) : chamberUpper e r chart u = chart.toContinuousMap u (e k) := by
+  have hr : 0 < r.val := by omega
+  have hk : (⟨r.val - 1, by omega⟩ : Fin n) = k := Fin.ext (by dsimp; omega)
+  simp [chamberUpper, hr, hk]
+
+private theorem HigherHurewicz.NativeSubdivision.chamberUpper_first {n : ℕ} (e : Equiv.Perm (Fin n))
+    (r : Fin (n + 1)) (chart : NativeChamberChart e) (u : NativeCube (Fin n)) (h : r.val = 0) :
+    chamberUpper e r chart u = 1 := by simp [chamberUpper, h]
+
+private theorem
+    HigherHurewicz.NativeSubdivision.chamberLower_zero_face {n : ℕ} (e : Equiv.Perm (Fin n))
+    (r : Fin (n + 1)) (chart : NativeChamberChart e) (u : NativeCube (Fin n)) (k : Fin n)
+    (h : r.val = k.val + 1) (hu : u (e k) = 0) :
+    chamberLower e r chart u = chart.toContinuousMap u (e k) := by
+  by_cases hr : r.val < n
+  · let j : Fin n := ⟨r.val, hr⟩
+    rw [chamberLower_of_rank e r chart u j rfl]
+    exact (chart.zero_adjacent u k j (by simpa [j] using h.symm) hu).symm
+  · have hn : r.val = n := by omega
+    rw [chamberLower_last e r chart u hn]
+    exact (chart.zero_last u k (by omega) hu).symm
+
+private theorem
+    HigherHurewicz.NativeSubdivision.chamberUpper_one_face {n : ℕ} (e : Equiv.Perm (Fin n))
+    (r : Fin (n + 1)) (chart : NativeChamberChart e) (u : NativeCube (Fin n)) (k : Fin n)
+    (h : r.val = k.val) (hu : u (e k) = 1) :
+    chamberUpper e r chart u = chart.toContinuousMap u (e k) := by
+  by_cases hr : 0 < r.val
+  · let j : Fin n := ⟨r.val - 1, by omega⟩
+    rw [chamberUpper_of_rank e r chart u j (by dsimp [j]; omega)]
+    exact (chart.one_adjacent u k j (by dsimp [j]; omega) hu).symm
+  · have hz : r.val = 0 := by omega
+    rw [chamberUpper_first e r chart u hz]
+    exact (chart.one_first u k (by omega) hu).symm
+
+private def HigherHurewicz.NativeSubdivision.chamberOldCoordinates {n : ℕ} :
+    C(NativeCube (Fin (n + 1)), NativeCube (Fin n))
+    where
+  toFun u k := u k.castSucc
+  continuous_toFun := continuous_pi fun _ => continuous_apply _
+
+private def HigherHurewicz.NativeSubdivision.insertChamberMap {n : ℕ} (e : Equiv.Perm (Fin n))
+    (r : Fin (n + 1)) (chart : NativeChamberChart e) :
+    C(NativeCube (Fin (n + 1)), NativeCube (Fin (n + 1)))
+    where
+  toFun
+    u :=
+    Fin.lastCases
+      (Set.Icc.convexComb (chamberLower e r chart (chamberOldCoordinates u))
+        (chamberUpper e r chart (chamberOldCoordinates u)) (u (Fin.last n)))
+      (chart.toContinuousMap (chamberOldCoordinates u))
+  continuous_toFun := by
+    apply continuous_pi
+    intro k
+    refine Fin.lastCases ?_ (fun j => ?_) k
+    · simp only [Fin.lastCases_last]
+      exact
+        Set.Icc.continuous_convexComb_prod.comp
+          (((chamberLower e r chart).continuous.comp chamberOldCoordinates.continuous).prodMk
+            (((chamberUpper e r chart).continuous.comp chamberOldCoordinates.continuous).prodMk
+              (continuous_apply (Fin.last n))))
+    · simp only [Fin.lastCases_castSucc]
+      exact
+        (continuous_apply j).comp
+          (chart.toContinuousMap.continuous.comp chamberOldCoordinates.continuous)
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.insertChamberMap_apply_castSucc {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (r : Fin (n + 1)) (chart : NativeChamberChart e)
+    (u : NativeCube (Fin (n + 1))) (k : Fin n) :
+    insertChamberMap e r chart u k.castSucc = chart.toContinuousMap (chamberOldCoordinates u) k :=
+  by simp [insertChamberMap]
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.insertChamberMap_apply_last {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (r : Fin (n + 1)) (chart : NativeChamberChart e)
+    (u : NativeCube (Fin (n + 1))) :
+    insertChamberMap e r chart u (Fin.last n) =
+      Set.Icc.convexComb (chamberLower e r chart (chamberOldCoordinates u))
+        (chamberUpper e r chart (chamberOldCoordinates u)) (u (Fin.last n)) := by
+  simp [insertChamberMap]
+
+private theorem
+    HigherHurewicz.NativeSubdivision.chamberSuccAbove_val_cases {n : ℕ} (r : Fin (n + 1))
+    (i : Fin n) :
+    ((r.succAbove i).val = i.val ∧ i.val < r.val) ∨
+      ((r.succAbove i).val = i.val + 1 ∧ r.val ≤ i.val) := by
+  by_cases h : i.castSucc < r
+  · exact Or.inl ⟨congrArg Fin.val (Fin.succAbove_of_castSucc_lt r i h), h⟩
+  · exact
+      Or.inr
+        ⟨congrArg Fin.val (Fin.succAbove_of_le_castSucc r i (le_of_not_gt h)), le_of_not_gt h⟩
+
+private theorem HigherHurewicz.NativeSubdivision.chamberUpper_succ_eq_lower_castSucc {m : ℕ}
+    (e : Equiv.Perm (Fin m)) (chart : NativeChamberChart e) (j : Fin m) (u : NativeCube (Fin m)) :
+    chamberUpper e j.succ chart u = chamberLower e j.castSucc chart u := by
+  rw [chamberUpper_of_rank e j.succ chart u j rfl,
+    chamberLower_of_rank e j.castSucc chart u j rfl]
+
+private def HigherHurewicz.NativeSubdivision.chamberCutSequence {m : ℕ} (e : Equiv.Perm (Fin m))
+    (chart : NativeChamberChart e) : Fin (m + 2) → C(NativeCube (Fin m), (unitInterval)) :=
+  Fin.cons (ContinuousMap.const _ 0) (fun j : Fin (m + 1) => chamberUpper e j.rev chart)
+
+private theorem
+    HigherHurewicz.NativeSubdivision.chamberCutSequence_succ {m : ℕ} (e : Equiv.Perm (Fin m))
+    (chart : NativeChamberChart e) (j : Fin (m + 1)) (u : NativeCube (Fin m)) :
+    chamberCutSequence e chart j.succ u = chamberUpper e j.rev chart u := by
+  simp [chamberCutSequence]
+
+@[simp]
+private theorem
+    HigherHurewicz.NativeSubdivision.chamberCutSequence_last {m : ℕ} (e : Equiv.Perm (Fin m))
+    (chart : NativeChamberChart e) (u : NativeCube (Fin m)) :
+    chamberCutSequence e chart (Fin.last (m + 1)) u = 1 := by
+  change chamberUpper e (Fin.last m).rev chart u = 1
+  rw [Fin.rev_last]
+  exact chamberUpper_first e 0 chart u rfl
+
+private theorem HigherHurewicz.NativeSubdivision.chamberCutSequence_castSucc {m : ℕ}
+    (e : Equiv.Perm (Fin m)) (chart : NativeChamberChart e) (j : Fin (m + 1))
+    (u : NativeCube (Fin m)) :
+    chamberCutSequence e chart j.castSucc u = chamberLower e j.rev chart u := by
+  refine Fin.cases ?_ (fun k => ?_) j
+  · change 0 = chamberLower e (0 : Fin (m + 1)).rev chart u
+    rw [Fin.rev_zero]
+    exact (chamberLower_last e (Fin.last m) chart u rfl).symm
+  · change chamberUpper e k.castSucc.rev chart u = chamberLower e k.succ.rev chart u
+    rw [Fin.rev_castSucc, Fin.rev_succ]
+    exact chamberUpper_succ_eq_lower_castSucc e chart k.rev u
+
+private theorem
+    HigherHurewicz.NativeSubdivision.chamberCuts_sum_rev {m : ℕ} {A : Type*} [AddCommMonoid A]
+    (f : Fin (m + 1) → A) : ∑ j : Fin (m + 1), f j.rev = ∑ j : Fin (m + 1), f j :=
+  Equiv.sum_comp Fin.revPerm f
+
+private def HigherHurewicz.NativeSubdivision.cubeRestriction {m n : ℕ} (h : m ≤ n) :
+    C(NativeCube (Fin n), NativeCube (Fin m))
+    where
+  toFun u i := u (Fin.castLE h i)
+  continuous_toFun := continuous_pi fun i => continuous_apply (Fin.castLE h i)
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.cubeRestriction_apply {m n : ℕ} (h : m ≤ n)
+    (u : NativeCube (Fin n)) (i : Fin m) : cubeRestriction h u i = u (Fin.castLE h i) :=
+  rfl
+
+private def HigherHurewicz.NativeSubdivision.extendCubeMap {m n : ℕ} (h : m ≤ n)
+    (f : C(NativeCube (Fin m), NativeCube (Fin m))) : C(NativeCube (Fin n), NativeCube (Fin n))
+    where
+  toFun u i := if hi : i.val < m then f (cubeRestriction h u) ⟨i.val, hi⟩ else u i
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    by_cases hi : i.val < m
+    · simp only [dite_eq_left hi]
+      exact (continuous_apply ⟨i.val, hi⟩).comp (f.continuous.comp (cubeRestriction h).continuous)
+    · simpa only [dite_eq_right hi] using
+        (continuous_apply i : Continuous fun u : NativeCube (Fin n) => u i)
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.extendCubeMap_castLE {m n : ℕ} (h : m ≤ n)
+    (f : C(NativeCube (Fin m), NativeCube (Fin m))) (u : NativeCube (Fin n)) (i : Fin m) :
+    extendCubeMap h f u (Fin.castLE h i) = f (cubeRestriction h u) i := by simp [extendCubeMap]
+
+private theorem HigherHurewicz.NativeSubdivision.extendCubeMap_outside {m n : ℕ} (h : m ≤ n)
+    (f : C(NativeCube (Fin m), NativeCube (Fin m))) (u : NativeCube (Fin n)) (i : Fin n)
+    (hi : m ≤ i.val) : extendCubeMap h f u i = u i := by simp [extendCubeMap, Nat.not_lt.mpr hi]
+
+private theorem
+    HigherHurewicz.NativeSubdivision.cubeRestriction_update_outside {m n : ℕ} (h : m ≤ n)
+    (u : NativeCube (Fin n)) (i : Fin n) (hi : m ≤ i.val) (v : (unitInterval)) :
+    cubeRestriction h (Function.update u i v) = cubeRestriction h u := by
+  funext j
+  apply Function.update_of_ne
+  intro heq
+  have hv := congrArg Fin.val heq
+  exact (Nat.not_lt.mpr hi) (hv ▸ j.isLt)
+
+private theorem HigherHurewicz.NativeSubdivision.extendCubeMap_update_outside {m n : ℕ} (h : m ≤ n)
+    (f : C(NativeCube (Fin m), NativeCube (Fin m))) (u : NativeCube (Fin n)) (i : Fin n)
+    (hi : m ≤ i.val) (v : (unitInterval)) :
+    extendCubeMap h f (Function.update u i v) = Function.update (extendCubeMap h f u) i v := by
+  funext j
+  by_cases hj : j = i
+  · subst j
+    simp [extendCubeMap_outside h f _ i hi]
+  · rw [Function.update_of_ne hj]
+    by_cases hjm : j.val < m
+    · simp only [extendCubeMap, ContinuousMap.coe_mk, dite_eq_left hjm]
+      rw [cubeRestriction_update_outside h u i hi v]
+    · rw [extendCubeMap_outside h f _ j (Nat.le_of_not_gt hjm),
+        extendCubeMap_outside h f _ j (Nat.le_of_not_gt hjm), Function.update_of_ne hj]
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.extendCubeMap_refl {n : ℕ}
+    (f : C(NativeCube (Fin n), NativeCube (Fin n))) : extendCubeMap (le_refl n) f = f := by
+  ext u i
+  simp [cubeRestriction, extendCubeMap]
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.extendCubeMap_zero {n : ℕ} (h : 0 ≤ n)
+    (f : C(NativeCube (Fin 0), NativeCube (Fin 0))) : extendCubeMap h f = ContinuousMap.id _ := by
+  apply ContinuousMap.ext
+  intro u
+  funext i
+  exact extendCubeMap_outside h f u i (Nat.zero_le _)
+
+private theorem HigherHurewicz.NativeSubdivision.extendCubeMap_sameFlat {m n : ℕ} (h : m ≤ n)
+    (f g : C(NativeCube (Fin m), NativeCube (Fin m))) (u : NativeCube (Fin n))
+    (hfg : NativeCubeSameFlat (f (cubeRestriction h u)) (g (cubeRestriction h u))) :
+    NativeCubeSameFlat (extendCubeMap h f u) (extendCubeMap h g u) := by
+  cases hfg with
+  | zero i hf hg => exact .zero (Fin.castLE h i) (by simpa using hf) (by simpa using hg)
+  | one i hf hg => exact .one (Fin.castLE h i) (by simpa using hf) (by simpa using hg)
+  | equal i j hij hf hg =>
+    exact
+      .equal (Fin.castLE h i) (Fin.castLE h j)
+        (fun heq => hij (Fin.ext (congrArg (fun k : Fin n => k.val) heq))) (by simpa using hf)
+        (by simpa using hg)
+
+private theorem HigherHurewicz.NativeSubdivision.insertChamberMap_zero_last {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (r : Fin (n + 1)) (chart : NativeChamberChart e)
+    (u : NativeCube (Fin (n + 1))) (i : Fin (n + 1)) (hi : i.val + 1 = n + 1)
+    (hu : u (insertPermutation e r i) = 0) :
+    insertChamberMap e r chart u (insertPermutation e r i) = 0 := by
+  revert hi hu
+  refine Fin.succAboveCases r ?_ (fun k => ?_) i
+  · intro hi hu
+    simp only [insertPermutation_apply_at] at hu ⊢
+    rw [insertChamberMap_apply_last, hu, Set.Icc.convexComb_zero]
+    exact chamberLower_last e r chart (chamberOldCoordinates u) (by omega)
+  · intro hi hu
+    have hk := chamberSuccAbove_val_cases r k
+    simp only [insertPermutation_apply_succAbove, insertChamberMap_apply_castSucc] at hu ⊢
+    exact chart.zero_last (chamberOldCoordinates u) k (by omega) hu
+
+private theorem HigherHurewicz.NativeSubdivision.insertChamberMap_zero_adjacent {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (r : Fin (n + 1)) (chart : NativeChamberChart e)
+    (u : NativeCube (Fin (n + 1))) (i j : Fin (n + 1)) (hij : i.val + 1 = j.val)
+    (hu : u (insertPermutation e r i) = 0) :
+    insertChamberMap e r chart u (insertPermutation e r i) =
+      insertChamberMap e r chart u (insertPermutation e r j) := by
+  revert hij hu
+  refine Fin.succAboveCases r ?_ (fun k => ?_) i
+  · refine Fin.succAboveCases r ?_ (fun l => ?_) j
+    · intro hij
+      omega
+    · intro hij hu
+      have hl := chamberSuccAbove_val_cases r l
+      have hr : r.val = l.val := by omega
+      simp only [insertPermutation_apply_at, insertPermutation_apply_succAbove,
+        insertChamberMap_apply_last, insertChamberMap_apply_castSucc] at hu ⊢
+      rw [hu, Set.Icc.convexComb_zero]
+      exact chamberLower_of_rank e r chart (chamberOldCoordinates u) l hr
+  · refine Fin.succAboveCases r ?_ (fun l => ?_) j
+    · intro hij hu
+      have hk := chamberSuccAbove_val_cases r k
+      have hr : r.val = k.val + 1 := by omega
+      simp only [insertPermutation_apply_at, insertPermutation_apply_succAbove,
+        insertChamberMap_apply_last, insertChamberMap_apply_castSucc] at hu ⊢
+      rw [chamberLower_zero_face e r chart (chamberOldCoordinates u) k hr hu,
+        chamberUpper_of_rank e r chart (chamberOldCoordinates u) k hr]
+      simp
+    · intro hij hu
+      have hk := chamberSuccAbove_val_cases r k
+      have hl := chamberSuccAbove_val_cases r l
+      have hkl : k.val + 1 = l.val := by omega
+      simp only [insertPermutation_apply_succAbove, insertChamberMap_apply_castSucc] at hu ⊢
+      exact chart.zero_adjacent (chamberOldCoordinates u) k l hkl hu
+
+private theorem HigherHurewicz.NativeSubdivision.insertChamberMap_one_first {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (r : Fin (n + 1)) (chart : NativeChamberChart e)
+    (u : NativeCube (Fin (n + 1))) (i : Fin (n + 1)) (hi : i.val = 0)
+    (hu : u (insertPermutation e r i) = 1) :
+    insertChamberMap e r chart u (insertPermutation e r i) = 1 := by
+  revert hi hu
+  refine Fin.succAboveCases r ?_ (fun k => ?_) i
+  · intro hi hu
+    simp only [insertPermutation_apply_at] at hu ⊢
+    rw [insertChamberMap_apply_last, hu, Set.Icc.convexComb_one]
+    exact chamberUpper_first e r chart (chamberOldCoordinates u) hi
+  · intro hi hu
+    have hk := chamberSuccAbove_val_cases r k
+    simp only [insertPermutation_apply_succAbove, insertChamberMap_apply_castSucc] at hu ⊢
+    exact chart.one_first (chamberOldCoordinates u) k (by omega) hu
+
+private theorem HigherHurewicz.NativeSubdivision.insertChamberMap_one_adjacent {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (r : Fin (n + 1)) (chart : NativeChamberChart e)
+    (u : NativeCube (Fin (n + 1))) (i j : Fin (n + 1)) (hij : j.val + 1 = i.val)
+    (hu : u (insertPermutation e r i) = 1) :
+    insertChamberMap e r chart u (insertPermutation e r i) =
+      insertChamberMap e r chart u (insertPermutation e r j) := by
+  revert hij hu
+  refine Fin.succAboveCases r ?_ (fun k => ?_) i
+  · refine Fin.succAboveCases r ?_ (fun l => ?_) j
+    · intro hij
+      omega
+    · intro hij hu
+      have hl := chamberSuccAbove_val_cases r l
+      have hr : r.val = l.val + 1 := by omega
+      simp only [insertPermutation_apply_at, insertPermutation_apply_succAbove,
+        insertChamberMap_apply_last, insertChamberMap_apply_castSucc] at hu ⊢
+      rw [hu, Set.Icc.convexComb_one]
+      exact chamberUpper_of_rank e r chart (chamberOldCoordinates u) l hr
+  · refine Fin.succAboveCases r ?_ (fun l => ?_) j
+    · intro hij hu
+      have hk := chamberSuccAbove_val_cases r k
+      have hr : r.val = k.val := by omega
+      simp only [insertPermutation_apply_at, insertPermutation_apply_succAbove,
+        insertChamberMap_apply_last, insertChamberMap_apply_castSucc] at hu ⊢
+      rw [chamberLower_of_rank e r chart (chamberOldCoordinates u) k hr,
+        chamberUpper_one_face e r chart (chamberOldCoordinates u) k hr hu]
+      simp
+    · intro hij hu
+      have hk := chamberSuccAbove_val_cases r k
+      have hl := chamberSuccAbove_val_cases r l
+      have hkl : l.val + 1 = k.val := by omega
+      simp only [insertPermutation_apply_succAbove, insertChamberMap_apply_castSucc] at hu ⊢
+      exact chart.one_adjacent (chamberOldCoordinates u) k l hkl hu
+
+private def HigherHurewicz.NativeSubdivision.insertChamberChart {n : ℕ} (e : Equiv.Perm (Fin n))
+    (r : Fin (n + 1)) (chart : NativeChamberChart e) : NativeChamberChart (insertPermutation e r)
+    where
+  toContinuousMap := insertChamberMap e r chart
+  zero_last := insertChamberMap_zero_last e r chart
+  zero_adjacent := insertChamberMap_zero_adjacent e r chart
+  one_first := insertChamberMap_one_first e r chart
+  one_adjacent := insertChamberMap_one_adjacent e r chart
+
+@[ext]
+private theorem
+    HigherHurewicz.NativeSubdivision.NativeChamberChart.ext {n : ℕ} {e : Equiv.Perm (Fin n)}
+    {f g : HigherHurewicz.NativeSubdivision.NativeChamberChart e}
+    (h : f.toContinuousMap = g.toContinuousMap) : f = g := by
+  cases f
+  cases g
+  cases h
+  rfl
+
+private def HigherHurewicz.NativeSubdivision.chamberCutIndex {m n : ℕ} (h : m + 1 ≤ n) : Fin n :=
+  Fin.castLE h (Fin.last m)
+
+private theorem HigherHurewicz.NativeSubdivision.chamberCutIndex_ne_castLE {m n : ℕ} (h : m + 1 ≤ n)
+    (j : Fin m) : Fin.castLE (Nat.le_of_succ_le h) j ≠ chamberCutIndex h := by
+  intro he
+  have hv := congrArg Fin.val he
+  exact (Nat.ne_of_lt j.isLt) hv
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.chamberOldCoordinates_cubeRestriction {m n : ℕ}
+    (h : m + 1 ≤ n) (u : NativeCube (Fin n)) :
+    chamberOldCoordinates (cubeRestriction h u) = cubeRestriction (Nat.le_of_succ_le h) u :=
+  rfl
+
+private theorem HigherHurewicz.NativeSubdivision.extend_insertChamberMap {m n : ℕ} (h : m + 1 ≤ n)
+    (e : Equiv.Perm (Fin m)) (r : Fin (m + 1)) (chart : NativeChamberChart e)
+    (u : NativeCube (Fin n)) :
+    extendCubeMap h (insertChamberMap e r chart) u =
+      Function.update (extendCubeMap (Nat.le_of_succ_le h) chart.toContinuousMap u)
+        (chamberCutIndex h)
+        (Set.Icc.convexComb (chamberLower e r chart (cubeRestriction (Nat.le_of_succ_le h) u))
+          (chamberUpper e r chart (cubeRestriction (Nat.le_of_succ_le h) u))
+          (u (chamberCutIndex h))) := by
+  funext j
+  by_cases hjm : j.val < m
+  · let k : Fin m := ⟨j.val, hjm⟩
+    have hk : Fin.castLE h k.castSucc = j := Fin.ext rfl
+    have hk' : Fin.castLE h k.castSucc = Fin.castLE (Nat.le_of_succ_le h) k := Fin.ext rfl
+    have hji : j ≠ chamberCutIndex h := by
+      rw [← hk, hk']
+      exact chamberCutIndex_ne_castLE h k
+    rw [Function.update_of_ne hji, ← hk, extendCubeMap_castLE, insertChamberMap_apply_castSucc,
+      chamberOldCoordinates_cubeRestriction, hk', extendCubeMap_castLE]
+  · by_cases hji : j = chamberCutIndex h
+    · subst j
+      rw [Function.update_self]
+      change extendCubeMap h (insertChamberMap e r chart) u (Fin.castLE h (Fin.last m)) = _
+      rw [extendCubeMap_castLE, insertChamberMap_apply_last,
+        chamberOldCoordinates_cubeRestriction]
+      rfl
+    · have hjval : j.val ≠ m := fun he => hji (Fin.ext he)
+      have hmj : m + 1 ≤ j.val := by omega
+      rw [extendCubeMap_outside h _ u j hmj, Function.update_of_ne hji,
+        extendCubeMap_outside (Nat.le_of_succ_le h) _ u j (Nat.le_of_succ_le hmj)]
+
+private def HigherHurewicz.NativeSubdivision.extendedChamberCutSequence {m n : ℕ} (h : m + 1 ≤ n)
+    (e : Equiv.Perm (Fin m)) (chart : NativeChamberChart e) :
+    Fin (m + 2) → C(NativeCube (Fin n), (unitInterval)) := fun j =>
+  (chamberCutSequence e chart j).comp (cubeRestriction (Nat.le_of_succ_le h))
+
+@[simp]
+private theorem
+    HigherHurewicz.NativeSubdivision.extendedChamberCutSequence_zero {m n : ℕ} (h : m + 1 ≤ n)
+    (e : Equiv.Perm (Fin m)) (chart : NativeChamberChart e) (u : NativeCube (Fin n)) :
+    extendedChamberCutSequence h e chart 0 u = 0 :=
+  rfl
+
+@[simp]
+private theorem
+    HigherHurewicz.NativeSubdivision.extendedChamberCutSequence_last {m n : ℕ} (h : m + 1 ≤ n)
+    (e : Equiv.Perm (Fin m)) (chart : NativeChamberChart e) (u : NativeCube (Fin n)) :
+    extendedChamberCutSequence h e chart (Fin.last (m + 1)) u = 1 :=
+  chamberCutSequence_last e chart _
+
+private theorem HigherHurewicz.NativeSubdivision.extendedChamberCutSequence_castSucc {m n : ℕ}
+    (h : m + 1 ≤ n) (e : Equiv.Perm (Fin m)) (chart : NativeChamberChart e) (j : Fin (m + 1))
+    (u : NativeCube (Fin n)) :
+    extendedChamberCutSequence h e chart j.castSucc u =
+      chamberLower e j.rev chart (cubeRestriction (Nat.le_of_succ_le h) u) :=
+  chamberCutSequence_castSucc e chart j _
+
+private theorem
+    HigherHurewicz.NativeSubdivision.extendedChamberCutSequence_succ {m n : ℕ} (h : m + 1 ≤ n)
+    (e : Equiv.Perm (Fin m)) (chart : NativeChamberChart e) (j : Fin (m + 1))
+    (u : NativeCube (Fin n)) :
+    extendedChamberCutSequence h e chart j.succ u =
+      chamberUpper e j.rev chart (cubeRestriction (Nat.le_of_succ_le h) u) :=
+  chamberCutSequence_succ e chart j _
+
+private theorem HigherHurewicz.NativeSubdivision.NativeChamberChart.sameFlat {m : ℕ}
+    {e : Equiv.Perm (Fin m)} (chart other : HigherHurewicz.NativeSubdivision.NativeChamberChart e)
+    (u : HigherHurewicz.NativeSubdivision.NativeCube (Fin m)) (hu : u ∈ Cube.boundary (Fin m)) :
+    HigherHurewicz.NativeSubdivision.NativeCubeSameFlat (chart.toContinuousMap u)
+      (other.toContinuousMap u) := by
+  obtain ⟨j, hj⟩ := hu
+  let i := e.symm j
+  have hei : e i = j := e.apply_symm_apply j
+  rcases hj with hj | hj
+  · have hi : u (e i) = 0 := hei ▸ hj
+    by_cases hilast : i.val + 1 = m
+    · exact .zero (e i) (chart.zero_last u i hilast hi) (other.zero_last u i hilast hi)
+    · let k : Fin m := ⟨i.val + 1, by have := i.isLt; omega⟩
+      have hik : i.val + 1 = k.val := rfl
+      have hne : e i ≠ e k := by
+        intro h
+        have hv := congrArg Fin.val (e.injective h)
+        dsimp [k] at hv
+        omega
+      exact
+        .equal (e i) (e k) hne (chart.zero_adjacent u i k hik hi)
+          (other.zero_adjacent u i k hik hi)
+  · have hi : u (e i) = 1 := hei ▸ hj
+    by_cases hifirst : i.val = 0
+    · exact .one (e i) (chart.one_first u i hifirst hi) (other.one_first u i hifirst hi)
+    · let k : Fin m := ⟨i.val - 1, by have := i.isLt; omega⟩
+      have hki : k.val + 1 = i.val := by dsimp [k]; omega
+      have hne : e i ≠ e k := by
+        intro h
+        have hv := congrArg Fin.val (e.injective h)
+        dsimp [k] at hv
+        omega
+      exact
+        .equal (e i) (e k) hne (chart.one_adjacent u i k hki hi) (other.one_adjacent u i k hki hi)
+
+private theorem HigherHurewicz.NativeSubdivision.extendedChamberMap_sameFlat {m n : ℕ} (h : m ≤ n)
+    {e : Equiv.Perm (Fin m)} (chart other : NativeChamberChart e) (u : NativeCube (Fin n))
+    (hu : u ∈ Cube.boundary (Fin n)) :
+    NativeCubeSameFlat (extendCubeMap h chart.toContinuousMap u)
+      (extendCubeMap h other.toContinuousMap u) := by
+  obtain ⟨j, hj⟩ := hu
+  by_cases hjm : j.val < m
+  · let k : Fin m := ⟨j.val, hjm⟩
+    have hk : Fin.castLE h k = j := Fin.ext rfl
+    apply extendCubeMap_sameFlat
+    apply chart.sameFlat other
+    refine ⟨k, ?_⟩
+    simpa only [cubeRestriction_apply, hk] using hj
+  · rcases hj with hj | hj
+    · exact
+        .zero j ((extendCubeMap_outside h _ u j (Nat.le_of_not_gt hjm)).trans hj)
+          ((extendCubeMap_outside h _ u j (Nat.le_of_not_gt hjm)).trans hj)
+    · exact
+        .one j ((extendCubeMap_outside h _ u j (Nat.le_of_not_gt hjm)).trans hj)
+          ((extendCubeMap_outside h _ u j (Nat.le_of_not_gt hjm)).trans hj)
+
+private theorem HigherHurewicz.NativeSubdivision.extendedChamberMap_based {m n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin n) X x) (hp : NativeCubeInternalBased p)
+    (h : m ≤ n) {e : Equiv.Perm (Fin m)} (chart : NativeChamberChart e) (u : NativeCube (Fin n))
+    (hu : u ∈ Cube.boundary (Fin n)) : p (extendCubeMap h chart.toContinuousMap u) = x := by
+  simpa only [nativeCubeBlend_zero] using
+    nativeCubeBlend_based p hp (extendedChamberMap_sameFlat h chart chart u hu) 0
+
+private def HigherHurewicz.NativeSubdivision.extendedChamberLoop {m n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin n) X x) (hp : NativeCubeInternalBased p)
+    (h : m ≤ n) {e : Equiv.Perm (Fin m)} (chart : NativeChamberChart e) : GenLoop (Fin n) X x :=
+  nativeCubePullbackLoop p (extendCubeMap h chart.toContinuousMap)
+    (extendedChamberMap_based p hp h chart)
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.extendedChamberLoop_apply {m n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin n) X x) (hp : NativeCubeInternalBased p)
+    (h : m ≤ n) {e : Equiv.Perm (Fin m)} (chart : NativeChamberChart e) (u : NativeCube (Fin n)) :
+    extendedChamberLoop p hp h chart u = p (extendCubeMap h chart.toContinuousMap u) :=
+  rfl
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.extendedChamberLoop_zero {n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin n) X x) (hp : NativeCubeInternalBased p)
+    (h : 0 ≤ n) {e : Equiv.Perm (Fin 0)} (chart : NativeChamberChart e) :
+    extendedChamberLoop p hp h chart = p := by
+  apply GenLoop.ext
+  intro u
+  simp
+
+private def HigherHurewicz.NativeSubdivision.extendedChamberHomotopy {m n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin n) X x) (hp : NativeCubeInternalBased p)
+    (h : m ≤ n) {e : Equiv.Perm (Fin m)} (chart other : NativeChamberChart e) :
+    (extendedChamberLoop p hp h chart).val.HomotopyRel (extendedChamberLoop p hp h other).val
+      (Cube.boundary (Fin n)) :=
+  nativeCubeLinearHomotopy p hp (extendCubeMap h chart.toContinuousMap)
+    (extendCubeMap h other.toContinuousMap) (extendedChamberMap_based p hp h chart)
+    (extendedChamberMap_based p hp h other) (extendedChamberMap_sameFlat h chart other)
+
+private theorem
+    HigherHurewicz.NativeSubdivision.nativeClass_extendedChamber_eq {m n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin n) X x) (hp : NativeCubeInternalBased p)
+    (h : m ≤ n) {e : Equiv.Perm (Fin m)} (chart other : NativeChamberChart e) :
+    nativeClass (extendedChamberLoop p hp h chart) =
+      nativeClass (extendedChamberLoop p hp h other) :=
+  nativeClass_homotopic ⟨extendedChamberHomotopy p hp h chart other⟩
+
+private def HigherHurewicz.NativeSubdivision.CutIndependent {N : Type*} [DecidableEq N] (i : N)
+    (a : C(NativeCube N, (unitInterval))) : Prop :=
+  ∀ u v, a (Function.update u i v) = a u
+
+private def HigherHurewicz.NativeSubdivision.CutBased {N : Type*} [DecidableEq N] {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop N X x) (i : N)
+    (a : C(NativeCube N, (unitInterval))) : Prop :=
+  ∀ u, p (Function.update u i (a u)) = x
+
+private def HigherHurewicz.NativeSubdivision.sliceMap {N : Type*} [DecidableEq N] (i : N)
+    (a b : C(NativeCube N, (unitInterval))) : C(NativeCube N, NativeCube N)
+    where
+  toFun u := Function.update u i (Set.Icc.convexComb (a u) (b u) (u i))
+  continuous_toFun :=
+    continuous_id.update i
+      (Set.Icc.continuous_convexComb_prod.comp
+        (a.continuous.prodMk (b.continuous.prodMk (continuous_apply i))))
+
+private theorem
+    HigherHurewicz.NativeSubdivision.sliceMap_based {N : Type*} [DecidableEq N] {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop N X x) (i : N)
+    (a b : C(NativeCube N, (unitInterval))) (ha : CutBased p i a) (hb : CutBased p i b)
+    (u : NativeCube N) (hu : u ∈ Cube.boundary N) : p (sliceMap i a b u) = x := by
+  rcases hu with ⟨j, hj⟩
+  by_cases hji : j = i
+  · subst j
+    rcases hj with hj | hj
+    · simpa [sliceMap, hj] using ha u
+    · simpa [sliceMap, hj] using hb u
+  · exact p.property _ ⟨j, by simpa [sliceMap, hji] using hj⟩
+
+private def HigherHurewicz.NativeSubdivision.sliceLoop {N : Type*} [DecidableEq N] {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop N X x) (i : N)
+    (a b : C(NativeCube N, (unitInterval))) (ha : CutBased p i a) (hb : CutBased p i b) :
+    GenLoop N X x :=
+  ⟨p.val.comp (sliceMap i a b), sliceMap_based p i a b ha hb⟩
+
+@[simp]
+private theorem
+    HigherHurewicz.NativeSubdivision.sliceLoop_apply {N : Type*} [DecidableEq N] {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop N X x) (i : N)
+    (a b : C(NativeCube N, (unitInterval))) (ha : CutBased p i a) (hb : CutBased p i b)
+    (u : NativeCube N) :
+    sliceLoop p i a b ha hb u = p (Function.update u i (Set.Icc.convexComb (a u) (b u) (u i))) :=
+  rfl
+
+private theorem
+    HigherHurewicz.NativeSubdivision.sliceLoop_self {N : Type*} [DecidableEq N] {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop N X x) (i : N) (a : C(NativeCube N, (unitInterval)))
+    (ha : CutBased p i a) : sliceLoop p i a a ha ha = GenLoop.const := by
+  apply GenLoop.ext
+  intro u
+  simpa only [sliceLoop_apply, Set.Icc.convexComb_eq, GenLoop.const_apply] using ha u
+
+private theorem
+    HigherHurewicz.NativeSubdivision.sliceLoop_full {N : Type*} [DecidableEq N] {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop N X x) (i : N)
+    (a b : C(NativeCube N, (unitInterval))) (ha : CutBased p i a) (hb : CutBased p i b)
+    (ha0 : ∀ u, a u = 0) (hb1 : ∀ u, b u = 1) : sliceLoop p i a b ha hb = p := by
+  apply GenLoop.ext
+  intro u
+  simp [ha0 u, hb1 u]
+
+private def HigherHurewicz.NativeSubdivision.sliceHomotopyOfCoordinate {N : Type*} [DecidableEq N]
+    {X : Type*} [TopologicalSpace X] {x : X} (p : GenLoop N X x) (i : N)
+    (a b : C(NativeCube N, (unitInterval))) (ha : CutBased p i a) (hb : CutBased p i b)
+    (q : GenLoop N X x) (w : C(NativeCube N, (unitInterval)))
+    (hq : ∀ u, q u = p (Function.update u i (w u))) (hw0 : ∀ u, u i = 0 → w u = a u)
+    (hw1 : ∀ u, u i = 1 → w u = b u) :
+    (sliceLoop p i a b ha hb).val.HomotopyRel q.val (Cube.boundary N)
+    where
+  toFun
+    v :=
+    p
+      (Function.update v.2 i
+        (Set.Icc.convexComb (Set.Icc.convexComb (a v.2) (b v.2) (v.2 i)) (w v.2) v.1))
+  continuous_toFun :=
+    p.val.continuous.comp
+      (continuous_snd.update i
+        (Set.Icc.continuous_convexComb_prod.comp
+          ((Set.Icc.continuous_convexComb_prod.comp
+                ((a.continuous.comp continuous_snd).prodMk
+                  ((b.continuous.comp continuous_snd).prodMk
+                    ((continuous_apply i).comp continuous_snd)))).prodMk
+            ((w.continuous.comp continuous_snd).prodMk continuous_fst))))
+  map_zero_left
+    u := by
+    change
+      p
+          (Function.update u i
+            (Set.Icc.convexComb (Set.Icc.convexComb (a u) (b u) (u i)) (w u) 0)) =
+        _
+    rw [Set.Icc.convexComb_zero]
+    rfl
+  map_one_left
+    u := by
+    change
+      p
+          (Function.update u i
+            (Set.Icc.convexComb (Set.Icc.convexComb (a u) (b u) (u i)) (w u) 1)) =
+        q u
+    rw [Set.Icc.convexComb_one]
+    exact (hq u).symm
+  prop' t u
+    hu := by
+    change
+      p
+          (Function.update u i
+            (Set.Icc.convexComb (Set.Icc.convexComb (a u) (b u) (u i)) (w u) t)) =
+        sliceLoop p i a b ha hb u
+    have hs : sliceLoop p i a b ha hb u = x := (sliceLoop p i a b ha hb).property u hu
+    rw [hs]
+    rcases hu with ⟨j, hj⟩
+    by_cases hji : j = i
+    · subst j
+      rcases hj with hj | hj
+      · simpa [hj, hw0 u hj] using ha u
+      · simpa [hj, hw1 u hj] using hb u
+    · exact p.property _ ⟨j, by simpa [hji] using hj⟩
+
+private theorem HigherHurewicz.NativeSubdivision.extendedChamberCutSequence_independent {m n : ℕ}
+    (h : m + 1 ≤ n) (e : Equiv.Perm (Fin m)) (chart : NativeChamberChart e) (j : Fin (m + 2)) :
+    CutIndependent (chamberCutIndex h) (extendedChamberCutSequence h e chart j) := by
+  intro u v
+  change
+    chamberCutSequence e chart j
+        (cubeRestriction (Nat.le_of_succ_le h) (Function.update u (chamberCutIndex h) v)) =
+      chamberCutSequence e chart j (cubeRestriction (Nat.le_of_succ_le h) u)
+  rw [cubeRestriction_update_outside (Nat.le_of_succ_le h) u (chamberCutIndex h) (le_refl m) v]
+
+private theorem
+    HigherHurewicz.NativeSubdivision.extendedChamberCutSequence_based {m n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin n) X x) (hp : NativeCubeInternalBased p)
+    (h : m + 1 ≤ n) (e : Equiv.Perm (Fin m)) (chart : NativeChamberChart e) (j : Fin (m + 2)) :
+    CutBased (extendedChamberLoop p hp (Nat.le_of_succ_le h) chart) (chamberCutIndex h)
+      (extendedChamberCutSequence h e chart j) := by
+  intro u
+  rw [extendedChamberLoop_apply,
+    extendCubeMap_update_outside (Nat.le_of_succ_le h) chart.toContinuousMap u (chamberCutIndex h)
+      (le_refl m)]
+  refine Fin.cases ?_ (fun r => ?_) j
+  · rw [extendedChamberCutSequence_zero]
+    exact p.property _ ⟨chamberCutIndex h, Or.inl (Function.update_self _ _ _)⟩
+  · rw [extendedChamberCutSequence_succ]
+    by_cases hr : 0 < r.rev.val
+    · let k : Fin m := ⟨r.rev.val - 1, by have := r.rev.isLt; omega⟩
+      have hk : r.rev.val = k.val + 1 := by
+        change r.rev.val = (r.rev.val - 1) + 1
+        omega
+      rw [chamberUpper_of_rank e r.rev chart (cubeRestriction (Nat.le_of_succ_le h) u) k hk]
+      apply
+        hp _ (chamberCutIndex h) (Fin.castLE (Nat.le_of_succ_le h) (e k))
+          (chamberCutIndex_ne_castLE h (e k)).symm
+      rw [Function.update_self, Function.update_of_ne (chamberCutIndex_ne_castLE h (e k)),
+        extendCubeMap_castLE]
+    · have hr0 : r.rev.val = 0 := by omega
+      rw [chamberUpper_first e r.rev chart (cubeRestriction (Nat.le_of_succ_le h) u) hr0]
+      exact p.property _ ⟨chamberCutIndex h, Or.inr (Function.update_self _ _ _)⟩
+
+private def HigherHurewicz.NativeSubdivision.cutBinaryWarp :
+    C(((unitInterval) × (unitInterval) × (unitInterval)) × (unitInterval), (unitInterval))
+    where
+  toFun
+    p :=
+    Set.Icc.convexComb
+      (Set.Icc.convexComb p.1.1 p.1.2.1 (Set.projIcc 0 1 zero_le_one (2 * (p.2 : ℝ)))) p.1.2.2
+      (Set.projIcc 0 1 zero_le_one (2 * (p.2 : ℝ) - 1))
+  continuous_toFun := by
+    unfold Set.Icc.convexComb
+    fun_prop
+
+private theorem HigherHurewicz.NativeSubdivision.cutBinaryWarp_apply (a b c t : (unitInterval)) :
+    cutBinaryWarp ((a, b, c), t) =
+      Set.Icc.convexComb (Set.Icc.convexComb a b (Set.projIcc 0 1 zero_le_one (2 * (t : ℝ)))) c
+        (Set.projIcc 0 1 zero_le_one (2 * (t : ℝ) - 1)) :=
+  rfl
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.cutBinaryWarp_zero (a b c : (unitInterval)) :
+    cutBinaryWarp ((a, b, c), 0) = a := by
+  norm_num [cutBinaryWarp, Set.projIcc, Set.Icc.convexComb]
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.cutBinaryWarp_one (a b c : (unitInterval)) :
+    cutBinaryWarp ((a, b, c), 1) = c := by
+  norm_num [cutBinaryWarp, Set.projIcc, Set.Icc.convexComb]
+
+private theorem HigherHurewicz.NativeSubdivision.cutBinaryWarp_of_le_half (a b c t : (unitInterval))
+    (ht : (t : ℝ) ≤ 1 / 2) :
+    cutBinaryWarp ((a, b, c), t) =
+      Set.Icc.convexComb a b (Set.projIcc 0 1 zero_le_one (2 * (t : ℝ))) := by
+  have hz : Set.projIcc 0 1 zero_le_one (2 * (t : ℝ) - 1) = (0 : (unitInterval)) :=
+    Set.projIcc_of_le_left zero_le_one (by linarith)
+  rw [cutBinaryWarp_apply, hz, Set.Icc.convexComb_zero]
+
+private theorem HigherHurewicz.NativeSubdivision.cutBinaryWarp_of_half_le (a b c t : (unitInterval))
+    (ht : 1 / 2 ≤ (t : ℝ)) :
+    cutBinaryWarp ((a, b, c), t) =
+      Set.Icc.convexComb b c (Set.projIcc 0 1 zero_le_one (2 * (t : ℝ) - 1)) := by
+  have ho : Set.projIcc 0 1 zero_le_one (2 * (t : ℝ)) = (1 : (unitInterval)) :=
+    Set.projIcc_of_right_le zero_le_one (by linarith)
+  rw [cutBinaryWarp_apply, ho, Set.Icc.convexComb_one]
+
+private theorem HigherHurewicz.NativeSubdivision.cutBinaryWarp_of_half_lt (a b c t : (unitInterval))
+    (ht : 1 / 2 < (t : ℝ)) :
+    cutBinaryWarp ((a, b, c), t) =
+      Set.Icc.convexComb b c (Set.projIcc 0 1 zero_le_one (2 * (t : ℝ) - 1)) :=
+  cutBinaryWarp_of_half_le a b c t ht.le
+
+private def HigherHurewicz.NativeSubdivision.sliceBinaryCoordinate {N : Type*} (i : N)
+    (a b c : C(NativeCube N, (unitInterval))) : C(NativeCube N, (unitInterval))
+    where
+  toFun u := cutBinaryWarp ((a u, b u, c u), u i)
+  continuous_toFun :=
+    cutBinaryWarp.continuous.comp
+      ((a.continuous.prodMk (b.continuous.prodMk c.continuous)).prodMk (continuous_apply i))
+
+private theorem HigherHurewicz.NativeSubdivision.sliceBinaryCoordinate_zero {N : Type*} (i : N)
+    (a b c : C(NativeCube N, (unitInterval))) (u : NativeCube N) (hu : u i = 0) :
+    sliceBinaryCoordinate i a b c u = a u := by simp [sliceBinaryCoordinate, hu]
+
+private theorem HigherHurewicz.NativeSubdivision.sliceBinaryCoordinate_one {N : Type*} (i : N)
+    (a b c : C(NativeCube N, (unitInterval))) (u : NativeCube N) (hu : u i = 1) :
+    sliceBinaryCoordinate i a b c u = c u := by simp [sliceBinaryCoordinate, hu]
+
+private theorem HigherHurewicz.NativeSubdivision.sliceTrans_apply {N : Type*} {X : Type*}
+    [TopologicalSpace X] {x : X} [DecidableEq N] (p : GenLoop N X x) (i : N)
+    (a b c : C(NativeCube N, (unitInterval))) (ha : CutBased p i a) (hb : CutBased p i b)
+    (hc : CutBased p i c) (haInd : CutIndependent i a) (hbInd : CutIndependent i b)
+    (hcInd : CutIndependent i c) (u : NativeCube N) :
+    GenLoop.transAt i (sliceLoop p i a b ha hb) (sliceLoop p i b c hb hc) u =
+      p (Function.update u i (sliceBinaryCoordinate i a b c u)) := by
+  change
+    (if (u i : ℝ) ≤ 1 / 2 then
+        sliceLoop p i a b ha hb
+          (Function.update u i (Set.projIcc 0 1 zero_le_one (2 * (u i : ℝ))))
+      else
+        sliceLoop p i b c hb hc
+          (Function.update u i (Set.projIcc 0 1 zero_le_one (2 * (u i : ℝ) - 1)))) =
+      p (Function.update u i (cutBinaryWarp ((a u, b u, c u), u i)))
+  split_ifs with h
+  · rw [sliceLoop_apply, haInd u _, hbInd u _, Function.update_self, Function.update_idem]
+    exact
+      congrArg (fun v => p (Function.update u i v))
+        (cutBinaryWarp_of_le_half (a u) (b u) (c u) (u i) h).symm
+  · rw [sliceLoop_apply, hbInd u _, hcInd u _, Function.update_self, Function.update_idem]
+    exact
+      congrArg (fun v => p (Function.update u i v))
+        (cutBinaryWarp_of_half_lt (a u) (b u) (c u) (u i) (lt_of_not_ge h)).symm
+
+private theorem HigherHurewicz.NativeSubdivision.slice_homotopic_trans {N : Type*} {X : Type*}
+    [TopologicalSpace X] {x : X} [DecidableEq N] (p : GenLoop N X x) (i : N)
+    (a b c : C(NativeCube N, (unitInterval))) (ha : CutBased p i a) (hb : CutBased p i b)
+    (hc : CutBased p i c) (haInd : CutIndependent i a) (hbInd : CutIndependent i b)
+    (hcInd : CutIndependent i c) :
+    GenLoop.Homotopic (sliceLoop p i a c ha hc)
+      (GenLoop.transAt i (sliceLoop p i a b ha hb) (sliceLoop p i b c hb hc)) :=
+  ⟨sliceHomotopyOfCoordinate p i a c ha hc
+      (GenLoop.transAt i (sliceLoop p i a b ha hb) (sliceLoop p i b c hb hc))
+      (sliceBinaryCoordinate i a b c) (sliceTrans_apply p i a b c ha hb hc haInd hbInd hcInd)
+      (sliceBinaryCoordinate_zero i a b c) (sliceBinaryCoordinate_one i a b c)⟩
+
+private theorem HigherHurewicz.NativeSubdivision.slice_toLoop_transAt {N : Type*} {X : Type*}
+    [TopologicalSpace X] {x : X} [DecidableEq N] (i : N) (a b : GenLoop N X x) :
+    GenLoop.toLoop i (GenLoop.transAt i a b) = (GenLoop.toLoop i a).trans (GenLoop.toLoop i b) := by
+  rw [← GenLoop.fromLoop_trans_toLoop, GenLoop.to_from]
+
+private theorem HigherHurewicz.NativeSubdivision.slice_transAt_homotopic {N : Type*} {X : Type*}
+    [TopologicalSpace X] {x : X} [DecidableEq N] (i : N) {a b c d : GenLoop N X x}
+    (ha : GenLoop.Homotopic a c) (hb : GenLoop.Homotopic b d) :
+    GenLoop.Homotopic (GenLoop.transAt i a b) (GenLoop.transAt i c d) := by
+  apply GenLoop.homotopicFrom i
+  rw [slice_toLoop_transAt, slice_toLoop_transAt]
+  rcases GenLoop.homotopicTo i ha with ⟨Ha⟩
+  rcases GenLoop.homotopicTo i hb with ⟨Hb⟩
+  exact ⟨Ha.hcomp Hb⟩
+
+private def HigherHurewicz.NativeSubdivision.sliceConcat {N : Type*} [DecidableEq N] {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop N X x) (i : N) :
+    (k : ℕ) →
+      (a : Fin (k + 1) → C(NativeCube N, (unitInterval))) →
+        (∀ j, CutBased p i (a j)) → GenLoop N X x
+  | 0, _, _ => GenLoop.const
+  | k + 1, a, ha =>
+    GenLoop.transAt i
+      (sliceLoop p i (a 0) (a (0 : Fin (k + 1)).succ) (ha 0) (ha (0 : Fin (k + 1)).succ))
+      (sliceConcat p i k (fun j => a j.succ) (fun j => ha j.succ))
+
+private theorem HigherHurewicz.NativeSubdivision.slice_homotopic_concat {N : Type*} [DecidableEq N]
+    {X : Type*} [TopologicalSpace X] {x : X} (p : GenLoop N X x) (i : N) (k : ℕ)
+    (a : Fin (k + 1) → C(NativeCube N, (unitInterval))) (ha : ∀ j, CutBased p i (a j))
+    (hInd : ∀ j, CutIndependent i (a j)) :
+    GenLoop.Homotopic (sliceLoop p i (a 0) (a (Fin.last k)) (ha 0) (ha (Fin.last k)))
+      (sliceConcat p i k a ha) := by
+  induction k with
+  | zero =>
+    change GenLoop.Homotopic (sliceLoop p i (a 0) (a 0) (ha 0) (ha 0)) GenLoop.const
+    rw [sliceLoop_self]
+  | succ k
+    ih =>
+    have ht := ih (fun j => a j.succ) (fun j => ha j.succ) (fun j => hInd j.succ)
+    have hs :=
+      slice_homotopic_trans p i (a 0) (a (0 : Fin (k + 1)).succ) (a (Fin.last (k + 1))) (ha 0)
+        (ha (0 : Fin (k + 1)).succ) (ha (Fin.last (k + 1))) (hInd 0) (hInd (0 : Fin (k + 1)).succ)
+        (hInd (Fin.last (k + 1)))
+    apply hs.trans
+    apply slice_transAt_homotopic
+    · exact GenLoop.Homotopic.refl _
+    · exact ht
+
+private theorem
+    HigherHurewicz.NativeSubdivision.sliceConcat_class {N : Type*} [DecidableEq N] {X : Type*}
+    [TopologicalSpace X] {x : X} [Nontrivial N] (p : GenLoop N X x) (i : N) (k : ℕ)
+    (a : Fin (k + 1) → C(NativeCube N, (unitInterval))) (ha : ∀ j, CutBased p i (a j)) :
+    nativeClass (sliceConcat p i k a ha) =
+      ∑ j : Fin k,
+        nativeClass (sliceLoop p i (a j.castSucc) (a j.succ) (ha j.castSucc) (ha j.succ)) := by
+  induction k with
+  | zero => simp [sliceConcat]
+  | succ k ih =>
+    rw [sliceConcat, nativeClass_transAt, ih, Fin.sum_univ_succ]
+    rfl
+
+private theorem HigherHurewicz.NativeSubdivision.finiteCuts_homotopic {N : Type*} [DecidableEq N]
+    {X : Type*} [TopologicalSpace X] {x : X} (p : GenLoop N X x) (i : N) (k : ℕ)
+    (a : Fin (k + 1) → C(NativeCube N, (unitInterval))) (ha : ∀ j, CutBased p i (a j))
+    (hInd : ∀ j, CutIndependent i (a j)) (hzero : ∀ u, a 0 u = 0)
+    (hone : ∀ u, a (Fin.last k) u = 1) : GenLoop.Homotopic p (sliceConcat p i k a ha) := by
+  have h := slice_homotopic_concat p i k a ha hInd
+  rwa [sliceLoop_full p i (a 0) (a (Fin.last k)) (ha 0) (ha (Fin.last k)) hzero hone] at h
+
+private theorem
+    HigherHurewicz.NativeSubdivision.finiteCuts_class {N : Type*} [DecidableEq N] {X : Type*}
+    [TopologicalSpace X] {x : X} [Nontrivial N] (p : GenLoop N X x) (i : N) (k : ℕ)
+    (a : Fin (k + 1) → C(NativeCube N, (unitInterval))) (ha : ∀ j, CutBased p i (a j))
+    (hInd : ∀ j, CutIndependent i (a j)) (hzero : ∀ u, a 0 u = 0)
+    (hone : ∀ u, a (Fin.last k) u = 1) :
+    nativeClass p =
+      ∑ j : Fin k,
+        nativeClass (sliceLoop p i (a j.castSucc) (a j.succ) (ha j.castSucc) (ha j.succ)) :=
+  (nativeClass_homotopic (finiteCuts_homotopic p i k a ha hInd hzero hone)).trans
+    (sliceConcat_class p i k a ha)
+
+private theorem HigherHurewicz.NativeSubdivision.extendedChamberCut_slice_eq {m n : ℕ} {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin n) X x) (hp : NativeCubeInternalBased p)
+    (h : m + 1 ≤ n) (e : Equiv.Perm (Fin m)) (chart : NativeChamberChart e) (j : Fin (m + 1)) :
+    sliceLoop (extendedChamberLoop p hp (Nat.le_of_succ_le h) chart) (chamberCutIndex h)
+        (extendedChamberCutSequence h e chart j.castSucc)
+        (extendedChamberCutSequence h e chart j.succ)
+        (extendedChamberCutSequence_based p hp h e chart j.castSucc)
+        (extendedChamberCutSequence_based p hp h e chart j.succ) =
+      extendedChamberLoop p hp h (insertChamberChart e j.rev chart) := by
+  apply GenLoop.ext
+  intro u
+  rw [sliceLoop_apply, extendedChamberLoop_apply, extendedChamberCutSequence_castSucc,
+    extendedChamberCutSequence_succ,
+    extendCubeMap_update_outside (Nat.le_of_succ_le h) chart.toContinuousMap u (chamberCutIndex h)
+      (le_refl m)]
+  exact congrArg p (extend_insertChamberMap h e j.rev chart u).symm
+
+private theorem
+    HigherHurewicz.NativeSubdivision.nativeClass_extendedChamber_eq_sum_insertions {m n : ℕ}
+    {X : Type*} [TopologicalSpace X] {x : X} [Nontrivial (Fin n)] (p : GenLoop (Fin n) X x)
+    (hp : NativeCubeInternalBased p) (h : m + 1 ≤ n) {e : Equiv.Perm (Fin m)}
+    (chart : NativeChamberChart e) :
+    nativeClass (extendedChamberLoop p hp (Nat.le_of_succ_le h) chart) =
+      ∑ r : Fin (m + 1),
+        nativeClass (extendedChamberLoop p hp h (insertChamberChart e r chart)) := by
+  have hcut :=
+    finiteCuts_class (extendedChamberLoop p hp (Nat.le_of_succ_le h) chart) (chamberCutIndex h)
+      (m + 1) (extendedChamberCutSequence h e chart)
+      (extendedChamberCutSequence_based p hp h e chart)
+      (extendedChamberCutSequence_independent h e chart)
+      (extendedChamberCutSequence_zero h e chart) (extendedChamberCutSequence_last h e chart)
+  have hrev :
+    nativeClass (extendedChamberLoop p hp (Nat.le_of_succ_le h) chart) =
+      ∑ j : Fin (m + 1),
+        nativeClass (extendedChamberLoop p hp h (insertChamberChart e j.rev chart)) := by
+    simpa only [extendedChamberCut_slice_eq p hp h e chart] using hcut
+  exact
+    hrev.trans
+      (chamberCuts_sum_rev
+        (fun r => nativeClass (extendedChamberLoop p hp h (insertChamberChart e r chart))))
+
+private def
+    HigherHurewicz.NativeSubdivision.prefixProduct {n : ℕ} (u : NativeCube (Fin n)) (k : ℕ) :
+    (unitInterval) :=
+  ∏ i ∈ Finset.univ.filter (fun i : Fin n => i.val < k), u i
+
+@[simp]
+private theorem
+    HigherHurewicz.NativeSubdivision.prefixProduct_zero {n : ℕ} (u : NativeCube (Fin n)) :
+    prefixProduct u 0 = 1 := by simp [prefixProduct]
+
+private theorem HigherHurewicz.NativeSubdivision.prefixProduct_succ {n : ℕ} (u : NativeCube (Fin n))
+    (k : ℕ) (hk : k < n) : prefixProduct u (k + 1) = prefixProduct u k * u ⟨k, hk⟩ := by
+  have hs :
+    (Finset.univ.filter fun i : Fin n => i.val < k + 1) =
+      Insert.insert ⟨k, hk⟩ (Finset.univ.filter fun i : Fin n => i.val < k) := by
+    ext i
+    simp only [Finset.mem_filter, Finset.mem_univ, true_and, Finset.mem_insert, Fin.ext_iff]
+    omega
+  unfold prefixProduct
+  rw [hs, Finset.prod_insert (by simp)]
+  exact mul_comm _ _
+
+private theorem HigherHurewicz.NativeSubdivision.prefixProduct_eq_zero_of_coordinate {n : ℕ}
+    (u : NativeCube (Fin n)) (k : ℕ) (i : Fin n) (hik : i.val < k) (hi : u i = 0) :
+    prefixProduct u k = 0 :=
+  Finset.prod_eq_zero (Finset.mem_filter.mpr ⟨Finset.mem_univ i, hik⟩) hi
+
+private theorem HigherHurewicz.NativeSubdivision.prefixProduct_succ_of_one {n : ℕ}
+    (u : NativeCube (Fin n)) (i : Fin n) (hi : u i = 1) :
+    prefixProduct u (i.val + 1) = prefixProduct u i.val := by
+  rw [prefixProduct_succ u i.val i.isLt, hi, mul_one]
+
+private theorem HigherHurewicz.NativeSubdivision.continuous_prefixProduct (n k : ℕ) :
+    Continuous (fun u : NativeCube (Fin n) => prefixProduct u k) := by
+  unfold prefixProduct
+  generalize Finset.univ.filter (fun i : Fin n => i.val < k) = s
+  induction s using Finset.induction_on with
+  | empty =>
+    simpa only [Finset.prod_empty] using
+      (continuous_const : Continuous (fun _ : NativeCube (Fin n) => (1 : (unitInterval))))
+  | @insert i s hi ih =>
+    simp only [Finset.prod_insert hi]
+    exact
+      ((continuous_subtype_val.comp (continuous_apply i)).mul
+            (continuous_subtype_val.comp ih)).subtype_mk
+        _
+
+private def HigherHurewicz.NativeSubdivision.nativeDuffyCubeCanonical (n : ℕ) :
+    C(NativeCube (Fin n), NativeCube (Fin n))
+    where
+  toFun u i := prefixProduct u (i.val + 1)
+  continuous_toFun := continuous_pi fun i => continuous_prefixProduct n (i.val + 1)
+
+private def HigherHurewicz.NativeSubdivision.nativeDuffyCube {n : ℕ} (e : Equiv.Perm (Fin n)) :
+    C(NativeCube (Fin n), NativeCube (Fin n))
+    where
+  toFun u i := nativeDuffyCubeCanonical n u (e.symm i)
+  continuous_toFun :=
+    continuous_pi fun i =>
+      (continuous_apply (e.symm i)).comp (nativeDuffyCubeCanonical n).continuous
+
+private theorem
+    HigherHurewicz.NativeSubdivision.nativeDuffyCube_apply {n : ℕ} (e : Equiv.Perm (Fin n))
+    (u : NativeCube (Fin n)) (i : Fin n) :
+    nativeDuffyCube e u i = prefixProduct u ((e.symm i).val + 1) :=
+  rfl
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.nativeDuffyCube_coordinate {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (u : NativeCube (Fin n)) (i : Fin n) :
+    nativeDuffyCube e u (e i) = prefixProduct u (i.val + 1) := by simp [nativeDuffyCube_apply]
+
+private theorem HigherHurewicz.NativeSubdivision.nativeDuffyCube_coordinate_eq_zero {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (u : NativeCube (Fin n)) (i j : Fin n) (hij : i ≤ j) (hi : u i = 0) :
+    nativeDuffyCube e u (e j) = 0 := by
+  rw [nativeDuffyCube_coordinate]
+  exact prefixProduct_eq_zero_of_coordinate u _ i (by omega) hi
+
+private theorem HigherHurewicz.NativeSubdivision.nativeDuffyCube_coordinate_zero_of_one {n : ℕ}
+    (e : Equiv.Perm (Fin (n + 1))) (u : NativeCube (Fin (n + 1))) (hu : u 0 = 1) :
+    nativeDuffyCube e u (e 0) = 1 := by
+  rw [nativeDuffyCube_coordinate, prefixProduct_succ_of_one u 0 hu]
+  exact prefixProduct_zero u
+
+private theorem HigherHurewicz.NativeSubdivision.nativeDuffyCube_adjacent_of_one {n : ℕ}
+    (e : Equiv.Perm (Fin (n + 1))) (u : NativeCube (Fin (n + 1))) (i : Fin n)
+    (hi : u i.succ = 1) : nativeDuffyCube e u (e i.castSucc) = nativeDuffyCube e u (e i.succ) := by
+  rw [nativeDuffyCube_coordinate, nativeDuffyCube_coordinate,
+    prefixProduct_succ_of_one u i.succ hi]
+  rfl
+
+private theorem
+    HigherHurewicz.NativeSubdivision.nativeDuffyCube_boundary {n : ℕ} (e : Equiv.Perm (Fin n))
+    (u : NativeCube (Fin n)) (hu : u ∈ Cube.boundary (Fin n)) :
+    nativeDuffyCube e u ∈ Cube.boundary (Fin n) ∨
+      ∃ i j : Fin n, i ≠ j ∧ nativeDuffyCube e u i = nativeDuffyCube e u j := by
+  obtain ⟨i, hi | hi⟩ := hu
+  · exact Or.inl ⟨e i, Or.inl (nativeDuffyCube_coordinate_eq_zero e u i i le_rfl hi)⟩
+  · cases n with
+    | zero => exact Fin.elim0 i
+    | succ n =>
+      cases i using Fin.cases with
+      | zero => exact Or.inl ⟨e 0, Or.inr (nativeDuffyCube_coordinate_zero_of_one e u hi)⟩
+      | succ i =>
+        exact
+          Or.inr
+            ⟨e i.castSucc, e i.succ,
+              e.injective.ne (by intro h; have := congrArg Fin.val h; simp at this),
+              nativeDuffyCube_adjacent_of_one e u i hi⟩
+
+private theorem
+    HigherHurewicz.NativeSubdivision.nativeDuffyCube_based {X : Type*} [TopologicalSpace X]
+    {x : X} {n : ℕ} (p : GenLoop (Fin n) X x) (hp : NativeCubeInternalBased p)
+    (e : Equiv.Perm (Fin n)) (u : NativeCube (Fin n)) (hu : u ∈ Cube.boundary (Fin n)) :
+    p (nativeDuffyCube e u) = x := by
+  rcases nativeDuffyCube_boundary e u hu with h | ⟨i, j, hij, h⟩
+  · exact p.property _ h
+  · exact hp _ i j hij h
+
+private def
+    HigherHurewicz.NativeSubdivision.nativeDuffyCubeLoop {X : Type*} [TopologicalSpace X] {x : X}
+    {n : ℕ} (p : GenLoop (Fin n) X x) (hp : NativeCubeInternalBased p) (e : Equiv.Perm (Fin n)) :
+    GenLoop (Fin n) X x :=
+  nativeCubePullbackLoop p (nativeDuffyCube e) (nativeDuffyCube_based p hp e)
+
+private def
+    HigherHurewicz.NativeSubdivision.nativeOrderedDuffyMap {n : ℕ} (e : Equiv.Perm (Fin n)) :
+    C(NativeCube (Fin n), NativeCube (Fin n)) :=
+  (nativeDuffyCube e).comp (permuteCubeCoordinates e)
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.nativeOrderedDuffyMap_coordinate {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (u : NativeCube (Fin n)) (i : Fin n) :
+    nativeOrderedDuffyMap e u (e i) = prefixProduct (fun k => u (e k)) (i.val + 1) := by
+  exact nativeDuffyCube_coordinate e (permuteCubeCoordinates e u) i
+
+private theorem HigherHurewicz.NativeSubdivision.nativeOrderedDuffyMap_coordinate_eq_zero {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (u : NativeCube (Fin n)) (i j : Fin n) (hij : i ≤ j)
+    (hi : u (e i) = 0) : nativeOrderedDuffyMap e u (e j) = 0 :=
+  nativeDuffyCube_coordinate_eq_zero e (permuteCubeCoordinates e u) i j hij hi
+
+private theorem HigherHurewicz.NativeSubdivision.nativeOrderedDuffyMap_zero_last {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (u : NativeCube (Fin n)) (i : Fin n) (_hi : i.val + 1 = n)
+    (hu : u (e i) = 0) : nativeOrderedDuffyMap e u (e i) = 0 :=
+  nativeOrderedDuffyMap_coordinate_eq_zero e u i i le_rfl hu
+
+private theorem HigherHurewicz.NativeSubdivision.nativeOrderedDuffyMap_zero_adjacent {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (u : NativeCube (Fin n)) (i j : Fin n) (hij : i.val + 1 = j.val)
+    (hu : u (e i) = 0) : nativeOrderedDuffyMap e u (e i) = nativeOrderedDuffyMap e u (e j) := by
+  rw [nativeOrderedDuffyMap_coordinate_eq_zero e u i i le_rfl hu,
+    nativeOrderedDuffyMap_coordinate_eq_zero e u i j (by omega) hu]
+
+private theorem HigherHurewicz.NativeSubdivision.nativeOrderedDuffyMap_one_first {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (u : NativeCube (Fin n)) (i : Fin n) (hi : i.val = 0)
+    (hu : u (e i) = 1) : nativeOrderedDuffyMap e u (e i) = 1 := by
+  rw [nativeOrderedDuffyMap_coordinate, prefixProduct_succ_of_one (fun k => u (e k)) i hu, hi,
+    prefixProduct_zero]
+
+private theorem HigherHurewicz.NativeSubdivision.nativeOrderedDuffyMap_one_adjacent {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (u : NativeCube (Fin n)) (i j : Fin n) (hji : j.val + 1 = i.val)
+    (hu : u (e i) = 1) : nativeOrderedDuffyMap e u (e i) = nativeOrderedDuffyMap e u (e j) := by
+  rw [nativeOrderedDuffyMap_coordinate, nativeOrderedDuffyMap_coordinate,
+    prefixProduct_succ_of_one (fun k => u (e k)) i hu, hji]
+
+private theorem HigherHurewicz.NativeSubdivision.nativeOrderedDuffyMap_based {X : Type*}
+    [TopologicalSpace X] {x : X} {n : ℕ} (p : GenLoop (Fin n) X x)
+    (hp : NativeCubeInternalBased p) (e : Equiv.Perm (Fin n)) (u : NativeCube (Fin n))
+    (hu : u ∈ Cube.boundary (Fin n)) : p (nativeOrderedDuffyMap e u) = x :=
+  nativeDuffyCube_based p hp e _ (permuteCubeCoordinates_boundary e u hu)
+
+private def HigherHurewicz.NativeSubdivision.nativeCubeOrderedDuffyHomotopy {X : Type*}
+    [TopologicalSpace X] {x : X} {n : ℕ} (p : GenLoop (Fin n) X x)
+    (hp : NativeCubeInternalBased p) (e : Equiv.Perm (Fin n))
+    (f : C(NativeCube (Fin n), NativeCube (Fin n)))
+    (hf : ∀ u ∈ Cube.boundary (Fin n), p (f u) = x)
+    (hfg : ∀ u ∈ Cube.boundary (Fin n), NativeCubeSameFlat (f u) (nativeOrderedDuffyMap e u)) :
+    (nativeCubePullbackLoop p f hf).val.HomotopyRel
+      (permuteCubeLoop (nativeDuffyCubeLoop p hp e) e).val (Cube.boundary (Fin n)) :=
+  nativeCubeLinearHomotopy p hp f (nativeOrderedDuffyMap e) hf
+    (nativeOrderedDuffyMap_based p hp e) hfg
+
+private theorem HigherHurewicz.NativeSubdivision.nativeClass_commonOrderedDuffy {X : Type*}
+    [TopologicalSpace X] {x : X} {n : ℕ} [Nontrivial (Fin n)] (p : GenLoop (Fin n) X x)
+    (hp : NativeCubeInternalBased p) (e : Equiv.Perm (Fin n))
+    (f : C(NativeCube (Fin n), NativeCube (Fin n)))
+    (hf : ∀ u ∈ Cube.boundary (Fin n), p (f u) = x)
+    (hfg : ∀ u ∈ Cube.boundary (Fin n), NativeCubeSameFlat (f u) (nativeOrderedDuffyMap e u)) :
+    nativeClass (nativeCubePullbackLoop p f hf) =
+      ((Equiv.Perm.sign e : ℤˣ) : ℤ) • nativeClass (nativeDuffyCubeLoop p hp e) := by
+  calc
+    nativeClass (nativeCubePullbackLoop p f hf) =
+        nativeClass (permuteCubeLoop (nativeDuffyCubeLoop p hp e) e) :=
+      nativeClass_homotopic ⟨nativeCubeOrderedDuffyHomotopy p hp e f hf hfg⟩
+    _ = _ := permuteCubeLoop_additiveClass _ e
+
+private def HigherHurewicz.NativeSubdivision.orderedDuffyChart {n : ℕ} (e : Equiv.Perm (Fin n)) :
+    NativeChamberChart e
+    where
+  toContinuousMap := nativeOrderedDuffyMap e
+  zero_last := nativeOrderedDuffyMap_zero_last e
+  zero_adjacent := nativeOrderedDuffyMap_zero_adjacent e
+  one_first := nativeOrderedDuffyMap_one_first e
+  one_adjacent := nativeOrderedDuffyMap_one_adjacent e
+
+private theorem HigherHurewicz.NativeSubdivision.NativeChamberChart.commonOrderedDuffy {n : ℕ}
+    {e : Equiv.Perm (Fin n)} (chart : HigherHurewicz.NativeSubdivision.NativeChamberChart e)
+    (u : HigherHurewicz.NativeSubdivision.NativeCube (Fin n)) (hu : u ∈ Cube.boundary (Fin n)) :
+    HigherHurewicz.NativeSubdivision.NativeCubeSameFlat (chart.toContinuousMap u)
+      (HigherHurewicz.NativeSubdivision.nativeOrderedDuffyMap e u) :=
+  chart.sameFlat (HigherHurewicz.NativeSubdivision.orderedDuffyChart e) u hu
+
+private theorem HigherHurewicz.NativeSubdivision.nativeClass_eq_sum_partialChambers {n : ℕ}
+    [Nontrivial (Fin n)] {X : Type*} [TopologicalSpace X] {x : X} (p : GenLoop (Fin n) X x)
+    (hp : NativeCubeInternalBased p) (m : ℕ) (h : m ≤ n) :
+    nativeClass p =
+      ∑ e : Equiv.Perm (Fin m), nativeClass (extendedChamberLoop p hp h (orderedDuffyChart e)) := by
+  induction m with
+  | zero => simp
+  | succ m ih =>
+    rw [sum_insertPermutation]
+    calc
+      nativeClass p =
+          ∑ e : Equiv.Perm (Fin m),
+            nativeClass (extendedChamberLoop p hp (Nat.le_of_succ_le h) (orderedDuffyChart e)) :=
+        ih (Nat.le_of_succ_le h)
+      _ =
+          ∑ e : Equiv.Perm (Fin m),
+            ∑ r : Fin (m + 1),
+              nativeClass
+                (extendedChamberLoop p hp h (orderedDuffyChart (insertPermutation e r))) := by
+        apply Finset.sum_congr rfl
+        intro e _
+        rw [nativeClass_extendedChamber_eq_sum_insertions p hp h (orderedDuffyChart e)]
+        apply Finset.sum_congr rfl
+        intro r _
+        exact
+          nativeClass_extendedChamber_eq p hp h (insertChamberChart e r (orderedDuffyChart e))
+            (orderedDuffyChart (insertPermutation e r))
+
+@[simp]
+private theorem HigherHurewicz.NativeSubdivision.nativeCubeSimplexQuotient_coordinate {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (u : NativeCube (Fin n)) (i : Fin n) :
+    nativeCubeSimplexQuotient e u (e i) =
+      HigherHurewicz.SimplexGeometry.prefixMinimum u (i.val + 1) :=
+  Subtype.ext (HigherHurewicz.SimplexGeometry.cubeSimplex_quotient_coordinate e u i)
+
+private theorem
+    HigherHurewicz.NativeSubdivision.nativeCubeSimplexQuotient_coordinate_eq_zero {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (u : NativeCube (Fin n)) (i j : Fin n) (hij : i ≤ j) (hi : u i = 0) :
+    nativeCubeSimplexQuotient e u (e j) = 0 := by
+  rw [nativeCubeSimplexQuotient_coordinate]
+  exact
+    le_antisymm (hi ▸ HigherHurewicz.SimplexGeometry.prefixMinimum_le_coordinate u _ i (by omega))
+      bot_le
+
+private theorem
+    HigherHurewicz.NativeSubdivision.nativeCubeSimplexQuotient_coordinate_zero_of_one {n : ℕ}
+    (e : Equiv.Perm (Fin (n + 1))) (u : NativeCube (Fin (n + 1))) (hu : u 0 = 1) :
+    nativeCubeSimplexQuotient e u (e 0) = 1 := by
+  rw [nativeCubeSimplexQuotient_coordinate]
+  change HigherHurewicz.SimplexGeometry.prefixMinimum u (0 + 1) = 1
+  rw [HigherHurewicz.SimplexGeometry.prefixMinimum_succ u 0 (Nat.zero_lt_succ n),
+    HigherHurewicz.SimplexGeometry.prefixMinimum_zero]
+  simp [hu]
+
+private theorem HigherHurewicz.NativeSubdivision.nativeCubeSimplexQuotient_adjacent_of_one {n : ℕ}
+    (e : Equiv.Perm (Fin (n + 1))) (u : NativeCube (Fin (n + 1))) (i : Fin n)
+    (hi : u i.succ = 1) :
+    nativeCubeSimplexQuotient e u (e i.castSucc) = nativeCubeSimplexQuotient e u (e i.succ) := by
+  rw [nativeCubeSimplexQuotient_coordinate, nativeCubeSimplexQuotient_coordinate,
+    HigherHurewicz.SimplexGeometry.prefixMinimum_succ u i.succ.val i.succ.isLt]
+  change
+    HigherHurewicz.SimplexGeometry.prefixMinimum u (i.val + 1) =
+      Min.min (HigherHurewicz.SimplexGeometry.prefixMinimum u (i.val + 1)) (u i.succ)
+  rw [hi,
+    min_eq_left
+      (show HigherHurewicz.SimplexGeometry.prefixMinimum u (i.val + 1) ≤ 1 from
+        (HigherHurewicz.SimplexGeometry.prefixMinimum u (i.val + 1)).property.2)]
+
+private theorem HigherHurewicz.NativeSubdivision.nativeDuffyCube_simplex_sameFlat {n : ℕ}
+    (e : Equiv.Perm (Fin n)) (u : NativeCube (Fin n)) (hu : u ∈ Cube.boundary (Fin n)) :
+    NativeCubeSameFlat (nativeDuffyCube e u) (nativeCubeSimplexQuotient e u) := by
+  obtain ⟨i, hi | hi⟩ := hu
+  · exact
+      .zero (e i) (nativeDuffyCube_coordinate_eq_zero e u i i le_rfl hi)
+        (nativeCubeSimplexQuotient_coordinate_eq_zero e u i i le_rfl hi)
+  · cases n with
+    | zero => exact Fin.elim0 i
+    | succ n =>
+      cases i using Fin.cases with
+      | zero =>
+        exact
+          .one (e 0) (nativeDuffyCube_coordinate_zero_of_one e u hi)
+            (nativeCubeSimplexQuotient_coordinate_zero_of_one e u hi)
+      | succ i =>
+        exact
+          .equal (e i.castSucc) (e i.succ)
+            (e.injective.ne (by intro h; have := congrArg Fin.val h; simp at this))
+            (nativeDuffyCube_adjacent_of_one e u i hi)
+            (nativeCubeSimplexQuotient_adjacent_of_one e u i hi)
+
+private def HigherHurewicz.NativeSubdivision.nativeDuffyCubeSimplexHomotopy {X : Type*}
+    [TopologicalSpace X] {x : X} {n : ℕ} (p : GenLoop (Fin n) X x)
+    (hp : NativeCubeInternalBased p) (e : Equiv.Perm (Fin n)) :
+    (nativeDuffyCubeLoop p hp e).val.HomotopyRel
+      (HigherHurewicz.SimplexGeometry.basedSimplexLoop (nativeBasedCubeSimplex p hp e)).val
+      (Cube.boundary (Fin n)) :=
+  nativeCubeLinearHomotopy p hp (nativeDuffyCube e) (nativeCubeSimplexQuotient e)
+    (nativeDuffyCube_based p hp e) (nativeCubeSimplexQuotient_based p hp e)
+    (nativeDuffyCube_simplex_sameFlat e)
+
+private theorem
+    HigherHurewicz.NativeSubdivision.nativeDuffyCube_homotopic_basedSimplexLoop {X : Type*}
+    [TopologicalSpace X] {x : X} {n : ℕ} (p : GenLoop (Fin n) X x)
+    (hp : NativeCubeInternalBased p) (e : Equiv.Perm (Fin n)) :
+    GenLoop.Homotopic (nativeDuffyCubeLoop p hp e)
+      (HigherHurewicz.SimplexGeometry.basedSimplexLoop (nativeBasedCubeSimplex p hp e)) :=
+  ⟨nativeDuffyCubeSimplexHomotopy p hp e⟩
+
+private theorem
+    HigherHurewicz.NativeSubdivision.nativeDuffyCubeClass_eq_basedSimplexClass {X : Type*}
+    [TopologicalSpace X] {x : X} {n : ℕ} (p : GenLoop (Fin n) X x)
+    (hp : NativeCubeInternalBased p) (e : Equiv.Perm (Fin n)) :
+    nativeClass (nativeDuffyCubeLoop p hp e) =
+      HigherHurewicz.SimplexGeometry.basedSimplexClass (nativeBasedCubeSimplex p hp e) :=
+  nativeClass_homotopic (nativeDuffyCube_homotopic_basedSimplexLoop p hp e)
+
+private theorem HigherHurewicz.NativeSubdivision.nativeClass_commonOrderedSimplex {X : Type*}
+    [TopologicalSpace X] {x : X} {n : ℕ} [Nontrivial (Fin n)] (p : GenLoop (Fin n) X x)
+    (hp : NativeCubeInternalBased p) (e : Equiv.Perm (Fin n))
+    (f : C(NativeCube (Fin n), NativeCube (Fin n)))
+    (hf : ∀ u ∈ Cube.boundary (Fin n), p (f u) = x)
+    (hfg : ∀ u ∈ Cube.boundary (Fin n), NativeCubeSameFlat (f u) (nativeOrderedDuffyMap e u)) :
+    nativeClass (nativeCubePullbackLoop p f hf) =
+      HigherHurewicz.CubeTriangulation.cubeOrientation e •
+        HigherHurewicz.SimplexGeometry.basedSimplexClass (nativeBasedCubeSimplex p hp e) := by
+  rw [nativeClass_commonOrderedDuffy p hp e f hf hfg, nativeDuffyCubeClass_eq_basedSimplexClass]
+  rfl
+
+private theorem HigherHurewicz.NativeSubdivision.nativeClass_chamber_eq_orientedSimplex {n : ℕ}
+    [Nontrivial (Fin n)] {X : Type*} [TopologicalSpace X] {x : X} (p : GenLoop (Fin n) X x)
+    (hp : NativeCubeInternalBased p) (e : Equiv.Perm (Fin n)) (chart : NativeChamberChart e) :
+    nativeClass (extendedChamberLoop p hp (le_refl n) chart) =
+      HigherHurewicz.CubeTriangulation.cubeOrientation e •
+        HigherHurewicz.SimplexGeometry.basedSimplexClass (nativeBasedCubeSimplex p hp e) := by
+  apply
+    nativeClass_commonOrderedSimplex p hp e (extendCubeMap (le_refl n) chart.toContinuousMap)
+      (extendedChamberMap_based p hp (le_refl n) chart)
+  intro u hu
+  rw [extendCubeMap_refl]
+  exact chart.commonOrderedDuffy u hu
+
+private theorem
+    HigherHurewicz.NativeSubdivision.nativeClass_eq_sum_simplices {n : ℕ} [Nontrivial (Fin n)]
+    {X : Type*} [TopologicalSpace X] {x : X} (p : GenLoop (Fin n) X x)
+    (hp : NativeCubeInternalBased p) :
+    nativeClass p =
+      ∑ e : Equiv.Perm (Fin n),
+        HigherHurewicz.CubeTriangulation.cubeOrientation e •
+          HigherHurewicz.SimplexGeometry.basedSimplexClass (nativeBasedCubeSimplex p hp e) := by
+  calc
+    nativeClass p =
+        ∑ e : Equiv.Perm (Fin n),
+          nativeClass (extendedChamberLoop p hp (le_refl n) (orderedDuffyChart e)) :=
+      nativeClass_eq_sum_partialChambers p hp n (le_refl n)
+    _ = _ :=
+      Finset.sum_congr rfl fun e _ =>
+        nativeClass_chamber_eq_orientedSimplex p hp e (orderedDuffyChart e)
+
+private theorem
+    HigherHurewicz.NativeSubdivision.nativeCubeSubdivision_class {n : ℕ} [Nontrivial (Fin n)]
+    {X : Type*} [TopologicalSpace X] {x : X} (p : GenLoop (Fin n) X x)
+    (hp : NativeCubeInternalBased p) :
+    Additive.ofMul (⟦p⟧ : π_ n X x) =
+      ∑ e : Equiv.Perm (Fin n),
+        HigherHurewicz.CubeTriangulation.cubeOrientation e •
+          HigherHurewicz.SimplexGeometry.basedSimplexClass (nativeBasedCubeSimplex p hp e) :=
+  nativeClass_eq_sum_simplices p hp
+
+private theorem FourthHurewicz.fourSimplexClassOperator_cubeChain {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (p : GenLoop (Fin 4) X x) :
+    fourSimplexClassOperator x (cubeChain p) = Additive.ofMul (⟦p⟧ : π_ 4 X x) := by
+  rw [fourSimplexClassOperator_cubeChain_sum]
+  calc
+    _ = Additive.ofMul (⟦normalizedCube x p⟧ : π_ 4 X x) := by
+      simpa only [normalizedCube_simplex, basedFourSimplexClass] using
+        (HigherHurewicz.NativeSubdivision.nativeCubeSubdivision_class (normalizedCube x p)
+            (normalizedCube_internalBased x p)).symm
+    _ = _ :=
+      congrArg Additive.ofMul
+        (Quotient.sound
+          (show GenLoop.Homotopic (normalizedCube x p) p from
+            ⟨(normalizationCubeHomotopy x p).symm⟩))
+
+private def FourthHurewicz.hurewiczInverse {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] :
+    SingularMayerVietoris.SingularHomology X 4 →ₗ[ℤ] Additive (π_ 4 X x) :=
+  HigherHurewicz.singularHomologyDesc 4 (fourSimplexClassOperator x)
+    (fourSimplexClassOperator_boundary x)
+
+@[simp]
+private theorem FourthHurewicz.hurewiczInverse_cycleClass {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 4) :
+    hurewiczInverse x
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 4 c) =
+      fourSimplexClassOperator x c.val :=
+  HigherHurewicz.singularHomologyDesc_cycleClass 4 _ _ c
+
+private theorem FourthHurewicz.hurewiczMap_comp_hurewiczInverse {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] :
+    (hurewiczMap x).comp (hurewiczInverse x) = LinearMap.id :=
+  HigherHurewicz.comp_singularHomologyDesc_eq_id 4 (fourSimplexClassOperator x)
+    (fourSimplexClassOperator_boundary x) (hurewiczMap x)
+    (hurewiczMap_fourSimplexClassOperator_cycle x)
+
+@[simp]
+private theorem FourthHurewicz.hurewiczMap_hurewiczInverse {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (c : SingularMayerVietoris.SingularHomology X 4) : hurewiczMap x (hurewiczInverse x c) = c :=
+  LinearMap.congr_fun (hurewiczMap_comp_hurewiczInverse x) c
+
+private theorem FourthHurewicz.hurewiczInverse_hurewiczMap_mk {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (p : GenLoop (Fin 4) X x) :
+    hurewiczInverse x (hurewiczMap x (Additive.ofMul (⟦p⟧ : π_ 4 X x))) =
+      Additive.ofMul (⟦p⟧ : π_ 4 X x) := by
+  rw [hurewiczMap_representative, hurewiczInverse_cycleClass]
+  exact fourSimplexClassOperator_cubeChain x p
+
+@[simp]
+private theorem FourthHurewicz.hurewiczInverse_hurewiczMap {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (a : Additive (π_ 4 X x)) : hurewiczInverse x (hurewiczMap x a) = a := by
+  change
+    hurewiczInverse x (hurewiczMap x (Additive.ofMul (Additive.toMul a))) =
+      Additive.ofMul (Additive.toMul a)
+  refine Quotient.inductionOn (Additive.toMul a) ?_
+  intro p
+  exact hurewiczInverse_hurewiczMap_mk x p
+
+private theorem FourthHurewicz.hurewiczInverse_comp_hurewiczMap {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] :
+    (hurewiczInverse x).comp (hurewiczMap x) = LinearMap.id := by
+  ext a
+  exact hurewiczInverse_hurewiczMap x a
+
+
+private def FourthHurewicz.hurewiczPi4Equiv {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] :
+    π_ 4 X x ≃* Multiplicative (SingularMayerVietoris.SingularHomology X 4)
+    where
+  __ := hurewiczPi4 x
+  invFun c := Additive.toMul (hurewiczInverse x (Multiplicative.toAdd c))
+  left_inv a := congrArg Additive.toMul (hurewiczInverse_hurewiczMap x (Additive.ofMul a))
+  right_inv
+    c := congrArg Multiplicative.ofAdd (hurewiczMap_hurewiczInverse x (Multiplicative.toAdd c))
+
+private def
+    FifthHurewicz.lowerSixSimplexHomotopy {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 6) : C((unitInterval) × FirstHurewicz.Simplex 6, X) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy
+    (FourthHurewicz.normalizationFourSimplexHomotopy x)
+    (FourthHurewicz.normalizationFiveSimplexHomotopy x)
+    (FourthHurewicz.normalizationFiveHomotopy_face x)
+    (FourthHurewicz.normalizationFiveSimplexHomotopy_zero x) smp
+
+@[simp]
+private theorem FifthHurewicz.lowerSixSimplexHomotopy_zero {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 6) (s : FirstHurewicz.Simplex 6) :
+    lowerSixSimplexHomotopy x smp (0, s) = smp s :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_zero _ _ _ _ smp s
+
+private theorem FifthHurewicz.lowerSixSimplexHomotopy_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 5
+      (FourthHurewicz.normalizationFiveSimplexHomotopy x) (lowerSixSimplexHomotopy x) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_face
+    (FourthHurewicz.normalizationFourSimplexHomotopy x)
+    (FourthHurewicz.normalizationFiveSimplexHomotopy x)
+    (FourthHurewicz.normalizationFiveHomotopy_face x)
+    (FourthHurewicz.normalizationFiveSimplexHomotopy_zero x)
+
+private def FifthHurewicz.fourFiveSimplexHomotopy {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 4 X x)] (smp : FirstHurewicz.SingularSimplex X 5) :
+    C((unitInterval) × FirstHurewicz.Simplex 5, X) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy
+    (SecondHurewicz.SimplyConnected.stationarySimplexHomotopy 3)
+    (HigherHurewicz.simplexStraighteningHomotopy 4 x)
+    (HigherHurewicz.simplexStraighteningHomotopy_face 3 x)
+    (HigherHurewicz.simplexStraighteningHomotopy_zero 4 x) smp
+
+@[simp]
+private theorem FifthHurewicz.fourFiveSimplexHomotopy_zero {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 4 X x)] (smp : FirstHurewicz.SingularSimplex X 5)
+    (s : FirstHurewicz.Simplex 5) : fourFiveSimplexHomotopy x smp (0, s) = smp s :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_zero _ _ _ _ smp s
+
+private theorem FifthHurewicz.fourFiveSimplexHomotopy_face {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 4 X x)] :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 4
+      (HigherHurewicz.simplexStraighteningHomotopy 4 x) (fourFiveSimplexHomotopy x) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_face
+    (SecondHurewicz.SimplyConnected.stationarySimplexHomotopy 3)
+    (HigherHurewicz.simplexStraighteningHomotopy 4 x)
+    (HigherHurewicz.simplexStraighteningHomotopy_face 3 x)
+    (HigherHurewicz.simplexStraighteningHomotopy_zero 4 x)
+
+@[simp]
+private theorem FifthHurewicz.fourFiveSimplexHomotopy_const {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 4 X x)] :
+    fourFiveSimplexHomotopy x (ContinuousMap.const (FirstHurewicz.Simplex 5) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 5) x :=
+  ThirdHurewicz.extendCoherentSimplexHomotopy_const
+    (SecondHurewicz.SimplyConnected.stationarySimplexHomotopy 3)
+    (HigherHurewicz.simplexStraighteningHomotopy 4 x)
+    (HigherHurewicz.simplexStraighteningHomotopy_face 3 x)
+    (HigherHurewicz.simplexStraighteningHomotopy_zero 4 x) x
+    (HigherHurewicz.simplexStraighteningHomotopy_const 4 x)
+
+private def FifthHurewicz.fourSixSimplexHomotopy {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 4 X x)] (smp : FirstHurewicz.SingularSimplex X 6) :
+    C((unitInterval) × FirstHurewicz.Simplex 6, X) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy
+    (HigherHurewicz.simplexStraighteningHomotopy 4 x) (fourFiveSimplexHomotopy x)
+    (fourFiveSimplexHomotopy_face x) (fourFiveSimplexHomotopy_zero x) smp
+
+@[simp]
+private theorem FifthHurewicz.fourSixSimplexHomotopy_zero {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 4 X x)] (smp : FirstHurewicz.SingularSimplex X 6)
+    (s : FirstHurewicz.Simplex 6) : fourSixSimplexHomotopy x smp (0, s) = smp s :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_zero _ _ _ _ smp s
+
+private theorem FifthHurewicz.fourSixSimplexHomotopy_face {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 4 X x)] :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 5 (fourFiveSimplexHomotopy x)
+      (fourSixSimplexHomotopy x) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_face
+    (HigherHurewicz.simplexStraighteningHomotopy 4 x) (fourFiveSimplexHomotopy x)
+    (fourFiveSimplexHomotopy_face x) (fourFiveSimplexHomotopy_zero x)
+
+private def FifthHurewicz.normalizationFourSimplexHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] :
+    FirstHurewicz.SingularSimplex X 4 → C((unitInterval) × FirstHurewicz.Simplex 4, X) :=
+  ThirdHurewicz.composeSimplexHomotopies (FourthHurewicz.normalizationFourSimplexHomotopy x)
+    (HigherHurewicz.simplexStraighteningHomotopy 4 x)
+    (FourthHurewicz.normalizationFourSimplexHomotopy_zero x)
+    (HigherHurewicz.simplexStraighteningHomotopy_zero 4 x)
+
+private def FifthHurewicz.normalizationFiveSimplexHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] :
+    FirstHurewicz.SingularSimplex X 5 → C((unitInterval) × FirstHurewicz.Simplex 5, X) :=
+  ThirdHurewicz.composeSimplexHomotopies (FourthHurewicz.normalizationFiveSimplexHomotopy x)
+    (fourFiveSimplexHomotopy x) (FourthHurewicz.normalizationFiveSimplexHomotopy_zero x)
+    (fourFiveSimplexHomotopy_zero x)
+
+private def FifthHurewicz.normalizationSixSimplexHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] :
+    FirstHurewicz.SingularSimplex X 6 → C((unitInterval) × FirstHurewicz.Simplex 6, X) :=
+  ThirdHurewicz.composeSimplexHomotopies (lowerSixSimplexHomotopy x) (fourSixSimplexHomotopy x)
+    (lowerSixSimplexHomotopy_zero x) (fourSixSimplexHomotopy_zero x)
+
+@[simp]
+private theorem FifthHurewicz.normalizationFiveSimplexHomotopy_zero {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] (smp : FirstHurewicz.SingularSimplex X 5)
+    (s : FirstHurewicz.Simplex 5) : normalizationFiveSimplexHomotopy x smp (0, s) = smp s :=
+  ThirdHurewicz.composeSimplexHomotopies_zero _ _ _ _ smp s
+
+@[simp]
+private theorem FifthHurewicz.normalizationSixSimplexHomotopy_zero {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] (smp : FirstHurewicz.SingularSimplex X 6)
+    (s : FirstHurewicz.Simplex 6) : normalizationSixSimplexHomotopy x smp (0, s) = smp s :=
+  ThirdHurewicz.composeSimplexHomotopies_zero _ _ _ _ smp s
+
+private theorem FifthHurewicz.normalizationHomotopy_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 4 (normalizationFourSimplexHomotopy x)
+      (normalizationFiveSimplexHomotopy x) :=
+  ThirdHurewicz.composeSimplexHomotopies_face (FourthHurewicz.normalizationFourSimplexHomotopy x)
+    (HigherHurewicz.simplexStraighteningHomotopy 4 x)
+    (FourthHurewicz.normalizationFiveSimplexHomotopy x) (fourFiveSimplexHomotopy x)
+    (FourthHurewicz.normalizationFourSimplexHomotopy_zero x)
+    (HigherHurewicz.simplexStraighteningHomotopy_zero 4 x)
+    (FourthHurewicz.normalizationFiveSimplexHomotopy_zero x) (fourFiveSimplexHomotopy_zero x)
+    (FourthHurewicz.normalizationFiveHomotopy_face x) (fourFiveSimplexHomotopy_face x)
+
+private theorem FifthHurewicz.normalizationSixHomotopy_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 5 (normalizationFiveSimplexHomotopy x)
+      (normalizationSixSimplexHomotopy x) :=
+  ThirdHurewicz.composeSimplexHomotopies_face (FourthHurewicz.normalizationFiveSimplexHomotopy x)
+    (fourFiveSimplexHomotopy x) (lowerSixSimplexHomotopy x) (fourSixSimplexHomotopy x)
+    (FourthHurewicz.normalizationFiveSimplexHomotopy_zero x) (fourFiveSimplexHomotopy_zero x)
+    (lowerSixSimplexHomotopy_zero x) (fourSixSimplexHomotopy_zero x)
+    (lowerSixSimplexHomotopy_face x) (fourSixSimplexHomotopy_face x)
+
+@[simp]
+private theorem FifthHurewicz.normalizationFourSimplexHomotopy_const {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] :
+    normalizationFourSimplexHomotopy x (ContinuousMap.const (FirstHurewicz.Simplex 4) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 4) x :=
+  ThirdHurewicz.composeSimplexHomotopies_const (FourthHurewicz.normalizationFourSimplexHomotopy x)
+    (HigherHurewicz.simplexStraighteningHomotopy 4 x)
+    (FourthHurewicz.normalizationFourSimplexHomotopy_zero x)
+    (HigherHurewicz.simplexStraighteningHomotopy_zero 4 x) x
+    (FourthHurewicz.normalizationFourSimplexHomotopy_const x)
+    (HigherHurewicz.simplexStraighteningHomotopy_const 4 x)
+
+@[simp]
+private theorem FifthHurewicz.normalizationFiveSimplexHomotopy_const {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] :
+    normalizationFiveSimplexHomotopy x (ContinuousMap.const (FirstHurewicz.Simplex 5) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 5) x :=
+  ThirdHurewicz.composeSimplexHomotopies_const (FourthHurewicz.normalizationFiveSimplexHomotopy x)
+    (fourFiveSimplexHomotopy x) (FourthHurewicz.normalizationFiveSimplexHomotopy_zero x)
+    (fourFiveSimplexHomotopy_zero x) x (FourthHurewicz.normalizationFiveSimplexHomotopy_const x)
+    (fourFiveSimplexHomotopy_const x)
+
+@[simp]
+private theorem
+    FifthHurewicz.normalizationFourSimplexHomotopy_endpoint {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] (smp : FirstHurewicz.SingularSimplex X 4) :
+    SecondHurewicz.SimplyConnected.timeSlice (normalizationFourSimplexHomotopy x smp) 1 =
+      ContinuousMap.const (FirstHurewicz.Simplex 4) x := by
+  rw [normalizationFourSimplexHomotopy, ThirdHurewicz.timeSlice_composeSimplexHomotopies_one,
+    FourthHurewicz.normalizationFourSimplexHomotopy_endpoint]
+  ext s
+  exact
+    HigherHurewicz.simplexStraighteningHomotopy_one 4 x
+      (FourthHurewicz.normalizedFourSimplex x smp).val
+      (FourthHurewicz.normalizedFourSimplex x smp).property s
+
+private abbrev FifthHurewicz.fiveSimplexBoundary : Set (FirstHurewicz.Simplex 5) :=
+  SecondHurewicz.SimplyConnected.simplexBoundary 5
+
+private abbrev FifthHurewicz.BasedFiveSimplex {X : Type*} [TopologicalSpace X] (x : X) :=
+  HigherHurewicz.SimplexGeometry.BasedSimplex 5 x
+
+private abbrev FifthHurewicz.basedFiveSimplexLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (τ : BasedFiveSimplex x) : GenLoop (Fin 5) X x :=
+  HigherHurewicz.SimplexGeometry.basedSimplexLoop τ
+
+private abbrev FifthHurewicz.basedFiveSimplexClass {X : Type*} [TopologicalSpace X] {x : X}
+    (τ : BasedFiveSimplex x) : Additive (π_ 5 X x) :=
+  HigherHurewicz.SimplexGeometry.basedSimplexClass τ
+
+private theorem FifthHurewicz.basedFiveSimplex_face {X : Type*} [TopologicalSpace X] {x : X}
+    (τ : BasedFiveSimplex x) (i : Fin 6) :
+    τ.val.comp (FirstHurewicz.simplexFace 4 i) =
+      ContinuousMap.const (FirstHurewicz.Simplex 4) x :=
+  HigherHurewicz.SimplexGeometry.basedSimplex_face τ i
+
+private def
+    FifthHurewicz.normalizedFiveSimplex {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] [Subsingleton (π_ 4 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 5) : BasedFiveSimplex x :=
+  ⟨SecondHurewicz.SimplyConnected.timeSlice (normalizationFiveSimplexHomotopy x smp) 1,
+    HigherHurewicz.simplexEndpoint_boundary (normalizationFourSimplexHomotopy x)
+      (normalizationFiveSimplexHomotopy x) (normalizationHomotopy_face x) x
+      (normalizationFourSimplexHomotopy_endpoint x) smp⟩
+
+private theorem
+    FifthHurewicz.normalizationFiveSimplexHomotopy_endpoint {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] (smp : FirstHurewicz.SingularSimplex X 5) :
+    SecondHurewicz.SimplyConnected.timeSlice (normalizationFiveSimplexHomotopy x smp) 1 =
+      (normalizedFiveSimplex x smp).val :=
+  rfl
+
+private def
+    FifthHurewicz.normalizedSixSimplexMap {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] [Subsingleton (π_ 4 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 6) : FirstHurewicz.SingularSimplex X 6 :=
+  SecondHurewicz.SimplyConnected.timeSlice (normalizationSixSimplexHomotopy x smp) 1
+
+private theorem FifthHurewicz.normalizedSixSimplexMap_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] (smp : FirstHurewicz.SingularSimplex X 6) (i : Fin 7) :
+    (normalizedSixSimplexMap x smp).comp (FirstHurewicz.simplexFace 5 i) =
+      (normalizedFiveSimplex x (smp.comp (FirstHurewicz.simplexFace 5 i))).val :=
+  SecondHurewicz.SimplyConnected.timeSlice_face (normalizationSixHomotopy_face x) smp i 1
+
+private theorem FifthHurewicz.normalizedSixSimplexMap_face_boundary {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] (smp : FirstHurewicz.SingularSimplex X 6) (i : Fin 7)
+    (s : FirstHurewicz.Simplex 5) (hs : s ∈ fiveSimplexBoundary) :
+    normalizedSixSimplexMap x smp (FirstHurewicz.simplexFace 5 i s) = x := by
+  have hf :=
+    congrArg (fun f : C(FirstHurewicz.Simplex 5, X) => f s) (normalizedSixSimplexMap_face x smp i)
+  exact
+    hf.trans ((normalizedFiveSimplex x (smp.comp (FirstHurewicz.simplexFace 5 i))).property s hs)
+
+private def FifthHurewicz.fiveSimplexClassOperator {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] : FirstHurewicz.Chains X 5 →ₗ[ℤ] Additive (π_ 5 X x) :=
+  FirstHurewicz.chainLift X 5 fun smp => basedFiveSimplexClass (normalizedFiveSimplex x smp)
+
+@[simp]
+private theorem FifthHurewicz.fiveSimplexClassOperator_simplex {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] (smp : FirstHurewicz.SingularSimplex X 5) :
+    fiveSimplexClassOperator x (FirstHurewicz.simplexChain X 5 smp) =
+      basedFiveSimplexClass (normalizedFiveSimplex x smp) :=
+  FirstHurewicz.chainLift_simplex X 5 _ smp
+
+private abbrev FifthHurewicz.BasedSixSimplex {X : Type*} [TopologicalSpace X] (x : X) :=
+  HigherHurewicz.SimplexGeometry.BasedSimplexBoundary 6 x
+
+private abbrev FifthHurewicz.basedSixSimplexFace {X : Type*} [TopologicalSpace X] {x : X}
+    (τ : BasedSixSimplex x) (i : Fin 7) : BasedFiveSimplex x :=
+  HigherHurewicz.SimplexGeometry.basedSimplexBoundaryFace τ i
+
+private def FifthHurewicz.BasedSixSimplex.ofFaces {X : Type*} [TopologicalSpace X] {x : X}
+    (τ : C(FirstHurewicz.Simplex 6, X))
+    (h :
+      ∀ i : Fin 7,
+        ∀ s ∈ FifthHurewicz.fiveSimplexBoundary, (τ.comp (FirstHurewicz.simplexFace 5 i)) s = x) :
+    FifthHurewicz.BasedSixSimplex x :=
+  HigherHurewicz.SimplexGeometry.BasedSimplexBoundary.ofFaces τ h
+
+private theorem
+    FifthHurewicz.basedSixSimplex_signed_relation {X : Type*} [TopologicalSpace X] {x : X}
+    (τ : BasedSixSimplex x) :
+    (∑ i : Fin 7, (-1 : ℤ) ^ i.val • basedFiveSimplexClass (basedSixSimplexFace τ i)) = 0 :=
+  HigherHurewicz.SimplexGeometry.basedSimplexBoundary_signed_relation (n := 3) τ
+
+private def
+    FifthHurewicz.normalizedSixSimplex {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] [Subsingleton (π_ 4 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 6) : BasedSixSimplex x :=
+  BasedSixSimplex.ofFaces (normalizedSixSimplexMap x smp)
+    (normalizedSixSimplexMap_face_boundary x smp)
+
+@[simp]
+private theorem FifthHurewicz.normalizedSixSimplex_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] (smp : FirstHurewicz.SingularSimplex X 6) (i : Fin 7) :
+    basedSixSimplexFace (normalizedSixSimplex x smp) i =
+      normalizedFiveSimplex x (smp.comp (FirstHurewicz.simplexFace 5 i)) := by
+  apply Subtype.ext
+  exact normalizedSixSimplexMap_face x smp i
+
+private theorem
+    FifthHurewicz.normalizedFiveSimplex_boundary_relation {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] (smp : FirstHurewicz.SingularSimplex X 6) :
+    ∑ i : Fin 7,
+        (-1 : ℤ) ^ i.val •
+          basedFiveSimplexClass
+            (normalizedFiveSimplex x (smp.comp (FirstHurewicz.simplexFace 5 i))) =
+      0 := by
+  simpa only [normalizedSixSimplex_face] using
+    basedSixSimplex_signed_relation (normalizedSixSimplex x smp)
+
+private theorem FifthHurewicz.fiveSimplexClassOperator_boundary {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] (b : FirstHurewicz.Chains X 6) :
+    fiveSimplexClassOperator x (((FirstHurewicz.singularComplex X).d 6 5).hom b) = 0 := by
+  have h : (fiveSimplexClassOperator x).comp ((FirstHurewicz.singularComplex X).d 6 5).hom = 0 := by
+    apply FirstHurewicz.chainMap_ext X 6
+    intro smp
+    simp only [LinearMap.comp_apply, FirstHurewicz.boundary_simplex, map_sum, map_zsmul,
+      fiveSimplexClassOperator_simplex, LinearMap.zero_apply]
+    exact normalizedFiveSimplex_boundary_relation x smp
+  exact LinearMap.congr_fun h b
+
+private def
+    FifthHurewicz.normalizedCube {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X] (x : X)
+    [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] [Subsingleton (π_ 4 X x)]
+    (p : GenLoop (Fin 5) X x) : GenLoop (Fin 5) X x :=
+  HigherHurewicz.CubeGluing.coherentCubeEndpoint (normalizationFourSimplexHomotopy x)
+    (normalizationFiveSimplexHomotopy x) (normalizationHomotopy_face x)
+    (normalizationFourSimplexHomotopy_const x) p
+
+private theorem
+    FifthHurewicz.normalizedCube_cell {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] [Subsingleton (π_ 4 X x)]
+    (p : GenLoop (Fin 5) X x) (e : Equiv.Perm (Fin 5)) :
+    (normalizedCube x p).val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e) =
+      (normalizedFiveSimplex x
+          (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e))).val :=
+  HigherHurewicz.CubeGluing.coherentCubeEndpoint_cell (normalizationFourSimplexHomotopy x)
+    (normalizationFiveSimplexHomotopy x) (normalizationHomotopy_face x)
+    (normalizationFourSimplexHomotopy_const x) p e
+
+private def FifthHurewicz.normalizationCubeHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] (p : GenLoop (Fin 5) X x) :
+    p.val.HomotopyRel (normalizedCube x p).val (Cube.boundary (Fin 5)) :=
+  HigherHurewicz.CubeGluing.coherentCubeHomotopy (normalizationFourSimplexHomotopy x)
+    (normalizationFiveSimplexHomotopy x) (normalizationHomotopy_face x)
+    (normalizationFourSimplexHomotopy_const x) (normalizationFiveSimplexHomotopy_zero x) p
+
+private theorem FifthHurewicz.normalizedCube_internalBased {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] (p : GenLoop (Fin 5) X x) (u : Fin 5 → (unitInterval)) (i j : Fin 5)
+    (hij : i ≠ j) (hu : u i = u j) : normalizedCube x p u = x :=
+  HigherHurewicz.coherentCubeEndpoint_internalBased (normalizationFourSimplexHomotopy x)
+    (normalizationFiveSimplexHomotopy x) (normalizationHomotopy_face x)
+    (normalizationFourSimplexHomotopy_const x) (normalizationFourSimplexHomotopy_endpoint x) p u i
+    j hij hu
+
+private theorem FifthHurewicz.normalizedCube_simplex {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] (p : GenLoop (Fin 5) X x) (e : Equiv.Perm (Fin 5)) :
+    HigherHurewicz.NativeSubdivision.nativeBasedCubeSimplex (normalizedCube x p)
+        (normalizedCube_internalBased x p) e =
+      normalizedFiveSimplex x (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e)) := by
+  apply Subtype.ext
+  exact normalizedCube_cell x p e
+
+private abbrev FifthHurewicz.Remaining :=
+  { j : Fin 5 // j ≠ 0 }
+
+private def
+    FifthHurewicz.remainingCoordinates : C(Fin 4 → (unitInterval), Remaining → (unitInterval))
+    where
+  toFun u j := u (j.val.pred j.property)
+  continuous_toFun := by fun_prop
+
+@[simp]
+private theorem FifthHurewicz.remainingCoordinates_succ (u : Fin 4 → (unitInterval)) (i : Fin 4) :
+    remainingCoordinates u ⟨i.succ, Fin.succ_ne_zero i⟩ = u i := by simp [remainingCoordinates]
+
+private theorem FifthHurewicz.remainingCoordinates_boundary {u : Fin 4 → (unitInterval)}
+    (h : u ∈ Cube.boundary (Fin 4)) : remainingCoordinates u ∈ Cube.boundary Remaining := by
+  obtain ⟨i, hi⟩ := h
+  exact ⟨⟨i.succ, Fin.succ_ne_zero i⟩, by simpa using hi⟩
+
+private abbrev FifthHurewicz.BasedLoopSpace {X : Type} [TopologicalSpace X] (x : X) :=
+  GenLoop Remaining X x
+
+private def FifthHurewicz.evaluation {X : Type} [TopologicalSpace X] (x : X) :
+    C(BasedLoopSpace x × (Fin 4 → (unitInterval)), X)
+    where
+  toFun z := z.1 (remainingCoordinates z.2)
+  continuous_toFun := by fun_prop
+
+private theorem FifthHurewicz.evaluation_boundary {X : Type} [TopologicalSpace X] (x : X)
+    (p : BasedLoopSpace x) (u : Fin 4 → (unitInterval)) (hu : u ∈ Cube.boundary (Fin 4)) :
+    evaluation x (p, u) = x :=
+  GenLoop.boundary p _ (remainingCoordinates_boundary hu)
+
+private theorem FifthHurewicz.evaluation_comp_boundary {X : Type} [TopologicalSpace X] {A : Type}
+    [TopologicalSpace A] (x : X) (f : C(A, Fin 4 → (unitInterval)))
+    (hf : ∀ a, f a ∈ Cube.boundary (Fin 4)) :
+    (evaluation x).comp ((ContinuousMap.id (BasedLoopSpace x)).prodMap f) =
+      ContinuousMap.const (BasedLoopSpace x × A) x := by
+  ext z
+  exact evaluation_boundary x z.1 (f z.2) (hf z.2)
+
+private def FifthHurewicz.cubeCoordinates :
+    C((unitInterval) × (Fin 4 → (unitInterval)), Fin 5 → (unitInterval))
+    where
+  toFun z := Cube.insertAt (0 : Fin 5) (z.1, remainingCoordinates z.2)
+  continuous_toFun := by fun_prop
+
+@[simp]
+private theorem FifthHurewicz.cubeCoordinates_zero (z : (unitInterval) × (Fin 4 → (unitInterval))) :
+    cubeCoordinates z 0 = z.1 := by
+  simp [cubeCoordinates, Cube.insertAt, Homeomorph.funSplitAt_symm_apply]
+
+@[simp]
+private theorem FifthHurewicz.cubeCoordinates_succ (z : (unitInterval) × (Fin 4 → (unitInterval)))
+    (i : Fin 4) : cubeCoordinates z i.succ = z.2 i := by
+  simp [cubeCoordinates, Cube.insertAt, Homeomorph.funSplitAt_symm_apply, remainingCoordinates]
+
+private def
+    FifthHurewicz.cubeMap {X : Type} [TopologicalSpace X] {x : X} (p : GenLoop (Fin 5) X x) :
+    C((unitInterval) × (Fin 4 → (unitInterval)), X) :=
+  p.val.comp cubeCoordinates
+
+private theorem FifthHurewicz.evaluation_comp_toLoop {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 5) X x) :
+    (evaluation x).comp
+        ((GenLoop.toLoop (0 : Fin 5) p).toContinuousMap.prodMap
+          (ContinuousMap.id (Fin 4 → (unitInterval)))) =
+      cubeMap p := by
+  ext z
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def FifthHurewicz.remainingCubeSideFirst (t : (unitInterval)) :
+    C(Fin 3 → (unitInterval), Fin 4 → (unitInterval)) :=
+  FourthHurewicz.cubeCoordinates.comp (PeriodTorusHigherHomology.crossInsertLeft t)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def FifthHurewicz.remainingCubeSide {A : Type} [TopologicalSpace A]
+    (f : C(A, Fin 3 → (unitInterval))) : C((unitInterval) × A, Fin 4 → (unitInterval)) :=
+  FourthHurewicz.cubeCoordinates.comp ((ContinuousMap.id (unitInterval)).prodMap f)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    FifthHurewicz.remainingCubeSideFirst_boundary (t : (unitInterval)) (ht : t = 0 ∨ t = 1)
+    (u : Fin 3 → (unitInterval)) : remainingCubeSideFirst t u ∈ Cube.boundary (Fin 4) := by
+  refine ⟨0, ?_⟩
+  change FourthHurewicz.cubeCoordinates (t, u) 0 = 0 ∨ FourthHurewicz.cubeCoordinates (t, u) 0 = 1
+  simpa only [FourthHurewicz.cubeCoordinates_zero] using ht
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FifthHurewicz.remainingCubeSide_boundary {A : Type} [TopologicalSpace A]
+    (f : C(A, Fin 3 → (unitInterval))) (hf : ∀ a, f a ∈ Cube.boundary (Fin 3))
+    (z : (unitInterval) × A) : remainingCubeSide f z ∈ Cube.boundary (Fin 4) := by
+  obtain ⟨i, hi⟩ := hf z.2
+  refine ⟨i.succ, ?_⟩
+  change
+    FourthHurewicz.cubeCoordinates (z.1, f z.2) i.succ = 0 ∨
+      FourthHurewicz.cubeCoordinates (z.1, f z.2) i.succ = 1
+  simpa only [FourthHurewicz.cubeCoordinates_succ] using hi
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FifthHurewicz.remainingCubeSide_chain {A : Type} [TopologicalSpace A] (k : ℕ)
+    (f : C(A, Fin 3 → (unitInterval))) (b : FirstHurewicz.Chains A k) :
+    FirstHurewicz.inducedChain FourthHurewicz.cubeCoordinates (k + 1)
+        (PeriodTorusHigherHomology.crossProductEdge (unitInterval) (Fin 3 → (unitInterval)) k
+          SecondHurewicz.intervalChain (FirstHurewicz.inducedChain f k b)) =
+      FirstHurewicz.inducedChain (remainingCubeSide f) (k + 1)
+        (PeriodTorusHigherHomology.crossProductEdge (unitInterval) A k
+          SecondHurewicz.intervalChain b) := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductEdge_natural (ContinuousMap.id (unitInterval)) f k
+      SecondHurewicz.intervalChain b
+  rw [FirstHurewicz.inducedChain_id, LinearMap.id_apply] at h
+  rw [← h]
+  change
+    ((FirstHurewicz.inducedChain FourthHurewicz.cubeCoordinates (k + 1)).comp
+          (FirstHurewicz.inducedChain ((ContinuousMap.id (unitInterval)).prodMap f) (k + 1)))
+        _ =
+      _
+  rw [← FirstHurewicz.inducedChain_comp]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def FifthHurewicz.productThreeIntervalChain :
+    FirstHurewicz.Chains ((unitInterval) × ((unitInterval) × (unitInterval))) 3 :=
+  PeriodTorusHigherHomology.crossProductEdge (unitInterval) ((unitInterval) × (unitInterval)) 2
+    SecondHurewicz.intervalChain SecondHurewicz.productSquareChain
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FifthHurewicz.remainingCubeChain_boundary :
+    ((FirstHurewicz.singularComplex (Fin 4 → (unitInterval))).d 4 3).hom
+        FourthHurewicz.fundamentalCubeChain =
+      FirstHurewicz.inducedChain (remainingCubeSideFirst 1) 3 ThirdHurewicz.fundamentalCubeChain -
+          FirstHurewicz.inducedChain (remainingCubeSideFirst 0) 3
+            ThirdHurewicz.fundamentalCubeChain -
+        (FirstHurewicz.inducedChain (remainingCubeSide (FourthHurewicz.remainingCubeSideFirst 1))
+              3 ThirdHurewicz.productCubeChain -
+            FirstHurewicz.inducedChain
+              (remainingCubeSide (FourthHurewicz.remainingCubeSideFirst 0)) 3
+              ThirdHurewicz.productCubeChain -
+          (FirstHurewicz.inducedChain
+                (remainingCubeSide
+                  (FourthHurewicz.remainingCubeSide (ThirdHurewicz.squareSideLeft 1)))
+                3 productThreeIntervalChain -
+              FirstHurewicz.inducedChain
+                (remainingCubeSide
+                  (FourthHurewicz.remainingCubeSide (ThirdHurewicz.squareSideLeft 0)))
+                3 productThreeIntervalChain -
+            (FirstHurewicz.inducedChain
+                (remainingCubeSide
+                  (FourthHurewicz.remainingCubeSide (ThirdHurewicz.squareSideRight 1)))
+                3 productThreeIntervalChain -
+              FirstHurewicz.inducedChain
+                (remainingCubeSide
+                  (FourthHurewicz.remainingCubeSide (ThirdHurewicz.squareSideRight 0)))
+                3 productThreeIntervalChain))) := by
+  have hpoint (t : (unitInterval)) :
+    PeriodTorusHigherHomology.crossProductZeroLeft (unitInterval) (Fin 3 → (unitInterval)) 3
+        (FirstHurewicz.pointChain t) ThirdHurewicz.fundamentalCubeChain =
+      FirstHurewicz.inducedChain (PeriodTorusHigherHomology.crossInsertLeft t) 3
+        ThirdHurewicz.fundamentalCubeChain := by
+    rw [FirstHurewicz.pointChain, PeriodTorusHigherHomology.crossProductZeroLeft_simplex_left]
+    rfl
+  have hfirst (t : (unitInterval)) :
+    FirstHurewicz.inducedChain FourthHurewicz.cubeCoordinates 3
+        (FirstHurewicz.inducedChain (PeriodTorusHigherHomology.crossInsertLeft t) 3
+          ThirdHurewicz.fundamentalCubeChain) =
+      FirstHurewicz.inducedChain (remainingCubeSideFirst t) 3
+        ThirdHurewicz.fundamentalCubeChain := by
+    rw [remainingCubeSideFirst, FirstHurewicz.inducedChain_comp]
+    rfl
+  rw [FourthHurewicz.fundamentalCubeChain, ← FirstHurewicz.inducedChain_boundary]
+  change
+    FirstHurewicz.inducedChain FourthHurewicz.cubeCoordinates 3
+        (((FirstHurewicz.singularComplex ((unitInterval) × (Fin 3 → (unitInterval)))).d 4 3).hom
+          (PeriodTorusHigherHomology.crossProductEdge (unitInterval) (Fin 3 → (unitInterval)) 3
+            SecondHurewicz.intervalChain ThirdHurewicz.fundamentalCubeChain)) =
+      _
+  rw [PeriodTorusHigherHomology.crossProductEdge_boundary 2]
+  change
+    FirstHurewicz.inducedChain FourthHurewicz.cubeCoordinates 3
+        (PeriodTorusHigherHomology.crossProductZeroLeft (unitInterval) (Fin 3 → (unitInterval)) 3
+            (FirstHurewicz.boundaryOne (unitInterval) SecondHurewicz.intervalChain)
+            ThirdHurewicz.fundamentalCubeChain -
+          PeriodTorusHigherHomology.crossProductEdge (unitInterval) (Fin 3 → (unitInterval)) 2
+            SecondHurewicz.intervalChain
+            (((FirstHurewicz.singularComplex (Fin 3 → (unitInterval))).d 3 2).hom
+              ThirdHurewicz.fundamentalCubeChain)) =
+      _
+  rw [SecondHurewicz.intervalChain_boundary, FourthHurewicz.remainingCubeChain_boundary]
+  simp only [map_sub, LinearMap.sub_apply, hpoint, hfirst, remainingCubeSide_chain]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FifthHurewicz.evaluated_edge_boundaryMap {X A : Type} [TopologicalSpace X]
+    [TopologicalSpace A] (x : X) (a : FirstHurewicz.Chains (BasedLoopSpace x) 1) (k : ℕ)
+    (b : FirstHurewicz.Chains A k) (f : C(A, Fin 4 → (unitInterval)))
+    (hf : ∀ t, f t ∈ Cube.boundary (Fin 4)) :
+    FirstHurewicz.inducedChain (evaluation x) (k + 1)
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 4 → (unitInterval)) k
+          a (FirstHurewicz.inducedChain f k b)) =
+      FirstHurewicz.inducedChain (ContinuousMap.const (BasedLoopSpace x × A) x) (k + 1)
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) A k a b) := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductEdge_natural (ContinuousMap.id (BasedLoopSpace x)) f k a
+      b
+  rw [FirstHurewicz.inducedChain_id, LinearMap.id_apply] at h
+  rw [← h]
+  change
+    ((FirstHurewicz.inducedChain (evaluation x) (k + 1)).comp
+          (FirstHurewicz.inducedChain ((ContinuousMap.id (BasedLoopSpace x)).prodMap f) (k + 1)))
+        _ =
+      _
+  rw [← FirstHurewicz.inducedChain_comp, evaluation_comp_boundary x f hf]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FifthHurewicz.evaluated_triangle_boundaryMap {X A : Type} [TopologicalSpace X]
+    [TopologicalSpace A] (x : X) (a : FirstHurewicz.Chains (BasedLoopSpace x) 2) (k : ℕ)
+    (b : FirstHurewicz.Chains A k) (f : C(A, Fin 4 → (unitInterval)))
+    (hf : ∀ t, f t ∈ Cube.boundary (Fin 4)) :
+    FirstHurewicz.inducedChain (evaluation x) (k + 2)
+        (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x)
+          (Fin 4 → (unitInterval)) k a (FirstHurewicz.inducedChain f k b)) =
+      FirstHurewicz.inducedChain (ContinuousMap.const (BasedLoopSpace x × A) x) (k + 2)
+        (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x) A k a b) := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductTriangle_natural (ContinuousMap.id (BasedLoopSpace x)) f
+      k a b
+  rw [FirstHurewicz.inducedChain_id, LinearMap.id_apply] at h
+  rw [← h]
+  change
+    ((FirstHurewicz.inducedChain (evaluation x) (k + 2)).comp
+          (FirstHurewicz.inducedChain ((ContinuousMap.id (BasedLoopSpace x)).prodMap f) (k + 2)))
+        _ =
+      _
+  rw [← FirstHurewicz.inducedChain_comp, evaluation_comp_boundary x f hf]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    FifthHurewicz.evaluated_edge_cubeBoundary_cancel {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 1) :
+    FirstHurewicz.inducedChain (evaluation x) 4
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 4 → (unitInterval)) 3
+          a
+          (((FirstHurewicz.singularComplex (Fin 4 → (unitInterval))).d 4 3).hom
+            FourthHurewicz.fundamentalCubeChain)) =
+      0 := by
+  have hF (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_edge_boundaryMap x a 3 ThirdHurewicz.fundamentalCubeChain (remainingCubeSideFirst t)
+      (remainingCubeSideFirst_boundary t ht)
+  have hS (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_edge_boundaryMap x a 3 ThirdHurewicz.productCubeChain
+      (remainingCubeSide (FourthHurewicz.remainingCubeSideFirst t))
+      (remainingCubeSide_boundary _ (FourthHurewicz.remainingCubeSideFirst_boundary t ht))
+  have hL (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_edge_boundaryMap x a 3 productThreeIntervalChain
+      (remainingCubeSide (FourthHurewicz.remainingCubeSide (ThirdHurewicz.squareSideLeft t)))
+      (remainingCubeSide_boundary _
+        (FourthHurewicz.remainingCubeSide_boundary _
+          (ThirdHurewicz.squareSideLeft_boundary t ht)))
+  have hR (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_edge_boundaryMap x a 3 productThreeIntervalChain
+      (remainingCubeSide (FourthHurewicz.remainingCubeSide (ThirdHurewicz.squareSideRight t)))
+      (remainingCubeSide_boundary _
+        (FourthHurewicz.remainingCubeSide_boundary _
+          (ThirdHurewicz.squareSideRight_boundary t ht)))
+  simp only [remainingCubeChain_boundary, map_sub, hF 1 (Or.inr rfl), hF 0 (Or.inl rfl),
+    hS 1 (Or.inr rfl), hS 0 (Or.inl rfl), hL 1 (Or.inr rfl), hL 0 (Or.inl rfl), hR 1 (Or.inr rfl),
+    hR 0 (Or.inl rfl), sub_self]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FifthHurewicz.evaluated_triangle_cubeBoundary_cancel {X : Type} [TopologicalSpace X]
+    (x : X) (a : FirstHurewicz.Chains (BasedLoopSpace x) 2) :
+    FirstHurewicz.inducedChain (evaluation x) 5
+        (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x)
+          (Fin 4 → (unitInterval)) 3 a
+          (((FirstHurewicz.singularComplex (Fin 4 → (unitInterval))).d 4 3).hom
+            FourthHurewicz.fundamentalCubeChain)) =
+      0 := by
+  have hF (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_triangle_boundaryMap x a 3 ThirdHurewicz.fundamentalCubeChain
+      (remainingCubeSideFirst t) (remainingCubeSideFirst_boundary t ht)
+  have hS (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_triangle_boundaryMap x a 3 ThirdHurewicz.productCubeChain
+      (remainingCubeSide (FourthHurewicz.remainingCubeSideFirst t))
+      (remainingCubeSide_boundary _ (FourthHurewicz.remainingCubeSideFirst_boundary t ht))
+  have hL (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_triangle_boundaryMap x a 3 productThreeIntervalChain
+      (remainingCubeSide (FourthHurewicz.remainingCubeSide (ThirdHurewicz.squareSideLeft t)))
+      (remainingCubeSide_boundary _
+        (FourthHurewicz.remainingCubeSide_boundary _
+          (ThirdHurewicz.squareSideLeft_boundary t ht)))
+  have hR (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_triangle_boundaryMap x a 3 productThreeIntervalChain
+      (remainingCubeSide (FourthHurewicz.remainingCubeSide (ThirdHurewicz.squareSideRight t)))
+      (remainingCubeSide_boundary _
+        (FourthHurewicz.remainingCubeSide_boundary _
+          (ThirdHurewicz.squareSideRight_boundary t ht)))
+  simp only [remainingCubeChain_boundary, map_sub, hF 1 (Or.inr rfl), hF 0 (Or.inl rfl),
+    hS 1 (Or.inr rfl), hS 0 (Or.inl rfl), hL 1 (Or.inr rfl), hL 0 (Or.inl rfl), hR 1 (Or.inr rfl),
+    hR 0 (Or.inl rfl), sub_self]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def FifthHurewicz.suspensionOne {X : Type} [TopologicalSpace X] (x : X) :
+    FirstHurewicz.Chains (BasedLoopSpace x) 1 →ₗ[ℤ] FirstHurewicz.Chains X 5 :=
+  (FirstHurewicz.inducedChain (evaluation x) 5).comp
+    (PeriodTorusHigherHomology.integerBilinearRightApply
+      (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 4 → (unitInterval)) 4)
+      FourthHurewicz.fundamentalCubeChain)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem FifthHurewicz.suspensionOne_apply {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 1) :
+    suspensionOne x a =
+      FirstHurewicz.inducedChain (evaluation x) 5
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 4 → (unitInterval)) 4
+          a FourthHurewicz.fundamentalCubeChain) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def FifthHurewicz.suspensionTwo {X : Type} [TopologicalSpace X] (x : X) :
+    FirstHurewicz.Chains (BasedLoopSpace x) 2 →ₗ[ℤ] FirstHurewicz.Chains X 6 :=
+  (FirstHurewicz.inducedChain (evaluation x) 6).comp
+    (PeriodTorusHigherHomology.integerBilinearRightApply
+      (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x) (Fin 4 → (unitInterval))
+        4)
+      FourthHurewicz.fundamentalCubeChain)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem FifthHurewicz.suspensionTwo_apply {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 2) :
+    suspensionTwo x a =
+      FirstHurewicz.inducedChain (evaluation x) 6
+        (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x)
+          (Fin 4 → (unitInterval)) 4 a FourthHurewicz.fundamentalCubeChain) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    FifthHurewicz.boundaryFive_suspensionOne_of_cycle {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 1)
+    (ha : FirstHurewicz.boundaryOne (BasedLoopSpace x) a = 0) :
+    ((FirstHurewicz.singularComplex X).d 5 4).hom (suspensionOne x a) = 0 := by
+  rw [suspensionOne_apply, ← FirstHurewicz.inducedChain_boundary,
+    PeriodTorusHigherHomology.crossProductEdge_boundary 3]
+  change
+    FirstHurewicz.inducedChain (evaluation x) 4
+        (PeriodTorusHigherHomology.crossProductZeroLeft (BasedLoopSpace x)
+            (Fin 4 → (unitInterval)) 4 (FirstHurewicz.boundaryOne (BasedLoopSpace x) a)
+            FourthHurewicz.fundamentalCubeChain -
+          PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 4 → (unitInterval)) 3
+            a
+            (((FirstHurewicz.singularComplex (Fin 4 → (unitInterval))).d 4 3).hom
+              FourthHurewicz.fundamentalCubeChain)) =
+      0
+  rw [ha, map_zero, LinearMap.zero_apply, zero_sub, map_neg, evaluated_edge_cubeBoundary_cancel,
+    neg_zero]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FifthHurewicz.boundarySix_suspensionTwo {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 2) :
+    ((FirstHurewicz.singularComplex X).d 6 5).hom (suspensionTwo x a) =
+      suspensionOne x (FirstHurewicz.boundaryTwo (BasedLoopSpace x) a) := by
+  rw [suspensionTwo_apply, ← FirstHurewicz.inducedChain_boundary,
+    PeriodTorusHigherHomology.crossProductTriangle_boundary 3]
+  change
+    FirstHurewicz.inducedChain (evaluation x) 5
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 4 → (unitInterval)) 4
+            (FirstHurewicz.boundaryTwo (BasedLoopSpace x) a) FourthHurewicz.fundamentalCubeChain +
+          PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x)
+            (Fin 4 → (unitInterval)) 3 a
+            (((FirstHurewicz.singularComplex (Fin 4 → (unitInterval))).d 4 3).hom
+              FourthHurewicz.fundamentalCubeChain)) =
+      _
+  rw [map_add, evaluated_triangle_cubeBoundary_cancel, add_zero]
+  rfl
+
+private def FifthHurewicz.pathCubeCycle {X : Type} [TopologicalSpace X] (x : X)
+    (p : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 5 :=
+  SingularMayerVietoris.ModuleHomology.mkCycle (FirstHurewicz.singularComplex X) 5
+    (suspensionOne x (FirstHurewicz.pathChain p))
+    (boundaryFive_suspensionOne_of_cycle x (FirstHurewicz.pathChain p)
+      (FirstHurewicz.boundaryOne_loop p))
+
+@[simp]
+private theorem FifthHurewicz.pathCubeCycle_val {X : Type} [TopologicalSpace X] (x : X)
+    (p : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    (pathCubeCycle x p).1 = suspensionOne x (FirstHurewicz.pathChain p) :=
+  rfl
+
+private def FifthHurewicz.pathCubeClass {X : Type} [TopologicalSpace X] (x : X)
+    (p : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    SingularMayerVietoris.SingularHomology X 5 :=
+  SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 5
+    (pathCubeCycle x p)
+
+private theorem FifthHurewicz.pathCube_homotopy_boundary {X : Type} [TopologicalSpace X] (x : X)
+    {p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const} (H : p.Homotopy q) :
+    ((FirstHurewicz.singularComplex X).d 6 5).hom
+        (suspensionTwo x (FirstHurewicz.homotopyChain H)) =
+      (pathCubeCycle x p).1 - (pathCubeCycle x q).1 := by
+  rw [boundarySix_suspensionTwo, FirstHurewicz.boundaryTwo_loopHomotopy, map_sub]
+  rfl
+
+private theorem FifthHurewicz.pathCubeClass_homotopy {X : Type} [TopologicalSpace X] (x : X)
+    {p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const} (H : p.Homotopy q) :
+    pathCubeClass x p = pathCubeClass x q :=
+  (SingularMayerVietoris.ModuleHomology.cycleClass_eq_iff (FirstHurewicz.singularComplex X) 5 _
+        _).mpr
+    ⟨suspensionTwo x (FirstHurewicz.homotopyChain H), pathCube_homotopy_boundary x H⟩
+
+private theorem FifthHurewicz.pathCubeClass_homotopic {X : Type} [TopologicalSpace X] (x : X)
+    {p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const} (h : p.Homotopic q) :
+    pathCubeClass x p = pathCubeClass x q := by
+  obtain ⟨H⟩ := h
+  exact pathCubeClass_homotopy x H
+
+@[simp]
+private theorem FifthHurewicz.pathCubeClass_refl {X : Type} [TopologicalSpace X] (x : X) :
+    pathCubeClass x (Path.refl (GenLoop.const : BasedLoopSpace x)) = 0 := by
+  apply
+    (SingularMayerVietoris.ModuleHomology.cycleClass_eq_zero_iff (FirstHurewicz.singularComplex X)
+        5 _).mpr
+  refine
+    ⟨suspensionTwo x (FirstHurewicz.constantTriangleChain (GenLoop.const : BasedLoopSpace x)), ?_⟩
+  rw [boundarySix_suspensionTwo, FirstHurewicz.boundaryTwo_constantTriangleChain]
+  rfl
+
+private theorem FifthHurewicz.pathCube_concat_boundary {X : Type} [TopologicalSpace X] (x : X)
+    (p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    ((FirstHurewicz.singularComplex X).d 6 5).hom
+        (-suspensionTwo x (FirstHurewicz.concatChain p q)) =
+      (pathCubeCycle x (p.trans q)).1 - ((pathCubeCycle x p).1 + (pathCubeCycle x q).1) := by
+  rw [map_neg, boundarySix_suspensionTwo, FirstHurewicz.boundaryTwo_concatChain, map_add, map_sub]
+  simp only [pathCubeCycle_val]
+  abel
+
+private theorem FifthHurewicz.pathCubeClass_trans {X : Type} [TopologicalSpace X] (x : X)
+    (p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    pathCubeClass x (p.trans q) = pathCubeClass x p + pathCubeClass x q := by
+  unfold pathCubeClass
+  rw [← map_add]
+  apply
+    (SingularMayerVietoris.ModuleHomology.cycleClass_eq_iff (FirstHurewicz.singularComplex X) 5 _
+        _).mpr
+  exact ⟨-suspensionTwo x (FirstHurewicz.concatChain p q), pathCube_concat_boundary x p q⟩
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def FifthHurewicz.productCubeChain :
+    FirstHurewicz.Chains ((unitInterval) × (Fin 4 → (unitInterval))) 5 :=
+  PeriodTorusHigherHomology.crossProductEdge (unitInterval) (Fin 4 → (unitInterval)) 4
+    SecondHurewicz.intervalChain FourthHurewicz.fundamentalCubeChain
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def FifthHurewicz.fundamentalCubeChain : FirstHurewicz.Chains (Fin 5 → (unitInterval)) 5 :=
+  FirstHurewicz.inducedChain cubeCoordinates 5 productCubeChain
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FifthHurewicz.suspensionOne_toLoop {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 5) X x) :
+    suspensionOne x (FirstHurewicz.pathChain (GenLoop.toLoop (0 : Fin 5) p)) =
+      FirstHurewicz.inducedChain (cubeMap p) 5 productCubeChain := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductEdge_natural
+      (GenLoop.toLoop (0 : Fin 5) p).toContinuousMap (ContinuousMap.id (Fin 4 → (unitInterval))) 4
+      SecondHurewicz.intervalChain FourthHurewicz.fundamentalCubeChain
+  rw [SecondHurewicz.induced_intervalChain, FirstHurewicz.inducedChain_id,
+    LinearMap.id_apply] at h
+  rw [suspensionOne_apply, ← h]
+  change
+    ((FirstHurewicz.inducedChain (evaluation x) 5).comp
+          (FirstHurewicz.inducedChain
+            ((GenLoop.toLoop (0 : Fin 5) p).toContinuousMap.prodMap
+              (ContinuousMap.id (Fin 4 → (unitInterval))))
+            5))
+        productCubeChain =
+      _
+  rw [← FirstHurewicz.inducedChain_comp, evaluation_comp_toLoop]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    FifthHurewicz.cubeChain {X : Type} [TopologicalSpace X] {x : X} (p : GenLoop (Fin 5) X x) :
+    FirstHurewicz.Chains X 5 :=
+  suspensionOne x (FirstHurewicz.pathChain (GenLoop.toLoop (0 : Fin 5) p))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FifthHurewicz.cubeChain_eq_induced {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 5) X x) :
+    cubeChain p = FirstHurewicz.inducedChain p.val 5 fundamentalCubeChain := by
+  rw [cubeChain, suspensionOne_toLoop]
+  change
+    FirstHurewicz.inducedChain (p.val.comp cubeCoordinates) 5 productCubeChain =
+      ((FirstHurewicz.inducedChain p.val 5).comp (FirstHurewicz.inducedChain cubeCoordinates 5))
+        productCubeChain
+  rw [FirstHurewicz.inducedChain_comp]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    FifthHurewicz.cubeCycle {X : Type} [TopologicalSpace X] {x : X} (p : GenLoop (Fin 5) X x) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 5 :=
+  pathCubeCycle x (GenLoop.toLoop (0 : Fin 5) p)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def FifthHurewicz.cubeHomologyClass {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 5) X x) : SingularMayerVietoris.SingularHomology X 5 :=
+  SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 5
+    (cubeCycle p)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    FifthHurewicz.cubeHomologyClass_eq_pathCubeClass {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 5) X x) :
+    cubeHomologyClass p = pathCubeClass x (GenLoop.toLoop (0 : Fin 5) p) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FifthHurewicz.cubeHomologyClass_homotopic {X : Type} [TopologicalSpace X] {x : X}
+    {p q : GenLoop (Fin 5) X x} (h : GenLoop.Homotopic p q) :
+    cubeHomologyClass p = cubeHomologyClass q :=
+  pathCubeClass_homotopic x (GenLoop.homotopicTo (0 : Fin 5) h)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FifthHurewicz.toLoop_const {X : Type} [TopologicalSpace X] {x : X} :
+    GenLoop.toLoop (0 : Fin 5) (GenLoop.const : GenLoop (Fin 5) X x) =
+      Path.refl (GenLoop.const : BasedLoopSpace x) := by
+  apply Path.ext
+  funext t
+  apply GenLoop.ext
+  intro u
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem FifthHurewicz.cubeHomologyClass_const {X : Type} [TopologicalSpace X] {x : X} :
+    cubeHomologyClass (GenLoop.const : GenLoop (Fin 5) X x) = 0 := by
+  rw [cubeHomologyClass_eq_pathCubeClass, toLoop_const, pathCubeClass_refl]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+public
+theorem FifthHurewicz.toLoop_transAt {X : Type} [TopologicalSpace X] {x : X}
+    (p q : GenLoop (Fin 5) X x) :
+    GenLoop.toLoop (0 : Fin 5) (GenLoop.transAt (0 : Fin 5) p q) =
+      (GenLoop.toLoop (0 : Fin 5) p).trans (GenLoop.toLoop (0 : Fin 5) q) := by
+  have h :=
+    congrArg (GenLoop.toLoop (0 : Fin 5))
+      (GenLoop.fromLoop_trans_toLoop (i := (0 : Fin 5)) (p := p) (q := q))
+  rw [GenLoop.to_from] at h
+  exact h.symm
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FifthHurewicz.cubeHomologyClass_transAt {X : Type} [TopologicalSpace X] {x : X}
+    (p q : GenLoop (Fin 5) X x) :
+    cubeHomologyClass (GenLoop.transAt (0 : Fin 5) p q) =
+      cubeHomologyClass p + cubeHomologyClass q := by
+  simp only [cubeHomologyClass_eq_pathCubeClass, toLoop_transAt, pathCubeClass_trans]
+
+private theorem FifthHurewicz.CubeSubdivision.cubeCoordinates_boundary_right (s : (unitInterval))
+    {u : Fin 4 → (unitInterval)} (hu : u ∈ Cube.boundary (Fin 4)) :
+    FifthHurewicz.cubeCoordinates (s, u) ∈ Cube.boundary (Fin 5) := by
+  obtain ⟨i, hi⟩ := hu
+  exact ⟨i.succ, by simpa only [FifthHurewicz.cubeCoordinates_succ] using hi⟩
+
+private def FifthHurewicz.CubeSubdivision.curryLoop {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 5) X x) :
+    GenLoop (Fin 4) C((unitInterval), X) (ContinuousMap.const (unitInterval) x) :=
+  ⟨((FifthHurewicz.cubeMap p).comp ContinuousMap.prodSwap).curry,
+    by
+    intro u hu
+    apply ContinuousMap.ext
+    intro s
+    exact GenLoop.boundary p _ (cubeCoordinates_boundary_right s hu)⟩
+
+private theorem
+    FifthHurewicz.CubeSubdivision.evalLeft_comp_curryLoop {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 5) X x) :
+    (FourthHurewicz.CubeSubdivision.evalLeft X).comp
+        ((ContinuousMap.id (unitInterval)).prodMap (curryLoop p).val) =
+      FifthHurewicz.cubeMap p := by
+  ext z
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FifthHurewicz.CubeSubdivision.evalLeft_crossProductEdge_curryLoop {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 5) X x) (n : ℕ)
+    (b : FirstHurewicz.Chains (Fin 4 → (unitInterval)) n) :
+    FirstHurewicz.inducedChain (FourthHurewicz.CubeSubdivision.evalLeft X) (n + 1)
+        (PeriodTorusHigherHomology.crossProductEdge (unitInterval) C((unitInterval), X) n
+          SecondHurewicz.intervalChain (FirstHurewicz.inducedChain (curryLoop p).val n b)) =
+      FirstHurewicz.inducedChain (FifthHurewicz.cubeMap p) (n + 1)
+        (PeriodTorusHigherHomology.crossProductEdge (unitInterval) (Fin 4 → (unitInterval)) n
+          SecondHurewicz.intervalChain b) := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductEdge_natural (ContinuousMap.id (unitInterval))
+      (curryLoop p).val n SecondHurewicz.intervalChain b
+  rw [FirstHurewicz.inducedChain_id, LinearMap.id_apply] at h
+  rw [← h]
+  change
+    ((FirstHurewicz.inducedChain (FourthHurewicz.CubeSubdivision.evalLeft X) (n + 1)).comp
+          (FirstHurewicz.inducedChain
+            ((ContinuousMap.id (unitInterval)).prodMap (curryLoop p).val) (n + 1)))
+        _ =
+      _
+  rw [← FirstHurewicz.inducedChain_comp, evalLeft_comp_curryLoop]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FifthHurewicz.CubeSubdivision.cubeChain_eq_curriedCrossProduct {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 5) X x) :
+    FifthHurewicz.cubeChain p =
+      FirstHurewicz.inducedChain (FourthHurewicz.CubeSubdivision.evalLeft X) 5
+        (PeriodTorusHigherHomology.crossProductEdge (unitInterval) C((unitInterval), X) 4
+          SecondHurewicz.intervalChain (FourthHurewicz.cubeChain (curryLoop p))) := by
+  rw [FourthHurewicz.cubeChain_eq_induced, evalLeft_crossProductEdge_curryLoop,
+    FifthHurewicz.cubeChain_eq_induced, FifthHurewicz.fundamentalCubeChain]
+  change
+    (FirstHurewicz.inducedChain p.val 5)
+        ((FirstHurewicz.inducedChain FifthHurewicz.cubeCoordinates 5)
+          FifthHurewicz.productCubeChain) =
+      (FirstHurewicz.inducedChain (p.val.comp FifthHurewicz.cubeCoordinates) 5)
+        FifthHurewicz.productCubeChain
+  rw [FirstHurewicz.inducedChain_comp]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    FifthHurewicz.CubeSubdivision.intervalFourSimplexChain {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 5) X x) (e : Equiv.Perm (Fin 4)) : FirstHurewicz.Chains X 5 :=
+  FirstHurewicz.inducedChain (FourthHurewicz.CubeSubdivision.evalLeft X) 5
+    (PeriodTorusHigherHomology.crossProductEdge (unitInterval) C((unitInterval), X) 4
+      SecondHurewicz.intervalChain
+      (FirstHurewicz.simplexChain C((unitInterval), X) 4
+        ((curryLoop p).val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e))))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FifthHurewicz.CubeSubdivision.intervalFourSimplexChain_eq_original {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 5) X x) (e : Equiv.Perm (Fin 4)) :
+    intervalFourSimplexChain p e =
+      FirstHurewicz.inducedChain (FifthHurewicz.cubeMap p) 5
+        (PeriodTorusHigherHomology.crossProductEdge (unitInterval) (Fin 4 → (unitInterval)) 4
+          SecondHurewicz.intervalChain
+          (FirstHurewicz.simplexChain (Fin 4 → (unitInterval)) 4
+            (HigherHurewicz.CubeTriangulation.cubeSimplex e))) := by
+  rw [intervalFourSimplexChain, ← FirstHurewicz.inducedChain_simplex,
+    evalLeft_crossProductEdge_curryLoop]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    FifthHurewicz.CubeSubdivision.cubeChain_eq_sum_prisms {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 5) X x) :
+    FifthHurewicz.cubeChain p =
+      ∑ e : Equiv.Perm (Fin 4),
+        HigherHurewicz.CubeTriangulation.cubeOrientation e • intervalFourSimplexChain p e := by
+  rw [cubeChain_eq_curriedCrossProduct, FourthHurewicz.CubeSubdivision.cubeChain_eq_sum_simplices]
+  simp only [map_sum, map_zsmul, intervalFourSimplexChain]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem FifthHurewicz.CubeSubdivision.prismCubeMap_four (e : Equiv.Perm (Fin 4)) :
+    FifthHurewicz.cubeCoordinates.comp
+        ((FirstHurewicz.pathSimplex Path.id).prodMap
+          (HigherHurewicz.CubeTriangulation.cubeSimplex e)) =
+      FourthHurewicz.CubeSubdivision.prismCubeMap e := by
+  apply ContinuousMap.ext
+  intro z
+  funext i
+  refine Fin.cases ?_ (fun j => ?_) i
+  · exact FifthHurewicz.cubeCoordinates_zero _
+  · change
+      FifthHurewicz.cubeCoordinates
+          (FirstHurewicz.pathSimplex Path.id z.1,
+            HigherHurewicz.CubeTriangulation.cubeSimplex e z.2)
+          j.succ =
+        _
+    rw [FifthHurewicz.cubeCoordinates_succ]
+    rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    FifthHurewicz.CubeSubdivision.intervalFourSimplexChain_eq_prismCubeRealization {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 5) X x) (e : Equiv.Perm (Fin 4)) :
+    intervalFourSimplexChain p e =
+      FourthHurewicz.CubeSubdivision.prismCubeRealization p.val e 5
+        (PeriodTorusHigherHomology.formalEdgeCrossProduct 4
+          (SingularMayerVietoris.formalSimplex (fun i : Fin 2 => i))
+          (SingularMayerVietoris.formalSimplex (fun j : Fin 5 => j))) := by
+  rw [intervalFourSimplexChain_eq_original, SecondHurewicz.intervalChain, FirstHurewicz.pathChain,
+    PeriodTorusHigherHomology.crossProductEdge_simplex,
+    FourthHurewicz.CubeSubdivision.prismCubeRealization_edgeCrossProduct]
+  change
+    ((FirstHurewicz.inducedChain (FifthHurewicz.cubeMap p) 5).comp
+          (FirstHurewicz.inducedChain
+            ((FirstHurewicz.pathSimplex Path.id).prodMap
+              (HigherHurewicz.CubeTriangulation.cubeSimplex e))
+            5))
+        _ =
+      _
+  rw [← FirstHurewicz.inducedChain_comp]
+  change
+    FirstHurewicz.inducedChain
+        (p.val.comp
+          (FifthHurewicz.cubeCoordinates.comp
+            ((FirstHurewicz.pathSimplex Path.id).prodMap
+              (HigherHurewicz.CubeTriangulation.cubeSimplex e))))
+        5 _ =
+      _
+  rw [prismCubeMap_four]
+
+private theorem FifthHurewicz.CubeSubdivision.cubeChain_eq_orientedPrismRealization {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 5) X x) :
+    FifthHurewicz.cubeChain p =
+      FourthHurewicz.CubeSubdivision.orientedPrismRealization p.val 5
+        (PeriodTorusHigherHomology.formalEdgeCrossProduct 4
+          (SingularMayerVietoris.formalSimplex (fun i : Fin 2 => i))
+          (SingularMayerVietoris.formalSimplex (fun j : Fin 5 => j))) := by
+  rw [cubeChain_eq_sum_prisms, FourthHurewicz.CubeSubdivision.orientedPrismRealization_eq_sum]
+  simp only [intervalFourSimplexChain_eq_prismCubeRealization]
+
+private theorem
+    FifthHurewicz.CubeSubdivision.cubeChain_eq_sum_simplices {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 5) X x) :
+    FifthHurewicz.cubeChain p =
+      ∑ e : Equiv.Perm (Fin 5),
+        HigherHurewicz.CubeTriangulation.cubeOrientation e •
+          FirstHurewicz.simplexChain X 5
+            (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e)) := by
+  rw [cubeChain_eq_orientedPrismRealization,
+    FourthHurewicz.CubeSubdivision.orientedPrismRealization_edge_eq_standard (n := 2) p,
+    FourthHurewicz.CubeSubdivision.orientedPrismRealization_standardPrism]
+
+private theorem FifthHurewicz.fiveSimplexClassOperator_cubeChain_sum {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] (p : GenLoop (Fin 5) X x) :
+    fiveSimplexClassOperator x (cubeChain p) =
+      ∑ e : Equiv.Perm (Fin 5),
+        HigherHurewicz.CubeTriangulation.cubeOrientation e •
+          basedFiveSimplexClass
+            (normalizedFiveSimplex x
+              (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e))) := by
+  rw [CubeSubdivision.cubeChain_eq_sum_simplices, map_sum]
+  apply Finset.sum_congr rfl
+  intro e _
+  rw [map_zsmul, fiveSimplexClassOperator_simplex]
+
+private theorem FifthHurewicz.fiveSimplexClassOperator_cubeChain {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] (p : GenLoop (Fin 5) X x) :
+    fiveSimplexClassOperator x (cubeChain p) = Additive.ofMul (⟦p⟧ : π_ 5 X x) := by
+  rw [fiveSimplexClassOperator_cubeChain_sum]
+  calc
+    _ = Additive.ofMul (⟦normalizedCube x p⟧ : π_ 5 X x) := by
+      simpa only [normalizedCube_simplex, basedFiveSimplexClass] using
+        (HigherHurewicz.NativeSubdivision.nativeCubeSubdivision_class (normalizedCube x p)
+            (normalizedCube_internalBased x p)).symm
+    _ = _ :=
+      congrArg Additive.ofMul
+        (Quotient.sound
+          (show GenLoop.Homotopic (normalizedCube x p) p from
+            ⟨(normalizationCubeHomotopy x p).symm⟩))
+
+private def FifthHurewicz.basedFiveSimplexChain {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFiveSimplex x) : FirstHurewicz.Chains X 5 :=
+  HigherHurewicz.correctedSimplexChain 5 x τ.val
+
+private def FifthHurewicz.basedFiveSimplexCycle {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFiveSimplex x) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 5 :=
+  HigherHurewicz.correctedSimplexCycle 4 x τ.val (basedFiveSimplex_face τ)
+
+private theorem
+    FifthHurewicz.basedFiveSimplex_simplexChain_sum {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFiveSimplex x) :
+    (∑ e : Equiv.Perm (Fin 5),
+        HigherHurewicz.CubeTriangulation.cubeOrientation e •
+          FirstHurewicz.simplexChain X 5
+            ((basedFiveSimplexLoop τ).val.comp
+              (HigherHurewicz.CubeTriangulation.cubeSimplex e))) =
+      basedFiveSimplexChain τ :=
+  HigherHurewicz.SimplexGeometry.basedSimplex_simplexChain_sum (n := 3) τ
+
+private def HigherHurewicz.normalizedCycleAssignment {X : Type} [TopologicalSpace X] (n : ℕ) (x : X)
+    (f : FirstHurewicz.SingularSimplex X (n + 1) → SimplexGeometry.BasedSimplex (n + 1) x) :
+    FirstHurewicz.Chains X (n + 1) →ₗ[ℤ]
+      SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) (n + 1) :=
+  FirstHurewicz.chainLift X (n + 1) fun smp =>
+    correctedSimplexCycle n x (f smp).val (SimplexGeometry.basedSimplex_face (f smp))
+
+@[simp]
+private theorem
+    HigherHurewicz.normalizedCycleAssignment_simplex {X : Type} [TopologicalSpace X] (n : ℕ)
+    (x : X) (f : FirstHurewicz.SingularSimplex X (n + 1) → SimplexGeometry.BasedSimplex (n + 1) x)
+    (smp : FirstHurewicz.SingularSimplex X (n + 1)) :
+    normalizedCycleAssignment n x f (FirstHurewicz.simplexChain X (n + 1) smp) =
+      correctedSimplexCycle n x (f smp).val (SimplexGeometry.basedSimplex_face (f smp)) :=
+  FirstHurewicz.chainLift_simplex X (n + 1) _ smp
+
+private theorem HigherHurewicz.normalizedCycleAssignment_val {X : Type} [TopologicalSpace X] (n : ℕ)
+    (x : X) (f : FirstHurewicz.SingularSimplex X (n + 1) → SimplexGeometry.BasedSimplex (n + 1) x)
+    (c : FirstHurewicz.Chains X (n + 1)) :
+    (normalizedCycleAssignment n x f c).val =
+      FirstHurewicz.chainLift X (n + 1)
+        (fun smp =>
+          FirstHurewicz.simplexChain X (n + 1) (f smp).val - constantSimplexChain (n + 1) x)
+        c := by
+  have h :
+    (SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X)
+            (n + 1)).subtype.comp
+        (normalizedCycleAssignment n x f) =
+      FirstHurewicz.chainLift X (n + 1)
+        (fun smp =>
+          FirstHurewicz.simplexChain X (n + 1) (f smp).val - constantSimplexChain (n + 1) x) := by
+    apply FirstHurewicz.chainMap_ext X (n + 1)
+    intro smp
+    simp only [LinearMap.comp_apply, Submodule.subtype_apply, normalizedCycleAssignment_simplex,
+      correctedSimplexCycle_val, FirstHurewicz.chainLift_simplex]
+  exact LinearMap.congr_fun h c
+
+private theorem
+    HigherHurewicz.normalizedCycleAssignment_val_endpoint {X : Type} [TopologicalSpace X]
+    (n : ℕ) (x : X)
+    (f : FirstHurewicz.SingularSimplex X (n + 1) → SimplexGeometry.BasedSimplex (n + 1) x)
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (hf : ∀ smp, (f smp).val = SecondHurewicz.SimplyConnected.timeSlice (H' smp) 1)
+    (c : FirstHurewicz.Chains X (n + 1)) :
+    (normalizedCycleAssignment n x f c).val =
+      SecondHurewicz.SimplyConnected.simplexEndpointOperator (n + 1) H' 1 c -
+        SecondHurewicz.SimplyConnected.chainAugmentation X (n + 1) c •
+          constantSimplexChain (n + 1) x := by
+  rw [normalizedCycleAssignment_val, SecondHurewicz.SimplyConnected.chainLift_sub_constant]
+  have hmap :
+    FirstHurewicz.chainLift X (n + 1)
+        (fun smp => FirstHurewicz.simplexChain X (n + 1) (f smp).val) =
+      SecondHurewicz.SimplyConnected.simplexEndpointOperator (n + 1) H' 1 := by
+    apply FirstHurewicz.chainMap_ext X (n + 1)
+    intro smp
+    rw [FirstHurewicz.chainLift_simplex,
+      SecondHurewicz.SimplyConnected.simplexEndpointOperator_simplex, hf]
+  rw [hmap]
+
+private theorem
+    HigherHurewicz.normalizedCycleAssignment_evenCycle {X : Type} [TopologicalSpace X] (n : ℕ)
+    (x : X) (f : FirstHurewicz.SingularSimplex X (n + 1) → SimplexGeometry.BasedSimplex (n + 1) x)
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H H')
+    (hf : ∀ smp, (f smp).val = SecondHurewicz.SimplyConnected.timeSlice (H' smp) 1)
+    (heven : Even (n + 1))
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) (n + 1)) :
+    normalizedCycleAssignment n x f c.val = straightenedCycle n H H' hface c := by
+  apply Subtype.ext
+  rw [normalizedCycleAssignment_val_endpoint n x f H' hf,
+    chainAugmentation_evenCycle X (n + 1) heven (Nat.zero_lt_succ n), zero_smul, sub_zero,
+    straightenedCycle_val]
+
+private theorem
+    HigherHurewicz.normalizedCycleAssignment_oddCycle {X : Type} [TopologicalSpace X] (n : ℕ)
+    (x : X) (f : FirstHurewicz.SingularSimplex X (n + 1) → SimplexGeometry.BasedSimplex (n + 1) x)
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H H')
+    (hf : ∀ smp, (f smp).val = SecondHurewicz.SimplyConnected.timeSlice (H' smp) 1)
+    (hodd : Odd (n + 1))
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) (n + 1)) :
+    normalizedCycleAssignment n x f c.val =
+      straightenedCycle n H H' hface c -
+        SecondHurewicz.SimplyConnected.chainAugmentation X (n + 1) c.val •
+          constantSimplexCycle (n + 1) x hodd := by
+  apply Subtype.ext
+  change
+    (normalizedCycleAssignment n x f c.val).val =
+      (straightenedCycle n H H' hface c).val -
+        SecondHurewicz.SimplyConnected.chainAugmentation X (n + 1) c.val •
+          (constantSimplexCycle (n + 1) x hodd).val
+  rw [normalizedCycleAssignment_val_endpoint n x f H' hf, straightenedCycle_val,
+    constantSimplexCycle_val]
+
+private theorem
+    HigherHurewicz.normalizedCycleAssignment_class {X : Type} [TopologicalSpace X] (n : ℕ)
+    (x : X) (f : FirstHurewicz.SingularSimplex X (n + 1) → SimplexGeometry.BasedSimplex (n + 1) x)
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (hface : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H H')
+    (h₀ : ∀ smp, SecondHurewicz.SimplyConnected.timeSlice (H' smp) 0 = smp)
+    (hf : ∀ smp, (f smp).val = SecondHurewicz.SimplyConnected.timeSlice (H' smp) 1)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) (n + 1)) :
+    SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) (n + 1)
+        (normalizedCycleAssignment n x f c.val) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) (n + 1)
+        c := by
+  by_cases heven : Even (n + 1)
+  · rw [normalizedCycleAssignment_evenCycle n x f H H' hface hf heven]
+    exact straightenedCycle_class n H H' hface h₀ c
+  · have hodd : Odd (n + 1) := Nat.not_even_iff_odd.mp heven
+    rw [normalizedCycleAssignment_oddCycle n x f H H' hface hf hodd, map_sub, map_zsmul,
+      constantSimplexCycle_class, zsmul_zero, sub_zero]
+    exact straightenedCycle_class n H H' hface h₀ c
+
+private def FifthHurewicz.normalizedFiveSimplexCycleOperator {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] :
+    FirstHurewicz.Chains X 5 →ₗ[ℤ]
+      SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 5 :=
+  HigherHurewicz.normalizedCycleAssignment 4 x (normalizedFiveSimplex x)
+
+@[simp]
+private theorem
+    FifthHurewicz.normalizedFiveSimplexCycleOperator_simplex {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] (smp : FirstHurewicz.SingularSimplex X 5) :
+    normalizedFiveSimplexCycleOperator x (FirstHurewicz.simplexChain X 5 smp) =
+      basedFiveSimplexCycle (normalizedFiveSimplex x smp) :=
+  HigherHurewicz.normalizedCycleAssignment_simplex 4 x (normalizedFiveSimplex x) smp
+
+private theorem
+    FifthHurewicz.normalizedFiveSimplexCycleOperator_class {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)]
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 5) :
+    SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 5
+        (normalizedFiveSimplexCycleOperator x c.val) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 5 c := by
+  apply
+    HigherHurewicz.normalizedCycleAssignment_class 4 x (normalizedFiveSimplex x)
+      (normalizationFourSimplexHomotopy x) (normalizationFiveSimplexHomotopy x)
+      (normalizationHomotopy_face x) _ (fun _ => rfl) c
+  intro smp
+  ext s
+  exact normalizationFiveSimplexHomotopy_zero x smp s
+
+private def FifthHurewicz.hurewiczFunction {X : Type} [TopologicalSpace X] (x : X) :
+    π_ 5 X x → SingularMayerVietoris.SingularHomology X 5 :=
+  Quotient.lift cubeHomologyClass (fun _ _ h => cubeHomologyClass_homotopic h)
+
+private def FifthHurewicz.hurewiczPi5 {X : Type} [TopologicalSpace X] (x : X) :
+    π_ 5 X x →* Multiplicative (SingularMayerVietoris.SingularHomology X 5)
+    where
+  toFun a := Multiplicative.ofAdd (hurewiczFunction x a)
+  map_one' := congrArg Multiplicative.ofAdd (cubeHomologyClass_const (x := x))
+  map_mul' a
+    b := by
+    refine Quotient.inductionOn₂ a b fun p q => ?_
+    refine
+      (congrArg (fun c : π_ 5 X x => Multiplicative.ofAdd (hurewiczFunction x c))
+            (HomotopyGroup.mul_spec (i := (0 : Fin 5)) (p := p) (q := q))).trans
+        ?_
+    change
+      Multiplicative.ofAdd (cubeHomologyClass (GenLoop.transAt (0 : Fin 5) q p)) =
+        Multiplicative.ofAdd (cubeHomologyClass p + cubeHomologyClass q)
+    rw [cubeHomologyClass_transAt, add_comm]
+
+private def FifthHurewicz.hurewiczMap {X : Type} [TopologicalSpace X] (x : X) :
+    Additive (π_ 5 X x) →ₗ[ℤ] SingularMayerVietoris.SingularHomology X 5
+    where
+  toFun := (hurewiczPi5 x).toAdditiveLeft
+  map_add' := (hurewiczPi5 x).toAdditiveLeft.map_add
+  map_smul' n a := by simpa using map_intCast_smul (hurewiczPi5 x).toAdditiveLeft ℤ ℤ n a
+
+private theorem FifthHurewicz.hurewiczMap_representative {X : Type} [TopologicalSpace X] (x : X)
+    (p : GenLoop (Fin 5) X x) :
+    hurewiczMap x (Additive.ofMul (⟦p⟧ : π_ 5 X x)) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 5
+        (cubeCycle p) :=
+  rfl
+
+private theorem FifthHurewicz.cubeChain_basedFiveSimplexLoop {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFiveSimplex x) : cubeChain (basedFiveSimplexLoop τ) = basedFiveSimplexChain τ := by
+  rw [CubeSubdivision.cubeChain_eq_sum_simplices, basedFiveSimplex_simplexChain_sum]
+
+private theorem FifthHurewicz.cubeCycle_basedFiveSimplexLoop {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFiveSimplex x) : cubeCycle (basedFiveSimplexLoop τ) = basedFiveSimplexCycle τ := by
+  apply Subtype.ext
+  exact cubeChain_basedFiveSimplexLoop τ
+
+private theorem FifthHurewicz.hurewicz_basedFiveSimplexClass {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFiveSimplex x) :
+    hurewiczMap x (basedFiveSimplexClass τ) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 5
+        (basedFiveSimplexCycle τ) := by
+  change
+    SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 5
+        (cubeCycle (basedFiveSimplexLoop τ)) =
+      _
+  rw [cubeCycle_basedFiveSimplexLoop]
+
+private theorem
+    FifthHurewicz.hurewiczMap_comp_fiveSimplexClassOperator {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] :
+    (hurewiczMap x).comp (fiveSimplexClassOperator x) =
+      (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 5).comp
+        (normalizedFiveSimplexCycleOperator x) := by
+  apply FirstHurewicz.chainMap_ext X 5
+  intro smp
+  simp only [LinearMap.comp_apply, fiveSimplexClassOperator_simplex,
+    normalizedFiveSimplexCycleOperator_simplex]
+  exact hurewicz_basedFiveSimplexClass (normalizedFiveSimplex x smp)
+
+private theorem
+    FifthHurewicz.hurewiczMap_fiveSimplexClassOperator_cycle {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)]
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 5) :
+    hurewiczMap x (fiveSimplexClassOperator x c.val) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 5 c := by
+  have h := LinearMap.congr_fun (hurewiczMap_comp_fiveSimplexClassOperator x) c.val
+  change
+    hurewiczMap x (fiveSimplexClassOperator x c.val) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 5
+        (normalizedFiveSimplexCycleOperator x c.val) at h
+  exact h.trans (normalizedFiveSimplexCycleOperator_class x c)
+
+private def
+    FifthHurewicz.hurewiczInverse {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X] (x : X)
+    [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] [Subsingleton (π_ 4 X x)] :
+    SingularMayerVietoris.SingularHomology X 5 →ₗ[ℤ] Additive (π_ 5 X x) :=
+  HigherHurewicz.singularHomologyDesc 5 (fiveSimplexClassOperator x)
+    (fiveSimplexClassOperator_boundary x)
+
+@[simp]
+private theorem FifthHurewicz.hurewiczInverse_cycleClass {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)]
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 5) :
+    hurewiczInverse x
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 5 c) =
+      fiveSimplexClassOperator x c.val :=
+  HigherHurewicz.singularHomologyDesc_cycleClass 5 _ _ c
+
+private theorem FifthHurewicz.hurewiczMap_comp_hurewiczInverse {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] : (hurewiczMap x).comp (hurewiczInverse x) = LinearMap.id :=
+  HigherHurewicz.comp_singularHomologyDesc_eq_id 5 (fiveSimplexClassOperator x)
+    (fiveSimplexClassOperator_boundary x) (hurewiczMap x)
+    (hurewiczMap_fiveSimplexClassOperator_cycle x)
+
+@[simp]
+private theorem FifthHurewicz.hurewiczMap_hurewiczInverse {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] (c : SingularMayerVietoris.SingularHomology X 5) :
+    hurewiczMap x (hurewiczInverse x c) = c :=
+  LinearMap.congr_fun (hurewiczMap_comp_hurewiczInverse x) c
+
+private theorem FifthHurewicz.hurewiczInverse_hurewiczMap_mk {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] (p : GenLoop (Fin 5) X x) :
+    hurewiczInverse x (hurewiczMap x (Additive.ofMul (⟦p⟧ : π_ 5 X x))) =
+      Additive.ofMul (⟦p⟧ : π_ 5 X x) := by
+  rw [hurewiczMap_representative, hurewiczInverse_cycleClass]
+  exact fiveSimplexClassOperator_cubeChain x p
+
+@[simp]
+private theorem FifthHurewicz.hurewiczInverse_hurewiczMap {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] (a : Additive (π_ 5 X x)) :
+    hurewiczInverse x (hurewiczMap x a) = a := by
+  change
+    hurewiczInverse x (hurewiczMap x (Additive.ofMul (Additive.toMul a))) =
+      Additive.ofMul (Additive.toMul a)
+  refine Quotient.inductionOn (Additive.toMul a) ?_
+  intro p
+  exact hurewiczInverse_hurewiczMap_mk x p
+
+private theorem FifthHurewicz.hurewiczInverse_comp_hurewiczMap {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] : (hurewiczInverse x).comp (hurewiczMap x) = LinearMap.id := by
+  ext a
+  exact hurewiczInverse_hurewiczMap x a
+
+
+private def FifthHurewicz.hurewiczPi5Equiv {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] [Subsingleton (π_ 4 X x)] :
+    π_ 5 X x ≃* Multiplicative (SingularMayerVietoris.SingularHomology X 5)
+    where
+  __ := hurewiczPi5 x
+  invFun c := Additive.toMul (hurewiczInverse x (Multiplicative.toAdd c))
+  left_inv a := congrArg Additive.toMul (hurewiczInverse_hurewiczMap x (Additive.ofMul a))
+  right_inv
+    c := congrArg Multiplicative.ofAdd (hurewiczMap_hurewiczInverse x (Multiplicative.toAdd c))
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Hurewicz/SecondHurewicz.lean b/LeanPool/HopfProblem/Hurewicz/SecondHurewicz.lean
new file mode 100644
index 000000000..77cd77382
--- /dev/null
+++ b/LeanPool/HopfProblem/Hurewicz/SecondHurewicz.lean
@@ -0,0 +1,5740 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Foundations.InvariantSubsetQuotient
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Foundations.TriangleRegularBaseFundamentalGroup
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology4
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz2
+import all LeanPool.HopfProblem.Foundations.InvariantSubsetQuotient
+
+/-!
+# Hopf problem: hurewicz · second hurewicz
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def
+    SecondHurewicz.SimplyConnected.simplexBoundary (n : ℕ) : Set (FirstHurewicz.Simplex n) :=
+  {s | ∃ i : Fin (n + 1), s i = 0}
+
+private abbrev SecondHurewicz.SimplyConnected.SimplexBoundary (n : ℕ) :=
+  ↥(simplexBoundary n)
+
+private def SecondHurewicz.SimplyConnected.bottomOrSide (n : ℕ) :
+    Set (unitInterval × FirstHurewicz.Simplex n) :=
+  {u | u.1 = 0 ∨ u.2 ∈ simplexBoundary n}
+
+private theorem SecondHurewicz.SimplyConnected.isClosed_simplexBoundary (n : ℕ) :
+    IsClosed (simplexBoundary n) := by
+  have h : IsClosed (⋃ i : Fin (n + 1), {s : FirstHurewicz.Simplex n | s i = 0}) :=
+    isClosed_iUnion_of_finite fun i =>
+      isClosed_eq ((continuous_apply i).comp continuous_subtype_val) continuous_const
+  simpa only [simplexBoundary, Set.ofPred_exists] using h
+
+private theorem SecondHurewicz.SimplyConnected.simplexFace_mem_boundary (n : ℕ) (i : Fin (n + 2))
+    (s : FirstHurewicz.Simplex n) : FirstHurewicz.simplexFace n i s ∈ simplexBoundary (n + 1) :=
+  ⟨i, FirstHurewicz.simplexFace_apply_self n i s⟩
+
+private def SecondHurewicz.SimplyConnected.bottomInclusion (n : ℕ) :
+    C(FirstHurewicz.Simplex n, ↥(bottomOrSide n))
+    where
+  toFun s := ⟨(0, s), Or.inl rfl⟩
+  continuous_toFun := (continuous_const.prodMk continuous_id).subtype_mk _
+
+private def SecondHurewicz.SimplyConnected.sideInclusion (n : ℕ) :
+    C(unitInterval × SimplexBoundary n, ↥(bottomOrSide n))
+    where
+  toFun u := ⟨(u.1, u.2.val), Or.inr u.2.property⟩
+  continuous_toFun :=
+    (continuous_fst.prodMk (continuous_subtype_val.comp continuous_snd)).subtype_mk _
+
+private def HigherHurewicz.flatSimplexSet (n : ℕ) : Set (Fin n → ℝ) :=
+  {v | (∀ i, 0 ≤ v i) ∧ ∑ i, v i ≤ 1}
+
+private def HigherHurewicz.realCubeSet (n : ℕ) : Set (Fin n → ℝ) :=
+  Set.Icc 0 1
+
+private def HigherHurewicz.BasedSimplex (n : ℕ) {X : Type} [TopologicalSpace X] (x : X) :=
+  { τ : C(FirstHurewicz.Simplex n, X) //
+    ∀ s ∈ SecondHurewicz.SimplyConnected.simplexBoundary n, τ s = x }
+
+private def HigherHurewicz.constantBasedSimplex (n : ℕ) {X : Type} [TopologicalSpace X] (x : X) :
+    BasedSimplex n x :=
+  ⟨ContinuousMap.const (FirstHurewicz.Simplex n) x, fun _ _ => rfl⟩
+
+private theorem HigherHurewicz.convex_realCubeSet (n : ℕ) : Convex ℝ (realCubeSet n) :=
+  convex_Icc 0 1
+
+private theorem HigherHurewicz.isClosed_realCubeSet (n : ℕ) : IsClosed (realCubeSet n) :=
+  isClosed_Icc
+
+private theorem HigherHurewicz.isCompact_realCubeSet (n : ℕ) : IsCompact (realCubeSet n) :=
+  CompactIccSpace.isCompact_Icc
+
+private theorem HigherHurewicz.mem_interior_realCubeSet (n : ℕ) (v : Fin n → ℝ) :
+    v ∈ interior (realCubeSet n) ↔ ∀ i, 0 < v i ∧ v i < 1 := by
+  rw [realCubeSet, ← Set.pi_univ_Icc, interior_pi_set (Set.finite_univ)]
+  simp only [Set.mem_pi, Set.mem_univ, forall_const, interior_Icc, Pi.zero_apply, Pi.one_apply,
+    Set.mem_Ioo]
+
+private theorem HigherHurewicz.interior_realCubeSet_nonempty (n : ℕ) :
+    (interior (realCubeSet n)).Nonempty := by
+  refine ⟨fun _ => 1 / 2, (mem_interior_realCubeSet n _).mpr ?_⟩
+  intro i
+  norm_num
+
+private theorem HigherHurewicz.realCubeSet_mem_frontier_iff (n : ℕ) (v : ↥(realCubeSet n)) :
+    v.val ∈ frontier (realCubeSet n) ↔ ∃ i, v.val i = 0 ∨ v.val i = 1 := by
+  classical
+  rw [frontier, (isClosed_realCubeSet n).closure_eq]
+  simp only [Set.mem_sdiff, v.property, true_and, mem_interior_realCubeSet]
+  constructor
+  · intro h
+    simp only [Classical.not_forall, not_and_or, not_lt] at h
+    obtain ⟨i, h | h⟩ := h
+    · exact ⟨i, Or.inl (le_antisymm h (v.property.1 i))⟩
+    · exact ⟨i, Or.inr (le_antisymm (v.property.2 i) h)⟩
+  · rintro ⟨i, h | h⟩ hi
+    · have h0 := (hi i).1
+      rw [h] at h0
+      exact lt_irrefl _ h0
+    · have h1 := (hi i).2
+      rw [h] at h1
+      exact lt_irrefl _ h1
+
+private def HigherHurewicz.realCubeHomeomorph (n : ℕ) : ↥(realCubeSet n) ≃ₜ (Fin n → (unitInterval))
+    where
+  toFun v i := ⟨v.val i, v.property.1 i, v.property.2 i⟩
+  invFun u := ⟨fun i => (u i : ℝ), fun i => (u i).property.1, fun i => (u i).property.2⟩
+  left_inv v := Subtype.ext rfl
+  right_inv
+    u := by
+    funext i
+    apply Subtype.ext
+    rfl
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    exact ((continuous_apply i).comp continuous_subtype_val).subtype_mk _
+  continuous_invFun := by
+    apply Continuous.subtype_mk
+    exact continuous_pi fun i => continuous_subtype_val.comp (continuous_apply i)
+
+private theorem HigherHurewicz.realCubeHomeomorph_mem_boundary_iff (n : ℕ) (v : ↥(realCubeSet n)) :
+    realCubeHomeomorph n v ∈ Cube.boundary (Fin n) ↔ v.val ∈ frontier (realCubeSet n) := by
+  rw [realCubeSet_mem_frontier_iff]
+  constructor
+  · rintro ⟨i, hi | hi⟩
+    · exact ⟨i, Or.inl (congrArg (fun t : (unitInterval) => (t : ℝ)) hi)⟩
+    · exact ⟨i, Or.inr (congrArg (fun t : (unitInterval) => (t : ℝ)) hi)⟩
+  · rintro ⟨i, hi | hi⟩
+    · exact ⟨i, Or.inl (Subtype.ext hi)⟩
+    · exact ⟨i, Or.inr (Subtype.ext hi)⟩
+
+private def
+    HigherHurewicz.simplexFlat (n : ℕ) (s : FirstHurewicz.Simplex n) : ↥(flatSimplexSet n) :=
+  ⟨fun i => s i.succ, by
+    refine ⟨fun i => stdSimplex.zero_le s i.succ, ?_⟩
+    have hs := stdSimplex.sum_eq_one s
+    rw [Fin.sum_univ_succ] at hs
+    have h0 := stdSimplex.zero_le s 0
+    linarith⟩
+
+private def
+    HigherHurewicz.flatSimplex (n : ℕ) (v : ↥(flatSimplexSet n)) : FirstHurewicz.Simplex n :=
+  ⟨Fin.cons (1 - ∑ i, v.val i) v.val, by
+    constructor
+    · intro i
+      refine Fin.cases ?_ (fun j => ?_) i
+      · exact sub_nonneg.mpr v.property.2
+      · exact v.property.1 j
+    · simp only [Fin.sum_univ_succ, Fin.cons_zero, Fin.cons_succ]
+      exact sub_add_cancel 1 _⟩
+
+private theorem HigherHurewicz.continuous_simplexFlat (n : ℕ) : Continuous (simplexFlat n) := by
+  apply Continuous.subtype_mk
+  exact continuous_pi fun i => (continuous_apply i.succ).comp continuous_subtype_val
+
+private theorem HigherHurewicz.continuous_flatSimplex (n : ℕ) : Continuous (flatSimplex n) := by
+  apply Continuous.subtype_mk
+  apply continuous_pi
+  intro i
+  refine Fin.cases ?_ (fun j => ?_) i
+  · exact
+      continuous_const.sub <|
+        continuous_finsetSum _ fun j _ => (continuous_apply j).comp continuous_subtype_val
+  · exact (continuous_apply j).comp continuous_subtype_val
+
+@[simp]
+private theorem HigherHurewicz.flatSimplex_simplexFlat (n : ℕ) (s : FirstHurewicz.Simplex n) :
+    flatSimplex n (simplexFlat n s) = s := by
+  apply Subtype.ext
+  funext i
+  refine Fin.cases ?_ (fun j => ?_) i
+  · change 1 - ∑ j : Fin n, s j.succ = s 0
+    have hs := stdSimplex.sum_eq_one s
+    rw [Fin.sum_univ_succ] at hs
+    linarith
+  · rfl
+
+@[simp]
+private theorem HigherHurewicz.simplexFlat_flatSimplex (n : ℕ) (v : ↥(flatSimplexSet n)) :
+    simplexFlat n (flatSimplex n v) = v := by
+  apply Subtype.ext
+  rfl
+
+private def
+    HigherHurewicz.simplexFlatHomeomorph (n : ℕ) : FirstHurewicz.Simplex n ≃ₜ ↥(flatSimplexSet n)
+    where
+  toFun := simplexFlat n
+  invFun := flatSimplex n
+  left_inv := flatSimplex_simplexFlat n
+  right_inv := simplexFlat_flatSimplex n
+  continuous_toFun := continuous_simplexFlat n
+  continuous_invFun := continuous_flatSimplex n
+
+private theorem HigherHurewicz.convex_flatSimplexSet (n : ℕ) : Convex ℝ (flatSimplexSet n) := by
+  intro x hx y hy a b ha hb hab
+  constructor
+  · intro i
+    exact add_nonneg (mul_nonneg ha (hx.1 i)) (mul_nonneg hb (hy.1 i))
+  · change ∑ i, (a * x i + b * y i) ≤ 1
+    rw [Finset.sum_add_distrib, ← Finset.mul_sum, ← Finset.mul_sum]
+    calc
+      a * ∑ i, x i + b * ∑ i, y i ≤ a * 1 + b * 1 :=
+        add_le_add (mul_le_mul_of_nonneg_left hx.2 ha) (mul_le_mul_of_nonneg_left hy.2 hb)
+      _ = 1 := by simpa only [mul_one] using hab
+
+private theorem HigherHurewicz.isClosed_flatSimplexSet (n : ℕ) : IsClosed (flatSimplexSet n) := by
+  have he : flatSimplexSet n = (⋂ i : Fin n, {v : Fin n → ℝ | 0 ≤ v i}) ∩ {v | ∑ i, v i ≤ 1} := by
+    ext v
+    simp only [flatSimplexSet, Set.mem_ofPred_eq, Set.mem_inter_iff, Set.mem_iInter]
+  rw [he]
+  exact
+    (isClosed_iInter fun i => isClosed_le continuous_const (continuous_apply i)).inter
+      (isClosed_le (by fun_prop) continuous_const)
+
+private theorem HigherHurewicz.flatSimplexSet_subset_Icc (n : ℕ) :
+    flatSimplexSet n ⊆ Set.Icc (0 : Fin n → ℝ) 1 := by
+  intro v hv
+  refine ⟨hv.1, fun i => ?_⟩
+  exact (Finset.single_le_sum (fun j _ => hv.1 j) (Finset.mem_univ i)).trans hv.2
+
+private theorem HigherHurewicz.isCompact_flatSimplexSet (n : ℕ) : IsCompact (flatSimplexSet n) :=
+  CompactIccSpace.isCompact_Icc.of_isClosed_subset (isClosed_flatSimplexSet n)
+    (flatSimplexSet_subset_Icc n)
+
+private def HigherHurewicz.flatCoordinateSum_mo1973_5884 (n : ℕ) : (Fin n → ℝ) →L[ℝ] ℝ
+    where
+  toFun v := ∑ i, v i
+  map_add' v w := Finset.sum_add_distrib
+  map_smul' a v := by simp only [Pi.smul_apply, smul_eq_mul, Finset.mul_sum, RingHom.id_apply]
+  cont := by fun_prop
+
+private theorem HigherHurewicz.flatCoordinateSum_succ_ne_zero_mo1973_5885 (n : ℕ) :
+    flatCoordinateSum_mo1973_5884 (n + 1) ≠ 0 := by
+  intro h
+  have he := congrArg (fun f : (Fin (n + 1) → ℝ) →L[ℝ] ℝ => f 1) h
+  have hn : (n : ℝ) + 1 = 0 := by simpa [flatCoordinateSum_mo1973_5884] using he
+  exact (ne_of_gt (Nat.cast_add_one_pos n)) hn
+
+private theorem HigherHurewicz.isOpen_flatSimplexStrict_mo1973_5886 (n : ℕ) :
+    IsOpen {v : Fin n → ℝ | (∀ i, 0 < v i) ∧ ∑ i, v i < 1} := by
+  have he :
+    {v : Fin n → ℝ | (∀ i, 0 < v i) ∧ ∑ i, v i < 1} =
+      (⋂ i : Fin n, {v : Fin n → ℝ | 0 < v i}) ∩ {v | ∑ i, v i < 1} := by
+    ext v
+    simp only [Set.mem_ofPred_eq, Set.mem_inter_iff, Set.mem_iInter]
+  rw [he]
+  exact
+    (isOpen_iInter_of_finite fun i => isOpen_lt continuous_const (continuous_apply i)).inter
+      (isOpen_lt (by fun_prop) continuous_const)
+
+private theorem HigherHurewicz.interior_flatSimplexSet (n : ℕ) :
+    interior (flatSimplexSet n) = {v : Fin n → ℝ | (∀ i, 0 < v i) ∧ ∑ i, v i < 1} := by
+  apply Set.Subset.antisymm
+  · intro v hv
+    constructor
+    · intro i
+      have hi : v ∈ interior ((fun w : Fin n → ℝ => w i) ⁻¹' Set.Ici 0) :=
+        interior_mono (fun w hw => hw.1 i) hv
+      have h := (isOpenMap_eval i).interior_preimage_subset_preimage_interior hi
+      simpa only [Set.mem_preimage, interior_Ici, Set.mem_Ioi] using h
+    · cases n with
+      | zero => simp
+      | succ
+        n =>
+        have hs : v ∈ interior (flatCoordinateSum_mo1973_5884 (n + 1) ⁻¹' Set.Iic 1) :=
+          interior_mono (fun w hw => hw.2) hv
+        have h :=
+          ((flatCoordinateSum_mo1973_5884 (n + 1)).isOpenMap_of_ne_zero
+                (flatCoordinateSum_succ_ne_zero_mo1973_5885
+                  n)).interior_preimage_subset_preimage_interior
+            hs
+        simpa only [Set.mem_preimage, interior_Iic, Set.mem_Iio, flatCoordinateSum_mo1973_5884,
+          ContinuousLinearMap.coe_mk', LinearMap.coe_mk, AddHom.coe_mk] using h
+  · exact
+      (isOpen_flatSimplexStrict_mo1973_5886 n).subset_interior_iff.mpr
+        (fun _ hv => ⟨fun i => (hv.1 i).le, hv.2.le⟩)
+
+private theorem HigherHurewicz.interior_flatSimplexSet_nonempty (n : ℕ) :
+    (interior (flatSimplexSet n)).Nonempty := by
+  rw [interior_flatSimplexSet]
+  have hn : 0 < (n : ℝ) + 1 := Nat.cast_add_one_pos n
+  refine ⟨fun _ => 1 / ((n : ℝ) + 1), fun _ => one_div_pos.mpr hn, ?_⟩
+  simpa only [Finset.sum_const, Finset.card_univ, Fintype.card_fin, nsmul_eq_mul,
+    mul_one_div] using (div_lt_one hn).mpr (lt_add_one (n : ℝ))
+
+private theorem HigherHurewicz.simplexFlatHomeomorph_mem_interior_iff (n : ℕ)
+    (s : FirstHurewicz.Simplex n) :
+    (simplexFlatHomeomorph n s).val ∈ interior (flatSimplexSet n) ↔ ∀ i, 0 < s i := by
+  rw [interior_flatSimplexSet]
+  change ((∀ i : Fin n, 0 < s i.succ) ∧ ∑ i : Fin n, s i.succ < 1) ↔ _
+  have hs := stdSimplex.sum_eq_one s
+  rw [Fin.sum_univ_succ] at hs
+  constructor
+  · rintro ⟨hpos, hsum⟩ i
+    refine Fin.cases ?_ (fun j => hpos j) i
+    linarith
+  · intro hpos
+    exact ⟨fun i => hpos i.succ, by linarith [hpos 0]⟩
+
+private theorem HigherHurewicz.simplexFlatHomeomorph_mem_frontier_iff (n : ℕ)
+    (s : FirstHurewicz.Simplex n) :
+    (simplexFlatHomeomorph n s).val ∈ frontier (flatSimplexSet n) ↔
+      s ∈ SecondHurewicz.SimplyConnected.simplexBoundary n := by
+  rw [frontier, (isClosed_flatSimplexSet n).closure_eq]
+  change (_ ∧ _) ↔ ∃ i : Fin (n + 1), s i = 0
+  rw [simplexFlatHomeomorph_mem_interior_iff]
+  constructor
+  · rintro ⟨_, hnot⟩
+    classical
+    push Not at hnot
+    obtain ⟨i, hi⟩ := hnot
+    exact ⟨i, le_antisymm hi (stdSimplex.zero_le s i)⟩
+  · rintro ⟨i, hi⟩
+    refine ⟨(simplexFlatHomeomorph n s).property, ?_⟩
+    intro hpos
+    have := hpos i
+    rw [hi] at this
+    exact (lt_irrefl 0) this
+
+private theorem HigherHurewicz.exists_ambientSimplexCubeHomeomorph (n : ℕ) :
+    ∃ e : (Fin n → ℝ) ≃ₜ (Fin n → ℝ),
+      e '' flatSimplexSet n = realCubeSet n ∧
+        e '' frontier (flatSimplexSet n) = frontier (realCubeSet n) := by
+  obtain ⟨e, _, hclosed, hfrontier⟩ :=
+    exists_homeomorph_image_eq (convex_flatSimplexSet n) (interior_flatSimplexSet_nonempty n)
+      ((isCompact_flatSimplexSet n).isVonNBounded ℝ) (convex_realCubeSet n)
+      (interior_realCubeSet_nonempty n) ((isCompact_realCubeSet n).isVonNBounded ℝ)
+  refine ⟨e, ?_, hfrontier⟩
+  simpa only [(isClosed_flatSimplexSet n).closure_eq, (isClosed_realCubeSet n).closure_eq] using
+    hclosed
+
+private def HigherHurewicz.ambientSimplexCubeHomeomorph (n : ℕ) : (Fin n → ℝ) ≃ₜ (Fin n → ℝ) :=
+  Classical.choose (exists_ambientSimplexCubeHomeomorph n)
+
+private theorem HigherHurewicz.ambientSimplexCubeHomeomorph_image (n : ℕ) :
+    ambientSimplexCubeHomeomorph n '' flatSimplexSet n = realCubeSet n :=
+  (Classical.choose_spec (exists_ambientSimplexCubeHomeomorph n)).1
+
+private theorem HigherHurewicz.ambientSimplexCubeHomeomorph_image_frontier (n : ℕ) :
+    ambientSimplexCubeHomeomorph n '' frontier (flatSimplexSet n) = frontier (realCubeSet n) :=
+  (Classical.choose_spec (exists_ambientSimplexCubeHomeomorph n)).2
+
+private theorem HigherHurewicz.ambientSimplexCubeHomeomorph_mem_iff (n : ℕ) (v : Fin n → ℝ) :
+    v ∈ flatSimplexSet n ↔ ambientSimplexCubeHomeomorph n v ∈ realCubeSet n := by
+  constructor
+  · intro hv
+    rw [← ambientSimplexCubeHomeomorph_image]
+    exact ⟨v, hv, rfl⟩
+  · intro hv
+    rw [← ambientSimplexCubeHomeomorph_image] at hv
+    obtain ⟨w, hw, he⟩ := hv
+    exact (ambientSimplexCubeHomeomorph n).injective he ▸ hw
+
+private theorem
+    HigherHurewicz.ambientSimplexCubeHomeomorph_mem_frontier_iff (n : ℕ) (v : Fin n → ℝ) :
+    v ∈ frontier (flatSimplexSet n) ↔
+      ambientSimplexCubeHomeomorph n v ∈ frontier (realCubeSet n) := by
+  constructor
+  · intro hv
+    rw [← ambientSimplexCubeHomeomorph_image_frontier]
+    exact ⟨v, hv, rfl⟩
+  · intro hv
+    rw [← ambientSimplexCubeHomeomorph_image_frontier] at hv
+    obtain ⟨w, hw, he⟩ := hv
+    exact (ambientSimplexCubeHomeomorph n).injective he ▸ hw
+
+private def HigherHurewicz.flatCubeHomeomorph (n : ℕ) : ↥(flatSimplexSet n) ≃ₜ ↥(realCubeSet n) :=
+  (ambientSimplexCubeHomeomorph n).subtype (ambientSimplexCubeHomeomorph_mem_iff n)
+
+private def HigherHurewicz.simplexCubeHomeomorph (n : ℕ) :
+    FirstHurewicz.Simplex n ≃ₜ (Fin n → (unitInterval)) :=
+  (simplexFlatHomeomorph n).trans ((flatCubeHomeomorph n).trans (realCubeHomeomorph n))
+
+private theorem
+    HigherHurewicz.simplexCubeHomeomorph_boundary_iff (n : ℕ) (s : FirstHurewicz.Simplex n) :
+    simplexCubeHomeomorph n s ∈ Cube.boundary (Fin n) ↔
+      s ∈ SecondHurewicz.SimplyConnected.simplexBoundary n := by
+  change
+    realCubeHomeomorph n (flatCubeHomeomorph n (simplexFlatHomeomorph n s)) ∈
+        Cube.boundary (Fin n) ↔
+      _
+  rw [realCubeHomeomorph_mem_boundary_iff]
+  change
+    ambientSimplexCubeHomeomorph n (simplexFlatHomeomorph n s).val ∈ frontier (realCubeSet n) ↔ _
+  rw [← ambientSimplexCubeHomeomorph_mem_frontier_iff, simplexFlatHomeomorph_mem_frontier_iff]
+
+private theorem HigherHurewicz.simplexCubeHomeomorph_symm_boundary_iff (n : ℕ)
+    (u : Fin n → (unitInterval)) :
+    (simplexCubeHomeomorph n).symm u ∈ SecondHurewicz.SimplyConnected.simplexBoundary n ↔
+      u ∈ Cube.boundary (Fin n) := by
+  rw [← simplexCubeHomeomorph_boundary_iff, Homeomorph.apply_symm_apply]
+
+private def
+    SecondHurewicz.SimplyConnected.VerticesBased {X : Type} [TopologicalSpace X] (x : X) (n : ℕ)
+    (smp : C(FirstHurewicz.Simplex n, X)) : Prop :=
+  ∀ i : Fin (n + 1), smp (stdSimplex.vertex (S := ℝ) i) = x
+
+private theorem
+    SecondHurewicz.SimplyConnected.VerticesBased.face {X : Type} [TopologicalSpace X] {x : X}
+    {n : ℕ} {smp : C(FirstHurewicz.Simplex (n + 1), X)}
+    (h : SecondHurewicz.SimplyConnected.VerticesBased x (n + 1) smp) (i : Fin (n + 2)) :
+    SecondHurewicz.SimplyConnected.VerticesBased x n (smp.comp (FirstHurewicz.simplexFace n i)) :=
+  by
+  intro j
+  change smp (FirstHurewicz.simplexFace n i (stdSimplex.vertex (S := ℝ) j)) = x
+  rw [FirstHurewicz.simplexFace_vertex]
+  exact h (i.succAbove j)
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.verticesBased_const {X : Type} [TopologicalSpace X] (x : X)
+    (n : ℕ) : VerticesBased x n (ContinuousMap.const (FirstHurewicz.Simplex n) x) := fun _ => rfl
+
+private theorem
+    SecondHurewicz.SimplyConnected.verticesBased_zero_iff {X : Type} [TopologicalSpace X]
+    {x : X} {smp : C(FirstHurewicz.Simplex 0, X)} :
+    VerticesBased x 0 smp ↔ smp = ContinuousMap.const (FirstHurewicz.Simplex 0) x := by
+  constructor
+  · intro h
+    apply ContinuousMap.ext
+    intro s
+    change smp s = x
+    rw [FirstHurewicz.simplexZero_eq_vertex s]
+    exact h 0
+  · rintro rfl
+    exact verticesBased_const x 0
+
+private theorem SecondHurewicz.SimplyConnected.simplexVertex_exists_face (n : ℕ) (k : Fin (n + 2)) :
+    ∃ i : Fin (n + 2),
+      ∃ j : Fin (n + 1),
+        FirstHurewicz.simplexFace n i (stdSimplex.vertex (S := ℝ) j) =
+          stdSimplex.vertex (S := ℝ) k := by
+  obtain ⟨i, hi⟩ := exists_ne k
+  obtain ⟨j, hj⟩ := Fin.exists_succAbove_eq hi.symm
+  refine ⟨i, j, ?_⟩
+  rw [FirstHurewicz.simplexFace_vertex, hj]
+
+private def SecondHurewicz.SimplyConnected.simplexFaceInverse (n : ℕ) (i : Fin (n + 2)) :
+    C({ s : FirstHurewicz.Simplex (n + 1) // s i = 0 }, FirstHurewicz.Simplex n)
+    where
+  toFun
+    s :=
+    ⟨fun k => s.val (i.succAbove k),
+      ⟨fun k => stdSimplex.zero_le s.val (i.succAbove k),
+        by
+        have hs := stdSimplex.sum_eq_one s.val
+        rw [Fin.sum_univ_succAbove _ i, s.property, zero_add] at hs
+        exact hs⟩⟩
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    apply continuous_pi
+    intro k
+    have hc : Continuous (fun s : FirstHurewicz.Simplex (n + 1) => s (i.succAbove k)) :=
+      (continuous_apply (i.succAbove k)).comp continuous_subtype_val
+    exact hc.comp continuous_subtype_val
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.simplexFace_inverse (n : ℕ) (i : Fin (n + 2))
+    (s : { s : FirstHurewicz.Simplex (n + 1) // s i = 0 }) :
+    FirstHurewicz.simplexFace n i (simplexFaceInverse n i s) = s.val := by
+  apply Subtype.ext
+  funext k
+  change FirstHurewicz.simplexFace n i (simplexFaceInverse n i s) k = s.val k
+  by_cases hk : k = i
+  · subst k
+    exact (FirstHurewicz.simplexFace_apply_self n i _).trans s.property.symm
+  · obtain ⟨l, rfl⟩ := Fin.exists_succAbove_eq hk
+    exact FirstHurewicz.simplexFace_apply_succAbove n i _ l
+
+private theorem SecondHurewicz.SimplyConnected.simplexFace_range (n : ℕ) (i : Fin (n + 2)) :
+    Set.range (FirstHurewicz.simplexFace n i) = {s : FirstHurewicz.Simplex (n + 1) | s i = 0} := by
+  ext s
+  constructor
+  · rintro ⟨t, rfl⟩
+    exact FirstHurewicz.simplexFace_apply_self n i t
+  · intro hs
+    exact ⟨simplexFaceInverse n i ⟨s, hs⟩, simplexFace_inverse n i ⟨s, hs⟩⟩
+
+private theorem SecondHurewicz.SimplyConnected.simplexFace_injective (n : ℕ) (i : Fin (n + 2)) :
+    Function.Injective (FirstHurewicz.simplexFace n i) := by
+  intro s t h
+  apply Subtype.ext
+  funext k
+  change s k = t k
+  have hk := congrArg (fun u : FirstHurewicz.Simplex (n + 1) => u (i.succAbove k)) h
+  simpa only [FirstHurewicz.simplexFace_apply_succAbove] using hk
+
+private def SecondHurewicz.SimplyConnected.simplexFaceBoundary (n : ℕ) (i : Fin (n + 2)) :
+    C(FirstHurewicz.Simplex n, SimplexBoundary (n + 1))
+    where
+  toFun s := ⟨FirstHurewicz.simplexFace n i s, simplexFace_mem_boundary n i s⟩
+  continuous_toFun := (FirstHurewicz.simplexFace n i).continuous.subtype_mk _
+
+private theorem SecondHurewicz.SimplyConnected.simplexBoundary_exists_face (n : ℕ)
+    (s : SimplexBoundary (n + 1)) :
+    ∃ i : Fin (n + 2), ∃ t : FirstHurewicz.Simplex n, simplexFaceBoundary n i t = s := by
+  obtain ⟨i, hi⟩ := s.property
+  have hmem : s.val ∈ Set.range (FirstHurewicz.simplexFace n i) := by
+    rw [simplexFace_range]
+    exact hi
+  obtain ⟨t, ht⟩ := hmem
+  exact ⟨i, t, Subtype.ext ht⟩
+
+private def SecondHurewicz.SimplyConnected.simplexFaceCylinder (n : ℕ) (i : Fin (n + 2)) :
+    C((unitInterval) × FirstHurewicz.Simplex n, (unitInterval) × SimplexBoundary (n + 1)) :=
+  (ContinuousMap.id (unitInterval)).prodMap (simplexFaceBoundary n i)
+
+private def SecondHurewicz.SimplyConnected.simplexFaceCover (n : ℕ) :
+    C((Σ _i : Fin (n + 2), (unitInterval) × FirstHurewicz.Simplex n),
+      (unitInterval) × SimplexBoundary (n + 1))
+    where
+  toFun a := simplexFaceCylinder n a.fst a.snd
+  continuous_toFun := continuous_sigma fun i => (simplexFaceCylinder n i).continuous
+
+private theorem SecondHurewicz.SimplyConnected.simplexFaceCover_surjective (n : ℕ) :
+    Function.Surjective (simplexFaceCover n) := by
+  rintro ⟨r, s⟩
+  obtain ⟨i, t, rfl⟩ := simplexBoundary_exists_face n s
+  exact ⟨⟨i, (r, t)⟩, rfl⟩
+
+private theorem SecondHurewicz.SimplyConnected.simplexFaceCover_isQuotientMap (n : ℕ) :
+    Topology.IsQuotientMap (simplexFaceCover n) :=
+  Topology.IsQuotientMap.of_surjective_continuous (simplexFaceCover_surjective n)
+    (simplexFaceCover n).continuous
+
+private def SecondHurewicz.SimplyConnected.FaceCompatible {X : Type} [TopologicalSpace X] {n : ℕ}
+    (F : Fin (n + 2) → C((unitInterval) × FirstHurewicz.Simplex n, X)) : Prop :=
+  ∀ (i j : Fin (n + 2)) (s t : FirstHurewicz.Simplex n),
+    FirstHurewicz.simplexFace n i s = FirstHurewicz.simplexFace n j t →
+      ∀ r : (unitInterval), F i (r, s) = F j (r, t)
+
+private def SecondHurewicz.SimplyConnected.faceFamilyMap {X : Type} [TopologicalSpace X] {n : ℕ}
+    (F : Fin (n + 2) → C((unitInterval) × FirstHurewicz.Simplex n, X)) :
+    C((Σ _i : Fin (n + 2), (unitInterval) × FirstHurewicz.Simplex n), X)
+    where
+  toFun a := F a.fst a.snd
+  continuous_toFun := continuous_sigma fun i => (F i).continuous
+
+private theorem SecondHurewicz.SimplyConnected.faceFamilyMap_factorsThrough {X : Type}
+    [TopologicalSpace X] {n : ℕ}
+    (F : Fin (n + 2) → C((unitInterval) × FirstHurewicz.Simplex n, X)) (hF : FaceCompatible F) :
+    Function.FactorsThrough (faceFamilyMap F) (simplexFaceCover n) := by
+  rintro ⟨i, r, s⟩ ⟨j, q, t⟩ h
+  have hr : r = q := congrArg Prod.fst h
+  have hs : FirstHurewicz.simplexFace n i s = FirstHurewicz.simplexFace n j t :=
+    congrArg (fun u : (unitInterval) × SimplexBoundary (n + 1) => u.2.val) h
+  subst q
+  exact hF i j s t hs r
+
+private def
+    SecondHurewicz.SimplyConnected.glueFaceHomotopies {X : Type} [TopologicalSpace X] {n : ℕ}
+    (F : Fin (n + 2) → C((unitInterval) × FirstHurewicz.Simplex n, X)) (hF : FaceCompatible F) :
+    C((unitInterval) × SimplexBoundary (n + 1), X) :=
+  (simplexFaceCover_isQuotientMap n).lift (faceFamilyMap F) (faceFamilyMap_factorsThrough F hF)
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.glueFaceHomotopies_face {X : Type} [TopologicalSpace X]
+    {n : ℕ} (F : Fin (n + 2) → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (hF : FaceCompatible F) (i : Fin (n + 2)) (r : (unitInterval)) (s : FirstHurewicz.Simplex n) :
+    glueFaceHomotopies F hF (r, simplexFaceBoundary n i s) = F i (r, s) := by
+  exact
+    congrArg (fun f => f ⟨i, (r, s)⟩)
+      ((simplexFaceCover_isQuotientMap n).lift_comp (faceFamilyMap F)
+        (faceFamilyMap_factorsThrough F hF))
+
+private theorem
+    SecondHurewicz.SimplyConnected.glueFaceHomotopies_time {X : Type} [TopologicalSpace X]
+    {n : ℕ} (F : Fin (n + 2) → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (hF : FaceCompatible F) (r : (unitInterval)) (g : FirstHurewicz.Simplex (n + 1) → X)
+    (h :
+      ∀ (i : Fin (n + 2)) (s : FirstHurewicz.Simplex n),
+        F i (r, s) = g (FirstHurewicz.simplexFace n i s))
+    (b : SimplexBoundary (n + 1)) : glueFaceHomotopies F hF (r, b) = g b.val := by
+  obtain ⟨i, s, rfl⟩ := simplexBoundary_exists_face n b
+  exact (glueFaceHomotopies_face F hF i r s).trans (h i s)
+
+private theorem
+    SecondHurewicz.SimplyConnected.glueFaceHomotopies_zero {X : Type} [TopologicalSpace X]
+    {n : ℕ} (F : Fin (n + 2) → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (hF : FaceCompatible F) (g : C(FirstHurewicz.Simplex (n + 1), X))
+    (h :
+      ∀ (i : Fin (n + 2)) (s : FirstHurewicz.Simplex n),
+        F i (0, s) = g (FirstHurewicz.simplexFace n i s))
+    (b : SimplexBoundary (n + 1)) : glueFaceHomotopies F hF (0, b) = g b.val :=
+  glueFaceHomotopies_time F hF 0 g h b
+
+private theorem
+    SecondHurewicz.SimplyConnected.glueFaceHomotopies_unique {X : Type} [TopologicalSpace X]
+    {n : ℕ} (F : Fin (n + 2) → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (hF : FaceCompatible F) (G : C((unitInterval) × SimplexBoundary (n + 1), X))
+    (hG :
+      ∀ (i : Fin (n + 2)) (r : (unitInterval)) (s : FirstHurewicz.Simplex n),
+        G (r, simplexFaceBoundary n i s) = F i (r, s)) :
+    G = glueFaceHomotopies F hF := by
+  ext u
+  rcases u with ⟨r, b⟩
+  obtain ⟨i, s, rfl⟩ := simplexBoundary_exists_face n b
+  exact (hG i r s).trans (glueFaceHomotopies_face F hF i r s).symm
+
+private theorem SecondHurewicz.SimplyConnected.simplexFace_intersection {n : ℕ} {i j : Fin (n + 2)}
+    (hij : i ≤ j) {s t : FirstHurewicz.Simplex (n + 1)}
+    (h :
+      FirstHurewicz.simplexFace (n + 1) j.succ s =
+        FirstHurewicz.simplexFace (n + 1) i.castSucc t) :
+    ∃ u : FirstHurewicz.Simplex n,
+      FirstHurewicz.simplexFace n i u = s ∧ FirstHurewicz.simplexFace n j u = t := by
+  have hs : s i = 0 := by
+    calc
+      s i = FirstHurewicz.simplexFace (n + 1) j.succ s (j.succ.succAbove i) :=
+        (FirstHurewicz.simplexFace_apply_succAbove (n + 1) j.succ s i).symm
+      _ = FirstHurewicz.simplexFace (n + 1) j.succ s i.castSucc := by
+        rw [Fin.succAbove_succ_of_le j i hij]
+      _ = FirstHurewicz.simplexFace (n + 1) i.castSucc t i.castSucc :=
+        (congrArg (fun v : FirstHurewicz.Simplex (n + 2) => v i.castSucc) h)
+      _ = 0 := FirstHurewicz.simplexFace_apply_self (n + 1) i.castSucc t
+  let u := simplexFaceInverse n i ⟨s, hs⟩
+  have hu : FirstHurewicz.simplexFace n i u = s := simplexFace_inverse n i ⟨s, hs⟩
+  refine ⟨u, hu, simplexFace_injective (n + 1) i.castSucc ?_⟩
+  calc
+    FirstHurewicz.simplexFace (n + 1) i.castSucc (FirstHurewicz.simplexFace n j u) =
+        FirstHurewicz.simplexFace (n + 1) j.succ (FirstHurewicz.simplexFace n i u) :=
+      (congrArg (fun f : C(FirstHurewicz.Simplex n, FirstHurewicz.Simplex (n + 2)) => f u)
+          (PeriodTorusLineBundle.ChernCocycle.simplexFace_comp hij)).symm
+    _ = FirstHurewicz.simplexFace (n + 1) j.succ s :=
+      (congrArg (FirstHurewicz.simplexFace (n + 1) j.succ) hu)
+    _ = FirstHurewicz.simplexFace (n + 1) i.castSucc t := h
+
+private def SecondHurewicz.SimplyConnected.CofaceCompatible {X : Type} [TopologicalSpace X] {n : ℕ}
+    (F : Fin (n + 3) → C((unitInterval) × FirstHurewicz.Simplex (n + 1), X)) : Prop :=
+  ∀ (i j : Fin (n + 2)),
+    i ≤ j →
+      ∀ (r : (unitInterval)) (u : FirstHurewicz.Simplex n),
+        F j.succ (r, FirstHurewicz.simplexFace n i u) =
+          F i.castSucc (r, FirstHurewicz.simplexFace n j u)
+
+private theorem SecondHurewicz.SimplyConnected.faceCompatible_of_cofaceCompatible_lt_mo1973_6084
+    {X : Type} [TopologicalSpace X] {n : ℕ}
+    (F : Fin (n + 3) → C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (hF : CofaceCompatible F) {a b : Fin (n + 3)} (hab : a < b)
+    {s t : FirstHurewicz.Simplex (n + 1)}
+    (hst : FirstHurewicz.simplexFace (n + 1) a s = FirstHurewicz.simplexFace (n + 1) b t)
+    (r : (unitInterval)) : F a (r, s) = F b (r, t) := by
+  obtain ⟨i, rfl⟩ := Fin.exists_castSucc_eq.mpr (Fin.ne_last_of_lt hab)
+  obtain ⟨j, rfl⟩ := Fin.exists_succ_eq.mpr (Fin.ne_zero_of_lt hab)
+  have hij : i ≤ j := Fin.castSucc_lt_succ_iff.mp hab
+  obtain ⟨u, hu, hv⟩ := simplexFace_intersection hij hst.symm
+  rw [← hu, ← hv]
+  exact (hF i j hij r u).symm
+
+private theorem SecondHurewicz.SimplyConnected.faceCompatible_of_cofaceCompatible {X : Type}
+    [TopologicalSpace X] {n : ℕ}
+    (F : Fin (n + 3) → C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (hF : CofaceCompatible F) : FaceCompatible F := by
+  intro a b s t hst r
+  rcases lt_trichotomy a b with hab | hab | hba
+  · exact faceCompatible_of_cofaceCompatible_lt_mo1973_6084 F hF hab hst r
+  · subst b
+    exact congrArg (fun u => F a (r, u)) (simplexFace_injective (n + 1) a hst)
+  · exact (faceCompatible_of_cofaceCompatible_lt_mo1973_6084 F hF hba hst.symm r).symm
+
+private theorem SecondHurewicz.SimplyConnected.faceCompatible_zero {X : Type} [TopologicalSpace X]
+    (F : Fin 2 → C((unitInterval) × FirstHurewicz.Simplex 0, X)) : FaceCompatible F := by
+  intro i j s t hst r
+  have hs : s = t := by
+    rw [FirstHurewicz.simplexZero_eq_vertex s, FirstHurewicz.simplexZero_eq_vertex t]
+  subst t
+  fin_cases i <;> fin_cases j
+  · rfl
+  · have h : (1 : Fin 2) = 0 :=
+      stdSimplex.vertex_injective
+        ((FirstHurewicz.simplexFace_zero_zero s).symm.trans
+          (hst.trans (FirstHurewicz.simplexFace_zero_one s)))
+    exact False.elim ((by decide : (1 : Fin 2) ≠ 0) h)
+  · have h : (0 : Fin 2) = 1 :=
+      stdSimplex.vertex_injective
+        ((FirstHurewicz.simplexFace_zero_one s).symm.trans
+          (hst.trans (FirstHurewicz.simplexFace_zero_zero s)))
+    exact False.elim ((by decide : (0 : Fin 2) ≠ 1) h)
+  · rfl
+
+private def
+    SecondHurewicz.SimplyConnected.minimumCoordinate {n : ℕ} (s : FirstHurewicz.Simplex n) : ℝ :=
+  Finset.univ.inf' Finset.univ_nonempty (fun i => s i)
+
+private theorem SecondHurewicz.SimplyConnected.minimumCoordinate_nonneg {n : ℕ}
+    (s : FirstHurewicz.Simplex n) : 0 ≤ minimumCoordinate s :=
+  Finset.le_inf' _ _ fun i _ => stdSimplex.zero_le s i
+
+private theorem
+    SecondHurewicz.SimplyConnected.minimumCoordinate_le {n : ℕ} (s : FirstHurewicz.Simplex n)
+    (i : Fin (n + 1)) : minimumCoordinate s ≤ s i :=
+  Finset.inf'_le _ (Finset.mem_univ i)
+
+private theorem SecondHurewicz.SimplyConnected.exists_coordinate_eq_minimum {n : ℕ}
+    (s : FirstHurewicz.Simplex n) : ∃ i : Fin (n + 1), s i = minimumCoordinate s := by
+  obtain ⟨i, _, hi⟩ := Finset.exists_mem_eq_inf' Finset.univ_nonempty (fun i => s i)
+  exact ⟨i, hi.symm⟩
+
+private theorem SecondHurewicz.SimplyConnected.continuous_minimumCoordinate (n : ℕ) :
+    Continuous (minimumCoordinate (n := n)) :=
+  Continuous.finset_inf'_apply _ fun i _ => (continuous_apply i).comp continuous_subtype_val
+
+private theorem SecondHurewicz.SimplyConnected.minimumCoordinate_eq_zero_of_mem_boundary {n : ℕ}
+    {s : FirstHurewicz.Simplex n} (hs : s ∈ simplexBoundary n) : minimumCoordinate s = 0 := by
+  obtain ⟨i, hi⟩ := hs
+  exact le_antisymm (hi ▸ minimumCoordinate_le s i) (minimumCoordinate_nonneg s)
+
+private def SecondHurewicz.SimplyConnected.barycenterCoordinate (n : ℕ) : ℝ :=
+  ((n : ℝ) + 1)⁻¹
+
+private theorem
+    SecondHurewicz.SimplyConnected.simplexCard_pos (n : ℕ) : 0 < (n : ℝ) + 1 := by positivity
+
+private theorem SecondHurewicz.SimplyConnected.barycenterCoordinate_pos (n : ℕ) :
+    0 < barycenterCoordinate n :=
+  inv_pos.mpr (simplexCard_pos n)
+
+private theorem SecondHurewicz.SimplyConnected.card_mul_barycenterCoordinate (n : ℕ) :
+    ((n : ℝ) + 1) * barycenterCoordinate n = 1 :=
+  mul_inv_cancel₀ (ne_of_gt (simplexCard_pos n))
+
+private def SecondHurewicz.SimplyConnected.cylinderDenominator {n : ℕ}
+    (u : unitInterval × FirstHurewicz.Simplex n) : ℝ :=
+  Max.max (1 - (u.1 : ℝ) / 2) (1 - ((n : ℝ) + 1) * minimumCoordinate u.2)
+
+private theorem SecondHurewicz.SimplyConnected.cylinderDenominator_half_le {n : ℕ}
+    (u : unitInterval × FirstHurewicz.Simplex n) : 1 / 2 ≤ cylinderDenominator u := by
+  have ht := u.1.property.2
+  exact (show 1 / 2 ≤ 1 - (u.1 : ℝ) / 2 by linarith).trans (le_max_left _ _)
+
+private theorem SecondHurewicz.SimplyConnected.cylinderDenominator_pos {n : ℕ}
+    (u : unitInterval × FirstHurewicz.Simplex n) : 0 < cylinderDenominator u :=
+  lt_of_lt_of_le (by norm_num) (cylinderDenominator_half_le u)
+
+private theorem SecondHurewicz.SimplyConnected.cylinderDenominator_ne_zero {n : ℕ}
+    (u : unitInterval × FirstHurewicz.Simplex n) : cylinderDenominator u ≠ 0 :=
+  ne_of_gt (cylinderDenominator_pos u)
+
+private theorem SecondHurewicz.SimplyConnected.cylinderDenominator_le_one {n : ℕ}
+    (u : unitInterval × FirstHurewicz.Simplex n) : cylinderDenominator u ≤ 1 := by
+  apply max_le
+  · have ht := u.1.property.1
+    linarith
+  · have hm := mul_nonneg (le_of_lt (simplexCard_pos n)) (minimumCoordinate_nonneg u.2)
+    linarith
+
+private theorem SecondHurewicz.SimplyConnected.bottomDenominator_le {n : ℕ}
+    (u : unitInterval × FirstHurewicz.Simplex n) : 1 - (u.1 : ℝ) / 2 ≤ cylinderDenominator u :=
+  le_max_left _ _
+
+private theorem SecondHurewicz.SimplyConnected.sideDenominator_le {n : ℕ}
+    (u : unitInterval × FirstHurewicz.Simplex n) :
+    1 - ((n : ℝ) + 1) * minimumCoordinate u.2 ≤ cylinderDenominator u :=
+  le_max_right _ _
+
+private theorem SecondHurewicz.SimplyConnected.coordinateDenominator_le {n : ℕ}
+    (u : unitInterval × FirstHurewicz.Simplex n) (i : Fin (n + 1)) :
+    1 - ((n : ℝ) + 1) * u.2 i ≤ cylinderDenominator u := by
+  have hm := mul_le_mul_of_nonneg_left (minimumCoordinate_le u.2 i) (le_of_lt (simplexCard_pos n))
+  exact (sub_le_sub_left hm 1).trans (sideDenominator_le u)
+
+private theorem SecondHurewicz.SimplyConnected.continuous_cylinderDenominator (n : ℕ) :
+    Continuous (cylinderDenominator (n := n)) :=
+  (continuous_const.sub ((continuous_subtype_val.comp continuous_fst).div_const 2)).max
+    (continuous_const.sub
+      (continuous_const.mul ((continuous_minimumCoordinate n).comp continuous_snd)))
+
+private theorem SecondHurewicz.SimplyConnected.cylinderDenominator_eq_one_of_mem {n : ℕ}
+    {u : unitInterval × FirstHurewicz.Simplex n} (hu : u ∈ bottomOrSide n) :
+    cylinderDenominator u = 1 := by
+  apply le_antisymm (cylinderDenominator_le_one u)
+  rcases hu with ht | hs
+  · have h := bottomDenominator_le u
+    rw [ht] at h
+    change 1 - (0 : ℝ) / 2 ≤ cylinderDenominator u at h
+    simpa only [zero_div, sub_zero] using h
+  · have h := sideDenominator_le u
+    simpa only [minimumCoordinate_eq_zero_of_mem_boundary hs, MulZeroClass.mul_zero,
+      sub_zero] using h
+
+private theorem SecondHurewicz.SimplyConnected.retractedTime_nonneg {n : ℕ}
+    (u : unitInterval × FirstHurewicz.Simplex n) :
+    0 ≤ ((u.1 : ℝ) + 2 * cylinderDenominator u - 2) / cylinderDenominator u := by
+  apply div_nonneg _ (le_of_lt (cylinderDenominator_pos u))
+  have h := bottomDenominator_le u
+  linarith
+
+private theorem SecondHurewicz.SimplyConnected.retractedTime_le_one {n : ℕ}
+    (u : unitInterval × FirstHurewicz.Simplex n) :
+    ((u.1 : ℝ) + 2 * cylinderDenominator u - 2) / cylinderDenominator u ≤ 1 := by
+  apply (div_le_one (cylinderDenominator_pos u)).mpr
+  have ht := u.1.property.2
+  have hd := cylinderDenominator_le_one u
+  linarith
+
+private def SecondHurewicz.SimplyConnected.retractedTime {n : ℕ}
+    (u : unitInterval × FirstHurewicz.Simplex n) : unitInterval :=
+  ⟨((u.1 : ℝ) + 2 * cylinderDenominator u - 2) / cylinderDenominator u, retractedTime_nonneg u,
+    retractedTime_le_one u⟩
+
+private theorem SecondHurewicz.SimplyConnected.continuous_retractedTime (n : ℕ) :
+    Continuous (retractedTime (n := n)) := by
+  apply Continuous.subtype_mk
+  exact
+    (((continuous_subtype_val.comp continuous_fst).add
+              (continuous_const.mul (continuous_cylinderDenominator n))).sub
+          continuous_const).div
+      (continuous_cylinderDenominator n) cylinderDenominator_ne_zero
+
+private theorem SecondHurewicz.SimplyConnected.retractedCoordinate_numerator_nonneg {n : ℕ}
+    (u : unitInterval × FirstHurewicz.Simplex n) (i : Fin (n + 1)) :
+    0 ≤ u.2 i + (cylinderDenominator u - 1) * barycenterCoordinate n := by
+  have h :=
+    mul_nonneg (sub_nonneg.mpr (coordinateDenominator_le u i))
+      (le_of_lt (barycenterCoordinate_pos n))
+  have he :
+    (cylinderDenominator u - (1 - ((n : ℝ) + 1) * u.2 i)) * barycenterCoordinate n =
+      u.2 i + (cylinderDenominator u - 1) * barycenterCoordinate n := by
+    calc
+      _ =
+          (cylinderDenominator u - 1) * barycenterCoordinate n +
+            u.2 i * (((n : ℝ) + 1) * barycenterCoordinate n) := by ring
+      _ = _ := by rw [card_mul_barycenterCoordinate]; ring
+  exact he ▸ h
+
+private theorem SecondHurewicz.SimplyConnected.retractedCoordinate_nonneg {n : ℕ}
+    (u : unitInterval × FirstHurewicz.Simplex n) (i : Fin (n + 1)) :
+    0 ≤ (u.2 i + (cylinderDenominator u - 1) * barycenterCoordinate n) / cylinderDenominator u :=
+  div_nonneg (retractedCoordinate_numerator_nonneg u i) (le_of_lt (cylinderDenominator_pos u))
+
+private theorem SecondHurewicz.SimplyConnected.retractedCoordinates_sum {n : ℕ}
+    (u : unitInterval × FirstHurewicz.Simplex n) :
+    ∑ i : Fin (n + 1),
+        (u.2 i + (cylinderDenominator u - 1) * barycenterCoordinate n) / cylinderDenominator u =
+      1 := by
+  have hsum :
+    (∑ _i : Fin (n + 1), (cylinderDenominator u - 1) * barycenterCoordinate n) =
+      cylinderDenominator u - 1 := by
+    simp only [Finset.sum_const, Finset.card_univ, Fintype.card_fin, nsmul_eq_mul, Nat.cast_add,
+      Nat.cast_one]
+    calc
+      _ = (cylinderDenominator u - 1) * (((n : ℝ) + 1) * barycenterCoordinate n) := by ring
+      _ = _ := by rw [card_mul_barycenterCoordinate, mul_one]
+  simp_rw [div_eq_mul_inv]
+  rw [← Finset.sum_mul, Finset.sum_add_distrib, stdSimplex.sum_eq_one, hsum]
+  rw [show 1 + (cylinderDenominator u - 1) = cylinderDenominator u by ring,
+    mul_inv_cancel₀ (cylinderDenominator_ne_zero u)]
+
+private def SecondHurewicz.SimplyConnected.retractedSimplex {n : ℕ}
+    (u : unitInterval × FirstHurewicz.Simplex n) : FirstHurewicz.Simplex n :=
+  ⟨fun i =>
+    (u.2 i + (cylinderDenominator u - 1) * barycenterCoordinate n) / cylinderDenominator u,
+    retractedCoordinate_nonneg u, retractedCoordinates_sum u⟩
+
+private theorem SecondHurewicz.SimplyConnected.continuous_retractedSimplex (n : ℕ) :
+    Continuous (retractedSimplex (n := n)) := by
+  apply Continuous.subtype_mk
+  apply continuous_pi
+  intro i
+  exact
+    (((continuous_apply i).comp (continuous_subtype_val.comp continuous_snd)).add
+          (((continuous_cylinderDenominator n).sub continuous_const).mul continuous_const)).div
+      (continuous_cylinderDenominator n) cylinderDenominator_ne_zero
+
+private theorem SecondHurewicz.SimplyConnected.retractedTime_eq_of_mem {n : ℕ}
+    {u : unitInterval × FirstHurewicz.Simplex n} (hu : u ∈ bottomOrSide n) :
+    retractedTime u = u.1 := by
+  apply Subtype.ext
+  change ((u.1 : ℝ) + 2 * cylinderDenominator u - 2) / cylinderDenominator u = (u.1 : ℝ)
+  rw [cylinderDenominator_eq_one_of_mem hu]
+  ring
+
+private theorem SecondHurewicz.SimplyConnected.retractedSimplex_eq_of_mem {n : ℕ}
+    {u : unitInterval × FirstHurewicz.Simplex n} (hu : u ∈ bottomOrSide n) :
+    retractedSimplex u = u.2 := by
+  apply Subtype.ext
+  funext i
+  change
+    (u.2 i + (cylinderDenominator u - 1) * barycenterCoordinate n) / cylinderDenominator u = u.2 i
+  rw [cylinderDenominator_eq_one_of_mem hu]
+  simp
+
+private theorem SecondHurewicz.SimplyConnected.retracted_mem_bottomOrSide {n : ℕ}
+    (u : unitInterval × FirstHurewicz.Simplex n) :
+    (retractedTime u, retractedSimplex u) ∈ bottomOrSide n := by
+  rcases le_total (1 - ((n : ℝ) + 1) * minimumCoordinate u.2) (1 - (u.1 : ℝ) / 2) with h | h
+  · have hd : cylinderDenominator u = 1 - (u.1 : ℝ) / 2 := max_eq_left h
+    left
+    apply Subtype.ext
+    change ((u.1 : ℝ) + 2 * cylinderDenominator u - 2) / cylinderDenominator u = 0
+    have hn : (u.1 : ℝ) + 2 * cylinderDenominator u - 2 = 0 := by rw [hd]; ring
+    rw [hn, zero_div]
+  · have hd : cylinderDenominator u = 1 - ((n : ℝ) + 1) * minimumCoordinate u.2 := max_eq_right h
+    right
+    obtain ⟨i, hi⟩ := exists_coordinate_eq_minimum u.2
+    refine ⟨i, ?_⟩
+    change
+      (u.2 i + (cylinderDenominator u - 1) * barycenterCoordinate n) / cylinderDenominator u = 0
+    have hn : u.2 i + (cylinderDenominator u - 1) * barycenterCoordinate n = 0 := by
+      rw [hi, hd]
+      calc
+        _ =
+            minimumCoordinate u.2 -
+              minimumCoordinate u.2 * (((n : ℝ) + 1) * barycenterCoordinate n) := by ring
+        _ = 0 := by rw [card_mul_barycenterCoordinate]; ring
+    rw [hn, zero_div]
+
+private def SecondHurewicz.SimplyConnected.cylinderRetraction (n : ℕ) :
+    C(unitInterval × FirstHurewicz.Simplex n, ↥(bottomOrSide n))
+    where
+  toFun u := ⟨(retractedTime u, retractedSimplex u), retracted_mem_bottomOrSide u⟩
+  continuous_toFun :=
+    ((continuous_retractedTime n).prodMk (continuous_retractedSimplex n)).subtype_mk _
+
+private theorem SecondHurewicz.SimplyConnected.cylinderRetraction_val_of_mem {n : ℕ}
+    {u : unitInterval × FirstHurewicz.Simplex n} (hu : u ∈ bottomOrSide n) :
+    (cylinderRetraction n u).val = u :=
+  Prod.ext (retractedTime_eq_of_mem hu) (retractedSimplex_eq_of_mem hu)
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.cylinderRetraction_fix {n : ℕ} (u : ↥(bottomOrSide n)) :
+    cylinderRetraction n u.val = u :=
+  Subtype.ext (cylinderRetraction_val_of_mem u.property)
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.cylinderRetraction_bottom (n : ℕ)
+    (s : FirstHurewicz.Simplex n) : cylinderRetraction n (0, s) = bottomInclusion n s :=
+  cylinderRetraction_fix (bottomInclusion n s)
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.cylinderRetraction_side (n : ℕ) (t : unitInterval)
+    (s : SimplexBoundary n) : cylinderRetraction n (t, s.val) = sideInclusion n (t, s) :=
+  cylinderRetraction_fix (sideInclusion n (t, s))
+
+private def SecondHurewicz.SimplyConnected.gluedBoundaryFunction_mo1973_6129 {n : ℕ} {X : Type*}
+    [TopologicalSpace X] (f : C(FirstHurewicz.Simplex n, X))
+    (h : C(unitInterval × SimplexBoundary n, X)) (u : ↥(bottomOrSide n)) : X :=
+  if hu : u.val.1 = 0 then f u.val.2 else h (u.val.1, ⟨u.val.2, u.property.resolve_left hu⟩)
+
+private theorem SecondHurewicz.SimplyConnected.gluedBoundaryFunction_bottom_mo1973_6130 {n : ℕ}
+    {X : Type*} [TopologicalSpace X] (f : C(FirstHurewicz.Simplex n, X))
+    (h : C(unitInterval × SimplexBoundary n, X)) (u : ↥(bottomOrSide n)) (hu : u.val.1 = 0) :
+    gluedBoundaryFunction_mo1973_6129 f h u = f u.val.2 := by classical exact dite_eq_left hu
+
+private theorem SecondHurewicz.SimplyConnected.gluedBoundaryFunction_side_mo1973_6131 {n : ℕ}
+    {X : Type*} [TopologicalSpace X] (f : C(FirstHurewicz.Simplex n, X))
+    (h : C(unitInterval × SimplexBoundary n, X)) (h0 : ∀ s, h (0, s) = f s.val)
+    (u : ↥(bottomOrSide n)) (hu : u.val.2 ∈ simplexBoundary n) :
+    gluedBoundaryFunction_mo1973_6129 f h u = h (u.val.1, ⟨u.val.2, hu⟩) := by
+  classical
+  by_cases ht : u.val.1 = 0
+  · rw [gluedBoundaryFunction_bottom_mo1973_6130 f h u ht]
+    simpa only [ht] using (h0 ⟨u.val.2, hu⟩).symm
+  · exact dite_eq_right ht
+
+private theorem SecondHurewicz.SimplyConnected.continuous_gluedBoundaryFunction_mo1973_6132
+    {n : ℕ} {X : Type*} [TopologicalSpace X] (f : C(FirstHurewicz.Simplex n, X))
+    (h : C(unitInterval × SimplexBoundary n, X)) (h0 : ∀ s, h (0, s) = f s.val) :
+    Continuous (gluedBoundaryFunction_mo1973_6129 f h) := by
+  let B : Set (↥(bottomOrSide n)) := {u | u.val.1 = 0}
+  let S : Set (↥(bottomOrSide n)) := {u | u.val.2 ∈ simplexBoundary n}
+  have hB : IsClosed B :=
+    isClosed_eq (continuous_fst.comp continuous_subtype_val) continuous_const
+  have hS : IsClosed S :=
+    (isClosed_simplexBoundary n).preimage (continuous_snd.comp continuous_subtype_val)
+  have hcover : B ∪ S = Set.univ := by
+    apply Set.eq_univ_of_forall
+    intro u
+    exact u.property
+  have hbottom : ContinuousOn (gluedBoundaryFunction_mo1973_6129 f h) B :=
+    (f.continuous.comp (continuous_snd.comp continuous_subtype_val)).continuousOn.congr
+      (fun u hu => gluedBoundaryFunction_bottom_mo1973_6130 f h u hu)
+  have hside : ContinuousOn (gluedBoundaryFunction_mo1973_6129 f h) S := by
+    apply continuousOn_iff_continuous_domRestrict.mpr
+    have hc : Continuous (fun u : S => h (u.val.val.1, ⟨u.val.val.2, u.property⟩)) :=
+      h.continuous.comp
+        ((continuous_fst.comp (continuous_subtype_val.comp continuous_subtype_val)).prodMk
+          ((continuous_snd.comp (continuous_subtype_val.comp continuous_subtype_val)).subtype_mk
+            _))
+    exact hc.congr fun u => (gluedBoundaryFunction_side_mo1973_6131 f h h0 u.val u.property).symm
+  apply continuousOn_univ.mp
+  rw [← hcover]
+  exact hbottom.union_of_isClosed hside hB hS
+
+private def SecondHurewicz.SimplyConnected.gluedBoundaryMap {n : ℕ} {X : Type*} [TopologicalSpace X]
+    (f : C(FirstHurewicz.Simplex n, X)) (h : C(unitInterval × SimplexBoundary n, X))
+    (h0 : ∀ s, h (0, s) = f s.val) : C(↥(bottomOrSide n), X)
+    where
+  toFun := gluedBoundaryFunction_mo1973_6129 f h
+  continuous_toFun := continuous_gluedBoundaryFunction_mo1973_6132 f h h0
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.gluedBoundaryMap_bottomInclusion {n : ℕ} {X : Type*}
+    [TopologicalSpace X] (f : C(FirstHurewicz.Simplex n, X))
+    (h : C(unitInterval × SimplexBoundary n, X)) (h0 : ∀ s, h (0, s) = f s.val)
+    (s : FirstHurewicz.Simplex n) : gluedBoundaryMap f h h0 (bottomInclusion n s) = f s :=
+  gluedBoundaryFunction_bottom_mo1973_6130 f h (bottomInclusion n s) rfl
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.gluedBoundaryMap_sideInclusion {n : ℕ} {X : Type*}
+    [TopologicalSpace X] (f : C(FirstHurewicz.Simplex n, X))
+    (h : C(unitInterval × SimplexBoundary n, X)) (h0 : ∀ s, h (0, s) = f s.val)
+    (u : unitInterval × SimplexBoundary n) : gluedBoundaryMap f h h0 (sideInclusion n u) = h u :=
+  gluedBoundaryFunction_side_mo1973_6131 f h h0 (sideInclusion n u) u.2.property
+
+private def
+    SecondHurewicz.SimplyConnected.extendBoundaryHomotopy {n : ℕ} {X : Type*} [TopologicalSpace X]
+    (f : C(FirstHurewicz.Simplex n, X)) (h : C(unitInterval × SimplexBoundary n, X))
+    (h0 : ∀ s, h (0, s) = f s.val) : C(unitInterval × FirstHurewicz.Simplex n, X) :=
+  (gluedBoundaryMap f h h0).comp (cylinderRetraction n)
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.extendBoundaryHomotopy_bottom {n : ℕ} {X : Type*}
+    [TopologicalSpace X] (f : C(FirstHurewicz.Simplex n, X))
+    (h : C(unitInterval × SimplexBoundary n, X)) (h0 : ∀ s, h (0, s) = f s.val)
+    (s : FirstHurewicz.Simplex n) : extendBoundaryHomotopy f h h0 (0, s) = f s := by
+  change gluedBoundaryMap f h h0 (cylinderRetraction n (0, s)) = f s
+  rw [cylinderRetraction_bottom, gluedBoundaryMap_bottomInclusion]
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.extendBoundaryHomotopy_side {n : ℕ} {X : Type*}
+    [TopologicalSpace X] (f : C(FirstHurewicz.Simplex n, X))
+    (h : C(unitInterval × SimplexBoundary n, X)) (h0 : ∀ s, h (0, s) = f s.val) (t : unitInterval)
+    (s : SimplexBoundary n) : extendBoundaryHomotopy f h h0 (t, s.val) = h (t, s) := by
+  change gluedBoundaryMap f h h0 (cylinderRetraction n (t, s.val)) = h (t, s)
+  rw [cylinderRetraction_side, gluedBoundaryMap_sideInclusion]
+
+private theorem SecondHurewicz.SimplyConnected.extendBoundaryHomotopy_boundary {n : ℕ} {X : Type*}
+    [TopologicalSpace X] (f : C(FirstHurewicz.Simplex n, X))
+    (h : C(unitInterval × SimplexBoundary n, X)) (h0 : ∀ s, h (0, s) = f s.val) (t : unitInterval)
+    (s : FirstHurewicz.Simplex n) (hs : s ∈ simplexBoundary n) :
+    extendBoundaryHomotopy f h h0 (t, s) = h (t, ⟨s, hs⟩) :=
+  extendBoundaryHomotopy_side f h h0 t ⟨s, hs⟩
+
+private theorem SecondHurewicz.SimplyConnected.extendBoundaryHomotopy_face {n : ℕ} {X : Type*}
+    [TopologicalSpace X] (f : C(FirstHurewicz.Simplex (n + 1), X))
+    (h : C(unitInterval × SimplexBoundary (n + 1), X)) (h0 : ∀ s, h (0, s) = f s.val)
+    (t : unitInterval) (i : Fin (n + 2)) (s : FirstHurewicz.Simplex n) :
+    extendBoundaryHomotopy f h h0 (t, FirstHurewicz.simplexFace n i s) =
+      h (t, ⟨FirstHurewicz.simplexFace n i s, simplexFace_mem_boundary n i s⟩) :=
+  extendBoundaryHomotopy_boundary f h h0 t _ (simplexFace_mem_boundary n i s)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    SecondHurewicz.crossProductTriangle_zero_eq_zeroRight (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] :
+    PeriodTorusHigherHomology.crossProductTriangle X Y 0 =
+      PeriodTorusHigherHomology.crossProductZeroRight X Y 2 := by
+  apply PeriodTorusHigherHomology.chainBilinearMap_ext X Y 2 0
+  intro σ τ
+  rw [PeriodTorusHigherHomology.crossProductTriangle_simplex,
+    PeriodTorusHigherHomology.formalTriangleCrossProduct_zero_simplex_right,
+    SingularMayerVietoris.formalMap_simplex,
+    PeriodTorusHigherHomology.productAffineChainMap_simplex, FirstHurewicz.inducedChain_simplex,
+    PeriodTorusHigherHomology.crossProductZeroRight_simplex]
+  apply congrArg (FirstHurewicz.simplexChain (X × Y) 2)
+  change
+    (σ.prodMap τ).comp
+        (PeriodTorusHigherHomology.productAffineSimplex
+          (fun i =>
+            (SingularMayerVietoris.stdVertices 2 i, SingularMayerVietoris.stdVertices 0 0))) =
+      (PeriodTorusHigherHomology.crossInsertRight
+            (PeriodTorusHigherHomology.zeroSimplexValue τ)).comp
+        σ
+  rw [PeriodTorusHigherHomology.productAffineSimplex_point_right,
+    SingularMayerVietoris.affineSimplex_stdVertices, ContinuousMap.comp_id]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SecondHurewicz.crossProductTriangle_point_right (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (a : FirstHurewicz.Chains X 2) (y : Y) :
+    PeriodTorusHigherHomology.crossProductTriangle X Y 0 a (FirstHurewicz.pointChain y) =
+      FirstHurewicz.inducedChain (PeriodTorusHigherHomology.crossInsertRight y) 2 a := by
+  rw [crossProductTriangle_zero_eq_zeroRight, FirstHurewicz.pointChain,
+    PeriodTorusHigherHomology.crossProductZeroRight_simplex_right]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SecondHurewicz.crossProductEdge_point_right (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (a : FirstHurewicz.Chains X 1) (y : Y) :
+    PeriodTorusHigherHomology.crossProductEdge X Y 0 a (FirstHurewicz.pointChain y) =
+      FirstHurewicz.inducedChain (PeriodTorusHigherHomology.crossInsertRight y) 1 a := by
+  rw [FirstHurewicz.pointChain, PeriodTorusHigherHomology.crossProductEdge_zero_simplex_right]
+  rfl
+
+private abbrev SecondHurewicz.Remaining :=
+  { j : Fin 2 // j ≠ 0 }
+
+private abbrev SecondHurewicz.BasedLoopSpace {X : Type} [TopologicalSpace X] (x : X) :=
+  GenLoop Remaining X x
+
+private def SecondHurewicz.evaluation {X : Type} [TopologicalSpace X] (x : X) :
+    C(BasedLoopSpace x × (unitInterval), X)
+    where
+  toFun z := z.1 (fun _ => z.2)
+  continuous_toFun := by fun_prop
+
+@[simp]
+private theorem SecondHurewicz.evaluation_zero {X : Type} [TopologicalSpace X] (x : X)
+    (p : BasedLoopSpace x) : evaluation x (p, 0) = x :=
+  GenLoop.boundary p _ ⟨⟨1, by decide⟩, Or.inl rfl⟩
+
+@[simp]
+private theorem SecondHurewicz.evaluation_one {X : Type} [TopologicalSpace X] (x : X)
+    (p : BasedLoopSpace x) : evaluation x (p, 1) = x :=
+  GenLoop.boundary p _ ⟨⟨1, by decide⟩, Or.inr rfl⟩
+
+@[simp]
+private theorem SecondHurewicz.evaluation_comp_right_zero {X : Type} [TopologicalSpace X] (x : X) :
+    (evaluation x).comp (PeriodTorusHigherHomology.crossInsertRight (0 : (unitInterval))) =
+      ContinuousMap.const (BasedLoopSpace x) x := by
+  ext p
+  exact evaluation_zero x p
+
+@[simp]
+private theorem SecondHurewicz.evaluation_comp_right_one {X : Type} [TopologicalSpace X] (x : X) :
+    (evaluation x).comp (PeriodTorusHigherHomology.crossInsertRight (1 : (unitInterval))) =
+      ContinuousMap.const (BasedLoopSpace x) x := by
+  ext p
+  exact evaluation_one x p
+
+private def
+    SecondHurewicz.squareCoordinates : C((unitInterval) × (unitInterval), Fin 2 → (unitInterval))
+    where
+  toFun z := Cube.insertAt (0 : Fin 2) (z.1, fun _ => z.2)
+  continuous_toFun := by fun_prop
+
+@[simp]
+private theorem SecondHurewicz.squareCoordinates_zero (z : (unitInterval) × (unitInterval)) :
+    squareCoordinates z 0 = z.1 := by
+  simp [squareCoordinates, Cube.insertAt, Homeomorph.funSplitAt_symm_apply]
+
+@[simp]
+private theorem SecondHurewicz.squareCoordinates_one (z : (unitInterval) × (unitInterval)) :
+    squareCoordinates z 1 = z.2 := by
+  simp [squareCoordinates, Cube.insertAt, Homeomorph.funSplitAt_symm_apply]
+
+private def
+    SecondHurewicz.squareMap {X : Type} [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x) :
+    C((unitInterval) × (unitInterval), X) :=
+  p.val.comp squareCoordinates
+
+private theorem SecondHurewicz.evaluation_comp_toLoop {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 2) X x) :
+    (evaluation x).comp
+        ((GenLoop.toLoop (0 : Fin 2) p).toContinuousMap.prodMap
+          (ContinuousMap.id (unitInterval))) =
+      squareMap p := by
+  ext z
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SecondHurewicz.intervalChain : FirstHurewicz.Chains (unitInterval) 1 :=
+  FirstHurewicz.pathChain Path.id
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SecondHurewicz.intervalChain_boundary :
+    FirstHurewicz.boundaryOne (unitInterval) intervalChain =
+      FirstHurewicz.pointChain (1 : (unitInterval)) -
+        FirstHurewicz.pointChain (0 : (unitInterval)) :=
+  FirstHurewicz.boundaryOne_pathChain Path.id
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    SecondHurewicz.evaluation_right_zero_chain {X : Type} [TopologicalSpace X] (x : X) (n : ℕ)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) n) :
+    FirstHurewicz.inducedChain (evaluation x) n
+        (FirstHurewicz.inducedChain
+          (PeriodTorusHigherHomology.crossInsertRight (0 : (unitInterval))) n a) =
+      FirstHurewicz.inducedChain (ContinuousMap.const (BasedLoopSpace x) x) n a := by
+  change
+    ((FirstHurewicz.inducedChain (evaluation x) n).comp
+          (FirstHurewicz.inducedChain
+            (PeriodTorusHigherHomology.crossInsertRight (0 : (unitInterval))) n))
+        a =
+      _
+  rw [← FirstHurewicz.inducedChain_comp, evaluation_comp_right_zero]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    SecondHurewicz.evaluation_right_one_chain {X : Type} [TopologicalSpace X] (x : X) (n : ℕ)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) n) :
+    FirstHurewicz.inducedChain (evaluation x) n
+        (FirstHurewicz.inducedChain
+          (PeriodTorusHigherHomology.crossInsertRight (1 : (unitInterval))) n a) =
+      FirstHurewicz.inducedChain (ContinuousMap.const (BasedLoopSpace x) x) n a := by
+  change
+    ((FirstHurewicz.inducedChain (evaluation x) n).comp
+          (FirstHurewicz.inducedChain
+            (PeriodTorusHigherHomology.crossInsertRight (1 : (unitInterval))) n))
+        a =
+      _
+  rw [← FirstHurewicz.inducedChain_comp, evaluation_comp_right_one]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    SecondHurewicz.evaluated_edge_endpoint_cancel {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 1) :
+    FirstHurewicz.inducedChain (evaluation x) 1
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (unitInterval) 0 a
+          (FirstHurewicz.boundaryOne (unitInterval) intervalChain)) =
+      0 := by
+  simp only [intervalChain_boundary, map_sub, crossProductEdge_point_right,
+    evaluation_right_one_chain, evaluation_right_zero_chain, sub_self]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    SecondHurewicz.evaluated_triangle_endpoint_cancel {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 2) :
+    FirstHurewicz.inducedChain (evaluation x) 2
+        (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x) (unitInterval) 0 a
+          (FirstHurewicz.boundaryOne (unitInterval) intervalChain)) =
+      0 := by
+  simp only [intervalChain_boundary, map_sub, crossProductTriangle_point_right,
+    evaluation_right_one_chain, evaluation_right_zero_chain, sub_self]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SecondHurewicz.suspensionOne {X : Type} [TopologicalSpace X] (x : X) :
+    FirstHurewicz.Chains (BasedLoopSpace x) 1 →ₗ[ℤ] FirstHurewicz.Chains X 2 :=
+  (FirstHurewicz.inducedChain (evaluation x) 2).comp
+    (PeriodTorusHigherHomology.integerBilinearRightApply
+      (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (unitInterval) 1)
+      intervalChain)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem SecondHurewicz.suspensionOne_apply {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 1) :
+    suspensionOne x a =
+      FirstHurewicz.inducedChain (evaluation x) 2
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (unitInterval) 1 a
+          intervalChain) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SecondHurewicz.suspensionTwo {X : Type} [TopologicalSpace X] (x : X) :
+    FirstHurewicz.Chains (BasedLoopSpace x) 2 →ₗ[ℤ] FirstHurewicz.Chains X 3 :=
+  (FirstHurewicz.inducedChain (evaluation x) 3).comp
+    (PeriodTorusHigherHomology.integerBilinearRightApply
+      (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x) (unitInterval) 1)
+      intervalChain)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem SecondHurewicz.suspensionTwo_apply {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 2) :
+    suspensionTwo x a =
+      FirstHurewicz.inducedChain (evaluation x) 3
+        (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x) (unitInterval) 1 a
+          intervalChain) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    SecondHurewicz.boundaryTwo_suspensionOne_of_cycle {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 1)
+    (ha : FirstHurewicz.boundaryOne (BasedLoopSpace x) a = 0) :
+    FirstHurewicz.boundaryTwo X (suspensionOne x a) = 0 := by
+  change ((FirstHurewicz.singularComplex X).d 2 1).hom (suspensionOne x a) = 0
+  rw [suspensionOne_apply, ← FirstHurewicz.inducedChain_boundary,
+    PeriodTorusHigherHomology.crossProductEdge_boundary 0]
+  change
+    FirstHurewicz.inducedChain (evaluation x) 1
+        (PeriodTorusHigherHomology.crossProductZeroLeft (BasedLoopSpace x) (unitInterval) 1
+            (FirstHurewicz.boundaryOne (BasedLoopSpace x) a) intervalChain -
+          PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (unitInterval) 0 a
+            (FirstHurewicz.boundaryOne (unitInterval) intervalChain)) =
+      0
+  rw [ha, map_zero, LinearMap.zero_apply, zero_sub, map_neg, evaluated_edge_endpoint_cancel,
+    neg_zero]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SecondHurewicz.boundaryThree_suspensionTwo {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 2) :
+    ((FirstHurewicz.singularComplex X).d 3 2).hom (suspensionTwo x a) =
+      suspensionOne x (FirstHurewicz.boundaryTwo (BasedLoopSpace x) a) := by
+  rw [suspensionTwo_apply, ← FirstHurewicz.inducedChain_boundary,
+    PeriodTorusHigherHomology.crossProductTriangle_boundary 0]
+  change
+    FirstHurewicz.inducedChain (evaluation x) 2
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (unitInterval) 1
+            (FirstHurewicz.boundaryTwo (BasedLoopSpace x) a) intervalChain +
+          PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x) (unitInterval) 0 a
+            (FirstHurewicz.boundaryOne (unitInterval) intervalChain)) =
+      _
+  rw [map_add, evaluated_triangle_endpoint_cancel, add_zero]
+  rfl
+
+private def SecondHurewicz.pathSquareCycle {X : Type} [TopologicalSpace X] (x : X)
+    (p : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2 :=
+  SingularMayerVietoris.ModuleHomology.mkCycle (FirstHurewicz.singularComplex X) 2
+    (suspensionOne x (FirstHurewicz.pathChain p))
+    (boundaryTwo_suspensionOne_of_cycle x (FirstHurewicz.pathChain p)
+      (FirstHurewicz.boundaryOne_loop p))
+
+@[simp]
+private theorem SecondHurewicz.pathSquareCycle_val {X : Type} [TopologicalSpace X] (x : X)
+    (p : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    (pathSquareCycle x p).1 = suspensionOne x (FirstHurewicz.pathChain p) :=
+  rfl
+
+private def SecondHurewicz.pathSquareClass {X : Type} [TopologicalSpace X] (x : X)
+    (p : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    SingularMayerVietoris.SingularHomology X 2 :=
+  SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 2
+    (pathSquareCycle x p)
+
+private theorem SecondHurewicz.pathSquare_homotopy_boundary {X : Type} [TopologicalSpace X] (x : X)
+    {p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const} (H : p.Homotopy q) :
+    ((FirstHurewicz.singularComplex X).d 3 2).hom
+        (suspensionTwo x (FirstHurewicz.homotopyChain H)) =
+      (pathSquareCycle x p).1 - (pathSquareCycle x q).1 := by
+  rw [boundaryThree_suspensionTwo, FirstHurewicz.boundaryTwo_loopHomotopy, map_sub]
+  rfl
+
+private theorem SecondHurewicz.pathSquareClass_homotopy {X : Type} [TopologicalSpace X] (x : X)
+    {p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const} (H : p.Homotopy q) :
+    pathSquareClass x p = pathSquareClass x q :=
+  (SingularMayerVietoris.ModuleHomology.cycleClass_eq_iff (FirstHurewicz.singularComplex X) 2 _
+        _).mpr
+    ⟨suspensionTwo x (FirstHurewicz.homotopyChain H), pathSquare_homotopy_boundary x H⟩
+
+private theorem SecondHurewicz.pathSquareClass_homotopic {X : Type} [TopologicalSpace X] (x : X)
+    {p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const} (h : p.Homotopic q) :
+    pathSquareClass x p = pathSquareClass x q := by
+  obtain ⟨H⟩ := h
+  exact pathSquareClass_homotopy x H
+
+@[simp]
+private theorem SecondHurewicz.pathSquareClass_refl {X : Type} [TopologicalSpace X] (x : X) :
+    pathSquareClass x (Path.refl (GenLoop.const : BasedLoopSpace x)) = 0 := by
+  apply
+    (SingularMayerVietoris.ModuleHomology.cycleClass_eq_zero_iff (FirstHurewicz.singularComplex X)
+        2 _).mpr
+  refine
+    ⟨suspensionTwo x (FirstHurewicz.constantTriangleChain (GenLoop.const : BasedLoopSpace x)), ?_⟩
+  rw [boundaryThree_suspensionTwo, FirstHurewicz.boundaryTwo_constantTriangleChain]
+  rfl
+
+private theorem SecondHurewicz.pathSquare_concat_boundary {X : Type} [TopologicalSpace X] (x : X)
+    (p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    ((FirstHurewicz.singularComplex X).d 3 2).hom
+        (-suspensionTwo x (FirstHurewicz.concatChain p q)) =
+      (pathSquareCycle x (p.trans q)).1 - ((pathSquareCycle x p).1 + (pathSquareCycle x q).1) := by
+  rw [map_neg, boundaryThree_suspensionTwo, FirstHurewicz.boundaryTwo_concatChain, map_add,
+    map_sub]
+  simp only [pathSquareCycle_val]
+  abel
+
+private theorem SecondHurewicz.pathSquareClass_trans {X : Type} [TopologicalSpace X] (x : X)
+    (p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    pathSquareClass x (p.trans q) = pathSquareClass x p + pathSquareClass x q := by
+  unfold pathSquareClass
+  rw [← map_add]
+  apply
+    (SingularMayerVietoris.ModuleHomology.cycleClass_eq_iff (FirstHurewicz.singularComplex X) 2 _
+        _).mpr
+  exact ⟨-suspensionTwo x (FirstHurewicz.concatChain p q), pathSquare_concat_boundary x p q⟩
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SecondHurewicz.productSquareChain :
+    FirstHurewicz.Chains ((unitInterval) × (unitInterval)) 2 :=
+  PeriodTorusHigherHomology.crossProductEdge (unitInterval) (unitInterval) 1 intervalChain
+    intervalChain
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SecondHurewicz.productSquareChain_boundary :
+    FirstHurewicz.boundaryTwo ((unitInterval) × (unitInterval)) productSquareChain =
+      FirstHurewicz.inducedChain (PeriodTorusHigherHomology.crossInsertLeft (1 : (unitInterval)))
+            1 intervalChain -
+          FirstHurewicz.inducedChain
+            (PeriodTorusHigherHomology.crossInsertLeft (0 : (unitInterval))) 1 intervalChain -
+        (FirstHurewicz.inducedChain
+            (PeriodTorusHigherHomology.crossInsertRight (1 : (unitInterval))) 1 intervalChain -
+          FirstHurewicz.inducedChain
+            (PeriodTorusHigherHomology.crossInsertRight (0 : (unitInterval))) 1 intervalChain) := by
+  change
+    ((FirstHurewicz.singularComplex ((unitInterval) × (unitInterval))).d 2 1).hom
+        (PeriodTorusHigherHomology.crossProductEdge (unitInterval) (unitInterval) 1 intervalChain
+          intervalChain) =
+      _
+  rw [PeriodTorusHigherHomology.crossProductEdge_boundary 0]
+  change
+    PeriodTorusHigherHomology.crossProductZeroLeft (unitInterval) (unitInterval) 1
+          (FirstHurewicz.boundaryOne (unitInterval) intervalChain) intervalChain -
+        PeriodTorusHigherHomology.crossProductEdge (unitInterval) (unitInterval) 0 intervalChain
+          (FirstHurewicz.boundaryOne (unitInterval) intervalChain) =
+      _
+  simp only [intervalChain_boundary, map_sub, LinearMap.sub_apply, crossProductEdge_point_right]
+  simp only [FirstHurewicz.pointChain,
+    PeriodTorusHigherHomology.crossProductZeroLeft_simplex_left]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    SecondHurewicz.fundamentalSquareChain : FirstHurewicz.Chains (Fin 2 → (unitInterval)) 2 :=
+  FirstHurewicz.inducedChain squareCoordinates 2 productSquareChain
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SecondHurewicz.induced_intervalChain {X : Type} [TopologicalSpace X] {a b : X}
+    (p : Path a b) :
+    FirstHurewicz.inducedChain p.toContinuousMap 1 intervalChain = FirstHurewicz.pathChain p := by
+  rw [intervalChain, FirstHurewicz.pathChain, FirstHurewicz.inducedChain_simplex]
+  apply congrArg (FirstHurewicz.simplexChain X 1)
+  ext s
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SecondHurewicz.suspensionOne_toLoop {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 2) X x) :
+    suspensionOne x (FirstHurewicz.pathChain (GenLoop.toLoop (0 : Fin 2) p)) =
+      FirstHurewicz.inducedChain (squareMap p) 2 productSquareChain := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductEdge_natural
+      (GenLoop.toLoop (0 : Fin 2) p).toContinuousMap (ContinuousMap.id (unitInterval)) 1
+      intervalChain intervalChain
+  rw [induced_intervalChain, FirstHurewicz.inducedChain_id, LinearMap.id_apply] at h
+  rw [suspensionOne_apply, ← h]
+  change
+    ((FirstHurewicz.inducedChain (evaluation x) 2).comp
+          (FirstHurewicz.inducedChain
+            ((GenLoop.toLoop (0 : Fin 2) p).toContinuousMap.prodMap
+              (ContinuousMap.id (unitInterval)))
+            2))
+        productSquareChain =
+      _
+  rw [← FirstHurewicz.inducedChain_comp, evaluation_comp_toLoop]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    SecondHurewicz.squareChain {X : Type} [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x) :
+    FirstHurewicz.Chains X 2 :=
+  suspensionOne x (FirstHurewicz.pathChain (GenLoop.toLoop (0 : Fin 2) p))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SecondHurewicz.squareChain_boundary {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 2) X x) : FirstHurewicz.boundaryTwo X (squareChain p) = 0 :=
+  boundaryTwo_suspensionOne_of_cycle x _ (FirstHurewicz.boundaryOne_loop (GenLoop.toLoop 0 p))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    SecondHurewicz.squareCycle {X : Type} [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2 :=
+  pathSquareCycle x (GenLoop.toLoop (0 : Fin 2) p)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SecondHurewicz.squareHomologyClass {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 2) X x) : SingularMayerVietoris.SingularHomology X 2 :=
+  SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 2
+    (squareCycle p)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    SecondHurewicz.squareHomologyClass_eq_pathSquareClass {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 2) X x) :
+    squareHomologyClass p = pathSquareClass x (GenLoop.toLoop (0 : Fin 2) p) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SecondHurewicz.squareHomologyClass_homotopic {X : Type} [TopologicalSpace X] {x : X}
+    {p q : GenLoop (Fin 2) X x} (h : GenLoop.Homotopic p q) :
+    squareHomologyClass p = squareHomologyClass q :=
+  pathSquareClass_homotopic x (GenLoop.homotopicTo (0 : Fin 2) h)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SecondHurewicz.toLoop_const {X : Type} [TopologicalSpace X] {x : X} :
+    GenLoop.toLoop (0 : Fin 2) (GenLoop.const : GenLoop (Fin 2) X x) =
+      Path.refl (GenLoop.const : BasedLoopSpace x) := by
+  apply Path.ext
+  funext t
+  apply GenLoop.ext
+  intro u
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem SecondHurewicz.squareHomologyClass_const {X : Type} [TopologicalSpace X] {x : X} :
+    squareHomologyClass (GenLoop.const : GenLoop (Fin 2) X x) = 0 := by
+  rw [squareHomologyClass_eq_pathSquareClass, toLoop_const, pathSquareClass_refl]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SecondHurewicz.toLoop_transAt {X : Type} [TopologicalSpace X] {x : X}
+    (p q : GenLoop (Fin 2) X x) :
+    GenLoop.toLoop (0 : Fin 2) (GenLoop.transAt (0 : Fin 2) p q) =
+      (GenLoop.toLoop (0 : Fin 2) p).trans (GenLoop.toLoop (0 : Fin 2) q) := by
+  have h :=
+    congrArg (GenLoop.toLoop (0 : Fin 2))
+      (GenLoop.fromLoop_trans_toLoop (i := (0 : Fin 2)) (p := p) (q := q))
+  rw [GenLoop.to_from] at h
+  exact h.symm
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SecondHurewicz.squareHomologyClass_transAt {X : Type} [TopologicalSpace X] {x : X}
+    (p q : GenLoop (Fin 2) X x) :
+    squareHomologyClass (GenLoop.transAt (0 : Fin 2) p q) =
+      squareHomologyClass p + squareHomologyClass q := by
+  simp only [squareHomologyClass_eq_pathSquareClass, toLoop_transAt, pathSquareClass_trans]
+
+private def SecondHurewicz.mapGenLoop {N X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (f : C(X, Y)) (x : X) : C(GenLoop N X x, GenLoop N Y (f x))
+    where
+  toFun p := ⟨f.comp p.val, fun t ht => congrArg f (p.property t ht)⟩
+  continuous_toFun :=
+    ((ContinuousMap.continuous_postcomp f).comp continuous_subtype_val).subtype_mk _
+
+@[simp]
+private theorem
+    SecondHurewicz.mapGenLoop_val {N X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (f : C(X, Y)) (x : X) (p : GenLoop N X x) : (mapGenLoop f x p).val = f.comp p.val :=
+  rfl
+
+@[simp]
+private theorem
+    SecondHurewicz.mapGenLoop_const {N X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (f : C(X, Y)) (x : X) : mapGenLoop (N := N) f x GenLoop.const = GenLoop.const :=
+  rfl
+
+private theorem SecondHurewicz.mapGenLoop_homotopic {N X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (x : X) {p q : GenLoop N X x} (h : GenLoop.Homotopic p q) :
+    GenLoop.Homotopic (mapGenLoop f x p) (mapGenLoop f x q) :=
+  h.comp_continuousMap f
+
+@[simp]
+private theorem
+    SecondHurewicz.mapGenLoop_transAt {N X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    [DecidableEq N] (f : C(X, Y)) (x : X) (i : N) (p q : GenLoop N X x) :
+    mapGenLoop f x (GenLoop.transAt i p q) =
+      GenLoop.transAt i (mapGenLoop f x p) (mapGenLoop f x q) := by
+  apply GenLoop.ext
+  intro t
+  change f (if (t i : ℝ) ≤ 1 / 2 then _ else _) = if (t i : ℝ) ≤ 1 / 2 then _ else _
+  split_ifs <;> rfl
+
+private def SecondHurewicz.hurewiczFunction {X : Type} [TopologicalSpace X] (x : X) :
+    π_ 2 X x → SingularMayerVietoris.SingularHomology X 2 :=
+  Quotient.lift squareHomologyClass (fun _ _ h => squareHomologyClass_homotopic h)
+
+private def SecondHurewicz.hurewiczPi2 {X : Type} [TopologicalSpace X] (x : X) :
+    π_ 2 X x →* Multiplicative (SingularMayerVietoris.SingularHomology X 2)
+    where
+  toFun a := Multiplicative.ofAdd (hurewiczFunction x a)
+  map_one' := congrArg Multiplicative.ofAdd (squareHomologyClass_const (x := x))
+  map_mul' a
+    b := by
+    refine Quotient.inductionOn₂ a b fun p q => ?_
+    refine
+      (congrArg (fun c : π_ 2 X x => Multiplicative.ofAdd (hurewiczFunction x c))
+            (HomotopyGroup.mul_spec (i := (0 : Fin 2)) (p := p) (q := q))).trans
+        ?_
+    change
+      Multiplicative.ofAdd (squareHomologyClass (GenLoop.transAt (0 : Fin 2) q p)) =
+        Multiplicative.ofAdd (squareHomologyClass p + squareHomologyClass q)
+    rw [squareHomologyClass_transAt, add_comm]
+
+private def SecondHurewicz.hurewiczMap {X : Type} [TopologicalSpace X] (x : X) :
+    Additive (π_ 2 X x) →ₗ[ℤ] SingularMayerVietoris.SingularHomology X 2
+    where
+  toFun := (hurewiczPi2 x).toAdditiveLeft
+  map_add' := (hurewiczPi2 x).toAdditiveLeft.map_add
+  map_smul' n a := by simpa using map_intCast_smul (hurewiczPi2 x).toAdditiveLeft ℤ ℤ n a
+
+private theorem SecondHurewicz.hurewiczMap_representative {X : Type} [TopologicalSpace X] (x : X)
+    (p : GenLoop (Fin 2) X x) :
+    hurewiczMap x (Additive.ofMul (⟦p⟧ : π_ 2 X x)) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 2
+        (squareCycle p) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SecondHurewicz.SimplyConnected.timeSlice {A X : Type} [TopologicalSpace A]
+    [TopologicalSpace X] (H : C((unitInterval) × A, X)) (t : (unitInterval)) : C(A, X) :=
+  H.comp (PeriodTorusHigherHomology.crossInsertLeft t)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    SecondHurewicz.SimplyConnected.crossPoint_left {A : Type} [TopologicalSpace A] (n : ℕ)
+    (t : (unitInterval)) (c : FirstHurewicz.Chains A n) :
+    PeriodTorusHigherHomology.crossProductZeroLeft (unitInterval) A n (FirstHurewicz.pointChain t)
+        c =
+      FirstHurewicz.inducedChain (PeriodTorusHigherHomology.crossInsertLeft t) n c := by
+  rw [FirstHurewicz.pointChain, PeriodTorusHigherHomology.crossProductZeroLeft_simplex_left]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    SecondHurewicz.SimplyConnected.inducedChain_timeSlice {A X : Type} [TopologicalSpace A]
+    [TopologicalSpace X] (H : C((unitInterval) × A, X)) (t : (unitInterval)) (n : ℕ)
+    (c : FirstHurewicz.Chains A n) :
+    FirstHurewicz.inducedChain H n
+        (FirstHurewicz.inducedChain (PeriodTorusHigherHomology.crossInsertLeft t) n c) =
+      FirstHurewicz.inducedChain (timeSlice H t) n c := by
+  change
+    ((FirstHurewicz.inducedChain H n).comp
+          (FirstHurewicz.inducedChain (PeriodTorusHigherHomology.crossInsertLeft t) n))
+        c =
+      _
+  rw [← FirstHurewicz.inducedChain_comp]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SecondHurewicz.SimplyConnected.prismOperator {A X : Type} [TopologicalSpace A]
+    [TopologicalSpace X] (n : ℕ) (H : C((unitInterval) × A, X)) :
+    FirstHurewicz.Chains A n →ₗ[ℤ] FirstHurewicz.Chains X (n + 1) :=
+  (FirstHurewicz.inducedChain H (n + 1)).comp
+    (PeriodTorusHigherHomology.crossProductEdge (unitInterval) A n SecondHurewicz.intervalChain)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.prismOperator_apply {A X : Type} [TopologicalSpace A]
+    [TopologicalSpace X] (n : ℕ) (H : C((unitInterval) × A, X)) (c : FirstHurewicz.Chains A n) :
+    prismOperator n H c =
+      FirstHurewicz.inducedChain H (n + 1)
+        (PeriodTorusHigherHomology.crossProductEdge (unitInterval) A n
+          SecondHurewicz.intervalChain c) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    SecondHurewicz.SimplyConnected.prismOperator_boundary {A X : Type} [TopologicalSpace A]
+    [TopologicalSpace X] (n : ℕ) (H : C((unitInterval) × A, X))
+    (c : FirstHurewicz.Chains A (n + 1)) :
+    ((FirstHurewicz.singularComplex X).d (n + 2) (n + 1)).hom (prismOperator (n + 1) H c) =
+      FirstHurewicz.inducedChain (timeSlice H 1) (n + 1) c -
+          FirstHurewicz.inducedChain (timeSlice H 0) (n + 1) c -
+        prismOperator n H (((FirstHurewicz.singularComplex A).d (n + 1) n).hom c) := by
+  rw [prismOperator_apply, ← FirstHurewicz.inducedChain_boundary,
+    PeriodTorusHigherHomology.crossProductEdge_boundary n]
+  change
+    FirstHurewicz.inducedChain H (n + 1)
+        (PeriodTorusHigherHomology.crossProductZeroLeft (unitInterval) A (n + 1)
+            (FirstHurewicz.boundaryOne (unitInterval) SecondHurewicz.intervalChain) c -
+          PeriodTorusHigherHomology.crossProductEdge (unitInterval) A n
+            SecondHurewicz.intervalChain
+            (((FirstHurewicz.singularComplex A).d (n + 1) n).hom c)) =
+      _
+  simp only [SecondHurewicz.intervalChain_boundary, map_sub, LinearMap.sub_apply, crossPoint_left,
+    inducedChain_timeSlice, prismOperator_apply]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    SecondHurewicz.SimplyConnected.prismOperator_domain {A B X : Type} [TopologicalSpace A]
+    [TopologicalSpace B] [TopologicalSpace X] (n : ℕ) (f : C(A, B)) (H : C((unitInterval) × B, X))
+    (c : FirstHurewicz.Chains A n) :
+    prismOperator n (H.comp ((ContinuousMap.id (unitInterval)).prodMap f)) c =
+      prismOperator n H (FirstHurewicz.inducedChain f n c) := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductEdge_natural (ContinuousMap.id (unitInterval)) f n
+      SecondHurewicz.intervalChain c
+  rw [FirstHurewicz.inducedChain_id, LinearMap.id_apply] at h
+  simp only [prismOperator_apply, FirstHurewicz.inducedChain_comp, LinearMap.comp_apply]
+  exact congrArg (FirstHurewicz.inducedChain H (n + 1)) h
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SecondHurewicz.SimplyConnected.simplexPrism {X : Type} [TopologicalSpace X] (n : ℕ)
+    (H : C((unitInterval) × FirstHurewicz.Simplex n, X)) : FirstHurewicz.Chains X (n + 1) :=
+  prismOperator n H
+    (FirstHurewicz.simplexChain (FirstHurewicz.Simplex n) n
+      (ContinuousMap.id (FirstHurewicz.Simplex n)))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    SecondHurewicz.SimplyConnected.prismOperator_simplex {A X : Type} [TopologicalSpace A]
+    [TopologicalSpace X] (n : ℕ) (H : C((unitInterval) × A, X))
+    (smp : FirstHurewicz.SingularSimplex A n) :
+    prismOperator n H (FirstHurewicz.simplexChain A n smp) =
+      simplexPrism n (H.comp ((ContinuousMap.id (unitInterval)).prodMap smp)) := by
+  have h :=
+    prismOperator_domain n smp H
+      (FirstHurewicz.simplexChain (FirstHurewicz.Simplex n) n
+        (ContinuousMap.id (FirstHurewicz.Simplex n)))
+  rw [FirstHurewicz.inducedChain_simplex, ContinuousMap.comp_id] at h
+  exact h.symm
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SecondHurewicz.SimplyConnected.simplexPrism_boundary {X : Type} [TopologicalSpace X]
+    (n : ℕ) (H : C((unitInterval) × FirstHurewicz.Simplex (n + 1), X)) :
+    ((FirstHurewicz.singularComplex X).d (n + 2) (n + 1)).hom (simplexPrism (n + 1) H) =
+      FirstHurewicz.simplexChain X (n + 1) (timeSlice H 1) -
+          FirstHurewicz.simplexChain X (n + 1) (timeSlice H 0) -
+        ∑ i : Fin (n + 2),
+          (-1 : ℤ) ^ i.val •
+            simplexPrism n
+              (H.comp
+                ((ContinuousMap.id (unitInterval)).prodMap (FirstHurewicz.simplexFace n i))) := by
+  rw [simplexPrism, prismOperator_boundary, FirstHurewicz.inducedChain_simplex,
+    FirstHurewicz.inducedChain_simplex, ContinuousMap.comp_id, ContinuousMap.comp_id]
+  rw [FirstHurewicz.boundary_simplex, map_sum]
+  simp only [map_zsmul, ContinuousMap.id_comp, prismOperator_simplex]
+
+private def
+    SecondHurewicz.SimplyConnected.simplexEndpointOperator {X : Type} [TopologicalSpace X] (n : ℕ)
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (t : (unitInterval)) : FirstHurewicz.Chains X n →ₗ[ℤ] FirstHurewicz.Chains X n :=
+  FirstHurewicz.chainLift X n fun smp => FirstHurewicz.simplexChain X n (timeSlice (H smp) t)
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.simplexEndpointOperator_simplex {X : Type}
+    [TopologicalSpace X] (n : ℕ)
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (t : (unitInterval)) (smp : FirstHurewicz.SingularSimplex X n) :
+    simplexEndpointOperator n H t (FirstHurewicz.simplexChain X n smp) =
+      FirstHurewicz.simplexChain X n (timeSlice (H smp) t) :=
+  FirstHurewicz.chainLift_simplex X n _ smp
+
+private def
+    SecondHurewicz.SimplyConnected.simplexPrismOperator {X : Type} [TopologicalSpace X] (n : ℕ)
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X)) :
+    FirstHurewicz.Chains X n →ₗ[ℤ] FirstHurewicz.Chains X (n + 1) :=
+  FirstHurewicz.chainLift X n fun smp => simplexPrism n (H smp)
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.simplexPrismOperator_simplex {X : Type}
+    [TopologicalSpace X] (n : ℕ)
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (smp : FirstHurewicz.SingularSimplex X n) :
+    simplexPrismOperator n H (FirstHurewicz.simplexChain X n smp) = simplexPrism n (H smp) :=
+  FirstHurewicz.chainLift_simplex X n _ smp
+
+private def SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies {X : Type} [TopologicalSpace X]
+    (n : ℕ)
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X)) :
+    Prop :=
+  ∀ smp i,
+    (H' smp).comp ((ContinuousMap.id (unitInterval)).prodMap (FirstHurewicz.simplexFace n i)) =
+      H (smp.comp (FirstHurewicz.simplexFace n i))
+
+private theorem
+    SecondHurewicz.SimplyConnected.timeSlice_face {X : Type} [TopologicalSpace X] {n : ℕ}
+    {H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X)}
+    {H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X)}
+    (h : FaceCompatibleHomotopies n H H') (smp : FirstHurewicz.SingularSimplex X (n + 1))
+    (i : Fin (n + 2)) (t : (unitInterval)) :
+    (timeSlice (H' smp) t).comp (FirstHurewicz.simplexFace n i) =
+      timeSlice (H (smp.comp (FirstHurewicz.simplexFace n i))) t :=
+  congrArg (fun F => timeSlice F t) (h smp i)
+
+private theorem SecondHurewicz.SimplyConnected.simplexEndpointOperator_boundary {X : Type}
+    [TopologicalSpace X] (n : ℕ)
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (h : FaceCompatibleHomotopies n H H') (t : (unitInterval))
+    (c : FirstHurewicz.Chains X (n + 1)) :
+    ((FirstHurewicz.singularComplex X).d (n + 1) n).hom (simplexEndpointOperator (n + 1) H' t c) =
+      simplexEndpointOperator n H t (((FirstHurewicz.singularComplex X).d (n + 1) n).hom c) := by
+  have hc :
+    (((FirstHurewicz.singularComplex X).d (n + 1) n).hom).comp
+        (simplexEndpointOperator (n + 1) H' t) =
+      (simplexEndpointOperator n H t).comp ((FirstHurewicz.singularComplex X).d (n + 1) n).hom := by
+    apply FirstHurewicz.chainMap_ext X (n + 1)
+    intro smp
+    simp only [LinearMap.comp_apply, simplexEndpointOperator_simplex,
+      FirstHurewicz.boundary_simplex, map_sum, map_zsmul, timeSlice_face h]
+  exact LinearMap.congr_fun hc c
+
+private theorem SecondHurewicz.SimplyConnected.simplexPrismOperator_boundary {X : Type}
+    [TopologicalSpace X] (n : ℕ)
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (h : FaceCompatibleHomotopies n H H') (c : FirstHurewicz.Chains X (n + 1)) :
+    ((FirstHurewicz.singularComplex X).d (n + 2) (n + 1)).hom
+        (simplexPrismOperator (n + 1) H' c) =
+      simplexEndpointOperator (n + 1) H' 1 c - simplexEndpointOperator (n + 1) H' 0 c -
+        simplexPrismOperator n H (((FirstHurewicz.singularComplex X).d (n + 1) n).hom c) := by
+  have hc :
+    (((FirstHurewicz.singularComplex X).d (n + 2) (n + 1)).hom).comp
+        (simplexPrismOperator (n + 1) H') =
+      simplexEndpointOperator (n + 1) H' 1 - simplexEndpointOperator (n + 1) H' 0 -
+        (simplexPrismOperator n H).comp ((FirstHurewicz.singularComplex X).d (n + 1) n).hom := by
+    apply FirstHurewicz.chainMap_ext X (n + 1)
+    intro smp
+    have hface := h smp
+    simp only [LinearMap.comp_apply, LinearMap.sub_apply, simplexPrismOperator_simplex,
+      simplexPrism_boundary, simplexEndpointOperator_simplex, FirstHurewicz.boundary_simplex,
+      map_sum, map_zsmul, hface]
+  exact LinearMap.congr_fun hc c
+
+private theorem SecondHurewicz.SimplyConnected.simplexEndpointOperator_zero {X : Type}
+    [TopologicalSpace X] (n : ℕ)
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (h₀ : ∀ smp, timeSlice (H smp) 0 = smp) : simplexEndpointOperator n H 0 = LinearMap.id := by
+  apply FirstHurewicz.chainMap_ext X n
+  intro smp
+  rw [simplexEndpointOperator_simplex, h₀]
+  rfl
+
+private def SecondHurewicz.SimplyConnected.straightenedTwoCycle {X : Type} [TopologicalSpace X]
+    (H₁ : FirstHurewicz.SingularSimplex X 1 → C((unitInterval) × FirstHurewicz.Simplex 1, X))
+    (H₂ : FirstHurewicz.SingularSimplex X 2 → C((unitInterval) × FirstHurewicz.Simplex 2, X))
+    (h : FaceCompatibleHomotopies 1 H₁ H₂)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2 :=
+  SingularMayerVietoris.ModuleHomology.mkCycle (FirstHurewicz.singularComplex X) 2
+    (simplexEndpointOperator 2 H₂ 1 c.1)
+    (by
+      rw [simplexEndpointOperator_boundary 1 H₁ H₂ h,
+        SingularMayerVietoris.ModuleHomology.cycle_condition (FirstHurewicz.singularComplex X) 2
+          c,
+        map_zero])
+
+private theorem
+    SecondHurewicz.SimplyConnected.straightenedTwoCycle_class {X : Type} [TopologicalSpace X]
+    (H₁ : FirstHurewicz.SingularSimplex X 1 → C((unitInterval) × FirstHurewicz.Simplex 1, X))
+    (H₂ : FirstHurewicz.SingularSimplex X 2 → C((unitInterval) × FirstHurewicz.Simplex 2, X))
+    (h : FaceCompatibleHomotopies 1 H₁ H₂) (h₀ : ∀ smp, timeSlice (H₂ smp) 0 = smp)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2) :
+    SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 2
+        (straightenedTwoCycle H₁ H₂ h c) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 2 c := by
+  apply
+    (SingularMayerVietoris.ModuleHomology.cycleClass_eq_iff (FirstHurewicz.singularComplex X) 2 _
+        _).mpr
+  refine ⟨simplexPrismOperator 2 H₂ c.1, ?_⟩
+  rw [simplexPrismOperator_boundary 1 H₁ H₂ h, simplexEndpointOperator_zero 2 H₂ h₀,
+    SingularMayerVietoris.ModuleHomology.cycle_condition (FirstHurewicz.singularComplex X) 2 c,
+    map_zero, sub_zero]
+  rfl
+
+private structure SecondHurewicz.SimplyConnected.VertexHomotopyData {X : Type} [TopologicalSpace X]
+    (x : X) (n : ℕ) where
+  homotopy : C(FirstHurewicz.Simplex n, X) → C((unitInterval) × FirstHurewicz.Simplex n, X)
+  zero :
+    ∀ (smp : C(FirstHurewicz.Simplex n, X)) (s : FirstHurewicz.Simplex n),
+      homotopy smp (0, s) = smp s
+  one_verticesBased : ∀ smp, VerticesBased x n (timeSlice (homotopy smp) 1)
+  of_verticesBased :
+    ∀ smp,
+      VerticesBased x n smp →
+        homotopy smp =
+          smp.comp
+            (ContinuousMap.snd :
+              C((unitInterval) × FirstHurewicz.Simplex n, FirstHurewicz.Simplex n))
+  face_compatible :
+    ∀ smp : C(FirstHurewicz.Simplex (n + 1), X),
+      FaceCompatible (fun i => homotopy (smp.comp (FirstHurewicz.simplexFace n i)))
+
+private def
+    SecondHurewicz.SimplyConnected.vertexBoundaryHomotopy {X : Type} [TopologicalSpace X] {x : X}
+    {n : ℕ} (D : VertexHomotopyData x n) (smp : C(FirstHurewicz.Simplex (n + 1), X)) :
+    C((unitInterval) × SimplexBoundary (n + 1), X) :=
+  glueFaceHomotopies (fun i => D.homotopy (smp.comp (FirstHurewicz.simplexFace n i)))
+    (D.face_compatible smp)
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.vertexBoundaryHomotopy_face {X : Type} [TopologicalSpace X]
+    {x : X} {n : ℕ} (D : VertexHomotopyData x n) (smp : C(FirstHurewicz.Simplex (n + 1), X))
+    (i : Fin (n + 2)) (r : (unitInterval)) (s : FirstHurewicz.Simplex n) :
+    vertexBoundaryHomotopy D smp (r, simplexFaceBoundary n i s) =
+      D.homotopy (smp.comp (FirstHurewicz.simplexFace n i)) (r, s) :=
+  glueFaceHomotopies_face _ _ i r s
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.vertexBoundaryHomotopy_zero {X : Type} [TopologicalSpace X]
+    {x : X} {n : ℕ} (D : VertexHomotopyData x n) (smp : C(FirstHurewicz.Simplex (n + 1), X))
+    (s : SimplexBoundary (n + 1)) : vertexBoundaryHomotopy D smp (0, s) = smp s.val :=
+  glueFaceHomotopies_zero _ _ smp (fun i t => D.zero (smp.comp (FirstHurewicz.simplexFace n i)) t)
+    s
+
+private def
+    SecondHurewicz.SimplyConnected.vertexStepHomotopy {X : Type} [TopologicalSpace X] {x : X}
+    {n : ℕ} (D : VertexHomotopyData x n) (smp : C(FirstHurewicz.Simplex (n + 1), X)) :
+    C((unitInterval) × FirstHurewicz.Simplex (n + 1), X) := by
+  classical
+    exact
+    if VerticesBased x (n + 1) smp then
+      smp.comp
+        (ContinuousMap.snd :
+          C((unitInterval) × FirstHurewicz.Simplex (n + 1), FirstHurewicz.Simplex (n + 1)))
+    else
+      extendBoundaryHomotopy smp (vertexBoundaryHomotopy D smp)
+        (vertexBoundaryHomotopy_zero D smp)
+
+private theorem SecondHurewicz.SimplyConnected.vertexStepHomotopy_of_verticesBased {X : Type}
+    [TopologicalSpace X] {x : X} {n : ℕ} (D : VertexHomotopyData x n)
+    (smp : C(FirstHurewicz.Simplex (n + 1), X)) (h : VerticesBased x (n + 1) smp) :
+    vertexStepHomotopy D smp =
+      smp.comp
+        (ContinuousMap.snd :
+          C((unitInterval) × FirstHurewicz.Simplex (n + 1), FirstHurewicz.Simplex (n + 1))) := by
+  classical simp only [vertexStepHomotopy, ite_eq_left h]
+
+private theorem SecondHurewicz.SimplyConnected.vertexStepHomotopy_of_not_verticesBased {X : Type}
+    [TopologicalSpace X] {x : X} {n : ℕ} (D : VertexHomotopyData x n)
+    (smp : C(FirstHurewicz.Simplex (n + 1), X)) (h : ¬VerticesBased x (n + 1) smp) :
+    vertexStepHomotopy D smp =
+      extendBoundaryHomotopy smp (vertexBoundaryHomotopy D smp)
+        (vertexBoundaryHomotopy_zero D smp) := by
+  classical simp only [vertexStepHomotopy, ite_eq_right h]
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.vertexStepHomotopy_zero {X : Type} [TopologicalSpace X]
+    {x : X} {n : ℕ} (D : VertexHomotopyData x n) (smp : C(FirstHurewicz.Simplex (n + 1), X))
+    (s : FirstHurewicz.Simplex (n + 1)) : vertexStepHomotopy D smp (0, s) = smp s := by
+  classical
+  by_cases h : VerticesBased x (n + 1) smp
+  · rw [vertexStepHomotopy_of_verticesBased D smp h]
+    rfl
+  · rw [vertexStepHomotopy_of_not_verticesBased D smp h]
+    exact extendBoundaryHomotopy_bottom _ _ _ s
+
+private theorem SecondHurewicz.SimplyConnected.vertexStepHomotopy_face_apply {X : Type}
+    [TopologicalSpace X] {x : X} {n : ℕ} (D : VertexHomotopyData x n)
+    (smp : C(FirstHurewicz.Simplex (n + 1), X)) (i : Fin (n + 2)) (r : (unitInterval))
+    (s : FirstHurewicz.Simplex n) :
+    vertexStepHomotopy D smp (r, FirstHurewicz.simplexFace n i s) =
+      D.homotopy (smp.comp (FirstHurewicz.simplexFace n i)) (r, s) := by
+  classical
+  by_cases h : VerticesBased x (n + 1) smp
+  · rw [vertexStepHomotopy_of_verticesBased D smp h, D.of_verticesBased _ (h.face i)]
+    rfl
+  · rw [vertexStepHomotopy_of_not_verticesBased D smp h, extendBoundaryHomotopy_face]
+    exact vertexBoundaryHomotopy_face D smp i r s
+
+private theorem
+    SecondHurewicz.SimplyConnected.vertexStepHomotopy_face {X : Type} [TopologicalSpace X]
+    {x : X} {n : ℕ} (D : VertexHomotopyData x n) :
+    FaceCompatibleHomotopies n D.homotopy (vertexStepHomotopy D) := by
+  intro smp i
+  ext u
+  exact vertexStepHomotopy_face_apply D smp i u.1 u.2
+
+private theorem SecondHurewicz.SimplyConnected.vertexStepHomotopy_one_verticesBased {X : Type}
+    [TopologicalSpace X] {x : X} {n : ℕ} (D : VertexHomotopyData x n)
+    (smp : C(FirstHurewicz.Simplex (n + 1), X)) :
+    VerticesBased x (n + 1) (timeSlice (vertexStepHomotopy D smp) 1) := by
+  intro k
+  obtain ⟨i, j, hij⟩ := simplexVertex_exists_face n k
+  change vertexStepHomotopy D smp (1, stdSimplex.vertex k) = x
+  rw [← hij, vertexStepHomotopy_face_apply]
+  exact D.one_verticesBased (smp.comp (FirstHurewicz.simplexFace n i)) j
+
+private theorem SecondHurewicz.SimplyConnected.vertexStepHomotopy_faceCompatible {X : Type}
+    [TopologicalSpace X] {x : X} {n : ℕ} (D : VertexHomotopyData x n)
+    (smp : C(FirstHurewicz.Simplex (n + 2), X)) :
+    FaceCompatible
+      (fun i => vertexStepHomotopy D (smp.comp (FirstHurewicz.simplexFace (n + 1) i))) := by
+  apply faceCompatible_of_cofaceCompatible
+  intro i j hij r u
+  rw [vertexStepHomotopy_face_apply, vertexStepHomotopy_face_apply,
+    PeriodTorusLineBundle.ChernCocycle.singularSimplex_face_face smp hij]
+
+private def
+    SecondHurewicz.SimplyConnected.VertexHomotopyData.next {X : Type} [TopologicalSpace X] {x : X}
+    {n : ℕ} (D : SecondHurewicz.SimplyConnected.VertexHomotopyData x n) :
+    SecondHurewicz.SimplyConnected.VertexHomotopyData x (n + 1)
+    where
+  homotopy := SecondHurewicz.SimplyConnected.vertexStepHomotopy D
+  zero := SecondHurewicz.SimplyConnected.vertexStepHomotopy_zero D
+  one_verticesBased := SecondHurewicz.SimplyConnected.vertexStepHomotopy_one_verticesBased D
+  of_verticesBased := SecondHurewicz.SimplyConnected.vertexStepHomotopy_of_verticesBased D
+  face_compatible := SecondHurewicz.SimplyConnected.vertexStepHomotopy_faceCompatible D
+
+private def SecondHurewicz.SimplyConnected.basedEdgePath {X : Type} [TopologicalSpace X] (x : X)
+    (smp : C(FirstHurewicz.Simplex 1, X)) (h₀ : smp (stdSimplex.vertex (S := ℝ) (0 : Fin 2)) = x)
+    (h₁ : smp (stdSimplex.vertex (S := ℝ) (1 : Fin 2)) = x) : Path x x :=
+  (FirstHurewicz.simplexPath smp).cast h₀.symm h₁.symm
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.basedEdgePath_const {X : Type} [TopologicalSpace X]
+    (x : X) :
+    basedEdgePath x (ContinuousMap.const (FirstHurewicz.Simplex 1) x) rfl rfl = Path.refl x := by
+  apply Path.ext
+  funext t
+  rfl
+
+private def SecondHurewicz.SimplyConnected.chosenBasePath {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x y : X) : Path y x := by
+  classical exact if h : y = x then (Path.refl x).cast h rfl else PathConnectedSpace.somePath y x
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.chosenBasePath_self {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) : chosenBasePath x x = Path.refl x := by
+  simp [chosenBasePath]
+
+private def SecondHurewicz.SimplyConnected.chosenNullHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (p : Path x x) : p.Homotopy (Path.refl x) := by
+  classical
+    exact
+    if h : p = Path.refl x then (Path.Homotopy.refl (Path.refl x)).cast h.symm rfl
+    else Classical.choice (SimplyConnectedSpace.paths_homotopic p (Path.refl x))
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.chosenNullHomotopy_refl {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) :
+    chosenNullHomotopy x (Path.refl x) = Path.Homotopy.refl (Path.refl x) := by
+  simp [chosenNullHomotopy]
+  rfl
+
+private def SecondHurewicz.SimplyConnected.vertexHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (smp : C(FirstHurewicz.Simplex 0, X)) :
+    C((unitInterval) × FirstHurewicz.Simplex 0, X) :=
+  (chosenBasePath x (smp (stdSimplex.vertex (S := ℝ) (0 : Fin 1)))).toContinuousMap.comp
+    (ContinuousMap.fst : C((unitInterval) × FirstHurewicz.Simplex 0, (unitInterval)))
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.vertexHomotopy_zero {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (smp : C(FirstHurewicz.Simplex 0, X))
+    (s : FirstHurewicz.Simplex 0) : vertexHomotopy x smp (0, s) = smp s := by
+  change chosenBasePath x (smp (stdSimplex.vertex (S := ℝ) (0 : Fin 1))) 0 = smp s
+  rw [Path.source, FirstHurewicz.simplexZero_eq_vertex s]
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.vertexHomotopy_one {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (smp : C(FirstHurewicz.Simplex 0, X))
+    (s : FirstHurewicz.Simplex 0) : vertexHomotopy x smp (1, s) = x :=
+  (chosenBasePath x (smp (stdSimplex.vertex (S := ℝ) (0 : Fin 1)))).target
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.vertexHomotopy_const {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) :
+    vertexHomotopy x (ContinuousMap.const (FirstHurewicz.Simplex 0) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 0) x := by
+  ext t
+  change chosenBasePath x x t.1 = x
+  rw [chosenBasePath_self]
+  rfl
+
+private def SecondHurewicz.SimplyConnected.edgeNullHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (smp : C(FirstHurewicz.Simplex 1, X))
+    (h₀ : smp (stdSimplex.vertex (S := ℝ) (0 : Fin 2)) = x)
+    (h₁ : smp (stdSimplex.vertex (S := ℝ) (1 : Fin 2)) = x) :
+    C((unitInterval) × FirstHurewicz.Simplex 1, X) :=
+  (chosenNullHomotopy x (basedEdgePath x smp h₀ h₁)).toContinuousMap.comp
+    ((ContinuousMap.id (unitInterval)).prodMap
+      ⟨stdSimplexHomeomorphUnitInterval, stdSimplexHomeomorphUnitInterval.continuous⟩)
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.edgeNullHomotopy_zero {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (smp : C(FirstHurewicz.Simplex 1, X)) (h₀ h₁)
+    (s : FirstHurewicz.Simplex 1) : edgeNullHomotopy x smp h₀ h₁ (0, s) = smp s := by
+  change
+    chosenNullHomotopy x (basedEdgePath x smp h₀ h₁) (0, stdSimplexHomeomorphUnitInterval s) =
+      smp s
+  rw [ContinuousMap.HomotopyWith.apply_zero]
+  change smp (stdSimplexHomeomorphUnitInterval.symm (stdSimplexHomeomorphUnitInterval s)) = smp s
+  rw [stdSimplexHomeomorphUnitInterval.symm_apply_apply]
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.edgeNullHomotopy_one {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (smp : C(FirstHurewicz.Simplex 1, X)) (h₀ h₁)
+    (s : FirstHurewicz.Simplex 1) : edgeNullHomotopy x smp h₀ h₁ (1, s) = x := by
+  change
+    chosenNullHomotopy x (basedEdgePath x smp h₀ h₁) (1, stdSimplexHomeomorphUnitInterval s) = x
+  rw [ContinuousMap.HomotopyWith.apply_one]
+  rfl
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.edgeNullHomotopy_vertex_zero {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) (smp : C(FirstHurewicz.Simplex 1, X))
+    (h₀ h₁) (t : (unitInterval)) :
+    edgeNullHomotopy x smp h₀ h₁ (t, stdSimplex.vertex (S := ℝ) (0 : Fin 2)) = x := by
+  change
+    chosenNullHomotopy x (basedEdgePath x smp h₀ h₁) (t, stdSimplexHomeomorphUnitInterval _) = x
+  rw [stdSimplexHomeomorphUnitInterval_zero]
+  exact Path.Homotopy.source _ t
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.edgeNullHomotopy_vertex_one {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (smp : C(FirstHurewicz.Simplex 1, X)) (h₀ h₁)
+    (t : (unitInterval)) :
+    edgeNullHomotopy x smp h₀ h₁ (t, stdSimplex.vertex (S := ℝ) (1 : Fin 2)) = x := by
+  change
+    chosenNullHomotopy x (basedEdgePath x smp h₀ h₁) (t, stdSimplexHomeomorphUnitInterval _) = x
+  rw [stdSimplexHomeomorphUnitInterval_one]
+  exact Path.Homotopy.target _ t
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.edgeNullHomotopy_const {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) :
+    edgeNullHomotopy x (ContinuousMap.const (FirstHurewicz.Simplex 1) x) rfl rfl =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 1) x := by
+  ext t
+  change
+    chosenNullHomotopy x
+        (basedEdgePath x (ContinuousMap.const (FirstHurewicz.Simplex 1) x) rfl rfl)
+        (t.1, stdSimplexHomeomorphUnitInterval t.2) =
+      x
+  rw [basedEdgePath_const, chosenNullHomotopy_refl]
+  rfl
+
+private def SecondHurewicz.SimplyConnected.vertexInitialData {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) : VertexHomotopyData x 0
+    where
+  homotopy := vertexHomotopy x
+  zero := vertexHomotopy_zero x
+  one_verticesBased smp i := vertexHomotopy_one x smp (stdSimplex.vertex i)
+  of_verticesBased smp
+    h := by
+    have hs : smp = ContinuousMap.const (FirstHurewicz.Simplex 0) x := verticesBased_zero_iff.mp h
+    rw [hs, vertexHomotopy_const]
+    rfl
+  face_compatible
+    smp :=
+    faceCompatible_zero (fun i => vertexHomotopy x (smp.comp (FirstHurewicz.simplexFace 0 i)))
+
+private def SecondHurewicz.SimplyConnected.vertexStraighteningData {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) : (n : ℕ) → VertexHomotopyData x n
+  | 0 => vertexInitialData x
+  | n + 1 => (vertexStraighteningData x n).next
+
+private def
+    SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (n : ℕ) (smp : C(FirstHurewicz.Simplex n, X)) :
+    C((unitInterval) × FirstHurewicz.Simplex n, X) :=
+  (vertexStraighteningData x n).homotopy smp
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy_zero {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) (n : ℕ)
+    (smp : C(FirstHurewicz.Simplex n, X)) (s : FirstHurewicz.Simplex n) :
+    vertexStraighteningHomotopy x n smp (0, s) = smp s :=
+  (vertexStraighteningData x n).zero smp s
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy_timeSlice_zero {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) (n : ℕ)
+    (smp : C(FirstHurewicz.Simplex n, X)) :
+    timeSlice (vertexStraighteningHomotopy x n smp) 0 = smp := by
+  ext s
+  exact vertexStraighteningHomotopy_zero x n smp s
+
+private theorem SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy_face {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) (n : ℕ) :
+    FaceCompatibleHomotopies n (vertexStraighteningHomotopy x n)
+      (vertexStraighteningHomotopy x (n + 1)) :=
+  vertexStepHomotopy_face (vertexStraighteningData x n)
+
+private theorem SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy_timeSlice_face {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) (n : ℕ)
+    (smp : C(FirstHurewicz.Simplex (n + 1), X)) (i : Fin (n + 2)) (r : (unitInterval)) :
+    (timeSlice (vertexStraighteningHomotopy x (n + 1) smp) r).comp
+        (FirstHurewicz.simplexFace n i) =
+      timeSlice (vertexStraighteningHomotopy x n (smp.comp (FirstHurewicz.simplexFace n i))) r :=
+  timeSlice_face (vertexStraighteningHomotopy_face x n) smp i r
+
+private theorem
+    SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy_one_verticesBased {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) (n : ℕ)
+    (smp : C(FirstHurewicz.Simplex n, X)) :
+    VerticesBased x n (timeSlice (vertexStraighteningHomotopy x n smp) 1) :=
+  (vertexStraighteningData x n).one_verticesBased smp
+
+private theorem
+    SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy_of_verticesBased {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) (n : ℕ)
+    (smp : C(FirstHurewicz.Simplex n, X)) (h : VerticesBased x n smp) :
+    vertexStraighteningHomotopy x n smp =
+      smp.comp
+        (ContinuousMap.snd :
+          C((unitInterval) × FirstHurewicz.Simplex n, FirstHurewicz.Simplex n)) :=
+  (vertexStraighteningData x n).of_verticesBased smp h
+
+private theorem
+    SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy_timeSlice_of_verticesBased
+    {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) (n : ℕ)
+    (smp : C(FirstHurewicz.Simplex n, X)) (h : VerticesBased x n smp) (r : (unitInterval)) :
+    timeSlice (vertexStraighteningHomotopy x n smp) r = smp := by
+  rw [vertexStraighteningHomotopy_of_verticesBased x n smp h]
+  rfl
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy_const {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) (n : ℕ) :
+    vertexStraighteningHomotopy x n (ContinuousMap.const (FirstHurewicz.Simplex n) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex n) x := by
+  rw [vertexStraighteningHomotopy_of_verticesBased x n _ (verticesBased_const x n)]
+  rfl
+
+private def SecondHurewicz.SimplyConnected.stationarySimplexHomotopy {X : Type} [TopologicalSpace X]
+    (n : ℕ) (smp : C(FirstHurewicz.Simplex n, X)) :
+    C((unitInterval) × FirstHurewicz.Simplex n, X) :=
+  smp.comp
+    (ContinuousMap.snd : C((unitInterval) × FirstHurewicz.Simplex n, FirstHurewicz.Simplex n))
+
+private def SecondHurewicz.SimplyConnected.edgeStraighteningHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (smp : C(FirstHurewicz.Simplex 1, X)) :
+    C((unitInterval) × FirstHurewicz.Simplex 1, X) := by
+  classical
+    exact
+    if h :
+        smp (stdSimplex.vertex (S := ℝ) (0 : Fin 2)) = x ∧
+          smp (stdSimplex.vertex (S := ℝ) (1 : Fin 2)) = x then
+      edgeNullHomotopy x smp h.1 h.2
+    else stationarySimplexHomotopy 1 smp
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.edgeStraighteningHomotopy_zero {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) (smp : C(FirstHurewicz.Simplex 1, X))
+    (s : FirstHurewicz.Simplex 1) : edgeStraighteningHomotopy x smp (0, s) = smp s := by
+  classical
+  unfold edgeStraighteningHomotopy
+  split
+  · exact edgeNullHomotopy_zero x smp _ _ s
+  · rfl
+
+private theorem SecondHurewicz.SimplyConnected.edgeStraighteningHomotopy_one {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) (smp : C(FirstHurewicz.Simplex 1, X))
+    (h₀ : smp (stdSimplex.vertex (S := ℝ) (0 : Fin 2)) = x)
+    (h₁ : smp (stdSimplex.vertex (S := ℝ) (1 : Fin 2)) = x) (s : FirstHurewicz.Simplex 1) :
+    edgeStraighteningHomotopy x smp (1, s) = x := by
+  classical
+  have h :
+    smp (stdSimplex.vertex (S := ℝ) (0 : Fin 2)) = x ∧
+      smp (stdSimplex.vertex (S := ℝ) (1 : Fin 2)) = x :=
+    ⟨h₀, h₁⟩
+  rw [edgeStraighteningHomotopy, dite_eq_left h]
+  exact edgeNullHomotopy_one x smp _ _ s
+
+private theorem SecondHurewicz.SimplyConnected.edgeStraighteningHomotopy_vertex {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) (smp : C(FirstHurewicz.Simplex 1, X))
+    (i : Fin 2) (t : (unitInterval)) :
+    edgeStraighteningHomotopy x smp (t, stdSimplex.vertex (S := ℝ) i) =
+      smp (stdSimplex.vertex (S := ℝ) i) := by
+  classical
+  unfold edgeStraighteningHomotopy
+  split
+  · rename_i h
+    fin_cases i
+    · exact (edgeNullHomotopy_vertex_zero x smp h.1 h.2 t).trans h.1.symm
+    · exact (edgeNullHomotopy_vertex_one x smp h.1 h.2 t).trans h.2.symm
+  · rfl
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.edgeStraighteningHomotopy_const {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) :
+    edgeStraighteningHomotopy x (ContinuousMap.const (FirstHurewicz.Simplex 1) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 1) x := by
+  classical
+  simp only [edgeStraighteningHomotopy, ContinuousMap.const_apply]
+  exact edgeNullHomotopy_const x
+
+private theorem SecondHurewicz.SimplyConnected.edgeStraighteningHomotopy_face {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) :
+    FaceCompatibleHomotopies 0 (stationarySimplexHomotopy 0) (edgeStraighteningHomotopy x) := by
+  intro smp i
+  ext u
+  rcases u with ⟨t, s⟩
+  change
+    edgeStraighteningHomotopy x smp (t, FirstHurewicz.simplexFace 0 i s) =
+      smp (FirstHurewicz.simplexFace 0 i s)
+  rw [FirstHurewicz.simplexZero_eq_vertex s, FirstHurewicz.simplexFace_vertex]
+  exact edgeStraighteningHomotopy_vertex x smp _ t
+
+private theorem SecondHurewicz.SimplyConnected.nextFaceHomotopies_compatible {X : Type}
+    [TopologicalSpace X] {n : ℕ}
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (h : FaceCompatibleHomotopies n H H') (smp : FirstHurewicz.SingularSimplex X (n + 2)) :
+    FaceCompatible (fun i => H' (smp.comp (FirstHurewicz.simplexFace (n + 1) i))) := by
+  apply faceCompatible_of_cofaceCompatible
+  intro i j hij t s
+  have hi :=
+    congrArg (fun F : C((unitInterval) × FirstHurewicz.Simplex n, X) => F (t, s))
+      (h (smp.comp (FirstHurewicz.simplexFace (n + 1) j.succ)) i)
+  have hj :=
+    congrArg (fun F : C((unitInterval) × FirstHurewicz.Simplex n, X) => F (t, s))
+      (h (smp.comp (FirstHurewicz.simplexFace (n + 1) i.castSucc)) j)
+  change
+    H' (smp.comp (FirstHurewicz.simplexFace (n + 1) j.succ))
+        (t, FirstHurewicz.simplexFace n i s) =
+      H
+        ((smp.comp (FirstHurewicz.simplexFace (n + 1) j.succ)).comp
+          (FirstHurewicz.simplexFace n i))
+        (t, s) at hi
+  change
+    H' (smp.comp (FirstHurewicz.simplexFace (n + 1) i.castSucc))
+        (t, FirstHurewicz.simplexFace n j s) =
+      H
+        ((smp.comp (FirstHurewicz.simplexFace (n + 1) i.castSucc)).comp
+          (FirstHurewicz.simplexFace n j))
+        (t, s) at hj
+  rw [hi, hj]
+  change
+    H (smp.comp ((FirstHurewicz.simplexFace (n + 1) j.succ).comp (FirstHurewicz.simplexFace n i)))
+        (t, s) =
+      H
+        (smp.comp
+          ((FirstHurewicz.simplexFace (n + 1) i.castSucc).comp (FirstHurewicz.simplexFace n j)))
+        (t, s)
+  rw [PeriodTorusLineBundle.ChernCocycle.simplexFace_comp hij]
+
+private def
+    SecondHurewicz.SimplyConnected.coherentFaceBoundaryHomotopy {X : Type} [TopologicalSpace X]
+    {n : ℕ}
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (h : FaceCompatibleHomotopies n H H') (smp : FirstHurewicz.SingularSimplex X (n + 2)) :
+    C((unitInterval) × SimplexBoundary (n + 2), X) :=
+  glueFaceHomotopies (fun i => H' (smp.comp (FirstHurewicz.simplexFace (n + 1) i)))
+    (nextFaceHomotopies_compatible H H' h smp)
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.coherentFaceBoundaryHomotopy_face {X : Type}
+    [TopologicalSpace X] {n : ℕ}
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (h : FaceCompatibleHomotopies n H H') (smp : FirstHurewicz.SingularSimplex X (n + 2))
+    (i : Fin (n + 3)) (t : (unitInterval)) (s : FirstHurewicz.Simplex (n + 1)) :
+    coherentFaceBoundaryHomotopy H H' h smp (t, simplexFaceBoundary (n + 1) i s) =
+      H' (smp.comp (FirstHurewicz.simplexFace (n + 1) i)) (t, s) :=
+  glueFaceHomotopies_face _ _ i t s
+
+private theorem SecondHurewicz.SimplyConnected.coherentFaceBoundaryHomotopy_zero {X : Type}
+    [TopologicalSpace X] {n : ℕ}
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (h : FaceCompatibleHomotopies n H H') (h₀ : ∀ smp s, H' smp (0, s) = smp s)
+    (smp : FirstHurewicz.SingularSimplex X (n + 2)) (b : SimplexBoundary (n + 2)) :
+    coherentFaceBoundaryHomotopy H H' h smp (0, b) = smp b.val :=
+  glueFaceHomotopies_zero _ _ smp
+    (fun i s => h₀ (smp.comp (FirstHurewicz.simplexFace (n + 1) i)) s) b
+
+private def
+    SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy {X : Type} [TopologicalSpace X]
+    {n : ℕ}
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (h : FaceCompatibleHomotopies n H H') (h₀ : ∀ smp s, H' smp (0, s) = smp s)
+    (smp : FirstHurewicz.SingularSimplex X (n + 2)) :
+    C((unitInterval) × FirstHurewicz.Simplex (n + 2), X) :=
+  extendBoundaryHomotopy smp (coherentFaceBoundaryHomotopy H H' h smp)
+    (coherentFaceBoundaryHomotopy_zero H H' h h₀ smp)
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_zero {X : Type}
+    [TopologicalSpace X] {n : ℕ}
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (h : FaceCompatibleHomotopies n H H') (h₀ : ∀ smp s, H' smp (0, s) = smp s)
+    (smp : FirstHurewicz.SingularSimplex X (n + 2)) (s : FirstHurewicz.Simplex (n + 2)) :
+    extendCoherentSimplexHomotopy H H' h h₀ smp (0, s) = smp s :=
+  extendBoundaryHomotopy_bottom _ _ _ s
+
+private theorem SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_face {X : Type}
+    [TopologicalSpace X] {n : ℕ}
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (h : FaceCompatibleHomotopies n H H') (h₀ : ∀ smp s, H' smp (0, s) = smp s) :
+    FaceCompatibleHomotopies (n + 1) H' (extendCoherentSimplexHomotopy H H' h h₀) := by
+  intro smp i
+  ext u
+  rcases u with ⟨t, s⟩
+  change
+    extendBoundaryHomotopy smp (coherentFaceBoundaryHomotopy H H' h smp)
+        (coherentFaceBoundaryHomotopy_zero H H' h h₀ smp)
+        (t, FirstHurewicz.simplexFace (n + 1) i s) =
+      _
+  rw [extendBoundaryHomotopy_face]
+  exact coherentFaceBoundaryHomotopy_face H H' h smp i t s
+
+private def SecondHurewicz.SimplyConnected.triangleBoundary : Set (FirstHurewicz.Simplex 2) :=
+  {s | ∃ i, s i = 0}
+
+private def SecondHurewicz.SimplyConnected.BasedTriangle {X : Type} [TopologicalSpace X] (x : X) :=
+  { τ : C(FirstHurewicz.Simplex 2, X) // ∀ s ∈ triangleBoundary, τ s = x }
+
+private def SecondHurewicz.SimplyConnected.triangleQuotient :
+    C((unitInterval) × (unitInterval), FirstHurewicz.Simplex 2)
+    where
+  toFun
+    z :=
+    ⟨![1 - (z.1 : ℝ), (z.1 : ℝ) - Min.min (z.1 : ℝ) (z.2 : ℝ), Min.min (z.1 : ℝ) (z.2 : ℝ)],
+      by
+      constructor
+      · intro i
+        fin_cases i
+        · exact sub_nonneg.mpr z.1.property.2
+        · exact sub_nonneg.mpr (min_le_left _ _)
+        · exact le_min z.1.property.1 z.2.property.1
+      · simp only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero, Matrix.cons_val_zero,
+          Matrix.cons_val_succ, Matrix.cons_val_fin_one]
+        ring⟩
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    apply continuous_pi
+    intro i
+    fin_cases i <;> dsimp <;> fun_prop
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.triangleQuotient_zero
+    (z : (unitInterval) × (unitInterval)) : triangleQuotient z 0 = 1 - (z.1 : ℝ) :=
+  rfl
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.triangleQuotient_one
+    (z : (unitInterval) × (unitInterval)) :
+    triangleQuotient z 1 = (z.1 : ℝ) - Min.min (z.1 : ℝ) (z.2 : ℝ) :=
+  rfl
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.triangleQuotient_two
+    (z : (unitInterval) × (unitInterval)) : triangleQuotient z 2 = Min.min (z.1 : ℝ) (z.2 : ℝ) :=
+  rfl
+
+private def SecondHurewicz.SimplyConnected.triangleCubeQuotient :
+    C(Fin 2 → (unitInterval), FirstHurewicz.Simplex 2) :=
+  triangleQuotient.comp ⟨fun t => (t 0, t 1), by fun_prop⟩
+
+private theorem
+    SecondHurewicz.SimplyConnected.triangleCubeQuotient_boundary (t : Fin 2 → (unitInterval))
+    (ht : t ∈ Cube.boundary (Fin 2)) : triangleCubeQuotient t ∈ triangleBoundary := by
+  rcases ht with ⟨i, hi | hi⟩
+  · fin_cases i
+    · refine ⟨2, ?_⟩
+      change t 0 = 0 at hi
+      change Min.min (t 0 : ℝ) (t 1 : ℝ) = 0
+      simp [hi, min_eq_left (t 1).property.1]
+    · refine ⟨2, ?_⟩
+      change t 1 = 0 at hi
+      change Min.min (t 0 : ℝ) (t 1 : ℝ) = 0
+      simp [hi, min_eq_right (t 0).property.1]
+  · fin_cases i
+    · refine ⟨0, ?_⟩
+      change t 0 = 1 at hi
+      change 1 - (t 0 : ℝ) = 0
+      simp [hi]
+    · refine ⟨1, ?_⟩
+      change t 1 = 1 at hi
+      change (t 0 : ℝ) - Min.min (t 0 : ℝ) (t 1 : ℝ) = 0
+      simp [hi, min_eq_left (t 0).property.2]
+
+private def SecondHurewicz.SimplyConnected.basedTriangleLoop {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedTriangle x) : GenLoop (Fin 2) X x :=
+  ⟨τ.val.comp triangleCubeQuotient, fun t ht => τ.property _ (triangleCubeQuotient_boundary t ht)⟩
+
+private theorem
+    SecondHurewicz.SimplyConnected.squareMap_basedTriangleLoop {X : Type} [TopologicalSpace X]
+    {x : X} (τ : BasedTriangle x) :
+    SecondHurewicz.squareMap (basedTriangleLoop τ) = τ.val.comp triangleQuotient := by
+  ext z
+  change
+    τ.val
+        (triangleQuotient
+          (SecondHurewicz.squareCoordinates z 0, SecondHurewicz.squareCoordinates z 1)) =
+      _
+  rw [SecondHurewicz.squareCoordinates_zero, SecondHurewicz.squareCoordinates_one]
+  rfl
+
+private def
+    SecondHurewicz.SimplyConnected.basedTriangleClass {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedTriangle x) : Additive (π_ 2 X x) :=
+  Additive.ofMul (⟦basedTriangleLoop τ⟧ : π_ 2 X x)
+
+private def
+    SecondHurewicz.SimplyConnected.constantBasedTriangle {X : Type} [TopologicalSpace X] (x : X) :
+    BasedTriangle x :=
+  ⟨ContinuousMap.const (FirstHurewicz.Simplex 2) x, fun _ _ => rfl⟩
+
+private def SecondHurewicz.SimplyConnected.triangleEdgeStraighteningHomotopy {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X)
+    (smp : FirstHurewicz.SingularSimplex X 2) : C((unitInterval) × FirstHurewicz.Simplex 2, X) :=
+  extendCoherentSimplexHomotopy (stationarySimplexHomotopy 0) (edgeStraighteningHomotopy x)
+    (edgeStraighteningHomotopy_face x) (edgeStraighteningHomotopy_zero x) smp
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.triangleEdgeStraighteningHomotopy_zero {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X)
+    (smp : FirstHurewicz.SingularSimplex X 2) (s : FirstHurewicz.Simplex 2) :
+    triangleEdgeStraighteningHomotopy x smp (0, s) = smp s :=
+  extendCoherentSimplexHomotopy_zero _ _ _ _ smp s
+
+private theorem SecondHurewicz.SimplyConnected.triangleEdgeStraighteningHomotopy_face {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) :
+    FaceCompatibleHomotopies 1 (edgeStraighteningHomotopy x)
+      (triangleEdgeStraighteningHomotopy x) :=
+  extendCoherentSimplexHomotopy_face (stationarySimplexHomotopy 0) (edgeStraighteningHomotopy x)
+    (edgeStraighteningHomotopy_face x) (edgeStraighteningHomotopy_zero x)
+
+private def SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X)
+    (smp : FirstHurewicz.SingularSimplex X 3) : C((unitInterval) × FirstHurewicz.Simplex 3, X) :=
+  extendCoherentSimplexHomotopy (edgeStraighteningHomotopy x)
+    (triangleEdgeStraighteningHomotopy x) (triangleEdgeStraighteningHomotopy_face x)
+    (triangleEdgeStraighteningHomotopy_zero x) smp
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy_zero {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X)
+    (smp : FirstHurewicz.SingularSimplex X 3) (s : FirstHurewicz.Simplex 3) :
+    tetrahedronEdgeStraighteningHomotopy x smp (0, s) = smp s :=
+  extendCoherentSimplexHomotopy_zero _ _ _ _ smp s
+
+private theorem SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy_face {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) :
+    FaceCompatibleHomotopies 2 (triangleEdgeStraighteningHomotopy x)
+      (tetrahedronEdgeStraighteningHomotopy x) :=
+  extendCoherentSimplexHomotopy_face (edgeStraighteningHomotopy x)
+    (triangleEdgeStraighteningHomotopy x) (triangleEdgeStraighteningHomotopy_face x)
+    (triangleEdgeStraighteningHomotopy_zero x)
+
+private theorem SecondHurewicz.SimplyConnected.triangleEdgeStraighteningHomotopy_one_face {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X)
+    (smp : FirstHurewicz.SingularSimplex X 2) (h : VerticesBased x 2 smp) (i : Fin 3) :
+    (timeSlice (triangleEdgeStraighteningHomotopy x smp) 1).comp (FirstHurewicz.simplexFace 1 i) =
+      ContinuousMap.const (FirstHurewicz.Simplex 1) x := by
+  rw [timeSlice_face (triangleEdgeStraighteningHomotopy_face x)]
+  ext s
+  exact
+    edgeStraighteningHomotopy_one x (smp.comp (FirstHurewicz.simplexFace 1 i)) (h.face i 0)
+      (h.face i 1) s
+
+private theorem
+    SecondHurewicz.SimplyConnected.triangleEdgeStraighteningHomotopy_one_boundary {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X)
+    (smp : FirstHurewicz.SingularSimplex X 2) (h : VerticesBased x 2 smp)
+    (s : FirstHurewicz.Simplex 2) (hs : s ∈ triangleBoundary) :
+    timeSlice (triangleEdgeStraighteningHomotopy x smp) 1 s = x := by
+  obtain ⟨i, t, ht⟩ := simplexBoundary_exists_face 1 (⟨s, hs⟩ : SimplexBoundary 2)
+  have he : FirstHurewicz.simplexFace 1 i t = s := congrArg Subtype.val ht
+  rw [← he]
+  exact
+    congrArg (fun f : C(FirstHurewicz.Simplex 1, X) => f t)
+      (triangleEdgeStraighteningHomotopy_one_face x smp h i)
+
+private def SecondHurewicz.SimplyConnected.edgeStraightenedTriangle {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (smp : FirstHurewicz.SingularSimplex X 2)
+    (h : VerticesBased x 2 smp) : BasedTriangle x :=
+  ⟨timeSlice (triangleEdgeStraighteningHomotopy x smp) 1,
+    triangleEdgeStraighteningHomotopy_one_boundary x smp h⟩
+
+private def SecondHurewicz.SimplyConnected.vertexNormalizedSimplex {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (n : ℕ) (smp : FirstHurewicz.SingularSimplex X n) :
+    FirstHurewicz.SingularSimplex X n :=
+  timeSlice (vertexStraighteningHomotopy x n smp) 1
+
+private theorem SecondHurewicz.SimplyConnected.vertexNormalizedSimplex_verticesBased {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) (n : ℕ)
+    (smp : FirstHurewicz.SingularSimplex X n) :
+    VerticesBased x n (vertexNormalizedSimplex x n smp) :=
+  vertexStraighteningHomotopy_one_verticesBased x n smp
+
+private theorem SecondHurewicz.SimplyConnected.vertexNormalizedSimplex_face {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) (n : ℕ)
+    (smp : FirstHurewicz.SingularSimplex X (n + 1)) (i : Fin (n + 2)) :
+    (vertexNormalizedSimplex x (n + 1) smp).comp (FirstHurewicz.simplexFace n i) =
+      vertexNormalizedSimplex x n (smp.comp (FirstHurewicz.simplexFace n i)) :=
+  vertexStraighteningHomotopy_timeSlice_face x n smp i 1
+
+private theorem SecondHurewicz.SimplyConnected.vertexNormalizedSimplex_of_verticesBased {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) (n : ℕ)
+    (smp : FirstHurewicz.SingularSimplex X n) (h : VerticesBased x n smp) :
+    vertexNormalizedSimplex x n smp = smp :=
+  vertexStraighteningHomotopy_timeSlice_of_verticesBased x n smp h 1
+
+private def SecondHurewicz.SimplyConnected.normalizedTriangle {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (smp : FirstHurewicz.SingularSimplex X 2) :
+    BasedTriangle x :=
+  edgeStraightenedTriangle x (vertexNormalizedSimplex x 2 smp)
+    (vertexNormalizedSimplex_verticesBased x 2 smp)
+
+private theorem SecondHurewicz.SimplyConnected.normalizedTriangle_of_verticesBased {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X)
+    (smp : FirstHurewicz.SingularSimplex X 2) (h : VerticesBased x 2 smp) :
+    normalizedTriangle x smp = edgeStraightenedTriangle x smp h := by
+  apply Subtype.ext
+  change
+    timeSlice (triangleEdgeStraighteningHomotopy x (vertexNormalizedSimplex x 2 smp)) 1 =
+      timeSlice (triangleEdgeStraighteningHomotopy x smp) 1
+  rw [vertexNormalizedSimplex_of_verticesBased x 2 smp h]
+
+private def SecondHurewicz.SimplyConnected.normalizedTetrahedronMap {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (smp : FirstHurewicz.SingularSimplex X 3) :
+    FirstHurewicz.SingularSimplex X 3 :=
+  timeSlice (tetrahedronEdgeStraighteningHomotopy x (vertexNormalizedSimplex x 3 smp)) 1
+
+private theorem SecondHurewicz.SimplyConnected.normalizedTetrahedronMap_face {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X)
+    (smp : FirstHurewicz.SingularSimplex X 3) (i : Fin 4) :
+    (normalizedTetrahedronMap x smp).comp (FirstHurewicz.simplexFace 2 i) =
+      (normalizedTriangle x (smp.comp (FirstHurewicz.simplexFace 2 i))).val := by
+  change
+    (timeSlice (tetrahedronEdgeStraighteningHomotopy x (vertexNormalizedSimplex x 3 smp)) 1).comp
+        (FirstHurewicz.simplexFace 2 i) =
+      _
+  rw [timeSlice_face (tetrahedronEdgeStraighteningHomotopy_face x), vertexNormalizedSimplex_face]
+  rfl
+
+private theorem SecondHurewicz.SimplyConnected.normalizedTetrahedronMap_face_boundary {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X)
+    (smp : FirstHurewicz.SingularSimplex X 3) (i : Fin 4) (s : FirstHurewicz.Simplex 2)
+    (hs : s ∈ triangleBoundary) :
+    normalizedTetrahedronMap x smp (FirstHurewicz.simplexFace 2 i s) = x := by
+  have hf :=
+    congrArg (fun f : C(FirstHurewicz.Simplex 2, X) => f s)
+      (normalizedTetrahedronMap_face x smp i)
+  exact hf.trans ((normalizedTriangle x (smp.comp (FirstHurewicz.simplexFace 2 i))).property s hs)
+
+private def SecondHurewicz.SimplyConnected.normalizedTwoChain {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) : FirstHurewicz.Chains X 2 →ₗ[ℤ] FirstHurewicz.Chains X 2 :=
+  FirstHurewicz.chainLift X 2 fun smp =>
+    FirstHurewicz.simplexChain X 2 (normalizedTriangle x smp).val
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.normalizedTwoChain_simplex {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (smp : FirstHurewicz.SingularSimplex X 2) :
+    normalizedTwoChain x (FirstHurewicz.simplexChain X 2 smp) =
+      FirstHurewicz.simplexChain X 2 (normalizedTriangle x smp).val :=
+  FirstHurewicz.chainLift_simplex X 2 _ smp
+
+private theorem SecondHurewicz.SimplyConnected.normalizedTwoChain_eq {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) :
+    normalizedTwoChain x =
+      (simplexEndpointOperator 2 (triangleEdgeStraighteningHomotopy x) 1).comp
+        (simplexEndpointOperator 2 (vertexStraighteningHomotopy x 2) 1) := by
+  apply FirstHurewicz.chainMap_ext X 2
+  intro smp
+  simp only [normalizedTwoChain_simplex, LinearMap.comp_apply, simplexEndpointOperator_simplex]
+  rfl
+
+private def SecondHurewicz.SimplyConnected.vertexNormalizedTwoCycle {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2 :=
+  straightenedTwoCycle (vertexStraighteningHomotopy x 1) (vertexStraighteningHomotopy x 2)
+    (vertexStraighteningHomotopy_face x 1) c
+
+private theorem SecondHurewicz.SimplyConnected.vertexNormalizedTwoCycle_class {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2) :
+    SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 2
+        (vertexNormalizedTwoCycle x c) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 2 c :=
+  straightenedTwoCycle_class _ _ (vertexStraighteningHomotopy_face x 1)
+    (vertexStraighteningHomotopy_timeSlice_zero x 2) c
+
+private def SecondHurewicz.SimplyConnected.normalizedTwoCycle {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2 :=
+  straightenedTwoCycle (edgeStraighteningHomotopy x) (triangleEdgeStraighteningHomotopy x)
+    (triangleEdgeStraighteningHomotopy_face x) (vertexNormalizedTwoCycle x c)
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.normalizedTwoCycle_val {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2) :
+    (normalizedTwoCycle x c).val = normalizedTwoChain x c.val := by
+  rw [normalizedTwoChain_eq]
+  rfl
+
+private theorem
+    SecondHurewicz.SimplyConnected.normalizedTwoCycle_class {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2) :
+    SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 2
+        (normalizedTwoCycle x c) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 2 c := by
+  have h₀ : ∀ smp, timeSlice (triangleEdgeStraighteningHomotopy x smp) 0 = smp := by
+    intro smp
+    ext s
+    exact triangleEdgeStraighteningHomotopy_zero x smp s
+  exact
+    (straightenedTwoCycle_class _ _ (triangleEdgeStraighteningHomotopy_face x) h₀
+          (vertexNormalizedTwoCycle x c)).trans
+      (vertexNormalizedTwoCycle_class x c)
+
+private def SecondHurewicz.SimplyConnected.tetrahedronOneSkeleton : Set (FirstHurewicz.Simplex 3) :=
+  {s | ∃ i j : Fin 4, i ≠ j ∧ s i = 0 ∧ s j = 0}
+
+private def
+    SecondHurewicz.SimplyConnected.BasedTetrahedron {X : Type} [TopologicalSpace X] (x : X) :=
+  { τ : C(FirstHurewicz.Simplex 3, X) // ∀ s ∈ tetrahedronOneSkeleton, τ s = x }
+
+private theorem SecondHurewicz.SimplyConnected.simplexFace_triangleBoundary (i : Fin 4)
+    (s : FirstHurewicz.Simplex 2) (hs : s ∈ triangleBoundary) :
+    FirstHurewicz.simplexFace 2 i s ∈ tetrahedronOneSkeleton := by
+  obtain ⟨j, hj⟩ := hs
+  exact
+    ⟨i, i.succAbove j, (Fin.succAbove_ne i j).symm, FirstHurewicz.simplexFace_apply_self 2 i s,
+      (FirstHurewicz.simplexFace_apply_succAbove 2 i s j).trans hj⟩
+
+private def
+    SecondHurewicz.SimplyConnected.basedTetrahedronFace {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedTetrahedron x) (i : Fin 4) : BasedTriangle x :=
+  ⟨τ.val.comp (FirstHurewicz.simplexFace 2 i), fun s hs =>
+    τ.property _ (simplexFace_triangleBoundary i s hs)⟩
+
+private def SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend {n : ℕ} (t : (unitInterval))
+    (a b : FirstHurewicz.Simplex n) : FirstHurewicz.Simplex n :=
+  ⟨(1 - (t : ℝ)) • (a : Fin (n + 1) → ℝ) + (t : ℝ) • (b : Fin (n + 1) → ℝ),
+    convex_stdSimplex ℝ _ a.property b.property (sub_nonneg.mpr t.property.2) t.property.1
+      (by ring)⟩
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend_zero {n : ℕ}
+    (a b : FirstHurewicz.Simplex n) : tetrahedronSimplexBlend 0 a b = a := by
+  apply Subtype.ext
+  funext i
+  change (1 - (0 : ℝ)) * a i + (0 : ℝ) * b i = a i
+  simp
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend_one {n : ℕ}
+    (a b : FirstHurewicz.Simplex n) : tetrahedronSimplexBlend 1 a b = b := by
+  apply Subtype.ext
+  funext i
+  change (1 - (1 : ℝ)) * a i + (1 : ℝ) * b i = b i
+  simp
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend_self {n : ℕ} (t : (unitInterval))
+    (a : FirstHurewicz.Simplex n) : tetrahedronSimplexBlend t a a = a := by
+  apply Subtype.ext
+  funext i
+  change (1 - (t : ℝ)) * a i + (t : ℝ) * a i = a i
+  ring
+
+private def SecondHurewicz.SimplyConnected.tetrahedronSimplexBlendMap {n : ℕ} {Y : Type}
+    [TopologicalSpace Y] (f g : C(Y, FirstHurewicz.Simplex n)) :
+    C((unitInterval) × Y, FirstHurewicz.Simplex n)
+    where
+  toFun p := tetrahedronSimplexBlend p.1 (f p.2) (g p.2)
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    apply continuous_pi
+    intro i
+    change
+      Continuous fun p : (unitInterval) × Y => (1 - (p.1 : ℝ)) * f p.2 i + (p.1 : ℝ) * g p.2 i
+    have hf : Continuous fun p : (unitInterval) × Y => f p.2 i :=
+      (continuous_apply i).comp (continuous_subtype_val.comp (f.continuous.comp continuous_snd))
+    have hg : Continuous fun p : (unitInterval) × Y => g p.2 i :=
+      (continuous_apply i).comp (continuous_subtype_val.comp (g.continuous.comp continuous_snd))
+    exact
+      ((continuous_const.sub (continuous_subtype_val.comp continuous_fst)).mul hf).add
+        ((continuous_subtype_val.comp continuous_fst).mul hg)
+
+private theorem SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend_zero_coordinate {n : ℕ}
+    (t : (unitInterval)) (a b : FirstHurewicz.Simplex n) (i : Fin (n + 1)) (ha : a i = 0)
+    (hb : b i = 0) : tetrahedronSimplexBlend t a b i = 0 := by
+  change (1 - (t : ℝ)) * a i + (t : ℝ) * b i = 0
+  simp [ha, hb]
+
+private theorem SecondHurewicz.SimplyConnected.simplexFace_two_zero (s : FirstHurewicz.Simplex 2) :
+    (FirstHurewicz.simplexFace 2 0 s : Fin 4 → ℝ) = ![0, s 0, s 1, s 2] := by
+  funext i
+  fin_cases i
+  · exact FirstHurewicz.simplexFace_apply_self 2 0 s
+  · exact FirstHurewicz.simplexFace_apply_succAbove 2 0 s 0
+  · exact FirstHurewicz.simplexFace_apply_succAbove 2 0 s 1
+  · exact FirstHurewicz.simplexFace_apply_succAbove 2 0 s 2
+
+private theorem SecondHurewicz.SimplyConnected.simplexFace_two_one (s : FirstHurewicz.Simplex 2) :
+    (FirstHurewicz.simplexFace 2 1 s : Fin 4 → ℝ) = ![s 0, 0, s 1, s 2] := by
+  funext i
+  fin_cases i
+  · exact FirstHurewicz.simplexFace_apply_succAbove 2 1 s 0
+  · exact FirstHurewicz.simplexFace_apply_self 2 1 s
+  · exact FirstHurewicz.simplexFace_apply_succAbove 2 1 s 1
+  · exact FirstHurewicz.simplexFace_apply_succAbove 2 1 s 2
+
+private theorem SecondHurewicz.SimplyConnected.simplexFace_two_two (s : FirstHurewicz.Simplex 2) :
+    (FirstHurewicz.simplexFace 2 2 s : Fin 4 → ℝ) = ![s 0, s 1, 0, s 2] := by
+  funext i
+  fin_cases i
+  · exact FirstHurewicz.simplexFace_apply_succAbove 2 2 s 0
+  · exact FirstHurewicz.simplexFace_apply_succAbove 2 2 s 1
+  · exact FirstHurewicz.simplexFace_apply_self 2 2 s
+  · exact FirstHurewicz.simplexFace_apply_succAbove 2 2 s 2
+
+private theorem SecondHurewicz.SimplyConnected.simplexFace_two_three (s : FirstHurewicz.Simplex 2) :
+    (FirstHurewicz.simplexFace 2 3 s : Fin 4 → ℝ) = ![s 0, s 1, s 2, 0] := by
+  funext i
+  fin_cases i
+  · exact FirstHurewicz.simplexFace_apply_succAbove 2 3 s 0
+  · exact FirstHurewicz.simplexFace_apply_succAbove 2 3 s 1
+  · exact FirstHurewicz.simplexFace_apply_succAbove 2 3 s 2
+  · exact FirstHurewicz.simplexFace_apply_self 2 3 s
+
+private def SecondHurewicz.SimplyConnected.BasedTetrahedron.ofFaces {X : Type} [TopologicalSpace X]
+    {x : X} (τ : C(FirstHurewicz.Simplex 3, X))
+    (h :
+      ∀ i : Fin 4,
+        ∀ s ∈ SecondHurewicz.SimplyConnected.triangleBoundary,
+          (τ.comp (FirstHurewicz.simplexFace 2 i)) s = x) :
+    SecondHurewicz.SimplyConnected.BasedTetrahedron x :=
+  ⟨τ, by
+    intro s hs
+    obtain ⟨i, j, hij, hi, hj⟩ := hs
+    obtain ⟨k, hk⟩ := Fin.exists_succAbove_eq hij.symm
+    let t := SecondHurewicz.SimplyConnected.simplexFaceInverse 2 i ⟨s, hi⟩
+    have ht : t ∈ SecondHurewicz.SimplyConnected.triangleBoundary := by
+      refine ⟨k, ?_⟩
+      change s (i.succAbove k) = 0
+      rw [hk]
+      exact hj
+    have he := h i t ht
+    change τ (FirstHurewicz.simplexFace 2 i t) = x at he
+    rw [show FirstHurewicz.simplexFace 2 i t = s from
+        SecondHurewicz.SimplyConnected.simplexFace_inverse 2 i ⟨s, hi⟩] at he
+    exact he⟩
+
+private def SecondHurewicz.SimplyConnected.tetrahedronQuadrilateralA :
+    C(Fin 2 → (unitInterval), FirstHurewicz.Simplex 3)
+    where
+  toFun
+    u :=
+    ⟨![1 - Max.max (u 0 : ℝ) (u 1 : ℝ), (u 0 : ℝ) - Min.min (u 0 : ℝ) (u 1 : ℝ),
+        Min.min (u 0 : ℝ) (u 1 : ℝ), (u 1 : ℝ) - Min.min (u 0 : ℝ) (u 1 : ℝ)],
+      by
+      constructor
+      · intro i
+        fin_cases i
+        · exact sub_nonneg.mpr (max_le (u 0).property.2 (u 1).property.2)
+        · exact sub_nonneg.mpr (min_le_left _ _)
+        · exact le_min (u 0).property.1 (u 1).property.1
+        · exact sub_nonneg.mpr (min_le_right _ _)
+      · simp only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero, Matrix.cons_val_zero,
+          Matrix.cons_val_succ, Matrix.cons_val_fin_one]
+        rcases le_total (u 0 : ℝ) (u 1 : ℝ) with h | h
+        · rw [min_eq_left h, max_eq_right h]
+          ring
+        · rw [min_eq_right h, max_eq_left h]
+          ring⟩
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    apply continuous_pi
+    intro i
+    fin_cases i <;> dsimp <;> fun_prop
+
+private theorem SecondHurewicz.SimplyConnected.tetrahedronQuadrilateralA_boundary
+    (u : Fin 2 → (unitInterval)) (hu : u ∈ Cube.boundary (Fin 2)) :
+    tetrahedronQuadrilateralA u ∈ tetrahedronOneSkeleton := by
+  rcases hu with ⟨i, hi | hi⟩
+  · fin_cases i
+    · change u 0 = 0 at hi
+      refine ⟨1, 2, by decide, ?_, ?_⟩ <;>
+        simp [DFunLike.coe, tetrahedronQuadrilateralA, hi, min_eq_left (u 1).property.1]
+    · change u 1 = 0 at hi
+      refine ⟨2, 3, by decide, ?_, ?_⟩ <;>
+        simp [DFunLike.coe, tetrahedronQuadrilateralA, hi, min_eq_right (u 0).property.1]
+  · fin_cases i
+    · change u 0 = 1 at hi
+      refine ⟨0, 3, by decide, ?_, ?_⟩ <;>
+        simp [DFunLike.coe, tetrahedronQuadrilateralA, hi, min_eq_right (u 1).property.2,
+          max_eq_left (u 1).property.2]
+    · change u 1 = 1 at hi
+      refine ⟨0, 1, by decide, ?_, ?_⟩ <;>
+        simp [DFunLike.coe, tetrahedronQuadrilateralA, hi, min_eq_left (u 0).property.2,
+          max_eq_right (u 0).property.2]
+
+private theorem
+    SecondHurewicz.SimplyConnected.tetrahedronQuadrilateralA_diagonal (t : (unitInterval)) :
+    tetrahedronQuadrilateralA ![t, t] ∈ tetrahedronOneSkeleton := by
+  refine ⟨1, 3, by decide, ?_, ?_⟩ <;> simp [DFunLike.coe, tetrahedronQuadrilateralA]
+
+private def SecondHurewicz.SimplyConnected.tetrahedronQuarterShift :
+    C(FirstHurewicz.Simplex 3, FirstHurewicz.Simplex 3)
+    where
+  toFun
+    s :=
+    ⟨![s 3, s 0, s 1, s 2], by
+      constructor
+      · intro i
+        fin_cases i <;> exact stdSimplex.zero_le s _
+      · have hs := stdSimplex.sum_eq_one s
+        simp only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero, Matrix.cons_val_zero,
+          Matrix.cons_val_succ, Matrix.cons_val_fin_one] at hs ⊢
+        change s 0 + (s 1 + (s 2 + s 3)) = 1 at hs
+        linarith⟩
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    apply continuous_pi
+    intro i
+    fin_cases i
+    · exact (continuous_apply 3).comp continuous_subtype_val
+    · exact (continuous_apply 0).comp continuous_subtype_val
+    · exact (continuous_apply 1).comp continuous_subtype_val
+    · exact (continuous_apply 2).comp continuous_subtype_val
+
+private def SecondHurewicz.SimplyConnected.tetrahedronQuarterIndex : Fin 4 ≃ Fin 4
+    where
+  toFun i := ![1, 2, 3, 0] i
+  invFun i := ![3, 0, 1, 2] i
+  left_inv i := by fin_cases i <;> rfl
+  right_inv i := by fin_cases i <;> rfl
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.tetrahedronQuarterShift_index (s : FirstHurewicz.Simplex 3)
+    (i : Fin 4) : tetrahedronQuarterShift s (tetrahedronQuarterIndex i) = s i := by
+  fin_cases i <;> rfl
+
+private theorem SecondHurewicz.SimplyConnected.tetrahedronQuarterShift_oneSkeleton
+    (s : FirstHurewicz.Simplex 3) (hs : s ∈ tetrahedronOneSkeleton) :
+    tetrahedronQuarterShift s ∈ tetrahedronOneSkeleton := by
+  obtain ⟨i, j, hij, hi, hj⟩ := hs
+  exact
+    ⟨tetrahedronQuarterIndex i, tetrahedronQuarterIndex j, fun h =>
+      hij (tetrahedronQuarterIndex.injective h), by simpa, by simpa⟩
+
+private def
+    SecondHurewicz.SimplyConnected.tetrahedronQuadrilateralLoop {X : Type} [TopologicalSpace X]
+    {x : X} (τ : BasedTetrahedron x) : GenLoop (Fin 2) X x :=
+  ⟨τ.val.comp tetrahedronQuadrilateralA, fun u hu =>
+    τ.property _ (tetrahedronQuadrilateralA_boundary u hu)⟩
+
+private theorem SecondHurewicz.SimplyConnected.tetrahedronQuadrilateralLoop_diagonal {X : Type}
+    [TopologicalSpace X] {x : X} (τ : BasedTetrahedron x) (t : (unitInterval)) :
+    tetrahedronQuadrilateralLoop τ ![t, t] = x :=
+  τ.property _ (tetrahedronQuadrilateralA_diagonal t)
+
+private def SecondHurewicz.SimplyConnected.tetrahedronShiftedQuadrilateralLoop {X : Type}
+    [TopologicalSpace X] {x : X} (τ : BasedTetrahedron x) : GenLoop (Fin 2) X x :=
+  ⟨τ.val.comp (tetrahedronQuarterShift.comp tetrahedronQuadrilateralA), fun u hu =>
+    τ.property _
+      (tetrahedronQuarterShift_oneSkeleton _ (tetrahedronQuadrilateralA_boundary u hu))⟩
+
+private theorem
+    SecondHurewicz.SimplyConnected.tetrahedronShiftedQuadrilateralLoop_diagonal {X : Type}
+    [TopologicalSpace X] {x : X} (τ : BasedTetrahedron x) (t : (unitInterval)) :
+    tetrahedronShiftedQuadrilateralLoop τ ![t, t] = x :=
+  τ.property _ (tetrahedronQuarterShift_oneSkeleton _ (tetrahedronQuadrilateralA_diagonal t))
+
+private def
+    SecondHurewicz.SimplyConnected.quarterTurn : C(Fin 2 → (unitInterval), Fin 2 → (unitInterval))
+    where
+  toFun u := ![u 1, (unitInterval.symm) (u 0)]
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    fin_cases i <;> dsimp <;> fun_prop
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.quarterTurn_apply (u : Fin 2 → (unitInterval)) :
+    quarterTurn u = ![u 1, (unitInterval.symm) (u 0)] :=
+  rfl
+
+private theorem SecondHurewicz.SimplyConnected.quarterTurn_boundary (u : Fin 2 → (unitInterval))
+    (hu : u ∈ Cube.boundary (Fin 2)) : quarterTurn u ∈ Cube.boundary (Fin 2) := by
+  rcases hu with ⟨i, hi | hi⟩
+  · fin_cases i
+    · change u 0 = 0 at hi
+      exact ⟨1, Or.inr (by simp [hi])⟩
+    · exact ⟨0, Or.inl (by simpa using hi)⟩
+  · fin_cases i
+    · change u 0 = 1 at hi
+      exact ⟨1, Or.inl (by simp [hi])⟩
+    · exact ⟨0, Or.inr (by simpa using hi)⟩
+
+private def
+    SecondHurewicz.SimplyConnected.rotatedSquareLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 2) X x) : GenLoop (Fin 2) X x :=
+  ⟨p.val.comp quarterTurn, fun u hu => p.property _ (quarterTurn_boundary u hu)⟩
+
+private def SecondHurewicz.SimplyConnected.rotationVector (v : ℝ × ℝ) : ℝ × ℝ :=
+  (v.2, -v.1)
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.rotationVector_norm (v : ℝ × ℝ) :
+    ‖rotationVector v‖ = ‖v‖ := by simp [rotationVector, Prod.norm_def, max_comm]
+
+private def SecondHurewicz.SimplyConnected.rotationBlend (t : ℝ) (v : ℝ × ℝ) : ℝ × ℝ :=
+  ((1 - t) * v.1 + t * v.2, (1 - t) * v.2 - t * v.1)
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.rotationBlend_zero (v : ℝ × ℝ) : rotationBlend 0 v = v := by
+  ext <;> simp [rotationBlend]
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.rotationBlend_one (v : ℝ × ℝ) :
+    rotationBlend 1 v = rotationVector v := by ext <;> simp [rotationBlend, rotationVector]
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.rotationBlend_zero_vector (t : ℝ) :
+    rotationBlend t 0 = 0 := by ext <;> simp [rotationBlend]
+
+private theorem
+    SecondHurewicz.SimplyConnected.rotationBlend_ne_zero (t : ℝ) {v : ℝ × ℝ} (hv : v ≠ 0) :
+    rotationBlend t v ≠ 0 := by
+  intro h
+  have h₁ : (1 - t) * v.1 + t * v.2 = 0 := congrArg Prod.fst h
+  have h₂ : (1 - t) * v.2 - t * v.1 = 0 := congrArg Prod.snd h
+  have hd : (1 - t) ^ 2 + t ^ 2 ≠ 0 := by
+    have hp : 0 < (1 - t) ^ 2 + t ^ 2 := by nlinarith [sq_nonneg (t - 1 / 2)]
+    exact ne_of_gt hp
+  have ha : ((1 - t) ^ 2 + t ^ 2) * v.1 = 0 := by linear_combination (1 - t) * h₁ - t * h₂
+  have hb : ((1 - t) ^ 2 + t ^ 2) * v.2 = 0 := by linear_combination t * h₁ + (1 - t) * h₂
+  apply hv
+  exact Prod.ext (mul_eq_zero.mp ha |>.resolve_left hd) (mul_eq_zero.mp hb |>.resolve_left hd)
+
+private theorem SecondHurewicz.SimplyConnected.rotationBlend_continuous :
+    Continuous (fun z : ℝ × (ℝ × ℝ) => rotationBlend z.1 z.2) := by
+  unfold rotationBlend
+  fun_prop
+
+private def SecondHurewicz.SimplyConnected.rotationCentered (u : Fin 2 → (unitInterval)) : ℝ × ℝ :=
+  (2 * (u 0 : ℝ) - 1, 2 * (u 1 : ℝ) - 1)
+
+private theorem SecondHurewicz.SimplyConnected.rotationCentered_continuous :
+    Continuous rotationCentered := by
+  unfold rotationCentered
+  fun_prop
+
+private theorem
+    SecondHurewicz.SimplyConnected.rotationCentered_norm_le (u : Fin 2 → (unitInterval)) :
+    ‖rotationCentered u‖ ≤ 1 := by
+  rw [norm_prod_le_iff]
+  constructor <;> rw [Real.norm_eq_abs, abs_le]
+  · constructor <;> dsimp [rotationCentered] <;> linarith [(u 0).property.1, (u 0).property.2]
+  · constructor <;> dsimp [rotationCentered] <;> linarith [(u 1).property.1, (u 1).property.2]
+
+private theorem
+    SecondHurewicz.SimplyConnected.rotationCentered_norm_boundary (u : Fin 2 → (unitInterval))
+    (hu : u ∈ Cube.boundary (Fin 2)) : ‖rotationCentered u‖ = 1 := by
+  apply le_antisymm (rotationCentered_norm_le u)
+  rcases hu with ⟨i, hi | hi⟩
+  · fin_cases i
+    · change u 0 = 0 at hi
+      have hc : ‖(rotationCentered u).1‖ = 1 := by norm_num [rotationCentered, hi]
+      exact hc ▸ norm_fst_le (rotationCentered u)
+    · change u 1 = 0 at hi
+      have hc : ‖(rotationCentered u).2‖ = 1 := by norm_num [rotationCentered, hi]
+      exact hc ▸ norm_snd_le (rotationCentered u)
+  · fin_cases i
+    · change u 0 = 1 at hi
+      have hc : ‖(rotationCentered u).1‖ = 1 := by norm_num [rotationCentered, hi]
+      exact hc ▸ norm_fst_le (rotationCentered u)
+    · change u 1 = 1 at hi
+      have hc : ‖(rotationCentered u).2‖ = 1 := by norm_num [rotationCentered, hi]
+      exact hc ▸ norm_snd_le (rotationCentered u)
+
+private def SecondHurewicz.SimplyConnected.rotationDenominator (t : (unitInterval))
+    (u : Fin 2 → (unitInterval)) : ℝ :=
+  1 - ‖rotationCentered u‖ + ‖rotationBlend t (rotationCentered u)‖
+
+private theorem SecondHurewicz.SimplyConnected.rotationDenominator_pos (t : (unitInterval))
+    (u : Fin 2 → (unitInterval)) : 0 < rotationDenominator t u := by
+  by_cases hv : rotationCentered u = 0
+  · simp [rotationDenominator, hv]
+  · have hnorm : 0 < ‖rotationBlend t (rotationCentered u)‖ :=
+      norm_pos_iff.mpr (rotationBlend_ne_zero t hv)
+    have hle := rotationCentered_norm_le u
+    unfold rotationDenominator
+    linarith
+
+private theorem SecondHurewicz.SimplyConnected.rotationDenominator_continuous :
+    Continuous
+      (fun z : (unitInterval) × (Fin 2 → (unitInterval)) => rotationDenominator z.1 z.2) := by
+  unfold rotationDenominator
+  apply Continuous.add
+  · exact continuous_const.sub (rotationCentered_continuous.comp continuous_snd).norm
+  · apply Continuous.norm
+    exact
+      rotationBlend_continuous.comp
+        ((continuous_subtype_val.comp continuous_fst).prodMk
+          (rotationCentered_continuous.comp continuous_snd))
+
+private def SecondHurewicz.SimplyConnected.rotationNormalized (t : (unitInterval))
+    (u : Fin 2 → (unitInterval)) : ℝ × ℝ :=
+  (rotationDenominator t u)⁻¹ • rotationBlend t (rotationCentered u)
+
+private theorem SecondHurewicz.SimplyConnected.rotationNormalized_continuous :
+    Continuous
+      (fun z : (unitInterval) × (Fin 2 → (unitInterval)) => rotationNormalized z.1 z.2) := by
+  unfold rotationNormalized
+  apply
+    Continuous.smul (f := fun z : (unitInterval) × (Fin 2 → (unitInterval)) =>
+      (rotationDenominator z.1 z.2)⁻¹) (g := fun z : (unitInterval) × (Fin 2 → (unitInterval)) =>
+      rotationBlend z.1 (rotationCentered z.2))
+  · exact
+      rotationDenominator_continuous.inv₀ (fun z => ne_of_gt (rotationDenominator_pos z.1 z.2))
+  · exact
+      rotationBlend_continuous.comp
+        ((continuous_subtype_val.comp continuous_fst).prodMk
+          (rotationCentered_continuous.comp continuous_snd))
+
+private theorem SecondHurewicz.SimplyConnected.rotationNormalized_norm_le (t : (unitInterval))
+    (u : Fin 2 → (unitInterval)) : ‖rotationNormalized t u‖ ≤ 1 := by
+  have hd := rotationDenominator_pos t u
+  rw [rotationNormalized, norm_smul, Real.norm_of_nonneg (inv_nonneg.mpr hd.le)]
+  rw [inv_mul_le_iff₀ hd, mul_one]
+  unfold rotationDenominator
+  linarith [rotationCentered_norm_le u]
+
+private theorem SecondHurewicz.SimplyConnected.rotationNormalized_norm_boundary (t : (unitInterval))
+    (u : Fin 2 → (unitInterval)) (hu : u ∈ Cube.boundary (Fin 2)) :
+    ‖rotationNormalized t u‖ = 1 := by
+  have hd := rotationDenominator_pos t u
+  have he : rotationDenominator t u = ‖rotationBlend t (rotationCentered u)‖ := by
+    simp [rotationDenominator, rotationCentered_norm_boundary u hu]
+  rw [rotationNormalized, norm_smul, Real.norm_of_nonneg (inv_nonneg.mpr hd.le)]
+  rw [← he, inv_mul_cancel₀ (ne_of_gt hd)]
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.rotationNormalized_zero (u : Fin 2 → (unitInterval)) :
+    rotationNormalized 0 u = rotationCentered u := by
+  simp [rotationNormalized, rotationDenominator]
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.rotationNormalized_one (u : Fin 2 → (unitInterval)) :
+    rotationNormalized 1 u = rotationVector (rotationCentered u) := by
+  simp [rotationNormalized, rotationDenominator]
+
+private def SecondHurewicz.SimplyConnected.rotationUncenter (v : ℝ × ℝ) (hv : ‖v‖ ≤ 1) :
+    Fin 2 → (unitInterval) :=
+  ![⟨(v.1 + 1) / 2,
+      by
+      have h := abs_le.mp (show |v.1| ≤ 1 from (norm_fst_le v).trans hv)
+      constructor <;> linarith⟩,
+    ⟨(v.2 + 1) / 2,
+      by
+      have h := abs_le.mp (show |v.2| ≤ 1 from (norm_snd_le v).trans hv)
+      constructor <;> linarith⟩]
+
+private theorem SecondHurewicz.SimplyConnected.rotationUncenter_congr {v w : ℝ × ℝ} {hv : ‖v‖ ≤ 1}
+    {hw : ‖w‖ ≤ 1} (h : v = w) : rotationUncenter v hv = rotationUncenter w hw := by
+  subst w
+  rfl
+
+private theorem
+    SecondHurewicz.SimplyConnected.rotationUncenter_centered (u : Fin 2 → (unitInterval)) :
+    rotationUncenter (rotationCentered u) (rotationCentered_norm_le u) = u := by
+  funext i
+  fin_cases i <;> apply Subtype.ext <;> dsimp [rotationUncenter, rotationCentered] <;> ring
+
+private theorem
+    SecondHurewicz.SimplyConnected.rotationUncenter_vector (u : Fin 2 → (unitInterval)) :
+    rotationUncenter (rotationVector (rotationCentered u))
+        (by simpa using rotationCentered_norm_le u) =
+      quarterTurn u := by
+  rw [quarterTurn_apply]
+  funext i
+  fin_cases i <;> apply Subtype.ext <;>
+      dsimp [rotationUncenter, rotationVector, rotationCentered, unitInterval.symm] <;>
+    ring
+
+private theorem SecondHurewicz.SimplyConnected.rotationUncenter_boundary (v : ℝ × ℝ) (hv : ‖v‖ ≤ 1)
+    (he : ‖v‖ = 1) : rotationUncenter v hv ∈ Cube.boundary (Fin 2) := by
+  have hm : 1 ≤ Max.max |v.1| |v.2| := by simpa [Prod.norm_def, Real.norm_eq_abs] using he.ge
+  rcases le_max_iff.mp hm with ha | hb
+  · have hn : |v.1| = 1 := le_antisymm ((norm_fst_le v).trans hv) ha
+    by_cases hp : 0 ≤ v.1
+    · have h : v.1 = 1 := by simpa [abs_of_nonneg hp] using hn
+      refine ⟨0, Or.inr ?_⟩
+      apply Subtype.ext
+      dsimp [rotationUncenter]
+      linarith
+    · have h : v.1 = -1 := by
+        rw [abs_of_neg (lt_of_not_ge hp)] at hn
+        linarith
+      refine ⟨0, Or.inl ?_⟩
+      apply Subtype.ext
+      dsimp [rotationUncenter]
+      linarith
+  · have hn : |v.2| = 1 := le_antisymm ((norm_snd_le v).trans hv) hb
+    by_cases hp : 0 ≤ v.2
+    · have h : v.2 = 1 := by simpa [abs_of_nonneg hp] using hn
+      refine ⟨1, Or.inr ?_⟩
+      apply Subtype.ext
+      dsimp [rotationUncenter]
+      linarith
+    · have h : v.2 = -1 := by
+        rw [abs_of_neg (lt_of_not_ge hp)] at hn
+        linarith
+      refine ⟨1, Or.inl ?_⟩
+      apply Subtype.ext
+      dsimp [rotationUncenter]
+      linarith
+
+private def SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap :
+    C((unitInterval) × (Fin 2 → (unitInterval)), Fin 2 → (unitInterval))
+    where
+  toFun z := rotationUncenter (rotationNormalized z.1 z.2) (rotationNormalized_norm_le z.1 z.2)
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    fin_cases i
+    · apply Continuous.subtype_mk
+      change
+        Continuous
+          (fun z : (unitInterval) × (Fin 2 → (unitInterval)) =>
+            ((rotationNormalized z.1 z.2).1 + 1) / 2)
+      exact (rotationNormalized_continuous.fst.add continuous_const).div_const 2
+    · apply Continuous.subtype_mk
+      change
+        Continuous
+          (fun z : (unitInterval) × (Fin 2 → (unitInterval)) =>
+            ((rotationNormalized z.1 z.2).2 + 1) / 2)
+      exact (rotationNormalized_continuous.snd.add continuous_const).div_const 2
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap_zero (u : Fin 2 → (unitInterval)) :
+    quarterTurnHomotopyMap (0, u) = u := by
+  exact
+    (rotationUncenter_congr (hv := rotationNormalized_norm_le 0 u)
+          (rotationNormalized_zero u)).trans
+      (rotationUncenter_centered u)
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap_one (u : Fin 2 → (unitInterval)) :
+    quarterTurnHomotopyMap (1, u) = quarterTurn u := by
+  exact
+    (rotationUncenter_congr (hv := rotationNormalized_norm_le 1 u)
+          (rotationNormalized_one u)).trans
+      (rotationUncenter_vector u)
+
+private theorem SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap_boundary (t : (unitInterval))
+    (u : Fin 2 → (unitInterval)) (hu : u ∈ Cube.boundary (Fin 2)) :
+    quarterTurnHomotopyMap (t, u) ∈ Cube.boundary (Fin 2) :=
+  rotationUncenter_boundary (rotationNormalized t u) (rotationNormalized_norm_le t u)
+    (rotationNormalized_norm_boundary t u hu)
+
+private def
+    SecondHurewicz.SimplyConnected.rotatedSquareLoop_homotopy {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 2) X x) :
+    p.val.HomotopyRel (rotatedSquareLoop p).val (Cube.boundary (Fin 2))
+    where
+  toFun z := p (quarterTurnHomotopyMap z)
+  continuous_toFun := p.val.continuous.comp quarterTurnHomotopyMap.continuous
+  map_zero_left u := congrArg p (quarterTurnHomotopyMap_zero u)
+  map_one_left u := congrArg p (quarterTurnHomotopyMap_one u)
+  prop' t u
+    hu := (p.property _ (quarterTurnHomotopyMap_boundary t u hu)).trans (p.property u hu).symm
+
+private theorem
+    SecondHurewicz.SimplyConnected.rotatedSquareLoop_class {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 2) X x) : (⟦rotatedSquareLoop p⟧ : π_ 2 X x) = ⟦p⟧ := by
+  have h : (⟦p⟧ : π_ 2 X x) = ⟦rotatedSquareLoop p⟧ :=
+    Quotient.sound
+      (show GenLoop.Homotopic p (rotatedSquareLoop p) from ⟨rotatedSquareLoop_homotopy p⟩)
+  exact h.symm
+
+private def SecondHurewicz.SimplyConnected.tetrahedronQuadrilateralB :
+    C(Fin 2 → (unitInterval), FirstHurewicz.Simplex 3) :=
+  (tetrahedronQuarterShift.comp tetrahedronQuadrilateralA).comp quarterTurn
+
+private theorem SecondHurewicz.SimplyConnected.tetrahedronQuadrilateral_perimeter
+    (u : Fin 2 → (unitInterval)) (hu : u ∈ Cube.boundary (Fin 2)) :
+    tetrahedronQuadrilateralA u = tetrahedronQuadrilateralB u := by
+  have tetrahedronQuadrilateralA_zero (u : Fin 2 → (unitInterval)) :
+    tetrahedronQuadrilateralA u 0 = 1 - Max.max (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have tetrahedronQuadrilateralA_one (u : Fin 2 → (unitInterval)) :
+    tetrahedronQuadrilateralA u 1 = (u 0 : ℝ) - Min.min (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have tetrahedronQuadrilateralA_two (u : Fin 2 → (unitInterval)) :
+    tetrahedronQuadrilateralA u 2 = Min.min (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have tetrahedronQuadrilateralA_three (u : Fin 2 → (unitInterval)) :
+    tetrahedronQuadrilateralA u 3 = (u 1 : ℝ) - Min.min (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have tetrahedronQuarterShift_zero (s : FirstHurewicz.Simplex 3) :
+    tetrahedronQuarterShift s 0 = s 3 := rfl
+  have tetrahedronQuarterShift_one (s : FirstHurewicz.Simplex 3) :
+    tetrahedronQuarterShift s 1 = s 0 := rfl
+  have tetrahedronQuarterShift_two (s : FirstHurewicz.Simplex 3) :
+    tetrahedronQuarterShift s 2 = s 1 := rfl
+  have tetrahedronQuarterShift_three (s : FirstHurewicz.Simplex 3) :
+    tetrahedronQuarterShift s 3 = s 2 := rfl
+  have tetrahedronQuadrilateralB_apply (u : Fin 2 → (unitInterval)) :
+    tetrahedronQuadrilateralB u =
+      tetrahedronQuarterShift (tetrahedronQuadrilateralA ![u 1, (unitInterval.symm) (u 0)]) :=
+    rfl
+  apply Subtype.ext
+  funext j
+  change tetrahedronQuadrilateralA u j = tetrahedronQuadrilateralB u j
+  rcases hu with ⟨i, hi | hi⟩
+  · fin_cases i
+    · change u 0 = 0 at hi
+      fin_cases j <;>
+        simp [tetrahedronQuadrilateralA_zero, tetrahedronQuadrilateralA_one,
+          tetrahedronQuadrilateralA_two, tetrahedronQuadrilateralA_three,
+          tetrahedronQuarterShift_zero, tetrahedronQuarterShift_one, tetrahedronQuarterShift_two,
+          tetrahedronQuarterShift_three, tetrahedronQuadrilateralB_apply, hi,
+          min_eq_left (u 1).property.2, max_eq_right (u 1).property.2,
+          min_eq_left (u 1).property.1, max_eq_right (u 1).property.1]
+    · change u 1 = 0 at hi
+      fin_cases j <;>
+        simp [tetrahedronQuadrilateralA_zero, tetrahedronQuadrilateralA_one,
+          tetrahedronQuadrilateralA_two, tetrahedronQuadrilateralA_three,
+          tetrahedronQuarterShift_zero, tetrahedronQuarterShift_one, tetrahedronQuarterShift_two,
+          tetrahedronQuarterShift_three, tetrahedronQuadrilateralB_apply, hi,
+          min_eq_right (u 0).property.1, max_eq_left (u 0).property.1, (u 0).property.2]
+  · fin_cases i
+    · change u 0 = 1 at hi
+      fin_cases j <;>
+        simp [tetrahedronQuadrilateralA_zero, tetrahedronQuadrilateralA_one,
+          tetrahedronQuadrilateralA_two, tetrahedronQuadrilateralA_three,
+          tetrahedronQuarterShift_zero, tetrahedronQuarterShift_one, tetrahedronQuarterShift_two,
+          tetrahedronQuarterShift_three, tetrahedronQuadrilateralB_apply, hi,
+          min_eq_right (u 1).property.2, max_eq_left (u 1).property.2,
+          min_eq_right (u 1).property.1, max_eq_left (u 1).property.1]
+    · change u 1 = 1 at hi
+      fin_cases j <;>
+        simp [tetrahedronQuadrilateralA_zero, tetrahedronQuadrilateralA_one,
+          tetrahedronQuadrilateralA_two, tetrahedronQuadrilateralA_three,
+          tetrahedronQuarterShift_zero, tetrahedronQuarterShift_one, tetrahedronQuarterShift_two,
+          tetrahedronQuarterShift_three, tetrahedronQuadrilateralB_apply, hi,
+          min_eq_left (u 0).property.2, max_eq_right (u 0).property.2, (u 0).property.1]
+
+private def
+    SecondHurewicz.SimplyConnected.tetrahedronFillingsHomotopy {X : Type} [TopologicalSpace X]
+    {x : X} (τ : BasedTetrahedron x) :
+    (tetrahedronQuadrilateralLoop τ).val.HomotopyRel
+      (rotatedSquareLoop (tetrahedronShiftedQuadrilateralLoop τ)).val (Cube.boundary (Fin 2))
+    where
+  toFun
+    p :=
+    τ.val
+      (tetrahedronSimplexBlend p.1 (tetrahedronQuadrilateralA p.2)
+        (tetrahedronQuadrilateralB p.2))
+  continuous_toFun :=
+    τ.val.continuous.comp
+      (tetrahedronSimplexBlendMap tetrahedronQuadrilateralA tetrahedronQuadrilateralB).continuous
+  map_zero_left
+    u := by
+    change τ.val (tetrahedronSimplexBlend 0 _ _) = τ.val (tetrahedronQuadrilateralA u)
+    rw [tetrahedronSimplexBlend_zero]
+  map_one_left
+    u := by
+    change τ.val (tetrahedronSimplexBlend 1 _ _) = τ.val (tetrahedronQuadrilateralB u)
+    rw [tetrahedronSimplexBlend_one]
+  prop' t u
+    hu := by
+    change τ.val (tetrahedronSimplexBlend t _ _) = τ.val (tetrahedronQuadrilateralA u)
+    rw [← tetrahedronQuadrilateral_perimeter u hu, tetrahedronSimplexBlend_self]
+
+private theorem SecondHurewicz.SimplyConnected.tetrahedronFillings_homotopic {X : Type}
+    [TopologicalSpace X] {x : X} (τ : BasedTetrahedron x) :
+    GenLoop.Homotopic (tetrahedronQuadrilateralLoop τ)
+      (rotatedSquareLoop (tetrahedronShiftedQuadrilateralLoop τ)) :=
+  ⟨tetrahedronFillingsHomotopy τ⟩
+
+private theorem
+    SecondHurewicz.SimplyConnected.tetrahedronFillings_class {X : Type} [TopologicalSpace X]
+    {x : X} (τ : BasedTetrahedron x) :
+    (⟦tetrahedronQuadrilateralLoop τ⟧ : π_ 2 X x) = ⟦tetrahedronShiftedQuadrilateralLoop τ⟧ :=
+  (Quotient.sound (tetrahedronFillings_homotopic τ)).trans
+    (rotatedSquareLoop_class (tetrahedronShiftedQuadrilateralLoop τ))
+
+private def SecondHurewicz.SimplyConnected.triangleCyclicPermutation :
+    C(FirstHurewicz.Simplex 2, FirstHurewicz.Simplex 2)
+    where
+  toFun
+    s :=
+    ⟨![s 1, s 2, s 0], by
+      constructor
+      · intro i
+        fin_cases i <;> exact stdSimplex.zero_le s _
+      · have hs := stdSimplex.sum_eq_one s
+        simp only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero, Matrix.cons_val_zero,
+          Matrix.cons_val_succ, Matrix.cons_val_fin_one] at hs ⊢
+        change s 0 + (s 1 + s 2) = 1 at hs
+        linarith⟩
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    apply continuous_pi
+    intro i
+    fin_cases i
+    · exact (continuous_apply 1).comp continuous_subtype_val
+    · exact (continuous_apply 2).comp continuous_subtype_val
+    · exact (continuous_apply 0).comp continuous_subtype_val
+
+private theorem SecondHurewicz.SimplyConnected.triangleCyclicPermutation_boundary
+    (s : FirstHurewicz.Simplex 2) (hs : s ∈ triangleBoundary) :
+    triangleCyclicPermutation s ∈ triangleBoundary := by
+  obtain ⟨i, hi⟩ := hs
+  fin_cases i
+  · exact ⟨2, hi⟩
+  · exact ⟨0, hi⟩
+  · exact ⟨1, hi⟩
+
+private def
+    SecondHurewicz.SimplyConnected.cyclicBasedTriangle {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedTriangle x) : BasedTriangle x :=
+  ⟨τ.val.comp triangleCyclicPermutation, fun s hs =>
+    τ.property _ (triangleCyclicPermutation_boundary s hs)⟩
+
+private theorem SecondHurewicz.SimplyConnected.cyclicTriangleQuotient_commonZero
+    (u : Fin 2 → (unitInterval)) (hu : u ∈ Cube.boundary (Fin 2)) :
+    ∃ i : Fin 3,
+      triangleCyclicPermutation (triangleCubeQuotient u) i = 0 ∧
+        triangleCubeQuotient (quarterTurn u) i = 0 := by
+  have triangleCubeQuotient_apply (t : Fin 2 → (unitInterval)) :
+    triangleCubeQuotient t = triangleQuotient (t 0, t 1) := rfl
+  have triangleCyclicPermutation_zero (s : FirstHurewicz.Simplex 2) :
+    triangleCyclicPermutation s 0 = s 1 := rfl
+  have triangleCyclicPermutation_one (s : FirstHurewicz.Simplex 2) :
+    triangleCyclicPermutation s 1 = s 2 := rfl
+  have triangleCyclicPermutation_two (s : FirstHurewicz.Simplex 2) :
+    triangleCyclicPermutation s 2 = s 0 := rfl
+  rcases hu with ⟨i, hi | hi⟩
+  · fin_cases i
+    · change u 0 = 0 at hi
+      refine ⟨1, ?_, ?_⟩ <;>
+        simp [triangleCubeQuotient_apply, triangleCyclicPermutation_one, hi,
+          min_eq_left (u 1).property.1, min_eq_left (u 1).property.2]
+    · change u 1 = 0 at hi
+      refine ⟨1, ?_, ?_⟩
+      · simp [triangleCubeQuotient_apply, triangleCyclicPermutation_one, hi,
+          min_eq_right (u 0).property.1]
+      · simp [triangleCubeQuotient_apply, hi, (u 0).property.2]
+  · fin_cases i
+    · change u 0 = 1 at hi
+      refine ⟨2, ?_, ?_⟩ <;>
+        simp [triangleCubeQuotient_apply, triangleCyclicPermutation_two, hi,
+          min_eq_right (u 1).property.1]
+    · change u 1 = 1 at hi
+      refine ⟨0, ?_, ?_⟩ <;>
+        simp [triangleCubeQuotient_apply, triangleCyclicPermutation_zero, hi,
+          min_eq_left (u 0).property.2]
+
+private theorem
+    SecondHurewicz.SimplyConnected.cyclicTriangleQuotient_blend_boundary (t : (unitInterval))
+    (u : Fin 2 → (unitInterval)) (hu : u ∈ Cube.boundary (Fin 2)) :
+    tetrahedronSimplexBlend t (triangleCyclicPermutation (triangleCubeQuotient u))
+        (triangleCubeQuotient (quarterTurn u)) ∈
+      triangleBoundary := by
+  obtain ⟨i, hi, hj⟩ := cyclicTriangleQuotient_commonZero u hu
+  exact ⟨i, tetrahedronSimplexBlend_zero_coordinate t _ _ i hi hj⟩
+
+private def
+    SecondHurewicz.SimplyConnected.cyclicTriangleLoopHomotopy {X : Type} [TopologicalSpace X]
+    {x : X} (τ : BasedTriangle x) :
+    (basedTriangleLoop (cyclicBasedTriangle τ)).val.HomotopyRel
+      (rotatedSquareLoop (basedTriangleLoop τ)).val (Cube.boundary (Fin 2))
+    where
+  toFun
+    p :=
+    τ.val
+      (tetrahedronSimplexBlend p.1 (triangleCyclicPermutation (triangleCubeQuotient p.2))
+        (triangleCubeQuotient (quarterTurn p.2)))
+  continuous_toFun :=
+    τ.val.continuous.comp
+      (tetrahedronSimplexBlendMap (triangleCyclicPermutation.comp triangleCubeQuotient)
+          (triangleCubeQuotient.comp quarterTurn)).continuous
+  map_zero_left
+    u := by
+    change
+      τ.val (tetrahedronSimplexBlend 0 _ _) =
+        τ.val (triangleCyclicPermutation (triangleCubeQuotient u))
+    rw [tetrahedronSimplexBlend_zero]
+  map_one_left
+    u := by
+    change τ.val (tetrahedronSimplexBlend 1 _ _) = τ.val (triangleCubeQuotient (quarterTurn u))
+    rw [tetrahedronSimplexBlend_one]
+  prop' t u
+    hu :=
+    (τ.property _ (cyclicTriangleQuotient_blend_boundary t u hu)).trans
+      ((basedTriangleLoop (cyclicBasedTriangle τ)).property u hu).symm
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.basedTriangleClass_cyclic {X : Type} [TopologicalSpace X]
+    {x : X} (τ : BasedTriangle x) :
+    basedTriangleClass (cyclicBasedTriangle τ) = basedTriangleClass τ := by
+  have h :
+    GenLoop.Homotopic (basedTriangleLoop (cyclicBasedTriangle τ))
+      (rotatedSquareLoop (basedTriangleLoop τ)) :=
+    ⟨cyclicTriangleLoopHomotopy τ⟩
+  have he :
+    (⟦basedTriangleLoop (cyclicBasedTriangle τ)⟧ : π_ 2 X x) =
+      ⟦rotatedSquareLoop (basedTriangleLoop τ)⟧ :=
+    Quotient.sound h
+  exact congrArg Additive.ofMul (he.trans (rotatedSquareLoop_class (basedTriangleLoop τ)))
+
+private abbrev SecondHurewicz.SimplyConnected.SubdivisionSquare :=
+  Fin 2 → (unitInterval)
+
+private theorem
+    SecondHurewicz.SimplyConnected.subdivisionSquare_boundary_cases (u : SubdivisionSquare)
+    (hu : u ∈ Cube.boundary (Fin 2)) : u 0 = 0 ∨ u 0 = 1 ∨ u 1 = 0 ∨ u 1 = 1 := by
+  rcases hu with ⟨i, hi⟩
+  fin_cases i
+  · rcases hi with hi | hi
+    · exact Or.inl hi
+    · exact Or.inr (Or.inl hi)
+  · rcases hi with hi | hi
+    · exact Or.inr (Or.inr (Or.inl hi))
+    · exact Or.inr (Or.inr (Or.inr hi))
+
+private inductive
+    SecondHurewicz.SimplyConnected.SubdivisionSameSide (a b : SubdivisionSquare) : Prop
+  | zero (i : Fin 2) (ha : a i = 0) (hb : b i = 0)
+  | one (i : Fin 2) (ha : a i = 1) (hb : b i = 1)
+  | diagonal (ha : a 0 = a 1) (hb : b 0 = b 1)
+
+private def SecondHurewicz.SimplyConnected.subdivisionBlend (t : (unitInterval))
+    (a b : SubdivisionSquare) : SubdivisionSquare := fun i => Set.Icc.convexComb (a i) (b i) t
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.subdivisionBlend_zero (a b : SubdivisionSquare) :
+    subdivisionBlend 0 a b = a := by
+  funext i
+  exact Set.Icc.convexComb_zero _ _
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.subdivisionBlend_one (a b : SubdivisionSquare) :
+    subdivisionBlend 1 a b = b := by
+  funext i
+  exact Set.Icc.convexComb_one _ _
+
+private def SecondHurewicz.SimplyConnected.subdivisionBlendMap
+    (f g : C(SubdivisionSquare, SubdivisionSquare)) :
+    C((unitInterval) × SubdivisionSquare, SubdivisionSquare)
+    where
+  toFun u := subdivisionBlend u.1 (f u.2) (g u.2)
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    exact
+      Set.Icc.continuous_convexComb_prod.comp
+        (((continuous_apply i).comp (f.continuous.comp continuous_snd)).prodMk
+          (((continuous_apply i).comp (g.continuous.comp continuous_snd)).prodMk continuous_fst))
+
+private theorem
+    SecondHurewicz.SimplyConnected.subdivisionOnDiagonal {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 2) X x) (hd : ∀ t : (unitInterval), p ![t, t] = x)
+    (a : SubdivisionSquare) (ha : a 0 = a 1) : p a = x := by
+  have h : a = ![a 0, a 0] := by
+    funext i
+    fin_cases i
+    · rfl
+    · exact ha.symm
+  exact (congrArg p h).trans (hd _)
+
+private theorem
+    SecondHurewicz.SimplyConnected.subdivisionBlend_based {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 2) X x) (hd : ∀ t : (unitInterval), p ![t, t] = x)
+    {a b : SubdivisionSquare} (h : SubdivisionSameSide a b) (t : (unitInterval)) :
+    p (subdivisionBlend t a b) = x := by
+  cases h with
+  | zero i ha hb =>
+    apply p.property
+    exact ⟨i, Or.inl (by simp [subdivisionBlend, ha, hb])⟩
+  | one i ha hb =>
+    apply p.property
+    exact ⟨i, Or.inr (by simp [subdivisionBlend, ha, hb])⟩
+  | diagonal ha hb =>
+    apply subdivisionOnDiagonal p hd
+    simp only [subdivisionBlend, ha, hb]
+
+private def SecondHurewicz.SimplyConnected.subdivisionPullbackLoop {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 2) X x) (f : C(SubdivisionSquare, SubdivisionSquare))
+    (hf : ∀ u ∈ Cube.boundary (Fin 2), p (f u) = x) : GenLoop (Fin 2) X x :=
+  ⟨p.val.comp f, hf⟩
+
+private def
+    SecondHurewicz.SimplyConnected.subdivisionLinearHomotopy {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 2) X x) (hd : ∀ t : (unitInterval), p ![t, t] = x)
+    (f g : C(SubdivisionSquare, SubdivisionSquare))
+    (hf : ∀ u ∈ Cube.boundary (Fin 2), p (f u) = x)
+    (hg : ∀ u ∈ Cube.boundary (Fin 2), p (g u) = x)
+    (hfg : ∀ u ∈ Cube.boundary (Fin 2), SubdivisionSameSide (f u) (g u)) :
+    (subdivisionPullbackLoop p f hf).val.HomotopyRel (subdivisionPullbackLoop p g hg).val
+      (Cube.boundary (Fin 2))
+    where
+  toFun u := p (subdivisionBlend u.1 (f u.2) (g u.2))
+  continuous_toFun := p.val.continuous.comp (subdivisionBlendMap f g).continuous
+  map_zero_left
+    u := by
+    change p (subdivisionBlend 0 (f u) (g u)) = p (f u)
+    rw [subdivisionBlend_zero]
+  map_one_left
+    u := by
+    change p (subdivisionBlend 1 (f u) (g u)) = p (g u)
+    rw [subdivisionBlend_one]
+  prop' t u hu := (subdivisionBlend_based p hd (hfg u hu) t).trans (hf u hu).symm
+
+private def
+    SecondHurewicz.SimplyConnected.subdivisionSubMin (u v : (unitInterval)) : (unitInterval) :=
+  ⟨(u : ℝ) - Min.min (u : ℝ) (v : ℝ), sub_nonneg.mpr (min_le_left _ _),
+    (sub_le_self _ (le_min u.property.1 v.property.1)).trans u.property.2⟩
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.subdivisionSubMin_zero_left (v : (unitInterval)) :
+    subdivisionSubMin 0 v = 0 := by
+  apply Subtype.ext
+  simp [subdivisionSubMin, v.property.1]
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.subdivisionSubMin_zero_right (u : (unitInterval)) :
+    subdivisionSubMin u 0 = u := by
+  apply Subtype.ext
+  simp [subdivisionSubMin, u.property.1]
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.subdivisionSubMin_one_left (v : (unitInterval)) :
+    subdivisionSubMin 1 v = (unitInterval.symm) v := by
+  apply Subtype.ext
+  simp [subdivisionSubMin, v.property.2]
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.subdivisionSubMin_one_right (u : (unitInterval)) :
+    subdivisionSubMin u 1 = 0 := by
+  apply Subtype.ext
+  simp [subdivisionSubMin, u.property.2]
+
+private def SecondHurewicz.SimplyConnected.subdivisionLowerProductMap :
+    C(SubdivisionSquare, SubdivisionSquare)
+    where
+  toFun u := ![u 0, u 0 * u 1]
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    fin_cases i
+    · exact continuous_apply 0
+    · change Continuous fun u : SubdivisionSquare => u 0 * u 1
+      apply Continuous.subtype_mk
+      exact
+        (continuous_subtype_val.comp (continuous_apply 0)).mul
+          (continuous_subtype_val.comp (continuous_apply 1))
+
+private def SecondHurewicz.SimplyConnected.subdivisionUpperProductMap :
+    C(SubdivisionSquare, SubdivisionSquare)
+    where
+  toFun u := ![u 0, Set.Icc.convexComb (u 0) 1 (u 1)]
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    fin_cases i
+    · exact continuous_apply 0
+    · change Continuous fun u : SubdivisionSquare => Set.Icc.convexComb (u 0) 1 (u 1)
+      unfold Set.Icc.convexComb
+      fun_prop
+
+private def SecondHurewicz.SimplyConnected.subdivisionUpperConeMap :
+    C(SubdivisionSquare, SubdivisionSquare)
+    where
+  toFun u := ![u 0 * (unitInterval.symm) (u 1), Set.Icc.convexComb (u 0) 1 (u 1)]
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    fin_cases i
+    · change Continuous fun u : SubdivisionSquare => u 0 * (unitInterval.symm) (u 1)
+      apply Continuous.subtype_mk
+      change Continuous fun u : SubdivisionSquare => (u 0 : ℝ) * (1 - (u 1 : ℝ))
+      fun_prop
+    · change Continuous fun u : SubdivisionSquare => Set.Icc.convexComb (u 0) 1 (u 1)
+      unfold Set.Icc.convexComb
+      fun_prop
+
+private def SecondHurewicz.SimplyConnected.subdivisionLowerTriangleMap :
+    C(SubdivisionSquare, SubdivisionSquare)
+    where
+  toFun u := ![u 0, Min.min (u 0) (u 1)]
+  continuous_toFun := by fun_prop
+
+private def SecondHurewicz.SimplyConnected.subdivisionUpperTriangleMap :
+    C(SubdivisionSquare, SubdivisionSquare)
+    where
+  toFun u := ![subdivisionSubMin (u 0) (u 1), u 0]
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    fin_cases i
+    · change Continuous fun u : SubdivisionSquare => subdivisionSubMin (u 0) (u 1)
+      unfold subdivisionSubMin
+      fun_prop
+    · exact continuous_apply 0
+
+private theorem SecondHurewicz.SimplyConnected.subdivisionLowerProductMap_based {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) (u : SubdivisionSquare)
+    (hu : u ∈ Cube.boundary (Fin 2)) : p (subdivisionLowerProductMap u) = x := by
+  rcases subdivisionSquare_boundary_cases u hu with h | h | h | h
+  · exact p.property _ ⟨0, Or.inl (by simp [subdivisionLowerProductMap, h])⟩
+  · exact p.property _ ⟨0, Or.inr (by simp [subdivisionLowerProductMap, h])⟩
+  · exact p.property _ ⟨1, Or.inl (by simp [subdivisionLowerProductMap, h])⟩
+  · exact subdivisionOnDiagonal p hd _ (by simp [subdivisionLowerProductMap, h])
+
+private theorem SecondHurewicz.SimplyConnected.subdivisionUpperProductMap_based {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) (u : SubdivisionSquare)
+    (hu : u ∈ Cube.boundary (Fin 2)) : p (subdivisionUpperProductMap u) = x := by
+  rcases subdivisionSquare_boundary_cases u hu with h | h | h | h
+  · exact p.property _ ⟨0, Or.inl (by simp [subdivisionUpperProductMap, h])⟩
+  · exact p.property _ ⟨0, Or.inr (by simp [subdivisionUpperProductMap, h])⟩
+  · exact subdivisionOnDiagonal p hd _ (by simp [subdivisionUpperProductMap, h])
+  · exact p.property _ ⟨1, Or.inr (by simp [subdivisionUpperProductMap, h])⟩
+
+private theorem SecondHurewicz.SimplyConnected.subdivisionUpperConeMap_based {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) (u : SubdivisionSquare)
+    (hu : u ∈ Cube.boundary (Fin 2)) : p (subdivisionUpperConeMap u) = x := by
+  rcases subdivisionSquare_boundary_cases u hu with h | h | h | h
+  · exact p.property _ ⟨0, Or.inl (by simp [subdivisionUpperConeMap, h])⟩
+  · exact p.property _ ⟨1, Or.inr (by simp [subdivisionUpperConeMap, h])⟩
+  · exact subdivisionOnDiagonal p hd _ (by simp [subdivisionUpperConeMap, h])
+  · exact p.property _ ⟨0, Or.inl (by simp [subdivisionUpperConeMap, h])⟩
+
+private theorem SecondHurewicz.SimplyConnected.subdivisionLowerTriangleMap_based {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) (u : SubdivisionSquare)
+    (hu : u ∈ Cube.boundary (Fin 2)) : p (subdivisionLowerTriangleMap u) = x := by
+  rcases subdivisionSquare_boundary_cases u hu with h | h | h | h
+  · exact p.property _ ⟨0, Or.inl (by simp [subdivisionLowerTriangleMap, h])⟩
+  · exact p.property _ ⟨0, Or.inr (by simp [subdivisionLowerTriangleMap, h])⟩
+  · exact p.property _ ⟨1, Or.inl (by simp [subdivisionLowerTriangleMap, h])⟩
+  · exact
+      subdivisionOnDiagonal p hd _
+        (by
+          simp [subdivisionLowerTriangleMap, h,
+            min_eq_left (show u 0 ≤ (1 : (unitInterval)) from (u 0).property.2)])
+
+private theorem SecondHurewicz.SimplyConnected.subdivisionUpperTriangleMap_based {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) (u : SubdivisionSquare)
+    (hu : u ∈ Cube.boundary (Fin 2)) : p (subdivisionUpperTriangleMap u) = x := by
+  rcases subdivisionSquare_boundary_cases u hu with h | h | h | h
+  · exact p.property _ ⟨1, Or.inl (by simp [subdivisionUpperTriangleMap, h])⟩
+  · exact p.property _ ⟨1, Or.inr (by simp [subdivisionUpperTriangleMap, h])⟩
+  · exact subdivisionOnDiagonal p hd _ (by simp [subdivisionUpperTriangleMap, h])
+  · exact p.property _ ⟨0, Or.inl (by simp [subdivisionUpperTriangleMap, h])⟩
+
+private def
+    SecondHurewicz.SimplyConnected.subdivisionLowerProductLoop {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 2) X x) (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    GenLoop (Fin 2) X x :=
+  subdivisionPullbackLoop p subdivisionLowerProductMap (subdivisionLowerProductMap_based p hd)
+
+private def
+    SecondHurewicz.SimplyConnected.subdivisionUpperProductLoop {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 2) X x) (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    GenLoop (Fin 2) X x :=
+  subdivisionPullbackLoop p subdivisionUpperProductMap (subdivisionUpperProductMap_based p hd)
+
+private def SecondHurewicz.SimplyConnected.subdivisionUpperConeLoop {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 2) X x) (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    GenLoop (Fin 2) X x :=
+  subdivisionPullbackLoop p subdivisionUpperConeMap (subdivisionUpperConeMap_based p hd)
+
+private def
+    SecondHurewicz.SimplyConnected.subdivisionLowerTriangleLoop {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 2) X x) (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    GenLoop (Fin 2) X x :=
+  subdivisionPullbackLoop p subdivisionLowerTriangleMap (subdivisionLowerTriangleMap_based p hd)
+
+private def
+    SecondHurewicz.SimplyConnected.subdivisionUpperTriangleLoop {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 2) X x) (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    GenLoop (Fin 2) X x :=
+  subdivisionPullbackLoop p subdivisionUpperTriangleMap (subdivisionUpperTriangleMap_based p hd)
+
+private theorem SecondHurewicz.SimplyConnected.subdivisionLowerProductTriangle_sides
+    (u : SubdivisionSquare) (hu : u ∈ Cube.boundary (Fin 2)) :
+    SubdivisionSameSide (subdivisionLowerProductMap u) (subdivisionLowerTriangleMap u) := by
+  rcases subdivisionSquare_boundary_cases u hu with h | h | h | h
+  · exact
+      .zero 0 (by simp [subdivisionLowerProductMap, h]) (by simp [subdivisionLowerTriangleMap, h])
+  · exact
+      .one 0 (by simp [subdivisionLowerProductMap, h]) (by simp [subdivisionLowerTriangleMap, h])
+  · exact
+      .zero 1 (by simp [subdivisionLowerProductMap, h]) (by simp [subdivisionLowerTriangleMap, h])
+  · exact
+      .diagonal (by simp [subdivisionLowerProductMap, h])
+        (by
+          simp [subdivisionLowerTriangleMap, h,
+            min_eq_left (show u 0 ≤ (1 : (unitInterval)) from (u 0).property.2)])
+
+private theorem
+    SecondHurewicz.SimplyConnected.subdivisionUpperProductCone_sides (u : SubdivisionSquare)
+    (hu : u ∈ Cube.boundary (Fin 2)) :
+    SubdivisionSameSide (subdivisionUpperProductMap u) (subdivisionUpperConeMap u) := by
+  rcases subdivisionSquare_boundary_cases u hu with h | h | h | h
+  · exact .zero 0 (by simp [subdivisionUpperProductMap, h]) (by simp [subdivisionUpperConeMap, h])
+  · exact .one 1 (by simp [subdivisionUpperProductMap, h]) (by simp [subdivisionUpperConeMap, h])
+  · exact
+      .diagonal (by simp [subdivisionUpperProductMap, h]) (by simp [subdivisionUpperConeMap, h])
+  · exact .one 1 (by simp [subdivisionUpperProductMap, h]) (by simp [subdivisionUpperConeMap, h])
+
+private theorem
+    SecondHurewicz.SimplyConnected.subdivisionUpperConeTriangle_sides (u : SubdivisionSquare)
+    (hu : u ∈ Cube.boundary (Fin 2)) :
+    SubdivisionSameSide (subdivisionUpperConeMap u) (subdivisionUpperTriangleMap u) := by
+  rcases subdivisionSquare_boundary_cases u hu with h | h | h | h
+  · exact
+      .zero 0 (by simp [subdivisionUpperConeMap, h]) (by simp [subdivisionUpperTriangleMap, h])
+  · exact .one 1 (by simp [subdivisionUpperConeMap, h]) (by simp [subdivisionUpperTriangleMap, h])
+  · exact
+      .diagonal (by simp [subdivisionUpperConeMap, h]) (by simp [subdivisionUpperTriangleMap, h])
+  · exact
+      .zero 0 (by simp [subdivisionUpperConeMap, h]) (by simp [subdivisionUpperTriangleMap, h])
+
+private def SecondHurewicz.SimplyConnected.subdivisionLowerTriangleHomotopy {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    (subdivisionLowerProductLoop p hd).val.HomotopyRel (subdivisionLowerTriangleLoop p hd).val
+      (Cube.boundary (Fin 2)) :=
+  subdivisionLinearHomotopy p hd _ _ (subdivisionLowerProductMap_based p hd)
+    (subdivisionLowerTriangleMap_based p hd) subdivisionLowerProductTriangle_sides
+
+private def
+    SecondHurewicz.SimplyConnected.subdivisionUpperConeHomotopy {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 2) X x) (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    (subdivisionUpperProductLoop p hd).val.HomotopyRel (subdivisionUpperConeLoop p hd).val
+      (Cube.boundary (Fin 2)) :=
+  subdivisionLinearHomotopy p hd _ _ (subdivisionUpperProductMap_based p hd)
+    (subdivisionUpperConeMap_based p hd) subdivisionUpperProductCone_sides
+
+private def SecondHurewicz.SimplyConnected.subdivisionUpperTriangleHomotopy {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    (subdivisionUpperConeLoop p hd).val.HomotopyRel (subdivisionUpperTriangleLoop p hd).val
+      (Cube.boundary (Fin 2)) :=
+  subdivisionLinearHomotopy p hd _ _ (subdivisionUpperConeMap_based p hd)
+    (subdivisionUpperTriangleMap_based p hd) subdivisionUpperConeTriangle_sides
+
+private theorem
+    SecondHurewicz.SimplyConnected.subdivision_toLoop_transAt {X : Type*} [TopologicalSpace X]
+    {x : X} (i : Fin 2) (a b : GenLoop (Fin 2) X x) :
+    GenLoop.toLoop i (GenLoop.transAt i a b) = (GenLoop.toLoop i a).trans (GenLoop.toLoop i b) := by
+  rw [← GenLoop.fromLoop_trans_toLoop, GenLoop.to_from]
+
+private theorem SecondHurewicz.SimplyConnected.subdivision_transAt_homotopic {X : Type*}
+    [TopologicalSpace X] {x : X} (i : Fin 2) {a b c d : GenLoop (Fin 2) X x}
+    (ha : GenLoop.Homotopic a c) (hb : GenLoop.Homotopic b d) :
+    GenLoop.Homotopic (GenLoop.transAt i a b) (GenLoop.transAt i c d) := by
+  apply GenLoop.homotopicFrom i
+  rw [subdivision_toLoop_transAt, subdivision_toLoop_transAt]
+  rcases GenLoop.homotopicTo i ha with ⟨Ha⟩
+  rcases GenLoop.homotopicTo i hb with ⟨Hb⟩
+  exact ⟨Ha.hcomp Hb⟩
+
+private noncomputable def SecondHurewicz.SimplyConnected.subdivisionWarpCoordinate :
+    C((unitInterval) × (unitInterval), (unitInterval))
+    where
+  toFun
+    p :=
+    Set.Icc.convexComb (Set.projIcc 0 1 zero_le_one (2 * (p.2 : ℝ) - 1))
+      (Set.projIcc 0 1 zero_le_one (2 * (p.2 : ℝ))) p.1
+  continuous_toFun := by
+    unfold Set.Icc.convexComb
+    fun_prop
+
+private theorem
+    SecondHurewicz.SimplyConnected.subdivisionWarpCoordinate_apply (u v : (unitInterval)) :
+    subdivisionWarpCoordinate (u, v) =
+      Set.Icc.convexComb (Set.projIcc 0 1 zero_le_one (2 * (v : ℝ) - 1))
+        (Set.projIcc 0 1 zero_le_one (2 * (v : ℝ))) u :=
+  rfl
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.subdivisionWarpCoordinate_zero (u : (unitInterval)) :
+    subdivisionWarpCoordinate (u, 0) = 0 := by
+  simp [subdivisionWarpCoordinate, Set.projIcc, Set.Icc.convexComb]
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.subdivisionWarpCoordinate_one (u : (unitInterval)) :
+    subdivisionWarpCoordinate (u, 1) = 1 := by
+  norm_num [subdivisionWarpCoordinate, Set.projIcc, Set.Icc.convexComb]
+
+private theorem
+    SecondHurewicz.SimplyConnected.subdivisionWarpCoordinate_of_le_half (u v : (unitInterval))
+    (hv : (v : ℝ) ≤ 1 / 2) :
+    subdivisionWarpCoordinate (u, v) = u * Set.projIcc 0 1 zero_le_one (2 * (v : ℝ)) := by
+  have hzero : Set.projIcc 0 1 zero_le_one (2 * (v : ℝ) - 1) = (0 : (unitInterval)) :=
+    Set.projIcc_of_le_left zero_le_one (by linarith)
+  rw [subdivisionWarpCoordinate_apply, hzero]
+  apply Subtype.ext
+  simp
+
+private theorem
+    SecondHurewicz.SimplyConnected.subdivisionWarpCoordinate_of_half_le (u v : (unitInterval))
+    (hv : 1 / 2 ≤ (v : ℝ)) :
+    subdivisionWarpCoordinate (u, v) =
+      Set.Icc.convexComb u 1 (Set.projIcc 0 1 zero_le_one (2 * (v : ℝ) - 1)) := by
+  have hone : Set.projIcc 0 1 zero_le_one (2 * (v : ℝ)) = (1 : (unitInterval)) :=
+    Set.projIcc_of_right_le zero_le_one (by linarith)
+  rw [subdivisionWarpCoordinate_apply, hone]
+  apply Subtype.ext
+  simp only [Set.Icc.coe_convexComb]
+  change (1 - (u : ℝ)) * _ + (u : ℝ) * 1 = (1 - _) * (u : ℝ) + _ * 1
+  ring
+
+private theorem
+    SecondHurewicz.SimplyConnected.subdivisionWarpCoordinate_of_half_lt (u v : (unitInterval))
+    (hv : 1 / 2 < (v : ℝ)) :
+    subdivisionWarpCoordinate (u, v) =
+      Set.Icc.convexComb u 1 (Set.projIcc 0 1 zero_le_one (2 * (v : ℝ) - 1)) :=
+  subdivisionWarpCoordinate_of_half_le u v hv.le
+
+private def
+    SecondHurewicz.SimplyConnected.subdivisionWarpMap : C(SubdivisionSquare, SubdivisionSquare)
+    where
+  toFun u := ![u 0, subdivisionWarpCoordinate (u 0, u 1)]
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    fin_cases i
+    · exact continuous_apply 0
+    · change Continuous fun u : SubdivisionSquare => subdivisionWarpCoordinate (u 0, u 1)
+      exact
+        subdivisionWarpCoordinate.continuous.comp
+          (show Continuous (fun u : SubdivisionSquare => (u 0, u 1)) from
+            (continuous_apply 0).prodMk (continuous_apply 1))
+
+private theorem SecondHurewicz.SimplyConnected.subdivisionWarpMap_sides (u : SubdivisionSquare)
+    (hu : u ∈ Cube.boundary (Fin 2)) : SubdivisionSameSide u (subdivisionWarpMap u) := by
+  rcases subdivisionSquare_boundary_cases u hu with h | h | h | h
+  · exact .zero 0 h (by simp [subdivisionWarpMap, h])
+  · exact .one 0 h (by simp [subdivisionWarpMap, h])
+  · exact .zero 1 h (by simp [subdivisionWarpMap, h])
+  · exact .one 1 h (by simp [subdivisionWarpMap, h])
+
+private theorem
+    SecondHurewicz.SimplyConnected.subdivisionWarpMap_based {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 2) X x) (u : SubdivisionSquare) (hu : u ∈ Cube.boundary (Fin 2)) :
+    p (subdivisionWarpMap u) = x := by
+  rcases subdivisionSquare_boundary_cases u hu with h | h | h | h
+  · exact p.property _ ⟨0, Or.inl (by simp [subdivisionWarpMap, h])⟩
+  · exact p.property _ ⟨0, Or.inr (by simp [subdivisionWarpMap, h])⟩
+  · exact p.property _ ⟨1, Or.inl (by simp [subdivisionWarpMap, h])⟩
+  · exact p.property _ ⟨1, Or.inr (by simp [subdivisionWarpMap, h])⟩
+
+private def
+    SecondHurewicz.SimplyConnected.subdivisionWarpLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 2) X x) : GenLoop (Fin 2) X x :=
+  subdivisionPullbackLoop p subdivisionWarpMap (subdivisionWarpMap_based p)
+
+private def SecondHurewicz.SimplyConnected.subdivisionWarpHomotopy {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 2) X x) (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    p.val.HomotopyRel (subdivisionWarpLoop p).val (Cube.boundary (Fin 2)) :=
+  subdivisionLinearHomotopy p hd (ContinuousMap.id _) subdivisionWarpMap p.property
+    (subdivisionWarpMap_based p) subdivisionWarpMap_sides
+
+private theorem SecondHurewicz.SimplyConnected.subdivisionWarpLoop_eq_transAt {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    subdivisionWarpLoop p =
+      GenLoop.transAt (1 : Fin 2) (subdivisionLowerProductLoop p hd)
+        (subdivisionUpperProductLoop p hd) := by
+  apply GenLoop.ext
+  intro u
+  change
+    p ![u 0, subdivisionWarpCoordinate (u 0, u 1)] =
+      if (u 1 : ℝ) ≤ 1 / 2 then
+        subdivisionLowerProductLoop p hd
+          (Function.update u 1 (Set.projIcc 0 1 zero_le_one (2 * (u 1 : ℝ))))
+      else
+        subdivisionUpperProductLoop p hd
+          (Function.update u 1 (Set.projIcc 0 1 zero_le_one (2 * (u 1 : ℝ) - 1)))
+  split_ifs with h
+  · simpa [subdivisionLowerProductLoop, subdivisionPullbackLoop, subdivisionLowerProductMap] using
+      congrArg (fun v : (unitInterval) => p ![u 0, v])
+        (subdivisionWarpCoordinate_of_le_half (u 0) (u 1) h)
+  · simpa [subdivisionUpperProductLoop, subdivisionPullbackLoop, subdivisionUpperProductMap] using
+      congrArg (fun v : (unitInterval) => p ![u 0, v])
+        (subdivisionWarpCoordinate_of_half_lt (u 0) (u 1) (lt_of_not_ge h))
+
+private theorem
+    SecondHurewicz.SimplyConnected.subdivision_homotopic {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 2) X x) (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    GenLoop.Homotopic p
+      (GenLoop.transAt (1 : Fin 2) (subdivisionLowerTriangleLoop p hd)
+        (subdivisionUpperTriangleLoop p hd)) := by
+  have hw : GenLoop.Homotopic p (subdivisionWarpLoop p) := ⟨subdivisionWarpHomotopy p hd⟩
+  rw [subdivisionWarpLoop_eq_transAt p hd] at hw
+  apply hw.trans
+  apply subdivision_transAt_homotopic
+  · exact ⟨subdivisionLowerTriangleHomotopy p hd⟩
+  · exact ⟨(subdivisionUpperConeHomotopy p hd).trans (subdivisionUpperTriangleHomotopy p hd)⟩
+
+private theorem
+    SecondHurewicz.SimplyConnected.subdivision_class {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 2) X x) (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    (⟦p⟧ : π_ 2 X x) =
+      ((· * ·) : π_ 2 X x → π_ 2 X x → π_ 2 X x) ⟦subdivisionLowerTriangleLoop p hd⟧
+        ⟦subdivisionUpperTriangleLoop p hd⟧ := by
+  have h :
+    (⟦p⟧ : π_ 2 X x) =
+      (⟦GenLoop.transAt (1 : Fin 2) (subdivisionLowerTriangleLoop p hd)
+            (subdivisionUpperTriangleLoop p hd)⟧ :
+        π_ 2 X x) :=
+    Quotient.sound (subdivision_homotopic p hd)
+  exact
+    h.trans
+      ((HomotopyGroup.mul_spec (i := (1 : Fin 2)) (p := subdivisionUpperTriangleLoop p hd) (q :=
+            subdivisionLowerTriangleLoop p hd)).symm.trans
+        (mul_comm _ _))
+
+private theorem
+    SecondHurewicz.SimplyConnected.subdivision_additiveClass {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 2) X x) (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    Additive.ofMul (⟦p⟧ : π_ 2 X x) =
+      ((· + ·) : Additive (π_ 2 X x) → Additive (π_ 2 X x) → Additive (π_ 2 X x))
+        (Additive.ofMul (⟦subdivisionLowerTriangleLoop p hd⟧ : π_ 2 X x))
+        (Additive.ofMul (⟦subdivisionUpperTriangleLoop p hd⟧ : π_ 2 X x)) :=
+  congrArg Additive.ofMul (subdivision_class p hd)
+
+private theorem SecondHurewicz.SimplyConnected.tetrahedronQuadrilateralA_lower
+    (u : Fin 2 → (unitInterval)) :
+    tetrahedronQuadrilateralA (subdivisionLowerTriangleMap u) =
+      FirstHurewicz.simplexFace 2 3 (triangleCubeQuotient u) := by
+  have tetrahedronQuadrilateralA_zero (u : Fin 2 → (unitInterval)) :
+    tetrahedronQuadrilateralA u 0 = 1 - Max.max (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have tetrahedronQuadrilateralA_one (u : Fin 2 → (unitInterval)) :
+    tetrahedronQuadrilateralA u 1 = (u 0 : ℝ) - Min.min (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have tetrahedronQuadrilateralA_two (u : Fin 2 → (unitInterval)) :
+    tetrahedronQuadrilateralA u 2 = Min.min (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have tetrahedronQuadrilateralA_three (u : Fin 2 → (unitInterval)) :
+    tetrahedronQuadrilateralA u 3 = (u 1 : ℝ) - Min.min (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have triangleCubeQuotient_apply (t : Fin 2 → (unitInterval)) :
+    triangleCubeQuotient t = triangleQuotient (t 0, t 1) := rfl
+  apply Subtype.ext
+  funext j
+  change
+    tetrahedronQuadrilateralA ![u 0, Min.min (u 0) (u 1)] j =
+      (FirstHurewicz.simplexFace 2 3 (triangleCubeQuotient u) : Fin 4 → ℝ) j
+  rw [simplexFace_two_three]
+  fin_cases j <;>
+    simp [tetrahedronQuadrilateralA_zero, tetrahedronQuadrilateralA_one,
+      tetrahedronQuadrilateralA_two, tetrahedronQuadrilateralA_three, triangleCubeQuotient_apply]
+
+private theorem SecondHurewicz.SimplyConnected.tetrahedronQuadrilateralA_upper
+    (u : Fin 2 → (unitInterval)) :
+    tetrahedronQuadrilateralA (subdivisionUpperTriangleMap u) =
+      FirstHurewicz.simplexFace 2 1 (triangleCubeQuotient u) := by
+  have tetrahedronQuadrilateralA_zero (u : Fin 2 → (unitInterval)) :
+    tetrahedronQuadrilateralA u 0 = 1 - Max.max (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have tetrahedronQuadrilateralA_one (u : Fin 2 → (unitInterval)) :
+    tetrahedronQuadrilateralA u 1 = (u 0 : ℝ) - Min.min (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have tetrahedronQuadrilateralA_two (u : Fin 2 → (unitInterval)) :
+    tetrahedronQuadrilateralA u 2 = Min.min (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have tetrahedronQuadrilateralA_three (u : Fin 2 → (unitInterval)) :
+    tetrahedronQuadrilateralA u 3 = (u 1 : ℝ) - Min.min (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have triangleCubeQuotient_apply (t : Fin 2 → (unitInterval)) :
+    triangleCubeQuotient t = triangleQuotient (t 0, t 1) := rfl
+  have subdivisionSubMin_coe (u v : (unitInterval)) :
+    (subdivisionSubMin u v : ℝ) = (u : ℝ) - Min.min (u : ℝ) (v : ℝ) := rfl
+  have hm : (u 0 : ℝ) - Min.min (u 0 : ℝ) (u 1 : ℝ) ≤ (u 0 : ℝ) :=
+    sub_le_self _ (le_min (u 0).property.1 (u 1).property.1)
+  apply Subtype.ext
+  funext j
+  change
+    tetrahedronQuadrilateralA ![subdivisionSubMin (u 0) (u 1), u 0] j =
+      (FirstHurewicz.simplexFace 2 1 (triangleCubeQuotient u) : Fin 4 → ℝ) j
+  rw [simplexFace_two_one]
+  fin_cases j <;>
+    simp [tetrahedronQuadrilateralA_zero, tetrahedronQuadrilateralA_one,
+      tetrahedronQuadrilateralA_two, tetrahedronQuadrilateralA_three, triangleCubeQuotient_apply,
+      subdivisionSubMin_coe, min_eq_left hm, max_eq_right hm]
+
+private theorem SecondHurewicz.SimplyConnected.tetrahedronQuarterShift_face_three
+    (s : FirstHurewicz.Simplex 2) :
+    tetrahedronQuarterShift (FirstHurewicz.simplexFace 2 3 s) = FirstHurewicz.simplexFace 2 0 s :=
+  by
+  apply Subtype.ext
+  funext j
+  change
+    tetrahedronQuarterShift (FirstHurewicz.simplexFace 2 3 s) j =
+      (FirstHurewicz.simplexFace 2 0 s : Fin 4 → ℝ) j
+  rw [simplexFace_two_zero]
+  fin_cases j
+  · exact FirstHurewicz.simplexFace_apply_self 2 3 s
+  · exact FirstHurewicz.simplexFace_apply_succAbove 2 3 s 0
+  · exact FirstHurewicz.simplexFace_apply_succAbove 2 3 s 1
+  · exact FirstHurewicz.simplexFace_apply_succAbove 2 3 s 2
+
+private theorem SecondHurewicz.SimplyConnected.tetrahedronQuarterShift_face_one
+    (s : FirstHurewicz.Simplex 2) :
+    tetrahedronQuarterShift (FirstHurewicz.simplexFace 2 1 s) =
+      FirstHurewicz.simplexFace 2 2 (triangleCyclicPermutation (triangleCyclicPermutation s)) := by
+  apply Subtype.ext
+  funext j
+  change
+    tetrahedronQuarterShift (FirstHurewicz.simplexFace 2 1 s) j =
+      (FirstHurewicz.simplexFace 2 2 (triangleCyclicPermutation (triangleCyclicPermutation s)) :
+          Fin 4 → ℝ)
+        j
+  rw [simplexFace_two_two]
+  fin_cases j
+  · exact FirstHurewicz.simplexFace_apply_succAbove 2 1 s 2
+  · exact FirstHurewicz.simplexFace_apply_succAbove 2 1 s 0
+  · exact FirstHurewicz.simplexFace_apply_self 2 1 s
+  · exact FirstHurewicz.simplexFace_apply_succAbove 2 1 s 1
+
+private theorem SecondHurewicz.SimplyConnected.tetrahedronLowerLoop_eq_face {X : Type}
+    [TopologicalSpace X] {x : X} (τ : BasedTetrahedron x) :
+    subdivisionLowerTriangleLoop (tetrahedronQuadrilateralLoop τ)
+        (tetrahedronQuadrilateralLoop_diagonal τ) =
+      basedTriangleLoop (basedTetrahedronFace τ 3) := by
+  apply GenLoop.ext
+  intro u
+  change
+    τ.val (tetrahedronQuadrilateralA (subdivisionLowerTriangleMap u)) =
+      τ.val (FirstHurewicz.simplexFace 2 3 (triangleCubeQuotient u))
+  rw [tetrahedronQuadrilateralA_lower]
+
+private theorem SecondHurewicz.SimplyConnected.tetrahedronUpperLoop_eq_face {X : Type}
+    [TopologicalSpace X] {x : X} (τ : BasedTetrahedron x) :
+    subdivisionUpperTriangleLoop (tetrahedronQuadrilateralLoop τ)
+        (tetrahedronQuadrilateralLoop_diagonal τ) =
+      basedTriangleLoop (basedTetrahedronFace τ 1) := by
+  apply GenLoop.ext
+  intro u
+  change
+    τ.val (tetrahedronQuadrilateralA (subdivisionUpperTriangleMap u)) =
+      τ.val (FirstHurewicz.simplexFace 2 1 (triangleCubeQuotient u))
+  rw [tetrahedronQuadrilateralA_upper]
+
+private theorem SecondHurewicz.SimplyConnected.tetrahedronShiftedLowerLoop_eq_face {X : Type}
+    [TopologicalSpace X] {x : X} (τ : BasedTetrahedron x) :
+    subdivisionLowerTriangleLoop (tetrahedronShiftedQuadrilateralLoop τ)
+        (tetrahedronShiftedQuadrilateralLoop_diagonal τ) =
+      basedTriangleLoop (basedTetrahedronFace τ 0) := by
+  apply GenLoop.ext
+  intro u
+  change
+    τ.val (tetrahedronQuarterShift (tetrahedronQuadrilateralA (subdivisionLowerTriangleMap u))) =
+      τ.val (FirstHurewicz.simplexFace 2 0 (triangleCubeQuotient u))
+  rw [tetrahedronQuadrilateralA_lower, tetrahedronQuarterShift_face_three]
+
+private theorem SecondHurewicz.SimplyConnected.tetrahedronShiftedUpperLoop_eq_face {X : Type}
+    [TopologicalSpace X] {x : X} (τ : BasedTetrahedron x) :
+    subdivisionUpperTriangleLoop (tetrahedronShiftedQuadrilateralLoop τ)
+        (tetrahedronShiftedQuadrilateralLoop_diagonal τ) =
+      basedTriangleLoop (cyclicBasedTriangle (cyclicBasedTriangle (basedTetrahedronFace τ 2))) := by
+  apply GenLoop.ext
+  intro u
+  change
+    τ.val (tetrahedronQuarterShift (tetrahedronQuadrilateralA (subdivisionUpperTriangleMap u))) =
+      τ.val
+        (FirstHurewicz.simplexFace 2 2
+          (triangleCyclicPermutation (triangleCyclicPermutation (triangleCubeQuotient u))))
+  rw [tetrahedronQuadrilateralA_upper, tetrahedronQuarterShift_face_one]
+
+private theorem SecondHurewicz.SimplyConnected.basedTetrahedron_pair_relation {X : Type}
+    [TopologicalSpace X] {x : X} (τ : BasedTetrahedron x) :
+    basedTriangleClass (basedTetrahedronFace τ 3) +
+        basedTriangleClass (basedTetrahedronFace τ 1) =
+      basedTriangleClass (basedTetrahedronFace τ 0) +
+        basedTriangleClass (basedTetrahedronFace τ 2) := by
+  have hA :=
+    subdivision_additiveClass (tetrahedronQuadrilateralLoop τ)
+      (tetrahedronQuadrilateralLoop_diagonal τ)
+  rw [tetrahedronLowerLoop_eq_face, tetrahedronUpperLoop_eq_face] at hA
+  have hB :=
+    subdivision_additiveClass (tetrahedronShiftedQuadrilateralLoop τ)
+      (tetrahedronShiftedQuadrilateralLoop_diagonal τ)
+  rw [tetrahedronShiftedLowerLoop_eq_face, tetrahedronShiftedUpperLoop_eq_face] at hB
+  change
+    Additive.ofMul (⟦tetrahedronShiftedQuadrilateralLoop τ⟧ : π_ 2 X x) =
+      basedTriangleClass (basedTetrahedronFace τ 0) +
+        basedTriangleClass
+          (cyclicBasedTriangle (cyclicBasedTriangle (basedTetrahedronFace τ 2))) at hB
+  simp only [basedTriangleClass_cyclic] at hB
+  exact hA.symm.trans ((congrArg Additive.ofMul (tetrahedronFillings_class τ)).trans hB)
+
+private theorem SecondHurewicz.SimplyConnected.basedTetrahedron_boundary_relation {X : Type}
+    [TopologicalSpace X] {x : X} (τ : BasedTetrahedron x) :
+    basedTriangleClass (basedTetrahedronFace τ 0) -
+            basedTriangleClass (basedTetrahedronFace τ 1) +
+          basedTriangleClass (basedTetrahedronFace τ 2) -
+        basedTriangleClass (basedTetrahedronFace τ 3) =
+      0 := by
+  calc
+    _ =
+        (basedTriangleClass (basedTetrahedronFace τ 0) +
+            basedTriangleClass (basedTetrahedronFace τ 2)) -
+          (basedTriangleClass (basedTetrahedronFace τ 3) +
+            basedTriangleClass (basedTetrahedronFace τ 1)) := by abel
+    _ = 0 := sub_eq_zero.mpr (basedTetrahedron_pair_relation τ).symm
+
+private theorem SecondHurewicz.SimplyConnected.basedTetrahedron_signed_relation {X : Type}
+    [TopologicalSpace X] {x : X} (τ : BasedTetrahedron x) :
+    ∑ i : Fin 4, (-1 : ℤ) ^ i.val • basedTriangleClass (basedTetrahedronFace τ i) = 0 := by
+  have h := basedTetrahedron_boundary_relation τ
+  simpa [Fin.sum_univ_succ, sub_eq_add_neg, add_assoc] using h
+
+private def SecondHurewicz.SimplyConnected.normalizedTetrahedron {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (smp : FirstHurewicz.SingularSimplex X 3) :
+    BasedTetrahedron x :=
+  BasedTetrahedron.ofFaces (normalizedTetrahedronMap x smp)
+    (normalizedTetrahedronMap_face_boundary x smp)
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.normalizedTetrahedron_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (smp : FirstHurewicz.SingularSimplex X 3) (i : Fin 4) :
+    basedTetrahedronFace (normalizedTetrahedron x smp) i =
+      normalizedTriangle x (smp.comp (FirstHurewicz.simplexFace 2 i)) := by
+  apply Subtype.ext
+  exact normalizedTetrahedronMap_face x smp i
+
+private theorem SecondHurewicz.SimplyConnected.normalizedTriangle_boundary_relation {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X)
+    (smp : FirstHurewicz.SingularSimplex X 3) :
+    ∑ i : Fin 4,
+        (-1 : ℤ) ^ i.val •
+          basedTriangleClass (normalizedTriangle x (smp.comp (FirstHurewicz.simplexFace 2 i))) =
+      0 := by
+  simpa only [normalizedTetrahedron_face] using
+    basedTetrahedron_signed_relation (normalizedTetrahedron x smp)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SecondHurewicz.SimplyConnected.squareAffineTriangle (v : Fin 3 → Fin 2 × Fin 2) :
+    C(FirstHurewicz.Simplex 2, (unitInterval) × (unitInterval)) :=
+  ((FirstHurewicz.pathSimplex Path.id).prodMap (FirstHurewicz.pathSimplex Path.id)).comp
+    (PeriodTorusHigherHomology.productAffineSimplex
+      (fun i =>
+        (SingularMayerVietoris.stdVertices 1 (v i).1,
+          SingularMayerVietoris.stdVertices 1 (v i).2)))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    SecondHurewicz.SimplyConnected.squareAffineTriangle_fst_coe (v : Fin 3 → Fin 2 × Fin 2)
+    (s : FirstHurewicz.Simplex 2) :
+    ((squareAffineTriangle v s).1 : ℝ) =
+      ∑ i, s i * SingularMayerVietoris.stdVertices 1 (v i).1 1 := by
+  change
+    SingularMayerVietoris.affineSimplex (fun i => SingularMayerVietoris.stdVertices 1 (v i).1) s
+        1 =
+      _
+  exact SingularMayerVietoris.affineSimplex_coordinate _ _ _
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    SecondHurewicz.SimplyConnected.squareAffineTriangle_snd_coe (v : Fin 3 → Fin 2 × Fin 2)
+    (s : FirstHurewicz.Simplex 2) :
+    ((squareAffineTriangle v s).2 : ℝ) =
+      ∑ i, s i * SingularMayerVietoris.stdVertices 1 (v i).2 1 := by
+  change
+    SingularMayerVietoris.affineSimplex (fun i => SingularMayerVietoris.stdVertices 1 (v i).2) s
+        1 =
+      _
+  exact SingularMayerVietoris.affineSimplex_coordinate _ _ _
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SecondHurewicz.SimplyConnected.lowerProductTriangle :
+    C(FirstHurewicz.Simplex 2, (unitInterval) × (unitInterval)) :=
+  squareAffineTriangle ![(0, 0), (1, 0), (1, 1)]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SecondHurewicz.SimplyConnected.upperProductTriangle :
+    C(FirstHurewicz.Simplex 2, (unitInterval) × (unitInterval)) :=
+  squareAffineTriangle ![(0, 0), (0, 1), (1, 1)]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SecondHurewicz.SimplyConnected.leftProductDegenerate :
+    C(FirstHurewicz.Simplex 2, (unitInterval) × (unitInterval)) :=
+  squareAffineTriangle ![(0, 0), (0, 0), (0, 1)]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SecondHurewicz.SimplyConnected.bottomProductDegenerate :
+    C(FirstHurewicz.Simplex 2, (unitInterval) × (unitInterval)) :=
+  squareAffineTriangle ![(0, 0), (0, 0), (1, 0)]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.lowerProductTriangle_fst (s : FirstHurewicz.Simplex 2) :
+    ((lowerProductTriangle s).1 : ℝ) = s 1 + s 2 := by
+  simp [lowerProductTriangle, squareAffineTriangle_fst_coe, SingularMayerVietoris.stdVertices,
+    stdSimplex.vertex, Fin.sum_univ_succ, Pi.single_apply]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.lowerProductTriangle_snd (s : FirstHurewicz.Simplex 2) :
+    ((lowerProductTriangle s).2 : ℝ) = s 2 := by
+  simp [lowerProductTriangle, squareAffineTriangle_snd_coe, SingularMayerVietoris.stdVertices,
+    stdSimplex.vertex, Fin.sum_univ_succ, Pi.single_apply]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.upperProductTriangle_fst (s : FirstHurewicz.Simplex 2) :
+    ((upperProductTriangle s).1 : ℝ) = s 2 := by
+  simp [upperProductTriangle, squareAffineTriangle_fst_coe, SingularMayerVietoris.stdVertices,
+    stdSimplex.vertex, Fin.sum_univ_succ, Pi.single_apply]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.upperProductTriangle_snd (s : FirstHurewicz.Simplex 2) :
+    ((upperProductTriangle s).2 : ℝ) = s 1 + s 2 := by
+  simp [upperProductTriangle, squareAffineTriangle_snd_coe, SingularMayerVietoris.stdVertices,
+    stdSimplex.vertex, Fin.sum_univ_succ, Pi.single_apply]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.leftProductDegenerate_fst (s : FirstHurewicz.Simplex 2) :
+    (leftProductDegenerate s).1 = 0 := by
+  apply Subtype.ext
+  simp [leftProductDegenerate, squareAffineTriangle_fst_coe, SingularMayerVietoris.stdVertices,
+    stdSimplex.vertex, Fin.sum_univ_succ, Pi.single_apply]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.bottomProductDegenerate_snd (s : FirstHurewicz.Simplex 2) :
+    (bottomProductDegenerate s).2 = 0 := by
+  apply Subtype.ext
+  simp [bottomProductDegenerate, squareAffineTriangle_snd_coe, SingularMayerVietoris.stdVertices,
+    stdSimplex.vertex, Fin.sum_univ_succ, Pi.single_apply]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SecondHurewicz.SimplyConnected.lowerSquareTriangle :
+    C(FirstHurewicz.Simplex 2, Fin 2 → (unitInterval)) :=
+  SecondHurewicz.squareCoordinates.comp lowerProductTriangle
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SecondHurewicz.SimplyConnected.upperSquareTriangle :
+    C(FirstHurewicz.Simplex 2, Fin 2 → (unitInterval)) :=
+  SecondHurewicz.squareCoordinates.comp upperProductTriangle
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.lowerSquareTriangle_zero (s : FirstHurewicz.Simplex 2) :
+    (lowerSquareTriangle s 0 : ℝ) = s 1 + s 2 := by simp [lowerSquareTriangle]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.lowerSquareTriangle_one (s : FirstHurewicz.Simplex 2) :
+    (lowerSquareTriangle s 1 : ℝ) = s 2 := by simp [lowerSquareTriangle]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.upperSquareTriangle_zero (s : FirstHurewicz.Simplex 2) :
+    (upperSquareTriangle s 0 : ℝ) = s 2 := by simp [upperSquareTriangle]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.upperSquareTriangle_one (s : FirstHurewicz.Simplex 2) :
+    (upperSquareTriangle s 1 : ℝ) = s 1 + s 2 := by simp [upperSquareTriangle]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SecondHurewicz.SimplyConnected.productSquareChain_four_triangles :
+    SecondHurewicz.productSquareChain =
+      FirstHurewicz.simplexChain ((unitInterval) × (unitInterval)) 2 lowerProductTriangle -
+            FirstHurewicz.simplexChain ((unitInterval) × (unitInterval)) 2 leftProductDegenerate -
+          FirstHurewicz.simplexChain ((unitInterval) × (unitInterval)) 2 upperProductTriangle +
+        FirstHurewicz.simplexChain ((unitInterval) × (unitInterval)) 2 bottomProductDegenerate := by
+  rw [SecondHurewicz.productSquareChain, SecondHurewicz.intervalChain, FirstHurewicz.pathChain,
+    PeriodTorusHigherHomology.crossProductEdge_simplex,
+    PeriodTorusHigherHomology.formalEdgeCrossProduct_simplex_succ,
+    PeriodTorusHigherHomology.formalPointCrossProduct_edge_boundary,
+    PeriodTorusHigherHomology.formalBoundary_edge_simplex]
+  simp only [map_sub, PeriodTorusHigherHomology.formalEdgeCrossProduct_zero_simplex_right,
+    SingularMayerVietoris.formalMap_simplex, SingularMayerVietoris.formalCone_simplex,
+    PeriodTorusHigherHomology.productAffineChainMap_simplex, FirstHurewicz.inducedChain_simplex]
+  change
+    (FirstHurewicz.simplexChain ((unitInterval) × (unitInterval)) 2 lowerProductTriangle -
+          FirstHurewicz.simplexChain ((unitInterval) × (unitInterval)) 2 leftProductDegenerate) -
+        (FirstHurewicz.simplexChain ((unitInterval) × (unitInterval)) 2 upperProductTriangle -
+          FirstHurewicz.simplexChain ((unitInterval) × (unitInterval)) 2
+            bottomProductDegenerate) =
+      _
+  abel
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SecondHurewicz.SimplyConnected.squareMap_leftProductDegenerate {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x) :
+    (SecondHurewicz.squareMap p).comp leftProductDegenerate =
+      ContinuousMap.const (FirstHurewicz.Simplex 2) x := by
+  ext s
+  apply GenLoop.boundary p
+  refine ⟨0, Or.inl ?_⟩
+  rw [SecondHurewicz.squareCoordinates_zero, leftProductDegenerate_fst]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SecondHurewicz.SimplyConnected.squareMap_bottomProductDegenerate {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x) :
+    (SecondHurewicz.squareMap p).comp bottomProductDegenerate =
+      ContinuousMap.const (FirstHurewicz.Simplex 2) x := by
+  ext s
+  apply GenLoop.boundary p
+  refine ⟨1, Or.inl ?_⟩
+  rw [SecondHurewicz.squareCoordinates_one, bottomProductDegenerate_snd]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    SecondHurewicz.SimplyConnected.squareChain_two_triangles {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 2) X x) :
+    SecondHurewicz.squareChain p =
+      FirstHurewicz.simplexChain X 2 (p.val.comp lowerSquareTriangle) -
+        FirstHurewicz.simplexChain X 2 (p.val.comp upperSquareTriangle) := by
+  rw [SecondHurewicz.squareChain, SecondHurewicz.suspensionOne_toLoop,
+    productSquareChain_four_triangles]
+  simp only [map_add, map_sub, FirstHurewicz.inducedChain_simplex,
+    squareMap_leftProductDegenerate, squareMap_bottomProductDegenerate]
+  change
+    (FirstHurewicz.simplexChain X 2 (p.val.comp lowerSquareTriangle) -
+            FirstHurewicz.simplexChain X 2 (ContinuousMap.const (FirstHurewicz.Simplex 2) x)) -
+          FirstHurewicz.simplexChain X 2 (p.val.comp upperSquareTriangle) +
+        FirstHurewicz.simplexChain X 2 (ContinuousMap.const (FirstHurewicz.Simplex 2) x) =
+      _
+  abel
+
+private theorem SecondHurewicz.SimplyConnected.triangleQuotient_lowerProductTriangle :
+    triangleQuotient.comp lowerProductTriangle = ContinuousMap.id (FirstHurewicz.Simplex 2) := by
+  apply ContinuousMap.ext
+  intro s
+  apply Subtype.ext
+  funext i
+  have hs := stdSimplex.sum_eq_one s
+  simp only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero] at hs
+  change s 0 + (s 1 + s 2) = 1 at hs
+  have hle : s 2 ≤ s 1 + s 2 := le_add_of_nonneg_left (stdSimplex.zero_le s 1)
+  fin_cases i
+  · change 1 - ((lowerProductTriangle s).1 : ℝ) = s 0
+    rw [lowerProductTriangle_fst]
+    linarith
+  · change
+      ((lowerProductTriangle s).1 : ℝ) -
+          Min.min ((lowerProductTriangle s).1 : ℝ) ((lowerProductTriangle s).2 : ℝ) =
+        s 1
+    rw [lowerProductTriangle_fst, lowerProductTriangle_snd, min_eq_right hle]
+    ring
+  · change Min.min ((lowerProductTriangle s).1 : ℝ) ((lowerProductTriangle s).2 : ℝ) = s 2
+    rw [lowerProductTriangle_fst, lowerProductTriangle_snd, min_eq_right hle]
+
+private theorem SecondHurewicz.SimplyConnected.triangleQuotient_upperProductTriangle_boundary
+    (s : FirstHurewicz.Simplex 2) :
+    triangleQuotient (upperProductTriangle s) ∈ triangleBoundary := by
+  refine ⟨1, ?_⟩
+  rw [triangleQuotient_one, upperProductTriangle_fst, upperProductTriangle_snd,
+    min_eq_left (le_add_of_nonneg_left (stdSimplex.zero_le s 1)), sub_self]
+
+private theorem
+    SecondHurewicz.SimplyConnected.basedTriangleLoop_lower {X : Type} [TopologicalSpace X]
+    {x : X} (τ : BasedTriangle x) : (basedTriangleLoop τ).val.comp lowerSquareTriangle = τ.val := by
+  change (SecondHurewicz.squareMap (basedTriangleLoop τ)).comp lowerProductTriangle = _
+  rw [squareMap_basedTriangleLoop, ContinuousMap.comp_assoc,
+    triangleQuotient_lowerProductTriangle, ContinuousMap.comp_id]
+
+private theorem
+    SecondHurewicz.SimplyConnected.basedTriangleLoop_upper {X : Type} [TopologicalSpace X]
+    {x : X} (τ : BasedTriangle x) :
+    (basedTriangleLoop τ).val.comp upperSquareTriangle =
+      ContinuousMap.const (FirstHurewicz.Simplex 2) x := by
+  change (SecondHurewicz.squareMap (basedTriangleLoop τ)).comp upperProductTriangle = _
+  rw [squareMap_basedTriangleLoop]
+  ext s
+  exact τ.property _ (triangleQuotient_upperProductTriangle_boundary s)
+
+private theorem SecondHurewicz.SimplyConnected.squareChain_basedTriangleLoop {X : Type}
+    [TopologicalSpace X] {x : X} (τ : BasedTriangle x) :
+    SecondHurewicz.squareChain (basedTriangleLoop τ) =
+      FirstHurewicz.simplexChain X 2 τ.val -
+        FirstHurewicz.simplexChain X 2 (ContinuousMap.const (FirstHurewicz.Simplex 2) x) := by
+  rw [squareChain_two_triangles, basedTriangleLoop_lower, basedTriangleLoop_upper]
+
+private def
+    SecondHurewicz.SimplyConnected.basedTriangleCycle {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedTriangle x) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2 :=
+  SingularMayerVietoris.ModuleHomology.mkCycle (FirstHurewicz.singularComplex X) 2
+    (FirstHurewicz.simplexChain X 2 τ.val -
+      FirstHurewicz.simplexChain X 2 (ContinuousMap.const (FirstHurewicz.Simplex 2) x))
+    (by
+      rw [← squareChain_basedTriangleLoop]
+      exact SecondHurewicz.squareChain_boundary (basedTriangleLoop τ))
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.basedTriangleCycle_val {X : Type} [TopologicalSpace X]
+    {x : X} (τ : BasedTriangle x) :
+    (basedTriangleCycle τ).val =
+      FirstHurewicz.simplexChain X 2 τ.val -
+        FirstHurewicz.simplexChain X 2 (ContinuousMap.const (FirstHurewicz.Simplex 2) x) :=
+  rfl
+
+private theorem
+    SecondHurewicz.SimplyConnected.hurewicz_basedTriangleClass {X : Type} [TopologicalSpace X]
+    {x : X} (τ : BasedTriangle x) :
+    SecondHurewicz.hurewiczMap x (basedTriangleClass τ) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 2
+        (basedTriangleCycle τ) := by
+  change
+    SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 2
+        (SecondHurewicz.squareCycle (basedTriangleLoop τ)) =
+      _
+  congr 1
+  apply Subtype.ext
+  exact squareChain_basedTriangleLoop τ
+
+private def
+    SecondHurewicz.SimplyConnected.secondHomologyDesc {X : Type} [TopologicalSpace X] {M : Type*}
+    [AddCommGroup M] [Module ℤ M] (F : FirstHurewicz.Chains X 2 →ₗ[ℤ] M)
+    (hF :
+      ∀ b : FirstHurewicz.Chains X 3, F (((FirstHurewicz.singularComplex X).d 3 2).hom b) = 0) :
+    SingularMayerVietoris.SingularHomology X 2 →ₗ[ℤ] M :=
+  PeriodTorusHigherHomology.homologyDesc (FirstHurewicz.singularComplex X) 2
+    (F.comp
+      (SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2).subtype)
+    (fun b => hF b)
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.secondHomologyDesc_cycleClass {X : Type}
+    [TopologicalSpace X] {M : Type*} [AddCommGroup M] [Module ℤ M]
+    (F : FirstHurewicz.Chains X 2 →ₗ[ℤ] M)
+    (hF : ∀ b : FirstHurewicz.Chains X 3, F (((FirstHurewicz.singularComplex X).d 3 2).hom b) = 0)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2) :
+    secondHomologyDesc F hF
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 2 c) =
+      F c.1 :=
+  PeriodTorusHigherHomology.homologyDesc_cycleClass (FirstHurewicz.singularComplex X) 2 _ _ c
+
+private theorem SecondHurewicz.SimplyConnected.comp_secondHomologyDesc_eq_id {X : Type}
+    [TopologicalSpace X] {M : Type*} [AddCommGroup M] [Module ℤ M]
+    (F : FirstHurewicz.Chains X 2 →ₗ[ℤ] M)
+    (hF : ∀ b : FirstHurewicz.Chains X 3, F (((FirstHurewicz.singularComplex X).d 3 2).hom b) = 0)
+    (g : M →ₗ[ℤ] SingularMayerVietoris.SingularHomology X 2)
+    (hg :
+      ∀ c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2,
+        g (F c.1) =
+          SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 2 c) :
+    g.comp (secondHomologyDesc F hF) = LinearMap.id := by
+  apply PeriodTorusHigherHomology.homologyLinearMap_ext (FirstHurewicz.singularComplex X) 2
+  intro c
+  simpa only [LinearMap.comp_apply, secondHomologyDesc_cycleClass, LinearMap.id_apply] using hg c
+
+private def
+    SecondHurewicz.SimplyConnected.chainAugmentation (X : Type) [TopologicalSpace X] (n : ℕ) :
+    FirstHurewicz.Chains X n →ₗ[ℤ] ℤ :=
+  FirstHurewicz.chainLift X n fun _ => 1
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.chainAugmentation_simplex (X : Type) [TopologicalSpace X]
+    (n : ℕ) (smp : FirstHurewicz.SingularSimplex X n) :
+    chainAugmentation X n (FirstHurewicz.simplexChain X n smp) = 1 :=
+  FirstHurewicz.chainLift_simplex X n _ smp
+
+private theorem SecondHurewicz.SimplyConnected.chainAugmentation_boundaryTwo (X : Type)
+    [TopologicalSpace X] (c : FirstHurewicz.Chains X 2) :
+    chainAugmentation X 1 (FirstHurewicz.boundaryTwo X c) = chainAugmentation X 2 c := by
+  have h : (chainAugmentation X 1).comp (FirstHurewicz.boundaryTwo X) = chainAugmentation X 2 := by
+    apply FirstHurewicz.chainMap_ext X 2
+    intro smp
+    simp only [LinearMap.comp_apply, FirstHurewicz.boundaryTwo_simplex, map_add, map_sub,
+      chainAugmentation_simplex, sub_self, zero_add]
+  exact LinearMap.congr_fun h c
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.chainAugmentation_twoCycle (X : Type) [TopologicalSpace X]
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2) :
+    chainAugmentation X 2 c.1 = 0 := by
+  rw [← chainAugmentation_boundaryTwo]
+  have hc :=
+    SingularMayerVietoris.ModuleHomology.cycle_condition (FirstHurewicz.singularComplex X) 2 c
+  change FirstHurewicz.boundaryTwo X c.1 = 0 at hc
+  rw [hc, map_zero]
+
+private theorem
+    SecondHurewicz.SimplyConnected.chainLift_sub_constant (X : Type) [TopologicalSpace X]
+    {M : Type} [AddCommGroup M] [Module ℤ M] (n : ℕ) (f : FirstHurewicz.SingularSimplex X n → M)
+    (m : M) (c : FirstHurewicz.Chains X n) :
+    FirstHurewicz.chainLift X n (fun smp => f smp - m) c =
+      FirstHurewicz.chainLift X n f c - chainAugmentation X n c • m := by
+  have h :
+    FirstHurewicz.chainLift X n (fun smp => f smp - m) =
+      FirstHurewicz.chainLift X n f -
+        (LinearMap.toSpanSingleton ℤ M m).comp (chainAugmentation X n) := by
+    apply FirstHurewicz.chainMap_ext X n
+    intro smp
+    simp only [FirstHurewicz.chainLift_simplex, LinearMap.sub_apply, LinearMap.comp_apply,
+      chainAugmentation_simplex, LinearMap.toSpanSingleton_apply_one]
+  exact
+    (LinearMap.congr_fun h c).trans
+      (congrArg (fun z : M => FirstHurewicz.chainLift X n f c - z)
+        (int_smul_eq_zsmul (inferInstance : Module ℤ M) (chainAugmentation X n c) m))
+
+private theorem SecondHurewicz.SimplyConnected.chainLift_sub_constant_twoCycle (X : Type)
+    [TopologicalSpace X] {M : Type} [AddCommGroup M] [Module ℤ M]
+    (f : FirstHurewicz.SingularSimplex X 2 → M) (m : M)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2) :
+    FirstHurewicz.chainLift X 2 (fun smp => f smp - m) c.1 = FirstHurewicz.chainLift X 2 f c.1 := by
+  rw [chainLift_sub_constant, chainAugmentation_twoCycle, zero_smul, sub_zero]
+
+private def SecondHurewicz.SimplyConnected.triangleClassOperator {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) : FirstHurewicz.Chains X 2 →ₗ[ℤ] Additive (π_ 2 X x) :=
+  FirstHurewicz.chainLift X 2 fun smp => basedTriangleClass (normalizedTriangle x smp)
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.triangleClassOperator_simplex {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X)
+    (smp : FirstHurewicz.SingularSimplex X 2) :
+    triangleClassOperator x (FirstHurewicz.simplexChain X 2 smp) =
+      basedTriangleClass (normalizedTriangle x smp) :=
+  FirstHurewicz.chainLift_simplex X 2 _ smp
+
+private theorem SecondHurewicz.SimplyConnected.triangleClassOperator_boundary {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) (b : FirstHurewicz.Chains X 3) :
+    triangleClassOperator x (((FirstHurewicz.singularComplex X).d 3 2).hom b) = 0 := by
+  have h : (triangleClassOperator x).comp ((FirstHurewicz.singularComplex X).d 3 2).hom = 0 := by
+    apply FirstHurewicz.chainMap_ext X 3
+    intro smp
+    simp only [LinearMap.comp_apply, FirstHurewicz.boundary_simplex, map_sum, map_zsmul,
+      triangleClassOperator_simplex, LinearMap.zero_apply]
+    exact normalizedTriangle_boundary_relation x smp
+  exact LinearMap.congr_fun h b
+
+private def
+    SecondHurewicz.SimplyConnected.normalizedTriangleCycleOperator {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) :
+    FirstHurewicz.Chains X 2 →ₗ[ℤ]
+      SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2 :=
+  FirstHurewicz.chainLift X 2 fun smp => basedTriangleCycle (normalizedTriangle x smp)
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.normalizedTriangleCycleOperator_simplex {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X)
+    (smp : FirstHurewicz.SingularSimplex X 2) :
+    normalizedTriangleCycleOperator x (FirstHurewicz.simplexChain X 2 smp) =
+      basedTriangleCycle (normalizedTriangle x smp) :=
+  FirstHurewicz.chainLift_simplex X 2 _ smp
+
+private theorem SecondHurewicz.SimplyConnected.normalizedTriangleCycleOperator_val {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) (c : FirstHurewicz.Chains X 2) :
+    (normalizedTriangleCycleOperator x c).val =
+      FirstHurewicz.chainLift X 2
+        (fun smp =>
+          FirstHurewicz.simplexChain X 2 (normalizedTriangle x smp).val -
+            FirstHurewicz.simplexChain X 2 (ContinuousMap.const (FirstHurewicz.Simplex 2) x))
+        c := by
+  have h :
+    (SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2).subtype.comp
+        (normalizedTriangleCycleOperator x) =
+      FirstHurewicz.chainLift X 2
+        (fun smp =>
+          FirstHurewicz.simplexChain X 2 (normalizedTriangle x smp).val -
+            FirstHurewicz.simplexChain X 2 (ContinuousMap.const (FirstHurewicz.Simplex 2) x)) := by
+    apply FirstHurewicz.chainMap_ext X 2
+    intro smp
+    simp only [LinearMap.comp_apply, normalizedTriangleCycleOperator_simplex,
+      Submodule.subtype_apply, basedTriangleCycle_val, FirstHurewicz.chainLift_simplex]
+  exact LinearMap.congr_fun h c
+
+private theorem SecondHurewicz.SimplyConnected.normalizedTriangleCycleOperator_twoCycle {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2) :
+    normalizedTriangleCycleOperator x c.val = normalizedTwoCycle x c := by
+  apply Subtype.ext
+  rw [normalizedTriangleCycleOperator_val, chainLift_sub_constant_twoCycle,
+    normalizedTwoCycle_val]
+  rfl
+
+private theorem SecondHurewicz.SimplyConnected.hurewiczMap_comp_triangleClassOperator {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) :
+    (SecondHurewicz.hurewiczMap x).comp (triangleClassOperator x) =
+      (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 2).comp
+        (normalizedTriangleCycleOperator x) := by
+  apply FirstHurewicz.chainMap_ext X 2
+  intro smp
+  simp only [LinearMap.comp_apply, triangleClassOperator_simplex,
+    normalizedTriangleCycleOperator_simplex]
+  exact hurewicz_basedTriangleClass (normalizedTriangle x smp)
+
+private theorem SecondHurewicz.SimplyConnected.hurewiczMap_triangleClassOperator_twoCycle {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2) :
+    SecondHurewicz.hurewiczMap x (triangleClassOperator x c.val) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 2 c := by
+  have h := LinearMap.congr_fun (hurewiczMap_comp_triangleClassOperator x) c.val
+  change
+    SecondHurewicz.hurewiczMap x (triangleClassOperator x c.val) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 2
+        (normalizedTriangleCycleOperator x c.val) at h
+  rw [normalizedTriangleCycleOperator_twoCycle] at h
+  exact h.trans (normalizedTwoCycle_class x c)
+
+private def SecondHurewicz.SimplyConnected.hurewiczInverse {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) :
+    SingularMayerVietoris.SingularHomology X 2 →ₗ[ℤ] Additive (π_ 2 X x) :=
+  secondHomologyDesc (triangleClassOperator x) (triangleClassOperator_boundary x)
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.hurewiczInverse_cycleClass {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2) :
+    hurewiczInverse x
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 2 c) =
+      triangleClassOperator x c.val :=
+  secondHomologyDesc_cycleClass _ _ c
+
+private theorem SecondHurewicz.SimplyConnected.hurewiczMap_comp_hurewiczInverse {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) :
+    (SecondHurewicz.hurewiczMap x).comp (hurewiczInverse x) = LinearMap.id :=
+  comp_secondHomologyDesc_eq_id (triangleClassOperator x) (triangleClassOperator_boundary x)
+    (SecondHurewicz.hurewiczMap x) (hurewiczMap_triangleClassOperator_twoCycle x)
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.hurewiczMap_hurewiczInverse {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (c : SingularMayerVietoris.SingularHomology X 2) :
+    SecondHurewicz.hurewiczMap x (hurewiczInverse x c) = c :=
+  LinearMap.congr_fun (hurewiczMap_comp_hurewiczInverse x) c
+
+private theorem SecondHurewicz.SimplyConnected.lowerSquareTriangle_verticesBased {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x) :
+    VerticesBased x 2 (p.val.comp lowerSquareTriangle) := by
+  intro i
+  change p (lowerSquareTriangle (stdSimplex.vertex (S := ℝ) i)) = x
+  apply GenLoop.boundary p
+  refine ⟨1, ?_⟩
+  by_cases hi : i = 2
+  · right
+    apply Subtype.ext
+    change (lowerSquareTriangle (stdSimplex.vertex (S := ℝ) i) 1 : ℝ) = 1
+    simp [hi, stdSimplex.vertex]
+  · left
+    apply Subtype.ext
+    change (lowerSquareTriangle (stdSimplex.vertex (S := ℝ) i) 1 : ℝ) = 0
+    simp [hi, stdSimplex.vertex]
+
+private theorem SecondHurewicz.SimplyConnected.upperSquareTriangle_verticesBased {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x) :
+    VerticesBased x 2 (p.val.comp upperSquareTriangle) := by
+  intro i
+  change p (upperSquareTriangle (stdSimplex.vertex (S := ℝ) i)) = x
+  apply GenLoop.boundary p
+  refine ⟨0, ?_⟩
+  by_cases hi : i = 2
+  · right
+    apply Subtype.ext
+    change (upperSquareTriangle (stdSimplex.vertex (S := ℝ) i) 0 : ℝ) = 1
+    simp [hi, stdSimplex.vertex]
+  · left
+    apply Subtype.ext
+    change (upperSquareTriangle (stdSimplex.vertex (S := ℝ) i) 0 : ℝ) = 0
+    simp [hi, stdSimplex.vertex]
+
+private theorem
+    SecondHurewicz.SimplyConnected.squareTriangles_diagonal {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 2) X x) :
+    (p.val.comp lowerSquareTriangle).comp (FirstHurewicz.simplexFace 1 1) =
+      (p.val.comp upperSquareTriangle).comp (FirstHurewicz.simplexFace 1 1) := by
+  apply ContinuousMap.ext
+  intro s
+  change
+    p.val (lowerSquareTriangle (FirstHurewicz.simplexFace 1 1 s)) =
+      p.val (upperSquareTriangle (FirstHurewicz.simplexFace 1 1 s))
+  apply congrArg p.val
+  funext i
+  apply Subtype.ext
+  fin_cases i
+  · change
+      (lowerSquareTriangle (FirstHurewicz.simplexFace 1 1 s) 0 : ℝ) =
+        (upperSquareTriangle (FirstHurewicz.simplexFace 1 1 s) 0 : ℝ)
+    rw [lowerSquareTriangle_zero, upperSquareTriangle_zero, FirstHurewicz.simplexFace_apply_self,
+      zero_add]
+  · change
+      (lowerSquareTriangle (FirstHurewicz.simplexFace 1 1 s) 1 : ℝ) =
+        (upperSquareTriangle (FirstHurewicz.simplexFace 1 1 s) 1 : ℝ)
+    rw [lowerSquareTriangle_one, upperSquareTriangle_one, FirstHurewicz.simplexFace_apply_self,
+      zero_add]
+
+private theorem SecondHurewicz.SimplyConnected.lowerSquareTriangle_outerFace {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x) (i : Fin 3) (hi : i ≠ 1) :
+    (p.val.comp lowerSquareTriangle).comp (FirstHurewicz.simplexFace 1 i) =
+      ContinuousMap.const (FirstHurewicz.Simplex 1) x := by
+  fin_cases i
+  · apply ContinuousMap.ext
+    intro s
+    change p (lowerSquareTriangle (FirstHurewicz.simplexFace 1 0 s)) = x
+    apply GenLoop.boundary p
+    refine ⟨0, Or.inr ?_⟩
+    apply Subtype.ext
+    change (lowerSquareTriangle (FirstHurewicz.simplexFace 1 0 s) 0 : ℝ) = 1
+    rw [lowerSquareTriangle_zero]
+    have h1 : FirstHurewicz.simplexFace 1 0 s 1 = s 0 :=
+      FirstHurewicz.simplexFace_apply_succAbove 1 0 s 0
+    have h2 : FirstHurewicz.simplexFace 1 0 s 2 = s 1 :=
+      FirstHurewicz.simplexFace_apply_succAbove 1 0 s 1
+    rw [h1, h2]
+    exact stdSimplex.add_eq_one s
+  · exact (hi rfl).elim
+  · apply ContinuousMap.ext
+    intro s
+    change p (lowerSquareTriangle (FirstHurewicz.simplexFace 1 2 s)) = x
+    apply GenLoop.boundary p
+    refine ⟨1, Or.inl ?_⟩
+    apply Subtype.ext
+    change (lowerSquareTriangle (FirstHurewicz.simplexFace 1 2 s) 1 : ℝ) = 0
+    rw [lowerSquareTriangle_one, FirstHurewicz.simplexFace_apply_self]
+
+private theorem SecondHurewicz.SimplyConnected.upperSquareTriangle_outerFace {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x) (i : Fin 3) (hi : i ≠ 1) :
+    (p.val.comp upperSquareTriangle).comp (FirstHurewicz.simplexFace 1 i) =
+      ContinuousMap.const (FirstHurewicz.Simplex 1) x := by
+  fin_cases i
+  · apply ContinuousMap.ext
+    intro s
+    change p (upperSquareTriangle (FirstHurewicz.simplexFace 1 0 s)) = x
+    apply GenLoop.boundary p
+    refine ⟨1, Or.inr ?_⟩
+    apply Subtype.ext
+    change (upperSquareTriangle (FirstHurewicz.simplexFace 1 0 s) 1 : ℝ) = 1
+    rw [upperSquareTriangle_one]
+    have h1 : FirstHurewicz.simplexFace 1 0 s 1 = s 0 :=
+      FirstHurewicz.simplexFace_apply_succAbove 1 0 s 0
+    have h2 : FirstHurewicz.simplexFace 1 0 s 2 = s 1 :=
+      FirstHurewicz.simplexFace_apply_succAbove 1 0 s 1
+    rw [h1, h2]
+    exact stdSimplex.add_eq_one s
+  · exact (hi rfl).elim
+  · apply ContinuousMap.ext
+    intro s
+    change p (upperSquareTriangle (FirstHurewicz.simplexFace 1 2 s)) = x
+    apply GenLoop.boundary p
+    refine ⟨0, Or.inl ?_⟩
+    apply Subtype.ext
+    change (upperSquareTriangle (FirstHurewicz.simplexFace 1 2 s) 0 : ℝ) = 0
+    rw [upperSquareTriangle_zero, FirstHurewicz.simplexFace_apply_self]
+
+private theorem
+    SecondHurewicz.SimplyConnected.lowerSquareTriangle_quotient (t : Fin 2 → (unitInterval))
+    (h : (t 1 : ℝ) ≤ t 0) : lowerSquareTriangle (triangleQuotient (t 0, t 1)) = t := by
+  funext i
+  apply Subtype.ext
+  fin_cases i
+  · change (lowerSquareTriangle (triangleQuotient (t 0, t 1)) 0 : ℝ) = (t 0 : ℝ)
+    rw [lowerSquareTriangle_zero, triangleQuotient_one, triangleQuotient_two]
+    ring
+  · change (lowerSquareTriangle (triangleQuotient (t 0, t 1)) 1 : ℝ) = (t 1 : ℝ)
+    rw [lowerSquareTriangle_one, triangleQuotient_two, min_eq_right h]
+
+private theorem
+    SecondHurewicz.SimplyConnected.upperSquareTriangle_quotient (t : Fin 2 → (unitInterval))
+    (h : (t 0 : ℝ) ≤ t 1) : upperSquareTriangle (triangleQuotient (t 1, t 0)) = t := by
+  funext i
+  apply Subtype.ext
+  fin_cases i
+  · change (upperSquareTriangle (triangleQuotient (t 1, t 0)) 0 : ℝ) = (t 0 : ℝ)
+    rw [upperSquareTriangle_zero, triangleQuotient_two, min_eq_right h]
+  · change (upperSquareTriangle (triangleQuotient (t 1, t 0)) 1 : ℝ) = (t 1 : ℝ)
+    rw [upperSquareTriangle_one, triangleQuotient_one, triangleQuotient_two]
+    ring
+
+private theorem SecondHurewicz.SimplyConnected.triangleQuotient_perimeter_of_le
+    (z : (unitInterval) × (unitInterval)) (hper : z.1 = 0 ∨ z.1 = 1 ∨ z.2 = 0 ∨ z.2 = 1)
+    (hle : (z.2 : ℝ) ≤ z.1) : triangleQuotient z 0 = 0 ∨ triangleQuotient z 2 = 0 := by
+  rcases hper with h | h | h | h
+  · right
+    rw [triangleQuotient_two, h]
+    exact min_eq_left z.2.property.1
+  · left
+    rw [triangleQuotient_zero, h]
+    norm_num
+  · right
+    rw [triangleQuotient_two, h]
+    exact min_eq_right z.1.property.1
+  · have hu : z.1 = 1 := Subtype.ext (le_antisymm z.1.property.2 (by simpa only [h] using hle))
+    left
+    rw [triangleQuotient_zero, hu]
+    norm_num
+
+private theorem
+    SecondHurewicz.SimplyConnected.cubeBoundary_productBoundary (t : Fin 2 → (unitInterval))
+    (ht : t ∈ Cube.boundary (Fin 2)) : t 0 = 0 ∨ t 0 = 1 ∨ t 1 = 0 ∨ t 1 = 1 := by
+  rcases ht with ⟨i, hi | hi⟩
+  · fin_cases i
+    · exact Or.inl hi
+    · exact Or.inr (Or.inr (Or.inl hi))
+  · fin_cases i
+    · exact Or.inr (Or.inl hi)
+    · exact Or.inr (Or.inr (Or.inr hi))
+
+private def SecondHurewicz.SimplyConnected.gluedTriangleHomotopyMap {X : Type} [TopologicalSpace X]
+    (L U : C((unitInterval) × FirstHurewicz.Simplex 2, X))
+    (hdiag : ∀ r s, s 1 = 0 → L (r, s) = U (r, s)) :
+    C((unitInterval) × (Fin 2 → (unitInterval)), X)
+    where
+  toFun
+    z :=
+    if (z.2 1 : ℝ) ≤ z.2 0 then L (z.1, triangleQuotient (z.2 0, z.2 1))
+    else U (z.1, triangleQuotient (z.2 1, z.2 0))
+  continuous_toFun := by
+    apply Continuous.if_le (by fun_prop) (by fun_prop) (by fun_prop) (by fun_prop)
+    intro z h
+    have he : z.2 1 = z.2 0 := Subtype.ext h
+    have hq : triangleQuotient (z.2 0, z.2 1) 1 = 0 := by
+      simp only [triangleQuotient_one, he, min_self, sub_self]
+    simpa only [he] using hdiag z.1 (triangleQuotient (z.2 0, z.2 1)) hq
+
+private theorem SecondHurewicz.SimplyConnected.gluedTriangleHomotopyMap_boundary {X : Type}
+    [TopologicalSpace X] (L U : C((unitInterval) × FirstHurewicz.Simplex 2, X))
+    (hdiag : ∀ r s, s 1 = 0 → L (r, s) = U (r, s)) (x : X)
+    (hL : ∀ r s, s 0 = 0 ∨ s 2 = 0 → L (r, s) = x) (hU : ∀ r s, s 0 = 0 ∨ s 2 = 0 → U (r, s) = x)
+    (r : (unitInterval)) (t : Fin 2 → (unitInterval)) (ht : t ∈ Cube.boundary (Fin 2)) :
+    gluedTriangleHomotopyMap L U hdiag (r, t) = x := by
+  have hp := cubeBoundary_productBoundary t ht
+  change (if (t 1 : ℝ) ≤ t 0 then _ else _) = x
+  split_ifs with h
+  · exact hL r _ (triangleQuotient_perimeter_of_le (t 0, t 1) hp h)
+  · have hp' : t 1 = 0 ∨ t 1 = 1 ∨ t 0 = 0 ∨ t 0 = 1 := by
+      rcases hp with hp | hp | hp | hp
+      · exact Or.inr (Or.inr (Or.inl hp))
+      · exact Or.inr (Or.inr (Or.inr hp))
+      · exact Or.inl hp
+      · exact Or.inr (Or.inl hp)
+    exact hU r _ (triangleQuotient_perimeter_of_le (t 1, t 0) hp' (le_of_not_ge h))
+
+private def
+    SecondHurewicz.SimplyConnected.gluedTriangleHomotopy {X : Type} [TopologicalSpace X] {x : X}
+    {p q : GenLoop (Fin 2) X x}
+    (L : (p.val.comp lowerSquareTriangle).Homotopy (q.val.comp lowerSquareTriangle))
+    (U : (p.val.comp upperSquareTriangle).Homotopy (q.val.comp upperSquareTriangle))
+    (hdiag : ∀ r s, s 1 = 0 → L (r, s) = U (r, s)) (hL : ∀ r s, s 0 = 0 ∨ s 2 = 0 → L (r, s) = x)
+    (hU : ∀ r s, s 0 = 0 ∨ s 2 = 0 → U (r, s) = x) :
+    p.val.HomotopyRel q.val (Cube.boundary (Fin 2))
+    where
+  toContinuousMap := gluedTriangleHomotopyMap L.toContinuousMap U.toContinuousMap hdiag
+  map_zero_left
+    t := by
+    change (if (t 1 : ℝ) ≤ t 0 then _ else _) = p.val t
+    split_ifs with h
+    · change L (0, triangleQuotient (t 0, t 1)) = p.val t
+      rw [L.apply_zero]
+      change p.val (lowerSquareTriangle (triangleQuotient (t 0, t 1))) = p.val t
+      rw [lowerSquareTriangle_quotient t h]
+    · change U (0, triangleQuotient (t 1, t 0)) = p.val t
+      rw [U.apply_zero]
+      change p.val (upperSquareTriangle (triangleQuotient (t 1, t 0))) = p.val t
+      rw [upperSquareTriangle_quotient t (le_of_not_ge h)]
+  map_one_left
+    t := by
+    change (if (t 1 : ℝ) ≤ t 0 then _ else _) = q.val t
+    split_ifs with h
+    · change L (1, triangleQuotient (t 0, t 1)) = q.val t
+      rw [L.apply_one]
+      change q.val (lowerSquareTriangle (triangleQuotient (t 0, t 1))) = q.val t
+      rw [lowerSquareTriangle_quotient t h]
+    · change U (1, triangleQuotient (t 1, t 0)) = q.val t
+      rw [U.apply_one]
+      change q.val (upperSquareTriangle (triangleQuotient (t 1, t 0))) = q.val t
+      rw [upperSquareTriangle_quotient t (le_of_not_ge h)]
+  prop' r t
+    ht :=
+    (gluedTriangleHomotopyMap_boundary L.toContinuousMap U.toContinuousMap hdiag x hL hU r t
+          ht).trans
+      (GenLoop.boundary p t ht).symm
+
+private theorem SecondHurewicz.SimplyConnected.basedTriangles_diagonal_mo1973_6743 {X : Type}
+    [TopologicalSpace X] {x : X} (τ υ : BasedTriangle x) (s : FirstHurewicz.Simplex 2)
+    (hs : s 1 = 0) : τ.val s = υ.val s :=
+  (τ.property s ⟨1, hs⟩).trans (υ.property s ⟨1, hs⟩).symm
+
+private def
+    SecondHurewicz.SimplyConnected.basedTrianglesLoop {X : Type} [TopologicalSpace X] {x : X}
+    (τ υ : BasedTriangle x) : GenLoop (Fin 2) X x :=
+  ⟨(gluedTriangleHomotopyMap (τ.val.comp ContinuousMap.snd) (υ.val.comp ContinuousMap.snd)
+          (fun _ => basedTriangles_diagonal_mo1973_6743 τ υ)).comp
+      ⟨fun t => ((0 : (unitInterval)), t), by fun_prop⟩,
+    by
+    intro t ht
+    exact
+      gluedTriangleHomotopyMap_boundary _ _ (fun _ => basedTriangles_diagonal_mo1973_6743 τ υ) x
+        (fun _ s hs => τ.property s (hs.elim (fun h => ⟨0, h⟩) (fun h => ⟨2, h⟩)))
+        (fun _ s hs => υ.property s (hs.elim (fun h => ⟨0, h⟩) (fun h => ⟨2, h⟩))) 0 t ht⟩
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.basedTrianglesLoop_apply {X : Type} [TopologicalSpace X]
+    {x : X} (τ υ : BasedTriangle x) (t : Fin 2 → (unitInterval)) :
+    basedTrianglesLoop τ υ t =
+      if (t 1 : ℝ) ≤ t 0 then τ.val (triangleQuotient (t 0, t 1))
+      else υ.val (triangleQuotient (t 1, t 0)) :=
+  rfl
+
+private theorem
+    SecondHurewicz.SimplyConnected.basedTrianglesLoop_diagonal {X : Type} [TopologicalSpace X]
+    {x : X} (τ υ : BasedTriangle x) (u : (unitInterval)) :
+    basedTrianglesLoop τ υ (fun _ => u) = x := by
+  rw [basedTrianglesLoop_apply, ite_eq_left le_rfl]
+  apply τ.property
+  exact ⟨1, by simp only [triangleQuotient_one, min_self, sub_self]⟩
+
+private theorem
+    SecondHurewicz.SimplyConnected.basedTrianglesLoop_lower {X : Type} [TopologicalSpace X]
+    {x : X} (τ υ : BasedTriangle x) :
+    (basedTrianglesLoop τ υ).val.comp lowerSquareTriangle = τ.val := by
+  apply ContinuousMap.ext
+  intro s
+  change basedTrianglesLoop τ υ (lowerSquareTriangle s) = τ.val s
+  rw [basedTrianglesLoop_apply]
+  have hle : (lowerSquareTriangle s 1 : ℝ) ≤ lowerSquareTriangle s 0 := by
+    rw [lowerSquareTriangle_zero, lowerSquareTriangle_one]
+    exact le_add_of_nonneg_left (stdSimplex.zero_le s 1)
+  rw [ite_eq_left hle]
+  change
+    τ.val (triangleQuotient ((lowerProductTriangle s).1, (lowerProductTriangle s).2)) = τ.val s
+  exact congrArg τ.val (ContinuousMap.congr_fun triangleQuotient_lowerProductTriangle s)
+
+private theorem SecondHurewicz.SimplyConnected.triangleQuotient_swapped_upper_mo1973_6748
+    (s : FirstHurewicz.Simplex 2) :
+    triangleQuotient (upperSquareTriangle s 1, upperSquareTriangle s 0) = s := by
+  have hpair : (upperSquareTriangle s 1, upperSquareTriangle s 0) = lowerProductTriangle s := by
+    apply Prod.ext <;> apply Subtype.ext
+    · rw [upperSquareTriangle_one, lowerProductTriangle_fst]
+    · rw [upperSquareTriangle_zero, lowerProductTriangle_snd]
+  rw [hpair]
+  exact ContinuousMap.congr_fun triangleQuotient_lowerProductTriangle s
+
+private theorem
+    SecondHurewicz.SimplyConnected.basedTrianglesLoop_upper {X : Type} [TopologicalSpace X]
+    {x : X} (τ υ : BasedTriangle x) :
+    (basedTrianglesLoop τ υ).val.comp upperSquareTriangle = υ.val := by
+  apply ContinuousMap.ext
+  intro s
+  change basedTrianglesLoop τ υ (upperSquareTriangle s) = υ.val s
+  rw [basedTrianglesLoop_apply]
+  split_ifs with h
+  · have hs : s 1 = 0 := by
+      rw [upperSquareTriangle_zero, upperSquareTriangle_one] at h
+      exact le_antisymm (by linarith) (stdSimplex.zero_le s 1)
+    have he : upperSquareTriangle s 0 = upperSquareTriangle s 1 := by
+      apply Subtype.ext
+      rw [upperSquareTriangle_zero, upperSquareTriangle_one, hs, zero_add]
+    have hq : triangleQuotient (upperSquareTriangle s 0, upperSquareTriangle s 1) = s := by
+      simpa only [he] using triangleQuotient_swapped_upper_mo1973_6748 s
+    rw [hq]
+    exact basedTriangles_diagonal_mo1973_6743 τ υ s hs
+  · rw [triangleQuotient_swapped_upper_mo1973_6748]
+
+private def
+    SecondHurewicz.SimplyConnected.basedTrianglesHomotopy {X : Type} [TopologicalSpace X] {x : X}
+    {p : GenLoop (Fin 2) X x} (τ υ : BasedTriangle x)
+    (L : (p.val.comp lowerSquareTriangle).Homotopy τ.val)
+    (U : (p.val.comp upperSquareTriangle).Homotopy υ.val)
+    (hdiag : ∀ r s, s 1 = 0 → L (r, s) = U (r, s)) (hL : ∀ r s, s 0 = 0 ∨ s 2 = 0 → L (r, s) = x)
+    (hU : ∀ r s, s 0 = 0 ∨ s 2 = 0 → U (r, s) = x) :
+    p.val.HomotopyRel (basedTrianglesLoop τ υ).val (Cube.boundary (Fin 2)) :=
+  gluedTriangleHomotopy (L.cast rfl (basedTrianglesLoop_lower τ υ).symm)
+    (U.cast rfl (basedTrianglesLoop_upper τ υ).symm) hdiag hL hU
+
+private theorem SecondHurewicz.SimplyConnected.triangleProperty_of_face
+    {P : FirstHurewicz.Simplex 2 → Prop} (i : Fin 3)
+    (h : ∀ u, P (FirstHurewicz.simplexFace 1 i u)) (s : FirstHurewicz.Simplex 2) (hs : s i = 0) :
+    P s := by simpa only [simplexFace_inverse] using h (simplexFaceInverse 1 i ⟨s, hs⟩)
+
+private def
+    SecondHurewicz.SimplyConnected.basedTrianglesHomotopy_of_faces {X : Type} [TopologicalSpace X]
+    {x : X} {p : GenLoop (Fin 2) X x} (τ υ : BasedTriangle x)
+    (L : (p.val.comp lowerSquareTriangle).Homotopy τ.val)
+    (U : (p.val.comp upperSquareTriangle).Homotopy υ.val)
+    (hdiag :
+      ∀ r s, L (r, FirstHurewicz.simplexFace 1 1 s) = U (r, FirstHurewicz.simplexFace 1 1 s))
+    (hL : ∀ r (i : Fin 3), i ≠ 1 → ∀ s, L (r, FirstHurewicz.simplexFace 1 i s) = x)
+    (hU : ∀ r (i : Fin 3), i ≠ 1 → ∀ s, U (r, FirstHurewicz.simplexFace 1 i s) = x) :
+    p.val.HomotopyRel (basedTrianglesLoop τ υ).val (Cube.boundary (Fin 2)) :=
+  basedTrianglesHomotopy τ υ L U
+    (fun r s hs => triangleProperty_of_face (P := fun s => L (r, s) = U (r, s)) 1 (hdiag r) s hs)
+    (fun r s hs =>
+      hs.elim (triangleProperty_of_face (P := fun s => L (r, s) = x) 0 (hL r 0 (by decide)) s)
+        (triangleProperty_of_face (P := fun s => L (r, s) = x) 2 (hL r 2 (by decide)) s))
+    (fun r s hs =>
+      hs.elim (triangleProperty_of_face (P := fun s => U (r, s) = x) 0 (hU r 0 (by decide)) s)
+        (triangleProperty_of_face (P := fun s => U (r, s) = x) 2 (hU r 2 (by decide)) s))
+
+private def
+    SecondHurewicz.SimplyConnected.squareNormalizedLowerTriangle {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] {x : X} (p : GenLoop (Fin 2) X x) : BasedTriangle x :=
+  edgeStraightenedTriangle x (p.val.comp lowerSquareTriangle)
+    (lowerSquareTriangle_verticesBased p)
+
+private def
+    SecondHurewicz.SimplyConnected.squareNormalizedUpperTriangle {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] {x : X} (p : GenLoop (Fin 2) X x) : BasedTriangle x :=
+  edgeStraightenedTriangle x (p.val.comp upperSquareTriangle)
+    (upperSquareTriangle_verticesBased p)
+
+private def SecondHurewicz.SimplyConnected.squareNormalizationTriangleHomotopy {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] {x : X} (smp : C(FirstHurewicz.Simplex 2, X))
+    (h : VerticesBased x 2 smp) : smp.Homotopy (edgeStraightenedTriangle x smp h).val
+    where
+  toContinuousMap := triangleEdgeStraighteningHomotopy x smp
+  map_zero_left := triangleEdgeStraighteningHomotopy_zero x smp
+  map_one_left _ := rfl
+
+private def SecondHurewicz.SimplyConnected.squareLowerNormalizationHomotopy {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] {x : X} (p : GenLoop (Fin 2) X x) :
+    (p.val.comp lowerSquareTriangle).Homotopy (squareNormalizedLowerTriangle p).val :=
+  squareNormalizationTriangleHomotopy _ (lowerSquareTriangle_verticesBased p)
+
+private def SecondHurewicz.SimplyConnected.squareUpperNormalizationHomotopy {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] {x : X} (p : GenLoop (Fin 2) X x) :
+    (p.val.comp upperSquareTriangle).Homotopy (squareNormalizedUpperTriangle p).val :=
+  squareNormalizationTriangleHomotopy _ (upperSquareTriangle_verticesBased p)
+
+private theorem SecondHurewicz.SimplyConnected.squareNormalization_edge_face {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] {x : X} (smp : C(FirstHurewicz.Simplex 2, X))
+    (i : Fin 3) (r : (unitInterval)) (s : FirstHurewicz.Simplex 1) :
+    triangleEdgeStraighteningHomotopy x smp (r, FirstHurewicz.simplexFace 1 i s) =
+      edgeStraighteningHomotopy x (smp.comp (FirstHurewicz.simplexFace 1 i)) (r, s) :=
+  DFunLike.congr_fun (triangleEdgeStraighteningHomotopy_face x smp i) (r, s)
+
+private theorem SecondHurewicz.SimplyConnected.squareNormalization_diagonal {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (r : (unitInterval)) (s : FirstHurewicz.Simplex 1) :
+    squareLowerNormalizationHomotopy p (r, FirstHurewicz.simplexFace 1 1 s) =
+      squareUpperNormalizationHomotopy p (r, FirstHurewicz.simplexFace 1 1 s) := by
+  change
+    triangleEdgeStraighteningHomotopy x (p.val.comp lowerSquareTriangle)
+        (r, FirstHurewicz.simplexFace 1 1 s) =
+      triangleEdgeStraighteningHomotopy x (p.val.comp upperSquareTriangle)
+        (r, FirstHurewicz.simplexFace 1 1 s)
+  rw [squareNormalization_edge_face, squareNormalization_edge_face, squareTriangles_diagonal]
+
+private theorem SecondHurewicz.SimplyConnected.squareLowerNormalization_outerFace {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (r : (unitInterval)) (i : Fin 3) (hi : i ≠ 1) (s : FirstHurewicz.Simplex 1) :
+    squareLowerNormalizationHomotopy p (r, FirstHurewicz.simplexFace 1 i s) = x := by
+  change
+    triangleEdgeStraighteningHomotopy x (p.val.comp lowerSquareTriangle)
+        (r, FirstHurewicz.simplexFace 1 i s) =
+      x
+  rw [squareNormalization_edge_face, lowerSquareTriangle_outerFace p i hi,
+    edgeStraighteningHomotopy_const]
+  rfl
+
+private theorem SecondHurewicz.SimplyConnected.squareUpperNormalization_outerFace {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (r : (unitInterval)) (i : Fin 3) (hi : i ≠ 1) (s : FirstHurewicz.Simplex 1) :
+    squareUpperNormalizationHomotopy p (r, FirstHurewicz.simplexFace 1 i s) = x := by
+  change
+    triangleEdgeStraighteningHomotopy x (p.val.comp upperSquareTriangle)
+        (r, FirstHurewicz.simplexFace 1 i s) =
+      x
+  rw [squareNormalization_edge_face, upperSquareTriangle_outerFace p i hi,
+    edgeStraighteningHomotopy_const]
+  rfl
+
+private def
+    SecondHurewicz.SimplyConnected.squareNormalizationHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] {x : X} (p : GenLoop (Fin 2) X x) :
+    p.val.HomotopyRel
+      (basedTrianglesLoop (squareNormalizedLowerTriangle p) (squareNormalizedUpperTriangle p)).val
+      (Cube.boundary (Fin 2)) :=
+  basedTrianglesHomotopy_of_faces (squareNormalizedLowerTriangle p)
+    (squareNormalizedUpperTriangle p) (squareLowerNormalizationHomotopy p)
+    (squareUpperNormalizationHomotopy p) (squareNormalization_diagonal p)
+    (squareLowerNormalization_outerFace p) (squareUpperNormalization_outerFace p)
+
+private theorem SecondHurewicz.SimplyConnected.squareNormalization_homotopic {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] {x : X} (p : GenLoop (Fin 2) X x) :
+    GenLoop.Homotopic p
+      (basedTrianglesLoop (squareNormalizedLowerTriangle p) (squareNormalizedUpperTriangle p)) :=
+  ⟨squareNormalizationHomotopy p⟩
+
+private def SecondHurewicz.SimplyConnected.subdivisionUpperPositiveSquareTriangle :
+    C(FirstHurewicz.Simplex 2, Fin 2 → (unitInterval)) :=
+  SecondHurewicz.squareCoordinates.comp (squareAffineTriangle ![(0, 0), (1, 1), (0, 1)])
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.subdivisionUpperPositiveSquareTriangle_zero
+    (s : FirstHurewicz.Simplex 2) : (subdivisionUpperPositiveSquareTriangle s 0 : ℝ) = s 1 := by
+  simp [subdivisionUpperPositiveSquareTriangle, squareAffineTriangle_fst_coe,
+    SingularMayerVietoris.stdVertices, stdSimplex.vertex, Fin.sum_univ_succ, Pi.single_apply]
+
+@[simp]
+private theorem SecondHurewicz.SimplyConnected.subdivisionUpperPositiveSquareTriangle_one
+    (s : FirstHurewicz.Simplex 2) :
+    (subdivisionUpperPositiveSquareTriangle s 1 : ℝ) = s 1 + s 2 := by
+  simp [subdivisionUpperPositiveSquareTriangle, squareAffineTriangle_snd_coe,
+    SingularMayerVietoris.stdVertices, stdSimplex.vertex, Fin.sum_univ_succ, Pi.single_apply]
+
+private theorem SecondHurewicz.SimplyConnected.subdivisionTriangle_coordinate_sum
+    (s : FirstHurewicz.Simplex 2) : s 0 + s 1 + s 2 = 1 := by
+  have hsum := stdSimplex.sum_eq_one s
+  simp only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero] at hsum
+  change s 0 + (s 1 + s 2) = 1 at hsum
+  linarith
+
+private theorem SecondHurewicz.SimplyConnected.subdivisionLowerSquareTriangle_based {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) (s : FirstHurewicz.Simplex 2)
+    (hs : s ∈ triangleBoundary) : p (lowerSquareTriangle s) = x := by
+  rcases hs with ⟨i, hi⟩
+  fin_cases i
+  · change s 0 = 0 at hi
+    apply p.property
+    refine ⟨0, Or.inr ?_⟩
+    apply Subtype.ext
+    change (lowerSquareTriangle s 0 : ℝ) = 1
+    rw [lowerSquareTriangle_zero]
+    linarith [subdivisionTriangle_coordinate_sum s]
+  · change s 1 = 0 at hi
+    apply subdivisionOnDiagonal p hd
+    apply Subtype.ext
+    simp [hi]
+  · change s 2 = 0 at hi
+    apply p.property
+    refine ⟨1, Or.inl ?_⟩
+    apply Subtype.ext
+    simpa using hi
+
+private theorem
+    SecondHurewicz.SimplyConnected.subdivisionUpperNegativeSquareTriangle_based {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) (s : FirstHurewicz.Simplex 2)
+    (hs : s ∈ triangleBoundary) : p (upperSquareTriangle s) = x := by
+  rcases hs with ⟨i, hi⟩
+  fin_cases i
+  · change s 0 = 0 at hi
+    apply p.property
+    refine ⟨1, Or.inr ?_⟩
+    apply Subtype.ext
+    change (upperSquareTriangle s 1 : ℝ) = 1
+    rw [upperSquareTriangle_one]
+    linarith [subdivisionTriangle_coordinate_sum s]
+  · change s 1 = 0 at hi
+    apply subdivisionOnDiagonal p hd
+    apply Subtype.ext
+    simp [hi]
+  · change s 2 = 0 at hi
+    apply p.property
+    refine ⟨0, Or.inl ?_⟩
+    apply Subtype.ext
+    simpa using hi
+
+private theorem
+    SecondHurewicz.SimplyConnected.subdivisionUpperPositiveSquareTriangle_based {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) (s : FirstHurewicz.Simplex 2)
+    (hs : s ∈ triangleBoundary) : p (subdivisionUpperPositiveSquareTriangle s) = x := by
+  rcases hs with ⟨i, hi⟩
+  fin_cases i
+  · change s 0 = 0 at hi
+    apply p.property
+    refine ⟨1, Or.inr ?_⟩
+    apply Subtype.ext
+    change (subdivisionUpperPositiveSquareTriangle s 1 : ℝ) = 1
+    rw [subdivisionUpperPositiveSquareTriangle_one]
+    linarith [subdivisionTriangle_coordinate_sum s]
+  · change s 1 = 0 at hi
+    apply p.property
+    refine ⟨0, Or.inl ?_⟩
+    apply Subtype.ext
+    simpa using hi
+  · change s 2 = 0 at hi
+    apply subdivisionOnDiagonal p hd
+    apply Subtype.ext
+    simp [hi]
+
+private def
+    SecondHurewicz.SimplyConnected.subdivisionLowerBasedTriangle {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 2) X x) (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    BasedTriangle x :=
+  ⟨p.val.comp lowerSquareTriangle, subdivisionLowerSquareTriangle_based p hd⟩
+
+private def SecondHurewicz.SimplyConnected.subdivisionUpperNegativeBasedTriangle {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) : BasedTriangle x :=
+  ⟨p.val.comp upperSquareTriangle, subdivisionUpperNegativeSquareTriangle_based p hd⟩
+
+private def SecondHurewicz.SimplyConnected.subdivisionUpperPositiveBasedTriangle {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) : BasedTriangle x :=
+  ⟨p.val.comp subdivisionUpperPositiveSquareTriangle,
+    subdivisionUpperPositiveSquareTriangle_based p hd⟩
+
+private theorem SecondHurewicz.SimplyConnected.subdivisionLowerTriangleLoop_eq_basedTriangleLoop
+    {X : Type} [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    subdivisionLowerTriangleLoop p hd = basedTriangleLoop (subdivisionLowerBasedTriangle p hd) := by
+  apply GenLoop.ext
+  intro u
+  change p ![u 0, Min.min (u 0) (u 1)] = p (lowerSquareTriangle (triangleQuotient (u 0, u 1)))
+  congr 1
+  funext i
+  fin_cases i <;> apply Subtype.ext <;> simp
+
+private theorem SecondHurewicz.SimplyConnected.subdivisionUpperTriangleLoop_eq_basedTriangleLoop
+    {X : Type} [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    subdivisionUpperTriangleLoop p hd =
+      basedTriangleLoop (subdivisionUpperPositiveBasedTriangle p hd) := by
+  apply GenLoop.ext
+  intro u
+  change
+    p ![subdivisionSubMin (u 0) (u 1), u 0] =
+      p (subdivisionUpperPositiveSquareTriangle (triangleQuotient (u 0, u 1)))
+  congr 1
+  funext i
+  fin_cases i <;> apply Subtype.ext <;> simp [subdivisionSubMin]
+
+private theorem
+    SecondHurewicz.SimplyConnected.subdivisionUpperNegativeBasedTriangle_loop_apply {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) (u : Fin 2 → (unitInterval)) :
+    basedTriangleLoop (subdivisionUpperNegativeBasedTriangle p hd) u =
+      p ![Min.min (u 0) (u 1), u 0] := by
+  change p (upperSquareTriangle (triangleQuotient (u 0, u 1))) = p ![Min.min (u 0) (u 1), u 0]
+  congr 1
+  funext i
+  fin_cases i <;> apply Subtype.ext <;> simp
+
+private theorem SecondHurewicz.SimplyConnected.subdivision_basedTriangleClass_sum {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    Additive.ofMul (⟦p⟧ : π_ 2 X x) =
+      basedTriangleClass (subdivisionLowerBasedTriangle p hd) +
+        basedTriangleClass (subdivisionUpperPositiveBasedTriangle p hd) := by
+  simpa only [subdivisionLowerTriangleLoop_eq_basedTriangleLoop,
+    subdivisionUpperTriangleLoop_eq_basedTriangleLoop, basedTriangleClass] using
+    subdivision_additiveClass p hd
+
+private def SecondHurewicz.SimplyConnected.subdivisionUpperNegativeMap :
+    C(SubdivisionSquare, SubdivisionSquare)
+    where
+  toFun u := ![Min.min (u 0) (u 1), u 0]
+  continuous_toFun := by fun_prop
+
+private def SecondHurewicz.SimplyConnected.subdivisionUpperNegativeReversedMap :
+    C(SubdivisionSquare, SubdivisionSquare)
+    where
+  toFun u := ![Min.min (u 0) ((unitInterval.symm) (u 1)), u 0]
+  continuous_toFun := by fun_prop
+
+private theorem SecondHurewicz.SimplyConnected.subdivisionUpperNegativeMap_based {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) (u : SubdivisionSquare)
+    (hu : u ∈ Cube.boundary (Fin 2)) : p (subdivisionUpperNegativeMap u) = x := by
+  rcases subdivisionSquare_boundary_cases u hu with h | h | h | h
+  · exact p.property _ ⟨1, Or.inl (by simp [subdivisionUpperNegativeMap, h])⟩
+  · exact p.property _ ⟨1, Or.inr (by simp [subdivisionUpperNegativeMap, h])⟩
+  · exact p.property _ ⟨0, Or.inl (by simp [subdivisionUpperNegativeMap, h])⟩
+  · exact
+      subdivisionOnDiagonal p hd _
+        (by
+          simp [subdivisionUpperNegativeMap, h,
+            min_eq_left (show u 0 ≤ (1 : (unitInterval)) from (u 0).property.2)])
+
+private theorem SecondHurewicz.SimplyConnected.subdivisionUpperNegativeReversedMap_based {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) (u : SubdivisionSquare)
+    (hu : u ∈ Cube.boundary (Fin 2)) : p (subdivisionUpperNegativeReversedMap u) = x := by
+  rcases subdivisionSquare_boundary_cases u hu with h | h | h | h
+  · exact p.property _ ⟨1, Or.inl (by simp [subdivisionUpperNegativeReversedMap, h])⟩
+  · exact p.property _ ⟨1, Or.inr (by simp [subdivisionUpperNegativeReversedMap, h])⟩
+  · exact
+      subdivisionOnDiagonal p hd _
+        (by
+          simp [subdivisionUpperNegativeReversedMap, h,
+            min_eq_left (show u 0 ≤ (1 : (unitInterval)) from (u 0).property.2)])
+  · exact p.property _ ⟨0, Or.inl (by simp [subdivisionUpperNegativeReversedMap, h])⟩
+
+private def
+    SecondHurewicz.SimplyConnected.subdivisionUpperNegativeLoop {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 2) X x) (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    GenLoop (Fin 2) X x :=
+  subdivisionPullbackLoop p subdivisionUpperNegativeMap (subdivisionUpperNegativeMap_based p hd)
+
+private def SecondHurewicz.SimplyConnected.subdivisionUpperNegativeReversedLoop {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) : GenLoop (Fin 2) X x :=
+  subdivisionPullbackLoop p subdivisionUpperNegativeReversedMap
+    (subdivisionUpperNegativeReversedMap_based p hd)
+
+private theorem
+    SecondHurewicz.SimplyConnected.subdivisionUpperOrientation_sides (u : SubdivisionSquare)
+    (hu : u ∈ Cube.boundary (Fin 2)) :
+    SubdivisionSameSide (subdivisionUpperTriangleMap u) (subdivisionUpperNegativeReversedMap u) :=
+  by
+  rcases subdivisionSquare_boundary_cases u hu with h | h | h | h
+  · exact
+      .zero 1 (by simp [subdivisionUpperTriangleMap, h])
+        (by simp [subdivisionUpperNegativeReversedMap, h])
+  · exact
+      .one 1 (by simp [subdivisionUpperTriangleMap, h])
+        (by simp [subdivisionUpperNegativeReversedMap, h])
+  · exact
+      .diagonal (by simp [subdivisionUpperTriangleMap, h])
+        (by
+          simp [subdivisionUpperNegativeReversedMap, h,
+            min_eq_left (show u 0 ≤ (1 : (unitInterval)) from (u 0).property.2)])
+  · exact
+      .zero 0 (by simp [subdivisionUpperTriangleMap, h])
+        (by simp [subdivisionUpperNegativeReversedMap, h])
+
+private def SecondHurewicz.SimplyConnected.subdivisionUpperOrientationHomotopy {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    (subdivisionUpperTriangleLoop p hd).val.HomotopyRel
+      (subdivisionUpperNegativeReversedLoop p hd).val (Cube.boundary (Fin 2)) :=
+  subdivisionLinearHomotopy p hd _ _ (subdivisionUpperTriangleMap_based p hd)
+    (subdivisionUpperNegativeReversedMap_based p hd) subdivisionUpperOrientation_sides
+
+private theorem
+    SecondHurewicz.SimplyConnected.subdivisionUpperNegativeReversedLoop_eq_symmAt {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    subdivisionUpperNegativeReversedLoop p hd =
+      GenLoop.symmAt (1 : Fin 2) (subdivisionUpperNegativeLoop p hd) := by
+  apply GenLoop.ext
+  intro u
+  change
+    p ![Min.min (u 0) ((unitInterval.symm) (u 1)), u 0] =
+      subdivisionUpperNegativeLoop p hd
+        (fun j => if j = 1 then (unitInterval.symm) (u 1) else u j)
+  simp [subdivisionUpperNegativeLoop, subdivisionPullbackLoop, subdivisionUpperNegativeMap]
+
+private theorem SecondHurewicz.SimplyConnected.subdivisionUpperOrientation_homotopic {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    GenLoop.Homotopic (subdivisionUpperTriangleLoop p hd)
+      (GenLoop.symmAt (1 : Fin 2) (subdivisionUpperNegativeLoop p hd)) := by
+  rw [← subdivisionUpperNegativeReversedLoop_eq_symmAt]
+  exact ⟨subdivisionUpperOrientationHomotopy p hd⟩
+
+private theorem SecondHurewicz.SimplyConnected.subdivisionUpperOrientation_class {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    (⟦subdivisionUpperTriangleLoop p hd⟧ : π_ 2 X x) =
+      ((·⁻¹) : π_ 2 X x → π_ 2 X x) ⟦subdivisionUpperNegativeLoop p hd⟧ := by
+  have h :
+    (⟦subdivisionUpperTriangleLoop p hd⟧ : π_ 2 X x) =
+      (⟦GenLoop.symmAt (1 : Fin 2) (subdivisionUpperNegativeLoop p hd)⟧ : π_ 2 X x) :=
+    Quotient.sound (subdivisionUpperOrientation_homotopic p hd)
+  exact
+    h.trans
+      (HomotopyGroup.inv_spec (i := (1 : Fin 2)) (p := subdivisionUpperNegativeLoop p hd)).symm
+
+private theorem SecondHurewicz.SimplyConnected.subdivisionUpperOrientation_additiveClass {X : Type*}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    Additive.ofMul (⟦subdivisionUpperTriangleLoop p hd⟧ : π_ 2 X x) =
+      ((-·) : Additive (π_ 2 X x) → Additive (π_ 2 X x))
+        (Additive.ofMul (⟦subdivisionUpperNegativeLoop p hd⟧ : π_ 2 X x)) :=
+  congrArg Additive.ofMul (subdivisionUpperOrientation_class p hd)
+
+public
+theorem SecondHurewicz.SimplyConnected.subdivision_eq_sub_of_eq_add {A : Type*} [AddGroup A]
+    {a b c d : A} (h : a = b + c) (hc : c = -d) : a = b - d :=
+  h.trans ((congrArg (fun z => b + z) hc).trans (sub_eq_add_neg b d).symm)
+
+private theorem SecondHurewicz.SimplyConnected.subdivisionUpperNegativeLoop_eq_basedTriangleLoop
+    {X : Type} [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    subdivisionUpperNegativeLoop p hd =
+      basedTriangleLoop (subdivisionUpperNegativeBasedTriangle p hd) := by
+  apply GenLoop.ext
+  intro u
+  exact (subdivisionUpperNegativeBasedTriangle_loop_apply p hd u).symm
+
+private theorem SecondHurewicz.SimplyConnected.subdivisionUpperPositiveBasedTriangle_class_eq_neg
+    {X : Type} [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    basedTriangleClass (subdivisionUpperPositiveBasedTriangle p hd) =
+      -basedTriangleClass (subdivisionUpperNegativeBasedTriangle p hd) := by
+  unfold basedTriangleClass
+  rw [← subdivisionUpperTriangleLoop_eq_basedTriangleLoop, ←
+    subdivisionUpperNegativeLoop_eq_basedTriangleLoop]
+  exact subdivisionUpperOrientation_additiveClass p hd
+
+private theorem SecondHurewicz.SimplyConnected.subdivision_basedTriangleClass_sub {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 2) X x)
+    (hd : ∀ t : (unitInterval), p ![t, t] = x) :
+    Additive.ofMul (⟦p⟧ : π_ 2 X x) =
+      basedTriangleClass (subdivisionLowerBasedTriangle p hd) -
+        basedTriangleClass (subdivisionUpperNegativeBasedTriangle p hd) :=
+  subdivision_eq_sub_of_eq_add (A := Additive (π_ 2 X x))
+    (subdivision_basedTriangleClass_sum p hd)
+    (subdivisionUpperPositiveBasedTriangle_class_eq_neg p hd)
+
+private theorem
+    SecondHurewicz.SimplyConnected.basedTrianglesLoop_class {X : Type} [TopologicalSpace X]
+    {x : X} (τ υ : BasedTriangle x) :
+    Additive.ofMul (⟦basedTrianglesLoop τ υ⟧ : π_ 2 X x) =
+      basedTriangleClass τ - basedTriangleClass υ := by
+  have hd : ∀ t : (unitInterval), basedTrianglesLoop τ υ ![t, t] = x := by
+    intro t
+    have he : (![t, t] : Fin 2 → (unitInterval)) = fun _ => t := by
+      funext i
+      fin_cases i <;> rfl
+    rw [he, basedTrianglesLoop_diagonal]
+  have hl : subdivisionLowerBasedTriangle (basedTrianglesLoop τ υ) hd = τ :=
+    Subtype.ext (basedTrianglesLoop_lower τ υ)
+  have hu : subdivisionUpperNegativeBasedTriangle (basedTrianglesLoop τ υ) hd = υ :=
+    Subtype.ext (basedTrianglesLoop_upper τ υ)
+  simpa only [hl, hu] using subdivision_basedTriangleClass_sub (basedTrianglesLoop τ υ) hd
+
+private theorem SecondHurewicz.SimplyConnected.squareNormalization_quotient {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] {x : X} (p : GenLoop (Fin 2) X x) :
+    (⟦p⟧ : π_ 2 X x) =
+      ⟦basedTrianglesLoop (squareNormalizedLowerTriangle p) (squareNormalizedUpperTriangle p)⟧ :=
+  Quotient.sound (squareNormalization_homotopic p)
+
+private theorem
+    SecondHurewicz.SimplyConnected.squareNormalization_class {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] {x : X} (p : GenLoop (Fin 2) X x) :
+    basedTriangleClass (squareNormalizedLowerTriangle p) -
+        basedTriangleClass (squareNormalizedUpperTriangle p) =
+      Additive.ofMul (⟦p⟧ : π_ 2 X x) := by
+  have h := congrArg Additive.ofMul (squareNormalization_quotient p)
+  exact
+    (basedTrianglesLoop_class (squareNormalizedLowerTriangle p)
+          (squareNormalizedUpperTriangle p)).symm.trans
+      h.symm
+
+private theorem SecondHurewicz.SimplyConnected.triangleClassOperator_squareChain {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) (p : GenLoop (Fin 2) X x) :
+    triangleClassOperator x (SecondHurewicz.squareChain p) = Additive.ofMul (⟦p⟧ : π_ 2 X x) := by
+  rw [squareChain_two_triangles, map_sub, triangleClassOperator_simplex,
+    triangleClassOperator_simplex,
+    normalizedTriangle_of_verticesBased x _ (lowerSquareTriangle_verticesBased p),
+    normalizedTriangle_of_verticesBased x _ (upperSquareTriangle_verticesBased p)]
+  exact squareNormalization_class p
+
+private theorem SecondHurewicz.SimplyConnected.hurewiczInverse_hurewiczMap_mk {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) (p : GenLoop (Fin 2) X x) :
+    hurewiczInverse x (SecondHurewicz.hurewiczMap x (Additive.ofMul (⟦p⟧ : π_ 2 X x))) =
+      Additive.ofMul (⟦p⟧ : π_ 2 X x) := by
+  rw [SecondHurewicz.hurewiczMap_representative, hurewiczInverse_cycleClass]
+  exact triangleClassOperator_squareChain x p
+
+@[simp]
+private theorem
+    SecondHurewicz.SimplyConnected.hurewiczInverse_hurewiczMap {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (a : Additive (π_ 2 X x)) :
+    hurewiczInverse x (SecondHurewicz.hurewiczMap x a) = a := by
+  change
+    hurewiczInverse x (SecondHurewicz.hurewiczMap x (Additive.ofMul (Additive.toMul a))) =
+      Additive.ofMul (Additive.toMul a)
+  refine Quotient.inductionOn (Additive.toMul a) ?_
+  intro p
+  exact hurewiczInverse_hurewiczMap_mk x p
+
+private theorem SecondHurewicz.SimplyConnected.hurewiczInverse_comp_hurewiczMap {X : Type}
+    [TopologicalSpace X] [SimplyConnectedSpace X] (x : X) :
+    (hurewiczInverse x).comp (SecondHurewicz.hurewiczMap x) = LinearMap.id := by
+  ext a
+  exact hurewiczInverse_hurewiczMap x a
+
+
+private def SecondHurewicz.SimplyConnected.hurewiczPi2Equiv {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) :
+    π_ 2 X x ≃* Multiplicative (SingularMayerVietoris.SingularHomology X 2)
+    where
+  __ := SecondHurewicz.hurewiczPi2 x
+  invFun c := Additive.toMul (hurewiczInverse x (Multiplicative.toAdd c))
+  left_inv a := congrArg Additive.toMul (hurewiczInverse_hurewiczMap x (Additive.ofMul a))
+  right_inv
+    c := congrArg Multiplicative.ofAdd (hurewiczMap_hurewiczInverse x (Multiplicative.toAdd c))
+
+private theorem
+    ThirdHurewicz.gluedBoundaryMap_constant_value {X : Type} [TopologicalSpace X] {n : ℕ}
+    (f : C(FirstHurewicz.Simplex n, X))
+    (g : C((unitInterval) × SecondHurewicz.SimplyConnected.SimplexBoundary n, X))
+    (h₀ : ∀ s, g (0, s) = f s.val) (x : X) (hf : ∀ s, f s = x) (hg : ∀ u, g u = x)
+    (u : ↥(SecondHurewicz.SimplyConnected.bottomOrSide n)) :
+    SecondHurewicz.SimplyConnected.gluedBoundaryMap f g h₀ u = x := by
+  rcases u.property with hb | hs
+  · have hu : u = SecondHurewicz.SimplyConnected.bottomInclusion n u.val.2 := by
+      apply Subtype.ext
+      exact Prod.ext hb rfl
+    exact
+      (congrArg (SecondHurewicz.SimplyConnected.gluedBoundaryMap f g h₀) hu).trans
+        ((SecondHurewicz.SimplyConnected.gluedBoundaryMap_bottomInclusion f g h₀ _).trans (hf _))
+  · have hu : u = SecondHurewicz.SimplyConnected.sideInclusion n (u.val.1, ⟨u.val.2, hs⟩) := by
+      apply Subtype.ext
+      rfl
+    exact
+      (congrArg (SecondHurewicz.SimplyConnected.gluedBoundaryMap f g h₀) hu).trans
+        ((SecondHurewicz.SimplyConnected.gluedBoundaryMap_sideInclusion f g h₀ _).trans (hg _))
+
+private theorem
+    ThirdHurewicz.coherentFaceBoundaryHomotopy_const {X : Type} [TopologicalSpace X] {n : ℕ}
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (h : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H H') (x : X)
+    (hc :
+      H' (ContinuousMap.const (FirstHurewicz.Simplex (n + 1)) x) =
+        ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex (n + 1)) x) :
+    SecondHurewicz.SimplyConnected.coherentFaceBoundaryHomotopy H H' h
+        (ContinuousMap.const (FirstHurewicz.Simplex (n + 2)) x) =
+      ContinuousMap.const
+        ((unitInterval) × SecondHurewicz.SimplyConnected.SimplexBoundary (n + 2)) x := by
+  unfold SecondHurewicz.SimplyConnected.coherentFaceBoundaryHomotopy
+  apply
+    (SecondHurewicz.SimplyConnected.glueFaceHomotopies_unique _ _ (ContinuousMap.const _ x)
+        ?_).symm
+  intro i r s
+  change x = H' (ContinuousMap.const (FirstHurewicz.Simplex (n + 1)) x) (r, s)
+  rw [hc]
+  rfl
+
+private theorem
+    ThirdHurewicz.extendCoherentSimplexHomotopy_const {X : Type} [TopologicalSpace X] {n : ℕ}
+    (H : FirstHurewicz.SingularSimplex X n → C((unitInterval) × FirstHurewicz.Simplex n, X))
+    (H' :
+      FirstHurewicz.SingularSimplex X (n + 1) →
+        C((unitInterval) × FirstHurewicz.Simplex (n + 1), X))
+    (h : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies n H H')
+    (h₀ : ∀ smp s, H' smp (0, s) = smp s) (x : X)
+    (hc :
+      H' (ContinuousMap.const (FirstHurewicz.Simplex (n + 1)) x) =
+        ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex (n + 1)) x) :
+    SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy H H' h h₀
+        (ContinuousMap.const (FirstHurewicz.Simplex (n + 2)) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex (n + 2)) x := by
+  unfold SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy
+  ext u
+  change
+    SecondHurewicz.SimplyConnected.gluedBoundaryMap
+        (ContinuousMap.const (FirstHurewicz.Simplex (n + 2)) x)
+        (SecondHurewicz.SimplyConnected.coherentFaceBoundaryHomotopy H H' h
+          (ContinuousMap.const (FirstHurewicz.Simplex (n + 2)) x))
+        (SecondHurewicz.SimplyConnected.coherentFaceBoundaryHomotopy_zero H H' h h₀
+          (ContinuousMap.const (FirstHurewicz.Simplex (n + 2)) x))
+        (SecondHurewicz.SimplyConnected.cylinderRetraction (n + 2) u) =
+      x
+  apply gluedBoundaryMap_constant_value _ _ _ x (fun _ => rfl)
+  intro v
+  exact
+    congrArg
+      (fun F : C((unitInterval) × SecondHurewicz.SimplyConnected.SimplexBoundary (n + 2), X) =>
+        F v)
+      (coherentFaceBoundaryHomotopy_const H H' h x hc)
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Hurewicz/SixthHurewicz.lean b/LeanPool/HopfProblem/Hurewicz/SixthHurewicz.lean
new file mode 100644
index 000000000..2333f432d
--- /dev/null
+++ b/LeanPool/HopfProblem/Hurewicz/SixthHurewicz.lean
@@ -0,0 +1,1524 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.CuspFibre.CuspNegation
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology4
+import all LeanPool.HopfProblem.Hurewicz.SecondHurewicz
+import all LeanPool.HopfProblem.Hurewicz.ThirdHurewicz
+import all LeanPool.HopfProblem.Hurewicz.HigherHurewicz1
+import all LeanPool.HopfProblem.Hurewicz.HigherHurewicz2
+import all LeanPool.HopfProblem.CuspFibre.CuspNegation
+
+/-!
+# Hopf problem: hurewicz · sixth hurewicz
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def SixthHurewicz.lowerSevenSimplexHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] (smp : FirstHurewicz.SingularSimplex X 7) :
+    C((unitInterval) × FirstHurewicz.Simplex 7, X) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy
+    (FifthHurewicz.normalizationFiveSimplexHomotopy x)
+    (FifthHurewicz.normalizationSixSimplexHomotopy x)
+    (FifthHurewicz.normalizationSixHomotopy_face x)
+    (FifthHurewicz.normalizationSixSimplexHomotopy_zero x) smp
+
+@[simp]
+private theorem SixthHurewicz.lowerSevenSimplexHomotopy_zero {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] (smp : FirstHurewicz.SingularSimplex X 7)
+    (s : FirstHurewicz.Simplex 7) : lowerSevenSimplexHomotopy x smp (0, s) = smp s :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_zero _ _ _ _ smp s
+
+private theorem SixthHurewicz.lowerSevenSimplexHomotopy_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 6
+      (FifthHurewicz.normalizationSixSimplexHomotopy x) (lowerSevenSimplexHomotopy x) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_face
+    (FifthHurewicz.normalizationFiveSimplexHomotopy x)
+    (FifthHurewicz.normalizationSixSimplexHomotopy x)
+    (FifthHurewicz.normalizationSixHomotopy_face x)
+    (FifthHurewicz.normalizationSixSimplexHomotopy_zero x)
+
+private def SixthHurewicz.fiveSixSimplexHomotopy {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 5 X x)] (smp : FirstHurewicz.SingularSimplex X 6) :
+    C((unitInterval) × FirstHurewicz.Simplex 6, X) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy
+    (SecondHurewicz.SimplyConnected.stationarySimplexHomotopy 4)
+    (HigherHurewicz.simplexStraighteningHomotopy 5 x)
+    (HigherHurewicz.simplexStraighteningHomotopy_face 4 x)
+    (HigherHurewicz.simplexStraighteningHomotopy_zero 5 x) smp
+
+@[simp]
+private theorem SixthHurewicz.fiveSixSimplexHomotopy_zero {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 5 X x)] (smp : FirstHurewicz.SingularSimplex X 6)
+    (s : FirstHurewicz.Simplex 6) : fiveSixSimplexHomotopy x smp (0, s) = smp s :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_zero _ _ _ _ smp s
+
+private theorem SixthHurewicz.fiveSixSimplexHomotopy_face {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 5 X x)] :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 5
+      (HigherHurewicz.simplexStraighteningHomotopy 5 x) (fiveSixSimplexHomotopy x) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_face
+    (SecondHurewicz.SimplyConnected.stationarySimplexHomotopy 4)
+    (HigherHurewicz.simplexStraighteningHomotopy 5 x)
+    (HigherHurewicz.simplexStraighteningHomotopy_face 4 x)
+    (HigherHurewicz.simplexStraighteningHomotopy_zero 5 x)
+
+private def SixthHurewicz.fiveSevenSimplexHomotopy {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 5 X x)] (smp : FirstHurewicz.SingularSimplex X 7) :
+    C((unitInterval) × FirstHurewicz.Simplex 7, X) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy
+    (HigherHurewicz.simplexStraighteningHomotopy 5 x) (fiveSixSimplexHomotopy x)
+    (fiveSixSimplexHomotopy_face x) (fiveSixSimplexHomotopy_zero x) smp
+
+@[simp]
+private theorem SixthHurewicz.fiveSevenSimplexHomotopy_zero {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 5 X x)] (smp : FirstHurewicz.SingularSimplex X 7)
+    (s : FirstHurewicz.Simplex 7) : fiveSevenSimplexHomotopy x smp (0, s) = smp s :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_zero _ _ _ _ smp s
+
+private theorem SixthHurewicz.fiveSevenSimplexHomotopy_face {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 5 X x)] :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 6 (fiveSixSimplexHomotopy x)
+      (fiveSevenSimplexHomotopy x) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_face
+    (HigherHurewicz.simplexStraighteningHomotopy 5 x) (fiveSixSimplexHomotopy x)
+    (fiveSixSimplexHomotopy_face x) (fiveSixSimplexHomotopy_zero x)
+
+private def SixthHurewicz.normalizationFiveSimplexHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] :
+    FirstHurewicz.SingularSimplex X 5 → C((unitInterval) × FirstHurewicz.Simplex 5, X) :=
+  ThirdHurewicz.composeSimplexHomotopies (FifthHurewicz.normalizationFiveSimplexHomotopy x)
+    (HigherHurewicz.simplexStraighteningHomotopy 5 x)
+    (FifthHurewicz.normalizationFiveSimplexHomotopy_zero x)
+    (HigherHurewicz.simplexStraighteningHomotopy_zero 5 x)
+
+private def SixthHurewicz.normalizationSixSimplexHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] :
+    FirstHurewicz.SingularSimplex X 6 → C((unitInterval) × FirstHurewicz.Simplex 6, X) :=
+  ThirdHurewicz.composeSimplexHomotopies (FifthHurewicz.normalizationSixSimplexHomotopy x)
+    (fiveSixSimplexHomotopy x) (FifthHurewicz.normalizationSixSimplexHomotopy_zero x)
+    (fiveSixSimplexHomotopy_zero x)
+
+private def SixthHurewicz.normalizationSevenSimplexHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] :
+    FirstHurewicz.SingularSimplex X 7 → C((unitInterval) × FirstHurewicz.Simplex 7, X) :=
+  ThirdHurewicz.composeSimplexHomotopies (lowerSevenSimplexHomotopy x)
+    (fiveSevenSimplexHomotopy x) (lowerSevenSimplexHomotopy_zero x)
+    (fiveSevenSimplexHomotopy_zero x)
+
+@[simp]
+private theorem SixthHurewicz.normalizationSixSimplexHomotopy_zero {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] (smp : FirstHurewicz.SingularSimplex X 6)
+    (s : FirstHurewicz.Simplex 6) : normalizationSixSimplexHomotopy x smp (0, s) = smp s :=
+  ThirdHurewicz.composeSimplexHomotopies_zero _ _ _ _ smp s
+
+private theorem SixthHurewicz.normalizationHomotopy_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 5 (normalizationFiveSimplexHomotopy x)
+      (normalizationSixSimplexHomotopy x) :=
+  ThirdHurewicz.composeSimplexHomotopies_face (FifthHurewicz.normalizationFiveSimplexHomotopy x)
+    (HigherHurewicz.simplexStraighteningHomotopy 5 x)
+    (FifthHurewicz.normalizationSixSimplexHomotopy x) (fiveSixSimplexHomotopy x)
+    (FifthHurewicz.normalizationFiveSimplexHomotopy_zero x)
+    (HigherHurewicz.simplexStraighteningHomotopy_zero 5 x)
+    (FifthHurewicz.normalizationSixSimplexHomotopy_zero x) (fiveSixSimplexHomotopy_zero x)
+    (FifthHurewicz.normalizationSixHomotopy_face x) (fiveSixSimplexHomotopy_face x)
+
+private theorem SixthHurewicz.normalizationSevenHomotopy_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 6 (normalizationSixSimplexHomotopy x)
+      (normalizationSevenSimplexHomotopy x) :=
+  ThirdHurewicz.composeSimplexHomotopies_face (FifthHurewicz.normalizationSixSimplexHomotopy x)
+    (fiveSixSimplexHomotopy x) (lowerSevenSimplexHomotopy x) (fiveSevenSimplexHomotopy x)
+    (FifthHurewicz.normalizationSixSimplexHomotopy_zero x) (fiveSixSimplexHomotopy_zero x)
+    (lowerSevenSimplexHomotopy_zero x) (fiveSevenSimplexHomotopy_zero x)
+    (lowerSevenSimplexHomotopy_face x) (fiveSevenSimplexHomotopy_face x)
+
+@[simp]
+private theorem SixthHurewicz.normalizationFiveSimplexHomotopy_const {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] :
+    normalizationFiveSimplexHomotopy x (ContinuousMap.const (FirstHurewicz.Simplex 5) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 5) x :=
+  ThirdHurewicz.composeSimplexHomotopies_const (FifthHurewicz.normalizationFiveSimplexHomotopy x)
+    (HigherHurewicz.simplexStraighteningHomotopy 5 x)
+    (FifthHurewicz.normalizationFiveSimplexHomotopy_zero x)
+    (HigherHurewicz.simplexStraighteningHomotopy_zero 5 x) x
+    (FifthHurewicz.normalizationFiveSimplexHomotopy_const x)
+    (HigherHurewicz.simplexStraighteningHomotopy_const 5 x)
+
+@[simp]
+private theorem
+    SixthHurewicz.normalizationFiveSimplexHomotopy_endpoint {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 5) :
+    SecondHurewicz.SimplyConnected.timeSlice (normalizationFiveSimplexHomotopy x smp) 1 =
+      ContinuousMap.const (FirstHurewicz.Simplex 5) x := by
+  rw [normalizationFiveSimplexHomotopy, ThirdHurewicz.timeSlice_composeSimplexHomotopies_one,
+    FifthHurewicz.normalizationFiveSimplexHomotopy_endpoint]
+  ext s
+  exact
+    HigherHurewicz.simplexStraighteningHomotopy_one 5 x
+      (FifthHurewicz.normalizedFiveSimplex x smp).val
+      (FifthHurewicz.normalizedFiveSimplex x smp).property s
+
+private abbrev SixthHurewicz.sixSimplexBoundary : Set (FirstHurewicz.Simplex 6) :=
+  SecondHurewicz.SimplyConnected.simplexBoundary 6
+
+private abbrev SixthHurewicz.BasedSixSimplex {X : Type*} [TopologicalSpace X] (x : X) :=
+  HigherHurewicz.SimplexGeometry.BasedSimplex 6 x
+
+private abbrev SixthHurewicz.basedSixSimplexLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (τ : BasedSixSimplex x) : GenLoop (Fin 6) X x :=
+  HigherHurewicz.SimplexGeometry.basedSimplexLoop τ
+
+private abbrev SixthHurewicz.basedSixSimplexClass {X : Type*} [TopologicalSpace X] {x : X}
+    (τ : BasedSixSimplex x) : Additive (π_ 6 X x) :=
+  HigherHurewicz.SimplexGeometry.basedSimplexClass τ
+
+private theorem SixthHurewicz.basedSixSimplex_face {X : Type*} [TopologicalSpace X] {x : X}
+    (τ : BasedSixSimplex x) (i : Fin 7) :
+    τ.val.comp (FirstHurewicz.simplexFace 5 i) =
+      ContinuousMap.const (FirstHurewicz.Simplex 5) x :=
+  HigherHurewicz.SimplexGeometry.basedSimplex_face τ i
+
+private def
+    SixthHurewicz.normalizedSixSimplex {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] [Subsingleton (π_ 4 X x)]
+    [Subsingleton (π_ 5 X x)] (smp : FirstHurewicz.SingularSimplex X 6) : BasedSixSimplex x :=
+  ⟨SecondHurewicz.SimplyConnected.timeSlice (normalizationSixSimplexHomotopy x smp) 1,
+    HigherHurewicz.simplexEndpoint_boundary (normalizationFiveSimplexHomotopy x)
+      (normalizationSixSimplexHomotopy x) (normalizationHomotopy_face x) x
+      (normalizationFiveSimplexHomotopy_endpoint x) smp⟩
+
+private def SixthHurewicz.normalizedSevenSimplexMap {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 7) : FirstHurewicz.SingularSimplex X 7 :=
+  SecondHurewicz.SimplyConnected.timeSlice (normalizationSevenSimplexHomotopy x smp) 1
+
+private theorem SixthHurewicz.normalizedSevenSimplexMap_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] (smp : FirstHurewicz.SingularSimplex X 7)
+    (i : Fin 8) :
+    (normalizedSevenSimplexMap x smp).comp (FirstHurewicz.simplexFace 6 i) =
+      (normalizedSixSimplex x (smp.comp (FirstHurewicz.simplexFace 6 i))).val :=
+  SecondHurewicz.SimplyConnected.timeSlice_face (normalizationSevenHomotopy_face x) smp i 1
+
+private theorem
+    SixthHurewicz.normalizedSevenSimplexMap_face_boundary {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] (smp : FirstHurewicz.SingularSimplex X 7)
+    (i : Fin 8) (s : FirstHurewicz.Simplex 6) (hs : s ∈ sixSimplexBoundary) :
+    normalizedSevenSimplexMap x smp (FirstHurewicz.simplexFace 6 i s) = x := by
+  have hf :=
+    congrArg (fun f : C(FirstHurewicz.Simplex 6, X) => f s)
+      (normalizedSevenSimplexMap_face x smp i)
+  exact
+    hf.trans ((normalizedSixSimplex x (smp.comp (FirstHurewicz.simplexFace 6 i))).property s hs)
+
+private def
+    SixthHurewicz.sixSimplexClassOperator {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] [Subsingleton (π_ 4 X x)]
+    [Subsingleton (π_ 5 X x)] : FirstHurewicz.Chains X 6 →ₗ[ℤ] Additive (π_ 6 X x) :=
+  FirstHurewicz.chainLift X 6 fun smp => basedSixSimplexClass (normalizedSixSimplex x smp)
+
+@[simp]
+private theorem SixthHurewicz.sixSimplexClassOperator_simplex {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 6) :
+    sixSimplexClassOperator x (FirstHurewicz.simplexChain X 6 smp) =
+      basedSixSimplexClass (normalizedSixSimplex x smp) :=
+  FirstHurewicz.chainLift_simplex X 6 _ smp
+
+private abbrev SixthHurewicz.BasedSevenSimplex {X : Type*} [TopologicalSpace X] (x : X) :=
+  HigherHurewicz.SimplexGeometry.BasedSimplexBoundary 7 x
+
+private abbrev SixthHurewicz.basedSevenSimplexFace {X : Type*} [TopologicalSpace X] {x : X}
+    (τ : BasedSevenSimplex x) (i : Fin 8) : BasedSixSimplex x :=
+  HigherHurewicz.SimplexGeometry.basedSimplexBoundaryFace τ i
+
+private def SixthHurewicz.BasedSevenSimplex.ofFaces {X : Type*} [TopologicalSpace X] {x : X}
+    (τ : C(FirstHurewicz.Simplex 7, X))
+    (h :
+      ∀ i : Fin 8,
+        ∀ s ∈ SixthHurewicz.sixSimplexBoundary, (τ.comp (FirstHurewicz.simplexFace 6 i)) s = x) :
+    SixthHurewicz.BasedSevenSimplex x :=
+  HigherHurewicz.SimplexGeometry.BasedSimplexBoundary.ofFaces τ h
+
+private theorem
+    SixthHurewicz.basedSevenSimplex_signed_relation {X : Type*} [TopologicalSpace X] {x : X}
+    (τ : BasedSevenSimplex x) :
+    (∑ i : Fin 8, (-1 : ℤ) ^ i.val • basedSixSimplexClass (basedSevenSimplexFace τ i)) = 0 :=
+  HigherHurewicz.SimplexGeometry.basedSimplexBoundary_signed_relation (n := 4) τ
+
+private def
+    SixthHurewicz.normalizedSevenSimplex {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] [Subsingleton (π_ 4 X x)]
+    [Subsingleton (π_ 5 X x)] (smp : FirstHurewicz.SingularSimplex X 7) : BasedSevenSimplex x :=
+  BasedSevenSimplex.ofFaces (normalizedSevenSimplexMap x smp)
+    (normalizedSevenSimplexMap_face_boundary x smp)
+
+@[simp]
+private theorem SixthHurewicz.normalizedSevenSimplex_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] (smp : FirstHurewicz.SingularSimplex X 7)
+    (i : Fin 8) :
+    basedSevenSimplexFace (normalizedSevenSimplex x smp) i =
+      normalizedSixSimplex x (smp.comp (FirstHurewicz.simplexFace 6 i)) := by
+  apply Subtype.ext
+  exact normalizedSevenSimplexMap_face x smp i
+
+private theorem SixthHurewicz.normalizedSixSimplex_boundary_relation {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 7) :
+    ∑ i : Fin 8,
+        (-1 : ℤ) ^ i.val •
+          basedSixSimplexClass
+            (normalizedSixSimplex x (smp.comp (FirstHurewicz.simplexFace 6 i))) =
+      0 := by
+  simpa only [normalizedSevenSimplex_face] using
+    basedSevenSimplex_signed_relation (normalizedSevenSimplex x smp)
+
+private theorem SixthHurewicz.sixSimplexClassOperator_boundary {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] (b : FirstHurewicz.Chains X 7) :
+    sixSimplexClassOperator x (((FirstHurewicz.singularComplex X).d 7 6).hom b) = 0 := by
+  have h : (sixSimplexClassOperator x).comp ((FirstHurewicz.singularComplex X).d 7 6).hom = 0 := by
+    apply FirstHurewicz.chainMap_ext X 7
+    intro smp
+    simp only [LinearMap.comp_apply, FirstHurewicz.boundary_simplex, map_sum, map_zsmul,
+      sixSimplexClassOperator_simplex, LinearMap.zero_apply]
+    exact normalizedSixSimplex_boundary_relation x smp
+  exact LinearMap.congr_fun h b
+
+private def
+    SixthHurewicz.normalizedCube {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X] (x : X)
+    [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] [Subsingleton (π_ 4 X x)]
+    [Subsingleton (π_ 5 X x)] (p : GenLoop (Fin 6) X x) : GenLoop (Fin 6) X x :=
+  HigherHurewicz.CubeGluing.coherentCubeEndpoint (normalizationFiveSimplexHomotopy x)
+    (normalizationSixSimplexHomotopy x) (normalizationHomotopy_face x)
+    (normalizationFiveSimplexHomotopy_const x) p
+
+private theorem
+    SixthHurewicz.normalizedCube_cell {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] [Subsingleton (π_ 4 X x)]
+    [Subsingleton (π_ 5 X x)] (p : GenLoop (Fin 6) X x) (e : Equiv.Perm (Fin 6)) :
+    (normalizedCube x p).val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e) =
+      (normalizedSixSimplex x
+          (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e))).val :=
+  HigherHurewicz.CubeGluing.coherentCubeEndpoint_cell (normalizationFiveSimplexHomotopy x)
+    (normalizationSixSimplexHomotopy x) (normalizationHomotopy_face x)
+    (normalizationFiveSimplexHomotopy_const x) p e
+
+private def SixthHurewicz.normalizationCubeHomotopy {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] (p : GenLoop (Fin 6) X x) :
+    p.val.HomotopyRel (normalizedCube x p).val (Cube.boundary (Fin 6)) :=
+  HigherHurewicz.CubeGluing.coherentCubeHomotopy (normalizationFiveSimplexHomotopy x)
+    (normalizationSixSimplexHomotopy x) (normalizationHomotopy_face x)
+    (normalizationFiveSimplexHomotopy_const x) (normalizationSixSimplexHomotopy_zero x) p
+
+private theorem SixthHurewicz.normalizedCube_internalBased {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] (p : GenLoop (Fin 6) X x)
+    (u : Fin 6 → (unitInterval)) (i j : Fin 6) (hij : i ≠ j) (hu : u i = u j) :
+    normalizedCube x p u = x :=
+  HigherHurewicz.coherentCubeEndpoint_internalBased (normalizationFiveSimplexHomotopy x)
+    (normalizationSixSimplexHomotopy x) (normalizationHomotopy_face x)
+    (normalizationFiveSimplexHomotopy_const x) (normalizationFiveSimplexHomotopy_endpoint x) p u i
+    j hij hu
+
+private theorem SixthHurewicz.normalizedCube_simplex {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] (p : GenLoop (Fin 6) X x)
+    (e : Equiv.Perm (Fin 6)) :
+    HigherHurewicz.NativeSubdivision.nativeBasedCubeSimplex (normalizedCube x p)
+        (normalizedCube_internalBased x p) e =
+      normalizedSixSimplex x (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e)) := by
+  apply Subtype.ext
+  exact normalizedCube_cell x p e
+
+private abbrev SixthHurewicz.Remaining :=
+  { j : Fin 6 // j ≠ 0 }
+
+private def
+    SixthHurewicz.remainingCoordinates : C(Fin 5 → (unitInterval), Remaining → (unitInterval))
+    where
+  toFun u j := u (j.val.pred j.property)
+  continuous_toFun := by fun_prop
+
+@[simp]
+private theorem SixthHurewicz.remainingCoordinates_succ (u : Fin 5 → (unitInterval)) (i : Fin 5) :
+    remainingCoordinates u ⟨i.succ, Fin.succ_ne_zero i⟩ = u i := by simp [remainingCoordinates]
+
+private theorem SixthHurewicz.remainingCoordinates_boundary {u : Fin 5 → (unitInterval)}
+    (h : u ∈ Cube.boundary (Fin 5)) : remainingCoordinates u ∈ Cube.boundary Remaining := by
+  obtain ⟨i, hi⟩ := h
+  exact ⟨⟨i.succ, Fin.succ_ne_zero i⟩, by simpa using hi⟩
+
+private abbrev SixthHurewicz.BasedLoopSpace {X : Type} [TopologicalSpace X] (x : X) :=
+  GenLoop Remaining X x
+
+private def SixthHurewicz.evaluation {X : Type} [TopologicalSpace X] (x : X) :
+    C(BasedLoopSpace x × (Fin 5 → (unitInterval)), X)
+    where
+  toFun z := z.1 (remainingCoordinates z.2)
+  continuous_toFun := by fun_prop
+
+private theorem SixthHurewicz.evaluation_boundary {X : Type} [TopologicalSpace X] (x : X)
+    (p : BasedLoopSpace x) (u : Fin 5 → (unitInterval)) (hu : u ∈ Cube.boundary (Fin 5)) :
+    evaluation x (p, u) = x :=
+  GenLoop.boundary p _ (remainingCoordinates_boundary hu)
+
+private theorem SixthHurewicz.evaluation_comp_boundary {X : Type} [TopologicalSpace X] {A : Type}
+    [TopologicalSpace A] (x : X) (f : C(A, Fin 5 → (unitInterval)))
+    (hf : ∀ a, f a ∈ Cube.boundary (Fin 5)) :
+    (evaluation x).comp ((ContinuousMap.id (BasedLoopSpace x)).prodMap f) =
+      ContinuousMap.const (BasedLoopSpace x × A) x := by
+  ext z
+  exact evaluation_boundary x z.1 (f z.2) (hf z.2)
+
+private def SixthHurewicz.cubeCoordinates :
+    C((unitInterval) × (Fin 5 → (unitInterval)), Fin 6 → (unitInterval))
+    where
+  toFun z := Cube.insertAt (0 : Fin 6) (z.1, remainingCoordinates z.2)
+  continuous_toFun := by fun_prop
+
+@[simp]
+private theorem SixthHurewicz.cubeCoordinates_zero (z : (unitInterval) × (Fin 5 → (unitInterval))) :
+    cubeCoordinates z 0 = z.1 := by
+  simp [cubeCoordinates, Cube.insertAt, Homeomorph.funSplitAt_symm_apply]
+
+@[simp]
+private theorem SixthHurewicz.cubeCoordinates_succ (z : (unitInterval) × (Fin 5 → (unitInterval)))
+    (i : Fin 5) : cubeCoordinates z i.succ = z.2 i := by
+  simp [cubeCoordinates, Cube.insertAt, Homeomorph.funSplitAt_symm_apply, remainingCoordinates]
+
+private def
+    SixthHurewicz.cubeMap {X : Type} [TopologicalSpace X] {x : X} (p : GenLoop (Fin 6) X x) :
+    C((unitInterval) × (Fin 5 → (unitInterval)), X) :=
+  p.val.comp cubeCoordinates
+
+private theorem SixthHurewicz.evaluation_comp_toLoop {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 6) X x) :
+    (evaluation x).comp
+        ((GenLoop.toLoop (0 : Fin 6) p).toContinuousMap.prodMap
+          (ContinuousMap.id (Fin 5 → (unitInterval)))) =
+      cubeMap p := by
+  ext z
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SixthHurewicz.remainingCubeSideFirst (t : (unitInterval)) :
+    C(Fin 4 → (unitInterval), Fin 5 → (unitInterval)) :=
+  FifthHurewicz.cubeCoordinates.comp (PeriodTorusHigherHomology.crossInsertLeft t)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SixthHurewicz.remainingCubeSide {A : Type} [TopologicalSpace A]
+    (f : C(A, Fin 4 → (unitInterval))) : C((unitInterval) × A, Fin 5 → (unitInterval)) :=
+  FifthHurewicz.cubeCoordinates.comp ((ContinuousMap.id (unitInterval)).prodMap f)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    SixthHurewicz.remainingCubeSideFirst_boundary (t : (unitInterval)) (ht : t = 0 ∨ t = 1)
+    (u : Fin 4 → (unitInterval)) : remainingCubeSideFirst t u ∈ Cube.boundary (Fin 5) := by
+  refine ⟨0, ?_⟩
+  change FifthHurewicz.cubeCoordinates (t, u) 0 = 0 ∨ FifthHurewicz.cubeCoordinates (t, u) 0 = 1
+  simpa only [FifthHurewicz.cubeCoordinates_zero] using ht
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SixthHurewicz.remainingCubeSide_boundary {A : Type} [TopologicalSpace A]
+    (f : C(A, Fin 4 → (unitInterval))) (hf : ∀ a, f a ∈ Cube.boundary (Fin 4))
+    (z : (unitInterval) × A) : remainingCubeSide f z ∈ Cube.boundary (Fin 5) := by
+  obtain ⟨i, hi⟩ := hf z.2
+  refine ⟨i.succ, ?_⟩
+  change
+    FifthHurewicz.cubeCoordinates (z.1, f z.2) i.succ = 0 ∨
+      FifthHurewicz.cubeCoordinates (z.1, f z.2) i.succ = 1
+  simpa only [FifthHurewicz.cubeCoordinates_succ] using hi
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SixthHurewicz.remainingCubeSide_chain {A : Type} [TopologicalSpace A] (k : ℕ)
+    (f : C(A, Fin 4 → (unitInterval))) (b : FirstHurewicz.Chains A k) :
+    FirstHurewicz.inducedChain FifthHurewicz.cubeCoordinates (k + 1)
+        (PeriodTorusHigherHomology.crossProductEdge (unitInterval) (Fin 4 → (unitInterval)) k
+          SecondHurewicz.intervalChain (FirstHurewicz.inducedChain f k b)) =
+      FirstHurewicz.inducedChain (remainingCubeSide f) (k + 1)
+        (PeriodTorusHigherHomology.crossProductEdge (unitInterval) A k
+          SecondHurewicz.intervalChain b) := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductEdge_natural (ContinuousMap.id (unitInterval)) f k
+      SecondHurewicz.intervalChain b
+  rw [FirstHurewicz.inducedChain_id, LinearMap.id_apply] at h
+  rw [← h]
+  change
+    ((FirstHurewicz.inducedChain FifthHurewicz.cubeCoordinates (k + 1)).comp
+          (FirstHurewicz.inducedChain ((ContinuousMap.id (unitInterval)).prodMap f) (k + 1)))
+        _ =
+      _
+  rw [← FirstHurewicz.inducedChain_comp]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SixthHurewicz.productTwoIntervalSquareChain :
+    FirstHurewicz.Chains ((unitInterval) × ((unitInterval) × (Fin 2 → (unitInterval)))) 4 :=
+  PeriodTorusHigherHomology.crossProductEdge (unitInterval)
+    ((unitInterval) × (Fin 2 → (unitInterval))) 3 SecondHurewicz.intervalChain
+    ThirdHurewicz.productCubeChain
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SixthHurewicz.productFourIntervalChain :
+    FirstHurewicz.Chains ((unitInterval) × ((unitInterval) × ((unitInterval) × (unitInterval))))
+      4 :=
+  PeriodTorusHigherHomology.crossProductEdge (unitInterval)
+    ((unitInterval) × ((unitInterval) × (unitInterval))) 3 SecondHurewicz.intervalChain
+    FifthHurewicz.productThreeIntervalChain
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SixthHurewicz.remainingCubeChain_boundary :
+    ((FirstHurewicz.singularComplex (Fin 5 → (unitInterval))).d 5 4).hom
+        FifthHurewicz.fundamentalCubeChain =
+      FirstHurewicz.inducedChain (remainingCubeSideFirst 1) 4
+            FourthHurewicz.fundamentalCubeChain -
+          FirstHurewicz.inducedChain (remainingCubeSideFirst 0) 4
+            FourthHurewicz.fundamentalCubeChain -
+        (FirstHurewicz.inducedChain (remainingCubeSide (FifthHurewicz.remainingCubeSideFirst 1)) 4
+              FourthHurewicz.productCubeChain -
+            FirstHurewicz.inducedChain
+              (remainingCubeSide (FifthHurewicz.remainingCubeSideFirst 0)) 4
+              FourthHurewicz.productCubeChain -
+          (FirstHurewicz.inducedChain
+                (remainingCubeSide
+                  (FifthHurewicz.remainingCubeSide (FourthHurewicz.remainingCubeSideFirst 1)))
+                4 productTwoIntervalSquareChain -
+              FirstHurewicz.inducedChain
+                (remainingCubeSide
+                  (FifthHurewicz.remainingCubeSide (FourthHurewicz.remainingCubeSideFirst 0)))
+                4 productTwoIntervalSquareChain -
+            (FirstHurewicz.inducedChain
+                  (remainingCubeSide
+                    (FifthHurewicz.remainingCubeSide
+                      (FourthHurewicz.remainingCubeSide (ThirdHurewicz.squareSideLeft 1))))
+                  4 productFourIntervalChain -
+                FirstHurewicz.inducedChain
+                  (remainingCubeSide
+                    (FifthHurewicz.remainingCubeSide
+                      (FourthHurewicz.remainingCubeSide (ThirdHurewicz.squareSideLeft 0))))
+                  4 productFourIntervalChain -
+              (FirstHurewicz.inducedChain
+                  (remainingCubeSide
+                    (FifthHurewicz.remainingCubeSide
+                      (FourthHurewicz.remainingCubeSide (ThirdHurewicz.squareSideRight 1))))
+                  4 productFourIntervalChain -
+                FirstHurewicz.inducedChain
+                  (remainingCubeSide
+                    (FifthHurewicz.remainingCubeSide
+                      (FourthHurewicz.remainingCubeSide (ThirdHurewicz.squareSideRight 0))))
+                  4 productFourIntervalChain)))) := by
+  have hpoint (t : (unitInterval)) :
+    PeriodTorusHigherHomology.crossProductZeroLeft (unitInterval) (Fin 4 → (unitInterval)) 4
+        (FirstHurewicz.pointChain t) FourthHurewicz.fundamentalCubeChain =
+      FirstHurewicz.inducedChain (PeriodTorusHigherHomology.crossInsertLeft t) 4
+        FourthHurewicz.fundamentalCubeChain := by
+    rw [FirstHurewicz.pointChain, PeriodTorusHigherHomology.crossProductZeroLeft_simplex_left]
+    rfl
+  have hfirst (t : (unitInterval)) :
+    FirstHurewicz.inducedChain FifthHurewicz.cubeCoordinates 4
+        (FirstHurewicz.inducedChain (PeriodTorusHigherHomology.crossInsertLeft t) 4
+          FourthHurewicz.fundamentalCubeChain) =
+      FirstHurewicz.inducedChain (remainingCubeSideFirst t) 4
+        FourthHurewicz.fundamentalCubeChain := by
+    rw [remainingCubeSideFirst, FirstHurewicz.inducedChain_comp]
+    rfl
+  rw [FifthHurewicz.fundamentalCubeChain, ← FirstHurewicz.inducedChain_boundary]
+  change
+    FirstHurewicz.inducedChain FifthHurewicz.cubeCoordinates 4
+        (((FirstHurewicz.singularComplex ((unitInterval) × (Fin 4 → (unitInterval)))).d 5 4).hom
+          (PeriodTorusHigherHomology.crossProductEdge (unitInterval) (Fin 4 → (unitInterval)) 4
+            SecondHurewicz.intervalChain FourthHurewicz.fundamentalCubeChain)) =
+      _
+  rw [PeriodTorusHigherHomology.crossProductEdge_boundary 3]
+  change
+    FirstHurewicz.inducedChain FifthHurewicz.cubeCoordinates 4
+        (PeriodTorusHigherHomology.crossProductZeroLeft (unitInterval) (Fin 4 → (unitInterval)) 4
+            (FirstHurewicz.boundaryOne (unitInterval) SecondHurewicz.intervalChain)
+            FourthHurewicz.fundamentalCubeChain -
+          PeriodTorusHigherHomology.crossProductEdge (unitInterval) (Fin 4 → (unitInterval)) 3
+            SecondHurewicz.intervalChain
+            (((FirstHurewicz.singularComplex (Fin 4 → (unitInterval))).d 4 3).hom
+              FourthHurewicz.fundamentalCubeChain)) =
+      _
+  rw [SecondHurewicz.intervalChain_boundary, FifthHurewicz.remainingCubeChain_boundary]
+  simp only [map_sub, LinearMap.sub_apply, hpoint, hfirst, remainingCubeSide_chain]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SixthHurewicz.evaluated_edge_boundaryMap {X A : Type} [TopologicalSpace X]
+    [TopologicalSpace A] (x : X) (a : FirstHurewicz.Chains (BasedLoopSpace x) 1) (k : ℕ)
+    (b : FirstHurewicz.Chains A k) (f : C(A, Fin 5 → (unitInterval)))
+    (hf : ∀ t, f t ∈ Cube.boundary (Fin 5)) :
+    FirstHurewicz.inducedChain (evaluation x) (k + 1)
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 5 → (unitInterval)) k
+          a (FirstHurewicz.inducedChain f k b)) =
+      FirstHurewicz.inducedChain (ContinuousMap.const (BasedLoopSpace x × A) x) (k + 1)
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) A k a b) := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductEdge_natural (ContinuousMap.id (BasedLoopSpace x)) f k a
+      b
+  rw [FirstHurewicz.inducedChain_id, LinearMap.id_apply] at h
+  rw [← h]
+  change
+    ((FirstHurewicz.inducedChain (evaluation x) (k + 1)).comp
+          (FirstHurewicz.inducedChain ((ContinuousMap.id (BasedLoopSpace x)).prodMap f) (k + 1)))
+        _ =
+      _
+  rw [← FirstHurewicz.inducedChain_comp, evaluation_comp_boundary x f hf]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SixthHurewicz.evaluated_triangle_boundaryMap {X A : Type} [TopologicalSpace X]
+    [TopologicalSpace A] (x : X) (a : FirstHurewicz.Chains (BasedLoopSpace x) 2) (k : ℕ)
+    (b : FirstHurewicz.Chains A k) (f : C(A, Fin 5 → (unitInterval)))
+    (hf : ∀ t, f t ∈ Cube.boundary (Fin 5)) :
+    FirstHurewicz.inducedChain (evaluation x) (k + 2)
+        (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x)
+          (Fin 5 → (unitInterval)) k a (FirstHurewicz.inducedChain f k b)) =
+      FirstHurewicz.inducedChain (ContinuousMap.const (BasedLoopSpace x × A) x) (k + 2)
+        (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x) A k a b) := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductTriangle_natural (ContinuousMap.id (BasedLoopSpace x)) f
+      k a b
+  rw [FirstHurewicz.inducedChain_id, LinearMap.id_apply] at h
+  rw [← h]
+  change
+    ((FirstHurewicz.inducedChain (evaluation x) (k + 2)).comp
+          (FirstHurewicz.inducedChain ((ContinuousMap.id (BasedLoopSpace x)).prodMap f) (k + 2)))
+        _ =
+      _
+  rw [← FirstHurewicz.inducedChain_comp, evaluation_comp_boundary x f hf]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    SixthHurewicz.evaluated_edge_cubeBoundary_cancel {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 1) :
+    FirstHurewicz.inducedChain (evaluation x) 5
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 5 → (unitInterval)) 4
+          a
+          (((FirstHurewicz.singularComplex (Fin 5 → (unitInterval))).d 5 4).hom
+            FifthHurewicz.fundamentalCubeChain)) =
+      0 := by
+  have hF (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_edge_boundaryMap x a 4 FourthHurewicz.fundamentalCubeChain
+      (remainingCubeSideFirst t) (remainingCubeSideFirst_boundary t ht)
+  have hS (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_edge_boundaryMap x a 4 FourthHurewicz.productCubeChain
+      (remainingCubeSide (FifthHurewicz.remainingCubeSideFirst t))
+      (remainingCubeSide_boundary _ (FifthHurewicz.remainingCubeSideFirst_boundary t ht))
+  have hT (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_edge_boundaryMap x a 4 productTwoIntervalSquareChain
+      (remainingCubeSide
+        (FifthHurewicz.remainingCubeSide (FourthHurewicz.remainingCubeSideFirst t)))
+      (remainingCubeSide_boundary _
+        (FifthHurewicz.remainingCubeSide_boundary _
+          (FourthHurewicz.remainingCubeSideFirst_boundary t ht)))
+  have hL (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_edge_boundaryMap x a 4 productFourIntervalChain
+      (remainingCubeSide
+        (FifthHurewicz.remainingCubeSide
+          (FourthHurewicz.remainingCubeSide (ThirdHurewicz.squareSideLeft t))))
+      (remainingCubeSide_boundary _
+        (FifthHurewicz.remainingCubeSide_boundary _
+          (FourthHurewicz.remainingCubeSide_boundary _
+            (ThirdHurewicz.squareSideLeft_boundary t ht))))
+  have hR (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_edge_boundaryMap x a 4 productFourIntervalChain
+      (remainingCubeSide
+        (FifthHurewicz.remainingCubeSide
+          (FourthHurewicz.remainingCubeSide (ThirdHurewicz.squareSideRight t))))
+      (remainingCubeSide_boundary _
+        (FifthHurewicz.remainingCubeSide_boundary _
+          (FourthHurewicz.remainingCubeSide_boundary _
+            (ThirdHurewicz.squareSideRight_boundary t ht))))
+  simp only [remainingCubeChain_boundary, map_sub, hF 1 (Or.inr rfl), hF 0 (Or.inl rfl),
+    hS 1 (Or.inr rfl), hS 0 (Or.inl rfl), hT 1 (Or.inr rfl), hT 0 (Or.inl rfl), hL 1 (Or.inr rfl),
+    hL 0 (Or.inl rfl), hR 1 (Or.inr rfl), hR 0 (Or.inl rfl), sub_self]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SixthHurewicz.evaluated_triangle_cubeBoundary_cancel {X : Type} [TopologicalSpace X]
+    (x : X) (a : FirstHurewicz.Chains (BasedLoopSpace x) 2) :
+    FirstHurewicz.inducedChain (evaluation x) 6
+        (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x)
+          (Fin 5 → (unitInterval)) 4 a
+          (((FirstHurewicz.singularComplex (Fin 5 → (unitInterval))).d 5 4).hom
+            FifthHurewicz.fundamentalCubeChain)) =
+      0 := by
+  have hF (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_triangle_boundaryMap x a 4 FourthHurewicz.fundamentalCubeChain
+      (remainingCubeSideFirst t) (remainingCubeSideFirst_boundary t ht)
+  have hS (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_triangle_boundaryMap x a 4 FourthHurewicz.productCubeChain
+      (remainingCubeSide (FifthHurewicz.remainingCubeSideFirst t))
+      (remainingCubeSide_boundary _ (FifthHurewicz.remainingCubeSideFirst_boundary t ht))
+  have hT (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_triangle_boundaryMap x a 4 productTwoIntervalSquareChain
+      (remainingCubeSide
+        (FifthHurewicz.remainingCubeSide (FourthHurewicz.remainingCubeSideFirst t)))
+      (remainingCubeSide_boundary _
+        (FifthHurewicz.remainingCubeSide_boundary _
+          (FourthHurewicz.remainingCubeSideFirst_boundary t ht)))
+  have hL (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_triangle_boundaryMap x a 4 productFourIntervalChain
+      (remainingCubeSide
+        (FifthHurewicz.remainingCubeSide
+          (FourthHurewicz.remainingCubeSide (ThirdHurewicz.squareSideLeft t))))
+      (remainingCubeSide_boundary _
+        (FifthHurewicz.remainingCubeSide_boundary _
+          (FourthHurewicz.remainingCubeSide_boundary _
+            (ThirdHurewicz.squareSideLeft_boundary t ht))))
+  have hR (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_triangle_boundaryMap x a 4 productFourIntervalChain
+      (remainingCubeSide
+        (FifthHurewicz.remainingCubeSide
+          (FourthHurewicz.remainingCubeSide (ThirdHurewicz.squareSideRight t))))
+      (remainingCubeSide_boundary _
+        (FifthHurewicz.remainingCubeSide_boundary _
+          (FourthHurewicz.remainingCubeSide_boundary _
+            (ThirdHurewicz.squareSideRight_boundary t ht))))
+  simp only [remainingCubeChain_boundary, map_sub, hF 1 (Or.inr rfl), hF 0 (Or.inl rfl),
+    hS 1 (Or.inr rfl), hS 0 (Or.inl rfl), hT 1 (Or.inr rfl), hT 0 (Or.inl rfl), hL 1 (Or.inr rfl),
+    hL 0 (Or.inl rfl), hR 1 (Or.inr rfl), hR 0 (Or.inl rfl), sub_self]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SixthHurewicz.suspensionOne {X : Type} [TopologicalSpace X] (x : X) :
+    FirstHurewicz.Chains (BasedLoopSpace x) 1 →ₗ[ℤ] FirstHurewicz.Chains X 6 :=
+  (FirstHurewicz.inducedChain (evaluation x) 6).comp
+    (PeriodTorusHigherHomology.integerBilinearRightApply
+      (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 5 → (unitInterval)) 5)
+      FifthHurewicz.fundamentalCubeChain)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem SixthHurewicz.suspensionOne_apply {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 1) :
+    suspensionOne x a =
+      FirstHurewicz.inducedChain (evaluation x) 6
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 5 → (unitInterval)) 5
+          a FifthHurewicz.fundamentalCubeChain) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SixthHurewicz.suspensionTwo {X : Type} [TopologicalSpace X] (x : X) :
+    FirstHurewicz.Chains (BasedLoopSpace x) 2 →ₗ[ℤ] FirstHurewicz.Chains X 7 :=
+  (FirstHurewicz.inducedChain (evaluation x) 7).comp
+    (PeriodTorusHigherHomology.integerBilinearRightApply
+      (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x) (Fin 5 → (unitInterval))
+        5)
+      FifthHurewicz.fundamentalCubeChain)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem SixthHurewicz.suspensionTwo_apply {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 2) :
+    suspensionTwo x a =
+      FirstHurewicz.inducedChain (evaluation x) 7
+        (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x)
+          (Fin 5 → (unitInterval)) 5 a FifthHurewicz.fundamentalCubeChain) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    SixthHurewicz.boundarySix_suspensionOne_of_cycle {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 1)
+    (ha : FirstHurewicz.boundaryOne (BasedLoopSpace x) a = 0) :
+    ((FirstHurewicz.singularComplex X).d 6 5).hom (suspensionOne x a) = 0 := by
+  rw [suspensionOne_apply, ← FirstHurewicz.inducedChain_boundary,
+    PeriodTorusHigherHomology.crossProductEdge_boundary 4]
+  change
+    FirstHurewicz.inducedChain (evaluation x) 5
+        (PeriodTorusHigherHomology.crossProductZeroLeft (BasedLoopSpace x)
+            (Fin 5 → (unitInterval)) 5 (FirstHurewicz.boundaryOne (BasedLoopSpace x) a)
+            FifthHurewicz.fundamentalCubeChain -
+          PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 5 → (unitInterval)) 4
+            a
+            (((FirstHurewicz.singularComplex (Fin 5 → (unitInterval))).d 5 4).hom
+              FifthHurewicz.fundamentalCubeChain)) =
+      0
+  rw [ha, map_zero, LinearMap.zero_apply, zero_sub, map_neg, evaluated_edge_cubeBoundary_cancel,
+    neg_zero]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SixthHurewicz.boundarySeven_suspensionTwo {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 2) :
+    ((FirstHurewicz.singularComplex X).d 7 6).hom (suspensionTwo x a) =
+      suspensionOne x (FirstHurewicz.boundaryTwo (BasedLoopSpace x) a) := by
+  rw [suspensionTwo_apply, ← FirstHurewicz.inducedChain_boundary,
+    PeriodTorusHigherHomology.crossProductTriangle_boundary 4]
+  change
+    FirstHurewicz.inducedChain (evaluation x) 6
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 5 → (unitInterval)) 5
+            (FirstHurewicz.boundaryTwo (BasedLoopSpace x) a) FifthHurewicz.fundamentalCubeChain +
+          PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x)
+            (Fin 5 → (unitInterval)) 4 a
+            (((FirstHurewicz.singularComplex (Fin 5 → (unitInterval))).d 5 4).hom
+              FifthHurewicz.fundamentalCubeChain)) =
+      _
+  rw [map_add, evaluated_triangle_cubeBoundary_cancel, add_zero]
+  rfl
+
+private def SixthHurewicz.pathCubeCycle {X : Type} [TopologicalSpace X] (x : X)
+    (p : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 6 :=
+  SingularMayerVietoris.ModuleHomology.mkCycle (FirstHurewicz.singularComplex X) 6
+    (suspensionOne x (FirstHurewicz.pathChain p))
+    (boundarySix_suspensionOne_of_cycle x (FirstHurewicz.pathChain p)
+      (FirstHurewicz.boundaryOne_loop p))
+
+@[simp]
+private theorem SixthHurewicz.pathCubeCycle_val {X : Type} [TopologicalSpace X] (x : X)
+    (p : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    (pathCubeCycle x p).1 = suspensionOne x (FirstHurewicz.pathChain p) :=
+  rfl
+
+private def SixthHurewicz.pathCubeClass {X : Type} [TopologicalSpace X] (x : X)
+    (p : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    SingularMayerVietoris.SingularHomology X 6 :=
+  SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 6
+    (pathCubeCycle x p)
+
+private theorem SixthHurewicz.pathCube_homotopy_boundary {X : Type} [TopologicalSpace X] (x : X)
+    {p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const} (H : p.Homotopy q) :
+    ((FirstHurewicz.singularComplex X).d 7 6).hom
+        (suspensionTwo x (FirstHurewicz.homotopyChain H)) =
+      (pathCubeCycle x p).1 - (pathCubeCycle x q).1 := by
+  rw [boundarySeven_suspensionTwo, FirstHurewicz.boundaryTwo_loopHomotopy, map_sub]
+  rfl
+
+private theorem SixthHurewicz.pathCubeClass_homotopy {X : Type} [TopologicalSpace X] (x : X)
+    {p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const} (H : p.Homotopy q) :
+    pathCubeClass x p = pathCubeClass x q :=
+  (SingularMayerVietoris.ModuleHomology.cycleClass_eq_iff (FirstHurewicz.singularComplex X) 6 _
+        _).mpr
+    ⟨suspensionTwo x (FirstHurewicz.homotopyChain H), pathCube_homotopy_boundary x H⟩
+
+private theorem SixthHurewicz.pathCubeClass_homotopic {X : Type} [TopologicalSpace X] (x : X)
+    {p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const} (h : p.Homotopic q) :
+    pathCubeClass x p = pathCubeClass x q := by
+  obtain ⟨H⟩ := h
+  exact pathCubeClass_homotopy x H
+
+@[simp]
+private theorem SixthHurewicz.pathCubeClass_refl {X : Type} [TopologicalSpace X] (x : X) :
+    pathCubeClass x (Path.refl (GenLoop.const : BasedLoopSpace x)) = 0 := by
+  apply
+    (SingularMayerVietoris.ModuleHomology.cycleClass_eq_zero_iff (FirstHurewicz.singularComplex X)
+        6 _).mpr
+  refine
+    ⟨suspensionTwo x (FirstHurewicz.constantTriangleChain (GenLoop.const : BasedLoopSpace x)), ?_⟩
+  rw [boundarySeven_suspensionTwo, FirstHurewicz.boundaryTwo_constantTriangleChain]
+  rfl
+
+private theorem SixthHurewicz.pathCube_concat_boundary {X : Type} [TopologicalSpace X] (x : X)
+    (p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    ((FirstHurewicz.singularComplex X).d 7 6).hom
+        (-suspensionTwo x (FirstHurewicz.concatChain p q)) =
+      (pathCubeCycle x (p.trans q)).1 - ((pathCubeCycle x p).1 + (pathCubeCycle x q).1) := by
+  rw [map_neg, boundarySeven_suspensionTwo, FirstHurewicz.boundaryTwo_concatChain, map_add,
+    map_sub]
+  simp only [pathCubeCycle_val]
+  abel
+
+private theorem SixthHurewicz.pathCubeClass_trans {X : Type} [TopologicalSpace X] (x : X)
+    (p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    pathCubeClass x (p.trans q) = pathCubeClass x p + pathCubeClass x q := by
+  unfold pathCubeClass
+  rw [← map_add]
+  apply
+    (SingularMayerVietoris.ModuleHomology.cycleClass_eq_iff (FirstHurewicz.singularComplex X) 6 _
+        _).mpr
+  exact ⟨-suspensionTwo x (FirstHurewicz.concatChain p q), pathCube_concat_boundary x p q⟩
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SixthHurewicz.productCubeChain :
+    FirstHurewicz.Chains ((unitInterval) × (Fin 5 → (unitInterval))) 6 :=
+  PeriodTorusHigherHomology.crossProductEdge (unitInterval) (Fin 5 → (unitInterval)) 5
+    SecondHurewicz.intervalChain FifthHurewicz.fundamentalCubeChain
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SixthHurewicz.fundamentalCubeChain : FirstHurewicz.Chains (Fin 6 → (unitInterval)) 6 :=
+  FirstHurewicz.inducedChain cubeCoordinates 6 productCubeChain
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SixthHurewicz.suspensionOne_toLoop {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 6) X x) :
+    suspensionOne x (FirstHurewicz.pathChain (GenLoop.toLoop (0 : Fin 6) p)) =
+      FirstHurewicz.inducedChain (cubeMap p) 6 productCubeChain := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductEdge_natural
+      (GenLoop.toLoop (0 : Fin 6) p).toContinuousMap (ContinuousMap.id (Fin 5 → (unitInterval))) 5
+      SecondHurewicz.intervalChain FifthHurewicz.fundamentalCubeChain
+  rw [SecondHurewicz.induced_intervalChain, FirstHurewicz.inducedChain_id,
+    LinearMap.id_apply] at h
+  rw [suspensionOne_apply, ← h]
+  change
+    ((FirstHurewicz.inducedChain (evaluation x) 6).comp
+          (FirstHurewicz.inducedChain
+            ((GenLoop.toLoop (0 : Fin 6) p).toContinuousMap.prodMap
+              (ContinuousMap.id (Fin 5 → (unitInterval))))
+            6))
+        productCubeChain =
+      _
+  rw [← FirstHurewicz.inducedChain_comp, evaluation_comp_toLoop]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    SixthHurewicz.cubeChain {X : Type} [TopologicalSpace X] {x : X} (p : GenLoop (Fin 6) X x) :
+    FirstHurewicz.Chains X 6 :=
+  suspensionOne x (FirstHurewicz.pathChain (GenLoop.toLoop (0 : Fin 6) p))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SixthHurewicz.cubeChain_eq_induced {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 6) X x) :
+    cubeChain p = FirstHurewicz.inducedChain p.val 6 fundamentalCubeChain := by
+  rw [cubeChain, suspensionOne_toLoop]
+  change
+    FirstHurewicz.inducedChain (p.val.comp cubeCoordinates) 6 productCubeChain =
+      ((FirstHurewicz.inducedChain p.val 6).comp (FirstHurewicz.inducedChain cubeCoordinates 6))
+        productCubeChain
+  rw [FirstHurewicz.inducedChain_comp]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    SixthHurewicz.cubeCycle {X : Type} [TopologicalSpace X] {x : X} (p : GenLoop (Fin 6) X x) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 6 :=
+  pathCubeCycle x (GenLoop.toLoop (0 : Fin 6) p)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem SixthHurewicz.cubeCycle_val {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 6) X x) : (cubeCycle p).1 = cubeChain p :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def SixthHurewicz.cubeHomologyClass {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 6) X x) : SingularMayerVietoris.SingularHomology X 6 :=
+  SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 6
+    (cubeCycle p)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    SixthHurewicz.cubeHomologyClass_eq_pathCubeClass {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 6) X x) :
+    cubeHomologyClass p = pathCubeClass x (GenLoop.toLoop (0 : Fin 6) p) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SixthHurewicz.cubeHomologyClass_homotopic {X : Type} [TopologicalSpace X] {x : X}
+    {p q : GenLoop (Fin 6) X x} (h : GenLoop.Homotopic p q) :
+    cubeHomologyClass p = cubeHomologyClass q :=
+  pathCubeClass_homotopic x (GenLoop.homotopicTo (0 : Fin 6) h)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SixthHurewicz.toLoop_const {X : Type} [TopologicalSpace X] {x : X} :
+    GenLoop.toLoop (0 : Fin 6) (GenLoop.const : GenLoop (Fin 6) X x) =
+      Path.refl (GenLoop.const : BasedLoopSpace x) := by
+  apply Path.ext
+  funext t
+  apply GenLoop.ext
+  intro u
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem SixthHurewicz.cubeHomologyClass_const {X : Type} [TopologicalSpace X] {x : X} :
+    cubeHomologyClass (GenLoop.const : GenLoop (Fin 6) X x) = 0 := by
+  rw [cubeHomologyClass_eq_pathCubeClass, toLoop_const, pathCubeClass_refl]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+public
+theorem SixthHurewicz.toLoop_transAt {X : Type} [TopologicalSpace X] {x : X}
+    (p q : GenLoop (Fin 6) X x) :
+    GenLoop.toLoop (0 : Fin 6) (GenLoop.transAt (0 : Fin 6) p q) =
+      (GenLoop.toLoop (0 : Fin 6) p).trans (GenLoop.toLoop (0 : Fin 6) q) := by
+  have h :=
+    congrArg (GenLoop.toLoop (0 : Fin 6))
+      (GenLoop.fromLoop_trans_toLoop (i := (0 : Fin 6)) (p := p) (q := q))
+  rw [GenLoop.to_from] at h
+  exact h.symm
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SixthHurewicz.cubeHomologyClass_transAt {X : Type} [TopologicalSpace X] {x : X}
+    (p q : GenLoop (Fin 6) X x) :
+    cubeHomologyClass (GenLoop.transAt (0 : Fin 6) p q) =
+      cubeHomologyClass p + cubeHomologyClass q := by
+  simp only [cubeHomologyClass_eq_pathCubeClass, toLoop_transAt, pathCubeClass_trans]
+
+private theorem SixthHurewicz.CubeSubdivision.cubeCoordinates_boundary_right (s : (unitInterval))
+    {u : Fin 5 → (unitInterval)} (hu : u ∈ Cube.boundary (Fin 5)) :
+    SixthHurewicz.cubeCoordinates (s, u) ∈ Cube.boundary (Fin 6) := by
+  obtain ⟨i, hi⟩ := hu
+  exact ⟨i.succ, by simpa only [SixthHurewicz.cubeCoordinates_succ] using hi⟩
+
+private def SixthHurewicz.CubeSubdivision.curryLoop {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 6) X x) :
+    GenLoop (Fin 5) C((unitInterval), X) (ContinuousMap.const (unitInterval) x) :=
+  ⟨((SixthHurewicz.cubeMap p).comp ContinuousMap.prodSwap).curry,
+    by
+    intro u hu
+    apply ContinuousMap.ext
+    intro s
+    exact GenLoop.boundary p _ (cubeCoordinates_boundary_right s hu)⟩
+
+private theorem
+    SixthHurewicz.CubeSubdivision.evalLeft_comp_curryLoop {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 6) X x) :
+    (FourthHurewicz.CubeSubdivision.evalLeft X).comp
+        ((ContinuousMap.id (unitInterval)).prodMap (curryLoop p).val) =
+      SixthHurewicz.cubeMap p := by
+  ext z
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SixthHurewicz.CubeSubdivision.evalLeft_crossProductEdge_curryLoop {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 6) X x) (n : ℕ)
+    (b : FirstHurewicz.Chains (Fin 5 → (unitInterval)) n) :
+    FirstHurewicz.inducedChain (FourthHurewicz.CubeSubdivision.evalLeft X) (n + 1)
+        (PeriodTorusHigherHomology.crossProductEdge (unitInterval) C((unitInterval), X) n
+          SecondHurewicz.intervalChain (FirstHurewicz.inducedChain (curryLoop p).val n b)) =
+      FirstHurewicz.inducedChain (SixthHurewicz.cubeMap p) (n + 1)
+        (PeriodTorusHigherHomology.crossProductEdge (unitInterval) (Fin 5 → (unitInterval)) n
+          SecondHurewicz.intervalChain b) := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductEdge_natural (ContinuousMap.id (unitInterval))
+      (curryLoop p).val n SecondHurewicz.intervalChain b
+  rw [FirstHurewicz.inducedChain_id, LinearMap.id_apply] at h
+  rw [← h]
+  change
+    ((FirstHurewicz.inducedChain (FourthHurewicz.CubeSubdivision.evalLeft X) (n + 1)).comp
+          (FirstHurewicz.inducedChain
+            ((ContinuousMap.id (unitInterval)).prodMap (curryLoop p).val) (n + 1)))
+        _ =
+      _
+  rw [← FirstHurewicz.inducedChain_comp, evalLeft_comp_curryLoop]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SixthHurewicz.CubeSubdivision.cubeChain_eq_curriedCrossProduct {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 6) X x) :
+    SixthHurewicz.cubeChain p =
+      FirstHurewicz.inducedChain (FourthHurewicz.CubeSubdivision.evalLeft X) 6
+        (PeriodTorusHigherHomology.crossProductEdge (unitInterval) C((unitInterval), X) 5
+          SecondHurewicz.intervalChain (FifthHurewicz.cubeChain (curryLoop p))) := by
+  rw [FifthHurewicz.cubeChain_eq_induced, evalLeft_crossProductEdge_curryLoop,
+    SixthHurewicz.cubeChain_eq_induced, SixthHurewicz.fundamentalCubeChain]
+  change
+    (FirstHurewicz.inducedChain p.val 6)
+        ((FirstHurewicz.inducedChain SixthHurewicz.cubeCoordinates 6)
+          SixthHurewicz.productCubeChain) =
+      (FirstHurewicz.inducedChain (p.val.comp SixthHurewicz.cubeCoordinates) 6)
+        SixthHurewicz.productCubeChain
+  rw [FirstHurewicz.inducedChain_comp]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    SixthHurewicz.CubeSubdivision.intervalFiveSimplexChain {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 6) X x) (e : Equiv.Perm (Fin 5)) : FirstHurewicz.Chains X 6 :=
+  FirstHurewicz.inducedChain (FourthHurewicz.CubeSubdivision.evalLeft X) 6
+    (PeriodTorusHigherHomology.crossProductEdge (unitInterval) C((unitInterval), X) 5
+      SecondHurewicz.intervalChain
+      (FirstHurewicz.simplexChain C((unitInterval), X) 5
+        ((curryLoop p).val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e))))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SixthHurewicz.CubeSubdivision.intervalFiveSimplexChain_eq_original {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 6) X x) (e : Equiv.Perm (Fin 5)) :
+    intervalFiveSimplexChain p e =
+      FirstHurewicz.inducedChain (SixthHurewicz.cubeMap p) 6
+        (PeriodTorusHigherHomology.crossProductEdge (unitInterval) (Fin 5 → (unitInterval)) 5
+          SecondHurewicz.intervalChain
+          (FirstHurewicz.simplexChain (Fin 5 → (unitInterval)) 5
+            (HigherHurewicz.CubeTriangulation.cubeSimplex e))) := by
+  rw [intervalFiveSimplexChain, ← FirstHurewicz.inducedChain_simplex,
+    evalLeft_crossProductEdge_curryLoop]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    SixthHurewicz.CubeSubdivision.cubeChain_eq_sum_prisms {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 6) X x) :
+    SixthHurewicz.cubeChain p =
+      ∑ e : Equiv.Perm (Fin 5),
+        HigherHurewicz.CubeTriangulation.cubeOrientation e • intervalFiveSimplexChain p e := by
+  rw [cubeChain_eq_curriedCrossProduct, FifthHurewicz.CubeSubdivision.cubeChain_eq_sum_simplices]
+  simp only [map_sum, map_zsmul, intervalFiveSimplexChain]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem SixthHurewicz.CubeSubdivision.prismCubeMap_five (e : Equiv.Perm (Fin 5)) :
+    SixthHurewicz.cubeCoordinates.comp
+        ((FirstHurewicz.pathSimplex Path.id).prodMap
+          (HigherHurewicz.CubeTriangulation.cubeSimplex e)) =
+      FourthHurewicz.CubeSubdivision.prismCubeMap e := by
+  apply ContinuousMap.ext
+  intro z
+  funext i
+  refine Fin.cases ?_ (fun j => ?_) i
+  · exact SixthHurewicz.cubeCoordinates_zero _
+  · change
+      SixthHurewicz.cubeCoordinates
+          (FirstHurewicz.pathSimplex Path.id z.1,
+            HigherHurewicz.CubeTriangulation.cubeSimplex e z.2)
+          j.succ =
+        _
+    rw [SixthHurewicz.cubeCoordinates_succ]
+    rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    SixthHurewicz.CubeSubdivision.intervalFiveSimplexChain_eq_prismCubeRealization {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 6) X x) (e : Equiv.Perm (Fin 5)) :
+    intervalFiveSimplexChain p e =
+      FourthHurewicz.CubeSubdivision.prismCubeRealization p.val e 6
+        (PeriodTorusHigherHomology.formalEdgeCrossProduct 5
+          (SingularMayerVietoris.formalSimplex (fun i : Fin 2 => i))
+          (SingularMayerVietoris.formalSimplex (fun j : Fin 6 => j))) := by
+  rw [intervalFiveSimplexChain_eq_original, SecondHurewicz.intervalChain, FirstHurewicz.pathChain,
+    PeriodTorusHigherHomology.crossProductEdge_simplex,
+    FourthHurewicz.CubeSubdivision.prismCubeRealization_edgeCrossProduct]
+  change
+    ((FirstHurewicz.inducedChain (SixthHurewicz.cubeMap p) 6).comp
+          (FirstHurewicz.inducedChain
+            ((FirstHurewicz.pathSimplex Path.id).prodMap
+              (HigherHurewicz.CubeTriangulation.cubeSimplex e))
+            6))
+        _ =
+      _
+  rw [← FirstHurewicz.inducedChain_comp]
+  change
+    FirstHurewicz.inducedChain
+        (p.val.comp
+          (SixthHurewicz.cubeCoordinates.comp
+            ((FirstHurewicz.pathSimplex Path.id).prodMap
+              (HigherHurewicz.CubeTriangulation.cubeSimplex e))))
+        6 _ =
+      _
+  rw [prismCubeMap_five]
+
+private theorem SixthHurewicz.CubeSubdivision.cubeChain_eq_orientedPrismRealization {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 6) X x) :
+    SixthHurewicz.cubeChain p =
+      FourthHurewicz.CubeSubdivision.orientedPrismRealization p.val 6
+        (PeriodTorusHigherHomology.formalEdgeCrossProduct 5
+          (SingularMayerVietoris.formalSimplex (fun i : Fin 2 => i))
+          (SingularMayerVietoris.formalSimplex (fun j : Fin 6 => j))) := by
+  rw [cubeChain_eq_sum_prisms, FourthHurewicz.CubeSubdivision.orientedPrismRealization_eq_sum]
+  simp only [intervalFiveSimplexChain_eq_prismCubeRealization]
+
+private theorem
+    SixthHurewicz.CubeSubdivision.cubeChain_eq_sum_simplices {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 6) X x) :
+    SixthHurewicz.cubeChain p =
+      ∑ e : Equiv.Perm (Fin 6),
+        HigherHurewicz.CubeTriangulation.cubeOrientation e •
+          FirstHurewicz.simplexChain X 6
+            (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e)) := by
+  rw [cubeChain_eq_orientedPrismRealization,
+    FourthHurewicz.CubeSubdivision.orientedPrismRealization_edge_eq_standard (n := 3) p,
+    FourthHurewicz.CubeSubdivision.orientedPrismRealization_standardPrism]
+
+private theorem SixthHurewicz.sixSimplexClassOperator_cubeChain_sum {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] (p : GenLoop (Fin 6) X x) :
+    sixSimplexClassOperator x (cubeChain p) =
+      ∑ e : Equiv.Perm (Fin 6),
+        HigherHurewicz.CubeTriangulation.cubeOrientation e •
+          basedSixSimplexClass
+            (normalizedSixSimplex x
+              (p.val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e))) := by
+  rw [CubeSubdivision.cubeChain_eq_sum_simplices, map_sum]
+  apply Finset.sum_congr rfl
+  intro e _
+  rw [map_zsmul, sixSimplexClassOperator_simplex]
+
+private theorem SixthHurewicz.sixSimplexClassOperator_cubeChain {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] (p : GenLoop (Fin 6) X x) :
+    sixSimplexClassOperator x (cubeChain p) = Additive.ofMul (⟦p⟧ : π_ 6 X x) := by
+  rw [sixSimplexClassOperator_cubeChain_sum]
+  calc
+    _ = Additive.ofMul (⟦normalizedCube x p⟧ : π_ 6 X x) := by
+      simpa only [normalizedCube_simplex, basedSixSimplexClass] using
+        (HigherHurewicz.NativeSubdivision.nativeCubeSubdivision_class (normalizedCube x p)
+            (normalizedCube_internalBased x p)).symm
+    _ = _ :=
+      congrArg Additive.ofMul
+        (Quotient.sound
+          (show GenLoop.Homotopic (normalizedCube x p) p from
+            ⟨(normalizationCubeHomotopy x p).symm⟩))
+
+private def SixthHurewicz.basedSixSimplexChain {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedSixSimplex x) : FirstHurewicz.Chains X 6 :=
+  HigherHurewicz.correctedSimplexChain 6 x τ.val
+
+private def SixthHurewicz.basedSixSimplexCycle {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedSixSimplex x) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 6 :=
+  HigherHurewicz.correctedSimplexCycle 5 x τ.val (basedSixSimplex_face τ)
+
+private theorem
+    SixthHurewicz.basedSixSimplex_simplexChain_sum {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedSixSimplex x) :
+    (∑ e : Equiv.Perm (Fin 6),
+        HigherHurewicz.CubeTriangulation.cubeOrientation e •
+          FirstHurewicz.simplexChain X 6
+            ((basedSixSimplexLoop τ).val.comp (HigherHurewicz.CubeTriangulation.cubeSimplex e))) =
+      basedSixSimplexChain τ :=
+  HigherHurewicz.SimplexGeometry.basedSimplex_simplexChain_sum (n := 4) τ
+
+private def SixthHurewicz.normalizedSixSimplexCycleOperator {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] :
+    FirstHurewicz.Chains X 6 →ₗ[ℤ]
+      SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 6 :=
+  HigherHurewicz.normalizedCycleAssignment 5 x (normalizedSixSimplex x)
+
+@[simp]
+private theorem
+    SixthHurewicz.normalizedSixSimplexCycleOperator_simplex {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 6) :
+    normalizedSixSimplexCycleOperator x (FirstHurewicz.simplexChain X 6 smp) =
+      basedSixSimplexCycle (normalizedSixSimplex x smp) :=
+  HigherHurewicz.normalizedCycleAssignment_simplex 5 x (normalizedSixSimplex x) smp
+
+private theorem
+    SixthHurewicz.normalizedSixSimplexCycleOperator_class {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)]
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 6) :
+    SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 6
+        (normalizedSixSimplexCycleOperator x c.val) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 6 c := by
+  apply
+    HigherHurewicz.normalizedCycleAssignment_class 5 x (normalizedSixSimplex x)
+      (normalizationFiveSimplexHomotopy x) (normalizationSixSimplexHomotopy x)
+      (normalizationHomotopy_face x) _ (fun _ => rfl) c
+  intro smp
+  ext s
+  exact normalizationSixSimplexHomotopy_zero x smp s
+
+private def
+    SixthHurewicz.homotopyMap {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y] (f : C(X, Y))
+    (x : X) : π_ 6 X x →* π_ 6 Y (f x)
+    where
+  toFun :=
+    Quotient.map (SecondHurewicz.mapGenLoop f x)
+      (fun _ _ h => SecondHurewicz.mapGenLoop_homotopic f x h)
+  map_one' := by
+    change (⟦SecondHurewicz.mapGenLoop f x GenLoop.const⟧ : π_ 6 Y (f x)) = ⟦GenLoop.const⟧
+    rw [SecondHurewicz.mapGenLoop_const]
+  map_mul' a
+    b := by
+    refine Quotient.inductionOn₂ a b fun p q => ?_
+    exact
+      (congrArg
+            (Quotient.map (SecondHurewicz.mapGenLoop f x)
+              (fun _ _ h => SecondHurewicz.mapGenLoop_homotopic f x h))
+            (HomotopyGroup.mul_spec (i := (0 : Fin 6)) (p := p) (q := q))).trans
+        ((congrArg (fun r : GenLoop (Fin 6) Y (f x) => (⟦r⟧ : π_ 6 Y (f x)))
+              (SecondHurewicz.mapGenLoop_transAt f x (0 : Fin 6) q p)).trans
+          (HomotopyGroup.mul_spec (i := (0 : Fin 6)) (p := SecondHurewicz.mapGenLoop f x p) (q :=
+              SecondHurewicz.mapGenLoop f x q)).symm)
+
+private def SixthHurewicz.hurewiczFunction {X : Type} [TopologicalSpace X] (x : X) :
+    π_ 6 X x → SingularMayerVietoris.SingularHomology X 6 :=
+  Quotient.lift cubeHomologyClass (fun _ _ h => cubeHomologyClass_homotopic h)
+
+private def SixthHurewicz.hurewiczPi6 {X : Type} [TopologicalSpace X] (x : X) :
+    π_ 6 X x →* Multiplicative (SingularMayerVietoris.SingularHomology X 6)
+    where
+  toFun a := Multiplicative.ofAdd (hurewiczFunction x a)
+  map_one' := congrArg Multiplicative.ofAdd (cubeHomologyClass_const (x := x))
+  map_mul' a
+    b := by
+    refine Quotient.inductionOn₂ a b fun p q => ?_
+    refine
+      (congrArg (fun c : π_ 6 X x => Multiplicative.ofAdd (hurewiczFunction x c))
+            (HomotopyGroup.mul_spec (i := (0 : Fin 6)) (p := p) (q := q))).trans
+        ?_
+    change
+      Multiplicative.ofAdd (cubeHomologyClass (GenLoop.transAt (0 : Fin 6) q p)) =
+        Multiplicative.ofAdd (cubeHomologyClass p + cubeHomologyClass q)
+    rw [cubeHomologyClass_transAt, add_comm]
+
+private def SixthHurewicz.hurewiczMap {X : Type} [TopologicalSpace X] (x : X) :
+    Additive (π_ 6 X x) →ₗ[ℤ] SingularMayerVietoris.SingularHomology X 6
+    where
+  toFun := (hurewiczPi6 x).toAdditiveLeft
+  map_add' := (hurewiczPi6 x).toAdditiveLeft.map_add
+  map_smul' n a := by simpa using map_intCast_smul (hurewiczPi6 x).toAdditiveLeft ℤ ℤ n a
+
+private theorem SixthHurewicz.hurewiczMap_representative {X : Type} [TopologicalSpace X] (x : X)
+    (p : GenLoop (Fin 6) X x) :
+    hurewiczMap x (Additive.ofMul (⟦p⟧ : π_ 6 X x)) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 6
+        (cubeCycle p) :=
+  rfl
+
+private theorem SixthHurewicz.cubeChain_basedSixSimplexLoop {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedSixSimplex x) : cubeChain (basedSixSimplexLoop τ) = basedSixSimplexChain τ := by
+  rw [CubeSubdivision.cubeChain_eq_sum_simplices, basedSixSimplex_simplexChain_sum]
+
+private theorem SixthHurewicz.cubeCycle_basedSixSimplexLoop {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedSixSimplex x) : cubeCycle (basedSixSimplexLoop τ) = basedSixSimplexCycle τ := by
+  apply Subtype.ext
+  exact cubeChain_basedSixSimplexLoop τ
+
+private theorem SixthHurewicz.hurewicz_basedSixSimplexClass {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedSixSimplex x) :
+    hurewiczMap x (basedSixSimplexClass τ) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 6
+        (basedSixSimplexCycle τ) := by
+  change
+    SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 6
+        (cubeCycle (basedSixSimplexLoop τ)) =
+      _
+  rw [cubeCycle_basedSixSimplexLoop]
+
+private theorem
+    SixthHurewicz.hurewiczMap_comp_sixSimplexClassOperator {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] :
+    (hurewiczMap x).comp (sixSimplexClassOperator x) =
+      (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 6).comp
+        (normalizedSixSimplexCycleOperator x) := by
+  apply FirstHurewicz.chainMap_ext X 6
+  intro smp
+  simp only [LinearMap.comp_apply, sixSimplexClassOperator_simplex,
+    normalizedSixSimplexCycleOperator_simplex]
+  exact hurewicz_basedSixSimplexClass (normalizedSixSimplex x smp)
+
+private theorem
+    SixthHurewicz.hurewiczMap_sixSimplexClassOperator_cycle {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)]
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 6) :
+    hurewiczMap x (sixSimplexClassOperator x c.val) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 6 c := by
+  have h := LinearMap.congr_fun (hurewiczMap_comp_sixSimplexClassOperator x) c.val
+  change
+    hurewiczMap x (sixSimplexClassOperator x c.val) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 6
+        (normalizedSixSimplexCycleOperator x c.val) at h
+  exact h.trans (normalizedSixSimplexCycleOperator_class x c)
+
+private def
+    SixthHurewicz.hurewiczInverse {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X] (x : X)
+    [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] [Subsingleton (π_ 4 X x)]
+    [Subsingleton (π_ 5 X x)] :
+    SingularMayerVietoris.SingularHomology X 6 →ₗ[ℤ] Additive (π_ 6 X x) :=
+  HigherHurewicz.singularHomologyDesc 6 (sixSimplexClassOperator x)
+    (sixSimplexClassOperator_boundary x)
+
+@[simp]
+private theorem SixthHurewicz.hurewiczInverse_cycleClass {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)]
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 6) :
+    hurewiczInverse x
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 6 c) =
+      sixSimplexClassOperator x c.val :=
+  HigherHurewicz.singularHomologyDesc_cycleClass 6 _ _ c
+
+private theorem SixthHurewicz.hurewiczMap_comp_hurewiczInverse {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] :
+    (hurewiczMap x).comp (hurewiczInverse x) = LinearMap.id :=
+  HigherHurewicz.comp_singularHomologyDesc_eq_id 6 (sixSimplexClassOperator x)
+    (sixSimplexClassOperator_boundary x) (hurewiczMap x)
+    (hurewiczMap_sixSimplexClassOperator_cycle x)
+
+@[simp]
+private theorem SixthHurewicz.hurewiczMap_hurewiczInverse {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)]
+    (c : SingularMayerVietoris.SingularHomology X 6) : hurewiczMap x (hurewiczInverse x c) = c :=
+  LinearMap.congr_fun (hurewiczMap_comp_hurewiczInverse x) c
+
+private theorem SixthHurewicz.hurewiczInverse_hurewiczMap_mk {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] (p : GenLoop (Fin 6) X x) :
+    hurewiczInverse x (hurewiczMap x (Additive.ofMul (⟦p⟧ : π_ 6 X x))) =
+      Additive.ofMul (⟦p⟧ : π_ 6 X x) := by
+  rw [hurewiczMap_representative, hurewiczInverse_cycleClass]
+  exact sixSimplexClassOperator_cubeChain x p
+
+@[simp]
+private theorem SixthHurewicz.hurewiczInverse_hurewiczMap {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] (a : Additive (π_ 6 X x)) :
+    hurewiczInverse x (hurewiczMap x a) = a := by
+  change
+    hurewiczInverse x (hurewiczMap x (Additive.ofMul (Additive.toMul a))) =
+      Additive.ofMul (Additive.toMul a)
+  refine Quotient.inductionOn (Additive.toMul a) ?_
+  intro p
+  exact hurewiczInverse_hurewiczMap_mk x p
+
+private theorem SixthHurewicz.hurewiczInverse_comp_hurewiczMap {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] :
+    (hurewiczInverse x).comp (hurewiczMap x) = LinearMap.id := by
+  ext a
+  exact hurewiczInverse_hurewiczMap x a
+
+private def
+    SixthHurewicz.hurewiczLinearEquiv {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] [Subsingleton (π_ 4 X x)]
+    [Subsingleton (π_ 5 X x)] :
+    Additive (π_ 6 X x) ≃ₗ[ℤ] SingularMayerVietoris.SingularHomology X 6 :=
+  LinearEquiv.ofLinearMap (hurewiczMap x) (hurewiczInverse x) (hurewiczMap_comp_hurewiczInverse x)
+    (hurewiczInverse_comp_hurewiczMap x)
+
+private def SixthHurewicz.hurewiczPi6Equiv {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] [Subsingleton (π_ 4 X x)]
+    [Subsingleton (π_ 5 X x)] :
+    π_ 6 X x ≃* Multiplicative (SingularMayerVietoris.SingularHomology X 6)
+    where
+  __ := hurewiczPi6 x
+  invFun c := Additive.toMul (hurewiczInverse x (Multiplicative.toAdd c))
+  left_inv a := congrArg Additive.toMul (hurewiczInverse_hurewiczMap x (Additive.ofMul a))
+  right_inv
+    c := congrArg Multiplicative.ofAdd (hurewiczMap_hurewiczInverse x (Multiplicative.toAdd c))
+
+private theorem
+    SixthHurewicz.cubeChain_natural {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (f : C(X, Y)) (x : X) (p : GenLoop (Fin 6) X x) :
+    FirstHurewicz.inducedChain f 6 (cubeChain p) = cubeChain (SecondHurewicz.mapGenLoop f x p) := by
+  rw [cubeChain_eq_induced, cubeChain_eq_induced, SecondHurewicz.mapGenLoop_val,
+    FirstHurewicz.inducedChain_comp, LinearMap.comp_apply]
+
+private theorem
+    SixthHurewicz.cubeCycle_natural {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (f : C(X, Y)) (x : X) (p : GenLoop (Fin 6) X x) :
+    SingularMayerVietoris.ModuleHomology.mapCycles (FirstHurewicz.singularChainMap f) 6
+        (cubeCycle p) =
+      cubeCycle (SecondHurewicz.mapGenLoop f x p) := by
+  apply Subtype.ext
+  rw [SingularMayerVietoris.ModuleHomology.mapCycles_val, cubeCycle_val, cubeCycle_val]
+  exact cubeChain_natural f x p
+
+private theorem SixthHurewicz.cubeHomologyClass_natural {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (x : X) (p : GenLoop (Fin 6) X x) :
+    SingularMayerVietoris.singularHomologyMap f 6 (cubeHomologyClass p) =
+      cubeHomologyClass (SecondHurewicz.mapGenLoop f x p) := by
+  change
+    (HomologicalComplex.homologyMap (FirstHurewicz.singularChainMap f) 6).hom
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 6
+          (cubeCycle p)) =
+      _
+  rw [SingularMayerVietoris.ModuleHomology.homologyMap_cycleClass, cubeCycle_natural]
+  rfl
+
+private theorem SixthHurewicz.hurewiczFunction_natural {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (x : X) (a : π_ 6 X x) :
+    SingularMayerVietoris.singularHomologyMap f 6 (hurewiczFunction x a) =
+      hurewiczFunction (f x) (homotopyMap f x a) := by
+  refine Quotient.inductionOn a fun p => ?_
+  exact cubeHomologyClass_natural f x p
+
+private theorem
+    SixthHurewicz.hurewiczMap_natural {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (f : C(X, Y)) (x : X) (a : Additive (π_ 6 X x)) :
+    SingularMayerVietoris.singularHomologyMap f 6 (hurewiczMap x a) =
+      hurewiczMap (f x) ((homotopyMap f x).toAdditive a) :=
+  hurewiczFunction_natural f x a.toMul
+
+private theorem SixthHurewicz.hurewiczLinearEquiv_natural {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] [SimplyConnectedSpace X] [SimplyConnectedSpace Y] (f : C(X, Y)) (x : X)
+    [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)] [Subsingleton (π_ 4 X x)]
+    [Subsingleton (π_ 5 X x)] [Subsingleton (π_ 2 Y (f x))] [Subsingleton (π_ 3 Y (f x))]
+    [Subsingleton (π_ 4 Y (f x))] [Subsingleton (π_ 5 Y (f x))] (a : Additive (π_ 6 X x)) :
+    SingularMayerVietoris.singularHomologyMap f 6 (hurewiczLinearEquiv x a) =
+      hurewiczLinearEquiv (f x) ((homotopyMap f x).toAdditive a) :=
+  hurewiczMap_natural f x a
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Hurewicz/ThirdHurewicz.lean b/LeanPool/HopfProblem/Hurewicz/ThirdHurewicz.lean
new file mode 100644
index 000000000..a1c13b398
--- /dev/null
+++ b/LeanPool/HopfProblem/Hurewicz/ThirdHurewicz.lean
@@ -0,0 +1,5654 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.PeriodFamily.Core5
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology4
+import all LeanPool.HopfProblem.Hurewicz.SecondHurewicz
+import all LeanPool.HopfProblem.PeriodFamily.Core5
+
+/-!
+# Hopf problem: hurewicz · third hurewicz
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+@[simp]
+private theorem ThirdHurewicz.edgeTriangleHomotopy_const {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) :
+    SecondHurewicz.SimplyConnected.triangleEdgeStraighteningHomotopy x
+        (ContinuousMap.const (FirstHurewicz.Simplex 2) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 2) x :=
+  extendCoherentSimplexHomotopy_const (SecondHurewicz.SimplyConnected.stationarySimplexHomotopy 0)
+    (SecondHurewicz.SimplyConnected.edgeStraighteningHomotopy x)
+    (SecondHurewicz.SimplyConnected.edgeStraighteningHomotopy_face x)
+    (SecondHurewicz.SimplyConnected.edgeStraighteningHomotopy_zero x) x
+    (SecondHurewicz.SimplyConnected.edgeStraighteningHomotopy_const x)
+
+@[simp]
+private theorem ThirdHurewicz.edgeTetrahedronHomotopy_const {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) :
+    SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy x
+        (ContinuousMap.const (FirstHurewicz.Simplex 3) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 3) x :=
+  extendCoherentSimplexHomotopy_const (SecondHurewicz.SimplyConnected.edgeStraighteningHomotopy x)
+    (SecondHurewicz.SimplyConnected.triangleEdgeStraighteningHomotopy x)
+    (SecondHurewicz.SimplyConnected.triangleEdgeStraighteningHomotopy_face x)
+    (SecondHurewicz.SimplyConnected.triangleEdgeStraighteningHomotopy_zero x) x
+    (edgeTriangleHomotopy_const x)
+
+private def
+    ThirdHurewicz.edgeFourSimplexHomotopy {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) (smp : FirstHurewicz.SingularSimplex X 4) :
+    C((unitInterval) × FirstHurewicz.Simplex 4, X) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy
+    (SecondHurewicz.SimplyConnected.triangleEdgeStraighteningHomotopy x)
+    (SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy x)
+    (SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy_face x)
+    (SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy_zero x) smp
+
+private theorem ThirdHurewicz.edgeFourSimplexHomotopy_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 3
+      (SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy x)
+      (edgeFourSimplexHomotopy x) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_face
+    (SecondHurewicz.SimplyConnected.triangleEdgeStraighteningHomotopy x)
+    (SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy x)
+    (SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy_face x)
+    (SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy_zero x)
+
+private def ThirdHurewicz.edgeNormalizedFourSimplexMap {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (smp : FirstHurewicz.SingularSimplex X 4) :
+    FirstHurewicz.SingularSimplex X 4 :=
+  SecondHurewicz.SimplyConnected.timeSlice
+    (edgeFourSimplexHomotopy x (SecondHurewicz.SimplyConnected.vertexNormalizedSimplex x 4 smp)) 1
+
+private theorem ThirdHurewicz.edgeNormalizedFourSimplexMap_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) (smp : FirstHurewicz.SingularSimplex X 4) (i : Fin 5) :
+    (edgeNormalizedFourSimplexMap x smp).comp (FirstHurewicz.simplexFace 3 i) =
+      SecondHurewicz.SimplyConnected.normalizedTetrahedronMap x
+        (smp.comp (FirstHurewicz.simplexFace 3 i)) := by
+  change
+    (SecondHurewicz.SimplyConnected.timeSlice
+            (edgeFourSimplexHomotopy x
+              (SecondHurewicz.SimplyConnected.vertexNormalizedSimplex x 4 smp))
+            1).comp
+        (FirstHurewicz.simplexFace 3 i) =
+      _
+  rw [SecondHurewicz.SimplyConnected.timeSlice_face (edgeFourSimplexHomotopy_face x),
+    SecondHurewicz.SimplyConnected.vertexNormalizedSimplex_face]
+  rfl
+
+private theorem ThirdHurewicz.triangleReturn_first_mem (s : FirstHurewicz.Simplex 2) :
+    s 1 + Max.max (s 2 - s 0) 0 ∈ unitInterval := by
+  constructor
+  · exact add_nonneg (stdSimplex.zero_le s 1) (le_max_right _ _)
+  · have hm : Max.max (s 2 - s 0) 0 ≤ s 2 :=
+      max_le (sub_le_self _ (stdSimplex.zero_le s 0)) (stdSimplex.zero_le s 2)
+    have h0 := stdSimplex.zero_le s 0
+    have hs := stdSimplex.sum_eq_one s
+    simp only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero] at hs
+    change s 0 + (s 1 + s 2) = 1 at hs
+    linarith
+
+private theorem ThirdHurewicz.triangleReturn_second_mem (s : FirstHurewicz.Simplex 2) :
+    s 2 + Min.min (s 0) (s 2) ∈ unitInterval := by
+  constructor
+  · exact
+      add_nonneg (stdSimplex.zero_le s 2)
+        (le_min (stdSimplex.zero_le s 0) (stdSimplex.zero_le s 2))
+  · have hm : Min.min (s 0) (s 2) ≤ s 0 := min_le_left _ _
+    have h1 := stdSimplex.zero_le s 1
+    have hs := stdSimplex.sum_eq_one s
+    simp only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero] at hs
+    change s 0 + (s 1 + s 2) = 1 at hs
+    linarith
+
+private def ThirdHurewicz.triangleCubicalReturn : C(FirstHurewicz.Simplex 2, Fin 2 → (unitInterval))
+    where
+  toFun
+    s :=
+    ![⟨s 1 + Max.max (s 2 - s 0) 0, triangleReturn_first_mem s⟩,
+      ⟨s 2 + Min.min (s 0) (s 2), triangleReturn_second_mem s⟩]
+  continuous_toFun := by
+    have hc (j : Fin 3) : Continuous (fun s : FirstHurewicz.Simplex 2 => s j) :=
+      (continuous_apply j).comp continuous_subtype_val
+    apply continuous_pi
+    intro i
+    fin_cases i <;> apply Continuous.subtype_mk
+    · change Continuous fun s : FirstHurewicz.Simplex 2 => s 1 + Max.max (s 2 - s 0) 0
+      exact (hc 1).add (((hc 2).sub (hc 0)).max continuous_const)
+    · change Continuous fun s : FirstHurewicz.Simplex 2 => s 2 + Min.min (s 0) (s 2)
+      exact (hc 2).add ((hc 0).min (hc 2))
+
+private theorem ThirdHurewicz.triangleCubicalReturn_face_zero (s : FirstHurewicz.Simplex 2)
+    (hs : s 0 = 0) : triangleCubicalReturn s 0 = 1 := by
+  apply Subtype.ext
+  change s 1 + Max.max (s 2 - s 0) 0 = 1
+  rw [hs, sub_zero, max_eq_left (stdSimplex.zero_le s 2)]
+  have hsum := stdSimplex.sum_eq_one s
+  simp only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero] at hsum
+  change s 0 + (s 1 + s 2) = 1 at hsum
+  simpa only [hs, zero_add] using hsum
+
+private theorem ThirdHurewicz.triangleCubicalReturn_face_two (s : FirstHurewicz.Simplex 2)
+    (hs : s 2 = 0) : triangleCubicalReturn s 1 = 0 := by
+  apply Subtype.ext
+  change s 2 + Min.min (s 0) (s 2) = 0
+  rw [hs, min_eq_right (stdSimplex.zero_le s 0), zero_add]
+
+private theorem ThirdHurewicz.triangleCubicalReturn_face_one (s : FirstHurewicz.Simplex 2)
+    (hs : s 1 = 0) : triangleCubicalReturn s 0 = 0 ∨ triangleCubicalReturn s 1 = 1 := by
+  rcases le_total (s 2) (s 0) with h | h
+  · left
+    apply Subtype.ext
+    change s 1 + Max.max (s 2 - s 0) 0 = 0
+    rw [hs, max_eq_right (sub_nonpos.mpr h), zero_add]
+  · right
+    apply Subtype.ext
+    change s 2 + Min.min (s 0) (s 2) = 1
+    rw [min_eq_left h]
+    have hsum := stdSimplex.sum_eq_one s
+    simp only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero] at hsum
+    change s 0 + (s 1 + s 2) = 1 at hsum
+    linarith
+
+private theorem ThirdHurewicz.triangleCubicalReturn_boundary (s : FirstHurewicz.Simplex 2)
+    (hs : s ∈ SecondHurewicz.SimplyConnected.triangleBoundary) :
+    triangleCubicalReturn s ∈ Cube.boundary (Fin 2) := by
+  obtain ⟨i, hi⟩ := hs
+  fin_cases i
+  · exact ⟨0, Or.inr (triangleCubicalReturn_face_zero s hi)⟩
+  · rcases triangleCubicalReturn_face_one s hi with h | h
+    · exact ⟨0, Or.inl h⟩
+    · exact ⟨1, Or.inr h⟩
+  · exact ⟨1, Or.inl (triangleCubicalReturn_face_two s hi)⟩
+
+private theorem ThirdHurewicz.triangleCubicalReturn_quotient_zero (s : FirstHurewicz.Simplex 2)
+    (i : Fin 3) (hi : s i = 0) :
+    SecondHurewicz.SimplyConnected.triangleCubeQuotient (triangleCubicalReturn s) i = 0 := by
+  fin_cases i
+  · change 1 - (triangleCubicalReturn s 0 : ℝ) = 0
+    rw [triangleCubicalReturn_face_zero s hi]
+    norm_num
+  · change
+      (triangleCubicalReturn s 0 : ℝ) -
+          Min.min (triangleCubicalReturn s 0 : ℝ) (triangleCubicalReturn s 1 : ℝ) =
+        0
+    rcases triangleCubicalReturn_face_one s hi with h | h
+    · rw [h]
+      change 0 - Min.min 0 (triangleCubicalReturn s 1 : ℝ) = 0
+      rw [min_eq_left (triangleCubicalReturn s 1).property.1, sub_self]
+    · rw [h]
+      change (triangleCubicalReturn s 0 : ℝ) - Min.min (triangleCubicalReturn s 0 : ℝ) 1 = 0
+      rw [min_eq_left (triangleCubicalReturn s 0).property.2, sub_self]
+  · change Min.min (triangleCubicalReturn s 0 : ℝ) (triangleCubicalReturn s 1 : ℝ) = 0
+    rw [triangleCubicalReturn_face_two s hi]
+    change Min.min (triangleCubicalReturn s 0 : ℝ) 0 = 0
+    exact min_eq_right (triangleCubicalReturn s 0).property.1
+
+private def ThirdHurewicz.triangleReturnComposition :
+    C(FirstHurewicz.Simplex 2, FirstHurewicz.Simplex 2) :=
+  SecondHurewicz.SimplyConnected.triangleCubeQuotient.comp triangleCubicalReturn
+
+private def ThirdHurewicz.triangleReturnInterpolation :
+    C((unitInterval) × FirstHurewicz.Simplex 2, FirstHurewicz.Simplex 2) :=
+  SecondHurewicz.SimplyConnected.tetrahedronSimplexBlendMap
+    (ContinuousMap.id (FirstHurewicz.Simplex 2)) triangleReturnComposition
+
+@[simp]
+private theorem ThirdHurewicz.triangleReturnInterpolation_zero (s : FirstHurewicz.Simplex 2) :
+    triangleReturnInterpolation (0, s) = s :=
+  SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend_zero s (triangleReturnComposition s)
+
+@[simp]
+private theorem ThirdHurewicz.triangleReturnInterpolation_one (s : FirstHurewicz.Simplex 2) :
+    triangleReturnInterpolation (1, s) = triangleReturnComposition s :=
+  SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend_one s (triangleReturnComposition s)
+
+private theorem ThirdHurewicz.triangleReturnInterpolation_coordinate_zero (t : (unitInterval))
+    (s : FirstHurewicz.Simplex 2) (i : Fin 3) (hi : s i = 0) :
+    triangleReturnInterpolation (t, s) i = 0 :=
+  SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend_zero_coordinate t s
+    (triangleReturnComposition s) i hi (triangleCubicalReturn_quotient_zero s i hi)
+
+private theorem ThirdHurewicz.triangleReturnInterpolation_boundary (t : (unitInterval))
+    (s : FirstHurewicz.Simplex 2) (hs : s ∈ SecondHurewicz.SimplyConnected.triangleBoundary) :
+    triangleReturnInterpolation (t, s) ∈ SecondHurewicz.SimplyConnected.triangleBoundary := by
+  obtain ⟨i, hi⟩ := hs
+  exact ⟨i, triangleReturnInterpolation_coordinate_zero t s i hi⟩
+
+private def ThirdHurewicz.triangleReturnHomotopy {X : Type} [TopologicalSpace X] {x : X}
+    (τ : SecondHurewicz.SimplyConnected.BasedTriangle x) :
+    τ.val.HomotopyRel
+      ((SecondHurewicz.SimplyConnected.basedTriangleLoop τ).val.comp triangleCubicalReturn)
+      SecondHurewicz.SimplyConnected.triangleBoundary
+    where
+  toFun z := τ.val (triangleReturnInterpolation z)
+  continuous_toFun := τ.val.continuous.comp triangleReturnInterpolation.continuous
+  map_zero_left s := congrArg τ.val (triangleReturnInterpolation_zero s)
+  map_one_left s := congrArg τ.val (triangleReturnInterpolation_one s)
+  prop' t s
+    hs :=
+    (τ.property _ (triangleReturnInterpolation_boundary t s hs)).trans (τ.property s hs).symm
+
+private def ThirdHurewicz.nativeSquareNullHomotopy {X : Type*} [TopologicalSpace X] {x : X}
+    [hπ : Subsingleton (π_ 2 X x)] (p : GenLoop (Fin 2) X x) :
+    p.val.HomotopyRel (ContinuousMap.const (Fin 2 → (unitInterval)) x) (Cube.boundary (Fin 2)) :=
+  Classical.choice
+    (show GenLoop.Homotopic p GenLoop.const from
+      Quotient.exact (@Subsingleton.elim (π_ 2 X x) hπ ⟦p⟧ ⟦GenLoop.const⟧))
+
+private def ThirdHurewicz.nativeSquareNullHomotopy_comp {X : Type*} [TopologicalSpace X] {x : X}
+    {A : Type*} [TopologicalSpace A] [Subsingleton (π_ 2 X x)] (p : GenLoop (Fin 2) X x)
+    (r : C(A, Fin 2 → (unitInterval))) (S : Set A) (hr : Set.MapsTo r S (Cube.boundary (Fin 2))) :
+    (p.val.comp r).HomotopyRel (ContinuousMap.const A x) S
+    where
+  toFun z := nativeSquareNullHomotopy p (z.1, r z.2)
+  continuous_toFun :=
+    (nativeSquareNullHomotopy p).continuous.comp
+      (continuous_fst.prodMk (r.continuous.comp continuous_snd))
+  map_zero_left a := (nativeSquareNullHomotopy p).apply_zero (r a)
+  map_one_left a := (nativeSquareNullHomotopy p).apply_one (r a)
+  prop' t _ ha := (nativeSquareNullHomotopy p).eq_fst t (hr ha)
+
+private def ThirdHurewicz.triangleNullHomotopyUnnormalized {X : Type} [TopologicalSpace X] {x : X}
+    [Subsingleton (π_ 2 X x)] (τ : SecondHurewicz.SimplyConnected.BasedTriangle x) :
+    τ.val.HomotopyRel (ContinuousMap.const (FirstHurewicz.Simplex 2) x)
+      SecondHurewicz.SimplyConnected.triangleBoundary :=
+  ContinuousMap.HomotopyRel.trans (triangleReturnHomotopy τ)
+    (nativeSquareNullHomotopy_comp (SecondHurewicz.SimplyConnected.basedTriangleLoop τ)
+      triangleCubicalReturn SecondHurewicz.SimplyConnected.triangleBoundary
+      (fun _ hs => triangleCubicalReturn_boundary _ hs))
+
+private def ThirdHurewicz.triangleNullHomotopy {X : Type} [TopologicalSpace X] {x : X}
+    [Subsingleton (π_ 2 X x)] (τ : SecondHurewicz.SimplyConnected.BasedTriangle x) :
+    τ.val.HomotopyRel (ContinuousMap.const (FirstHurewicz.Simplex 2) x)
+      SecondHurewicz.SimplyConnected.triangleBoundary := by
+  classical
+    exact
+    if h : τ = SecondHurewicz.SimplyConnected.constantBasedTriangle x then
+      ContinuousMap.HomotopyRel.cast
+        (ContinuousMap.HomotopyRel.refl (ContinuousMap.const (FirstHurewicz.Simplex 2) x)
+          SecondHurewicz.SimplyConnected.triangleBoundary)
+        (congrArg (fun υ : SecondHurewicz.SimplyConnected.BasedTriangle x => υ.val) h).symm rfl
+    else triangleNullHomotopyUnnormalized τ
+
+private theorem ThirdHurewicz.triangleNullHomotopy_zero {X : Type} [TopologicalSpace X] {x : X}
+    [Subsingleton (π_ 2 X x)] (τ : SecondHurewicz.SimplyConnected.BasedTriangle x)
+    (s : FirstHurewicz.Simplex 2) : triangleNullHomotopy τ (0, s) = τ.val s :=
+  (triangleNullHomotopy τ).apply_zero s
+
+private theorem ThirdHurewicz.triangleNullHomotopy_one {X : Type} [TopologicalSpace X] {x : X}
+    [Subsingleton (π_ 2 X x)] (τ : SecondHurewicz.SimplyConnected.BasedTriangle x)
+    (s : FirstHurewicz.Simplex 2) : triangleNullHomotopy τ (1, s) = x :=
+  (triangleNullHomotopy τ).apply_one s
+
+@[simp]
+private theorem ThirdHurewicz.triangleNullHomotopy_constant {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 2 X x)] :
+    triangleNullHomotopy (SecondHurewicz.SimplyConnected.constantBasedTriangle x) =
+      ContinuousMap.HomotopyRel.refl (ContinuousMap.const (FirstHurewicz.Simplex 2) x)
+        SecondHurewicz.SimplyConnected.triangleBoundary := by
+  classical
+  unfold triangleNullHomotopy
+  rw [dite_eq_left rfl]
+  rfl
+
+private theorem ThirdHurewicz.triangleNullHomotopy_constant_toContinuousMap {X : Type}
+    [TopologicalSpace X] (x : X) [Subsingleton (π_ 2 X x)] :
+    (triangleNullHomotopy
+          (SecondHurewicz.SimplyConnected.constantBasedTriangle x)).toContinuousMap =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 2) x := by
+  rw [triangleNullHomotopy_constant]
+  rfl
+
+private def ThirdHurewicz.triangleStraighteningHomotopy {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 2 X x)] (smp : FirstHurewicz.SingularSimplex X 2) :
+    C((unitInterval) × FirstHurewicz.Simplex 2, X) := by
+  classical
+    exact
+    if h : ∀ s ∈ SecondHurewicz.SimplyConnected.triangleBoundary, smp s = x then
+      (triangleNullHomotopy
+          (⟨smp, h⟩ : SecondHurewicz.SimplyConnected.BasedTriangle x)).toContinuousMap
+    else SecondHurewicz.SimplyConnected.stationarySimplexHomotopy 2 smp
+
+@[simp]
+private theorem
+    ThirdHurewicz.triangleStraighteningHomotopy_zero {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 2 X x)] (smp : FirstHurewicz.SingularSimplex X 2)
+    (s : FirstHurewicz.Simplex 2) : triangleStraighteningHomotopy x smp (0, s) = smp s := by
+  classical
+  unfold triangleStraighteningHomotopy
+  split
+  · rename_i h
+    exact triangleNullHomotopy_zero (⟨smp, h⟩ : SecondHurewicz.SimplyConnected.BasedTriangle x) s
+  · rfl
+
+private theorem
+    ThirdHurewicz.triangleStraighteningHomotopy_one {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 2 X x)] (smp : FirstHurewicz.SingularSimplex X 2)
+    (h : ∀ s ∈ SecondHurewicz.SimplyConnected.triangleBoundary, smp s = x)
+    (s : FirstHurewicz.Simplex 2) : triangleStraighteningHomotopy x smp (1, s) = x := by
+  classical
+  rw [triangleStraighteningHomotopy, dite_eq_left h]
+  exact triangleNullHomotopy_one (⟨smp, h⟩ : SecondHurewicz.SimplyConnected.BasedTriangle x) s
+
+private theorem ThirdHurewicz.triangleStraighteningHomotopy_boundary {X : Type} [TopologicalSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] (smp : FirstHurewicz.SingularSimplex X 2)
+    (r : (unitInterval)) (s : FirstHurewicz.Simplex 2)
+    (hs : s ∈ SecondHurewicz.SimplyConnected.triangleBoundary) :
+    triangleStraighteningHomotopy x smp (r, s) = smp s := by
+  classical
+  unfold triangleStraighteningHomotopy
+  split
+  · rename_i h
+    exact
+      (triangleNullHomotopy (⟨smp, h⟩ : SecondHurewicz.SimplyConnected.BasedTriangle x)).eq_fst r
+        hs
+  · rfl
+
+@[simp]
+private theorem
+    ThirdHurewicz.triangleStraighteningHomotopy_const {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 2 X x)] :
+    triangleStraighteningHomotopy x (ContinuousMap.const (FirstHurewicz.Simplex 2) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 2) x := by
+  classical
+  have h :
+    ∀ s ∈ SecondHurewicz.SimplyConnected.triangleBoundary,
+      (ContinuousMap.const (FirstHurewicz.Simplex 2) x) s = x :=
+    fun _ _ => rfl
+  rw [triangleStraighteningHomotopy, dite_eq_left h]
+  exact triangleNullHomotopy_constant_toContinuousMap x
+
+private theorem
+    ThirdHurewicz.triangleStraighteningHomotopy_face {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 2 X x)] :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 1
+      (SecondHurewicz.SimplyConnected.stationarySimplexHomotopy 1)
+      (triangleStraighteningHomotopy x) := by
+  intro smp i
+  ext u
+  change
+    triangleStraighteningHomotopy x smp (u.1, FirstHurewicz.simplexFace 1 i u.2) =
+      smp (FirstHurewicz.simplexFace 1 i u.2)
+  exact
+    triangleStraighteningHomotopy_boundary x smp u.1 _
+      ⟨i, FirstHurewicz.simplexFace_apply_self 1 i u.2⟩
+
+private def ThirdHurewicz.threeSimplexBoundary : Set (FirstHurewicz.Simplex 3) :=
+  {s | ∃ i, s i = 0}
+
+private def ThirdHurewicz.BasedThreeSimplex {X : Type} [TopologicalSpace X] (x : X) :=
+  { τ : C(FirstHurewicz.Simplex 3, X) // ∀ s ∈ threeSimplexBoundary, τ s = x }
+
+private def ThirdHurewicz.threeSimplexQuotient : C(Fin 3 → (unitInterval), FirstHurewicz.Simplex 3)
+    where
+  toFun
+    u :=
+    ⟨![1 - (u 0 : ℝ), (u 0 : ℝ) - Min.min (u 0 : ℝ) (u 1 : ℝ),
+        Min.min (u 0 : ℝ) (u 1 : ℝ) - Min.min (u 0 : ℝ) (Min.min (u 1 : ℝ) (u 2 : ℝ)),
+        Min.min (u 0 : ℝ) (Min.min (u 1 : ℝ) (u 2 : ℝ))],
+      by
+      constructor
+      · intro i
+        fin_cases i
+        · exact sub_nonneg.mpr (u 0).property.2
+        · exact sub_nonneg.mpr (min_le_left _ _)
+        · exact sub_nonneg.mpr (min_le_min_left _ (min_le_left _ _))
+        · exact le_min (u 0).property.1 (le_min (u 1).property.1 (u 2).property.1)
+      · simp only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero, Matrix.cons_val_zero,
+          Matrix.cons_val_succ, Matrix.cons_val_fin_one]
+        ring⟩
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    apply continuous_pi
+    intro i
+    fin_cases i <;> dsimp <;> fun_prop
+
+@[simp]
+private theorem ThirdHurewicz.threeSimplexQuotient_zero (u : Fin 3 → (unitInterval)) :
+    threeSimplexQuotient u 0 = 1 - (u 0 : ℝ) :=
+  rfl
+
+@[simp]
+private theorem ThirdHurewicz.threeSimplexQuotient_one (u : Fin 3 → (unitInterval)) :
+    threeSimplexQuotient u 1 = (u 0 : ℝ) - Min.min (u 0 : ℝ) (u 1 : ℝ) :=
+  rfl
+
+@[simp]
+private theorem ThirdHurewicz.threeSimplexQuotient_two (u : Fin 3 → (unitInterval)) :
+    threeSimplexQuotient u 2 =
+      Min.min (u 0 : ℝ) (u 1 : ℝ) - Min.min (u 0 : ℝ) (Min.min (u 1 : ℝ) (u 2 : ℝ)) :=
+  rfl
+
+@[simp]
+private theorem ThirdHurewicz.threeSimplexQuotient_three (u : Fin 3 → (unitInterval)) :
+    threeSimplexQuotient u 3 = Min.min (u 0 : ℝ) (Min.min (u 1 : ℝ) (u 2 : ℝ)) :=
+  rfl
+
+private theorem ThirdHurewicz.threeSimplexQuotient_boundary (u : Fin 3 → (unitInterval))
+    (hu : u ∈ Cube.boundary (Fin 3)) : threeSimplexQuotient u ∈ threeSimplexBoundary := by
+  rcases hu with ⟨i, hi | hi⟩
+  · fin_cases i
+    · change u 0 = 0 at hi
+      refine ⟨3, ?_⟩
+      rw [threeSimplexQuotient_three, hi]
+      exact min_eq_left (le_min (u 1).property.1 (u 2).property.1)
+    · change u 1 = 0 at hi
+      refine ⟨3, ?_⟩
+      rw [threeSimplexQuotient_three, hi]
+      change Min.min (u 0 : ℝ) (Min.min (0 : ℝ) (u 2 : ℝ)) = 0
+      rw [min_eq_left (u 2).property.1]
+      exact min_eq_right (u 0).property.1
+    · change u 2 = 0 at hi
+      refine ⟨3, ?_⟩
+      rw [threeSimplexQuotient_three, hi]
+      change Min.min (u 0 : ℝ) (Min.min (u 1 : ℝ) (0 : ℝ)) = 0
+      rw [min_eq_right (u 1).property.1]
+      exact min_eq_right (u 0).property.1
+  · fin_cases i
+    · change u 0 = 1 at hi
+      refine ⟨0, ?_⟩
+      rw [threeSimplexQuotient_zero, hi]
+      norm_num
+    · change u 1 = 1 at hi
+      refine ⟨1, ?_⟩
+      rw [threeSimplexQuotient_one, hi]
+      change (u 0 : ℝ) - Min.min (u 0 : ℝ) (1 : ℝ) = 0
+      rw [min_eq_left (u 0).property.2, sub_self]
+    · change u 2 = 1 at hi
+      refine ⟨2, ?_⟩
+      rw [threeSimplexQuotient_two, hi]
+      change Min.min (u 0 : ℝ) (u 1 : ℝ) - Min.min (u 0 : ℝ) (Min.min (u 1 : ℝ) (1 : ℝ)) = 0
+      rw [min_eq_left (u 1).property.2, sub_self]
+
+private theorem ThirdHurewicz.threeSimplexQuotient_boundary_of_first_le (u : Fin 3 → (unitInterval))
+    (h : (u 0 : ℝ) ≤ u 1) : threeSimplexQuotient u ∈ threeSimplexBoundary :=
+  ⟨1, by rw [threeSimplexQuotient_one, min_eq_left h, sub_self]⟩
+
+private theorem
+    ThirdHurewicz.threeSimplexQuotient_boundary_of_second_le (u : Fin 3 → (unitInterval))
+    (h : (u 1 : ℝ) ≤ u 2) : threeSimplexQuotient u ∈ threeSimplexBoundary :=
+  ⟨2, by rw [threeSimplexQuotient_two, min_eq_left h, sub_self]⟩
+
+private def ThirdHurewicz.basedThreeSimplexLoop {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedThreeSimplex x) : GenLoop (Fin 3) X x :=
+  ⟨τ.val.comp threeSimplexQuotient, fun u hu => τ.property _ (threeSimplexQuotient_boundary u hu)⟩
+
+private def ThirdHurewicz.basedThreeSimplexClass {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedThreeSimplex x) : Additive (π_ 3 X x) :=
+  Additive.ofMul (⟦basedThreeSimplexLoop τ⟧ : π_ 3 X x)
+
+private theorem ThirdHurewicz.basedThreeSimplex_face {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedThreeSimplex x) (i : Fin 4) :
+    τ.val.comp (FirstHurewicz.simplexFace 2 i) =
+      ContinuousMap.const (FirstHurewicz.Simplex 2) x := by
+  apply ContinuousMap.ext
+  intro s
+  exact τ.property _ ⟨i, FirstHurewicz.simplexFace_apply_self 2 i s⟩
+
+private def ThirdHurewicz.constantBasedThreeSimplex {X : Type} [TopologicalSpace X] (x : X) :
+    BasedThreeSimplex x :=
+  ⟨ContinuousMap.const (FirstHurewicz.Simplex 3) x, fun _ _ => rfl⟩
+
+private def ThirdHurewicz.triangleThreeSimplexHomotopy {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 2 X x)] (smp : FirstHurewicz.SingularSimplex X 3) :
+    C((unitInterval) × FirstHurewicz.Simplex 3, X) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy
+    (SecondHurewicz.SimplyConnected.stationarySimplexHomotopy 1) (triangleStraighteningHomotopy x)
+    (triangleStraighteningHomotopy_face x) (triangleStraighteningHomotopy_zero x) smp
+
+@[simp]
+private theorem
+    ThirdHurewicz.triangleThreeSimplexHomotopy_zero {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 2 X x)] (smp : FirstHurewicz.SingularSimplex X 3)
+    (s : FirstHurewicz.Simplex 3) : triangleThreeSimplexHomotopy x smp (0, s) = smp s :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_zero _ _ _ _ smp s
+
+private theorem
+    ThirdHurewicz.triangleThreeSimplexHomotopy_face {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 2 X x)] :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 2 (triangleStraighteningHomotopy x)
+      (triangleThreeSimplexHomotopy x) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_face
+    (SecondHurewicz.SimplyConnected.stationarySimplexHomotopy 1) (triangleStraighteningHomotopy x)
+    (triangleStraighteningHomotopy_face x) (triangleStraighteningHomotopy_zero x)
+
+@[simp]
+private theorem
+    ThirdHurewicz.triangleThreeSimplexHomotopy_const {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 2 X x)] :
+    triangleThreeSimplexHomotopy x (ContinuousMap.const (FirstHurewicz.Simplex 3) x) =
+      ContinuousMap.const ((unitInterval) × FirstHurewicz.Simplex 3) x :=
+  extendCoherentSimplexHomotopy_const (SecondHurewicz.SimplyConnected.stationarySimplexHomotopy 1)
+    (triangleStraighteningHomotopy x) (triangleStraighteningHomotopy_face x)
+    (triangleStraighteningHomotopy_zero x) x (triangleStraighteningHomotopy_const x)
+
+private def ThirdHurewicz.triangleFourSimplexHomotopy {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 2 X x)] (smp : FirstHurewicz.SingularSimplex X 4) :
+    C((unitInterval) × FirstHurewicz.Simplex 4, X) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy (triangleStraighteningHomotopy x)
+    (triangleThreeSimplexHomotopy x) (triangleThreeSimplexHomotopy_face x)
+    (triangleThreeSimplexHomotopy_zero x) smp
+
+private theorem
+    ThirdHurewicz.triangleFourSimplexHomotopy_face {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 2 X x)] :
+    SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 3 (triangleThreeSimplexHomotopy x)
+      (triangleFourSimplexHomotopy x) :=
+  SecondHurewicz.SimplyConnected.extendCoherentSimplexHomotopy_face
+    (triangleStraighteningHomotopy x) (triangleThreeSimplexHomotopy x)
+    (triangleThreeSimplexHomotopy_face x) (triangleThreeSimplexHomotopy_zero x)
+
+private theorem ThirdHurewicz.triangleThreeSimplexHomotopy_one_face {X : Type} [TopologicalSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] (smp : FirstHurewicz.SingularSimplex X 3)
+    (h :
+      ∀ i : Fin 4,
+        ∀ s ∈ SecondHurewicz.SimplyConnected.triangleBoundary,
+          (smp.comp (FirstHurewicz.simplexFace 2 i)) s = x)
+    (i : Fin 4) :
+    (SecondHurewicz.SimplyConnected.timeSlice (triangleThreeSimplexHomotopy x smp) 1).comp
+        (FirstHurewicz.simplexFace 2 i) =
+      ContinuousMap.const (FirstHurewicz.Simplex 2) x := by
+  rw [SecondHurewicz.SimplyConnected.timeSlice_face (triangleThreeSimplexHomotopy_face x)]
+  ext s
+  exact triangleStraighteningHomotopy_one x (smp.comp (FirstHurewicz.simplexFace 2 i)) (h i) s
+
+private theorem
+    ThirdHurewicz.triangleThreeSimplexHomotopy_one_boundary {X : Type} [TopologicalSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] (smp : FirstHurewicz.SingularSimplex X 3)
+    (h :
+      ∀ i : Fin 4,
+        ∀ s ∈ SecondHurewicz.SimplyConnected.triangleBoundary,
+          (smp.comp (FirstHurewicz.simplexFace 2 i)) s = x)
+    (s : FirstHurewicz.Simplex 3) (hs : s ∈ threeSimplexBoundary) :
+    SecondHurewicz.SimplyConnected.timeSlice (triangleThreeSimplexHomotopy x smp) 1 s = x := by
+  obtain ⟨i, t, ht⟩ :=
+    SecondHurewicz.SimplyConnected.simplexBoundary_exists_face 2
+      (⟨s, hs⟩ : SecondHurewicz.SimplyConnected.SimplexBoundary 3)
+  have he : FirstHurewicz.simplexFace 2 i t = s := congrArg Subtype.val ht
+  rw [← he]
+  exact
+    congrArg (fun f : C(FirstHurewicz.Simplex 2, X) => f t)
+      (triangleThreeSimplexHomotopy_one_face x smp h i)
+
+private def ThirdHurewicz.triangleStraightenedThreeSimplex {X : Type} [TopologicalSpace X] (x : X)
+    [Subsingleton (π_ 2 X x)] (smp : FirstHurewicz.SingularSimplex X 3)
+    (h :
+      ∀ i : Fin 4,
+        ∀ s ∈ SecondHurewicz.SimplyConnected.triangleBoundary,
+          (smp.comp (FirstHurewicz.simplexFace 2 i)) s = x) :
+    BasedThreeSimplex x :=
+  ⟨SecondHurewicz.SimplyConnected.timeSlice (triangleThreeSimplexHomotopy x smp) 1,
+    triangleThreeSimplexHomotopy_one_boundary x smp h⟩
+
+private def
+    ThirdHurewicz.normalizedThreeSimplex {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] (smp : FirstHurewicz.SingularSimplex X 3) :
+    BasedThreeSimplex x :=
+  triangleStraightenedThreeSimplex x
+    (SecondHurewicz.SimplyConnected.normalizedTetrahedronMap x smp)
+    (SecondHurewicz.SimplyConnected.normalizedTetrahedronMap_face_boundary x smp)
+
+private def ThirdHurewicz.normalizedFourSimplexMap {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 4) : FirstHurewicz.SingularSimplex X 4 :=
+  SecondHurewicz.SimplyConnected.timeSlice
+    (triangleFourSimplexHomotopy x (edgeNormalizedFourSimplexMap x smp)) 1
+
+private theorem ThirdHurewicz.normalizedFourSimplexMap_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 4) (i : Fin 5) :
+    (normalizedFourSimplexMap x smp).comp (FirstHurewicz.simplexFace 3 i) =
+      (normalizedThreeSimplex x (smp.comp (FirstHurewicz.simplexFace 3 i))).val := by
+  change
+    (SecondHurewicz.SimplyConnected.timeSlice
+            (triangleFourSimplexHomotopy x (edgeNormalizedFourSimplexMap x smp)) 1).comp
+        (FirstHurewicz.simplexFace 3 i) =
+      _
+  rw [SecondHurewicz.SimplyConnected.timeSlice_face (triangleFourSimplexHomotopy_face x),
+    edgeNormalizedFourSimplexMap_face]
+  rfl
+
+private theorem ThirdHurewicz.normalizedFourSimplexMap_face_boundary {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 4) (i : Fin 5) (s : FirstHurewicz.Simplex 3)
+    (hs : s ∈ threeSimplexBoundary) :
+    normalizedFourSimplexMap x smp (FirstHurewicz.simplexFace 3 i s) = x := by
+  have hf :=
+    congrArg (fun f : C(FirstHurewicz.Simplex 3, X) => f s)
+      (normalizedFourSimplexMap_face x smp i)
+  exact
+    hf.trans ((normalizedThreeSimplex x (smp.comp (FirstHurewicz.simplexFace 3 i))).property s hs)
+
+private def ThirdHurewicz.threeSimplexClassOperator {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] :
+    FirstHurewicz.Chains X 3 →ₗ[ℤ] Additive (π_ 3 X x) :=
+  FirstHurewicz.chainLift X 3 fun smp => basedThreeSimplexClass (normalizedThreeSimplex x smp)
+
+@[simp]
+private theorem ThirdHurewicz.threeSimplexClassOperator_simplex {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 3) :
+    threeSimplexClassOperator x (FirstHurewicz.simplexChain X 3 smp) =
+      basedThreeSimplexClass (normalizedThreeSimplex x smp) :=
+  FirstHurewicz.chainLift_simplex X 3 _ smp
+
+private def ThirdHurewicz.straightenedThreeCycle {X : Type} [TopologicalSpace X]
+    (H₂ : FirstHurewicz.SingularSimplex X 2 → C((unitInterval) × FirstHurewicz.Simplex 2, X))
+    (H₃ : FirstHurewicz.SingularSimplex X 3 → C((unitInterval) × FirstHurewicz.Simplex 3, X))
+    (h : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 2 H₂ H₃)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3 :=
+  SingularMayerVietoris.ModuleHomology.mkCycle (FirstHurewicz.singularComplex X) 3
+    (SecondHurewicz.SimplyConnected.simplexEndpointOperator 3 H₃ 1 c.1)
+    (by
+      rw [SecondHurewicz.SimplyConnected.simplexEndpointOperator_boundary 2 H₂ H₃ h,
+        SingularMayerVietoris.ModuleHomology.cycle_condition (FirstHurewicz.singularComplex X) 3
+          c,
+        map_zero])
+
+private theorem ThirdHurewicz.straightenedThreeCycle_boundary {X : Type} [TopologicalSpace X]
+    (H₂ : FirstHurewicz.SingularSimplex X 2 → C((unitInterval) × FirstHurewicz.Simplex 2, X))
+    (H₃ : FirstHurewicz.SingularSimplex X 3 → C((unitInterval) × FirstHurewicz.Simplex 3, X))
+    (h : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 2 H₂ H₃)
+    (h₀ : ∀ smp, SecondHurewicz.SimplyConnected.timeSlice (H₃ smp) 0 = smp)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3) :
+    ((FirstHurewicz.singularComplex X).d 4 3).hom
+        (SecondHurewicz.SimplyConnected.simplexPrismOperator 3 H₃ c.1) =
+      (straightenedThreeCycle H₂ H₃ h c).1 - c.1 := by
+  rw [SecondHurewicz.SimplyConnected.simplexPrismOperator_boundary 2 H₂ H₃ h,
+    SecondHurewicz.SimplyConnected.simplexEndpointOperator_zero 3 H₃ h₀,
+    SingularMayerVietoris.ModuleHomology.cycle_condition (FirstHurewicz.singularComplex X) 3 c,
+    map_zero, sub_zero]
+  rfl
+
+private theorem ThirdHurewicz.straightenedThreeCycle_class {X : Type} [TopologicalSpace X]
+    (H₂ : FirstHurewicz.SingularSimplex X 2 → C((unitInterval) × FirstHurewicz.Simplex 2, X))
+    (H₃ : FirstHurewicz.SingularSimplex X 3 → C((unitInterval) × FirstHurewicz.Simplex 3, X))
+    (h : SecondHurewicz.SimplyConnected.FaceCompatibleHomotopies 2 H₂ H₃)
+    (h₀ : ∀ smp, SecondHurewicz.SimplyConnected.timeSlice (H₃ smp) 0 = smp)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3) :
+    SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 3
+        (straightenedThreeCycle H₂ H₃ h c) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 3 c := by
+  apply
+    (SingularMayerVietoris.ModuleHomology.cycleClass_eq_iff (FirstHurewicz.singularComplex X) 3 _
+        _).mpr
+  exact
+    ⟨SecondHurewicz.SimplyConnected.simplexPrismOperator 3 H₃ c.1,
+      straightenedThreeCycle_boundary H₂ H₃ h h₀ c⟩
+
+private def
+    ThirdHurewicz.normalizedThreeChain {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] : FirstHurewicz.Chains X 3 →ₗ[ℤ] FirstHurewicz.Chains X 3 :=
+  FirstHurewicz.chainLift X 3 fun smp =>
+    FirstHurewicz.simplexChain X 3 (normalizedThreeSimplex x smp).val
+
+@[simp]
+private theorem ThirdHurewicz.normalizedThreeChain_simplex {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 3) :
+    normalizedThreeChain x (FirstHurewicz.simplexChain X 3 smp) =
+      FirstHurewicz.simplexChain X 3 (normalizedThreeSimplex x smp).val :=
+  FirstHurewicz.chainLift_simplex X 3 _ smp
+
+private theorem ThirdHurewicz.normalizedThreeChain_eq {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] :
+    normalizedThreeChain x =
+      (SecondHurewicz.SimplyConnected.simplexEndpointOperator 3 (triangleThreeSimplexHomotopy x)
+            1).comp
+        ((SecondHurewicz.SimplyConnected.simplexEndpointOperator 3
+              (SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy x) 1).comp
+          (SecondHurewicz.SimplyConnected.simplexEndpointOperator 3
+            (SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy x 3) 1)) := by
+  apply FirstHurewicz.chainMap_ext X 3
+  intro smp
+  simp only [normalizedThreeChain_simplex, LinearMap.comp_apply,
+    SecondHurewicz.SimplyConnected.simplexEndpointOperator_simplex]
+  rfl
+
+private def ThirdHurewicz.vertexNormalizedThreeCycle {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3 :=
+  straightenedThreeCycle (SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy x 2)
+    (SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy x 3)
+    (SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy_face x 2) c
+
+private theorem ThirdHurewicz.vertexNormalizedThreeCycle_class {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3) :
+    SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 3
+        (vertexNormalizedThreeCycle x c) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 3 c :=
+  straightenedThreeCycle_class _ _
+    (SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy_face x 2)
+    (SecondHurewicz.SimplyConnected.vertexStraighteningHomotopy_timeSlice_zero x 3) c
+
+private def ThirdHurewicz.edgeNormalizedThreeCycle {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3 :=
+  straightenedThreeCycle (SecondHurewicz.SimplyConnected.triangleEdgeStraighteningHomotopy x)
+    (SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy x)
+    (SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy_face x)
+    (vertexNormalizedThreeCycle x c)
+
+private theorem ThirdHurewicz.edgeNormalizedThreeCycle_class {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3) :
+    SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 3
+        (edgeNormalizedThreeCycle x c) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 3 c := by
+  have h₀ :
+    ∀ smp,
+      SecondHurewicz.SimplyConnected.timeSlice
+          (SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy x smp) 0 =
+        smp := by
+    intro smp
+    ext s
+    exact SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy_zero x smp s
+  exact
+    (straightenedThreeCycle_class _ _
+          (SecondHurewicz.SimplyConnected.tetrahedronEdgeStraighteningHomotopy_face x) h₀
+          (vertexNormalizedThreeCycle x c)).trans
+      (vertexNormalizedThreeCycle_class x c)
+
+private def
+    ThirdHurewicz.normalizedThreeCycle {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)]
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3 :=
+  straightenedThreeCycle (triangleStraighteningHomotopy x) (triangleThreeSimplexHomotopy x)
+    (triangleThreeSimplexHomotopy_face x) (edgeNormalizedThreeCycle x c)
+
+@[simp]
+private theorem ThirdHurewicz.normalizedThreeCycle_val {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)]
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3) :
+    (normalizedThreeCycle x c).val = normalizedThreeChain x c.val := by
+  rw [normalizedThreeChain_eq]
+  rfl
+
+private theorem ThirdHurewicz.normalizedThreeCycle_class {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)]
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3) :
+    SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 3
+        (normalizedThreeCycle x c) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 3 c := by
+  have h₀ :
+    ∀ smp,
+      SecondHurewicz.SimplyConnected.timeSlice (triangleThreeSimplexHomotopy x smp) 0 = smp := by
+    intro smp
+    ext s
+    exact triangleThreeSimplexHomotopy_zero x smp s
+  exact
+    (straightenedThreeCycle_class _ _ (triangleThreeSimplexHomotopy_face x) h₀
+          (edgeNormalizedThreeCycle x c)).trans
+      (edgeNormalizedThreeCycle_class x c)
+
+private theorem ThirdHurewicz.basedThreeSimplex_boundary {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedThreeSimplex x) :
+    ((FirstHurewicz.singularComplex X).d 3 2).hom (FirstHurewicz.simplexChain X 3 τ.val) = 0 := by
+  change (FirstHurewicz.singularComplex X).d 3 2 (FirstHurewicz.simplexChain X 3 τ.val) = 0
+  rw [FirstHurewicz.boundary_simplex]
+  simp [basedThreeSimplex_face, Fin.sum_univ_succ]
+
+private def ThirdHurewicz.basedThreeSimplexChain {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedThreeSimplex x) : FirstHurewicz.Chains X 3 :=
+  FirstHurewicz.simplexChain X 3 τ.val -
+    FirstHurewicz.simplexChain X 3 (ContinuousMap.const (FirstHurewicz.Simplex 3) x)
+
+private theorem
+    ThirdHurewicz.basedThreeSimplexChain_boundary {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedThreeSimplex x) :
+    ((FirstHurewicz.singularComplex X).d 3 2).hom (basedThreeSimplexChain τ) = 0 := by
+  rw [basedThreeSimplexChain, map_sub, basedThreeSimplex_boundary]
+  have hc := basedThreeSimplex_boundary (constantBasedThreeSimplex x)
+  change
+    ((FirstHurewicz.singularComplex X).d 3 2).hom
+        (FirstHurewicz.simplexChain X 3 (ContinuousMap.const (FirstHurewicz.Simplex 3) x)) =
+      0 at hc
+  rw [hc, sub_self]
+
+private def ThirdHurewicz.basedThreeSimplexCycle {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedThreeSimplex x) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3 :=
+  SingularMayerVietoris.ModuleHomology.mkCycle (FirstHurewicz.singularComplex X) 3
+    (basedThreeSimplexChain τ) (basedThreeSimplexChain_boundary τ)
+
+@[simp]
+private theorem ThirdHurewicz.basedThreeSimplexCycle_val {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedThreeSimplex x) :
+    (basedThreeSimplexCycle τ).val =
+      FirstHurewicz.simplexChain X 3 τ.val -
+        FirstHurewicz.simplexChain X 3 (ContinuousMap.const (FirstHurewicz.Simplex 3) x) :=
+  rfl
+
+private def
+    ThirdHurewicz.thirdHomologyDesc {X : Type} [TopologicalSpace X] {M : Type*} [AddCommGroup M]
+    [Module ℤ M] (F : FirstHurewicz.Chains X 3 →ₗ[ℤ] M)
+    (hF :
+      ∀ b : FirstHurewicz.Chains X 4, F (((FirstHurewicz.singularComplex X).d 4 3).hom b) = 0) :
+    SingularMayerVietoris.SingularHomology X 3 →ₗ[ℤ] M :=
+  PeriodTorusHigherHomology.homologyDesc (FirstHurewicz.singularComplex X) 3
+    (F.comp
+      (SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3).subtype)
+    (fun b => hF b)
+
+@[simp]
+private theorem
+    ThirdHurewicz.thirdHomologyDesc_cycleClass {X : Type} [TopologicalSpace X] {M : Type*}
+    [AddCommGroup M] [Module ℤ M] (F : FirstHurewicz.Chains X 3 →ₗ[ℤ] M)
+    (hF : ∀ b : FirstHurewicz.Chains X 4, F (((FirstHurewicz.singularComplex X).d 4 3).hom b) = 0)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3) :
+    thirdHomologyDesc F hF
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 3 c) =
+      F c.1 :=
+  PeriodTorusHigherHomology.homologyDesc_cycleClass (FirstHurewicz.singularComplex X) 3 _ _ c
+
+private theorem
+    ThirdHurewicz.comp_thirdHomologyDesc_eq_id {X : Type} [TopologicalSpace X] {M : Type*}
+    [AddCommGroup M] [Module ℤ M] (F : FirstHurewicz.Chains X 3 →ₗ[ℤ] M)
+    (hF : ∀ b : FirstHurewicz.Chains X 4, F (((FirstHurewicz.singularComplex X).d 4 3).hom b) = 0)
+    (g : M →ₗ[ℤ] SingularMayerVietoris.SingularHomology X 3)
+    (hg :
+      ∀ c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3,
+        g (F c.1) =
+          SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 3 c) :
+    g.comp (thirdHomologyDesc F hF) = LinearMap.id := by
+  apply PeriodTorusHigherHomology.homologyLinearMap_ext (FirstHurewicz.singularComplex X) 3
+  intro c
+  simpa only [LinearMap.comp_apply, thirdHomologyDesc_cycleClass, LinearMap.id_apply] using hg c
+
+private def ThirdHurewicz.constantThreeChain {X : Type} [TopologicalSpace X] (x : X) :
+    FirstHurewicz.Chains X 3 :=
+  FirstHurewicz.simplexChain X 3 (ContinuousMap.const (FirstHurewicz.Simplex 3) x)
+
+private def ThirdHurewicz.constantFourChain {X : Type} [TopologicalSpace X] (x : X) :
+    FirstHurewicz.Chains X 4 :=
+  FirstHurewicz.simplexChain X 4 (ContinuousMap.const (FirstHurewicz.Simplex 4) x)
+
+private theorem
+    ThirdHurewicz.boundaryThree_constantThreeChain {X : Type} [TopologicalSpace X] (x : X) :
+    ((FirstHurewicz.singularComplex X).d 3 2).hom (constantThreeChain x) = 0 := by
+  rw [constantThreeChain, FirstHurewicz.boundary_simplex]
+  change
+    (∑ i : Fin 4,
+        (-1 : ℤ) ^ i.val •
+          FirstHurewicz.simplexChain X 2 (ContinuousMap.const (FirstHurewicz.Simplex 2) x)) =
+      0
+  simp [Fin.sum_univ_succ]
+
+private theorem
+    ThirdHurewicz.boundaryFour_constantFourChain {X : Type} [TopologicalSpace X] (x : X) :
+    ((FirstHurewicz.singularComplex X).d 4 3).hom (constantFourChain x) = constantThreeChain x := by
+  rw [constantFourChain, FirstHurewicz.boundary_simplex]
+  change (∑ i : Fin 5, (-1 : ℤ) ^ i.val • constantThreeChain x) = constantThreeChain x
+  simp [Fin.sum_univ_succ]
+
+private def ThirdHurewicz.constantThreeCycle {X : Type} [TopologicalSpace X] (x : X) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3 :=
+  SingularMayerVietoris.ModuleHomology.mkCycle (FirstHurewicz.singularComplex X) 3
+    (constantThreeChain x) (boundaryThree_constantThreeChain x)
+
+@[simp]
+private theorem ThirdHurewicz.constantThreeCycle_val {X : Type} [TopologicalSpace X] (x : X) :
+    (constantThreeCycle x).1 = constantThreeChain x :=
+  rfl
+
+@[simp]
+private theorem ThirdHurewicz.constantThreeCycle_class {X : Type} [TopologicalSpace X] (x : X) :
+    SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 3
+        (constantThreeCycle x) =
+      0 := by
+  apply
+    (SingularMayerVietoris.ModuleHomology.cycleClass_eq_zero_iff (FirstHurewicz.singularComplex X)
+        3 _).mpr
+  exact ⟨constantFourChain x, boundaryFour_constantFourChain x⟩
+
+private def ThirdHurewicz.normalizedThreeSimplexCycleOperator {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] :
+    FirstHurewicz.Chains X 3 →ₗ[ℤ]
+      SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3 :=
+  FirstHurewicz.chainLift X 3 fun smp => basedThreeSimplexCycle (normalizedThreeSimplex x smp)
+
+@[simp]
+private theorem
+    ThirdHurewicz.normalizedThreeSimplexCycleOperator_simplex {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 3) :
+    normalizedThreeSimplexCycleOperator x (FirstHurewicz.simplexChain X 3 smp) =
+      basedThreeSimplexCycle (normalizedThreeSimplex x smp) :=
+  FirstHurewicz.chainLift_simplex X 3 _ smp
+
+private theorem
+    ThirdHurewicz.normalizedThreeSimplexCycleOperator_val {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] (c : FirstHurewicz.Chains X 3) :
+    (normalizedThreeSimplexCycleOperator x c).val =
+      FirstHurewicz.chainLift X 3
+        (fun smp =>
+          FirstHurewicz.simplexChain X 3 (normalizedThreeSimplex x smp).val -
+            FirstHurewicz.simplexChain X 3 (ContinuousMap.const (FirstHurewicz.Simplex 3) x))
+        c := by
+  have h :
+    (SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3).subtype.comp
+        (normalizedThreeSimplexCycleOperator x) =
+      FirstHurewicz.chainLift X 3
+        (fun smp =>
+          FirstHurewicz.simplexChain X 3 (normalizedThreeSimplex x smp).val -
+            FirstHurewicz.simplexChain X 3 (ContinuousMap.const (FirstHurewicz.Simplex 3) x)) := by
+    apply FirstHurewicz.chainMap_ext X 3
+    intro smp
+    simp only [LinearMap.comp_apply, normalizedThreeSimplexCycleOperator_simplex,
+      Submodule.subtype_apply, basedThreeSimplexCycle_val, FirstHurewicz.chainLift_simplex]
+  exact LinearMap.congr_fun h c
+
+private theorem
+    ThirdHurewicz.normalizedThreeSimplexCycleOperator_cycle {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)]
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3) :
+    normalizedThreeSimplexCycleOperator x c.val =
+      normalizedThreeCycle x c -
+        SecondHurewicz.SimplyConnected.chainAugmentation X 3 c.val • constantThreeCycle x := by
+  apply Subtype.ext
+  change
+    (normalizedThreeSimplexCycleOperator x c.val).val =
+      (normalizedThreeCycle x c).val -
+        SecondHurewicz.SimplyConnected.chainAugmentation X 3 c.val • (constantThreeCycle x).val
+  rw [normalizedThreeSimplexCycleOperator_val,
+    SecondHurewicz.SimplyConnected.chainLift_sub_constant, normalizedThreeCycle_val,
+    constantThreeCycle_val]
+  rfl
+
+private theorem
+    ThirdHurewicz.normalizedThreeSimplexCycleOperator_class {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)]
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3) :
+    SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 3
+        (normalizedThreeSimplexCycleOperator x c.val) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 3 c := by
+  rw [normalizedThreeSimplexCycleOperator_cycle, map_sub, map_zsmul, constantThreeCycle_class,
+    zsmul_zero, sub_zero, normalizedThreeCycle_class]
+
+private abbrev ThirdHurewicz.Geometry.Cube3 :=
+  Fin 3 → (unitInterval)
+
+private def ThirdHurewicz.Geometry.cubeAffineSimplex {n : ℕ} (v : Fin (n + 1) → Cube3) :
+    C(FirstHurewicz.Simplex n, Cube3)
+    where
+  toFun s
+    i :=
+    ⟨∑ j, s j * (v j i : ℝ), by
+      constructor
+      · exact Finset.sum_nonneg fun j _ => mul_nonneg (stdSimplex.zero_le s j) (v j i).property.1
+      · calc
+          ∑ j, s j * (v j i : ℝ) ≤ ∑ j, s j * 1 :=
+            Finset.sum_le_sum fun j _ =>
+              mul_le_mul_of_nonneg_left (v j i).property.2 (stdSimplex.zero_le s j)
+          _ = 1 := by simp only [mul_one, stdSimplex.sum_eq_one]⟩
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    apply Continuous.subtype_mk
+    exact
+      continuous_finsetSum _ fun j _ =>
+        ((continuous_apply j).comp continuous_subtype_val).mul continuous_const
+
+@[simp]
+private theorem
+    ThirdHurewicz.Geometry.cubeAffineSimplex_coordinate {n : ℕ} (v : Fin (n + 1) → Cube3)
+    (s : FirstHurewicz.Simplex n) (i : Fin 3) :
+    (cubeAffineSimplex v s i : ℝ) = ∑ j, s j * (v j i : ℝ) :=
+  rfl
+
+private theorem ThirdHurewicz.Geometry.cubeAffineSimplex_face {n : ℕ} (v : Fin (n + 2) → Cube3)
+    (i : Fin (n + 2)) :
+    (cubeAffineSimplex v).comp (FirstHurewicz.simplexFace n i) =
+      cubeAffineSimplex (fun j => v (i.succAbove j)) := by
+  ext s k
+  change
+    (∑ j : Fin (n + 2), FirstHurewicz.simplexFace n i s j * (v j k : ℝ)) =
+      ∑ j : Fin (n + 1), s j * (v (i.succAbove j) k : ℝ)
+  rw [Fin.sum_univ_succAbove _ i]
+  simp only [FirstHurewicz.simplexFace_apply_self, MulZeroClass.zero_mul,
+    FirstHurewicz.simplexFace_apply_succAbove, zero_add]
+
+private theorem ThirdHurewicz.Geometry.cubeAffineSimplex_constant_coordinate {n : ℕ}
+    (v : Fin (n + 1) → Cube3) (i : Fin 3) (c : (unitInterval)) (h : ∀ j, v j i = c)
+    (s : FirstHurewicz.Simplex n) : cubeAffineSimplex v s i = c := by
+  apply Subtype.ext
+  simp only [cubeAffineSimplex_coordinate, h, ← Finset.sum_mul, stdSimplex.sum_eq_one, one_mul]
+
+private def
+    ThirdHurewicz.Geometry.cubeVertex (e : Equiv.Perm (Fin 3)) (k : Fin 4) : Cube3 := fun i =>
+  if (e.symm i).val < k.val then 1 else 0
+
+private def ThirdHurewicz.Geometry.cubeTetrahedron (e : Equiv.Perm (Fin 3)) :
+    C(FirstHurewicz.Simplex 3, Cube3) :=
+  cubeAffineSimplex (cubeVertex e)
+
+@[simp]
+private theorem ThirdHurewicz.Geometry.cubeTetrahedron_coordinate_zero (e : Equiv.Perm (Fin 3))
+    (s : FirstHurewicz.Simplex 3) : (cubeTetrahedron e s (e 0) : ℝ) = s 1 + s 2 + s 3 := by
+  simp [cubeTetrahedron, cubeAffineSimplex_coordinate, cubeVertex, Fin.sum_univ_succ, add_assoc]
+
+@[simp]
+private theorem ThirdHurewicz.Geometry.cubeTetrahedron_coordinate_one (e : Equiv.Perm (Fin 3))
+    (s : FirstHurewicz.Simplex 3) : (cubeTetrahedron e s (e 1) : ℝ) = s 2 + s 3 := by
+  simp [cubeTetrahedron, cubeAffineSimplex_coordinate, cubeVertex, Fin.sum_univ_succ]
+
+@[simp]
+private theorem ThirdHurewicz.Geometry.cubeTetrahedron_coordinate_two (e : Equiv.Perm (Fin 3))
+    (s : FirstHurewicz.Simplex 3) : (cubeTetrahedron e s (e 2) : ℝ) = s 3 := by
+  simp [cubeTetrahedron, cubeAffineSimplex_coordinate, cubeVertex, Fin.sum_univ_succ]
+
+private theorem ThirdHurewicz.Geometry.cubeTetrahedron_order_first (e : Equiv.Perm (Fin 3))
+    (s : FirstHurewicz.Simplex 3) : cubeTetrahedron e s (e 1) ≤ cubeTetrahedron e s (e 0) := by
+  change (cubeTetrahedron e s (e 1) : ℝ) ≤ (cubeTetrahedron e s (e 0) : ℝ)
+  rw [cubeTetrahedron_coordinate_one, cubeTetrahedron_coordinate_zero]
+  linarith [stdSimplex.zero_le s 1]
+
+private theorem ThirdHurewicz.Geometry.cubeTetrahedron_order_second (e : Equiv.Perm (Fin 3))
+    (s : FirstHurewicz.Simplex 3) : cubeTetrahedron e s (e 2) ≤ cubeTetrahedron e s (e 1) := by
+  change (cubeTetrahedron e s (e 2) : ℝ) ≤ (cubeTetrahedron e s (e 1) : ℝ)
+  rw [cubeTetrahedron_coordinate_two, cubeTetrahedron_coordinate_one]
+  exact le_add_of_nonneg_left (stdSimplex.zero_le s 2)
+
+private theorem ThirdHurewicz.Geometry.cubeTetrahedron_face_zero_coordinate (e : Equiv.Perm (Fin 3))
+    (s : FirstHurewicz.Simplex 2) :
+    cubeTetrahedron e (FirstHurewicz.simplexFace 2 0 s) (e 0) = 1 := by
+  change ((cubeAffineSimplex (cubeVertex e)).comp (FirstHurewicz.simplexFace 2 0)) s (e 0) = 1
+  rw [cubeAffineSimplex_face]
+  apply cubeAffineSimplex_constant_coordinate
+  intro j
+  fin_cases j <;> simp [cubeVertex, Fin.succAbove]
+
+private theorem
+    ThirdHurewicz.Geometry.cubeTetrahedron_face_three_coordinate (e : Equiv.Perm (Fin 3))
+    (s : FirstHurewicz.Simplex 2) :
+    cubeTetrahedron e (FirstHurewicz.simplexFace 2 3 s) (e 2) = 0 := by
+  change ((cubeAffineSimplex (cubeVertex e)).comp (FirstHurewicz.simplexFace 2 3)) s (e 2) = 0
+  rw [cubeAffineSimplex_face]
+  apply cubeAffineSimplex_constant_coordinate
+  intro j
+  fin_cases j <;> simp [cubeVertex, Fin.succAbove]
+
+private theorem ThirdHurewicz.Geometry.cubeTetrahedron_face_zero_boundary (e : Equiv.Perm (Fin 3))
+    (s : FirstHurewicz.Simplex 2) :
+    cubeTetrahedron e (FirstHurewicz.simplexFace 2 0 s) ∈ Cube.boundary (Fin 3) :=
+  ⟨e 0, Or.inr (cubeTetrahedron_face_zero_coordinate e s)⟩
+
+private theorem ThirdHurewicz.Geometry.cubeTetrahedron_face_three_boundary (e : Equiv.Perm (Fin 3))
+    (s : FirstHurewicz.Simplex 2) :
+    cubeTetrahedron e (FirstHurewicz.simplexFace 2 3 s) ∈ Cube.boundary (Fin 3) :=
+  ⟨e 2, Or.inl (cubeTetrahedron_face_three_coordinate e s)⟩
+
+private theorem ThirdHurewicz.Geometry.cubeTetrahedron_face_one_swap (e : Equiv.Perm (Fin 3)) :
+    (cubeTetrahedron e).comp (FirstHurewicz.simplexFace 2 1) =
+      (cubeTetrahedron ((Equiv.swap 0 1).trans e)).comp (FirstHurewicz.simplexFace 2 1) := by
+  simp only [cubeTetrahedron, cubeAffineSimplex_face]
+  congr 1
+  funext j i
+  obtain ⟨k, rfl⟩ := e.surjective i
+  fin_cases j <;> fin_cases k <;> simp [cubeVertex, Equiv.swap_apply_def, Fin.succAbove]
+
+private theorem ThirdHurewicz.Geometry.cubeTetrahedron_face_two_swap (e : Equiv.Perm (Fin 3)) :
+    (cubeTetrahedron e).comp (FirstHurewicz.simplexFace 2 2) =
+      (cubeTetrahedron ((Equiv.swap 1 2).trans e)).comp (FirstHurewicz.simplexFace 2 2) := by
+  simp only [cubeTetrahedron, cubeAffineSimplex_face]
+  congr 1
+  funext j i
+  obtain ⟨k, rfl⟩ := e.surjective i
+  fin_cases j <;> fin_cases k <;> simp [cubeVertex, Equiv.swap_apply_def, Fin.succAbove]
+
+private def ThirdHurewicz.Geometry.cubeOrientation (e : Equiv.Perm (Fin 3)) : ℤ :=
+  Equiv.Perm.sign e
+
+@[simp]
+private theorem
+    ThirdHurewicz.Geometry.cubeOrientation_refl : cubeOrientation (Equiv.refl (Fin 3)) = 1 := by
+  simp [cubeOrientation]
+
+private theorem ThirdHurewicz.Geometry.cubeOrientation_swap (e : Equiv.Perm (Fin 3)) {i j : Fin 3}
+    (h : i ≠ j) : cubeOrientation ((Equiv.swap i j).trans e) = -cubeOrientation e := by
+  simp [cubeOrientation, Equiv.Perm.sign_trans, Equiv.Perm.sign_swap h]
+
+private theorem ThirdHurewicz.threeSimplex_coordinate_sum (s : FirstHurewicz.Simplex 3) :
+    s 0 + (s 1 + s 2 + s 3) = 1 := by
+  have hs := stdSimplex.sum_eq_one s
+  simp only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero] at hs
+  change s 0 + (s 1 + (s 2 + s 3)) = 1 at hs
+  linarith
+
+private theorem ThirdHurewicz.threeSimplexQuotient_cubeTetrahedron_refl :
+    threeSimplexQuotient.comp (Geometry.cubeTetrahedron (Equiv.refl (Fin 3))) =
+      ContinuousMap.id (FirstHurewicz.Simplex 3) := by
+  apply ContinuousMap.ext
+  intro s
+  apply Subtype.ext
+  funext i
+  have h₁ : s 2 + s 3 ≤ s 1 + s 2 + s 3 := by linarith [stdSimplex.zero_le s 1]
+  have h₂ : s 3 ≤ s 2 + s 3 := le_add_of_nonneg_left (stdSimplex.zero_le s 2)
+  have h₃ : s 3 ≤ s 1 + s 2 + s 3 := h₂.trans h₁
+  have hu₀ := Geometry.cubeTetrahedron_coordinate_zero (Equiv.refl (Fin 3)) s
+  have hu₁ := Geometry.cubeTetrahedron_coordinate_one (Equiv.refl (Fin 3)) s
+  have hu₂ := Geometry.cubeTetrahedron_coordinate_two (Equiv.refl (Fin 3)) s
+  change (Geometry.cubeTetrahedron (Equiv.refl (Fin 3)) s 0 : ℝ) = _ at hu₀
+  change (Geometry.cubeTetrahedron (Equiv.refl (Fin 3)) s 1 : ℝ) = _ at hu₁
+  change (Geometry.cubeTetrahedron (Equiv.refl (Fin 3)) s 2 : ℝ) = _ at hu₂
+  fin_cases i
+  · change 1 - (Geometry.cubeTetrahedron (Equiv.refl (Fin 3)) s 0 : ℝ) = s 0
+    rw [hu₀]
+    linarith [threeSimplex_coordinate_sum s]
+  · change
+      (Geometry.cubeTetrahedron (Equiv.refl (Fin 3)) s 0 : ℝ) -
+          Min.min (Geometry.cubeTetrahedron (Equiv.refl (Fin 3)) s 0 : ℝ)
+            (Geometry.cubeTetrahedron (Equiv.refl (Fin 3)) s 1 : ℝ) =
+        s 1
+    rw [hu₀, hu₁, min_eq_right h₁]
+    ring
+  · change
+      Min.min (Geometry.cubeTetrahedron (Equiv.refl (Fin 3)) s 0 : ℝ)
+            (Geometry.cubeTetrahedron (Equiv.refl (Fin 3)) s 1 : ℝ) -
+          Min.min (Geometry.cubeTetrahedron (Equiv.refl (Fin 3)) s 0 : ℝ)
+            (Min.min (Geometry.cubeTetrahedron (Equiv.refl (Fin 3)) s 1 : ℝ)
+              (Geometry.cubeTetrahedron (Equiv.refl (Fin 3)) s 2 : ℝ)) =
+        s 2
+    rw [hu₀, hu₁, hu₂, min_eq_right h₁, min_eq_right h₂, min_eq_right h₃]
+    ring
+  · change
+      Min.min (Geometry.cubeTetrahedron (Equiv.refl (Fin 3)) s 0 : ℝ)
+          (Min.min (Geometry.cubeTetrahedron (Equiv.refl (Fin 3)) s 1 : ℝ)
+            (Geometry.cubeTetrahedron (Equiv.refl (Fin 3)) s 2 : ℝ)) =
+        s 3
+    rw [hu₀, hu₁, hu₂, min_eq_right h₂, min_eq_right h₃]
+
+private theorem ThirdHurewicz.cubeTetrahedron_coordinates_antitone (e : Equiv.Perm (Fin 3))
+    (s : FirstHurewicz.Simplex 3) :
+    Antitone (fun i => (Geometry.cubeTetrahedron e s (e i) : ℝ)) := by
+  apply Fin.antitone_iff_succ_le.mpr
+  intro i
+  fin_cases i
+  · exact Geometry.cubeTetrahedron_order_first e s
+  · exact Geometry.cubeTetrahedron_order_second e s
+
+private theorem ThirdHurewicz.cubeTetrahedron_coordinate_inversion (e : Equiv.Perm (Fin 3))
+    (he : e ≠ Equiv.refl (Fin 3)) (s : FirstHurewicz.Simplex 3) :
+    (Geometry.cubeTetrahedron e s 0 : ℝ) ≤ Geometry.cubeTetrahedron e s 1 ∨
+      (Geometry.cubeTetrahedron e s 1 : ℝ) ≤ Geometry.cubeTetrahedron e s 2 := by
+  by_contra h
+  obtain ⟨h₁, h₂⟩ := not_or.mp h
+  have hu : StrictAnti (fun i => (Geometry.cubeTetrahedron e s i : ℝ)) := by
+    apply Fin.strictAnti_iff_succ_lt.mpr
+    intro i
+    fin_cases i
+    · exact lt_of_not_ge h₁
+    · exact lt_of_not_ge h₂
+  have hm : Monotone e := by
+    intro i j hij
+    exact hu.le_iff_ge.mp (cubeTetrahedron_coordinates_antitone e s hij)
+  apply he
+  apply Equiv.ext
+  intro i
+  exact (hm.strictMono_of_injective e.injective).apply_eq
+
+private theorem ThirdHurewicz.threeSimplexQuotient_cubeTetrahedron_boundary (e : Equiv.Perm (Fin 3))
+    (he : e ≠ Equiv.refl (Fin 3)) (s : FirstHurewicz.Simplex 3) :
+    threeSimplexQuotient (Geometry.cubeTetrahedron e s) ∈ threeSimplexBoundary := by
+  rcases cubeTetrahedron_coordinate_inversion e he s with h | h
+  · exact threeSimplexQuotient_boundary_of_first_le _ h
+  · exact threeSimplexQuotient_boundary_of_second_le _ h
+
+private theorem
+    ThirdHurewicz.basedThreeSimplexLoop_cubeTetrahedron_refl {X : Type} [TopologicalSpace X]
+    {x : X} (τ : BasedThreeSimplex x) :
+    (basedThreeSimplexLoop τ).val.comp (Geometry.cubeTetrahedron (Equiv.refl (Fin 3))) = τ.val := by
+  change (τ.val.comp threeSimplexQuotient).comp _ = _
+  rw [ContinuousMap.comp_assoc, threeSimplexQuotient_cubeTetrahedron_refl, ContinuousMap.comp_id]
+
+private theorem
+    ThirdHurewicz.basedThreeSimplexLoop_cubeTetrahedron_other {X : Type} [TopologicalSpace X]
+    {x : X} (τ : BasedThreeSimplex x) (e : Equiv.Perm (Fin 3)) (he : e ≠ Equiv.refl (Fin 3)) :
+    (basedThreeSimplexLoop τ).val.comp (Geometry.cubeTetrahedron e) =
+      ContinuousMap.const (FirstHurewicz.Simplex 3) x := by
+  apply ContinuousMap.ext
+  intro s
+  exact τ.property _ (threeSimplexQuotient_cubeTetrahedron_boundary e he s)
+
+private theorem ThirdHurewicz.threeCubeOrientation_sum :
+    ∑ e : Equiv.Perm (Fin 3), Geometry.cubeOrientation e = 0 := by
+  have h := Equiv.sum_comp (Equiv.mulRight (Equiv.swap (0 : Fin 3) 1)) Geometry.cubeOrientation
+  change
+    (∑ e : Equiv.Perm (Fin 3), Geometry.cubeOrientation ((Equiv.swap 0 1).trans e)) =
+      ∑ e : Equiv.Perm (Fin 3), Geometry.cubeOrientation e at h
+  simp_rw [Geometry.cubeOrientation_swap _ (by decide : (0 : Fin 3) ≠ 1)] at h
+  rw [Finset.sum_neg_distrib] at h
+  omega
+
+private theorem ThirdHurewicz.basedThreeSimplex_tetrahedronChain_sum {X : Type} [TopologicalSpace X]
+    {x : X} (τ : BasedThreeSimplex x) :
+    (∑ e : Equiv.Perm (Fin 3),
+        Geometry.cubeOrientation e •
+          FirstHurewicz.simplexChain X 3
+            ((basedThreeSimplexLoop τ).val.comp (Geometry.cubeTetrahedron e))) =
+      basedThreeSimplexChain τ := by
+  classical
+  let c := FirstHurewicz.simplexChain X 3 (ContinuousMap.const (FirstHurewicz.Simplex 3) x)
+  have heq (e : Equiv.Perm (Fin 3)) :
+    Geometry.cubeOrientation e •
+        FirstHurewicz.simplexChain X 3
+          ((basedThreeSimplexLoop τ).val.comp (Geometry.cubeTetrahedron e)) =
+      (if e = Equiv.refl (Fin 3) then basedThreeSimplexChain τ else 0) +
+        Geometry.cubeOrientation e • c := by
+    by_cases he : e = Equiv.refl (Fin 3)
+    · subst e
+      rw [basedThreeSimplexLoop_cubeTetrahedron_refl, Geometry.cubeOrientation_refl, one_smul,
+        ite_eq_left rfl, one_smul]
+      change FirstHurewicz.simplexChain X 3 τ.val = (FirstHurewicz.simplexChain X 3 τ.val - c) + c
+      abel
+    · rw [basedThreeSimplexLoop_cubeTetrahedron_other τ e he, ite_eq_right he, zero_add]
+  calc
+    _ =
+        ∑ e : Equiv.Perm (Fin 3),
+          ((if e = Equiv.refl (Fin 3) then basedThreeSimplexChain τ else 0) +
+            Geometry.cubeOrientation e • c) :=
+      Finset.sum_congr rfl (fun e _ => heq e)
+    _ = basedThreeSimplexChain τ + (∑ e : Equiv.Perm (Fin 3), Geometry.cubeOrientation e) • c := by
+      rw [Finset.sum_add_distrib]
+      have hc :
+        (∑ e : Equiv.Perm (Fin 3), Geometry.cubeOrientation e) • c =
+          ∑ e : Equiv.Perm (Fin 3), Geometry.cubeOrientation e • c := by
+        let f : ℤ →+ FirstHurewicz.Chains X 3 :=
+          { toFun := fun n => n • c
+            map_zero' := zero_zsmul c
+            map_add' := fun a b => add_zsmul c a b }
+        exact map_sum f Geometry.cubeOrientation Finset.univ
+      rw [← hc]
+      simp
+    _ = basedThreeSimplexChain τ := by rw [threeCubeOrientation_sum, zero_smul, add_zero]
+
+private abbrev ThirdHurewicz.Remaining :=
+  { j : Fin 3 // j ≠ 0 }
+
+private def
+    ThirdHurewicz.remainingCoordinates : C(Fin 2 → (unitInterval), Remaining → (unitInterval))
+    where
+  toFun u j := u (j.val.pred j.property)
+  continuous_toFun := by fun_prop
+
+@[simp]
+private theorem ThirdHurewicz.remainingCoordinates_succ (u : Fin 2 → (unitInterval)) (i : Fin 2) :
+    remainingCoordinates u ⟨i.succ, Fin.succ_ne_zero i⟩ = u i := by simp [remainingCoordinates]
+
+private theorem ThirdHurewicz.remainingCoordinates_boundary {u : Fin 2 → (unitInterval)}
+    (h : u ∈ Cube.boundary (Fin 2)) : remainingCoordinates u ∈ Cube.boundary Remaining := by
+  obtain ⟨i, hi⟩ := h
+  exact ⟨⟨i.succ, Fin.succ_ne_zero i⟩, by simpa using hi⟩
+
+private abbrev ThirdHurewicz.BasedLoopSpace {X : Type} [TopologicalSpace X] (x : X) :=
+  GenLoop Remaining X x
+
+private def ThirdHurewicz.evaluation {X : Type} [TopologicalSpace X] (x : X) :
+    C(BasedLoopSpace x × (Fin 2 → (unitInterval)), X)
+    where
+  toFun z := z.1 (remainingCoordinates z.2)
+  continuous_toFun := by fun_prop
+
+private theorem ThirdHurewicz.evaluation_boundary {X : Type} [TopologicalSpace X] (x : X)
+    (p : BasedLoopSpace x) (u : Fin 2 → (unitInterval)) (hu : u ∈ Cube.boundary (Fin 2)) :
+    evaluation x (p, u) = x :=
+  GenLoop.boundary p _ (remainingCoordinates_boundary hu)
+
+private theorem ThirdHurewicz.evaluation_comp_boundary {X : Type} [TopologicalSpace X] (x : X)
+    (f : C((unitInterval), Fin 2 → (unitInterval))) (hf : ∀ t, f t ∈ Cube.boundary (Fin 2)) :
+    (evaluation x).comp ((ContinuousMap.id (BasedLoopSpace x)).prodMap f) =
+      ContinuousMap.const (BasedLoopSpace x × (unitInterval)) x := by
+  ext z
+  exact evaluation_boundary x z.1 (f z.2) (hf z.2)
+
+private def ThirdHurewicz.cubeCoordinates :
+    C((unitInterval) × (Fin 2 → (unitInterval)), Fin 3 → (unitInterval))
+    where
+  toFun z := Cube.insertAt (0 : Fin 3) (z.1, remainingCoordinates z.2)
+  continuous_toFun := by fun_prop
+
+@[simp]
+private theorem ThirdHurewicz.cubeCoordinates_zero (z : (unitInterval) × (Fin 2 → (unitInterval))) :
+    cubeCoordinates z 0 = z.1 := by
+  simp [cubeCoordinates, Cube.insertAt, Homeomorph.funSplitAt_symm_apply]
+
+@[simp]
+private theorem ThirdHurewicz.cubeCoordinates_succ (z : (unitInterval) × (Fin 2 → (unitInterval)))
+    (i : Fin 2) : cubeCoordinates z i.succ = z.2 i := by
+  simp [cubeCoordinates, Cube.insertAt, Homeomorph.funSplitAt_symm_apply, remainingCoordinates]
+
+private def
+    ThirdHurewicz.cubeMap {X : Type} [TopologicalSpace X] {x : X} (p : GenLoop (Fin 3) X x) :
+    C((unitInterval) × (Fin 2 → (unitInterval)), X) :=
+  p.val.comp cubeCoordinates
+
+private theorem ThirdHurewicz.evaluation_comp_toLoop {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) :
+    (evaluation x).comp
+        ((GenLoop.toLoop (0 : Fin 3) p).toContinuousMap.prodMap
+          (ContinuousMap.id (Fin 2 → (unitInterval)))) =
+      cubeMap p := by
+  ext z
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def ThirdHurewicz.squareSideLeft (t : (unitInterval)) :
+    C((unitInterval), Fin 2 → (unitInterval)) :=
+  SecondHurewicz.squareCoordinates.comp (PeriodTorusHigherHomology.crossInsertLeft t)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def ThirdHurewicz.squareSideRight (t : (unitInterval)) :
+    C((unitInterval), Fin 2 → (unitInterval)) :=
+  SecondHurewicz.squareCoordinates.comp (PeriodTorusHigherHomology.crossInsertRight t)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem ThirdHurewicz.squareSideLeft_boundary (t : (unitInterval)) (ht : t = 0 ∨ t = 1)
+    (s : (unitInterval)) : squareSideLeft t s ∈ Cube.boundary (Fin 2) := by
+  refine ⟨0, ?_⟩
+  change
+    SecondHurewicz.squareCoordinates (t, s) 0 = 0 ∨ SecondHurewicz.squareCoordinates (t, s) 0 = 1
+  simpa only [SecondHurewicz.squareCoordinates_zero] using ht
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem ThirdHurewicz.squareSideRight_boundary (t : (unitInterval)) (ht : t = 0 ∨ t = 1)
+    (s : (unitInterval)) : squareSideRight t s ∈ Cube.boundary (Fin 2) := by
+  refine ⟨1, ?_⟩
+  change
+    SecondHurewicz.squareCoordinates (s, t) 1 = 0 ∨ SecondHurewicz.squareCoordinates (s, t) 1 = 1
+  simpa only [SecondHurewicz.squareCoordinates_one] using ht
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem ThirdHurewicz.fundamentalSquareChain_boundary :
+    FirstHurewicz.boundaryTwo (Fin 2 → (unitInterval)) SecondHurewicz.fundamentalSquareChain =
+      FirstHurewicz.inducedChain (squareSideLeft 1) 1 SecondHurewicz.intervalChain -
+          FirstHurewicz.inducedChain (squareSideLeft 0) 1 SecondHurewicz.intervalChain -
+        (FirstHurewicz.inducedChain (squareSideRight 1) 1 SecondHurewicz.intervalChain -
+          FirstHurewicz.inducedChain (squareSideRight 0) 1 SecondHurewicz.intervalChain) := by
+  change
+    ((FirstHurewicz.singularComplex (Fin 2 → (unitInterval))).d 2 1).hom
+        (FirstHurewicz.inducedChain SecondHurewicz.squareCoordinates 2
+          SecondHurewicz.productSquareChain) =
+      _
+  rw [← FirstHurewicz.inducedChain_boundary]
+  change
+    FirstHurewicz.inducedChain SecondHurewicz.squareCoordinates 1
+        (FirstHurewicz.boundaryTwo ((unitInterval) × (unitInterval))
+          SecondHurewicz.productSquareChain) =
+      _
+  rw [SecondHurewicz.productSquareChain_boundary]
+  simp only [map_sub, squareSideLeft, squareSideRight, FirstHurewicz.inducedChain_comp,
+    LinearMap.comp_apply]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem ThirdHurewicz.evaluated_edge_boundaryMap {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 1)
+    (f : C((unitInterval), Fin 2 → (unitInterval))) (hf : ∀ t, f t ∈ Cube.boundary (Fin 2)) :
+    FirstHurewicz.inducedChain (evaluation x) 2
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 2 → (unitInterval)) 1
+          a (FirstHurewicz.inducedChain f 1 SecondHurewicz.intervalChain)) =
+      FirstHurewicz.inducedChain (ContinuousMap.const (BasedLoopSpace x × (unitInterval)) x) 2
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (unitInterval) 1 a
+          SecondHurewicz.intervalChain) := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductEdge_natural (ContinuousMap.id (BasedLoopSpace x)) f 1 a
+      SecondHurewicz.intervalChain
+  rw [FirstHurewicz.inducedChain_id, LinearMap.id_apply] at h
+  rw [← h]
+  change
+    ((FirstHurewicz.inducedChain (evaluation x) 2).comp
+          (FirstHurewicz.inducedChain ((ContinuousMap.id (BasedLoopSpace x)).prodMap f) 2))
+        _ =
+      _
+  rw [← FirstHurewicz.inducedChain_comp, evaluation_comp_boundary x f hf]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem ThirdHurewicz.evaluated_triangle_boundaryMap {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 2)
+    (f : C((unitInterval), Fin 2 → (unitInterval))) (hf : ∀ t, f t ∈ Cube.boundary (Fin 2)) :
+    FirstHurewicz.inducedChain (evaluation x) 3
+        (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x)
+          (Fin 2 → (unitInterval)) 1 a
+          (FirstHurewicz.inducedChain f 1 SecondHurewicz.intervalChain)) =
+      FirstHurewicz.inducedChain (ContinuousMap.const (BasedLoopSpace x × (unitInterval)) x) 3
+        (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x) (unitInterval) 1 a
+          SecondHurewicz.intervalChain) := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductTriangle_natural (ContinuousMap.id (BasedLoopSpace x)) f
+      1 a SecondHurewicz.intervalChain
+  rw [FirstHurewicz.inducedChain_id, LinearMap.id_apply] at h
+  rw [← h]
+  change
+    ((FirstHurewicz.inducedChain (evaluation x) 3).comp
+          (FirstHurewicz.inducedChain ((ContinuousMap.id (BasedLoopSpace x)).prodMap f) 3))
+        _ =
+      _
+  rw [← FirstHurewicz.inducedChain_comp, evaluation_comp_boundary x f hf]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    ThirdHurewicz.evaluated_edge_squareBoundary_cancel {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 1) :
+    FirstHurewicz.inducedChain (evaluation x) 2
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 2 → (unitInterval)) 1
+          a
+          (FirstHurewicz.boundaryTwo (Fin 2 → (unitInterval))
+            SecondHurewicz.fundamentalSquareChain)) =
+      0 := by
+  have hL (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_edge_boundaryMap x a (squareSideLeft t) (squareSideLeft_boundary t ht)
+  have hR (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_edge_boundaryMap x a (squareSideRight t) (squareSideRight_boundary t ht)
+  simp only [fundamentalSquareChain_boundary, map_sub, hL 1 (Or.inr rfl), hL 0 (Or.inl rfl),
+    hR 1 (Or.inr rfl), hR 0 (Or.inl rfl), sub_self]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    ThirdHurewicz.evaluated_triangle_squareBoundary_cancel {X : Type} [TopologicalSpace X]
+    (x : X) (a : FirstHurewicz.Chains (BasedLoopSpace x) 2) :
+    FirstHurewicz.inducedChain (evaluation x) 3
+        (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x)
+          (Fin 2 → (unitInterval)) 1 a
+          (FirstHurewicz.boundaryTwo (Fin 2 → (unitInterval))
+            SecondHurewicz.fundamentalSquareChain)) =
+      0 := by
+  have hL (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_triangle_boundaryMap x a (squareSideLeft t) (squareSideLeft_boundary t ht)
+  have hR (t : (unitInterval)) (ht : t = 0 ∨ t = 1) :=
+    evaluated_triangle_boundaryMap x a (squareSideRight t) (squareSideRight_boundary t ht)
+  simp only [fundamentalSquareChain_boundary, map_sub, hL 1 (Or.inr rfl), hL 0 (Or.inl rfl),
+    hR 1 (Or.inr rfl), hR 0 (Or.inl rfl), sub_self]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def ThirdHurewicz.suspensionOne {X : Type} [TopologicalSpace X] (x : X) :
+    FirstHurewicz.Chains (BasedLoopSpace x) 1 →ₗ[ℤ] FirstHurewicz.Chains X 3 :=
+  (FirstHurewicz.inducedChain (evaluation x) 3).comp
+    (PeriodTorusHigherHomology.integerBilinearRightApply
+      (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 2 → (unitInterval)) 2)
+      SecondHurewicz.fundamentalSquareChain)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem ThirdHurewicz.suspensionOne_apply {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 1) :
+    suspensionOne x a =
+      FirstHurewicz.inducedChain (evaluation x) 3
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 2 → (unitInterval)) 2
+          a SecondHurewicz.fundamentalSquareChain) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def ThirdHurewicz.suspensionTwo {X : Type} [TopologicalSpace X] (x : X) :
+    FirstHurewicz.Chains (BasedLoopSpace x) 2 →ₗ[ℤ] FirstHurewicz.Chains X 4 :=
+  (FirstHurewicz.inducedChain (evaluation x) 4).comp
+    (PeriodTorusHigherHomology.integerBilinearRightApply
+      (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x) (Fin 2 → (unitInterval))
+        2)
+      SecondHurewicz.fundamentalSquareChain)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem ThirdHurewicz.suspensionTwo_apply {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 2) :
+    suspensionTwo x a =
+      FirstHurewicz.inducedChain (evaluation x) 4
+        (PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x)
+          (Fin 2 → (unitInterval)) 2 a SecondHurewicz.fundamentalSquareChain) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    ThirdHurewicz.boundaryThree_suspensionOne_of_cycle {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 1)
+    (ha : FirstHurewicz.boundaryOne (BasedLoopSpace x) a = 0) :
+    ((FirstHurewicz.singularComplex X).d 3 2).hom (suspensionOne x a) = 0 := by
+  rw [suspensionOne_apply, ← FirstHurewicz.inducedChain_boundary,
+    PeriodTorusHigherHomology.crossProductEdge_boundary 1]
+  change
+    FirstHurewicz.inducedChain (evaluation x) 2
+        (PeriodTorusHigherHomology.crossProductZeroLeft (BasedLoopSpace x)
+            (Fin 2 → (unitInterval)) 2 (FirstHurewicz.boundaryOne (BasedLoopSpace x) a)
+            SecondHurewicz.fundamentalSquareChain -
+          PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 2 → (unitInterval)) 1
+            a
+            (FirstHurewicz.boundaryTwo (Fin 2 → (unitInterval))
+              SecondHurewicz.fundamentalSquareChain)) =
+      0
+  rw [ha, map_zero, LinearMap.zero_apply, zero_sub, map_neg, evaluated_edge_squareBoundary_cancel,
+    neg_zero]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem ThirdHurewicz.boundaryFour_suspensionTwo {X : Type} [TopologicalSpace X] (x : X)
+    (a : FirstHurewicz.Chains (BasedLoopSpace x) 2) :
+    ((FirstHurewicz.singularComplex X).d 4 3).hom (suspensionTwo x a) =
+      suspensionOne x (FirstHurewicz.boundaryTwo (BasedLoopSpace x) a) := by
+  rw [suspensionTwo_apply, ← FirstHurewicz.inducedChain_boundary,
+    PeriodTorusHigherHomology.crossProductTriangle_boundary 1]
+  change
+    FirstHurewicz.inducedChain (evaluation x) 3
+        (PeriodTorusHigherHomology.crossProductEdge (BasedLoopSpace x) (Fin 2 → (unitInterval)) 2
+            (FirstHurewicz.boundaryTwo (BasedLoopSpace x) a)
+            SecondHurewicz.fundamentalSquareChain +
+          PeriodTorusHigherHomology.crossProductTriangle (BasedLoopSpace x)
+            (Fin 2 → (unitInterval)) 1 a
+            (FirstHurewicz.boundaryTwo (Fin 2 → (unitInterval))
+              SecondHurewicz.fundamentalSquareChain)) =
+      _
+  rw [map_add, evaluated_triangle_squareBoundary_cancel, add_zero]
+  rfl
+
+private def ThirdHurewicz.pathCubeCycle {X : Type} [TopologicalSpace X] (x : X)
+    (p : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3 :=
+  SingularMayerVietoris.ModuleHomology.mkCycle (FirstHurewicz.singularComplex X) 3
+    (suspensionOne x (FirstHurewicz.pathChain p))
+    (boundaryThree_suspensionOne_of_cycle x (FirstHurewicz.pathChain p)
+      (FirstHurewicz.boundaryOne_loop p))
+
+@[simp]
+private theorem ThirdHurewicz.pathCubeCycle_val {X : Type} [TopologicalSpace X] (x : X)
+    (p : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    (pathCubeCycle x p).1 = suspensionOne x (FirstHurewicz.pathChain p) :=
+  rfl
+
+private def ThirdHurewicz.pathCubeClass {X : Type} [TopologicalSpace X] (x : X)
+    (p : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    SingularMayerVietoris.SingularHomology X 3 :=
+  SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 3
+    (pathCubeCycle x p)
+
+private theorem ThirdHurewicz.pathCube_homotopy_boundary {X : Type} [TopologicalSpace X] (x : X)
+    {p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const} (H : p.Homotopy q) :
+    ((FirstHurewicz.singularComplex X).d 4 3).hom
+        (suspensionTwo x (FirstHurewicz.homotopyChain H)) =
+      (pathCubeCycle x p).1 - (pathCubeCycle x q).1 := by
+  rw [boundaryFour_suspensionTwo, FirstHurewicz.boundaryTwo_loopHomotopy, map_sub]
+  rfl
+
+private theorem ThirdHurewicz.pathCubeClass_homotopy {X : Type} [TopologicalSpace X] (x : X)
+    {p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const} (H : p.Homotopy q) :
+    pathCubeClass x p = pathCubeClass x q :=
+  (SingularMayerVietoris.ModuleHomology.cycleClass_eq_iff (FirstHurewicz.singularComplex X) 3 _
+        _).mpr
+    ⟨suspensionTwo x (FirstHurewicz.homotopyChain H), pathCube_homotopy_boundary x H⟩
+
+private theorem ThirdHurewicz.pathCubeClass_homotopic {X : Type} [TopologicalSpace X] (x : X)
+    {p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const} (h : p.Homotopic q) :
+    pathCubeClass x p = pathCubeClass x q := by
+  obtain ⟨H⟩ := h
+  exact pathCubeClass_homotopy x H
+
+@[simp]
+private theorem ThirdHurewicz.pathCubeClass_refl {X : Type} [TopologicalSpace X] (x : X) :
+    pathCubeClass x (Path.refl (GenLoop.const : BasedLoopSpace x)) = 0 := by
+  apply
+    (SingularMayerVietoris.ModuleHomology.cycleClass_eq_zero_iff (FirstHurewicz.singularComplex X)
+        3 _).mpr
+  refine
+    ⟨suspensionTwo x (FirstHurewicz.constantTriangleChain (GenLoop.const : BasedLoopSpace x)), ?_⟩
+  rw [boundaryFour_suspensionTwo, FirstHurewicz.boundaryTwo_constantTriangleChain]
+  rfl
+
+private theorem ThirdHurewicz.pathCube_concat_boundary {X : Type} [TopologicalSpace X] (x : X)
+    (p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    ((FirstHurewicz.singularComplex X).d 4 3).hom
+        (-suspensionTwo x (FirstHurewicz.concatChain p q)) =
+      (pathCubeCycle x (p.trans q)).1 - ((pathCubeCycle x p).1 + (pathCubeCycle x q).1) := by
+  rw [map_neg, boundaryFour_suspensionTwo, FirstHurewicz.boundaryTwo_concatChain, map_add,
+    map_sub]
+  simp only [pathCubeCycle_val]
+  abel
+
+private theorem ThirdHurewicz.pathCubeClass_trans {X : Type} [TopologicalSpace X] (x : X)
+    (p q : Path (GenLoop.const : BasedLoopSpace x) GenLoop.const) :
+    pathCubeClass x (p.trans q) = pathCubeClass x p + pathCubeClass x q := by
+  unfold pathCubeClass
+  rw [← map_add]
+  apply
+    (SingularMayerVietoris.ModuleHomology.cycleClass_eq_iff (FirstHurewicz.singularComplex X) 3 _
+        _).mpr
+  exact ⟨-suspensionTwo x (FirstHurewicz.concatChain p q), pathCube_concat_boundary x p q⟩
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def ThirdHurewicz.productCubeChain :
+    FirstHurewicz.Chains ((unitInterval) × (Fin 2 → (unitInterval))) 3 :=
+  PeriodTorusHigherHomology.crossProductEdge (unitInterval) (Fin 2 → (unitInterval)) 2
+    SecondHurewicz.intervalChain SecondHurewicz.fundamentalSquareChain
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def ThirdHurewicz.fundamentalCubeChain : FirstHurewicz.Chains (Fin 3 → (unitInterval)) 3 :=
+  FirstHurewicz.inducedChain cubeCoordinates 3 productCubeChain
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem ThirdHurewicz.suspensionOne_toLoop {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) :
+    suspensionOne x (FirstHurewicz.pathChain (GenLoop.toLoop (0 : Fin 3) p)) =
+      FirstHurewicz.inducedChain (cubeMap p) 3 productCubeChain := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductEdge_natural
+      (GenLoop.toLoop (0 : Fin 3) p).toContinuousMap (ContinuousMap.id (Fin 2 → (unitInterval))) 2
+      SecondHurewicz.intervalChain SecondHurewicz.fundamentalSquareChain
+  rw [SecondHurewicz.induced_intervalChain, FirstHurewicz.inducedChain_id,
+    LinearMap.id_apply] at h
+  rw [suspensionOne_apply, ← h]
+  change
+    ((FirstHurewicz.inducedChain (evaluation x) 3).comp
+          (FirstHurewicz.inducedChain
+            ((GenLoop.toLoop (0 : Fin 3) p).toContinuousMap.prodMap
+              (ContinuousMap.id (Fin 2 → (unitInterval))))
+            3))
+        productCubeChain =
+      _
+  rw [← FirstHurewicz.inducedChain_comp, evaluation_comp_toLoop]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    ThirdHurewicz.cubeChain {X : Type} [TopologicalSpace X] {x : X} (p : GenLoop (Fin 3) X x) :
+    FirstHurewicz.Chains X 3 :=
+  suspensionOne x (FirstHurewicz.pathChain (GenLoop.toLoop (0 : Fin 3) p))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem ThirdHurewicz.cubeChain_eq_induced {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) :
+    cubeChain p = FirstHurewicz.inducedChain p.val 3 fundamentalCubeChain := by
+  rw [cubeChain, suspensionOne_toLoop]
+  change
+    FirstHurewicz.inducedChain (p.val.comp cubeCoordinates) 3 productCubeChain =
+      ((FirstHurewicz.inducedChain p.val 3).comp (FirstHurewicz.inducedChain cubeCoordinates 3))
+        productCubeChain
+  rw [FirstHurewicz.inducedChain_comp]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    ThirdHurewicz.cubeCycle {X : Type} [TopologicalSpace X] {x : X} (p : GenLoop (Fin 3) X x) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3 :=
+  pathCubeCycle x (GenLoop.toLoop (0 : Fin 3) p)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def ThirdHurewicz.cubeHomologyClass {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) : SingularMayerVietoris.SingularHomology X 3 :=
+  SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 3
+    (cubeCycle p)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    ThirdHurewicz.cubeHomologyClass_eq_pathCubeClass {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) :
+    cubeHomologyClass p = pathCubeClass x (GenLoop.toLoop (0 : Fin 3) p) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem ThirdHurewicz.cubeHomologyClass_homotopic {X : Type} [TopologicalSpace X] {x : X}
+    {p q : GenLoop (Fin 3) X x} (h : GenLoop.Homotopic p q) :
+    cubeHomologyClass p = cubeHomologyClass q :=
+  pathCubeClass_homotopic x (GenLoop.homotopicTo (0 : Fin 3) h)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem ThirdHurewicz.toLoop_const {X : Type} [TopologicalSpace X] {x : X} :
+    GenLoop.toLoop (0 : Fin 3) (GenLoop.const : GenLoop (Fin 3) X x) =
+      Path.refl (GenLoop.const : BasedLoopSpace x) := by
+  apply Path.ext
+  funext t
+  apply GenLoop.ext
+  intro u
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem ThirdHurewicz.cubeHomologyClass_const {X : Type} [TopologicalSpace X] {x : X} :
+    cubeHomologyClass (GenLoop.const : GenLoop (Fin 3) X x) = 0 := by
+  rw [cubeHomologyClass_eq_pathCubeClass, toLoop_const, pathCubeClass_refl]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem ThirdHurewicz.toLoop_transAt {X : Type} [TopologicalSpace X] {x : X}
+    (p q : GenLoop (Fin 3) X x) :
+    GenLoop.toLoop (0 : Fin 3) (GenLoop.transAt (0 : Fin 3) p q) =
+      (GenLoop.toLoop (0 : Fin 3) p).trans (GenLoop.toLoop (0 : Fin 3) q) := by
+  have h :=
+    congrArg (GenLoop.toLoop (0 : Fin 3))
+      (GenLoop.fromLoop_trans_toLoop (i := (0 : Fin 3)) (p := p) (q := q))
+  rw [GenLoop.to_from] at h
+  exact h.symm
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem ThirdHurewicz.cubeHomologyClass_transAt {X : Type} [TopologicalSpace X] {x : X}
+    (p q : GenLoop (Fin 3) X x) :
+    cubeHomologyClass (GenLoop.transAt (0 : Fin 3) p q) =
+      cubeHomologyClass p + cubeHomologyClass q := by
+  simp only [cubeHomologyClass_eq_pathCubeClass, toLoop_transAt, pathCubeClass_trans]
+
+private def ThirdHurewicz.Geometry.cubeBitVertex (v : Fin 3 → Fin 2) : Cube3 := fun i =>
+  FirstHurewicz.pathSimplex Path.id (SingularMayerVietoris.stdVertices 1 (v i))
+
+@[simp]
+private theorem ThirdHurewicz.Geometry.cubeBitVertex_coordinate (v : Fin 3 → Fin 2) (i : Fin 3) :
+    (cubeBitVertex v i : ℝ) = SingularMayerVietoris.stdVertices 1 (v i) 1 :=
+  rfl
+
+@[simp]
+private theorem
+    ThirdHurewicz.Geometry.cubeBitVertex_zero (v : Fin 3 → Fin 2) {i : Fin 3} (h : v i = 0) :
+    cubeBitVertex v i = 0 := by simp [cubeBitVertex, h, SingularMayerVietoris.stdVertices]
+
+@[simp]
+private theorem
+    ThirdHurewicz.Geometry.cubeBitVertex_one (v : Fin 3 → Fin 2) {i : Fin 3} (h : v i = 1) :
+    cubeBitVertex v i = 1 := by simp [cubeBitVertex, h, SingularMayerVietoris.stdVertices]
+
+private def ThirdHurewicz.Geometry.cubeTrianglePrism (v : Fin 3 → Fin 2 × Fin 2) :
+    C(FirstHurewicz.Simplex 1 × FirstHurewicz.Simplex 2, Cube3) :=
+  ThirdHurewicz.cubeCoordinates.comp
+    ((FirstHurewicz.pathSimplex Path.id).prodMap
+      (SecondHurewicz.squareCoordinates.comp
+        (SecondHurewicz.SimplyConnected.squareAffineTriangle v)))
+
+private theorem ThirdHurewicz.Geometry.affineSimplex_comp_selectedVertices {m n p : ℕ}
+    (v : Fin (n + 1) → FirstHurewicz.Simplex p) (a : Fin (m + 1) → Fin (n + 1)) :
+    (SingularMayerVietoris.affineSimplex v).comp
+        (SingularMayerVietoris.affineSimplex
+          (fun j => SingularMayerVietoris.stdVertices n (a j))) =
+      SingularMayerVietoris.affineSimplex (fun j => v (a j)) := by
+  rw [SingularMayerVietoris.affineSimplex_comp]
+  congr 1
+  funext j
+  exact SingularMayerVietoris.affineSimplex_vertex v (a j)
+
+private theorem ThirdHurewicz.Geometry.cubeTrianglePrism_affine {n : ℕ} (v : Fin 3 → Fin 2 × Fin 2)
+    (w : Fin (n + 1) → Fin 2 × Fin 3) :
+    (cubeTrianglePrism v).comp
+        (PeriodTorusHigherHomology.productAffineSimplex
+          (fun j =>
+            (SingularMayerVietoris.stdVertices 1 (w j).1,
+              SingularMayerVietoris.stdVertices 2 (w j).2))) =
+      cubeAffineSimplex (fun j => cubeBitVertex ![(w j).1, (v (w j).2).1, (v (w j).2).2]) := by
+  ext s i
+  fin_cases i
+  · change
+      SingularMayerVietoris.affineSimplex (fun j => SingularMayerVietoris.stdVertices 1 (w j).1) s
+          1 =
+        _
+    rw [SingularMayerVietoris.affineSimplex_coordinate]
+    simp [cubeAffineSimplex_coordinate, cubeBitVertex_coordinate]
+  · change
+      SingularMayerVietoris.affineSimplex (fun j => SingularMayerVietoris.stdVertices 1 (v j).1)
+          (SingularMayerVietoris.affineSimplex
+            (fun j => SingularMayerVietoris.stdVertices 2 (w j).2) s)
+          1 =
+        _
+    change
+      ((SingularMayerVietoris.affineSimplex
+                (fun j => SingularMayerVietoris.stdVertices 1 (v j).1)).comp
+            (SingularMayerVietoris.affineSimplex
+              (fun j => SingularMayerVietoris.stdVertices 2 (w j).2)))
+          s 1 =
+        _
+    rw [affineSimplex_comp_selectedVertices, SingularMayerVietoris.affineSimplex_coordinate]
+    simp [cubeAffineSimplex_coordinate, cubeBitVertex_coordinate]
+  · change
+      SingularMayerVietoris.affineSimplex (fun j => SingularMayerVietoris.stdVertices 1 (v j).2)
+          (SingularMayerVietoris.affineSimplex
+            (fun j => SingularMayerVietoris.stdVertices 2 (w j).2) s)
+          1 =
+        _
+    change
+      ((SingularMayerVietoris.affineSimplex
+                (fun j => SingularMayerVietoris.stdVertices 1 (v j).2)).comp
+            (SingularMayerVietoris.affineSimplex
+              (fun j => SingularMayerVietoris.stdVertices 2 (w j).2)))
+          s 1 =
+        _
+    rw [affineSimplex_comp_selectedVertices, SingularMayerVietoris.affineSimplex_coordinate]
+    simp [cubeAffineSimplex_coordinate, cubeBitVertex_coordinate]
+
+private theorem ThirdHurewicz.Geometry.cubeAffineSimplex_boundary_of_coordinate {n : ℕ}
+    (v : Fin (n + 1) → Cube3) (i : Fin 3) (h : (∀ j, v j i = 0) ∨ (∀ j, v j i = 1))
+    (s : FirstHurewicz.Simplex n) : cubeAffineSimplex v s ∈ Cube.boundary (Fin 3) := by
+  rcases h with h | h
+  · exact ⟨i, Or.inl (cubeAffineSimplex_constant_coordinate v i 0 h s)⟩
+  · exact ⟨i, Or.inr (cubeAffineSimplex_constant_coordinate v i 1 h s)⟩
+
+private theorem ThirdHurewicz.Geometry.loop_comp_cubeAffineSimplex_of_coordinate {X : Type}
+    [TopologicalSpace X] {x : X} {n : ℕ} (p : GenLoop (Fin 3) X x) (v : Fin (n + 1) → Cube3)
+    (i : Fin 3) (h : (∀ j, v j i = 0) ∨ (∀ j, v j i = 1)) :
+    p.val.comp (cubeAffineSimplex v) = ContinuousMap.const (FirstHurewicz.Simplex n) x := by
+  ext s
+  exact GenLoop.boundary p _ (cubeAffineSimplex_boundary_of_coordinate v i h s)
+
+private theorem ThirdHurewicz.CubeSubdivision.formalEdgeCrossProduct_one_expansion_mo1973_7080
+    {V W : Type*} (v : Fin 2 → V) (w : Fin 2 → W) :
+    PeriodTorusHigherHomology.formalEdgeCrossProduct 1 (SingularMayerVietoris.formalSimplex v)
+        (SingularMayerVietoris.formalSimplex w) =
+      SingularMayerVietoris.formalSimplex ![(v 0, w 0), (v 1, w 0), (v 1, w 1)] -
+            SingularMayerVietoris.formalSimplex ![(v 0, w 0), (v 0, w 0), (v 0, w 1)] -
+          SingularMayerVietoris.formalSimplex ![(v 0, w 0), (v 0, w 1), (v 1, w 1)] +
+        SingularMayerVietoris.formalSimplex ![(v 0, w 0), (v 0, w 0), (v 1, w 0)] := by
+  rw [PeriodTorusHigherHomology.formalEdgeCrossProduct_simplex_succ,
+    PeriodTorusHigherHomology.formalPointCrossProduct_edge_boundary,
+    PeriodTorusHigherHomology.formalBoundary_edge_simplex]
+  simp only [map_sub, PeriodTorusHigherHomology.formalEdgeCrossProduct_zero_simplex_right,
+    SingularMayerVietoris.formalMap_simplex, SingularMayerVietoris.formalCone_simplex]
+  have hv₀ : (fun i : Fin 2 => (v 0, w i)) = ![(v 0, w 0), (v 0, w 1)] := by
+    funext i
+    fin_cases i <;> rfl
+  have hv₁ : (fun i : Fin 2 => (v 1, w i)) = ![(v 1, w 0), (v 1, w 1)] := by
+    funext i
+    fin_cases i <;> rfl
+  have hw₀ : (fun i : Fin 2 => (v i, w 0)) = ![(v 0, w 0), (v 1, w 0)] := by
+    funext i
+    fin_cases i <;> rfl
+  have hw₁ : (fun i : Fin 2 => (v i, w 1)) = ![(v 0, w 1), (v 1, w 1)] := by
+    funext i
+    fin_cases i <;> rfl
+  simp only [Function.comp_def, hv₀, hv₁, hw₀, hw₁]
+  abel
+
+private theorem ThirdHurewicz.CubeSubdivision.formalBoundary_triangle_simplex {W : Type*}
+    (w : Fin 3 → W) :
+    SingularMayerVietoris.formalBoundary 2 (SingularMayerVietoris.formalSimplex w) =
+      SingularMayerVietoris.formalSimplex ![w 1, w 2] -
+          SingularMayerVietoris.formalSimplex ![w 0, w 2] +
+        SingularMayerVietoris.formalSimplex ![w 0, w 1] := by
+  have h₀ : w ∘ (0 : Fin 3).succAbove = ![w 1, w 2] := by
+    funext i
+    fin_cases i <;> rfl
+  have h₁ : w ∘ (1 : Fin 3).succAbove = ![w 0, w 2] := by
+    funext i
+    fin_cases i <;> rfl
+  have h₂ : w ∘ (2 : Fin 3).succAbove = ![w 0, w 1] := by
+    funext i
+    fin_cases i <;> rfl
+  rw [SingularMayerVietoris.formalBoundary_simplex]
+  change
+    (∑ i : Fin 3, (-1 : ℤ) ^ i.val • SingularMayerVietoris.formalSimplex (w ∘ i.succAbove)) = _
+  rw [Fin.sum_univ_succ, Fin.sum_univ_two]
+  norm_num only [Fin.val_zero, Fin.val_succ, Fin.val_one, pow_zero, pow_one, one_smul,
+    neg_one_smul]
+  change
+    SingularMayerVietoris.formalSimplex (w ∘ (0 : Fin 3).succAbove) +
+        (-SingularMayerVietoris.formalSimplex (w ∘ (1 : Fin 3).succAbove) +
+          SingularMayerVietoris.formalSimplex (w ∘ (2 : Fin 3).succAbove)) =
+      _
+  rw [h₀, h₁, h₂]
+  abel
+
+private theorem ThirdHurewicz.CubeSubdivision.formalEdgeCrossProduct_two_expansion {V W : Type*}
+    (v : Fin 2 → V) (w : Fin 3 → W) :
+    PeriodTorusHigherHomology.formalEdgeCrossProduct 2 (SingularMayerVietoris.formalSimplex v)
+        (SingularMayerVietoris.formalSimplex w) =
+      SingularMayerVietoris.formalSimplex ![(v 0, w 0), (v 1, w 0), (v 1, w 1), (v 1, w 2)] -
+                            SingularMayerVietoris.formalSimplex
+                              ![(v 0, w 0), (v 0, w 1), (v 1, w 1), (v 1, w 2)] +
+                          SingularMayerVietoris.formalSimplex
+                            ![(v 0, w 0), (v 0, w 1), (v 0, w 2), (v 1, w 2)] -
+                        SingularMayerVietoris.formalSimplex
+                          ![(v 0, w 0), (v 0, w 0), (v 0, w 1), (v 0, w 2)] +
+                      SingularMayerVietoris.formalSimplex
+                        ![(v 0, w 0), (v 0, w 1), (v 0, w 1), (v 0, w 2)] -
+                    SingularMayerVietoris.formalSimplex
+                      ![(v 0, w 0), (v 0, w 1), (v 0, w 1), (v 1, w 1)] +
+                  SingularMayerVietoris.formalSimplex
+                    ![(v 0, w 0), (v 0, w 0), (v 1, w 0), (v 1, w 2)] -
+                SingularMayerVietoris.formalSimplex
+                  ![(v 0, w 0), (v 0, w 0), (v 0, w 0), (v 0, w 2)] -
+              SingularMayerVietoris.formalSimplex
+                ![(v 0, w 0), (v 0, w 0), (v 0, w 2), (v 1, w 2)] -
+            SingularMayerVietoris.formalSimplex
+              ![(v 0, w 0), (v 0, w 0), (v 1, w 0), (v 1, w 1)] +
+          SingularMayerVietoris.formalSimplex ![(v 0, w 0), (v 0, w 0), (v 0, w 0), (v 0, w 1)] +
+        SingularMayerVietoris.formalSimplex ![(v 0, w 0), (v 0, w 0), (v 0, w 1), (v 1, w 1)] := by
+  rw [PeriodTorusHigherHomology.formalEdgeCrossProduct_simplex_succ,
+    PeriodTorusHigherHomology.formalPointCrossProduct_edge_boundary,
+    formalBoundary_triangle_simplex]
+  simp only [map_add, map_sub, formalEdgeCrossProduct_one_expansion_mo1973_7080,
+    SingularMayerVietoris.formalMap_simplex, SingularMayerVietoris.formalCone_simplex]
+  have hv₀ : (fun i : Fin 3 => (v 0, w i)) = ![(v 0, w 0), (v 0, w 1), (v 0, w 2)] := by
+    funext i
+    fin_cases i <;> rfl
+  have hv₁ : (fun i : Fin 3 => (v 1, w i)) = ![(v 1, w 0), (v 1, w 1), (v 1, w 2)] := by
+    funext i
+    fin_cases i <;> rfl
+  simp only [Function.comp_def, hv₀, hv₁, Matrix.cons_val_zero, Matrix.cons_val_one,
+    Matrix.Fin.cons_vecCons]
+  abel
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def ThirdHurewicz.CubeSubdivision.prismSimplex (v : Fin 3 → Fin 2 × Fin 2)
+    (w : Fin 4 → Fin 2 × Fin 3) : C(FirstHurewicz.Simplex 3, ThirdHurewicz.Geometry.Cube3) :=
+  ThirdHurewicz.Geometry.cubeAffineSimplex
+    (fun j => ThirdHurewicz.Geometry.cubeBitVertex ![(w j).1, (v (w j).2).1, (v (w j).2).2])
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def ThirdHurewicz.CubeSubdivision.prismSimplexChain (v : Fin 3 → Fin 2 × Fin 2)
+    (w : Fin 4 → Fin 2 × Fin 3) : FirstHurewicz.Chains ThirdHurewicz.Geometry.Cube3 3 :=
+  FirstHurewicz.simplexChain ThirdHurewicz.Geometry.Cube3 3 (prismSimplex v w)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def ThirdHurewicz.CubeSubdivision.prismRealization (v : Fin 3 → Fin 2 × Fin 2) :
+    SingularMayerVietoris.FormalChains (Fin 2 × Fin 3) 4 →ₗ[ℤ]
+      FirstHurewicz.Chains ThirdHurewicz.Geometry.Cube3 3 :=
+  (FirstHurewicz.inducedChain (ThirdHurewicz.Geometry.cubeTrianglePrism v) 3).comp
+    ((PeriodTorusHigherHomology.productAffineChainMap 1 2 3).comp
+      (SingularMayerVietoris.formalMap
+        (fun z : Fin 2 × Fin 3 =>
+          (SingularMayerVietoris.stdVertices 1 z.1, SingularMayerVietoris.stdVertices 2 z.2))
+        4))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem ThirdHurewicz.CubeSubdivision.prismRealization_simplex (v : Fin 3 → Fin 2 × Fin 2)
+    (w : Fin 4 → Fin 2 × Fin 3) :
+    prismRealization v (SingularMayerVietoris.formalSimplex w) = prismSimplexChain v w := by
+  simp only [prismRealization, LinearMap.comp_apply, SingularMayerVietoris.formalMap_simplex,
+    PeriodTorusHigherHomology.productAffineChainMap_simplex, FirstHurewicz.inducedChain_simplex]
+  change
+    FirstHurewicz.simplexChain ThirdHurewicz.Geometry.Cube3 3
+        ((ThirdHurewicz.Geometry.cubeTrianglePrism v).comp
+          (PeriodTorusHigherHomology.productAffineSimplex
+            (fun j =>
+              (SingularMayerVietoris.stdVertices 1 (w j).1,
+                SingularMayerVietoris.stdVertices 2 (w j).2)))) =
+      _
+  rw [ThirdHurewicz.Geometry.cubeTrianglePrism_affine]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def ThirdHurewicz.CubeSubdivision.intervalTriangleChain (v : Fin 3 → Fin 2 × Fin 2) :
+    FirstHurewicz.Chains ThirdHurewicz.Geometry.Cube3 3 :=
+  FirstHurewicz.inducedChain ThirdHurewicz.cubeCoordinates 3
+    (PeriodTorusHigherHomology.crossProductEdge (unitInterval) (Fin 2 → (unitInterval)) 2
+      SecondHurewicz.intervalChain
+      (FirstHurewicz.inducedChain SecondHurewicz.squareCoordinates 2
+        (FirstHurewicz.simplexChain ((unitInterval) × (unitInterval)) 2
+          (SecondHurewicz.SimplyConnected.squareAffineTriangle v))))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem ThirdHurewicz.CubeSubdivision.intervalTriangleChain_eq_prismRealization
+    (v : Fin 3 → Fin 2 × Fin 2) :
+    intervalTriangleChain v =
+      prismRealization v
+        (PeriodTorusHigherHomology.formalEdgeCrossProduct 2
+          (SingularMayerVietoris.formalSimplex (fun i : Fin 2 => i))
+          (SingularMayerVietoris.formalSimplex (fun j : Fin 3 => j))) := by
+  have h :=
+    PeriodTorusHigherHomology.formalMap_edgeCrossProduct (SingularMayerVietoris.stdVertices 1)
+      (SingularMayerVietoris.stdVertices 2) 2
+      (SingularMayerVietoris.formalSimplex (fun i : Fin 2 => i))
+      (SingularMayerVietoris.formalSimplex (fun j : Fin 3 => j))
+  simp only [SingularMayerVietoris.formalMap_simplex, Function.comp_def] at h
+  rw [intervalTriangleChain, FirstHurewicz.inducedChain_simplex, SecondHurewicz.intervalChain,
+    FirstHurewicz.pathChain, PeriodTorusHigherHomology.crossProductEdge_simplex]
+  change
+    ((FirstHurewicz.inducedChain ThirdHurewicz.cubeCoordinates 3).comp
+          (FirstHurewicz.inducedChain
+            ((FirstHurewicz.pathSimplex Path.id).prodMap
+              (SecondHurewicz.squareCoordinates.comp
+                (SecondHurewicz.SimplyConnected.squareAffineTriangle v)))
+            3))
+        (PeriodTorusHigherHomology.productAffineChainMap 1 2 3
+          (PeriodTorusHigherHomology.formalEdgeCrossProduct 2
+            (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+            (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 2)))) =
+      _
+  rw [← FirstHurewicz.inducedChain_comp, ← h]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem ThirdHurewicz.CubeSubdivision.intervalTriangleChain_twelve_tetrahedra
+    (v : Fin 3 → Fin 2 × Fin 2) :
+    intervalTriangleChain v =
+      prismSimplexChain v ![(0, 0), (1, 0), (1, 1), (1, 2)] -
+                            prismSimplexChain v ![(0, 0), (0, 1), (1, 1), (1, 2)] +
+                          prismSimplexChain v ![(0, 0), (0, 1), (0, 2), (1, 2)] -
+                        prismSimplexChain v ![(0, 0), (0, 0), (0, 1), (0, 2)] +
+                      prismSimplexChain v ![(0, 0), (0, 1), (0, 1), (0, 2)] -
+                    prismSimplexChain v ![(0, 0), (0, 1), (0, 1), (1, 1)] +
+                  prismSimplexChain v ![(0, 0), (0, 0), (1, 0), (1, 2)] -
+                prismSimplexChain v ![(0, 0), (0, 0), (0, 0), (0, 2)] -
+              prismSimplexChain v ![(0, 0), (0, 0), (0, 2), (1, 2)] -
+            prismSimplexChain v ![(0, 0), (0, 0), (1, 0), (1, 1)] +
+          prismSimplexChain v ![(0, 0), (0, 0), (0, 0), (0, 1)] +
+        prismSimplexChain v ![(0, 0), (0, 0), (0, 1), (1, 1)] := by
+  rw [intervalTriangleChain_eq_prismRealization]
+  have h :=
+    congrArg (prismRealization v)
+      (formalEdgeCrossProduct_two_expansion (fun i : Fin 2 => i) (fun j : Fin 3 => j))
+  simpa only [map_sub, map_add, prismRealization_simplex] using h
+
+private def ThirdHurewicz.Geometry.cubePermutation : Fin 6 → Equiv.Perm (Fin 3) :=
+  ![1, Equiv.swap 1 2, Equiv.swap 0 1, (Equiv.swap 0 1).trans (Equiv.swap 1 2),
+    (Equiv.swap 1 2).trans (Equiv.swap 0 1), Equiv.swap 0 2]
+
+private theorem
+    ThirdHurewicz.Geometry.cubePermutation_injective : Function.Injective cubePermutation := by
+  decide
+
+private theorem
+    ThirdHurewicz.Geometry.cubePermutation_bijective : Function.Bijective cubePermutation := by
+  apply (Fintype.bijective_iff_injective_and_card _).mpr
+  exact ⟨cubePermutation_injective, by norm_num [Fintype.card_perm, Nat.factorial]⟩
+
+private theorem ThirdHurewicz.Geometry.sum_cubePermutations {A : Type*} [AddCommMonoid A]
+    (f : Equiv.Perm (Fin 3) → A) :
+    ∑ e, f e =
+      f 1 + f (Equiv.swap 1 2) + f (Equiv.swap 0 1) +
+            f ((Equiv.swap 0 1).trans (Equiv.swap 1 2)) +
+          f ((Equiv.swap 1 2).trans (Equiv.swap 0 1)) +
+        f (Equiv.swap 0 2) := by
+  rw [← cubePermutation_bijective.sum_comp f]
+  simp [cubePermutation, Fin.sum_univ_succ, add_assoc]
+
+private theorem ThirdHurewicz.Geometry.cubeOrientation_cubePermutation (i : Fin 6) :
+    cubeOrientation (cubePermutation i) = ![1, -1, -1, 1, 1, -1] i := by
+  fin_cases i <;>
+    simp [cubePermutation, cubeOrientation, Equiv.Perm.sign_trans, Equiv.Perm.sign_swap']
+
+private theorem ThirdHurewicz.Geometry.sum_oriented_cubePermutations {A : Type*} [AddCommGroup A]
+    (f : Equiv.Perm (Fin 3) → A) :
+    ∑ e, cubeOrientation e • f e =
+      f 1 - f (Equiv.swap 1 2) - f (Equiv.swap 0 1) +
+            f ((Equiv.swap 0 1).trans (Equiv.swap 1 2)) +
+          f ((Equiv.swap 1 2).trans (Equiv.swap 0 1)) -
+        f (Equiv.swap 0 2) := by
+  rw [sum_cubePermutations]
+  simp [cubeOrientation, Equiv.Perm.sign_trans, Equiv.Perm.sign_swap', sub_eq_add_neg, add_assoc]
+
+private theorem ThirdHurewicz.CubeSubdivision.prismSimplex_lower_zero :
+    prismSimplex ![(0, 0), (1, 0), (1, 1)] ![(0, 0), (1, 0), (1, 1), (1, 2)] =
+      ThirdHurewicz.Geometry.cubeTetrahedron 1 := by
+  change
+    ThirdHurewicz.Geometry.cubeAffineSimplex _ =
+      ThirdHurewicz.Geometry.cubeAffineSimplex
+        (ThirdHurewicz.Geometry.cubeVertex (Equiv.refl (Fin 3)))
+  apply congrArg ThirdHurewicz.Geometry.cubeAffineSimplex
+  funext j i
+  fin_cases j <;> fin_cases i <;>
+    simp [ThirdHurewicz.Geometry.cubeBitVertex, ThirdHurewicz.Geometry.cubeVertex,
+      SingularMayerVietoris.stdVertices]
+
+private theorem ThirdHurewicz.CubeSubdivision.prismSimplex_lower_one :
+    prismSimplex ![(0, 0), (1, 0), (1, 1)] ![(0, 0), (0, 1), (1, 1), (1, 2)] =
+      ThirdHurewicz.Geometry.cubeTetrahedron (Equiv.swap 0 1) := by
+  apply congrArg ThirdHurewicz.Geometry.cubeAffineSimplex
+  funext j i
+  fin_cases j <;> fin_cases i <;>
+    simp [ThirdHurewicz.Geometry.cubeBitVertex, ThirdHurewicz.Geometry.cubeVertex,
+      SingularMayerVietoris.stdVertices, Equiv.swap_apply_def]
+
+private theorem ThirdHurewicz.CubeSubdivision.prismSimplex_lower_two :
+    prismSimplex ![(0, 0), (1, 0), (1, 1)] ![(0, 0), (0, 1), (0, 2), (1, 2)] =
+      ThirdHurewicz.Geometry.cubeTetrahedron ((Equiv.swap 1 2).trans (Equiv.swap 0 1)) := by
+  apply congrArg ThirdHurewicz.Geometry.cubeAffineSimplex
+  funext j i
+  fin_cases j <;> fin_cases i <;>
+    simp [ThirdHurewicz.Geometry.cubeBitVertex, ThirdHurewicz.Geometry.cubeVertex,
+      SingularMayerVietoris.stdVertices, Equiv.swap_apply_def]
+
+private theorem ThirdHurewicz.CubeSubdivision.prismSimplex_upper_zero :
+    prismSimplex ![(0, 0), (0, 1), (1, 1)] ![(0, 0), (1, 0), (1, 1), (1, 2)] =
+      ThirdHurewicz.Geometry.cubeTetrahedron (Equiv.swap 1 2) := by
+  apply congrArg ThirdHurewicz.Geometry.cubeAffineSimplex
+  funext j i
+  fin_cases j <;> fin_cases i <;>
+    simp [ThirdHurewicz.Geometry.cubeBitVertex, ThirdHurewicz.Geometry.cubeVertex,
+      SingularMayerVietoris.stdVertices, Equiv.swap_apply_def]
+
+private theorem ThirdHurewicz.CubeSubdivision.prismSimplex_upper_one :
+    prismSimplex ![(0, 0), (0, 1), (1, 1)] ![(0, 0), (0, 1), (1, 1), (1, 2)] =
+      ThirdHurewicz.Geometry.cubeTetrahedron ((Equiv.swap 0 1).trans (Equiv.swap 1 2)) := by
+  apply congrArg ThirdHurewicz.Geometry.cubeAffineSimplex
+  funext j i
+  fin_cases j <;> fin_cases i <;>
+    simp [ThirdHurewicz.Geometry.cubeBitVertex, ThirdHurewicz.Geometry.cubeVertex,
+      SingularMayerVietoris.stdVertices, Equiv.swap_apply_def]
+
+private theorem ThirdHurewicz.CubeSubdivision.prismSimplex_upper_two :
+    prismSimplex ![(0, 0), (0, 1), (1, 1)] ![(0, 0), (0, 1), (0, 2), (1, 2)] =
+      ThirdHurewicz.Geometry.cubeTetrahedron (Equiv.swap 0 2) := by
+  apply congrArg ThirdHurewicz.Geometry.cubeAffineSimplex
+  funext j i
+  fin_cases j <;> fin_cases i <;>
+    simp [ThirdHurewicz.Geometry.cubeBitVertex, ThirdHurewicz.Geometry.cubeVertex,
+      SingularMayerVietoris.stdVertices, Equiv.swap_apply_def]
+
+private theorem ThirdHurewicz.CubeSubdivision.loop_prismSimplex_of_coordinate {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 3) X x) (v : Fin 3 → Fin 2 × Fin 2)
+    (w : Fin 4 → Fin 2 × Fin 3) (i : Fin 3)
+    (h :
+      (∀ j, ThirdHurewicz.Geometry.cubeBitVertex ![(w j).1, (v (w j).2).1, (v (w j).2).2] i = 0) ∨
+        (∀ j,
+          ThirdHurewicz.Geometry.cubeBitVertex ![(w j).1, (v (w j).2).1, (v (w j).2).2] i = 1)) :
+    p.val.comp (prismSimplex v w) = ContinuousMap.const (FirstHurewicz.Simplex 3) x :=
+  ThirdHurewicz.Geometry.loop_comp_cubeAffineSimplex_of_coordinate p _ i h
+
+private theorem ThirdHurewicz.CubeSubdivision.induced_prismSimplexChain_of_coordinate {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 3) X x) (v : Fin 3 → Fin 2 × Fin 2)
+    (w : Fin 4 → Fin 2 × Fin 3) (i : Fin 3)
+    (h :
+      (∀ j, ThirdHurewicz.Geometry.cubeBitVertex ![(w j).1, (v (w j).2).1, (v (w j).2).2] i = 0) ∨
+        (∀ j,
+          ThirdHurewicz.Geometry.cubeBitVertex ![(w j).1, (v (w j).2).1, (v (w j).2).2] i = 1)) :
+    FirstHurewicz.inducedChain p.val 3 (prismSimplexChain v w) =
+      FirstHurewicz.simplexChain X 3 (ContinuousMap.const (FirstHurewicz.Simplex 3) x) := by
+  rw [prismSimplexChain, FirstHurewicz.inducedChain_simplex,
+    loop_prismSimplex_of_coordinate p v w i h]
+
+private theorem
+    ThirdHurewicz.CubeSubdivision.loop_prismSimplex_of_fst {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 3) X x) (v : Fin 3 → Fin 2 × Fin 2) (w : Fin 4 → Fin 2 × Fin 3)
+    (h : (∀ j, (v j).1 = 0) ∨ (∀ j, (v j).1 = 1)) :
+    p.val.comp (prismSimplex v w) = ContinuousMap.const (FirstHurewicz.Simplex 3) x := by
+  apply loop_prismSimplex_of_coordinate p v w 1
+  rcases h with h | h
+  · exact Or.inl fun j => ThirdHurewicz.Geometry.cubeBitVertex_zero _ (i := 1) (h (w j).2)
+  · exact Or.inr fun j => ThirdHurewicz.Geometry.cubeBitVertex_one _ (i := 1) (h (w j).2)
+
+private theorem
+    ThirdHurewicz.CubeSubdivision.loop_prismSimplex_of_snd {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 3) X x) (v : Fin 3 → Fin 2 × Fin 2) (w : Fin 4 → Fin 2 × Fin 3)
+    (h : (∀ j, (v j).2 = 0) ∨ (∀ j, (v j).2 = 1)) :
+    p.val.comp (prismSimplex v w) = ContinuousMap.const (FirstHurewicz.Simplex 3) x := by
+  apply loop_prismSimplex_of_coordinate p v w 2
+  rcases h with h | h
+  · exact Or.inl fun j => ThirdHurewicz.Geometry.cubeBitVertex_zero _ (i := 2) (h (w j).2)
+  · exact Or.inr fun j => ThirdHurewicz.Geometry.cubeBitVertex_one _ (i := 2) (h (w j).2)
+
+private theorem
+  ThirdHurewicz.CubeSubdivision.induced_intervalTriangleChain_of_constant_mo1973_7106 {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 3) X x) (v : Fin 3 → Fin 2 × Fin 2)
+    (h : ∀ w, p.val.comp (prismSimplex v w) = ContinuousMap.const (FirstHurewicz.Simplex 3) x) :
+    FirstHurewicz.inducedChain p.val 3 (intervalTriangleChain v) = 0 := by
+  rw [intervalTriangleChain_twelve_tetrahedra]
+  simp only [map_add, map_sub, prismSimplexChain, FirstHurewicz.inducedChain_simplex, h]
+  abel
+
+private theorem ThirdHurewicz.CubeSubdivision.induced_intervalTriangleChain_of_fst {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 3) X x) (v : Fin 3 → Fin 2 × Fin 2)
+    (h : (∀ j, (v j).1 = 0) ∨ (∀ j, (v j).1 = 1)) :
+    FirstHurewicz.inducedChain p.val 3 (intervalTriangleChain v) = 0 :=
+  induced_intervalTriangleChain_of_constant_mo1973_7106 p v fun w =>
+    loop_prismSimplex_of_fst p v w h
+
+private theorem ThirdHurewicz.CubeSubdivision.induced_intervalTriangleChain_of_snd {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 3) X x) (v : Fin 3 → Fin 2 × Fin 2)
+    (h : (∀ j, (v j).2 = 0) ∨ (∀ j, (v j).2 = 1)) :
+    FirstHurewicz.inducedChain p.val 3 (intervalTriangleChain v) = 0 :=
+  induced_intervalTriangleChain_of_constant_mo1973_7106 p v fun w =>
+    loop_prismSimplex_of_snd p v w h
+
+private theorem ThirdHurewicz.CubeSubdivision.prismSimplex_endpoints_eq (b c : Fin 2 × Fin 2)
+    (w : Fin 4 → Fin 2 × Fin 3) (h : ∀ j, (w j).2 = 0 ∨ (w j).2 = 2) :
+    prismSimplex ![(0, 0), b, (1, 1)] w = prismSimplex ![(0, 0), c, (1, 1)] w := by
+  apply congrArg ThirdHurewicz.Geometry.cubeAffineSimplex
+  funext j
+  rcases h j with hj | hj <;> simp [hj]
+
+private def
+    ThirdHurewicz.CubeSubdivision.diagonalPrismPrincipal {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (b : Fin 2 × Fin 2) : FirstHurewicz.Chains X 3 :=
+  FirstHurewicz.inducedChain p.val 3
+        (prismSimplexChain ![(0, 0), b, (1, 1)] ![(0, 0), (1, 0), (1, 1), (1, 2)]) -
+      FirstHurewicz.inducedChain p.val 3
+        (prismSimplexChain ![(0, 0), b, (1, 1)] ![(0, 0), (0, 1), (1, 1), (1, 2)]) +
+    FirstHurewicz.inducedChain p.val 3
+      (prismSimplexChain ![(0, 0), b, (1, 1)] ![(0, 0), (0, 1), (0, 2), (1, 2)])
+
+private def
+    ThirdHurewicz.CubeSubdivision.prismCommonCorrection {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) : FirstHurewicz.Chains X 3 :=
+  FirstHurewicz.inducedChain p.val 3
+        (prismSimplexChain ![(0, 0), (0, 0), (1, 1)] ![(0, 0), (0, 0), (1, 0), (1, 2)]) -
+      FirstHurewicz.inducedChain p.val 3
+        (prismSimplexChain ![(0, 0), (0, 0), (1, 1)] ![(0, 0), (0, 0), (0, 2), (1, 2)]) -
+    FirstHurewicz.simplexChain X 3 (ContinuousMap.const (FirstHurewicz.Simplex 3) x)
+
+private theorem
+    ThirdHurewicz.CubeSubdivision.induced_diagonalPrism_eq_principal_add_correction {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 3) X x) (b : Fin 2 × Fin 2)
+    (hb : b.1 = 0 ∨ b.2 = 0) :
+    FirstHurewicz.inducedChain p.val 3 (intervalTriangleChain ![(0, 0), b, (1, 1)]) =
+      diagonalPrismPrincipal p b + prismCommonCorrection p := by
+  have htime (w : Fin 4 → Fin 2 × Fin 3) (hw : ∀ j, (w j).1 = 0) :
+    FirstHurewicz.inducedChain p.val 3 (prismSimplexChain ![(0, 0), b, (1, 1)] w) =
+      FirstHurewicz.simplexChain X 3 (ContinuousMap.const (FirstHurewicz.Simplex 3) x) := by
+    apply induced_prismSimplexChain_of_coordinate p _ w 0
+    left
+    intro j
+    simp [ThirdHurewicz.Geometry.cubeBitVertex, SingularMayerVietoris.stdVertices, hw j]
+  have hside (w : Fin 4 → Fin 2 × Fin 3) (hw : ∀ j, (w j).2 = 0 ∨ (w j).2 = 1) :
+    FirstHurewicz.inducedChain p.val 3 (prismSimplexChain ![(0, 0), b, (1, 1)] w) =
+      FirstHurewicz.simplexChain X 3 (ContinuousMap.const (FirstHurewicz.Simplex 3) x) := by
+    rcases hb with hb | hb
+    · apply induced_prismSimplexChain_of_coordinate p _ w 1
+      left
+      intro j
+      rcases hw j with hj | hj <;>
+        simp [ThirdHurewicz.Geometry.cubeBitVertex, SingularMayerVietoris.stdVertices, hj, hb]
+    · apply induced_prismSimplexChain_of_coordinate p _ w 2
+      left
+      intro j
+      rcases hw j with hj | hj <;>
+        simp [ThirdHurewicz.Geometry.cubeBitVertex, SingularMayerVietoris.stdVertices, hj, hb]
+  have hdiag (w : Fin 4 → Fin 2 × Fin 3) (hw : ∀ j, (w j).2 = 0 ∨ (w j).2 = 2) :
+    FirstHurewicz.inducedChain p.val 3 (prismSimplexChain ![(0, 0), b, (1, 1)] w) =
+      FirstHurewicz.inducedChain p.val 3 (prismSimplexChain ![(0, 0), (0, 0), (1, 1)] w) := by
+    simp only [prismSimplexChain, prismSimplex_endpoints_eq b (0, 0) w hw]
+  rw [intervalTriangleChain_twelve_tetrahedra]
+  simp only [map_add, map_sub]
+  rw [htime ![(0, 0), (0, 0), (0, 1), (0, 2)] (by intro j; fin_cases j <;> rfl),
+    htime ![(0, 0), (0, 1), (0, 1), (0, 2)] (by intro j; fin_cases j <;> rfl),
+    hside ![(0, 0), (0, 1), (0, 1), (1, 1)] (by intro j; fin_cases j <;> simp),
+    hdiag ![(0, 0), (0, 0), (1, 0), (1, 2)] (by intro j; fin_cases j <;> simp),
+    htime ![(0, 0), (0, 0), (0, 0), (0, 2)] (by intro j; fin_cases j <;> rfl),
+    hdiag ![(0, 0), (0, 0), (0, 2), (1, 2)] (by intro j; fin_cases j <;> simp),
+    hside ![(0, 0), (0, 0), (1, 0), (1, 1)] (by intro j; fin_cases j <;> simp),
+    htime ![(0, 0), (0, 0), (0, 0), (0, 1)] (by intro j; fin_cases j <;> rfl),
+    hside ![(0, 0), (0, 0), (0, 1), (1, 1)] (by intro j; fin_cases j <;> simp)]
+  unfold diagonalPrismPrincipal prismCommonCorrection
+  abel
+
+private theorem
+    ThirdHurewicz.CubeSubdivision.induced_diagonalPrism_sub {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 3) X x) :
+    FirstHurewicz.inducedChain p.val 3 (intervalTriangleChain ![(0, 0), (1, 0), (1, 1)]) -
+        FirstHurewicz.inducedChain p.val 3 (intervalTriangleChain ![(0, 0), (0, 1), (1, 1)]) =
+      diagonalPrismPrincipal p (1, 0) - diagonalPrismPrincipal p (0, 1) := by
+  rw [induced_diagonalPrism_eq_principal_add_correction p (1, 0) (Or.inr rfl),
+    induced_diagonalPrism_eq_principal_add_correction p (0, 1) (Or.inl rfl)]
+  abel
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem ThirdHurewicz.CubeSubdivision.fundamentalCubeChain_four_prisms :
+    ThirdHurewicz.fundamentalCubeChain =
+      intervalTriangleChain ![(0, 0), (1, 0), (1, 1)] -
+            intervalTriangleChain ![(0, 0), (0, 0), (0, 1)] -
+          intervalTriangleChain ![(0, 0), (0, 1), (1, 1)] +
+        intervalTriangleChain ![(0, 0), (0, 0), (1, 0)] := by
+  rw [ThirdHurewicz.fundamentalCubeChain, ThirdHurewicz.productCubeChain,
+    SecondHurewicz.fundamentalSquareChain,
+    SecondHurewicz.SimplyConnected.productSquareChain_four_triangles]
+  simp only [map_add, map_sub]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem ThirdHurewicz.CubeSubdivision.induced_fundamentalCubeChain_eq_principal {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 3) X x) :
+    FirstHurewicz.inducedChain p.val 3 ThirdHurewicz.fundamentalCubeChain =
+      diagonalPrismPrincipal p (1, 0) - diagonalPrismPrincipal p (0, 1) := by
+  rw [fundamentalCubeChain_four_prisms]
+  simp only [map_add, map_sub]
+  rw [induced_intervalTriangleChain_of_fst p ![(0, 0), (0, 0), (0, 1)]
+      (Or.inl (by intro j; fin_cases j <;> rfl)),
+    induced_intervalTriangleChain_of_snd p ![(0, 0), (0, 0), (1, 0)]
+      (Or.inl (by intro j; fin_cases j <;> rfl)),
+    sub_zero, add_zero]
+  exact induced_diagonalPrism_sub p
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    ThirdHurewicz.CubeSubdivision.cubeChain_six_tetrahedra {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 3) X x) :
+    ThirdHurewicz.cubeChain p =
+      FirstHurewicz.simplexChain X 3 (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron 1)) -
+                FirstHurewicz.simplexChain X 3
+                  (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron (Equiv.swap 0 1))) +
+              FirstHurewicz.simplexChain X 3
+                (p.val.comp
+                  (ThirdHurewicz.Geometry.cubeTetrahedron
+                    ((Equiv.swap 1 2).trans (Equiv.swap 0 1)))) -
+            FirstHurewicz.simplexChain X 3
+              (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron (Equiv.swap 1 2))) +
+          FirstHurewicz.simplexChain X 3
+            (p.val.comp
+              (ThirdHurewicz.Geometry.cubeTetrahedron
+                ((Equiv.swap 0 1).trans (Equiv.swap 1 2)))) -
+        FirstHurewicz.simplexChain X 3
+          (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron (Equiv.swap 0 2))) := by
+  rw [ThirdHurewicz.cubeChain_eq_induced, induced_fundamentalCubeChain_eq_principal]
+  simp only [diagonalPrismPrincipal, prismSimplexChain, FirstHurewicz.inducedChain_simplex,
+    prismSimplex_lower_zero, prismSimplex_lower_one, prismSimplex_lower_two,
+    prismSimplex_upper_zero, prismSimplex_upper_one, prismSimplex_upper_two]
+  abel
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    ThirdHurewicz.CubeSubdivision.cubeChain_eq_sum_tetrahedra {X : Type} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 3) X x) :
+    ThirdHurewicz.cubeChain p =
+      ∑ e : Equiv.Perm (Fin 3),
+        ThirdHurewicz.Geometry.cubeOrientation e •
+          FirstHurewicz.simplexChain X 3
+            (p.val.comp (ThirdHurewicz.Geometry.cubeTetrahedron e)) := by
+  rw [cubeChain_six_tetrahedra, ThirdHurewicz.Geometry.sum_oriented_cubePermutations]
+  abel
+
+private def ThirdHurewicz.hurewiczFunction {X : Type} [TopologicalSpace X] (x : X) :
+    π_ 3 X x → SingularMayerVietoris.SingularHomology X 3 :=
+  Quotient.lift cubeHomologyClass (fun _ _ h => cubeHomologyClass_homotopic h)
+
+private def ThirdHurewicz.hurewiczPi3 {X : Type} [TopologicalSpace X] (x : X) :
+    π_ 3 X x →* Multiplicative (SingularMayerVietoris.SingularHomology X 3)
+    where
+  toFun a := Multiplicative.ofAdd (hurewiczFunction x a)
+  map_one' := congrArg Multiplicative.ofAdd (cubeHomologyClass_const (x := x))
+  map_mul' a
+    b := by
+    refine Quotient.inductionOn₂ a b fun p q => ?_
+    refine
+      (congrArg (fun c : π_ 3 X x => Multiplicative.ofAdd (hurewiczFunction x c))
+            (HomotopyGroup.mul_spec (i := (0 : Fin 3)) (p := p) (q := q))).trans
+        ?_
+    change
+      Multiplicative.ofAdd (cubeHomologyClass (GenLoop.transAt (0 : Fin 3) q p)) =
+        Multiplicative.ofAdd (cubeHomologyClass p + cubeHomologyClass q)
+    rw [cubeHomologyClass_transAt, add_comm]
+
+private def ThirdHurewicz.hurewiczMap {X : Type} [TopologicalSpace X] (x : X) :
+    Additive (π_ 3 X x) →ₗ[ℤ] SingularMayerVietoris.SingularHomology X 3
+    where
+  toFun := (hurewiczPi3 x).toAdditiveLeft
+  map_add' := (hurewiczPi3 x).toAdditiveLeft.map_add
+  map_smul' n a := by simpa using map_intCast_smul (hurewiczPi3 x).toAdditiveLeft ℤ ℤ n a
+
+private theorem ThirdHurewicz.hurewiczMap_representative {X : Type} [TopologicalSpace X] (x : X)
+    (p : GenLoop (Fin 3) X x) :
+    hurewiczMap x (Additive.ofMul (⟦p⟧ : π_ 3 X x)) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 3
+        (cubeCycle p) :=
+  rfl
+
+private theorem
+    ThirdHurewicz.cubeChain_basedThreeSimplexLoop {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedThreeSimplex x) : cubeChain (basedThreeSimplexLoop τ) = basedThreeSimplexChain τ := by
+  rw [CubeSubdivision.cubeChain_eq_sum_tetrahedra, basedThreeSimplex_tetrahedronChain_sum]
+
+private theorem
+    ThirdHurewicz.cubeCycle_basedThreeSimplexLoop {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedThreeSimplex x) : cubeCycle (basedThreeSimplexLoop τ) = basedThreeSimplexCycle τ := by
+  apply Subtype.ext
+  exact cubeChain_basedThreeSimplexLoop τ
+
+private theorem
+    ThirdHurewicz.hurewicz_basedThreeSimplexClass {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedThreeSimplex x) :
+    hurewiczMap x (basedThreeSimplexClass τ) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 3
+        (basedThreeSimplexCycle τ) := by
+  change
+    SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 3
+        (cubeCycle (basedThreeSimplexLoop τ)) =
+      _
+  rw [cubeCycle_basedThreeSimplexLoop]
+
+private theorem
+    ThirdHurewicz.hurewiczMap_comp_threeSimplexClassOperator {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)] :
+    (hurewiczMap x).comp (threeSimplexClassOperator x) =
+      (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 3).comp
+        (normalizedThreeSimplexCycleOperator x) := by
+  apply FirstHurewicz.chainMap_ext X 3
+  intro smp
+  simp only [LinearMap.comp_apply, threeSimplexClassOperator_simplex,
+    normalizedThreeSimplexCycleOperator_simplex]
+  exact hurewicz_basedThreeSimplexClass (normalizedThreeSimplex x smp)
+
+private theorem
+    ThirdHurewicz.hurewiczMap_threeSimplexClassOperator_cycle {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)]
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 3) :
+    hurewiczMap x (threeSimplexClassOperator x c.val) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 3 c := by
+  have h := LinearMap.congr_fun (hurewiczMap_comp_threeSimplexClassOperator x) c.val
+  change
+    hurewiczMap x (threeSimplexClassOperator x c.val) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 3
+        (normalizedThreeSimplexCycleOperator x c.val) at h
+  exact h.trans (normalizedThreeSimplexCycleOperator_class x c)
+
+private def ThirdHurewicz.fourSimplexTwoSkeleton : Set (FirstHurewicz.Simplex 4) :=
+  {s | ∃ i j : Fin 5, i ≠ j ∧ s i = 0 ∧ s j = 0}
+
+private def ThirdHurewicz.BasedFourSimplex {X : Type} [TopologicalSpace X] (x : X) :=
+  { τ : C(FirstHurewicz.Simplex 4, X) // ∀ s ∈ fourSimplexTwoSkeleton, τ s = x }
+
+private theorem
+    ThirdHurewicz.simplexFace_threeSimplexBoundary (i : Fin 5) (s : FirstHurewicz.Simplex 3)
+    (hs : s ∈ threeSimplexBoundary) : FirstHurewicz.simplexFace 3 i s ∈ fourSimplexTwoSkeleton := by
+  obtain ⟨j, hj⟩ := hs
+  exact
+    ⟨i, i.succAbove j, (Fin.succAbove_ne i j).symm, FirstHurewicz.simplexFace_apply_self 3 i s,
+      (FirstHurewicz.simplexFace_apply_succAbove 3 i s j).trans hj⟩
+
+private def ThirdHurewicz.basedFourSimplexFace {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) (i : Fin 5) : BasedThreeSimplex x :=
+  ⟨τ.val.comp (FirstHurewicz.simplexFace 3 i), fun s hs =>
+    τ.property _ (simplexFace_threeSimplexBoundary i s hs)⟩
+
+private def ThirdHurewicz.BasedFourSimplex.ofFaces {X : Type} [TopologicalSpace X] {x : X}
+    (τ : C(FirstHurewicz.Simplex 4, X))
+    (h :
+      ∀ i : Fin 5,
+        ∀ s ∈ ThirdHurewicz.threeSimplexBoundary,
+          (τ.comp (FirstHurewicz.simplexFace 3 i)) s = x) :
+    ThirdHurewicz.BasedFourSimplex x :=
+  ⟨τ, by
+    intro s hs
+    obtain ⟨i, j, hij, hi, hj⟩ := hs
+    obtain ⟨k, hk⟩ := Fin.exists_succAbove_eq hij.symm
+    let t := SecondHurewicz.SimplyConnected.simplexFaceInverse 3 i ⟨s, hi⟩
+    have ht : t ∈ ThirdHurewicz.threeSimplexBoundary := by
+      refine ⟨k, ?_⟩
+      change s (i.succAbove k) = 0
+      rw [hk]
+      exact hj
+    have he := h i t ht
+    change τ (FirstHurewicz.simplexFace 3 i t) = x at he
+    rw [show FirstHurewicz.simplexFace 3 i t = s from
+        SecondHurewicz.SimplyConnected.simplexFace_inverse 3 i ⟨s, hi⟩] at he
+    exact he⟩
+
+private def
+    ThirdHurewicz.normalizedFourSimplex {X : Type} [TopologicalSpace X] [SimplyConnectedSpace X]
+    (x : X) [Subsingleton (π_ 2 X x)] (smp : FirstHurewicz.SingularSimplex X 4) :
+    BasedFourSimplex x :=
+  BasedFourSimplex.ofFaces (normalizedFourSimplexMap x smp)
+    (normalizedFourSimplexMap_face_boundary x smp)
+
+@[simp]
+private theorem ThirdHurewicz.normalizedFourSimplex_face {X : Type} [TopologicalSpace X]
+    [SimplyConnectedSpace X] (x : X) [Subsingleton (π_ 2 X x)]
+    (smp : FirstHurewicz.SingularSimplex X 4) (i : Fin 5) :
+    basedFourSimplexFace (normalizedFourSimplex x smp) i =
+      normalizedThreeSimplex x (smp.comp (FirstHurewicz.simplexFace 3 i)) := by
+  apply Subtype.ext
+  exact normalizedFourSimplexMap_face x smp i
+
+private theorem ThirdHurewicz.fourSimplex_three_order_cases (a b c : ℝ) :
+    (a ≤ b ∧ b ≤ c) ∨
+      (a ≤ c ∧ c ≤ b) ∨ (b ≤ a ∧ a ≤ c) ∨ (b ≤ c ∧ c ≤ a) ∨ (c ≤ a ∧ a ≤ b) ∨ (c ≤ b ∧ b ≤ a) := by
+  rcases le_total a b with hab | hba
+  · rcases le_total b c with hbc | hcb
+    · exact Or.inl ⟨hab, hbc⟩
+    · rcases le_total a c with hac | hca
+      · exact Or.inr (Or.inl ⟨hac, hcb⟩)
+      · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inl ⟨hca, hab⟩))))
+  · rcases le_total a c with hac | hca
+    · exact Or.inr (Or.inr (Or.inl ⟨hba, hac⟩))
+    · rcases le_total b c with hbc | hcb
+      · exact Or.inr (Or.inr (Or.inr (Or.inl ⟨hbc, hca⟩)))
+      · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inr ⟨hcb, hba⟩))))
+
+private theorem ThirdHurewicz.fourSimplex_coordinates_sum_A (a b c : ℝ) :
+    (1 - Max.max a b) + (a - Min.min a (Max.max b c)) + (b - Min.min b c) +
+          (Min.min b c - Min.min a (Min.min b c)) +
+        Min.min a c =
+      1 := by
+  rcases fourSimplex_three_order_cases a b c with ⟨h₁, h₂⟩ | ⟨h₁, h₂⟩ | ⟨h₁, h₂⟩ | ⟨h₁, h₂⟩ |
+    ⟨h₁, h₂⟩ | ⟨h₁, h₂⟩
+  all_goals
+    have h₃ := h₁.trans h₂
+    simp_all only [min_eq_left, min_eq_right, max_eq_left, max_eq_right]
+    ring
+
+private theorem ThirdHurewicz.fourSimplex_coordinates_sum_B (a b c : ℝ) :
+    (a - Min.min a b) + (1 - Max.max a (Max.max b c)) + (b - Min.min b c) +
+          Min.min a (Min.min b c) +
+        (c - Min.min a c) =
+      1 := by
+  rcases fourSimplex_three_order_cases a b c with ⟨h₁, h₂⟩ | ⟨h₁, h₂⟩ | ⟨h₁, h₂⟩ | ⟨h₁, h₂⟩ |
+    ⟨h₁, h₂⟩ | ⟨h₁, h₂⟩
+  all_goals
+    have h₃ := h₁.trans h₂
+    simp_all only [min_eq_left, min_eq_right, max_eq_left, max_eq_right]
+    ring
+
+private def ThirdHurewicz.fourSimplexFillA : C(Fin 3 → (unitInterval), FirstHurewicz.Simplex 4)
+    where
+  toFun
+    u :=
+    ⟨![1 - Max.max (u 0 : ℝ) (u 1 : ℝ),
+        (u 0 : ℝ) - Min.min (u 0 : ℝ) (Max.max (u 1 : ℝ) (u 2 : ℝ)),
+        (u 1 : ℝ) - Min.min (u 1 : ℝ) (u 2 : ℝ),
+        Min.min (u 1 : ℝ) (u 2 : ℝ) - Min.min (u 0 : ℝ) (Min.min (u 1 : ℝ) (u 2 : ℝ)),
+        Min.min (u 0 : ℝ) (u 2 : ℝ)],
+      by
+      constructor
+      · intro i
+        fin_cases i
+        · exact sub_nonneg.mpr (max_le (u 0).property.2 (u 1).property.2)
+        · exact sub_nonneg.mpr (min_le_left _ _)
+        · exact sub_nonneg.mpr (min_le_left _ _)
+        · exact sub_nonneg.mpr (min_le_right _ _)
+        · exact le_min (u 0).property.1 (u 2).property.1
+      · simp only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero, Matrix.cons_val_zero,
+          Matrix.cons_val_succ, Matrix.cons_val_fin_one]
+        simpa only [add_assoc] using fourSimplex_coordinates_sum_A (u 0) (u 1) (u 2)⟩
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    apply continuous_pi
+    intro i
+    fin_cases i <;> dsimp <;> fun_prop
+
+private def ThirdHurewicz.fourSimplexFillB : C(Fin 3 → (unitInterval), FirstHurewicz.Simplex 4)
+    where
+  toFun
+    u :=
+    ⟨![(u 0 : ℝ) - Min.min (u 0 : ℝ) (u 1 : ℝ),
+        1 - Max.max (u 0 : ℝ) (Max.max (u 1 : ℝ) (u 2 : ℝ)),
+        (u 1 : ℝ) - Min.min (u 1 : ℝ) (u 2 : ℝ), Min.min (u 0 : ℝ) (Min.min (u 1 : ℝ) (u 2 : ℝ)),
+        (u 2 : ℝ) - Min.min (u 0 : ℝ) (u 2 : ℝ)],
+      by
+      constructor
+      · intro i
+        fin_cases i
+        · exact sub_nonneg.mpr (min_le_left _ _)
+        · exact
+            sub_nonneg.mpr (max_le (u 0).property.2 (max_le (u 1).property.2 (u 2).property.2))
+        · exact sub_nonneg.mpr (min_le_left _ _)
+        · exact le_min (u 0).property.1 (le_min (u 1).property.1 (u 2).property.1)
+        · exact sub_nonneg.mpr (min_le_right _ _)
+      · simp only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero, Matrix.cons_val_zero,
+          Matrix.cons_val_succ, Matrix.cons_val_fin_one]
+        simpa only [add_assoc] using fourSimplex_coordinates_sum_B (u 0) (u 1) (u 2)⟩
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    apply continuous_pi
+    intro i
+    fin_cases i <;> dsimp <;> fun_prop
+
+private def
+    ThirdHurewicz.fourSimplexReflectFirst : C(Fin 3 → (unitInterval), Fin 3 → (unitInterval))
+    where
+  toFun u := ![(unitInterval.symm) (u 0), u 1, u 2]
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    fin_cases i <;> dsimp <;> fun_prop
+
+@[simp]
+private theorem ThirdHurewicz.fourSimplexReflectFirst_involutive (u : Fin 3 → (unitInterval)) :
+    fourSimplexReflectFirst (fourSimplexReflectFirst u) = u := by
+  funext i
+  fin_cases i <;> simp [fourSimplexReflectFirst]
+
+private theorem ThirdHurewicz.fourSimplexReflectFirst_boundary (u : Fin 3 → (unitInterval))
+    (hu : u ∈ Cube.boundary (Fin 3)) : fourSimplexReflectFirst u ∈ Cube.boundary (Fin 3) := by
+  rcases hu with ⟨i, hi | hi⟩
+  · fin_cases i
+    · change u 0 = 0 at hi
+      exact ⟨0, Or.inr (by simp [fourSimplexReflectFirst, hi])⟩
+    · exact ⟨1, Or.inl (by simpa [fourSimplexReflectFirst] using hi)⟩
+    · exact ⟨2, Or.inl (by simpa [fourSimplexReflectFirst] using hi)⟩
+  · fin_cases i
+    · change u 0 = 1 at hi
+      exact ⟨0, Or.inl (by simp [fourSimplexReflectFirst, hi])⟩
+    · exact ⟨1, Or.inr (by simpa [fourSimplexReflectFirst] using hi)⟩
+    · exact ⟨2, Or.inr (by simpa [fourSimplexReflectFirst] using hi)⟩
+
+private theorem
+    ThirdHurewicz.fourSimplexFill_first_zero (u : Fin 3 → (unitInterval)) (hu : u 0 = 0) :
+    fourSimplexFillA u 1 = 0 ∧
+      fourSimplexFillA u 4 = 0 ∧
+        fourSimplexFillB (fourSimplexReflectFirst u) 1 = 0 ∧
+          fourSimplexFillB (fourSimplexReflectFirst u) 4 = 0 := by
+  simp [fourSimplexFillA, fourSimplexFillB, fourSimplexReflectFirst, DFunLike.coe, hu,
+    min_eq_left ((u 1).property.1.trans (le_max_left _ (u 2 : ℝ))), min_eq_left (u 2).property.1,
+    max_eq_left (max_le (u 1).property.2 (u 2).property.2), min_eq_right (u 2).property.2]
+
+private theorem
+    ThirdHurewicz.fourSimplexFill_first_one (u : Fin 3 → (unitInterval)) (hu : u 0 = 1) :
+    fourSimplexFillA u 0 = 0 ∧
+      fourSimplexFillA u 3 = 0 ∧
+        fourSimplexFillB (fourSimplexReflectFirst u) 0 = 0 ∧
+          fourSimplexFillB (fourSimplexReflectFirst u) 3 = 0 := by
+  simp [fourSimplexFillA, fourSimplexFillB, fourSimplexReflectFirst, DFunLike.coe, hu,
+    max_eq_left (u 1).property.2,
+    min_eq_right ((min_le_left (u 1 : ℝ) (u 2 : ℝ)).trans (u 1).property.2),
+    min_eq_left (u 1).property.1, min_eq_left (le_min (u 1).property.1 (u 2).property.1)]
+
+private theorem
+    ThirdHurewicz.fourSimplexFill_second_zero (u : Fin 3 → (unitInterval)) (hu : u 1 = 0) :
+    fourSimplexFillA u 2 = 0 ∧
+      fourSimplexFillA u 3 = 0 ∧
+        fourSimplexFillB (fourSimplexReflectFirst u) 2 = 0 ∧
+          fourSimplexFillB (fourSimplexReflectFirst u) 3 = 0 := by
+  simp [fourSimplexFillA, fourSimplexFillB, fourSimplexReflectFirst, DFunLike.coe, hu,
+    min_eq_left (u 2).property.1, min_eq_right (u 0).property.1, (u 0).property.2]
+
+private theorem
+    ThirdHurewicz.fourSimplexFill_second_one (u : Fin 3 → (unitInterval)) (hu : u 1 = 1) :
+    fourSimplexFillA u 0 = 0 ∧
+      fourSimplexFillA u 1 = 0 ∧
+        fourSimplexFillB (fourSimplexReflectFirst u) 0 = 0 ∧
+          fourSimplexFillB (fourSimplexReflectFirst u) 1 = 0 := by
+  simp [fourSimplexFillA, fourSimplexFillB, fourSimplexReflectFirst, DFunLike.coe, hu,
+    max_eq_right (u 0).property.2, max_eq_left (u 2).property.2, min_eq_left (u 0).property.2,
+    min_eq_left (sub_le_self 1 (u 0).property.1), max_eq_right (sub_le_self 1 (u 0).property.1)]
+
+private theorem
+    ThirdHurewicz.fourSimplexFill_third_zero (u : Fin 3 → (unitInterval)) (hu : u 2 = 0) :
+    fourSimplexFillA u 3 = 0 ∧
+      fourSimplexFillA u 4 = 0 ∧
+        fourSimplexFillB (fourSimplexReflectFirst u) 3 = 0 ∧
+          fourSimplexFillB (fourSimplexReflectFirst u) 4 = 0 := by
+  simp [fourSimplexFillA, fourSimplexFillB, fourSimplexReflectFirst, DFunLike.coe, hu,
+    min_eq_right (u 1).property.1, min_eq_right (u 0).property.1, (u 0).property.2]
+
+private theorem
+    ThirdHurewicz.fourSimplexFill_third_one (u : Fin 3 → (unitInterval)) (hu : u 2 = 1) :
+    fourSimplexFillA u 1 = 0 ∧
+      fourSimplexFillA u 2 = 0 ∧
+        fourSimplexFillB (fourSimplexReflectFirst u) 1 = 0 ∧
+          fourSimplexFillB (fourSimplexReflectFirst u) 2 = 0 := by
+  simp [fourSimplexFillA, fourSimplexFillB, fourSimplexReflectFirst, DFunLike.coe, hu,
+    max_eq_right (u 1).property.2, min_eq_left (u 0).property.2, min_eq_left (u 1).property.2,
+    max_eq_right (sub_le_self 1 (u 0).property.1)]
+
+private theorem ThirdHurewicz.fourSimplexFill_boundary_common_zeros (u : Fin 3 → (unitInterval))
+    (hu : u ∈ Cube.boundary (Fin 3)) :
+    ∃ i j : Fin 5,
+      i ≠ j ∧
+        fourSimplexFillA u i = 0 ∧
+          fourSimplexFillA u j = 0 ∧
+            fourSimplexFillB (fourSimplexReflectFirst u) i = 0 ∧
+              fourSimplexFillB (fourSimplexReflectFirst u) j = 0 := by
+  rcases hu with ⟨i, hi | hi⟩
+  · fin_cases i
+    · exact ⟨1, 4, by decide, fourSimplexFill_first_zero u hi⟩
+    · exact ⟨2, 3, by decide, fourSimplexFill_second_zero u hi⟩
+    · exact ⟨3, 4, by decide, fourSimplexFill_third_zero u hi⟩
+  · fin_cases i
+    · exact ⟨0, 3, by decide, fourSimplexFill_first_one u hi⟩
+    · exact ⟨0, 1, by decide, fourSimplexFill_second_one u hi⟩
+    · exact ⟨1, 2, by decide, fourSimplexFill_third_one u hi⟩
+
+private theorem ThirdHurewicz.fourSimplexFillA_first_eq_second (u : Fin 3 → (unitInterval))
+    (hu : u 0 = u 1) : fourSimplexFillA u ∈ fourSimplexTwoSkeleton := by
+  refine ⟨1, 3, by decide, ?_, ?_⟩
+  · simp [fourSimplexFillA, DFunLike.coe, hu]
+  · simp [fourSimplexFillA, DFunLike.coe, hu]
+
+private theorem ThirdHurewicz.fourSimplexFillA_first_eq_third (u : Fin 3 → (unitInterval))
+    (hu : u 0 = u 2) : fourSimplexFillA u ∈ fourSimplexTwoSkeleton := by
+  refine ⟨1, 3, by decide, ?_, ?_⟩
+  · simp [fourSimplexFillA, DFunLike.coe, hu]
+  · simp [fourSimplexFillA, DFunLike.coe, hu]
+
+private theorem ThirdHurewicz.fourSimplexFillA_second_eq_third (u : Fin 3 → (unitInterval))
+    (hu : u 1 = u 2) : fourSimplexFillA u ∈ fourSimplexTwoSkeleton := by
+  rcases le_total (u 0 : ℝ) (u 2 : ℝ) with h | h
+  · refine ⟨1, 2, by decide, ?_, ?_⟩
+    · simp [fourSimplexFillA, DFunLike.coe, hu, min_eq_left h]
+    · simp [fourSimplexFillA, DFunLike.coe, hu]
+  · refine ⟨2, 3, by decide, ?_, ?_⟩
+    · simp [fourSimplexFillA, DFunLike.coe, hu]
+    · simp [fourSimplexFillA, DFunLike.coe, hu, min_eq_right h]
+
+private theorem ThirdHurewicz.fourSimplexFillB_first_eq_second (u : Fin 3 → (unitInterval))
+    (hu : u 0 = u 1) : fourSimplexFillB u ∈ fourSimplexTwoSkeleton := by
+  rcases le_total (u 1 : ℝ) (u 2 : ℝ) with h | h
+  · refine ⟨0, 2, by decide, ?_, ?_⟩
+    · simp [fourSimplexFillB, DFunLike.coe, hu]
+    · simp [fourSimplexFillB, DFunLike.coe, min_eq_left h]
+  · refine ⟨0, 4, by decide, ?_, ?_⟩
+    · simp [fourSimplexFillB, DFunLike.coe, hu]
+    · simp [fourSimplexFillB, DFunLike.coe, hu, min_eq_right h]
+
+private theorem ThirdHurewicz.fourSimplexFillB_first_eq_third (u : Fin 3 → (unitInterval))
+    (hu : u 0 = u 2) : fourSimplexFillB u ∈ fourSimplexTwoSkeleton := by
+  rcases le_total (u 2 : ℝ) (u 1 : ℝ) with h | h
+  · refine ⟨0, 4, by decide, ?_, ?_⟩
+    · simp [fourSimplexFillB, DFunLike.coe, hu, min_eq_left h]
+    · simp [fourSimplexFillB, DFunLike.coe, hu]
+  · refine ⟨2, 4, by decide, ?_, ?_⟩
+    · simp [fourSimplexFillB, DFunLike.coe, min_eq_left h]
+    · simp [fourSimplexFillB, DFunLike.coe, hu]
+
+private theorem ThirdHurewicz.fourSimplexFillB_second_eq_third (u : Fin 3 → (unitInterval))
+    (hu : u 1 = u 2) : fourSimplexFillB u ∈ fourSimplexTwoSkeleton := by
+  rcases le_total (u 0 : ℝ) (u 2 : ℝ) with h | h
+  · refine ⟨0, 2, by decide, ?_, ?_⟩
+    · simp [fourSimplexFillB, DFunLike.coe, hu, min_eq_left h]
+    · simp [fourSimplexFillB, DFunLike.coe, hu]
+  · refine ⟨2, 4, by decide, ?_, ?_⟩
+    · simp [fourSimplexFillB, DFunLike.coe, hu]
+    · simp [fourSimplexFillB, DFunLike.coe, min_eq_right h]
+
+private theorem ThirdHurewicz.fourSimplexFillA_internal (u : Fin 3 → (unitInterval)) (i j : Fin 3)
+    (hij : i ≠ j) (hu : u i = u j) : fourSimplexFillA u ∈ fourSimplexTwoSkeleton := by
+  fin_cases i <;> fin_cases j
+  · exact (hij rfl).elim
+  · exact fourSimplexFillA_first_eq_second u hu
+  · exact fourSimplexFillA_first_eq_third u hu
+  · exact fourSimplexFillA_first_eq_second u hu.symm
+  · exact (hij rfl).elim
+  · exact fourSimplexFillA_second_eq_third u hu
+  · exact fourSimplexFillA_first_eq_third u hu.symm
+  · exact fourSimplexFillA_second_eq_third u hu.symm
+  · exact (hij rfl).elim
+
+private theorem ThirdHurewicz.fourSimplexFillB_internal (u : Fin 3 → (unitInterval)) (i j : Fin 3)
+    (hij : i ≠ j) (hu : u i = u j) : fourSimplexFillB u ∈ fourSimplexTwoSkeleton := by
+  fin_cases i <;> fin_cases j
+  · exact (hij rfl).elim
+  · exact fourSimplexFillB_first_eq_second u hu
+  · exact fourSimplexFillB_first_eq_third u hu
+  · exact fourSimplexFillB_first_eq_second u hu.symm
+  · exact (hij rfl).elim
+  · exact fourSimplexFillB_second_eq_third u hu
+  · exact fourSimplexFillB_first_eq_third u hu.symm
+  · exact fourSimplexFillB_second_eq_third u hu.symm
+  · exact (hij rfl).elim
+
+private theorem ThirdHurewicz.fourSimplexFillA_boundary (u : Fin 3 → (unitInterval))
+    (hu : u ∈ Cube.boundary (Fin 3)) : fourSimplexFillA u ∈ fourSimplexTwoSkeleton := by
+  obtain ⟨i, j, hij, hi, hj, _, _⟩ := fourSimplexFill_boundary_common_zeros u hu
+  exact ⟨i, j, hij, hi, hj⟩
+
+private theorem ThirdHurewicz.fourSimplexFillB_boundary (u : Fin 3 → (unitInterval))
+    (hu : u ∈ Cube.boundary (Fin 3)) : fourSimplexFillB u ∈ fourSimplexTwoSkeleton := by
+  obtain ⟨i, j, hij, _, _, hi, hj⟩ :=
+    fourSimplexFill_boundary_common_zeros (fourSimplexReflectFirst u)
+      (fourSimplexReflectFirst_boundary u hu)
+  exact
+    ⟨i, j, hij, by simpa only [fourSimplexReflectFirst_involutive] using hi, by
+      simpa only [fourSimplexReflectFirst_involutive] using hj⟩
+
+private theorem ThirdHurewicz.fourSimplexFill_blend_boundary (t : (unitInterval))
+    (u : Fin 3 → (unitInterval)) (hu : u ∈ Cube.boundary (Fin 3)) :
+    SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend t (fourSimplexFillA u)
+        (fourSimplexFillB (fourSimplexReflectFirst u)) ∈
+      fourSimplexTwoSkeleton := by
+  obtain ⟨i, j, hij, hai, haj, hbi, hbj⟩ := fourSimplexFill_boundary_common_zeros u hu
+  exact
+    ⟨i, j, hij,
+      SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend_zero_coordinate t _ _ i hai hbi,
+      SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend_zero_coordinate t _ _ j haj hbj⟩
+
+private abbrev ThirdHurewicz.NativeCube :=
+  Fin 3 → (unitInterval)
+
+private def ThirdHurewicz.nativeCubeClass {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) : Additive (π_ 3 X x) :=
+  Additive.ofMul (⟦p⟧ : π_ 3 X x)
+
+private theorem ThirdHurewicz.nativeCubeClass_homotopic {X : Type*} [TopologicalSpace X] {x : X}
+    {p q : GenLoop (Fin 3) X x} (h : GenLoop.Homotopic p q) :
+    nativeCubeClass p = nativeCubeClass q :=
+  congrArg (fun a : π_ 3 X x => Additive.ofMul a) (Quotient.sound h)
+
+private theorem
+    ThirdHurewicz.nativeCubeClass_transAt {X : Type*} [TopologicalSpace X] {x : X} (i : Fin 3)
+    (p q : GenLoop (Fin 3) X x) :
+    nativeCubeClass (GenLoop.transAt i p q) = nativeCubeClass p + nativeCubeClass q :=
+  congrArg Additive.ofMul
+    ((HomotopyGroup.mul_spec (i := i) (p := q) (q := p)).symm.trans (mul_comm _ _))
+
+private theorem
+    ThirdHurewicz.nativeCubeClass_symmAt {X : Type*} [TopologicalSpace X] {x : X} (i : Fin 3)
+    (p : GenLoop (Fin 3) X x) : nativeCubeClass (GenLoop.symmAt i p) = -nativeCubeClass p :=
+  congrArg Additive.ofMul (HomotopyGroup.inv_spec (i := i) (p := p)).symm
+
+private def ThirdHurewicz.NativeCubeInternalBased {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) : Prop :=
+  ∀ u : NativeCube, ∀ i j : Fin 3, i ≠ j → u i = u j → p u = x
+
+private inductive ThirdHurewicz.NativeCubeSameFlat (a b : NativeCube) : Prop
+  | zero (i : Fin 3) (ha : a i = 0) (hb : b i = 0)
+  | one (i : Fin 3) (ha : a i = 1) (hb : b i = 1)
+  | equal (i j : Fin 3) (hij : i ≠ j) (ha : a i = a j) (hb : b i = b j)
+
+private def
+    ThirdHurewicz.nativeCubeBlend (t : (unitInterval)) (a b : NativeCube) : NativeCube := fun i =>
+  Set.Icc.convexComb (a i) (b i) t
+
+@[simp]
+private theorem
+    ThirdHurewicz.nativeCubeBlend_zero (a b : NativeCube) : nativeCubeBlend 0 a b = a := by
+  funext i
+  exact Set.Icc.convexComb_zero _ _
+
+@[simp]
+private theorem
+    ThirdHurewicz.nativeCubeBlend_one (a b : NativeCube) : nativeCubeBlend 1 a b = b := by
+  funext i
+  exact Set.Icc.convexComb_one _ _
+
+private def ThirdHurewicz.nativeCubeBlendMap (f g : C(NativeCube, NativeCube)) :
+    C((unitInterval) × NativeCube, NativeCube)
+    where
+  toFun u := nativeCubeBlend u.1 (f u.2) (g u.2)
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    exact
+      Set.Icc.continuous_convexComb_prod.comp
+        (((continuous_apply i).comp (f.continuous.comp continuous_snd)).prodMk
+          (((continuous_apply i).comp (g.continuous.comp continuous_snd)).prodMk continuous_fst))
+
+private theorem ThirdHurewicz.nativeCubeBlend_based {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) {a b : NativeCube}
+    (h : NativeCubeSameFlat a b) (t : (unitInterval)) : p (nativeCubeBlend t a b) = x := by
+  cases h with
+  | zero i ha hb => exact p.property _ ⟨i, Or.inl (by simp [nativeCubeBlend, ha, hb])⟩
+  | one i ha hb => exact p.property _ ⟨i, Or.inr (by simp [nativeCubeBlend, ha, hb])⟩
+  | equal i j hij ha hb => exact hp _ i j hij (by simp only [nativeCubeBlend, ha, hb])
+
+private def ThirdHurewicz.nativeCubePullbackLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (f : C(NativeCube, NativeCube))
+    (hf : ∀ u ∈ Cube.boundary (Fin 3), p (f u) = x) : GenLoop (Fin 3) X x :=
+  ⟨p.val.comp f, hf⟩
+
+private def ThirdHurewicz.nativeCubeLinearHomotopy {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) (f g : C(NativeCube, NativeCube))
+    (hf : ∀ u ∈ Cube.boundary (Fin 3), p (f u) = x)
+    (hg : ∀ u ∈ Cube.boundary (Fin 3), p (g u) = x)
+    (hfg : ∀ u ∈ Cube.boundary (Fin 3), NativeCubeSameFlat (f u) (g u)) :
+    (nativeCubePullbackLoop p f hf).val.HomotopyRel (nativeCubePullbackLoop p g hg).val
+      (Cube.boundary (Fin 3))
+    where
+  toFun u := p (nativeCubeBlend u.1 (f u.2) (g u.2))
+  continuous_toFun := p.val.continuous.comp (nativeCubeBlendMap f g).continuous
+  map_zero_left
+    u := by
+    change p (nativeCubeBlend 0 (f u) (g u)) = p (f u)
+    rw [nativeCubeBlend_zero]
+  map_one_left
+    u := by
+    change p (nativeCubeBlend 1 (f u) (g u)) = p (g u)
+    rw [nativeCubeBlend_one]
+  prop' t u hu := (nativeCubeBlend_based p hp (hfg u hu) t).trans (hf u hu).symm
+
+private def ThirdHurewicz.fourSimplexLoopA {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) : GenLoop (Fin 3) X x :=
+  ⟨τ.val.comp fourSimplexFillA, fun u hu => τ.property _ (fourSimplexFillA_boundary u hu)⟩
+
+private def ThirdHurewicz.fourSimplexLoopB {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) : GenLoop (Fin 3) X x :=
+  ⟨τ.val.comp fourSimplexFillB, fun u hu => τ.property _ (fourSimplexFillB_boundary u hu)⟩
+
+private theorem ThirdHurewicz.fourSimplexLoopA_internal {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) (u : Fin 3 → (unitInterval)) (i j : Fin 3) (hij : i ≠ j)
+    (hu : u i = u j) : fourSimplexLoopA τ u = x :=
+  τ.property _ (fourSimplexFillA_internal u i j hij hu)
+
+private theorem ThirdHurewicz.fourSimplexLoopB_internal {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) (u : Fin 3 → (unitInterval)) (i j : Fin 3) (hij : i ≠ j)
+    (hu : u i = u j) : fourSimplexLoopB τ u = x :=
+  τ.property _ (fourSimplexFillB_internal u i j hij hu)
+
+private theorem ThirdHurewicz.fourSimplexReflectFirst_eq_update (u : Fin 3 → (unitInterval)) :
+    fourSimplexReflectFirst u = Function.update u 0 ((unitInterval.symm) (u 0)) := by
+  funext i
+  fin_cases i <;> simp [fourSimplexReflectFirst]
+
+private def ThirdHurewicz.fourSimplexFillingsHomotopy {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    (fourSimplexLoopA τ).val.HomotopyRel (GenLoop.symmAt 0 (fourSimplexLoopB τ)).val
+      (Cube.boundary (Fin 3))
+    where
+  toFun
+    p :=
+    τ.val
+      (SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend p.1 (fourSimplexFillA p.2)
+        (fourSimplexFillB (fourSimplexReflectFirst p.2)))
+  continuous_toFun :=
+    τ.val.continuous.comp
+      (SecondHurewicz.SimplyConnected.tetrahedronSimplexBlendMap fourSimplexFillA
+          (fourSimplexFillB.comp fourSimplexReflectFirst)).continuous
+  map_zero_left
+    u := by
+    change
+      τ.val (SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend 0 _ _) =
+        τ.val (fourSimplexFillA u)
+    rw [SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend_zero]
+  map_one_left
+    u := by
+    change
+      τ.val (SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend 1 _ _) =
+        τ.val (fourSimplexFillB (Function.update u 0 ((unitInterval.symm) (u 0))))
+    rw [SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend_one,
+      fourSimplexReflectFirst_eq_update]
+  prop' t u
+    hu :=
+    (τ.property _ (fourSimplexFill_blend_boundary t u hu)).trans
+      ((fourSimplexLoopA τ).property u hu).symm
+
+private theorem
+    ThirdHurewicz.fourSimplexFillings_additiveClass {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    nativeCubeClass (fourSimplexLoopA τ) = -nativeCubeClass (fourSimplexLoopB τ) :=
+  (nativeCubeClass_homotopic ⟨fourSimplexFillingsHomotopy τ⟩).trans
+    (nativeCubeClass_symmAt 0 (fourSimplexLoopB τ))
+
+private def ThirdHurewicz.nativeCubeTetrahedronQuotient (e : Equiv.Perm (Fin 3)) :
+    C(NativeCube, NativeCube) :=
+  (Geometry.cubeTetrahedron e).comp threeSimplexQuotient
+
+@[simp]
+private theorem ThirdHurewicz.nativeCubeTetrahedronQuotient_coordinate_zero (e : Equiv.Perm (Fin 3))
+    (u : NativeCube) : nativeCubeTetrahedronQuotient e u (e 0) = u 0 := by
+  apply Subtype.ext
+  change (Geometry.cubeTetrahedron e (threeSimplexQuotient u) (e 0) : ℝ) = (u 0 : ℝ)
+  rw [Geometry.cubeTetrahedron_coordinate_zero, threeSimplexQuotient_one,
+    threeSimplexQuotient_two, threeSimplexQuotient_three]
+  ring
+
+@[simp]
+private theorem ThirdHurewicz.nativeCubeTetrahedronQuotient_coordinate_one (e : Equiv.Perm (Fin 3))
+    (u : NativeCube) : nativeCubeTetrahedronQuotient e u (e 1) = Min.min (u 0) (u 1) := by
+  apply Subtype.ext
+  change
+    (Geometry.cubeTetrahedron e (threeSimplexQuotient u) (e 1) : ℝ) = Min.min (u 0 : ℝ) (u 1 : ℝ)
+  rw [Geometry.cubeTetrahedron_coordinate_one, threeSimplexQuotient_two,
+    threeSimplexQuotient_three]
+  exact sub_add_cancel _ _
+
+@[simp]
+private theorem ThirdHurewicz.nativeCubeTetrahedronQuotient_coordinate_two (e : Equiv.Perm (Fin 3))
+    (u : NativeCube) :
+    nativeCubeTetrahedronQuotient e u (e 2) = Min.min (u 0) (Min.min (u 1) (u 2)) := by
+  apply Subtype.ext
+  change
+    (Geometry.cubeTetrahedron e (threeSimplexQuotient u) (e 2) : ℝ) =
+      Min.min (u 0 : ℝ) (Min.min (u 1 : ℝ) (u 2 : ℝ))
+  rw [Geometry.cubeTetrahedron_coordinate_two, threeSimplexQuotient_three]
+
+private theorem ThirdHurewicz.nativeCubeTetrahedron_coordinate_sum (s : FirstHurewicz.Simplex 3) :
+    s 0 + s 1 + s 2 + s 3 = 1 := by
+  have hs := stdSimplex.sum_eq_one s
+  simp only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero] at hs
+  change s 0 + (s 1 + (s 2 + s 3)) = 1 at hs
+  linarith
+
+private theorem ThirdHurewicz.nativeCubeTetrahedron_based {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) (e : Equiv.Perm (Fin 3))
+    (s : FirstHurewicz.Simplex 3) (hs : s ∈ threeSimplexBoundary) :
+    p (Geometry.cubeTetrahedron e s) = x := by
+  rcases hs with ⟨i, hi⟩
+  fin_cases i
+  · change s 0 = 0 at hi
+    apply p.property
+    refine ⟨e 0, Or.inr ?_⟩
+    apply Subtype.ext
+    change (Geometry.cubeTetrahedron e s (e 0) : ℝ) = 1
+    rw [Geometry.cubeTetrahedron_coordinate_zero]
+    linarith [nativeCubeTetrahedron_coordinate_sum s]
+  · change s 1 = 0 at hi
+    apply hp _ (e 0) (e 1) (e.injective.ne (by decide))
+    apply Subtype.ext
+    simp [hi]
+  · change s 2 = 0 at hi
+    apply hp _ (e 1) (e 2) (e.injective.ne (by decide))
+    apply Subtype.ext
+    simp [hi]
+  · change s 3 = 0 at hi
+    apply p.property
+    refine ⟨e 2, Or.inl ?_⟩
+    apply Subtype.ext
+    simpa using hi
+
+private def ThirdHurewicz.nativeBasedCubeTetrahedron {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) (e : Equiv.Perm (Fin 3)) :
+    BasedThreeSimplex x :=
+  ⟨p.val.comp (Geometry.cubeTetrahedron e), nativeCubeTetrahedron_based p hp e⟩
+
+private theorem
+    ThirdHurewicz.nativeCubeTetrahedronQuotient_based {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) (e : Equiv.Perm (Fin 3))
+    (u : NativeCube) (hu : u ∈ Cube.boundary (Fin 3)) :
+    p (nativeCubeTetrahedronQuotient e u) = x :=
+  nativeCubeTetrahedron_based p hp e _ (threeSimplexQuotient_boundary u hu)
+
+private def ThirdHurewicz.fourSimplexTetrahedronA {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) (e : Equiv.Perm (Fin 3)) : BasedThreeSimplex x :=
+  nativeBasedCubeTetrahedron (fourSimplexLoopA τ) (fourSimplexLoopA_internal τ) e
+
+private def ThirdHurewicz.fourSimplexTetrahedronB {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) (e : Equiv.Perm (Fin 3)) : BasedThreeSimplex x :=
+  nativeBasedCubeTetrahedron (fourSimplexLoopB τ) (fourSimplexLoopB_internal τ) e
+
+private theorem ThirdHurewicz.fourSimplexTetrahedron_coordinate_perm (e : Equiv.Perm (Fin 3))
+    (s : FirstHurewicz.Simplex 3) (i : Fin 3) :
+    (Geometry.cubeTetrahedron e s i : ℝ) = ![s 1 + s 2 + s 3, s 2 + s 3, s 3] (e.symm i) := by
+  obtain ⟨j, rfl⟩ := e.surjective i
+  fin_cases j <;> simp
+
+private theorem ThirdHurewicz.fourSimplexTetrahedron_zero_coordinate (s : FirstHurewicz.Simplex 3)
+    (i : Fin 3) :
+    (Geometry.cubeTetrahedron (Geometry.cubePermutation 0) s i : ℝ) =
+      ![s 1 + s 2 + s 3, s 2 + s 3, s 3] i := by
+  rw [fourSimplexTetrahedron_coordinate_perm]
+  rfl
+
+private theorem ThirdHurewicz.fourSimplexTetrahedron_one_coordinate (s : FirstHurewicz.Simplex 3)
+    (i : Fin 3) :
+    (Geometry.cubeTetrahedron (Geometry.cubePermutation 1) s i : ℝ) =
+      ![s 1 + s 2 + s 3, s 3, s 2 + s 3] i := by
+  rw [fourSimplexTetrahedron_coordinate_perm]
+  fin_cases i <;> simp [Geometry.cubePermutation, Equiv.swap_apply_def]
+
+private theorem ThirdHurewicz.fourSimplexTetrahedron_two_coordinate (s : FirstHurewicz.Simplex 3)
+    (i : Fin 3) :
+    (Geometry.cubeTetrahedron (Geometry.cubePermutation 2) s i : ℝ) =
+      ![s 2 + s 3, s 1 + s 2 + s 3, s 3] i := by
+  rw [fourSimplexTetrahedron_coordinate_perm]
+  fin_cases i <;> simp [Geometry.cubePermutation, Equiv.swap_apply_def]
+
+private theorem ThirdHurewicz.fourSimplexTetrahedron_three_coordinate (s : FirstHurewicz.Simplex 3)
+    (i : Fin 3) :
+    (Geometry.cubeTetrahedron (Geometry.cubePermutation 3) s i : ℝ) =
+      ![s 2 + s 3, s 3, s 1 + s 2 + s 3] i := by
+  rw [fourSimplexTetrahedron_coordinate_perm]
+  fin_cases i <;> simp [Geometry.cubePermutation, Equiv.swap_apply_def]
+
+private theorem ThirdHurewicz.fourSimplexTetrahedron_four_coordinate (s : FirstHurewicz.Simplex 3)
+    (i : Fin 3) :
+    (Geometry.cubeTetrahedron (Geometry.cubePermutation 4) s i : ℝ) =
+      ![s 3, s 1 + s 2 + s 3, s 2 + s 3] i := by
+  rw [fourSimplexTetrahedron_coordinate_perm]
+  fin_cases i <;> simp [Geometry.cubePermutation, Equiv.swap_apply_def]
+
+private theorem ThirdHurewicz.fourSimplexTetrahedron_five_coordinate (s : FirstHurewicz.Simplex 3)
+    (i : Fin 3) :
+    (Geometry.cubeTetrahedron (Geometry.cubePermutation 5) s i : ℝ) =
+      ![s 3, s 2 + s 3, s 1 + s 2 + s 3] i := by
+  rw [fourSimplexTetrahedron_coordinate_perm]
+  fin_cases i <;> simp [Geometry.cubePermutation, Equiv.swap_apply_def]
+
+private theorem ThirdHurewicz.fourSimplexTetrahedron_tail_le_middle (s : FirstHurewicz.Simplex 3) :
+    s 3 ≤ s 2 + s 3 :=
+  le_add_of_nonneg_left (stdSimplex.zero_le s 2)
+
+private theorem ThirdHurewicz.fourSimplexTetrahedron_middle_le_first (s : FirstHurewicz.Simplex 3) :
+    s 2 + s 3 ≤ s 1 + s 2 + s 3 := by linarith [stdSimplex.zero_le s 1]
+
+private theorem ThirdHurewicz.fourSimplexTetrahedron_tail_le_first (s : FirstHurewicz.Simplex 3) :
+    s 3 ≤ s 1 + s 2 + s 3 :=
+  (fourSimplexTetrahedron_tail_le_middle s).trans (fourSimplexTetrahedron_middle_le_first s)
+
+private theorem ThirdHurewicz.fourSimplexTetrahedron_sum (s : FirstHurewicz.Simplex 3) :
+    s 0 + s 1 + s 2 + s 3 = 1 := by
+  have h := stdSimplex.sum_eq_one s
+  simp only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero] at h
+  change s 0 + (s 1 + (s 2 + s 3)) = 1 at h
+  linarith
+
+private theorem ThirdHurewicz.fourSimplexFillA_tetrahedron_zero (s : FirstHurewicz.Simplex 3) :
+    (fourSimplexFillA (Geometry.cubeTetrahedron (Geometry.cubePermutation 0) s) : Fin 5 → ℝ) =
+      ![s 0, s 1, s 2, 0, s 3] := by
+  have fourSimplexFillA_zero (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 0 = 1 - Max.max (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have fourSimplexFillA_one (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 1 = (u 0 : ℝ) - Min.min (u 0 : ℝ) (Max.max (u 1 : ℝ) (u 2 : ℝ)) := rfl
+  have fourSimplexFillA_two (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 2 = (u 1 : ℝ) - Min.min (u 1 : ℝ) (u 2 : ℝ) := rfl
+  have fourSimplexFillA_three (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 3 =
+      Min.min (u 1 : ℝ) (u 2 : ℝ) - Min.min (u 0 : ℝ) (Min.min (u 1 : ℝ) (u 2 : ℝ)) :=
+    rfl
+  have fourSimplexFillA_four (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 4 = Min.min (u 0 : ℝ) (u 2 : ℝ) := rfl
+  have hca := fourSimplexTetrahedron_tail_le_first s
+  have hs := fourSimplexTetrahedron_sum s
+  funext i
+  fin_cases i <;>
+    simp [fourSimplexFillA_zero, fourSimplexFillA_one, fourSimplexFillA_two,
+      fourSimplexFillA_three, fourSimplexFillA_four, fourSimplexTetrahedron_zero_coordinate,
+      min_eq_right hca]
+  all_goals linarith
+
+private theorem ThirdHurewicz.fourSimplexFillB_tetrahedron_zero (s : FirstHurewicz.Simplex 3) :
+    (fourSimplexFillB (Geometry.cubeTetrahedron (Geometry.cubePermutation 0) s) : Fin 5 → ℝ) =
+      ![s 1, s 0, s 2, s 3, 0] := by
+  have fourSimplexFillB_zero (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 0 = (u 0 : ℝ) - Min.min (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have fourSimplexFillB_one (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 1 = 1 - Max.max (u 0 : ℝ) (Max.max (u 1 : ℝ) (u 2 : ℝ)) := rfl
+  have fourSimplexFillB_two (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 2 = (u 1 : ℝ) - Min.min (u 1 : ℝ) (u 2 : ℝ) := rfl
+  have fourSimplexFillB_three (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 3 = Min.min (u 0 : ℝ) (Min.min (u 1 : ℝ) (u 2 : ℝ)) := rfl
+  have fourSimplexFillB_four (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 4 = (u 2 : ℝ) - Min.min (u 0 : ℝ) (u 2 : ℝ) := rfl
+  have hca := fourSimplexTetrahedron_tail_le_first s
+  have hs := fourSimplexTetrahedron_sum s
+  funext i
+  fin_cases i <;>
+    simp [fourSimplexFillB_zero, fourSimplexFillB_one, fourSimplexFillB_two,
+      fourSimplexFillB_three, fourSimplexFillB_four, fourSimplexTetrahedron_zero_coordinate,
+      min_eq_right hca]
+  all_goals linarith
+
+private theorem ThirdHurewicz.fourSimplexFillA_tetrahedron_one (s : FirstHurewicz.Simplex 3) :
+    (fourSimplexFillA (Geometry.cubeTetrahedron (Geometry.cubePermutation 1) s) : Fin 5 → ℝ) =
+      ![s 0, s 1, 0, 0, s 2 + s 3] := by
+  have fourSimplexFillA_zero (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 0 = 1 - Max.max (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have fourSimplexFillA_one (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 1 = (u 0 : ℝ) - Min.min (u 0 : ℝ) (Max.max (u 1 : ℝ) (u 2 : ℝ)) := rfl
+  have fourSimplexFillA_two (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 2 = (u 1 : ℝ) - Min.min (u 1 : ℝ) (u 2 : ℝ) := rfl
+  have fourSimplexFillA_three (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 3 =
+      Min.min (u 1 : ℝ) (u 2 : ℝ) - Min.min (u 0 : ℝ) (Min.min (u 1 : ℝ) (u 2 : ℝ)) :=
+    rfl
+  have fourSimplexFillA_four (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 4 = Min.min (u 0 : ℝ) (u 2 : ℝ) := rfl
+  have hca := fourSimplexTetrahedron_tail_le_first s
+  have hs := fourSimplexTetrahedron_sum s
+  funext i
+  fin_cases i <;>
+    simp [fourSimplexFillA_zero, fourSimplexFillA_one, fourSimplexFillA_two,
+      fourSimplexFillA_three, fourSimplexFillA_four, fourSimplexTetrahedron_one_coordinate,
+      max_eq_left hca, min_eq_right hca]
+  all_goals linarith
+
+private theorem ThirdHurewicz.fourSimplexFillB_tetrahedron_one (s : FirstHurewicz.Simplex 3) :
+    (fourSimplexFillB (Geometry.cubeTetrahedron (Geometry.cubePermutation 1) s) : Fin 5 → ℝ) =
+      ![s 1 + s 2, s 0, 0, s 3, 0] := by
+  have fourSimplexFillB_zero (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 0 = (u 0 : ℝ) - Min.min (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have fourSimplexFillB_one (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 1 = 1 - Max.max (u 0 : ℝ) (Max.max (u 1 : ℝ) (u 2 : ℝ)) := rfl
+  have fourSimplexFillB_two (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 2 = (u 1 : ℝ) - Min.min (u 1 : ℝ) (u 2 : ℝ) := rfl
+  have fourSimplexFillB_three (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 3 = Min.min (u 0 : ℝ) (Min.min (u 1 : ℝ) (u 2 : ℝ)) := rfl
+  have fourSimplexFillB_four (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 4 = (u 2 : ℝ) - Min.min (u 0 : ℝ) (u 2 : ℝ) := rfl
+  have hca := fourSimplexTetrahedron_tail_le_first s
+  have hs := fourSimplexTetrahedron_sum s
+  funext i
+  fin_cases i <;>
+    simp [fourSimplexFillB_zero, fourSimplexFillB_one, fourSimplexFillB_two,
+      fourSimplexFillB_three, fourSimplexFillB_four, fourSimplexTetrahedron_one_coordinate,
+      min_eq_right hca]
+  all_goals linarith
+
+private theorem ThirdHurewicz.fourSimplexFillA_tetrahedron_two (s : FirstHurewicz.Simplex 3) :
+    (fourSimplexFillA (Geometry.cubeTetrahedron (Geometry.cubePermutation 2) s) : Fin 5 → ℝ) =
+      ![s 0, 0, s 1 + s 2, 0, s 3] := by
+  have fourSimplexFillA_zero (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 0 = 1 - Max.max (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have fourSimplexFillA_one (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 1 = (u 0 : ℝ) - Min.min (u 0 : ℝ) (Max.max (u 1 : ℝ) (u 2 : ℝ)) := rfl
+  have fourSimplexFillA_two (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 2 = (u 1 : ℝ) - Min.min (u 1 : ℝ) (u 2 : ℝ) := rfl
+  have fourSimplexFillA_three (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 3 =
+      Min.min (u 1 : ℝ) (u 2 : ℝ) - Min.min (u 0 : ℝ) (Min.min (u 1 : ℝ) (u 2 : ℝ)) :=
+    rfl
+  have fourSimplexFillA_four (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 4 = Min.min (u 0 : ℝ) (u 2 : ℝ) := rfl
+  have hca := fourSimplexTetrahedron_tail_le_first s
+  have hs := fourSimplexTetrahedron_sum s
+  funext i
+  fin_cases i <;>
+    simp [fourSimplexFillA_zero, fourSimplexFillA_one, fourSimplexFillA_two,
+      fourSimplexFillA_three, fourSimplexFillA_four, fourSimplexTetrahedron_two_coordinate,
+      max_eq_left hca, min_eq_right hca]
+  all_goals linarith
+
+private theorem ThirdHurewicz.fourSimplexFillB_tetrahedron_two (s : FirstHurewicz.Simplex 3) :
+    (fourSimplexFillB (Geometry.cubeTetrahedron (Geometry.cubePermutation 2) s) : Fin 5 → ℝ) =
+      ![0, s 0, s 1 + s 2, s 3, 0] := by
+  have fourSimplexFillB_zero (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 0 = (u 0 : ℝ) - Min.min (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have fourSimplexFillB_one (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 1 = 1 - Max.max (u 0 : ℝ) (Max.max (u 1 : ℝ) (u 2 : ℝ)) := rfl
+  have fourSimplexFillB_two (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 2 = (u 1 : ℝ) - Min.min (u 1 : ℝ) (u 2 : ℝ) := rfl
+  have fourSimplexFillB_three (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 3 = Min.min (u 0 : ℝ) (Min.min (u 1 : ℝ) (u 2 : ℝ)) := rfl
+  have fourSimplexFillB_four (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 4 = (u 2 : ℝ) - Min.min (u 0 : ℝ) (u 2 : ℝ) := rfl
+  have hca := fourSimplexTetrahedron_tail_le_first s
+  have hs := fourSimplexTetrahedron_sum s
+  funext i
+  fin_cases i <;>
+    simp [fourSimplexFillB_zero, fourSimplexFillB_one, fourSimplexFillB_two,
+      fourSimplexFillB_three, fourSimplexFillB_four, fourSimplexTetrahedron_two_coordinate,
+      max_eq_left hca, min_eq_right hca]
+  all_goals linarith
+
+private theorem ThirdHurewicz.fourSimplexFillA_tetrahedron_three (s : FirstHurewicz.Simplex 3) :
+    (fourSimplexFillA (Geometry.cubeTetrahedron (Geometry.cubePermutation 3) s) : Fin 5 → ℝ) =
+      ![s 0 + s 1, 0, 0, 0, s 2 + s 3] := by
+  have fourSimplexFillA_zero (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 0 = 1 - Max.max (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have fourSimplexFillA_one (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 1 = (u 0 : ℝ) - Min.min (u 0 : ℝ) (Max.max (u 1 : ℝ) (u 2 : ℝ)) := rfl
+  have fourSimplexFillA_two (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 2 = (u 1 : ℝ) - Min.min (u 1 : ℝ) (u 2 : ℝ) := rfl
+  have fourSimplexFillA_three (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 3 =
+      Min.min (u 1 : ℝ) (u 2 : ℝ) - Min.min (u 0 : ℝ) (Min.min (u 1 : ℝ) (u 2 : ℝ)) :=
+    rfl
+  have fourSimplexFillA_four (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 4 = Min.min (u 0 : ℝ) (u 2 : ℝ) := rfl
+  have hca := fourSimplexTetrahedron_tail_le_first s
+  have hs := fourSimplexTetrahedron_sum s
+  funext i
+  fin_cases i <;>
+    simp [fourSimplexFillA_zero, fourSimplexFillA_one, fourSimplexFillA_two,
+      fourSimplexFillA_three, fourSimplexFillA_four, fourSimplexTetrahedron_three_coordinate,
+      max_eq_right hca, min_eq_left hca]
+  all_goals linarith
+
+private theorem ThirdHurewicz.fourSimplexFillB_tetrahedron_three (s : FirstHurewicz.Simplex 3) :
+    (fourSimplexFillB (Geometry.cubeTetrahedron (Geometry.cubePermutation 3) s) : Fin 5 → ℝ) =
+      ![s 2, s 0, 0, s 3, s 1] := by
+  have fourSimplexFillB_zero (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 0 = (u 0 : ℝ) - Min.min (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have fourSimplexFillB_one (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 1 = 1 - Max.max (u 0 : ℝ) (Max.max (u 1 : ℝ) (u 2 : ℝ)) := rfl
+  have fourSimplexFillB_two (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 2 = (u 1 : ℝ) - Min.min (u 1 : ℝ) (u 2 : ℝ) := rfl
+  have fourSimplexFillB_three (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 3 = Min.min (u 0 : ℝ) (Min.min (u 1 : ℝ) (u 2 : ℝ)) := rfl
+  have fourSimplexFillB_four (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 4 = (u 2 : ℝ) - Min.min (u 0 : ℝ) (u 2 : ℝ) := rfl
+  have hca := fourSimplexTetrahedron_tail_le_first s
+  have hs := fourSimplexTetrahedron_sum s
+  funext i
+  fin_cases i <;>
+    simp [fourSimplexFillB_zero, fourSimplexFillB_one, fourSimplexFillB_two,
+      fourSimplexFillB_three, fourSimplexFillB_four, fourSimplexTetrahedron_three_coordinate,
+      max_eq_right hca, min_eq_left hca]
+  all_goals linarith
+
+private theorem ThirdHurewicz.fourSimplexFillA_tetrahedron_four (s : FirstHurewicz.Simplex 3) :
+    (fourSimplexFillA (Geometry.cubeTetrahedron (Geometry.cubePermutation 4) s) : Fin 5 → ℝ) =
+      ![s 0, 0, s 1, s 2, s 3] := by
+  have fourSimplexFillA_zero (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 0 = 1 - Max.max (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have fourSimplexFillA_one (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 1 = (u 0 : ℝ) - Min.min (u 0 : ℝ) (Max.max (u 1 : ℝ) (u 2 : ℝ)) := rfl
+  have fourSimplexFillA_two (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 2 = (u 1 : ℝ) - Min.min (u 1 : ℝ) (u 2 : ℝ) := rfl
+  have fourSimplexFillA_three (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 3 =
+      Min.min (u 1 : ℝ) (u 2 : ℝ) - Min.min (u 0 : ℝ) (Min.min (u 1 : ℝ) (u 2 : ℝ)) :=
+    rfl
+  have fourSimplexFillA_four (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 4 = Min.min (u 0 : ℝ) (u 2 : ℝ) := rfl
+  have hca := fourSimplexTetrahedron_tail_le_first s
+  have hs := fourSimplexTetrahedron_sum s
+  funext i
+  fin_cases i <;>
+    simp [fourSimplexFillA_zero, fourSimplexFillA_one, fourSimplexFillA_two,
+      fourSimplexFillA_three, fourSimplexFillA_four, fourSimplexTetrahedron_four_coordinate,
+      max_eq_right hca, min_eq_left hca]
+  all_goals linarith
+
+private theorem ThirdHurewicz.fourSimplexFillB_tetrahedron_four (s : FirstHurewicz.Simplex 3) :
+    (fourSimplexFillB (Geometry.cubeTetrahedron (Geometry.cubePermutation 4) s) : Fin 5 → ℝ) =
+      ![0, s 0, s 1, s 3, s 2] := by
+  have fourSimplexFillB_zero (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 0 = (u 0 : ℝ) - Min.min (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have fourSimplexFillB_one (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 1 = 1 - Max.max (u 0 : ℝ) (Max.max (u 1 : ℝ) (u 2 : ℝ)) := rfl
+  have fourSimplexFillB_two (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 2 = (u 1 : ℝ) - Min.min (u 1 : ℝ) (u 2 : ℝ) := rfl
+  have fourSimplexFillB_three (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 3 = Min.min (u 0 : ℝ) (Min.min (u 1 : ℝ) (u 2 : ℝ)) := rfl
+  have fourSimplexFillB_four (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 4 = (u 2 : ℝ) - Min.min (u 0 : ℝ) (u 2 : ℝ) := rfl
+  have hca := fourSimplexTetrahedron_tail_le_first s
+  have hs := fourSimplexTetrahedron_sum s
+  funext i
+  fin_cases i <;>
+    simp [fourSimplexFillB_zero, fourSimplexFillB_one, fourSimplexFillB_two,
+      fourSimplexFillB_three, fourSimplexFillB_four, fourSimplexTetrahedron_four_coordinate,
+      min_eq_left hca, max_eq_right hca]
+  all_goals linarith
+
+private theorem ThirdHurewicz.fourSimplexFillA_tetrahedron_five (s : FirstHurewicz.Simplex 3) :
+    (fourSimplexFillA (Geometry.cubeTetrahedron (Geometry.cubePermutation 5) s) : Fin 5 → ℝ) =
+      ![s 0 + s 1, 0, 0, s 2, s 3] := by
+  have fourSimplexFillA_zero (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 0 = 1 - Max.max (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have fourSimplexFillA_one (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 1 = (u 0 : ℝ) - Min.min (u 0 : ℝ) (Max.max (u 1 : ℝ) (u 2 : ℝ)) := rfl
+  have fourSimplexFillA_two (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 2 = (u 1 : ℝ) - Min.min (u 1 : ℝ) (u 2 : ℝ) := rfl
+  have fourSimplexFillA_three (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 3 =
+      Min.min (u 1 : ℝ) (u 2 : ℝ) - Min.min (u 0 : ℝ) (Min.min (u 1 : ℝ) (u 2 : ℝ)) :=
+    rfl
+  have fourSimplexFillA_four (u : Fin 3 → unitInterval) :
+    fourSimplexFillA u 4 = Min.min (u 0 : ℝ) (u 2 : ℝ) := rfl
+  have hca := fourSimplexTetrahedron_tail_le_first s
+  have hs := fourSimplexTetrahedron_sum s
+  funext i
+  fin_cases i <;>
+    simp [fourSimplexFillA_zero, fourSimplexFillA_one, fourSimplexFillA_two,
+      fourSimplexFillA_three, fourSimplexFillA_four, fourSimplexTetrahedron_five_coordinate,
+      min_eq_left hca]
+  all_goals linarith
+
+private theorem ThirdHurewicz.fourSimplexFillB_tetrahedron_five (s : FirstHurewicz.Simplex 3) :
+    (fourSimplexFillB (Geometry.cubeTetrahedron (Geometry.cubePermutation 5) s) : Fin 5 → ℝ) =
+      ![0, s 0, 0, s 3, s 1 + s 2] := by
+  have fourSimplexFillB_zero (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 0 = (u 0 : ℝ) - Min.min (u 0 : ℝ) (u 1 : ℝ) := rfl
+  have fourSimplexFillB_one (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 1 = 1 - Max.max (u 0 : ℝ) (Max.max (u 1 : ℝ) (u 2 : ℝ)) := rfl
+  have fourSimplexFillB_two (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 2 = (u 1 : ℝ) - Min.min (u 1 : ℝ) (u 2 : ℝ) := rfl
+  have fourSimplexFillB_three (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 3 = Min.min (u 0 : ℝ) (Min.min (u 1 : ℝ) (u 2 : ℝ)) := rfl
+  have fourSimplexFillB_four (u : Fin 3 → unitInterval) :
+    fourSimplexFillB u 4 = (u 2 : ℝ) - Min.min (u 0 : ℝ) (u 2 : ℝ) := rfl
+  have hca := fourSimplexTetrahedron_tail_le_first s
+  have hs := fourSimplexTetrahedron_sum s
+  funext i
+  fin_cases i <;>
+    simp [fourSimplexFillB_zero, fourSimplexFillB_one, fourSimplexFillB_two,
+      fourSimplexFillB_three, fourSimplexFillB_four, fourSimplexTetrahedron_five_coordinate,
+      max_eq_right hca, min_eq_left hca]
+  all_goals linarith
+
+private theorem ThirdHurewicz.simplexFace_three_zero (s : FirstHurewicz.Simplex 3) :
+    (FirstHurewicz.simplexFace 3 0 s : Fin 5 → ℝ) = ![0, s 0, s 1, s 2, s 3] := by
+  funext i
+  fin_cases i
+  · exact FirstHurewicz.simplexFace_apply_self 3 0 s
+  · exact FirstHurewicz.simplexFace_apply_succAbove 3 0 s 0
+  · exact FirstHurewicz.simplexFace_apply_succAbove 3 0 s 1
+  · exact FirstHurewicz.simplexFace_apply_succAbove 3 0 s 2
+  · exact FirstHurewicz.simplexFace_apply_succAbove 3 0 s 3
+
+private theorem ThirdHurewicz.simplexFace_three_one (s : FirstHurewicz.Simplex 3) :
+    (FirstHurewicz.simplexFace 3 1 s : Fin 5 → ℝ) = ![s 0, 0, s 1, s 2, s 3] := by
+  funext i
+  fin_cases i
+  · exact FirstHurewicz.simplexFace_apply_succAbove 3 1 s 0
+  · exact FirstHurewicz.simplexFace_apply_self 3 1 s
+  · exact FirstHurewicz.simplexFace_apply_succAbove 3 1 s 1
+  · exact FirstHurewicz.simplexFace_apply_succAbove 3 1 s 2
+  · exact FirstHurewicz.simplexFace_apply_succAbove 3 1 s 3
+
+private theorem ThirdHurewicz.simplexFace_three_two (s : FirstHurewicz.Simplex 3) :
+    (FirstHurewicz.simplexFace 3 2 s : Fin 5 → ℝ) = ![s 0, s 1, 0, s 2, s 3] := by
+  funext i
+  fin_cases i
+  · exact FirstHurewicz.simplexFace_apply_succAbove 3 2 s 0
+  · exact FirstHurewicz.simplexFace_apply_succAbove 3 2 s 1
+  · exact FirstHurewicz.simplexFace_apply_self 3 2 s
+  · exact FirstHurewicz.simplexFace_apply_succAbove 3 2 s 2
+  · exact FirstHurewicz.simplexFace_apply_succAbove 3 2 s 3
+
+private theorem ThirdHurewicz.simplexFace_three_three (s : FirstHurewicz.Simplex 3) :
+    (FirstHurewicz.simplexFace 3 3 s : Fin 5 → ℝ) = ![s 0, s 1, s 2, 0, s 3] := by
+  funext i
+  fin_cases i
+  · exact FirstHurewicz.simplexFace_apply_succAbove 3 3 s 0
+  · exact FirstHurewicz.simplexFace_apply_succAbove 3 3 s 1
+  · exact FirstHurewicz.simplexFace_apply_succAbove 3 3 s 2
+  · exact FirstHurewicz.simplexFace_apply_self 3 3 s
+  · exact FirstHurewicz.simplexFace_apply_succAbove 3 3 s 3
+
+private theorem ThirdHurewicz.simplexFace_three_four (s : FirstHurewicz.Simplex 3) :
+    (FirstHurewicz.simplexFace 3 4 s : Fin 5 → ℝ) = ![s 0, s 1, s 2, s 3, 0] := by
+  funext i
+  fin_cases i
+  · exact FirstHurewicz.simplexFace_apply_succAbove 3 4 s 0
+  · exact FirstHurewicz.simplexFace_apply_succAbove 3 4 s 1
+  · exact FirstHurewicz.simplexFace_apply_succAbove 3 4 s 2
+  · exact FirstHurewicz.simplexFace_apply_succAbove 3 4 s 3
+  · exact FirstHurewicz.simplexFace_apply_self 3 4 s
+
+private theorem ThirdHurewicz.fourSimplexTetrahedronA_zero {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    fourSimplexTetrahedronA τ (Geometry.cubePermutation 0) = basedFourSimplexFace τ 3 := by
+  apply Subtype.ext
+  apply ContinuousMap.ext
+  intro s
+  change
+    τ.val (fourSimplexFillA (Geometry.cubeTetrahedron (Geometry.cubePermutation 0) s)) =
+      τ.val (FirstHurewicz.simplexFace 3 3 s)
+  apply congrArg τ.val
+  apply Subtype.ext
+  exact (fourSimplexFillA_tetrahedron_zero s).trans (simplexFace_three_three s).symm
+
+private theorem ThirdHurewicz.fourSimplexTetrahedronA_one {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    fourSimplexTetrahedronA τ (Geometry.cubePermutation 1) = constantBasedThreeSimplex x := by
+  apply Subtype.ext
+  apply ContinuousMap.ext
+  intro s
+  change τ.val (fourSimplexFillA (Geometry.cubeTetrahedron (Geometry.cubePermutation 1) s)) = x
+  apply τ.property
+  exact
+    ⟨2, 3, by decide, (congrFun (fourSimplexFillA_tetrahedron_one s) 2).trans rfl,
+      (congrFun (fourSimplexFillA_tetrahedron_one s) 3).trans rfl⟩
+
+private theorem ThirdHurewicz.fourSimplexTetrahedronA_two {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    fourSimplexTetrahedronA τ (Geometry.cubePermutation 2) = constantBasedThreeSimplex x := by
+  apply Subtype.ext
+  apply ContinuousMap.ext
+  intro s
+  change τ.val (fourSimplexFillA (Geometry.cubeTetrahedron (Geometry.cubePermutation 2) s)) = x
+  apply τ.property
+  exact
+    ⟨1, 3, by decide, (congrFun (fourSimplexFillA_tetrahedron_two s) 1).trans rfl,
+      (congrFun (fourSimplexFillA_tetrahedron_two s) 3).trans rfl⟩
+
+private theorem ThirdHurewicz.fourSimplexTetrahedronA_three {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    fourSimplexTetrahedronA τ (Geometry.cubePermutation 3) = constantBasedThreeSimplex x := by
+  apply Subtype.ext
+  apply ContinuousMap.ext
+  intro s
+  change τ.val (fourSimplexFillA (Geometry.cubeTetrahedron (Geometry.cubePermutation 3) s)) = x
+  apply τ.property
+  exact
+    ⟨1, 2, by decide, (congrFun (fourSimplexFillA_tetrahedron_three s) 1).trans rfl,
+      (congrFun (fourSimplexFillA_tetrahedron_three s) 2).trans rfl⟩
+
+private theorem ThirdHurewicz.fourSimplexTetrahedronA_four {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    fourSimplexTetrahedronA τ (Geometry.cubePermutation 4) = basedFourSimplexFace τ 1 := by
+  apply Subtype.ext
+  apply ContinuousMap.ext
+  intro s
+  change
+    τ.val (fourSimplexFillA (Geometry.cubeTetrahedron (Geometry.cubePermutation 4) s)) =
+      τ.val (FirstHurewicz.simplexFace 3 1 s)
+  apply congrArg τ.val
+  apply Subtype.ext
+  exact (fourSimplexFillA_tetrahedron_four s).trans (simplexFace_three_one s).symm
+
+private theorem ThirdHurewicz.fourSimplexTetrahedronA_five {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    fourSimplexTetrahedronA τ (Geometry.cubePermutation 5) = constantBasedThreeSimplex x := by
+  apply Subtype.ext
+  apply ContinuousMap.ext
+  intro s
+  change τ.val (fourSimplexFillA (Geometry.cubeTetrahedron (Geometry.cubePermutation 5) s)) = x
+  apply τ.property
+  exact
+    ⟨1, 2, by decide, (congrFun (fourSimplexFillA_tetrahedron_five s) 1).trans rfl,
+      (congrFun (fourSimplexFillA_tetrahedron_five s) 2).trans rfl⟩
+
+private def ThirdHurewicz.cubeThirdCycle : C(Fin 3 → (unitInterval), Fin 3 → (unitInterval))
+    where
+  toFun u := ![u 1, u 2, u 0]
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    fin_cases i <;> dsimp <;> fun_prop
+
+private theorem ThirdHurewicz.cubeThirdCycle_boundary (u : Fin 3 → (unitInterval))
+    (hu : u ∈ Cube.boundary (Fin 3)) : cubeThirdCycle u ∈ Cube.boundary (Fin 3) := by
+  rcases hu with ⟨i, hi⟩
+  fin_cases i
+  · exact ⟨2, by simpa [cubeThirdCycle] using hi⟩
+  · exact ⟨0, by simpa [cubeThirdCycle] using hi⟩
+  · exact ⟨1, by simpa [cubeThirdCycle] using hi⟩
+
+private def ThirdHurewicz.cubeThirdCyclicReverse : C(Fin 3 → (unitInterval), Fin 3 → (unitInterval))
+    where
+  toFun u := ![u 1, u 2, (unitInterval.symm) (u 0)]
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    fin_cases i <;> dsimp <;> fun_prop
+
+private theorem ThirdHurewicz.cubeThirdCyclicReverse_boundary (u : Fin 3 → (unitInterval))
+    (hu : u ∈ Cube.boundary (Fin 3)) : cubeThirdCyclicReverse u ∈ Cube.boundary (Fin 3) := by
+  rcases hu with ⟨i, hi⟩
+  fin_cases i
+  · change u 0 = 0 ∨ u 0 = 1 at hi
+    rcases hi with hi | hi
+    · exact ⟨2, Or.inr (by simp [cubeThirdCyclicReverse, hi])⟩
+    · exact ⟨2, Or.inl (by simp [cubeThirdCyclicReverse, hi])⟩
+  · exact ⟨0, by simpa [cubeThirdCyclicReverse] using hi⟩
+  · exact ⟨1, by simpa [cubeThirdCyclicReverse] using hi⟩
+
+private def ThirdHurewicz.cyclicThreeLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) : GenLoop (Fin 3) X x :=
+  ⟨p.val.comp cubeThirdCycle, fun u hu => p.property _ (cubeThirdCycle_boundary u hu)⟩
+
+private def ThirdHurewicz.cyclicReverseThreeLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) : GenLoop (Fin 3) X x :=
+  ⟨p.val.comp cubeThirdCyclicReverse, fun u hu =>
+    p.property _ (cubeThirdCyclicReverse_boundary u hu)⟩
+
+private theorem
+    ThirdHurewicz.cubeInsert01_boundary (a : Fin 2 → (unitInterval)) (b : (unitInterval))
+    (ha : a ∈ Cube.boundary (Fin 2)) : ![a 0, a 1, b] ∈ Cube.boundary (Fin 3) := by
+  rcases ha with ⟨i, hi⟩
+  fin_cases i
+  · exact ⟨0, by simpa using hi⟩
+  · exact ⟨1, by simpa using hi⟩
+
+private theorem
+    ThirdHurewicz.cubeInsert12_boundary (a : (unitInterval)) (b : Fin 2 → (unitInterval))
+    (hb : b ∈ Cube.boundary (Fin 2)) : ![a, b 0, b 1] ∈ Cube.boundary (Fin 3) := by
+  rcases hb with ⟨i, hi⟩
+  fin_cases i
+  · exact ⟨1, by simpa using hi⟩
+  · exact ⟨2, by simpa using hi⟩
+
+private def ThirdHurewicz.cubeQuarter01HomotopyMap :
+    C((unitInterval) × (Fin 3 → (unitInterval)), Fin 3 → (unitInterval))
+    where
+  toFun
+    z :=
+    ![SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap (z.1, ![z.2 0, z.2 1]) 0,
+      SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap (z.1, ![z.2 0, z.2 1]) 1, z.2 2]
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    fin_cases i <;> dsimp <;> fun_prop
+
+@[simp]
+private theorem ThirdHurewicz.cubeQuarter01HomotopyMap_zero (u : Fin 3 → (unitInterval)) :
+    cubeQuarter01HomotopyMap (0, u) = u := by
+  funext i
+  fin_cases i <;> simp [cubeQuarter01HomotopyMap]
+
+@[simp]
+private theorem ThirdHurewicz.cubeQuarter01HomotopyMap_one (u : Fin 3 → (unitInterval)) :
+    cubeQuarter01HomotopyMap (1, u) = ![u 1, (unitInterval.symm) (u 0), u 2] := by
+  funext i
+  fin_cases i <;> simp [cubeQuarter01HomotopyMap]
+
+private theorem ThirdHurewicz.cubeQuarter01HomotopyMap_boundary (t : (unitInterval))
+    (u : Fin 3 → (unitInterval)) (hu : u ∈ Cube.boundary (Fin 3)) :
+    cubeQuarter01HomotopyMap (t, u) ∈ Cube.boundary (Fin 3) := by
+  rcases hu with ⟨i, hi⟩
+  fin_cases i
+  · exact
+      cubeInsert01_boundary _ _
+        (SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap_boundary t (![u 0, u 1])
+          ⟨0, by simpa using hi⟩)
+  · exact
+      cubeInsert01_boundary _ _
+        (SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap_boundary t (![u 0, u 1])
+          ⟨1, by simpa using hi⟩)
+  · exact ⟨2, by simpa [cubeQuarter01HomotopyMap] using hi⟩
+
+private def ThirdHurewicz.cubeQuarter12HomotopyMap :
+    C((unitInterval) × (Fin 3 → (unitInterval)), Fin 3 → (unitInterval))
+    where
+  toFun
+    z :=
+    ![z.2 0, SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap (z.1, ![z.2 1, z.2 2]) 0,
+      SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap (z.1, ![z.2 1, z.2 2]) 1]
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    fin_cases i <;> dsimp <;> fun_prop
+
+@[simp]
+private theorem ThirdHurewicz.cubeQuarter12HomotopyMap_zero (u : Fin 3 → (unitInterval)) :
+    cubeQuarter12HomotopyMap (0, u) = u := by
+  funext i
+  fin_cases i <;> simp [cubeQuarter12HomotopyMap]
+
+@[simp]
+private theorem ThirdHurewicz.cubeQuarter12HomotopyMap_one (u : Fin 3 → (unitInterval)) :
+    cubeQuarter12HomotopyMap (1, u) = ![u 0, u 2, (unitInterval.symm) (u 1)] := by
+  funext i
+  fin_cases i <;> simp [cubeQuarter12HomotopyMap]
+
+private theorem ThirdHurewicz.cubeQuarter12HomotopyMap_boundary (t : (unitInterval))
+    (u : Fin 3 → (unitInterval)) (hu : u ∈ Cube.boundary (Fin 3)) :
+    cubeQuarter12HomotopyMap (t, u) ∈ Cube.boundary (Fin 3) := by
+  rcases hu with ⟨i, hi⟩
+  fin_cases i
+  · exact ⟨0, by simpa [cubeQuarter12HomotopyMap] using hi⟩
+  · exact
+      cubeInsert12_boundary _ _
+        (SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap_boundary t (![u 1, u 2])
+          ⟨0, by simpa using hi⟩)
+  · exact
+      cubeInsert12_boundary _ _
+        (SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap_boundary t (![u 1, u 2])
+          ⟨1, by simpa using hi⟩)
+
+private def ThirdHurewicz.cubeThirdCycleHomotopyMap :
+    C((unitInterval) × (Fin 3 → (unitInterval)), Fin 3 → (unitInterval)) :=
+  cubeQuarter12HomotopyMap.comp ⟨fun z => (z.1, cubeQuarter01HomotopyMap z), by fun_prop⟩
+
+@[simp]
+private theorem ThirdHurewicz.cubeThirdCycleHomotopyMap_zero (u : Fin 3 → (unitInterval)) :
+    cubeThirdCycleHomotopyMap (0, u) = u := by
+  change cubeQuarter12HomotopyMap (0, cubeQuarter01HomotopyMap (0, u)) = u
+  rw [cubeQuarter01HomotopyMap_zero, cubeQuarter12HomotopyMap_zero]
+
+@[simp]
+private theorem ThirdHurewicz.cubeThirdCycleHomotopyMap_one (u : Fin 3 → (unitInterval)) :
+    cubeThirdCycleHomotopyMap (1, u) = cubeThirdCycle u := by
+  change cubeQuarter12HomotopyMap (1, cubeQuarter01HomotopyMap (1, u)) = _
+  rw [cubeQuarter01HomotopyMap_one, cubeQuarter12HomotopyMap_one]
+  simp [cubeThirdCycle]
+
+private theorem ThirdHurewicz.cubeThirdCycleHomotopyMap_boundary (t : (unitInterval))
+    (u : Fin 3 → (unitInterval)) (hu : u ∈ Cube.boundary (Fin 3)) :
+    cubeThirdCycleHomotopyMap (t, u) ∈ Cube.boundary (Fin 3) :=
+  cubeQuarter12HomotopyMap_boundary t _ (cubeQuarter01HomotopyMap_boundary t u hu)
+
+private def ThirdHurewicz.cyclicThreeLoop_homotopy {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) : p.val.HomotopyRel (cyclicThreeLoop p).val (Cube.boundary (Fin 3))
+    where
+  toFun z := p (cubeThirdCycleHomotopyMap z)
+  continuous_toFun := p.val.continuous.comp cubeThirdCycleHomotopyMap.continuous
+  map_zero_left u := congrArg p (cubeThirdCycleHomotopyMap_zero u)
+  map_one_left u := congrArg p (cubeThirdCycleHomotopyMap_one u)
+  prop' t u
+    hu := (p.property _ (cubeThirdCycleHomotopyMap_boundary t u hu)).trans (p.property u hu).symm
+
+private theorem ThirdHurewicz.cyclicThreeLoop_class {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) : (⟦cyclicThreeLoop p⟧ : π_ 3 X x) = ⟦p⟧ := by
+  have h : (⟦p⟧ : π_ 3 X x) = ⟦cyclicThreeLoop p⟧ :=
+    Quotient.sound
+      (show GenLoop.Homotopic p (cyclicThreeLoop p) from ⟨cyclicThreeLoop_homotopy p⟩)
+  exact h.symm
+
+private theorem ThirdHurewicz.cyclicReverseThreeLoop_eq {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) :
+    cyclicReverseThreeLoop p = cyclicThreeLoop (GenLoop.symmAt (2 : Fin 3) p) := by
+  apply GenLoop.ext
+  intro u
+  change
+    p ![u 1, u 2, (unitInterval.symm) (u 0)] =
+      p
+        (fun j =>
+          if j = (2 : Fin 3) then (unitInterval.symm) (![u 1, u 2, u 0] 2)
+          else ![u 1, u 2, u 0] j)
+  congr 1
+  funext i
+  fin_cases i <;> simp
+
+private theorem ThirdHurewicz.cyclicReverseThreeLoop_class {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) :
+    (⟦cyclicReverseThreeLoop p⟧ : π_ 3 X x) = ((·⁻¹) : π_ 3 X x → π_ 3 X x) ⟦p⟧ := by
+  rw [cyclicReverseThreeLoop_eq, cyclicThreeLoop_class]
+  exact (HomotopyGroup.inv_spec (i := (2 : Fin 3)) (p := p)).symm
+
+private def ThirdHurewicz.threeSimplexCycle : C(FirstHurewicz.Simplex 3, FirstHurewicz.Simplex 3)
+    where
+  toFun
+    s :=
+    ⟨![s 1, s 2, s 3, s 0], by
+      constructor
+      · intro i
+        fin_cases i <;> exact stdSimplex.zero_le s _
+      · have hs := stdSimplex.sum_eq_one s
+        simp only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero, Matrix.cons_val_zero,
+          Matrix.cons_val_succ, Matrix.cons_val_fin_one] at hs ⊢
+        change s 0 + (s 1 + (s 2 + s 3)) = 1 at hs
+        linarith⟩
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    apply continuous_pi
+    intro i
+    fin_cases i
+    · exact (continuous_apply 1).comp continuous_subtype_val
+    · exact (continuous_apply 2).comp continuous_subtype_val
+    · exact (continuous_apply 3).comp continuous_subtype_val
+    · exact (continuous_apply 0).comp continuous_subtype_val
+
+private theorem ThirdHurewicz.threeSimplexCycle_boundary (s : FirstHurewicz.Simplex 3)
+    (hs : s ∈ threeSimplexBoundary) : threeSimplexCycle s ∈ threeSimplexBoundary := by
+  obtain ⟨i, hi⟩ := hs
+  fin_cases i
+  · exact ⟨3, hi⟩
+  · exact ⟨0, hi⟩
+  · exact ⟨1, hi⟩
+  · exact ⟨2, hi⟩
+
+private def ThirdHurewicz.basedThreeSimplexVertexCycle {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedThreeSimplex x) : BasedThreeSimplex x :=
+  ⟨τ.val.comp threeSimplexCycle, fun s hs => τ.property _ (threeSimplexCycle_boundary s hs)⟩
+
+private theorem ThirdHurewicz.threeSimplexCycle_quotient_commonZero (u : Fin 3 → (unitInterval))
+    (hu : u ∈ Cube.boundary (Fin 3)) :
+    ∃ i : Fin 4,
+      threeSimplexCycle (threeSimplexQuotient u) i = 0 ∧
+        threeSimplexQuotient (cubeThirdCyclicReverse u) i = 0 := by
+  have threeSimplexCycle_zero (s : FirstHurewicz.Simplex 3) : threeSimplexCycle s 0 = s 1 := rfl
+  have threeSimplexCycle_one (s : FirstHurewicz.Simplex 3) : threeSimplexCycle s 1 = s 2 := rfl
+  have threeSimplexCycle_two (s : FirstHurewicz.Simplex 3) : threeSimplexCycle s 2 = s 3 := rfl
+  have threeSimplexCycle_three (s : FirstHurewicz.Simplex 3) : threeSimplexCycle s 3 = s 0 := rfl
+  have cubeThirdCyclicReverse_apply (u : Fin 3 → (unitInterval)) :
+    cubeThirdCyclicReverse u = ![u 1, u 2, (unitInterval.symm) (u 0)] := rfl
+  rcases hu with ⟨i, hi | hi⟩
+  · fin_cases i
+    · change u 0 = 0 at hi
+      refine ⟨2, ?_, ?_⟩
+      · simp [threeSimplexCycle_two, hi, min_eq_left (le_min (u 1).property.1 (u 2).property.1)]
+      · simp [cubeThirdCyclicReverse_apply, hi, min_eq_left (u 2).property.2]
+    · change u 1 = 0 at hi
+      refine ⟨1, ?_, ?_⟩ <;>
+        simp [threeSimplexCycle_one, cubeThirdCyclicReverse_apply, hi,
+          min_eq_left (u 2).property.1, min_eq_right (u 0).property.1]
+    · change u 2 = 0 at hi
+      refine ⟨2, ?_, ?_⟩ <;>
+        simp [threeSimplexCycle_two, cubeThirdCyclicReverse_apply, hi,
+          min_eq_right (u 1).property.1, min_eq_right (u 0).property.1,
+          min_eq_left (sub_nonneg.mpr (u 0).property.2)]
+  · fin_cases i
+    · change u 0 = 1 at hi
+      refine ⟨3, ?_, ?_⟩ <;>
+        simp [threeSimplexCycle_three, cubeThirdCyclicReverse_apply, hi,
+          min_eq_right (u 2).property.1, min_eq_right (u 1).property.1]
+    · change u 1 = 1 at hi
+      refine ⟨0, ?_, ?_⟩ <;>
+        simp [threeSimplexCycle_zero, cubeThirdCyclicReverse_apply, hi,
+          min_eq_left (u 0).property.2]
+    · change u 2 = 1 at hi
+      refine ⟨1, ?_, ?_⟩ <;>
+        simp [threeSimplexCycle_one, cubeThirdCyclicReverse_apply, hi,
+          min_eq_left (u 1).property.2]
+
+private theorem ThirdHurewicz.threeSimplexCycle_quotient_blend_boundary (t : (unitInterval))
+    (u : Fin 3 → (unitInterval)) (hu : u ∈ Cube.boundary (Fin 3)) :
+    SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend t
+        (threeSimplexCycle (threeSimplexQuotient u))
+        (threeSimplexQuotient (cubeThirdCyclicReverse u)) ∈
+      threeSimplexBoundary := by
+  obtain ⟨i, hi, hj⟩ := threeSimplexCycle_quotient_commonZero u hu
+  exact ⟨i, SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend_zero_coordinate t _ _ i hi hj⟩
+
+private def ThirdHurewicz.basedThreeSimplexVertexCycle_loopHomotopy {X : Type} [TopologicalSpace X]
+    {x : X} (τ : BasedThreeSimplex x) :
+    (basedThreeSimplexLoop (basedThreeSimplexVertexCycle τ)).val.HomotopyRel
+      (cyclicReverseThreeLoop (basedThreeSimplexLoop τ)).val (Cube.boundary (Fin 3))
+    where
+  toFun
+    z :=
+    τ.val
+      (SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend z.1
+        (threeSimplexCycle (threeSimplexQuotient z.2))
+        (threeSimplexQuotient (cubeThirdCyclicReverse z.2)))
+  continuous_toFun :=
+    τ.val.continuous.comp
+      (SecondHurewicz.SimplyConnected.tetrahedronSimplexBlendMap
+          (threeSimplexCycle.comp threeSimplexQuotient)
+          (threeSimplexQuotient.comp cubeThirdCyclicReverse)).continuous
+  map_zero_left
+    u := by
+    change
+      τ.val (SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend 0 _ _) =
+        τ.val (threeSimplexCycle (threeSimplexQuotient u))
+    rw [SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend_zero]
+  map_one_left
+    u := by
+    change
+      τ.val (SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend 1 _ _) =
+        τ.val (threeSimplexQuotient (cubeThirdCyclicReverse u))
+    rw [SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend_one]
+  prop' t u
+    hu :=
+    (τ.property _ (threeSimplexCycle_quotient_blend_boundary t u hu)).trans
+      ((basedThreeSimplexLoop (basedThreeSimplexVertexCycle τ)).property u hu).symm
+
+@[simp]
+private theorem
+    ThirdHurewicz.basedThreeSimplexVertexCycle_class {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedThreeSimplex x) :
+    basedThreeSimplexClass (basedThreeSimplexVertexCycle τ) = -basedThreeSimplexClass τ := by
+  have h :
+    GenLoop.Homotopic (basedThreeSimplexLoop (basedThreeSimplexVertexCycle τ))
+      (cyclicReverseThreeLoop (basedThreeSimplexLoop τ)) :=
+    ⟨basedThreeSimplexVertexCycle_loopHomotopy τ⟩
+  have he :
+    (⟦basedThreeSimplexLoop (basedThreeSimplexVertexCycle τ)⟧ : π_ 3 X x) =
+      ⟦cyclicReverseThreeLoop (basedThreeSimplexLoop τ)⟧ :=
+    Quotient.sound h
+  exact
+    congrArg Additive.ofMul (he.trans (cyclicReverseThreeLoop_class (basedThreeSimplexLoop τ)))
+
+private def ThirdHurewicz.threeSimplexSwapLast : C(FirstHurewicz.Simplex 3, FirstHurewicz.Simplex 3)
+    where
+  toFun
+    s :=
+    ⟨![s 0, s 1, s 3, s 2], by
+      constructor
+      · intro i
+        fin_cases i <;> exact s.property.1 _
+      · have hs := s.property.2
+        simp only [Fin.sum_univ_succ, Fin.sum_univ_zero, add_zero, Matrix.cons_val_zero,
+          Matrix.cons_val_succ, Matrix.cons_val_fin_one] at hs ⊢
+        change s 0 + (s 1 + (s 2 + s 3)) = 1 at hs
+        simpa only [add_comm (s 2) (s 3)] using hs⟩
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    apply continuous_pi
+    intro i
+    fin_cases i
+    · change Continuous fun s : FirstHurewicz.Simplex 3 => s 0
+      exact (continuous_apply 0).comp continuous_subtype_val
+    · change Continuous fun s : FirstHurewicz.Simplex 3 => s 1
+      exact (continuous_apply 1).comp continuous_subtype_val
+    · change Continuous fun s : FirstHurewicz.Simplex 3 => s 3
+      exact (continuous_apply 3).comp continuous_subtype_val
+    · change Continuous fun s : FirstHurewicz.Simplex 3 => s 2
+      exact (continuous_apply 2).comp continuous_subtype_val
+
+private theorem ThirdHurewicz.threeSimplexSwapLast_boundary (s : FirstHurewicz.Simplex 3)
+    (hs : s ∈ threeSimplexBoundary) : threeSimplexSwapLast s ∈ threeSimplexBoundary := by
+  obtain ⟨i, hi⟩ := hs
+  fin_cases i
+  · exact ⟨0, hi⟩
+  · exact ⟨1, hi⟩
+  · exact ⟨3, hi⟩
+  · exact ⟨2, hi⟩
+
+private def ThirdHurewicz.cubeThirdLastReverse : C(Fin 3 → (unitInterval), Fin 3 → (unitInterval))
+    where
+  toFun u := ![u 0, u 1, (unitInterval.symm) (u 2)]
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    fin_cases i <;> dsimp <;> fun_prop
+
+@[simp]
+private theorem ThirdHurewicz.cubeThirdLastReverse_zero (u : Fin 3 → (unitInterval)) :
+    cubeThirdLastReverse u 0 = u 0 :=
+  rfl
+
+@[simp]
+private theorem ThirdHurewicz.cubeThirdLastReverse_one (u : Fin 3 → (unitInterval)) :
+    cubeThirdLastReverse u 1 = u 1 :=
+  rfl
+
+@[simp]
+private theorem ThirdHurewicz.cubeThirdLastReverse_two (u : Fin 3 → (unitInterval)) :
+    cubeThirdLastReverse u 2 = (unitInterval.symm) (u 2) :=
+  rfl
+
+private theorem ThirdHurewicz.threeSimplexSwapLast_commonZero (u : Fin 3 → (unitInterval))
+    (hu : u ∈ Cube.boundary (Fin 3)) :
+    ∃ i : Fin 4,
+      threeSimplexSwapLast (threeSimplexQuotient u) i = 0 ∧
+        threeSimplexQuotient (cubeThirdLastReverse u) i = 0 := by
+  have threeSimplexSwapLast_zero (s : FirstHurewicz.Simplex 3) : threeSimplexSwapLast s 0 = s 0 :=
+    rfl
+  have threeSimplexSwapLast_one (s : FirstHurewicz.Simplex 3) : threeSimplexSwapLast s 1 = s 1 :=
+    rfl
+  have threeSimplexSwapLast_two (s : FirstHurewicz.Simplex 3) : threeSimplexSwapLast s 2 = s 3 :=
+    rfl
+  have threeSimplexSwapLast_three (s : FirstHurewicz.Simplex 3) :
+    threeSimplexSwapLast s 3 = s 2 := rfl
+  rcases hu with ⟨j, hj | hj⟩
+  · fin_cases j
+    · change u 0 = 0 at hj
+      refine ⟨1, ?_, ?_⟩
+      · simp [threeSimplexSwapLast_one, hj, min_eq_left (u 1).property.1]
+      · simp [hj, min_eq_left (u 1).property.1]
+    · change u 1 = 0 at hj
+      refine ⟨2, ?_, ?_⟩
+      · simp [threeSimplexSwapLast_two, hj, min_eq_left (u 2).property.1,
+          min_eq_right (u 0).property.1]
+      · simp only [threeSimplexQuotient_two, cubeThirdLastReverse_zero, cubeThirdLastReverse_one,
+          cubeThirdLastReverse_two, hj]
+        change
+          Min.min (u 0 : ℝ) 0 - Min.min (u 0 : ℝ) (Min.min 0 ((unitInterval.symm) (u 2) : ℝ)) = 0
+        rw [min_eq_right (u 0).property.1, min_eq_left ((unitInterval.symm) (u 2)).property.1,
+          min_eq_right (u 0).property.1, sub_self]
+    · change u 2 = 0 at hj
+      refine ⟨2, ?_, ?_⟩
+      · simp [threeSimplexSwapLast_two, hj, min_eq_right (u 1).property.1,
+          min_eq_right (u 0).property.1]
+      · simp [hj, min_eq_left (u 1).property.2]
+  · fin_cases j
+    · change u 0 = 1 at hj
+      exact ⟨0, by simp [threeSimplexSwapLast_zero, hj], by simp [hj]⟩
+    · change u 1 = 1 at hj
+      exact
+        ⟨1, by simp [threeSimplexSwapLast_one, hj, min_eq_left (u 0).property.2], by
+          simp [hj, min_eq_left (u 0).property.2]⟩
+    · change u 2 = 1 at hj
+      refine ⟨3, ?_, ?_⟩
+      · simp [threeSimplexSwapLast_three, hj, min_eq_left (u 1).property.2]
+      · simp [hj, min_eq_right (u 1).property.1, min_eq_right (u 0).property.1]
+
+private def ThirdHurewicz.basedThreeSimplexSwapLast {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedThreeSimplex x) : BasedThreeSimplex x :=
+  ⟨τ.val.comp threeSimplexSwapLast, fun s hs => τ.property _ (threeSimplexSwapLast_boundary s hs)⟩
+
+private theorem ThirdHurewicz.symmAt_last_apply {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (u : Fin 3 → (unitInterval)) :
+    GenLoop.symmAt (2 : Fin 3) p u = p (cubeThirdLastReverse u) := by
+  change p (fun j => if j = (2 : Fin 3) then (unitInterval.symm) (u 2) else u j) = _
+  congr 1
+  funext j
+  fin_cases j <;> rfl
+
+private def
+    ThirdHurewicz.basedThreeSimplexSwapLast_loopHomotopy {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedThreeSimplex x) :
+    (basedThreeSimplexLoop (basedThreeSimplexSwapLast τ)).val.HomotopyRel
+      (GenLoop.symmAt (2 : Fin 3) (basedThreeSimplexLoop τ)).val (Cube.boundary (Fin 3))
+    where
+  toFun
+    z :=
+    τ.val
+      (SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend z.1
+        (threeSimplexSwapLast (threeSimplexQuotient z.2))
+        (threeSimplexQuotient (cubeThirdLastReverse z.2)))
+  continuous_toFun :=
+    τ.val.continuous.comp
+      (SecondHurewicz.SimplyConnected.tetrahedronSimplexBlendMap
+          (threeSimplexSwapLast.comp threeSimplexQuotient)
+          (threeSimplexQuotient.comp cubeThirdLastReverse)).continuous
+  map_zero_left
+    u := by
+    change τ.val (SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend 0 _ _) = _
+    rw [SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend_zero]
+    rfl
+  map_one_left
+    u := by
+    change
+      τ.val (SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend 1 _ _) =
+        GenLoop.symmAt (2 : Fin 3) (basedThreeSimplexLoop τ) u
+    rw [SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend_one, symmAt_last_apply]
+    rfl
+  prop' t u
+    hu := by
+    obtain ⟨i, ha, hb⟩ := threeSimplexSwapLast_commonZero u hu
+    exact
+      (τ.property _
+            ⟨i,
+              SecondHurewicz.SimplyConnected.tetrahedronSimplexBlend_zero_coordinate t _ _ i ha
+                hb⟩).trans
+        ((basedThreeSimplexLoop (basedThreeSimplexSwapLast τ)).property u hu).symm
+
+private theorem
+    ThirdHurewicz.basedThreeSimplexSwapLast_class {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedThreeSimplex x) :
+    basedThreeSimplexClass (basedThreeSimplexSwapLast τ) = -basedThreeSimplexClass τ := by
+  have h :
+    (⟦basedThreeSimplexLoop (basedThreeSimplexSwapLast τ)⟧ : π_ 3 X x) =
+      ⟦GenLoop.symmAt (2 : Fin 3) (basedThreeSimplexLoop τ)⟧ :=
+    Quotient.sound ⟨basedThreeSimplexSwapLast_loopHomotopy τ⟩
+  exact
+    congrArg Additive.ofMul
+      (h.trans (HomotopyGroup.inv_spec (i := (2 : Fin 3)) (p := basedThreeSimplexLoop τ)).symm)
+
+private def
+    ThirdHurewicz.threeSimplexSwapFirst : C(FirstHurewicz.Simplex 3, FirstHurewicz.Simplex 3) :=
+  threeSimplexCycle.comp
+    (threeSimplexCycle.comp
+      (threeSimplexSwapLast.comp (threeSimplexCycle.comp threeSimplexCycle)))
+
+private theorem ThirdHurewicz.threeSimplexSwapFirst_boundary (s : FirstHurewicz.Simplex 3)
+    (hs : s ∈ threeSimplexBoundary) : threeSimplexSwapFirst s ∈ threeSimplexBoundary :=
+  threeSimplexCycle_boundary _
+    (threeSimplexCycle_boundary _
+      (threeSimplexSwapLast_boundary _
+        (threeSimplexCycle_boundary _ (threeSimplexCycle_boundary _ hs))))
+
+private def ThirdHurewicz.threeSimplexVertexOrder1302 :
+    C(FirstHurewicz.Simplex 3, FirstHurewicz.Simplex 3) :=
+  threeSimplexCycle.comp (threeSimplexSwapLast.comp threeSimplexCycle)
+
+private theorem ThirdHurewicz.threeSimplexVertexOrder1302_boundary (s : FirstHurewicz.Simplex 3)
+    (hs : s ∈ threeSimplexBoundary) : threeSimplexVertexOrder1302 s ∈ threeSimplexBoundary :=
+  threeSimplexCycle_boundary _ (threeSimplexSwapLast_boundary _ (threeSimplexCycle_boundary _ hs))
+
+private def ThirdHurewicz.basedThreeSimplexSwapFirst {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedThreeSimplex x) : BasedThreeSimplex x :=
+  ⟨τ.val.comp threeSimplexSwapFirst, fun s hs =>
+    τ.property _ (threeSimplexSwapFirst_boundary s hs)⟩
+
+private theorem
+    ThirdHurewicz.basedThreeSimplexSwapFirst_word {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedThreeSimplex x) :
+    basedThreeSimplexSwapFirst τ =
+      basedThreeSimplexVertexCycle
+        (basedThreeSimplexVertexCycle
+          (basedThreeSimplexSwapLast
+            (basedThreeSimplexVertexCycle (basedThreeSimplexVertexCycle τ)))) := by
+  apply Subtype.ext
+  apply ContinuousMap.ext
+  intro s
+  rfl
+
+@[simp]
+private theorem
+    ThirdHurewicz.basedThreeSimplexSwapFirst_class {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedThreeSimplex x) :
+    basedThreeSimplexClass (basedThreeSimplexSwapFirst τ) = -basedThreeSimplexClass τ := by
+  rw [basedThreeSimplexSwapFirst_word]
+  simp only [basedThreeSimplexVertexCycle_class, basedThreeSimplexSwapLast_class, neg_neg]
+
+private def ThirdHurewicz.basedThreeSimplexVertexOrder1302 {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedThreeSimplex x) : BasedThreeSimplex x :=
+  ⟨τ.val.comp threeSimplexVertexOrder1302, fun s hs =>
+    τ.property _ (threeSimplexVertexOrder1302_boundary s hs)⟩
+
+private theorem ThirdHurewicz.basedThreeSimplexVertexOrder1302_word {X : Type} [TopologicalSpace X]
+    {x : X} (τ : BasedThreeSimplex x) :
+    basedThreeSimplexVertexOrder1302 τ =
+      basedThreeSimplexVertexCycle (basedThreeSimplexSwapLast (basedThreeSimplexVertexCycle τ)) :=
+  by
+  apply Subtype.ext
+  apply ContinuousMap.ext
+  intro s
+  rfl
+
+@[simp]
+private theorem ThirdHurewicz.basedThreeSimplexVertexOrder1302_class {X : Type} [TopologicalSpace X]
+    {x : X} (τ : BasedThreeSimplex x) :
+    basedThreeSimplexClass (basedThreeSimplexVertexOrder1302 τ) = -basedThreeSimplexClass τ := by
+  rw [basedThreeSimplexVertexOrder1302_word]
+  simp only [basedThreeSimplexVertexCycle_class, basedThreeSimplexSwapLast_class, neg_neg]
+
+private theorem ThirdHurewicz.fourSimplexTetrahedronB_zero {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    fourSimplexTetrahedronB τ (Geometry.cubePermutation 0) =
+      basedThreeSimplexSwapFirst (basedFourSimplexFace τ 4) := by
+  apply Subtype.ext
+  apply ContinuousMap.ext
+  intro s
+  change
+    τ.val (fourSimplexFillB (Geometry.cubeTetrahedron (Geometry.cubePermutation 0) s)) =
+      τ.val (FirstHurewicz.simplexFace 3 4 (threeSimplexSwapFirst s))
+  apply congrArg τ.val
+  apply Subtype.ext
+  exact
+    (fourSimplexFillB_tetrahedron_zero s).trans
+      (simplexFace_three_four (threeSimplexSwapFirst s)).symm
+
+private theorem ThirdHurewicz.fourSimplexTetrahedronB_one {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    fourSimplexTetrahedronB τ (Geometry.cubePermutation 1) = constantBasedThreeSimplex x := by
+  apply Subtype.ext
+  apply ContinuousMap.ext
+  intro s
+  change τ.val (fourSimplexFillB (Geometry.cubeTetrahedron (Geometry.cubePermutation 1) s)) = x
+  apply τ.property
+  exact
+    ⟨2, 4, by decide, (congrFun (fourSimplexFillB_tetrahedron_one s) 2).trans rfl,
+      (congrFun (fourSimplexFillB_tetrahedron_one s) 4).trans rfl⟩
+
+private theorem ThirdHurewicz.fourSimplexTetrahedronB_two {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    fourSimplexTetrahedronB τ (Geometry.cubePermutation 2) = constantBasedThreeSimplex x := by
+  apply Subtype.ext
+  apply ContinuousMap.ext
+  intro s
+  change τ.val (fourSimplexFillB (Geometry.cubeTetrahedron (Geometry.cubePermutation 2) s)) = x
+  apply τ.property
+  exact
+    ⟨0, 4, by decide, (congrFun (fourSimplexFillB_tetrahedron_two s) 0).trans rfl,
+      (congrFun (fourSimplexFillB_tetrahedron_two s) 4).trans rfl⟩
+
+private theorem ThirdHurewicz.fourSimplexTetrahedronB_three {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    fourSimplexTetrahedronB τ (Geometry.cubePermutation 3) =
+      basedThreeSimplexVertexOrder1302 (basedFourSimplexFace τ 2) := by
+  apply Subtype.ext
+  apply ContinuousMap.ext
+  intro s
+  change
+    τ.val (fourSimplexFillB (Geometry.cubeTetrahedron (Geometry.cubePermutation 3) s)) =
+      τ.val (FirstHurewicz.simplexFace 3 2 (threeSimplexVertexOrder1302 s))
+  apply congrArg τ.val
+  apply Subtype.ext
+  exact
+    (fourSimplexFillB_tetrahedron_three s).trans
+      (simplexFace_three_two (threeSimplexVertexOrder1302 s)).symm
+
+private theorem ThirdHurewicz.fourSimplexTetrahedronB_four {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    fourSimplexTetrahedronB τ (Geometry.cubePermutation 4) =
+      basedThreeSimplexSwapLast (basedFourSimplexFace τ 0) := by
+  apply Subtype.ext
+  apply ContinuousMap.ext
+  intro s
+  change
+    τ.val (fourSimplexFillB (Geometry.cubeTetrahedron (Geometry.cubePermutation 4) s)) =
+      τ.val (FirstHurewicz.simplexFace 3 0 (threeSimplexSwapLast s))
+  apply congrArg τ.val
+  apply Subtype.ext
+  exact
+    (fourSimplexFillB_tetrahedron_four s).trans
+      (simplexFace_three_zero (threeSimplexSwapLast s)).symm
+
+private theorem ThirdHurewicz.fourSimplexTetrahedronB_five {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    fourSimplexTetrahedronB τ (Geometry.cubePermutation 5) = constantBasedThreeSimplex x := by
+  apply Subtype.ext
+  apply ContinuousMap.ext
+  intro s
+  change τ.val (fourSimplexFillB (Geometry.cubeTetrahedron (Geometry.cubePermutation 5) s)) = x
+  apply τ.property
+  exact
+    ⟨0, 2, by decide, (congrFun (fourSimplexFillB_tetrahedron_five s) 0).trans rfl,
+      (congrFun (fourSimplexFillB_tetrahedron_five s) 2).trans rfl⟩
+
+private theorem ThirdHurewicz.fourSimplexTetrahedraA_sum {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    ∑ e : Equiv.Perm (Fin 3),
+        Geometry.cubeOrientation e • basedThreeSimplexClass (fourSimplexTetrahedronA τ e) =
+      basedThreeSimplexClass (basedFourSimplexFace τ 3) +
+        basedThreeSimplexClass (basedFourSimplexFace τ 1) := by
+  have hconstant : basedThreeSimplexClass (constantBasedThreeSimplex x) = 0 := rfl
+  rw [←
+    Geometry.cubePermutation_bijective.sum_comp
+      (fun e =>
+        Geometry.cubeOrientation e • basedThreeSimplexClass (fourSimplexTetrahedronA τ e))]
+  simp [hconstant, Fin.sum_univ_succ, Geometry.cubeOrientation_cubePermutation,
+    fourSimplexTetrahedronA_zero, fourSimplexTetrahedronA_one, fourSimplexTetrahedronA_two,
+    fourSimplexTetrahedronA_three, fourSimplexTetrahedronA_four, fourSimplexTetrahedronA_five]
+
+private theorem ThirdHurewicz.fourSimplexTetrahedraB_sum {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    ∑ e : Equiv.Perm (Fin 3),
+        Geometry.cubeOrientation e • basedThreeSimplexClass (fourSimplexTetrahedronB τ e) =
+      -(basedThreeSimplexClass (basedFourSimplexFace τ 4) +
+            basedThreeSimplexClass (basedFourSimplexFace τ 2) +
+          basedThreeSimplexClass (basedFourSimplexFace τ 0)) := by
+  have hconstant : basedThreeSimplexClass (constantBasedThreeSimplex x) = 0 := rfl
+  rw [←
+    Geometry.cubePermutation_bijective.sum_comp
+      (fun e =>
+        Geometry.cubeOrientation e • basedThreeSimplexClass (fourSimplexTetrahedronB τ e))]
+  simp [hconstant, Fin.sum_univ_succ, Geometry.cubeOrientation_cubePermutation, add_assoc,
+    fourSimplexTetrahedronB_zero, fourSimplexTetrahedronB_one, fourSimplexTetrahedronB_two,
+    fourSimplexTetrahedronB_three, fourSimplexTetrahedronB_four, fourSimplexTetrahedronB_five,
+    basedThreeSimplexSwapLast_class]
+  abel
+
+private def ThirdHurewicz.nativeDuffyCubeCanonical : C(NativeCube, NativeCube)
+    where
+  toFun u := ![u 0, u 0 * u 1, u 0 * u 1 * u 2]
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    fin_cases i
+    · exact continuous_apply 0
+    · exact
+        ((continuous_subtype_val.comp (continuous_apply 0)).mul
+              (continuous_subtype_val.comp (continuous_apply 1))).subtype_mk
+          _
+    · exact
+        (((continuous_subtype_val.comp (continuous_apply 0)).mul
+                  (continuous_subtype_val.comp (continuous_apply 1))).mul
+              (continuous_subtype_val.comp (continuous_apply 2))).subtype_mk
+          _
+
+private def ThirdHurewicz.nativeDuffyCube (e : Equiv.Perm (Fin 3)) : C(NativeCube, NativeCube)
+    where
+  toFun u i := nativeDuffyCubeCanonical u (e.symm i)
+  continuous_toFun :=
+    continuous_pi fun i => (continuous_apply (e.symm i)).comp nativeDuffyCubeCanonical.continuous
+
+private theorem ThirdHurewicz.nativeDuffyCube_apply (e : Equiv.Perm (Fin 3)) (u : NativeCube)
+    (i : Fin 3) : nativeDuffyCube e u i = ![u 0, u 0 * u 1, u 0 * u 1 * u 2] (e.symm i) :=
+  rfl
+
+@[simp]
+private theorem
+    ThirdHurewicz.nativeDuffyCube_coordinate_zero (e : Equiv.Perm (Fin 3)) (u : NativeCube) :
+    nativeDuffyCube e u (e 0) = u 0 := by simp [nativeDuffyCube_apply]
+
+@[simp]
+private theorem
+    ThirdHurewicz.nativeDuffyCube_coordinate_one (e : Equiv.Perm (Fin 3)) (u : NativeCube) :
+    nativeDuffyCube e u (e 1) = u 0 * u 1 := by simp [nativeDuffyCube_apply]
+
+@[simp]
+private theorem
+    ThirdHurewicz.nativeDuffyCube_coordinate_two (e : Equiv.Perm (Fin 3)) (u : NativeCube) :
+    nativeDuffyCube e u (e 2) = u 0 * u 1 * u 2 := by simp [nativeDuffyCube_apply]
+
+private theorem ThirdHurewicz.nativeDuffyCube_boundary (e : Equiv.Perm (Fin 3)) (u : NativeCube)
+    (hu : u ∈ Cube.boundary (Fin 3)) :
+    nativeDuffyCube e u ∈ Cube.boundary (Fin 3) ∨
+      ∃ i j : Fin 3, i ≠ j ∧ nativeDuffyCube e u i = nativeDuffyCube e u j := by
+  rcases hu with ⟨j, hj⟩
+  fin_cases j
+  · change u 0 = 0 ∨ u 0 = 1 at hj
+    rcases hj with hj | hj
+    · exact Or.inl ⟨e 0, Or.inl (by simpa using hj)⟩
+    · exact Or.inl ⟨e 0, Or.inr (by simpa using hj)⟩
+  · change u 1 = 0 ∨ u 1 = 1 at hj
+    rcases hj with hj | hj
+    · exact Or.inl ⟨e 1, Or.inl (by simp [hj])⟩
+    · exact Or.inr ⟨e 0, e 1, e.injective.ne (by decide), by simp [hj]⟩
+  · change u 2 = 0 ∨ u 2 = 1 at hj
+    rcases hj with hj | hj
+    · exact Or.inl ⟨e 2, Or.inl (by simp [hj])⟩
+    · exact Or.inr ⟨e 1, e 2, e.injective.ne (by decide), by simp [hj]⟩
+
+private theorem ThirdHurewicz.nativeDuffyCube_based {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) (e : Equiv.Perm (Fin 3))
+    (u : NativeCube) (hu : u ∈ Cube.boundary (Fin 3)) : p (nativeDuffyCube e u) = x := by
+  rcases nativeDuffyCube_boundary e u hu with h | ⟨i, j, hij, h⟩
+  · exact p.property _ h
+  · exact hp _ i j hij h
+
+private def ThirdHurewicz.nativeDuffyCubeLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) (e : Equiv.Perm (Fin 3)) :
+    GenLoop (Fin 3) X x :=
+  nativeCubePullbackLoop p (nativeDuffyCube e) (nativeDuffyCube_based p hp e)
+
+private def
+    ThirdHurewicz.nativeCubePair (i j : Fin 3) : C(Fin 3 → (unitInterval), Fin 2 → (unitInterval))
+    where
+  toFun u := ![u i, u j]
+  continuous_toFun := by
+    apply continuous_pi
+    intro k
+    fin_cases k <;> exact continuous_apply _
+
+private def ThirdHurewicz.nativeCubeQuarterTurnHomotopyMap (i j : Fin 3) :
+    C((unitInterval) × (Fin 3 → (unitInterval)), Fin 3 → (unitInterval))
+    where
+  toFun z
+    k :=
+    if k = i then
+      SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap (z.1, nativeCubePair i j z.2) 0
+    else
+      if k = j then
+        SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap (z.1, nativeCubePair i j z.2) 1
+      else z.2 k
+  continuous_toFun := by
+    apply continuous_pi
+    intro k
+    by_cases hi : k = i
+    · simp only [ite_eq_left hi]
+      exact
+        (continuous_apply (0 : Fin 2)).comp
+          (SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap.continuous.comp
+            (continuous_fst.prodMk ((nativeCubePair i j).continuous.comp continuous_snd)))
+    · by_cases hj : k = j
+      · simp only [ite_eq_right hi, ite_eq_left hj]
+        exact
+          (continuous_apply (1 : Fin 2)).comp
+            (SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap.continuous.comp
+              (continuous_fst.prodMk ((nativeCubePair i j).continuous.comp continuous_snd)))
+      · simp only [ite_eq_right hi, ite_eq_right hj]
+        exact (continuous_apply k).comp continuous_snd
+
+@[simp]
+private theorem ThirdHurewicz.nativeCubeQuarterTurnHomotopyMap_zero (i j : Fin 3)
+    (u : Fin 3 → (unitInterval)) : nativeCubeQuarterTurnHomotopyMap i j (0, u) = u := by
+  funext k
+  change
+    (if k = i then
+        SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap (0, nativeCubePair i j u) 0
+      else
+        if k = j then
+          SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap (0, nativeCubePair i j u) 1
+        else u k) =
+      u k
+  simp only [SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap_zero]
+  change (if k = i then u i else if k = j then u j else u k) = u k
+  split_ifs with hi hj <;> simp_all
+
+@[simp]
+private theorem ThirdHurewicz.nativeCubeQuarterTurnHomotopyMap_one (i j : Fin 3)
+    (u : Fin 3 → (unitInterval)) :
+    nativeCubeQuarterTurnHomotopyMap i j (1, u) = fun k =>
+      if k = i then u j else if k = j then (unitInterval.symm) (u i) else u k := by
+  funext k
+  simp [nativeCubeQuarterTurnHomotopyMap, nativeCubePair]
+
+private theorem ThirdHurewicz.nativeCubeQuarterTurnHomotopyMap_boundary (i j : Fin 3) (hij : i ≠ j)
+    (t : (unitInterval)) (u : Fin 3 → (unitInterval)) (hu : u ∈ Cube.boundary (Fin 3)) :
+    nativeCubeQuarterTurnHomotopyMap i j (t, u) ∈ Cube.boundary (Fin 3) := by
+  have hp (h : nativeCubePair i j u ∈ Cube.boundary (Fin 2)) :
+    nativeCubeQuarterTurnHomotopyMap i j (t, u) ∈ Cube.boundary (Fin 3) := by
+    obtain ⟨k, hk⟩ :=
+      SecondHurewicz.SimplyConnected.quarterTurnHomotopyMap_boundary t (nativeCubePair i j u) h
+    fin_cases k
+    · exact ⟨i, by simpa [nativeCubeQuarterTurnHomotopyMap] using hk⟩
+    · exact ⟨j, by simpa [nativeCubeQuarterTurnHomotopyMap, hij.symm] using hk⟩
+  obtain ⟨k, hk⟩ := hu
+  by_cases hi : k = i
+  · subst k
+    exact hp ⟨0, by simpa [nativeCubePair] using hk⟩
+  · by_cases hj : k = j
+    · subst k
+      exact hp ⟨1, by simpa [nativeCubePair] using hk⟩
+    · exact ⟨k, by simpa [nativeCubeQuarterTurnHomotopyMap, hi, hj] using hk⟩
+
+private def ThirdHurewicz.nativeCubeQuarterTurnLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i j : Fin 3) (hij : i ≠ j) : GenLoop (Fin 3) X x :=
+  ⟨⟨fun u => p (nativeCubeQuarterTurnHomotopyMap i j (1, u)),
+      p.val.continuous.comp
+        ((nativeCubeQuarterTurnHomotopyMap i j).continuous.comp
+          (continuous_const.prodMk continuous_id))⟩,
+    fun u hu => p.property _ (nativeCubeQuarterTurnHomotopyMap_boundary i j hij 1 u hu)⟩
+
+@[simp]
+private theorem
+    ThirdHurewicz.nativeCubeQuarterTurnLoop_apply {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i j : Fin 3) (hij : i ≠ j) (u : Fin 3 → (unitInterval)) :
+    nativeCubeQuarterTurnLoop p i j hij u =
+      p (fun k => if k = i then u j else if k = j then (unitInterval.symm) (u i) else u k) := by
+  change p (nativeCubeQuarterTurnHomotopyMap i j (1, u)) = _
+  rw [nativeCubeQuarterTurnHomotopyMap_one]
+
+private def ThirdHurewicz.nativeCubeQuarterTurnHomotopy {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i j : Fin 3) (hij : i ≠ j) :
+    p.val.HomotopyRel (nativeCubeQuarterTurnLoop p i j hij).val (Cube.boundary (Fin 3))
+    where
+  toFun z := p (nativeCubeQuarterTurnHomotopyMap i j z)
+  continuous_toFun := p.val.continuous.comp (nativeCubeQuarterTurnHomotopyMap i j).continuous
+  map_zero_left u := congrArg p (nativeCubeQuarterTurnHomotopyMap_zero i j u)
+  map_one_left _ := rfl
+  prop' t u
+    hu :=
+    (p.property _ (nativeCubeQuarterTurnHomotopyMap_boundary i j hij t u hu)).trans
+      (p.property u hu).symm
+
+private theorem
+    ThirdHurewicz.nativeCubeQuarterTurnLoop_class {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i j : Fin 3) (hij : i ≠ j) :
+    (⟦nativeCubeQuarterTurnLoop p i j hij⟧ : π_ 3 X x) = ⟦p⟧ := by
+  exact
+    (Quotient.sound
+        (show GenLoop.Homotopic p (nativeCubeQuarterTurnLoop p i j hij) from
+          ⟨nativeCubeQuarterTurnHomotopy p i j hij⟩)).symm
+
+private theorem
+    ThirdHurewicz.nativeCubeQuarterTurnLoop_additiveClass {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 3) X x) (i j : Fin 3) (hij : i ≠ j) :
+    Additive.ofMul (⟦nativeCubeQuarterTurnLoop p i j hij⟧ : π_ 3 X x) =
+      Additive.ofMul (⟦p⟧ : π_ 3 X x) :=
+  congrArg Additive.ofMul (nativeCubeQuarterTurnLoop_class p i j hij)
+
+private def ThirdHurewicz.permuteCubeCoordinates (e : Equiv.Perm (Fin 3)) :
+    C(Fin 3 → (unitInterval), Fin 3 → (unitInterval))
+    where
+  toFun u i := u (e i)
+  continuous_toFun := by fun_prop
+
+private theorem ThirdHurewicz.permuteCubeCoordinates_boundary (e : Equiv.Perm (Fin 3))
+    (u : Fin 3 → (unitInterval)) (hu : u ∈ Cube.boundary (Fin 3)) :
+    permuteCubeCoordinates e u ∈ Cube.boundary (Fin 3) := by
+  obtain ⟨i, hi⟩ := hu
+  exact ⟨e.symm i, by simpa [permuteCubeCoordinates] using hi⟩
+
+private def ThirdHurewicz.permuteCubeLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (e : Equiv.Perm (Fin 3)) : GenLoop (Fin 3) X x :=
+  ⟨p.val.comp (permuteCubeCoordinates e), fun u hu =>
+    p.property _ (permuteCubeCoordinates_boundary e u hu)⟩
+
+@[simp]
+private theorem ThirdHurewicz.permuteCubeLoop_one {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) : permuteCubeLoop p 1 = p := by
+  apply GenLoop.ext
+  intro u
+  rfl
+
+private theorem ThirdHurewicz.permuteCubeLoop_mul {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (e f : Equiv.Perm (Fin 3)) :
+    permuteCubeLoop p (e * f) = permuteCubeLoop (permuteCubeLoop p f) e := by
+  apply GenLoop.ext
+  intro u
+  rfl
+
+private theorem
+    ThirdHurewicz.nativeCubeQuarterTurnLoop_eq_symmAt_permute {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 3) X x) (i j : Fin 3) (hij : i ≠ j) :
+    nativeCubeQuarterTurnLoop p i j hij = GenLoop.symmAt i (permuteCubeLoop p (Equiv.swap i j)) :=
+  by
+  apply GenLoop.ext
+  intro u
+  rw [nativeCubeQuarterTurnLoop_apply]
+  change
+    p (fun k => if k = i then u j else if k = j then (unitInterval.symm) (u i) else u k) =
+      p
+        (fun k =>
+          if Equiv.swap i j k = i then (unitInterval.symm) (u i) else u (Equiv.swap i j k))
+  congr 1
+  funext k
+  by_cases hi : k = i
+  · subst k
+    simp [hij.symm]
+  · by_cases hj : k = j
+    · subst k
+      simp [hij.symm]
+    · simp [hi, hj, Equiv.swap_apply_of_ne_of_ne hi hj]
+
+private theorem ThirdHurewicz.nativeCubeClass_quarterTurn {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i j : Fin 3) (hij : i ≠ j) :
+    nativeCubeClass (nativeCubeQuarterTurnLoop p i j hij) = nativeCubeClass p :=
+  nativeCubeQuarterTurnLoop_additiveClass p i j hij
+
+private theorem
+    ThirdHurewicz.permuteCubeLoop_swap_additiveClass {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i j : Fin 3) (hij : i ≠ j) :
+    nativeCubeClass (permuteCubeLoop p (Equiv.swap i j)) = -nativeCubeClass p := by
+  have h := nativeCubeClass_quarterTurn p i j hij
+  rw [nativeCubeQuarterTurnLoop_eq_symmAt_permute, nativeCubeClass_symmAt] at h
+  simpa only [neg_neg] using congrArg Neg.neg h
+
+private theorem ThirdHurewicz.permuteCubeLoop_additiveClass {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (e : Equiv.Perm (Fin 3)) :
+    nativeCubeClass (permuteCubeLoop p e) = ((Equiv.Perm.sign e : ℤˣ) : ℤ) • nativeCubeClass p := by
+  induction e using Equiv.Perm.swap_induction_on with
+  | one => simp
+  | swap_mul e i j hij
+    ih =>
+    rw [permuteCubeLoop_mul, permuteCubeLoop_swap_additiveClass _ i j hij, ih]
+    simp [Equiv.Perm.sign_mul, Equiv.Perm.sign_swap hij]
+
+private def ThirdHurewicz.nativeCubeCycle120 : Equiv.Perm (Fin 3) :=
+  Equiv.swap 0 1 * Equiv.swap 1 2
+
+private def ThirdHurewicz.nativeCubeCycle201 : Equiv.Perm (Fin 3) :=
+  Equiv.swap 1 2 * Equiv.swap 0 1
+
+@[fun_prop]
+private theorem ThirdHurewicz.nativeInterval_continuous_mul {Y : Type*} [TopologicalSpace Y]
+    {f g : Y → (unitInterval)} (hf : Continuous f) (hg : Continuous g) :
+    Continuous fun y => f y * g y := by
+  apply Continuous.subtype_mk
+  exact hf.subtype_val.mul hg.subtype_val
+
+@[fun_prop]
+private theorem ThirdHurewicz.nativeInterval_continuous_convexComb {Y : Type*} [TopologicalSpace Y]
+    {f g t : Y → (unitInterval)} (hf : Continuous f) (hg : Continuous g) (ht : Continuous t) :
+    Continuous fun y => Set.Icc.convexComb (f y) (g y) (t y) := by
+  apply Continuous.subtype_mk
+  exact
+    ((continuous_const.sub ht.subtype_val).mul hf.subtype_val).add
+      (ht.subtype_val.mul hg.subtype_val)
+
+private def ThirdHurewicz.nativeLowerPrismMap : C(NativeCube, NativeCube)
+    where
+  toFun u := ![u 0, u 0 * u 1, u 2]
+  continuous_toFun := by fun_prop
+
+private def ThirdHurewicz.nativeUpperPrismMap : C(NativeCube, NativeCube)
+    where
+  toFun u := ![u 0, Set.Icc.convexComb (u 0) 1 (u 1), u 2]
+  continuous_toFun := by fun_prop
+
+private def ThirdHurewicz.nativeMiddleChamberMap : C(NativeCube, NativeCube)
+    where
+  toFun u := ![u 0, u 0 * u 1, u 0 * Set.Icc.convexComb (u 1) 1 (u 2)]
+  continuous_toFun := by fun_prop
+
+private def ThirdHurewicz.nativeHighChamberMap : C(NativeCube, NativeCube)
+    where
+  toFun u := ![u 0, u 0 * u 1, Set.Icc.convexComb (u 0) 1 (u 2)]
+  continuous_toFun := by fun_prop
+
+private def ThirdHurewicz.nativeUpperLowChamberMap : C(NativeCube, NativeCube)
+    where
+  toFun u := ![u 0, Set.Icc.convexComb (u 0) 1 (u 1), u 0 * u 2]
+  continuous_toFun := by fun_prop
+
+private def ThirdHurewicz.nativeUpperMiddleChamberMap : C(NativeCube, NativeCube)
+    where
+  toFun
+    u :=
+    ![u 0, Set.Icc.convexComb (u 0) 1 (u 1),
+      Set.Icc.convexComb (u 0) (Set.Icc.convexComb (u 0) 1 (u 1)) (u 2)]
+  continuous_toFun := by fun_prop
+
+private def ThirdHurewicz.nativeUpperHighChamberMap : C(NativeCube, NativeCube)
+    where
+  toFun
+    u :=
+    ![u 0, Set.Icc.convexComb (u 0) 1 (u 1),
+      Set.Icc.convexComb (Set.Icc.convexComb (u 0) 1 (u 1)) 1 (u 2)]
+  continuous_toFun := by fun_prop
+
+private def
+    ThirdHurewicz.nativeOrderedDuffyMap (e : Equiv.Perm (Fin 3)) : C(NativeCube, NativeCube) :=
+  (nativeDuffyCube e).comp (permuteCubeCoordinates e)
+
+@[simp]
+private theorem ThirdHurewicz.nativeOrderedDuffyMap_swap12 (u : NativeCube) :
+    nativeOrderedDuffyMap (Equiv.swap 1 2) u = ![u 0, u 0 * u 2 * u 1, u 0 * u 2] := by
+  funext i
+  fin_cases i <;> rfl
+
+@[simp]
+private theorem ThirdHurewicz.nativeOrderedDuffyMap_cycle201 (u : NativeCube) :
+    nativeOrderedDuffyMap nativeCubeCycle201 u = ![u 2 * u 0, u 2 * u 0 * u 1, u 2] := by
+  funext i
+  fin_cases i <;> rfl
+
+@[simp]
+private theorem ThirdHurewicz.nativeOrderedDuffyMap_swap01 (u : NativeCube) :
+    nativeOrderedDuffyMap (Equiv.swap 0 1) u = ![u 1 * u 0, u 1, u 1 * u 0 * u 2] := by
+  funext i
+  fin_cases i <;> rfl
+
+@[simp]
+private theorem ThirdHurewicz.nativeOrderedDuffyMap_cycle120 (u : NativeCube) :
+    nativeOrderedDuffyMap nativeCubeCycle120 u = ![u 1 * u 2 * u 0, u 1, u 1 * u 2] := by
+  funext i
+  fin_cases i <;> rfl
+
+@[simp]
+private theorem ThirdHurewicz.nativeOrderedDuffyMap_swap02 (u : NativeCube) :
+    nativeOrderedDuffyMap (Equiv.swap 0 2) u = ![u 2 * u 1 * u 0, u 2 * u 1, u 2] := by
+  funext i
+  fin_cases i <;> rfl
+
+private theorem ThirdHurewicz.nativeMiddleChamber_flats (u : NativeCube)
+    (hu : u ∈ Cube.boundary (Fin 3)) :
+    NativeCubeSameFlat (nativeMiddleChamberMap u) (nativeOrderedDuffyMap (Equiv.swap 1 2) u) := by
+  rcases hu with ⟨i, hi | hi⟩
+  · fin_cases i
+    · change u 0 = 0 at hi
+      exact .zero 0 (by simp [nativeMiddleChamberMap, hi]) (by simp [hi])
+    · change u 1 = 0 at hi
+      exact .zero 1 (by simp [nativeMiddleChamberMap, hi]) (by simp [hi])
+    · change u 2 = 0 at hi
+      exact .equal 1 2 (by decide) (by simp [nativeMiddleChamberMap, hi]) (by simp [hi])
+  · fin_cases i
+    · change u 0 = 1 at hi
+      exact .one 0 (by simp [nativeMiddleChamberMap, hi]) (by simp [hi])
+    · change u 1 = 1 at hi
+      exact .equal 1 2 (by decide) (by simp [nativeMiddleChamberMap, hi]) (by simp [hi])
+    · change u 2 = 1 at hi
+      exact .equal 0 2 (by decide) (by simp [nativeMiddleChamberMap, hi]) (by simp [hi])
+
+private theorem
+    ThirdHurewicz.nativeHighChamber_flats (u : NativeCube) (hu : u ∈ Cube.boundary (Fin 3)) :
+    NativeCubeSameFlat (nativeHighChamberMap u) (nativeOrderedDuffyMap (nativeCubeCycle201) u) := by
+  rcases hu with ⟨i, hi | hi⟩
+  · fin_cases i
+    · change u 0 = 0 at hi
+      exact .zero 0 (by simp [nativeHighChamberMap, hi]) (by simp [hi])
+    · change u 1 = 0 at hi
+      exact .zero 1 (by simp [nativeHighChamberMap, hi]) (by simp [hi])
+    · change u 2 = 0 at hi
+      exact .equal 0 2 (by decide) (by simp [nativeHighChamberMap, hi]) (by simp [hi])
+  · fin_cases i
+    · change u 0 = 1 at hi
+      exact .equal 0 2 (by decide) (by simp [nativeHighChamberMap, hi]) (by simp [hi])
+    · change u 1 = 1 at hi
+      exact .equal 0 1 (by decide) (by simp [nativeHighChamberMap, hi]) (by simp [hi])
+    · change u 2 = 1 at hi
+      exact .one 2 (by simp [nativeHighChamberMap, hi]) (by simp [hi])
+
+private theorem ThirdHurewicz.nativeUpperLowChamber_flats (u : NativeCube)
+    (hu : u ∈ Cube.boundary (Fin 3)) :
+    NativeCubeSameFlat (nativeUpperLowChamberMap u) (nativeOrderedDuffyMap (Equiv.swap 0 1) u) := by
+  rcases hu with ⟨i, hi | hi⟩
+  · fin_cases i
+    · change u 0 = 0 at hi
+      exact .zero 0 (by simp [nativeUpperLowChamberMap, hi]) (by simp [hi])
+    · change u 1 = 0 at hi
+      exact .equal 0 1 (by decide) (by simp [nativeUpperLowChamberMap, hi]) (by simp [hi])
+    · change u 2 = 0 at hi
+      exact .zero 2 (by simp [nativeUpperLowChamberMap, hi]) (by simp [hi])
+  · fin_cases i
+    · change u 0 = 1 at hi
+      exact .equal 0 1 (by decide) (by simp [nativeUpperLowChamberMap, hi]) (by simp [hi])
+    · change u 1 = 1 at hi
+      exact .one 1 (by simp [nativeUpperLowChamberMap, hi]) (by simp [hi])
+    · change u 2 = 1 at hi
+      exact .equal 0 2 (by decide) (by simp [nativeUpperLowChamberMap, hi]) (by simp [hi])
+
+private theorem ThirdHurewicz.nativeUpperMiddleChamber_flats (u : NativeCube)
+    (hu : u ∈ Cube.boundary (Fin 3)) :
+    NativeCubeSameFlat (nativeUpperMiddleChamberMap u)
+      (nativeOrderedDuffyMap nativeCubeCycle120 u) := by
+  rcases hu with ⟨i, hi | hi⟩
+  · fin_cases i
+    · change u 0 = 0 at hi
+      exact .zero 0 (by simp [nativeUpperMiddleChamberMap, hi]) (by simp [hi])
+    · change u 1 = 0 at hi
+      exact .equal 0 1 (by decide) (by simp [nativeUpperMiddleChamberMap, hi]) (by simp [hi])
+    · change u 2 = 0 at hi
+      exact .equal 0 2 (by decide) (by simp [nativeUpperMiddleChamberMap, hi]) (by simp [hi])
+  · fin_cases i
+    · change u 0 = 1 at hi
+      exact .equal 0 2 (by decide) (by simp [nativeUpperMiddleChamberMap, hi]) (by simp [hi])
+    · change u 1 = 1 at hi
+      exact .one 1 (by simp [nativeUpperMiddleChamberMap, hi]) (by simp [hi])
+    · change u 2 = 1 at hi
+      exact .equal 1 2 (by decide) (by simp [nativeUpperMiddleChamberMap, hi]) (by simp [hi])
+
+private theorem ThirdHurewicz.nativeUpperHighChamber_flats (u : NativeCube)
+    (hu : u ∈ Cube.boundary (Fin 3)) :
+    NativeCubeSameFlat (nativeUpperHighChamberMap u) (nativeOrderedDuffyMap (Equiv.swap 0 2) u) :=
+  by
+  rcases hu with ⟨i, hi | hi⟩
+  · fin_cases i
+    · change u 0 = 0 at hi
+      exact .zero 0 (by simp [nativeUpperHighChamberMap, hi]) (by simp [hi])
+    · change u 1 = 0 at hi
+      exact .equal 0 1 (by decide) (by simp [nativeUpperHighChamberMap, hi]) (by simp [hi])
+    · change u 2 = 0 at hi
+      exact .equal 1 2 (by decide) (by simp [nativeUpperHighChamberMap, hi]) (by simp [hi])
+  · fin_cases i
+    · change u 0 = 1 at hi
+      exact .equal 0 1 (by decide) (by simp [nativeUpperHighChamberMap, hi]) (by simp [hi])
+    · change u 1 = 1 at hi
+      exact .equal 1 2 (by decide) (by simp [nativeUpperHighChamberMap, hi]) (by simp [hi])
+    · change u 2 = 1 at hi
+      exact .one 2 (by simp [nativeUpperHighChamberMap, hi]) (by simp [hi])
+
+private theorem
+    ThirdHurewicz.nativeCubeMap_based_of_commonLeft {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) {f g : C(NativeCube, NativeCube)}
+    (h : ∀ u ∈ Cube.boundary (Fin 3), NativeCubeSameFlat (f u) (g u)) (u : NativeCube)
+    (hu : u ∈ Cube.boundary (Fin 3)) : p (f u) = x := by
+  simpa only [nativeCubeBlend_zero] using nativeCubeBlend_based p hp (h u hu) 0
+
+private theorem ThirdHurewicz.nativeDuffyCube_tetrahedron_sameFlat (e : Equiv.Perm (Fin 3))
+    (u : NativeCube) (hu : u ∈ Cube.boundary (Fin 3)) :
+    NativeCubeSameFlat (nativeDuffyCube e u) (nativeCubeTetrahedronQuotient e u) := by
+  rcases hu with ⟨i, hi | hi⟩
+  · fin_cases i
+    · change u 0 = 0 at hi
+      exact .zero (e 0) (by simp [hi]) (by simp [hi])
+    · change u 1 = 0 at hi
+      refine .zero (e 1) (by simp [hi]) ?_
+      simp [hi]
+    · change u 2 = 0 at hi
+      refine .zero (e 2) (by simp [hi]) ?_
+      simp [hi]
+  · fin_cases i
+    · change u 0 = 1 at hi
+      exact .one (e 0) (by simp [hi]) (by simp [hi])
+    · change u 1 = 1 at hi
+      refine .equal (e 0) (e 1) (e.injective.ne (by decide)) (by simp [hi]) ?_
+      simp [hi, min_eq_left (show u 0 ≤ (1 : (unitInterval)) from (u 0).property.2)]
+    · change u 2 = 1 at hi
+      refine .equal (e 1) (e 2) (e.injective.ne (by decide)) (by simp [hi]) ?_
+      simp [hi, min_eq_left (show u 1 ≤ (1 : (unitInterval)) from (u 1).property.2)]
+
+private def ThirdHurewicz.nativeDuffyCubeTetrahedronHomotopy {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) (e : Equiv.Perm (Fin 3)) :
+    (nativeDuffyCubeLoop p hp e).val.HomotopyRel
+      (basedThreeSimplexLoop (nativeBasedCubeTetrahedron p hp e)).val (Cube.boundary (Fin 3)) :=
+  nativeCubeLinearHomotopy p hp (nativeDuffyCube e) (nativeCubeTetrahedronQuotient e)
+    (nativeDuffyCube_based p hp e) (nativeCubeTetrahedronQuotient_based p hp e)
+    (nativeDuffyCube_tetrahedron_sameFlat e)
+
+private theorem ThirdHurewicz.nativeDuffyCube_homotopic_basedThreeSimplexLoop {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p)
+    (e : Equiv.Perm (Fin 3)) :
+    GenLoop.Homotopic (nativeDuffyCubeLoop p hp e)
+      (basedThreeSimplexLoop (nativeBasedCubeTetrahedron p hp e)) :=
+  ⟨nativeDuffyCubeTetrahedronHomotopy p hp e⟩
+
+private theorem ThirdHurewicz.nativeDuffyCubeClass_eq_basedThreeSimplexClass {X : Type}
+    [TopologicalSpace X] {x : X} (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p)
+    (e : Equiv.Perm (Fin 3)) :
+    nativeCubeClass (nativeDuffyCubeLoop p hp e) =
+      basedThreeSimplexClass (nativeBasedCubeTetrahedron p hp e) :=
+  nativeCubeClass_homotopic (nativeDuffyCube_homotopic_basedThreeSimplexLoop p hp e)
+
+private def ThirdHurewicz.nativeCubeOrderedDuffyHomotopy {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) (f : C(NativeCube, NativeCube))
+    (e : Equiv.Perm (Fin 3)) (hf : ∀ u ∈ Cube.boundary (Fin 3), p (f u) = x)
+    (hfg : ∀ u ∈ Cube.boundary (Fin 3), NativeCubeSameFlat (f u) (nativeOrderedDuffyMap e u)) :
+    (nativeCubePullbackLoop p f hf).val.HomotopyRel
+      (permuteCubeLoop (nativeDuffyCubeLoop p hp e) e).val (Cube.boundary (Fin 3)) :=
+  nativeCubeLinearHomotopy p hp f (nativeOrderedDuffyMap e) hf
+    (fun u hu => nativeDuffyCube_based p hp e _ (permuteCubeCoordinates_boundary e u hu)) hfg
+
+private theorem
+    ThirdHurewicz.nativeCubeClass_commonOrderedDuffy {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) (f : C(NativeCube, NativeCube))
+    (e : Equiv.Perm (Fin 3)) (hf : ∀ u ∈ Cube.boundary (Fin 3), p (f u) = x)
+    (hfg : ∀ u ∈ Cube.boundary (Fin 3), NativeCubeSameFlat (f u) (nativeOrderedDuffyMap e u)) :
+    nativeCubeClass (nativeCubePullbackLoop p f hf) =
+      ((Equiv.Perm.sign e : ℤˣ) : ℤ) • nativeCubeClass (nativeDuffyCubeLoop p hp e) :=
+  (nativeCubeClass_homotopic ⟨nativeCubeOrderedDuffyHomotopy p hp f e hf hfg⟩).trans
+    (permuteCubeLoop_additiveClass (nativeDuffyCubeLoop p hp e) e)
+
+private theorem
+    ThirdHurewicz.nativeCubeClass_commonOrderedTetrahedron {Y : Type} [TopologicalSpace Y]
+    {y : Y} (p : GenLoop (Fin 3) Y y) (hp : NativeCubeInternalBased p)
+    (f : C(NativeCube, NativeCube)) (e : Equiv.Perm (Fin 3))
+    (hf : ∀ u ∈ Cube.boundary (Fin 3), p (f u) = y)
+    (hfg : ∀ u ∈ Cube.boundary (Fin 3), NativeCubeSameFlat (f u) (nativeOrderedDuffyMap e u)) :
+    nativeCubeClass (nativeCubePullbackLoop p f hf) =
+      Geometry.cubeOrientation e • basedThreeSimplexClass (nativeBasedCubeTetrahedron p hp e) := by
+  simpa only [nativeDuffyCubeClass_eq_basedThreeSimplexClass, Geometry.cubeOrientation] using
+    nativeCubeClass_commonOrderedDuffy p hp f e hf hfg
+
+private theorem ThirdHurewicz.nativeLowerPrismMap_based {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) (u : NativeCube)
+    (hu : u ∈ Cube.boundary (Fin 3)) : p (nativeLowerPrismMap u) = x := by
+  rcases hu with ⟨i, hi | hi⟩
+  · fin_cases i
+    · change u 0 = 0 at hi
+      exact p.property _ ⟨0, Or.inl (by simp [nativeLowerPrismMap, hi])⟩
+    · change u 1 = 0 at hi
+      exact p.property _ ⟨1, Or.inl (by simp [nativeLowerPrismMap, hi])⟩
+    · change u 2 = 0 at hi
+      exact p.property _ ⟨2, Or.inl (by simp [nativeLowerPrismMap, hi])⟩
+  · fin_cases i
+    · change u 0 = 1 at hi
+      exact p.property _ ⟨0, Or.inr (by simp [nativeLowerPrismMap, hi])⟩
+    · change u 1 = 1 at hi
+      exact hp _ 0 1 (by decide) (by simp [nativeLowerPrismMap, hi])
+    · change u 2 = 1 at hi
+      exact p.property _ ⟨2, Or.inr (by simp [nativeLowerPrismMap, hi])⟩
+
+private theorem ThirdHurewicz.nativeUpperPrismMap_based {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) (u : NativeCube)
+    (hu : u ∈ Cube.boundary (Fin 3)) : p (nativeUpperPrismMap u) = x := by
+  rcases hu with ⟨i, hi | hi⟩
+  · fin_cases i
+    · change u 0 = 0 at hi
+      exact p.property _ ⟨0, Or.inl (by simp [nativeUpperPrismMap, hi])⟩
+    · change u 1 = 0 at hi
+      exact hp _ 0 1 (by decide) (by simp [nativeUpperPrismMap, hi])
+    · change u 2 = 0 at hi
+      exact p.property _ ⟨2, Or.inl (by simp [nativeUpperPrismMap, hi])⟩
+  · fin_cases i
+    · change u 0 = 1 at hi
+      exact p.property _ ⟨0, Or.inr (by simp [nativeUpperPrismMap, hi])⟩
+    · change u 1 = 1 at hi
+      exact p.property _ ⟨1, Or.inr (by simp [nativeUpperPrismMap, hi])⟩
+    · change u 2 = 1 at hi
+      exact p.property _ ⟨2, Or.inr (by simp [nativeUpperPrismMap, hi])⟩
+
+private def ThirdHurewicz.nativeLowerPrismLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) : GenLoop (Fin 3) X x :=
+  nativeCubePullbackLoop p nativeLowerPrismMap (nativeLowerPrismMap_based p hp)
+
+private def ThirdHurewicz.nativeUpperPrismLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) : GenLoop (Fin 3) X x :=
+  nativeCubePullbackLoop p nativeUpperPrismMap (nativeUpperPrismMap_based p hp)
+
+private def ThirdHurewicz.nativeMiddleChamberLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) : GenLoop (Fin 3) X x :=
+  nativeCubePullbackLoop p nativeMiddleChamberMap
+    (nativeCubeMap_based_of_commonLeft p hp nativeMiddleChamber_flats)
+
+private def ThirdHurewicz.nativeHighChamberLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) : GenLoop (Fin 3) X x :=
+  nativeCubePullbackLoop p nativeHighChamberMap
+    (nativeCubeMap_based_of_commonLeft p hp nativeHighChamber_flats)
+
+private def ThirdHurewicz.nativeUpperLowChamberLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) : GenLoop (Fin 3) X x :=
+  nativeCubePullbackLoop p nativeUpperLowChamberMap
+    (nativeCubeMap_based_of_commonLeft p hp nativeUpperLowChamber_flats)
+
+private def ThirdHurewicz.nativeUpperMiddleChamberLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) : GenLoop (Fin 3) X x :=
+  nativeCubePullbackLoop p nativeUpperMiddleChamberMap
+    (nativeCubeMap_based_of_commonLeft p hp nativeUpperMiddleChamber_flats)
+
+private def ThirdHurewicz.nativeUpperHighChamberLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) : GenLoop (Fin 3) X x :=
+  nativeCubePullbackLoop p nativeUpperHighChamberMap
+    (nativeCubeMap_based_of_commonLeft p hp nativeUpperHighChamber_flats)
+
+private def ThirdHurewicz.nativeCubeRecoveryPermutation : Fin 6 → Equiv.Perm (Fin 3) :=
+  Geometry.cubePermutation ∘ Equiv.swap 2 3
+
+private theorem ThirdHurewicz.nativeCubeRecoveryPermutation_apply (i : Fin 6) :
+    nativeCubeRecoveryPermutation i =
+      ![1, Equiv.swap 1 2, nativeCubeCycle201, Equiv.swap 0 1, nativeCubeCycle120, Equiv.swap 0 2]
+        i := by fin_cases i <;> rfl
+
+private theorem ThirdHurewicz.nativeCubeRecoveryPermutation_bijective :
+    Function.Bijective nativeCubeRecoveryPermutation :=
+  Geometry.cubePermutation_bijective.comp (Equiv.swap 2 3).bijective
+
+@[simp]
+private theorem ThirdHurewicz.cubeOrientation_nativeCubeCycle120 :
+    Geometry.cubeOrientation nativeCubeCycle120 = 1 := by
+  simp [Geometry.cubeOrientation, nativeCubeCycle120, Equiv.Perm.sign_swap']
+
+@[simp]
+private theorem ThirdHurewicz.cubeOrientation_nativeCubeCycle201 :
+    Geometry.cubeOrientation nativeCubeCycle201 = 1 := by
+  simp [Geometry.cubeOrientation, nativeCubeCycle201, Equiv.Perm.sign_swap']
+
+private theorem ThirdHurewicz.sum_nativeCubeRecoveryPermutations {A : Type*} [AddCommMonoid A]
+    (F : Equiv.Perm (Fin 3) → A) :
+    ∑ e, F e =
+      F 1 + F (Equiv.swap 1 2) + F nativeCubeCycle201 + F (Equiv.swap 0 1) +
+          F nativeCubeCycle120 +
+        F (Equiv.swap 0 2) := by
+  rw [← nativeCubeRecoveryPermutation_bijective.sum_comp F]
+  simp [nativeCubeRecoveryPermutation_apply, Fin.sum_univ_succ, add_assoc]
+
+private theorem
+    ThirdHurewicz.sum_oriented_nativeCubeRecoveryPermutations {A : Type*} [AddCommGroup A]
+    (F : Equiv.Perm (Fin 3) → A) :
+    ∑ e, Geometry.cubeOrientation e • F e =
+      F 1 - F (Equiv.swap 1 2) + F nativeCubeCycle201 - F (Equiv.swap 0 1) +
+          F nativeCubeCycle120 -
+        F (Equiv.swap 0 2) := by
+  rw [sum_nativeCubeRecoveryPermutations]
+  simp [Geometry.cubeOrientation, nativeCubeCycle120, nativeCubeCycle201, Equiv.Perm.sign_swap',
+    sub_eq_add_neg]
+
+private theorem ThirdHurewicz.nativeMiddleChamberLoop_class {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    nativeCubeClass (nativeMiddleChamberLoop p hp) =
+      -basedThreeSimplexClass (nativeBasedCubeTetrahedron p hp (Equiv.swap 1 2)) := by
+  simpa [nativeMiddleChamberLoop, Geometry.cubeOrientation, Equiv.Perm.sign_swap'] using
+    nativeCubeClass_commonOrderedTetrahedron p hp nativeMiddleChamberMap (Equiv.swap 1 2)
+      (nativeCubeMap_based_of_commonLeft p hp nativeMiddleChamber_flats) nativeMiddleChamber_flats
+
+private theorem ThirdHurewicz.nativeHighChamberLoop_class {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    nativeCubeClass (nativeHighChamberLoop p hp) =
+      basedThreeSimplexClass (nativeBasedCubeTetrahedron p hp nativeCubeCycle201) := by
+  simpa [nativeHighChamberLoop] using
+    nativeCubeClass_commonOrderedTetrahedron p hp nativeHighChamberMap nativeCubeCycle201
+      (nativeCubeMap_based_of_commonLeft p hp nativeHighChamber_flats) nativeHighChamber_flats
+
+private theorem
+    ThirdHurewicz.nativeUpperLowChamberLoop_class {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    nativeCubeClass (nativeUpperLowChamberLoop p hp) =
+      -basedThreeSimplexClass (nativeBasedCubeTetrahedron p hp (Equiv.swap 0 1)) := by
+  simpa [nativeUpperLowChamberLoop, Geometry.cubeOrientation, Equiv.Perm.sign_swap'] using
+    nativeCubeClass_commonOrderedTetrahedron p hp nativeUpperLowChamberMap (Equiv.swap 0 1)
+      (nativeCubeMap_based_of_commonLeft p hp nativeUpperLowChamber_flats)
+      nativeUpperLowChamber_flats
+
+private theorem
+    ThirdHurewicz.nativeUpperMiddleChamberLoop_class {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    nativeCubeClass (nativeUpperMiddleChamberLoop p hp) =
+      basedThreeSimplexClass (nativeBasedCubeTetrahedron p hp nativeCubeCycle120) := by
+  simpa [nativeUpperMiddleChamberLoop] using
+    nativeCubeClass_commonOrderedTetrahedron p hp nativeUpperMiddleChamberMap nativeCubeCycle120
+      (nativeCubeMap_based_of_commonLeft p hp nativeUpperMiddleChamber_flats)
+      nativeUpperMiddleChamber_flats
+
+private theorem
+    ThirdHurewicz.nativeUpperHighChamberLoop_class {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    nativeCubeClass (nativeUpperHighChamberLoop p hp) =
+      -basedThreeSimplexClass (nativeBasedCubeTetrahedron p hp (Equiv.swap 0 2)) := by
+  simpa [nativeUpperHighChamberLoop, Geometry.cubeOrientation, Equiv.Perm.sign_swap'] using
+    nativeCubeClass_commonOrderedTetrahedron p hp nativeUpperHighChamberMap (Equiv.swap 0 2)
+      (nativeCubeMap_based_of_commonLeft p hp nativeUpperHighChamber_flats)
+      nativeUpperHighChamber_flats
+
+private def ThirdHurewicz.NativeCubeCutIndependent (i : Fin 3) (a : C(NativeCube, (unitInterval))) :
+    Prop :=
+  ∀ u v, a (Function.update u i v) = a u
+
+private def ThirdHurewicz.NativeCubeCutBased {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i : Fin 3) (a : C(NativeCube, (unitInterval))) : Prop :=
+  ∀ u, p (Function.update u i (a u)) = x
+
+private def ThirdHurewicz.nativeCubeCutLowerMap (i : Fin 3) (a : C(NativeCube, (unitInterval))) :
+    C(NativeCube, NativeCube)
+    where
+  toFun u := Function.update u i (a u * u i)
+  continuous_toFun :=
+    continuous_id.update i
+      (((continuous_subtype_val.comp a.continuous).mul
+            (continuous_subtype_val.comp (continuous_apply i))).subtype_mk
+        _)
+
+private def ThirdHurewicz.nativeCubeCutMiddleMap (i : Fin 3) (a b : C(NativeCube, (unitInterval))) :
+    C(NativeCube, NativeCube)
+    where
+  toFun u := Function.update u i (Set.Icc.convexComb (a u) (b u) (u i))
+  continuous_toFun :=
+    continuous_id.update i
+      (Set.Icc.continuous_convexComb_prod.comp
+        (a.continuous.prodMk (b.continuous.prodMk (continuous_apply i))))
+
+private def ThirdHurewicz.nativeCubeCutUpperMap (i : Fin 3) (b : C(NativeCube, (unitInterval))) :
+    C(NativeCube, NativeCube)
+    where
+  toFun u := Function.update u i (Set.Icc.convexComb (b u) 1 (u i))
+  continuous_toFun :=
+    continuous_id.update i
+      (Set.Icc.continuous_convexComb_prod.comp
+        (b.continuous.prodMk (continuous_const.prodMk (continuous_apply i))))
+
+private theorem ThirdHurewicz.nativeCubeCutLowerMap_based {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i : Fin 3) (a : C(NativeCube, (unitInterval)))
+    (ha : NativeCubeCutBased p i a) (u : NativeCube) (hu : u ∈ Cube.boundary (Fin 3)) :
+    p (nativeCubeCutLowerMap i a u) = x := by
+  rcases hu with ⟨j, hj⟩
+  by_cases hji : j = i
+  · subst j
+    rcases hj with hj | hj
+    · exact p.property _ ⟨i, Or.inl (by simp [nativeCubeCutLowerMap, hj])⟩
+    · simpa [nativeCubeCutLowerMap, hj] using ha u
+  · exact p.property _ ⟨j, by simpa [nativeCubeCutLowerMap, hji] using hj⟩
+
+private theorem ThirdHurewicz.nativeCubeCutMiddleMap_based {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i : Fin 3) (a b : C(NativeCube, (unitInterval)))
+    (ha : NativeCubeCutBased p i a) (hb : NativeCubeCutBased p i b) (u : NativeCube)
+    (hu : u ∈ Cube.boundary (Fin 3)) : p (nativeCubeCutMiddleMap i a b u) = x := by
+  rcases hu with ⟨j, hj⟩
+  by_cases hji : j = i
+  · subst j
+    rcases hj with hj | hj
+    · simpa [nativeCubeCutMiddleMap, hj] using ha u
+    · simpa [nativeCubeCutMiddleMap, hj] using hb u
+  · exact p.property _ ⟨j, by simpa [nativeCubeCutMiddleMap, hji] using hj⟩
+
+private theorem ThirdHurewicz.nativeCubeCutUpperMap_based {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i : Fin 3) (b : C(NativeCube, (unitInterval)))
+    (hb : NativeCubeCutBased p i b) (u : NativeCube) (hu : u ∈ Cube.boundary (Fin 3)) :
+    p (nativeCubeCutUpperMap i b u) = x := by
+  rcases hu with ⟨j, hj⟩
+  by_cases hji : j = i
+  · subst j
+    rcases hj with hj | hj
+    · simpa [nativeCubeCutUpperMap, hj] using hb u
+    · exact p.property _ ⟨i, Or.inr (by simp [nativeCubeCutUpperMap, hj])⟩
+  · exact p.property _ ⟨j, by simpa [nativeCubeCutUpperMap, hji] using hj⟩
+
+private def ThirdHurewicz.nativeCubeCutLowerLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i : Fin 3) (a : C(NativeCube, (unitInterval)))
+    (ha : NativeCubeCutBased p i a) : GenLoop (Fin 3) X x :=
+  nativeCubePullbackLoop p (nativeCubeCutLowerMap i a) (nativeCubeCutLowerMap_based p i a ha)
+
+private def ThirdHurewicz.nativeCubeCutMiddleLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i : Fin 3) (a b : C(NativeCube, (unitInterval)))
+    (ha : NativeCubeCutBased p i a) (hb : NativeCubeCutBased p i b) : GenLoop (Fin 3) X x :=
+  nativeCubePullbackLoop p (nativeCubeCutMiddleMap i a b)
+    (nativeCubeCutMiddleMap_based p i a b ha hb)
+
+private def ThirdHurewicz.nativeCubeCutUpperLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i : Fin 3) (b : C(NativeCube, (unitInterval)))
+    (hb : NativeCubeCutBased p i b) : GenLoop (Fin 3) X x :=
+  nativeCubePullbackLoop p (nativeCubeCutUpperMap i b) (nativeCubeCutUpperMap_based p i b hb)
+
+@[simp]
+private theorem ThirdHurewicz.nativeCubeCutLowerLoop_apply {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i : Fin 3) (a : C(NativeCube, (unitInterval)))
+    (ha : NativeCubeCutBased p i a) (u : NativeCube) :
+    nativeCubeCutLowerLoop p i a ha u = p (Function.update u i (a u * u i)) :=
+  rfl
+
+@[simp]
+private theorem ThirdHurewicz.nativeCubeCutMiddleLoop_apply {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i : Fin 3) (a b : C(NativeCube, (unitInterval)))
+    (ha : NativeCubeCutBased p i a) (hb : NativeCubeCutBased p i b) (u : NativeCube) :
+    nativeCubeCutMiddleLoop p i a b ha hb u =
+      p (Function.update u i (Set.Icc.convexComb (a u) (b u) (u i))) :=
+  rfl
+
+@[simp]
+private theorem ThirdHurewicz.nativeCubeCutUpperLoop_apply {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i : Fin 3) (b : C(NativeCube, (unitInterval)))
+    (hb : NativeCubeCutBased p i b) (u : NativeCube) :
+    nativeCubeCutUpperLoop p i b hb u =
+      p (Function.update u i (Set.Icc.convexComb (b u) 1 (u i))) :=
+  rfl
+
+private def
+    ThirdHurewicz.nativeCubeCutCoordinateMap (i : Fin 3) (w : C(NativeCube, (unitInterval))) :
+    C(NativeCube, NativeCube)
+    where
+  toFun u := Function.update u i (w u)
+  continuous_toFun := continuous_id.update i w.continuous
+
+private theorem ThirdHurewicz.nativeCubeCutCoordinateMap_boundary (i : Fin 3)
+    (w : C(NativeCube, (unitInterval))) (hzero : ∀ u, u i = 0 → w u = 0)
+    (hone : ∀ u, u i = 1 → w u = 1) (u : NativeCube) (hu : u ∈ Cube.boundary (Fin 3)) :
+    nativeCubeCutCoordinateMap i w u ∈ Cube.boundary (Fin 3) := by
+  rcases hu with ⟨j, hj⟩
+  by_cases hji : j = i
+  · subst j
+    rcases hj with hj | hj
+    · exact ⟨i, Or.inl (by simp [nativeCubeCutCoordinateMap, hzero u hj])⟩
+    · exact ⟨i, Or.inr (by simp [nativeCubeCutCoordinateMap, hone u hj])⟩
+  · exact ⟨j, by simpa [nativeCubeCutCoordinateMap, hji] using hj⟩
+
+private def ThirdHurewicz.nativeCubeCutCoordinateLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i : Fin 3) (w : C(NativeCube, (unitInterval)))
+    (hzero : ∀ u, u i = 0 → w u = 0) (hone : ∀ u, u i = 1 → w u = 1) : GenLoop (Fin 3) X x :=
+  nativeCubePullbackLoop p (nativeCubeCutCoordinateMap i w)
+    (fun u hu => p.property _ (nativeCubeCutCoordinateMap_boundary i w hzero hone u hu))
+
+private def ThirdHurewicz.nativeCubeCutCoordinateHomotopy {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i : Fin 3) (w : C(NativeCube, (unitInterval)))
+    (hzero : ∀ u, u i = 0 → w u = 0) (hone : ∀ u, u i = 1 → w u = 1) :
+    p.val.HomotopyRel (nativeCubeCutCoordinateLoop p i w hzero hone).val (Cube.boundary (Fin 3))
+    where
+  toFun v := p (Function.update v.2 i (Set.Icc.convexComb (v.2 i) (w v.2) v.1))
+  continuous_toFun :=
+    p.val.continuous.comp
+      (continuous_snd.update i
+        (Set.Icc.continuous_convexComb_prod.comp
+          (((continuous_apply i).comp continuous_snd).prodMk
+            ((w.continuous.comp continuous_snd).prodMk continuous_fst))))
+  map_zero_left u := by simp
+  map_one_left
+    u := by
+    change
+      p (Function.update u i (Set.Icc.convexComb (u i) (w u) 1)) = p (Function.update u i (w u))
+    rw [Set.Icc.convexComb_one]
+  prop' t u
+    hu := by
+    rw [p.property u hu]
+    apply p.property
+    rcases hu with ⟨j, hj⟩
+    by_cases hji : j = i
+    · subst j
+      rcases hj with hj | hj
+      · exact ⟨i, Or.inl (by simp [hj, hzero u hj])⟩
+      · exact ⟨i, Or.inr (by simp [hj, hone u hj])⟩
+    · exact ⟨j, by simpa [hji] using hj⟩
+
+private def
+    ThirdHurewicz.nativeCubeCutTwoWarpCoordinate (i : Fin 3) (a : C(NativeCube, (unitInterval))) :
+    C(NativeCube, (unitInterval))
+    where
+  toFun u := SecondHurewicz.SimplyConnected.subdivisionWarpCoordinate (a u, u i)
+  continuous_toFun :=
+    SecondHurewicz.SimplyConnected.subdivisionWarpCoordinate.continuous.comp
+      (a.continuous.prodMk (continuous_apply i))
+
+private theorem ThirdHurewicz.nativeCubeCutTwoWarpCoordinate_zero (i : Fin 3)
+    (a : C(NativeCube, (unitInterval))) (u : NativeCube) (hu : u i = 0) :
+    nativeCubeCutTwoWarpCoordinate i a u = 0 := by simp [nativeCubeCutTwoWarpCoordinate, hu]
+
+private theorem ThirdHurewicz.nativeCubeCutTwoWarpCoordinate_one (i : Fin 3)
+    (a : C(NativeCube, (unitInterval))) (u : NativeCube) (hu : u i = 1) :
+    nativeCubeCutTwoWarpCoordinate i a u = 1 := by simp [nativeCubeCutTwoWarpCoordinate, hu]
+
+private def ThirdHurewicz.nativeCubeCutTwoWarpLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i : Fin 3) (a : C(NativeCube, (unitInterval))) :
+    GenLoop (Fin 3) X x :=
+  nativeCubeCutCoordinateLoop p i (nativeCubeCutTwoWarpCoordinate i a)
+    (nativeCubeCutTwoWarpCoordinate_zero i a) (nativeCubeCutTwoWarpCoordinate_one i a)
+
+private theorem
+    ThirdHurewicz.nativeCubeCutTwoWarpLoop_eq_transAt {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i : Fin 3) (a : C(NativeCube, (unitInterval)))
+    (ha : NativeCubeCutBased p i a) (haInd : NativeCubeCutIndependent i a) :
+    nativeCubeCutTwoWarpLoop p i a =
+      GenLoop.transAt i (nativeCubeCutLowerLoop p i a ha) (nativeCubeCutUpperLoop p i a ha) := by
+  apply GenLoop.ext
+  intro u
+  change
+    p
+        (Function.update u i
+          (SecondHurewicz.SimplyConnected.subdivisionWarpCoordinate (a u, u i))) =
+      if (u i : ℝ) ≤ 1 / 2 then
+        nativeCubeCutLowerLoop p i a ha
+          (Function.update u i (Set.projIcc 0 1 zero_le_one (2 * (u i : ℝ))))
+      else
+        nativeCubeCutUpperLoop p i a ha
+          (Function.update u i (Set.projIcc 0 1 zero_le_one (2 * (u i : ℝ) - 1)))
+  split_ifs with h
+  · rw [nativeCubeCutLowerLoop_apply, haInd u _, Function.update_self, Function.update_idem]
+    exact
+      congrArg (fun v => p (Function.update u i v))
+        (SecondHurewicz.SimplyConnected.subdivisionWarpCoordinate_of_le_half (a u) (u i) h)
+  · rw [nativeCubeCutUpperLoop_apply, haInd u _, Function.update_self, Function.update_idem]
+    exact
+      congrArg (fun v => p (Function.update u i v))
+        (SecondHurewicz.SimplyConnected.subdivisionWarpCoordinate_of_half_lt (a u) (u i)
+          (lt_of_not_ge h))
+
+private theorem ThirdHurewicz.nativeCubeCutTwo_homotopic {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i : Fin 3) (a : C(NativeCube, (unitInterval)))
+    (ha : NativeCubeCutBased p i a) (haInd : NativeCubeCutIndependent i a) :
+    GenLoop.Homotopic p
+      (GenLoop.transAt i (nativeCubeCutLowerLoop p i a ha) (nativeCubeCutUpperLoop p i a ha)) := by
+  have h : GenLoop.Homotopic p (nativeCubeCutTwoWarpLoop p i a) :=
+    ⟨nativeCubeCutCoordinateHomotopy p i (nativeCubeCutTwoWarpCoordinate i a)
+        (nativeCubeCutTwoWarpCoordinate_zero i a) (nativeCubeCutTwoWarpCoordinate_one i a)⟩
+  rwa [nativeCubeCutTwoWarpLoop_eq_transAt p i a ha haInd] at h
+
+private theorem ThirdHurewicz.nativeCubeCutTwo_class {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i : Fin 3) (a : C(NativeCube, (unitInterval)))
+    (ha : NativeCubeCutBased p i a) (haInd : NativeCubeCutIndependent i a) :
+    nativeCubeClass p =
+      nativeCubeClass (nativeCubeCutLowerLoop p i a ha) +
+        nativeCubeClass (nativeCubeCutUpperLoop p i a ha) :=
+  (nativeCubeClass_homotopic (nativeCubeCutTwo_homotopic p i a ha haInd)).trans
+    (nativeCubeClass_transAt i _ _)
+
+private def ThirdHurewicz.subdivisionWarpThreeCoordinate :
+    C(((unitInterval) × (unitInterval)) × (unitInterval), (unitInterval))
+    where
+  toFun
+    p :=
+    Set.Icc.convexComb (p.1.1 * Set.projIcc 0 1 zero_le_one (4 * (p.2 : ℝ)))
+      (Set.Icc.convexComb p.1.2 1 (Set.projIcc 0 1 zero_le_one (2 * (p.2 : ℝ) - 1)))
+      (Set.projIcc 0 1 zero_le_one (4 * (p.2 : ℝ) - 1))
+  continuous_toFun := by
+    unfold Set.Icc.convexComb
+    fun_prop
+
+private theorem ThirdHurewicz.subdivisionWarpThreeCoordinate_apply (a b w : (unitInterval)) :
+    subdivisionWarpThreeCoordinate ((a, b), w) =
+      Set.Icc.convexComb (a * Set.projIcc 0 1 zero_le_one (4 * (w : ℝ)))
+        (Set.Icc.convexComb b 1 (Set.projIcc 0 1 zero_le_one (2 * (w : ℝ) - 1)))
+        (Set.projIcc 0 1 zero_le_one (4 * (w : ℝ) - 1)) :=
+  rfl
+
+@[simp]
+private theorem ThirdHurewicz.subdivisionWarpThreeCoordinate_zero (a b : (unitInterval)) :
+    subdivisionWarpThreeCoordinate ((a, b), 0) = 0 := by
+  norm_num [subdivisionWarpThreeCoordinate, Set.projIcc, Set.Icc.convexComb]
+
+@[simp]
+private theorem ThirdHurewicz.subdivisionWarpThreeCoordinate_one (a b : (unitInterval)) :
+    subdivisionWarpThreeCoordinate ((a, b), 1) = 1 := by
+  norm_num [subdivisionWarpThreeCoordinate, Set.projIcc, Set.Icc.convexComb]
+
+private theorem ThirdHurewicz.subdivisionWarpThreeCoordinate_of_le_quarter (a b w : (unitInterval))
+    (hw : (w : ℝ) ≤ 1 / 4) :
+    subdivisionWarpThreeCoordinate ((a, b), w) = a * Set.projIcc 0 1 zero_le_one (4 * (w : ℝ)) := by
+  have hz : Set.projIcc 0 1 zero_le_one (4 * (w : ℝ) - 1) = (0 : (unitInterval)) :=
+    Set.projIcc_of_le_left zero_le_one (by linarith)
+  rw [subdivisionWarpThreeCoordinate_apply, hz, Set.Icc.convexComb_zero]
+
+private theorem ThirdHurewicz.subdivisionWarpThreeCoordinate_of_quarter_le_of_le_half
+    (a b w : (unitInterval)) (hl : 1 / 4 ≤ (w : ℝ)) (hu : (w : ℝ) ≤ 1 / 2) :
+    subdivisionWarpThreeCoordinate ((a, b), w) =
+      Set.Icc.convexComb a b (Set.projIcc 0 1 zero_le_one (4 * (w : ℝ) - 1)) := by
+  have hone : Set.projIcc 0 1 zero_le_one (4 * (w : ℝ)) = (1 : (unitInterval)) :=
+    Set.projIcc_of_right_le zero_le_one (by linarith)
+  have hzero : Set.projIcc 0 1 zero_le_one (2 * (w : ℝ) - 1) = (0 : (unitInterval)) :=
+    Set.projIcc_of_le_left zero_le_one (by linarith)
+  rw [subdivisionWarpThreeCoordinate_apply, hone, hzero, mul_one, Set.Icc.convexComb_zero]
+
+private theorem ThirdHurewicz.subdivisionWarpThreeCoordinate_of_half_le (a b w : (unitInterval))
+    (hw : 1 / 2 ≤ (w : ℝ)) :
+    subdivisionWarpThreeCoordinate ((a, b), w) =
+      Set.Icc.convexComb b 1 (Set.projIcc 0 1 zero_le_one (2 * (w : ℝ) - 1)) := by
+  have hone : Set.projIcc 0 1 zero_le_one (4 * (w : ℝ) - 1) = (1 : (unitInterval)) :=
+    Set.projIcc_of_right_le zero_le_one (by linarith)
+  rw [subdivisionWarpThreeCoordinate_apply, hone, Set.Icc.convexComb_one]
+
+private theorem ThirdHurewicz.subdivisionWarpThreeCoordinate_of_half_lt (a b w : (unitInterval))
+    (hw : 1 / 2 < (w : ℝ)) :
+    subdivisionWarpThreeCoordinate ((a, b), w) =
+      Set.Icc.convexComb b 1 (Set.projIcc 0 1 zero_le_one (2 * (w : ℝ) - 1)) :=
+  subdivisionWarpThreeCoordinate_of_half_le a b w hw.le
+
+private theorem ThirdHurewicz.subdivisionWarpThree_clip_two_coe (w : (unitInterval))
+    (hw : (w : ℝ) ≤ 1 / 2) : (Set.projIcc 0 1 zero_le_one (2 * (w : ℝ)) : ℝ) = 2 * (w : ℝ) := by
+  have hmem : 2 * (w : ℝ) ∈ Set.Icc (0 : ℝ) 1 := ⟨by linarith [w.property.1], by linarith⟩
+  exact congrArg Subtype.val (Set.projIcc_of_mem zero_le_one hmem)
+
+private theorem ThirdHurewicz.subdivisionWarpThreeCoordinate_nested_lower (a b w : (unitInterval))
+    (hw : (w : ℝ) ≤ 1 / 2) (hi : (Set.projIcc 0 1 zero_le_one (2 * (w : ℝ)) : ℝ) ≤ 1 / 2) :
+    subdivisionWarpThreeCoordinate ((a, b), w) =
+      a * Set.projIcc 0 1 zero_le_one (2 * (Set.projIcc 0 1 zero_le_one (2 * (w : ℝ)) : ℝ)) := by
+  have hc := subdivisionWarpThree_clip_two_coe w hw
+  have hquarter : (w : ℝ) ≤ 1 / 4 := by rw [hc] at hi; linarith
+  have he : 2 * (Set.projIcc 0 1 zero_le_one (2 * (w : ℝ)) : ℝ) = 4 * (w : ℝ) := by rw [hc]; ring
+  rw [he]
+  exact subdivisionWarpThreeCoordinate_of_le_quarter a b w hquarter
+
+private theorem ThirdHurewicz.subdivisionWarpThreeCoordinate_nested_middle (a b w : (unitInterval))
+    (hw : (w : ℝ) ≤ 1 / 2) (hi : 1 / 2 < (Set.projIcc 0 1 zero_le_one (2 * (w : ℝ)) : ℝ)) :
+    subdivisionWarpThreeCoordinate ((a, b), w) =
+      Set.Icc.convexComb a b
+        (Set.projIcc 0 1 zero_le_one (2 * (Set.projIcc 0 1 zero_le_one (2 * (w : ℝ)) : ℝ) - 1)) :=
+  by
+  have hc := subdivisionWarpThree_clip_two_coe w hw
+  have hquarter : 1 / 4 ≤ (w : ℝ) := by rw [hc] at hi; linarith
+  have he : 2 * (Set.projIcc 0 1 zero_le_one (2 * (w : ℝ)) : ℝ) - 1 = 4 * (w : ℝ) - 1 := by
+    rw [hc]; ring
+  rw [he]
+  exact subdivisionWarpThreeCoordinate_of_quarter_le_of_le_half a b w hquarter hw
+
+private theorem ThirdHurewicz.subdivisionWarpThreeCoordinate_nested_upper (a b w : (unitInterval))
+    (hw : 1 / 2 < (w : ℝ)) :
+    subdivisionWarpThreeCoordinate ((a, b), w) =
+      Set.Icc.convexComb b 1 (Set.projIcc 0 1 zero_le_one (2 * (w : ℝ) - 1)) :=
+  subdivisionWarpThreeCoordinate_of_half_lt a b w hw
+
+private def ThirdHurewicz.nativeCubeCutThreeWarpCoordinate (i : Fin 3)
+    (a b : C(NativeCube, (unitInterval))) : C(NativeCube, (unitInterval))
+    where
+  toFun u := subdivisionWarpThreeCoordinate ((a u, b u), u i)
+  continuous_toFun :=
+    subdivisionWarpThreeCoordinate.continuous.comp
+      ((a.continuous.prodMk b.continuous).prodMk (continuous_apply i))
+
+private theorem ThirdHurewicz.nativeCubeCutThreeWarpCoordinate_zero (i : Fin 3)
+    (a b : C(NativeCube, (unitInterval))) (u : NativeCube) (hu : u i = 0) :
+    nativeCubeCutThreeWarpCoordinate i a b u = 0 := by simp [nativeCubeCutThreeWarpCoordinate, hu]
+
+private theorem ThirdHurewicz.nativeCubeCutThreeWarpCoordinate_one (i : Fin 3)
+    (a b : C(NativeCube, (unitInterval))) (u : NativeCube) (hu : u i = 1) :
+    nativeCubeCutThreeWarpCoordinate i a b u = 1 := by simp [nativeCubeCutThreeWarpCoordinate, hu]
+
+private def ThirdHurewicz.nativeCubeCutThreeWarpLoop {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i : Fin 3) (a b : C(NativeCube, (unitInterval))) :
+    GenLoop (Fin 3) X x :=
+  nativeCubeCutCoordinateLoop p i (nativeCubeCutThreeWarpCoordinate i a b)
+    (nativeCubeCutThreeWarpCoordinate_zero i a b) (nativeCubeCutThreeWarpCoordinate_one i a b)
+
+private theorem ThirdHurewicz.nativeCubeCutThreeWarpLoop_eq_transAt {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 3) X x) (i : Fin 3) (a b : C(NativeCube, (unitInterval)))
+    (ha : NativeCubeCutBased p i a) (hb : NativeCubeCutBased p i b)
+    (haInd : NativeCubeCutIndependent i a) (hbInd : NativeCubeCutIndependent i b) :
+    nativeCubeCutThreeWarpLoop p i a b =
+      GenLoop.transAt i
+        (GenLoop.transAt i (nativeCubeCutLowerLoop p i a ha)
+          (nativeCubeCutMiddleLoop p i a b ha hb))
+        (nativeCubeCutUpperLoop p i b hb) := by
+  apply GenLoop.ext
+  intro u
+  change
+    p (Function.update u i (subdivisionWarpThreeCoordinate ((a u, b u), u i))) =
+      if (u i : ℝ) ≤ 1 / 2 then
+        (GenLoop.transAt i (nativeCubeCutLowerLoop p i a ha)
+            (nativeCubeCutMiddleLoop p i a b ha hb))
+          (Function.update u i (Set.projIcc 0 1 zero_le_one (2 * (u i : ℝ))))
+      else
+        nativeCubeCutUpperLoop p i b hb
+          (Function.update u i (Set.projIcc 0 1 zero_le_one (2 * (u i : ℝ) - 1)))
+  split_ifs with h
+  · change
+      p (Function.update u i (subdivisionWarpThreeCoordinate ((a u, b u), u i))) =
+        if
+            ((Function.update u i (Set.projIcc 0 1 zero_le_one (2 * (u i : ℝ)))) i : ℝ) ≤
+              1 / 2 then
+          nativeCubeCutLowerLoop p i a ha
+            (Function.update (Function.update u i (Set.projIcc 0 1 zero_le_one (2 * (u i : ℝ)))) i
+              (Set.projIcc 0 1 zero_le_one
+                (2 *
+                  ((Function.update u i (Set.projIcc 0 1 zero_le_one (2 * (u i : ℝ)))) i : ℝ))))
+        else
+          nativeCubeCutMiddleLoop p i a b ha hb
+            (Function.update (Function.update u i (Set.projIcc 0 1 zero_le_one (2 * (u i : ℝ)))) i
+              (Set.projIcc 0 1 zero_le_one
+                (2 * ((Function.update u i (Set.projIcc 0 1 zero_le_one (2 * (u i : ℝ)))) i : ℝ) -
+                  1)))
+    simp only [Function.update_self]
+    split_ifs with hi
+    · simp only [nativeCubeCutLowerLoop_apply, Function.update_self, Function.update_idem]
+      rw [haInd u _]
+      exact
+        congrArg (fun v => p (Function.update u i v))
+          (subdivisionWarpThreeCoordinate_nested_lower (a u) (b u) (u i) h hi)
+    · simp only [nativeCubeCutMiddleLoop_apply, Function.update_self, Function.update_idem]
+      rw [haInd u _, hbInd u _]
+      exact
+        congrArg (fun v => p (Function.update u i v))
+          (subdivisionWarpThreeCoordinate_nested_middle (a u) (b u) (u i) h (lt_of_not_ge hi))
+  · rw [nativeCubeCutUpperLoop_apply, hbInd u _, Function.update_self, Function.update_idem]
+    exact
+      congrArg (fun v => p (Function.update u i v))
+        (subdivisionWarpThreeCoordinate_nested_upper (a u) (b u) (u i) (lt_of_not_ge h))
+
+private theorem ThirdHurewicz.nativeCubeCutThree_homotopic {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i : Fin 3) (a b : C(NativeCube, (unitInterval)))
+    (ha : NativeCubeCutBased p i a) (hb : NativeCubeCutBased p i b)
+    (haInd : NativeCubeCutIndependent i a) (hbInd : NativeCubeCutIndependent i b) :
+    GenLoop.Homotopic p
+      (GenLoop.transAt i
+        (GenLoop.transAt i (nativeCubeCutLowerLoop p i a ha)
+          (nativeCubeCutMiddleLoop p i a b ha hb))
+        (nativeCubeCutUpperLoop p i b hb)) := by
+  have h : GenLoop.Homotopic p (nativeCubeCutThreeWarpLoop p i a b) :=
+    ⟨nativeCubeCutCoordinateHomotopy p i (nativeCubeCutThreeWarpCoordinate i a b)
+        (nativeCubeCutThreeWarpCoordinate_zero i a b)
+        (nativeCubeCutThreeWarpCoordinate_one i a b)⟩
+  rwa [nativeCubeCutThreeWarpLoop_eq_transAt p i a b ha hb haInd hbInd] at h
+
+private theorem ThirdHurewicz.nativeCubeCutThree_class {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (i : Fin 3) (a b : C(NativeCube, (unitInterval)))
+    (ha : NativeCubeCutBased p i a) (hb : NativeCubeCutBased p i b)
+    (haInd : NativeCubeCutIndependent i a) (hbInd : NativeCubeCutIndependent i b) :
+    nativeCubeClass p =
+      nativeCubeClass (nativeCubeCutLowerLoop p i a ha) +
+          nativeCubeClass (nativeCubeCutMiddleLoop p i a b ha hb) +
+        nativeCubeClass (nativeCubeCutUpperLoop p i b hb) := by
+  rw [nativeCubeClass_homotopic (nativeCubeCutThree_homotopic p i a b ha hb haInd hbInd),
+    nativeCubeClass_transAt, nativeCubeClass_transAt]
+
+private def ThirdHurewicz.nativePrismFirstCut : C(NativeCube, (unitInterval)) :=
+  ⟨fun u => u 0, continuous_apply 0⟩
+
+private def ThirdHurewicz.nativeLowerPrismCut : C(NativeCube, (unitInterval))
+    where
+  toFun u := u 0 * u 1
+  continuous_toFun := by fun_prop
+
+private def ThirdHurewicz.nativeUpperPrismCut : C(NativeCube, (unitInterval))
+    where
+  toFun u := Set.Icc.convexComb (u 0) 1 (u 1)
+  continuous_toFun := by fun_prop
+
+private theorem ThirdHurewicz.nativePrismFirstCut_independent (i : Fin 3) (hi : i ≠ 0) :
+    NativeCubeCutIndependent i nativePrismFirstCut := by
+  intro u v
+  simp [nativePrismFirstCut, hi.symm]
+
+private theorem ThirdHurewicz.nativeLowerPrismCut_independent :
+    NativeCubeCutIndependent 2 nativeLowerPrismCut := by
+  intro u v
+  simp [nativeLowerPrismCut]
+
+private theorem ThirdHurewicz.nativeUpperPrismCut_independent :
+    NativeCubeCutIndependent 2 nativeUpperPrismCut := by
+  intro u v
+  simp [nativeUpperPrismCut]
+
+public
+theorem ThirdHurewicz.nativeInterval_convexComb_mul (a b t : (unitInterval)) :
+    Set.Icc.convexComb (a * b) a t = a * Set.Icc.convexComb b 1 t := by
+  apply Subtype.ext
+  change
+    (1 - (t : ℝ)) * ((a : ℝ) * (b : ℝ)) + (t : ℝ) * (a : ℝ) =
+      (a : ℝ) * ((1 - (t : ℝ)) * (b : ℝ) + (t : ℝ) * 1)
+  ring
+
+private theorem ThirdHurewicz.nativePrismFirstCut_based {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    NativeCubeCutBased p 1 nativePrismFirstCut := by
+  intro u
+  exact hp _ 0 1 (by decide) (by simp [nativePrismFirstCut])
+
+private theorem ThirdHurewicz.nativeLowerPrismCut_based {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    NativeCubeCutBased (nativeLowerPrismLoop p hp) 2 nativeLowerPrismCut := by
+  intro u
+  change p (nativeLowerPrismMap (Function.update u 2 (u 0 * u 1))) = x
+  exact hp _ 1 2 (by decide) (by simp [nativeLowerPrismMap])
+
+private theorem
+    ThirdHurewicz.nativeLowerPrismFirstCut_based {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    NativeCubeCutBased (nativeLowerPrismLoop p hp) 2 nativePrismFirstCut := by
+  intro u
+  change p (nativeLowerPrismMap (Function.update u 2 (u 0))) = x
+  exact hp _ 0 2 (by decide) (by simp [nativeLowerPrismMap])
+
+private theorem
+    ThirdHurewicz.nativeUpperPrismFirstCut_based {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    NativeCubeCutBased (nativeUpperPrismLoop p hp) 2 nativePrismFirstCut := by
+  intro u
+  change p (nativeUpperPrismMap (Function.update u 2 (u 0))) = x
+  exact hp _ 0 2 (by decide) (by simp [nativeUpperPrismMap])
+
+private theorem ThirdHurewicz.nativeUpperPrismCut_based {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    NativeCubeCutBased (nativeUpperPrismLoop p hp) 2 nativeUpperPrismCut := by
+  intro u
+  change p (nativeUpperPrismMap (Function.update u 2 (Set.Icc.convexComb (u 0) 1 (u 1)))) = x
+  exact hp _ 1 2 (by decide) (by simp [nativeUpperPrismMap])
+
+private theorem ThirdHurewicz.nativeCubeCutLowerLoop_eq_lowerPrism {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    nativeCubeCutLowerLoop p 1 nativePrismFirstCut (nativePrismFirstCut_based p hp) =
+      nativeLowerPrismLoop p hp := by
+  apply GenLoop.ext
+  intro u
+  apply congrArg p
+  funext j
+  fin_cases j <;> rfl
+
+private theorem ThirdHurewicz.nativeCubeCutUpperLoop_eq_upperPrism {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    nativeCubeCutUpperLoop p 1 nativePrismFirstCut (nativePrismFirstCut_based p hp) =
+      nativeUpperPrismLoop p hp := by
+  apply GenLoop.ext
+  intro u
+  apply congrArg p
+  funext j
+  fin_cases j <;> rfl
+
+private theorem ThirdHurewicz.nativeCubeClass_prisms {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    nativeCubeClass p =
+      nativeCubeClass (nativeLowerPrismLoop p hp) + nativeCubeClass (nativeUpperPrismLoop p hp) :=
+  by
+  simpa only [nativeCubeCutLowerLoop_eq_lowerPrism p hp,
+    nativeCubeCutUpperLoop_eq_upperPrism p hp] using
+    nativeCubeCutTwo_class p 1 nativePrismFirstCut (nativePrismFirstCut_based p hp)
+      (nativePrismFirstCut_independent 1 (by decide))
+
+private theorem ThirdHurewicz.nativeLowerPrismCutLowerLoop_eq_duffy {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    nativeCubeCutLowerLoop (nativeLowerPrismLoop p hp) 2 nativeLowerPrismCut
+        (nativeLowerPrismCut_based p hp) =
+      nativeDuffyCubeLoop p hp 1 := by
+  apply GenLoop.ext
+  intro u
+  apply congrArg p
+  funext j
+  fin_cases j <;> rfl
+
+private theorem
+    ThirdHurewicz.nativeLowerPrismCutMiddleLoop_eq_middle {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    nativeCubeCutMiddleLoop (nativeLowerPrismLoop p hp) 2 nativeLowerPrismCut nativePrismFirstCut
+        (nativeLowerPrismCut_based p hp) (nativeLowerPrismFirstCut_based p hp) =
+      nativeMiddleChamberLoop p hp := by
+  apply GenLoop.ext
+  intro u
+  change
+    p ![u 0, u 0 * u 1, Set.Icc.convexComb (u 0 * u 1) (u 0) (u 2)] =
+      p ![u 0, u 0 * u 1, u 0 * Set.Icc.convexComb (u 1) 1 (u 2)]
+  rw [nativeInterval_convexComb_mul]
+
+private theorem ThirdHurewicz.nativeLowerPrismCutUpperLoop_eq_high {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    nativeCubeCutUpperLoop (nativeLowerPrismLoop p hp) 2 nativePrismFirstCut
+        (nativeLowerPrismFirstCut_based p hp) =
+      nativeHighChamberLoop p hp := by
+  apply GenLoop.ext
+  intro u
+  apply congrArg p
+  funext j
+  fin_cases j <;> rfl
+
+private theorem ThirdHurewicz.nativeLowerPrismClass_eq {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    nativeCubeClass (nativeLowerPrismLoop p hp) =
+      nativeCubeClass (nativeDuffyCubeLoop p hp 1) +
+          nativeCubeClass (nativeMiddleChamberLoop p hp) +
+        nativeCubeClass (nativeHighChamberLoop p hp) := by
+  simpa only [nativeLowerPrismCutLowerLoop_eq_duffy, nativeLowerPrismCutMiddleLoop_eq_middle,
+    nativeLowerPrismCutUpperLoop_eq_high] using
+    nativeCubeCutThree_class (nativeLowerPrismLoop p hp) 2 nativeLowerPrismCut nativePrismFirstCut
+      (nativeLowerPrismCut_based p hp) (nativeLowerPrismFirstCut_based p hp)
+      nativeLowerPrismCut_independent (nativePrismFirstCut_independent 2 (by decide))
+
+private theorem ThirdHurewicz.nativeUpperPrismCutLowerLoop_eq_lower {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    nativeCubeCutLowerLoop (nativeUpperPrismLoop p hp) 2 nativePrismFirstCut
+        (nativeUpperPrismFirstCut_based p hp) =
+      nativeUpperLowChamberLoop p hp := by
+  apply GenLoop.ext
+  intro u
+  apply congrArg p
+  funext j
+  fin_cases j <;> rfl
+
+private theorem
+    ThirdHurewicz.nativeUpperPrismCutMiddleLoop_eq_middle {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    nativeCubeCutMiddleLoop (nativeUpperPrismLoop p hp) 2 nativePrismFirstCut nativeUpperPrismCut
+        (nativeUpperPrismFirstCut_based p hp) (nativeUpperPrismCut_based p hp) =
+      nativeUpperMiddleChamberLoop p hp := by
+  apply GenLoop.ext
+  intro u
+  apply congrArg p
+  funext j
+  fin_cases j <;> rfl
+
+private theorem ThirdHurewicz.nativeUpperPrismCutUpperLoop_eq_upper {X : Type*} [TopologicalSpace X]
+    {x : X} (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    nativeCubeCutUpperLoop (nativeUpperPrismLoop p hp) 2 nativeUpperPrismCut
+        (nativeUpperPrismCut_based p hp) =
+      nativeUpperHighChamberLoop p hp := by
+  apply GenLoop.ext
+  intro u
+  apply congrArg p
+  funext j
+  fin_cases j <;> rfl
+
+private theorem ThirdHurewicz.nativeUpperPrismClass_eq {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    nativeCubeClass (nativeUpperPrismLoop p hp) =
+      nativeCubeClass (nativeUpperLowChamberLoop p hp) +
+          nativeCubeClass (nativeUpperMiddleChamberLoop p hp) +
+        nativeCubeClass (nativeUpperHighChamberLoop p hp) := by
+  simpa only [nativeUpperPrismCutLowerLoop_eq_lower, nativeUpperPrismCutMiddleLoop_eq_middle,
+    nativeUpperPrismCutUpperLoop_eq_upper] using
+    nativeCubeCutThree_class (nativeUpperPrismLoop p hp) 2 nativePrismFirstCut nativeUpperPrismCut
+      (nativeUpperPrismFirstCut_based p hp) (nativeUpperPrismCut_based p hp)
+      (nativePrismFirstCut_independent 2 (by decide)) nativeUpperPrismCut_independent
+
+private theorem
+    ThirdHurewicz.nativeCubeClass_eq_sum_tetrahedra {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    nativeCubeClass p =
+      ∑ e : Equiv.Perm (Fin 3),
+        Geometry.cubeOrientation e • basedThreeSimplexClass (nativeBasedCubeTetrahedron p hp e) :=
+  by
+  rw [sum_oriented_nativeCubeRecoveryPermutations, nativeCubeClass_prisms p hp,
+    nativeLowerPrismClass_eq, nativeUpperPrismClass_eq,
+    nativeDuffyCubeClass_eq_basedThreeSimplexClass, nativeMiddleChamberLoop_class,
+    nativeHighChamberLoop_class, nativeUpperLowChamberLoop_class,
+    nativeUpperMiddleChamberLoop_class, nativeUpperHighChamberLoop_class]
+  simp only [sub_eq_add_neg, add_assoc]
+
+private theorem ThirdHurewicz.nativeCubeSubdivision_class {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 3) X x) (hp : NativeCubeInternalBased p) :
+    Additive.ofMul (⟦p⟧ : π_ 3 X x) =
+      ∑ e : Equiv.Perm (Fin 3),
+        Geometry.cubeOrientation e • basedThreeSimplexClass (nativeBasedCubeTetrahedron p hp e) :=
+  nativeCubeClass_eq_sum_tetrahedra p hp
+
+private theorem
+    ThirdHurewicz.nativeCubeSubdivision_homotopy_class {X : Type} [TopologicalSpace X] {x : X}
+    (p q : GenLoop (Fin 3) X x) (H : p.val.HomotopyRel q.val (Cube.boundary (Fin 3)))
+    (hq : NativeCubeInternalBased q) :
+    nativeCubeClass p =
+      ∑ e : Equiv.Perm (Fin 3),
+        Geometry.cubeOrientation e • basedThreeSimplexClass (nativeBasedCubeTetrahedron q hq e) :=
+  (nativeCubeClass_homotopic ⟨H⟩).trans (nativeCubeClass_eq_sum_tetrahedra q hq)
+
+private theorem ThirdHurewicz.fourSimplexLoopA_class {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    nativeCubeClass (fourSimplexLoopA τ) =
+      basedThreeSimplexClass (basedFourSimplexFace τ 3) +
+        basedThreeSimplexClass (basedFourSimplexFace τ 1) :=
+  (nativeCubeSubdivision_class (fourSimplexLoopA τ) (fourSimplexLoopA_internal τ)).trans
+    (fourSimplexTetrahedraA_sum τ)
+
+private theorem ThirdHurewicz.fourSimplexLoopB_class {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    nativeCubeClass (fourSimplexLoopB τ) =
+      -(basedThreeSimplexClass (basedFourSimplexFace τ 4) +
+            basedThreeSimplexClass (basedFourSimplexFace τ 2) +
+          basedThreeSimplexClass (basedFourSimplexFace τ 0)) :=
+  (nativeCubeSubdivision_class (fourSimplexLoopB τ) (fourSimplexLoopB_internal τ)).trans
+    (fourSimplexTetrahedraB_sum τ)
+
+private theorem ThirdHurewicz.basedFourSimplex_pair_relation {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    basedThreeSimplexClass (basedFourSimplexFace τ 3) +
+        basedThreeSimplexClass (basedFourSimplexFace τ 1) =
+      basedThreeSimplexClass (basedFourSimplexFace τ 4) +
+          basedThreeSimplexClass (basedFourSimplexFace τ 2) +
+        basedThreeSimplexClass (basedFourSimplexFace τ 0) := by
+  have h := fourSimplexFillings_additiveClass τ
+  rw [fourSimplexLoopA_class, fourSimplexLoopB_class, neg_neg] at h
+  exact h
+
+private theorem
+    ThirdHurewicz.basedFourSimplex_boundary_relation {X : Type} [TopologicalSpace X] {x : X}
+    (τ : BasedFourSimplex x) :
+    basedThreeSimplexClass (basedFourSimplexFace τ 0) -
+              basedThreeSimplexClass (basedFourSimplexFace τ 1) +
+            basedThreeSimplexClass (basedFourSimplexFace τ 2) -
+          basedThreeSimplexClass (basedFourSimplexFace τ 3) +
+        basedThreeSimplexClass (basedFourSimplexFace τ 4) =
+      0 := by
+  calc
+    _ =
+        (basedThreeSimplexClass (basedFourSimplexFace τ 4) +
+              basedThreeSimplexClass (basedFourSimplexFace τ 2) +
+            basedThreeSimplexClass (basedFourSimplexFace τ 0)) -
+          (basedThreeSimplexClass (basedFourSimplexFace τ 3) +
+            basedThreeSimplexClass (basedFourSimplexFace τ 1)) := by abel
+    _ = 0 := sub_eq_zero.mpr (basedFourSimplex_pair_relation τ).symm
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Lattice/Core1.lean b/LeanPool/HopfProblem/Lattice/Core1.lean
new file mode 100644
index 000000000..c43268c96
--- /dev/null
+++ b/LeanPool/HopfProblem/Lattice/Core1.lean
@@ -0,0 +1,73 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Foundations.LineBundleTransport
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.Foundations.LineBundleTransport
+
+/-!
+# Hopf problem: lattice · core 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+/-- The rank-four integer lattice in coordinate form. -/
+public
+abbrev Lattice :=
+  Fin 4 → ℤ
+
+private def T₁ : LatticeMatrix :=
+  !![1, 0, -6, 2; 0, -1, 1, 1; 0, -1, 0, 1; 0, 0, 0, 1]
+
+private def T₂ : LatticeMatrix :=
+  !![1, 6, 0, -3; 0, 0, -1, 1; 0, 1, 0, 0; 0, 0, 0, 1]
+
+private def T₀ : LatticeMatrix :=
+  !![1, 0, 0, 1; 0, 1, -1, 0; 0, 0, 1, 0; 0, 0, 0, 1]
+
+private def A₁ : LatticeMatrix :=
+  !![1, 0, 0, 0; 6, 0, 1, 0; -6, -1, -1, 0; -2, 1, 0, 1]
+
+private def A₂ : LatticeMatrix :=
+  !![1, 0, 0, 0; 0, 0, -1, 0; -6, 1, 0, 0; 3, 0, 1, 1]
+
+private def M₀ : LatticeMatrix :=
+  !![1, 0, 0, 0; 0, 1, 0, 0; 0, 1, 1, 0; -1, 0, 0, 1]
+
+private def B₀ : Matrix (Fin 2) (Fin 2) ℤ :=
+  !![0, 1; -1, 0]
+
+private theorem T₁_cube : T₁ ^ 3 = 1 := by decide
+
+private theorem T₂_fourth : T₂ ^ 4 = 1 := by decide
+
+private theorem A₁_eq_transpose_sq : A₁ = (T₁ ^ 2).transpose := by decide
+
+private theorem A₂_eq_transpose_cube : A₂ = (T₂ ^ 3).transpose := by decide
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Lattice/Core2.lean b/LeanPool/HopfProblem/Lattice/Core2.lean
new file mode 100644
index 000000000..da457c2ca
--- /dev/null
+++ b/LeanPool/HopfProblem/Lattice/Core2.lean
@@ -0,0 +1,122 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+
+/-!
+# Hopf problem: lattice · core 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem A₁_fixes_ε : A₁ *ᵥ ε = ε := by decide
+
+private theorem A₂_fixes_ε' : A₂ *ᵥ ε' = ε' := by decide
+
+private theorem M₀_sub_one_mulVec (v : Lattice) : (M₀ - 1) *ᵥ v = ![0, 0, v 1, -v 0] := by
+  ext i
+  fin_cases i <;> simp [M₀, Matrix.mulVec, dotProduct, Fin.sum_univ_succ, Matrix.one_apply]
+
+private theorem M₀_sub_one_kernel (v : Lattice) : (M₀ - 1) *ᵥ v = 0 ↔ v 0 = 0 ∧ v 1 = 0 := by
+  rw [M₀_sub_one_mulVec]
+  constructor
+  · intro h
+    have h₂ := congrFun h 2
+    have h₃ := congrFun h 3
+    change v 1 = 0 at h₂
+    change -v 0 = 0 at h₃
+    exact ⟨neg_eq_zero.mp h₃, h₂⟩
+  · rintro ⟨h₀, h₁⟩
+    simp [h₀, h₁]
+
+private theorem
+    M₀_sub_one_range (v : Lattice) : (∃ w : Lattice, (M₀ - 1) *ᵥ w = v) ↔ v 0 = 0 ∧ v 1 = 0 :=
+  by
+  constructor
+  · rintro ⟨w, rfl⟩
+    simp [M₀_sub_one_mulVec]
+  · rintro ⟨h₀, h₁⟩
+    refine ⟨![-v 3, v 2, 0, 0], ?_⟩
+    rw [M₀_sub_one_mulVec]
+    ext i
+    fin_cases i <;> simp [h₀, h₁]
+
+private theorem A₁_fixed_iff (v : Lattice) : A₁ *ᵥ v = v ↔ v 1 = 2 * v 0 ∧ v 2 = -4 * v 0 := by
+  constructor
+  · intro h
+    have h₁ := congrFun h 1
+    have h₂ := congrFun h 2
+    have h₃ := congrFun h 3
+    simp [A₁, Matrix.mulVec, dotProduct, Fin.sum_univ_succ] at h₁ h₂ h₃
+    omega
+  · rintro ⟨h₁, h₂⟩
+    ext i
+    fin_cases i <;> simp [A₁, Matrix.mulVec, dotProduct, Fin.sum_univ_succ, h₁, h₂] <;> ring
+
+private theorem A₂_fixed_iff (v : Lattice) : A₂ *ᵥ v = v ↔ v 1 = 3 * v 0 ∧ v 2 = -3 * v 0 := by
+  constructor
+  · intro h
+    have h₁ := congrFun h 1
+    have h₂ := congrFun h 2
+    have h₃ := congrFun h 3
+    simp [A₂, Matrix.mulVec, dotProduct, Fin.sum_univ_succ] at h₁ h₂ h₃
+    omega
+  · rintro ⟨h₁, h₂⟩
+    ext i
+    fin_cases i <;> simp [A₂, Matrix.mulVec, dotProduct, Fin.sum_univ_succ, h₁, h₂]
+    ring
+
+/-- An integer coordinate vector of length `n`. -/
+public
+abbrev LocalSystemMatrices.Vec (n : ℕ) :=
+  Fin n → ℤ
+
+/-- The linear functional selecting the last coordinate of a rank-four vector. -/
+public
+def LocalSystemMatrices.lastCoordinate : Vec 4 →ₗ[ℤ] ℤ :=
+  LinearMap.proj 3
+
+/-- The two coordinate indices represented by an exterior-square basis element. -/
+public
+def LocalSystemMatrices.pairIndices : Fin 6 → Fin 2 → Fin 4 :=
+  ![![0, 1], ![0, 2], ![0, 3], ![1, 2], ![1, 3], ![2, 3] ]
+
+private def LocalSystemMatrices.exteriorSquare (T : LatticeMatrix) : Matrix (Fin 6) (Fin 6) ℤ :=
+  fun i j => (T.submatrix (pairIndices i) (pairIndices j)).det
+
+private def LocalSystemMatrices.tripleIndices : Fin 4 → Fin 3 → Fin 4 :=
+  ![![0, 1, 2], ![0, 1, 3], ![0, 2, 3], ![1, 2, 3] ]
+
+private def LocalSystemMatrices.exteriorCube (T : LatticeMatrix) : LatticeMatrix := fun i j =>
+  (T.submatrix (tripleIndices i) (tripleIndices j)).det
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/MainTheorem/Core1.lean b/LeanPool/HopfProblem/MainTheorem/Core1.lean
new file mode 100644
index 000000000..7f19f3bfe
--- /dev/null
+++ b/LeanPool/HopfProblem/MainTheorem/Core1.lean
@@ -0,0 +1,49 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Foundations.CanonicalProduct
+import all LeanPool.HopfProblem.Foundations.CanonicalProduct
+
+/-!
+# Hopf problem: main theorem · core 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+public
+theorem complexManifold_isRealManifold {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedSpace ℂ E] [IsScalarTower ℝ ℂ E] (M : Type*) [TopologicalSpace M] [ChartedSpace E M]
+    (n : ℕ∞ω) [IsManifold 𝓘(ℂ, E) n M] : IsManifold 𝓘(ℝ, E) n M := by
+  apply isManifold_of_contDiffOn 𝓘(ℝ, E) n M
+  intro e e' he he'
+  have h := (contDiffGroupoid n 𝓘(ℂ, E)).compatible he he'
+  have hc : ContDiffOn ℂ n (e.symm ≫ₕ e') (e.symm ≫ₕ e').source := by
+    simpa only [contDiffPregroupoid, mfld_simps] using h.1
+  simpa only [mfld_simps] using hc.restrict_scalars ℝ
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/MainTheorem/Core2.lean b/LeanPool/HopfProblem/MainTheorem/Core2.lean
new file mode 100644
index 000000000..a74a2610f
--- /dev/null
+++ b/LeanPool/HopfProblem/MainTheorem/Core2.lean
@@ -0,0 +1,43 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology4
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology4
+
+/-!
+# Hopf problem: main theorem · core 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+/-- The unit `n`-sphere in Euclidean `(n+1)`-space. -/
+public
+abbrev unitSphere (n : ℕ) :=
+  Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/MainTheorem/Core3.lean b/LeanPool/HopfProblem/MainTheorem/Core3.lean
new file mode 100644
index 000000000..685af9c88
--- /dev/null
+++ b/LeanPool/HopfProblem/MainTheorem/Core3.lean
@@ -0,0 +1,46 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Threefold.SixSphereComplexAtlas
+import all LeanPool.HopfProblem.MainTheorem.Core2
+import all LeanPool.HopfProblem.Threefold.SixSphereComplexAtlas
+
+/-!
+# Hopf problem: main theorem · core 3
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+public
+theorem mathoverflow_1973 :
+    ∃ atlas : ChartedSpace (EuclideanSpace ℂ (Fin 3)) (unitSphere 6),
+      letI := atlas
+      IsManifold 𝓘(ℂ, EuclideanSpace ℂ (Fin 3)) 1 (unitSphere 6) := by
+  exact SixSphereComplexAtlas.exists_complex_atlas
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/MainTheorem/SixSphereCube1.lean b/LeanPool/HopfProblem/MainTheorem/SixSphereCube1.lean
new file mode 100644
index 000000000..c4aa0988d
--- /dev/null
+++ b/LeanPool/HopfProblem/MainTheorem/SixSphereCube1.lean
@@ -0,0 +1,135 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.PeriodFamily.Core7
+import all LeanPool.HopfProblem.PeriodFamily.Core7
+
+/-!
+# Hopf problem: main theorem · six sphere cube 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+/-- The map collapsing a subset to the point at infinity of its complement. -/
+public
+def SixSphereCube.collapse {K : Type*} (F : Set K) (a : K) : OnePoint ↥Fᶜ := by
+  classical exact if h : a ∈ F then (OnePoint.infty) else ((⟨a, h⟩ : ↥Fᶜ) : OnePoint ↥Fᶜ)
+
+@[simp]
+private theorem SixSphereCube.collapse_of_mem {K : Type*} (F : Set K) {a : K} (ha : a ∈ F) :
+    collapse F a = (OnePoint.infty) := by classical simp only [collapse, dite_eq_left ha]
+
+private theorem SixSphereCube.collapse_of_not_mem {K : Type*} (F : Set K) {a : K} (ha : a ∉ F) :
+    collapse F a = ((⟨a, ha⟩ : ↥Fᶜ) : OnePoint ↥Fᶜ) := by
+  classical simp only [collapse, dite_eq_right ha]
+
+@[simp]
+private theorem SixSphereCube.collapse_coe {K : Type*} (F : Set K) (a : ↥Fᶜ) :
+    collapse F a.val = (a : OnePoint ↥Fᶜ) :=
+  collapse_of_not_mem F a.property
+
+@[simp]
+private theorem SixSphereCube.collapse_eq_infty_iff {K : Type*} (F : Set K) (a : K) :
+    collapse F a = (OnePoint.infty) ↔ a ∈ F := by
+  classical
+  by_cases ha : a ∈ F
+  · simp only [SixSphereCube.collapse_of_mem F ha, ha]
+  · simp only [collapse_of_not_mem F ha, OnePoint.coe_ne_infty, ha]
+
+public
+theorem SixSphereCube.collapse_eq_iff {K : Type*} (F : Set K) (a b : K) :
+    collapse F a = collapse F b ↔ a = b ∨ a ∈ F ∧ b ∈ F := by
+  classical
+  constructor
+  · intro h
+    by_cases ha : a ∈ F
+    · exact
+        Or.inr
+          ⟨ha, (collapse_eq_infty_iff F b).mp (h.symm.trans (SixSphereCube.collapse_of_mem F ha))⟩
+    · have hb : b ∉ F := fun hb =>
+        ha ((collapse_eq_infty_iff F a).mp (h.trans (SixSphereCube.collapse_of_mem F hb)))
+      rw [collapse_of_not_mem F ha, collapse_of_not_mem F hb] at h
+      exact Or.inl (congrArg Subtype.val (OnePoint.coe_injective h))
+  · rintro (rfl | ⟨ha, hb⟩)
+    · rfl
+    · rw [SixSphereCube.collapse_of_mem F ha, SixSphereCube.collapse_of_mem F hb]
+
+private theorem SixSphereCube.collapse_surjective {K : Type*} (F : Set K) (hne : F.Nonempty) :
+    Function.Surjective (collapse F) := by
+  intro z
+  induction z using OnePoint.rec with
+  | infty =>
+    obtain ⟨a, ha⟩ := hne
+    exact ⟨a, SixSphereCube.collapse_of_mem F ha⟩
+  | coe a => exact ⟨a.val, collapse_coe F a⟩
+
+private theorem SixSphereCube.collapse_preimage_of_not_mem {K : Type*} (F : Set K)
+    (s : Set (OnePoint ↥Fᶜ)) (hs : (OnePoint.infty) ∉ s) :
+    collapse F ⁻¹' s = Subtype.val '' (((↑) : ↥Fᶜ → OnePoint ↥Fᶜ) ⁻¹' s) := by
+  ext a
+  constructor
+  · intro ha
+    change collapse F a ∈ s at ha
+    have haF : a ∉ F := by
+      intro haF
+      exact hs (by simpa only [SixSphereCube.collapse_of_mem F haF] using ha)
+    exact ⟨⟨a, haF⟩, by simpa only [Set.mem_preimage, collapse_of_not_mem F haF] using ha, rfl⟩
+  · rintro ⟨b, hb, rfl⟩
+    simpa only [Set.mem_preimage, collapse_coe] using hb
+
+private theorem SixSphereCube.collapse_preimage_compl_of_mem {K : Type*} (F : Set K)
+    (s : Set (OnePoint ↥Fᶜ)) (hs : (OnePoint.infty) ∈ s) :
+    (collapse F ⁻¹' s)ᶜ = Subtype.val '' ((((↑) : ↥Fᶜ → OnePoint ↥Fᶜ) ⁻¹' s)ᶜ) :=
+  collapse_preimage_of_not_mem F sᶜ (fun h => h hs)
+
+private theorem
+    SixSphereCube.continuous_collapse {K : Type*} [TopologicalSpace K] [T2Space K] (F : Set K)
+    (hF : IsClosed F) : Continuous (collapse F) := by
+  classical
+  apply continuous_def.mpr
+  intro s hs
+  by_cases hinf : (OnePoint.infty) ∈ s
+  · apply isClosed_compl_iff.mp
+    rw [collapse_preimage_compl_of_mem F s hinf]
+    exact (((OnePoint.isOpen_def.mp hs).1 hinf).image continuous_subtype_val).isClosed
+  · rw [collapse_preimage_of_not_mem F s hinf]
+    exact hF.isOpen_compl.isOpenMap_subtype_val _ (OnePoint.isOpen_def.mp hs).2
+
+private def SixSphereCube.collapseMap {K : Type*} [TopologicalSpace K] [T2Space K] (F : Set K)
+    (hF : IsClosed F) : C(K, OnePoint ↥Fᶜ) :=
+  ⟨collapse F, continuous_collapse F hF⟩
+
+private theorem SixSphereCube.isQuotientMap_collapse {K : Type*} [TopologicalSpace K] [T2Space K]
+    (F : Set K) [CompactSpace K] (hF : IsClosed F) (hne : F.Nonempty) :
+    Topology.IsQuotientMap (collapse F) := by
+  let : LocallyCompactSpace ↥Fᶜ := hF.isOpen_compl.locallyCompactSpace
+  exact
+    Topology.IsQuotientMap.of_surjective_continuous (collapse_surjective F hne)
+      (continuous_collapse F hF)
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/MainTheorem/SixSphereCube2.lean b/LeanPool/HopfProblem/MainTheorem/SixSphereCube2.lean
new file mode 100644
index 000000000..762c30df0
--- /dev/null
+++ b/LeanPool/HopfProblem/MainTheorem/SixSphereCube2.lean
@@ -0,0 +1,51 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Hurewicz.HigherHurewicz2
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology1
+import all LeanPool.HopfProblem.Hurewicz.HigherHurewicz2
+
+/-!
+# Hopf problem: main theorem · six sphere cube 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+/-- The standard unit six-sphere. -/
+public
+abbrev SixSphereCube.StandardSphere :=
+  SphereHomology.UnitSphere 6
+
+private def SixSphereCube.euclideanOnePointSphereHomeomorph :
+    OnePoint (EuclideanSpace ℝ (Fin 6)) ≃ₜ StandardSphere :=
+  onePointEquivSphereOfFinrankEq (V := EuclideanSpace ℝ (Fin 6)) (ι := Fin 7) (by simp)
+
+private def SixSphereCube.sphereBasePoint : StandardSphere :=
+  euclideanOnePointSphereHomeomorph (OnePoint.infty)
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/MainTheorem/SixSphereCube3.lean b/LeanPool/HopfProblem/MainTheorem/SixSphereCube3.lean
new file mode 100644
index 000000000..5004acb34
--- /dev/null
+++ b/LeanPool/HopfProblem/MainTheorem/SixSphereCube3.lean
@@ -0,0 +1,296 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Hurewicz.SixthHurewicz
+public import LeanPool.HopfProblem.Recognition.Smale12
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology2
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology3
+import all LeanPool.HopfProblem.MainTheorem.SixSphereCube1
+import all LeanPool.HopfProblem.MainTheorem.SixSphereCube2
+import all LeanPool.HopfProblem.Recognition.Smale12
+import all LeanPool.HopfProblem.Hurewicz.SixthHurewicz
+
+/-!
+# Hopf problem: main theorem · six sphere cube 3
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private abbrev SixSphere :=
+  Metric.sphere (0 : EuclideanSpace ℝ (Fin 7)) 1
+
+private def SixSphereHomology.homologyZeroEquiv :
+    SingularMayerVietoris.SingularHomology SixSphere 0 ≃ₗ[ℤ] ℤ :=
+  SphereHomology.unitSphereHomologyZeroEquiv 5
+
+private def SixSphereHomology.homologySixEquiv :
+    SingularMayerVietoris.SingularHomology SixSphere 6 ≃ₗ[ℤ] ℤ :=
+  SphereHomology.unitSphereHomologyTopEquiv 5
+
+private theorem SixSphereHomology.homology_subsingleton (k : ℕ) (hk : k ≠ 0) (hk6 : k ≠ 6) :
+    Subsingleton (SingularMayerVietoris.SingularHomology SixSphere k) :=
+  SphereHomology.unitSphere_homology_subsingleton 5 k hk hk6
+
+private def
+    SixSphereCube.collapseLift {K X : Type*} [TopologicalSpace K] [CompactSpace K] [T2Space K]
+    [TopologicalSpace X] (F : Set K) (hF : IsClosed F) (hne : F.Nonempty) (f : C(K, X)) (x : X)
+    (hf : ∀ a ∈ F, f a = x) : C(OnePoint ↥Fᶜ, X) :=
+  Topology.IsQuotientMap.lift (f := collapseMap F hF) (isQuotientMap_collapse F hF hne) f
+    (by
+      intro a b h
+      rcases (collapse_eq_iff F a b).mp h with rfl | ⟨ha, hb⟩
+      · rfl
+      · exact (hf a ha).trans (hf b hb).symm)
+
+@[simp]
+private theorem SixSphereCube.collapseLift_comp {K X : Type*} [TopologicalSpace K] [CompactSpace K]
+    [T2Space K] [TopologicalSpace X] (F : Set K) (hF : IsClosed F) (hne : F.Nonempty)
+    (f : C(K, X)) (x : X) (hf : ∀ a ∈ F, f a = x) :
+    (collapseLift F hF hne f x hf).comp (collapseMap F hF) = f :=
+  Topology.IsQuotientMap.lift_comp (f := collapseMap F hF) (isQuotientMap_collapse F hF hne) f _
+
+@[simp]
+private theorem SixSphereCube.collapseLift_apply {K X : Type*} [TopologicalSpace K] [CompactSpace K]
+    [T2Space K] [TopologicalSpace X] (F : Set K) (hF : IsClosed F) (hne : F.Nonempty)
+    (f : C(K, X)) (x : X) (hf : ∀ a ∈ F, f a = x) (a : K) :
+    collapseLift F hF hne f x hf (collapse F a) = f a :=
+  ContinuousMap.congr_fun (collapseLift_comp F hF hne f x hf) a
+
+private abbrev SixSphereCube.OpenUnitInterval :=
+  Set.Ioo (0 : ℝ) 1
+
+private def SixSphereCube.openUnitIntervalAffineOrderIso : OpenUnitInterval ≃o Set.Ioo (-1 : ℝ) 1
+    where
+  toFun t := ⟨2 * (t : ℝ) - 1, by constructor <;> linarith [t.property.1, t.property.2]⟩
+  invFun t := ⟨((t : ℝ) + 1) / 2, by constructor <;> linarith [t.property.1, t.property.2]⟩
+  left_inv
+    t := by
+    apply Subtype.ext
+    change (2 * (t : ℝ) - 1 + 1) / 2 = (t : ℝ)
+    ring
+  right_inv
+    t := by
+    apply Subtype.ext
+    change 2 * (((t : ℝ) + 1) / 2) - 1 = (t : ℝ)
+    ring
+  map_rel_iff' := by
+    intro t s
+    change 2 * (t : ℝ) - 1 ≤ 2 * (s : ℝ) - 1 ↔ (t : ℝ) ≤ (s : ℝ)
+    constructor <;> intro h <;> linarith
+
+private def SixSphereCube.openUnitIntervalHomeomorph : OpenUnitInterval ≃ₜ ℝ :=
+  openUnitIntervalAffineOrderIso.toHomeomorph.trans (orderIsoIooNegOneOne ℝ).toHomeomorph.symm
+
+private abbrev SixSphereCube.CubeInteriorN (n : ℕ) :=
+  { u : Fin n → (unitInterval) // u ∉ Cube.boundary (Fin n) }
+
+private theorem SixSphereCube.not_mem_cubeBoundary_iff {n : ℕ} (u : Fin n → (unitInterval)) :
+    u ∉ Cube.boundary (Fin n) ↔ ∀ i, 0 < (u i : ℝ) ∧ (u i : ℝ) < 1 := by
+  simp only [Cube.boundary, Set.mem_ofPred_eq, not_exists, not_or, unitInterval.coe_pos,
+    unitInterval.coe_lt_one, unitInterval.pos_iff_ne_zero, unitInterval.lt_one_iff_ne_one]
+
+private theorem SixSphereCube.cubeBoundary_eq_iUnion (n : ℕ) :
+    Cube.boundary (Fin n) =
+      ⋃ i : Fin n,
+        {u : Fin n → (unitInterval) | u i = 0} ∪ {u : Fin n → (unitInterval) | u i = 1} := by
+  ext u
+  simp only [Cube.boundary, Set.mem_ofPred_eq, Set.mem_iUnion, Set.mem_union]
+
+private theorem
+    SixSphereCube.isClosed_cubeBoundaryN (n : ℕ) : IsClosed (Cube.boundary (Fin n)) := by
+  rw [cubeBoundary_eq_iUnion]
+  exact
+    isClosed_iUnion_of_finite fun i =>
+      (isClosed_eq (continuous_apply i) continuous_const).union
+        (isClosed_eq (continuous_apply i) continuous_const)
+
+private def
+    SixSphereCube.cubeInteriorCoordinates (n : ℕ) : CubeInteriorN n ≃ₜ (Fin n → OpenUnitInterval)
+    where
+  toFun u i := ⟨(u.val i : ℝ), (not_mem_cubeBoundary_iff u.val).mp u.property i⟩
+  invFun
+    v :=
+    ⟨fun i => ⟨(v i : ℝ), ⟨(v i).property.1.le, (v i).property.2.le⟩⟩,
+      (not_mem_cubeBoundary_iff _).mpr fun i => (v i).property⟩
+  left_inv
+    u := by
+    apply Subtype.ext
+    funext i
+    exact Subtype.ext rfl
+  right_inv
+    v := by
+    funext i
+    exact Subtype.ext rfl
+  continuous_toFun := by
+    refine continuous_pi fun i => ?_
+    have hi : Continuous (fun u : CubeInteriorN n => u.val i) :=
+      (continuous_apply i).comp continuous_subtype_val
+    exact (continuous_subtype_val.comp hi).subtype_mk _
+  continuous_invFun := by
+    refine Continuous.subtype_mk ?_ _
+    refine continuous_pi fun i => ?_
+    have hi : Continuous (fun v : Fin n → OpenUnitInterval => v i) := continuous_apply i
+    exact (continuous_subtype_val.comp hi).subtype_mk _
+
+private def SixSphereCube.cubeInteriorEuclideanHomeomorph (n : ℕ) :
+    CubeInteriorN n ≃ₜ EuclideanSpace ℝ (Fin n) :=
+  (cubeInteriorCoordinates n).trans
+    ((Homeomorph.piCongrRight fun _ : Fin n => openUnitIntervalHomeomorph).trans
+      (PiLp.homeomorph 2 (fun _ : Fin n => ℝ)).symm)
+
+private abbrev SixSphereCube.CubeInterior :=
+  CubeInteriorN 6
+
+private theorem SixSphereCube.isClosed_cubeBoundary : IsClosed (Cube.boundary (Fin 6)) :=
+  isClosed_cubeBoundaryN 6
+
+private abbrev SixSphereCube.cubeInteriorHomeomorph : CubeInterior ≃ₜ EuclideanSpace ℝ (Fin 6) :=
+  cubeInteriorEuclideanHomeomorph 6
+
+@[simp]
+public
+theorem SixSphereCube.zero_mem_cubeBoundary :
+    (0 : Fin 6 → (unitInterval)) ∈ Cube.boundary (Fin 6) :=
+  ⟨0, Or.inl rfl⟩
+
+private theorem SixSphereCube.cubeBoundary_nonempty : (Cube.boundary (Fin 6)).Nonempty :=
+  ⟨0, zero_mem_cubeBoundary⟩
+
+private def SixSphereCube.cubeInteriorSphereHomeomorph : OnePoint CubeInterior ≃ₜ StandardSphere :=
+  cubeInteriorHomeomorph.onePointCongr.trans euclideanOnePointSphereHomeomorph
+
+@[simp]
+private theorem SixSphereCube.cubeInteriorSphereHomeomorph_infty :
+    cubeInteriorSphereHomeomorph (OnePoint.infty) = sphereBasePoint :=
+  rfl
+
+private def SixSphereCube.cubeSphereMap : C(Fin 6 → (unitInterval), StandardSphere) :=
+  (cubeInteriorSphereHomeomorph : C(OnePoint CubeInterior, StandardSphere)).comp
+    (collapseMap (Cube.boundary (Fin 6)) isClosed_cubeBoundary)
+
+@[simp]
+private theorem SixSphereCube.cubeSphereMap_apply (u : Fin 6 → (unitInterval)) :
+    cubeSphereMap u = cubeInteriorSphereHomeomorph (collapse (Cube.boundary (Fin 6)) u) :=
+  rfl
+
+private theorem SixSphereCube.cubeSphereMap_boundary (u : Fin 6 → (unitInterval))
+    (hu : u ∈ Cube.boundary (Fin 6)) : cubeSphereMap u = sphereBasePoint := by
+  rw [cubeSphereMap_apply, SixSphereCube.collapse_of_mem _ hu, cubeInteriorSphereHomeomorph_infty]
+
+private theorem SixSphereCube.cubeSphereMap_eq_iff (u v : Fin 6 → (unitInterval)) :
+    cubeSphereMap u = cubeSphereMap v ↔
+      u = v ∨ u ∈ Cube.boundary (Fin 6) ∧ v ∈ Cube.boundary (Fin 6) := by
+  change
+    cubeInteriorSphereHomeomorph (collapse (Cube.boundary (Fin 6)) u) =
+        cubeInteriorSphereHomeomorph (collapse (Cube.boundary (Fin 6)) v) ↔
+      _
+  rw [cubeInteriorSphereHomeomorph.injective.eq_iff, collapse_eq_iff]
+
+private theorem SixSphereCube.cubeSphereMap_surjective : Function.Surjective cubeSphereMap :=
+  cubeInteriorSphereHomeomorph.surjective.comp
+    (collapse_surjective (Cube.boundary (Fin 6)) cubeBoundary_nonempty)
+
+private def SixSphereCube.cubeSphereLoop : GenLoop (Fin 6) StandardSphere sphereBasePoint :=
+  ⟨cubeSphereMap, cubeSphereMap_boundary⟩
+
+@[simp]
+private theorem SixSphereCube.cubeSphereLoop_val : cubeSphereLoop.val = cubeSphereMap :=
+  rfl
+
+private def
+    SixSphereCube.factorMap {X : Type*} [TopologicalSpace X] {x : X} (p : GenLoop (Fin 6) X x) :
+    C(StandardSphere, X) :=
+  (collapseLift (Cube.boundary (Fin 6)) isClosed_cubeBoundary cubeBoundary_nonempty p.val x
+        (fun u hu => p.property u hu)).comp
+    (cubeInteriorSphereHomeomorph.symm : C(StandardSphere, OnePoint CubeInterior))
+
+private theorem SixSphereCube.factorMap_cubeSphereMap {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 6) X x) (u : Fin 6 → (unitInterval)) :
+    factorMap p (cubeSphereMap u) = p u := by
+  change
+    collapseLift (Cube.boundary (Fin 6)) isClosed_cubeBoundary cubeBoundary_nonempty p.val x
+        (fun v hv => p.property v hv)
+        (cubeInteriorSphereHomeomorph.symm
+          (cubeInteriorSphereHomeomorph (collapse (Cube.boundary (Fin 6)) u))) =
+      p u
+  rw [cubeInteriorSphereHomeomorph.symm_apply_apply]
+  exact
+    collapseLift_apply (Cube.boundary (Fin 6)) isClosed_cubeBoundary cubeBoundary_nonempty p.val x
+      (fun v hv => p.property v hv) u
+
+@[simp]
+private theorem SixSphereCube.factorMap_comp_cubeSphereMap {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 6) X x) : (factorMap p).comp cubeSphereMap = p.val := by
+  ext u
+  exact factorMap_cubeSphereMap p u
+
+private theorem SixSphereCube.factorMap_unique {X : Type*} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 6) X x) (f : C(StandardSphere, X)) (hf : f.comp cubeSphereMap = p.val) :
+    f = factorMap p := by
+  ext z
+  obtain ⟨u, rfl⟩ := cubeSphereMap_surjective z
+  exact (ContinuousMap.congr_fun hf u).trans (factorMap_cubeSphereMap p u).symm
+
+private theorem SixSphereCube.factor_cubeChain {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 6) X x) :
+    FirstHurewicz.inducedChain (factorMap p) 6 (SixthHurewicz.cubeChain cubeSphereLoop) =
+      SixthHurewicz.cubeChain p := by
+  calc
+    _ =
+        FirstHurewicz.inducedChain ((factorMap p).comp cubeSphereMap) 6
+          SixthHurewicz.fundamentalCubeChain := by
+      rw [SixthHurewicz.cubeChain_eq_induced, cubeSphereLoop_val, FirstHurewicz.inducedChain_comp,
+        LinearMap.comp_apply]
+    _ = _ := by rw [factorMap_comp_cubeSphereMap, SixthHurewicz.cubeChain_eq_induced]
+
+private theorem SixSphereCube.factor_cubeCycle {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 6) X x) :
+    SingularMayerVietoris.ModuleHomology.mapCycles (FirstHurewicz.singularChainMap (factorMap p))
+        6 (SixthHurewicz.cubeCycle cubeSphereLoop) =
+      SixthHurewicz.cubeCycle p := by
+  apply Subtype.ext
+  rw [SingularMayerVietoris.ModuleHomology.mapCycles_val, SixthHurewicz.cubeCycle_val,
+    SixthHurewicz.cubeCycle_val]
+  exact factor_cubeChain p
+
+private theorem SixSphereCube.factor_cubeHomologyClass {X : Type} [TopologicalSpace X] {x : X}
+    (p : GenLoop (Fin 6) X x) :
+    SingularMayerVietoris.singularHomologyMap (factorMap p) 6
+        (SixthHurewicz.cubeHomologyClass cubeSphereLoop) =
+      SixthHurewicz.cubeHomologyClass p := by
+  change
+    (HomologicalComplex.homologyMap (FirstHurewicz.singularChainMap (factorMap p)) 6).hom
+        (SingularMayerVietoris.ModuleHomology.cycleClass
+          (FirstHurewicz.singularComplex StandardSphere) 6
+          (SixthHurewicz.cubeCycle cubeSphereLoop)) =
+      _
+  rw [SingularMayerVietoris.ModuleHomology.homologyMap_cycleClass, factor_cubeCycle]
+  rfl
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/PeriodFamily/Core1.lean b/LeanPool/HopfProblem/PeriodFamily/Core1.lean
new file mode 100644
index 000000000..f1348b1a3
--- /dev/null
+++ b/LeanPool/HopfProblem/PeriodFamily/Core1.lean
@@ -0,0 +1,266 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Uniformization.SpecialPeriods5
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods5
+
+/-!
+# Hopf problem: period family · core 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem PeriodPoint.discriminant_le_im_beta (p : PeriodPoint) (hτ : 0 < p.τ.im) :
+    p.discriminant ≤ p.β.im := by
+  exact sub_le_self _ (div_nonneg (mul_nonneg (by norm_num) (sq_nonneg _)) hτ.le)
+
+private theorem
+    PeriodPoint.discriminant_le_im_beta_add_tau_sub (p : PeriodPoint) (hτ : 0 < p.τ.im) :
+    p.discriminant ≤ (p.β + p.τ).im - p.τ.im := by
+  simpa only [Complex.add_im, add_sub_cancel_right] using p.discriminant_le_im_beta hτ
+
+private theorem
+    PeriodPoint.tendsto_discriminant_atBot {X : Type*} {l : Filter X} (P : X → PeriodPoint)
+    (hτ : ∀ᶠ z in l, 0 < (P z).τ.im) (hτinf : Filter.Tendsto (fun z => (P z).τ.im) l Filter.atTop)
+    (hb : ∃ C : ℝ, ∀ᶠ z in l, ((P z).β + (P z).τ).im ≤ C) :
+    Filter.Tendsto (fun z => (P z).discriminant) l Filter.atBot := by
+  obtain ⟨C, hC⟩ := hb
+  refine Filter.tendsto_atBot.mpr fun R => ?_
+  filter_upwards [hτ, hC, hτinf.eventually_ge_atTop (C - R)] with z hzτ hzC hzR
+  have hD := (P z).discriminant_le_im_beta_add_tau_sub hzτ
+  linarith
+
+private theorem PeriodPoint.continuousOn_discriminant {X : Type*} [TopologicalSpace X]
+    (P : X → PeriodPoint) {s : Set X} (hτ : ContinuousOn (fun z => (P z).τ) s)
+    (hμ : ContinuousOn (fun z => (P z).μ) s) (hβ : ContinuousOn (fun z => (P z).β) s)
+    (hτ₀ : ∀ z ∈ s, (P z).τ.im ≠ 0) : ContinuousOn (fun z => (P z).discriminant) s := by
+  exact
+    (Complex.continuous_im.comp_continuousOn hβ).sub
+      ((continuousOn_const.mul ((Complex.continuous_im.comp_continuousOn hμ).pow 2)).div
+        (Complex.continuous_im.comp_continuousOn hτ) hτ₀)
+
+private def PeriodPoint.shiftBeta (p : PeriodPoint) (c : ℂ) : PeriodPoint :=
+  ⟨p.τ, p.μ, p.β + c⟩
+
+@[simp]
+private theorem PeriodPoint.shiftBeta_discriminant (p : PeriodPoint) (c : ℂ) :
+    (p.shiftBeta c).discriminant = p.discriminant + c.im := by
+  simp only [discriminant, shiftBeta, Complex.add_im]
+  ring
+
+private theorem PeriodPoint.exists_uniform_shift_of_bddAbove {X : Type*} (P : X → PeriodPoint)
+    (hτ : ∀ z, 0 < (P z).τ.im) (hD : BddAbove (Set.range fun z => (P z).discriminant)) :
+    ∃ M : ℝ, 0 ≤ M ∧ ∀ c : ℂ, c.im < -M → ∀ z, ((P z).shiftBeta c).Admissible := by
+  obtain ⟨C, hC⟩ := hD
+  refine ⟨Max.max C 0, le_max_right _ _, fun c hc z => ⟨hτ z, ?_⟩⟩
+  rw [shiftBeta_discriminant]
+  have hDz : (P z).discriminant ≤ C := hC (Set.mem_range_self z)
+  have hCM : C ≤ Max.max C 0 := le_max_left _ _
+  linarith
+
+private theorem
+    PeriodPoint.exists_negative_imaginary_shift_of_bddAbove {X : Type*} (P : X → PeriodPoint)
+    (hτ : ∀ z, 0 < (P z).τ.im) (hD : BddAbove (Set.range fun z => (P z).discriminant)) :
+    ∃ M : ℝ, 0 < M ∧ ∀ z, ((P z).shiftBeta (-((M : ℂ) * Complex.I))).Admissible := by
+  obtain ⟨M, hM, hshift⟩ := exists_uniform_shift_of_bddAbove P hτ hD
+  refine ⟨M + 1, by linarith, hshift _ ?_⟩
+  simp only [Complex.neg_im, Complex.mul_im, Complex.ofReal_re, Complex.I_im, Complex.ofReal_im,
+    Complex.I_re, mul_one, MulZeroClass.mul_zero, add_zero]
+  linarith
+
+private def PeriodFamily.dualComplexMatrix (g : SpecialPeriods.TriangleGroup) :
+    Matrix (Fin 4) (Fin 4) ℂ :=
+  (SpecialPeriods.triangleDualRepresentation g : LatticeMatrix).map (Int.castRingHom ℂ)
+
+@[simp]
+private theorem PeriodFamily.dualComplexMatrix_one : dualComplexMatrix 1 = 1 := by
+  simp [dualComplexMatrix]
+
+private theorem PeriodFamily.dualComplexMatrix_mul (g h : SpecialPeriods.TriangleGroup) :
+    dualComplexMatrix (g * h) = dualComplexMatrix g * dualComplexMatrix h := by
+  simp only [dualComplexMatrix, map_mul, Matrix.SpecialLinearGroup.coe_mul]
+  exact Matrix.map_mul
+
+@[simp]
+private theorem PeriodFamily.dualComplexMatrix_generator₁ :
+    dualComplexMatrix SpecialPeriods.triangleGenerator₁ = A₁.map (Int.castRingHom ℂ) := by
+  rw [dualComplexMatrix, SpecialPeriods.triangleDualRepresentation_generator₁_matrix]
+
+@[simp]
+private theorem PeriodFamily.dualComplexMatrix_generator₂ :
+    dualComplexMatrix SpecialPeriods.triangleGenerator₂ = A₂.map (Int.castRingHom ℂ) := by
+  rw [dualComplexMatrix, SpecialPeriods.triangleDualRepresentation_generator₂_matrix]
+
+private def PeriodFamily.matrixRight (M : Matrix (Fin 2) (Fin 4) ℂ) : Matrix (Fin 2) (Fin 2) ℂ :=
+  fun i k => M i (![2, 3] k)
+
+private theorem PeriodFamily.periodMatrix_right (p : PeriodPoint) (R : Matrix (Fin 2) (Fin 2) ℂ) :
+    (fun i k => (R * p.matrix) i (![2, 3] k)) = R := by
+  ext i k
+  fin_cases i <;> fin_cases k <;> simp [PeriodPoint.matrix, Matrix.mul_apply, Fin.sum_univ_two]
+
+private structure PeriodFamily.Data (V B : Type*) [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [MulAction SpecialPeriods.TriangleGroup B] where
+  periods : HolomorphicPeriodMap V B
+  base_holomorphic :
+    ∀ g : SpecialPeriods.TriangleGroup,
+      ContMDiff (modelWithCornersSelf ℂ V) (modelWithCornersSelf ℂ V) ω (fun b : B => g • b)
+  covariance₁ :
+    ∀ b, periods.point (SpecialPeriods.triangleGenerator₁ • b) = (periods.point b).step₁
+  covariance₂ :
+    ∀ b, periods.point (SpecialPeriods.triangleGenerator₂ • b) = (periods.point b).step₂
+
+private def
+    PeriodFamily.Data.rightBlock {V : Type*} {B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [MulAction SpecialPeriods.TriangleGroup B]
+    (D : PeriodFamily.Data V B) (g : SpecialPeriods.TriangleGroup) (b : B) :
+    Matrix (Fin 2) (Fin 2) ℂ := fun i k =>
+  ((D.periods.point (g • b)).val.matrix * PeriodFamily.dualComplexMatrix g) i (![2, 3] k)
+
+private def PeriodFamily.Data.HasCovariance_mo1973_18367 {V : Type*} {B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (g : SpecialPeriods.TriangleGroup) : Prop :=
+  ∀ b : B,
+    ∃ R : Matrix (Fin 2) (Fin 2) ℂ,
+      (D.periods.point (g • b)).val.matrix * PeriodFamily.dualComplexMatrix g =
+        R * (D.periods.point b).val.matrix
+
+private theorem PeriodFamily.Data.hasCovariance_one_mo1973_18368 {V : Type*} {B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) :
+    D.HasCovariance_mo1973_18367 1 := by
+  intro b
+  exact ⟨1, by simp⟩
+
+private theorem PeriodFamily.Data.hasCovariance_mul_mo1973_18369 {V : Type*} {B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    {g h : SpecialPeriods.TriangleGroup} (hg : D.HasCovariance_mo1973_18367 g)
+    (hh : D.HasCovariance_mo1973_18367 h) : D.HasCovariance_mo1973_18367 (g * h) := by
+  intro b
+  obtain ⟨Rg, hg⟩ := hg (h • b)
+  obtain ⟨Rh, hh⟩ := hh b
+  refine ⟨Rg * Rh, ?_⟩
+  rw [SemigroupAction.mul_smul, PeriodFamily.dualComplexMatrix_mul, ← Matrix.mul_assoc, hg,
+    Matrix.mul_assoc, hh, Matrix.mul_assoc]
+
+private theorem PeriodFamily.Data.hasCovariance_generator₁_mo1973_18370 {V : Type*} {B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) :
+    D.HasCovariance_mo1973_18367 SpecialPeriods.triangleGenerator₁ := by
+  intro b
+  refine ⟨(D.periods.point b).val.R₁, ?_⟩
+  rw [D.covariance₁, PeriodFamily.dualComplexMatrix_generator₁]
+  change (D.periods.point b).val.step₁.matrix * A₁.map (Int.castRingHom ℂ) = _
+  rw [PeriodPoint.step₁_matrix _
+      ((D.periods.point b).val.τ_ne_zero (D.periods.point b).property.1),
+    Matrix.mul_assoc]
+  have h : (T₁.map (Int.castRingHom ℂ)).transpose * A₁.map (Int.castRingHom ℂ) = 1 := by
+    change T₁.transpose.map (Int.castRingHom ℂ) * A₁.map (Int.castRingHom ℂ) = 1
+    rw [← Matrix.map_mul, show T₁.transpose * A₁ = 1 by decide]
+    simp
+  rw [h, Matrix.mul_one]
+
+private theorem PeriodFamily.Data.hasCovariance_generator₂_mo1973_18371 {V : Type*} {B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) :
+    D.HasCovariance_mo1973_18367 SpecialPeriods.triangleGenerator₂ := by
+  intro b
+  refine ⟨(D.periods.point b).val.R₂, ?_⟩
+  rw [D.covariance₂, PeriodFamily.dualComplexMatrix_generator₂]
+  change (D.periods.point b).val.step₂.matrix * A₂.map (Int.castRingHom ℂ) = _
+  rw [PeriodPoint.step₂_matrix _
+      ((D.periods.point b).val.τ_ne_zero (D.periods.point b).property.1),
+    Matrix.mul_assoc]
+  have h : (T₂.map (Int.castRingHom ℂ)).transpose * A₂.map (Int.castRingHom ℂ) = 1 := by
+    change T₂.transpose.map (Int.castRingHom ℂ) * A₂.map (Int.castRingHom ℂ) = 1
+    rw [← Matrix.map_mul, show T₂.transpose * A₂ = 1 by decide]
+    simp
+  rw [h, Matrix.mul_one]
+
+private theorem PeriodFamily.Data.hasCovariance_pow_mo1973_18372 {V : Type*} {B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    {g : SpecialPeriods.TriangleGroup} (hg : D.HasCovariance_mo1973_18367 g) (n : ℕ) :
+    D.HasCovariance_mo1973_18367 (g ^ n) := by
+  induction n with
+  | zero => simpa using D.hasCovariance_one_mo1973_18368
+  | succ n ih => simpa only [pow_succ] using D.hasCovariance_mul_mo1973_18369 ih hg
+
+public
+theorem PeriodFamily.Data.cyclic_eq_generator_pow_mo1973_18373 {n : ℕ} [NeZero n]
+    (x : Multiplicative (ZMod n)) : x = Multiplicative.ofAdd (1 : ZMod n) ^ x.toAdd.val := by
+  change x.toAdd = x.toAdd.val • (1 : ZMod n)
+  simpa only [nsmul_eq_mul, mul_one] using (ZMod.natCast_zmod_val x.toAdd).symm
+
+private theorem PeriodFamily.Data.hasCovariance_mo1973_18374 {V : Type*} {B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (g : SpecialPeriods.TriangleGroup) : D.HasCovariance_mo1973_18367 g := by
+  induction g using Monoid.Coprod.induction_on with
+  | inl x =>
+    rw [cyclic_eq_generator_pow_mo1973_18373 x, map_pow]
+    exact D.hasCovariance_pow_mo1973_18372 D.hasCovariance_generator₁_mo1973_18370 _
+  | inr x =>
+    rw [cyclic_eq_generator_pow_mo1973_18373 x, map_pow]
+    exact D.hasCovariance_pow_mo1973_18372 D.hasCovariance_generator₂_mo1973_18371 _
+  | mul g h hg hh => exact D.hasCovariance_mul_mo1973_18369 hg hh
+
+private theorem PeriodFamily.Data.rightBlock_eq_of_covariance {V : Type*} {B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (g : SpecialPeriods.TriangleGroup) (b : B) (R : Matrix (Fin 2) (Fin 2) ℂ)
+    (hR :
+      (D.periods.point (g • b)).val.matrix * PeriodFamily.dualComplexMatrix g =
+        R * (D.periods.point b).val.matrix) :
+    D.rightBlock g b = R := by
+  unfold rightBlock
+  rw [hR, PeriodFamily.periodMatrix_right]
+
+private theorem PeriodFamily.Data.matrix_covariance {V : Type*} {B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (g : SpecialPeriods.TriangleGroup) (b : B) :
+    (D.periods.point (g • b)).val.matrix * PeriodFamily.dualComplexMatrix g =
+      D.rightBlock g b * (D.periods.point b).val.matrix := by
+  obtain ⟨R, hR⟩ := D.hasCovariance_mo1973_18374 g b
+  rw [D.rightBlock_eq_of_covariance g b R hR]
+  exact hR
+
+private abbrev PeriodFamily.Data.TotalSpace {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [MulAction SpecialPeriods.TriangleGroup B]
+    (D : PeriodFamily.Data V B) :=
+  D.periods.TotalSpace
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/PeriodFamily/Core2.lean b/LeanPool/HopfProblem/PeriodFamily/Core2.lean
new file mode 100644
index 000000000..5e15f60e9
--- /dev/null
+++ b/LeanPool/HopfProblem/PeriodFamily/Core2.lean
@@ -0,0 +1,538 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology8
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.PeriodFamily.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods6
+import all LeanPool.HopfProblem.Toric.DiagonalQuotient1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology8
+
+/-!
+# Hopf problem: period family · core 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+@[instance_reducible]
+private def PeriodFamily.Data.totalAction {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [MulAction SpecialPeriods.TriangleGroup B]
+    (D : PeriodFamily.Data V B) : MulAction SpecialPeriods.TriangleGroup D.TotalSpace := by
+  let := SpecialPeriods.triangleTorusAction
+  exact inferInstanceAs (MulAction SpecialPeriods.TriangleGroup (B × RealTorus₄))
+
+private theorem PeriodFamily.Data.totalAction_zeroSection {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (g : SpecialPeriods.TriangleGroup) (b : B) :
+    letI := D.totalAction
+    g • D.periods.zeroSection b = D.periods.zeroSection (g • b) := by
+  let := D.totalAction
+  change (g • b, SpecialPeriods.triangleTorusHomeomorph g 0) = (g • b, 0)
+  rw [SpecialPeriods.triangleTorusHomeomorph_zero]
+
+private theorem PeriodFamily.Data.periodEquiv_matrix {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) (b : B)
+    (x : RealPlane₄) :
+    D.periods.periodEquiv b x = (D.periods.point b).val.matrix *ᵥ (fun i => (x i : ℂ)) := by
+  rw [HolomorphicPeriodMap.periodEquiv_coordinates]
+  ext i
+  fin_cases i <;> simp [PeriodPoint.matrix, Matrix.mulVec, dotProduct, Fin.sum_univ_four]
+
+private theorem PeriodFamily.Data.realEquiv_complexCast (g : SpecialPeriods.TriangleGroup)
+    (x : RealPlane₄) :
+    (fun i => ((SpecialPeriods.triangleRealEquiv g x) i : ℂ)) =
+      PeriodFamily.dualComplexMatrix g *ᵥ (fun i => (x i : ℂ)) := by
+  ext i
+  simp [SpecialPeriods.triangleRealEquiv_apply, PeriodFamily.dualComplexMatrix, Matrix.mulVec,
+    dotProduct]
+
+private theorem PeriodFamily.Data.periodEquiv_monodromy {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (g : SpecialPeriods.TriangleGroup) (b : B) (x : RealPlane₄) :
+    D.periods.periodEquiv (g • b) (SpecialPeriods.triangleRealEquiv g x) =
+      D.rightBlock g b *ᵥ D.periods.periodEquiv b x := by
+  rw [D.periodEquiv_matrix, realEquiv_complexCast, Matrix.mulVec_mulVec, D.periodEquiv_matrix,
+    Matrix.mulVec_mulVec, D.matrix_covariance]
+
+private theorem PeriodFamily.Data.periodEquiv_symm_monodromy {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (g : SpecialPeriods.TriangleGroup) (b : B) (w : ComplexPlane₂) :
+    (D.periods.periodEquiv (g • b)).symm (D.rightBlock g b *ᵥ w) =
+      SpecialPeriods.triangleRealEquiv g ((D.periods.periodEquiv b).symm w) := by
+  apply (D.periods.periodEquiv (g • b)).injective
+  rw [LinearEquiv.apply_symm_apply, D.periodEquiv_monodromy, LinearEquiv.apply_symm_apply]
+
+private def PeriodFamily.Data.complexLift {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [MulAction SpecialPeriods.TriangleGroup B]
+    (D : PeriodFamily.Data V B) (g : SpecialPeriods.TriangleGroup) (x : B × ComplexPlane₂) :
+    B × ComplexPlane₂ :=
+  (g • x.1, D.rightBlock g x.1 *ᵥ x.2)
+
+private theorem PeriodFamily.Data.complexLift_quotientMap {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (g : SpecialPeriods.TriangleGroup) (x : B × ComplexPlane₂) :
+    letI := D.totalAction
+    D.periods.quotientMap (D.complexLift g x) = g • D.periods.quotientMap x := by
+  let := D.totalAction
+  change
+    (g • x.1,
+        standardLattice.mkQ
+          ((D.periods.periodEquiv (g • x.1)).symm (D.rightBlock g x.1 *ᵥ x.2))) =
+      (g • x.1,
+        SpecialPeriods.triangleTorusHomeomorph g
+          (standardLattice.mkQ ((D.periods.periodEquiv x.1).symm x.2)))
+  rw [D.periodEquiv_symm_monodromy, SpecialPeriods.triangleTorusHomeomorph_mkQ]
+
+/-- The product charted-space structure on the covering space of a period family. -/
+@[instance_reducible]
+public
+def PeriodFamily.Data.coveringChartedSpace {V B : Type*} [NormedAddCommGroup V]
+    [TopologicalSpace B] [ChartedSpace V B] :
+    ChartedSpace (V × ComplexPlane₂) (B × ComplexPlane₂) :=
+  inferInstanceAs (ChartedSpace (ModelProd V ComplexPlane₂) (B × ComplexPlane₂))
+
+attribute [local instance] PeriodFamily.Data.coveringChartedSpace in
+public
+theorem
+    PeriodFamily.Data.coveringManifold {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [IsManifold (modelWithCornersSelf ℂ V) ω B] :
+    IsManifold (modelWithCornersSelf ℂ (V × ComplexPlane₂)) ω (B × ComplexPlane₂) := by
+  rw [modelWithCornersSelf_prod]
+  exact
+    IsManifold.prod (I := modelWithCornersSelf ℂ V) (I' := modelWithCornersSelf ℂ ComplexPlane₂) B
+      ComplexPlane₂
+
+attribute [local instance] PeriodFamily.Data.coveringChartedSpace
+    PeriodFamily.Data.coveringManifold in
+private theorem
+    PeriodFamily.Data.periodMatrix_entry_holomorphic {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) (i : Fin 2)
+    (k : Fin 4) :
+    ContMDiff (modelWithCornersSelf ℂ V) (modelWithCornersSelf ℂ ℂ) ω
+      (fun b : B => (D.periods.point b).val.matrix i k) := by
+  fin_cases i
+  · fin_cases k
+    · exact contMDiff_const.mul D.periods.holomorphic_mu
+    · exact D.periods.holomorphic_tau
+    · exact contMDiff_const
+    · exact contMDiff_const
+  · fin_cases k
+    · exact D.periods.holomorphic_beta
+    · exact D.periods.holomorphic_mu
+    · exact contMDiff_const
+    · exact contMDiff_const
+
+attribute [local instance] PeriodFamily.Data.coveringChartedSpace
+    PeriodFamily.Data.coveringManifold in
+private theorem PeriodFamily.Data.rightBlock_entry_holomorphic {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (g : SpecialPeriods.TriangleGroup) (i k : Fin 2) :
+    ContMDiff (modelWithCornersSelf ℂ V) (modelWithCornersSelf ℂ ℂ) ω
+      (fun b : B => D.rightBlock g b i k) := by
+  have h₀ :=
+    ((D.periodMatrix_entry_holomorphic i 0).comp (D.base_holomorphic g)).mul
+      (contMDiff_const (c := PeriodFamily.dualComplexMatrix g 0 (![2, 3] k)))
+  have h₁ :=
+    ((D.periodMatrix_entry_holomorphic i 1).comp (D.base_holomorphic g)).mul
+      (contMDiff_const (c := PeriodFamily.dualComplexMatrix g 1 (![2, 3] k)))
+  have h₂ :=
+    ((D.periodMatrix_entry_holomorphic i 2).comp (D.base_holomorphic g)).mul
+      (contMDiff_const (c := PeriodFamily.dualComplexMatrix g 2 (![2, 3] k)))
+  have h₃ :=
+    ((D.periodMatrix_entry_holomorphic i 3).comp (D.base_holomorphic g)).mul
+      (contMDiff_const (c := PeriodFamily.dualComplexMatrix g 3 (![2, 3] k)))
+  convert ((h₀.add h₁).add h₂).add h₃ using 1
+  funext b
+  simp [rightBlock, Matrix.mul_apply, Fin.sum_univ_four, add_assoc, Function.comp_def]
+
+attribute [local instance] PeriodFamily.Data.coveringChartedSpace
+    PeriodFamily.Data.coveringManifold in
+private theorem PeriodFamily.Data.linearLift_holomorphic {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (g : SpecialPeriods.TriangleGroup) :
+    ContMDiff (modelWithCornersSelf ℂ (V × ComplexPlane₂)) (modelWithCornersSelf ℂ ComplexPlane₂)
+      ω (fun x : B × ComplexPlane₂ => D.rightBlock g x.1 *ᵥ x.2) := by
+  have hf :
+    ContMDiff (modelWithCornersSelf ℂ (V × ComplexPlane₂)) (modelWithCornersSelf ℂ V) ω
+      (Prod.fst : B × ComplexPlane₂ → B) := by
+    rw [modelWithCornersSelf_prod]
+    exact contMDiff_fst
+  have hs :
+    ContMDiff (modelWithCornersSelf ℂ (V × ComplexPlane₂)) (modelWithCornersSelf ℂ ComplexPlane₂)
+      ω (Prod.snd : B × ComplexPlane₂ → ComplexPlane₂) := by
+    rw [modelWithCornersSelf_prod]
+    exact contMDiff_snd
+  apply contMDiff_pi_space.mpr
+  intro i
+  have h₀ := ((D.rightBlock_entry_holomorphic g i 0).comp hf).mul ((contMDiff_pi_space.mp hs) 0)
+  have h₁ := ((D.rightBlock_entry_holomorphic g i 1).comp hf).mul ((contMDiff_pi_space.mp hs) 1)
+  convert h₀.add h₁ using 1
+  funext x
+  simp [Matrix.mulVec, dotProduct, Fin.sum_univ_two, Function.comp_def]
+
+attribute [local instance] PeriodFamily.Data.coveringChartedSpace
+    PeriodFamily.Data.coveringManifold in
+private theorem PeriodFamily.Data.complexLift_holomorphic {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (g : SpecialPeriods.TriangleGroup) :
+    ContMDiff (modelWithCornersSelf ℂ (V × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (V × ComplexPlane₂)) ω (D.complexLift g) := by
+  have hf :
+    ContMDiff (modelWithCornersSelf ℂ (V × ComplexPlane₂)) (modelWithCornersSelf ℂ V) ω
+      (fun x : B × ComplexPlane₂ => g • x.1) := by
+    rw [modelWithCornersSelf_prod]
+    exact (D.base_holomorphic g).comp contMDiff_fst
+  have hs := D.linearLift_holomorphic g
+  rw [modelWithCornersSelf_prod] at hf hs ⊢
+  exact hf.prodMk hs
+
+attribute [local instance] PeriodFamily.Data.coveringChartedSpace
+    PeriodFamily.Data.coveringManifold in
+private theorem PeriodFamily.Data.totalAction_holomorphic {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    [IsManifold (modelWithCornersSelf ℂ V) ω B] (g : SpecialPeriods.TriangleGroup) :
+    letI := D.periods.totalChartedSpace
+    letI := D.totalAction
+    ContMDiff (modelWithCornersSelf ℂ (V × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (V × ComplexPlane₂)) ω (fun x : D.TotalSpace => g • x) := by
+  let := D.periods.totalChartedSpace
+  let := D.totalAction
+  let := D.periods.coveringAction
+  apply
+    CoveringQuotient.contMDiff_of_comp (E := V × ComplexPlane₂) D.periods.quotientCoveringMap
+      (modelWithCornersSelf ℂ (V × ComplexPlane₂)) ω
+  have h := D.periods.quotientMap_holomorphic.comp (D.complexLift_holomorphic g)
+  convert h using 1
+  funext x
+  exact (D.complexLift_quotientMap g x).symm
+
+private def PeriodFamily.Data.BaseSpace {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [MulAction SpecialPeriods.TriangleGroup B]
+    (_D : PeriodFamily.Data V B) : Type _ :=
+  DiagonalQuotient.BaseSpace SpecialPeriods.TriangleGroup B
+
+private def PeriodFamily.Data.Space {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [MulAction SpecialPeriods.TriangleGroup B]
+    (D : PeriodFamily.Data V B) : Type _ :=
+  @MulAction.orbitRel.Quotient SpecialPeriods.TriangleGroup D.TotalSpace _ D.totalAction
+
+private instance PeriodFamily.Data.baseSpaceTopology {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) :
+    TopologicalSpace D.BaseSpace :=
+  inferInstanceAs (TopologicalSpace (DiagonalQuotient.BaseSpace SpecialPeriods.TriangleGroup B))
+
+private instance
+    PeriodFamily.Data.spaceTopology {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [MulAction SpecialPeriods.TriangleGroup B]
+    (D : PeriodFamily.Data V B) : TopologicalSpace D.Space :=
+  inferInstanceAs
+    (TopologicalSpace
+      (@MulAction.orbitRel.Quotient SpecialPeriods.TriangleGroup D.TotalSpace _ D.totalAction))
+
+private def PeriodFamily.Data.baseQuotient {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [MulAction SpecialPeriods.TriangleGroup B]
+    (D : PeriodFamily.Data V B) : B → D.BaseSpace :=
+  DiagonalQuotient.baseQuotient SpecialPeriods.TriangleGroup B
+
+private def PeriodFamily.Data.quotient {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [MulAction SpecialPeriods.TriangleGroup B]
+    (D : PeriodFamily.Data V B) : D.TotalSpace → D.Space := by
+  let := SpecialPeriods.triangleTorusAction
+  exact DiagonalQuotient.quotient SpecialPeriods.TriangleGroup B RealTorus₄
+
+private def PeriodFamily.Data.projection {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [MulAction SpecialPeriods.TriangleGroup B]
+    (D : PeriodFamily.Data V B) : D.Space → D.BaseSpace := by
+  let := SpecialPeriods.triangleTorusAction
+  exact DiagonalQuotient.projection SpecialPeriods.TriangleGroup B RealTorus₄
+
+@[simp]
+private theorem PeriodFamily.Data.projection_quotient {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) (x : D.TotalSpace) :
+    D.projection (D.quotient x) = D.baseQuotient (D.periods.projection x) :=
+  rfl
+
+private theorem PeriodFamily.Data.quotient_surjective {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) :
+    Function.Surjective D.quotient := by
+  let := SpecialPeriods.triangleTorusAction
+  exact DiagonalQuotient.quotient_surjective SpecialPeriods.TriangleGroup B RealTorus₄
+
+private theorem PeriodFamily.Data.quotient_continuous {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) :
+    Continuous D.quotient := by
+  let := SpecialPeriods.triangleTorusAction
+  exact DiagonalQuotient.quotient_continuous SpecialPeriods.TriangleGroup B RealTorus₄
+
+private theorem PeriodFamily.Data.projection_continuous {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) :
+    Continuous D.projection := by
+  let := SpecialPeriods.triangleTorusAction
+  exact DiagonalQuotient.projection_continuous SpecialPeriods.TriangleGroup B RealTorus₄
+
+private theorem PeriodFamily.Data.quotient_isQuotientMap {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) :
+    Topology.IsQuotientMap D.quotient := by
+  let := SpecialPeriods.triangleTorusAction
+  exact DiagonalQuotient.quotient_isQuotientMap SpecialPeriods.TriangleGroup B RealTorus₄
+
+private theorem
+    PeriodFamily.Data.quotient_eq_iff {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [MulAction SpecialPeriods.TriangleGroup B]
+    (D : PeriodFamily.Data V B) (x y : D.TotalSpace) :
+    letI := D.totalAction
+    D.quotient x = D.quotient y ↔ ∃ g : SpecialPeriods.TriangleGroup, g • y = x := by
+  let := SpecialPeriods.triangleTorusAction
+  exact DiagonalQuotient.quotient_eq_iff SpecialPeriods.TriangleGroup B RealTorus₄ x y
+
+@[simp]
+private theorem
+    PeriodFamily.Data.quotient_smul {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [MulAction SpecialPeriods.TriangleGroup B]
+    (D : PeriodFamily.Data V B) (g : SpecialPeriods.TriangleGroup) (x : D.TotalSpace) :
+    letI := D.totalAction
+    D.quotient (g • x) = D.quotient x := by
+  let := SpecialPeriods.triangleTorusAction
+  exact DiagonalQuotient.quotient_smul SpecialPeriods.TriangleGroup B RealTorus₄ g x
+
+private theorem PeriodFamily.Data.quotientCoveringMap {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) :
+    letI := D.totalAction
+    IsQuotientCoveringMap D.quotient SpecialPeriods.TriangleGroup := by
+  let := SpecialPeriods.triangleTorusAction
+  let := SpecialPeriods.triangleTorusAction_continuous
+  exact DiagonalQuotient.quotientCoveringMap (F := RealTorus₄) hq
+
+private theorem
+    PeriodFamily.Data.projection_proper {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [MulAction SpecialPeriods.TriangleGroup B]
+    (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) :
+    IsProperMap D.projection := by
+  let := SpecialPeriods.triangleTorusAction
+  let := SpecialPeriods.triangleTorusAction_continuous
+  exact DiagonalQuotient.projection_proper (F := RealTorus₄) hq
+
+private theorem PeriodFamily.Data.baseT2Space {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [MulAction SpecialPeriods.TriangleGroup B]
+    (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) [T2Space B]
+    [LocallyCompactSpace B] [ProperlyDiscontinuousSMul SpecialPeriods.TriangleGroup B] :
+    T2Space D.BaseSpace :=
+  DiagonalQuotient.baseT2Space hq
+
+private theorem
+    PeriodFamily.Data.spaceT2Space {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [MulAction SpecialPeriods.TriangleGroup B]
+    (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup)
+    [T2Space D.BaseSpace] : T2Space D.Space := by
+  let := SpecialPeriods.triangleTorusAction
+  let := SpecialPeriods.triangleTorusAction_continuous
+  let : T2Space (DiagonalQuotient.BaseSpace SpecialPeriods.TriangleGroup B) :=
+    ‹T2Space D.BaseSpace›
+  exact DiagonalQuotient.spaceT2Space (F := RealTorus₄) hq
+
+private theorem PeriodFamily.Data.spaceT2Space_of_properlyDiscontinuous {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) [T2Space B]
+    [LocallyCompactSpace B] [ProperlyDiscontinuousSMul SpecialPeriods.TriangleGroup B] :
+    T2Space D.Space := by
+  let := D.baseT2Space hq
+  exact D.spaceT2Space hq
+
+private theorem PeriodFamily.Data.spaceSecondCountable {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup)
+    [SecondCountableTopology B] : SecondCountableTopology D.Space := by
+  let := SpecialPeriods.triangleTorusAction
+  let := SpecialPeriods.triangleTorusAction_continuous
+  exact DiagonalQuotient.spaceSecondCountable (F := RealTorus₄) hq
+
+@[instance_reducible]
+private def PeriodFamily.Data.chartedSpace {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [MulAction SpecialPeriods.TriangleGroup B]
+    (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) :
+    ChartedSpace (V × ComplexPlane₂) D.Space := by
+  let := D.periods.totalChartedSpace
+  let := D.totalAction
+  exact CoveringQuotient.chartedSpace (E := V × ComplexPlane₂) (D.quotientCoveringMap hq)
+
+private theorem PeriodFamily.Data.isManifold {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [MulAction SpecialPeriods.TriangleGroup B]
+    (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup)
+    [IsManifold (modelWithCornersSelf ℂ V) ω B] :
+    letI := D.chartedSpace hq
+    IsManifold (modelWithCornersSelf ℂ (V × ComplexPlane₂)) ω D.Space := by
+  let := D.periods.totalChartedSpace
+  let := D.periods.totalSpace_isManifold
+  let := D.totalAction
+  exact CoveringQuotient.isManifold (D.quotientCoveringMap hq) ω D.totalAction_holomorphic
+
+private theorem PeriodFamily.Data.quotient_holomorphic {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup)
+    [IsManifold (modelWithCornersSelf ℂ V) ω B] :
+    letI := D.periods.totalChartedSpace
+    letI := D.chartedSpace hq
+    ContMDiff (modelWithCornersSelf ℂ (V × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (V × ComplexPlane₂)) ω D.quotient := by
+  let := D.periods.totalChartedSpace
+  let := D.periods.totalSpace_isManifold
+  let := D.totalAction
+  exact CoveringQuotient.contMDiff_project (D.quotientCoveringMap hq) ω D.totalAction_holomorphic
+
+private def PeriodFamily.Data.fibreHomeomorph {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [MulAction SpecialPeriods.TriangleGroup B]
+    (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) (b : B) :
+    (D.periods.point b).Torus ≃ₜ (D.projection ⁻¹' {D.baseQuotient b}) := by
+  let := SpecialPeriods.triangleTorusAction
+  let := SpecialPeriods.triangleTorusAction_continuous
+  exact
+    (D.periods.torusHomeomorph b).symm.trans
+      (DiagonalQuotient.fibreHomeomorphOver (F := RealTorus₄) hq b).symm
+
+private def PeriodFamily.Data.zeroSection {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [MulAction SpecialPeriods.TriangleGroup B]
+    (D : PeriodFamily.Data V B) : D.BaseSpace → D.Space := by
+  let := D.totalAction
+  refine Quotient.lift (fun b : B => D.quotient (D.periods.zeroSection b)) ?_
+  rintro b b' ⟨g, hg⟩
+  rw [← hg, ← D.totalAction_zeroSection, D.quotient_smul]
+
+@[simp]
+private theorem PeriodFamily.Data.zeroSection_baseQuotient {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) (b : B) :
+    D.zeroSection (D.baseQuotient b) = D.quotient (D.periods.zeroSection b) :=
+  rfl
+
+@[simp]
+private theorem PeriodFamily.Data.projection_zeroSection {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) (b : D.BaseSpace) :
+    D.projection (D.zeroSection b) = b := by
+  induction b using Quotient.inductionOn with
+  | h b => rfl
+
+private theorem PeriodFamily.Data.zeroSection_continuous {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) :
+    Continuous D.zeroSection := by
+  exact
+    isQuotientMap_quotient_mk'.continuous_iff.mpr
+      (D.quotient_continuous.comp (continuous_id.prodMk continuous_const))
+
+private theorem PeriodFamily.Data.quotient_isLocalDiffeomorph {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup)
+    [IsManifold (modelWithCornersSelf ℂ V) ω B] :
+    letI := D.periods.totalChartedSpace
+    letI := D.chartedSpace hq
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ (V × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (V × ComplexPlane₂)) ω D.quotient := by
+  let := D.periods.totalChartedSpace
+  let := D.periods.totalSpace_isManifold
+  let := D.totalAction
+  exact
+    CoveringQuotient.project_isLocalDiffeomorph (D.quotientCoveringMap hq)
+      D.totalAction_holomorphic
+
+private def PeriodFamily.regularPeriods (P : HolomorphicPeriodMap ℂ ℍ) :
+    HolomorphicPeriodMap ℂ SpecialPeriods.TriangleRegularPoint
+    where
+  point z := P.point z.val
+  holomorphic_tau :=
+    P.holomorphic_tau.comp (contMDiff_subtype_val (U := SpecialPeriods.triangleRegularDomain))
+  holomorphic_mu :=
+    P.holomorphic_mu.comp (contMDiff_subtype_val (U := SpecialPeriods.triangleRegularDomain))
+  holomorphic_beta :=
+    P.holomorphic_beta.comp (contMDiff_subtype_val (U := SpecialPeriods.triangleRegularDomain))
+
+private def PeriodFamily.regularData (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    Data ℂ SpecialPeriods.TriangleRegularPoint
+    where
+  periods := regularPeriods P
+  base_holomorphic := SpecialPeriods.triangleRegularAction_holomorphic
+  covariance₁
+    z := by
+    change
+      P.point
+          (SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleGenerator₁
+            z.val) =
+        _
+    rw [SpecialPeriods.triangleGeometricRepresentation_generator₁_apply]
+    exact h₁ z.val
+  covariance₂
+    z := by
+    change
+      P.point
+          (SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleGenerator₂
+            z.val) =
+        _
+    rw [SpecialPeriods.triangleGeometricRepresentation_generator₂_apply]
+    exact h₂ z.val
+
+private theorem PeriodFamily.regularCovering (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    IsQuotientCoveringMap (regularData P h₁ h₂).baseQuotient SpecialPeriods.TriangleGroup :=
+  SpecialPeriods.triangleRegularProject_covering
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/PeriodFamily/Core3.lean b/LeanPool/HopfProblem/PeriodFamily/Core3.lean
new file mode 100644
index 000000000..676a6454a
--- /dev/null
+++ b/LeanPool/HopfProblem/PeriodFamily/Core3.lean
@@ -0,0 +1,3301 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Pi1.ThreefoldOverlapMappingTorus2
+public import LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology2
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.PeriodFamily.PeriodDomain
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Pi1.ThreefoldOverlapMappingTorus1
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import all LeanPool.HopfProblem.PeriodFamily.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods6
+import all LeanPool.HopfProblem.Toric.DiagonalQuotient1
+import all LeanPool.HopfProblem.PeriodFamily.Core2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods7
+import all LeanPool.HopfProblem.Elliptic.Core3
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods8
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen2
+import all LeanPool.HopfProblem.Elliptic.Core5
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods8
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods9
+import all LeanPool.HopfProblem.Toric.DiagonalQuotient2
+import all LeanPool.HopfProblem.Foundations.SplitGroupExtension
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization4
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology2
+import all LeanPool.HopfProblem.Pi1.ThreefoldOverlapMappingTorus2
+
+/-!
+# Hopf problem: period family · core 3
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def
+    PeriodFamily.Boundary.EllipticCapProduct.twistCylinderMap {X : Type*} [TopologicalSpace X]
+    (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1)
+    (p : ℝ × ((Elliptic.HigherHomology.MappingTorusQuotient.Circle) × X)) :
+    Elliptic.HigherHomology.MappingTorusQuotient.ProductQuotient m B hB ×
+      (Elliptic.HigherHomology.MappingTorusQuotient.Circle) :=
+  (Elliptic.HigherHomology.MappingTorusQuotient.project m B hB p.2,
+    p.2.1 + (((p.1 / m : ℝ) : (Elliptic.HigherHomology.MappingTorusQuotient.Circle))))
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.twistCylinderMap_continuous {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) :
+    Continuous (twistCylinderMap m B hB) :=
+  ((Elliptic.HigherHomology.MappingTorusQuotient.project_continuous m B hB).comp
+        continuous_snd).prodMk
+    ((continuous_fst.comp continuous_snd).add
+      ((AddCircle.continuous_mk' (1 : ℝ)).comp (continuous_fst.div_const (m : ℝ))))
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.twistCylinderMap_deck {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) (n : ℤ)
+    (p : ℝ × ((Elliptic.HigherHomology.MappingTorusQuotient.Circle) × X)) :
+    twistCylinderMap m B hB
+        (MappingTorus.deck (Elliptic.HigherHomology.MappingTorusQuotient.twist m B) n p) =
+      twistCylinderMap m B hB p := by
+  rcases p with ⟨t, a, x⟩
+  simp only [twistCylinderMap, MappingTorus.deck,
+    Elliptic.HigherHomology.MappingTorusQuotient.twist_zpow_apply]
+  apply Prod.ext
+  · exact (Elliptic.HigherHomology.MappingTorusQuotient.project_eq_iff m B hB _ _).mpr ⟨-n, rfl⟩
+  · change
+      (a + ((((-n : ℤ) : ℝ) / m : ℝ) : (Elliptic.HigherHomology.MappingTorusQuotient.Circle))) +
+          (((t + (n : ℝ)) / m : ℝ) : (Elliptic.HigherHomology.MappingTorusQuotient.Circle)) =
+        a + ((t / m : ℝ) : (Elliptic.HigherHomology.MappingTorusQuotient.Circle))
+    rw [add_assoc, ← AddCircle.coe_add]
+    congr 2
+    push_cast
+    ring
+
+private def
+    PeriodFamily.Boundary.EllipticCapProduct.twistProductMap {X : Type*} [TopologicalSpace X]
+    (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) :
+    MappingTorus.Torus (Elliptic.HigherHomology.MappingTorusQuotient.twist m B) →
+      Elliptic.HigherHomology.MappingTorusQuotient.ProductQuotient m B hB ×
+        (Elliptic.HigherHomology.MappingTorusQuotient.Circle) :=
+  Quotient.lift (twistCylinderMap m B hB)
+    (by
+      rintro p q ⟨n, rfl⟩
+      exact (twistCylinderMap_deck m B hB n p).symm)
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticCapProduct.twistProductMap_mk {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) (t : ℝ)
+    (a : (Elliptic.HigherHomology.MappingTorusQuotient.Circle)) (x : X) :
+    twistProductMap m B hB
+        (MappingTorus.mk (Elliptic.HigherHomology.MappingTorusQuotient.twist m B) (t, (a, x))) =
+      (Elliptic.HigherHomology.MappingTorusQuotient.project m B hB (a, x),
+        a + ((t / m : ℝ) : (Elliptic.HigherHomology.MappingTorusQuotient.Circle))) :=
+  rfl
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.twistProductMap_continuous {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) :
+    Continuous (twistProductMap m B hB) :=
+  (twistCylinderMap_continuous m B hB).quotient_lift _
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.twistProductMap_injective {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) :
+    Function.Injective (twistProductMap m B hB) := by
+  intro p q hpq
+  obtain ⟨⟨t, a, x⟩, rfl⟩ :=
+    MappingTorus.mk_surjective (Elliptic.HigherHomology.MappingTorusQuotient.twist m B) p
+  obtain ⟨⟨s, b, y⟩, rfl⟩ :=
+    MappingTorus.mk_surjective (Elliptic.HigherHomology.MappingTorusQuotient.twist m B) q
+  have hq :
+    Elliptic.HigherHomology.MappingTorusQuotient.project m B hB (a, x) =
+      Elliptic.HigherHomology.MappingTorusQuotient.project m B hB (b, y) :=
+    congrArg Prod.fst hpq
+  have hc :
+    a + ((t / m : ℝ) : (Elliptic.HigherHomology.MappingTorusQuotient.Circle)) =
+      b + ((s / m : ℝ) : (Elliptic.HigherHomology.MappingTorusQuotient.Circle)) :=
+    congrArg Prod.snd hpq
+  obtain ⟨n, hn⟩ := (Elliptic.HigherHomology.MappingTorusQuotient.project_eq_iff m B hB _ _).mp hq
+  have ha : a = b + (((n : ℝ) / m : ℝ) : (Elliptic.HigherHomology.MappingTorusQuotient.Circle)) :=
+    congrArg Prod.fst hn
+  have ht :
+    ((s / m : ℝ) : (Elliptic.HigherHomology.MappingTorusQuotient.Circle)) =
+      ((t / m + (n : ℝ) / m : ℝ) : (Elliptic.HigherHomology.MappingTorusQuotient.Circle)) := by
+    apply add_left_cancel (a := b)
+    rw [AddCircle.coe_add]
+    rw [ha, add_assoc] at hc
+    exact hc.symm.trans (by abel)
+  obtain ⟨k, hk⟩ :=
+    (Elliptic.HigherHomology.MappingTorusQuotient.circle_scaled_eq_iff m s t n).mp ht
+  apply Eq.symm
+  apply
+    (MappingTorus.mk_eq_mk_iff (Elliptic.HigherHomology.MappingTorusQuotient.twist m B)
+        (s, (b, y)) (t, (a, x))).mpr
+  refine ⟨-(n + (m : ℤ) * k), ?_, ?_⟩
+  · push_cast at hk ⊢
+    linarith
+  · rw [neg_neg,
+      Elliptic.HigherHomology.MappingTorusQuotient.fibre_zpow_add_mul_period m
+        (Elliptic.HigherHomology.MappingTorusQuotient.twist m B)
+        (Elliptic.HigherHomology.MappingTorusQuotient.twist_pow_order m B hB),
+      Elliptic.HigherHomology.MappingTorusQuotient.twist_zpow_apply]
+    exact hn
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.twistProductMap_surjective {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) :
+    Function.Surjective (twistProductMap m B hB) := by
+  rintro ⟨q, c⟩
+  obtain ⟨⟨a, x⟩, rfl⟩ := Elliptic.HigherHomology.MappingTorusQuotient.project_surjective m B hB q
+  obtain ⟨u, hu⟩ := QuotientAddGroup.mk_surjective (c - a)
+  change (u : (Elliptic.HigherHomology.MappingTorusQuotient.Circle)) = c - a at hu
+  refine
+    ⟨MappingTorus.mk (Elliptic.HigherHomology.MappingTorusQuotient.twist m B) (u * m, (a, x)), ?_⟩
+  rw [twistProductMap_mk]
+  apply Prod.ext
+  · rfl
+  · have hm : (m : ℝ) ≠ 0 := Nat.cast_ne_zero.mpr (NeZero.ne m)
+    change a + (((u * m) / m : ℝ) : (Elliptic.HigherHomology.MappingTorusQuotient.Circle)) = c
+    rw [mul_div_cancel_right₀ u hm, hu]
+    abel
+
+private def PeriodFamily.Boundary.EllipticCapProduct.twistProductHomeomorph {X : Type*}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) [CompactSpace X]
+    [T2Space X] :
+    MappingTorus.Torus (Elliptic.HigherHomology.MappingTorusQuotient.twist m B) ≃ₜ
+      Elliptic.HigherHomology.MappingTorusQuotient.ProductQuotient m B hB ×
+        (Elliptic.HigherHomology.MappingTorusQuotient.Circle) :=
+  Continuous.homeoOfEquivCompactToT2 (f :=
+    Equiv.ofBijective (twistProductMap m B hB)
+      ⟨twistProductMap_injective m B hB, twistProductMap_surjective m B hB⟩)
+    (twistProductMap_continuous m B hB)
+
+private def PeriodFamily.Boundary.EllipticCapProduct.homeomorphConjugation {X Y : Type*}
+    [TopologicalSpace X] [TopologicalSpace Y] (e : X ≃ₜ Y) : (X ≃ₜ X) →* (Y ≃ₜ Y)
+    where
+  toFun f := e.symm.trans (f.trans e)
+  map_one' := by ext y; simp
+  map_mul' f h := by ext y; simp
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticCapProduct.homeomorphConjugation_apply {X Y : Type*}
+    [TopologicalSpace X] [TopologicalSpace Y] (e : X ≃ₜ Y) (f : X ≃ₜ X) (y : Y) :
+    homeomorphConjugation e f y = e (f (e.symm y)) :=
+  rfl
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.mappingTorusConjugacy_zpow {X Y : Type*}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : X ≃ₜ Y)
+    (he : ∀ x, e (f x) = g (e x)) (n : ℤ) (x : X) : e ((f ^ n) x) = (g ^ n) (e x) := by
+  have hfg : homeomorphConjugation e f = g := by
+    ext y
+    change e (f (e.symm y)) = g y
+    rw [he, e.apply_symm_apply]
+  have hpow := congrArg (fun h : Y ≃ₜ Y ↦ h (e x)) ((homeomorphConjugation e).map_zpow f n)
+  simpa only [homeomorphConjugation_apply, e.symm_apply_apply, hfg] using hpow
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.mappingTorusConjugacy_symm_generator
+    {X Y : Type*} [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : X ≃ₜ Y)
+    (he : ∀ x, e (f x) = g (e x)) (y : Y) : e.symm (g y) = f (e.symm y) := by
+  apply e.injective
+  rw [e.apply_symm_apply, he, e.apply_symm_apply]
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.mappingTorusConjugacy_deck {X Y : Type*}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : X ≃ₜ Y)
+    (he : ∀ x, e (f x) = g (e x)) (n : ℤ) (p : ℝ × X) :
+    ((MappingTorus.deck f n p).1, e (MappingTorus.deck f n p).2) =
+      MappingTorus.deck g n (p.1, e p.2) := by
+  apply Prod.ext
+  · rfl
+  · exact mappingTorusConjugacy_zpow f g e he (-n) p.2
+
+private def PeriodFamily.Boundary.EllipticCapProduct.mappingTorusConjugacyMap {X Y : Type*}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : X ≃ₜ Y)
+    (he : ∀ x, e (f x) = g (e x)) : C(MappingTorus.Torus f, MappingTorus.Torus g)
+    where
+  toFun :=
+    Quotient.lift (fun p : ℝ × X ↦ MappingTorus.mk g (p.1, e p.2))
+      (by
+        rintro p q ⟨n, rfl⟩
+        rw [mappingTorusConjugacy_deck f g e he, MappingTorus.mk_deck])
+  continuous_toFun :=
+    ((MappingTorus.mk_continuous g).comp
+          (continuous_fst.prodMk (e.continuous.comp continuous_snd))).quotient_lift
+      _
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticCapProduct.mappingTorusConjugacyMap_mk {X Y : Type*}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : X ≃ₜ Y)
+    (he : ∀ x, e (f x) = g (e x)) (t : ℝ) (x : X) :
+    mappingTorusConjugacyMap f g e he (MappingTorus.mk f (t, x)) = MappingTorus.mk g (t, e x) :=
+  rfl
+
+private def PeriodFamily.Boundary.EllipticCapProduct.mappingTorusConjugacy {X Y : Type*}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y) (e : X ≃ₜ Y)
+    (he : ∀ x, e (f x) = g (e x)) : MappingTorus.Torus f ≃ₜ MappingTorus.Torus g
+    where
+  toFun := mappingTorusConjugacyMap f g e he
+  invFun := mappingTorusConjugacyMap g f e.symm (mappingTorusConjugacy_symm_generator f g e he)
+  left_inv
+    q := by
+    obtain ⟨⟨t, x⟩, rfl⟩ := MappingTorus.mk_surjective f q
+    simp only [mappingTorusConjugacyMap_mk, e.symm_apply_apply]
+  right_inv
+    q := by
+    obtain ⟨⟨t, y⟩, rfl⟩ := MappingTorus.mk_surjective g q
+    simp only [mappingTorusConjugacyMap_mk, e.apply_symm_apply]
+  continuous_toFun := (mappingTorusConjugacyMap f g e he).continuous
+  continuous_invFun :=
+    (mappingTorusConjugacyMap g f e.symm
+        (mappingTorusConjugacy_symm_generator f g e he)).continuous
+
+private def PeriodFamily.Boundary.EllipticCapProduct.splitBoundaryHomeomorph (j : Elliptic.Kind) :
+    (ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary) j ≃ₜ
+      MappingTorus.Torus
+        (Elliptic.HigherHomology.MappingTorusQuotient.twist j.order
+          (Elliptic.HigherHomology.fibreTorusHomeomorph j)) :=
+  mappingTorusConjugacy (Elliptic.flatTorusAffine j j.twist)
+    (Elliptic.HigherHomology.MappingTorusQuotient.twist j.order
+      (Elliptic.HigherHomology.fibreTorusHomeomorph j))
+    (Elliptic.HigherHomology.splitFlatTorusHomeomorph j)
+    (Elliptic.HigherHomology.splitFlatTorusHomeomorph_flatTorusAffine j)
+
+@[simp]
+private theorem
+    PeriodFamily.Boundary.EllipticCapProduct.splitBoundaryHomeomorph_mk (j : Elliptic.Kind)
+    (t : ℝ) (x : RealTorus₄) :
+    splitBoundaryHomeomorph j (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (t, x)) =
+      MappingTorus.mk
+        (Elliptic.HigherHomology.MappingTorusQuotient.twist j.order
+          (Elliptic.HigherHomology.fibreTorusHomeomorph j))
+        (t, Elliptic.HigherHomology.splitFlatTorusHomeomorph j x) :=
+  rfl
+
+private def PeriodFamily.Boundary.EllipticCapProduct.boundaryProductHomeomorph (j : Elliptic.Kind) :
+    (ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary) j ≃ₜ
+      ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface j × MappingTorus.Circle :=
+  (splitBoundaryHomeomorph j).trans
+    ((twistProductHomeomorph j.order (Elliptic.HigherHomology.fibreTorusHomeomorph j)
+          (Elliptic.HigherHomology.fibreTorusHomeomorph_pow_order j)).trans
+      (((Elliptic.HigherHomology.surfaceSplitQuotientHomeomorph j
+              (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).symm).prodCongr
+        (Homeomorph.refl MappingTorus.Circle)))
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.splitPeriodTorusHomeomorph_symm_splitFlat
+    (j : Elliptic.Kind) (p : PeriodDomain) (x : RealTorus₄) :
+    (Elliptic.HigherHomology.splitPeriodTorusHomeomorph j p).symm
+        (Elliptic.HigherHomology.splitFlatTorusHomeomorph j x) =
+      Elliptic.flatTorusPeriodHomeomorph p x := by
+  apply (Elliptic.HigherHomology.splitPeriodTorusHomeomorph j p).injective
+  rw [Homeomorph.apply_symm_apply]
+  change
+    Elliptic.HigherHomology.splitFlatTorusHomeomorph j x =
+      Elliptic.HigherHomology.splitFlatTorusHomeomorph j
+        ((Elliptic.flatTorusPeriodHomeomorph p).symm (Elliptic.flatTorusPeriodHomeomorph p x))
+  rw [Homeomorph.symm_apply_apply]
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapProduct.boundaryProductHomeomorph_mk (j : Elliptic.Kind)
+    (t : ℝ) (x : RealTorus₄) :
+    boundaryProductHomeomorph j (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (t, x)) =
+      (ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryToCentral j
+          (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (t, x)),
+        (Elliptic.HigherHomology.splitFlatTorusHomeomorph j x).1 +
+          ((t / j.order : ℝ) : MappingTorus.Circle)) := by
+  rw [boundaryProductHomeomorph, Homeomorph.trans_apply, splitBoundaryHomeomorph_mk,
+    Homeomorph.trans_apply]
+  change
+    ((Elliptic.HigherHomology.surfaceSplitQuotientHomeomorph j
+              (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).symm
+          (Elliptic.HigherHomology.MappingTorusQuotient.project j.order
+            (Elliptic.HigherHomology.fibreTorusHomeomorph j)
+            (Elliptic.HigherHomology.fibreTorusHomeomorph_pow_order j)
+            (Elliptic.HigherHomology.splitFlatTorusHomeomorph j x)),
+        (Elliptic.HigherHomology.splitFlatTorusHomeomorph j x).1 +
+          ((t / j.order : ℝ) : MappingTorus.Circle)) =
+      _
+  rw [Elliptic.HigherHomology.surfaceSplitQuotientHomeomorph_symm_project,
+    splitPeriodTorusHomeomorph_symm_splitFlat,
+    ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryToCentral_mk]
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapProduct.boundaryProductHomeomorph_fst (j : Elliptic.Kind)
+    (q : (ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary) j) :
+    (boundaryProductHomeomorph j q).1 =
+      ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryToCentral j q := by
+  obtain ⟨⟨t, x⟩, rfl⟩ := MappingTorus.mk_surjective (Elliptic.flatTorusAffine j j.twist) q
+  exact congrArg Prod.fst (boundaryProductHomeomorph_mk j t x)
+
+private def PeriodFamily.Boundary.EllipticCapProduct.capSection (j : Elliptic.Kind) :
+    C(ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface j,
+      (ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary) j) :=
+  ((boundaryProductHomeomorph j).symm : C(_, _)).comp
+    ⟨fun x => (x, (0 : MappingTorus.Circle)), continuous_id.prodMk continuous_const⟩
+
+private def
+    PeriodFamily.Boundary.EllipticCapProduct.boundaryCircleFirstHomeomorph (j : Elliptic.Kind) :
+    (ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary) j ≃ₜ
+      MappingTorus.Circle × (ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j :=
+  (boundaryProductHomeomorph j).trans (Homeomorph.prodComm _ _)
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.boundaryCircleFirstHomeomorph_projection
+    (j : Elliptic.Kind) :
+    (PeriodTorusHigherHomology.CircleTopology.productProjection
+            ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j)).comp
+        (boundaryCircleFirstHomeomorph j : C(_, _)) =
+      ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryToCentral j := by
+  ext q
+  exact boundaryProductHomeomorph_fst j q
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.boundaryCircleFirstHomeomorph_section
+    (j : Elliptic.Kind) :
+    (boundaryCircleFirstHomeomorph j : C(_, _)).comp (capSection j) =
+      PeriodTorusHigherHomology.CircleTopology.productSection
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) := by
+  apply ContinuousMap.ext
+  intro x
+  change
+    Prod.swap (boundaryProductHomeomorph j ((boundaryProductHomeomorph j).symm (x, 0))) = (0, x)
+  rw [Homeomorph.apply_symm_apply]
+  rfl
+
+private def PeriodFamily.Boundary.EllipticCapProduct.boundaryCapHomologyEquiv (j : Elliptic.Kind)
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary) j) (n + 1) ≃ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology
+          ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) (n + 1) ×
+        SingularMayerVietoris.SingularHomology
+          ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) n) :=
+  (PeriodTorusHigherHomology.homeomorphHomologyEquiv (boundaryCircleFirstHomeomorph j)
+        (n + 1)).trans
+    (PeriodTorusHigherHomology.circleProductHomologyEquiv
+      ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) n)
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapProduct.boundaryCapHomologyEquiv_fst (j : Elliptic.Kind)
+    (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary) j) (n + 1)) :
+    (boundaryCapHomologyEquiv j n a).1 =
+      SingularMayerVietoris.singularHomologyMap
+        (ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryToCentral j) (n + 1) a := by
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.CircleTopology.productProjection
+          ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j))
+        (n + 1)
+        (SingularMayerVietoris.singularHomologyMap (boundaryCircleFirstHomeomorph j : C(_, _))
+          (n + 1) a) =
+      _
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    boundaryCircleFirstHomeomorph_projection]
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticCapProduct.boundaryCapHomologyEquiv_section
+    (j : Elliptic.Kind) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) (n + 1)) :
+    boundaryCapHomologyEquiv j n
+        (SingularMayerVietoris.singularHomologyMap (capSection j) (n + 1) a) =
+      (a, 0) := by
+  change
+    PeriodTorusHigherHomology.circleProductHomologyEquiv
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) n
+        (SingularMayerVietoris.singularHomologyMap (boundaryCircleFirstHomeomorph j : C(_, _))
+          (n + 1) (SingularMayerVietoris.singularHomologyMap (capSection j) (n + 1) a)) =
+      _
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    boundaryCircleFirstHomeomorph_section]
+  exact
+    PeriodTorusHigherHomology.circleProductHomologyEquiv_section
+      ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) n a
+
+private def PeriodFamily.Boundary.EllipticCapProduct.boundaryPositiveCircleCross (j : Elliptic.Kind)
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) n →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary) j) (n + 1) :=
+  (PeriodTorusHigherHomology.homeomorphHomologyEquiv (boundaryCircleFirstHomeomorph j)
+        (n + 1)).symm.toLinearMap.comp
+    (PeriodTorusHigherHomology.positiveCircleCross
+      ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) n)
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.boundaryPositiveCircleCross_apply
+    (j : Elliptic.Kind) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) n) :
+    boundaryPositiveCircleCross j n a =
+      SingularMayerVietoris.singularHomologyMap ((boundaryCircleFirstHomeomorph j).symm : C(_, _))
+        (n + 1)
+        (PeriodTorusHigherHomology.positiveCircleCross
+          ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) n a) :=
+  rfl
+
+@[simp]
+private theorem
+    PeriodFamily.Boundary.EllipticCapProduct.boundaryCapHomologyEquiv_positiveCircleCross
+    (j : Elliptic.Kind) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) n) :
+    boundaryCapHomologyEquiv j n (boundaryPositiveCircleCross j n a) = (0, a) := by
+  change
+    PeriodTorusHigherHomology.circleProductHomologyEquiv
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) n
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv (boundaryCircleFirstHomeomorph j)
+          (n + 1)
+          ((PeriodTorusHigherHomology.homeomorphHomologyEquiv (boundaryCircleFirstHomeomorph j)
+                (n + 1)).symm
+            (PeriodTorusHigherHomology.positiveCircleCross
+              ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) n a))) =
+      _
+  rw [LinearEquiv.apply_symm_apply,
+    PeriodTorusHigherHomology.circleProductHomologyEquiv_positiveCircleCross]
+
+private def
+    PeriodFamily.Boundary.EllipticCapProduct.boundaryCapHomologyZeroEquiv (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary) j) 0 ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) 0 :=
+  (PeriodTorusHigherHomology.homeomorphHomologyEquiv (boundaryCircleFirstHomeomorph j) 0).trans
+    (PeriodTorusHigherHomology.circleProductHomologyZeroEquiv
+      ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j))
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.boundaryCapHomologyZeroEquiv_apply
+    (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary) j) 0) :
+    boundaryCapHomologyZeroEquiv j a =
+      SingularMayerVietoris.singularHomologyMap
+        (ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryToCentral j) 0 a := by
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.CircleTopology.productProjection
+          ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j))
+        0
+        (SingularMayerVietoris.singularHomologyMap (boundaryCircleFirstHomeomorph j : C(_, _)) 0
+          a) =
+      _
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    boundaryCircleFirstHomeomorph_projection]
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.boundaryToFilling_centralRetraction
+    (j : Elliptic.Kind) :
+    (SpecialPeriods.Threefold.EllipticGeometry.pieceSurfaceRetraction j).comp
+        (ThreefoldOverlapMappingTorus.boundaryToFilling (Option.some j)) =
+      ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryToCentral j := by
+  rw [ThreefoldOverlapMappingTorus.boundaryToFilling_elliptic]
+  rfl
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.boundaryFillingHomologyMap_central
+    (j : Elliptic.Kind) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary) j) n) :
+    ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j n
+        (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) n a) =
+      SingularMayerVietoris.singularHomologyMap
+        (ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryToCentral j) n a := by
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (SpecialPeriods.Threefold.EllipticGeometry.pieceSurfaceRetraction j) n
+        (SingularMayerVietoris.singularHomologyMap
+          (ThreefoldOverlapMappingTorus.boundaryToFilling (Option.some j)) n a) =
+      _
+  exact
+    (LinearMap.congr_fun
+          (PeriodTorusHigherHomology.singularHomologyMap_comp
+            (ThreefoldOverlapMappingTorus.boundaryToFilling (Option.some j))
+            (SpecialPeriods.Threefold.EllipticGeometry.pieceSurfaceRetraction j) n)
+          a).symm.trans
+      (congrArg
+        (fun f :
+            C((ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary) j,
+              (ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) =>
+          SingularMayerVietoris.singularHomologyMap f n a)
+        (boundaryToFilling_centralRetraction j))
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.boundaryFillingHomologyMap_first
+    (j : Elliptic.Kind) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary) j) (n + 1)) :
+    ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j (n + 1)
+        (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) (n + 1) a) =
+      (boundaryCapHomologyEquiv j n a).1 :=
+  (boundaryFillingHomologyMap_central j (n + 1) a).trans (boundaryCapHomologyEquiv_fst j n a).symm
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapProduct.boundaryFillingHomologyMap_eq_retraction_symm
+    (j : Elliptic.Kind) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary) j) (n + 1)) :
+    ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) (n + 1) a =
+      (ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j (n + 1)).symm
+        (boundaryCapHomologyEquiv j n a).1 := by
+  apply (ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j (n + 1)).injective
+  rw [boundaryFillingHomologyMap_first, LinearEquiv.apply_symm_apply]
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticCapProduct.boundaryFillingHomologyMap_section
+    (j : Elliptic.Kind) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) (n + 1)) :
+    ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) (n + 1)
+        (SingularMayerVietoris.singularHomologyMap (capSection j) (n + 1) a) =
+      (ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j (n + 1)).symm a := by
+  rw [boundaryFillingHomologyMap_eq_retraction_symm, boundaryCapHomologyEquiv_section]
+
+@[simp]
+private theorem
+    PeriodFamily.Boundary.EllipticCapProduct.boundaryFillingHomologyMap_positiveCircleCross
+    (j : Elliptic.Kind) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) n) :
+    ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) (n + 1)
+        (boundaryPositiveCircleCross j n a) =
+      0 := by
+  rw [boundaryFillingHomologyMap_eq_retraction_symm, boundaryCapHomologyEquiv_positiveCircleCross,
+    map_zero]
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.boundaryFillingHomologyMap_surjective
+    (j : Elliptic.Kind) (n : ℕ) :
+    Function.Surjective
+      (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) n) := by
+  cases n with
+  | zero =>
+    intro a
+    obtain ⟨b, hb⟩ :=
+      (boundaryCapHomologyZeroEquiv j).surjective
+        (ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j 0 a)
+    refine
+      ⟨b, (ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j 0).injective ?_⟩
+    rw [boundaryFillingHomologyMap_central, ← boundaryCapHomologyZeroEquiv_apply]
+    exact hb
+  | succ n =>
+    intro a
+    refine
+      ⟨SingularMayerVietoris.singularHomologyMap (capSection j) (n + 1)
+          (ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j (n + 1) a),
+        ?_⟩
+    rw [boundaryFillingHomologyMap_section, LinearEquiv.symm_apply_apply]
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.boundaryFillingHomologyMap_eq_zero_iff
+    (j : Elliptic.Kind) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary) j) (n + 1)) :
+    ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) (n + 1) a = 0 ↔
+      (boundaryCapHomologyEquiv j n a).1 = 0 := by
+  constructor
+  · intro h
+    rw [← boundaryFillingHomologyMap_first, h, map_zero]
+  · intro h
+    rw [boundaryFillingHomologyMap_eq_retraction_symm, h, map_zero]
+
+private def
+    PeriodFamily.Boundary.EllipticCapProduct.boundaryCapKernelEquiv (j : Elliptic.Kind) (n : ℕ) :
+    LinearMap.ker
+        (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) (n + 1)) ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) n :=
+  ({    toFun a := (boundaryCapHomologyEquiv j n a.val).2
+        map_add' a b := congrArg Prod.snd ((boundaryCapHomologyEquiv j n).map_add a.val b.val)
+        invFun
+          b :=
+          ⟨boundaryPositiveCircleCross j n b,
+            boundaryFillingHomologyMap_positiveCircleCross j n b⟩
+        left_inv
+          a := by
+          apply Subtype.ext
+          apply (boundaryCapHomologyEquiv j n).injective
+          rw [boundaryCapHomologyEquiv_positiveCircleCross]
+          exact
+            Prod.ext ((boundaryFillingHomologyMap_eq_zero_iff j n a.val).mp a.property).symm rfl
+        right_inv b := congrArg Prod.snd (boundaryCapHomologyEquiv_positiveCircleCross j n b) } :
+      LinearMap.ker
+          (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) (n + 1)) ≃+
+        SingularMayerVietoris.SingularHomology
+          ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) n).toIntLinearEquiv
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticCapProduct.boundaryCapKernelEquiv_symm_val
+    (j : Elliptic.Kind) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) n) :
+    ((boundaryCapKernelEquiv j n).symm a).val = boundaryPositiveCircleCross j n a :=
+  rfl
+
+private theorem PeriodFamily.Boundary.Cylinder.projection_isOpenQuotientMap {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) : IsOpenQuotientMap (MappingTorus.mk φ) :=
+  ⟨MappingTorus.mk_surjective φ, MappingTorus.mk_continuous φ, MappingTorus.mk_open φ⟩
+
+private def
+    PeriodFamily.Boundary.Cylinder.descend {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (φ : X ≃ₜ X) (F : C(ℝ × X, Y)) (hF : ∀ (k : ℤ) p, F (MappingTorus.deck φ k p) = F p) :
+    C(MappingTorus.Torus φ, Y)
+    where
+  toFun :=
+    Quotient.lift F
+      (by
+        rintro p q ⟨k, rfl⟩
+        exact (hF k p).symm)
+  continuous_toFun := F.continuous.quotient_lift _
+
+private def PeriodFamily.Boundary.Cylinder.descendHomotopy {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (φ : X ≃ₜ X) (F G : C(ℝ × X, Y))
+    (hF : ∀ (k : ℤ) p, F (MappingTorus.deck φ k p) = F p)
+    (hG : ∀ (k : ℤ) p, G (MappingTorus.deck φ k p) = G p) (H : F.Homotopy G)
+    (hH : ∀ (s : unitInterval) (k : ℤ) p, H (s, MappingTorus.deck φ k p) = H (s, p)) :
+    (descend φ F hF).Homotopy (descend φ G hG)
+    where
+  toFun
+    z :=
+    Quotient.lift (fun p => H (z.1, p))
+      (by
+        rintro p q ⟨k, rfl⟩
+        exact (hH z.1 k p).symm)
+      z.2
+  continuous_toFun := by
+    apply (IsOpenQuotientMap.id.prodMap (projection_isOpenQuotientMap φ)).continuous_comp_iff.mp
+    exact H.continuous
+  map_zero_left
+    x := by
+    obtain ⟨p, rfl⟩ := MappingTorus.mk_surjective φ x
+    exact H.apply_zero p
+  map_one_left
+    x := by
+    obtain ⟨p, rfl⟩ := MappingTorus.mk_surjective φ x
+    exact H.apply_one p
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.baseHomotopyLift
+    (H : C(unitInterval × ℝ, SpecialPeriods.TriangleRegularQuotient))
+    (L : C(ℝ, SpecialPeriods.TriangleRegularPoint))
+    (hzero : ∀ t, H (0, t) = SpecialPeriods.triangleRegularProject (L t)) :
+    C(unitInterval × ℝ, SpecialPeriods.TriangleRegularPoint) :=
+  SpecialPeriods.triangleRegularProject_covering.isCoveringMap.liftHomotopy H L hzero
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+@[simp]
+private theorem PeriodFamily.Boundary.baseHomotopyLift_zero
+    (H : C(unitInterval × ℝ, SpecialPeriods.TriangleRegularQuotient))
+    (L : C(ℝ, SpecialPeriods.TriangleRegularPoint))
+    (hzero : ∀ t, H (0, t) = SpecialPeriods.triangleRegularProject (L t)) (t : ℝ) :
+    baseHomotopyLift H L hzero (0, t) = L t :=
+  SpecialPeriods.triangleRegularProject_covering.isCoveringMap.liftHomotopy_zero H L hzero t
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.baseHomotopyLift_projection
+    (H : C(unitInterval × ℝ, SpecialPeriods.TriangleRegularQuotient))
+    (L : C(ℝ, SpecialPeriods.TriangleRegularPoint))
+    (hzero : ∀ t, H (0, t) = SpecialPeriods.triangleRegularProject (L t)) (s : unitInterval)
+    (t : ℝ) :
+    SpecialPeriods.triangleRegularProject (baseHomotopyLift H L hzero (s, t)) = H (s, t) :=
+  congr_fun
+    (SpecialPeriods.triangleRegularProject_covering.isCoveringMap.liftHomotopy_lifts H L hzero)
+    (s, t)
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.baseHomotopyLift_translate
+    (H : C(unitInterval × ℝ, SpecialPeriods.TriangleRegularQuotient))
+    (L : C(ℝ, SpecialPeriods.TriangleRegularPoint))
+    (hzero : ∀ t, H (0, t) = SpecialPeriods.triangleRegularProject (L t))
+    (g : SpecialPeriods.TriangleGroup)
+    (hperiod : ∀ (s : unitInterval) (k : ℤ) t, H (s, t + k) = H (s, t))
+    (hdeck : ∀ (k : ℤ) t, L (t + k) = (g ^ (-k)) • L t) (s : unitInterval) (k : ℤ) (t : ℝ) :
+    baseHomotopyLift H L hzero (s, t + k) = (g ^ (-k)) • baseHomotopyLift H L hzero (s, t) := by
+  have hleft : Continuous (fun u : unitInterval => baseHomotopyLift H L hzero (u, t + k)) :=
+    (baseHomotopyLift H L hzero).continuous.comp (continuous_id.prodMk continuous_const)
+  have hright :
+    Continuous (fun u : unitInterval => (g ^ (-k)) • baseHomotopyLift H L hzero (u, t)) :=
+    (ContinuousConstSMul.continuous_const_smul (g ^ (-k))).comp
+      ((baseHomotopyLift H L hzero).continuous.comp (continuous_id.prodMk continuous_const))
+  have he :
+    SpecialPeriods.triangleRegularProject ∘
+        (fun u : unitInterval => baseHomotopyLift H L hzero (u, t + k)) =
+      SpecialPeriods.triangleRegularProject ∘
+        (fun u : unitInterval => (g ^ (-k)) • baseHomotopyLift H L hzero (u, t)) := by
+    funext u
+    simp only [Function.comp_apply, baseHomotopyLift_projection,
+      SpecialPeriods.triangleRegularProject_covering.map_smul, hperiod]
+  exact
+    congr_fun
+      (SpecialPeriods.triangleRegularProject_covering.isCoveringMap.eq_of_comp_eq hleft hright he
+        0 (by simp only [baseHomotopyLift_zero, hdeck]))
+      s
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.familyCylinderMap {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (L : C(ℝ, SpecialPeriods.TriangleRegularPoint)) (G : C(ℝ × X, RealTorus₄)) :
+    C(ℝ × X, D.Space) :=
+  ⟨fun p => D.quotient (L p.1, G p),
+    D.quotient_continuous.comp ((L.continuous.comp continuous_fst).prodMk G.continuous)⟩
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.familyCylinderMap_deck {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (φ : X ≃ₜ X)
+    (L : C(ℝ, SpecialPeriods.TriangleRegularPoint)) (G : C(ℝ × X, RealTorus₄))
+    (g : SpecialPeriods.TriangleGroup) (hL : ∀ (k : ℤ) t, L (t + k) = (g ^ (-k)) • L t)
+    (hG : ∀ (k : ℤ) p, G (MappingTorus.deck φ k p) = (g ^ (-k)) • G p) (k : ℤ) (p : ℝ × X) :
+    familyCylinderMap D L G (MappingTorus.deck φ k p) = familyCylinderMap D L G p := by
+  change D.quotient (L (p.1 + k), G (MappingTorus.deck φ k p)) = D.quotient (L p.1, G p)
+  rw [hL, hG]
+  exact
+    DiagonalQuotient.quotient_smul SpecialPeriods.TriangleGroup
+      SpecialPeriods.TriangleRegularPoint RealTorus₄ (g ^ (-k)) (L p.1, G p)
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.familyBoundaryMap {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (φ : X ≃ₜ X)
+    (L : C(ℝ, SpecialPeriods.TriangleRegularPoint)) (G : C(ℝ × X, RealTorus₄))
+    (g : SpecialPeriods.TriangleGroup) (hL : ∀ (k : ℤ) t, L (t + k) = (g ^ (-k)) • L t)
+    (hG : ∀ (k : ℤ) p, G (MappingTorus.deck φ k p) = (g ^ (-k)) • G p) :
+    C(MappingTorus.Torus φ, D.Space) :=
+  Cylinder.descend φ (familyCylinderMap D L G) (familyCylinderMap_deck D φ L G g hL hG)
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.baseHomotopySlice
+    (H : C(unitInterval × ℝ, SpecialPeriods.TriangleRegularPoint)) (s : unitInterval) :
+    C(ℝ, SpecialPeriods.TriangleRegularPoint) :=
+  ⟨fun t => H (s, t), H.continuous.comp (continuous_const.prodMk continuous_id)⟩
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.familyCylinderHomotopy {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (H : C(unitInterval × ℝ, SpecialPeriods.TriangleRegularPoint)) (G : C(ℝ × X, RealTorus₄)) :
+    (familyCylinderMap D (baseHomotopySlice H 0) G).Homotopy
+      (familyCylinderMap D (baseHomotopySlice H 1) G)
+    where
+  toFun p := D.quotient (H (p.1, p.2.1), G p.2)
+  continuous_toFun :=
+    D.quotient_continuous.comp
+      ((H.continuous.comp (continuous_fst.prodMk (continuous_fst.comp continuous_snd))).prodMk
+        (G.continuous.comp continuous_snd))
+  map_zero_left _ := rfl
+  map_one_left _ := rfl
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.familyCylinderHomotopy_deck {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (φ : X ≃ₜ X)
+    (H : C(unitInterval × ℝ, SpecialPeriods.TriangleRegularPoint)) (G : C(ℝ × X, RealTorus₄))
+    (g : SpecialPeriods.TriangleGroup)
+    (hH : ∀ (s : unitInterval) (k : ℤ) t, H (s, t + k) = (g ^ (-k)) • H (s, t))
+    (hG : ∀ (k : ℤ) p, G (MappingTorus.deck φ k p) = (g ^ (-k)) • G p) (s : unitInterval) (k : ℤ)
+    (p : ℝ × X) :
+    familyCylinderHomotopy D H G (s, MappingTorus.deck φ k p) =
+      familyCylinderHomotopy D H G (s, p) := by
+  change D.quotient (H (s, p.1 + k), G (MappingTorus.deck φ k p)) = D.quotient (H (s, p.1), G p)
+  rw [hH, hG]
+  exact
+    DiagonalQuotient.quotient_smul SpecialPeriods.TriangleGroup
+      SpecialPeriods.TriangleRegularPoint RealTorus₄ (g ^ (-k)) (H (s, p.1), G p)
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.familyBoundaryHomotopy {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (φ : X ≃ₜ X)
+    (H : C(unitInterval × ℝ, SpecialPeriods.TriangleRegularPoint)) (G : C(ℝ × X, RealTorus₄))
+    (g : SpecialPeriods.TriangleGroup)
+    (hH : ∀ (s : unitInterval) (k : ℤ) t, H (s, t + k) = (g ^ (-k)) • H (s, t))
+    (hG : ∀ (k : ℤ) p, G (MappingTorus.deck φ k p) = (g ^ (-k)) • G p) :
+    (familyBoundaryMap D φ (baseHomotopySlice H 0) G g (hH 0) hG).Homotopy
+      (familyBoundaryMap D φ (baseHomotopySlice H 1) G g (hH 1) hG) :=
+  Cylinder.descendHomotopy φ _ _ (familyCylinderMap_deck D φ _ G g (hH 0) hG)
+    (familyCylinderMap_deck D φ _ G g (hH 1) hG) (familyCylinderHomotopy D H G)
+    (familyCylinderHomotopy_deck D φ H G g hH hG)
+
+private def PeriodFamily.Boundary.loopSquareLift {a b : SpecialPeriods.TriangleRegularQuotient}
+    {p : Path a a} {q : Path b b} (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q)
+    (L : C(unitInterval, SpecialPeriods.TriangleRegularPoint))
+    (hL : ∀ t, SpecialPeriods.triangleRegularProject (L t) = p t) :
+    C(unitInterval × unitInterval, SpecialPeriods.TriangleRegularPoint) :=
+  SpecialPeriods.triangleRegularProject_covering.isCoveringMap.liftHomotopy S.map L
+    (fun t => (S.initial t).trans (hL t).symm)
+
+@[simp]
+private theorem
+    PeriodFamily.Boundary.loopSquareLift_zero {a b : SpecialPeriods.TriangleRegularQuotient}
+    {p : Path a a} {q : Path b b} (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q)
+    (L : C(unitInterval, SpecialPeriods.TriangleRegularPoint))
+    (hL : ∀ t, SpecialPeriods.triangleRegularProject (L t) = p t) (t : unitInterval) :
+    loopSquareLift S L hL (0, t) = L t :=
+  SpecialPeriods.triangleRegularProject_covering.isCoveringMap.liftHomotopy_zero _ _ _ t
+
+private theorem PeriodFamily.Boundary.loopSquareLift_projection
+    {a b : SpecialPeriods.TriangleRegularQuotient} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q)
+    (L : C(unitInterval, SpecialPeriods.TriangleRegularPoint))
+    (hL : ∀ t, SpecialPeriods.triangleRegularProject (L t) = p t) (s t : unitInterval) :
+    SpecialPeriods.triangleRegularProject (loopSquareLift S L hL (s, t)) = S.map (s, t) :=
+  congr_fun
+    (SpecialPeriods.triangleRegularProject_covering.isCoveringMap.liftHomotopy_lifts _ _
+      (fun t => (S.initial t).trans (hL t).symm))
+    (s, t)
+
+private theorem PeriodFamily.Boundary.loopSquareLift_endpoint
+    {a b : SpecialPeriods.TriangleRegularQuotient} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q)
+    (L : C(unitInterval, SpecialPeriods.TriangleRegularPoint))
+    (hL : ∀ t, SpecialPeriods.triangleRegularProject (L t) = p t)
+    (g : SpecialPeriods.TriangleGroup) (hend : L 1 = g • L 0) (s : unitInterval) :
+    loopSquareLift S L hL (s, 1) = g • loopSquareLift S L hL (s, 0) := by
+  have hleft : Continuous (fun u : unitInterval => loopSquareLift S L hL (u, 1)) :=
+    (loopSquareLift S L hL).continuous.comp (continuous_id.prodMk continuous_const)
+  have hright : Continuous (fun u : unitInterval => g • loopSquareLift S L hL (u, 0)) :=
+    (ContinuousConstSMul.continuous_const_smul g).comp
+      ((loopSquareLift S L hL).continuous.comp (continuous_id.prodMk continuous_const))
+  have he :
+    SpecialPeriods.triangleRegularProject ∘
+        (fun u : unitInterval => loopSquareLift S L hL (u, 1)) =
+      SpecialPeriods.triangleRegularProject ∘
+        (fun u : unitInterval => g • loopSquareLift S L hL (u, 0)) := by
+    funext u
+    simp only [Function.comp_apply, loopSquareLift_projection,
+      SpecialPeriods.triangleRegularProject_covering.map_smul]
+    exact (S.closed u).symm
+  exact
+    congr_fun
+      (SpecialPeriods.triangleRegularProject_covering.isCoveringMap.eq_of_comp_eq hleft hright he
+        0 (by simpa only [loopSquareLift_zero] using hend))
+      s
+
+private theorem PeriodFamily.Boundary.loopSquareLift_final_frame
+    {a b : SpecialPeriods.TriangleRegularQuotient} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q)
+    (L : C(unitInterval, SpecialPeriods.TriangleRegularPoint))
+    (hL : ∀ t, SpecialPeriods.triangleRegularProject (L t) = p t)
+    (K : C(unitInterval, SpecialPeriods.TriangleRegularPoint))
+    (hK : ∀ t, SpecialPeriods.triangleRegularProject (K t) = q t)
+    (d : SpecialPeriods.TriangleGroup) (hd : loopSquareLift S L hL (1, 0) = d • K 0)
+    (t : unitInterval) : loopSquareLift S L hL (1, t) = d • K t := by
+  have hleft : Continuous (fun u : unitInterval => loopSquareLift S L hL (1, u)) :=
+    (loopSquareLift S L hL).continuous.comp (continuous_const.prodMk continuous_id)
+  have hright : Continuous (fun u : unitInterval => d • K u) :=
+    (ContinuousConstSMul.continuous_const_smul d).comp K.continuous
+  have he :
+    SpecialPeriods.triangleRegularProject ∘
+        (fun u : unitInterval => loopSquareLift S L hL (1, u)) =
+      SpecialPeriods.triangleRegularProject ∘ (fun u : unitInterval => d • K u) := by
+    funext u
+    simp only [Function.comp_apply, loopSquareLift_projection, S.final,
+      SpecialPeriods.triangleRegularProject_covering.map_smul, hK]
+  exact
+    congr_fun
+      (SpecialPeriods.triangleRegularProject_covering.isCoveringMap.eq_of_comp_eq hleft hright he
+        0 hd)
+      t
+
+private theorem PeriodFamily.Boundary.loopSquareLift_frame_relation
+    {a b : SpecialPeriods.TriangleRegularQuotient} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q)
+    (L : C(unitInterval, SpecialPeriods.TriangleRegularPoint))
+    (hL : ∀ t, SpecialPeriods.triangleRegularProject (L t) = p t)
+    (g : SpecialPeriods.TriangleGroup) (hend : L 1 = g • L 0)
+    (K : C(unitInterval, SpecialPeriods.TriangleRegularPoint))
+    (hK : ∀ t, SpecialPeriods.triangleRegularProject (K t) = q t)
+    (h : SpecialPeriods.TriangleGroup) (hKend : K 1 = h • K 0) (d : SpecialPeriods.TriangleGroup)
+    (hd : loopSquareLift S L hL (1, 0) = d • K 0) : g * d = d * h := by
+  let := SpecialPeriods.triangleRegularProject_covering.isCancelSMul
+  apply IsCancelSMul.right_cancel _ _ (K 0)
+  calc
+    (g * d) • K 0 = g • loopSquareLift S L hL (1, 0) := by rw [SemigroupAction.mul_smul, hd]
+    _ = loopSquareLift S L hL (1, 1) := (loopSquareLift_endpoint S L hL g hend 1).symm
+    _ = d • K 1 := (loopSquareLift_final_frame S L hL K hK d hd 1)
+    _ = (d * h) • K 0 := by rw [hKend, SemigroupAction.mul_smul]
+
+private theorem PeriodFamily.Boundary.loopSquareLift_exists_frame
+    {a b : SpecialPeriods.TriangleRegularQuotient} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q)
+    (L : C(unitInterval, SpecialPeriods.TriangleRegularPoint))
+    (hL : ∀ t, SpecialPeriods.triangleRegularProject (L t) = p t)
+    (z : SpecialPeriods.TriangleRegularPoint) (hz : SpecialPeriods.triangleRegularProject z = b) :
+    ∃ d : SpecialPeriods.TriangleGroup, loopSquareLift S L hL (1, 0) = d • z := by
+  have he :
+    SpecialPeriods.triangleRegularProject (loopSquareLift S L hL (1, 0)) =
+      SpecialPeriods.triangleRegularProject z := by
+    rw [loopSquareLift_projection, S.final, q.source, hz]
+  obtain ⟨d, hd⟩ := SpecialPeriods.triangleRegularProject_covering.apply_eq_iff_mem_orbit.mp he
+  exact ⟨d, hd.symm⟩
+
+private def PeriodFamily.Meridians.halfFordRealPreimage (x : ℝ) :
+    SpecialPeriods.Triangle.halfFordRegion :=
+  RiemannMapping.halfFordNormalizationHomeomorph.symm
+    ⟨(x : ℂ), by simp [RiemannSphere.closedOrientedHalfPlane]⟩
+
+private theorem PeriodFamily.Meridians.halfFordRealPreimage_normalization (x : ℝ) :
+    (RiemannMapping.halfFordNormalizationHomeomorph (halfFordRealPreimage x) : ℂ) = (x : ℂ) :=
+  congrArg
+    (fun w : RiemannSphere.closedOrientedHalfPlane RiemannMapping.normalizationOrientation =>
+      (w : ℂ))
+    (RiemannMapping.halfFordNormalizationHomeomorph.apply_symm_apply _)
+
+private theorem PeriodFamily.Meridians.halfFordRealPreimage_not_mem_interior (x : ℝ) :
+    (halfFordRealPreimage x : ℍ) ∉ SpecialPeriods.Triangle.halfFordInterior := by
+  apply (RiemannMapping.halfFordNormalizationHomeomorph_boundary_iff _).mp
+  rw [halfFordRealPreimage_normalization]
+  exact Complex.ofReal_im x
+
+private def
+    PeriodFamily.Meridians.halfFordBoundaryValue (z : SpecialPeriods.Triangle.halfFordRegion) :
+    ℝ :=
+  (RiemannMapping.halfFordNormalizationHomeomorph z : ℂ).re
+
+private theorem PeriodFamily.Meridians.halfFordBoundaryValue_continuous :
+    Continuous halfFordBoundaryValue :=
+  Complex.continuous_re.comp
+    (continuous_subtype_val.comp RiemannMapping.halfFordNormalizationHomeomorph.continuous)
+
+@[simp]
+private theorem PeriodFamily.Meridians.halfFordBoundaryValue_realPreimage (x : ℝ) :
+    halfFordBoundaryValue (halfFordRealPreimage x) = x := by
+  rw [halfFordBoundaryValue, halfFordRealPreimage_normalization, Complex.ofReal_re]
+
+@[simp]
+private theorem PeriodFamily.Meridians.halfFordBoundaryValue_centerOne :
+    halfFordBoundaryValue
+        ⟨SpecialPeriods.Triangle.centerOne,
+          SpecialPeriods.Triangle.centerOne_mem_halfFordRegion⟩ =
+      0 := by
+  rw [halfFordBoundaryValue, RiemannMapping.halfFordNormalizationHomeomorph_centerOne,
+    Complex.zero_re]
+
+@[simp]
+private theorem PeriodFamily.Meridians.halfFordBoundaryValue_centerTwo :
+    halfFordBoundaryValue
+        ⟨SpecialPeriods.Triangle.centerTwo,
+          SpecialPeriods.Triangle.centerTwo_mem_halfFordRegion⟩ =
+      1 := by
+  rw [halfFordBoundaryValue, RiemannMapping.halfFordNormalizationHomeomorph_centerTwo,
+    Complex.one_re]
+
+private theorem PeriodFamily.Meridians.halfFordBoundaryValue_coe
+    (z : SpecialPeriods.Triangle.halfFordRegion)
+    (hz : (z : ℍ) ∉ SpecialPeriods.Triangle.halfFordInterior) :
+    (halfFordBoundaryValue z : ℂ) = (RiemannMapping.halfFordNormalizationHomeomorph z : ℂ) := by
+  apply Complex.ext
+  · exact Complex.ofReal_re _
+  · rw [Complex.ofReal_im, (RiemannMapping.halfFordNormalizationHomeomorph_boundary_iff z).mpr hz]
+
+private theorem PeriodFamily.Meridians.halfFordBoundaryValue_injOn :
+    Set.InjOn halfFordBoundaryValue
+      {z : SpecialPeriods.Triangle.halfFordRegion |
+        (z : ℍ) ∉ SpecialPeriods.Triangle.halfFordInterior} := by
+  intro z hz w hw he
+  apply RiemannMapping.halfFordNormalizationHomeomorph.injective
+  apply Subtype.ext
+  rw [← halfFordBoundaryValue_coe z hz, ← halfFordBoundaryValue_coe w hw, he]
+
+private abbrev PeriodFamily.Meridians.RegularHalfPlane : Type :=
+  { w : RiemannSphere.closedOrientedHalfPlane RiemannMapping.normalizationOrientation //
+    (w : ℂ) ≠ 0 ∧ (w : ℂ) ≠ 1 }
+
+private def PeriodFamily.Meridians.halfPlaneValue (w : RegularHalfPlane) :
+    SpecialPeriods.Triangle.TwicePuncturedPlane :=
+  ⟨(w.val : ℂ), w.property⟩
+
+private def PeriodFamily.Meridians.halfPlaneConjugateValue (w : RegularHalfPlane) :
+    SpecialPeriods.Triangle.TwicePuncturedPlane := by
+  refine ⟨conj (w.val : ℂ), ?_, ?_⟩
+  · intro h
+    apply w.property.1
+    simpa using congrArg conj h
+  · intro h
+    apply w.property.2
+    simpa using congrArg conj h
+
+private theorem PeriodFamily.Meridians.halfFordNormalization_symm_projection
+    (w : RiemannSphere.closedOrientedHalfPlane RiemannMapping.normalizationOrientation) :
+    SpecialPeriods.Triangle.trianglePlaneUniformizationHomeomorph
+        (SpecialPeriods.triangleOrbitProjection
+          (RiemannMapping.halfFordNormalizationHomeomorph.symm w : ℍ)) =
+      (w : ℂ) := by
+  rw [SpecialPeriods.Triangle.trianglePlaneUniformizationHomeomorph_projection
+      (RiemannMapping.halfFordNormalizationHomeomorph.symm w).property,
+    RiemannMapping.triangleSignedHalfPlaneMap_of_mem
+      (RiemannMapping.halfFordNormalizationHomeomorph.symm w).property]
+  exact
+    congrArg
+      (fun v : RiemannSphere.closedOrientedHalfPlane RiemannMapping.normalizationOrientation =>
+        (v : ℂ))
+      (RiemannMapping.halfFordNormalizationHomeomorph.apply_symm_apply w)
+
+private theorem PeriodFamily.Meridians.triangleRegularLocus_iff_planeUniformization (z : ℍ) :
+    z ∈ SpecialPeriods.triangleRegularLocus ↔
+      SpecialPeriods.Triangle.trianglePlaneUniformizationHomeomorph
+            (SpecialPeriods.triangleOrbitProjection z) ≠
+          0 ∧
+        SpecialPeriods.Triangle.trianglePlaneUniformizationHomeomorph
+            (SpecialPeriods.triangleOrbitProjection z) ≠
+          1 := by
+  rw [← SpecialPeriods.triangleOrbitProjection_mem_regularDomain_iff,
+    SpecialPeriods.Triangle.trianglePlaneUniformizationHomeomorph_regular_iff]
+  rfl
+
+private theorem
+    PeriodFamily.Meridians.halfFordNormalization_symm_mem_regular (w : RegularHalfPlane) :
+    (RiemannMapping.halfFordNormalizationHomeomorph.symm w.val : ℍ) ∈
+      SpecialPeriods.triangleRegularLocus := by
+  apply (triangleRegularLocus_iff_planeUniformization _).mpr
+  rw [halfFordNormalization_symm_projection]
+  exact w.property
+
+private def PeriodFamily.Meridians.halfPlaneLift (w : RegularHalfPlane) :
+    SpecialPeriods.TriangleRegularPoint :=
+  ⟨(RiemannMapping.halfFordNormalizationHomeomorph.symm w.val : ℍ),
+    halfFordNormalization_symm_mem_regular w⟩
+
+private theorem PeriodFamily.Meridians.halfPlaneLift_mem_halfFordRegion (w : RegularHalfPlane) :
+    (halfPlaneLift w : ℍ) ∈ SpecialPeriods.Triangle.halfFordRegion :=
+  (RiemannMapping.halfFordNormalizationHomeomorph.symm w.val).property
+
+private theorem PeriodFamily.Meridians.halfPlaneLift_continuous : Continuous halfPlaneLift :=
+  (continuous_subtype_val.comp
+        (RiemannMapping.halfFordNormalizationHomeomorph.symm.continuous.comp
+          continuous_subtype_val)).subtype_mk
+    _
+
+@[simp]
+private theorem PeriodFamily.Meridians.halfPlaneLift_projection (w : RegularHalfPlane) :
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+        (SpecialPeriods.triangleRegularProject (halfPlaneLift w)) =
+      halfPlaneValue w := by
+  apply Subtype.ext
+  exact halfFordNormalization_symm_projection w.val
+
+private def PeriodFamily.Meridians.realHalfPlaneValue (x : ℝ) (hx0 : x ≠ 0) (hx1 : x ≠ 1) :
+    RegularHalfPlane := by
+  refine ⟨⟨(x : ℂ), by simp [RiemannSphere.closedOrientedHalfPlane]⟩, ?_, ?_⟩
+  · change (x : ℂ) ≠ 0
+    exact_mod_cast hx0
+  · change (x : ℂ) ≠ 1
+    exact_mod_cast hx1
+
+private theorem PeriodFamily.Meridians.triangleOrbitProjection_circleReflection (z : ℍ) :
+    SpecialPeriods.triangleOrbitProjection (SpecialPeriods.Triangle.circleReflection z) =
+      SpecialPeriods.triangleOrbitProjection (SpecialPeriods.Triangle.rightReflection z) := by
+  have h :=
+    SpecialPeriods.triangleOrbitProjection_smul SpecialPeriods.triangleGenerator₁
+      (SpecialPeriods.Triangle.circleReflection z)
+  rw [SpecialPeriods.triangleGeometricRepresentation_generator₁_apply,
+    SpecialPeriods.Triangle.generatorOne_reflections,
+    SpecialPeriods.Triangle.circleReflection_involutive] at h
+  exact h.symm
+
+private theorem
+    PeriodFamily.Meridians.trianglePlaneUniformizationHomeomorph_circleReflection {z : ℍ}
+    (hz : z ∈ SpecialPeriods.Triangle.halfFordRegion) :
+    SpecialPeriods.Triangle.trianglePlaneUniformizationHomeomorph
+        (SpecialPeriods.triangleOrbitProjection (SpecialPeriods.Triangle.circleReflection z)) =
+      conj (RiemannMapping.triangleSignedHalfPlaneMap z) := by
+  rw [triangleOrbitProjection_circleReflection]
+  change
+    RiemannMapping.triangleSignedHalfPlaneMap.quotientHomeomorph
+        RiemannMapping.triangleSignedHalfPlaneMap_isProperMap
+        (SpecialPeriods.triangleOrbitProjection (SpecialPeriods.Triangle.rightReflection z)) =
+      _
+  rw [RiemannMapping.triangleSignedHalfPlaneMap.quotientHomeomorph_projection
+      RiemannMapping.triangleSignedHalfPlaneMap_isProperMap
+      (SpecialPeriods.Triangle.rightReflection z)
+      (SpecialPeriods.Triangle.rightReflection_mapsTo_fordRegion hz.1)]
+  exact RiemannMapping.triangleSignedHalfPlaneMap.toBoundaryMap.foldedFordMap_reflected z hz
+
+private theorem
+  PeriodFamily.Meridians.trianglePlaneUniformizationHomeomorph_circleReflection_normalization
+    {z : ℍ} (hz : z ∈ SpecialPeriods.Triangle.halfFordRegion) :
+    SpecialPeriods.Triangle.trianglePlaneUniformizationHomeomorph
+        (SpecialPeriods.triangleOrbitProjection (SpecialPeriods.Triangle.circleReflection z)) =
+      conj (RiemannMapping.halfFordNormalizationHomeomorph ⟨z, hz⟩ : ℂ) := by
+  rw [trianglePlaneUniformizationHomeomorph_circleReflection hz,
+    RiemannMapping.triangleSignedHalfPlaneMap_of_mem hz]
+
+private theorem
+    PeriodFamily.Meridians.circleReflection_halfPlaneLift_projection (w : RegularHalfPlane) :
+    SpecialPeriods.Triangle.trianglePlaneUniformizationHomeomorph
+        (SpecialPeriods.triangleOrbitProjection
+          (SpecialPeriods.Triangle.circleReflection (halfPlaneLift w : ℍ))) =
+      conj (w.val : ℂ) := by
+  rw [trianglePlaneUniformizationHomeomorph_circleReflection_normalization
+      (halfPlaneLift_mem_halfFordRegion w)]
+  exact
+    congrArg
+      (fun v : RiemannSphere.closedOrientedHalfPlane RiemannMapping.normalizationOrientation =>
+        conj (v : ℂ))
+      (RiemannMapping.halfFordNormalizationHomeomorph.apply_symm_apply w.val)
+
+private theorem
+    PeriodFamily.Meridians.circleReflection_halfPlaneLift_mem_regular (w : RegularHalfPlane) :
+    SpecialPeriods.Triangle.circleReflection (halfPlaneLift w : ℍ) ∈
+      SpecialPeriods.triangleRegularLocus := by
+  apply (triangleRegularLocus_iff_planeUniformization _).mpr
+  rw [circleReflection_halfPlaneLift_projection]
+  exact (halfPlaneConjugateValue w).property
+
+private def PeriodFamily.Meridians.reflectedHalfPlaneLift (w : RegularHalfPlane) :
+    SpecialPeriods.TriangleRegularPoint :=
+  ⟨SpecialPeriods.Triangle.circleReflection (halfPlaneLift w : ℍ),
+    circleReflection_halfPlaneLift_mem_regular w⟩
+
+private theorem PeriodFamily.Meridians.reflectedHalfPlaneLift_continuous :
+    Continuous reflectedHalfPlaneLift :=
+  (SpecialPeriods.Triangle.circleReflection.continuous.comp
+        (continuous_subtype_val.comp halfPlaneLift_continuous)).subtype_mk
+    _
+
+@[simp]
+private theorem PeriodFamily.Meridians.reflectedHalfPlaneLift_projection (w : RegularHalfPlane) :
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+        (SpecialPeriods.triangleRegularProject (reflectedHalfPlaneLift w)) =
+      halfPlaneConjugateValue w := by
+  apply Subtype.ext
+  exact circleReflection_halfPlaneLift_projection w
+
+private def PeriodFamily.Meridians.normalizationReversesMeridians : Bool :=
+  Decidable.decide (0 < RiemannMapping.normalizationOrientation)
+
+private theorem PeriodFamily.Meridians.halfCircle_im_nonneg_mo1973_23809 (t : unitInterval) :
+    0 ≤ (SpecialPeriods.Triangle.meridianHalfCircle t).im := by
+  rw [SpecialPeriods.Triangle.meridianHalfCircle, circleMap_zero_im]
+  apply mul_nonneg (by norm_num)
+  exact
+    Real.sin_nonneg_of_nonneg_of_le_pi (mul_nonneg Real.pi_pos.le t.property.1)
+      (by nlinarith [Real.pi_pos, t.property.2])
+
+private theorem PeriodFamily.Meridians.upperZeroPath_im_nonneg (t : unitInterval) :
+    0 ≤ (SpecialPeriods.Triangle.upperZeroPath t : ℂ).im :=
+  halfCircle_im_nonneg_mo1973_23809 t
+
+private theorem PeriodFamily.Meridians.lowerZeroPath_im_nonpos (t : unitInterval) :
+    (SpecialPeriods.Triangle.lowerZeroPath t : ℂ).im ≤ 0 := by
+  change (conj (SpecialPeriods.Triangle.meridianHalfCircle t)).im ≤ 0
+  simpa using halfCircle_im_nonneg_mo1973_23809 t
+
+private theorem PeriodFamily.Meridians.upperOnePath_im_nonneg (t : unitInterval) :
+    0 ≤ (SpecialPeriods.Triangle.upperOnePath t : ℂ).im := by
+  change 0 ≤ (1 - conj (SpecialPeriods.Triangle.meridianHalfCircle t)).im
+  simpa using halfCircle_im_nonneg_mo1973_23809 t
+
+private theorem PeriodFamily.Meridians.lowerOnePath_im_nonpos (t : unitInterval) :
+    (SpecialPeriods.Triangle.lowerOnePath t : ℂ).im ≤ 0 := by
+  change (1 - SpecialPeriods.Triangle.meridianHalfCircle t).im ≤ 0
+  simpa using halfCircle_im_nonneg_mo1973_23809 t
+
+private def PeriodFamily.Meridians.zeroHalfPath :
+    Path SpecialPeriods.Triangle.meridianBasepoint SpecialPeriods.Triangle.meridianLeftPoint :=
+  if 0 < RiemannMapping.normalizationOrientation then SpecialPeriods.Triangle.upperZeroPath
+  else SpecialPeriods.Triangle.lowerZeroPath
+
+private def PeriodFamily.Meridians.oneHalfPath :
+    Path SpecialPeriods.Triangle.meridianBasepoint SpecialPeriods.Triangle.meridianRightPoint :=
+  if 0 < RiemannMapping.normalizationOrientation then SpecialPeriods.Triangle.upperOnePath
+  else SpecialPeriods.Triangle.lowerOnePath
+
+private def PeriodFamily.Meridians.oppositeZeroPath :
+    Path SpecialPeriods.Triangle.meridianBasepoint SpecialPeriods.Triangle.meridianLeftPoint :=
+  if 0 < RiemannMapping.normalizationOrientation then SpecialPeriods.Triangle.lowerZeroPath
+  else SpecialPeriods.Triangle.upperZeroPath
+
+private def PeriodFamily.Meridians.oppositeOnePath :
+    Path SpecialPeriods.Triangle.meridianBasepoint SpecialPeriods.Triangle.meridianRightPoint :=
+  if 0 < RiemannMapping.normalizationOrientation then SpecialPeriods.Triangle.lowerOnePath
+  else SpecialPeriods.Triangle.upperOnePath
+
+private theorem PeriodFamily.Meridians.zeroHalfPath_mem_halfPlane (t : unitInterval) :
+    0 ≤ RiemannMapping.normalizationOrientation * (zeroHalfPath t : ℂ).im := by
+  by_cases ho : 0 < RiemannMapping.normalizationOrientation
+  · rw [zeroHalfPath, ite_eq_left ho]
+    exact mul_nonneg ho.le (upperZeroPath_im_nonneg t)
+  · rw [zeroHalfPath, ite_eq_right ho]
+    exact mul_nonneg_of_nonpos_of_nonpos (le_of_not_gt ho) (lowerZeroPath_im_nonpos t)
+
+private theorem PeriodFamily.Meridians.oneHalfPath_mem_halfPlane (t : unitInterval) :
+    0 ≤ RiemannMapping.normalizationOrientation * (oneHalfPath t : ℂ).im := by
+  by_cases ho : 0 < RiemannMapping.normalizationOrientation
+  · rw [oneHalfPath, ite_eq_left ho]
+    exact mul_nonneg ho.le (upperOnePath_im_nonneg t)
+  · rw [oneHalfPath, ite_eq_right ho]
+    exact mul_nonneg_of_nonpos_of_nonpos (le_of_not_gt ho) (lowerOnePath_im_nonpos t)
+
+private theorem PeriodFamily.Meridians.oppositeZeroPath_coe (t : unitInterval) :
+    (oppositeZeroPath t : ℂ) = conj (zeroHalfPath t : ℂ) := by
+  by_cases ho : 0 < RiemannMapping.normalizationOrientation
+  · rw [oppositeZeroPath, zeroHalfPath, ite_eq_left ho, ite_eq_left ho]
+    rfl
+  · rw [oppositeZeroPath, zeroHalfPath, ite_eq_right ho, ite_eq_right ho]
+    exact (Complex.conj_conj (SpecialPeriods.Triangle.meridianHalfCircle t)).symm
+
+private theorem PeriodFamily.Meridians.oppositeOnePath_coe (t : unitInterval) :
+    (oppositeOnePath t : ℂ) = conj (oneHalfPath t : ℂ) := by
+  by_cases ho : 0 < RiemannMapping.normalizationOrientation
+  · rw [oppositeOnePath, oneHalfPath, ite_eq_left ho, ite_eq_left ho]
+    change
+      1 - SpecialPeriods.Triangle.meridianHalfCircle t =
+        conj (1 - conj (SpecialPeriods.Triangle.meridianHalfCircle t))
+    simp only [map_sub, map_one, Complex.conj_conj]
+  · rw [oppositeOnePath, oneHalfPath, ite_eq_right ho, ite_eq_right ho]
+    change
+      1 - conj (SpecialPeriods.Triangle.meridianHalfCircle t) =
+        conj (1 - SpecialPeriods.Triangle.meridianHalfCircle t)
+    simp only [map_sub, map_one]
+
+private def PeriodFamily.Meridians.compatiblePlanarMeridian (b : Bool) :
+    Path SpecialPeriods.Triangle.meridianBasepoint SpecialPeriods.Triangle.meridianBasepoint :=
+  if b then oneHalfPath.trans oppositeOnePath.symm else oppositeZeroPath.trans zeroHalfPath.symm
+
+private theorem PeriodFamily.Meridians.compatiblePlanarMeridian_eq (b : Bool) :
+    compatiblePlanarMeridian b =
+      if 0 < RiemannMapping.normalizationOrientation then
+        (if b then SpecialPeriods.Triangle.positiveMeridianOne
+          else SpecialPeriods.Triangle.positiveMeridianZero).symm
+      else
+        if b then SpecialPeriods.Triangle.positiveMeridianOne
+        else SpecialPeriods.Triangle.positiveMeridianZero := by
+  cases b <;> by_cases ho : 0 < RiemannMapping.normalizationOrientation <;>
+    simp [compatiblePlanarMeridian, zeroHalfPath, oneHalfPath, oppositeZeroPath, oppositeOnePath,
+      ho, SpecialPeriods.Triangle.positiveMeridianZero,
+      SpecialPeriods.Triangle.positiveMeridianOne, Path.trans_symm, Path.symm_symm]
+
+private theorem PeriodFamily.Meridians.compatiblePlanarMeridian_class (b : Bool) :
+    FundamentalGroup.fromPath (Path.Homotopic.Quotient.mk (compatiblePlanarMeridian b)) =
+      FreeMeridianMarking.orientedClass normalizationReversesMeridians b := by
+  rw [compatiblePlanarMeridian_eq]
+  by_cases ho : 0 < RiemannMapping.normalizationOrientation
+  · simp only [ite_eq_left ho, FreeMeridianMarking.orientedClass, normalizationReversesMeridians,
+      decide_eq_true_eq.mpr ho, ↓reduceIte]
+    rfl
+  · simp only [ite_eq_right ho, FreeMeridianMarking.orientedClass, normalizationReversesMeridians,
+      decide_eq_false_iff_not.mpr ho, Bool.false_eq_true, ↓reduceIte]
+    rfl
+
+private theorem PeriodFamily.Meridians.norm_mono_of_re_eq_im_le_mo1973_23882 {a z : ℂ}
+    (hre : z.re = a.re) (ha : 0 ≤ a.im) (him : a.im ≤ z.im) : ‖a‖ ≤ ‖z‖ := by
+  have hi : a.im ^ 2 ≤ z.im ^ 2 := (sq_le_sq₀ ha (ha.trans him)).mpr him
+  apply (sq_le_sq₀ (norm_nonneg a) (norm_nonneg z)).mp
+  rw [← Complex.normSq_eq_norm_sq, ← Complex.normSq_eq_norm_sq]
+  simp only [Complex.normSq_apply, hre]
+  nlinarith
+
+private theorem PeriodFamily.Meridians.halfFordRegion_vertical_mono (a z : ℍ)
+    (ha : a ∈ SpecialPeriods.Triangle.halfFordRegion) (hre : z.re = a.re) (him : a.im ≤ z.im) :
+    z ∈ SpecialPeriods.Triangle.halfFordRegion := by
+  have hn : ‖(a : ℂ)‖ ≤ ‖(z : ℂ)‖ := norm_mono_of_re_eq_im_le_mo1973_23882 hre a.im_pos.le him
+  have hp : ‖(a : ℂ) + 1‖ ≤ ‖(z : ℂ) + 1‖ := by
+    apply norm_mono_of_re_eq_im_le_mo1973_23882
+    · simpa only [Complex.add_re, Complex.one_re, UpperHalfPlane.coe_re] using
+        congrArg (fun x : ℝ => x + 1) hre
+    · simpa only [Complex.add_im, Complex.one_im, add_zero, UpperHalfPlane.coe_im] using
+        a.im_pos.le
+    · simpa only [Complex.add_im, Complex.one_im, add_zero, UpperHalfPlane.coe_im] using him
+  refine ⟨⟨hre ▸ ha.1.1, hre ▸ ha.1.2.1, ha.1.2.2.1.trans hp, ha.1.2.2.2.trans hn⟩, ?_⟩
+  change z.re ≤ -(1 / 2)
+  rw [hre]
+  exact ha.2
+
+private theorem PeriodFamily.Meridians.circle_left_re_lt_right_re_mo1973_23890 :
+    SpecialPeriods.Triangle.centerTwo.re < SpecialPeriods.Triangle.centerOne.re := by
+  change (SpecialPeriods.Triangle.centerTwo : ℂ).re < (SpecialPeriods.Triangle.centerOne : ℂ).re
+  rw [SpecialPeriods.Triangle.centerTwo_coe_re, SpecialPeriods.Triangle.centerOne_coe_re]
+  exact SpecialPeriods.Triangle.stripLeft_lt_right
+
+private def PeriodFamily.Meridians.halfFordCircleReal (t : unitInterval) : ℝ :=
+  (1 - (t : ℝ)) * SpecialPeriods.Triangle.centerOne.re +
+    (t : ℝ) * SpecialPeriods.Triangle.centerTwo.re
+
+@[fun_prop]
+private theorem
+    PeriodFamily.Meridians.halfFordCircleReal_continuous : Continuous halfFordCircleReal := by
+  unfold halfFordCircleReal
+  fun_prop
+
+private theorem
+    PeriodFamily.Meridians.halfFordCircleReal_strictAnti : StrictAnti halfFordCircleReal := by
+  intro s t hst
+  have ht : (s : ℝ) < (t : ℝ) := hst
+  have hp := mul_pos (sub_pos.mpr ht) (sub_pos.mpr circle_left_re_lt_right_re_mo1973_23890)
+  dsimp only [halfFordCircleReal]
+  nlinarith
+
+private theorem PeriodFamily.Meridians.halfFordCircleReal_mem (t : unitInterval) :
+    halfFordCircleReal t ∈ Set.Icc SpecialPeriods.Triangle.stripLeft (-1 / 2) := by
+  have hbounds :
+    SpecialPeriods.Triangle.centerTwo.re ≤ halfFordCircleReal t ∧
+      halfFordCircleReal t ≤ SpecialPeriods.Triangle.centerOne.re := by
+    constructor
+    · dsimp only [halfFordCircleReal]
+      nlinarith [mul_nonneg (sub_nonneg.mpr t.property.2)
+          (sub_nonneg.mpr circle_left_re_lt_right_re_mo1973_23890.le)]
+    · dsimp only [halfFordCircleReal]
+      nlinarith [mul_nonneg t.property.1
+          (sub_nonneg.mpr circle_left_re_lt_right_re_mo1973_23890.le)]
+  have h₁ : SpecialPeriods.Triangle.centerOne.re = -1 / 2 :=
+    SpecialPeriods.Triangle.centerOne_coe_re
+  have h₂ : SpecialPeriods.Triangle.centerTwo.re = SpecialPeriods.Triangle.stripLeft :=
+    SpecialPeriods.Triangle.centerTwo_coe_re
+  simpa only [Set.mem_Icc, h₁, h₂] using hbounds
+
+private theorem PeriodFamily.Meridians.boundaryCircle_norm_mo1973_23895 (x : ℝ)
+    (hl : SpecialPeriods.Triangle.stripLeft ≤ x) (hr : x ≤ -1 / 2) :
+    ‖(⟨x, SpecialPeriods.Triangle.boundaryHeight x⟩ : ℂ) + 1‖ = 1 := by
+  have hs : SpecialPeriods.Triangle.boundaryHeight x ^ 2 = 1 - (x + 1) ^ 2 :=
+    Real.sq_sqrt
+      (Real.sqrt_pos.mp (SpecialPeriods.Triangle.boundaryHeight_pos_of_closed_bounds hl hr)).le
+  apply (sq_eq_sq₀ (norm_nonneg _) (show (0 : ℝ) ≤ 1 by norm_num)).mp
+  rw [← Complex.normSq_eq_norm_sq]
+  simp only [Complex.normSq_apply, Complex.add_re, Complex.add_im, Complex.one_re, Complex.one_im,
+    add_zero, one_pow]
+  nlinarith
+
+private def PeriodFamily.Meridians.halfFordCirclePoint (t : unitInterval) :
+    SpecialPeriods.Triangle.halfFordRegion :=
+  ⟨⟨⟨halfFordCircleReal t, SpecialPeriods.Triangle.boundaryHeight (halfFordCircleReal t)⟩,
+      SpecialPeriods.Triangle.boundaryHeight_pos_of_closed_bounds (halfFordCircleReal_mem t).1
+        (halfFordCircleReal_mem t).2⟩,
+    by
+    apply (SpecialPeriods.Triangle.coe_mem_triangleClosedRegion_iff_halfFordRegion _).mp
+    apply (SpecialPeriods.Triangle.mem_triangleClosedRegion_iff_epigraph _).mpr
+    exact ⟨(halfFordCircleReal_mem t).1, (halfFordCircleReal_mem t).2, le_rfl⟩⟩
+
+@[simp]
+private theorem PeriodFamily.Meridians.halfFordCirclePoint_re (t : unitInterval) :
+    (halfFordCirclePoint t : ℍ).re =
+      (1 - (t : ℝ)) * SpecialPeriods.Triangle.centerOne.re +
+        (t : ℝ) * SpecialPeriods.Triangle.centerTwo.re :=
+  rfl
+
+@[simp]
+private theorem PeriodFamily.Meridians.halfFordCirclePoint_im (t : unitInterval) :
+    (halfFordCirclePoint t : ℍ).im =
+      SpecialPeriods.Triangle.boundaryHeight (halfFordCirclePoint t : ℍ).re :=
+  rfl
+
+private theorem
+    PeriodFamily.Meridians.halfFordCirclePoint_continuous : Continuous halfFordCirclePoint := by
+  have hc :
+    Continuous
+      (fun t : unitInterval =>
+        (⟨halfFordCircleReal t, SpecialPeriods.Triangle.boundaryHeight (halfFordCircleReal t)⟩ :
+          ℂ)) := by
+    simp_rw [Complex.mk_eq_add_mul_I]
+    exact
+      (Complex.continuous_ofReal.comp halfFordCircleReal_continuous).add
+        ((Complex.continuous_ofReal.comp
+              (SpecialPeriods.Triangle.continuous_boundaryHeight.comp
+                halfFordCircleReal_continuous)).mul
+          continuous_const)
+  exact (hc.upperHalfPlaneMk _).subtype_mk _
+
+@[simp]
+private theorem PeriodFamily.Meridians.halfFordCirclePoint_norm_add_one (t : unitInterval) :
+    ‖((halfFordCirclePoint t : ℍ) : ℂ) + 1‖ = 1 :=
+  boundaryCircle_norm_mo1973_23895 _ (halfFordCircleReal_mem t).1 (halfFordCircleReal_mem t).2
+
+@[simp]
+private theorem PeriodFamily.Meridians.halfFordCirclePoint_zero :
+    halfFordCirclePoint 0 =
+      (⟨SpecialPeriods.Triangle.centerOne, SpecialPeriods.Triangle.centerOne_mem_halfFordRegion⟩ :
+        SpecialPeriods.Triangle.halfFordRegion) := by
+  apply Subtype.ext
+  apply UpperHalfPlane.ext
+  apply SpecialPeriods.Triangle.complex_eq_of_re_eq_norm_add_one_eq
+  · change
+      (1 - (0 : ℝ)) * SpecialPeriods.Triangle.centerOne.re +
+          0 * SpecialPeriods.Triangle.centerTwo.re =
+        SpecialPeriods.Triangle.centerOne.re
+    simp
+  · exact (halfFordCirclePoint 0 : ℍ).im_pos
+  · exact SpecialPeriods.Triangle.centerOne.im_pos
+  · rw [halfFordCirclePoint_norm_add_one, SpecialPeriods.Triangle.centerOne_norm_add_one]
+
+@[simp]
+private theorem PeriodFamily.Meridians.halfFordCirclePoint_one :
+    halfFordCirclePoint 1 =
+      (⟨SpecialPeriods.Triangle.centerTwo, SpecialPeriods.Triangle.centerTwo_mem_halfFordRegion⟩ :
+        SpecialPeriods.Triangle.halfFordRegion) := by
+  apply Subtype.ext
+  apply UpperHalfPlane.ext
+  apply SpecialPeriods.Triangle.complex_eq_of_re_eq_norm_add_one_eq
+  · change
+      (1 - (1 : ℝ)) * SpecialPeriods.Triangle.centerOne.re +
+          1 * SpecialPeriods.Triangle.centerTwo.re =
+        SpecialPeriods.Triangle.centerTwo.re
+    simp
+  · exact (halfFordCirclePoint 1 : ℍ).im_pos
+  · exact SpecialPeriods.Triangle.centerTwo.im_pos
+  · rw [halfFordCirclePoint_norm_add_one, SpecialPeriods.Triangle.centerTwo_norm_add_one]
+
+private theorem PeriodFamily.Meridians.halfFordCirclePoint_injective :
+    Function.Injective halfFordCirclePoint := by
+  intro s t h
+  apply halfFordCircleReal_strictAnti.injective
+  exact congrArg (fun z : SpecialPeriods.Triangle.halfFordRegion => (z : ℍ).re) h
+
+private theorem PeriodFamily.Meridians.halfFordCirclePoint_range :
+    Set.range halfFordCirclePoint =
+      {z : SpecialPeriods.Triangle.halfFordRegion | ‖((z : ℍ) : ℂ) + 1‖ = 1} := by
+  ext z
+  constructor
+  · rintro ⟨t, rfl⟩
+    exact halfFordCirclePoint_norm_add_one t
+  · intro hz
+    have hclosed :=
+      (SpecialPeriods.Triangle.coe_mem_triangleClosedRegion_iff_halfFordRegion (z : ℍ)).mpr
+        z.property
+    have hl : SpecialPeriods.Triangle.centerTwo.re ≤ (z : ℍ).re := by
+      change (SpecialPeriods.Triangle.centerTwo : ℂ).re ≤ ((z : ℍ) : ℂ).re
+      rw [SpecialPeriods.Triangle.centerTwo_coe_re]
+      exact hclosed.1
+    have hr : (z : ℍ).re ≤ SpecialPeriods.Triangle.centerOne.re := by
+      change ((z : ℍ) : ℂ).re ≤ (SpecialPeriods.Triangle.centerOne : ℂ).re
+      rw [SpecialPeriods.Triangle.centerOne_coe_re]
+      exact hclosed.2.1
+    have hd : 0 < SpecialPeriods.Triangle.centerOne.re - SpecialPeriods.Triangle.centerTwo.re :=
+      sub_pos.mpr circle_left_re_lt_right_re_mo1973_23890
+    let t : unitInterval :=
+      ⟨(SpecialPeriods.Triangle.centerOne.re - (z : ℍ).re) /
+          (SpecialPeriods.Triangle.centerOne.re - SpecialPeriods.Triangle.centerTwo.re),
+        div_nonneg (sub_nonneg.mpr hr) hd.le, (div_le_one hd).mpr (by linarith)⟩
+    have ht : halfFordCircleReal t = (z : ℍ).re := by
+      dsimp only [halfFordCircleReal, t]
+      field_simp [hd.ne']
+      ring
+    refine ⟨t, ?_⟩
+    apply Subtype.ext
+    apply UpperHalfPlane.ext
+    apply SpecialPeriods.Triangle.complex_eq_of_re_eq_norm_add_one_eq
+    · exact ht
+    · exact (halfFordCirclePoint t : ℍ).im_pos
+    · exact (z : ℍ).im_pos
+    · exact (halfFordCirclePoint_norm_add_one t).trans hz.symm
+
+private def PeriodFamily.Meridians.halfFordCirclePath :
+    Path
+      (⟨SpecialPeriods.Triangle.centerOne, SpecialPeriods.Triangle.centerOne_mem_halfFordRegion⟩ :
+        SpecialPeriods.Triangle.halfFordRegion)
+      ⟨SpecialPeriods.Triangle.centerTwo, SpecialPeriods.Triangle.centerTwo_mem_halfFordRegion⟩
+    where
+  toFun := halfFordCirclePoint
+  continuous_toFun := halfFordCirclePoint_continuous
+  source' := halfFordCirclePoint_zero
+  target' := halfFordCirclePoint_one
+
+private def PeriodFamily.Meridians.boundaryRise_mo1973_23910 (t : ℝ) : ℝ :=
+  Max.max (-t) 0 + Max.max (t - 1) 0
+
+private theorem PeriodFamily.Meridians.boundaryRise_nonneg_mo1973_23911 (t : ℝ) :
+    0 ≤ boundaryRise_mo1973_23910 t :=
+  add_nonneg (le_max_right _ _) (le_max_right _ _)
+
+private theorem PeriodFamily.Meridians.boundaryRise_of_nonpos_mo1973_23912 {t : ℝ} (ht : t ≤ 0) :
+    boundaryRise_mo1973_23910 t = -t := by
+  rw [boundaryRise_mo1973_23910, max_eq_left (by linarith), max_eq_right (by linarith), add_zero]
+
+private theorem PeriodFamily.Meridians.boundaryRise_of_unit_mo1973_23913 {t : ℝ} (ht0 : 0 ≤ t)
+    (ht1 : t ≤ 1) : boundaryRise_mo1973_23910 t = 0 := by
+  rw [boundaryRise_mo1973_23910, max_eq_right (by linarith), max_eq_right (by linarith), add_zero]
+
+private theorem PeriodFamily.Meridians.boundaryRise_of_one_le_mo1973_23914 {t : ℝ} (ht : 1 ≤ t) :
+    boundaryRise_mo1973_23910 t = t - 1 := by
+  rw [boundaryRise_mo1973_23910, max_eq_right (by linarith), max_eq_left (by linarith), zero_add]
+
+private def PeriodFamily.Meridians.halfFordBoundaryParam (t : ℝ) :
+    SpecialPeriods.Triangle.halfFordRegion :=
+  let a : SpecialPeriods.Triangle.halfFordRegion := halfFordCirclePath.extend t
+  let z : ℍ :=
+    ⟨⟨(a : ℍ).re, (a : ℍ).im + boundaryRise_mo1973_23910 t⟩,
+      lt_of_lt_of_le (a : ℍ).im_pos (le_add_of_nonneg_right (boundaryRise_nonneg_mo1973_23911 t))⟩
+  ⟨z,
+    halfFordRegion_vertical_mono a z a.property rfl
+      (le_add_of_nonneg_right (boundaryRise_nonneg_mo1973_23911 t))⟩
+
+private theorem PeriodFamily.Meridians.halfFordBoundaryParam_re_mo1973_23916 (t : ℝ) :
+    (halfFordBoundaryParam t : ℍ).re = (halfFordCirclePath.extend t : ℍ).re :=
+  rfl
+
+private theorem PeriodFamily.Meridians.halfFordBoundaryParam_im_mo1973_23917 (t : ℝ) :
+    (halfFordBoundaryParam t : ℍ).im =
+      (halfFordCirclePath.extend t : ℍ).im + boundaryRise_mo1973_23910 t :=
+  rfl
+
+@[fun_prop]
+private theorem PeriodFamily.Meridians.continuous_halfFordBoundaryParam :
+    Continuous halfFordBoundaryParam := by
+  have hbase : Continuous (fun t : ℝ => (halfFordCirclePath.extend t : ℍ)) :=
+    continuous_subtype_val.comp halfFordCirclePath.continuous_extend
+  have hr : Continuous (fun t : ℝ => boundaryRise_mo1973_23910 t) := by
+    unfold boundaryRise_mo1973_23910
+    fun_prop
+  apply Continuous.subtype_mk
+  apply Continuous.upperHalfPlaneMk
+  simp_rw [Complex.mk_eq_add_mul_I]
+  exact
+    (Complex.continuous_ofReal.comp (UpperHalfPlane.continuous_re.comp hbase)).add
+      ((Complex.continuous_ofReal.comp ((UpperHalfPlane.continuous_im.comp hbase).add hr)).mul
+        continuous_const)
+
+private theorem PeriodFamily.Meridians.halfFordBoundaryParam_re_of_nonpos {t : ℝ} (ht : t ≤ 0) :
+    (halfFordBoundaryParam t : ℍ).re = SpecialPeriods.Triangle.centerOne.re := by
+  rw [halfFordBoundaryParam_re_mo1973_23916, halfFordCirclePath.extend_of_le_zero ht]
+
+private theorem PeriodFamily.Meridians.halfFordBoundaryParam_im_of_nonpos {t : ℝ} (ht : t ≤ 0) :
+    (halfFordBoundaryParam t : ℍ).im = SpecialPeriods.Triangle.centerOne.im - t := by
+  rw [halfFordBoundaryParam_im_mo1973_23917, halfFordCirclePath.extend_of_le_zero ht,
+    boundaryRise_of_nonpos_mo1973_23912 ht]
+  rfl
+
+private theorem PeriodFamily.Meridians.halfFordBoundaryParam_eq_circle {t : ℝ} (ht0 : 0 ≤ t)
+    (ht1 : t ≤ 1) : halfFordBoundaryParam t = halfFordCirclePoint ⟨t, ht0, ht1⟩ := by
+  apply Subtype.ext
+  apply UpperHalfPlane.ext_re_im
+  · rw [halfFordBoundaryParam_re_mo1973_23916, Path.extend_apply _ ⟨ht0, ht1⟩]
+    rfl
+  · rw [halfFordBoundaryParam_im_mo1973_23917, Path.extend_apply _ ⟨ht0, ht1⟩,
+      boundaryRise_of_unit_mo1973_23913 ht0 ht1, add_zero]
+    rfl
+
+private theorem PeriodFamily.Meridians.halfFordBoundaryParam_re_of_one_le {t : ℝ} (ht : 1 ≤ t) :
+    (halfFordBoundaryParam t : ℍ).re = SpecialPeriods.Triangle.centerTwo.re := by
+  rw [halfFordBoundaryParam_re_mo1973_23916, halfFordCirclePath.extend_of_one_le ht]
+
+private theorem PeriodFamily.Meridians.halfFordBoundaryParam_im_of_one_le {t : ℝ} (ht : 1 ≤ t) :
+    (halfFordBoundaryParam t : ℍ).im = SpecialPeriods.Triangle.centerTwo.im + t - 1 := by
+  rw [halfFordBoundaryParam_im_mo1973_23917, halfFordCirclePath.extend_of_one_le ht,
+    boundaryRise_of_one_le_mo1973_23914 ht]
+  ring
+
+@[simp]
+private theorem PeriodFamily.Meridians.halfFordBoundaryParam_zero :
+    halfFordBoundaryParam 0 =
+      (⟨SpecialPeriods.Triangle.centerOne, SpecialPeriods.Triangle.centerOne_mem_halfFordRegion⟩ :
+        SpecialPeriods.Triangle.halfFordRegion) := by
+  rw [halfFordBoundaryParam_eq_circle (by norm_num) (by norm_num)]
+  exact halfFordCirclePoint_zero
+
+@[simp]
+private theorem PeriodFamily.Meridians.halfFordBoundaryParam_one :
+    halfFordBoundaryParam 1 =
+      (⟨SpecialPeriods.Triangle.centerTwo, SpecialPeriods.Triangle.centerTwo_mem_halfFordRegion⟩ :
+        SpecialPeriods.Triangle.halfFordRegion) := by
+  rw [halfFordBoundaryParam_eq_circle (by norm_num) (by norm_num)]
+  exact halfFordCirclePoint_one
+
+private theorem PeriodFamily.Meridians.centerTwo_re_lt_centerOne_re_mo1973_23926 :
+    SpecialPeriods.Triangle.centerTwo.re < SpecialPeriods.Triangle.centerOne.re := by
+  change (SpecialPeriods.Triangle.centerTwo : ℂ).re < (SpecialPeriods.Triangle.centerOne : ℂ).re
+  rw [SpecialPeriods.Triangle.centerOne_coe_re, SpecialPeriods.Triangle.centerTwo_coe_re]
+  exact SpecialPeriods.Triangle.stripLeft_lt_right
+
+private theorem PeriodFamily.Meridians.halfFordBoundaryParam_re_eq_centerOne_iff (t : ℝ) :
+    (halfFordBoundaryParam t : ℍ).re = SpecialPeriods.Triangle.centerOne.re ↔ t ≤ 0 := by
+  constructor
+  · intro hr
+    by_contra ht
+    have ht0 : 0 < t := lt_of_not_ge ht
+    by_cases ht1 : t ≤ 1
+    · rw [halfFordBoundaryParam_eq_circle ht0.le ht1, halfFordCirclePoint_re] at hr
+      have hp := mul_pos ht0 (sub_pos.mpr centerTwo_re_lt_centerOne_re_mo1973_23926)
+      dsimp at hr
+      nlinarith
+    · rw [halfFordBoundaryParam_re_of_one_le (le_of_not_ge ht1)] at hr
+      exact centerTwo_re_lt_centerOne_re_mo1973_23926.ne hr
+  · exact halfFordBoundaryParam_re_of_nonpos
+
+private theorem PeriodFamily.Meridians.halfFordBoundaryParam_re_eq_centerTwo_iff (t : ℝ) :
+    (halfFordBoundaryParam t : ℍ).re = SpecialPeriods.Triangle.centerTwo.re ↔ 1 ≤ t := by
+  constructor
+  · intro hr
+    by_contra ht
+    have ht1 : t < 1 := lt_of_not_ge ht
+    by_cases ht0 : t ≤ 0
+    · rw [halfFordBoundaryParam_re_of_nonpos ht0] at hr
+      exact centerTwo_re_lt_centerOne_re_mo1973_23926.ne' hr
+    · rw [halfFordBoundaryParam_eq_circle (le_of_not_ge ht0) ht1.le, halfFordCirclePoint_re] at hr
+      have hp := mul_pos (sub_pos.mpr ht1) (sub_pos.mpr centerTwo_re_lt_centerOne_re_mo1973_23926)
+      dsimp at hr
+      nlinarith
+  · exact halfFordBoundaryParam_re_of_one_le
+
+private theorem PeriodFamily.Meridians.halfFordBoundaryParam_re_eq_right_iff (t : ℝ) :
+    (halfFordBoundaryParam t : ℍ).re = -(1 / 2) ↔ t ≤ 0 := by
+  have h : SpecialPeriods.Triangle.centerOne.re = -(1 / 2) := by
+    change (SpecialPeriods.Triangle.centerOne : ℂ).re = -(1 / 2)
+    simpa only [neg_div] using SpecialPeriods.Triangle.centerOne_coe_re
+  rw [← h]
+  exact halfFordBoundaryParam_re_eq_centerOne_iff t
+
+private theorem PeriodFamily.Meridians.halfFordBoundaryParam_re_eq_left_iff (t : ℝ) :
+    (halfFordBoundaryParam t : ℍ).re = SpecialPeriods.Triangle.stripLeft ↔ 1 ≤ t := by
+  rw [← SpecialPeriods.Triangle.centerTwo_coe_re]
+  exact halfFordBoundaryParam_re_eq_centerTwo_iff t
+
+private theorem PeriodFamily.Meridians.halfFordBoundaryParam_norm_add_one_eq_one_iff (t : ℝ) :
+    ‖((halfFordBoundaryParam t : ℍ) : ℂ) + 1‖ = 1 ↔ 0 ≤ t ∧ t ≤ 1 := by
+  constructor
+  · intro hn
+    by_cases ht0 : t ≤ 0
+    · have he : ((halfFordBoundaryParam t : ℍ) : ℂ) = (SpecialPeriods.Triangle.centerOne : ℂ) :=
+        SpecialPeriods.Triangle.complex_eq_of_re_eq_norm_add_one_eq
+          (halfFordBoundaryParam_re_of_nonpos ht0) (halfFordBoundaryParam t : ℍ).im_pos
+          SpecialPeriods.Triangle.centerOne.im_pos
+          (hn.trans SpecialPeriods.Triangle.centerOne_norm_add_one.symm)
+      have hi := congrArg Complex.im he
+      change (halfFordBoundaryParam t : ℍ).im = SpecialPeriods.Triangle.centerOne.im at hi
+      rw [halfFordBoundaryParam_im_of_nonpos ht0] at hi
+      have ht : t = 0 := by linarith
+      subst t
+      norm_num
+    · by_cases ht1 : 1 ≤ t
+      · have he : ((halfFordBoundaryParam t : ℍ) : ℂ) = (SpecialPeriods.Triangle.centerTwo : ℂ) :=
+          SpecialPeriods.Triangle.complex_eq_of_re_eq_norm_add_one_eq
+            (halfFordBoundaryParam_re_of_one_le ht1) (halfFordBoundaryParam t : ℍ).im_pos
+            SpecialPeriods.Triangle.centerTwo.im_pos
+            (hn.trans SpecialPeriods.Triangle.centerTwo_norm_add_one.symm)
+        have hi := congrArg Complex.im he
+        change (halfFordBoundaryParam t : ℍ).im = SpecialPeriods.Triangle.centerTwo.im at hi
+        rw [halfFordBoundaryParam_im_of_one_le ht1] at hi
+        have ht : t = 1 := by linarith
+        subst t
+        norm_num
+      · exact ⟨le_of_not_ge ht0, le_of_not_ge ht1⟩
+  · rintro ⟨ht0, ht1⟩
+    rw [halfFordBoundaryParam_eq_circle ht0 ht1]
+    exact halfFordCirclePoint_norm_add_one _
+
+private theorem PeriodFamily.Meridians.halfFordBoundaryParam_notMem_interior (t : ℝ) :
+    (halfFordBoundaryParam t : ℍ) ∉ SpecialPeriods.Triangle.halfFordInterior := by
+  intro hi
+  have hI : ((halfFordBoundaryParam t : ℍ) : ℂ) ∈ SpecialPeriods.Triangle.triangleInterior := by
+    simpa only [SpecialPeriods.Triangle.halfFordInterior_eq_preimage_triangleInterior,
+      Set.mem_preimage] using hi
+  by_cases ht0 : t ≤ 0
+  · have hr := halfFordBoundaryParam_re_eq_right_iff t |>.mpr ht0
+    have hu := hI.2.1
+    change (halfFordBoundaryParam t : ℍ).re < -1 / 2 at hu
+    linarith
+  · by_cases ht1 : 1 ≤ t
+    · have hr := halfFordBoundaryParam_re_eq_left_iff t |>.mpr ht1
+      have hl := hI.1
+      change SpecialPeriods.Triangle.stripLeft < (halfFordBoundaryParam t : ℍ).re at hl
+      linarith
+    · have hn :=
+        (halfFordBoundaryParam_norm_add_one_eq_one_iff t).mpr ⟨le_of_not_ge ht0, le_of_not_ge ht1⟩
+      have hgt := hI.2.2.2
+      rw [hn] at hgt
+      exact lt_irrefl _ hgt
+
+private theorem PeriodFamily.Meridians.halfFordBoundaryParam_injective :
+    Function.Injective halfFordBoundaryParam := by
+  intro s t he
+  have hr := congrArg (fun z : SpecialPeriods.Triangle.halfFordRegion => (z : ℍ).re) he
+  have hi := congrArg (fun z : SpecialPeriods.Triangle.halfFordRegion => (z : ℍ).im) he
+  by_cases hs0 : s ≤ 0
+  · have ht0 : t ≤ 0 :=
+      (halfFordBoundaryParam_re_eq_centerOne_iff t).mp
+        (hr.symm.trans (halfFordBoundaryParam_re_of_nonpos hs0))
+    rw [halfFordBoundaryParam_im_of_nonpos hs0, halfFordBoundaryParam_im_of_nonpos ht0] at hi
+    linarith
+  · by_cases hs1 : 1 ≤ s
+    · have ht1 : 1 ≤ t :=
+        (halfFordBoundaryParam_re_eq_centerTwo_iff t).mp
+          (hr.symm.trans (halfFordBoundaryParam_re_of_one_le hs1))
+      rw [halfFordBoundaryParam_im_of_one_le hs1, halfFordBoundaryParam_im_of_one_le ht1] at hi
+      linarith
+    · have hs : 0 ≤ s ∧ s ≤ 1 := ⟨le_of_not_ge hs0, le_of_not_ge hs1⟩
+      have ht : 0 ≤ t ∧ t ≤ 1 := by
+        apply (halfFordBoundaryParam_norm_add_one_eq_one_iff t).mp
+        rw [← he]
+        exact (halfFordBoundaryParam_norm_add_one_eq_one_iff s).mpr hs
+      rw [halfFordBoundaryParam_eq_circle hs.1 hs.2,
+        halfFordBoundaryParam_eq_circle ht.1 ht.2] at he
+      exact congrArg Subtype.val (halfFordCirclePoint_injective he)
+
+private theorem PeriodFamily.Meridians.centerOne_im_eq_boundaryHeight_mo1973_23934 :
+    SpecialPeriods.Triangle.centerOne.im =
+      SpecialPeriods.Triangle.boundaryHeight SpecialPeriods.Triangle.centerOne.re := by
+  simpa only [halfFordCirclePoint_zero] using halfFordCirclePoint_im 0
+
+private theorem PeriodFamily.Meridians.centerTwo_im_eq_boundaryHeight_mo1973_23935 :
+    SpecialPeriods.Triangle.centerTwo.im =
+      SpecialPeriods.Triangle.boundaryHeight SpecialPeriods.Triangle.centerTwo.re := by
+  simpa only [halfFordCirclePoint_one] using halfFordCirclePoint_im 1
+
+private theorem PeriodFamily.Meridians.halfFordBoundaryParam_range :
+    Set.range halfFordBoundaryParam =
+      {z : SpecialPeriods.Triangle.halfFordRegion |
+        (z : ℍ) ∉ SpecialPeriods.Triangle.halfFordInterior} := by
+  ext z
+  constructor
+  · rintro ⟨t, rfl⟩
+    exact halfFordBoundaryParam_notMem_interior t
+  · intro hz
+    have hclosed : ((z : ℍ) : ℂ) ∈ SpecialPeriods.Triangle.triangleClosedRegion :=
+      (SpecialPeriods.Triangle.coe_mem_triangleClosedRegion_iff_halfFordRegion _).mpr z.property
+    have hheight : SpecialPeriods.Triangle.boundaryHeight (z : ℍ).re ≤ (z : ℍ).im :=
+      (SpecialPeriods.Triangle.mem_triangleClosedRegion_iff_epigraph _).mp hclosed |>.2.2
+    by_cases hr : (z : ℍ).re = SpecialPeriods.Triangle.centerOne.re
+    · have hi : SpecialPeriods.Triangle.centerOne.im ≤ (z : ℍ).im := by
+        simpa only [hr, ← centerOne_im_eq_boundaryHeight_mo1973_23934] using hheight
+      have ht : SpecialPeriods.Triangle.centerOne.im - (z : ℍ).im ≤ 0 := sub_nonpos.mpr hi
+      refine
+        ⟨SpecialPeriods.Triangle.centerOne.im - (z : ℍ).im,
+          Subtype.ext (UpperHalfPlane.ext_re_im ?_ ?_)⟩
+      · exact (halfFordBoundaryParam_re_of_nonpos ht).trans hr.symm
+      · rw [halfFordBoundaryParam_im_of_nonpos ht]
+        ring
+    · by_cases hl : (z : ℍ).re = SpecialPeriods.Triangle.centerTwo.re
+      · have hi : SpecialPeriods.Triangle.centerTwo.im ≤ (z : ℍ).im := by
+          simpa only [hl, ← centerTwo_im_eq_boundaryHeight_mo1973_23935] using hheight
+        have ht : 1 ≤ 1 + (z : ℍ).im - SpecialPeriods.Triangle.centerTwo.im := by linarith
+        refine
+          ⟨1 + (z : ℍ).im - SpecialPeriods.Triangle.centerTwo.im,
+            Subtype.ext (UpperHalfPlane.ext_re_im ?_ ?_)⟩
+        · exact (halfFordBoundaryParam_re_of_one_le ht).trans hl.symm
+        · rw [halfFordBoundaryParam_im_of_one_le ht]
+          ring
+      · have hnorm : ‖((z : ℍ) : ℂ) + 1‖ = 1 := by
+          by_contra hn
+          have hleft : SpecialPeriods.Triangle.stripLeft < (z : ℍ).re := by
+            have hc : SpecialPeriods.Triangle.centerTwo.re = SpecialPeriods.Triangle.stripLeft :=
+              SpecialPeriods.Triangle.centerTwo_coe_re
+            have hne : (z : ℍ).re ≠ SpecialPeriods.Triangle.stripLeft := fun he =>
+              hl (he.trans hc.symm)
+            exact lt_of_le_of_ne hclosed.1 hne.symm
+          have hright : (z : ℍ).re < -1 / 2 := by
+            have hc : SpecialPeriods.Triangle.centerOne.re = -1 / 2 :=
+              SpecialPeriods.Triangle.centerOne_coe_re
+            have hne : (z : ℍ).re ≠ -1 / 2 := fun he => hr (he.trans hc.symm)
+            exact lt_of_le_of_ne hclosed.2.1 hne
+          apply hz
+          rw [SpecialPeriods.Triangle.halfFordInterior_eq_preimage_triangleInterior]
+          exact
+            ⟨hleft, hright, (z : ℍ).im_pos, lt_of_le_of_ne hclosed.2.2.2 (fun he => hn he.symm)⟩
+        have hc : z ∈ Set.range halfFordCirclePoint := by
+          rw [halfFordCirclePoint_range]
+          exact hnorm
+        obtain ⟨t, rfl⟩ := hc
+        exact ⟨t, halfFordBoundaryParam_eq_circle t.property.1 t.property.2⟩
+
+private theorem PeriodFamily.Meridians.halfFordBoundaryParam_mem_boundary_mo1973_23937 (t : ℝ) :
+    (halfFordBoundaryParam t : ℍ) ∉ SpecialPeriods.Triangle.halfFordInterior := by
+  change
+    halfFordBoundaryParam t ∈
+      {z : SpecialPeriods.Triangle.halfFordRegion |
+        (z : ℍ) ∉ SpecialPeriods.Triangle.halfFordInterior}
+  rw [← halfFordBoundaryParam_range]
+  exact Set.mem_range_self t
+
+private def PeriodFamily.Meridians.halfFordNormalizedBoundaryParam (t : ℝ) : ℝ :=
+  halfFordBoundaryValue (halfFordBoundaryParam t)
+
+private theorem PeriodFamily.Meridians.halfFordNormalizedBoundaryParam_continuous :
+    Continuous halfFordNormalizedBoundaryParam :=
+  halfFordBoundaryValue_continuous.comp continuous_halfFordBoundaryParam
+
+private theorem PeriodFamily.Meridians.halfFordNormalizedBoundaryParam_injective :
+    Function.Injective halfFordNormalizedBoundaryParam := by
+  intro s t h
+  apply halfFordBoundaryParam_injective
+  exact
+    halfFordBoundaryValue_injOn (halfFordBoundaryParam_mem_boundary_mo1973_23937 s)
+      (halfFordBoundaryParam_mem_boundary_mo1973_23937 t) h
+
+@[simp]
+private theorem PeriodFamily.Meridians.halfFordNormalizedBoundaryParam_zero :
+    halfFordNormalizedBoundaryParam 0 = 0 := by
+  rw [halfFordNormalizedBoundaryParam, halfFordBoundaryParam_zero,
+    halfFordBoundaryValue_centerOne]
+
+@[simp]
+private theorem PeriodFamily.Meridians.halfFordNormalizedBoundaryParam_one :
+    halfFordNormalizedBoundaryParam 1 = 1 := by
+  rw [halfFordNormalizedBoundaryParam, halfFordBoundaryParam_one, halfFordBoundaryValue_centerTwo]
+
+private theorem PeriodFamily.Meridians.halfFordNormalizedBoundaryParam_strictMono :
+    StrictMono halfFordNormalizedBoundaryParam := by
+  apply
+    (halfFordNormalizedBoundaryParam_continuous.strictMono_of_inj
+        halfFordNormalizedBoundaryParam_injective).resolve_right
+  intro h
+  have hh := h (show (0 : ℝ) < 1 by norm_num)
+  rw [halfFordNormalizedBoundaryParam_zero, halfFordNormalizedBoundaryParam_one] at hh
+  linarith
+
+private theorem PeriodFamily.Meridians.halfFordBoundaryValue_right_iff
+    (z : SpecialPeriods.Triangle.halfFordRegion)
+    (hz : (z : ℍ) ∉ SpecialPeriods.Triangle.halfFordInterior) :
+    (z : ℍ).re = -(1 / 2) ↔ halfFordBoundaryValue z ≤ 0 := by
+  have hm : z ∈ Set.range halfFordBoundaryParam := by
+    rw [halfFordBoundaryParam_range]
+    exact hz
+  obtain ⟨t, rfl⟩ := hm
+  rw [halfFordBoundaryParam_re_eq_right_iff]
+  change t ≤ 0 ↔ halfFordNormalizedBoundaryParam t ≤ 0
+  simpa only [halfFordNormalizedBoundaryParam_zero] using
+    (halfFordNormalizedBoundaryParam_strictMono.le_iff_le (a := t) (b := 0)).symm
+
+private theorem PeriodFamily.Meridians.halfFordBoundaryValue_left_iff
+    (z : SpecialPeriods.Triangle.halfFordRegion)
+    (hz : (z : ℍ) ∉ SpecialPeriods.Triangle.halfFordInterior) :
+    (z : ℍ).re = SpecialPeriods.Triangle.stripLeft ↔ 1 ≤ halfFordBoundaryValue z := by
+  have hm : z ∈ Set.range halfFordBoundaryParam := by
+    rw [halfFordBoundaryParam_range]
+    exact hz
+  obtain ⟨t, rfl⟩ := hm
+  rw [halfFordBoundaryParam_re_eq_left_iff]
+  change 1 ≤ t ↔ 1 ≤ halfFordNormalizedBoundaryParam t
+  simpa only [halfFordNormalizedBoundaryParam_one] using
+    (halfFordNormalizedBoundaryParam_strictMono.le_iff_le (a := 1) (b := t)).symm
+
+private theorem PeriodFamily.Meridians.halfFordBoundaryValue_circle_iff
+    (z : SpecialPeriods.Triangle.halfFordRegion)
+    (hz : (z : ℍ) ∉ SpecialPeriods.Triangle.halfFordInterior) :
+    ‖((z : ℍ) : ℂ) + 1‖ = 1 ↔ halfFordBoundaryValue z ∈ Set.Icc (0 : ℝ) 1 := by
+  have hm : z ∈ Set.range halfFordBoundaryParam := by
+    rw [halfFordBoundaryParam_range]
+    exact hz
+  obtain ⟨t, rfl⟩ := hm
+  rw [halfFordBoundaryParam_norm_add_one_eq_one_iff]
+  change
+    (0 ≤ t ∧ t ≤ 1) ↔
+      (0 ≤ halfFordNormalizedBoundaryParam t ∧ halfFordNormalizedBoundaryParam t ≤ 1)
+  apply and_congr
+  · simpa only [halfFordNormalizedBoundaryParam_zero] using
+      (halfFordNormalizedBoundaryParam_strictMono.le_iff_le (a := 0) (b := t)).symm
+  · simpa only [halfFordNormalizedBoundaryParam_one] using
+      (halfFordNormalizedBoundaryParam_strictMono.le_iff_le (a := t) (b := 1)).symm
+
+private theorem PeriodFamily.Meridians.halfFordRealPreimage_re_eq_right_iff (x : ℝ) :
+    (halfFordRealPreimage x : ℍ).re = -(1 / 2) ↔ x ≤ 0 := by
+  simpa only [halfFordBoundaryValue_realPreimage] using
+    halfFordBoundaryValue_right_iff (halfFordRealPreimage x)
+      (halfFordRealPreimage_not_mem_interior x)
+
+private theorem PeriodFamily.Meridians.halfFordRealPreimage_re_eq_left_iff (x : ℝ) :
+    (halfFordRealPreimage x : ℍ).re = SpecialPeriods.Triangle.stripLeft ↔ 1 ≤ x := by
+  simpa only [halfFordBoundaryValue_realPreimage] using
+    halfFordBoundaryValue_left_iff (halfFordRealPreimage x)
+      (halfFordRealPreimage_not_mem_interior x)
+
+private theorem PeriodFamily.Meridians.halfFordRealPreimage_norm_add_one_eq_one_iff (x : ℝ) :
+    ‖((halfFordRealPreimage x : ℍ) : ℂ) + 1‖ = 1 ↔ x ∈ Set.Icc (0 : ℝ) 1 := by
+  simpa only [halfFordBoundaryValue_realPreimage] using
+    halfFordBoundaryValue_circle_iff (halfFordRealPreimage x)
+      (halfFordRealPreimage_not_mem_interior x)
+
+private theorem PeriodFamily.Meridians.halfFordRealPreimage_rightReflection (x : ℝ) (hx : x ≤ 0) :
+    SpecialPeriods.Triangle.rightReflection (halfFordRealPreimage x : ℍ) =
+      (halfFordRealPreimage x : ℍ) :=
+  (SpecialPeriods.Triangle.rightReflection_fixed_iff _).mpr
+    ((halfFordRealPreimage_re_eq_right_iff x).mpr hx)
+
+private theorem PeriodFamily.Meridians.halfFordRealPreimage_leftReflection (x : ℝ) (hx : 1 ≤ x) :
+    SpecialPeriods.Triangle.leftReflection (halfFordRealPreimage x : ℍ) =
+      (halfFordRealPreimage x : ℍ) :=
+  (SpecialPeriods.Triangle.leftReflection_fixed_iff _).mpr
+    ((halfFordRealPreimage_re_eq_left_iff x).mpr hx)
+
+private theorem PeriodFamily.Meridians.halfFordRealPreimage_circleReflection (x : ℝ)
+    (hx : x ∈ Set.Icc (0 : ℝ) 1) :
+    SpecialPeriods.Triangle.circleReflection (halfFordRealPreimage x : ℍ) =
+      (halfFordRealPreimage x : ℍ) :=
+  (SpecialPeriods.Triangle.circleReflection_fixed_iff _).mpr
+    ((halfFordRealPreimage_norm_add_one_eq_one_iff x).mpr hx)
+
+private def PeriodFamily.Meridians.halfPlaneMeridianBasepoint : RegularHalfPlane :=
+  realHalfPlaneValue (1 / 2) (by norm_num) (by norm_num)
+
+private def PeriodFamily.Meridians.halfPlaneMeridianLeftPoint : RegularHalfPlane :=
+  realHalfPlaneValue (-1 / 2) (by norm_num) (by norm_num)
+
+private def PeriodFamily.Meridians.halfPlaneMeridianRightPoint : RegularHalfPlane :=
+  realHalfPlaneValue (3 / 2) (by norm_num) (by norm_num)
+
+@[simp]
+private theorem PeriodFamily.Meridians.halfPlaneValue_basepoint :
+    halfPlaneValue halfPlaneMeridianBasepoint = SpecialPeriods.Triangle.meridianBasepoint := by
+  apply Subtype.ext
+  norm_num [halfPlaneValue, halfPlaneMeridianBasepoint, realHalfPlaneValue,
+    SpecialPeriods.Triangle.meridianBasepoint]
+
+@[simp]
+private theorem PeriodFamily.Meridians.halfPlaneValue_leftPoint :
+    halfPlaneValue halfPlaneMeridianLeftPoint = SpecialPeriods.Triangle.meridianLeftPoint := by
+  apply Subtype.ext
+  norm_num [halfPlaneValue, halfPlaneMeridianLeftPoint, realHalfPlaneValue,
+    SpecialPeriods.Triangle.meridianLeftPoint]
+
+@[simp]
+private theorem PeriodFamily.Meridians.halfPlaneValue_rightPoint :
+    halfPlaneValue halfPlaneMeridianRightPoint = SpecialPeriods.Triangle.meridianRightPoint := by
+  apply Subtype.ext
+  norm_num [halfPlaneValue, halfPlaneMeridianRightPoint, realHalfPlaneValue,
+    SpecialPeriods.Triangle.meridianRightPoint]
+
+private def PeriodFamily.Meridians.normalizedRegularMeridianBasepoint :
+    SpecialPeriods.TriangleRegularPoint :=
+  halfPlaneLift halfPlaneMeridianBasepoint
+
+private def PeriodFamily.Meridians.normalizedRegularMeridianLeftPoint :
+    SpecialPeriods.TriangleRegularPoint :=
+  halfPlaneLift halfPlaneMeridianLeftPoint
+
+private def PeriodFamily.Meridians.normalizedRegularMeridianRightPoint :
+    SpecialPeriods.TriangleRegularPoint :=
+  halfPlaneLift halfPlaneMeridianRightPoint
+
+@[simp]
+private theorem PeriodFamily.Meridians.normalizedRegularMeridianBasepoint_coordinate :
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+        (SpecialPeriods.triangleRegularProject normalizedRegularMeridianBasepoint) =
+      SpecialPeriods.Triangle.meridianBasepoint := by
+  rw [normalizedRegularMeridianBasepoint, halfPlaneLift_projection, halfPlaneValue_basepoint]
+
+@[simp]
+private theorem PeriodFamily.Meridians.normalizedRegularMeridianLeftPoint_coordinate :
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+        (SpecialPeriods.triangleRegularProject normalizedRegularMeridianLeftPoint) =
+      SpecialPeriods.Triangle.meridianLeftPoint := by
+  rw [normalizedRegularMeridianLeftPoint, halfPlaneLift_projection, halfPlaneValue_leftPoint]
+
+@[simp]
+private theorem PeriodFamily.Meridians.normalizedRegularMeridianRightPoint_coordinate :
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+        (SpecialPeriods.triangleRegularProject normalizedRegularMeridianRightPoint) =
+      SpecialPeriods.Triangle.meridianRightPoint := by
+  rw [normalizedRegularMeridianRightPoint, halfPlaneLift_projection, halfPlaneValue_rightPoint]
+
+private theorem PeriodFamily.Meridians.normalizedRegularMeridianBasepoint_circleReflection :
+    SpecialPeriods.Triangle.circleReflection (normalizedRegularMeridianBasepoint : ℍ) =
+      (normalizedRegularMeridianBasepoint : ℍ) :=
+  halfFordRealPreimage_circleReflection (1 / 2) (by norm_num)
+
+private theorem PeriodFamily.Meridians.normalizedRegularMeridianLeftPoint_rightReflection :
+    SpecialPeriods.Triangle.rightReflection (normalizedRegularMeridianLeftPoint : ℍ) =
+      (normalizedRegularMeridianLeftPoint : ℍ) :=
+  halfFordRealPreimage_rightReflection (-1 / 2) (by norm_num)
+
+private theorem PeriodFamily.Meridians.normalizedRegularMeridianRightPoint_leftReflection :
+    SpecialPeriods.Triangle.leftReflection (normalizedRegularMeridianRightPoint : ℍ) =
+      (normalizedRegularMeridianRightPoint : ℍ) :=
+  halfFordRealPreimage_leftReflection (3 / 2) (by norm_num)
+
+@[simp]
+private theorem PeriodFamily.Meridians.reflectedHalfPlaneLift_basepoint :
+    reflectedHalfPlaneLift halfPlaneMeridianBasepoint = normalizedRegularMeridianBasepoint := by
+  apply Subtype.ext
+  exact normalizedRegularMeridianBasepoint_circleReflection
+
+private theorem PeriodFamily.Meridians.circleReflection_eq_inverse_generatorOne (z : ℍ)
+    (hz : SpecialPeriods.Triangle.rightReflection z = z) :
+    SpecialPeriods.Triangle.circleReflection z =
+      SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleGenerator₁⁻¹ z := by
+  rw [map_inv]
+  apply
+    (SpecialPeriods.triangleGeometricRepresentation
+        SpecialPeriods.triangleGenerator₁).eq_symm_apply.mpr
+  rw [SpecialPeriods.triangleGeometricRepresentation_generator₁_apply,
+    SpecialPeriods.Triangle.generatorOne_reflections,
+    SpecialPeriods.Triangle.circleReflection_involutive, hz]
+
+private theorem PeriodFamily.Meridians.circleReflection_eq_generatorTwo (z : ℍ)
+    (hz : SpecialPeriods.Triangle.leftReflection z = z) :
+    SpecialPeriods.Triangle.circleReflection z =
+      SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleGenerator₂ z := by
+  rw [SpecialPeriods.triangleGeometricRepresentation_generator₂_apply,
+    SpecialPeriods.Triangle.generatorTwo_reflections, hz]
+
+@[simp]
+private theorem PeriodFamily.Meridians.reflectedHalfPlaneLift_leftPoint :
+    reflectedHalfPlaneLift halfPlaneMeridianLeftPoint =
+      SpecialPeriods.triangleGenerator₁⁻¹ • normalizedRegularMeridianLeftPoint := by
+  apply Subtype.ext
+  exact
+    circleReflection_eq_inverse_generatorOne _ normalizedRegularMeridianLeftPoint_rightReflection
+
+@[simp]
+private theorem PeriodFamily.Meridians.reflectedHalfPlaneLift_rightPoint :
+    reflectedHalfPlaneLift halfPlaneMeridianRightPoint =
+      SpecialPeriods.triangleGenerator₂ • normalizedRegularMeridianRightPoint := by
+  apply Subtype.ext
+  exact circleReflection_eq_generatorTwo _ normalizedRegularMeridianRightPoint_leftReflection
+
+private def PeriodFamily.Meridians.halfPlaneZeroPath :
+    Path halfPlaneMeridianBasepoint halfPlaneMeridianLeftPoint
+    where
+  toFun t := ⟨⟨(zeroHalfPath t : ℂ), zeroHalfPath_mem_halfPlane t⟩, (zeroHalfPath t).property⟩
+  continuous_toFun :=
+    ((continuous_subtype_val.comp zeroHalfPath.continuous).subtype_mk _).subtype_mk _
+  source' := by
+    apply Subtype.ext
+    apply Subtype.ext
+    change (zeroHalfPath 0 : ℂ) = _
+    rw [Path.source]
+    norm_num [halfPlaneMeridianBasepoint, realHalfPlaneValue,
+      SpecialPeriods.Triangle.meridianBasepoint]
+  target' := by
+    apply Subtype.ext
+    apply Subtype.ext
+    change (zeroHalfPath 1 : ℂ) = _
+    rw [Path.target]
+    norm_num [halfPlaneMeridianLeftPoint, realHalfPlaneValue,
+      SpecialPeriods.Triangle.meridianLeftPoint]
+
+private def PeriodFamily.Meridians.halfPlaneOnePath :
+    Path halfPlaneMeridianBasepoint halfPlaneMeridianRightPoint
+    where
+  toFun t := ⟨⟨(oneHalfPath t : ℂ), oneHalfPath_mem_halfPlane t⟩, (oneHalfPath t).property⟩
+  continuous_toFun :=
+    ((continuous_subtype_val.comp oneHalfPath.continuous).subtype_mk _).subtype_mk _
+  source' := by
+    apply Subtype.ext
+    apply Subtype.ext
+    change (oneHalfPath 0 : ℂ) = _
+    rw [Path.source]
+    norm_num [halfPlaneMeridianBasepoint, realHalfPlaneValue,
+      SpecialPeriods.Triangle.meridianBasepoint]
+  target' := by
+    apply Subtype.ext
+    apply Subtype.ext
+    change (oneHalfPath 1 : ℂ) = _
+    rw [Path.target]
+    norm_num [halfPlaneMeridianRightPoint, realHalfPlaneValue,
+      SpecialPeriods.Triangle.meridianRightPoint]
+
+@[simp]
+private theorem PeriodFamily.Meridians.halfPlaneZeroPath_conjugateValue (t : unitInterval) :
+    halfPlaneConjugateValue (halfPlaneZeroPath t) = oppositeZeroPath t := by
+  apply Subtype.ext
+  exact (oppositeZeroPath_coe t).symm
+
+@[simp]
+private theorem PeriodFamily.Meridians.halfPlaneOnePath_conjugateValue (t : unitInterval) :
+    halfPlaneConjugateValue (halfPlaneOnePath t) = oppositeOnePath t := by
+  apply Subtype.ext
+  exact (oppositeOnePath_coe t).symm
+
+private def PeriodFamily.Meridians.liftedZeroHalfPath :
+    Path normalizedRegularMeridianBasepoint normalizedRegularMeridianLeftPoint :=
+  halfPlaneZeroPath.map halfPlaneLift_continuous
+
+private def PeriodFamily.Meridians.liftedOneHalfPath :
+    Path normalizedRegularMeridianBasepoint normalizedRegularMeridianRightPoint :=
+  halfPlaneOnePath.map halfPlaneLift_continuous
+
+private def PeriodFamily.Meridians.reflectedZeroHalfPath :
+    Path normalizedRegularMeridianBasepoint
+      (SpecialPeriods.triangleGenerator₁⁻¹ • normalizedRegularMeridianLeftPoint) :=
+  (halfPlaneZeroPath.map reflectedHalfPlaneLift_continuous).cast
+    reflectedHalfPlaneLift_basepoint.symm reflectedHalfPlaneLift_leftPoint.symm
+
+private def PeriodFamily.Meridians.reflectedOneHalfPath :
+    Path normalizedRegularMeridianBasepoint
+      (SpecialPeriods.triangleGenerator₂ • normalizedRegularMeridianRightPoint) :=
+  (halfPlaneOnePath.map reflectedHalfPlaneLift_continuous).cast
+    reflectedHalfPlaneLift_basepoint.symm reflectedHalfPlaneLift_rightPoint.symm
+
+@[simp]
+private theorem PeriodFamily.Meridians.liftedZeroHalfPath_coordinate (t : unitInterval) :
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+        (SpecialPeriods.triangleRegularProject (liftedZeroHalfPath t)) =
+      zeroHalfPath t :=
+  halfPlaneLift_projection (halfPlaneZeroPath t)
+
+@[simp]
+private theorem PeriodFamily.Meridians.liftedOneHalfPath_coordinate (t : unitInterval) :
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+        (SpecialPeriods.triangleRegularProject (liftedOneHalfPath t)) =
+      oneHalfPath t :=
+  halfPlaneLift_projection (halfPlaneOnePath t)
+
+@[simp]
+private theorem PeriodFamily.Meridians.reflectedZeroHalfPath_coordinate (t : unitInterval) :
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+        (SpecialPeriods.triangleRegularProject (reflectedZeroHalfPath t)) =
+      oppositeZeroPath t :=
+  (reflectedHalfPlaneLift_projection (halfPlaneZeroPath t)).trans
+    (halfPlaneZeroPath_conjugateValue t)
+
+@[simp]
+private theorem PeriodFamily.Meridians.reflectedOneHalfPath_coordinate (t : unitInterval) :
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+        (SpecialPeriods.triangleRegularProject (reflectedOneHalfPath t)) =
+      oppositeOnePath t :=
+  (reflectedHalfPlaneLift_projection (halfPlaneOnePath t)).trans
+    (halfPlaneOnePath_conjugateValue t)
+
+private def
+    PeriodFamily.Data.deckTransportHom {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [MulAction SpecialPeriods.TriangleGroup B]
+    (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) (b : B) :
+    FundamentalGroup D.BaseSpace (D.baseQuotient b) →* SpecialPeriods.TriangleGroup :=
+  (MulEquiv.inv' SpecialPeriods.TriangleGroup).symm.toMonoidHom.comp
+    (hq.fundamentalGroupToMulOpposite ⟨b, rfl⟩)
+
+private theorem PeriodFamily.Data.deckTransportHom_monodromy {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) (b : B)
+    (γ : FundamentalGroup D.BaseSpace (D.baseQuotient b)) :
+    (D.deckTransportHom hq b γ)⁻¹ • b = (hq.isCoveringMap.monodromy γ ⟨b, rfl⟩ : B) := by
+  change ((hq.fundamentalGroupToMulOpposite ⟨b, rfl⟩ γ).unop⁻¹)⁻¹ • b = _
+  rw [inv_inv]
+  exact hq.unop_fundamentalGroupToMulOpposite_smul
+
+private theorem PeriodFamily.Data.deckTransportHom_eq_of_inverse_endpoint {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) (b : B)
+    (γ : FundamentalGroup D.BaseSpace (D.baseQuotient b)) (g : SpecialPeriods.TriangleGroup)
+    (hγ : (hq.isCoveringMap.monodromy γ ⟨b, rfl⟩ : B) = g⁻¹ • b) :
+    D.deckTransportHom hq b γ = g := by
+  let := hq.isCancelSMul
+  apply inv_injective
+  exact IsCancelSMul.right_cancel _ _ b ((D.deckTransportHom_monodromy hq b γ).trans hγ)
+
+private def PeriodFamily.FlatTorus.periodVector : Lattice →+ RealPlane₄
+    where
+  toFun := Elliptic.realCast
+  map_zero' := by ext i; simp [Elliptic.realCast]
+  map_add' c d := by ext i; simp [Elliptic.realCast]
+
+private theorem
+    PeriodFamily.FlatTorus.periodVector_injective : Function.Injective periodVector := by
+  intro c d h
+  ext i
+  have hi : (c i : ℝ) = (d i : ℝ) := congrFun h i
+  exact_mod_cast hi
+
+private theorem PeriodFamily.FlatTorus.periodVector_mem_standardLattice (c : Lattice) :
+    periodVector c ∈ standardLattice :=
+  (Elliptic.standardLattice_mem_iff _).mpr ⟨c, rfl⟩
+
+private def PeriodFamily.FlatTorus.periodLatticeMap : Lattice →+ standardLattice :=
+  periodVector.codRestrict standardLattice.toAddSubgroup periodVector_mem_standardLattice
+
+private theorem
+    PeriodFamily.FlatTorus.periodLatticeMap_bijective : Function.Bijective periodLatticeMap :=
+  by
+  constructor
+  · intro c d h
+    exact periodVector_injective (congrArg Subtype.val h)
+  · intro z
+    obtain ⟨c, hc⟩ := (Elliptic.standardLattice_mem_iff z).mp z.property
+    exact ⟨c, Subtype.ext hc.symm⟩
+
+private def PeriodFamily.FlatTorus.periodLatticeEquiv : Lattice ≃+ standardLattice :=
+  AddEquiv.ofBijective periodLatticeMap periodLatticeMap_bijective
+
+private def PeriodFamily.FlatTorus.latticeEquiv : standardLattice ≃+ Lattice :=
+  periodLatticeEquiv.symm
+
+private theorem PeriodFamily.FlatTorus.periodVector_latticeEquiv (z : standardLattice) :
+    periodVector (latticeEquiv z) = z :=
+  congrArg Subtype.val (periodLatticeEquiv.apply_symm_apply z)
+
+private theorem PeriodFamily.FlatTorus.quotientCovering :
+    IsAddQuotientCoveringMap standardLattice.mkQ standardLattice.toAddSubgroup := by
+  apply standardLattice.toAddSubgroup.isAddQuotientCoveringMap_of_comm
+  change IsDiscrete (standardLattice : Set RealPlane₄)
+  let : DiscreteTopology (standardLattice : Set RealPlane₄) := standardLattice_discrete
+  exact DiscreteTopology.isDiscrete
+
+private def PeriodFamily.FlatTorus.zeroLift : standardLattice.mkQ ⁻¹' ({0} : Set RealTorus₄) :=
+  ⟨0, by simp⟩
+
+private def PeriodFamily.FlatTorus.fundamentalGroupEquiv :
+    FundamentalGroup RealTorus₄ 0 ≃* Multiplicative Lattice :=
+  ((quotientCovering.fundamentalGroupEquiv zeroLift).trans MulOpposite.opMulEquiv.symm).trans
+    latticeEquiv.toMultiplicative
+
+private theorem PeriodFamily.FlatTorus.fundamentalGroupEquiv_monodromy
+    (γ : FundamentalGroup RealTorus₄ 0) :
+    periodVector (fundamentalGroupEquiv γ).toAdd =
+      (quotientCovering.isCoveringMap.monodromy γ zeroLift : RealPlane₄) := by
+  have h := quotientCovering.unop_fundamentalGroupToMulOpposite_smul (e := zeroLift) (γ := γ)
+  change
+    periodVector
+        (latticeEquiv (quotientCovering.fundamentalGroupToMulOpposite zeroLift γ).unop.toAdd) =
+      _
+  rw [periodVector_latticeEquiv]
+  change
+    ((quotientCovering.fundamentalGroupToMulOpposite zeroLift γ).unop.toAdd : RealPlane₄) + 0 =
+      _ at h
+  simpa only [add_zero] using h
+
+private theorem PeriodFamily.FlatTorus.mkQ_periodVector (c : Lattice) :
+    standardLattice.mkQ (periodVector c) = 0 :=
+  (Submodule.Quotient.mk_eq_zero standardLattice).mpr (periodVector_mem_standardLattice c)
+
+private def PeriodFamily.FlatTorus.periodLoop (c : Lattice) : Path (0 : RealTorus₄) 0 :=
+  ((Path.segment (0 : RealPlane₄) (periodVector c)).map standardLattice.continuous_mkQ).cast
+    (map_zero standardLattice.mkQ).symm (mkQ_periodVector c).symm
+
+private theorem PeriodFamily.FlatTorus.periodLoop_apply (c : Lattice) (t : unitInterval) :
+    periodLoop c t = standardLattice.mkQ ((t : ℝ) • Elliptic.realCast c) := by
+  change standardLattice.mkQ (Path.segment (0 : RealPlane₄) (Elliptic.realCast c) t) = _
+  simp only [Path.segment_apply, AffineMap.lineMap_apply_module, smul_zero, zero_add]
+
+private theorem PeriodFamily.FlatTorus.periodLoop_monodromy (c : Lattice) :
+    quotientCovering.isCoveringMap.monodromy (FirstHurewicz.loopQuotient (periodLoop c))
+        zeroLift =
+      ⟨periodVector c, mkQ_periodVector c⟩ := by
+  apply
+    quotientCovering.isCoveringMap.monodromy_eq_of_map_eq
+      (Path.Homotopic.Quotient.mk (Path.segment (0 : RealPlane₄) (periodVector c)))
+  apply congrArg Path.Homotopic.Quotient.mk
+  ext t
+  rfl
+
+@[simp]
+private theorem PeriodFamily.FlatTorus.fundamentalGroupEquiv_periodLoop (c : Lattice) :
+    fundamentalGroupEquiv (FirstHurewicz.loopQuotient (periodLoop c)) = Multiplicative.ofAdd c := by
+  apply Multiplicative.toAdd.injective
+  apply periodVector_injective
+  rw [fundamentalGroupEquiv_monodromy, periodLoop_monodromy]
+  rfl
+
+private theorem PeriodFamily.FlatTorus.fundamentalGroupEquiv_symm_apply (c : Lattice) :
+    fundamentalGroupEquiv.symm (Multiplicative.ofAdd c) =
+      FirstHurewicz.loopQuotient (periodLoop c) := by
+  apply fundamentalGroupEquiv.injective
+  rw [MulEquiv.apply_symm_apply, fundamentalGroupEquiv_periodLoop]
+
+private def
+    PeriodFamily.FlatTorus.singularH1Equiv : FirstHurewicz.SingularH1 RealTorus₄ ≃ₗ[ℤ] Lattice :=
+  FirstHurewicz.singularH1EquivOfPi1 (0 : RealTorus₄) fundamentalGroupEquiv
+
+@[simp]
+private theorem
+    PeriodFamily.FlatTorus.singularH1Equiv_loopHomologyClass (p : Path (0 : RealTorus₄) 0) :
+    singularH1Equiv (FirstHurewicz.loopHomologyClass p) =
+      (fundamentalGroupEquiv (FirstHurewicz.loopQuotient p)).toAdd :=
+  FirstHurewicz.singularH1EquivOfPi1_loopHomologyClass (0 : RealTorus₄) fundamentalGroupEquiv p
+
+private theorem PeriodFamily.FlatTorus.singularH1Equiv_periodLoop (c : Lattice) :
+    singularH1Equiv (FirstHurewicz.loopHomologyClass (periodLoop c)) = c := by
+  rw [singularH1Equiv_loopHomologyClass, fundamentalGroupEquiv_periodLoop]
+  rfl
+
+@[simp]
+private theorem PeriodFamily.FlatTorus.singularH1Equiv_symm_apply (c : Lattice) :
+    singularH1Equiv.symm c = FirstHurewicz.loopHomologyClass (periodLoop c) := by
+  apply singularH1Equiv.injective
+  rw [LinearEquiv.apply_symm_apply, singularH1Equiv_periodLoop]
+
+private theorem PeriodFamily.FlatTorus.periodLoop_map_triangle (g : SpecialPeriods.TriangleGroup)
+    (c : Lattice) :
+    (periodLoop c).map (SpecialPeriods.triangleTorusHomeomorph g).continuous =
+      (periodLoop ((SpecialPeriods.triangleDualRepresentation g : LatticeMatrix) *ᵥ c)).cast
+        (SpecialPeriods.triangleTorusHomeomorph_zero g)
+        (SpecialPeriods.triangleTorusHomeomorph_zero g) := by
+  ext t
+  change
+    SpecialPeriods.triangleTorusHomeomorph g (periodLoop c t) =
+      periodLoop ((SpecialPeriods.triangleDualRepresentation g : LatticeMatrix) *ᵥ c) t
+  rw [periodLoop_apply, SpecialPeriods.triangleTorusHomeomorph_mkQ, periodLoop_apply, map_smul,
+    SpecialPeriods.triangleRealEquiv_realCast]
+
+private theorem PeriodFamily.FlatTorus.inducedHomology_periodLoop_triangle
+    (g : SpecialPeriods.TriangleGroup) (c : Lattice) :
+    FirstHurewicz.inducedHomology
+        (SpecialPeriods.triangleTorusHomeomorph g : C(RealTorus₄, RealTorus₄))
+        (FirstHurewicz.loopHomologyClass (periodLoop c)) =
+      FirstHurewicz.loopHomologyClass
+        (periodLoop ((SpecialPeriods.triangleDualRepresentation g : LatticeMatrix) *ᵥ c)) := by
+  rw [FirstHurewicz.inducedHomology_loopHomologyClass, periodLoop_map_triangle]
+  rfl
+
+private theorem PeriodFamily.FlatTorus.singularH1Equiv_inducedHomology_triangle
+    (g : SpecialPeriods.TriangleGroup) (a : FirstHurewicz.SingularH1 RealTorus₄) :
+    singularH1Equiv
+        (FirstHurewicz.inducedHomology
+          (SpecialPeriods.triangleTorusHomeomorph g : C(RealTorus₄, RealTorus₄)) a) =
+      (SpecialPeriods.triangleDualRepresentation g : LatticeMatrix) *ᵥ singularH1Equiv a := by
+  obtain ⟨c, rfl⟩ := singularH1Equiv.symm.surjective a
+  rw [singularH1Equiv_symm_apply, inducedHomology_periodLoop_triangle, singularH1Equiv_periodLoop,
+    singularH1Equiv_periodLoop]
+
+private theorem PeriodFamily.Data.periodEquiv_realCast {V B : Type} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) (b : B) (c : Lattice) :
+    D.periods.periodEquiv b (Elliptic.realCast c) = (D.periods.point b).periodVector c := by
+  rw [D.periodEquiv_matrix, PeriodDomain.periodVector_apply]
+  simp only [Elliptic.realCast, Complex.ofReal_intCast]
+
+private def PeriodFamily.Meridians.projectLift (b : SpecialPeriods.TriangleRegularPoint)
+    (g : SpecialPeriods.TriangleGroup) (δ : Path b (g⁻¹ • b)) :
+    Path (SpecialPeriods.triangleRegularProject b) (SpecialPeriods.triangleRegularProject b) :=
+  (δ.map SpecialPeriods.triangleRegularProject_covering.continuous).cast rfl
+    (SpecialPeriods.triangleRegularProject_covering.map_smul g⁻¹).symm
+
+private theorem
+    PeriodFamily.Meridians.projectLift_monodromy (b : SpecialPeriods.TriangleRegularPoint)
+    (g : SpecialPeriods.TriangleGroup) (δ : Path b (g⁻¹ • b)) :
+    SpecialPeriods.triangleRegularProject_covering.isCoveringMap.monodromy
+        (Path.Homotopic.Quotient.mk (projectLift b g δ)) ⟨b, rfl⟩ =
+      ⟨g⁻¹ • b, SpecialPeriods.triangleRegularProject_covering.map_smul g⁻¹⟩ := by
+  apply
+    SpecialPeriods.triangleRegularProject_covering.isCoveringMap.monodromy_eq_of_map_eq
+      (Path.Homotopic.Quotient.mk δ)
+  apply congrArg Path.Homotopic.Quotient.mk
+  ext t
+  rfl
+
+private theorem PeriodFamily.Meridians.trans_coordinate_mo1973_24201 {X Y : Type*}
+    [TopologicalSpace X] [TopologicalSpace Y] {a b c : X} {x y z : Y} (f : X → Y) (p : Path a b)
+    (q : Path b c) (α : Path x y) (β : Path y z) (hp : ∀ t : unitInterval, f (p t) = α t)
+    (hq : ∀ t : unitInterval, f (q t) = β t) (t : unitInterval) :
+    f ((p.trans q) t) = (α.trans β) t := by
+  simp only [Path.trans_apply]
+  split_ifs
+  · exact hp _
+  · exact hq _
+
+private def PeriodFamily.Meridians.liftedMeridianZero :
+    Path normalizedRegularMeridianBasepoint
+      (SpecialPeriods.triangleGenerator₁⁻¹ • normalizedRegularMeridianBasepoint) :=
+  reflectedZeroHalfPath.trans
+    (liftedZeroHalfPath.symm.map
+      (ContinuousConstSMul.continuous_const_smul SpecialPeriods.triangleGenerator₁⁻¹))
+
+private def PeriodFamily.Meridians.liftedMeridianOne :
+    Path normalizedRegularMeridianBasepoint
+      (SpecialPeriods.triangleGenerator₂⁻¹ • normalizedRegularMeridianBasepoint) :=
+  liftedOneHalfPath.trans
+    ((reflectedOneHalfPath.symm.map
+          (ContinuousConstSMul.continuous_const_smul SpecialPeriods.triangleGenerator₂⁻¹)).cast
+      (inv_smul_smul SpecialPeriods.triangleGenerator₂ normalizedRegularMeridianRightPoint).symm
+      rfl)
+
+private theorem PeriodFamily.Meridians.liftedMeridianZero_coordinate (t : unitInterval) :
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+        (SpecialPeriods.triangleRegularProject (liftedMeridianZero t)) =
+      compatiblePlanarMeridian Bool.false t := by
+  change
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+        (SpecialPeriods.triangleRegularProject
+          ((reflectedZeroHalfPath.trans
+              (liftedZeroHalfPath.symm.map
+                (ContinuousConstSMul.continuous_const_smul SpecialPeriods.triangleGenerator₁⁻¹)))
+            t)) =
+      (oppositeZeroPath.trans zeroHalfPath.symm) t
+  apply
+    trans_coordinate_mo1973_24201
+      (fun z =>
+        SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+          (SpecialPeriods.triangleRegularProject z))
+  · exact reflectedZeroHalfPath_coordinate
+  · intro s
+    change
+      SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+          (SpecialPeriods.triangleRegularProject
+            (SpecialPeriods.triangleGenerator₁⁻¹ • liftedZeroHalfPath (unitInterval.symm s))) =
+        zeroHalfPath (unitInterval.symm s)
+    rw [SpecialPeriods.triangleRegularProject_covering.map_smul]
+    exact liftedZeroHalfPath_coordinate _
+
+private theorem PeriodFamily.Meridians.liftedMeridianOne_coordinate (t : unitInterval) :
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+        (SpecialPeriods.triangleRegularProject (liftedMeridianOne t)) =
+      compatiblePlanarMeridian Bool.true t := by
+  change
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+        (SpecialPeriods.triangleRegularProject
+          ((liftedOneHalfPath.trans
+              ((reflectedOneHalfPath.symm.map
+                    (ContinuousConstSMul.continuous_const_smul
+                      SpecialPeriods.triangleGenerator₂⁻¹)).cast
+                (inv_smul_smul SpecialPeriods.triangleGenerator₂
+                    normalizedRegularMeridianRightPoint).symm
+                rfl))
+            t)) =
+      (oneHalfPath.trans oppositeOnePath.symm) t
+  apply
+    trans_coordinate_mo1973_24201
+      (fun z =>
+        SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+          (SpecialPeriods.triangleRegularProject z))
+  · exact liftedOneHalfPath_coordinate
+  · intro s
+    change
+      SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+          (SpecialPeriods.triangleRegularProject
+            (SpecialPeriods.triangleGenerator₂⁻¹ • reflectedOneHalfPath (unitInterval.symm s))) =
+        oppositeOnePath (unitInterval.symm s)
+    rw [SpecialPeriods.triangleRegularProject_covering.map_smul]
+    exact reflectedOneHalfPath_coordinate _
+
+private def PeriodFamily.Meridians.compatibleMeridianGenerator : Bool → SpecialPeriods.TriangleGroup
+  | false => SpecialPeriods.triangleGenerator₁
+  | true => SpecialPeriods.triangleGenerator₂
+
+private def PeriodFamily.Meridians.compatibleMeridianLift (b : Bool) :
+    Path normalizedRegularMeridianBasepoint
+      ((compatibleMeridianGenerator b)⁻¹ • normalizedRegularMeridianBasepoint) :=
+  match b with
+  | false => liftedMeridianZero
+  | true => liftedMeridianOne
+
+private theorem
+    PeriodFamily.Meridians.compatibleMeridianLift_coordinate (b : Bool) (t : unitInterval) :
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+        (SpecialPeriods.triangleRegularProject (compatibleMeridianLift b t)) =
+      compatiblePlanarMeridian b t := by
+  cases b
+  · exact liftedMeridianZero_coordinate t
+  · exact liftedMeridianOne_coordinate t
+
+private def PeriodFamily.Meridians.compatibleRegularMeridian (b : Bool) :
+    Path (SpecialPeriods.triangleRegularProject normalizedRegularMeridianBasepoint)
+      (SpecialPeriods.triangleRegularProject normalizedRegularMeridianBasepoint) :=
+  projectLift normalizedRegularMeridianBasepoint (compatibleMeridianGenerator b)
+    (compatibleMeridianLift b)
+
+@[simp]
+private theorem PeriodFamily.Meridians.compatibleRegularMeridian_coordinate (b : Bool)
+    (t : unitInterval) :
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph (compatibleRegularMeridian b t) =
+      compatiblePlanarMeridian b t :=
+  compatibleMeridianLift_coordinate b t
+
+private theorem PeriodFamily.Meridians.compatibleRegularMeridian_monodromy (b : Bool) :
+    (SpecialPeriods.triangleRegularProject_covering.isCoveringMap.monodromy
+          (Path.Homotopic.Quotient.mk (compatibleRegularMeridian b))
+          ⟨normalizedRegularMeridianBasepoint, rfl⟩ :
+        SpecialPeriods.TriangleRegularPoint) =
+      (compatibleMeridianGenerator b)⁻¹ • normalizedRegularMeridianBasepoint :=
+  congrArg Subtype.val (projectLift_monodromy _ _ _)
+
+private def PeriodFamily.Meridians.compatibleRegularMeridianClass (b : Bool) :
+    FundamentalGroup SpecialPeriods.TriangleRegularQuotient
+      (SpecialPeriods.triangleRegularProject normalizedRegularMeridianBasepoint) :=
+  FundamentalGroup.fromPath (Path.Homotopic.Quotient.mk (compatibleRegularMeridian b))
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Data.fundamentalGroupBasepoint {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) (b : B) : D.Space :=
+  D.quotient (b, 0)
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Data.flatFibreFundamentalGroupHom {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) (b : B) :
+    FundamentalGroup RealTorus₄ 0 →* FundamentalGroup D.Space (D.fundamentalGroupBasepoint b) :=
+  FundamentalGroup.map
+    ⟨fun x : RealTorus₄ => D.quotient (b, x),
+      D.quotient_continuous.comp (continuous_const.prodMk continuous_id)⟩
+    0
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Data.latticeFundamentalGroupHom {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) (b : B) :
+    Multiplicative Lattice →* FundamentalGroup D.Space (D.fundamentalGroupBasepoint b) :=
+  (D.flatFibreFundamentalGroupHom b).comp
+    PeriodFamily.FlatTorus.fundamentalGroupEquiv.symm.toMonoidHom
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Data.projectionFundamentalGroupHom {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) (b : B) :
+    FundamentalGroup D.Space (D.fundamentalGroupBasepoint b) →*
+      FundamentalGroup D.BaseSpace (D.baseQuotient b) :=
+  FundamentalGroup.map ⟨D.projection, D.projection_continuous⟩ (D.fundamentalGroupBasepoint b)
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Data.sectionFundamentalGroupHom {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) (b : B) :
+    FundamentalGroup D.BaseSpace (D.baseQuotient b) →*
+      FundamentalGroup D.Space (D.fundamentalGroupBasepoint b) :=
+  FundamentalGroup.map ⟨D.zeroSection, D.zeroSection_continuous⟩ (D.baseQuotient b)
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Data.projectionFundamentalGroupHom_comp_section {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) (b : B) :
+    (D.projectionFundamentalGroupHom b).comp (D.sectionFundamentalGroupHom b) =
+      MonoidHom.id (FundamentalGroup D.BaseSpace (D.baseQuotient b)) :=
+  DiagonalQuotient.projectionFundamentalGroupHom_comp_section (0 : RealTorus₄)
+    SpecialPeriods.triangleTorusAction_zero b
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Data.latticeFundamentalGroupHom_periodLoop {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) (b : B) (v : Lattice) :
+    D.latticeFundamentalGroupHom b (Multiplicative.ofAdd v) =
+      D.flatFibreFundamentalGroupHom b
+        (Path.Homotopic.Quotient.mk (PeriodFamily.FlatTorus.periodLoop v)) := by
+  change
+    D.flatFibreFundamentalGroupHom b
+        (PeriodFamily.FlatTorus.fundamentalGroupEquiv.symm (Multiplicative.ofAdd v)) =
+      _
+  rw [PeriodFamily.FlatTorus.fundamentalGroupEquiv_symm_apply]
+  rfl
+
+@[instance_reducible]
+private def
+    PeriodFamily.FlatTorus.instMulAction1 : MulAction SpecialPeriods.TriangleGroup RealTorus₄ :=
+  SpecialPeriods.triangleTorusAction
+
+attribute [local instance] PeriodFamily.FlatTorus.instMulAction1 in
+private theorem PeriodFamily.FlatTorus.instContinuousConstSMul1 :
+    ContinuousConstSMul SpecialPeriods.TriangleGroup RealTorus₄ :=
+  SpecialPeriods.triangleTorusAction_continuous
+
+attribute [local instance] PeriodFamily.FlatTorus.instMulAction1
+    PeriodFamily.FlatTorus.instContinuousConstSMul1 in
+private theorem PeriodFamily.FlatTorus.fibreActionFundamentalGroupHom_periodLoop
+    (g : SpecialPeriods.TriangleGroup) (c : Lattice) :
+    DiagonalQuotient.fibreActionFundamentalGroupHom (0 : RealTorus₄)
+        SpecialPeriods.triangleTorusAction_zero g (FirstHurewicz.loopQuotient (periodLoop c)) =
+      FirstHurewicz.loopQuotient
+        (periodLoop ((SpecialPeriods.triangleDualRepresentation g : LatticeMatrix) *ᵥ c)) := by
+  rw [DiagonalQuotient.fibreActionFundamentalGroupHom, FundamentalGroup.mapOfEq_apply]
+  change
+    Path.Homotopic.Quotient.mk
+        (((periodLoop c).map (SpecialPeriods.triangleTorusHomeomorph g).continuous).cast
+          (SpecialPeriods.triangleTorusHomeomorph_zero g).symm
+          (SpecialPeriods.triangleTorusHomeomorph_zero g).symm) =
+      _
+  rw [periodLoop_map_triangle]
+  rfl
+
+attribute [local instance] PeriodFamily.FlatTorus.instMulAction1
+    PeriodFamily.FlatTorus.instContinuousConstSMul1 in
+private theorem PeriodFamily.FlatTorus.fundamentalGroupEquiv_fibreAction
+    (g : SpecialPeriods.TriangleGroup) (γ : FundamentalGroup RealTorus₄ 0) :
+    fundamentalGroupEquiv
+        (DiagonalQuotient.fibreActionFundamentalGroupHom (0 : RealTorus₄)
+          SpecialPeriods.triangleTorusAction_zero g γ) =
+      SpecialPeriods.triangleLatticeMulAutHom g (fundamentalGroupEquiv γ) := by
+  obtain ⟨c, rfl⟩ := fundamentalGroupEquiv.symm.surjective γ
+  change
+    fundamentalGroupEquiv
+        (DiagonalQuotient.fibreActionFundamentalGroupHom (0 : RealTorus₄)
+          SpecialPeriods.triangleTorusAction_zero g
+          (fundamentalGroupEquiv.symm (Multiplicative.ofAdd c.toAdd))) =
+      _
+  rw [fundamentalGroupEquiv_symm_apply, fibreActionFundamentalGroupHom_periodLoop,
+    fundamentalGroupEquiv_periodLoop, MulEquiv.apply_symm_apply]
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Data.flatFibreFundamentalGroupHom_injective {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) (b : B) :
+    Function.Injective (D.flatFibreFundamentalGroupHom b) :=
+  DiagonalQuotient.fibreFundamentalGroupHom_injective hq b (0 : RealTorus₄)
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Data.latticeFundamentalGroupHom_injective {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) (b : B) :
+    Function.Injective (D.latticeFundamentalGroupHom b) :=
+  (D.flatFibreFundamentalGroupHom_injective hq b).comp
+    PeriodFamily.FlatTorus.fundamentalGroupEquiv.symm.injective
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Data.latticeFundamentalGroupHom_range_eq_ker {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) (b : B) :
+    (D.latticeFundamentalGroupHom b).range = (D.projectionFundamentalGroupHom b).ker := by
+  have hflat :
+    (D.flatFibreFundamentalGroupHom b).range = (D.projectionFundamentalGroupHom b).ker :=
+    DiagonalQuotient.fibreFundamentalGroupHom_range_eq_ker hq b (0 : RealTorus₄)
+  rw [← hflat]
+  ext γ
+  constructor
+  · rintro ⟨v, rfl⟩
+    exact ⟨PeriodFamily.FlatTorus.fundamentalGroupEquiv.symm v, rfl⟩
+  · rintro ⟨δ, rfl⟩
+    refine ⟨PeriodFamily.FlatTorus.fundamentalGroupEquiv δ, ?_⟩
+    change
+      D.flatFibreFundamentalGroupHom b
+          (PeriodFamily.FlatTorus.fundamentalGroupEquiv.symm
+            (PeriodFamily.FlatTorus.fundamentalGroupEquiv δ)) =
+        _
+    rw [MulEquiv.symm_apply_apply]
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Data.fundamentalGroupAction {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) (b : B) :
+    FundamentalGroup D.BaseSpace (D.baseQuotient b) →* MulAut (Multiplicative Lattice) :=
+  SpecialPeriods.triangleLatticeMulAutHom.comp (D.deckTransportHom hq b)
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Data.latticeFundamentalGroupHom_conjugation {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) (b : B)
+    (β : FundamentalGroup D.BaseSpace (D.baseQuotient b)) (v : Multiplicative Lattice) :
+    D.latticeFundamentalGroupHom b (D.fundamentalGroupAction hq b β v) =
+      D.sectionFundamentalGroupHom b β * D.latticeFundamentalGroupHom b v *
+        (D.sectionFundamentalGroupHom b β)⁻¹ := by
+  have hmark :
+    PeriodFamily.FlatTorus.fundamentalGroupEquiv.symm
+        (SpecialPeriods.triangleLatticeMulAutHom (D.deckTransportHom hq b β) v) =
+      DiagonalQuotient.fibreActionFundamentalGroupHom (0 : RealTorus₄)
+        SpecialPeriods.triangleTorusAction_zero (D.deckTransportHom hq b β)
+        (PeriodFamily.FlatTorus.fundamentalGroupEquiv.symm v) := by
+    apply PeriodFamily.FlatTorus.fundamentalGroupEquiv.injective
+    simp only [PeriodFamily.FlatTorus.fundamentalGroupEquiv_fibreAction,
+      MulEquiv.apply_symm_apply]
+  change
+    D.flatFibreFundamentalGroupHom b
+        (PeriodFamily.FlatTorus.fundamentalGroupEquiv.symm
+          (SpecialPeriods.triangleLatticeMulAutHom (D.deckTransportHom hq b β) v)) =
+      _
+  rw [hmark]
+  exact
+    (DiagonalQuotient.sectionFundamentalGroupHom_conjugate_fibre hq (0 : RealTorus₄)
+        SpecialPeriods.triangleTorusAction_zero b β
+        (PeriodFamily.FlatTorus.fundamentalGroupEquiv.symm v)).symm
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Data.semidirectFundamentalGroupEquiv {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) (b : B) :
+    (Multiplicative Lattice) ⋊[D.fundamentalGroupAction hq b]
+        (FundamentalGroup D.BaseSpace (D.baseQuotient b)) ≃*
+      FundamentalGroup D.Space (D.fundamentalGroupBasepoint b) :=
+  SplitGroupExtension.mulEquiv (D.latticeFundamentalGroupHom b)
+    (D.projectionFundamentalGroupHom b) (D.sectionFundamentalGroupHom b)
+    (D.fundamentalGroupAction hq b) (D.latticeFundamentalGroupHom_injective hq b)
+    (D.projectionFundamentalGroupHom_comp_section b)
+    (D.latticeFundamentalGroupHom_range_eq_ker hq b)
+    (D.latticeFundamentalGroupHom_conjugation hq b)
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Data.fundamentalGroupSemidirectEquiv {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) (b : B) :
+    FundamentalGroup D.Space (D.fundamentalGroupBasepoint b) ≃*
+      (Multiplicative Lattice) ⋊[D.fundamentalGroupAction hq b]
+        (FundamentalGroup D.BaseSpace (D.baseQuotient b)) :=
+  (D.semidirectFundamentalGroupEquiv hq b).symm
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+@[simp]
+private theorem PeriodFamily.Data.fundamentalGroupSemidirectEquiv_lattice {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) (b : B)
+    (v : Multiplicative Lattice) :
+    D.fundamentalGroupSemidirectEquiv hq b (D.latticeFundamentalGroupHom b v) =
+      SemidirectProduct.inl v :=
+  SplitGroupExtension.mulEquiv_symm_inclusion _ _ _ _ _ _ _ _ v
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+@[simp]
+private theorem PeriodFamily.Data.fundamentalGroupSemidirectEquiv_section {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) (b : B)
+    (β : FundamentalGroup D.BaseSpace (D.baseQuotient b)) :
+    D.fundamentalGroupSemidirectEquiv hq b (D.sectionFundamentalGroupHom b β) =
+      SemidirectProduct.inr β :=
+  SplitGroupExtension.mulEquiv_symm_section _ _ _ _ _ _ _ _ β
+
+private def PeriodFamily.Data.freeFundamentalGroupAction {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) (b : B)
+    (e : FundamentalGroup D.BaseSpace (D.baseQuotient b) ≃* FreeGroup Bool) :
+    FreeGroup Bool →* MulAut (Multiplicative Lattice) :=
+  (D.fundamentalGroupAction hq b).comp e.symm.toMonoidHom
+
+private def PeriodFamily.Data.semidirectFreeReparametrization {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) (b : B)
+    (e : FundamentalGroup D.BaseSpace (D.baseQuotient b) ≃* FreeGroup Bool) :
+    (Multiplicative Lattice) ⋊[D.fundamentalGroupAction hq b]
+        (FundamentalGroup D.BaseSpace (D.baseQuotient b)) ≃*
+      (Multiplicative Lattice) ⋊[D.freeFundamentalGroupAction hq b e] (FreeGroup Bool) := by
+  refine SemidirectProduct.congr (MulEquiv.refl (Multiplicative Lattice)) e ?_
+  intro β
+  apply MulEquiv.ext
+  intro v
+  change D.fundamentalGroupAction hq b β v = D.fundamentalGroupAction hq b (e.symm (e β)) v
+  rw [MulEquiv.symm_apply_apply]
+
+@[simp]
+private theorem
+    PeriodFamily.Data.semidirectFreeReparametrization_inl {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) (b : B)
+    (e : FundamentalGroup D.BaseSpace (D.baseQuotient b) ≃* FreeGroup Bool)
+    (v : Multiplicative Lattice) :
+    D.semidirectFreeReparametrization hq b e (SemidirectProduct.inl v) =
+      SemidirectProduct.inl v := by
+  apply SemidirectProduct.ext
+  · rfl
+  · exact e.map_one
+
+@[simp]
+private theorem
+    PeriodFamily.Data.semidirectFreeReparametrization_inr {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) (b : B)
+    (e : FundamentalGroup D.BaseSpace (D.baseQuotient b) ≃* FreeGroup Bool)
+    (β : FundamentalGroup D.BaseSpace (D.baseQuotient b)) :
+    D.semidirectFreeReparametrization hq b e (SemidirectProduct.inr β) =
+      SemidirectProduct.inr (e β) :=
+  rfl
+
+private def
+    PeriodFamily.Data.fundamentalGroupFreeSemidirectEquiv {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) (b : B)
+    (e : FundamentalGroup D.BaseSpace (D.baseQuotient b) ≃* FreeGroup Bool) :
+    FundamentalGroup D.Space (D.fundamentalGroupBasepoint b) ≃*
+      (Multiplicative Lattice) ⋊[D.freeFundamentalGroupAction hq b e] (FreeGroup Bool) :=
+  (D.fundamentalGroupSemidirectEquiv hq b).trans (D.semidirectFreeReparametrization hq b e)
+
+@[simp]
+private theorem PeriodFamily.Data.fundamentalGroupFreeSemidirectEquiv_lattice {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) (b : B)
+    (e : FundamentalGroup D.BaseSpace (D.baseQuotient b) ≃* FreeGroup Bool)
+    (v : Multiplicative Lattice) :
+    D.fundamentalGroupFreeSemidirectEquiv hq b e (D.latticeFundamentalGroupHom b v) =
+      SemidirectProduct.inl v := by
+  change
+    D.semidirectFreeReparametrization hq b e
+        (D.fundamentalGroupSemidirectEquiv hq b (D.latticeFundamentalGroupHom b v)) =
+      _
+  rw [D.fundamentalGroupSemidirectEquiv_lattice, D.semidirectFreeReparametrization_inl]
+
+@[simp]
+private theorem PeriodFamily.Data.fundamentalGroupFreeSemidirectEquiv_section {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup) (b : B)
+    (e : FundamentalGroup D.BaseSpace (D.baseQuotient b) ≃* FreeGroup Bool)
+    (β : FundamentalGroup D.BaseSpace (D.baseQuotient b)) :
+    D.fundamentalGroupFreeSemidirectEquiv hq b e (D.sectionFundamentalGroupHom b β) =
+      SemidirectProduct.inr (e β) := by
+  change
+    D.semidirectFreeReparametrization hq b e
+        (D.fundamentalGroupSemidirectEquiv hq b (D.sectionFundamentalGroupHom b β)) =
+      _
+  rw [D.fundamentalGroupSemidirectEquiv_section, D.semidirectFreeReparametrization_inr]
+
+private def PeriodFamily.Meridians.pointedHomeomorphFundamentalGroupEquiv_mo1973_24733
+    {X Y : Type*} [TopologicalSpace X] [TopologicalSpace Y] (e : X ≃ₜ Y) {x : X} {y : Y}
+    (h : e x = y) : FundamentalGroup X x ≃* FundamentalGroup Y y
+    where
+  __ := FundamentalGroup.mapOfEq ⟨e, e.continuous⟩ h
+  invFun :=
+    FundamentalGroup.mapOfEq ⟨e.symm, e.symm.continuous⟩
+      ((congrArg e.symm h).symm.trans (e.symm_apply_apply x))
+  left_inv
+    γ := by
+    change
+      FundamentalGroup.mapOfEq ⟨e.symm, e.symm.continuous⟩
+          ((congrArg e.symm h).symm.trans (e.symm_apply_apply x))
+          (FundamentalGroup.mapOfEq ⟨e, e.continuous⟩ h γ) =
+        γ
+    rw [FundamentalGroup.mapOfEq_apply, FundamentalGroup.mapOfEq_apply]
+    obtain ⟨γ⟩ := γ
+    apply congrArg Path.Homotopic.Quotient.mk
+    ext t
+    exact e.symm_apply_apply (γ t)
+  right_inv
+    γ := by
+    change
+      FundamentalGroup.mapOfEq ⟨e, e.continuous⟩ h
+          (FundamentalGroup.mapOfEq ⟨e.symm, e.symm.continuous⟩
+            ((congrArg e.symm h).symm.trans (e.symm_apply_apply x)) γ) =
+        γ
+    rw [FundamentalGroup.mapOfEq_apply, FundamentalGroup.mapOfEq_apply]
+    obtain ⟨γ⟩ := γ
+    apply congrArg Path.Homotopic.Quotient.mk
+    ext t
+    exact e.apply_symm_apply (γ t)
+
+private def PeriodFamily.Meridians.compatibleBasePlaneEquiv :
+    FundamentalGroup SpecialPeriods.TriangleRegularQuotient
+        (SpecialPeriods.triangleRegularProject normalizedRegularMeridianBasepoint) ≃*
+      FundamentalGroup SpecialPeriods.Triangle.TwicePuncturedPlane
+        SpecialPeriods.Triangle.meridianBasepoint :=
+  pointedHomeomorphFundamentalGroupEquiv_mo1973_24733
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+    normalizedRegularMeridianBasepoint_coordinate
+
+@[simp]
+private theorem PeriodFamily.Meridians.compatibleBasePlaneEquiv_apply
+    (γ :
+      FundamentalGroup SpecialPeriods.TriangleRegularQuotient
+        (SpecialPeriods.triangleRegularProject normalizedRegularMeridianBasepoint)) :
+    compatibleBasePlaneEquiv γ =
+      FundamentalGroup.mapOfEq
+        ⟨SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph,
+          SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.continuous⟩
+        normalizedRegularMeridianBasepoint_coordinate γ :=
+  rfl
+
+private theorem PeriodFamily.Meridians.compatibleBasePlaneEquiv_meridianClass (b : Bool) :
+    compatibleBasePlaneEquiv (compatibleRegularMeridianClass b) =
+      FreeMeridianMarking.orientedClass normalizationReversesMeridians b := by
+  rw [compatibleBasePlaneEquiv_apply, FundamentalGroup.mapOfEq_apply, ←
+    compatiblePlanarMeridian_class]
+  apply congrArg Path.Homotopic.Quotient.mk
+  apply Path.ext
+  funext t
+  exact compatibleRegularMeridian_coordinate b t
+
+private def PeriodFamily.Meridians.compatibleRegularFundamentalGroupEquiv :
+    FundamentalGroup SpecialPeriods.TriangleRegularQuotient
+        (SpecialPeriods.triangleRegularProject normalizedRegularMeridianBasepoint) ≃*
+      FreeGroup Bool :=
+  compatibleBasePlaneEquiv.trans
+    (FreeMeridianMarking.orientedEquiv normalizationReversesMeridians)
+
+@[simp]
+private theorem
+    PeriodFamily.Meridians.compatibleRegularFundamentalGroupEquiv_meridianClass (b : Bool) :
+    compatibleRegularFundamentalGroupEquiv (compatibleRegularMeridianClass b) = FreeGroup.of b := by
+  change
+    FreeMeridianMarking.orientedEquiv normalizationReversesMeridians
+        (compatibleBasePlaneEquiv (compatibleRegularMeridianClass b)) =
+      _
+  rw [compatibleBasePlaneEquiv_meridianClass, FreeMeridianMarking.orientedEquiv_orientedClass]
+
+@[simp]
+private theorem PeriodFamily.Meridians.compatibleRegularFundamentalGroupEquiv_symm_of (b : Bool) :
+    compatibleRegularFundamentalGroupEquiv.symm (FreeGroup.of b) =
+      compatibleRegularMeridianClass b := by
+  apply compatibleRegularFundamentalGroupEquiv.injective
+  rw [MulEquiv.apply_symm_apply, compatibleRegularFundamentalGroupEquiv_meridianClass]
+
+private def PeriodFamily.Meridians.sourceFreeTriangleHom :
+    FreeGroup Bool →* SpecialPeriods.TriangleGroup :=
+  FreeGroup.lift compatibleMeridianGenerator
+
+@[simp]
+private theorem PeriodFamily.Meridians.sourceFreeTriangleHom_of (b : Bool) :
+    sourceFreeTriangleHom (FreeGroup.of b) = compatibleMeridianGenerator b :=
+  FreeGroup.lift_apply_of
+
+private def PeriodFamily.Meridians.sourceFreeLatticeAction :
+    FreeGroup Bool →* MulAut (Multiplicative Lattice) :=
+  SpecialPeriods.triangleLatticeMulAutHom.comp sourceFreeTriangleHom
+
+@[simp]
+private theorem PeriodFamily.Meridians.sourceFreeLatticeAction_of (b : Bool) :
+    sourceFreeLatticeAction (FreeGroup.of b) =
+      SpecialPeriods.triangleLatticeMulAutHom (compatibleMeridianGenerator b) := by
+  change SpecialPeriods.triangleLatticeMulAutHom (sourceFreeTriangleHom (FreeGroup.of b)) = _
+  rw [sourceFreeTriangleHom_of]
+
+private theorem PeriodFamily.Meridians.sourceFreeLatticeAction_first (v : Multiplicative Lattice) :
+    (sourceFreeLatticeAction (FreeGroup.of Bool.false) v).toAdd = A₁ *ᵥ v.toAdd := by
+  rw [sourceFreeLatticeAction_of, SpecialPeriods.triangleLatticeMulAutHom_toAdd]
+  exact
+    congrArg (fun A : LatticeMatrix => A *ᵥ v.toAdd)
+      SpecialPeriods.triangleDualRepresentation_generator₁_matrix
+
+private theorem PeriodFamily.Meridians.sourceFreeLatticeAction_second (v : Multiplicative Lattice) :
+    (sourceFreeLatticeAction (FreeGroup.of Bool.true) v).toAdd = A₂ *ᵥ v.toAdd := by
+  rw [sourceFreeLatticeAction_of, SpecialPeriods.triangleLatticeMulAutHom_toAdd]
+  exact
+    congrArg (fun A : LatticeMatrix => A *ᵥ v.toAdd)
+      SpecialPeriods.triangleDualRepresentation_generator₂_matrix
+
+private theorem PeriodFamily.compatibleMeridian_deckTransport (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (b : Bool) :
+    ((regularData P h₁ h₂)).deckTransportHom (regularCovering P h₁ h₂)
+        (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+        (Meridians.compatibleRegularMeridianClass b) =
+      Meridians.compatibleMeridianGenerator b :=
+  ((regularData P h₁ h₂)).deckTransportHom_eq_of_inverse_endpoint (regularCovering P h₁ h₂)
+    (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint) _ _
+    (Meridians.compatibleRegularMeridian_monodromy b)
+
+private def PeriodFamily.markedRegularFundamentalGroupAction (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    FreeGroup Bool →* MulAut (Multiplicative Lattice) :=
+  ((regularData P h₁ h₂)).freeFundamentalGroupAction (regularCovering P h₁ h₂)
+    (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+    Meridians.compatibleRegularFundamentalGroupEquiv
+
+@[simp]
+private theorem PeriodFamily.markedRegularFundamentalGroupAction_of (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (b : Bool) :
+    markedRegularFundamentalGroupAction P h₁ h₂ (FreeGroup.of b) =
+      SpecialPeriods.triangleLatticeMulAutHom (Meridians.compatibleMeridianGenerator b) := by
+  change
+    SpecialPeriods.triangleLatticeMulAutHom
+        (((regularData P h₁ h₂)).deckTransportHom (regularCovering P h₁ h₂)
+          (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+          (Meridians.compatibleRegularFundamentalGroupEquiv.symm (FreeGroup.of b))) =
+      _
+  rw [Meridians.compatibleRegularFundamentalGroupEquiv_symm_of, compatibleMeridian_deckTransport]
+
+private theorem PeriodFamily.markedRegularFundamentalGroupAction_eq (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    markedRegularFundamentalGroupAction P h₁ h₂ = Meridians.sourceFreeLatticeAction := by
+  apply FreeGroup.ext_hom
+  intro b
+  rw [markedRegularFundamentalGroupAction_of, Meridians.sourceFreeLatticeAction_of]
+
+private def PeriodFamily.markedSemidirectReparametrization (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    (Multiplicative Lattice) ⋊[markedRegularFundamentalGroupAction P h₁ h₂] (FreeGroup Bool) ≃*
+      (Multiplicative Lattice) ⋊[Meridians.sourceFreeLatticeAction] (FreeGroup Bool) := by
+  refine SemidirectProduct.congr (MulEquiv.refl _) (MulEquiv.refl _) ?_
+  intro w
+  apply MulEquiv.ext
+  intro v
+  change markedRegularFundamentalGroupAction P h₁ h₂ w v = Meridians.sourceFreeLatticeAction w v
+  rw [markedRegularFundamentalGroupAction_eq]
+
+@[simp]
+private theorem PeriodFamily.markedSemidirectReparametrization_inl (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (v : Multiplicative Lattice) :
+    markedSemidirectReparametrization P h₁ h₂ (SemidirectProduct.inl v) =
+      SemidirectProduct.inl v :=
+  rfl
+
+@[simp]
+private theorem PeriodFamily.markedSemidirectReparametrization_inr (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (w : FreeGroup Bool) :
+    markedSemidirectReparametrization P h₁ h₂ (SemidirectProduct.inr w) =
+      SemidirectProduct.inr w :=
+  rfl
+
+private def PeriodFamily.markedRegularFundamentalGroupEquiv (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    FundamentalGroup ((regularData P h₁ h₂)).Space
+        (((regularData P h₁ h₂)).fundamentalGroupBasepoint
+          (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)) ≃*
+      (Multiplicative Lattice) ⋊[Meridians.sourceFreeLatticeAction] (FreeGroup Bool) :=
+  (((regularData P h₁ h₂)).fundamentalGroupFreeSemidirectEquiv (regularCovering P h₁ h₂)
+        (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+        Meridians.compatibleRegularFundamentalGroupEquiv).trans
+    (markedSemidirectReparametrization P h₁ h₂)
+
+@[simp]
+private theorem
+    PeriodFamily.markedRegularFundamentalGroupEquiv_lattice (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (v : Multiplicative Lattice) :
+    markedRegularFundamentalGroupEquiv P h₁ h₂
+        (((regularData P h₁ h₂)).latticeFundamentalGroupHom
+          (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint) v) =
+      SemidirectProduct.inl v := by
+  change
+    markedSemidirectReparametrization P h₁ h₂
+        (((regularData P h₁ h₂)).fundamentalGroupFreeSemidirectEquiv (regularCovering P h₁ h₂)
+          (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+          Meridians.compatibleRegularFundamentalGroupEquiv
+          (((regularData P h₁ h₂)).latticeFundamentalGroupHom
+            (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint) v)) =
+      _
+  exact
+    (congrArg (markedSemidirectReparametrization P h₁ h₂)
+          (((regularData P h₁ h₂)).fundamentalGroupFreeSemidirectEquiv_lattice
+            (regularCovering P h₁ h₂) (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+            Meridians.compatibleRegularFundamentalGroupEquiv v)).trans
+      (markedSemidirectReparametrization_inl P h₁ h₂ v)
+
+@[simp]
+private theorem
+    PeriodFamily.markedRegularFundamentalGroupEquiv_meridian (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (b : Bool) :
+    markedRegularFundamentalGroupEquiv P h₁ h₂
+        (((regularData P h₁ h₂)).sectionFundamentalGroupHom
+          (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+          (Meridians.compatibleRegularMeridianClass b)) =
+      SemidirectProduct.inr (FreeGroup.of b) := by
+  change
+    markedSemidirectReparametrization P h₁ h₂
+        (((regularData P h₁ h₂)).fundamentalGroupFreeSemidirectEquiv (regularCovering P h₁ h₂)
+          (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+          Meridians.compatibleRegularFundamentalGroupEquiv
+          (((regularData P h₁ h₂)).sectionFundamentalGroupHom
+            (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+            (Meridians.compatibleRegularMeridianClass b))) =
+      _
+  have hs :=
+    congrArg (markedSemidirectReparametrization P h₁ h₂)
+      (((regularData P h₁ h₂)).fundamentalGroupFreeSemidirectEquiv_section
+        (regularCovering P h₁ h₂) (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+        Meridians.compatibleRegularFundamentalGroupEquiv
+        (Meridians.compatibleRegularMeridianClass b))
+  exact
+    hs.trans
+      ((congrArg
+            (fun w : FreeGroup Bool =>
+              markedSemidirectReparametrization P h₁ h₂ (SemidirectProduct.inr w))
+            (Meridians.compatibleRegularFundamentalGroupEquiv_meridianClass b)).trans
+        (markedSemidirectReparametrization_inr P h₁ h₂ (FreeGroup.of b)))
+
+public
+theorem PeriodFamily.freeSemidirect_subgroup_eq_top {N α : Type*} [Group N]
+    (φ : FreeGroup α →* MulAut N) (S : Subgroup (N ⋊[φ] FreeGroup α))
+    (hN : ∀ n, SemidirectProduct.inl n ∈ S)
+    (hG : ∀ a, SemidirectProduct.inr (FreeGroup.of a) ∈ S) : S = ⊤ := by
+  have hc :
+    (⊤ : Subgroup (FreeGroup α)) ≤
+      S.comap (SemidirectProduct.inr : FreeGroup α →* N ⋊[φ] FreeGroup α) := by
+    rw [← FreeGroup.closure_range_of α]
+    apply (Subgroup.closure_le _).mpr
+    rintro _ ⟨a, rfl⟩
+    exact hG a
+  apply top_unique
+  intro x _
+  rw [← SemidirectProduct.inl_left_mul_inr_right x]
+  exact S.mul_mem (hN x.left) (hc (Subgroup.mem_top x.right))
+
+private def PeriodFamily.markedRegularFundamentalGroupGenerators (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    Set
+      (FundamentalGroup ((regularData P h₁ h₂)).Space
+        (((regularData P h₁ h₂)).fundamentalGroupBasepoint
+          (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint))) :=
+  Set.range
+      (((regularData P h₁ h₂)).latticeFundamentalGroupHom
+        (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)) ∪
+    Set.range
+      (fun b : Bool =>
+        ((regularData P h₁ h₂)).sectionFundamentalGroupHom
+          (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+          (Meridians.compatibleRegularMeridianClass b))
+
+private theorem
+    PeriodFamily.markedRegularFundamentalGroup_subgroup_eq_top (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (S :
+      Subgroup
+        (FundamentalGroup ((regularData P h₁ h₂)).Space
+          (((regularData P h₁ h₂)).fundamentalGroupBasepoint
+            (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint))))
+    (hL :
+      ∀ v : Multiplicative Lattice,
+        ((regularData P h₁ h₂)).latticeFundamentalGroupHom
+            (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint) v ∈
+          S)
+    (hM :
+      ∀ b : Bool,
+        ((regularData P h₁ h₂)).sectionFundamentalGroupHom
+            (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+            (Meridians.compatibleRegularMeridianClass b) ∈
+          S) :
+    S = ⊤ := by
+  let e := markedRegularFundamentalGroupEquiv P h₁ h₂
+  have hmap : S.map e.toMonoidHom = ⊤ := by
+    apply freeSemidirect_subgroup_eq_top
+    · intro v
+      exact
+        ⟨((regularData P h₁ h₂)).latticeFundamentalGroupHom
+            (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint) v,
+          hL v, markedRegularFundamentalGroupEquiv_lattice P h₁ h₂ v⟩
+    · intro b
+      exact
+        ⟨((regularData P h₁ h₂)).sectionFundamentalGroupHom
+            (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+            (Meridians.compatibleRegularMeridianClass b),
+          hM b, markedRegularFundamentalGroupEquiv_meridian P h₁ h₂ b⟩
+  apply top_unique
+  intro γ _
+  have hγ : e γ ∈ S.map e.toMonoidHom := by
+    rw [hmap]
+    trivial
+  obtain ⟨δ, hδ, he⟩ := hγ
+  exact e.injective he ▸ hδ
+
+private theorem PeriodFamily.markedRegularFundamentalGroup_generators_closure
+    (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    Subgroup.closure (markedRegularFundamentalGroupGenerators P h₁ h₂) = ⊤ := by
+  apply markedRegularFundamentalGroup_subgroup_eq_top P h₁ h₂
+  · intro v
+    exact Subgroup.subset_closure (Or.inl ⟨v, rfl⟩)
+  · intro b
+    exact Subgroup.subset_closure (Or.inr ⟨b, rfl⟩)
+
+private theorem PeriodFamily.markedRegularFundamentalGroupHom_ext (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    {A : Type*} [Monoid A]
+    (f g :
+      FundamentalGroup ((regularData P h₁ h₂)).Space
+          (((regularData P h₁ h₂)).fundamentalGroupBasepoint
+            (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)) →*
+        A)
+    (hL :
+      ∀ v : Multiplicative Lattice,
+        f
+            (((regularData P h₁ h₂)).latticeFundamentalGroupHom
+              (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint) v) =
+          g
+            (((regularData P h₁ h₂)).latticeFundamentalGroupHom
+              (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint) v))
+    (hM :
+      ∀ b : Bool,
+        f
+            (((regularData P h₁ h₂)).sectionFundamentalGroupHom
+              (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+              (Meridians.compatibleRegularMeridianClass b)) =
+          g
+            (((regularData P h₁ h₂)).sectionFundamentalGroupHom
+              (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+              (Meridians.compatibleRegularMeridianClass b))) :
+    f = g := by
+  apply MonoidHom.eq_of_eqOn_dense (markedRegularFundamentalGroup_generators_closure P h₁ h₂)
+  rintro γ (⟨v, rfl⟩ | ⟨b, rfl⟩)
+  · exact hL v
+  · exact hM b
+
+private theorem PeriodFamily.Boundary.compatibleLift_projection (b : Bool) (t : unitInterval) :
+    SpecialPeriods.triangleRegularProject (PeriodFamily.Meridians.compatibleMeridianLift b t) =
+      PeriodFamily.Meridians.compatibleRegularMeridian b t := by
+  apply SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.injective
+  exact
+    (PeriodFamily.Meridians.compatibleMeridianLift_coordinate b t).trans
+      (PeriodFamily.Meridians.compatibleRegularMeridian_coordinate b t).symm
+
+private def PeriodFamily.Boundary.clockwiseLiftEndpoint (b : Bool) : SpecialPeriods.TriangleGroup :=
+  if PeriodFamily.Meridians.normalizationReversesMeridians then
+    (PeriodFamily.Meridians.compatibleMeridianGenerator b)⁻¹
+  else PeriodFamily.Meridians.compatibleMeridianGenerator b
+
+private def PeriodFamily.Boundary.clockwiseFinalLift (b : Bool) :
+    C(unitInterval, SpecialPeriods.TriangleRegularPoint) :=
+  if PeriodFamily.Meridians.normalizationReversesMeridians then
+    (PeriodFamily.Meridians.compatibleMeridianLift b).toContinuousMap
+  else
+    ((PeriodFamily.Meridians.compatibleMeridianLift b).symm.map
+        (ContinuousConstSMul.continuous_const_smul
+          (PeriodFamily.Meridians.compatibleMeridianGenerator b))).toContinuousMap
+
+@[simp]
+private theorem PeriodFamily.Boundary.clockwiseFinalLift_zero (b : Bool) :
+    clockwiseFinalLift b 0 = PeriodFamily.Meridians.normalizedRegularMeridianBasepoint := by
+  by_cases h : PeriodFamily.Meridians.normalizationReversesMeridians = Bool.true
+  · rw [clockwiseFinalLift, ite_eq_left h]
+    exact (PeriodFamily.Meridians.compatibleMeridianLift b).source
+  · rw [clockwiseFinalLift, ite_eq_right h]
+    exact
+      (((PeriodFamily.Meridians.compatibleMeridianLift b).symm.map
+              (ContinuousConstSMul.continuous_const_smul
+                (PeriodFamily.Meridians.compatibleMeridianGenerator b))).source).trans
+        (smul_inv_smul (PeriodFamily.Meridians.compatibleMeridianGenerator b)
+          PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+
+private theorem PeriodFamily.Boundary.clockwiseFinalLift_one (b : Bool) :
+    clockwiseFinalLift b 1 = clockwiseLiftEndpoint b • clockwiseFinalLift b 0 := by
+  rw [clockwiseFinalLift_zero]
+  by_cases h : PeriodFamily.Meridians.normalizationReversesMeridians = Bool.true
+  · rw [clockwiseFinalLift, clockwiseLiftEndpoint, ite_eq_left h, ite_eq_left h]
+    exact (PeriodFamily.Meridians.compatibleMeridianLift b).target
+  · rw [clockwiseFinalLift, clockwiseLiftEndpoint, ite_eq_right h, ite_eq_right h]
+    exact
+      ((PeriodFamily.Meridians.compatibleMeridianLift b).symm.map
+          (ContinuousConstSMul.continuous_const_smul
+            (PeriodFamily.Meridians.compatibleMeridianGenerator b))).target
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/PeriodFamily/Core4.lean b/LeanPool/HopfProblem/PeriodFamily/Core4.lean
new file mode 100644
index 000000000..25177b438
--- /dev/null
+++ b/LeanPool/HopfProblem/PeriodFamily/Core4.lean
@@ -0,0 +1,2049 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology9
+public import LeanPool.HopfProblem.Toric.DiagonalQuotient3
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology3
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.PeriodFamily.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods6
+import all LeanPool.HopfProblem.Toric.DiagonalQuotient1
+import all LeanPool.HopfProblem.HomologyOfX.CuspCoinvariants
+import all LeanPool.HopfProblem.PeriodFamily.Core2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods7
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods8
+import all LeanPool.HopfProblem.PeriodFamily.Core3
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods10
+import all LeanPool.HopfProblem.HomologyOfX.TrianglePeriodFamilyHomologyAlgebra
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology9
+import all LeanPool.HopfProblem.Toric.DiagonalQuotient3
+
+/-!
+# Hopf problem: period family · core 4
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem PeriodFamily.Boundary.clockwiseFinalLift_projection (b : Bool) (t : unitInterval) :
+    SpecialPeriods.triangleRegularProject (clockwiseFinalLift b t) =
+      SpecialPeriods.EllipticAttachingMeridians.clockwiseRegularMeridian b t := by
+  by_cases h : PeriodFamily.Meridians.normalizationReversesMeridians = Bool.true
+  · rw [clockwiseFinalLift, SpecialPeriods.EllipticAttachingMeridians.clockwiseRegularMeridian,
+      ite_eq_left h, ite_eq_left h]
+    exact compatibleLift_projection b t
+  · rw [clockwiseFinalLift, SpecialPeriods.EllipticAttachingMeridians.clockwiseRegularMeridian,
+      ite_eq_right h, ite_eq_right h]
+    change
+      SpecialPeriods.triangleRegularProject
+          (PeriodFamily.Meridians.compatibleMeridianGenerator b •
+            PeriodFamily.Meridians.compatibleMeridianLift b (unitInterval.symm t)) =
+        _
+    rw [SpecialPeriods.triangleRegularProject_covering.map_smul]
+    exact compatibleLift_projection b (unitInterval.symm t)
+
+private def PeriodFamily.Boundary.chosenNativeLift (j : Elliptic.Kind) :
+    C(unitInterval, SpecialPeriods.TriangleRegularPoint) :=
+  ⟨SpecialPeriods.Threefold.EllipticGeometry.attachingUpstairsPoint j
+      (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingParameter j)
+      (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingParameter_im_pos j),
+    SpecialPeriods.Threefold.EllipticGeometry.attachingUpstairsPoint_continuous j _ _⟩
+
+@[simp]
+private theorem
+    PeriodFamily.Boundary.chosenNativeLift_projection (j : Elliptic.Kind) (t : unitInterval) :
+    SpecialPeriods.triangleRegularProject (chosenNativeLift j t) =
+      SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingBaseLoop j t :=
+  rfl
+
+private theorem PeriodFamily.Boundary.chosenNativeLift_one (j : Elliptic.Kind) :
+    chosenNativeLift j 1 = SpecialPeriods.Triangle.ellipticGenerator j • chosenNativeLift j 0 :=
+  SpecialPeriods.Threefold.EllipticGeometry.attachingUpstairsPoint_one j _ _
+
+private def PeriodFamily.Boundary.chosenNativeSquareLift (j : Elliptic.Kind) :
+    C(unitInterval × unitInterval, SpecialPeriods.TriangleRegularPoint) :=
+  loopSquareLift (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingSquare j)
+    (chosenNativeLift j) (chosenNativeLift_projection j)
+
+private def
+    PeriodFamily.Boundary.nativeTailFrame (j : Elliptic.Kind) : SpecialPeriods.TriangleGroup :=
+  (loopSquareLift_exists_frame (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingSquare j)
+      (chosenNativeLift j) (chosenNativeLift_projection j)
+      PeriodFamily.Meridians.normalizedRegularMeridianBasepoint rfl).choose
+
+private theorem PeriodFamily.Boundary.nativeTailFrame_apply (j : Elliptic.Kind) :
+    chosenNativeSquareLift j (1, 0) =
+      nativeTailFrame j • PeriodFamily.Meridians.normalizedRegularMeridianBasepoint :=
+  (loopSquareLift_exists_frame (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingSquare j)
+      (chosenNativeLift j) (chosenNativeLift_projection j)
+      PeriodFamily.Meridians.normalizedRegularMeridianBasepoint rfl).choose_spec
+
+private theorem PeriodFamily.Boundary.nativeTailFrame_relation (j : Elliptic.Kind) :
+    SpecialPeriods.Triangle.ellipticGenerator j * nativeTailFrame j =
+      nativeTailFrame j *
+        clockwiseLiftEndpoint
+          (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j) := by
+  apply
+    loopSquareLift_frame_relation
+      (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingSquare j) (chosenNativeLift j)
+      (chosenNativeLift_projection j) (SpecialPeriods.Triangle.ellipticGenerator j)
+      (chosenNativeLift_one j)
+      (clockwiseFinalLift (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j))
+      (clockwiseFinalLift_projection
+        (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j))
+      (clockwiseLiftEndpoint (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j))
+      (clockwiseFinalLift_one
+        (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j))
+      (nativeTailFrame j)
+  rw [clockwiseFinalLift_zero]
+  exact nativeTailFrame_apply j
+
+private theorem PeriodFamily.Boundary.nativeTailFrame_relation_if (j : Elliptic.Kind) :
+    SpecialPeriods.Triangle.ellipticGenerator j * nativeTailFrame j =
+      nativeTailFrame j *
+        (if PeriodFamily.Meridians.normalizationReversesMeridians then
+          (SpecialPeriods.Triangle.ellipticGenerator j)⁻¹
+        else SpecialPeriods.Triangle.ellipticGenerator j) := by
+  have h := nativeTailFrame_relation j
+  cases j <;> exact h
+
+private def PeriodFamily.Boundary.firstCyclicCharacter :
+    SpecialPeriods.TriangleGroup →* Multiplicative (ZMod 3) :=
+  Monoid.Coprod.lift (MonoidHom.id _) 1
+
+@[simp]
+private theorem PeriodFamily.Boundary.firstCyclicCharacter_generator :
+    firstCyclicCharacter SpecialPeriods.triangleGenerator₁ = Multiplicative.ofAdd (1 : ZMod 3) := by
+  simp [firstCyclicCharacter, SpecialPeriods.triangleGenerator₁]
+
+private theorem PeriodFamily.Boundary.firstGenerator_not_inverse_conjugate
+    (d : SpecialPeriods.TriangleGroup) :
+    SpecialPeriods.triangleGenerator₁ * d ≠ d * SpecialPeriods.triangleGenerator₁⁻¹ := by
+  intro he
+  have hm := congrArg firstCyclicCharacter he
+  simp only [map_mul, map_inv, firstCyclicCharacter_generator] at hm
+  rw [mul_comm (Multiplicative.ofAdd (1 : ZMod 3)) (firstCyclicCharacter d)] at hm
+  have hc := mul_left_cancel hm
+  have ha := congrArg (fun x : Multiplicative (ZMod 3) => x.toAdd) hc
+  exact (by decide : (1 : ZMod 3) ≠ -1) ha
+
+private theorem PeriodFamily.Boundary.normalizationReversesMeridians_false :
+    PeriodFamily.Meridians.normalizationReversesMeridians = Bool.false := by
+  apply Bool.eq_false_iff.mpr
+  intro h
+  apply firstGenerator_not_inverse_conjugate (nativeTailFrame .three)
+  simpa [h, SpecialPeriods.Triangle.ellipticGenerator] using nativeTailFrame_relation_if .three
+
+private theorem PeriodFamily.Boundary.normalizationOrientation_nonpos :
+    RiemannMapping.normalizationOrientation ≤ 0 := by
+  apply le_of_not_gt
+  have h := normalizationReversesMeridians_false
+  simpa only [PeriodFamily.Meridians.normalizationReversesMeridians,
+    decide_eq_false_iff_not] using h
+
+private theorem PeriodFamily.Boundary.nativeTailFrame_commute (j : Elliptic.Kind) :
+    Commute (SpecialPeriods.Triangle.ellipticGenerator j) (nativeTailFrame j) := by
+  change
+    SpecialPeriods.Triangle.ellipticGenerator j * nativeTailFrame j =
+      nativeTailFrame j * SpecialPeriods.Triangle.ellipticGenerator j
+  have h := nativeTailFrame_relation_if j
+  simpa only [normalizationReversesMeridians_false, Bool.false_eq_true, ite_false] using h
+
+private theorem PeriodFamily.Boundary.nativeTailFrame_inv_eq_power (j : Elliptic.Kind) :
+    ∃ k : ℕ,
+      k < j.order ∧ (nativeTailFrame j)⁻¹ = SpecialPeriods.Triangle.ellipticGenerator j ^ k := by
+  cases j
+  · exact
+      SpecialPeriods.triangleGenerator₁_commute_eq_pow _
+        (nativeTailFrame_commute .three).inv_right
+  · exact
+      SpecialPeriods.triangleGenerator₂_commute_eq_pow _ (nativeTailFrame_commute .four).inv_right
+
+private def PeriodFamily.Homology.regularOpen
+    (U : TopologicalSpace.Opens SpecialPeriods.Triangle.TwicePuncturedPlane) :
+    TopologicalSpace.Opens SpecialPeriods.TriangleRegularQuotient :=
+  ⟨SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph ⁻¹'
+      (U : Set SpecialPeriods.Triangle.TwicePuncturedPlane),
+    U.isOpen.preimage SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.continuous⟩
+
+@[simp]
+private theorem PeriodFamily.Homology.mem_regularOpen
+    (U : TopologicalSpace.Opens SpecialPeriods.Triangle.TwicePuncturedPlane)
+    (x : SpecialPeriods.TriangleRegularQuotient) :
+    x ∈ regularOpen U ↔ SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph x ∈ U :=
+  Iff.rfl
+
+private def PeriodFamily.Homology.regularOpenHomeomorph
+    (U : TopologicalSpace.Opens SpecialPeriods.Triangle.TwicePuncturedPlane) :
+    regularOpen U ≃ₜ U :=
+  SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.subtype (fun _ => Iff.rfl)
+
+private theorem PeriodFamily.Homology.regularOpen_locallyPathConnectedSpace
+    (U : TopologicalSpace.Opens SpecialPeriods.Triangle.TwicePuncturedPlane) :
+    LocallyPathConnectedSpace (regularOpen U) := by
+  let := SpecialPeriods.Triangle.twicePuncturedPlaneDomain.isOpen.locallyPathConnectedSpace
+  let := U.isOpen.locallyPathConnectedSpace
+  exact (regularOpenHomeomorph U).isOpenEmbedding.locallyPathConnectedSpace
+
+private abbrev PeriodFamily.Homology.upperBase :=
+  regularOpen SpecialPeriods.Triangle.upperSlit
+
+private abbrev PeriodFamily.Homology.lowerBase :=
+  regularOpen SpecialPeriods.Triangle.lowerSlit
+
+private abbrev PeriodFamily.Homology.overlapBase (i : Fin 3) :=
+  regularOpen (SpecialPeriods.Triangle.slitOverlapStrip i)
+
+private instance PeriodFamily.Homology.upperBase_contractibleSpace : ContractibleSpace upperBase :=
+  (regularOpenHomeomorph SpecialPeriods.Triangle.upperSlit).contractibleSpace
+
+private instance PeriodFamily.Homology.lowerBase_contractibleSpace : ContractibleSpace lowerBase :=
+  (regularOpenHomeomorph SpecialPeriods.Triangle.lowerSlit).contractibleSpace
+
+private instance PeriodFamily.Homology.overlapBase_contractibleSpace (i : Fin 3) :
+    ContractibleSpace (overlapBase i) :=
+  (regularOpenHomeomorph (SpecialPeriods.Triangle.slitOverlapStrip i)).contractibleSpace
+
+private instance PeriodFamily.Homology.upperBase_locallyPathConnectedSpace :
+    LocallyPathConnectedSpace upperBase :=
+  regularOpen_locallyPathConnectedSpace SpecialPeriods.Triangle.upperSlit
+
+private instance PeriodFamily.Homology.lowerBase_locallyPathConnectedSpace :
+    LocallyPathConnectedSpace lowerBase :=
+  regularOpen_locallyPathConnectedSpace SpecialPeriods.Triangle.lowerSlit
+
+private theorem PeriodFamily.Homology.overlapBase_subset (i : Fin 3) :
+    (overlapBase i : Set SpecialPeriods.TriangleRegularQuotient) ⊆
+      (upperBase : Set SpecialPeriods.TriangleRegularQuotient) ∩ lowerBase :=
+  fun _ hx => SpecialPeriods.Triangle.slitOverlapStrip_subset_overlap i hx
+
+private theorem PeriodFamily.Homology.overlapBase_pairwise_disjoint :
+    Pairwise fun i j : Fin 3 =>
+      Disjoint (overlapBase i : Set SpecialPeriods.TriangleRegularQuotient) (overlapBase j) := by
+  intro i j hij
+  apply Set.disjoint_left.mpr
+  intro x hi hj
+  exact
+    Set.disjoint_left.mp (SpecialPeriods.Triangle.slitOverlapStrip_pairwise_disjoint hij) hi hj
+
+private theorem PeriodFamily.Homology.overlapBase_iUnion :
+    (⋃ i : Fin 3, (overlapBase i : Set SpecialPeriods.TriangleRegularQuotient)) =
+      (upperBase : Set SpecialPeriods.TriangleRegularQuotient) ∩ lowerBase := by
+  ext x
+  constructor
+  · intro hx
+    obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hx
+    exact overlapBase_subset i hi
+  · intro hx
+    have hh :
+      SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph x ∈
+        ⋃ i : Fin 3,
+          (SpecialPeriods.Triangle.slitOverlapStrip i :
+            Set SpecialPeriods.Triangle.TwicePuncturedPlane) := by
+      rw [SpecialPeriods.Triangle.slitOverlapStrip_iUnion]
+      exact hx
+    obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hh
+    exact Set.mem_iUnion.mpr ⟨i, hi⟩
+
+private def PeriodFamily.Homology.overlapBasePoint (i : Fin 3) : overlapBase i :=
+  (regularOpenHomeomorph (SpecialPeriods.Triangle.slitOverlapStrip i)).symm
+    (SpecialPeriods.Triangle.slitOverlapStripPoint i)
+
+private def PeriodFamily.Homology.slitBasepoint : SpecialPeriods.TriangleRegularQuotient :=
+  SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm
+    SpecialPeriods.Triangle.meridianBasepoint
+
+@[simp]
+private theorem PeriodFamily.Homology.slitBasepoint_coordinate :
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph slitBasepoint =
+      SpecialPeriods.Triangle.meridianBasepoint :=
+  SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.apply_symm_apply
+    SpecialPeriods.Triangle.meridianBasepoint
+
+private theorem PeriodFamily.Homology.slitBasepoint_mem_upper : slitBasepoint ∈ upperBase := by
+  rw [mem_regularOpen, slitBasepoint_coordinate]
+  change (1 / 2 : ℂ) ∈ SpecialPeriods.Triangle.upperSlitPlane
+  norm_num [SpecialPeriods.Triangle.upperSlitPlane]
+
+private theorem PeriodFamily.Homology.slitBasepoint_mem_lower : slitBasepoint ∈ lowerBase := by
+  rw [mem_regularOpen, slitBasepoint_coordinate]
+  change (1 / 2 : ℂ) ∈ SpecialPeriods.Triangle.lowerSlitPlane
+  norm_num [SpecialPeriods.Triangle.lowerSlitPlane]
+
+private def PeriodFamily.Homology.upperBasePoint : upperBase :=
+  ⟨slitBasepoint, slitBasepoint_mem_upper⟩
+
+private def PeriodFamily.Homology.lowerBasePoint : lowerBase :=
+  ⟨slitBasepoint, slitBasepoint_mem_lower⟩
+
+private abbrev PeriodFamily.Homology.SlitBaseLift :=
+  SpecialPeriods.triangleRegularProject ⁻¹'
+    ({ slitBasepoint } : Set SpecialPeriods.TriangleRegularQuotient)
+
+private def PeriodFamily.Homology.upperBaseInclusion :
+    C(upperBase, SpecialPeriods.TriangleRegularQuotient) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private def PeriodFamily.Homology.lowerBaseInclusion :
+    C(lowerBase, SpecialPeriods.TriangleRegularQuotient) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private theorem PeriodFamily.Homology.upperLift_existsUnique (b : SlitBaseLift) :
+    ∃! s : C(upperBase, SpecialPeriods.TriangleRegularPoint),
+      s upperBasePoint = b.val ∧ SpecialPeriods.triangleRegularProject ∘ s = upperBaseInclusion :=
+  SpecialPeriods.triangleRegularProject_covering.isCoveringMap.existsUnique_continuousMap_lifts
+    upperBaseInclusion upperBasePoint b.val b.property
+
+private theorem PeriodFamily.Homology.lowerLift_existsUnique (b : SlitBaseLift) :
+    ∃! s : C(lowerBase, SpecialPeriods.TriangleRegularPoint),
+      s lowerBasePoint = b.val ∧ SpecialPeriods.triangleRegularProject ∘ s = lowerBaseInclusion :=
+  SpecialPeriods.triangleRegularProject_covering.isCoveringMap.existsUnique_continuousMap_lifts
+    lowerBaseInclusion lowerBasePoint b.val b.property
+
+private def PeriodFamily.Homology.upperLift (b : SlitBaseLift) :
+    C(upperBase, SpecialPeriods.TriangleRegularPoint) :=
+  (upperLift_existsUnique b).choose
+
+private def PeriodFamily.Homology.lowerLift (b : SlitBaseLift) :
+    C(lowerBase, SpecialPeriods.TriangleRegularPoint) :=
+  (lowerLift_existsUnique b).choose
+
+@[simp]
+private theorem PeriodFamily.Homology.upperLift_basepoint (b : SlitBaseLift) :
+    upperLift b upperBasePoint = b.val :=
+  (upperLift_existsUnique b).choose_spec.1.1
+
+@[simp]
+private theorem PeriodFamily.Homology.lowerLift_basepoint (b : SlitBaseLift) :
+    lowerLift b lowerBasePoint = b.val :=
+  (lowerLift_existsUnique b).choose_spec.1.1
+
+@[simp]
+private theorem PeriodFamily.Homology.upperLift_project (b : SlitBaseLift) (x : upperBase) :
+    SpecialPeriods.triangleRegularProject (upperLift b x) = x.val :=
+  congrFun (upperLift_existsUnique b).choose_spec.1.2 x
+
+@[simp]
+private theorem PeriodFamily.Homology.lowerLift_project (b : SlitBaseLift) (x : lowerBase) :
+    SpecialPeriods.triangleRegularProject (lowerLift b x) = x.val :=
+  congrFun (lowerLift_existsUnique b).choose_spec.1.2 x
+
+private def PeriodFamily.Homology.overlapToUpper (i : Fin 3) : C(overlapBase i, upperBase) :=
+  ⟨fun x => ⟨x.val, (overlapBase_subset i x.property).1⟩, by fun_prop⟩
+
+private def PeriodFamily.Homology.overlapToLower (i : Fin 3) : C(overlapBase i, lowerBase) :=
+  ⟨fun x => ⟨x.val, (overlapBase_subset i x.property).2⟩, by fun_prop⟩
+
+private def PeriodFamily.Homology.upperLiftOnOverlap (b : SlitBaseLift) (i : Fin 3) :
+    C(overlapBase i, SpecialPeriods.TriangleRegularPoint) :=
+  (upperLift b).comp (overlapToUpper i)
+
+private def PeriodFamily.Homology.lowerLiftOnOverlap (b : SlitBaseLift) (i : Fin 3) :
+    C(overlapBase i, SpecialPeriods.TriangleRegularPoint) :=
+  (lowerLift b).comp (overlapToLower i)
+
+@[simp]
+private theorem PeriodFamily.Homology.upperLiftOnOverlap_project (b : SlitBaseLift) (i : Fin 3)
+    (x : overlapBase i) :
+    SpecialPeriods.triangleRegularProject (upperLiftOnOverlap b i x) = x.val :=
+  upperLift_project b (overlapToUpper i x)
+
+@[simp]
+private theorem PeriodFamily.Homology.lowerLiftOnOverlap_project (b : SlitBaseLift) (i : Fin 3)
+    (x : overlapBase i) :
+    SpecialPeriods.triangleRegularProject (lowerLiftOnOverlap b i x) = x.val :=
+  lowerLift_project b (overlapToLower i x)
+
+private theorem PeriodFamily.Homology.overlapTransition_exists (b : SlitBaseLift) (i : Fin 3) :
+    ∃ g : SpecialPeriods.TriangleGroup,
+      g • upperLiftOnOverlap b i (overlapBasePoint i) =
+        lowerLiftOnOverlap b i (overlapBasePoint i) := by
+  apply SpecialPeriods.triangleRegularProject_covering.apply_eq_iff_mem_orbit.mp
+  rw [upperLiftOnOverlap_project, lowerLiftOnOverlap_project]
+
+private def PeriodFamily.Homology.overlapTransition (b : SlitBaseLift) (i : Fin 3) :
+    SpecialPeriods.TriangleGroup :=
+  (overlapTransition_exists b i).choose
+
+private theorem PeriodFamily.Homology.overlapTransition_at_point (b : SlitBaseLift) (i : Fin 3) :
+    overlapTransition b i • upperLiftOnOverlap b i (overlapBasePoint i) =
+      lowerLiftOnOverlap b i (overlapBasePoint i) :=
+  (overlapTransition_exists b i).choose_spec
+
+private theorem PeriodFamily.Homology.overlapTransition_apply (b : SlitBaseLift) (i : Fin 3)
+    (x : overlapBase i) :
+    overlapTransition b i • upperLiftOnOverlap b i x = lowerLiftOnOverlap b i x := by
+  have he :
+    (fun y => overlapTransition b i • upperLiftOnOverlap b i y) = lowerLiftOnOverlap b i := by
+    apply
+      SpecialPeriods.triangleRegularProject_covering.isCoveringMap.eq_of_comp_eq
+        ((SpecialPeriods.triangleRegularProject_covering.continuous_const_smul _).comp
+          (upperLiftOnOverlap b i).continuous)
+        (lowerLiftOnOverlap b i).continuous
+    · funext y
+      change
+        SpecialPeriods.triangleRegularProject (overlapTransition b i • upperLiftOnOverlap b i y) =
+          SpecialPeriods.triangleRegularProject (lowerLiftOnOverlap b i y)
+      rw [SpecialPeriods.triangleRegularProject_covering.map_smul, upperLiftOnOverlap_project,
+        lowerLiftOnOverlap_project]
+    · exact overlapTransition_at_point b i
+  exact congrFun he x
+
+private theorem PeriodFamily.Homology.overlapTransition_eq_of_apply (b : SlitBaseLift) (i : Fin 3)
+    (g : SpecialPeriods.TriangleGroup) (x : overlapBase i)
+    (hg : g • upperLiftOnOverlap b i x = lowerLiftOnOverlap b i x) : overlapTransition b i = g := by
+  let := SpecialPeriods.triangleRegularProject_covering.isCancelSMul
+  exact
+    IsCancelSMul.right_cancel _ _ (upperLiftOnOverlap b i x)
+      ((overlapTransition_apply b i x).trans hg.symm)
+
+private def PeriodFamily.Homology.middleOverlapPoint : overlapBase 1 := by
+  refine ⟨slitBasepoint, ?_⟩
+  rw [mem_regularOpen, slitBasepoint_coordinate]
+  change (1 / 2 : ℂ) ∈ SpecialPeriods.Triangle.overlapStrip 1
+  norm_num [SpecialPeriods.Triangle.overlapStrip]
+
+@[simp]
+private theorem PeriodFamily.Homology.upperLift_middleOverlapPoint (b : SlitBaseLift) :
+    upperLiftOnOverlap b 1 middleOverlapPoint = b.val :=
+  upperLift_basepoint b
+
+@[simp]
+private theorem PeriodFamily.Homology.lowerLift_middleOverlapPoint (b : SlitBaseLift) :
+    lowerLiftOnOverlap b 1 middleOverlapPoint = b.val :=
+  lowerLift_basepoint b
+
+@[simp]
+private theorem PeriodFamily.Homology.overlapTransition_middle (b : SlitBaseLift) :
+    overlapTransition b 1 = 1 := by
+  apply overlapTransition_eq_of_apply b 1 1 middleOverlapPoint
+  rw [one_smul, upperLift_middleOverlapPoint, lowerLift_middleOverlapPoint]
+
+private def PeriodFamily.Homology.normalizedSlitBaseLift : SlitBaseLift :=
+  ⟨PeriodFamily.Meridians.normalizedRegularMeridianBasepoint,
+    by
+    change
+      SpecialPeriods.triangleRegularProject
+          PeriodFamily.Meridians.normalizedRegularMeridianBasepoint =
+        slitBasepoint
+    apply SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.injective
+    rw [PeriodFamily.Meridians.normalizedRegularMeridianBasepoint_coordinate,
+      slitBasepoint_coordinate]⟩
+
+@[simp]
+private theorem PeriodFamily.Homology.normalizedSlitBaseLift_val :
+    normalizedSlitBaseLift.val = PeriodFamily.Meridians.normalizedRegularMeridianBasepoint :=
+  rfl
+
+private theorem PeriodFamily.Homology.upperLift_path (b : SlitBaseLift)
+    {z : SpecialPeriods.TriangleRegularPoint} (p : Path b.val z)
+    (hp : ∀ t, SpecialPeriods.triangleRegularProject (p t) ∈ upperBase) (t : unitInterval) :
+    upperLift b ⟨SpecialPeriods.triangleRegularProject (p t), hp t⟩ = p t := by
+  let q : C(unitInterval, upperBase) :=
+    ⟨fun s => ⟨SpecialPeriods.triangleRegularProject (p s), hp s⟩,
+      (SpecialPeriods.triangleRegularProject_covering.continuous.comp p.continuous).subtype_mk hp⟩
+  have hq : q 0 = upperBasePoint := by
+    apply Subtype.ext
+    change SpecialPeriods.triangleRegularProject (p 0) = slitBasepoint
+    rw [p.source]
+    exact b.property
+  have h :
+    (fun s => upperLift b (q s)) = (p : unitInterval → SpecialPeriods.TriangleRegularPoint) := by
+    refine
+      SpecialPeriods.triangleRegularProject_covering.isCoveringMap.eq_of_comp_eq
+        ((upperLift b).continuous.comp q.continuous) p.continuous ?_ (0 : unitInterval) ?_
+    · funext s
+      exact upperLift_project b (q s)
+    · rw [hq, upperLift_basepoint, p.source]
+  exact congrFun h t
+
+private theorem PeriodFamily.Homology.lowerLift_path (b : SlitBaseLift)
+    {z : SpecialPeriods.TriangleRegularPoint} (p : Path b.val z)
+    (hp : ∀ t, SpecialPeriods.triangleRegularProject (p t) ∈ lowerBase) (t : unitInterval) :
+    lowerLift b ⟨SpecialPeriods.triangleRegularProject (p t), hp t⟩ = p t := by
+  let q : C(unitInterval, lowerBase) :=
+    ⟨fun s => ⟨SpecialPeriods.triangleRegularProject (p s), hp s⟩,
+      (SpecialPeriods.triangleRegularProject_covering.continuous.comp p.continuous).subtype_mk hp⟩
+  have hq : q 0 = lowerBasePoint := by
+    apply Subtype.ext
+    change SpecialPeriods.triangleRegularProject (p 0) = slitBasepoint
+    rw [p.source]
+    exact b.property
+  have h :
+    (fun s => lowerLift b (q s)) = (p : unitInterval → SpecialPeriods.TriangleRegularPoint) := by
+    refine
+      SpecialPeriods.triangleRegularProject_covering.isCoveringMap.eq_of_comp_eq
+        ((lowerLift b).continuous.comp q.continuous) p.continuous ?_ (0 : unitInterval) ?_
+    · funext s
+      exact lowerLift_project b (q s)
+    · rw [hq, lowerLift_basepoint, p.source]
+  exact congrFun h t
+
+private theorem PeriodFamily.Homology.upperLift_endpoint (b : SlitBaseLift) (x : upperBase)
+    {z : SpecialPeriods.TriangleRegularPoint} (p : Path b.val z)
+    (hp : ∀ t, SpecialPeriods.triangleRegularProject (p t) ∈ upperBase)
+    (hx : x.val = SpecialPeriods.triangleRegularProject z) : upperLift b x = z := by
+  have hx' : x = ⟨SpecialPeriods.triangleRegularProject (p 1), hp 1⟩ :=
+    Subtype.ext (hx.trans (congrArg SpecialPeriods.triangleRegularProject p.target.symm))
+  calc
+    upperLift b x = upperLift b ⟨SpecialPeriods.triangleRegularProject (p 1), hp 1⟩ :=
+      congrArg (upperLift b) hx'
+    _ = p 1 := (upperLift_path b p hp 1)
+    _ = z := p.target
+
+private theorem PeriodFamily.Homology.lowerLift_endpoint (b : SlitBaseLift) (x : lowerBase)
+    {z : SpecialPeriods.TriangleRegularPoint} (p : Path b.val z)
+    (hp : ∀ t, SpecialPeriods.triangleRegularProject (p t) ∈ lowerBase)
+    (hx : x.val = SpecialPeriods.triangleRegularProject z) : lowerLift b x = z := by
+  have hx' : x = ⟨SpecialPeriods.triangleRegularProject (p 1), hp 1⟩ :=
+    Subtype.ext (hx.trans (congrArg SpecialPeriods.triangleRegularProject p.target.symm))
+  calc
+    lowerLift b x = lowerLift b ⟨SpecialPeriods.triangleRegularProject (p 1), hp 1⟩ :=
+      congrArg (lowerLift b) hx'
+    _ = p 1 := (lowerLift_path b p hp 1)
+    _ = z := p.target
+
+private def PeriodFamily.Homology.meridianLeftOverlapPoint : overlapBase 0 := by
+  refine
+    ⟨SpecialPeriods.triangleRegularProject
+        PeriodFamily.Meridians.normalizedRegularMeridianLeftPoint,
+      ?_⟩
+  rw [mem_regularOpen, PeriodFamily.Meridians.normalizedRegularMeridianLeftPoint_coordinate]
+  change (-1 / 2 : ℂ) ∈ SpecialPeriods.Triangle.overlapStrip 0
+  norm_num [SpecialPeriods.Triangle.overlapStrip]
+
+private def PeriodFamily.Homology.meridianRightOverlapPoint : overlapBase 2 := by
+  refine
+    ⟨SpecialPeriods.triangleRegularProject
+        PeriodFamily.Meridians.normalizedRegularMeridianRightPoint,
+      ?_⟩
+  rw [mem_regularOpen, PeriodFamily.Meridians.normalizedRegularMeridianRightPoint_coordinate]
+  change (3 / 2 : ℂ) ∈ SpecialPeriods.Triangle.overlapStrip 2
+  norm_num [SpecialPeriods.Triangle.overlapStrip]
+
+private def PeriodFamily.Homology.normalizedOverlapTransition (i : Fin 3) :
+    SpecialPeriods.TriangleGroup :=
+  overlapTransition normalizedSlitBaseLift i
+
+private theorem PeriodFamily.Homology.normalizedOverlapTransition_left_of_pos
+    (ho : 0 < RiemannMapping.normalizationOrientation) :
+    normalizedOverlapTransition 0 = SpecialPeriods.triangleGenerator₁⁻¹ := by
+  apply
+    overlapTransition_eq_of_apply normalizedSlitBaseLift 0 SpecialPeriods.triangleGenerator₁⁻¹
+      meridianLeftOverlapPoint
+  have hU :
+    upperLiftOnOverlap normalizedSlitBaseLift 0 meridianLeftOverlapPoint =
+      PeriodFamily.Meridians.normalizedRegularMeridianLeftPoint := by
+    change
+      upperLift normalizedSlitBaseLift
+          ⟨SpecialPeriods.triangleRegularProject
+              PeriodFamily.Meridians.normalizedRegularMeridianLeftPoint,
+            _⟩ =
+        _
+    have hp (t : unitInterval) :
+      SpecialPeriods.triangleRegularProject (PeriodFamily.Meridians.liftedZeroHalfPath t) ∈
+        upperBase := by
+      rw [mem_regularOpen, PeriodFamily.Meridians.liftedZeroHalfPath_coordinate,
+        PeriodFamily.Meridians.zeroHalfPath, ite_eq_left ho]
+      exact SpecialPeriods.Triangle.upperZeroPath_mem_upperSlitPlane t
+    apply upperLift_endpoint normalizedSlitBaseLift _ PeriodFamily.Meridians.liftedZeroHalfPath hp
+    rfl
+  have hL :
+    lowerLiftOnOverlap normalizedSlitBaseLift 0 meridianLeftOverlapPoint =
+      SpecialPeriods.triangleGenerator₁⁻¹ •
+        PeriodFamily.Meridians.normalizedRegularMeridianLeftPoint := by
+    change
+      lowerLift normalizedSlitBaseLift
+          ⟨SpecialPeriods.triangleRegularProject
+              PeriodFamily.Meridians.normalizedRegularMeridianLeftPoint,
+            _⟩ =
+        _
+    have hp (t : unitInterval) :
+      SpecialPeriods.triangleRegularProject (PeriodFamily.Meridians.reflectedZeroHalfPath t) ∈
+        lowerBase := by
+      rw [mem_regularOpen, PeriodFamily.Meridians.reflectedZeroHalfPath_coordinate,
+        PeriodFamily.Meridians.oppositeZeroPath, ite_eq_left ho]
+      exact SpecialPeriods.Triangle.lowerZeroPath_mem_lowerSlitPlane t
+    apply
+      lowerLift_endpoint normalizedSlitBaseLift _ PeriodFamily.Meridians.reflectedZeroHalfPath hp
+    exact (SpecialPeriods.triangleRegularProject_covering.map_smul _).symm
+  rw [hU, hL]
+
+private theorem PeriodFamily.Homology.normalizedOverlapTransition_left_of_nonpos
+    (ho : RiemannMapping.normalizationOrientation ≤ 0) :
+    normalizedOverlapTransition 0 = SpecialPeriods.triangleGenerator₁ := by
+  have hn : ¬0 < RiemannMapping.normalizationOrientation := not_lt.mpr ho
+  apply
+    overlapTransition_eq_of_apply normalizedSlitBaseLift 0 SpecialPeriods.triangleGenerator₁
+      meridianLeftOverlapPoint
+  have hU :
+    upperLiftOnOverlap normalizedSlitBaseLift 0 meridianLeftOverlapPoint =
+      SpecialPeriods.triangleGenerator₁⁻¹ •
+        PeriodFamily.Meridians.normalizedRegularMeridianLeftPoint := by
+    change
+      upperLift normalizedSlitBaseLift
+          ⟨SpecialPeriods.triangleRegularProject
+              PeriodFamily.Meridians.normalizedRegularMeridianLeftPoint,
+            _⟩ =
+        _
+    have hp (t : unitInterval) :
+      SpecialPeriods.triangleRegularProject (PeriodFamily.Meridians.reflectedZeroHalfPath t) ∈
+        upperBase := by
+      rw [mem_regularOpen, PeriodFamily.Meridians.reflectedZeroHalfPath_coordinate,
+        PeriodFamily.Meridians.oppositeZeroPath, ite_eq_right hn]
+      exact SpecialPeriods.Triangle.upperZeroPath_mem_upperSlitPlane t
+    apply
+      upperLift_endpoint normalizedSlitBaseLift _ PeriodFamily.Meridians.reflectedZeroHalfPath hp
+    exact (SpecialPeriods.triangleRegularProject_covering.map_smul _).symm
+  have hL :
+    lowerLiftOnOverlap normalizedSlitBaseLift 0 meridianLeftOverlapPoint =
+      PeriodFamily.Meridians.normalizedRegularMeridianLeftPoint := by
+    change
+      lowerLift normalizedSlitBaseLift
+          ⟨SpecialPeriods.triangleRegularProject
+              PeriodFamily.Meridians.normalizedRegularMeridianLeftPoint,
+            _⟩ =
+        _
+    have hp (t : unitInterval) :
+      SpecialPeriods.triangleRegularProject (PeriodFamily.Meridians.liftedZeroHalfPath t) ∈
+        lowerBase := by
+      rw [mem_regularOpen, PeriodFamily.Meridians.liftedZeroHalfPath_coordinate,
+        PeriodFamily.Meridians.zeroHalfPath, ite_eq_right hn]
+      exact SpecialPeriods.Triangle.lowerZeroPath_mem_lowerSlitPlane t
+    apply lowerLift_endpoint normalizedSlitBaseLift _ PeriodFamily.Meridians.liftedZeroHalfPath hp
+    rfl
+  rw [hU, hL, smul_inv_smul]
+
+private theorem PeriodFamily.Homology.normalizedOverlapTransition_right_of_pos
+    (ho : 0 < RiemannMapping.normalizationOrientation) :
+    normalizedOverlapTransition 2 = SpecialPeriods.triangleGenerator₂ := by
+  apply
+    overlapTransition_eq_of_apply normalizedSlitBaseLift 2 SpecialPeriods.triangleGenerator₂
+      meridianRightOverlapPoint
+  have hU :
+    upperLiftOnOverlap normalizedSlitBaseLift 2 meridianRightOverlapPoint =
+      PeriodFamily.Meridians.normalizedRegularMeridianRightPoint := by
+    change
+      upperLift normalizedSlitBaseLift
+          ⟨SpecialPeriods.triangleRegularProject
+              PeriodFamily.Meridians.normalizedRegularMeridianRightPoint,
+            _⟩ =
+        _
+    have hp (t : unitInterval) :
+      SpecialPeriods.triangleRegularProject (PeriodFamily.Meridians.liftedOneHalfPath t) ∈
+        upperBase := by
+      rw [mem_regularOpen, PeriodFamily.Meridians.liftedOneHalfPath_coordinate,
+        PeriodFamily.Meridians.oneHalfPath, ite_eq_left ho]
+      exact SpecialPeriods.Triangle.upperOnePath_mem_upperSlitPlane t
+    apply upperLift_endpoint normalizedSlitBaseLift _ PeriodFamily.Meridians.liftedOneHalfPath hp
+    rfl
+  have hL :
+    lowerLiftOnOverlap normalizedSlitBaseLift 2 meridianRightOverlapPoint =
+      SpecialPeriods.triangleGenerator₂ •
+        PeriodFamily.Meridians.normalizedRegularMeridianRightPoint := by
+    change
+      lowerLift normalizedSlitBaseLift
+          ⟨SpecialPeriods.triangleRegularProject
+              PeriodFamily.Meridians.normalizedRegularMeridianRightPoint,
+            _⟩ =
+        _
+    have hp (t : unitInterval) :
+      SpecialPeriods.triangleRegularProject (PeriodFamily.Meridians.reflectedOneHalfPath t) ∈
+        lowerBase := by
+      rw [mem_regularOpen, PeriodFamily.Meridians.reflectedOneHalfPath_coordinate,
+        PeriodFamily.Meridians.oppositeOnePath, ite_eq_left ho]
+      exact SpecialPeriods.Triangle.lowerOnePath_mem_lowerSlitPlane t
+    apply
+      lowerLift_endpoint normalizedSlitBaseLift _ PeriodFamily.Meridians.reflectedOneHalfPath hp
+    exact (SpecialPeriods.triangleRegularProject_covering.map_smul _).symm
+  rw [hU, hL]
+
+private theorem PeriodFamily.Homology.normalizedOverlapTransition_right_of_nonpos
+    (ho : RiemannMapping.normalizationOrientation ≤ 0) :
+    normalizedOverlapTransition 2 = SpecialPeriods.triangleGenerator₂⁻¹ := by
+  have hn : ¬0 < RiemannMapping.normalizationOrientation := not_lt.mpr ho
+  apply
+    overlapTransition_eq_of_apply normalizedSlitBaseLift 2 SpecialPeriods.triangleGenerator₂⁻¹
+      meridianRightOverlapPoint
+  have hU :
+    upperLiftOnOverlap normalizedSlitBaseLift 2 meridianRightOverlapPoint =
+      SpecialPeriods.triangleGenerator₂ •
+        PeriodFamily.Meridians.normalizedRegularMeridianRightPoint := by
+    change
+      upperLift normalizedSlitBaseLift
+          ⟨SpecialPeriods.triangleRegularProject
+              PeriodFamily.Meridians.normalizedRegularMeridianRightPoint,
+            _⟩ =
+        _
+    have hp (t : unitInterval) :
+      SpecialPeriods.triangleRegularProject (PeriodFamily.Meridians.reflectedOneHalfPath t) ∈
+        upperBase := by
+      rw [mem_regularOpen, PeriodFamily.Meridians.reflectedOneHalfPath_coordinate,
+        PeriodFamily.Meridians.oppositeOnePath, ite_eq_right hn]
+      exact SpecialPeriods.Triangle.upperOnePath_mem_upperSlitPlane t
+    apply
+      upperLift_endpoint normalizedSlitBaseLift _ PeriodFamily.Meridians.reflectedOneHalfPath hp
+    exact (SpecialPeriods.triangleRegularProject_covering.map_smul _).symm
+  have hL :
+    lowerLiftOnOverlap normalizedSlitBaseLift 2 meridianRightOverlapPoint =
+      PeriodFamily.Meridians.normalizedRegularMeridianRightPoint := by
+    change
+      lowerLift normalizedSlitBaseLift
+          ⟨SpecialPeriods.triangleRegularProject
+              PeriodFamily.Meridians.normalizedRegularMeridianRightPoint,
+            _⟩ =
+        _
+    have hp (t : unitInterval) :
+      SpecialPeriods.triangleRegularProject (PeriodFamily.Meridians.liftedOneHalfPath t) ∈
+        lowerBase := by
+      rw [mem_regularOpen, PeriodFamily.Meridians.liftedOneHalfPath_coordinate,
+        PeriodFamily.Meridians.oneHalfPath, ite_eq_right hn]
+      exact SpecialPeriods.Triangle.lowerOnePath_mem_lowerSlitPlane t
+    apply lowerLift_endpoint normalizedSlitBaseLift _ PeriodFamily.Meridians.liftedOneHalfPath hp
+    rfl
+  rw [hU, hL, inv_smul_smul]
+
+private theorem
+    PeriodFamily.Homology.normalizedOverlapTransition_apply (i : Fin 3) (x : overlapBase i) :
+    normalizedOverlapTransition i • upperLiftOnOverlap normalizedSlitBaseLift i x =
+      lowerLiftOnOverlap normalizedSlitBaseLift i x :=
+  overlapTransition_apply normalizedSlitBaseLift i x
+
+private def PeriodFamily.Homology.triangleHomologyEquiv (g : SpecialPeriods.TriangleGroup) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology RealTorus₄ n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology RealTorus₄ n :=
+  PeriodTorusHigherHomology.homeomorphHomologyEquiv (SpecialPeriods.triangleTorusHomeomorph g) n
+
+@[simp]
+private theorem PeriodFamily.Homology.triangleHomologyEquiv_one (n : ℕ) :
+    triangleHomologyEquiv 1 n =
+      LinearEquiv.refl ℤ (SingularMayerVietoris.SingularHomology RealTorus₄ n) := by
+  rw [triangleHomologyEquiv, SpecialPeriods.triangleTorusHomeomorph_one,
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv_refl]
+
+@[simp]
+private theorem PeriodFamily.Homology.triangleHomologyEquiv_inv (g : SpecialPeriods.TriangleGroup)
+    (n : ℕ) : triangleHomologyEquiv g⁻¹ n = (triangleHomologyEquiv g n).symm := by
+  rw [triangleHomologyEquiv, SpecialPeriods.triangleTorusHomeomorph_inv]
+  exact
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv_symm
+        (SpecialPeriods.triangleTorusHomeomorph g) n).symm
+
+private theorem
+    PeriodFamily.Homology.triangleHomologyEquiv_zero (g : SpecialPeriods.TriangleGroup) :
+    triangleHomologyEquiv g 0 =
+      LinearEquiv.refl ℤ (SingularMayerVietoris.SingularHomology RealTorus₄ 0) := by
+  apply LinearEquiv.ext
+  intro a
+  apply (PeriodTorusHigherHomology.connectedHomologyZeroEquiv RealTorus₄).injective
+  exact
+    PeriodTorusHigherHomology.connectedHomologyZeroEquiv_natural
+      (SpecialPeriods.triangleTorusHomeomorph g : C(RealTorus₄, RealTorus₄)) a
+
+private def PeriodFamily.Homology.overlapHomologyAction (b : SlitBaseLift) (i : Fin 3) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology RealTorus₄ n →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology RealTorus₄ n :=
+  (triangleHomologyEquiv (overlapTransition b i) n).toLinearMap
+
+private def PeriodFamily.Homology.generatorHomologyEquiv (j : Bool) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology RealTorus₄ n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology RealTorus₄ n :=
+  triangleHomologyEquiv
+    (if j then SpecialPeriods.triangleGenerator₂ else SpecialPeriods.triangleGenerator₁) n
+
+private def PeriodFamily.Homology.sourceDifference (n : ℕ) :
+    (SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+        SingularMayerVietoris.SingularHomology RealTorus₄ n) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology RealTorus₄ n :=
+  TrianglePeriodFamilyHomologyAlgebra.delta (generatorHomologyEquiv Bool.false n).toLinearMap
+    (generatorHomologyEquiv Bool.true n).toLinearMap
+
+private def PeriodFamily.Homology.slitDifference (b : SlitBaseLift) (n : ℕ) :
+    (SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+        SingularMayerVietoris.SingularHomology RealTorus₄ n) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology RealTorus₄ n :=
+  TrianglePeriodFamilyHomologyAlgebra.delta (overlapHomologyAction b 0 n)
+    (overlapHomologyAction b 2 n)
+
+private abbrev PeriodFamily.Homology.normalizedSlitDifference (n : ℕ) :=
+  slitDifference normalizedSlitBaseLift n
+
+private theorem PeriodFamily.Homology.normalizedSlitDifference_of_pos (n : ℕ)
+    (ho : 0 < RiemannMapping.normalizationOrientation) :
+    normalizedSlitDifference n =
+      TrianglePeriodFamilyHomologyAlgebra.delta
+        (generatorHomologyEquiv Bool.false n).symm.toLinearMap
+        (generatorHomologyEquiv Bool.true n).toLinearMap := by
+  change
+    TrianglePeriodFamilyHomologyAlgebra.delta
+        (triangleHomologyEquiv (normalizedOverlapTransition 0) n).toLinearMap
+        (triangleHomologyEquiv (normalizedOverlapTransition 2) n).toLinearMap =
+      _
+  rw [normalizedOverlapTransition_left_of_pos ho, normalizedOverlapTransition_right_of_pos ho,
+    triangleHomologyEquiv_inv]
+  rfl
+
+private theorem PeriodFamily.Homology.normalizedSlitDifference_of_nonpos (n : ℕ)
+    (ho : RiemannMapping.normalizationOrientation ≤ 0) :
+    normalizedSlitDifference n =
+      TrianglePeriodFamilyHomologyAlgebra.delta (generatorHomologyEquiv Bool.false n).toLinearMap
+        (generatorHomologyEquiv Bool.true n).symm.toLinearMap := by
+  change
+    TrianglePeriodFamilyHomologyAlgebra.delta
+        (triangleHomologyEquiv (normalizedOverlapTransition 0) n).toLinearMap
+        (triangleHomologyEquiv (normalizedOverlapTransition 2) n).toLinearMap =
+      _
+  rw [normalizedOverlapTransition_left_of_nonpos ho,
+    normalizedOverlapTransition_right_of_nonpos ho, triangleHomologyEquiv_inv]
+  rfl
+
+private def PeriodFamily.Homology.normalizedSourceDomainEquiv (n : ℕ) :
+    (SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+        SingularMayerVietoris.SingularHomology RealTorus₄ n) ≃ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+        SingularMayerVietoris.SingularHomology RealTorus₄ n) :=
+  if 0 < RiemannMapping.normalizationOrientation then
+    TrianglePeriodFamilyHomologyAlgebra.inverseFirstCoordinate
+      (generatorHomologyEquiv Bool.false n)
+  else
+    TrianglePeriodFamilyHomologyAlgebra.inverseSecondCoordinate
+      (generatorHomologyEquiv Bool.true n)
+
+private theorem PeriodFamily.Homology.sourceDifference_coordinate_change (n : ℕ)
+    (x :
+      SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+        SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    sourceDifference n (normalizedSourceDomainEquiv n x) = normalizedSlitDifference n x := by
+  by_cases ho : 0 < RiemannMapping.normalizationOrientation
+  · rw [normalizedSourceDomainEquiv, ite_eq_left ho, normalizedSlitDifference_of_pos n ho]
+    exact
+      TrianglePeriodFamilyHomologyAlgebra.delta_inverse_first
+        (generatorHomologyEquiv Bool.false n) (generatorHomologyEquiv Bool.true n).toLinearMap x
+  · rw [normalizedSourceDomainEquiv, ite_eq_right ho,
+      normalizedSlitDifference_of_nonpos n (le_of_not_gt ho)]
+    exact
+      TrianglePeriodFamilyHomologyAlgebra.delta_inverse_second
+        (generatorHomologyEquiv Bool.false n).toLinearMap (generatorHomologyEquiv Bool.true n) x
+
+private theorem PeriodFamily.Homology.normalizedSlitDifference_range (n : ℕ) :
+    LinearMap.range (normalizedSlitDifference n) = LinearMap.range (sourceDifference n) :=
+  TrianglePeriodFamilyHomologyAlgebra.range_eq_of_coordinates _ _ (normalizedSourceDomainEquiv n)
+    (sourceDifference_coordinate_change n)
+
+private def PeriodFamily.Homology.normalizedSlitKernelEquiv (n : ℕ) :
+    LinearMap.ker (normalizedSlitDifference n) ≃ₗ[ℤ] LinearMap.ker (sourceDifference n) :=
+  TrianglePeriodFamilyHomologyAlgebra.kernelEquivOfCoordinates _ _ (normalizedSourceDomainEquiv n)
+    (sourceDifference_coordinate_change n)
+
+private def PeriodFamily.Homology.normalizedSlitCokernelEquiv (n : ℕ) :
+    (SingularMayerVietoris.SingularHomology RealTorus₄ n ⧸
+        LinearMap.range (normalizedSlitDifference n)) ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology RealTorus₄ n ⧸
+        LinearMap.range (sourceDifference n) :=
+  TrianglePeriodFamilyHomologyAlgebra.integralQuotientCongr (H :=
+    SingularMayerVietoris.SingularHomology RealTorus₄ n)
+    (LinearMap.range (normalizedSlitDifference n)) (LinearMap.range (sourceDifference n))
+    (normalizedSlitDifference_range n)
+
+@[simp]
+private theorem PeriodFamily.Homology.normalizedSlitCokernelEquiv_mk (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    normalizedSlitCokernelEquiv n (Submodule.Quotient.mk a) = Submodule.Quotient.mk a :=
+  rfl
+
+@[simp]
+private theorem PeriodFamily.Homology.sourceDifference_zero : sourceDifference 0 = 0 := by
+  apply LinearMap.ext
+  intro x
+  change
+    (triangleHomologyEquiv SpecialPeriods.triangleGenerator₁ 0 x.1 - x.1) +
+        (triangleHomologyEquiv SpecialPeriods.triangleGenerator₂ 0 x.2 - x.2) =
+      0
+  rw [triangleHomologyEquiv_zero, triangleHomologyEquiv_zero]
+  simp
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem
+    PeriodFamily.Boundary.triangleHomologyEquiv_mul_apply (g h : SpecialPeriods.TriangleGroup)
+    (n : ℕ) (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    PeriodFamily.Homology.triangleHomologyEquiv (g * h) n a =
+      PeriodFamily.Homology.triangleHomologyEquiv g n
+        (PeriodFamily.Homology.triangleHomologyEquiv h n a) := by
+  unfold PeriodFamily.Homology.triangleHomologyEquiv
+  rw [SpecialPeriods.triangleTorusHomeomorph_mul,
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv_trans]
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem
+    PeriodFamily.Boundary.triangleHomologyEquiv_pow_fixed (g : SpecialPeriods.TriangleGroup)
+    (n : ℕ) (a : SingularMayerVietoris.SingularHomology RealTorus₄ n)
+    (ha : PeriodFamily.Homology.triangleHomologyEquiv g n a = a) (k : ℕ) :
+    PeriodFamily.Homology.triangleHomologyEquiv (g ^ k) n a = a := by
+  induction k with
+  | zero => rw [pow_zero, PeriodFamily.Homology.triangleHomologyEquiv_one]; rfl
+  | succ k ih => rw [pow_succ, triangleHomologyEquiv_mul_apply, ha, ih]
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.ellipticTriangle_mkQ (j : Elliptic.Kind)
+    (x : RealPlane₄) :
+    SpecialPeriods.triangleTorusHomeomorph (SpecialPeriods.Triangle.ellipticGenerator j)
+        (standardLattice.mkQ x) =
+      standardLattice.mkQ (Elliptic.flatLinear j x) := by
+  cases j
+  · exact SpecialPeriods.triangleTorusAction_generator₁_mkQ x
+  · exact SpecialPeriods.triangleTorusAction_generator₂_mkQ x
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.flatTorusAffine_eq_translation_triangle (j : Elliptic.Kind)
+    (v : Lattice) :
+    (Elliptic.flatTorusAffine j v : C(RealTorus₄, RealTorus₄)) =
+      (PeriodTorusHigherHomology.rightTranslation
+            (standardLattice.mkQ ((1 / (j.order : ℝ)) • Elliptic.realCast v))).comp
+        (SpecialPeriods.triangleTorusHomeomorph (SpecialPeriods.Triangle.ellipticGenerator j) :
+          C(RealTorus₄, RealTorus₄)) := by
+  apply ContinuousMap.ext
+  intro x
+  obtain ⟨u, rfl⟩ := standardLattice.mkQ_surjective x
+  simp only [ContinuousMap.comp_apply, PeriodTorusHigherHomology.rightTranslation_apply]
+  calc
+    _ = standardLattice.mkQ (Elliptic.flatAffine j v u) := Elliptic.flatTorusAffine_mkQ j v u
+    _ = _ := by
+      rw [Elliptic.flatAffine, map_add]
+      exact
+        congrArg
+          (fun w : RealTorus₄ =>
+            w + standardLattice.mkQ ((1 / (j.order : ℝ)) • Elliptic.realCast v))
+          (ellipticTriangle_mkQ j u).symm
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem
+    PeriodFamily.Boundary.flatTorusAffine_homology_triangle (j : Elliptic.Kind) (v : Lattice)
+    (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap
+        (Elliptic.flatTorusAffine j v : C(RealTorus₄, RealTorus₄)) n =
+      (PeriodFamily.Homology.triangleHomologyEquiv (SpecialPeriods.Triangle.ellipticGenerator j)
+          n).toLinearMap := by
+  rw [flatTorusAffine_eq_translation_triangle, PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodTorusHigherHomology.rightTranslation_singularHomologyMap, LinearMap.id_comp]
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.nativeTailFrame_inv_homology_fixed (j : Elliptic.Kind) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n)
+    (ha :
+      PeriodFamily.Homology.triangleHomologyEquiv (SpecialPeriods.Triangle.ellipticGenerator j) n
+          a =
+        a) :
+    PeriodFamily.Homology.triangleHomologyEquiv (nativeTailFrame j)⁻¹ n a = a := by
+  obtain ⟨k, _, hk⟩ := nativeTailFrame_inv_eq_power j
+  rw [hk]
+  exact triangleHomologyEquiv_pow_fixed (SpecialPeriods.Triangle.ellipticGenerator j) n a ha k
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.ellipticWangBoundary_generator_fixed (j : Elliptic.Kind)
+    (v : Lattice) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology (MappingTorus.Torus (Elliptic.flatTorusAffine j v))
+        (n + 1)) :
+    PeriodFamily.Homology.triangleHomologyEquiv (SpecialPeriods.Triangle.ellipticGenerator j) n
+        (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j v) n a) =
+      MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j v) n a := by
+  have hb :
+    MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j v) n a ∈
+      LinearMap.ker (MappingTorusHomology.wangDifference (Elliptic.flatTorusAffine j v) n) := by
+    rw [← MappingTorusHomology.wangBoundary_range]
+    exact ⟨a, rfl⟩
+  have he := LinearMap.mem_ker.mp hb
+  change
+    MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j v) n a -
+        SingularMayerVietoris.singularHomologyMap
+          (Elliptic.flatTorusAffine j v : C(RealTorus₄, RealTorus₄)) n
+          (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j v) n a) =
+      0 at he
+  rw [flatTorusAffine_homology_triangle] at he
+  exact (sub_eq_zero.mp he).symm
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem
+    PeriodFamily.Boundary.nativeTailFrame_inv_wangBoundary (j : Elliptic.Kind) (v : Lattice)
+    (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology (MappingTorus.Torus (Elliptic.flatTorusAffine j v))
+        (n + 1)) :
+    PeriodFamily.Homology.triangleHomologyEquiv (nativeTailFrame j)⁻¹ n
+        (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j v) n a) =
+      MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j v) n a :=
+  nativeTailFrame_inv_homology_fixed j n _ (ellipticWangBoundary_generator_fixed j v n a)
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private theorem PeriodFamily.HomologyDifference.mem_range_iff_of_commuting {M N M' N' : Type*}
+    [AddCommGroup M] [AddCommGroup N] [AddCommGroup M'] [AddCommGroup N'] [Module ℤ M]
+    [Module ℤ N] [Module ℤ M'] [Module ℤ N'] (f : M →ₗ[ℤ] N) (g : M' →ₗ[ℤ] N') (e : M ≃ₗ[ℤ] M')
+    (d : N ≃ₗ[ℤ] N') (h : ∀ x, d (f x) = g (e x)) (y : N) :
+    d y ∈ LinearMap.range g ↔ y ∈ LinearMap.range f := by
+  constructor
+  · rintro ⟨x, hx⟩
+    refine ⟨e.symm x, d.injective ?_⟩
+    calc
+      d (f (e.symm x)) = g (e (e.symm x)) := h _
+      _ = g x := (congrArg g (e.apply_symm_apply x))
+      _ = d y := hx
+  · rintro ⟨x, hx⟩
+    exact ⟨e x, (h x).symm.trans (congrArg d hx)⟩
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def
+    PeriodFamily.HomologyDifference.kernelEquivOfCommuting {M N M' N' : Type*} [AddCommGroup M]
+    [AddCommGroup N] [AddCommGroup M'] [AddCommGroup N'] [Module ℤ M] [Module ℤ N] [Module ℤ M']
+    [Module ℤ N'] (f : M →ₗ[ℤ] N) (g : M' →ₗ[ℤ] N') (e : M ≃ₗ[ℤ] M') (d : N ≃ₗ[ℤ] N')
+    (h : ∀ x, d (f x) = g (e x)) : LinearMap.ker f ≃ₗ[ℤ] LinearMap.ker g :=
+  ({    toFun
+          x :=
+          ⟨e x.val, by
+            change g (e x.val) = 0
+            calc
+              g (e x.val) = d (f x.val) := (h x.val).symm
+              _ = d 0 := (congrArg d x.property)
+              _ = 0 := d.map_zero⟩
+        invFun
+          y :=
+          ⟨e.symm y.val, by
+            change f (e.symm y.val) = 0
+            apply d.injective
+            calc
+              d (f (e.symm y.val)) = g (e (e.symm y.val)) := h _
+              _ = g y.val := (congrArg g (e.apply_symm_apply y.val))
+              _ = 0 := y.property
+              _ = d 0 := d.map_zero.symm⟩
+        left_inv x := Subtype.ext (e.symm_apply_apply x.val)
+        right_inv y := Subtype.ext (e.apply_symm_apply y.val)
+        map_add' x y := Subtype.ext (e.map_add x.val y.val) } :
+      LinearMap.ker f ≃+ LinearMap.ker g).toIntLinearEquiv
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def
+    PeriodFamily.HomologyDifference.cokernelEquivOfCommuting {M N M' N' : Type*} [AddCommGroup M]
+    [AddCommGroup N] [AddCommGroup M'] [AddCommGroup N'] [Module ℤ M] [Module ℤ N] [Module ℤ M']
+    [Module ℤ N'] (f : M →ₗ[ℤ] N) (g : M' →ₗ[ℤ] N') (e : M ≃ₗ[ℤ] M') (d : N ≃ₗ[ℤ] N')
+    (h : ∀ x, d (f x) = g (e x)) : (N ⧸ LinearMap.range f) ≃ₗ[ℤ] (N' ⧸ LinearMap.range g) :=
+  ({    toEquiv :=
+          @Quotient.congr N N' (Submodule.quotientRel (LinearMap.range f))
+            (Submodule.quotientRel (LinearMap.range g)) d.toEquiv
+            (fun x y =>
+              by
+              change
+                (LinearMap.range f).quotientRel x y ↔ (LinearMap.range g).quotientRel (d x) (d y)
+              rw [Submodule.quotientRel_def, Submodule.quotientRel_def, ← map_sub]
+              exact (mem_range_iff_of_commuting f g e d h (x - y)).symm)
+        map_add' := by
+          rintro ⟨x⟩ ⟨y⟩
+          change Submodule.Quotient.mk (d (x + y)) = Submodule.Quotient.mk (d x + d y)
+          exact congrArg Submodule.Quotient.mk (d.map_add x y) } :
+      (N ⧸ LinearMap.range f) ≃+ (N' ⧸ LinearMap.range g)).toIntLinearEquiv
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def
+    PeriodFamily.Homology.familyOpen (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (U : TopologicalSpace.Opens SpecialPeriods.TriangleRegularQuotient) :
+    TopologicalSpace.Opens D.Space :=
+  ⟨D.projection ⁻¹' (U : Set SpecialPeriods.TriangleRegularQuotient),
+    U.isOpen.preimage D.projection_continuous⟩
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private abbrev PeriodFamily.Homology.upperFamily
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :=
+  familyOpen D upperBase
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private abbrev PeriodFamily.Homology.lowerFamily
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :=
+  familyOpen D lowerBase
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private abbrev PeriodFamily.Homology.overlapFamily
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (i : Fin 3) :=
+  familyOpen D (overlapBase i)
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Homology.upperFamily_union_lowerFamily
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    (upperFamily D : Set D.Space) ∪ lowerFamily D = Set.univ := by
+  apply Set.eq_univ_of_forall
+  intro x
+  exact
+    SpecialPeriods.Triangle.mem_upperSlit_or_lowerSlit
+      (SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph (D.projection x))
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Homology.overlapFamily_subset
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (i : Fin 3) :
+    (overlapFamily D i : Set D.Space) ⊆ (upperFamily D : Set D.Space) ∩ lowerFamily D :=
+  fun _ hx => overlapBase_subset i hx
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Homology.overlapFamily_pairwise_disjoint
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    Pairwise fun i j : Fin 3 => Disjoint (overlapFamily D i : Set D.Space) (overlapFamily D j) := by
+  intro i j hij
+  apply Set.disjoint_left.mpr
+  intro x hi hj
+  exact Set.disjoint_left.mp (overlapBase_pairwise_disjoint hij) hi hj
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Homology.overlapFamily_iUnion
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    (⋃ i : Fin 3, (overlapFamily D i : Set D.Space)) =
+      (upperFamily D : Set D.Space) ∩ lowerFamily D := by
+  ext x
+  constructor
+  · intro hx
+    obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hx
+    exact overlapFamily_subset D i hi
+  · intro hx
+    have hh :
+      D.projection x ∈
+        ⋃ i : Fin 3, (overlapBase i : Set SpecialPeriods.TriangleRegularQuotient) := by
+      rw [overlapBase_iUnion]
+      exact hx
+    obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hh
+    exact Set.mem_iUnion.mpr ⟨i, hi⟩
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Homology.sectionChart
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (U : TopologicalSpace.Opens SpecialPeriods.TriangleRegularQuotient)
+    (s : C(U, SpecialPeriods.TriangleRegularPoint))
+    (hs : ∀ x, SpecialPeriods.triangleRegularProject (s x) = x.val) :
+    familyOpen D U ≃ₜ U × RealTorus₄ :=
+  DiagonalQuotient.sectionHomeomorph SpecialPeriods.triangleRegularProject_covering U s hs
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+@[simp]
+private theorem PeriodFamily.Homology.sectionChart_symm_coe
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (U : TopologicalSpace.Opens SpecialPeriods.TriangleRegularQuotient)
+    (s : C(U, SpecialPeriods.TriangleRegularPoint))
+    (hs : ∀ x, SpecialPeriods.triangleRegularProject (s x) = x.val) (x : U × RealTorus₄) :
+    ((sectionChart D U s hs).symm x : D.Space) = D.quotient (s x.1, x.2) :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Homology.sectionChart_projection
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (U : TopologicalSpace.Opens SpecialPeriods.TriangleRegularQuotient)
+    (s : C(U, SpecialPeriods.TriangleRegularPoint))
+    (hs : ∀ x, SpecialPeriods.triangleRegularProject (s x) = x.val) (x : familyOpen D U) :
+    ((sectionChart D U s hs x).1 : SpecialPeriods.TriangleRegularQuotient) = D.projection x.val :=
+  DiagonalQuotient.sectionHomeomorph_projection SpecialPeriods.triangleRegularProject_covering U s
+    hs x
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+@[simp]
+private theorem PeriodFamily.Homology.sectionChart_apply_quotient
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (U : TopologicalSpace.Opens SpecialPeriods.TriangleRegularQuotient)
+    (s : C(U, SpecialPeriods.TriangleRegularPoint))
+    (hs : ∀ x, SpecialPeriods.triangleRegularProject (s x) = x.val) (x : U) (f : RealTorus₄) :
+    sectionChart D U s hs
+        ⟨D.quotient (s x, f),
+          by
+          change SpecialPeriods.triangleRegularProject (s x) ∈ U
+          rw [hs x]
+          exact x.property⟩ =
+      (x, f) :=
+  DiagonalQuotient.sectionHomeomorph_apply_quotient SpecialPeriods.triangleRegularProject_covering
+    U s hs x f
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def
+    PeriodFamily.Homology.upperChart (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (b : SlitBaseLift) : upperFamily D ≃ₜ upperBase × RealTorus₄ :=
+  sectionChart D upperBase (upperLift b) (upperLift_project b)
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def
+    PeriodFamily.Homology.lowerChart (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (b : SlitBaseLift) : lowerFamily D ≃ₜ lowerBase × RealTorus₄ :=
+  sectionChart D lowerBase (lowerLift b) (lowerLift_project b)
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Homology.overlapChart
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (i : Fin 3) :
+    overlapFamily D i ≃ₜ overlapBase i × RealTorus₄ :=
+  sectionChart D (overlapBase i) (upperLiftOnOverlap b i) (upperLiftOnOverlap_project b i)
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+@[simp]
+private theorem PeriodFamily.Homology.overlapChart_symm_coe
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (i : Fin 3)
+    (x : overlapBase i × RealTorus₄) :
+    ((overlapChart D b i).symm x : D.Space) = D.quotient (upperLiftOnOverlap b i x.1, x.2) :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Homology.overlapFamilyToUpper
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (i : Fin 3) :
+    C(overlapFamily D i, upperFamily D) :=
+  ⟨fun x => ⟨x.val, (overlapFamily_subset D i x.property).1⟩, by fun_prop⟩
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Homology.overlapFamilyToLower
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (i : Fin 3) :
+    C(overlapFamily D i, lowerFamily D) :=
+  ⟨fun x => ⟨x.val, (overlapFamily_subset D i x.property).2⟩, by fun_prop⟩
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Homology.upperChart_overlapFamilyToUpper
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (i : Fin 3)
+    (x : overlapFamily D i) :
+    upperChart D b (overlapFamilyToUpper D i x) =
+      (overlapToUpper i (overlapChart D b i x).1, (overlapChart D b i x).2) := by
+  obtain ⟨y, rfl⟩ := (overlapChart D b i).symm.surjective x
+  rw [Homeomorph.apply_symm_apply]
+  exact
+    sectionChart_apply_quotient D upperBase (upperLift b) (upperLift_project b)
+      (overlapToUpper i y.1) y.2
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Homology.lowerChart_overlapFamilyToLower
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (i : Fin 3)
+    (x : overlapFamily D i) :
+    lowerChart D b (overlapFamilyToLower D i x) =
+      (overlapToLower i (overlapChart D b i x).1,
+        SpecialPeriods.triangleTorusHomeomorph (overlapTransition b i)
+          (overlapChart D b i x).2) := by
+  obtain ⟨y, rfl⟩ := (overlapChart D b i).symm.surjective x
+  rw [Homeomorph.apply_symm_apply]
+  apply (lowerChart D b).symm.injective
+  rw [Homeomorph.symm_apply_apply]
+  apply Subtype.ext
+  change
+    D.quotient (upperLiftOnOverlap b i y.1, y.2) =
+      D.quotient
+        (lowerLiftOnOverlap b i y.1,
+          SpecialPeriods.triangleTorusHomeomorph (overlapTransition b i) y.2)
+  rw [← overlapTransition_apply b i y.1]
+  exact
+    (DiagonalQuotient.quotient_smul SpecialPeriods.TriangleGroup
+        SpecialPeriods.TriangleRegularPoint RealTorus₄ (overlapTransition b i)
+        (upperLiftOnOverlap b i y.1, y.2)).symm
+
+private abbrev PeriodFamily.Homology.familyLeftHomologyMap
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :=
+  SingularMayerVietoris.leftHomologyMap (upperFamily D : Set D.Space) (lowerFamily D) n
+
+private abbrev PeriodFamily.Homology.familyRightHomologyMap
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :=
+  SingularMayerVietoris.rightHomologyMap (upperFamily D : Set D.Space) (lowerFamily D) n
+
+private def PeriodFamily.Homology.familyConnectingHomomorphism
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology D.Space (n + 1) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology
+        ((upperFamily D : Set D.Space) ∩ lowerFamily D : Set D.Space) n :=
+  SingularMayerVietoris.connectingHomomorphism (upperFamily D : Set D.Space) (lowerFamily D)
+    (upperFamily D).isOpen (lowerFamily D).isOpen (upperFamily_union_lowerFamily D) n
+
+private theorem PeriodFamily.Homology.family_exact_at_pair
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    Function.Exact (familyLeftHomologyMap D n) (familyRightHomologyMap D n) := by
+  apply LinearMap.exact_iff.mpr
+  exact
+    (SingularMayerVietoris.exact_at_pair (upperFamily D : Set D.Space) (lowerFamily D)
+        (upperFamily D).isOpen (lowerFamily D).isOpen (upperFamily_union_lowerFamily D) n).symm
+
+private theorem PeriodFamily.Homology.family_exact_at_ambient
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    Function.Exact (familyRightHomologyMap D (n + 1)) (familyConnectingHomomorphism D n) := by
+  apply LinearMap.exact_iff.mpr
+  exact
+    (SingularMayerVietoris.exact_at_ambient (upperFamily D : Set D.Space) (lowerFamily D)
+        (upperFamily D).isOpen (lowerFamily D).isOpen (upperFamily_union_lowerFamily D) n).symm
+
+private theorem PeriodFamily.Homology.family_exact_at_intersection
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    Function.Exact (familyConnectingHomomorphism D n) (familyLeftHomologyMap D n) := by
+  apply LinearMap.exact_iff.mpr
+  exact
+    (SingularMayerVietoris.exact_at_intersection (upperFamily D : Set D.Space) (lowerFamily D)
+        (upperFamily D).isOpen (lowerFamily D).isOpen (upperFamily_union_lowerFamily D) n).symm
+
+private theorem PeriodFamily.Homology.familyRightHomologyMap_zero_surjective
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    Function.Surjective (familyRightHomologyMap D 0) :=
+  SingularMayerVietoris.rightHomologyMap_zero_surjective (upperFamily D : Set D.Space)
+    (lowerFamily D) (upperFamily D).isOpen (lowerFamily D).isOpen
+    (upperFamily_union_lowerFamily D)
+
+private def PeriodFamily.Homology.familyIntersection
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    TopologicalSpace.Opens D.Space :=
+  upperFamily D ⊓ lowerFamily D
+
+private def PeriodFamily.Homology.intersectionIndex : Fin 3 → Fin 3 :=
+  Equiv.swap 0 1
+
+@[simp]
+private theorem PeriodFamily.Homology.intersectionIndex_zero : intersectionIndex 0 = 1 := by decide
+
+@[simp]
+private theorem PeriodFamily.Homology.intersectionIndex_one : intersectionIndex 1 = 0 := by decide
+
+@[simp]
+private theorem PeriodFamily.Homology.intersectionIndex_two : intersectionIndex 2 = 2 := by decide
+
+private theorem PeriodFamily.Homology.intersectionIndex_injective :
+    Function.Injective intersectionIndex :=
+  (Equiv.swap (0 : Fin 3) 1).injective
+
+private theorem PeriodFamily.Homology.intersectionIndex_surjective :
+    Function.Surjective intersectionIndex :=
+  (Equiv.swap (0 : Fin 3) 1).surjective
+
+private def PeriodFamily.Homology.intersectionPiece
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (i : Fin 3) :
+    TopologicalSpace.Opens (familyIntersection D) :=
+  ⟨Subtype.val ⁻¹' (overlapFamily D (intersectionIndex i) : Set D.Space),
+    (overlapFamily D (intersectionIndex i)).isOpen.preimage continuous_subtype_val⟩
+
+private theorem PeriodFamily.Homology.intersectionPiece_pairwise_disjoint
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    Pairwise fun i j : Fin 3 =>
+      Disjoint (intersectionPiece D i : Set (familyIntersection D)) (intersectionPiece D j) := by
+  intro i j hij
+  apply Set.disjoint_left.mpr
+  intro x hi hj
+  exact
+    Set.disjoint_left.mp
+      (overlapFamily_pairwise_disjoint D (fun h => hij (intersectionIndex_injective h))) hi hj
+
+private theorem PeriodFamily.Homology.intersectionPiece_iUnion
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    (⋃ i : Fin 3, (intersectionPiece D i : Set (familyIntersection D))) = Set.univ := by
+  apply Set.eq_univ_of_forall
+  intro x
+  have hx : x.val ∈ ⋃ j : Fin 3, (overlapFamily D j : Set D.Space) := by
+    rw [overlapFamily_iUnion]
+    exact x.property
+  obtain ⟨j, hj⟩ := Set.mem_iUnion.mp hx
+  obtain ⟨i, hi⟩ := intersectionIndex_surjective j
+  apply Set.mem_iUnion.mpr
+  refine ⟨i, ?_⟩
+  change x.val ∈ overlapFamily D (intersectionIndex i)
+  rw [hi]
+  exact hj
+
+private def PeriodFamily.Homology.intersectionPieceHomeomorph
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (i : Fin 3) :
+    intersectionPiece D i ≃ₜ overlapFamily D (intersectionIndex i)
+    where
+  toFun x := ⟨x.val.val, x.property⟩
+  invFun x := ⟨⟨x.val, overlapFamily_subset D (intersectionIndex i) x.property⟩, x.property⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := by fun_prop
+  continuous_invFun := by fun_prop
+
+private def PeriodFamily.Homology.intersectionToUpper
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    C(familyIntersection D, upperFamily D) :=
+  ⟨fun x => ⟨x.val, x.property.1⟩, by fun_prop⟩
+
+private def PeriodFamily.Homology.intersectionToLower
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    C(familyIntersection D, lowerFamily D) :=
+  ⟨fun x => ⟨x.val, x.property.2⟩, by fun_prop⟩
+
+private theorem PeriodFamily.Homology.intersectionToUpper_comp_piece
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (i : Fin 3) :
+    (intersectionToUpper D).comp
+        (⟨Subtype.val, continuous_subtype_val⟩ : C(intersectionPiece D i, familyIntersection D)) =
+      (overlapFamilyToUpper D (intersectionIndex i)).comp
+        (intersectionPieceHomeomorph D i : C(_, _)) :=
+  rfl
+
+private theorem PeriodFamily.Homology.intersectionToLower_comp_piece
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (i : Fin 3) :
+    (intersectionToLower D).comp
+        (⟨Subtype.val, continuous_subtype_val⟩ : C(intersectionPiece D i, familyIntersection D)) =
+      (overlapFamilyToLower D (intersectionIndex i)).comp
+        (intersectionPieceHomeomorph D i : C(_, _)) :=
+  rfl
+
+private def PeriodFamily.Homology.upperHomotopyEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) :
+    upperFamily D ≃ₕ RealTorus₄ :=
+  (upperChart D b).toHomotopyEquiv.trans
+    (PeriodTorusHigherHomology.CircleTopology.contractibleProdHomotopyEquiv upperBase RealTorus₄)
+
+private def PeriodFamily.Homology.lowerHomotopyEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) :
+    lowerFamily D ≃ₕ RealTorus₄ :=
+  (lowerChart D b).toHomotopyEquiv.trans
+    (PeriodTorusHigherHomology.CircleTopology.contractibleProdHomotopyEquiv lowerBase RealTorus₄)
+
+private def PeriodFamily.Homology.overlapHomotopyEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (i : Fin 3) :
+    overlapFamily D i ≃ₕ RealTorus₄ :=
+  (overlapChart D b i).toHomotopyEquiv.trans
+    (PeriodTorusHigherHomology.CircleTopology.contractibleProdHomotopyEquiv (overlapBase i)
+      RealTorus₄)
+
+private theorem PeriodFamily.Homology.upperHomotopyEquiv_comp_overlap
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (i : Fin 3) :
+    (upperHomotopyEquiv D b).toFun.comp (overlapFamilyToUpper D i) =
+      (overlapHomotopyEquiv D b i).toFun := by
+  apply ContinuousMap.ext
+  intro x
+  exact congrArg Prod.snd (upperChart_overlapFamilyToUpper D b i x)
+
+private theorem PeriodFamily.Homology.lowerHomotopyEquiv_comp_overlap
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (i : Fin 3) :
+    (lowerHomotopyEquiv D b).toFun.comp (overlapFamilyToLower D i) =
+      (SpecialPeriods.triangleTorusHomeomorph (overlapTransition b i) :
+            C(RealTorus₄, RealTorus₄)).comp
+        (overlapHomotopyEquiv D b i).toFun := by
+  apply ContinuousMap.ext
+  intro x
+  exact congrArg Prod.snd (lowerChart_overlapFamilyToLower D b i x)
+
+private def PeriodFamily.Homology.upperHomologyEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (upperFamily D) n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology RealTorus₄ n :=
+  PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (upperHomotopyEquiv D b) n
+
+private def PeriodFamily.Homology.lowerHomologyEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (lowerFamily D) n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology RealTorus₄ n :=
+  PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (lowerHomotopyEquiv D b) n
+
+private def PeriodFamily.Homology.overlapHomologyEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (i : Fin 3)
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (overlapFamily D i) n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology RealTorus₄ n :=
+  PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (overlapHomotopyEquiv D b i) n
+
+@[simp]
+private theorem PeriodFamily.Homology.upperHomologyEquiv_apply
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (upperFamily D) n) :
+    upperHomologyEquiv D b n a =
+      SingularMayerVietoris.singularHomologyMap (upperHomotopyEquiv D b).toFun n a :=
+  rfl
+
+@[simp]
+private theorem PeriodFamily.Homology.lowerHomologyEquiv_apply
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (lowerFamily D) n) :
+    lowerHomologyEquiv D b n a =
+      SingularMayerVietoris.singularHomologyMap (lowerHomotopyEquiv D b).toFun n a :=
+  rfl
+
+private theorem PeriodFamily.Homology.upperHomologyEquiv_overlap
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (i : Fin 3)
+    (n : ℕ) (a : SingularMayerVietoris.SingularHomology (overlapFamily D i) n) :
+    upperHomologyEquiv D b n
+        (SingularMayerVietoris.singularHomologyMap (overlapFamilyToUpper D i) n a) =
+      overlapHomologyEquiv D b i n a := by
+  rw [upperHomologyEquiv_apply, ← LinearMap.comp_apply, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp, upperHomotopyEquiv_comp_overlap]
+  rfl
+
+private theorem PeriodFamily.Homology.lowerHomologyEquiv_overlap
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (i : Fin 3)
+    (n : ℕ) (a : SingularMayerVietoris.SingularHomology (overlapFamily D i) n) :
+    lowerHomologyEquiv D b n
+        (SingularMayerVietoris.singularHomologyMap (overlapFamilyToLower D i) n a) =
+      SingularMayerVietoris.singularHomologyMap
+        (SpecialPeriods.triangleTorusHomeomorph (overlapTransition b i) :
+          C(RealTorus₄, RealTorus₄))
+        n (overlapHomologyEquiv D b i n a) := by
+  rw [lowerHomologyEquiv_apply, ← LinearMap.comp_apply, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp, lowerHomotopyEquiv_comp_overlap,
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+  rfl
+
+private def PeriodFamily.Homology.pairHomologyEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ) :
+    (SingularMayerVietoris.SingularHomology (upperFamily D) n ×
+        SingularMayerVietoris.SingularHomology (lowerFamily D) n) ≃ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+        SingularMayerVietoris.SingularHomology RealTorus₄ n) :=
+  ((upperHomologyEquiv D b n).toAddEquiv.prodCongr
+      (lowerHomologyEquiv D b n).toAddEquiv).toIntLinearEquiv
+
+private abbrev PeriodFamily.Homology.openPartitionSum {X : Type} [TopologicalSpace X]
+    (U : Fin 3 → TopologicalSpace.Opens X) :=
+  U 0 ⊕ (U 1 ⊕ U 2)
+
+private def PeriodFamily.Homology.openPartitionInclusion {X : Type} [TopologicalSpace X]
+    (U : Fin 3 → TopologicalSpace.Opens X) (i : Fin 3) : C(U i, X) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private def PeriodFamily.Homology.openPartitionSumMap {X : Type} [TopologicalSpace X]
+    (U : Fin 3 → TopologicalSpace.Opens X) : C(openPartitionSum U, X) :=
+  PeriodTorusHigherHomology.sumElimMap (openPartitionInclusion U 0)
+    (PeriodTorusHigherHomology.sumElimMap (openPartitionInclusion U 1)
+      (openPartitionInclusion U 2))
+
+private theorem PeriodFamily.Homology.openPartitionSumMap_isOpenMap {X : Type} [TopologicalSpace X]
+    (U : Fin 3 → TopologicalSpace.Opens X) : IsOpenMap (openPartitionSumMap U) :=
+  (U 0).isOpen.isOpenMap_subtype_val.sumElim
+    ((U 1).isOpen.isOpenMap_subtype_val.sumElim (U 2).isOpen.isOpenMap_subtype_val)
+
+public
+theorem PeriodFamily.Homology.openPartitionInclusion_ne_mo1973_25234 {X : Type}
+    [TopologicalSpace X] (U : Fin 3 → TopologicalSpace.Opens X)
+    (hdisj : Pairwise fun i j : Fin 3 => Disjoint (U i : Set X) (U j : Set X)) {i j : Fin 3}
+    (hij : i ≠ j) (x : U i) (y : U j) : (x : X) ≠ (y : X) := by
+  intro h
+  exact Set.disjoint_left.mp (hdisj hij) x.property (h.symm ▸ y.property)
+
+private theorem PeriodFamily.Homology.openPartitionSumMap_injective {X : Type} [TopologicalSpace X]
+    (U : Fin 3 → TopologicalSpace.Opens X)
+    (hdisj : Pairwise fun i j : Fin 3 => Disjoint (U i : Set X) (U j : Set X)) :
+    Function.Injective (openPartitionSumMap U) := by
+  rintro (x | (x | x)) (y | (y | y)) h
+  · exact congrArg Sum.inl (Subtype.ext h)
+  · exact
+      False.elim
+        (openPartitionInclusion_ne_mo1973_25234 U hdisj (by decide : (0 : Fin 3) ≠ 1) x y h)
+  · exact
+      False.elim
+        (openPartitionInclusion_ne_mo1973_25234 U hdisj (by decide : (0 : Fin 3) ≠ 2) x y h)
+  · exact
+      False.elim
+        (openPartitionInclusion_ne_mo1973_25234 U hdisj (by decide : (1 : Fin 3) ≠ 0) x y h)
+  · exact congrArg (Sum.inr ∘ Sum.inl) (Subtype.ext h)
+  · exact
+      False.elim
+        (openPartitionInclusion_ne_mo1973_25234 U hdisj (by decide : (1 : Fin 3) ≠ 2) x y h)
+  · exact
+      False.elim
+        (openPartitionInclusion_ne_mo1973_25234 U hdisj (by decide : (2 : Fin 3) ≠ 0) x y h)
+  · exact
+      False.elim
+        (openPartitionInclusion_ne_mo1973_25234 U hdisj (by decide : (2 : Fin 3) ≠ 1) x y h)
+  · exact congrArg (Sum.inr ∘ Sum.inr) (Subtype.ext h)
+
+private theorem PeriodFamily.Homology.openPartitionSumMap_surjective {X : Type} [TopologicalSpace X]
+    (U : Fin 3 → TopologicalSpace.Opens X) (hcover : (⋃ i, (U i : Set X)) = Set.univ) :
+    Function.Surjective (openPartitionSumMap U) := by
+  intro x
+  have hx : x ∈ ⋃ i, (U i : Set X) := by rw [hcover]; exact Set.mem_univ x
+  obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hx
+  fin_cases i
+  · exact ⟨Sum.inl ⟨x, hi⟩, rfl⟩
+  · exact ⟨Sum.inr (Sum.inl ⟨x, hi⟩), rfl⟩
+  · exact ⟨Sum.inr (Sum.inr ⟨x, hi⟩), rfl⟩
+
+private def PeriodFamily.Homology.openPartitionHomeomorph {X : Type} [TopologicalSpace X]
+    (U : Fin 3 → TopologicalSpace.Opens X)
+    (hdisj : Pairwise fun i j : Fin 3 => Disjoint (U i : Set X) (U j : Set X))
+    (hcover : (⋃ i, (U i : Set X)) = Set.univ) : X ≃ₜ openPartitionSum U :=
+  ((Equiv.ofBijective (openPartitionSumMap U)
+          ⟨openPartitionSumMap_injective U hdisj,
+            openPartitionSumMap_surjective U hcover⟩).toHomeomorphOfContinuousOpen
+      (openPartitionSumMap U).continuous (openPartitionSumMap_isOpenMap U)).symm
+
+@[simp]
+private theorem
+    PeriodFamily.Homology.openPartitionHomeomorph_symm_apply {X : Type} [TopologicalSpace X]
+    (U : Fin 3 → TopologicalSpace.Opens X)
+    (hdisj : Pairwise fun i j : Fin 3 => Disjoint (U i : Set X) (U j : Set X))
+    (hcover : (⋃ i, (U i : Set X)) = Set.univ) (a : openPartitionSum U) :
+    (openPartitionHomeomorph U hdisj hcover).symm a = openPartitionSumMap U a :=
+  rfl
+
+private def PeriodFamily.Homology.tripleSumHomologyEquiv (A B C : Type) [TopologicalSpace A]
+    [TopologicalSpace B] [TopologicalSpace C] (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (A ⊕ (B ⊕ C)) n ≃ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology A n ×
+        (SingularMayerVietoris.SingularHomology B n ×
+          SingularMayerVietoris.SingularHomology C n)) :=
+  (PeriodTorusHigherHomology.sumHomologyEquiv A (B ⊕ C) n).trans
+    (((AddEquiv.refl (SingularMayerVietoris.SingularHomology A n)).prodCongr
+        (PeriodTorusHigherHomology.sumHomologyEquiv B C n).toAddEquiv).toIntLinearEquiv)
+
+private theorem
+    PeriodFamily.Homology.tripleSumHomologyEquiv_sumElim_symm {A : Type} {B : Type} {C : Type}
+    [TopologicalSpace A] [TopologicalSpace B] [TopologicalSpace C] {D : Type} [TopologicalSpace D]
+    (f : C(A, D)) (g : C(B, D)) (h : C(C, D)) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology A n ×
+        (SingularMayerVietoris.SingularHomology B n ×
+          SingularMayerVietoris.SingularHomology C n)) :
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.sumElimMap f (PeriodTorusHigherHomology.sumElimMap g h)) n
+        ((tripleSumHomologyEquiv A B C n).symm a) =
+      SingularMayerVietoris.singularHomologyMap f n a.1 +
+        (SingularMayerVietoris.singularHomologyMap g n a.2.1 +
+          SingularMayerVietoris.singularHomologyMap h n a.2.2) := by
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.sumElimMap f (PeriodTorusHigherHomology.sumElimMap g h)) n
+        ((PeriodTorusHigherHomology.sumHomologyEquiv A (B ⊕ C) n).symm
+          (a.1, (PeriodTorusHigherHomology.sumHomologyEquiv B C n).symm a.2)) =
+      _
+  rw [PeriodTorusHigherHomology.sumHomologyEquiv_sumElim_symm,
+    PeriodTorusHigherHomology.sumHomologyEquiv_sumElim_symm]
+
+private theorem PeriodFamily.Homology.openPartitionHomeomorph_symm_toContinuousMap {X : Type}
+    [TopologicalSpace X] (U : Fin 3 → TopologicalSpace.Opens X)
+    (hdisj : Pairwise fun i j : Fin 3 => Disjoint (U i : Set X) (U j : Set X))
+    (hcover : (⋃ i, (U i : Set X)) = Set.univ) :
+    ((openPartitionHomeomorph U hdisj hcover).symm : C(openPartitionSum U, X)) =
+      openPartitionSumMap U := by
+  apply ContinuousMap.ext
+  exact openPartitionHomeomorph_symm_apply U hdisj hcover
+
+private def PeriodFamily.Homology.openPartitionHomologyEquiv {X : Type} [TopologicalSpace X]
+    (U : Fin 3 → TopologicalSpace.Opens X)
+    (hdisj : Pairwise fun i j : Fin 3 => Disjoint (U i : Set X) (U j : Set X))
+    (hcover : (⋃ i, (U i : Set X)) = Set.univ) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology X n ≃ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology (U 0) n ×
+        (SingularMayerVietoris.SingularHomology (U 1) n ×
+          SingularMayerVietoris.SingularHomology (U 2) n)) :=
+  (PeriodTorusHigherHomology.homeomorphHomologyEquiv (openPartitionHomeomorph U hdisj hcover)
+        n).trans
+    (tripleSumHomologyEquiv (U 0) (U 1) (U 2) n)
+
+private theorem PeriodFamily.Homology.openPartitionHomologyEquiv_symm_apply {X : Type}
+    [TopologicalSpace X] (U : Fin 3 → TopologicalSpace.Opens X)
+    (hdisj : Pairwise fun i j : Fin 3 => Disjoint (U i : Set X) (U j : Set X))
+    (hcover : (⋃ i, (U i : Set X)) = Set.univ) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology (U 0) n ×
+        (SingularMayerVietoris.SingularHomology (U 1) n ×
+          SingularMayerVietoris.SingularHomology (U 2) n)) :
+    (openPartitionHomologyEquiv U hdisj hcover n).symm a =
+      SingularMayerVietoris.singularHomologyMap (openPartitionInclusion U 0) n a.1 +
+        (SingularMayerVietoris.singularHomologyMap (openPartitionInclusion U 1) n a.2.1 +
+          SingularMayerVietoris.singularHomologyMap (openPartitionInclusion U 2) n a.2.2) := by
+  change
+    SingularMayerVietoris.singularHomologyMap
+        ((openPartitionHomeomorph U hdisj hcover).symm : C(openPartitionSum U, X)) n
+        ((tripleSumHomologyEquiv (U 0) (U 1) (U 2) n).symm a) =
+      _
+  rw [openPartitionHomeomorph_symm_toContinuousMap]
+  exact
+    tripleSumHomologyEquiv_sumElim_symm (openPartitionInclusion U 0) (openPartitionInclusion U 1)
+      (openPartitionInclusion U 2) n a
+
+@[simp]
+private theorem PeriodFamily.Homology.openPartitionHomologyEquiv_inclusion_zero {X : Type}
+    [TopologicalSpace X] (U : Fin 3 → TopologicalSpace.Opens X)
+    (hdisj : Pairwise fun i j : Fin 3 => Disjoint (U i : Set X) (U j : Set X))
+    (hcover : (⋃ i, (U i : Set X)) = Set.univ) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (U 0) n) :
+    openPartitionHomologyEquiv U hdisj hcover n
+        (SingularMayerVietoris.singularHomologyMap (openPartitionInclusion U 0) n a) =
+      (a, (0, 0)) := by
+  apply (openPartitionHomologyEquiv U hdisj hcover n).symm.injective
+  rw [LinearEquiv.symm_apply_apply, openPartitionHomologyEquiv_symm_apply]
+  simp only [map_zero, add_zero]
+
+@[simp]
+private theorem PeriodFamily.Homology.openPartitionHomologyEquiv_inclusion_one {X : Type}
+    [TopologicalSpace X] (U : Fin 3 → TopologicalSpace.Opens X)
+    (hdisj : Pairwise fun i j : Fin 3 => Disjoint (U i : Set X) (U j : Set X))
+    (hcover : (⋃ i, (U i : Set X)) = Set.univ) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (U 1) n) :
+    openPartitionHomologyEquiv U hdisj hcover n
+        (SingularMayerVietoris.singularHomologyMap (openPartitionInclusion U 1) n a) =
+      (0, (a, 0)) := by
+  apply (openPartitionHomologyEquiv U hdisj hcover n).symm.injective
+  rw [LinearEquiv.symm_apply_apply, openPartitionHomologyEquiv_symm_apply]
+  simp only [map_zero, zero_add, add_zero]
+
+@[simp]
+private theorem PeriodFamily.Homology.openPartitionHomologyEquiv_inclusion_two {X : Type}
+    [TopologicalSpace X] (U : Fin 3 → TopologicalSpace.Opens X)
+    (hdisj : Pairwise fun i j : Fin 3 => Disjoint (U i : Set X) (U j : Set X))
+    (hcover : (⋃ i, (U i : Set X)) = Set.univ) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (U 2) n) :
+    openPartitionHomologyEquiv U hdisj hcover n
+        (SingularMayerVietoris.singularHomologyMap (openPartitionInclusion U 2) n a) =
+      (0, (0, a)) := by
+  apply (openPartitionHomologyEquiv U hdisj hcover n).symm.injective
+  rw [LinearEquiv.symm_apply_apply, openPartitionHomologyEquiv_symm_apply]
+  simp only [map_zero, zero_add]
+
+private theorem PeriodFamily.Homology.openPartitionHomologyEquiv_map_out_symm {X : Type}
+    [TopologicalSpace X] (U : Fin 3 → TopologicalSpace.Opens X)
+    (hdisj : Pairwise fun i j : Fin 3 => Disjoint (U i : Set X) (U j : Set X))
+    (hcover : (⋃ i, (U i : Set X)) = Set.univ) {Y : Type} [TopologicalSpace Y] (f : C(X, Y))
+    (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology (U 0) n ×
+        (SingularMayerVietoris.SingularHomology (U 1) n ×
+          SingularMayerVietoris.SingularHomology (U 2) n)) :
+    SingularMayerVietoris.singularHomologyMap f n
+        ((openPartitionHomologyEquiv U hdisj hcover n).symm a) =
+      SingularMayerVietoris.singularHomologyMap (f.comp (openPartitionInclusion U 0)) n a.1 +
+        (SingularMayerVietoris.singularHomologyMap (f.comp (openPartitionInclusion U 1)) n a.2.1 +
+          SingularMayerVietoris.singularHomologyMap (f.comp (openPartitionInclusion U 2)) n
+            a.2.2) := by
+  rw [openPartitionHomologyEquiv_symm_apply, map_add, map_add,
+    PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+  rfl
+
+private theorem
+    PeriodFamily.Homology.openPartitionHomologyEquiv_map_out {X : Type} [TopologicalSpace X]
+    (U : Fin 3 → TopologicalSpace.Opens X)
+    (hdisj : Pairwise fun i j : Fin 3 => Disjoint (U i : Set X) (U j : Set X))
+    (hcover : (⋃ i, (U i : Set X)) = Set.univ) {Y : Type} [TopologicalSpace Y] (f : C(X, Y))
+    (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    SingularMayerVietoris.singularHomologyMap f n a =
+      SingularMayerVietoris.singularHomologyMap (f.comp (openPartitionInclusion U 0)) n
+          (openPartitionHomologyEquiv U hdisj hcover n a).1 +
+        (SingularMayerVietoris.singularHomologyMap (f.comp (openPartitionInclusion U 1)) n
+            (openPartitionHomologyEquiv U hdisj hcover n a).2.1 +
+          SingularMayerVietoris.singularHomologyMap (f.comp (openPartitionInclusion U 2)) n
+            (openPartitionHomologyEquiv U hdisj hcover n a).2.2) := by
+  have h :=
+    openPartitionHomologyEquiv_map_out_symm U hdisj hcover f n
+      (openPartitionHomologyEquiv U hdisj hcover n a)
+  rwa [LinearEquiv.symm_apply_apply] at h
+
+private def PeriodFamily.Homology.intersectionPieceHomologyEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (i : Fin 3)
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (intersectionPiece D i) n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology RealTorus₄ n :=
+  (PeriodTorusHigherHomology.homeomorphHomologyEquiv (intersectionPieceHomeomorph D i) n).trans
+    (overlapHomologyEquiv D b (intersectionIndex i) n)
+
+private abbrev PeriodFamily.Homology.intersectionPartitionHomologyEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (familyIntersection D) n ≃ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology (intersectionPiece D 0) n ×
+        (SingularMayerVietoris.SingularHomology (intersectionPiece D 1) n ×
+          SingularMayerVietoris.SingularHomology (intersectionPiece D 2) n)) :=
+  openPartitionHomologyEquiv (intersectionPiece D) (intersectionPiece_pairwise_disjoint D)
+    (intersectionPiece_iUnion D) n
+
+private def PeriodFamily.Homology.intersectionHomologyEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (familyIntersection D) n ≃ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+        (SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+          SingularMayerVietoris.SingularHomology RealTorus₄ n)) :=
+  (intersectionPartitionHomologyEquiv D n).trans
+    (((intersectionPieceHomologyEquiv D b 0 n).toAddEquiv.prodCongr
+        ((intersectionPieceHomologyEquiv D b 1 n).toAddEquiv.prodCongr
+          (intersectionPieceHomologyEquiv D b 2 n).toAddEquiv)).toIntLinearEquiv)
+
+@[simp]
+private theorem PeriodFamily.Homology.intersectionHomologyEquiv_apply
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (familyIntersection D) n) :
+    intersectionHomologyEquiv D b n a =
+      (intersectionPieceHomologyEquiv D b 0 n (intersectionPartitionHomologyEquiv D n a).1,
+        (intersectionPieceHomologyEquiv D b 1 n (intersectionPartitionHomologyEquiv D n a).2.1,
+          intersectionPieceHomologyEquiv D b 2 n
+            (intersectionPartitionHomologyEquiv D n a).2.2)) :=
+  rfl
+
+private theorem PeriodFamily.Homology.intersectionHomologyEquiv_inclusion_middle
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (intersectionPiece D 0) n) :
+    intersectionHomologyEquiv D b n
+        (SingularMayerVietoris.singularHomologyMap
+          (openPartitionInclusion (intersectionPiece D) 0) n a) =
+      (intersectionPieceHomologyEquiv D b 0 n a, (0, 0)) := by
+  simp only [intersectionHomologyEquiv_apply, intersectionPartitionHomologyEquiv,
+    openPartitionHomologyEquiv_inclusion_zero, map_zero]
+
+private theorem PeriodFamily.Homology.intersectionHomologyEquiv_inclusion_left
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (intersectionPiece D 1) n) :
+    intersectionHomologyEquiv D b n
+        (SingularMayerVietoris.singularHomologyMap
+          (openPartitionInclusion (intersectionPiece D) 1) n a) =
+      (0, (intersectionPieceHomologyEquiv D b 1 n a, 0)) := by
+  simp only [intersectionHomologyEquiv_apply, intersectionPartitionHomologyEquiv,
+    openPartitionHomologyEquiv_inclusion_one, map_zero]
+
+private theorem PeriodFamily.Homology.intersectionHomologyEquiv_inclusion_right
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (intersectionPiece D 2) n) :
+    intersectionHomologyEquiv D b n
+        (SingularMayerVietoris.singularHomologyMap
+          (openPartitionInclusion (intersectionPiece D) 2) n a) =
+      (0, (0, intersectionPieceHomologyEquiv D b 2 n a)) := by
+  simp only [intersectionHomologyEquiv_apply, intersectionPartitionHomologyEquiv,
+    openPartitionHomologyEquiv_inclusion_two, map_zero]
+
+private theorem PeriodFamily.Homology.upperHomologyEquiv_intersectionPiece
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (i : Fin 3)
+    (n : ℕ) (a : SingularMayerVietoris.SingularHomology (intersectionPiece D i) n) :
+    upperHomologyEquiv D b n
+        (SingularMayerVietoris.singularHomologyMap
+          ((intersectionToUpper D).comp (openPartitionInclusion (intersectionPiece D) i)) n a) =
+      intersectionPieceHomologyEquiv D b i n a := by
+  rw [openPartitionInclusion, intersectionToUpper_comp_piece,
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+  exact upperHomologyEquiv_overlap D b (intersectionIndex i) n _
+
+private theorem PeriodFamily.Homology.lowerHomologyEquiv_intersectionPiece
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (i : Fin 3)
+    (n : ℕ) (a : SingularMayerVietoris.SingularHomology (intersectionPiece D i) n) :
+    lowerHomologyEquiv D b n
+        (SingularMayerVietoris.singularHomologyMap
+          ((intersectionToLower D).comp (openPartitionInclusion (intersectionPiece D) i)) n a) =
+      SingularMayerVietoris.singularHomologyMap
+        (SpecialPeriods.triangleTorusHomeomorph (overlapTransition b (intersectionIndex i)) :
+          C(RealTorus₄, RealTorus₄))
+        n (intersectionPieceHomologyEquiv D b i n a) := by
+  rw [openPartitionInclusion, intersectionToLower_comp_piece,
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+  exact lowerHomologyEquiv_overlap D b (intersectionIndex i) n _
+
+private theorem PeriodFamily.Homology.upperHomologyEquiv_intersection
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (familyIntersection D) n) :
+    upperHomologyEquiv D b n
+        (SingularMayerVietoris.singularHomologyMap (intersectionToUpper D) n a) =
+      (intersectionHomologyEquiv D b n a).1 + (intersectionHomologyEquiv D b n a).2.1 +
+        (intersectionHomologyEquiv D b n a).2.2 := by
+  have h :=
+    congrArg (upperHomologyEquiv D b n)
+      (openPartitionHomologyEquiv_map_out (intersectionPiece D)
+        (intersectionPiece_pairwise_disjoint D) (intersectionPiece_iUnion D)
+        (intersectionToUpper D) n a)
+  simp only [map_add, upperHomologyEquiv_intersectionPiece] at h
+  simpa only [intersectionHomologyEquiv_apply, ← add_assoc] using h
+
+private theorem PeriodFamily.Homology.lowerHomologyEquiv_intersection
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (familyIntersection D) n) :
+    lowerHomologyEquiv D b n
+        (SingularMayerVietoris.singularHomologyMap (intersectionToLower D) n a) =
+      (intersectionHomologyEquiv D b n a).1 +
+          SingularMayerVietoris.singularHomologyMap
+            (SpecialPeriods.triangleTorusHomeomorph (overlapTransition b 0) :
+              C(RealTorus₄, RealTorus₄))
+            n (intersectionHomologyEquiv D b n a).2.1 +
+        SingularMayerVietoris.singularHomologyMap
+          (SpecialPeriods.triangleTorusHomeomorph (overlapTransition b 2) :
+            C(RealTorus₄, RealTorus₄))
+          n (intersectionHomologyEquiv D b n a).2.2 := by
+  have hidentity :
+    SingularMayerVietoris.singularHomologyMap
+        (Homeomorph.refl RealTorus₄ : C(RealTorus₄, RealTorus₄)) n =
+      LinearMap.id := by
+    change SingularMayerVietoris.singularHomologyMap (ContinuousMap.id RealTorus₄) n = _
+    exact PeriodTorusHigherHomology.singularHomologyMap_id RealTorus₄ n
+  have h :=
+    congrArg (lowerHomologyEquiv D b n)
+      (openPartitionHomologyEquiv_map_out (intersectionPiece D)
+        (intersectionPiece_pairwise_disjoint D) (intersectionPiece_iUnion D)
+        (intersectionToLower D) n a)
+  simp only [map_add, lowerHomologyEquiv_intersectionPiece, intersectionIndex_zero,
+    intersectionIndex_one, intersectionIndex_two, overlapTransition_middle,
+    SpecialPeriods.triangleTorusHomeomorph_one, hidentity, LinearMap.id_apply] at h
+  simpa only [intersectionHomologyEquiv_apply, ← add_assoc] using h
+
+private theorem PeriodFamily.Homology.pairHomologyEquiv_leftHomologyMap
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (familyIntersection D) n) :
+    pairHomologyEquiv D b n
+        (SingularMayerVietoris.leftHomologyMap (upperFamily D : Set D.Space) (lowerFamily D) n
+          a) =
+      TrianglePeriodFamilyHomologyAlgebra.overlapMap
+        (SingularMayerVietoris.singularHomologyMap
+          (SpecialPeriods.triangleTorusHomeomorph (overlapTransition b 0) :
+            C(RealTorus₄, RealTorus₄))
+          n)
+        (SingularMayerVietoris.singularHomologyMap
+          (SpecialPeriods.triangleTorusHomeomorph (overlapTransition b 2) :
+            C(RealTorus₄, RealTorus₄))
+          n)
+        (intersectionHomologyEquiv D b n a) := by
+  refine
+    (congrArg (pairHomologyEquiv D b n)
+          (SingularMayerVietoris.leftHomologyMap_apply (upperFamily D : Set D.Space)
+            (lowerFamily D) n a)).trans
+      ?_
+  change
+    (upperHomologyEquiv D b n
+          (SingularMayerVietoris.singularHomologyMap (intersectionToUpper D) n a),
+        lowerHomologyEquiv D b n
+          (-SingularMayerVietoris.singularHomologyMap (intersectionToLower D) n a)) =
+      _
+  rw [map_neg, TrianglePeriodFamilyHomologyAlgebra.overlapMap_apply]
+  apply Prod.ext
+  · exact upperHomologyEquiv_intersection D b n a
+  · exact congrArg Neg.neg (lowerHomologyEquiv_intersection D b n a)
+
+private abbrev PeriodFamily.Homology.slitOverlapMap (b : SlitBaseLift) (n : ℕ) :=
+  TrianglePeriodFamilyHomologyAlgebra.overlapMap (overlapHomologyAction b 0 n)
+    (overlapHomologyAction b 2 n)
+
+private def PeriodFamily.Homology.familyMarkedRight
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ) :
+    (SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+        SingularMayerVietoris.SingularHomology RealTorus₄ n) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology D.Space n :=
+  (familyRightHomologyMap D n).comp (pairHomologyEquiv D b n).symm.toLinearMap
+
+private def PeriodFamily.Homology.familyMarkedConnecting
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology D.Space (n + 1) →ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+        (SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+          SingularMayerVietoris.SingularHomology RealTorus₄ n)) :=
+  (intersectionHomologyEquiv D b n).toLinearMap.comp (familyConnectingHomomorphism D n)
+
+@[simp]
+private theorem PeriodFamily.Homology.familyMarkedRight_apply
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+        SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    familyMarkedRight D b n a = familyRightHomologyMap D n ((pairHomologyEquiv D b n).symm a) :=
+  rfl
+
+@[simp]
+private theorem PeriodFamily.Homology.familyMarkedConnecting_apply
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology D.Space (n + 1)) :
+    familyMarkedConnecting D b n a =
+      intersectionHomologyEquiv D b n (familyConnectingHomomorphism D n a) :=
+  rfl
+
+private theorem PeriodFamily.Homology.slitOverlapMap_intersection
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (familyIntersection D) n) :
+    slitOverlapMap b n (intersectionHomologyEquiv D b n a) =
+      pairHomologyEquiv D b n (familyLeftHomologyMap D n a) :=
+  (pairHomologyEquiv_leftHomologyMap D b n a).symm
+
+private theorem PeriodFamily.Homology.familyMarked_exact_at_pair
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ) :
+    Function.Exact (slitOverlapMap b n) (familyMarkedRight D b n) := by
+  intro x
+  constructor
+  · intro hx
+    obtain ⟨a, ha⟩ := (family_exact_at_pair D n ((pairHomologyEquiv D b n).symm x)).mp hx
+    refine ⟨intersectionHomologyEquiv D b n a, ?_⟩
+    exact
+      (slitOverlapMap_intersection D b n a).trans
+        ((congrArg (pairHomologyEquiv D b n) ha).trans
+          ((pairHomologyEquiv D b n).apply_symm_apply x))
+  · rintro ⟨v, rfl⟩
+    obtain ⟨a, rfl⟩ := (intersectionHomologyEquiv D b n).surjective v
+    rw [familyMarkedRight_apply, slitOverlapMap_intersection, LinearEquiv.symm_apply_apply]
+    exact (family_exact_at_pair D n).apply_apply_eq_zero a
+
+private theorem PeriodFamily.Homology.familyMarked_exact_at_ambient
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ) :
+    Function.Exact (familyMarkedRight D b (n + 1)) (familyMarkedConnecting D b n) := by
+  intro x
+  constructor
+  · intro hx
+    have hzero : familyConnectingHomomorphism D n x = 0 := by
+      apply (intersectionHomologyEquiv D b n).injective
+      exact hx.trans (intersectionHomologyEquiv D b n).map_zero.symm
+    obtain ⟨a, ha⟩ := (family_exact_at_ambient D n x).mp hzero
+    refine ⟨pairHomologyEquiv D b (n + 1) a, ?_⟩
+    rw [familyMarkedRight_apply, LinearEquiv.symm_apply_apply]
+    exact ha
+  · rintro ⟨a, rfl⟩
+    rw [familyMarkedConnecting_apply, familyMarkedRight_apply,
+      (family_exact_at_ambient D n).apply_apply_eq_zero]
+    exact (intersectionHomologyEquiv D b n).map_zero
+
+private theorem PeriodFamily.Homology.familyMarked_exact_at_intersection
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ) :
+    Function.Exact (familyMarkedConnecting D b n) (slitOverlapMap b n) := by
+  intro x
+  constructor
+  · intro hx
+    have hzero : familyLeftHomologyMap D n ((intersectionHomologyEquiv D b n).symm x) = 0 := by
+      apply (pairHomologyEquiv D b n).injective
+      rw [← slitOverlapMap_intersection, LinearEquiv.apply_symm_apply, hx, map_zero]
+    obtain ⟨a, ha⟩ :=
+      (family_exact_at_intersection D n ((intersectionHomologyEquiv D b n).symm x)).mp hzero
+    refine ⟨a, ?_⟩
+    rw [familyMarkedConnecting_apply, ha, LinearEquiv.apply_symm_apply]
+  · rintro ⟨a, rfl⟩
+    exact
+      (slitOverlapMap_intersection D b n (familyConnectingHomomorphism D n a)).trans
+        ((congrArg (pairHomologyEquiv D b n)
+              ((family_exact_at_intersection D n).apply_apply_eq_zero a)).trans
+          (pairHomologyEquiv D b n).map_zero)
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/PeriodFamily/Core5.lean b/LeanPool/HopfProblem/PeriodFamily/Core5.lean
new file mode 100644
index 000000000..8defc8496
--- /dev/null
+++ b/LeanPool/HopfProblem/PeriodFamily/Core5.lean
@@ -0,0 +1,5638 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Toric.DiagonalQuotient4
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology4
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap1
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+import all LeanPool.HopfProblem.Lattice.Core2
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.PeriodFamily.PeriodDomain
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods3
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology7
+import all LeanPool.HopfProblem.PeriodFamily.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods6
+import all LeanPool.HopfProblem.Toric.DiagonalQuotient1
+import all LeanPool.HopfProblem.HomologyOfX.CuspCoinvariants
+import all LeanPool.HopfProblem.PeriodFamily.Core2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods7
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen2
+import all LeanPool.HopfProblem.Elliptic.Core5
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods8
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods9
+import all LeanPool.HopfProblem.PeriodFamily.Core3
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods10
+import all LeanPool.HopfProblem.HomologyOfX.TrianglePeriodFamilyHomologyAlgebra
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology9
+import all LeanPool.HopfProblem.Foundations.TrianglePeriodFamilyHomologySplitting
+import all LeanPool.HopfProblem.PeriodFamily.Core4
+import all LeanPool.HopfProblem.HomologyOfX.TrianglePeriodFamilyHomologyLattice
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods9
+import all LeanPool.HopfProblem.Pi1.TwistGroup
+import all LeanPool.HopfProblem.Toric.DiagonalQuotient4
+
+/-!
+# Hopf problem: period family · core 5
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def PeriodFamily.Homology.slitCoinvariantInclusion
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ) :
+    (SingularMayerVietoris.SingularHomology RealTorus₄ n ⧸
+        LinearMap.range (slitDifference b n)) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology D.Space n :=
+  TrianglePeriodFamilyHomologyAlgebra.reducedCokernelToMiddle (overlapHomologyAction b 0 n)
+    (overlapHomologyAction b 2 n) (familyMarkedRight D b n) (familyMarked_exact_at_pair D b n)
+
+@[simp]
+private theorem PeriodFamily.Homology.slitCoinvariantInclusion_mk
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    slitCoinvariantInclusion D b n (Submodule.Quotient.mk a) = familyMarkedRight D b n (0, -a) :=
+  TrianglePeriodFamilyHomologyAlgebra.reducedCokernelToMiddle_mk (overlapHomologyAction b 0 n)
+    (overlapHomologyAction b 2 n) (familyMarkedRight D b n) (familyMarked_exact_at_pair D b n) a
+
+private theorem PeriodFamily.Homology.slitCoinvariantInclusion_injective
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ) :
+    Function.Injective (slitCoinvariantInclusion D b n) :=
+  TrianglePeriodFamilyHomologyAlgebra.reducedCokernelToMiddle_injective
+    (overlapHomologyAction b 0 n) (overlapHomologyAction b 2 n) (familyMarkedRight D b n)
+    (familyMarked_exact_at_pair D b n)
+
+private def PeriodFamily.Homology.slitKernelProjection
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology D.Space (n + 1) →ₗ[ℤ]
+      LinearMap.ker (slitDifference b n) :=
+  TrianglePeriodFamilyHomologyAlgebra.middleToReducedKernel (overlapHomologyAction b 0 n)
+    (overlapHomologyAction b 2 n) (familyMarkedConnecting D b n)
+    (familyMarked_exact_at_intersection D b n)
+
+private theorem PeriodFamily.Homology.slitKernelProjection_surjective
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ) :
+    Function.Surjective (slitKernelProjection D b n) :=
+  TrianglePeriodFamilyHomologyAlgebra.middleToReducedKernel_surjective
+    (overlapHomologyAction b 0 n) (overlapHomologyAction b 2 n) (familyMarkedConnecting D b n)
+    (familyMarked_exact_at_intersection D b n)
+
+private theorem PeriodFamily.Homology.slitCoinvariantInclusion_kernelProjection_exact
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ) :
+    Function.Exact (slitCoinvariantInclusion D b (n + 1)) (slitKernelProjection D b n) :=
+  TrianglePeriodFamilyHomologyAlgebra.reducedExtension_exact (overlapHomologyAction b 0 (n + 1))
+    (overlapHomologyAction b 2 (n + 1)) (overlapHomologyAction b 0 n)
+    (overlapHomologyAction b 2 n) (familyMarkedRight D b (n + 1)) (familyMarkedConnecting D b n)
+    (familyMarked_exact_at_pair D b (n + 1)) (familyMarked_exact_at_ambient D b n)
+    (familyMarked_exact_at_intersection D b n)
+
+private def PeriodFamily.Homology.familyFibreInclusion
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) :
+    C(RealTorus₄, D.Space) :=
+  ⟨fun f => D.quotient (b.val, f),
+    D.quotient_continuous.comp (continuous_const.prodMk continuous_id)⟩
+
+private def PeriodFamily.Homology.upperFamilyInclusion
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) : C(upperFamily D, D.Space) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private def PeriodFamily.Homology.lowerFamilyInclusion
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) : C(lowerFamily D, D.Space) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private def PeriodFamily.Homology.upperContractionToBasepoint :
+    Path (PeriodTorusHigherHomology.CircleTopology.contractionPoint upperBase) upperBasePoint :=
+  PathConnectedSpace.somePath
+    (PeriodTorusHigherHomology.CircleTopology.contractionPoint upperBase) upperBasePoint
+
+private def PeriodFamily.Homology.lowerContractionToBasepoint :
+    Path (PeriodTorusHigherHomology.CircleTopology.contractionPoint lowerBase) lowerBasePoint :=
+  PathConnectedSpace.somePath
+    (PeriodTorusHigherHomology.CircleTopology.contractionPoint lowerBase) lowerBasePoint
+
+private def PeriodFamily.Homology.upperFamilyFibreHomotopy
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) :
+    ((upperFamilyInclusion D).comp (upperHomotopyEquiv D b).invFun).Homotopy
+      (familyFibreInclusion D b)
+    where
+  toFun x := D.quotient (upperLift b (upperContractionToBasepoint x.1), x.2)
+  continuous_toFun :=
+    D.quotient_continuous.comp
+      (((upperLift b).continuous.comp
+            (upperContractionToBasepoint.continuous.comp continuous_fst)).prodMk
+        continuous_snd)
+  map_zero_left
+    f := by
+    change
+      D.quotient (upperLift b (upperContractionToBasepoint 0), f) =
+        D.quotient
+          (upperLift b (PeriodTorusHigherHomology.CircleTopology.contractionPoint upperBase), f)
+    rw [upperContractionToBasepoint.source]
+  map_one_left
+    f := by
+    change D.quotient (upperLift b (upperContractionToBasepoint 1), f) = D.quotient (b.val, f)
+    rw [upperContractionToBasepoint.target, upperLift_basepoint]
+
+private def PeriodFamily.Homology.lowerFamilyFibreHomotopy
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) :
+    ((lowerFamilyInclusion D).comp (lowerHomotopyEquiv D b).invFun).Homotopy
+      (familyFibreInclusion D b)
+    where
+  toFun x := D.quotient (lowerLift b (lowerContractionToBasepoint x.1), x.2)
+  continuous_toFun :=
+    D.quotient_continuous.comp
+      (((lowerLift b).continuous.comp
+            (lowerContractionToBasepoint.continuous.comp continuous_fst)).prodMk
+        continuous_snd)
+  map_zero_left
+    f := by
+    change
+      D.quotient (lowerLift b (lowerContractionToBasepoint 0), f) =
+        D.quotient
+          (lowerLift b (PeriodTorusHigherHomology.CircleTopology.contractionPoint lowerBase), f)
+    rw [lowerContractionToBasepoint.source]
+  map_one_left
+    f := by
+    change D.quotient (lowerLift b (lowerContractionToBasepoint 1), f) = D.quotient (b.val, f)
+    rw [lowerContractionToBasepoint.target, lowerLift_basepoint]
+
+private theorem PeriodFamily.Homology.upperFamilyInclusion_homology_symm
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    SingularMayerVietoris.singularHomologyMap (upperFamilyInclusion D) n
+        ((upperHomologyEquiv D b n).symm a) =
+      SingularMayerVietoris.singularHomologyMap (familyFibreInclusion D b) n a := by
+  change
+    SingularMayerVietoris.singularHomologyMap (upperFamilyInclusion D) n
+        (SingularMayerVietoris.singularHomologyMap (upperHomotopyEquiv D b).invFun n a) =
+      _
+  exact
+    LinearMap.congr_fun
+      ((PeriodTorusHigherHomology.singularHomologyMap_comp (upperHomotopyEquiv D b).invFun
+            (upperFamilyInclusion D) n).symm.trans
+        (PeriodTorusHigherHomology.homotopy_homologyMap (upperFamilyFibreHomotopy D b) n))
+      a
+
+private theorem PeriodFamily.Homology.lowerFamilyInclusion_homology_symm
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    SingularMayerVietoris.singularHomologyMap (lowerFamilyInclusion D) n
+        ((lowerHomologyEquiv D b n).symm a) =
+      SingularMayerVietoris.singularHomologyMap (familyFibreInclusion D b) n a := by
+  change
+    SingularMayerVietoris.singularHomologyMap (lowerFamilyInclusion D) n
+        (SingularMayerVietoris.singularHomologyMap (lowerHomotopyEquiv D b).invFun n a) =
+      _
+  exact
+    LinearMap.congr_fun
+      ((PeriodTorusHigherHomology.singularHomologyMap_comp (lowerHomotopyEquiv D b).invFun
+            (lowerFamilyInclusion D) n).symm.trans
+        (PeriodTorusHigherHomology.homotopy_homologyMap (lowerFamilyFibreHomotopy D b) n))
+      a
+
+private theorem PeriodFamily.Homology.familyRightHomologyMap_pair_symm
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+        SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    familyRightHomologyMap D n ((pairHomologyEquiv D b n).symm a) =
+      SingularMayerVietoris.singularHomologyMap (familyFibreInclusion D b) n (a.1 + a.2) := by
+  refine
+    (SingularMayerVietoris.rightHomologyMap_apply (upperFamily D : Set D.Space) (lowerFamily D) n
+          ((pairHomologyEquiv D b n).symm a)).trans
+      ?_
+  change
+    SingularMayerVietoris.singularHomologyMap (upperFamilyInclusion D) n
+          ((upperHomologyEquiv D b n).symm a.1) +
+        SingularMayerVietoris.singularHomologyMap (lowerFamilyInclusion D) n
+          ((lowerHomologyEquiv D b n).symm a.2) =
+      _
+  rw [upperFamilyInclusion_homology_symm, lowerFamilyInclusion_homology_symm, map_add]
+
+private theorem PeriodFamily.Homology.familyRightHomologyMap_pair
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology (upperFamily D) n ×
+        SingularMayerVietoris.SingularHomology (lowerFamily D) n) :
+    familyRightHomologyMap D n a =
+      SingularMayerVietoris.singularHomologyMap (familyFibreInclusion D b) n
+        ((pairHomologyEquiv D b n a).1 + (pairHomologyEquiv D b n a).2) := by
+  simpa only [LinearEquiv.symm_apply_apply] using
+    familyRightHomologyMap_pair_symm D b n (pairHomologyEquiv D b n a)
+
+private theorem PeriodFamily.Homology.familyRightHomologyMap_range_eq_fibre
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ) :
+    LinearMap.range (familyRightHomologyMap D n) =
+      LinearMap.range (SingularMayerVietoris.singularHomologyMap (familyFibreInclusion D b) n) := by
+  apply le_antisymm
+  · rintro y ⟨a, rfl⟩
+    refine ⟨(pairHomologyEquiv D b n a).1 + (pairHomologyEquiv D b n a).2, ?_⟩
+    exact (familyRightHomologyMap_pair D b n a).symm
+  · rintro y ⟨a, rfl⟩
+    refine ⟨(pairHomologyEquiv D b n).symm (a, 0), ?_⟩
+    simpa only [add_zero] using familyRightHomologyMap_pair_symm D b n (a, 0)
+
+private theorem PeriodFamily.Homology.familyConnectingHomomorphism_ker_eq_fibre
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ) :
+    LinearMap.ker (familyConnectingHomomorphism D n) =
+      LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap (familyFibreInclusion D b) (n + 1)) :=
+  (LinearMap.exact_iff.mp (family_exact_at_ambient D n)).trans
+    (familyRightHomologyMap_range_eq_fibre D b (n + 1))
+
+@[simp]
+private theorem PeriodFamily.Homology.normalizedSlitCokernelEquiv_symm_mk (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    (normalizedSlitCokernelEquiv n).symm (Submodule.Quotient.mk a) = Submodule.Quotient.mk a := by
+  apply (normalizedSlitCokernelEquiv n).injective
+  rw [LinearEquiv.apply_symm_apply, normalizedSlitCokernelEquiv_mk]
+
+private theorem PeriodFamily.Homology.familyMarkedRight_eq_fibre
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+        SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    familyMarkedRight D b n a =
+      SingularMayerVietoris.singularHomologyMap (familyFibreInclusion D b) n (a.1 + a.2) :=
+  familyRightHomologyMap_pair_symm D b n a
+
+private def PeriodFamily.Homology.sourceCoinvariantInclusion
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    (SingularMayerVietoris.SingularHomology RealTorus₄ n ⧸
+        LinearMap.range (sourceDifference n)) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology D.Space n :=
+  -((slitCoinvariantInclusion D normalizedSlitBaseLift n).comp
+      (normalizedSlitCokernelEquiv n).symm.toLinearMap)
+
+@[simp]
+private theorem PeriodFamily.Homology.sourceCoinvariantInclusion_apply
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology RealTorus₄ n ⧸
+        LinearMap.range (sourceDifference n)) :
+    sourceCoinvariantInclusion D n a =
+      -slitCoinvariantInclusion D normalizedSlitBaseLift n
+          ((normalizedSlitCokernelEquiv n).symm a) :=
+  rfl
+
+private theorem PeriodFamily.Homology.sourceCoinvariantInclusion_mk
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    sourceCoinvariantInclusion D n (Submodule.Quotient.mk a) =
+      SingularMayerVietoris.singularHomologyMap (familyFibreInclusion D normalizedSlitBaseLift) n
+        a := by
+  rw [sourceCoinvariantInclusion_apply, normalizedSlitCokernelEquiv_symm_mk,
+    slitCoinvariantInclusion_mk, familyMarkedRight_eq_fibre]
+  simp only [zero_add, map_neg, neg_neg]
+
+private theorem PeriodFamily.Homology.sourceCoinvariantInclusion_injective
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    Function.Injective (sourceCoinvariantInclusion D n) := by
+  intro a b hab
+  have hneg :
+    -slitCoinvariantInclusion D normalizedSlitBaseLift n
+          ((normalizedSlitCokernelEquiv n).symm a) =
+      -slitCoinvariantInclusion D normalizedSlitBaseLift n
+          ((normalizedSlitCokernelEquiv n).symm b) :=
+    hab
+  exact
+    (normalizedSlitCokernelEquiv n).symm.injective
+      (slitCoinvariantInclusion_injective D normalizedSlitBaseLift n (neg_injective hneg))
+
+private def PeriodFamily.Homology.sourceKernelProjection
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology D.Space (n + 1) →ₗ[ℤ]
+      LinearMap.ker (sourceDifference n) :=
+  (normalizedSlitKernelEquiv n).toLinearMap.comp (slitKernelProjection D normalizedSlitBaseLift n)
+
+@[simp]
+private theorem PeriodFamily.Homology.sourceKernelProjection_apply
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology D.Space (n + 1)) :
+    sourceKernelProjection D n a =
+      normalizedSlitKernelEquiv n (slitKernelProjection D normalizedSlitBaseLift n a) :=
+  rfl
+
+private theorem PeriodFamily.Homology.sourceKernelProjection_surjective
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    Function.Surjective (sourceKernelProjection D n) :=
+  (normalizedSlitKernelEquiv n).surjective.comp
+    (slitKernelProjection_surjective D normalizedSlitBaseLift n)
+
+private theorem PeriodFamily.Homology.sourceCoinvariantInclusion_kernelProjection_exact
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    Function.Exact (sourceCoinvariantInclusion D (n + 1)) (sourceKernelProjection D n) := by
+  intro a
+  constructor
+  · intro ha
+    have hzero : slitKernelProjection D normalizedSlitBaseLift n a = 0 := by
+      apply (normalizedSlitKernelEquiv n).injective
+      exact ha.trans (normalizedSlitKernelEquiv n).map_zero.symm
+    obtain ⟨q, hq⟩ :=
+      (slitCoinvariantInclusion_kernelProjection_exact D normalizedSlitBaseLift n a).mp hzero
+    refine ⟨-normalizedSlitCokernelEquiv (n + 1) q, ?_⟩
+    rw [sourceCoinvariantInclusion_apply, map_neg, LinearEquiv.symm_apply_apply, map_neg, neg_neg]
+    exact hq
+  · rintro ⟨q, rfl⟩
+    have hex := slitCoinvariantInclusion_kernelProjection_exact D normalizedSlitBaseLift n
+    rw [sourceKernelProjection_apply, sourceCoinvariantInclusion_apply, map_neg,
+      hex.apply_apply_eq_zero, neg_zero, map_zero]
+
+private theorem PeriodFamily.Homology.familyFibreInclusion_kernel
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    LinearMap.ker
+        (SingularMayerVietoris.singularHomologyMap (familyFibreInclusion D normalizedSlitBaseLift)
+          n) =
+      LinearMap.range (sourceDifference n) := by
+  ext a
+  change
+    SingularMayerVietoris.singularHomologyMap (familyFibreInclusion D normalizedSlitBaseLift) n
+          a =
+        0 ↔
+      _
+  rw [← sourceCoinvariantInclusion_mk]
+  constructor
+  · intro ha
+    have hq :
+      (Submodule.Quotient.mk a :
+          SingularMayerVietoris.SingularHomology RealTorus₄ n ⧸
+            LinearMap.range (sourceDifference n)) =
+        0 :=
+      sourceCoinvariantInclusion_injective D n (ha.trans (map_zero _).symm)
+    exact
+      (Submodule.Quotient.mk_eq_zero (p := LinearMap.range (sourceDifference n)) (x := a)).mp hq
+  · intro ha
+    rw [(Submodule.Quotient.mk_eq_zero (p := LinearMap.range (sourceDifference n)) (x := a)).mpr
+        ha,
+      map_zero]
+
+private theorem PeriodFamily.Homology.sourceCoinvariantInclusion_range
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    LinearMap.range (sourceCoinvariantInclusion D n) =
+      LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap (familyFibreInclusion D normalizedSlitBaseLift)
+          n) := by
+  apply le_antisymm
+  · rintro a ⟨q, rfl⟩
+    obtain ⟨x, rfl⟩ := Submodule.Quotient.mk_surjective _ q
+    exact ⟨x, (sourceCoinvariantInclusion_mk D n x).symm⟩
+  · rintro a ⟨x, rfl⟩
+    exact ⟨Submodule.Quotient.mk x, sourceCoinvariantInclusion_mk D n x⟩
+
+private theorem PeriodFamily.Homology.sourceKernelProjection_kernel
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    LinearMap.ker (sourceKernelProjection D n) =
+      LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap (familyFibreInclusion D normalizedSlitBaseLift)
+          (n + 1)) :=
+  (LinearMap.exact_iff.mp (sourceCoinvariantInclusion_kernelProjection_exact D n)).trans
+    (sourceCoinvariantInclusion_range D (n + 1))
+
+private def PeriodFamily.Homology.familyHomologySplitEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ)
+    [Module.Free ℤ (LinearMap.ker (sourceDifference n))] :
+    SingularMayerVietoris.SingularHomology D.Space (n + 1) ≃ₗ[ℤ]
+      ((SingularMayerVietoris.SingularHomology RealTorus₄ (n + 1) ⧸
+          LinearMap.range (sourceDifference (n + 1))) ×
+        LinearMap.ker (sourceDifference n)) :=
+  TrianglePeriodFamilyHomologySplitting.freeRightSplitEquiv (sourceCoinvariantInclusion D (n + 1))
+    (sourceKernelProjection D n) (sourceCoinvariantInclusion_kernelProjection_exact D n)
+    (sourceCoinvariantInclusion_injective D (n + 1)) (sourceKernelProjection_surjective D n)
+
+private def PeriodFamily.Homology.familyHomologyMarkedEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) {L K : Type*}
+    [AddCommGroup L] [AddCommGroup K] [Module ℤ K]
+    (ec :
+      (SingularMayerVietoris.SingularHomology RealTorus₄ (n + 1) ⧸
+          LinearMap.range (sourceDifference (n + 1))) ≃+
+        L)
+    (ek : LinearMap.ker (sourceDifference n) ≃+ K) [Module.Free ℤ K] :
+    SingularMayerVietoris.SingularHomology D.Space (n + 1) ≃ₗ[ℤ] (L × K) := by
+  letI := Module.Free.of_equiv ek.toIntLinearEquiv.symm
+  exact ((familyHomologySplitEquiv D n).toAddEquiv.trans (ec.prodCongr ek)).toIntLinearEquiv
+
+private theorem PeriodFamily.FlatTorus.flatTorusCircleHomeomorph_triangle
+    (g : SpecialPeriods.TriangleGroup) (x : RealTorus₄) :
+    PeriodTorusHigherHomology.flatTorusCircleHomeomorph
+        (SpecialPeriods.triangleTorusHomeomorph g x) =
+      PeriodTorusHigherHomology.torusMatrixMap
+        (SpecialPeriods.triangleDualRepresentation g : LatticeMatrix)
+        (PeriodTorusHigherHomology.flatTorusCircleHomeomorph x) := by
+  obtain ⟨v, rfl⟩ := standardLattice.mkQ_surjective x
+  simp only [SpecialPeriods.triangleTorusHomeomorph_mkQ,
+    PeriodTorusHigherHomology.flatTorusCircleHomeomorph_mkQ,
+    PeriodTorusHigherHomology.torusMatrixMap_coordinateProjection,
+    SpecialPeriods.triangleRealEquiv_apply]
+
+private theorem PeriodFamily.FlatTorus.flatTorusCircleHomeomorph_triangle_comp
+    (g : SpecialPeriods.TriangleGroup) :
+    (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+            C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4)).comp
+        (SpecialPeriods.triangleTorusHomeomorph g : C(RealTorus₄, RealTorus₄)) =
+      (PeriodTorusHigherHomology.torusMatrixMap
+            (SpecialPeriods.triangleDualRepresentation g : LatticeMatrix)).comp
+        (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+          C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4)) := by
+  apply ContinuousMap.ext
+  intro x
+  exact flatTorusCircleHomeomorph_triangle g x
+
+@[simp]
+private theorem PeriodFamily.FlatTorus.flatTorusCircleHomeomorph_zero :
+    PeriodTorusHigherHomology.flatTorusCircleHomeomorph (0 : RealTorus₄) = 0 :=
+  PeriodTorusHigherHomology.flatTorusCircleMap.map_zero
+
+private theorem PeriodFamily.FlatTorus.flatTorusCircleHomeomorph_periodLoop_apply (c : Lattice)
+    (t : unitInterval) :
+    PeriodTorusHigherHomology.flatTorusCircleHomeomorph (periodLoop c t) =
+      PeriodTorusHigherHomology.coordinatePeriodLoop 4 c t := by
+  rw [periodLoop_apply, PeriodTorusHigherHomology.flatTorusCircleHomeomorph_mkQ]
+  ext i
+  rw [PeriodTorusHigherHomology.coordinatePeriodLoop_apply]
+  rfl
+
+private theorem PeriodFamily.FlatTorus.flatTorusCircleHomeomorph_periodLoop (c : Lattice) :
+    (periodLoop c).map PeriodTorusHigherHomology.flatTorusCircleHomeomorph.continuous =
+      (PeriodTorusHigherHomology.coordinatePeriodLoop 4 c).cast flatTorusCircleHomeomorph_zero
+        flatTorusCircleHomeomorph_zero := by
+  apply Path.ext
+  funext t
+  exact flatTorusCircleHomeomorph_periodLoop_apply c t
+
+private theorem PeriodFamily.FlatTorus.inducedHomology_periodLoop_circle (c : Lattice) :
+    FirstHurewicz.inducedHomology
+        (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+          C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+        (FirstHurewicz.loopHomologyClass (periodLoop c)) =
+      FirstHurewicz.loopHomologyClass (PeriodTorusHigherHomology.coordinatePeriodLoop 4 c) := by
+  rw [FirstHurewicz.inducedHomology_loopHomologyClass, flatTorusCircleHomeomorph_periodLoop]
+  rfl
+
+private theorem PeriodFamily.FlatTorus.inducedHomology_singularH1Equiv_symm_circle (c : Lattice) :
+    FirstHurewicz.inducedHomology
+        (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+          C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+        (singularH1Equiv.symm c) =
+      FirstHurewicz.loopHomologyClass (PeriodTorusHigherHomology.coordinatePeriodLoop 4 c) := by
+  rw [singularH1Equiv_symm_apply, inducedHomology_periodLoop_circle]
+
+private theorem PeriodFamily.FlatTorus.coordinateH1_eq_flatMarking :
+    PeriodTorusHigherHomology.coordinateH1 4 =
+      (FirstHurewicz.inducedHomology
+            (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+              C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))).comp
+        singularH1Equiv.symm.toLinearMap := by
+  apply (Pi.basisFun ℤ (Fin 4)).ext
+  intro i
+  change
+    PeriodTorusHigherHomology.coordinateH1 4 (Pi.basisFun ℤ (Fin 4) i) =
+      FirstHurewicz.inducedHomology
+        (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+          C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+        (singularH1Equiv.symm (Pi.basisFun ℤ (Fin 4) i))
+  rw [PeriodTorusHigherHomology.coordinateH1_basis, inducedHomology_singularH1Equiv_symm_circle]
+  simp only [Pi.basisFun_apply]
+
+private theorem PeriodFamily.FlatTorus.coordinateH1_flatMarking (c : Lattice) :
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+          C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+        1 (singularH1Equiv.symm c) =
+      PeriodTorusHigherHomology.coordinateH1 4 c :=
+  (LinearMap.congr_fun coordinateH1_eq_flatMarking c).symm
+
+private def PeriodFamily.FlatTorus.singularH2Equiv :
+    SingularMayerVietoris.SingularHomology RealTorus₄ 2 ≃ₗ[ℤ]
+      PeriodTorusHigherHomologyExterior.latticeExterior 2 :=
+  (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+        PeriodTorusHigherHomology.flatTorusCircleHomeomorph 2).trans
+    PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv
+
+private def PeriodFamily.FlatTorus.singularH3Equiv :
+    SingularMayerVietoris.SingularHomology RealTorus₄ 3 ≃ₗ[ℤ]
+      PeriodTorusHigherHomologyExterior.latticeExterior 3 :=
+  (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+        PeriodTorusHigherHomology.flatTorusCircleHomeomorph 3).trans
+    PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv
+
+@[simp]
+private theorem PeriodFamily.FlatTorus.singularH2Equiv_apply
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 2) :
+    singularH2Equiv a =
+      PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+            C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+          2 a) :=
+  rfl
+
+@[simp]
+private theorem PeriodFamily.FlatTorus.singularH3Equiv_apply
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 3) :
+    singularH3Equiv a =
+      PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+            C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+          3 a) :=
+  rfl
+
+private def PeriodFamily.FlatTorus.singularH2Coordinates :
+    SingularMayerVietoris.SingularHomology RealTorus₄ 2 ≃ₗ[ℤ] (Fin 6 → ℤ) :=
+  singularH2Equiv.trans PeriodTorusHigherHomologyExterior.squareCoordinates
+
+private def PeriodFamily.FlatTorus.singularH3Coordinates :
+    SingularMayerVietoris.SingularHomology RealTorus₄ 3 ≃ₗ[ℤ] (Fin 4 → ℤ) :=
+  singularH3Equiv.trans PeriodTorusHigherHomologyExterior.cubeCoordinates
+
+@[simp]
+private theorem PeriodFamily.FlatTorus.singularH2Coordinates_apply
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 2) :
+    singularH2Coordinates a =
+      PeriodTorusHigherHomologyExterior.squareCoordinates (singularH2Equiv a) :=
+  rfl
+
+@[simp]
+private theorem PeriodFamily.FlatTorus.singularH3Coordinates_apply
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 3) :
+    singularH3Coordinates a =
+      PeriodTorusHigherHomologyExterior.cubeCoordinates (singularH3Equiv a) :=
+  rfl
+
+private theorem
+    PeriodFamily.FlatTorus.flatTorusCircleHomology_triangle (g : SpecialPeriods.TriangleGroup)
+    (n : ℕ) :
+    (SingularMayerVietoris.singularHomologyMap
+            (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+              C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+            n).comp
+        (SingularMayerVietoris.singularHomologyMap
+          (SpecialPeriods.triangleTorusHomeomorph g : C(RealTorus₄, RealTorus₄)) n) =
+      (SingularMayerVietoris.singularHomologyMap
+            (PeriodTorusHigherHomology.torusMatrixMap
+              (SpecialPeriods.triangleDualRepresentation g : LatticeMatrix))
+            n).comp
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+            C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+          n) := by
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp, flatTorusCircleHomeomorph_triangle_comp]
+
+private theorem PeriodFamily.FlatTorus.flatTorusCircleHomology_triangle_apply
+    (g : SpecialPeriods.TriangleGroup) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+          C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+        n
+        (SingularMayerVietoris.singularHomologyMap
+          (SpecialPeriods.triangleTorusHomeomorph g : C(RealTorus₄, RealTorus₄)) n a) =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.torusMatrixMap
+          (SpecialPeriods.triangleDualRepresentation g : LatticeMatrix))
+        n
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+            C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+          n a) :=
+  LinearMap.congr_fun (flatTorusCircleHomology_triangle g n) a
+
+private theorem PeriodFamily.FlatTorus.singularH2Equiv_inducedHomology_triangle
+    (g : SpecialPeriods.TriangleGroup) (a : SingularMayerVietoris.SingularHomology RealTorus₄ 2) :
+    singularH2Equiv
+        (SingularMayerVietoris.singularHomologyMap
+          (SpecialPeriods.triangleTorusHomeomorph g : C(RealTorus₄, RealTorus₄)) 2 a) =
+      exteriorPower.map 2 (SpecialPeriods.triangleDualRepresentation g : LatticeMatrix).mulVecLin
+        (singularH2Equiv a) := by
+  change
+    PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+            C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+          2
+          (SingularMayerVietoris.singularHomologyMap
+            (SpecialPeriods.triangleTorusHomeomorph g : C(RealTorus₄, RealTorus₄)) 2 a)) =
+      exteriorPower.map 2 (SpecialPeriods.triangleDualRepresentation g : LatticeMatrix).mulVecLin
+        (PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv
+          (SingularMayerVietoris.singularHomologyMap
+            (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+              C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+            2 a))
+  rw [flatTorusCircleHomology_triangle_apply,
+    PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv_matrix]
+
+private theorem PeriodFamily.FlatTorus.singularH3Equiv_inducedHomology_triangle
+    (g : SpecialPeriods.TriangleGroup) (a : SingularMayerVietoris.SingularHomology RealTorus₄ 3) :
+    singularH3Equiv
+        (SingularMayerVietoris.singularHomologyMap
+          (SpecialPeriods.triangleTorusHomeomorph g : C(RealTorus₄, RealTorus₄)) 3 a) =
+      exteriorPower.map 3 (SpecialPeriods.triangleDualRepresentation g : LatticeMatrix).mulVecLin
+        (singularH3Equiv a) := by
+  change
+    PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+            C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+          3
+          (SingularMayerVietoris.singularHomologyMap
+            (SpecialPeriods.triangleTorusHomeomorph g : C(RealTorus₄, RealTorus₄)) 3 a)) =
+      exteriorPower.map 3 (SpecialPeriods.triangleDualRepresentation g : LatticeMatrix).mulVecLin
+        (PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv
+          (SingularMayerVietoris.singularHomologyMap
+            (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+              C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+            3 a))
+  rw [flatTorusCircleHomology_triangle_apply,
+    PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv_matrix]
+
+private theorem PeriodFamily.FlatTorus.singularH2Coordinates_inducedHomology_triangle
+    (g : SpecialPeriods.TriangleGroup) (a : SingularMayerVietoris.SingularHomology RealTorus₄ 2) :
+    singularH2Coordinates
+        (SingularMayerVietoris.singularHomologyMap
+          (SpecialPeriods.triangleTorusHomeomorph g : C(RealTorus₄, RealTorus₄)) 2 a) =
+      LocalSystemMatrices.exteriorSquare
+          (SpecialPeriods.triangleDualRepresentation g : LatticeMatrix) *ᵥ
+        singularH2Coordinates a := by
+  rw [singularH2Coordinates_apply, singularH2Equiv_inducedHomology_triangle]
+  exact
+    PeriodTorusHigherHomologyExterior.squareCoordinates_map
+      (SpecialPeriods.triangleDualRepresentation g : LatticeMatrix) (singularH2Equiv a)
+
+private theorem PeriodFamily.FlatTorus.singularH3Coordinates_inducedHomology_triangle
+    (g : SpecialPeriods.TriangleGroup) (a : SingularMayerVietoris.SingularHomology RealTorus₄ 3) :
+    singularH3Coordinates
+        (SingularMayerVietoris.singularHomologyMap
+          (SpecialPeriods.triangleTorusHomeomorph g : C(RealTorus₄, RealTorus₄)) 3 a) =
+      LocalSystemMatrices.exteriorCube
+          (SpecialPeriods.triangleDualRepresentation g : LatticeMatrix) *ᵥ
+        singularH3Coordinates a := by
+  rw [singularH3Coordinates_apply, singularH3Equiv_inducedHomology_triangle]
+  exact
+    PeriodTorusHigherHomologyExterior.cubeCoordinates_map
+      (SpecialPeriods.triangleDualRepresentation g : LatticeMatrix) (singularH3Equiv a)
+
+private theorem PeriodFamily.HomologyDifference.generatorHomologyTwo_coordinates (j : Bool)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 2) :
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        (PeriodFamily.Homology.generatorHomologyEquiv j 2 a) =
+      (if j then PeriodTorusHigherHomologyExterior.squareA₂
+        else PeriodTorusHigherHomologyExterior.squareA₁) *ᵥ
+        PeriodFamily.FlatTorus.singularH2Coordinates a := by
+  cases j
+  · change
+      PeriodFamily.FlatTorus.singularH2Coordinates
+          (SingularMayerVietoris.singularHomologyMap
+            (SpecialPeriods.triangleTorusHomeomorph SpecialPeriods.triangleGenerator₁ :
+              C(RealTorus₄, RealTorus₄))
+            2 a) =
+        _
+    rw [PeriodFamily.FlatTorus.singularH2Coordinates_inducedHomology_triangle,
+      SpecialPeriods.triangleDualRepresentation_generator₁_matrix]
+    rfl
+  · change
+      PeriodFamily.FlatTorus.singularH2Coordinates
+          (SingularMayerVietoris.singularHomologyMap
+            (SpecialPeriods.triangleTorusHomeomorph SpecialPeriods.triangleGenerator₂ :
+              C(RealTorus₄, RealTorus₄))
+            2 a) =
+        _
+    rw [PeriodFamily.FlatTorus.singularH2Coordinates_inducedHomology_triangle,
+      SpecialPeriods.triangleDualRepresentation_generator₂_matrix]
+    rfl
+
+private theorem PeriodFamily.HomologyDifference.sourceDifferenceTwo_coordinates
+    (x :
+      SingularMayerVietoris.SingularHomology RealTorus₄ 2 ×
+        SingularMayerVietoris.SingularHomology RealTorus₄ 2) :
+    PeriodFamily.FlatTorus.singularH2Coordinates (PeriodFamily.Homology.sourceDifference 2 x) =
+      TrianglePeriodFamilyHomologyLattice.deltaTwo
+        (PeriodFamily.FlatTorus.singularH2Coordinates x.1,
+          PeriodFamily.FlatTorus.singularH2Coordinates x.2) := by
+  change
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        ((PeriodFamily.Homology.generatorHomologyEquiv Bool.false 2 x.1 - x.1) +
+          (PeriodFamily.Homology.generatorHomologyEquiv Bool.true 2 x.2 - x.2)) =
+      (PeriodTorusHigherHomologyExterior.squareA₁ *ᵥ
+            PeriodFamily.FlatTorus.singularH2Coordinates x.1 -
+          PeriodFamily.FlatTorus.singularH2Coordinates x.1) +
+        (PeriodTorusHigherHomologyExterior.squareA₂ *ᵥ
+            PeriodFamily.FlatTorus.singularH2Coordinates x.2 -
+          PeriodFamily.FlatTorus.singularH2Coordinates x.2)
+  rw [map_add, map_sub, map_sub, generatorHomologyTwo_coordinates,
+    generatorHomologyTwo_coordinates]
+  rfl
+
+private theorem PeriodFamily.HomologyDifference.generatorHomologyThree_coordinates (j : Bool)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 3) :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (PeriodFamily.Homology.generatorHomologyEquiv j 3 a) =
+      (if j then PeriodTorusHigherHomologyExterior.cubeA₂
+        else PeriodTorusHigherHomologyExterior.cubeA₁) *ᵥ
+        PeriodFamily.FlatTorus.singularH3Coordinates a := by
+  cases j
+  · change
+      PeriodFamily.FlatTorus.singularH3Coordinates
+          (SingularMayerVietoris.singularHomologyMap
+            (SpecialPeriods.triangleTorusHomeomorph SpecialPeriods.triangleGenerator₁ :
+              C(RealTorus₄, RealTorus₄))
+            3 a) =
+        _
+    rw [PeriodFamily.FlatTorus.singularH3Coordinates_inducedHomology_triangle,
+      SpecialPeriods.triangleDualRepresentation_generator₁_matrix]
+    rfl
+  · change
+      PeriodFamily.FlatTorus.singularH3Coordinates
+          (SingularMayerVietoris.singularHomologyMap
+            (SpecialPeriods.triangleTorusHomeomorph SpecialPeriods.triangleGenerator₂ :
+              C(RealTorus₄, RealTorus₄))
+            3 a) =
+        _
+    rw [PeriodFamily.FlatTorus.singularH3Coordinates_inducedHomology_triangle,
+      SpecialPeriods.triangleDualRepresentation_generator₂_matrix]
+    rfl
+
+private theorem PeriodFamily.HomologyDifference.sourceDifferenceThree_coordinates
+    (x :
+      SingularMayerVietoris.SingularHomology RealTorus₄ 3 ×
+        SingularMayerVietoris.SingularHomology RealTorus₄ 3) :
+    PeriodFamily.FlatTorus.singularH3Coordinates (PeriodFamily.Homology.sourceDifference 3 x) =
+      TrianglePeriodFamilyHomologyLattice.deltaThree
+        (PeriodFamily.FlatTorus.singularH3Coordinates x.1,
+          PeriodFamily.FlatTorus.singularH3Coordinates x.2) := by
+  change
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        ((PeriodFamily.Homology.generatorHomologyEquiv Bool.false 3 x.1 - x.1) +
+          (PeriodFamily.Homology.generatorHomologyEquiv Bool.true 3 x.2 - x.2)) =
+      (PeriodTorusHigherHomologyExterior.cubeA₁ *ᵥ
+            PeriodFamily.FlatTorus.singularH3Coordinates x.1 -
+          PeriodFamily.FlatTorus.singularH3Coordinates x.1) +
+        (PeriodTorusHigherHomologyExterior.cubeA₂ *ᵥ
+            PeriodFamily.FlatTorus.singularH3Coordinates x.2 -
+          PeriodFamily.FlatTorus.singularH3Coordinates x.2)
+  rw [map_add, map_sub, map_sub, generatorHomologyThree_coordinates,
+    generatorHomologyThree_coordinates]
+  rfl
+
+private theorem PeriodFamily.HomologyDifference.generatorHomologyOne_false_coordinates
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 1) :
+    PeriodFamily.FlatTorus.singularH1Equiv
+        (PeriodFamily.Homology.generatorHomologyEquiv Bool.false 1 a) =
+      A₁ *ᵥ PeriodFamily.FlatTorus.singularH1Equiv a := by
+  change
+    PeriodFamily.FlatTorus.singularH1Equiv
+        (FirstHurewicz.inducedHomology
+          (SpecialPeriods.triangleTorusHomeomorph SpecialPeriods.triangleGenerator₁ :
+            C(RealTorus₄, RealTorus₄))
+          a) =
+      _
+  rw [PeriodFamily.FlatTorus.singularH1Equiv_inducedHomology_triangle,
+    SpecialPeriods.triangleDualRepresentation_generator₁_matrix]
+
+private theorem PeriodFamily.HomologyDifference.generatorHomologyOne_true_coordinates
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 1) :
+    PeriodFamily.FlatTorus.singularH1Equiv
+        (PeriodFamily.Homology.generatorHomologyEquiv Bool.true 1 a) =
+      A₂ *ᵥ PeriodFamily.FlatTorus.singularH1Equiv a := by
+  change
+    PeriodFamily.FlatTorus.singularH1Equiv
+        (FirstHurewicz.inducedHomology
+          (SpecialPeriods.triangleTorusHomeomorph SpecialPeriods.triangleGenerator₂ :
+            C(RealTorus₄, RealTorus₄))
+          a) =
+      _
+  rw [PeriodFamily.FlatTorus.singularH1Equiv_inducedHomology_triangle,
+    SpecialPeriods.triangleDualRepresentation_generator₂_matrix]
+
+private theorem PeriodFamily.HomologyDifference.sourceDifferenceOne_coordinates
+    (x :
+      SingularMayerVietoris.SingularHomology RealTorus₄ 1 ×
+        SingularMayerVietoris.SingularHomology RealTorus₄ 1) :
+    PeriodFamily.FlatTorus.singularH1Equiv (PeriodFamily.Homology.sourceDifference 1 x) =
+      TrianglePeriodFamilyHomologyLattice.deltaOne
+        (PeriodFamily.FlatTorus.singularH1Equiv x.1,
+          PeriodFamily.FlatTorus.singularH1Equiv x.2) := by
+  change
+    PeriodFamily.FlatTorus.singularH1Equiv
+        ((PeriodFamily.Homology.generatorHomologyEquiv Bool.false 1 x.1 - x.1) +
+          (PeriodFamily.Homology.generatorHomologyEquiv Bool.true 1 x.2 - x.2)) =
+      (A₁ *ᵥ PeriodFamily.FlatTorus.singularH1Equiv x.1 -
+          PeriodFamily.FlatTorus.singularH1Equiv x.1) +
+        (A₂ *ᵥ PeriodFamily.FlatTorus.singularH1Equiv x.2 -
+          PeriodFamily.FlatTorus.singularH1Equiv x.2)
+  rw [map_add, map_sub, map_sub, generatorHomologyOne_false_coordinates,
+    generatorHomologyOne_true_coordinates]
+
+private theorem PeriodFamily.HomologyDifference.sourceDifferenceZero_coordinates
+    (x :
+      SingularMayerVietoris.SingularHomology RealTorus₄ 0 ×
+        SingularMayerVietoris.SingularHomology RealTorus₄ 0) :
+    PeriodTorusHigherHomology.connectedHomologyZeroEquiv RealTorus₄
+        (PeriodFamily.Homology.sourceDifference 0 x) =
+      TrianglePeriodFamilyHomologyLattice.deltaZero
+        (PeriodTorusHigherHomology.connectedHomologyZeroEquiv RealTorus₄ x.1,
+          PeriodTorusHigherHomology.connectedHomologyZeroEquiv RealTorus₄ x.2) := by
+  rw [PeriodFamily.Homology.sourceDifference_zero,
+    TrianglePeriodFamilyHomologyLattice.deltaZero_eq_zero]
+  simp only [LinearMap.zero_apply, map_zero]
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.HomologyDifference.kernelZeroCoordinates :
+    LinearMap.ker (PeriodFamily.Homology.sourceDifference 0) ≃ₗ[ℤ]
+      LinearMap.ker TrianglePeriodFamilyHomologyLattice.deltaZero :=
+  kernelEquivOfCommuting (PeriodFamily.Homology.sourceDifference 0)
+    TrianglePeriodFamilyHomologyLattice.deltaZero
+    ((PeriodTorusHigherHomology.connectedHomologyZeroEquiv RealTorus₄).toAddEquiv.prodCongr
+        (PeriodTorusHigherHomology.connectedHomologyZeroEquiv
+            RealTorus₄).toAddEquiv).toIntLinearEquiv
+    (PeriodTorusHigherHomology.connectedHomologyZeroEquiv RealTorus₄)
+    sourceDifferenceZero_coordinates
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.HomologyDifference.kernelZeroEquiv :
+    LinearMap.ker (PeriodFamily.Homology.sourceDifference 0) ≃ₗ[ℤ] (ℤ × ℤ) :=
+  (kernelZeroCoordinates.toAddEquiv.trans
+      TrianglePeriodFamilyHomologyLattice.kernelZeroEquiv.toAddEquiv).toIntLinearEquiv
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.HomologyDifference.kernelOneCoordinates :
+    LinearMap.ker (PeriodFamily.Homology.sourceDifference 1) ≃ₗ[ℤ]
+      LinearMap.ker TrianglePeriodFamilyHomologyLattice.deltaOne :=
+  kernelEquivOfCommuting (PeriodFamily.Homology.sourceDifference 1)
+    TrianglePeriodFamilyHomologyLattice.deltaOne
+    (PeriodFamily.FlatTorus.singularH1Equiv.toAddEquiv.prodCongr
+        PeriodFamily.FlatTorus.singularH1Equiv.toAddEquiv).toIntLinearEquiv
+    PeriodFamily.FlatTorus.singularH1Equiv sourceDifferenceOne_coordinates
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.HomologyDifference.kernelOneEquiv :
+    LinearMap.ker (PeriodFamily.Homology.sourceDifference 1) ≃ₗ[ℤ] (Fin 5 → ℤ) :=
+  (kernelOneCoordinates.toAddEquiv.trans
+      TrianglePeriodFamilyHomologyLattice.kernelOneEquiv.toAddEquiv).toIntLinearEquiv
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.HomologyDifference.cokernelOneCoordinates :
+    (SingularMayerVietoris.SingularHomology RealTorus₄ 1 ⧸
+        LinearMap.range (PeriodFamily.Homology.sourceDifference 1)) ≃ₗ[ℤ]
+      (Lattice ⧸ LinearMap.range TrianglePeriodFamilyHomologyLattice.deltaOne) :=
+  cokernelEquivOfCommuting (PeriodFamily.Homology.sourceDifference 1)
+    TrianglePeriodFamilyHomologyLattice.deltaOne
+    (PeriodFamily.FlatTorus.singularH1Equiv.toAddEquiv.prodCongr
+        PeriodFamily.FlatTorus.singularH1Equiv.toAddEquiv).toIntLinearEquiv
+    PeriodFamily.FlatTorus.singularH1Equiv sourceDifferenceOne_coordinates
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.HomologyDifference.cokernelOneEquiv :
+    (SingularMayerVietoris.SingularHomology RealTorus₄ 1 ⧸
+        LinearMap.range (PeriodFamily.Homology.sourceDifference 1)) ≃ₗ[ℤ]
+      ℤ :=
+  (cokernelOneCoordinates.toAddEquiv.trans
+      TrianglePeriodFamilyHomologyLattice.cokernelOneEquiv.toAddEquiv).toIntLinearEquiv
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.HomologyDifference.kernelTwoCoordinates :
+    LinearMap.ker (PeriodFamily.Homology.sourceDifference 2) ≃ₗ[ℤ]
+      LinearMap.ker TrianglePeriodFamilyHomologyLattice.deltaTwo :=
+  kernelEquivOfCommuting (PeriodFamily.Homology.sourceDifference 2)
+    TrianglePeriodFamilyHomologyLattice.deltaTwo
+    (PeriodFamily.FlatTorus.singularH2Coordinates.toAddEquiv.prodCongr
+        PeriodFamily.FlatTorus.singularH2Coordinates.toAddEquiv).toIntLinearEquiv
+    PeriodFamily.FlatTorus.singularH2Coordinates sourceDifferenceTwo_coordinates
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.HomologyDifference.kernelTwoEquiv :
+    LinearMap.ker (PeriodFamily.Homology.sourceDifference 2) ≃ₗ[ℤ] (Fin 7 → ℤ) :=
+  (kernelTwoCoordinates.toAddEquiv.trans
+      TrianglePeriodFamilyHomologyLattice.kernelTwoEquiv.toAddEquiv).toIntLinearEquiv
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.HomologyDifference.cokernelTwoCoordinates :
+    (SingularMayerVietoris.SingularHomology RealTorus₄ 2 ⧸
+        LinearMap.range (PeriodFamily.Homology.sourceDifference 2)) ≃ₗ[ℤ]
+      ((Fin 6 → ℤ) ⧸ LinearMap.range TrianglePeriodFamilyHomologyLattice.deltaTwo) :=
+  cokernelEquivOfCommuting (PeriodFamily.Homology.sourceDifference 2)
+    TrianglePeriodFamilyHomologyLattice.deltaTwo
+    (PeriodFamily.FlatTorus.singularH2Coordinates.toAddEquiv.prodCongr
+        PeriodFamily.FlatTorus.singularH2Coordinates.toAddEquiv).toIntLinearEquiv
+    PeriodFamily.FlatTorus.singularH2Coordinates sourceDifferenceTwo_coordinates
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+@[simp]
+private theorem PeriodFamily.HomologyDifference.cokernelTwoCoordinates_mk
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 2) :
+    cokernelTwoCoordinates (Submodule.Quotient.mk a) =
+      Submodule.Quotient.mk (PeriodFamily.FlatTorus.singularH2Coordinates a) :=
+  rfl
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.HomologyDifference.cokernelTwoEquiv :
+    (SingularMayerVietoris.SingularHomology RealTorus₄ 2 ⧸
+        LinearMap.range (PeriodFamily.Homology.sourceDifference 2)) ≃ₗ[ℤ]
+      ℤ :=
+  (cokernelTwoCoordinates.toAddEquiv.trans
+      TrianglePeriodFamilyHomologyLattice.cokernelTwoEquiv.toAddEquiv).toIntLinearEquiv
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+@[simp]
+private theorem PeriodFamily.HomologyDifference.cokernelTwoEquiv_mk
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 2) :
+    cokernelTwoEquiv (Submodule.Quotient.mk a) =
+      6 * PeriodFamily.FlatTorus.singularH2Coordinates a 2 +
+        PeriodFamily.FlatTorus.singularH2Coordinates a 3 := by
+  change
+    TrianglePeriodFamilyHomologyLattice.cokernelTwoEquiv
+        (cokernelTwoCoordinates (Submodule.Quotient.mk a)) =
+      _
+  rw [cokernelTwoCoordinates_mk]
+  exact TrianglePeriodFamilyHomologyLattice.cokernelTwoEquiv_mk _
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.HomologyDifference.kernelThreeCoordinates :
+    LinearMap.ker (PeriodFamily.Homology.sourceDifference 3) ≃ₗ[ℤ]
+      LinearMap.ker TrianglePeriodFamilyHomologyLattice.deltaThree :=
+  kernelEquivOfCommuting (PeriodFamily.Homology.sourceDifference 3)
+    TrianglePeriodFamilyHomologyLattice.deltaThree
+    (PeriodFamily.FlatTorus.singularH3Coordinates.toAddEquiv.prodCongr
+        PeriodFamily.FlatTorus.singularH3Coordinates.toAddEquiv).toIntLinearEquiv
+    PeriodFamily.FlatTorus.singularH3Coordinates sourceDifferenceThree_coordinates
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.HomologyDifference.kernelThreeEquiv :
+    LinearMap.ker (PeriodFamily.Homology.sourceDifference 3) ≃ₗ[ℤ] (Fin 5 → ℤ) :=
+  (kernelThreeCoordinates.toAddEquiv.trans
+      TrianglePeriodFamilyHomologyLattice.kernelThreeEquiv.toAddEquiv).toIntLinearEquiv
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.HomologyDifference.cokernelThreeCoordinates :
+    (SingularMayerVietoris.SingularHomology RealTorus₄ 3 ⧸
+        LinearMap.range (PeriodFamily.Homology.sourceDifference 3)) ≃ₗ[ℤ]
+      (Lattice ⧸ LinearMap.range TrianglePeriodFamilyHomologyLattice.deltaThree) :=
+  cokernelEquivOfCommuting (PeriodFamily.Homology.sourceDifference 3)
+    TrianglePeriodFamilyHomologyLattice.deltaThree
+    (PeriodFamily.FlatTorus.singularH3Coordinates.toAddEquiv.prodCongr
+        PeriodFamily.FlatTorus.singularH3Coordinates.toAddEquiv).toIntLinearEquiv
+    PeriodFamily.FlatTorus.singularH3Coordinates sourceDifferenceThree_coordinates
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+@[simp]
+private theorem PeriodFamily.HomologyDifference.cokernelThreeCoordinates_mk
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 3) :
+    cokernelThreeCoordinates (Submodule.Quotient.mk a) =
+      Submodule.Quotient.mk (PeriodFamily.FlatTorus.singularH3Coordinates a) :=
+  rfl
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.HomologyDifference.cokernelThreeEquiv :
+    (SingularMayerVietoris.SingularHomology RealTorus₄ 3 ⧸
+        LinearMap.range (PeriodFamily.Homology.sourceDifference 3)) ≃ₗ[ℤ]
+      ℤ :=
+  (cokernelThreeCoordinates.toAddEquiv.trans
+      TrianglePeriodFamilyHomologyLattice.cokernelThreeEquiv.toAddEquiv).toIntLinearEquiv
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+@[simp]
+private theorem PeriodFamily.HomologyDifference.cokernelThreeEquiv_mk
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 3) :
+    cokernelThreeEquiv (Submodule.Quotient.mk a) =
+      PeriodFamily.FlatTorus.singularH3Coordinates a 0 := by
+  change
+    TrianglePeriodFamilyHomologyLattice.cokernelThreeEquiv
+        (cokernelThreeCoordinates (Submodule.Quotient.mk a)) =
+      _
+  rw [cokernelThreeCoordinates_mk]
+  exact TrianglePeriodFamilyHomologyLattice.cokernelThreeEquiv_mk _
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+@[simp]
+private theorem PeriodFamily.HomologyDifference.cokernelThreeEquiv_symm_apply (z : ℤ) :
+    cokernelThreeEquiv.symm z =
+      Submodule.Quotient.mk (PeriodFamily.FlatTorus.singularH3Coordinates.symm ![z, 0, 0, 0]) := by
+  apply cokernelThreeEquiv.injective
+  rw [LinearEquiv.apply_symm_apply, cokernelThreeEquiv_mk]
+  simp only [LinearEquiv.apply_symm_apply]
+  rfl
+
+private def
+    PeriodFamily.Homology.headMapFibre {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (F :
+      C((PeriodTorusHigherHomology.CircleTopology.Circle) × X,
+        (PeriodTorusHigherHomology.CircleTopology.Circle) × Y))
+    (z : (PeriodTorusHigherHomology.CircleTopology.Circle)) : C(X, Y) :=
+  (PeriodTorusHigherHomology.CircleTopology.productProjection Y).comp
+    (F.comp ((ContinuousMap.const X z).prodMk (ContinuousMap.id X)))
+
+private theorem PeriodFamily.Homology.headMap_mapsToU {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y]
+    (F :
+      C((PeriodTorusHigherHomology.CircleTopology.Circle) × X,
+        (PeriodTorusHigherHomology.CircleTopology.Circle) × Y))
+    (hF : ∀ z, (F z).1 = z.1) :
+    Set.MapsTo F (PeriodTorusHigherHomology.CircleTopology.productU X)
+      (PeriodTorusHigherHomology.CircleTopology.productU Y) := by
+  intro z hz
+  change (F z).1 ∈ PeriodTorusHigherHomology.CircleTopology.arcU
+  rw [hF]
+  exact hz
+
+private theorem PeriodFamily.Homology.headMap_mapsToV {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y]
+    (F :
+      C((PeriodTorusHigherHomology.CircleTopology.Circle) × X,
+        (PeriodTorusHigherHomology.CircleTopology.Circle) × Y))
+    (hF : ∀ z, (F z).1 = z.1) :
+    Set.MapsTo F (PeriodTorusHigherHomology.CircleTopology.productV X)
+      (PeriodTorusHigherHomology.CircleTopology.productV Y) := by
+  intro z hz
+  change (F z).1 ∈ PeriodTorusHigherHomology.CircleTopology.arcV
+  rw [hF]
+  exact hz
+
+private def PeriodFamily.Homology.headIntersectionMap {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y]
+    (F :
+      C((PeriodTorusHigherHomology.CircleTopology.Circle) × X,
+        (PeriodTorusHigherHomology.CircleTopology.Circle) × Y))
+    (hF : ∀ z, (F z).1 = z.1) :
+    C(↥(PeriodTorusHigherHomology.CircleTopology.productU X ∩
+          PeriodTorusHigherHomology.CircleTopology.productV X),
+      ↥(PeriodTorusHigherHomology.CircleTopology.productU Y ∩
+          PeriodTorusHigherHomology.CircleTopology.productV Y)) :=
+  SingularMayerVietoris.intersectionRestriction F
+    (PeriodTorusHigherHomology.CircleTopology.productU X)
+    (PeriodTorusHigherHomology.CircleTopology.productV X)
+    (PeriodTorusHigherHomology.CircleTopology.productU Y)
+    (PeriodTorusHigherHomology.CircleTopology.productV Y) (headMap_mapsToU F hF)
+    (headMap_mapsToV F hF)
+
+private theorem PeriodFamily.Homology.headIntersectionMap_quarter {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y]
+    (F :
+      C((PeriodTorusHigherHomology.CircleTopology.Circle) × X,
+        (PeriodTorusHigherHomology.CircleTopology.Circle) × Y))
+    (hF : ∀ z, (F z).1 = z.1) :
+    (headIntersectionMap F hF).comp
+        (PeriodTorusHigherHomology.CirclePaths.quarterIntersectionSection X) =
+      (PeriodTorusHigherHomology.CirclePaths.quarterIntersectionSection Y).comp
+        (headMapFibre F PeriodTorusHigherHomology.CirclePaths.quarterPoint) := by
+  apply ContinuousMap.ext
+  intro x
+  apply Subtype.ext
+  apply Prod.ext
+  · exact hF (PeriodTorusHigherHomology.CirclePaths.quarterPoint, x)
+  · rfl
+
+private theorem
+    PeriodFamily.Homology.headIntersectionMap_threeQuarter {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y]
+    (F :
+      C((PeriodTorusHigherHomology.CircleTopology.Circle) × X,
+        (PeriodTorusHigherHomology.CircleTopology.Circle) × Y))
+    (hF : ∀ z, (F z).1 = z.1) :
+    (headIntersectionMap F hF).comp
+        (PeriodTorusHigherHomology.CirclePaths.threeQuarterIntersectionSection X) =
+      (PeriodTorusHigherHomology.CirclePaths.threeQuarterIntersectionSection Y).comp
+        (headMapFibre F PeriodTorusHigherHomology.CirclePaths.threeQuarterPoint) := by
+  apply ContinuousMap.ext
+  intro x
+  apply Subtype.ext
+  apply Prod.ext
+  · exact hF (PeriodTorusHigherHomology.CirclePaths.threeQuarterPoint, x)
+  · rfl
+
+private theorem PeriodFamily.Homology.intersectionHomology_sections {X : Type} [TopologicalSpace X]
+    (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (PeriodTorusHigherHomology.CircleTopology.productU X ∩
+            PeriodTorusHigherHomology.CircleTopology.productV X :
+          Set ((PeriodTorusHigherHomology.CircleTopology.Circle) × X))
+        n) :
+    a =
+      SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.CirclePaths.quarterIntersectionSection X) n
+          (PeriodTorusHigherHomology.productIntersectionHomologyEquiv X n a).1 +
+        SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.CirclePaths.threeQuarterIntersectionSection X) n
+          (PeriodTorusHigherHomology.productIntersectionHomologyEquiv X n a).2 := by
+  apply (PeriodTorusHigherHomology.productIntersectionHomologyEquiv X n).injective
+  rw [map_add, PeriodTorusHigherHomology.quarterIntersectionHomology_coordinates,
+    PeriodTorusHigherHomology.threeQuarterIntersectionHomology_coordinates]
+  simp only [Prod.mk_add_mk, add_zero, zero_add, Prod.mk.eta]
+
+private theorem
+    PeriodFamily.Homology.headIntersectionHomology_quarter {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y]
+    (F :
+      C((PeriodTorusHigherHomology.CircleTopology.Circle) × X,
+        (PeriodTorusHigherHomology.CircleTopology.Circle) × Y))
+    (hF : ∀ z, (F z).1 = z.1) (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    PeriodTorusHigherHomology.productIntersectionHomologyEquiv Y n
+        (SingularMayerVietoris.singularHomologyMap (headIntersectionMap F hF) n
+          (SingularMayerVietoris.singularHomologyMap
+            (PeriodTorusHigherHomology.CirclePaths.quarterIntersectionSection X) n a)) =
+      (SingularMayerVietoris.singularHomologyMap
+          (headMapFibre F PeriodTorusHigherHomology.CirclePaths.quarterPoint) n a,
+        0) := by
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    headIntersectionMap_quarter, PeriodTorusHigherHomology.singularHomologyMap_comp,
+    LinearMap.comp_apply, PeriodTorusHigherHomology.quarterIntersectionHomology_coordinates]
+
+private theorem PeriodFamily.Homology.headIntersectionHomology_threeQuarter {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y]
+    (F :
+      C((PeriodTorusHigherHomology.CircleTopology.Circle) × X,
+        (PeriodTorusHigherHomology.CircleTopology.Circle) × Y))
+    (hF : ∀ z, (F z).1 = z.1) (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    PeriodTorusHigherHomology.productIntersectionHomologyEquiv Y n
+        (SingularMayerVietoris.singularHomologyMap (headIntersectionMap F hF) n
+          (SingularMayerVietoris.singularHomologyMap
+            (PeriodTorusHigherHomology.CirclePaths.threeQuarterIntersectionSection X) n a)) =
+      (0,
+        SingularMayerVietoris.singularHomologyMap
+          (headMapFibre F PeriodTorusHigherHomology.CirclePaths.threeQuarterPoint) n a) := by
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    headIntersectionMap_threeQuarter, PeriodTorusHigherHomology.singularHomologyMap_comp,
+    LinearMap.comp_apply, PeriodTorusHigherHomology.threeQuarterIntersectionHomology_coordinates]
+
+private theorem PeriodFamily.Homology.headIntersectionHomology_coordinates {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y]
+    (F :
+      C((PeriodTorusHigherHomology.CircleTopology.Circle) × X,
+        (PeriodTorusHigherHomology.CircleTopology.Circle) × Y))
+    (hF : ∀ z, (F z).1 = z.1) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (PeriodTorusHigherHomology.CircleTopology.productU X ∩
+            PeriodTorusHigherHomology.CircleTopology.productV X :
+          Set ((PeriodTorusHigherHomology.CircleTopology.Circle) × X))
+        n) :
+    PeriodTorusHigherHomology.productIntersectionHomologyEquiv Y n
+        (SingularMayerVietoris.singularHomologyMap (headIntersectionMap F hF) n a) =
+      (SingularMayerVietoris.singularHomologyMap
+          (headMapFibre F PeriodTorusHigherHomology.CirclePaths.quarterPoint) n
+          (PeriodTorusHigherHomology.productIntersectionHomologyEquiv X n a).1,
+        SingularMayerVietoris.singularHomologyMap
+          (headMapFibre F PeriodTorusHigherHomology.CirclePaths.threeQuarterPoint) n
+          (PeriodTorusHigherHomology.productIntersectionHomologyEquiv X n a).2) := by
+  conv_lhs => rw [intersectionHomology_sections n a]
+  rw [map_add, map_add, headIntersectionHomology_quarter, headIntersectionHomology_threeQuarter]
+  simp only [Prod.mk_add_mk, add_zero, zero_add]
+
+private theorem PeriodFamily.Homology.circleConnecting_headMap {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y]
+    (F :
+      C((PeriodTorusHigherHomology.CircleTopology.Circle) × X,
+        (PeriodTorusHigherHomology.CircleTopology.Circle) × Y))
+    (hF : ∀ z, (F z).1 = z.1) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) × X) (n + 1)) :
+    SingularMayerVietoris.singularHomologyMap (headIntersectionMap F hF) n
+        (PeriodTorusHigherHomology.circleMayerVietorisConnecting X n a) =
+      PeriodTorusHigherHomology.circleMayerVietorisConnecting Y n
+        (SingularMayerVietoris.singularHomologyMap F (n + 1) a) :=
+  SingularMayerVietoris.connectingHomomorphism_naturality_apply F
+    (PeriodTorusHigherHomology.CircleTopology.productU X)
+    (PeriodTorusHigherHomology.CircleTopology.productV X)
+    (PeriodTorusHigherHomology.CircleTopology.productU Y)
+    (PeriodTorusHigherHomology.CircleTopology.productV Y) (headMap_mapsToU F hF)
+    (headMap_mapsToV F hF) (PeriodTorusHigherHomology.CircleTopology.productU_open X)
+    (PeriodTorusHigherHomology.CircleTopology.productV_open X)
+    (PeriodTorusHigherHomology.CircleTopology.product_cover X)
+    (PeriodTorusHigherHomology.CircleTopology.productU_open Y)
+    (PeriodTorusHigherHomology.CircleTopology.productV_open Y)
+    (PeriodTorusHigherHomology.CircleTopology.product_cover Y) n a
+
+private theorem PeriodFamily.Homology.circleBoundary_headMap {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y]
+    (F :
+      C((PeriodTorusHigherHomology.CircleTopology.Circle) × X,
+        (PeriodTorusHigherHomology.CircleTopology.Circle) × Y))
+    (hF : ∀ z, (F z).1 = z.1) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) × X) (n + 1)) :
+    PeriodTorusHigherHomology.circleBoundary Y n
+        (SingularMayerVietoris.singularHomologyMap F (n + 1) a) =
+      SingularMayerVietoris.singularHomologyMap
+        (headMapFibre F PeriodTorusHigherHomology.CirclePaths.quarterPoint) n
+        (PeriodTorusHigherHomology.circleBoundary X n a) := by
+  change
+    -(PeriodTorusHigherHomology.productIntersectionHomologyEquiv Y n
+            (PeriodTorusHigherHomology.circleMayerVietorisConnecting Y n
+              (SingularMayerVietoris.singularHomologyMap F (n + 1) a))).1 =
+      SingularMayerVietoris.singularHomologyMap
+        (headMapFibre F PeriodTorusHigherHomology.CirclePaths.quarterPoint) n
+        (-(PeriodTorusHigherHomology.productIntersectionHomologyEquiv X n
+              (PeriodTorusHigherHomology.circleMayerVietorisConnecting X n a)).1)
+  rw [← circleConnecting_headMap F hF, headIntersectionHomology_coordinates, map_neg]
+
+private def PeriodFamily.Homology.topDegreeTailMatrix (A : Matrix (Fin 4) (Fin 4) ℤ) :
+    Matrix (Fin 3) (Fin 3) ℤ :=
+  A.submatrix Fin.succ Fin.succ
+
+private def PeriodFamily.Homology.topDegreeCircleMap (A : Matrix (Fin 4) (Fin 4) ℤ) :
+    C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+        PeriodTorusHigherHomology.ProductTorus 3,
+      (PeriodTorusHigherHomology.CircleTopology.Circle) ×
+        PeriodTorusHigherHomology.ProductTorus 3) :=
+  (PeriodTorusHigherHomology.productTorusSuccHomeomorph 3 : C(_, _)).comp
+    ((PeriodTorusHigherHomology.torusMatrixMap A).comp
+      ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 3).symm : C(_, _)))
+
+@[simp]
+private theorem PeriodFamily.Homology.topDegreeCircleMap_apply (A : Matrix (Fin 4) (Fin 4) ℤ)
+    (z :
+      (PeriodTorusHigherHomology.CircleTopology.Circle) ×
+        PeriodTorusHigherHomology.ProductTorus 3) :
+    topDegreeCircleMap A z =
+      PeriodTorusHigherHomology.productTorusSuccHomeomorph 3
+        (PeriodTorusHigherHomology.torusMatrixMap A
+          ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 3).symm z)) :=
+  rfl
+
+private theorem PeriodFamily.Homology.topDegreeCircleMap_homeomorph (A : Matrix (Fin 4) (Fin 4) ℤ)
+    (x : PeriodTorusHigherHomology.ProductTorus 4) :
+    topDegreeCircleMap A (PeriodTorusHigherHomology.productTorusSuccHomeomorph 3 x) =
+      PeriodTorusHigherHomology.productTorusSuccHomeomorph 3
+        (PeriodTorusHigherHomology.torusMatrixMap A x) := by
+  rw [topDegreeCircleMap_apply, Homeomorph.symm_apply_apply]
+
+private theorem
+    PeriodFamily.Homology.topDegreeCircleMap_comp_homeomorph (A : Matrix (Fin 4) (Fin 4) ℤ) :
+    (topDegreeCircleMap A).comp
+        (PeriodTorusHigherHomology.productTorusSuccHomeomorph 3 : C(_, _)) =
+      (PeriodTorusHigherHomology.productTorusSuccHomeomorph 3 : C(_, _)).comp
+        (PeriodTorusHigherHomology.torusMatrixMap A) := by
+  apply ContinuousMap.ext
+  intro x
+  exact topDegreeCircleMap_homeomorph A x
+
+private theorem PeriodFamily.Homology.topDegreeCircleMap_fst (A : Matrix (Fin 4) (Fin 4) ℤ)
+    (hA : ∀ j, A 0 j = if j = 0 then 1 else 0)
+    (z :
+      (PeriodTorusHigherHomology.CircleTopology.Circle) ×
+        PeriodTorusHigherHomology.ProductTorus 3) :
+    (topDegreeCircleMap A z).1 = z.1 := by
+  change (∑ j : Fin 4, A 0 j • Fin.cons z.1 z.2 j) = z.1
+  simp [hA]
+
+private theorem PeriodFamily.Homology.topDegreeCircleMap_snd (A : Matrix (Fin 4) (Fin 4) ℤ)
+    (z :
+      (PeriodTorusHigherHomology.CircleTopology.Circle) ×
+        PeriodTorusHigherHomology.ProductTorus 3)
+    (i : Fin 3) :
+    (topDegreeCircleMap A z).2 i =
+      PeriodTorusHigherHomology.torusMatrixMap (topDegreeTailMatrix A) z.2 i + A i.succ 0 • z.1 :=
+  by
+  change
+    (∑ j : Fin 4, A i.succ j • Fin.cons z.1 z.2 j) =
+      (∑ j : Fin 3, A i.succ j.succ • z.2 j) + A i.succ 0 • z.1
+  rw [Fin.sum_univ_succ]
+  simp only [Fin.cons_zero, Fin.cons_succ]
+  exact add_comm _ _
+
+private def PeriodFamily.Homology.topDegreeCircleSection
+    (z : (PeriodTorusHigherHomology.CircleTopology.Circle)) :
+    C(PeriodTorusHigherHomology.ProductTorus 3,
+      (PeriodTorusHigherHomology.CircleTopology.Circle) ×
+        PeriodTorusHigherHomology.ProductTorus 3) :=
+  ⟨fun x => (z, x), continuous_const.prodMk continuous_id⟩
+
+private def PeriodFamily.Homology.topDegreeFibreMap (A : Matrix (Fin 4) (Fin 4) ℤ)
+    (z : (PeriodTorusHigherHomology.CircleTopology.Circle)) :
+    C(PeriodTorusHigherHomology.ProductTorus 3, PeriodTorusHigherHomology.ProductTorus 3) :=
+  ContinuousMap.snd.comp ((topDegreeCircleMap A).comp (topDegreeCircleSection z))
+
+private theorem
+    PeriodFamily.Homology.topDegreeFibreMap_apply_coordinate (A : Matrix (Fin 4) (Fin 4) ℤ)
+    (z : (PeriodTorusHigherHomology.CircleTopology.Circle))
+    (x : PeriodTorusHigherHomology.ProductTorus 3) (i : Fin 3) :
+    topDegreeFibreMap A z x i =
+      PeriodTorusHigherHomology.torusMatrixMap (topDegreeTailMatrix A) x i + A i.succ 0 • z :=
+  topDegreeCircleMap_snd A (z, x) i
+
+private def PeriodFamily.Homology.topDegreeFibreTranslation (A : Matrix (Fin 4) (Fin 4) ℤ)
+    (z : (PeriodTorusHigherHomology.CircleTopology.Circle)) :
+    PeriodTorusHigherHomology.ProductTorus 3 := fun i => A i.succ 0 • z
+
+private theorem
+    PeriodFamily.Homology.topDegreeFibreMap_eq_translation (A : Matrix (Fin 4) (Fin 4) ℤ)
+    (z : (PeriodTorusHigherHomology.CircleTopology.Circle)) :
+    topDegreeFibreMap A z =
+      (PeriodTorusHigherHomology.rightTranslation (topDegreeFibreTranslation A z)).comp
+        (PeriodTorusHigherHomology.torusMatrixMap (topDegreeTailMatrix A)) := by
+  apply ContinuousMap.ext
+  intro x
+  ext i
+  exact topDegreeFibreMap_apply_coordinate A z x i
+
+private theorem
+    PeriodFamily.Homology.topDegreeFibreMap_singularHomologyMap (A : Matrix (Fin 4) (Fin 4) ℤ)
+    (z : (PeriodTorusHigherHomology.CircleTopology.Circle)) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (topDegreeFibreMap A z) n =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.torusMatrixMap (topDegreeTailMatrix A)) n := by
+  rw [topDegreeFibreMap_eq_translation, PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodTorusHigherHomology.rightTranslation_singularHomologyMap, LinearMap.id_comp]
+
+private theorem PeriodFamily.Homology.topDegree_det_eq_tail (A : Matrix (Fin 4) (Fin 4) ℤ)
+    (hA : ∀ j, A 0 j = if j = 0 then 1 else 0) : A.det = (topDegreeTailMatrix A).det := by
+  rw [Matrix.det_succ_row_zero]
+  simp [hA, topDegreeTailMatrix]
+
+private theorem PeriodFamily.Homology.circleTopDegreeBoundary_injective :
+    Function.Injective
+      (PeriodTorusHigherHomology.circleBoundary (PeriodTorusHigherHomology.ProductTorus 3) 3) := by
+  let := PeriodTorusHigherHomology.productTorus_homology_subsingleton_of_lt (show 3 < 4 by decide)
+  intro a b hab
+  apply
+    (PeriodTorusHigherHomology.circleProductHomologyEquiv
+        (PeriodTorusHigherHomology.ProductTorus 3) 3).injective
+  apply Prod.ext
+  · exact Subsingleton.elim _ _
+  · exact hab
+
+private def PeriodFamily.Homology.circleTopDegreeEquiv :
+    SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 3)
+        4 ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3 :=
+  LinearEquiv.ofBijective
+    (PeriodTorusHigherHomology.circleBoundary (PeriodTorusHigherHomology.ProductTorus 3) 3)
+    ⟨circleTopDegreeBoundary_injective,
+      PeriodTorusHigherHomology.circleBoundary_surjective
+        (PeriodTorusHigherHomology.ProductTorus 3) 3⟩
+
+@[simp]
+private theorem PeriodFamily.Homology.circleTopDegreeEquiv_positiveCircleCross
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3) :
+    circleTopDegreeEquiv
+        (PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 3)
+          3 a) =
+      a :=
+  PeriodTorusHigherHomology.circleBoundary_positiveCircleCross
+    (PeriodTorusHigherHomology.ProductTorus 3) 3 a
+
+private theorem PeriodFamily.Homology.circleTopDegreeEquiv_symm_apply
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3) :
+    circleTopDegreeEquiv.symm a =
+      PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 3) 3
+        a := by
+  apply circleTopDegreeEquiv.injective
+  rw [LinearEquiv.apply_symm_apply, circleTopDegreeEquiv_positiveCircleCross]
+
+private def PeriodFamily.Homology.circleTopDegreeCoordinates :
+    SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 3)
+        4 ≃ₗ[ℤ]
+      ℤ :=
+  circleTopDegreeEquiv.trans Elliptic.HigherHomology.torusH3Coordinates
+
+private def PeriodFamily.Homology.topDegreeTorusCoordinates :
+    SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 4 ≃ₗ[ℤ] ℤ :=
+  (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+        (PeriodTorusHigherHomology.productTorusSuccHomeomorph 3) 4).trans
+    circleTopDegreeCoordinates
+
+@[simp]
+private theorem PeriodFamily.Homology.topDegreeTorusCoordinates_apply
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 4) :
+    topDegreeTorusCoordinates a =
+      Elliptic.HigherHomology.torusH3Coordinates
+        (PeriodTorusHigherHomology.circleBoundary (PeriodTorusHigherHomology.ProductTorus 3) 3
+          (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+            (PeriodTorusHigherHomology.productTorusSuccHomeomorph 3) 4 a)) :=
+  rfl
+
+private theorem PeriodFamily.Homology.topDegreeTorusCoordinates_topClass :
+    topDegreeTorusCoordinates (PeriodTorusHigherHomology.productTorusTopClass 4) = 1 := by
+  rw [topDegreeTorusCoordinates_apply,
+    PeriodTorusHigherHomology.productTorusTopClass_succ_boundary]
+  have h :
+    PeriodTorusHigherHomology.productTorusTopClass 3 =
+      Elliptic.HigherHomology.torusH3Coordinates.symm 1 :=
+    PeriodTorusHigherHomology.productTorusTopClass_three.trans
+      Elliptic.HigherHomology.torusH3Coordinates_symm_one.symm
+  rw [h, LinearEquiv.apply_symm_apply]
+
+private theorem PeriodFamily.Homology.circleTopDegreeBoundary_matrix (A : LatticeMatrix)
+    (hA : ∀ j, A 0 j = if j = 0 then 1 else 0)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 3)
+        4) :
+    PeriodTorusHigherHomology.circleBoundary (PeriodTorusHigherHomology.ProductTorus 3) 3
+        (SingularMayerVietoris.singularHomologyMap (topDegreeCircleMap A) 4 a) =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.torusMatrixMap (topDegreeTailMatrix A)) 3
+        (PeriodTorusHigherHomology.circleBoundary (PeriodTorusHigherHomology.ProductTorus 3) 3
+          a) := by
+  have h := circleBoundary_headMap (topDegreeCircleMap A) (topDegreeCircleMap_fst A hA) 3 a
+  change
+    PeriodTorusHigherHomology.circleBoundary (PeriodTorusHigherHomology.ProductTorus 3) 3
+        (SingularMayerVietoris.singularHomologyMap (topDegreeCircleMap A) 4 a) =
+      SingularMayerVietoris.singularHomologyMap
+        (topDegreeFibreMap A PeriodTorusHigherHomology.CirclePaths.quarterPoint) 3
+        (PeriodTorusHigherHomology.circleBoundary (PeriodTorusHigherHomology.ProductTorus 3) 3
+          a) at h
+  rw [topDegreeFibreMap_singularHomologyMap] at h
+  exact h
+
+private theorem PeriodFamily.Homology.circleTopDegreeCoordinates_matrix (A : LatticeMatrix)
+    (hA : ∀ j, A 0 j = if j = 0 then 1 else 0)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 3)
+        4) :
+    circleTopDegreeCoordinates
+        (SingularMayerVietoris.singularHomologyMap (topDegreeCircleMap A) 4 a) =
+      A.det * circleTopDegreeCoordinates a := by
+  change
+    Elliptic.HigherHomology.torusH3Coordinates
+        (PeriodTorusHigherHomology.circleBoundary (PeriodTorusHigherHomology.ProductTorus 3) 3
+          (SingularMayerVietoris.singularHomologyMap (topDegreeCircleMap A) 4 a)) =
+      _
+  rw [circleTopDegreeBoundary_matrix A hA,
+    Elliptic.HigherHomology.torusH3Coordinates_matrix_natural, topDegree_det_eq_tail A hA]
+  rfl
+
+private theorem PeriodFamily.Homology.topDegreeTorusCoordinates_matrix (A : LatticeMatrix)
+    (hA : ∀ j, A 0 j = if j = 0 then 1 else 0)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 4) :
+    topDegreeTorusCoordinates
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap A) 4
+          a) =
+      A.det * topDegreeTorusCoordinates a := by
+  change
+    circleTopDegreeCoordinates
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.productTorusSuccHomeomorph 3 : C(_, _)) 4
+          (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap A)
+            4 a)) =
+      _
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp, ←
+    topDegreeCircleMap_comp_homeomorph, PeriodTorusHigherHomology.singularHomologyMap_comp,
+    LinearMap.comp_apply]
+  exact circleTopDegreeCoordinates_matrix A hA _
+
+private theorem PeriodFamily.Homology.torusMatrixMap_homologyFour_apply (A : LatticeMatrix)
+    (hA : ∀ j, A 0 j = if j = 0 then 1 else 0)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 4) :
+    SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap A) 4 a =
+      A.det • a := by
+  apply topDegreeTorusCoordinates.injective
+  rw [map_zsmul]
+  simpa only [zsmul_eq_mul, Int.cast_id] using topDegreeTorusCoordinates_matrix A hA a
+
+private theorem PeriodFamily.Homology.torusMatrixMap_homologyFour (A : LatticeMatrix)
+    (hA : ∀ j, A 0 j = if j = 0 then 1 else 0) :
+    SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap A) 4 =
+      A.det •
+        (LinearMap.id :
+          SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4)
+              4 →ₗ[ℤ]
+            _) := by
+  apply LinearMap.ext
+  intro a
+  exact torusMatrixMap_homologyFour_apply A hA a
+
+private theorem PeriodFamily.Homology.torusMatrixMap_homologyFour_of_det_one (A : LatticeMatrix)
+    (hA : ∀ j, A 0 j = if j = 0 then 1 else 0) (hdet : A.det = 1) :
+    SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap A) 4 =
+      LinearMap.id := by rw [torusMatrixMap_homologyFour A hA, hdet, one_smul]
+
+private theorem PeriodFamily.Homology.torusMatrixMap_A₁_homologyFour :
+    SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap A₁) 4 =
+      LinearMap.id := by
+  apply torusMatrixMap_homologyFour_of_det_one A₁
+  · intro j
+    fin_cases j <;> decide
+  · decide
+
+private theorem PeriodFamily.Homology.torusMatrixMap_A₂_homologyFour :
+    SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap A₂) 4 =
+      LinearMap.id := by
+  apply torusMatrixMap_homologyFour_of_det_one A₂
+  · intro j
+    fin_cases j <;> decide
+  · decide
+
+private theorem PeriodFamily.Homology.torusMatrixMap_M₀_homologyFour :
+    SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusMatrixMap M₀) 4 =
+      LinearMap.id := by
+  apply torusMatrixMap_homologyFour_of_det_one M₀
+  · intro j
+    fin_cases j <;> decide
+  · decide
+
+private theorem PeriodFamily.Homology.dual_homology_one_mo1973_25539 :
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.torusMatrixMap
+          (SpecialPeriods.triangleDualRepresentation 1 : LatticeMatrix))
+        4 =
+      LinearMap.id := by
+  rw [map_one, Matrix.SpecialLinearGroup.coe_one, PeriodTorusHigherHomology.torusMatrixMap_one,
+    PeriodTorusHigherHomology.singularHomologyMap_id]
+
+private theorem PeriodFamily.Homology.dual_homology_mul_mo1973_25540
+    (g h : SpecialPeriods.TriangleGroup) :
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.torusMatrixMap
+          (SpecialPeriods.triangleDualRepresentation (g * h) : LatticeMatrix))
+        4 =
+      (SingularMayerVietoris.singularHomologyMap
+            (PeriodTorusHigherHomology.torusMatrixMap
+              (SpecialPeriods.triangleDualRepresentation g : LatticeMatrix))
+            4).comp
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.torusMatrixMap
+            (SpecialPeriods.triangleDualRepresentation h : LatticeMatrix))
+          4) := by
+  rw [map_mul, Matrix.SpecialLinearGroup.coe_mul, PeriodTorusHigherHomology.torusMatrixMap_mul,
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+
+private theorem PeriodFamily.Homology.triangleDualRepresentation_homologyFour
+    (g : SpecialPeriods.TriangleGroup) :
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.torusMatrixMap
+          (SpecialPeriods.triangleDualRepresentation g : LatticeMatrix))
+        4 =
+      LinearMap.id := by
+  have hg :
+    g ∈
+      Subgroup.closure
+        ({ SpecialPeriods.triangleGenerator₁, SpecialPeriods.triangleGenerator₂ } :
+          Set SpecialPeriods.TriangleGroup) := by
+    rw [SpecialPeriods.triangle_generators_generate]
+    exact Subgroup.mem_top g
+  induction hg using Subgroup.closure_induction with
+  | mem g hg =>
+    rcases Set.mem_insert_iff.mp hg with rfl | hg
+    · rw [SpecialPeriods.triangleDualRepresentation_generator₁_matrix]
+      exact torusMatrixMap_A₁_homologyFour
+    · have he : g = SpecialPeriods.triangleGenerator₂ := Set.mem_singleton_iff.mp hg
+      subst g
+      rw [SpecialPeriods.triangleDualRepresentation_generator₂_matrix]
+      exact torusMatrixMap_A₂_homologyFour
+  | one => exact dual_homology_one_mo1973_25539
+  | mul g h _ _ ihg ihh => rw [dual_homology_mul_mo1973_25540, ihg, ihh, LinearMap.id_comp]
+  | inv g _ ihg =>
+    have h := dual_homology_mul_mo1973_25540 g⁻¹ g
+    rw [inv_mul_cancel, dual_homology_one_mo1973_25539, ihg, LinearMap.comp_id] at h
+    exact h.symm
+
+private theorem PeriodFamily.HomologyDifference.triangleHomologyFour_identity
+    (g : SpecialPeriods.TriangleGroup) :
+    PeriodFamily.Homology.triangleHomologyEquiv g 4 =
+      LinearEquiv.refl ℤ (SingularMayerVietoris.SingularHomology RealTorus₄ 4) := by
+  apply LinearEquiv.ext
+  intro a
+  apply
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+        PeriodTorusHigherHomology.flatTorusCircleHomeomorph 4).injective
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+          C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+        4
+        (SingularMayerVietoris.singularHomologyMap
+          (SpecialPeriods.triangleTorusHomeomorph g : C(RealTorus₄, RealTorus₄)) 4 a) =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+          C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+        4 a
+  rw [PeriodFamily.FlatTorus.flatTorusCircleHomology_triangle_apply,
+    PeriodFamily.Homology.triangleDualRepresentation_homologyFour, LinearMap.id_apply]
+
+@[simp]
+private theorem PeriodFamily.HomologyDifference.sourceDifference_four :
+    PeriodFamily.Homology.sourceDifference 4 = 0 := by
+  apply LinearMap.ext
+  intro x
+  change
+    (PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleGenerator₁ 4 x.1 - x.1) +
+        (PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleGenerator₂ 4 x.2 -
+          x.2) =
+      0
+  rw [triangleHomologyFour_identity, triangleHomologyFour_identity]
+  simp
+
+private theorem PeriodFamily.HomologyDifference.sourceDifferenceFour_coordinates
+    (x :
+      SingularMayerVietoris.SingularHomology RealTorus₄ 4 ×
+        SingularMayerVietoris.SingularHomology RealTorus₄ 4) :
+    PeriodTorusHigherHomology.realTorusH4Equiv (PeriodFamily.Homology.sourceDifference 4 x) =
+      TrianglePeriodFamilyHomologyLattice.deltaFour
+        (PeriodTorusHigherHomology.realTorusH4Equiv x.1,
+          PeriodTorusHigherHomology.realTorusH4Equiv x.2) := by
+  rw [sourceDifference_four, TrianglePeriodFamilyHomologyLattice.deltaFour_eq_zero]
+  simp only [LinearMap.zero_apply, map_zero]
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.HomologyDifference.kernelFourCoordinates :
+    LinearMap.ker (PeriodFamily.Homology.sourceDifference 4) ≃ₗ[ℤ]
+      LinearMap.ker TrianglePeriodFamilyHomologyLattice.deltaFour :=
+  kernelEquivOfCommuting (PeriodFamily.Homology.sourceDifference 4)
+    TrianglePeriodFamilyHomologyLattice.deltaFour
+    (PeriodTorusHigherHomology.realTorusH4Equiv.toAddEquiv.prodCongr
+        PeriodTorusHigherHomology.realTorusH4Equiv.toAddEquiv).toIntLinearEquiv
+    PeriodTorusHigherHomology.realTorusH4Equiv sourceDifferenceFour_coordinates
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.HomologyDifference.kernelFourEquiv :
+    LinearMap.ker (PeriodFamily.Homology.sourceDifference 4) ≃ₗ[ℤ] (ℤ × ℤ) :=
+  (kernelFourCoordinates.toAddEquiv.trans
+      TrianglePeriodFamilyHomologyLattice.kernelFourEquiv.toAddEquiv).toIntLinearEquiv
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.HomologyDifference.cokernelFourCoordinates :
+    (SingularMayerVietoris.SingularHomology RealTorus₄ 4 ⧸
+        LinearMap.range (PeriodFamily.Homology.sourceDifference 4)) ≃ₗ[ℤ]
+      (ℤ ⧸ LinearMap.range TrianglePeriodFamilyHomologyLattice.deltaFour) :=
+  cokernelEquivOfCommuting (PeriodFamily.Homology.sourceDifference 4)
+    TrianglePeriodFamilyHomologyLattice.deltaFour
+    (PeriodTorusHigherHomology.realTorusH4Equiv.toAddEquiv.prodCongr
+        PeriodTorusHigherHomology.realTorusH4Equiv.toAddEquiv).toIntLinearEquiv
+    PeriodTorusHigherHomology.realTorusH4Equiv sourceDifferenceFour_coordinates
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.HomologyDifference.cokernelFourEquiv :
+    (SingularMayerVietoris.SingularHomology RealTorus₄ 4 ⧸
+        LinearMap.range (PeriodFamily.Homology.sourceDifference 4)) ≃ₗ[ℤ]
+      ℤ :=
+  (cokernelFourCoordinates.toAddEquiv.trans
+      TrianglePeriodFamilyHomologyLattice.cokernelFourEquiv.toAddEquiv).toIntLinearEquiv
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.Homology.familyH1ProductEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    SingularMayerVietoris.SingularHomology D.Space 1 ≃ₗ[ℤ] (ℤ × (ℤ × ℤ)) :=
+  familyHomologyMarkedEquiv D 0 PeriodFamily.HomologyDifference.cokernelOneEquiv.toAddEquiv
+    PeriodFamily.HomologyDifference.kernelZeroEquiv.toAddEquiv
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.Homology.familyH2ProductEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    SingularMayerVietoris.SingularHomology D.Space 2 ≃ₗ[ℤ] (ℤ × (Fin 5 → ℤ)) :=
+  familyHomologyMarkedEquiv D 1 PeriodFamily.HomologyDifference.cokernelTwoEquiv.toAddEquiv
+    PeriodFamily.HomologyDifference.kernelOneEquiv.toAddEquiv
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.Homology.familyH3ProductEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    SingularMayerVietoris.SingularHomology D.Space 3 ≃ₗ[ℤ] (ℤ × (Fin 7 → ℤ)) :=
+  familyHomologyMarkedEquiv D 2 PeriodFamily.HomologyDifference.cokernelThreeEquiv.toAddEquiv
+    PeriodFamily.HomologyDifference.kernelTwoEquiv.toAddEquiv
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.Homology.familyH4ProductEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    SingularMayerVietoris.SingularHomology D.Space 4 ≃ₗ[ℤ] (ℤ × (Fin 5 → ℤ)) :=
+  familyHomologyMarkedEquiv D 3 PeriodFamily.HomologyDifference.cokernelFourEquiv.toAddEquiv
+    PeriodFamily.HomologyDifference.kernelThreeEquiv.toAddEquiv
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private theorem PeriodFamily.Homology.sourceKernelProjection_injective_of_torus_vanish
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ)
+    (hn : Subsingleton (SingularMayerVietoris.SingularHomology RealTorus₄ (n + 1))) :
+    Function.Injective (sourceKernelProjection D n) := by
+  intro a b hab
+  have hzero : sourceKernelProjection D n (a - b) = 0 := by rw [map_sub, hab, sub_self]
+  obtain ⟨q, hq⟩ := (sourceCoinvariantInclusion_kernelProjection_exact D n (a - b)).mp hzero
+  obtain ⟨x, rfl⟩ := Submodule.Quotient.mk_surjective _ q
+  have hx : x = 0 := hn.elim _ _
+  rw [hx, Submodule.Quotient.mk_zero, map_zero] at hq
+  exact sub_eq_zero.mp hq.symm
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.Homology.familyH5KernelEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    SingularMayerVietoris.SingularHomology D.Space 5 ≃ₗ[ℤ] LinearMap.ker (sourceDifference 4) :=
+  LinearEquiv.ofBijective (sourceKernelProjection D 4)
+    ⟨sourceKernelProjection_injective_of_torus_vanish D 4
+        (PeriodTorusHigherHomology.realTorus_homology_subsingleton_of_lt (by decide)),
+      sourceKernelProjection_surjective D 4⟩
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.Homology.familyH5ProductEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    SingularMayerVietoris.SingularHomology D.Space 5 ≃ₗ[ℤ] (ℤ × ℤ) :=
+  ((familyH5KernelEquiv D).toAddEquiv.trans
+      PeriodFamily.HomologyDifference.kernelFourEquiv.toAddEquiv).toIntLinearEquiv
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.Homology.familyH1Equiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    SingularMayerVietoris.SingularHomology D.Space 1 ≃ₗ[ℤ] (Fin 3 → ℤ) :=
+  let e : (ℤ × (ℤ × ℤ)) ≃+ (ℤ × (Fin 2 → ℤ)) :=
+    (AddEquiv.refl ℤ).prodCongr (LinearEquiv.finTwoArrow ℤ ℤ).symm.toAddEquiv
+  (((familyH1ProductEquiv D).toAddEquiv.trans e).toIntLinearEquiv).trans
+    (TrianglePeriodFamilyHomologyFreeCoordinates.integerFreeCoordinateEquiv 2)
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.Homology.familyH2Equiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    SingularMayerVietoris.SingularHomology D.Space 2 ≃ₗ[ℤ] (Fin 6 → ℤ) :=
+  (familyH2ProductEquiv D).trans
+    (TrianglePeriodFamilyHomologyFreeCoordinates.integerFreeCoordinateEquiv 5)
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.Homology.familyH3Equiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    SingularMayerVietoris.SingularHomology D.Space 3 ≃ₗ[ℤ] (Fin 8 → ℤ) :=
+  (familyH3ProductEquiv D).trans
+    (TrianglePeriodFamilyHomologyFreeCoordinates.integerFreeCoordinateEquiv 7)
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.Homology.familyH4Equiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    SingularMayerVietoris.SingularHomology D.Space 4 ≃ₗ[ℤ] (Fin 6 → ℤ) :=
+  (familyH4ProductEquiv D).trans
+    (TrianglePeriodFamilyHomologyFreeCoordinates.integerFreeCoordinateEquiv 5)
+
+attribute [local instance] TrianglePeriodFamilyHomologyAlgebra.cokernelQuotientModule
+    TrianglePeriodFamilyHomologyAlgebra.kernelModule in
+private def PeriodFamily.Homology.familyH5Equiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    SingularMayerVietoris.SingularHomology D.Space 5 ≃ₗ[ℤ] (Fin 2 → ℤ) :=
+  (familyH5ProductEquiv D).trans (LinearEquiv.finTwoArrow ℤ ℤ).symm
+
+private theorem PeriodFamily.Homology.familyFibreInclusion_zero_surjective
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (b : SlitBaseLift) :
+    Function.Surjective
+      (SingularMayerVietoris.singularHomologyMap (familyFibreInclusion D b) 0) := by
+  intro a
+  have ha : a ∈ LinearMap.range (familyRightHomologyMap D 0) :=
+    familyRightHomologyMap_zero_surjective D a
+  rw [familyRightHomologyMap_range_eq_fibre D b 0] at ha
+  exact ha
+
+private theorem PeriodFamily.Homology.familyFibreInclusion_zero_injective
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    Function.Injective
+      (SingularMayerVietoris.singularHomologyMap (familyFibreInclusion D normalizedSlitBaseLift)
+        0) := by
+  apply LinearMap.ker_eq_bot.mp
+  rw [familyFibreInclusion_kernel, sourceDifference_zero, LinearMap.range_zero]
+
+private def PeriodFamily.Homology.familyFibreHomologyZeroEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    SingularMayerVietoris.SingularHomology RealTorus₄ 0 ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology D.Space 0 :=
+  LinearEquiv.ofBijective
+    (SingularMayerVietoris.singularHomologyMap (familyFibreInclusion D normalizedSlitBaseLift) 0)
+    ⟨familyFibreInclusion_zero_injective D,
+      familyFibreInclusion_zero_surjective D normalizedSlitBaseLift⟩
+
+private def PeriodFamily.Homology.familyH0Equiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    SingularMayerVietoris.SingularHomology D.Space 0 ≃ₗ[ℤ] ℤ :=
+  (familyFibreHomologyZeroEquiv D).symm.trans
+    (PeriodTorusHigherHomology.connectedHomologyZeroEquiv RealTorus₄)
+
+private theorem PeriodFamily.Homology.family_homology_subsingleton_of_lt
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) {n : ℕ} (hn : 5 < n) :
+    Subsingleton (SingularMayerVietoris.SingularHomology D.Space n) := by
+  cases n with
+  | zero => omega
+  | succ
+    m =>
+    let := PeriodTorusHigherHomology.realTorus_homology_subsingleton_of_lt (n := m) (by omega)
+    let := PeriodTorusHigherHomology.realTorus_homology_subsingleton_of_lt (n := m + 1) (by omega)
+    have hz (x : SingularMayerVietoris.SingularHomology D.Space (m + 1)) : x = 0 := by
+      obtain ⟨q, hq⟩ :=
+        (sourceCoinvariantInclusion_kernelProjection_exact D m x).mp (Subsingleton.elim _ _)
+      have hq0 : q = 0 := Subsingleton.elim _ _
+      simpa only [hq0, map_zero] using hq.symm
+    exact ⟨fun x y => (hz x).trans (hz y).symm⟩
+
+private theorem PeriodFamily.Homology.family_homology_isZero_of_lt
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) {n : ℕ} (hn : 5 < n) :
+    CategoryTheory.Limits.IsZero (SingularMayerVietoris.SingularHomology D.Space n) := by
+  let := family_homology_subsingleton_of_lt D hn
+  exact ModuleCat.isZero_of_subsingleton _
+
+private def PeriodFamily.Homology.familyBetti : ℕ → ℕ
+  | 0 => 1
+  | 1 => 3
+  | 2 => 6
+  | 3 => 8
+  | 4 => 6
+  | 5 => 2
+  | _ + 6 => 0
+
+private def PeriodFamily.Homology.familyHomologyEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    (n : ℕ) → SingularMayerVietoris.SingularHomology D.Space n ≃ₗ[ℤ] (Fin (familyBetti n) → ℤ)
+  | 0 => (familyH0Equiv D).trans (LinearEquiv.funUnique (Fin 1) ℤ ℤ).symm
+  | 1 => familyH1Equiv D
+  | 2 => familyH2Equiv D
+  | 3 => familyH3Equiv D
+  | 4 => familyH4Equiv D
+  | 5 => familyH5Equiv D
+  | n + 6 =>
+    by
+    change SingularMayerVietoris.SingularHomology D.Space (n + 6) ≃ₗ[ℤ] (Fin 0 → ℤ)
+    letI := family_homology_subsingleton_of_lt D (n := n + 6) (by omega)
+    exact LinearEquiv.ofSubsingleton _ _
+
+private theorem PeriodFamily.Homology.family_homology_free
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    Module.Free ℤ (SingularMayerVietoris.SingularHomology D.Space n) :=
+  Module.Free.of_equiv (familyHomologyEquiv D n).symm
+
+private theorem PeriodFamily.Homology.family_homology_finite
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    Module.Finite ℤ (SingularMayerVietoris.SingularHomology D.Space n) :=
+  Module.Finite.of_surjective (familyHomologyEquiv D n).symm.toLinearMap
+    (familyHomologyEquiv D n).symm.surjective
+
+private theorem PeriodFamily.Homology.family_homology_finrank
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    Module.finrank ℤ (SingularMayerVietoris.SingularHomology D.Space n) = familyBetti n := by
+  rw [(familyHomologyEquiv D n).finrank_eq]
+  simp
+
+private abbrev PeriodFamily.Canonical.Model :=
+  ℂ × ComplexPlane₂
+
+private abbrev PeriodFamily.Canonical.Atlas.tangentCore (M : Type*) [TopologicalSpace M]
+    [ChartedSpace PeriodFamily.Canonical.Model M]
+    [IsManifold (modelWithCornersSelf ℂ PeriodFamily.Canonical.Model) ω M] :
+    VectorBundleCore ℂ M PeriodFamily.Canonical.Model (atlas PeriodFamily.Canonical.Model M) :=
+  tangentBundleCore (modelWithCornersSelf ℂ PeriodFamily.Canonical.Model) M
+
+
+private theorem PeriodFamily.dualComplexMatrix_fixes_delta (g : SpecialPeriods.TriangleGroup) :
+    dualComplexMatrix g *ᵥ ![0, 0, 0, 1] = (![0, 0, 0, 1] : Fin 4 → ℂ) := by
+  have hg :
+    g ∈
+      Subgroup.closure
+        ({ SpecialPeriods.triangleGenerator₁, SpecialPeriods.triangleGenerator₂ } :
+          Set SpecialPeriods.TriangleGroup) := by
+    rw [SpecialPeriods.triangle_generators_generate]
+    trivial
+  induction hg using Subgroup.closure_induction with
+  | mem h hh =>
+    rcases hh with rfl | rfl
+    · rw [dualComplexMatrix_generator₁]
+      ext i
+      fin_cases i <;>
+        norm_num [A₁, Matrix.mulVec, dotProduct, Fin.sum_univ_four, Matrix.cons_val_two,
+          Matrix.cons_val_three]
+    · rw [dualComplexMatrix_generator₂]
+      ext i
+      fin_cases i <;>
+        norm_num [A₂, Matrix.mulVec, dotProduct, Fin.sum_univ_four, Matrix.cons_val_two,
+          Matrix.cons_val_three]
+  | one => rw [dualComplexMatrix_one, Matrix.one_mulVec]
+  | mul g h _ _ ihg ihh => rw [dualComplexMatrix_mul, ← Matrix.mulVec_mulVec, ihh, ihg]
+  | inv g _
+    ih =>
+    have he := congrArg (fun v : Fin 4 → ℂ => dualComplexMatrix g⁻¹ *ᵥ v) ih
+    rw [Matrix.mulVec_mulVec, ← dualComplexMatrix_mul, inv_mul_cancel, dualComplexMatrix_one,
+      Matrix.one_mulVec] at he
+    exact he.symm
+
+private theorem
+    PeriodFamily.dualComplexMatrix_lastColumn (g : SpecialPeriods.TriangleGroup) (i : Fin 4) :
+    dualComplexMatrix g i 3 = (![0, 0, 0, 1] : Fin 4 → ℂ) i := by
+  have h := congrFun (dualComplexMatrix_fixes_delta g) i
+  simpa [Matrix.mulVec, dotProduct, Fin.sum_univ_four] using h
+
+private theorem PeriodFamily.Data.rightBlock_secondColumn {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (g : SpecialPeriods.TriangleGroup) (b : B) :
+    (fun i => D.rightBlock g b i 1) = (![0, 1] : Fin 2 → ℂ) := by
+  ext i
+  fin_cases i <;>
+    simp [rightBlock, Matrix.mul_apply, Fin.sum_univ_four,
+      PeriodFamily.dualComplexMatrix_lastColumn, PeriodPoint.matrix]
+
+@[simp]
+private theorem PeriodFamily.Data.rightBlock_zero_one {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (g : SpecialPeriods.TriangleGroup) (b : B) : D.rightBlock g b 0 1 = 0 :=
+  congrFun (D.rightBlock_secondColumn g b) 0
+
+@[simp]
+private theorem PeriodFamily.Data.rightBlock_one_one {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (g : SpecialPeriods.TriangleGroup) (b : B) : D.rightBlock g b 1 1 = 1 :=
+  congrFun (D.rightBlock_secondColumn g b) 1
+
+private theorem PeriodFamily.Data.rightBlock_fixes_second {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (g : SpecialPeriods.TriangleGroup) (b : B) :
+    D.rightBlock g b *ᵥ ![0, 1] = (![0, 1] : Fin 2 → ℂ) := by
+  ext i
+  fin_cases i <;> simp [Matrix.mulVec, dotProduct, Fin.sum_univ_two]
+
+private abbrev PeriodFamily.Canonical.specialRegularData :
+    PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint :=
+  PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+
+private abbrev PeriodFamily.Canonical.SpecialRegularFamily :=
+  specialRegularData.Space
+
+private theorem PeriodFamily.Canonical.specialRegularHomology_free (n : ℕ) :
+    Module.Free ℤ (SingularMayerVietoris.SingularHomology SpecialRegularFamily n) :=
+  PeriodFamily.Homology.family_homology_free specialRegularData n
+
+private theorem PeriodFamily.Canonical.specialRegularHomology_finite (n : ℕ) :
+    Module.Finite ℤ (SingularMayerVietoris.SingularHomology SpecialRegularFamily n) :=
+  PeriodFamily.Homology.family_homology_finite specialRegularData n
+
+private theorem PeriodFamily.Canonical.specialRegularHomology_finrank (n : ℕ) :
+    Module.finrank ℤ (SingularMayerVietoris.SingularHomology SpecialRegularFamily n) =
+      PeriodFamily.Homology.familyBetti n :=
+  PeriodFamily.Homology.family_homology_finrank specialRegularData n
+
+private theorem PeriodFamily.Canonical.specialRegularHomology_isZero_of_lt {n : ℕ} (hn : 5 < n) :
+    CategoryTheory.Limits.IsZero
+      (SingularMayerVietoris.SingularHomology SpecialRegularFamily n) :=
+  PeriodFamily.Homology.family_homology_isZero_of_lt specialRegularData hn
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Data.zeroSectionPath {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] [MulAction SpecialPeriods.TriangleGroup B]
+    (D : PeriodFamily.Data V B) {b₀ b₁ : B} (p : Path b₀ b₁) :
+    Path (D.fundamentalGroupBasepoint b₀) (D.fundamentalGroupBasepoint b₁) :=
+  DiagonalQuotient.fibreBasepointPath (G := SpecialPeriods.TriangleGroup) (0 : RealTorus₄) p
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Data.flatFibreFundamentalGroupHom_baseChange {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) {b₀ b₁ : B}
+    (p : Path b₀ b₁) (v : FundamentalGroup RealTorus₄ 0) :
+    FundamentalGroup.fundamentalGroupMulEquivOfPath (D.zeroSectionPath p)
+        (D.flatFibreFundamentalGroupHom b₀ v) =
+      D.flatFibreFundamentalGroupHom b₁ v :=
+  DiagonalQuotient.fibreFundamentalGroupHom_baseChange (G := SpecialPeriods.TriangleGroup)
+    (0 : RealTorus₄) p v
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Data.latticeFundamentalGroupHom_baseChange {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) {b₀ b₁ : B}
+    (p : Path b₀ b₁) (v : Multiplicative Lattice) :
+    FundamentalGroup.fundamentalGroupMulEquivOfPath (D.zeroSectionPath p)
+        (D.latticeFundamentalGroupHom b₀ v) =
+      D.latticeFundamentalGroupHom b₁ v :=
+  D.flatFibreFundamentalGroupHom_baseChange p
+    (PeriodFamily.FlatTorus.fundamentalGroupEquiv.symm v)
+
+private def PeriodDomain.fullPeriodCoordinatesEquiv : Lattice ≃ₗ[ℤ] FullPeriodMatrix.IntegerPeriods
+    where
+  toFun c := (![c 2, c 3], ![c 0, c 1])
+  invFun c := ![c.2 0, c.2 1, c.1 0, c.1 1]
+  left_inv c := by ext i; fin_cases i <;> rfl
+  right_inv c := by ext i <;> fin_cases i <;> rfl
+  map_add' c d := by ext i <;> fin_cases i <;> rfl
+  map_smul' n c := by ext i <;> fin_cases i <;> rfl
+
+private theorem PeriodDomain.fullPeriod_periodVector (p : PeriodDomain) (q : FullPeriodMatrix)
+    (h : q.matrix = p.val.leftBlock) (c : Lattice) :
+    q.periodVector (fullPeriodCoordinatesEquiv c) = p.periodVector c := by
+  ext i
+  fin_cases i <;>
+      simp [FullPeriodMatrix.periodVector, periodVector, fullPeriodCoordinatesEquiv, h,
+        PeriodPoint.leftBlock, PeriodPoint.matrix, dotProduct, Fin.sum_univ_succ, Matrix.vecHead,
+        Matrix.vecTail] <;>
+    ring
+
+private def PeriodFamily.Boundary.realCurveLift (c : C(ℝ, SpecialPeriods.TriangleRegularQuotient))
+    (z : SpecialPeriods.TriangleRegularPoint)
+    (hz : SpecialPeriods.triangleRegularProject z = c 0) :
+    C(ℝ, SpecialPeriods.TriangleRegularPoint) :=
+  (SpecialPeriods.triangleRegularProject_covering.isCoveringMap.existsUnique_continuousMap_lifts c
+      0 z hz).choose
+
+@[simp]
+private theorem PeriodFamily.Boundary.realCurveLift_zero
+    (c : C(ℝ, SpecialPeriods.TriangleRegularQuotient)) (z : SpecialPeriods.TriangleRegularPoint)
+    (hz : SpecialPeriods.triangleRegularProject z = c 0) : realCurveLift c z hz 0 = z :=
+  (SpecialPeriods.triangleRegularProject_covering.isCoveringMap.existsUnique_continuousMap_lifts c
+          0 z hz).choose_spec.1.1
+
+@[simp]
+private theorem PeriodFamily.Boundary.realCurveLift_projection
+    (c : C(ℝ, SpecialPeriods.TriangleRegularQuotient)) (z : SpecialPeriods.TriangleRegularPoint)
+    (hz : SpecialPeriods.triangleRegularProject z = c 0) (t : ℝ) :
+    SpecialPeriods.triangleRegularProject (realCurveLift c z hz t) = c t :=
+  congr_fun
+    (SpecialPeriods.triangleRegularProject_covering.isCoveringMap.existsUnique_continuousMap_lifts
+            c 0 z hz).choose_spec.1.2
+    t
+
+private theorem PeriodFamily.Boundary.realCurveLift_unique
+    (c : C(ℝ, SpecialPeriods.TriangleRegularQuotient)) (z : SpecialPeriods.TriangleRegularPoint)
+    (hz : SpecialPeriods.triangleRegularProject z = c 0)
+    (L : C(ℝ, SpecialPeriods.TriangleRegularPoint))
+    (hL : ∀ t, SpecialPeriods.triangleRegularProject (L t) = c t) (hzero : L 0 = z) :
+    L = realCurveLift c z hz := by
+  apply ContinuousMap.ext
+  exact
+    congr_fun
+      (SpecialPeriods.triangleRegularProject_covering.isCoveringMap.eq_of_comp_eq L.continuous
+        (realCurveLift c z hz).continuous
+        (by funext t; simp only [Function.comp_apply, hL, realCurveLift_projection]) 0
+        (hzero.trans (realCurveLift_zero c z hz).symm))
+
+private theorem PeriodFamily.Boundary.realCurveLift_translate_one
+    (c : C(ℝ, SpecialPeriods.TriangleRegularQuotient)) (z : SpecialPeriods.TriangleRegularPoint)
+    (hz : SpecialPeriods.triangleRegularProject z = c 0) (hperiod : ∀ t : ℝ, c (t + 1) = c t)
+    (g : SpecialPeriods.TriangleGroup) (hend : realCurveLift c z hz 1 = g⁻¹ • z) (t : ℝ) :
+    realCurveLift c z hz (t + 1) = g⁻¹ • realCurveLift c z hz t := by
+  have hleft : Continuous (fun t : ℝ => realCurveLift c z hz (t + 1)) :=
+    (realCurveLift c z hz).continuous.comp (continuous_id.add continuous_const)
+  have hright : Continuous (fun t : ℝ => g⁻¹ • realCurveLift c z hz t) :=
+    (ContinuousConstSMul.continuous_const_smul g⁻¹).comp (realCurveLift c z hz).continuous
+  have he :
+    SpecialPeriods.triangleRegularProject ∘ (fun t : ℝ => realCurveLift c z hz (t + 1)) =
+      SpecialPeriods.triangleRegularProject ∘ (fun t : ℝ => g⁻¹ • realCurveLift c z hz t) := by
+    funext t
+    simp only [Function.comp_apply, realCurveLift_projection,
+      SpecialPeriods.triangleRegularProject_covering.map_smul, hperiod]
+  exact
+    congr_fun
+      (SpecialPeriods.triangleRegularProject_covering.isCoveringMap.eq_of_comp_eq hleft hright he
+        0 (by simpa only [zero_add, realCurveLift_zero] using hend))
+      t
+
+private theorem PeriodFamily.Boundary.realCurve_integer_translate
+    (L : ℝ → SpecialPeriods.TriangleRegularPoint) (g : SpecialPeriods.TriangleGroup)
+    (hstep : ∀ t : ℝ, L (t + 1) = g⁻¹ • L t) (k : ℤ) (t : ℝ) : L (t + k) = (g ^ (-k)) • L t := by
+  have hprev (s : ℝ) : L (s - 1) = g • L s := by
+    have h := congrArg (fun y : SpecialPeriods.TriangleRegularPoint => g • y) (hstep (s - 1))
+    simpa only [sub_add_cancel, smul_inv_smul] using h.symm
+  have hall : ∀ k : ℤ, ∀ t : ℝ, L (t + k) = (g ^ (-k)) • L t := by
+    intro k
+    induction k using Int.induction_on with
+    | zero => intro t; simp
+    | succ k ih =>
+      intro t
+      rw [Int.cast_add, Int.cast_one, ← add_assoc, hstep, ih]
+      rw [show -((k : ℤ) + 1) = -1 + -(k : ℤ) by omega, zpow_add, zpow_neg_one,
+        SemigroupAction.mul_smul]
+    | pred k ih =>
+      intro t
+      rw [Int.cast_sub, Int.cast_one, ← add_sub_assoc, hprev, ih]
+      rw [show -(-(k : ℤ) - 1) = 1 + -(-(k : ℤ)) by omega, zpow_add, zpow_one,
+        SemigroupAction.mul_smul]
+  exact hall k t
+
+private theorem PeriodFamily.Boundary.realCurveLift_translate
+    (c : C(ℝ, SpecialPeriods.TriangleRegularQuotient)) (z : SpecialPeriods.TriangleRegularPoint)
+    (hz : SpecialPeriods.triangleRegularProject z = c 0) (hperiod : ∀ t : ℝ, c (t + 1) = c t)
+    (g : SpecialPeriods.TriangleGroup) (hend : realCurveLift c z hz 1 = g⁻¹ • z) (k : ℤ) (t : ℝ) :
+    realCurveLift c z hz (t + k) = (g ^ (-k)) • realCurveLift c z hz t :=
+  realCurve_integer_translate (realCurveLift c z hz) g
+    (realCurveLift_translate_one c z hz hperiod g hend) k t
+
+private def PeriodFamily.Boundary.realCurveLoop (c : C(ℝ, SpecialPeriods.TriangleRegularQuotient))
+    (hperiod : ∀ t : ℝ, c (t + 1) = c t) : Path (c 0) (c 0)
+    where
+  toFun t := c t
+  continuous_toFun := c.continuous.comp continuous_subtype_val
+  source' := rfl
+  target' := by
+    change c (1 : ℝ) = c 0
+    simpa only [zero_add] using hperiod 0
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def PeriodFamily.Boundary.Cusp.reciprocalCoordinate : ℂ → ℂ :=
+  SpecialPeriods.MuTorsor.CuspCoordinates.t SpecialPeriods.Triangle.triangleSphereUniformization
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem PeriodFamily.Boundary.Cusp.reciprocalCoordinate_zero : reciprocalCoordinate 0 = 0 :=
+  SpecialPeriods.MuTorsor.CuspCoordinates.t_zero
+    SpecialPeriods.Triangle.triangleSphereUniformization
+    SpecialPeriods.Triangle.triangleSphereUniformization_cusp
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem PeriodFamily.Boundary.Cusp.reciprocalCoordinate_analytic :
+    AnalyticAt ℂ reciprocalCoordinate 0 :=
+  SpecialPeriods.MuTorsor.CuspCoordinates.t_analyticAt_zero
+    SpecialPeriods.Triangle.triangleSphereUniformization
+    SpecialPeriods.Triangle.triangleSphereUniformization_cusp
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem PeriodFamily.Boundary.Cusp.reciprocalCoordinate_derivative :
+    deriv reciprocalCoordinate 0 ≠ 0 :=
+  SpecialPeriods.TriangleSource.reciprocalCusp_deriv_ne_zero
+    SpecialPeriods.Triangle.triangleSphereUniformization
+    SpecialPeriods.Triangle.triangleSphereUniformization_cusp
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def PeriodFamily.Boundary.Cusp.reciprocalControl :
+    SpecialPeriods.EllipticAttachingMeridians.LinearizationControl reciprocalCoordinate :=
+  SpecialPeriods.EllipticAttachingMeridians.analyticLinearizationControl
+    reciprocalCoordinate_analytic reciprocalCoordinate_derivative
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def PeriodFamily.Boundary.Cusp.controlledHeight :
+    ThreefoldOverlapMappingTorus.Cusp.Height
+      ThreefoldOverlapMappingTorus.Cusp.specialData.radius :=
+  ⟨Max.max
+        (ThreefoldOverlapMappingTorus.Cusp.heightThreshold
+          ThreefoldOverlapMappingTorus.Cusp.specialData.radius)
+        (ThreefoldOverlapMappingTorus.Cusp.heightThreshold reciprocalControl.radius) +
+      1,
+    by
+    change
+      ThreefoldOverlapMappingTorus.Cusp.heightThreshold
+          ThreefoldOverlapMappingTorus.Cusp.specialData.radius <
+        Max.max
+            (ThreefoldOverlapMappingTorus.Cusp.heightThreshold
+              ThreefoldOverlapMappingTorus.Cusp.specialData.radius)
+            (ThreefoldOverlapMappingTorus.Cusp.heightThreshold reciprocalControl.radius) +
+          1
+    exact lt_of_le_of_lt (le_max_left _ _) (lt_add_one _)⟩
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def PeriodFamily.Boundary.Cusp.parameter
+    (h :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius) :
+    ℂ :=
+  CuspUniformization.exponential
+    (ThreefoldOverlapMappingTorus.Cusp.logPoint
+      ThreefoldOverlapMappingTorus.Cusp.specialData.radius
+      ThreefoldOverlapMappingTorus.Cusp.specialData.radius_pos 0 h)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem PeriodFamily.Boundary.Cusp.parameter_ne_zero
+    (h :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius) :
+    parameter h ≠ 0 :=
+  CuspUniformization.exponential_ne_zero _
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem PeriodFamily.Boundary.Cusp.parameter_controlled :
+    ‖parameter controlledHeight‖ < reciprocalControl.radius := by
+  apply (SpecialPeriods.CuspFamily.mem_logBase reciprocalControl.radius _).mp
+  rw [ThreefoldOverlapMappingTorus.Cusp.mem_logBase_iff_height reciprocalControl.radius
+      reciprocalControl.radius_pos,
+    ThreefoldOverlapMappingTorus.Cusp.logPoint_im]
+  change
+    ThreefoldOverlapMappingTorus.Cusp.heightThreshold reciprocalControl.radius <
+      Max.max
+          (ThreefoldOverlapMappingTorus.Cusp.heightThreshold
+            ThreefoldOverlapMappingTorus.Cusp.specialData.radius)
+          (ThreefoldOverlapMappingTorus.Cusp.heightThreshold reciprocalControl.radius) +
+        1
+  exact lt_of_le_of_lt (le_max_right _ _) (lt_add_one _)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def PeriodFamily.Boundary.Cusp.baseLift
+    (h :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius) :
+    C(ℝ, SpecialPeriods.TriangleRegularPoint) :=
+  ⟨fun t =>
+    SpecialPeriods.CuspFamily.logBaseToRegular
+      ThreefoldOverlapMappingTorus.Cusp.specialData.radius
+      ThreefoldOverlapMappingTorus.Cusp.specialRadius_cap
+      (ThreefoldOverlapMappingTorus.Cusp.logPoint
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius_pos t h),
+    (SpecialPeriods.CuspFamily.logBaseToRegular_holomorphic
+          ThreefoldOverlapMappingTorus.Cusp.specialData.radius
+          ThreefoldOverlapMappingTorus.Cusp.specialRadius_cap).continuous.comp
+      ((ThreefoldOverlapMappingTorus.Cusp.logBaseHeightHomeomorph
+            ThreefoldOverlapMappingTorus.Cusp.specialData.radius
+            ThreefoldOverlapMappingTorus.Cusp.specialData.radius_pos).symm.continuous.comp
+        (continuous_const.prodMk continuous_id))⟩
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem PeriodFamily.Boundary.Cusp.baseLift_translate
+    (h :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius)
+    (k : ℤ) (t : ℝ) :
+    baseLift h (t + k) = (SpecialPeriods.triangleCuspGenerator ^ (-k)) • baseLift h t := by
+  have he :=
+    SpecialPeriods.CuspFamily.logBaseToRegular_translate
+      ThreefoldOverlapMappingTorus.Cusp.specialData.radius
+      ThreefoldOverlapMappingTorus.Cusp.specialRadius_cap (-k)
+      (ThreefoldOverlapMappingTorus.Cusp.logPoint
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius_pos t h)
+  rw [ThreefoldOverlapMappingTorus.Cusp.logPoint_translate] at he
+  simpa only [baseLift, ContinuousMap.coe_mk, Int.cast_neg, sub_neg_eq_add] using he
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem PeriodFamily.Boundary.Cusp.baseLift_projection_periodic
+    (h :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius) :
+    Function.Periodic (fun t : ℝ => SpecialPeriods.triangleRegularProject (baseLift h t)) 1 := by
+  intro t
+  have he := congrArg SpecialPeriods.triangleRegularProject (baseLift_translate h 1 t)
+  simpa only [Int.cast_one, SpecialPeriods.triangleRegularProject_covering.map_smul] using he
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem PeriodFamily.Boundary.Cusp.baseLift_mem_horodisc
+    (h :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius)
+    (t : ℝ) :
+    (baseLift h t : UpperHalfPlane) ∈
+      SpecialPeriods.Triangle.horodisc SpecialPeriods.Triangle.width :=
+  SpecialPeriods.CuspFamily.logBaseToRegular_mem_horodisc
+    ThreefoldOverlapMappingTorus.Cusp.specialData.radius
+    ThreefoldOverlapMappingTorus.Cusp.specialRadius_cap _
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem PeriodFamily.Boundary.Cusp.baseLift_cuspQ
+    (h :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius)
+    (t : ℝ) :
+    SpecialPeriods.Triangle.cuspQ (baseLift h t : UpperHalfPlane) =
+      CuspUniformization.exponential
+        (ThreefoldOverlapMappingTorus.Cusp.logPoint
+          ThreefoldOverlapMappingTorus.Cusp.specialData.radius
+          ThreefoldOverlapMappingTorus.Cusp.specialData.radius_pos t h) :=
+  SpecialPeriods.CuspFamily.logBaseToRegular_cuspQ
+    ThreefoldOverlapMappingTorus.Cusp.specialData.radius
+    ThreefoldOverlapMappingTorus.Cusp.specialRadius_cap _
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem PeriodFamily.Boundary.Cusp.boundaryToRegularFamily_mk (t : ℝ) (x : RealTorus₄) :
+    ThreefoldOverlapMappingTorus.boundaryToRegularFamily Option.none
+        (MappingTorus.mk ThreefoldOverlapMappingTorus.Cusp.monodromy (t, x)) =
+      ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData.quotient
+        (baseLift ThreefoldOverlapMappingTorus.Cusp.specialHeight t, x) :=
+  ThreefoldOverlapMappingTorus.Cusp.boundaryToRegularFamily_cusp_mk t x
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace in
+private theorem PeriodFamily.Boundary.Cusp.finiteProjection_eq_plane (z : UpperHalfPlane) :
+    SpecialPeriods.BetaTorsor.finiteProjection
+        SpecialPeriods.Triangle.triangleSphereUniformization z =
+      SpecialPeriods.Triangle.trianglePlaneUniformizationHomeomorph
+        (SpecialPeriods.triangleOrbitProjection z) := by
+  rw [SpecialPeriods.BetaTorsor.finiteProjection, SpecialPeriods.BetaTorsor.finiteOrbitCoordinate,
+    SpecialPeriods.Triangle.triangleSphereUniformization_openInclusion,
+    SpecialPeriods.BetaTorsor.sphereFiniteCoordinate_coe]
+  exact
+    congrArg
+      (fun e : SpecialPeriods.TriangleOrbitSpace ≃ₜ ℂ =>
+        e (SpecialPeriods.triangleOrbitProjection z))
+      SpecialPeriods.Triangle.trianglePlaneUniformization_toHomeomorph
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace in
+private theorem PeriodFamily.Boundary.Cusp.regularCoordinate_eq_finiteProjection
+    (z : SpecialPeriods.TriangleRegularPoint) :
+    (SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+          (SpecialPeriods.triangleRegularProject z) :
+        ℂ) =
+      SpecialPeriods.BetaTorsor.finiteProjection
+        SpecialPeriods.Triangle.triangleSphereUniformization z.val := by
+  rw [SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph_project, finiteProjection_eq_plane]
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace in
+private theorem PeriodFamily.Boundary.Cusp.reciprocalCoordinate_baseLift
+    (h :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius)
+    (t : ℝ) :
+    reciprocalCoordinate
+        (CuspUniformization.exponential
+          (ThreefoldOverlapMappingTorus.Cusp.logPoint
+            ThreefoldOverlapMappingTorus.Cusp.specialData.radius
+            ThreefoldOverlapMappingTorus.Cusp.specialData.radius_pos t h)) =
+      ((SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+            (SpecialPeriods.triangleRegularProject (baseLift h t)) :
+          ℂ))⁻¹ := by
+  have hp :
+    SpecialPeriods.BetaTorsor.finiteProjection
+        SpecialPeriods.Triangle.triangleSphereUniformization (baseLift h t).val ≠
+      0 := by
+    rw [← regularCoordinate_eq_finiteProjection]
+    exact
+      (SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+            (SpecialPeriods.triangleRegularProject (baseLift h t))).property.1
+  have he :=
+    SpecialPeriods.MuTorsor.CuspCoordinates.t_cuspQ_eq_inv_finiteProjection_of_mem
+      SpecialPeriods.Triangle.triangleSphereUniformization
+      SpecialPeriods.Triangle.triangleSphereUniformization_cusp (baseLift h t).val
+      (baseLift_mem_horodisc h t) hp
+  rw [baseLift_cuspQ] at he
+  rw [regularCoordinate_eq_finiteProjection]
+  exact he
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace in
+private theorem PeriodFamily.Boundary.Cusp.clockwiseUnit_symm_exponential (t : unitInterval) :
+    SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit (unitInterval.symm t) =
+      CuspUniformization.exponential (((t : ℝ) : ℂ) - 1) := by
+  unfold SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit CuspUniformization.exponential
+  rw [unitInterval.coe_symm_eq]
+  congr 1
+  push_cast
+  ring
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace in
+private theorem PeriodFamily.Boundary.Cusp.parameter_positive
+    (h :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius)
+    (t : unitInterval) :
+    CuspUniformization.exponential
+        (ThreefoldOverlapMappingTorus.Cusp.logPoint
+          ThreefoldOverlapMappingTorus.Cusp.specialData.radius
+          ThreefoldOverlapMappingTorus.Cusp.specialData.radius_pos (t : ℝ) h) =
+      parameter h *
+        SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit (unitInterval.symm t) := by
+  rw [clockwiseUnit_symm_exponential, parameter, ← CuspUniformization.exponential_add]
+  apply (CuspUniformization.exponential_eq_iff _ _).mpr
+  refine ⟨1, ?_⟩
+  change
+    ((t : ℝ) : ℂ) + (h : ℝ) * Complex.I =
+      ((0 : ℝ) : ℂ) + (h : ℝ) * Complex.I + (((t : ℝ) : ℂ) - 1) + ((1 : ℤ) : ℂ)
+  push_cast
+  ring
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace in
+private def PeriodFamily.Boundary.Cusp.projectedCurve
+    (h :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius) :
+    C(ℝ, SpecialPeriods.TriangleRegularQuotient) :=
+  ⟨fun t => SpecialPeriods.triangleRegularProject (baseLift h t),
+    SpecialPeriods.triangleRegularProject_covering.continuous.comp (baseLift h).continuous⟩
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace in
+private def PeriodFamily.Boundary.Cusp.nativeLoop
+    (h :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius) :
+    Path (projectedCurve h 0) (projectedCurve h 0) :=
+  PeriodFamily.Boundary.realCurveLoop (projectedCurve h) (baseLift_projection_periodic h)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace in
+private theorem PeriodFamily.Boundary.Cusp.nativeLoop_coordinate
+    (h :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius)
+    (t : unitInterval) :
+    (SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph (nativeLoop h t) : ℂ) =
+      (reciprocalCoordinate
+          (parameter h *
+            SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit (unitInterval.symm t)))⁻¹ := by
+  change
+    (SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+          (SpecialPeriods.triangleRegularProject (baseLift h (t : ℝ))) :
+        ℂ) =
+      _
+  rw [← parameter_positive, reciprocalCoordinate_baseLift, inv_inv]
+
+private def PeriodFamily.Boundary.Cusp.planeInverse :
+    SpecialPeriods.Triangle.TwicePuncturedPlane ≃ₜ SpecialPeriods.Triangle.TwicePuncturedPlane
+    where
+  toFun z := ⟨(z : ℂ)⁻¹, inv_ne_zero z.property.1, fun h => z.property.2 (inv_eq_one.mp h)⟩
+  invFun z := ⟨(z : ℂ)⁻¹, inv_ne_zero z.property.1, fun h => z.property.2 (inv_eq_one.mp h)⟩
+  left_inv z := Subtype.ext (inv_inv (z : ℂ))
+  right_inv z := Subtype.ext (inv_inv (z : ℂ))
+  continuous_toFun :=
+    (continuous_subtype_val.inv₀
+          (fun z : SpecialPeriods.Triangle.TwicePuncturedPlane => z.property.1)).subtype_mk
+      _
+  continuous_invFun :=
+    (continuous_subtype_val.inv₀
+          (fun z : SpecialPeriods.Triangle.TwicePuncturedPlane => z.property.1)).subtype_mk
+      _
+
+private def PeriodFamily.Boundary.Cusp.inverseMeridian :
+    Path (planeInverse SpecialPeriods.Triangle.meridianBasepoint)
+      (planeInverse SpecialPeriods.Triangle.meridianBasepoint) :=
+  ((SpecialPeriods.EllipticAttachingMeridians.fixedClockwiseMeridian Bool.false).symm).map
+    planeInverse.continuous
+
+private theorem PeriodFamily.Boundary.Cusp.inverseMeridian_coe (t : unitInterval) :
+    (inverseMeridian t : ℂ) = 2 * SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit t := by
+  have hp :
+    (SpecialPeriods.EllipticAttachingMeridians.fixedClockwiseMeridian Bool.false).symm =
+      SpecialPeriods.Triangle.positiveMeridianZero := by
+    simp only [SpecialPeriods.EllipticAttachingMeridians.fixedClockwiseMeridian,
+      Bool.false_eq_true, ite_false, Path.symm_symm]
+  change
+    (((SpecialPeriods.EllipticAttachingMeridians.fixedClockwiseMeridian Bool.false).symm t :
+          ℂ))⁻¹ =
+      _
+  rw [hp, SpecialPeriods.Triangle.positiveMeridianZero_apply, mul_inv_rev, ← Complex.exp_neg]
+  norm_num only [inv_div, inv_one, one_mul]
+  unfold SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit
+  rw [show
+      -((2 * Real.pi : ℂ) * Complex.I * ((t : ℝ) : ℂ)) =
+        -(2 * Real.pi : ℂ) * Complex.I * ((t : ℝ) : ℂ)
+      by ring]
+  ring
+
+private def PeriodFamily.Boundary.Cusp.inverseRegularMeridian :
+    Path
+      (SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm
+        (planeInverse SpecialPeriods.Triangle.meridianBasepoint))
+      (SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm
+        (planeInverse SpecialPeriods.Triangle.meridianBasepoint)) :=
+  inverseMeridian.map SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm.continuous
+
+private theorem PeriodFamily.Boundary.Cusp.reciprocalCoordinate_center :
+    reciprocalCoordinate 0 = SpecialPeriods.EllipticAttachingMeridians.center Bool.false :=
+  reciprocalCoordinate_zero
+
+private def PeriodFamily.Boundary.Cusp.nativeReciprocalSquare :
+    SpecialPeriods.EllipticAttachingMeridians.LoopSquare (nativeLoop controlledHeight)
+      inverseRegularMeridian := by
+  let S :=
+    reciprocalControl.analyticMeridianSquare Bool.false reciprocalCoordinate_center
+      (parameter controlledHeight) (parameter_ne_zero controlledHeight) parameter_controlled
+  let rev : C(unitInterval × unitInterval, unitInterval × unitInterval) :=
+    ⟨fun z => (z.1, unitInterval.symm z.2),
+      continuous_fst.prodMk (unitInterval.continuous_symm.comp continuous_snd)⟩
+  refine
+    { map :=
+        (SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm :
+              C(SpecialPeriods.Triangle.TwicePuncturedPlane, _)).comp
+          ((planeInverse :
+                C(SpecialPeriods.Triangle.TwicePuncturedPlane,
+                  SpecialPeriods.Triangle.TwicePuncturedPlane)).comp
+            (S.map.comp rev))
+      initial := ?_
+      final := ?_
+      closed := ?_ }
+  · intro t
+    change
+      SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm
+          (planeInverse (S.map (0, unitInterval.symm t))) =
+        nativeLoop controlledHeight t
+    apply SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.injective
+    rw [Homeomorph.apply_symm_apply]
+    apply Subtype.ext
+    change ((S.map (0, unitInterval.symm t) : ℂ))⁻¹ = _
+    rw [S.initial]
+    exact (nativeLoop_coordinate controlledHeight t).symm
+  · intro t
+    change
+      SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm
+          (planeInverse (S.map (1, unitInterval.symm t))) =
+        inverseRegularMeridian t
+    rw [S.final]
+    rfl
+  · intro s
+    change
+      SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm
+          (planeInverse (S.map (s, unitInterval.symm 0))) =
+        SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm
+          (planeInverse (S.map (s, unitInterval.symm 1)))
+    simp only [unitInterval.symm_zero, unitInterval.symm_one]
+    exact
+      congrArg
+        (fun z => SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm (planeInverse z))
+        (S.closed s).symm
+
+private def PeriodFamily.Boundary.Cusp.outerDeformationCoefficient (s : unitInterval) : ℂ :=
+  2 * Complex.exp ((-(Real.pi : ℂ) / 2 * Complex.I) * ((s : ℝ) : ℂ))
+
+@[simp]
+private theorem PeriodFamily.Boundary.Cusp.outerDeformationCoefficient_zero :
+    outerDeformationCoefficient 0 = 2 := by simp [outerDeformationCoefficient]
+
+@[simp]
+private theorem PeriodFamily.Boundary.Cusp.outerDeformationCoefficient_one :
+    outerDeformationCoefficient 1 = -2 * Complex.I := by
+  simp [outerDeformationCoefficient, Complex.exp_neg_pi_div_two_mul_I]
+
+private theorem PeriodFamily.Boundary.Cusp.outerDeformationCoefficient_norm (s : unitInterval) :
+    ‖outerDeformationCoefficient s‖ = 2 := by simp [outerDeformationCoefficient, Complex.norm_exp]
+
+private def PeriodFamily.Boundary.Cusp.outerDeformation (s t : unitInterval) : ℂ :=
+  (((s : ℝ) / 2 : ℝ) : ℂ) +
+    outerDeformationCoefficient s * SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit t
+
+private theorem PeriodFamily.Boundary.Cusp.outerDeformation_continuous :
+    Continuous (fun p : unitInterval × unitInterval => outerDeformation p.1 p.2) := by
+  unfold outerDeformation outerDeformationCoefficient
+    SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit
+  fun_prop
+
+private theorem PeriodFamily.Boundary.Cusp.outerDeformation_norm (s t : unitInterval) :
+    ‖outerDeformation s t - (((s : ℝ) / 2 : ℝ) : ℂ)‖ = 2 := by
+  simp only [outerDeformation, add_sub_cancel_left, norm_mul, outerDeformationCoefficient_norm,
+    SpecialPeriods.EllipticAttachingMeridians.norm_clockwiseUnit, mul_one]
+
+private theorem PeriodFamily.Boundary.Cusp.outerDeformation_mem (s t : unitInterval) :
+    outerDeformation s t ∈ SpecialPeriods.Triangle.twicePuncturedPlaneDomain := by
+  change outerDeformation s t ≠ 0 ∧ outerDeformation s t ≠ 1
+  have hs0 : 0 ≤ (s : ℝ) / 2 := div_nonneg s.property.1 (by norm_num)
+  have hs1 : 0 ≤ 1 - (s : ℝ) / 2 := by linarith [s.property.2]
+  constructor
+  · intro he
+    have hn := outerDeformation_norm s t
+    rw [he, zero_sub, norm_neg, Complex.norm_real, Real.norm_eq_abs, abs_of_nonneg hs0] at hn
+    linarith [s.property.2]
+  · intro he
+    have hn := outerDeformation_norm s t
+    rw [he,
+      show (1 : ℂ) - (((s : ℝ) / 2 : ℝ) : ℂ) = ((1 - (s : ℝ) / 2 : ℝ) : ℂ) by push_cast; rfl,
+      Complex.norm_real, Real.norm_eq_abs, abs_of_nonneg hs1] at hn
+    linarith [s.property.1]
+
+private theorem PeriodFamily.Boundary.Cusp.outerCircle_symm_coefficient (t : unitInterval) :
+    ((SpecialPeriods.Triangle.outerPositiveCircle 2 (le_refl 2)).symm t : ℂ) =
+      (1 / 2 : ℂ) +
+        (-2 * Complex.I) * SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit t := by
+  change (SpecialPeriods.Triangle.outerPositiveCircle 2 (le_refl 2) (unitInterval.symm t) : ℂ) = _
+  rw [SpecialPeriods.Triangle.outerPositiveCircle_coe, unitInterval.coe_symm_eq]
+  unfold circleMap SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit
+  push_cast
+  rw [show
+      (-(Real.pi : ℂ) / 2 + 2 * Real.pi * (1 - ((t : ℝ) : ℂ))) * Complex.I =
+        (-(Real.pi : ℂ) / 2 * Complex.I + (-(2 * Real.pi : ℂ) * Complex.I * ((t : ℝ) : ℂ))) +
+          2 * Real.pi * Complex.I
+      by ring,
+    Complex.exp_periodic, Complex.exp_add, Complex.exp_neg_pi_div_two_mul_I]
+  ring
+
+private def PeriodFamily.Boundary.Cusp.inverseOuterSquare :
+    SpecialPeriods.EllipticAttachingMeridians.LoopSquare inverseMeridian
+      ((SpecialPeriods.Triangle.outerPositiveCircle 2 (le_refl 2)).symm) := by
+  refine
+    SpecialPeriods.EllipticAttachingMeridians.LoopSquare.ofContinuous
+      (fun p => ⟨outerDeformation p.1 p.2, outerDeformation_mem p.1 p.2⟩)
+      (outerDeformation_continuous.subtype_mk _) ?_ ?_ ?_
+  · intro t
+    apply Subtype.ext
+    change outerDeformation 0 t = (inverseMeridian t : ℂ)
+    rw [inverseMeridian_coe]
+    simp [outerDeformation]
+  · intro t
+    apply Subtype.ext
+    rw [outerCircle_symm_coefficient]
+    simp [outerDeformation]
+  · intro s
+    apply Subtype.ext
+    simp only [outerDeformation, SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit_zero,
+      SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit_one]
+
+private def PeriodFamily.Boundary.Cusp.nativeOuterSquare :
+    SpecialPeriods.EllipticAttachingMeridians.LoopSquare (nativeLoop controlledHeight)
+      (((SpecialPeriods.Triangle.outerPositiveCircle 2 (le_refl 2)).symm).map
+        SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm.continuous) :=
+  nativeReciprocalSquare.trans
+    (inverseOuterSquare.postcompose SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm
+      SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm.continuous)
+
+private abbrev PeriodFamily.BoundaryLoopSquares.LoopCircle :=
+  AddCircle (1 : ℝ)
+
+private abbrev PeriodFamily.BoundaryLoopSquares.LoopInterval :=
+  Set.Icc (0 : ℝ) (0 + 1)
+
+private abbrev PeriodFamily.BoundaryLoopSquares.LoopQuotient :=
+  Quot (AddCircle.EndpointIdent (1 : ℝ) 0)
+
+private def PeriodFamily.BoundaryLoopSquares.loopIntervalHomeomorph : unitInterval ≃ₜ LoopInterval
+    where
+  toFun t := ⟨t.val, by simpa only [LoopInterval, unitInterval, zero_add] using t.property⟩
+  invFun t := ⟨t.val, by simpa only [LoopInterval, unitInterval, zero_add] using t.property⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun :=
+    continuous_subtype_val.subtype_mk
+      (fun t => by simpa only [LoopInterval, unitInterval, zero_add] using t.property)
+  continuous_invFun :=
+    continuous_subtype_val.subtype_mk
+      (fun t => by simpa only [LoopInterval, unitInterval, zero_add] using t.property)
+
+private def PeriodFamily.BoundaryLoopSquares.loopQuotientMap (t : unitInterval) : LoopQuotient :=
+  Quot.mk _ ⟨t.val, by simpa only [LoopInterval, unitInterval, zero_add] using t.property⟩
+
+private theorem PeriodFamily.BoundaryLoopSquares.loopQuotientMap_isQuotientMap :
+    Topology.IsQuotientMap loopQuotientMap :=
+  isQuotientMap_quot_mk.comp loopIntervalHomeomorph.isQuotientMap
+
+private theorem PeriodFamily.BoundaryLoopSquares.loopCircleQuotient_unit (t : unitInterval) :
+    AddCircle.homeoIccQuot (1 : ℝ) 0 ((t : ℝ) : LoopCircle) = loopQuotientMap t := by
+  apply (AddCircle.homeoIccQuot (1 : ℝ) 0).symm.injective
+  rw [Homeomorph.symm_apply_apply]
+  rfl
+
+private theorem PeriodFamily.BoundaryLoopSquares.loopUnitCircle_surjective :
+    Function.Surjective (fun t : unitInterval => ((t : ℝ) : LoopCircle)) := by
+  intro z
+  obtain ⟨t, ht⟩ := loopQuotientMap_isQuotientMap.surjective (AddCircle.homeoIccQuot (1 : ℝ) 0 z)
+  refine ⟨t, (AddCircle.homeoIccQuot (1 : ℝ) 0).injective ?_⟩
+  rw [loopCircleQuotient_unit, ht]
+
+private theorem
+    PeriodFamily.BoundaryLoopSquares.loopCircle_int (k : ℤ) : ((k : ℝ) : LoopCircle) = 0 := by
+  apply (AddCircle.coe_eq_zero_iff (1 : ℝ)).mpr
+  exact ⟨k, by simp [zsmul_eq_mul]⟩
+
+private theorem PeriodFamily.BoundaryLoopSquares.loopCircle_add_int (t : ℝ) (k : ℤ) :
+    ((t + (k : ℝ) : ℝ) : LoopCircle) = (t : LoopCircle) := by
+  rw [AddCircle.coe_add, loopCircle_int, add_zero]
+
+private theorem PeriodFamily.BoundaryLoopSquares.loopCircle_add_one (t : ℝ) :
+    ((t + 1 : ℝ) : LoopCircle) = (t : LoopCircle) :=
+  AddCircle.coe_add_period (1 : ℝ) t
+
+private def PeriodFamily.BoundaryLoopSquares.loopOnQuotient {X : Type*} [TopologicalSpace X] {a : X}
+    (p : Path a a) : C(LoopQuotient, X)
+    where
+  toFun :=
+    Quot.lift
+      (fun u : LoopInterval =>
+        p ⟨u.val, by simpa only [LoopInterval, unitInterval, zero_add] using u.property⟩)
+      (by
+        intro u v h
+        cases h
+        calc
+          _ = p 0 := congrArg p (Subtype.ext rfl)
+          _ = p 1 := (p.source.trans p.target.symm)
+          _ = _ := congrArg p (Subtype.ext (zero_add (1 : ℝ)).symm))
+  continuous_toFun :=
+    continuous_quot_lift _ (p.continuous.comp loopIntervalHomeomorph.symm.continuous)
+
+@[simp]
+private theorem
+    PeriodFamily.BoundaryLoopSquares.loopOnQuotient_unit {X : Type*} [TopologicalSpace X]
+    {a : X} (p : Path a a) (t : unitInterval) : loopOnQuotient p (loopQuotientMap t) = p t :=
+  rfl
+
+private def PeriodFamily.BoundaryLoopSquares.loopOnCircle {X : Type*} [TopologicalSpace X] {a : X}
+    (p : Path a a) : C(LoopCircle, X) :=
+  (loopOnQuotient p).comp (AddCircle.homeoIccQuot (1 : ℝ) 0 : C(LoopCircle, LoopQuotient))
+
+@[simp]
+private theorem PeriodFamily.BoundaryLoopSquares.loopOnCircle_unit {X : Type*} [TopologicalSpace X]
+    {a : X} (p : Path a a) (t : unitInterval) : loopOnCircle p ((t : ℝ) : LoopCircle) = p t := by
+  change loopOnQuotient p (AddCircle.homeoIccQuot (1 : ℝ) 0 ((t : ℝ) : LoopCircle)) = p t
+  rw [loopCircleQuotient_unit, loopOnQuotient_unit]
+
+private def PeriodFamily.BoundaryLoopSquares.loopPeriodic {X : Type*} [TopologicalSpace X] {a : X}
+    (p : Path a a) : C(ℝ, X) :=
+  (loopOnCircle p).comp ⟨fun t : ℝ => (t : LoopCircle), AddCircle.continuous_mk' (1 : ℝ)⟩
+
+@[simp]
+private theorem PeriodFamily.BoundaryLoopSquares.loopPeriodic_apply {X : Type*} [TopologicalSpace X]
+    {a : X} (p : Path a a) (t : ℝ) : loopPeriodic p t = loopOnCircle p (t : LoopCircle) :=
+  rfl
+
+private theorem PeriodFamily.BoundaryLoopSquares.loopPeriodic_unit {X : Type*} [TopologicalSpace X]
+    {a : X} (p : Path a a) (t : unitInterval) : loopPeriodic p (t : ℝ) = p t :=
+  loopOnCircle_unit p t
+
+private theorem
+    PeriodFamily.BoundaryLoopSquares.loopPeriodic_add_one {X : Type*} [TopologicalSpace X]
+    {a : X} (p : Path a a) (t : ℝ) : loopPeriodic p (t + 1) = loopPeriodic p t := by
+  simp only [loopPeriodic_apply, loopCircle_add_one]
+
+private theorem PeriodFamily.BoundaryLoopSquares.loopPeriodic_zero {X : Type*} [TopologicalSpace X]
+    {a : X} (p : Path a a) : loopPeriodic p 0 = a :=
+  (loopPeriodic_unit p 0).trans p.source
+
+private theorem
+    PeriodFamily.BoundaryLoopSquares.loopPeriodic_unique {X : Type*} [TopologicalSpace X]
+    {a : X} {p : Path a a} (f : ℝ → X) (hf : Function.Periodic f 1)
+    (hp : ∀ t : unitInterval, f (t : ℝ) = p t) : f = loopPeriodic p := by
+  have h : hf.lift = (loopOnCircle p : LoopCircle → X) := by
+    funext z
+    obtain ⟨t, rfl⟩ := loopUnitCircle_surjective z
+    rw [Function.Periodic.lift_coe, loopOnCircle_unit]
+    exact hp t
+  funext t
+  exact congrFun h (t : LoopCircle)
+
+private def
+    PeriodFamily.BoundaryLoopSquares.loopSquareQuotient {X : Type*} [TopologicalSpace X] {a b : X}
+    {p : Path a a} {q : Path b b} (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q)
+    (z : unitInterval × LoopQuotient) : X :=
+  Quot.lift
+    (fun u : LoopInterval =>
+      S.map (z.1, ⟨u.val, by simpa only [LoopInterval, unitInterval, zero_add] using u.property⟩))
+    (by
+      intro u v h
+      cases h
+      calc
+        _ = S.map (z.1, 0) := congrArg (fun t => S.map (z.1, t)) (Subtype.ext rfl)
+        _ = S.map (z.1, 1) := (S.closed z.1)
+        _ = _ := congrArg (fun t => S.map (z.1, t)) (Subtype.ext (zero_add (1 : ℝ)).symm))
+    z.2
+
+@[simp]
+private theorem
+    PeriodFamily.BoundaryLoopSquares.loopSquareQuotient_unit {X : Type*} [TopologicalSpace X]
+    {a b : X} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) (s t : unitInterval) :
+    loopSquareQuotient S (s, loopQuotientMap t) = S.map (s, t) :=
+  rfl
+
+private theorem PeriodFamily.BoundaryLoopSquares.continuous_loopSquareQuotient {X : Type*}
+    [TopologicalSpace X] {a b : X} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) :
+    Continuous (loopSquareQuotient S) := by
+  apply loopQuotientMap_isQuotientMap.continuous_lift_prod_right
+  change Continuous (fun z : unitInterval × unitInterval => S.map (z.1, z.2))
+  exact S.map.continuous
+
+private def
+    PeriodFamily.BoundaryLoopSquares.quotientSquare {X : Type*} [TopologicalSpace X] {a b : X}
+    {p : Path a a} {q : Path b b} (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) :
+    C(unitInterval × LoopQuotient, X) :=
+  ⟨loopSquareQuotient S, continuous_loopSquareQuotient S⟩
+
+private def PeriodFamily.BoundaryLoopSquares.circleSquare {X : Type*} [TopologicalSpace X] {a b : X}
+    {p : Path a a} {q : Path b b} (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) :
+    C(unitInterval × LoopCircle, X) :=
+  (quotientSquare S).comp
+    ⟨fun z => (z.1, AddCircle.homeoIccQuot (1 : ℝ) 0 z.2),
+      continuous_fst.prodMk ((AddCircle.homeoIccQuot (1 : ℝ) 0).continuous.comp continuous_snd)⟩
+
+@[simp]
+private theorem PeriodFamily.BoundaryLoopSquares.circleSquare_unit {X : Type*} [TopologicalSpace X]
+    {a b : X} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) (s t : unitInterval) :
+    circleSquare S (s, ((t : ℝ) : LoopCircle)) = S.map (s, t) := by
+  change loopSquareQuotient S (s, AddCircle.homeoIccQuot (1 : ℝ) 0 ((t : ℝ) : LoopCircle)) = _
+  rw [loopCircleQuotient_unit, loopSquareQuotient_unit]
+
+@[simp]
+private theorem
+    PeriodFamily.BoundaryLoopSquares.circleSquare_initial {X : Type*} [TopologicalSpace X]
+    {a b : X} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) (z : LoopCircle) :
+    circleSquare S (0, z) = loopOnCircle p z := by
+  obtain ⟨t, rfl⟩ := loopUnitCircle_surjective z
+  rw [circleSquare_unit, loopOnCircle_unit, S.initial]
+
+@[simp]
+private theorem PeriodFamily.BoundaryLoopSquares.circleSquare_final {X : Type*} [TopologicalSpace X]
+    {a b : X} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) (z : LoopCircle) :
+    circleSquare S (1, z) = loopOnCircle q z := by
+  obtain ⟨t, rfl⟩ := loopUnitCircle_surjective z
+  rw [circleSquare_unit, loopOnCircle_unit, S.final]
+
+private def
+    PeriodFamily.BoundaryLoopSquares.periodicSquare {X : Type*} [TopologicalSpace X] {a b : X}
+    {p : Path a a} {q : Path b b} (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) :
+    C(unitInterval × ℝ, X) :=
+  (circleSquare S).comp
+    ⟨fun z => (z.1, (z.2 : LoopCircle)),
+      continuous_fst.prodMk ((AddCircle.continuous_mk' (1 : ℝ)).comp continuous_snd)⟩
+
+@[simp]
+private theorem
+    PeriodFamily.BoundaryLoopSquares.periodicSquare_unit {X : Type*} [TopologicalSpace X]
+    {a b : X} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) (s t : unitInterval) :
+    periodicSquare S (s, (t : ℝ)) = S.map (s, t) :=
+  circleSquare_unit S s t
+
+@[simp]
+private theorem
+    PeriodFamily.BoundaryLoopSquares.periodicSquare_initial {X : Type*} [TopologicalSpace X]
+    {a b : X} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) (t : ℝ) :
+    periodicSquare S (0, t) = loopPeriodic p t :=
+  circleSquare_initial S (t : LoopCircle)
+
+@[simp]
+private theorem
+    PeriodFamily.BoundaryLoopSquares.periodicSquare_final {X : Type*} [TopologicalSpace X]
+    {a b : X} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) (t : ℝ) :
+    periodicSquare S (1, t) = loopPeriodic q t :=
+  circleSquare_final S (t : LoopCircle)
+
+private theorem
+    PeriodFamily.BoundaryLoopSquares.periodicSquare_add_int {X : Type*} [TopologicalSpace X]
+    {a b : X} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) (s : unitInterval) (t : ℝ)
+    (k : ℤ) : periodicSquare S (s, t + (k : ℝ)) = periodicSquare S (s, t) := by
+  change circleSquare S (s, ((t + (k : ℝ) : ℝ) : LoopCircle)) = _
+  rw [loopCircle_add_int]
+  rfl
+
+private def
+    PeriodFamily.BoundaryLoopSquares.periodicHomotopy {X : Type*} [TopologicalSpace X] {a b : X}
+    {p : Path a a} {q : Path b b} (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) :
+    (loopPeriodic p).Homotopy (loopPeriodic q)
+    where
+  toFun := periodicSquare S
+  continuous_toFun := (periodicSquare S).continuous
+  map_zero_left := periodicSquare_initial S
+  map_one_left := periodicSquare_final S
+
+@[simp]
+private theorem
+    PeriodFamily.BoundaryLoopSquares.periodicHomotopy_unit {X : Type*} [TopologicalSpace X]
+    {a b : X} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) (s t : unitInterval) :
+    periodicHomotopy S (s, (t : ℝ)) = S.map (s, t) :=
+  periodicSquare_unit S s t
+
+private theorem
+    PeriodFamily.BoundaryLoopSquares.periodicHomotopy_add_int {X : Type*} [TopologicalSpace X]
+    {a b : X} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) (s : unitInterval) (t : ℝ)
+    (k : ℤ) : periodicHomotopy S (s, t + (k : ℝ)) = periodicHomotopy S (s, t) :=
+  periodicSquare_add_int S s t k
+
+private theorem PeriodFamily.Boundary.Cusp.projectedCurve_eq_periodic
+    (h :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius) :
+    (projectedCurve h : ℝ → SpecialPeriods.TriangleRegularQuotient) =
+      PeriodFamily.BoundaryLoopSquares.loopPeriodic (nativeLoop h) :=
+  PeriodFamily.BoundaryLoopSquares.loopPeriodic_unique (projectedCurve h)
+    (baseLift_projection_periodic h) (fun _ => rfl)
+
+private def PeriodFamily.Boundary.Cusp.nativePeriodicSquare :
+    C(unitInterval × ℝ, SpecialPeriods.TriangleRegularQuotient) :=
+  PeriodFamily.BoundaryLoopSquares.periodicSquare nativeOuterSquare
+
+@[simp]
+private theorem PeriodFamily.Boundary.Cusp.nativePeriodicSquare_zero (t : ℝ) :
+    nativePeriodicSquare (0, t) =
+      SpecialPeriods.triangleRegularProject (baseLift controlledHeight t) :=
+  (PeriodFamily.BoundaryLoopSquares.periodicSquare_initial nativeOuterSquare t).trans
+    (congrFun (projectedCurve_eq_periodic controlledHeight) t).symm
+
+private theorem PeriodFamily.Boundary.Cusp.nativePeriodicSquare_translate (s : unitInterval) (k : ℤ)
+    (t : ℝ) : nativePeriodicSquare (s, t + k) = nativePeriodicSquare (s, t) :=
+  PeriodFamily.BoundaryLoopSquares.periodicSquare_add_int nativeOuterSquare s t k
+
+private def PeriodFamily.Boundary.Cusp.nativeLiftedSquare :
+    C(unitInterval × ℝ, SpecialPeriods.TriangleRegularPoint) :=
+  PeriodFamily.Boundary.baseHomotopyLift nativePeriodicSquare (baseLift controlledHeight)
+    nativePeriodicSquare_zero
+
+@[simp]
+private theorem PeriodFamily.Boundary.Cusp.nativeLiftedSquare_zero (t : ℝ) :
+    nativeLiftedSquare (0, t) = baseLift controlledHeight t :=
+  PeriodFamily.Boundary.baseHomotopyLift_zero nativePeriodicSquare (baseLift controlledHeight)
+    nativePeriodicSquare_zero t
+
+private theorem
+    PeriodFamily.Boundary.Cusp.nativeLiftedSquare_projection (s : unitInterval) (t : ℝ) :
+    SpecialPeriods.triangleRegularProject (nativeLiftedSquare (s, t)) =
+      nativePeriodicSquare (s, t) :=
+  PeriodFamily.Boundary.baseHomotopyLift_projection nativePeriodicSquare
+    (baseLift controlledHeight) nativePeriodicSquare_zero s t
+
+private theorem PeriodFamily.Boundary.Cusp.nativeLiftedSquare_translate (s : unitInterval) (k : ℤ)
+    (t : ℝ) :
+    nativeLiftedSquare (s, t + k) =
+      (SpecialPeriods.triangleCuspGenerator ^ (-k)) • nativeLiftedSquare (s, t) :=
+  PeriodFamily.Boundary.baseHomotopyLift_translate nativePeriodicSquare
+    (baseLift controlledHeight) nativePeriodicSquare_zero SpecialPeriods.triangleCuspGenerator
+    nativePeriodicSquare_translate (baseLift_translate controlledHeight) s k t
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.quotient_same_base_injective
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (z : SpecialPeriods.TriangleRegularPoint) :
+    Function.Injective (fun x : RealTorus₄ => D.quotient (z, x)) :=
+  DiagonalQuotient.fibreInclusion_injective (F := RealTorus₄)
+    SpecialPeriods.triangleRegularProject_covering z
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.fibreMap_deck_of_actual {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (φ : X ≃ₜ X)
+    (F : C(MappingTorus.Torus φ, D.Space)) (L : C(ℝ, SpecialPeriods.TriangleRegularPoint))
+    (G : C(ℝ × X, RealTorus₄)) (g : SpecialPeriods.TriangleGroup)
+    (hF : ∀ p : ℝ × X, F (MappingTorus.mk φ p) = D.quotient (L p.1, G p))
+    (hL : ∀ (k : ℤ) t, L (t + k) = (g ^ (-k)) • L t) (k : ℤ) (p : ℝ × X) :
+    G (MappingTorus.deck φ k p) = (g ^ (-k)) • G p := by
+  have hraw : D.quotient (L (p.1 + k), G (MappingTorus.deck φ k p)) = D.quotient (L p.1, G p) := by
+    calc
+      _ = F (MappingTorus.mk φ (MappingTorus.deck φ k p)) := (hF (MappingTorus.deck φ k p)).symm
+      _ = F (MappingTorus.mk φ p) := (congrArg F (MappingTorus.mk_deck φ k p))
+      _ = _ := hF p
+  have hframe : D.quotient (L (p.1 + k), (g ^ (-k)) • G p) = D.quotient (L p.1, G p) := by
+    rw [hL]
+    exact D.quotient_smul (g ^ (-k)) (L p.1, G p)
+  exact quotient_same_base_injective D (L (p.1 + k)) (hraw.trans hframe.symm)
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem
+    PeriodFamily.Boundary.actualBoundary_homotopic_of_base {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (φ : X ≃ₜ X)
+    (F : C(MappingTorus.Torus φ, D.Space)) (L : C(ℝ, SpecialPeriods.TriangleRegularPoint))
+    (G : C(ℝ × X, RealTorus₄)) (g : SpecialPeriods.TriangleGroup)
+    (hF : ∀ p : ℝ × X, F (MappingTorus.mk φ p) = D.quotient (L p.1, G p))
+    (hL : ∀ (k : ℤ) t, L (t + k) = (g ^ (-k)) • L t)
+    (H : C(unitInterval × ℝ, SpecialPeriods.TriangleRegularPoint)) (hzero : ∀ t, H (0, t) = L t)
+    (hH : ∀ (s : unitInterval) (k : ℤ) t, H (s, t + k) = (g ^ (-k)) • H (s, t)) :
+    F.Homotopic
+      (familyBoundaryMap D φ (baseHomotopySlice H 1) G g (hH 1)
+        (fibreMap_deck_of_actual D φ F L G g hF hL)) := by
+  have he :
+    familyBoundaryMap D φ (baseHomotopySlice H 0) G g (hH 0)
+        (fibreMap_deck_of_actual D φ F L G g hF hL) =
+      F := by
+    apply ContinuousMap.ext
+    intro q
+    obtain ⟨p, rfl⟩ := MappingTorus.mk_surjective φ q
+    change D.quotient (H (0, p.1), G p) = F (MappingTorus.mk φ p)
+    exact (congrArg (fun z => D.quotient (z, G p)) (hzero p.1)).trans (hF p).symm
+  exact
+    ⟨(familyBoundaryHomotopy D φ H G g hH (fibreMap_deck_of_actual D φ F L G g hF hL)).cast he
+        rfl⟩
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.Cusp.nativeFibreCylinder : C(ℝ × RealTorus₄, RealTorus₄) :=
+  ⟨Prod.snd, continuous_snd⟩
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.Cusp.nativeFibreCylinder_deck (k : ℤ) (p : ℝ × RealTorus₄) :
+    nativeFibreCylinder (MappingTorus.deck ThreefoldOverlapMappingTorus.Cusp.monodromy k p) =
+      (SpecialPeriods.triangleCuspGenerator ^ (-k)) • nativeFibreCylinder p :=
+  PeriodFamily.Boundary.fibreMap_deck_of_actual
+    ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData
+    ThreefoldOverlapMappingTorus.Cusp.monodromy
+    (ThreefoldOverlapMappingTorus.boundaryToRegularFamily Option.none)
+    (baseLift ThreefoldOverlapMappingTorus.Cusp.specialHeight) nativeFibreCylinder
+    SpecialPeriods.triangleCuspGenerator (fun p => boundaryToRegularFamily_mk p.1 p.2)
+    (baseLift_translate ThreefoldOverlapMappingTorus.Cusp.specialHeight) k p
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.Cusp.heightBoundaryMap
+    (h :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius) :
+    C(ThreefoldOverlapMappingTorus.Cusp.Boundary,
+      ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData.Space) :=
+  PeriodFamily.Boundary.familyBoundaryMap ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData
+    ThreefoldOverlapMappingTorus.Cusp.monodromy (baseLift h) nativeFibreCylinder
+    SpecialPeriods.triangleCuspGenerator (baseLift_translate h) nativeFibreCylinder_deck
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.Cusp.heightBoundaryMap_specialHeight :
+    heightBoundaryMap ThreefoldOverlapMappingTorus.Cusp.specialHeight =
+      ThreefoldOverlapMappingTorus.boundaryToRegularFamily Option.none := by
+  apply ContinuousMap.ext
+  intro q
+  obtain ⟨p, rfl⟩ := MappingTorus.mk_surjective ThreefoldOverlapMappingTorus.Cusp.monodromy q
+  exact (boundaryToRegularFamily_mk p.1 p.2).symm
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.Cusp.heightSegment
+    (a b :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius) :
+    C(unitInterval,
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius) :=
+  ⟨fun s =>
+    ⟨(1 - (s : ℝ)) * (a : ℝ) + (s : ℝ) * (b : ℝ), by
+      exact
+        (convex_Ioi
+              (ThreefoldOverlapMappingTorus.Cusp.heightThreshold
+                ThreefoldOverlapMappingTorus.Cusp.specialData.radius) :
+            Convex ℝ
+              (Set.Ioi
+                (ThreefoldOverlapMappingTorus.Cusp.heightThreshold
+                  ThreefoldOverlapMappingTorus.Cusp.specialData.radius)))
+          a.property b.property (sub_nonneg.mpr s.property.2) s.property.1
+          (sub_add_cancel 1 (s : ℝ))⟩,
+    (((continuous_const.sub continuous_subtype_val).mul continuous_const).add
+          (continuous_subtype_val.mul continuous_const)).subtype_mk
+      _⟩
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+@[simp]
+private theorem PeriodFamily.Boundary.Cusp.heightSegment_zero
+    (a b :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius) :
+    heightSegment a b 0 = a := by
+  apply Subtype.ext
+  change (1 - (0 : ℝ)) * (a : ℝ) + 0 * (b : ℝ) = (a : ℝ)
+  simp
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+@[simp]
+private theorem PeriodFamily.Boundary.Cusp.heightSegment_one
+    (a b :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius) :
+    heightSegment a b 1 = b := by
+  apply Subtype.ext
+  change (1 - (1 : ℝ)) * (a : ℝ) + 1 * (b : ℝ) = (b : ℝ)
+  simp
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.Cusp.heightBaseHomotopy
+    (a b :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius) :
+    C(unitInterval × ℝ, SpecialPeriods.TriangleRegularPoint) :=
+  ⟨fun p => baseLift (heightSegment a b p.1) p.2,
+    (SpecialPeriods.CuspFamily.logBaseToRegular_holomorphic
+          ThreefoldOverlapMappingTorus.Cusp.specialData.radius
+          ThreefoldOverlapMappingTorus.Cusp.specialRadius_cap).continuous.comp
+      ((ThreefoldOverlapMappingTorus.Cusp.logBaseHeightHomeomorph
+            ThreefoldOverlapMappingTorus.Cusp.specialData.radius
+            ThreefoldOverlapMappingTorus.Cusp.specialData.radius_pos).symm.continuous.comp
+        (((heightSegment a b).continuous.comp continuous_fst).prodMk continuous_snd))⟩
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+@[simp]
+private theorem PeriodFamily.Boundary.Cusp.heightBaseHomotopy_apply
+    (a b :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius)
+    (s : unitInterval) (t : ℝ) :
+    heightBaseHomotopy a b (s, t) = baseLift (heightSegment a b s) t :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.Cusp.heightBaseHomotopy_zero
+    (a b :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius)
+    (t : ℝ) : heightBaseHomotopy a b (0, t) = baseLift a t := by
+  rw [heightBaseHomotopy_apply, heightSegment_zero]
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.Cusp.heightBaseHomotopy_one
+    (a b :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius)
+    (t : ℝ) : heightBaseHomotopy a b (1, t) = baseLift b t := by
+  rw [heightBaseHomotopy_apply, heightSegment_one]
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.Cusp.heightBaseHomotopy_translate
+    (a b :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius)
+    (s : unitInterval) (k : ℤ) (t : ℝ) :
+    heightBaseHomotopy a b (s, t + k) =
+      (SpecialPeriods.triangleCuspGenerator ^ (-k)) • heightBaseHomotopy a b (s, t) :=
+  baseLift_translate (heightSegment a b s) k t
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.Cusp.heightBoundaryHomotopy
+    (a b :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius) :
+    (heightBoundaryMap a).Homotopy (heightBoundaryMap b) :=
+  (PeriodFamily.Boundary.familyBoundaryHomotopy
+        ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData
+        ThreefoldOverlapMappingTorus.Cusp.monodromy (heightBaseHomotopy a b) nativeFibreCylinder
+        SpecialPeriods.triangleCuspGenerator (heightBaseHomotopy_translate a b)
+        nativeFibreCylinder_deck).cast
+    (by
+      apply ContinuousMap.ext
+      intro q
+      obtain ⟨p, rfl⟩ := MappingTorus.mk_surjective ThreefoldOverlapMappingTorus.Cusp.monodromy q
+      change
+        ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData.quotient
+            (heightBaseHomotopy a b (0, p.1), p.2) =
+          ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData.quotient (baseLift a p.1, p.2)
+      rw [heightBaseHomotopy_zero])
+    (by
+      apply ContinuousMap.ext
+      intro q
+      obtain ⟨p, rfl⟩ := MappingTorus.mk_surjective ThreefoldOverlapMappingTorus.Cusp.monodromy q
+      change
+        ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData.quotient
+            (heightBaseHomotopy a b (1, p.1), p.2) =
+          ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData.quotient (baseLift b p.1, p.2)
+      rw [heightBaseHomotopy_one])
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.Cusp.boundaryToRegularFamily_heightHomotopy
+    (h :
+      ThreefoldOverlapMappingTorus.Cusp.Height
+        ThreefoldOverlapMappingTorus.Cusp.specialData.radius) :
+    (ThreefoldOverlapMappingTorus.boundaryToRegularFamily Option.none).Homotopy
+      (heightBoundaryMap h) :=
+  (heightBoundaryHomotopy ThreefoldOverlapMappingTorus.Cusp.specialHeight h).cast
+    heightBoundaryMap_specialHeight rfl
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.Cusp.normalizedBoundaryMap :
+    C(ThreefoldOverlapMappingTorus.Cusp.Boundary,
+      ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData.Space) :=
+  PeriodFamily.Boundary.familyBoundaryMap ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData
+    ThreefoldOverlapMappingTorus.Cusp.monodromy
+    (PeriodFamily.Boundary.baseHomotopySlice nativeLiftedSquare 1) nativeFibreCylinder
+    SpecialPeriods.triangleCuspGenerator (nativeLiftedSquare_translate 1) nativeFibreCylinder_deck
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+@[simp]
+private theorem PeriodFamily.Boundary.Cusp.normalizedBoundaryMap_mk (t : ℝ) (x : RealTorus₄) :
+    normalizedBoundaryMap (MappingTorus.mk ThreefoldOverlapMappingTorus.Cusp.monodromy (t, x)) =
+      ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData.quotient
+        (nativeLiftedSquare (1, t), x) :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.Cusp.heightToNormalizedHomotopy :
+    (heightBoundaryMap controlledHeight).Homotopy normalizedBoundaryMap :=
+  (PeriodFamily.Boundary.familyBoundaryHomotopy
+        ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData
+        ThreefoldOverlapMappingTorus.Cusp.monodromy nativeLiftedSquare nativeFibreCylinder
+        SpecialPeriods.triangleCuspGenerator nativeLiftedSquare_translate
+        nativeFibreCylinder_deck).cast
+    (by
+      apply ContinuousMap.ext
+      intro q
+      obtain ⟨p, rfl⟩ := MappingTorus.mk_surjective ThreefoldOverlapMappingTorus.Cusp.monodromy q
+      change
+        ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData.quotient
+            (nativeLiftedSquare (0, p.1), p.2) =
+          ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData.quotient
+            (baseLift controlledHeight p.1, p.2)
+      rw [nativeLiftedSquare_zero])
+    rfl
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.Cusp.boundaryToNormalizedHomotopy :
+    (ThreefoldOverlapMappingTorus.boundaryToRegularFamily Option.none).Homotopy
+      normalizedBoundaryMap :=
+  (boundaryToRegularFamily_heightHomotopy controlledHeight).trans heightToNormalizedHomotopy
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.Cusp.boundaryRegularHomologyMap_normalized (n : ℕ) :
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none n =
+      SingularMayerVietoris.singularHomologyMap normalizedBoundaryMap n :=
+  PeriodTorusHigherHomology.homotopy_homologyMap boundaryToNormalizedHomotopy n
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem
+    PeriodFamily.Boundary.Cusp.normalizedBoundaryMap_projection_mk (t : ℝ) (x : RealTorus₄) :
+    ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData.projection
+        (normalizedBoundaryMap
+          (MappingTorus.mk ThreefoldOverlapMappingTorus.Cusp.monodromy (t, x))) =
+      SpecialPeriods.triangleRegularProject (nativeLiftedSquare (1, t)) :=
+  rfl
+
+private theorem PeriodFamily.Boundary.Cusp.sin_two_pi_gt_half_of_le_quarter_mo1973_26635 (t : ℝ)
+    (ht0 : 1 / 8 < t) (ht1 : t ≤ 1 / 4) : (1 / 2 : ℝ) < Real.sin (2 * Real.pi * t) := by
+  have hlow := mul_lt_mul_of_pos_left ht0 Real.pi_pos
+  have hupp := mul_le_mul_of_nonneg_left ht1 Real.pi_pos.le
+  calc
+    (1 / 2 : ℝ) = Real.sin (Real.pi / 6) := Real.sin_pi_div_six.symm
+    _ < Real.sin (2 * Real.pi * t) := by
+      apply Real.sin_lt_sin_of_lt_of_le_pi_div_two
+      · linarith [Real.pi_pos]
+      · linarith
+      · linarith [Real.pi_pos]
+
+private theorem PeriodFamily.Boundary.Cusp.sin_two_pi_gt_half (t : ℝ) (ht0 : 1 / 8 < t)
+    (ht1 : t < 3 / 8) : (1 / 2 : ℝ) < Real.sin (2 * Real.pi * t) := by
+  by_cases ht : t ≤ 1 / 4
+  · exact sin_two_pi_gt_half_of_le_quarter_mo1973_26635 t ht0 ht
+  · have h :=
+      sin_two_pi_gt_half_of_le_quarter_mo1973_26635 (1 / 2 - t) (by linarith) (by linarith)
+    rwa [show 2 * Real.pi * (1 / 2 - t) = Real.pi - 2 * Real.pi * t by ring, Real.sin_pi_sub] at h
+
+public
+theorem PeriodFamily.Boundary.Cusp.sin_two_pi_lt_neg_half (t : ℝ) (ht0 : -(3 / 8) < t)
+    (ht1 : t < -(1 / 8)) : Real.sin (2 * Real.pi * t) < -(1 / 2 : ℝ) := by
+  have h := sin_two_pi_gt_half (-t) (by linarith) (by linarith)
+  rw [mul_neg, Real.sin_neg] at h
+  linarith
+
+private def PeriodFamily.Boundary.Cusp.outerClockwiseCircle :
+    Path (SpecialPeriods.Triangle.outerCircleBasepoint (2 : ℝ) (by norm_num))
+      (SpecialPeriods.Triangle.outerCircleBasepoint (2 : ℝ) (by norm_num)) :=
+  (SpecialPeriods.Triangle.outerPositiveCircle (2 : ℝ) (by norm_num)).symm
+
+private def PeriodFamily.Boundary.Cusp.outerClockwiseCurve :
+    C(ℝ, SpecialPeriods.Triangle.TwicePuncturedPlane) :=
+  ⟨fun t =>
+    ⟨SpecialPeriods.Triangle.outerCircleValue 2 (-t),
+      SpecialPeriods.Triangle.outerCircleValue_avoids_punctures 2 (by norm_num) (-t)⟩,
+    ((SpecialPeriods.Triangle.continuous_outerCircleValue 2).comp
+          ContinuousNeg.continuous_neg).subtype_mk
+      _⟩
+
+@[simp]
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseCurve_coe (t : ℝ) :
+    (outerClockwiseCurve t : ℂ) = SpecialPeriods.Triangle.outerCircleValue 2 (-t) :=
+  rfl
+
+private theorem PeriodFamily.Boundary.Cusp.outerValue_periodic_mo1973_26641 (R : ℝ) :
+    Function.Periodic (SpecialPeriods.Triangle.outerCircleValue R) 1 := by
+  intro t
+  unfold SpecialPeriods.Triangle.outerCircleValue
+  rw [show -Real.pi / 2 + 2 * Real.pi * (t + 1) = (-Real.pi / 2 + 2 * Real.pi * t) + 2 * Real.pi
+      by ring]
+  exact periodic_circleMap (1 / 2 : ℂ) R _
+
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseCurve_periodic :
+    Function.Periodic outerClockwiseCurve 1 := by
+  intro t
+  apply Subtype.ext
+  change
+    SpecialPeriods.Triangle.outerCircleValue 2 (-(t + 1)) =
+      SpecialPeriods.Triangle.outerCircleValue 2 (-t)
+  rw [show -(t + 1) = -t - 1 by ring]
+  exact (outerValue_periodic_mo1973_26641 2).sub_eq (-t)
+
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseCurve_add_one (t : ℝ) :
+    outerClockwiseCurve (t + 1) = outerClockwiseCurve t :=
+  outerClockwiseCurve_periodic t
+
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseCurve_unit (t : unitInterval) :
+    outerClockwiseCurve (t : ℝ) = outerClockwiseCircle t := by
+  apply Subtype.ext
+  change
+    SpecialPeriods.Triangle.outerCircleValue 2 (-(t : ℝ)) =
+      SpecialPeriods.Triangle.outerCircleValue 2 ((unitInterval.symm t : unitInterval) : ℝ)
+  rw [unitInterval.coe_symm_eq]
+  exact (outerValue_periodic_mo1973_26641 2).sub_eq'.symm
+
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseCurve_quarter :
+    (outerClockwiseCurve (1 / 4) : ℂ) = -(3 / 2 : ℂ) := by
+  rw [outerClockwiseCurve_coe]
+  have h :
+    SpecialPeriods.Triangle.outerCircleValue 2 (-(1 / 4 : ℝ)) =
+      SpecialPeriods.Triangle.outerCircleValue 2 (3 / 4) := by
+    convert ((outerValue_periodic_mo1973_26641 2) (-(1 / 4 : ℝ))).symm using 1
+    norm_num
+  rw [h, SpecialPeriods.Triangle.outerCircleValue_threeQuarters]
+  norm_num
+
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseCurve_threeQuarters :
+    (outerClockwiseCurve (3 / 4) : ℂ) = (5 / 2 : ℂ) := by
+  rw [outerClockwiseCurve_coe]
+  have h :
+    SpecialPeriods.Triangle.outerCircleValue 2 (-(3 / 4 : ℝ)) =
+      SpecialPeriods.Triangle.outerCircleValue 2 (1 / 4) := by
+    convert ((outerValue_periodic_mo1973_26641 2) (-(3 / 4 : ℝ))).symm using 1
+    norm_num
+  rw [h, SpecialPeriods.Triangle.outerCircleValue_quarter]
+  norm_num
+
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseCurve_re (t : ℝ) :
+    (outerClockwiseCurve t : ℂ).re = 1 / 2 - 2 * Real.sin (2 * Real.pi * t) := by
+  have h :=
+    congrArg Complex.re (circleMap_sub_center (1 / 2 : ℂ) 2 (-Real.pi / 2 + 2 * Real.pi * (-t)))
+  rw [Complex.sub_re, circleMap_zero_re,
+    show -Real.pi / 2 + 2 * Real.pi * (-t) = -(2 * Real.pi * t) - Real.pi / 2 by ring,
+    Real.cos_sub_pi_div_two, Real.sin_neg] at h
+  norm_num at h
+  change (circleMap (1 / 2 : ℂ) 2 (-Real.pi / 2 + 2 * Real.pi * (-t))).re = _
+  rw [show -Real.pi / 2 + 2 * Real.pi * (-t) = -(2 * Real.pi * t) - Real.pi / 2 by ring]
+  linarith
+
+private theorem
+    PeriodFamily.Boundary.Cusp.outerClockwiseCircle_mem_upperSlitPlane (t : unitInterval)
+    (ht0 : 1 / 4 ≤ (t : ℝ)) (ht1 : (t : ℝ) ≤ 3 / 4) :
+    (outerClockwiseCircle t : ℂ) ∈ SpecialPeriods.Triangle.upperSlitPlane := by
+  change
+    (SpecialPeriods.Triangle.outerPositiveCircle 2 (by norm_num) (unitInterval.symm t) : ℂ) ∈
+      SpecialPeriods.Triangle.upperSlitPlane
+  apply SpecialPeriods.Triangle.outerPositiveCircle_mem_upperSlitPlane
+  · rw [unitInterval.coe_symm_eq]
+    linarith
+  · rw [unitInterval.coe_symm_eq]
+    linarith
+
+private theorem
+    PeriodFamily.Boundary.Cusp.outerClockwiseCircle_mem_lowerSlitPlane (t : unitInterval)
+    (ht : (t : ℝ) ≤ 1 / 4 ∨ 3 / 4 ≤ (t : ℝ)) :
+    (outerClockwiseCircle t : ℂ) ∈ SpecialPeriods.Triangle.lowerSlitPlane := by
+  change
+    (SpecialPeriods.Triangle.outerPositiveCircle 2 (by norm_num) (unitInterval.symm t) : ℂ) ∈
+      SpecialPeriods.Triangle.lowerSlitPlane
+  apply SpecialPeriods.Triangle.outerPositiveCircle_mem_lowerSlitPlane
+  rw [unitInterval.coe_symm_eq]
+  rcases ht with ht | ht
+  · exact Or.inr (by linarith)
+  · exact Or.inl (by linarith)
+
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseCurve_mem_upperSlitPlane (t : ℝ)
+    (ht0 : 1 / 8 < t) (ht1 : t < 7 / 8) :
+    (outerClockwiseCurve t : ℂ) ∈ SpecialPeriods.Triangle.upperSlitPlane := by
+  by_cases hleft : t < 1 / 4
+  · have hs := sin_two_pi_gt_half t ht0 (by linarith)
+    apply Or.inr
+    rw [outerClockwiseCurve_re]
+    constructor <;> linarith
+  by_cases hright : 3 / 4 < t
+  · have hs := sin_two_pi_lt_neg_half (t - 1) (by linarith) (by linarith)
+    rw [show 2 * Real.pi * (t - 1) = 2 * Real.pi * t - 2 * Real.pi by ring,
+      Real.sin_sub_two_pi] at hs
+    apply Or.inr
+    rw [outerClockwiseCurve_re]
+    constructor <;> linarith
+  · let u : unitInterval := ⟨t, by constructor <;> linarith⟩
+    change (outerClockwiseCurve (u : ℝ) : ℂ) ∈ SpecialPeriods.Triangle.upperSlitPlane
+    rw [outerClockwiseCurve_unit]
+    exact outerClockwiseCircle_mem_upperSlitPlane u (le_of_not_gt hleft) (le_of_not_gt hright)
+
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseCurve_mem_lowerSlitPlane (t : ℝ)
+    (ht0 : -(3 / 8) < t) (ht1 : t < 3 / 8) :
+    (outerClockwiseCurve t : ℂ) ∈ SpecialPeriods.Triangle.lowerSlitPlane := by
+  by_cases hleft : t < -(1 / 4)
+  · have hs := sin_two_pi_lt_neg_half t ht0 (by linarith)
+    apply Or.inr
+    rw [outerClockwiseCurve_re]
+    constructor <;> linarith
+  by_cases hright : 1 / 4 < t
+  · have hs := sin_two_pi_gt_half t (by linarith) ht1
+    apply Or.inr
+    rw [outerClockwiseCurve_re]
+    constructor <;> linarith
+  by_cases hneg : t < 0
+  · let u : unitInterval := ⟨t + 1, by constructor <;> linarith⟩
+    have hu : 3 / 4 ≤ (u : ℝ) := by
+      change 3 / 4 ≤ t + 1
+      linarith
+    have h := outerClockwiseCircle_mem_lowerSlitPlane u (Or.inr hu)
+    rw [← outerClockwiseCurve_unit] at h
+    change (outerClockwiseCurve (t + 1) : ℂ) ∈ SpecialPeriods.Triangle.lowerSlitPlane at h
+    rwa [outerClockwiseCurve_add_one] at h
+  · let u : unitInterval := ⟨t, by constructor <;> linarith⟩
+    change (outerClockwiseCurve (u : ℝ) : ℂ) ∈ SpecialPeriods.Triangle.lowerSlitPlane
+    rw [outerClockwiseCurve_unit]
+    exact outerClockwiseCircle_mem_lowerSlitPlane u (Or.inl (le_of_not_gt hright))
+
+private def PeriodFamily.Boundary.Cusp.outerClockwiseRegularCurve :
+    C(ℝ, SpecialPeriods.TriangleRegularQuotient) :=
+  (SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm :
+        C(SpecialPeriods.Triangle.TwicePuncturedPlane,
+          SpecialPeriods.TriangleRegularQuotient)).comp
+    outerClockwiseCurve
+
+@[simp]
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseRegularCurve_coordinate (t : ℝ) :
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph (outerClockwiseRegularCurve t) =
+      outerClockwiseCurve t :=
+  SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.apply_symm_apply _
+
+private def PeriodFamily.Boundary.Cusp.outerClockwiseRegularBasepoint :
+    SpecialPeriods.TriangleRegularQuotient :=
+  SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm
+    (SpecialPeriods.Triangle.outerCircleBasepoint 2 (by norm_num))
+
+@[simp]
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseRegularBasepoint_coordinate :
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph outerClockwiseRegularBasepoint =
+      SpecialPeriods.Triangle.outerCircleBasepoint 2 (by norm_num) :=
+  SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.apply_symm_apply _
+
+private def PeriodFamily.Boundary.Cusp.outerClockwiseRegularMeridian :
+    Path outerClockwiseRegularBasepoint outerClockwiseRegularBasepoint :=
+  outerClockwiseCircle.map SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm.continuous
+
+@[simp]
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseRegularCurve_unit (t : unitInterval) :
+    outerClockwiseRegularCurve t = outerClockwiseRegularMeridian t := by
+  change
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm (outerClockwiseCurve t) =
+      SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm (outerClockwiseCircle t)
+  rw [outerClockwiseCurve_unit]
+
+@[simp]
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseRegularCurve_zero :
+    outerClockwiseRegularCurve 0 = outerClockwiseRegularBasepoint :=
+  (outerClockwiseRegularCurve_unit 0).trans outerClockwiseRegularMeridian.source
+
+@[simp]
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseRegularCurve_one :
+    outerClockwiseRegularCurve 1 = outerClockwiseRegularBasepoint :=
+  (outerClockwiseRegularCurve_unit 1).trans outerClockwiseRegularMeridian.target
+
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseRegularCurve_periodic :
+    Function.Periodic outerClockwiseRegularCurve 1 := by
+  intro t
+  change
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm (outerClockwiseCurve (t + 1)) =
+      SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm (outerClockwiseCurve t)
+  rw [outerClockwiseCurve_periodic t]
+
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseRegularBasepoint_mem_lower :
+    outerClockwiseRegularBasepoint ∈ PeriodFamily.Homology.lowerBase := by
+  rw [PeriodFamily.Homology.mem_regularOpen, outerClockwiseRegularBasepoint_coordinate]
+  change ((1 / 2 : ℂ) - (2 : ℂ) * Complex.I) ∈ SpecialPeriods.Triangle.lowerSlitPlane
+  apply Or.inr
+  norm_num
+
+private def
+    PeriodFamily.Boundary.Cusp.outerClockwiseLowerBasepoint : PeriodFamily.Homology.lowerBase :=
+  ⟨outerClockwiseRegularBasepoint, outerClockwiseRegularBasepoint_mem_lower⟩
+
+private def
+    PeriodFamily.Boundary.Cusp.outerClockwiseBaseLift : SpecialPeriods.TriangleRegularPoint :=
+  PeriodFamily.Homology.lowerLift PeriodFamily.Homology.normalizedSlitBaseLift
+    outerClockwiseLowerBasepoint
+
+@[simp]
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseBaseLift_project :
+    SpecialPeriods.triangleRegularProject outerClockwiseBaseLift =
+      outerClockwiseRegularBasepoint :=
+  PeriodFamily.Homology.lowerLift_project PeriodFamily.Homology.normalizedSlitBaseLift
+    outerClockwiseLowerBasepoint
+
+private def
+    PeriodFamily.Boundary.Cusp.outerClockwiseLift : C(ℝ, SpecialPeriods.TriangleRegularPoint) :=
+  PeriodFamily.Boundary.realCurveLift outerClockwiseRegularCurve outerClockwiseBaseLift
+    (outerClockwiseBaseLift_project.trans outerClockwiseRegularCurve_zero.symm)
+
+@[simp]
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseLift_zero :
+    outerClockwiseLift 0 = outerClockwiseBaseLift :=
+  PeriodFamily.Boundary.realCurveLift_zero _ _ _
+
+@[simp]
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseLift_projection (t : ℝ) :
+    SpecialPeriods.triangleRegularProject (outerClockwiseLift t) = outerClockwiseRegularCurve t :=
+  PeriodFamily.Boundary.realCurveLift_projection _ _ _ t
+
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseRegularCurve_mem_upperBase (t : ℝ)
+    (ht₀ : 1 / 8 < t) (ht₁ : t < 7 / 8) :
+    outerClockwiseRegularCurve t ∈ PeriodFamily.Homology.upperBase := by
+  rw [PeriodFamily.Homology.mem_regularOpen, outerClockwiseRegularCurve_coordinate]
+  exact outerClockwiseCurve_mem_upperSlitPlane t ht₀ ht₁
+
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseRegularCurve_mem_lowerBase (t : ℝ)
+    (ht₀ : -(3 / 8) < t) (ht₁ : t < 3 / 8) :
+    outerClockwiseRegularCurve t ∈ PeriodFamily.Homology.lowerBase := by
+  rw [PeriodFamily.Homology.mem_regularOpen, outerClockwiseRegularCurve_coordinate]
+  exact outerClockwiseCurve_mem_lowerSlitPlane t ht₀ ht₁
+
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseRegularCurve_mem_lower_piece (t : ℝ)
+    (ht₀ : 0 ≤ t) (ht₁ : t ≤ 1) (ht : t ≤ 1 / 4 ∨ 3 / 4 ≤ t) :
+    outerClockwiseRegularCurve t ∈ PeriodFamily.Homology.lowerBase := by
+  rw [PeriodFamily.Homology.mem_regularOpen, outerClockwiseRegularCurve_coordinate]
+  change (outerClockwiseCurve t : ℂ) ∈ SpecialPeriods.Triangle.lowerSlitPlane
+  have he := outerClockwiseCurve_unit (⟨t, ht₀, ht₁⟩ : unitInterval)
+  rw [he]
+  exact outerClockwiseCircle_mem_lowerSlitPlane _ ht
+
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseRegularCurve_mem_upper_piece (t : ℝ)
+    (ht₀ : 1 / 4 ≤ t) (ht₁ : t ≤ 3 / 4) :
+    outerClockwiseRegularCurve t ∈ PeriodFamily.Homology.upperBase := by
+  rw [PeriodFamily.Homology.mem_regularOpen, outerClockwiseRegularCurve_coordinate]
+  change (outerClockwiseCurve t : ℂ) ∈ SpecialPeriods.Triangle.upperSlitPlane
+  let u : unitInterval := ⟨t, by constructor <;> linarith⟩
+  have he := outerClockwiseCurve_unit u
+  rw [he]
+  exact outerClockwiseCircle_mem_upperSlitPlane u ht₀ ht₁
+
+private def
+    PeriodFamily.Boundary.Cusp.outerClockwiseQuarterPoint : PeriodFamily.Homology.overlapBase 0 :=
+  by
+  refine ⟨outerClockwiseRegularCurve (1 / 4), ?_⟩
+  rw [PeriodFamily.Homology.mem_regularOpen, outerClockwiseRegularCurve_coordinate]
+  change (outerClockwiseCurve (1 / 4) : ℂ) ∈ SpecialPeriods.Triangle.overlapStrip 0
+  rw [outerClockwiseCurve_quarter]
+  norm_num [SpecialPeriods.Triangle.overlapStrip]
+
+private def PeriodFamily.Boundary.Cusp.outerClockwiseThreeQuarterPoint :
+    PeriodFamily.Homology.overlapBase 2 := by
+  refine ⟨outerClockwiseRegularCurve (3 / 4), ?_⟩
+  rw [PeriodFamily.Homology.mem_regularOpen, outerClockwiseRegularCurve_coordinate]
+  change (outerClockwiseCurve (3 / 4) : ℂ) ∈ SpecialPeriods.Triangle.overlapStrip 2
+  rw [outerClockwiseCurve_threeQuarters]
+  norm_num [SpecialPeriods.Triangle.overlapStrip]
+
+private theorem PeriodFamily.Boundary.Cusp.outerLift_interval_unique_mo1973_26683 {a b : ℝ}
+    (s : C(Set.Icc a b, SpecialPeriods.TriangleRegularPoint))
+    (hs : ∀ t, SpecialPeriods.triangleRegularProject (s t) = outerClockwiseRegularCurve t)
+    (t₀ : Set.Icc a b) (h₀ : outerClockwiseLift t₀ = s t₀) (t : Set.Icc a b) :
+    outerClockwiseLift t = s t := by
+  let : PreconnectedSpace (Set.Icc a b) := Subtype.preconnectedSpace isPreconnected_Icc
+  exact
+    congrFun
+      (SpecialPeriods.triangleRegularProject_covering.isCoveringMap.eq_of_comp_eq
+        (outerClockwiseLift.continuous.comp continuous_subtype_val) s.continuous
+        (by
+          funext u
+          exact (outerClockwiseLift_projection u).trans (hs u).symm)
+        t₀ h₀)
+      t
+
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseLift_lower_initial (t : ℝ) (ht₀ : 0 ≤ t)
+    (ht₁ : t ≤ 1 / 4) :
+    outerClockwiseLift t =
+      PeriodFamily.Homology.lowerLift PeriodFamily.Homology.normalizedSlitBaseLift
+        ⟨outerClockwiseRegularCurve t,
+          outerClockwiseRegularCurve_mem_lower_piece t ht₀ (by linarith) (Or.inl ht₁)⟩ := by
+  let q : C(Set.Icc (0 : ℝ) (1 / 4), PeriodFamily.Homology.lowerBase) :=
+    ⟨fun s =>
+      ⟨outerClockwiseRegularCurve s,
+        outerClockwiseRegularCurve_mem_lower_piece s s.property.1 (by linarith [s.property.2])
+          (Or.inl s.property.2)⟩,
+      (outerClockwiseRegularCurve.continuous.comp continuous_subtype_val).subtype_mk _⟩
+  apply
+    outerLift_interval_unique_mo1973_26683
+      ((PeriodFamily.Homology.lowerLift PeriodFamily.Homology.normalizedSlitBaseLift).comp q)
+      (fun s =>
+        PeriodFamily.Homology.lowerLift_project PeriodFamily.Homology.normalizedSlitBaseLift
+          (q s))
+      (⟨0, by constructor <;> norm_num⟩ : Set.Icc (0 : ℝ) (1 / 4)) _
+      (⟨t, ht₀, ht₁⟩ : Set.Icc (0 : ℝ) (1 / 4))
+  rw [outerClockwiseLift_zero]
+  change
+    PeriodFamily.Homology.lowerLift PeriodFamily.Homology.normalizedSlitBaseLift
+        outerClockwiseLowerBasepoint =
+      PeriodFamily.Homology.lowerLift PeriodFamily.Homology.normalizedSlitBaseLift
+        (q ⟨0, by constructor <;> norm_num⟩)
+  apply congrArg (PeriodFamily.Homology.lowerLift PeriodFamily.Homology.normalizedSlitBaseLift)
+  apply Subtype.ext
+  exact outerClockwiseRegularCurve_zero.symm
+
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseLift_quarter_frame :
+    outerClockwiseLift (1 / 4) =
+      SpecialPeriods.triangleGenerator₁ •
+        PeriodFamily.Homology.upperLiftOnOverlap PeriodFamily.Homology.normalizedSlitBaseLift 0
+          outerClockwiseQuarterPoint := by
+  have h := PeriodFamily.Homology.normalizedOverlapTransition_apply 0 outerClockwiseQuarterPoint
+  rw [PeriodFamily.Homology.normalizedOverlapTransition_left_of_nonpos
+      PeriodFamily.Boundary.normalizationOrientation_nonpos] at h
+  calc
+    outerClockwiseLift (1 / 4) =
+        PeriodFamily.Homology.lowerLiftOnOverlap PeriodFamily.Homology.normalizedSlitBaseLift 0
+          outerClockwiseQuarterPoint :=
+      outerClockwiseLift_lower_initial _ (by norm_num) le_rfl
+    _ =
+        SpecialPeriods.triangleGenerator₁ •
+          PeriodFamily.Homology.upperLiftOnOverlap PeriodFamily.Homology.normalizedSlitBaseLift 0
+            outerClockwiseQuarterPoint :=
+      h.symm
+
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseLift_upper_middle (t : ℝ) (ht₀ : 1 / 4 ≤ t)
+    (ht₁ : t ≤ 3 / 4) :
+    outerClockwiseLift t =
+      SpecialPeriods.triangleGenerator₁ •
+        PeriodFamily.Homology.upperLift PeriodFamily.Homology.normalizedSlitBaseLift
+          ⟨outerClockwiseRegularCurve t, outerClockwiseRegularCurve_mem_upper_piece t ht₀ ht₁⟩ := by
+  let q : C(Set.Icc (1 / 4 : ℝ) (3 / 4), PeriodFamily.Homology.upperBase) :=
+    ⟨fun s =>
+      ⟨outerClockwiseRegularCurve s,
+        outerClockwiseRegularCurve_mem_upper_piece s s.property.1 s.property.2⟩,
+      (outerClockwiseRegularCurve.continuous.comp continuous_subtype_val).subtype_mk _⟩
+  let s : C(Set.Icc (1 / 4 : ℝ) (3 / 4), SpecialPeriods.TriangleRegularPoint) :=
+    ⟨fun u =>
+      SpecialPeriods.triangleGenerator₁ •
+        PeriodFamily.Homology.upperLift PeriodFamily.Homology.normalizedSlitBaseLift (q u),
+      (SpecialPeriods.triangleRegularProject_covering.continuous_const_smul
+            SpecialPeriods.triangleGenerator₁).comp
+        ((PeriodFamily.Homology.upperLift
+              PeriodFamily.Homology.normalizedSlitBaseLift).continuous.comp
+          q.continuous)⟩
+  apply
+    outerLift_interval_unique_mo1973_26683 s _
+      (⟨1 / 4, by constructor <;> norm_num⟩ : Set.Icc (1 / 4 : ℝ) (3 / 4)) _
+      (⟨t, ht₀, ht₁⟩ : Set.Icc (1 / 4 : ℝ) (3 / 4))
+  · intro u
+    exact
+      (SpecialPeriods.triangleRegularProject_covering.map_smul
+            SpecialPeriods.triangleGenerator₁).trans
+        (PeriodFamily.Homology.upperLift_project PeriodFamily.Homology.normalizedSlitBaseLift
+          (q u))
+  · exact outerClockwiseLift_quarter_frame
+
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseLift_threeQuarters_frame :
+    outerClockwiseLift (3 / 4) =
+      SpecialPeriods.triangleGenerator₁ •
+        PeriodFamily.Homology.upperLiftOnOverlap PeriodFamily.Homology.normalizedSlitBaseLift 2
+          outerClockwiseThreeQuarterPoint :=
+  outerClockwiseLift_upper_middle _ (by norm_num) le_rfl
+
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseLift_threeQuarters_lower_mo1973_26688 :
+    outerClockwiseLift (3 / 4) =
+      (SpecialPeriods.triangleGenerator₁ * SpecialPeriods.triangleGenerator₂) •
+        PeriodFamily.Homology.lowerLiftOnOverlap PeriodFamily.Homology.normalizedSlitBaseLift 2
+          outerClockwiseThreeQuarterPoint := by
+  have h :=
+    PeriodFamily.Homology.normalizedOverlapTransition_apply 2 outerClockwiseThreeQuarterPoint
+  rw [PeriodFamily.Homology.normalizedOverlapTransition_right_of_nonpos
+      PeriodFamily.Boundary.normalizationOrientation_nonpos] at h
+  have he :=
+    congrArg
+      (fun z : SpecialPeriods.TriangleRegularPoint => SpecialPeriods.triangleGenerator₂ • z) h
+  simp only [smul_inv_smul] at he
+  rw [outerClockwiseLift_threeQuarters_frame, SemigroupAction.mul_smul, ← he]
+
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseLift_lower_final (t : ℝ) (ht₀ : 3 / 4 ≤ t)
+    (ht₁ : t ≤ 1) :
+    outerClockwiseLift t =
+      (SpecialPeriods.triangleGenerator₁ * SpecialPeriods.triangleGenerator₂) •
+        PeriodFamily.Homology.lowerLift PeriodFamily.Homology.normalizedSlitBaseLift
+          ⟨outerClockwiseRegularCurve t,
+            outerClockwiseRegularCurve_mem_lower_piece t (by linarith) ht₁ (Or.inr ht₀)⟩ := by
+  let q : C(Set.Icc (3 / 4 : ℝ) 1, PeriodFamily.Homology.lowerBase) :=
+    ⟨fun s =>
+      ⟨outerClockwiseRegularCurve s,
+        outerClockwiseRegularCurve_mem_lower_piece s (by linarith [s.property.1]) s.property.2
+          (Or.inr s.property.1)⟩,
+      (outerClockwiseRegularCurve.continuous.comp continuous_subtype_val).subtype_mk _⟩
+  let s : C(Set.Icc (3 / 4 : ℝ) 1, SpecialPeriods.TriangleRegularPoint) :=
+    ⟨fun u =>
+      (SpecialPeriods.triangleGenerator₁ * SpecialPeriods.triangleGenerator₂) •
+        PeriodFamily.Homology.lowerLift PeriodFamily.Homology.normalizedSlitBaseLift (q u),
+      (SpecialPeriods.triangleRegularProject_covering.continuous_const_smul
+            (SpecialPeriods.triangleGenerator₁ * SpecialPeriods.triangleGenerator₂)).comp
+        ((PeriodFamily.Homology.lowerLift
+              PeriodFamily.Homology.normalizedSlitBaseLift).continuous.comp
+          q.continuous)⟩
+  apply
+    outerLift_interval_unique_mo1973_26683 s _
+      (⟨3 / 4, by constructor <;> norm_num⟩ : Set.Icc (3 / 4 : ℝ) 1) _
+      (⟨t, ht₀, ht₁⟩ : Set.Icc (3 / 4 : ℝ) 1)
+  · intro u
+    exact
+      (SpecialPeriods.triangleRegularProject_covering.map_smul
+            (SpecialPeriods.triangleGenerator₁ * SpecialPeriods.triangleGenerator₂)).trans
+        (PeriodFamily.Homology.lowerLift_project PeriodFamily.Homology.normalizedSlitBaseLift
+          (q u))
+  · exact outerClockwiseLift_threeQuarters_lower_mo1973_26688
+
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseLift_one :
+    outerClockwiseLift 1 = SpecialPeriods.triangleCuspGenerator⁻¹ • outerClockwiseBaseLift := by
+  have h := outerClockwiseLift_lower_final 1 (by norm_num) le_rfl
+  have hb :
+    PeriodFamily.Homology.lowerLift PeriodFamily.Homology.normalizedSlitBaseLift
+        ⟨outerClockwiseRegularCurve 1,
+          outerClockwiseRegularCurve_mem_lower_piece 1 (by norm_num) le_rfl
+            (Or.inr (by norm_num))⟩ =
+      outerClockwiseBaseLift := by
+    apply congrArg (PeriodFamily.Homology.lowerLift PeriodFamily.Homology.normalizedSlitBaseLift)
+    apply Subtype.ext
+    exact outerClockwiseRegularCurve_one
+  rw [hb] at h
+  simpa only [SpecialPeriods.triangleCuspGenerator, inv_inv] using h
+
+private theorem PeriodFamily.Boundary.realSLPermutation_commute_cusp_lower_left (A : SL(2, ℝ))
+    (h :
+      Commute (SpecialPeriods.Triangle.realSLPermutation SpecialPeriods.Triangle.cuspSL)
+        (SpecialPeriods.Triangle.realSLPermutation A)) :
+    A 1 0 = 0 := by
+  have he :
+    SpecialPeriods.Triangle.realSLPermutation (SpecialPeriods.Triangle.cuspSL * A) =
+      SpecialPeriods.Triangle.realSLPermutation (A * SpecialPeriods.Triangle.cuspSL) := by
+    simpa only [map_mul] using h.eq
+  rcases
+    (SpecialPeriods.Triangle.realSLPermutation_eq_iff (SpecialPeriods.Triangle.cuspSL * A)
+          (A * SpecialPeriods.Triangle.cuspSL)).mp
+      he with
+    hp | hm
+  · have he₀ := congrArg (fun B : SL(2, ℝ) => B 0 0) hp
+    simp only [Matrix.SpecialLinearGroup.coe_mul, SpecialPeriods.Triangle.coe_cuspSL,
+      Matrix.mul_apply, Fin.sum_univ_two, Matrix.of_apply, Matrix.cons_val_zero,
+      Matrix.cons_val_one, Matrix.cons_val_fin_one, one_mul, mul_one, MulZeroClass.mul_zero,
+      add_zero] at he₀
+    have hz : SpecialPeriods.Triangle.width * A 1 0 = 0 := by linarith
+    exact (mul_eq_zero.mp hz).resolve_left SpecialPeriods.Triangle.width_ne_zero
+  · have he₁ := congrArg (fun B : SL(2, ℝ) => B 1 0) hm
+    simp only [Matrix.SpecialLinearGroup.coe_mul, SpecialPeriods.Triangle.coe_cuspSL,
+      Matrix.SpecialLinearGroup.coe_neg, Matrix.neg_apply, Matrix.mul_apply, Fin.sum_univ_two,
+      Matrix.of_apply, Matrix.cons_val_zero, Matrix.cons_val_one, Matrix.cons_val_fin_one,
+      one_mul, MulZeroClass.zero_mul, mul_one, MulZeroClass.mul_zero, zero_add, add_zero] at he₁
+    linarith
+
+private theorem PeriodFamily.Boundary.triangleCuspGenerator_commute_mem_zpowers
+    (g : SpecialPeriods.TriangleGroup) (h : Commute SpecialPeriods.triangleCuspGenerator g) :
+    g ∈ Subgroup.zpowers SpecialPeriods.triangleCuspGenerator := by
+  obtain ⟨A, hA⟩ := SpecialPeriods.Triangle.triangleGeometricRepresentation_matrixGroup_lift g
+  apply (SpecialPeriods.Triangle.triangleGeometric_upperTriangular_lift_iff g A hA).mp
+  apply realSLPermutation_commute_cusp_lower_left
+  rw [hA, ← SpecialPeriods.triangleGeometricRepresentation_cusp]
+  exact h.map SpecialPeriods.triangleGeometricRepresentation
+
+private theorem PeriodFamily.Boundary.triangleCuspGenerator_commute_eq_zpow
+    (g : SpecialPeriods.TriangleGroup) (h : Commute SpecialPeriods.triangleCuspGenerator g) :
+    ∃ k : ℤ, g = SpecialPeriods.triangleCuspGenerator ^ k := by
+  obtain ⟨k, hk⟩ := Subgroup.mem_zpowers_iff.mp (triangleCuspGenerator_commute_mem_zpowers g h)
+  exact ⟨k, hk.symm⟩
+
+private theorem
+    PeriodFamily.Boundary.triangleHomologyEquiv_zpow_fixed (g : SpecialPeriods.TriangleGroup)
+    (n : ℕ) (a : SingularMayerVietoris.SingularHomology RealTorus₄ n)
+    (ha : PeriodFamily.Homology.triangleHomologyEquiv g n a = a) (k : ℤ) :
+    PeriodFamily.Homology.triangleHomologyEquiv (g ^ k) n a = a := by
+  cases k with
+  | ofNat k =>
+    simpa only [Int.ofNat_eq_natCast, zpow_natCast] using
+      triangleHomologyEquiv_pow_fixed g n a ha k
+  | negSucc k =>
+    rw [zpow_negSucc, PeriodFamily.Homology.triangleHomologyEquiv_inv]
+    apply (PeriodFamily.Homology.triangleHomologyEquiv (g ^ (k + 1)) n).injective
+    rw [LinearEquiv.apply_symm_apply, triangleHomologyEquiv_pow_fixed g n a ha]
+
+private theorem
+    PeriodFamily.Boundary.cuspCentralizer_homology_fixed (g : SpecialPeriods.TriangleGroup)
+    (h : Commute SpecialPeriods.triangleCuspGenerator g) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n)
+    (ha :
+      PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleCuspGenerator n a = a) :
+    PeriodFamily.Homology.triangleHomologyEquiv g n a = a := by
+  obtain ⟨k, hk⟩ := triangleCuspGenerator_commute_eq_zpow g h
+  rw [hk]
+  exact triangleHomologyEquiv_zpow_fixed SpecialPeriods.triangleCuspGenerator n a ha k
+
+private theorem PeriodFamily.Boundary.cuspCentralizer_inv_homology_fixed
+    (g : SpecialPeriods.TriangleGroup) (h : Commute SpecialPeriods.triangleCuspGenerator g)
+    (n : ℕ) (a : SingularMayerVietoris.SingularHomology RealTorus₄ n)
+    (ha :
+      PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleCuspGenerator n a = a) :
+    PeriodFamily.Homology.triangleHomologyEquiv g⁻¹ n a = a :=
+  cuspCentralizer_homology_fixed g⁻¹ h.inv_right n a ha
+
+private theorem PeriodFamily.Boundary.Cusp.outerClockwiseRegularCurve_eq_periodic :
+    (outerClockwiseRegularCurve : ℝ → SpecialPeriods.TriangleRegularQuotient) =
+      PeriodFamily.BoundaryLoopSquares.loopPeriodic outerClockwiseRegularMeridian :=
+  PeriodFamily.BoundaryLoopSquares.loopPeriodic_unique outerClockwiseRegularCurve
+    outerClockwiseRegularCurve_periodic outerClockwiseRegularCurve_unit
+
+@[simp]
+private theorem PeriodFamily.Boundary.Cusp.nativePeriodicSquare_one (t : ℝ) :
+    nativePeriodicSquare (1, t) = outerClockwiseRegularCurve t :=
+  (PeriodFamily.BoundaryLoopSquares.periodicSquare_final nativeOuterSquare t).trans
+    (congrFun outerClockwiseRegularCurve_eq_periodic t).symm
+
+@[simp]
+private theorem PeriodFamily.Boundary.Cusp.nativeLiftedSquare_final_projection (t : ℝ) :
+    SpecialPeriods.triangleRegularProject (nativeLiftedSquare (1, t)) =
+      outerClockwiseRegularCurve t :=
+  (nativeLiftedSquare_projection 1 t).trans (nativePeriodicSquare_one t)
+
+private theorem PeriodFamily.Boundary.Cusp.nativeLiftedSquare_exists_tailFrame :
+    ∃ d : SpecialPeriods.TriangleGroup, nativeLiftedSquare (1, 0) = d • outerClockwiseBaseLift := by
+  have he :
+    SpecialPeriods.triangleRegularProject (nativeLiftedSquare (1, 0)) =
+      SpecialPeriods.triangleRegularProject outerClockwiseBaseLift :=
+    (nativeLiftedSquare_final_projection 0).trans
+      (outerClockwiseRegularCurve_zero.trans outerClockwiseBaseLift_project.symm)
+  obtain ⟨d, hd⟩ := SpecialPeriods.triangleRegularProject_covering.apply_eq_iff_mem_orbit.mp he
+  exact ⟨d, hd.symm⟩
+
+private def PeriodFamily.Boundary.Cusp.tailFrame : SpecialPeriods.TriangleGroup :=
+  nativeLiftedSquare_exists_tailFrame.choose
+
+private theorem PeriodFamily.Boundary.Cusp.tailFrame_apply :
+    nativeLiftedSquare (1, 0) = tailFrame • outerClockwiseBaseLift :=
+  nativeLiftedSquare_exists_tailFrame.choose_spec
+
+private theorem PeriodFamily.Boundary.Cusp.nativeLiftedSquare_final (t : ℝ) :
+    nativeLiftedSquare (1, t) = tailFrame • outerClockwiseLift t := by
+  have hleft : Continuous (fun u : ℝ => nativeLiftedSquare (1, u)) :=
+    nativeLiftedSquare.continuous.comp (continuous_const.prodMk continuous_id)
+  have hright : Continuous (fun u : ℝ => tailFrame • outerClockwiseLift u) :=
+    (SpecialPeriods.triangleRegularProject_covering.continuous_const_smul tailFrame).comp
+      outerClockwiseLift.continuous
+  have he :
+    SpecialPeriods.triangleRegularProject ∘ (fun u : ℝ => nativeLiftedSquare (1, u)) =
+      SpecialPeriods.triangleRegularProject ∘ (fun u : ℝ => tailFrame • outerClockwiseLift u) := by
+    funext u
+    simp only [Function.comp_apply, nativeLiftedSquare_final_projection,
+      SpecialPeriods.triangleRegularProject_covering.map_smul, outerClockwiseLift_projection]
+  exact
+    congrFun
+      (SpecialPeriods.triangleRegularProject_covering.isCoveringMap.eq_of_comp_eq hleft hright he
+        0 (by simpa only [outerClockwiseLift_zero] using tailFrame_apply))
+      t
+
+private theorem PeriodFamily.Boundary.Cusp.nativeLiftedSquare_final_endpoint :
+    nativeLiftedSquare (1, 1) =
+      SpecialPeriods.triangleCuspGenerator⁻¹ • nativeLiftedSquare (1, 0) := by
+  simpa only [Int.cast_one, zero_add, zpow_neg_one] using nativeLiftedSquare_translate 1 1 0
+
+private theorem PeriodFamily.Boundary.Cusp.tailFrame_inverse_cusp_commute :
+    Commute SpecialPeriods.triangleCuspGenerator⁻¹ tailFrame := by
+  let := SpecialPeriods.triangleRegularProject_covering.isCancelSMul
+  change
+    SpecialPeriods.triangleCuspGenerator⁻¹ * tailFrame =
+      tailFrame * SpecialPeriods.triangleCuspGenerator⁻¹
+  apply IsCancelSMul.right_cancel _ _ outerClockwiseBaseLift
+  calc
+    (SpecialPeriods.triangleCuspGenerator⁻¹ * tailFrame) • outerClockwiseBaseLift =
+        SpecialPeriods.triangleCuspGenerator⁻¹ • nativeLiftedSquare (1, 0) := by
+      rw [SemigroupAction.mul_smul, tailFrame_apply]
+    _ = nativeLiftedSquare (1, 1) := nativeLiftedSquare_final_endpoint.symm
+    _ = tailFrame • outerClockwiseLift 1 := (nativeLiftedSquare_final 1)
+    _ = (tailFrame * SpecialPeriods.triangleCuspGenerator⁻¹) • outerClockwiseBaseLift := by
+      rw [outerClockwiseLift_one, SemigroupAction.mul_smul]
+
+private theorem PeriodFamily.Boundary.Cusp.tailFrame_commute :
+    Commute SpecialPeriods.triangleCuspGenerator tailFrame := by
+  simpa only [inv_inv] using tailFrame_inverse_cusp_commute.inv_left
+
+private theorem PeriodFamily.Boundary.Cusp.nativeLiftedSquare_quarter_frame :
+    nativeLiftedSquare (1, 1 / 4) =
+      (tailFrame * SpecialPeriods.triangleGenerator₁) •
+        PeriodFamily.Homology.upperLiftOnOverlap PeriodFamily.Homology.normalizedSlitBaseLift 0
+          outerClockwiseQuarterPoint := by
+  rw [nativeLiftedSquare_final, outerClockwiseLift_quarter_frame, SemigroupAction.mul_smul]
+
+private theorem PeriodFamily.Boundary.Cusp.nativeLiftedSquare_threeQuarters_frame :
+    nativeLiftedSquare (1, 3 / 4) =
+      (tailFrame * SpecialPeriods.triangleGenerator₁) •
+        PeriodFamily.Homology.upperLiftOnOverlap PeriodFamily.Homology.normalizedSlitBaseLift 2
+          outerClockwiseThreeQuarterPoint := by
+  rw [nativeLiftedSquare_final, outerClockwiseLift_threeQuarters_frame, SemigroupAction.mul_smul]
+
+private def PeriodFamily.Boundary.RefinedWang.U {X : Type} [TopologicalSpace X] (φ : X ≃ₜ X) :
+    Set (MappingTorus.Torus φ) :=
+  MappingTorus.mk φ '' (Set.Ioo (1 / 8 : ℝ) (7 / 8) ×ˢ (Set.univ : Set X))
+
+private def PeriodFamily.Boundary.RefinedWang.V {X : Type} [TopologicalSpace X] (φ : X ≃ₜ X) :
+    Set (MappingTorus.Torus φ) :=
+  MappingTorus.mk φ '' (Set.Ioo (-(3 / 8 : ℝ)) (3 / 8) ×ˢ (Set.univ : Set X))
+
+private theorem
+    PeriodFamily.Boundary.RefinedWang.mem_U_iff {X : Type} [TopologicalSpace X] (φ : X ≃ₜ X)
+    {q : MappingTorus.Torus φ} :
+    q ∈ U φ ↔ ∃ (t : ℝ) (x : X), 1 / 8 < t ∧ t < 7 / 8 ∧ MappingTorus.mk φ (t, x) = q := by
+  constructor
+  · rintro ⟨⟨t, x⟩, ⟨ht, _⟩, hq⟩
+    exact ⟨t, x, ht.1, ht.2, hq⟩
+  · rintro ⟨t, x, ht, ht', hq⟩
+    exact ⟨(t, x), ⟨⟨ht, ht'⟩, Set.mem_univ x⟩, hq⟩
+
+private theorem
+    PeriodFamily.Boundary.RefinedWang.mem_V_iff {X : Type} [TopologicalSpace X] (φ : X ≃ₜ X)
+    {q : MappingTorus.Torus φ} :
+    q ∈ V φ ↔ ∃ (t : ℝ) (x : X), -(3 / 8) < t ∧ t < 3 / 8 ∧ MappingTorus.mk φ (t, x) = q := by
+  constructor
+  · rintro ⟨⟨t, x⟩, ⟨ht, _⟩, hq⟩
+    exact ⟨t, x, ht.1, ht.2, hq⟩
+  · rintro ⟨t, x, ht, ht', hq⟩
+    exact ⟨(t, x), ⟨⟨ht, ht'⟩, Set.mem_univ x⟩, hq⟩
+
+private theorem
+    PeriodFamily.Boundary.RefinedWang.U_open {X : Type} [TopologicalSpace X] (φ : X ≃ₜ X) :
+    IsOpen (U φ) :=
+  MappingTorus.mk_open φ _ (isOpen_Ioo.prod isOpen_univ)
+
+private theorem
+    PeriodFamily.Boundary.RefinedWang.V_open {X : Type} [TopologicalSpace X] (φ : X ≃ₜ X) :
+    IsOpen (V φ) :=
+  MappingTorus.mk_open φ _ (isOpen_Ioo.prod isOpen_univ)
+
+private theorem
+    PeriodFamily.Boundary.RefinedWang.U_subset {X : Type} [TopologicalSpace X] (φ : X ≃ₜ X) :
+    U φ ⊆ MappingTorus.HomologyCover.U φ := by
+  intro q hq
+  obtain ⟨t, x, ht, ht', rfl⟩ := (mem_U_iff φ).mp hq
+  exact MappingTorus.base_mk_ne_of_mem_Ioo φ 0 ⟨t, by constructor <;> linarith⟩ x
+
+private theorem
+    PeriodFamily.Boundary.RefinedWang.V_subset {X : Type} [TopologicalSpace X] (φ : X ≃ₜ X) :
+    V φ ⊆ MappingTorus.HomologyCover.V φ := by
+  intro q hq
+  obtain ⟨t, x, ht, ht', rfl⟩ := (mem_V_iff φ).mp hq
+  exact MappingTorus.base_mk_ne_of_mem_Ioo φ (-(1 / 2 : ℝ)) ⟨t, by constructor <;> linarith⟩ x
+
+private theorem
+    PeriodFamily.Boundary.RefinedWang.cover {X : Type} [TopologicalSpace X] (φ : X ≃ₜ X) :
+    U φ ∪ V φ = Set.univ := by
+  apply Set.eq_univ_of_forall
+  intro q
+  have hq : q ∈ MappingTorus.HomologyCover.U φ ∪ MappingTorus.HomologyCover.V φ := by
+    rw [MappingTorus.HomologyCover.cover]
+    exact Set.mem_univ q
+  rcases hq with hq | hq
+  · let p := MappingTorus.HomologyCover.chartU φ ⟨q, hq⟩
+    let t : ℝ := p.1
+    have ht : 0 < t ∧ t < 1 := p.1.property
+    have hp : MappingTorus.mk φ (t, p.2) = q :=
+      MappingTorus.HomologyCover.chartU_representation φ ⟨q, hq⟩
+    by_cases hu : 1 / 8 < t ∧ t < 7 / 8
+    · exact Or.inl ((mem_U_iff φ).mpr ⟨t, p.2, hu.1, hu.2, hp⟩)
+    · apply Or.inr
+      apply (mem_V_iff φ).mpr
+      by_cases hs : t < 3 / 8
+      · exact ⟨t, p.2, by linarith, hs, hp⟩
+      · have hl : 7 / 8 ≤ t := by
+          by_contra hl
+          apply hu
+          constructor <;> linarith
+        exact ⟨t - 1, φ p.2, by linarith, by linarith, (MappingTorus.mk_sub_one φ t p.2).trans hp⟩
+  · let p := MappingTorus.HomologyCover.chartV φ ⟨q, hq⟩
+    let t : ℝ := p.1
+    have ht : -(1 / 2) < t ∧ t < 1 / 2 := p.1.property
+    have hp : MappingTorus.mk φ (t, p.2) = q :=
+      MappingTorus.HomologyCover.chartV_representation φ ⟨q, hq⟩
+    by_cases hv : -(3 / 8) < t ∧ t < 3 / 8
+    · exact Or.inr ((mem_V_iff φ).mpr ⟨t, p.2, hv.1, hv.2, hp⟩)
+    · apply Or.inl
+      apply (mem_U_iff φ).mpr
+      by_cases hs : 1 / 8 < t
+      · exact ⟨t, p.2, hs, by linarith, hp⟩
+      · have hl : t ≤ -(3 / 8) := by
+          by_contra hl
+          apply hv
+          constructor <;> linarith
+        refine ⟨t + 1, φ.symm p.2, by linarith, by linarith, ?_⟩
+        exact
+          (MappingTorus.mk_add_one φ t (φ.symm p.2)).trans
+            (by simpa only [Homeomorph.apply_symm_apply] using hp)
+
+private def PeriodFamily.Boundary.RefinedWang.intersectionInclusion {X : Type} [TopologicalSpace X]
+    (φ : X ≃ₜ X) :
+    C(↥(U φ ∩ V φ), ↥(MappingTorus.HomologyCover.U φ ∩ MappingTorus.HomologyCover.V φ)) :=
+  ContinuousMap.inclusion (Set.inter_subset_inter (U_subset φ) (V_subset φ))
+
+private abbrev PeriodFamily.Boundary.RefinedWang.LowerInterval :=
+  Set.Ioo (1 / 8 : ℝ) (3 / 8)
+
+private abbrev PeriodFamily.Boundary.RefinedWang.UpperInterval :=
+  Set.Ioo (5 / 8 : ℝ) (7 / 8)
+
+private def PeriodFamily.Boundary.RefinedWang.lowerParam_mo1973_26734 {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (p : LowerInterval × X) : ↥(U φ ∩ V φ) :=
+  ⟨MappingTorus.mk φ ((p.1 : ℝ), p.2),
+    (mem_U_iff φ).mpr ⟨p.1, p.2, p.1.property.1, by linarith [p.1.property.2], rfl⟩,
+    (mem_V_iff φ).mpr ⟨p.1, p.2, by linarith [p.1.property.1], p.1.property.2, rfl⟩⟩
+
+private def PeriodFamily.Boundary.RefinedWang.upperParam_mo1973_26735 {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (p : UpperInterval × X) : ↥(U φ ∩ V φ) :=
+  ⟨MappingTorus.mk φ ((p.1 : ℝ), p.2),
+    (mem_U_iff φ).mpr ⟨p.1, p.2, by linarith [p.1.property.1], p.1.property.2, rfl⟩,
+    (mem_V_iff φ).mpr
+      ⟨(p.1 : ℝ) - 1, φ p.2, by linarith [p.1.property.1], by linarith [p.1.property.2],
+        MappingTorus.mk_sub_one φ (p.1 : ℝ) p.2⟩⟩
+
+private theorem PeriodFamily.Boundary.RefinedWang.lowerParam_continuous_mo1973_26736 {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) : Continuous (lowerParam_mo1973_26734 φ) :=
+  ((MappingTorus.mk_continuous φ).comp
+        ((continuous_subtype_val.comp continuous_fst).prodMk continuous_snd)).subtype_mk
+    _
+
+private theorem PeriodFamily.Boundary.RefinedWang.upperParam_continuous_mo1973_26737 {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) : Continuous (upperParam_mo1973_26735 φ) :=
+  ((MappingTorus.mk_continuous φ).comp
+        ((continuous_subtype_val.comp continuous_fst).prodMk continuous_snd)).subtype_mk
+    _
+
+private theorem PeriodFamily.Boundary.RefinedWang.lowerParam_open_mo1973_26738 {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) : IsOpenMap (lowerParam_mo1973_26734 φ) :=
+  ((MappingTorus.mk_open φ).comp
+        (isOpen_Ioo.isOpenMap_subtype_val.prodMap IsOpenMap.id)).subtype_mk
+    _
+
+private theorem PeriodFamily.Boundary.RefinedWang.upperParam_open_mo1973_26739 {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) : IsOpenMap (upperParam_mo1973_26735 φ) :=
+  ((MappingTorus.mk_open φ).comp
+        (isOpen_Ioo.isOpenMap_subtype_val.prodMap IsOpenMap.id)).subtype_mk
+    _
+
+private theorem PeriodFamily.Boundary.RefinedWang.lowerParam_inclusion_mo1973_26740 {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (p : LowerInterval × X) :
+    intersectionInclusion φ (lowerParam_mo1973_26734 φ p) =
+      (MappingTorus.HomologyCover.intersectionHomeomorph φ).symm
+        (Sum.inl
+          (⟨(p.1 : ℝ), by constructor <;> linarith [p.1.property.1, p.1.property.2]⟩, p.2)) := by
+  apply Subtype.ext
+  rw [MappingTorus.HomologyCover.intersectionHomeomorph_symm_inl_coe]
+  rfl
+
+private theorem PeriodFamily.Boundary.RefinedWang.upperParam_inclusion_mo1973_26741 {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (p : UpperInterval × X) :
+    intersectionInclusion φ (upperParam_mo1973_26735 φ p) =
+      (MappingTorus.HomologyCover.intersectionHomeomorph φ).symm
+        (Sum.inr
+          (⟨(p.1 : ℝ), by constructor <;> linarith [p.1.property.1, p.1.property.2]⟩, p.2)) := by
+  apply Subtype.ext
+  rw [MappingTorus.HomologyCover.intersectionHomeomorph_symm_inr_coe]
+  rfl
+
+private theorem PeriodFamily.Boundary.RefinedWang.lowerParam_oldChart_mo1973_26742 {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (p : LowerInterval × X) :
+    MappingTorus.HomologyCover.intersectionHomeomorph φ
+        (intersectionInclusion φ (lowerParam_mo1973_26734 φ p)) =
+      Sum.inl (⟨(p.1 : ℝ), by constructor <;> linarith [p.1.property.1, p.1.property.2]⟩, p.2) := by
+  rw [lowerParam_inclusion_mo1973_26740, Homeomorph.apply_symm_apply]
+
+private theorem PeriodFamily.Boundary.RefinedWang.upperParam_oldChart_mo1973_26743 {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (p : UpperInterval × X) :
+    MappingTorus.HomologyCover.intersectionHomeomorph φ
+        (intersectionInclusion φ (upperParam_mo1973_26735 φ p)) =
+      Sum.inr (⟨(p.1 : ℝ), by constructor <;> linarith [p.1.property.1, p.1.property.2]⟩, p.2) := by
+  rw [upperParam_inclusion_mo1973_26741, Homeomorph.apply_symm_apply]
+
+private def PeriodFamily.Boundary.RefinedWang.intersectionParam_mo1973_26744 {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) :
+    ((LowerInterval × X) ⊕ (UpperInterval × X)) → ↥(U φ ∩ V φ) :=
+  Sum.elim (lowerParam_mo1973_26734 φ) (upperParam_mo1973_26735 φ)
+
+private theorem PeriodFamily.Boundary.RefinedWang.intersectionParam_injective_mo1973_26745
+    {X : Type} [TopologicalSpace X] (φ : X ≃ₜ X) :
+    Function.Injective (intersectionParam_mo1973_26744 φ) := by
+  intro p q hpq
+  have he :=
+    congrArg
+      (fun q => MappingTorus.HomologyCover.intersectionHomeomorph φ (intersectionInclusion φ q))
+      hpq
+  cases p with
+  | inl p =>
+    cases q with
+    | inl
+      q =>
+      simp only [intersectionParam_mo1973_26744, Sum.elim_inl, lowerParam_oldChart_mo1973_26742,
+        Sum.inl.injEq, Prod.mk.injEq] at he
+      have ht : (p.1 : ℝ) = (q.1 : ℝ) :=
+        congrArg (fun z : Set.Ioo (0 : ℝ) (1 / 2) => (z : ℝ)) he.1
+      exact congrArg Sum.inl (Prod.ext (Subtype.ext ht) he.2)
+    | inr q =>
+      simp only [intersectionParam_mo1973_26744, Sum.elim_inl, Sum.elim_inr,
+        lowerParam_oldChart_mo1973_26742, upperParam_oldChart_mo1973_26743, Sum.inl_ne_inr] at he
+  | inr p =>
+    cases q with
+    | inl q =>
+      simp only [intersectionParam_mo1973_26744, Sum.elim_inl, Sum.elim_inr,
+        lowerParam_oldChart_mo1973_26742, upperParam_oldChart_mo1973_26743, Sum.inr_ne_inl] at he
+    | inr
+      q =>
+      simp only [intersectionParam_mo1973_26744, Sum.elim_inr, upperParam_oldChart_mo1973_26743,
+        Sum.inr.injEq, Prod.mk.injEq] at he
+      have ht : (p.1 : ℝ) = (q.1 : ℝ) := congrArg (fun z : Set.Ioo (1 / 2 : ℝ) 1 => (z : ℝ)) he.1
+      exact congrArg Sum.inr (Prod.ext (Subtype.ext ht) he.2)
+
+private theorem PeriodFamily.Boundary.RefinedWang.intersectionParam_surjective_mo1973_26746
+    {X : Type} [TopologicalSpace X] (φ : X ≃ₜ X) :
+    Function.Surjective (intersectionParam_mo1973_26744 φ) := by
+  intro q
+  obtain ⟨t, x, ht, ht', hu⟩ := (mem_U_iff φ).mp q.property.1
+  obtain ⟨s, y, hs, hs', hv⟩ := (mem_V_iff φ).mp q.property.2
+  obtain ⟨n, hn, _⟩ := (MappingTorus.mk_eq_mk_iff φ (t, x) (s, y)).mp (hu.trans hv.symm)
+  dsimp only at hn
+  have hnloR : (-2 : ℝ) < (n : ℝ) := by linarith
+  have hnhiR : (n : ℝ) < 1 := by linarith
+  have hnlo : (-2 : ℤ) < n := by exact_mod_cast hnloR
+  have hnhi : n < 1 := by exact_mod_cast hnhiR
+  have hn0 : n = 0 ∨ n = -1 := by omega
+  rcases hn0 with rfl | rfl
+  · simp only [Int.cast_zero, add_zero] at hn
+    refine ⟨Sum.inl (⟨t, ht, by linarith⟩, x), ?_⟩
+    exact Subtype.ext hu
+  · simp only [Int.cast_neg, Int.cast_one] at hn
+    refine ⟨Sum.inr (⟨t, by linarith, ht'⟩, x), ?_⟩
+    exact Subtype.ext hu
+
+private def PeriodFamily.Boundary.RefinedWang.intersectionHomeomorph {X : Type} [TopologicalSpace X]
+    (φ : X ≃ₜ X) : ↥(U φ ∩ V φ) ≃ₜ ((LowerInterval × X) ⊕ (UpperInterval × X)) :=
+  ((Equiv.ofBijective (intersectionParam_mo1973_26744 φ)
+          ⟨intersectionParam_injective_mo1973_26745 φ,
+            intersectionParam_surjective_mo1973_26746 φ⟩).toHomeomorphOfContinuousOpen
+      ((lowerParam_continuous_mo1973_26736 φ).sumElim (upperParam_continuous_mo1973_26737 φ))
+      ((lowerParam_open_mo1973_26738 φ).sumElim (upperParam_open_mo1973_26739 φ))).symm
+
+@[simp]
+private theorem PeriodFamily.Boundary.RefinedWang.intersectionHomeomorph_symm_inl_coe {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (p : LowerInterval × X) :
+    ((intersectionHomeomorph φ).symm (Sum.inl p) : MappingTorus.Torus φ) =
+      MappingTorus.mk φ ((p.1 : ℝ), p.2) :=
+  rfl
+
+@[simp]
+private theorem PeriodFamily.Boundary.RefinedWang.intersectionHomeomorph_symm_inr_coe {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (p : UpperInterval × X) :
+    ((intersectionHomeomorph φ).symm (Sum.inr p) : MappingTorus.Torus φ) =
+      MappingTorus.mk φ ((p.1 : ℝ), p.2) :=
+  rfl
+
+private theorem
+    PeriodFamily.Boundary.RefinedWang.intersectionHomeomorph_symm_inl_inclusion {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (p : LowerInterval × X) :
+    intersectionInclusion φ ((intersectionHomeomorph φ).symm (Sum.inl p)) =
+      (MappingTorus.HomologyCover.intersectionHomeomorph φ).symm
+        (Sum.inl
+          (⟨(p.1 : ℝ), by constructor <;> linarith [p.1.property.1, p.1.property.2]⟩, p.2)) :=
+  lowerParam_inclusion_mo1973_26740 φ p
+
+private theorem
+    PeriodFamily.Boundary.RefinedWang.intersectionHomeomorph_symm_inr_inclusion {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (p : UpperInterval × X) :
+    intersectionInclusion φ ((intersectionHomeomorph φ).symm (Sum.inr p)) =
+      (MappingTorus.HomologyCover.intersectionHomeomorph φ).symm
+        (Sum.inr
+          (⟨(p.1 : ℝ), by constructor <;> linarith [p.1.property.1, p.1.property.2]⟩, p.2)) :=
+  upperParam_inclusion_mo1973_26741 φ p
+
+private def
+    PeriodFamily.Boundary.RefinedWang.intersectionHomotopyEquiv {X : Type} [TopologicalSpace X]
+    (φ : X ≃ₜ X) : ↥(U φ ∩ V φ) ≃ₕ X ⊕ X := by
+  letI : ContractibleSpace LowerInterval :=
+    PeriodTorusHigherHomology.CircleTopology.intervalContractible (1 / 8 : ℝ) (3 / 8)
+      (by norm_num)
+  letI : ContractibleSpace UpperInterval :=
+    PeriodTorusHigherHomology.CircleTopology.intervalContractible (5 / 8 : ℝ) (7 / 8)
+      (by norm_num)
+  exact
+    (intersectionHomeomorph φ).toHomotopyEquiv.trans
+      (PeriodTorusHigherHomology.CircleTopology.sumHomotopyEquiv
+        (PeriodTorusHigherHomology.CircleTopology.contractibleProdHomotopyEquiv LowerInterval X)
+        (PeriodTorusHigherHomology.CircleTopology.contractibleProdHomotopyEquiv UpperInterval X))
+
+@[simp]
+private theorem PeriodFamily.Boundary.RefinedWang.intersectionHomotopyEquiv_inl {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (p : LowerInterval × X) :
+    intersectionHomotopyEquiv φ ((intersectionHomeomorph φ).symm (Sum.inl p)) = Sum.inl p.2 := by
+  change
+    Sum.map (fun p : LowerInterval × X => p.2) (fun p : UpperInterval × X => p.2)
+        (intersectionHomeomorph φ ((intersectionHomeomorph φ).symm (Sum.inl p))) =
+      _
+  rw [Homeomorph.apply_symm_apply]
+  rfl
+
+@[simp]
+private theorem PeriodFamily.Boundary.RefinedWang.intersectionHomotopyEquiv_inr {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (p : UpperInterval × X) :
+    intersectionHomotopyEquiv φ ((intersectionHomeomorph φ).symm (Sum.inr p)) = Sum.inr p.2 := by
+  change
+    Sum.map (fun p : LowerInterval × X => p.2) (fun p : UpperInterval × X => p.2)
+        (intersectionHomeomorph φ ((intersectionHomeomorph φ).symm (Sum.inr p))) =
+      _
+  rw [Homeomorph.apply_symm_apply]
+  rfl
+
+private theorem PeriodFamily.Boundary.RefinedWang.intersectionHomotopyEquiv_inclusion {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) :
+    (MappingTorus.HomologyCover.intersectionHomotopyEquiv φ).toFun.comp
+        (intersectionInclusion φ) =
+      (intersectionHomotopyEquiv φ).toFun := by
+  apply ContinuousMap.ext
+  intro q
+  obtain ⟨p, rfl⟩ := (intersectionHomeomorph φ).symm.surjective q
+  cases p with
+  | inl
+    p =>
+    change
+      MappingTorus.HomologyCover.intersectionHomotopyEquiv φ
+          (intersectionInclusion φ ((intersectionHomeomorph φ).symm (Sum.inl p))) =
+        intersectionHomotopyEquiv φ ((intersectionHomeomorph φ).symm (Sum.inl p))
+    rw [intersectionHomeomorph_symm_inl_inclusion,
+      MappingTorus.HomologyCover.intersectionHomotopyEquiv_inl, intersectionHomotopyEquiv_inl]
+  | inr
+    p =>
+    change
+      MappingTorus.HomologyCover.intersectionHomotopyEquiv φ
+          (intersectionInclusion φ ((intersectionHomeomorph φ).symm (Sum.inr p))) =
+        intersectionHomotopyEquiv φ ((intersectionHomeomorph φ).symm (Sum.inr p))
+    rw [intersectionHomeomorph_symm_inr_inclusion,
+      MappingTorus.HomologyCover.intersectionHomotopyEquiv_inr, intersectionHomotopyEquiv_inr]
+
+private def PeriodFamily.Boundary.RefinedWang.lowerComponentTime : LowerInterval :=
+  ⟨1 / 4, by constructor <;> norm_num⟩
+
+private def PeriodFamily.Boundary.RefinedWang.upperComponentTime : UpperInterval :=
+  ⟨3 / 4, by constructor <;> norm_num⟩
+
+private def PeriodFamily.Boundary.RefinedWang.lowerComponentFibre {X : Type} [TopologicalSpace X]
+    (φ : X ≃ₜ X) : C(X, ↥(U φ ∩ V φ))
+    where
+  toFun x := (intersectionHomeomorph φ).symm (Sum.inl (lowerComponentTime, x))
+  continuous_toFun :=
+    (intersectionHomeomorph φ).symm.continuous.comp
+      (continuous_inl.comp (continuous_const.prodMk continuous_id))
+
+private def PeriodFamily.Boundary.RefinedWang.upperComponentFibre {X : Type} [TopologicalSpace X]
+    (φ : X ≃ₜ X) : C(X, ↥(U φ ∩ V φ))
+    where
+  toFun x := (intersectionHomeomorph φ).symm (Sum.inr (upperComponentTime, x))
+  continuous_toFun :=
+    (intersectionHomeomorph φ).symm.continuous.comp
+      (continuous_inr.comp (continuous_const.prodMk continuous_id))
+
+@[simp]
+private theorem
+    PeriodFamily.Boundary.RefinedWang.lowerComponentFibre_coe {X : Type} [TopologicalSpace X]
+    (φ : X ≃ₜ X) (x : X) : (lowerComponentFibre φ x).val = MappingTorus.mk φ (1 / 4, x) :=
+  intersectionHomeomorph_symm_inl_coe φ (lowerComponentTime, x)
+
+@[simp]
+private theorem
+    PeriodFamily.Boundary.RefinedWang.upperComponentFibre_coe {X : Type} [TopologicalSpace X]
+    (φ : X ≃ₜ X) (x : X) : (upperComponentFibre φ x).val = MappingTorus.mk φ (3 / 4, x) :=
+  intersectionHomeomorph_symm_inr_coe φ (upperComponentTime, x)
+
+private theorem PeriodFamily.Boundary.RefinedWang.lowerComponentFibre_retraction {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) :
+    (intersectionHomotopyEquiv φ).toFun.comp (lowerComponentFibre φ) =
+      PeriodTorusHigherHomology.sumInlMap X X := by
+  apply ContinuousMap.ext
+  intro x
+  exact intersectionHomotopyEquiv_inl φ (lowerComponentTime, x)
+
+private theorem PeriodFamily.Boundary.RefinedWang.upperComponentFibre_retraction {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) :
+    (intersectionHomotopyEquiv φ).toFun.comp (upperComponentFibre φ) =
+      PeriodTorusHigherHomology.sumInrMap X X := by
+  apply ContinuousMap.ext
+  intro x
+  exact intersectionHomotopyEquiv_inr φ (upperComponentTime, x)
+
+private def
+    PeriodFamily.Boundary.RefinedWang.intersectionHomologyEquiv {X : Type} [TopologicalSpace X]
+    (φ : X ≃ₜ X) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (U φ ∩ V φ : Set (MappingTorus.Torus φ)) n ≃ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology X n × SingularMayerVietoris.SingularHomology X n) :=
+  (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (intersectionHomotopyEquiv φ) n).trans
+    (PeriodTorusHigherHomology.sumHomologyEquiv X X n)
+
+@[simp]
+private theorem PeriodFamily.Boundary.RefinedWang.intersectionHomologyEquiv_apply {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (U φ ∩ V φ : Set (MappingTorus.Torus φ)) n) :
+    intersectionHomologyEquiv φ n a =
+      PeriodTorusHigherHomology.sumHomologyEquiv X X n
+        (SingularMayerVietoris.singularHomologyMap (intersectionHomotopyEquiv φ).toFun n a) :=
+  rfl
+
+private theorem PeriodFamily.Boundary.RefinedWang.intersectionHomologyEquiv_inclusion {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (U φ ∩ V φ : Set (MappingTorus.Torus φ)) n) :
+    MappingTorusHomology.intersectionHomologyEquiv φ n
+        (SingularMayerVietoris.singularHomologyMap (intersectionInclusion φ) n a) =
+      intersectionHomologyEquiv φ n a := by
+  rw [MappingTorusHomology.intersectionHomologyEquiv_apply, intersectionHomologyEquiv_apply]
+  have h :=
+    congrArg (fun f => SingularMayerVietoris.singularHomologyMap f n)
+      (intersectionHomotopyEquiv_inclusion φ)
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp] at h
+  exact congrArg (PeriodTorusHigherHomology.sumHomologyEquiv X X n) (LinearMap.congr_fun h a)
+
+private theorem PeriodFamily.Boundary.RefinedWang.intersectionInclusion_eq_intersectionRestriction
+    {X : Type} [TopologicalSpace X] (φ : X ≃ₜ X) :
+    intersectionInclusion φ =
+      SingularMayerVietoris.intersectionRestriction (ContinuousMap.id (MappingTorus.Torus φ))
+        (U φ) (V φ) (MappingTorus.HomologyCover.U φ) (MappingTorus.HomologyCover.V φ) (U_subset φ)
+        (V_subset φ) := by
+  apply ContinuousMap.ext
+  intro x
+  apply Subtype.ext
+  rfl
+
+private abbrev
+    PeriodFamily.Boundary.RefinedWang.mayerVietorisConnecting {X : Type} [TopologicalSpace X]
+    (φ : X ≃ₜ X) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (MappingTorus.Torus φ) (n + 1) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (U φ ∩ V φ : Set (MappingTorus.Torus φ)) n :=
+  SingularMayerVietoris.connectingHomomorphism (U φ) (V φ) (U_open φ) (V_open φ) (cover φ) n
+
+private theorem PeriodFamily.Boundary.RefinedWang.mayerVietorisConnecting_refinement {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus φ) (n + 1)) :
+    SingularMayerVietoris.singularHomologyMap (intersectionInclusion φ) n
+        (mayerVietorisConnecting φ n a) =
+      MappingTorusHomology.mayerVietorisConnecting φ n a := by
+  have h :=
+    SingularMayerVietoris.connectingHomomorphism_naturality_apply
+      (ContinuousMap.id (MappingTorus.Torus φ)) (U φ) (V φ) (MappingTorus.HomologyCover.U φ)
+      (MappingTorus.HomologyCover.V φ) (U_subset φ) (V_subset φ) (U_open φ) (V_open φ) (cover φ)
+      (MappingTorus.HomologyCover.U_open φ) (MappingTorus.HomologyCover.V_open φ)
+      (MappingTorus.HomologyCover.cover φ) n a
+  rw [← intersectionInclusion_eq_intersectionRestriction,
+    PeriodTorusHigherHomology.singularHomologyMap_id, LinearMap.id_apply] at h
+  exact h
+
+private def PeriodFamily.Boundary.RefinedWang.boundaryCoordinates {X : Type} [TopologicalSpace X]
+    (φ : X ≃ₜ X) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (MappingTorus.Torus φ) (n + 1) →ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology X n × SingularMayerVietoris.SingularHomology X n) :=
+  (intersectionHomologyEquiv φ n).toLinearMap.comp (mayerVietorisConnecting φ n)
+
+@[simp]
+private theorem PeriodFamily.Boundary.RefinedWang.boundaryCoordinates_apply {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus φ) (n + 1)) :
+    boundaryCoordinates φ n a = intersectionHomologyEquiv φ n (mayerVietorisConnecting φ n a) :=
+  rfl
+
+private theorem PeriodFamily.Boundary.RefinedWang.boundaryCoordinates_refinement {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus φ) (n + 1)) :
+    boundaryCoordinates φ n a = MappingTorusHomology.boundaryCoordinates φ n a := by
+  rw [boundaryCoordinates_apply, ← intersectionHomologyEquiv_inclusion,
+    mayerVietorisConnecting_refinement]
+  rfl
+
+private theorem PeriodFamily.Boundary.RefinedWang.boundaryCoordinates_eq_antidiagonal {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus φ) (n + 1)) :
+    boundaryCoordinates φ n a =
+      (-MappingTorusHomology.wangBoundary φ n a, MappingTorusHomology.wangBoundary φ n a) :=
+  (boundaryCoordinates_refinement φ n a).trans
+    (MappingTorusHomology.boundaryCoordinates_eq_antidiagonal φ n a)
+
+private theorem
+    PeriodFamily.Boundary.RefinedWang.mappingTorusConnecting_eq_marked_boundary {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus φ) (n + 1)) :
+    mayerVietorisConnecting φ n a =
+      (intersectionHomologyEquiv φ n).symm
+        (-MappingTorusHomology.wangBoundary φ n a, MappingTorusHomology.wangBoundary φ n a) := by
+  apply (intersectionHomologyEquiv φ n).injective
+  rw [LinearEquiv.apply_symm_apply]
+  exact boundaryCoordinates_eq_antidiagonal φ n a
+
+private theorem PeriodFamily.Boundary.RefinedWang.lowerComponentFibre_homology {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    intersectionHomologyEquiv φ n
+        (SingularMayerVietoris.singularHomologyMap (lowerComponentFibre φ) n a) =
+      (a, 0) := by
+  rw [intersectionHomologyEquiv_apply, ← LinearMap.comp_apply, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp, lowerComponentFibre_retraction,
+    PeriodTorusHigherHomology.sumHomologyEquiv_inl]
+
+private theorem PeriodFamily.Boundary.RefinedWang.upperComponentFibre_homology {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    intersectionHomologyEquiv φ n
+        (SingularMayerVietoris.singularHomologyMap (upperComponentFibre φ) n a) =
+      (0, a) := by
+  rw [intersectionHomologyEquiv_apply, ← LinearMap.comp_apply, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp, upperComponentFibre_retraction,
+    PeriodTorusHigherHomology.sumHomologyEquiv_inr]
+
+@[simp]
+private theorem PeriodFamily.Boundary.RefinedWang.intersectionHomologyEquiv_symm_lower {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    (intersectionHomologyEquiv φ n).symm (a, 0) =
+      SingularMayerVietoris.singularHomologyMap (lowerComponentFibre φ) n a := by
+  apply (intersectionHomologyEquiv φ n).injective
+  rw [LinearEquiv.apply_symm_apply, lowerComponentFibre_homology]
+
+@[simp]
+private theorem PeriodFamily.Boundary.RefinedWang.intersectionHomologyEquiv_symm_upper {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    (intersectionHomologyEquiv φ n).symm (0, a) =
+      SingularMayerVietoris.singularHomologyMap (upperComponentFibre φ) n a := by
+  apply (intersectionHomologyEquiv φ n).injective
+  rw [LinearEquiv.apply_symm_apply, upperComponentFibre_homology]
+
+private def PeriodFamily.Boundary.RefinedWang.intersectionMap {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (φ : X ≃ₜ X)
+    (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (V φ) (PeriodFamily.Homology.lowerFamily D)) :
+    C((U φ ∩ V φ : Set (MappingTorus.Torus φ)), PeriodFamily.Homology.familyIntersection D) :=
+  SingularMayerVietoris.intersectionRestriction F (U φ) (V φ)
+    (PeriodFamily.Homology.upperFamily D) (PeriodFamily.Homology.lowerFamily D) hU hV
+
+private theorem PeriodFamily.Boundary.RefinedWang.markedConnecting_naturality {X : Type}
+    [TopologicalSpace X] (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (φ : X ≃ₜ X) (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (V φ) (PeriodFamily.Homology.lowerFamily D))
+    (b : PeriodFamily.Homology.SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus φ) (n + 1)) :
+    PeriodFamily.Homology.familyMarkedConnecting D b n
+        (SingularMayerVietoris.singularHomologyMap F (n + 1) a) =
+      PeriodFamily.Homology.intersectionHomologyEquiv D b n
+        (SingularMayerVietoris.singularHomologyMap (intersectionMap D φ F hU hV) n
+          (mayerVietorisConnecting φ n a)) := by
+  have h :=
+    SingularMayerVietoris.connectingHomomorphism_naturality_apply F (U φ) (V φ)
+      (PeriodFamily.Homology.upperFamily D) (PeriodFamily.Homology.lowerFamily D) hU hV (U_open φ)
+      (V_open φ) (cover φ) (PeriodFamily.Homology.upperFamily D).isOpen
+      (PeriodFamily.Homology.lowerFamily D).isOpen
+      (PeriodFamily.Homology.upperFamily_union_lowerFamily D) n a
+  exact (congrArg (PeriodFamily.Homology.intersectionHomologyEquiv D b n) h).symm
+
+private def PeriodFamily.Boundary.RefinedWang.intersectionComparison {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (φ : X ≃ₜ X)
+    (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (V φ) (PeriodFamily.Homology.lowerFamily D))
+    (b : PeriodFamily.Homology.SlitBaseLift) (n : ℕ) :
+    (SingularMayerVietoris.SingularHomology X n ×
+        SingularMayerVietoris.SingularHomology X n) →ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+        (SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+          SingularMayerVietoris.SingularHomology RealTorus₄ n)) :=
+  (PeriodFamily.Homology.intersectionHomologyEquiv D b n).toLinearMap.comp
+    ((SingularMayerVietoris.singularHomologyMap (intersectionMap D φ F hU hV) n).comp
+      (intersectionHomologyEquiv φ n).symm.toLinearMap)
+
+@[simp]
+private theorem PeriodFamily.Boundary.RefinedWang.intersectionComparison_apply {X : Type}
+    [TopologicalSpace X] (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (φ : X ≃ₜ X) (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (V φ) (PeriodFamily.Homology.lowerFamily D))
+    (b : PeriodFamily.Homology.SlitBaseLift) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology X n × SingularMayerVietoris.SingularHomology X n) :
+    intersectionComparison D φ F hU hV b n a =
+      PeriodFamily.Homology.intersectionHomologyEquiv D b n
+        (SingularMayerVietoris.singularHomologyMap (intersectionMap D φ F hU hV) n
+          ((intersectionHomologyEquiv φ n).symm a)) :=
+  rfl
+
+private theorem PeriodFamily.Boundary.RefinedWang.markedConnecting_wangBoundary {X : Type}
+    [TopologicalSpace X] (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (φ : X ≃ₜ X) (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (V φ) (PeriodFamily.Homology.lowerFamily D))
+    (b : PeriodFamily.Homology.SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus φ) (n + 1)) :
+    PeriodFamily.Homology.familyMarkedConnecting D b n
+        (SingularMayerVietoris.singularHomologyMap F (n + 1) a) =
+      intersectionComparison D φ F hU hV b n
+        (-MappingTorusHomology.wangBoundary φ n a, MappingTorusHomology.wangBoundary φ n a) := by
+  refine (markedConnecting_naturality D φ F hU hV b n a).trans ?_
+  exact
+    congrArg
+      (fun z =>
+        PeriodFamily.Homology.intersectionHomologyEquiv D b n
+          (SingularMayerVietoris.singularHomologyMap (intersectionMap D φ F hU hV) n z))
+      (mappingTorusConnecting_eq_marked_boundary φ n a)
+
+private theorem PeriodFamily.Boundary.RefinedWang.intersectionComparison_antidiagonal {X : Type}
+    [TopologicalSpace X] (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (φ : X ≃ₜ X) (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (V φ) (PeriodFamily.Homology.lowerFamily D))
+    (b : PeriodFamily.Homology.SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology X n) :
+    intersectionComparison D φ F hU hV b n (-a, a) =
+      -intersectionComparison D φ F hU hV b n (a, 0) +
+        intersectionComparison D φ F hU hV b n (0, a) := by
+  have h : (-a, a) = -(a, (0 : SingularMayerVietoris.SingularHomology X n)) + (0, a) := by
+    ext <;> simp
+  rw [h, map_add, map_neg]
+
+private def PeriodFamily.Boundary.RefinedWang.lowerColumnMap {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (φ : X ≃ₜ X)
+    (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (V φ) (PeriodFamily.Homology.lowerFamily D)) :
+    C(X, PeriodFamily.Homology.familyIntersection D) :=
+  (intersectionMap D φ F hU hV).comp (lowerComponentFibre φ)
+
+private def PeriodFamily.Boundary.RefinedWang.upperColumnMap {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (φ : X ≃ₜ X)
+    (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (V φ) (PeriodFamily.Homology.lowerFamily D)) :
+    C(X, PeriodFamily.Homology.familyIntersection D) :=
+  (intersectionMap D φ F hU hV).comp (upperComponentFibre φ)
+
+@[simp]
+private theorem PeriodFamily.Boundary.RefinedWang.lowerColumnMap_coe {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (φ : X ≃ₜ X)
+    (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (V φ) (PeriodFamily.Homology.lowerFamily D)) (x : X) :
+    (lowerColumnMap D φ F hU hV x).val = F (MappingTorus.mk φ (1 / 4, x)) := by
+  change F (lowerComponentFibre φ x).val = _
+  rw [lowerComponentFibre_coe]
+
+@[simp]
+private theorem PeriodFamily.Boundary.RefinedWang.upperColumnMap_coe {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (φ : X ≃ₜ X)
+    (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (V φ) (PeriodFamily.Homology.lowerFamily D)) (x : X) :
+    (upperColumnMap D φ F hU hV x).val = F (MappingTorus.mk φ (3 / 4, x)) := by
+  change F (upperComponentFibre φ x).val = _
+  rw [upperComponentFibre_coe]
+
+private theorem PeriodFamily.Boundary.RefinedWang.intersectionComparison_lowerColumn {X : Type}
+    [TopologicalSpace X] (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (φ : X ≃ₜ X) (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (V φ) (PeriodFamily.Homology.lowerFamily D))
+    (b : PeriodFamily.Homology.SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology X n) :
+    intersectionComparison D φ F hU hV b n (a, 0) =
+      PeriodFamily.Homology.intersectionHomologyEquiv D b n
+        (SingularMayerVietoris.singularHomologyMap (lowerColumnMap D φ F hU hV) n a) := by
+  rw [intersectionComparison_apply, intersectionHomologyEquiv_symm_lower]
+  exact
+    congrArg (PeriodFamily.Homology.intersectionHomologyEquiv D b n)
+      (LinearMap.congr_fun
+          (PeriodTorusHigherHomology.singularHomologyMap_comp (lowerComponentFibre φ)
+            (intersectionMap D φ F hU hV) n)
+          a).symm
+
+private theorem PeriodFamily.Boundary.RefinedWang.intersectionComparison_upperColumn {X : Type}
+    [TopologicalSpace X] (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (φ : X ≃ₜ X) (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (V φ) (PeriodFamily.Homology.lowerFamily D))
+    (b : PeriodFamily.Homology.SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology X n) :
+    intersectionComparison D φ F hU hV b n (0, a) =
+      PeriodFamily.Homology.intersectionHomologyEquiv D b n
+        (SingularMayerVietoris.singularHomologyMap (upperColumnMap D φ F hU hV) n a) := by
+  rw [intersectionComparison_apply, intersectionHomologyEquiv_symm_upper]
+  exact
+    congrArg (PeriodFamily.Homology.intersectionHomologyEquiv D b n)
+      (LinearMap.congr_fun
+          (PeriodTorusHigherHomology.singularHomologyMap_comp (upperComponentFibre φ)
+            (intersectionMap D φ F hU hV) n)
+          a).symm
+
+private theorem PeriodFamily.Boundary.RefinedWang.markedConnecting_quarterColumns {X : Type}
+    [TopologicalSpace X] (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (φ : X ≃ₜ X) (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (V φ) (PeriodFamily.Homology.lowerFamily D))
+    (b : PeriodFamily.Homology.SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus φ) (n + 1)) :
+    PeriodFamily.Homology.familyMarkedConnecting D b n
+        (SingularMayerVietoris.singularHomologyMap F (n + 1) a) =
+      -PeriodFamily.Homology.intersectionHomologyEquiv D b n
+            (SingularMayerVietoris.singularHomologyMap (lowerColumnMap D φ F hU hV) n
+              (MappingTorusHomology.wangBoundary φ n a)) +
+        PeriodFamily.Homology.intersectionHomologyEquiv D b n
+          (SingularMayerVietoris.singularHomologyMap (upperColumnMap D φ F hU hV) n
+            (MappingTorusHomology.wangBoundary φ n a)) := by
+  rw [markedConnecting_wangBoundary D φ F hU hV b n a, intersectionComparison_antidiagonal,
+    intersectionComparison_lowerColumn, intersectionComparison_upperColumn]
+
+private theorem PeriodFamily.Boundary.RefinedWang.sourceKernelProjection_quarterColumns {X : Type}
+    [TopologicalSpace X] (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (φ : X ≃ₜ X) (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (V φ) (PeriodFamily.Homology.lowerFamily D)) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus φ) (n + 1)) :
+    (PeriodFamily.Homology.sourceKernelProjection D n
+          (SingularMayerVietoris.singularHomologyMap F (n + 1) a) :
+        SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+          SingularMayerVietoris.SingularHomology RealTorus₄ n) =
+      PeriodFamily.Homology.normalizedSourceDomainEquiv n
+        (-PeriodFamily.Homology.intersectionHomologyEquiv D
+                PeriodFamily.Homology.normalizedSlitBaseLift n
+                (SingularMayerVietoris.singularHomologyMap (lowerColumnMap D φ F hU hV) n
+                  (MappingTorusHomology.wangBoundary φ n a)) +
+            PeriodFamily.Homology.intersectionHomologyEquiv D
+              PeriodFamily.Homology.normalizedSlitBaseLift n
+              (SingularMayerVietoris.singularHomologyMap (upperColumnMap D φ F hU hV) n
+                (MappingTorusHomology.wangBoundary φ n a))).2 := by
+  exact
+    congrArg
+      (fun z :
+          SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+            (SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+              SingularMayerVietoris.SingularHomology RealTorus₄ n) =>
+        PeriodFamily.Homology.normalizedSourceDomainEquiv n z.2)
+      (markedConnecting_quarterColumns D φ F hU hV PeriodFamily.Homology.normalizedSlitBaseLift n
+        a)
+
+private theorem PeriodFamily.Boundary.Cusp.normalizedBoundaryMap_outer_projection (t : ℝ)
+    (x : RealTorus₄) :
+    ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData.projection
+        (normalizedBoundaryMap
+          (MappingTorus.mk ThreefoldOverlapMappingTorus.Cusp.monodromy (t, x))) =
+      outerClockwiseRegularCurve t := by
+  rw [normalizedBoundaryMap_projection_mk, nativeLiftedSquare_final_projection]
+
+private theorem PeriodFamily.Boundary.Cusp.normalizedBoundaryMap_upper :
+    Set.MapsTo normalizedBoundaryMap
+      (PeriodFamily.Boundary.RefinedWang.U ThreefoldOverlapMappingTorus.Cusp.monodromy)
+      (PeriodFamily.Homology.upperFamily ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData) :=
+  by
+  intro q hq
+  obtain ⟨t, x, ht, ht', rfl⟩ :=
+    (PeriodFamily.Boundary.RefinedWang.mem_U_iff ThreefoldOverlapMappingTorus.Cusp.monodromy).mp
+      hq
+  change
+    ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData.projection
+        (normalizedBoundaryMap
+          (MappingTorus.mk ThreefoldOverlapMappingTorus.Cusp.monodromy (t, x))) ∈
+      PeriodFamily.Homology.upperBase
+  rw [normalizedBoundaryMap_outer_projection]
+  exact outerClockwiseRegularCurve_mem_upperBase t ht ht'
+
+private theorem PeriodFamily.Boundary.Cusp.normalizedBoundaryMap_lower :
+    Set.MapsTo normalizedBoundaryMap
+      (PeriodFamily.Boundary.RefinedWang.V ThreefoldOverlapMappingTorus.Cusp.monodromy)
+      (PeriodFamily.Homology.lowerFamily ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData) :=
+  by
+  intro q hq
+  obtain ⟨t, x, ht, ht', rfl⟩ :=
+    (PeriodFamily.Boundary.RefinedWang.mem_V_iff ThreefoldOverlapMappingTorus.Cusp.monodromy).mp
+      hq
+  change
+    ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData.projection
+        (normalizedBoundaryMap
+          (MappingTorus.mk ThreefoldOverlapMappingTorus.Cusp.monodromy (t, x))) ∈
+      PeriodFamily.Homology.lowerBase
+  rw [normalizedBoundaryMap_outer_projection]
+  exact outerClockwiseRegularCurve_mem_lowerBase t ht ht'
+
+private def PeriodFamily.Boundary.Cusp.lowerColumn :
+    C(RealTorus₄,
+      PeriodFamily.Homology.familyIntersection
+        ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData) :=
+  PeriodFamily.Boundary.RefinedWang.lowerColumnMap
+    ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData
+    ThreefoldOverlapMappingTorus.Cusp.monodromy normalizedBoundaryMap normalizedBoundaryMap_upper
+    normalizedBoundaryMap_lower
+
+private def PeriodFamily.Boundary.Cusp.upperColumn :
+    C(RealTorus₄,
+      PeriodFamily.Homology.familyIntersection
+        ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData) :=
+  PeriodFamily.Boundary.RefinedWang.upperColumnMap
+    ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData
+    ThreefoldOverlapMappingTorus.Cusp.monodromy normalizedBoundaryMap normalizedBoundaryMap_upper
+    normalizedBoundaryMap_lower
+
+private theorem PeriodFamily.Boundary.Cusp.lowerColumn_coe (x : RealTorus₄) :
+    (lowerColumn x).val =
+      ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData.quotient
+        (nativeLiftedSquare (1, 1 / 4), x) := by
+  rw [lowerColumn, PeriodFamily.Boundary.RefinedWang.lowerColumnMap_coe, normalizedBoundaryMap_mk]
+
+private theorem PeriodFamily.Boundary.Cusp.upperColumn_coe (x : RealTorus₄) :
+    (upperColumn x).val =
+      ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData.quotient
+        (nativeLiftedSquare (1, 3 / 4), x) := by
+  rw [upperColumn, PeriodFamily.Boundary.RefinedWang.upperColumnMap_coe, normalizedBoundaryMap_mk]
+
+private theorem PeriodFamily.Boundary.Cusp.lowerColumn_mem (x : RealTorus₄) :
+    lowerColumn x ∈
+      PeriodFamily.Homology.intersectionPiece
+        ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData 1 := by
+  change
+    ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData.projection (lowerColumn x).val ∈
+      PeriodFamily.Homology.overlapBase (PeriodFamily.Homology.intersectionIndex 1)
+  rw [lowerColumn_coe, ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData.projection_quotient]
+  change
+    SpecialPeriods.triangleRegularProject (nativeLiftedSquare (1, 1 / 4)) ∈
+      PeriodFamily.Homology.overlapBase 0
+  rw [nativeLiftedSquare_final_projection]
+  exact outerClockwiseQuarterPoint.property
+
+private theorem PeriodFamily.Boundary.Cusp.upperColumn_mem (x : RealTorus₄) :
+    upperColumn x ∈
+      PeriodFamily.Homology.intersectionPiece
+        ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData 2 := by
+  change
+    ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData.projection (upperColumn x).val ∈
+      PeriodFamily.Homology.overlapBase (PeriodFamily.Homology.intersectionIndex 2)
+  rw [upperColumn_coe, ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData.projection_quotient]
+  change
+    SpecialPeriods.triangleRegularProject (nativeLiftedSquare (1, 3 / 4)) ∈
+      PeriodFamily.Homology.overlapBase 2
+  rw [nativeLiftedSquare_final_projection]
+  exact outerClockwiseThreeQuarterPoint.property
+
+private theorem PeriodFamily.Boundary.Cusp.monodromyHomology_triangle (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap
+        (ThreefoldOverlapMappingTorus.Cusp.monodromy : C(RealTorus₄, RealTorus₄)) n =
+      (PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleCuspGenerator
+          n).toLinearMap := by
+  have hm :
+    ThreefoldOverlapMappingTorus.Cusp.monodromy =
+      SpecialPeriods.triangleTorusHomeomorph SpecialPeriods.triangleCuspGenerator := by
+    simpa only [zpow_one] using (SpecialPeriods.triangleTorusHomeomorph_cusp_zpow (1 : ℤ)).symm
+  rw [hm]
+  rfl
+
+private theorem PeriodFamily.Boundary.Cusp.wangBoundary_generator_fixed (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (MappingTorus.Torus ThreefoldOverlapMappingTorus.Cusp.monodromy) (n + 1)) :
+    PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleCuspGenerator n
+        (MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n a) =
+      MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n a := by
+  have hb :
+    MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n a ∈
+      LinearMap.ker
+        (MappingTorusHomology.wangDifference ThreefoldOverlapMappingTorus.Cusp.monodromy n) := by
+    rw [← MappingTorusHomology.wangBoundary_range]
+    exact ⟨a, rfl⟩
+  have he := LinearMap.mem_ker.mp hb
+  change
+    MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n a -
+        SingularMayerVietoris.singularHomologyMap
+          (ThreefoldOverlapMappingTorus.Cusp.monodromy : C(RealTorus₄, RealTorus₄)) n
+          (MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n a) =
+      0 at he
+  rw [monodromyHomology_triangle] at he
+  exact (sub_eq_zero.mp he).symm
+
+private theorem PeriodFamily.Boundary.Cusp.wangBoundary_inverse_word (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (MappingTorus.Torus ThreefoldOverlapMappingTorus.Cusp.monodromy) (n + 1)) :
+    (PeriodFamily.Homology.generatorHomologyEquiv Bool.true n).symm
+        (PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleGenerator₁⁻¹ n
+          (MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n a)) =
+      MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n a := by
+  have he := wangBoundary_generator_fixed n a
+  rw [SpecialPeriods.triangleCuspGenerator, mul_inv_rev,
+    PeriodFamily.Boundary.triangleHomologyEquiv_mul_apply,
+    PeriodFamily.Homology.triangleHomologyEquiv_inv] at he
+  exact he
+
+private theorem PeriodFamily.Boundary.Cusp.commutingFrame_inv_wangBoundary
+    (g : SpecialPeriods.TriangleGroup) (hg : Commute SpecialPeriods.triangleCuspGenerator g)
+    (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (MappingTorus.Torus ThreefoldOverlapMappingTorus.Cusp.monodromy) (n + 1)) :
+    PeriodFamily.Homology.triangleHomologyEquiv g⁻¹ n
+        (MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n a) =
+      MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n a :=
+  PeriodFamily.Boundary.cuspCentralizer_inv_homology_fixed g hg n _
+    (wangBoundary_generator_fixed n a)
+
+private theorem PeriodFamily.Boundary.Cusp.commutingColumnFrame_inv_wangBoundary
+    (g : SpecialPeriods.TriangleGroup) (hg : Commute SpecialPeriods.triangleCuspGenerator g)
+    (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (MappingTorus.Torus ThreefoldOverlapMappingTorus.Cusp.monodromy) (n + 1)) :
+    PeriodFamily.Homology.triangleHomologyEquiv (g * SpecialPeriods.triangleGenerator₁)⁻¹ n
+        (MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n a) =
+      PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleGenerator₁⁻¹ n
+        (MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n a) := by
+  rw [mul_inv_rev, PeriodFamily.Boundary.triangleHomologyEquiv_mul_apply,
+    commutingFrame_inv_wangBoundary g hg]
+
+private def PeriodFamily.Boundary.intersectionMap {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (φ : X ≃ₜ X)
+    (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (MappingTorus.HomologyCover.U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (MappingTorus.HomologyCover.V φ) (PeriodFamily.Homology.lowerFamily D)) :
+    C((MappingTorus.HomologyCover.U φ ∩ MappingTorus.HomologyCover.V φ :
+        Set (MappingTorus.Torus φ)),
+      PeriodFamily.Homology.familyIntersection D) :=
+  SingularMayerVietoris.intersectionRestriction F (MappingTorus.HomologyCover.U φ)
+    (MappingTorus.HomologyCover.V φ) (PeriodFamily.Homology.upperFamily D)
+    (PeriodFamily.Homology.lowerFamily D) hU hV
+
+private theorem PeriodFamily.Boundary.markedConnecting_naturality {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (φ : X ≃ₜ X)
+    (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (MappingTorus.HomologyCover.U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (MappingTorus.HomologyCover.V φ) (PeriodFamily.Homology.lowerFamily D))
+    (b : PeriodFamily.Homology.SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus φ) (n + 1)) :
+    PeriodFamily.Homology.familyMarkedConnecting D b n
+        (SingularMayerVietoris.singularHomologyMap F (n + 1) a) =
+      PeriodFamily.Homology.intersectionHomologyEquiv D b n
+        (SingularMayerVietoris.singularHomologyMap (intersectionMap D φ F hU hV) n
+          (MappingTorusHomology.mayerVietorisConnecting φ n a)) := by
+  have h :=
+    SingularMayerVietoris.connectingHomomorphism_naturality_apply F
+      (MappingTorus.HomologyCover.U φ) (MappingTorus.HomologyCover.V φ)
+      (PeriodFamily.Homology.upperFamily D) (PeriodFamily.Homology.lowerFamily D) hU hV
+      (MappingTorus.HomologyCover.U_open φ) (MappingTorus.HomologyCover.V_open φ)
+      (MappingTorus.HomologyCover.cover φ) (PeriodFamily.Homology.upperFamily D).isOpen
+      (PeriodFamily.Homology.lowerFamily D).isOpen
+      (PeriodFamily.Homology.upperFamily_union_lowerFamily D) n a
+  exact (congrArg (PeriodFamily.Homology.intersectionHomologyEquiv D b n) h).symm
+
+private def PeriodFamily.Boundary.intersectionComparison {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (φ : X ≃ₜ X)
+    (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (MappingTorus.HomologyCover.U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (MappingTorus.HomologyCover.V φ) (PeriodFamily.Homology.lowerFamily D))
+    (b : PeriodFamily.Homology.SlitBaseLift) (n : ℕ) :
+    (SingularMayerVietoris.SingularHomology X n ×
+        SingularMayerVietoris.SingularHomology X n) →ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+        (SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+          SingularMayerVietoris.SingularHomology RealTorus₄ n)) :=
+  (PeriodFamily.Homology.intersectionHomologyEquiv D b n).toLinearMap.comp
+    ((SingularMayerVietoris.singularHomologyMap (intersectionMap D φ F hU hV) n).comp
+      (MappingTorusHomology.intersectionHomologyEquiv φ n).symm.toLinearMap)
+
+@[simp]
+private theorem PeriodFamily.Boundary.intersectionComparison_apply {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (φ : X ≃ₜ X)
+    (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (MappingTorus.HomologyCover.U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (MappingTorus.HomologyCover.V φ) (PeriodFamily.Homology.lowerFamily D))
+    (b : PeriodFamily.Homology.SlitBaseLift) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology X n × SingularMayerVietoris.SingularHomology X n) :
+    intersectionComparison D φ F hU hV b n a =
+      PeriodFamily.Homology.intersectionHomologyEquiv D b n
+        (SingularMayerVietoris.singularHomologyMap (intersectionMap D φ F hU hV) n
+          ((MappingTorusHomology.intersectionHomologyEquiv φ n).symm a)) :=
+  rfl
+
+private theorem PeriodFamily.Boundary.mappingTorusConnecting_eq_marked_boundary {X : Type}
+    [TopologicalSpace X] (φ : X ≃ₜ X) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus φ) (n + 1)) :
+    MappingTorusHomology.mayerVietorisConnecting φ n a =
+      (MappingTorusHomology.intersectionHomologyEquiv φ n).symm
+        (-MappingTorusHomology.wangBoundary φ n a, MappingTorusHomology.wangBoundary φ n a) := by
+  apply (MappingTorusHomology.intersectionHomologyEquiv φ n).injective
+  rw [LinearEquiv.apply_symm_apply]
+  exact MappingTorusHomology.boundaryCoordinates_eq_antidiagonal φ n a
+
+private theorem PeriodFamily.Boundary.markedConnecting_wangBoundary {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (φ : X ≃ₜ X)
+    (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (MappingTorus.HomologyCover.U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (MappingTorus.HomologyCover.V φ) (PeriodFamily.Homology.lowerFamily D))
+    (b : PeriodFamily.Homology.SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus φ) (n + 1)) :
+    PeriodFamily.Homology.familyMarkedConnecting D b n
+        (SingularMayerVietoris.singularHomologyMap F (n + 1) a) =
+      intersectionComparison D φ F hU hV b n
+        (-MappingTorusHomology.wangBoundary φ n a, MappingTorusHomology.wangBoundary φ n a) := by
+  refine (markedConnecting_naturality D φ F hU hV b n a).trans ?_
+  exact
+    congrArg
+      (fun z =>
+        PeriodFamily.Homology.intersectionHomologyEquiv D b n
+          (SingularMayerVietoris.singularHomologyMap (intersectionMap D φ F hU hV) n z))
+      (mappingTorusConnecting_eq_marked_boundary φ n a)
+
+private theorem
+    PeriodFamily.Boundary.sourceKernelProjection_wangBoundary {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (φ : X ≃ₜ X)
+    (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (MappingTorus.HomologyCover.U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (MappingTorus.HomologyCover.V φ) (PeriodFamily.Homology.lowerFamily D))
+    (n : ℕ) (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus φ) (n + 1)) :
+    (PeriodFamily.Homology.sourceKernelProjection D n
+          (SingularMayerVietoris.singularHomologyMap F (n + 1) a) :
+        SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+          SingularMayerVietoris.SingularHomology RealTorus₄ n) =
+      PeriodFamily.Homology.normalizedSourceDomainEquiv n
+        (intersectionComparison D φ F hU hV PeriodFamily.Homology.normalizedSlitBaseLift n
+            (-MappingTorusHomology.wangBoundary φ n a,
+              MappingTorusHomology.wangBoundary φ n a)).2 := by
+  exact
+    congrArg
+      (fun z :
+          SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+            (SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+              SingularMayerVietoris.SingularHomology RealTorus₄ n) =>
+        PeriodFamily.Homology.normalizedSourceDomainEquiv n z.2)
+      (markedConnecting_wangBoundary D φ F hU hV PeriodFamily.Homology.normalizedSlitBaseLift n a)
+
+private theorem
+    PeriodFamily.Boundary.intersectionComparison_antidiagonal {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (φ : X ≃ₜ X)
+    (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (MappingTorus.HomologyCover.U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (MappingTorus.HomologyCover.V φ) (PeriodFamily.Homology.lowerFamily D))
+    (b : PeriodFamily.Homology.SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology X n) :
+    intersectionComparison D φ F hU hV b n (-a, a) =
+      -intersectionComparison D φ F hU hV b n (a, 0) +
+        intersectionComparison D φ F hU hV b n (0, a) := by
+  have h : (-a, a) = -(a, (0 : SingularMayerVietoris.SingularHomology X n)) + (0, a) := by
+    ext <;> simp
+  rw [h, map_add, map_neg]
+
+private def PeriodFamily.Boundary.lowerComponentTime : Set.Ioo (0 : ℝ) (1 / 2) :=
+  ⟨1 / 4, by constructor <;> norm_num⟩
+
+private def PeriodFamily.Boundary.upperComponentTime : Set.Ioo (1 / 2 : ℝ) 1 :=
+  ⟨3 / 4, by constructor <;> norm_num⟩
+
+private def PeriodFamily.Boundary.lowerComponentFibre {X : Type} [TopologicalSpace X] (φ : X ≃ₜ X) :
+    C(X,
+      (MappingTorus.HomologyCover.U φ ∩ MappingTorus.HomologyCover.V φ :
+        Set (MappingTorus.Torus φ)))
+    where
+  toFun
+    x :=
+    (MappingTorus.HomologyCover.intersectionHomeomorph φ).symm (Sum.inl (lowerComponentTime, x))
+  continuous_toFun :=
+    (MappingTorus.HomologyCover.intersectionHomeomorph φ).symm.continuous.comp
+      (continuous_inl.comp (continuous_const.prodMk continuous_id))
+
+private def PeriodFamily.Boundary.upperComponentFibre {X : Type} [TopologicalSpace X] (φ : X ≃ₜ X) :
+    C(X,
+      (MappingTorus.HomologyCover.U φ ∩ MappingTorus.HomologyCover.V φ :
+        Set (MappingTorus.Torus φ)))
+    where
+  toFun
+    x :=
+    (MappingTorus.HomologyCover.intersectionHomeomorph φ).symm (Sum.inr (upperComponentTime, x))
+  continuous_toFun :=
+    (MappingTorus.HomologyCover.intersectionHomeomorph φ).symm.continuous.comp
+      (continuous_inr.comp (continuous_const.prodMk continuous_id))
+
+@[simp]
+private theorem
+    PeriodFamily.Boundary.lowerComponentFibre_coe {X : Type} [TopologicalSpace X] (φ : X ≃ₜ X)
+    (x : X) : (lowerComponentFibre φ x).val = MappingTorus.mk φ (1 / 4, x) :=
+  MappingTorus.HomologyCover.intersectionHomeomorph_symm_inl_coe φ (lowerComponentTime, x)
+
+@[simp]
+private theorem
+    PeriodFamily.Boundary.upperComponentFibre_coe {X : Type} [TopologicalSpace X] (φ : X ≃ₜ X)
+    (x : X) : (upperComponentFibre φ x).val = MappingTorus.mk φ (3 / 4, x) :=
+  MappingTorus.HomologyCover.intersectionHomeomorph_symm_inr_coe φ (upperComponentTime, x)
+
+private theorem PeriodFamily.Boundary.lowerComponentFibre_retraction {X : Type} [TopologicalSpace X]
+    (φ : X ≃ₜ X) :
+    (MappingTorus.HomologyCover.intersectionHomotopyEquiv φ).toFun.comp (lowerComponentFibre φ) =
+      PeriodTorusHigherHomology.sumInlMap X X := by
+  apply ContinuousMap.ext
+  intro x
+  exact MappingTorus.HomologyCover.intersectionHomotopyEquiv_inl φ (lowerComponentTime, x)
+
+private theorem PeriodFamily.Boundary.upperComponentFibre_retraction {X : Type} [TopologicalSpace X]
+    (φ : X ≃ₜ X) :
+    (MappingTorus.HomologyCover.intersectionHomotopyEquiv φ).toFun.comp (upperComponentFibre φ) =
+      PeriodTorusHigherHomology.sumInrMap X X := by
+  apply ContinuousMap.ext
+  intro x
+  exact MappingTorus.HomologyCover.intersectionHomotopyEquiv_inr φ (upperComponentTime, x)
+
+private theorem PeriodFamily.Boundary.lowerComponentFibre_homology {X : Type} [TopologicalSpace X]
+    (φ : X ≃ₜ X) (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    MappingTorusHomology.intersectionHomologyEquiv φ n
+        (SingularMayerVietoris.singularHomologyMap (lowerComponentFibre φ) n a) =
+      (a, 0) := by
+  rw [MappingTorusHomology.intersectionHomologyEquiv_apply, ← LinearMap.comp_apply, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp, lowerComponentFibre_retraction,
+    PeriodTorusHigherHomology.sumHomologyEquiv_inl]
+
+private theorem PeriodFamily.Boundary.upperComponentFibre_homology {X : Type} [TopologicalSpace X]
+    (φ : X ≃ₜ X) (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    MappingTorusHomology.intersectionHomologyEquiv φ n
+        (SingularMayerVietoris.singularHomologyMap (upperComponentFibre φ) n a) =
+      (0, a) := by
+  rw [MappingTorusHomology.intersectionHomologyEquiv_apply, ← LinearMap.comp_apply, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp, upperComponentFibre_retraction,
+    PeriodTorusHigherHomology.sumHomologyEquiv_inr]
+
+@[simp]
+private theorem
+    PeriodFamily.Boundary.intersectionHomologyEquiv_symm_lower {X : Type} [TopologicalSpace X]
+    (φ : X ≃ₜ X) (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    (MappingTorusHomology.intersectionHomologyEquiv φ n).symm (a, 0) =
+      SingularMayerVietoris.singularHomologyMap (lowerComponentFibre φ) n a := by
+  apply (MappingTorusHomology.intersectionHomologyEquiv φ n).injective
+  rw [LinearEquiv.apply_symm_apply, lowerComponentFibre_homology]
+
+@[simp]
+private theorem
+    PeriodFamily.Boundary.intersectionHomologyEquiv_symm_upper {X : Type} [TopologicalSpace X]
+    (φ : X ≃ₜ X) (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    (MappingTorusHomology.intersectionHomologyEquiv φ n).symm (0, a) =
+      SingularMayerVietoris.singularHomologyMap (upperComponentFibre φ) n a := by
+  apply (MappingTorusHomology.intersectionHomologyEquiv φ n).injective
+  rw [LinearEquiv.apply_symm_apply, upperComponentFibre_homology]
+
+private def PeriodFamily.Boundary.lowerColumnMap {X : Type} [TopologicalSpace X] (φ : X ≃ₜ X)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (MappingTorus.HomologyCover.U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (MappingTorus.HomologyCover.V φ) (PeriodFamily.Homology.lowerFamily D)) :
+    C(X, PeriodFamily.Homology.familyIntersection D) :=
+  (intersectionMap D φ F hU hV).comp (lowerComponentFibre φ)
+
+private def PeriodFamily.Boundary.upperColumnMap {X : Type} [TopologicalSpace X] (φ : X ≃ₜ X)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (MappingTorus.HomologyCover.U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (MappingTorus.HomologyCover.V φ) (PeriodFamily.Homology.lowerFamily D)) :
+    C(X, PeriodFamily.Homology.familyIntersection D) :=
+  (intersectionMap D φ F hU hV).comp (upperComponentFibre φ)
+
+@[simp]
+private theorem
+    PeriodFamily.Boundary.lowerColumnMap_coe {X : Type} [TopologicalSpace X] (φ : X ≃ₜ X)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (MappingTorus.HomologyCover.U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (MappingTorus.HomologyCover.V φ) (PeriodFamily.Homology.lowerFamily D))
+    (x : X) : (lowerColumnMap φ D F hU hV x).val = F (MappingTorus.mk φ (1 / 4, x)) := by
+  change F (lowerComponentFibre φ x).val = _
+  rw [lowerComponentFibre_coe]
+
+@[simp]
+private theorem
+    PeriodFamily.Boundary.upperColumnMap_coe {X : Type} [TopologicalSpace X] (φ : X ≃ₜ X)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (MappingTorus.HomologyCover.U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (MappingTorus.HomologyCover.V φ) (PeriodFamily.Homology.lowerFamily D))
+    (x : X) : (upperColumnMap φ D F hU hV x).val = F (MappingTorus.mk φ (3 / 4, x)) := by
+  change F (upperComponentFibre φ x).val = _
+  rw [upperComponentFibre_coe]
+
+private theorem
+    PeriodFamily.Boundary.intersectionComparison_lowerColumn {X : Type} [TopologicalSpace X]
+    (φ : X ≃ₜ X) (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (MappingTorus.HomologyCover.U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (MappingTorus.HomologyCover.V φ) (PeriodFamily.Homology.lowerFamily D))
+    (b : PeriodFamily.Homology.SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology X n) :
+    intersectionComparison D φ F hU hV b n (a, 0) =
+      PeriodFamily.Homology.intersectionHomologyEquiv D b n
+        (SingularMayerVietoris.singularHomologyMap (lowerColumnMap φ D F hU hV) n a) := by
+  rw [intersectionComparison_apply, intersectionHomologyEquiv_symm_lower]
+  exact
+    congrArg (PeriodFamily.Homology.intersectionHomologyEquiv D b n)
+      (LinearMap.congr_fun
+          (PeriodTorusHigherHomology.singularHomologyMap_comp (lowerComponentFibre φ)
+            (intersectionMap D φ F hU hV) n)
+          a).symm
+
+private theorem
+    PeriodFamily.Boundary.intersectionComparison_upperColumn {X : Type} [TopologicalSpace X]
+    (φ : X ≃ₜ X) (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (F : C(MappingTorus.Torus φ, D.Space))
+    (hU : Set.MapsTo F (MappingTorus.HomologyCover.U φ) (PeriodFamily.Homology.upperFamily D))
+    (hV : Set.MapsTo F (MappingTorus.HomologyCover.V φ) (PeriodFamily.Homology.lowerFamily D))
+    (b : PeriodFamily.Homology.SlitBaseLift) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology X n) :
+    intersectionComparison D φ F hU hV b n (0, a) =
+      PeriodFamily.Homology.intersectionHomologyEquiv D b n
+        (SingularMayerVietoris.singularHomologyMap (upperColumnMap φ D F hU hV) n a) := by
+  rw [intersectionComparison_apply, intersectionHomologyEquiv_symm_upper]
+  exact
+    congrArg (PeriodFamily.Homology.intersectionHomologyEquiv D b n)
+      (LinearMap.congr_fun
+          (PeriodTorusHigherHomology.singularHomologyMap_comp (upperComponentFibre φ)
+            (intersectionMap D φ F hU hV) n)
+          a).symm
+
+private def PeriodFamily.Boundary.componentCoordinates {H : Type*} [Zero H] (i : Fin 3) (a : H) :
+    H × (H × H) :=
+  ![(a, (0, 0)), (0, (a, 0)), (0, (0, a))] i
+
+@[simp]
+private theorem PeriodFamily.Boundary.componentCoordinates_one {H : Type*} [Zero H] (a : H) :
+    componentCoordinates 1 a = (0, (a, 0)) :=
+  rfl
+
+@[simp]
+private theorem PeriodFamily.Boundary.componentCoordinates_two {H : Type*} [Zero H] (a : H) :
+    componentCoordinates 2 a = (0, (0, a)) :=
+  rfl
+
+private def PeriodFamily.Boundary.pieceFibreProjection
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (b : PeriodFamily.Homology.SlitBaseLift) (i : Fin 3) :
+    C(PeriodFamily.Homology.intersectionPiece D i, RealTorus₄) :=
+  (PeriodFamily.Homology.overlapHomotopyEquiv D b
+        (PeriodFamily.Homology.intersectionIndex i)).toFun.comp
+    (PeriodFamily.Homology.intersectionPieceHomeomorph D i : C(_, _))
+
+private theorem PeriodFamily.Boundary.pieceFibreProjection_homology
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (b : PeriodFamily.Homology.SlitBaseLift) (i : Fin 3) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (pieceFibreProjection D b i) n =
+      (PeriodFamily.Homology.intersectionPieceHomologyEquiv D b i n).toLinearMap := by
+  rw [pieceFibreProjection, PeriodTorusHigherHomology.singularHomologyMap_comp]
+  rfl
+
+private def PeriodFamily.Boundary.componentLift {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (C : C(X, PeriodFamily.Homology.familyIntersection D)) (i : Fin 3)
+    (hC : ∀ x, C x ∈ PeriodFamily.Homology.intersectionPiece D i) :
+    C(X, PeriodFamily.Homology.intersectionPiece D i) :=
+  ⟨fun x => ⟨C x, hC x⟩, C.continuous.subtype_mk _⟩
+
+private theorem PeriodFamily.Boundary.componentLift_factor {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (C : C(X, PeriodFamily.Homology.familyIntersection D)) (i : Fin 3)
+    (hC : ∀ x, C x ∈ PeriodFamily.Homology.intersectionPiece D i) :
+    (PeriodFamily.Homology.openPartitionInclusion (PeriodFamily.Homology.intersectionPiece D)
+            i).comp
+        (componentLift D C i hC) =
+      C := by
+  apply ContinuousMap.ext
+  intro x
+  rfl
+
+private def PeriodFamily.Boundary.componentFibreMap {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (b : PeriodFamily.Homology.SlitBaseLift)
+    (C : C(X, PeriodFamily.Homology.familyIntersection D)) (i : Fin 3)
+    (hC : ∀ x, C x ∈ PeriodFamily.Homology.intersectionPiece D i) : C(X, RealTorus₄) :=
+  (pieceFibreProjection D b i).comp (componentLift D C i hC)
+
+@[simp]
+private theorem PeriodFamily.Boundary.componentFibreMap_apply {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (b : PeriodFamily.Homology.SlitBaseLift)
+    (C : C(X, PeriodFamily.Homology.familyIntersection D)) (i : Fin 3)
+    (hC : ∀ x, C x ∈ PeriodFamily.Homology.intersectionPiece D i) (x : X) :
+    componentFibreMap D b C i hC x =
+      (PeriodFamily.Homology.overlapChart D b (PeriodFamily.Homology.intersectionIndex i)
+          ⟨(C x).val, hC x⟩).2 :=
+  rfl
+
+private theorem PeriodFamily.Boundary.componentFibreMap_homology {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (b : PeriodFamily.Homology.SlitBaseLift)
+    (C : C(X, PeriodFamily.Homology.familyIntersection D)) (i : Fin 3)
+    (hC : ∀ x, C x ∈ PeriodFamily.Homology.intersectionPiece D i) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology X n) :
+    SingularMayerVietoris.singularHomologyMap (componentFibreMap D b C i hC) n a =
+      PeriodFamily.Homology.intersectionPieceHomologyEquiv D b i n
+        (SingularMayerVietoris.singularHomologyMap (componentLift D C i hC) n a) := by
+  rw [componentFibreMap, PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply,
+    pieceFibreProjection_homology]
+  rfl
+
+private theorem
+    PeriodFamily.Boundary.intersectionHomology_componentMap {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (b : PeriodFamily.Homology.SlitBaseLift)
+    (C : C(X, PeriodFamily.Homology.familyIntersection D)) (i : Fin 3)
+    (hC : ∀ x, C x ∈ PeriodFamily.Homology.intersectionPiece D i) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology X n) :
+    PeriodFamily.Homology.intersectionHomologyEquiv D b n
+        (SingularMayerVietoris.singularHomologyMap C n a) =
+      componentCoordinates i
+        (SingularMayerVietoris.singularHomologyMap (componentFibreMap D b C i hC) n a) := by
+  have hfactor :
+    SingularMayerVietoris.singularHomologyMap C n a =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodFamily.Homology.openPartitionInclusion (PeriodFamily.Homology.intersectionPiece D)
+          i)
+        n (SingularMayerVietoris.singularHomologyMap (componentLift D C i hC) n a) := by
+    rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+      componentLift_factor]
+  rw [hfactor, componentFibreMap_homology]
+  fin_cases i
+  · exact PeriodFamily.Homology.intersectionHomologyEquiv_inclusion_middle D b n _
+  · exact PeriodFamily.Homology.intersectionHomologyEquiv_inclusion_left D b n _
+  · exact PeriodFamily.Homology.intersectionHomologyEquiv_inclusion_right D b n _
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.componentFibreMap_eq_deck_comp {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (b : PeriodFamily.Homology.SlitBaseLift)
+    (C : C(X, PeriodFamily.Homology.familyIntersection D)) (i : Fin 3)
+    (hC : ∀ x, C x ∈ PeriodFamily.Homology.intersectionPiece D i)
+    (q : PeriodFamily.Homology.overlapBase (PeriodFamily.Homology.intersectionIndex i))
+    (z : SpecialPeriods.TriangleRegularPoint) (g : SpecialPeriods.TriangleGroup)
+    (hz :
+      z =
+        g •
+          PeriodFamily.Homology.upperLiftOnOverlap b (PeriodFamily.Homology.intersectionIndex i)
+            q)
+    (F : C(X, RealTorus₄)) (hF : ∀ x, (C x).val = D.quotient (z, F x)) :
+    componentFibreMap D b C i hC =
+      (SpecialPeriods.triangleTorusHomeomorph g⁻¹ : C(RealTorus₄, RealTorus₄)).comp F := by
+  apply ContinuousMap.ext
+  intro x
+  rw [componentFibreMap_apply]
+  have he :
+    (⟨(C x).val, hC x⟩ :
+        PeriodFamily.Homology.overlapFamily D (PeriodFamily.Homology.intersectionIndex i)) =
+      (PeriodFamily.Homology.overlapChart D b (PeriodFamily.Homology.intersectionIndex i)).symm
+        (q, g⁻¹ • F x) := by
+    apply Subtype.ext
+    rw [PeriodFamily.Homology.overlapChart_symm_coe, hF, hz]
+    have h :=
+      D.quotient_smul g
+        (PeriodFamily.Homology.upperLiftOnOverlap b (PeriodFamily.Homology.intersectionIndex i) q,
+          g⁻¹ • F x)
+    change
+      D.quotient
+          (g •
+              PeriodFamily.Homology.upperLiftOnOverlap b
+                (PeriodFamily.Homology.intersectionIndex i) q,
+            g • (g⁻¹ • F x)) =
+        D.quotient
+          (PeriodFamily.Homology.upperLiftOnOverlap b (PeriodFamily.Homology.intersectionIndex i)
+              q,
+            g⁻¹ • F x) at h
+    simpa only [smul_inv_smul] using h
+  rw [he, Homeomorph.apply_symm_apply]
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem
+    PeriodFamily.Boundary.componentFibreMap_homology_deck_comp {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (b : PeriodFamily.Homology.SlitBaseLift)
+    (C : C(X, PeriodFamily.Homology.familyIntersection D)) (i : Fin 3)
+    (hC : ∀ x, C x ∈ PeriodFamily.Homology.intersectionPiece D i)
+    (q : PeriodFamily.Homology.overlapBase (PeriodFamily.Homology.intersectionIndex i))
+    (z : SpecialPeriods.TriangleRegularPoint) (g : SpecialPeriods.TriangleGroup)
+    (hz :
+      z =
+        g •
+          PeriodFamily.Homology.upperLiftOnOverlap b (PeriodFamily.Homology.intersectionIndex i)
+            q)
+    (F : C(X, RealTorus₄)) (hF : ∀ x, (C x).val = D.quotient (z, F x)) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (componentFibreMap D b C i hC) n =
+      (SingularMayerVietoris.singularHomologyMap
+            (SpecialPeriods.triangleTorusHomeomorph g⁻¹ : C(RealTorus₄, RealTorus₄)) n).comp
+        (SingularMayerVietoris.singularHomologyMap F n) := by
+  rw [componentFibreMap_eq_deck_comp D b C i hC q z g hz F hF,
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem
+    PeriodFamily.Boundary.componentFibreMap_homology_affine {X : Type} [TopologicalSpace X]
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (b : PeriodFamily.Homology.SlitBaseLift)
+    (C : C(X, PeriodFamily.Homology.familyIntersection D)) (i : Fin 3)
+    (hC : ∀ x, C x ∈ PeriodFamily.Homology.intersectionPiece D i)
+    (q : PeriodFamily.Homology.overlapBase (PeriodFamily.Homology.intersectionIndex i))
+    (z : SpecialPeriods.TriangleRegularPoint) (g : SpecialPeriods.TriangleGroup)
+    (hz :
+      z =
+        g •
+          PeriodFamily.Homology.upperLiftOnOverlap b (PeriodFamily.Homology.intersectionIndex i)
+            q)
+    (F : C(X, RealTorus₄)) (v : RealTorus₄) (hF : ∀ x, (C x).val = D.quotient (z, F x + v))
+    (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (componentFibreMap D b C i hC) n =
+      (SingularMayerVietoris.singularHomologyMap
+            (SpecialPeriods.triangleTorusHomeomorph g⁻¹ : C(RealTorus₄, RealTorus₄)) n).comp
+        (SingularMayerVietoris.singularHomologyMap F n) := by
+  rw [componentFibreMap_homology_deck_comp D b C i hC q z g hz
+      ((PeriodTorusHigherHomology.rightTranslation v).comp F) hF,
+    PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodTorusHigherHomology.rightTranslation_singularHomologyMap, LinearMap.id_comp]
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.intersectionHomology_component_affine {X : Type}
+    [TopologicalSpace X] (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (b : PeriodFamily.Homology.SlitBaseLift)
+    (C : C(X, PeriodFamily.Homology.familyIntersection D)) (i : Fin 3)
+    (hC : ∀ x, C x ∈ PeriodFamily.Homology.intersectionPiece D i)
+    (q : PeriodFamily.Homology.overlapBase (PeriodFamily.Homology.intersectionIndex i))
+    (z : SpecialPeriods.TriangleRegularPoint) (g : SpecialPeriods.TriangleGroup)
+    (hz :
+      z =
+        g •
+          PeriodFamily.Homology.upperLiftOnOverlap b (PeriodFamily.Homology.intersectionIndex i)
+            q)
+    (F : C(X, RealTorus₄)) (v : RealTorus₄) (hF : ∀ x, (C x).val = D.quotient (z, F x + v))
+    (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    PeriodFamily.Homology.intersectionHomologyEquiv D b n
+        (SingularMayerVietoris.singularHomologyMap C n a) =
+      componentCoordinates i
+        (SingularMayerVietoris.singularHomologyMap
+          (SpecialPeriods.triangleTorusHomeomorph g⁻¹ : C(RealTorus₄, RealTorus₄)) n
+          (SingularMayerVietoris.singularHomologyMap F n a)) := by
+  rw [intersectionHomology_componentMap D b C i hC n a,
+    componentFibreMap_homology_affine D b C i hC q z g hz F v hF n, LinearMap.comp_apply]
+
+private theorem PeriodFamily.Boundary.Cusp.lowerColumn_homology (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    PeriodFamily.Homology.intersectionHomologyEquiv
+        ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData
+        PeriodFamily.Homology.normalizedSlitBaseLift n
+        (SingularMayerVietoris.singularHomologyMap lowerColumn n a) =
+      PeriodFamily.Boundary.componentCoordinates 1
+        (PeriodFamily.Homology.triangleHomologyEquiv
+          (tailFrame * SpecialPeriods.triangleGenerator₁)⁻¹ n a) := by
+  rw [PeriodFamily.Boundary.intersectionHomology_componentMap
+      ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData
+      PeriodFamily.Homology.normalizedSlitBaseLift lowerColumn 1 lowerColumn_mem n a]
+  have h :=
+    PeriodFamily.Boundary.componentFibreMap_homology_deck_comp
+      ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData
+      PeriodFamily.Homology.normalizedSlitBaseLift lowerColumn 1 lowerColumn_mem
+      outerClockwiseQuarterPoint (nativeLiftedSquare (1, 1 / 4))
+      (tailFrame * SpecialPeriods.triangleGenerator₁) nativeLiftedSquare_quarter_frame
+      (ContinuousMap.id RealTorus₄) lowerColumn_coe n
+  rw [h, PeriodTorusHigherHomology.singularHomologyMap_id, LinearMap.comp_apply,
+    LinearMap.id_apply]
+  rfl
+
+private theorem PeriodFamily.Boundary.Cusp.upperColumn_homology (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    PeriodFamily.Homology.intersectionHomologyEquiv
+        ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData
+        PeriodFamily.Homology.normalizedSlitBaseLift n
+        (SingularMayerVietoris.singularHomologyMap upperColumn n a) =
+      PeriodFamily.Boundary.componentCoordinates 2
+        (PeriodFamily.Homology.triangleHomologyEquiv
+          (tailFrame * SpecialPeriods.triangleGenerator₁)⁻¹ n a) := by
+  rw [PeriodFamily.Boundary.intersectionHomology_componentMap
+      ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData
+      PeriodFamily.Homology.normalizedSlitBaseLift upperColumn 2 upperColumn_mem n a]
+  have h :=
+    PeriodFamily.Boundary.componentFibreMap_homology_deck_comp
+      ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData
+      PeriodFamily.Homology.normalizedSlitBaseLift upperColumn 2 upperColumn_mem
+      outerClockwiseThreeQuarterPoint (nativeLiftedSquare (1, 3 / 4))
+      (tailFrame * SpecialPeriods.triangleGenerator₁) nativeLiftedSquare_threeQuarters_frame
+      (ContinuousMap.id RealTorus₄) upperColumn_coe n
+  rw [h, PeriodTorusHigherHomology.singularHomologyMap_id, LinearMap.comp_apply,
+    LinearMap.id_apply]
+  rfl
+
+private theorem PeriodFamily.Boundary.Cusp.lowerColumn_wangBoundary (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (MappingTorus.Torus ThreefoldOverlapMappingTorus.Cusp.monodromy) (n + 1)) :
+    PeriodFamily.Homology.intersectionHomologyEquiv
+        ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData
+        PeriodFamily.Homology.normalizedSlitBaseLift n
+        (SingularMayerVietoris.singularHomologyMap lowerColumn n
+          (MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n a)) =
+      PeriodFamily.Boundary.componentCoordinates 1
+        (PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleGenerator₁⁻¹ n
+          (MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n a)) := by
+  rw [lowerColumn_homology, commutingColumnFrame_inv_wangBoundary tailFrame tailFrame_commute]
+
+private theorem PeriodFamily.Boundary.Cusp.upperColumn_wangBoundary (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (MappingTorus.Torus ThreefoldOverlapMappingTorus.Cusp.monodromy) (n + 1)) :
+    PeriodFamily.Homology.intersectionHomologyEquiv
+        ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData
+        PeriodFamily.Homology.normalizedSlitBaseLift n
+        (SingularMayerVietoris.singularHomologyMap upperColumn n
+          (MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n a)) =
+      PeriodFamily.Boundary.componentCoordinates 2
+        (PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleGenerator₁⁻¹ n
+          (MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n a)) := by
+  rw [upperColumn_homology, commutingColumnFrame_inv_wangBoundary tailFrame tailFrame_commute]
+
+private def PeriodFamily.BoundaryLoopSquares.chosenAttachingPeriodicHomotopy (j : Elliptic.Kind) :
+    (loopPeriodic (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingBaseLoop j)).Homotopy
+      (loopPeriodic
+        (SpecialPeriods.EllipticAttachingMeridians.clockwiseRegularMeridian
+          (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j))) :=
+  periodicHomotopy (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingSquare j)
+
+@[simp]
+private theorem
+    PeriodFamily.BoundaryLoopSquares.chosenAttachingPeriodicHomotopy_unit (j : Elliptic.Kind)
+    (s t : unitInterval) :
+    chosenAttachingPeriodicHomotopy j (s, (t : ℝ)) =
+      (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingSquare j).map (s, t) :=
+  periodicHomotopy_unit (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingSquare j) s t
+
+private theorem PeriodFamily.BoundaryLoopSquares.chosenAttachingPeriodicHomotopy_initial
+    (j : Elliptic.Kind) (t : ℝ) :
+    chosenAttachingPeriodicHomotopy j (0, t) =
+      loopPeriodic (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingBaseLoop j) t :=
+  periodicSquare_initial (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingSquare j) t
+
+private theorem
+    PeriodFamily.BoundaryLoopSquares.chosenAttachingPeriodicHomotopy_final (j : Elliptic.Kind)
+    (t : ℝ) :
+    chosenAttachingPeriodicHomotopy j (1, t) =
+      loopPeriodic
+        (SpecialPeriods.EllipticAttachingMeridians.clockwiseRegularMeridian
+          (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j))
+        t :=
+  periodicSquare_final (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingSquare j) t
+
+private theorem PeriodFamily.BoundaryLoopSquares.chosenAttachingPeriodicHomotopy_add_int
+    (j : Elliptic.Kind) (s : unitInterval) (t : ℝ) (k : ℤ) :
+    chosenAttachingPeriodicHomotopy j (s, t + (k : ℝ)) =
+      chosenAttachingPeriodicHomotopy j (s, t) :=
+  periodicHomotopy_add_int (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingSquare j) s t
+    k
+
+private theorem PeriodFamily.Boundary.chosenAttachingPeriodicBasepoint (j : Elliptic.Kind) :
+    SpecialPeriods.triangleRegularProject (chosenNativeLift j 0) =
+      PeriodFamily.BoundaryLoopSquares.loopPeriodic
+        (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingBaseLoop j) 0 := by
+  rw [PeriodFamily.BoundaryLoopSquares.loopPeriodic_zero]
+  exact
+    (chosenNativeLift_projection j 0).trans
+      (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingBaseLoop j).source
+
+private def PeriodFamily.Boundary.chosenAttachingPeriodicLift (j : Elliptic.Kind) :
+    C(ℝ, SpecialPeriods.TriangleRegularPoint) :=
+  realCurveLift
+    (PeriodFamily.BoundaryLoopSquares.loopPeriodic
+      (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingBaseLoop j))
+    (chosenNativeLift j 0) (chosenAttachingPeriodicBasepoint j)
+
+@[simp]
+private theorem PeriodFamily.Boundary.chosenAttachingPeriodicLift_zero (j : Elliptic.Kind) :
+    chosenAttachingPeriodicLift j 0 = chosenNativeLift j 0 :=
+  realCurveLift_zero _ _ _
+
+@[simp]
+private theorem
+    PeriodFamily.Boundary.chosenAttachingPeriodicLift_projection (j : Elliptic.Kind) (t : ℝ) :
+    SpecialPeriods.triangleRegularProject (chosenAttachingPeriodicLift j t) =
+      PeriodFamily.BoundaryLoopSquares.loopPeriodic
+        (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingBaseLoop j) t :=
+  realCurveLift_projection _ _ _ t
+
+@[simp]
+private theorem PeriodFamily.Boundary.chosenAttachingPeriodicLift_unit (j : Elliptic.Kind)
+    (t : unitInterval) : chosenAttachingPeriodicLift j (t : ℝ) = chosenNativeLift j t := by
+  have he :
+    SpecialPeriods.triangleRegularProject ∘
+        (fun u : unitInterval => chosenAttachingPeriodicLift j (u : ℝ)) =
+      SpecialPeriods.triangleRegularProject ∘ chosenNativeLift j := by
+    funext u
+    simp only [Function.comp_apply, chosenAttachingPeriodicLift_projection,
+      PeriodFamily.BoundaryLoopSquares.loopPeriodic_unit, chosenNativeLift_projection]
+  exact
+    congr_fun
+      (SpecialPeriods.triangleRegularProject_covering.isCoveringMap.eq_of_comp_eq
+        ((chosenAttachingPeriodicLift j).continuous.comp continuous_subtype_val)
+        (chosenNativeLift j).continuous he 0 (chosenAttachingPeriodicLift_zero j))
+      t
+
+private theorem
+    PeriodFamily.Boundary.chosenAttachingPeriodicLift_translate (j : Elliptic.Kind) (k : ℤ)
+    (t : ℝ) :
+    chosenAttachingPeriodicLift j (t + k) =
+      ((SpecialPeriods.Triangle.ellipticGenerator j)⁻¹ ^ (-k)) •
+        chosenAttachingPeriodicLift j t := by
+  apply
+    realCurveLift_translate
+      (PeriodFamily.BoundaryLoopSquares.loopPeriodic
+        (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingBaseLoop j))
+      (chosenNativeLift j 0) (chosenAttachingPeriodicBasepoint j)
+      (PeriodFamily.BoundaryLoopSquares.loopPeriodic_add_one
+        (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingBaseLoop j))
+      (SpecialPeriods.Triangle.ellipticGenerator j)⁻¹ _ k t
+  change
+    chosenAttachingPeriodicLift j 1 =
+      ((SpecialPeriods.Triangle.ellipticGenerator j)⁻¹)⁻¹ • chosenNativeLift j 0
+  rw [inv_inv]
+  exact (chosenAttachingPeriodicLift_unit j 1).trans (chosenNativeLift_one j)
+
+private theorem
+    PeriodFamily.Boundary.chosenAttachingPeriodicHomotopy_initialLift (j : Elliptic.Kind)
+    (t : ℝ) :
+    PeriodFamily.BoundaryLoopSquares.chosenAttachingPeriodicHomotopy j (0, t) =
+      SpecialPeriods.triangleRegularProject (chosenAttachingPeriodicLift j t) :=
+  (PeriodFamily.BoundaryLoopSquares.chosenAttachingPeriodicHomotopy_initial j t).trans
+    (chosenAttachingPeriodicLift_projection j t).symm
+
+private def PeriodFamily.Boundary.chosenAttachingPeriodicSquareLift (j : Elliptic.Kind) :
+    C(unitInterval × ℝ, SpecialPeriods.TriangleRegularPoint) :=
+  baseHomotopyLift
+    (PeriodFamily.BoundaryLoopSquares.chosenAttachingPeriodicHomotopy j).toContinuousMap
+    (chosenAttachingPeriodicLift j) (chosenAttachingPeriodicHomotopy_initialLift j)
+
+@[simp]
+private theorem
+    PeriodFamily.Boundary.chosenAttachingPeriodicSquareLift_zero (j : Elliptic.Kind) (t : ℝ) :
+    chosenAttachingPeriodicSquareLift j (0, t) = chosenAttachingPeriodicLift j t :=
+  baseHomotopyLift_zero _ _ _ t
+
+@[simp]
+private theorem
+    PeriodFamily.Boundary.chosenAttachingPeriodicSquareLift_projection (j : Elliptic.Kind)
+    (s : unitInterval) (t : ℝ) :
+    SpecialPeriods.triangleRegularProject (chosenAttachingPeriodicSquareLift j (s, t)) =
+      PeriodFamily.BoundaryLoopSquares.chosenAttachingPeriodicHomotopy j (s, t) :=
+  baseHomotopyLift_projection _ _ _ s t
+
+@[simp]
+private theorem PeriodFamily.Boundary.chosenAttachingPeriodicSquareLift_unit (j : Elliptic.Kind)
+    (s t : unitInterval) :
+    chosenAttachingPeriodicSquareLift j (s, (t : ℝ)) = chosenNativeSquareLift j (s, t) := by
+  have hleft :
+    Continuous (fun u : unitInterval => chosenAttachingPeriodicSquareLift j (u, (t : ℝ))) :=
+    (chosenAttachingPeriodicSquareLift j).continuous.comp (continuous_id.prodMk continuous_const)
+  have hright : Continuous (fun u : unitInterval => chosenNativeSquareLift j (u, t)) :=
+    (chosenNativeSquareLift j).continuous.comp (continuous_id.prodMk continuous_const)
+  have he :
+    SpecialPeriods.triangleRegularProject ∘
+        (fun u : unitInterval => chosenAttachingPeriodicSquareLift j (u, (t : ℝ))) =
+      SpecialPeriods.triangleRegularProject ∘
+        (fun u : unitInterval => chosenNativeSquareLift j (u, t)) := by
+    funext u
+    exact
+      (chosenAttachingPeriodicSquareLift_projection j u t).trans
+        ((PeriodFamily.BoundaryLoopSquares.chosenAttachingPeriodicHomotopy_unit j u t).trans
+          (loopSquareLift_projection
+              (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingSquare j)
+              (chosenNativeLift j) (chosenNativeLift_projection j) u t).symm)
+  have hzero :
+    chosenAttachingPeriodicSquareLift j (0, (t : ℝ)) = chosenNativeSquareLift j (0, t) :=
+    (chosenAttachingPeriodicSquareLift_zero j t).trans
+      ((chosenAttachingPeriodicLift_unit j t).trans
+        (loopSquareLift_zero (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingSquare j)
+            (chosenNativeLift j) (chosenNativeLift_projection j) t).symm)
+  exact
+    congr_fun
+      (SpecialPeriods.triangleRegularProject_covering.isCoveringMap.eq_of_comp_eq hleft hright he
+        0 hzero)
+      s
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/PeriodFamily/Core6.lean b/LeanPool/HopfProblem/PeriodFamily/Core6.lean
new file mode 100644
index 000000000..403953341
--- /dev/null
+++ b/LeanPool/HopfProblem/PeriodFamily/Core6.lean
@@ -0,0 +1,5643 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.PeriodFamily.Core5
+public import LeanPool.HopfProblem.Foundations.PeriodTorusTypeOneOne
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology3
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology4
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap1
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+import all LeanPool.HopfProblem.Lattice.Core2
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Pi1.ThreefoldOverlapMappingTorus1
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology7
+import all LeanPool.HopfProblem.PeriodFamily.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods6
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology8
+import all LeanPool.HopfProblem.PeriodFamily.Core2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods7
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import all LeanPool.HopfProblem.Elliptic.Core3
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.Elliptic.Core4
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods8
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen2
+import all LeanPool.HopfProblem.Elliptic.Core5
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods8
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods9
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology2
+import all LeanPool.HopfProblem.Pi1.ThreefoldOverlapMappingTorus2
+import all LeanPool.HopfProblem.PeriodFamily.Core3
+import all LeanPool.HopfProblem.Elliptic.Core6
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods10
+import all LeanPool.HopfProblem.HomologyOfX.TrianglePeriodFamilyHomologyAlgebra
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology9
+import all LeanPool.HopfProblem.PeriodFamily.Core4
+import all LeanPool.HopfProblem.Pi1.TwistGroup
+import all LeanPool.HopfProblem.Pi1.MappingTorusHomology
+import all LeanPool.HopfProblem.PeriodFamily.Core5
+import all LeanPool.HopfProblem.Elliptic.Core7
+import all LeanPool.HopfProblem.Foundations.PeriodTorusTypeOneOne
+
+/-!
+# Hopf problem: period family · core 6
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+@[simp]
+private theorem PeriodFamily.Boundary.chosenAttachingPeriodicSquareLift_tail (j : Elliptic.Kind)
+    (s : unitInterval) :
+    chosenAttachingPeriodicSquareLift j (s, 0) = chosenNativeSquareLift j (s, 0) :=
+  chosenAttachingPeriodicSquareLift_unit j s 0
+
+private theorem PeriodFamily.Boundary.chosenAttachingPeriodicSquareLift_frame (j : Elliptic.Kind) :
+    chosenAttachingPeriodicSquareLift j (1, 0) =
+      nativeTailFrame j • PeriodFamily.Meridians.normalizedRegularMeridianBasepoint :=
+  (chosenAttachingPeriodicSquareLift_tail j 1).trans (nativeTailFrame_apply j)
+
+private theorem
+    PeriodFamily.Boundary.chosenAttachingPeriodicSquareLift_translate (j : Elliptic.Kind)
+    (s : unitInterval) (k : ℤ) (t : ℝ) :
+    chosenAttachingPeriodicSquareLift j (s, t + k) =
+      ((SpecialPeriods.Triangle.ellipticGenerator j)⁻¹ ^ (-k)) •
+        chosenAttachingPeriodicSquareLift j (s, t) :=
+  baseHomotopyLift_translate
+    (PeriodFamily.BoundaryLoopSquares.chosenAttachingPeriodicHomotopy j).toContinuousMap
+    (chosenAttachingPeriodicLift j) (chosenAttachingPeriodicHomotopy_initialLift j)
+    (SpecialPeriods.Triangle.ellipticGenerator j)⁻¹
+    (fun u k v =>
+      PeriodFamily.BoundaryLoopSquares.chosenAttachingPeriodicHomotopy_add_int j u v k)
+    (chosenAttachingPeriodicLift_translate j) s k t
+
+private theorem PeriodFamily.Boundary.chosenAttachingPeriodicSquareLift_add_int (j : Elliptic.Kind)
+    (s : unitInterval) (t : ℝ) (k : ℤ) :
+    chosenAttachingPeriodicSquareLift j (s, t + (k : ℝ)) =
+      (SpecialPeriods.Triangle.ellipticGenerator j ^ k) •
+        chosenAttachingPeriodicSquareLift j (s, t) := by
+  simpa only [inv_zpow, zpow_neg, inv_inv] using
+    chosenAttachingPeriodicSquareLift_translate j s k t
+
+private def PeriodFamily.Boundary.clockwisePeriodicLift (b : Bool) :
+    C(ℝ, SpecialPeriods.TriangleRegularPoint) :=
+  realCurveLift
+    (PeriodFamily.BoundaryLoopSquares.loopPeriodic
+      (SpecialPeriods.EllipticAttachingMeridians.clockwiseRegularMeridian b))
+    PeriodFamily.Meridians.normalizedRegularMeridianBasepoint
+    (PeriodFamily.BoundaryLoopSquares.loopPeriodic_zero
+        (SpecialPeriods.EllipticAttachingMeridians.clockwiseRegularMeridian b)).symm
+
+@[simp]
+private theorem PeriodFamily.Boundary.clockwisePeriodicLift_projection (b : Bool) (t : ℝ) :
+    SpecialPeriods.triangleRegularProject (clockwisePeriodicLift b t) =
+      PeriodFamily.BoundaryLoopSquares.loopPeriodic
+        (SpecialPeriods.EllipticAttachingMeridians.clockwiseRegularMeridian b) t :=
+  realCurveLift_projection _ _ _ t
+
+@[simp]
+private theorem PeriodFamily.Boundary.clockwisePeriodicLift_zero (b : Bool) :
+    clockwisePeriodicLift b 0 = PeriodFamily.Meridians.normalizedRegularMeridianBasepoint :=
+  realCurveLift_zero _ _ _
+
+@[simp]
+private theorem PeriodFamily.Boundary.clockwisePeriodicLift_unit (b : Bool) (t : unitInterval) :
+    clockwisePeriodicLift b (t : ℝ) = clockwiseFinalLift b t := by
+  have he :
+    SpecialPeriods.triangleRegularProject ∘
+        (fun u : unitInterval => clockwisePeriodicLift b (u : ℝ)) =
+      SpecialPeriods.triangleRegularProject ∘ clockwiseFinalLift b := by
+    funext u
+    simp only [Function.comp_apply, clockwisePeriodicLift_projection,
+      PeriodFamily.BoundaryLoopSquares.loopPeriodic_unit, clockwiseFinalLift_projection]
+  exact
+    congr_fun
+      (SpecialPeriods.triangleRegularProject_covering.isCoveringMap.eq_of_comp_eq
+        ((clockwisePeriodicLift b).continuous.comp continuous_subtype_val)
+        (clockwiseFinalLift b).continuous he 0
+        ((clockwisePeriodicLift_zero b).trans (clockwiseFinalLift_zero b).symm))
+      t
+
+private theorem PeriodFamily.Boundary.clockwisePeriodicLift_one (b : Bool) :
+    clockwisePeriodicLift b 1 = clockwiseLiftEndpoint b • clockwisePeriodicLift b 0 := by
+  rw [clockwisePeriodicLift_zero]
+  have h := clockwiseFinalLift_one b
+  rw [clockwiseFinalLift_zero] at h
+  exact (clockwisePeriodicLift_unit b 1).trans h
+
+private theorem PeriodFamily.Boundary.clockwisePeriodicLift_translate (b : Bool) (k : ℤ) (t : ℝ) :
+    clockwisePeriodicLift b (t + k) =
+      ((clockwiseLiftEndpoint b)⁻¹ ^ (-k)) • clockwisePeriodicLift b t := by
+  apply
+    realCurveLift_translate
+      (PeriodFamily.BoundaryLoopSquares.loopPeriodic
+        (SpecialPeriods.EllipticAttachingMeridians.clockwiseRegularMeridian b))
+      PeriodFamily.Meridians.normalizedRegularMeridianBasepoint
+      (PeriodFamily.BoundaryLoopSquares.loopPeriodic_zero
+          (SpecialPeriods.EllipticAttachingMeridians.clockwiseRegularMeridian b)).symm
+      (PeriodFamily.BoundaryLoopSquares.loopPeriodic_add_one
+        (SpecialPeriods.EllipticAttachingMeridians.clockwiseRegularMeridian b))
+      (clockwiseLiftEndpoint b)⁻¹ _ k t
+  change
+    clockwisePeriodicLift b 1 =
+      ((clockwiseLiftEndpoint b)⁻¹)⁻¹ • PeriodFamily.Meridians.normalizedRegularMeridianBasepoint
+  rw [inv_inv, ← clockwisePeriodicLift_zero b]
+  exact clockwisePeriodicLift_one b
+
+private theorem PeriodFamily.Boundary.clockwisePeriodicLift_add_int (b : Bool) (t : ℝ) (k : ℤ) :
+    clockwisePeriodicLift b (t + (k : ℝ)) =
+      (clockwiseLiftEndpoint b ^ k) • clockwisePeriodicLift b t := by
+  simpa only [inv_zpow, zpow_neg, inv_inv] using clockwisePeriodicLift_translate b k t
+
+private theorem PeriodFamily.Boundary.chosenAttachingPeriodicSquareLift_final (j : Elliptic.Kind)
+    (t : ℝ) :
+    chosenAttachingPeriodicSquareLift j (1, t) =
+      nativeTailFrame j •
+        clockwisePeriodicLift (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j)
+          t := by
+  have hleft : Continuous (fun u : ℝ => chosenAttachingPeriodicSquareLift j (1, u)) :=
+    (chosenAttachingPeriodicSquareLift j).continuous.comp (continuous_const.prodMk continuous_id)
+  have hright :
+    Continuous
+      (fun u : ℝ =>
+        nativeTailFrame j •
+          clockwisePeriodicLift
+            (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j) u) :=
+    (ContinuousConstSMul.continuous_const_smul (nativeTailFrame j)).comp
+      (clockwisePeriodicLift
+          (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j)).continuous
+  have he :
+    SpecialPeriods.triangleRegularProject ∘
+        (fun u : ℝ => chosenAttachingPeriodicSquareLift j (1, u)) =
+      SpecialPeriods.triangleRegularProject ∘
+        (fun u : ℝ =>
+          nativeTailFrame j •
+            clockwisePeriodicLift
+              (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j) u) := by
+    funext u
+    simp only [Function.comp_apply, chosenAttachingPeriodicSquareLift_projection,
+      PeriodFamily.BoundaryLoopSquares.chosenAttachingPeriodicHomotopy_final,
+      SpecialPeriods.triangleRegularProject_covering.map_smul, clockwisePeriodicLift_projection]
+  have hzero :
+    chosenAttachingPeriodicSquareLift j (1, 0) =
+      nativeTailFrame j •
+        clockwisePeriodicLift (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j)
+          0 := by
+    rw [clockwisePeriodicLift_zero]
+    exact chosenAttachingPeriodicSquareLift_frame j
+  exact
+    congr_fun
+      (SpecialPeriods.triangleRegularProject_covering.isCoveringMap.eq_of_comp_eq hleft hright he
+        0 hzero)
+      t
+
+private def PeriodFamily.Boundary.nativeClockwiseParameter (j : Elliptic.Kind) (t : ℝ) : ℂ :=
+  SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingParameter j - (t : ℂ) / (j.order : ℂ)
+
+@[simp]
+private theorem PeriodFamily.Boundary.nativeClockwiseParameter_im (j : Elliptic.Kind) (t : ℝ) :
+    (nativeClockwiseParameter j t).im =
+      (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingParameter j).im := by
+  simp [nativeClockwiseParameter, Complex.div_im]
+
+private def
+    PeriodFamily.Boundary.nativeClockwiseRoot (j : Elliptic.Kind) : C(ℝ, SpecialPeriods.Disc)
+    where
+  toFun
+    t :=
+    ⟨CuspUniformization.exponential (nativeClockwiseParameter j t),
+      by
+      change Dist.dist (CuspUniformization.exponential (nativeClockwiseParameter j t)) 0 < 1
+      rw [dist_zero_right]
+      apply SpecialPeriods.TauCusp.exponential_norm_lt_one_of_upperHalfPlane
+      simpa only [nativeClockwiseParameter_im] using
+        SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingParameter_im_pos j⟩
+  continuous_toFun :=
+    (CuspUniformization.exponential_holomorphic.continuous.comp
+          (continuous_const.sub (Complex.continuous_ofReal.div_const (j.order : ℂ)))).subtype_mk
+      _
+
+@[simp]
+private theorem PeriodFamily.Boundary.nativeClockwiseRoot_coe (j : Elliptic.Kind) (t : ℝ) :
+    (nativeClockwiseRoot j t : ℂ) =
+      CuspUniformization.exponential (nativeClockwiseParameter j t) :=
+  rfl
+
+private theorem PeriodFamily.Boundary.nativeClockwiseRoot_ne_zero (j : Elliptic.Kind) (t : ℝ) :
+    (nativeClockwiseRoot j t : ℂ) ≠ 0 :=
+  CuspUniformization.exponential_ne_zero _
+
+private theorem
+    PeriodFamily.Boundary.nativeClockwiseRoot_unit (j : Elliptic.Kind) (t : unitInterval) :
+    nativeClockwiseRoot j (t : ℝ) =
+      Elliptic.LogGauge.logMeridianRoot j
+        (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingParameter j)
+        (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingParameter_im_pos j) t := by
+  apply Subtype.ext
+  rfl
+
+private theorem PeriodFamily.Boundary.nativeClockwiseRoot_add_one (j : Elliptic.Kind) (t : ℝ) :
+    nativeClockwiseRoot j (t + 1) = Elliptic.familyRotation j (nativeClockwiseRoot j t) := by
+  apply Subtype.ext
+  rw [Elliptic.LogGauge.familyRotation_val_exponential, nativeClockwiseRoot_coe,
+    nativeClockwiseRoot_coe]
+  have he :
+    nativeClockwiseParameter j (t + 1) = nativeClockwiseParameter j t + -(1 / (j.order : ℂ)) := by
+    simp only [nativeClockwiseParameter]
+    push_cast
+    ring
+  rw [he, CuspUniformization.exponential_add]
+  exact mul_comm _ _
+
+private def PeriodFamily.Boundary.nativeClockwiseBase (j : Elliptic.Kind) :
+    C(ℝ, SpecialPeriods.TriangleRegularPoint) :=
+  ⟨fun t =>
+    SpecialPeriods.EllipticFilling.localBase j
+      ⟨nativeClockwiseRoot j t, nativeClockwiseRoot_ne_zero j t⟩,
+    (SpecialPeriods.EllipticFilling.localBase_continuous j).comp
+      ((nativeClockwiseRoot j).continuous.subtype_mk _)⟩
+
+private theorem
+    PeriodFamily.Boundary.nativeClockwiseBase_unit (j : Elliptic.Kind) (t : unitInterval) :
+    nativeClockwiseBase j (t : ℝ) = chosenNativeLift j t := by
+  change
+    SpecialPeriods.EllipticFilling.localBase j ⟨nativeClockwiseRoot j (t : ℝ), _⟩ =
+      SpecialPeriods.EllipticFilling.localBase j
+        (Elliptic.LogGauge.logMeridianRootStar (j := j)
+          (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingParameter j)
+          (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingParameter_im_pos j) t)
+  apply congrArg (SpecialPeriods.EllipticFilling.localBase j)
+  apply Subtype.ext
+  exact nativeClockwiseRoot_unit j t
+
+private theorem PeriodFamily.Boundary.nativeClockwiseBase_endpoint (j : Elliptic.Kind) (t : ℝ) :
+    nativeClockwiseBase j (t + 1) =
+      SpecialPeriods.Triangle.ellipticGenerator j • nativeClockwiseBase j t := by
+  let z₀ : Elliptic.LogGauge.BaseStar :=
+    ⟨nativeClockwiseRoot j t, nativeClockwiseRoot_ne_zero j t⟩
+  let z₁ : Elliptic.LogGauge.BaseStar :=
+    ⟨nativeClockwiseRoot j (t + 1), nativeClockwiseRoot_ne_zero j (t + 1)⟩
+  have hz : SpecialPeriods.EllipticFilling.puncturedRotation j z₀ = z₁ :=
+    Subtype.ext (nativeClockwiseRoot_add_one j t).symm
+  have h := SpecialPeriods.EllipticFilling.localBase_rotation j z₀
+  rw [hz] at h
+  exact h
+
+private theorem PeriodFamily.Boundary.nativeClockwiseBase_projection_periodic (j : Elliptic.Kind) :
+    Function.Periodic
+      (fun t : ℝ => SpecialPeriods.triangleRegularProject (nativeClockwiseBase j t)) 1 := by
+  intro t
+  change
+    SpecialPeriods.triangleRegularProject (nativeClockwiseBase j (t + 1)) =
+      SpecialPeriods.triangleRegularProject (nativeClockwiseBase j t)
+  rw [nativeClockwiseBase_endpoint, SpecialPeriods.triangleRegularProject_covering.map_smul]
+
+private theorem
+    PeriodFamily.Boundary.nativeClockwiseBase_projection_eq (j : Elliptic.Kind) (t : ℝ) :
+    SpecialPeriods.triangleRegularProject (nativeClockwiseBase j t) =
+      PeriodFamily.BoundaryLoopSquares.loopPeriodic
+        (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingBaseLoop j) t := by
+  apply
+    congrFun
+      (PeriodFamily.BoundaryLoopSquares.loopPeriodic_unique
+        (fun t : ℝ => SpecialPeriods.triangleRegularProject (nativeClockwiseBase j t))
+        (nativeClockwiseBase_projection_periodic j) _)
+      t
+  intro u
+  rw [nativeClockwiseBase_unit, chosenNativeLift_projection]
+
+private theorem PeriodFamily.Boundary.nativeClockwiseBase_eq_periodicLift (j : Elliptic.Kind) :
+    nativeClockwiseBase j = chosenAttachingPeriodicLift j :=
+  realCurveLift_unique
+    (PeriodFamily.BoundaryLoopSquares.loopPeriodic
+      (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingBaseLoop j))
+    (chosenNativeLift j 0) (chosenAttachingPeriodicBasepoint j) (nativeClockwiseBase j)
+    (nativeClockwiseBase_projection_eq j) (nativeClockwiseBase_unit j 0)
+
+private def PeriodFamily.Boundary.nativePositiveBase (j : Elliptic.Kind) :
+    C(ℝ, SpecialPeriods.TriangleRegularPoint) :=
+  (nativeClockwiseBase j).comp ⟨Neg.neg, ContinuousNeg.continuous_neg⟩
+
+@[simp]
+private theorem PeriodFamily.Boundary.nativePositiveBase_apply (j : Elliptic.Kind) (t : ℝ) :
+    nativePositiveBase j t = nativeClockwiseBase j (-t) :=
+  rfl
+
+private theorem
+    PeriodFamily.Boundary.nativePositiveBase_eq_periodicLift (j : Elliptic.Kind) (t : ℝ) :
+    nativePositiveBase j t = chosenAttachingPeriodicLift j (-t) := by
+  rw [nativePositiveBase_apply, nativeClockwiseBase_eq_periodicLift]
+
+private def PeriodFamily.Boundary.nativePositiveSquareLift (j : Elliptic.Kind) :
+    C(unitInterval × ℝ, SpecialPeriods.TriangleRegularPoint) :=
+  (chosenAttachingPeriodicSquareLift j).comp
+    ⟨fun p => (p.1, -p.2),
+      continuous_fst.prodMk (ContinuousNeg.continuous_neg.comp continuous_snd)⟩
+
+@[simp]
+private theorem PeriodFamily.Boundary.nativePositiveSquareLift_apply (j : Elliptic.Kind)
+    (s : unitInterval) (t : ℝ) :
+    nativePositiveSquareLift j (s, t) = chosenAttachingPeriodicSquareLift j (s, -t) :=
+  rfl
+
+private theorem PeriodFamily.Boundary.nativePositiveSquareLift_zero (j : Elliptic.Kind) (t : ℝ) :
+    nativePositiveSquareLift j (0, t) = nativePositiveBase j t := by
+  rw [nativePositiveSquareLift_apply, chosenAttachingPeriodicSquareLift_zero,
+    nativePositiveBase_eq_periodicLift]
+
+private theorem PeriodFamily.Boundary.nativePositiveSquareLift_translate (j : Elliptic.Kind)
+    (s : unitInterval) (k : ℤ) (t : ℝ) :
+    nativePositiveSquareLift j (s, t + k) =
+      (SpecialPeriods.Triangle.ellipticGenerator j ^ (-k)) • nativePositiveSquareLift j (s, t) := by
+  rw [nativePositiveSquareLift_apply, nativePositiveSquareLift_apply]
+  have ht : -(t + (k : ℝ)) = -t + ((-k : ℤ) : ℝ) := by push_cast; ring
+  rw [ht]
+  exact chosenAttachingPeriodicSquareLift_add_int j s (-t) (-k)
+
+private theorem PeriodFamily.Boundary.nativePositiveSquareLift_final (j : Elliptic.Kind) (t : ℝ) :
+    nativePositiveSquareLift j (1, t) =
+      nativeTailFrame j •
+        clockwisePeriodicLift (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j)
+          (-t) :=
+  chosenAttachingPeriodicSquareLift_final j (-t)
+
+private theorem PeriodFamily.Boundary.exponential_eq_norm_mul_real (s : ℂ) :
+    CuspUniformization.exponential s =
+      (‖CuspUniformization.exponential s‖ : ℂ) * CuspUniformization.exponential (s.re : ℂ) := by
+  simp only [CuspUniformization.exponential]
+  rw [Complex.norm_exp, Complex.ofReal_exp, ← Complex.exp_add]
+  congr 1
+  apply Complex.ext <;> simp [Complex.mul_re, Complex.mul_im]
+
+private def PeriodFamily.Boundary.nativeBoundaryRootRadius (j : Elliptic.Kind) :
+    ThreefoldOverlapMappingTorus.Radius j.order
+      (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :=
+  ⟨‖CuspUniformization.exponential
+        (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingParameter j)‖,
+    norm_pos_iff.mpr (CuspUniformization.exponential_ne_zero _),
+    SpecialPeriods.TauCusp.exponential_norm_lt_one_of_upperHalfPlane
+      (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingParameter_im_pos j),
+    SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingParameter_filling_bound j⟩
+
+private def PeriodFamily.Boundary.nativeBoundaryRootPhase (j : Elliptic.Kind) : ℝ :=
+  (j.order : ℝ) * (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingParameter j).re
+
+private theorem PeriodFamily.Boundary.nativeBoundaryRoot_coe (j : Elliptic.Kind) (t : ℝ) :
+    (ThreefoldOverlapMappingTorus.root j.order
+          (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+          (nativeBoundaryRootRadius j)
+          (((t + nativeBoundaryRootPhase j) / j.order : ℝ) :
+            (ThreefoldOverlapMappingTorus.Circle)) :
+        ℂ) =
+      CuspUniformization.exponential
+        (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingParameter j +
+          (t : ℂ) / (j.order : ℂ)) := by
+  have hm : (j.order : ℝ) ≠ 0 := by exact_mod_cast (Nat.ne_of_gt j.order_pos)
+  have ht :
+    (t + nativeBoundaryRootPhase j) / (j.order : ℝ) =
+      (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingParameter j).re +
+        t / (j.order : ℝ) := by
+    dsimp [nativeBoundaryRootPhase]
+    field_simp
+    ring
+  change
+    ‖CuspUniformization.exponential
+            (SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingParameter j)‖ •
+        (ThreefoldOverlapMappingTorus.phase
+            (((t + nativeBoundaryRootPhase j) / j.order : ℝ) :
+              (ThreefoldOverlapMappingTorus.Circle)) :
+          ℂ) =
+      _
+  rw [ThreefoldOverlapMappingTorus.phase_real, Complex.real_smul, ht]
+  simp only [Complex.ofReal_add, Complex.ofReal_div, Complex.ofReal_natCast]
+  rw [CuspUniformization.exponential_add, ← mul_assoc, ← exponential_eq_norm_mul_real, ←
+    CuspUniformization.exponential_add]
+
+private theorem PeriodFamily.Boundary.nativeBoundaryRoot_eq (j : Elliptic.Kind) (t : ℝ) :
+    ThreefoldOverlapMappingTorus.root j.order
+        (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+        (nativeBoundaryRootRadius j)
+        (((t + nativeBoundaryRootPhase j) / j.order : ℝ) :
+          (ThreefoldOverlapMappingTorus.Circle)) =
+      nativeClockwiseRoot j (-t) := by
+  apply Subtype.ext
+  rw [nativeBoundaryRoot_coe, nativeClockwiseRoot_coe]
+  simp only [nativeClockwiseParameter, Complex.ofReal_neg, neg_div, sub_neg_eq_add]
+
+private def PeriodFamily.Boundary.nativeShiftedBase (j : Elliptic.Kind) (τ : ℝ) :
+    C(ℝ, SpecialPeriods.TriangleRegularPoint) :=
+  (nativePositiveBase j).comp ⟨fun t => t + τ, continuous_id.add continuous_const⟩
+
+private def PeriodFamily.Boundary.nativeShiftedSquareLift (j : Elliptic.Kind) (τ : ℝ) :
+    C(unitInterval × ℝ, SpecialPeriods.TriangleRegularPoint) :=
+  (nativePositiveSquareLift j).comp
+    ⟨fun p => (p.1, p.2 + τ), continuous_fst.prodMk (continuous_snd.add continuous_const)⟩
+
+@[simp]
+private theorem PeriodFamily.Boundary.nativeShiftedSquareLift_zero (j : Elliptic.Kind) (τ t : ℝ) :
+    nativeShiftedSquareLift j τ (0, t) = nativeShiftedBase j τ t :=
+  nativePositiveSquareLift_zero j (t + τ)
+
+private theorem PeriodFamily.Boundary.nativeShiftedSquareLift_translate (j : Elliptic.Kind) (τ : ℝ)
+    (s : unitInterval) (k : ℤ) (t : ℝ) :
+    nativeShiftedSquareLift j τ (s, t + k) =
+      (SpecialPeriods.Triangle.ellipticGenerator j ^ (-k)) • nativeShiftedSquareLift j τ (s, t) :=
+  by
+  change
+    nativePositiveSquareLift j (s, (t + k) + τ) =
+      (SpecialPeriods.Triangle.ellipticGenerator j ^ (-k)) • nativePositiveSquareLift j (s, t + τ)
+  rw [show (t + (k : ℝ)) + τ = (t + τ) + (k : ℝ) by ring]
+  exact nativePositiveSquareLift_translate j s k (t + τ)
+
+private theorem
+    PeriodFamily.Boundary.nativeShiftedBase_translate (j : Elliptic.Kind) (τ : ℝ) (k : ℤ)
+    (t : ℝ) :
+    nativeShiftedBase j τ (t + k) =
+      (SpecialPeriods.Triangle.ellipticGenerator j ^ (-k)) • nativeShiftedBase j τ t := by
+  simpa only [nativeShiftedSquareLift_zero] using nativeShiftedSquareLift_translate j τ 0 k t
+
+private def PeriodFamily.Boundary.nativeGaugeFamilyStar (j : Elliptic.Kind) (τ : ℝ) :
+    C(ℝ × RealTorus₄,
+      Elliptic.LogGauge.FamilyStar (SpecialPeriods.EllipticFilling.specialLocalData j).periods)
+    where
+  toFun
+    p := ⟨(nativeClockwiseRoot j (-(p.1 + τ)), p.2), nativeClockwiseRoot_ne_zero j (-(p.1 + τ))⟩
+  continuous_toFun :=
+    (((nativeClockwiseRoot j).continuous.comp (continuous_fst.add continuous_const).neg).prodMk
+          continuous_snd).subtype_mk
+      _
+
+private def PeriodFamily.Boundary.nativeGaugeCylinder (j : Elliptic.Kind) (τ : ℝ) :
+    C(ℝ × RealTorus₄, RealTorus₄) :=
+  ⟨fun p =>
+    (Elliptic.LogGauge.gaugeMap (SpecialPeriods.EllipticFilling.specialLocalData j).periods
+          j.twist (nativeGaugeFamilyStar j τ p)).val.2,
+    (continuous_snd.comp continuous_subtype_val).comp
+      ((Elliptic.LogGauge.gaugeMap_continuous
+            (SpecialPeriods.EllipticFilling.specialLocalData j).periods j.twist).comp
+        (nativeGaugeFamilyStar j τ).continuous)⟩
+
+@[simp]
+private theorem PeriodFamily.Boundary.nativeGaugeCylinder_apply (j : Elliptic.Kind) (τ t : ℝ)
+    (x : RealTorus₄) :
+    nativeGaugeCylinder j τ (t, x) =
+      x +
+        Elliptic.LogGauge.sectionCoordinate
+          (SpecialPeriods.EllipticFilling.specialLocalData j).periods j.twist
+          (nativeClockwiseRoot j (-(t + τ))) :=
+  rfl
+
+private theorem PeriodFamily.Boundary.nativeShiftedSquareLift_final (j : Elliptic.Kind) (τ t : ℝ) :
+    nativeShiftedSquareLift j τ (1, t) =
+      nativeTailFrame j •
+        clockwisePeriodicLift (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j)
+          (-(t + τ)) :=
+  nativePositiveSquareLift_final j (t + τ)
+
+attribute [local instance] SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace in
+private def PeriodFamily.Boundary.nativeBoundaryInclusion (j : Elliptic.Kind) (τ : ℝ) :
+    C(ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary j,
+      ThreefoldOverlapMappingTorus.PuncturedPiece (Option.some j)) :=
+  ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryInclusionAt j (nativeBoundaryRootRadius j)
+    (nativeBoundaryRootPhase j + τ)
+
+attribute [local instance] SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace in
+private def PeriodFamily.Boundary.nativeRegularBoundaryMap (j : Elliptic.Kind) (τ : ℝ) :
+    C(ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary j,
+      ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁
+          SpecialPeriods.specialPeriodMap_generator₂)).Space) :=
+  ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryToRegularFamilyAt j
+    (nativeBoundaryRootRadius j) (nativeBoundaryRootPhase j + τ)
+
+attribute [local instance] SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace in
+private theorem PeriodFamily.Boundary.nativeBoundaryInclusion_mk (j : Elliptic.Kind) (τ t : ℝ)
+    (x : RealTorus₄) :
+    ((nativeBoundaryInclusion j τ
+              (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (t, x))).val :
+          SpecialPeriods.Threefold.SpecialEllipticPiece j).val =
+      (SpecialPeriods.EllipticFilling.specialLocalData j).quotient j.twist
+        (Elliptic.mainTwist_admissible j) (nativeClockwiseRoot j (-(t + τ)), x) := by
+  have h :=
+    ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryInclusionAt_mk j
+      (nativeBoundaryRootRadius j) (nativeBoundaryRootPhase j + τ) t x
+  have hr :
+    ThreefoldOverlapMappingTorus.root j.order
+        (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+        (nativeBoundaryRootRadius j)
+        (((t + (nativeBoundaryRootPhase j + τ)) / j.order : ℝ) :
+          ThreefoldOverlapMappingTorus.Circle) =
+      nativeClockwiseRoot j (-(t + τ)) := by
+    rw [show t + (nativeBoundaryRootPhase j + τ) = (t + τ) + nativeBoundaryRootPhase j by ring]
+    exact nativeBoundaryRoot_eq j (t + τ)
+  exact
+    h.trans
+      (congrArg
+        ((SpecialPeriods.EllipticFilling.specialLocalData j).quotient j.twist
+          (Elliptic.mainTwist_admissible j))
+        (Prod.ext hr rfl))
+
+attribute [local instance] SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace in
+private theorem PeriodFamily.Boundary.nativeRegularBoundaryMap_gauge (j : Elliptic.Kind) (τ t : ℝ)
+    (x : RealTorus₄) :
+    nativeRegularBoundaryMap j τ (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (t, x)) =
+      SpecialPeriods.EllipticFilling.regularMap SpecialPeriods.specialPeriodMap j
+        SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+        (Elliptic.LogGauge.gaugeMap (SpecialPeriods.EllipticFilling.specialLocalData j).periods
+          j.twist (nativeGaugeFamilyStar j τ (t, x))) := by
+  let y :=
+    nativeBoundaryInclusion j τ (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (t, x))
+  change ThreefoldOverlapMappingTorus.puncturedPieceToRegular (Option.some j) y = _
+  rw [ThreefoldOverlapMappingTorus.Elliptic.puncturedPieceToRegular_elliptic]
+  have hx :
+    (SpecialPeriods.EllipticFilling.specialFullFillingProjection j
+          (y.val : SpecialPeriods.Threefold.SpecialEllipticPiece j).val :
+        ℂ) ≠
+      0 :=
+    (ThreefoldOverlapMappingTorus.Elliptic.specialPiece_regular_iff j y.val).mp y.property
+  have hstar :
+    (⟨(y.val : SpecialPeriods.Threefold.SpecialEllipticPiece j).val, hx⟩ :
+        SpecialPeriods.EllipticFilling.MainFillingStar SpecialPeriods.specialPeriodMap j
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂) =
+      Elliptic.LogGauge.fillingStarProject (SpecialPeriods.EllipticFilling.specialLocalData j)
+        j.twist (Elliptic.mainTwist_admissible j) (nativeGaugeFamilyStar j τ (t, x)) := by
+    apply Subtype.ext
+    exact nativeBoundaryInclusion_mk j τ t x
+  change
+    SpecialPeriods.EllipticFilling.smallOverlap SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+        SpecialPeriods.Threefold.specialBaseCover j y.val =
+      _
+  rw [SpecialPeriods.EllipticFilling.smallOverlap_apply_mainStar SpecialPeriods.specialPeriodMap
+      SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+      SpecialPeriods.Threefold.specialBaseCover j y.val hx,
+    hstar]
+  change
+    (SpecialPeriods.EllipticFilling.tautologicalOverlapBiholomorph SpecialPeriods.specialPeriodMap
+          j SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+          (Elliptic.LogGauge.fillingToTautologicalBiholomorph
+            (SpecialPeriods.EllipticFilling.specialLocalData j) j.twist
+            (Elliptic.mainTwist_admissible j)
+            (Elliptic.LogGauge.fillingStarProject
+              (SpecialPeriods.EllipticFilling.specialLocalData j) j.twist
+              (Elliptic.mainTwist_admissible j) (nativeGaugeFamilyStar j τ (t, x))))).val =
+      _
+  rw [Elliptic.LogGauge.fillingToTautologicalBiholomorph_project]
+  exact
+    congrArg Subtype.val
+      (SpecialPeriods.EllipticFilling.tautologicalOverlapBiholomorph_project
+        SpecialPeriods.specialPeriodMap j SpecialPeriods.specialPeriodMap_generator₁
+        SpecialPeriods.specialPeriodMap_generator₂
+        (Elliptic.LogGauge.gaugeMap (SpecialPeriods.EllipticFilling.specialLocalData j).periods
+          j.twist (nativeGaugeFamilyStar j τ (t, x))))
+
+attribute [local instance] SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace in
+private theorem PeriodFamily.Boundary.nativeRegularBoundaryMap_mk (j : Elliptic.Kind) (τ t : ℝ)
+    (x : RealTorus₄) :
+    nativeRegularBoundaryMap j τ (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (t, x)) =
+      ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).quotient
+        (nativeShiftedBase j τ t, nativeGaugeCylinder j τ (t, x)) := by
+  rw [nativeRegularBoundaryMap_gauge]
+  rfl
+
+attribute [local instance] SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace in
+private theorem PeriodFamily.Boundary.boundaryRegularHomologyMap_native (j : Elliptic.Kind) (τ : ℝ)
+    (n : ℕ) :
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some j) n =
+      SingularMayerVietoris.singularHomologyMap (nativeRegularBoundaryMap j τ) n :=
+  ThreefoldOverlapMappingTorus.Elliptic.boundaryRegularHomologyMap_at j
+    (nativeBoundaryRootRadius j) (nativeBoundaryRootPhase j + τ) n
+
+attribute [local instance] SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace in
+private theorem PeriodFamily.Boundary.nativeGaugeCylinder_deck (j : Elliptic.Kind) (τ : ℝ) (k : ℤ)
+    (p : ℝ × RealTorus₄) :
+    nativeGaugeCylinder j τ (MappingTorus.deck (Elliptic.flatTorusAffine j j.twist) k p) =
+      SpecialPeriods.triangleTorusHomeomorph (SpecialPeriods.Triangle.ellipticGenerator j ^ (-k))
+        (nativeGaugeCylinder j τ p) := by
+  exact
+    fibreMap_deck_of_actual
+      (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+      (Elliptic.flatTorusAffine j j.twist) (nativeRegularBoundaryMap j τ) (nativeShiftedBase j τ)
+      (nativeGaugeCylinder j τ) (SpecialPeriods.Triangle.ellipticGenerator j)
+      (fun p => nativeRegularBoundaryMap_mk j τ p.1 p.2) (nativeShiftedBase_translate j τ) k p
+
+attribute [local instance] SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace in
+private def PeriodFamily.Boundary.normalizedEllipticBoundaryMap (j : Elliptic.Kind) (τ : ℝ) :
+    C(ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary j,
+      ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁
+          SpecialPeriods.specialPeriodMap_generator₂)).Space) :=
+  familyBoundaryMap
+    (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+      SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+    (Elliptic.flatTorusAffine j j.twist) (baseHomotopySlice (nativeShiftedSquareLift j τ) 1)
+    (nativeGaugeCylinder j τ) (SpecialPeriods.Triangle.ellipticGenerator j)
+    (nativeShiftedSquareLift_translate j τ 1) (nativeGaugeCylinder_deck j τ)
+
+attribute [local instance] SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace in
+private theorem
+    PeriodFamily.Boundary.nativeRegularBoundaryMap_homotopic_normalized (j : Elliptic.Kind)
+    (τ : ℝ) : (nativeRegularBoundaryMap j τ).Homotopic (normalizedEllipticBoundaryMap j τ) :=
+  actualBoundary_homotopic_of_base
+    (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+      SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+    (Elliptic.flatTorusAffine j j.twist) (nativeRegularBoundaryMap j τ) (nativeShiftedBase j τ)
+    (nativeGaugeCylinder j τ) (SpecialPeriods.Triangle.ellipticGenerator j)
+    (fun p => nativeRegularBoundaryMap_mk j τ p.1 p.2) (nativeShiftedBase_translate j τ)
+    (nativeShiftedSquareLift j τ) (nativeShiftedSquareLift_zero j τ)
+    (nativeShiftedSquareLift_translate j τ)
+
+attribute [local instance] SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace in
+private theorem
+    PeriodFamily.Boundary.boundaryRegularHomologyMap_normalized (j : Elliptic.Kind) (τ : ℝ)
+    (n : ℕ) :
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some j) n =
+      SingularMayerVietoris.singularHomologyMap (normalizedEllipticBoundaryMap j τ) n :=
+  (boundaryRegularHomologyMap_native j τ n).trans
+    (PeriodTorusHigherHomology.homotopic_homologyMap
+      (nativeRegularBoundaryMap_homotopic_normalized j τ) n)
+
+attribute [local instance] SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace in
+private theorem PeriodFamily.Boundary.normalizedEllipticBoundaryMap_mk (j : Elliptic.Kind) (τ t : ℝ)
+    (x : RealTorus₄) :
+    normalizedEllipticBoundaryMap j τ
+        (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (t, x)) =
+      ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).quotient
+        (nativeShiftedSquareLift j τ (1, t), nativeGaugeCylinder j τ (t, x)) :=
+  rfl
+
+private theorem PeriodFamily.Boundary.clockwiseEndpoint_eq_generator_mo1973_26994 (b : Bool) :
+    clockwiseLiftEndpoint b = PeriodFamily.Meridians.compatibleMeridianGenerator b := by
+  simp only [clockwiseLiftEndpoint, normalizationReversesMeridians_false, Bool.false_eq_true,
+    ite_false]
+
+private theorem PeriodFamily.Boundary.clockwiseFinalLift_eq_reverse_mo1973_26995 (b : Bool)
+    (t : unitInterval) :
+    clockwiseFinalLift b t =
+      PeriodFamily.Meridians.compatibleMeridianGenerator b •
+        PeriodFamily.Meridians.compatibleMeridianLift b (unitInterval.symm t) := by
+  rw [clockwiseFinalLift, normalizationReversesMeridians_false]
+  rfl
+
+private def PeriodFamily.Boundary.canonicalPositiveLift (b : Bool) :
+    C(ℝ, SpecialPeriods.TriangleRegularPoint) :=
+  (clockwisePeriodicLift b).comp ⟨fun t : ℝ => -t, ContinuousNeg.continuous_neg⟩
+
+@[simp]
+private theorem PeriodFamily.Boundary.canonicalPositiveLift_apply (b : Bool) (t : ℝ) :
+    canonicalPositiveLift b t = clockwisePeriodicLift b (-t) :=
+  rfl
+
+private theorem PeriodFamily.Boundary.canonicalPositiveLift_unit (b : Bool) (t : unitInterval) :
+    canonicalPositiveLift b (t : ℝ) = PeriodFamily.Meridians.compatibleMeridianLift b t := by
+  calc
+    _ = clockwisePeriodicLift b ((unitInterval.symm t : ℝ) + (-1 : ℝ)) := by
+      rw [canonicalPositiveLift_apply, unitInterval.coe_symm_eq]
+      congr 1
+      ring
+    _ =
+        (clockwiseLiftEndpoint b ^ (-1 : ℤ)) •
+          clockwisePeriodicLift b (unitInterval.symm t : ℝ) := by
+      simpa only [Int.cast_neg, Int.cast_one] using
+        clockwisePeriodicLift_add_int b (unitInterval.symm t : ℝ) (-1)
+    _ =
+        (PeriodFamily.Meridians.compatibleMeridianGenerator b)⁻¹ •
+          (PeriodFamily.Meridians.compatibleMeridianGenerator b •
+            PeriodFamily.Meridians.compatibleMeridianLift b t) := by
+      rw [clockwiseEndpoint_eq_generator_mo1973_26994, zpow_neg_one, clockwisePeriodicLift_unit,
+        clockwiseFinalLift_eq_reverse_mo1973_26995, unitInterval.symm_symm]
+    _ = _ := inv_smul_smul _ _
+
+private theorem PeriodFamily.Boundary.canonicalPositiveLift_one (b : Bool) :
+    canonicalPositiveLift b 1 =
+      (PeriodFamily.Meridians.compatibleMeridianGenerator b)⁻¹ •
+        PeriodFamily.Meridians.normalizedRegularMeridianBasepoint :=
+  (canonicalPositiveLift_unit b 1).trans (PeriodFamily.Meridians.compatibleMeridianLift b).target
+
+private theorem PeriodFamily.Boundary.canonicalPositiveLift_translate (b : Bool) (k : ℤ) (t : ℝ) :
+    canonicalPositiveLift b (t + k) =
+      (PeriodFamily.Meridians.compatibleMeridianGenerator b ^ (-k)) • canonicalPositiveLift b t :=
+  by
+  simpa only [canonicalPositiveLift_apply, neg_add, Int.cast_neg,
+    clockwiseEndpoint_eq_generator_mo1973_26994] using clockwisePeriodicLift_add_int b (-t) (-k)
+
+private theorem PeriodFamily.Boundary.canonicalPositiveLift_projection (b : Bool) (t : ℝ) :
+    SpecialPeriods.triangleRegularProject (canonicalPositiveLift b t) =
+      PeriodFamily.BoundaryLoopSquares.loopPeriodic
+        (PeriodFamily.Meridians.compatibleRegularMeridian b) t := by
+  have hp :
+    Function.Periodic
+      (fun u : ℝ => SpecialPeriods.triangleRegularProject (canonicalPositiveLift b u)) 1 := by
+    intro u
+    have h :=
+      congrArg SpecialPeriods.triangleRegularProject (canonicalPositiveLift_translate b 1 u)
+    simpa only [Int.cast_one, SpecialPeriods.triangleRegularProject_covering.map_smul] using h
+  have hu (u : unitInterval) :
+    SpecialPeriods.triangleRegularProject (canonicalPositiveLift b (u : ℝ)) =
+      PeriodFamily.Meridians.compatibleRegularMeridian b u := by
+    rw [canonicalPositiveLift_unit]
+    exact compatibleLift_projection b u
+  exact
+    congrFun
+      (PeriodFamily.BoundaryLoopSquares.loopPeriodic_unique (p :=
+        PeriodFamily.Meridians.compatibleRegularMeridian b)
+        (fun u : ℝ => SpecialPeriods.triangleRegularProject (canonicalPositiveLift b u)) hp hu)
+      t
+
+private def PeriodFamily.Boundary.canonicalPositivePhaseLift (b : Bool) (phase : ℝ) :
+    C(ℝ, SpecialPeriods.TriangleRegularPoint) :=
+  (canonicalPositiveLift b).comp ⟨fun t => t + phase, continuous_id.add continuous_const⟩
+
+private theorem PeriodFamily.Boundary.canonicalUpperLeft :
+    PeriodFamily.Homology.upperLiftOnOverlap PeriodFamily.Homology.normalizedSlitBaseLift 0
+        PeriodFamily.Homology.meridianLeftOverlapPoint =
+      SpecialPeriods.triangleGenerator₁⁻¹ •
+        PeriodFamily.Meridians.normalizedRegularMeridianLeftPoint := by
+  have hn : ¬0 < RiemannMapping.normalizationOrientation :=
+    not_lt.mpr normalizationOrientation_nonpos
+  change
+    PeriodFamily.Homology.upperLift PeriodFamily.Homology.normalizedSlitBaseLift
+        ⟨SpecialPeriods.triangleRegularProject
+            PeriodFamily.Meridians.normalizedRegularMeridianLeftPoint,
+          _⟩ =
+      _
+  have hp (t : unitInterval) :
+    SpecialPeriods.triangleRegularProject (PeriodFamily.Meridians.reflectedZeroHalfPath t) ∈
+      PeriodFamily.Homology.upperBase := by
+    rw [PeriodFamily.Homology.mem_regularOpen,
+      PeriodFamily.Meridians.reflectedZeroHalfPath_coordinate,
+      PeriodFamily.Meridians.oppositeZeroPath, ite_eq_right hn]
+    exact SpecialPeriods.Triangle.upperZeroPath_mem_upperSlitPlane t
+  apply
+    PeriodFamily.Homology.upperLift_endpoint PeriodFamily.Homology.normalizedSlitBaseLift _
+      PeriodFamily.Meridians.reflectedZeroHalfPath hp
+  exact (SpecialPeriods.triangleRegularProject_covering.map_smul _).symm
+
+private theorem PeriodFamily.Boundary.canonicalUpperRight :
+    PeriodFamily.Homology.upperLiftOnOverlap PeriodFamily.Homology.normalizedSlitBaseLift 2
+        PeriodFamily.Homology.meridianRightOverlapPoint =
+      SpecialPeriods.triangleGenerator₂ •
+        PeriodFamily.Meridians.normalizedRegularMeridianRightPoint := by
+  have hn : ¬0 < RiemannMapping.normalizationOrientation :=
+    not_lt.mpr normalizationOrientation_nonpos
+  change
+    PeriodFamily.Homology.upperLift PeriodFamily.Homology.normalizedSlitBaseLift
+        ⟨SpecialPeriods.triangleRegularProject
+            PeriodFamily.Meridians.normalizedRegularMeridianRightPoint,
+          _⟩ =
+      _
+  have hp (t : unitInterval) :
+    SpecialPeriods.triangleRegularProject (PeriodFamily.Meridians.reflectedOneHalfPath t) ∈
+      PeriodFamily.Homology.upperBase := by
+    rw [PeriodFamily.Homology.mem_regularOpen,
+      PeriodFamily.Meridians.reflectedOneHalfPath_coordinate,
+      PeriodFamily.Meridians.oppositeOnePath, ite_eq_right hn]
+    exact SpecialPeriods.Triangle.upperOnePath_mem_upperSlitPlane t
+  apply
+    PeriodFamily.Homology.upperLift_endpoint PeriodFamily.Homology.normalizedSlitBaseLift _
+      PeriodFamily.Meridians.reflectedOneHalfPath hp
+  exact (SpecialPeriods.triangleRegularProject_covering.map_smul _).symm
+
+private def PeriodFamily.Boundary.canonicalHalfTime : unitInterval :=
+  ⟨1 / 2, by constructor <;> norm_num⟩
+
+private theorem PeriodFamily.Boundary.path_trans_canonicalHalfTime_mo1973_27012 {X : Type*}
+    [TopologicalSpace X] {a b c : X} (p : Path a b) (q : Path b c) :
+    (p.trans q) canonicalHalfTime = b := by
+  rw [Path.trans_apply, dite_eq_left (show (canonicalHalfTime : ℝ) ≤ 1 / 2 from le_rfl)]
+  calc
+    _ = p 1 := congrArg p (Subtype.ext (by norm_num [canonicalHalfTime]))
+    _ = b := p.target
+
+private theorem PeriodFamily.Boundary.compatibleMeridianLift_false_half :
+    PeriodFamily.Meridians.compatibleMeridianLift Bool.false canonicalHalfTime =
+      SpecialPeriods.triangleGenerator₁⁻¹ •
+        PeriodFamily.Meridians.normalizedRegularMeridianLeftPoint :=
+  path_trans_canonicalHalfTime_mo1973_27012 PeriodFamily.Meridians.reflectedZeroHalfPath
+    (PeriodFamily.Meridians.liftedZeroHalfPath.symm.map
+      (ContinuousConstSMul.continuous_const_smul SpecialPeriods.triangleGenerator₁⁻¹))
+
+private theorem PeriodFamily.Boundary.compatibleMeridianLift_true_half :
+    PeriodFamily.Meridians.compatibleMeridianLift Bool.true canonicalHalfTime =
+      PeriodFamily.Meridians.normalizedRegularMeridianRightPoint :=
+  path_trans_canonicalHalfTime_mo1973_27012 PeriodFamily.Meridians.liftedOneHalfPath
+    ((PeriodFamily.Meridians.reflectedOneHalfPath.symm.map
+          (ContinuousConstSMul.continuous_const_smul SpecialPeriods.triangleGenerator₂⁻¹)).cast
+      (inv_smul_smul SpecialPeriods.triangleGenerator₂
+          PeriodFamily.Meridians.normalizedRegularMeridianRightPoint).symm
+      rfl)
+
+private abbrev PeriodFamily.BoundaryRadius.SmallRadius :=
+  Set.Ioc (0 : ℝ) (1 / 2)
+
+private def PeriodFamily.BoundaryRadius.outerRadius : SmallRadius :=
+  ⟨1 / 2, by norm_num⟩
+
+private abbrev PeriodFamily.BoundaryRadius.RadiusStrip :=
+  SmallRadius × ℝ
+
+private theorem PeriodFamily.BoundaryRadius.small_circle_ne_one_mo1973_27030 (r : SmallRadius)
+    (θ : ℝ) : circleMap 0 (r : ℝ) θ ≠ 1 := by
+  intro h
+  have hn := norm_circleMap_zero (r : ℝ) θ
+  rw [h, NormOneClass.norm_one, abs_of_pos r.property.1] at hn
+  have hr := r.property.2
+  linarith
+
+private theorem PeriodFamily.BoundaryRadius.radialCoordinate_mem_mo1973_27031 (b : Bool)
+    (x : RadiusStrip) :
+    (if b then 1 - circleMap 0 (x.1 : ℝ) (2 * Real.pi * x.2)
+      else circleMap 0 (x.1 : ℝ) (2 * Real.pi * x.2)) ∈
+      SpecialPeriods.Triangle.twicePuncturedPlaneDomain := by
+  have h₀ := circleMap_ne_center (ne_of_gt x.1.property.1) (c := (0 : ℂ)) (θ := 2 * Real.pi * x.2)
+  have h₁ := small_circle_ne_one_mo1973_27030 x.1 (2 * Real.pi * x.2)
+  cases b
+  · exact ⟨h₀, h₁⟩
+  · constructor
+    · exact sub_ne_zero.mpr h₁.symm
+    · intro h
+      exact h₀ (sub_eq_self.mp h)
+
+private def PeriodFamily.BoundaryRadius.radialCoordinate (b : Bool) :
+    C(RadiusStrip, SpecialPeriods.Triangle.TwicePuncturedPlane) :=
+  ⟨fun x =>
+    ⟨if b then 1 - circleMap 0 (x.1 : ℝ) (2 * Real.pi * x.2)
+      else circleMap 0 (x.1 : ℝ) (2 * Real.pi * x.2),
+      radialCoordinate_mem_mo1973_27031 b x⟩,
+    by
+    apply Continuous.subtype_mk
+    cases b <;> dsimp [circleMap] <;> fun_prop⟩
+
+private def PeriodFamily.BoundaryCircleSlits.shiftedTrigPoint (b : Bool)
+    (r : PeriodFamily.BoundaryRadius.SmallRadius) (t : ℝ) : ℂ :=
+  ⟨(if b then 1 else 0) + (r : ℝ) * Real.sin (2 * Real.pi * t),
+    -(r : ℝ) * Real.cos (2 * Real.pi * t)⟩
+
+private theorem PeriodFamily.BoundaryCircleSlits.shiftedTrigPoint_re_ne_mo1973_27039 (b : Bool)
+    (r : PeriodFamily.BoundaryRadius.SmallRadius) (t : ℝ) (hs : Real.sin (2 * Real.pi * t) ≠ 0) :
+    (shiftedTrigPoint b r t).re ≠ 0 ∧ (shiftedTrigPoint b r t).re ≠ 1 := by
+  have hp : (r : ℝ) * Real.sin (2 * Real.pi * t) ≠ 0 := mul_ne_zero (ne_of_gt r.property.1) hs
+  have hle : (r : ℝ) * Real.sin (2 * Real.pi * t) ≤ (r : ℝ) := by
+    simpa only [mul_one] using
+      mul_le_mul_of_nonneg_left (Real.sin_le_one (2 * Real.pi * t)) r.property.1.le
+  have hge : -(r : ℝ) ≤ (r : ℝ) * Real.sin (2 * Real.pi * t) := by
+    simpa only [mul_neg, mul_one] using
+      mul_le_mul_of_nonneg_left (Real.neg_one_le_sin (2 * Real.pi * t)) r.property.1.le
+  have hr := r.property.2
+  cases b with
+  |
+    false =>
+    change
+      0 + (r : ℝ) * Real.sin (2 * Real.pi * t) ≠ 0 ∧ 0 + (r : ℝ) * Real.sin (2 * Real.pi * t) ≠ 1
+    constructor
+    · simpa only [zero_add] using hp
+    · linarith
+  |
+    true =>
+    change
+      1 + (r : ℝ) * Real.sin (2 * Real.pi * t) ≠ 0 ∧ 1 + (r : ℝ) * Real.sin (2 * Real.pi * t) ≠ 1
+    constructor
+    · linarith
+    · intro h
+      apply hp
+      linarith
+
+private theorem PeriodFamily.BoundaryCircleSlits.sin_two_pi_pos_mo1973_27040 {t : ℝ} (ht0 : 0 < t)
+    (ht1 : t < 1 / 2) : 0 < Real.sin (2 * Real.pi * t) := by
+  have hpi : 0 < 2 * Real.pi := mul_pos (by norm_num) Real.pi_pos
+  apply Real.sin_pos_of_pos_of_lt_pi (mul_pos hpi ht0)
+  calc
+    2 * Real.pi * t < 2 * Real.pi * (1 / 2) := mul_lt_mul_of_pos_left ht1 hpi
+    _ = Real.pi := by ring
+
+private theorem PeriodFamily.BoundaryCircleSlits.sin_two_pi_neg_mo1973_27041 {t : ℝ}
+    (ht0 : -(1 / 2 : ℝ) < t) (ht1 : t < 0) : Real.sin (2 * Real.pi * t) < 0 := by
+  have hpi : 0 < 2 * Real.pi := mul_pos (by norm_num) Real.pi_pos
+  apply Real.sin_neg_of_neg_of_neg_pi_lt (mul_neg_of_pos_of_neg hpi ht1)
+  calc
+    -Real.pi = 2 * Real.pi * (-(1 / 2 : ℝ)) := by ring
+    _ < 2 * Real.pi * t := mul_lt_mul_of_pos_left ht0 hpi
+
+private theorem PeriodFamily.BoundaryCircleSlits.shiftedTrigPoint_upper (b : Bool)
+    (r : PeriodFamily.BoundaryRadius.SmallRadius) {t : ℝ} (ht0 : 0 < t) (ht1 : t < 1) :
+    shiftedTrigPoint b r t ∈ SpecialPeriods.Triangle.upperSlitPlane := by
+  rcases lt_trichotomy t (1 / 2) with h | h | h
+  · exact
+      Or.inr
+        (shiftedTrigPoint_re_ne_mo1973_27039 b r t (ne_of_gt (sin_two_pi_pos_mo1973_27040 ht0 h)))
+  · apply Or.inl
+    change 0 < -(r : ℝ) * Real.cos (2 * Real.pi * t)
+    rw [h, show 2 * Real.pi * (1 / 2) = Real.pi by ring, Real.cos_pi]
+    simpa only [mul_neg, mul_one, neg_neg] using r.property.1
+  · have hs := sin_two_pi_neg_mo1973_27041 (t := t - 1) (by linarith) (by linarith)
+    rw [show 2 * Real.pi * (t - 1) = 2 * Real.pi * t - 2 * Real.pi by ring,
+      Real.sin_sub_two_pi] at hs
+    exact Or.inr (shiftedTrigPoint_re_ne_mo1973_27039 b r t (ne_of_lt hs))
+
+private theorem PeriodFamily.BoundaryCircleSlits.shiftedTrigPoint_lower (b : Bool)
+    (r : PeriodFamily.BoundaryRadius.SmallRadius) {t : ℝ} (ht0 : -(1 / 2 : ℝ) < t)
+    (ht1 : t < 1 / 2) : shiftedTrigPoint b r t ∈ SpecialPeriods.Triangle.lowerSlitPlane := by
+  rcases lt_trichotomy t 0 with h | h | h
+  · exact
+      Or.inr
+        (shiftedTrigPoint_re_ne_mo1973_27039 b r t (ne_of_lt (sin_two_pi_neg_mo1973_27041 ht0 h)))
+  · apply Or.inl
+    change -(r : ℝ) * Real.cos (2 * Real.pi * t) < 0
+    rw [h, MulZeroClass.mul_zero, Real.cos_zero, mul_one]
+    exact neg_neg_of_pos r.property.1
+  · exact
+      Or.inr
+        (shiftedTrigPoint_re_ne_mo1973_27039 b r t (ne_of_gt (sin_two_pi_pos_mo1973_27040 h ht1)))
+
+private def PeriodFamily.BoundaryCircleSlits.circlePhase : Bool → ℝ
+  | false => 3 / 4
+  | true => 1 / 4
+
+private def PeriodFamily.BoundaryCircleSlits.shiftedCircle (b : Bool)
+    (r : PeriodFamily.BoundaryRadius.SmallRadius) :
+    C(ℝ, SpecialPeriods.Triangle.TwicePuncturedPlane) :=
+  (PeriodFamily.BoundaryRadius.radialCoordinate b).comp
+    ⟨fun t => (r, t + circlePhase b),
+      continuous_const.prodMk (continuous_id.add continuous_const)⟩
+
+@[simp]
+private theorem PeriodFamily.BoundaryCircleSlits.shiftedCircle_radialCoordinate (b : Bool)
+    (r : PeriodFamily.BoundaryRadius.SmallRadius) (t : ℝ) :
+    shiftedCircle b r t = PeriodFamily.BoundaryRadius.radialCoordinate b (r, t + circlePhase b) :=
+  rfl
+
+private theorem PeriodFamily.BoundaryCircleSlits.shiftedCircle_coe (b : Bool)
+    (r : PeriodFamily.BoundaryRadius.SmallRadius) (t : ℝ) :
+    (shiftedCircle b r t : ℂ) =
+      if b then 1 - circleMap 0 (r : ℝ) (2 * Real.pi * (t + circlePhase b))
+      else circleMap 0 (r : ℝ) (2 * Real.pi * (t + circlePhase b)) :=
+  rfl
+
+private theorem PeriodFamily.BoundaryCircleSlits.shiftedCircle_re (b : Bool)
+    (r : PeriodFamily.BoundaryRadius.SmallRadius) (t : ℝ) :
+    (shiftedCircle b r t : ℂ).re = (if b then 1 else 0) + (r : ℝ) * Real.sin (2 * Real.pi * t) := by
+  cases b
+  · change
+      (circleMap 0 (r : ℝ) (2 * Real.pi * (t + 3 / 4))).re =
+        0 + (r : ℝ) * Real.sin (2 * Real.pi * t)
+    rw [circleMap_zero_re,
+      show 2 * Real.pi * (t + 3 / 4) = (2 * Real.pi * t + Real.pi) + Real.pi / 2 by ring,
+      Real.cos_add_pi_div_two, Real.sin_add_pi, neg_neg, zero_add]
+  · change
+      (1 - circleMap 0 (r : ℝ) (2 * Real.pi * (t + 1 / 4))).re =
+        1 + (r : ℝ) * Real.sin (2 * Real.pi * t)
+    rw [Complex.sub_re, Complex.one_re, circleMap_zero_re,
+      show 2 * Real.pi * (t + 1 / 4) = 2 * Real.pi * t + Real.pi / 2 by ring,
+      Real.cos_add_pi_div_two]
+    ring
+
+private theorem PeriodFamily.BoundaryCircleSlits.shiftedCircle_im (b : Bool)
+    (r : PeriodFamily.BoundaryRadius.SmallRadius) (t : ℝ) :
+    (shiftedCircle b r t : ℂ).im = -(r : ℝ) * Real.cos (2 * Real.pi * t) := by
+  cases b
+  · change
+      (circleMap 0 (r : ℝ) (2 * Real.pi * (t + 3 / 4))).im = -(r : ℝ) * Real.cos (2 * Real.pi * t)
+    rw [circleMap_zero_im,
+      show 2 * Real.pi * (t + 3 / 4) = (2 * Real.pi * t + Real.pi) + Real.pi / 2 by ring,
+      Real.sin_add_pi_div_two, Real.cos_add_pi]
+    ring
+  · change
+      (1 - circleMap 0 (r : ℝ) (2 * Real.pi * (t + 1 / 4))).im =
+        -(r : ℝ) * Real.cos (2 * Real.pi * t)
+    rw [Complex.sub_im, Complex.one_im, circleMap_zero_im,
+      show 2 * Real.pi * (t + 1 / 4) = 2 * Real.pi * t + Real.pi / 2 by ring,
+      Real.sin_add_pi_div_two]
+    ring
+
+private theorem PeriodFamily.BoundaryCircleSlits.shiftedCircle_eq_trig (b : Bool)
+    (r : PeriodFamily.BoundaryRadius.SmallRadius) (t : ℝ) :
+    (shiftedCircle b r t : ℂ) = shiftedTrigPoint b r t :=
+  Complex.ext (shiftedCircle_re b r t) (shiftedCircle_im b r t)
+
+private theorem PeriodFamily.BoundaryCircleSlits.shiftedCircle_upper (b : Bool)
+    (r : PeriodFamily.BoundaryRadius.SmallRadius) {t : ℝ} (ht0 : 0 < t) (ht1 : t < 1) :
+    (shiftedCircle b r t : ℂ) ∈ SpecialPeriods.Triangle.upperSlitPlane := by
+  rw [shiftedCircle_eq_trig]
+  exact shiftedTrigPoint_upper b r ht0 ht1
+
+private theorem PeriodFamily.BoundaryCircleSlits.shiftedCircle_lower (b : Bool)
+    (r : PeriodFamily.BoundaryRadius.SmallRadius) {t : ℝ} (ht0 : -(1 / 2 : ℝ) < t)
+    (ht1 : t < 1 / 2) : (shiftedCircle b r t : ℂ) ∈ SpecialPeriods.Triangle.lowerSlitPlane := by
+  rw [shiftedCircle_eq_trig]
+  exact shiftedTrigPoint_lower b r ht0 ht1
+
+private theorem PeriodFamily.BoundaryCircleSlits.shiftedCircle_mem_upperSlit (b : Bool)
+    (r : PeriodFamily.BoundaryRadius.SmallRadius) {t : ℝ} (ht0 : 0 < t) (ht1 : t < 1) :
+    shiftedCircle b r t ∈ SpecialPeriods.Triangle.upperSlit :=
+  shiftedCircle_upper b r ht0 ht1
+
+private theorem PeriodFamily.BoundaryCircleSlits.shiftedCircle_mem_lowerSlit (b : Bool)
+    (r : PeriodFamily.BoundaryRadius.SmallRadius) {t : ℝ} (ht0 : -(1 / 2 : ℝ) < t)
+    (ht1 : t < 1 / 2) : shiftedCircle b r t ∈ SpecialPeriods.Triangle.lowerSlit :=
+  shiftedCircle_lower b r ht0 ht1
+
+private theorem PeriodFamily.BoundaryCircleSlits.smallCircle_period_mo1973_27057 (r t : ℝ) :
+    circleMap 0 r (2 * Real.pi * (t + 1)) = circleMap 0 r (2 * Real.pi * t) := by
+  rw [show 2 * Real.pi * (t + 1) = 2 * Real.pi * t + 2 * Real.pi by ring]
+  exact periodic_circleMap (0 : ℂ) r (2 * Real.pi * t)
+
+private theorem PeriodFamily.BoundaryCircleSlits.shiftedCircle_periodic (b : Bool)
+    (r : PeriodFamily.BoundaryRadius.SmallRadius) : Function.Periodic (shiftedCircle b r) 1 := by
+  intro t
+  apply Subtype.ext
+  rw [shiftedCircle_coe, shiftedCircle_coe,
+    show t + 1 + circlePhase b = (t + circlePhase b) + 1 by ring, smallCircle_period_mo1973_27057]
+
+private theorem PeriodFamily.BoundaryCircleSlits.shiftedCircle_add_one (b : Bool)
+    (r : PeriodFamily.BoundaryRadius.SmallRadius) (t : ℝ) :
+    shiftedCircle b r (t + 1) = shiftedCircle b r t :=
+  shiftedCircle_periodic b r t
+
+private theorem PeriodFamily.BoundaryCircleSlits.radialCoordinate_outer_positiveMeridian (b : Bool)
+    (t : unitInterval) :
+    PeriodFamily.BoundaryRadius.radialCoordinate b
+        (PeriodFamily.BoundaryRadius.outerRadius, (t : ℝ)) =
+      if b then SpecialPeriods.Triangle.positiveMeridianOne t
+      else SpecialPeriods.Triangle.positiveMeridianZero t := by
+  cases b
+  · apply Subtype.ext
+    change
+      circleMap 0 (1 / 2) (2 * Real.pi * (t : ℝ)) =
+        (SpecialPeriods.Triangle.positiveMeridianZero t : ℂ)
+    exact (SpecialPeriods.Triangle.positiveMeridianZero_eq_circleMap t).symm
+  · apply Subtype.ext
+    change
+      1 - circleMap 0 (1 / 2) (2 * Real.pi * (t : ℝ)) =
+        (SpecialPeriods.Triangle.positiveMeridianOne t : ℂ)
+    rw [← SpecialPeriods.Triangle.positiveMeridianZero_eq_circleMap,
+      SpecialPeriods.Triangle.positiveMeridianZero_apply,
+      SpecialPeriods.Triangle.positiveMeridianOne_apply]
+
+private def PeriodFamily.Boundary.canonicalQuarterOverlapIndex (b : Bool) : Fin 3 :=
+  if b then 2 else 1
+
+private def PeriodFamily.Boundary.canonicalThreeQuarterOverlapIndex (b : Bool) : Fin 3 :=
+  if b then 1 else 0
+
+private def PeriodFamily.Boundary.canonicalQuarterOverlapPoint :
+    (b : Bool) → PeriodFamily.Homology.overlapBase (canonicalQuarterOverlapIndex b)
+  | false => PeriodFamily.Homology.middleOverlapPoint
+  | true => PeriodFamily.Homology.meridianRightOverlapPoint
+
+private def PeriodFamily.Boundary.canonicalThreeQuarterOverlapPoint :
+    (b : Bool) → PeriodFamily.Homology.overlapBase (canonicalThreeQuarterOverlapIndex b)
+  | false => PeriodFamily.Homology.meridianLeftOverlapPoint
+  | true => PeriodFamily.Homology.middleOverlapPoint
+
+private theorem PeriodFamily.Boundary.canonicalPositiveLift_false_half :
+    canonicalPositiveLift Bool.false (1 / 2) =
+      SpecialPeriods.triangleGenerator₁⁻¹ •
+        PeriodFamily.Meridians.normalizedRegularMeridianLeftPoint :=
+  (canonicalPositiveLift_unit Bool.false canonicalHalfTime).trans
+    compatibleMeridianLift_false_half
+
+private theorem PeriodFamily.Boundary.canonicalPositiveLift_true_half :
+    canonicalPositiveLift Bool.true (1 / 2) =
+      PeriodFamily.Meridians.normalizedRegularMeridianRightPoint :=
+  (canonicalPositiveLift_unit Bool.true canonicalHalfTime).trans compatibleMeridianLift_true_half
+
+private def PeriodFamily.Boundary.canonicalPhasedLift (b : Bool) :
+    C(ℝ, SpecialPeriods.TriangleRegularPoint) :=
+  canonicalPositivePhaseLift b (PeriodFamily.BoundaryCircleSlits.circlePhase b)
+
+private theorem PeriodFamily.Boundary.canonicalPhasedLift_quarter_frame (b : Bool) :
+    canonicalPhasedLift b (1 / 4) =
+      (PeriodFamily.Meridians.compatibleMeridianGenerator b)⁻¹ •
+        PeriodFamily.Homology.upperLiftOnOverlap PeriodFamily.Homology.normalizedSlitBaseLift
+          (canonicalQuarterOverlapIndex b) (canonicalQuarterOverlapPoint b) := by
+  cases b
+  · change
+      canonicalPositiveLift Bool.false ((1 / 4 : ℝ) + 3 / 4) =
+        SpecialPeriods.triangleGenerator₁⁻¹ •
+          PeriodFamily.Homology.upperLiftOnOverlap PeriodFamily.Homology.normalizedSlitBaseLift 1
+            PeriodFamily.Homology.middleOverlapPoint
+    rw [show (1 / 4 : ℝ) + 3 / 4 = 1 by norm_num]
+    simp only [canonicalPositiveLift_one, PeriodFamily.Meridians.compatibleMeridianGenerator,
+      PeriodFamily.Homology.upperLift_middleOverlapPoint,
+      PeriodFamily.Homology.normalizedSlitBaseLift_val]
+  · change
+      canonicalPositiveLift Bool.true ((1 / 4 : ℝ) + 1 / 4) =
+        SpecialPeriods.triangleGenerator₂⁻¹ •
+          PeriodFamily.Homology.upperLiftOnOverlap PeriodFamily.Homology.normalizedSlitBaseLift 2
+            PeriodFamily.Homology.meridianRightOverlapPoint
+    rw [show (1 / 4 : ℝ) + 1 / 4 = 1 / 2 by norm_num, canonicalPositiveLift_true_half,
+      canonicalUpperRight, inv_smul_smul]
+
+private theorem PeriodFamily.Boundary.canonicalPhasedLift_threeQuarter_frame (b : Bool) :
+    canonicalPhasedLift b (3 / 4) =
+      (PeriodFamily.Meridians.compatibleMeridianGenerator b)⁻¹ •
+        PeriodFamily.Homology.upperLiftOnOverlap PeriodFamily.Homology.normalizedSlitBaseLift
+          (canonicalThreeQuarterOverlapIndex b) (canonicalThreeQuarterOverlapPoint b) := by
+  cases b
+  · change
+      canonicalPositiveLift Bool.false ((3 / 4 : ℝ) + 3 / 4) =
+        SpecialPeriods.triangleGenerator₁⁻¹ •
+          PeriodFamily.Homology.upperLiftOnOverlap PeriodFamily.Homology.normalizedSlitBaseLift 0
+            PeriodFamily.Homology.meridianLeftOverlapPoint
+    rw [show (3 / 4 : ℝ) + 3 / 4 = (1 / 2 : ℝ) + 1 by norm_num, canonicalUpperLeft]
+    simpa only [Int.cast_one, zpow_neg_one, PeriodFamily.Meridians.compatibleMeridianGenerator,
+      canonicalPositiveLift_false_half] using canonicalPositiveLift_translate Bool.false 1 (1 / 2)
+  · change
+      canonicalPositiveLift Bool.true ((3 / 4 : ℝ) + 1 / 4) =
+        SpecialPeriods.triangleGenerator₂⁻¹ •
+          PeriodFamily.Homology.upperLiftOnOverlap PeriodFamily.Homology.normalizedSlitBaseLift 1
+            PeriodFamily.Homology.middleOverlapPoint
+    rw [show (3 / 4 : ℝ) + 1 / 4 = 1 by norm_num]
+    simp only [canonicalPositiveLift_one, PeriodFamily.Meridians.compatibleMeridianGenerator,
+      PeriodFamily.Homology.upperLift_middleOverlapPoint,
+      PeriodFamily.Homology.normalizedSlitBaseLift_val]
+
+private theorem PeriodFamily.Boundary.canonicalPhasedLift_quarter_project (b : Bool) :
+    SpecialPeriods.triangleRegularProject (canonicalPhasedLift b (1 / 4)) =
+      (canonicalQuarterOverlapPoint b).val := by
+  rw [canonicalPhasedLift_quarter_frame, SpecialPeriods.triangleRegularProject_covering.map_smul,
+    PeriodFamily.Homology.upperLiftOnOverlap_project]
+
+private theorem PeriodFamily.Boundary.canonicalPhasedLift_threeQuarter_project (b : Bool) :
+    SpecialPeriods.triangleRegularProject (canonicalPhasedLift b (3 / 4)) =
+      (canonicalThreeQuarterOverlapPoint b).val := by
+  rw [canonicalPhasedLift_threeQuarter_frame,
+    SpecialPeriods.triangleRegularProject_covering.map_smul,
+    PeriodFamily.Homology.upperLiftOnOverlap_project]
+
+private def PeriodFamily.Boundary.ellipticBoundaryPhase (j : Elliptic.Kind) : ℝ :=
+  PeriodFamily.BoundaryCircleSlits.circlePhase
+    (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j)
+
+private theorem PeriodFamily.Boundary.ellipticBoundary_generator (j : Elliptic.Kind) :
+    PeriodFamily.Meridians.compatibleMeridianGenerator
+        (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j) =
+      SpecialPeriods.Triangle.ellipticGenerator j := by cases j <;> rfl
+
+private def PeriodFamily.Boundary.ellipticBoundaryFrame (j : Elliptic.Kind) :
+    SpecialPeriods.TriangleGroup :=
+  nativeTailFrame j * (SpecialPeriods.Triangle.ellipticGenerator j)⁻¹
+
+private theorem
+    PeriodFamily.Boundary.nativeShiftedSquareLift_canonical (j : Elliptic.Kind) (t : ℝ) :
+    nativeShiftedSquareLift j (ellipticBoundaryPhase j) (1, t) =
+      nativeTailFrame j •
+        canonicalPhasedLift (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j)
+          t :=
+  nativeShiftedSquareLift_final j (ellipticBoundaryPhase j) t
+
+private theorem PeriodFamily.Boundary.nativeShiftedSquareLift_quarter_frame (j : Elliptic.Kind) :
+    nativeShiftedSquareLift j (ellipticBoundaryPhase j) (1, 1 / 4) =
+      ellipticBoundaryFrame j •
+        PeriodFamily.Homology.upperLiftOnOverlap PeriodFamily.Homology.normalizedSlitBaseLift
+          (canonicalQuarterOverlapIndex
+            (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j))
+          (canonicalQuarterOverlapPoint
+            (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j)) := by
+  rw [nativeShiftedSquareLift_canonical, canonicalPhasedLift_quarter_frame,
+    ellipticBoundary_generator, ellipticBoundaryFrame, SemigroupAction.mul_smul]
+
+private theorem
+    PeriodFamily.Boundary.nativeShiftedSquareLift_threeQuarter_frame (j : Elliptic.Kind) :
+    nativeShiftedSquareLift j (ellipticBoundaryPhase j) (1, 3 / 4) =
+      ellipticBoundaryFrame j •
+        PeriodFamily.Homology.upperLiftOnOverlap PeriodFamily.Homology.normalizedSlitBaseLift
+          (canonicalThreeQuarterOverlapIndex
+            (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j))
+          (canonicalThreeQuarterOverlapPoint
+            (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j)) := by
+  rw [nativeShiftedSquareLift_canonical, canonicalPhasedLift_threeQuarter_frame,
+    ellipticBoundary_generator, ellipticBoundaryFrame, SemigroupAction.mul_smul]
+
+private theorem PeriodFamily.Boundary.nativeShiftedSquareLift_quarter_project (j : Elliptic.Kind) :
+    SpecialPeriods.triangleRegularProject
+        (nativeShiftedSquareLift j (ellipticBoundaryPhase j) (1, 1 / 4)) =
+      (canonicalQuarterOverlapPoint
+          (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j)).val := by
+  rw [nativeShiftedSquareLift_canonical, SpecialPeriods.triangleRegularProject_covering.map_smul,
+    canonicalPhasedLift_quarter_project]
+
+private theorem
+    PeriodFamily.Boundary.nativeShiftedSquareLift_threeQuarter_project (j : Elliptic.Kind) :
+    SpecialPeriods.triangleRegularProject
+        (nativeShiftedSquareLift j (ellipticBoundaryPhase j) (1, 3 / 4)) =
+      (canonicalThreeQuarterOverlapPoint
+          (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j)).val := by
+  rw [nativeShiftedSquareLift_canonical, SpecialPeriods.triangleRegularProject_covering.map_smul,
+    canonicalPhasedLift_threeQuarter_project]
+
+private theorem PeriodFamily.Boundary.ellipticBoundaryFrame_inv_wangBoundary (j : Elliptic.Kind)
+    (v : Lattice) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology (MappingTorus.Torus (Elliptic.flatTorusAffine j v))
+        (n + 1)) :
+    PeriodFamily.Homology.triangleHomologyEquiv (ellipticBoundaryFrame j)⁻¹ n
+        (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j v) n a) =
+      MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j v) n a := by
+  rw [ellipticBoundaryFrame, mul_inv_rev, inv_inv, triangleHomologyEquiv_mul_apply,
+    nativeTailFrame_inv_wangBoundary, ellipticWangBoundary_generator_fixed]
+
+private theorem PeriodFamily.Boundary.canonicalRadialCoordinate_periodic (b : Bool)
+    (r : PeriodFamily.BoundaryRadius.SmallRadius) :
+    Function.Periodic (fun t : ℝ => PeriodFamily.BoundaryRadius.radialCoordinate b (r, t)) 1 := by
+  intro t
+  have h :=
+    PeriodFamily.BoundaryCircleSlits.shiftedCircle_add_one b r
+      (t - PeriodFamily.BoundaryCircleSlits.circlePhase b)
+  simpa only [PeriodFamily.BoundaryCircleSlits.shiftedCircle_radialCoordinate,
+    show
+        t - PeriodFamily.BoundaryCircleSlits.circlePhase b + 1 +
+            PeriodFamily.BoundaryCircleSlits.circlePhase b =
+          t + 1
+        by ring,
+    sub_add_cancel] using h
+
+private theorem PeriodFamily.Boundary.canonicalRadialOuter_unit (b : Bool) (t : unitInterval) :
+    PeriodFamily.BoundaryRadius.radialCoordinate b
+        (PeriodFamily.BoundaryRadius.outerRadius, (t : ℝ)) =
+      PeriodFamily.Meridians.compatiblePlanarMeridian b t := by
+  rw [PeriodFamily.BoundaryCircleSlits.radialCoordinate_outer_positiveMeridian,
+    PeriodFamily.Meridians.compatiblePlanarMeridian_eq,
+    ite_eq_right (not_lt.mpr normalizationOrientation_nonpos)]
+  cases b <;> rfl
+
+private theorem PeriodFamily.Boundary.canonicalPositiveLift_coordinate (b : Bool) (t : ℝ) :
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+        (SpecialPeriods.triangleRegularProject (canonicalPositiveLift b t)) =
+      PeriodFamily.BoundaryRadius.radialCoordinate b
+        (PeriodFamily.BoundaryRadius.outerRadius, t) := by
+  have hp :
+    Function.Periodic
+      (fun u : ℝ =>
+        SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+          (SpecialPeriods.triangleRegularProject (canonicalPositiveLift b u)))
+      1 := by
+    intro u
+    simp only [canonicalPositiveLift_projection,
+      PeriodFamily.BoundaryLoopSquares.loopPeriodic_add_one]
+  have hu (u : unitInterval) :
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+        (SpecialPeriods.triangleRegularProject (canonicalPositiveLift b (u : ℝ))) =
+      PeriodFamily.Meridians.compatiblePlanarMeridian b u := by
+    rw [canonicalPositiveLift_projection, PeriodFamily.BoundaryLoopSquares.loopPeriodic_unit,
+      PeriodFamily.Meridians.compatibleRegularMeridian_coordinate]
+  have hpositive :=
+    PeriodFamily.BoundaryLoopSquares.loopPeriodic_unique (p :=
+      PeriodFamily.Meridians.compatiblePlanarMeridian b)
+      (fun u : ℝ =>
+        SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+          (SpecialPeriods.triangleRegularProject (canonicalPositiveLift b u)))
+      hp hu
+  have hradial :=
+    PeriodFamily.BoundaryLoopSquares.loopPeriodic_unique (p :=
+      PeriodFamily.Meridians.compatiblePlanarMeridian b)
+      (fun u : ℝ =>
+        PeriodFamily.BoundaryRadius.radialCoordinate b
+          (PeriodFamily.BoundaryRadius.outerRadius, u))
+      (canonicalRadialCoordinate_periodic b PeriodFamily.BoundaryRadius.outerRadius)
+      (canonicalRadialOuter_unit b)
+  exact (congrFun hpositive t).trans (congrFun hradial t).symm
+
+private theorem PeriodFamily.Boundary.canonicalPhasedLift_coordinate (b : Bool) (t : ℝ) :
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+        (SpecialPeriods.triangleRegularProject (canonicalPhasedLift b t)) =
+      PeriodFamily.BoundaryCircleSlits.shiftedCircle b PeriodFamily.BoundaryRadius.outerRadius
+        t := by
+  change
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+        (SpecialPeriods.triangleRegularProject
+          (canonicalPositiveLift b (t + PeriodFamily.BoundaryCircleSlits.circlePhase b))) =
+      PeriodFamily.BoundaryRadius.radialCoordinate b
+        (PeriodFamily.BoundaryRadius.outerRadius,
+          t + PeriodFamily.BoundaryCircleSlits.circlePhase b)
+  exact canonicalPositiveLift_coordinate b (t + PeriodFamily.BoundaryCircleSlits.circlePhase b)
+
+private theorem
+    PeriodFamily.Boundary.canonicalPhasedLift_mem_upperSlit (b : Bool) {t : ℝ} (ht0 : 0 < t)
+    (ht1 : t < 1) :
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+        (SpecialPeriods.triangleRegularProject (canonicalPhasedLift b t)) ∈
+      SpecialPeriods.Triangle.upperSlit := by
+  rw [canonicalPhasedLift_coordinate]
+  exact
+    PeriodFamily.BoundaryCircleSlits.shiftedCircle_mem_upperSlit b
+      PeriodFamily.BoundaryRadius.outerRadius ht0 ht1
+
+private theorem PeriodFamily.Boundary.canonicalPhasedLift_mem_lowerSlit (b : Bool) {t : ℝ}
+    (ht0 : -(1 / 2 : ℝ) < t) (ht1 : t < 1 / 2) :
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+        (SpecialPeriods.triangleRegularProject (canonicalPhasedLift b t)) ∈
+      SpecialPeriods.Triangle.lowerSlit := by
+  rw [canonicalPhasedLift_coordinate]
+  exact
+    PeriodFamily.BoundaryCircleSlits.shiftedCircle_mem_lowerSlit b
+      PeriodFamily.BoundaryRadius.outerRadius ht0 ht1
+
+private theorem
+    PeriodFamily.Boundary.canonicalPhasedLift_mem_upperBase (b : Bool) {t : ℝ} (ht0 : 0 < t)
+    (ht1 : t < 1) :
+    SpecialPeriods.triangleRegularProject (canonicalPhasedLift b t) ∈
+      PeriodFamily.Homology.upperBase := by
+  rw [PeriodFamily.Homology.mem_regularOpen]
+  exact canonicalPhasedLift_mem_upperSlit b ht0 ht1
+
+private theorem PeriodFamily.Boundary.canonicalPhasedLift_mem_lowerBase (b : Bool) {t : ℝ}
+    (ht0 : -(1 / 2 : ℝ) < t) (ht1 : t < 1 / 2) :
+    SpecialPeriods.triangleRegularProject (canonicalPhasedLift b t) ∈
+      PeriodFamily.Homology.lowerBase := by
+  rw [PeriodFamily.Homology.mem_regularOpen]
+  exact canonicalPhasedLift_mem_lowerSlit b ht0 ht1
+
+private def PeriodFamily.Boundary.ellipticSlitBoundaryMap (j : Elliptic.Kind) :
+    C(ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary j,
+      ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁
+          SpecialPeriods.specialPeriodMap_generator₂)).Space) :=
+  normalizedEllipticBoundaryMap j (ellipticBoundaryPhase j)
+
+private theorem
+    PeriodFamily.Boundary.ellipticSlitBoundaryMap_projection_mk (j : Elliptic.Kind) (t : ℝ)
+    (x : RealTorus₄) :
+    ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).projection
+        (ellipticSlitBoundaryMap j
+          (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (t, x))) =
+      SpecialPeriods.triangleRegularProject
+        (canonicalPhasedLift (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j)
+          t) := by
+  rw [ellipticSlitBoundaryMap, normalizedEllipticBoundaryMap_mk,
+    ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁
+        SpecialPeriods.specialPeriodMap_generator₂)).projection_quotient]
+  change
+    SpecialPeriods.triangleRegularProject
+        (nativeShiftedSquareLift j (ellipticBoundaryPhase j) (1, t)) =
+      _
+  rw [nativeShiftedSquareLift_canonical, SpecialPeriods.triangleRegularProject_covering.map_smul]
+
+private theorem PeriodFamily.Boundary.ellipticSlitBoundaryMap_upper (j : Elliptic.Kind) :
+    Set.MapsTo (ellipticSlitBoundaryMap j)
+      (MappingTorus.HomologyCover.U (Elliptic.flatTorusAffine j j.twist))
+      (PeriodFamily.Homology.upperFamily
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁
+          SpecialPeriods.specialPeriodMap_generator₂)) := by
+  intro q hq
+  let p := MappingTorus.HomologyCover.chartU (Elliptic.flatTorusAffine j j.twist) ⟨q, hq⟩
+  have hp : MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) ((p.1 : ℝ), p.2) = q :=
+    MappingTorus.HomologyCover.chartU_representation (Elliptic.flatTorusAffine j j.twist) ⟨q, hq⟩
+  rw [← hp]
+  change
+    ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).projection
+        (ellipticSlitBoundaryMap j
+          (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) ((p.1 : ℝ), p.2))) ∈
+      PeriodFamily.Homology.upperBase
+  rw [ellipticSlitBoundaryMap_projection_mk]
+  exact
+    canonicalPhasedLift_mem_upperBase
+      (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j) p.1.property.1
+      p.1.property.2
+
+private theorem PeriodFamily.Boundary.ellipticSlitBoundaryMap_lower (j : Elliptic.Kind) :
+    Set.MapsTo (ellipticSlitBoundaryMap j)
+      (MappingTorus.HomologyCover.V (Elliptic.flatTorusAffine j j.twist))
+      (PeriodFamily.Homology.lowerFamily
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁
+          SpecialPeriods.specialPeriodMap_generator₂)) := by
+  intro q hq
+  let p := MappingTorus.HomologyCover.chartV (Elliptic.flatTorusAffine j j.twist) ⟨q, hq⟩
+  have hp : MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) ((p.1 : ℝ), p.2) = q :=
+    MappingTorus.HomologyCover.chartV_representation (Elliptic.flatTorusAffine j j.twist) ⟨q, hq⟩
+  rw [← hp]
+  change
+    ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).projection
+        (ellipticSlitBoundaryMap j
+          (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) ((p.1 : ℝ), p.2))) ∈
+      PeriodFamily.Homology.lowerBase
+  rw [ellipticSlitBoundaryMap_projection_mk]
+  exact
+    canonicalPhasedLift_mem_lowerBase
+      (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j) p.1.property.1
+      p.1.property.2
+
+private theorem PeriodFamily.Boundary.boundaryRegularHomologyMap_slit (j : Elliptic.Kind) (n : ℕ) :
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some j) n =
+      SingularMayerVietoris.singularHomologyMap (ellipticSlitBoundaryMap j) n :=
+  boundaryRegularHomologyMap_normalized j (ellipticBoundaryPhase j) n
+
+private def PeriodFamily.Boundary.ellipticLowerColumn (j : Elliptic.Kind) :
+    C(RealTorus₄,
+      PeriodFamily.Homology.familyIntersection
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁
+          SpecialPeriods.specialPeriodMap_generator₂)) :=
+  lowerColumnMap (Elliptic.flatTorusAffine j j.twist)
+    (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+      SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+    (ellipticSlitBoundaryMap j) (ellipticSlitBoundaryMap_upper j)
+    (ellipticSlitBoundaryMap_lower j)
+
+private def PeriodFamily.Boundary.ellipticUpperColumn (j : Elliptic.Kind) :
+    C(RealTorus₄,
+      PeriodFamily.Homology.familyIntersection
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁
+          SpecialPeriods.specialPeriodMap_generator₂)) :=
+  upperColumnMap (Elliptic.flatTorusAffine j j.twist)
+    (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+      SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+    (ellipticSlitBoundaryMap j) (ellipticSlitBoundaryMap_upper j)
+    (ellipticSlitBoundaryMap_lower j)
+
+private theorem PeriodFamily.Boundary.ellipticLowerColumn_coe (j : Elliptic.Kind) (x : RealTorus₄) :
+    (ellipticLowerColumn j x).val =
+      ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).quotient
+        (nativeShiftedSquareLift j (ellipticBoundaryPhase j) (1, 1 / 4),
+          nativeGaugeCylinder j (ellipticBoundaryPhase j) (1 / 4, x)) := by
+  rw [ellipticLowerColumn, lowerColumnMap_coe]
+  exact normalizedEllipticBoundaryMap_mk j (ellipticBoundaryPhase j) (1 / 4) x
+
+private theorem PeriodFamily.Boundary.ellipticUpperColumn_coe (j : Elliptic.Kind) (x : RealTorus₄) :
+    (ellipticUpperColumn j x).val =
+      ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).quotient
+        (nativeShiftedSquareLift j (ellipticBoundaryPhase j) (1, 3 / 4),
+          nativeGaugeCylinder j (ellipticBoundaryPhase j) (3 / 4, x)) := by
+  rw [ellipticUpperColumn, upperColumnMap_coe]
+  exact normalizedEllipticBoundaryMap_mk j (ellipticBoundaryPhase j) (3 / 4) x
+
+private def PeriodFamily.Boundary.ellipticLowerColumnIndex (j : Elliptic.Kind) : Fin 3 :=
+  if SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j then 2 else 0
+
+private def PeriodFamily.Boundary.ellipticUpperColumnIndex (j : Elliptic.Kind) : Fin 3 :=
+  if SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j then 0 else 1
+
+private theorem PeriodFamily.Boundary.ellipticLowerColumnIndex_overlap (j : Elliptic.Kind) :
+    PeriodFamily.Homology.intersectionIndex (ellipticLowerColumnIndex j) =
+      canonicalQuarterOverlapIndex
+        (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j) := by
+  cases j <;> decide
+
+private theorem PeriodFamily.Boundary.ellipticUpperColumnIndex_overlap (j : Elliptic.Kind) :
+    PeriodFamily.Homology.intersectionIndex (ellipticUpperColumnIndex j) =
+      canonicalThreeQuarterOverlapIndex
+        (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j) := by
+  cases j <;> decide
+
+private def PeriodFamily.Boundary.ellipticLowerColumnPoint (j : Elliptic.Kind) :
+    PeriodFamily.Homology.overlapBase
+      (PeriodFamily.Homology.intersectionIndex (ellipticLowerColumnIndex j)) :=
+  ⟨(canonicalQuarterOverlapPoint
+        (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j)).val,
+    by
+    rw [ellipticLowerColumnIndex_overlap]
+    exact
+      (canonicalQuarterOverlapPoint
+          (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j)).property⟩
+
+private def PeriodFamily.Boundary.ellipticUpperColumnPoint (j : Elliptic.Kind) :
+    PeriodFamily.Homology.overlapBase
+      (PeriodFamily.Homology.intersectionIndex (ellipticUpperColumnIndex j)) :=
+  ⟨(canonicalThreeQuarterOverlapPoint
+        (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j)).val,
+    by
+    rw [ellipticUpperColumnIndex_overlap]
+    exact
+      (canonicalThreeQuarterOverlapPoint
+          (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j)).property⟩
+
+private theorem PeriodFamily.Boundary.ellipticLowerColumn_mem (j : Elliptic.Kind) (x : RealTorus₄) :
+    ellipticLowerColumn j x ∈
+      PeriodFamily.Homology.intersectionPiece
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        (ellipticLowerColumnIndex j) := by
+  change
+    ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).projection
+        (ellipticLowerColumn j x).val ∈
+      PeriodFamily.Homology.overlapBase
+        (PeriodFamily.Homology.intersectionIndex (ellipticLowerColumnIndex j))
+  rw [ellipticLowerColumn_coe,
+    ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁
+        SpecialPeriods.specialPeriodMap_generator₂)).projection_quotient]
+  change
+    SpecialPeriods.triangleRegularProject
+        (nativeShiftedSquareLift j (ellipticBoundaryPhase j) (1, 1 / 4)) ∈
+      _
+  rw [nativeShiftedSquareLift_quarter_project, ellipticLowerColumnIndex_overlap]
+  exact
+    (canonicalQuarterOverlapPoint
+        (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j)).property
+
+private theorem PeriodFamily.Boundary.ellipticUpperColumn_mem (j : Elliptic.Kind) (x : RealTorus₄) :
+    ellipticUpperColumn j x ∈
+      PeriodFamily.Homology.intersectionPiece
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        (ellipticUpperColumnIndex j) := by
+  change
+    ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).projection
+        (ellipticUpperColumn j x).val ∈
+      PeriodFamily.Homology.overlapBase
+        (PeriodFamily.Homology.intersectionIndex (ellipticUpperColumnIndex j))
+  rw [ellipticUpperColumn_coe,
+    ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁
+        SpecialPeriods.specialPeriodMap_generator₂)).projection_quotient]
+  change
+    SpecialPeriods.triangleRegularProject
+        (nativeShiftedSquareLift j (ellipticBoundaryPhase j) (1, 3 / 4)) ∈
+      _
+  rw [nativeShiftedSquareLift_threeQuarter_project, ellipticUpperColumnIndex_overlap]
+  exact
+    (canonicalThreeQuarterOverlapPoint
+        (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j)).property
+
+private theorem PeriodFamily.Boundary.ellipticLowerColumn_frame (j : Elliptic.Kind) :
+    nativeShiftedSquareLift j (ellipticBoundaryPhase j) (1, 1 / 4) =
+      ellipticBoundaryFrame j •
+        PeriodFamily.Homology.upperLiftOnOverlap PeriodFamily.Homology.normalizedSlitBaseLift
+          (PeriodFamily.Homology.intersectionIndex (ellipticLowerColumnIndex j))
+          (ellipticLowerColumnPoint j) := by
+  cases j <;> exact nativeShiftedSquareLift_quarter_frame _
+
+private theorem PeriodFamily.Boundary.ellipticUpperColumn_frame (j : Elliptic.Kind) :
+    nativeShiftedSquareLift j (ellipticBoundaryPhase j) (1, 3 / 4) =
+      ellipticBoundaryFrame j •
+        PeriodFamily.Homology.upperLiftOnOverlap PeriodFamily.Homology.normalizedSlitBaseLift
+          (PeriodFamily.Homology.intersectionIndex (ellipticUpperColumnIndex j))
+          (ellipticUpperColumnPoint j) := by
+  cases j <;> exact nativeShiftedSquareLift_threeQuarter_frame _
+
+private theorem
+    PeriodFamily.Boundary.nativeGaugeCylinder_fibre_translation (j : Elliptic.Kind) (τ t : ℝ)
+    (x : RealTorus₄) : nativeGaugeCylinder j τ (t, x) = x + nativeGaugeCylinder j τ (t, 0) := by
+  simp only [nativeGaugeCylinder_apply, zero_add]
+
+private theorem PeriodFamily.Boundary.ellipticLowerColumn_homology (j : Elliptic.Kind) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    PeriodFamily.Homology.intersectionHomologyEquiv
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        PeriodFamily.Homology.normalizedSlitBaseLift n
+        (SingularMayerVietoris.singularHomologyMap (ellipticLowerColumn j) n a) =
+      componentCoordinates (ellipticLowerColumnIndex j)
+        (PeriodFamily.Homology.triangleHomologyEquiv (ellipticBoundaryFrame j)⁻¹ n a) := by
+  have h :=
+    intersectionHomology_component_affine
+      (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+      PeriodFamily.Homology.normalizedSlitBaseLift (ellipticLowerColumn j)
+      (ellipticLowerColumnIndex j) (ellipticLowerColumn_mem j) (ellipticLowerColumnPoint j)
+      (nativeShiftedSquareLift j (ellipticBoundaryPhase j) (1, 1 / 4)) (ellipticBoundaryFrame j)
+      (ellipticLowerColumn_frame j) (ContinuousMap.id RealTorus₄)
+      (nativeGaugeCylinder j (ellipticBoundaryPhase j) (1 / 4, 0))
+      (fun x => by
+        rw [ellipticLowerColumn_coe, nativeGaugeCylinder_fibre_translation]
+        rfl)
+      n a
+  rw [PeriodTorusHigherHomology.singularHomologyMap_id, LinearMap.id_apply] at h
+  exact h
+
+private theorem PeriodFamily.Boundary.ellipticUpperColumn_homology (j : Elliptic.Kind) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    PeriodFamily.Homology.intersectionHomologyEquiv
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        PeriodFamily.Homology.normalizedSlitBaseLift n
+        (SingularMayerVietoris.singularHomologyMap (ellipticUpperColumn j) n a) =
+      componentCoordinates (ellipticUpperColumnIndex j)
+        (PeriodFamily.Homology.triangleHomologyEquiv (ellipticBoundaryFrame j)⁻¹ n a) := by
+  have h :=
+    intersectionHomology_component_affine
+      (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+      PeriodFamily.Homology.normalizedSlitBaseLift (ellipticUpperColumn j)
+      (ellipticUpperColumnIndex j) (ellipticUpperColumn_mem j) (ellipticUpperColumnPoint j)
+      (nativeShiftedSquareLift j (ellipticBoundaryPhase j) (1, 3 / 4)) (ellipticBoundaryFrame j)
+      (ellipticUpperColumn_frame j) (ContinuousMap.id RealTorus₄)
+      (nativeGaugeCylinder j (ellipticBoundaryPhase j) (3 / 4, 0))
+      (fun x => by
+        rw [ellipticUpperColumn_coe, nativeGaugeCylinder_fibre_translation]
+        rfl)
+      n a
+  rw [PeriodTorusHigherHomology.singularHomologyMap_id, LinearMap.id_apply] at h
+  exact h
+
+private theorem PeriodFamily.Boundary.ellipticLowerColumn_wangBoundary (j : Elliptic.Kind) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (MappingTorus.Torus (Elliptic.flatTorusAffine j j.twist)) (n + 1)) :
+    PeriodFamily.Homology.intersectionHomologyEquiv
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        PeriodFamily.Homology.normalizedSlitBaseLift n
+        (SingularMayerVietoris.singularHomologyMap (ellipticLowerColumn j) n
+          (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) n a)) =
+      componentCoordinates (ellipticLowerColumnIndex j)
+        (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) n a) := by
+  rw [ellipticLowerColumn_homology, ellipticBoundaryFrame_inv_wangBoundary]
+
+private theorem PeriodFamily.Boundary.ellipticUpperColumn_wangBoundary (j : Elliptic.Kind) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (MappingTorus.Torus (Elliptic.flatTorusAffine j j.twist)) (n + 1)) :
+    PeriodFamily.Homology.intersectionHomologyEquiv
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        PeriodFamily.Homology.normalizedSlitBaseLift n
+        (SingularMayerVietoris.singularHomologyMap (ellipticUpperColumn j) n
+          (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) n a)) =
+      componentCoordinates (ellipticUpperColumnIndex j)
+        (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) n a) := by
+  rw [ellipticUpperColumn_homology, ellipticBoundaryFrame_inv_wangBoundary]
+
+private theorem PeriodFamily.Boundary.normalizedSourceDomainEquiv_nonpos (n : ℕ)
+    (x :
+      SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+        SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    PeriodFamily.Homology.normalizedSourceDomainEquiv n x =
+      (x.1, -(PeriodFamily.Homology.generatorHomologyEquiv Bool.true n).symm x.2) := by
+  rw [PeriodFamily.Homology.normalizedSourceDomainEquiv,
+    ite_eq_right (not_lt.mpr normalizationOrientation_nonpos),
+    TrianglePeriodFamilyHomologyAlgebra.inverseSecondCoordinate_apply]
+
+private theorem PeriodFamily.Boundary.ellipticWangBoundary_generator_inv_fixed (j : Elliptic.Kind)
+    (v : Lattice) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology (MappingTorus.Torus (Elliptic.flatTorusAffine j v))
+        (n + 1)) :
+    PeriodFamily.Homology.triangleHomologyEquiv (SpecialPeriods.Triangle.ellipticGenerator j)⁻¹ n
+        (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j v) n a) =
+      MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j v) n a := by
+  rw [PeriodFamily.Homology.triangleHomologyEquiv_inv]
+  apply
+    (PeriodFamily.Homology.triangleHomologyEquiv (SpecialPeriods.Triangle.ellipticGenerator j)
+        n).injective
+  rw [LinearEquiv.apply_symm_apply, ellipticWangBoundary_generator_fixed]
+
+private theorem PeriodFamily.Boundary.ellipticBoundary_sourceKernelProjection_components
+    (j : Elliptic.Kind) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (MappingTorus.Torus (Elliptic.flatTorusAffine j j.twist)) (n + 1)) :
+    (PeriodFamily.Homology.sourceKernelProjection
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          n (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some j) (n + 1) a) :
+        SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+          SingularMayerVietoris.SingularHomology RealTorus₄ n) =
+      PeriodFamily.Homology.normalizedSourceDomainEquiv n
+        (-componentCoordinates (ellipticLowerColumnIndex j)
+                (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) n a) +
+            componentCoordinates (ellipticUpperColumnIndex j)
+              (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) n a)).2 := by
+  refine
+    (congrArg
+          (fun z :
+              SingularMayerVietoris.SingularHomology
+                ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                    SpecialPeriods.specialPeriodMap_generator₁
+                    SpecialPeriods.specialPeriodMap_generator₂)).Space
+                (n + 1) =>
+            (PeriodFamily.Homology.sourceKernelProjection
+                (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                  SpecialPeriods.specialPeriodMap_generator₁
+                  SpecialPeriods.specialPeriodMap_generator₂)
+                n z :
+              SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+                SingularMayerVietoris.SingularHomology RealTorus₄ n))
+          (LinearMap.congr_fun (boundaryRegularHomologyMap_slit j (n + 1)) a)).trans
+      ?_
+  refine
+    (sourceKernelProjection_wangBoundary
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          (Elliptic.flatTorusAffine j j.twist) (ellipticSlitBoundaryMap j)
+          (ellipticSlitBoundaryMap_upper j) (ellipticSlitBoundaryMap_lower j) n a).trans
+      ?_
+  rw [intersectionComparison_antidiagonal, intersectionComparison_lowerColumn,
+    intersectionComparison_upperColumn]
+  change
+    PeriodFamily.Homology.normalizedSourceDomainEquiv n
+        (-PeriodFamily.Homology.intersectionHomologyEquiv
+                (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                  SpecialPeriods.specialPeriodMap_generator₁
+                  SpecialPeriods.specialPeriodMap_generator₂)
+                PeriodFamily.Homology.normalizedSlitBaseLift n
+                (SingularMayerVietoris.singularHomologyMap (ellipticLowerColumn j) n
+                  (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) n a)) +
+            PeriodFamily.Homology.intersectionHomologyEquiv
+              (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                SpecialPeriods.specialPeriodMap_generator₁
+                SpecialPeriods.specialPeriodMap_generator₂)
+              PeriodFamily.Homology.normalizedSlitBaseLift n
+              (SingularMayerVietoris.singularHomologyMap (ellipticUpperColumn j) n
+                (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) n a))).2 =
+      _
+  rw [ellipticLowerColumn_wangBoundary, ellipticUpperColumn_wangBoundary]
+
+private theorem
+    PeriodFamily.Boundary.ellipticBoundary_sourceKernelProjection (j : Elliptic.Kind) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (MappingTorus.Torus (Elliptic.flatTorusAffine j j.twist)) (n + 1)) :
+    (PeriodFamily.Homology.sourceKernelProjection
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          n (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some j) (n + 1) a) :
+        SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+          SingularMayerVietoris.SingularHomology RealTorus₄ n) =
+      if SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j then
+        (0, MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) n a)
+      else (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) n a, 0) := by
+  rw [ellipticBoundary_sourceKernelProjection_components, normalizedSourceDomainEquiv_nonpos]
+  cases j with
+  | three =>
+    simp [componentCoordinates, ellipticLowerColumnIndex, ellipticUpperColumnIndex,
+      SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex]
+  |
+    four =>
+    have hw := ellipticWangBoundary_generator_inv_fixed .four Elliptic.Kind.four.twist n a
+    rw [PeriodFamily.Homology.triangleHomologyEquiv_inv] at hw
+    change
+      (PeriodFamily.Homology.generatorHomologyEquiv Bool.true n).symm
+          (MappingTorusHomology.wangBoundary
+            (Elliptic.flatTorusAffine .four Elliptic.Kind.four.twist) n a) =
+        MappingTorusHomology.wangBoundary
+          (Elliptic.flatTorusAffine .four Elliptic.Kind.four.twist) n a at hw
+    simpa [componentCoordinates, ellipticLowerColumnIndex, ellipticUpperColumnIndex,
+      SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex] using hw
+
+private theorem PeriodFamily.Boundary.ellipticThreeBoundary_sourceKernelProjection (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (MappingTorus.Torus (Elliptic.flatTorusAffine .three Elliptic.Kind.three.twist))
+        (n + 1)) :
+    (PeriodFamily.Homology.sourceKernelProjection
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          n
+          (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap
+            (Option.some Elliptic.Kind.three) (n + 1) a) :
+        SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+          SingularMayerVietoris.SingularHomology RealTorus₄ n) =
+      (MappingTorusHomology.wangBoundary
+          (Elliptic.flatTorusAffine .three Elliptic.Kind.three.twist) n a,
+        0) :=
+  ellipticBoundary_sourceKernelProjection .three n a
+
+private theorem PeriodFamily.Boundary.ellipticFourBoundary_sourceKernelProjection (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (MappingTorus.Torus (Elliptic.flatTorusAffine .four Elliptic.Kind.four.twist)) (n + 1)) :
+    (PeriodFamily.Homology.sourceKernelProjection
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          n
+          (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap
+            (Option.some Elliptic.Kind.four) (n + 1) a) :
+        SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+          SingularMayerVietoris.SingularHomology RealTorus₄ n) =
+      (0,
+        MappingTorusHomology.wangBoundary
+          (Elliptic.flatTorusAffine .four Elliptic.Kind.four.twist) n a) :=
+  ellipticBoundary_sourceKernelProjection .four n a
+
+private theorem PeriodFamily.Boundary.Cusp.boundary_sourceKernelProjection_components (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (MappingTorus.Torus ThreefoldOverlapMappingTorus.Cusp.monodromy) (n + 1)) :
+    (PeriodFamily.Homology.sourceKernelProjection
+          ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData n
+          (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none (n + 1) a) :
+        SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+          SingularMayerVietoris.SingularHomology RealTorus₄ n) =
+      PeriodFamily.Homology.normalizedSourceDomainEquiv n
+        (-PeriodFamily.Boundary.componentCoordinates 1
+                (PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleGenerator₁⁻¹ n
+                  (MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n
+                    a)) +
+            PeriodFamily.Boundary.componentCoordinates 2
+              (PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleGenerator₁⁻¹ n
+                (MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n
+                  a))).2 := by
+  refine
+    (congrArg
+          (fun z :
+              SingularMayerVietoris.SingularHomology
+                ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData.Space (n + 1) =>
+            (PeriodFamily.Homology.sourceKernelProjection
+                ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData n z :
+              SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+                SingularMayerVietoris.SingularHomology RealTorus₄ n))
+          (LinearMap.congr_fun (boundaryRegularHomologyMap_normalized (n + 1)) a)).trans
+      ?_
+  refine
+    (PeriodFamily.Boundary.RefinedWang.sourceKernelProjection_quarterColumns
+          ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData
+          ThreefoldOverlapMappingTorus.Cusp.monodromy normalizedBoundaryMap
+          normalizedBoundaryMap_upper normalizedBoundaryMap_lower n a).trans
+      ?_
+  change
+    PeriodFamily.Homology.normalizedSourceDomainEquiv n
+        (-PeriodFamily.Homology.intersectionHomologyEquiv
+                ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData
+                PeriodFamily.Homology.normalizedSlitBaseLift n
+                (SingularMayerVietoris.singularHomologyMap lowerColumn n
+                  (MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n
+                    a)) +
+            PeriodFamily.Homology.intersectionHomologyEquiv
+              ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData
+              PeriodFamily.Homology.normalizedSlitBaseLift n
+              (SingularMayerVietoris.singularHomologyMap upperColumn n
+                (MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n
+                  a))).2 =
+      _
+  rw [lowerColumn_wangBoundary, upperColumn_wangBoundary]
+
+private theorem PeriodFamily.Boundary.Cusp.boundary_sourceKernelProjection (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (MappingTorus.Torus ThreefoldOverlapMappingTorus.Cusp.monodromy) (n + 1)) :
+    (PeriodFamily.Homology.sourceKernelProjection
+          ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData n
+          (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none (n + 1) a) :
+        SingularMayerVietoris.SingularHomology RealTorus₄ n ×
+          SingularMayerVietoris.SingularHomology RealTorus₄ n) =
+      (-PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleGenerator₁⁻¹ n
+            (MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n a),
+        -MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n a) := by
+  rw [boundary_sourceKernelProjection_components,
+    PeriodFamily.Boundary.normalizedSourceDomainEquiv_nonpos]
+  simpa only [PeriodFamily.Boundary.componentCoordinates_one,
+    PeriodFamily.Boundary.componentCoordinates_two, Prod.neg_mk, Prod.mk_add_mk, neg_zero,
+    zero_add, add_zero] using
+    congrArg
+      (fun b : SingularMayerVietoris.SingularHomology RealTorus₄ n =>
+        (-PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleGenerator₁⁻¹ n
+              (MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy n a),
+          -b))
+      (wangBoundary_inverse_word n a)
+
+private theorem PeriodFamily.Boundary.Cusp.boundary_four_sourceKernelProjection
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (MappingTorus.Torus ThreefoldOverlapMappingTorus.Cusp.monodromy) 4) :
+    (PeriodFamily.Homology.sourceKernelProjection
+          ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData 3
+          (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none 4 a) :
+        SingularMayerVietoris.SingularHomology RealTorus₄ 3 ×
+          SingularMayerVietoris.SingularHomology RealTorus₄ 3) =
+      (-PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleGenerator₁⁻¹ 3
+            (MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy 3 a),
+        -MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy 3 a) :=
+  boundary_sourceKernelProjection 3 a
+
+private def PeriodFamily.Boundary.EllipticCapProduct.boundaryCapH4Equiv (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary) j) 4 ≃ₗ[ℤ]
+      (ℤ × (Fin 2 → ℤ)) :=
+  ((boundaryCapHomologyEquiv j 3).toAddEquiv.trans
+      ((Elliptic.HigherHomology.surfaceH4Equiv j
+            (SpecialPeriods.EllipticFilling.specialLocalData
+                j).centralPeriod).toAddEquiv.prodCongr
+        (Elliptic.HigherHomology.surfaceH3Equiv j
+            (SpecialPeriods.EllipticFilling.specialLocalData
+                j).centralPeriod).toAddEquiv)).toIntLinearEquiv
+
+@[simp]
+private theorem
+    PeriodFamily.Boundary.EllipticCapProduct.boundaryCapH4Equiv_apply (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary) j) 4) :
+    boundaryCapH4Equiv j a =
+      (Elliptic.HigherHomology.surfaceH4Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+          (boundaryCapHomologyEquiv j 3 a).1,
+        Elliptic.HigherHomology.surfaceH3Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+          (boundaryCapHomologyEquiv j 3 a).2) :=
+  rfl
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.boundaryFillingHomologyMap_H4_first
+    (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary) j) 4) :
+    Elliptic.HigherHomology.surfaceH4Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+        (ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j 4
+          (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) 4 a)) =
+      (boundaryCapH4Equiv j a).1 := by
+  rw [boundaryFillingHomologyMap_first]
+  rfl
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapProduct.boundaryCapH4Equiv_section (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) 4) :
+    boundaryCapH4Equiv j (SingularMayerVietoris.singularHomologyMap (capSection j) 4 a) =
+      (Elliptic.HigherHomology.surfaceH4Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a,
+        0) := by
+  rw [boundaryCapH4Equiv_apply, boundaryCapHomologyEquiv_section]
+  simp only [map_zero]
+
+private def
+    PeriodFamily.Boundary.EllipticCapProduct.boundaryCapH4CoordinatesMap (j : Elliptic.Kind) :
+    (ℤ × (Fin 2 → ℤ)) →ₗ[ℤ] ℤ :=
+  (Elliptic.HigherHomology.surfaceH4Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).toLinearMap.comp
+    ((ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j 4).toLinearMap.comp
+      ((ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) 4).comp
+        (boundaryCapH4Equiv j).symm.toLinearMap))
+
+private def PeriodFamily.Boundary.EllipticCapProduct.boundaryCapH4KernelEquiv (j : Elliptic.Kind) :
+    LinearMap.ker
+        (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) 4) ≃ₗ[ℤ]
+      (Fin 2 → ℤ) :=
+  (boundaryCapKernelEquiv j 3).trans
+    (Elliptic.HigherHomology.surfaceH3Equiv j
+      (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod)
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticCapProduct.boundaryCapH4KernelEquiv_symm_val
+    (j : Elliptic.Kind) (a : Fin 2 → ℤ) :
+    ((boundaryCapH4KernelEquiv j).symm a).val =
+      boundaryPositiveCircleCross j 3
+        ((Elliptic.HigherHomology.surfaceH3Equiv j
+              (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).symm
+          a) :=
+  rfl
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.reflection_mk_shifted {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y)
+    (F : C(MappingTorus.Torus f, MappingTorus.Torus g)) (G : ℝ → C(X, Y))
+    (hF : ∀ (t : ℝ) (x : X), F (MappingTorus.mk f (t, x)) = MappingTorus.mk g (-t, G t x)) (t : ℝ)
+    (x : X) : F (MappingTorus.mk f (t, x)) = MappingTorus.mk g (1 - t, g.symm (G t x)) := by
+  rw [hF]
+  calc
+    MappingTorus.mk g (-t, G t x) = MappingTorus.mk g (-t + 1, g.symm (G t x)) := by
+      rw [MappingTorus.mk_add_one, Homeomorph.apply_symm_apply]
+    _ = MappingTorus.mk g (1 - t, g.symm (G t x)) :=
+      congrArg (fun s : ℝ => MappingTorus.mk g (s, g.symm (G t x))) (by ring)
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.reflection_mapsTo_U {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y)
+    (F : C(MappingTorus.Torus f, MappingTorus.Torus g)) (G : ℝ → C(X, Y))
+    (hF : ∀ (t : ℝ) (x : X), F (MappingTorus.mk f (t, x)) = MappingTorus.mk g (-t, G t x)) :
+    Set.MapsTo F (MappingTorus.HomologyCover.U f) (MappingTorus.HomologyCover.U g) := by
+  intro q hq
+  let p := MappingTorus.HomologyCover.chartU f ⟨q, hq⟩
+  let t : Set.Ioo (0 : ℝ) 1 :=
+    ⟨1 - (p.1 : ℝ), by constructor <;> linarith [p.1.property.1, p.1.property.2]⟩
+  have he :
+    F q =
+      ((MappingTorus.HomologyCover.chartU g).symm (t, g.symm (G p.1 p.2)) :
+        MappingTorus.Torus g) := by
+    rw [MappingTorus.HomologyCover.chartU_symm_coe]
+    exact
+      (congrArg F (MappingTorus.HomologyCover.chartU_representation f ⟨q, hq⟩)).symm.trans
+        (reflection_mk_shifted f g F G hF p.1 p.2)
+  rw [he]
+  exact ((MappingTorus.HomologyCover.chartU g).symm (t, g.symm (G p.1 p.2))).property
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.reflection_mapsTo_V {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y)
+    (F : C(MappingTorus.Torus f, MappingTorus.Torus g)) (G : ℝ → C(X, Y))
+    (hF : ∀ (t : ℝ) (x : X), F (MappingTorus.mk f (t, x)) = MappingTorus.mk g (-t, G t x)) :
+    Set.MapsTo F (MappingTorus.HomologyCover.V f) (MappingTorus.HomologyCover.V g) := by
+  intro q hq
+  let p := MappingTorus.HomologyCover.chartV f ⟨q, hq⟩
+  let t : Set.Ioo (-(1 / 2 : ℝ)) (1 / 2) :=
+    ⟨-(p.1 : ℝ), by constructor <;> linarith [p.1.property.1, p.1.property.2]⟩
+  have he :
+    F q = ((MappingTorus.HomologyCover.chartV g).symm (t, G p.1 p.2) : MappingTorus.Torus g) := by
+    rw [MappingTorus.HomologyCover.chartV_symm_coe]
+    exact
+      (congrArg F (MappingTorus.HomologyCover.chartV_representation f ⟨q, hq⟩)).symm.trans
+        (hF p.1 p.2)
+  rw [he]
+  exact ((MappingTorus.HomologyCover.chartV g).symm (t, G p.1 p.2)).property
+
+private def PeriodFamily.Boundary.EllipticCapProduct.reflectionIntersectionMap {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y)
+    (F : C(MappingTorus.Torus f, MappingTorus.Torus g)) (G : ℝ → C(X, Y))
+    (hF : ∀ (t : ℝ) (x : X), F (MappingTorus.mk f (t, x)) = MappingTorus.mk g (-t, G t x)) :
+    C((MappingTorus.HomologyCover.U f ∩ MappingTorus.HomologyCover.V f :
+        Set (MappingTorus.Torus f)),
+      (MappingTorus.HomologyCover.U g ∩ MappingTorus.HomologyCover.V g :
+        Set (MappingTorus.Torus g))) :=
+  SingularMayerVietoris.intersectionRestriction F (MappingTorus.HomologyCover.U f)
+    (MappingTorus.HomologyCover.V f) (MappingTorus.HomologyCover.U g)
+    (MappingTorus.HomologyCover.V g) (reflection_mapsTo_U f g F G hF)
+    (reflection_mapsTo_V f g F G hF)
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapProduct.reflectionIntersectionMap_lower {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y)
+    (F : C(MappingTorus.Torus f, MappingTorus.Torus g)) (G : ℝ → C(X, Y))
+    (hF : ∀ (t : ℝ) (x : X), F (MappingTorus.mk f (t, x)) = MappingTorus.mk g (-t, G t x)) :
+    (reflectionIntersectionMap f g F G hF).comp (PeriodFamily.Boundary.lowerComponentFibre f) =
+      (PeriodFamily.Boundary.upperComponentFibre g).comp ((g.symm : C(Y, Y)).comp (G (1 / 4))) := by
+  apply ContinuousMap.ext
+  intro x
+  apply Subtype.ext
+  change
+    F (PeriodFamily.Boundary.lowerComponentFibre f x).val =
+      (PeriodFamily.Boundary.upperComponentFibre g (g.symm (G (1 / 4) x))).val
+  rw [PeriodFamily.Boundary.lowerComponentFibre_coe,
+    PeriodFamily.Boundary.upperComponentFibre_coe]
+  convert reflection_mk_shifted f g F G hF (1 / 4) x using 1; norm_num
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapProduct.reflectionIntersectionMap_upper {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y)
+    (F : C(MappingTorus.Torus f, MappingTorus.Torus g)) (G : ℝ → C(X, Y))
+    (hF : ∀ (t : ℝ) (x : X), F (MappingTorus.mk f (t, x)) = MappingTorus.mk g (-t, G t x)) :
+    (reflectionIntersectionMap f g F G hF).comp (PeriodFamily.Boundary.upperComponentFibre f) =
+      (PeriodFamily.Boundary.lowerComponentFibre g).comp ((g.symm : C(Y, Y)).comp (G (3 / 4))) := by
+  apply ContinuousMap.ext
+  intro x
+  apply Subtype.ext
+  change
+    F (PeriodFamily.Boundary.upperComponentFibre f x).val =
+      (PeriodFamily.Boundary.lowerComponentFibre g (g.symm (G (3 / 4) x))).val
+  rw [PeriodFamily.Boundary.upperComponentFibre_coe,
+    PeriodFamily.Boundary.lowerComponentFibre_coe]
+  convert reflection_mk_shifted f g F G hF (3 / 4) x using 1; norm_num
+
+private def PeriodFamily.Boundary.EllipticCapProduct.reflectionIntersectionComparison {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y)
+    (F : C(MappingTorus.Torus f, MappingTorus.Torus g)) (G : ℝ → C(X, Y))
+    (hF : ∀ (t : ℝ) (x : X), F (MappingTorus.mk f (t, x)) = MappingTorus.mk g (-t, G t x))
+    (n : ℕ) :
+    (SingularMayerVietoris.SingularHomology X n ×
+        SingularMayerVietoris.SingularHomology X n) →ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology Y n × SingularMayerVietoris.SingularHomology Y n) :=
+  (MappingTorusHomology.intersectionHomologyEquiv g n).toLinearMap.comp
+    ((SingularMayerVietoris.singularHomologyMap (reflectionIntersectionMap f g F G hF) n).comp
+      (MappingTorusHomology.intersectionHomologyEquiv f n).symm.toLinearMap)
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticCapProduct.reflectionIntersectionComparison_apply
+    {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y)
+    (F : C(MappingTorus.Torus f, MappingTorus.Torus g)) (G : ℝ → C(X, Y))
+    (hF : ∀ (t : ℝ) (x : X), F (MappingTorus.mk f (t, x)) = MappingTorus.mk g (-t, G t x)) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology X n × SingularMayerVietoris.SingularHomology X n) :
+    reflectionIntersectionComparison f g F G hF n a =
+      MappingTorusHomology.intersectionHomologyEquiv g n
+        (SingularMayerVietoris.singularHomologyMap (reflectionIntersectionMap f g F G hF) n
+          ((MappingTorusHomology.intersectionHomologyEquiv f n).symm a)) :=
+  rfl
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.reflectionIntersectionComparison_lower
+    {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y)
+    (F : C(MappingTorus.Torus f, MappingTorus.Torus g)) (G : ℝ → C(X, Y))
+    (hF : ∀ (t : ℝ) (x : X), F (MappingTorus.mk f (t, x)) = MappingTorus.mk g (-t, G t x)) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology X n) :
+    reflectionIntersectionComparison f g F G hF n (a, 0) =
+      (0, SingularMayerVietoris.singularHomologyMap ((g.symm : C(Y, Y)).comp (G (1 / 4))) n a) := by
+  rw [reflectionIntersectionComparison_apply,
+    PeriodFamily.Boundary.intersectionHomologyEquiv_symm_lower, ← LinearMap.comp_apply, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp, reflectionIntersectionMap_lower,
+    PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply,
+    PeriodFamily.Boundary.upperComponentFibre_homology]
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.reflectionIntersectionComparison_upper
+    {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y)
+    (F : C(MappingTorus.Torus f, MappingTorus.Torus g)) (G : ℝ → C(X, Y))
+    (hF : ∀ (t : ℝ) (x : X), F (MappingTorus.mk f (t, x)) = MappingTorus.mk g (-t, G t x)) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology X n) :
+    reflectionIntersectionComparison f g F G hF n (0, a) =
+      (SingularMayerVietoris.singularHomologyMap ((g.symm : C(Y, Y)).comp (G (3 / 4))) n a, 0) := by
+  rw [reflectionIntersectionComparison_apply,
+    PeriodFamily.Boundary.intersectionHomologyEquiv_symm_upper, ← LinearMap.comp_apply, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp, reflectionIntersectionMap_upper,
+    PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply,
+    PeriodFamily.Boundary.lowerComponentFibre_homology]
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.reflectionIntersectionComparison_pair
+    {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y)
+    (F : C(MappingTorus.Torus f, MappingTorus.Torus g)) (G : ℝ → C(X, Y))
+    (hF : ∀ (t : ℝ) (x : X), F (MappingTorus.mk f (t, x)) = MappingTorus.mk g (-t, G t x)) (n : ℕ)
+    (a b : SingularMayerVietoris.SingularHomology X n) :
+    reflectionIntersectionComparison f g F G hF n (a, b) =
+      (SingularMayerVietoris.singularHomologyMap ((g.symm : C(Y, Y)).comp (G (3 / 4))) n b,
+        SingularMayerVietoris.singularHomologyMap ((g.symm : C(Y, Y)).comp (G (1 / 4))) n a) := by
+  have hab : (a, b) = (a, (0 : SingularMayerVietoris.SingularHomology X n)) + (0, b) := by
+    ext <;> simp
+  rw [hab, map_add, reflectionIntersectionComparison_lower,
+    reflectionIntersectionComparison_upper]
+  simp
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.reflection_boundaryCoordinates_naturality
+    {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y)
+    (F : C(MappingTorus.Torus f, MappingTorus.Torus g)) (G : ℝ → C(X, Y))
+    (hF : ∀ (t : ℝ) (x : X), F (MappingTorus.mk f (t, x)) = MappingTorus.mk g (-t, G t x)) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) (n + 1)) :
+    MappingTorusHomology.boundaryCoordinates g n
+        (SingularMayerVietoris.singularHomologyMap F (n + 1) a) =
+      MappingTorusHomology.intersectionHomologyEquiv g n
+        (SingularMayerVietoris.singularHomologyMap (reflectionIntersectionMap f g F G hF) n
+          (MappingTorusHomology.mayerVietorisConnecting f n a)) := by
+  have h :=
+    SingularMayerVietoris.connectingHomomorphism_naturality_apply F
+      (MappingTorus.HomologyCover.U f) (MappingTorus.HomologyCover.V f)
+      (MappingTorus.HomologyCover.U g) (MappingTorus.HomologyCover.V g)
+      (reflection_mapsTo_U f g F G hF) (reflection_mapsTo_V f g F G hF)
+      (MappingTorus.HomologyCover.U_open f) (MappingTorus.HomologyCover.V_open f)
+      (MappingTorus.HomologyCover.cover f) (MappingTorus.HomologyCover.U_open g)
+      (MappingTorus.HomologyCover.V_open g) (MappingTorus.HomologyCover.cover g) n a
+  exact (congrArg (MappingTorusHomology.intersectionHomologyEquiv g n) h).symm
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.reflection_boundaryCoordinates_comparison
+    {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y)
+    (F : C(MappingTorus.Torus f, MappingTorus.Torus g)) (G : ℝ → C(X, Y))
+    (hF : ∀ (t : ℝ) (x : X), F (MappingTorus.mk f (t, x)) = MappingTorus.mk g (-t, G t x)) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) (n + 1)) :
+    MappingTorusHomology.boundaryCoordinates g n
+        (SingularMayerVietoris.singularHomologyMap F (n + 1) a) =
+      reflectionIntersectionComparison f g F G hF n
+        (-MappingTorusHomology.wangBoundary f n a, MappingTorusHomology.wangBoundary f n a) := by
+  rw [reflection_boundaryCoordinates_naturality f g F G hF,
+    PeriodFamily.Boundary.mappingTorusConnecting_eq_marked_boundary f n a]
+  rfl
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.reflection_boundaryCoordinates_quarters
+    {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y)
+    (F : C(MappingTorus.Torus f, MappingTorus.Torus g)) (G : ℝ → C(X, Y))
+    (hF : ∀ (t : ℝ) (x : X), F (MappingTorus.mk f (t, x)) = MappingTorus.mk g (-t, G t x)) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) (n + 1)) :
+    MappingTorusHomology.boundaryCoordinates g n
+        (SingularMayerVietoris.singularHomologyMap F (n + 1) a) =
+      (SingularMayerVietoris.singularHomologyMap ((g.symm : C(Y, Y)).comp (G (3 / 4))) n
+          (MappingTorusHomology.wangBoundary f n a),
+        -SingularMayerVietoris.singularHomologyMap ((g.symm : C(Y, Y)).comp (G (1 / 4))) n
+            (MappingTorusHomology.wangBoundary f n a)) := by
+  rw [reflection_boundaryCoordinates_comparison f g F G hF, reflectionIntersectionComparison_pair,
+    map_neg]
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.wangBoundary_timeReflection {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y)
+    (F : C(MappingTorus.Torus f, MappingTorus.Torus g)) (G : ℝ → C(X, Y))
+    (hF : ∀ (t : ℝ) (x : X), F (MappingTorus.mk f (t, x)) = MappingTorus.mk g (-t, G t x)) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) (n + 1)) :
+    MappingTorusHomology.wangBoundary g n
+        (SingularMayerVietoris.singularHomologyMap F (n + 1) a) =
+      -SingularMayerVietoris.singularHomologyMap ((g.symm : C(Y, Y)).comp (G (3 / 4))) n
+          (MappingTorusHomology.wangBoundary f n a) := by
+  change
+    -(MappingTorusHomology.boundaryCoordinates g n
+            (SingularMayerVietoris.singularHomologyMap F (n + 1) a)).1 =
+      _
+  rw [reflection_boundaryCoordinates_quarters f g F G hF]
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.wangBoundary_timeReflection_of_quarter
+    {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y] (f : X ≃ₜ X) (g : Y ≃ₜ Y)
+    (F : C(MappingTorus.Torus f, MappingTorus.Torus g)) (G : ℝ → C(X, Y))
+    (hF : ∀ (t : ℝ) (x : X), F (MappingTorus.mk f (t, x)) = MappingTorus.mk g (-t, G t x))
+    (h : C(X, Y)) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) (n + 1))
+    (hquarter :
+      SingularMayerVietoris.singularHomologyMap ((g.symm : C(Y, Y)).comp (G (3 / 4))) n
+          (MappingTorusHomology.wangBoundary f n a) =
+        SingularMayerVietoris.singularHomologyMap h n (MappingTorusHomology.wangBoundary f n a)) :
+    MappingTorusHomology.wangBoundary g n
+        (SingularMayerVietoris.singularHomologyMap F (n + 1) a) =
+      -SingularMayerVietoris.singularHomologyMap h n (MappingTorusHomology.wangBoundary f n a) := by
+  rw [wangBoundary_timeReflection f g F G hF, hquarter]
+
+private def PeriodFamily.Boundary.EllipticCapProduct.capSectionFibre (j : Elliptic.Kind) (s : ℝ) :
+    C(PeriodTorusHigherHomology.ProductTorus 3, RealTorus₄)
+    where
+  toFun
+    y :=
+    (Elliptic.HigherHomology.splitFlatTorusHomeomorph j).symm
+      (((s / j.order : ℝ) : MappingTorus.Circle), y)
+  continuous_toFun :=
+    (Elliptic.HigherHomology.splitFlatTorusHomeomorph j).symm.continuous.comp
+      (continuous_const.prodMk continuous_id)
+
+@[simp]
+private theorem
+    PeriodFamily.Boundary.EllipticCapProduct.capSectionFibre_apply (j : Elliptic.Kind) (s : ℝ)
+    (y : PeriodTorusHigherHomology.ProductTorus 3) :
+    capSectionFibre j s y =
+      (Elliptic.HigherHomology.splitFlatTorusHomeomorph j).symm
+        (((s / j.order : ℝ) : MappingTorus.Circle), y) :=
+  rfl
+
+private def PeriodFamily.Boundary.EllipticCapProduct.capSectionFibreHomotopy (j : Elliptic.Kind)
+    (s t : ℝ) : (capSectionFibre j s).Homotopy (capSectionFibre j t)
+    where
+  toFun
+    p :=
+    (Elliptic.HigherHomology.splitFlatTorusHomeomorph j).symm
+      (((((1 - (p.1 : ℝ)) * s + (p.1 : ℝ) * t) / j.order : ℝ) : MappingTorus.Circle), p.2)
+  continuous_toFun :=
+    (Elliptic.HigherHomology.splitFlatTorusHomeomorph j).symm.continuous.comp
+      (((AddCircle.continuous_mk' (1 : ℝ)).comp (by fun_prop)).prodMk continuous_snd)
+  map_zero_left y := by simp [capSectionFibre]
+  map_one_left y := by simp [capSectionFibre]
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapProduct.capSectionFibre_homology (j : Elliptic.Kind)
+    (s t : ℝ) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (capSectionFibre j s) n =
+      SingularMayerVietoris.singularHomologyMap (capSectionFibre j t) n :=
+  PeriodTorusHigherHomology.homotopy_homologyMap (capSectionFibreHomotopy j s t) n
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.capSectionFibre_zero_coordinateProjection
+    (j : Elliptic.Kind) (k : Elliptic.HigherHomology.FibreCoordinates) :
+    capSectionFibre j 0 (PeriodTorusHigherHomology.coordinateProjection 3 k) =
+      standardLattice.mkQ (Fin.cons 0 k) := by
+  rw [capSectionFibre_apply, zero_div]
+  rw [Elliptic.HigherHomology.splitFlatTorusHomeomorph_symm_coordinateProjection]
+  simp only [Elliptic.HigherHomology.splitRealCoordinates_symm_apply, zero_smul, zero_add]
+
+private def PeriodFamily.Boundary.EllipticCapProduct.capSectionFromModel (j : Elliptic.Kind) :
+    C(Elliptic.HigherHomology.mappingTorusModel j,
+      ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary j) :=
+  (capSection j).comp
+    ((Elliptic.HigherHomology.surfaceMappingTorusHomeomorph j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).symm :
+      C(_, _))
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.capSectionFromModel_mk (j : Elliptic.Kind)
+    (s : ℝ) (y : PeriodTorusHigherHomology.ProductTorus 3) :
+    capSectionFromModel j
+        (MappingTorus.mk (Elliptic.HigherHomology.fibreTorusHomeomorph j).symm (s, y)) =
+      MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (-s, capSectionFibre j s y) := by
+  apply (boundaryProductHomeomorph j).injective
+  change
+    boundaryProductHomeomorph j
+        ((boundaryProductHomeomorph j).symm
+          ((Elliptic.HigherHomology.surfaceMappingTorusHomeomorph j
+                  (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).symm
+              (MappingTorus.mk (Elliptic.HigherHomology.fibreTorusHomeomorph j).symm (s, y)),
+            0)) =
+      _
+  rw [Homeomorph.apply_symm_apply, boundaryProductHomeomorph_mk,
+    ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryToCentral_mk,
+    Elliptic.HigherHomology.surfaceMappingTorusHomeomorph_symm_mk]
+  apply Prod.ext
+  · apply
+      congrArg
+        (Elliptic.surfaceProjection j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+          (Elliptic.mainTwist_admissible j))
+    rw [← splitPeriodTorusHomeomorph_symm_splitFlat j]
+    simp only [capSectionFibre_apply, Homeomorph.apply_symm_apply]
+  · simp only [capSectionFibre_apply, Homeomorph.apply_symm_apply]
+    change
+      (0 : MappingTorus.Circle) =
+        ((s / j.order : ℝ) : MappingTorus.Circle) + ((-s / j.order : ℝ) : MappingTorus.Circle)
+    rw [← AddCircle.coe_add, ← add_div, add_neg_cancel, zero_div, AddCircle.coe_zero]
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapProduct.affine_symm_capSectionFibre (j : Elliptic.Kind)
+    (s : ℝ) (y : PeriodTorusHigherHomology.ProductTorus 3) :
+    (Elliptic.flatTorusAffine j j.twist).symm (capSectionFibre j s y) =
+      capSectionFibre j (s - 1) ((Elliptic.HigherHomology.fibreTorusHomeomorph j).symm y) := by
+  apply (Elliptic.flatTorusAffine j j.twist).injective
+  rw [Homeomorph.apply_symm_apply]
+  simp only [capSectionFibre_apply,
+    Elliptic.HigherHomology.flatTorusAffine_splitFlatTorusHomeomorph_symm,
+    Homeomorph.apply_symm_apply]
+  apply congrArg (Elliptic.HigherHomology.splitFlatTorusHomeomorph j).symm
+  apply Prod.ext
+  · change
+      ((s / j.order : ℝ) : MappingTorus.Circle) =
+        (((s - 1) / j.order : ℝ) : MappingTorus.Circle) +
+          ((1 / j.order : ℝ) : MappingTorus.Circle)
+    rw [← AddCircle.coe_add]
+    congr 1
+    ring
+  · rfl
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapProduct.surfaceWangBoundary_fixed (j : Elliptic.Kind)
+    (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology (Elliptic.HigherHomology.mappingTorusModel j)
+        (n + 1)) :
+    SingularMayerVietoris.singularHomologyMap
+        ((Elliptic.HigherHomology.fibreTorusHomeomorph j).symm : C(_, _)) n
+        (MappingTorusHomology.wangBoundary (Elliptic.HigherHomology.fibreTorusHomeomorph j).symm n
+          a) =
+      MappingTorusHomology.wangBoundary (Elliptic.HigherHomology.fibreTorusHomeomorph j).symm n
+        a := by
+  have h :
+    MappingTorusHomology.wangBoundary (Elliptic.HigherHomology.fibreTorusHomeomorph j).symm n a ∈
+      LinearMap.range
+        (MappingTorusHomology.wangBoundary (Elliptic.HigherHomology.fibreTorusHomeomorph j).symm
+          n) :=
+    ⟨a, rfl⟩
+  rw [MappingTorusHomology.wangBoundary_range] at h
+  change
+    MappingTorusHomology.wangBoundary (Elliptic.HigherHomology.fibreTorusHomeomorph j).symm n a -
+        SingularMayerVietoris.singularHomologyMap
+          ((Elliptic.HigherHomology.fibreTorusHomeomorph j).symm : C(_, _)) n
+          (MappingTorusHomology.wangBoundary (Elliptic.HigherHomology.fibreTorusHomeomorph j).symm
+            n a) =
+      0 at h
+  exact (sub_eq_zero.mp h).symm
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.affine_symm_capSectionFibre_wang
+    (j : Elliptic.Kind) (s : ℝ) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology (Elliptic.HigherHomology.mappingTorusModel j)
+        (n + 1)) :
+    SingularMayerVietoris.singularHomologyMap
+        (((Elliptic.flatTorusAffine j j.twist).symm : C(RealTorus₄, RealTorus₄)).comp
+          (capSectionFibre j s))
+        n
+        (MappingTorusHomology.wangBoundary (Elliptic.HigherHomology.fibreTorusHomeomorph j).symm n
+          a) =
+      SingularMayerVietoris.singularHomologyMap (capSectionFibre j 0) n
+        (MappingTorusHomology.wangBoundary (Elliptic.HigherHomology.fibreTorusHomeomorph j).symm n
+          a) := by
+  have hmap :
+    ((Elliptic.flatTorusAffine j j.twist).symm : C(RealTorus₄, RealTorus₄)).comp
+        (capSectionFibre j s) =
+      (capSectionFibre j (s - 1)).comp
+        ((Elliptic.HigherHomology.fibreTorusHomeomorph j).symm :
+          C(PeriodTorusHigherHomology.ProductTorus 3,
+            PeriodTorusHigherHomology.ProductTorus 3)) := by
+    ext y
+    exact affine_symm_capSectionFibre j s y
+  rw [hmap, PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply,
+    surfaceWangBoundary_fixed, capSectionFibre_homology j (s - 1) 0]
+
+private def
+    PeriodFamily.Boundary.EllipticCapProduct.sectionFibreMatrix : Matrix (Fin 4) (Fin 3) ℤ :=
+  PeriodTorusHigherHomology.omitHeadMatrix (1 : Elliptic.HigherHomology.FibreMatrix)
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.sectionFibreMatrix_basis (i : Fin 3) :
+    sectionFibreMatrix *ᵥ Pi.single i 1 = Pi.single i.succ 1 := by fin_cases i <;> decide
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.capSectionFibre_zero_flatCoordinates
+    (j : Elliptic.Kind) :
+    (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+            C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4)).comp
+        (capSectionFibre j 0) =
+      PeriodTorusHigherHomology.torusMatrixMap sectionFibreMatrix := by
+  apply ContinuousMap.ext
+  intro y
+  obtain ⟨k, rfl⟩ := PeriodTorusHigherHomology.coordinateProjection_surjective 3 y
+  change
+    PeriodTorusHigherHomology.flatTorusCircleHomeomorph
+        (capSectionFibre j 0 (PeriodTorusHigherHomology.coordinateProjection 3 k)) =
+      _
+  rw [capSectionFibre_zero_coordinateProjection,
+    PeriodTorusHigherHomology.flatTorusCircleHomeomorph_mkQ]
+  rw [sectionFibreMatrix, PeriodTorusHigherHomology.torusMatrixMap_omitHeadMatrix,
+    PeriodTorusHigherHomology.torusMatrixMap_one]
+  funext i
+  refine Fin.cases ?_ (fun k => ?_) i
+  · change ((0 : ℝ) : MappingTorus.Circle) = 0
+    simp only [AddCircle.coe_zero]
+  · rfl
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapProduct.sectionFibreMatrix_loopHomology (i : Fin 3) :
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.torusMatrixMap sectionFibreMatrix) 1
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 3 (Pi.single i 1))) =
+      FirstHurewicz.loopHomologyClass
+        (PeriodTorusHigherHomology.coordinatePeriodLoop 4 (Pi.single i.succ 1)) := by
+  rw [SingularMayerVietoris.singularHomologyMap_one,
+    PeriodTorusHigherHomology.torusMatrixMap_coordinatePeriodHomology, sectionFibreMatrix_basis]
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.sectionFibreMatrix_topClass :
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.torusMatrixMap sectionFibreMatrix) 3
+        (Elliptic.HigherHomology.torusH3Coordinates.symm 1) =
+      PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv.symm
+        (PeriodTorusHigherHomologyExterior.cubeBasis 3) := by
+  rw [Elliptic.HigherHomology.torusH3Coordinates_symm_one,
+    PeriodTorusHigherHomologyPontryagin.tripleProduct_natural _
+      (PeriodTorusHigherHomology.torusMatrixMap_add sectionFibreMatrix),
+    sectionFibreMatrix_loopHomology, sectionFibreMatrix_loopHomology,
+    sectionFibreMatrix_loopHomology, PeriodTorusHigherHomologyExterior.cubeBasis_apply,
+    PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv_symm_ιMulti]
+  have hi : LocalSystemMatrices.tripleIndices 3 = Fin.succ := by decide
+  rw [hi]
+  simp only [Function.comp_apply, PeriodTorusHigherHomologyExterior.latticeBasis,
+    Pi.basisFun_apply]
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapProduct.capSectionFibre_zero_h3_one (j : Elliptic.Kind) :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (SingularMayerVietoris.singularHomologyMap (capSectionFibre j 0) 3
+          (Elliptic.HigherHomology.torusH3Coordinates.symm 1)) =
+      Pi.single (3 : Fin 4) 1 := by
+  change
+    PeriodTorusHigherHomologyExterior.cubeCoordinates
+        (PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv
+          (SingularMayerVietoris.singularHomologyMap
+            (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+              C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+            3
+            (SingularMayerVietoris.singularHomologyMap (capSectionFibre j 0) 3
+              (Elliptic.HigherHomology.torusH3Coordinates.symm 1)))) =
+      _
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    capSectionFibre_zero_flatCoordinates, sectionFibreMatrix_topClass,
+    LinearEquiv.apply_symm_apply]
+  change
+    PeriodTorusHigherHomologyExterior.cubeBasis.equivFun
+        (PeriodTorusHigherHomologyExterior.cubeBasis 3) =
+      _
+  ext i
+  simp [Pi.single_apply, eq_comm]
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.capSectionFibre_zero_h3 (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3) :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (SingularMayerVietoris.singularHomologyMap (capSectionFibre j 0) 3 a) =
+      Pi.single (3 : Fin 4) (Elliptic.HigherHomology.torusH3Coordinates a) := by
+  have ha :
+    a =
+      Elliptic.HigherHomology.torusH3Coordinates a •
+        Elliptic.HigherHomology.torusH3Coordinates.symm 1 := by
+    apply Elliptic.HigherHomology.torusH3Coordinates.injective
+    simp
+  calc
+    _ =
+        PeriodFamily.FlatTorus.singularH3Coordinates
+          (SingularMayerVietoris.singularHomologyMap (capSectionFibre j 0) 3
+            (Elliptic.HigherHomology.torusH3Coordinates a •
+              Elliptic.HigherHomology.torusH3Coordinates.symm 1)) :=
+      congrArg
+        (fun b =>
+          PeriodFamily.FlatTorus.singularH3Coordinates
+            (SingularMayerVietoris.singularHomologyMap (capSectionFibre j 0) 3 b))
+        ha
+    _ = Elliptic.HigherHomology.torusH3Coordinates a • Pi.single (3 : Fin 4) 1 := by
+      rw [map_zsmul, map_zsmul, capSectionFibre_zero_h3_one]
+    _ = _ := by
+      ext i
+      by_cases hi : i = 3
+      · subst i
+        simp
+      · simp [hi]
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapProduct.capSectionFromModel_wang (j : Elliptic.Kind)
+    (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology (Elliptic.HigherHomology.mappingTorusModel j)
+        (n + 1)) :
+    MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) n
+        (SingularMayerVietoris.singularHomologyMap (capSectionFromModel j) (n + 1) a) =
+      -SingularMayerVietoris.singularHomologyMap (capSectionFibre j 0) n
+          (MappingTorusHomology.wangBoundary (Elliptic.HigherHomology.fibreTorusHomeomorph j).symm
+            n a) :=
+  wangBoundary_timeReflection_of_quarter (Elliptic.HigherHomology.fibreTorusHomeomorph j).symm
+    (Elliptic.flatTorusAffine j j.twist) (capSectionFromModel j) (capSectionFibre j)
+    (capSectionFromModel_mk j) (capSectionFibre j 0) n a
+    (affine_symm_capSectionFibre_wang j (3 / 4) n a)
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.capSection_wang (j : Elliptic.Kind) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface j) (n + 1)) :
+    MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) n
+        (SingularMayerVietoris.singularHomologyMap (capSection j) (n + 1) a) =
+      -SingularMayerVietoris.singularHomologyMap (capSectionFibre j 0) n
+          (MappingTorusHomology.wangBoundary (Elliptic.HigherHomology.fibreTorusHomeomorph j).symm
+            n
+            (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+              (Elliptic.HigherHomology.surfaceMappingTorusHomeomorph j
+                (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod)
+              (n + 1) a)) := by
+  have hcomp :
+    (capSectionFromModel j).comp
+        (Elliptic.HigherHomology.surfaceMappingTorusHomeomorph j
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod :
+          C(_, _)) =
+      capSection j := by
+    ext x
+    change
+      capSection j
+          ((Elliptic.HigherHomology.surfaceMappingTorusHomeomorph j
+                (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).symm
+            (Elliptic.HigherHomology.surfaceMappingTorusHomeomorph j
+              (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod x)) =
+        _
+    rw [Homeomorph.symm_apply_apply]
+  rw [← hcomp, PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply,
+    capSectionFromModel_wang]
+  rfl
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.capSection_wang_h4_coordinates
+    (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface j) 4) :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) 3
+          (SingularMayerVietoris.singularHomologyMap (capSection j) 4 a)) =
+      -Pi.single (3 : Fin 4)
+          (Elliptic.HigherHomology.surfaceH4Equiv j
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a) := by
+  rw [capSection_wang, map_neg, capSectionFibre_zero_h3]
+  congr 2
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapProduct.capSection_wang_h4_unit (j : Elliptic.Kind) :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) 3
+          (SingularMayerVietoris.singularHomologyMap (capSection j) 4
+            ((Elliptic.HigherHomology.surfaceH4Equiv j
+                  (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).symm
+              1))) =
+      -Pi.single (3 : Fin 4) 1 := by
+  rw [capSection_wang_h4_coordinates, LinearEquiv.apply_symm_apply]
+
+private def PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology
+      (ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary j) 4 :=
+  SingularMayerVietoris.singularHomologyMap (capSection j) 4
+    ((Elliptic.HigherHomology.surfaceH4Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).symm
+      1)
+
+private theorem PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass_coordinates
+    (j : Elliptic.Kind) : boundaryCapH4Equiv j (unitCapSectionClass j) = (1, 0) := by
+  rw [unitCapSectionClass, boundaryCapH4Equiv_section, LinearEquiv.apply_symm_apply]
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass_filling (j : Elliptic.Kind) :
+    Elliptic.HigherHomology.surfaceH4Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+        (ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j 4
+          (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) 4
+            (unitCapSectionClass j))) =
+      1 := by rw [boundaryFillingHomologyMap_H4_first, unitCapSectionClass_coordinates]
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass_wang (j : Elliptic.Kind) :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) 3
+          (unitCapSectionClass j)) =
+      -Pi.single (3 : Fin 4) 1 :=
+  capSection_wang_h4_unit j
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover (j : Elliptic.Kind) :
+    C(RealTorus₄, (ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) :=
+  (ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryToCentral j).comp
+    (MappingTorus.HomologyCover.fibreInclusion (Elliptic.flatTorusAffine j j.twist))
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover_apply (j : Elliptic.Kind)
+    (x : RealTorus₄) :
+    surfaceCover j x =
+      Elliptic.surfaceProjection j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+        (Elliptic.mainTwist_admissible j)
+        (Elliptic.flatTorusPeriodHomeomorph
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod.val x) :=
+  ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryToCentral_mk j 0 x
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.twistCircleCharacter (j : Elliptic.Kind) :
+    C(RealTorus₄, MappingTorus.Circle)
+    where
+  toFun x := (Elliptic.HigherHomology.splitFlatTorusHomeomorph j x).1
+  continuous_toFun :=
+    continuous_fst.comp (Elliptic.HigherHomology.splitFlatTorusHomeomorph j).continuous
+
+@[simp]
+private theorem
+    PeriodFamily.Boundary.EllipticCapKernelWang.twistCircleCharacter_apply (j : Elliptic.Kind)
+    (x : RealTorus₄) :
+    twistCircleCharacter j x = (Elliptic.HigherHomology.splitFlatTorusHomeomorph j x).1 :=
+  rfl
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.nativeShear (j : Elliptic.Kind) :
+    C(MappingTorus.Circle × RealTorus₄, MappingTorus.Circle × RealTorus₄)
+    where
+  toFun p := (p.1 - twistCircleCharacter j p.2, p.2)
+  continuous_toFun :=
+    (continuous_fst.sub ((twistCircleCharacter j).continuous.comp continuous_snd)).prodMk
+      continuous_snd
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.nativeProductCover (j : Elliptic.Kind) :
+    C(MappingTorus.Circle × RealTorus₄,
+      (ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary) j) :=
+  MappingTorusHomology.Covering.productCover j.order (Elliptic.flatTorusAffine j j.twist).symm
+    (ThreefoldOverlapMappingTorus.Elliptic.affine_symm_pow_order j j.twist j.matrix_fixes_twist)
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.nativeProductCover_real_apply
+    (j : Elliptic.Kind) (t : ℝ) (x : RealTorus₄) :
+    nativeProductCover j ((t : MappingTorus.Circle), x) =
+      MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (t * j.order, x) :=
+  MappingTorusHomology.Covering.productCover_real_apply j.order
+    (Elliptic.flatTorusAffine j j.twist).symm
+    (ThreefoldOverlapMappingTorus.Elliptic.affine_symm_pow_order j j.twist j.matrix_fixes_twist) t
+    x
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.boundaryCircleFirstHomeomorph_mk
+    (j : Elliptic.Kind) (t : ℝ) (x : RealTorus₄) :
+    PeriodFamily.Boundary.EllipticCapProduct.boundaryCircleFirstHomeomorph j
+        (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (t, x)) =
+      (twistCircleCharacter j x + ((t / j.order : ℝ) : MappingTorus.Circle), surfaceCover j x) := by
+  change
+    Prod.swap
+        (PeriodFamily.Boundary.EllipticCapProduct.boundaryProductHomeomorph j
+          (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (t, x))) =
+      _
+  rw [PeriodFamily.Boundary.EllipticCapProduct.boundaryProductHomeomorph_mk]
+  apply Prod.ext
+  · rfl
+  · exact ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryToCentral_angle j t 0 x
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.nativeProductCover_shear_apply
+    (j : Elliptic.Kind) (c : MappingTorus.Circle) (x : RealTorus₄) :
+    nativeProductCover j (nativeShear j (c, x)) =
+      (PeriodFamily.Boundary.EllipticCapProduct.boundaryCircleFirstHomeomorph j).symm
+        (c, surfaceCover j x) := by
+  obtain ⟨t, ht⟩ := QuotientAddGroup.mk_surjective (c - twistCircleCharacter j x)
+  apply (PeriodFamily.Boundary.EllipticCapProduct.boundaryCircleFirstHomeomorph j).injective
+  rw [Homeomorph.apply_symm_apply]
+  change
+    PeriodFamily.Boundary.EllipticCapProduct.boundaryCircleFirstHomeomorph j
+        (nativeProductCover j (c - twistCircleCharacter j x, x)) =
+      _
+  rw [← ht, nativeProductCover_real_apply, boundaryCircleFirstHomeomorph_mk]
+  have hm : (j.order : ℝ) ≠ 0 := by exact_mod_cast j.order_pos.ne'
+  rw [mul_div_cancel_right₀ _ hm, ht]
+  exact Prod.ext (add_sub_cancel _ _) rfl
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.nativeProductCover_comp_shear
+    (j : Elliptic.Kind) :
+    (nativeProductCover j).comp (nativeShear j) =
+      ((PeriodFamily.Boundary.EllipticCapProduct.boundaryCircleFirstHomeomorph j).symm :
+            C(_, _)).comp
+        (PeriodTorusHigherHomology.circleProductMap (surfaceCover j)) := by
+  apply ContinuousMap.ext
+  rintro ⟨c, x⟩
+  exact nativeProductCover_shear_apply j c x
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.crossWang (j : Elliptic.Kind) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) n →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology RealTorus₄ n :=
+  (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) n).comp
+    (PeriodFamily.Boundary.EllipticCapProduct.boundaryPositiveCircleCross j n)
+
+@[simp]
+private theorem
+    PeriodFamily.Boundary.EllipticCapKernelWang.crossWang_apply (j : Elliptic.Kind) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) n) :
+    crossWang j n a =
+      MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) n
+        (PeriodFamily.Boundary.EllipticCapProduct.boundaryPositiveCircleCross j n a) :=
+  rfl
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.crossWang_surfaceCover_of_shear
+    (j : Elliptic.Kind) (n : ℕ) (a : SingularMayerVietoris.SingularHomology RealTorus₄ n)
+    (ha :
+      SingularMayerVietoris.singularHomologyMap (nativeShear j) (n + 1)
+          (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ n a) =
+        PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ n a) :
+    crossWang j n (SingularMayerVietoris.singularHomologyMap (surfaceCover j) n a) =
+      MappingTorusHomology.Covering.homologyNorm j.order (Elliptic.flatTorusAffine j j.twist).symm
+        n a := by
+  rw [crossWang_apply, PeriodFamily.Boundary.EllipticCapProduct.boundaryPositiveCircleCross_apply,
+    ← PeriodTorusHigherHomology.positiveCircleCross_naturality]
+  have hmap :=
+    congrArg
+      (fun f :
+          C(MappingTorus.Circle × RealTorus₄,
+            (ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary) j) =>
+        SingularMayerVietoris.singularHomologyMap f (n + 1))
+      (nativeProductCover_comp_shear j)
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodTorusHigherHomology.singularHomologyMap_comp] at hmap
+  have hc :=
+    LinearMap.congr_fun hmap (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ n a)
+  simp only [LinearMap.comp_apply, ha] at hc
+  rw [← hc]
+  exact
+    MappingTorusHomology.Covering.wangBoundary_productCover_positiveCircleCross j.order
+      (Elliptic.flatTorusAffine j j.twist).symm
+      (ThreefoldOverlapMappingTorus.Elliptic.affine_symm_pow_order j j.twist j.matrix_fixes_twist)
+      n a
+
+private def
+    PeriodFamily.Boundary.EllipticCapKernelWang.originalAffineNorm (j : Elliptic.Kind) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology RealTorus₄ n →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology RealTorus₄ n :=
+  MappingTorusHomology.Covering.homologyNorm j.order (Elliptic.flatTorusAffine j j.twist).symm n
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapKernelWang.originalAffine_pow_order (j : Elliptic.Kind) :
+    Elliptic.flatTorusAffine j j.twist ^ j.order = 1 :=
+  ThreefoldOverlapMappingTorus.Elliptic.affine_pow_order j j.twist j.matrix_fixes_twist
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalAffineNorm_eq_positive
+    (j : Elliptic.Kind) (n : ℕ) :
+    originalAffineNorm j n =
+      MappingTorusHomology.Covering.homologyNorm j.order (Elliptic.flatTorusAffine j j.twist) n :=
+  MappingTorusHomology.Covering.homologyNorm_symm j.order (Elliptic.flatTorusAffine j j.twist) n
+    (originalAffine_pow_order j)
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalAffineNorm_sum_powers
+    (j : Elliptic.Kind) (n : ℕ) :
+    originalAffineNorm j n =
+      ∑ k ∈ Finset.range j.order,
+        (MappingTorusHomology.monodromyHomologyMap (Elliptic.flatTorusAffine j j.twist) n) ^ k := by
+  rw [originalAffineNorm_eq_positive, MappingTorusHomology.Covering.homologyNorm_eq_sum_powers]
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.originalNormMatrixOne (j : Elliptic.Kind) :
+    LatticeMatrix :=
+  ∑ k ∈ Finset.range j.order, j.matrix ^ k
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.originalNormMatrixTwo (j : Elliptic.Kind) :
+    Matrix (Fin 6) (Fin 6) ℤ :=
+  ∑ k ∈ Finset.range j.order, (LocalSystemMatrices.exteriorSquare j.matrix) ^ k
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalAffine_h1_coordinates
+    (j : Elliptic.Kind) (a : SingularMayerVietoris.SingularHomology RealTorus₄ 1) :
+    PeriodFamily.FlatTorus.singularH1Equiv
+        (MappingTorusHomology.monodromyHomologyMap (Elliptic.flatTorusAffine j j.twist) 1 a) =
+      j.matrix *ᵥ PeriodFamily.FlatTorus.singularH1Equiv a := by
+  rw [MappingTorusHomology.monodromyHomologyMap,
+    PeriodFamily.Boundary.flatTorusAffine_homology_triangle]
+  change
+    PeriodFamily.FlatTorus.singularH1Equiv
+        (FirstHurewicz.inducedHomology
+          (SpecialPeriods.triangleTorusHomeomorph (SpecialPeriods.Triangle.ellipticGenerator j) :
+            C(RealTorus₄, RealTorus₄))
+          a) =
+      _
+  rw [PeriodFamily.FlatTorus.singularH1Equiv_inducedHomology_triangle,
+    SpecialPeriods.EllipticFilling.ellipticGenerator_dual_matrix]
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalAffine_h2_coordinates
+    (j : Elliptic.Kind) (a : SingularMayerVietoris.SingularHomology RealTorus₄ 2) :
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        (MappingTorusHomology.monodromyHomologyMap (Elliptic.flatTorusAffine j j.twist) 2 a) =
+      LocalSystemMatrices.exteriorSquare j.matrix *ᵥ
+        PeriodFamily.FlatTorus.singularH2Coordinates a := by
+  rw [MappingTorusHomology.monodromyHomologyMap,
+    PeriodFamily.Boundary.flatTorusAffine_homology_triangle]
+  change
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        (SingularMayerVietoris.singularHomologyMap
+          (SpecialPeriods.triangleTorusHomeomorph (SpecialPeriods.Triangle.ellipticGenerator j) :
+            C(RealTorus₄, RealTorus₄))
+          2 a) =
+      _
+  rw [PeriodFamily.FlatTorus.singularH2Coordinates_inducedHomology_triangle,
+    SpecialPeriods.EllipticFilling.ellipticGenerator_dual_matrix]
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.marked_endomorphism_pow_mo1973_27421
+    {M : Type*} [AddCommGroup M] [Module ℤ M] {r : ℕ} (e : M ≃ₗ[ℤ] (Fin r → ℤ))
+    (f : Module.End ℤ M) (A : Matrix (Fin r) (Fin r) ℤ) (hf : ∀ a, e (f a) = A *ᵥ e a) (k : ℕ)
+    (a : M) : e ((f ^ k) a) = A ^ k *ᵥ e a := by
+  induction k with
+  | zero => simp only [pow_zero, Module.End.one_apply, Matrix.one_mulVec]
+  | succ k ih => rw [pow_succ', Module.End.mul_apply, hf, ih, Matrix.mulVec_mulVec, ← pow_succ']
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalAffine_pow_h1_coordinates
+    (j : Elliptic.Kind) (k : ℕ) (a : SingularMayerVietoris.SingularHomology RealTorus₄ 1) :
+    PeriodFamily.FlatTorus.singularH1Equiv
+        ((MappingTorusHomology.monodromyHomologyMap (Elliptic.flatTorusAffine j j.twist) 1 ^ k)
+          a) =
+      j.matrix ^ k *ᵥ PeriodFamily.FlatTorus.singularH1Equiv a :=
+  marked_endomorphism_pow_mo1973_27421 PeriodFamily.FlatTorus.singularH1Equiv
+    (MappingTorusHomology.monodromyHomologyMap (Elliptic.flatTorusAffine j j.twist) 1) j.matrix
+    (originalAffine_h1_coordinates j) k a
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalAffine_pow_h2_coordinates
+    (j : Elliptic.Kind) (k : ℕ) (a : SingularMayerVietoris.SingularHomology RealTorus₄ 2) :
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        ((MappingTorusHomology.monodromyHomologyMap (Elliptic.flatTorusAffine j j.twist) 2 ^ k)
+          a) =
+      (LocalSystemMatrices.exteriorSquare j.matrix) ^ k *ᵥ
+        PeriodFamily.FlatTorus.singularH2Coordinates a :=
+  marked_endomorphism_pow_mo1973_27421 PeriodFamily.FlatTorus.singularH2Coordinates
+    (MappingTorusHomology.monodromyHomologyMap (Elliptic.flatTorusAffine j j.twist) 2)
+    (LocalSystemMatrices.exteriorSquare j.matrix) (originalAffine_h2_coordinates j) k a
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalAffineNorm_h1_coordinates
+    (j : Elliptic.Kind) (a : SingularMayerVietoris.SingularHomology RealTorus₄ 1) :
+    PeriodFamily.FlatTorus.singularH1Equiv (originalAffineNorm j 1 a) =
+      originalNormMatrixOne j *ᵥ PeriodFamily.FlatTorus.singularH1Equiv a := by
+  rw [originalAffineNorm_sum_powers, LinearMap.sum_apply, map_sum]
+  simp only [originalAffine_pow_h1_coordinates]
+  exact (Matrix.sum_mulVec _ _ _).symm
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalAffineNorm_h2_coordinates
+    (j : Elliptic.Kind) (a : SingularMayerVietoris.SingularHomology RealTorus₄ 2) :
+    PeriodFamily.FlatTorus.singularH2Coordinates (originalAffineNorm j 2 a) =
+      originalNormMatrixTwo j *ᵥ PeriodFamily.FlatTorus.singularH2Coordinates a := by
+  rw [originalAffineNorm_sum_powers, LinearMap.sum_apply, map_sum]
+  simp only [originalAffine_pow_h2_coordinates]
+  exact (Matrix.sum_mulVec _ _ _).symm
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalNormMatrixOne_three :
+    originalNormMatrixOne .three = !![3, 0, 0, 0; 6, 0, 0, 0; -12, 0, 0, 0; 0, 2, 1, 3] := by
+  decide
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalNormMatrixOne_four :
+    originalNormMatrixOne .four = !![4, 0, 0, 0; 12, 0, 0, 0; -12, 0, 0, 0; 0, 2, 2, 4] := by
+  decide
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalNormMatrixTwo_three :
+    originalNormMatrixTwo .three =
+      !![0, 0, 0, 0, 0, 0;
+        0, 0, 0, 0, 0, 0;
+        2, 1, 3, 0, 0, 0;
+        -12, -6, 0, 3, 0, 0;
+        8, 4, 6, -1, 0, 0;
+        -16, -8, -12, 2, 0, 0] := by
+  change (∑ k ∈ Finset.range 3, PeriodTorusHigherHomologyExterior.squareA₁ ^ k) = _
+  rw [PeriodTorusHigherHomologyExterior.squareA₁_eq]
+  decide
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalNormMatrixTwo_four :
+    originalNormMatrixTwo .four =
+      !![0, 0, 0, 0, 0, 0;
+        0, 0, 0, 0, 0, 0;
+        2, 2, 4, 0, 0, 0;
+        -12, -12, 0, 4, 0, 0;
+        12, 12, 12, -2, 0, 0;
+        -12, -12, -12, 2, 0, 0] := by
+  change (∑ k ∈ Finset.range 4, PeriodTorusHigherHomologyExterior.squareA₂ ^ k) = _
+  rw [PeriodTorusHigherHomologyExterior.squareA₂_eq]
+  decide
+
+private def PeriodFamily.CapKernelShear.shear
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 4,
+        (PeriodTorusHigherHomology.CircleTopology.Circle))) :
+    C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+        PeriodTorusHigherHomology.ProductTorus 4,
+      (PeriodTorusHigherHomology.CircleTopology.Circle) ×
+        PeriodTorusHigherHomology.ProductTorus 4) :=
+  ⟨fun p => (p.1 - χ p.2, p.2),
+    (continuous_fst.sub (χ.continuous.comp continuous_snd)).prodMk continuous_snd⟩
+
+private def PeriodFamily.CapKernelShear.torusShear
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 4,
+        (PeriodTorusHigherHomology.CircleTopology.Circle))) :
+    C(PeriodTorusHigherHomology.ProductTorus 5, PeriodTorusHigherHomology.ProductTorus 5)
+    where
+  toFun z := Fin.cons (z 0 - χ (fun i => z i.succ)) (fun i => z i.succ)
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    refine Fin.cases ?_ (fun j => ?_) i
+    · exact
+        (continuous_apply 0).sub
+          (χ.continuous.comp (continuous_pi fun j => continuous_apply j.succ))
+    · exact continuous_apply j.succ
+
+@[simp]
+private theorem PeriodFamily.CapKernelShear.torusShear_apply
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 4,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (z : PeriodTorusHigherHomology.ProductTorus 5) :
+    torusShear χ z = Fin.cons (z 0 - χ (fun i => z i.succ)) (fun i => z i.succ) :=
+  rfl
+
+private theorem PeriodFamily.CapKernelShear.torusShear_comp_unsplit
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 4,
+        (PeriodTorusHigherHomology.CircleTopology.Circle))) :
+    (torusShear χ).comp
+        ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 4).symm :
+          C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+              PeriodTorusHigherHomology.ProductTorus 4,
+            PeriodTorusHigherHomology.ProductTorus 5)) =
+      ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 4).symm :
+            C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+                PeriodTorusHigherHomology.ProductTorus 4,
+              PeriodTorusHigherHomology.ProductTorus 5)).comp
+        (shear χ) :=
+  rfl
+
+private theorem PeriodFamily.CapKernelShear.character_zero
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 4,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y) : χ 0 = 0 := by
+  have h : χ 0 + χ 0 = χ 0 + 0 := by simpa only [zero_add, add_zero] using (hχ 0 0).symm
+  exact add_left_cancel h
+
+private theorem PeriodFamily.CapKernelShear.torusShear_add
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 4,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y) (z w : PeriodTorusHigherHomology.ProductTorus 5) :
+    torusShear χ (z + w) = torusShear χ z + torusShear χ w := by
+  funext i
+  refine Fin.cases ?_ (fun j => ?_) i
+  · change
+      z 0 + w 0 - χ ((fun j => z j.succ) + (fun j => w j.succ)) =
+        (z 0 - χ (fun j => z j.succ)) + (w 0 - χ (fun j => w j.succ))
+    rw [hχ]
+    abel
+  · rfl
+
+private theorem PeriodFamily.CapKernelShear.torusShear_comp_head
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 4,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y) :
+    (torusShear χ).comp (PeriodTorusHigherHomology.torusHeadCircleMap 4) =
+      PeriodTorusHigherHomology.torusHeadCircleMap 4 := by
+  apply ContinuousMap.ext
+  intro z
+  change
+    torusShear χ (PeriodTorusHigherHomology.torusHeadCircleMap 4 z) =
+      PeriodTorusHigherHomology.torusHeadCircleMap 4 z
+  rw [PeriodTorusHigherHomology.torusHeadCircleMap_apply, torusShear_apply]
+  change
+    Fin.cons (α := fun _ : Fin 5 => (PeriodTorusHigherHomology.CircleTopology.Circle)) (z - χ 0)
+        0 =
+      Fin.cons z 0
+  rw [character_zero χ hχ, sub_zero]
+
+private theorem PeriodFamily.CapKernelShear.torusShear_comp_tail
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 4,
+        (PeriodTorusHigherHomology.CircleTopology.Circle))) :
+    (torusShear χ).comp (PeriodTorusHigherHomology.torusTailMap 4) =
+      PeriodTorusHigherHomology.torusTailMap 4 -
+        (PeriodTorusHigherHomology.torusHeadCircleMap 4).comp χ := by
+  apply ContinuousMap.ext
+  intro x
+  change
+    torusShear χ (PeriodTorusHigherHomology.torusTailMap 4 x) =
+      PeriodTorusHigherHomology.torusTailMap 4 x -
+        PeriodTorusHigherHomology.torusHeadCircleMap 4 (χ x)
+  simp only [PeriodTorusHigherHomology.torusTailMap_apply, torusShear_apply,
+    PeriodTorusHigherHomology.torusHeadCircleMap_apply]
+  funext i
+  refine Fin.cases ?_ (fun j => ?_) i <;> simp
+
+private theorem PeriodFamily.CapKernelShear.loopHomologyClass_add_zero_mo1973_27446 {G : Type}
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G] (p q : Path (0 : G) 0) :
+    FirstHurewicz.loopHomologyClass (p.add q) =
+      FirstHurewicz.loopHomologyClass p + FirstHurewicz.loopHomologyClass q := by
+  have hp : (p.prod (Path.refl (0 : G))).map continuous_add = p.cast (add_zero 0) (add_zero 0) := by
+    ext t
+    simp only [Path.map_coe, Function.comp_apply, Path.prod_coe, Path.refl_apply, Path.cast_coe,
+      add_zero]
+  have hq : ((Path.refl (0 : G)).prod q).map continuous_add = q.cast (add_zero 0) (add_zero 0) := by
+    ext t
+    simp only [Path.map_coe, Function.comp_apply, Path.prod_coe, Path.refl_apply, Path.cast_coe,
+      zero_add]
+  have h :
+    ((p.prod (Path.refl (0 : G))).trans ((Path.refl (0 : G)).prod q)).Homotopic (p.prod q) := by
+    rw [Path.trans_prod_eq_prod_trans]
+    exact ⟨Path.Homotopic.prodHomotopy (Path.Homotopy.transRefl p) (Path.Homotopy.reflTrans q)⟩
+  have he :=
+    FirstHurewicz.loopHomologyClass_homotopic
+      (h.map (⟨fun x : G × G => x.1 + x.2, continuous_add⟩ : C(G × G, G)))
+  rw [Path.map_trans, FirstHurewicz.loopHomologyClass_trans, hp, hq] at he
+  exact he.symm
+
+private theorem PeriodFamily.CapKernelShear.inducedH1_add_of_zero_mo1973_27447 {X G : Type}
+    [TopologicalSpace X] [PathConnectedSpace X] [TopologicalSpace G] [AddCommGroup G]
+    [IsTopologicalAddGroup G] (f g : C(X, G)) (b : X) (hf : f b = 0) (hg : g b = 0) :
+    FirstHurewicz.inducedHomology (f + g) =
+      FirstHurewicz.inducedHomology f + FirstHurewicz.inducedHomology g := by
+  apply LinearMap.ext
+  intro a
+  obtain ⟨p, rfl⟩ := FirstHurewicz.loopHomologyClass_surjective b a
+  let pf : Path (0 : G) 0 := (p.map f.continuous).cast hf.symm hf.symm
+  let pg : Path (0 : G) 0 := (p.map g.continuous).cast hg.symm hg.symm
+  have h :
+    p.map (f + g).continuous =
+      (pf.add pg).cast (by simp only [ContinuousMap.add_apply, hf, hg])
+        (by simp only [ContinuousMap.add_apply, hf, hg]) := by
+    ext t
+    rfl
+  simp only [LinearMap.add_apply, FirstHurewicz.inducedHomology_loopHomologyClass]
+  rw [h]
+  exact loopHomologyClass_add_zero_mo1973_27446 pf pg
+
+private theorem PeriodFamily.CapKernelShear.inducedH1_sub_of_zero_mo1973_27448 {X G : Type}
+    [TopologicalSpace X] [PathConnectedSpace X] [TopologicalSpace G] [AddCommGroup G]
+    [IsTopologicalAddGroup G] (f g : C(X, G)) (b : X) (hf : f b = 0) (hg : g b = 0) :
+    FirstHurewicz.inducedHomology (f - g) =
+      FirstHurewicz.inducedHomology f - FirstHurewicz.inducedHomology g := by
+  have h :=
+    inducedH1_add_of_zero_mo1973_27447 (f - g) g b
+      (by simp only [ContinuousMap.sub_apply, hf, hg, sub_self]) hg
+  rw [sub_add_cancel] at h
+  exact (eq_sub_iff_add_eq).mpr h.symm
+
+private def PeriodFamily.CapKernelShear.headClass :
+    SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 5) 1 :=
+  FirstHurewicz.loopHomologyClass
+    (PeriodTorusHigherHomology.coordinatePeriodLoop 5 (Pi.single 0 1))
+
+private theorem PeriodFamily.CapKernelShear.headClass_eq_image :
+    headClass =
+      SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusHeadCircleMap 4) 1
+        (FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop) :=
+  (PeriodTorusHigherHomology.torusHeadCircleMap_positiveHomology 4).symm
+
+private theorem PeriodFamily.CapKernelShear.headHomology_eq_degree_smul
+    (a :
+      SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.CircleTopology.Circle)
+        1) :
+    SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusHeadCircleMap 4) 1
+        a =
+      PeriodTorusHigherHomology.circleHomologyOneEquiv a • headClass := by
+  have ha :
+    a =
+      PeriodTorusHigherHomology.circleHomologyOneEquiv a •
+        FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop := by
+    simpa only [LinearEquiv.symm_apply_apply] using
+      PeriodTorusHigherHomology.circleHomologyOneEquiv_symm_int
+        (PeriodTorusHigherHomology.circleHomologyOneEquiv a)
+  calc
+    _ =
+        SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusHeadCircleMap 4)
+          1
+          (PeriodTorusHigherHomology.circleHomologyOneEquiv a •
+            FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop) :=
+      congrArg
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.torusHeadCircleMap 4) 1)
+        ha
+    _ = PeriodTorusHigherHomology.circleHomologyOneEquiv a • headClass := by
+      rw [map_zsmul, PeriodTorusHigherHomology.torusHeadCircleMap_positiveHomology]
+      rfl
+
+private theorem PeriodFamily.CapKernelShear.torusShear_headHomology
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 4,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y)
+    (a :
+      SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.CircleTopology.Circle)
+        1) :
+    SingularMayerVietoris.singularHomologyMap (torusShear χ) 1
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.torusHeadCircleMap 4) 1 a) =
+      SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusHeadCircleMap 4) 1
+        a := by
+  change
+    ((SingularMayerVietoris.singularHomologyMap (torusShear χ) 1).comp
+          (SingularMayerVietoris.singularHomologyMap
+            (PeriodTorusHigherHomology.torusHeadCircleMap 4) 1))
+        a =
+      _
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp, torusShear_comp_head χ hχ]
+
+private theorem PeriodFamily.CapKernelShear.torusShear_headClass
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 4,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y) :
+    SingularMayerVietoris.singularHomologyMap (torusShear χ) 1 headClass = headClass := by
+  simpa only [headClass_eq_image] using
+    torusShear_headHomology χ hχ
+      (FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop)
+
+private theorem PeriodFamily.CapKernelShear.torusShear_tailHomology
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 4,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y)
+    (b : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 1) :
+    SingularMayerVietoris.singularHomologyMap (torusShear χ) 1
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusTailMap 4) 1
+          b) =
+      SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusTailMap 4) 1 b -
+        PeriodTorusHigherHomology.circleHomologyOneEquiv
+            (SingularMayerVietoris.singularHomologyMap χ 1 b) •
+          headClass := by
+  have hzero :
+    ((PeriodTorusHigherHomology.torusHeadCircleMap 4).comp χ)
+        (0 : PeriodTorusHigherHomology.ProductTorus 4) =
+      0 := by
+    change PeriodTorusHigherHomology.torusHeadCircleMap 4 (χ 0) = 0
+    rw [character_zero χ hχ]
+    exact PeriodTorusHigherHomology.coordinateCircleMap_zero (Pi.single (0 : Fin 5) 1)
+  have hsub :
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.torusTailMap 4 -
+          (PeriodTorusHigherHomology.torusHeadCircleMap 4).comp χ)
+        1 =
+      SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusTailMap 4) 1 -
+        SingularMayerVietoris.singularHomologyMap
+          ((PeriodTorusHigherHomology.torusHeadCircleMap 4).comp χ) 1 := by
+    simpa only [SingularMayerVietoris.singularHomologyMap_one] using
+      inducedH1_sub_of_zero_mo1973_27448 (PeriodTorusHigherHomology.torusTailMap 4)
+        ((PeriodTorusHigherHomology.torusHeadCircleMap 4).comp χ)
+        (0 : PeriodTorusHigherHomology.ProductTorus 4)
+        (PeriodTorusHigherHomology.torusTailMap_zero 4) hzero
+  calc
+    _ =
+        SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.torusTailMap 4 -
+            (PeriodTorusHigherHomology.torusHeadCircleMap 4).comp χ)
+          1 b := by
+      rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+        torusShear_comp_tail]
+    _ =
+        SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusTailMap 4) 1 b -
+          SingularMayerVietoris.singularHomologyMap
+            ((PeriodTorusHigherHomology.torusHeadCircleMap 4).comp χ) 1 b := by
+      rw [hsub, LinearMap.sub_apply]
+    _ =
+        SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusTailMap 4) 1 b -
+          PeriodTorusHigherHomology.circleHomologyOneEquiv
+              (SingularMayerVietoris.singularHomologyMap χ 1 b) •
+            headClass := by
+      rw [PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply,
+        headHomology_eq_degree_smul]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.CapKernelShear.product11_sub_head (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)]
+    (a b : SingularMayerVietoris.SingularHomology G 1) (k : ℤ) :
+    PeriodTorusHigherHomologyPontryagin.product11 G a (b - k • a) =
+      PeriodTorusHigherHomologyPontryagin.product11 G a b := by
+  rw [map_sub, map_zsmul, PeriodTorusHigherHomologyPontryagin.product11_self, zsmul_zero,
+    sub_zero]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.CapKernelShear.tripleProduct_sub_head (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)]
+    (a b c : SingularMayerVietoris.SingularHomology G 1) (k l : ℤ) :
+    PeriodTorusHigherHomologyPontryagin.tripleProduct G a (b - k • a) (c - l • a) =
+      PeriodTorusHigherHomologyPontryagin.tripleProduct G a b c := by
+  calc
+    PeriodTorusHigherHomologyPontryagin.tripleProduct G a (b - k • a) (c - l • a) =
+        PeriodTorusHigherHomologyPontryagin.tripleProduct G a b (c - l • a) -
+          k • PeriodTorusHigherHomologyPontryagin.tripleProduct G a a (c - l • a) := by
+      rw [(PeriodTorusHigherHomologyPontryagin.tripleProduct G a).map_sub, LinearMap.sub_apply]
+      exact
+        congrArg
+          (fun t => PeriodTorusHigherHomologyPontryagin.tripleProduct G a b (c - l • a) - t)
+          (congrArg
+            (fun f :
+                SingularMayerVietoris.SingularHomology G 1 →ₗ[ℤ]
+                  SingularMayerVietoris.SingularHomology G 3 =>
+              f (c - l • a))
+            (map_zsmul (PeriodTorusHigherHomologyPontryagin.tripleProduct G a) k a))
+    _ = PeriodTorusHigherHomologyPontryagin.tripleProduct G a b (c - l • a) := by
+      rw [PeriodTorusHigherHomologyPontryagin.tripleProduct_self01, zsmul_zero, sub_zero]
+    _ = PeriodTorusHigherHomologyPontryagin.tripleProduct G a b c := by
+      rw [map_sub, map_zsmul, PeriodTorusHigherHomologyPontryagin.tripleProduct_self02,
+        zsmul_zero, sub_zero]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.CapKernelShear.product11_fixed_of_head (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] (f : C(G, G))
+    (hf : ∀ x y, f (x + y) = f x + f y) (a b : SingularMayerVietoris.SingularHomology G 1) (k : ℤ)
+    (ha : SingularMayerVietoris.singularHomologyMap f 1 a = a)
+    (hb : SingularMayerVietoris.singularHomologyMap f 1 b = b - k • a) :
+    SingularMayerVietoris.singularHomologyMap f 2
+        (PeriodTorusHigherHomologyPontryagin.product11 G a b) =
+      PeriodTorusHigherHomologyPontryagin.product11 G a b := by
+  rw [PeriodTorusHigherHomologyPontryagin.product_natural f hf 1, ha, hb, product11_sub_head]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodFamily.CapKernelShear.tripleProduct_fixed_of_head (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] (f : C(G, G))
+    (hf : ∀ x y, f (x + y) = f x + f y) (a b c : SingularMayerVietoris.SingularHomology G 1)
+    (k l : ℤ) (ha : SingularMayerVietoris.singularHomologyMap f 1 a = a)
+    (hb : SingularMayerVietoris.singularHomologyMap f 1 b = b - k • a)
+    (hc : SingularMayerVietoris.singularHomologyMap f 1 c = c - l • a) :
+    SingularMayerVietoris.singularHomologyMap f 3
+        (PeriodTorusHigherHomologyPontryagin.tripleProduct G a b c) =
+      PeriodTorusHigherHomologyPontryagin.tripleProduct G a b c := by
+  rw [PeriodTorusHigherHomologyPontryagin.tripleProduct_natural f hf, ha, hb, hc,
+    tripleProduct_sub_head]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.CapKernelShear.shear_unsplit_homology
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 4,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 4)
+        n) :
+    SingularMayerVietoris.singularHomologyMap
+        ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 4).symm :
+          C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+              PeriodTorusHigherHomology.ProductTorus 4,
+            PeriodTorusHigherHomology.ProductTorus 5))
+        n (SingularMayerVietoris.singularHomologyMap (shear χ) n a) =
+      SingularMayerVietoris.singularHomologyMap (torusShear χ) n
+        (SingularMayerVietoris.singularHomologyMap
+          ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 4).symm :
+            C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+                PeriodTorusHigherHomology.ProductTorus 4,
+              PeriodTorusHigherHomology.ProductTorus 5))
+          n a) := by
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp, ←
+    torusShear_comp_unsplit, PeriodTorusHigherHomology.singularHomologyMap_comp,
+    LinearMap.comp_apply]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.CapKernelShear.unsplit_positiveCircleCross (n : ℕ)
+    (b : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) n) :
+    SingularMayerVietoris.singularHomologyMap
+        ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 4).symm :
+          C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+              PeriodTorusHigherHomology.ProductTorus 4,
+            PeriodTorusHigherHomology.ProductTorus 5))
+        (n + 1)
+        (PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 4)
+          n b) =
+      PeriodTorusHigherHomologyPontryagin.product (PeriodTorusHigherHomology.ProductTorus 5) n
+        headClass
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusTailMap 4) n
+          b) := by
+  rw [PeriodTorusHigherHomology.torusSplit_positiveCircleCross,
+    PeriodTorusHigherHomology.torusHeadCircleMap_positiveHomology]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.CapKernelShear.shear_positiveCircleCross_of_product
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 4,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (n : ℕ)
+    (b : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) n)
+    (h :
+      SingularMayerVietoris.singularHomologyMap (torusShear χ) (n + 1)
+          (PeriodTorusHigherHomologyPontryagin.product (PeriodTorusHigherHomology.ProductTorus 5)
+            n headClass
+            (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusTailMap 4)
+              n b)) =
+        PeriodTorusHigherHomologyPontryagin.product (PeriodTorusHigherHomology.ProductTorus 5) n
+          headClass
+          (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusTailMap 4) n
+            b)) :
+    SingularMayerVietoris.singularHomologyMap (shear χ) (n + 1)
+        (PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 4)
+          n b) =
+      PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 4) n
+        b := by
+  apply
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+        (PeriodTorusHigherHomology.productTorusSuccHomeomorph 4).symm (n + 1)).injective
+  change
+    SingularMayerVietoris.singularHomologyMap
+        ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 4).symm :
+          C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+              PeriodTorusHigherHomology.ProductTorus 4,
+            PeriodTorusHigherHomology.ProductTorus 5))
+        (n + 1)
+        (SingularMayerVietoris.singularHomologyMap (shear χ) (n + 1)
+          (PeriodTorusHigherHomology.positiveCircleCross
+            (PeriodTorusHigherHomology.ProductTorus 4) n b)) =
+      SingularMayerVietoris.singularHomologyMap
+        ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 4).symm :
+          C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+              PeriodTorusHigherHomology.ProductTorus 4,
+            PeriodTorusHigherHomology.ProductTorus 5))
+        (n + 1)
+        (PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 4)
+          n b)
+  rw [shear_unsplit_homology, unsplit_positiveCircleCross]
+  exact h
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.CapKernelShear.shear_positiveCircleCross_one
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 4,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y)
+    (b : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 1) :
+    SingularMayerVietoris.singularHomologyMap (shear χ) 2
+        (PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 4)
+          1 b) =
+      PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 4) 1
+        b := by
+  let := PeriodTorusHigherHomology.productTorus_homology_torsionFree 5 2
+  apply shear_positiveCircleCross_of_product χ 1 b
+  exact
+    product11_fixed_of_head (PeriodTorusHigherHomology.ProductTorus 5) (torusShear χ)
+      (torusShear_add χ hχ) headClass
+      (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusTailMap 4) 1 b)
+      (PeriodTorusHigherHomology.circleHomologyOneEquiv
+        (SingularMayerVietoris.singularHomologyMap χ 1 b))
+      (torusShear_headClass χ hχ) (torusShear_tailHomology χ hχ b)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.CapKernelShear.shear_positiveCircleCross_two_product11
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 4,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y)
+    (b c : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 1) :
+    SingularMayerVietoris.singularHomologyMap (shear χ) 3
+        (PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 4)
+          2
+          (PeriodTorusHigherHomologyPontryagin.product11
+            (PeriodTorusHigherHomology.ProductTorus 4) b c)) =
+      PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 4) 2
+        (PeriodTorusHigherHomologyPontryagin.product11 (PeriodTorusHigherHomology.ProductTorus 4)
+          b c) := by
+  let := PeriodTorusHigherHomology.productTorus_homology_torsionFree 5 2
+  apply
+    shear_positiveCircleCross_of_product χ 2
+      (PeriodTorusHigherHomologyPontryagin.product11 (PeriodTorusHigherHomology.ProductTorus 4) b
+        c)
+  rw [PeriodTorusHigherHomologyPontryagin.product_natural
+      (PeriodTorusHigherHomology.torusTailMap 4) (PeriodTorusHigherHomology.torusTailMap_add 4) 1]
+  exact
+    tripleProduct_fixed_of_head (PeriodTorusHigherHomology.ProductTorus 5) (torusShear χ)
+      (torusShear_add χ hχ) headClass
+      (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusTailMap 4) 1 b)
+      (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusTailMap 4) 1 c)
+      (PeriodTorusHigherHomology.circleHomologyOneEquiv
+        (SingularMayerVietoris.singularHomologyMap χ 1 b))
+      (PeriodTorusHigherHomology.circleHomologyOneEquiv
+        (SingularMayerVietoris.singularHomologyMap χ 1 c))
+      (torusShear_headClass χ hχ) (torusShear_tailHomology χ hχ b)
+      (torusShear_tailHomology χ hχ c)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.CapKernelShear.shear_positiveCircleCross_two
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 4,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y)
+    (b : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 2) :
+    SingularMayerVietoris.singularHomologyMap (shear χ) 3
+        (PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 4)
+          2 b) =
+      PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 4) 2
+        b := by
+  have h :
+    ((SingularMayerVietoris.singularHomologyMap (shear χ) 3).comp
+            (PeriodTorusHigherHomology.positiveCircleCross
+              (PeriodTorusHigherHomology.ProductTorus 4) 2)).comp
+        PeriodTorusHigherHomology.coordinateTorusWedgeTwo =
+      (PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 4)
+            2).comp
+        PeriodTorusHigherHomology.coordinateTorusWedgeTwo := by
+    apply exteriorPower.linearMap_ext
+    apply AlternatingMap.ext
+    intro v
+    change
+      SingularMayerVietoris.singularHomologyMap (shear χ) 3
+          (PeriodTorusHigherHomology.positiveCircleCross
+            (PeriodTorusHigherHomology.ProductTorus 4) 2
+            (PeriodTorusHigherHomology.coordinateTorusWedgeTwo (exteriorPower.ιMulti ℤ 2 v))) =
+        PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 4) 2
+          (PeriodTorusHigherHomology.coordinateTorusWedgeTwo (exteriorPower.ιMulti ℤ 2 v))
+    rw [PeriodTorusHigherHomology.coordinateTorusWedgeTwo_apply_ιMulti]
+    exact shear_positiveCircleCross_two_product11 χ hχ _ _
+  obtain ⟨v, rfl⟩ := PeriodTorusHigherHomology.coordinateTorusWedgeTwo_surjective b
+  exact LinearMap.congr_fun h v
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.CapKernelShear.shear_positiveCircleCross
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 4,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y) (n : ℕ) (hn : n = 1 ∨ n = 2)
+    (b : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) n) :
+    SingularMayerVietoris.singularHomologyMap (shear χ) (n + 1)
+        (PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 4)
+          n b) =
+      PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 4) n
+        b := by
+  rcases hn with rfl | rfl
+  · exact shear_positiveCircleCross_one χ hχ b
+  · exact shear_positiveCircleCross_two χ hχ b
+
+private def PeriodFamily.CapKernelShear.realShear
+    (χ : C(RealTorus₄, (PeriodTorusHigherHomology.CircleTopology.Circle))) :
+    C((PeriodTorusHigherHomology.CircleTopology.Circle) × RealTorus₄,
+      (PeriodTorusHigherHomology.CircleTopology.Circle) × RealTorus₄)
+    where
+  toFun z := (z.1 - χ z.2, z.2)
+  continuous_toFun :=
+    (continuous_fst.sub (χ.continuous.comp continuous_snd)).prodMk continuous_snd
+
+private def PeriodFamily.CapKernelShear.coordinateCharacter
+    (χ : C(RealTorus₄, (PeriodTorusHigherHomology.CircleTopology.Circle))) :
+    C(PeriodTorusHigherHomology.ProductTorus 4,
+      (PeriodTorusHigherHomology.CircleTopology.Circle)) :=
+  χ.comp
+    (PeriodTorusHigherHomology.flatTorusCircleHomeomorph.symm :
+      C(PeriodTorusHigherHomology.ProductTorus 4, RealTorus₄))
+
+private theorem PeriodFamily.CapKernelShear.coordinateCharacter_add
+    (χ : C(RealTorus₄, (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y) (x y : PeriodTorusHigherHomology.ProductTorus 4) :
+    coordinateCharacter χ (x + y) = coordinateCharacter χ x + coordinateCharacter χ y := by
+  have h :
+    PeriodTorusHigherHomology.flatTorusCircleHomeomorph.symm (x + y) =
+      PeriodTorusHigherHomology.flatTorusCircleHomeomorph.symm x +
+        PeriodTorusHigherHomology.flatTorusCircleHomeomorph.symm y := by
+    apply PeriodTorusHigherHomology.flatTorusCircleHomeomorph.injective
+    rw [Homeomorph.apply_symm_apply, PeriodTorusHigherHomology.flatTorusCircleHomeomorph_add,
+      Homeomorph.apply_symm_apply, Homeomorph.apply_symm_apply]
+  change
+    χ (PeriodTorusHigherHomology.flatTorusCircleHomeomorph.symm (x + y)) =
+      χ (PeriodTorusHigherHomology.flatTorusCircleHomeomorph.symm x) +
+        χ (PeriodTorusHigherHomology.flatTorusCircleHomeomorph.symm y)
+  rw [h, hχ]
+
+private def PeriodFamily.CapKernelShear.realCircleCoordinates :
+    ((PeriodTorusHigherHomology.CircleTopology.Circle) × RealTorus₄) ≃ₜ
+      ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+        PeriodTorusHigherHomology.ProductTorus 4) :=
+  (Homeomorph.refl (PeriodTorusHigherHomology.CircleTopology.Circle)).prodCongr
+    PeriodTorusHigherHomology.flatTorusCircleHomeomorph
+
+private theorem PeriodFamily.CapKernelShear.realShear_coordinates
+    (χ : C(RealTorus₄, (PeriodTorusHigherHomology.CircleTopology.Circle))) :
+    (PeriodTorusHigherHomology.circleProductMap
+            (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+              C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))).comp
+        (realShear χ) =
+      (shear (coordinateCharacter χ)).comp
+        (PeriodTorusHigherHomology.circleProductMap
+          (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+            C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))) := by
+  apply ContinuousMap.ext
+  rintro ⟨z, x⟩
+  change
+    (z - χ x, PeriodTorusHigherHomology.flatTorusCircleHomeomorph x) =
+      (z -
+          χ
+            (PeriodTorusHigherHomology.flatTorusCircleHomeomorph.symm
+              (PeriodTorusHigherHomology.flatTorusCircleHomeomorph x)),
+        PeriodTorusHigherHomology.flatTorusCircleHomeomorph x)
+  rw [Homeomorph.symm_apply_apply]
+
+private theorem PeriodFamily.CapKernelShear.realShear_coordinate_homology
+    (χ : C(RealTorus₄, (PeriodTorusHigherHomology.CircleTopology.Circle))) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) × RealTorus₄) n) :
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.circleProductMap
+          (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+            C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4)))
+        n (SingularMayerVietoris.singularHomologyMap (realShear χ) n a) =
+      SingularMayerVietoris.singularHomologyMap (shear (coordinateCharacter χ)) n
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.circleProductMap
+            (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+              C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4)))
+          n a) := by
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    realShear_coordinates, PeriodTorusHigherHomology.singularHomologyMap_comp,
+    LinearMap.comp_apply]
+
+private theorem PeriodFamily.CapKernelShear.realShear_positiveCircleCross
+    (χ : C(RealTorus₄, (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y) (n : ℕ) (hn : n = 1 ∨ n = 2)
+    (b : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    SingularMayerVietoris.singularHomologyMap (realShear χ) (n + 1)
+        (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ n b) =
+      PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ n b := by
+  apply
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv realCircleCoordinates (n + 1)).injective
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.circleProductMap
+          (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+            C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4)))
+        (n + 1)
+        (SingularMayerVietoris.singularHomologyMap (realShear χ) (n + 1)
+          (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ n b)) =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.circleProductMap
+          (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+            C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4)))
+        (n + 1) (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ n b)
+  simp only [realShear_coordinate_homology,
+    PeriodTorusHigherHomology.positiveCircleCross_naturality]
+  exact
+    shear_positiveCircleCross (coordinateCharacter χ) (coordinateCharacter_add χ hχ) n hn
+      (SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+          C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+        n b)
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapKernelWang.twistCircleCharacter_add (j : Elliptic.Kind)
+    (x y : RealTorus₄) :
+    twistCircleCharacter j (x + y) = twistCircleCharacter j x + twistCircleCharacter j y := by
+  obtain ⟨u, rfl⟩ := standardLattice.mkQ_surjective x
+  obtain ⟨v, rfl⟩ := standardLattice.mkQ_surjective y
+  rw [← map_add, twistCircleCharacter_apply, twistCircleCharacter_apply,
+    twistCircleCharacter_apply, Elliptic.HigherHomology.splitFlatTorusHomeomorph_mkQ,
+    Elliptic.HigherHomology.splitFlatTorusHomeomorph_mkQ,
+    Elliptic.HigherHomology.splitFlatTorusHomeomorph_mkQ]
+  simp only [map_add, Prod.fst_add, AddCircle.coe_add]
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapKernelWang.nativeShear_eq_realShear (j : Elliptic.Kind) :
+    nativeShear j = PeriodFamily.CapKernelShear.realShear (twistCircleCharacter j) :=
+  rfl
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.nativeShear_positiveCircleCross
+    (j : Elliptic.Kind) (n : ℕ) (hn : n = 1 ∨ n = 2)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    SingularMayerVietoris.singularHomologyMap (nativeShear j) (n + 1)
+        (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ n a) =
+      PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ n a := by
+  rw [nativeShear_eq_realShear]
+  exact
+    PeriodFamily.CapKernelShear.realShear_positiveCircleCross (twistCircleCharacter j)
+      (twistCircleCharacter_add j) n hn a
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapKernelWang.crossWang_surfaceCover (j : Elliptic.Kind)
+    (n : ℕ) (hn : n = 1 ∨ n = 2) (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    crossWang j n (SingularMayerVietoris.singularHomologyMap (surfaceCover j) n a) =
+      originalAffineNorm j n a :=
+  crossWang_surfaceCover_of_shear j n a (nativeShear_positiveCircleCross j n hn a)
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapKernelWang.crossWang_surfaceCover_one (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 1) :
+    crossWang j 1 (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 1 a) =
+      originalAffineNorm j 1 a :=
+  crossWang_surfaceCover j 1 (Or.inl rfl) a
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapKernelWang.crossWang_surfaceCover_two (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 2) :
+    crossWang j 2 (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 2 a) =
+      originalAffineNorm j 2 a :=
+  crossWang_surfaceCover j 2 (Or.inr rfl) a
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover_eq_periodCover
+    (j : Elliptic.Kind) :
+    surfaceCover j =
+      (Elliptic.HigherHomology.periodCover j
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+            (Elliptic.mainTwist_admissible j)).comp
+        (Elliptic.flatTorusPeriodHomeomorph
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod.val :
+          C(_, _)) := by
+  apply ContinuousMap.ext
+  exact surfaceCover_apply j
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover_split (j : Elliptic.Kind) :
+    (Elliptic.HigherHomology.surfaceMappingTorusHomeomorph j
+              (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod :
+            C(_, _)).comp
+        ((surfaceCover j).comp
+          ((Elliptic.HigherHomology.splitFlatTorusHomeomorph j).symm : C(_, _))) =
+      MappingTorusHomology.Covering.productCover j.order
+        (Elliptic.HigherHomology.fibreTorusHomeomorph j)
+        (Elliptic.HigherHomology.fibreTorusHomeomorph_pow_order j) := by
+  apply ContinuousMap.ext
+  rintro ⟨c, x⟩
+  obtain ⟨t, rfl⟩ := QuotientAddGroup.mk_surjective c
+  change
+    Elliptic.HigherHomology.surfaceMappingTorusHomeomorph j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+        (surfaceCover j
+          ((Elliptic.HigherHomology.splitFlatTorusHomeomorph j).symm
+            ((t : MappingTorus.Circle), x))) =
+      _
+  rw [surfaceCover_apply]
+  change
+    Elliptic.HigherHomology.surfaceMappingTorusHomeomorph j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+        (Elliptic.surfaceProjection j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+          (Elliptic.mainTwist_admissible j)
+          ((Elliptic.HigherHomology.splitPeriodTorusHomeomorph j
+                (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod.val).symm
+            ((t : MappingTorus.Circle), x))) =
+      _
+  rw [Elliptic.HigherHomology.surfaceMappingTorusHomeomorph_splitPeriodTorus,
+    MappingTorusHomology.Covering.productCover_real_apply]
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover_split_homology
+    (j : Elliptic.Kind) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (MappingTorus.Circle × PeriodTorusHigherHomology.ProductTorus 3) n) :
+    Elliptic.HigherHomology.surfaceMappingTorusHomologyEquiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod n
+        (SingularMayerVietoris.singularHomologyMap (surfaceCover j) n
+          (SingularMayerVietoris.singularHomologyMap
+            ((Elliptic.HigherHomology.splitFlatTorusHomeomorph j).symm : C(_, _)) n a)) =
+      MappingTorusHomology.Covering.productCoverHomology j.order
+        (Elliptic.HigherHomology.fibreTorusHomeomorph j)
+        (Elliptic.HigherHomology.fibreTorusHomeomorph_pow_order j) n a := by
+  have h :=
+    congrArg
+      (fun f :
+          C(MappingTorus.Circle × PeriodTorusHigherHomology.ProductTorus 3,
+            Elliptic.HigherHomology.mappingTorusModel j) =>
+        SingularMayerVietoris.singularHomologyMap f n)
+      (surfaceCover_split j)
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodTorusHigherHomology.singularHomologyMap_comp] at h
+  exact LinearMap.congr_fun h a
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover_split_section (j : Elliptic.Kind)
+    (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) n) :
+    Elliptic.HigherHomology.surfaceMappingTorusHomologyEquiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod n
+        (SingularMayerVietoris.singularHomologyMap (surfaceCover j) n
+          (SingularMayerVietoris.singularHomologyMap
+            ((Elliptic.HigherHomology.splitFlatTorusHomeomorph j).symm : C(_, _)) n
+            (PeriodTorusHigherHomology.circleSectionHomology
+              (PeriodTorusHigherHomology.ProductTorus 3) n a))) =
+      MappingTorusHomology.fibreHomologyMap (Elliptic.HigherHomology.fibreTorusHomeomorph j).symm
+        n a := by
+  rw [surfaceCover_split_homology,
+    MappingTorusHomology.Covering.productCoverHomology_circleSection_apply]
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover_split_cross_wang
+    (j : Elliptic.Kind) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) n) :
+    MappingTorusHomology.wangBoundary (Elliptic.HigherHomology.fibreTorusHomeomorph j).symm n
+        (Elliptic.HigherHomology.surfaceMappingTorusHomologyEquiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod (n + 1)
+          (SingularMayerVietoris.singularHomologyMap (surfaceCover j) (n + 1)
+            (SingularMayerVietoris.singularHomologyMap
+              ((Elliptic.HigherHomology.splitFlatTorusHomeomorph j).symm : C(_, _)) (n + 1)
+              (PeriodTorusHigherHomology.positiveCircleCross
+                (PeriodTorusHigherHomology.ProductTorus 3) n a)))) =
+      Elliptic.HigherHomology.fibreHomologyNorm j n a := by
+  rw [surfaceCover_split_homology,
+    MappingTorusHomology.Covering.wangBoundary_productCover_positiveCircleCross]
+  exact LinearMap.congr_fun (Elliptic.HigherHomology.fibreHomologyNorm_eq_homologyNorm j n).symm a
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreInputOne :
+    SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 1 :=
+  Elliptic.HigherHomology.torusH1Equiv.symm ![0, 1, 0]
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreInputTwo :
+    SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 2 :=
+  Elliptic.HigherHomology.torusH2Coordinates.symm ![1, 0, 0]
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreClassOne (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology RealTorus₄ 1 :=
+  SingularMayerVietoris.singularHomologyMap
+    ((Elliptic.HigherHomology.splitFlatTorusHomeomorph j).symm :
+      C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 3,
+        RealTorus₄))
+    1
+    (PeriodTorusHigherHomology.circleSectionHomology (PeriodTorusHigherHomology.ProductTorus 3) 1
+      splitFibreInputOne)
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassOne (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology RealTorus₄ 1 :=
+  SingularMayerVietoris.singularHomologyMap
+    ((Elliptic.HigherHomology.splitFlatTorusHomeomorph j).symm :
+      C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 3,
+        RealTorus₄))
+    1
+    (PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 3) 0
+      (PeriodTorusHigherHomology.pointClass (0 : PeriodTorusHigherHomology.ProductTorus 3)))
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreClassTwo (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology RealTorus₄ 2 :=
+  SingularMayerVietoris.singularHomologyMap
+    ((Elliptic.HigherHomology.splitFlatTorusHomeomorph j).symm :
+      C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 3,
+        RealTorus₄))
+    2
+    (PeriodTorusHigherHomology.circleSectionHomology (PeriodTorusHigherHomology.ProductTorus 3) 2
+      splitFibreInputTwo)
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassTwo (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology RealTorus₄ 2 :=
+  SingularMayerVietoris.singularHomologyMap
+    ((Elliptic.HigherHomology.splitFlatTorusHomeomorph j).symm :
+      C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 3,
+        RealTorus₄))
+    2
+    (PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 3) 1
+      splitFibreInputOne)
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearOne (j : Elliptic.Kind) : ℤ :=
+  Elliptic.HigherHomology.surfaceH1Equiv j
+    (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+    (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 1 (splitCircleClassOne j)) 0
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo (j : Elliptic.Kind) : ℤ :=
+  Elliptic.HigherHomology.surfaceH2Equiv j
+    (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+    (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 2 (splitCircleClassTwo j)) 0
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover_splitFibreClassOne
+    (j : Elliptic.Kind) :
+    Elliptic.HigherHomology.surfaceH1Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+        (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 1 (splitFibreClassOne j)) =
+      ![1, 0] := by
+  change
+    Elliptic.HigherHomology.mappingTorusH1Equiv j
+        (Elliptic.HigherHomology.surfaceMappingTorusHomologyEquiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod 1
+          (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 1 (splitFibreClassOne j))) =
+      _
+  rw [splitFibreClassOne, surfaceCover_split_section,
+    Elliptic.HigherHomology.mappingTorusH1Equiv_fibre, splitFibreInputOne,
+    LinearEquiv.apply_symm_apply, Elliptic.HigherHomology.fibreCoinvariantCoordinate_section]
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover_splitCircleClassOne_second
+    (j : Elliptic.Kind) :
+    Elliptic.HigherHomology.surfaceH1Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+        (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 1 (splitCircleClassOne j)) 1 =
+      j.order := by
+  change
+    Elliptic.HigherHomology.mappingTorusH1Equiv j
+        (Elliptic.HigherHomology.surfaceMappingTorusHomologyEquiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod 1
+          (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 1 (splitCircleClassOne j)))
+        1 =
+      _
+  rw [Elliptic.HigherHomology.mappingTorusH1Equiv_boundary, splitCircleClassOne,
+    surfaceCover_split_cross_wang, Elliptic.HigherHomology.fibreHomologyNorm_zero,
+    Elliptic.HigherHomology.torusH0Coordinates_pointClass, mul_one]
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover_splitCircleClassOne
+    (j : Elliptic.Kind) :
+    Elliptic.HigherHomology.surfaceH1Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+        (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 1 (splitCircleClassOne j)) =
+      ![sourceShearOne j, (j.order : ℤ)] := by
+  ext i
+  fin_cases i
+  · rfl
+  · exact surfaceCover_splitCircleClassOne_second j
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover_splitFibreClassTwo
+    (j : Elliptic.Kind) :
+    Elliptic.HigherHomology.surfaceH2Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+        (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 2 (splitFibreClassTwo j)) =
+      ![1, 0] := by
+  change
+    Elliptic.HigherHomology.mappingTorusH2Equiv j
+        (Elliptic.HigherHomology.surfaceMappingTorusHomologyEquiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod 2
+          (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 2 (splitFibreClassTwo j))) =
+      _
+  rw [splitFibreClassTwo, surfaceCover_split_section,
+    Elliptic.HigherHomology.mappingTorusH2Equiv_fibre, splitFibreInputTwo,
+    LinearEquiv.apply_symm_apply]
+  rfl
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover_splitCircleClassTwo_second
+    (j : Elliptic.Kind) :
+    Elliptic.HigherHomology.surfaceH2Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+        (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 2 (splitCircleClassTwo j)) 1 =
+      Elliptic.HigherHomology.fibreNormIndex j := by
+  change
+    Elliptic.HigherHomology.mappingTorusH2Equiv j
+        (Elliptic.HigherHomology.surfaceMappingTorusHomologyEquiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod 2
+          (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 2 (splitCircleClassTwo j)))
+        1 =
+      _
+  rw [Elliptic.HigherHomology.mappingTorusH2Equiv_boundary, splitCircleClassTwo,
+    surfaceCover_split_cross_wang]
+  change Elliptic.HigherHomology.fibreHomologyNormOneCoordinate j splitFibreInputOne = _
+  rw [Elliptic.HigherHomology.fibreHomologyNormOneCoordinate_apply, splitFibreInputOne,
+    LinearEquiv.apply_symm_apply, Elliptic.HigherHomology.fibreCoinvariantCoordinate_section,
+    mul_one]
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover_splitCircleClassTwo
+    (j : Elliptic.Kind) :
+    Elliptic.HigherHomology.surfaceH2Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+        (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 2 (splitCircleClassTwo j)) =
+      ![sourceShearTwo j, (Elliptic.HigherHomology.fibreNormIndex j : ℤ)] := by
+  ext i
+  fin_cases i
+  · rfl
+  · exact surfaceCover_splitCircleClassTwo_second j
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.cover_columns_smul {A : Type*}
+    [AddCommGroup A] [Module ℤ A] (e : A ≃ₗ[ℤ] (Fin 2 → ℤ)) (u v a : A) (c d : ℤ)
+    (hu : e u = ![1, 0]) (hv : e v = ![c, d]) : d • a = (d * e a 0 - c * e a 1) • u + e a 1 • v :=
+  by
+  apply e.injective
+  rw [map_add, map_zsmul, map_zsmul, map_zsmul, hu, hv]
+  ext i
+  fin_cases i
+  · change d * e a 0 = (d * e a 0 - c * e a 1) * 1 + e a 1 * c
+    ring
+  · change d * e a 1 = (d * e a 0 - c * e a 1) * 0 + e a 1 * d
+    ring
+
+public
+theorem PeriodFamily.Boundary.EllipticCapKernelWang.map_cover_columns {A B : Type*}
+    [AddCommGroup A] [Module ℤ A] [AddCommGroup B] [Module ℤ B] (e : A ≃ₗ[ℤ] (Fin 2 → ℤ))
+    (L : A →ₗ[ℤ] B) (u v a : A) (c d : ℤ) (hu : e u = ![1, 0]) (hv : e v = ![c, d]) :
+    d • L a = (d * e a 0 - c * e a 1) • L u + e a 1 • L v := by
+  simpa only [map_add, map_zsmul] using congrArg L (cover_columns_smul e u v a c d hu hv)
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.h1Coordinates (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) 1 →ₗ[ℤ]
+      Lattice :=
+  PeriodFamily.FlatTorus.singularH1Equiv.toLinearMap.comp (crossWang j 1)
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.h2Coordinates (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) 2 →ₗ[ℤ]
+      (Fin 6 → ℤ) :=
+  PeriodFamily.FlatTorus.singularH2Coordinates.toLinearMap.comp (crossWang j 2)
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.h1Coordinates_apply (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) 1) :
+    h1Coordinates j a = PeriodFamily.FlatTorus.singularH1Equiv (crossWang j 1 a) :=
+  rfl
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.h2Coordinates_apply (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) 2) :
+    h2Coordinates j a = PeriodFamily.FlatTorus.singularH2Coordinates (crossWang j 2 a) :=
+  rfl
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapKernelWang.h1Coordinates_surfaceCover (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 1) :
+    h1Coordinates j (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 1 a) =
+      PeriodFamily.FlatTorus.singularH1Equiv (originalAffineNorm j 1 a) := by
+  rw [h1Coordinates_apply, crossWang_surfaceCover_one]
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapKernelWang.h2Coordinates_surfaceCover (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 2) :
+    h2Coordinates j (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 2 a) =
+      PeriodFamily.FlatTorus.singularH2Coordinates (originalAffineNorm j 2 a) := by
+  rw [h2Coordinates_apply, crossWang_surfaceCover_two]
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.h1Coordinates_cover_columns
+    (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) 1) :
+    (j.order : ℤ) • h1Coordinates j a =
+      ((j.order : ℤ) *
+              Elliptic.HigherHomology.surfaceH1Equiv j
+                (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 0 -
+            sourceShearOne j *
+              Elliptic.HigherHomology.surfaceH1Equiv j
+                (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1) •
+          PeriodFamily.FlatTorus.singularH1Equiv (originalAffineNorm j 1 (splitFibreClassOne j)) +
+        Elliptic.HigherHomology.surfaceH1Equiv j
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1 •
+          PeriodFamily.FlatTorus.singularH1Equiv
+            (originalAffineNorm j 1 (splitCircleClassOne j)) := by
+  have h :=
+    map_cover_columns
+      (Elliptic.HigherHomology.surfaceH1Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod)
+      (h1Coordinates j)
+      (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 1 (splitFibreClassOne j))
+      (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 1 (splitCircleClassOne j)) a
+      (sourceShearOne j) (j.order : ℤ) (surfaceCover_splitFibreClassOne j)
+      (surfaceCover_splitCircleClassOne j)
+  simpa only [h1Coordinates_surfaceCover] using h
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.h2Coordinates_cover_columns
+    (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) 2) :
+    (Elliptic.HigherHomology.fibreNormIndex j : ℤ) • h2Coordinates j a =
+      ((Elliptic.HigherHomology.fibreNormIndex j : ℤ) *
+              Elliptic.HigherHomology.surfaceH2Equiv j
+                (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 0 -
+            sourceShearTwo j *
+              Elliptic.HigherHomology.surfaceH2Equiv j
+                (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1) •
+          PeriodFamily.FlatTorus.singularH2Coordinates
+            (originalAffineNorm j 2 (splitFibreClassTwo j)) +
+        Elliptic.HigherHomology.surfaceH2Equiv j
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1 •
+          PeriodFamily.FlatTorus.singularH2Coordinates
+            (originalAffineNorm j 2 (splitCircleClassTwo j)) := by
+  have h :=
+    map_cover_columns
+      (Elliptic.HigherHomology.surfaceH2Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod)
+      (h2Coordinates j)
+      (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 2 (splitFibreClassTwo j))
+      (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 2 (splitCircleClassTwo j)) a
+      (sourceShearTwo j) (Elliptic.HigherHomology.fibreNormIndex j : ℤ)
+      (surfaceCover_splitFibreClassTwo j) (surfaceCover_splitCircleClassTwo j)
+  simpa only [h2Coordinates_surfaceCover] using h
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitFlat_inverse_circle_comp
+    (j : Elliptic.Kind) :
+    (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+            C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4)).comp
+        ((Elliptic.HigherHomology.splitFlatTorusHomeomorph j).symm :
+          C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+              PeriodTorusHigherHomology.ProductTorus 3,
+            RealTorus₄)) =
+      (PeriodTorusHigherHomology.torusMatrixMap (Elliptic.HigherHomology.twistBasisMatrix j)).comp
+        ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 3).symm :
+          C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+              PeriodTorusHigherHomology.ProductTorus 3,
+            PeriodTorusHigherHomology.ProductTorus 4)) := by
+  apply ContinuousMap.ext
+  intro x
+  change
+    PeriodTorusHigherHomology.flatTorusCircleHomeomorph
+        (PeriodTorusHigherHomology.flatTorusCircleHomeomorph.symm
+          (PeriodTorusHigherHomology.torusMatrixMap (Elliptic.HigherHomology.twistBasisMatrix j)
+            ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 3).symm x))) =
+      _
+  exact PeriodTorusHigherHomology.flatTorusCircleHomeomorph.apply_symm_apply _
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitFlat_inverse_circle_homology
+    (j : Elliptic.Kind) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 3)
+        n) :
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+          C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+        n
+        (SingularMayerVietoris.singularHomologyMap
+          ((Elliptic.HigherHomology.splitFlatTorusHomeomorph j).symm :
+            C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+                PeriodTorusHigherHomology.ProductTorus 3,
+              RealTorus₄))
+          n a) =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.torusMatrixMap (Elliptic.HigherHomology.twistBasisMatrix j)) n
+        (SingularMayerVietoris.singularHomologyMap
+          ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 3).symm :
+            C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+                PeriodTorusHigherHomology.ProductTorus 3,
+              PeriodTorusHigherHomology.ProductTorus 4))
+          n a) := by
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    splitFlat_inverse_circle_comp, PeriodTorusHigherHomology.singularHomologyMap_comp,
+    LinearMap.comp_apply]
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitOne_unsplit_fibre
+    (v : Elliptic.HigherHomology.FibreLattice) :
+    SingularMayerVietoris.singularHomologyMap
+        ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 3).symm :
+          C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+              PeriodTorusHigherHomology.ProductTorus 3,
+            PeriodTorusHigherHomology.ProductTorus 4))
+        1
+        (PeriodTorusHigherHomology.circleSectionHomology
+          (PeriodTorusHigherHomology.ProductTorus 3) 1
+          (Elliptic.HigherHomology.torusH1Equiv.symm v)) =
+      FirstHurewicz.loopHomologyClass
+        (PeriodTorusHigherHomology.coordinatePeriodLoop 4 (Fin.cons 0 v)) := by
+  rw [Elliptic.HigherHomology.torusH1Equiv_symm_apply_loop,
+    PeriodTorusHigherHomology.circleSectionHomology, ← LinearMap.comp_apply, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+  exact PeriodTorusHigherHomology.torusTailMap_coordinatePeriodHomology 3 v
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitOne_unsplit_circle :
+    SingularMayerVietoris.singularHomologyMap
+        ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 3).symm :
+          C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+              PeriodTorusHigherHomology.ProductTorus 3,
+            PeriodTorusHigherHomology.ProductTorus 4))
+        1
+        (PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 3)
+          0
+          (PeriodTorusHigherHomology.pointClass (0 : PeriodTorusHigherHomology.ProductTorus 3))) =
+      FirstHurewicz.loopHomologyClass
+        (PeriodTorusHigherHomology.coordinatePeriodLoop 4 (Pi.single 0 1)) := by
+  rw [PeriodTorusHigherHomology.positiveCircleCross,
+    PeriodTorusHigherHomology.crossProductHomology_pointClass_right]
+  have hmap :
+    ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 3).symm :
+            C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+                PeriodTorusHigherHomology.ProductTorus 3,
+              PeriodTorusHigherHomology.ProductTorus 4)).comp
+        (PeriodTorusHigherHomology.crossInsertRight
+          (0 : PeriodTorusHigherHomology.ProductTorus 3)) =
+      PeriodTorusHigherHomology.torusHeadCircleMap 3 := by
+    apply ContinuousMap.ext
+    intro z
+    rw [PeriodTorusHigherHomology.torusHeadCircleMap_apply]
+    rfl
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp, hmap]
+  exact PeriodTorusHigherHomology.torusHeadCircleMap_positiveHomology 3
+
+private theorem
+  PeriodFamily.Boundary.EllipticCapKernelWang.splitOne_originalCoordinates_mo1973_27797
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 1) (v : Lattice)
+    (h :
+      SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+            C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+          1 a =
+        FirstHurewicz.loopHomologyClass (PeriodTorusHigherHomology.coordinatePeriodLoop 4 v)) :
+    PeriodFamily.FlatTorus.singularH1Equiv a = v := by
+  apply PeriodFamily.FlatTorus.singularH1Equiv.symm.injective
+  rw [LinearEquiv.symm_apply_apply]
+  apply
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+        PeriodTorusHigherHomology.flatTorusCircleHomeomorph 1).injective
+  exact h.trans (PeriodFamily.FlatTorus.inducedHomology_singularH1Equiv_symm_circle v).symm
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreClassOne_coordinates
+    (j : Elliptic.Kind) :
+    PeriodFamily.FlatTorus.singularH1Equiv (splitFibreClassOne j) = ![0, 0, 1, 0] := by
+  apply splitOne_originalCoordinates_mo1973_27797
+  rw [splitFibreClassOne, splitFlat_inverse_circle_homology, splitFibreInputOne,
+    splitOne_unsplit_fibre, SingularMayerVietoris.singularHomologyMap_one,
+    PeriodTorusHigherHomology.torusMatrixMap_coordinatePeriodHomology]
+  have h : Elliptic.HigherHomology.twistBasisMatrix j *ᵥ Fin.cons 0 ![0, 1, 0] = ![0, 0, 1, 0] := by
+    cases j <;> decide
+  rw [h]
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassOne_coordinates
+    (j : Elliptic.Kind) :
+    PeriodFamily.FlatTorus.singularH1Equiv (splitCircleClassOne j) = j.twist := by
+  apply splitOne_originalCoordinates_mo1973_27797
+  rw [splitCircleClassOne, splitFlat_inverse_circle_homology, splitOne_unsplit_circle,
+    SingularMayerVietoris.singularHomologyMap_one,
+    PeriodTorusHigherHomology.torusMatrixMap_coordinatePeriodHomology]
+  have h : Elliptic.HigherHomology.twistBasisMatrix j *ᵥ Pi.single 0 1 = j.twist := by
+    cases j <;> decide
+  rw [h]
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreInputTwo_product :
+    splitFibreInputTwo =
+      PeriodTorusHigherHomologyPontryagin.product11 (PeriodTorusHigherHomology.ProductTorus 3)
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 3 (Pi.single 0 1)))
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 3 (Pi.single 1 1))) := by
+  have hv : (![1, 0, 0] : Fin 3 → ℤ) = Pi.single 0 1 := by decide
+  rw [splitFibreInputTwo, hv, Elliptic.HigherHomology.torusH2Coordinates_symm_basis]
+  rfl
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitTwo_fibre_unsplit :
+    SingularMayerVietoris.singularHomologyMap
+        ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 3).symm :
+          C(PeriodTorusHigherHomology.CircleTopology.Circle ×
+              PeriodTorusHigherHomology.ProductTorus 3,
+            PeriodTorusHigherHomology.ProductTorus 4))
+        2
+        (PeriodTorusHigherHomology.circleSectionHomology
+          (PeriodTorusHigherHomology.ProductTorus 3) 2 splitFibreInputTwo) =
+      PeriodTorusHigherHomologyPontryagin.product11 (PeriodTorusHigherHomology.ProductTorus 4)
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 4 (Pi.single 1 1)))
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 4 (Pi.single 2 1))) := by
+  rw [PeriodTorusHigherHomology.circleSectionHomology, ← LinearMap.comp_apply, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+  change
+    SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusTailMap 3) 2
+        splitFibreInputTwo =
+      _
+  rw [splitFibreInputTwo_product]
+  change
+    SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusTailMap 3) 2
+        (PeriodTorusHigherHomologyPontryagin.product (PeriodTorusHigherHomology.ProductTorus 3) 1
+          _ _) =
+      PeriodTorusHigherHomologyPontryagin.product (PeriodTorusHigherHomology.ProductTorus 4) 1 _ _
+  rw [PeriodTorusHigherHomologyPontryagin.product_natural
+      (PeriodTorusHigherHomology.torusTailMap 3) (PeriodTorusHigherHomology.torusTailMap_add 3) 1,
+    PeriodTorusHigherHomology.torusTailMap_coordinatePeriodHomology,
+    PeriodTorusHigherHomology.torusTailMap_coordinatePeriodHomology]
+  have hu : (Fin.cons 0 (Pi.single (0 : Fin 3) 1) : Lattice) = Pi.single 1 1 := by decide
+  have hw : (Fin.cons 0 (Pi.single (1 : Fin 3) 1) : Lattice) = Pi.single 2 1 := by decide
+  rw [hu, hw]
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitTwo_circle_unsplit :
+    SingularMayerVietoris.singularHomologyMap
+        ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 3).symm :
+          C(PeriodTorusHigherHomology.CircleTopology.Circle ×
+              PeriodTorusHigherHomology.ProductTorus 3,
+            PeriodTorusHigherHomology.ProductTorus 4))
+        2
+        (PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 3)
+          1 splitFibreInputOne) =
+      PeriodTorusHigherHomologyPontryagin.product11 (PeriodTorusHigherHomology.ProductTorus 4)
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 4 (Pi.single 0 1)))
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 4 (Pi.single 2 1))) := by
+  rw [PeriodTorusHigherHomology.torusSplit_positiveCircleCross,
+    PeriodTorusHigherHomology.torusHeadCircleMap_positiveHomology, splitFibreInputOne,
+    Elliptic.HigherHomology.torusH1Equiv_symm_apply_loop,
+    PeriodTorusHigherHomology.torusTailMap_coordinatePeriodHomology]
+  have hw : (Fin.cons 0 ![0, 1, 0] : Lattice) = Pi.single 2 1 := by decide
+  rw [hw]
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitTwo_fibre_unsplit_coordinates :
+    PeriodTorusHigherHomology.coordinateTorusH2Coordinates
+        (SingularMayerVietoris.singularHomologyMap
+          ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 3).symm :
+            C(PeriodTorusHigherHomology.CircleTopology.Circle ×
+                PeriodTorusHigherHomology.ProductTorus 3,
+              PeriodTorusHigherHomology.ProductTorus 4))
+          2
+          (PeriodTorusHigherHomology.circleSectionHomology
+            (PeriodTorusHigherHomology.ProductTorus 3) 2 splitFibreInputTwo)) =
+      Pi.single 3 1 := by
+  rw [splitTwo_fibre_unsplit]
+  exact PeriodTorusCohomologyCup.coordinateTorusH2Coordinates_basis_pair 3
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitTwo_circle_unsplit_coordinates :
+    PeriodTorusHigherHomology.coordinateTorusH2Coordinates
+        (SingularMayerVietoris.singularHomologyMap
+          ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 3).symm :
+            C(PeriodTorusHigherHomology.CircleTopology.Circle ×
+                PeriodTorusHigherHomology.ProductTorus 3,
+              PeriodTorusHigherHomology.ProductTorus 4))
+          2
+          (PeriodTorusHigherHomology.positiveCircleCross
+            (PeriodTorusHigherHomology.ProductTorus 3) 1 splitFibreInputOne)) =
+      Pi.single 1 1 := by
+  rw [splitTwo_circle_unsplit]
+  exact PeriodTorusCohomologyCup.coordinateTorusH2Coordinates_basis_pair 1
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitFlat_inverse_h2_coordinates
+    (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (PeriodTorusHigherHomology.CircleTopology.Circle ×
+          PeriodTorusHigherHomology.ProductTorus 3)
+        2) :
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        (SingularMayerVietoris.singularHomologyMap
+          ((Elliptic.HigherHomology.splitFlatTorusHomeomorph j).symm :
+            C(PeriodTorusHigherHomology.CircleTopology.Circle ×
+                PeriodTorusHigherHomology.ProductTorus 3,
+              RealTorus₄))
+          2 a) =
+      LocalSystemMatrices.exteriorSquare (Elliptic.HigherHomology.twistBasisMatrix j) *ᵥ
+        PeriodTorusHigherHomology.coordinateTorusH2Coordinates
+          (SingularMayerVietoris.singularHomologyMap
+            ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 3).symm :
+              C(PeriodTorusHigherHomology.CircleTopology.Circle ×
+                  PeriodTorusHigherHomology.ProductTorus 3,
+                PeriodTorusHigherHomology.ProductTorus 4))
+            2 a) := by
+  rw [PeriodFamily.FlatTorus.singularH2Coordinates_apply,
+    PeriodFamily.FlatTorus.singularH2Equiv_apply, splitFlat_inverse_circle_homology]
+  exact
+    PeriodTorusHigherHomology.coordinateTorusH2Coordinates_matrix
+      (Elliptic.HigherHomology.twistBasisMatrix j) _
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreClassTwo_coordinates
+    (j : Elliptic.Kind) :
+    PeriodFamily.FlatTorus.singularH2Coordinates (splitFibreClassTwo j) = ![0, 0, 0, 1, 0, 0] := by
+  rw [splitFibreClassTwo, splitFlat_inverse_h2_coordinates, splitTwo_fibre_unsplit_coordinates]
+  cases j <;> decide
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassTwo_coordinates
+    (j : Elliptic.Kind) :
+    PeriodFamily.FlatTorus.singularH2Coordinates (splitCircleClassTwo j) =
+      ![0, j.twist 0, 0, j.twist 1, 0, 0] := by
+  rw [splitCircleClassTwo, splitFlat_inverse_h2_coordinates, splitTwo_circle_unsplit_coordinates]
+  cases j <;> decide
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalAffineNorm_splitFibreClassOne
+    (j : Elliptic.Kind) :
+    PeriodFamily.FlatTorus.singularH1Equiv (originalAffineNorm j 1 (splitFibreClassOne j)) =
+      (Elliptic.HigherHomology.fibreNormIndex j : ℤ) • (![0, 0, 0, 1] : Lattice) := by
+  rw [originalAffineNorm_h1_coordinates, splitFibreClassOne_coordinates]
+  cases j
+  · rw [originalNormMatrixOne_three]
+    decide
+  · rw [originalNormMatrixOne_four]
+    decide
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalAffineNorm_splitCircleClassOne
+    (j : Elliptic.Kind) :
+    PeriodFamily.FlatTorus.singularH1Equiv (originalAffineNorm j 1 (splitCircleClassOne j)) =
+      (j.order : ℤ) • j.twist := by
+  rw [originalAffineNorm_h1_coordinates, splitCircleClassOne_coordinates]
+  cases j
+  · rw [originalNormMatrixOne_three]
+    decide
+  · rw [originalNormMatrixOne_four]
+    decide
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalAffineNorm_splitFibreClassTwo
+    (j : Elliptic.Kind) :
+    PeriodFamily.FlatTorus.singularH2Coordinates (originalAffineNorm j 2 (splitFibreClassTwo j)) =
+      (Elliptic.HigherHomology.fibreNormIndex j : ℤ) •
+        ![0, 0, 0, Elliptic.HigherHomology.fibreSquareKernelVector j 0,
+          Elliptic.HigherHomology.fibreSquareKernelVector j 1,
+          Elliptic.HigherHomology.fibreSquareKernelVector j 2] := by
+  rw [originalAffineNorm_h2_coordinates, splitFibreClassTwo_coordinates]
+  cases j
+  · rw [originalNormMatrixTwo_three]
+    decide
+  · rw [originalNormMatrixTwo_four]
+    decide
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalAffineNorm_splitCircleClassTwo
+    (j : Elliptic.Kind) :
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        (originalAffineNorm j 2 (splitCircleClassTwo j)) =
+      (Elliptic.HigherHomology.fibreNormIndex j : ℤ) •
+        ![0, 0, j.twist 0, 0, j.twist 1, j.twist 2] := by
+  rw [originalAffineNorm_h2_coordinates, splitCircleClassTwo_coordinates]
+  cases j
+  · rw [originalNormMatrixTwo_three]
+    decide
+  · rw [originalNormMatrixTwo_four]
+    decide
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.deltaVector : Lattice :=
+  ![0, 0, 0, 1]
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.twist_fourth_zero (j : Elliptic.Kind) :
+    j.twist 3 = 0 := by cases j <;> rfl
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearOne_correction_divisible
+    (j : Elliptic.Kind) :
+    (j.order : ℤ) ∣ (Elliptic.HigherHomology.fibreNormIndex j : ℤ) * sourceShearOne j := by
+  let a :=
+    (Elliptic.HigherHomology.surfaceH1Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).symm
+      ![0, 1]
+  have he :
+    Elliptic.HigherHomology.surfaceH1Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a =
+      ![0, 1] :=
+    LinearEquiv.apply_symm_apply _ _
+  have h := h1Coordinates_cover_columns j a
+  rw [originalAffineNorm_splitFibreClassOne, originalAffineNorm_splitCircleClassOne] at h
+  have h₃ := congrFun h (3 : Fin 4)
+  change
+    (j.order : ℤ) * h1Coordinates j a 3 =
+      ((j.order : ℤ) *
+              (Elliptic.HigherHomology.surfaceH1Equiv j
+                  (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a)
+                0 -
+            sourceShearOne j *
+              (Elliptic.HigherHomology.surfaceH1Equiv j
+                  (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a)
+                1) *
+          ((Elliptic.HigherHomology.fibreNormIndex j : ℤ) * 1) +
+        (Elliptic.HigherHomology.surfaceH1Equiv j
+              (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a)
+            1 *
+          ((j.order : ℤ) * j.twist 3) at h₃
+  rw [he, twist_fourth_zero] at h₃
+  change
+    (j.order : ℤ) * h1Coordinates j a 3 =
+      ((j.order : ℤ) * 0 - sourceShearOne j * 1) *
+          ((Elliptic.HigherHomology.fibreNormIndex j : ℤ) * 1) +
+        1 * ((j.order : ℤ) * 0) at h₃
+  refine ⟨-h1Coordinates j a 3, ?_⟩
+  linear_combination h₃
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.h1ShearCorrection (j : Elliptic.Kind) : ℤ :=
+  ((Elliptic.HigherHomology.fibreNormIndex j : ℤ) * sourceShearOne j) / j.order
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.order_mul_h1ShearCorrection
+    (j : Elliptic.Kind) :
+    (j.order : ℤ) * h1ShearCorrection j =
+      (Elliptic.HigherHomology.fibreNormIndex j : ℤ) * sourceShearOne j := by
+  rw [mul_comm]
+  exact Int.ediv_mul_cancel (sourceShearOne_correction_divisible j)
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapKernelWang.h1Coordinates_formula (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) 1) :
+    h1Coordinates j a =
+      Elliptic.HigherHomology.surfaceH1Equiv j
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1 •
+          j.twist +
+        ((Elliptic.HigherHomology.fibreNormIndex j : ℤ) *
+              Elliptic.HigherHomology.surfaceH1Equiv j
+                (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 0 -
+            h1ShearCorrection j *
+              Elliptic.HigherHomology.surfaceH1Equiv j
+                (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1) •
+          deltaVector := by
+  have h := h1Coordinates_cover_columns j a
+  rw [originalAffineNorm_splitFibreClassOne, originalAffineNorm_splitCircleClassOne] at h
+  have hm : (j.order : ℤ) ≠ 0 := by exact_mod_cast j.order_pos.ne'
+  ext i
+  apply mul_left_cancel₀ hm
+  have hi := congrFun h i
+  change
+    (j.order : ℤ) * h1Coordinates j a i =
+      ((j.order : ℤ) *
+              Elliptic.HigherHomology.surfaceH1Equiv j
+                (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 0 -
+            sourceShearOne j *
+              Elliptic.HigherHomology.surfaceH1Equiv j
+                (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1) *
+          ((Elliptic.HigherHomology.fibreNormIndex j : ℤ) * deltaVector i) +
+        Elliptic.HigherHomology.surfaceH1Equiv j
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1 *
+          ((j.order : ℤ) * j.twist i) at hi
+  change
+    (j.order : ℤ) * h1Coordinates j a i =
+      (j.order : ℤ) *
+        (Elliptic.HigherHomology.surfaceH1Equiv j
+              (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1 *
+            j.twist i +
+          ((Elliptic.HigherHomology.fibreNormIndex j : ℤ) *
+                Elliptic.HigherHomology.surfaceH1Equiv j
+                  (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 0 -
+              h1ShearCorrection j *
+                Elliptic.HigherHomology.surfaceH1Equiv j
+                  (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1) *
+            deltaVector i)
+  rw [hi]
+  have hk := order_mul_h1ShearCorrection j
+  linear_combination
+    (Elliptic.HigherHomology.surfaceH1Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1 *
+        deltaVector i) *
+      hk
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.capKernel_wang_h1_coordinates
+    (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) 1) :
+    PeriodFamily.FlatTorus.singularH1Equiv
+        (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) 1
+          ((PeriodFamily.Boundary.EllipticCapProduct.boundaryCapKernelEquiv j 1).symm a).val) =
+      Elliptic.HigherHomology.surfaceH1Equiv j
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1 •
+          j.twist +
+        ((Elliptic.HigherHomology.fibreNormIndex j : ℤ) *
+              Elliptic.HigherHomology.surfaceH1Equiv j
+                (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 0 -
+            h1ShearCorrection j *
+              Elliptic.HigherHomology.surfaceH1Equiv j
+                (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1) •
+          deltaVector :=
+  h1Coordinates_formula j a
+
+private def
+    PeriodFamily.Boundary.EllipticCapKernelWang.fibreInvariantPairVector (j : Elliptic.Kind) :
+    Fin 6 → ℤ :=
+  ![0, 0, 0, Elliptic.HigherHomology.fibreSquareKernelVector j 0,
+    Elliptic.HigherHomology.fibreSquareKernelVector j 1,
+    Elliptic.HigherHomology.fibreSquareKernelVector j 2]
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.twistDeltaVector (j : Elliptic.Kind) :
+    Fin 6 → ℤ :=
+  ![0, 0, j.twist 0, 0, j.twist 1, j.twist 2]
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapKernelWang.h2Coordinates_formula (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) 2) :
+    h2Coordinates j a =
+      ((Elliptic.HigherHomology.fibreNormIndex j : ℤ) *
+              Elliptic.HigherHomology.surfaceH2Equiv j
+                (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 0 -
+            sourceShearTwo j *
+              Elliptic.HigherHomology.surfaceH2Equiv j
+                (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1) •
+          fibreInvariantPairVector j +
+        Elliptic.HigherHomology.surfaceH2Equiv j
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1 •
+          twistDeltaVector j := by
+  have h := h2Coordinates_cover_columns j a
+  rw [originalAffineNorm_splitFibreClassTwo, originalAffineNorm_splitCircleClassTwo] at h
+  ext i
+  apply mul_left_cancel₀ (Elliptic.HigherHomology.fibreNormIndex_int_ne_zero j)
+  have hi := congrFun h i
+  change
+    (Elliptic.HigherHomology.fibreNormIndex j : ℤ) * h2Coordinates j a i =
+      ((Elliptic.HigherHomology.fibreNormIndex j : ℤ) *
+              Elliptic.HigherHomology.surfaceH2Equiv j
+                (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 0 -
+            sourceShearTwo j *
+              Elliptic.HigherHomology.surfaceH2Equiv j
+                (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1) *
+          ((Elliptic.HigherHomology.fibreNormIndex j : ℤ) * fibreInvariantPairVector j i) +
+        Elliptic.HigherHomology.surfaceH2Equiv j
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1 *
+          ((Elliptic.HigherHomology.fibreNormIndex j : ℤ) * twistDeltaVector j i) at hi
+  change
+    (Elliptic.HigherHomology.fibreNormIndex j : ℤ) * h2Coordinates j a i =
+      (Elliptic.HigherHomology.fibreNormIndex j : ℤ) *
+        (((Elliptic.HigherHomology.fibreNormIndex j : ℤ) *
+                Elliptic.HigherHomology.surfaceH2Equiv j
+                  (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 0 -
+              sourceShearTwo j *
+                Elliptic.HigherHomology.surfaceH2Equiv j
+                  (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1) *
+            fibreInvariantPairVector j i +
+          Elliptic.HigherHomology.surfaceH2Equiv j
+              (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1 *
+            twistDeltaVector j i)
+  rw [hi]
+  ring
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.capKernel_wang_h2_coordinates
+    (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) 2) :
+    PeriodFamily.FlatTorus.singularH2Coordinates
+        (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) 2
+          ((PeriodFamily.Boundary.EllipticCapProduct.boundaryCapKernelEquiv j 2).symm a).val) =
+      ((Elliptic.HigherHomology.fibreNormIndex j : ℤ) *
+              Elliptic.HigherHomology.surfaceH2Equiv j
+                (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 0 -
+            sourceShearTwo j *
+              Elliptic.HigherHomology.surfaceH2Equiv j
+                (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1) •
+          fibreInvariantPairVector j +
+        Elliptic.HigherHomology.surfaceH2Equiv j
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1 •
+          twistDeltaVector j :=
+  h2Coordinates_formula j a
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.ranges_twist_zero_ne_zero_mo1973_28416
+    (j : Elliptic.Kind) : j.twist 0 ≠ 0 := by cases j <;> decide
+
+private theorem
+  PeriodFamily.Boundary.EllipticCapKernelWang.ranges_fibre_kernel_zero_ne_zero_mo1973_28420
+    (j : Elliptic.Kind) : Elliptic.HigherHomology.fibreSquareKernelVector j 0 ≠ 0 := by
+  cases j <;> decide
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.ranges_h2_two_mo1973_28421
+    (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) 2) :
+    h2Coordinates j a 2 =
+      Elliptic.HigherHomology.surfaceH2Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1 *
+        j.twist 0 := by
+  rw [h2Coordinates_formula]
+  simp [fibreInvariantPairVector, twistDeltaVector]
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.ranges_h2_three_mo1973_28422
+    (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) 2) :
+    h2Coordinates j a 3 =
+      ((Elliptic.HigherHomology.fibreNormIndex j : ℤ) *
+            Elliptic.HigherHomology.surfaceH2Equiv j
+              (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 0 -
+          sourceShearTwo j *
+            Elliptic.HigherHomology.surfaceH2Equiv j
+              (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1) *
+        Elliptic.HigherHomology.fibreSquareKernelVector j 0 := by
+  rw [h2Coordinates_formula]
+  simp [fibreInvariantPairVector, twistDeltaVector]
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapKernelWang.h2Coordinates_injective (j : Elliptic.Kind) :
+    Function.Injective (h2Coordinates j) := by
+  intro a b hab
+  let e :=
+    Elliptic.HigherHomology.surfaceH2Equiv j
+      (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+  have h₁ : e a 1 = e b 1 := by
+    apply mul_right_cancel₀ (ranges_twist_zero_ne_zero_mo1973_28416 j)
+    simpa only [ranges_h2_two_mo1973_28421] using congrFun hab (2 : Fin 6)
+  have hL := congrFun hab (3 : Fin 6)
+  rw [ranges_h2_three_mo1973_28422, ranges_h2_three_mo1973_28422] at hL
+  have hcoef := mul_right_cancel₀ (ranges_fibre_kernel_zero_ne_zero_mo1973_28420 j) hL
+  rw [h₁] at hcoef
+  have h₀ : e a 0 = e b 0 := by
+    apply mul_left_cancel₀ (Elliptic.HigherHomology.fibreNormIndex_int_ne_zero j)
+    linarith only [hcoef]
+  apply e.injective
+  funext i
+  fin_cases i
+  · exact h₀
+  · exact h₁
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.capKernelWang (j : Elliptic.Kind) (n : ℕ) :
+    LinearMap.ker
+        (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) (n + 1)) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology RealTorus₄ n
+    where
+  toFun a := MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) n a.val
+  map_add' a b := map_add _ a.val b.val
+  map_smul' k
+    a :=
+    (map_zsmul
+          ((MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist)
+                n).toAddMonoidHom.comp
+            (LinearMap.ker
+                (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j)
+                  (n + 1))).subtype.toAddMonoidHom)
+          k a).trans
+      (int_smul_eq_zsmul (SingularMayerVietoris.SingularHomology RealTorus₄ n).isModule k
+          (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) n a.val)).symm
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapKernelWang.capKernelWang_eq_cross (j : Elliptic.Kind)
+    (n : ℕ)
+    (a :
+      LinearMap.ker
+        (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) (n + 1))) :
+    capKernelWang j n a =
+      crossWang j n (PeriodFamily.Boundary.EllipticCapProduct.boundaryCapKernelEquiv j n a) := by
+  have h :=
+    (PeriodFamily.Boundary.EllipticCapProduct.boundaryCapKernelEquiv j n).symm_apply_apply a
+  have hv :=
+    congrArg
+      (fun b :
+          LinearMap.ker
+            (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) (n + 1)) =>
+        b.val)
+      h
+  change
+    PeriodFamily.Boundary.EllipticCapProduct.boundaryPositiveCircleCross j n
+        (PeriodFamily.Boundary.EllipticCapProduct.boundaryCapKernelEquiv j n a) =
+      a.val at hv
+  change
+    MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) n a.val =
+      MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) n
+        (PeriodFamily.Boundary.EllipticCapProduct.boundaryPositiveCircleCross j n
+          (PeriodFamily.Boundary.EllipticCapProduct.boundaryCapKernelEquiv j n a))
+  rw [hv]
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.capKernelWang_two_injective
+    (j : Elliptic.Kind) : Function.Injective (capKernelWang j 2) := by
+  intro a b hab
+  apply (PeriodFamily.Boundary.EllipticCapProduct.boundaryCapKernelEquiv j 2).injective
+  apply h2Coordinates_injective j
+  rw [h2Coordinates_apply, h2Coordinates_apply, ← capKernelWang_eq_cross, ←
+    capKernelWang_eq_cross, hab]
+
+private def PeriodFamily.CapKernelShear.shearOn (r : ℕ)
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus r,
+        (PeriodTorusHigherHomology.CircleTopology.Circle))) :
+    C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+        PeriodTorusHigherHomology.ProductTorus r,
+      (PeriodTorusHigherHomology.CircleTopology.Circle) ×
+        PeriodTorusHigherHomology.ProductTorus r) :=
+  ⟨fun p => (p.1 - χ p.2, p.2),
+    (continuous_fst.sub (χ.continuous.comp continuous_snd)).prodMk continuous_snd⟩
+
+private theorem PeriodFamily.CapKernelShear.circleTorus_homology_subsingleton_of_lt {r n : ℕ}
+    (h : r + 1 < n) :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus r)
+        n) := by
+  let := PeriodTorusHigherHomology.productTorus_homology_subsingleton_of_lt h
+  exact
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+        (PeriodTorusHigherHomology.productTorusSuccHomeomorph r).symm n).injective.subsingleton
+
+private def PeriodFamily.CapKernelShear.twoToFour_mo1973_28436 :
+    C(PeriodTorusHigherHomology.ProductTorus 2, PeriodTorusHigherHomology.ProductTorus 4) :=
+  (PeriodTorusHigherHomology.torusTailMap 3).comp (PeriodTorusHigherHomology.torusTailMap 2)
+
+private def PeriodFamily.CapKernelShear.fourToTwo_mo1973_28437 :
+    C(PeriodTorusHigherHomology.ProductTorus 4, PeriodTorusHigherHomology.ProductTorus 2) :=
+  ⟨fun x i => x i.succ.succ, continuous_pi fun i => continuous_apply i.succ.succ⟩
+
+private theorem PeriodFamily.CapKernelShear.fourToTwo_twoToFour_mo1973_28438
+    (x : PeriodTorusHigherHomology.ProductTorus 2) :
+    fourToTwo_mo1973_28437 (twoToFour_mo1973_28436 x) = x := by
+  funext i
+  rfl
+
+private theorem PeriodFamily.CapKernelShear.circleProduct_retract_mo1973_28439 :
+    (PeriodTorusHigherHomology.circleProductMap fourToTwo_mo1973_28437).comp
+        (PeriodTorusHigherHomology.circleProductMap twoToFour_mo1973_28436) =
+      ContinuousMap.id
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 2) := by
+  apply ContinuousMap.ext
+  intro p
+  exact Prod.ext rfl (fourToTwo_twoToFour_mo1973_28438 p.2)
+
+private theorem
+  PeriodFamily.CapKernelShear.circleProduct_twoToFour_homology_injective_mo1973_28440 (n : ℕ) :
+    Function.Injective
+      (SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.circleProductMap twoToFour_mo1973_28436) n) := by
+  have h :
+    Function.LeftInverse
+      (SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.circleProductMap fourToTwo_mo1973_28437) n)
+      (SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.circleProductMap twoToFour_mo1973_28436) n) := by
+    intro a
+    change
+      ((SingularMayerVietoris.singularHomologyMap
+                (PeriodTorusHigherHomology.circleProductMap fourToTwo_mo1973_28437) n).comp
+            (SingularMayerVietoris.singularHomologyMap
+              (PeriodTorusHigherHomology.circleProductMap twoToFour_mo1973_28436) n))
+          a =
+        a
+    rw [← PeriodTorusHigherHomology.singularHomologyMap_comp, circleProduct_retract_mo1973_28439,
+      PeriodTorusHigherHomology.singularHomologyMap_id, LinearMap.id_apply]
+  exact h.injective
+
+private theorem PeriodFamily.CapKernelShear.positiveCircleCross_two_surjective_mo1973_28441 :
+    Function.Surjective
+      (PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 2)
+        2) := by
+  let := PeriodTorusHigherHomology.productTorus_homology_subsingleton_of_lt (show 2 < 3 by decide)
+  intro a
+  obtain ⟨b, rfl⟩ :=
+    (PeriodTorusHigherHomology.circleProductHomologyEquiv
+          (PeriodTorusHigherHomology.ProductTorus 2) 2).symm.surjective
+      a
+  refine ⟨b.2, ?_⟩
+  rw [PeriodTorusHigherHomology.circleProductHomologyEquiv_symm_eq_section_add_cross,
+    (Subsingleton.elim b.1 0), map_zero, zero_add]
+
+private theorem PeriodFamily.CapKernelShear.twoToFour_shear_mo1973_28442
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 2,
+        (PeriodTorusHigherHomology.CircleTopology.Circle))) :
+    (PeriodTorusHigherHomology.circleProductMap twoToFour_mo1973_28436).comp (shearOn 2 χ) =
+      (shear (χ.comp fourToTwo_mo1973_28437)).comp
+        (PeriodTorusHigherHomology.circleProductMap twoToFour_mo1973_28436) := by
+  apply ContinuousMap.ext
+  rintro ⟨c, x⟩
+  change
+    (c - χ x, twoToFour_mo1973_28436 x) =
+      (c - χ (fourToTwo_mo1973_28437 (twoToFour_mo1973_28436 x)), twoToFour_mo1973_28436 x)
+  rw [fourToTwo_twoToFour_mo1973_28438]
+
+private theorem PeriodFamily.CapKernelShear.shearOn_two_positiveCircleCross_mo1973_28443
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 2,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y)
+    (b : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 2) 2) :
+    SingularMayerVietoris.singularHomologyMap (shearOn 2 χ) 3
+        (PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 2)
+          2 b) =
+      PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 2) 2
+        b := by
+  apply circleProduct_twoToFour_homology_injective_mo1973_28440 3
+  change
+    ((SingularMayerVietoris.singularHomologyMap
+              (PeriodTorusHigherHomology.circleProductMap twoToFour_mo1973_28436) 3).comp
+          (SingularMayerVietoris.singularHomologyMap (shearOn 2 χ) 3))
+        (PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 2)
+          2 b) =
+      _
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp, twoToFour_shear_mo1973_28442,
+    PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply,
+    PeriodTorusHigherHomology.positiveCircleCross_naturality]
+  apply shear_positiveCircleCross_two (χ.comp fourToTwo_mo1973_28437)
+  intro x y
+  change
+    χ (fourToTwo_mo1973_28437 x + fourToTwo_mo1973_28437 y) =
+      χ (fourToTwo_mo1973_28437 x) + χ (fourToTwo_mo1973_28437 y)
+  exact hχ _ _
+
+private theorem PeriodFamily.CapKernelShear.shearOn_two_homologyThree
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 2,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 2)
+        3) :
+    SingularMayerVietoris.singularHomologyMap (shearOn 2 χ) 3 a = a := by
+  obtain ⟨b, rfl⟩ := positiveCircleCross_two_surjective_mo1973_28441 a
+  exact shearOn_two_positiveCircleCross_mo1973_28443 χ hχ b
+
+private def PeriodFamily.CapKernelShear.threeSwapCoordinates :
+    ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+        PeriodTorusHigherHomology.ProductTorus 3) ≃ₜ
+      ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 2))
+    where
+  toFun p := (p.2 0, (p.1, fun i => p.2 i.succ))
+  invFun p := (p.2.1, Fin.cons p.1 p.2.2)
+  left_inv
+    p := by
+    apply Prod.ext
+    · rfl
+    · exact Fin.cons_self_tail p.2
+  right_inv p := rfl
+  continuous_toFun :=
+    ((continuous_apply 0).comp continuous_snd).prodMk
+      (continuous_fst.prodMk
+        (continuous_pi fun i => (continuous_apply i.succ).comp continuous_snd))
+  continuous_invFun :=
+    (continuous_fst.comp continuous_snd).prodMk
+      ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 2).symm.continuous.comp
+        (continuous_fst.prodMk (continuous_snd.comp continuous_snd)))
+
+private def PeriodFamily.CapKernelShear.threeHeadMap
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 3,
+        (PeriodTorusHigherHomology.CircleTopology.Circle))) :
+    C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 2),
+      (PeriodTorusHigherHomology.CircleTopology.Circle) ×
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 2)) :=
+  (threeSwapCoordinates : C(_, _)).comp ((shearOn 3 χ).comp (threeSwapCoordinates.symm : C(_, _)))
+
+private theorem PeriodFamily.CapKernelShear.threeHeadMap_fst
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 3,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (p :
+      (PeriodTorusHigherHomology.CircleTopology.Circle) ×
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 2)) :
+    (threeHeadMap χ p).1 = p.1 :=
+  rfl
+
+private theorem PeriodFamily.CapKernelShear.threeSwapCoordinates_shear
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 3,
+        (PeriodTorusHigherHomology.CircleTopology.Circle))) :
+    (threeSwapCoordinates : C(_, _)).comp (shearOn 3 χ) =
+      (threeHeadMap χ).comp (threeSwapCoordinates : C(_, _)) := by
+  apply ContinuousMap.ext
+  intro p
+  change
+    threeSwapCoordinates (shearOn 3 χ p) =
+      threeSwapCoordinates (shearOn 3 χ (threeSwapCoordinates.symm (threeSwapCoordinates p)))
+  rw [Homeomorph.symm_apply_apply]
+
+private def PeriodFamily.CapKernelShear.threeTailCharacter
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 3,
+        (PeriodTorusHigherHomology.CircleTopology.Circle))) :
+    C(PeriodTorusHigherHomology.ProductTorus 2,
+      (PeriodTorusHigherHomology.CircleTopology.Circle)) :=
+  χ.comp (PeriodTorusHigherHomology.torusTailMap 2)
+
+private theorem PeriodFamily.CapKernelShear.threeTailCharacter_add
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 3,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y) (x y : PeriodTorusHigherHomology.ProductTorus 2) :
+    threeTailCharacter χ (x + y) = threeTailCharacter χ x + threeTailCharacter χ y := by
+  change
+    χ (PeriodTorusHigherHomology.torusTailMap 2 (x + y)) =
+      χ (PeriodTorusHigherHomology.torusTailMap 2 x) +
+        χ (PeriodTorusHigherHomology.torusTailMap 2 y)
+  rw [PeriodTorusHigherHomology.torusTailMap_add, hχ]
+
+private theorem PeriodFamily.CapKernelShear.threeCharacter_split
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 3,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y) (t : (PeriodTorusHigherHomology.CircleTopology.Circle))
+    (y : PeriodTorusHigherHomology.ProductTorus 2) :
+    χ (Fin.cons t y) =
+      χ (PeriodTorusHigherHomology.torusHeadCircleMap 2 t) + threeTailCharacter χ y := by
+  have h :
+    (Fin.cons t y : PeriodTorusHigherHomology.ProductTorus 3) =
+      PeriodTorusHigherHomology.torusHeadCircleMap 2 t +
+        PeriodTorusHigherHomology.torusTailMap 2 y := by
+    rw [PeriodTorusHigherHomology.torusHeadCircleMap_apply,
+      PeriodTorusHigherHomology.torusTailMap_apply]
+    funext i
+    refine Fin.cases ?_ (fun j => ?_) i <;> simp
+  rw [h, hχ]
+  rfl
+
+private theorem PeriodFamily.CapKernelShear.threeHeadMap_fibre
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 3,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y) (t : (PeriodTorusHigherHomology.CircleTopology.Circle)) :
+    PeriodFamily.Homology.headMapFibre (threeHeadMap χ) t =
+      (PeriodTorusHigherHomology.rightTranslation
+            (-χ (PeriodTorusHigherHomology.torusHeadCircleMap 2 t),
+              (0 : PeriodTorusHigherHomology.ProductTorus 2))).comp
+        (shearOn 2 (threeTailCharacter χ)) := by
+  apply ContinuousMap.ext
+  rintro ⟨c, y⟩
+  apply Prod.ext
+  · change
+      c - χ (Fin.cons t y) =
+        (c - threeTailCharacter χ y) + -χ (PeriodTorusHigherHomology.torusHeadCircleMap 2 t)
+    rw [threeCharacter_split χ hχ]
+    abel
+  · change y = y + 0
+    exact (add_zero y).symm
+
+private theorem PeriodFamily.CapKernelShear.threeHeadBoundary_injective :
+    Function.Injective
+      (PeriodTorusHigherHomology.circleBoundary
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 2)
+        3) := by
+  let := circleTorus_homology_subsingleton_of_lt (r := 2) (n := 4) (by decide)
+  intro a b hab
+  apply
+    (PeriodTorusHigherHomology.circleProductHomologyEquiv
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 2)
+        3).injective
+  apply Prod.ext
+  · exact Subsingleton.elim _ _
+  · exact hab
+
+private theorem PeriodFamily.CapKernelShear.threeHeadMap_fibre_homologyThree
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 3,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y) (t : (PeriodTorusHigherHomology.CircleTopology.Circle))
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 2)
+        3) :
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodFamily.Homology.headMapFibre (threeHeadMap χ) t) 3 a =
+      a := by
+  rw [threeHeadMap_fibre χ hχ, PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodTorusHigherHomology.rightTranslation_singularHomologyMap, LinearMap.id_comp]
+  exact shearOn_two_homologyThree (threeTailCharacter χ) (threeTailCharacter_add χ hχ) a
+
+private theorem PeriodFamily.CapKernelShear.threeHeadMap_homologyFour
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 3,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+            PeriodTorusHigherHomology.ProductTorus 2))
+        4) :
+    SingularMayerVietoris.singularHomologyMap (threeHeadMap χ) 4 a = a := by
+  apply threeHeadBoundary_injective
+  rw [PeriodFamily.Homology.circleBoundary_headMap (threeHeadMap χ) (threeHeadMap_fst χ) 3 a]
+  exact
+    threeHeadMap_fibre_homologyThree χ hχ PeriodTorusHigherHomology.CirclePaths.quarterPoint
+      (PeriodTorusHigherHomology.circleBoundary
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 2)
+        3 a)
+
+private theorem PeriodFamily.CapKernelShear.shearOn_three_homologyFour
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 3,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 3)
+        4) :
+    SingularMayerVietoris.singularHomologyMap (shearOn 3 χ) 4 a = a := by
+  apply (PeriodTorusHigherHomology.homeomorphHomologyEquiv threeSwapCoordinates 4).injective
+  simp only [PeriodTorusHigherHomology.homeomorphHomologyEquiv_apply]
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    threeSwapCoordinates_shear, PeriodTorusHigherHomology.singularHomologyMap_comp,
+    LinearMap.comp_apply]
+  exact threeHeadMap_homologyFour χ hχ _
+
+private theorem PeriodFamily.CapKernelShear.shear_comp_threeSubtorus
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 4,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (f : C(PeriodTorusHigherHomology.ProductTorus 3, PeriodTorusHigherHomology.ProductTorus 4)) :
+    (shear χ).comp (PeriodTorusHigherHomology.circleProductMap f) =
+      (PeriodTorusHigherHomology.circleProductMap f).comp (shearOn 3 (χ.comp f)) := by
+  apply ContinuousMap.ext
+  intro x
+  rfl
+
+private theorem PeriodFamily.CapKernelShear.shear_positiveCircleCross_three_map
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 4,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y)
+    (f : C(PeriodTorusHigherHomology.ProductTorus 3, PeriodTorusHigherHomology.ProductTorus 4))
+    (hf : ∀ x y, f (x + y) = f x + f y)
+    (b : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3) :
+    SingularMayerVietoris.singularHomologyMap (shear χ) 4
+        (PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 4)
+          3 (SingularMayerVietoris.singularHomologyMap f 3 b)) =
+      PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 4) 3
+        (SingularMayerVietoris.singularHomologyMap f 3 b) := by
+  have hχf : ∀ x y, (χ.comp f) (x + y) = (χ.comp f) x + (χ.comp f) y := by
+    intro x y
+    change χ (f (x + y)) = χ (f x) + χ (f y)
+    rw [hf, hχ]
+  have hnat := PeriodTorusHigherHomology.positiveCircleCross_naturality f 3 b
+  calc
+    SingularMayerVietoris.singularHomologyMap (shear χ) 4
+          (PeriodTorusHigherHomology.positiveCircleCross
+            (PeriodTorusHigherHomology.ProductTorus 4) 3
+            (SingularMayerVietoris.singularHomologyMap f 3 b)) =
+        SingularMayerVietoris.singularHomologyMap (shear χ) 4
+          (SingularMayerVietoris.singularHomologyMap
+            (PeriodTorusHigherHomology.circleProductMap f) 4
+            (PeriodTorusHigherHomology.positiveCircleCross
+              (PeriodTorusHigherHomology.ProductTorus 3) 3 b)) :=
+      congrArg (SingularMayerVietoris.singularHomologyMap (shear χ) 4) hnat.symm
+    _ =
+        SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.circleProductMap f) 4
+          (SingularMayerVietoris.singularHomologyMap (shearOn 3 (χ.comp f)) 4
+            (PeriodTorusHigherHomology.positiveCircleCross
+              (PeriodTorusHigherHomology.ProductTorus 3) 3 b)) := by
+      rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+        shear_comp_threeSubtorus, PeriodTorusHigherHomology.singularHomologyMap_comp,
+        LinearMap.comp_apply]
+    _ =
+        SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.circleProductMap f) 4
+          (PeriodTorusHigherHomology.positiveCircleCross
+            (PeriodTorusHigherHomology.ProductTorus 3) 3 b) :=
+      (congrArg
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.circleProductMap f)
+          4)
+        (shearOn_three_homologyFour (χ.comp f) hχf
+          (PeriodTorusHigherHomology.positiveCircleCross
+            (PeriodTorusHigherHomology.ProductTorus 3) 3 b)))
+    _ =
+        PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 4) 3
+          (SingularMayerVietoris.singularHomologyMap f 3 b) :=
+      hnat
+
+private theorem PeriodFamily.CapKernelShear.shear_positiveCircleCross_three
+    (χ :
+      C(PeriodTorusHigherHomology.ProductTorus 4,
+        (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y)
+    (b : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 3) :
+    SingularMayerVietoris.singularHomologyMap (shear χ) 4
+        (PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 4)
+          3 b) =
+      PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 4) 3
+        b := by
+  have h :
+    (SingularMayerVietoris.singularHomologyMap (shear χ) 4).comp
+        (PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 4)
+          3) =
+      PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 4)
+        3 := by
+    apply (PeriodTorusHigherHomology.coordinateTorusBasis 4 3).ext
+    intro i
+    simp only [LinearMap.comp_apply, PeriodTorusHigherHomology.coordinateTorusBasis_apply,
+      PeriodTorusHigherHomology.coordinateTorusClass]
+    exact
+      shear_positiveCircleCross_three_map χ hχ
+        (PeriodTorusHigherHomology.coordinateTorusMap 4 3 i)
+        (PeriodTorusHigherHomology.coordinateTorusMap_add 4 3 i)
+        (PeriodTorusHigherHomology.productTorusTopClass 3)
+  exact LinearMap.congr_fun h b
+
+private theorem PeriodFamily.CapKernelShear.realShear_positiveCircleCross_three
+    (χ : C(RealTorus₄, (PeriodTorusHigherHomology.CircleTopology.Circle)))
+    (hχ : ∀ x y, χ (x + y) = χ x + χ y)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 3) :
+    SingularMayerVietoris.singularHomologyMap (realShear χ) 4
+        (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ 3 a) =
+      PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ 3 a := by
+  apply (PeriodTorusHigherHomology.homeomorphHomologyEquiv realCircleCoordinates 4).injective
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.circleProductMap
+          (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+            C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4)))
+        4
+        (SingularMayerVietoris.singularHomologyMap (realShear χ) 4
+          (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ 3 a)) =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.circleProductMap
+          (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+            C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4)))
+        4 (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ 3 a)
+  simp only [realShear_coordinate_homology,
+    PeriodTorusHigherHomology.positiveCircleCross_naturality]
+  exact
+    shear_positiveCircleCross_three (coordinateCharacter χ) (coordinateCharacter_add χ hχ)
+      (SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+          C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+        3 a)
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.nativeShear_positiveCircleCross_three
+    (j : Elliptic.Kind) (a : SingularMayerVietoris.SingularHomology RealTorus₄ 3) :
+    SingularMayerVietoris.singularHomologyMap (nativeShear j) 4
+        (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ 3 a) =
+      PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ 3 a := by
+  rw [nativeShear_eq_realShear]
+  exact
+    PeriodFamily.CapKernelShear.realShear_positiveCircleCross_three (twistCircleCharacter j)
+      (twistCircleCharacter_add j) a
+
+private def
+    PeriodFamily.Boundary.EllipticCapKernelWang.originalNormMatrixThree (j : Elliptic.Kind) :
+    LatticeMatrix :=
+  ∑ k ∈ Finset.range j.order, (LocalSystemMatrices.exteriorCube j.matrix) ^ k
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalAffine_h3_coordinates
+    (j : Elliptic.Kind) (a : SingularMayerVietoris.SingularHomology RealTorus₄ 3) :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (MappingTorusHomology.monodromyHomologyMap (Elliptic.flatTorusAffine j j.twist) 3 a) =
+      LocalSystemMatrices.exteriorCube j.matrix *ᵥ
+        PeriodFamily.FlatTorus.singularH3Coordinates a := by
+  rw [MappingTorusHomology.monodromyHomologyMap,
+    PeriodFamily.Boundary.flatTorusAffine_homology_triangle]
+  change
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (SingularMayerVietoris.singularHomologyMap
+          (SpecialPeriods.triangleTorusHomeomorph (SpecialPeriods.Triangle.ellipticGenerator j) :
+            C(RealTorus₄, RealTorus₄))
+          3 a) =
+      _
+  rw [PeriodFamily.FlatTorus.singularH3Coordinates_inducedHomology_triangle,
+    SpecialPeriods.EllipticFilling.ellipticGenerator_dual_matrix]
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalAffine_pow_h3_coordinates
+    (j : Elliptic.Kind) (k : ℕ) (a : SingularMayerVietoris.SingularHomology RealTorus₄ 3) :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        ((MappingTorusHomology.monodromyHomologyMap (Elliptic.flatTorusAffine j j.twist) 3 ^ k)
+          a) =
+      (LocalSystemMatrices.exteriorCube j.matrix) ^ k *ᵥ
+        PeriodFamily.FlatTorus.singularH3Coordinates a := by
+  induction k with
+  | zero => simp only [pow_zero, Module.End.one_apply, Matrix.one_mulVec]
+  | succ k ih =>
+    rw [pow_succ', Module.End.mul_apply, originalAffine_h3_coordinates, ih, Matrix.mulVec_mulVec,
+      ← pow_succ']
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalAffineNorm_h3_coordinates
+    (j : Elliptic.Kind) (a : SingularMayerVietoris.SingularHomology RealTorus₄ 3) :
+    PeriodFamily.FlatTorus.singularH3Coordinates (originalAffineNorm j 3 a) =
+      originalNormMatrixThree j *ᵥ PeriodFamily.FlatTorus.singularH3Coordinates a := by
+  rw [originalAffineNorm_sum_powers, LinearMap.sum_apply, map_sum]
+  simp only [originalAffine_pow_h3_coordinates]
+  exact (Matrix.sum_mulVec _ _ _).symm
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalNormMatrixThree_three :
+    originalNormMatrixThree .three = !![3, 0, 0, 0; -1, 0, 0, 0; 2, 0, 0, 0; 0, -12, -6, 3] := by
+  change (∑ k ∈ Finset.range 3, PeriodTorusHigherHomologyExterior.cubeA₁ ^ k) = _
+  rw [PeriodTorusHigherHomologyExterior.cubeA₁_eq]
+  decide
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalNormMatrixThree_four :
+    originalNormMatrixThree .four = !![4, 0, 0, 0; -2, 0, 0, 0; 2, 0, 0, 0; 0, -12, -12, 4] := by
+  change (∑ k ∈ Finset.range 4, PeriodTorusHigherHomologyExterior.cubeA₂ ^ k) = _
+  rw [PeriodTorusHigherHomologyExterior.cubeA₂_eq]
+  decide
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.crossWang_surfaceCover_three
+    (j : Elliptic.Kind) (a : SingularMayerVietoris.SingularHomology RealTorus₄ 3) :
+    crossWang j 3 (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 3 a) =
+      originalAffineNorm j 3 a :=
+  crossWang_surfaceCover_of_shear j 3 a (nativeShear_positiveCircleCross_three j a)
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.h3Coordinates (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology
+        (ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface j) 3 →ₗ[ℤ]
+      Lattice :=
+  PeriodFamily.FlatTorus.singularH3Coordinates.toLinearMap.comp (crossWang j 3)
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.h3Coordinates_apply (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface j) 3) :
+    h3Coordinates j a = PeriodFamily.FlatTorus.singularH3Coordinates (crossWang j 3 a) :=
+  rfl
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapKernelWang.h3Coordinates_surfaceCover (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 3) :
+    h3Coordinates j (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 3 a) =
+      PeriodFamily.FlatTorus.singularH3Coordinates (originalAffineNorm j 3 a) := by
+  rw [h3Coordinates_apply, crossWang_surfaceCover_three]
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreInputThree :
+    SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3 :=
+  Elliptic.HigherHomology.torusH3Coordinates.symm 1
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreInputThree_coordinates :
+    Elliptic.HigherHomology.torusH3Coordinates splitFibreInputThree = 1 :=
+  Elliptic.HigherHomology.torusH3Coordinates.apply_symm_apply 1
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreInputThree_product :
+    splitFibreInputThree =
+      PeriodTorusHigherHomologyPontryagin.tripleProduct (PeriodTorusHigherHomology.ProductTorus 3)
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 3 (Pi.single 0 1)))
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 3 (Pi.single 1 1)))
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 3 (Pi.single 2 1))) :=
+  Elliptic.HigherHomology.torusH3Coordinates_symm_one
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreClassThree (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology RealTorus₄ 3 :=
+  SingularMayerVietoris.singularHomologyMap
+    ((Elliptic.HigherHomology.splitFlatTorusHomeomorph j).symm :
+      C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 3,
+        RealTorus₄))
+    3
+    (PeriodTorusHigherHomology.circleSectionHomology (PeriodTorusHigherHomology.ProductTorus 3) 3
+      splitFibreInputThree)
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassThree (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology RealTorus₄ 3 :=
+  SingularMayerVietoris.singularHomologyMap
+    ((Elliptic.HigherHomology.splitFlatTorusHomeomorph j).symm :
+      C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 3,
+        RealTorus₄))
+    3
+    (PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 3) 2
+      splitFibreInputTwo)
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearThree (j : Elliptic.Kind) : ℤ :=
+  Elliptic.HigherHomology.surfaceH3Equiv j
+    (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+    (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 3 (splitCircleClassThree j)) 0
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover_splitFibreClassThree
+    (j : Elliptic.Kind) :
+    Elliptic.HigherHomology.surfaceH3Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+        (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 3 (splitFibreClassThree j)) =
+      ![1, 0] := by
+  change
+    Elliptic.HigherHomology.mappingTorusH3Equiv j
+        (Elliptic.HigherHomology.surfaceMappingTorusHomologyEquiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod 3
+          (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 3
+            (splitFibreClassThree j))) =
+      _
+  rw [splitFibreClassThree, surfaceCover_split_section,
+    Elliptic.HigherHomology.mappingTorusH3Equiv_fibre, splitFibreInputThree_coordinates]
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover_splitCircleClassThree_second
+    (j : Elliptic.Kind) :
+    Elliptic.HigherHomology.surfaceH3Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+        (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 3 (splitCircleClassThree j))
+        1 =
+      Elliptic.HigherHomology.fibreNormIndex j := by
+  change
+    Elliptic.HigherHomology.mappingTorusH3Equiv j
+        (Elliptic.HigherHomology.surfaceMappingTorusHomologyEquiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod 3
+          (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 3
+            (splitCircleClassThree j)))
+        1 =
+      _
+  rw [Elliptic.HigherHomology.mappingTorusH3Equiv_boundary, splitCircleClassThree,
+    surfaceCover_split_cross_wang]
+  change Elliptic.HigherHomology.fibreHomologyNormTwoCoordinate j splitFibreInputTwo = _
+  rw [Elliptic.HigherHomology.fibreHomologyNormTwoCoordinate_apply, splitFibreInputTwo,
+    LinearEquiv.apply_symm_apply]
+  simp only [Matrix.cons_val_zero, mul_one]
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover_splitCircleClassThree
+    (j : Elliptic.Kind) :
+    Elliptic.HigherHomology.surfaceH3Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+        (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 3 (splitCircleClassThree j)) =
+      ![sourceShearThree j, (Elliptic.HigherHomology.fibreNormIndex j : ℤ)] := by
+  ext i
+  fin_cases i
+  · rfl
+  · exact surfaceCover_splitCircleClassThree_second j
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitThree_fibre_unsplit :
+    SingularMayerVietoris.singularHomologyMap
+        ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 3).symm :
+          C(PeriodTorusHigherHomology.CircleTopology.Circle ×
+              PeriodTorusHigherHomology.ProductTorus 3,
+            PeriodTorusHigherHomology.ProductTorus 4))
+        3
+        (PeriodTorusHigherHomology.circleSectionHomology
+          (PeriodTorusHigherHomology.ProductTorus 3) 3 splitFibreInputThree) =
+      PeriodTorusHigherHomologyPontryagin.tripleProduct (PeriodTorusHigherHomology.ProductTorus 4)
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 4 (Pi.single 1 1)))
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 4 (Pi.single 2 1)))
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 4 (Pi.single 3 1))) := by
+  rw [PeriodTorusHigherHomology.circleSectionHomology, ← LinearMap.comp_apply, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+  change
+    SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusTailMap 3) 3
+        splitFibreInputThree =
+      _
+  rw [splitFibreInputThree_product,
+    PeriodTorusHigherHomologyPontryagin.tripleProduct_natural
+      (PeriodTorusHigherHomology.torusTailMap 3) (PeriodTorusHigherHomology.torusTailMap_add 3),
+    PeriodTorusHigherHomology.torusTailMap_coordinatePeriodHomology,
+    PeriodTorusHigherHomology.torusTailMap_coordinatePeriodHomology,
+    PeriodTorusHigherHomology.torusTailMap_coordinatePeriodHomology]
+  have hu : (Fin.cons 0 (Pi.single (0 : Fin 3) 1) : Lattice) = Pi.single 1 1 := by decide
+  have hw : (Fin.cons 0 (Pi.single (1 : Fin 3) 1) : Lattice) = Pi.single 2 1 := by decide
+  have hd : (Fin.cons 0 (Pi.single (2 : Fin 3) 1) : Lattice) = Pi.single 3 1 := by decide
+  rw [hu, hw, hd]
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitThree_circle_unsplit :
+    SingularMayerVietoris.singularHomologyMap
+        ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 3).symm :
+          C(PeriodTorusHigherHomology.CircleTopology.Circle ×
+              PeriodTorusHigherHomology.ProductTorus 3,
+            PeriodTorusHigherHomology.ProductTorus 4))
+        3
+        (PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 3)
+          2 splitFibreInputTwo) =
+      PeriodTorusHigherHomologyPontryagin.tripleProduct (PeriodTorusHigherHomology.ProductTorus 4)
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 4 (Pi.single 0 1)))
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 4 (Pi.single 1 1)))
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 4 (Pi.single 2 1))) := by
+  rw [PeriodTorusHigherHomology.torusSplit_positiveCircleCross,
+    PeriodTorusHigherHomology.torusHeadCircleMap_positiveHomology, splitFibreInputTwo_product,
+    PeriodTorusHigherHomologyPontryagin.tripleProduct_apply]
+  change
+    PeriodTorusHigherHomologyPontryagin.product (PeriodTorusHigherHomology.ProductTorus 4) 2 _
+        (SingularMayerVietoris.singularHomologyMap (PeriodTorusHigherHomology.torusTailMap 3) 2
+          (PeriodTorusHigherHomologyPontryagin.product (PeriodTorusHigherHomology.ProductTorus 3)
+            1 _ _)) =
+      _
+  rw [PeriodTorusHigherHomologyPontryagin.product_natural
+      (PeriodTorusHigherHomology.torusTailMap 3) (PeriodTorusHigherHomology.torusTailMap_add 3) 1,
+    PeriodTorusHigherHomology.torusTailMap_coordinatePeriodHomology,
+    PeriodTorusHigherHomology.torusTailMap_coordinatePeriodHomology]
+  have hu : (Fin.cons 0 (Pi.single (0 : Fin 3) 1) : Lattice) = Pi.single 1 1 := by decide
+  have hw : (Fin.cons 0 (Pi.single (1 : Fin 3) 1) : Lattice) = Pi.single 2 1 := by decide
+  rw [hu, hw]
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapKernelWang.splitThree_basis_coordinates (i : Fin 4) :
+    PeriodTorusHigherHomology.coordinateTorusH3Coordinates
+        (PeriodTorusHigherHomologyPontryagin.tripleProduct
+          (PeriodTorusHigherHomology.ProductTorus 4)
+          (FirstHurewicz.loopHomologyClass
+            (PeriodTorusHigherHomology.coordinatePeriodLoop 4
+              (Pi.single (LocalSystemMatrices.tripleIndices i 0) 1)))
+          (FirstHurewicz.loopHomologyClass
+            (PeriodTorusHigherHomology.coordinatePeriodLoop 4
+              (Pi.single (LocalSystemMatrices.tripleIndices i 1) 1)))
+          (FirstHurewicz.loopHomologyClass
+            (PeriodTorusHigherHomology.coordinatePeriodLoop 4
+              (Pi.single (LocalSystemMatrices.tripleIndices i 2) 1)))) =
+      Pi.single i 1 := by
+  have h :
+    PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv.symm
+        (PeriodTorusHigherHomologyExterior.cubeBasis i) =
+      PeriodTorusHigherHomologyPontryagin.tripleProduct (PeriodTorusHigherHomology.ProductTorus 4)
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 4
+            (Pi.single (LocalSystemMatrices.tripleIndices i 0) 1)))
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 4
+            (Pi.single (LocalSystemMatrices.tripleIndices i 1) 1)))
+        (FirstHurewicz.loopHomologyClass
+          (PeriodTorusHigherHomology.coordinatePeriodLoop 4
+            (Pi.single (LocalSystemMatrices.tripleIndices i 2) 1))) := by
+    rw [PeriodTorusHigherHomologyExterior.cubeBasis_apply,
+      PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv_symm_ιMulti]
+    simp only [Function.comp_apply, PeriodTorusHigherHomologyExterior.latticeBasis,
+      Pi.basisFun_apply]
+  rw [← h]
+  change
+    PeriodTorusHigherHomologyExterior.cubeCoordinates
+        (PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv
+          (PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv.symm
+            (PeriodTorusHigherHomologyExterior.cubeBasis i))) =
+      _
+  rw [LinearEquiv.apply_symm_apply]
+  change
+    PeriodTorusHigherHomologyExterior.cubeBasis.equivFun
+        (PeriodTorusHigherHomologyExterior.cubeBasis i) =
+      _
+  ext k
+  simp [Pi.single_apply, eq_comm]
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitThree_fibre_unsplit_coordinates :
+    PeriodTorusHigherHomology.coordinateTorusH3Coordinates
+        (SingularMayerVietoris.singularHomologyMap
+          ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 3).symm :
+            C(PeriodTorusHigherHomology.CircleTopology.Circle ×
+                PeriodTorusHigherHomology.ProductTorus 3,
+              PeriodTorusHigherHomology.ProductTorus 4))
+          3
+          (PeriodTorusHigherHomology.circleSectionHomology
+            (PeriodTorusHigherHomology.ProductTorus 3) 3 splitFibreInputThree)) =
+      Pi.single 3 1 := by
+  rw [splitThree_fibre_unsplit]
+  exact splitThree_basis_coordinates 3
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitThree_circle_unsplit_coordinates :
+    PeriodTorusHigherHomology.coordinateTorusH3Coordinates
+        (SingularMayerVietoris.singularHomologyMap
+          ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 3).symm :
+            C(PeriodTorusHigherHomology.CircleTopology.Circle ×
+                PeriodTorusHigherHomology.ProductTorus 3,
+              PeriodTorusHigherHomology.ProductTorus 4))
+          3
+          (PeriodTorusHigherHomology.positiveCircleCross
+            (PeriodTorusHigherHomology.ProductTorus 3) 2 splitFibreInputTwo)) =
+      Pi.single 0 1 := by
+  rw [splitThree_circle_unsplit]
+  exact splitThree_basis_coordinates 0
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitFlat_inverse_h3_coordinates
+    (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (PeriodTorusHigherHomology.CircleTopology.Circle ×
+          PeriodTorusHigherHomology.ProductTorus 3)
+        3) :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (SingularMayerVietoris.singularHomologyMap
+          ((Elliptic.HigherHomology.splitFlatTorusHomeomorph j).symm :
+            C(PeriodTorusHigherHomology.CircleTopology.Circle ×
+                PeriodTorusHigherHomology.ProductTorus 3,
+              RealTorus₄))
+          3 a) =
+      LocalSystemMatrices.exteriorCube (Elliptic.HigherHomology.twistBasisMatrix j) *ᵥ
+        PeriodTorusHigherHomology.coordinateTorusH3Coordinates
+          (SingularMayerVietoris.singularHomologyMap
+            ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 3).symm :
+              C(PeriodTorusHigherHomology.CircleTopology.Circle ×
+                  PeriodTorusHigherHomology.ProductTorus 3,
+                PeriodTorusHigherHomology.ProductTorus 4))
+            3 a) := by
+  rw [PeriodFamily.FlatTorus.singularH3Coordinates_apply,
+    PeriodFamily.FlatTorus.singularH3Equiv_apply, splitFlat_inverse_circle_homology]
+  exact
+    PeriodTorusHigherHomology.coordinateTorusH3Coordinates_matrix
+      (Elliptic.HigherHomology.twistBasisMatrix j) _
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreClassThree_coordinates
+    (j : Elliptic.Kind) :
+    PeriodFamily.FlatTorus.singularH3Coordinates (splitFibreClassThree j) = ![0, 0, 0, 1] := by
+  rw [splitFibreClassThree, splitFlat_inverse_h3_coordinates,
+    splitThree_fibre_unsplit_coordinates]
+  cases j <;> decide
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassThree_coordinates
+    (j : Elliptic.Kind) :
+    PeriodFamily.FlatTorus.singularH3Coordinates (splitCircleClassThree j) =
+      ![γ j.twist, 0, 0, 0] := by
+  rw [splitCircleClassThree, splitFlat_inverse_h3_coordinates,
+    splitThree_circle_unsplit_coordinates]
+  cases j <;> decide
+
+private def PeriodFamily.Boundary.EllipticCapKernelWang.topWangMatrix :
+    Elliptic.Kind → ℤ → Matrix (Fin 4) (Fin 2) ℤ
+  | .three, c => !![0, 3; 0, -1; 0, 2; 3, -3 * c]
+  | .four, c => !![0, -2; 0, 1; 0, -1; 4, -2 * c]
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.topWangMatrix_mulVec_three (c : ℤ)
+    (a : Fin 2 → ℤ) :
+    topWangMatrix .three c *ᵥ a = ![3 * a 1, -a 1, 2 * a 1, 3 * a 0 - 3 * c * a 1] := by
+  ext i
+  fin_cases i <;> simp [topWangMatrix, Matrix.mulVec, dotProduct, Fin.sum_univ_succ]
+  ring
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.topWangMatrix_mulVec_four (c : ℤ)
+    (a : Fin 2 → ℤ) :
+    topWangMatrix .four c *ᵥ a = ![-2 * a 1, a 1, -a 1, 4 * a 0 - 2 * c * a 1] := by
+  ext i
+  fin_cases i <;> simp [topWangMatrix, Matrix.mulVec, dotProduct, Fin.sum_univ_succ]
+  ring
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalAffineNorm_splitFibreClassThree
+    (j : Elliptic.Kind) :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (originalAffineNorm j 3 (splitFibreClassThree j)) =
+      (j.order : ℤ) • ![0, 0, 0, 1] := by
+  rw [originalAffineNorm_h3_coordinates, splitFibreClassThree_coordinates]
+  cases j
+  · rw [originalNormMatrixThree_three]
+    decide
+  · rw [originalNormMatrixThree_four]
+    decide
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.originalAffineNorm_splitCircleClassThree
+    (j : Elliptic.Kind) :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (originalAffineNorm j 3 (splitCircleClassThree j)) =
+      match j with
+      | .three => ![3, -1, 2, 0]
+      | .four => ![-4, 2, -2, 0] := by
+  rw [originalAffineNorm_h3_coordinates, splitCircleClassThree_coordinates]
+  cases j
+  · rw [originalNormMatrixThree_three]
+    decide
+  · rw [originalNormMatrixThree_four]
+    decide
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.h3Coordinates_cover_columns
+    (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) 3) :
+    (Elliptic.HigherHomology.fibreNormIndex j : ℤ) • h3Coordinates j a =
+      ((Elliptic.HigherHomology.fibreNormIndex j : ℤ) *
+              Elliptic.HigherHomology.surfaceH3Equiv j
+                (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 0 -
+            sourceShearThree j *
+              Elliptic.HigherHomology.surfaceH3Equiv j
+                (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1) •
+          PeriodFamily.FlatTorus.singularH3Coordinates
+            (originalAffineNorm j 3 (splitFibreClassThree j)) +
+        Elliptic.HigherHomology.surfaceH3Equiv j
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a 1 •
+          PeriodFamily.FlatTorus.singularH3Coordinates
+            (originalAffineNorm j 3 (splitCircleClassThree j)) := by
+  have h :=
+    map_cover_columns
+      (Elliptic.HigherHomology.surfaceH3Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod)
+      (h3Coordinates j)
+      (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 3 (splitFibreClassThree j))
+      (SingularMayerVietoris.singularHomologyMap (surfaceCover j) 3 (splitCircleClassThree j)) a
+      (sourceShearThree j) (Elliptic.HigherHomology.fibreNormIndex j : ℤ)
+      (surfaceCover_splitFibreClassThree j) (surfaceCover_splitCircleClassThree j)
+  simpa only [h3Coordinates_surfaceCover] using h
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.h3Coordinates_three
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) .three) 3) :
+    h3Coordinates .three a =
+      ![3 *
+          Elliptic.HigherHomology.surfaceH3Equiv .three
+            (SpecialPeriods.EllipticFilling.specialLocalData .three).centralPeriod a 1,
+        -Elliptic.HigherHomology.surfaceH3Equiv .three
+            (SpecialPeriods.EllipticFilling.specialLocalData .three).centralPeriod a 1,
+        2 *
+          Elliptic.HigherHomology.surfaceH3Equiv .three
+            (SpecialPeriods.EllipticFilling.specialLocalData .three).centralPeriod a 1,
+        3 *
+            Elliptic.HigherHomology.surfaceH3Equiv .three
+              (SpecialPeriods.EllipticFilling.specialLocalData .three).centralPeriod a 0 -
+          3 * sourceShearThree .three *
+            Elliptic.HigherHomology.surfaceH3Equiv .three
+              (SpecialPeriods.EllipticFilling.specialLocalData .three).centralPeriod a 1] := by
+  have h := h3Coordinates_cover_columns .three a
+  rw [originalAffineNorm_splitFibreClassThree, originalAffineNorm_splitCircleClassThree] at h
+  simp only [Elliptic.HigherHomology.fibreNormIndex_three, Nat.cast_one, one_smul, one_mul] at h
+  rw [h]
+  ext i
+  fin_cases i <;> simp [Elliptic.Kind.order] <;> ring
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/PeriodFamily/Core7.lean b/LeanPool/HopfProblem/PeriodFamily/Core7.lean
new file mode 100644
index 000000000..05623f04b
--- /dev/null
+++ b/LeanPool/HopfProblem/PeriodFamily/Core7.lean
@@ -0,0 +1,1142 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.PeriodFamily.Core6
+public import LeanPool.HopfProblem.MainTheorem.Core1
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology4
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap1
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology7
+import all LeanPool.HopfProblem.PeriodFamily.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods6
+import all LeanPool.HopfProblem.PeriodFamily.Core2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import all LeanPool.HopfProblem.Elliptic.Core3
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.Elliptic.Core4
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods8
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen2
+import all LeanPool.HopfProblem.Elliptic.Core5
+import all LeanPool.HopfProblem.PeriodFamily.Core3
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods10
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology9
+import all LeanPool.HopfProblem.PeriodFamily.Core4
+import all LeanPool.HopfProblem.Pi1.MappingTorusHomology
+import all LeanPool.HopfProblem.PeriodFamily.Core5
+import all LeanPool.HopfProblem.Elliptic.Core7
+import all LeanPool.HopfProblem.PeriodFamily.Core6
+import all LeanPool.HopfProblem.MainTheorem.Core1
+
+/-!
+# Hopf problem: period family · core 7
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.h3Coordinates_four
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) .four) 3) :
+    h3Coordinates .four a =
+      ![-2 *
+          Elliptic.HigherHomology.surfaceH3Equiv .four
+            (SpecialPeriods.EllipticFilling.specialLocalData .four).centralPeriod a 1,
+        Elliptic.HigherHomology.surfaceH3Equiv .four
+          (SpecialPeriods.EllipticFilling.specialLocalData .four).centralPeriod a 1,
+        -Elliptic.HigherHomology.surfaceH3Equiv .four
+            (SpecialPeriods.EllipticFilling.specialLocalData .four).centralPeriod a 1,
+        4 *
+            Elliptic.HigherHomology.surfaceH3Equiv .four
+              (SpecialPeriods.EllipticFilling.specialLocalData .four).centralPeriod a 0 -
+          2 * sourceShearThree .four *
+            Elliptic.HigherHomology.surfaceH3Equiv .four
+              (SpecialPeriods.EllipticFilling.specialLocalData .four).centralPeriod a 1] := by
+  have h := h3Coordinates_cover_columns .four a
+  rw [originalAffineNorm_splitFibreClassThree, originalAffineNorm_splitCircleClassThree] at h
+  ext i
+  have hi := congrFun h i
+  fin_cases i
+  all_goals
+    simp [Elliptic.HigherHomology.fibreNormIndex_four, Elliptic.Kind.order] at hi ⊢
+    linarith only [hi]
+
+private theorem
+    PeriodFamily.Boundary.EllipticCapKernelWang.h3Coordinates_formula (j : Elliptic.Kind)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface) j) 3) :
+    h3Coordinates j a =
+      topWangMatrix j (sourceShearThree j) *ᵥ
+        Elliptic.HigherHomology.surfaceH3Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod a := by
+  cases j
+  · rw [h3Coordinates_three, topWangMatrix_mulVec_three]
+  · rw [h3Coordinates_four, topWangMatrix_mulVec_four]
+
+private def
+    PeriodFamily.Boundary.EllipticCapKernelWang.capKernelWangH4Coordinates (j : Elliptic.Kind) :
+    LinearMap.ker
+        (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) 4) →ₗ[ℤ]
+      Lattice :=
+  AddMonoidHom.toIntLinearMap
+    (PeriodFamily.FlatTorus.singularH3Coordinates.toAddEquiv.toAddMonoidHom.comp
+      ((MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist)
+            3).toAddMonoidHom.comp
+        (LinearMap.ker
+            (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j)
+              4)).subtype.toAddMonoidHom))
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.capKernelWangH4Coordinates_apply
+    (j : Elliptic.Kind)
+    (a :
+      LinearMap.ker (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) 4)) :
+    capKernelWangH4Coordinates j a =
+      PeriodFamily.FlatTorus.singularH3Coordinates
+        (MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) 3 a.val) :=
+  rfl
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.capKernelWangH4Coordinates_symm
+    (j : Elliptic.Kind) (a : Fin 2 → ℤ) :
+    capKernelWangH4Coordinates j
+        ((PeriodFamily.Boundary.EllipticCapProduct.boundaryCapH4KernelEquiv j).symm a) =
+      topWangMatrix j (sourceShearThree j) *ᵥ a := by
+  rw [capKernelWangH4Coordinates_apply,
+    PeriodFamily.Boundary.EllipticCapProduct.boundaryCapH4KernelEquiv_symm_val]
+  simpa only [h3Coordinates_apply, crossWang_apply, LinearEquiv.apply_symm_apply] using
+    h3Coordinates_formula j
+      ((Elliptic.HigherHomology.surfaceH3Equiv j
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).symm
+        a)
+
+private theorem PeriodFamily.Boundary.EllipticCapKernelWang.capKernelWangH4Coordinates_first_axis
+    (j : Elliptic.Kind) :
+    capKernelWangH4Coordinates j
+        ((PeriodFamily.Boundary.EllipticCapProduct.boundaryCapH4KernelEquiv j).symm ![1, 0]) =
+      (j.order : ℤ) • ![0, 0, 0, 1] := by
+  rw [capKernelWangH4Coordinates_symm]
+  cases j
+  · rw [topWangMatrix_mulVec_three]
+    simp [Elliptic.Kind.order]
+  · rw [topWangMatrix_mulVec_four]
+    simp [Elliptic.Kind.order]
+
+private theorem PeriodFamily.Boundary.normalizedFamilyFibreHomologyFour_ker
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    LinearMap.ker
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodFamily.Homology.familyFibreInclusion D
+            PeriodFamily.Homology.normalizedSlitBaseLift)
+          4) =
+      ⊥ := by
+  rw [PeriodFamily.Homology.familyFibreInclusion_kernel,
+    PeriodFamily.HomologyDifference.sourceDifference_four, LinearMap.range_zero]
+
+private theorem PeriodFamily.Boundary.normalizedFamilyFibreHomologyFour_injective
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    Function.Injective
+      (SingularMayerVietoris.singularHomologyMap
+        (PeriodFamily.Homology.familyFibreInclusion D
+          PeriodFamily.Homology.normalizedSlitBaseLift)
+        4) :=
+  LinearMap.ker_eq_bot.mp (normalizedFamilyFibreHomologyFour_ker D)
+
+private def PeriodFamily.Homology.pointFamilyFibreInclusion
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (z : SpecialPeriods.TriangleRegularPoint) : C(RealTorus₄, D.Space) :=
+  ⟨fun f => D.quotient (z, f), D.quotient_continuous.comp (continuous_const.prodMk continuous_id)⟩
+
+private def PeriodFamily.Homology.pointFamilyFibreHomotopy
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    {z w : SpecialPeriods.TriangleRegularPoint} (γ : Path z w) :
+    (pointFamilyFibreInclusion D z).Homotopy (pointFamilyFibreInclusion D w)
+    where
+  toFun tf := D.quotient (γ tf.1, tf.2)
+  continuous_toFun :=
+    D.quotient_continuous.comp ((γ.continuous.comp continuous_fst).prodMk continuous_snd)
+  map_zero_left
+    f := by
+    change D.quotient (γ 0, f) = D.quotient (z, f)
+    rw [γ.source]
+  map_one_left
+    f := by
+    change D.quotient (γ 1, f) = D.quotient (w, f)
+    rw [γ.target]
+
+private theorem PeriodFamily.Homology.pointFamilyFibreInclusion_homology_eq_of_path
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    {z w : SpecialPeriods.TriangleRegularPoint} (γ : Path z w) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (pointFamilyFibreInclusion D z) n =
+      SingularMayerVietoris.singularHomologyMap (pointFamilyFibreInclusion D w) n :=
+  PeriodTorusHigherHomology.homotopy_homologyMap (pointFamilyFibreHomotopy D γ) n
+
+private theorem PeriodFamily.Homology.pointFamilyFibreInclusion_homology_eq
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (z w : SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (pointFamilyFibreInclusion D z) n =
+      SingularMayerVietoris.singularHomologyMap (pointFamilyFibreInclusion D w) n :=
+  pointFamilyFibreInclusion_homology_eq_of_path D (PathConnectedSpace.somePath z w) n
+
+private theorem PeriodFamily.Homology.pointFamilyFibreInclusion_homology_eq_normalized
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (z : SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (pointFamilyFibreInclusion D z) n =
+      SingularMayerVietoris.singularHomologyMap (familyFibreInclusion D normalizedSlitBaseLift)
+        n :=
+  pointFamilyFibreInclusion_homology_eq D z normalizedSlitBaseLift.val n
+
+private def PeriodFamily.Boundary.EllipticGaugeLinearization.positiveLogFlat {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (z : SpecialPeriods.Disc) (s : ℂ) :
+    RealPlane₄ :=
+  (D.periods.periodEquiv z).symm (s • Elliptic.LogGauge.periodVector D.periods v z)
+
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.positiveLogFlat_continuous
+    {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j) (v : Lattice) :
+    Continuous (fun p : SpecialPeriods.Disc × ℂ => positiveLogFlat D v p.1 p.2) := by
+  change
+    Continuous
+      ((fun q : SpecialPeriods.Disc × ComplexPlane₂ => (D.periods.periodEquiv q.1).symm q.2) ∘
+        (fun p : SpecialPeriods.Disc × ℂ =>
+          (p.1, p.2 • Elliptic.LogGauge.periodVector D.periods v p.1)))
+  apply D.periods.continuous_periodEquiv_symm.comp
+  exact
+    continuous_fst.prodMk
+      (continuous_snd.smul
+        ((Elliptic.LogGauge.periodVector_holomorphic D.periods v).continuous.comp continuous_fst))
+
+private def PeriodFamily.Boundary.EllipticGaugeLinearization.positiveLogFlatMap {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) :
+    C(SpecialPeriods.Disc × ℂ, RealPlane₄) :=
+  ⟨fun p => positiveLogFlat D v p.1 p.2, positiveLogFlat_continuous D v⟩
+
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.positiveLogFlat_rotation
+    {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (z : SpecialPeriods.Disc) (s : ℂ) :
+    positiveLogFlat D v (Elliptic.familyRotation j z) (s - 1 / (j.order : ℂ)) =
+      Elliptic.flatLinear j (positiveLogFlat D v z s) -
+        (1 / (j.order : ℝ)) • Elliptic.realCast v := by
+  apply (D.periods.periodEquiv (Elliptic.familyRotation j z)).injective
+  simp only [positiveLogFlat, LinearEquiv.apply_symm_apply, map_sub, D.periodEquiv_flatLinear,
+    Elliptic.LogGauge.complexLift_translation, Matrix.mulVec_smul,
+    Elliptic.LogGauge.periodVector_covariance D v hv]
+  exact sub_smul _ _ _
+
+private theorem
+    PeriodFamily.Boundary.EllipticGaugeLinearization.sectionCoordinate_eq_positiveLogFlat
+    {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j) (v : Lattice) (z : SpecialPeriods.Disc)
+    (hz : (z : ℂ) ≠ 0) (s : ℂ) (hs : CuspUniformization.exponential s = (z : ℂ)) :
+    Elliptic.LogGauge.sectionCoordinate D.periods v z =
+      standardLattice.mkQ (positiveLogFlat D v z s) := by
+  have h := Elliptic.LogGauge.sectionMap_formula_of_exponential D.periods v ⟨z, hz⟩ s hs
+  have h' := congrArg Prod.snd h
+  change
+    0 + Elliptic.LogGauge.sectionCoordinate D.periods v z =
+      standardLattice.mkQ (positiveLogFlat D v z s) at h'
+  exact (zero_add _).symm.trans h'
+
+private def PeriodFamily.Boundary.EllipticGaugeLinearization.nativeLogParameter (j : Elliptic.Kind)
+    (τ : ℝ) : C(ℝ, ℂ)
+    where
+  toFun t := PeriodFamily.Boundary.nativeClockwiseParameter j (-(t + τ))
+  continuous_toFun := by unfold PeriodFamily.Boundary.nativeClockwiseParameter; fun_prop
+
+private def
+    PeriodFamily.Boundary.EllipticGaugeLinearization.nativeLogRoot (j : Elliptic.Kind) (τ : ℝ) :
+    C(ℝ, SpecialPeriods.Disc) :=
+  (PeriodFamily.Boundary.nativeClockwiseRoot j).comp
+    ⟨fun t => -(t + τ), (continuous_id.add continuous_const).neg⟩
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.nativeLogParameter_apply
+    (j : Elliptic.Kind) (τ t : ℝ) :
+    nativeLogParameter j τ t = PeriodFamily.Boundary.nativeClockwiseParameter j (-(t + τ)) :=
+  rfl
+
+private theorem
+    PeriodFamily.Boundary.EllipticGaugeLinearization.nativeLogRoot_ne_zero (j : Elliptic.Kind)
+    (τ t : ℝ) : (nativeLogRoot j τ t : ℂ) ≠ 0 :=
+  PeriodFamily.Boundary.nativeClockwiseRoot_ne_zero j _
+
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.nativeLogRoot_exponential
+    (j : Elliptic.Kind) (τ t : ℝ) :
+    CuspUniformization.exponential (nativeLogParameter j τ t) = (nativeLogRoot j τ t : ℂ) :=
+  rfl
+
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.nativeLogRoot_rotation
+    (j : Elliptic.Kind) (τ t : ℝ) :
+    Elliptic.familyRotation j (nativeLogRoot j τ (t + 1)) = nativeLogRoot j τ t := by
+  have h := PeriodFamily.Boundary.nativeClockwiseRoot_add_one j (-(t + 1 + τ))
+  rw [show -(t + 1 + τ) + 1 = -(t + τ) by ring] at h
+  exact h.symm
+
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.nativeLogParameter_step
+    (j : Elliptic.Kind) (τ t : ℝ) :
+    nativeLogParameter j τ (t + 1) - 1 / (j.order : ℂ) = nativeLogParameter j τ t := by
+  simp only [nativeLogParameter_apply, PeriodFamily.Boundary.nativeClockwiseParameter]
+  push_cast
+  ring
+
+private def PeriodFamily.Boundary.EllipticGaugeLinearization.nativeGaugeRealLift (j : Elliptic.Kind)
+    (τ : ℝ) : C(ℝ, RealPlane₄) :=
+  (positiveLogFlatMap (SpecialPeriods.EllipticFilling.specialLocalData j) j.twist).comp
+    ((nativeLogRoot j τ).prodMk (nativeLogParameter j τ))
+
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.nativeGaugeRealLift_forward
+    (j : Elliptic.Kind) (τ t : ℝ) :
+    Elliptic.flatLinear j (nativeGaugeRealLift j τ (t + 1)) =
+      nativeGaugeRealLift j τ t + (1 / (j.order : ℝ)) • Elliptic.realCast j.twist := by
+  have h :=
+    positiveLogFlat_rotation (SpecialPeriods.EllipticFilling.specialLocalData j) j.twist
+      j.matrix_fixes_twist (nativeLogRoot j τ (t + 1)) (nativeLogParameter j τ (t + 1))
+  rw [nativeLogRoot_rotation, nativeLogParameter_step] at h
+  change
+    nativeGaugeRealLift j τ t =
+      Elliptic.flatLinear j (nativeGaugeRealLift j τ (t + 1)) -
+        (1 / (j.order : ℝ)) • Elliptic.realCast j.twist at h
+  exact sub_eq_iff_eq_add.mp h.symm
+
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.nativeGaugeCylinder_realLift
+    (j : Elliptic.Kind) (τ t : ℝ) (x : RealTorus₄) :
+    PeriodFamily.Boundary.nativeGaugeCylinder j τ (t, x) =
+      x + standardLattice.mkQ (nativeGaugeRealLift j τ t) := by
+  rw [PeriodFamily.Boundary.nativeGaugeCylinder_apply]
+  apply congrArg (fun y : RealTorus₄ => x + y)
+  exact
+    sectionCoordinate_eq_positiveLogFlat (SpecialPeriods.EllipticFilling.specialLocalData j)
+      j.twist (nativeLogRoot j τ t) (nativeLogRoot_ne_zero j τ t) (nativeLogParameter j τ t)
+      (nativeLogRoot_exponential j τ t)
+
+private def PeriodFamily.Boundary.EllipticGaugeLinearization.linearGauge (j : Elliptic.Kind)
+    (v : Lattice) : C(ℝ, RealPlane₄) :=
+  ⟨fun t => (t / (j.order : ℝ)) • Elliptic.realCast v,
+    (continuous_id.div_const (j.order : ℝ)).smul continuous_const⟩
+
+private theorem
+    PeriodFamily.Boundary.EllipticGaugeLinearization.linearGauge_forward (j : Elliptic.Kind)
+    (v : Lattice) (hv : j.matrix *ᵥ v = v) (t : ℝ) :
+    Elliptic.flatLinear j (linearGauge j v (t + 1)) =
+      linearGauge j v t + (1 / (j.order : ℝ)) • Elliptic.realCast v := by
+  change
+    Elliptic.flatLinear j (((t + 1) / (j.order : ℝ)) • Elliptic.realCast v) =
+      (t / (j.order : ℝ)) • Elliptic.realCast v + (1 / (j.order : ℝ)) • Elliptic.realCast v
+  rw [map_smul, Elliptic.flatLinear_realCast, hv, add_div, add_smul]
+
+private def PeriodFamily.Boundary.EllipticGaugeLinearization.gaugeInterpolation (j : Elliptic.Kind)
+    (v : Lattice) (a : C(ℝ, RealPlane₄)) :
+    C(unitInterval × ℝ, RealPlane₄) :=
+  ⟨fun p => (1 - (p.1 : ℝ)) • a p.2 + (p.1 : ℝ) • linearGauge j v p.2,
+    ((continuous_const.sub (continuous_subtype_val.comp continuous_fst)).smul
+          (a.continuous.comp continuous_snd)).add
+      ((continuous_subtype_val.comp continuous_fst).smul
+        ((linearGauge j v).continuous.comp continuous_snd))⟩
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.gaugeInterpolation_zero
+    (j : Elliptic.Kind) (v : Lattice) (a : C(ℝ, RealPlane₄)) (t : ℝ) :
+    gaugeInterpolation j v a (0, t) = a t := by
+  change (1 - (0 : ℝ)) • a t + (0 : ℝ) • linearGauge j v t = a t
+  simp
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.gaugeInterpolation_one
+    (j : Elliptic.Kind) (v : Lattice) (a : C(ℝ, RealPlane₄)) (t : ℝ) :
+    gaugeInterpolation j v a (1, t) = linearGauge j v t := by
+  change (1 - (1 : ℝ)) • a t + (1 : ℝ) • linearGauge j v t = linearGauge j v t
+  simp
+
+private def
+    PeriodFamily.Boundary.EllipticGaugeLinearization.gaugeInterpolationSlice (j : Elliptic.Kind)
+    (v : Lattice) (a : C(ℝ, RealPlane₄)) (s : unitInterval) :
+    C(ℝ, RealPlane₄) :=
+  ⟨fun t => gaugeInterpolation j v a (s, t),
+    (gaugeInterpolation j v a).continuous.comp (continuous_const.prodMk continuous_id)⟩
+
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.gaugeInterpolation_forward
+    (j : Elliptic.Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (a : C(ℝ, RealPlane₄))
+    (ha :
+      ∀ t, Elliptic.flatLinear j (a (t + 1)) = a t + (1 / (j.order : ℝ)) • Elliptic.realCast v)
+    (s : unitInterval) (t : ℝ) :
+    Elliptic.flatLinear j (gaugeInterpolationSlice j v a s (t + 1)) =
+      gaugeInterpolationSlice j v a s t + (1 / (j.order : ℝ)) • Elliptic.realCast v := by
+  change
+    Elliptic.flatLinear j ((1 - (s : ℝ)) • a (t + 1) + (s : ℝ) • linearGauge j v (t + 1)) =
+      ((1 - (s : ℝ)) • a t + (s : ℝ) • linearGauge j v t) +
+        (1 / (j.order : ℝ)) • Elliptic.realCast v
+  rw [map_add, map_smul, map_smul, ha, linearGauge_forward j v hv]
+  ext i
+  simp only [Pi.add_apply, Pi.smul_apply, smul_eq_mul]
+  ring
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.EllipticGaugeLinearization.gaugeFibreCylinder
+    (a : C(ℝ, RealPlane₄)) : C(ℝ × RealTorus₄, RealTorus₄) :=
+  ⟨fun p => p.2 + standardLattice.mkQ (a p.1),
+    continuous_snd.add (standardLattice.continuous_mkQ.comp (a.continuous.comp continuous_fst))⟩
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem
+    PeriodFamily.Boundary.EllipticGaugeLinearization.flatTorusAffine_apply_eq_triangle_add
+    (j : Elliptic.Kind) (v : Lattice) (x : RealTorus₄) :
+    Elliptic.flatTorusAffine j v x =
+      SpecialPeriods.Triangle.ellipticGenerator j • x +
+        standardLattice.mkQ ((1 / (j.order : ℝ)) • Elliptic.realCast v) :=
+  congrArg (fun f : C(RealTorus₄, RealTorus₄) => f x)
+    (PeriodFamily.Boundary.flatTorusAffine_eq_translation_triangle j v)
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.gaugeFibreCylinder_forward
+    (j : Elliptic.Kind) (v : Lattice) (a : C(ℝ, RealPlane₄))
+    (ha :
+      ∀ t, Elliptic.flatLinear j (a (t + 1)) = a t + (1 / (j.order : ℝ)) • Elliptic.realCast v)
+    (t : ℝ) (x : RealTorus₄) :
+    SpecialPeriods.Triangle.ellipticGenerator j • gaugeFibreCylinder a (t + 1, x) =
+      gaugeFibreCylinder a (t, Elliptic.flatTorusAffine j v x) := by
+  change
+    SpecialPeriods.triangleTorusHomeomorph (SpecialPeriods.Triangle.ellipticGenerator j)
+        (x + standardLattice.mkQ (a (t + 1))) =
+      Elliptic.flatTorusAffine j v x + standardLattice.mkQ (a t)
+  rw [SpecialPeriods.triangleTorusHomeomorph_add, PeriodFamily.Boundary.ellipticTriangle_mkQ, ha,
+    map_add, flatTorusAffine_apply_eq_triangle_add]
+  change
+    SpecialPeriods.triangleTorusHomeomorph (SpecialPeriods.Triangle.ellipticGenerator j) x +
+        (standardLattice.mkQ (a t) +
+          standardLattice.mkQ ((1 / (j.order : ℝ)) • Elliptic.realCast v)) =
+      (SpecialPeriods.triangleTorusHomeomorph (SpecialPeriods.Triangle.ellipticGenerator j) x +
+          standardLattice.mkQ ((1 / (j.order : ℝ)) • Elliptic.realCast v)) +
+        standardLattice.mkQ (a t)
+  abel
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.gaugeFibreCylinder_deck_one
+    (j : Elliptic.Kind) (v : Lattice) (a : C(ℝ, RealPlane₄))
+    (ha :
+      ∀ t, Elliptic.flatLinear j (a (t + 1)) = a t + (1 / (j.order : ℝ)) • Elliptic.realCast v)
+    (p : ℝ × RealTorus₄) :
+    gaugeFibreCylinder a (MappingTorus.deck (Elliptic.flatTorusAffine j v) 1 p) =
+      (SpecialPeriods.Triangle.ellipticGenerator j)⁻¹ • gaugeFibreCylinder a p := by
+  apply
+    (SpecialPeriods.triangleTorusHomeomorph
+        (SpecialPeriods.Triangle.ellipticGenerator j)).injective
+  change
+    SpecialPeriods.Triangle.ellipticGenerator j •
+        gaugeFibreCylinder a (MappingTorus.deck (Elliptic.flatTorusAffine j v) 1 p) =
+      SpecialPeriods.Triangle.ellipticGenerator j •
+        ((SpecialPeriods.Triangle.ellipticGenerator j)⁻¹ • gaugeFibreCylinder a p)
+  rw [smul_inv_smul]
+  simp only [MappingTorus.deck, Int.cast_one, zpow_neg_one]
+  change
+    SpecialPeriods.Triangle.ellipticGenerator j •
+        gaugeFibreCylinder a (p.1 + 1, (Elliptic.flatTorusAffine j v).symm p.2) =
+      gaugeFibreCylinder a p
+  rw [gaugeFibreCylinder_forward j v a ha, Homeomorph.apply_symm_apply]
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.fibreDeck_of_one
+    (φ : RealTorus₄ ≃ₜ RealTorus₄) (F : ℝ × RealTorus₄ → RealTorus₄)
+    (g : SpecialPeriods.TriangleGroup) (hF : ∀ p, F (MappingTorus.deck φ 1 p) = g⁻¹ • F p) (k : ℤ)
+    (p : ℝ × RealTorus₄) : F (MappingTorus.deck φ k p) = (g ^ (-k)) • F p := by
+  have hprev (q : ℝ × RealTorus₄) : F (MappingTorus.deck φ (-1) q) = g • F q := by
+    have h := congrArg (fun y : RealTorus₄ => g • y) (hF (MappingTorus.deck φ (-1) q))
+    simpa only [← MappingTorus.deck_add, add_neg_cancel, MappingTorus.deck_zero,
+      smul_inv_smul] using h.symm
+  have hall : ∀ k : ℤ, ∀ p : ℝ × RealTorus₄, F (MappingTorus.deck φ k p) = (g ^ (-k)) • F p := by
+    intro k
+    induction k using Int.induction_on with
+    | zero => intro p; simp only [MappingTorus.deck_zero, neg_zero, zpow_zero, one_smul]
+    | succ k ih =>
+      intro p
+      rw [MappingTorus.deck_add, ih, hF, neg_add, zpow_add, zpow_neg_one,
+        SemigroupAction.mul_smul]
+    | pred k ih =>
+      intro p
+      rw [sub_eq_add_neg, MappingTorus.deck_add, ih, hprev]
+      simp only [neg_add, neg_neg, zpow_add, zpow_one, SemigroupAction.mul_smul]
+  exact hall k p
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.gaugeFibreCylinder_deck
+    (j : Elliptic.Kind) (v : Lattice) (a : C(ℝ, RealPlane₄))
+    (ha :
+      ∀ t, Elliptic.flatLinear j (a (t + 1)) = a t + (1 / (j.order : ℝ)) • Elliptic.realCast v)
+    (k : ℤ) (p : ℝ × RealTorus₄) :
+    gaugeFibreCylinder a (MappingTorus.deck (Elliptic.flatTorusAffine j v) k p) =
+      (SpecialPeriods.Triangle.ellipticGenerator j ^ (-k)) • gaugeFibreCylinder a p :=
+  fibreDeck_of_one (Elliptic.flatTorusAffine j v) (gaugeFibreCylinder a)
+    (SpecialPeriods.Triangle.ellipticGenerator j) (gaugeFibreCylinder_deck_one j v a ha) k p
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.interpolatedGaugeFibreCylinder_deck
+    (j : Elliptic.Kind) (v : Lattice) (hv : j.matrix *ᵥ v = v)
+    (a : C(ℝ, RealPlane₄))
+    (ha :
+      ∀ t, Elliptic.flatLinear j (a (t + 1)) = a t + (1 / (j.order : ℝ)) • Elliptic.realCast v)
+    (s : unitInterval) (k : ℤ) (p : ℝ × RealTorus₄) :
+    gaugeFibreCylinder (gaugeInterpolationSlice j v a s)
+        (MappingTorus.deck (Elliptic.flatTorusAffine j v) k p) =
+      (SpecialPeriods.Triangle.ellipticGenerator j ^ (-k)) •
+        gaugeFibreCylinder (gaugeInterpolationSlice j v a s) p :=
+  gaugeFibreCylinder_deck j v (gaugeInterpolationSlice j v a s)
+    (gaugeInterpolation_forward j v hv a ha s) k p
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.EllipticGaugeLinearization.gaugeCylinderMap
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (L : C(ℝ, SpecialPeriods.TriangleRegularPoint)) (a : C(ℝ, RealPlane₄)) :
+    C(ℝ × RealTorus₄, D.Space) :=
+  PeriodFamily.Boundary.familyCylinderMap D L (gaugeFibreCylinder a)
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.gaugeCylinderMap_deck
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (j : Elliptic.Kind)
+    (v : Lattice) (a : C(ℝ, RealPlane₄))
+    (ha :
+      ∀ t, Elliptic.flatLinear j (a (t + 1)) = a t + (1 / (j.order : ℝ)) • Elliptic.realCast v)
+    (L : C(ℝ, SpecialPeriods.TriangleRegularPoint))
+    (hL : ∀ (k : ℤ) t, L (t + k) = (SpecialPeriods.Triangle.ellipticGenerator j ^ (-k)) • L t)
+    (k : ℤ) (p : ℝ × RealTorus₄) :
+    gaugeCylinderMap D L a (MappingTorus.deck (Elliptic.flatTorusAffine j v) k p) =
+      gaugeCylinderMap D L a p :=
+  PeriodFamily.Boundary.familyCylinderMap_deck D (Elliptic.flatTorusAffine j v) L
+    (gaugeFibreCylinder a) (SpecialPeriods.Triangle.ellipticGenerator j) hL
+    (gaugeFibreCylinder_deck j v a ha) k p
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.EllipticGaugeLinearization.gaugeBoundaryMap
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (j : Elliptic.Kind)
+    (v : Lattice) (a : C(ℝ, RealPlane₄))
+    (ha :
+      ∀ t, Elliptic.flatLinear j (a (t + 1)) = a t + (1 / (j.order : ℝ)) • Elliptic.realCast v)
+    (L : C(ℝ, SpecialPeriods.TriangleRegularPoint))
+    (hL : ∀ (k : ℤ) t, L (t + k) = (SpecialPeriods.Triangle.ellipticGenerator j ^ (-k)) • L t) :
+    C(MappingTorus.Torus (Elliptic.flatTorusAffine j v), D.Space) :=
+  PeriodFamily.Boundary.Cylinder.descend (Elliptic.flatTorusAffine j v) (gaugeCylinderMap D L a)
+    (gaugeCylinderMap_deck D j v a ha L hL)
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.EllipticGaugeLinearization.gaugeCylinderHomotopy
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (j : Elliptic.Kind)
+    (v : Lattice) (a : C(ℝ, RealPlane₄))
+    (L : C(ℝ, SpecialPeriods.TriangleRegularPoint)) :
+    (gaugeCylinderMap D L a).Homotopy (gaugeCylinderMap D L (linearGauge j v))
+    where
+  toFun
+    p := D.quotient (L p.2.1, p.2.2 + standardLattice.mkQ (gaugeInterpolation j v a (p.1, p.2.1)))
+  continuous_toFun :=
+    D.quotient_continuous.comp
+      ((L.continuous.comp (continuous_fst.comp continuous_snd)).prodMk
+        ((continuous_snd.comp continuous_snd).add
+          (standardLattice.continuous_mkQ.comp
+            ((gaugeInterpolation j v a).continuous.comp
+              (continuous_fst.prodMk (continuous_fst.comp continuous_snd))))))
+  map_zero_left
+    p := by
+    change
+      D.quotient (L p.1, p.2 + standardLattice.mkQ (gaugeInterpolation j v a (0, p.1))) =
+        D.quotient (L p.1, p.2 + standardLattice.mkQ (a p.1))
+    rw [gaugeInterpolation_zero]
+  map_one_left
+    p := by
+    change
+      D.quotient (L p.1, p.2 + standardLattice.mkQ (gaugeInterpolation j v a (1, p.1))) =
+        D.quotient (L p.1, p.2 + standardLattice.mkQ (linearGauge j v p.1))
+    rw [gaugeInterpolation_one]
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.gaugeCylinderHomotopy_deck
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (j : Elliptic.Kind)
+    (v : Lattice) (hv : j.matrix *ᵥ v = v) (a : C(ℝ, RealPlane₄))
+    (ha :
+      ∀ t, Elliptic.flatLinear j (a (t + 1)) = a t + (1 / (j.order : ℝ)) • Elliptic.realCast v)
+    (L : C(ℝ, SpecialPeriods.TriangleRegularPoint))
+    (hL : ∀ (k : ℤ) t, L (t + k) = (SpecialPeriods.Triangle.ellipticGenerator j ^ (-k)) • L t)
+    (s : unitInterval) (k : ℤ) (p : ℝ × RealTorus₄) :
+    gaugeCylinderHomotopy D j v a L (s, MappingTorus.deck (Elliptic.flatTorusAffine j v) k p) =
+      gaugeCylinderHomotopy D j v a L (s, p) :=
+  PeriodFamily.Boundary.familyCylinderMap_deck D (Elliptic.flatTorusAffine j v) L
+    (gaugeFibreCylinder (gaugeInterpolationSlice j v a s))
+    (SpecialPeriods.Triangle.ellipticGenerator j) hL
+    (interpolatedGaugeFibreCylinder_deck j v hv a ha s) k p
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.EllipticGaugeLinearization.gaugeLinearizationHomotopy
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (j : Elliptic.Kind)
+    (v : Lattice) (hv : j.matrix *ᵥ v = v) (a : C(ℝ, RealPlane₄))
+    (ha :
+      ∀ t, Elliptic.flatLinear j (a (t + 1)) = a t + (1 / (j.order : ℝ)) • Elliptic.realCast v)
+    (L : C(ℝ, SpecialPeriods.TriangleRegularPoint))
+    (hL : ∀ (k : ℤ) t, L (t + k) = (SpecialPeriods.Triangle.ellipticGenerator j ^ (-k)) • L t) :
+    (gaugeBoundaryMap D j v a ha L hL).Homotopy
+      (gaugeBoundaryMap D j v (linearGauge j v) (linearGauge_forward j v hv) L hL) :=
+  PeriodFamily.Boundary.Cylinder.descendHomotopy (Elliptic.flatTorusAffine j v)
+    (gaugeCylinderMap D L a) (gaugeCylinderMap D L (linearGauge j v))
+    (gaugeCylinderMap_deck D j v a ha L hL)
+    (gaugeCylinderMap_deck D j v (linearGauge j v) (linearGauge_forward j v hv) L hL)
+    (gaugeCylinderHomotopy D j v a L) (gaugeCylinderHomotopy_deck D j v hv a ha L hL)
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.gaugeBoundaryMap_eq_of_mk
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (j : Elliptic.Kind)
+    (v : Lattice) (a : C(ℝ, RealPlane₄))
+    (ha :
+      ∀ t, Elliptic.flatLinear j (a (t + 1)) = a t + (1 / (j.order : ℝ)) • Elliptic.realCast v)
+    (L : C(ℝ, SpecialPeriods.TriangleRegularPoint))
+    (hL : ∀ (k : ℤ) t, L (t + k) = (SpecialPeriods.Triangle.ellipticGenerator j ^ (-k)) • L t)
+    (F : C(MappingTorus.Torus (Elliptic.flatTorusAffine j v), D.Space))
+    (hF :
+      ∀ t x,
+        F (MappingTorus.mk (Elliptic.flatTorusAffine j v) (t, x)) =
+          D.quotient (L t, x + standardLattice.mkQ (a t))) :
+    F = gaugeBoundaryMap D j v a ha L hL := by
+  apply ContinuousMap.ext
+  intro q
+  obtain ⟨⟨t, x⟩, rfl⟩ := MappingTorus.mk_surjective (Elliptic.flatTorusAffine j v) q
+  exact hF t x
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.EllipticGaugeLinearization.gaugeLinearizationHomotopyOfMk
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (j : Elliptic.Kind)
+    (v : Lattice) (hv : j.matrix *ᵥ v = v) (a : C(ℝ, RealPlane₄))
+    (ha :
+      ∀ t, Elliptic.flatLinear j (a (t + 1)) = a t + (1 / (j.order : ℝ)) • Elliptic.realCast v)
+    (L : C(ℝ, SpecialPeriods.TriangleRegularPoint))
+    (hL : ∀ (k : ℤ) t, L (t + k) = (SpecialPeriods.Triangle.ellipticGenerator j ^ (-k)) • L t)
+    (F : C(MappingTorus.Torus (Elliptic.flatTorusAffine j v), D.Space))
+    (hF :
+      ∀ t x,
+        F (MappingTorus.mk (Elliptic.flatTorusAffine j v) (t, x)) =
+          D.quotient (L t, x + standardLattice.mkQ (a t))) :
+    F.Homotopy (gaugeBoundaryMap D j v (linearGauge j v) (linearGauge_forward j v hv) L hL) :=
+  (gaugeLinearizationHomotopy D j v hv a ha L hL).cast
+    (gaugeBoundaryMap_eq_of_mk D j v a ha L hL F hF).symm rfl
+
+private theorem
+    PeriodFamily.Boundary.EllipticGaugeLinearization.capSectionFibre_coordinateProjection
+    (j : Elliptic.Kind) (s : ℝ) (k : Elliptic.HigherHomology.FibreCoordinates) :
+    PeriodFamily.Boundary.EllipticCapProduct.capSectionFibre j s
+        (PeriodTorusHigherHomology.coordinateProjection 3 k) =
+      standardLattice.mkQ ((s / (j.order : ℝ)) • Elliptic.realCast j.twist + Fin.cons 0 k) := by
+  rw [PeriodFamily.Boundary.EllipticCapProduct.capSectionFibre_apply,
+    Elliptic.HigherHomology.splitFlatTorusHomeomorph_symm_coordinateProjection,
+    Elliptic.HigherHomology.splitRealCoordinates_symm_apply]
+
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.capSectionFibre_linearGauge_cancel
+    (j : Elliptic.Kind) (s : ℝ) (y : PeriodTorusHigherHomology.ProductTorus 3) :
+    PeriodFamily.Boundary.EllipticCapProduct.capSectionFibre j s y +
+        standardLattice.mkQ ((-s / (j.order : ℝ)) • Elliptic.realCast j.twist) =
+      PeriodFamily.Boundary.EllipticCapProduct.capSectionFibre j 0 y := by
+  obtain ⟨k, rfl⟩ := PeriodTorusHigherHomology.coordinateProjection_surjective 3 y
+  rw [capSectionFibre_coordinateProjection,
+    PeriodFamily.Boundary.EllipticCapProduct.capSectionFibre_zero_coordinateProjection, ← map_add]
+  apply congrArg standardLattice.mkQ
+  rw [neg_div, neg_smul]
+  abel
+
+private def
+    PeriodFamily.Boundary.EllipticGaugeLinearization.linearRegularBoundaryMap (j : Elliptic.Kind)
+    (τ : ℝ) :
+    C(ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary j,
+      ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁
+          SpecialPeriods.specialPeriodMap_generator₂)).Space) :=
+  gaugeBoundaryMap
+    (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+      SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+    j j.twist (linearGauge j j.twist) (linearGauge_forward j j.twist j.matrix_fixes_twist)
+    (PeriodFamily.Boundary.nativeShiftedBase j τ)
+    (PeriodFamily.Boundary.nativeShiftedBase_translate j τ)
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.linearRegularBoundaryMap_mk
+    (j : Elliptic.Kind) (τ t : ℝ) (x : RealTorus₄) :
+    linearRegularBoundaryMap j τ (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (t, x)) =
+      ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).quotient
+        (PeriodFamily.Boundary.nativeShiftedBase j τ t,
+          x + standardLattice.mkQ ((t / (j.order : ℝ)) • Elliptic.realCast j.twist)) :=
+  rfl
+
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.nativeRegularBoundaryMap_realLift
+    (j : Elliptic.Kind) (τ t : ℝ) (x : RealTorus₄) :
+    PeriodFamily.Boundary.nativeRegularBoundaryMap j τ
+        (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (t, x)) =
+      ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).quotient
+        (PeriodFamily.Boundary.nativeShiftedBase j τ t,
+          x + standardLattice.mkQ (nativeGaugeRealLift j τ t)) := by
+  rw [PeriodFamily.Boundary.nativeRegularBoundaryMap_mk, nativeGaugeCylinder_realLift]
+
+private def
+  PeriodFamily.Boundary.EllipticGaugeLinearization.nativeRegularBoundaryGaugeLinearizationHomotopy
+    (j : Elliptic.Kind) (τ : ℝ) :
+    (PeriodFamily.Boundary.nativeRegularBoundaryMap j τ).Homotopy
+      (linearRegularBoundaryMap j τ) :=
+  gaugeLinearizationHomotopyOfMk
+    (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+      SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+    j j.twist j.matrix_fixes_twist (nativeGaugeRealLift j τ) (nativeGaugeRealLift_forward j τ)
+    (PeriodFamily.Boundary.nativeShiftedBase j τ)
+    (PeriodFamily.Boundary.nativeShiftedBase_translate j τ)
+    (PeriodFamily.Boundary.nativeRegularBoundaryMap j τ) (nativeRegularBoundaryMap_realLift j τ)
+
+private theorem
+    PeriodFamily.Boundary.EllipticGaugeLinearization.nativeRegularBoundaryMap_homotopic_linear
+    (j : Elliptic.Kind) (τ : ℝ) :
+    (PeriodFamily.Boundary.nativeRegularBoundaryMap j τ).Homotopic
+      (linearRegularBoundaryMap j τ) :=
+  ⟨nativeRegularBoundaryGaugeLinearizationHomotopy j τ⟩
+
+private theorem
+    PeriodFamily.Boundary.EllipticGaugeLinearization.boundaryToRegularFamily_homotopic_linear
+    (j : Elliptic.Kind) (τ : ℝ) :
+    (ThreefoldOverlapMappingTorus.boundaryToRegularFamily (Option.some j)).Homotopic
+      (linearRegularBoundaryMap j τ) :=
+  (ThreefoldOverlapMappingTorus.Elliptic.boundaryToRegularFamily_homotopic_at j
+        (PeriodFamily.Boundary.nativeBoundaryRootRadius j)
+        (PeriodFamily.Boundary.nativeBoundaryRootPhase j + τ)).trans
+    (nativeRegularBoundaryMap_homotopic_linear j τ)
+
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.boundaryRegularHomologyMap_linear
+    (j : Elliptic.Kind) (τ : ℝ) (n : ℕ) :
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some j) n =
+      SingularMayerVietoris.singularHomologyMap (linearRegularBoundaryMap j τ) n :=
+  PeriodTorusHigherHomology.homotopic_homologyMap (boundaryToRegularFamily_homotopic_linear j τ) n
+
+private theorem
+  PeriodFamily.Boundary.EllipticGaugeLinearization.linearRegularBoundaryMap_capSectionFromModel_mk
+    (j : Elliptic.Kind) (τ s : ℝ) (y : PeriodTorusHigherHomology.ProductTorus 3) :
+    linearRegularBoundaryMap j τ
+        (PeriodFamily.Boundary.EllipticCapProduct.capSectionFromModel j
+          (MappingTorus.mk (Elliptic.HigherHomology.fibreTorusHomeomorph j).symm (s, y))) =
+      ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).quotient
+        (PeriodFamily.Boundary.nativeShiftedBase j τ (-s),
+          PeriodFamily.Boundary.EllipticCapProduct.capSectionFibre j 0 y) := by
+  rw [PeriodFamily.Boundary.EllipticCapProduct.capSectionFromModel_mk,
+    linearRegularBoundaryMap_mk, capSectionFibre_linearGauge_cancel]
+
+private theorem PeriodFamily.Boundary.fibreToRegularFamily_cusp_eq_point :
+    ThreefoldOverlapMappingTorus.fibreToRegularFamily Option.none =
+      PeriodFamily.Homology.pointFamilyFibreInclusion
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        (Cusp.baseLift ThreefoldOverlapMappingTorus.Cusp.specialHeight 0) := by
+  apply ContinuousMap.ext
+  intro x
+  exact Cusp.boundaryToRegularFamily_mk 0 x
+
+private theorem PeriodFamily.Boundary.linearRegularBoundaryMap_fibre_eq_point (j : Elliptic.Kind) :
+    (EllipticGaugeLinearization.linearRegularBoundaryMap j 0).comp
+        (MappingTorus.HomologyCover.fibreInclusion (Elliptic.flatTorusAffine j j.twist)) =
+      PeriodFamily.Homology.pointFamilyFibreInclusion
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        (nativeShiftedBase j 0 0) := by
+  apply ContinuousMap.ext
+  intro x
+  change
+    EllipticGaugeLinearization.linearRegularBoundaryMap j 0
+        (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (0, x)) =
+      ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).quotient
+        (nativeShiftedBase j 0 0, x)
+  rw [EllipticGaugeLinearization.linearRegularBoundaryMap_mk]
+  simp only [zero_div, zero_smul, map_zero, add_zero]
+
+private theorem
+    PeriodFamily.Boundary.fibreToRegularFamily_elliptic_homotopic_point (j : Elliptic.Kind) :
+    (ThreefoldOverlapMappingTorus.fibreToRegularFamily (Option.some j)).Homotopic
+      (PeriodFamily.Homology.pointFamilyFibreInclusion
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        (nativeShiftedBase j 0 0)) := by
+  obtain ⟨H⟩ := EllipticGaugeLinearization.boundaryToRegularFamily_homotopic_linear j 0
+  exact
+    ⟨(H.comp
+            (ContinuousMap.Homotopy.refl
+              (MappingTorus.HomologyCover.fibreInclusion
+                (Elliptic.flatTorusAffine j j.twist)))).cast
+        rfl (linearRegularBoundaryMap_fibre_eq_point j)⟩
+
+private theorem PeriodFamily.Boundary.fibreToRegularFamily_homology_common
+    (i : SpecialPeriods.Threefold.Puncture) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap
+        (ThreefoldOverlapMappingTorus.fibreToRegularFamily i) n =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodFamily.Homology.familyFibreInclusion
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          PeriodFamily.Homology.normalizedSlitBaseLift)
+        n := by
+  cases i with
+  | none =>
+    rw [fibreToRegularFamily_cusp_eq_point]
+    exact
+      PeriodFamily.Homology.pointFamilyFibreInclusion_homology_eq_normalized
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        _ n
+  | some j =>
+    exact
+      (PeriodTorusHigherHomology.homotopic_homologyMap
+            (fibreToRegularFamily_elliptic_homotopic_point j) n).trans
+        (PeriodFamily.Homology.pointFamilyFibreInclusion_homology_eq_normalized
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          _ n)
+
+private theorem PeriodFamily.Boundary.boundaryRegularHomologyMap_common_fibre
+    (i : SpecialPeriods.Threefold.Puncture) (n : ℕ) :
+    (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap i n).comp
+        (MappingTorusHomology.fibreHomologyMap (ThreefoldOverlapMappingTorus.monodromy i) n) =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodFamily.Homology.familyFibreInclusion
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          PeriodFamily.Homology.normalizedSlitBaseLift)
+        n :=
+  (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap_fibre i n).trans
+    (fibreToRegularFamily_homology_common i n)
+
+private theorem PeriodFamily.Boundary.boundaryRegularHomologyMap_common_fibre_apply
+    (i : SpecialPeriods.Threefold.Puncture) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap i n
+        (MappingTorusHomology.fibreHomologyMap (ThreefoldOverlapMappingTorus.monodromy i) n a) =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodFamily.Homology.familyFibreInclusion
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          PeriodFamily.Homology.normalizedSlitBaseLift)
+        n a :=
+  LinearMap.congr_fun (boundaryRegularHomologyMap_common_fibre i n) a
+
+/-- Negation on the unit circle as a homeomorphism. -/
+public
+def PeriodFamily.Boundary.EllipticTopFibre.circleNegation :
+    C((PeriodTorusHigherHomology.CircleTopology.Circle),
+      (PeriodTorusHigherHomology.CircleTopology.Circle)) :=
+  ⟨fun z => -z, ContinuousNeg.continuous_neg⟩
+
+@[simp]
+public
+theorem PeriodFamily.Boundary.EllipticTopFibre.circleNegation_zero : circleNegation 0 = 0 :=
+  neg_zero
+
+private theorem PeriodFamily.Boundary.EllipticTopFibre.circleNegation_positiveLoop :
+    PeriodTorusHigherHomology.CirclePaths.positiveLoop.map circleNegation.continuous =
+      PeriodTorusHigherHomology.CirclePaths.positiveLoop.symm.cast circleNegation_zero
+        circleNegation_zero := by
+  apply Path.ext
+  funext t
+  change
+    -((t : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle)) =
+      (((1 - (t : ℝ)) : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle))
+  rw [AddCircle.coe_sub, AddCircle.coe_period, zero_sub]
+
+private theorem PeriodFamily.Boundary.EllipticTopFibre.circleNegation_positiveHomology :
+    SingularMayerVietoris.singularHomologyMap circleNegation 1
+        (FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop) =
+      -FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop := by
+  rw [SingularMayerVietoris.singularHomologyMap_one,
+    FirstHurewicz.inducedHomology_loopHomologyClass, circleNegation_positiveLoop]
+  apply
+    FirstHurewicz.homologyToChainClass_injective (PeriodTorusHigherHomology.CircleTopology.Circle)
+  rw [FirstHurewicz.homologyToChainClass_loopHomologyClass, map_neg,
+    FirstHurewicz.homologyToChainClass_loopHomologyClass, FirstHurewicz.pathClass_cast,
+    FirstHurewicz.pathClass_symm]
+
+private def PeriodFamily.Boundary.EllipticTopFibre.productNegation :
+    C((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+        PeriodTorusHigherHomology.ProductTorus 3,
+      (PeriodTorusHigherHomology.CircleTopology.Circle) ×
+        PeriodTorusHigherHomology.ProductTorus 3) :=
+  circleNegation.prodMap (ContinuousMap.id (PeriodTorusHigherHomology.ProductTorus 3))
+
+private theorem PeriodFamily.Boundary.EllipticTopFibre.productNegation_positiveCircleCross
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) 3) :
+    SingularMayerVietoris.singularHomologyMap productNegation 4
+        (PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 3)
+          3 a) =
+      -PeriodTorusHigherHomology.positiveCircleCross (PeriodTorusHigherHomology.ProductTorus 3) 3
+          a := by
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (circleNegation.prodMap (ContinuousMap.id (PeriodTorusHigherHomology.ProductTorus 3))) 4
+        (PeriodTorusHigherHomology.crossProductHomology
+          (PeriodTorusHigherHomology.CircleTopology.Circle)
+          (PeriodTorusHigherHomology.ProductTorus 3) 3
+          (FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop)
+          a) =
+      _
+  rw [PeriodTorusHigherHomology.crossProductHomology_natural, circleNegation_positiveHomology]
+  change
+    PeriodTorusHigherHomology.crossProductHomology
+        (PeriodTorusHigherHomology.CircleTopology.Circle)
+        (PeriodTorusHigherHomology.ProductTorus 3) 3
+        (-FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop)
+        (SingularMayerVietoris.singularHomologyMap
+          (ContinuousMap.id (PeriodTorusHigherHomology.ProductTorus 3)) 3 a) =
+      _
+  rw [PeriodTorusHigherHomology.singularHomologyMap_id, LinearMap.id_apply, map_neg,
+    LinearMap.neg_apply]
+  rfl
+
+private theorem PeriodFamily.Boundary.EllipticTopFibre.productNegation_homology_four
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) ×
+          PeriodTorusHigherHomology.ProductTorus 3)
+        4) :
+    SingularMayerVietoris.singularHomologyMap productNegation 4 a = -a := by
+  obtain ⟨b, rfl⟩ := PeriodFamily.Homology.circleTopDegreeEquiv.symm.surjective a
+  rw [PeriodFamily.Homology.circleTopDegreeEquiv_symm_apply]
+  exact productNegation_positiveCircleCross b
+
+private def PeriodFamily.Boundary.EllipticTopFibre.headReflectionMatrix : LatticeMatrix :=
+  !![-1, 0, 0, 0; 0, 1, 0, 0; 0, 0, 1, 0; 0, 0, 0, 1]
+
+private theorem PeriodFamily.Boundary.EllipticTopFibre.headReflectionMatrix_circleMap :
+    PeriodFamily.Homology.topDegreeCircleMap headReflectionMatrix = productNegation := by
+  apply ContinuousMap.ext
+  rintro ⟨z, x⟩
+  apply Prod.ext
+  · change (∑ i : Fin 4, headReflectionMatrix 0 i • Fin.cons z x i) = -z
+    simp [headReflectionMatrix, Fin.sum_univ_succ]
+  · funext i
+    change (∑ k : Fin 4, headReflectionMatrix i.succ k • Fin.cons z x k) = x i
+    fin_cases i <;> simp [headReflectionMatrix, Fin.sum_univ_succ]
+
+private theorem PeriodFamily.Boundary.EllipticTopFibre.headReflectionMatrix_homology_four
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 4) :
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.torusMatrixMap headReflectionMatrix) 4 a =
+      -a := by
+  apply
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+        (PeriodTorusHigherHomology.productTorusSuccHomeomorph 3) 4).injective
+  rw [PeriodTorusHigherHomology.homeomorphHomologyEquiv_apply,
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv_apply]
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp, ←
+    PeriodFamily.Homology.topDegreeCircleMap_comp_homeomorph,
+    PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply,
+    headReflectionMatrix_circleMap, productNegation_homology_four, map_neg]
+
+private theorem PeriodFamily.Boundary.EllipticTopFibre.twistBasisInvMatrix_homology_four
+    (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 4) :
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.torusMatrixMap (Elliptic.HigherHomology.twistBasisInvMatrix j))
+        4 a =
+      γ j.twist • a := by
+  cases j with
+  |
+    three =>
+    have h :=
+      PeriodFamily.Homology.torusMatrixMap_homologyFour_of_det_one
+        (Elliptic.HigherHomology.twistBasisInvMatrix .three) (by intro i; fin_cases i <;> decide)
+        (by decide)
+    rw [h, LinearMap.id_apply]
+    simp [γ, Elliptic.Kind.twist, ε]
+  |
+    four =>
+    have hfirst :
+      ∀ i,
+        (Elliptic.HigherHomology.twistBasisInvMatrix .four * headReflectionMatrix) 0 i =
+          if i = 0 then 1 else 0 := by
+      intro i
+      fin_cases i <;> decide
+    have hdet :
+      (Elliptic.HigherHomology.twistBasisInvMatrix .four * headReflectionMatrix).det = 1 := by
+      decide
+    have hfactor :
+      (Elliptic.HigherHomology.twistBasisInvMatrix .four * headReflectionMatrix) *
+          headReflectionMatrix =
+        Elliptic.HigherHomology.twistBasisInvMatrix .four := by decide
+    have h :=
+      PeriodFamily.Homology.torusMatrixMap_homologyFour_of_det_one
+        (Elliptic.HigherHomology.twistBasisInvMatrix .four * headReflectionMatrix) hfirst hdet
+    rw [← hfactor, PeriodTorusHigherHomology.torusMatrixMap_mul,
+      PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply, h,
+      LinearMap.id_apply, headReflectionMatrix_homology_four]
+    simp [γ, Elliptic.Kind.twist, ε']
+
+private def PeriodFamily.Boundary.EllipticTopFibre.coordinateTopEquiv :
+    SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 4 ≃ₗ[ℤ] ℤ :=
+  (PeriodTorusHigherHomology.productTorusHomologyEquiv 4 4).trans
+    (PeriodTorusHigherHomology.integerBinomialZeroEquiv 4).symm
+
+@[simp]
+private theorem PeriodFamily.Boundary.EllipticTopFibre.coordinateTopEquiv_topClass :
+    coordinateTopEquiv (PeriodTorusHigherHomology.productTorusTopClass 4) = 1 := by
+  change
+    PeriodTorusHigherHomology.productTorusHomologyEquiv 4 4
+        (PeriodTorusHigherHomology.productTorusTopClass 4) ⟨0, by decide⟩ =
+      1
+  rw [PeriodTorusHigherHomology.productTorusHomologyEquiv_topClass]
+
+private theorem PeriodFamily.Boundary.EllipticTopFibre.coordinateTopEquiv_smul_topClass
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 4) :
+    a = coordinateTopEquiv a • PeriodTorusHigherHomology.productTorusTopClass 4 := by
+  apply coordinateTopEquiv.injective
+  rw [map_zsmul, coordinateTopEquiv_topClass, zsmul_eq_mul, mul_one]
+  simp only [Int.cast_id]
+
+private theorem
+    PeriodFamily.Boundary.EllipticTopFibre.topDegreeTorusCoordinates_eq_coordinateTopEquiv
+    (a : SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 4) 4) :
+    PeriodFamily.Homology.topDegreeTorusCoordinates a = coordinateTopEquiv a := by
+  conv_lhs => rw [coordinateTopEquiv_smul_topClass a]
+  rw [map_zsmul, PeriodFamily.Homology.topDegreeTorusCoordinates_topClass, zsmul_eq_mul, mul_one]
+  simp only [Int.cast_id]
+
+private theorem PeriodFamily.Boundary.EllipticTopFibre.coordinateTopEquiv_flat
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 4) :
+    coordinateTopEquiv
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+          PeriodTorusHigherHomology.flatTorusCircleHomeomorph 4 a) =
+      PeriodTorusHigherHomology.realTorusH4Equiv a := by
+  change
+    PeriodTorusHigherHomology.productTorusHomologyEquiv 4 4
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+          PeriodTorusHigherHomology.flatTorusCircleHomeomorph 4 a)
+        ⟨0, by decide⟩ =
+      PeriodTorusHigherHomology.realTorusHomologyEquiv 4 a ⟨0, by decide⟩
+  rw [PeriodTorusHigherHomology.realTorusHomologyEquiv_apply,
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv_apply]
+
+private theorem
+    PeriodFamily.Boundary.EllipticTopFibre.splitFlatTorus_top_boundary (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 4) :
+    Elliptic.HigherHomology.torusH3Coordinates
+        (PeriodTorusHigherHomology.circleBoundary (PeriodTorusHigherHomology.ProductTorus 3) 3
+          (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+            (Elliptic.HigherHomology.splitFlatTorusHomeomorph j) 4 a)) =
+      γ j.twist * PeriodTorusHigherHomology.realTorusH4Equiv a := by
+  rw [Elliptic.HigherHomology.splitFlatTorusHomeomorph,
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv_trans, LinearEquiv.trans_apply,
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv_trans, LinearEquiv.trans_apply]
+  change
+    PeriodFamily.Homology.topDegreeTorusCoordinates
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.torusMatrixMap
+            (Elliptic.HigherHomology.twistBasisInvMatrix j))
+          4
+          (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+            PeriodTorusHigherHomology.flatTorusCircleHomeomorph 4 a)) =
+      _
+  rw [twistBasisInvMatrix_homology_four, map_zsmul,
+    topDegreeTorusCoordinates_eq_coordinateTopEquiv, zsmul_eq_mul, Int.cast_id,
+    coordinateTopEquiv_flat]
+
+private theorem
+    PeriodFamily.Boundary.EllipticTopFibre.splitPeriod_comp_flatPeriod (j : Elliptic.Kind)
+    (p : PeriodDomain) :
+    (Elliptic.HigherHomology.splitPeriodTorusHomeomorph j p :
+            C(p.Torus, AddCircle (1 : ℝ) × PeriodTorusHigherHomology.ProductTorus 3)).comp
+        (Elliptic.flatTorusPeriodHomeomorph p : C(RealTorus₄, p.Torus)) =
+      (Elliptic.HigherHomology.splitFlatTorusHomeomorph j :
+        C(RealTorus₄, AddCircle (1 : ℝ) × PeriodTorusHigherHomology.ProductTorus 3)) := by
+  apply ContinuousMap.ext
+  intro x
+  change
+    Elliptic.HigherHomology.splitFlatTorusHomeomorph j
+        ((Elliptic.flatTorusPeriodHomeomorph p).symm (Elliptic.flatTorusPeriodHomeomorph p x)) =
+      _
+  rw [Homeomorph.symm_apply_apply]
+  rfl
+
+private theorem PeriodFamily.Boundary.EllipticTopFibre.surfacePeriodCoverCircleBoundary_flat
+    (j : Elliptic.Kind) (p : Elliptic.FixedPeriod j)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 4) :
+    Elliptic.HigherHomology.torusH3Coordinates
+        (Elliptic.HigherHomology.surfacePeriodCoverCircleBoundary j p 3
+          (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+            (Elliptic.flatTorusPeriodHomeomorph p.val) 4 a)) =
+      γ j.twist * PeriodTorusHigherHomology.realTorusH4Equiv a := by
+  rw [Elliptic.HigherHomology.surfacePeriodCoverCircleBoundary_apply,
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv_apply,
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv_apply]
+  have hc :
+    (SingularMayerVietoris.singularHomologyMap
+            (Elliptic.HigherHomology.splitPeriodTorusHomeomorph j p.val :
+              C(p.val.Torus, AddCircle (1 : ℝ) × PeriodTorusHigherHomology.ProductTorus 3))
+            4).comp
+        (SingularMayerVietoris.singularHomologyMap
+          (Elliptic.flatTorusPeriodHomeomorph p.val : C(RealTorus₄, p.val.Torus)) 4) =
+      SingularMayerVietoris.singularHomologyMap
+        (Elliptic.HigherHomology.splitFlatTorusHomeomorph j :
+          C(RealTorus₄, AddCircle (1 : ℝ) × PeriodTorusHigherHomology.ProductTorus 3))
+        4 := by
+    rw [← PeriodTorusHigherHomology.singularHomologyMap_comp, splitPeriod_comp_flatPeriod]
+  exact
+    (congrArg
+          (fun b =>
+            Elliptic.HigherHomology.torusH3Coordinates
+              (PeriodTorusHigherHomology.circleBoundary (PeriodTorusHigherHomology.ProductTorus 3)
+                3 b))
+          (LinearMap.congr_fun hc a)).trans
+      (splitFlatTorus_top_boundary j a)
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/PeriodFamily/Core8.lean b/LeanPool/HopfProblem/PeriodFamily/Core8.lean
new file mode 100644
index 000000000..4ab30edc5
--- /dev/null
+++ b/LeanPool/HopfProblem/PeriodFamily/Core8.lean
@@ -0,0 +1,893 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology3
+public import LeanPool.HopfProblem.Recognition.Smale11
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology7
+import all LeanPool.HopfProblem.PeriodFamily.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods6
+import all LeanPool.HopfProblem.PeriodFamily.Core2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import all LeanPool.HopfProblem.Elliptic.Core3
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods8
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen2
+import all LeanPool.HopfProblem.Elliptic.Core5
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods9
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology2
+import all LeanPool.HopfProblem.PeriodFamily.Core3
+import all LeanPool.HopfProblem.PeriodFamily.Core4
+import all LeanPool.HopfProblem.PeriodFamily.Core5
+import all LeanPool.HopfProblem.Elliptic.Core7
+import all LeanPool.HopfProblem.PeriodFamily.Core6
+import all LeanPool.HopfProblem.PeriodFamily.Core7
+import all LeanPool.HopfProblem.Recognition.Smale11
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology3
+
+/-!
+# Hopf problem: period family · core 8
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem
+    PeriodFamily.Boundary.EllipticTopFibre.centralRealCover_h4_coordinates (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 4) :
+    Elliptic.HigherHomology.surfaceH4Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+        (SingularMayerVietoris.singularHomologyMap
+          (ThreefoldHomology.EllipticFibre.centralRealCover j) 4 a) =
+      (j.order : ℤ) * γ j.twist * PeriodTorusHigherHomology.realTorusH4Equiv a := by
+  rw [ThreefoldHomology.EllipticFibre.centralRealCover,
+    PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply]
+  change
+    Elliptic.HigherHomology.surfacePeriodCoverH4Coordinates j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+          (Elliptic.flatTorusPeriodHomeomorph
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod.val)
+          4 a) =
+      _
+  rw [Elliptic.HigherHomology.surfacePeriodCoverH4Coordinates_apply,
+    surfacePeriodCoverCircleBoundary_flat]
+  ring
+
+private theorem
+    PeriodFamily.Boundary.EllipticTopFibre.fibreToFilling_h4_coordinates (j : Elliptic.Kind)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 4) :
+    Elliptic.HigherHomology.surfaceH4Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+        (ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j 4
+          (SingularMayerVietoris.singularHomologyMap
+            (ThreefoldOverlapMappingTorus.fibreToFilling (Option.some j)) 4 a)) =
+      (j.order : ℤ) * γ j.twist * PeriodTorusHigherHomology.realTorusH4Equiv a := by
+  have h :=
+    LinearMap.congr_fun (ThreefoldHomology.EllipticFibre.fibreToFilling_homology_retraction j 4) a
+  change
+    ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j 4
+        (SingularMayerVietoris.singularHomologyMap
+          (ThreefoldOverlapMappingTorus.fibreToFilling (Option.some j)) 4 a) =
+      SingularMayerVietoris.singularHomologyMap
+        (Elliptic.HigherHomology.periodCover j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+          (Elliptic.mainTwist_admissible j))
+        4 (ThreefoldHomology.EllipticFibre.centralPeriodHomologyEquiv j 4 a) at h
+  refine
+    (congrArg
+          (Elliptic.HigherHomology.surfaceH4Equiv j
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod)
+          h).trans
+      ?_
+  have hc := centralRealCover_h4_coordinates j a
+  rw [ThreefoldHomology.EllipticFibre.centralRealCover,
+    PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply] at hc
+  exact hc
+
+private theorem PeriodFamily.Boundary.EllipticTopFibre.boundaryFilling_fibre_h4_coordinates
+    (j : Elliptic.Kind) (a : SingularMayerVietoris.SingularHomology RealTorus₄ 4) :
+    Elliptic.HigherHomology.surfaceH4Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+        (ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j 4
+          (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) 4
+            (MappingTorusHomology.fibreHomologyMap
+              (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) 4 a))) =
+      (j.order : ℤ) * γ j.twist * PeriodTorusHigherHomology.realTorusH4Equiv a := by
+  have h :=
+    LinearMap.congr_fun
+      (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap_fibre (Option.some j) 4) a
+  change
+    ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap (Option.some j) 4
+        (MappingTorusHomology.fibreHomologyMap
+          (ThreefoldOverlapMappingTorus.monodromy (Option.some j)) 4 a) =
+      SingularMayerVietoris.singularHomologyMap
+        (ThreefoldOverlapMappingTorus.fibreToFilling (Option.some j)) 4 a at h
+  exact
+    (congrArg
+          (fun b =>
+            Elliptic.HigherHomology.surfaceH4Equiv j
+              (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+              (ThreefoldHomology.Finiteness.ellipticPieceRetractionHomologyEquiv j 4 b))
+          h).trans
+      (fibreToFilling_h4_coordinates j a)
+
+private def PeriodFamily.GammaZero.fibreGamma : C(RealTorus₄, AddCircle (1 : ℝ)) :=
+  ⟨fun x => PeriodTorusHigherHomology.flatTorusCircleHomeomorph x 0,
+    (continuous_apply 0).comp PeriodTorusHigherHomology.flatTorusCircleHomeomorph.continuous⟩
+
+private theorem PeriodFamily.GammaZero.fibreGamma_mkQ (x : RealPlane₄) :
+    fibreGamma (standardLattice.mkQ x) = (x 0 : AddCircle (1 : ℝ)) := by
+  change PeriodTorusHigherHomology.flatTorusCircleHomeomorph (standardLattice.mkQ x) 0 = _
+  rw [PeriodTorusHigherHomology.flatTorusCircleHomeomorph_mkQ]
+  rfl
+
+private abbrev PeriodFamily.GammaZero.Fibre :=
+  { x : RealTorus₄ // fibreGamma x = 0 }
+
+private def PeriodFamily.GammaZero.fibreInclusion : C(Fibre, RealTorus₄) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private def
+    PeriodFamily.GammaZero.fibreHomeomorph : Fibre ≃ₜ PeriodTorusHigherHomology.ProductTorus 3
+    where
+  toFun x i := PeriodTorusHigherHomology.flatTorusCircleHomeomorph x.val i.succ
+  invFun
+    y :=
+    ⟨PeriodTorusHigherHomology.flatTorusCircleHomeomorph.symm (Fin.cons 0 y),
+      by
+      change
+        PeriodTorusHigherHomology.flatTorusCircleHomeomorph
+            (PeriodTorusHigherHomology.flatTorusCircleHomeomorph.symm (Fin.cons 0 y)) 0 =
+          0
+      rw [Homeomorph.apply_symm_apply]
+      rfl⟩
+  left_inv
+    x := by
+    apply Subtype.ext
+    apply PeriodTorusHigherHomology.flatTorusCircleHomeomorph.injective
+    rw [Homeomorph.apply_symm_apply]
+    funext i
+    refine Fin.cases ?_ (fun j => ?_) i
+    · exact x.property.symm
+    · rfl
+  right_inv
+    y := by
+    funext i
+    exact
+      congrFun
+        (PeriodTorusHigherHomology.flatTorusCircleHomeomorph.apply_symm_apply (Fin.cons 0 y))
+        i.succ
+  continuous_toFun :=
+    continuous_pi fun i =>
+      (continuous_apply i.succ).comp
+        (PeriodTorusHigherHomology.flatTorusCircleHomeomorph.continuous.comp
+          continuous_subtype_val)
+  continuous_invFun := by
+    apply Continuous.subtype_mk
+    exact
+      PeriodTorusHigherHomology.flatTorusCircleHomeomorph.symm.continuous.comp
+        ((PeriodTorusHigherHomology.productTorusSuccHomeomorph 3).symm.continuous.comp
+          (continuous_const.prodMk continuous_id))
+
+private def PeriodFamily.GammaZero.fibreMkQ (x : Fin 3 → ℝ) : Fibre :=
+  ⟨standardLattice.mkQ (Fin.cons 0 x), by rw [fibreGamma_mkQ]; rfl⟩
+
+@[simp]
+private theorem PeriodFamily.GammaZero.fibreHomeomorph_mkQ (x : Fin 3 → ℝ) :
+    fibreHomeomorph (fibreMkQ x) = PeriodTorusHigherHomology.coordinateProjection 3 x := by
+  funext i
+  change
+    PeriodTorusHigherHomology.flatTorusCircleHomeomorph (standardLattice.mkQ (Fin.cons 0 x))
+        i.succ =
+      _
+  rw [PeriodTorusHigherHomology.flatTorusCircleHomeomorph_mkQ]
+  rfl
+
+private theorem PeriodFamily.GammaZero.fibreHomeomorph_symm_coordinateProjection (x : Fin 3 → ℝ) :
+    (fibreHomeomorph.symm (PeriodTorusHigherHomology.coordinateProjection 3 x)).val =
+      standardLattice.mkQ (Fin.cons 0 x) := by
+  have h :
+    fibreHomeomorph.symm (PeriodTorusHigherHomology.coordinateProjection 3 x) = fibreMkQ x := by
+    apply fibreHomeomorph.injective
+    rw [Homeomorph.apply_symm_apply, fibreHomeomorph_mkQ]
+  exact congrArg Subtype.val h
+
+private def PeriodFamily.GammaZero.fibreRetraction : C(RealTorus₄, Fibre) :=
+  ⟨fun x =>
+    fibreHomeomorph.symm (fun i => PeriodTorusHigherHomology.flatTorusCircleHomeomorph x i.succ),
+    fibreHomeomorph.symm.continuous.comp
+      (continuous_pi fun i =>
+        (continuous_apply i.succ).comp
+          PeriodTorusHigherHomology.flatTorusCircleHomeomorph.continuous)⟩
+
+@[simp]
+private theorem PeriodFamily.GammaZero.fibreRetraction_inclusion (x : Fibre) :
+    fibreRetraction (fibreInclusion x) = x :=
+  fibreHomeomorph.symm_apply_apply x
+
+private theorem PeriodFamily.GammaZero.triangleRealEquiv_generator₁_gamma (x : RealPlane₄) :
+    SpecialPeriods.triangleRealEquiv SpecialPeriods.triangleGenerator₁ x 0 = x 0 := by
+  rw [SpecialPeriods.triangleRealEquiv_apply,
+    SpecialPeriods.triangleDualRepresentation_generator₁_matrix]
+  simp [A₁, Matrix.mulVec, dotProduct, Fin.sum_univ_four]
+
+private theorem PeriodFamily.GammaZero.triangleRealEquiv_generator₂_gamma (x : RealPlane₄) :
+    SpecialPeriods.triangleRealEquiv SpecialPeriods.triangleGenerator₂ x 0 = x 0 := by
+  rw [SpecialPeriods.triangleRealEquiv_apply,
+    SpecialPeriods.triangleDualRepresentation_generator₂_matrix]
+  simp [A₂, Matrix.mulVec, dotProduct, Fin.sum_univ_four]
+
+public
+theorem PeriodFamily.GammaZero.triangleRealEquiv_gamma (g : SpecialPeriods.TriangleGroup)
+    (x : RealPlane₄) : SpecialPeriods.triangleRealEquiv g x 0 = x 0 := by
+  have hg :
+    g ∈
+      Subgroup.closure
+        ({ SpecialPeriods.triangleGenerator₁, SpecialPeriods.triangleGenerator₂ } :
+          Set SpecialPeriods.TriangleGroup) := by
+    rw [SpecialPeriods.triangle_generators_generate]
+    exact Subgroup.mem_top g
+  have h : ∀ x : RealPlane₄, SpecialPeriods.triangleRealEquiv g x 0 = x 0 := by
+    induction hg using Subgroup.closure_induction with
+    | mem g hg =>
+      rcases Set.mem_insert_iff.mp hg with rfl | hg
+      · exact triangleRealEquiv_generator₁_gamma
+      · have he : g = SpecialPeriods.triangleGenerator₂ := Set.mem_singleton_iff.mp hg
+        subst g
+        exact triangleRealEquiv_generator₂_gamma
+    | one =>
+      intro y
+      rw [SpecialPeriods.triangleRealEquiv_one]
+      rfl
+    | mul g h _ _ ihg ihh =>
+      intro y
+      rw [SpecialPeriods.triangleRealEquiv_mul_apply, ihg, ihh]
+    | inv g _ ihg =>
+      intro y
+      have hy := ihg (SpecialPeriods.triangleRealEquiv g⁻¹ y)
+      rw [← SpecialPeriods.triangleRealEquiv_mul_apply, mul_inv_cancel,
+        SpecialPeriods.triangleRealEquiv_one] at hy
+      exact hy.symm
+  exact h x
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+@[simp]
+private theorem PeriodFamily.GammaZero.fibreGamma_triangleTorusHomeomorph
+    (g : SpecialPeriods.TriangleGroup) (x : RealTorus₄) :
+    fibreGamma (SpecialPeriods.triangleTorusHomeomorph g x) = fibreGamma x := by
+  obtain ⟨v, rfl⟩ := standardLattice.mkQ_surjective x
+  rw [SpecialPeriods.triangleTorusHomeomorph_mkQ, fibreGamma_mkQ, fibreGamma_mkQ,
+    triangleRealEquiv_gamma]
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.GammaZero.familyGamma
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) : C(D.Space, AddCircle (1 : ℝ))
+    where
+  toFun :=
+    Quotient.lift (fun x : SpecialPeriods.TriangleRegularPoint × RealTorus₄ => fibreGamma x.2)
+      (by
+        rintro x y ⟨g, hg⟩
+        have he : SpecialPeriods.triangleTorusHomeomorph g y.2 = x.2 := congrArg Prod.snd hg
+        rw [← he, fibreGamma_triangleTorusHomeomorph])
+  continuous_toFun :=
+    D.quotient_isQuotientMap.continuous_iff.mpr (fibreGamma.continuous.comp continuous_snd)
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+@[simp]
+private theorem PeriodFamily.GammaZero.familyGamma_quotient
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (b : SpecialPeriods.TriangleRegularPoint) (x : RealTorus₄) :
+    familyGamma D (D.quotient (b, x)) = fibreGamma x :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private abbrev PeriodFamily.GammaZero.Space
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :=
+  { x : D.Space // familyGamma D x = 0 }
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.GammaZero.inclusion
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) : C(Space D, D.Space) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.GammaZero.projection
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    C(Space D, SpecialPeriods.TriangleRegularQuotient) :=
+  ⟨fun x => D.projection x.val, D.projection_continuous.comp continuous_subtype_val⟩
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.GammaZero.quotient
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    C(SpecialPeriods.TriangleRegularPoint × Fibre, Space D)
+    where
+  toFun
+    x :=
+    ⟨PeriodFamily.Data.quotient D (x.1, x.2.val),
+      (familyGamma_quotient D x.1 x.2.val).trans x.2.property⟩
+  continuous_toFun :=
+    ((PeriodFamily.Data.quotient_continuous D).comp
+          (continuous_fst.prodMk (continuous_subtype_val.comp continuous_snd))).subtype_mk
+      _
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def
+    PeriodFamily.GammaZero.lift (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    {X : Type*} [TopologicalSpace X] (f : C(X, D.Space)) (hf : ∀ x, familyGamma D (f x) = 0) :
+    C(X, Space D) :=
+  ⟨fun x => ⟨f x, hf x⟩, f.continuous.subtype_mk _⟩
+
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.capSectionFibre_zero_gamma
+    (j : Elliptic.Kind) (y : PeriodTorusHigherHomology.ProductTorus 3) :
+    PeriodFamily.GammaZero.fibreGamma
+        (PeriodFamily.Boundary.EllipticCapProduct.capSectionFibre j 0 y) =
+      0 := by
+  obtain ⟨k, rfl⟩ := PeriodTorusHigherHomology.coordinateProjection_surjective 3 y
+  rw [PeriodFamily.Boundary.EllipticCapProduct.capSectionFibre_zero_coordinateProjection,
+    PeriodFamily.GammaZero.fibreGamma_mkQ]
+  simp only [Fin.cons_zero, AddCircle.coe_zero]
+
+private theorem
+    PeriodFamily.Boundary.EllipticGaugeLinearization.familyGamma_linear_capSectionFromModel
+    (j : Elliptic.Kind) (τ : ℝ) (q : Elliptic.HigherHomology.mappingTorusModel j) :
+    PeriodFamily.GammaZero.familyGamma
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        (linearRegularBoundaryMap j τ
+          (PeriodFamily.Boundary.EllipticCapProduct.capSectionFromModel j q)) =
+      0 := by
+  obtain ⟨⟨s, y⟩, rfl⟩ :=
+    MappingTorus.mk_surjective (Elliptic.HigherHomology.fibreTorusHomeomorph j).symm q
+  rw [linearRegularBoundaryMap_capSectionFromModel_mk,
+    PeriodFamily.GammaZero.familyGamma_quotient]
+  exact capSectionFibre_zero_gamma j y
+
+private theorem PeriodFamily.Boundary.EllipticGaugeLinearization.familyGamma_linear_capSection
+    (j : Elliptic.Kind) (τ : ℝ)
+    (q : ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface j) :
+    PeriodFamily.GammaZero.familyGamma
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        (linearRegularBoundaryMap j τ (PeriodFamily.Boundary.EllipticCapProduct.capSection j q)) =
+      0 := by
+  obtain ⟨x, rfl⟩ :=
+    (Elliptic.HigherHomology.surfaceMappingTorusHomeomorph j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).symm.surjective
+      q
+  exact familyGamma_linear_capSectionFromModel j τ x
+
+private def
+    PeriodFamily.Boundary.EllipticGaugeLinearization.capSectionGammaZeroMap (j : Elliptic.Kind)
+    (τ : ℝ) :
+    C(ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface j,
+      PeriodFamily.GammaZero.Space
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁
+          SpecialPeriods.specialPeriodMap_generator₂)) :=
+  PeriodFamily.GammaZero.lift
+    (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+      SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+    ((linearRegularBoundaryMap j τ).comp (PeriodFamily.Boundary.EllipticCapProduct.capSection j))
+    (familyGamma_linear_capSection j τ)
+
+@[simp]
+private theorem
+    PeriodFamily.Boundary.EllipticGaugeLinearization.inclusion_comp_capSectionGammaZeroMap
+    (j : Elliptic.Kind) (τ : ℝ) :
+    (PeriodFamily.GammaZero.inclusion
+            (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)).comp
+        (capSectionGammaZeroMap j τ) =
+      (linearRegularBoundaryMap j τ).comp
+        (PeriodFamily.Boundary.EllipticCapProduct.capSection j) :=
+  rfl
+
+private theorem
+  PeriodFamily.Boundary.EllipticGaugeLinearization.boundaryRegular_capSection_homotopic_gammaZero
+    (j : Elliptic.Kind) (τ : ℝ) :
+    ((ThreefoldOverlapMappingTorus.boundaryToRegularFamily (Option.some j)).comp
+          (PeriodFamily.Boundary.EllipticCapProduct.capSection j)).Homotopic
+      ((PeriodFamily.GammaZero.inclusion
+            (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)).comp
+        (capSectionGammaZeroMap j τ)) := by
+  rw [inclusion_comp_capSectionGammaZeroMap]
+  exact
+    (boundaryToRegularFamily_homotopic_linear j τ).comp
+      (ContinuousMap.Homotopic.refl (PeriodFamily.Boundary.EllipticCapProduct.capSection j))
+
+private theorem
+  PeriodFamily.Boundary.EllipticGaugeLinearization.boundaryRegularHomologyMap_capSection_factor
+    (j : Elliptic.Kind) (τ : ℝ) (n : ℕ) :
+    (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some j) n).comp
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodFamily.Boundary.EllipticCapProduct.capSection j) n) =
+      (SingularMayerVietoris.singularHomologyMap
+            (PeriodFamily.GammaZero.inclusion
+              (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                SpecialPeriods.specialPeriodMap_generator₁
+                SpecialPeriods.specialPeriodMap_generator₂))
+            n).comp
+        (SingularMayerVietoris.singularHomologyMap (capSectionGammaZeroMap j τ) n) := by
+  exact
+    (PeriodTorusHigherHomology.singularHomologyMap_comp
+          (PeriodFamily.Boundary.EllipticCapProduct.capSection j)
+          (ThreefoldOverlapMappingTorus.boundaryToRegularFamily (Option.some j)) n).symm.trans
+      ((PeriodTorusHigherHomology.homotopic_homologyMap
+            (boundaryRegular_capSection_homotopic_gammaZero j τ) n).trans
+        (PeriodTorusHigherHomology.singularHomologyMap_comp (capSectionGammaZeroMap j τ)
+          (PeriodFamily.GammaZero.inclusion
+            (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂))
+          n))
+
+private theorem
+  PeriodFamily.Boundary.EllipticGaugeLinearization.boundaryRegularHomologyMap_capSection_mem_range
+    (j : Elliptic.Kind) (τ : ℝ) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface j) n) :
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some j) n
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodFamily.Boundary.EllipticCapProduct.capSection j) n a) ∈
+      LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodFamily.GammaZero.inclusion
+            (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂))
+          n) := by
+  refine ⟨SingularMayerVietoris.singularHomologyMap (capSectionGammaZeroMap j τ) n a, ?_⟩
+  exact (LinearMap.congr_fun (boundaryRegularHomologyMap_capSection_factor j τ n) a).symm
+
+private def PeriodFamily.GammaZero.familyOpen
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (U : TopologicalSpace.Opens SpecialPeriods.TriangleRegularQuotient) :
+    TopologicalSpace.Opens (Space D) :=
+  ⟨(projection D) ⁻¹' (U : Set SpecialPeriods.TriangleRegularQuotient),
+    U.isOpen.preimage (projection D).continuous⟩
+
+private def PeriodFamily.GammaZero.inclusionOnOpen
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (U : TopologicalSpace.Opens SpecialPeriods.TriangleRegularQuotient) :
+    C(familyOpen D U, PeriodFamily.Homology.familyOpen D U) :=
+  ⟨fun x => ⟨x.val.val, x.property⟩,
+    (continuous_subtype_val.comp continuous_subtype_val).subtype_mk _⟩
+
+private theorem PeriodFamily.GammaZero.oldSectionChart_gamma
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (U : TopologicalSpace.Opens SpecialPeriods.TriangleRegularQuotient)
+    (s : C(U, SpecialPeriods.TriangleRegularPoint))
+    (hs : ∀ x, SpecialPeriods.triangleRegularProject (s x) = x.val)
+    (x : PeriodFamily.Homology.familyOpen D U) :
+    fibreGamma (PeriodFamily.Homology.sectionChart D U s hs x).2 = familyGamma D x.val := by
+  obtain ⟨y, rfl⟩ := (PeriodFamily.Homology.sectionChart D U s hs).symm.surjective x
+  rw [Homeomorph.apply_symm_apply, PeriodFamily.Homology.sectionChart_symm_coe,
+    familyGamma_quotient]
+
+private def PeriodFamily.GammaZero.sectionChart
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (U : TopologicalSpace.Opens SpecialPeriods.TriangleRegularQuotient)
+    (s : C(U, SpecialPeriods.TriangleRegularPoint))
+    (hs : ∀ x, SpecialPeriods.triangleRegularProject (s x) = x.val) : familyOpen D U ≃ₜ U × Fibre
+    where
+  toFun
+    x :=
+    ((PeriodFamily.Homology.sectionChart D U s hs (inclusionOnOpen D U x)).1,
+      ⟨(PeriodFamily.Homology.sectionChart D U s hs (inclusionOnOpen D U x)).2,
+        (oldSectionChart_gamma D U s hs (inclusionOnOpen D U x)).trans x.val.property⟩)
+  invFun
+    y :=
+    ⟨quotient D (s y.1, y.2),
+      show SpecialPeriods.triangleRegularProject (s y.1) ∈ U from (hs y.1).symm ▸ y.1.property⟩
+  left_inv
+    x := by
+    have h :=
+      congrArg (fun z : PeriodFamily.Homology.familyOpen D U => z.val)
+        ((PeriodFamily.Homology.sectionChart D U s hs).symm_apply_apply (inclusionOnOpen D U x))
+    exact Subtype.ext (Subtype.ext h)
+  right_inv
+    y := by
+    have h := PeriodFamily.Homology.sectionChart_apply_quotient D U s hs y.1 y.2.val
+    have h₁ := congrArg Prod.fst h
+    have h₂ := congrArg Prod.snd h
+    apply Prod.ext
+    · exact h₁
+    · exact Subtype.ext h₂
+  continuous_toFun := by
+    have h :=
+      (PeriodFamily.Homology.sectionChart D U s hs).continuous.comp
+        (inclusionOnOpen D U).continuous
+    exact h.fst.prodMk (h.snd.subtype_mk _)
+  continuous_invFun :=
+    ((quotient D).continuous.comp
+          ((s.continuous.comp continuous_fst).prodMk continuous_snd)).subtype_mk
+      _
+
+@[simp]
+private theorem PeriodFamily.GammaZero.sectionChart_symm_projection
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (U : TopologicalSpace.Opens SpecialPeriods.TriangleRegularQuotient)
+    (s : C(U, SpecialPeriods.TriangleRegularPoint))
+    (hs : ∀ x, SpecialPeriods.triangleRegularProject (s x) = x.val) (y : U × Fibre) :
+    projection D ((sectionChart D U s hs).symm y).val = y.1.val :=
+  hs y.1
+
+private def PeriodFamily.GammaZero.sectionRetraction
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (U : TopologicalSpace.Opens SpecialPeriods.TriangleRegularQuotient)
+    (s : C(U, SpecialPeriods.TriangleRegularPoint))
+    (hs : ∀ x, SpecialPeriods.triangleRegularProject (s x) = x.val) :
+    C(PeriodFamily.Homology.familyOpen D U, familyOpen D U) :=
+  ((sectionChart D U s hs).symm : C(_, _)).comp
+    ⟨fun x =>
+      ((PeriodFamily.Homology.sectionChart D U s hs x).1,
+        fibreRetraction (PeriodFamily.Homology.sectionChart D U s hs x).2),
+      (PeriodFamily.Homology.sectionChart D U s hs).continuous.fst.prodMk
+        (fibreRetraction.continuous.comp
+          (PeriodFamily.Homology.sectionChart D U s hs).continuous.snd)⟩
+
+@[simp]
+private theorem PeriodFamily.GammaZero.sectionRetraction_projection
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (U : TopologicalSpace.Opens SpecialPeriods.TriangleRegularQuotient)
+    (s : C(U, SpecialPeriods.TriangleRegularPoint))
+    (hs : ∀ x, SpecialPeriods.triangleRegularProject (s x) = x.val)
+    (x : PeriodFamily.Homology.familyOpen D U) :
+    projection D (sectionRetraction D U s hs x).val = D.projection x.val := by
+  change
+    projection D
+        ((sectionChart D U s hs).symm
+            ((PeriodFamily.Homology.sectionChart D U s hs x).1,
+              fibreRetraction (PeriodFamily.Homology.sectionChart D U s hs x).2)).val =
+      _
+  rw [sectionChart_symm_projection]
+  exact PeriodFamily.Homology.sectionChart_projection D U s hs x
+
+@[simp]
+private theorem PeriodFamily.GammaZero.sectionRetraction_inclusionOnOpen
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (U : TopologicalSpace.Opens SpecialPeriods.TriangleRegularQuotient)
+    (s : C(U, SpecialPeriods.TriangleRegularPoint))
+    (hs : ∀ x, SpecialPeriods.triangleRegularProject (s x) = x.val) (x : familyOpen D U) :
+    sectionRetraction D U s hs (inclusionOnOpen D U x) = x := by
+  apply (sectionChart D U s hs).injective
+  change
+    sectionChart D U s hs
+        ((sectionChart D U s hs).symm
+          ((PeriodFamily.Homology.sectionChart D U s hs (inclusionOnOpen D U x)).1,
+            fibreRetraction
+              (PeriodFamily.Homology.sectionChart D U s hs (inclusionOnOpen D U x)).2)) =
+      _
+  rw [Homeomorph.apply_symm_apply]
+  apply Prod.ext
+  · rfl
+  · exact fibreRetraction_inclusion (sectionChart D U s hs x).2
+
+private theorem PeriodFamily.GammaZero.connecting_injective_of_local_homology_zero {X : Type}
+    [TopologicalSpace X] (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ)
+    (n : ℕ) [Subsingleton (SingularMayerVietoris.SingularHomology U (n + 1))]
+    [Subsingleton (SingularMayerVietoris.SingularHomology V (n + 1))] :
+    Function.Injective (SingularMayerVietoris.connectingHomomorphism U V hU hV hcover n) := by
+  apply LinearMap.ker_eq_bot.mp
+  rw [← SingularMayerVietoris.exact_at_ambient U V hU hV hcover n]
+  have hz : SingularMayerVietoris.rightHomologyMap U V (n + 1) = 0 := by
+    apply LinearMap.ext
+    intro a
+    rw [Subsingleton.elim a 0, map_zero, LinearMap.zero_apply]
+  rw [hz, LinearMap.range_zero]
+
+private theorem PeriodFamily.GammaZero.connecting_comp_homologyMap_injective {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : C(X, Y)) (U V : Set X) (U' V' : Set Y)
+    (hfU : Set.MapsTo f U U') (hfV : Set.MapsTo f V V') (hU : IsOpen U) (hV : IsOpen V)
+    (hcover : U ∪ V = Set.univ) (hU' : IsOpen U') (hV' : IsOpen V') (hcover' : U' ∪ V' = Set.univ)
+    (n : ℕ) [Subsingleton (SingularMayerVietoris.SingularHomology U (n + 1))]
+    [Subsingleton (SingularMayerVietoris.SingularHomology V (n + 1))]
+    (hIntersection :
+      Function.Injective
+        (SingularMayerVietoris.singularHomologyMap
+          (SingularMayerVietoris.intersectionRestriction f U V U' V' hfU hfV) n)) :
+    Function.Injective
+      ((SingularMayerVietoris.connectingHomomorphism U' V' hU' hV' hcover' n).comp
+        (SingularMayerVietoris.singularHomologyMap f (n + 1))) := by
+  rw [←
+    SingularMayerVietoris.connectingHomomorphism_naturality f U V U' V' hfU hfV hU hV hcover hU'
+      hV' hcover' n]
+  exact hIntersection.comp (connecting_injective_of_local_homology_zero U V hU hV hcover n)
+
+private abbrev PeriodFamily.GammaZero.upperFamily
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :=
+  familyOpen D PeriodFamily.Homology.upperBase
+
+private abbrev PeriodFamily.GammaZero.lowerFamily
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :=
+  familyOpen D PeriodFamily.Homology.lowerBase
+
+private theorem PeriodFamily.GammaZero.upperFamily_union_lowerFamily
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    (upperFamily D : Set (Space D)) ∪ lowerFamily D = Set.univ := by
+  apply Set.eq_univ_of_forall
+  intro x
+  have h :
+    x.val ∈
+      (PeriodFamily.Homology.upperFamily D : Set D.Space) ∪ PeriodFamily.Homology.lowerFamily D :=
+    by
+    rw [PeriodFamily.Homology.upperFamily_union_lowerFamily]
+    trivial
+  exact h
+
+private theorem PeriodFamily.GammaZero.inclusion_mapsTo_upper
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    Set.MapsTo (PeriodFamily.GammaZero.inclusion D) (upperFamily D : Set (Space D))
+      (PeriodFamily.Homology.upperFamily D) :=
+  fun _ hx => hx
+
+private theorem PeriodFamily.GammaZero.inclusion_mapsTo_lower
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    Set.MapsTo (PeriodFamily.GammaZero.inclusion D) (lowerFamily D : Set (Space D))
+      (PeriodFamily.Homology.lowerFamily D) :=
+  fun _ hx => hx
+
+private abbrev PeriodFamily.GammaZero.intersectionFamily
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) : Set (Space D) :=
+  (upperFamily D : Set (Space D)) ∩ lowerFamily D
+
+private abbrev PeriodFamily.GammaZero.originalIntersection
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) : Set D.Space :=
+  (PeriodFamily.Homology.upperFamily D : Set D.Space) ∩ PeriodFamily.Homology.lowerFamily D
+
+private def PeriodFamily.GammaZero.intersectionInclusion
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    C(intersectionFamily D, originalIntersection D) :=
+  SingularMayerVietoris.intersectionRestriction (PeriodFamily.GammaZero.inclusion D)
+    (upperFamily D) (lowerFamily D) (PeriodFamily.Homology.upperFamily D)
+    (PeriodFamily.Homology.lowerFamily D) (inclusion_mapsTo_upper D) (inclusion_mapsTo_lower D)
+
+private def PeriodFamily.GammaZero.intersectionToUpper
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    C(originalIntersection D, PeriodFamily.Homology.upperFamily D) :=
+  ⟨fun x => ⟨x.val, x.property.1⟩, continuous_subtype_val.subtype_mk _⟩
+
+private def PeriodFamily.GammaZero.upperRetraction
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    C(PeriodFamily.Homology.upperFamily D, upperFamily D) :=
+  sectionRetraction D PeriodFamily.Homology.upperBase
+    (PeriodFamily.Homology.upperLift PeriodFamily.Homology.normalizedSlitBaseLift)
+    (PeriodFamily.Homology.upperLift_project PeriodFamily.Homology.normalizedSlitBaseLift)
+
+@[simp]
+private theorem PeriodFamily.GammaZero.upperRetraction_projection
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (x : PeriodFamily.Homology.upperFamily D) :
+    projection D (upperRetraction D x).val = D.projection x.val :=
+  sectionRetraction_projection D PeriodFamily.Homology.upperBase
+    (PeriodFamily.Homology.upperLift PeriodFamily.Homology.normalizedSlitBaseLift)
+    (PeriodFamily.Homology.upperLift_project PeriodFamily.Homology.normalizedSlitBaseLift) x
+
+private theorem PeriodFamily.GammaZero.upperRetraction_intersection_mem_lower
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (x : originalIntersection D) :
+    (upperRetraction D (intersectionToUpper D x)).val ∈ lowerFamily D := by
+  change
+    projection D (upperRetraction D (intersectionToUpper D x)).val ∈
+      PeriodFamily.Homology.lowerBase
+  rw [upperRetraction_projection]
+  exact x.property.2
+
+private def PeriodFamily.GammaZero.intersectionRetraction
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    C(originalIntersection D, intersectionFamily D)
+    where
+  toFun
+    x :=
+    ⟨(upperRetraction D (intersectionToUpper D x)).val,
+      (upperRetraction D (intersectionToUpper D x)).property,
+      upperRetraction_intersection_mem_lower D x⟩
+  continuous_toFun :=
+    (continuous_subtype_val.comp
+          ((upperRetraction D).continuous.comp (intersectionToUpper D).continuous)).subtype_mk
+      _
+
+@[simp]
+private theorem PeriodFamily.GammaZero.intersectionRetraction_inclusion
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (x : intersectionFamily D) :
+    intersectionRetraction D (intersectionInclusion D x) = x := by
+  have h :=
+    sectionRetraction_inclusionOnOpen D PeriodFamily.Homology.upperBase
+      (PeriodFamily.Homology.upperLift PeriodFamily.Homology.normalizedSlitBaseLift)
+      (PeriodFamily.Homology.upperLift_project PeriodFamily.Homology.normalizedSlitBaseLift)
+      ⟨x.val, x.property.1⟩
+  have hv := congrArg (fun z : upperFamily D => z.val) h
+  exact Subtype.ext hv
+
+private theorem PeriodFamily.GammaZero.intersectionRetraction_comp_inclusion
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    (intersectionRetraction D).comp (intersectionInclusion D) =
+      ContinuousMap.id (intersectionFamily D) :=
+  ContinuousMap.ext (intersectionRetraction_inclusion D)
+
+private theorem PeriodFamily.GammaZero.intersectionHomologyRetraction_comp_inclusion
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    (SingularMayerVietoris.singularHomologyMap (intersectionRetraction D) n).comp
+        (SingularMayerVietoris.singularHomologyMap (intersectionInclusion D) n) =
+      LinearMap.id := by
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp, intersectionRetraction_comp_inclusion,
+    PeriodTorusHigherHomology.singularHomologyMap_id]
+
+private theorem PeriodFamily.GammaZero.intersectionHomologyInclusion_injective
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    Function.Injective (SingularMayerVietoris.singularHomologyMap (intersectionInclusion D) n) := by
+  apply
+    Function.LeftInverse.injective (g :=
+      SingularMayerVietoris.singularHomologyMap (intersectionRetraction D) n)
+  intro a
+  exact LinearMap.congr_fun (intersectionHomologyRetraction_comp_inclusion D n) a
+
+private def PeriodFamily.GammaZero.fibreTorusHomologyEquiv (n : ℕ) :
+    SingularMayerVietoris.SingularHomology Fibre n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.ProductTorus 3) n :=
+  PeriodTorusHigherHomology.homeomorphHomologyEquiv fibreHomeomorph n
+
+private theorem PeriodFamily.GammaZero.fibreHomology_subsingleton_of_lt (n : ℕ) (h : 3 < n) :
+    Subsingleton (SingularMayerVietoris.SingularHomology Fibre n) := by
+  let := PeriodTorusHigherHomology.productTorus_homology_subsingleton_of_lt h
+  exact (fibreTorusHomologyEquiv n).injective.subsingleton
+
+private theorem PeriodFamily.GammaZero.fibreH4_subsingleton :
+    Subsingleton (SingularMayerVietoris.SingularHomology Fibre 4) :=
+  fibreHomology_subsingleton_of_lt 4 (by decide)
+
+private def PeriodFamily.GammaZero.upperHomotopyEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) : upperFamily D ≃ₕ Fibre :=
+  (sectionChart D PeriodFamily.Homology.upperBase
+        (PeriodFamily.Homology.upperLift PeriodFamily.Homology.normalizedSlitBaseLift)
+        (PeriodFamily.Homology.upperLift_project
+          PeriodFamily.Homology.normalizedSlitBaseLift)).toHomotopyEquiv.trans
+    (PeriodTorusHigherHomology.CircleTopology.contractibleProdHomotopyEquiv
+      PeriodFamily.Homology.upperBase Fibre)
+
+private def PeriodFamily.GammaZero.lowerHomotopyEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) : lowerFamily D ≃ₕ Fibre :=
+  (sectionChart D PeriodFamily.Homology.lowerBase
+        (PeriodFamily.Homology.lowerLift PeriodFamily.Homology.normalizedSlitBaseLift)
+        (PeriodFamily.Homology.lowerLift_project
+          PeriodFamily.Homology.normalizedSlitBaseLift)).toHomotopyEquiv.trans
+    (PeriodTorusHigherHomology.CircleTopology.contractibleProdHomotopyEquiv
+      PeriodFamily.Homology.lowerBase Fibre)
+
+private def PeriodFamily.GammaZero.upperHomologyEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (upperFamily D) n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology Fibre n :=
+  PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (upperHomotopyEquiv D) n
+
+private def PeriodFamily.GammaZero.lowerHomologyEquiv
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (lowerFamily D) n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology Fibre n :=
+  PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (lowerHomotopyEquiv D) n
+
+private theorem PeriodFamily.GammaZero.upperH4_subsingleton
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    Subsingleton (SingularMayerVietoris.SingularHomology (upperFamily D) 4) := by
+  let := fibreH4_subsingleton
+  exact (upperHomologyEquiv D 4).injective.subsingleton
+
+private theorem PeriodFamily.GammaZero.lowerH4_subsingleton
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    Subsingleton (SingularMayerVietoris.SingularHomology (lowerFamily D) 4) := by
+  let := fibreH4_subsingleton
+  exact (lowerHomologyEquiv D 4).injective.subsingleton
+
+private def PeriodFamily.GammaZero.homologyInclusion
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (Space D) n →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology D.Space n :=
+  SingularMayerVietoris.singularHomologyMap (PeriodFamily.GammaZero.inclusion D) n
+
+private theorem PeriodFamily.GammaZero.connecting_comp_homologyInclusion_injective
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    Function.Injective
+      ((PeriodFamily.Homology.familyConnectingHomomorphism D 3).comp (homologyInclusion D 4)) := by
+  let := upperH4_subsingleton D
+  let := lowerH4_subsingleton D
+  exact
+    connecting_comp_homologyMap_injective (PeriodFamily.GammaZero.inclusion D) (upperFamily D)
+      (lowerFamily D) (PeriodFamily.Homology.upperFamily D) (PeriodFamily.Homology.lowerFamily D)
+      (inclusion_mapsTo_upper D) (inclusion_mapsTo_lower D) (upperFamily D).isOpen
+      (lowerFamily D).isOpen (upperFamily_union_lowerFamily D)
+      (PeriodFamily.Homology.upperFamily D).isOpen (PeriodFamily.Homology.lowerFamily D).isOpen
+      (PeriodFamily.Homology.upperFamily_union_lowerFamily D) 3
+      (intersectionHomologyInclusion_injective D 3)
+
+private theorem PeriodFamily.GammaZero.sourceKernelProjection_eq_zero_iff_connecting
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology D.Space (n + 1)) :
+    PeriodFamily.Homology.sourceKernelProjection D n a = 0 ↔
+      PeriodFamily.Homology.familyConnectingHomomorphism D n a = 0 := by
+  change
+    a ∈ LinearMap.ker (PeriodFamily.Homology.sourceKernelProjection D n) ↔
+      a ∈ LinearMap.ker (PeriodFamily.Homology.familyConnectingHomomorphism D n)
+  rw [PeriodFamily.Homology.sourceKernelProjection_kernel,
+    PeriodFamily.Homology.familyConnectingHomomorphism_ker_eq_fibre D
+      PeriodFamily.Homology.normalizedSlitBaseLift]
+
+private theorem PeriodFamily.GammaZero.sourceKernelProjection_eq_iff_connecting
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) (n : ℕ)
+    (a b : SingularMayerVietoris.SingularHomology D.Space (n + 1)) :
+    PeriodFamily.Homology.sourceKernelProjection D n a =
+        PeriodFamily.Homology.sourceKernelProjection D n b ↔
+      PeriodFamily.Homology.familyConnectingHomomorphism D n a =
+        PeriodFamily.Homology.familyConnectingHomomorphism D n b := by
+  simpa only [map_sub, sub_eq_zero] using
+    sourceKernelProjection_eq_zero_iff_connecting D n (a - b)
+
+private theorem PeriodFamily.GammaZero.sourceKernelProjection_comp_homologyInclusion_injective
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    Function.Injective
+      ((PeriodFamily.Homology.sourceKernelProjection D 3).comp (homologyInclusion D 4)) := by
+  intro a b hab
+  apply connecting_comp_homologyInclusion_injective D
+  exact
+    (sourceKernelProjection_eq_iff_connecting D 3 (homologyInclusion D 4 a)
+          (homologyInclusion D 4 b)).mp
+      hab
+
+private theorem PeriodFamily.GammaZero.sourceKernelProjection_injOn_range
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    Set.InjOn (PeriodFamily.Homology.sourceKernelProjection D 3)
+      (LinearMap.range (homologyInclusion D 4)) := by
+  rintro a ⟨x, rfl⟩ b ⟨y, rfl⟩ h
+  exact
+    congrArg (homologyInclusion D 4) (sourceKernelProjection_comp_homologyInclusion_injective D h)
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/PeriodFamily/Core9.lean b/LeanPool/HopfProblem/PeriodFamily/Core9.lean
new file mode 100644
index 000000000..e05f92639
--- /dev/null
+++ b/LeanPool/HopfProblem/PeriodFamily/Core9.lean
@@ -0,0 +1,1604 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.CuspFibre.CuspBoundaryTopVanishing
+public import LeanPool.HopfProblem.MainTheorem.SixSphereCube2
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology4
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+import all LeanPool.HopfProblem.Lattice.Core2
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology7
+import all LeanPool.HopfProblem.PeriodFamily.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods6
+import all LeanPool.HopfProblem.PeriodFamily.Core2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import all LeanPool.HopfProblem.Elliptic.Core3
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods8
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen2
+import all LeanPool.HopfProblem.Elliptic.Core5
+import all LeanPool.HopfProblem.PeriodFamily.Core3
+import all LeanPool.HopfProblem.PeriodFamily.Core4
+import all LeanPool.HopfProblem.Pi1.TwistGroup
+import all LeanPool.HopfProblem.PeriodFamily.Core5
+import all LeanPool.HopfProblem.Elliptic.Core7
+import all LeanPool.HopfProblem.PeriodFamily.Core6
+import all LeanPool.HopfProblem.PeriodFamily.Core7
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology3
+import all LeanPool.HopfProblem.PeriodFamily.Core8
+import all LeanPool.HopfProblem.CuspFibre.CuspBoundaryTopVanishing
+import all LeanPool.HopfProblem.MainTheorem.SixSphereCube2
+
+/-!
+# Hopf problem: period family · core 9
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem
+    PeriodFamily.Boundary.FourthRelation.unitCapSection_wang_eq_neg_cusp (j : Elliptic.Kind) :
+    MappingTorusHomology.wangBoundary (Elliptic.flatTorusAffine j j.twist) 3
+        (PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass j) =
+      -MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy 3
+          CuspBoundaryGammaZero.nativeClass := by
+  apply PeriodFamily.FlatTorus.singularH3Coordinates.injective
+  rw [PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass_wang, map_neg,
+    CuspBoundaryGammaZero.nativeClass_wang_coordinates]
+
+private theorem PeriodFamily.Boundary.FourthRelation.nativeClass_wang_first_inv_fixed :
+    PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleGenerator₁⁻¹ 3
+        (MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy 3
+          CuspBoundaryGammaZero.nativeClass) =
+      MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy 3
+        CuspBoundaryGammaZero.nativeClass := by
+  have h :=
+    PeriodFamily.Boundary.ellipticWangBoundary_generator_inv_fixed .three
+      Elliptic.Kind.three.twist 3
+      (PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass .three)
+  change
+    PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleGenerator₁⁻¹ 3
+        (MappingTorusHomology.wangBoundary
+          (Elliptic.flatTorusAffine .three Elliptic.Kind.three.twist) 3
+          (PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass .three)) =
+      MappingTorusHomology.wangBoundary
+        (Elliptic.flatTorusAffine .three Elliptic.Kind.three.twist) 3
+        (PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass .three) at h
+  rw [unitCapSection_wang_eq_neg_cusp, map_neg] at h
+  exact neg_injective h
+
+private theorem PeriodFamily.Boundary.FourthRelation.unitCapSection_regular_mem_range
+    (j : Elliptic.Kind) :
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some j) 4
+        (PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass j) ∈
+      LinearMap.range
+        (PeriodFamily.GammaZero.homologyInclusion
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          4) :=
+  PeriodFamily.Boundary.EllipticGaugeLinearization.boundaryRegularHomologyMap_capSection_mem_range
+    j 0 4
+    ((Elliptic.HigherHomology.surfaceH4Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).symm
+      1)
+
+private theorem PeriodFamily.Boundary.FourthRelation.nativeClass_sourceKernel_eq_capSections :
+    PeriodFamily.Homology.sourceKernelProjection
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        3
+        (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none 4
+          CuspBoundaryGammaZero.nativeClass) =
+      PeriodFamily.Homology.sourceKernelProjection
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        3
+        (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some Elliptic.Kind.three)
+            4 (PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass .three) +
+          ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some Elliptic.Kind.four)
+            4 (PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass .four)) := by
+  apply Subtype.ext
+  have hadd :
+    (PeriodFamily.Homology.sourceKernelProjection
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          3
+          (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap
+              (Option.some Elliptic.Kind.three) 4
+              (PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass .three) +
+            ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap
+              (Option.some Elliptic.Kind.four) 4
+              (PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass .four)) :
+        SingularMayerVietoris.SingularHomology RealTorus₄ 3 ×
+          SingularMayerVietoris.SingularHomology RealTorus₄ 3) =
+      (PeriodFamily.Homology.sourceKernelProjection
+            (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)
+            3
+            (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap
+              (Option.some Elliptic.Kind.three) 4
+              (PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass .three)) :
+          SingularMayerVietoris.SingularHomology RealTorus₄ 3 ×
+            SingularMayerVietoris.SingularHomology RealTorus₄ 3) +
+        (PeriodFamily.Homology.sourceKernelProjection
+            (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)
+            3
+            (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap
+              (Option.some Elliptic.Kind.four) 4
+              (PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass .four)) :
+          SingularMayerVietoris.SingularHomology RealTorus₄ 3 ×
+            SingularMayerVietoris.SingularHomology RealTorus₄ 3) :=
+    congrArg Subtype.val
+      (map_add
+        (PeriodFamily.Homology.sourceKernelProjection
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          3)
+        _ _)
+  have hc :
+    (PeriodFamily.Homology.sourceKernelProjection
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          3
+          (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none 4
+            CuspBoundaryGammaZero.nativeClass) :
+        SingularMayerVietoris.SingularHomology RealTorus₄ 3 ×
+          SingularMayerVietoris.SingularHomology RealTorus₄ 3) =
+      (-PeriodFamily.Homology.triangleHomologyEquiv SpecialPeriods.triangleGenerator₁⁻¹ 3
+            (MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy 3
+              CuspBoundaryGammaZero.nativeClass),
+        -MappingTorusHomology.wangBoundary ThreefoldOverlapMappingTorus.Cusp.monodromy 3
+            CuspBoundaryGammaZero.nativeClass) :=
+    PeriodFamily.Boundary.Cusp.boundary_four_sourceKernelProjection
+      CuspBoundaryGammaZero.nativeClass
+  rw [hc, hadd, PeriodFamily.Boundary.ellipticThreeBoundary_sourceKernelProjection,
+    PeriodFamily.Boundary.ellipticFourBoundary_sourceKernelProjection,
+    unitCapSection_wang_eq_neg_cusp, unitCapSection_wang_eq_neg_cusp,
+    nativeClass_wang_first_inv_fixed]
+  simp only [Prod.mk_add_mk, add_zero, zero_add]
+
+private theorem PeriodFamily.Boundary.FourthRelation.nativeClass_regular_eq_capSections :
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none 4
+        CuspBoundaryGammaZero.nativeClass =
+      ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some Elliptic.Kind.three) 4
+          (PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass .three) +
+        ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some Elliptic.Kind.four) 4
+          (PeriodFamily.Boundary.EllipticCapProduct.unitCapSectionClass .four) := by
+  apply
+    PeriodFamily.GammaZero.sourceKernelProjection_injOn_range
+      (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+      CuspBoundaryGammaZero.nativeClass_regular_mem_range
+      (Submodule.add_mem _ (unitCapSection_regular_mem_range .three)
+        (unitCapSection_regular_mem_range .four))
+  exact nativeClass_sourceKernel_eq_capSections
+
+private theorem PeriodFamily.Boundary.H5ToH4Wang_injective (f : RealTorus₄ ≃ₜ RealTorus₄) :
+    Function.Injective (MappingTorusHomology.wangBoundary f 4) := by
+  let : Subsingleton (SingularMayerVietoris.SingularHomology RealTorus₄ 5) :=
+    PeriodTorusHigherHomology.realTorus_homology_subsingleton_of_lt (by decide : 4 < 5)
+  have hzero : MappingTorusHomology.fibreHomologyMap f 5 = 0 := by
+    apply LinearMap.ext
+    intro a
+    exact
+      (congrArg (MappingTorusHomology.fibreHomologyMap f 5) (Subsingleton.elim a 0)).trans
+        (map_zero (MappingTorusHomology.fibreHomologyMap f 5))
+  apply LinearMap.ker_eq_bot.mp
+  rw [← MappingTorusHomology.wang_exact_at_mappingTorus f 4, hzero, LinearMap.range_zero]
+
+private theorem PeriodFamily.Boundary.H5ToH4Wang_surjective (f : RealTorus₄ ≃ₜ RealTorus₄)
+    (hf : MappingTorusHomology.monodromyHomologyMap f 4 = LinearMap.id) :
+    Function.Surjective (MappingTorusHomology.wangBoundary f 4) := by
+  intro a
+  have ha : a ∈ LinearMap.ker (MappingTorusHomology.wangDifference f 4) := by
+    change a - MappingTorusHomology.monodromyHomologyMap f 4 a = 0
+    rw [hf, LinearMap.id_apply, sub_self]
+  rw [← MappingTorusHomology.wangBoundary_range f 4] at ha
+  exact ha
+
+private def PeriodFamily.Boundary.H5ToH4WangEquiv (f : RealTorus₄ ≃ₜ RealTorus₄)
+    (hf : MappingTorusHomology.monodromyHomologyMap f 4 = LinearMap.id) :
+    SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) 5 ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology RealTorus₄ 4 :=
+  LinearEquiv.ofBijective (MappingTorusHomology.wangBoundary f 4)
+    ⟨H5ToH4Wang_injective f, H5ToH4Wang_surjective f hf⟩
+
+private theorem PeriodFamily.Boundary.ThirdRelation.capCircle_surfaceCover_class (j : Elliptic.Kind)
+    (n : ℕ) (hn : n = 1 ∨ n = 2) (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    PeriodFamily.Boundary.EllipticCapProduct.boundaryPositiveCircleCross j n
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover j) n a) =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodFamily.Boundary.EllipticCapKernelWang.nativeProductCover j) (n + 1)
+        (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ n a) := by
+  rw [PeriodFamily.Boundary.EllipticCapProduct.boundaryPositiveCircleCross_apply, ←
+    PeriodTorusHigherHomology.positiveCircleCross_naturality]
+  have hmap :=
+    congrArg
+      (fun f :
+          C(MappingTorus.Circle × RealTorus₄,
+            ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary j) =>
+        SingularMayerVietoris.singularHomologyMap f (n + 1))
+      (PeriodFamily.Boundary.EllipticCapKernelWang.nativeProductCover_comp_shear j)
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodTorusHigherHomology.singularHomologyMap_comp] at hmap
+  have h :=
+    LinearMap.congr_fun hmap (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ n a)
+  simpa only [LinearMap.comp_apply,
+    PeriodFamily.Boundary.EllipticCapKernelWang.nativeShear_positiveCircleCross j n hn a] using
+    h.symm
+
+private theorem PeriodFamily.Boundary.ThirdRelation.surfaceCover_two_combination (j : Elliptic.Kind)
+    (p q : ℤ) :
+    Elliptic.HigherHomology.surfaceH2Equiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover j) 2
+          (p • PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreClassTwo j +
+            q • PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassTwo j)) =
+      ![p + q * PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo j,
+        q * (Elliptic.HigherHomology.fibreNormIndex j : ℤ)] := by
+  rw [map_add, map_zsmul, map_zsmul, map_add, map_zsmul, map_zsmul,
+    PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover_splitFibreClassTwo,
+    PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover_splitCircleClassTwo]
+  ext i
+  fin_cases i <;> simp
+
+private theorem PeriodFamily.Boundary.ThirdRelation.capCircle_two_combination (j : Elliptic.Kind)
+    (p q : ℤ) :
+    PeriodFamily.Boundary.EllipticCapProduct.boundaryPositiveCircleCross j 2
+        ((Elliptic.HigherHomology.surfaceH2Equiv j
+              (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).symm
+          ![p + q * PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo j,
+            q * (Elliptic.HigherHomology.fibreNormIndex j : ℤ)]) =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodFamily.Boundary.EllipticCapKernelWang.nativeProductCover j) 3
+        (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ 2
+          (p • PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreClassTwo j +
+            q • PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassTwo j)) := by
+  have h :
+    (Elliptic.HigherHomology.surfaceH2Equiv j
+            (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).symm
+        ![p + q * PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo j,
+          q * (Elliptic.HigherHomology.fibreNormIndex j : ℤ)] =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodFamily.Boundary.EllipticCapKernelWang.surfaceCover j) 2
+        (p • PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreClassTwo j +
+          q • PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassTwo j) := by
+    apply
+      (Elliptic.HigherHomology.surfaceH2Equiv j
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod).injective
+    rw [LinearEquiv.apply_symm_apply, surfaceCover_two_combination]
+  rw [h]
+  exact capCircle_surfaceCover_class j 2 (Or.inr rfl) _
+
+private theorem PeriodFamily.Boundary.ThirdRelation.capCircle_three_reference :
+    PeriodFamily.Boundary.EllipticCapProduct.boundaryPositiveCircleCross .three 2
+        ((Elliptic.HigherHomology.surfaceH2Equiv .three
+              (SpecialPeriods.EllipticFilling.specialLocalData .three).centralPeriod).symm
+          ![2 * PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo .three + 4, 2]) =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodFamily.Boundary.EllipticCapKernelWang.nativeProductCover .three) 3
+        (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ 2
+          ((4 : ℤ) • PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreClassTwo .three +
+            (2 : ℤ) • PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassTwo .three)) := by
+  have h := capCircle_two_combination .three 4 2
+  have h₀ :
+    4 + 2 * PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo .three =
+      2 * PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo .three + 4 :=
+    add_comm _ _
+  have h₁ : (2 : ℤ) * (Elliptic.HigherHomology.fibreNormIndex .three : ℤ) = 2 := by decide
+  rw [h₀, h₁] at h
+  exact h
+
+private theorem PeriodFamily.Boundary.ThirdRelation.capCircle_four_reference :
+    PeriodFamily.Boundary.EllipticCapProduct.boundaryPositiveCircleCross .four 2
+        ((Elliptic.HigherHomology.surfaceH2Equiv .four
+              (SpecialPeriods.EllipticFilling.specialLocalData .four).centralPeriod).symm
+          ![3 - PeriodFamily.Boundary.EllipticCapKernelWang.sourceShearTwo .four, -2]) =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodFamily.Boundary.EllipticCapKernelWang.nativeProductCover .four) 3
+        (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ 2
+          ((3 : ℤ) • PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreClassTwo .four -
+            PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassTwo .four)) := by
+  have h := capCircle_two_combination .four 3 (-1)
+  simpa only [neg_one_mul, sub_eq_add_neg, Elliptic.HigherHomology.fibreNormIndex_four,
+    Nat.cast_ofNat, neg_one_zsmul] using h
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.ThirdRelation.flatNegation : C(RealTorus₄, RealTorus₄) :=
+  ⟨Neg.neg, ContinuousNeg.continuous_neg⟩
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.ThirdRelation.triangleTorusHomeomorph_neg
+    (g : SpecialPeriods.TriangleGroup) (x : RealTorus₄) :
+    SpecialPeriods.triangleTorusHomeomorph g (-x) = -SpecialPeriods.triangleTorusHomeomorph g x :=
+  by
+  obtain ⟨v, rfl⟩ := standardLattice.mkQ_surjective x
+  rw [← map_neg, SpecialPeriods.triangleTorusHomeomorph_mkQ, map_neg, map_neg,
+    SpecialPeriods.triangleTorusHomeomorph_mkQ]
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private def PeriodFamily.Boundary.ThirdRelation.familyNegation
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) : C(D.Space, D.Space)
+    where
+  toFun :=
+    Quotient.lift
+      (fun x : SpecialPeriods.TriangleRegularPoint × RealTorus₄ => D.quotient (x.1, -x.2))
+      (by
+        rintro x y ⟨g, hg⟩
+        apply (D.quotient_eq_iff _ _).mpr
+        refine ⟨g, ?_⟩
+        apply Prod.ext
+        · change g • y.1 = x.1
+          exact congrArg (fun p : SpecialPeriods.TriangleRegularPoint × RealTorus₄ => p.1) hg
+        · change SpecialPeriods.triangleTorusHomeomorph g (-y.2) = -x.2
+          rw [triangleTorusHomeomorph_neg]
+          exact congrArg Neg.neg (congrArg Prod.snd hg))
+  continuous_toFun :=
+    D.quotient_isQuotientMap.continuous_iff.mpr
+      (D.quotient_continuous.comp (continuous_fst.prodMk continuous_snd.neg))
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+@[simp]
+private theorem PeriodFamily.Boundary.ThirdRelation.familyNegation_quotient
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (b : SpecialPeriods.TriangleRegularPoint) (x : RealTorus₄) :
+    familyNegation D (D.quotient (b, x)) = D.quotient (b, -x) :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.ThirdRelation.familyNegation_comp_fibre
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (b : PeriodFamily.Homology.SlitBaseLift) :
+    (familyNegation D).comp (PeriodFamily.Homology.familyFibreInclusion D b) =
+      (PeriodFamily.Homology.familyFibreInclusion D b).comp flatNegation :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.ThirdRelation.torusMatrixMap_neg_one_mo1973_30293
+    (x : PeriodTorusHigherHomology.ProductTorus 4) :
+    PeriodTorusHigherHomology.torusMatrixMap (-1 : LatticeMatrix) x = -x := by
+  ext i
+  simp [PeriodTorusHigherHomology.torusMatrixMap_apply, Matrix.one_apply]
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.ThirdRelation.square_neg_one_mo1973_30294 :
+    LocalSystemMatrices.exteriorSquare (-1 : LatticeMatrix) = 1 := by
+  ext i j
+  fin_cases i <;> fin_cases j <;> decide
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.ThirdRelation.cube_neg_one_mo1973_30295 :
+    LocalSystemMatrices.exteriorCube (-1 : LatticeMatrix) = -1 := by
+  ext i j
+  fin_cases i <;> fin_cases j <;> decide
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.ThirdRelation.flatNegation_circle_comp :
+    (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+            C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4)).comp
+        flatNegation =
+      (PeriodTorusHigherHomology.torusMatrixMap (-1 : LatticeMatrix)).comp
+        (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+          C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4)) := by
+  apply ContinuousMap.ext
+  intro x
+  change
+    PeriodTorusHigherHomology.flatTorusCircleHomeomorph (-x) =
+      PeriodTorusHigherHomology.torusMatrixMap (-1 : LatticeMatrix)
+        (PeriodTorusHigherHomology.flatTorusCircleHomeomorph x)
+  rw [torusMatrixMap_neg_one_mo1973_30293]
+  exact map_neg PeriodTorusHigherHomology.flatTorusCircleMap x
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.ThirdRelation.flatNegation_circle_homology (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+          C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+        n (SingularMayerVietoris.singularHomologyMap flatNegation n a) =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodTorusHigherHomology.torusMatrixMap (-1 : LatticeMatrix)) n
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+            C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+          n a) := by
+  have h :=
+    congrArg
+      (fun f : C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4) =>
+        SingularMayerVietoris.singularHomologyMap f n)
+      flatNegation_circle_comp
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodTorusHigherHomology.singularHomologyMap_comp] at h
+  exact LinearMap.congr_fun h a
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.ThirdRelation.flatNegation_homology_two
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 2) :
+    SingularMayerVietoris.singularHomologyMap flatNegation 2 a = a := by
+  apply PeriodFamily.FlatTorus.singularH2Coordinates.injective
+  change
+    PeriodTorusHigherHomology.coordinateTorusH2Coordinates
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+            C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+          2 (SingularMayerVietoris.singularHomologyMap flatNegation 2 a)) =
+      PeriodTorusHigherHomology.coordinateTorusH2Coordinates
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+            C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+          2 a)
+  rw [flatNegation_circle_homology, PeriodTorusHigherHomology.coordinateTorusH2Coordinates_matrix,
+    square_neg_one_mo1973_30294, Matrix.one_mulVec]
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.ThirdRelation.flatNegation_homology_three
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 3) :
+    SingularMayerVietoris.singularHomologyMap flatNegation 3 a = -a := by
+  apply PeriodFamily.FlatTorus.singularH3Coordinates.injective
+  change
+    PeriodTorusHigherHomology.coordinateTorusH3Coordinates
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+            C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+          3 (SingularMayerVietoris.singularHomologyMap flatNegation 3 a)) =
+      PeriodTorusHigherHomology.coordinateTorusH3Coordinates
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.flatTorusCircleHomeomorph :
+            C(RealTorus₄, PeriodTorusHigherHomology.ProductTorus 4))
+          3 (-a))
+  rw [flatNegation_circle_homology, PeriodTorusHigherHomology.coordinateTorusH3Coordinates_matrix,
+    cube_neg_one_mo1973_30295, Matrix.neg_mulVec, Matrix.one_mulVec, map_neg, map_neg]
+
+attribute [local instance] SpecialPeriods.triangleTorusAction
+    SpecialPeriods.triangleTorusAction_continuous in
+private theorem PeriodFamily.Boundary.ThirdRelation.familyNegation_homology_fibre_three
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (b : PeriodFamily.Homology.SlitBaseLift)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ 3) :
+    SingularMayerVietoris.singularHomologyMap (familyNegation D) 3
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodFamily.Homology.familyFibreInclusion D b) 3 a) =
+      -SingularMayerVietoris.singularHomologyMap (PeriodFamily.Homology.familyFibreInclusion D b)
+          3 a := by
+  have h :=
+    congrArg (fun f : C(RealTorus₄, D.Space) => SingularMayerVietoris.singularHomologyMap f 3)
+      (familyNegation_comp_fibre D b)
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodTorusHigherHomology.singularHomologyMap_comp] at h
+  have ha := LinearMap.congr_fun h a
+  simpa only [LinearMap.comp_apply, flatNegation_homology_three, map_neg] using ha
+
+private theorem PeriodFamily.Boundary.ThirdRelation.loopHomologyClass_add_zero {G : Type}
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G] (p q : Path (0 : G) 0) :
+    FirstHurewicz.loopHomologyClass (p.add q) =
+      FirstHurewicz.loopHomologyClass p + FirstHurewicz.loopHomologyClass q := by
+  have hp : (p.prod (Path.refl (0 : G))).map continuous_add = p.cast (add_zero 0) (add_zero 0) := by
+    ext t
+    simp only [Path.map_coe, Function.comp_apply, Path.prod_coe, Path.refl_apply, Path.cast_coe,
+      add_zero]
+  have hq : ((Path.refl (0 : G)).prod q).map continuous_add = q.cast (add_zero 0) (add_zero 0) := by
+    ext t
+    simp only [Path.map_coe, Function.comp_apply, Path.prod_coe, Path.refl_apply, Path.cast_coe,
+      zero_add]
+  have h :
+    ((p.prod (Path.refl (0 : G))).trans ((Path.refl (0 : G)).prod q)).Homotopic (p.prod q) := by
+    rw [Path.trans_prod_eq_prod_trans]
+    exact ⟨Path.Homotopic.prodHomotopy (Path.Homotopy.transRefl p) (Path.Homotopy.reflTrans q)⟩
+  have he :=
+    FirstHurewicz.loopHomologyClass_homotopic
+      (h.map (⟨fun x : G × G => x.1 + x.2, continuous_add⟩ : C(G × G, G)))
+  rw [Path.map_trans, FirstHurewicz.loopHomologyClass_trans, hp, hq] at he
+  exact he.symm
+
+private theorem PeriodFamily.Boundary.ThirdRelation.inducedH1_add_of_zero {X G : Type}
+    [TopologicalSpace X] [PathConnectedSpace X] [TopologicalSpace G] [AddCommGroup G]
+    [IsTopologicalAddGroup G] (f g : C(X, G)) (b : X) (hf : f b = 0) (hg : g b = 0) :
+    FirstHurewicz.inducedHomology (f + g) =
+      FirstHurewicz.inducedHomology f + FirstHurewicz.inducedHomology g := by
+  apply LinearMap.ext
+  intro a
+  obtain ⟨p, rfl⟩ := FirstHurewicz.loopHomologyClass_surjective b a
+  let pf : Path (0 : G) 0 := (p.map f.continuous).cast hf.symm hf.symm
+  let pg : Path (0 : G) 0 := (p.map g.continuous).cast hg.symm hg.symm
+  have h :
+    p.map (f + g).continuous =
+      (pf.add pg).cast (by simp only [ContinuousMap.add_apply, hf, hg])
+        (by simp only [ContinuousMap.add_apply, hf, hg]) := by
+    ext t
+    rfl
+  simp only [LinearMap.add_apply, FirstHurewicz.inducedHomology_loopHomologyClass]
+  rw [h]
+  exact loopHomologyClass_add_zero pf pg
+
+private def PeriodFamily.Boundary.ThirdRelation.circleHeadMap (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] :
+    C((PeriodTorusHigherHomology.CircleTopology.Circle),
+      (PeriodTorusHigherHomology.CircleTopology.Circle) × G) :=
+  (ContinuousMap.id (PeriodTorusHigherHomology.CircleTopology.Circle)).prodMk
+    (ContinuousMap.const (PeriodTorusHigherHomology.CircleTopology.Circle) 0)
+
+@[simp]
+private theorem
+    PeriodFamily.Boundary.ThirdRelation.circleHeadMap_zero (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] : circleHeadMap G 0 = 0 :=
+  rfl
+
+private theorem
+    PeriodFamily.Boundary.ThirdRelation.productSection_add (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] (x y : G) :
+    PeriodTorusHigherHomology.CircleTopology.productSection G (x + y) =
+      PeriodTorusHigherHomology.CircleTopology.productSection G x +
+        PeriodTorusHigherHomology.CircleTopology.productSection G y := by
+  exact Prod.ext (zero_add 0).symm rfl
+
+private def PeriodFamily.Boundary.ThirdRelation.verticalProductShear (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    (v : C((PeriodTorusHigherHomology.CircleTopology.Circle), G)) :
+    C((PeriodTorusHigherHomology.CircleTopology.Circle) × G,
+      (PeriodTorusHigherHomology.CircleTopology.Circle) × G) :=
+  ⟨fun p => (p.1, p.2 + v p.1),
+    continuous_fst.prodMk (continuous_snd.add (v.continuous.comp continuous_fst))⟩
+
+private def PeriodFamily.Boundary.ThirdRelation.verticalProductShearHomeomorph (G : Type)
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    (v : C((PeriodTorusHigherHomology.CircleTopology.Circle), G)) :
+    ((PeriodTorusHigherHomology.CircleTopology.Circle) × G) ≃ₜ
+      ((PeriodTorusHigherHomology.CircleTopology.Circle) × G)
+    where
+  toFun := verticalProductShear G v
+  invFun p := (p.1, p.2 - v p.1)
+  left_inv p := Prod.ext rfl (add_sub_cancel_right p.2 (v p.1))
+  right_inv p := Prod.ext rfl (sub_add_cancel p.2 (v p.1))
+  continuous_toFun := (verticalProductShear G v).continuous
+  continuous_invFun :=
+    continuous_fst.prodMk (continuous_snd.sub (v.continuous.comp continuous_fst))
+
+public
+theorem
+    PeriodFamily.Boundary.ThirdRelation.circleMorphism_zero (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] (v : C((PeriodTorusHigherHomology.CircleTopology.Circle), G))
+    (hv : ∀ x y, v (x + y) = v x + v y) : v 0 = 0 := by
+  have h : v 0 + v 0 = v 0 + 0 := by simpa only [zero_add, add_zero] using (hv 0 0).symm
+  exact add_left_cancel h
+
+private theorem PeriodFamily.Boundary.ThirdRelation.verticalProductShear_add (G : Type)
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    (v : C((PeriodTorusHigherHomology.CircleTopology.Circle), G))
+    (hv : ∀ x y, v (x + y) = v x + v y)
+    (x y : (PeriodTorusHigherHomology.CircleTopology.Circle) × G) :
+    verticalProductShear G v (x + y) = verticalProductShear G v x + verticalProductShear G v y := by
+  apply Prod.ext
+  · rfl
+  · change x.2 + y.2 + v (x.1 + y.1) = (x.2 + v x.1) + (y.2 + v y.1)
+    rw [hv]
+    abel
+
+private theorem PeriodFamily.Boundary.ThirdRelation.verticalProductShear_comp_section (G : Type)
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    (v : C((PeriodTorusHigherHomology.CircleTopology.Circle), G))
+    (hv : ∀ x y, v (x + y) = v x + v y) :
+    (verticalProductShear G v).comp (PeriodTorusHigherHomology.CircleTopology.productSection G) =
+      PeriodTorusHigherHomology.CircleTopology.productSection G := by
+  ext x
+  · rfl
+  · change x + v 0 = x
+    rw [circleMorphism_zero G v hv, add_zero]
+
+private theorem PeriodFamily.Boundary.ThirdRelation.verticalProductShear_comp_head (G : Type)
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    (v : C((PeriodTorusHigherHomology.CircleTopology.Circle), G)) :
+    (verticalProductShear G v).comp (circleHeadMap G) =
+      circleHeadMap G + (PeriodTorusHigherHomology.CircleTopology.productSection G).comp v := by
+  ext c
+  · exact (add_zero c).symm
+  · rfl
+
+private theorem PeriodFamily.Boundary.ThirdRelation.circleProduct_identity_eq_add (G : Type)
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G] :
+    ContinuousMap.id ((PeriodTorusHigherHomology.CircleTopology.Circle) × G) =
+      (PeriodTorusHigherHomologyPontryagin.additionMap
+            ((PeriodTorusHigherHomology.CircleTopology.Circle) × G)).comp
+        ((circleHeadMap G).prodMap (PeriodTorusHigherHomology.CircleTopology.productSection G)) :=
+  by
+  apply ContinuousMap.ext
+  rintro ⟨c, x⟩
+  exact Prod.ext (add_zero c).symm (zero_add x).symm
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodFamily.Boundary.ThirdRelation.circleCross_eq_product (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G] (n : ℕ)
+    (b : SingularMayerVietoris.SingularHomology G n) :
+    PeriodTorusHigherHomology.positiveCircleCross G n b =
+      PeriodTorusHigherHomologyPontryagin.product
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) × G) n
+        (SingularMayerVietoris.singularHomologyMap (circleHeadMap G) 1
+          (FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop))
+        (PeriodTorusHigherHomology.circleSectionHomology G n b) := by
+  rw [PeriodTorusHigherHomologyPontryagin.product_apply]
+  rw [←
+    PeriodTorusHigherHomology.crossProductHomology_natural (circleHeadMap G)
+      (PeriodTorusHigherHomology.CircleTopology.productSection G) n
+      (FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop) b]
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp, ←
+    circleProduct_identity_eq_add, PeriodTorusHigherHomology.singularHomologyMap_id]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.Boundary.ThirdRelation.verticalProductShear_headHomology (G : Type)
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    (v : C((PeriodTorusHigherHomology.CircleTopology.Circle), G))
+    (hv : ∀ x y, v (x + y) = v x + v y)
+    (a :
+      SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.CircleTopology.Circle)
+        1) :
+    SingularMayerVietoris.singularHomologyMap (verticalProductShear G v) 1
+        (SingularMayerVietoris.singularHomologyMap (circleHeadMap G) 1 a) =
+      SingularMayerVietoris.singularHomologyMap (circleHeadMap G) 1 a +
+        PeriodTorusHigherHomology.circleSectionHomology G 1
+          (SingularMayerVietoris.singularHomologyMap v 1 a) := by
+  have hzero :
+    ((PeriodTorusHigherHomology.CircleTopology.productSection G).comp v)
+        (0 : (PeriodTorusHigherHomology.CircleTopology.Circle)) =
+      0 := by
+    change (0, v 0) = (0, 0)
+    rw [circleMorphism_zero G v hv]
+  have hsum :
+    SingularMayerVietoris.singularHomologyMap
+        (circleHeadMap G + (PeriodTorusHigherHomology.CircleTopology.productSection G).comp v) 1 =
+      SingularMayerVietoris.singularHomologyMap (circleHeadMap G) 1 +
+        SingularMayerVietoris.singularHomologyMap
+          ((PeriodTorusHigherHomology.CircleTopology.productSection G).comp v) 1 := by
+    simpa only [SingularMayerVietoris.singularHomologyMap_one] using
+      inducedH1_add_of_zero (circleHeadMap G)
+        ((PeriodTorusHigherHomology.CircleTopology.productSection G).comp v)
+        (0 : (PeriodTorusHigherHomology.CircleTopology.Circle)) (circleHeadMap_zero G) hzero
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    verticalProductShear_comp_head, hsum, LinearMap.add_apply,
+    PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.Boundary.ThirdRelation.verticalProductShear_sectionHomology (G : Type)
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    (v : C((PeriodTorusHigherHomology.CircleTopology.Circle), G))
+    (hv : ∀ x y, v (x + y) = v x + v y) (n : ℕ) (b : SingularMayerVietoris.SingularHomology G n) :
+    SingularMayerVietoris.singularHomologyMap (verticalProductShear G v) n
+        (PeriodTorusHigherHomology.circleSectionHomology G n b) =
+      PeriodTorusHigherHomology.circleSectionHomology G n b := by
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    verticalProductShear_comp_section G v hv]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodFamily.Boundary.ThirdRelation.verticalProductShear_positiveCircleCross (G : Type)
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    (v : C((PeriodTorusHigherHomology.CircleTopology.Circle), G))
+    (hv : ∀ x y, v (x + y) = v x + v y) (n : ℕ) (b : SingularMayerVietoris.SingularHomology G n) :
+    SingularMayerVietoris.singularHomologyMap (verticalProductShear G v) (n + 1)
+        (PeriodTorusHigherHomology.positiveCircleCross G n b) =
+      PeriodTorusHigherHomology.positiveCircleCross G n b +
+        PeriodTorusHigherHomology.circleSectionHomology G (n + 1)
+          (PeriodTorusHigherHomologyPontryagin.product G n
+            (SingularMayerVietoris.singularHomologyMap v 1
+              (FirstHurewicz.loopHomologyClass
+                PeriodTorusHigherHomology.CirclePaths.positiveLoop))
+            b) := by
+  rw [circleCross_eq_product,
+    PeriodTorusHigherHomologyPontryagin.product_natural (verticalProductShear G v)
+      (verticalProductShear_add G v hv),
+    verticalProductShear_headHomology G v hv, verticalProductShear_sectionHomology G v hv,
+    (PeriodTorusHigherHomologyPontryagin.product
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) × G) n).map_add,
+    LinearMap.add_apply]
+  rw [← circleCross_eq_product]
+  congr 1
+  exact
+    (PeriodTorusHigherHomologyPontryagin.product_natural
+        (PeriodTorusHigherHomology.CircleTopology.productSection G) (productSection_add G) n
+        (SingularMayerVietoris.singularHomologyMap v 1
+          (FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop))
+        b).symm
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodFamily.Boundary.ThirdRelation.periodCircle (v : Lattice) :
+    C((PeriodTorusHigherHomology.CircleTopology.Circle), RealTorus₄) :=
+  (PeriodTorusHigherHomology.flatTorusCircleHomeomorph.symm :
+        C(PeriodTorusHigherHomology.ProductTorus 4, RealTorus₄)).comp
+    (PeriodTorusHigherHomology.coordinateCircleMap v)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem
+    PeriodFamily.Boundary.ThirdRelation.flatTorusCircleHomeomorph_periodCircle (v : Lattice)
+    (t : (PeriodTorusHigherHomology.CircleTopology.Circle)) :
+    PeriodTorusHigherHomology.flatTorusCircleHomeomorph (periodCircle v t) =
+      PeriodTorusHigherHomology.coordinateCircleMap v t :=
+  PeriodTorusHigherHomology.flatTorusCircleHomeomorph.apply_symm_apply _
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.Boundary.ThirdRelation.periodCircle_real_apply (v : Lattice) (t : ℝ) :
+    periodCircle v (t : (PeriodTorusHigherHomology.CircleTopology.Circle)) =
+      standardLattice.mkQ (t • Elliptic.realCast v) := by
+  apply PeriodTorusHigherHomology.flatTorusCircleHomeomorph.injective
+  rw [flatTorusCircleHomeomorph_periodCircle,
+    PeriodTorusHigherHomology.flatTorusCircleHomeomorph_mkQ]
+  ext i
+  change
+    v i • (t : (PeriodTorusHigherHomology.CircleTopology.Circle)) =
+      (((t * (v i : ℝ)) : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle))
+  rw [← AddCircle.coe_zsmul]
+  congr 1
+  simp only [zsmul_eq_mul, mul_comm]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodFamily.Boundary.ThirdRelation.periodCircle_zero (v : Lattice) :
+    periodCircle v 0 = 0 := by
+  apply PeriodTorusHigherHomology.flatTorusCircleHomeomorph.injective
+  rw [flatTorusCircleHomeomorph_periodCircle, PeriodTorusHigherHomology.coordinateCircleMap_zero,
+    PeriodFamily.FlatTorus.flatTorusCircleHomeomorph_zero]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.Boundary.ThirdRelation.periodCircle_add (v : Lattice)
+    (s t : (PeriodTorusHigherHomology.CircleTopology.Circle)) :
+    periodCircle v (s + t) = periodCircle v s + periodCircle v t := by
+  apply PeriodTorusHigherHomology.flatTorusCircleHomeomorph.injective
+  rw [flatTorusCircleHomeomorph_periodCircle,
+    PeriodTorusHigherHomology.flatTorusCircleHomeomorph_add,
+    flatTorusCircleHomeomorph_periodCircle, flatTorusCircleHomeomorph_periodCircle,
+    PeriodTorusHigherHomology.coordinateCircleMap_add]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.Boundary.ThirdRelation.periodCircle_positiveLoop (v : Lattice) :
+    PeriodTorusHigherHomology.CirclePaths.positiveLoop.map (periodCircle v).continuous =
+      (PeriodFamily.FlatTorus.periodLoop v).cast (periodCircle_zero v) (periodCircle_zero v) := by
+  apply Path.ext
+  funext t
+  change
+    periodCircle v (PeriodTorusHigherHomology.CirclePaths.positiveLoop t) =
+      PeriodFamily.FlatTorus.periodLoop v t
+  rw [PeriodTorusHigherHomology.CirclePaths.positiveLoop_apply, periodCircle_real_apply,
+    PeriodFamily.FlatTorus.periodLoop_apply]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.Boundary.ThirdRelation.periodCircle_positiveHomology (v : Lattice) :
+    SingularMayerVietoris.singularHomologyMap (periodCircle v) 1
+        (FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop) =
+      PeriodFamily.FlatTorus.singularH1Equiv.symm v := by
+  rw [SingularMayerVietoris.singularHomologyMap_one,
+    FirstHurewicz.inducedHomology_loopHomologyClass, periodCircle_positiveLoop,
+    PeriodFamily.FlatTorus.singularH1Equiv_symm_apply]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodFamily.Boundary.ThirdRelation.verticalShear (v : Lattice) :
+    C((PeriodTorusHigherHomology.CircleTopology.Circle) × RealTorus₄,
+      (PeriodTorusHigherHomology.CircleTopology.Circle) × RealTorus₄) :=
+  verticalProductShear RealTorus₄ (periodCircle v)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodFamily.Boundary.ThirdRelation.verticalShearHomeomorph (v : Lattice) :
+    ((PeriodTorusHigherHomology.CircleTopology.Circle) × RealTorus₄) ≃ₜ
+      ((PeriodTorusHigherHomology.CircleTopology.Circle) × RealTorus₄) :=
+  verticalProductShearHomeomorph RealTorus₄ (periodCircle v)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.Boundary.ThirdRelation.verticalShear_positiveCircleCross (v : Lattice)
+    (n : ℕ) (b : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    SingularMayerVietoris.singularHomologyMap (verticalShear v) (n + 1)
+        (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ n b) =
+      PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ n b +
+        PeriodTorusHigherHomology.circleSectionHomology RealTorus₄ (n + 1)
+          (PeriodTorusHigherHomologyPontryagin.product RealTorus₄ n
+            (PeriodFamily.FlatTorus.singularH1Equiv.symm v) b) := by
+  simpa only [verticalShear, periodCircle_positiveHomology] using
+    verticalProductShear_positiveCircleCross RealTorus₄ (periodCircle v) (periodCircle_add v) n b
+
+private def PeriodFamily.Boundary.ThirdRelation.coveredRegularMap (j : Elliptic.Kind) (τ : ℝ) :
+    C((MappingTorus.Circle) × RealTorus₄,
+      ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁
+          SpecialPeriods.specialPeriodMap_generator₂)).Space) :=
+  (PeriodFamily.Boundary.EllipticGaugeLinearization.linearRegularBoundaryMap j τ).comp
+    (PeriodFamily.Boundary.EllipticCapKernelWang.nativeProductCover j)
+
+private def PeriodFamily.Boundary.ThirdRelation.untwistedRegularMap (j : Elliptic.Kind) (τ : ℝ) :
+    C((MappingTorus.Circle) × RealTorus₄,
+      ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁
+          SpecialPeriods.specialPeriodMap_generator₂)).Space) :=
+  (coveredRegularMap j τ).comp
+    ((verticalShearHomeomorph j.twist).symm :
+      C((MappingTorus.Circle) × RealTorus₄, (MappingTorus.Circle) × RealTorus₄))
+
+private theorem
+    PeriodFamily.Boundary.ThirdRelation.untwistedRegularMap_real_apply (j : Elliptic.Kind)
+    (τ t : ℝ) (x : RealTorus₄) :
+    untwistedRegularMap j τ ((t : (MappingTorus.Circle)), x) =
+      ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).quotient
+        (PeriodFamily.Boundary.nativeShiftedBase j τ (t * j.order), x) := by
+  change
+    PeriodFamily.Boundary.EllipticGaugeLinearization.linearRegularBoundaryMap j τ
+        (PeriodFamily.Boundary.EllipticCapKernelWang.nativeProductCover j
+          ((t : (MappingTorus.Circle)), x - periodCircle j.twist (t : (MappingTorus.Circle)))) =
+      _
+  rw [PeriodFamily.Boundary.EllipticCapKernelWang.nativeProductCover_real_apply,
+    PeriodFamily.Boundary.EllipticGaugeLinearization.linearRegularBoundaryMap_mk,
+    periodCircle_real_apply]
+  have hm : (j.order : ℝ) ≠ 0 := by exact_mod_cast j.order_pos.ne'
+  rw [mul_div_cancel_right₀ _ hm, sub_add_cancel]
+
+private theorem
+    PeriodFamily.Boundary.ThirdRelation.untwistedRegularMap_comp_shear (j : Elliptic.Kind)
+    (τ : ℝ) : (untwistedRegularMap j τ).comp (verticalShear j.twist) = coveredRegularMap j τ := by
+  apply ContinuousMap.ext
+  intro p
+  change
+    coveredRegularMap j τ
+        ((verticalShearHomeomorph j.twist).symm (verticalShearHomeomorph j.twist p)) =
+      _
+  rw [Homeomorph.symm_apply_apply]
+
+private theorem PeriodFamily.Boundary.ThirdRelation.familyNegation_comp_untwistedRegularMap
+    (j : Elliptic.Kind) (τ : ℝ) :
+    (familyNegation
+            (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)).comp
+        (untwistedRegularMap j τ) =
+      (untwistedRegularMap j τ).comp (PeriodTorusHigherHomology.circleProductMap flatNegation) := by
+  apply ContinuousMap.ext
+  rintro ⟨c, x⟩
+  obtain ⟨t, rfl⟩ := QuotientAddGroup.mk_surjective c
+  change
+    familyNegation
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        (untwistedRegularMap j τ ((t : (MappingTorus.Circle)), x)) =
+      untwistedRegularMap j τ ((t : (MappingTorus.Circle)), -x)
+  rw [untwistedRegularMap_real_apply, familyNegation_quotient, untwistedRegularMap_real_apply]
+
+private theorem PeriodFamily.Boundary.ThirdRelation.untwistedRegularMap_positiveCircleCross_negation
+    (j : Elliptic.Kind) (τ : ℝ) (a : SingularMayerVietoris.SingularHomology RealTorus₄ 2) :
+    SingularMayerVietoris.singularHomologyMap
+        (familyNegation
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂))
+        3
+        (SingularMayerVietoris.singularHomologyMap (untwistedRegularMap j τ) 3
+          (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ 2 a)) =
+      SingularMayerVietoris.singularHomologyMap (untwistedRegularMap j τ) 3
+        (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ 2 a) := by
+  have h :=
+    congrArg
+      (fun f :
+          C((MappingTorus.Circle) × RealTorus₄,
+            ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                SpecialPeriods.specialPeriodMap_generator₁
+                SpecialPeriods.specialPeriodMap_generator₂)).Space) =>
+        SingularMayerVietoris.singularHomologyMap f 3)
+      (familyNegation_comp_untwistedRegularMap j τ)
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodTorusHigherHomology.singularHomologyMap_comp] at h
+  have ha := LinearMap.congr_fun h (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ 2 a)
+  simpa only [LinearMap.comp_apply, PeriodTorusHigherHomology.positiveCircleCross_naturality,
+    flatNegation_homology_two] using ha
+
+private theorem PeriodFamily.Boundary.ThirdRelation.untwistedRegularMap_comp_circleSection
+    (j : Elliptic.Kind) (τ : ℝ) :
+    (untwistedRegularMap j τ).comp
+        (PeriodTorusHigherHomology.CircleTopology.productSection RealTorus₄) =
+      PeriodFamily.Homology.pointFamilyFibreInclusion
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        (PeriodFamily.Boundary.nativeShiftedBase j τ 0) := by
+  apply ContinuousMap.ext
+  intro x
+  change
+    untwistedRegularMap j τ (0, x) =
+      ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).quotient
+        (PeriodFamily.Boundary.nativeShiftedBase j τ 0, x)
+  have h := untwistedRegularMap_real_apply j τ 0 x
+  simpa only [AddCircle.coe_zero, MulZeroClass.zero_mul] using h
+
+private theorem PeriodFamily.Boundary.ThirdRelation.untwistedRegularMap_circleSection_homology
+    (j : Elliptic.Kind) (τ : ℝ) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    SingularMayerVietoris.singularHomologyMap (untwistedRegularMap j τ) n
+        (PeriodTorusHigherHomology.circleSectionHomology RealTorus₄ n a) =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodFamily.Homology.familyFibreInclusion
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+          PeriodFamily.Homology.normalizedSlitBaseLift)
+        n a := by
+  have h :=
+    congrArg
+      (fun f :
+          C(RealTorus₄,
+            ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                SpecialPeriods.specialPeriodMap_generator₁
+                SpecialPeriods.specialPeriodMap_generator₂)).Space) =>
+        SingularMayerVietoris.singularHomologyMap f n)
+      (untwistedRegularMap_comp_circleSection j τ)
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodFamily.Homology.pointFamilyFibreInclusion_homology_eq_normalized] at h
+  exact LinearMap.congr_fun h a
+
+private theorem PeriodFamily.Boundary.ThirdRelation.coveredRegularMap_positiveCircleCross
+    (j : Elliptic.Kind) (τ : ℝ) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    SingularMayerVietoris.singularHomologyMap (coveredRegularMap j τ) (n + 1)
+        (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ n a) =
+      SingularMayerVietoris.singularHomologyMap (untwistedRegularMap j τ) (n + 1)
+          (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ n a) +
+        SingularMayerVietoris.singularHomologyMap
+          (PeriodFamily.Homology.familyFibreInclusion
+            (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)
+            PeriodFamily.Homology.normalizedSlitBaseLift)
+          (n + 1)
+          (PeriodTorusHigherHomologyPontryagin.product RealTorus₄ n
+            (PeriodFamily.FlatTorus.singularH1Equiv.symm j.twist) a) := by
+  have h :=
+    congrArg
+      (fun f :
+          C((MappingTorus.Circle) × RealTorus₄,
+            ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                SpecialPeriods.specialPeriodMap_generator₁
+                SpecialPeriods.specialPeriodMap_generator₂)).Space) =>
+        SingularMayerVietoris.singularHomologyMap f (n + 1))
+      (untwistedRegularMap_comp_shear j τ)
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp] at h
+  have ha := LinearMap.congr_fun h (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ n a)
+  simpa only [LinearMap.comp_apply, verticalShear_positiveCircleCross, map_add,
+    untwistedRegularMap_circleSection_homology] using ha.symm
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.Boundary.ThirdRelation.flat_tripleProduct_exterior (a b c : Lattice) :
+    PeriodFamily.FlatTorus.singularH3Equiv
+        (PeriodTorusHigherHomologyPontryagin.tripleProduct RealTorus₄
+          (PeriodFamily.FlatTorus.singularH1Equiv.symm a)
+          (PeriodFamily.FlatTorus.singularH1Equiv.symm b)
+          (PeriodFamily.FlatTorus.singularH1Equiv.symm c)) =
+      exteriorPower.ιMulti ℤ 3 ![a, b, c] := by
+  rw [PeriodFamily.FlatTorus.singularH3Equiv_apply,
+    PeriodTorusHigherHomologyPontryagin.tripleProduct_natural _
+      PeriodTorusHigherHomology.flatTorusCircleHomeomorph_add,
+    PeriodFamily.FlatTorus.coordinateH1_flatMarking,
+    PeriodFamily.FlatTorus.coordinateH1_flatMarking,
+    PeriodFamily.FlatTorus.coordinateH1_flatMarking]
+  calc
+    _ =
+        PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv
+          (PeriodTorusHigherHomology.coordinateTorusWedgeThree
+            (exteriorPower.ιMulti ℤ 3 ![a, b, c])) :=
+      congrArg PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv
+        (PeriodTorusHigherHomology.coordinateTorusWedgeThree_apply_ιMulti ![a, b, c]).symm
+    _ = _ := PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv_wedge _
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.Boundary.ThirdRelation.flat_triple_uw_coordinates (a : Lattice) :
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (PeriodTorusHigherHomologyPontryagin.tripleProduct RealTorus₄
+          (PeriodFamily.FlatTorus.singularH1Equiv.symm a)
+          (PeriodFamily.FlatTorus.singularH1Equiv.symm (Pi.single 1 1))
+          (PeriodFamily.FlatTorus.singularH1Equiv.symm (Pi.single 2 1))) =
+      ![a 0, 0, 0, a 3] := by
+  rw [PeriodFamily.FlatTorus.singularH3Coordinates_apply, flat_tripleProduct_exterior]
+  funext i
+  rw [PeriodTorusHigherHomologyExterior.cubeCoordinates_apply,
+    PeriodTorusHigherHomologyExterior.cubeBasis, Module.Basis.repr_reindex_apply]
+  change
+    ((Pi.basisFun ℤ (Fin 4)).exteriorPower 3).repr
+        (exteriorPower.ιMulti ℤ 3 ![a, Pi.single 1 1, Pi.single 2 1])
+        (PeriodTorusHigherHomologyExterior.tripleSubset i) =
+      _
+  rw [exteriorPower.basis_repr_apply, exteriorPower.ιMultiDual_apply_ιMulti]
+  simp only [PeriodTorusHigherHomologyExterior.tripleSubset_ordered, Module.Basis.coord_apply,
+    Pi.basisFun_repr]
+  fin_cases i <;> simp [LocalSystemMatrices.tripleIndices, Matrix.det_fin_three]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodFamily.Boundary.ThirdRelation.gammaUWClass :
+    SingularMayerVietoris.SingularHomology RealTorus₄ 3 :=
+  PeriodFamily.FlatTorus.singularH3Coordinates.symm ![1, 0, 0, 0]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.Boundary.ThirdRelation.gammaUWClass_coordinates :
+    PeriodFamily.FlatTorus.singularH3Coordinates gammaUWClass = ![1, 0, 0, 0] :=
+  PeriodFamily.FlatTorus.singularH3Coordinates.apply_symm_apply _
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodFamily.Boundary.ThirdRelation.splitFibreClassTwo_eq_product (j : Elliptic.Kind) :
+    PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreClassTwo j =
+      PeriodTorusHigherHomologyPontryagin.product11 RealTorus₄
+        (PeriodFamily.FlatTorus.singularH1Equiv.symm (Pi.single 1 1))
+        (PeriodFamily.FlatTorus.singularH1Equiv.symm (Pi.single 2 1)) := by
+  apply PeriodFamily.FlatTorus.singularH2Coordinates.injective
+  rw [PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreClassTwo_coordinates,
+    ThreefoldHomology.DeltaSweep.flat_product11_coordinates]
+  simp
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodFamily.Boundary.ThirdRelation.splitCircleClassTwo_eq_product (j : Elliptic.Kind) :
+    PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassTwo j =
+      PeriodTorusHigherHomologyPontryagin.product11 RealTorus₄
+        (PeriodFamily.FlatTorus.singularH1Equiv.symm j.twist)
+        (PeriodFamily.FlatTorus.singularH1Equiv.symm (Pi.single 2 1)) := by
+  apply PeriodFamily.FlatTorus.singularH2Coordinates.injective
+  rw [PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassTwo_coordinates,
+    ThreefoldHomology.DeltaSweep.flat_product11_coordinates]
+  cases j <;> simp [Elliptic.Kind.twist, ε, ε']
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.Boundary.ThirdRelation.twist_product_splitFibre (j : Elliptic.Kind) :
+    PeriodTorusHigherHomologyPontryagin.product RealTorus₄ 2
+        (PeriodFamily.FlatTorus.singularH1Equiv.symm j.twist)
+        (PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreClassTwo j) =
+      j.twist 0 • gammaUWClass := by
+  rw [splitFibreClassTwo_eq_product]
+  apply PeriodFamily.FlatTorus.singularH3Coordinates.injective
+  change
+    PeriodFamily.FlatTorus.singularH3Coordinates
+        (PeriodTorusHigherHomologyPontryagin.tripleProduct RealTorus₄
+          (PeriodFamily.FlatTorus.singularH1Equiv.symm j.twist)
+          (PeriodFamily.FlatTorus.singularH1Equiv.symm (Pi.single 1 1))
+          (PeriodFamily.FlatTorus.singularH1Equiv.symm (Pi.single 2 1))) =
+      _
+  rw [flat_triple_uw_coordinates, map_zsmul, gammaUWClass_coordinates]
+  cases j <;> ext i <;> fin_cases i <;> simp [Elliptic.Kind.twist, ε, ε']
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.Boundary.ThirdRelation.twist_product_splitCircle (j : Elliptic.Kind) :
+    PeriodTorusHigherHomologyPontryagin.product RealTorus₄ 2
+        (PeriodFamily.FlatTorus.singularH1Equiv.symm j.twist)
+        (PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassTwo j) =
+      0 := by
+  rw [splitCircleClassTwo_eq_product]
+  have := PeriodTorusHigherHomology.realTorus_homology_torsionFree 2
+  exact PeriodTorusHigherHomologyPontryagin.tripleProduct_self01 RealTorus₄ _ _
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.Boundary.ThirdRelation.three_shear_correction :
+    PeriodTorusHigherHomologyPontryagin.product RealTorus₄ 2
+        (PeriodFamily.FlatTorus.singularH1Equiv.symm Elliptic.Kind.three.twist)
+        (4 • PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreClassTwo .three +
+          2 • PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassTwo .three) =
+      (4 : ℤ) • gammaUWClass := by
+  rw [map_add, map_nsmul, map_nsmul, twist_product_splitFibre, twist_product_splitCircle]
+  simp [Elliptic.Kind.twist, ε, ofNat_zsmul]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodFamily.Boundary.ThirdRelation.four_shear_correction :
+    PeriodTorusHigherHomologyPontryagin.product RealTorus₄ 2
+        (PeriodFamily.FlatTorus.singularH1Equiv.symm Elliptic.Kind.four.twist)
+        (3 • PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreClassTwo .four -
+          PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassTwo .four) =
+      (-3 : ℤ) • gammaUWClass := by
+  rw [map_sub, map_nsmul, twist_product_splitFibre, twist_product_splitCircle]
+  simp [Elliptic.Kind.twist, ε', ofNat_zsmul]
+
+private def PeriodFamily.Boundary.ThirdRelation.referenceCoverInput :
+    Elliptic.Kind → SingularMayerVietoris.SingularHomology RealTorus₄ 2
+  | .three =>
+    4 • PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreClassTwo .three +
+      2 • PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassTwo .three
+  | .four =>
+    3 • PeriodFamily.Boundary.EllipticCapKernelWang.splitFibreClassTwo .four -
+      PeriodFamily.Boundary.EllipticCapKernelWang.splitCircleClassTwo .four
+
+private theorem
+    PeriodFamily.Boundary.ThirdRelation.referenceClasses_elliptic_cover (j : Elliptic.Kind) :
+    (ThreefoldHomology.ThirdDegree.referenceClasses (Option.some j)).val =
+      SingularMayerVietoris.singularHomologyMap
+        (PeriodFamily.Boundary.EllipticCapKernelWang.nativeProductCover j) 3
+        (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ 2 (referenceCoverInput j)) := by
+  cases j
+  · change
+      ((PeriodFamily.Boundary.EllipticCapProduct.boundaryCapKernelEquiv .three 2).symm _).val = _
+    rw [PeriodFamily.Boundary.EllipticCapProduct.boundaryCapKernelEquiv_symm_val]
+    simpa only [referenceCoverInput, ofNat_zsmul] using! capCircle_three_reference
+  · change
+      ((PeriodFamily.Boundary.EllipticCapProduct.boundaryCapKernelEquiv .four 2).symm _).val = _
+    rw [PeriodFamily.Boundary.EllipticCapProduct.boundaryCapKernelEquiv_symm_val]
+    simpa only [referenceCoverInput, ofNat_zsmul] using! capCircle_four_reference
+
+private theorem PeriodFamily.Boundary.ThirdRelation.referenceClasses_elliptic_regular_cover
+    (j : Elliptic.Kind) :
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some j) 3
+        (ThreefoldHomology.ThirdDegree.referenceClasses (Option.some j)).val =
+      SingularMayerVietoris.singularHomologyMap (coveredRegularMap j 0) 3
+        (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ 2 (referenceCoverInput j)) := by
+  rw [referenceClasses_elliptic_cover,
+    PeriodFamily.Boundary.EllipticGaugeLinearization.boundaryRegularHomologyMap_linear j 0 3]
+  exact
+    (LinearMap.congr_fun
+        (PeriodTorusHigherHomology.singularHomologyMap_comp
+          (PeriodFamily.Boundary.EllipticCapKernelWang.nativeProductCover j)
+          (PeriodFamily.Boundary.EllipticGaugeLinearization.linearRegularBoundaryMap j 0) 3)
+        (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ 2 (referenceCoverInput j))).symm
+
+private def PeriodFamily.Boundary.ThirdRelation.ellipticHorizontal (j : Elliptic.Kind) :
+    SingularMayerVietoris.SingularHomology
+      ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁
+          SpecialPeriods.specialPeriodMap_generator₂)).Space
+      3 :=
+  SingularMayerVietoris.singularHomologyMap (untwistedRegularMap j 0) 3
+    (PeriodTorusHigherHomology.positiveCircleCross RealTorus₄ 2 (referenceCoverInput j))
+
+private theorem
+    PeriodFamily.Boundary.ThirdRelation.ellipticHorizontal_negation (j : Elliptic.Kind) :
+    SingularMayerVietoris.singularHomologyMap
+        (familyNegation
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂))
+        3 (ellipticHorizontal j) =
+      ellipticHorizontal j :=
+  untwistedRegularMap_positiveCircleCross_negation j 0 (referenceCoverInput j)
+
+private def PeriodFamily.Boundary.ThirdRelation.regularGammaUW :
+    SingularMayerVietoris.SingularHomology
+      ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁
+          SpecialPeriods.specialPeriodMap_generator₂)).Space
+      3 :=
+  SingularMayerVietoris.singularHomologyMap
+    (PeriodFamily.Homology.familyFibreInclusion
+      (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+      PeriodFamily.Homology.normalizedSlitBaseLift)
+    3 gammaUWClass
+
+private theorem PeriodFamily.Boundary.ThirdRelation.referenceClasses_three_regular :
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some .three) 3
+        (ThreefoldHomology.ThirdDegree.referenceClasses (Option.some .three)).val =
+      ellipticHorizontal .three + (4 : ℤ) • regularGammaUW := by
+  rw [referenceClasses_elliptic_regular_cover, coveredRegularMap_positiveCircleCross]
+  change
+    ellipticHorizontal .three +
+        SingularMayerVietoris.singularHomologyMap
+          (PeriodFamily.Homology.familyFibreInclusion
+            (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)
+            PeriodFamily.Homology.normalizedSlitBaseLift)
+          3
+          (PeriodTorusHigherHomologyPontryagin.product RealTorus₄ 2
+            (PeriodFamily.FlatTorus.singularH1Equiv.symm Elliptic.Kind.three.twist)
+            (referenceCoverInput .three)) =
+      _
+  rw [referenceCoverInput, three_shear_correction, map_zsmul]
+  rfl
+
+private theorem PeriodFamily.Boundary.ThirdRelation.referenceClasses_four_regular :
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some .four) 3
+        (ThreefoldHomology.ThirdDegree.referenceClasses (Option.some .four)).val =
+      ellipticHorizontal .four + (-3 : ℤ) • regularGammaUW := by
+  rw [referenceClasses_elliptic_regular_cover, coveredRegularMap_positiveCircleCross]
+  change
+    ellipticHorizontal .four +
+        SingularMayerVietoris.singularHomologyMap
+          (PeriodFamily.Homology.familyFibreInclusion
+            (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)
+            PeriodFamily.Homology.normalizedSlitBaseLift)
+          3
+          (PeriodTorusHigherHomologyPontryagin.product RealTorus₄ 2
+            (PeriodFamily.FlatTorus.singularH1Equiv.symm Elliptic.Kind.four.twist)
+            (referenceCoverInput .four)) =
+      _
+  rw [referenceCoverInput, four_shear_correction, map_zsmul]
+  rfl
+
+private theorem PeriodFamily.Boundary.ThirdRelation.negation_fixed_source_zero
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (a : SingularMayerVietoris.SingularHomology D.Space 3)
+    (hneg : SingularMayerVietoris.singularHomologyMap (familyNegation D) 3 a = a)
+    (hsource : PeriodFamily.Homology.sourceKernelProjection D 2 a = 0) : a = 0 := by
+  have ha :
+    a ∈
+      LinearMap.range
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodFamily.Homology.familyFibreInclusion D
+            PeriodFamily.Homology.normalizedSlitBaseLift)
+          3) := by
+    rw [← PeriodFamily.Homology.sourceKernelProjection_kernel D 2]
+    exact hsource
+  obtain ⟨b, hb⟩ := ha
+  have hminus : SingularMayerVietoris.singularHomologyMap (familyNegation D) 3 a = -a := by
+    rw [← hb]
+    exact familyNegation_homology_fibre_three D PeriodFamily.Homology.normalizedSlitBaseLift b
+  have heq : a = -a := hneg.symm.trans hminus
+  apply (PeriodFamily.Homology.familyH3Equiv D).injective
+  rw [map_zero]
+  ext i
+  have hi := congrArg (fun x => PeriodFamily.Homology.familyH3Equiv D x i) heq
+  simp only [map_neg, Pi.neg_apply] at hi
+  change PeriodFamily.Homology.familyH3Equiv D a i = 0
+  omega
+
+private theorem PeriodFamily.Boundary.ThirdRelation.regularGammaUW_eq_thirdFibreCyclicMap :
+    regularGammaUW = ThreefoldHomology.ThirdDegree.thirdFibreCyclicMap 1 := by
+  rw [ThreefoldHomology.ThirdDegree.thirdFibreCyclicMap_apply]
+  rfl
+
+private theorem PeriodFamily.Boundary.ThirdRelation.regularGammaUW_source_eq_zero :
+    PeriodFamily.Homology.sourceKernelProjection
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        2 regularGammaUW =
+      0 := by
+  rw [regularGammaUW_eq_thirdFibreCyclicMap]
+  exact ThreefoldHomology.ThirdDegree.thirdFibreCyclicMap_source_eq_zero 1
+
+private def PeriodFamily.Boundary.ThirdRelation.horizontalRemainder :
+    SingularMayerVietoris.SingularHomology
+      ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁
+          SpecialPeriods.specialPeriodMap_generator₂)).Space
+      3 :=
+  ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none 3
+        (ThreefoldHomology.ThirdDegree.referenceClasses Option.none).val +
+      ellipticHorizontal .three +
+    ellipticHorizontal .four
+
+private theorem PeriodFamily.Boundary.ThirdRelation.referenceClasses_regular_split :
+    ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 3
+        ThreefoldHomology.ThirdDegree.referenceClasses =
+      horizontalRemainder + regularGammaUW := by
+  classical
+  rw [ThreefoldHomology.CapElimination.nativeCapKernelRegularMap_apply, Fintype.sum_option]
+  have hu : (Finset.univ : Finset Elliptic.Kind) = {.three, .four} := by
+    ext j
+    cases j <;> simp
+  rw [hu, Finset.sum_pair (by decide : Elliptic.Kind.three ≠ .four),
+    referenceClasses_three_regular, referenceClasses_four_regular]
+  unfold horizontalRemainder
+  abel
+
+private theorem PeriodFamily.Boundary.ThirdRelation.horizontalRemainder_source_eq_zero :
+    PeriodFamily.Homology.sourceKernelProjection
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        2 horizontalRemainder =
+      0 := by
+  have h := ThreefoldHomology.ThirdDegree.referenceClasses_source_eq_zero
+  change
+    PeriodFamily.Homology.sourceKernelProjection
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        2
+        (ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 3
+          ThreefoldHomology.ThirdDegree.referenceClasses) =
+      0 at h
+  rw [referenceClasses_regular_split, map_add, regularGammaUW_source_eq_zero, add_zero] at h
+  exact h
+
+private theorem PeriodFamily.Boundary.ThirdRelation.horizontalRemainder_negation
+    (hC :
+      SingularMayerVietoris.singularHomologyMap
+          (familyNegation
+            (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂))
+          3
+          (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none 3
+            (ThreefoldHomology.ThirdDegree.referenceClasses Option.none).val) =
+        ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none 3
+          (ThreefoldHomology.ThirdDegree.referenceClasses Option.none).val) :
+    SingularMayerVietoris.singularHomologyMap
+        (familyNegation
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂))
+        3 horizontalRemainder =
+      horizontalRemainder := by
+  unfold horizontalRemainder
+  rw [map_add, map_add, hC, ellipticHorizontal_negation, ellipticHorizontal_negation]
+
+private theorem PeriodFamily.Boundary.ThirdRelation.referenceClasses_regular_of_cusp_negation
+    (hC :
+      SingularMayerVietoris.singularHomologyMap
+          (familyNegation
+            (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂))
+          3
+          (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none 3
+            (ThreefoldHomology.ThirdDegree.referenceClasses Option.none).val) =
+        ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none 3
+          (ThreefoldHomology.ThirdDegree.referenceClasses Option.none).val) :
+    ThreefoldHomology.CapElimination.nativeCapKernelRegularMap 3
+        ThreefoldHomology.ThirdDegree.referenceClasses =
+      ThreefoldHomology.ThirdDegree.thirdFibreCyclicMap 1 := by
+  have hzero : horizontalRemainder = 0 :=
+    negation_fixed_source_zero
+      (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+      horizontalRemainder (horizontalRemainder_negation hC) horizontalRemainder_source_eq_zero
+  rw [referenceClasses_regular_split, hzero, zero_add, regularGammaUW_eq_thirdFibreCyclicMap]
+
+private theorem PeriodFamily.Boundary.ThirdRelation.cuspMonodromy_negation_mo1973_30380
+    (x : RealTorus₄) :
+    flatNegation (ThreefoldOverlapMappingTorus.monodromy Option.none x) =
+      ThreefoldOverlapMappingTorus.monodromy Option.none (flatNegation x) := by
+  obtain ⟨v, rfl⟩ := standardLattice.mkQ_surjective x
+  change
+    -SpecialPeriods.CuspFamily.cuspTorusHomeomorph 1 (standardLattice.mkQ v) =
+      SpecialPeriods.CuspFamily.cuspTorusHomeomorph 1 (-standardLattice.mkQ v)
+  rw [← map_neg standardLattice.mkQ v, SpecialPeriods.CuspFamily.cuspTorusHomeomorph_mkQ,
+    SpecialPeriods.CuspFamily.cuspTorusHomeomorph_mkQ, map_neg, map_neg]
+
+private theorem PeriodFamily.Boundary.ThirdRelation.cuspNegation_eq_mappingTorusMap
+    (N :
+      C(ThreefoldOverlapMappingTorus.Boundary Option.none,
+        ThreefoldOverlapMappingTorus.Boundary Option.none))
+    (hN :
+      ∀ (t : ℝ) (x : RealTorus₄),
+        N (MappingTorus.mk (ThreefoldOverlapMappingTorus.monodromy Option.none) (t, x)) =
+          MappingTorus.mk (ThreefoldOverlapMappingTorus.monodromy Option.none) (t, -x)) :
+    N =
+      CuspBoundaryGammaZero.mappingTorusMap (ThreefoldOverlapMappingTorus.monodromy Option.none)
+        (ThreefoldOverlapMappingTorus.monodromy Option.none) flatNegation
+        cuspMonodromy_negation_mo1973_30380 := by
+  apply ContinuousMap.ext
+  intro p
+  obtain ⟨⟨t, x⟩, rfl⟩ :=
+    MappingTorus.mk_surjective (ThreefoldOverlapMappingTorus.monodromy Option.none) p
+  exact hN t x
+
+private theorem PeriodFamily.Boundary.ThirdRelation.cuspNegation_wang
+    (N :
+      C(ThreefoldOverlapMappingTorus.Boundary Option.none,
+        ThreefoldOverlapMappingTorus.Boundary Option.none))
+    (hN :
+      ∀ (t : ℝ) (x : RealTorus₄),
+        N (MappingTorus.mk (ThreefoldOverlapMappingTorus.monodromy Option.none) (t, x)) =
+          MappingTorus.mk (ThreefoldOverlapMappingTorus.monodromy Option.none) (t, -x))
+    (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology (ThreefoldOverlapMappingTorus.Boundary Option.none)
+        (n + 1)) :
+    MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy Option.none) n
+        (SingularMayerVietoris.singularHomologyMap N (n + 1) a) =
+      SingularMayerVietoris.singularHomologyMap flatNegation n
+        (MappingTorusHomology.wangBoundary (ThreefoldOverlapMappingTorus.monodromy Option.none) n
+          a) := by
+  rw [cuspNegation_eq_mappingTorusMap N hN]
+  exact
+    CuspBoundaryGammaZero.wangBoundary_mappingTorusMap
+      (ThreefoldOverlapMappingTorus.monodromy Option.none)
+      (ThreefoldOverlapMappingTorus.monodromy Option.none) flatNegation
+      cuspMonodromy_negation_mo1973_30380 n a
+
+private theorem PeriodFamily.Boundary.ThirdRelation.cuspNegation_regular_comp
+    (N :
+      C(ThreefoldOverlapMappingTorus.Boundary Option.none,
+        ThreefoldOverlapMappingTorus.Boundary Option.none))
+    (hN :
+      ∀ (t : ℝ) (x : RealTorus₄),
+        N (MappingTorus.mk (ThreefoldOverlapMappingTorus.monodromy Option.none) (t, x)) =
+          MappingTorus.mk (ThreefoldOverlapMappingTorus.monodromy Option.none) (t, -x)) :
+    (familyNegation
+            (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)).comp
+        (ThreefoldOverlapMappingTorus.boundaryToRegularFamily Option.none) =
+      (ThreefoldOverlapMappingTorus.boundaryToRegularFamily Option.none).comp N := by
+  apply ContinuousMap.ext
+  intro p
+  obtain ⟨⟨t, x⟩, rfl⟩ :=
+    MappingTorus.mk_surjective (ThreefoldOverlapMappingTorus.monodromy Option.none) p
+  change
+    familyNegation
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        (ThreefoldOverlapMappingTorus.boundaryToRegularFamily Option.none
+          (MappingTorus.mk (ThreefoldOverlapMappingTorus.monodromy Option.none) (t, x))) =
+      ThreefoldOverlapMappingTorus.boundaryToRegularFamily Option.none
+        (N (MappingTorus.mk (ThreefoldOverlapMappingTorus.monodromy Option.none) (t, x)))
+  rw [hN]
+  change
+    familyNegation
+        (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂)
+        (ThreefoldOverlapMappingTorus.boundaryToRegularFamily Option.none
+          (MappingTorus.mk ThreefoldOverlapMappingTorus.Cusp.monodromy (t, x))) =
+      ThreefoldOverlapMappingTorus.boundaryToRegularFamily Option.none
+        (MappingTorus.mk ThreefoldOverlapMappingTorus.Cusp.monodromy (t, -x))
+  rw [ThreefoldOverlapMappingTorus.Cusp.boundaryToRegularFamily_cusp_mk,
+    ThreefoldOverlapMappingTorus.Cusp.boundaryToRegularFamily_cusp_mk]
+  rfl
+
+private theorem PeriodFamily.Boundary.ThirdRelation.cuspNegation_cap_zero
+    (N :
+      C(ThreefoldOverlapMappingTorus.Boundary Option.none,
+        ThreefoldOverlapMappingTorus.Boundary Option.none))
+    (J :
+      C(SpecialPeriods.Threefold.localPiece (Option.some Option.none),
+        SpecialPeriods.Threefold.localPiece (Option.some Option.none)))
+    (hJ :
+      (ThreefoldOverlapMappingTorus.boundaryToFilling Option.none).comp N =
+        J.comp (ThreefoldOverlapMappingTorus.boundaryToFilling Option.none))
+    (a :
+      SingularMayerVietoris.SingularHomology (ThreefoldOverlapMappingTorus.Boundary Option.none)
+        3)
+    (ha : ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none 3 a = 0) :
+    ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none 3
+        (SingularMayerVietoris.singularHomologyMap N 3 a) =
+      0 := by
+  have h :=
+    congrArg
+      (fun f :
+          C(ThreefoldOverlapMappingTorus.Boundary Option.none,
+            SpecialPeriods.Threefold.localPiece (Option.some Option.none)) =>
+        SingularMayerVietoris.singularHomologyMap f 3)
+      hJ
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodTorusHigherHomology.singularHomologyMap_comp] at h
+  have he := LinearMap.congr_fun h a
+  change
+    ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none 3
+        (SingularMayerVietoris.singularHomologyMap N 3 a) =
+      SingularMayerVietoris.singularHomologyMap J 3
+        (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none 3 a) at he
+  rw [he, ha, map_zero]
+
+private theorem PeriodFamily.Boundary.ThirdRelation.cuspNegation_capKernel_fixed
+    (N :
+      C(ThreefoldOverlapMappingTorus.Boundary Option.none,
+        ThreefoldOverlapMappingTorus.Boundary Option.none))
+    (hN :
+      ∀ (t : ℝ) (x : RealTorus₄),
+        N (MappingTorus.mk (ThreefoldOverlapMappingTorus.monodromy Option.none) (t, x)) =
+          MappingTorus.mk (ThreefoldOverlapMappingTorus.monodromy Option.none) (t, -x))
+    (J :
+      C(SpecialPeriods.Threefold.localPiece (Option.some Option.none),
+        SpecialPeriods.Threefold.localPiece (Option.some Option.none)))
+    (hJ :
+      (ThreefoldOverlapMappingTorus.boundaryToFilling Option.none).comp N =
+        J.comp (ThreefoldOverlapMappingTorus.boundaryToFilling Option.none))
+    (a : LinearMap.ker (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none 3)) :
+    SingularMayerVietoris.singularHomologyMap N 3 a.val = a.val := by
+  apply ThreefoldHomologyCuspFibre.cuspCap_wang_ext 2
+  · exact (cuspNegation_cap_zero N J hJ a.val a.property).trans a.property.symm
+  · rw [cuspNegation_wang N hN, flatNegation_homology_two]
+
+private theorem PeriodFamily.Boundary.ThirdRelation.cuspNegation_capKernel_regular_fixed
+    (N :
+      C(ThreefoldOverlapMappingTorus.Boundary Option.none,
+        ThreefoldOverlapMappingTorus.Boundary Option.none))
+    (hN :
+      ∀ (t : ℝ) (x : RealTorus₄),
+        N (MappingTorus.mk (ThreefoldOverlapMappingTorus.monodromy Option.none) (t, x)) =
+          MappingTorus.mk (ThreefoldOverlapMappingTorus.monodromy Option.none) (t, -x))
+    (J :
+      C(SpecialPeriods.Threefold.localPiece (Option.some Option.none),
+        SpecialPeriods.Threefold.localPiece (Option.some Option.none)))
+    (hJ :
+      (ThreefoldOverlapMappingTorus.boundaryToFilling Option.none).comp N =
+        J.comp (ThreefoldOverlapMappingTorus.boundaryToFilling Option.none))
+    (a : LinearMap.ker (ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap Option.none 3)) :
+    SingularMayerVietoris.singularHomologyMap
+        (familyNegation
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂))
+        3 (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none 3 a.val) =
+      ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none 3 a.val := by
+  have h :=
+    congrArg
+      (fun f :
+          C(ThreefoldOverlapMappingTorus.Boundary Option.none,
+            ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                SpecialPeriods.specialPeriodMap_generator₁
+                SpecialPeriods.specialPeriodMap_generator₂)).Space) =>
+        SingularMayerVietoris.singularHomologyMap f 3)
+      (cuspNegation_regular_comp N hN)
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodTorusHigherHomology.singularHomologyMap_comp] at h
+  have he := LinearMap.congr_fun h a.val
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (familyNegation
+          (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂))
+        3 (ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none 3 a.val) =
+      ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap Option.none 3
+        (SingularMayerVietoris.singularHomologyMap N 3 a.val) at he
+  rw [he, cuspNegation_capKernel_fixed N hN J hJ]
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/PeriodFamily/HolomorphicPeriodMap1.lean b/LeanPool/HopfProblem/PeriodFamily/HolomorphicPeriodMap1.lean
new file mode 100644
index 000000000..602d9493e
--- /dev/null
+++ b/LeanPool/HopfProblem/PeriodFamily/HolomorphicPeriodMap1.lean
@@ -0,0 +1,395 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Foundations.Core3
+public import LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+
+/-!
+# Hopf problem: period family · holomorphic period map 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private abbrev
+    HolomorphicPeriodMap.TotalSpace {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] (_P : HolomorphicPeriodMap V B) :=
+  B × RealTorus₄
+
+private def HolomorphicPeriodMap.quotientMap {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B) :
+    (B × ComplexPlane₂) → P.TotalSpace := fun x =>
+  (x.1, standardLattice.mkQ ((P.periodEquiv x.1).symm x.2))
+
+private theorem
+    HolomorphicPeriodMap.quotientMap_localHomeomorph {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B) :
+    IsLocalHomeomorph P.quotientMap := by
+  have : DiscreteTopology standardLattice.toAddSubgroup :=
+    inferInstanceAs (DiscreteTopology standardLattice)
+  have h :=
+    (AddSubgroup.isAddQuotientCoveringMap_of_comm standardLattice.toAddSubgroup
+        DiscreteTopology.isDiscrete).isCoveringMap.isLocalHomeomorph
+  exact (localHomeomorph_prod_id (B := B) h).comp P.realTrivialization.isLocalHomeomorph
+
+private theorem HolomorphicPeriodMap.quotientMap_surjective {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B) :
+    Function.Surjective P.quotientMap := by
+  rintro ⟨b, z⟩
+  obtain ⟨v, hv⟩ := standardLattice.mkQ_surjective z
+  refine ⟨(b, P.periodEquiv b v), ?_⟩
+  simpa [quotientMap] using congrArg (Prod.mk b) hv
+
+private theorem HolomorphicPeriodMap.periodEquiv_coordinates {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B)
+    (b : B) (v : RealPlane₄) :
+    P.periodEquiv b v =
+      ![6 * (P.point b).val.μ * (v 0) + (P.point b).val.τ * (v 1) + (v 2),
+        (P.point b).val.β * (v 0) + (P.point b).val.μ * (v 1) + (v 3)] := by
+  rw [periodEquiv_apply]
+  ext i : 1
+  fin_cases i <;> apply Complex.ext <;>
+    simp [complexCoordinates, PeriodPoint.realMatrix, dotProduct, Fin.sum_univ_four,
+      Complex.mul_re, Complex.mul_im]
+
+private theorem
+    HolomorphicPeriodMap.holomorphic_periodEquiv_const {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B)
+    (v : RealPlane₄) :
+    ContMDiff (modelWithCornersSelf ℂ V) (modelWithCornersSelf ℂ ComplexPlane₂) ω
+      (fun b => P.periodEquiv b v) := by
+  simp_rw [periodEquiv_coordinates]
+  apply contMDiff_pi_space.mpr
+  intro i
+  fin_cases i
+  · exact
+      (((contMDiff_const.mul P.holomorphic_mu).mul contMDiff_const).add
+            (P.holomorphic_tau.mul contMDiff_const)).add
+        contMDiff_const
+  · exact
+      ((P.holomorphic_beta.mul contMDiff_const).add (P.holomorphic_mu.mul contMDiff_const)).add
+        contMDiff_const
+
+private theorem HolomorphicPeriodMap.periodEquiv_map_lattice {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B)
+    (b : B) :
+    standardLattice.map ((P.periodEquiv b).restrictScalars ℤ).toLinearMap = (P.point b).lattice :=
+  by
+  rw [standardLattice, Submodule.map_span, PeriodDomain.lattice_eq_span_basis]
+  congr 1
+  rw [← Set.range_comp]
+  congr 1
+
+@[instance_reducible]
+private def
+    HolomorphicPeriodMap.coveringAction {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B) :
+    MulAction (Multiplicative standardLattice) (B × ComplexPlane₂)
+    where
+  smul g x := (x.1, x.2 + P.periodEquiv x.1 (g.toAdd : RealPlane₄))
+  one_smul
+    x := by
+    change
+      (x.1, x.2 + P.periodEquiv x.1 ((1 : Multiplicative standardLattice).toAdd : RealPlane₄)) = x
+    simp
+  mul_smul g h
+    x := by
+    change
+      (x.1, x.2 + P.periodEquiv x.1 ((g * h).toAdd : RealPlane₄)) =
+        (x.1,
+          (x.2 + P.periodEquiv x.1 (h.toAdd : RealPlane₄)) +
+            P.periodEquiv x.1 (g.toAdd : RealPlane₄))
+    simp [map_add, add_left_comm, add_comm]
+
+private theorem HolomorphicPeriodMap.realTrivialization_smul {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B)
+    (g : Multiplicative standardLattice) (x : B × ComplexPlane₂) :
+    letI := P.coveringAction
+    P.realTrivialization (g • x) = (x.1, (P.periodEquiv x.1).symm x.2 + (g.toAdd : RealPlane₄)) :=
+  by
+  let := P.coveringAction
+  change (x.1, (P.periodEquiv x.1).symm (x.2 + P.periodEquiv x.1 (g.toAdd : RealPlane₄))) = _
+  simp only [map_add, LinearEquiv.symm_apply_apply]
+
+private theorem HolomorphicPeriodMap.coveringAction_continuous {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B) :
+    letI := P.coveringAction
+    ContinuousConstSMul (Multiplicative standardLattice) (B × ComplexPlane₂) := by
+  let := P.coveringAction
+  constructor
+  intro g
+  change
+    Continuous
+      (fun x : B × ComplexPlane₂ => (x.1, x.2 + P.periodEquiv x.1 (g.toAdd : RealPlane₄)))
+  exact
+    continuous_fst.prodMk
+      (continuous_snd.add
+        ((P.holomorphic_periodEquiv_const (g.toAdd : RealPlane₄)).continuous.comp continuous_fst))
+
+private theorem HolomorphicPeriodMap.coveringAction_free {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B) :
+    letI := P.coveringAction
+    IsCancelSMul (Multiplicative standardLattice) (B × ComplexPlane₂) := by
+  let := P.coveringAction
+  constructor
+  intro g h x he
+  have he' := congrArg (fun y => (P.realTrivialization y).2) he
+  rw [P.realTrivialization_smul, P.realTrivialization_smul] at he'
+  apply Multiplicative.toAdd.injective
+  apply Subtype.ext
+  exact add_left_cancel he'
+
+private theorem HolomorphicPeriodMap.quotientMap_smul {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B)
+    (g : Multiplicative standardLattice) (x : B × ComplexPlane₂) :
+    letI := P.coveringAction
+    P.quotientMap (g • x) = P.quotientMap x := by
+  let := P.coveringAction
+  have hg : standardLattice.mkQ (g.toAdd : RealPlane₄) = 0 :=
+    (Submodule.Quotient.mk_eq_zero standardLattice).mpr g.toAdd.property
+  change
+    (x.1,
+        standardLattice.mkQ
+          ((P.periodEquiv x.1).symm (x.2 + P.periodEquiv x.1 (g.toAdd : RealPlane₄)))) =
+      _
+  simp only [map_add, LinearEquiv.symm_apply_apply, hg, add_zero]
+  rfl
+
+private theorem HolomorphicPeriodMap.quotientMap_orbit {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B) :
+    letI := P.coveringAction
+    ∀ x y : B × ComplexPlane₂,
+      P.quotientMap x = P.quotientMap y ↔
+        x ∈ MulAction.orbit (Multiplicative standardLattice) y := by
+  let := P.coveringAction
+  rintro ⟨b, z⟩ ⟨b', w⟩
+  constructor
+  · intro h
+    have hb : b = b' := congrArg Prod.fst h
+    subst b'
+    have hv : (P.periodEquiv b).symm z - (P.periodEquiv b).symm w ∈ standardLattice :=
+      (Submodule.Quotient.eq standardLattice).mp (congrArg Prod.snd h)
+    refine ⟨Multiplicative.ofAdd ⟨_, hv⟩, ?_⟩
+    change (b, w + P.periodEquiv b ((P.periodEquiv b).symm z - (P.periodEquiv b).symm w)) = (b, z)
+    simp only [map_sub, LinearEquiv.apply_symm_apply]
+    congr 1
+    abel
+  · rintro ⟨g, hg⟩
+    rw [← hg]
+    exact P.quotientMap_smul g (b', w)
+
+private theorem HolomorphicPeriodMap.quotientCoveringMap {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B) :
+    letI := P.coveringAction
+    IsQuotientCoveringMap P.quotientMap (Multiplicative standardLattice) := by
+  let := P.coveringAction
+  have := P.coveringAction_continuous
+  have := P.coveringAction_free
+  exact
+    quotientCoveringMap_of_localHomeomorph P.quotientMap_localHomeomorph P.quotientMap_surjective
+      P.quotientMap_orbit
+
+/-- The product charted-space structure used on the period-map cover. -/
+@[instance_reducible]
+public
+def HolomorphicPeriodMap.coveringChartedSpace {V B : Type*} [NormedAddCommGroup V]
+    [TopologicalSpace B] [ChartedSpace V B] :
+    ChartedSpace (V × ComplexPlane₂) (B × ComplexPlane₂) :=
+  inferInstanceAs (ChartedSpace (ModelProd V ComplexPlane₂) (B × ComplexPlane₂))
+
+attribute [local instance] HolomorphicPeriodMap.coveringChartedSpace in
+public
+theorem HolomorphicPeriodMap.coveringManifold {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [IsManifold (modelWithCornersSelf ℂ V) ω B] :
+    IsManifold (modelWithCornersSelf ℂ (V × ComplexPlane₂)) ω (B × ComplexPlane₂) := by
+  rw [modelWithCornersSelf_prod]
+  exact
+    IsManifold.prod (I := modelWithCornersSelf ℂ V) (I' := modelWithCornersSelf ℂ ComplexPlane₂) B
+      ComplexPlane₂
+
+attribute [local instance] HolomorphicPeriodMap.coveringChartedSpace
+    HolomorphicPeriodMap.coveringManifold in
+private theorem HolomorphicPeriodMap.coveringAction_holomorphic {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B)
+    (g : Multiplicative standardLattice) :
+    letI := P.coveringAction
+    ContMDiff (modelWithCornersSelf ℂ (V × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (V × ComplexPlane₂)) ω (fun x : B × ComplexPlane₂ => g • x) := by
+  let := P.coveringAction
+  rw [modelWithCornersSelf_prod]
+  change
+    ContMDiff _ _ ω
+      (fun x : B × ComplexPlane₂ => (x.1, x.2 + P.periodEquiv x.1 (g.toAdd : RealPlane₄)))
+  exact
+    contMDiff_fst.prodMk
+      (contMDiff_snd.add
+        ((P.holomorphic_periodEquiv_const (g.toAdd : RealPlane₄)).comp contMDiff_fst))
+
+attribute [local instance] HolomorphicPeriodMap.coveringChartedSpace
+    HolomorphicPeriodMap.coveringManifold in
+@[instance_reducible]
+private def
+    HolomorphicPeriodMap.totalChartedSpace {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B) :
+    ChartedSpace (V × ComplexPlane₂) P.TotalSpace := by
+  let := P.coveringAction
+  exact CoveringQuotient.chartedSpace (E := V × ComplexPlane₂) P.quotientCoveringMap
+
+attribute [local instance] HolomorphicPeriodMap.coveringChartedSpace
+    HolomorphicPeriodMap.coveringManifold in
+private theorem HolomorphicPeriodMap.totalSpace_isManifold {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B)
+    [IsManifold (modelWithCornersSelf ℂ V) ω B] :
+    letI := P.totalChartedSpace
+    IsManifold (modelWithCornersSelf ℂ (V × ComplexPlane₂)) ω P.TotalSpace := by
+  let := P.coveringAction
+  have : IsManifold (modelWithCornersSelf ℂ (V × ComplexPlane₂)) ω (B × ComplexPlane₂) := by
+    infer_instance
+  exact
+    CoveringQuotient.isManifold (E := V × ComplexPlane₂) P.quotientCoveringMap ω
+      P.coveringAction_holomorphic
+
+attribute [local instance] HolomorphicPeriodMap.coveringChartedSpace
+    HolomorphicPeriodMap.coveringManifold in
+private theorem HolomorphicPeriodMap.quotientMap_holomorphic {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B)
+    [IsManifold (modelWithCornersSelf ℂ V) ω B] :
+    letI := P.totalChartedSpace
+    ContMDiff (modelWithCornersSelf ℂ (V × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (V × ComplexPlane₂)) ω P.quotientMap := by
+  let := P.coveringAction
+  have : IsManifold (modelWithCornersSelf ℂ (V × ComplexPlane₂)) ω (B × ComplexPlane₂) := by
+    infer_instance
+  exact
+    CoveringQuotient.contMDiff_project (E := V × ComplexPlane₂) P.quotientCoveringMap ω
+      P.coveringAction_holomorphic
+
+attribute [local instance] HolomorphicPeriodMap.coveringChartedSpace
+    HolomorphicPeriodMap.coveringManifold in
+private def HolomorphicPeriodMap.projection {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B) : P.TotalSpace → B :=
+  Prod.fst
+
+attribute [local instance] HolomorphicPeriodMap.coveringChartedSpace
+    HolomorphicPeriodMap.coveringManifold in
+private theorem HolomorphicPeriodMap.projection_surjective {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B) :
+    Function.Surjective P.projection := fun b => ⟨(b, 0), rfl⟩
+
+attribute [local instance] HolomorphicPeriodMap.coveringChartedSpace
+    HolomorphicPeriodMap.coveringManifold in
+private theorem HolomorphicPeriodMap.projection_proper {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B) :
+    IsProperMap P.projection :=
+  isProperMap_fst_of_compactSpace
+
+attribute [local instance] HolomorphicPeriodMap.coveringChartedSpace
+    HolomorphicPeriodMap.coveringManifold in
+private def
+    HolomorphicPeriodMap.torusHomeomorph {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B) (b : B) :
+    RealTorus₄ ≃ₜ (P.point b).Torus
+    where
+  toEquiv :=
+    (Submodule.Quotient.equiv standardLattice (P.point b).lattice
+        ((P.periodEquiv b).restrictScalars ℤ) (P.periodEquiv_map_lattice b)).toEquiv
+  continuous_toFun := by
+    apply standardLattice.isQuotientMap_mkQ.continuous_iff.mpr
+    exact
+      (P.point b).lattice.continuous_mkQ.comp (P.periodEquiv b).toContinuousLinearEquiv.continuous
+  continuous_invFun := by
+    apply (P.point b).lattice.isQuotientMap_mkQ.continuous_iff.mpr
+    exact
+      standardLattice.continuous_mkQ.comp
+        (P.periodEquiv b).symm.toContinuousLinearEquiv.continuous
+
+attribute [local instance] HolomorphicPeriodMap.coveringChartedSpace
+    HolomorphicPeriodMap.coveringManifold in
+private def
+    HolomorphicPeriodMap.fibreInclusion {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B) (b : B) :
+    (P.point b).Torus → P.TotalSpace := fun z => (b, (P.torusHomeomorph b).symm z)
+
+attribute [local instance] HolomorphicPeriodMap.coveringChartedSpace
+    HolomorphicPeriodMap.coveringManifold in
+private theorem HolomorphicPeriodMap.fibreInclusion_injective {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B)
+    (b : B) : Function.Injective (P.fibreInclusion b) := by
+  intro x y h
+  exact (P.torusHomeomorph b).symm.injective (congrArg Prod.snd h)
+
+attribute [local instance] HolomorphicPeriodMap.coveringChartedSpace
+    HolomorphicPeriodMap.coveringManifold in
+private theorem HolomorphicPeriodMap.fibreInclusion_mkQ {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B)
+    (b : B) (z : ComplexPlane₂) :
+    P.fibreInclusion b ((P.point b).lattice.mkQ z) = P.quotientMap (b, z) :=
+  rfl
+
+attribute [local instance] HolomorphicPeriodMap.coveringChartedSpace
+    HolomorphicPeriodMap.coveringManifold in
+private theorem HolomorphicPeriodMap.range_fibreInclusion {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B)
+    (b : B) : Set.range (P.fibreInclusion b) = P.projection ⁻¹' { b } := by
+  ext z
+  constructor
+  · rintro ⟨w, rfl⟩
+    rfl
+  · intro hz
+    have hb : z.1 = b := hz
+    refine ⟨P.torusHomeomorph b z.2, ?_⟩
+    simp only [fibreInclusion, Homeomorph.symm_apply_apply, ← hb, Prod.mk.eta]
+
+attribute [local instance] HolomorphicPeriodMap.coveringChartedSpace
+    HolomorphicPeriodMap.coveringManifold in
+private theorem HolomorphicPeriodMap.fibreInclusion_holomorphic {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B)
+    [IsManifold (modelWithCornersSelf ℂ V) ω B] (b : B) :
+    letI := P.totalChartedSpace
+    ContMDiff (modelWithCornersSelf ℂ ComplexPlane₂) (modelWithCornersSelf ℂ (V × ComplexPlane₂))
+      ω (P.fibreInclusion b) := by
+  let := P.totalChartedSpace
+  apply DiscreteQuotient.contMDiff_of_comp_mkQ (P.point b).lattice
+  have h :
+    ContMDiff (modelWithCornersSelf ℂ ComplexPlane₂) (modelWithCornersSelf ℂ (V × ComplexPlane₂))
+      ω (fun z : ComplexPlane₂ => (b, z)) := by
+    rw [modelWithCornersSelf_prod]
+    exact contMDiff_const.prodMk contMDiff_id
+  exact P.quotientMap_holomorphic.comp h
+
+attribute [local instance] HolomorphicPeriodMap.coveringChartedSpace
+    HolomorphicPeriodMap.coveringManifold in
+private def HolomorphicPeriodMap.zeroSection {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B) : B → P.TotalSpace :=
+  fun b => (b, 0)
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/PeriodFamily/HolomorphicPeriodMap2.lean b/LeanPool/HopfProblem/PeriodFamily/HolomorphicPeriodMap2.lean
new file mode 100644
index 000000000..78f9d7daf
--- /dev/null
+++ b/LeanPool/HopfProblem/PeriodFamily/HolomorphicPeriodMap2.lean
@@ -0,0 +1,127 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.HomologyOfX.ThreefoldGluing2
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap1
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldGluing2
+
+/-!
+# Hopf problem: period family · holomorphic period map 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+/-- The charted-space structure on the pullback of the period cover. -/
+@[instance_reducible]
+public
+def HolomorphicPeriodMap.periodPullbackCoveringChartedSpace {V B : Type*} [NormedAddCommGroup V]
+    [TopologicalSpace B] [ChartedSpace V B] :
+    ChartedSpace (V × ComplexPlane₂) (B × ComplexPlane₂) :=
+  inferInstanceAs (ChartedSpace (ModelProd V ComplexPlane₂) (B × ComplexPlane₂))
+
+attribute [local instance] HolomorphicPeriodMap.periodPullbackCoveringChartedSpace in
+public
+theorem
+    HolomorphicPeriodMap.periodPullbackCoveringManifold {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [IsManifold (modelWithCornersSelf ℂ V) ω B] :
+    IsManifold (modelWithCornersSelf ℂ (V × ComplexPlane₂)) ω (B × ComplexPlane₂) := by
+  rw [modelWithCornersSelf_prod]
+  exact
+    IsManifold.prod (I := modelWithCornersSelf ℂ V) (I' := modelWithCornersSelf ℂ ComplexPlane₂) B
+      ComplexPlane₂
+
+attribute [local instance] HolomorphicPeriodMap.periodPullbackCoveringChartedSpace
+    HolomorphicPeriodMap.periodPullbackCoveringManifold in
+private theorem
+    HolomorphicPeriodMap.quotientMap_isLocalDiffeomorph {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [IsManifold (modelWithCornersSelf ℂ V) ω B] (P : HolomorphicPeriodMap V B) :
+    letI := P.totalChartedSpace
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ (V × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (V × ComplexPlane₂)) ω P.quotientMap := by
+  let := P.coveringAction
+  let := P.totalChartedSpace
+  exact
+    CoveringQuotient.project_isLocalDiffeomorph P.quotientCoveringMap P.coveringAction_holomorphic
+
+attribute [local instance] HolomorphicPeriodMap.periodPullbackCoveringChartedSpace
+    HolomorphicPeriodMap.periodPullbackCoveringManifold in
+private def
+    HolomorphicPeriodMap.periodPullbackMap {B C : Type*} [TopologicalSpace B] [ChartedSpace ℂ B]
+    [TopologicalSpace C] [ChartedSpace ℂ C] (P : HolomorphicPeriodMap ℂ B)
+    (Q : HolomorphicPeriodMap ℂ C) (f : B → C) : P.TotalSpace → Q.TotalSpace := fun x =>
+  (f x.1, x.2)
+
+attribute [local instance] HolomorphicPeriodMap.periodPullbackCoveringChartedSpace
+    HolomorphicPeriodMap.periodPullbackCoveringManifold in
+private def HolomorphicPeriodMap.periodPullbackVectorMap {B C : Type*} (f : B → C) :
+    (B × ComplexPlane₂) → (C × ComplexPlane₂) := fun x => (f x.1, x.2)
+
+attribute [local instance] HolomorphicPeriodMap.periodPullbackCoveringChartedSpace
+    HolomorphicPeriodMap.periodPullbackCoveringManifold in
+private theorem HolomorphicPeriodMap.periodEquiv_pullback_eq {B C : Type*} [TopologicalSpace B]
+    [ChartedSpace ℂ B] [TopologicalSpace C] [ChartedSpace ℂ C] (P : HolomorphicPeriodMap ℂ B)
+    (Q : HolomorphicPeriodMap ℂ C) (f : B → C) (hpoint : ∀ b, Q.point (f b) = P.point b) (b : B) :
+    Q.periodEquiv (f b) = P.periodEquiv b := by simp only [periodEquiv, hpoint b]
+
+attribute [local instance] HolomorphicPeriodMap.periodPullbackCoveringChartedSpace
+    HolomorphicPeriodMap.periodPullbackCoveringManifold in
+private theorem
+    HolomorphicPeriodMap.periodPullbackMap_quotientMap {B C : Type*} [TopologicalSpace B]
+    [ChartedSpace ℂ B] [TopologicalSpace C] [ChartedSpace ℂ C] (P : HolomorphicPeriodMap ℂ B)
+    (Q : HolomorphicPeriodMap ℂ C) (f : B → C) (hpoint : ∀ b, Q.point (f b) = P.point b)
+    (x : B × ComplexPlane₂) :
+    periodPullbackMap P Q f (P.quotientMap x) = Q.quotientMap (periodPullbackVectorMap f x) := by
+  change
+    (f x.1, standardLattice.mkQ ((P.periodEquiv x.1).symm x.2)) =
+      (f x.1, standardLattice.mkQ ((Q.periodEquiv (f x.1)).symm x.2))
+  rw [periodEquiv_pullback_eq P Q f hpoint]
+
+attribute [local instance] HolomorphicPeriodMap.periodPullbackCoveringChartedSpace
+    HolomorphicPeriodMap.periodPullbackCoveringManifold in
+private theorem HolomorphicPeriodMap.periodPullbackMap_isLocalDiffeomorph {B C : Type*}
+    [TopologicalSpace B] [ChartedSpace ℂ B] [TopologicalSpace C] [ChartedSpace ℂ C]
+    (P : HolomorphicPeriodMap ℂ B) (Q : HolomorphicPeriodMap ℂ C) (f : B → C)
+    [IsManifold 𝓘(ℂ) ω B] [IsManifold 𝓘(ℂ) ω C] (hpoint : ∀ b, Q.point (f b) = P.point b)
+    (hf : IsLocalDiffeomorph 𝓘(ℂ) 𝓘(ℂ) ω f) :
+    letI := P.totalChartedSpace
+    letI := Q.totalChartedSpace
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (periodPullbackMap P Q f) := by
+  let := P.totalChartedSpace
+  let := Q.totalChartedSpace
+  exact
+    SpecialPeriods.EllipticFilling.periodFamilyMap_isLocalDiffeomorph P Q f
+      (fun b => (hpoint b).symm) hf
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/PeriodFamily/PeriodDomain.lean b/LeanPool/HopfProblem/PeriodFamily/PeriodDomain.lean
new file mode 100644
index 000000000..b0cc0fd8e
--- /dev/null
+++ b/LeanPool/HopfProblem/PeriodFamily/PeriodDomain.lean
@@ -0,0 +1,330 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+public import LeanPool.HopfProblem.Recognition.Smale2
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+import all LeanPool.HopfProblem.Recognition.Smale2
+
+/-!
+# Hopf problem: period family · period domain
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+/-- The type of four integral period vectors. -/
+public
+abbrev FullPeriodMatrix.IntegerPeriods :=
+  (Fin 2 → ℤ) × (Fin 2 → ℤ)
+
+/-- The integral period vector selected by an index. -/
+public
+def FullPeriodMatrix.periodVector (p : FullPeriodMatrix) : IntegerPeriods →+ ComplexPlane₂
+    where
+  toFun c := (fun i => (c.1 i : ℂ)) + p.matrix *ᵥ (fun i => (c.2 i : ℂ))
+  map_zero' := by ext i; fin_cases i <;> simp []
+  map_add' c
+    d := by
+    ext i
+    simp only [Prod.fst_add, Prod.snd_add, Pi.add_apply, Int.cast_add, Matrix.mulVec, dotProduct,
+      Fin.sum_univ_two]
+    ring
+
+private theorem FullPeriodMatrix.periodVector_eq_periodLinear (p : FullPeriodMatrix)
+    (c : IntegerPeriods) :
+    p.periodVector c = p.periodLinear ((fun i => (c.1 i : ℝ)), (fun i => (c.2 i : ℝ))) := by
+  ext i
+  fin_cases i <;> simp [periodVector, periodLinear, Matrix.vecHead, Matrix.vecTail]
+
+public
+theorem FullPeriodMatrix.periodVector_injective (p : FullPeriodMatrix) :
+    Function.Injective p.periodVector := by
+  intro c d h
+  rw [p.periodVector_eq_periodLinear, p.periodVector_eq_periodLinear] at h
+  have he := p.periodLinear_bijective.1 h
+  apply Prod.ext
+  · ext i
+    have hi : (c.1 i : ℝ) = (d.1 i : ℝ) := congrFun (congrArg Prod.fst he) i
+    exact_mod_cast hi
+  · ext i
+    have hi : (c.2 i : ℝ) = (d.2 i : ℝ) := congrFun (congrArg Prod.snd he) i
+    exact_mod_cast hi
+
+private theorem
+    FullPeriodMatrix.periodVector_mem_lattice (p : FullPeriodMatrix) (c : IntegerPeriods) :
+    p.periodVector c ∈ p.lattice :=
+  (p.mem_lattice_iff _).mpr ⟨c.1, c.2, rfl⟩
+
+private def
+    FullPeriodMatrix.periodLatticeMap (p : FullPeriodMatrix) : IntegerPeriods →+ p.lattice :=
+  p.periodVector.codRestrict p.lattice.toAddSubgroup p.periodVector_mem_lattice
+
+private theorem FullPeriodMatrix.periodLatticeMap_bijective (p : FullPeriodMatrix) :
+    Function.Bijective p.periodLatticeMap := by
+  constructor
+  · intro c d h
+    exact p.periodVector_injective (congrArg Subtype.val h)
+  · intro z
+    obtain ⟨m, n, hmn⟩ := (p.mem_lattice_iff z).mp z.property
+    exact ⟨(m, n), Subtype.ext hmn.symm⟩
+
+private def
+    FullPeriodMatrix.periodLatticeEquiv (p : FullPeriodMatrix) : IntegerPeriods ≃+ p.lattice :=
+  AddEquiv.ofBijective p.periodLatticeMap p.periodLatticeMap_bijective
+
+private def FullPeriodMatrix.latticeEquiv (p : FullPeriodMatrix) : p.lattice ≃+ IntegerPeriods :=
+  p.periodLatticeEquiv.symm
+
+private theorem FullPeriodMatrix.periodVector_latticeEquiv (p : FullPeriodMatrix) (z : p.lattice) :
+    p.periodVector (p.latticeEquiv z) = z :=
+  congrArg Subtype.val (p.periodLatticeEquiv.apply_symm_apply z)
+
+private theorem FullPeriodMatrix.quotientCovering (p : FullPeriodMatrix) :
+    IsAddQuotientCoveringMap p.lattice.mkQ p.lattice.toAddSubgroup := by
+  apply p.lattice.toAddSubgroup.isAddQuotientCoveringMap_of_comm
+  change IsDiscrete (p.lattice : Set ComplexPlane₂)
+  let : DiscreteTopology (p.lattice : Set ComplexPlane₂) := p.lattice_discrete
+  exact DiscreteTopology.isDiscrete
+
+private def
+    FullPeriodMatrix.zeroLift (p : FullPeriodMatrix) : p.lattice.mkQ ⁻¹' ({0} : Set p.Torus) :=
+  ⟨0, by simp⟩
+
+private def FullPeriodMatrix.fundamentalGroupEquiv (p : FullPeriodMatrix) :
+    FundamentalGroup p.Torus 0 ≃* Multiplicative IntegerPeriods :=
+  ((p.quotientCovering.fundamentalGroupEquiv p.zeroLift).trans MulOpposite.opMulEquiv.symm).trans
+    p.latticeEquiv.toMultiplicative
+
+private theorem FullPeriodMatrix.fundamentalGroupEquiv_monodromy (p : FullPeriodMatrix)
+    (γ : FundamentalGroup p.Torus 0) :
+    p.periodVector (p.fundamentalGroupEquiv γ).toAdd =
+      (p.quotientCovering.isCoveringMap.monodromy γ p.zeroLift : ComplexPlane₂) := by
+  have h := p.quotientCovering.unop_fundamentalGroupToMulOpposite_smul (e := p.zeroLift) (γ := γ)
+  change
+    p.periodVector
+        (p.latticeEquiv
+          (p.quotientCovering.fundamentalGroupToMulOpposite p.zeroLift γ).unop.toAdd) =
+      _
+  rw [p.periodVector_latticeEquiv]
+  change
+    ((p.quotientCovering.fundamentalGroupToMulOpposite p.zeroLift γ).unop.toAdd : ComplexPlane₂) +
+        0 =
+      _ at h
+  simpa only [add_zero] using h
+
+private theorem FullPeriodMatrix.mkQ_periodVector (p : FullPeriodMatrix) (c : IntegerPeriods) :
+    p.lattice.mkQ (p.periodVector c) = 0 :=
+  (Submodule.Quotient.mk_eq_zero p.lattice).mpr (p.periodVector_mem_lattice c)
+
+private def FullPeriodMatrix.periodLoop (p : FullPeriodMatrix) (c : IntegerPeriods) :
+    Path (0 : p.Torus) 0 :=
+  ((Path.segment (0 : ComplexPlane₂) (p.periodVector c)).map p.lattice.continuous_mkQ).cast
+    (map_zero p.lattice.mkQ).symm (p.mkQ_periodVector c).symm
+
+private theorem FullPeriodMatrix.periodLoop_apply (p : FullPeriodMatrix) (c : IntegerPeriods)
+    (t : unitInterval) : p.periodLoop c t = p.lattice.mkQ ((t : ℝ) • p.periodVector c) := by
+  simp only [periodLoop, Path.cast_coe, Path.map_coe, Function.comp_apply, Path.segment_apply,
+    AffineMap.lineMap_apply_module, smul_zero, zero_add]
+
+private theorem FullPeriodMatrix.periodLoop_monodromy (p : FullPeriodMatrix) (c : IntegerPeriods) :
+    p.quotientCovering.isCoveringMap.monodromy (FundamentalGroup.fromPath ⟦p.periodLoop c⟧)
+        p.zeroLift =
+      ⟨p.periodVector c, p.mkQ_periodVector c⟩ := by
+  apply
+    p.quotientCovering.isCoveringMap.monodromy_eq_of_map_eq
+      (Path.Homotopic.Quotient.mk (Path.segment (0 : ComplexPlane₂) (p.periodVector c)))
+  apply congrArg Path.Homotopic.Quotient.mk
+  ext t
+  rfl
+
+private theorem FullPeriodMatrix.fundamentalGroupEquiv_periodLoop (p : FullPeriodMatrix)
+    (c : IntegerPeriods) :
+    p.fundamentalGroupEquiv (FundamentalGroup.fromPath ⟦p.periodLoop c⟧) =
+      Multiplicative.ofAdd c := by
+  apply Multiplicative.toAdd.injective
+  apply p.periodVector_injective
+  rw [p.fundamentalGroupEquiv_monodromy, p.periodLoop_monodromy]
+  rfl
+
+private def PeriodDomain.periodVector (p : PeriodDomain) : Lattice →+ ComplexPlane₂
+    where
+  toFun c := p.val.matrix *ᵥ (fun i => (c i : ℂ))
+  map_zero' := by
+    simp only [Pi.zero_apply, Int.cast_zero]
+    exact Matrix.mulVec_zero _
+  map_add' c
+    d := by
+    simp only [Pi.add_apply, Int.cast_add]
+    exact Matrix.mulVec_add _ _ _
+
+@[simp]
+private theorem PeriodDomain.periodVector_apply (p : PeriodDomain) (c : Lattice) :
+    p.periodVector c = p.val.matrix *ᵥ (fun i => (c i : ℂ)) :=
+  rfl
+
+private theorem PeriodDomain.periodVector_eq_sum (p : PeriodDomain) (c : Lattice) :
+    p.periodVector c = ∑ i, c i • p.basis i := by
+  ext j
+  simp [periodVector, Matrix.mulVec, dotProduct, p.basis_apply, zsmul_eq_mul, mul_comm]
+
+private theorem PeriodDomain.periodVector_injective (p : PeriodDomain) :
+    Function.Injective p.periodVector := by
+  intro c d h
+  have hi : LinearIndependent ℤ p.basis := p.basis.linearIndependent.restrict_scalars' ℤ
+  apply funext
+  apply (Fintype.linearIndependent_iffₛ.mp hi) c d
+  rw [← p.periodVector_eq_sum, ← p.periodVector_eq_sum]
+  exact h
+
+private theorem PeriodDomain.mem_lattice_iff (p : PeriodDomain) (z : ComplexPlane₂) :
+    z ∈ p.lattice ↔ ∃ c : Lattice, p.periodVector c = z := by
+  rw [p.lattice_eq_span_basis, Submodule.mem_span_range_iff_exists_fun]
+  constructor
+  · rintro ⟨c, hc⟩
+    exact ⟨c, (p.periodVector_eq_sum c).trans hc⟩
+  · rintro ⟨c, hc⟩
+    exact ⟨c, (p.periodVector_eq_sum c).symm.trans hc⟩
+
+private theorem PeriodDomain.periodVector_mem_lattice (p : PeriodDomain) (c : Lattice) :
+    p.periodVector c ∈ p.lattice :=
+  (p.mem_lattice_iff _).mpr ⟨c, rfl⟩
+
+private def PeriodDomain.periodLatticeMap (p : PeriodDomain) : Lattice →+ p.lattice :=
+  p.periodVector.codRestrict p.lattice.toAddSubgroup p.periodVector_mem_lattice
+
+private theorem PeriodDomain.periodLatticeMap_bijective (p : PeriodDomain) :
+    Function.Bijective p.periodLatticeMap := by
+  constructor
+  · intro c d h
+    exact p.periodVector_injective (congrArg Subtype.val h)
+  · intro z
+    obtain ⟨c, hc⟩ := (p.mem_lattice_iff z).mp z.property
+    exact ⟨c, Subtype.ext hc⟩
+
+private def PeriodDomain.periodLatticeEquiv (p : PeriodDomain) : Lattice ≃+ p.lattice :=
+  AddEquiv.ofBijective p.periodLatticeMap p.periodLatticeMap_bijective
+
+private def PeriodDomain.latticeEquiv (p : PeriodDomain) : p.lattice ≃+ Lattice :=
+  p.periodLatticeEquiv.symm
+
+private theorem PeriodDomain.periodVector_latticeEquiv (p : PeriodDomain) (z : p.lattice) :
+    p.periodVector (p.latticeEquiv z) = z :=
+  congrArg Subtype.val (p.periodLatticeEquiv.apply_symm_apply z)
+
+private theorem PeriodDomain.quotientCovering (p : PeriodDomain) :
+    IsAddQuotientCoveringMap p.lattice.mkQ p.lattice.toAddSubgroup := by
+  apply p.lattice.toAddSubgroup.isAddQuotientCoveringMap_of_comm
+  change IsDiscrete (p.lattice : Set ComplexPlane₂)
+  let : DiscreteTopology (p.lattice : Set ComplexPlane₂) := p.lattice_discrete
+  exact DiscreteTopology.isDiscrete
+
+private def PeriodDomain.zeroLift (p : PeriodDomain) : p.lattice.mkQ ⁻¹' ({0} : Set p.Torus) :=
+  ⟨0, by simp⟩
+
+private def PeriodDomain.fundamentalGroupEquiv (p : PeriodDomain) :
+    FundamentalGroup p.Torus 0 ≃* Multiplicative Lattice :=
+  ((p.quotientCovering.fundamentalGroupEquiv p.zeroLift).trans MulOpposite.opMulEquiv.symm).trans
+    p.latticeEquiv.toMultiplicative
+
+private theorem PeriodDomain.fundamentalGroupEquiv_monodromy (p : PeriodDomain)
+    (g : FundamentalGroup p.Torus 0) :
+    p.periodVector (p.fundamentalGroupEquiv g).toAdd =
+      (p.quotientCovering.isCoveringMap.monodromy g p.zeroLift : ComplexPlane₂) := by
+  have h := p.quotientCovering.unop_fundamentalGroupToMulOpposite_smul (e := p.zeroLift) (γ := g)
+  change
+    p.periodVector
+        (p.latticeEquiv
+          (p.quotientCovering.fundamentalGroupToMulOpposite p.zeroLift g).unop.toAdd) =
+      _
+  rw [p.periodVector_latticeEquiv]
+  change
+    ((p.quotientCovering.fundamentalGroupToMulOpposite p.zeroLift g).unop.toAdd : ComplexPlane₂) +
+        0 =
+      _ at h
+  simpa only [add_zero] using h
+
+private theorem PeriodDomain.mkQ_periodVector (p : PeriodDomain) (c : Lattice) :
+    p.lattice.mkQ (p.periodVector c) = 0 :=
+  (Submodule.Quotient.mk_eq_zero p.lattice).mpr (p.periodVector_mem_lattice c)
+
+private def PeriodDomain.periodLoop (p : PeriodDomain) (c : Lattice) : Path (0 : p.Torus) 0 :=
+  ((Path.segment (0 : ComplexPlane₂) (p.periodVector c)).map p.lattice.continuous_mkQ).cast
+    (map_zero p.lattice.mkQ).symm (p.mkQ_periodVector c).symm
+
+private theorem PeriodDomain.periodLoop_apply (p : PeriodDomain) (c : Lattice) (t : unitInterval) :
+    p.periodLoop c t = p.lattice.mkQ ((t : ℝ) • p.periodVector c) := by
+  simp only [periodLoop, Path.cast_coe, Path.map_coe, Function.comp_apply, Path.segment_apply,
+    AffineMap.lineMap_apply_module, smul_zero, zero_add]
+
+private theorem PeriodDomain.periodLoop_monodromy (p : PeriodDomain) (c : Lattice) :
+    p.quotientCovering.isCoveringMap.monodromy (FirstHurewicz.loopQuotient (p.periodLoop c))
+        p.zeroLift =
+      ⟨p.periodVector c, p.mkQ_periodVector c⟩ := by
+  apply
+    p.quotientCovering.isCoveringMap.monodromy_eq_of_map_eq
+      (Path.Homotopic.Quotient.mk (Path.segment (0 : ComplexPlane₂) (p.periodVector c)))
+  apply congrArg Path.Homotopic.Quotient.mk
+  ext t
+  rfl
+
+@[simp]
+private theorem PeriodDomain.fundamentalGroupEquiv_periodLoop (p : PeriodDomain) (c : Lattice) :
+    p.fundamentalGroupEquiv (FirstHurewicz.loopQuotient (p.periodLoop c)) =
+      Multiplicative.ofAdd c := by
+  apply Multiplicative.toAdd.injective
+  apply p.periodVector_injective
+  rw [p.fundamentalGroupEquiv_monodromy, p.periodLoop_monodromy]
+  rfl
+
+private def PeriodDomain.singularH1Equiv (p : PeriodDomain) :
+    FirstHurewicz.SingularH1 p.Torus ≃ₗ[ℤ] Lattice :=
+  FirstHurewicz.singularH1EquivOfPi1 (0 : p.Torus) p.fundamentalGroupEquiv
+
+@[simp]
+private theorem PeriodDomain.singularH1Equiv_loopHomologyClass (p : PeriodDomain)
+    (q : Path (0 : p.Torus) 0) :
+    p.singularH1Equiv (FirstHurewicz.loopHomologyClass q) =
+      (p.fundamentalGroupEquiv (FirstHurewicz.loopQuotient q)).toAdd :=
+  FirstHurewicz.singularH1EquivOfPi1_loopHomologyClass (0 : p.Torus) p.fundamentalGroupEquiv q
+
+private theorem PeriodDomain.singularH1Equiv_periodLoop (p : PeriodDomain) (c : Lattice) :
+    p.singularH1Equiv (FirstHurewicz.loopHomologyClass (p.periodLoop c)) = c := by
+  rw [p.singularH1Equiv_loopHomologyClass, p.fundamentalGroupEquiv_periodLoop]
+  rfl
+
+@[simp]
+private theorem PeriodDomain.singularH1Equiv_symm_apply (p : PeriodDomain) (c : Lattice) :
+    p.singularH1Equiv.symm c = FirstHurewicz.loopHomologyClass (p.periodLoop c) := by
+  apply p.singularH1Equiv.injective
+  rw [LinearEquiv.apply_symm_apply, p.singularH1Equiv_periodLoop]
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/PeriodFamily/PeriodPoint.lean b/LeanPool/HopfProblem/PeriodFamily/PeriodPoint.lean
new file mode 100644
index 000000000..b41295dc2
--- /dev/null
+++ b/LeanPool/HopfProblem/PeriodFamily/PeriodPoint.lean
@@ -0,0 +1,555 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+
+/-!
+# Hopf problem: period family · period point
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+@[ext]
+private structure PeriodPoint where
+  τ : ℂ
+  μ : ℂ
+  β : ℂ
+
+private def PeriodPoint.discriminant (p : PeriodPoint) : ℝ :=
+  p.β.im - 6 * p.μ.im ^ 2 / p.τ.im
+
+private def PeriodPoint.Admissible (p : PeriodPoint) : Prop :=
+  0 < p.τ.im ∧ p.discriminant < 0
+
+private def PeriodPoint.matrix (p : PeriodPoint) : Matrix (Fin 2) (Fin 4) ℂ :=
+  !![6 * p.μ, p.τ, 1, 0; p.β, p.μ, 0, 1]
+
+private def PeriodPoint.realMatrix (p : PeriodPoint) : Matrix (Fin 4) (Fin 4) ℝ :=
+  !![6 * p.μ.re, p.τ.re, 1, 0;
+    6 * p.μ.im, p.τ.im, 0, 0;
+    p.β.re, p.μ.re, 0, 1;
+    p.β.im, p.μ.im, 0, 0]
+
+private def PeriodPoint.step₁ (p : PeriodPoint) : PeriodPoint :=
+  ⟨(p.τ - 1) / p.τ, (1 - p.μ) / p.τ, p.β + 2 - 6 * (1 - p.μ) ^ 2 / p.τ⟩
+
+private def PeriodPoint.step₂ (p : PeriodPoint) : PeriodPoint :=
+  ⟨-1 / p.τ, 1 + p.μ / p.τ, p.β - 3 - 6 * p.μ ^ 2 / p.τ⟩
+
+private def PeriodPoint.R₁ (p : PeriodPoint) : Matrix (Fin 2) (Fin 2) ℂ :=
+  !![-1 / p.τ, 0; (1 - p.μ) / p.τ, 1]
+
+private def PeriodPoint.R₂ (p : PeriodPoint) : Matrix (Fin 2) (Fin 2) ℂ :=
+  !![1 / p.τ, 0; -p.μ / p.τ, 1]
+
+private theorem PeriodPoint.τ_ne_zero (p : PeriodPoint) (h : 0 < p.τ.im) : p.τ ≠ 0 := by
+  intro heq
+  simp [heq] at h
+
+private theorem PeriodPoint.det_realMatrix (p : PeriodPoint) :
+    p.realMatrix.det = p.τ.im * p.β.im - 6 * p.μ.im ^ 2 := by
+  have hminor :
+    p.realMatrix.submatrix (Fin.succAbove (0 : Fin 4)) (Fin.succAbove (2 : Fin 4)) =
+      !![6 * p.μ.im, p.τ.im, 0; p.β.re, p.μ.re, 1; p.β.im, p.μ.im, 0] := by
+    ext i j
+    fin_cases i <;> fin_cases j <;> rfl
+  rw [Matrix.det_succ_column _ 2, Fin.sum_univ_four, hminor]
+  norm_num [realMatrix, Matrix.det_fin_three, Matrix.cons_val_two, Matrix.cons_val_three]
+  ring
+
+private theorem PeriodPoint.det_realMatrix_eq_discriminant (p : PeriodPoint) (h : p.τ.im ≠ 0) :
+    p.realMatrix.det = p.τ.im * p.discriminant := by
+  rw [det_realMatrix]
+  unfold discriminant
+  field_simp
+
+private theorem PeriodPoint.det_realMatrix_neg (p : PeriodPoint) (h : p.Admissible) :
+    p.realMatrix.det < 0 := by
+  rw [det_realMatrix_eq_discriminant p (ne_of_gt h.1)]
+  exact mul_neg_of_pos_of_neg h.1 h.2
+
+private theorem PeriodPoint.det_R₁ (p : PeriodPoint) : p.R₁.det = -1 / p.τ := by
+  simp [R₁, Matrix.det_fin_two]
+
+private theorem PeriodPoint.det_R₂ (p : PeriodPoint) : p.R₂.det = 1 / p.τ := by
+  simp [R₂, Matrix.det_fin_two]
+
+private theorem PeriodPoint.step₁_matrix (p : PeriodPoint) (h : p.τ ≠ 0) :
+    p.step₁.matrix = p.R₁ * p.matrix * (T₁.map (Int.castRingHom ℂ)).transpose := by
+  ext i j
+  fin_cases i <;> fin_cases j <;>
+        simp [step₁, PeriodPoint.matrix, R₁, T₁, Matrix.mul_apply, Fin.sum_univ_succ] <;>
+      field_simp <;>
+    ring
+
+private theorem PeriodPoint.step₂_matrix (p : PeriodPoint) (h : p.τ ≠ 0) :
+    p.step₂.matrix = p.R₂ * p.matrix * (T₂.map (Int.castRingHom ℂ)).transpose := by
+  ext i j
+  fin_cases i <;> fin_cases j <;>
+        simp [step₂, PeriodPoint.matrix, R₂, T₂, Matrix.mul_apply, Fin.sum_univ_succ] <;>
+      field_simp <;>
+    ring
+
+private theorem PeriodPoint.step₂_discriminant (p : PeriodPoint) (h : p.τ.im ≠ 0) :
+    p.step₂.discriminant = p.discriminant := by
+  have hτ : p.τ ≠ 0 := by
+    intro heq
+    exact h (by simp [heq])
+  have hn : Complex.normSq p.τ ≠ 0 := mt Complex.normSq_eq_zero.mp hτ
+  simp [step₂, discriminant, Complex.div_im, Complex.mul_im, Complex.mul_re, pow_two]
+  field_simp
+  simp [Complex.normSq_apply]
+  ring
+
+private theorem PeriodPoint.step₁_discriminant (p : PeriodPoint) (h : p.τ.im ≠ 0) :
+    p.step₁.discriminant = p.discriminant := by
+  have hτ : p.τ ≠ 0 := by
+    intro heq
+    exact h (by simp [heq])
+  have hs := step₂_discriminant ⟨p.τ, 1 - p.μ, p.β⟩ h
+  simpa [step₁, step₂, discriminant, sub_div, hτ, Complex.div_im, neg_div] using hs
+
+private theorem PeriodPoint.step₁_im (p : PeriodPoint) (h : p.τ ≠ 0) :
+    p.step₁.τ.im = p.τ.im / Complex.normSq p.τ := by simp [step₁, sub_div, h, neg_div]
+
+private theorem
+    PeriodPoint.step₂_im (p : PeriodPoint) : p.step₂.τ.im = p.τ.im / Complex.normSq p.τ := by
+  simp [step₂, neg_div]
+
+private theorem
+    PeriodPoint.step₁_admissible (p : PeriodPoint) (h : p.Admissible) : p.step₁.Admissible := by
+  refine ⟨?_, ?_⟩
+  · rw [step₁_im p (p.τ_ne_zero h.1)]
+    exact div_pos h.1 (Complex.normSq_pos.mpr (p.τ_ne_zero h.1))
+  · rw [step₁_discriminant p (ne_of_gt h.1)]
+    exact h.2
+
+private theorem
+    PeriodPoint.step₂_admissible (p : PeriodPoint) (h : p.Admissible) : p.step₂.Admissible := by
+  refine ⟨?_, ?_⟩
+  · rw [step₂_im]
+    exact div_pos h.1 (Complex.normSq_pos.mpr (p.τ_ne_zero h.1))
+  · rw [step₂_discriminant p (ne_of_gt h.1)]
+    exact h.2
+
+private theorem PeriodPoint.step₁_sq (p : PeriodPoint) (h₀ : p.τ ≠ 0) (h₁ : p.τ - 1 ≠ 0) :
+    p.step₁.step₁ =
+      ⟨-1 / (p.τ - 1), (p.τ - 1 + p.μ) / (p.τ - 1), p.β - 2 - 6 * p.μ ^ 2 / (p.τ - 1)⟩ := by
+  apply PeriodPoint.ext <;> simp [step₁] <;> field_simp <;> ring
+
+private theorem PeriodPoint.step₂_sq (p : PeriodPoint) (h : p.τ ≠ 0) :
+    p.step₂.step₂ = ⟨p.τ, 1 - p.τ - p.μ, p.β - 6 + 6 * p.τ + 12 * p.μ⟩ := by
+  apply PeriodPoint.ext <;> simp [step₂] <;> field_simp <;> ring
+
+private theorem PeriodPoint.step₁_cube (p : PeriodPoint) (h₀ : p.τ ≠ 0) (h₁ : p.τ - 1 ≠ 0) :
+    p.step₁.step₁.step₁ = p := by
+  rw [step₁_sq p h₀ h₁]
+  apply PeriodPoint.ext <;> simp [step₁] <;> field_simp <;> ring
+
+private theorem PeriodPoint.step₂_fourth (p : PeriodPoint) (h : p.τ ≠ 0) :
+    p.step₂.step₂.step₂.step₂ = p := by
+  rw [step₂_sq (p.step₂.step₂), step₂_sq p h]
+  · apply PeriodPoint.ext <;> simp
+    all_goals ring
+  · simpa [step₂] using h
+
+private theorem PeriodPoint.step₁_step₂ (p : PeriodPoint) (h : p.τ ≠ 0) :
+    p.step₂.step₁ = ⟨p.τ + 1, p.μ, p.β - 1⟩ := by
+  apply PeriodPoint.ext <;> simp [step₁, step₂] <;> field_simp <;> ring
+
+private abbrev PeriodDomain :=
+  { p : PeriodPoint // p.Admissible }
+
+private def PeriodDomain.realEquiv (p : PeriodDomain) : (Fin 4 → ℝ) ≃ₗ[ℝ] (Fin 4 → ℝ) :=
+  Matrix.toLinearEquiv (Pi.basisFun ℝ (Fin 4)) p.val.realMatrix
+    (isUnit_iff_ne_zero.mpr (ne_of_lt (p.val.det_realMatrix_neg p.property)))
+
+private theorem PeriodDomain.realEquiv_apply (p : PeriodDomain) (v : Fin 4 → ℝ) :
+    p.realEquiv v = p.val.realMatrix *ᵥ v := by
+  simp [realEquiv, Matrix.toLin_eq_toLin', Matrix.toLin'_apply]
+
+private def PeriodDomain.basis (p : PeriodDomain) : Module.Basis (Fin 4) ℝ ComplexPlane₂ :=
+  (Pi.basisFun ℝ (Fin 4)).map (p.realEquiv.trans complexCoordinates)
+
+private theorem PeriodDomain.basis_apply (p : PeriodDomain) (j : Fin 4) :
+    p.basis j = fun i => p.val.matrix i j := by
+  simp only [basis, Module.Basis.map_apply, LinearEquiv.trans_apply, realEquiv_apply,
+    Pi.basisFun_apply, Matrix.mulVec_single_one]
+  ext i : 1
+  fin_cases i <;> fin_cases j <;> apply Complex.ext <;>
+    simp [complexCoordinates, PeriodPoint.realMatrix, PeriodPoint.matrix]
+
+private def PeriodDomain.lattice (p : PeriodDomain) : Submodule ℤ ComplexPlane₂ :=
+  Submodule.span ℤ (Set.range (fun j i => p.val.matrix i j))
+
+private theorem PeriodDomain.lattice_eq_span_basis (p : PeriodDomain) :
+    p.lattice = Submodule.span ℤ (Set.range p.basis) := by
+  unfold lattice
+  congr 2
+  funext j
+  exact (p.basis_apply j).symm
+
+private instance PeriodDomain.lattice_discrete (p : PeriodDomain) : DiscreteTopology p.lattice := by
+  rw [lattice_eq_span_basis]
+  infer_instance
+
+private instance PeriodDomain.lattice_isZLattice (p : PeriodDomain) : IsZLattice ℝ p.lattice := by
+  constructor
+  rw [lattice_eq_span_basis]
+  exact ZSpan.span_top p.basis
+
+private instance PeriodDomain.lattice_addSubgroup_discrete (p : PeriodDomain) :
+    DiscreteTopology p.lattice.toAddSubgroup :=
+  inferInstanceAs (DiscreteTopology p.lattice)
+
+private instance PeriodDomain.lattice_isClosed (p : PeriodDomain) :
+    IsClosed (p.lattice : Set ComplexPlane₂) := by
+  change IsClosed (p.lattice.toAddSubgroup : Set ComplexPlane₂)
+  exact AddSubgroup.isClosed_of_discrete (H := p.lattice.toAddSubgroup)
+
+private abbrev PeriodDomain.Torus (p : PeriodDomain) :=
+  ComplexPlane₂ ⧸ p.lattice
+
+private instance PeriodDomain.torus_pathConnected (p : PeriodDomain) : PathConnectedSpace p.Torus :=
+  p.lattice.mkQ_surjective.pathConnectedSpace p.lattice.continuous_mkQ
+
+private instance PeriodDomain.torus_compact (p : PeriodDomain) : CompactSpace p.Torus := by
+  let f := p.lattice.mkQ
+  have hf : Continuous f := p.lattice.continuous_mkQ
+  have hper : ∀ z w, w ∈ p.lattice → f (z + w) = f z := by
+    intro z w hw
+    have hw' : f w = 0 := (Submodule.Quotient.mk_eq_zero p.lattice).mpr hw
+    rw [map_add, hw', add_zero]
+  have hc := IsZLattice.isCompact_range_of_periodic p.lattice f hf hper
+  have hs : Function.Surjective f := Submodule.Quotient.mk_surjective p.lattice
+  exact ⟨by simpa only [Set.range_eq_univ.mpr hs] using hc⟩
+
+/-- A full period matrix equipped with a nonvanishing determinant witness. -/
+public
+structure FullPeriodMatrix where
+  /-- The complex matrix underlying a full period matrix. -/
+  matrix : Matrix (Fin 2) (Fin 2) ℂ
+  nondegenerate : Function.Bijective (matrix.map Complex.im).mulVecLin
+
+private def
+    FullPeriodMatrix.imaginaryEquiv (p : FullPeriodMatrix) : (Fin 2 → ℝ) ≃ₗ[ℝ] (Fin 2 → ℝ) :=
+  LinearEquiv.ofBijective (p.matrix.map Complex.im).mulVecLin p.nondegenerate
+
+private def FullPeriodMatrix.periodLinear (p : FullPeriodMatrix) : RealPair₂ →ₗ[ℝ] ComplexPlane₂
+    where
+  toFun x := fun i => (x.1 i : ℂ) + (p.matrix *ᵥ fun j => (x.2 j : ℂ)) i
+  map_add' x
+    y := by
+    ext i
+    simp only [Prod.fst_add, Prod.snd_add, Pi.add_apply, Complex.ofReal_add, Matrix.mulVec,
+      dotProduct, Fin.sum_univ_two]
+    ring
+  map_smul' a
+    x := by
+    ext i
+    simp only [Prod.smul_fst, Prod.smul_snd, Pi.smul_apply, smul_eq_mul, Complex.ofReal_mul,
+      Matrix.mulVec, dotProduct, Fin.sum_univ_two]
+    simp only [Complex.real_smul, RingHom.id_apply]
+    ring
+
+private theorem
+    FullPeriodMatrix.periodLinear_re (p : FullPeriodMatrix) (x : RealPair₂) (i : Fin 2) :
+    (p.periodLinear x i).re = x.1 i + ((p.matrix.map Complex.re) *ᵥ x.2) i := by
+  simp [periodLinear, Matrix.mulVec, dotProduct, Fin.sum_univ_two, Complex.mul_re]
+
+private theorem
+    FullPeriodMatrix.periodLinear_im (p : FullPeriodMatrix) (x : RealPair₂) (i : Fin 2) :
+    (p.periodLinear x i).im = p.imaginaryEquiv x.2 i := by
+  simp [periodLinear, imaginaryEquiv, Matrix.mulVec, dotProduct, Fin.sum_univ_two, Complex.mul_im]
+
+private theorem FullPeriodMatrix.periodLinear_bijective (p : FullPeriodMatrix) :
+    Function.Bijective p.periodLinear := by
+  constructor
+  · intro x y hxy
+    have him : p.imaginaryEquiv x.2 = p.imaginaryEquiv y.2 := by
+      ext i
+      simpa only [periodLinear_im] using congrArg Complex.im (congrFun hxy i)
+    have hs : x.2 = y.2 := p.imaginaryEquiv.injective him
+    apply Prod.ext _ hs
+    ext i
+    have he := congrArg Complex.re (congrFun hxy i)
+    simpa only [periodLinear_re, hs, add_left_inj] using he
+  · intro z
+    let b := p.imaginaryEquiv.symm (fun i => (z i).im)
+    let a := (fun i => (z i).re) - (p.matrix.map Complex.re) *ᵥ b
+    refine ⟨(a, b), ?_⟩
+    ext i
+    apply Complex.ext
+    · simp only [periodLinear_re, a, Pi.sub_apply, sub_add_cancel]
+    · simpa only [periodLinear_im] using congrFun (p.imaginaryEquiv.apply_symm_apply _) i
+
+private def FullPeriodMatrix.periodEquiv (p : FullPeriodMatrix) : RealPair₂ ≃ₗ[ℝ] ComplexPlane₂ :=
+  LinearEquiv.ofBijective p.periodLinear p.periodLinear_bijective
+
+private def FullPeriodMatrix.basis (p : FullPeriodMatrix) :
+    Module.Basis (Fin 2 ⊕ Fin 2) ℝ ComplexPlane₂ :=
+  ((Pi.basisFun ℝ (Fin 2)).prod (Pi.basisFun ℝ (Fin 2))).map p.periodEquiv
+
+private theorem FullPeriodMatrix.basis_inl (p : FullPeriodMatrix) (j : Fin 2) :
+    p.basis (Sum.inl j) = Pi.single j 1 := by
+  ext i
+  fin_cases i <;> fin_cases j <;>
+    simp [basis, periodEquiv, periodLinear, Module.Basis.prod_apply, Pi.basisFun_apply,
+      Matrix.mulVec, dotProduct, Fin.sum_univ_two]
+
+private theorem FullPeriodMatrix.basis_inr (p : FullPeriodMatrix) (j : Fin 2) :
+    p.basis (Sum.inr j) = fun i => p.matrix i j := by
+  ext i
+  fin_cases i <;> fin_cases j <;>
+    simp [basis, periodEquiv, periodLinear, Module.Basis.prod_apply, Pi.basisFun_apply,
+      Matrix.mulVec, dotProduct, Fin.sum_univ_two]
+
+private def FullPeriodMatrix.lattice (p : FullPeriodMatrix) : Submodule ℤ ComplexPlane₂ :=
+  Submodule.span ℤ (Set.range p.basis)
+
+private theorem FullPeriodMatrix.basis_integer_sum (p : FullPeriodMatrix) (c : Fin 2 ⊕ Fin 2 → ℤ) :
+    ∑ j, c j • p.basis j =
+      (fun i => (c (Sum.inl i) : ℂ)) + p.matrix *ᵥ (fun i => (c (Sum.inr i) : ℂ)) := by
+  ext i
+  fin_cases i <;>
+    simp [Fintype.sum_sum_type, basis_inl, basis_inr, Fin.sum_univ_two, Pi.single_apply,
+      zsmul_eq_mul, mul_comm]
+
+private theorem FullPeriodMatrix.mem_lattice_iff (p : FullPeriodMatrix) (z : ComplexPlane₂) :
+    z ∈ p.lattice ↔
+      ∃ m n : Fin 2 → ℤ, z = (fun i => (m i : ℂ)) + p.matrix *ᵥ (fun i => (n i : ℂ)) := by
+  rw [lattice, Submodule.mem_span_range_iff_exists_fun]
+  constructor
+  · rintro ⟨c, hc⟩
+    exact ⟨fun i => c (Sum.inl i), fun i => c (Sum.inr i), hc.symm.trans (p.basis_integer_sum c)⟩
+  · rintro ⟨m, n, rfl⟩
+    exact ⟨Sum.elim m n, p.basis_integer_sum (Sum.elim m n)⟩
+
+private instance
+    FullPeriodMatrix.lattice_discrete (p : FullPeriodMatrix) : DiscreteTopology p.lattice := by
+  unfold lattice; infer_instance
+
+private instance
+    FullPeriodMatrix.lattice_isZLattice (p : FullPeriodMatrix) : IsZLattice ℝ p.lattice :=
+  ⟨ZSpan.span_top p.basis⟩
+
+private abbrev FullPeriodMatrix.Torus (p : FullPeriodMatrix) :=
+  ComplexPlane₂ ⧸ p.lattice
+
+private instance FullPeriodMatrix.torus_pathConnected (p : FullPeriodMatrix) :
+    PathConnectedSpace p.Torus :=
+  p.lattice.mkQ_surjective.pathConnectedSpace p.lattice.continuous_mkQ
+
+private instance FullPeriodMatrix.torus_compact (p : FullPeriodMatrix) : CompactSpace p.Torus := by
+  have hper : ∀ z w, w ∈ p.lattice → p.lattice.mkQ (z + w) = p.lattice.mkQ z := by
+    intro z w hw
+    have hw' : p.lattice.mkQ w = 0 := (Submodule.Quotient.mk_eq_zero p.lattice).mpr hw
+    rw [map_add, hw', add_zero]
+  have hc :=
+    IsZLattice.isCompact_range_of_periodic p.lattice p.lattice.mkQ p.lattice.continuous_mkQ hper
+  exact ⟨by simpa only [Set.range_eq_univ.mpr p.lattice.mkQ_surjective] using hc⟩
+
+private def PeriodDomain.step₁ (p : PeriodDomain) : PeriodDomain :=
+  ⟨p.val.step₁, p.val.step₁_admissible p.property⟩
+
+private def PeriodDomain.step₂ (p : PeriodDomain) : PeriodDomain :=
+  ⟨p.val.step₂, p.val.step₂_admissible p.property⟩
+
+private def PeriodDomain.R₁Equiv (p : PeriodDomain) : ComplexPlane₂ ≃L[ℂ] ComplexPlane₂ :=
+  (Matrix.toLinearEquiv (Pi.basisFun ℂ (Fin 2)) p.val.R₁
+      (isUnit_iff_ne_zero.mpr
+        (by
+          rw [PeriodPoint.det_R₁]
+          exact
+            div_ne_zero (by norm_num) (p.val.τ_ne_zero p.property.1)))).toContinuousLinearEquiv
+
+private def PeriodDomain.R₂Equiv (p : PeriodDomain) : ComplexPlane₂ ≃L[ℂ] ComplexPlane₂ :=
+  (Matrix.toLinearEquiv (Pi.basisFun ℂ (Fin 2)) p.val.R₂
+      (isUnit_iff_ne_zero.mpr
+        (by
+          rw [PeriodPoint.det_R₂]
+          exact div_ne_zero one_ne_zero (p.val.τ_ne_zero p.property.1)))).toContinuousLinearEquiv
+
+private theorem PeriodDomain.R₁Equiv_apply (p : PeriodDomain) (z : ComplexPlane₂) :
+    p.R₁Equiv z = p.val.R₁ *ᵥ z := by simp [R₁Equiv, Matrix.toLin_eq_toLin', Matrix.toLin'_apply]
+
+private theorem PeriodDomain.R₂Equiv_apply (p : PeriodDomain) (z : ComplexPlane₂) :
+    p.R₂Equiv z = p.val.R₂ *ᵥ z := by simp [R₂Equiv, Matrix.toLin_eq_toLin', Matrix.toLin'_apply]
+
+private theorem PeriodDomain.R₁Equiv_map_lattice (p : PeriodDomain) :
+    p.lattice.map (p.R₁Equiv.toLinearEquiv.restrictScalars ℤ).toLinearMap = p.step₁.lattice := by
+  have he :
+    (p.R₁Equiv.toLinearEquiv.restrictScalars ℤ).toLinearMap =
+      p.val.R₁.mulVecLin.restrictScalars ℤ := by exact LinearMap.ext fun z => R₁Equiv_apply p z
+  change (columnLattice p.val.matrix).map _ = columnLattice p.val.step₁.matrix
+  rw [he, map_columnLattice, p.val.step₁_matrix (p.val.τ_ne_zero p.property.1)]
+  exact (columnLattice_mul_eq _ T₁.transpose A₁ (by decide)).symm
+
+private theorem PeriodDomain.R₂Equiv_map_lattice (p : PeriodDomain) :
+    p.lattice.map (p.R₂Equiv.toLinearEquiv.restrictScalars ℤ).toLinearMap = p.step₂.lattice := by
+  have he :
+    (p.R₂Equiv.toLinearEquiv.restrictScalars ℤ).toLinearMap =
+      p.val.R₂.mulVecLin.restrictScalars ℤ := by exact LinearMap.ext fun z => R₂Equiv_apply p z
+  change (columnLattice p.val.matrix).map _ = columnLattice p.val.step₂.matrix
+  rw [he, map_columnLattice, p.val.step₂_matrix (p.val.τ_ne_zero p.property.1)]
+  exact (columnLattice_mul_eq _ T₂.transpose A₂ (by decide)).symm
+
+private def PeriodPoint.leftBlock (p : PeriodPoint) : Matrix (Fin 2) (Fin 2) ℂ :=
+  !![6 * p.μ, p.τ; p.β, p.μ]
+
+private theorem PeriodPoint.leftBlock_apply (p : PeriodPoint) (i j : Fin 2) :
+    p.leftBlock i j = p.matrix i (Fin.castAdd 2 j) := by fin_cases i <;> fin_cases j <;> rfl
+
+private theorem PeriodPoint.matrix_rightBlock (p : PeriodPoint) (i j : Fin 2) :
+    p.matrix i (Fin.natAdd 2 j) = (Pi.single j (1 : ℂ) : ComplexPlane₂) i := by
+  fin_cases i <;> fin_cases j <;> simp [PeriodPoint.matrix]
+
+private theorem PeriodDomain.fullPeriodLattice_eq (p : PeriodDomain) (q : FullPeriodMatrix)
+    (h : q.matrix = p.val.leftBlock) : q.lattice = p.lattice := by
+  have hrange : Set.range q.basis = Set.range (fun j i => p.val.matrix i j) := by
+    ext z
+    constructor
+    · rintro ⟨j, rfl⟩
+      cases j with
+      | inl j =>
+        refine ⟨Fin.natAdd 2 j, ?_⟩
+        ext i
+        rw [q.basis_inl]
+        exact p.val.matrix_rightBlock i j
+      | inr j =>
+        refine ⟨Fin.castAdd 2 j, ?_⟩
+        ext i
+        rw [q.basis_inr, h]
+        exact (p.val.leftBlock_apply i j).symm
+    · rintro ⟨j, rfl⟩
+      fin_cases j
+      · refine ⟨Sum.inr 0, ?_⟩
+        rw [q.basis_inr, h]
+        ext i
+        exact p.val.leftBlock_apply i 0
+      · refine ⟨Sum.inr 1, ?_⟩
+        rw [q.basis_inr, h]
+        ext i
+        exact p.val.leftBlock_apply i 1
+      · refine ⟨Sum.inl 0, ?_⟩
+        rw [q.basis_inl]
+        ext i
+        exact (p.val.matrix_rightBlock i 0).symm
+      · refine ⟨Sum.inl 1, ?_⟩
+        rw [q.basis_inl]
+        ext i
+        exact (p.val.matrix_rightBlock i 1).symm
+  exact congrArg (Submodule.span ℤ) hrange
+
+private structure HolomorphicPeriodMap (V B : Type*) [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] where
+  point : B → PeriodDomain
+  holomorphic_tau :
+    ContMDiff (modelWithCornersSelf ℂ V) (modelWithCornersSelf ℂ ℂ) ω (fun b => (point b).val.τ)
+  holomorphic_mu :
+    ContMDiff (modelWithCornersSelf ℂ V) (modelWithCornersSelf ℂ ℂ) ω (fun b => (point b).val.μ)
+  holomorphic_beta :
+    ContMDiff (modelWithCornersSelf ℂ V) (modelWithCornersSelf ℂ ℂ) ω (fun b => (point b).val.β)
+
+private def HolomorphicPeriodMap.periodEquiv {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B) (b : B) :
+    RealPlane₄ ≃ₗ[ℝ] ComplexPlane₂ :=
+  (P.point b).realEquiv.trans complexCoordinates
+
+private theorem HolomorphicPeriodMap.periodEquiv_apply {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B)
+    (b : B) (v : RealPlane₄) :
+    P.periodEquiv b v = complexCoordinates ((P.point b).val.realMatrix *ᵥ v) := by
+  simp only [periodEquiv, LinearEquiv.trans_apply, PeriodDomain.realEquiv_apply]
+
+private theorem HolomorphicPeriodMap.periodEquiv_symm_apply {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B)
+    (b : B) (z : ComplexPlane₂) :
+    (P.periodEquiv b).symm z = (P.point b).val.realMatrix⁻¹ *ᵥ complexCoordinates.symm z := by
+  simp [periodEquiv, PeriodDomain.realEquiv, Matrix.toLinearEquiv, Matrix.toLin_eq_toLin',
+    Matrix.toLin'_apply]
+
+private theorem HolomorphicPeriodMap.continuous_realMatrix {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B) :
+    Continuous (fun b => (P.point b).val.realMatrix) := by
+  have ht := P.holomorphic_tau.continuous
+  have hm := P.holomorphic_mu.continuous
+  have hb := P.holomorphic_beta.continuous
+  apply continuous_matrix
+  intro i j
+  fin_cases i <;> fin_cases j <;> simp only [PeriodPoint.realMatrix] <;> fun_prop
+
+private theorem HolomorphicPeriodMap.continuous_realMatrix_inv {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B) :
+    Continuous (fun b => (P.point b).val.realMatrix⁻¹) := by
+  apply continuous_iff_continuousAt.mpr
+  intro b
+  have hd : (P.point b).val.realMatrix.det ≠ 0 :=
+    ne_of_lt ((P.point b).val.det_realMatrix_neg (P.point b).property)
+  have hinv : ContinuousAt (fun A : Matrix (Fin 4) (Fin 4) ℝ => A⁻¹) (P.point b).val.realMatrix :=
+    by
+    apply continuousAt_matrix_inv
+    simpa only [Ring.inverse_eq_inv'] using ContinuousInv₀.continuousAt_inv₀ hd
+  exact
+    hinv.comp (f := fun b : B => (P.point b).val.realMatrix)
+      (P.continuous_realMatrix.continuousAt (x := b))
+
+private theorem HolomorphicPeriodMap.continuous_periodEquiv {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B) :
+    Continuous (fun x : B × RealPlane₄ => P.periodEquiv x.1 x.2) := by
+  simp_rw [periodEquiv_apply]
+  exact
+    complexCoordinates.toContinuousLinearEquiv.continuous.comp
+      ((P.continuous_realMatrix.comp continuous_fst).matrix_mulVec continuous_snd)
+
+private theorem
+    HolomorphicPeriodMap.continuous_periodEquiv_symm {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B) :
+    Continuous (fun x : B × ComplexPlane₂ => (P.periodEquiv x.1).symm x.2) := by
+  simp_rw [periodEquiv_symm_apply]
+  exact
+    (P.continuous_realMatrix_inv.comp continuous_fst).matrix_mulVec
+      (complexCoordinates.symm.toContinuousLinearEquiv.continuous.comp continuous_snd)
+
+private def
+    HolomorphicPeriodMap.realTrivialization {V B : Type*} [NormedAddCommGroup V] [NormedSpace ℂ V]
+    [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B) :
+    (B × ComplexPlane₂) ≃ₜ (B × RealPlane₄)
+    where
+  toFun x := (x.1, (P.periodEquiv x.1).symm x.2)
+  invFun x := (x.1, P.periodEquiv x.1 x.2)
+  left_inv x := by simp
+  right_inv x := by simp
+  continuous_toFun := continuous_fst.prodMk P.continuous_periodEquiv_symm
+  continuous_invFun := continuous_fst.prodMk P.continuous_periodEquiv
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Pi1/FundamentalGroupVanKampen1.lean b/LeanPool/HopfProblem/Pi1/FundamentalGroupVanKampen1.lean
new file mode 100644
index 000000000..dcf142900
--- /dev/null
+++ b/LeanPool/HopfProblem/Pi1/FundamentalGroupVanKampen1.lean
@@ -0,0 +1,479 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Foundations.TriangleRegularBaseFundamentalGroup
+import all LeanPool.HopfProblem.Foundations.Core2
+
+/-!
+# Hopf problem: pi 1 · fundamental group van kampen 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem FundamentalGroupVanKampen.subpath_mem_of_mem_Icc {X : Type*} [TopologicalSpace X]
+    {x y : X} (p : Path x y) {a b : (unitInterval)} (hab : a ≤ b) {s : Set X}
+    (hp : ∀ t ∈ Set.Icc a b, p t ∈ s) : ∀ t, p.subpath a b t ∈ s := by
+  apply Set.range_subset_iff.mp
+  rw [p.range_subpath_of_le a b hab]
+  exact Set.image_subset_iff.mpr hp
+
+private structure
+    FundamentalGroupVanKampen.LocalPathValue {X : Type*} [TopologicalSpace X] {ι : Type*}
+    (U : ι → Set X) (G : Type*) [Group G] where
+  value : ∀ i {x y : X} (p : Path x y), (∀ t, p t ∈ U i) → G
+  refl : ∀ i (x : X) (hx : ∀ t, Path.refl x t ∈ U i), value i (Path.refl x) hx = 1
+  trans :
+    ∀ i {x y z : X} (p : Path x y) (q : Path y z) (hp : ∀ t, p t ∈ U i) (hq : ∀ t, q t ∈ U i)
+      (hpq : ∀ t, p.trans q t ∈ U i), value i (p.trans q) hpq = value i p hp * value i q hq
+  subpath_mul :
+    ∀ i {x y : X} (p : Path x y) (a b c : (unitInterval)) (_ : a ≤ b) (_ : b ≤ c)
+      (hab : ∀ t, p.subpath a b t ∈ U i) (hbc : ∀ t, p.subpath b c t ∈ U i)
+      (hac : ∀ t, p.subpath a c t ∈ U i),
+      value i (p.subpath a c) hac = value i (p.subpath a b) hab * value i (p.subpath b c) hbc
+  compatible :
+    ∀ i j {x y : X} (p : Path x y) (hi : ∀ t, p t ∈ U i) (hj : ∀ t, p t ∈ U j),
+      value i p hi = value j p hj
+
+private theorem FundamentalGroupVanKampen.LocalPathValue.value_cast {X : Type*} [TopologicalSpace X]
+    {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) (i : ι) {x y x' y' : X} (p : Path x y)
+    (hx : x' = x) (hy : y' = y) (hp : ∀ t, p t ∈ U i) (hp' : ∀ t, p.cast hx hy t ∈ U i) :
+    L.value i (p.cast hx hy) hp' = L.value i p hp := by
+  cases hx
+  cases hy
+  rfl
+
+private def
+    FundamentalGroupVanKampen.LocalPathValue.HomotopyInvariant {X : Type*} [TopologicalSpace X]
+    {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) : Prop :=
+  ∀ i {x y : X} (p q : Path x y) (hp : ∀ t, p t ∈ U i) (hq : ∀ t, q t ∈ U i)
+    (H : Path.Homotopy p q), (∀ s, H s ∈ U i) → L.value i p hp = L.value i q hq
+
+private structure FundamentalGroupVanKampen.PathValue (X : Type*) [TopologicalSpace X] (G : Type*)
+    [Group G] where
+  value : ∀ {x y : X}, Path x y → G
+  refl : ∀ x, value (Path.refl x) = 1
+  trans : ∀ {x y z : X} (p : Path x y) (q : Path y z), value (p.trans q) = value p * value q
+  subpath_mul :
+    ∀ {x y : X} (p : Path x y) (a b c : (unitInterval)),
+      a ≤ b → b ≤ c → value (p.subpath a c) = value (p.subpath a b) * value (p.subpath b c)
+
+private theorem FundamentalGroupVanKampen.PathValue.value_cast {X : Type*} [TopologicalSpace X]
+    {G : Type*} [Group G] (V : FundamentalGroupVanKampen.PathValue X G) {x y x' y' : X}
+    (p : Path x y) (hx : x' = x) (hy : y' = y) : V.value (p.cast hx hy) = V.value p := by
+  cases hx
+  cases hy
+  rfl
+
+private theorem FundamentalGroupVanKampen.PathValue.value_subpath_zero_one {X : Type*}
+    [TopologicalSpace X] {G : Type*} [Group G] (V : FundamentalGroupVanKampen.PathValue X G)
+    {x y : X} (p : Path x y) : V.value (p.subpath 0 1) = V.value p := by
+  rw [Path.subpath_zero_one, V.value_cast]
+
+private def FundamentalGroupVanKampen.PathValue.Extends {X : Type*} [TopologicalSpace X] {ι : Type*}
+    {G : Type*} [Group G] (V : FundamentalGroupVanKampen.PathValue X G) {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) : Prop :=
+  ∀ i {x y : X} (p : Path x y) (hp : ∀ t, p t ∈ U i), V.value p = L.value i p hp
+
+private def FundamentalGroupVanKampen.PathValue.HomotopyInvariant {X : Type*} [TopologicalSpace X]
+    {G : Type*} [Group G] (V : FundamentalGroupVanKampen.PathValue X G) : Prop :=
+  ∀ {x y : X} (p q : Path x y), Path.Homotopic p q → V.value p = V.value q
+
+/-- A pointed two-open cover with a connected overlap for van Kampen's theorem. -/
+public
+structure FundamentalGroupVanKampen.TwoOpenCover (X : Type*) [TopologicalSpace X] where
+  /-- The first open set of the cover. -/
+  U : TopologicalSpace.Opens X
+  /-- The second open set of the cover. -/
+  V : TopologicalSpace.Opens X
+  cover : (U : Set X) ∪ V = Set.univ
+  pathConnectedU : IsPathConnected (U : Set X)
+  pathConnectedV : IsPathConnected (V : Set X)
+  pathConnectedIntersection : IsPathConnected ((U : Set X) ∩ V)
+  /-- The chosen base point in the overlap. -/
+  base : X
+  baseU : base ∈ U
+  baseV : base ∈ V
+
+private abbrev FundamentalGroupVanKampen.TwoOpenCover.chart {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) : Bool → TopologicalSpace.Opens X
+  | false => D.U
+  | true => D.V
+
+private theorem
+    FundamentalGroupVanKampen.TwoOpenCover.base_mem_chart {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) (i : Bool) : D.base ∈ D.chart i := by
+  cases i
+  · exact D.baseU
+  · exact D.baseV
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.chart_open {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) (i : Bool) : IsOpen (D.chart i : Set X) :=
+  (D.chart i).isOpen
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.chart_cover {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) : ⋃ i, (D.chart i : Set X) = Set.univ := by
+  apply subset_antisymm (Set.subset_univ _)
+  intro x _
+  have hx : x ∈ (D.U : Set X) ∪ D.V := by rw [D.cover]; trivial
+  rcases hx with hx | hx
+  · exact Set.mem_iUnion.mpr ⟨Bool.false, hx⟩
+  · exact Set.mem_iUnion.mpr ⟨Bool.true, hx⟩
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.mem_U_or_V {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) (x : X) : x ∈ D.U ∨ x ∈ D.V := by
+  have hx : x ∈ (D.U : Set X) ∪ D.V := by rw [D.cover]; trivial
+  exact hx
+
+private def FundamentalGroupVanKampen.TwoOpenCover.rawPathTo {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) (x : X) : Path D.base x := by
+  classical
+    exact
+    if h : x ∈ (D.U : Set X) ∩ D.V then
+      (D.pathConnectedIntersection.joinedIn D.base ⟨D.baseU, D.baseV⟩ x h).somePath
+    else
+      if hU : x ∈ D.U then (D.pathConnectedU.joinedIn D.base D.baseU x hU).somePath
+      else
+        (D.pathConnectedV.joinedIn D.base D.baseV x ((D.mem_U_or_V x).resolve_left hU)).somePath
+
+private theorem
+    FundamentalGroupVanKampen.TwoOpenCover.rawPathTo_mem {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) (i : Bool) (x : X) (hx : x ∈ D.chart i)
+    (t : (unitInterval)) : D.rawPathTo x t ∈ D.chart i := by
+  classical
+    cases i with
+  | false =>
+    change D.rawPathTo x t ∈ D.U
+    change x ∈ D.U at hx
+    unfold rawPathTo
+    by_cases h : x ∈ (D.U : Set X) ∩ D.V
+    · rw [dite_eq_left h]
+      exact
+        ((D.pathConnectedIntersection.joinedIn D.base ⟨D.baseU, D.baseV⟩ x h).somePath_mem t).1
+    · rw [dite_eq_right h, dite_eq_left hx]
+      exact JoinedIn.somePath_mem _ t
+  | true =>
+    change D.rawPathTo x t ∈ D.V
+    change x ∈ D.V at hx
+    unfold rawPathTo
+    by_cases h : x ∈ (D.U : Set X) ∩ D.V
+    · rw [dite_eq_left h]
+      exact
+        ((D.pathConnectedIntersection.joinedIn D.base ⟨D.baseU, D.baseV⟩ x h).somePath_mem t).2
+    · have hnU : x ∉ D.U := fun hU => h ⟨hU, hx⟩
+      rw [dite_eq_right h, dite_eq_right hnU]
+      exact JoinedIn.somePath_mem _ t
+
+private def FundamentalGroupVanKampen.TwoOpenCover.pathTo {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) (x : X) : Path D.base x := by
+  classical exact if h : x = D.base then (Path.refl D.base).cast rfl h else D.rawPathTo x
+
+@[simp]
+private theorem FundamentalGroupVanKampen.TwoOpenCover.pathTo_base {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) : D.pathTo D.base = Path.refl D.base := by
+  classical simp [pathTo]
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.pathTo_mem {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) (i : Bool) (x : X) (hx : x ∈ D.chart i)
+    (t : (unitInterval)) : D.pathTo x t ∈ D.chart i := by
+  classical
+  unfold pathTo
+  split_ifs
+  · exact D.base_mem_chart i
+  · exact D.rawPathTo_mem i x hx t
+
+/-- The intersection of the two open sets. -/
+public
+abbrev FundamentalGroupVanKampen.TwoOpenCover.overlap {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) : TopologicalSpace.Opens X :=
+  D.U ⊓ D.V
+
+/-- The base point regarded as a point of the first open set. -/
+public
+abbrev FundamentalGroupVanKampen.TwoOpenCover.baseUPoint {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) : D.U :=
+  ⟨D.base, D.baseU⟩
+
+/-- The base point regarded as a point of the second open set. -/
+public
+abbrev FundamentalGroupVanKampen.TwoOpenCover.baseVPoint {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) : D.V :=
+  ⟨D.base, D.baseV⟩
+
+/-- The base point regarded as a point of the overlap. -/
+public
+abbrev FundamentalGroupVanKampen.TwoOpenCover.baseOverlapPoint {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) : D.overlap :=
+  ⟨D.base, D.baseU, D.baseV⟩
+
+private abbrev FundamentalGroupVanKampen.TwoOpenCover.baseChart {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) (i : Bool) : D.chart i :=
+  ⟨D.base, D.base_mem_chart i⟩
+
+/-- The fundamental group of the first open set at the chosen base point. -/
+public
+abbrev FundamentalGroupVanKampen.TwoOpenCover.UGroup {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) :=
+  FundamentalGroup D.U D.baseUPoint
+
+/-- The fundamental group of the second open set at the chosen base point. -/
+public
+abbrev FundamentalGroupVanKampen.TwoOpenCover.VGroup {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) :=
+  FundamentalGroup D.V D.baseVPoint
+
+/-- The fundamental group of the overlap at the chosen base point. -/
+public
+abbrev FundamentalGroupVanKampen.TwoOpenCover.OverlapGroup {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) :=
+  FundamentalGroup D.overlap D.baseOverlapPoint
+
+private def FundamentalGroupVanKampen.TwoOpenCover.overlapToU {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) : C(D.overlap, D.U) :=
+  ⟨fun x => ⟨x.val, x.property.1⟩, continuous_subtype_val.subtype_mk _⟩
+
+private def FundamentalGroupVanKampen.TwoOpenCover.overlapToV {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) : C(D.overlap, D.V) :=
+  ⟨fun x => ⟨x.val, x.property.2⟩, continuous_subtype_val.subtype_mk _⟩
+
+private def FundamentalGroupVanKampen.TwoOpenCover.inclusionU {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) : C(D.U, X) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private def FundamentalGroupVanKampen.TwoOpenCover.inclusionV {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) : C(D.V, X) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private def FundamentalGroupVanKampen.TwoOpenCover.overlapHomU {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) : D.OverlapGroup →* D.UGroup :=
+  FundamentalGroup.map D.overlapToU D.baseOverlapPoint
+
+/-- The fundamental-group homomorphism from the overlap into the second open set. -/
+public
+def FundamentalGroupVanKampen.TwoOpenCover.overlapHomV {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) : D.OverlapGroup →* D.VGroup :=
+  FundamentalGroup.map D.overlapToV D.baseOverlapPoint
+
+/-- The fundamental-group homomorphism induced by including the first open set. -/
+public
+def FundamentalGroupVanKampen.TwoOpenCover.inclusionHomU {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) : D.UGroup →* FundamentalGroup X D.base :=
+  FundamentalGroup.map D.inclusionU D.baseUPoint
+
+private def FundamentalGroupVanKampen.TwoOpenCover.inclusionHomV {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) : D.VGroup →* FundamentalGroup X D.base :=
+  FundamentalGroup.map D.inclusionV D.baseVPoint
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.inclusionHom_compatible {X : Type*}
+    [TopologicalSpace X] (D : FundamentalGroupVanKampen.TwoOpenCover X) :
+    D.inclusionHomU.comp D.overlapHomU = D.inclusionHomV.comp D.overlapHomV := by
+  ext γ
+  obtain ⟨p⟩ := γ
+  apply congrArg Path.Homotopic.Quotient.mk
+  ext t
+  rfl
+
+private def FundamentalGroupVanKampen.TwoOpenCover.Compatible {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) {G : Type*} [Group G] (fU : D.UGroup →* G)
+    (fV : D.VGroup →* G) : Prop :=
+  fU.comp D.overlapHomU = fV.comp D.overlapHomV
+
+private def FundamentalGroupVanKampen.pathIn {X : Type*} [TopologicalSpace X] {S : Set X} {x y : X}
+    (p : Path x y) (hx : x ∈ S) (hy : y ∈ S) (hp : ∀ t, p t ∈ S) : Path (⟨x, hx⟩ : S) ⟨y, hy⟩
+    where
+  toFun t := ⟨p t, hp t⟩
+  continuous_toFun := p.continuous.subtype_mk _
+  source' := Subtype.ext p.source
+  target' := Subtype.ext p.target
+
+@[simp]
+private theorem FundamentalGroupVanKampen.pathIn_apply {X : Type*} [TopologicalSpace X] {S : Set X}
+    {x y : X} (p : Path x y) (hx : x ∈ S) (hy : y ∈ S) (hp : ∀ t, p t ∈ S) (t : (unitInterval)) :
+    (pathIn p hx hy hp t : X) = p t :=
+  rfl
+
+@[simp]
+private theorem FundamentalGroupVanKampen.pathIn_map {X : Type*} [TopologicalSpace X] {S : Set X}
+    {x y : X} (p : Path x y) (hx : x ∈ S) (hy : y ∈ S) (hp : ∀ t, p t ∈ S) :
+    (pathIn p hx hy hp).map continuous_subtype_val = p := by
+  ext t
+  rfl
+
+@[simp]
+private theorem
+    FundamentalGroupVanKampen.pathIn_refl {X : Type*} [TopologicalSpace X] {S : Set X} {x : X}
+    (hx : x ∈ S) (hp : ∀ t, Path.refl x t ∈ S) :
+    pathIn (Path.refl x) hx hx hp = Path.refl (⟨x, hx⟩ : S) := by
+  ext t
+  rfl
+
+@[simp]
+private theorem FundamentalGroupVanKampen.pathIn_trans {X : Type*} [TopologicalSpace X] {S : Set X}
+    {x y z : X} (p : Path x y) (q : Path y z) (hx : x ∈ S) (hy : y ∈ S) (hz : z ∈ S)
+    (hp : ∀ t, p t ∈ S) (hq : ∀ t, q t ∈ S) (hpq : ∀ t, p.trans q t ∈ S) :
+    pathIn (p.trans q) hx hz hpq = (pathIn p hx hy hp).trans (pathIn q hy hz hq) := by
+  ext t
+  simp only [pathIn_apply, Path.trans_apply]
+  split_ifs <;> rfl
+
+private def
+    FundamentalGroupVanKampen.homotopyIn {X : Type*} [TopologicalSpace X] {S : Set X} {x y : X}
+    (p q : Path x y) (hx : x ∈ S) (hy : y ∈ S) (hp : ∀ t, p t ∈ S) (hq : ∀ t, q t ∈ S)
+    (H : Path.Homotopy p q) (hH : ∀ s, H s ∈ S) :
+    Path.Homotopy (pathIn p hx hy hp) (pathIn q hx hy hq)
+    where
+  toFun s := ⟨H s, hH s⟩
+  continuous_toFun := H.continuous.subtype_mk _
+  map_zero_left t := Subtype.ext (H.apply_zero t)
+  map_one_left t := Subtype.ext (H.apply_one t)
+  prop' s _t ht := Subtype.ext (H.eq_fst s ht)
+
+private theorem
+    FundamentalGroupVanKampen.homotopy_trans_mem {X : Type*} [TopologicalSpace X] {S : Set X}
+    {x y : X} {p q r : Path x y} (H : Path.Homotopy p q) (K : Path.Homotopy q r)
+    (hH : ∀ s, H s ∈ S) (hK : ∀ s, K s ∈ S) : ∀ s, H.trans K s ∈ S := by
+  intro s
+  rw [Path.Homotopy.trans_apply]
+  split_ifs
+  · exact hH _
+  · exact hK _
+
+private theorem FundamentalGroupVanKampen.homotopy_transRefl_mem {X : Type*} [TopologicalSpace X]
+    {S : Set X} {x y : X} (p : Path x y) (hp : ∀ t, p t ∈ S) :
+    ∀ s, Path.Homotopy.transRefl p s ∈ S := by
+  intro s
+  exact hp _
+
+private theorem FundamentalGroupVanKampen.homotopy_subpathTransSubpathRefl_mem {X : Type*}
+    [TopologicalSpace X] {S : Set X} {x y : X} (p : Path x y) (a b c : (unitInterval))
+    (hab : a ≤ b) (hbc : b ≤ c) (hp : ∀ t ∈ Set.Icc a c, p t ∈ S) :
+    ∀ s, Path.Homotopy.subpathTransSubpathRefl p a b c s ∈ S := by
+  intro s
+  let m := Set.Icc.convexComb b c s.1
+  have ham : a ≤ m := hab.trans (Set.Icc.le_convexComb hbc s.1)
+  have hmc : m ≤ c := Set.Icc.convexComb_le hbc s.1
+  change ((p.subpath a m).trans (p.subpath m c)) s.2 ∈ S
+  apply SimplyConnectedCover.trans_mem
+  · exact subpath_mem_of_mem_Icc p ham (fun t ht => hp t ⟨ht.1, ht.2.trans hmc⟩)
+  · exact subpath_mem_of_mem_Icc p hmc (fun t ht => hp t ⟨ham.trans ht.1, ht.2⟩)
+
+private theorem FundamentalGroupVanKampen.homotopy_subpathTransSubpath_mem {X : Type*}
+    [TopologicalSpace X] {S : Set X} {x y : X} (p : Path x y) (a b c : (unitInterval))
+    (hab : a ≤ b) (hbc : b ≤ c) (hp : ∀ t ∈ Set.Icc a c, p t ∈ S) :
+    ∀ s, Path.Homotopy.subpathTransSubpath p a b c s ∈ S :=
+  homotopy_trans_mem _ _ (homotopy_subpathTransSubpathRefl_mem p a b c hab hbc hp)
+    (homotopy_transRefl_mem _ (subpath_mem_of_mem_Icc p (hab.trans hbc) hp))
+
+private theorem FundamentalGroupVanKampen.mem_Icc_of_subpath_mem {X : Type*} [TopologicalSpace X]
+    {S : Set X} {x y : X} (p : Path x y) {a b : (unitInterval)} (hab : a ≤ b)
+    (hp : ∀ t, p.subpath a b t ∈ S) : ∀ t ∈ Set.Icc a b, p t ∈ S := by
+  have hr := Set.range_subset_iff.mpr hp
+  rw [p.range_subpath_of_le a b hab] at hr
+  intro t ht
+  exact hr ⟨t, ht, rfl⟩
+
+private def
+    FundamentalGroupVanKampen.subpathTransSubpathIn {X : Type*} [TopologicalSpace X] {S : Set X}
+    {x y : X} (p : Path x y) (a b c : (unitInterval)) (hab : a ≤ b) (hbc : b ≤ c) (ha : p a ∈ S)
+    (hb : p b ∈ S) (hc : p c ∈ S) (hpab : ∀ t, p.subpath a b t ∈ S)
+    (hpbc : ∀ t, p.subpath b c t ∈ S) (hpac : ∀ t, p.subpath a c t ∈ S) :
+    Path.Homotopy ((pathIn (p.subpath a b) ha hb hpab).trans (pathIn (p.subpath b c) hb hc hpbc))
+      (pathIn (p.subpath a c) ha hc hpac) :=
+  (homotopyIn _ _ ha hc (SimplyConnectedCover.trans_mem _ _ hpab hpbc) hpac
+        (Path.Homotopy.subpathTransSubpath p a b c)
+        (homotopy_subpathTransSubpath_mem p a b c hab hbc
+          (mem_Icc_of_subpath_mem p (hab.trans hbc) hpac))).cast
+    (pathIn_trans _ _ ha hb hc hpab hpbc _) rfl
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.hom_ext {X : Type*} [TopologicalSpace X]
+    {G : Type*} [Group G] (D : FundamentalGroupVanKampen.TwoOpenCover X)
+    (f g : FundamentalGroup X D.base →* G) (hU : f.comp D.inclusionHomU = g.comp D.inclusionHomU)
+    (hV : f.comp D.inclusionHomV = g.comp D.inclusionHomV) : f = g := by
+  let F (x : X) : Path.Homotopic.Quotient D.base x := Path.Homotopic.Quotient.mk (D.pathTo x)
+  have hlocal :
+    ∀ (i : Bool) {x y : X} (p : Path x y),
+      (∀ t, p t ∈ D.chart i) →
+        f (TriangleRegularBaseFundamentalGroup.basedLoop F (Path.Homotopic.Quotient.mk p)) =
+          g (TriangleRegularBaseFundamentalGroup.basedLoop F (Path.Homotopic.Quotient.mk p)) := by
+    intro i x y p hp
+    have hx : x ∈ D.chart i := by simpa using hp 0
+    have hy : y ∈ D.chart i := by simpa using hp 1
+    let l : Path D.base D.base := ((D.pathTo x).trans p).trans (D.pathTo y).symm
+    have hl : ∀ t, l t ∈ D.chart i :=
+      SimplyConnectedCover.trans_mem _ _
+        (SimplyConnectedCover.trans_mem _ _ (D.pathTo_mem i x hx) hp)
+        (fun t => D.pathTo_mem i y hy (unitInterval.symm t))
+    let l' : Path (D.baseChart i) (D.baseChart i) :=
+      FundamentalGroupVanKampen.pathIn l (D.base_mem_chart i) (D.base_mem_chart i) hl
+    have hmap :
+      (Path.Homotopic.Quotient.mk l').map
+          (⟨Subtype.val, continuous_subtype_val⟩ : C(D.chart i, X)) =
+        TriangleRegularBaseFundamentalGroup.basedLoop F (Path.Homotopic.Quotient.mk p) := by
+      change
+        Path.Homotopic.Quotient.mk (l'.map continuous_subtype_val) =
+          TriangleRegularBaseFundamentalGroup.basedLoop F (Path.Homotopic.Quotient.mk p)
+      rw [show l'.map continuous_subtype_val = l from
+          FundamentalGroupVanKampen.pathIn_map _ _ _ _]
+      rfl
+    cases i with
+    | false =>
+      have h := DFunLike.congr_fun hU (Path.Homotopic.Quotient.mk l')
+      exact (congrArg f hmap).symm.trans (h.trans (congrArg g hmap))
+    | true =>
+      have h := DFunLike.congr_fun hV (Path.Homotopic.Quotient.mk l')
+      exact (congrArg f hmap).symm.trans (h.trans (congrArg g hmap))
+  have hall :
+    ∀ {x y : X} (q : Path.Homotopic.Quotient x y),
+      f (TriangleRegularBaseFundamentalGroup.basedLoop F q) =
+        g (TriangleRegularBaseFundamentalGroup.basedLoop F q) := by
+    apply
+      TriangleRegularBaseFundamentalGroup.pathClass_induction_of_open_cover
+        (fun i => (D.chart i : Set X)) D.chart_open D.chart_cover
+        (fun q =>
+          f (TriangleRegularBaseFundamentalGroup.basedLoop F q) =
+            g (TriangleRegularBaseFundamentalGroup.basedLoop F q))
+    · intro x
+      simp only [TriangleRegularBaseFundamentalGroup.basedLoop_refl, map_one]
+    · intro x y z p q hp hq
+      rw [TriangleRegularBaseFundamentalGroup.basedLoop_trans, map_mul, map_mul, hp, hq]
+    · intro i x y p hp
+      exact hlocal i p (Set.range_subset_iff.mp hp)
+  have hbase : F D.base = Path.Homotopic.Quotient.refl D.base := by
+    simp only [F, D.pathTo_base, Path.Homotopic.Quotient.mk_refl]
+  have hsymm : (Path.Homotopic.Quotient.refl D.base).symm = Path.Homotopic.Quotient.refl D.base :=
+    by
+    change (1 : FundamentalGroup X D.base)⁻¹ = 1
+    exact inv_one
+  apply MonoidHom.ext
+  intro q
+  simpa only [TriangleRegularBaseFundamentalGroup.basedLoop, hbase,
+    Path.Homotopic.Quotient.refl_trans, hsymm, Path.Homotopic.Quotient.trans_refl] using hall q
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Pi1/FundamentalGroupVanKampen2.lean b/LeanPool/HopfProblem/Pi1/FundamentalGroupVanKampen2.lean
new file mode 100644
index 000000000..f07e20866
--- /dev/null
+++ b/LeanPool/HopfProblem/Pi1/FundamentalGroupVanKampen2.lean
@@ -0,0 +1,2732 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Foundations.EuclideanSphere
+public import LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.Foundations.TriangleRegularBaseFundamentalGroup
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen1
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Pi1.ThreefoldOverlapMappingTorus1
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.PeriodFamily.Core2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import all LeanPool.HopfProblem.Elliptic.Core3
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.Elliptic.Core4
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods8
+import all LeanPool.HopfProblem.Foundations.EuclideanSphere
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology1
+
+/-!
+# Hopf problem: pi 1 · fundamental group van kampen 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem ThreefoldOverlapMappingTorus.Elliptic.root_sub_order (j : Elliptic.Kind) (r : ℝ)
+    (a : ThreefoldOverlapMappingTorus.Radius j.order r)
+    (t : ThreefoldOverlapMappingTorus.Circle) :
+    ThreefoldOverlapMappingTorus.root j.order r a
+        (t - (((1 : ℝ) / j.order : ℝ) : ThreefoldOverlapMappingTorus.Circle)) =
+      Elliptic.familyRotation j (ThreefoldOverlapMappingTorus.root j.order r a t) := by
+  apply Subtype.ext
+  rw [Elliptic.LogGauge.familyRotation_val_exponential]
+  change
+    (a : ℝ) •
+        (ThreefoldOverlapMappingTorus.phase
+            (t - (((1 : ℝ) / j.order : ℝ) : ThreefoldOverlapMappingTorus.Circle)) :
+          ℂ) =
+      CuspUniformization.exponential (-(1 / (j.order : ℂ))) *
+        ((a : ℝ) • (ThreefoldOverlapMappingTorus.phase t : ℂ))
+  rw [sub_eq_add_neg, ← AddCircle.coe_neg, ThreefoldOverlapMappingTorus.phase_add,
+    _root_.Circle.coe_mul, ThreefoldOverlapMappingTorus.phase_real]
+  have he : (((-(1 / (j.order : ℝ))) : ℝ) : ℂ) = -(1 / (j.order : ℂ)) := by
+    push_cast
+    rfl
+  rw [he, Complex.real_smul, Complex.real_smul]
+  ring
+
+private theorem ThreefoldOverlapMappingTorus.Elliptic.root_add_order (j : Elliptic.Kind) (r : ℝ)
+    (a : ThreefoldOverlapMappingTorus.Radius j.order r)
+    (t : ThreefoldOverlapMappingTorus.Circle) :
+    ThreefoldOverlapMappingTorus.root j.order r a
+        (t + (((1 : ℝ) / j.order : ℝ) : ThreefoldOverlapMappingTorus.Circle)) =
+      (Elliptic.familyRotation j).symm (ThreefoldOverlapMappingTorus.root j.order r a t) := by
+  apply (Elliptic.familyRotation j).injective
+  exact
+    ((root_sub_order j r a
+              (t + (((1 : ℝ) / j.order : ℝ) : ThreefoldOverlapMappingTorus.Circle))).symm.trans
+          (congrArg (ThreefoldOverlapMappingTorus.root j.order r a)
+            (add_sub_cancel_right _ _))).trans
+      ((Elliptic.familyRotation j).apply_symm_apply _).symm
+
+private def ThreefoldOverlapMappingTorus.Elliptic.polarFamilyAt (j : Elliptic.Kind) (r : ℝ)
+    (a : ThreefoldOverlapMappingTorus.Radius j.order r)
+    (p : ThreefoldOverlapMappingTorus.Circle × RealTorus₄) : Elliptic.Family j :=
+  (ThreefoldOverlapMappingTorus.root j.order r a p.1, p.2)
+
+private theorem
+    ThreefoldOverlapMappingTorus.Elliptic.polarFamilyAt_injective (j : Elliptic.Kind) (r : ℝ)
+    (a : ThreefoldOverlapMappingTorus.Radius j.order r) :
+    Function.Injective (polarFamilyAt j r a) := by
+  intro p q hpq
+  apply Prod.ext
+  · have hz :
+      ThreefoldOverlapMappingTorus.polarRoot j.order r (a, p.1) =
+        ThreefoldOverlapMappingTorus.polarRoot j.order r (a, q.1) :=
+      Subtype.ext (congrArg Prod.fst hpq)
+    have he := congrArg (ThreefoldOverlapMappingTorus.rootAngle j.order r) hz
+    simpa only [ThreefoldOverlapMappingTorus.rootAngle_polarRoot] using he
+  · exact congrArg (fun y : Elliptic.Family j => y.2) hpq
+
+private theorem ThreefoldOverlapMappingTorus.Elliptic.polarFamilyAt_twist (j : Elliptic.Kind)
+    (v : Lattice) (r : ℝ) (a : ThreefoldOverlapMappingTorus.Radius j.order r)
+    (p : ThreefoldOverlapMappingTorus.Circle × RealTorus₄) :
+    polarFamilyAt j r a
+        (Elliptic.HigherHomology.MappingTorusQuotient.twist j.order
+          (Elliptic.flatTorusAffine j v).symm p) =
+      (Elliptic.familyPermutation j v).symm (polarFamilyAt j r a p) := by
+  change
+    (ThreefoldOverlapMappingTorus.root j.order r a
+          (p.1 + (((1 : ℝ) / j.order : ℝ) : ThreefoldOverlapMappingTorus.Circle)),
+        (Elliptic.flatTorusAffine j v).symm p.2) =
+      ((Elliptic.familyRotation j).symm (ThreefoldOverlapMappingTorus.root j.order r a p.1),
+        (Elliptic.flatTorusAffine j v).symm p.2)
+  exact Prod.ext (root_add_order j r a p.1) rfl
+
+private theorem
+    ThreefoldOverlapMappingTorus.Elliptic.polarFamilyAt_smul (j : Elliptic.Kind) (v : Lattice)
+    (hv : j.matrix *ᵥ v = v) (r : ℝ) (a : ThreefoldOverlapMappingTorus.Radius j.order r)
+    (g : Elliptic.CyclicGroup j) (p : ThreefoldOverlapMappingTorus.Circle × RealTorus₄) :
+    letI :=
+      Elliptic.HigherHomology.MappingTorusQuotient.productAction j.order
+        (Elliptic.flatTorusAffine j v).symm (affine_symm_pow_order j v hv)
+    letI := Elliptic.familyAction j v hv
+    polarFamilyAt j r a (g • p) = g⁻¹ • polarFamilyAt j r a p := by
+  let :=
+    Elliptic.HigherHomology.MappingTorusQuotient.productAction j.order
+      (Elliptic.flatTorusAffine j v).symm (affine_symm_pow_order j v hv)
+  let := Elliptic.familyAction j v hv
+  have he : g⁻¹ = Multiplicative.ofAdd (-(g.toAdd.val : ℤ) : ZMod j.order) := by
+    apply Multiplicative.ext
+    simp
+  have hright :
+    g⁻¹ • polarFamilyAt j r a p =
+      ((Elliptic.familyPermutation j v).symm :
+            Elliptic.Family j → Elliptic.Family j)^[g.toAdd.val]
+        (polarFamilyAt j r a p) := by
+    rw [he]
+    have hc :=
+      Elliptic.HigherHomology.MappingTorusQuotient.cyclicAction_ofAdd_intCast_smul j.order
+        (Elliptic.familyPermutation j v) (Elliptic.familyPermutation_pow_order j v hv)
+        (-(g.toAdd.val : ℤ)) (polarFamilyAt j r a p)
+    simp only [Int.cast_neg, Int.cast_natCast, zpow_neg, zpow_natCast] at hc
+    rw [← inv_pow, Equiv.Perm.coe_pow] at hc
+    simpa only [Int.cast_natCast, Equiv.Perm.inv_def] using hc
+  rw [hright]
+  change
+    polarFamilyAt j r a
+        ((Elliptic.HigherHomology.MappingTorusQuotient.twist j.order
+                (Elliptic.flatTorusAffine j v).symm :
+              _ → _)^[g.toAdd.val]
+          p) =
+      _
+  exact Function.Semiconj.iterate_right (polarFamilyAt_twist j v r a) g.toAdd.val p
+
+private def ThreefoldOverlapMappingTorus.quotientComparison {X Y Z : Type*} (q : X → Y) (p : X → Z)
+    (hq : Function.Surjective q) : Y → Z := fun y => p (hq y).choose
+
+private theorem ThreefoldOverlapMappingTorus.quotientComparison_apply {X Y Z : Type*} (q : X → Y)
+    (p : X → Z) (hq : Function.Surjective q) (h : ∀ x x', q x = q x' ↔ p x = p x') (x : X) :
+    quotientComparison q p hq (q x) = p x :=
+  (h _ _).mp (hq (q x)).choose_spec
+
+private theorem ThreefoldOverlapMappingTorus.quotientComparison_continuous {X Y Z : Type*}
+    [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace Z] (q : X → Y) (p : X → Z)
+    (hq : Topology.IsQuotientMap q) (hp : Continuous p) (h : ∀ x x', q x = q x' ↔ p x = p x') :
+    Continuous (quotientComparison q p hq.surjective) := by
+  apply hq.continuous_iff.mpr
+  have he : quotientComparison q p hq.surjective ∘ q = p :=
+    funext (quotientComparison_apply q p hq.surjective h)
+  rw [he]
+  exact hp
+
+private def ThreefoldOverlapMappingTorus.quotientHomeomorph {X Y Z : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] [TopologicalSpace Z] (q : X → Y) (p : X → Z)
+    (hq : Topology.IsQuotientMap q) (hp : Topology.IsQuotientMap p)
+    (h : ∀ x x', q x = q x' ↔ p x = p x') : Y ≃ₜ Z
+    where
+  toFun := quotientComparison q p hq.surjective
+  invFun := quotientComparison p q hp.surjective
+  left_inv
+    y := by
+    obtain ⟨x, rfl⟩ := hq.surjective y
+    rw [quotientComparison_apply q p hq.surjective h,
+      quotientComparison_apply p q hp.surjective (fun x x' => (h x x').symm)]
+  right_inv
+    z := by
+    obtain ⟨x, rfl⟩ := hp.surjective z
+    rw [quotientComparison_apply p q hp.surjective (fun x x' => (h x x').symm),
+      quotientComparison_apply q p hq.surjective h]
+  continuous_toFun := quotientComparison_continuous q p hq hp.continuous h
+  continuous_invFun :=
+    quotientComparison_continuous p q hp hq.continuous (fun x x' => (h x x').symm)
+
+@[simp]
+private theorem ThreefoldOverlapMappingTorus.quotientHomeomorph_symm_apply {X Y Z : Type*}
+    [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace Z] (q : X → Y) (p : X → Z)
+    (hq : Topology.IsQuotientMap q) (hp : Topology.IsQuotientMap p)
+    (h : ∀ x x', q x = q x' ↔ p x = p x') (x : X) :
+    (quotientHomeomorph q p hq hp h).symm (p x) = q x :=
+  quotientComparison_apply p q hp.surjective (fun x x' => (h x x').symm) x
+
+private def ThreefoldOverlapMappingTorus.Elliptic.puncturedSet (j : Elliptic.Kind) (v : Lattice)
+    (hv : Elliptic.AdmissibleTwist j v) (r : ℝ) : Set (Elliptic.Filling j v hv) :=
+  {y |
+    (Elliptic.fillingProjection j v hv y : ℂ) ≠ 0 ∧
+      ‖(Elliptic.fillingProjection j v hv y : ℂ)‖ < r}
+
+private abbrev
+    ThreefoldOverlapMappingTorus.Elliptic.PuncturedFilling (j : Elliptic.Kind) (v : Lattice)
+    (hv : Elliptic.AdmissibleTwist j v) (r : ℝ) :=
+  puncturedSet j v hv r
+
+private abbrev
+    ThreefoldOverlapMappingTorus.Elliptic.PuncturedUpstairs (j : Elliptic.Kind) (v : Lattice)
+    (hv : Elliptic.AdmissibleTwist j v) (r : ℝ) :=
+  Elliptic.fillingQuotient j v hv ⁻¹' puncturedSet j v hv r
+
+private theorem ThreefoldOverlapMappingTorus.Elliptic.puncturedUpstairs_mem (j : Elliptic.Kind)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (r : ℝ) (x : Elliptic.Family j) :
+    x ∈ PuncturedUpstairs j v hv r ↔ (x.1 : ℂ) ≠ 0 ∧ ‖(x.1 : ℂ)‖ ^ j.order < r := by
+  change ((x.1 : ℂ) ^ j.order ≠ 0 ∧ ‖(x.1 : ℂ) ^ j.order‖ < r) ↔ _
+  rw [norm_pow]
+  constructor
+  · rintro ⟨hne, hnorm⟩
+    exact ⟨fun hz => hne (by rw [hz, zero_pow j.order_pos.ne']), hnorm⟩
+  · rintro ⟨hne, hnorm⟩
+    exact ⟨pow_ne_zero _ hne, hnorm⟩
+
+private def
+    ThreefoldOverlapMappingTorus.Elliptic.upstairsRootHomeomorph (j : Elliptic.Kind) (v : Lattice)
+    (hv : Elliptic.AdmissibleTwist j v) (r : ℝ) :
+    PuncturedUpstairs j v hv r ≃ₜ ThreefoldOverlapMappingTorus.RootDisc j.order r × RealTorus₄
+    where
+  toFun y := (⟨y.val.1, (puncturedUpstairs_mem j v hv r y.val).mp y.property⟩, y.val.2)
+  invFun p := ⟨(p.1.val, p.2), (puncturedUpstairs_mem j v hv r (p.1.val, p.2)).mpr p.1.property⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun :=
+    ((continuous_fst.comp continuous_subtype_val).subtype_mk _).prodMk
+      (continuous_snd.comp continuous_subtype_val)
+  continuous_invFun :=
+    ((continuous_subtype_val.comp continuous_fst).prodMk continuous_snd).subtype_mk _
+
+private def ThreefoldOverlapMappingTorus.Elliptic.upstairsPolarHomeomorph (j : Elliptic.Kind)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (r : ℝ) :
+    PuncturedUpstairs j v hv r ≃ₜ
+      ThreefoldOverlapMappingTorus.Radius j.order r ×
+        (ThreefoldOverlapMappingTorus.Circle × RealTorus₄) :=
+  (upstairsRootHomeomorph j v hv r).trans
+    (((ThreefoldOverlapMappingTorus.polarHomeomorph j.order r).prodCongr
+          (Homeomorph.refl RealTorus₄)).trans
+      (Homeomorph.prodAssoc _ _ _))
+
+private def ThreefoldOverlapMappingTorus.Elliptic.polarQuotient (j : Elliptic.Kind) (v : Lattice)
+    (hv : Elliptic.AdmissibleTwist j v) (r : ℝ)
+    (p :
+      ThreefoldOverlapMappingTorus.Radius j.order r ×
+        (ThreefoldOverlapMappingTorus.Circle × RealTorus₄)) :
+    PuncturedFilling j v hv r :=
+  (puncturedSet j v hv r).restrictPreimage (Elliptic.fillingQuotient j v hv)
+    ((upstairsPolarHomeomorph j v hv r).symm p)
+
+private theorem
+    ThreefoldOverlapMappingTorus.Elliptic.polarQuotient_isOpenQuotientMap (j : Elliptic.Kind)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (r : ℝ) :
+    IsOpenQuotientMap (polarQuotient j v hv r) := by
+  have hq : IsOpenQuotientMap (Elliptic.fillingQuotient j v hv) :=
+    ⟨Elliptic.fillingQuotient_surjective j v hv, Elliptic.fillingQuotient_continuous j v hv,
+      (Elliptic.fillingQuotient_isCoveringMap j v hv).isOpenMap⟩
+  have hr := hq.restrictPreimage (puncturedSet j v hv r)
+  let e := (upstairsPolarHomeomorph j v hv r).symm
+  exact
+    ⟨hr.surjective.comp e.surjective, hr.continuous.comp e.continuous,
+      hr.isOpenMap.comp e.isOpenMap⟩
+
+@[simp]
+private theorem
+    ThreefoldOverlapMappingTorus.Elliptic.polarQuotient_projection_norm (j : Elliptic.Kind)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (r : ℝ)
+    (p :
+      ThreefoldOverlapMappingTorus.Radius j.order r ×
+        (ThreefoldOverlapMappingTorus.Circle × RealTorus₄)) :
+    ‖(Elliptic.fillingProjection j v hv (polarQuotient j v hv r p) : ℂ)‖ = (p.1 : ℝ) ^ j.order := by
+  change ‖(ThreefoldOverlapMappingTorus.root j.order r p.1 p.2.1 : ℂ) ^ j.order‖ = _
+  rw [norm_pow, ThreefoldOverlapMappingTorus.root_norm]
+
+private abbrev
+    ThreefoldOverlapMappingTorus.Elliptic.BoundaryQuotient (j : Elliptic.Kind) (v : Lattice)
+    (hv : Elliptic.AdmissibleTwist j v) :=
+  Elliptic.HigherHomology.MappingTorusQuotient.ProductQuotient j.order
+    (Elliptic.flatTorusAffine j v).symm (affine_symm_pow_order j v hv.1)
+
+private def ThreefoldOverlapMappingTorus.Elliptic.radialQuotient (j : Elliptic.Kind) (v : Lattice)
+    (hv : Elliptic.AdmissibleTwist j v) (r : ℝ)
+    (p :
+      ThreefoldOverlapMappingTorus.Radius j.order r ×
+        (ThreefoldOverlapMappingTorus.Circle × RealTorus₄)) :
+    ThreefoldOverlapMappingTorus.Radius j.order r × BoundaryQuotient j v hv :=
+  (p.1,
+    Elliptic.HigherHomology.MappingTorusQuotient.project j.order
+      (Elliptic.flatTorusAffine j v).symm (affine_symm_pow_order j v hv.1) p.2)
+
+private theorem
+    ThreefoldOverlapMappingTorus.Elliptic.radialQuotient_isOpenQuotientMap (j : Elliptic.Kind)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (r : ℝ) :
+    IsOpenQuotientMap (radialQuotient j v hv r) := by
+  let :=
+    Elliptic.HigherHomology.MappingTorusQuotient.productAction j.order
+      (Elliptic.flatTorusAffine j v).symm (affine_symm_pow_order j v hv.1)
+  let :=
+    Elliptic.HigherHomology.MappingTorusQuotient.productAction_continuousConstSMul j.order
+      (Elliptic.flatTorusAffine j v).symm (affine_symm_pow_order j v hv.1)
+  exact
+    IsOpenQuotientMap.id.prodMap
+      (Elliptic.FiniteQuotient.project_isOpenQuotientMap (Elliptic.CyclicGroup j)
+        (ThreefoldOverlapMappingTorus.Circle × RealTorus₄))
+
+private theorem ThreefoldOverlapMappingTorus.Elliptic.polarQuotient_eq_iff (j : Elliptic.Kind)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (r : ℝ)
+    (p q :
+      ThreefoldOverlapMappingTorus.Radius j.order r ×
+        (ThreefoldOverlapMappingTorus.Circle × RealTorus₄)) :
+    polarQuotient j v hv r p = polarQuotient j v hv r q ↔
+      radialQuotient j v hv r p = radialQuotient j v hv r q := by
+  let :=
+    Elliptic.HigherHomology.MappingTorusQuotient.productAction j.order
+      (Elliptic.flatTorusAffine j v).symm (affine_symm_pow_order j v hv.1)
+  let := Elliptic.familyAction j v hv.1
+  rcases p with ⟨a, p⟩
+  rcases q with ⟨b, q⟩
+  constructor
+  · intro h
+    have hpow :=
+      congrArg (fun y : PuncturedFilling j v hv r => ‖(Elliptic.fillingProjection j v hv y : ℂ)‖)
+        h
+    simp only [polarQuotient_projection_norm] at hpow
+    have hab : a = b :=
+      Subtype.ext ((pow_left_inj₀ a.property.1.le b.property.1.le j.order_pos.ne').mp hpow)
+    subst b
+    apply Prod.ext
+    · rfl
+    have hq :
+      Elliptic.fillingQuotient j v hv (polarFamilyAt j r a p) =
+        Elliptic.fillingQuotient j v hv (polarFamilyAt j r a q) :=
+      congrArg Subtype.val h
+    obtain ⟨g, hg⟩ :=
+      (Elliptic.FiniteQuotient.project_eq_iff_mem_orbit (Elliptic.CyclicGroup j)
+            (Elliptic.Family j) _ _).mp
+        hq
+    apply
+      (Elliptic.FiniteQuotient.project_eq_iff_mem_orbit (Elliptic.CyclicGroup j)
+          (ThreefoldOverlapMappingTorus.Circle × RealTorus₄) _ _).mpr
+    refine ⟨g⁻¹, (polarFamilyAt_injective j r a) ?_⟩
+    have he := polarFamilyAt_smul j v hv.1 r a g⁻¹ q
+    have he' : polarFamilyAt j r a (g⁻¹ • q) = g • polarFamilyAt j r a q := by
+      simpa only [inv_inv] using he
+    exact he'.trans hg
+  · intro h
+    have hab : a = b := congrArg Prod.fst h
+    subst b
+    have hp :
+      Elliptic.HigherHomology.MappingTorusQuotient.project j.order
+          (Elliptic.flatTorusAffine j v).symm (affine_symm_pow_order j v hv.1) p =
+        Elliptic.HigherHomology.MappingTorusQuotient.project j.order
+          (Elliptic.flatTorusAffine j v).symm (affine_symm_pow_order j v hv.1) q :=
+      congrArg Prod.snd h
+    obtain ⟨g, hg⟩ :=
+      (Elliptic.FiniteQuotient.project_eq_iff_mem_orbit (Elliptic.CyclicGroup j)
+            (ThreefoldOverlapMappingTorus.Circle × RealTorus₄) _ _).mp
+        hp
+    apply Subtype.ext
+    change
+      Elliptic.fillingQuotient j v hv (polarFamilyAt j r a p) =
+        Elliptic.fillingQuotient j v hv (polarFamilyAt j r a q)
+    rw [← hg, polarFamilyAt_smul j v hv.1]
+    exact Elliptic.FiniteQuotient.project_smul (Elliptic.CyclicGroup j) (Elliptic.Family j) g⁻¹ _
+
+private def ThreefoldOverlapMappingTorus.Elliptic.puncturedPolarHomeomorph (j : Elliptic.Kind)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (r : ℝ) :
+    PuncturedFilling j v hv r ≃ₜ
+      ThreefoldOverlapMappingTorus.Radius j.order r × BoundaryQuotient j v hv :=
+  ThreefoldOverlapMappingTorus.quotientHomeomorph (polarQuotient j v hv r)
+    (radialQuotient j v hv r) (polarQuotient_isOpenQuotientMap j v hv r).isQuotientMap
+    (radialQuotient_isOpenQuotientMap j v hv r).isQuotientMap (polarQuotient_eq_iff j v hv r)
+
+@[simp]
+private theorem ThreefoldOverlapMappingTorus.Elliptic.puncturedPolarHomeomorph_symm_radialQuotient
+    (j : Elliptic.Kind) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (r : ℝ)
+    (p :
+      ThreefoldOverlapMappingTorus.Radius j.order r ×
+        (ThreefoldOverlapMappingTorus.Circle × RealTorus₄)) :
+    (puncturedPolarHomeomorph j v hv r).symm (radialQuotient j v hv r p) =
+      polarQuotient j v hv r p :=
+  ThreefoldOverlapMappingTorus.quotientHomeomorph_symm_apply _ _ _ _ _ p
+
+private abbrev ThreefoldOverlapMappingTorus.Elliptic.Boundary (j : Elliptic.Kind) (v : Lattice) :=
+  MappingTorus.Torus (Elliptic.flatTorusAffine j v)
+
+private def ThreefoldOverlapMappingTorus.Elliptic.puncturedProductHomeomorph (j : Elliptic.Kind)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (r : ℝ) :
+    PuncturedFilling j v hv r ≃ₜ ThreefoldOverlapMappingTorus.Radius j.order r × Boundary j v :=
+  (puncturedPolarHomeomorph j v hv r).trans
+    ((Homeomorph.refl _).prodCongr
+      (Elliptic.HigherHomology.MappingTorusQuotient.mappingTorusHomeomorph j.order
+        (Elliptic.flatTorusAffine j v).symm (affine_symm_pow_order j v hv.1)))
+
+private theorem ThreefoldOverlapMappingTorus.Elliptic.puncturedProductHomeomorph_symm_mk
+    (j : Elliptic.Kind) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (r : ℝ)
+    (a : ThreefoldOverlapMappingTorus.Radius j.order r) (t : ℝ) (x : RealTorus₄) :
+    (puncturedProductHomeomorph j v hv r).symm
+        (a, MappingTorus.mk (Elliptic.flatTorusAffine j v) (t, x)) =
+      polarQuotient j v hv r
+        (a, (((t / j.order : ℝ) : ThreefoldOverlapMappingTorus.Circle), x)) := by
+  change
+    (puncturedPolarHomeomorph j v hv r).symm
+        (a,
+          (Elliptic.HigherHomology.MappingTorusQuotient.mappingTorusHomeomorph j.order
+                (Elliptic.flatTorusAffine j v).symm (affine_symm_pow_order j v hv.1)).symm
+            (MappingTorus.mk _ (t, x))) =
+      _
+  rw [Elliptic.HigherHomology.MappingTorusQuotient.mappingTorusHomeomorph_symm_mk]
+  exact
+    puncturedPolarHomeomorph_symm_radialQuotient j v hv r
+      (a, (((t / j.order : ℝ) : ThreefoldOverlapMappingTorus.Circle), x))
+
+private def
+    ThreefoldOverlapMappingTorus.Elliptic.puncturedMappingTorusHomotopyEquiv (j : Elliptic.Kind)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (r : ℝ)
+    (a : ThreefoldOverlapMappingTorus.Radius j.order r) :
+    PuncturedFilling j v hv r ≃ₕ Boundary j v :=
+  (puncturedProductHomeomorph j v hv r).toHomotopyEquiv.trans
+    (ThreefoldOverlapMappingTorus.radiusProductHomotopyEquiv a (Boundary j v))
+
+private def
+    ThreefoldOverlapMappingTorus.Elliptic.boundaryInclusion (j : Elliptic.Kind) (v : Lattice)
+    (hv : Elliptic.AdmissibleTwist j v) (r : ℝ)
+    (a : ThreefoldOverlapMappingTorus.Radius j.order r) :
+    C(Boundary j v, PuncturedFilling j v hv r) :=
+  ⟨(puncturedMappingTorusHomotopyEquiv j v hv r a).symm,
+    (puncturedMappingTorusHomotopyEquiv j v hv r a).symm.continuous⟩
+
+@[simp]
+private theorem ThreefoldOverlapMappingTorus.Elliptic.boundaryInclusion_mk (j : Elliptic.Kind)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (r : ℝ)
+    (a : ThreefoldOverlapMappingTorus.Radius j.order r) (t : ℝ) (x : RealTorus₄) :
+    boundaryInclusion j v hv r a (MappingTorus.mk (Elliptic.flatTorusAffine j v) (t, x)) =
+      polarQuotient j v hv r
+        (a, (((t / j.order : ℝ) : ThreefoldOverlapMappingTorus.Circle), x)) :=
+  puncturedProductHomeomorph_symm_mk j v hv r a t x
+
+private def FundamentalGroupVanKampen.TwoOpenCover.chartPath {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) (i : Bool) (x : D.chart i) :
+    Path (D.baseChart i) x :=
+  FundamentalGroupVanKampen.pathIn (D.pathTo x.val) (D.base_mem_chart i) x.property
+    (D.pathTo_mem i x.val x.property)
+
+@[simp]
+private theorem
+    FundamentalGroupVanKampen.TwoOpenCover.chartPath_base {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) (i : Bool) :
+    D.chartPath i (D.baseChart i) = Path.refl (D.baseChart i) := by
+  simp only [chartPath, baseChart, D.pathTo_base, FundamentalGroupVanKampen.pathIn_refl]
+
+private def FundamentalGroupVanKampen.TwoOpenCover.chartPathClass {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) (i : Bool) (x : D.chart i) :
+    Path.Homotopic.Quotient (D.baseChart i) x :=
+  Path.Homotopic.Quotient.mk (D.chartPath i x)
+
+@[simp]
+private theorem FundamentalGroupVanKampen.TwoOpenCover.chartPathClass_base {X : Type*}
+    [TopologicalSpace X] (D : FundamentalGroupVanKampen.TwoOpenCover X) (i : Bool) :
+    D.chartPathClass i (D.baseChart i) = Path.Homotopic.Quotient.refl (D.baseChart i) := by
+  simp only [chartPathClass, D.chartPath_base, Path.Homotopic.Quotient.mk_refl]
+
+private def FundamentalGroupVanKampen.TwoOpenCover.closePath {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) (i : Bool) {x y : D.chart i} (p : Path x y) :
+    FundamentalGroup (D.chart i) (D.baseChart i) :=
+  TriangleRegularBaseFundamentalGroup.basedLoop (D.chartPathClass i)
+    (Path.Homotopic.Quotient.mk p)
+
+@[simp]
+private theorem
+    FundamentalGroupVanKampen.TwoOpenCover.closePath_refl {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) (i : Bool) (x : D.chart i) :
+    D.closePath i (Path.refl x) = 1 :=
+  TriangleRegularBaseFundamentalGroup.basedLoop_refl _ _
+
+private theorem
+    FundamentalGroupVanKampen.TwoOpenCover.closePath_trans {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) (i : Bool) {x y z : D.chart i} (p : Path x y)
+    (q : Path y z) : D.closePath i (p.trans q) = D.closePath i q * D.closePath i p := by
+  exact
+    TriangleRegularBaseFundamentalGroup.basedLoop_trans (D.chartPathClass i)
+      (Path.Homotopic.Quotient.mk p) (Path.Homotopic.Quotient.mk q)
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.closePath_homotopic {X : Type*}
+    [TopologicalSpace X] (D : FundamentalGroupVanKampen.TwoOpenCover X) (i : Bool)
+    {x y : D.chart i} {p q : Path x y} (hpq : Path.Homotopic p q) :
+    D.closePath i p = D.closePath i q := by
+  unfold closePath
+  rw [Path.Homotopic.Quotient.eq.mpr hpq]
+
+private theorem
+    FundamentalGroupVanKampen.TwoOpenCover.closePath_loop {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) (i : Bool)
+    (p : Path (D.baseChart i) (D.baseChart i)) : D.closePath i p = Path.Homotopic.Quotient.mk p :=
+  by
+  simp only [closePath, TriangleRegularBaseFundamentalGroup.basedLoop, D.chartPathClass_base,
+    Path.Homotopic.Quotient.refl_trans]
+  exact Path.Homotopic.Quotient.trans_refl _
+
+private def
+    FundamentalGroupVanKampen.TwoOpenCover.chartHom {X : Type*} [TopologicalSpace X] {G : Type*}
+    [Group G] (D : FundamentalGroupVanKampen.TwoOpenCover X) (fU : D.UGroup →* G)
+    (fV : D.VGroup →* G) (i : Bool) : FundamentalGroup (D.chart i) (D.baseChart i) →* G := by
+  cases i
+  · exact fU
+  · exact fV
+
+private def
+    FundamentalGroupVanKampen.TwoOpenCover.localValue {X : Type*} [TopologicalSpace X] {G : Type*}
+    [Group G] (D : FundamentalGroupVanKampen.TwoOpenCover X) (fU : D.UGroup →* G)
+    (fV : D.VGroup →* G) (i : Bool) {x y : X} (p : Path x y) (hp : ∀ t, p t ∈ D.chart i) : G :=
+  (D.chartHom fU fV i
+      (D.closePath i
+        (FundamentalGroupVanKampen.pathIn (S := (D.chart i : Set X)) p (by simpa using hp 0)
+          (by simpa using hp 1) hp)))⁻¹
+
+private theorem
+    FundamentalGroupVanKampen.TwoOpenCover.localValue_refl {X : Type*} [TopologicalSpace X]
+    {G : Type*} [Group G] (D : FundamentalGroupVanKampen.TwoOpenCover X) (fU : D.UGroup →* G)
+    (fV : D.VGroup →* G) (i : Bool) (x : X) (hx : ∀ t, Path.refl x t ∈ D.chart i) :
+    D.localValue fU fV i (Path.refl x) hx = 1 := by
+  simp only [localValue, FundamentalGroupVanKampen.pathIn_refl, D.closePath_refl, map_one,
+    inv_one]
+
+private theorem
+    FundamentalGroupVanKampen.TwoOpenCover.localValue_trans {X : Type*} [TopologicalSpace X]
+    {G : Type*} [Group G] (D : FundamentalGroupVanKampen.TwoOpenCover X) (fU : D.UGroup →* G)
+    (fV : D.VGroup →* G) (i : Bool) {x y z : X} (p : Path x y) (q : Path y z)
+    (hp : ∀ t, p t ∈ D.chart i) (hq : ∀ t, q t ∈ D.chart i) (hpq : ∀ t, p.trans q t ∈ D.chart i) :
+    D.localValue fU fV i (p.trans q) hpq =
+      D.localValue fU fV i p hp * D.localValue fU fV i q hq := by
+  have hx : x ∈ D.chart i := by simpa using hp 0
+  have hy : y ∈ D.chart i := by simpa using hp 1
+  have hz : z ∈ D.chart i := by simpa using hq 1
+  unfold localValue
+  rw [FundamentalGroupVanKampen.pathIn_trans p q hx hy hz hp hq hpq, D.closePath_trans, map_mul,
+    mul_inv_rev]
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.localValue_subpath_mul {X : Type*}
+    [TopologicalSpace X] {G : Type*} [Group G] (D : FundamentalGroupVanKampen.TwoOpenCover X)
+    (fU : D.UGroup →* G) (fV : D.VGroup →* G) (i : Bool) {x y : X} (p : Path x y)
+    (a b c : (unitInterval)) (hab : a ≤ b) (hbc : b ≤ c) (hpab : ∀ t, p.subpath a b t ∈ D.chart i)
+    (hpbc : ∀ t, p.subpath b c t ∈ D.chart i) (hpac : ∀ t, p.subpath a c t ∈ D.chart i) :
+    D.localValue fU fV i (p.subpath a c) hpac =
+      D.localValue fU fV i (p.subpath a b) hpab * D.localValue fU fV i (p.subpath b c) hpbc := by
+  have ha : p a ∈ D.chart i := by simpa using hpab 0
+  have hb : p b ∈ D.chart i := by simpa using hpab 1
+  have hc : p c ∈ D.chart i := by simpa using hpbc 1
+  have H :=
+    FundamentalGroupVanKampen.subpathTransSubpathIn p a b c hab hbc ha hb hc hpab hpbc hpac
+  unfold localValue
+  rw [← D.closePath_homotopic i ⟨H⟩, D.closePath_trans, map_mul, mul_inv_rev]
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.localValue_homotopy {X : Type*}
+    [TopologicalSpace X] {G : Type*} [Group G] (D : FundamentalGroupVanKampen.TwoOpenCover X)
+    (fU : D.UGroup →* G) (fV : D.VGroup →* G) (i : Bool) {x y : X} (p q : Path x y)
+    (hp : ∀ t, p t ∈ D.chart i) (hq : ∀ t, q t ∈ D.chart i) (H : Path.Homotopy p q)
+    (hH : ∀ s, H s ∈ D.chart i) : D.localValue fU fV i p hp = D.localValue fU fV i q hq := by
+  have hx : x ∈ D.chart i := by simpa using hp 0
+  have hy : y ∈ D.chart i := by simpa using hp 1
+  unfold localValue
+  rw [D.closePath_homotopic i ⟨FundamentalGroupVanKampen.homotopyIn p q hx hy hp hq H hH⟩]
+
+private def FundamentalGroupVanKampen.TwoOpenCover.overlapPath {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) (x : D.overlap) : Path D.baseOverlapPoint x :=
+  FundamentalGroupVanKampen.pathIn (S := (D.overlap : Set X)) (D.pathTo x.val) ⟨D.baseU, D.baseV⟩
+    x.property
+    (fun t =>
+      ⟨D.pathTo_mem Bool.false x.val x.property.1 t, D.pathTo_mem Bool.true x.val x.property.2 t⟩)
+
+private theorem
+    FundamentalGroupVanKampen.TwoOpenCover.overlapPath_map_U {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) (x : D.overlap) :
+    (D.overlapPath x).map D.overlapToU.continuous = D.chartPath Bool.false (D.overlapToU x) := by
+  ext t
+  rfl
+
+private theorem
+    FundamentalGroupVanKampen.TwoOpenCover.overlapPath_map_V {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) (x : D.overlap) :
+    (D.overlapPath x).map D.overlapToV.continuous = D.chartPath Bool.true (D.overlapToV x) := by
+  ext t
+  rfl
+
+private def FundamentalGroupVanKampen.TwoOpenCover.overlapClose {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) {x y : D.overlap} (p : Path x y) :
+    D.OverlapGroup :=
+  TriangleRegularBaseFundamentalGroup.basedLoop
+    (fun x => Path.Homotopic.Quotient.mk (D.overlapPath x)) (Path.Homotopic.Quotient.mk p)
+
+private theorem
+    FundamentalGroupVanKampen.TwoOpenCover.overlapHomU_close {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) {x y : D.overlap} (p : Path x y) :
+    D.overlapHomU (D.overlapClose p) = D.closePath Bool.false (p.map D.overlapToU.continuous) := by
+  change
+    Path.Homotopic.Quotient.mk
+        ((((D.overlapPath x).trans p).trans (D.overlapPath y).symm).map D.overlapToU.continuous) =
+      Path.Homotopic.Quotient.mk
+        (((D.chartPath Bool.false (D.overlapToU x)).trans (p.map D.overlapToU.continuous)).trans
+          (D.chartPath Bool.false (D.overlapToU y)).symm)
+  rw [Path.map_trans, Path.map_trans, ← Path.map_symm, D.overlapPath_map_U, D.overlapPath_map_U]
+  rfl
+
+private theorem
+    FundamentalGroupVanKampen.TwoOpenCover.overlapHomV_close {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) {x y : D.overlap} (p : Path x y) :
+    D.overlapHomV (D.overlapClose p) = D.closePath Bool.true (p.map D.overlapToV.continuous) := by
+  change
+    Path.Homotopic.Quotient.mk
+        ((((D.overlapPath x).trans p).trans (D.overlapPath y).symm).map D.overlapToV.continuous) =
+      Path.Homotopic.Quotient.mk
+        (((D.chartPath Bool.true (D.overlapToV x)).trans (p.map D.overlapToV.continuous)).trans
+          (D.chartPath Bool.true (D.overlapToV y)).symm)
+  rw [Path.map_trans, Path.map_trans, ← Path.map_symm, D.overlapPath_map_V, D.overlapPath_map_V]
+  rfl
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.localValue_compatible_UV {X : Type*}
+    [TopologicalSpace X] {G : Type*} [Group G] (D : FundamentalGroupVanKampen.TwoOpenCover X)
+    (fU : D.UGroup →* G) (fV : D.VGroup →* G) (hf : D.Compatible fU fV) {x y : X} (p : Path x y)
+    (hU : ∀ t, p t ∈ D.U) (hV : ∀ t, p t ∈ D.V) :
+    D.localValue fU fV Bool.false p hU = D.localValue fU fV Bool.true p hV := by
+  have hxU : x ∈ D.U := by simpa using hU 0
+  have hxV : x ∈ D.V := by simpa using hV 0
+  have hyU : y ∈ D.U := by simpa using hU 1
+  have hyV : y ∈ D.V := by simpa using hV 1
+  let pI :=
+    FundamentalGroupVanKampen.pathIn (S := (D.overlap : Set X)) p ⟨hxU, hxV⟩ ⟨hyU, hyV⟩
+      (fun t => ⟨hU t, hV t⟩)
+  have hpU : pI.map D.overlapToU.continuous = FundamentalGroupVanKampen.pathIn p hxU hyU hU := by
+    ext t
+    rfl
+  have hpV : pI.map D.overlapToV.continuous = FundamentalGroupVanKampen.pathIn p hxV hyV hV := by
+    ext t
+    rfl
+  have h := DFunLike.congr_fun hf (D.overlapClose pI)
+  change fU (D.overlapHomU (D.overlapClose pI)) = fV (D.overlapHomV (D.overlapClose pI)) at h
+  have hU' := congrArg fU ((D.overlapHomU_close pI).trans (congrArg (D.closePath Bool.false) hpU))
+  have hV' := congrArg fV ((D.overlapHomV_close pI).trans (congrArg (D.closePath Bool.true) hpV))
+  exact congrArg (fun a : G => a⁻¹) (hU'.symm.trans (h.trans hV'))
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.localValue_compatible {X : Type*}
+    [TopologicalSpace X] {G : Type*} [Group G] (D : FundamentalGroupVanKampen.TwoOpenCover X)
+    (fU : D.UGroup →* G) (fV : D.VGroup →* G) (hf : D.Compatible fU fV) (i j : Bool) {x y : X}
+    (p : Path x y) (hi : ∀ t, p t ∈ D.chart i) (hj : ∀ t, p t ∈ D.chart j) :
+    D.localValue fU fV i p hi = D.localValue fU fV j p hj := by
+  cases i <;> cases j
+  · rfl
+  · exact D.localValue_compatible_UV fU fV hf p hi hj
+  · exact (D.localValue_compatible_UV fU fV hf p hj hi).symm
+  · rfl
+
+private def FundamentalGroupVanKampen.TwoOpenCover.localPathValue {X : Type*} [TopologicalSpace X]
+    {G : Type*} [Group G] (D : FundamentalGroupVanKampen.TwoOpenCover X) (fU : D.UGroup →* G)
+    (fV : D.VGroup →* G) (hf : D.Compatible fU fV) :
+    FundamentalGroupVanKampen.LocalPathValue (fun i => (D.chart i : Set X)) G
+    where
+  value := D.localValue fU fV
+  refl := D.localValue_refl fU fV
+  trans := D.localValue_trans fU fV
+  subpath_mul := D.localValue_subpath_mul fU fV
+  compatible := D.localValue_compatible fU fV hf
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.localPathValue_homotopyInvariant {X : Type*}
+    [TopologicalSpace X] {G : Type*} [Group G] (D : FundamentalGroupVanKampen.TwoOpenCover X)
+    (fU : D.UGroup →* G) (fV : D.VGroup →* G) (hf : D.Compatible fU fV) :
+    (D.localPathValue fU fV hf).HomotopyInvariant :=
+  D.localValue_homotopy fU fV
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.localValue_map_loop {X : Type*}
+    [TopologicalSpace X] {G : Type*} [Group G] (D : FundamentalGroupVanKampen.TwoOpenCover X)
+    (fU : D.UGroup →* G) (fV : D.VGroup →* G) (i : Bool)
+    (p : Path (D.baseChart i) (D.baseChart i)) :
+    D.localValue fU fV i (p.map continuous_subtype_val) (fun t => (p t).property) =
+      (D.chartHom fU fV i (Path.Homotopic.Quotient.mk p))⁻¹ := by
+  unfold localValue
+  apply
+    congrArg (fun a : FundamentalGroup (D.chart i) (D.baseChart i) => (D.chartHom fU fV i a)⁻¹)
+  rw [D.closePath_loop]
+  apply congrArg Path.Homotopic.Quotient.mk
+  ext t
+  rfl
+
+private def FundamentalGroupVanKampen.PathValue.fundamentalGroupHom {X : Type*} [TopologicalSpace X]
+    {G : Type*} [Group G] (V : FundamentalGroupVanKampen.PathValue X G) (hV : V.HomotopyInvariant)
+    (o : X) : FundamentalGroup X o →* G
+    where
+  toFun :=
+    _root_.Quotient.lift (fun p : Path o o => (V.value p)⁻¹)
+      (fun p q h => congrArg (fun a : G => a⁻¹) (hV p q h))
+  map_one' := by
+    change (V.value (Path.refl o))⁻¹ = 1
+    rw [V.refl, inv_one]
+  map_mul' := by
+    intro a b
+    obtain ⟨p⟩ := a
+    obtain ⟨q⟩ := b
+    change (V.value (q.trans p))⁻¹ = (V.value p)⁻¹ * (V.value q)⁻¹
+    rw [V.trans, mul_inv_rev]
+
+private theorem
+    FundamentalGroupVanKampen.mem_of_subpath_mem {X : Type*} [TopologicalSpace X] {x y : X}
+    (p : Path x y) {a b : (unitInterval)} (hab : a ≤ b) {s : Set X}
+    (hp : ∀ t, p.subpath a b t ∈ s) {t : (unitInterval)} (ht : t ∈ Set.Icc a b) : p t ∈ s := by
+  have hsub : Set.range (p.subpath a b) ⊆ s := Set.range_subset_iff.mpr hp
+  rw [p.range_subpath_of_le a b hab] at hsub
+  exact hsub ⟨t, ht, rfl⟩
+
+private theorem
+    FundamentalGroupVanKampen.subpath_mem_mono {X : Type*} [TopologicalSpace X] {x y : X}
+    (p : Path x y) {a b c d : (unitInterval)} (hab : a ≤ b) (hcd : c ≤ d) (hac : a ≤ c)
+    (hdb : d ≤ b) {s : Set X} (hp : ∀ t, p.subpath a b t ∈ s) : ∀ t, p.subpath c d t ∈ s := by
+  apply subpath_mem_of_mem_Icc p hcd
+  intro t ht
+  exact mem_of_subpath_mem p hab hp ⟨hac.trans ht.1, ht.2.trans hdb⟩
+
+private theorem FundamentalGroupVanKampen.exists_path_subdivision {X : Type*} [TopologicalSpace X]
+    {ι : Type*} {U : ι → Set X} (hopen : ∀ i, IsOpen (U i)) (hcover : (⋃ i, U i) = Set.univ)
+    {x y : X} (p : Path x y) :
+    ∃ t : ℕ → (unitInterval),
+      t 0 = 0 ∧
+        Monotone t ∧ (∃ n, t n = 1) ∧ ∀ n, ∃ i, ∀ s ∈ Set.Icc (t n) (t (n + 1)), p s ∈ U i := by
+  obtain ⟨t, ht0, hmono, ⟨n, hn⟩, hsub⟩ :=
+    exists_monotone_Icc_subset_open_cover_unitInterval (fun i ↦ (hopen i).preimage p.continuous)
+      (by
+        intro s _
+        have hs : p s ∈ ⋃ i, U i := by rw [hcover]; trivial
+        obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hs
+        exact Set.mem_iUnion.mpr ⟨i, hi⟩)
+  exact ⟨t, ht0, hmono, ⟨n, hn n le_rfl⟩, fun n ↦ hsub n⟩
+
+private def FundamentalGroupVanKampen.LocalPathValue.IsPrimitive {X : Type*} [TopologicalSpace X]
+    {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) {x y : X} (p : Path x y)
+    (F : (unitInterval) → G) : Prop :=
+  ∀ (a b : (unitInterval)),
+    a ≤ b → ∀ i (h : ∀ t, p.subpath a b t ∈ U i), F b = F a * L.value i (p.subpath a b) h
+
+private def
+    FundamentalGroupVanKampen.LocalPathValue.IsPrimitiveUpTo {X : Type*} [TopologicalSpace X]
+    {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) {x y : X} (p : Path x y)
+    (F : (unitInterval) → G) (r : (unitInterval)) : Prop :=
+  ∀ (a b : (unitInterval)),
+    a ≤ b → b ≤ r → ∀ i (h : ∀ t, p.subpath a b t ∈ U i), F b = F a * L.value i (p.subpath a b) h
+
+private theorem FundamentalGroupVanKampen.LocalPathValue.isPrimitiveUpTo_zero {X : Type*}
+    [TopologicalSpace X] {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) {x y : X} (p : Path x y) :
+    L.IsPrimitiveUpTo p (fun _ ↦ 1) 0 := by
+  intro a b hab hb i hi
+  have ha0 : a = 0 := le_antisymm (hab.trans hb) bot_le
+  have hb0 : b = 0 := le_antisymm hb bot_le
+  subst a
+  subst b
+  simp only [Path.subpath_self, L.refl, mul_one]
+
+private theorem FundamentalGroupVanKampen.LocalPathValue.exists_primitiveUpTo_step {X : Type*}
+    [TopologicalSpace X] {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) {x y : X} (p : Path x y)
+    {F : (unitInterval) → G} {a b : (unitInterval)} (_hab : a ≤ b) (i : ι)
+    (hi : ∀ t ∈ Set.Icc a b, p t ∈ U i) (hF : L.IsPrimitiveUpTo p F a) :
+    ∃ H : (unitInterval) → G, H 0 = F 0 ∧ L.IsPrimitiveUpTo p H b := by
+  classical
+  let memi (s t : (unitInterval)) (has : a ≤ s) (hst : s ≤ t) (htb : t ≤ b) :
+    ∀ u, p.subpath s t u ∈ U i :=
+    FundamentalGroupVanKampen.subpath_mem_of_mem_Icc p hst
+      (fun u hu ↦ hi u ⟨has.trans hu.1, hu.2.trans htb⟩)
+  let H (t : (unitInterval)) : G :=
+    if hta : t ≤ a then F t
+    else
+      if htb : t ≤ b then F a * L.value i (p.subpath a t) (memi a t le_rfl (le_of_not_ge hta) htb)
+      else 1
+  have hleft (t : (unitInterval)) (hta : t ≤ a) : H t = F t := by exact dite_eq_left hta
+  have hright (t : (unitInterval)) (hat : a ≤ t) (htb : t ≤ b) :
+    H t = F a * L.value i (p.subpath a t) (memi a t le_rfl hat htb) := by
+    by_cases hta : t ≤ a
+    · have ht : t = a := le_antisymm hta hat
+      subst t
+      rw [hleft a le_rfl]
+      simp only [Path.subpath_self, L.refl, mul_one]
+    · dsimp only [H]
+      rw [dite_eq_right hta, dite_eq_left htb]
+  refine ⟨H, hleft 0 bot_le, ?_⟩
+  intro s t hst htb j hj
+  by_cases hta : t ≤ a
+  · rw [hleft t hta, hleft s (hst.trans hta)]
+    exact hF s t hst hta j hj
+  have hat : a ≤ t := le_of_not_ge hta
+  by_cases hsa : s ≤ a
+  · have hjsa : ∀ u, p.subpath s a u ∈ U j :=
+      FundamentalGroupVanKampen.subpath_mem_mono p hst hsa le_rfl hat hj
+    have hjat : ∀ u, p.subpath a t u ∈ U j :=
+      FundamentalGroupVanKampen.subpath_mem_mono p hst hat hsa le_rfl hj
+    calc
+      H t = F a * L.value i (p.subpath a t) (memi a t le_rfl hat htb) := hright t hat htb
+      _ = F a * L.value j (p.subpath a t) hjat := by rw [L.compatible i j (p.subpath a t) _ hjat]
+      _ = (F s * L.value j (p.subpath s a) hjsa) * L.value j (p.subpath a t) hjat := by
+        rw [hF s a hsa le_rfl j hjsa]
+      _ = F s * L.value j (p.subpath s t) hj := by
+        rw [L.subpath_mul j p s a t hsa hat hjsa hjat hj, mul_assoc]
+      _ = H s * L.value j (p.subpath s t) hj := by rw [hleft s hsa]
+  · have has : a ≤ s := le_of_not_ge hsa
+    rw [hright t hat htb, hright s has (hst.trans htb)]
+    rw [L.compatible j i (p.subpath s t) hj (memi s t has hst htb)]
+    rw [L.subpath_mul i p a s t has hst (memi a s le_rfl has (hst.trans htb))
+        (memi s t has hst htb) (memi a t le_rfl hat htb)]
+    exact (mul_assoc _ _ _).symm
+
+private theorem
+    FundamentalGroupVanKampen.LocalPathValue.exists_primitive {X : Type*} [TopologicalSpace X]
+    {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) (hopen : ∀ i, IsOpen (U i))
+    (hcover : (⋃ i, U i) = Set.univ) {x y : X} (p : Path x y) :
+    ∃ F : (unitInterval) → G, F 0 = 1 ∧ L.IsPrimitive p F := by
+  obtain ⟨t, ht0, hmono, ⟨n, hn⟩, hsub⟩ :=
+    FundamentalGroupVanKampen.exists_path_subdivision hopen hcover p
+  have hprefix : ∀ m, ∃ F : (unitInterval) → G, F 0 = 1 ∧ L.IsPrimitiveUpTo p F (t m) := by
+    intro m
+    induction m with
+    | zero =>
+      refine ⟨fun _ ↦ 1, rfl, ?_⟩
+      rw [ht0]
+      exact L.isPrimitiveUpTo_zero p
+    | succ m ih =>
+      obtain ⟨F, hF0, hF⟩ := ih
+      obtain ⟨i, hi⟩ := hsub m
+      obtain ⟨H, hH0, hH⟩ := L.exists_primitiveUpTo_step p (hmono m.le_succ) i hi hF
+      exact ⟨H, hH0.trans hF0, hH⟩
+  obtain ⟨F, hF0, hF⟩ := hprefix n
+  refine ⟨F, hF0, ?_⟩
+  intro a b hab i hi
+  exact hF a b hab (by rw [hn]; exact le_top) i hi
+
+private theorem
+    FundamentalGroupVanKampen.LocalPathValue.primitive_unique {X : Type*} [TopologicalSpace X]
+    {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) (hopen : ∀ i, IsOpen (U i))
+    (hcover : (⋃ i, U i) = Set.univ) {x y : X} (p : Path x y) {F H : (unitInterval) → G}
+    (hF : L.IsPrimitive p F) (hH : L.IsPrimitive p H) (h0 : F 0 = H 0) : F = H := by
+  obtain ⟨t, ht0, hmono, ⟨n, hn⟩, hsub⟩ :=
+    FundamentalGroupVanKampen.exists_path_subdivision hopen hcover p
+  have hprefix : ∀ m, ∀ s ≤ t m, F s = H s := by
+    intro m
+    induction m with
+    | zero =>
+      intro s hs
+      have hs0 : s = 0 := le_antisymm (by simpa only [ht0] using hs) bot_le
+      simpa only [hs0] using h0
+    | succ m ih =>
+      intro s hs
+      by_cases hst : s ≤ t m
+      · exact ih s hst
+      have hts : t m ≤ s := le_of_not_ge hst
+      obtain ⟨i, hi⟩ := hsub m
+      have hlocal : ∀ u, p.subpath (t m) s u ∈ U i :=
+        FundamentalGroupVanKampen.subpath_mem_of_mem_Icc p hts
+          (fun u hu ↦ hi u ⟨hu.1, hu.2.trans hs⟩)
+      rw [hF (t m) s hts i hlocal, hH (t m) s hts i hlocal, ih (t m) le_rfl]
+  funext s
+  exact hprefix n s (by rw [hn]; exact le_top)
+
+private theorem FundamentalGroupVanKampen.convexComb_monotone {a b : (unitInterval)} (hab : a ≤ b) :
+    Monotone (Set.Icc.convexComb a b) := by
+  intro s t hst
+  change (1 - (s : ℝ)) * a + s * b ≤ (1 - (t : ℝ)) * a + t * b
+  have hab' : (a : ℝ) ≤ b := hab
+  have hst' : (s : ℝ) ≤ t := hst
+  nlinarith [mul_nonneg (sub_nonneg.mpr hab') (sub_nonneg.mpr hst')]
+
+private theorem FundamentalGroupVanKampen.convexComb_comp (a b s t u : (unitInterval)) :
+    Set.Icc.convexComb a b (Set.Icc.convexComb s t u) =
+      Set.Icc.convexComb (Set.Icc.convexComb a b s) (Set.Icc.convexComb a b t) u := by
+  apply Subtype.ext
+  simp only [Set.Icc.coe_convexComb]
+  ring
+
+private theorem FundamentalGroupVanKampen.subpath_subpath {X : Type*} [TopologicalSpace X] {x y : X}
+    (p : Path x y) (a b s t : (unitInterval)) :
+    (p.subpath a b).subpath s t =
+      p.subpath (Set.Icc.convexComb a b s) (Set.Icc.convexComb a b t) := by
+  ext u
+  change
+    p (Set.Icc.convexComb a b (Set.Icc.convexComb s t u)) =
+      p (Set.Icc.convexComb (Set.Icc.convexComb a b s) (Set.Icc.convexComb a b t) u)
+  rw [convexComb_comp]
+
+private def FundamentalGroupVanKampen.intervalHalf : (unitInterval) :=
+  ⟨1 / 2, by norm_num⟩
+
+private theorem
+    FundamentalGroupVanKampen.trans_convexComb_first_half {X : Type*} [TopologicalSpace X]
+    {x y z : X} (p : Path x y) (q : Path y z) (t : (unitInterval)) :
+    (p.trans q) (Set.Icc.convexComb 0 intervalHalf t) = p t := by
+  have ht : (Set.Icc.convexComb 0 intervalHalf t : ℝ) ≤ 1 / 2 := by
+    change (1 - (t : ℝ)) * 0 + t * (1 / 2) ≤ 1 / 2
+    linarith [t.2.2]
+  rw [← Path.extend_apply (p.trans q), Path.extend_trans_of_le_half p q ht]
+  have heq : 2 * (Set.Icc.convexComb 0 intervalHalf t : ℝ) = t := by
+    change 2 * ((1 - (t : ℝ)) * 0 + t * (1 / 2)) = t
+    ring
+  rw [heq, Path.extend_apply]
+
+private theorem
+    FundamentalGroupVanKampen.trans_convexComb_second_half {X : Type*} [TopologicalSpace X]
+    {x y z : X} (p : Path x y) (q : Path y z) (t : (unitInterval)) :
+    (p.trans q) (Set.Icc.convexComb intervalHalf 1 t) = q t := by
+  have ht : 1 / 2 ≤ (Set.Icc.convexComb intervalHalf 1 t : ℝ) := by
+    change 1 / 2 ≤ (1 - (t : ℝ)) * (1 / 2) + t * 1
+    linarith [t.2.1]
+  rw [← Path.extend_apply (p.trans q), Path.extend_trans_of_half_le p q ht]
+  have heq : 2 * (Set.Icc.convexComb intervalHalf 1 t : ℝ) - 1 = t := by
+    change 2 * ((1 - (t : ℝ)) * (1 / 2) + t * 1) - 1 = t
+    ring
+  rw [heq, Path.extend_apply]
+
+@[simp]
+private theorem FundamentalGroupVanKampen.trans_apply_intervalHalf {X : Type*} [TopologicalSpace X]
+    {x y z : X} (p : Path x y) (q : Path y z) : (p.trans q) intervalHalf = y := by
+  simpa using trans_convexComb_first_half p q 1
+
+private theorem FundamentalGroupVanKampen.trans_subpath_first_half {X : Type*} [TopologicalSpace X]
+    {x y z : X} (p : Path x y) (q : Path y z) :
+    (p.trans q).subpath 0 intervalHalf =
+      p.cast (p.trans q).source (trans_apply_intervalHalf p q) := by
+  ext t
+  exact trans_convexComb_first_half p q t
+
+private theorem FundamentalGroupVanKampen.trans_subpath_second_half {X : Type*} [TopologicalSpace X]
+    {x y z : X} (p : Path x y) (q : Path y z) :
+    (p.trans q).subpath intervalHalf 1 =
+      q.cast (trans_apply_intervalHalf p q) (p.trans q).target := by
+  ext t
+  exact trans_convexComb_second_half p q t
+
+private theorem FundamentalGroupVanKampen.LocalPathValue.value_eq_of_path_eq {X : Type*}
+    [TopologicalSpace X] {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) (i : ι) {x y : X} {p q : Path x y}
+    (h : p = q) (hp : ∀ t, p t ∈ U i) (hq : ∀ t, q t ∈ U i) : L.value i p hp = L.value i q hq := by
+  cases h
+  rfl
+
+private theorem FundamentalGroupVanKampen.LocalPathValue.isPrimitive_subpath {X : Type*}
+    [TopologicalSpace X] {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) {x y : X} (p : Path x y)
+    {F : (unitInterval) → G} (hF : L.IsPrimitive p F) (a b : (unitInterval)) (hab : a ≤ b) :
+    L.IsPrimitive (p.subpath a b) (fun t => (F a)⁻¹ * F (Set.Icc.convexComb a b t)) := by
+  intro s t hst i hi
+  have heq := FundamentalGroupVanKampen.subpath_subpath p a b s t
+  have hlocal : ∀ v, p.subpath (Set.Icc.convexComb a b s) (Set.Icc.convexComb a b t) v ∈ U i := by
+    intro v
+    rw [← heq]
+    exact hi v
+  have hv := L.value_eq_of_path_eq i heq hi hlocal
+  have hstep :=
+    hF (Set.Icc.convexComb a b s) (Set.Icc.convexComb a b t)
+      (FundamentalGroupVanKampen.convexComb_monotone hab hst) i hlocal
+  change
+    (F a)⁻¹ * F (Set.Icc.convexComb a b t) =
+      ((F a)⁻¹ * F (Set.Icc.convexComb a b s)) * L.value i ((p.subpath a b).subpath s t) hi
+  rw [hv, hstep, mul_assoc]
+  rfl
+
+private def FundamentalGroupVanKampen.LocalPathValue.transport {X : Type*} [TopologicalSpace X]
+    {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) (hopen : ∀ i, IsOpen (U i))
+    (hcover : (⋃ i, U i) = Set.univ) {x y : X} (p : Path x y) : (unitInterval) → G :=
+  (L.exists_primitive hopen hcover p).choose
+
+@[simp]
+private theorem
+    FundamentalGroupVanKampen.LocalPathValue.transport_zero {X : Type*} [TopologicalSpace X]
+    {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) (hopen : ∀ i, IsOpen (U i))
+    (hcover : (⋃ i, U i) = Set.univ) {x y : X} (p : Path x y) :
+    L.transport hopen hcover p 0 = 1 :=
+  (L.exists_primitive hopen hcover p).choose_spec.1
+
+private theorem FundamentalGroupVanKampen.LocalPathValue.transport_isPrimitive {X : Type*}
+    [TopologicalSpace X] {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) (hopen : ∀ i, IsOpen (U i))
+    (hcover : (⋃ i, U i) = Set.univ) {x y : X} (p : Path x y) :
+    L.IsPrimitive p (L.transport hopen hcover p) :=
+  (L.exists_primitive hopen hcover p).choose_spec.2
+
+private theorem FundamentalGroupVanKampen.LocalPathValue.transport_subpath {X : Type*}
+    [TopologicalSpace X] {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) (hopen : ∀ i, IsOpen (U i))
+    (hcover : (⋃ i, U i) = Set.univ) {x y : X} (p : Path x y) (a b : (unitInterval)) (hab : a ≤ b)
+    (t : (unitInterval)) :
+    L.transport hopen hcover (p.subpath a b) t =
+      (L.transport hopen hcover p a)⁻¹ * L.transport hopen hcover p (Set.Icc.convexComb a b t) := by
+  apply
+    congrFun
+      (L.primitive_unique hopen hcover (p.subpath a b)
+        (L.transport_isPrimitive hopen hcover (p.subpath a b))
+        (L.isPrimitive_subpath p (L.transport_isPrimitive hopen hcover p) a b hab) ?_)
+      t
+  simp only [transport_zero, Set.Icc.convexComb_zero, inv_mul_cancel]
+
+private def
+    FundamentalGroupVanKampen.LocalPathValue.rawValue {X : Type*} [TopologicalSpace X] {ι : Type*}
+    {G : Type*} [Group G] {U : ι → Set X} (L : FundamentalGroupVanKampen.LocalPathValue U G)
+    (hopen : ∀ i, IsOpen (U i)) (hcover : (⋃ i, U i) = Set.univ) {x y : X} (p : Path x y) : G :=
+  L.transport hopen hcover p 1
+
+private theorem
+    FundamentalGroupVanKampen.LocalPathValue.rawValue_cast {X : Type*} [TopologicalSpace X]
+    {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) (hopen : ∀ i, IsOpen (U i))
+    (hcover : (⋃ i, U i) = Set.univ) {x y x' y' : X} (p : Path x y) (hx : x' = x) (hy : y' = y) :
+    L.rawValue hopen hcover (p.cast hx hy) = L.rawValue hopen hcover p := by
+  cases hx
+  cases hy
+  rfl
+
+private theorem FundamentalGroupVanKampen.LocalPathValue.rawValue_subpath_zero_one {X : Type*}
+    [TopologicalSpace X] {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) (hopen : ∀ i, IsOpen (U i))
+    (hcover : (⋃ i, U i) = Set.univ) {x y : X} (p : Path x y) :
+    L.rawValue hopen hcover (p.subpath 0 1) = L.rawValue hopen hcover p := by
+  rw [Path.subpath_zero_one, L.rawValue_cast]
+
+private theorem
+    FundamentalGroupVanKampen.LocalPathValue.rawValue_subpath {X : Type*} [TopologicalSpace X]
+    {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) (hopen : ∀ i, IsOpen (U i))
+    (hcover : (⋃ i, U i) = Set.univ) {x y : X} (p : Path x y) (a b : (unitInterval))
+    (hab : a ≤ b) :
+    L.rawValue hopen hcover (p.subpath a b) =
+      (L.transport hopen hcover p a)⁻¹ * L.transport hopen hcover p b := by
+  simpa only [rawValue, Set.Icc.convexComb_one] using L.transport_subpath hopen hcover p a b hab 1
+
+private theorem
+    FundamentalGroupVanKampen.LocalPathValue.rawValue_local {X : Type*} [TopologicalSpace X]
+    {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) (hopen : ∀ i, IsOpen (U i))
+    (hcover : (⋃ i, U i) = Set.univ) (i : ι) {x y : X} (p : Path x y) (hp : ∀ t, p t ∈ U i) :
+    L.rawValue hopen hcover p = L.value i p hp := by
+  have hs : ∀ t, p.subpath 0 1 t ∈ U i := fun t => hp _
+  have h := L.transport_isPrimitive hopen hcover p 0 1 (by exact zero_le_one) i hs
+  rw [L.transport_zero, one_mul] at h
+  change L.rawValue hopen hcover p = _ at h
+  have hc : ∀ t, p.cast p.source p.target t ∈ U i := hp
+  exact
+    h.trans
+      ((L.value_eq_of_path_eq i (Path.subpath_zero_one p) hs hc).trans
+        (L.value_cast i p p.source p.target hp hc))
+
+private theorem
+    FundamentalGroupVanKampen.LocalPathValue.rawValue_refl {X : Type*} [TopologicalSpace X]
+    {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) (hopen : ∀ i, IsOpen (U i))
+    (hcover : (⋃ i, U i) = Set.univ) (x : X) : L.rawValue hopen hcover (Path.refl x) = 1 := by
+  have hx : x ∈ ⋃ i, U i := by rw [hcover]; trivial
+  obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hx
+  have hp : ∀ t, Path.refl x t ∈ U i := fun _ => hi
+  rw [L.rawValue_local hopen hcover i (Path.refl x) hp, L.refl]
+
+private theorem FundamentalGroupVanKampen.LocalPathValue.rawValue_subpath_mul {X : Type*}
+    [TopologicalSpace X] {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) (hopen : ∀ i, IsOpen (U i))
+    (hcover : (⋃ i, U i) = Set.univ) {x y : X} (p : Path x y) (a b c : (unitInterval))
+    (hab : a ≤ b) (hbc : b ≤ c) :
+    L.rawValue hopen hcover (p.subpath a c) =
+      L.rawValue hopen hcover (p.subpath a b) * L.rawValue hopen hcover (p.subpath b c) := by
+  rw [L.rawValue_subpath hopen hcover p a c (hab.trans hbc),
+    L.rawValue_subpath hopen hcover p a b hab, L.rawValue_subpath hopen hcover p b c hbc,
+    mul_assoc, mul_inv_cancel_left]
+
+private theorem
+    FundamentalGroupVanKampen.LocalPathValue.rawValue_trans {X : Type*} [TopologicalSpace X]
+    {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) (hopen : ∀ i, IsOpen (U i))
+    (hcover : (⋃ i, U i) = Set.univ) {x y z : X} (p : Path x y) (q : Path y z) :
+    L.rawValue hopen hcover (p.trans q) = L.rawValue hopen hcover p * L.rawValue hopen hcover q :=
+  by
+  calc
+    L.rawValue hopen hcover (p.trans q) = L.rawValue hopen hcover ((p.trans q).subpath 0 1) :=
+      (L.rawValue_subpath_zero_one hopen hcover (p.trans q)).symm
+    _ =
+        L.rawValue hopen hcover ((p.trans q).subpath 0 FundamentalGroupVanKampen.intervalHalf) *
+          L.rawValue hopen hcover
+            ((p.trans q).subpath FundamentalGroupVanKampen.intervalHalf 1) :=
+      (L.rawValue_subpath_mul hopen hcover (p.trans q) 0 FundamentalGroupVanKampen.intervalHalf 1
+        unitInterval.nonneg' unitInterval.le_one')
+    _ = L.rawValue hopen hcover p * L.rawValue hopen hcover q := by
+      rw [FundamentalGroupVanKampen.trans_subpath_first_half,
+        FundamentalGroupVanKampen.trans_subpath_second_half, L.rawValue_cast, L.rawValue_cast]
+
+private def FundamentalGroupVanKampen.LocalPathValue.extension {X : Type*} [TopologicalSpace X]
+    {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) (hopen : ∀ i, IsOpen (U i))
+    (hcover : (⋃ i, U i) = Set.univ) : FundamentalGroupVanKampen.PathValue X G
+    where
+  value := L.rawValue hopen hcover
+  refl := L.rawValue_refl hopen hcover
+  trans := L.rawValue_trans hopen hcover
+  subpath_mul := L.rawValue_subpath_mul hopen hcover
+
+private theorem FundamentalGroupVanKampen.LocalPathValue.extension_extends {X : Type*}
+    [TopologicalSpace X] {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) (hopen : ∀ i, IsOpen (U i))
+    (hcover : (⋃ i, U i) = Set.univ) : (L.extension hopen hcover).Extends L := by
+  intro i x y p hp
+  exact L.rawValue_local hopen hcover i p hp
+
+private def FundamentalGroupVanKampen.squareHorizontal {X : Type*} [TopologicalSpace X]
+    (F : C((unitInterval) × (unitInterval), X)) (s : (unitInterval)) : Path (F (s, 0)) (F (s, 1))
+    where
+  toFun t := F (s, t)
+  continuous_toFun := F.continuous.comp (continuous_const.prodMk continuous_id)
+  source' := rfl
+  target' := rfl
+
+private def FundamentalGroupVanKampen.squareVertical {X : Type*} [TopologicalSpace X]
+    (F : C((unitInterval) × (unitInterval), X)) (t : (unitInterval)) : Path (F (0, t)) (F (1, t))
+    where
+  toFun s := F (s, t)
+  continuous_toFun := F.continuous.comp (continuous_id.prodMk continuous_const)
+  source' := rfl
+  target' := rfl
+
+private def FundamentalGroupVanKampen.squarePathHomotopy {x y : (unitInterval) × (unitInterval)}
+    (p q : Path x y) : Path.Homotopy p q
+    where
+  toFun
+    u := (Set.Icc.convexComb (p u.2).1 (q u.2).1 u.1, Set.Icc.convexComb (p u.2).2 (q u.2).2 u.1)
+  continuous_toFun := by
+    apply Continuous.prodMk
+    · exact
+        Set.Icc.continuous_convexComb_prod.comp
+          (((p.continuous.comp continuous_snd).fst).prodMk
+            (((q.continuous.comp continuous_snd).fst).prodMk continuous_fst))
+    · exact
+        Set.Icc.continuous_convexComb_prod.comp
+          (((p.continuous.comp continuous_snd).snd).prodMk
+            (((q.continuous.comp continuous_snd).snd).prodMk continuous_fst))
+  map_zero_left u := by simp
+  map_one_left u := by simp
+  prop' r u hu := by rcases hu with rfl | rfl <;> simp
+
+public
+theorem FundamentalGroupVanKampen.convexComb_mem_Icc {s t u v : (unitInterval)}
+    (hu : u ∈ Set.Icc s t) (hv : v ∈ Set.Icc s t) (r : (unitInterval)) :
+    Set.Icc.convexComb u v r ∈ Set.Icc s t := by
+  change (Set.Icc.convexComb u v r : ℝ) ∈ Set.Icc (s : ℝ) (t : ℝ)
+  exact
+    convex_Icc (s : ℝ) (t : ℝ) (show (u : ℝ) ∈ Set.Icc (s : ℝ) (t : ℝ) from hu)
+      (show (v : ℝ) ∈ Set.Icc (s : ℝ) (t : ℝ) from hv) (unitInterval.one_minus_nonneg r)
+      (unitInterval.nonneg r) (sub_add_cancel _ _)
+
+private theorem FundamentalGroupVanKampen.squarePathHomotopy_mem_rectangle
+    {x y : (unitInterval) × (unitInterval)} (p q : Path x y) (s t a b : (unitInterval))
+    (hp : ∀ u, p u ∈ Set.Icc s t ×ˢ Set.Icc a b) (hq : ∀ u, q u ∈ Set.Icc s t ×ˢ Set.Icc a b)
+    (u : (unitInterval) × (unitInterval)) :
+    squarePathHomotopy p q u ∈ Set.Icc s t ×ˢ Set.Icc a b :=
+  ⟨convexComb_mem_Icc (hp u.2).1 (hq u.2).1 u.1, convexComb_mem_Icc (hp u.2).2 (hq u.2).2 u.1⟩
+
+private def FundamentalGroupVanKampen.rectangleHorizontalVertical (s t a b : (unitInterval)) :
+    Path (s, a) (t, b) :=
+  ((squareHorizontal (ContinuousMap.id ((unitInterval) × (unitInterval))) s).subpath a b).trans
+    ((squareVertical (ContinuousMap.id ((unitInterval) × (unitInterval))) b).subpath s t)
+
+private def FundamentalGroupVanKampen.rectangleVerticalHorizontal (s t a b : (unitInterval)) :
+    Path (s, a) (t, b) :=
+  ((squareVertical (ContinuousMap.id ((unitInterval) × (unitInterval))) a).subpath s t).trans
+    ((squareHorizontal (ContinuousMap.id ((unitInterval) × (unitInterval))) t).subpath a b)
+
+private theorem
+    FundamentalGroupVanKampen.rectangleHorizontalVertical_map {X : Type*} [TopologicalSpace X]
+    (F : C((unitInterval) × (unitInterval), X)) (s t a b : (unitInterval)) :
+    (rectangleHorizontalVertical s t a b).map F.continuous =
+      ((squareHorizontal F s).subpath a b).trans ((squareVertical F b).subpath s t) := by
+  exact
+    Path.map_trans
+      ((squareHorizontal (ContinuousMap.id ((unitInterval) × (unitInterval))) s).subpath a b)
+      ((squareVertical (ContinuousMap.id ((unitInterval) × (unitInterval))) b).subpath s t)
+      F.continuous
+
+private theorem
+    FundamentalGroupVanKampen.rectangleVerticalHorizontal_map {X : Type*} [TopologicalSpace X]
+    (F : C((unitInterval) × (unitInterval), X)) (s t a b : (unitInterval)) :
+    (rectangleVerticalHorizontal s t a b).map F.continuous =
+      ((squareVertical F a).subpath s t).trans ((squareHorizontal F t).subpath a b) := by
+  exact
+    Path.map_trans
+      ((squareVertical (ContinuousMap.id ((unitInterval) × (unitInterval))) a).subpath s t)
+      ((squareHorizontal (ContinuousMap.id ((unitInterval) × (unitInterval))) t).subpath a b)
+      F.continuous
+
+private theorem FundamentalGroupVanKampen.rectangleHorizontalVertical_mem (s t a b : (unitInterval))
+    (hst : s ≤ t) (hab : a ≤ b) :
+    ∀ u, rectangleHorizontalVertical s t a b u ∈ Set.Icc s t ×ˢ Set.Icc a b := by
+  apply SimplyConnectedCover.trans_mem
+  · intro u
+    exact ⟨⟨le_rfl, hst⟩, Set.Icc.le_convexComb hab u, Set.Icc.convexComb_le hab u⟩
+  · intro u
+    exact ⟨⟨Set.Icc.le_convexComb hst u, Set.Icc.convexComb_le hst u⟩, hab, le_rfl⟩
+
+private theorem FundamentalGroupVanKampen.rectangleVerticalHorizontal_mem (s t a b : (unitInterval))
+    (hst : s ≤ t) (hab : a ≤ b) :
+    ∀ u, rectangleVerticalHorizontal s t a b u ∈ Set.Icc s t ×ˢ Set.Icc a b := by
+  apply SimplyConnectedCover.trans_mem
+  · intro u
+    exact ⟨⟨Set.Icc.le_convexComb hst u, Set.Icc.convexComb_le hst u⟩, le_rfl, hab⟩
+  · intro u
+    exact ⟨⟨hst, le_rfl⟩, Set.Icc.le_convexComb hab u, Set.Icc.convexComb_le hab u⟩
+
+private def FundamentalGroupVanKampen.rectangleBoundaryHomotopy {X : Type*} [TopologicalSpace X]
+    (F : C((unitInterval) × (unitInterval), X)) (s t a b : (unitInterval)) :
+    Path.Homotopy (((squareHorizontal F s).subpath a b).trans ((squareVertical F b).subpath s t))
+      (((squareVertical F a).subpath s t).trans ((squareHorizontal F t).subpath a b)) :=
+  ((squarePathHomotopy (rectangleHorizontalVertical s t a b)
+            (rectangleVerticalHorizontal s t a b)).map
+        F).cast
+    (rectangleHorizontalVertical_map F s t a b) (rectangleVerticalHorizontal_map F s t a b)
+
+private theorem
+    FundamentalGroupVanKampen.rectangleBoundaryHomotopy_apply {X : Type*} [TopologicalSpace X]
+    (F : C((unitInterval) × (unitInterval), X)) (s t a b : (unitInterval))
+    (u : (unitInterval) × (unitInterval)) :
+    rectangleBoundaryHomotopy F s t a b u =
+      F
+        (squarePathHomotopy (rectangleHorizontalVertical s t a b)
+          (rectangleVerticalHorizontal s t a b) u) :=
+  rfl
+
+private theorem
+    FundamentalGroupVanKampen.rectangleBoundaryHomotopy_mem {X : Type*} [TopologicalSpace X]
+    (F : C((unitInterval) × (unitInterval), X)) (s t a b : (unitInterval)) (hst : s ≤ t)
+    (hab : a ≤ b) {A : Set X} (hcell : ∀ u ∈ Set.Icc s t ×ˢ Set.Icc a b, F u ∈ A)
+    (u : (unitInterval) × (unitInterval)) : rectangleBoundaryHomotopy F s t a b u ∈ A := by
+  rw [rectangleBoundaryHomotopy_apply]
+  exact
+    hcell _
+      (squarePathHomotopy_mem_rectangle _ _ s t a b
+        (rectangleHorizontalVertical_mem s t a b hst hab)
+        (rectangleVerticalHorizontal_mem s t a b hst hab) u)
+
+private theorem
+    FundamentalGroupVanKampen.PathValue.square_cell_of_local {X : Type*} [TopologicalSpace X]
+    {ι G : Type*} [Group G] (V : FundamentalGroupVanKampen.PathValue X G) {U : ι → Set X}
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) (hExt : V.Extends L)
+    (hL : L.HomotopyInvariant) (i : ι) (F : C((unitInterval) × (unitInterval), X))
+    (s t a b : (unitInterval)) (hst : s ≤ t) (hab : a ≤ b)
+    (hcell : ∀ u ∈ Set.Icc s t ×ˢ Set.Icc a b, F u ∈ U i) :
+    V.value ((FundamentalGroupVanKampen.squareHorizontal F s).subpath a b) *
+        V.value ((FundamentalGroupVanKampen.squareVertical F b).subpath s t) =
+      V.value ((FundamentalGroupVanKampen.squareVertical F a).subpath s t) *
+        V.value ((FundamentalGroupVanKampen.squareHorizontal F t).subpath a b) := by
+  let H := FundamentalGroupVanKampen.rectangleBoundaryHomotopy F s t a b
+  have hH : ∀ u, H u ∈ U i :=
+    FundamentalGroupVanKampen.rectangleBoundaryHomotopy_mem F s t a b hst hab hcell
+  have hp :
+    ∀ u,
+      ((FundamentalGroupVanKampen.squareHorizontal F s).subpath a b).trans
+          ((FundamentalGroupVanKampen.squareVertical F b).subpath s t) u ∈
+        U i := by
+    intro u
+    exact (congrArg (fun x => x ∈ U i) (H.map_zero_left u)).mp (hH (0, u))
+  have hq :
+    ∀ u,
+      ((FundamentalGroupVanKampen.squareVertical F a).subpath s t).trans
+          ((FundamentalGroupVanKampen.squareHorizontal F t).subpath a b) u ∈
+        U i := by
+    intro u
+    exact (congrArg (fun x => x ∈ U i) (H.map_one_left u)).mp (hH (1, u))
+  calc
+    _ =
+        V.value
+          (((FundamentalGroupVanKampen.squareHorizontal F s).subpath a b).trans
+            ((FundamentalGroupVanKampen.squareVertical F b).subpath s t)) :=
+      (V.trans _ _).symm
+    _ = L.value i _ hp := (hExt i _ hp)
+    _ = L.value i _ hq := (hL i _ _ hp hq H hH)
+    _ =
+        V.value
+          (((FundamentalGroupVanKampen.squareVertical F a).subpath s t).trans
+            ((FundamentalGroupVanKampen.squareHorizontal F t).subpath a b)) :=
+      (hExt i _ hq).symm
+    _ = _ := V.trans _ _
+
+private theorem FundamentalGroupVanKampen.PathValue.value_eq_one_of_constant {X : Type*}
+    [TopologicalSpace X] {G : Type*} [Group G] (V : FundamentalGroupVanKampen.PathValue X G)
+    {x y : X} (p : Path x y) (hp : ∀ t, p t = x) : V.value p = 1 := by
+  have hy : y = x := p.target.symm.trans (hp 1)
+  subst y
+  have heq : p = Path.refl x := by
+    ext t
+    exact hp t
+  rw [heq, V.refl]
+
+private theorem FundamentalGroupVanKampen.PathValue.square_strip {X : Type*} [TopologicalSpace X]
+    {G : Type*} [Group G] (V : FundamentalGroupVanKampen.PathValue X G)
+    (F : C((unitInterval) × (unitInterval), X)) (s t : (unitInterval)) (d : ℕ → (unitInterval))
+    (hmono : Monotone d) (n : ℕ)
+    (hcell :
+      ∀ k < n,
+        V.value ((FundamentalGroupVanKampen.squareHorizontal F s).subpath (d k) (d (k + 1))) *
+            V.value ((FundamentalGroupVanKampen.squareVertical F (d (k + 1))).subpath s t) =
+          V.value ((FundamentalGroupVanKampen.squareVertical F (d k)).subpath s t) *
+            V.value
+              ((FundamentalGroupVanKampen.squareHorizontal F t).subpath (d k) (d (k + 1)))) :
+    V.value ((FundamentalGroupVanKampen.squareHorizontal F s).subpath (d 0) (d n)) *
+        V.value ((FundamentalGroupVanKampen.squareVertical F (d n)).subpath s t) =
+      V.value ((FundamentalGroupVanKampen.squareVertical F (d 0)).subpath s t) *
+        V.value ((FundamentalGroupVanKampen.squareHorizontal F t).subpath (d 0) (d n)) := by
+  induction n with
+  | zero => simp only [Path.subpath_self, V.refl, one_mul, mul_one]
+  | succ n ih =>
+    have hprev := ih (fun k hk => hcell k (Nat.lt_succ_of_lt hk))
+    rw [V.subpath_mul _ (d 0) (d n) (d (n + 1)) (hmono (Nat.zero_le n)) (hmono (Nat.le_succ n)),
+      V.subpath_mul _ (d 0) (d n) (d (n + 1)) (hmono (Nat.zero_le n)) (hmono (Nat.le_succ n))]
+    calc
+      _ =
+          V.value ((FundamentalGroupVanKampen.squareHorizontal F s).subpath (d 0) (d n)) *
+            (V.value
+                ((FundamentalGroupVanKampen.squareHorizontal F s).subpath (d n) (d (n + 1))) *
+              V.value ((FundamentalGroupVanKampen.squareVertical F (d (n + 1))).subpath s t)) :=
+        mul_assoc _ _ _
+      _ =
+          V.value ((FundamentalGroupVanKampen.squareHorizontal F s).subpath (d 0) (d n)) *
+            (V.value ((FundamentalGroupVanKampen.squareVertical F (d n)).subpath s t) *
+              V.value
+                ((FundamentalGroupVanKampen.squareHorizontal F t).subpath (d n) (d (n + 1)))) := by
+        rw [hcell n (Nat.lt_succ_self n)]
+      _ =
+          (V.value ((FundamentalGroupVanKampen.squareHorizontal F s).subpath (d 0) (d n)) *
+              V.value ((FundamentalGroupVanKampen.squareVertical F (d n)).subpath s t)) *
+            V.value
+              ((FundamentalGroupVanKampen.squareHorizontal F t).subpath (d n) (d (n + 1))) :=
+        (mul_assoc _ _ _).symm
+      _ =
+          (V.value ((FundamentalGroupVanKampen.squareVertical F (d 0)).subpath s t) *
+              V.value ((FundamentalGroupVanKampen.squareHorizontal F t).subpath (d 0) (d n))) *
+            V.value
+              ((FundamentalGroupVanKampen.squareHorizontal F t).subpath (d n) (d (n + 1))) := by
+        rw [hprev]
+      _ = _ := mul_assoc _ _ _
+
+private theorem FundamentalGroupVanKampen.PathValue.value_squareHorizontal_homotopy {X : Type*}
+    [TopologicalSpace X] {G : Type*} [Group G] (V : FundamentalGroupVanKampen.PathValue X G)
+    {x y : X} {p q : Path x y} (H : Path.Homotopy p q) (s : (unitInterval)) :
+    V.value (FundamentalGroupVanKampen.squareHorizontal H.toContinuousMap s) =
+      V.value (H.eval s) := by
+  have heq :
+    FundamentalGroupVanKampen.squareHorizontal H.toContinuousMap s =
+      (H.eval s).cast (H.source s) (H.target s) := by
+    ext t
+    rfl
+  rw [heq, V.value_cast]
+
+private theorem FundamentalGroupVanKampen.PathValue.value_squareVertical_homotopy_zero {X : Type*}
+    [TopologicalSpace X] {G : Type*} [Group G] (V : FundamentalGroupVanKampen.PathValue X G)
+    {x y : X} {p q : Path x y} (H : Path.Homotopy p q) (s t : (unitInterval)) :
+    V.value ((FundamentalGroupVanKampen.squareVertical H.toContinuousMap 0).subpath s t) = 1 := by
+  apply V.value_eq_one_of_constant
+  intro u
+  change H (_, 0) = H (s, 0)
+  simp only [Path.Homotopy.source]
+
+private theorem FundamentalGroupVanKampen.PathValue.value_squareVertical_homotopy_one {X : Type*}
+    [TopologicalSpace X] {G : Type*} [Group G] (V : FundamentalGroupVanKampen.PathValue X G)
+    {x y : X} {p q : Path x y} (H : Path.Homotopy p q) (s t : (unitInterval)) :
+    V.value ((FundamentalGroupVanKampen.squareVertical H.toContinuousMap 1).subpath s t) = 1 := by
+  apply V.value_eq_one_of_constant
+  intro u
+  change H (_, 1) = H (s, 1)
+  simp only [Path.Homotopy.target]
+
+private theorem FundamentalGroupVanKampen.PathValue.value_eq_of_homotopy_of_open_cover {X : Type*}
+    [TopologicalSpace X] {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (V : FundamentalGroupVanKampen.PathValue X G)
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) (hopen : ∀ i, IsOpen (U i))
+    (hcover : ⋃ i, U i = Set.univ) (hExt : V.Extends L) (hL : L.HomotopyInvariant) {x y : X}
+    (p q : Path x y) (H : Path.Homotopy p q) : V.value p = V.value q := by
+  have hpre : Set.univ ⊆ ⋃ i, H ⁻¹' U i := by
+    rw [← Set.preimage_iUnion, hcover, Set.preimage_univ]
+  obtain ⟨d, hd0, hdmono, ⟨n, hn⟩, hrect⟩ :=
+    exists_monotone_Icc_subset_open_cover_unitInterval_prod_self
+      (fun i => (hopen i).preimage (ContinuousMapClass.map_continuous H)) hpre
+  have hstep (k : ℕ) : V.value (H.eval (d k)) = V.value (H.eval (d (k + 1))) := by
+    have hstrip :=
+      V.square_strip H.toContinuousMap (d k) (d (k + 1)) d hdmono n
+        (fun m _ => by
+          obtain ⟨i, hi⟩ := hrect k m
+          exact
+            V.square_cell_of_local L hExt hL i H.toContinuousMap (d k) (d (k + 1)) (d m)
+              (d (m + 1)) (hdmono (Nat.le_succ k)) (hdmono (Nat.le_succ m)) hi)
+    rw [hd0, hn n le_rfl] at hstrip
+    simpa only [V.value_subpath_zero_one, V.value_squareVertical_homotopy_zero,
+      V.value_squareVertical_homotopy_one, V.value_squareHorizontal_homotopy, mul_one,
+      one_mul] using hstrip
+  have hwalk : ∀ k, V.value (H.eval (d 0)) = V.value (H.eval (d k)) := by
+    intro k
+    induction k with
+    | zero => rfl
+    | succ k ih => exact ih.trans (hstep k)
+  have hfinish := hwalk n
+  simpa only [hd0, hn n le_rfl, Path.Homotopy.eval_zero, Path.Homotopy.eval_one] using hfinish
+
+private theorem FundamentalGroupVanKampen.PathValue.homotopyInvariant_of_open_cover {X : Type*}
+    [TopologicalSpace X] {ι : Type*} {G : Type*} [Group G] {U : ι → Set X}
+    (V : FundamentalGroupVanKampen.PathValue X G)
+    (L : FundamentalGroupVanKampen.LocalPathValue U G) (hopen : ∀ i, IsOpen (U i))
+    (hcover : ⋃ i, U i = Set.univ) (hExt : V.Extends L) (hL : L.HomotopyInvariant) :
+    V.HomotopyInvariant := by
+  intro x y p q h
+  obtain ⟨H⟩ := h
+  exact V.value_eq_of_homotopy_of_open_cover L hopen hcover hExt hL p q H
+
+private def FundamentalGroupVanKampen.TwoOpenCover.globalPathValue {X : Type*} [TopologicalSpace X]
+    {G : Type*} [Group G] (D : FundamentalGroupVanKampen.TwoOpenCover X) (fU : D.UGroup →* G)
+    (fV : D.VGroup →* G) (hf : D.Compatible fU fV) : FundamentalGroupVanKampen.PathValue X G :=
+  (D.localPathValue fU fV hf).extension D.chart_open D.chart_cover
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.globalPathValue_extends {X : Type*}
+    [TopologicalSpace X] {G : Type*} [Group G] (D : FundamentalGroupVanKampen.TwoOpenCover X)
+    (fU : D.UGroup →* G) (fV : D.VGroup →* G) (hf : D.Compatible fU fV) :
+    (D.globalPathValue fU fV hf).Extends (D.localPathValue fU fV hf) :=
+  (D.localPathValue fU fV hf).extension_extends D.chart_open D.chart_cover
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.globalPathValue_homotopyInvariant {X : Type*}
+    [TopologicalSpace X] {G : Type*} [Group G] (D : FundamentalGroupVanKampen.TwoOpenCover X)
+    (fU : D.UGroup →* G) (fV : D.VGroup →* G) (hf : D.Compatible fU fV) :
+    (D.globalPathValue fU fV hf).HomotopyInvariant :=
+  FundamentalGroupVanKampen.PathValue.homotopyInvariant_of_open_cover (D.globalPathValue fU fV hf)
+    (D.localPathValue fU fV hf) D.chart_open D.chart_cover (D.globalPathValue_extends fU fV hf)
+    (D.localPathValue_homotopyInvariant fU fV hf)
+
+private def FundamentalGroupVanKampen.TwoOpenCover.lift {X : Type*} [TopologicalSpace X] {G : Type*}
+    [Group G] (D : FundamentalGroupVanKampen.TwoOpenCover X) (fU : D.UGroup →* G)
+    (fV : D.VGroup →* G) (hf : D.Compatible fU fV) : FundamentalGroup X D.base →* G :=
+  (D.globalPathValue fU fV hf).fundamentalGroupHom (D.globalPathValue_homotopyInvariant fU fV hf)
+    D.base
+
+private theorem
+    FundamentalGroupVanKampen.TwoOpenCover.lift_mk_of_mem {X : Type*} [TopologicalSpace X]
+    {G : Type*} [Group G] (D : FundamentalGroupVanKampen.TwoOpenCover X) (fU : D.UGroup →* G)
+    (fV : D.VGroup →* G) (hf : D.Compatible fU fV) (i : Bool) (p : Path D.base D.base)
+    (hp : ∀ t, p t ∈ D.chart i) :
+    D.lift fU fV hf (Path.Homotopic.Quotient.mk p) = (D.localValue fU fV i p hp)⁻¹ :=
+  congrArg (fun a : G => a⁻¹) (D.globalPathValue_extends fU fV hf i p hp)
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.lift_comp_inclusionU {X : Type*}
+    [TopologicalSpace X] {G : Type*} [Group G] (D : FundamentalGroupVanKampen.TwoOpenCover X)
+    (fU : D.UGroup →* G) (fV : D.VGroup →* G) (hf : D.Compatible fU fV) :
+    (D.lift fU fV hf).comp D.inclusionHomU = fU := by
+  ext γ
+  obtain ⟨p⟩ := γ
+  have h :=
+    D.lift_mk_of_mem fU fV hf Bool.false (p.map continuous_subtype_val) (fun t => (p t).property)
+  rw [D.localValue_map_loop, inv_inv] at h
+  exact h
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.lift_comp_inclusionV {X : Type*}
+    [TopologicalSpace X] {G : Type*} [Group G] (D : FundamentalGroupVanKampen.TwoOpenCover X)
+    (fU : D.UGroup →* G) (fV : D.VGroup →* G) (hf : D.Compatible fU fV) :
+    (D.lift fU fV hf).comp D.inclusionHomV = fV := by
+  ext γ
+  obtain ⟨p⟩ := γ
+  have h :=
+    D.lift_mk_of_mem fU fV hf Bool.true (p.map continuous_subtype_val) (fun t => (p t).property)
+  rw [D.localValue_map_loop, inv_inv] at h
+  exact h
+
+private abbrev FundamentalGroupVanKampen.TwoOpenCover.ChartGroup {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) (i : Bool) :=
+  FundamentalGroup (D.chart i) (D.baseChart i)
+
+private def FundamentalGroupVanKampen.TwoOpenCover.overlapHom {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) : (i : Bool) → D.OverlapGroup →* D.ChartGroup i
+  | false => D.overlapHomU
+  | true => D.overlapHomV
+
+private def FundamentalGroupVanKampen.TwoOpenCover.inclusionHom {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) :
+    (i : Bool) → D.ChartGroup i →* FundamentalGroup X D.base
+  | false => D.inclusionHomU
+  | true => D.inclusionHomV
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.inclusionHom_comp_overlapHom {X : Type*}
+    [TopologicalSpace X] (D : FundamentalGroupVanKampen.TwoOpenCover X) (i : Bool) :
+    (D.inclusionHom i).comp (D.overlapHom i) = D.inclusionHomU.comp D.overlapHomU := by
+  cases i
+  · rfl
+  · exact D.inclusionHom_compatible.symm
+
+private abbrev FundamentalGroupVanKampen.TwoOpenCover.Pushout {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) :=
+  Monoid.PushoutI D.overlapHom
+
+private def FundamentalGroupVanKampen.TwoOpenCover.pushoutOfU {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) : D.UGroup →* D.Pushout :=
+  Monoid.PushoutI.of (φ := D.overlapHom) Bool.false
+
+private def FundamentalGroupVanKampen.TwoOpenCover.pushoutOfV {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) : D.VGroup →* D.Pushout :=
+  Monoid.PushoutI.of (φ := D.overlapHom) Bool.true
+
+private def FundamentalGroupVanKampen.TwoOpenCover.pushoutBase {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) : D.OverlapGroup →* D.Pushout :=
+  Monoid.PushoutI.base D.overlapHom
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.pushoutOfU_comp_overlapHomU {X : Type*}
+    [TopologicalSpace X] (D : FundamentalGroupVanKampen.TwoOpenCover X) :
+    D.pushoutOfU.comp D.overlapHomU = D.pushoutBase :=
+  Monoid.PushoutI.of_comp_eq_base (φ := D.overlapHom) Bool.false
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.pushoutOfV_comp_overlapHomV {X : Type*}
+    [TopologicalSpace X] (D : FundamentalGroupVanKampen.TwoOpenCover X) :
+    D.pushoutOfV.comp D.overlapHomV = D.pushoutBase :=
+  Monoid.PushoutI.of_comp_eq_base (φ := D.overlapHom) Bool.true
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.pushoutOf_compatible {X : Type*}
+    [TopologicalSpace X] (D : FundamentalGroupVanKampen.TwoOpenCover X) :
+    D.Compatible D.pushoutOfU D.pushoutOfV :=
+  D.pushoutOfU_comp_overlapHomU.trans D.pushoutOfV_comp_overlapHomV.symm
+
+private def FundamentalGroupVanKampen.TwoOpenCover.pushoutToFundamentalGroup {X : Type*}
+    [TopologicalSpace X] (D : FundamentalGroupVanKampen.TwoOpenCover X) :
+    D.Pushout →* FundamentalGroup X D.base :=
+  Monoid.PushoutI.lift D.inclusionHom (D.inclusionHomU.comp D.overlapHomU)
+    D.inclusionHom_comp_overlapHom
+
+@[simp]
+private theorem FundamentalGroupVanKampen.TwoOpenCover.pushoutToFundamentalGroup_of {X : Type*}
+    [TopologicalSpace X] (D : FundamentalGroupVanKampen.TwoOpenCover X) (i : Bool)
+    (g : D.ChartGroup i) :
+    D.pushoutToFundamentalGroup (Monoid.PushoutI.of i g) = D.inclusionHom i g :=
+  Monoid.PushoutI.lift_of _ _ _ g
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.pushoutToFundamentalGroup_comp_of {X : Type*}
+    [TopologicalSpace X] (D : FundamentalGroupVanKampen.TwoOpenCover X) (i : Bool) :
+    D.pushoutToFundamentalGroup.comp (Monoid.PushoutI.of i) = D.inclusionHom i := by
+  ext g
+  exact D.pushoutToFundamentalGroup_of i g
+
+private theorem
+    FundamentalGroupVanKampen.TwoOpenCover.pushoutToFundamentalGroup_comp_ofU {X : Type*}
+    [TopologicalSpace X] (D : FundamentalGroupVanKampen.TwoOpenCover X) :
+    D.pushoutToFundamentalGroup.comp D.pushoutOfU = D.inclusionHomU :=
+  D.pushoutToFundamentalGroup_comp_of Bool.false
+
+private theorem
+    FundamentalGroupVanKampen.TwoOpenCover.pushoutToFundamentalGroup_comp_ofV {X : Type*}
+    [TopologicalSpace X] (D : FundamentalGroupVanKampen.TwoOpenCover X) :
+    D.pushoutToFundamentalGroup.comp D.pushoutOfV = D.inclusionHomV :=
+  D.pushoutToFundamentalGroup_comp_of Bool.true
+
+private def FundamentalGroupVanKampen.TwoOpenCover.fundamentalGroupToPushout {X : Type*}
+    [TopologicalSpace X] (D : FundamentalGroupVanKampen.TwoOpenCover X) :
+    FundamentalGroup X D.base →* D.Pushout :=
+  D.lift D.pushoutOfU D.pushoutOfV D.pushoutOf_compatible
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.fundamentalGroupToPushout_comp_inclusionU
+    {X : Type*} [TopologicalSpace X] (D : FundamentalGroupVanKampen.TwoOpenCover X) :
+    D.fundamentalGroupToPushout.comp D.inclusionHomU = D.pushoutOfU :=
+  D.lift_comp_inclusionU D.pushoutOfU D.pushoutOfV D.pushoutOf_compatible
+
+private theorem FundamentalGroupVanKampen.TwoOpenCover.fundamentalGroupToPushout_comp_inclusionV
+    {X : Type*} [TopologicalSpace X] (D : FundamentalGroupVanKampen.TwoOpenCover X) :
+    D.fundamentalGroupToPushout.comp D.inclusionHomV = D.pushoutOfV :=
+  D.lift_comp_inclusionV D.pushoutOfU D.pushoutOfV D.pushoutOf_compatible
+
+private theorem
+  FundamentalGroupVanKampen.TwoOpenCover.fundamentalGroupToPushout_comp_pushoutToFundamentalGroup
+    {X : Type*} [TopologicalSpace X] (D : FundamentalGroupVanKampen.TwoOpenCover X) :
+    D.fundamentalGroupToPushout.comp D.pushoutToFundamentalGroup = MonoidHom.id D.Pushout := by
+  apply Monoid.PushoutI.hom_ext_nonempty
+  intro i
+  cases i
+  · change
+      (D.fundamentalGroupToPushout.comp D.pushoutToFundamentalGroup).comp D.pushoutOfU =
+        (MonoidHom.id D.Pushout).comp D.pushoutOfU
+    rw [MonoidHom.comp_assoc, D.pushoutToFundamentalGroup_comp_ofU,
+      D.fundamentalGroupToPushout_comp_inclusionU, MonoidHom.id_comp]
+  · change
+      (D.fundamentalGroupToPushout.comp D.pushoutToFundamentalGroup).comp D.pushoutOfV =
+        (MonoidHom.id D.Pushout).comp D.pushoutOfV
+    rw [MonoidHom.comp_assoc, D.pushoutToFundamentalGroup_comp_ofV,
+      D.fundamentalGroupToPushout_comp_inclusionV, MonoidHom.id_comp]
+
+private theorem
+  FundamentalGroupVanKampen.TwoOpenCover.pushoutToFundamentalGroup_comp_fundamentalGroupToPushout
+    {X : Type*} [TopologicalSpace X] (D : FundamentalGroupVanKampen.TwoOpenCover X) :
+    D.pushoutToFundamentalGroup.comp D.fundamentalGroupToPushout =
+      MonoidHom.id (FundamentalGroup X D.base) := by
+  apply D.hom_ext
+  · rw [MonoidHom.comp_assoc, D.fundamentalGroupToPushout_comp_inclusionU,
+      D.pushoutToFundamentalGroup_comp_ofU, MonoidHom.id_comp]
+  · rw [MonoidHom.comp_assoc, D.fundamentalGroupToPushout_comp_inclusionV,
+      D.pushoutToFundamentalGroup_comp_ofV, MonoidHom.id_comp]
+
+private def FundamentalGroupVanKampen.TwoOpenCover.pushoutEquiv {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) : D.Pushout ≃* FundamentalGroup X D.base
+    where
+  toFun := D.pushoutToFundamentalGroup
+  invFun := D.fundamentalGroupToPushout
+  left_inv g := DFunLike.congr_fun D.fundamentalGroupToPushout_comp_pushoutToFundamentalGroup g
+  right_inv g := DFunLike.congr_fun D.pushoutToFundamentalGroup_comp_fundamentalGroupToPushout g
+  map_mul' := D.pushoutToFundamentalGroup.map_mul
+
+@[simp]
+private theorem
+    FundamentalGroupVanKampen.TwoOpenCover.pushoutEquiv_of {X : Type*} [TopologicalSpace X]
+    (D : FundamentalGroupVanKampen.TwoOpenCover X) (i : Bool) (g : D.ChartGroup i) :
+    D.pushoutEquiv (Monoid.PushoutI.of i g) = D.inclusionHom i g :=
+  D.pushoutToFundamentalGroup_of i g
+
+private abbrev
+    ThreefoldOverlapMappingTorus.PuncturedPiece (i : SpecialPeriods.Threefold.Puncture) :=
+  { x : SpecialPeriods.Threefold.localPiece (Option.some i) //
+    SpecialPeriods.Threefold.localProjectionToBase (Option.some i) x ∈
+      SpecialPeriods.Threefold.regularPatch }
+
+private theorem ThreefoldOverlapMappingTorus.inclusion_mem_regular_iff
+    (i : SpecialPeriods.Threefold.Puncture)
+    (x : SpecialPeriods.Threefold.localPiece (Option.some i)) :
+    SpecialPeriods.Threefold.inclusion (Option.some i) x ∈
+        SpecialPeriods.Threefold.liftedPatch Option.none ↔
+      SpecialPeriods.Threefold.localProjectionToBase (Option.some i) x ∈
+        SpecialPeriods.Threefold.regularPatch := by
+  change
+    SpecialPeriods.Threefold.projection (SpecialPeriods.Threefold.inclusion (Option.some i) x) ∈
+        SpecialPeriods.Threefold.regularPatch ↔
+      _
+  rw [SpecialPeriods.Threefold.projection_inclusion]
+
+private def
+    ThreefoldOverlapMappingTorus.overlapPieceHomeomorph (i : SpecialPeriods.Threefold.Puncture) :
+    SpecialPeriods.Threefold.RegularOverlap i ≃ₜ PuncturedPiece i
+    where
+  toFun
+    x :=
+    ⟨ThreefoldHomology.overlapToFilling i x,
+      by
+      apply (inclusion_mem_regular_iff i _).mp
+      rw [ThreefoldHomology.inclusion_overlapToFilling]
+      exact x.property.1⟩
+  invFun
+    x :=
+    ⟨SpecialPeriods.Threefold.inclusion (Option.some i) x.val,
+      (inclusion_mem_regular_iff i x.val).mpr x.property,
+      (ThreefoldHomology.originalPatchHomeomorph (Option.some i) x.val).property⟩
+  left_inv x := Subtype.ext (ThreefoldHomology.inclusion_overlapToFilling i x)
+  right_inv
+    x := by
+    apply Subtype.ext
+    apply (SpecialPeriods.Threefold.inclusion_openEmbedding (Option.some i)).injective
+    exact ThreefoldHomology.inclusion_overlapToFilling i _
+  continuous_toFun := (ThreefoldHomology.overlapToFilling i).continuous.subtype_mk _
+  continuous_invFun :=
+    ((SpecialPeriods.Threefold.inclusion_openEmbedding (Option.some i)).continuous.comp
+          continuous_subtype_val).subtype_mk
+      _
+
+private def
+    ThreefoldOverlapMappingTorus.puncturedPieceInclusion (i : SpecialPeriods.Threefold.Puncture) :
+    C(PuncturedPiece i, SpecialPeriods.Threefold.localPiece (Option.some i)) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private def
+    ThreefoldOverlapMappingTorus.puncturedPieceToRegular (i : SpecialPeriods.Threefold.Puncture) :
+    C(PuncturedPiece i, SpecialPeriods.Threefold.SpecialRegularFamily) :=
+  (ThreefoldHomology.overlapToRegularFamily i).comp
+    ((overlapPieceHomeomorph i).symm :
+      C(PuncturedPiece i, SpecialPeriods.Threefold.RegularOverlap i))
+
+private theorem ThreefoldOverlapMappingTorus.puncturedPieceToRegular_inclusion
+    (i : SpecialPeriods.Threefold.Puncture) (x : PuncturedPiece i) :
+    SpecialPeriods.Threefold.inclusion Option.none (puncturedPieceToRegular i x) =
+      SpecialPeriods.Threefold.inclusion (Option.some i) x.val :=
+  ThreefoldHomology.inclusion_overlapToRegularFamily i ((overlapPieceHomeomorph i).symm x)
+
+private theorem ThreefoldOverlapMappingTorus.Elliptic.specialPiece_regular_iff (j : Elliptic.Kind)
+    (x : SpecialPeriods.Threefold.SpecialEllipticPiece j) :
+    SpecialPeriods.Threefold.localProjectionToBase (Option.some (Option.some j)) x ∈
+        SpecialPeriods.Threefold.regularPatch ↔
+      (SpecialPeriods.EllipticFilling.specialFullFillingProjection j x.val : ℂ) ≠ 0 :=
+  SpecialPeriods.EllipticFilling.pieceProjectionToBase_mem_regular_iff
+    SpecialPeriods.specialPeriodMap SpecialPeriods.specialPeriodMap_generator₁
+    SpecialPeriods.specialPeriodMap_generator₂ SpecialPeriods.Threefold.specialBaseCover j x
+
+private def ThreefoldOverlapMappingTorus.Elliptic.specialPuncturedHomeomorph (j : Elliptic.Kind) :
+    ThreefoldOverlapMappingTorus.PuncturedPiece (Option.some j) ≃ₜ
+      PuncturedFilling j j.twist (Elliptic.mainTwist_admissible j)
+        (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    where
+  toFun
+    x :=
+    ⟨(SpecialPeriods.EllipticFilling.specialLocalData j).fillingHomeomorph j.twist
+        (Elliptic.mainTwist_admissible j)
+        ((x.val : SpecialPeriods.Threefold.SpecialEllipticPiece j).val),
+      (specialPiece_regular_iff j x.val).mp x.property,
+      (x.val : SpecialPeriods.Threefold.SpecialEllipticPiece j).property⟩
+  invFun
+    y :=
+    ⟨(⟨((SpecialPeriods.EllipticFilling.specialLocalData j).fillingHomeomorph j.twist
+                (Elliptic.mainTwist_admissible j)).symm
+            y.val,
+          y.property.2⟩ :
+        SpecialPeriods.Threefold.SpecialEllipticPiece j),
+      (specialPiece_regular_iff j _).mpr y.property.1⟩
+  left_inv
+    x := by
+    apply Subtype.ext
+    apply Subtype.ext
+    exact
+      ((SpecialPeriods.EllipticFilling.specialLocalData j).fillingHomeomorph j.twist
+            (Elliptic.mainTwist_admissible j)).symm_apply_apply
+        _
+  right_inv
+    y := by
+    apply Subtype.ext
+    exact
+      ((SpecialPeriods.EllipticFilling.specialLocalData j).fillingHomeomorph j.twist
+            (Elliptic.mainTwist_admissible j)).apply_symm_apply
+        _
+  continuous_toFun :=
+    (((SpecialPeriods.EllipticFilling.specialLocalData j).fillingHomeomorph j.twist
+              (Elliptic.mainTwist_admissible j)).continuous.comp
+          (continuous_subtype_val.comp continuous_subtype_val)).subtype_mk
+      _
+  continuous_invFun :=
+    ((((SpecialPeriods.EllipticFilling.specialLocalData j).fillingHomeomorph j.twist
+                  (Elliptic.mainTwist_admissible j)).symm.continuous.comp
+              continuous_subtype_val).subtype_mk
+          _).subtype_mk
+      _
+
+private def ThreefoldOverlapMappingTorus.Elliptic.specialRootRadius (j : Elliptic.Kind) :
+    ThreefoldOverlapMappingTorus.Radius j.order
+      (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :=
+  Classical.choice
+    (ThreefoldOverlapMappingTorus.radius_nonempty j.order j.order_pos
+      (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+      (SpecialPeriods.Threefold.specialBaseCover.radius_pos (Option.some j)))
+
+private abbrev ThreefoldOverlapMappingTorus.Elliptic.SpecialBoundary (j : Elliptic.Kind) :=
+  Boundary j j.twist
+
+private def
+    ThreefoldOverlapMappingTorus.Elliptic.specialMappingTorusHomotopyEquiv (j : Elliptic.Kind) :
+    ThreefoldOverlapMappingTorus.PuncturedPiece (Option.some j) ≃ₕ SpecialBoundary j :=
+  (specialPuncturedHomeomorph j).toHomotopyEquiv.trans
+    (puncturedMappingTorusHomotopyEquiv j j.twist (Elliptic.mainTwist_admissible j)
+      (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) (specialRootRadius j))
+
+private def ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryInclusion (j : Elliptic.Kind) :
+    C(SpecialBoundary j, ThreefoldOverlapMappingTorus.PuncturedPiece (Option.some j)) :=
+  ⟨(specialMappingTorusHomotopyEquiv j).symm,
+    (specialMappingTorusHomotopyEquiv j).symm.continuous⟩
+
+private def ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryToPiece (j : Elliptic.Kind) :
+    C(SpecialBoundary j, SpecialPeriods.Threefold.SpecialEllipticPiece j) :=
+  (ThreefoldOverlapMappingTorus.puncturedPieceInclusion (Option.some j)).comp
+    (specialBoundaryInclusion j)
+
+private theorem
+    ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryInclusion_mk (j : Elliptic.Kind)
+    (t : ℝ) (x : RealTorus₄) :
+    ((specialBoundaryInclusion j
+              (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (t, x))).val :
+          SpecialPeriods.Threefold.SpecialEllipticPiece j).val =
+      (SpecialPeriods.EllipticFilling.specialLocalData j).quotient j.twist
+        (Elliptic.mainTwist_admissible j)
+        (ThreefoldOverlapMappingTorus.root j.order
+            (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+            (specialRootRadius j) ((t / j.order : ℝ) : ThreefoldOverlapMappingTorus.Circle),
+          x) := by
+  change
+    (((specialPuncturedHomeomorph j).symm
+              (boundaryInclusion j j.twist (Elliptic.mainTwist_admissible j)
+                (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+                (specialRootRadius j) (MappingTorus.mk _ (t, x)))).val :
+          SpecialPeriods.Threefold.SpecialEllipticPiece j).val =
+      _
+  rw [boundaryInclusion_mk]
+  rfl
+
+private def ThreefoldOverlapMappingTorus.Cusp.specialData : SpecialPeriods.CuspFamily.Data :=
+  SpecialPeriods.Threefold.CuspPiece.restrictedData SpecialPeriods.specialCuspData
+    SpecialPeriods.Threefold.specialBaseCover SpecialPeriods.Threefold.specialCuspRadius_le
+
+private abbrev ThreefoldOverlapMappingTorus.Cusp.SpecialPuncturedPiece :=
+  {x : SpecialPeriods.Threefold.SpecialCuspPiece |
+    SpecialPeriods.Threefold.specialCuspPieceProjectionToBase x ∈
+      SpecialPeriods.Threefold.regularPatch}
+
+private def ThreefoldOverlapMappingTorus.Cusp.specialPuncturedHomeomorph :
+    SpecialPuncturedPiece ≃ₜ
+      CuspUniformization.PuncturedQuotient specialData.correction specialData.radius
+    where
+  toFun
+    x :=
+    ⟨x.1,
+      (SpecialPeriods.Threefold.CuspPiece.projectionToBase_mem_regular_iff
+            SpecialPeriods.specialCuspData SpecialPeriods.Threefold.specialBaseCover x.1).mp
+        x.property⟩
+  invFun
+    x :=
+    ⟨x.1,
+      (SpecialPeriods.Threefold.CuspPiece.projectionToBase_mem_regular_iff
+            SpecialPeriods.specialCuspData SpecialPeriods.Threefold.specialBaseCover x.1).mpr
+        x.property⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := continuous_subtype_val.subtype_mk _
+  continuous_invFun := continuous_subtype_val.subtype_mk _
+
+private def ThreefoldOverlapMappingTorus.Cusp.specialHeight : Height specialData.radius :=
+  ⟨heightThreshold specialData.radius + 1,
+    by
+    change heightThreshold specialData.radius < heightThreshold specialData.radius + 1
+    exact lt_add_one _⟩
+
+private def ThreefoldOverlapMappingTorus.Cusp.specialMappingTorusHomotopyEquivAt
+    (h : Height specialData.radius) : SpecialPuncturedPiece ≃ₕ Boundary :=
+  specialPuncturedHomeomorph.toHomotopyEquiv.trans
+    (puncturedMappingTorusHomotopyEquiv specialData h)
+
+private def ThreefoldOverlapMappingTorus.Cusp.specialMappingTorusHomotopyEquiv :
+    SpecialPuncturedPiece ≃ₕ Boundary :=
+  specialMappingTorusHomotopyEquivAt specialHeight
+
+private def ThreefoldOverlapMappingTorus.Cusp.specialBoundaryInclusion :
+    C(Boundary, SpecialPuncturedPiece) :=
+  specialMappingTorusHomotopyEquiv.invFun
+
+private def ThreefoldOverlapMappingTorus.Cusp.specialBoundaryToPiece :
+    C(Boundary, SpecialPeriods.Threefold.SpecialCuspPiece) :=
+  (⟨Subtype.val, continuous_subtype_val⟩ :
+        C(SpecialPuncturedPiece, SpecialPeriods.Threefold.SpecialCuspPiece)).comp
+    specialBoundaryInclusion
+
+private def ThreefoldOverlapMappingTorus.Cusp.specialFibreToPiece :
+    C(RealTorus₄, SpecialPeriods.Threefold.SpecialCuspPiece) :=
+  specialBoundaryToPiece.comp (MappingTorus.HomologyCover.fibreInclusion monodromy)
+
+private def ThreefoldOverlapMappingTorus.monodromy :
+    SpecialPeriods.Threefold.Puncture → (RealTorus₄ ≃ₜ RealTorus₄)
+  | none => Cusp.monodromy
+  | some j => Elliptic.flatTorusAffine j j.twist
+
+private abbrev ThreefoldOverlapMappingTorus.Boundary (i : SpecialPeriods.Threefold.Puncture) :=
+  MappingTorus.Torus (monodromy i)
+
+private def ThreefoldOverlapMappingTorus.pieceMappingTorusHomotopyEquiv
+    (i : SpecialPeriods.Threefold.Puncture) : PuncturedPiece i ≃ₕ Boundary i := by
+  cases i with
+  | none => exact Cusp.specialMappingTorusHomotopyEquiv
+  | some j => exact Elliptic.specialMappingTorusHomotopyEquiv j
+
+private def ThreefoldOverlapMappingTorus.overlapMappingTorusHomotopyEquiv
+    (i : SpecialPeriods.Threefold.Puncture) :
+    SpecialPeriods.Threefold.RegularOverlap i ≃ₕ Boundary i :=
+  (overlapPieceHomeomorph i).toHomotopyEquiv.trans (pieceMappingTorusHomotopyEquiv i)
+
+private def ThreefoldOverlapMappingTorus.boundaryToOverlap (i : SpecialPeriods.Threefold.Puncture) :
+    C(Boundary i, SpecialPeriods.Threefold.RegularOverlap i) :=
+  ⟨(overlapMappingTorusHomotopyEquiv i).symm,
+    (overlapMappingTorusHomotopyEquiv i).symm.continuous⟩
+
+private def
+    ThreefoldOverlapMappingTorus.boundaryToRegularFamily (i : SpecialPeriods.Threefold.Puncture) :
+    C(Boundary i, SpecialPeriods.Threefold.SpecialRegularFamily) :=
+  (ThreefoldHomology.overlapToRegularFamily i).comp (boundaryToOverlap i)
+
+private def ThreefoldOverlapMappingTorus.boundaryToFilling (i : SpecialPeriods.Threefold.Puncture) :
+    C(Boundary i, SpecialPeriods.Threefold.localPiece (Option.some i)) :=
+  (ThreefoldHomology.overlapToFilling i).comp (boundaryToOverlap i)
+
+private theorem ThreefoldOverlapMappingTorus.boundaryToRegularFamily_ambient
+    (i : SpecialPeriods.Threefold.Puncture) (x : Boundary i) :
+    SpecialPeriods.Threefold.inclusion Option.none (boundaryToRegularFamily i x) =
+      (boundaryToOverlap i x).val :=
+  ThreefoldHomology.inclusion_overlapToRegularFamily i (boundaryToOverlap i x)
+
+private theorem ThreefoldOverlapMappingTorus.boundaryToFilling_ambient
+    (i : SpecialPeriods.Threefold.Puncture) (x : Boundary i) :
+    SpecialPeriods.Threefold.inclusion (Option.some i) (boundaryToFilling i x) =
+      (boundaryToOverlap i x).val :=
+  ThreefoldHomology.inclusion_overlapToFilling i (boundaryToOverlap i x)
+
+private theorem
+    ThreefoldOverlapMappingTorus.boundary_maps_agree (i : SpecialPeriods.Threefold.Puncture) :
+    ThreefoldHomology.originalRegularInclusion.comp (boundaryToRegularFamily i) =
+      (ThreefoldHomology.originalPieceInclusion (Option.some i)).comp (boundaryToFilling i) := by
+  apply ContinuousMap.ext
+  intro x
+  exact (boundaryToRegularFamily_ambient i x).trans (boundaryToFilling_ambient i x).symm
+
+@[simp]
+private theorem
+    ThreefoldOverlapMappingTorus.boundaryToOverlap_cusp_piece (x : Boundary Option.none) :
+    overlapPieceHomeomorph Option.none (boundaryToOverlap Option.none x) =
+      Cusp.specialBoundaryInclusion x :=
+  (overlapPieceHomeomorph Option.none).apply_symm_apply _
+
+@[simp]
+private theorem ThreefoldOverlapMappingTorus.boundaryToOverlap_elliptic_piece (j : Elliptic.Kind)
+    (x : Boundary (Option.some j)) :
+    overlapPieceHomeomorph (Option.some j) (boundaryToOverlap (Option.some j) x) =
+      Elliptic.specialBoundaryInclusion j x :=
+  (overlapPieceHomeomorph (Option.some j)).apply_symm_apply _
+
+private theorem ThreefoldOverlapMappingTorus.boundaryToFilling_cusp :
+    boundaryToFilling Option.none = Cusp.specialBoundaryToPiece := by
+  apply ContinuousMap.ext
+  intro x
+  exact congrArg Subtype.val (boundaryToOverlap_cusp_piece x)
+
+private theorem ThreefoldOverlapMappingTorus.boundaryToFilling_elliptic (j : Elliptic.Kind) :
+    boundaryToFilling (Option.some j) = Elliptic.specialBoundaryToPiece j := by
+  apply ContinuousMap.ext
+  intro x
+  exact congrArg Subtype.val (boundaryToOverlap_elliptic_piece j x)
+
+private def ThreefoldOverlapMappingTorus.overlapRetraction (i : SpecialPeriods.Threefold.Puncture) :
+    C(SpecialPeriods.Threefold.RegularOverlap i, Boundary i) :=
+  ⟨overlapMappingTorusHomotopyEquiv i, (overlapMappingTorusHomotopyEquiv i).continuous⟩
+
+private theorem ThreefoldOverlapMappingTorus.boundary_overlap_retraction_homotopic
+    (i : SpecialPeriods.Threefold.Puncture) :
+    ((boundaryToOverlap i).comp (overlapRetraction i)).Homotopic (ContinuousMap.id _) :=
+  (overlapMappingTorusHomotopyEquiv i).left_inv
+
+private theorem ThreefoldOverlapMappingTorus.boundary_regular_retraction_homotopic
+    (i : SpecialPeriods.Threefold.Puncture) :
+    ((boundaryToRegularFamily i).comp (overlapRetraction i)).Homotopic
+      (ThreefoldHomology.overlapToRegularFamily i) := by
+  simpa only [boundaryToRegularFamily, ContinuousMap.comp_assoc, ContinuousMap.comp_id] using
+    (ContinuousMap.Homotopic.refl (ThreefoldHomology.overlapToRegularFamily i)).comp
+      (boundary_overlap_retraction_homotopic i)
+
+private theorem ThreefoldOverlapMappingTorus.boundary_filling_retraction_homotopic
+    (i : SpecialPeriods.Threefold.Puncture) :
+    ((boundaryToFilling i).comp (overlapRetraction i)).Homotopic
+      (ThreefoldHomology.overlapToFilling i) := by
+  simpa only [boundaryToFilling, ContinuousMap.comp_assoc, ContinuousMap.comp_id] using
+    (ContinuousMap.Homotopic.refl (ThreefoldHomology.overlapToFilling i)).comp
+      (boundary_overlap_retraction_homotopic i)
+
+private def
+    ThreefoldOverlapMappingTorus.fibreToRegularFamily (i : SpecialPeriods.Threefold.Puncture) :
+    C(RealTorus₄, SpecialPeriods.Threefold.SpecialRegularFamily) :=
+  (boundaryToRegularFamily i).comp (MappingTorus.HomologyCover.fibreInclusion (monodromy i))
+
+private def ThreefoldOverlapMappingTorus.fibreToFilling (i : SpecialPeriods.Threefold.Puncture) :
+    C(RealTorus₄, SpecialPeriods.Threefold.localPiece (Option.some i)) :=
+  (boundaryToFilling i).comp (MappingTorus.HomologyCover.fibreInclusion (monodromy i))
+
+private def
+    ThreefoldOverlapMappingTorus.overlapHomologyEquiv (i : SpecialPeriods.Threefold.Puncture)
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.RegularOverlap i) n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (Boundary i) n :=
+  PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (overlapMappingTorusHomotopyEquiv i) n
+
+@[simp]
+private theorem ThreefoldOverlapMappingTorus.overlapHomologyEquiv_toLinearMap
+    (i : SpecialPeriods.Threefold.Puncture) (n : ℕ) :
+    (overlapHomologyEquiv i n).toLinearMap =
+      SingularMayerVietoris.singularHomologyMap (overlapRetraction i) n :=
+  rfl
+
+private def ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap
+    (i : SpecialPeriods.Threefold.Puncture) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (Boundary i) n →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.SpecialRegularFamily n :=
+  SingularMayerVietoris.singularHomologyMap (boundaryToRegularFamily i) n
+
+private def ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap
+    (i : SpecialPeriods.Threefold.Puncture) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (Boundary i) n →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (SpecialPeriods.Threefold.localPiece (Option.some i))
+        n :=
+  SingularMayerVietoris.singularHomologyMap (boundaryToFilling i) n
+
+private theorem ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap_eq
+    (i : SpecialPeriods.Threefold.Puncture) (n : ℕ) :
+    boundaryFillingHomologyMap i n =
+      (SingularMayerVietoris.singularHomologyMap (ThreefoldHomology.overlapToFilling i) n).comp
+        (overlapHomologyEquiv i n).symm.toLinearMap :=
+  PeriodTorusHigherHomology.singularHomologyMap_comp (boundaryToOverlap i)
+    (ThreefoldHomology.overlapToFilling i) n
+
+private theorem ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap_retraction
+    (i : SpecialPeriods.Threefold.Puncture) (n : ℕ) :
+    (boundaryRegularHomologyMap i n).comp (overlapHomologyEquiv i n).toLinearMap =
+      SingularMayerVietoris.singularHomologyMap (ThreefoldHomology.overlapToRegularFamily i) n := by
+  rw [overlapHomologyEquiv_toLinearMap]
+  change
+    (SingularMayerVietoris.singularHomologyMap (boundaryToRegularFamily i) n).comp
+        (SingularMayerVietoris.singularHomologyMap (overlapRetraction i) n) =
+      _
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp]
+  exact
+    PeriodTorusHigherHomology.homotopic_homologyMap (boundary_regular_retraction_homotopic i) n
+
+private theorem ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap_retraction
+    (i : SpecialPeriods.Threefold.Puncture) (n : ℕ) :
+    (boundaryFillingHomologyMap i n).comp (overlapHomologyEquiv i n).toLinearMap =
+      SingularMayerVietoris.singularHomologyMap (ThreefoldHomology.overlapToFilling i) n := by
+  rw [overlapHomologyEquiv_toLinearMap]
+  change
+    (SingularMayerVietoris.singularHomologyMap (boundaryToFilling i) n).comp
+        (SingularMayerVietoris.singularHomologyMap (overlapRetraction i) n) =
+      _
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp]
+  exact
+    PeriodTorusHigherHomology.homotopic_homologyMap (boundary_filling_retraction_homotopic i) n
+
+private theorem ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap_fibre
+    (i : SpecialPeriods.Threefold.Puncture) (n : ℕ) :
+    (boundaryRegularHomologyMap i n).comp
+        (SingularMayerVietoris.singularHomologyMap
+          (MappingTorus.HomologyCover.fibreInclusion (monodromy i)) n) =
+      SingularMayerVietoris.singularHomologyMap (fibreToRegularFamily i) n :=
+  (PeriodTorusHigherHomology.singularHomologyMap_comp
+      (MappingTorus.HomologyCover.fibreInclusion (monodromy i)) (boundaryToRegularFamily i)
+      n).symm
+
+private theorem ThreefoldOverlapMappingTorus.boundaryFillingHomologyMap_fibre
+    (i : SpecialPeriods.Threefold.Puncture) (n : ℕ) :
+    (boundaryFillingHomologyMap i n).comp
+        (SingularMayerVietoris.singularHomologyMap
+          (MappingTorus.HomologyCover.fibreInclusion (monodromy i)) n) =
+      SingularMayerVietoris.singularHomologyMap (fibreToFilling i) n :=
+  (PeriodTorusHigherHomology.singularHomologyMap_comp
+      (MappingTorus.HomologyCover.fibreInclusion (monodromy i)) (boundaryToFilling i) n).symm
+
+private def MappingTorusHomology.Algebra.difference {M : Type*} [AddCommGroup M] [Module ℤ M]
+    (F : M →ₗ[ℤ] M) : M →ₗ[ℤ] M :=
+  LinearMap.id - F
+
+private def MappingTorusHomology.Algebra.twoArcMap {M : Type*} [AddCommGroup M] [Module ℤ M]
+    (F : M →ₗ[ℤ] M) : (M × M) →ₗ[ℤ] (M × M) :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun p := (p.1 + p.2, -(p.1 + F p.2))
+      map_zero' := by simp
+      map_add' p
+        q := by
+        apply Prod.ext
+        · exact add_add_add_comm p.1 q.1 p.2 q.2
+        · change -((p.1 + q.1) + F (p.2 + q.2)) = -(p.1 + F p.2) + -(q.1 + F q.2)
+          rw [map_add]
+          abel }
+
+@[simp]
+private theorem
+    MappingTorusHomology.Algebra.twoArcMap_apply {M : Type*} [AddCommGroup M] [Module ℤ M]
+    (F : M →ₗ[ℤ] M) (p : M × M) : twoArcMap F p = (p.1 + p.2, -(p.1 + F p.2)) :=
+  rfl
+
+private theorem
+    MappingTorusHomology.Algebra.pairSum_twoArcMap {M : Type*} [AddCommGroup M] [Module ℤ M]
+    (F : M →ₗ[ℤ] M) (p : M × M) :
+    PeriodTorusHigherHomology.pairSumMap M (twoArcMap F p) = difference F p.2 := by
+  change (p.1 + p.2) + -(p.1 + F p.2) = p.2 - F p.2
+  abel
+
+private theorem MappingTorusHomology.Algebra.twoArcMap_kernel_iff {M : Type*} [AddCommGroup M]
+    [Module ℤ M] (F : M →ₗ[ℤ] M) (p : M × M) :
+    twoArcMap F p = 0 ↔ p.1 = -p.2 ∧ difference F p.2 = 0 := by
+  constructor
+  · intro hp
+    have hsum : p.1 + p.2 = 0 := congrArg Prod.fst hp
+    refine ⟨eq_neg_of_add_eq_zero_left hsum, ?_⟩
+    rw [← pairSum_twoArcMap F p, hp, map_zero]
+  · rintro ⟨hfst, hfix⟩
+    have hF : F p.2 = p.2 := (sub_eq_zero.mp hfix).symm
+    rw [twoArcMap_apply, hfst, hF, neg_add_cancel, neg_zero]
+    rfl
+
+private theorem MappingTorusHomology.Algebra.range_difference_eq_ker {M N : Type*} [AddCommGroup M]
+    [Module ℤ M] [AddCommGroup N] [Module ℤ N] (F : M →ₗ[ℤ] M) (i : M →ₗ[ℤ] N)
+    (hJ :
+      LinearMap.range (twoArcMap F) =
+        LinearMap.ker (i.comp (PeriodTorusHigherHomology.pairSumMap M))) :
+    LinearMap.range (difference F) = LinearMap.ker i := by
+  ext x
+  constructor
+  · rintro ⟨b, rfl⟩
+    have hb : twoArcMap F (0, b) ∈ LinearMap.range (twoArcMap F) := ⟨(0, b), rfl⟩
+    rw [hJ] at hb
+    change i (PeriodTorusHigherHomology.pairSumMap M (twoArcMap F (0, b))) = 0 at hb
+    rw [pairSum_twoArcMap] at hb
+    exact hb
+  · intro hx
+    have hix : i x = 0 := LinearMap.mem_ker.mp hx
+    have hp : (x, 0) ∈ LinearMap.ker (i.comp (PeriodTorusHigherHomology.pairSumMap M)) := by
+      change i (x + 0) = 0
+      simpa only [add_zero] using hix
+    rw [← hJ] at hp
+    obtain ⟨p, hp⟩ := hp
+    refine ⟨p.2, ?_⟩
+    calc
+      difference F p.2 = PeriodTorusHigherHomology.pairSumMap M (twoArcMap F p) :=
+        (pairSum_twoArcMap F p).symm
+      _ = x := by rw [hp, PeriodTorusHigherHomology.pairSumMap_apply, add_zero]
+
+private def MappingTorusHomology.Algebra.boundary {N P : Type*} [AddCommGroup N] [Module ℤ N]
+    [AddCommGroup P] [Module ℤ P] (d : N →ₗ[ℤ] (P × P)) : N →ₗ[ℤ] P :=
+  (PeriodTorusHigherHomology.negativeFirstMap P).comp d
+
+@[simp]
+private theorem
+    MappingTorusHomology.Algebra.boundary_apply {N P : Type*} [AddCommGroup N] [Module ℤ N]
+    [AddCommGroup P] [Module ℤ P] (d : N →ₗ[ℤ] (P × P)) (n : N) : boundary d n = -(d n).1 :=
+  rfl
+
+private theorem MappingTorusHomology.Algebra.connecting_mem_kernel {N P : Type*} [AddCommGroup N]
+    [Module ℤ N] [AddCommGroup P] [Module ℤ P] (F : P →ₗ[ℤ] P) (d : N →ₗ[ℤ] (P × P))
+    (hd : LinearMap.range d = LinearMap.ker (twoArcMap F)) (n : N) :
+    d n ∈ LinearMap.ker (twoArcMap F) := by
+  rw [← hd]
+  exact ⟨n, rfl⟩
+
+private theorem
+    MappingTorusHomology.Algebra.boundary_eq_snd {N P : Type*} [AddCommGroup N] [Module ℤ N]
+    [AddCommGroup P] [Module ℤ P] (F : P →ₗ[ℤ] P) (d : N →ₗ[ℤ] (P × P))
+    (hd : LinearMap.range d = LinearMap.ker (twoArcMap F)) (n : N) : boundary d n = (d n).2 := by
+  have hp := (twoArcMap_kernel_iff F (d n)).mp (connecting_mem_kernel F d hd n)
+  rw [boundary_apply, hp.1, neg_neg]
+
+private theorem
+    MappingTorusHomology.Algebra.connecting_eq_antidiagonal {N P : Type*} [AddCommGroup N]
+    [Module ℤ N] [AddCommGroup P] [Module ℤ P] (F : P →ₗ[ℤ] P) (d : N →ₗ[ℤ] (P × P))
+    (hd : LinearMap.range d = LinearMap.ker (twoArcMap F)) (n : N) :
+    d n = (-boundary d n, boundary d n) := by
+  apply Prod.ext
+  · simp only [boundary_apply, neg_neg]
+  · exact (boundary_eq_snd F d hd n).symm
+
+private theorem MappingTorusHomology.Algebra.boundary_mem_kernel {N P : Type*} [AddCommGroup N]
+    [Module ℤ N] [AddCommGroup P] [Module ℤ P] (F : P →ₗ[ℤ] P) (d : N →ₗ[ℤ] (P × P))
+    (hd : LinearMap.range d = LinearMap.ker (twoArcMap F)) (n : N) :
+    boundary d n ∈ LinearMap.ker (difference F) := by
+  rw [boundary_eq_snd F d hd n]
+  exact ((twoArcMap_kernel_iff F (d n)).mp (connecting_mem_kernel F d hd n)).2
+
+private theorem
+    MappingTorusHomology.Algebra.boundary_range {N P : Type*} [AddCommGroup N] [Module ℤ N]
+    [AddCommGroup P] [Module ℤ P] (F : P →ₗ[ℤ] P) (d : N →ₗ[ℤ] (P × P))
+    (hd : LinearMap.range d = LinearMap.ker (twoArcMap F)) :
+    LinearMap.range (boundary d) = LinearMap.ker (difference F) := by
+  ext b
+  constructor
+  · rintro ⟨n, rfl⟩
+    exact boundary_mem_kernel F d hd n
+  · intro hb
+    have hp : (-b, b) ∈ LinearMap.ker (twoArcMap F) :=
+      (twoArcMap_kernel_iff F (-b, b)).mpr ⟨rfl, hb⟩
+    rw [← hd] at hp
+    obtain ⟨n, hn⟩ := hp
+    refine ⟨n, ?_⟩
+    rw [boundary_apply, hn]
+    exact neg_neg b
+
+private theorem
+    MappingTorusHomology.Algebra.boundary_ker {N P : Type*} [AddCommGroup N] [Module ℤ N]
+    [AddCommGroup P] [Module ℤ P] (F : P →ₗ[ℤ] P) (d : N →ₗ[ℤ] (P × P))
+    (hd : LinearMap.range d = LinearMap.ker (twoArcMap F)) :
+    LinearMap.ker (boundary d) = LinearMap.ker d := by
+  ext n
+  change boundary d n = 0 ↔ d n = 0
+  constructor
+  · intro hn
+    rw [connecting_eq_antidiagonal F d hd n, hn, neg_zero]
+    rfl
+  · intro hn
+    rw [boundary_apply, hn]
+    exact neg_zero
+
+private theorem MappingTorusHomology.Algebra.range_inclusion_eq_ker_boundary {M N P : Type*}
+    [AddCommGroup M] [Module ℤ M] [AddCommGroup N] [Module ℤ N] [AddCommGroup P] [Module ℤ P]
+    (F : P →ₗ[ℤ] P) (i : M →ₗ[ℤ] N) (d : N →ₗ[ℤ] (P × P))
+    (hi : LinearMap.range i = LinearMap.ker d)
+    (hd : LinearMap.range d = LinearMap.ker (twoArcMap F)) :
+    LinearMap.range i = LinearMap.ker (boundary d) :=
+  hi.trans (boundary_ker F d hd).symm
+
+private abbrev
+    MappingTorusHomology.monodromyHomologyMap {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology X n →ₗ[ℤ] SingularMayerVietoris.SingularHomology X n :=
+  SingularMayerVietoris.singularHomologyMap (f : C(X, X)) n
+
+private abbrev MappingTorusHomology.fibreHomologyMap {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology X n →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) n :=
+  SingularMayerVietoris.singularHomologyMap (MappingTorus.HomologyCover.fibreInclusion f) n
+
+private def
+    MappingTorusHomology.arcHomologyEquiv {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) (n : ℕ) :
+    (SingularMayerVietoris.SingularHomology (MappingTorus.HomologyCover.U f) n ×
+        SingularMayerVietoris.SingularHomology (MappingTorus.HomologyCover.V f) n) ≃ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology X n × SingularMayerVietoris.SingularHomology X n) :=
+  ((PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+          (MappingTorus.HomologyCover.homotopyEquivU f) n).toAddEquiv.prodCongr
+      (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+          (MappingTorus.HomologyCover.homotopyEquivV f) n).toAddEquiv).toIntLinearEquiv
+
+private def
+    MappingTorusHomology.intersectionHomologyEquiv {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology
+        (MappingTorus.HomologyCover.U f ∩ MappingTorus.HomologyCover.V f :
+          Set (MappingTorus.Torus f))
+        n ≃ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology X n × SingularMayerVietoris.SingularHomology X n) :=
+  (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+        (MappingTorus.HomologyCover.intersectionHomotopyEquiv f) n).trans
+    (PeriodTorusHigherHomology.sumHomologyEquiv X X n)
+
+@[simp]
+private theorem MappingTorusHomology.intersectionHomologyEquiv_apply {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (MappingTorus.HomologyCover.U f ∩ MappingTorus.HomologyCover.V f :
+          Set (MappingTorus.Torus f))
+        n) :
+    intersectionHomologyEquiv f n a =
+      PeriodTorusHigherHomology.sumHomologyEquiv X X n
+        (SingularMayerVietoris.singularHomologyMap
+          (MappingTorus.HomologyCover.intersectionHomotopyEquiv f).toFun n a) :=
+  rfl
+
+private theorem
+    MappingTorusHomology.inclusionU_homology {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (MappingTorus.HomologyCover.inclusionU f) n =
+      (fibreHomologyMap f n).comp
+        (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+            (MappingTorus.HomologyCover.homotopyEquivU f) n).toLinearMap := by
+  rw [PeriodTorusHigherHomology.homotopy_homologyMap
+      (MappingTorus.HomologyCover.inclusionUHomotopy f) n,
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+  rfl
+
+private theorem
+    MappingTorusHomology.inclusionV_homology {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (MappingTorus.HomologyCover.inclusionV f) n =
+      (fibreHomologyMap f n).comp
+        (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+            (MappingTorus.HomologyCover.homotopyEquivV f) n).toLinearMap := by
+  rw [PeriodTorusHigherHomology.homotopy_homologyMap
+      (MappingTorus.HomologyCover.inclusionVHomotopy f) n,
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+  rfl
+
+private theorem
+    MappingTorusHomology.intersectionToU_homology {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (MappingTorus.HomologyCover.U f ∩ MappingTorus.HomologyCover.V f :
+          Set (MappingTorus.Torus f))
+        n) :
+    PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+        (MappingTorus.HomologyCover.homotopyEquivU f) n
+        (SingularMayerVietoris.singularHomologyMap (MappingTorus.HomologyCover.intersectionToU f)
+          n a) =
+      (intersectionHomologyEquiv f n a).1 + (intersectionHomologyEquiv f n a).2 := by
+  change
+    SingularMayerVietoris.singularHomologyMap (MappingTorus.HomologyCover.homotopyEquivU f).toFun
+        n
+        (SingularMayerVietoris.singularHomologyMap (MappingTorus.HomologyCover.intersectionToU f)
+          n a) =
+      _
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    MappingTorus.HomologyCover.intersectionToU_fold,
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+  simp only [LinearMap.comp_apply, intersectionHomologyEquiv_apply]
+  exact
+    PeriodTorusHigherHomology.sumHomologyEquiv_fold (X := X) n
+      (SingularMayerVietoris.singularHomologyMap
+        (MappingTorus.HomologyCover.intersectionHomotopyEquiv f).toFun n a)
+
+private theorem
+    MappingTorusHomology.intersectionToV_homology {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (MappingTorus.HomologyCover.U f ∩ MappingTorus.HomologyCover.V f :
+          Set (MappingTorus.Torus f))
+        n) :
+    PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+        (MappingTorus.HomologyCover.homotopyEquivV f) n
+        (SingularMayerVietoris.singularHomologyMap (MappingTorus.HomologyCover.intersectionToV f)
+          n a) =
+      (intersectionHomologyEquiv f n a).1 +
+        monodromyHomologyMap f n (intersectionHomologyEquiv f n a).2 := by
+  change
+    SingularMayerVietoris.singularHomologyMap (MappingTorus.HomologyCover.homotopyEquivV f).toFun
+        n
+        (SingularMayerVietoris.singularHomologyMap (MappingTorus.HomologyCover.intersectionToV f)
+          n a) =
+      _
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    MappingTorus.HomologyCover.intersectionToV_twistedFold,
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+  simp only [LinearMap.comp_apply, intersectionHomologyEquiv_apply]
+  have h :=
+    PeriodTorusHigherHomology.sumHomologyEquiv_sumElim (ContinuousMap.id X) (f : C(X, X)) n
+      (SingularMayerVietoris.singularHomologyMap
+        (MappingTorus.HomologyCover.intersectionHomotopyEquiv f).toFun n a)
+  simpa only [PeriodTorusHigherHomology.singularHomologyMap_id, LinearMap.id_apply] using h
+
+private theorem MappingTorusHomology.leftHomologyMap_coordinates {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (MappingTorus.HomologyCover.U f ∩ MappingTorus.HomologyCover.V f :
+          Set (MappingTorus.Torus f))
+        n) :
+    arcHomologyEquiv f n
+        (SingularMayerVietoris.leftHomologyMap (MappingTorus.HomologyCover.U f)
+          (MappingTorus.HomologyCover.V f) n a) =
+      Algebra.twoArcMap (monodromyHomologyMap f n) (intersectionHomologyEquiv f n a) := by
+  rw [SingularMayerVietoris.leftHomologyMap_apply]
+  change
+    (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+          (MappingTorus.HomologyCover.homotopyEquivU f) n
+          (SingularMayerVietoris.singularHomologyMap
+            (MappingTorus.HomologyCover.intersectionToU f) n a),
+        PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+          (MappingTorus.HomologyCover.homotopyEquivV f) n
+          (-SingularMayerVietoris.singularHomologyMap
+              (MappingTorus.HomologyCover.intersectionToV f) n a)) =
+      _
+  rw [map_neg, intersectionToU_homology, intersectionToV_homology]
+  rfl
+
+private theorem MappingTorusHomology.rightHomologyMap_coordinates {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology (MappingTorus.HomologyCover.U f) n ×
+        SingularMayerVietoris.SingularHomology (MappingTorus.HomologyCover.V f) n) :
+    SingularMayerVietoris.rightHomologyMap (MappingTorus.HomologyCover.U f)
+        (MappingTorus.HomologyCover.V f) n a =
+      fibreHomologyMap f n ((arcHomologyEquiv f n a).1 + (arcHomologyEquiv f n a).2) := by
+  rw [SingularMayerVietoris.rightHomologyMap_apply]
+  change
+    SingularMayerVietoris.singularHomologyMap (MappingTorus.HomologyCover.inclusionU f) n a.1 +
+        SingularMayerVietoris.singularHomologyMap (MappingTorus.HomologyCover.inclusionV f) n
+          a.2 =
+      _
+  rw [inclusionU_homology, inclusionV_homology]
+  exact (map_add (fibreHomologyMap f n) _ _).symm
+
+private def
+    MappingTorusHomology.Algebra.cokernelInclusion {M N : Type*} [AddCommGroup M] [Module ℤ M]
+    [AddCommGroup N] [Module ℤ N] (F : M →ₗ[ℤ] M) (i : M →ₗ[ℤ] N)
+    (hJ :
+      LinearMap.range (twoArcMap F) =
+        LinearMap.ker (i.comp (PeriodTorusHigherHomology.pairSumMap M))) :
+    (M ⧸ LinearMap.range (difference F)) →ₗ[ℤ] N :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    ((LinearMap.range (difference F)).liftQ i (range_difference_eq_ker F i hJ).le).toAddMonoidHom
+
+private theorem
+    MappingTorusHomology.Algebra.cokernelInclusion_injective {M N : Type*} [AddCommGroup M]
+    [Module ℤ M] [AddCommGroup N] [Module ℤ N] (F : M →ₗ[ℤ] M) (i : M →ₗ[ℤ] N)
+    (hJ :
+      LinearMap.range (twoArcMap F) =
+        LinearMap.ker (i.comp (PeriodTorusHigherHomology.pairSumMap M))) :
+    Function.Injective (cokernelInclusion F i hJ) := by
+  intro x y hxy
+  obtain ⟨a, rfl⟩ := (LinearMap.range (difference F)).mkQ_surjective x
+  obtain ⟨b, rfl⟩ := (LinearMap.range (difference F)).mkQ_surjective y
+  change i a = i b at hxy
+  apply (Submodule.Quotient.eq (LinearMap.range (difference F))).mpr
+  rw [range_difference_eq_ker F i hJ]
+  change i (a - b) = 0
+  rw [map_sub, hxy, sub_self]
+
+private theorem MappingTorusHomology.Algebra.cokernelInclusion_range {M N : Type*} [AddCommGroup M]
+    [Module ℤ M] [AddCommGroup N] [Module ℤ N] (F : M →ₗ[ℤ] M) (i : M →ₗ[ℤ] N)
+    (hJ :
+      LinearMap.range (twoArcMap F) =
+        LinearMap.ker (i.comp (PeriodTorusHigherHomology.pairSumMap M))) :
+    LinearMap.range (cokernelInclusion F i hJ) = LinearMap.range i := by
+  ext n
+  constructor
+  · rintro ⟨x, rfl⟩
+    obtain ⟨a, rfl⟩ := (LinearMap.range (difference F)).mkQ_surjective x
+    exact ⟨a, rfl⟩
+  · rintro ⟨a, rfl⟩
+    exact ⟨Submodule.Quotient.mk a, rfl⟩
+
+private def MappingTorusHomology.Algebra.kernelBoundary {N P : Type*} [AddCommGroup N] [Module ℤ N]
+    [AddCommGroup P] [Module ℤ P] (F : P →ₗ[ℤ] P) (d : N →ₗ[ℤ] (P × P))
+    (hd : LinearMap.range d = LinearMap.ker (twoArcMap F)) :
+    N →ₗ[ℤ] LinearMap.ker (difference F) :=
+  PeriodTorusHigherHomology.intLinearMapOfAddHom
+    { toFun n := ⟨boundary d n, boundary_mem_kernel F d hd n⟩
+      map_zero' := by
+        apply Subtype.ext
+        exact map_zero (boundary d)
+      map_add' n
+        m := by
+        apply Subtype.ext
+        exact map_add (boundary d) n m }
+
+private theorem
+    MappingTorusHomology.Algebra.kernelBoundary_eq_zero_iff {N P : Type*} [AddCommGroup N]
+    [Module ℤ N] [AddCommGroup P] [Module ℤ P] (F : P →ₗ[ℤ] P) (d : N →ₗ[ℤ] (P × P))
+    (hd : LinearMap.range d = LinearMap.ker (twoArcMap F)) (n : N) :
+    kernelBoundary F d hd n = 0 ↔ boundary d n = 0 := by
+  constructor
+  · intro hn
+    exact congrArg Subtype.val hn
+  · intro hn
+    exact Subtype.ext hn
+
+private theorem MappingTorusHomology.Algebra.kernelBoundary_ker {N P : Type*} [AddCommGroup N]
+    [Module ℤ N] [AddCommGroup P] [Module ℤ P] (F : P →ₗ[ℤ] P) (d : N →ₗ[ℤ] (P × P))
+    (hd : LinearMap.range d = LinearMap.ker (twoArcMap F)) :
+    LinearMap.ker (kernelBoundary F d hd) = LinearMap.ker (boundary d) := by
+  ext n
+  exact kernelBoundary_eq_zero_iff F d hd n
+
+private theorem
+    MappingTorusHomology.Algebra.kernelBoundary_surjective {N P : Type*} [AddCommGroup N]
+    [Module ℤ N] [AddCommGroup P] [Module ℤ P] (F : P →ₗ[ℤ] P) (d : N →ₗ[ℤ] (P × P))
+    (hd : LinearMap.range d = LinearMap.ker (twoArcMap F)) :
+    Function.Surjective (kernelBoundary F d hd) := by
+  intro b
+  have hb : (b : P) ∈ LinearMap.range (boundary d) := by
+    rw [boundary_range F d hd]
+    exact b.property
+  obtain ⟨n, hn⟩ := hb
+  exact ⟨n, Subtype.ext hn⟩
+
+private theorem
+    MappingTorusHomology.Algebra.cokernelInclusion_range_eq_ker_kernelBoundary {M N P : Type*}
+    [AddCommGroup M] [Module ℤ M] [AddCommGroup N] [Module ℤ N] [AddCommGroup P] [Module ℤ P]
+    (F : M →ₗ[ℤ] M) (F' : P →ₗ[ℤ] P) (i : M →ₗ[ℤ] N) (d : N →ₗ[ℤ] (P × P))
+    (hJ :
+      LinearMap.range (twoArcMap F) =
+        LinearMap.ker (i.comp (PeriodTorusHigherHomology.pairSumMap M)))
+    (hi : LinearMap.range i = LinearMap.ker d)
+    (hd : LinearMap.range d = LinearMap.ker (twoArcMap F')) :
+    LinearMap.range (cokernelInclusion F i hJ) = LinearMap.ker (kernelBoundary F' d hd) := by
+  rw [cokernelInclusion_range, kernelBoundary_ker, boundary_ker F' d hd]
+  exact hi
+
+private def
+    MappingTorusHomology.wangDifference {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology X n →ₗ[ℤ] SingularMayerVietoris.SingularHomology X n :=
+  Algebra.difference (monodromyHomologyMap f n)
+
+@[simp]
+private theorem
+    MappingTorusHomology.wangDifference_apply {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    wangDifference f n a = a - SingularMayerVietoris.singularHomologyMap (f : C(X, X)) n a :=
+  rfl
+
+private theorem
+    MappingTorusHomology.twoArc_exact_at_pair {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (n : ℕ) :
+    LinearMap.range (Algebra.twoArcMap (monodromyHomologyMap f n)) =
+      LinearMap.ker
+        ((fibreHomologyMap f n).comp
+          (PeriodTorusHigherHomology.pairSumMap (SingularMayerVietoris.SingularHomology X n))) := by
+  ext a
+  constructor
+  · rintro ⟨b, rfl⟩
+    have h :=
+      LinearMap.congr_fun
+        (SingularMayerVietoris.leftHomologyMap_comp_right (MappingTorus.HomologyCover.U f)
+          (MappingTorus.HomologyCover.V f) n)
+        ((intersectionHomologyEquiv f n).symm b)
+    change
+      SingularMayerVietoris.rightHomologyMap (MappingTorus.HomologyCover.U f)
+          (MappingTorus.HomologyCover.V f) n
+          (SingularMayerVietoris.leftHomologyMap (MappingTorus.HomologyCover.U f)
+            (MappingTorus.HomologyCover.V f) n ((intersectionHomologyEquiv f n).symm b)) =
+        0 at h
+    rw [rightHomologyMap_coordinates, leftHomologyMap_coordinates,
+      LinearEquiv.apply_symm_apply] at h
+    exact h
+  · intro ha
+    have hright :
+      (arcHomologyEquiv f n).symm a ∈
+        LinearMap.ker
+          (SingularMayerVietoris.rightHomologyMap (MappingTorus.HomologyCover.U f)
+            (MappingTorus.HomologyCover.V f) n) := by
+      change
+        SingularMayerVietoris.rightHomologyMap (MappingTorus.HomologyCover.U f)
+            (MappingTorus.HomologyCover.V f) n ((arcHomologyEquiv f n).symm a) =
+          0
+      rw [rightHomologyMap_coordinates, LinearEquiv.apply_symm_apply]
+      exact ha
+    rw [←
+      SingularMayerVietoris.exact_at_pair (MappingTorus.HomologyCover.U f)
+        (MappingTorus.HomologyCover.V f) (MappingTorus.HomologyCover.U_open f)
+        (MappingTorus.HomologyCover.V_open f) (MappingTorus.HomologyCover.cover f) n] at hright
+    obtain ⟨b, hb⟩ := hright
+    refine ⟨intersectionHomologyEquiv f n b, ?_⟩
+    rw [← leftHomologyMap_coordinates, hb, LinearEquiv.apply_symm_apply]
+
+private abbrev
+    MappingTorusHomology.mayerVietorisConnecting {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) (n + 1) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology
+        (MappingTorus.HomologyCover.U f ∩ MappingTorus.HomologyCover.V f :
+          Set (MappingTorus.Torus f))
+        n :=
+  SingularMayerVietoris.connectingHomomorphism (MappingTorus.HomologyCover.U f)
+    (MappingTorus.HomologyCover.V f) (MappingTorus.HomologyCover.U_open f)
+    (MappingTorus.HomologyCover.V_open f) (MappingTorus.HomologyCover.cover f) n
+
+private def MappingTorusHomology.boundaryCoordinates {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) (n + 1) →ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology X n × SingularMayerVietoris.SingularHomology X n) :=
+  (intersectionHomologyEquiv f n).toLinearMap.comp (mayerVietorisConnecting f n)
+
+@[simp]
+private theorem MappingTorusHomology.boundaryCoordinates_apply {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) (n + 1)) :
+    boundaryCoordinates f n a = intersectionHomologyEquiv f n (mayerVietorisConnecting f n a) :=
+  rfl
+
+private theorem MappingTorusHomology.boundaryCoordinates_range {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (n : ℕ) :
+    LinearMap.range (boundaryCoordinates f n) =
+      LinearMap.ker (Algebra.twoArcMap (monodromyHomologyMap f n)) := by
+  ext a
+  constructor
+  · rintro ⟨b, rfl⟩
+    have hb : mayerVietorisConnecting f n b ∈ LinearMap.range (mayerVietorisConnecting f n) :=
+      ⟨b, rfl⟩
+    rw [SingularMayerVietoris.exact_at_intersection (MappingTorus.HomologyCover.U f)
+        (MappingTorus.HomologyCover.V f) (MappingTorus.HomologyCover.U_open f)
+        (MappingTorus.HomologyCover.V_open f) (MappingTorus.HomologyCover.cover f)] at hb
+    have h := congrArg (arcHomologyEquiv f n) hb
+    rw [leftHomologyMap_coordinates, map_zero] at h
+    exact h
+  · intro ha
+    have hl :
+      SingularMayerVietoris.leftHomologyMap (MappingTorus.HomologyCover.U f)
+          (MappingTorus.HomologyCover.V f) n ((intersectionHomologyEquiv f n).symm a) =
+        0 := by
+      apply (arcHomologyEquiv f n).injective
+      rw [leftHomologyMap_coordinates, LinearEquiv.apply_symm_apply, map_zero]
+      exact ha
+    have hr :
+      (intersectionHomologyEquiv f n).symm a ∈ LinearMap.range (mayerVietorisConnecting f n) := by
+      rw [SingularMayerVietoris.exact_at_intersection (MappingTorus.HomologyCover.U f)
+          (MappingTorus.HomologyCover.V f) (MappingTorus.HomologyCover.U_open f)
+          (MappingTorus.HomologyCover.V_open f) (MappingTorus.HomologyCover.cover f)]
+      exact hl
+    obtain ⟨b, hb⟩ := hr
+    refine ⟨b, ?_⟩
+    rw [boundaryCoordinates_apply, hb, LinearEquiv.apply_symm_apply]
+
+private theorem
+    MappingTorusHomology.rightHomologyMap_range {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (n : ℕ) :
+    LinearMap.range
+        (SingularMayerVietoris.rightHomologyMap (MappingTorus.HomologyCover.U f)
+          (MappingTorus.HomologyCover.V f) n) =
+      LinearMap.range (fibreHomologyMap f n) := by
+  ext b
+  constructor
+  · rintro ⟨a, rfl⟩
+    exact
+      ⟨(arcHomologyEquiv f n a).1 + (arcHomologyEquiv f n a).2,
+        (rightHomologyMap_coordinates f n a).symm⟩
+  · rintro ⟨a, rfl⟩
+    refine ⟨(arcHomologyEquiv f n).symm (a, 0), ?_⟩
+    rw [rightHomologyMap_coordinates, LinearEquiv.apply_symm_apply]
+    exact congrArg (fibreHomologyMap f n) (add_zero a)
+
+private theorem
+    MappingTorusHomology.boundaryCoordinates_ker {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (n : ℕ) :
+    LinearMap.range (fibreHomologyMap f (n + 1)) = LinearMap.ker (boundaryCoordinates f n) := by
+  rw [boundaryCoordinates, SingularMayerVietoris.rightTransport_second_ker]
+  rw [←
+    SingularMayerVietoris.exact_at_ambient (MappingTorus.HomologyCover.U f)
+      (MappingTorus.HomologyCover.V f) (MappingTorus.HomologyCover.U_open f)
+      (MappingTorus.HomologyCover.V_open f) (MappingTorus.HomologyCover.cover f)]
+  exact (rightHomologyMap_range f (n + 1)).symm
+
+private def MappingTorusHomology.wangBoundary {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) (n + 1) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology X n :=
+  Algebra.boundary (boundaryCoordinates f n)
+
+@[simp]
+private theorem MappingTorusHomology.wangBoundary_apply {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (n : ℕ) (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) (n + 1)) :
+    wangBoundary f n a = -(boundaryCoordinates f n a).1 :=
+  rfl
+
+private theorem
+    MappingTorusHomology.boundaryCoordinates_eq_antidiagonal {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) (n + 1)) :
+    boundaryCoordinates f n a = (-wangBoundary f n a, wangBoundary f n a) :=
+  Algebra.connecting_eq_antidiagonal _ _ (boundaryCoordinates_range f n) a
+
+private theorem
+    MappingTorusHomology.wang_exact_at_fibre {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (n : ℕ) : LinearMap.range (wangDifference f n) = LinearMap.ker (fibreHomologyMap f n) :=
+  Algebra.range_difference_eq_ker _ _ (twoArc_exact_at_pair f n)
+
+private theorem MappingTorusHomology.wang_exact_at_mappingTorus {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (n : ℕ) :
+    LinearMap.range (fibreHomologyMap f (n + 1)) = LinearMap.ker (wangBoundary f n) :=
+  Algebra.range_inclusion_eq_ker_boundary _ _ _ (boundaryCoordinates_ker f n)
+    (boundaryCoordinates_range f n)
+
+private theorem MappingTorusHomology.wangBoundary_range {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (n : ℕ) : LinearMap.range (wangBoundary f n) = LinearMap.ker (wangDifference f n) :=
+  Algebra.boundary_range _ _ (boundaryCoordinates_range f n)
+
+private def
+    MappingTorusHomology.cokernelInclusion {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) (n : ℕ) :
+    (SingularMayerVietoris.SingularHomology X n ⧸ LinearMap.range (wangDifference f n)) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) n :=
+  Algebra.cokernelInclusion _ _ (twoArc_exact_at_pair f n)
+
+@[simp]
+private theorem
+    MappingTorusHomology.cokernelInclusion_mk {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    cokernelInclusion f n (Submodule.Quotient.mk a) = fibreHomologyMap f n a :=
+  rfl
+
+private theorem MappingTorusHomology.cokernelInclusion_injective {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (n : ℕ) : Function.Injective (cokernelInclusion f n) :=
+  Algebra.cokernelInclusion_injective _ _ (twoArc_exact_at_pair f n)
+
+private def
+    MappingTorusHomology.kernelBoundary {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) (n + 1) →ₗ[ℤ]
+      LinearMap.ker (wangDifference f n) :=
+  Algebra.kernelBoundary _ _ (boundaryCoordinates_range f n)
+
+private theorem MappingTorusHomology.kernelBoundary_surjective {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (n : ℕ) : Function.Surjective (kernelBoundary f n) :=
+  Algebra.kernelBoundary_surjective _ _ (boundaryCoordinates_range f n)
+
+private theorem MappingTorusHomology.cokernelInclusion_range_eq_ker_kernelBoundary {X : Type}
+    [TopologicalSpace X] (f : X ≃ₜ X) (n : ℕ) :
+    LinearMap.range (cokernelInclusion f (n + 1)) = LinearMap.ker (kernelBoundary f n) :=
+  Algebra.cokernelInclusion_range_eq_ker_kernelBoundary _ _ _ _ (twoArc_exact_at_pair f (n + 1))
+    (boundaryCoordinates_ker f n) (boundaryCoordinates_range f n)
+
+private theorem
+    MappingTorusHomology.fibreHomologyMap_zero_surjective {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) : Function.Surjective (fibreHomologyMap f 0) := by
+  intro b
+  obtain ⟨a, ha⟩ :=
+    SingularMayerVietoris.rightHomologyMap_zero_surjective (MappingTorus.HomologyCover.U f)
+      (MappingTorus.HomologyCover.V f) (MappingTorus.HomologyCover.U_open f)
+      (MappingTorus.HomologyCover.V_open f) (MappingTorus.HomologyCover.cover f) b
+  exact
+    ⟨(arcHomologyEquiv f 0 a).1 + (arcHomologyEquiv f 0 a).2,
+      (rightHomologyMap_coordinates f 0 a).symm.trans ha⟩
+
+private theorem
+    MappingTorusHomology.cokernelInclusion_zero_surjective {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) : Function.Surjective (cokernelInclusion f 0) := by
+  intro b
+  obtain ⟨a, ha⟩ := fibreHomologyMap_zero_surjective f b
+  exact ⟨Submodule.Quotient.mk a, ha⟩
+
+private def
+    MappingTorusHomology.degreeZeroHomologyEquiv {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) :
+    SingularMayerVietoris.SingularHomology (MappingTorus.Torus f) 0 ≃ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology X 0 ⧸ LinearMap.range (wangDifference f 0)) :=
+  (LinearEquiv.ofBijective (cokernelInclusion f 0)
+      ⟨cokernelInclusion_injective f 0, cokernelInclusion_zero_surjective f⟩).symm
+
+private def ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryToFullFilling (j : Elliptic.Kind) :
+    C(SpecialBoundary j, SpecialPeriods.EllipticFilling.SpecialFullFilling j) :=
+  (⟨Subtype.val, continuous_subtype_val⟩ :
+        C(SpecialPeriods.Threefold.SpecialEllipticPiece j,
+          SpecialPeriods.EllipticFilling.SpecialFullFilling j)).comp
+    (specialBoundaryToPiece j)
+
+private abbrev ThreefoldOverlapMappingTorus.Elliptic.BoundaryCentralSurface (j : Elliptic.Kind) :=
+  Elliptic.Surface j (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+    (Elliptic.mainTwist_admissible j)
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Pi1/MappingTorus.lean b/LeanPool/HopfProblem/Pi1/MappingTorus.lean
new file mode 100644
index 000000000..584c50174
--- /dev/null
+++ b/LeanPool/HopfProblem/Pi1/MappingTorus.lean
@@ -0,0 +1,1013 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Threefold.SpecialPeriods2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods2
+
+/-!
+# Hopf problem: pi 1 · mapping torus
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private abbrev MappingTorus.Circle :=
+  AddCircle (1 : ℝ)
+
+private def
+    MappingTorus.deck {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) (n : ℤ) (p : ℝ × X) : ℝ × X :=
+  (p.1 + (n : ℝ), (f ^ (-n)) p.2)
+
+@[simp]
+private theorem MappingTorus.deck_zero {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) (p : ℝ × X) :
+    deck f 0 p = p := by simp [deck]
+
+private theorem MappingTorus.deck_add {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) (m n : ℤ)
+    (p : ℝ × X) : deck f (m + n) p = deck f m (deck f n p) := by
+  apply Prod.ext
+  · simp only [deck, Int.cast_add]
+    abel
+  · simp only [deck, neg_add, zpow_add, Homeomorph.mul_apply]
+
+private theorem MappingTorus.deck_continuous {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) (n : ℤ) :
+    Continuous (deck f n) :=
+  (continuous_fst.add continuous_const).prodMk ((f ^ (-n)).continuous.comp continuous_snd)
+
+private def MappingTorus.deckHomeomorph {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) (n : ℤ) :
+    (ℝ × X) ≃ₜ (ℝ × X) where
+  toFun := deck f n
+  invFun := deck f (-n)
+  left_inv p := by rw [← deck_add, neg_add_cancel, deck_zero]
+  right_inv p := by rw [← deck_add, add_neg_cancel, deck_zero]
+  continuous_toFun := deck_continuous f n
+  continuous_invFun := deck_continuous f (-n)
+
+private def MappingTorus.orbitSetoid {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) : Setoid (ℝ × X)
+    where
+  r p q := ∃ n : ℤ, deck f n p = q
+  iseqv :=
+    { refl := fun p ↦ ⟨0, deck_zero f p⟩
+      symm := by
+        rintro p q ⟨n, rfl⟩
+        exact ⟨-n, by rw [← deck_add, neg_add_cancel, deck_zero]⟩
+      trans := by
+        rintro p q r ⟨m, rfl⟩ ⟨n, rfl⟩
+        exact ⟨n + m, deck_add f n m p⟩ }
+
+private def MappingTorus.Torus {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) :=
+  Quotient (orbitSetoid f)
+
+private instance MappingTorus.instLocal1 {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) :
+    TopologicalSpace (Torus f) :=
+  inferInstanceAs (TopologicalSpace (Quotient (orbitSetoid f)))
+
+private def MappingTorus.mk {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) (p : ℝ × X) : Torus f :=
+  Quotient.mk (orbitSetoid f) p
+
+private theorem MappingTorus.mk_continuous {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) :
+    Continuous (MappingTorus.mk f) :=
+  continuous_quotient_mk'
+
+private theorem MappingTorus.mk_surjective {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) :
+    Function.Surjective (MappingTorus.mk f) :=
+  Quotient.mk_surjective
+
+private theorem
+    MappingTorus.mk_eq_mk_iff {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) (p q : ℝ × X) :
+    MappingTorus.mk f p = MappingTorus.mk f q ↔
+      ∃ n : ℤ, q.1 = p.1 + (n : ℝ) ∧ q.2 = (f ^ (-n)) p.2 := by
+  change (Quotient.mk (orbitSetoid f) p = Quotient.mk (orbitSetoid f) q) ↔ _
+  rw [Quotient.eq]
+  change (∃ n : ℤ, deck f n p = q) ↔ _
+  constructor
+  · rintro ⟨n, hn⟩
+    exact ⟨n, (congrArg Prod.fst hn).symm, (congrArg Prod.snd hn).symm⟩
+  · rintro ⟨n, ht, hx⟩
+    exact ⟨n, Prod.ext ht.symm hx.symm⟩
+
+@[simp]
+private theorem
+    MappingTorus.mk_deck {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) (n : ℤ) (p : ℝ × X) :
+    MappingTorus.mk f (deck f n p) = MappingTorus.mk f p :=
+  (Quotient.sound (s := orbitSetoid f) ⟨n, rfl⟩).symm
+
+@[simp]
+private theorem
+    MappingTorus.mk_sub_one {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) (t : ℝ) (x : X) :
+    MappingTorus.mk f (t - 1, f x) = MappingTorus.mk f (t, x) := by
+  simpa [deck, sub_eq_add_neg] using mk_deck f (-1) (t, x)
+
+private theorem
+    MappingTorus.mk_add_one {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) (t : ℝ) (x : X) :
+    MappingTorus.mk f (t + 1, x) = MappingTorus.mk f (t, f x) := by
+  simpa using (mk_sub_one f (t + 1) x).symm
+
+private theorem MappingTorus.mk_preimage_image {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X)
+    (s : Set (ℝ × X)) : MappingTorus.mk f ⁻¹' (MappingTorus.mk f '' s) = ⋃ n : ℤ, deck f n '' s :=
+  by
+  ext p
+  constructor
+  · rintro ⟨q, hq, he⟩
+    obtain ⟨n, hn⟩ := Quotient.exact he
+    exact Set.mem_iUnion.mpr ⟨n, q, hq, hn⟩
+  · intro hp
+    obtain ⟨n, q, hq, rfl⟩ := Set.mem_iUnion.mp hp
+    exact ⟨q, hq, (mk_deck f n q).symm⟩
+
+private theorem MappingTorus.mk_open {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) :
+    IsOpenMap (MappingTorus.mk f) := by
+  intro s hs
+  apply (isQuotientMap_quotient_mk' (s := orbitSetoid f)).isOpen_preimage.mp
+  change IsOpen (MappingTorus.mk f ⁻¹' (MappingTorus.mk f '' s))
+  rw [mk_preimage_image]
+  exact isOpen_iUnion fun n ↦ (deckHomeomorph f n).isOpenMap s hs
+
+@[simp]
+private theorem MappingTorus.circle_intCast (n : ℤ) : ((n : ℝ) : MappingTorus.Circle) = 0 := by
+  apply (AddCircle.coe_eq_zero_iff (1 : ℝ)).mpr
+  exact ⟨n, by simp⟩
+
+private theorem MappingTorus.circle_coe_eq_iff (t s : ℝ) :
+    (t : MappingTorus.Circle) = (s : MappingTorus.Circle) ↔ ∃ n : ℤ, s = t + (n : ℝ) := by
+  constructor
+  · intro h
+    have hs : ((s - t : ℝ) : MappingTorus.Circle) = 0 := by rw [AddCircle.coe_sub, h, sub_self]
+    obtain ⟨n, hn⟩ := (AddCircle.coe_eq_zero_iff (1 : ℝ)).mp hs
+    refine ⟨n, ?_⟩
+    simp only [zsmul_eq_mul, mul_one] at hn
+    linarith
+  · rintro ⟨n, rfl⟩
+    simp
+
+private def MappingTorus.base {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) :
+    C(Torus f, MappingTorus.Circle)
+    where
+  toFun :=
+    Quotient.lift (fun p : ℝ × X ↦ (p.1 : MappingTorus.Circle))
+      (by
+        rintro p q ⟨n, rfl⟩
+        simp [deck])
+  continuous_toFun := (AddCircle.continuous_mk' (1 : ℝ)).comp continuous_fst |>.quotient_lift _
+
+@[simp]
+private theorem MappingTorus.base_mk {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) (p : ℝ × X) :
+    base f (MappingTorus.mk f p) = (p.1 : MappingTorus.Circle) :=
+  rfl
+
+/-- The torus monodromy used for the cusp boundary mapping torus. -/
+public
+abbrev ThreefoldOverlapMappingTorus.Cusp.monodromy : RealTorus₄ ≃ₜ RealTorus₄ :=
+  SpecialPeriods.CuspFamily.cuspTorusHomeomorph 1
+
+private abbrev ThreefoldOverlapMappingTorus.Cusp.Boundary :=
+  MappingTorus.Torus monodromy
+
+private def ThreefoldOverlapMappingTorus.Cusp.monodromyHom_mo1973_10002 :
+    Multiplicative ℤ →* (RealTorus₄ ≃ₜ RealTorus₄)
+    where
+  toFun k := SpecialPeriods.CuspFamily.cuspTorusHomeomorph k.toAdd
+  map_one' := SpecialPeriods.CuspFamily.cuspTorusHomeomorph_zero_eq
+  map_mul' k
+    l := by
+    apply Homeomorph.ext
+    exact SpecialPeriods.CuspFamily.cuspTorusHomeomorph_add_apply k.toAdd l.toAdd
+
+private theorem ThreefoldOverlapMappingTorus.Cusp.monodromy_zpow (k : ℤ) :
+    monodromy ^ k = SpecialPeriods.CuspFamily.cuspTorusHomeomorph k := by
+  have h := map_zpow monodromyHom_mo1973_10002 (Multiplicative.ofAdd (1 : ℤ)) k
+  change
+    SpecialPeriods.CuspFamily.cuspTorusHomeomorph (((Multiplicative.ofAdd (1 : ℤ)) ^ k).toAdd) =
+      monodromy ^ k at h
+  simpa using h.symm
+
+private def ThreefoldOverlapMappingTorus.Cusp.heightThreshold (r : ℝ) : ℝ :=
+  -Real.log r / (2 * Real.pi)
+
+private abbrev ThreefoldOverlapMappingTorus.Cusp.Height (r : ℝ) :=
+  Set.Ioi (heightThreshold r)
+
+private theorem
+    ThreefoldOverlapMappingTorus.Cusp.mem_logBase_iff_height (r : ℝ) (hr : 0 < r) (s : ℂ) :
+    s ∈ SpecialPeriods.CuspFamily.logBase r ↔ heightThreshold r < s.im := by
+  simpa only [SpecialPeriods.CuspFamily.mem_logBase, CuspUniformization.mem_logDomain,
+    heightThreshold] using (CuspUniformization.mem_logDomain_iff_im r hr (s, (0 : ComplexPlane₂)))
+
+private def ThreefoldOverlapMappingTorus.Cusp.logPoint (r : ℝ) (hr : 0 < r) (t : ℝ) (h : Height r) :
+    SpecialPeriods.CuspFamily.LogBase r :=
+  ⟨(t : ℂ) + (h : ℝ) * Complex.I,
+    (mem_logBase_iff_height r hr _).mpr
+      (by
+        simpa only [Height, Set.mem_Ioi, Complex.add_im, Complex.ofReal_im, Complex.mul_im,
+          Complex.ofReal_re, Complex.I_im, Complex.I_re, mul_one, MulZeroClass.mul_zero, zero_add,
+          add_zero] using h.property)⟩
+
+@[simp]
+private theorem ThreefoldOverlapMappingTorus.Cusp.logPoint_re (r : ℝ) (hr : 0 < r) (t : ℝ)
+    (h : Height r) : (logPoint r hr t h : ℂ).re = t := by simp [logPoint]
+
+@[simp]
+private theorem ThreefoldOverlapMappingTorus.Cusp.logPoint_im (r : ℝ) (hr : 0 < r) (t : ℝ)
+    (h : Height r) : (logPoint r hr t h : ℂ).im = (h : ℝ) := by simp [logPoint]
+
+private def ThreefoldOverlapMappingTorus.Cusp.logBaseHeightHomeomorph (r : ℝ) (hr : 0 < r) :
+    SpecialPeriods.CuspFamily.LogBase r ≃ₜ Height r × ℝ
+    where
+  toFun s := (⟨(s : ℂ).im, (mem_logBase_iff_height r hr s).mp s.property⟩, (s : ℂ).re)
+  invFun p := logPoint r hr p.2 p.1
+  left_inv
+    s := by
+    apply Subtype.ext
+    apply Complex.ext <;> simp [logPoint]
+  right_inv
+    p := by
+    apply Prod.ext
+    · apply Subtype.ext
+      exact logPoint_im r hr p.2 p.1
+    · exact logPoint_re r hr p.2 p.1
+  continuous_toFun :=
+    ((Complex.continuous_im.comp continuous_subtype_val).subtype_mk _).prodMk
+      (Complex.continuous_re.comp continuous_subtype_val)
+  continuous_invFun :=
+    ((Complex.continuous_ofReal.comp continuous_snd).add
+          ((Complex.continuous_ofReal.comp (continuous_subtype_val.comp continuous_fst)).mul
+            continuous_const)).subtype_mk
+      _
+
+private theorem
+    ThreefoldOverlapMappingTorus.Cusp.logPoint_translate (r : ℝ) (hr : 0 < r) (k : ℤ) (t : ℝ)
+    (h : Height r) :
+    SpecialPeriods.CuspFamily.logBaseTranslate r k (logPoint r hr t h) =
+      logPoint r hr (t - (k : ℝ)) h := by
+  apply Subtype.ext
+  change (t : ℂ) + (h : ℝ) * Complex.I - (k : ℂ) = ((t - (k : ℝ) : ℝ) : ℂ) + (h : ℝ) * Complex.I
+  push_cast
+  ring
+
+private def ThreefoldOverlapMappingTorus.Cusp.familyCylinderHomeomorph
+    (D : SpecialPeriods.CuspFamily.Data) : D.TotalSpace ≃ₜ Height D.radius × (ℝ × RealTorus₄) :=
+  ((logBaseHeightHomeomorph D.radius D.radius_pos).prodCongr (Homeomorph.refl RealTorus₄)).trans
+    (Homeomorph.prodAssoc (Height D.radius) ℝ RealTorus₄)
+
+private theorem ThreefoldOverlapMappingTorus.Cusp.familyCylinderHomeomorph_smul
+    (D : SpecialPeriods.CuspFamily.Data) (k : Multiplicative ℤ) (x : D.TotalSpace) :
+    letI := D.totalAction
+    familyCylinderHomeomorph D (k • x) =
+      ((familyCylinderHomeomorph D x).1,
+        MappingTorus.deck monodromy (-k.toAdd) (familyCylinderHomeomorph D x).2) := by
+  let := D.totalAction
+  apply Prod.ext
+  · apply Subtype.ext
+    change ((x.1 : ℂ) - (k.toAdd : ℂ)).im = (x.1 : ℂ).im
+    simp
+  · apply Prod.ext
+    · change ((x.1 : ℂ) - (k.toAdd : ℂ)).re = (x.1 : ℂ).re + ((-k.toAdd : ℤ) : ℝ)
+      simp [sub_eq_add_neg]
+    · change
+        SpecialPeriods.CuspFamily.cuspTorusHomeomorph k.toAdd x.2 =
+          (monodromy ^ (-(-k.toAdd))) x.2
+      rw [neg_neg, monodromy_zpow]
+
+private def ThreefoldOverlapMappingTorus.Cusp.commonQuotientHomeomorph_mo1973_10028
+    {A X Y : Type*} [TopologicalSpace A] [TopologicalSpace X] [TopologicalSpace Y] (f : A → X)
+    (g : A → Y) (hf : Topology.IsQuotientMap f) (hg : Topology.IsQuotientMap g)
+    (he : ∀ a b, f a = f b ↔ g a = g b) : X ≃ₜ Y := by
+  let e : X ≃ Y :=
+    Equiv.ofBijective (CuspHoneycombHexagon.CommonFibres.descend f g hf.surjective)
+      ⟨CuspHoneycombHexagon.CommonFibres.descend_injective f g hf.surjective
+          (fun a b => (he a b).mpr),
+        CuspHoneycombHexagon.CommonFibres.descend_surjective f g hf.surjective
+          (fun a b => (he a b).mp) hg.surjective⟩
+  refine
+    { toEquiv := e
+      continuous_toFun :=
+        CuspHoneycombHexagon.CommonFibres.descend_continuous f g hf.surjective hf hg.continuous
+          (fun a b => (he a b).mp)
+      continuous_invFun := ?_ }
+  apply hg.continuous_iff.mpr
+  change Continuous (e.symm ∘ g)
+  have hcomp : e.symm ∘ g = f := by
+    funext a
+    apply e.injective
+    change e (e.symm (g a)) = e (f a)
+    rw [e.apply_symm_apply]
+    exact
+      (CuspHoneycombHexagon.CommonFibres.descend_apply f g hf.surjective (fun a b => (he a b).mp)
+          a).symm
+  rw [hcomp]
+  exact hf.continuous
+
+private theorem ThreefoldOverlapMappingTorus.Cusp.commonQuotientHomeomorph_apply_mo1973_10029
+    {A X Y : Type*} [TopologicalSpace A] [TopologicalSpace X] [TopologicalSpace Y] (f : A → X)
+    (g : A → Y) (hf : Topology.IsQuotientMap f) (hg : Topology.IsQuotientMap g)
+    (he : ∀ a b, f a = f b ↔ g a = g b) (a : A) :
+    commonQuotientHomeomorph_mo1973_10028 f g hf hg he (f a) = g a :=
+  CuspHoneycombHexagon.CommonFibres.descend_apply f g hf.surjective (fun a b => (he a b).mp) a
+
+private def ThreefoldOverlapMappingTorus.Cusp.cylinderProjection (r : ℝ) :
+    C(Height r × (ℝ × RealTorus₄), Height r × Boundary) :=
+  ⟨Prod.map id (MappingTorus.mk monodromy),
+    continuous_id.prodMap (MappingTorus.mk_continuous monodromy)⟩
+
+private theorem ThreefoldOverlapMappingTorus.Cusp.cylinderProjection_isOpenQuotientMap (r : ℝ) :
+    IsOpenQuotientMap (cylinderProjection r) :=
+  IsOpenQuotientMap.id.prodMap
+    ⟨MappingTorus.mk_surjective monodromy, MappingTorus.mk_continuous monodromy,
+      MappingTorus.mk_open monodromy⟩
+
+private def
+    ThreefoldOverlapMappingTorus.Cusp.familyProductMap (D : SpecialPeriods.CuspFamily.Data) :
+    C(D.TotalSpace, Height D.radius × Boundary) :=
+  (cylinderProjection D.radius).comp
+    ⟨familyCylinderHomeomorph D, (familyCylinderHomeomorph D).continuous⟩
+
+private theorem ThreefoldOverlapMappingTorus.Cusp.familyProductMap_isOpenQuotientMap
+    (D : SpecialPeriods.CuspFamily.Data) : IsOpenQuotientMap (familyProductMap D) :=
+  (cylinderProjection_isOpenQuotientMap D.radius).comp
+    (familyCylinderHomeomorph D).isOpenQuotientMap
+
+private theorem ThreefoldOverlapMappingTorus.Cusp.familyProductMap_smul
+    (D : SpecialPeriods.CuspFamily.Data) (k : Multiplicative ℤ) (x : D.TotalSpace) :
+    letI := D.totalAction
+    familyProductMap D (k • x) = familyProductMap D x := by
+  let := D.totalAction
+  change Prod.map id (MappingTorus.mk monodromy) (familyCylinderHomeomorph D (k • x)) = _
+  rw [familyCylinderHomeomorph_smul]
+  exact Prod.ext rfl (MappingTorus.mk_deck monodromy (-k.toAdd) _)
+
+private theorem ThreefoldOverlapMappingTorus.Cusp.familyProductMap_eq_iff
+    (D : SpecialPeriods.CuspFamily.Data) (x y : D.TotalSpace) :
+    familyProductMap D x = familyProductMap D y ↔ D.quotient x = D.quotient y := by
+  let := D.totalAction
+  constructor
+  · intro h
+    have hheight : (x.1 : ℂ).im = (y.1 : ℂ).im :=
+      congrArg (fun p : Height D.radius × Boundary => (p.1 : ℝ)) h
+    have htime := congrArg Prod.snd h
+    change
+      MappingTorus.mk monodromy ((x.1 : ℂ).re, x.2) =
+        MappingTorus.mk monodromy ((y.1 : ℂ).re, y.2) at htime
+    obtain ⟨n, ht, hx⟩ := (MappingTorus.mk_eq_mk_iff monodromy _ _).mp htime
+    apply (D.quotient_eq_iff x y).mpr
+    refine ⟨Multiplicative.ofAdd n, ?_⟩
+    apply Prod.ext
+    · apply Subtype.ext
+      apply Complex.ext
+      · change ((y.1 : ℂ) - (n : ℂ)).re = (x.1 : ℂ).re
+        change (y.1 : ℂ).re = (x.1 : ℂ).re + (n : ℝ) at ht
+        simp only [Complex.sub_re, Complex.intCast_re]
+        linarith
+      · change ((y.1 : ℂ) - (n : ℂ)).im = (x.1 : ℂ).im
+        simpa only [Complex.sub_im, Complex.intCast_im, sub_zero] using hheight.symm
+    · change SpecialPeriods.CuspFamily.cuspTorusHomeomorph n y.2 = x.2
+      change y.2 = (monodromy ^ (-n)) x.2 at hx
+      rw [monodromy_zpow] at hx
+      rw [hx, ← SpecialPeriods.CuspFamily.cuspTorusHomeomorph_add_apply, add_neg_cancel,
+        SpecialPeriods.CuspFamily.cuspTorusHomeomorph_zero_apply]
+  · intro h
+    obtain ⟨k, hk⟩ := (D.quotient_eq_iff x y).mp h
+    rw [← hk, familyProductMap_smul]
+
+private theorem ThreefoldOverlapMappingTorus.Cusp.familyQuotient_isQuotientMap
+    (D : SpecialPeriods.CuspFamily.Data) : Topology.IsQuotientMap D.quotient := by
+  let := D.totalAction
+  exact D.quotientCoveringMap.toIsQuotientMap
+
+private def ThreefoldOverlapMappingTorus.Cusp.familyProductHomeomorph
+    (D : SpecialPeriods.CuspFamily.Data) : D.Space ≃ₜ Height D.radius × Boundary :=
+  commonQuotientHomeomorph_mo1973_10028 D.quotient (familyProductMap D)
+    (familyQuotient_isQuotientMap D) (familyProductMap_isOpenQuotientMap D).isQuotientMap
+    (fun x y => (familyProductMap_eq_iff D x y).symm)
+
+@[simp]
+private theorem ThreefoldOverlapMappingTorus.Cusp.familyProductHomeomorph_quotient
+    (D : SpecialPeriods.CuspFamily.Data) (x : D.TotalSpace) :
+    familyProductHomeomorph D (D.quotient x) = familyProductMap D x :=
+  commonQuotientHomeomorph_apply_mo1973_10029 D.quotient (familyProductMap D)
+    (familyQuotient_isQuotientMap D) (familyProductMap_isOpenQuotientMap D).isQuotientMap
+    (fun x y => (familyProductMap_eq_iff D x y).symm) x
+
+private theorem ThreefoldOverlapMappingTorus.Cusp.familyProductMap_logPoint
+    (D : SpecialPeriods.CuspFamily.Data) (h : Height D.radius) (t : ℝ) (x : RealTorus₄) :
+    familyProductMap D (logPoint D.radius D.radius_pos t h, x) =
+      (h, MappingTorus.mk monodromy (t, x)) := by
+  apply Prod.ext
+  · apply Subtype.ext
+    exact logPoint_im D.radius D.radius_pos t h
+  · change MappingTorus.mk monodromy ((logPoint D.radius D.radius_pos t h : ℂ).re, x) = _
+    rw [logPoint_re]
+
+private theorem ThreefoldOverlapMappingTorus.Cusp.familyProductHomeomorph_symm_mk
+    (D : SpecialPeriods.CuspFamily.Data) (h : Height D.radius) (t : ℝ) (x : RealTorus₄) :
+    (familyProductHomeomorph D).symm (h, MappingTorus.mk monodromy (t, x)) =
+      D.quotient (logPoint D.radius D.radius_pos t h, x) := by
+  simpa only [familyProductHomeomorph_quotient, familyProductMap_logPoint] using
+    (familyProductHomeomorph D).symm_apply_apply
+      (D.quotient (logPoint D.radius D.radius_pos t h, x))
+
+private theorem
+    MappingTorus.base_mk_ne_of_mem_Ioo {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) (a : ℝ)
+    (t : Set.Ioo a (a + 1)) (x : X) :
+    base f (MappingTorus.mk f ((t : ℝ), x)) ≠ (a : MappingTorus.Circle) :=
+  (AddCircle.openPartialHomeomorphCoe (1 : ℝ) a).map_source t.property
+
+private def MappingTorus.intervalParam {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) (a : ℝ)
+    (p : Set.Ioo a (a + 1) × X) : { q : Torus f // base f q ≠ (a : MappingTorus.Circle) } :=
+  ⟨MappingTorus.mk f ((p.1 : ℝ), p.2), base_mk_ne_of_mem_Ioo f a p.1 p.2⟩
+
+private theorem MappingTorus.intervalParam_continuous {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X)
+    (a : ℝ) : Continuous (intervalParam f a) :=
+  ((mk_continuous f).comp
+        ((continuous_subtype_val.comp continuous_fst).prodMk continuous_snd)).subtype_mk
+    _
+
+private theorem
+    MappingTorus.intervalParam_open {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) (a : ℝ) :
+    IsOpenMap (intervalParam f a) :=
+  ((mk_open f).comp (isOpen_Ioo.isOpenMap_subtype_val.prodMap IsOpenMap.id)).subtype_mk _
+
+private theorem MappingTorus.intervalParam_injective {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X)
+    (a : ℝ) : Function.Injective (intervalParam f a) := by
+  intro p q hpq
+  have he : MappingTorus.mk f ((p.1 : ℝ), p.2) = MappingTorus.mk f ((q.1 : ℝ), q.2) :=
+    congrArg Subtype.val hpq
+  have hc : ((p.1 : ℝ) : MappingTorus.Circle) = ((q.1 : ℝ) : MappingTorus.Circle) :=
+    congrArg (base f) he
+  have ht : (p.1 : ℝ) = (q.1 : ℝ) :=
+    (AddCircle.coe_eq_coe_iff_of_mem_Ico (Set.Ioo_subset_Ico_self p.1.property)
+          (Set.Ioo_subset_Ico_self q.1.property)).mp
+      hc
+  obtain ⟨n, hn, hx⟩ := (mk_eq_mk_iff f _ _).mp he
+  have hnR : (n : ℝ) = 0 := by
+    dsimp at hn
+    linarith
+  have hn0 : n = 0 := Int.cast_eq_zero.mp hnR
+  apply Prod.ext (Subtype.ext ht)
+  simpa [hn0] using hx.symm
+
+private theorem MappingTorus.intervalParam_surjective {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X)
+    (a : ℝ) : Function.Surjective (intervalParam f a) := by
+  intro q
+  obtain ⟨⟨s, x⟩, hp⟩ := mk_surjective f q.val
+  let e := AddCircle.openPartialHomeomorphCoe (1 : ℝ) a
+  let t : Set.Ioo a (a + 1) := ⟨e.symm (base f q.val), e.map_target q.property⟩
+  have ht : ((t : ℝ) : MappingTorus.Circle) = base f q.val := e.right_inv q.property
+  have hst : (s : MappingTorus.Circle) = ((t : ℝ) : MappingTorus.Circle) :=
+    (congrArg (base f) hp).trans ht.symm
+  obtain ⟨n, hn⟩ := (circle_coe_eq_iff s (t : ℝ)).mp hst
+  refine ⟨(t, (f ^ (-n)) x), Subtype.ext ?_⟩
+  change MappingTorus.mk f ((t : ℝ), (f ^ (-n)) x) = q.val
+  rw [hn]
+  exact (mk_deck f n (s, x)).trans hp
+
+private def MappingTorus.intervalHomeomorph {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) (a : ℝ) :
+    { q : Torus f // base f q ≠ (a : MappingTorus.Circle) } ≃ₜ (Set.Ioo a (a + 1) × X) :=
+  ((Equiv.ofBijective (intervalParam f a)
+          ⟨intervalParam_injective f a,
+            intervalParam_surjective f a⟩).toHomeomorphOfContinuousOpen
+      (intervalParam_continuous f a) (intervalParam_open f a)).symm
+
+@[simp]
+private theorem
+    MappingTorus.intervalHomeomorph_symm_coe {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X)
+    (a : ℝ) (p : Set.Ioo a (a + 1) × X) :
+    ((intervalHomeomorph f a).symm p : Torus f) = MappingTorus.mk f ((p.1 : ℝ), p.2) :=
+  rfl
+
+private theorem MappingTorus.HomologyCover.negativeHalf_coe :
+    ((-(1 / 2 : ℝ)) : (PeriodTorusHigherHomology.CircleTopology.Circle)) =
+      PeriodTorusHigherHomology.CircleTopology.halfPoint := by
+  have h := AddCircle.coe_add_period (p := (1 : ℝ)) (-(1 / 2 : ℝ))
+  norm_num [PeriodTorusHigherHomology.CircleTopology.halfPoint] at h ⊢
+  exact h.symm
+
+private theorem MappingTorus.HomologyCover.negativeHalf_coe_ne_zero :
+    ((-(1 / 2 : ℝ)) : (PeriodTorusHigherHomology.CircleTopology.Circle)) ≠ 0 := by
+  rw [negativeHalf_coe]
+  exact PeriodTorusHigherHomology.CircleTopology.halfPoint_ne_zero
+
+private theorem
+    MappingTorus.HomologyCover.unitInterval_coe_eq_negativeHalf_iff (t : Set.Ioo (0 : ℝ) 1) :
+    ((t : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle)) =
+        ((-(1 / 2 : ℝ)) : (PeriodTorusHigherHomology.CircleTopology.Circle)) ↔
+      (t : ℝ) = 1 / 2 := by
+  rw [negativeHalf_coe]
+  exact
+    AddCircle.coe_eq_coe_iff_of_mem_Ico (p := (1 : ℝ)) (a := 0)
+      ⟨le_of_lt t.property.1, by simpa only [zero_add] using t.property.2⟩ (by norm_num)
+
+private theorem
+    MappingTorus.HomologyCover.unitInterval_coe_ne_negativeHalf_iff (t : Set.Ioo (0 : ℝ) 1) :
+    ((t : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle)) ≠
+        ((-(1 / 2 : ℝ)) : (PeriodTorusHigherHomology.CircleTopology.Circle)) ↔
+      (t : ℝ) ≠ 1 / 2 :=
+  not_congr (unitInterval_coe_eq_negativeHalf_iff t)
+
+private def MappingTorus.HomologyCover.firstPredicateHomeomorph (A X : Type*) [TopologicalSpace A]
+    [TopologicalSpace X] (p : A → Prop) : { z : A × X // p z.1 } ≃ₜ ({ a : A // p a } × X)
+    where
+  toFun z := (⟨z.val.1, z.property⟩, z.val.2)
+  invFun z := ⟨(z.1.val, z.2), z.1.property⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := (continuous_subtype_val.fst.subtype_mk _).prodMk continuous_subtype_val.snd
+  continuous_invFun :=
+    ((continuous_subtype_val.comp continuous_fst).prodMk continuous_snd).subtype_mk _
+
+private def
+    MappingTorus.HomologyCover.intervalIntersectionHomeomorph (X : Type*) [TopologicalSpace X] :
+    { p : Set.Ioo (0 : ℝ) 1 × X // (p.1 : ℝ) ≠ 1 / 2 } ≃ₜ
+      ((Set.Ioo (0 : ℝ) (1 / 2) × X) ⊕ (Set.Ioo (1 / 2 : ℝ) 1 × X)) :=
+  ((firstPredicateHomeomorph (Set.Ioo (0 : ℝ) 1) X (fun t => (t : ℝ) ≠ 1 / 2)).trans
+        (PeriodTorusHigherHomology.CircleTopology.puncturedIntervalHomeomorph.prodCongr
+          (Homeomorph.refl X))).trans
+    Homeomorph.sumProdDistrib
+
+private def MappingTorus.HomologyCover.U {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) :
+    Set (MappingTorus.Torus f) :=
+  {q | MappingTorus.base f q ≠ ((0 : ℝ) : MappingTorus.Circle)}
+
+private def MappingTorus.HomologyCover.V {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) :
+    Set (MappingTorus.Torus f) :=
+  {q | MappingTorus.base f q ≠ ((-(1 / 2 : ℝ)) : MappingTorus.Circle)}
+
+private theorem MappingTorus.HomologyCover.U_open {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) :
+    IsOpen (U f) :=
+  isOpen_compl_singleton.preimage (MappingTorus.base f).continuous
+
+private theorem MappingTorus.HomologyCover.V_open {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) :
+    IsOpen (V f) :=
+  isOpen_compl_singleton.preimage (MappingTorus.base f).continuous
+
+private theorem MappingTorus.HomologyCover.cover {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) :
+    U f ∪ V f = Set.univ := by
+  ext q
+  simp only [Set.mem_union, Set.mem_univ, iff_true]
+  by_cases hq : MappingTorus.base f q = 0
+  · right
+    change MappingTorus.base f q ≠ ((-(1 / 2 : ℝ)) : MappingTorus.Circle)
+    rw [hq]
+    exact Ne.symm negativeHalf_coe_ne_zero
+  · exact Or.inl hq
+
+private def MappingTorus.HomologyCover.chartU {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) :
+    U f ≃ₜ Set.Ioo (0 : ℝ) 1 × X :=
+  (MappingTorus.intervalHomeomorph f 0).trans
+    ((Homeomorph.setCongr (by simp : Ioo (0 : ℝ) (0 + 1) = Ioo 0 1)).prodCongr
+      (Homeomorph.refl X))
+
+private def MappingTorus.HomologyCover.chartV {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) :
+    V f ≃ₜ Set.Ioo (-(1 / 2 : ℝ)) (1 / 2) × X :=
+  (MappingTorus.intervalHomeomorph f (-(1 / 2 : ℝ))).trans
+    ((Homeomorph.setCongr
+          (by norm_num : Ioo (-(1 / 2 : ℝ)) (-(1 / 2) + 1) = Ioo (-(1 / 2)) (1 / 2))).prodCongr
+      (Homeomorph.refl X))
+
+@[simp]
+private theorem
+    MappingTorus.HomologyCover.chartU_symm_coe {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (p : Set.Ioo (0 : ℝ) 1 × X) :
+    ((chartU f).symm p : MappingTorus.Torus f) = MappingTorus.mk f ((p.1 : ℝ), p.2) :=
+  MappingTorus.intervalHomeomorph_symm_coe f 0 _
+
+@[simp]
+private theorem
+    MappingTorus.HomologyCover.chartV_symm_coe {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (p : Set.Ioo (-(1 / 2 : ℝ)) (1 / 2) × X) :
+    ((chartV f).symm p : MappingTorus.Torus f) = MappingTorus.mk f ((p.1 : ℝ), p.2) :=
+  MappingTorus.intervalHomeomorph_symm_coe f (-(1 / 2 : ℝ)) _
+
+private theorem MappingTorus.HomologyCover.chartU_mk {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (q : U f) (p : Set.Ioo (0 : ℝ) 1 × X)
+    (hq : (q : MappingTorus.Torus f) = MappingTorus.mk f ((p.1 : ℝ), p.2)) : chartU f q = p := by
+  apply (chartU f).symm.injective
+  rw [Homeomorph.symm_apply_apply]
+  exact Subtype.ext (hq.trans (chartU_symm_coe f p).symm)
+
+private theorem MappingTorus.HomologyCover.chartV_mk {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (q : V f) (p : Set.Ioo (-(1 / 2 : ℝ)) (1 / 2) × X)
+    (hq : (q : MappingTorus.Torus f) = MappingTorus.mk f ((p.1 : ℝ), p.2)) : chartV f q = p := by
+  apply (chartV f).symm.injective
+  rw [Homeomorph.symm_apply_apply]
+  exact Subtype.ext (hq.trans (chartV_symm_coe f p).symm)
+
+private theorem MappingTorus.HomologyCover.chartU_representation {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (q : U f) :
+    MappingTorus.mk f (((chartU f q).1 : ℝ), (chartU f q).2) = (q : MappingTorus.Torus f) := by
+  rw [← chartU_symm_coe, Homeomorph.symm_apply_apply]
+
+private theorem MappingTorus.HomologyCover.chartV_representation {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (q : V f) :
+    MappingTorus.mk f (((chartV f q).1 : ℝ), (chartV f q).2) = (q : MappingTorus.Torus f) := by
+  rw [← chartV_symm_coe, Homeomorph.symm_apply_apply]
+
+private theorem MappingTorus.HomologyCover.chartU_base {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (q : U f) : (((chartU f q).1 : ℝ) : MappingTorus.Circle) = MappingTorus.base f q := by
+  have h := congrArg (MappingTorus.base f) (chartU_representation f q)
+  simpa only [MappingTorus.base_mk] using h
+
+private theorem
+    MappingTorus.HomologyCover.chartU_mem_V_iff {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (q : U f) : (q : MappingTorus.Torus f) ∈ V f ↔ ((chartU f q).1 : ℝ) ≠ 1 / 2 := by
+  change MappingTorus.base f q ≠ ((-(1 / 2 : ℝ)) : MappingTorus.Circle) ↔ _
+  rw [← chartU_base]
+  exact unitInterval_coe_ne_negativeHalf_iff _
+
+private def
+    MappingTorus.HomologyCover.intersectionChart {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) :
+    ↥(U f ∩ V f) ≃ₜ { p : Set.Ioo (0 : ℝ) 1 × X // (p.1 : ℝ) ≠ 1 / 2 } :=
+  (PeriodTorusHigherHomology.CircleTopology.intersectionSubtypeHomeomorph (U f) (V f)).trans
+    ((chartU f).subtype (chartU_mem_V_iff f))
+
+private def MappingTorus.HomologyCover.intersectionHomeomorph {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) :
+    ↥(U f ∩ V f) ≃ₜ ((Set.Ioo (0 : ℝ) (1 / 2) × X) ⊕ (Set.Ioo (1 / 2 : ℝ) 1 × X)) :=
+  (intersectionChart f).trans (intervalIntersectionHomeomorph X)
+
+@[simp]
+private theorem MappingTorus.HomologyCover.intersectionHomeomorph_symm_inl_coe {X : Type}
+    [TopologicalSpace X] (f : X ≃ₜ X) (p : Set.Ioo (0 : ℝ) (1 / 2) × X) :
+    ((intersectionHomeomorph f).symm (Sum.inl p) : MappingTorus.Torus f) =
+      MappingTorus.mk f ((p.1 : ℝ), p.2) :=
+  chartU_symm_coe f _
+
+@[simp]
+private theorem MappingTorus.HomologyCover.intersectionHomeomorph_symm_inr_coe {X : Type}
+    [TopologicalSpace X] (f : X ≃ₜ X) (p : Set.Ioo (1 / 2 : ℝ) 1 × X) :
+    ((intersectionHomeomorph f).symm (Sum.inr p) : MappingTorus.Torus f) =
+      MappingTorus.mk f ((p.1 : ℝ), p.2) :=
+  chartU_symm_coe f _
+
+private def MappingTorus.HomologyCover.inclusionU {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) :
+    C(U f, MappingTorus.Torus f) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private def MappingTorus.HomologyCover.inclusionV {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) :
+    C(V f, MappingTorus.Torus f) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private def
+    MappingTorus.HomologyCover.intersectionToU {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) :
+    C(↥(U f ∩ V f), U f) :=
+  ContinuousMap.inclusion Set.inter_subset_left
+
+private def
+    MappingTorus.HomologyCover.intersectionToV {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) :
+    C(↥(U f ∩ V f), V f) :=
+  ContinuousMap.inclusion Set.inter_subset_right
+
+private theorem MappingTorus.HomologyCover.chartU_intersection_inl {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (p : Set.Ioo (0 : ℝ) (1 / 2) × X) :
+    (chartU f (intersectionToU f ((intersectionHomeomorph f).symm (Sum.inl p)))).2 = p.2 := by
+  exact
+    congrArg Prod.snd
+      (chartU_mk f (intersectionToU f ((intersectionHomeomorph f).symm (Sum.inl p)))
+        ((PeriodTorusHigherHomology.CircleTopology.puncturedIntervalInl p.1).val, p.2)
+        (intersectionHomeomorph_symm_inl_coe f p))
+
+private theorem MappingTorus.HomologyCover.chartU_intersection_inr {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (p : Set.Ioo (1 / 2 : ℝ) 1 × X) :
+    (chartU f (intersectionToU f ((intersectionHomeomorph f).symm (Sum.inr p)))).2 = p.2 := by
+  exact
+    congrArg Prod.snd
+      (chartU_mk f (intersectionToU f ((intersectionHomeomorph f).symm (Sum.inr p)))
+        ((PeriodTorusHigherHomology.CircleTopology.puncturedIntervalInr p.1).val, p.2)
+        (intersectionHomeomorph_symm_inr_coe f p))
+
+private theorem MappingTorus.HomologyCover.chartV_intersection_inl {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (p : Set.Ioo (0 : ℝ) (1 / 2) × X) :
+    (chartV f (intersectionToV f ((intersectionHomeomorph f).symm (Sum.inl p)))).2 = p.2 := by
+  let t : Set.Ioo (-(1 / 2 : ℝ)) (1 / 2) :=
+    ⟨p.1, by constructor <;> linarith [p.1.property.1, p.1.property.2]⟩
+  rw [chartV_mk f _ (t, p.2) (intersectionHomeomorph_symm_inl_coe f p)]
+
+private theorem MappingTorus.HomologyCover.chartV_intersection_inr {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (p : Set.Ioo (1 / 2 : ℝ) 1 × X) :
+    (chartV f (intersectionToV f ((intersectionHomeomorph f).symm (Sum.inr p)))).2 = f p.2 := by
+  let t : Set.Ioo (-(1 / 2 : ℝ)) (1 / 2) :=
+    ⟨(p.1 : ℝ) - 1, by constructor <;> linarith [p.1.property.1, p.1.property.2]⟩
+  apply congrArg Prod.snd (chartV_mk f _ (t, f p.2) ?_)
+  exact (intersectionHomeomorph_symm_inr_coe f p).trans (MappingTorus.mk_sub_one f _ _).symm
+
+private def MappingTorus.HomologyCover.fibreInclusion {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) :
+    C(X, MappingTorus.Torus f) :=
+  ⟨fun x => MappingTorus.mk f (0, x),
+    (MappingTorus.mk_continuous f).comp (continuous_const.prodMk continuous_id)⟩
+
+private def MappingTorus.HomologyCover.liftContraction {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    {S : Type} [TopologicalSpace S] (q : C(S, MappingTorus.Torus f)) (l : C(S, ℝ × X))
+    (hl : ∀ s, MappingTorus.mk f (l s) = q s) :
+    q.Homotopy ((fibreInclusion f).comp (ContinuousMap.snd.comp l))
+    where
+  toFun p := MappingTorus.mk f ((1 - (p.1 : ℝ)) * (l p.2).1, (l p.2).2)
+  continuous_toFun :=
+    (MappingTorus.mk_continuous f).comp
+      (((continuous_const.sub (continuous_subtype_val.comp continuous_fst)).mul
+            (l.continuous.fst.comp continuous_snd)).prodMk
+        (l.continuous.snd.comp continuous_snd))
+  map_zero_left s := by simpa using hl s
+  map_one_left s := by simp [fibreInclusion]
+
+private def MappingTorus.HomologyCover.liftU {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) :
+    C(U f, ℝ × X) :=
+  ⟨fun q => (((chartU f q).1 : ℝ), (chartU f q).2),
+    (continuous_subtype_val.comp (chartU f).continuous.fst).prodMk (chartU f).continuous.snd⟩
+
+private def MappingTorus.HomologyCover.liftV {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) :
+    C(V f, ℝ × X) :=
+  ⟨fun q => (((chartV f q).1 : ℝ), (chartV f q).2),
+    (continuous_subtype_val.comp (chartV f).continuous.fst).prodMk (chartV f).continuous.snd⟩
+
+private def MappingTorus.HomologyCover.homotopyEquivU {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) :
+    U f ≃ₕ X := by
+  letI : ContractibleSpace (Set.Ioo (0 : ℝ) 1) :=
+    PeriodTorusHigherHomology.CircleTopology.intervalContractible 0 1 zero_lt_one
+  exact
+    (chartU f).toHomotopyEquiv.trans
+      (PeriodTorusHigherHomology.CircleTopology.contractibleProdHomotopyEquiv (Set.Ioo (0 : ℝ) 1)
+        X)
+
+private def MappingTorus.HomologyCover.homotopyEquivV {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) :
+    V f ≃ₕ X := by
+  letI : ContractibleSpace (Set.Ioo (-(1 / 2 : ℝ)) (1 / 2)) :=
+    PeriodTorusHigherHomology.CircleTopology.intervalContractible _ _ (by norm_num)
+  exact
+    (chartV f).toHomotopyEquiv.trans
+      (PeriodTorusHigherHomology.CircleTopology.contractibleProdHomotopyEquiv
+        (Set.Ioo (-(1 / 2 : ℝ)) (1 / 2)) X)
+
+private def
+    MappingTorus.HomologyCover.inclusionUHomotopy {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) :
+    (inclusionU f).Homotopy ((fibreInclusion f).comp (homotopyEquivU f).toFun) :=
+  liftContraction f (inclusionU f) (liftU f) (chartU_representation f)
+
+private def
+    MappingTorus.HomologyCover.inclusionVHomotopy {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) :
+    (inclusionV f).Homotopy ((fibreInclusion f).comp (homotopyEquivV f).toFun) :=
+  liftContraction f (inclusionV f) (liftV f) (chartV_representation f)
+
+private def MappingTorus.HomologyCover.intersectionHomotopyEquiv {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) : ↥(U f ∩ V f) ≃ₕ X ⊕ X :=
+  (intersectionHomeomorph f).toHomotopyEquiv.trans
+    (PeriodTorusHigherHomology.CircleTopology.sumHomotopyEquiv
+      (PeriodTorusHigherHomology.CircleTopology.contractibleProdHomotopyEquiv
+        (Set.Ioo (0 : ℝ) (1 / 2)) X)
+      (PeriodTorusHigherHomology.CircleTopology.contractibleProdHomotopyEquiv
+        (Set.Ioo (1 / 2 : ℝ) 1) X))
+
+@[simp]
+private theorem
+    MappingTorus.HomologyCover.intersectionHomotopyEquiv_inl {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (p : Set.Ioo (0 : ℝ) (1 / 2) × X) :
+    intersectionHomotopyEquiv f ((intersectionHomeomorph f).symm (Sum.inl p)) = Sum.inl p.2 := by
+  change
+    Sum.map (fun p : Set.Ioo (0 : ℝ) (1 / 2) × X => p.2)
+        (fun p : Set.Ioo (1 / 2 : ℝ) 1 × X => p.2)
+        (intersectionHomeomorph f ((intersectionHomeomorph f).symm (Sum.inl p))) =
+      _
+  rw [Homeomorph.apply_symm_apply]
+  rfl
+
+@[simp]
+private theorem
+    MappingTorus.HomologyCover.intersectionHomotopyEquiv_inr {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (p : Set.Ioo (1 / 2 : ℝ) 1 × X) :
+    intersectionHomotopyEquiv f ((intersectionHomeomorph f).symm (Sum.inr p)) = Sum.inr p.2 := by
+  change
+    Sum.map (fun p : Set.Ioo (0 : ℝ) (1 / 2) × X => p.2)
+        (fun p : Set.Ioo (1 / 2 : ℝ) 1 × X => p.2)
+        (intersectionHomeomorph f ((intersectionHomeomorph f).symm (Sum.inr p))) =
+      _
+  rw [Homeomorph.apply_symm_apply]
+  rfl
+
+private theorem MappingTorus.HomologyCover.intersectionToU_fold {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) :
+    (homotopyEquivU f).toFun.comp (intersectionToU f) =
+      (PeriodTorusHigherHomology.sumElimMap (ContinuousMap.id X) (ContinuousMap.id X)).comp
+        (intersectionHomotopyEquiv f).toFun := by
+  apply ContinuousMap.ext
+  intro q
+  obtain ⟨p, rfl⟩ := (intersectionHomeomorph f).symm.surjective q
+  cases p with
+  | inl
+    p =>
+    change
+      (chartU f (intersectionToU f _)).2 =
+        PeriodTorusHigherHomology.sumElimMap (ContinuousMap.id X) (ContinuousMap.id X)
+          (intersectionHomotopyEquiv f _)
+    rw [intersectionHomotopyEquiv_inl, chartU_intersection_inl]
+    rfl
+  | inr
+    p =>
+    change
+      (chartU f (intersectionToU f _)).2 =
+        PeriodTorusHigherHomology.sumElimMap (ContinuousMap.id X) (ContinuousMap.id X)
+          (intersectionHomotopyEquiv f _)
+    rw [intersectionHomotopyEquiv_inr, chartU_intersection_inr]
+    rfl
+
+private theorem
+    MappingTorus.HomologyCover.intersectionToV_twistedFold {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) :
+    (homotopyEquivV f).toFun.comp (intersectionToV f) =
+      (PeriodTorusHigherHomology.sumElimMap (ContinuousMap.id X) (f : C(X, X))).comp
+        (intersectionHomotopyEquiv f).toFun := by
+  apply ContinuousMap.ext
+  intro q
+  obtain ⟨p, rfl⟩ := (intersectionHomeomorph f).symm.surjective q
+  cases p with
+  | inl
+    p =>
+    change
+      (chartV f (intersectionToV f _)).2 =
+        PeriodTorusHigherHomology.sumElimMap (ContinuousMap.id X) (f : C(X, X))
+          (intersectionHomotopyEquiv f _)
+    rw [intersectionHomotopyEquiv_inl, chartV_intersection_inl]
+    rfl
+  | inr
+    p =>
+    change
+      (chartV f (intersectionToV f _)).2 =
+        PeriodTorusHigherHomology.sumElimMap (ContinuousMap.id X) (f : C(X, X))
+          (intersectionHomotopyEquiv f _)
+    rw [intersectionHomotopyEquiv_inr, chartV_intersection_inr]
+    rfl
+
+private def ThreefoldOverlapMappingTorus.Cusp.heightContraction (r : ℝ) (h : Height r) :
+    (ContinuousMap.const (Height r) h).Homotopy (ContinuousMap.id (Height r))
+    where
+  toFun
+    p :=
+    ⟨(1 - (p.1 : ℝ)) * (h : ℝ) + (p.1 : ℝ) * (p.2 : ℝ),
+      (convex_Ioi (heightThreshold r)) h.property p.2.property (sub_nonneg.mpr p.1.property.2)
+        p.1.property.1 (sub_add_cancel 1 (p.1 : ℝ))⟩
+  continuous_toFun :=
+    (((continuous_const.sub (continuous_subtype_val.comp continuous_fst)).mul
+              continuous_const).add
+          ((continuous_subtype_val.comp continuous_fst).mul
+            (continuous_subtype_val.comp continuous_snd))).subtype_mk
+      _
+  map_zero_left
+    x := by
+    apply Subtype.ext
+    change (1 - (0 : ℝ)) * (h : ℝ) + 0 * (x : ℝ) = (h : ℝ)
+    simp only [sub_zero, one_mul, MulZeroClass.zero_mul, add_zero]
+  map_one_left
+    x := by
+    apply Subtype.ext
+    change (1 - (1 : ℝ)) * (h : ℝ) + 1 * (x : ℝ) = (x : ℝ)
+    simp only [sub_self, MulZeroClass.zero_mul, one_mul, zero_add]
+
+private def ThreefoldOverlapMappingTorus.Cusp.heightProductHomotopyEquiv (r : ℝ) (h : Height r) :
+    (Height r × Boundary) ≃ₕ Boundary
+    where
+  toFun := ContinuousMap.snd
+  invFun := (ContinuousMap.const Boundary h).prodMk (ContinuousMap.id Boundary)
+  left_inv :=
+    (show (ContinuousMap.const (Height r) h).Homotopic (ContinuousMap.id (Height r)) from
+          ⟨heightContraction r h⟩).prodMap
+      (.refl (ContinuousMap.id Boundary))
+  right_inv := .refl (ContinuousMap.id Boundary)
+
+private def ThreefoldOverlapMappingTorus.Cusp.familyMappingTorusHomotopyEquiv
+    (D : SpecialPeriods.CuspFamily.Data) (h : Height D.radius) : D.Space ≃ₕ Boundary :=
+  (familyProductHomeomorph D).toHomotopyEquiv.trans (heightProductHomotopyEquiv D.radius h)
+
+private def ThreefoldOverlapMappingTorus.Cusp.puncturedFamilyHomeomorph
+    (D : SpecialPeriods.CuspFamily.Data) :
+    D.Space ≃ₜ CuspUniformization.PuncturedQuotient D.correction D.radius := by
+  letI := D.chartedSpace
+  letI :=
+    CuspQuotient.chartedSpace D.correction D.radius D.radius_pos D.radius_lt_one D.holomorphic
+      D.smallDrift
+  exact D.puncturedFamilyBiholomorph.toHomeomorph
+
+@[simp]
+private theorem ThreefoldOverlapMappingTorus.Cusp.puncturedFamilyHomeomorph_iteratedCover
+    (D : SpecialPeriods.CuspFamily.Data) (p : CuspUniformization.LogCover D.radius) :
+    puncturedFamilyHomeomorph D (D.iteratedCover p) =
+      CuspUniformization.puncturedCuspCover D.correction D.radius p := by
+  let := D.chartedSpace
+  let :=
+    CuspQuotient.chartedSpace D.correction D.radius D.radius_pos D.radius_lt_one D.holomorphic
+      D.smallDrift
+  exact D.puncturedFamilyBiholomorph_iteratedCover p
+
+private theorem ThreefoldOverlapMappingTorus.Cusp.puncturedFamilyHomeomorph_base
+    (D : SpecialPeriods.CuspFamily.Data) (q : D.Space) :
+    CuspQuotient.projection D.correction D.radius (puncturedFamilyHomeomorph D q) =
+      (D.projection q : ℂ) := by
+  let := D.chartedSpace
+  let :=
+    CuspQuotient.chartedSpace D.correction D.radius D.radius_pos D.radius_lt_one D.holomorphic
+      D.smallDrift
+  exact D.puncturedFamilyBiholomorph_preserves_base q
+
+private theorem ThreefoldOverlapMappingTorus.Cusp.puncturedFamilyHomeomorph_realCoordinates
+    (D : SpecialPeriods.CuspFamily.Data) (s : SpecialPeriods.CuspFamily.LogBase D.radius)
+    (x : RealPlane₄) :
+    puncturedFamilyHomeomorph D (D.quotient (s, standardLattice.mkQ x)) =
+      CuspUniformization.puncturedCuspCover D.correction D.radius
+        ⟨((s : ℂ), D.periods.periodEquiv s x), s.property⟩ := by
+  have he :
+    D.iteratedCover ⟨((s : ℂ), D.periods.periodEquiv s x), s.property⟩ =
+      D.quotient (s, standardLattice.mkQ x) := by
+    change
+      D.quotient
+          (s, standardLattice.mkQ ((D.periods.periodEquiv s).symm (D.periods.periodEquiv s x))) =
+        _
+    rw [LinearEquiv.symm_apply_apply]
+  rw [← he, puncturedFamilyHomeomorph_iteratedCover]
+
+private def ThreefoldOverlapMappingTorus.Cusp.puncturedProductHomeomorph
+    (D : SpecialPeriods.CuspFamily.Data) :
+    CuspUniformization.PuncturedQuotient D.correction D.radius ≃ₜ Height D.radius × Boundary :=
+  (puncturedFamilyHomeomorph D).symm.trans (familyProductHomeomorph D)
+
+private def ThreefoldOverlapMappingTorus.Cusp.puncturedMappingTorusHomotopyEquiv
+    (D : SpecialPeriods.CuspFamily.Data) (h : Height D.radius) :
+    CuspUniformization.PuncturedQuotient D.correction D.radius ≃ₕ Boundary :=
+  (puncturedFamilyHomeomorph D).symm.toHomotopyEquiv.trans (familyMappingTorusHomotopyEquiv D h)
+
+private def ThreefoldOverlapMappingTorus.Cusp.boundaryInclusion (D : SpecialPeriods.CuspFamily.Data)
+    (h : Height D.radius) :
+    C(Boundary, CuspUniformization.PuncturedQuotient D.correction D.radius) :=
+  (puncturedMappingTorusHomotopyEquiv D h).invFun
+
+private def ThreefoldOverlapMappingTorus.Cusp.boundaryCylinder (D : SpecialPeriods.CuspFamily.Data)
+    (h : Height D.radius) :
+    C(ℝ × RealTorus₄, CuspUniformization.PuncturedQuotient D.correction D.radius) :=
+  (boundaryInclusion D h).comp ⟨MappingTorus.mk monodromy, MappingTorus.mk_continuous monodromy⟩
+
+private theorem ThreefoldOverlapMappingTorus.Cusp.boundaryCylinder_apply
+    (D : SpecialPeriods.CuspFamily.Data) (h : Height D.radius) (t : ℝ) (x : RealTorus₄) :
+    boundaryCylinder D h (t, x) =
+      puncturedFamilyHomeomorph D (D.quotient (logPoint D.radius D.radius_pos t h, x)) := by
+  change
+    puncturedFamilyHomeomorph D
+        ((familyProductHomeomorph D).symm (h, MappingTorus.mk monodromy (t, x))) =
+      _
+  rw [familyProductHomeomorph_symm_mk]
+
+private theorem ThreefoldOverlapMappingTorus.Cusp.boundaryCylinder_realCoordinates
+    (D : SpecialPeriods.CuspFamily.Data) (h : Height D.radius) (t : ℝ) (x : RealPlane₄) :
+    boundaryCylinder D h (t, standardLattice.mkQ x) =
+      CuspUniformization.puncturedCuspCover D.correction D.radius
+        ⟨((logPoint D.radius D.radius_pos t h : ℂ),
+            D.periods.periodEquiv (logPoint D.radius D.radius_pos t h) x),
+          (logPoint D.radius D.radius_pos t h).property⟩ := by
+  rw [boundaryCylinder_apply, puncturedFamilyHomeomorph_realCoordinates]
+
+private theorem ThreefoldOverlapMappingTorus.Cusp.boundaryCylinder_base
+    (D : SpecialPeriods.CuspFamily.Data) (h : Height D.radius) (t : ℝ) (x : RealTorus₄) :
+    CuspQuotient.projection D.correction D.radius (boundaryCylinder D h (t, x)) =
+      CuspUniformization.exponential ((t : ℂ) + (h : ℝ) * Complex.I) := by
+  rw [boundaryCylinder_apply, puncturedFamilyHomeomorph_base, D.projection_quotient]
+  rfl
+
+private def ThreefoldOverlapMappingTorus.Cusp.fibreToPunctured (D : SpecialPeriods.CuspFamily.Data)
+    (h : Height D.radius) :
+    C(RealTorus₄, CuspUniformization.PuncturedQuotient D.correction D.radius) :=
+  (boundaryInclusion D h).comp (MappingTorus.HomologyCover.fibreInclusion monodromy)
+
+private theorem ThreefoldOverlapMappingTorus.Cusp.fibreToPunctured_realCoordinates
+    (D : SpecialPeriods.CuspFamily.Data) (h : Height D.radius) (x : RealPlane₄) :
+    fibreToPunctured D h (standardLattice.mkQ x) =
+      CuspUniformization.puncturedCuspCover D.correction D.radius
+        ⟨((logPoint D.radius D.radius_pos 0 h : ℂ),
+            D.periods.periodEquiv (logPoint D.radius D.radius_pos 0 h) x),
+          (logPoint D.radius D.radius_pos 0 h).property⟩ :=
+  boundaryCylinder_realCoordinates D h 0 x
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Pi1/MappingTorusHomology.lean b/LeanPool/HopfProblem/Pi1/MappingTorusHomology.lean
new file mode 100644
index 000000000..d513d4994
--- /dev/null
+++ b/LeanPool/HopfProblem/Pi1/MappingTorusHomology.lean
@@ -0,0 +1,1423 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Recognition.Smale9
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology4
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Pi1.ThreefoldOverlapMappingTorus1
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import all LeanPool.HopfProblem.PeriodFamily.Core2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import all LeanPool.HopfProblem.Elliptic.Core3
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldGluing1
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods8
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen2
+import all LeanPool.HopfProblem.Recognition.Smale9
+
+/-!
+# Hopf problem: pi 1 · mapping torus homology
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+attribute [local instance] SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace in
+private theorem
+    ThreefoldOverlapMappingTorus.Elliptic.puncturedPieceToRegular_elliptic (j : Elliptic.Kind)
+    (x : ThreefoldOverlapMappingTorus.PuncturedPiece (Option.some j)) :
+    ThreefoldOverlapMappingTorus.puncturedPieceToRegular (Option.some j) x =
+      SpecialPeriods.Threefold.specialEllipticOverlap j x.val := by
+  apply (SpecialPeriods.Threefold.inclusion_openEmbedding Option.none).injective
+  have hx : x.val ∈ (SpecialPeriods.Threefold.specialEllipticOverlap j).source := by
+    rw [SpecialPeriods.Threefold.specialEllipticOverlap_source]
+    exact x.property
+  refine
+    (ThreefoldOverlapMappingTorus.puncturedPieceToRegular_inclusion (Option.some j) x).trans ?_
+  change
+    SpecialPeriods.Threefold.gluingData.inclusion (Option.some (Option.some j)) x.val =
+      SpecialPeriods.Threefold.gluingData.inclusion Option.none
+        (SpecialPeriods.Threefold.specialEllipticOverlap j x.val)
+  exact
+    (SpecialPeriods.Threefold.gluingData.inclusion_eq_iff (Option.some (Option.some j))
+          Option.none _ _).mpr
+      ⟨hx, rfl⟩
+
+private def
+    ThreefoldOverlapMappingTorus.timeShift {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) (θ : ℝ) :
+    C(MappingTorus.Torus f, MappingTorus.Torus f)
+    where
+  toFun :=
+    Quotient.lift (fun p : ℝ × X => MappingTorus.mk f (p.1 + θ, p.2))
+      (by
+        rintro p q ⟨k, rfl⟩
+        simpa only [MappingTorus.deck, add_assoc, add_left_comm, add_comm] using
+          (MappingTorus.mk_deck f k (p.1 + θ, p.2)).symm)
+  continuous_toFun :=
+    ((MappingTorus.mk_continuous f).comp
+          ((continuous_fst.add continuous_const).prodMk continuous_snd)).quotient_lift
+      _
+
+@[simp]
+private theorem
+    ThreefoldOverlapMappingTorus.timeShift_mk {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X)
+    (θ t : ℝ) (x : X) : timeShift f θ (MappingTorus.mk f (t, x)) = MappingTorus.mk f (t + θ, x) :=
+  rfl
+
+@[simp]
+private theorem
+    ThreefoldOverlapMappingTorus.timeShift_zero {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X)
+    (x : MappingTorus.Torus f) : timeShift f 0 x = x := by
+  obtain ⟨⟨t, u⟩, rfl⟩ := MappingTorus.mk_surjective f x
+  simp only [timeShift_mk, add_zero]
+
+private theorem
+    ThreefoldOverlapMappingTorus.timeShift_jointly_continuous {X : Type*} [TopologicalSpace X]
+    (f : X ≃ₜ X) : Continuous (fun p : ℝ × MappingTorus.Torus f => timeShift f p.1 p.2) := by
+  have hq : IsOpenQuotientMap (MappingTorus.mk f) :=
+    ⟨MappingTorus.mk_surjective f, MappingTorus.mk_continuous f, MappingTorus.mk_open f⟩
+  apply (IsOpenQuotientMap.id.prodMap hq).continuous_comp_iff.mp
+  change Continuous (fun p : ℝ × (ℝ × X) => MappingTorus.mk f (p.2.1 + p.1, p.2.2))
+  exact
+    (MappingTorus.mk_continuous f).comp
+      (((continuous_fst.comp continuous_snd).add continuous_fst).prodMk
+        (continuous_snd.comp continuous_snd))
+
+private def
+    ThreefoldOverlapMappingTorus.Elliptic.boundaryInclusionAt (j : Elliptic.Kind) (v : Lattice)
+    (hv : Elliptic.AdmissibleTwist j v) (r : ℝ)
+    (a : ThreefoldOverlapMappingTorus.Radius j.order r) (θ : ℝ) :
+    C(Boundary j v, PuncturedFilling j v hv r) :=
+  ⟨fun x =>
+    (puncturedProductHomeomorph j v hv r).symm
+      (a, ThreefoldOverlapMappingTorus.timeShift (Elliptic.flatTorusAffine j v) θ x),
+    (puncturedProductHomeomorph j v hv r).symm.continuous.comp
+      (continuous_const.prodMk
+        (ThreefoldOverlapMappingTorus.timeShift (Elliptic.flatTorusAffine j v) θ).continuous)⟩
+
+@[simp]
+private theorem ThreefoldOverlapMappingTorus.Elliptic.boundaryInclusionAt_mk (j : Elliptic.Kind)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (r : ℝ)
+    (a : ThreefoldOverlapMappingTorus.Radius j.order r) (θ t : ℝ) (x : RealTorus₄) :
+    boundaryInclusionAt j v hv r a θ (MappingTorus.mk (Elliptic.flatTorusAffine j v) (t, x)) =
+      polarQuotient j v hv r
+        (a, ((((t + θ) / j.order : ℝ) : ThreefoldOverlapMappingTorus.Circle), x)) := by
+  change
+    (puncturedProductHomeomorph j v hv r).symm
+        (a,
+          ThreefoldOverlapMappingTorus.timeShift (Elliptic.flatTorusAffine j v) θ
+            (MappingTorus.mk _ (t, x))) =
+      _
+  rw [ThreefoldOverlapMappingTorus.timeShift_mk, puncturedProductHomeomorph_symm_mk]
+
+private def ThreefoldOverlapMappingTorus.Elliptic.boundaryRadiusPhaseHomotopy (j : Elliptic.Kind)
+    (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (r : ℝ)
+    (a b : ThreefoldOverlapMappingTorus.Radius j.order r) (θ : ℝ) :
+    (boundaryInclusion j v hv r a).Homotopy (boundaryInclusionAt j v hv r b θ)
+    where
+  toFun
+    p :=
+    (puncturedProductHomeomorph j v hv r).symm
+      (ThreefoldOverlapMappingTorus.radiusSegment a b p.1,
+        ThreefoldOverlapMappingTorus.timeShift (Elliptic.flatTorusAffine j v) ((p.1 : ℝ) * θ) p.2)
+  continuous_toFun :=
+    (puncturedProductHomeomorph j v hv r).symm.continuous.comp
+      (((ThreefoldOverlapMappingTorus.radiusSegment_continuous a).comp
+            (continuous_fst.prodMk continuous_const)).prodMk
+        ((ThreefoldOverlapMappingTorus.timeShift_jointly_continuous
+              (Elliptic.flatTorusAffine j v)).comp
+          (((continuous_subtype_val.comp continuous_fst).mul continuous_const).prodMk
+            continuous_snd)))
+  map_zero_left
+    x := by
+    change
+      (puncturedProductHomeomorph j v hv r).symm
+          (ThreefoldOverlapMappingTorus.radiusSegment a b 0,
+            ThreefoldOverlapMappingTorus.timeShift (Elliptic.flatTorusAffine j v)
+              ((0 : unitInterval) * θ) x) =
+        (puncturedProductHomeomorph j v hv r).symm (a, x)
+    simp
+  map_one_left
+    x := by
+    change
+      (puncturedProductHomeomorph j v hv r).symm
+          (ThreefoldOverlapMappingTorus.radiusSegment a b 1,
+            ThreefoldOverlapMappingTorus.timeShift (Elliptic.flatTorusAffine j v)
+              ((1 : unitInterval) * θ) x) =
+        (puncturedProductHomeomorph j v hv r).symm
+          (b, ThreefoldOverlapMappingTorus.timeShift (Elliptic.flatTorusAffine j v) θ x)
+    simp
+
+private def ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryInclusionAt (j : Elliptic.Kind)
+    (a :
+      ThreefoldOverlapMappingTorus.Radius j.order
+        (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)))
+    (θ : ℝ) : C(SpecialBoundary j, ThreefoldOverlapMappingTorus.PuncturedPiece (Option.some j)) :=
+  ((specialPuncturedHomeomorph j).symm : C(_, _)).comp
+    (boundaryInclusionAt j j.twist (Elliptic.mainTwist_admissible j)
+      (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) a θ)
+
+private def
+    ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryRadiusPhaseHomotopy (j : Elliptic.Kind)
+    (a :
+      ThreefoldOverlapMappingTorus.Radius j.order
+        (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)))
+    (θ : ℝ) : (specialBoundaryInclusion j).Homotopy (specialBoundaryInclusionAt j a θ) :=
+  (ContinuousMap.Homotopy.refl
+        ((specialPuncturedHomeomorph j).symm :
+          C(PuncturedFilling j j.twist (Elliptic.mainTwist_admissible j)
+              (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)),
+            ThreefoldOverlapMappingTorus.PuncturedPiece (Option.some j)))).comp
+    (boundaryRadiusPhaseHomotopy j j.twist (Elliptic.mainTwist_admissible j)
+      (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) (specialRootRadius j) a
+      θ)
+
+private theorem
+    ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryInclusionAt_mk (j : Elliptic.Kind)
+    (a :
+      ThreefoldOverlapMappingTorus.Radius j.order
+        (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)))
+    (θ : ℝ) (t : ℝ) (x : RealTorus₄) :
+    ((specialBoundaryInclusionAt j a θ
+              (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (t, x))).val :
+          SpecialPeriods.Threefold.SpecialEllipticPiece j).val =
+      (SpecialPeriods.EllipticFilling.specialLocalData j).quotient j.twist
+        (Elliptic.mainTwist_admissible j)
+        (ThreefoldOverlapMappingTorus.root j.order
+            (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) a
+            (((t + θ) / j.order : ℝ) : ThreefoldOverlapMappingTorus.Circle),
+          x) := by
+  change
+    (((specialPuncturedHomeomorph j).symm
+              (boundaryInclusionAt j j.twist (Elliptic.mainTwist_admissible j)
+                (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) a θ
+                (MappingTorus.mk _ (t, x)))).val :
+          SpecialPeriods.Threefold.SpecialEllipticPiece j).val =
+      _
+  rw [boundaryInclusionAt_mk]
+  rfl
+
+private def
+    ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryToRegularFamilyAt (j : Elliptic.Kind)
+    (a :
+      ThreefoldOverlapMappingTorus.Radius j.order
+        (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)))
+    (θ : ℝ) : C(SpecialBoundary j, SpecialPeriods.Threefold.SpecialRegularFamily) :=
+  (ThreefoldOverlapMappingTorus.puncturedPieceToRegular (Option.some j)).comp
+    (specialBoundaryInclusionAt j a θ)
+
+private theorem ThreefoldOverlapMappingTorus.Elliptic.boundaryToRegularFamily_homotopic_at
+    (j : Elliptic.Kind)
+    (a :
+      ThreefoldOverlapMappingTorus.Radius j.order
+        (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)))
+    (θ : ℝ) :
+    (ThreefoldOverlapMappingTorus.boundaryToRegularFamily (Option.some j)).Homotopic
+      (specialBoundaryToRegularFamilyAt j a θ) := by
+  change
+    ((ThreefoldOverlapMappingTorus.puncturedPieceToRegular (Option.some j)).comp
+          (specialBoundaryInclusion j)).Homotopic
+      _
+  exact
+    ⟨(ContinuousMap.Homotopy.refl
+            (ThreefoldOverlapMappingTorus.puncturedPieceToRegular (Option.some j))).comp
+        (specialBoundaryRadiusPhaseHomotopy j a θ)⟩
+
+private theorem
+    ThreefoldOverlapMappingTorus.Elliptic.boundaryRegularHomologyMap_at (j : Elliptic.Kind)
+    (a :
+      ThreefoldOverlapMappingTorus.Radius j.order
+        (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)))
+    (θ : ℝ) (n : ℕ) :
+    ThreefoldOverlapMappingTorus.boundaryRegularHomologyMap (Option.some j) n =
+      SingularMayerVietoris.singularHomologyMap (specialBoundaryToRegularFamilyAt j a θ) n :=
+  PeriodTorusHigherHomology.homotopic_homologyMap (boundaryToRegularFamily_homotopic_at j a θ) n
+
+private def MappingTorusHomology.Covering.lowerSection {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (k : ℕ) : C(X, ↥(MappingTorus.HomologyCover.U f ∩ MappingTorus.HomologyCover.V f))
+    where
+  toFun
+    x :=
+    (MappingTorus.HomologyCover.intersectionHomeomorph f).symm
+      (Sum.inl (⟨(1 / 4 : ℝ), by norm_num⟩, (f ^ k) x))
+  continuous_toFun :=
+    (MappingTorus.HomologyCover.intersectionHomeomorph f).symm.continuous.comp
+      (continuous_inl.comp (continuous_const.prodMk (f ^ k).continuous))
+
+private def MappingTorusHomology.Covering.upperSection {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (k : ℕ) : C(X, ↥(MappingTorus.HomologyCover.U f ∩ MappingTorus.HomologyCover.V f))
+    where
+  toFun
+    x :=
+    (MappingTorus.HomologyCover.intersectionHomeomorph f).symm
+      (Sum.inr (⟨(3 / 4 : ℝ), by norm_num⟩, (f ^ k) x))
+  continuous_toFun :=
+    (MappingTorus.HomologyCover.intersectionHomeomorph f).symm.continuous.comp
+      (continuous_inr.comp (continuous_const.prodMk (f ^ k).continuous))
+
+@[simp]
+private theorem MappingTorusHomology.Covering.lowerSection_val {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (k : ℕ) (x : X) :
+    (lowerSection f k x : MappingTorus.Torus f) = MappingTorus.mk f (1 / 4, (f ^ k) x) :=
+  MappingTorus.HomologyCover.intersectionHomeomorph_symm_inl_coe f _
+
+@[simp]
+private theorem MappingTorusHomology.Covering.upperSection_val {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (k : ℕ) (x : X) :
+    (upperSection f k x : MappingTorus.Torus f) = MappingTorus.mk f (3 / 4, (f ^ k) x) :=
+  MappingTorus.HomologyCover.intersectionHomeomorph_symm_inr_coe f _
+
+private def MappingTorusHomology.Covering.uTime (t : unitInterval) : Set.Ioo (0 : ℝ) 1 :=
+  ⟨(1 / 4 : ℝ) + (t : ℝ) / 2, by constructor <;> linarith [t.property.1, t.property.2]⟩
+
+private theorem MappingTorusHomology.Covering.uTime_continuous : Continuous uTime :=
+  (continuous_const.add (continuous_subtype_val.div_const 2)).subtype_mk _
+
+private def
+    MappingTorusHomology.Covering.vTime (t : unitInterval) : Set.Ioo (-(1 / 2 : ℝ)) (1 / 2) :=
+  ⟨-(1 / 4 : ℝ) + (t : ℝ) / 2, by constructor <;> linarith [t.property.1, t.property.2]⟩
+
+private theorem MappingTorusHomology.Covering.vTime_continuous : Continuous vTime :=
+  (continuous_const.add (continuous_subtype_val.div_const 2)).subtype_mk _
+
+private def
+    MappingTorusHomology.Covering.uStrip {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) (k : ℕ) :
+    C(unitInterval × X, MappingTorus.HomologyCover.U f)
+    where
+  toFun p := (MappingTorus.HomologyCover.chartU f).symm (uTime p.1, (f ^ k) p.2)
+  continuous_toFun :=
+    (MappingTorus.HomologyCover.chartU f).symm.continuous.comp
+      ((uTime_continuous.comp continuous_fst).prodMk ((f ^ k).continuous.comp continuous_snd))
+
+private def
+    MappingTorusHomology.Covering.vStrip {X : Type} [TopologicalSpace X] (f : X ≃ₜ X) (k : ℕ) :
+    C(unitInterval × X, MappingTorus.HomologyCover.V f)
+    where
+  toFun p := (MappingTorus.HomologyCover.chartV f).symm (vTime p.1, (f ^ (k + 1)) p.2)
+  continuous_toFun :=
+    (MappingTorus.HomologyCover.chartV f).symm.continuous.comp
+      ((vTime_continuous.comp continuous_fst).prodMk
+        ((f ^ (k + 1)).continuous.comp continuous_snd))
+
+@[simp]
+private theorem
+    MappingTorusHomology.Covering.uStrip_val {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (k : ℕ) (p : unitInterval × X) :
+    (uStrip f k p : MappingTorus.Torus f) =
+      MappingTorus.mk f ((1 / 4 : ℝ) + (p.1 : ℝ) / 2, (f ^ k) p.2) :=
+  MappingTorus.HomologyCover.chartU_symm_coe f _
+
+@[simp]
+private theorem
+    MappingTorusHomology.Covering.vStrip_val {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (k : ℕ) (p : unitInterval × X) :
+    (vStrip f k p : MappingTorus.Torus f) =
+      MappingTorus.mk f (-(1 / 4 : ℝ) + (p.1 : ℝ) / 2, (f ^ (k + 1)) p.2) :=
+  MappingTorus.HomologyCover.chartV_symm_coe f _
+
+private theorem
+    MappingTorusHomology.Covering.uStrip_zero {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (k : ℕ) :
+    (uStrip f k).comp (PeriodTorusHigherHomology.crossInsertLeft (0 : unitInterval)) =
+      (MappingTorus.HomologyCover.intersectionToU f).comp (lowerSection f k) := by
+  apply ContinuousMap.ext
+  intro x
+  apply Subtype.ext
+  change (uStrip f k (0, x) : MappingTorus.Torus f) = (lowerSection f k x : MappingTorus.Torus f)
+  rw [uStrip_val, lowerSection_val]
+  simp
+
+private theorem
+    MappingTorusHomology.Covering.uStrip_one {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (k : ℕ) :
+    (uStrip f k).comp (PeriodTorusHigherHomology.crossInsertLeft (1 : unitInterval)) =
+      (MappingTorus.HomologyCover.intersectionToU f).comp (upperSection f k) := by
+  apply ContinuousMap.ext
+  intro x
+  apply Subtype.ext
+  change (uStrip f k (1, x) : MappingTorus.Torus f) = (upperSection f k x : MappingTorus.Torus f)
+  rw [uStrip_val, upperSection_val]
+  norm_num
+
+private theorem
+    MappingTorusHomology.Covering.vStrip_zero {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (k : ℕ) :
+    (vStrip f k).comp (PeriodTorusHigherHomology.crossInsertLeft (0 : unitInterval)) =
+      (MappingTorus.HomologyCover.intersectionToV f).comp (upperSection f k) := by
+  apply ContinuousMap.ext
+  intro x
+  apply Subtype.ext
+  change (vStrip f k (0, x) : MappingTorus.Torus f) = (upperSection f k x : MappingTorus.Torus f)
+  rw [vStrip_val, upperSection_val]
+  have hpow : (f ^ (k + 1)) x = f ((f ^ k) x) := by rw [pow_succ', Homeomorph.mul_apply]
+  rw [hpow]
+  convert MappingTorus.mk_sub_one f (3 / 4) ((f ^ k) x) using 1
+  norm_num
+
+private theorem
+    MappingTorusHomology.Covering.vStrip_one {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (k : ℕ) :
+    (vStrip f k).comp (PeriodTorusHigherHomology.crossInsertLeft (1 : unitInterval)) =
+      (MappingTorus.HomologyCover.intersectionToV f).comp (lowerSection f (k + 1)) := by
+  apply ContinuousMap.ext
+  intro x
+  apply Subtype.ext
+  change
+    (vStrip f k (1, x) : MappingTorus.Torus f) = (lowerSection f (k + 1) x : MappingTorus.Torus f)
+  rw [vStrip_val, lowerSection_val]
+  norm_num
+
+private theorem MappingTorusHomology.Covering.lowerSection_period {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (m : ℕ) (hf : f ^ m = 1) : lowerSection f m = lowerSection f 0 := by
+  apply ContinuousMap.ext
+  intro x
+  change
+    (MappingTorus.HomologyCover.intersectionHomeomorph f).symm (Sum.inl (_, (f ^ m) x)) =
+      (MappingTorus.HomologyCover.intersectionHomeomorph f).symm (Sum.inl (_, (f ^ 0) x))
+  rw [hf, pow_zero]
+
+private theorem MappingTorusHomology.Covering.lowerSection_component {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (k : ℕ) :
+    (MappingTorus.HomologyCover.intersectionHomotopyEquiv f).toFun.comp (lowerSection f k) =
+      (⟨Sum.inl, continuous_inl⟩ : C(X, X ⊕ X)).comp ((f ^ k : X ≃ₜ X) : C(X, X)) := by
+  apply ContinuousMap.ext
+  intro x
+  exact MappingTorus.HomologyCover.intersectionHomotopyEquiv_inl f _
+
+private theorem MappingTorusHomology.Covering.upperSection_component {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (k : ℕ) :
+    (MappingTorus.HomologyCover.intersectionHomotopyEquiv f).toFun.comp (upperSection f k) =
+      (⟨Sum.inr, continuous_inr⟩ : C(X, X ⊕ X)).comp ((f ^ k : X ≃ₜ X) : C(X, X)) := by
+  apply ContinuousMap.ext
+  intro x
+  exact MappingTorus.HomologyCover.intersectionHomotopyEquiv_inr f _
+
+private theorem MappingTorusHomology.Covering.lowerSection_homology_coordinates {X : Type}
+    [TopologicalSpace X] (f : X ≃ₜ X) (k n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    MappingTorusHomology.intersectionHomologyEquiv f n
+        (SingularMayerVietoris.singularHomologyMap (lowerSection f k) n a) =
+      (SingularMayerVietoris.singularHomologyMap ((f ^ k : X ≃ₜ X) : C(X, X)) n a, 0) := by
+  rw [MappingTorusHomology.intersectionHomologyEquiv_apply, ← LinearMap.comp_apply, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp, lowerSection_component,
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+  exact PeriodTorusHigherHomology.sumHomologyEquiv_inl X X n _
+
+private theorem MappingTorusHomology.Covering.upperSection_homology_coordinates {X : Type}
+    [TopologicalSpace X] (f : X ≃ₜ X) (k n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    MappingTorusHomology.intersectionHomologyEquiv f n
+        (SingularMayerVietoris.singularHomologyMap (upperSection f k) n a) =
+      (0, SingularMayerVietoris.singularHomologyMap ((f ^ k : X ≃ₜ X) : C(X, X)) n a) := by
+  rw [MappingTorusHomology.intersectionHomologyEquiv_apply, ← LinearMap.comp_apply, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp, upperSection_component,
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+  exact PeriodTorusHigherHomology.sumHomologyEquiv_inr X X n _
+
+private theorem
+    MappingTorusHomology.Covering.mk_add_int {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (t : ℝ) (k : ℤ) (x : X) :
+    MappingTorus.mk f (t + (k : ℝ), x) = MappingTorus.mk f (t, (f ^ k) x) := by
+  apply (MappingTorus.mk_eq_mk_iff f _ _).mpr
+  exact ⟨-k, by simp, by simp⟩
+
+private def
+    MappingTorusHomology.Covering.productCover {X : Type} [TopologicalSpace X] [CompactSpace X]
+    [T2Space X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) :
+    C(MappingTorus.Circle × X, MappingTorus.Torus B.symm)
+    where
+  toFun :=
+    Elliptic.HigherHomology.MappingTorusQuotient.mappingTorusHomeomorph m B hB ∘
+      Elliptic.HigherHomology.MappingTorusQuotient.project m B hB
+  continuous_toFun :=
+    (Elliptic.HigherHomology.MappingTorusQuotient.mappingTorusHomeomorph m B hB).continuous.comp
+      (Elliptic.HigherHomology.MappingTorusQuotient.project_continuous m B hB)
+
+private theorem
+    MappingTorusHomology.Covering.productCover_real_apply {X : Type} [TopologicalSpace X]
+    [CompactSpace X] [T2Space X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) (t : ℝ)
+    (x : X) :
+    productCover m B hB ((t : MappingTorus.Circle), x) = MappingTorus.mk B.symm (t * m, x) :=
+  Elliptic.HigherHomology.MappingTorusQuotient.mappingTorusHomeomorph_project m B hB t x
+
+@[simp]
+private theorem
+    MappingTorusHomology.Covering.productCover_zero_apply {X : Type} [TopologicalSpace X]
+    [CompactSpace X] [T2Space X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) (x : X) :
+    productCover m B hB (0, x) = MappingTorus.mk B.symm (0, x) := by
+  simpa only [AddCircle.coe_zero, MulZeroClass.zero_mul] using productCover_real_apply m B hB 0 x
+
+@[simp]
+private theorem MappingTorusHomology.Covering.productCover_comp_productSection {X : Type}
+    [TopologicalSpace X] [CompactSpace X] [T2Space X] (m : ℕ) [NeZero m] (B : X ≃ₜ X)
+    (hB : B ^ m = 1) :
+    (productCover m B hB).comp (PeriodTorusHigherHomology.CircleTopology.productSection X) =
+      MappingTorus.HomologyCover.fibreInclusion B.symm := by
+  apply ContinuousMap.ext
+  intro x
+  exact productCover_zero_apply m B hB x
+
+private abbrev MappingTorusHomology.Covering.productCoverHomology {X : Type} [TopologicalSpace X]
+    [CompactSpace X] [T2Space X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (MappingTorus.Circle × X) n →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (MappingTorus.Torus B.symm) n :=
+  SingularMayerVietoris.singularHomologyMap (productCover m B hB) n
+
+private theorem MappingTorusHomology.Covering.productCoverHomology_comp_circleSection {X : Type}
+    [TopologicalSpace X] [CompactSpace X] [T2Space X] (m : ℕ) [NeZero m] (B : X ≃ₜ X)
+    (hB : B ^ m = 1) (n : ℕ) :
+    (productCoverHomology m B hB n).comp (PeriodTorusHigherHomology.circleSectionHomology X n) =
+      MappingTorusHomology.fibreHomologyMap B.symm n := by
+  change
+    (SingularMayerVietoris.singularHomologyMap (productCover m B hB) n).comp
+        (SingularMayerVietoris.singularHomologyMap
+          (PeriodTorusHigherHomology.CircleTopology.productSection X) n) =
+      _
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp, productCover_comp_productSection]
+
+@[simp]
+private theorem MappingTorusHomology.Covering.productCoverHomology_circleSection_apply {X : Type}
+    [TopologicalSpace X] [CompactSpace X] [T2Space X] (m : ℕ) [NeZero m] (B : X ≃ₜ X)
+    (hB : B ^ m = 1) (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    productCoverHomology m B hB n (PeriodTorusHigherHomology.circleSectionHomology X n a) =
+      MappingTorusHomology.fibreHomologyMap B.symm n a :=
+  LinearMap.congr_fun (productCoverHomology_comp_circleSection m B hB n) a
+
+private theorem MappingTorusHomology.Covering.wangBoundary_productCover_circleSection {X : Type}
+    [TopologicalSpace X] [CompactSpace X] [T2Space X] (m : ℕ) [NeZero m] (B : X ≃ₜ X)
+    (hB : B ^ m = 1) (n : ℕ) :
+    ((MappingTorusHomology.wangBoundary B.symm n).comp (productCoverHomology m B hB (n + 1))).comp
+        (PeriodTorusHigherHomology.circleSectionHomology X (n + 1)) =
+      0 := by
+  ext a
+  change
+    MappingTorusHomology.wangBoundary B.symm n
+        (productCoverHomology m B hB (n + 1)
+          (PeriodTorusHigherHomology.circleSectionHomology X (n + 1) a)) =
+      0
+  rw [productCoverHomology_circleSection_apply]
+  have ha :
+    MappingTorusHomology.fibreHomologyMap B.symm (n + 1) a ∈
+      LinearMap.range (MappingTorusHomology.fibreHomologyMap B.symm (n + 1)) :=
+    ⟨a, rfl⟩
+  rw [MappingTorusHomology.wang_exact_at_mappingTorus] at ha
+  exact ha
+
+private theorem
+    MappingTorusHomology.Covering.wangBoundary_productCover_circleSection_apply {X : Type}
+    [TopologicalSpace X] [CompactSpace X] [T2Space X] (m : ℕ) [NeZero m] (B : X ≃ₜ X)
+    (hB : B ^ m = 1) (n : ℕ) (a : SingularMayerVietoris.SingularHomology X (n + 1)) :
+    MappingTorusHomology.wangBoundary B.symm n
+        (productCoverHomology m B hB (n + 1)
+          (PeriodTorusHigherHomology.circleSectionHomology X (n + 1) a)) =
+      0 :=
+  LinearMap.congr_fun (wangBoundary_productCover_circleSection m B hB n) a
+
+private def MappingTorusHomology.Covering.affineRealArc (a b : ℝ) : Path a b
+    where
+  toFun t := a + (b - a) * (t : ℝ)
+  continuous_toFun := continuous_const.add (continuous_const.mul continuous_subtype_val)
+  source' := by simp
+  target' := by simp
+
+private def MappingTorusHomology.Covering.affineCircleArc (a b : ℝ) :
+    Path (a : (PeriodTorusHigherHomology.CircleTopology.Circle))
+      (b : (PeriodTorusHigherHomology.CircleTopology.Circle)) :=
+  (affineRealArc a b).map (AddCircle.continuous_mk' (1 : ℝ))
+
+@[simp]
+private theorem MappingTorusHomology.Covering.affineCircleArc_apply (a b : ℝ) (t : unitInterval) :
+    affineCircleArc a b t =
+      ((a + (b - a) * (t : ℝ) : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle)) :=
+  rfl
+
+@[simp]
+private theorem MappingTorusHomology.Covering.affineCircleArc_self (a : ℝ) :
+    affineCircleArc a a = Path.refl (a : (PeriodTorusHigherHomology.CircleTopology.Circle)) := by
+  apply Path.ext
+  funext t
+  simp
+
+private theorem MappingTorusHomology.Covering.affineCircleArc_trans_homotopic (a b c : ℝ) :
+    ((affineCircleArc a b).trans (affineCircleArc b c)).Homotopic (affineCircleArc a c) := by
+  have h :=
+    SimplyConnectedSpace.paths_homotopic ((affineRealArc a b).trans (affineRealArc b c))
+      (affineRealArc a c)
+  have hmap :=
+    h.map
+      (⟨fun x : ℝ => (x : (PeriodTorusHigherHomology.CircleTopology.Circle)),
+          AddCircle.continuous_mk' (1 : ℝ)⟩ :
+        C(ℝ, (PeriodTorusHigherHomology.CircleTopology.Circle)))
+  rw [Path.map_trans] at hmap
+  exact hmap
+
+private theorem MappingTorusHomology.Covering.pathClass_affineCircleArc_add (a b c : ℝ) :
+    FirstHurewicz.pathClass (affineCircleArc a b) +
+        FirstHurewicz.pathClass (affineCircleArc b c) =
+      FirstHurewicz.pathClass (affineCircleArc a c) := by
+  rw [← FirstHurewicz.pathClass_trans]
+  exact FirstHurewicz.pathClass_homotopic (affineCircleArc_trans_homotopic a b c)
+
+private def MappingTorusHomology.Covering.quarterLift (m k : ℕ) : ℝ :=
+  ((k : ℝ) + 1 / 4) / m
+
+private def MappingTorusHomology.Covering.threeQuarterLift (m k : ℕ) : ℝ :=
+  ((k : ℝ) + 3 / 4) / m
+
+private def MappingTorusHomology.Covering.uPath (m k : ℕ) :
+    Path (quarterLift m k : (PeriodTorusHigherHomology.CircleTopology.Circle))
+      (threeQuarterLift m k : (PeriodTorusHigherHomology.CircleTopology.Circle)) :=
+  affineCircleArc (quarterLift m k) (threeQuarterLift m k)
+
+private def MappingTorusHomology.Covering.vPath (m k : ℕ) :
+    Path (threeQuarterLift m k : (PeriodTorusHigherHomology.CircleTopology.Circle))
+      (quarterLift m (k + 1) : (PeriodTorusHigherHomology.CircleTopology.Circle)) :=
+  affineCircleArc (threeQuarterLift m k) (quarterLift m (k + 1))
+
+@[simp]
+private theorem MappingTorusHomology.Covering.uPath_apply (m k : ℕ) (t : unitInterval) :
+    uPath m k t =
+      ((((k : ℝ) + 1 / 4 + (t : ℝ) / 2) / m : ℝ) :
+        (PeriodTorusHigherHomology.CircleTopology.Circle)) := by
+  change
+    (((quarterLift m k + (threeQuarterLift m k - quarterLift m k) * (t : ℝ)) : ℝ) :
+        (PeriodTorusHigherHomology.CircleTopology.Circle)) =
+      _
+  congr 1
+  unfold quarterLift threeQuarterLift
+  ring
+
+@[simp]
+private theorem MappingTorusHomology.Covering.vPath_apply (m k : ℕ) (t : unitInterval) :
+    vPath m k t =
+      ((((k : ℝ) + 3 / 4 + (t : ℝ) / 2) / m : ℝ) :
+        (PeriodTorusHigherHomology.CircleTopology.Circle)) := by
+  change
+    (((threeQuarterLift m k + (quarterLift m (k + 1) - threeQuarterLift m k) * (t : ℝ)) : ℝ) :
+        (PeriodTorusHigherHomology.CircleTopology.Circle)) =
+      _
+  congr 1
+  unfold quarterLift threeQuarterLift
+  push_cast
+  ring
+
+private theorem MappingTorusHomology.Covering.pathClass_uPath_add_vPath (m k : ℕ) :
+    FirstHurewicz.pathClass (uPath m k) + FirstHurewicz.pathClass (vPath m k) =
+      FirstHurewicz.pathClass (affineCircleArc (quarterLift m k) (quarterLift m (k + 1))) :=
+  pathClass_affineCircleArc_add _ _ _
+
+private theorem MappingTorusHomology.Covering.quarterLift_period (m : ℕ) [NeZero m] :
+    quarterLift m m = quarterLift m 0 + 1 := by
+  have hm : (m : ℝ) ≠ 0 := Nat.cast_ne_zero.mpr (NeZero.ne m)
+  simp only [quarterLift, Nat.cast_zero, zero_add]
+  field_simp
+  ring
+
+private theorem MappingTorusHomology.Covering.quarterLift_circle_period (m : ℕ) [NeZero m] :
+    (quarterLift m m : (PeriodTorusHigherHomology.CircleTopology.Circle)) =
+      (quarterLift m 0 : (PeriodTorusHigherHomology.CircleTopology.Circle)) := by
+  rw [quarterLift_period]
+  exact AddCircle.coe_add_period (1 : ℝ) _
+
+private theorem MappingTorusHomology.Covering.boundaryOne_arcPrefix (m n : ℕ) :
+    FirstHurewicz.boundaryOne (PeriodTorusHigherHomology.CircleTopology.Circle)
+        (∑ k ∈ Finset.range n,
+          (FirstHurewicz.pathChain (uPath m k) + FirstHurewicz.pathChain (vPath m k))) =
+      FirstHurewicz.pointChain
+          (quarterLift m n : (PeriodTorusHigherHomology.CircleTopology.Circle)) -
+        FirstHurewicz.pointChain
+          (quarterLift m 0 : (PeriodTorusHigherHomology.CircleTopology.Circle)) := by
+  induction n with
+  | zero => simp
+  | succ n
+    ih =>
+    rw [Finset.sum_range_succ, map_add, ih, map_add, FirstHurewicz.boundaryOne_pathChain,
+      FirstHurewicz.boundaryOne_pathChain]
+    abel
+
+private theorem MappingTorusHomology.Covering.chainClass_arcPrefix (m n : ℕ) :
+    FirstHurewicz.chainClass (PeriodTorusHigherHomology.CircleTopology.Circle)
+        (∑ k ∈ Finset.range n,
+          (FirstHurewicz.pathChain (uPath m k) + FirstHurewicz.pathChain (vPath m k))) =
+      FirstHurewicz.pathClass (affineCircleArc (quarterLift m 0) (quarterLift m n)) := by
+  induction n with
+  | zero => simp
+  | succ n ih =>
+    rw [Finset.sum_range_succ, map_add, ih, map_add]
+    change
+      FirstHurewicz.pathClass (affineCircleArc (quarterLift m 0) (quarterLift m n)) +
+          (FirstHurewicz.pathClass (uPath m n) + FirstHurewicz.pathClass (vPath m n)) =
+        _
+    rw [pathClass_uPath_add_vPath, pathClass_affineCircleArc_add]
+
+private def MappingTorusHomology.Covering.arcSumChain (m : ℕ) :
+    FirstHurewicz.Chains (PeriodTorusHigherHomology.CircleTopology.Circle) 1 :=
+  ∑ k ∈ Finset.range m,
+    (FirstHurewicz.pathChain (uPath m k) + FirstHurewicz.pathChain (vPath m k))
+
+private theorem MappingTorusHomology.Covering.boundaryOne_arcSumChain (m : ℕ) [NeZero m] :
+    FirstHurewicz.boundaryOne (PeriodTorusHigherHomology.CircleTopology.Circle) (arcSumChain m) =
+      0 := by rw [arcSumChain, boundaryOne_arcPrefix, quarterLift_circle_period, sub_self]
+
+private def MappingTorusHomology.Covering.arcSumCycle (m : ℕ) [NeZero m] :
+    FirstHurewicz.Cycles1 (PeriodTorusHigherHomology.CircleTopology.Circle) :=
+  FirstHurewicz.mkCycle1 (PeriodTorusHigherHomology.CircleTopology.Circle) (arcSumChain m)
+    (boundaryOne_arcSumChain m)
+
+@[simp]
+private theorem MappingTorusHomology.Covering.arcSumCycle_val (m : ℕ) [NeZero m] :
+    (arcSumCycle m).1 = arcSumChain m :=
+  rfl
+
+private theorem MappingTorusHomology.Covering.chainClass_arcSumChain (m : ℕ) :
+    FirstHurewicz.chainClass (PeriodTorusHigherHomology.CircleTopology.Circle) (arcSumChain m) =
+      FirstHurewicz.pathClass (affineCircleArc (quarterLift m 0) (quarterLift m m)) :=
+  chainClass_arcPrefix m m
+
+private def MappingTorusHomology.Covering.translatedPositiveLoop (a : ℝ) :
+    Path (a : (PeriodTorusHigherHomology.CircleTopology.Circle))
+      (a : (PeriodTorusHigherHomology.CircleTopology.Circle)) :=
+  ((PeriodTorusHigherHomology.CirclePaths.positiveLoop.map
+        (PeriodTorusHigherHomology.CirclePaths.circleTranslation a).continuous).cast
+    (by simp) (by simp))
+
+@[simp]
+private theorem
+    MappingTorusHomology.Covering.translatedPositiveLoop_apply (a : ℝ) (t : unitInterval) :
+    translatedPositiveLoop a t =
+      ((a + (t : ℝ) : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle)) := by
+  change
+    (a : (PeriodTorusHigherHomology.CircleTopology.Circle)) +
+        ((t : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle)) =
+      ((a + (t : ℝ) : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle))
+  exact (AddCircle.coe_add (1 : ℝ) a (t : ℝ)).symm
+
+private theorem MappingTorusHomology.Covering.pathClass_affineCircleArc_period (a : ℝ) :
+    FirstHurewicz.pathClass (affineCircleArc a (a + 1)) =
+      FirstHurewicz.pathClass (translatedPositiveLoop a) := by
+  have hp :
+    (affineCircleArc a (a + 1)).cast rfl (AddCircle.coe_add_period (1 : ℝ) a).symm =
+      translatedPositiveLoop a := by
+    apply Path.ext
+    funext t
+    simp only [Path.cast_coe, affineCircleArc_apply, translatedPositiveLoop_apply]
+    congr 1
+    ring
+  rw [← hp, FirstHurewicz.pathClass_cast]
+
+private theorem MappingTorusHomology.Covering.translatedPositiveLoop_class (a : ℝ) :
+    FirstHurewicz.loopHomologyClass (translatedPositiveLoop a) =
+      FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop := by
+  have hc :
+    FirstHurewicz.loopHomologyClass (translatedPositiveLoop a) =
+      FirstHurewicz.loopHomologyClass
+        (PeriodTorusHigherHomology.CirclePaths.positiveLoop.map
+          (PeriodTorusHigherHomology.CirclePaths.circleTranslation a).continuous) := by
+    apply
+      FirstHurewicz.homologyToChainClass_injective
+        (PeriodTorusHigherHomology.CircleTopology.Circle)
+    rw [FirstHurewicz.homologyToChainClass_loopHomologyClass,
+      FirstHurewicz.homologyToChainClass_loopHomologyClass]
+    rfl
+  exact
+    hc.trans (PeriodTorusHigherHomology.CirclePaths.loopHomologyClass_map_circleTranslation a _)
+
+private theorem MappingTorusHomology.Covering.arcSumCycle_positiveLoop_class (m : ℕ) [NeZero m] :
+    FirstHurewicz.cycleClass (PeriodTorusHigherHomology.CircleTopology.Circle) (arcSumCycle m) =
+      FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop := by
+  rw [← translatedPositiveLoop_class (quarterLift m 0)]
+  apply
+    FirstHurewicz.homologyToChainClass_injective (PeriodTorusHigherHomology.CircleTopology.Circle)
+  rw [FirstHurewicz.homologyToChainClass_cycleClass,
+    FirstHurewicz.homologyToChainClass_loopHomologyClass, arcSumCycle_val, chainClass_arcSumChain,
+    quarterLift_period, pathClass_affineCircleArc_period]
+
+private def
+    MappingTorusHomology.Covering.uCircleMap (m k : ℕ) : C(unitInterval, (MappingTorus.Circle)) :=
+  ⟨uPath m k, (uPath m k).continuous⟩
+
+private def
+    MappingTorusHomology.Covering.vCircleMap (m k : ℕ) : C(unitInterval, (MappingTorus.Circle)) :=
+  ⟨vPath m k, (vPath m k).continuous⟩
+
+private theorem MappingTorusHomology.Covering.uCircleMap_pathChain (m k : ℕ) :
+    FirstHurewicz.inducedChain (uCircleMap m k) 1 (FirstHurewicz.pathChain Path.id) =
+      FirstHurewicz.pathChain (uPath m k) := by
+  rw [FirstHurewicz.inducedChain_pathChain]
+  rfl
+
+private theorem MappingTorusHomology.Covering.vCircleMap_pathChain (m k : ℕ) :
+    FirstHurewicz.inducedChain (vCircleMap m k) 1 (FirstHurewicz.pathChain Path.id) =
+      FirstHurewicz.pathChain (vPath m k) := by
+  rw [FirstHurewicz.inducedChain_pathChain]
+  rfl
+
+private theorem
+    MappingTorusHomology.Covering.productCover_uCircleMap {X : Type} [TopologicalSpace X]
+    [CompactSpace X] [T2Space X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) (k : ℕ) :
+    (productCover m B hB).comp ((uCircleMap m k).prodMap (ContinuousMap.id X)) =
+      (MappingTorus.HomologyCover.inclusionU B.symm).comp (uStrip B.symm k) := by
+  apply ContinuousMap.ext
+  intro p
+  change
+    productCover m B hB (uPath m k p.1, p.2) = (uStrip B.symm k p : MappingTorus.Torus B.symm)
+  rw [uPath_apply, productCover_real_apply, uStrip_val]
+  have hm : (m : ℝ) ≠ 0 := Nat.cast_ne_zero.mpr (NeZero.ne m)
+  rw [div_mul_cancel₀ _ hm]
+  have ht : (k : ℝ) + 1 / 4 + (p.1 : ℝ) / 2 = (1 / 4 : ℝ) + (p.1 : ℝ) / 2 + ((k : ℤ) : ℝ) := by
+    push_cast
+    ring
+  rw [ht, mk_add_int]
+  simp only [zpow_natCast]
+
+private theorem
+    MappingTorusHomology.Covering.productCover_vCircleMap {X : Type} [TopologicalSpace X]
+    [CompactSpace X] [T2Space X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) (k : ℕ) :
+    (productCover m B hB).comp ((vCircleMap m k).prodMap (ContinuousMap.id X)) =
+      (MappingTorus.HomologyCover.inclusionV B.symm).comp (vStrip B.symm k) := by
+  apply ContinuousMap.ext
+  intro p
+  change
+    productCover m B hB (vPath m k p.1, p.2) = (vStrip B.symm k p : MappingTorus.Torus B.symm)
+  rw [vPath_apply, productCover_real_apply, vStrip_val]
+  have hm : (m : ℝ) ≠ 0 := Nat.cast_ne_zero.mpr (NeZero.ne m)
+  rw [div_mul_cancel₀ _ hm]
+  have ht :
+    (k : ℝ) + 3 / 4 + (p.1 : ℝ) / 2 = -(1 / 4 : ℝ) + (p.1 : ℝ) / 2 + (((k + 1 : ℕ) : ℤ) : ℝ) := by
+    push_cast
+    ring
+  rw [ht, mk_add_int]
+  simp only [zpow_natCast]
+
+private theorem MappingTorusHomology.Covering.uStrip_inclusion_crossProduct {X : Type}
+    [TopologicalSpace X] [CompactSpace X] [T2Space X] (m : ℕ) [NeZero m] (B : X ≃ₜ X)
+    (hB : B ^ m = 1) (k n : ℕ) (b : FirstHurewicz.Chains X n) :
+    FirstHurewicz.inducedChain (MappingTorus.HomologyCover.inclusionU B.symm) (n + 1)
+        (FirstHurewicz.inducedChain (uStrip B.symm k) (n + 1)
+          (PeriodTorusHigherHomology.crossProductEdge unitInterval X n
+            (FirstHurewicz.pathChain Path.id) b)) =
+      FirstHurewicz.inducedChain (productCover m B hB) (n + 1)
+        (PeriodTorusHigherHomology.crossProductEdge (MappingTorus.Circle) X n
+          (FirstHurewicz.pathChain (uPath m k)) b) := by
+  have h :=
+    congrArg
+      (fun F =>
+        FirstHurewicz.inducedChain F (n + 1)
+          (PeriodTorusHigherHomology.crossProductEdge unitInterval X n
+            (FirstHurewicz.pathChain Path.id) b))
+      (productCover_uCircleMap m B hB k)
+  simp only [FirstHurewicz.inducedChain_comp, LinearMap.comp_apply,
+    PeriodTorusHigherHomology.crossProductEdge_natural, FirstHurewicz.inducedChain_id,
+    LinearMap.id_apply, uCircleMap_pathChain] at h
+  exact h.symm
+
+private theorem MappingTorusHomology.Covering.vStrip_inclusion_crossProduct {X : Type}
+    [TopologicalSpace X] [CompactSpace X] [T2Space X] (m : ℕ) [NeZero m] (B : X ≃ₜ X)
+    (hB : B ^ m = 1) (k n : ℕ) (b : FirstHurewicz.Chains X n) :
+    FirstHurewicz.inducedChain (MappingTorus.HomologyCover.inclusionV B.symm) (n + 1)
+        (FirstHurewicz.inducedChain (vStrip B.symm k) (n + 1)
+          (PeriodTorusHigherHomology.crossProductEdge unitInterval X n
+            (FirstHurewicz.pathChain Path.id) b)) =
+      FirstHurewicz.inducedChain (productCover m B hB) (n + 1)
+        (PeriodTorusHigherHomology.crossProductEdge (MappingTorus.Circle) X n
+          (FirstHurewicz.pathChain (vPath m k)) b) := by
+  have h :=
+    congrArg
+      (fun F =>
+        FirstHurewicz.inducedChain F (n + 1)
+          (PeriodTorusHigherHomology.crossProductEdge unitInterval X n
+            (FirstHurewicz.pathChain Path.id) b))
+      (productCover_vCircleMap m B hB k)
+  simp only [FirstHurewicz.inducedChain_comp, LinearMap.comp_apply,
+    PeriodTorusHigherHomology.crossProductEdge_natural, FirstHurewicz.inducedChain_id,
+    LinearMap.id_apply, vCircleMap_pathChain] at h
+  exact h.symm
+
+private theorem MappingTorusHomology.Covering.positiveCircleCross_subdivision_cycleClass {X : Type}
+    [TopologicalSpace X] (m : ℕ) [NeZero m] (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    PeriodTorusHigherHomology.positiveCircleCross X n
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n b) =
+      SingularMayerVietoris.ModuleHomology.cycleClass
+        (FirstHurewicz.singularComplex ((MappingTorus.Circle) × X)) (n + 1)
+        (PeriodTorusHigherHomology.crossProductCycles (MappingTorus.Circle) X n (arcSumCycle m)
+          b) := by
+  have h :
+    SingularMayerVietoris.ModuleHomology.cycleClass
+        (FirstHurewicz.singularComplex (MappingTorus.Circle)) 1 (arcSumCycle m) =
+      FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop :=
+    arcSumCycle_positiveLoop_class m
+  change
+    PeriodTorusHigherHomology.crossProductHomology (MappingTorus.Circle) X n
+        (FirstHurewicz.loopHomologyClass PeriodTorusHigherHomology.CirclePaths.positiveLoop)
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n b) =
+      _
+  rw [← h]
+  exact
+    PeriodTorusHigherHomology.crossProductHomology_cycleClass (MappingTorus.Circle) X n
+      (arcSumCycle m) b
+
+private def MappingTorusHomology.Covering.monodromyHomologyMonoidHom {X : Type} [TopologicalSpace X]
+    (n : ℕ) : (X ≃ₜ X) →* Module.End ℤ (SingularMayerVietoris.SingularHomology X n)
+    where
+  toFun B := MappingTorusHomology.monodromyHomologyMap B n
+  map_one' := PeriodTorusHigherHomology.singularHomologyMap_id X n
+  map_mul' B D := PeriodTorusHigherHomology.singularHomologyMap_comp (D : C(X, X)) (B : C(X, X)) n
+
+@[simp]
+private theorem
+    MappingTorusHomology.Covering.monodromyHomologyMap_pow {X : Type} [TopologicalSpace X]
+    (B : X ≃ₜ X) (n k : ℕ) :
+    MappingTorusHomology.monodromyHomologyMap (B ^ k) n =
+      (MappingTorusHomology.monodromyHomologyMap B n) ^ k :=
+  map_pow (monodromyHomologyMonoidHom (X := X) n) B k
+
+private def MappingTorusHomology.Covering.homologyNorm {X : Type} [TopologicalSpace X] (m : ℕ)
+    (B : X ≃ₜ X) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology X n →ₗ[ℤ] SingularMayerVietoris.SingularHomology X n :=
+  ∑ k ∈ Finset.range m, SingularMayerVietoris.singularHomologyMap ((B ^ k : X ≃ₜ X) : C(X, X)) n
+
+@[simp]
+private theorem
+    MappingTorusHomology.Covering.homologyNorm_apply {X : Type} [TopologicalSpace X] (m : ℕ)
+    (B : X ≃ₜ X) (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    homologyNorm m B n a =
+      ∑ k ∈ Finset.range m,
+        SingularMayerVietoris.singularHomologyMap ((B ^ k : X ≃ₜ X) : C(X, X)) n a := by
+  simp only [homologyNorm, LinearMap.sum_apply]
+
+private theorem
+    MappingTorusHomology.Covering.homologyNorm_eq_sum_powers {X : Type} [TopologicalSpace X]
+    (m : ℕ) (B : X ≃ₜ X) (n : ℕ) :
+    homologyNorm m B n =
+      ∑ k ∈ Finset.range m, (MappingTorusHomology.monodromyHomologyMap B n) ^ k := by
+  apply Finset.sum_congr rfl
+  intro k _
+  exact monodromyHomologyMap_pow B n k
+
+private theorem MappingTorusHomology.Covering.sum_range_shift_of_endpoints_mo1973_27356
+    {A : Type*} [AddCommGroup A] (F : ℕ → A) (m : ℕ) (hF : F m = F 0) :
+    ∑ k ∈ Finset.range m, F (k + 1) = ∑ k ∈ Finset.range m, F k := by
+  apply add_right_cancel (b := F 0)
+  calc
+    (∑ k ∈ Finset.range m, F (k + 1)) + F 0 = ∑ k ∈ Finset.range (m + 1), F k :=
+      (Finset.sum_range_succ' F m).symm
+    _ = (∑ k ∈ Finset.range m, F k) + F 0 := by rw [Finset.sum_range_succ, hF]
+
+private theorem MappingTorusHomology.Covering.homeomorph_symm_pow_eq {X : Type} [TopologicalSpace X]
+    (m : ℕ) (B : X ≃ₜ X) (hB : B ^ m = 1) (k : ℕ) (hk : k ≤ m) : B.symm ^ k = B ^ (m - k) := by
+  change B⁻¹ ^ k = B ^ (m - k)
+  rw [pow_sub B hk, hB, one_mul, inv_pow]
+
+private theorem
+    MappingTorusHomology.Covering.homologyNorm_symm {X : Type} [TopologicalSpace X] (m : ℕ)
+    (B : X ≃ₜ X) (n : ℕ) (hB : B ^ m = 1) : homologyNorm m B.symm n = homologyNorm m B n := by
+  unfold homologyNorm
+  calc
+    (∑ k ∈ Finset.range m,
+          SingularMayerVietoris.singularHomologyMap ((B.symm ^ k : X ≃ₜ X) : C(X, X)) n) =
+        ∑ k ∈ Finset.range m,
+          SingularMayerVietoris.singularHomologyMap ((B ^ (m - 1 - k + 1) : X ≃ₜ X) : C(X, X))
+            n := by
+      apply Finset.sum_congr rfl
+      intro k hk
+      have hkm : k < m := Finset.mem_range.mp hk
+      have hexp : m - k = m - 1 - k + 1 := by omega
+      rw [homeomorph_symm_pow_eq m B hB k hkm.le, hexp]
+    _ =
+        ∑ k ∈ Finset.range m,
+          SingularMayerVietoris.singularHomologyMap ((B ^ (k + 1) : X ≃ₜ X) : C(X, X)) n :=
+      (Finset.sum_range_reflect
+        (fun k => SingularMayerVietoris.singularHomologyMap ((B ^ (k + 1) : X ≃ₜ X) : C(X, X)) n)
+        m)
+    _ =
+        ∑ k ∈ Finset.range m,
+          SingularMayerVietoris.singularHomologyMap ((B ^ k : X ≃ₜ X) : C(X, X)) n := by
+      apply
+        sum_range_shift_of_endpoints_mo1973_27356
+          (fun k => SingularMayerVietoris.singularHomologyMap ((B ^ k : X ≃ₜ X) : C(X, X)) n) m
+      rw [hB, pow_zero]
+
+private def MappingTorusHomology.Covering.uCrossChain {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (k n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    FirstHurewicz.Chains (MappingTorus.HomologyCover.U f) (n + 1) :=
+  FirstHurewicz.inducedChain (uStrip f k) (n + 1)
+    (PeriodTorusHigherHomology.crossProductEdge unitInterval X n (FirstHurewicz.pathChain Path.id)
+      b.1)
+
+private def MappingTorusHomology.Covering.vCrossChain {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (k n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    FirstHurewicz.Chains (MappingTorus.HomologyCover.V f) (n + 1) :=
+  FirstHurewicz.inducedChain (vStrip f k) (n + 1)
+    (PeriodTorusHigherHomology.crossProductEdge unitInterval X n (FirstHurewicz.pathChain Path.id)
+      b.1)
+
+private theorem MappingTorusHomology.Covering.uCrossChain_boundary {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (k n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    ((FirstHurewicz.singularComplex (MappingTorus.HomologyCover.U f)).d (n + 1) n).hom
+        (uCrossChain f k n b) =
+      FirstHurewicz.inducedChain (MappingTorus.HomologyCover.intersectionToU f) n
+        (FirstHurewicz.inducedChain (upperSection f k) n b.1 -
+          FirstHurewicz.inducedChain (lowerSection f k) n b.1) := by
+  rw [uCrossChain, ← FirstHurewicz.inducedChain_boundary,
+    PeriodTorusHigherHomology.crossProductEdge_path_boundary, map_sub, map_sub]
+  congr 1
+  · have h := congrArg (fun g => FirstHurewicz.inducedChain g n b.1) (uStrip_one f k)
+    simpa only [FirstHurewicz.inducedChain_comp, LinearMap.comp_apply] using h
+  · have h := congrArg (fun g => FirstHurewicz.inducedChain g n b.1) (uStrip_zero f k)
+    simpa only [FirstHurewicz.inducedChain_comp, LinearMap.comp_apply] using h
+
+private theorem MappingTorusHomology.Covering.vCrossChain_boundary {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (k n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    ((FirstHurewicz.singularComplex (MappingTorus.HomologyCover.V f)).d (n + 1) n).hom
+        (vCrossChain f k n b) =
+      FirstHurewicz.inducedChain (MappingTorus.HomologyCover.intersectionToV f) n
+        (FirstHurewicz.inducedChain (lowerSection f (k + 1)) n b.1 -
+          FirstHurewicz.inducedChain (upperSection f k) n b.1) := by
+  rw [vCrossChain, ← FirstHurewicz.inducedChain_boundary,
+    PeriodTorusHigherHomology.crossProductEdge_path_boundary, map_sub, map_sub]
+  congr 1
+  · have h := congrArg (fun g => FirstHurewicz.inducedChain g n b.1) (vStrip_one f k)
+    simpa only [FirstHurewicz.inducedChain_comp, LinearMap.comp_apply] using h
+  · have h := congrArg (fun g => FirstHurewicz.inducedChain g n b.1) (vStrip_zero f k)
+    simpa only [FirstHurewicz.inducedChain_comp, LinearMap.comp_apply] using h
+
+private def
+    MappingTorusHomology.Covering.uCrossChainSum {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (m n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    FirstHurewicz.Chains (MappingTorus.HomologyCover.U f) (n + 1) :=
+  ∑ k ∈ Finset.range m, uCrossChain f k n b
+
+private def
+    MappingTorusHomology.Covering.vCrossChainSum {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (m n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    FirstHurewicz.Chains (MappingTorus.HomologyCover.V f) (n + 1) :=
+  ∑ k ∈ Finset.range m, vCrossChain f k n b
+
+private def
+    MappingTorusHomology.Covering.differenceCycle {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (m n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    SingularMayerVietoris.ModuleHomology.Cycle
+      (FirstHurewicz.singularComplex
+        (MappingTorus.HomologyCover.U f ∩ MappingTorus.HomologyCover.V f :
+          Set (MappingTorus.Torus f)))
+      n :=
+  ∑ k ∈ Finset.range m,
+    (SingularMayerVietoris.ModuleHomology.mapCycles
+        (FirstHurewicz.singularChainMap (upperSection f k)) n b -
+      SingularMayerVietoris.ModuleHomology.mapCycles
+        (FirstHurewicz.singularChainMap (lowerSection f k)) n b)
+
+@[simp]
+private theorem MappingTorusHomology.Covering.differenceCycle_val {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (m n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    (differenceCycle f m n b).1 =
+      ∑ k ∈ Finset.range m,
+        (FirstHurewicz.inducedChain (upperSection f k) n b.1 -
+          FirstHurewicz.inducedChain (lowerSection f k) n b.1) := by
+  simp only [differenceCycle, Submodule.coe_sum, Submodule.coe_sub,
+    SingularMayerVietoris.ModuleHomology.mapCycles_val]
+
+private theorem
+    MappingTorusHomology.Covering.lowerSection_chain_sum_shift {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (m : ℕ) (hf : f ^ m = 1) (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    (∑ k ∈ Finset.range m, FirstHurewicz.inducedChain (lowerSection f (k + 1)) n b.1) =
+      ∑ k ∈ Finset.range m, FirstHurewicz.inducedChain (lowerSection f k) n b.1 := by
+  apply add_right_cancel (b := FirstHurewicz.inducedChain (lowerSection f 0) n b.1)
+  calc
+    _ = ∑ k ∈ Finset.range (m + 1), FirstHurewicz.inducedChain (lowerSection f k) n b.1 :=
+      (Finset.sum_range_succ' (fun k => FirstHurewicz.inducedChain (lowerSection f k) n b.1)
+          m).symm
+    _ = _ := by rw [Finset.sum_range_succ, lowerSection_period f m hf]
+
+private theorem
+    MappingTorusHomology.Covering.uCrossChainSum_boundary {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (m n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    ((FirstHurewicz.singularComplex (MappingTorus.HomologyCover.U f)).d (n + 1) n).hom
+        (uCrossChainSum f m n b) =
+      FirstHurewicz.inducedChain (MappingTorus.HomologyCover.intersectionToU f) n
+        (differenceCycle f m n b).1 := by
+  simp only [uCrossChainSum, differenceCycle_val, map_sum, uCrossChain_boundary]
+
+private theorem
+    MappingTorusHomology.Covering.vCrossChainSum_boundary {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (m : ℕ) (hf : f ^ m = 1) (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    ((FirstHurewicz.singularComplex (MappingTorus.HomologyCover.V f)).d (n + 1) n).hom
+        (vCrossChainSum f m n b) =
+      -FirstHurewicz.inducedChain (MappingTorus.HomologyCover.intersectionToV f) n
+          (differenceCycle f m n b).1 := by
+  calc
+    _ =
+        FirstHurewicz.inducedChain (MappingTorus.HomologyCover.intersectionToV f) n
+          (∑ k ∈ Finset.range m,
+            (FirstHurewicz.inducedChain (lowerSection f (k + 1)) n b.1 -
+              FirstHurewicz.inducedChain (upperSection f k) n b.1)) := by
+      simp only [vCrossChainSum, map_sum, vCrossChain_boundary]
+    _ = _ := by
+      rw [differenceCycle_val]
+      simp only [Finset.sum_sub_distrib]
+      rw [lowerSection_chain_sum_shift f m hf]
+      simp only [map_sub]
+      abel
+
+private theorem MappingTorusHomology.Covering.differenceCycle_class {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (m n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    SingularMayerVietoris.ModuleHomology.cycleClass
+        (FirstHurewicz.singularComplex
+          (MappingTorus.HomologyCover.U f ∩ MappingTorus.HomologyCover.V f :
+            Set (MappingTorus.Torus f)))
+        n (differenceCycle f m n b) =
+      ∑ k ∈ Finset.range m,
+        (SingularMayerVietoris.singularHomologyMap (upperSection f k) n
+            (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n
+              b) -
+          SingularMayerVietoris.singularHomologyMap (lowerSection f k) n
+            (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n
+              b)) := by
+  simp only [differenceCycle, map_sum, map_sub,
+    ← SingularMayerVietoris.ModuleHomology.homologyMap_cycleClass]
+
+private theorem MappingTorusHomology.Covering.differenceCycle_class_coordinates {X : Type}
+    [TopologicalSpace X] (f : X ≃ₜ X) (m n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    MappingTorusHomology.intersectionHomologyEquiv f n
+        (SingularMayerVietoris.ModuleHomology.cycleClass
+          (FirstHurewicz.singularComplex
+            (MappingTorus.HomologyCover.U f ∩ MappingTorus.HomologyCover.V f :
+              Set (MappingTorus.Torus f)))
+          n (differenceCycle f m n b)) =
+      (-homologyNorm m f n
+            (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n
+              b),
+        homologyNorm m f n
+          (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n
+            b)) := by
+  rw [differenceCycle_class, map_sum]
+  simp only [map_sub, upperSection_homology_coordinates, lowerSection_homology_coordinates,
+    Prod.mk_sub_mk, zero_sub, sub_zero, ← prod_mk_sum, Finset.sum_neg_distrib, homologyNorm_apply]
+
+private def
+    MappingTorusHomology.Covering.coverSmallCycle {X : Type} [TopologicalSpace X] (f : X ≃ₜ X)
+    (m : ℕ) (hf : f ^ m = 1) (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    SingularMayerVietoris.ModuleHomology.Cycle
+      (SingularMayerVietoris.smallComplex (MappingTorus.HomologyCover.U f)
+        (MappingTorus.HomologyCover.V f))
+      (n + 1) :=
+  PeriodTorusHigherHomology.twoChainSmallCycle (MappingTorus.HomologyCover.U f)
+    (MappingTorus.HomologyCover.V f) n (uCrossChainSum f m n b) (vCrossChainSum f m n b)
+    (differenceCycle f m n b) (uCrossChainSum_boundary f m n b)
+    (vCrossChainSum_boundary f m hf n b)
+
+private theorem
+    MappingTorusHomology.Covering.coverSmallCycle_ambient_val {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (m : ℕ) (hf : f ^ m = 1) (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    (SingularMayerVietoris.ModuleHomology.mapCycles
+          (SingularMayerVietoris.smallInclusion (MappingTorus.HomologyCover.U f)
+            (MappingTorus.HomologyCover.V f))
+          (n + 1) (coverSmallCycle f m hf n b)).1 =
+      FirstHurewicz.inducedChain (MappingTorus.HomologyCover.inclusionU f) (n + 1)
+          (uCrossChainSum f m n b) +
+        FirstHurewicz.inducedChain (MappingTorus.HomologyCover.inclusionV f) (n + 1)
+          (vCrossChainSum f m n b) :=
+  PeriodTorusHigherHomology.twoChainSmallCycle_ambient_val (MappingTorus.HomologyCover.U f)
+    (MappingTorus.HomologyCover.V f) n (uCrossChainSum f m n b) (vCrossChainSum f m n b)
+    (differenceCycle f m n b) (uCrossChainSum_boundary f m n b)
+    (vCrossChainSum_boundary f m hf n b)
+
+private theorem MappingTorusHomology.Covering.coverSmallCycle_ambient_sum_val {X : Type}
+    [TopologicalSpace X] (f : X ≃ₜ X) (m : ℕ) (hf : f ^ m = 1) (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    (SingularMayerVietoris.ModuleHomology.mapCycles
+          (SingularMayerVietoris.smallInclusion (MappingTorus.HomologyCover.U f)
+            (MappingTorus.HomologyCover.V f))
+          (n + 1) (coverSmallCycle f m hf n b)).1 =
+      ∑ k ∈ Finset.range m,
+        (FirstHurewicz.inducedChain (MappingTorus.HomologyCover.inclusionU f) (n + 1)
+            (uCrossChain f k n b) +
+          FirstHurewicz.inducedChain (MappingTorus.HomologyCover.inclusionV f) (n + 1)
+            (vCrossChain f k n b)) := by
+  simp only [coverSmallCycle_ambient_val, uCrossChainSum, vCrossChainSum, map_sum,
+    Finset.sum_add_distrib]
+
+private theorem
+    MappingTorusHomology.Covering.coverSmallCycle_connecting {X : Type} [TopologicalSpace X]
+    (f : X ≃ₜ X) (m : ℕ) (hf : f ^ m = 1) (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    MappingTorusHomology.mayerVietorisConnecting f n
+        (SingularMayerVietoris.ModuleHomology.cycleClass
+          (FirstHurewicz.singularComplex (MappingTorus.Torus f)) (n + 1)
+          (SingularMayerVietoris.ModuleHomology.mapCycles
+            (SingularMayerVietoris.smallInclusion (MappingTorus.HomologyCover.U f)
+              (MappingTorus.HomologyCover.V f))
+            (n + 1) (coverSmallCycle f m hf n b))) =
+      SingularMayerVietoris.ModuleHomology.cycleClass
+        (FirstHurewicz.singularComplex
+          (MappingTorus.HomologyCover.U f ∩ MappingTorus.HomologyCover.V f :
+            Set (MappingTorus.Torus f)))
+        n (differenceCycle f m n b) :=
+  PeriodTorusHigherHomology.connectingHomomorphism_twoChain (MappingTorus.HomologyCover.U f)
+    (MappingTorus.HomologyCover.V f) (MappingTorus.HomologyCover.U_open f)
+    (MappingTorus.HomologyCover.V_open f) (MappingTorus.HomologyCover.cover f) n
+    (uCrossChainSum f m n b) (vCrossChainSum f m n b) (differenceCycle f m n b)
+    (uCrossChainSum_boundary f m n b) (vCrossChainSum_boundary f m hf n b)
+
+private theorem MappingTorusHomology.Covering.coverSmallCycle_boundaryCoordinates {X : Type}
+    [TopologicalSpace X] (f : X ≃ₜ X) (m : ℕ) (hf : f ^ m = 1) (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    MappingTorusHomology.boundaryCoordinates f n
+        (SingularMayerVietoris.ModuleHomology.cycleClass
+          (FirstHurewicz.singularComplex (MappingTorus.Torus f)) (n + 1)
+          (SingularMayerVietoris.ModuleHomology.mapCycles
+            (SingularMayerVietoris.smallInclusion (MappingTorus.HomologyCover.U f)
+              (MappingTorus.HomologyCover.V f))
+            (n + 1) (coverSmallCycle f m hf n b))) =
+      (-homologyNorm m f n
+            (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n
+              b),
+        homologyNorm m f n
+          (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n
+            b)) := by
+  rw [MappingTorusHomology.boundaryCoordinates_apply, coverSmallCycle_connecting]
+  exact differenceCycle_class_coordinates f m n b
+
+private theorem MappingTorusHomology.Covering.sub_cross_boundary_mem_range_circleSection {X : Type}
+    [TopologicalSpace X] (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) × X) (n + 1)) :
+    a -
+        PeriodTorusHigherHomology.positiveCircleCross X n
+          (PeriodTorusHigherHomology.circleBoundary X n a) ∈
+      LinearMap.range (PeriodTorusHigherHomology.circleSectionHomology X (n + 1)) := by
+  rw [PeriodTorusHigherHomology.circleBoundary_exact]
+  change
+    PeriodTorusHigherHomology.circleBoundary X n
+        (a -
+          PeriodTorusHigherHomology.positiveCircleCross X n
+            (PeriodTorusHigherHomology.circleBoundary X n a)) =
+      0
+  rw [map_sub, PeriodTorusHigherHomology.circleBoundary_positiveCircleCross, sub_self]
+
+private theorem
+    MappingTorusHomology.Covering.eq_comp_circleBoundary_of_section_cross_apply {X : Type}
+    [TopologicalSpace X] {A : Type*} [AddCommGroup A] [Module ℤ A] (n : ℕ)
+    (L :
+      SingularMayerVietoris.SingularHomology
+          ((PeriodTorusHigherHomology.CircleTopology.Circle) × X) (n + 1) →ₗ[ℤ]
+        A)
+    (N : SingularMayerVietoris.SingularHomology X n →ₗ[ℤ] A)
+    (hsec : ∀ b, L (PeriodTorusHigherHomology.circleSectionHomology X (n + 1) b) = 0)
+    (hcross : ∀ b, L (PeriodTorusHigherHomology.positiveCircleCross X n b) = N b)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) × X) (n + 1)) :
+    L a = N (PeriodTorusHigherHomology.circleBoundary X n a) := by
+  obtain ⟨b, hb⟩ := sub_cross_boundary_mem_range_circleSection n a
+  have h := hsec b
+  rw [hb, map_sub, hcross] at h
+  exact sub_eq_zero.mp h
+
+private theorem MappingTorusHomology.Covering.eq_comp_circleBoundary_of_section_cross {X : Type}
+    [TopologicalSpace X] {A : Type*} [AddCommGroup A] [Module ℤ A] (n : ℕ)
+    (L :
+      SingularMayerVietoris.SingularHomology
+          ((PeriodTorusHigherHomology.CircleTopology.Circle) × X) (n + 1) →ₗ[ℤ]
+        A)
+    (N : SingularMayerVietoris.SingularHomology X n →ₗ[ℤ] A)
+    (hsec : ∀ b, L (PeriodTorusHigherHomology.circleSectionHomology X (n + 1) b) = 0)
+    (hcross : ∀ b, L (PeriodTorusHigherHomology.positiveCircleCross X n b) = N b) :
+    L = N.comp (PeriodTorusHigherHomology.circleBoundary X n) := by
+  ext a
+  exact eq_comp_circleBoundary_of_section_cross_apply n L N hsec hcross a
+
+private theorem MappingTorusHomology.Covering.wangBoundary_productCover_eq_of_cross {X : Type}
+    [TopologicalSpace X] [CompactSpace X] [T2Space X] (m : ℕ) [NeZero m] (B : X ≃ₜ X)
+    (hB : B ^ m = 1) (n : ℕ)
+    (N :
+      SingularMayerVietoris.SingularHomology X n →ₗ[ℤ] SingularMayerVietoris.SingularHomology X n)
+    (hcross :
+      ∀ b,
+        MappingTorusHomology.wangBoundary B.symm n
+            (productCoverHomology m B hB (n + 1)
+              (PeriodTorusHigherHomology.positiveCircleCross X n b)) =
+          N b) :
+    (MappingTorusHomology.wangBoundary B.symm n).comp (productCoverHomology m B hB (n + 1)) =
+      N.comp (PeriodTorusHigherHomology.circleBoundary X n) := by
+  apply eq_comp_circleBoundary_of_section_cross n
+  · intro b
+    exact wangBoundary_productCover_circleSection_apply m B hB n b
+  · exact hcross
+
+public
+theorem MappingTorusHomology.Covering.inverseMonodromy_period_mo1973_27385 {X : Type}
+    [TopologicalSpace X] (m : ℕ) (B : X ≃ₜ X) (h : B ^ m = 1) : B.symm ^ m = 1 := by
+  rw [homeomorph_symm_pow_eq m B h m le_rfl, Nat.sub_self, pow_zero]
+
+private theorem MappingTorusHomology.Covering.coverSmallCycle_productCover_eq {X : Type}
+    [TopologicalSpace X] [CompactSpace X] [T2Space X] (m : ℕ) [NeZero m] (B : X ≃ₜ X)
+    (hB : B ^ m = 1) (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    SingularMayerVietoris.ModuleHomology.mapCycles
+        (SingularMayerVietoris.smallInclusion (MappingTorus.HomologyCover.U B.symm)
+          (MappingTorus.HomologyCover.V B.symm))
+        (n + 1) (coverSmallCycle B.symm m (inverseMonodromy_period_mo1973_27385 m B hB) n b) =
+      SingularMayerVietoris.ModuleHomology.mapCycles
+        (FirstHurewicz.singularChainMap (productCover m B hB)) (n + 1)
+        (PeriodTorusHigherHomology.crossProductCycles (MappingTorus.Circle) X n (arcSumCycle m)
+          b) := by
+  apply Subtype.ext
+  rw [coverSmallCycle_ambient_sum_val, SingularMayerVietoris.ModuleHomology.mapCycles_val]
+  change
+    (∑ k ∈ Finset.range m,
+        (FirstHurewicz.inducedChain (MappingTorus.HomologyCover.inclusionU B.symm) (n + 1)
+            (uCrossChain B.symm k n b) +
+          FirstHurewicz.inducedChain (MappingTorus.HomologyCover.inclusionV B.symm) (n + 1)
+            (vCrossChain B.symm k n b))) =
+      FirstHurewicz.inducedChain (productCover m B hB) (n + 1)
+        (PeriodTorusHigherHomology.crossProductEdge (MappingTorus.Circle) X n (arcSumChain m) b.1)
+  simp only [arcSumChain, map_sum, LinearMap.sum_apply, map_add, LinearMap.add_apply]
+  apply Finset.sum_congr rfl
+  intro k _
+  exact
+    congrArg₂ (· + ·) (uStrip_inclusion_crossProduct m B hB k n b.1)
+      (vStrip_inclusion_crossProduct m B hB k n b.1)
+
+private theorem MappingTorusHomology.Covering.coverSmallCycle_productCover_class {X : Type}
+    [TopologicalSpace X] [CompactSpace X] [T2Space X] (m : ℕ) [NeZero m] (B : X ≃ₜ X)
+    (hB : B ^ m = 1) (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    SingularMayerVietoris.ModuleHomology.cycleClass
+        (FirstHurewicz.singularComplex (MappingTorus.Torus B.symm)) (n + 1)
+        (SingularMayerVietoris.ModuleHomology.mapCycles
+          (SingularMayerVietoris.smallInclusion (MappingTorus.HomologyCover.U B.symm)
+            (MappingTorus.HomologyCover.V B.symm))
+          (n + 1) (coverSmallCycle B.symm m (inverseMonodromy_period_mo1973_27385 m B hB) n b)) =
+      productCoverHomology m B hB (n + 1)
+        (PeriodTorusHigherHomology.positiveCircleCross X n
+          (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n
+            b)) := by
+  rw [coverSmallCycle_productCover_eq, positiveCircleCross_subdivision_cycleClass m n b]
+  exact
+    (SingularMayerVietoris.ModuleHomology.homologyMap_cycleClass
+        (FirstHurewicz.singularChainMap (productCover m B hB)) (n + 1)
+        (PeriodTorusHigherHomology.crossProductCycles (MappingTorus.Circle) X n (arcSumCycle m)
+          b)).symm
+
+private theorem
+    MappingTorusHomology.Covering.boundaryCoordinates_productCover_cross_cycleClass {X : Type}
+    [TopologicalSpace X] [CompactSpace X] [T2Space X] (m : ℕ) [NeZero m] (B : X ≃ₜ X)
+    (hB : B ^ m = 1) (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    MappingTorusHomology.boundaryCoordinates B.symm n
+        (productCoverHomology m B hB (n + 1)
+          (PeriodTorusHigherHomology.positiveCircleCross X n
+            (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n
+              b))) =
+      (-homologyNorm m B.symm n
+            (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n
+              b),
+        homologyNorm m B.symm n
+          (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n
+            b)) := by
+  rw [← coverSmallCycle_productCover_class]
+  exact
+    coverSmallCycle_boundaryCoordinates B.symm m (inverseMonodromy_period_mo1973_27385 m B hB) n b
+
+private theorem MappingTorusHomology.Covering.wangBoundary_productCover_cross_cycleClass {X : Type}
+    [TopologicalSpace X] [CompactSpace X] [T2Space X] (m : ℕ) [NeZero m] (B : X ≃ₜ X)
+    (hB : B ^ m = 1) (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    MappingTorusHomology.wangBoundary B.symm n
+        (productCoverHomology m B hB (n + 1)
+          (PeriodTorusHigherHomology.positiveCircleCross X n
+            (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n
+              b))) =
+      homologyNorm m B n
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n b) :=
+  by
+  rw [MappingTorusHomology.wangBoundary_apply, boundaryCoordinates_productCover_cross_cycleClass]
+  simp only [neg_neg]
+  rw [homologyNorm_symm m B n hB]
+
+private theorem
+    MappingTorusHomology.Covering.wangBoundary_productCover_positiveCircleCross {X : Type}
+    [TopologicalSpace X] [CompactSpace X] [T2Space X] (m : ℕ) [NeZero m] (B : X ≃ₜ X)
+    (hB : B ^ m = 1) (n : ℕ) (b : SingularMayerVietoris.SingularHomology X n) :
+    MappingTorusHomology.wangBoundary B.symm n
+        (productCoverHomology m B hB (n + 1)
+          (PeriodTorusHigherHomology.positiveCircleCross X n b)) =
+      homologyNorm m B n b := by
+  obtain ⟨c, rfl⟩ :=
+    SingularMayerVietoris.ModuleHomology.cycleClass_surjective (FirstHurewicz.singularComplex X) n
+      b
+  exact wangBoundary_productCover_cross_cycleClass m B hB n c
+
+private theorem
+    MappingTorusHomology.Covering.wangBoundary_productCover {X : Type} [TopologicalSpace X]
+    [CompactSpace X] [T2Space X] (m : ℕ) [NeZero m] (B : X ≃ₜ X) (hB : B ^ m = 1) (n : ℕ) :
+    (MappingTorusHomology.wangBoundary B.symm n).comp (productCoverHomology m B hB (n + 1)) =
+      (homologyNorm m B n).comp (PeriodTorusHigherHomology.circleBoundary X n) :=
+  wangBoundary_productCover_eq_of_cross m B hB n (homologyNorm m B n)
+    (wangBoundary_productCover_positiveCircleCross m B hB n)
+
+private theorem MappingTorusHomology.Covering.wangBoundary_productCover_apply {X : Type}
+    [TopologicalSpace X] [CompactSpace X] [T2Space X] (m : ℕ) [NeZero m] (B : X ≃ₜ X)
+    (hB : B ^ m = 1) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology ((MappingTorus.Circle) × X) (n + 1)) :
+    MappingTorusHomology.wangBoundary B.symm n (productCoverHomology m B hB (n + 1) a) =
+      homologyNorm m B n (PeriodTorusHigherHomology.circleBoundary X n a) :=
+  LinearMap.congr_fun (wangBoundary_productCover m B hB n) a
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Pi1/ThreefoldOverlapMappingTorus1.lean b/LeanPool/HopfProblem/Pi1/ThreefoldOverlapMappingTorus1.lean
new file mode 100644
index 000000000..baaa2be8d
--- /dev/null
+++ b/LeanPool/HopfProblem/Pi1/ThreefoldOverlapMappingTorus1.lean
@@ -0,0 +1,316 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+public import LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+
+/-!
+# Hopf problem: pi 1 · threefold overlap mapping torus 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private abbrev ThreefoldOverlapMappingTorus.Circle :=
+  AddCircle (1 : ℝ)
+
+/-- Radii whose `n`th powers lie below a prescribed bound. -/
+public
+abbrev ThreefoldOverlapMappingTorus.Radius (n : ℕ) (r : ℝ) :=
+  { a : ℝ // 0 < a ∧ a < 1 ∧ a ^ n < r }
+
+private abbrev ThreefoldOverlapMappingTorus.RootDisc (n : ℕ) (r : ℝ) :=
+  { z : SpecialPeriods.Disc // (z : ℂ) ≠ 0 ∧ ‖(z : ℂ)‖ ^ n < r }
+
+private def ThreefoldOverlapMappingTorus.phase (t : ThreefoldOverlapMappingTorus.Circle) :
+    _root_.Circle :=
+  AddCircle.toCircle t
+
+private theorem ThreefoldOverlapMappingTorus.phase_continuous : Continuous phase :=
+  AddCircle.continuous_toCircle
+
+private theorem ThreefoldOverlapMappingTorus.phase_add (s t : ThreefoldOverlapMappingTorus.Circle) :
+    phase (s + t) = phase s * phase t :=
+  AddCircle.toCircle_add s t
+
+private theorem ThreefoldOverlapMappingTorus.phase_real (t : ℝ) :
+    (phase (t : ThreefoldOverlapMappingTorus.Circle) : ℂ) =
+      CuspUniformization.exponential (t : ℂ) := by
+  rw [phase, AddCircle.toCircle_apply_mk, _root_.Circle.coe_exp, CuspUniformization.exponential]
+  congr 1
+  push_cast
+  ring
+
+private def ThreefoldOverlapMappingTorus.root (n : ℕ) (r : ℝ) (a : Radius n r)
+    (t : ThreefoldOverlapMappingTorus.Circle) : SpecialPeriods.Disc :=
+  ⟨(a : ℝ) • (phase t : ℂ),
+    by
+    have hn : ‖(a : ℝ) • (phase t : ℂ)‖ < 1 := by
+      simpa only [norm_smul, Real.norm_eq_abs, abs_of_pos a.property.1, _root_.Circle.norm_coe,
+        mul_one] using a.property.2.1
+    simpa [SpecialPeriods.unitDisc] using hn⟩
+
+@[simp]
+private theorem ThreefoldOverlapMappingTorus.root_norm (n : ℕ) (r : ℝ) (a : Radius n r)
+    (t : ThreefoldOverlapMappingTorus.Circle) : ‖(root n r a t : ℂ)‖ = (a : ℝ) := by
+  simp only [root, norm_smul, Real.norm_eq_abs, abs_of_pos a.property.1, _root_.Circle.norm_coe,
+    mul_one]
+
+private theorem ThreefoldOverlapMappingTorus.root_ne_zero (n : ℕ) (r : ℝ) (a : Radius n r)
+    (t : ThreefoldOverlapMappingTorus.Circle) : (root n r a t : ℂ) ≠ 0 := by
+  apply norm_ne_zero_iff.mp
+  rw [root_norm]
+  exact a.property.1.ne'
+
+private theorem ThreefoldOverlapMappingTorus.root_continuous (n : ℕ) (r : ℝ) :
+    Continuous (fun p : Radius n r × ThreefoldOverlapMappingTorus.Circle => root n r p.1 p.2) :=
+  ((continuous_subtype_val.comp continuous_fst).smul
+        (continuous_subtype_val.comp (phase_continuous.comp continuous_snd))).subtype_mk
+    _
+
+private def ThreefoldOverlapMappingTorus.polarRoot (n : ℕ) (r : ℝ)
+    (p : Radius n r × ThreefoldOverlapMappingTorus.Circle) : RootDisc n r :=
+  ⟨root n r p.1 p.2, root_ne_zero n r p.1 p.2,
+    by
+    rw [root_norm]
+    exact p.1.property.2.2⟩
+
+private theorem ThreefoldOverlapMappingTorus.polarRoot_continuous (n : ℕ) (r : ℝ) :
+    Continuous (polarRoot n r) :=
+  (root_continuous n r).subtype_mk _
+
+private def
+    ThreefoldOverlapMappingTorus.rootRadius (n : ℕ) (r : ℝ) (z : RootDisc n r) : Radius n r :=
+  ⟨‖((z : SpecialPeriods.Disc) : ℂ)‖, norm_pos_iff.mpr z.property.1,
+    SpecialPeriods.disc_norm_lt_one z.val, z.property.2⟩
+
+private theorem ThreefoldOverlapMappingTorus.rootRadius_continuous (n : ℕ) (r : ℝ) :
+    Continuous (rootRadius n r) :=
+  (continuous_subtype_val.comp continuous_subtype_val).norm.subtype_mk _
+
+private def
+    ThreefoldOverlapMappingTorus.unitPhase (n : ℕ) (r : ℝ) (z : RootDisc n r) : _root_.Circle :=
+  ⟨‖((z : SpecialPeriods.Disc) : ℂ)‖⁻¹ • ((z : SpecialPeriods.Disc) : ℂ),
+    by
+    change
+      ‖((z : SpecialPeriods.Disc) : ℂ)‖⁻¹ • ((z : SpecialPeriods.Disc) : ℂ) ∈
+        Metric.sphere (0 : ℂ) 1
+    rw [Metric.mem_sphere, dist_zero_right]
+    rw [norm_smul, Real.norm_eq_abs, abs_of_pos (inv_pos.mpr (norm_pos_iff.mpr z.property.1))]
+    exact inv_mul_cancel₀ (norm_ne_zero_iff.mpr z.property.1)⟩
+
+private theorem ThreefoldOverlapMappingTorus.unitPhase_continuous (n : ℕ) (r : ℝ) :
+    Continuous (unitPhase n r) := by
+  have hz : Continuous (fun z : RootDisc n r => ((z : SpecialPeriods.Disc) : ℂ)) :=
+    continuous_subtype_val.comp continuous_subtype_val
+  exact ((hz.norm.inv₀ fun z => norm_ne_zero_iff.mpr z.property.1).smul hz).subtype_mk _
+
+private def ThreefoldOverlapMappingTorus.rootAngle (n : ℕ) (r : ℝ) (z : RootDisc n r) :
+    ThreefoldOverlapMappingTorus.Circle :=
+  (AddCircle.homeomorphCircle (T := (1 : ℝ)) one_ne_zero).symm (unitPhase n r z)
+
+private theorem ThreefoldOverlapMappingTorus.rootAngle_continuous (n : ℕ) (r : ℝ) :
+    Continuous (rootAngle n r) :=
+  (AddCircle.homeomorphCircle one_ne_zero).symm.continuous.comp (unitPhase_continuous n r)
+
+@[simp]
+private theorem ThreefoldOverlapMappingTorus.phase_rootAngle (n : ℕ) (r : ℝ) (z : RootDisc n r) :
+    phase (rootAngle n r z) = unitPhase n r z := by
+  rw [phase, ← AddCircle.homeomorphCircle_apply one_ne_zero]
+  exact (AddCircle.homeomorphCircle one_ne_zero).apply_symm_apply _
+
+private theorem
+    ThreefoldOverlapMappingTorus.polarRoot_radius_angle (n : ℕ) (r : ℝ) (z : RootDisc n r) :
+    polarRoot n r (rootRadius n r z, rootAngle n r z) = z := by
+  apply Subtype.ext
+  apply Subtype.ext
+  change
+    ‖((z : SpecialPeriods.Disc) : ℂ)‖ • (phase (rootAngle n r z) : ℂ) =
+      ((z : SpecialPeriods.Disc) : ℂ)
+  rw [phase_rootAngle]
+  change
+    ‖((z : SpecialPeriods.Disc) : ℂ)‖ •
+        (‖((z : SpecialPeriods.Disc) : ℂ)‖⁻¹ • ((z : SpecialPeriods.Disc) : ℂ)) =
+      _
+  rw [smul_smul, mul_inv_cancel₀ (norm_ne_zero_iff.mpr z.property.1), one_smul]
+
+@[simp]
+private theorem ThreefoldOverlapMappingTorus.rootRadius_polarRoot (n : ℕ) (r : ℝ)
+    (p : Radius n r × ThreefoldOverlapMappingTorus.Circle) :
+    rootRadius n r (polarRoot n r p) = p.1 :=
+  Subtype.ext (root_norm n r p.1 p.2)
+
+@[simp]
+private theorem ThreefoldOverlapMappingTorus.rootAngle_polarRoot (n : ℕ) (r : ℝ)
+    (p : Radius n r × ThreefoldOverlapMappingTorus.Circle) :
+    rootAngle n r (polarRoot n r p) = p.2 := by
+  apply (AddCircle.injective_toCircle one_ne_zero)
+  change phase (rootAngle n r (polarRoot n r p)) = phase p.2
+  rw [phase_rootAngle]
+  apply Subtype.ext
+  change ‖(root n r p.1 p.2 : ℂ)‖⁻¹ • ((p.1 : ℝ) • (phase p.2 : ℂ)) = _
+  rw [root_norm, smul_smul, inv_mul_cancel₀ p.1.property.1.ne', one_smul]
+
+private def ThreefoldOverlapMappingTorus.polarHomeomorph (n : ℕ) (r : ℝ) :
+    RootDisc n r ≃ₜ Radius n r × ThreefoldOverlapMappingTorus.Circle
+    where
+  toFun z := (rootRadius n r z, rootAngle n r z)
+  invFun := polarRoot n r
+  left_inv := polarRoot_radius_angle n r
+  right_inv p := Prod.ext (rootRadius_polarRoot n r p) (rootAngle_polarRoot n r p)
+  continuous_toFun := (rootRadius_continuous n r).prodMk (rootAngle_continuous n r)
+  continuous_invFun := polarRoot_continuous n r
+
+public
+theorem ThreefoldOverlapMappingTorus.radius_nonempty (n : ℕ) (hn : 0 < n) (r : ℝ) (hr : 0 < r) :
+    Nonempty (Radius n r) := by
+  let a : ℝ := Min.min r 1 / 2
+  have ha0 : 0 < a := half_pos (lt_min hr zero_lt_one)
+  have ha1 : a < 1 := by
+    have h := min_le_right r (1 : ℝ)
+    dsimp only [a]
+    linarith
+  have har : a < r := by
+    have h := min_le_left r (1 : ℝ)
+    dsimp only [a] at ha0 ⊢
+    linarith
+  have hpow : a ^ n ≤ a := by
+    obtain ⟨k, rfl⟩ := Nat.exists_eq_succ_of_ne_zero hn.ne'
+    rw [pow_succ]
+    exact (mul_le_mul_of_nonneg_right (pow_le_one₀ ha0.le ha1.le) ha0.le).trans_eq (one_mul a)
+  exact ⟨⟨a, ha0, ha1, hpow.trans_lt har⟩⟩
+
+private def ThreefoldOverlapMappingTorus.radiusSegment {n : ℕ} {r : ℝ} (a b : Radius n r)
+    (t : unitInterval) : Radius n r :=
+  ⟨(1 - (t : ℝ)) * (a : ℝ) + (t : ℝ) * (b : ℝ),
+    by
+    have ht0 := t.property.1
+    have ht1 := t.property.2
+    have ha := a.property
+    have hb := b.property
+    have hmax : (1 - (t : ℝ)) * (a : ℝ) + (t : ℝ) * (b : ℝ) ≤ Max.max (a : ℝ) (b : ℝ) := by
+      have h₁ := le_max_left (a : ℝ) (b : ℝ)
+      have h₂ := le_max_right (a : ℝ) (b : ℝ)
+      nlinarith
+    have hpos : 0 < (1 - (t : ℝ)) * (a : ℝ) + (t : ℝ) * (b : ℝ) := by
+      by_cases ht : (t : ℝ) = 1
+      · simp only [ht, sub_self, MulZeroClass.zero_mul, one_mul, zero_add]
+        exact hb.1
+      · have ht' : (t : ℝ) < 1 := lt_of_le_of_ne ht1 ht
+        exact add_pos_of_pos_of_nonneg (mul_pos (sub_pos.mpr ht') ha.1) (mul_nonneg ht0 hb.1.le)
+    refine ⟨hpos, hmax.trans_lt (max_lt ha.2.1 hb.2.1), ?_⟩
+    apply (pow_le_pow_left₀ hpos.le hmax n).trans_lt
+    rcases le_total (a : ℝ) (b : ℝ) with hab | hba
+    · rw [max_eq_right hab]
+      exact hb.2.2
+    · rw [max_eq_left hba]
+      exact ha.2.2⟩
+
+@[simp]
+private theorem ThreefoldOverlapMappingTorus.radiusSegment_zero {n : ℕ} {r : ℝ} (a b : Radius n r) :
+    radiusSegment a b 0 = a := by
+  apply Subtype.ext
+  simp [radiusSegment]
+
+@[simp]
+private theorem ThreefoldOverlapMappingTorus.radiusSegment_one {n : ℕ} {r : ℝ} (a b : Radius n r) :
+    radiusSegment a b 1 = b := by
+  apply Subtype.ext
+  simp [radiusSegment]
+
+private theorem
+    ThreefoldOverlapMappingTorus.radiusSegment_continuous {n : ℕ} {r : ℝ} (a : Radius n r) :
+    Continuous (fun p : unitInterval × Radius n r => radiusSegment a p.2 p.1) := by
+  exact
+    (((continuous_const.sub (continuous_subtype_val.comp continuous_fst)).mul
+              continuous_const).add
+          ((continuous_subtype_val.comp continuous_fst).mul
+            (continuous_subtype_val.comp continuous_snd))).subtype_mk
+      _
+
+private def ThreefoldOverlapMappingTorus.radiusProductHomotopyEquiv {n : ℕ} {r : ℝ} (a : Radius n r)
+    (X : Type*) [TopologicalSpace X] : (Radius n r × X) ≃ₕ X
+    where
+  toFun := ContinuousMap.snd
+  invFun := ⟨fun x => (a, x), continuous_const.prodMk continuous_id⟩
+  left_inv :=
+    ⟨{  toFun := fun p => (radiusSegment a p.2.1 p.1, p.2.2)
+        continuous_toFun :=
+          ((radiusSegment_continuous a).comp
+                (continuous_fst.prodMk (continuous_fst.comp continuous_snd))).prodMk
+            (continuous_snd.comp continuous_snd)
+        map_zero_left := fun p => Prod.ext (radiusSegment_zero a p.1) rfl
+        map_one_left := fun p => Prod.ext (radiusSegment_one a p.1) rfl }⟩
+  right_inv := ContinuousMap.Homotopic.refl _
+
+private theorem
+    MappingTorus.mk_unitCylinder_surjective {X : Type*} [TopologicalSpace X] (f : X ≃ₜ X) :
+    MappingTorus.mk f '' ((Set.Icc (0 : ℝ) 1) ×ˢ (Set.univ : Set X)) = Set.univ := by
+  apply Set.eq_univ_of_forall
+  intro q
+  obtain ⟨⟨t, x⟩, rfl⟩ := mk_surjective f q
+  refine ⟨deck f (-⌊t⌋) (t, x), ?_, mk_deck f (-⌊t⌋) (t, x)⟩
+  change (0 ≤ t + ((-⌊t⌋ : ℤ) : ℝ) ∧ t + ((-⌊t⌋ : ℤ) : ℝ) ≤ 1) ∧ True
+  push_cast
+  exact ⟨⟨by linarith [Int.floor_le t], by linarith [Int.lt_floor_add_one t]⟩, trivial⟩
+
+private instance MappingTorus.compactSpace {X : Type*} [TopologicalSpace X] [CompactSpace X]
+    (f : X ≃ₜ X) : CompactSpace (Torus f) where
+  isCompact_univ := by
+    rw [← mk_unitCylinder_surjective f]
+    exact (CompactIccSpace.isCompact_Icc.prod isCompact_univ).image (mk_continuous f)
+
+private def ThreefoldOverlapMappingTorus.Elliptic.homeomorphToPerm_mo1973_15505 :
+    (RealTorus₄ ≃ₜ RealTorus₄) →* Equiv.Perm RealTorus₄
+    where
+  toFun := Homeomorph.toEquiv
+  map_one' := rfl
+  map_mul' _ _ := rfl
+
+private theorem
+    ThreefoldOverlapMappingTorus.Elliptic.affine_pow_order (j : Elliptic.Kind) (v : Lattice)
+    (hv : j.matrix *ᵥ v = v) : Elliptic.flatTorusAffine j v ^ j.order = 1 := by
+  apply Homeomorph.ext
+  intro x
+  exact
+    congrArg (fun e : Equiv.Perm RealTorus₄ => e x)
+      ((homeomorphToPerm_mo1973_15505.map_pow (Elliptic.flatTorusAffine j v) j.order).trans
+        (Elliptic.flatTorusPermutation_pow_order j v hv))
+
+private theorem ThreefoldOverlapMappingTorus.Elliptic.affine_symm_pow_order (j : Elliptic.Kind)
+    (v : Lattice) (hv : j.matrix *ᵥ v = v) : (Elliptic.flatTorusAffine j v).symm ^ j.order = 1 := by
+  change (Elliptic.flatTorusAffine j v)⁻¹ ^ j.order = 1
+  rw [inv_pow, affine_pow_order j v hv, inv_one]
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Pi1/ThreefoldOverlapMappingTorus2.lean b/LeanPool/HopfProblem/Pi1/ThreefoldOverlapMappingTorus2.lean
new file mode 100644
index 000000000..7ca09b445
--- /dev/null
+++ b/LeanPool/HopfProblem/Pi1/ThreefoldOverlapMappingTorus2.lean
@@ -0,0 +1,152 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Uniformization.CuspUniformization4
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen1
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Pi1.ThreefoldOverlapMappingTorus1
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import all LeanPool.HopfProblem.Elliptic.Core3
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.Elliptic.Core4
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods8
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen2
+import all LeanPool.HopfProblem.Elliptic.Core5
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization4
+
+/-!
+# Hopf problem: pi 1 · threefold overlap mapping torus 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryToCentral (j : Elliptic.Kind) :
+    C(SpecialBoundary j, BoundaryCentralSurface j) :=
+  ((SpecialPeriods.EllipticFilling.specialLocalData j).fillingSurfaceRetraction j.twist
+        (Elliptic.mainTwist_admissible j)).comp
+    (specialBoundaryToFullFilling j)
+
+private theorem ThreefoldOverlapMappingTorus.Elliptic.centralInclusion_surfaceRetraction
+    {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j) (v : Lattice)
+    (hv : Elliptic.AdmissibleTwist j v) (y : D.Space v hv) :
+    D.centralFibreInclusion v hv (D.fillingSurfaceRetraction v hv y) = D.fillingRadial v hv 1 y :=
+  congrArg (fun f : C(D.Space v hv, D.Space v hv) => f y)
+    (D.surfaceIntoFilling_comp_retraction v hv)
+
+private theorem ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryToCentral_realCoordinates
+    (j : Elliptic.Kind) (t : ℝ) (x : RealPlane₄) :
+    specialBoundaryToCentral j
+        (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (t, standardLattice.mkQ x)) =
+      Elliptic.surfaceProjection j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+        (Elliptic.mainTwist_admissible j)
+        (Elliptic.flatProjection
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod.val x) := by
+  let y :
+    (SpecialPeriods.EllipticFilling.specialLocalData j).Space j.twist
+      (Elliptic.mainTwist_admissible j) :=
+    specialBoundaryToFullFilling j
+      (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (t, standardLattice.mkQ x))
+  have hy :
+    y =
+      (SpecialPeriods.EllipticFilling.specialLocalData j).quotient j.twist
+        (Elliptic.mainTwist_admissible j)
+        (ThreefoldOverlapMappingTorus.root j.order
+            (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+            (specialRootRadius j) ((t / j.order : ℝ) : ThreefoldOverlapMappingTorus.Circle),
+          standardLattice.mkQ x) :=
+    specialBoundaryInclusion_mk j t (standardLattice.mkQ x)
+  apply
+    (SpecialPeriods.EllipticFilling.specialLocalData j).centralFibreInclusion_injective j.twist
+      (Elliptic.mainTwist_admissible j)
+  change
+    (SpecialPeriods.EllipticFilling.specialLocalData j).centralFibreInclusion j.twist
+        (Elliptic.mainTwist_admissible j)
+        ((SpecialPeriods.EllipticFilling.specialLocalData j).fillingSurfaceRetraction j.twist
+          (Elliptic.mainTwist_admissible j) y) =
+      _
+  rw [centralInclusion_surfaceRetraction, hy, Elliptic.Equivariant.Data.fillingRadial_quotient,
+    Elliptic.discRadial_one, Elliptic.Equivariant.Data.centralFibreInclusion_surfaceProjection,
+    Elliptic.Equivariant.Data.centralInclusion_flatProjection]
+  rfl
+
+private theorem
+    ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryToCentral_mk (j : Elliptic.Kind)
+    (t : ℝ) (x : RealTorus₄) :
+    specialBoundaryToCentral j (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (t, x)) =
+      Elliptic.surfaceProjection j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+        (Elliptic.mainTwist_admissible j)
+        (Elliptic.flatTorusPeriodHomeomorph
+          (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod.val x) := by
+  obtain ⟨u, rfl⟩ := standardLattice.mkQ_surjective x
+  rw [Elliptic.flatTorusPeriodHomeomorph_mkQ]
+  exact specialBoundaryToCentral_realCoordinates j t u
+
+private theorem
+    ThreefoldOverlapMappingTorus.Elliptic.specialBoundaryToCentral_angle (j : Elliptic.Kind)
+    (t s : ℝ) (x : RealTorus₄) :
+    specialBoundaryToCentral j (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (t, x)) =
+      specialBoundaryToCentral j (MappingTorus.mk (Elliptic.flatTorusAffine j j.twist) (s, x)) := by
+  rw [specialBoundaryToCentral_mk, specialBoundaryToCentral_mk]
+
+public
+theorem FundamentalGroupVanKampen.TwoOpenCover.inclusionHomU_surjective_of_overlapHomV_surjective
+    {X : Type*} [TopologicalSpace X] (D : FundamentalGroupVanKampen.TwoOpenCover X)
+    (hV : Function.Surjective D.overlapHomV) : Function.Surjective D.inclusionHomU := by
+  intro γ
+  obtain ⟨q, rfl⟩ := D.pushoutEquiv.surjective γ
+  induction q using Monoid.PushoutI.induction_on with
+  | of i g =>
+    cases i with
+    | false => exact ⟨g, (D.pushoutEquiv_of Bool.false g).symm⟩
+    | true =>
+      obtain ⟨a, rfl⟩ := hV g
+      exact
+        ⟨D.overlapHomU a,
+          (DFunLike.congr_fun D.inclusionHom_compatible a).trans
+            (D.pushoutEquiv_of Bool.true (D.overlapHomV a)).symm⟩
+  | base a =>
+    refine ⟨D.overlapHomU a, ?_⟩
+    exact
+      (D.pushoutEquiv_of Bool.false (D.overlapHomU a)).symm.trans
+        (congrArg D.pushoutEquiv (Monoid.PushoutI.of_apply_eq_base D.overlapHom Bool.false a))
+  | mul x y hx hy =>
+    obtain ⟨a, ha⟩ := hx
+    obtain ⟨b, hb⟩ := hy
+    exact ⟨a * b, by rw [map_mul, ha, hb, map_mul]⟩
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Pi1/TwistGroup.lean b/LeanPool/HopfProblem/Pi1/TwistGroup.lean
new file mode 100644
index 000000000..a8b851a40
--- /dev/null
+++ b/LeanPool/HopfProblem/Pi1/TwistGroup.lean
@@ -0,0 +1,395 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Foundations.Core5
+public import LeanPool.HopfProblem.Uniformization.SpecialPeriods9
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.Lattice.Core2
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods2
+import all LeanPool.HopfProblem.Pi1.MappingTorus
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.PeriodFamily.Core1
+import all LeanPool.HopfProblem.PeriodFamily.Core2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldGluing1
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods8
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen2
+import all LeanPool.HopfProblem.Foundations.Core5
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods9
+
+/-!
+# Hopf problem: pi 1 · twist group
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def LatticeCuspNormalClosure.uHat : Lattice :=
+  ![0, 1, 0, 0]
+
+private def LatticeCuspNormalClosure.wHat : Lattice :=
+  ![0, 0, 1, 0]
+
+private theorem LatticeCuspNormalClosure.first_matrix_wHat : A₁ *ᵥ wHat = uHat - wHat := by decide
+
+private theorem LatticeCuspNormalClosure.image_wHat_eq_one {G : Type*} [Group G]
+    (φ : Multiplicative Lattice →* G)
+    (hc : ∀ v : Lattice, v 0 = 0 → v 1 = 0 → φ (Multiplicative.ofAdd v) = 1) :
+    φ (Multiplicative.ofAdd wHat) = 1 :=
+  hc wHat rfl rfl
+
+private theorem LatticeCuspNormalClosure.image_uHat_eq_one {G : Type*} [Group G]
+    (φ : Multiplicative Lattice →* G) (x : G)
+    (hx :
+      ∀ v : Lattice, x * φ (Multiplicative.ofAdd v) * x⁻¹ = φ (Multiplicative.ofAdd (A₁ *ᵥ v)))
+    (hc : ∀ v : Lattice, v 0 = 0 → v 1 = 0 → φ (Multiplicative.ofAdd v) = 1) :
+    φ (Multiplicative.ofAdd uHat) = 1 := by
+  have h := hx wHat
+  rw [first_matrix_wHat, ofAdd_sub, map_div, image_wHat_eq_one φ hc] at h
+  simpa only [mul_one, mul_inv_cancel, div_one] using h.symm
+
+private theorem LatticeCuspNormalClosure.image_eq_one_of_gamma_eq_zero {G : Type*} [Group G]
+    (φ : Multiplicative Lattice →* G) (x : G)
+    (hx :
+      ∀ v : Lattice, x * φ (Multiplicative.ofAdd v) * x⁻¹ = φ (Multiplicative.ofAdd (A₁ *ᵥ v)))
+    (hc : ∀ v : Lattice, v 0 = 0 → v 1 = 0 → φ (Multiplicative.ofAdd v) = 1) (v : Lattice)
+    (hv : γ v = 0) : φ (Multiplicative.ofAdd v) = 1 := by
+  have hv₀ : v 0 = 0 := hv
+  have hrest := hc (v - v 1 • uHat) (by simp [uHat, hv₀]) (by simp [uHat])
+  have hu : φ (Multiplicative.ofAdd (v 1 • uHat)) = 1 := by
+    rw [ofAdd_zsmul, map_zpow, image_uHat_eq_one φ x hx hc, one_zpow]
+  simpa only [ofAdd_sub, map_div, hu, div_one] using hrest
+
+private theorem LatticeCuspNormalClosure.image_eq_zpow_gamma {G : Type*} [Group G]
+    (φ : Multiplicative Lattice →* G) (x : G)
+    (hx :
+      ∀ v : Lattice, x * φ (Multiplicative.ofAdd v) * x⁻¹ = φ (Multiplicative.ofAdd (A₁ *ᵥ v)))
+    (hc : ∀ v : Lattice, v 0 = 0 → v 1 = 0 → φ (Multiplicative.ofAdd v) = 1) (v : Lattice) :
+    φ (Multiplicative.ofAdd v) = φ (Multiplicative.ofAdd ε) ^ γ v := by
+  have hk : γ (v - γ v • ε) = 0 := by simp [γ, ε]
+  have h := image_eq_one_of_gamma_eq_zero φ x hx hc (v - γ v • ε) hk
+  rw [ofAdd_sub, map_div, ofAdd_zsmul, map_zpow] at h
+  exact div_eq_one.mp h
+
+private theorem LatticeCuspNormalClosure.image_epsilon_prime_eq {G : Type*} [Group G]
+    (φ : Multiplicative Lattice →* G) (x : G)
+    (hx :
+      ∀ v : Lattice, x * φ (Multiplicative.ofAdd v) * x⁻¹ = φ (Multiplicative.ofAdd (A₁ *ᵥ v)))
+    (hc : ∀ v : Lattice, v 0 = 0 → v 1 = 0 → φ (Multiplicative.ofAdd v) = 1) :
+    φ (Multiplicative.ofAdd ε') = φ (Multiplicative.ofAdd ε) := by
+  simpa only [γ_ε', zpow_one] using image_eq_zpow_gamma φ x hx hc ε'
+
+private theorem LatticeCuspNormalClosure.image_epsilon_commute_first {G : Type*} [Group G]
+    (φ : Multiplicative Lattice →* G) (x : G)
+    (hx :
+      ∀ v : Lattice, x * φ (Multiplicative.ofAdd v) * x⁻¹ = φ (Multiplicative.ofAdd (A₁ *ᵥ v))) :
+    Commute (φ (Multiplicative.ofAdd ε)) x := by
+  have h := hx ε
+  rw [A₁_fixes_ε] at h
+  exact ((mul_inv_eq_iff_eq_mul).mp h).symm
+
+private theorem LatticeCuspNormalClosure.image_epsilon_commute_second {G : Type*} [Group G]
+    (φ : Multiplicative Lattice →* G) (x y : G)
+    (hx :
+      ∀ v : Lattice, x * φ (Multiplicative.ofAdd v) * x⁻¹ = φ (Multiplicative.ofAdd (A₁ *ᵥ v)))
+    (hy :
+      ∀ v : Lattice, y * φ (Multiplicative.ofAdd v) * y⁻¹ = φ (Multiplicative.ofAdd (A₂ *ᵥ v)))
+    (hc : ∀ v : Lattice, v 0 = 0 → v 1 = 0 → φ (Multiplicative.ofAdd v) = 1) :
+    Commute (φ (Multiplicative.ofAdd ε)) y := by
+  have h := hy ε'
+  rw [A₂_fixes_ε', image_epsilon_prime_eq φ x hx hc] at h
+  exact ((mul_inv_eq_iff_eq_mul).mp h).symm
+
+private theorem LatticeCuspNormalClosure.image_epsilon_commute_lattice {G : Type*} [Group G]
+    (φ : Multiplicative Lattice →* G) (v : Multiplicative Lattice) :
+    Commute (φ (Multiplicative.ofAdd ε)) (φ v) := by
+  change φ (Multiplicative.ofAdd ε) * φ v = φ v * φ (Multiplicative.ofAdd ε)
+  rw [← map_mul, ← map_mul, mul_comm]
+
+private theorem LatticeCuspNormalClosure.image_epsilon_mem_center_of_hom_ext {G : Type*} [Group G]
+    (φ : Multiplicative Lattice →* G) (x y : G)
+    (hx :
+      ∀ v : Lattice, x * φ (Multiplicative.ofAdd v) * x⁻¹ = φ (Multiplicative.ofAdd (A₁ *ᵥ v)))
+    (hy :
+      ∀ v : Lattice, y * φ (Multiplicative.ofAdd v) * y⁻¹ = φ (Multiplicative.ofAdd (A₂ *ᵥ v)))
+    (hc : ∀ v : Lattice, v 0 = 0 → v 1 = 0 → φ (Multiplicative.ofAdd v) = 1)
+    (hext :
+      ∀ f g : G →* G,
+        (∀ v : Multiplicative Lattice, f (φ v) = g (φ v)) → f x = g x → f y = g y → f = g) :
+    φ (Multiplicative.ofAdd ε) ∈ Subgroup.center G := by
+  let a := φ (Multiplicative.ofAdd ε)
+  have hconj : (MulAut.conj a).toMonoidHom = MonoidHom.id G := by
+    apply hext
+    · intro v
+      change a * φ v * a⁻¹ = φ v
+      rw [(image_epsilon_commute_lattice φ v).eq, mul_inv_cancel_right]
+    · change a * x * a⁻¹ = x
+      rw [(image_epsilon_commute_first φ x hx).eq, mul_inv_cancel_right]
+    · change a * y * a⁻¹ = y
+      rw [(image_epsilon_commute_second φ x y hx hy hc).eq, mul_inv_cancel_right]
+  apply Subgroup.mem_center_iff.mpr
+  intro g
+  have h : a * g * a⁻¹ = g := DFunLike.congr_fun hconj g
+  exact ((mul_inv_eq_iff_eq_mul).mp h).symm
+
+private abbrev TwistGroup (a b d : ℤ) :=
+  PresentedGroup (Set.range (twistRelators a b d))
+
+private def TwistGroup.c (a b d : ℤ) : TwistGroup a b d :=
+  PresentedGroup.of 0
+
+private def TwistGroup.x (a b d : ℤ) : TwistGroup a b d :=
+  PresentedGroup.of 1
+
+private def TwistGroup.y (a b d : ℤ) : TwistGroup a b d :=
+  PresentedGroup.of 2
+
+private theorem TwistGroup.c_commute_x (a b d : ℤ) : Commute (c a b d) (x a b d) := by
+  exact PresentedGroup.mk_eq_mk_of_mul_inv_mem (Set.mem_range.mpr ⟨0, rfl⟩)
+
+private theorem TwistGroup.x_mul_y (a b d : ℤ) : x a b d * y a b d = c a b d ^ a := by
+  exact PresentedGroup.mk_eq_mk_of_mul_inv_mem (Set.mem_range.mpr ⟨2, rfl⟩)
+
+private theorem TwistGroup.x_cube (a b d : ℤ) : x a b d ^ 3 = c a b d ^ b := by
+  exact PresentedGroup.mk_eq_mk_of_mul_inv_mem (Set.mem_range.mpr ⟨3, rfl⟩)
+
+private theorem TwistGroup.y_fourth (a b d : ℤ) : y a b d ^ 4 = c a b d ^ d := by
+  exact PresentedGroup.mk_eq_mk_of_mul_inv_mem (Set.mem_range.mpr ⟨4, rfl⟩)
+
+private theorem TwistGroup.x_commute_y (a b d : ℤ) : Commute (x a b d) (y a b d) := by
+  change x a b d * y a b d = y a b d * x a b d
+  apply mul_left_cancel (a := x a b d)
+  calc
+    x a b d * (x a b d * y a b d) = x a b d * c a b d ^ a := by rw [x_mul_y]
+    _ = c a b d ^ a * x a b d := ((c_commute_x a b d).symm.zpow_right a).eq
+    _ = x a b d * (y a b d * x a b d) := by rw [← x_mul_y, mul_assoc]
+
+private theorem TwistGroup.x_fourth (a b d : ℤ) : x a b d ^ 4 = c a b d ^ (4 * a - d) := by
+  calc
+    x a b d ^ 4 = (x a b d * y a b d) ^ 4 * (y a b d ^ 4)⁻¹ := by
+      rw [(x_commute_y a b d).mul_pow]; group
+    _ = (c a b d ^ a) ^ 4 * (c a b d ^ d)⁻¹ := by rw [x_mul_y, y_fourth]
+    _ = c a b d ^ (4 * a - d) := by
+      rw [← zpow_natCast _ 4, ← zpow_mul, ← zpow_sub]
+      congr 1
+      ring
+
+private theorem TwistGroup.x_eq_c_power (a b d : ℤ) : x a b d = c a b d ^ (4 * a - b - d) := by
+  calc
+    x a b d = x a b d ^ 4 * (x a b d ^ 3)⁻¹ := by group
+    _ = c a b d ^ (4 * a - d) * (c a b d ^ b)⁻¹ := by rw [x_fourth, x_cube]
+    _ = c a b d ^ (4 * a - b - d) := by
+      rw [← zpow_sub]
+      congr 1
+      ring
+
+private theorem TwistGroup.y_eq_c_power (a b d : ℤ) : y a b d = c a b d ^ (-3 * a + b + d) := by
+  calc
+    y a b d = (x a b d)⁻¹ * (x a b d * y a b d) := by group
+    _ = (c a b d ^ (4 * a - b - d))⁻¹ * c a b d ^ a := by rw [x_mul_y, x_eq_c_power]
+    _ = c a b d ^ (-3 * a + b + d) := by
+      rw [← zpow_neg, ← zpow_add]
+      congr 1
+      ring
+
+private theorem TwistGroup.c_twistOrder (a b d : ℤ) : c a b d ^ twistOrder a b d = 1 := by
+  have h := x_cube a b d
+  rw [x_eq_c_power, ← zpow_natCast _ 3, ← zpow_mul] at h
+  have h' := congrArg (fun z => z * (c a b d ^ b)⁻¹) h
+  rw [mul_inv_cancel, ← zpow_sub] at h'
+  norm_num only [Nat.cast_ofNat] at h'
+  have he : (4 * a - b - d) * 3 - b = twistOrder a b d := by unfold twistOrder; ring
+  rwa [he] at h'
+
+private theorem TwistGroup.generated_by_c (a b d : ℤ) (z : TwistGroup a b d) :
+    z ∈ Subgroup.zpowers (c a b d) := by
+  apply PresentedGroup.generated_by
+  intro j
+  fin_cases j
+  · exact Subgroup.mem_zpowers _
+  · change x a b d ∈ _
+    rw [x_eq_c_power]
+    exact Subgroup.zpow_mem_zpowers _ _
+  · change y a b d ∈ _
+    rw [y_eq_c_power]
+    exact Subgroup.zpow_mem_zpowers _ _
+
+private theorem TwistGroup.main_group_trivial (z : TwistGroup 0 1 (-1)) : z = 1 := by
+  have hc : c 0 1 (-1) = 1 := by
+    simpa only [main_twist_value, zpow_neg_one, inv_eq_one] using c_twistOrder 0 1 (-1)
+  obtain ⟨k, rfl⟩ := Subgroup.mem_zpowers_iff.mp (generated_by_c 0 1 (-1) z)
+  simp [hc]
+
+private def TwistGroup.realizationImages {G : Type*} (c₀ x₀ y₀ : G) : Fin 3 → G :=
+  ![c₀, x₀, y₀]
+
+private theorem
+    TwistGroup.realizationImages_relators {G : Type*} [Group G] (a b d : ℤ) (c₀ x₀ y₀ : G)
+    (hcx : Commute c₀ x₀) (hcy : Commute c₀ y₀) (hxy : x₀ * y₀ = c₀ ^ a) (hx : x₀ ^ 3 = c₀ ^ b)
+    (hy : y₀ ^ 4 = c₀ ^ d) :
+    ∀ r ∈ Set.range (twistRelators a b d), FreeGroup.lift (realizationImages c₀ x₀ y₀) r = 1 := by
+  rintro r ⟨i, rfl⟩
+  fin_cases i <;> simp [twistRelators, realizationImages, hcx.eq, hcy.eq, hxy, hx, hy]
+
+private def TwistGroup.realizationHom {G : Type*} [Group G] (a b d : ℤ) (c₀ x₀ y₀ : G)
+    (hcx : Commute c₀ x₀) (hcy : Commute c₀ y₀) (hxy : x₀ * y₀ = c₀ ^ a) (hx : x₀ ^ 3 = c₀ ^ b)
+    (hy : y₀ ^ 4 = c₀ ^ d) : TwistGroup a b d →* G :=
+  PresentedGroup.toGroup (realizationImages_relators a b d c₀ x₀ y₀ hcx hcy hxy hx hy)
+
+@[simp]
+private theorem TwistGroup.realizationHom_c {G : Type*} [Group G] (a b d : ℤ) (c₀ x₀ y₀ : G)
+    (hcx : Commute c₀ x₀) (hcy : Commute c₀ y₀) (hxy : x₀ * y₀ = c₀ ^ a) (hx : x₀ ^ 3 = c₀ ^ b)
+    (hy : y₀ ^ 4 = c₀ ^ d) : realizationHom a b d c₀ x₀ y₀ hcx hcy hxy hx hy (c a b d) = c₀ :=
+  PresentedGroup.toGroup.of (realizationImages_relators a b d c₀ x₀ y₀ hcx hcy hxy hx hy)
+
+@[simp]
+private theorem TwistGroup.realizationHom_x {G : Type*} [Group G] (a b d : ℤ) (c₀ x₀ y₀ : G)
+    (hcx : Commute c₀ x₀) (hcy : Commute c₀ y₀) (hxy : x₀ * y₀ = c₀ ^ a) (hx : x₀ ^ 3 = c₀ ^ b)
+    (hy : y₀ ^ 4 = c₀ ^ d) : realizationHom a b d c₀ x₀ y₀ hcx hcy hxy hx hy (x a b d) = x₀ :=
+  PresentedGroup.toGroup.of (realizationImages_relators a b d c₀ x₀ y₀ hcx hcy hxy hx hy)
+
+@[simp]
+private theorem TwistGroup.realizationHom_y {G : Type*} [Group G] (a b d : ℤ) (c₀ x₀ y₀ : G)
+    (hcx : Commute c₀ x₀) (hcy : Commute c₀ y₀) (hxy : x₀ * y₀ = c₀ ^ a) (hx : x₀ ^ 3 = c₀ ^ b)
+    (hy : y₀ ^ 4 = c₀ ^ d) : realizationHom a b d c₀ x₀ y₀ hcx hcy hxy hx hy (y a b d) = y₀ :=
+  PresentedGroup.toGroup.of (realizationImages_relators a b d c₀ x₀ y₀ hcx hcy hxy hx hy)
+
+public
+theorem TwistGroup.main_realization_generators_eq_one {G : Type*} [Group G] (c₀ x₀ y₀ : G)
+    (hcx : Commute c₀ x₀) (hcy : Commute c₀ y₀) (hxy : x₀ * y₀ = 1) (hx : x₀ ^ 3 = c₀)
+    (hy : y₀ ^ 4 = c₀⁻¹) : c₀ = 1 ∧ x₀ = 1 ∧ y₀ = 1 := by
+  let f :=
+    realizationHom 0 1 (-1) c₀ x₀ y₀ hcx hcy (by simpa only [zpow_zero] using hxy)
+      (by simpa only [zpow_one] using hx) (by simpa only [zpow_neg_one] using hy)
+  have hc₀ : f (c 0 1 (-1)) = c₀ := realizationHom_c ..
+  have hx₀ : f (x 0 1 (-1)) = x₀ := realizationHom_x ..
+  have hy₀ : f (y 0 1 (-1)) = y₀ := realizationHom_y ..
+  refine ⟨hc₀.symm.trans ?_, hx₀.symm.trans ?_, hy₀.symm.trans ?_⟩
+  · exact (congrArg f (main_group_trivial _)).trans f.map_one
+  · exact (congrArg f (main_group_trivial _)).trans f.map_one
+  · exact (congrArg f (main_group_trivial _)).trans f.map_one
+
+private def ThreefoldOverlapMappingTorus.Cusp.boundaryRegularData :
+    PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint :=
+  PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+
+private theorem ThreefoldOverlapMappingTorus.Cusp.specialRadius_cap :
+    specialData.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width :=
+  SpecialPeriods.Threefold.specialBaseCover_cusp_radius_bounds.2.2.le
+
+private theorem ThreefoldOverlapMappingTorus.Cusp.specialPeriod_agreement
+    (s : SpecialPeriods.CuspFamily.LogBase specialData.radius) :
+    boundaryRegularData.periods.point
+        (SpecialPeriods.CuspFamily.logBaseToRegular specialData.radius specialRadius_cap s) =
+      specialData.periods.point s :=
+  SpecialPeriods.CuspGlobalOverlap.spherePeriod_agreement
+    SpecialPeriods.Triangle.triangleSphereUniformization
+    SpecialPeriods.Triangle.triangleSphereUniformization_cusp
+    SpecialPeriods.Triangle.triangleSphereUniformization_centerOne
+    SpecialPeriods.Triangle.triangleSphereUniformization_centerTwo
+    (SpecialPeriods.Threefold.specialBaseCover.radius Option.none)
+    (SpecialPeriods.Threefold.specialBaseCover.radius_pos Option.none)
+    SpecialPeriods.Threefold.specialCuspRadius_le specialRadius_cap s
+
+private theorem ThreefoldOverlapMappingTorus.Cusp.puncturedPieceToRegular_cusp
+    (x : ThreefoldOverlapMappingTorus.PuncturedPiece Option.none) :
+    ThreefoldOverlapMappingTorus.puncturedPieceToRegular Option.none x =
+      SpecialPeriods.Threefold.specialCuspOverlap x.val := by
+  apply (SpecialPeriods.Threefold.inclusion_openEmbedding Option.none).injective
+  have hx : x.val ∈ SpecialPeriods.Threefold.specialCuspOverlap.source := by
+    rw [SpecialPeriods.Threefold.specialCuspOverlap_source]
+    exact x.property
+  refine (ThreefoldOverlapMappingTorus.puncturedPieceToRegular_inclusion Option.none x).trans ?_
+  change
+    SpecialPeriods.Threefold.gluingData.inclusion (Option.some Option.none) x.val =
+      SpecialPeriods.Threefold.gluingData.inclusion Option.none
+        (SpecialPeriods.Threefold.specialCuspOverlap x.val)
+  exact
+    (SpecialPeriods.Threefold.gluingData.inclusion_eq_iff (Option.some Option.none) Option.none _
+          _).mpr
+      ⟨hx, rfl⟩
+
+private theorem
+    ThreefoldOverlapMappingTorus.Cusp.specialCuspOverlap_family (y : specialData.Space) :
+    SpecialPeriods.Threefold.specialCuspOverlap (puncturedFamilyHomeomorph specialData y).val =
+      SpecialPeriods.CuspGlobalOverlap.familyMap specialData boundaryRegularData specialRadius_cap
+        y := by
+  let := specialData.chartedSpace
+  let :=
+    CuspQuotient.chartedSpace specialData.correction specialData.radius specialData.radius_pos
+      specialData.radius_lt_one specialData.holomorphic specialData.smallDrift
+  let :=
+    boundaryRegularData.chartedSpace
+      (SpecialPeriods.CuspGlobalOverlap.familyCovering boundaryRegularData)
+  change
+    SpecialPeriods.CuspGlobalOverlap.cuspToRegularPartial specialData boundaryRegularData
+        specialRadius_cap specialPeriod_agreement (puncturedFamilyHomeomorph specialData y).val =
+      _
+  rw [SpecialPeriods.CuspGlobalOverlap.cuspToRegularPartial_apply specialData boundaryRegularData
+      specialRadius_cap specialPeriod_agreement _
+      (puncturedFamilyHomeomorph specialData y).property]
+  change
+    SpecialPeriods.CuspGlobalOverlap.familyMap specialData boundaryRegularData specialRadius_cap
+        (specialData.puncturedFamilyBiholomorph.symm (specialData.puncturedFamilyBiholomorph y)) =
+      _
+  rw [Diffeomorph.symm_apply_apply]
+
+private theorem ThreefoldOverlapMappingTorus.Cusp.boundaryToRegularFamily_cusp_mk (t : ℝ)
+    (x : RealTorus₄) :
+    ThreefoldOverlapMappingTorus.boundaryToRegularFamily Option.none
+        (MappingTorus.mk monodromy (t, x)) =
+      boundaryRegularData.quotient
+        (SpecialPeriods.CuspFamily.logBaseToRegular specialData.radius specialRadius_cap
+            (logPoint specialData.radius specialData.radius_pos t specialHeight),
+          x) := by
+  let p : ThreefoldOverlapMappingTorus.PuncturedPiece Option.none :=
+    specialBoundaryInclusion (MappingTorus.mk monodromy (t, x))
+  have hp :
+    ThreefoldOverlapMappingTorus.boundaryToRegularFamily Option.none
+        (MappingTorus.mk monodromy (t, x)) =
+      SpecialPeriods.Threefold.specialCuspOverlap p.val :=
+    puncturedPieceToRegular_cusp p
+  refine hp.trans ?_
+  change
+    SpecialPeriods.Threefold.specialCuspOverlap
+        (boundaryCylinder specialData specialHeight (t, x)).val =
+      _
+  rw [boundaryCylinder_apply, specialCuspOverlap_family,
+    SpecialPeriods.CuspGlobalOverlap.familyMap_quotient]
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Prelude.lean b/LeanPool/HopfProblem/Prelude.lean
new file mode 100644
index 000000000..b8d8797c3
--- /dev/null
+++ b/LeanPool/HopfProblem/Prelude.lean
@@ -0,0 +1,111 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import Mathlib.Algebra.AffineMonoid.Basic
+public import Mathlib.Algebra.Category.ModuleCat.AB
+public import Mathlib.Algebra.Category.ModuleCat.Biproducts
+public import Mathlib.Algebra.Homology.ConcreteCategory
+public import Mathlib.Algebra.Homology.GrothendieckAbelian
+public import Mathlib.Algebra.Homology.HomologicalComplexBiprod
+public import Mathlib.Algebra.Homology.HomologySequenceLemmas
+public import Mathlib.Algebra.Module.StablyFree.Basic
+public import Mathlib.Algebra.Module.ZLattice.Summable
+public import Mathlib.Algebra.Order.Archimedean.Real.Hom
+public import Mathlib.Algebra.Ring.IsFormallyReal
+public import Mathlib.AlgebraicTopology.SingularHomology.HomologyZero
+public import Mathlib.AlgebraicTopology.SingularHomology.HomotopyInvariance
+public import Mathlib.Analysis.Calculus.Deriv.Star
+public import Mathlib.Analysis.Calculus.ImplicitContDiff
+public import Mathlib.Analysis.Calculus.TaylorIntegral
+public import Mathlib.Analysis.Complex.BranchLogRoot
+public import Mathlib.Analysis.Complex.Conformal
+public import Mathlib.Analysis.Complex.HasPrimitives
+public import Mathlib.Analysis.Complex.OpenMapping
+public import Mathlib.Analysis.Complex.Schwarz
+public import Mathlib.Analysis.Complex.UpperHalfPlane.FixedPoints
+public import Mathlib.Analysis.Complex.UpperHalfPlane.Metric
+public import Mathlib.Analysis.Convex.GaugeRescale
+public import Mathlib.Analysis.InnerProductSpace.OfNorm
+public import Mathlib.Analysis.Normed.Module.Connected
+public import Mathlib.Analysis.Normed.Module.ContinuousInverse
+public import Mathlib.Analysis.Normed.Module.Normalize
+public import Mathlib.Analysis.SpecialFunctions.Artanh
+public import Mathlib.Analysis.SpecialFunctions.Complex.Analytic
+public import Mathlib.Analysis.SpecialFunctions.Pow.Integral
+public import Mathlib.CategoryTheory.EffectiveEpi.Comp
+public import Mathlib.CategoryTheory.ExtremalEpi
+public import Mathlib.Combinatorics.Quiver.ReflQuiver
+public import Mathlib.Data.Int.Star
+public import Mathlib.Dynamics.OmegaLimit
+public import Mathlib.Geometry.Manifold.Complex
+public import Mathlib.Geometry.Manifold.Instances.Icc
+public import Mathlib.Geometry.Manifold.Instances.UnitsOfNormedAlgebra
+public import Mathlib.Geometry.Manifold.IntegralCurve.UniformTime
+public import Mathlib.Geometry.Manifold.Sheaf.Basic
+public import Mathlib.Geometry.Manifold.VectorField.Pullback
+public import Mathlib.Geometry.Manifold.WhitneyEmbedding
+public import Mathlib.GroupTheory.PresentedGroup
+public import Mathlib.GroupTheory.PushoutI
+public import Mathlib.GroupTheory.SemidirectProduct
+public import Mathlib.LinearAlgebra.ExteriorPower.Basis
+public import Mathlib.LinearAlgebra.Projectivization.Subspace
+public import Mathlib.LinearAlgebra.QuadraticForm.Real
+public import Mathlib.LinearAlgebra.QuadraticForm.Signature
+public import Mathlib.NumberTheory.ModularForms.Derivative
+public import Mathlib.NumberTheory.ModularForms.LevelOne.GradedRing
+public import Mathlib.NumberTheory.ModularForms.ProperlyDiscontinuous
+public import Mathlib.Order.CompletePartialOrder
+public import Mathlib.Order.Interval.Set.IsoIoo
+public import Mathlib.RingTheory.Etale.Weakly
+public import Mathlib.RingTheory.Finiteness.ModuleFinitePresentation
+public import Mathlib.RingTheory.Flat.TorsionFree
+public import Mathlib.RingTheory.Henselian
+public import Mathlib.RingTheory.PicardGroup
+public import Mathlib.RingTheory.RegularLocalRing.Defs
+public import Mathlib.RingTheory.RootsOfUnity.Complex
+public import Mathlib.RingTheory.SimpleRing.Principal
+public import Mathlib.RingTheory.TotallySplit
+public import Mathlib.Tactic.Abel
+public import Mathlib.Tactic.Choose
+public import Mathlib.Tactic.Continuity
+public import Mathlib.Tactic.Convert
+public import Mathlib.Tactic.Ext
+public import Mathlib.Tactic.FieldSimp
+public import Mathlib.Tactic.FinCases
+public import Mathlib.Tactic.FunProp
+public import Mathlib.Tactic.GCongr
+public import Mathlib.Tactic.Generalize
+public import Mathlib.Tactic.Group
+public import Mathlib.Tactic.IntervalCases
+public import Mathlib.Tactic.Lift
+public import Mathlib.Tactic.Linarith
+public import Mathlib.Tactic.LinearCombination
+public import Mathlib.Tactic.NormNum
+public import Mathlib.Tactic.NormNum.Parity
+public import Mathlib.Tactic.Positivity
+public import Mathlib.Tactic.Ring
+public import Mathlib.Tactic.SplitIfs
+public import Mathlib.Tactic.Tauto
+public import Mathlib.Tactic.WLOG
+public import Mathlib.Topology.Baire.LocallyCompactRegular
+public import Mathlib.Topology.Compactification.OnePoint.Sphere
+public import Mathlib.Topology.Connected.Separation
+public import Mathlib.Topology.Gluing
+public import Mathlib.Topology.Homotopy.HomotopyGroup
+public import Mathlib.Topology.MetricSpace.HausdorffDimension
+public import Mathlib.Topology.Separation.Lemmas
+public import Mathlib.Topology.Sheaves.EtaleSpace
+public import Mathlib.Topology.Subpath
+public import Mathlib.Topology.UniformSpace.Ascoli
+public import Mathlib.Topology.UniformSpace.Uniformizable
+public import Std.Tactic.BVDecide.LRAT.Internal.Formula.RupAddResult
+
+/-!
+# Hopf problem: prelude
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
diff --git a/LeanPool/HopfProblem/Recognition/Degree1.lean b/LeanPool/HopfProblem/Recognition/Degree1.lean
new file mode 100644
index 000000000..c4dc083f3
--- /dev/null
+++ b/LeanPool/HopfProblem/Recognition/Degree1.lean
@@ -0,0 +1,5662 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.CuspFibre.CuspSpecialization
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Foundations.LineBundleTransport
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.Recognition.Smale1
+import all LeanPool.HopfProblem.Recognition.Smale2
+import all LeanPool.HopfProblem.Recognition.Smale3
+import all LeanPool.HopfProblem.Recognition.Smale4
+import all LeanPool.HopfProblem.Recognition.Smale5
+import all LeanPool.HopfProblem.CuspFibre.CuspCentralHomology1
+import all LeanPool.HopfProblem.CuspFibre.CuspSpecialization
+
+/-!
+# Hopf problem: recognition · degree 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def
+    Degree.AxisCoordinates.transverseBlock {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    (L : (ℝ × V) →L[ℝ] (ℝ × V)) : V →L[ℝ] V :=
+  (ContinuousLinearMap.snd ℝ ℝ V).comp (L.comp (ContinuousLinearMap.inr ℝ ℝ V))
+
+private theorem Degree.AxisCoordinates.contDiff_tangentShear {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] : ContDiff ℝ ∞ (tangentShear (V := V)) :=
+  contDiff_const.clm_comp (contDiff_id.clm_comp contDiff_const)
+
+private theorem Degree.AxisCoordinates.contDiff_transverseBlock {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] : ContDiff ℝ ∞ (transverseBlock (V := V)) :=
+  contDiff_const.clm_comp (contDiff_id.clm_comp contDiff_const)
+
+private theorem Degree.AxisCoordinates.axis_block_apply {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] (L : (ℝ × V) →L[ℝ] (ℝ × V)) (hL : L (1, 0) = (1, 0)) (s : ℝ) (z : V) :
+    L (s, z) = (s + tangentShear L z, transverseBlock L z) := by
+  have hp : (s, z) = s • (1, (0 : V)) + (0, z) := by simp
+  rw [hp, map_add, map_smul, hL]
+  apply Prod.ext <;> simp [tangentShear, transverseBlock]
+
+private theorem
+    Degree.AxisCoordinates.axis_block_eq {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    (L : (ℝ × V) →L[ℝ] (ℝ × V)) (hL : L (1, 0) = (1, 0)) :
+    L = Smale.FrameField.shearedBlock (tangentShear L) (transverseBlock L) := by
+  apply ContinuousLinearMap.ext
+  intro p
+  rw [Smale.FrameField.shearedBlock_apply]
+  exact axis_block_apply L hL p.1 p.2
+
+private theorem Degree.AxisCoordinates.bijective_transverseBlock {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] (L : (ℝ × V) →L[ℝ] (ℝ × V)) (hL : L (1, 0) = (1, 0))
+    (hi : Function.Bijective L) : Function.Bijective (transverseBlock L) := by
+  constructor
+  · intro z w hzw
+    have he : L (-tangentShear L z, z) = L (-tangentShear L w, w) := by
+      rw [axis_block_apply L hL, axis_block_apply L hL]
+      simp only [neg_add_cancel, hzw]
+    exact congrArg (fun p : ℝ × V => p.2) (hi.1 he)
+  · intro w
+    obtain ⟨⟨s, z⟩, hz⟩ := hi.2 (0, w)
+    rw [axis_block_apply L hL] at hz
+    exact ⟨z, congrArg (fun p : ℝ × V => p.2) hz⟩
+
+private theorem
+    Degree.AxisCoordinates.isInvertible_transverseBlock {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [FiniteDimensional ℝ V] (L : (ℝ × V) →L[ℝ] (ℝ × V)) (hL : L (1, 0) = (1, 0))
+    (hi : L.IsInvertible) : (transverseBlock L).IsInvertible := by
+  let e :=
+    (LinearEquiv.ofBijective (transverseBlock L).toLinearMap
+        (bijective_transverseBlock L hL hi.bijective)).toContinuousLinearEquiv
+  exact ⟨e, rfl⟩
+
+private theorem Degree.AxisCoordinates.derivative_fixes_axis {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] {F : (ℝ × V) → (ℝ × V)} {s : ℝ} (hF : ContDiffAt ℝ ∞ F (s, 0))
+    (heq : (fun r : ℝ => F (r, 0)) =ᶠ[𝓝 s] (fun r => (r, (0 : V)))) :
+    fderiv ℝ F (s, 0) (1, 0) = (1, 0) := by
+  have ha : HasDerivAt (fun r : ℝ => (r, (0 : V))) (1, 0) s :=
+    (hasDerivAt_id s).prodMk (hasDerivAt_const s 0)
+  have hd := (hF.differentiableAt (by simp)).hasFDerivAt.comp_hasDerivAt s ha
+  exact hd.deriv.symm.trans (heq.deriv_eq.trans ha.deriv)
+
+private theorem Degree.AxisCoordinates.exists_native_axis_transition_data {V E M : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℝ V] [FiniteDimensional ℝ V] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (Φ Ψ : PartialDiffeomorph 𝓘(ℝ, ℝ × V) 𝓘(ℝ, E) (ℝ × V) M ∞) {s₀ : ℝ}
+    (hΦ : (s₀, (0 : V)) ∈ Φ.source) (hΨ : (s₀, (0 : V)) ∈ Ψ.source)
+    (haxis : (fun s : ℝ => Φ (s, 0)) =ᶠ[𝓝 s₀] (fun s => Ψ (s, 0))) :
+    ∃ U : Set ℝ,
+      IsOpen U ∧
+        s₀ ∈ U ∧
+          (∀ s ∈ U, (s, (0 : V)) ∈ (Φ.trans Ψ.symm).source) ∧
+            (∀ s ∈ U, Ψ.symm (Φ (s, 0)) = (s, 0)) ∧
+              ContDiffOn ℝ ∞ (fun s => tangentShear (fderiv ℝ (Ψ.symm ∘ Φ) (s, 0))) U ∧
+                ContDiffOn ℝ ∞ (fun s => transverseBlock (fderiv ℝ (Ψ.symm ∘ Φ) (s, 0))) U ∧
+                  (∀ s ∈ U, (transverseBlock (fderiv ℝ (Ψ.symm ∘ Φ) (s, 0))).IsInvertible) ∧
+                    ∀ s ∈ U,
+                      fderiv ℝ (Ψ.symm ∘ Φ) (s, 0) =
+                        Smale.FrameField.shearedBlock
+                          (tangentShear (fderiv ℝ (Ψ.symm ∘ Φ) (s, 0)))
+                          (transverseBlock (fderiv ℝ (Ψ.symm ∘ Φ) (s, 0))) := by
+  let R := Φ.trans Ψ.symm
+  have hR0 : (s₀, (0 : V)) ∈ R.source := by
+    refine ⟨hΦ, ?_⟩
+    change Φ (s₀, 0) ∈ Ψ.target
+    rw [haxis.eq_of_nhds]
+    exact Ψ.map_source' hΨ
+  have hRsource : ∀ᶠ s in 𝓝 s₀, (s, (0 : V)) ∈ R.source :=
+    (continuous_id.prodMk continuous_const).continuousAt (R.open_source.mem_nhds hR0)
+  have hΨsource : ∀ᶠ s in 𝓝 s₀, (s, (0 : V)) ∈ Ψ.source :=
+    (continuous_id.prodMk continuous_const).continuousAt (Ψ.open_source.mem_nhds hΨ)
+  have hRaxis : ∀ᶠ s in 𝓝 s₀, R (s, (0 : V)) = (s, 0) := by
+    filter_upwards [haxis, hΨsource] with s hs hsΨ
+    change Ψ.symm (Φ (s, 0)) = (s, 0)
+    rw [hs]
+    exact Ψ.left_inv' hsΨ
+  obtain ⟨U, hUN, hU, hs₀⟩ := mem_nhds_iff.mp (hRsource.and hRaxis)
+  have hdf : ContDiffOn ℝ ∞ (fun s : ℝ => fderiv ℝ R (s, (0 : V))) U :=
+    (R.contMDiffOn_toFun.contDiffOn.fderiv_of_isOpen R.open_source (m := ∞) (by simp)).comp
+      (contDiff_id.prodMk contDiff_const).contDiffOn (fun s hs => (hUN hs).1)
+  have hfix (s : ℝ) (hs : s ∈ U) : fderiv ℝ R (s, (0 : V)) (1, 0) = (1, 0) := by
+    apply
+      derivative_fixes_axis
+        (R.contMDiffOn_toFun.contDiffOn.contDiffAt (R.open_source.mem_nhds (hUN hs).1))
+    filter_upwards [hU.mem_nhds hs] with r hr
+    exact (hUN hr).2
+  refine
+    ⟨U, hU, hs₀, fun s hs => (hUN hs).1, fun s hs => (hUN hs).2,
+      (contDiff_tangentShear (V := V)).contDiffOn.comp hdf (fun _ _ => Set.mem_univ _),
+      (contDiff_transverseBlock (V := V)).contDiffOn.comp hdf (fun _ _ => Set.mem_univ _), ?_, ?_⟩
+  · intro s hs
+    have hl : IsLocalDiffeomorphAt 𝓘(ℝ, ℝ × V) 𝓘(ℝ, ℝ × V) ∞ R (s, 0) :=
+      ⟨R, (hUN hs).1, fun _ _ => rfl⟩
+    have hi : (fderiv ℝ R (s, 0)).IsInvertible := by
+      refine ⟨hl.mfderivToContinuousLinearEquiv (by simp), ?_⟩
+      have he := hl.mfderivToContinuousLinearEquiv_coe (by simp)
+      rw [mfderiv_eq_fderiv] at he
+      exact he
+    exact isInvertible_transverseBlock _ (hfix s hs) hi
+  · intro s hs
+    exact axis_block_eq _ (hfix s hs)
+
+private theorem Smale.exists_smooth_open_curve_with_germ {B : Type*} [NormedAddCommGroup B]
+    [NormedSpace ℝ B] (S : TopologicalSpace.Opens B) {a : ℝ → B} {U : Set ℝ} {t₀ : ℝ}
+    (ha : ContDiffOn ℝ ∞ a U) (hU : IsOpen U) (ht₀ : t₀ ∈ U) (ha0 : a t₀ ∈ S) :
+    ∃ f : C(ℝ, S), ContMDiff 𝓘(ℝ, ℝ) 𝓘(ℝ, B) ∞ f ∧ (fun t => (f t : B)) =ᶠ[𝓝 t₀] a := by
+  classical
+  let A : ℝ → S := fun t => if h : a t ∈ S then ⟨a t, h⟩ else ⟨a t₀, ha0⟩
+  let V := U ∩ a ⁻¹' (S : Set B)
+  have hV : IsOpen V := ha.continuousOn.isOpen_inter_preimage hU S.isOpen
+  have htV : t₀ ∈ V := ⟨ht₀, ha0⟩
+  have hval {t : ℝ} (ht : t ∈ V) : (Subtype.val ∘ A) =ᶠ[𝓝 t] a := by
+    filter_upwards [hV.mem_nhds ht] with s hs
+    have hsS : a s ∈ S := hs.2
+    simp only [Function.comp_apply, A, dite_eq_left hsS]
+  have hA : ContMDiffOn 𝓘(ℝ, ℝ) 𝓘(ℝ, B) ∞ A V := by
+    intro t ht
+    have haAt := (ha.contDiffAt (hU.mem_nhds ht.1)).contMDiffAt
+    have hvalAt := haAt.congr_of_eventuallyEq (hval ht)
+    exact ((ContMDiffAt.subtypeVal_comp_iff S A t).mp hvalAt).contMDiffWithinAt
+  obtain ⟨f, hf, heq⟩ := exists_smooth_curve_with_germ_at hA hV htV
+  refine ⟨f, hf, ?_⟩
+  filter_upwards [heq, hval htV] with t ht hta
+  exact (congrArg Subtype.val ht).trans hta
+
+private theorem
+    Smale.exists_smooth_open_curve_with_endpoint_germs {B : Type*} [NormedAddCommGroup B]
+    [NormedSpace ℝ B] (S : TopologicalSpace.Opens B) {a b : ℝ → B} {U V : Set ℝ}
+    (ha : ContDiffOn ℝ ∞ a U) (hb : ContDiffOn ℝ ∞ b V) (hU : IsOpen U) (hV : IsOpen V)
+    (h0U : (0 : ℝ) ∈ U) (h1V : (1 : ℝ) ∈ V) (ha0 : a 0 ∈ S) (hb1 : b 1 ∈ S)
+    (γ : Path (⟨a 0, ha0⟩ : S) (⟨b 1, hb1⟩ : S)) :
+    ∃ f : ℝ → B, ContDiff ℝ ∞ f ∧ (∀ t, f t ∈ S) ∧ (f =ᶠ[𝓝 (0 : ℝ)] a) ∧ (f =ᶠ[𝓝 (1 : ℝ)] b) := by
+  obtain ⟨a', ha', heqa⟩ := exists_smooth_open_curve_with_germ S ha hU h0U ha0
+  obtain ⟨b', hb', heqb⟩ := exists_smooth_open_curve_with_germ S hb hV h1V hb1
+  have hstart : a' 0 = (⟨a 0, ha0⟩ : S) := Subtype.ext heqa.eq_of_nhds
+  have hend : b' 1 = (⟨b 1, hb1⟩ : S) := Subtype.ext heqb.eq_of_nhds
+  obtain ⟨f, hf, hfa, hfb⟩ :=
+    exists_smooth_curve_with_endpoint_germs a' b' ha' hb' (γ.cast hstart hend)
+  refine
+    ⟨fun t => (f t : B), ((contMDiff_subtype_val (I := 𝓘(ℝ, B)) (U := S)).comp hf).contDiff,
+      fun t => (f t).property, ?_, ?_⟩
+  · filter_upwards [Iio_mem_nhds (show (0 : ℝ) < 1 / 8 by norm_num), heqa] with t ht hta
+    change t < 1 / 8 at ht
+    exact (congrArg Subtype.val (hfa ht.le)).trans hta
+  · filter_upwards [Ioi_mem_nhds (show (7 / 8 : ℝ) < 1 by norm_num), heqb] with t ht htb
+    change 7 / 8 < t at ht
+    exact (congrArg Subtype.val (hfb ht.le)).trans htb
+
+private def Degree.LinearFramePaths.matrixCoordinates {D ι : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [FiniteDimensional ℝ D] [Fintype ι] [DecidableEq ι]
+    (b : Module.Basis ι ℝ D) : (D →L[ℝ] D) ≃L[ℝ] Matrix ι ι ℝ :=
+  (LinearMap.toContinuousLinearMap.symm.trans (LinearMap.toMatrix b b)).toContinuousLinearEquiv
+
+private theorem Degree.LinearFramePaths.det_matrixCoordinates {D ι : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [FiniteDimensional ℝ D] [Fintype ι] [DecidableEq ι] (b : Module.Basis ι ℝ D)
+    (A : D →L[ℝ] D) : Matrix.det (matrixCoordinates b A) = A.toLinearMap.det :=
+  LinearMap.det_toMatrix b A.toLinearMap
+
+private def
+    Degree.LinearFramePaths.operatorComponent {D : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D]
+    (σ : ℝ) : TopologicalSpace.Opens (D →L[ℝ] D) :=
+  ⟨{A | 0 < σ * A.toLinearMap.det},
+    isOpen_lt continuous_const (continuous_const.mul ContinuousLinearMap.continuous_det)⟩
+
+private theorem
+    Degree.LinearFramePaths.joined_operatorComponent {D ι : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [FiniteDimensional ℝ D] [Nontrivial ι] [Finite ι] (b : Module.Basis ι ℝ D)
+    {σ : ℝ} (A B : operatorComponent (D := D) σ) : Joined A B := by
+  classical
+  let _ := Fintype.ofFinite ι
+  let e := matrixCoordinates b
+  let A' : determinantComponent (ι := ι) σ :=
+    ⟨e A, by
+      change 0 < σ * Matrix.det (matrixCoordinates b A)
+      rw [det_matrixCoordinates]
+      exact A.property⟩
+  let B' : determinantComponent (ι := ι) σ :=
+    ⟨e B, by
+      change 0 < σ * Matrix.det (matrixCoordinates b B)
+      rw [det_matrixCoordinates]
+      exact B.property⟩
+  let ψ : determinantComponent (ι := ι) σ → operatorComponent (D := D) σ := fun C =>
+    ⟨e.symm C, by
+      have hd := det_matrixCoordinates b (e.symm C)
+      change Matrix.det (e (e.symm C)) = (e.symm C).toLinearMap.det at hd
+      rw [e.apply_symm_apply] at hd
+      change 0 < σ * (e.symm C).toLinearMap.det
+      rw [← hd]
+      exact C.property⟩
+  have hψ : Continuous ψ := (e.symm.continuous.comp continuous_subtype_val).subtype_mk _
+  have hA : ψ A' = A := Subtype.ext (e.symm_apply_apply A)
+  have hB : ψ B' = B := Subtype.ext (e.symm_apply_apply B)
+  have h := (joined_determinantComponent A' B').map hψ
+  rwa [hA, hB] at h
+
+private theorem Degree.LinearFramePaths.exists_smooth_invertible_frame_join {D ι : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D] [Nontrivial ι] [Finite ι]
+    (basis : Module.Basis ι ℝ D) {a b : ℝ → (D →L[ℝ] D)} {U V : Set ℝ} (ha : ContDiffOn ℝ ∞ a U)
+    (hb : ContDiffOn ℝ ∞ b V) (hU : IsOpen U) (hV : IsOpen V) (h0U : (0 : ℝ) ∈ U)
+    (h1V : (1 : ℝ) ∈ V) (hsign : 0 < (a 0).toLinearMap.det * (b 1).toLinearMap.det) :
+    ∃ L : ℝ → (D →L[ℝ] D),
+      ContDiff ℝ ∞ L ∧
+        (∀ t, Function.Bijective (L t)) ∧
+          (∀ t, 0 < (a 0).toLinearMap.det * (L t).toLinearMap.det) ∧
+            (L =ᶠ[𝓝 (0 : ℝ)] a) ∧ (L =ᶠ[𝓝 (1 : ℝ)] b) := by
+  let σ := (a 0).toLinearMap.det
+  let S := operatorComponent (D := D) σ
+  have ha0ne : (a 0).toLinearMap.det ≠ 0 := by
+    intro hz
+    rw [hz, MulZeroClass.zero_mul] at hsign
+    exact lt_irrefl _ hsign
+  have ha0 : a 0 ∈ S := mul_self_pos.mpr ha0ne
+  have hb1 : b 1 ∈ S := hsign
+  let γ := (joined_operatorComponent basis (⟨a 0, ha0⟩ : S) ⟨b 1, hb1⟩).somePath
+  obtain ⟨L, hL, hmem, hleft, hright⟩ :=
+    Smale.exists_smooth_open_curve_with_endpoint_germs S ha hb hU hV h0U h1V ha0 hb1 γ
+  have hpositive (t : ℝ) : 0 < (a 0).toLinearMap.det * (L t).toLinearMap.det := hmem t
+  refine ⟨L, hL, ?_, hpositive, hleft, hright⟩
+  intro t
+  have hdet : (L t).toLinearMap.det ≠ 0 := by
+    intro hz
+    have hp := hpositive t
+    rw [hz, MulZeroClass.mul_zero] at hp
+    exact lt_irrefl _ hp
+  have hker : (L t).toLinearMap.ker = ⊥ := by
+    by_contra hk
+    exact hdet (LinearMap.det_eq_zero_iff_ker_ne_bot.mpr hk)
+  have hi : Function.Injective (L t) := LinearMap.ker_eq_bot.mp hker
+  exact ⟨hi, (LinearMap.injective_iff_surjective_of_finrank_eq_finrank rfl).mp hi⟩
+
+private theorem Degree.AxisCoordinates.exists_smooth_sheared_frame_join {V ι : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℝ V] [FiniteDimensional ℝ V] [Finite ι] [Nontrivial ι]
+    (basis : Module.Basis ι ℝ V) {A₀ A₁ : ℝ → (V →L[ℝ] ℝ)} {T₀ T₁ : ℝ → (V →L[ℝ] V)}
+    {U₀ U₁ : Set ℝ} (hA₀ : ContDiffOn ℝ ∞ A₀ U₀) (hA₁ : ContDiffOn ℝ ∞ A₁ U₁)
+    (hT₀ : ContDiffOn ℝ ∞ T₀ U₀) (hT₁ : ContDiffOn ℝ ∞ T₁ U₁) (hU₀ : IsOpen U₀) (hU₁ : IsOpen U₁)
+    (h0 : (0 : ℝ) ∈ U₀) (h1 : (1 : ℝ) ∈ U₁)
+    (hsign : 0 < (T₀ 0).toLinearMap.det * (T₁ 1).toLinearMap.det) :
+    ∃ A : ℝ → (V →L[ℝ] ℝ),
+      ∃ T : ℝ → (V →L[ℝ] V),
+        ContDiff ℝ ∞ A ∧
+          ContDiff ℝ ∞ T ∧
+            (∀ s, (T s).IsInvertible) ∧
+              (∀ s, (Smale.FrameField.shearedBlock (A s) (T s)).IsInvertible) ∧
+                (A =ᶠ[𝓝 (0 : ℝ)] A₀) ∧
+                  (A =ᶠ[𝓝 (1 : ℝ)] A₁) ∧ (T =ᶠ[𝓝 (0 : ℝ)] T₀) ∧ (T =ᶠ[𝓝 (1 : ℝ)] T₁) := by
+  let S : TopologicalSpace.Opens (V →L[ℝ] ℝ) := ⟨Set.univ, isOpen_univ⟩
+  let γ : Path (⟨A₀ 0, Set.mem_univ _⟩ : S) ⟨A₁ 1, Set.mem_univ _⟩ :=
+    { toFun := fun t => ⟨(1 - (t : ℝ)) • A₀ 0 + (t : ℝ) • A₁ 1, Set.mem_univ _⟩
+      continuous_toFun := by fun_prop
+      source' := by apply Subtype.ext; simp
+      target' := by apply Subtype.ext; simp }
+  obtain ⟨A, hA, -, ha₀, ha₁⟩ :=
+    Smale.exists_smooth_open_curve_with_endpoint_germs S hA₀ hA₁ hU₀ hU₁ h0 h1 (Set.mem_univ _)
+      (Set.mem_univ _) γ
+  obtain ⟨T, hT, hi, -, ht₀, ht₁⟩ :=
+    Degree.LinearFramePaths.exists_smooth_invertible_frame_join basis hT₀ hT₁ hU₀ hU₁ h0 h1 hsign
+  have hTi (s : ℝ) : (T s).IsInvertible :=
+    ⟨(LinearEquiv.ofBijective (T s).toLinearMap (hi s)).toContinuousLinearEquiv, rfl⟩
+  exact
+    ⟨A, T, hA, hT, hTi, fun s => Smale.FrameField.isInvertible_shearedBlock (A s) (T s) (hTi s),
+      ha₀, ha₁, ht₀, ht₁⟩
+
+private theorem Degree.AxisCoordinates.exists_smooth_sheared_frame_join_at {V ι : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℝ V] [FiniteDimensional ℝ V] [Finite ι] [Nontrivial ι]
+    (basis : Module.Basis ι ℝ V) {p q : ℝ} (hpq : p < q) {A₀ A₁ : ℝ → (V →L[ℝ] ℝ)}
+    {T₀ T₁ : ℝ → (V →L[ℝ] V)} {U₀ U₁ : Set ℝ} (hA₀ : ContDiffOn ℝ ∞ A₀ U₀)
+    (hA₁ : ContDiffOn ℝ ∞ A₁ U₁) (hT₀ : ContDiffOn ℝ ∞ T₀ U₀) (hT₁ : ContDiffOn ℝ ∞ T₁ U₁)
+    (hU₀ : IsOpen U₀) (hU₁ : IsOpen U₁) (hp : p ∈ U₀) (hq : q ∈ U₁)
+    (hsign : 0 < (T₀ p).toLinearMap.det * (T₁ q).toLinearMap.det) :
+    ∃ A : ℝ → (V →L[ℝ] ℝ),
+      ∃ T : ℝ → (V →L[ℝ] V),
+        ContDiff ℝ ∞ A ∧
+          ContDiff ℝ ∞ T ∧
+            (∀ s, (T s).IsInvertible) ∧
+              (∀ s, (Smale.FrameField.shearedBlock (A s) (T s)).IsInvertible) ∧
+                (A =ᶠ[𝓝 p] A₀) ∧ (A =ᶠ[𝓝 q] A₁) ∧ (T =ᶠ[𝓝 p] T₀) ∧ (T =ᶠ[𝓝 q] T₁) := by
+  let ξ : ℝ → ℝ := fun t => p + (q - p) * t
+  let ζ : ℝ → ℝ := fun s => (s - p) / (q - p)
+  have hn : q - p ≠ 0 := ne_of_gt (sub_pos.mpr hpq)
+  have hξ : ContDiff ℝ ∞ ξ := by dsimp [ξ]; fun_prop
+  have hζ : ContDiff ℝ ∞ ζ := by dsimp [ζ]; fun_prop
+  have hξ0 : ξ 0 = p := by simp [ξ]
+  have hξ1 : ξ 1 = q := by simp [ξ]
+  have hζp : ζ p = 0 := by simp [ζ]
+  have hζq : ζ q = 1 := by simp [ζ, hn]
+  have hξζ (s : ℝ) : ξ (ζ s) = s := by
+    dsimp [ξ, ζ]
+    field_simp
+    ring
+  have h0 : (0 : ℝ) ∈ ξ ⁻¹' U₀ := by simpa only [Set.mem_preimage, hξ0] using hp
+  have h1 : (1 : ℝ) ∈ ξ ⁻¹' U₁ := by simpa only [Set.mem_preimage, hξ1] using hq
+  have hsgn : 0 < ((T₀ ∘ ξ) 0).toLinearMap.det * ((T₁ ∘ ξ) 1).toLinearMap.det := by
+    simpa only [Function.comp_apply, hξ0, hξ1] using hsign
+  obtain ⟨A, T, hA, hT, hi, hb, ha₀, ha₁, ht₀, ht₁⟩ :=
+    exists_smooth_sheared_frame_join basis (hA₀.comp hξ.contDiffOn (fun _ hs => hs))
+      (hA₁.comp hξ.contDiffOn (fun _ hs => hs)) (hT₀.comp hξ.contDiffOn (fun _ hs => hs))
+      (hT₁.comp hξ.contDiffOn (fun _ hs => hs)) (hU₀.preimage hξ.continuous)
+      (hU₁.preimage hξ.continuous) h0 h1 hsgn
+  have hζ0 : Filter.Tendsto ζ (𝓝 p) (𝓝 0) := by
+    simpa only [hζp] using hζ.continuous.continuousAt.tendsto (x := p)
+  have hζ1 : Filter.Tendsto ζ (𝓝 q) (𝓝 1) := by
+    simpa only [hζq] using hζ.continuous.continuousAt.tendsto (x := q)
+  refine
+    ⟨A ∘ ζ, T ∘ ζ, hA.comp hζ, hT.comp hζ, fun s => hi (ζ s), fun s => hb (ζ s), ?_, ?_, ?_, ?_⟩
+  · filter_upwards [hζ0 ha₀] with s hs
+    exact hs.trans (congrArg A₀ (hξζ s))
+  · filter_upwards [hζ1 ha₁] with s hs
+    exact hs.trans (congrArg A₁ (hξζ s))
+  · filter_upwards [hζ0 ht₀] with s hs
+    exact hs.trans (congrArg T₀ (hξζ s))
+  · filter_upwards [hζ1 ht₁] with s hs
+    exact hs.trans (congrArg T₁ (hξζ s))
+
+private theorem
+    Degree.AxisCoordinates.exists_flat_local_correction {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    {H R : E → F} {K U : Set E} {x : E} (hH : ContDiff ℝ ∞ H) (hR : ContDiffOn ℝ ∞ R U)
+    (hU : IsOpen U) (hx : x ∈ U) (hvalue : ∀ y ∈ K ∩ U, R y = H y)
+    (hderiv : ∀ y ∈ K ∩ U, fderiv ℝ R y = fderiv ℝ H y) :
+    ∃ G : E → F,
+      ContDiff ℝ ∞ G ∧
+        (G =ᶠ[𝓝 x] R) ∧
+          (∀ y ∉ U, G =ᶠ[𝓝 y] H) ∧ Set.EqOn G H K ∧ Set.EqOn (fderiv ℝ G) (fderiv ℝ H) K := by
+  obtain ⟨β, hβ, -, hsupp, hone, -⟩ :=
+    Smale.exists_compact_smooth_cutoff (isCompact_singleton : IsCompact ({ x } : Set E)) hU
+      (Set.singleton_subset_iff.mpr hx)
+  let G : E → F := fun y => H y + β y • (R y - H y)
+  have hoff (y : E) (hy : y ∉ tsupport β) : G =ᶠ[𝓝 y] H := by
+    filter_upwards [notMem_tsupport_iff_eventuallyEq.mp hy] with z hz
+    simp only [G, hz, Pi.zero_apply, zero_smul, add_zero]
+  have hG : ContDiff ℝ ∞ G := by
+    rw [contDiff_iff_contDiffAt]
+    intro y
+    by_cases hy : y ∈ tsupport β
+    · exact
+        hH.contDiffAt.add
+          (hβ.contDiffAt.smul ((hR.contDiffAt (hU.mem_nhds (hsupp hy))).sub hH.contDiffAt))
+    · exact hH.contDiffAt.congr_of_eventuallyEq (hoff y hy)
+  have hGeq (y : E) (hy : y ∈ K) : G y = H y := by
+    by_cases hb : y ∈ tsupport β
+    · simp only [G, hvalue y ⟨hy, hsupp hb⟩, sub_self, smul_zero, add_zero]
+    · exact (hoff y hb).eq_of_nhds
+  refine ⟨G, hG, ?_, fun y hy => hoff y (fun h => hy (hsupp h)), hGeq, ?_⟩
+  · have hone' : ∀ᶠ y in 𝓝 x, β y = 1 := by simpa only [nhdsSet_singleton] using hone
+    filter_upwards [hone'] with y hy
+    simp only [G, hy, one_smul]
+    abel
+  · intro y hy
+    by_cases hb : y ∈ tsupport β
+    · have hr := (hR.contDiffAt (hU.mem_nhds (hsupp hb))).differentiableAt (by simp)
+      have hh := hH.differentiable (by simp) y
+      have hd : HasFDerivAt (fun z => R z - H z) (0 : E →L[ℝ] F) y := by
+        simpa only [hderiv y ⟨hy, hsupp hb⟩, sub_self, Pi.sub_def] using
+          hr.hasFDerivAt.sub hh.hasFDerivAt
+      have hc : HasFDerivAt (fun z => β z • (R z - H z)) (0 : E →L[ℝ] F) y := by
+        simpa only [hvalue y ⟨hy, hsupp hb⟩, sub_self, smul_zero,
+          ContinuousLinearMap.smulRight_zero, add_zero, Pi.smul_def'] using
+          (hβ.differentiable (by simp) y).hasFDerivAt.smul hd
+      simpa only [add_zero, Pi.add_def, G] using (hh.hasFDerivAt.add hc).fderiv
+    · exact (hoff y hb).fderiv_eq
+
+private theorem
+    Degree.AxisCoordinates.exists_axis_germ_correction {V F : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [FiniteDimensional ℝ V] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    {H R₀ R₁ : (ℝ × V) → F} {U₀ U₁ : Set (ℝ × V)} {p q : ℝ} (hpq : p < q) (hH : ContDiff ℝ ∞ H)
+    (hR₀ : ContDiffOn ℝ ∞ R₀ U₀) (hR₁ : ContDiffOn ℝ ∞ R₁ U₁) (hU₀ : IsOpen U₀) (hU₁ : IsOpen U₁)
+    (h0 : (p, (0 : V)) ∈ U₀) (h1 : (q, (0 : V)) ∈ U₁)
+    (hv₀ : (fun s : ℝ => R₀ (s, 0)) =ᶠ[𝓝 p] (fun s => H (s, 0)))
+    (hv₁ : (fun s : ℝ => R₁ (s, 0)) =ᶠ[𝓝 q] (fun s => H (s, 0)))
+    (hd₀ : (fun s : ℝ => fderiv ℝ R₀ (s, 0)) =ᶠ[𝓝 p] (fun s => fderiv ℝ H (s, 0)))
+    (hd₁ : (fun s : ℝ => fderiv ℝ R₁ (s, 0)) =ᶠ[𝓝 q] (fun s => fderiv ℝ H (s, 0))) :
+    ∃ G : (ℝ × V) → F,
+      ContDiff ℝ ∞ G ∧
+        (∀ s : ℝ, G (s, 0) = H (s, 0)) ∧
+          (∀ s : ℝ, fderiv ℝ G (s, 0) = fderiv ℝ H (s, 0)) ∧
+            (G =ᶠ[𝓝 (p, (0 : V))] R₀) ∧ (G =ᶠ[𝓝 (q, (0 : V))] R₁) := by
+  obtain ⟨I₀, hI₀sub, hI₀, h0I⟩ := mem_nhds_iff.mp (hv₀.and hd₀)
+  obtain ⟨I₁, hI₁sub, hI₁, h1I⟩ := mem_nhds_iff.mp (hv₁.and hd₁)
+  let W₀ := U₀ ∩ Prod.fst ⁻¹' (I₀ ∩ Set.Iio ((p + q) / 2))
+  let W₁ := U₁ ∩ Prod.fst ⁻¹' (I₁ ∩ Set.Ioi ((p + q) / 2))
+  have hW₀ : IsOpen W₀ := hU₀.inter ((hI₀.inter isOpen_Iio).preimage continuous_fst)
+  have hW₁ : IsOpen W₁ := hU₁.inter ((hI₁.inter isOpen_Ioi).preimage continuous_fst)
+  have h0W : (p, (0 : V)) ∈ W₀ := ⟨h0, h0I, by change p < (p + q) / 2; linarith⟩
+  have h1W : (q, (0 : V)) ∈ W₁ := ⟨h1, h1I, by change (p + q) / 2 < q; linarith⟩
+  let K : Set (ℝ × V) := Set.univ ×ˢ {0}
+  have hv0 (y : ℝ × V) (hy : y ∈ K ∩ W₀) : R₀ y = H y := by
+    have hz : y.2 = 0 := hy.1.2
+    have hh := (hI₀sub hy.2.2.1).1
+    exact (show (y.1, (0 : V)) = y from Prod.ext rfl hz.symm) ▸ hh
+  have hd0 (y : ℝ × V) (hy : y ∈ K ∩ W₀) : fderiv ℝ R₀ y = fderiv ℝ H y := by
+    have hz : y.2 = 0 := hy.1.2
+    have hh := (hI₀sub hy.2.2.1).2
+    exact (show (y.1, (0 : V)) = y from Prod.ext rfl hz.symm) ▸ hh
+  obtain ⟨G₀, hG₀, hg₀, -, hvG₀, hdG₀⟩ :=
+    exists_flat_local_correction hH (hR₀.mono Set.inter_subset_left) hW₀ h0W hv0 hd0
+  have hv1 (y : ℝ × V) (hy : y ∈ K ∩ W₁) : R₁ y = G₀ y := by
+    rw [hvG₀ hy.1]
+    have hz : y.2 = 0 := hy.1.2
+    have hh := (hI₁sub hy.2.2.1).1
+    exact (show (y.1, (0 : V)) = y from Prod.ext rfl hz.symm) ▸ hh
+  have hd1 (y : ℝ × V) (hy : y ∈ K ∩ W₁) : fderiv ℝ R₁ y = fderiv ℝ G₀ y := by
+    rw [hdG₀ hy.1]
+    have hz : y.2 = 0 := hy.1.2
+    have hh := (hI₁sub hy.2.2.1).2
+    exact (show (y.1, (0 : V)) = y from Prod.ext rfl hz.symm) ▸ hh
+  obtain ⟨G, hG, hg₁, hoff, hvG, hdG⟩ :=
+    exists_flat_local_correction hG₀ (hR₁.mono Set.inter_subset_left) hW₁ h1W hv1 hd1
+  have h0not : (p, (0 : V)) ∉ W₁ := by
+    intro hh
+    have hbad : (p + q) / 2 < p := hh.2.2
+    linarith
+  refine ⟨G, hG, ?_, ?_, (hoff _ h0not).trans hg₀, hg₁⟩
+  · intro s
+    have hs : (s, (0 : V)) ∈ K := ⟨Set.mem_univ s, rfl⟩
+    exact (hvG hs).trans (hvG₀ hs)
+  · intro s
+    have hs : (s, (0 : V)) ∈ K := ⟨Set.mem_univ s, rfl⟩
+    exact (hdG hs).trans (hdG₀ hs)
+
+private theorem
+    Smale.FrameField.exists_sheared_tubular_chart {X Z F E M : Type*} [NormedAddCommGroup X]
+    [NormedSpace ℝ X] [FiniteDimensional ℝ X] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [FiniteDimensional ℝ Z] [NormedAddCommGroup F] [NormedSpace ℝ F] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, X × F) 𝓘(ℝ, E) (X × F) M ∞) {K U : Set X} (hK : IsCompact K)
+    (hU : IsOpen U) (hKU : K ⊆ U) (hzero : K ×ˢ {(0 : F)} ⊆ Ψ.source) {A : X → (Z →L[ℝ] X)}
+    {T : X → (Z →L[ℝ] F)} (hA : ContDiffOn ℝ ∞ A U) (hT : ContDiffOn ℝ ∞ T U)
+    (hi : ∀ x ∈ K, (T x).IsInvertible) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∃ Φ : PartialDiffeomorph 𝓘(ℝ, X × Z) 𝓘(ℝ, E) (X × Z) M ∞,
+          K ×ˢ Metric.closedBall (0 : Z) ε ⊆ Φ.source ∧
+            (∀ p, Φ p = Ψ (shearedMap A T p)) ∧
+              Φ.target ⊆ Ψ.target ∧
+                (∀ x ∈ K, (Ψ.symm ∘ Φ) =ᶠ[𝓝 (x, (0 : Z))] shearedMap A T) ∧
+                  ∀ x ∈ K, HasFDerivAt (Ψ.symm ∘ Φ) (shearedBlock (A x) (T x)) (x, 0) := by
+  obtain ⟨χ, hzeroχ, -, hχ⟩ := exists_sheared_frame_chart hK hU hKU hA hT hi
+  let Φ := χ.trans Ψ
+  have hzeroΦ : K ×ˢ {(0 : Z)} ⊆ Φ.source := by
+    rintro ⟨x, z⟩ ⟨hx, hz⟩
+    have hz0 : z = 0 := hz
+    subst z
+    refine ⟨hzeroχ ⟨hx, rfl⟩, ?_⟩
+    change χ (x, 0) ∈ Ψ.source
+    rw [hχ, shearedMap_zero]
+    exact hzero ⟨hx, rfl⟩
+  obtain ⟨ε, hε, hprod⟩ :=
+    Smale.DiskFraming.exists_pos_prod_closedBall_subset hK Φ.open_source hzeroΦ
+  have hgerm : ∀ x ∈ K, (Ψ.symm ∘ Φ) =ᶠ[𝓝 (x, (0 : Z))] shearedMap A T := by
+    intro x hx
+    filter_upwards [Φ.open_source.mem_nhds (hzeroΦ ⟨hx, rfl⟩)] with p hp
+    change Ψ.symm (Ψ (χ p)) = shearedMap A T p
+    have hpΨ : χ p ∈ Ψ.source := hp.2
+    exact (Ψ.left_inv' hpΨ).trans (congrFun hχ p)
+  refine ⟨ε, hε, Φ, hprod, ?_, fun _ hy => hy.1, hgerm, ?_⟩
+  · intro p
+    change Ψ (χ p) = Ψ (shearedMap A T p)
+    rw [hχ]
+  · intro x hx
+    apply (hgerm x hx).hasFDerivAt_iff.mpr
+    exact
+      hasFDerivAt_shearedMap_zero
+        ((hA.contDiffAt (hU.mem_nhds (hKU hx))).differentiableAt (by simp))
+        ((hT.contDiffAt (hU.mem_nhds (hKU hx))).differentiableAt (by simp))
+
+private theorem
+    Degree.AxisCoordinates.exists_native_axis_chart_with_endpoint_germs {V E M ι : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℝ V] [FiniteDimensional ℝ V] [Finite ι] [Nontrivial ι]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (basis : Module.Basis ι ℝ V) (Ψ Φ₀ Φ₁ : PartialDiffeomorph 𝓘(ℝ, ℝ × V) 𝓘(ℝ, E) (ℝ × V) M ∞)
+    {p q : ℝ} (hpq : p < q) {K : Set ℝ} (hK : IsCompact K) (hzero : K ×ˢ {(0 : V)} ⊆ Ψ.source)
+    (hΨ₀ : (p, (0 : V)) ∈ Ψ.source) (hΨ₁ : (q, (0 : V)) ∈ Ψ.source)
+    (hΦ₀ : (p, (0 : V)) ∈ Φ₀.source) (hΦ₁ : (q, (0 : V)) ∈ Φ₁.source)
+    (haxis₀ : (fun s : ℝ => Φ₀ (s, 0)) =ᶠ[𝓝 p] (fun s => Ψ (s, 0)))
+    (haxis₁ : (fun s : ℝ => Φ₁ (s, 0)) =ᶠ[𝓝 q] (fun s => Ψ (s, 0)))
+    (hsign :
+      0 <
+        (transverseBlock (fderiv ℝ (Ψ.symm ∘ Φ₀) (p, 0))).toLinearMap.det *
+          (transverseBlock (fderiv ℝ (Ψ.symm ∘ Φ₁) (q, 0))).toLinearMap.det) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∃ Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × V) 𝓘(ℝ, E) (ℝ × V) M ∞,
+          K ×ˢ Metric.closedBall (0 : V) ε ⊆ Φ.source ∧
+            Φ.target ⊆ Ψ.target ∧
+              (∀ s : ℝ, Φ (s, 0) = Ψ (s, 0)) ∧
+                ((Φ : (ℝ × V) → M) =ᶠ[𝓝 (p, (0 : V))] Φ₀) ∧
+                  ((Φ : (ℝ × V) → M) =ᶠ[𝓝 (q, (0 : V))] Φ₁) := by
+  let R₀ := Φ₀.trans Ψ.symm
+  let R₁ := Φ₁.trans Ψ.symm
+  obtain ⟨U₀, hU₀, h0U, hs₀, hx₀, ha₀, ht₀, -, hb₀⟩ :=
+    exists_native_axis_transition_data Φ₀ Ψ hΦ₀ hΨ₀ haxis₀
+  obtain ⟨U₁, hU₁, h1U, hs₁, hx₁, ha₁, ht₁, -, hb₁⟩ :=
+    exists_native_axis_transition_data Φ₁ Ψ hΦ₁ hΨ₁ haxis₁
+  obtain ⟨A, T, hA, hT, -, hinv, hA₀, hA₁, hT₀, hT₁⟩ :=
+    exists_smooth_sheared_frame_join_at basis hpq ha₀ ha₁ ht₀ ht₁ hU₀ hU₁ h0U h1U hsign
+  let H := Smale.FrameField.shearedMap A T
+  have hH : ContDiff ℝ ∞ H :=
+    (contDiff_fst.add ((hA.comp contDiff_fst).clm_apply contDiff_snd)).prodMk
+      ((hT.comp contDiff_fst).clm_apply contDiff_snd)
+  have hHd (s : ℝ) : fderiv ℝ H (s, (0 : V)) = Smale.FrameField.shearedBlock (A s) (T s) :=
+    (Smale.FrameField.hasFDerivAt_shearedMap_zero (hA.differentiable (by simp) s)
+        (hT.differentiable (by simp) s)).fderiv
+  have hv₀ : (fun s : ℝ => R₀ (s, (0 : V))) =ᶠ[𝓝 p] (fun s => H (s, 0)) := by
+    filter_upwards [hU₀.mem_nhds h0U] with s hs
+    exact (hx₀ s hs).trans (Smale.FrameField.shearedMap_zero A T s).symm
+  have hv₁ : (fun s : ℝ => R₁ (s, (0 : V))) =ᶠ[𝓝 q] (fun s => H (s, 0)) := by
+    filter_upwards [hU₁.mem_nhds h1U] with s hs
+    exact (hx₁ s hs).trans (Smale.FrameField.shearedMap_zero A T s).symm
+  have hd₀ : (fun s : ℝ => fderiv ℝ R₀ (s, (0 : V))) =ᶠ[𝓝 p] (fun s => fderiv ℝ H (s, 0)) := by
+    filter_upwards [hU₀.mem_nhds h0U, hA₀, hT₀] with s hs ha ht
+    change fderiv ℝ (Ψ.symm ∘ Φ₀) (s, 0) = _
+    rw [hb₀ s hs, hHd s, ha, ht]
+  have hd₁ : (fun s : ℝ => fderiv ℝ R₁ (s, (0 : V))) =ᶠ[𝓝 q] (fun s => fderiv ℝ H (s, 0)) := by
+    filter_upwards [hU₁.mem_nhds h1U, hA₁, hT₁] with s hs ha ht
+    change fderiv ℝ (Ψ.symm ∘ Φ₁) (s, 0) = _
+    rw [hb₁ s hs, hHd s, ha, ht]
+  obtain ⟨G, hG, hvG, hdG, hg₀, hg₁⟩ :=
+    exists_axis_germ_correction hpq hH R₀.contMDiffOn_toFun.contDiffOn
+      R₁.contMDiffOn_toFun.contDiffOn R₀.open_source R₁.open_source (hs₀ p h0U) (hs₁ q h1U) hv₀
+      hv₁ hd₀ hd₁
+  have hGaxis (s : ℝ) : G (s, (0 : V)) = (s, 0) :=
+    (hvG s).trans (Smale.FrameField.shearedMap_zero A T s)
+  have hGi : Set.InjOn G (K ×ˢ {(0 : V)}) := by
+    rintro ⟨s, z⟩ ⟨hs, hz⟩ ⟨t, w⟩ ⟨ht, hw⟩ heq
+    have hz0 : z = 0 := hz
+    have hw0 : w = 0 := hw
+    subst z
+    subst w
+    simpa only [hGaxis] using heq
+  have hGl : ∀ p ∈ K ×ˢ {(0 : V)}, IsLocalDiffeomorphAt 𝓘(ℝ, ℝ × V) 𝓘(ℝ, ℝ × V) ∞ G p := by
+    rintro ⟨s, z⟩ ⟨hs, hz⟩
+    have hz0 : z = 0 := hz
+    subst z
+    apply
+      Smale.isLocalDiffeomorphAt_of_contMDiffOn isOpen_univ (Set.mem_univ _)
+        hG.contMDiff.contMDiffOn
+    rw [mfderiv_eq_fderiv, hdG s, hHd s]
+    exact hinv s
+  have hGO : K ×ˢ {(0 : V)} ⊆ G ⁻¹' Ψ.source := by
+    rintro ⟨s, z⟩ ⟨hs, hz⟩
+    have hz0 : z = 0 := hz
+    subst z
+    change G (s, 0) ∈ Ψ.source
+    rw [hGaxis]
+    exact hzero ⟨hs, rfl⟩
+  obtain ⟨χ, hχzero, hχsub, hχ⟩ :=
+    Smale.exists_partialDiffeomorph_near_compact (hK.prod isCompact_singleton) hGi hGl
+      (Ψ.open_source.preimage hG.continuous) hGO
+  let Φ := χ.trans Ψ
+  have hΦzero : K ×ˢ {(0 : V)} ⊆ Φ.source := by
+    intro p hp
+    refine ⟨hχzero hp, ?_⟩
+    change χ p ∈ Ψ.source
+    rw [hχ]
+    exact hχsub (hχzero hp)
+  obtain ⟨ε, hε, hprod⟩ :=
+    Smale.DiskFraming.exists_pos_prod_closedBall_subset hK Φ.open_source hΦzero
+  have hformula (p : ℝ × V) : Φ p = Ψ (G p) := by
+    change Ψ (χ p) = Ψ (G p)
+    rw [hχ]
+  refine ⟨ε, hε, Φ, hprod, fun _ hy => hy.1, ?_, ?_, ?_⟩
+  · intro s
+    rw [hformula, hGaxis]
+  · filter_upwards [hg₀, R₀.open_source.mem_nhds (hs₀ p h0U)] with p hp hs
+    rw [hformula, hp]
+    exact Ψ.right_inv' hs.2
+  · filter_upwards [hg₁, R₁.open_source.mem_nhds (hs₁ q h1U)] with p hp hs
+    rw [hformula, hp]
+    exact Ψ.right_inv' hs.2
+
+private def
+    MorseCancel.linearTransverseChart {V E M : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (C : V ≃L[ℝ] V) (Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × V) 𝓘(ℝ, E) (ℝ × V) M ∞) :
+    PartialDiffeomorph 𝓘(ℝ, ℝ × V) 𝓘(ℝ, E) (ℝ × V) M ∞ :=
+  ((ContinuousLinearEquiv.refl ℝ ℝ).prodCongr C).toDiffeomorph.toPartialDiffeomorph.trans Φ
+
+private theorem MorseCancel.linearTransverseChart_axis {V E M : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] (C : V ≃L[ℝ] V) (Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × V) 𝓘(ℝ, E) (ℝ × V) M ∞)
+    (t : ℝ) : linearTransverseChart C Φ (t, 0) = Φ (t, 0) := by
+  change Φ (t, C 0) = Φ (t, 0)
+  rw [map_zero]
+
+private theorem MorseCancel.linearTransverseChart_axis_source {V E M : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] (C : V ≃L[ℝ] V) (Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × V) 𝓘(ℝ, E) (ℝ × V) M ∞)
+    (t : ℝ) : (t, (0 : V)) ∈ (linearTransverseChart C Φ).source ↔ (t, (0 : V)) ∈ Φ.source := by
+  change (t, (0 : V)) ∈ Set.univ ∧ (t, C 0) ∈ Φ.source ↔ _
+  simp only [Set.mem_univ, map_zero, true_and]
+
+private theorem MorseCancel.transverseBlock_comp_linear {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] (C : V ≃L[ℝ] V) (L : (ℝ × V) →L[ℝ] (ℝ × V)) :
+    Degree.AxisCoordinates.transverseBlock
+        (L.comp ((ContinuousLinearEquiv.refl ℝ ℝ).prodCongr C).toContinuousLinearMap) =
+      (Degree.AxisCoordinates.transverseBlock L).comp C.toContinuousLinearMap := by
+  ext z
+  rfl
+
+private theorem
+    MorseCancel.det_transition_linearTransverseChart {V E M : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] (C : V ≃L[ℝ] V) (Φ Ψ : PartialDiffeomorph 𝓘(ℝ, ℝ × V) 𝓘(ℝ, E) (ℝ × V) M ∞)
+    {t : ℝ} (ht : (t, (0 : V)) ∈ (Φ.trans Ψ.symm).source) :
+    (Degree.AxisCoordinates.transverseBlock
+          (fderiv ℝ (Ψ.symm ∘ linearTransverseChart C Φ) (t, 0))).toLinearMap.det =
+      (Degree.AxisCoordinates.transverseBlock (fderiv ℝ (Ψ.symm ∘ Φ) (t, 0))).toLinearMap.det *
+        C.toLinearMap.det := by
+  let P := (ContinuousLinearEquiv.refl ℝ ℝ).prodCongr C
+  have hP (s : ℝ) : P (s, (0 : V)) = (s, 0) := by
+    change (s, C 0) = (s, 0)
+    rw [map_zero]
+  have hr : DifferentiableAt ℝ (Ψ.symm ∘ Φ) (t, (0 : V)) :=
+    ((Φ.trans Ψ.symm).contMDiffOn_toFun.contDiffOn.contDiffAt
+          ((Φ.trans Ψ.symm).open_source.mem_nhds ht)).differentiableAt
+      (by simp)
+  have hre : DifferentiableAt ℝ (Ψ.symm ∘ Φ) (P (t, (0 : V))) := by
+    rw [hP]
+    exact hr
+  have heq : (Ψ.symm ∘ linearTransverseChart C Φ) = (Ψ.symm ∘ Φ) ∘ P := rfl
+  rw [heq, fderiv_comp _ hre P.differentiableAt, P.fderiv, hP, transverseBlock_comp_linear]
+  exact LinearMap.det_comp _ _
+
+private theorem MorseCancel.det_ne_zero_of_isInvertible {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] (T : V →L[ℝ] V) (hT : T.IsInvertible) : T.toLinearMap.det ≠ 0 := by
+  obtain ⟨e, he⟩ := hT
+  rw [← he]
+  exact e.toLinearEquiv.isUnit_det'.ne_zero
+
+private theorem MorseCancel.exists_compatible_sheet_endpoint_orientation {A B E M ι : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [FiniteDimensional ℝ B] [Finite ι] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] (basis : Module.Basis ι ℝ B) (i : ι)
+    (Ψ Φ₀ Φ₁ : PartialDiffeomorph 𝓘(ℝ, ℝ × (A × B)) 𝓘(ℝ, E) (ℝ × (A × B)) M ∞) {p q : ℝ}
+    (hΨ₀ : (p, (0 : A × B)) ∈ Ψ.source) (hΨ₁ : (q, (0 : A × B)) ∈ Ψ.source)
+    (hΦ₀ : (p, (0 : A × B)) ∈ Φ₀.source) (hΦ₁ : (q, (0 : A × B)) ∈ Φ₁.source)
+    (haxis₀ : (fun s : ℝ => Φ₀ (s, 0)) =ᶠ[𝓝 p] (fun s => Ψ (s, 0)))
+    (haxis₁ : (fun s : ℝ => Φ₁ (s, 0)) =ᶠ[𝓝 q] (fun s => Ψ (s, 0))) :
+    ∃ R : B ≃L[ℝ] B,
+      0 <
+        (Degree.AxisCoordinates.transverseBlock (fderiv ℝ (Ψ.symm ∘ Φ₀) (p, 0))).toLinearMap.det *
+          (Degree.AxisCoordinates.transverseBlock
+              (fderiv ℝ
+                (Ψ.symm ∘ linearTransverseChart ((ContinuousLinearEquiv.refl ℝ A).prodCongr R) Φ₁)
+                (q, 0))).toLinearMap.det := by
+  classical
+  let := Fintype.ofFinite ι
+  obtain ⟨U₀, -, hp, -, -, -, -, hi₀, -⟩ :=
+    Degree.AxisCoordinates.exists_native_axis_transition_data Φ₀ Ψ hΦ₀ hΨ₀ haxis₀
+  obtain ⟨U₁, -, hq, hs₁, -, -, -, hi₁, -⟩ :=
+    Degree.AxisCoordinates.exists_native_axis_transition_data Φ₁ Ψ hΦ₁ hΨ₁ haxis₁
+  let d₀ :=
+    (Degree.AxisCoordinates.transverseBlock (fderiv ℝ (Ψ.symm ∘ Φ₀) (p, 0))).toLinearMap.det
+  let d₁ :=
+    (Degree.AxisCoordinates.transverseBlock (fderiv ℝ (Ψ.symm ∘ Φ₁) (q, 0))).toLinearMap.det
+  have h₀ : d₀ ≠ 0 := det_ne_zero_of_isInvertible _ (hi₀ p hp)
+  have h₁ : d₁ ≠ 0 := det_ne_zero_of_isInvertible _ (hi₁ q hq)
+  obtain ⟨R, hR⟩ :=
+    Degree.SupportedGerms.exists_linearEquiv_with_det basis i (inv_ne_zero (mul_ne_zero h₀ h₁))
+  refine ⟨R, ?_⟩
+  rw [det_transition_linearTransverseChart _ Φ₁ Ψ (hs₁ q hq)]
+  have hdet : ((ContinuousLinearEquiv.refl ℝ A).prodCongr R).toLinearMap.det = (d₀ * d₁)⁻¹ := by
+    change ((LinearMap.id : A →ₗ[ℝ] A).prodMap R.toLinearMap).det = _
+    rw [LinearMap.det_prodMap, LinearMap.det_id, one_mul, hR]
+  rw [hdet]
+  change 0 < d₀ * (d₁ * (d₀ * d₁)⁻¹)
+  have hone : d₀ * (d₁ * (d₀ * d₁)⁻¹) = 1 := by
+    rw [← mul_assoc, mul_inv_cancel₀ (mul_ne_zero h₀ h₁)]
+  rw [hone]
+  exact zero_lt_one
+
+private theorem
+    MorseCancel.exists_sheet_arc_tube {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [T2Space M] [CompactSpace M] {a : ℝ → M} (ha : ContMDiff 𝓘(ℝ, ℝ) 𝓘(ℝ, E) ∞ a)
+    (hinj : Set.InjOn a (Set.Icc (0 : ℝ) 1))
+    (hi : ∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Injective (mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, E) a t))
+    (hdim : Module.finrank ℝ E = 5)
+    (Φ₀ Φ₁ :
+      PartialDiffeomorph 𝓘(ℝ, (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))))
+        𝓘(ℝ, E) (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) M ∞)
+    (hΦ₀ : (0 : (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))) ∈ Φ₀.source)
+    (hΦ₁ : ((1 : ℝ), (0 : ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))) ∈ Φ₁.source)
+    (hleft : a =ᶠ[𝓝 (0 : ℝ)] fun t => Φ₀ (t, 0)) (hright : a =ᶠ[𝓝 (1 : ℝ)] fun t => Φ₁ (t, 0))
+    {O : Set M} (hO : IsOpen O) (haO : Set.MapsTo a (Set.Icc (0 : ℝ) 1) O) :
+    ∃ (R : (EuclideanSpace ℝ (Fin 2)) ≃L[ℝ] (EuclideanSpace ℝ (Fin 2))) (ε : ℝ),
+      0 < ε ∧
+        ∃ Φ :
+          PartialDiffeomorph 𝓘(ℝ, (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))))
+            𝓘(ℝ, E) (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) M ∞,
+          Set.Icc (0 : ℝ) 1 ×ˢ
+                Metric.closedBall (0 : ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))
+                  ε ⊆
+              Φ.source ∧
+            (∀ t : ℝ, Φ (t, 0) = a t) ∧
+              ((Φ :
+                    (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) →
+                      M) =ᶠ[𝓝
+                    (0 : (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))))]
+                  Φ₀) ∧
+                ((Φ :
+                      (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) →
+                        M) =ᶠ[𝓝
+                      ((1 : ℝ), (0 : ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))))]
+                    linearTransverseChart
+                      ((ContinuousLinearEquiv.refl ℝ (EuclideanSpace ℝ (Fin 2))).prodCongr R)
+                      Φ₁) ∧
+                  Φ.target ⊆ O := by
+  have h0K : (0 : ℝ) ∈ Set.Icc (0 : ℝ) 1 := ⟨le_rfl, zero_le_one⟩
+  have h1K : (1 : ℝ) ∈ Set.Icc (0 : ℝ) 1 := ⟨zero_le_one, le_rfl⟩
+  obtain ⟨r, hr, Ξ, hΞprod, hΞaxis, hΞO⟩ :=
+    Smale.exists_tubularNeighborhood_in_open_of_embedded_starConvex_with_global_zero ha
+      CompactIccSpace.isCompact_Icc h0K ((convex_Icc (0 : ℝ) 1).starConvex h0K) hinj hi 4
+      (by rw [Module.finrank_self, hdim]) hO haO
+  let L :
+    ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))) ≃L[ℝ] EuclideanSpace ℝ (Fin 4) :=
+    ContinuousLinearEquiv.ofFinrankEq
+      (by simp only [Module.finrank_prod, finrank_euclideanSpace_fin])
+  let P := ((ContinuousLinearEquiv.refl ℝ ℝ).prodCongr L).toDiffeomorph
+  let Ψ := P.toPartialDiffeomorph.trans Ξ
+  have hΨaxis (t : ℝ) : Ψ (t, 0) = a t := by
+    change Ξ (t, L 0) = a t
+    rw [map_zero, hΞaxis]
+  have hzero :
+    Set.Icc (0 : ℝ) 1 ×ˢ {(0 : ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))} ⊆
+      Ψ.source := by
+    rintro ⟨t, z⟩ ⟨ht, hz⟩
+    have hz0 : z = 0 := hz
+    subst z
+    change
+      (t, (0 : ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))) ∈ Set.univ ∧
+        (t, L 0) ∈ Ξ.source
+    rw [map_zero]
+    exact ⟨Set.mem_univ _, hΞprod ⟨ht, Metric.mem_closedBall_self hr.le⟩⟩
+  have hΨ₀ : (0 : (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))) ∈ Ψ.source :=
+    hzero ⟨h0K, rfl⟩
+  have hΨ₁ :
+    ((1 : ℝ), (0 : ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))) ∈ Ψ.source :=
+    hzero ⟨h1K, rfl⟩
+  have haxis₀ : (fun t : ℝ => Φ₀ (t, 0)) =ᶠ[𝓝 (0 : ℝ)] fun t => Ψ (t, 0) := by
+    filter_upwards [hleft] with t ht
+    exact ht.symm.trans (hΨaxis t).symm
+  have haxis₁ : (fun t : ℝ => Φ₁ (t, 0)) =ᶠ[𝓝 (1 : ℝ)] fun t => Ψ (t, 0) := by
+    filter_upwards [hright] with t ht
+    exact ht.symm.trans (hΨaxis t).symm
+  obtain ⟨R, hsign⟩ :=
+    exists_compatible_sheet_endpoint_orientation (Module.finBasis ℝ (EuclideanSpace ℝ (Fin 2)))
+      ⟨0, by simp only [finrank_euclideanSpace_fin]; norm_num⟩ Ψ Φ₀ Φ₁ hΨ₀ hΨ₁ hΦ₀ hΦ₁ haxis₀
+      haxis₁
+  let C := (ContinuousLinearEquiv.refl ℝ (EuclideanSpace ℝ (Fin 2))).prodCongr R
+  let Φ₂ := linearTransverseChart C Φ₁
+  have hΦ₂ :
+    ((1 : ℝ), (0 : ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))) ∈ Φ₂.source :=
+    (linearTransverseChart_axis_source C Φ₁ 1).mpr hΦ₁
+  have haxis₂ : (fun t : ℝ => Φ₂ (t, 0)) =ᶠ[𝓝 (1 : ℝ)] fun t => Ψ (t, 0) := by
+    filter_upwards [haxis₁] with t ht
+    exact (linearTransverseChart_axis C Φ₁ t).trans ht
+  let _ :
+    Nontrivial
+      (Fin (Module.finrank ℝ ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))) :=
+    Fin.nontrivial_iff_two_le.mpr
+      (by
+        simp only [Module.finrank_prod, finrank_euclideanSpace_fin]
+        norm_num)
+  obtain ⟨ε, hε, Φ, hprod, htarget, haxis, hgl, hgr⟩ :=
+    Degree.AxisCoordinates.exists_native_axis_chart_with_endpoint_germs
+      (Module.finBasis ℝ ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) Ψ Φ₀ Φ₂
+      zero_lt_one CompactIccSpace.isCompact_Icc hzero hΨ₀ hΨ₁ hΦ₀ hΦ₂ haxis₀ haxis₂ hsign
+  exact
+    ⟨R, ε, hε, Φ, hprod, fun t => (haxis t).trans (hΨaxis t), hgl, hgr, fun z hz =>
+      hΞO (htarget hz).1⟩
+
+private theorem
+    MorseCancel.exists_open_tube_sheet_recognition {V E H M : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ E H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × V) J (ℝ × V) M ∞) {K : Set ℝ}
+    (hKsource : K ×ˢ {(0 : V)} ⊆ Φ.source) {S : Set M} (hS : IsClosed S) (p : ℝ) (N : Set V)
+    (hlocal : ∀ᶠ z in 𝓝 (p, (0 : V)), Φ z ∈ S ↔ z.1 = p ∧ z.2 ∈ N)
+    (haway : ∀ t ∈ K, t ≠ p → Φ (t, 0) ∉ S) :
+    ∃ W : Set (ℝ × V),
+      IsOpen W ∧ K ×ˢ {(0 : V)} ⊆ W ∧ W ⊆ Φ.source ∧ ∀ z ∈ W, Φ z ∈ S ↔ z.1 = p ∧ z.2 ∈ N := by
+  obtain ⟨U, hUgood, hU, hpU⟩ := _root_.mem_nhds_iff.mp hlocal
+  let A : Set (ℝ × V) := (Φ.source ∩ Φ ⁻¹' Sᶜ) ∩ {z | z.1 ≠ p}
+  have hA : IsOpen A :=
+    (Φ.contMDiffOn_toFun.continuousOn.isOpen_inter_preimage Φ.open_source hS.isOpen_compl).inter
+      (isOpen_ne_fun continuous_fst continuous_const)
+  let W := Φ.source ∩ (U ∪ A)
+  refine ⟨W, Φ.open_source.inter (hU.union hA), ?_, Set.inter_subset_left, ?_⟩
+  · rintro ⟨t, z⟩ ⟨ht, hz⟩
+    have hz0 : z = 0 := hz
+    subst z
+    refine ⟨hKsource ⟨ht, rfl⟩, ?_⟩
+    by_cases htp : t = p
+    · subst t
+      exact Or.inl hpU
+    · exact Or.inr ⟨⟨hKsource ⟨ht, rfl⟩, haway t ht htp⟩, htp⟩
+  · intro z hz
+    rcases hz.2 with hzU | hzA
+    · exact hUgood hzU
+    · constructor
+      · intro h
+        exact (hzA.1.2 h).elim
+      · rintro ⟨h, -⟩
+        exact (hzA.2 h).elim
+
+private theorem
+    MorseCancel.exists_clean_axis_tube_restriction {V E H M : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ E H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × V) J (ℝ × V) M ∞) {K : Set ℝ} (hK : IsCompact K)
+    (hKsource : K ×ˢ {(0 : V)} ⊆ Φ.source) {S T : Set M} (hS : IsClosed S) (hT : IsClosed T)
+    (p q : ℝ) (N P : Set V) (hlocalS : ∀ᶠ z in 𝓝 (p, (0 : V)), Φ z ∈ S ↔ z.1 = p ∧ z.2 ∈ N)
+    (hlocalT : ∀ᶠ z in 𝓝 (q, (0 : V)), Φ z ∈ T ↔ z.1 = q ∧ z.2 ∈ P)
+    (hawayS : ∀ t ∈ K, t ≠ p → Φ (t, 0) ∉ S) (hawayT : ∀ t ∈ K, t ≠ q → Φ (t, 0) ∉ T) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∃ Ψ : PartialDiffeomorph 𝓘(ℝ, ℝ × V) J (ℝ × V) M ∞,
+          K ×ˢ Metric.closedBall (0 : V) ε ⊆ Ψ.source ∧
+            (∀ z, Ψ z = Φ z) ∧
+              Ψ.target ⊆ Φ.target ∧
+                (∀ z ∈ Ψ.source, Ψ z ∈ S ↔ z.1 = p ∧ z.2 ∈ N) ∧
+                  (∀ z ∈ Ψ.source, Ψ z ∈ T ↔ z.1 = q ∧ z.2 ∈ P) := by
+  obtain ⟨U, hU, hKU, -, hSU⟩ :=
+    exists_open_tube_sheet_recognition Φ hKsource hS p N hlocalS hawayS
+  obtain ⟨W, hW, hKW, -, hTW⟩ :=
+    exists_open_tube_sheet_recognition Φ hKsource hT q P hlocalT hawayT
+  let Ψ := Smale.PartialChart.restrictSource Φ (hU.inter hW)
+  have hzero : K ×ˢ {(0 : V)} ⊆ Ψ.source := fun z hz => ⟨hKsource hz, hKU hz, hKW hz⟩
+  obtain ⟨ε, hε, hprod⟩ :=
+    Smale.DiskFraming.exists_pos_prod_closedBall_subset hK Ψ.open_source hzero
+  exact
+    ⟨ε, hε, Ψ, hprod, fun _ => rfl, fun _ hz => hz.1, fun z hz => hSU z hz.2.1, fun z hz =>
+      hTW z hz.2.2⟩
+
+private theorem MorseCancel.exists_tube_support_box {V E H M : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ E H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × V) J (ℝ × V) M ∞)
+    (haxis : Set.Icc (0 : ℝ) 1 ×ˢ {(0 : V)} ⊆ Φ.source) :
+    ∃ l u r : ℝ, l < 0 ∧ 1 < u ∧ 0 < r ∧ Set.Icc l u ×ˢ Metric.closedBall (0 : V) r ⊆ Φ.source := by
+  let U : Set ℝ := (fun t : ℝ => (t, (0 : V))) ⁻¹' Φ.source
+  have hU : IsOpen U := Φ.open_source.preimage (continuous_id.prodMk continuous_const)
+  have h0U : (0 : ℝ) ∈ U := haxis ⟨⟨le_rfl, zero_le_one⟩, rfl⟩
+  have h1U : (1 : ℝ) ∈ U := haxis ⟨⟨zero_le_one, le_rfl⟩, rfl⟩
+  obtain ⟨a, ha, hball0⟩ := Metric.nhds_basis_closedBall.mem_iff.mp (hU.mem_nhds h0U)
+  obtain ⟨b, hb, hball1⟩ := Metric.nhds_basis_closedBall.mem_iff.mp (hU.mem_nhds h1U)
+  have hwide : Set.Icc (-a) (1 + b) ⊆ U := by
+    intro t ht
+    by_cases ht0 : t < 0
+    · apply hball0
+      rw [Metric.mem_closedBall, Real.dist_eq, sub_zero, abs_of_neg ht0]
+      linarith [ht.1]
+    · by_cases ht1 : 1 < t
+      · apply hball1
+        rw [Metric.mem_closedBall, Real.dist_eq, abs_of_pos (sub_pos.mpr ht1)]
+        linarith [ht.2]
+      · exact haxis ⟨⟨le_of_not_gt ht0, le_of_not_gt ht1⟩, rfl⟩
+  have hwideAxis : Set.Icc (-a) (1 + b) ×ˢ {(0 : V)} ⊆ Φ.source := by
+    rintro ⟨t, z⟩ ⟨ht, hz⟩
+    have hz0 : z = 0 := hz
+    subst z
+    exact hwide ht
+  obtain ⟨r, hr, hprod⟩ :=
+    Smale.DiskFraming.exists_pos_prod_closedBall_subset CompactIccSpace.isCompact_Icc
+      Φ.open_source hwideAxis
+  exact ⟨-a, 1 + b, r, by linarith, by linarith, hr, hprod⟩
+
+private def
+    Degree.RegularHeightCoordinates.heightMap {V : Type*} (F : ℝ × V → ℝ) (p : ℝ × V) : ℝ × V :=
+  (F p, p.2)
+
+private theorem
+    Degree.RegularHeightCoordinates.linear_decomposition {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] (L : ℝ × V →L[ℝ] ℝ) (s : ℝ) (z : V) : L (s, z) = s * L (1, 0) + L (0, z) := by
+  have he : (s, z) = s • (1, (0 : V)) + (0, z) := by simp
+  rw [he, map_add, map_smul]
+  rfl
+
+private theorem
+    Degree.RegularHeightCoordinates.triangular_bijective {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] (L : ℝ × V →L[ℝ] ℝ) (hL : L (1, 0) ≠ 0) :
+    Function.Bijective (L.prod (ContinuousLinearMap.snd ℝ ℝ V)) := by
+  constructor
+  · rintro ⟨s, z⟩ ⟨t, w⟩ h
+    have hzw : z = w := congrArg Prod.snd h
+    subst w
+    have he : L (s, z) = L (t, z) := congrArg Prod.fst h
+    rw [linear_decomposition L s z, linear_decomposition L t z] at he
+    have hst : s = t := (mul_right_cancel₀ hL) (by linarith)
+    exact Prod.ext hst rfl
+  · rintro ⟨s, z⟩
+    refine ⟨((s - L (0, z)) / L (1, 0), z), ?_⟩
+    apply Prod.ext
+    · change L ((s - L (0, z)) / L (1, 0), z) = s
+      rw [linear_decomposition L, div_mul_cancel₀ _ hL]
+      ring
+    · rfl
+
+private def Degree.RegularHeightCoordinates.triangularEquiv {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [FiniteDimensional ℝ V] (L : ℝ × V →L[ℝ] ℝ) (hL : L (1, 0) ≠ 0) :
+    (ℝ × V) ≃L[ℝ] (ℝ × V) :=
+  (LinearEquiv.ofBijective (L.prod (ContinuousLinearMap.snd ℝ ℝ V)).toLinearMap
+      (triangular_bijective L hL)).toContinuousLinearEquiv
+
+private theorem
+    Degree.RegularHeightCoordinates.contDiff_heightMap {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] {F : ℝ × V → ℝ} (hF : ContDiff ℝ ∞ F) : ContDiff ℝ ∞ (heightMap F) :=
+  hF.prodMk contDiff_snd
+
+private theorem Degree.RegularHeightCoordinates.fderiv_heightMap {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] {F : ℝ × V → ℝ} (hF : ContDiff ℝ ∞ F) (p : ℝ × V) :
+    fderiv ℝ (heightMap F) p = (fderiv ℝ F p).prod (ContinuousLinearMap.snd ℝ ℝ V) :=
+  (((hF.differentiable (by simp) p).hasFDerivAt).prodMk
+      (ContinuousLinearMap.snd ℝ ℝ V).hasFDerivAt).fderiv
+
+private theorem Degree.RegularHeightCoordinates.heightMap_localDiffeomorph {V : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℝ V] [FiniteDimensional ℝ V] {F : ℝ × V → ℝ}
+    (hF : ContDiff ℝ ∞ F) {p : ℝ × V} (hreg : fderiv ℝ F p (1, 0) ≠ 0) :
+    IsLocalDiffeomorphAt 𝓘(ℝ, ℝ × V) 𝓘(ℝ, ℝ × V) ∞ (heightMap F) p := by
+  have hinv : (fderiv ℝ (heightMap F) p).IsInvertible := by
+    refine ⟨triangularEquiv (fderiv ℝ F p) hreg, ?_⟩
+    rw [fderiv_heightMap hF]
+    rfl
+  obtain ⟨Φ, hp, _, hΦ⟩ :=
+    NoExotic.exists_partialDiffeomorph_of_contDiffOn isOpen_univ (Set.mem_univ p)
+      (contDiff_heightMap hF).contDiffOn hinv
+  exact ⟨Φ, hp, fun _ _ => congrFun hΦ.symm _⟩
+
+private def
+    Degree.RegularHeightCoordinates.displacedHeight {V : Type*} (u : ℝ × V → ℝ) (p : ℝ × V) : ℝ :=
+  p.1 + u p
+
+private theorem Degree.RegularHeightCoordinates.contDiff_displacedHeight {V : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℝ V] {u : ℝ × V → ℝ} (hu : ContDiff ℝ ∞ u) :
+    ContDiff ℝ ∞ (displacedHeight u) :=
+  contDiff_fst.add hu
+
+private theorem Degree.RegularHeightCoordinates.scalar_derivative {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] {F : ℝ × V → ℝ} (hF : ContDiff ℝ ∞ F) (s : ℝ) (z : V) :
+    HasDerivAt (fun t : ℝ => F (t, z)) (fderiv ℝ F (s, z) (1, 0)) s :=
+  ((hF.differentiable (by simp) (s, z)).hasFDerivAt).comp_hasDerivAt s
+    ((hasDerivAt_id s).prodMk (hasDerivAt_const s z))
+
+private theorem Degree.RegularHeightCoordinates.heightMap_injective_of_positive {V : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℝ V] {F : ℝ × V → ℝ} (hF : ContDiff ℝ ∞ F)
+    (hpos : ∀ p, 0 < fderiv ℝ F p (1, 0)) : Function.Injective (heightMap F) := by
+  have hmono (z : V) : StrictMono (fun s : ℝ => F (s, z)) :=
+    strictMono_of_deriv_pos (fun s => by rw [(scalar_derivative hF s z).deriv]; exact hpos _)
+  rintro ⟨s, z⟩ ⟨t, w⟩ he
+  have hzw : z = w := congrArg Prod.snd he
+  subst w
+  have hst : s = t := (hmono z).injective (congrArg Prod.fst he)
+  exact Prod.ext hst rfl
+
+private theorem Degree.RegularHeightCoordinates.heightMap_surjective_of_bounded {V : Type*}
+    [NormedAddCommGroup V] {u : ℝ × V → ℝ} (hu : Continuous u) (C : ℝ) (hC : 0 ≤ C)
+    (hbound : ∀ p, |u p| ≤ C) : Function.Surjective (heightMap (displacedHeight u)) := by
+  rintro ⟨r, z⟩
+  let a := r - (C + 1)
+  let b := r + (C + 1)
+  have hab : a ≤ b := by dsimp [a, b]; linarith
+  have hs : Continuous (fun s : ℝ => displacedHeight u (s, z)) :=
+    continuous_id.add (hu.comp (continuous_id.prodMk continuous_const))
+  have hlo : displacedHeight u (a, z) ≤ r := by
+    have h := (abs_le.mp (hbound (a, z))).2
+    dsimp [displacedHeight, a] at *
+    linarith
+  have hhi : r ≤ displacedHeight u (b, z) := by
+    have h := (abs_le.mp (hbound (b, z))).1
+    dsimp [displacedHeight, b] at *
+    linarith
+  obtain ⟨s, _, he⟩ := intermediate_value_Icc hab hs.continuousOn ⟨hlo, hhi⟩
+  exact ⟨(s, z), Prod.ext he rfl⟩
+
+private theorem Degree.RegularHeightCoordinates.heightMap_surjective_of_compactSupport {V : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℝ V] {u : ℝ × V → ℝ} (hu : ContDiff ℝ ∞ u)
+    (hc : HasCompactSupport u) : Function.Surjective (heightMap (displacedHeight u)) := by
+  obtain ⟨C, hC⟩ := (hc.isCompact_range hu.continuous).isBounded.exists_norm_le
+  have hC0 : 0 ≤ C := (norm_nonneg (u 0)).trans (hC _ ⟨0, rfl⟩)
+  exact
+    heightMap_surjective_of_bounded hu.continuous C hC0
+      (fun p => by simpa only [Real.norm_eq_abs] using hC _ ⟨p, rfl⟩)
+
+private def
+    Degree.RegularHeightCoordinates.longitudinalDiffeomorph {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [FiniteDimensional ℝ V] {u : ℝ × V → ℝ} (hu : ContDiff ℝ ∞ u)
+    (hc : HasCompactSupport u) (hpos : ∀ p, 0 < fderiv ℝ (displacedHeight u) p (1, 0)) :
+    (ℝ × V) ≃ₘ⟮𝓘(ℝ, ℝ × V), 𝓘(ℝ, ℝ × V)⟯ (ℝ × V) := by
+  have hs := contDiff_displacedHeight hu
+  have hloc : IsLocalDiffeomorph 𝓘(ℝ, ℝ × V) 𝓘(ℝ, ℝ × V) ∞ (heightMap (displacedHeight u)) :=
+    fun p => heightMap_localDiffeomorph hs (hpos p).ne'
+  exact
+    hloc.diffeomorphOfBijective
+      ⟨heightMap_injective_of_positive hs hpos, heightMap_surjective_of_compactSupport hu hc⟩
+
+private def Degree.MorseRearrangement.IntervalTranslation (a b x y : ℝ) : Prop :=
+  ∃ D : Diffeomorph 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) ℝ ℝ ∞,
+    (∀ z, z ∉ Set.Ioo a b → D z = z) ∧ D =ᶠ[𝓝 x] fun z => z + (y - x)
+
+private theorem
+    Degree.MorseRearrangement.translation_germ_apply (D : Diffeomorph 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) ℝ ℝ ∞)
+    {x y : ℝ} (hD : D =ᶠ[𝓝 x] fun z => z + (y - x)) : D x = y := by
+  have h := hD.self_of_nhds
+  linarith
+
+private theorem Degree.MorseRearrangement.intervalTranslation_refl (a b x : ℝ) :
+    IntervalTranslation a b x x := by
+  refine ⟨Diffeomorph.refl 𝓘(ℝ, ℝ) ℝ ∞, fun _ _ => rfl, Filter.Eventually.of_forall ?_⟩
+  intro z
+  change z = z + (x - x)
+  ring
+
+private theorem Degree.MorseRearrangement.intervalTranslation_symm {a b x y : ℝ}
+    (h : IntervalTranslation a b x y) : IntervalTranslation a b y x := by
+  obtain ⟨D, hfix, hgerm⟩ := h
+  have hxy := translation_germ_apply D hgerm
+  have hback : D.symm y = x := by rw [← hxy, D.symm_apply_apply]
+  have ht : Filter.Tendsto D.symm (𝓝 y) (𝓝 x) := hback ▸ D.symm.continuous.continuousAt.tendsto
+  refine ⟨D.symm, ?_, ?_⟩
+  · intro z hz
+    have hh := D.symm_apply_apply z
+    rwa [hfix z hz] at hh
+  · filter_upwards [hgerm.comp_tendsto ht] with z hz
+    change D (D.symm z) = D.symm z + (y - x) at hz
+    rw [D.apply_symm_apply] at hz
+    linarith
+
+private theorem Degree.MorseRearrangement.intervalTranslation_trans {a b x y z : ℝ}
+    (hxy : IntervalTranslation a b x y) (hyz : IntervalTranslation a b y z) :
+    IntervalTranslation a b x z := by
+  obtain ⟨D, hDfix, hD⟩ := hxy
+  obtain ⟨G, hGfix, hG⟩ := hyz
+  have hxy := translation_germ_apply D hD
+  have ht : Filter.Tendsto D (𝓝 x) (𝓝 y) := hxy ▸ D.continuous.continuousAt.tendsto
+  refine ⟨D.trans G, ?_, ?_⟩
+  · intro w hw
+    change G (D w) = w
+    rw [hDfix w hw, hGfix w hw]
+  · filter_upwards [hD, hG.comp_tendsto ht] with w hwD hwG
+    change G (D w) = w + (z - x)
+    change G (D w) = D w + (z - y) at hwG
+    rw [hwG, hwD]
+    ring
+
+private theorem Degree.MorseRearrangement.exists_local_interval_translation {a b x : ℝ}
+    (hx : x ∈ Set.Ioo a b) : ∃ ε, 0 < ε ∧ ∀ y, Dist.dist y x < ε → IntervalTranslation a b x y := by
+  obtain ⟨r, hr, hsub⟩ := Metric.mem_nhds_iff.mp (isOpen_Ioo.mem_nhds hx)
+  let β : ContDiffBump x := ⟨r / 4, r / 2, by positivity, by linarith⟩
+  have hsupp : tsupport (fun z : ℝ => β z) ⊆ Set.Ioo a b := by
+    rw [β.tsupport_eq]
+    intro z hz
+    apply hsub
+    have hh : Dist.dist z x ≤ r / 2 := hz
+    change Dist.dist z x < r
+    linarith
+  have hcompact : HasCompactSupport (fun z : ℝ => β z) := by
+    change IsCompact (tsupport (fun z : ℝ => β z))
+    rw [β.tsupport_eq]
+    exact ProperSpace.isCompact_closedBall _ _
+  obtain ⟨ε, hε, hmove⟩ :=
+    Smale.SmallPerturbation.exists_radius_bumpTranslation β.contDiff hcompact
+  refine ⟨ε, hε, ?_⟩
+  intro y hy
+  have hnorm : ‖y - x‖ < ε := by simpa only [dist_eq_norm] using hy
+  obtain ⟨D, hD, hfix⟩ := hmove (y - x) hnorm
+  refine ⟨D, fun z hz => hfix z (fun h => hz (hsupp h)), ?_⟩
+  filter_upwards [Metric.ball_mem_nhds x β.rIn_pos] with z hz
+  rw [hD, β.one_of_mem_closedBall (Metric.ball_subset_closedBall hz), one_smul]
+
+private theorem Degree.MorseRearrangement.exists_supported_interval_translation {a b x y : ℝ}
+    (hx : x ∈ Set.Ioo a b) (hy : y ∈ Set.Ioo a b) : IntervalTranslation a b x y := by
+  let U := Set.Ioo a b
+  let P : U → Prop := fun z => IntervalTranslation a b x z
+  have hlocal : IsLocallyConstant P := by
+    apply (IsLocallyConstant.iff_eventually_eq P).mpr
+    intro z
+    obtain ⟨ε, hε, hmove⟩ := exists_local_interval_translation z.property
+    filter_upwards [Metric.ball_mem_nhds z hε] with w hw
+    have hzw : IntervalTranslation a b z w := hmove w hw
+    apply propext
+    exact
+      ⟨fun hw => intervalTranslation_trans hw (intervalTranslation_symm hzw), fun hz =>
+        intervalTranslation_trans hz hzw⟩
+  let _ : PreconnectedSpace U := isPreconnected_iff_preconnectedSpace.mp isPreconnected_Ioo
+  have heq : P ⟨x, hx⟩ = P ⟨y, hy⟩ := hlocal.apply_eq_of_preconnectedSpace ⟨x, hx⟩ ⟨y, hy⟩
+  have hstart : P ⟨x, hx⟩ := intervalTranslation_refl a b x
+  have hfinish : P ⟨y, hy⟩ := heq ▸ hstart
+  exact hfinish
+
+private theorem Degree.MorseRearrangement.strictMono_of_fixed_exterior
+    (D : Diffeomorph 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) ℝ ℝ ∞) {a b : ℝ} (hfix : ∀ z, z ∉ Set.Ioo a b → D z = z) :
+    StrictMono D := by
+  rcases D.continuous.strictMono_of_inj D.injective with hm | ha
+  · exact hm
+  · have hanti := ha (show b < b + 1 by linarith)
+    rw [hfix b (fun h => (lt_irrefl b) h.2), hfix (b + 1) (fun h => by linarith [h.2])] at hanti
+    linarith
+
+private theorem Degree.MorseRearrangement.deriv_pos_of_strictMono_diffeomorph
+    (D : Diffeomorph 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) ℝ ℝ ∞) (hm : StrictMono D) (x : ℝ) : 0 < deriv D x := by
+  have hd := (D.mdifferentiable (by simp) x).differentiableAt.hasDerivAt
+  have hi := (D.symm.mdifferentiable (by simp) (D x)).differentiableAt.hasDerivAt
+  have hc := hi.comp x hd
+  have heq : D.symm ∘ D = id := funext D.symm_apply_apply
+  rw [heq] at hc
+  have hh := hc.unique (hasDerivAt_id x)
+  have hn : deriv D x ≠ 0 := by
+    intro hz
+    rw [hz, MulZeroClass.mul_zero] at hh
+    norm_num at hh
+  exact lt_of_le_of_ne hm.monotone.deriv_nonneg (Ne.symm hn)
+
+private theorem Degree.MorseRearrangement.exists_increasing_interval_translation {a b x y : ℝ}
+    (hx : x ∈ Set.Ioo a b) (hy : y ∈ Set.Ioo a b) :
+    ∃ D : Diffeomorph 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) ℝ ℝ ∞,
+      (∀ z, z ∉ Set.Ioo a b → D z = z) ∧
+        (D =ᶠ[𝓝 x] fun z => z + (y - x)) ∧ D x = y ∧ StrictMono D ∧ ∀ z, 0 < deriv D z := by
+  obtain ⟨D, hfix, hgerm⟩ := exists_supported_interval_translation hx hy
+  have hm := strictMono_of_fixed_exterior D hfix
+  exact
+    ⟨D, hfix, hgerm, translation_germ_apply D hgerm, hm, deriv_pos_of_strictMono_diffeomorph D hm⟩
+
+private theorem Degree.MorseRearrangement.exists_increasing_interval_translation_with_exterior_germs
+    {a b x y : ℝ} (hx : x ∈ Set.Ioo a b) (hy : y ∈ Set.Ioo a b) :
+    ∃ D : Diffeomorph 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) ℝ ℝ ∞,
+      (∀ z, z ∉ Set.Ioo a b → D z = z) ∧
+        (D =ᶠ[𝓝 x] fun z => z + (y - x)) ∧
+          D x = y ∧ StrictMono D ∧ (∀ z, 0 < deriv D z) ∧ ∀ z, z ∉ Set.Ioo a b → D =ᶠ[𝓝 z] id := by
+  obtain ⟨a', haa', ha'⟩ := exists_between (lt_min hx.1 hy.1)
+  obtain ⟨b', hb', hb'b⟩ := exists_between (max_lt hx.2 hy.2)
+  have hx' : x ∈ Set.Ioo a' b' := ⟨ha'.trans_le (min_le_left _ _), (le_max_left _ _).trans_lt hb'⟩
+  have hy' : y ∈ Set.Ioo a' b' :=
+    ⟨ha'.trans_le (min_le_right _ _), (le_max_right _ _).trans_lt hb'⟩
+  obtain ⟨D, hfix, hgerm, hpoint, hmono, hderiv⟩ := exists_increasing_interval_translation hx' hy'
+  have hsub : Set.Icc a' b' ⊆ Set.Ioo a b := fun z hz => ⟨haa'.trans_le hz.1, hz.2.trans_lt hb'b⟩
+  have hout (z : ℝ) (hz : z ∉ Set.Ioo a b) : D =ᶠ[𝓝 z] id := by
+    have hz' : z ∈ (Set.Icc a' b')ᶜ := fun h => hz (hsub h)
+    filter_upwards [isClosed_Icc.isOpen_compl.mem_nhds hz'] with w hw
+    exact hfix w (fun h => hw ⟨h.1.le, h.2.le⟩)
+  exact ⟨D, fun z hz => (hout z hz).self_of_nhds, hgerm, hpoint, hmono, hderiv, hout⟩
+
+private def Degree.MorseRearrangement.blendHeight (θ : ℝ) (P Q : ℝ → ℝ) (s : ℝ) : ℝ :=
+  θ * P s + (1 - θ) * Q s
+
+private theorem Degree.MorseRearrangement.blendHeight_zero (P Q : ℝ → ℝ) (s : ℝ) :
+    blendHeight 0 P Q s = Q s := by simp [blendHeight]
+
+private theorem Degree.MorseRearrangement.blendHeight_one (P Q : ℝ → ℝ) (s : ℝ) :
+    blendHeight 1 P Q s = P s := by simp [blendHeight]
+
+private theorem Degree.MorseRearrangement.blendHeight_fixed {P Q : ℝ → ℝ} {s : ℝ} (hP : P s = s)
+    (hQ : Q s = s) (θ : ℝ) : blendHeight θ P Q s = s := by
+  rw [blendHeight, hP, hQ]
+  ring
+
+private theorem Degree.MorseRearrangement.positive_blended_slope {θ a b : ℝ} (hθ : θ ∈ Set.Icc 0 1)
+    (ha : 0 < a) (hb : 0 < b) : 0 < θ * a + (1 - θ) * b := by
+  by_cases hzero : θ = 0
+  · simpa only [hzero, MulZeroClass.zero_mul, sub_zero, one_mul, zero_add] using hb
+  · exact
+      add_pos_of_pos_of_nonneg (mul_pos (lt_of_le_of_ne hθ.1 (Ne.symm hzero)) ha)
+        (mul_nonneg (sub_nonneg.mpr hθ.2) hb.le)
+
+private theorem
+    Degree.MorseRearrangement.hasDerivAt_blended_height {f θ P Q : ℝ → ℝ} {t f' p' q' : ℝ}
+    (hf : HasDerivAt f f' t) (hθ : HasDerivAt θ 0 t) (hP : HasDerivAt P p' (f t))
+    (hQ : HasDerivAt Q q' (f t)) :
+    HasDerivAt (fun s => blendHeight (θ s) P Q (f s)) ((θ t * p' + (1 - θ t) * q') * f') t := by
+  convert!
+    (hθ.mul (hP.comp t hf)).add (((hasDerivAt_const t (1 : ℝ)).sub hθ).mul (hQ.comp t hf)) using 1
+  simp only [Pi.sub_apply]
+  ring
+
+private def
+    MorseCancel.longitudinalBlendDisplacement {V : Type*} (D : ℝ → ℝ) (β : V → ℝ) (η : ℝ → ℝ)
+    (t : ℝ) (p : ℝ × V) : ℝ :=
+  η t * β p.2 * (D p.1 - p.1)
+
+private def MorseCancel.longitudinalBlend {V : Type*} (D : ℝ → ℝ) (β : V → ℝ) (η : ℝ → ℝ)
+    (p : ℝ × (ℝ × V)) : ℝ × V :=
+  (p.2.1 + longitudinalBlendDisplacement D β η p.1 p.2, p.2.2)
+
+private theorem MorseCancel.longitudinalBlendDisplacement_smooth {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] {D : ℝ → ℝ} {β : V → ℝ} (η : ℝ → ℝ) (hD : ContDiff ℝ ∞ D)
+    (hβ : ContDiff ℝ ∞ β) (t : ℝ) : ContDiff ℝ ∞ (longitudinalBlendDisplacement D β η t) :=
+  (contDiff_const.mul (hβ.comp contDiff_snd)).mul ((hD.comp contDiff_fst).sub contDiff_fst)
+
+private theorem
+    MorseCancel.longitudinalBlend_smooth {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    {D : ℝ → ℝ} {β : V → ℝ} {η : ℝ → ℝ} (hD : ContDiff ℝ ∞ D) (hβ : ContDiff ℝ ∞ β)
+    (hη : ContDiff ℝ ∞ η) :
+    ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, ℝ × V)) 𝓘(ℝ, ℝ × V) ∞ (longitudinalBlend D β η) := by
+  have hs : ContMDiff 𝓘(ℝ, ℝ × V) 𝓘(ℝ, ℝ) ∞ Prod.fst := contDiff_fst.contMDiff
+  have hz : ContMDiff 𝓘(ℝ, ℝ × V) 𝓘(ℝ, V) ∞ Prod.snd := contDiff_snd.contMDiff
+  have hs' : ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, ℝ × V)) 𝓘(ℝ, ℝ) ∞ (fun p : ℝ × (ℝ × V) => p.2.1) :=
+    hs.comp contMDiff_snd
+  have hz' : ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, ℝ × V)) 𝓘(ℝ, V) ∞ (fun p : ℝ × (ℝ × V) => p.2.2) :=
+    hz.comp contMDiff_snd
+  exact
+    (hs'.add
+          (((hη.contMDiff.comp contMDiff_fst).mul (hβ.contMDiff.comp hz')).mul
+            ((hD.contMDiff.comp hs').sub hs'))).prodMk_space
+      hz'
+
+private theorem
+    MorseCancel.longitudinalBlend_zero {V : Type*}
+    {D : ℝ → ℝ} {β : V → ℝ} {η : ℝ → ℝ} (hη : η 0 = 0) (p : ℝ × V) :
+    longitudinalBlend D β η (0, p) = p := by
+  simp only [longitudinalBlend, longitudinalBlendDisplacement, hη, MulZeroClass.zero_mul,
+    add_zero]
+
+private theorem
+    MorseCancel.longitudinalBlendDisplacement_zero_outside {V : Type*} [NormedAddCommGroup V]
+     {D : ℝ → ℝ} {β : V → ℝ} (η : ℝ → ℝ) {l u : ℝ}
+    (hfix : ∀ s ∉ Set.Ioo l u, D s = s) (t : ℝ) (p : ℝ × V) (hp : p ∉ Set.Icc l u ×ˢ tsupport β) :
+    longitudinalBlendDisplacement D β η t p = 0 := by
+  by_cases hs : p.1 ∈ Set.Icc l u
+  · have hb : β p.2 = 0 := image_eq_zero_of_notMem_tsupport (fun h => hp ⟨hs, h⟩)
+    simp only [longitudinalBlendDisplacement, hb, MulZeroClass.mul_zero, MulZeroClass.zero_mul]
+  · have hd := hfix p.1 (fun h => hs ⟨h.1.le, h.2.le⟩)
+    simp only [longitudinalBlendDisplacement, hd, sub_self, MulZeroClass.mul_zero]
+
+private theorem MorseCancel.longitudinalBlend_fixed_outside {V : Type*} [NormedAddCommGroup V]
+     {D : ℝ → ℝ} {β : V → ℝ} (η : ℝ → ℝ) {l u : ℝ}
+    (hfix : ∀ s ∉ Set.Ioo l u, D s = s) (t : ℝ) (p : ℝ × V) (hp : p ∉ Set.Icc l u ×ˢ tsupport β) :
+    longitudinalBlend D β η (t, p) = p := by
+  rw [longitudinalBlend, longitudinalBlendDisplacement_zero_outside η hfix t p hp, add_zero]
+
+private theorem MorseCancel.longitudinalBlend_derivative_positive {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] {D : ℝ → ℝ} {β : V → ℝ} {η : ℝ → ℝ} (hD : ContDiff ℝ ∞ D)
+    (hβ : ContDiff ℝ ∞ β) (hDpos : ∀ s, 0 < deriv D s) (hβrange : ∀ z, β z ∈ Set.Icc (0 : ℝ) 1)
+    (hηrange : ∀ t, η t ∈ Set.Icc (0 : ℝ) 1) (t : ℝ) (p : ℝ × V) :
+    0 <
+      fderiv ℝ
+        (Degree.RegularHeightCoordinates.displacedHeight (longitudinalBlendDisplacement D β η t))
+        p (1, 0) := by
+  have hu := longitudinalBlendDisplacement_smooth η hD hβ t
+  have hscalar :=
+    Degree.RegularHeightCoordinates.scalar_derivative
+      (Degree.RegularHeightCoordinates.contDiff_displacedHeight hu) p.1 p.2
+  have hd :=
+    (hasDerivAt_id p.1).add
+      (((hD.differentiable (by simp) p.1).hasDerivAt.sub (hasDerivAt_id p.1)).const_mul
+        (η t * β p.2))
+  have hrate :
+    fderiv ℝ
+        (Degree.RegularHeightCoordinates.displacedHeight (longitudinalBlendDisplacement D β η t))
+        p (1, 0) =
+      1 + (η t * β p.2) * (deriv D p.1 - 1) :=
+    hscalar.deriv.symm.trans hd.deriv
+  rw [hrate]
+  have hweight : η t * β p.2 ∈ Set.Icc (0 : ℝ) 1 :=
+    ⟨mul_nonneg (hηrange t).1 (hβrange p.2).1,
+      mul_le_one₀ (hηrange t).2 (hβrange p.2).1 (hβrange p.2).2⟩
+  have hpos := Degree.MorseRearrangement.positive_blended_slope hweight (hDpos p.1) zero_lt_one
+  nlinarith
+
+private theorem
+    MorseCancel.longitudinalBlend_slices {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    [FiniteDimensional ℝ V] {D : ℝ → ℝ} {β : V → ℝ} {η : ℝ → ℝ} {l u : ℝ} (hD : ContDiff ℝ ∞ D)
+    (hβ : ContDiff ℝ ∞ β) (hc : HasCompactSupport β) (hDpos : ∀ s, 0 < deriv D s)
+    (hfix : ∀ s ∉ Set.Ioo l u, D s = s) (hβrange : ∀ z, β z ∈ Set.Icc (0 : ℝ) 1)
+    (hηrange : ∀ t, η t ∈ Set.Icc (0 : ℝ) 1) (t : ℝ) :
+    ∃ d : Diffeomorph 𝓘(ℝ, ℝ × V) 𝓘(ℝ, ℝ × V) (ℝ × V) (ℝ × V) ∞,
+      ∀ p, d p = longitudinalBlend D β η (t, p) := by
+  have hu := longitudinalBlendDisplacement_smooth η hD hβ t
+  have hcompact : HasCompactSupport (longitudinalBlendDisplacement D β η t) :=
+    HasCompactSupport.intro (CompactIccSpace.isCompact_Icc.prod hc.isCompact)
+      (longitudinalBlendDisplacement_zero_outside η hfix t)
+  exact
+    ⟨Degree.RegularHeightCoordinates.longitudinalDiffeomorph hu hcompact
+        (longitudinalBlend_derivative_positive hD hβ hDpos hβrange hηrange t),
+      fun _ => rfl⟩
+
+private theorem MorseCancel.expNegInvGlue_hasDerivAt (t : ℝ) :
+    HasDerivAt expNegInvGlue (t⁻¹ ^ 2 * expNegInvGlue t) t := by
+  simpa using expNegInvGlue.hasDerivAt_polynomial_eval_inv_mul (1 : Polynomial ℝ) t
+
+private theorem MorseCancel.smoothTransition_deriv_pos {t : ℝ} (ht : t ∈ Set.Ioo (0 : ℝ) 1) :
+    0 < deriv Real.smoothTransition t := by
+  let a := expNegInvGlue t
+  let b := expNegInvGlue (1 - t)
+  let a' := t⁻¹ ^ 2 * a
+  let b' := (1 - t)⁻¹ ^ 2 * b
+  have ha : 0 < a := expNegInvGlue.pos_of_pos ht.1
+  have hb : 0 < b := expNegInvGlue.pos_of_pos (sub_pos.mpr ht.2)
+  have ha' : 0 < a' := mul_pos (sq_pos_of_ne_zero (inv_ne_zero ht.1.ne')) ha
+  have hb' : 0 < b' := mul_pos (sq_pos_of_ne_zero (inv_ne_zero (sub_pos.mpr ht.2).ne')) hb
+  have hA : HasDerivAt expNegInvGlue a' t := expNegInvGlue_hasDerivAt t
+  have hB : HasDerivAt (fun s : ℝ => expNegInvGlue (1 - s)) (-b') t := by
+    convert!
+      (expNegInvGlue_hasDerivAt (1 - t)).comp t
+        ((hasDerivAt_const t (1 : ℝ)).sub (hasDerivAt_id t)) using
+      1
+    dsimp only [b', b]
+    ring
+  have hd := hA.div (hA.add hB) (Real.smoothTransition.pos_denom t).ne'
+  change HasDerivAt Real.smoothTransition ((a' * (a + b) - a * (a' + -b')) / (a + b) ^ 2) t at hd
+  rw [hd.deriv]
+  apply div_pos
+  · have he : a' * (a + b) - a * (a' + -b') = a' * b + a * b' := by ring
+    rw [he]
+    exact add_pos (mul_pos ha' hb) (mul_pos ha hb')
+  · exact sq_pos_of_pos (add_pos ha hb)
+
+private theorem MorseCancel.smoothTransition_strictMonoOn :
+    StrictMonoOn Real.smoothTransition (Set.Icc (0 : ℝ) 1) := by
+  apply
+    strictMonoOn_of_deriv_pos (convex_Icc (0 : ℝ) 1) Real.smoothTransition.continuous.continuousOn
+  intro t ht
+  apply smoothTransition_deriv_pos
+  simpa only [interior_Icc] using ht
+
+private theorem
+    MorseCancel.exists_unique_smoothTransition_time {c : ℝ} (hc : c ∈ Set.Ioo (0 : ℝ) 1) :
+    ∃ τ : ℝ,
+      τ ∈ Set.Ioo (0 : ℝ) 1 ∧
+        Real.smoothTransition τ = c ∧
+          0 < deriv Real.smoothTransition τ ∧
+            ∀ t ∈ Set.Icc (0 : ℝ) 1, Real.smoothTransition t = c ↔ t = τ := by
+  have hc' : c ∈ Set.Icc (Real.smoothTransition 0) (Real.smoothTransition 1) := by
+    rw [Real.smoothTransition.zero, Real.smoothTransition.one]
+    exact ⟨hc.1.le, hc.2.le⟩
+  obtain ⟨τ, hτ, heq⟩ :=
+    intermediate_value_Icc zero_le_one Real.smoothTransition.continuous.continuousOn hc'
+  have hτ0 : τ ≠ 0 := by
+    intro h
+    rw [h, Real.smoothTransition.zero] at heq
+    linarith [hc.1]
+  have hτ1 : τ ≠ 1 := by
+    intro h
+    rw [h, Real.smoothTransition.one] at heq
+    linarith [hc.2]
+  have hτI : τ ∈ Set.Ioo (0 : ℝ) 1 := ⟨lt_of_le_of_ne hτ.1 (Ne.symm hτ0), lt_of_le_of_ne hτ.2 hτ1⟩
+  refine ⟨τ, hτI, heq, smoothTransition_deriv_pos hτI, ?_⟩
+  intro t ht
+  exact ⟨fun h => smoothTransition_strictMonoOn.injOn ht hτ (h.trans heq.symm), fun h => h ▸ heq⟩
+
+private structure MorseCancel.LongitudinalTubeMotion {V E H M : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ E H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × V) J (ℝ × V) M ∞) where
+  profile : Diffeomorph 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) ℝ ℝ ∞
+  cutoff : V → ℝ
+  cutoff_smooth : ContDiff ℝ ∞ cutoff
+  cutoff_germ : cutoff =ᶠ[𝓝 (0 : V)] fun _ => 1
+  cutoff_zero : cutoff 0 = 1
+  destination : ℝ
+  destination_gt_one : 1 < destination
+  profile_zero : profile 0 = destination
+  profile_germ : (profile : ℝ → ℝ) =ᶠ[𝓝 (0 : ℝ)] fun s => s + destination
+  time : ℝ
+  time_mem : time ∈ Set.Ioo (0 : ℝ) 1
+  time_value : Real.smoothTransition time * destination = 1
+  time_rate : 0 < deriv Real.smoothTransition time * destination
+  unique_time : ∀ t ∈ Set.Icc (0 : ℝ) 1, Real.smoothTransition t * destination = 1 ↔ t = time
+  family : ℝ × M → M
+  support : Set M
+  compact_support : IsCompact support
+  support_subset : support ⊆ Φ.target
+  smooth : ContMDiff (𝓘(ℝ, ℝ).prod J) J ∞ family
+  zero : ∀ y, family (0, y) = y
+  slices : ∀ t, ∃ d : Diffeomorph J J M M ∞, ∀ y, d y = family (t, y)
+  fixedOutside : ∀ t y, y ∉ support → family (t, y) = y
+  model_source :
+    ∀ t z, z ∈ Φ.source → longitudinalBlend profile cutoff Real.smoothTransition (t, z) ∈ Φ.source
+  formula :
+    ∀ t z,
+      z ∈ Φ.source →
+        family (t, Φ z) = Φ (longitudinalBlend profile cutoff Real.smoothTransition (t, z))
+
+private theorem MorseCancel.nonempty_longitudinalTubeMotion {V E H M : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ E H} [TopologicalSpace M] [ChartedSpace H M] [FiniteDimensional ℝ V]
+    [T2Space M] (Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × V) J (ℝ × V) M ∞)
+    (haxis : Set.Icc (0 : ℝ) 1 ×ˢ {(0 : V)} ⊆ Φ.source) : Nonempty (LongitudinalTubeMotion Φ) := by
+  obtain ⟨l, u, r, hl, hu, hr, hbox⟩ := exists_tube_support_box Φ haxis
+  let c : ℝ := (1 + u) / 2
+  have hc : 1 < c := by dsimp only [c]; linarith
+  have hcpos : 0 < c := zero_lt_one.trans hc
+  have hcu : c < u := by dsimp only [c]; linarith
+  have h0I : (0 : ℝ) ∈ Set.Ioo l u := ⟨hl, zero_lt_one.trans hu⟩
+  have hcI : c ∈ Set.Ioo l u := ⟨hl.trans hcpos, hcu⟩
+  obtain ⟨D, hDfix, hDgerm, hD0, -, hDpos⟩ :=
+    Degree.MorseRearrangement.exists_increasing_interval_translation h0I hcI
+  let β : ContDiffBump (0 : V) :=
+    { rIn := r / 2
+      rOut := r
+      rIn_pos := half_pos hr
+      rIn_lt_rOut := half_lt_self hr }
+  have hβgerm : (β : V → ℝ) =ᶠ[𝓝 (0 : V)] fun _ => 1 := by
+    filter_upwards [Metric.ball_mem_nhds (0 : V) β.rIn_pos] with z hz
+    exact β.one_of_mem_closedBall (Metric.ball_subset_closedBall hz)
+  have hβrange : ∀ z : V, β z ∈ Set.Icc (0 : ℝ) 1 := fun _ => ⟨β.nonneg, β.le_one⟩
+  have hηrange : ∀ t : ℝ, Real.smoothTransition t ∈ Set.Icc (0 : ℝ) 1 := fun t =>
+    ⟨Real.smoothTransition.nonneg t, Real.smoothTransition.le_one t⟩
+  have hmodel :=
+    longitudinalBlend_smooth D.contMDiff.contDiff β.contDiff
+      (Real.smoothTransition.contDiff (n := ⊤))
+  have hsource : Set.Icc l u ×ˢ tsupport (β : V → ℝ) ⊆ Φ.source := by
+    rw [β.tsupport_eq]
+    exact hbox
+  obtain ⟨F, K, hK, hKΦ, hF, hF0, hFd, hFfix, hsrc, hformula⟩ :=
+    Smale.SupportedDiffeomorph.exists_supported_isotopy_extension Φ hmodel
+      (longitudinalBlend_zero Real.smoothTransition.zero)
+      (longitudinalBlend_slices D.contMDiff.contDiff β.contDiff β.hasCompactSupport hDpos hDfix
+        hβrange hηrange)
+      (CompactIccSpace.isCompact_Icc.prod β.hasCompactSupport.isCompact) hsource
+      (longitudinalBlend_fixed_outside Real.smoothTransition hDfix)
+  have hcInv : 1 / c ∈ Set.Ioo (0 : ℝ) 1 := ⟨one_div_pos.mpr hcpos, (div_lt_one hcpos).mpr hc⟩
+  obtain ⟨τ, hτ, hτvalue, hτrate, hτunique⟩ := exists_unique_smoothTransition_time hcInv
+  refine
+    ⟨{  profile := D
+        cutoff := β
+        cutoff_smooth := β.contDiff
+        cutoff_germ := hβgerm
+        cutoff_zero := hβgerm.self_of_nhds
+        destination := c
+        destination_gt_one := hc
+        profile_zero := hD0
+        profile_germ := by simpa only [sub_zero] using hDgerm
+        time := τ
+        time_mem := hτ
+        time_value := (eq_div_iff hcpos.ne').mp hτvalue
+        time_rate := mul_pos hτrate hcpos
+        unique_time := ?_
+        family := F
+        support := K
+        compact_support := hK
+        support_subset := hKΦ
+        smooth := hF
+        zero := hF0
+        slices := hFd
+        fixedOutside := hFfix
+        model_source := hsrc
+        formula := hformula }⟩
+  intro t ht
+  rw [← eq_div_iff hcpos.ne']
+  exact hτunique t ht
+
+private theorem
+    MorseCancel.LongitudinalTubeMotion.model_axis {V E H M : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ E H} [TopologicalSpace M] [ChartedSpace H M]
+    {Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × V) J (ℝ × V) M ∞} (A : MorseCancel.LongitudinalTubeMotion Φ)
+    (t : ℝ) :
+    MorseCancel.longitudinalBlend A.profile A.cutoff Real.smoothTransition (t, (0, 0)) =
+      (Real.smoothTransition t * A.destination, 0) := by
+  simp only [MorseCancel.longitudinalBlend, MorseCancel.longitudinalBlendDisplacement,
+    A.cutoff_zero, A.profile_zero, mul_one, sub_zero, zero_add]
+
+private theorem
+    MorseCancel.LongitudinalTubeMotion.model_germ {V E H M : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ E H} [TopologicalSpace M] [ChartedSpace H M]
+    {Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × V) J (ℝ × V) M ∞} (A : MorseCancel.LongitudinalTubeMotion Φ)
+    (t : ℝ) :
+    MorseCancel.longitudinalBlend A.profile A.cutoff Real.smoothTransition =ᶠ[𝓝 (t, (0, 0))]
+      fun p : ℝ × (ℝ × V) => (p.2.1 + Real.smoothTransition p.1 * A.destination, p.2.2) := by
+  have hs : Filter.Tendsto (fun p : ℝ × (ℝ × V) => p.2.1) (𝓝 (t, (0, 0))) (𝓝 0) :=
+    continuous_fst.continuousAt.comp continuous_snd.continuousAt
+  have hz : Filter.Tendsto (fun p : ℝ × (ℝ × V) => p.2.2) (𝓝 (t, (0, 0))) (𝓝 0) :=
+    continuous_snd.continuousAt.comp continuous_snd.continuousAt
+  filter_upwards [hs.eventually A.profile_germ, hz.eventually A.cutoff_germ] with p hp hβ
+  simp only [MorseCancel.longitudinalBlend, MorseCancel.longitudinalBlendDisplacement, hp, hβ,
+    mul_one, add_sub_cancel_left]
+
+private theorem
+    MorseCancel.LongitudinalTubeMotion.native_axis {V E H M : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ E H} [TopologicalSpace M] [ChartedSpace H M]
+    {Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × V) J (ℝ × V) M ∞} (A : MorseCancel.LongitudinalTubeMotion Φ)
+    (h0 : (0 : ℝ × V) ∈ Φ.source) (t : ℝ) :
+    A.family (t, Φ 0) = Φ (Real.smoothTransition t * A.destination, 0) := by
+  rw [A.formula t 0 h0]
+  exact congrArg Φ (A.model_axis t)
+
+private theorem
+    MorseCancel.LongitudinalTubeMotion.native_germ {V E H M : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ E H} [TopologicalSpace M] [ChartedSpace H M]
+    {Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × V) J (ℝ × V) M ∞} (A : MorseCancel.LongitudinalTubeMotion Φ)
+    (h0 : (0 : ℝ × V) ∈ Φ.source) (t : ℝ) :
+    (fun p : ℝ × (ℝ × V) => A.family (p.1, Φ p.2)) =ᶠ[𝓝 (t, 0)] fun p =>
+      Φ (p.2.1 + Real.smoothTransition p.1 * A.destination, p.2.2) := by
+  have hs : ∀ᶠ p : ℝ × (ℝ × V) in 𝓝 (t, 0), p.2 ∈ Φ.source :=
+    continuous_snd.continuousAt.eventually (Φ.open_source.mem_nhds h0)
+  filter_upwards [A.model_germ t, hs] with p hp hs
+  rw [A.formula p.1 p.2 hs, hp]
+
+private theorem MorseCancel.LongitudinalTubeMotion.fixed_outside_target {V E H M : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℝ V] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ E H} [TopologicalSpace M] [ChartedSpace H M]
+    {Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × V) J (ℝ × V) M ∞} (A : MorseCancel.LongitudinalTubeMotion Φ)
+    (t : ℝ) (y : M) (hy : y ∉ Φ.target) : A.family (t, y) = y :=
+  A.fixedOutside t y (fun h => hy (A.support_subset h))
+
+private theorem
+    MorseCancel.LongitudinalTubeMotion.crossing_axis {V E H M : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ E H} [TopologicalSpace M] [ChartedSpace H M]
+    {Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × V) J (ℝ × V) M ∞} (A : MorseCancel.LongitudinalTubeMotion Φ)
+    (h0 : (0 : ℝ × V) ∈ Φ.source) : A.family (A.time, Φ 0) = Φ (1, 0) := by
+  rw [A.native_axis h0, A.time_value]
+
+private theorem MorseCancel.LongitudinalTubeMotion.whole_sheet_crossing_iff {U V E H M X Y : Type*}
+    [NormedAddCommGroup U] [NormedSpace ℝ U] [NormedAddCommGroup V] [NormedSpace ℝ V]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {J : ModelWithCorners ℝ E H}
+    [TopologicalSpace M] [ChartedSpace H M]
+    {Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × (U × V)) J (ℝ × (U × V)) M ∞}
+    (A : MorseCancel.LongitudinalTubeMotion Φ) {f : X → M} {g : Y → M}
+    (hfi : Function.Injective f) (hgi : Function.Injective g)
+    (hdisj : Disjoint (Set.range f) (Set.range g))
+    (hrecf : ∀ z ∈ Φ.source, Φ z ∈ Set.range f ↔ z.1 = 0 ∧ z.2.2 = 0)
+    (hrecg : ∀ z ∈ Φ.source, Φ z ∈ Set.range g ↔ z.1 = 1 ∧ z.2.1 = 0) (x₀ : X) (y₀ : Y)
+    (hx₀ : Φ 0 = f x₀) (hy₀ : Φ (1, 0) = g y₀) (h0 : (0 : ℝ × (U × V)) ∈ Φ.source) (t : ℝ)
+    (ht : t ∈ Set.Icc (0 : ℝ) 1) (x : X) (y : Y) :
+    A.family (t, f x) = g y ↔ t = A.time ∧ x = x₀ ∧ y = y₀ := by
+  constructor
+  · intro he
+    have htarget : f x ∈ Φ.target := by
+      by_contra hn
+      have hxy : f x = g y := (A.fixed_outside_target t (f x) hn).symm.trans he
+      exact (Set.disjoint_left.mp hdisj) ⟨x, rfl⟩ ⟨y, hxy.symm⟩
+    let z := Φ.symm (f x)
+    have hz : z ∈ Φ.source := Φ.map_target htarget
+    have hzfx : Φ z = f x := Φ.right_inv htarget
+    have hfz := (hrecf z hz).mp ⟨x, hzfx.symm⟩
+    let w := MorseCancel.longitudinalBlend A.profile A.cutoff Real.smoothTransition (t, z)
+    have hw : w ∈ Φ.source := A.model_source t z hz
+    have hwgy : Φ w = g y := by
+      calc
+        Φ w = A.family (t, Φ z) := (A.formula t z hz).symm
+        _ = A.family (t, f x) := (congrArg (fun p => A.family (t, p)) hzfx)
+        _ = g y := he
+    have hgw := (hrecg w hw).mp ⟨y, hwgy.symm⟩
+    have hu : z.2.1 = 0 := hgw.2
+    have hz0 : z = 0 := Prod.ext hfz.1 (Prod.ext hu hfz.2)
+    have hwaxis : w = (Real.smoothTransition t * A.destination, 0) := by
+      dsimp only [w]
+      rw [hz0]
+      exact A.model_axis t
+    have htimevalue : Real.smoothTransition t * A.destination = 1 :=
+      (congrArg Prod.fst hwaxis).symm.trans hgw.1
+    have htτ : t = A.time := (A.unique_time t ht).mp htimevalue
+    have hx : x = x₀ := hfi (hzfx.symm.trans ((congrArg Φ hz0).trans hx₀))
+    have hwy : Φ w = g y₀ := by
+      rw [hwaxis, htimevalue]
+      exact hy₀
+    exact ⟨htτ, hx, hgi (hwgy.symm.trans hwy)⟩
+  · rintro ⟨ht, hx, hy⟩
+    rw [ht, hx, hy]
+    calc
+      A.family (A.time, f x₀) = A.family (A.time, Φ 0) :=
+        congrArg (fun p => A.family (A.time, p)) hx₀.symm
+      _ = Φ (1, 0) := (A.crossing_axis h0)
+      _ = g y₀ := hy₀
+
+private theorem
+    MorseCancel.surjective_sheet_coordinate_mfderiv {U W H X : Type*} [NormedAddCommGroup U]
+    [NormedSpace ℝ U] [FiniteDimensional ℝ U] [NormedAddCommGroup W] [NormedSpace ℝ W]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ U H} [TopologicalSpace X] [ChartedSpace H X]
+    (P : W →L[ℝ] U) (Q : U →L[ℝ] W) (b : W) {a : X → W} {x : X}
+    (ha : MDifferentiableAt I 𝓘(ℝ, W) a x) (hi : Function.Injective (mfderiv I 𝓘(ℝ, W) a x))
+    (hgerm : a =ᶠ[𝓝 x] fun y => Q (P (a y)) + b) :
+    Function.Surjective (mfderiv I 𝓘(ℝ, U) (P ∘ a) x) := by
+  have hP : MDifferentiableAt 𝓘(ℝ, W) 𝓘(ℝ, U) P (a x) := P.differentiableAt.mdifferentiableAt
+  have hα := hP.comp x ha
+  have hQ : HasMFDerivAt 𝓘(ℝ, U) 𝓘(ℝ, W) (fun u => Q u + b) (P (a x)) Q :=
+    (Q.hasFDerivAt.add_const b).hasMFDerivAt
+  have heq : (mfderiv I 𝓘(ℝ, W) a x : U →L[ℝ] W) = Q.comp (mfderiv I 𝓘(ℝ, U) (P ∘ a) x) :=
+    hgerm.mfderiv_eq.trans (hQ.comp x hα.hasMFDerivAt).mfderiv
+  let D : U →L[ℝ] U := mfderiv I 𝓘(ℝ, U) (P ∘ a) x
+  change Function.Surjective D
+  apply (LinearMap.injective_iff_surjective (f := D.toLinearMap)).mp
+  intro u v huv
+  apply hi
+  rw [heq]
+  exact congrArg Q huv
+
+private theorem MorseCancel.native_coordinate_plane_trace_transverse {U H X : Type*}
+    [NormedAddCommGroup U] [NormedSpace ℝ U] [TopologicalSpace H]
+    {I : ModelWithCorners ℝ U H} [TopologicalSpace X] [ChartedSpace H X] {V H' Y : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℝ V] [TopologicalSpace H'] {I' : ModelWithCorners ℝ V H'}
+    [TopologicalSpace Y] [ChartedSpace H' Y] {α : X → U} {β : Y → V} {x : X} {y : Y} {η : ℝ → ℝ}
+    {τ κ : ℝ} (hα : MDifferentiableAt I 𝓘(ℝ, U) α x) (hβ : MDifferentiableAt I' 𝓘(ℝ, V) β y)
+    (hαs : Function.Surjective (mfderiv I 𝓘(ℝ, U) α x))
+    (hβs : Function.Surjective (mfderiv I' 𝓘(ℝ, V) β y)) (hη : HasDerivAt η κ τ) (hκ : κ ≠ 0) :
+    Smale.NativeTransversality.At (𝓘(ℝ, ℝ).prod I) I' 𝓘(ℝ, ℝ × (U × V))
+      (fun p : ℝ × X => (η p.1, (α p.2, 0))) (fun q : Y => (1, (0, β q))) (τ, x) y := by
+  let D : U →L[ℝ] U := mfderiv I 𝓘(ℝ, U) α x
+  let E : V →L[ℝ] V := mfderiv I' 𝓘(ℝ, V) β y
+  let C : (ℝ × U) →L[ℝ] ℝ :=
+    (ContinuousLinearMap.smulRight (1 : ℝ →L[ℝ] ℝ) κ).comp (ContinuousLinearMap.fst ℝ ℝ U)
+  let L : (ℝ × U) →L[ℝ] ℝ × (U × V) := C.prod ((D.comp (ContinuousLinearMap.snd ℝ ℝ U)).prod 0)
+  let R : V →L[ℝ] ℝ × (U × V) := (0 : V →L[ℝ] ℝ).prod ((0 : V →L[ℝ] U).prod E)
+  have htime :=
+    hη.hasFDerivAt.hasMFDerivAt.comp (τ, x) (hasMFDerivAt_fst (I := 𝓘(ℝ, ℝ)) (I' := I) (τ, x))
+  have hcoord := hα.hasMFDerivAt.comp (τ, x) (hasMFDerivAt_snd (I := 𝓘(ℝ, ℝ)) (I' := I) (τ, x))
+  have hzero : HasMFDerivAt (𝓘(ℝ, ℝ).prod I) 𝓘(ℝ, V) (fun _ : ℝ × X => (0 : V)) (τ, x) 0 :=
+    hasMFDerivAt_const _ _
+  have hT :
+    HasMFDerivAt (𝓘(ℝ, ℝ).prod I) 𝓘(ℝ, ℝ × (U × V)) (fun p : ℝ × X => (η p.1, (α p.2, (0 : V))))
+      (τ, x) L := by convert! htime.prodMk (hcoord.prodMk hzero) using 1
+  have hone : HasMFDerivAt I' 𝓘(ℝ, ℝ) (fun _ : Y => (1 : ℝ)) y 0 := hasMFDerivAt_const _ _
+  have hz : HasMFDerivAt I' 𝓘(ℝ, U) (fun _ : Y => (0 : U)) y 0 := hasMFDerivAt_const _ _
+  have hB : HasMFDerivAt I' 𝓘(ℝ, ℝ × (U × V)) (fun q : Y => ((1 : ℝ), ((0 : U), β q))) y R := by
+    convert! hone.prodMk (hz.prodMk hβ.hasMFDerivAt) using 1
+  intro _
+  rw [hT.mfderiv, hB.mfderiv]
+  change Function.Surjective (L.coprod R)
+  rintro ⟨s, u, v⟩
+  obtain ⟨a, ha⟩ := hαs u
+  obtain ⟨b, hb⟩ := hβs v
+  refine ⟨((s / κ, a), b), ?_⟩
+  apply Prod.ext
+  · change s / κ * κ + 0 = s
+    rw [add_zero, div_mul_cancel₀ s hκ]
+  · change (D a + 0, 0 + E b) = (u, v)
+    rw [add_zero, zero_add]
+    exact Prod.ext ha hb
+
+private theorem
+    MorseCancel.LongitudinalTubeMotion.whole_sheet_transverse {U V E HU HV H M X Y : Type*}
+    [NormedAddCommGroup U] [NormedSpace ℝ U] [FiniteDimensional ℝ U] [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [FiniteDimensional ℝ V] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace HU] [TopologicalSpace HV] [TopologicalSpace H] {I : ModelWithCorners ℝ U HU}
+    {I' : ModelWithCorners ℝ V HV} {J : ModelWithCorners ℝ E H} [TopologicalSpace M]
+    [ChartedSpace H M] [TopologicalSpace X] [ChartedSpace HU X] [TopologicalSpace Y]
+    [ChartedSpace HV Y] {Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × (U × V)) J (ℝ × (U × V)) M ∞}
+    (A : MorseCancel.LongitudinalTubeMotion Φ) {f : X → M} {g : Y → M} {x : X} {y : Y}
+    (hf : MDifferentiableAt I J f x) (hg : MDifferentiableAt I' J g y)
+    (hfi : Function.Injective (mfderiv I J f x)) (hgi : Function.Injective (mfderiv I' J g y))
+    (hrecf : ∀ z ∈ Φ.source, Φ z ∈ Set.range f ↔ z.1 = 0 ∧ z.2.2 = 0)
+    (hrecg : ∀ z ∈ Φ.source, Φ z ∈ Set.range g ↔ z.1 = 1 ∧ z.2.1 = 0) (hx : Φ 0 = f x)
+    (hy : Φ (1, 0) = g y) (h0 : (0 : ℝ × (U × V)) ∈ Φ.source) :
+    Smale.NativeTransversality.At (𝓘(ℝ, ℝ).prod I) I' J (fun p : ℝ × X => A.family (p.1, f p.2)) g
+      (A.time, x) y := by
+  let W := ℝ × (U × V)
+  let a : X → W := Φ.symm ∘ f
+  let b : Y → W := Φ.symm ∘ g
+  let P : W →L[ℝ] U := (ContinuousLinearMap.fst ℝ U V).comp (ContinuousLinearMap.snd ℝ ℝ (U × V))
+  let Q : U →L[ℝ] W := (0 : U →L[ℝ] ℝ).prod ((ContinuousLinearMap.id ℝ U).prod (0 : U →L[ℝ] V))
+  let R : W →L[ℝ] V := (ContinuousLinearMap.snd ℝ U V).comp (ContinuousLinearMap.snd ℝ ℝ (U × V))
+  let S : V →L[ℝ] W := (0 : V →L[ℝ] ℝ).prod ((0 : V →L[ℝ] U).prod (ContinuousLinearMap.id ℝ V))
+  have h1 : ((1 : ℝ), (0 : U × V)) ∈ Φ.source := by
+    have hh := A.model_source A.time ((0 : ℝ), (0 : U × V)) h0
+    rw [A.model_axis, A.time_value] at hh
+    exact hh
+  have hfx : f x ∈ Φ.target := hx ▸ Φ.map_source h0
+  have hgy : g y ∈ Φ.target := hy ▸ Φ.map_source h1
+  have ha : MDifferentiableAt I 𝓘(ℝ, W) a x := (Φ.symm.mdifferentiableAt (by simp) hfx).comp x hf
+  have hb : MDifferentiableAt I' 𝓘(ℝ, W) b y := (Φ.symm.mdifferentiableAt (by simp) hgy).comp y hg
+  have hai : Function.Injective (mfderiv I 𝓘(ℝ, W) a x) := by
+    rw [mfderiv_comp x (Φ.symm.mdifferentiableAt (by simp) hfx) hf]
+    exact (Smale.PartialChart.bijective_mfderiv Φ.symm hfx).injective.comp hfi
+  have hbi : Function.Injective (mfderiv I' 𝓘(ℝ, W) b y) := by
+    rw [mfderiv_comp y (Φ.symm.mdifferentiableAt (by simp) hgy) hg]
+    exact (Smale.PartialChart.bijective_mfderiv Φ.symm hgy).injective.comp hgi
+  have ha0 : a x = 0 := (congrArg Φ.symm hx).symm.trans (Φ.left_inv h0)
+  have hb1 : b y = (1, 0) := (congrArg Φ.symm hy).symm.trans (Φ.left_inv h1)
+  have hfn : ∀ᶠ q in 𝓝 x, f q ∈ Φ.target :=
+    hf.continuousAt.eventually (Φ.open_target.mem_nhds hfx)
+  have hgn : ∀ᶠ q in 𝓝 y, g q ∈ Φ.target :=
+    hg.continuousAt.eventually (Φ.open_target.mem_nhds hgy)
+  have hca : ∀ᶠ q in 𝓝 x, (a q).1 = 0 ∧ (a q).2.2 = 0 := by
+    filter_upwards [hfn] with q hq
+    exact (hrecf (a q) (Φ.map_target hq)).mp ⟨q, (Φ.right_inv hq).symm⟩
+  have hcb : ∀ᶠ q in 𝓝 y, (b q).1 = 1 ∧ (b q).2.1 = 0 := by
+    filter_upwards [hgn] with q hq
+    exact (hrecg (b q) (Φ.map_target hq)).mp ⟨q, (Φ.right_inv hq).symm⟩
+  have hagerm : a =ᶠ[𝓝 x] fun q => Q (P (a q)) + (0 : W) := by
+    filter_upwards [hca] with q hq
+    change a q = (0, ((a q).2.1, 0)) + (0 : W)
+    rw [add_zero]
+    exact Prod.ext hq.1 (Prod.ext rfl hq.2)
+  have hbgerm : b =ᶠ[𝓝 y] fun q => S (R (b q)) + ((1 : ℝ), (0 : U × V)) := by
+    filter_upwards [hcb] with q hq
+    change b q = (0, (0, (b q).2.2)) + ((1 : ℝ), (0 : U × V))
+    apply Prod.ext
+    · change (b q).1 = 0 + 1
+      simpa only [zero_add] using hq.1
+    · apply Prod.ext
+      · change (b q).2.1 = 0 + 0
+        simpa only [zero_add] using hq.2
+      · change (b q).2.2 = (b q).2.2 + 0
+        exact (add_zero _).symm
+  let α : X → U := P ∘ a
+  let β : Y → V := R ∘ b
+  have hα : MDifferentiableAt I 𝓘(ℝ, U) α x := P.differentiableAt.mdifferentiableAt.comp x ha
+  have hβ : MDifferentiableAt I' 𝓘(ℝ, V) β y := R.differentiableAt.mdifferentiableAt.comp y hb
+  have hαs := MorseCancel.surjective_sheet_coordinate_mfderiv P Q 0 ha hai hagerm
+  have hβs := MorseCancel.surjective_sheet_coordinate_mfderiv R S (1, 0) hb hbi hbgerm
+  let η : ℝ → ℝ := fun t => Real.smoothTransition t * A.destination
+  have hη : HasDerivAt η (deriv Real.smoothTransition A.time * A.destination) A.time :=
+    ((Real.smoothTransition.contDiff (n := ⊤)).differentiable (by simp)
+          A.time).hasDerivAt.mul_const
+      _
+  let T : ℝ × X → W := fun p => (η p.1, (α p.2, 0))
+  let B : Y → W := fun q => (1, (0, β q))
+  have hT : MDifferentiableAt (𝓘(ℝ, ℝ).prod I) 𝓘(ℝ, W) T (A.time, x) :=
+    (hη.differentiableAt.mdifferentiableAt.comp (A.time, x) mdifferentiableAt_fst).prodMk_space
+      ((hα.comp (A.time, x) mdifferentiableAt_snd).prodMk_space mdifferentiableAt_const)
+  have hB : MDifferentiableAt I' 𝓘(ℝ, W) B y :=
+    mdifferentiableAt_const.prodMk_space (mdifferentiableAt_const.prodMk_space hβ)
+  have hT0 : T (A.time, x) = (1, 0) := by
+    change (η A.time, (P (a x), (0 : V))) = (1, 0)
+    rw [ha0, map_zero]
+    exact Prod.ext A.time_value rfl
+  have hB0 : B y = (1, 0) := by
+    change ((1 : ℝ), ((0 : U), R (b y))) = (1, 0)
+    rw [hb1]
+    rfl
+  have hmodel : Smale.NativeTransversality.At (𝓘(ℝ, ℝ).prod I) I' 𝓘(ℝ, W) T B (A.time, x) y :=
+    MorseCancel.native_coordinate_plane_trace_transverse hα hβ hαs hβs hη A.time_rate.ne'
+  have hnative :=
+    (Degree.TransverseGerms.native_transversality_partial_diffeomorph_iff Φ hT hB
+          (hB0.trans hT0.symm) (hT0 ▸ h1)).mp
+      hmodel
+  have hq :
+    Filter.Tendsto (fun p : ℝ × X => (p.1, a p.2)) (𝓝 (A.time, x)) (𝓝 (A.time, (0 : W))) := by
+    have hcont : ContinuousAt (fun p : ℝ × X => (p.1, a p.2)) (A.time, x) :=
+      continuousAt_fst.prodMk
+        (ContinuousAt.comp (g := a) (f := fun p : ℝ × X => p.2) ha.continuousAt continuousAt_snd)
+    simpa only [ha0] using hcont.tendsto
+  have hFgerm : (fun p : ℝ × X => A.family (p.1, f p.2)) =ᶠ[𝓝 (A.time, x)] (Φ ∘ T) := by
+    filter_upwards [hq.eventually (A.native_germ h0 A.time),
+      continuous_snd.continuousAt.eventually hfn, continuous_snd.continuousAt.eventually hca] with
+      p hmove hp hplane
+    have hpoint : Φ (a p.2) = f p.2 := Φ.right_inv hp
+    calc
+      A.family (p.1, f p.2) = A.family (p.1, Φ (a p.2)) :=
+        congrArg (fun z => A.family (p.1, z)) hpoint.symm
+      _ = Φ ((a p.2).1 + η p.1, (a p.2).2) := hmove
+      _ = (Φ ∘ T) p := by
+        apply congrArg Φ
+        change ((a p.2).1 + η p.1, (a p.2).2) = (η p.1, ((a p.2).2.1, 0))
+        rw [hplane.1, zero_add]
+        exact Prod.ext rfl (Prod.ext rfl hplane.2)
+  have hGgerm : g =ᶠ[𝓝 y] (Φ ∘ B) := by
+    filter_upwards [hgn, hcb] with q hq hplane
+    calc
+      g q = Φ (b q) := (Φ.right_inv hq).symm
+      _ = (Φ ∘ B) q := congrArg Φ (Prod.ext hplane.1 (Prod.ext hplane.2 rfl))
+  intro _
+  rw [hFgerm.mfderiv_eq, hGgerm.mfderiv_eq]
+  exact hnative (congrArg Φ (hB0.trans hT0.symm))
+
+private theorem
+    MorseCancel.exists_clean_two_sheet_arc_avoiding {E M X Y Z : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [TopologicalSpace X]
+    [ChartedSpace (EuclideanSpace ℝ (Fin 2)) X] [IsManifold (𝓡 2) ∞ X] [CompactSpace X]
+    [SecondCountableTopology X] [TopologicalSpace Y] [ChartedSpace (EuclideanSpace ℝ (Fin 2)) Y]
+    [IsManifold (𝓡 2) ∞ Y] [CompactSpace Y] [SecondCountableTopology Y] [TopologicalSpace Z]
+    [ChartedSpace (EuclideanSpace ℝ (Fin 2)) Z] [IsManifold (𝓡 2) ∞ Z] [SecondCountableTopology Z]
+    {f : X → M} {g : Y → M} {b : Z → M} (hf : ContMDiff (𝓡 2) 𝓘(ℝ, E) ∞ f)
+    (hg : ContMDiff (𝓡 2) 𝓘(ℝ, E) ∞ g) (hfe : Topology.IsEmbedding f)
+    (hge : Topology.IsEmbedding g) (hfi : ∀ x, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, E) f x))
+    (hgi : ∀ y, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, E) g y)) (hb : ContMDiff (𝓡 2) 𝓘(ℝ, E) ∞ b)
+    (hbc : IsClosed (Set.range b)) (hdim : Module.finrank ℝ E = 5) (x : X) (y : Y)
+    (hx : f x ∉ Set.range g) (hy : g y ∉ Set.range f) (hbx : f x ∉ Set.range b)
+    (hby : g y ∉ Set.range b) (γ : Path (f x) (g y)) :
+    ∃ Φ Ψ :
+      PartialDiffeomorph 𝓘(ℝ, (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))))
+        𝓘(ℝ, E) (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) M ∞,
+      (0 : (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))) ∈ Φ.source ∧
+        ((1 : ℝ), (0 : (EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) ∈ Ψ.source ∧
+          Φ 0 = f x ∧
+            Ψ (1, 0) = g y ∧
+              (∀ z ∈ Φ.source, Φ z ∈ Set.range f ↔ z.1 = 0 ∧ z.2.2 = 0) ∧
+                (∀ z ∈ Ψ.source, Ψ z ∈ Set.range g ↔ z.1 = 1 ∧ z.2.1 = 0) ∧
+                  ∃ a : C(ℝ, M),
+                    ContMDiff 𝓘(ℝ, ℝ) 𝓘(ℝ, E) ∞ a ∧
+                      (a =ᶠ[𝓝 (0 : ℝ)] fun t => Φ (t, 0)) ∧
+                        (a =ᶠ[𝓝 (1 : ℝ)] fun t => Ψ (t, 0)) ∧
+                          Topology.IsClosedEmbedding (fun t : unitInterval => a t) ∧
+                            (∀ t ∈ Set.Icc (0 : ℝ) 1,
+                                Function.Injective (mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, E) a t)) ∧
+                              (∀ t ∈ Set.Icc (0 : ℝ) 1, a t ∈ Set.range f ↔ t = 0) ∧
+                                (∀ t ∈ Set.Icc (0 : ℝ) 1, a t ∈ Set.range g ↔ t = 1) ∧
+                                  Set.MapsTo a (Set.Icc (0 : ℝ) 1) (Set.range b)ᶜ := by
+  obtain ⟨Φ, Ψ, hΦ0, hΨ1, hΦx, hΨy, hΦavoid, hΨavoid, hΦrec, hΨrec, -⟩ :=
+    exists_clean_two_sheet_arc hf hg hfe hge hfi hgi hdim x y hx hy γ
+  let o : C((X ⊕ Y) ⊕ Z, M) :=
+    ⟨Sum.elim (Sum.elim f g) b, (hf.continuous.sumElim hg.continuous).sumElim hb.continuous⟩
+  have ho : ContMDiff (𝓡 2) 𝓘(ℝ, E) ∞ o := (hf.sumElim hg).sumElim hb
+  have horange : Set.range o = (Set.range f ∪ Set.range g) ∪ Set.range b := by
+    ext z
+    constructor
+    · rintro ⟨(a | c) | d, he⟩
+      · exact Or.inl (Or.inl ⟨a, he⟩)
+      · exact Or.inl (Or.inr ⟨c, he⟩)
+      · exact Or.inr ⟨d, he⟩
+    · rintro ((⟨a, he⟩ | ⟨c, he⟩) | ⟨d, he⟩)
+      · exact ⟨Sum.inl (Sum.inl a), he⟩
+      · exact ⟨Sum.inl (Sum.inr c), he⟩
+      · exact ⟨Sum.inr d, he⟩
+  have hoclosed : IsClosed (Set.range o) := by
+    rw [horange]
+    exact
+      ((isCompact_range hf.continuous).isClosed.union
+            (isCompact_range hg.continuous).isClosed).union
+        hbc
+  obtain ⟨U, hU, h0U, hUΦ, ha, hia⟩ := chart_axis_curve_properties Φ 0 hΦ0
+  obtain ⟨V, hV, h1V, hVΨ, hc, hic⟩ := chart_axis_curve_properties Ψ 1 hΨ1
+  have hnear0 :
+    ∀ᶠ t in 𝓝 (0 : ℝ),
+      Φ (t, (0 : (EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) ∉ Set.range b :=
+    (ha.contMDiffAt (hU.mem_nhds h0U)).continuousAt.eventually
+      (hbc.isOpen_compl.mem_nhds (by change Φ 0 ∉ Set.range b; rw [hΦx]; exact hbx))
+  have hnear1 :
+    ∀ᶠ t in 𝓝 (1 : ℝ),
+      Ψ (t, (0 : (EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) ∉ Set.range b :=
+    (hc.contMDiffAt (hV.mem_nhds h1V)).continuousAt.eventually
+      (hbc.isOpen_compl.mem_nhds (by change Ψ (1, 0) ∉ Set.range b; rw [hΨy]; exact hby))
+  have hclean0 :
+    ∀ᶠ t in 𝓝 (0 : ℝ),
+      Φ (t, (0 : (EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) ∈ Set.range o →
+        t = 0 := by
+    filter_upwards [hU.mem_nhds h0U, hnear0] with t ht hb'
+    rw [horange]
+    rintro ((h | h) | h)
+    · exact ((hΦrec (t, 0) (hUΦ t ht)).mp h).1
+    · exact (hΦavoid (Φ.map_source' (hUΦ t ht)) h).elim
+    · exact (hb' h).elim
+  have hclean1 :
+    ∀ᶠ t in 𝓝 (1 : ℝ),
+      Ψ (t, (0 : (EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) ∈ Set.range o →
+        t = 1 := by
+    filter_upwards [hV.mem_nhds h1V, hnear1] with t ht hb'
+    rw [horange]
+    rintro ((h | h) | h)
+    · exact (hΨavoid (Ψ.map_source' (hVΨ t ht)) h).elim
+    · exact ((hΨrec (t, 0) (hVΨ t ht)).mp h).1
+    · exact (hb' h).elim
+  have hends : Φ (0, 0) ≠ Ψ (1, 0) := by
+    change Φ 0 ≠ Ψ (1, 0)
+    rw [hΦx, hΨy]
+    exact fun h => hx ⟨y, h.symm⟩
+  obtain ⟨a, ha', hleft, hright, hemb, hi, havoid⟩ :=
+    exists_clean_arc_with_local_endpoint_germs ha hc hU hV h0U h1V hia hic (γ.cast hΦx hΨy) hends
+      (by omega) o ho hoclosed (by rw [finrank_euclideanSpace_fin, hdim]; norm_num) hclean0
+      hclean1
+  have ha0 : a 0 = f x := hleft.eq_of_nhds.trans hΦx
+  have ha1 : a 1 = g y := hright.eq_of_nhds.trans hΨy
+  refine ⟨Φ, Ψ, hΦ0, hΨ1, hΦx, hΨy, hΦrec, hΨrec, a, ha', hleft, hright, hemb, hi, ?_, ?_, ?_⟩
+  · intro t ht
+    constructor
+    · intro h
+      by_contra ht0
+      have ht1 : t ≠ 1 := by intro he; subst t; rw [ha1] at h; exact hy h
+      exact
+        havoid t ⟨lt_of_le_of_ne ht.1 (Ne.symm ht0), lt_of_le_of_ne ht.2 ht1⟩
+          (horange.symm ▸ Or.inl (Or.inl h))
+    · intro he
+      subst t
+      rw [ha0]
+      exact Set.mem_range_self x
+  · intro t ht
+    constructor
+    · intro h
+      by_contra ht1
+      have ht0 : t ≠ 0 := by intro he; subst t; rw [ha0] at h; exact hx h
+      exact
+        havoid t ⟨lt_of_le_of_ne ht.1 (Ne.symm ht0), lt_of_le_of_ne ht.2 ht1⟩
+          (horange.symm ▸ Or.inl (Or.inr h))
+    · intro he
+      subst t
+      rw [ha1]
+      exact Set.mem_range_self y
+  · intro t ht htb
+    have ht0 : t ≠ 0 := by intro he; subst t; rw [ha0] at htb; exact hbx htb
+    have ht1 : t ≠ 1 := by intro he; subst t; rw [ha1] at htb; exact hby htb
+    exact
+      havoid t ⟨lt_of_le_of_ne ht.1 (Ne.symm ht0), lt_of_le_of_ne ht.2 ht1⟩
+        (horange.symm ▸ Or.inr htb)
+
+private theorem
+    AdaptedWindows.exists_forward_basin_smooth_images {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f) :
+    ∃ r : ℝ,
+      0 < r ∧
+        (∀ n : ℕ,
+            ContMDiffOn 𝓘(ℝ, (S.data p).chart.PositiveCoordinates) 𝓘(ℝ, E) ∞
+              (fun v => S.flow (-(n : ℝ)) ((S.data p).chart.splitChart.symm (0, v)))
+              (Metric.ball 0 r)) ∧
+          {x : M | Filter.Tendsto (fun t => S.flow t x) Filter.atTop (𝓝 p.val)} =
+            ⋃ n : ℕ,
+              (fun v => S.flow (-(n : ℝ)) ((S.data p).chart.splitChart.symm (0, v))) ''
+                Metric.ball (0 : (S.data p).chart.PositiveCoordinates) r := by
+  let c := (S.data p).chart
+  obtain ⟨r, hr, hblock, hbasin⟩ :=
+    MorseCancel.exists_descending_morse_basin_block c hf (S.smooth.of_le (by simp)) S.flow
+      S.integral S.zero S.descent (S.critical_model_germ p)
+  have htarget (v : c.PositiveCoordinates) (hv : v ∈ Metric.ball 0 (r / 2)) :
+    (0, v) ∈ c.splitChart.target :=
+    hblock
+      ⟨Metric.mem_closedBall_self hr.le,
+        Metric.closedBall_subset_closedBall (by linarith : r / 2 ≤ r)
+          (Metric.ball_subset_closedBall hv)⟩
+  have hlocal :
+    ContMDiffOn 𝓘(ℝ, c.PositiveCoordinates) 𝓘(ℝ, E) ∞ (fun v => c.splitChart.symm (0, v))
+      (Metric.ball 0 (r / 2)) :=
+    c.splitChart.contMDiffOn_invFun.comp (contDiff_const.prodMk contDiff_id).contMDiff.contMDiffOn
+      htarget
+  have hpoint (v : c.PositiveCoordinates) (hv : v ∈ Metric.ball 0 (r / 2)) :
+    Filter.Tendsto (fun t => S.flow t (c.splitChart.symm (0, v))) Filter.atTop (𝓝 p.val) := by
+    have ht := htarget v hv
+    have hs : c.splitChart.symm (0, v) ∈ c.splitChart.source := c.splitChart.map_target' ht
+    have he : c.splitChart (c.splitChart.symm (0, v)) = (0, v) := c.splitChart.right_inv' ht
+    apply ((hbasin (c.splitChart.symm (0, v)) hs ?_ ?_).1).mpr
+    · rw [he]
+    · rw [he]
+      simpa using hr
+    · rw [he]
+      exact (mem_ball_zero_iff.mp hv).trans (half_lt_self hr)
+  refine ⟨r / 2, half_pos hr, ?_, ?_⟩
+  · intro n
+    exact
+      (Degree.SmoothODE.nativeFlowTimeDiffeomorph_of_field S.smooth S.flow S.integral
+            (-(n : ℝ))).contMDiff.comp_contMDiffOn
+        hlocal
+  · ext x
+    constructor
+    · intro hx
+      have hlim := hx.comp tendsto_natCast_atTop_atTop
+      obtain ⟨n, hs, hn, hp'⟩ :=
+        (hlim.eventually
+            (MorseCancel.morse_coordinate_neighborhood c (half_pos hr) (half_pos hr))).exists
+      have hnew := (MorseCancel.flow_time_atTop_limit_iff S.flow (n : ℝ) x p.val).mpr hx
+      have hz : (c.splitChart (S.flow (n : ℝ) x)).1 = 0 :=
+        ((hbasin _ hs (hn.trans (half_lt_self hr)) (hp'.trans (half_lt_self hr))).1).mp hnew
+      refine
+        Set.mem_iUnion.mpr ⟨n, (c.splitChart (S.flow (n : ℝ) x)).2, mem_ball_zero_iff.mpr hp', ?_⟩
+      have he : (0, (c.splitChart (S.flow (n : ℝ) x)).2) = c.splitChart (S.flow (n : ℝ) x) :=
+        Prod.ext hz.symm rfl
+      change S.flow (-(n : ℝ)) (c.splitChart.symm (0, (c.splitChart (S.flow (n : ℝ) x)).2)) = x
+      rw [he]
+      have hi : c.splitChart.symm (c.splitChart (S.flow (n : ℝ) x)) = S.flow (n : ℝ) x :=
+        c.splitChart.left_inv' hs
+      rw [hi, ← S.flow.map_add, neg_add_cancel, S.flow.map_zero_apply]
+    · intro hx
+      obtain ⟨n, v, hv, rfl⟩ := Set.mem_iUnion.mp hx
+      exact
+        (MorseCancel.flow_time_atTop_limit_iff S.flow (-(n : ℝ)) (c.splitChart.symm (0, v))
+              p.val).mpr
+          (hpoint v hv)
+
+private theorem
+    AdaptedWindows.exists_backward_basin_smooth_images {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f) :
+    ∃ r : ℝ,
+      0 < r ∧
+        (∀ n : ℕ,
+            ContMDiffOn 𝓘(ℝ, (S.data p).chart.NegativeCoordinates) 𝓘(ℝ, E) ∞
+              (fun v => S.flow (n : ℝ) ((S.data p).chart.splitChart.symm (v, 0)))
+              (Metric.ball 0 r)) ∧
+          {x : M | Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 p.val)} =
+            ⋃ n : ℕ,
+              (fun v => S.flow (n : ℝ) ((S.data p).chart.splitChart.symm (v, 0))) ''
+                Metric.ball (0 : (S.data p).chart.NegativeCoordinates) r := by
+  let c := (S.data p).chart
+  obtain ⟨r, hr, hblock, hbasin⟩ :=
+    MorseCancel.exists_descending_morse_basin_block c hf (S.smooth.of_le (by simp)) S.flow
+      S.integral S.zero S.descent (S.critical_model_germ p)
+  have htarget (v : c.NegativeCoordinates) (hv : v ∈ Metric.ball 0 (r / 2)) :
+    (v, 0) ∈ c.splitChart.target :=
+    hblock
+      ⟨Metric.closedBall_subset_closedBall (by linarith : r / 2 ≤ r)
+          (Metric.ball_subset_closedBall hv),
+        Metric.mem_closedBall_self hr.le⟩
+  have hlocal :
+    ContMDiffOn 𝓘(ℝ, c.NegativeCoordinates) 𝓘(ℝ, E) ∞ (fun v => c.splitChart.symm (v, 0))
+      (Metric.ball 0 (r / 2)) :=
+    c.splitChart.contMDiffOn_invFun.comp (contDiff_id.prodMk contDiff_const).contMDiff.contMDiffOn
+      htarget
+  have hpoint (v : c.NegativeCoordinates) (hv : v ∈ Metric.ball 0 (r / 2)) :
+    Filter.Tendsto (fun t => S.flow t (c.splitChart.symm (v, 0))) Filter.atBot (𝓝 p.val) := by
+    have ht := htarget v hv
+    have hs : c.splitChart.symm (v, 0) ∈ c.splitChart.source := c.splitChart.map_target' ht
+    have he : c.splitChart (c.splitChart.symm (v, 0)) = (v, 0) := c.splitChart.right_inv' ht
+    apply ((hbasin (c.splitChart.symm (v, 0)) hs ?_ ?_).2).mpr
+    · rw [he]
+    · rw [he]
+      exact (mem_ball_zero_iff.mp hv).trans (half_lt_self hr)
+    · rw [he]
+      simpa using hr
+  refine ⟨r / 2, half_pos hr, ?_, ?_⟩
+  · intro n
+    exact
+      (Degree.SmoothODE.nativeFlowTimeDiffeomorph_of_field S.smooth S.flow S.integral
+            (n : ℝ)).contMDiff.comp_contMDiffOn
+        hlocal
+  · ext x
+    constructor
+    · intro hx
+      have hlim : Filter.Tendsto (fun n : ℕ => S.flow (-(n : ℝ)) x) Filter.atTop (𝓝 p.val) :=
+        hx.comp (Filter.tendsto_neg_atTop_atBot.comp tendsto_natCast_atTop_atTop)
+      obtain ⟨n, hs, hn, hp'⟩ :=
+        (hlim.eventually
+            (MorseCancel.morse_coordinate_neighborhood c (half_pos hr) (half_pos hr))).exists
+      have hnew := (MorseCancel.flow_time_atBot_limit_iff S.flow (-(n : ℝ)) x p.val).mpr hx
+      have hz : (c.splitChart (S.flow (-(n : ℝ)) x)).2 = 0 :=
+        ((hbasin _ hs (hn.trans (half_lt_self hr)) (hp'.trans (half_lt_self hr))).2).mp hnew
+      refine
+        Set.mem_iUnion.mpr
+          ⟨n, (c.splitChart (S.flow (-(n : ℝ)) x)).1, mem_ball_zero_iff.mpr hn, ?_⟩
+      have he :
+        ((c.splitChart (S.flow (-(n : ℝ)) x)).1, 0) = c.splitChart (S.flow (-(n : ℝ)) x) :=
+        Prod.ext rfl hz.symm
+      change S.flow (n : ℝ) (c.splitChart.symm ((c.splitChart (S.flow (-(n : ℝ)) x)).1, 0)) = x
+      rw [he]
+      have hi : c.splitChart.symm (c.splitChart (S.flow (-(n : ℝ)) x)) = S.flow (-(n : ℝ)) x :=
+        c.splitChart.left_inv' hs
+      rw [hi, ← S.flow.map_add, add_neg_cancel, S.flow.map_zero_apply]
+    · intro hx
+      obtain ⟨n, v, hv, rfl⟩ := Set.mem_iUnion.mp hx
+      exact
+        (MorseCancel.flow_time_atBot_limit_iff S.flow (n : ℝ) (c.splitChart.symm (v, 0))
+              p.val).mpr
+          (hpoint v hv)
+
+private theorem MorseCancel.exists_smooth_ball_parametrization {V : Type*} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] [FiniteDimensional ℝ V] {d : ℕ} (hd : Module.finrank ℝ V ≤ d) {r : ℝ}
+    (hr : 0 < r) :
+    ∃ ψ : EuclideanSpace ℝ (Fin d) → V, ContDiff ℝ ∞ ψ ∧ Set.range ψ = Metric.ball 0 r := by
+  let W := EuclideanSpace ℝ (Fin (d - Module.finrank ℝ V))
+  let L : EuclideanSpace ℝ (Fin d) ≃L[ℝ] (V × W) :=
+    ContinuousLinearEquiv.ofFinrankEq
+      (by
+        simp only [Module.finrank_prod, finrank_euclideanSpace_fin, W]
+        omega)
+  let π : EuclideanSpace ℝ (Fin d) →L[ℝ] V :=
+    (ContinuousLinearMap.fst ℝ V W).comp L.toContinuousLinearMap
+  have hπ : Function.Surjective π := by
+    intro v
+    refine ⟨L.symm (v, 0), ?_⟩
+    change (L (L.symm (v, 0))).1 = v
+    rw [L.apply_symm_apply]
+  let B := OpenPartialHomeomorph.univBall (0 : V) r
+  let ψ : EuclideanSpace ℝ (Fin d) → V := B ∘ π
+  have hψ : ContDiff ℝ ∞ ψ := OpenPartialHomeomorph.contDiff_univBall.comp π.contDiff
+  refine ⟨ψ, hψ, ?_⟩
+  ext v
+  constructor
+  · rintro ⟨z, rfl⟩
+    have hm : π z ∈ B.source := by rw [OpenPartialHomeomorph.univBall_source]; trivial
+    have hh := B.map_source hm
+    rwa [OpenPartialHomeomorph.univBall_target _ hr] at hh
+  · intro hv
+    have hvt : v ∈ B.target := by rw [OpenPartialHomeomorph.univBall_target _ hr]; exact hv
+    obtain ⟨z, hz⟩ := hπ (B.symm v)
+    refine ⟨z, ?_⟩
+    change B (π z) = v
+    rw [hz]
+    exact B.right_inv hvt
+
+private theorem MorseCancel.exists_global_smooth_image_of_ball {V : Type*} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] [FiniteDimensional ℝ V] {E H M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [TopologicalSpace M]
+    [ChartedSpace H M] {d : ℕ} (hd : Module.finrank ℝ V ≤ d) {r : ℝ} (hr : 0 < r) {f : V → M}
+    (hf : ContMDiffOn 𝓘(ℝ, V) I ∞ f (Metric.ball 0 r)) :
+    ∃ g : EuclideanSpace ℝ (Fin d) → M,
+      ContMDiff 𝓘(ℝ, EuclideanSpace ℝ (Fin d)) I ∞ g ∧ Set.range g = f '' Metric.ball 0 r := by
+  obtain ⟨ψ, hψ, hrange⟩ := exists_smooth_ball_parametrization hd hr
+  refine ⟨f ∘ ψ, ?_, ?_⟩
+  · intro x
+    have hx : ψ x ∈ Metric.ball (0 : V) r := hrange ▸ Set.mem_range_self x
+    exact (hf.contMDiffAt (Metric.isOpen_ball.mem_nhds hx)).comp x hψ.contMDiff.contMDiffAt
+  · rw [Set.range_comp, hrange]
+
+private theorem Degree.FlowCancellation.native_flow_eq_on_positive_halfline {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M] {V W : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F G : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hG : ∀ x, IsMIntegralCurve (fun t => G t x) W) {x : M}
+    (hagrees : ∀ t : ℝ, 0 ≤ t → W (G t x) = V (G t x)) : ∀ t : ℝ, 0 ≤ t → G t x = F t x := by
+  intro t ht
+  rcases ht.eq_or_lt with ht | ht
+  · subst t
+    rw [G.map_zero_apply, F.map_zero_apply]
+  · have hc : IsMIntegralCurveOn (fun s => G s x) V (Set.Ioo (0 : ℝ) t) := by
+      intro s hs
+      have hd := hG x s
+      rw [hagrees s hs.1.le] at hd
+      exact hd.hasMFDerivWithinAt
+    have hh :=
+      Degree.FlowSuspension.native_flow_segment_endpoints hV F hF ht
+        (hG x).continuous.continuousOn hc
+    simpa only [sub_zero, G.map_zero_apply] using hh.symm
+
+private theorem Degree.FlowCancellation.native_flow_eq_on_negative_halfline {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M] {V W : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F G : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hG : ∀ x, IsMIntegralCurve (fun t => G t x) W) {x : M}
+    (hagrees : ∀ t : ℝ, t ≤ 0 → W (G t x) = V (G t x)) : ∀ t : ℝ, t ≤ 0 → G t x = F t x := by
+  intro t ht
+  rcases ht.lt_or_eq with ht | ht
+  · have hc : IsMIntegralCurveOn (fun s => G s x) V (Set.Ioo t (0 : ℝ)) := by
+      intro s hs
+      have hd := hG x s
+      rw [hagrees s hs.2.le] at hd
+      exact hd.hasMFDerivWithinAt
+    have hh :=
+      Degree.FlowSuspension.native_flow_segment_endpoints hV F hF ht
+        (hG x).continuous.continuousOn hc
+    have he := congrArg (F t) hh
+    simpa only [zero_sub, ← F.map_add, add_neg_cancel, F.map_zero_apply, G.map_zero_apply] using
+      he
+  · subst t
+    rw [G.map_zero_apply, F.map_zero_apply]
+
+public
+theorem Degree.FlowCancellation.exists_level_crossing_of_endpoint_limits {X : Type*}
+    [TopologicalSpace X] (F : Flow ℝ X) {f : X → ℝ} (hf : Continuous f) {x p q : X}
+    (hp : Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p))
+    (hq : Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 q)) {c : ℝ} (hpc : c < f p)
+    (hqc : f q < c) : ∃ t, f (F t x) = c := by
+  have htop : Filter.Tendsto (fun t => f (F t x)) Filter.atTop (𝓝 (f q)) :=
+    hf.continuousAt.tendsto.comp hq
+  have hbot : Filter.Tendsto (fun t => f (F t x)) Filter.atBot (𝓝 (f p)) :=
+    hf.continuousAt.tendsto.comp hp
+  obtain ⟨s, hs⟩ := (htop.eventually (eventually_lt_nhds hqc)).exists
+  obtain ⟨t, ht⟩ := (hbot.eventually (eventually_gt_nhds hpc)).exists
+  exact
+    mem_range_of_exists_le_of_exists_ge (hf.comp (F.continuous continuous_id continuous_const))
+      ⟨s, hs.le⟩ ⟨t, ht.le⟩
+
+private def MorseCancel.forwardHighBasins {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (a : ℝ) : Set M :=
+  {x |
+    ∃ p : Smale.ManifoldMorse.criticalPoints E f,
+      a ≤ f p ∧ Filter.Tendsto (fun t => S.flow t x) Filter.atTop (𝓝 p.val)}
+
+private def MorseCancel.backwardLowBasins {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (a : ℝ) : Set M :=
+  {x |
+    ∃ p : Smale.ManifoldMorse.criticalPoints E f,
+      f p ≤ a ∧ Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 p.val)}
+
+private theorem MorseCancel.forwardHighBasins_eq_inter {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (a : ℝ) : forwardHighBasins S a = ⋂ t : ℝ, {x | a ≤ f (S.flow t x)} := by
+  ext x
+  simp only [Set.mem_iInter, Set.mem_ofPred_eq]
+  constructor
+  · rintro ⟨p, hp, hlim⟩ t
+    have hmono :=
+      Smale.FlowConstruction.antitone_flow_height hf S.flow S.integral S.zero S.descent x
+    exact hp.trans (hmono.le_of_tendsto (hf.continuous.continuousAt.tendsto.comp hlim) t)
+  · intro hbound
+    obtain ⟨-, -, q, hq, -, hlim, -⟩ :=
+      Degree.FlowCancellation.exists_native_descent_endpoints hf S.smooth S.flow S.integral S.zero
+        S.descent S.distinct x
+    refine ⟨⟨q, hq⟩, ?_, hlim⟩
+    exact
+      ge_of_tendsto (hf.continuous.continuousAt.tendsto.comp hlim)
+        (Filter.Eventually.of_forall hbound)
+
+private theorem MorseCancel.backwardLowBasins_eq_inter {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (a : ℝ) : backwardLowBasins S a = ⋂ t : ℝ, {x | f (S.flow t x) ≤ a} := by
+  ext x
+  simp only [Set.mem_iInter, Set.mem_ofPred_eq]
+  constructor
+  · rintro ⟨p, hp, hlim⟩ t
+    have hmono :=
+      Smale.FlowConstruction.antitone_flow_height hf S.flow S.integral S.zero S.descent x
+    exact (hmono.ge_of_tendsto (hf.continuous.continuousAt.tendsto.comp hlim) t).trans hp
+  · intro hbound
+    obtain ⟨p, hp, -, -, hlim, -, -⟩ :=
+      Degree.FlowCancellation.exists_native_descent_endpoints hf S.smooth S.flow S.integral S.zero
+        S.descent S.distinct x
+    refine ⟨⟨p, hp⟩, ?_, hlim⟩
+    exact
+      le_of_tendsto (hf.continuous.continuousAt.tendsto.comp hlim)
+        (Filter.Eventually.of_forall hbound)
+
+private theorem MorseCancel.isClosed_endpoint_obstruction {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (a : ℝ) : IsClosed (forwardHighBasins S a ∪ backwardLowBasins S a) := by
+  rw [forwardHighBasins_eq_inter S hf, backwardLowBasins_eq_inter S hf]
+  apply IsClosed.union
+  · exact
+      isClosed_iInter
+        (fun t =>
+          isClosed_le continuous_const
+            (hf.continuous.comp (S.flow.continuous continuous_const continuous_id)))
+  · exact
+      isClosed_iInter
+        (fun t =>
+          isClosed_le (hf.continuous.comp (S.flow.continuous continuous_const continuous_id))
+            continuous_const)
+
+private theorem
+    MorseCancel.levelBasin_compl_eq_endpoint_obstruction {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    {a : ℝ} (hreg : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    (Degree.FlowCancellation.levelBasin S.flow f a)ᶜ =
+      forwardHighBasins S a ∪ backwardLowBasins S a := by
+  ext x
+  constructor
+  · intro hx
+    obtain ⟨p, hp, q, hq, hback, hforward, -⟩ :=
+      Degree.FlowCancellation.exists_native_descent_endpoints hf S.smooth S.flow S.integral S.zero
+        S.descent S.distinct x
+    by_cases hqa : a ≤ f q
+    · exact Or.inl ⟨⟨q, hq⟩, hqa, hforward⟩
+    by_cases hpa : f p ≤ a
+    · exact Or.inr ⟨⟨p, hp⟩, hpa, hback⟩
+    exact
+      False.elim
+        (hx
+          (Degree.FlowCancellation.exists_level_crossing_of_endpoint_limits S.flow hf.continuous
+            hback hforward (lt_of_not_ge hpa) (lt_of_not_ge hqa)))
+  · intro hx hcross
+    obtain ⟨t, ht⟩ := hcross
+    have hmono :=
+      Smale.FlowConstruction.antitone_flow_height hf S.flow S.integral S.zero S.descent x
+    rcases hx with ⟨p, hp, hlim⟩ | ⟨p, hp, hlim⟩
+    · have hh := hmono.le_of_tendsto (hf.continuous.continuousAt.tendsto.comp hlim) t
+      rw [ht] at hh
+      exact hreg p (le_antisymm hh hp) p.property
+    · have hh := hmono.ge_of_tendsto (hf.continuous.continuousAt.tendsto.comp hlim) t
+      rw [ht] at hh
+      exact hreg p (le_antisymm hp hh) p.property
+
+private theorem
+    AdaptedWindows.exists_forward_basin_global_images {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f) {d : ℕ}
+    (hd : Module.finrank ℝ E - MorseCancel.nativeMorseIndex E f p ≤ d) :
+    ∃ g : ℕ → EuclideanSpace ℝ (Fin d) → M,
+      (∀ n, ContMDiff 𝓘(ℝ, EuclideanSpace ℝ (Fin d)) 𝓘(ℝ, E) ∞ (g n)) ∧
+        {x : M | Filter.Tendsto (fun t => S.flow t x) Filter.atTop (𝓝 p.val)} =
+          ⋃ n, Set.range (g n) := by
+  obtain ⟨r, hr, hsmooth, hcover⟩ := S.exists_forward_basin_smooth_images hf p
+  have hdim : Module.finrank ℝ (S.data p).chart.PositiveCoordinates ≤ d := by
+    have hh := (S.data p).chart.finrank_negative_add_positive
+    rw [MorseCancel.nativeMorseIndex_eq_chart (S.data p).chart] at hd
+    omega
+  choose g hg hrange using
+    (fun n => MorseCancel.exists_global_smooth_image_of_ball hdim hr (hsmooth n))
+  refine ⟨g, hg, ?_⟩
+  rw [hcover]
+  exact Set.iUnion_congr (fun n => (hrange n).symm)
+
+private theorem
+    AdaptedWindows.exists_backward_basin_global_images {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f) {d : ℕ}
+    (hd : MorseCancel.nativeMorseIndex E f p ≤ d) :
+    ∃ g : ℕ → EuclideanSpace ℝ (Fin d) → M,
+      (∀ n, ContMDiff 𝓘(ℝ, EuclideanSpace ℝ (Fin d)) 𝓘(ℝ, E) ∞ (g n)) ∧
+        {x : M | Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 p.val)} =
+          ⋃ n, Set.range (g n) := by
+  obtain ⟨r, hr, hsmooth, hcover⟩ := S.exists_backward_basin_smooth_images hf p
+  have hdim : Module.finrank ℝ (S.data p).chart.NegativeCoordinates ≤ d := by
+    rwa [MorseCancel.nativeMorseIndex_eq_chart (S.data p).chart] at hd
+  choose g hg hrange using
+    (fun n => MorseCancel.exists_global_smooth_image_of_ball hdim hr (hsmooth n))
+  refine ⟨g, hg, ?_⟩
+  rw [hcover]
+  exact Set.iUnion_congr (fun n => (hrange n).symm)
+
+private abbrev MorseCancel.EndpointBasinIndex {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} (a : ℝ) :=
+  ({ p : Smale.ManifoldMorse.criticalPoints E f // a ≤ f p.val } × ℕ) ⊕
+    ({ p : Smale.ManifoldMorse.criticalPoints E f // f p.val ≤ a } × ℕ)
+
+private theorem MorseCancel.endpointBasinIndex_countable {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (a : ℝ) : Countable (EndpointBasinIndex (E := E) (f := f) a) := by
+  let _ := S.finite.fintype
+  unfold EndpointBasinIndex
+  infer_instance
+
+private theorem AdaptedWindows.exists_endpoint_obstruction_global_images {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (a : ℝ) {d : ℕ}
+    (hhigh :
+      ∀ p : Smale.ManifoldMorse.criticalPoints E f,
+        a ≤ f p → Module.finrank ℝ E - MorseCancel.nativeMorseIndex E f p ≤ d)
+    (hlow :
+      ∀ p : Smale.ManifoldMorse.criticalPoints E f,
+        f p ≤ a → MorseCancel.nativeMorseIndex E f p ≤ d) :
+    ∃ g : MorseCancel.EndpointBasinIndex (E := E) (f := f) a → EuclideanSpace ℝ (Fin d) → M,
+      (∀ i, ContMDiff 𝓘(ℝ, EuclideanSpace ℝ (Fin d)) 𝓘(ℝ, E) ∞ (g i)) ∧
+        MorseCancel.forwardHighBasins S a ∪ MorseCancel.backwardLowBasins S a =
+          ⋃ i, Set.range (g i) := by
+  choose gF hgF hF using
+    (fun p : { p : Smale.ManifoldMorse.criticalPoints E f // a ≤ f p.val } =>
+      S.exists_forward_basin_global_images hf p.val (hhigh p.val p.property))
+  choose gB hgB hB using
+    (fun p : { p : Smale.ManifoldMorse.criticalPoints E f // f p.val ≤ a } =>
+      S.exists_backward_basin_global_images hf p.val (hlow p.val p.property))
+  let g : MorseCancel.EndpointBasinIndex (E := E) (f := f) a → EuclideanSpace ℝ (Fin d) → M :=
+    Sum.elim (fun i => gF i.1 i.2) (fun i => gB i.1 i.2)
+  refine ⟨g, ?_, ?_⟩
+  · intro i
+    rcases i with ⟨p, n⟩ | ⟨p, n⟩
+    · exact hgF p n
+    · exact hgB p n
+  · ext x
+    constructor
+    · rintro (⟨p, hp, hx⟩ | ⟨p, hp, hx⟩)
+      · have hh : x ∈ ⋃ n, Set.range (gF ⟨p, hp⟩ n) := (hF ⟨p, hp⟩) ▸ hx
+        obtain ⟨n, hn⟩ := Set.mem_iUnion.mp hh
+        exact Set.mem_iUnion.mpr ⟨Sum.inl (⟨p, hp⟩, n), hn⟩
+      · have hh : x ∈ ⋃ n, Set.range (gB ⟨p, hp⟩ n) := (hB ⟨p, hp⟩) ▸ hx
+        obtain ⟨n, hn⟩ := Set.mem_iUnion.mp hh
+        exact Set.mem_iUnion.mpr ⟨Sum.inr (⟨p, hp⟩, n), hn⟩
+    · intro hx
+      obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hx
+      rcases i with ⟨p, n⟩ | ⟨p, n⟩
+      · have hh : x ∈ {x : M | Filter.Tendsto (fun t => S.flow t x) Filter.atTop (𝓝 p.val.val)} :=
+          by
+          rw [hF p]
+          exact Set.mem_iUnion.mpr ⟨n, hi⟩
+        exact Or.inl ⟨p.val, p.property, hh⟩
+      · have hh : x ∈ {x : M | Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 p.val.val)} :=
+          by
+          rw [hB p]
+          exact Set.mem_iUnion.mpr ⟨n, hi⟩
+        exact Or.inr ⟨p.val, p.property, hh⟩
+
+private theorem MorseCancel.isClosed_backwardLowBasins {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (a : ℝ) : IsClosed (backwardLowBasins S a) := by
+  rw [backwardLowBasins_eq_inter S hf]
+  exact
+    isClosed_iInter
+      (fun t =>
+        isClosed_le (hf.continuous.comp (S.flow.continuous continuous_const continuous_id))
+          continuous_const)
+
+private abbrev
+    MorseCancel.LowBackwardBasinIndex {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} (a : ℝ) :=
+  { p : Smale.ManifoldMorse.criticalPoints E f // f p.val ≤ a } × ℕ
+
+private theorem MorseCancel.lowBackwardBasinIndex_countable {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (a : ℝ) : Countable (LowBackwardBasinIndex (E := E) (f := f) a) := by
+  let _ := S.finite.fintype
+  unfold LowBackwardBasinIndex
+  infer_instance
+
+private theorem
+    AdaptedWindows.exists_low_backward_obstruction_images {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (a : ℝ) {d : ℕ}
+    (hlow :
+      ∀ p : Smale.ManifoldMorse.criticalPoints E f,
+        f p ≤ a → MorseCancel.nativeMorseIndex E f p ≤ d) :
+    ∃ g : MorseCancel.LowBackwardBasinIndex (E := E) (f := f) a → EuclideanSpace ℝ (Fin d) → M,
+      (∀ i, ContMDiff 𝓘(ℝ, EuclideanSpace ℝ (Fin d)) 𝓘(ℝ, E) ∞ (g i)) ∧
+        MorseCancel.backwardLowBasins S a = ⋃ i, Set.range (g i) := by
+  choose g hg hcover using
+    (fun p : { p : Smale.ManifoldMorse.criticalPoints E f // f p.val ≤ a } =>
+      S.exists_backward_basin_global_images hf p.val (hlow p.val p.property))
+  refine ⟨fun i => g i.1 i.2, fun i => hg i.1 i.2, ?_⟩
+  ext x
+  constructor
+  · rintro ⟨p, hp, hx⟩
+    have hh : x ∈ ⋃ n, Set.range (g ⟨p, hp⟩ n) := (hcover ⟨p, hp⟩) ▸ hx
+    obtain ⟨n, hn⟩ := Set.mem_iUnion.mp hh
+    exact Set.mem_iUnion.mpr ⟨(⟨p, hp⟩, n), hn⟩
+  · intro hx
+    obtain ⟨⟨p, n⟩, hn⟩ := Set.mem_iUnion.mp hx
+    have hh : x ∈ {x : M | Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 p.val.val)} := by
+      rw [hcover p]
+      exact Set.mem_iUnion.mpr ⟨n, hn⟩
+    exact ⟨p.val, p.property, hh⟩
+
+private theorem MorseCancel.contMDiff_discrete_family {ι V E H M : Type*} [TopologicalSpace ι]
+    [DiscreteTopology ι] [NormedAddCommGroup V] [NormedSpace ℝ V] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [TopologicalSpace M]
+    [ChartedSpace H M] (f : ι → V → M) (hf : ∀ i, ContMDiff 𝓘(ℝ, V) I ∞ (f i)) :
+    let _ : ChartedSpace (EuclideanSpace ℝ (Fin 0)) ι := ChartedSpace.ofDiscreteTopology
+    ContMDiff (𝓘(ℝ, EuclideanSpace ℝ (Fin 0)).prod 𝓘(ℝ, V)) I ∞ (fun p : ι × V => f p.1 p.2) := by
+  let _ : ChartedSpace (EuclideanSpace ℝ (Fin 0)) ι := ChartedSpace.ofDiscreteTopology
+  change ContMDiff (𝓘(ℝ, EuclideanSpace ℝ (Fin 0)).prod 𝓘(ℝ, V)) I ∞ (fun p : ι × V => f p.1 p.2)
+  intro p
+  have hg :
+    ContMDiffAt (𝓘(ℝ, EuclideanSpace ℝ (Fin 0)).prod 𝓘(ℝ, V)) I ∞ (fun q : ι × V => f p.1 q.2)
+      p :=
+    (hf p.1).contMDiffAt.comp p contMDiffAt_snd
+  apply hg.congr_of_eventuallyEq
+  have hnear : ∀ᶠ q : ι × V in 𝓝 p, q.1 ∈ ({ p.1 } : Set ι) :=
+    ((isOpen_discrete ({ p.1 } : Set ι)).preimage continuous_fst).mem_nhds (Set.mem_singleton _)
+  filter_upwards [hnear] with q hq
+  rw [Set.mem_singleton_iff.mp hq]
+
+private theorem MorseCancel.range_discrete_family {ι V M : Type*}
+    (f : ι → V → M) : Set.range (fun p : ι × V => f p.1 p.2) = ⋃ i, Set.range (f i) := by
+  ext x
+  constructor
+  · rintro ⟨⟨i, v⟩, rfl⟩
+    exact Set.mem_iUnion.mpr ⟨i, v, rfl⟩
+  · intro hx
+    obtain ⟨i, v, hv⟩ := Set.mem_iUnion.mp hx
+    exact ⟨(i, v), hv⟩
+
+private theorem MorseCancel.joinedIn_sublevel_of_forward_limit {X : Type*} [TopologicalSpace X]
+    [LocallyPathConnectedSpace X] (F : Flow ℝ X) {f : X → ℝ} (hf : Continuous f)
+    (hmono : ∀ x, Antitone (fun t : ℝ => f (F t x))) {x p : X} {a : ℝ} (hx : f x ≤ a)
+    (hp : f p < a) (hlim : Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p)) :
+    JoinedIn {y : X | f y ≤ a} x p := by
+  have hU : {y : X | f y < a} ∈ 𝓝 p := (isOpen_lt hf continuous_const).mem_nhds hp
+  have hC := pathComponentIn_mem_nhds hU
+  obtain ⟨T, hT, hFT⟩ := ((Filter.eventually_ge_atTop (0 : ℝ)).and (hlim.eventually hC)).exists
+  have htail : JoinedIn {y : X | f y ≤ a} (F T x) p :=
+    (show JoinedIn {y : X | f y < a} p (F T x) from hFT).symm.mono
+      (fun y hy => (show f y < a from hy).le)
+  have hsegment : JoinedIn {y : X | f y ≤ a} x (F T x) := by
+    let γ : Path x (F T x) :=
+      { toFun := fun u => F ((u : ℝ) * T) x
+        continuous_toFun := F.continuous (continuous_subtype_val.mul_const T) continuous_const
+        source' := by simp
+        target' := by simp }
+    refine ⟨γ, fun u => ?_⟩
+    have htime : 0 ≤ (u : ℝ) * T := mul_nonneg u.property.1 hT
+    have hh := hmono x htime
+    have hh' : f (F ((u : ℝ) * T) x) ≤ f x := by simpa only [F.map_zero_apply] using hh
+    exact hh'.trans hx
+  exact hsegment.trans htail
+
+private theorem MorseCancel.joined_sublevel_of_common_forward_limit {X : Type*} [TopologicalSpace X]
+    [LocallyPathConnectedSpace X] (F : Flow ℝ X) {f : X → ℝ} (hf : Continuous f)
+    (hmono : ∀ x, Antitone (fun t : ℝ => f (F t x))) {a : ℝ} (x y : { z : X // f z ≤ a }) {p : X}
+    (hp : f p < a) (hx : Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p))
+    (hy : Filter.Tendsto (fun t => F t y) Filter.atTop (𝓝 p)) : Joined x y := by
+  exact
+    ((joinedIn_sublevel_of_forward_limit F hf hmono x.property hp hx).trans
+        (joinedIn_sublevel_of_forward_limit F hf hmono y.property hp hy).symm).joined_subtype
+
+private theorem MorseCancel.joinedIn_open_forward_basin {X : Type*} [TopologicalSpace X]
+    [LocallyPathConnectedSpace X] (F : Flow ℝ X) (p : X)
+    (hopen : IsOpen {x : X | Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p)})
+    (hp : Filter.Tendsto (fun t => F t p) Filter.atTop (𝓝 p)) {x : X}
+    (hx : Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p)) :
+    JoinedIn {y : X | Filter.Tendsto (fun t => F t y) Filter.atTop (𝓝 p)} x p := by
+  let B : Set X := {y | Filter.Tendsto (fun t => F t y) Filter.atTop (𝓝 p)}
+  have hC := pathComponentIn_mem_nhds (hopen.mem_nhds hp)
+  obtain ⟨T, hT⟩ := (hx.eventually hC).exists
+  have htail : JoinedIn B (F T x) p := (show JoinedIn B p (F T x) from hT).symm
+  let γ : Path x (F T x) :=
+    { toFun := fun u => F ((u : ℝ) * T) x
+      continuous_toFun := F.continuous (continuous_subtype_val.mul_const T) continuous_const
+      source' := by simp
+      target' := by simp }
+  have hsegment : JoinedIn B x (F T x) := by
+    refine ⟨γ, fun u => ?_⟩
+    exact (flow_time_atTop_limit_iff F ((u : ℝ) * T) x p).mpr hx
+  exact hsegment.trans htail
+
+private theorem AdaptedWindows.joinedIn_minimum_basin {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f)
+    (hp : MorseCancel.nativeMorseIndex E f p = 0) {x y : M}
+    (hx : Filter.Tendsto (fun t => S.flow t x) Filter.atTop (𝓝 p.val))
+    (hy : Filter.Tendsto (fun t => S.flow t y) Filter.atTop (𝓝 p.val)) :
+    JoinedIn {z : M | Filter.Tendsto (fun t => S.flow t z) Filter.atTop (𝓝 p.val)} x y := by
+  let _ : LocallyPathConnectedSpace M := ChartedSpace.locallyPathConnectedSpace E M
+  have hpp : Filter.Tendsto (fun t => S.flow t p.val) Filter.atTop (𝓝 p.val) := by
+    have heq : (fun t => S.flow t p.val) = fun _ => p.val :=
+      funext
+        (fun t =>
+          Smale.FlowConstruction.flow_fixed_of_zero (S.smooth.of_le (by simp)) S.flow S.integral
+            (S.zero p p.property) t)
+    rw [heq]
+    exact tendsto_const_nhds
+  have hopen := S.isOpen_minimum_forward_basin hf p hp
+  exact
+    (MorseCancel.joinedIn_open_forward_basin S.flow p.val hopen hpp hx).trans
+      (MorseCancel.joinedIn_open_forward_basin S.flow p.val hopen hpp hy).symm
+
+private theorem Degree.SmoothODE.scalar_partial_invertible {P : Type*} [NormedAddCommGroup P]
+    [NormedSpace ℝ P] {F : P × ℝ → ℝ} {p : P} {t v : ℝ} (hF : ContDiffAt ℝ ∞ F (p, t))
+    (htime : HasDerivAt (fun s : ℝ => F (p, s)) v t) (hv : v ≠ 0) :
+    ((fderiv ℝ F (p, t)).comp (ContinuousLinearMap.inr ℝ P ℝ)).IsInvertible := by
+  have hd :=
+    (hF.differentiableAt (by simp)).hasFDerivAt.comp t
+      ((hasFDerivAt_const p t).prodMk (hasFDerivAt_id t))
+  change
+    HasFDerivAt (fun s : ℝ => F (p, s)) ((fderiv ℝ F (p, t)).comp (ContinuousLinearMap.inr ℝ P ℝ))
+      t at hd
+  have heq := hd.unique htime.hasFDerivAt
+  let L : ℝ ≃L[ℝ] ℝ := (LinearEquiv.smulOfNeZero ℝ ℝ v hv).toContinuousLinearEquiv
+  refine ⟨L, ?_⟩
+  rw [heq]
+  apply ContinuousLinearMap.ext
+  intro r
+  change v * r = r * v
+  exact mul_comm v r
+
+private theorem Degree.SmoothODE.exists_smooth_scalar_time_germ {P : Type*} [NormedAddCommGroup P]
+    [NormedSpace ℝ P] [CompleteSpace P] {F : P × ℝ → ℝ} {p : P} {t c v : ℝ}
+    (hF : ContDiffAt ℝ ∞ F (p, t)) (hlevel : F (p, t) = c)
+    (htime : HasDerivAt (fun s : ℝ => F (p, s)) v t) (hv : v ≠ 0) :
+    ∃ θ : P → ℝ, θ p = t ∧ ContDiffAt ℝ ∞ θ p ∧ ∀ᶠ q in 𝓝 p, F (q, θ q) = c := by
+  have hinv := scalar_partial_invertible hF htime hv
+  let θ := hF.implicitFunction (by simp) hinv
+  refine
+    ⟨θ, hF.implicitFunction_apply_self (by simp) hinv,
+      hF.contDiffAt_implicitFunction (by simp) hinv, ?_⟩
+  filter_upwards [hF.eventually_apply_implicitFunction (by simp) hinv] with q hq
+  exact hq.trans hlevel
+
+private theorem Degree.FlowCancellation.exists_native_smooth_time_germ {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {H : M × ℝ → ℝ} {p : M} {t c v : ℝ}
+    (hH : ContMDiffAt (𝓘(ℝ, E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, ℝ) ∞ H (p, t)) (hlevel : H (p, t) = c)
+    (htime : HasDerivAt (fun s : ℝ => H (p, s)) v t) (hv : v ≠ 0) :
+    ∃ θ : M → ℝ, θ p = t ∧ ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ θ p ∧ ∀ᶠ q in 𝓝 p, H (q, θ q) = c := by
+  let e := NoExotic.modelChartPartialDiffeomorph (I := 𝓘(ℝ, E)) p
+  have hp : p ∈ e.source := mem_extChartAt_source p
+  have hz : e p ∈ e.target := e.map_source' hp
+  have he : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, E) ∞ e p :=
+    (e.contMDiffOn p hp).contMDiffAt (e.open_source.mem_nhds hp)
+  have hi : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, E) ∞ e.symm (e p) :=
+    (e.symm.contMDiffOn (e p) hz).contMDiffAt (e.open_target.mem_nhds hz)
+  let B (q : E × ℝ) : M × ℝ := (e.symm q.1, q.2)
+  let F : E × ℝ → ℝ := H ∘ B
+  have hleft : e.symm (e p) = p := e.left_inv' hp
+  have hB : ContMDiffAt 𝓘(ℝ, E × ℝ) (𝓘(ℝ, E).prod 𝓘(ℝ, ℝ)) ∞ B (e p, t) := by
+    have hfst : ContMDiffAt 𝓘(ℝ, E × ℝ) 𝓘(ℝ, E) ∞ (Prod.fst : E × ℝ → E) (e p, t) :=
+      contDiffAt_fst.contMDiffAt
+    have hfirst := hi.comp (e p, t) hfst
+    exact hfirst.prodMk contDiffAt_snd.contMDiffAt
+  have hB0 : B (e p, t) = (p, t) := Prod.ext hleft rfl
+  have hH' : ContMDiffAt (𝓘(ℝ, E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, ℝ) ∞ H (B (e p, t)) := by
+    rw [hB0]
+    exact hH
+  have hF : ContDiffAt ℝ ∞ F (e p, t) := (hH'.comp (e p, t) hB).contDiffAt
+  have hFtime : (fun s : ℝ => F (e p, s)) = fun s => H (p, s) := by
+    funext s
+    change H (e.symm (e p), s) = H (p, s)
+    rw [hleft]
+  have hFt : HasDerivAt (fun s : ℝ => F (e p, s)) v t := by rw [hFtime]; exact htime
+  have hFc : F (e p, t) = c := by
+    change H (B (e p, t)) = c
+    rw [hB0]
+    exact hlevel
+  obtain ⟨θ, hθ, hsmooth, hroot⟩ := Degree.SmoothODE.exists_smooth_scalar_time_germ hF hFc hFt hv
+  refine ⟨θ ∘ e, hθ, hsmooth.contMDiffAt.comp p he, ?_⟩
+  filter_upwards [e.open_source.mem_nhds hp, he.continuousAt hroot] with q hq hrootq
+  have hqleft : e.symm (e q) = q := e.left_inv' hq
+  change H (e.symm (e q), θ (e q)) = c at hrootq
+  change H (q, θ (e q)) = c
+  rwa [hqleft] at hrootq
+
+private theorem
+    Degree.FlowCancellation.smooth_signed_level_time {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) {c : ℝ}
+    (hboundary : ∀ x, f x = c → mvfderiv 𝓘(ℝ, E) f x (V x) < 0) :
+    IsOpen (levelBasin F f c) ∧
+      ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ (signedLevelTime F f c) (levelBasin F f c) ∧
+        ∀ x ∈ levelBasin F f c,
+          ∀ s : ℝ, signedLevelTime F f c (F s x) = signedLevelTime F f c x - s := by
+  let D (x : M) := mvfderiv 𝓘(ℝ, E) f x (V x)
+  have hD : Continuous D := (MorseCancel.contMDiff_directionalDerivative hf hV).continuous
+  have hder (x : M) (t : ℝ) : HasDerivAt (fun s => f (F s x)) (D (F t x)) t :=
+    Smale.FlowConstruction.hasDerivAt_comp_integralCurve hf (hcurve x) t
+  have hH : ContMDiff (𝓘(ℝ, E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, ℝ) ∞ (fun q : M × ℝ => f (F q.2 q.1)) :=
+    hf.comp (Degree.SmoothODE.contMDiff_native_flow hV F hcurve)
+  have hgerm (p : M) (hp : p ∈ levelBasin F f c) :
+    ∃ θ : M → ℝ, ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ θ p ∧ ∀ᶠ q in 𝓝 p, f (F (θ q) q) = c := by
+    let t := signedLevelTime F f c p
+    have hhit : f (F t p) = c := signedLevelTime_hits F f c hp
+    obtain ⟨θ, -, hθ, heq⟩ :=
+      exists_native_smooth_time_germ hH.contMDiffAt hhit (hder p t) (hboundary (F t p) hhit).ne
+    exact ⟨θ, hθ, heq⟩
+  have hB : IsOpen (levelBasin F f c) := by
+    apply isOpen_iff_mem_nhds.mpr
+    intro p hp
+    obtain ⟨θ, -, heq⟩ := hgerm p hp
+    exact heq.mono (fun q hq => ⟨θ q, hq⟩)
+  refine ⟨hB, ?_, ?_⟩
+  · intro p hp
+    obtain ⟨θ, hθ, heq⟩ := hgerm p hp
+    apply ContMDiffAt.contMDiffWithinAt
+    apply hθ.congr_of_eventuallyEq
+    filter_upwards [heq] with q hq
+    exact signedLevelTime_eq_of_level F hf.continuous hD hder hboundary hq
+  · intro x hx s
+    exact signedLevelTime_flow F hf.continuous hD hder hboundary hx s
+
+private theorem Degree.FlowCancellation.exists_native_level_flow_cylinder {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    {c : ℝ} (hreg : ∀ x, f x = c → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hboundary : ∀ x, f x = c → mvfderiv 𝓘(ℝ, E) f x (V x) < 0) (z : { x : M // f x = c }) :
+    letI := Smale.RegularLevel.chartedSpace hf hreg
+    ∃ Φ :
+      PartialDiffeomorph (𝓘(ℝ, Smale.RegularLevel.Model E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E)
+        ({ x : M // f x = c } × ℝ) M ∞,
+      Φ.source = Set.univ ∧
+        Φ.target = levelBasin F f c ∧
+          (∀ p, Φ p = F p.2 p.1) ∧ ∀ x ∈ Φ.target, (Φ.symm x).2 = -signedLevelTime F f c x := by
+  classical
+  let _ := Smale.RegularLevel.chartedSpace hf hreg
+  let L := { x : M // f x = c }
+  let B := levelBasin F f c
+  let θ := signedLevelTime F f c
+  obtain ⟨hB, hθ, htranslate⟩ := smooth_signed_level_time hf hV F hcurve hboundary
+  let r : M → L := fun x => if hx : x ∈ B then ⟨F (θ x) x, signedLevelTime_hits F f c hx⟩ else z
+  let φ : L × ℝ → M := fun p => F p.2 p.1
+  let ψ : M → L × ℝ := fun x => (r x, -θ x)
+  have hflow := Degree.SmoothODE.contMDiff_native_flow hV F hcurve
+  have hφ : ContMDiff (𝓘(ℝ, Smale.RegularLevel.Model E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) ∞ φ :=
+    hflow.comp
+      (((Smale.RegularLevel.contMDiff_inclusion hf hreg).comp contMDiff_fst).prodMk contMDiff_snd)
+  have hψ : ContMDiffOn 𝓘(ℝ, E) (𝓘(ℝ, Smale.RegularLevel.Model E).prod 𝓘(ℝ, ℝ)) ∞ ψ B := by
+    intro x hx
+    have hθx := (hθ x hx).contMDiffAt (hB.mem_nhds hx)
+    have hr : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ r x := by
+      apply (Smale.RegularLevel.contMDiffAt_iff_inclusion hf hreg 𝓘(ℝ, E) r x).mpr
+      apply (hflow.contMDiffAt.comp x (contMDiffAt_id.prodMk hθx)).congr_of_eventuallyEq
+      filter_upwards [hB.mem_nhds hx] with y hy
+      change (r y : M) = F (θ y) y
+      have hyB : y ∈ B := hy
+      simp only [r, dite_eq_left hyB]
+    exact (hr.prodMk hθx.neg).contMDiffWithinAt
+  have hD : Continuous (fun x => mvfderiv 𝓘(ℝ, E) f x (V x)) :=
+    (MorseCancel.contMDiff_directionalDerivative hf hV).continuous
+  have hder (x : M) (t : ℝ) :=
+    Smale.FlowConstruction.hasDerivAt_comp_integralCurve hf (hcurve x) t
+  have hlevel (x : L) : (x : M) ∈ B := ⟨0, by simpa only [F.map_zero_apply] using x.property⟩
+  have hφB (p : L × ℝ) : φ p ∈ B := (levelBasin_flow_iff F f c p.2 p.1).mpr (hlevel p.1)
+  have hclock (p : L × ℝ) : θ (φ p) = -p.2 := by
+    have hh := htranslate p.1 (hlevel p.1) p.2
+    rw [signedLevelTime_eq_zero F hf.continuous hD hder hboundary p.1.property, zero_sub] at hh
+    exact hh
+  have hleft (p : L × ℝ) : ψ (φ p) = p := by
+    apply Prod.ext
+    · apply Subtype.ext
+      change (r (φ p) : M) = p.1
+      rw [show r (φ p) = ⟨F (θ (φ p)) (φ p), signedLevelTime_hits F f c (hφB p)⟩ by
+          simp only [r, dite_eq_left (hφB p)] ]
+      change F (θ (φ p)) (F p.2 p.1) = p.1
+      rw [hclock, ← F.map_add, neg_add_cancel, F.map_zero_apply]
+    · change -θ (φ p) = p.2
+      rw [hclock, neg_neg]
+  have hright (x : M) (hx : x ∈ B) : φ (ψ x) = x := by
+    change F (-θ x) (r x) = x
+    rw [show r x = ⟨F (θ x) x, signedLevelTime_hits F f c hx⟩ by simp only [r, dite_eq_left hx] ]
+    change F (-θ x) (F (θ x) x) = x
+    rw [← F.map_add, neg_add_cancel, F.map_zero_apply]
+  let Φ :
+    PartialDiffeomorph (𝓘(ℝ, Smale.RegularLevel.Model E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) (L × ℝ) M ∞ :=
+    { toFun := φ
+      invFun := ψ
+      source := Set.univ
+      target := B
+      map_source' := fun p _ => hφB p
+      map_target' := fun _ _ => Set.mem_univ _
+      left_inv' := fun p _ => hleft p
+      right_inv' := hright
+      open_source := isOpen_univ
+      open_target := hB
+      contMDiffOn_toFun := hφ.contMDiffOn
+      contMDiffOn_invFun := hψ }
+  exact ⟨Φ, rfl, rfl, fun _ => rfl, fun _ _ => rfl⟩
+
+private theorem AdaptedWindows.joinedIn_regular_level_of_endpoint_dimensions {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a : ℝ}
+    (hreg : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f) {d : ℕ}
+    (hhigh :
+      ∀ p : Smale.ManifoldMorse.criticalPoints E f,
+        a ≤ f p → Module.finrank ℝ E - MorseCancel.nativeMorseIndex E f p ≤ d)
+    (hlow :
+      ∀ p : Smale.ManifoldMorse.criticalPoints E f,
+        f p ≤ a → MorseCancel.nativeMorseIndex E f p ≤ d)
+    (hdim : 1 + d < Module.finrank ℝ E) {x y : M} (hxa : f x = a) (hya : f y = a) (γ : Path x y) :
+    JoinedIn {z : M | f z = a} x y := by
+  let _ := S.finite.fintype
+  let K := MorseCancel.EndpointBasinIndex (E := E) (f := f) a
+  let Z := EuclideanSpace ℝ (Fin 0)
+  let V := EuclideanSpace ℝ (Fin d)
+  let _ : Countable K := MorseCancel.endpointBasinIndex_countable S a
+  let _ : DiscreteTopology K := inferInstance
+  let _ : ChartedSpace Z K := ChartedSpace.ofDiscreteTopology
+  let _ : IsManifold 𝓘(ℝ, Z) ∞ K := IsManifold.of_discreteTopology ∞
+  obtain ⟨g, hg, hcover⟩ := S.exists_endpoint_obstruction_global_images hf a hhigh hlow
+  have hG : ContMDiff (𝓘(ℝ, Z).prod 𝓘(ℝ, V)) 𝓘(ℝ, E) ∞ (fun z : K × V => g z.1 z.2) :=
+    MorseCancel.contMDiff_discrete_family g hg
+  let G : C(K × V, M) := ⟨fun z => g z.1 z.2, hG.continuous⟩
+  have hrange : Set.range G = (Degree.FlowCancellation.levelBasin S.flow f a)ᶜ := by
+    rw [MorseCancel.levelBasin_compl_eq_endpoint_obstruction S hf hreg, hcover]
+    exact MorseCancel.range_discrete_family g
+  have hclosed : IsClosed (Set.range G) := by
+    rw [hrange, MorseCancel.levelBasin_compl_eq_endpoint_obstruction S hf hreg]
+    exact MorseCancel.isClosed_endpoint_obstruction S hf a
+  have hdim' : 1 + Module.finrank ℝ (Z × V) < Module.finrank ℝ E := by
+    simpa only [Z, V, Module.finrank_prod, finrank_euclideanSpace_fin, zero_add] using hdim
+  have hnot (z : M) (hz : f z = a) : z ∉ Set.range G := by
+    rw [hrange, Set.mem_compl_iff, Classical.not_not]
+    exact ⟨0, by simpa only [S.flow.map_zero_apply] using hz⟩
+  obtain ⟨η, -, havoid⟩ :=
+    MorseCancel.exists_smooth_path_avoiding_closed_image γ G hG hclosed hdim' (hnot x hxa)
+      (hnot y hya)
+  have hcross (t : unitInterval) : η t ∈ Degree.FlowCancellation.levelBasin S.flow f a := by
+    have hh := havoid t
+    simpa only [hrange, Set.mem_compl_iff, Classical.not_not] using hh
+  let _ := Smale.RegularLevel.chartedSpace hf hreg
+  let xL : { z : M // f z = a } := ⟨x, hxa⟩
+  let yL : { z : M // f z = a } := ⟨y, hya⟩
+  obtain ⟨Φ, hsource, htarget, hformula, -⟩ :=
+    Degree.FlowCancellation.exists_native_level_flow_cylinder hf hreg S.smooth S.flow S.integral
+      (fun z hz => S.descent z (hreg z hz)) xL
+  have hcont : Continuous (fun t : unitInterval => Φ.symm (η t)) :=
+    Φ.contMDiffOn_invFun.continuousOn.comp_continuous η.continuous
+      (fun t => htarget.symm ▸ hcross t)
+  have hinverse (z : { w : M // f w = a }) : Φ.symm z.val = (z, 0) := by
+    have hs : (z, (0 : ℝ)) ∈ Φ.source := by rw [hsource]; trivial
+    have he : Φ (z, 0) = z.val := by rw [hformula, S.flow.map_zero_apply]
+    have hi : Φ.symm (Φ (z, 0)) = (z, 0) := Φ.left_inv' hs
+    rwa [he] at hi
+  let ξ : Path x y :=
+    { toFun := fun t => (Φ.symm (η t)).1.val
+      continuous_toFun := continuous_subtype_val.comp (continuous_fst.comp hcont)
+      source' := by
+        rw [η.source]
+        exact congrArg (fun z : { w : M // f w = a } × ℝ => z.1.val) (hinverse xL)
+      target' := by
+        rw [η.target]
+        exact congrArg (fun z : { w : M // f w = a } × ℝ => z.1.val) (hinverse yL) }
+  exact ⟨ξ, fun t => (Φ.symm (η t)).1.property⟩
+
+private theorem AdaptedWindows.pathConnectedSpace_regular_level_of_endpoint_dimensions {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    [PathConnectedSpace M] (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a : ℝ}
+    (hreg : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f) {d : ℕ}
+    (hhigh :
+      ∀ p : Smale.ManifoldMorse.criticalPoints E f,
+        a ≤ f p → Module.finrank ℝ E - MorseCancel.nativeMorseIndex E f p ≤ d)
+    (hlow :
+      ∀ p : Smale.ManifoldMorse.criticalPoints E f,
+        f p ≤ a → MorseCancel.nativeMorseIndex E f p ≤ d)
+    (hdim : 1 + d < Module.finrank ℝ E) (z₀ : { z : M // f z = a }) :
+    PathConnectedSpace { z : M // f z = a }
+    where
+  nonempty := ⟨z₀⟩
+  joined x
+    y :=
+    (S.joinedIn_regular_level_of_endpoint_dimensions hf hreg hhigh hlow hdim x.property y.property
+        (PathConnectedSpace.somePath x.val y.val)).joined_subtype
+
+private theorem AdaptedWindows.pathConnectedSpace_middle_level {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} [PathConnectedSpace M]
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hdim : Module.finrank ℝ E = 6)
+    {a : ℝ} (hreg : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hhigh :
+      ∀ p : Smale.ManifoldMorse.criticalPoints E f,
+        a ≤ f p → 3 ≤ MorseCancel.nativeMorseIndex E f p)
+    (hlow :
+      ∀ p : Smale.ManifoldMorse.criticalPoints E f,
+        f p ≤ a → MorseCancel.nativeMorseIndex E f p ≤ 3)
+    (z₀ : { z : M // f z = a }) : PathConnectedSpace { z : M // f z = a } :=
+  S.pathConnectedSpace_regular_level_of_endpoint_dimensions hf hreg
+    (fun p hp => by have hh := hhigh p hp; omega) hlow (by omega) z₀
+
+private theorem AdaptedWindows.pathConnectedSpace_index_three_upper_level {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [PathConnectedSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hdim : Module.finrank ℝ E = 6)
+    (horder :
+      ∀ p q : Smale.ManifoldMorse.criticalPoints E f,
+        f p < f q → MorseCancel.nativeMorseIndex E f p ≤ MorseCancel.nativeMorseIndex E f q)
+    (p : Smale.ManifoldMorse.criticalPoints E f) (hp : MorseCancel.nativeMorseIndex E f p = 3)
+    (z₀ : (S.data p).UpperLevel) : PathConnectedSpace (S.data p).UpperLevel := by
+  apply S.pathConnectedSpace_middle_level hf hdim (S.data p).upper_regular (z₀ := z₀)
+  · intro r hr
+    have hpr : f p < f r := (S.toSurgeryWindows.value_lt_upper p).trans_le hr
+    simpa only [hp] using horder p r hpr
+  · intro r hr
+    rcases lt_trichotomy (f r) (f p) with h | h | h
+    · simpa only [hp] using horder r p h
+    · have he : r = p := Subtype.ext (S.distinct r.property p.property h)
+      rw [he, hp]
+    · have hsep := S.separated p r h
+      have hlow := S.toSurgeryWindows.lower_lt_value r
+      exact ((not_lt_of_ge hr) (hsep.trans hlow)).elim
+
+private theorem
+    Degree.MorseRearrangement.native_transverse_dimension_bound {D Z G H H' K X Y N : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    [TopologicalSpace K] {I : ModelWithCorners ℝ D H} {I' : ModelWithCorners ℝ Z H'}
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace Y]
+    [ChartedSpace H' Y] [TopologicalSpace N] [ChartedSpace K N] [FiniteDimensional ℝ D]
+    [FiniteDimensional ℝ Z] {f : X → N} {g : Y → N} {x : X} {y : Y}
+    (ht : Smale.NativeTransversality.At I I' J f g x y) (hxy : g y = f x) :
+    Module.finrank ℝ G ≤ Module.finrank ℝ D + Module.finrank ℝ Z := by
+  let L : (D × Z) →L[ℝ] G := by
+    exact (mfderiv I J f x : D →L[ℝ] G).coprod (mfderiv I' J g y : Z →L[ℝ] G)
+  have hL : Function.Surjective L := ht hxy
+  have hh := LinearMap.finrank_le_finrank_of_surjective (f := L.toLinearMap) hL
+  simpa only [Module.finrank_prod] using hh
+
+private theorem Degree.MorseRearrangement.disjoint_ranges_of_native_transverse_dimension
+    {D Z G H H' K X Y N : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H]
+    [TopologicalSpace H'] [TopologicalSpace K] {I : ModelWithCorners ℝ D H}
+    {I' : ModelWithCorners ℝ Z H'} {J : ModelWithCorners ℝ G K} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y] [TopologicalSpace N]
+    [ChartedSpace K N] [FiniteDimensional ℝ D] [FiniteDimensional ℝ Z] {f : X → N} {g : Y → N}
+    (ht : ∀ x y, Smale.NativeTransversality.At I I' J f g x y)
+    (hdim : Module.finrank ℝ D + Module.finrank ℝ Z < Module.finrank ℝ G) :
+    Disjoint (Set.range f) (Set.range g) := by
+  apply Set.disjoint_left.mpr
+  rintro z ⟨x, hx⟩ ⟨y, hy⟩
+  exact (not_le_of_gt hdim) (native_transverse_dimension_bound (ht x y) (hy.trans hx.symm))
+
+private theorem
+    Degree.MorseRearrangement.native_transverse_of_ignored_factor {D Z G H H' K X Y N : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    [TopologicalSpace K] {I : ModelWithCorners ℝ D H} {I' : ModelWithCorners ℝ Z H'}
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace Y]
+    [ChartedSpace H' Y] [TopologicalSpace N] [ChartedSpace K N] {R H'' W : Type*}
+    [NormedAddCommGroup R] [NormedSpace ℝ R] [TopologicalSpace H'']
+    {I'' : ModelWithCorners ℝ R H''} [TopologicalSpace W] [ChartedSpace H'' W] {f : X → N}
+    {g : Y → N} {x : X} {y : Y} (w : W) (hf : MDifferentiableAt I J f x)
+    (ht : Smale.NativeTransversality.At (I.prod I'') I' J (f ∘ Prod.fst) g (x, w) y) :
+    Smale.NativeTransversality.At I I' J f g x y := by
+  intro hxy
+  have hsurj := ht hxy
+  have hd :
+    (mfderiv (I.prod I'') J (f ∘ Prod.fst) (x, w) : (D × R) →L[ℝ] G) =
+      (mfderiv I J f x : D →L[ℝ] G).comp (ContinuousLinearMap.fst ℝ D R) := by
+    rw [mfderiv_comp (x, w) hf mdifferentiableAt_fst, mfderiv_fst]
+    rfl
+  change
+    Function.Surjective
+      ((mfderiv (I.prod I'') J (f ∘ Prod.fst) (x, w) : (D × R) →L[ℝ] G).coprod
+        (mfderiv I' J g y : Z →L[ℝ] G)) at hsurj
+  rw [hd] at hsurj
+  intro v
+  obtain ⟨⟨⟨a, b⟩, c⟩, hh⟩ := hsurj v
+  exact ⟨(a, c), hh⟩
+
+private theorem Smale.ChartMapPerturbation.exists_ambient_transverse_plateau
+    {D Z G F H H' K X Y N : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D]
+    [FiniteDimensional ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z]
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [FiniteDimensional ℝ F] [TopologicalSpace H] [TopologicalSpace H'] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ D H} {I' : ModelWithCorners ℝ Z H'} {J : ModelWithCorners ℝ G K}
+    [I.Boundaryless] [I'.Boundaryless] [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X]
+    [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y] [TopologicalSpace N]
+    [ChartedSpace K N] [T2Space N] [LindelofSpace (X × Y)]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {g : Y → N} {β : F → ℝ}
+    (hf : ContMDiff I J ∞ f) (hg : ContMDiff I' J ∞ g) (hβ : ContDiff ℝ ∞ β)
+    (hcompact : HasCompactSupport β) (hsupport : tsupport β ⊆ c.target)
+    (hdim : Module.finrank ℝ D + Module.finrank ℝ Z = Module.finrank ℝ F) {ε : ℝ} (hε : 0 < ε) :
+    ∃ a : F,
+      ‖a‖ < ε ∧
+        ∃ e : Diffeomorph J J N N ∞,
+          (∀ y, e y = Smale.SupportedDiffeomorph.bumpFamily c.symm β (a, y)) ∧
+            (∀ y ∉ c.symm '' tsupport β, e y = y) ∧
+              Smale.SupportedDiffeomorph.IsotopicToIdentity e ∧
+                ∀ x,
+                  f x ∈ c.source →
+                    (β =ᶠ[𝓝 (c (f x))] fun _ => 1) →
+                      ∀ y,
+                        g y = e (f x) →
+                          Function.Surjective
+                            ((mfderiv I J (e ∘ f) x : D →L[ℝ] G).coprod
+                              (mfderiv I' J g y : Z →L[ℝ] G)) := by
+  let U : Set X := f ⁻¹' c.source
+  let V : Set Y := g ⁻¹' c.source
+  have hU : IsOpen U := c.open_source.preimage hf.continuous
+  have hV : IsOpen V := c.open_source.preimage hg.continuous
+  have hcf : ContMDiffOn I 𝓘(ℝ, F) ∞ (c ∘ f) U :=
+    c.contMDiffOn_toFun.comp hf.contMDiffOn (fun _ hx => hx)
+  have hcg : ContMDiffOn I' 𝓘(ℝ, F) ∞ (c ∘ g) V :=
+    c.contMDiffOn_toFun.comp hg.contMDiffOn (fun _ hy => hy)
+  have hdense := Smale.TransverseCoordinates.dense_native_translations hU hV hcf hcg hdim
+  obtain ⟨δ, hδ, hdiff, -, hsource⟩ :=
+    Smale.SupportedDiffeomorph.exists_radius_ambient_bumpFamily c.symm hβ hcompact hsupport
+  obtain ⟨η, hη, hisotopy⟩ :=
+    Smale.SupportedDiffeomorph.exists_radius_bumpFamily_isotopy c.symm hβ hcompact hsupport
+  obtain ⟨a, ha, hnorm⟩ := hdense.exists_dist_lt 0 (lt_min hε (lt_min hδ hη))
+  have hn : ‖a‖ < Min.min ε (Min.min δ η) := by simpa only [dist_zero_left] using hnorm
+  have haδ := (lt_min_iff.mp (lt_min_iff.mp hn).2).1
+  have haη := (lt_min_iff.mp (lt_min_iff.mp hn).2).2
+  obtain ⟨e, he⟩ := hdiff a haδ
+  have hsrc := hsource a haδ
+  refine ⟨a, (lt_min_iff.mp hn).1, e, he, ?_, hisotopy a haη e he, ?_⟩
+  · intro y hy
+    rw [he]
+    exact Smale.SupportedDiffeomorph.bumpFamily_fixed_outside c.symm β a hy
+  · intro x hfx hx y hxy
+    have hnew : e (f x) ∈ c.source := by
+      rw [he]
+      exact Smale.SupportedDiffeomorph.bumpFamily_mem_target c.symm β a hsrc hfx
+    have hgy : g y ∈ c.source := hxy ▸ hnew
+    have hcfAt := hcf.contMDiffAt (hU.mem_nhds hfx)
+    have hevent : c ∘ (e ∘ f) =ᶠ[𝓝 x] fun z => c (f z) + a := by
+      filter_upwards [hU.mem_nhds hfx, hx.comp_tendsto hcfAt.continuousAt] with z hz hβz
+      change β (c (f z)) = 1 at hβz
+      change c (e (f z)) = c (f z) + a
+      rw [he]
+      have hh := Smale.SupportedDiffeomorph.bumpFamily_coordinates c.symm β a hsrc hz
+      change
+        c (Smale.SupportedDiffeomorph.bumpFamily c.symm β (a, f z)) =
+          c (f z) + β (c (f z)) • a at hh
+      exact hh.trans (by rw [hβz, one_smul])
+    have hcross : (c ∘ g) y = (c ∘ f) x + a := by
+      change c (g y) = c (f x) + a
+      rw [hxy]
+      exact hevent.eq_of_nhds
+    have ht := ha x hfx y hgy hcross
+    have hderiv := mfderiv_eq_of_translation_germ (hcfAt.mdifferentiableAt (by simp)) hevent
+    apply
+      transverse_of_chart c ((e.contMDiff.comp hf).mdifferentiableAt (by simp))
+        (hg.mdifferentiableAt (by simp)) hxy hnew
+    rw [hderiv]
+    exact ht
+
+private structure Smale.NativeTransversality.Patch {G K N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace K] (J : ModelWithCorners ℝ G K) [TopologicalSpace N]
+    [ChartedSpace K N] (X : Type*) [TopologicalSpace X] where
+  core : Set X
+  core_compact : IsCompact core
+  chart : PartialDiffeomorph J 𝓘(ℝ, G) N G ∞
+  cutoff : G → ℝ
+  cutoff_smooth : ContDiff ℝ ∞ cutoff
+  cutoff_compact : HasCompactSupport cutoff
+  cutoff_support : tsupport cutoff ⊆ chart.target
+  plateau : Set N
+  plateau_open : IsOpen plateau
+  plateau_source : plateau ⊆ chart.source
+  plateau_one : ∀ y ∈ plateau, cutoff =ᶠ[𝓝 (chart y)] fun _ => 1
+
+private def Smale.NativeTransversality.Patch.Compatible {G K N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace K] {J : ModelWithCorners ℝ G K} [TopologicalSpace N]
+    [ChartedSpace K N] {X : Type*} [TopologicalSpace X]
+    (p : Smale.NativeTransversality.Patch J X (N := N)) (f : X → N) : Prop :=
+  Set.MapsTo f p.core p.plateau
+
+private theorem Smale.NativeTransversality.exists_patch_at {G K N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace K] {J : ModelWithCorners ℝ G K} [TopologicalSpace N]
+    [ChartedSpace K N] {X : Type*} [TopologicalSpace X] [FiniteDimensional ℝ G] [J.Boundaryless]
+    [IsManifold J ∞ N] [CompactSpace X] [T2Space X] {f : X → N} (hf : Continuous f) (x : X) :
+    ∃ p : Patch J X (N := N), p.Compatible f ∧ x ∈ interior p.core := by
+  let c := NoExotic.modelChartPartialDiffeomorph (I := J) (f x)
+  have hcx : f x ∈ c.source := mem_extChartAt_source _
+  obtain ⟨r, hr, hball⟩ := Metric.mem_nhds_iff.mp (c.open_target.mem_nhds (c.map_source' hcx))
+  obtain ⟨β, hβ, hsupport, W, hW, hcenter, -, hone⟩ :=
+    LineBundleTransport.exists_smooth_cutoff_near_closed (K := {c (f x)}) (U :=
+      Metric.ball (c (f x)) r) isClosed_singleton Metric.isOpen_ball
+      (Set.singleton_subset_iff.mpr (Metric.mem_ball_self hr))
+  have hcompact : HasCompactSupport β :=
+    (ProperSpace.isCompact_closedBall (c (f x)) r).of_isClosed_subset (isClosed_tsupport β)
+      (hsupport.trans Metric.ball_subset_closedBall)
+  let O : Set N := c.source ∩ c ⁻¹' W
+  have hO : IsOpen O := c.contMDiffOn_toFun.continuousOn.isOpen_inter_preimage c.open_source hW
+  have hfx : f x ∈ O := ⟨hcx, hcenter (Set.mem_singleton _)⟩
+  obtain ⟨C, hC, -, hxC, hCO⟩ :=
+    exists_compact_closed_between (isCompact_singleton (x := x)) (hO.preimage hf)
+      (Set.singleton_subset_iff.mpr hfx)
+  let p : Patch J X (N := N) :=
+    { core := C
+      core_compact := hC
+      chart := c
+      cutoff := β
+      cutoff_smooth := hβ
+      cutoff_compact := hcompact
+      cutoff_support := hsupport.trans hball
+      plateau := O
+      plateau_open := hO
+      plateau_source := Set.inter_subset_left
+      plateau_one := by
+        intro y hy
+        filter_upwards [hW.mem_nhds hy.2] with z hz
+        exact hone hz }
+  exact ⟨p, hCO, hxC (Set.mem_singleton x)⟩
+
+private theorem Smale.NativeTransversality.exists_patch_step {D Z G H H' K X Y N : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H'] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ D H} {I' : ModelWithCorners ℝ Z H'} {J : ModelWithCorners ℝ G K}
+    [I.Boundaryless] [I'.Boundaryless] [J.Boundaryless] [TopologicalSpace X] [ChartedSpace H X]
+    [IsManifold I ∞ X] [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y]
+    [CompactSpace Y] [TopologicalSpace N] [ChartedSpace K N] [IsManifold J ∞ N] [T2Space N]
+    [LindelofSpace (X × Y)] {ι : Type*} [Finite ι] (p : ι → Patch J X (N := N)) (i : ι)
+    {f : X → N} {g : Y → N} (hf : ContMDiff I J ∞ f) (hg : ContMDiff I' J ∞ g)
+    (hcompatible : ∀ j, (p j).Compatible f)
+    (hdim : Module.finrank ℝ D + Module.finrank ℝ Z = Module.finrank ℝ G) {C : Set X}
+    (hC : IsCompact C) (htrans : ∀ x ∈ C, ∀ y, At I I' J f g x y) :
+    ∃ e : Diffeomorph J J N N ∞,
+      (∀ j, (p j).Compatible (e ∘ f)) ∧
+        (∀ x ∈ C ∪ (p i).core, ∀ y, At I I' J (e ∘ f) g x y) ∧
+          (∀ y ∉ (p i).chart.symm '' tsupport (p i).cutoff, e y = y) ∧
+            Smale.SupportedDiffeomorph.IsotopicToIdentity e := by
+  let A : G × X → N := fun q =>
+    Smale.SupportedDiffeomorph.bumpFamily (p i).chart.symm (p i).cutoff (q.1, f q.2)
+  have hkeep : ∀ᶠ a in 𝓝 (0 : G), ∀ j, (p j).Compatible (fun x => A (a, x)) := by
+    apply Filter.eventually_all.mpr
+    intro j
+    exact
+      Smale.SupportedDiffeomorph.eventually_bumpFamily_maps_compact_into_open (p i).chart.symm
+        (p i).cutoff_smooth (p i).cutoff_compact (p i).cutoff_support hf.continuous
+        (p j).core_compact (p j).plateau_open (hcompatible j)
+  obtain ⟨δ, hδ, -, hsmooth, -⟩ :=
+    Smale.SupportedDiffeomorph.exists_radius_ambient_bumpFamily (p i).chart.symm
+      (p i).cutoff_smooth (p i).cutoff_compact (p i).cutoff_support
+  have hA : ContMDiffOn (𝓘(ℝ, G).prod I) J ∞ A (Metric.ball (0 : G) δ ×ˢ Set.univ) := by
+    intro q hq
+    have hsmall : ‖q.1‖ < δ := by simpa only [Metric.mem_ball, dist_zero_right] using hq.1
+    have hpair :
+      ContMDiffAt (𝓘(ℝ, G).prod I) (𝓘(ℝ, G).prod J) ∞ (fun r : G × X => (r.1, f r.2)) q :=
+      contMDiffAt_fst.prodMk (hf.comp contMDiff_snd).contMDiffAt
+    exact ((hsmooth (q.1, f q.2) hsmall).comp q hpair).contMDiffWithinAt
+  have hzero : (fun x => A (0, x)) = f := by
+    funext x
+    exact Smale.SupportedDiffeomorph.bumpFamily_zero _ _ _
+  have hregular :
+    ∀ᶠ a in 𝓝 (0 : G), ∀ z ∈ C ×ˢ (Set.univ : Set Y), At I I' J (fun x => A (a, x)) g z.1 z.2 := by
+    apply
+      eventually_on_compact Metric.isOpen_ball hA hg hdim (hC.prod isCompact_univ)
+        (Metric.mem_ball_self hδ)
+    intro z hz
+    rw [hzero]
+    exact htrans z.1 hz.1 z.2
+  obtain ⟨ε, hε, hsmall⟩ := Metric.mem_nhds_iff.mp (hkeep.and hregular)
+  obtain ⟨a, ha, e, he, hfixed, hisotopy, hnew⟩ :=
+    Smale.ChartMapPerturbation.exists_ambient_transverse_plateau (p i).chart hf hg
+      (p i).cutoff_smooth (p i).cutoff_compact (p i).cutoff_support hdim hε
+  have hgood :=
+    hsmall
+      (show a ∈ Metric.ball (0 : G) ε by simpa only [Metric.mem_ball, dist_zero_right] using ha)
+  have heq : (fun x => A (a, x)) = e ∘ f := funext (fun x => (he (f x)).symm)
+  refine ⟨e, ?_, ?_, hfixed, hisotopy⟩
+  · intro j
+    exact heq ▸ hgood.1 j
+  · intro x hx y
+    rcases hx with hx | hx
+    · exact heq ▸ hgood.2 (x, y) ⟨hx, Set.mem_univ y⟩
+    · intro hxy
+      have hplateau := hcompatible i hx
+      exact hnew x ((p i).plateau_source hplateau) ((p i).plateau_one _ hplateau) y hxy
+
+private theorem
+    Smale.NativeTransversality.exists_finite_patch_diffeomorph {D Z G H H' K X Y N : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H'] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ D H} {I' : ModelWithCorners ℝ Z H'} {J : ModelWithCorners ℝ G K}
+    [I.Boundaryless] [I'.Boundaryless] [J.Boundaryless] [TopologicalSpace X] [ChartedSpace H X]
+    [IsManifold I ∞ X] [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y]
+    [CompactSpace Y] [TopologicalSpace N] [ChartedSpace K N] [IsManifold J ∞ N] [T2Space N]
+    [LindelofSpace (X × Y)] {ι : Type*} [Finite ι] (p : ι → Patch J X (N := N)) {f : X → N}
+    {g : Y → N} (hf : ContMDiff I J ∞ f) (hg : ContMDiff I' J ∞ g)
+    (hcompatible : ∀ j, (p j).Compatible f)
+    (hdim : Module.finrank ℝ D + Module.finrank ℝ Z = Module.finrank ℝ G) (s : Finset ι) :
+    ∃ e : Diffeomorph J J N N ∞,
+      Smale.SupportedDiffeomorph.IsotopicToIdentity e ∧
+        (∀ j, (p j).Compatible (e ∘ f)) ∧
+          ∀ j ∈ s, ∀ x ∈ (p j).core, ∀ y, At I I' J (e ∘ f) g x y := by
+  classical
+    induction s using Finset.induction_on with
+  |
+    empty =>
+    refine
+      ⟨Diffeomorph.refl J N ∞, Smale.SupportedDiffeomorph.isotopicToIdentity_refl, hcompatible,
+        ?_⟩
+    intro j hj
+    simp at hj
+  | @insert i s _ ih =>
+    obtain ⟨e₁, hiso₁, hc₁, ht₁⟩ := ih
+    let C : Set X := ⋃ j ∈ s, (p j).core
+    have hC : IsCompact C := s.isCompact_biUnion (fun j _ => (p j).core_compact)
+    have htrans : ∀ x ∈ C, ∀ y, At I I' J (e₁ ∘ f) g x y := by
+      intro x hx y
+      obtain ⟨j, hj, hxj⟩ := Set.mem_iUnion₂.mp hx
+      exact ht₁ j hj x hxj y
+    obtain ⟨e₂, hc₂, ht₂, -, hiso₂⟩ :=
+      exists_patch_step p i (e₁.contMDiff.comp hf) hg hc₁ hdim hC htrans
+    refine ⟨e₁.trans e₂, hiso₁.trans hiso₂, hc₂, ?_⟩
+    intro j hj x hx y
+    rcases Finset.mem_insert.mp hj with rfl | hjs
+    · exact ht₂ x (Or.inr hx) y
+    · exact ht₂ x (Or.inl (Set.mem_iUnion₂.mpr ⟨j, hjs, hx⟩)) y
+
+private theorem Smale.NativeTransversality.exists_ambient_transverse_diffeomorph
+    {D Z G H H' K X Y N : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    [TopologicalSpace K] {I : ModelWithCorners ℝ D H} {I' : ModelWithCorners ℝ Z H'}
+    {J : ModelWithCorners ℝ G K} [I.Boundaryless] [I'.Boundaryless] [J.Boundaryless]
+    [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X] [TopologicalSpace Y]
+    [ChartedSpace H' Y] [IsManifold I' ∞ Y] [CompactSpace Y] [TopologicalSpace N]
+    [ChartedSpace K N] [IsManifold J ∞ N] [T2Space N] [CompactSpace X] [T2Space X] {f : X → N}
+    {g : Y → N} (hf : ContMDiff I J ∞ f) (hg : ContMDiff I' J ∞ g)
+    (hdim : Module.finrank ℝ D + Module.finrank ℝ Z = Module.finrank ℝ G) :
+    ∃ e : Diffeomorph J J N N ∞,
+      Smale.SupportedDiffeomorph.IsotopicToIdentity e ∧ ∀ x y, At I I' J (e ∘ f) g x y := by
+  classical
+  choose p hp hx using fun x : X => exists_patch_at (J := J) hf.continuous x
+  have hcover : (Set.univ : Set X) ⊆ ⋃ x : X, interior (p x).core := by
+    intro x _
+    exact Set.mem_iUnion.mpr ⟨x, hx x⟩
+  obtain ⟨s, hs⟩ :=
+    isCompact_univ.elim_finite_subcover (fun x : X => interior (p x).core)
+      (fun _ => isOpen_interior) hcover
+  obtain ⟨e, hisotopy, -, ht⟩ :=
+    exists_finite_patch_diffeomorph (fun i : s => p i.1) hf hg (fun i => hp i.1) hdim Finset.univ
+  refine ⟨e, hisotopy, ?_⟩
+  intro x y
+  obtain ⟨i, hi, hxi⟩ := Set.mem_iUnion₂.mp (hs (Set.mem_univ x))
+  exact ht ⟨i, hi⟩ (Finset.mem_univ _) x (interior_subset hxi) y
+
+private theorem Degree.MorseRearrangement.exists_ambient_disjoint_diffeomorph_of_dimension
+    {D Z G H H' K X Y N : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    [TopologicalSpace K] {I : ModelWithCorners ℝ D H} {I' : ModelWithCorners ℝ Z H'}
+    {J : ModelWithCorners ℝ G K} [I.Boundaryless] [I'.Boundaryless] [J.Boundaryless]
+    [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X] [CompactSpace X] [T2Space X]
+    [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y] [CompactSpace Y]
+    [TopologicalSpace N] [ChartedSpace K N] [IsManifold J ∞ N] [T2Space N] {f : X → N} {g : Y → N}
+    (hf : ContMDiff I J ∞ f) (hg : ContMDiff I' J ∞ g)
+    (hdim : Module.finrank ℝ D + Module.finrank ℝ Z < Module.finrank ℝ G) :
+    ∃ e : Diffeomorph J J N N ∞,
+      Smale.SupportedDiffeomorph.IsotopicToIdentity e ∧
+        Disjoint (Set.range (e ∘ f)) (Set.range g) := by
+  classical
+  let d := Module.finrank ℝ G - (Module.finrank ℝ D + Module.finrank ℝ Z)
+  let f' : X × Smale.Hemisphere.Sphere d → N := f ∘ Prod.fst
+  have hf' : ContMDiff (I.prod (𝓡 d)) J ∞ f' := hf.comp contMDiff_fst
+  have hdim' :
+    Module.finrank ℝ (D × EuclideanSpace ℝ (Fin d)) + Module.finrank ℝ Z = Module.finrank ℝ G := by
+    simp only [Module.finrank_prod, finrank_euclideanSpace, Fintype.card_fin]
+    dsimp [d]
+    omega
+  obtain ⟨e, he, ht⟩ :=
+    Smale.NativeTransversality.exists_ambient_transverse_diffeomorph hf' hg hdim'
+  have htrans : ∀ x y, Smale.NativeTransversality.At I I' J (e ∘ f) g x y := by
+    intro x y
+    let w : Smale.Hemisphere.Sphere d := Smale.Hemisphere.point Bool.true ⟨0, by simp []⟩
+    apply
+      native_transverse_of_ignored_factor (I'' := 𝓡 d) w
+        ((e.contMDiff.comp hf).mdifferentiable (by simp) x)
+    exact ht (x, w) y
+  exact ⟨e, he, disjoint_ranges_of_native_transverse_dimension htrans hdim⟩
+
+private def Degree.PassageHomology.twoPunctureSet {X : Type} (a b : X) : Set X :=
+  ({ a }ᶜ : Set X) ∩ { b }ᶜ
+
+private def
+    Degree.PassageHomology.firstPunctureInclusion {X : Type} [TopologicalSpace X] (a b : X) :
+    C(twoPunctureSet a b, ({ a }ᶜ : Set X)) :=
+  ContinuousMap.inclusion Set.inter_subset_left
+
+private def
+    Degree.PassageHomology.secondPunctureInclusion {X : Type} [TopologicalSpace X] (a b : X) :
+    C(twoPunctureSet a b, ({ b }ᶜ : Set X)) :=
+  ContinuousMap.inclusion Set.inter_subset_right
+
+private theorem
+    Degree.PassageHomology.homology_ext_of_ambient_vanishing {X : Type} [TopologicalSpace X]
+    (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hc : U ∪ V = Set.univ) (n : ℕ)
+    [Subsingleton (SingularMayerVietoris.SingularHomology X (n + 1))]
+    {a b : SingularMayerVietoris.SingularHomology (U ∩ V : Set X) n}
+    (hfirst :
+      SingularMayerVietoris.singularHomologyMap
+          (ContinuousMap.inclusion (Set.inter_subset_left : U ∩ V ⊆ U)) n a =
+        SingularMayerVietoris.singularHomologyMap
+          (ContinuousMap.inclusion (Set.inter_subset_left : U ∩ V ⊆ U)) n b)
+    (hsecond :
+      SingularMayerVietoris.singularHomologyMap
+          (ContinuousMap.inclusion (Set.inter_subset_right : U ∩ V ⊆ V)) n a =
+        SingularMayerVietoris.singularHomologyMap
+          (ContinuousMap.inclusion (Set.inter_subset_right : U ∩ V ⊆ V)) n b) :
+    a = b := by
+  have hz : SingularMayerVietoris.connectingHomomorphism U V hU hV hc n = 0 := by
+    apply LinearMap.ext
+    intro c
+    have hc0 : c = 0 := Subsingleton.elim _ _
+    rw [hc0, map_zero]
+    rfl
+  have hi : Function.Injective (SingularMayerVietoris.leftHomologyMap U V n) := by
+    apply LinearMap.ker_eq_bot.mp
+    rw [← SingularMayerVietoris.exact_at_intersection U V hU hV hc n, hz, LinearMap.range_zero]
+  apply hi
+  rw [SingularMayerVietoris.leftHomologyMap_apply, SingularMayerVietoris.leftHomologyMap_apply,
+    hfirst, hsecond]
+
+private theorem Degree.PassageHomology.two_puncture_homology_ext {X : Type} [TopologicalSpace X]
+    [T1Space X] [ContractibleSpace X] {p q : X} (hpq : p ≠ q) (n : ℕ)
+    {a b : SingularMayerVietoris.SingularHomology (twoPunctureSet p q) n}
+    (hfirst :
+      SingularMayerVietoris.singularHomologyMap (firstPunctureInclusion p q) n a =
+        SingularMayerVietoris.singularHomologyMap (firstPunctureInclusion p q) n b)
+    (hsecond :
+      SingularMayerVietoris.singularHomologyMap (secondPunctureInclusion p q) n a =
+        SingularMayerVietoris.singularHomologyMap (secondPunctureInclusion p q) n b) :
+    a = b := by
+  have hc : ({ p }ᶜ : Set X) ∪ { q }ᶜ = Set.univ := by
+    ext z
+    simp only [Set.mem_union, Set.mem_compl_iff, Set.mem_singleton_iff, Set.mem_univ, iff_true]
+    by_cases hz : z = p
+    · exact Or.inr (fun hq => hpq (hz.symm.trans hq))
+    · exact Or.inl hz
+  let _ :=
+    PeriodTorusHigherHomology.contractible_homology_subsingleton X (n + 1) (Nat.succ_ne_zero n)
+  exact
+    homology_ext_of_ambient_vanishing _ _ isOpen_compl_singleton isOpen_compl_singleton hc n
+      hfirst hsecond
+
+private theorem Degree.PassageHomology.affine_sphere_ne_of_norm_ne {E : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {p c : E} {r : ℝ} (hr : 0 ≤ r) (h : ‖c - p‖ ≠ r)
+    (u : Metric.sphere (0 : E) 1) : c + r • u.val ≠ p := by
+  intro he
+  apply h
+  have hvalue : r • u.val = p - c := by rw [← he, add_sub_cancel_left]
+  calc
+    ‖c - p‖ = ‖p - c‖ := norm_sub_rev c p
+    _ = ‖r • u.val‖ := (congrArg Norm.norm hvalue.symm)
+    _ = r := by
+      rw [norm_smul, Real.norm_eq_abs, abs_of_nonneg hr, mem_sphere_zero_iff_norm.mp u.property,
+        mul_one]
+
+private def
+    Degree.PassageHomology.puncturedSphereMap {E : Type} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (p c : E) (r : ℝ) (h : ∀ u : Metric.sphere (0 : E) 1, c + r • u.val ≠ p) :
+    C(Metric.sphere (0 : E) 1, ({ p }ᶜ : Set E))
+    where
+  toFun u := ⟨c + r • u.val, h u⟩
+  continuous_toFun :=
+    (continuous_const.add (continuous_const.smul continuous_subtype_val)).subtype_mk _
+
+private theorem Degree.PassageHomology.puncturedSphereMap_homotopic_of_family {E : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] (p : E) (c : C(unitInterval, E))
+    (r : C(unitInterval, ℝ)) {c₀ c₁ : E} {r₀ r₁ : ℝ} (hc₀ : c 0 = c₀) (hc₁ : c 1 = c₁)
+    (hr₀ : r 0 = r₀) (hr₁ : r 1 = r₁)
+    (h : ∀ t, ∀ u : Metric.sphere (0 : E) 1, c t + r t • u.val ≠ p)
+    (h₀ : ∀ u : Metric.sphere (0 : E) 1, c₀ + r₀ • u.val ≠ p)
+    (h₁ : ∀ u : Metric.sphere (0 : E) 1, c₁ + r₁ • u.val ≠ p) :
+    (puncturedSphereMap p c₀ r₀ h₀).Homotopic (puncturedSphereMap p c₁ r₁ h₁) := by
+  refine
+    ⟨{  toFun := fun z => ⟨c z.1 + r z.1 • z.2.val, h z.1 z.2⟩
+        continuous_toFun :=
+          ((c.continuous.comp continuous_fst).add
+                ((r.continuous.comp continuous_fst).smul
+                  (continuous_subtype_val.comp continuous_snd))).subtype_mk
+            _
+        map_zero_left := ?_
+        map_one_left := ?_ }⟩
+  · intro u
+    apply Subtype.ext
+    change c 0 + r 0 • u.val = c₀ + r₀ • u.val
+    rw [hc₀, hr₀]
+  · intro u
+    apply Subtype.ext
+    change c 1 + r 1 • u.val = c₁ + r₁ • u.val
+    rw [hc₁, hr₁]
+
+private theorem Degree.PassageHomology.puncturedSphereMap_radius_homotopic {E : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] (p : E) {r₀ r₁ : ℝ} (hr₀ : 0 < r₀) (hr₁ : 0 < r₁)
+    (h₀ : ∀ u : Metric.sphere (0 : E) 1, p + r₀ • u.val ≠ p)
+    (h₁ : ∀ u : Metric.sphere (0 : E) 1, p + r₁ • u.val ≠ p) :
+    (puncturedSphereMap p p r₀ h₀).Homotopic (puncturedSphereMap p p r₁ h₁) := by
+  let r : C(unitInterval, ℝ) :=
+    ⟨fun t => (1 - (t : ℝ)) * r₀ + (t : ℝ) * r₁,
+      ((continuous_const.sub continuous_subtype_val).mul continuous_const).add
+        (continuous_subtype_val.mul continuous_const)⟩
+  apply
+    puncturedSphereMap_homotopic_of_family p (ContinuousMap.const _ p) r rfl rfl (by simp [r])
+      (by simp [r]) _ h₀ h₁
+  intro t u
+  have hrt : 0 < r t := by
+    change 0 < (1 - (t : ℝ)) * r₀ + (t : ℝ) * r₁
+    exact
+      (convex_Ioi (0 : ℝ)) hr₀ hr₁ (sub_nonneg.mpr t.property.2) t.property.1
+        (sub_add_cancel 1 (t : ℝ))
+  exact affine_sphere_ne_of_norm_ne hrt.le (by simpa using hrt.ne) u
+
+private theorem Degree.PassageHomology.puncturedSphereMap_center_homotopic {E : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] (p c : E) {r : ℝ} (hinside : ‖c - p‖ < r)
+    (h₀ : ∀ u : Metric.sphere (0 : E) 1, c + r • u.val ≠ p)
+    (h₁ : ∀ u : Metric.sphere (0 : E) 1, p + r • u.val ≠ p) :
+    (puncturedSphereMap p c r h₀).Homotopic (puncturedSphereMap p p r h₁) := by
+  let cpath : C(unitInterval, E) :=
+    ⟨fun t => p + (1 - (t : ℝ)) • (c - p),
+      continuous_const.add ((continuous_const.sub continuous_subtype_val).smul continuous_const)⟩
+  have hc0 : cpath 0 = c := by simp [cpath]
+  have hc1 : cpath 1 = p := by simp [cpath]
+  apply
+    puncturedSphereMap_homotopic_of_family p cpath (ContinuousMap.const _ r) hc0 hc1 rfl rfl _ h₀
+      h₁
+  intro t u
+  have hn : ‖cpath t - p‖ ≤ ‖c - p‖ := by
+    change ‖(p + (1 - (t : ℝ)) • (c - p)) - p‖ ≤ _
+    rw [add_sub_cancel_left, norm_smul, Real.norm_eq_abs,
+      abs_of_nonneg (sub_nonneg.mpr t.property.2)]
+    exact mul_le_of_le_one_left (norm_nonneg _) (sub_le_self _ t.property.1)
+  exact
+    affine_sphere_ne_of_norm_ne ((norm_nonneg _).trans_lt hinside).le (hn.trans_lt hinside).ne u
+
+private theorem Degree.PassageHomology.puncturedSphereMap_outside_nullhomotopic {E : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] (p c : E) {r : ℝ} (hr : 0 ≤ r)
+    (houtside : r < ‖c - p‖) (h : ∀ u : Metric.sphere (0 : E) 1, c + r • u.val ≠ p) :
+    ∃ q : ({ p }ᶜ : Set E), (puncturedSphereMap p c r h).Homotopic (ContinuousMap.const _ q) := by
+  have hcp : c ≠ p := by
+    intro he
+    rw [he, sub_self, norm_zero] at houtside
+    exact (not_lt_of_ge hr) houtside
+  have hzero : ∀ u : Metric.sphere (0 : E) 1, c + (0 : ℝ) • u.val ≠ p := by
+    intro u
+    simpa only [zero_smul, add_zero] using hcp
+  let rpath : C(unitInterval, ℝ) :=
+    ⟨fun t => (1 - (t : ℝ)) * r,
+      (continuous_const.sub continuous_subtype_val).mul continuous_const⟩
+  have H :=
+    puncturedSphereMap_homotopic_of_family p (ContinuousMap.const _ c) rpath rfl rfl
+      (by simp [rpath]) (by simp [rpath]) (h₀ := h) (h₁ := hzero)
+      (by
+        intro t u
+        have hrt : 0 ≤ rpath t := mul_nonneg (sub_nonneg.mpr t.property.2) hr
+        have hle : rpath t ≤ r := mul_le_of_le_one_left hr (sub_le_self _ t.property.1)
+        exact affine_sphere_ne_of_norm_ne hrt (hle.trans_lt houtside).ne' u)
+  have he :
+    puncturedSphereMap p c 0 hzero = ContinuousMap.const _ (⟨c, hcp⟩ : ({ p }ᶜ : Set E)) := by
+    apply ContinuousMap.ext
+    intro u
+    apply Subtype.ext
+    change c + (0 : ℝ) • u.val = c
+    rw [zero_smul, add_zero]
+  exact ⟨⟨c, hcp⟩, he ▸ H⟩
+
+private def Degree.PassageHomology.twoPunctureSphereMap {E : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (p q c : E) (r : ℝ) (hp : ∀ u : Metric.sphere (0 : E) 1, c + r • u.val ≠ p)
+    (hq : ∀ u : Metric.sphere (0 : E) 1, c + r • u.val ≠ q) :
+    C(Metric.sphere (0 : E) 1, twoPunctureSet p q)
+    where
+  toFun u := ⟨c + r • u.val, hp u, hq u⟩
+  continuous_toFun :=
+    (continuous_const.add (continuous_const.smul continuous_subtype_val)).subtype_mk _
+
+private def
+    Degree.PassageHomology.innerSphere {E : Type} [NormedAddCommGroup E] [NormedSpace ℝ E] (b : E)
+    (r : ℝ) (hr : 0 < r) (hrb : r < ‖b‖) : C(Metric.sphere (0 : E) 1, twoPunctureSet 0 b) :=
+  twoPunctureSphereMap 0 b 0 r
+    (affine_sphere_ne_of_norm_ne hr.le (by simpa only [sub_self, norm_zero] using hr.ne))
+    (affine_sphere_ne_of_norm_ne hr.le (by simpa only [zero_sub, norm_neg] using hrb.ne'))
+
+private def
+    Degree.PassageHomology.outerSphere {E : Type} [NormedAddCommGroup E] [NormedSpace ℝ E] (b : E)
+    (R : ℝ) (hbR : ‖b‖ < R) : C(Metric.sphere (0 : E) 1, twoPunctureSet 0 b) :=
+  twoPunctureSphereMap 0 b 0 R
+    (affine_sphere_ne_of_norm_ne ((norm_nonneg b).trans_lt hbR).le
+      (by simpa only [sub_self, norm_zero] using ((norm_nonneg b).trans_lt hbR).ne))
+    (affine_sphere_ne_of_norm_ne ((norm_nonneg b).trans_lt hbR).le
+      (by simpa only [zero_sub, norm_neg] using hbR.ne))
+
+private def Degree.PassageHomology.linkingSphere {E : Type} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (b : E) (ε : ℝ) (hε : 0 < ε) (hεb : ε < ‖b‖) :
+    C(Metric.sphere (0 : E) 1, twoPunctureSet 0 b) :=
+  twoPunctureSphereMap 0 b b ε
+    (affine_sphere_ne_of_norm_ne hε.le (by simpa only [sub_zero] using hεb.ne'))
+    (affine_sphere_ne_of_norm_ne hε.le (by simpa only [sub_self, norm_zero] using hε.ne))
+
+private theorem
+    Degree.PassageHomology.radial_sphere_homology_relation {E : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (b : E) {r R ε : ℝ} (hr : 0 < r) (hrb : r < ‖b‖) (hbR : ‖b‖ < R)
+    (hε : 0 < ε) (hεb : ε < ‖b‖) (n : ℕ) (hn : n ≠ 0) :
+    SingularMayerVietoris.singularHomologyMap (outerSphere b R hbR) n =
+      SingularMayerVietoris.singularHomologyMap (innerSphere b r hr hrb) n +
+        SingularMayerVietoris.singularHomologyMap (linkingSphere b ε hε hεb) n := by
+  have hb : b ≠ 0 := norm_pos_iff.mp (hr.trans hrb)
+  have hR : 0 < R := (norm_nonneg b).trans_lt hbR
+  let i := firstPunctureInclusion (0 : E) b
+  let j := secondPunctureInclusion (0 : E) b
+  let inner := innerSphere b r hr hrb
+  let outer := outerSphere b R hbR
+  let link := linkingSphere b ε hε hεb
+  have hio : (i.comp outer).Homotopic (i.comp inner) :=
+    puncturedSphereMap_radius_homotopic 0 hR hr (fun u => (outer u).property.1)
+      (fun u => (inner u).property.1)
+  have hil : (i.comp link).Nullhomotopic :=
+    puncturedSphereMap_outside_nullhomotopic 0 b hε.le (by simpa only [sub_zero] using hεb)
+      (fun u => (link u).property.1)
+  have hji : (j.comp inner).Nullhomotopic :=
+    puncturedSphereMap_outside_nullhomotopic b 0 hr.le
+      (by simpa only [zero_sub, norm_neg] using hrb) (fun u => (inner u).property.2)
+  have hcenter : ∀ u : Metric.sphere (0 : E) 1, b + R • u.val ≠ b :=
+    affine_sphere_ne_of_norm_ne hR.le (by simpa only [sub_self, norm_zero] using hR.ne)
+  let center := puncturedSphereMap b b R hcenter
+  have hoc : (j.comp outer).Homotopic center :=
+    puncturedSphereMap_center_homotopic b 0 (by simpa only [zero_sub, norm_neg] using hbR)
+      (fun u => (outer u).property.2) hcenter
+  have hcl : center.Homotopic (j.comp link) :=
+    puncturedSphereMap_radius_homotopic b hR hε hcenter (fun u => (link u).property.2)
+  have hjo := hoc.trans hcl
+  have hioMap := PeriodTorusHigherHomology.homotopic_homologyMap hio n
+  have hjoMap := PeriodTorusHigherHomology.homotopic_homologyMap hjo n
+  have hilMap :=
+    CuspCentralHomology.singularHomologyMap_eq_zero_of_nullhomotopic (i.comp link) hil n hn
+  have hjiMap :=
+    CuspCentralHomology.singularHomologyMap_eq_zero_of_nullhomotopic (j.comp inner) hji n hn
+  apply LinearMap.ext
+  intro a
+  change
+    SingularMayerVietoris.singularHomologyMap outer n a =
+      SingularMayerVietoris.singularHomologyMap inner n a +
+        SingularMayerVietoris.singularHomologyMap link n a
+  apply two_puncture_homology_ext hb.symm n
+  · change
+      SingularMayerVietoris.singularHomologyMap i n
+          (SingularMayerVietoris.singularHomologyMap outer n a) =
+        _
+    rw [map_add]
+    have ho :
+      SingularMayerVietoris.singularHomologyMap i n
+          (SingularMayerVietoris.singularHomologyMap outer n a) =
+        SingularMayerVietoris.singularHomologyMap i n
+          (SingularMayerVietoris.singularHomologyMap inner n a) := by
+      simpa only [PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply] using
+        LinearMap.congr_fun hioMap a
+    have hl :
+      SingularMayerVietoris.singularHomologyMap i n
+          (SingularMayerVietoris.singularHomologyMap link n a) =
+        0 := by
+      simpa only [PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply,
+        LinearMap.zero_apply] using LinearMap.congr_fun hilMap a
+    rw [ho, hl, add_zero]
+  · change
+      SingularMayerVietoris.singularHomologyMap j n
+          (SingularMayerVietoris.singularHomologyMap outer n a) =
+        _
+    rw [map_add]
+    have ho :
+      SingularMayerVietoris.singularHomologyMap j n
+          (SingularMayerVietoris.singularHomologyMap outer n a) =
+        SingularMayerVietoris.singularHomologyMap j n
+          (SingularMayerVietoris.singularHomologyMap link n a) := by
+      simpa only [PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply] using
+        LinearMap.congr_fun hjoMap a
+    have hi :
+      SingularMayerVietoris.singularHomologyMap j n
+          (SingularMayerVietoris.singularHomologyMap inner n a) =
+        0 := by
+      simpa only [PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply,
+        LinearMap.zero_apply] using LinearMap.congr_fun hjiMap a
+    rw [ho, hi, zero_add]
+
+private def Degree.PassageHomology.radialCylinderHomeomorph (E : Type) [NormedAddCommGroup E]
+    [NormedSpace ℝ E] : (ℝ × Metric.sphere (0 : E) 1) ≃ₜ ({0}ᶜ : Set E) :=
+  ((Homeomorph.prodComm ℝ (Metric.sphere (0 : E) 1)).trans
+        ((Homeomorph.refl (Metric.sphere (0 : E) 1)).prodCongr
+          Real.expOrderIso.toHomeomorph)).trans
+    (homeomorphUnitSphereProd E).symm
+
+private def
+    Degree.PassageHomology.cylinderPuncture {E : Type} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (τ : ℝ) (u : Metric.sphere (0 : E) 1) : E :=
+  Real.exp τ • u.val
+
+private theorem Degree.PassageHomology.norm_cylinderPuncture {E : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (τ : ℝ) (u : Metric.sphere (0 : E) 1) :
+    ‖cylinderPuncture τ u‖ = Real.exp τ := by
+  rw [cylinderPuncture, norm_smul, Real.norm_eq_abs, abs_of_pos (Real.exp_pos τ),
+    mem_sphere_zero_iff_norm.mp u.property, mul_one]
+
+private def Degree.PassageHomology.puncturedCylinderHomeomorph {E : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (τ : ℝ) (u : Metric.sphere (0 : E) 1) :
+    ({(τ, u)}ᶜ : Set (ℝ × Metric.sphere (0 : E) 1)) ≃ₜ twoPunctureSet 0 (cylinderPuncture τ u)
+    where
+  toFun
+    p := by
+    refine
+      ⟨(radialCylinderHomeomorph E p.val).val, (radialCylinderHomeomorph E p.val).property, ?_⟩
+    intro h
+    have he : radialCylinderHomeomorph E p.val = radialCylinderHomeomorph E (τ, u) :=
+      Subtype.ext h
+    exact p.property ((radialCylinderHomeomorph E).injective he)
+  invFun
+    z :=
+    ⟨(radialCylinderHomeomorph E).symm ⟨z.val, z.property.1⟩,
+      by
+      intro h
+      have hh := congrArg (radialCylinderHomeomorph E) h
+      rw [(radialCylinderHomeomorph E).apply_symm_apply] at hh
+      exact z.property.2 (congrArg Subtype.val hh)⟩
+  left_inv
+    p := by
+    apply Subtype.ext
+    change (radialCylinderHomeomorph E).symm (radialCylinderHomeomorph E p.val) = p.val
+    exact (radialCylinderHomeomorph E).symm_apply_apply p.val
+  right_inv
+    z := by
+    apply Subtype.ext
+    change
+      ((radialCylinderHomeomorph E)
+            ((radialCylinderHomeomorph E).symm ⟨z.val, z.property.1⟩)).val =
+        z.val
+    exact
+      congrArg (fun w : ({0}ᶜ : Set E) => w.val)
+        ((radialCylinderHomeomorph E).apply_symm_apply ⟨z.val, z.property.1⟩)
+  continuous_toFun :=
+    (continuous_subtype_val.comp
+          ((radialCylinderHomeomorph E).continuous.comp continuous_subtype_val)).subtype_mk
+      _
+  continuous_invFun := by
+    have hc :
+      Continuous
+        (fun z : twoPunctureSet 0 (cylinderPuncture τ u) =>
+          (⟨z.val, z.property.1⟩ : ({0}ᶜ : Set E))) :=
+      continuous_subtype_val.subtype_mk _
+    exact ((radialCylinderHomeomorph E).symm.continuous.comp hc).subtype_mk _
+
+private def Degree.PassageHomology.cylinderSlice {E : Type} [NormedAddCommGroup E] (τ : ℝ)
+    (u : Metric.sphere (0 : E) 1) (t : ℝ) (ht : t ≠ τ) :
+    C(Metric.sphere (0 : E) 1, ({(τ, u)}ᶜ : Set (ℝ × Metric.sphere (0 : E) 1)))
+    where
+  toFun v := ⟨(t, v), fun h => ht (congrArg Prod.fst h)⟩
+  continuous_toFun := (continuous_const.prodMk continuous_id).subtype_mk _
+
+private def Degree.PassageHomology.cylinderLink {E : Type} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (τ : ℝ) (u : Metric.sphere (0 : E) 1) (ε : ℝ) (hε : 0 < ε) (hεu : ε < Real.exp τ) :
+    C(Metric.sphere (0 : E) 1, ({(τ, u)}ᶜ : Set (ℝ × Metric.sphere (0 : E) 1))) :=
+  ((puncturedCylinderHomeomorph τ u).symm : C(_, _)).comp
+    (linkingSphere (cylinderPuncture τ u) ε hε (by rwa [norm_cylinderPuncture]))
+
+private theorem Degree.PassageHomology.punctured_cylinder_endpoint_relation {E : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] {τ : ℝ} (hτ : τ ∈ Set.Ioo (0 : ℝ) 1)
+    (u : Metric.sphere (0 : E) 1) {ε : ℝ} (hε : 0 < ε) (hεu : ε < Real.exp τ) (n : ℕ)
+    (hn : n ≠ 0) :
+    SingularMayerVietoris.singularHomologyMap (cylinderSlice τ u 1 hτ.2.ne') n =
+      SingularMayerVietoris.singularHomologyMap (cylinderSlice τ u 0 hτ.1.ne) n +
+        SingularMayerVietoris.singularHomologyMap (cylinderLink τ u ε hε hεu) n := by
+  let b := cylinderPuncture τ u
+  have hrb : (1 : ℝ) < ‖b‖ := by
+    rw [norm_cylinderPuncture]
+    exact Real.one_lt_exp_iff.mpr hτ.1
+  have hbR : ‖b‖ < Real.exp 1 := by
+    rw [norm_cylinderPuncture]
+    exact Real.exp_lt_exp.mpr hτ.2
+  have hεb : ε < ‖b‖ := by rwa [norm_cylinderPuncture]
+  let inner := innerSphere b 1 zero_lt_one hrb
+  let outer := outerSphere b (Real.exp 1) hbR
+  let link := linkingSphere b ε hε hεb
+  let e := puncturedCylinderHomeomorph τ u
+  let e' : C(twoPunctureSet 0 b, ({(τ, u)}ᶜ : Set (ℝ × Metric.sphere (0 : E) 1))) := e.symm
+  have hinner : e'.comp inner = cylinderSlice τ u 0 hτ.1.ne := by
+    apply ContinuousMap.ext
+    intro v
+    apply e.injective
+    change e (e.symm (inner v)) = e (cylinderSlice τ u 0 hτ.1.ne v)
+    rw [e.apply_symm_apply]
+    apply Subtype.ext
+    change (0 : E) + 1 • v.val = Real.exp 0 • v.val
+    rw [Real.exp_zero, one_smul, zero_add]
+  have houter : e'.comp outer = cylinderSlice τ u 1 hτ.2.ne' := by
+    apply ContinuousMap.ext
+    intro v
+    apply e.injective
+    change e (e.symm (outer v)) = e (cylinderSlice τ u 1 hτ.2.ne' v)
+    rw [e.apply_symm_apply]
+    apply Subtype.ext
+    change (0 : E) + Real.exp 1 • v.val = Real.exp 1 • v.val
+    rw [zero_add]
+  have H :
+    SingularMayerVietoris.singularHomologyMap (e'.comp outer) n =
+      SingularMayerVietoris.singularHomologyMap (e'.comp inner) n +
+        SingularMayerVietoris.singularHomologyMap (e'.comp link) n := by
+    rw [PeriodTorusHigherHomology.singularHomologyMap_comp,
+      PeriodTorusHigherHomology.singularHomologyMap_comp,
+      PeriodTorusHigherHomology.singularHomologyMap_comp]
+    have hrel := radial_sphere_homology_relation b zero_lt_one hrb hbR hε hεb n hn
+    change
+      (SingularMayerVietoris.singularHomologyMap e' n).comp
+          (SingularMayerVietoris.singularHomologyMap outer n) =
+        _
+    rw [hrel, LinearMap.comp_add]
+  rw [hinner, houter] at H
+  exact H
+
+private theorem
+    Degree.PassageHomology.punctured_cylinder_trace_relation {E : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {Y : Type} [TopologicalSpace Y] {τ : ℝ} (hτ : τ ∈ Set.Ioo (0 : ℝ) 1)
+    (u : Metric.sphere (0 : E) 1) {ε : ℝ} (hε : 0 < ε) (hεu : ε < Real.exp τ)
+    (F : C(({(τ, u)}ᶜ : Set (ℝ × Metric.sphere (0 : E) 1)), Y)) (n : ℕ) (hn : n ≠ 0) :
+    SingularMayerVietoris.singularHomologyMap (F.comp (cylinderSlice τ u 1 hτ.2.ne')) n =
+      SingularMayerVietoris.singularHomologyMap (F.comp (cylinderSlice τ u 0 hτ.1.ne)) n +
+        SingularMayerVietoris.singularHomologyMap (F.comp (cylinderLink τ u ε hε hεu)) n := by
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodTorusHigherHomology.singularHomologyMap_comp,
+    punctured_cylinder_endpoint_relation hτ u hε hεu n hn, LinearMap.comp_add]
+
+private def Degree.PassageHomology.clampTime : C(ℝ, ℝ) :=
+  ⟨fun t => Max.max 0 (Min.min 1 t), continuous_const.max (continuous_const.min continuous_id)⟩
+
+private theorem Degree.PassageHomology.clampTime_mem (t : ℝ) : clampTime t ∈ Set.Icc (0 : ℝ) 1 :=
+  ⟨le_max_left _ _, max_le zero_le_one (min_le_left _ _)⟩
+
+private theorem Degree.PassageHomology.clampTime_of_mem {t : ℝ} (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    clampTime t = t := by
+  change Max.max 0 (Min.min 1 t) = t
+  rw [min_eq_right ht.2, max_eq_right ht.1]
+
+private theorem
+    Degree.PassageHomology.clampTime_eq_interior_iff {τ : ℝ} (hτ : τ ∈ Set.Ioo (0 : ℝ) 1)
+    (t : ℝ) : clampTime t = τ ↔ t = τ := by
+  constructor
+  · intro he
+    by_cases ht0 : t ≤ 0
+    · have hc : clampTime t = 0 := by
+        change Max.max 0 (Min.min 1 t) = 0
+        rw [min_eq_right (ht0.trans zero_le_one), max_eq_left ht0]
+      exact (hτ.1.ne (hc.symm.trans he)).elim
+    by_cases ht1 : 1 ≤ t
+    · have hc : clampTime t = 1 := by
+        change Max.max 0 (Min.min 1 t) = 1
+        rw [min_eq_left ht1, max_eq_right zero_le_one]
+      exact (hτ.2.ne' (hc.symm.trans he)).elim
+    exact (clampTime_of_mem ⟨(lt_of_not_ge ht0).le, (lt_of_not_ge ht1).le⟩).symm.trans he
+  · intro he
+    subst t
+    exact clampTime_of_mem ⟨hτ.1.le, hτ.2.le⟩
+
+private def Degree.PassageHomology.puncturedPassageTrace {E X : Type} [NormedAddCommGroup E]
+    [TopologicalSpace X] (H : C(ℝ × Metric.sphere (0 : E) 1, X)) (S : Set X) {τ : ℝ}
+    (hτ : τ ∈ Set.Ioo (0 : ℝ) 1) (u : Metric.sphere (0 : E) 1)
+    (hcross :
+      ∀ t ∈ Set.Icc (0 : ℝ) 1, ∀ v : Metric.sphere (0 : E) 1, H (t, v) ∈ S ↔ t = τ ∧ v = u) :
+    C(({(τ, u)}ᶜ : Set (ℝ × Metric.sphere (0 : E) 1)), (Sᶜ : Set X))
+    where
+  toFun
+    p :=
+    ⟨H (clampTime p.val.1, p.val.2), by
+      intro hp
+      have he := (hcross _ (clampTime_mem _) p.val.2).mp hp
+      exact p.property (Prod.ext ((clampTime_eq_interior_iff hτ _).mp he.1) he.2)⟩
+  continuous_toFun := by
+    have ht :
+      Continuous (fun p : ({(τ, u)}ᶜ : Set (ℝ × Metric.sphere (0 : E) 1)) => clampTime p.val.1) :=
+      clampTime.continuous.comp (continuous_fst.comp continuous_subtype_val)
+    have hv : Continuous (fun p : ({(τ, u)}ᶜ : Set (ℝ × Metric.sphere (0 : E) 1)) => p.val.2) :=
+      continuous_snd.comp continuous_subtype_val
+    exact (H.continuous.comp (ht.prodMk hv)).subtype_mk _
+
+private theorem Degree.PassageHomology.puncturedPassageTrace_on_interval {E X : Type}
+    [NormedAddCommGroup E] [TopologicalSpace X]
+    (H : C(ℝ × Metric.sphere (0 : E) 1, X)) (S : Set X) {τ : ℝ} (hτ : τ ∈ Set.Ioo (0 : ℝ) 1)
+    (u : Metric.sphere (0 : E) 1)
+    (hcross :
+      ∀ t ∈ Set.Icc (0 : ℝ) 1, ∀ v : Metric.sphere (0 : E) 1, H (t, v) ∈ S ↔ t = τ ∧ v = u)
+    (p : ({(τ, u)}ᶜ : Set (ℝ × Metric.sphere (0 : E) 1))) (hp : p.val.1 ∈ Set.Icc (0 : ℝ) 1) :
+    (puncturedPassageTrace H S hτ u hcross p).val = H p.val := by
+  change H (clampTime p.val.1, p.val.2) = H p.val
+  rw [clampTime_of_mem hp]
+
+private theorem
+    MorseCancel.exists_native_open_curve_with_germ {G H N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [TopologicalSpace N]
+    [ChartedSpace H N] (S : TopologicalSpace.Opens N) {a : ℝ → N} {U : Set ℝ} {t₀ : ℝ}
+    (ha : ContMDiffOn 𝓘(ℝ, ℝ) J ∞ a U) (hU : IsOpen U) (ht₀ : t₀ ∈ U) (ha0 : a t₀ ∈ S) :
+    ∃ g : C(ℝ, S), ContMDiff 𝓘(ℝ, ℝ) J ∞ g ∧ (Subtype.val ∘ g) =ᶠ[𝓝 t₀] a := by
+  classical
+  let A : ℝ → S := fun t => if h : a t ∈ S then ⟨a t, h⟩ else ⟨a t₀, ha0⟩
+  let V := U ∩ a ⁻¹' (S : Set N)
+  have hV : IsOpen V := ha.continuousOn.isOpen_inter_preimage hU S.isOpen
+  have htV : t₀ ∈ V := ⟨ht₀, ha0⟩
+  have hval {t : ℝ} (ht : t ∈ V) : (Subtype.val ∘ A) =ᶠ[𝓝 t] a := by
+    filter_upwards [hV.mem_nhds ht] with s hs
+    have hsS : a s ∈ S := hs.2
+    simp only [Function.comp_apply, A, dite_eq_left hsS]
+  have hA : ContMDiffOn 𝓘(ℝ, ℝ) J ∞ A V := by
+    intro t ht
+    have hvalAt := (ha.contMDiffAt (hU.mem_nhds ht.1)).congr_of_eventuallyEq (hval ht)
+    exact ((ContMDiffAt.subtypeVal_comp_iff S A t).mp hvalAt).contMDiffWithinAt
+  obtain ⟨g, hg, heq⟩ := Smale.exists_smooth_curve_with_germ_at hA hV htV
+  refine ⟨g, hg, ?_⟩
+  filter_upwards [heq, hval htV] with t ht hta
+  exact (congrArg Subtype.val ht).trans hta
+
+private theorem MorseCancel.exists_embedded_native_open_arc_with_local_germs {G H N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [TopologicalSpace N] [ChartedSpace H N] [FiniteDimensional ℝ G] [J.Boundaryless]
+    [IsManifold J ∞ N] [T2Space N] (S : TopologicalSpace.Opens N) {a b : ℝ → N} {U V : Set ℝ}
+    (ha : ContMDiffOn 𝓘(ℝ, ℝ) J ∞ a U) (hb : ContMDiffOn 𝓘(ℝ, ℝ) J ∞ b V) (hU : IsOpen U)
+    (hV : IsOpen V) (h0U : (0 : ℝ) ∈ U) (h1V : (1 : ℝ) ∈ V) (ha0 : a 0 ∈ S) (hb1 : b 1 ∈ S)
+    (hia : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J a 0))
+    (hib : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J b 1))
+    (γ : Path (⟨a 0, ha0⟩ : S) (⟨b 1, hb1⟩ : S)) (hxy : a 0 ≠ b 1)
+    (hdim : 3 ≤ Module.finrank ℝ G) :
+    ∃ g : C(ℝ, S),
+      ContMDiff 𝓘(ℝ, ℝ) J ∞ g ∧
+        ((Subtype.val ∘ g) =ᶠ[𝓝 (0 : ℝ)] a) ∧
+          ((Subtype.val ∘ g) =ᶠ[𝓝 (1 : ℝ)] b) ∧
+            Topology.IsClosedEmbedding (fun t : unitInterval => g t) ∧
+              ∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J g t) := by
+  obtain ⟨a', ha', heqa⟩ := exists_native_open_curve_with_germ S ha hU h0U ha0
+  obtain ⟨b', hb', heqb⟩ := exists_native_open_curve_with_germ S hb hV h1V hb1
+  have hstart : a' 0 = (⟨a 0, ha0⟩ : S) := Subtype.ext heqa.eq_of_nhds
+  have hend : b' 1 = (⟨b 1, hb1⟩ : S) := Subtype.ext heqb.eq_of_nhds
+  have hia' : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J a' 0) := by
+    have hi : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J (Subtype.val ∘ a') 0) := by
+      rw [heqa.mfderiv_eq]
+      exact hia
+    rw [mfderiv_comp 0
+        ((contMDiff_subtype_val (I := J) (U := S) (n := ∞)).mdifferentiableAt (by simp))
+        (ha'.mdifferentiableAt (by simp))] at hi
+    intro x y hxy
+    exact hi (congrArg (mfderiv J J (Subtype.val : S → N) (a' 0)) hxy)
+  have hib' : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J b' 1) := by
+    have hi : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J (Subtype.val ∘ b') 1) := by
+      rw [heqb.mfderiv_eq]
+      exact hib
+    rw [mfderiv_comp 1
+        ((contMDiff_subtype_val (I := J) (U := S) (n := ∞)).mdifferentiableAt (by simp))
+        (hb'.mdifferentiableAt (by simp))] at hi
+    intro x y hxy
+    exact hi (congrArg (mfderiv J J (Subtype.val : S → N) (b' 1)) hxy)
+  have hxy' : a' 0 ≠ b' 1 := by
+    intro h
+    exact hxy (heqa.eq_of_nhds.symm.trans ((congrArg Subtype.val h).trans heqb.eq_of_nhds))
+  obtain ⟨g, hg, hga, hgb, hemb, hi, -⟩ :=
+    Smale.exists_embedded_arc_with_endpoint_germs a' b' ha' hb' hia' hib' (γ.cast hstart hend)
+      hxy' hdim (S := ∅) Set.finite_empty
+  refine ⟨g, hg, ?_, ?_, hemb, hi⟩
+  · filter_upwards [hga, heqa] with t hta hta'
+    exact (congrArg Subtype.val hta).trans hta'
+  · filter_upwards [hgb, heqb] with t htb htb'
+    exact (congrArg Subtype.val htb).trans htb'
+
+private theorem MorseCancel.injective_mfderiv_curve_translate {G H N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [TopologicalSpace N]
+    [ChartedSpace H N] {α : ℝ → N} {s c : ℝ} (hα : MDifferentiableAt 𝓘(ℝ, ℝ) J α (s + c))
+    (hi : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J α (s + c))) :
+    Function.Injective (mfderiv 𝓘(ℝ, ℝ) J (fun t => α (t + c)) s) := by
+  have ht : MDifferentiableAt 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) (fun t : ℝ => t + c) s :=
+    (contMDiff_id.add (contMDiff_const (c := c)) :
+          ContMDiff 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) ∞ (fun t : ℝ => t + c)).mdifferentiableAt
+      (by simp)
+  have hd : mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) (fun t : ℝ => t + c) s = ContinuousLinearMap.id ℝ ℝ := by
+    rw [mfderiv_eq_fderiv]
+    change fderiv ℝ (fun t : ℝ => id t + c) s = _
+    rw [fderiv_add_const, fderiv_id]
+  change Function.Injective (mfderiv 𝓘(ℝ, ℝ) J (α ∘ (fun t : ℝ => t + c)) s)
+  rw [mfderiv_comp s hα ht]
+  intro x y hxy
+  apply hi
+  have hdx : mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) (fun t : ℝ => t + c) s x = x :=
+    congrArg (fun L : ℝ →L[ℝ] ℝ => L x) hd
+  have hdy : mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) (fun t : ℝ => t + c) s y = y :=
+    congrArg (fun L : ℝ →L[ℝ] ℝ => L y) hd
+  change
+    mfderiv 𝓘(ℝ, ℝ) J α (s + c) (mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) (fun t : ℝ => t + c) s x) =
+      mfderiv 𝓘(ℝ, ℝ) J α (s + c) (mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) (fun t : ℝ => t + c) s y) at hxy
+  rw [hdx, hdy] at hxy
+  exact hxy
+
+private theorem
+    MorseCancel.exists_embedded_return_arc_inside_open {G H N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [TopologicalSpace N]
+    [ChartedSpace H N] [FiniteDimensional ℝ G] [J.Boundaryless] [IsManifold J ∞ N] [T2Space N]
+    (S : TopologicalSpace.Opens N) {α : ℝ → N} {R r : ℝ} (hr : 0 < r) (hrR : r < R)
+    (hα : ContMDiffOn 𝓘(ℝ, ℝ) J ∞ α (Set.Ioo (-R) R)) (hinj : Set.InjOn α (Set.Icc (-R) R))
+    (hderiv : ∀ s ∈ Set.Ioo (-R) R, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J α s)) (hplus : α r ∈ S)
+    (hminus : α (-r) ∈ S) (γ : Path (⟨α r, hplus⟩ : S) (⟨α (-r), hminus⟩ : S))
+    (hdim : 3 ≤ Module.finrank ℝ G) :
+    ∃ g : C(ℝ, S),
+      ContMDiff 𝓘(ℝ, ℝ) J ∞ g ∧
+        ((Subtype.val ∘ g) =ᶠ[𝓝 (0 : ℝ)] (fun t => α (t + r))) ∧
+          ((Subtype.val ∘ g) =ᶠ[𝓝 (1 : ℝ)] (fun t => α (t + (-1 - r)))) ∧
+            Topology.IsClosedEmbedding (fun t : unitInterval => g t) ∧
+              ∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J g t) := by
+  let a : ℝ → N := fun t => α (t + r)
+  let b : ℝ → N := fun t => α (t + (-1 - r))
+  let U : Set ℝ := (fun t : ℝ => t + r) ⁻¹' Set.Ioo (-R) R
+  let V : Set ℝ := (fun t : ℝ => t + (-1 - r)) ⁻¹' Set.Ioo (-R) R
+  have hU : IsOpen U := isOpen_Ioo.preimage (continuous_id.add continuous_const)
+  have hV : IsOpen V := isOpen_Ioo.preimage (continuous_id.add continuous_const)
+  have hp : r ∈ Set.Ioo (-R) R := ⟨by linarith, hrR⟩
+  have hm : -r ∈ Set.Ioo (-R) R := ⟨by linarith, by linarith⟩
+  have h0U : (0 : ℝ) ∈ U := by simpa only [U, Set.mem_preimage, zero_add] using hp
+  have h1V : (1 : ℝ) ∈ V := by
+    change 1 + (-1 - r) ∈ Set.Ioo (-R) R
+    simpa only [show (1 : ℝ) + (-1 - r) = -r by ring] using hm
+  have ha : ContMDiffOn 𝓘(ℝ, ℝ) J ∞ a U :=
+    hα.comp (contMDiff_id.add contMDiff_const).contMDiffOn (fun _ ht => ht)
+  have hb : ContMDiffOn 𝓘(ℝ, ℝ) J ∞ b V :=
+    hα.comp (contMDiff_id.add contMDiff_const).contMDiffOn (fun _ ht => ht)
+  have ha0 : a 0 = α r := by dsimp [a]; rw [zero_add]
+  have hb1 : b 1 = α (-r) := by dsimp [b]; congr 1; ring
+  have hia : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J a 0) := by
+    apply injective_mfderiv_curve_translate
+    · simpa only [zero_add] using
+        (hα.contMDiffAt (Ioo_mem_nhds hp.1 hp.2)).mdifferentiableAt (by simp)
+    · exact (zero_add r).symm ▸ hderiv r hp
+  have hib : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J b 1) := by
+    apply injective_mfderiv_curve_translate
+    · simpa only [show (1 : ℝ) + (-1 - r) = -r by ring] using
+        (hα.contMDiffAt (Ioo_mem_nhds hm.1 hm.2)).mdifferentiableAt (by simp)
+    · exact (show (1 : ℝ) + (-1 - r) = -r by ring).symm ▸ hderiv (-r) hm
+  have haS : a 0 ∈ S := ha0.symm ▸ hplus
+  have hbS : b 1 ∈ S := hb1.symm ▸ hminus
+  have hpath : Path (⟨a 0, haS⟩ : S) (⟨b 1, hbS⟩ : S) :=
+    γ.cast (Subtype.ext ha0) (Subtype.ext hb1)
+  have hxy : a 0 ≠ b 1 := by
+    rw [ha0, hb1]
+    intro hh
+    have heq := hinj ⟨hp.1.le, hp.2.le⟩ ⟨hm.1.le, hm.2.le⟩ hh
+    linarith
+  exact
+    exists_embedded_native_open_arc_with_local_germs S ha hb hU hV h0U h1V haS hbS hia hib hpath
+      hxy hdim
+
+private theorem
+    MorseCancel.exists_clean_return_endpoint_neighborhood {N : Type*}
+    {α β : ℝ → N} {R r : ℝ} (hr : 0 < r) (hrR : r < R) (hinj : Set.InjOn α (Set.Icc (-R) R))
+    (h0 : β =ᶠ[𝓝 (0 : ℝ)] (fun t => α (t + r)))
+    (h1 : β =ᶠ[𝓝 (1 : ℝ)] (fun t => α (t + (-1 - r)))) :
+    ∃ C : Set ℝ,
+      IsClosed C ∧
+        ({0, 1} : Set ℝ) ⊆ interior C ∧
+          ∀ t ∈ Set.Icc (0 : ℝ) 1 ∩ C, t ∉ ({0, 1} : Set ℝ) → β t ∉ α '' Set.Icc (-r) r := by
+  have hp : r ∈ Set.Ioo (-R) R := ⟨by linarith, hrR⟩
+  have hm : -r ∈ Set.Ioo (-R) R := ⟨by linarith, by linarith⟩
+  have hnear0 : ∀ᶠ t in 𝓝 (0 : ℝ), β t = α (t + r) ∧ t + r ∈ Set.Ioo (-R) R := by
+    have hn : ∀ᶠ t in 𝓝 (0 : ℝ), t + r ∈ Set.Ioo (-R) R :=
+      ((continuous_id.add continuous_const).continuousAt.tendsto
+        (show Set.Ioo (-R) R ∈ 𝓝 ((0 : ℝ) + r) by
+          simpa only [zero_add] using Ioo_mem_nhds hp.1 hp.2))
+    exact h0.and hn
+  have hnear1 : ∀ᶠ t in 𝓝 (1 : ℝ), β t = α (t + (-1 - r)) ∧ t + (-1 - r) ∈ Set.Ioo (-R) R := by
+    have hn : ∀ᶠ t in 𝓝 (1 : ℝ), t + (-1 - r) ∈ Set.Ioo (-R) R :=
+      ((continuous_id.add continuous_const).continuousAt.tendsto
+        (show Set.Ioo (-R) R ∈ 𝓝 ((1 : ℝ) + (-1 - r)) by
+          simpa only [show (1 : ℝ) + (-1 - r) = -r by ring] using Ioo_mem_nhds hm.1 hm.2))
+    exact h1.and hn
+  obtain ⟨δ₀, hδ₀, hball0⟩ := Metric.nhds_basis_closedBall.mem_iff.mp hnear0
+  obtain ⟨δ₁, hδ₁, hball1⟩ := Metric.nhds_basis_closedBall.mem_iff.mp hnear1
+  let C : Set ℝ := Metric.closedBall 0 δ₀ ∪ Metric.closedBall 1 δ₁
+  have h0C : C ∈ 𝓝 (0 : ℝ) :=
+    Filter.mem_of_superset (Metric.ball_mem_nhds 0 hδ₀)
+      (fun _ ht => Or.inl (Metric.ball_subset_closedBall ht))
+  have h1C : C ∈ 𝓝 (1 : ℝ) :=
+    Filter.mem_of_superset (Metric.ball_mem_nhds 1 hδ₁)
+      (fun _ ht => Or.inr (Metric.ball_subset_closedBall ht))
+  refine ⟨C, Metric.isClosed_closedBall.union Metric.isClosed_closedBall, ?_, ?_⟩
+  · intro t ht
+    rcases ht with rfl | ht
+    · exact mem_interior_iff_mem_nhds.mpr h0C
+    · have ht1 : t = 1 := ht
+      subst t
+      exact mem_interior_iff_mem_nhds.mpr h1C
+  · intro t ht htB
+    rintro ⟨s, hs, heq⟩
+    have hsR : s ∈ Set.Icc (-R) R := ⟨by linarith [hs.1], by linarith [hs.2]⟩
+    rcases ht.2 with ht0 | ht1
+    · have hg := hball0 ht0
+      have hts := hinj ⟨hg.2.1.le, hg.2.2.le⟩ hsR (hg.1.symm.trans heq.symm)
+      have htne : t ≠ 0 := fun h => htB (Or.inl h)
+      have htpos : 0 < t := lt_of_le_of_ne ht.1.1 htne.symm
+      linarith [hs.2]
+    · have hg := hball1 ht1
+      have hts := hinj ⟨hg.2.1.le, hg.2.2.le⟩ hsR (hg.1.symm.trans heq.symm)
+      have htne : t ≠ 1 := fun h => htB (Or.inr h)
+      have htlt : t < 1 := lt_of_le_of_ne ht.1.2 htne
+      linarith [hs.1]
+
+private theorem Smale.ManifoldImmersion.exists_relative_embedded_avoidance_in_open_of_isClosed_range
+    {E E' G H H' Y N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup E'] [NormedSpace ℝ E'] [FiniteDimensional ℝ E'] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    {J : ModelWithCorners ℝ G H} {I' : ModelWithCorners ℝ E' H'} [J.Boundaryless]
+    [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y] [SecondCountableTopology Y]
+    [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N]
+    (U : TopologicalSpace.Opens N) (f : C(E, U)) (g : C(Y, N)) (hf : ContMDiff 𝓘(ℝ, E) J ∞ f)
+    (hg : ContMDiff I' J ∞ g) (hclosed : IsClosed (Set.range g))
+    (hsourceDim : Module.finrank ℝ E = 2) (hdim : 5 ≤ Module.finrank ℝ G)
+    (hobstacle : Module.finrank ℝ E + Module.finrank ℝ E' < Module.finrank ℝ G) {K C B : Set E}
+    (hK : IsCompact K) (hC : IsClosed C) (hBC : B ⊆ interior C) (hinj : Set.InjOn f (K ∩ C))
+    (hderiv : ∀ x ∈ K ∩ C, Function.Injective (mfderiv 𝓘(ℝ, E) J f x))
+    (hclean : ∀ x ∈ K ∩ C, x ∉ B → (f x : N) ∉ Set.range g) :
+    ∃ f' : C(E, U),
+      ContMDiff 𝓘(ℝ, E) J ∞ f' ∧
+        f.HomotopicRel f' C ∧
+          Topology.IsClosedEmbedding (fun x : K => f' x) ∧
+            (∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f' x)) ∧
+              ∀ x ∈ K \ B, (f' x : N) ∉ Set.range g := by
+  have hclean' : ∀ x ∈ K ∩ C, x ∉ B → f x ∉ Set.range (Smale.OpenObstacle.restrict g U) := by
+    intro x hx hxB hmem
+    exact hclean x hx hxB ((Smale.OpenObstacle.mem_range_restrict_iff g U (f x)).mp hmem)
+  obtain ⟨f', hf', hhom, hemb, hderiv', havoid⟩ :=
+    exists_relative_embedded_avoidance_of_clean_neighborhood_of_isClosed_range f
+      (Smale.OpenObstacle.restrict g U) hf (Smale.OpenObstacle.contMDiff_restrict g U hg)
+      (Smale.OpenObstacle.isClosed_range_restrict g U hclosed) hsourceDim hdim hobstacle hK hC hBC
+      hinj hderiv hclean'
+  refine ⟨f', hf', hhom, hemb, hderiv', ?_⟩
+  intro x hx hmem
+  exact havoid x hx ((Smale.OpenObstacle.mem_range_restrict_iff g U (f' x)).mpr hmem)
+
+private theorem
+    Smale.ManifoldImmersion.exists_embedded_image_avoidance_relative_neighborhood_in_open
+    {E E' G H H' Y N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup E'] [NormedSpace ℝ E'] [FiniteDimensional ℝ E'] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    {J : ModelWithCorners ℝ G H} {I' : ModelWithCorners ℝ E' H'} [J.Boundaryless]
+    [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y] [SecondCountableTopology Y]
+    [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N]
+    (U : TopologicalSpace.Opens N) (f : C(E, U)) (g : C(Y, N)) (A : Set Y)
+    (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) (hg : ContMDiff I' J ∞ g) (hclosed : IsClosed (g '' A))
+    (hself : 2 * Module.finrank ℝ E < Module.finrank ℝ G)
+    (hobstacle : Module.finrank ℝ E + Module.finrank ℝ E' < Module.finrank ℝ G) {K C B : Set E}
+    (hK : IsCompact K) (hC : IsClosed C) (hBC : B ⊆ interior C) (hinj : Set.InjOn f K)
+    (hderiv : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f x))
+    (hclean : ∀ x ∈ K ∩ C, x ∉ B → (f x : N) ∉ g '' A) {O : Set U} (hO : IsOpen O)
+    (hmaps : Set.MapsTo f K O) :
+    ∃ f' : C(E, U),
+      ContMDiff 𝓘(ℝ, E) J ∞ f' ∧
+        f.HomotopicRel f' C ∧
+          Topology.IsClosedEmbedding (fun x : K => f' x) ∧
+            (∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f' x)) ∧
+              Set.MapsTo f' K O ∧ ∀ x ∈ K \ B, (f' x : N) ∉ g '' A := by
+  let A' : Set (Smale.OpenObstacle.source g U) := Subtype.val ⁻¹' A
+  have hclean' : ∀ x ∈ K ∩ C, x ∉ B → f x ∉ Smale.OpenObstacle.restrict g U '' A' := by
+    intro x hx hxB hmem
+    rw [Smale.OpenObstacle.image_restrict] at hmem
+    exact hclean x hx hxB hmem
+  obtain ⟨f', hf', hhom, hemb, hd, hmaps', havoid⟩ :=
+    exists_embedded_image_avoidance_relative_neighborhood f (Smale.OpenObstacle.restrict g U) A'
+      hf (Smale.OpenObstacle.contMDiff_restrict g U hg)
+      (Smale.OpenObstacle.isClosed_image_restrict g U A hclosed) hself hobstacle hK hC hBC hinj
+      hderiv hclean' hO hmaps
+  refine ⟨f', hf', hhom, hemb, hd, hmaps', ?_⟩
+  intro x hx hmem
+  apply havoid x hx
+  rw [Smale.OpenObstacle.image_restrict]
+  exact hmem
+
+private theorem Smale.ManifoldImmersion.exists_relative_embedded_avoidance_in_open
+    {E E' G H H' Y N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup E'] [NormedSpace ℝ E'] [FiniteDimensional ℝ E'] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    {J : ModelWithCorners ℝ G H} {I' : ModelWithCorners ℝ E' H'} [J.Boundaryless]
+    [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y] [TopologicalSpace N]
+    [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N] [CompactSpace Y]
+    [SecondCountableTopology H'] (U : TopologicalSpace.Opens N) (f : C(E, U)) (g : C(Y, N))
+    (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) (hg : ContMDiff I' J ∞ g) (hsourceDim : Module.finrank ℝ E = 2)
+    (hdim : 5 ≤ Module.finrank ℝ G)
+    (hobstacle : Module.finrank ℝ E + Module.finrank ℝ E' < Module.finrank ℝ G) {K C B : Set E}
+    (hK : IsCompact K) (hC : IsClosed C) (hBC : B ⊆ interior C) (hinj : Set.InjOn f (K ∩ C))
+    (hderiv : ∀ x ∈ K ∩ C, Function.Injective (mfderiv 𝓘(ℝ, E) J f x))
+    (hclean : ∀ x ∈ K ∩ C, x ∉ B → (f x : N) ∉ Set.range g) :
+    ∃ f' : C(E, U),
+      ContMDiff 𝓘(ℝ, E) J ∞ f' ∧
+        f.HomotopicRel f' C ∧
+          Topology.IsClosedEmbedding (fun x : K => f' x) ∧
+            (∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f' x)) ∧
+              ∀ x ∈ K \ B, (f' x : N) ∉ Set.range g := by
+  let : SecondCountableTopology Y := ChartedSpace.secondCountable_of_sigmaCompact H' Y
+  exact
+    exists_relative_embedded_avoidance_in_open_of_isClosed_range U f g hf hg
+      (isCompact_range g.continuous).isClosed hsourceDim hdim hobstacle hK hC hBC hinj hderiv
+      hclean
+
+private theorem
+    MorseCancel.exists_disjoint_embedded_return_arc {G H N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N]
+    (S : TopologicalSpace.Opens N) {α : ℝ → N} {R r : ℝ} (hr : 0 < r) (hrR : r < R)
+    (hα : ContMDiffOn 𝓘(ℝ, ℝ) J ∞ α (Set.Ioo (-R) R)) (hinj : Set.InjOn α (Set.Icc (-R) R))
+    (hderiv : ∀ s ∈ Set.Ioo (-R) R, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J α s)) (hplus : α r ∈ S)
+    (hminus : α (-r) ∈ S) (γ : Path (⟨α r, hplus⟩ : S) (⟨α (-r), hminus⟩ : S))
+    (hdim : 3 ≤ Module.finrank ℝ G) :
+    ∃ g : C(ℝ, S),
+      ContMDiff 𝓘(ℝ, ℝ) J ∞ g ∧
+        ((Subtype.val ∘ g) =ᶠ[𝓝 (0 : ℝ)] (fun t => α (t + r))) ∧
+          ((Subtype.val ∘ g) =ᶠ[𝓝 (1 : ℝ)] (fun t => α (t + (-1 - r)))) ∧
+            Topology.IsClosedEmbedding (fun t : unitInterval => g t) ∧
+              (∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J g t)) ∧
+                ∀ t ∈ Set.Ioo (0 : ℝ) 1, (g t : N) ∉ α '' Set.Icc (-r) r := by
+  obtain ⟨β, hβ, hβ0, hβ1, hemb, hβd⟩ :=
+    exists_embedded_return_arc_inside_open S hr hrR hα hinj hderiv hplus hminus γ hdim
+  obtain ⟨C, hC, hBC, hclean⟩ := exists_clean_return_endpoint_neighborhood hr hrR hinj hβ0 hβ1
+  let Q : TopologicalSpace.Opens ℝ := ⟨Set.Ioo (-R) R, isOpen_Ioo⟩
+  let q : C(Q, N) :=
+    ⟨fun s => α s,
+      continuous_iff_continuousAt.mpr
+        (fun s =>
+          (hα.continuousOn.continuousAt (isOpen_Ioo.mem_nhds s.property)).comp
+            continuous_subtype_val.continuousAt)⟩
+  have hq : ContMDiff 𝓘(ℝ, ℝ) J ∞ q := by
+    intro s
+    exact
+      (hα.contMDiffAt (isOpen_Ioo.mem_nhds s.property)).comp s
+        (contMDiff_subtype_val (n := ∞)).contMDiffAt
+  let A : Set Q := {s | (s : ℝ) ∈ Set.Icc (-r) r}
+  have hsub : Set.Icc (-r) r ⊆ Set.Ioo (-R) R := fun s hs =>
+    ⟨by linarith [hs.1], by linarith [hs.2]⟩
+  have himage : q '' A = α '' Set.Icc (-r) r := by
+    ext x
+    constructor
+    · rintro ⟨s, hs, rfl⟩
+      exact ⟨s, hs, rfl⟩
+    · rintro ⟨s, hs, rfl⟩
+      exact ⟨⟨s, hsub hs⟩, hs, rfl⟩
+  have hclosed : IsClosed (q '' A) := by
+    rw [himage]
+    exact
+      (CompactIccSpace.isCompact_Icc.image_of_continuousOn (hα.continuousOn.mono hsub)).isClosed
+  have hself : 2 * Module.finrank ℝ ℝ < Module.finrank ℝ G := by
+    simp only [Module.finrank_self]
+    omega
+  have hobstacle : Module.finrank ℝ ℝ + Module.finrank ℝ ℝ < Module.finrank ℝ G := by
+    simp only [Module.finrank_self]
+    omega
+  have hβinj : Set.InjOn β (Set.Icc (0 : ℝ) 1) := by
+    intro x hx y hy hxy
+    exact congrArg Subtype.val (hemb.injective (a₁ := ⟨x, hx⟩) (a₂ := ⟨y, hy⟩) hxy)
+  have hclean' : ∀ t ∈ Set.Icc (0 : ℝ) 1 ∩ C, t ∉ ({0, 1} : Set ℝ) → (β t : N) ∉ q '' A := by
+    intro t ht htB
+    rw [himage]
+    exact hclean t ht htB
+  obtain ⟨g, hg, hhom, hembg, hdg, -, havoid⟩ :=
+    Smale.ManifoldImmersion.exists_embedded_image_avoidance_relative_neighborhood_in_open S β q A
+      hβ hq hclosed hself hobstacle CompactIccSpace.isCompact_Icc hC hBC hβinj hβd hclean'
+      isOpen_univ (fun _ _ => Set.mem_univ _)
+  have h0C : C ∈ 𝓝 (0 : ℝ) := mem_interior_iff_mem_nhds.mp (hBC (Or.inl rfl))
+  have h1C : C ∈ 𝓝 (1 : ℝ) := mem_interior_iff_mem_nhds.mp (hBC (Or.inr rfl))
+  refine ⟨g, hg, ?_, ?_, hembg, hdg, ?_⟩
+  · filter_upwards [h0C, hβ0] with t ht ht0
+    exact (congrArg Subtype.val (hhom.fst_eq_snd ht)).symm.trans ht0
+  · filter_upwards [h1C, hβ1] with t ht ht1
+    exact (congrArg Subtype.val (hhom.fst_eq_snd ht)).symm.trans ht1
+  · intro t ht hmem
+    have htB : t ∉ ({0, 1} : Set ℝ) := by
+      simp only [Set.mem_insert_iff, Set.mem_singleton_iff, not_or]
+      exact ⟨ne_of_gt ht.1, ne_of_lt ht.2⟩
+    exact havoid t ⟨⟨ht.1.le, ht.2.le⟩, htB⟩ (himage.symm ▸ hmem)
+
+private def
+    Degree.CircleGluing.periodicExtension {N : Type*} {T : ℝ} (hT : 0 < T) (f : ℝ → N) (t : ℝ) :
+    N :=
+  f (toIcoMod hT 0 t)
+
+private theorem Degree.CircleGluing.periodicExtension_periodic {N : Type*} {T : ℝ} (hT : 0 < T)
+    (f : ℝ → N) : Function.Periodic (periodicExtension hT f) T := fun t =>
+  congrArg f (toIcoMod_add_right hT 0 t)
+
+private theorem
+    Degree.CircleGluing.periodicExtension_germ_in_fundamental_interval {N : Type*} {T : ℝ}
+    (hT : 0 < T) {f : ℝ → N} (hmatch : (fun t => f (t + T)) =ᶠ[𝓝 (0 : ℝ)] f) {x : ℝ}
+    (hx : x ∈ Set.Ico (0 : ℝ) T) : periodicExtension hT f =ᶠ[𝓝 x] f := by
+  by_cases hx0 : x = 0
+  · subst x
+    filter_upwards [hmatch, Ioo_mem_nhds (neg_lt_zero.mpr hT) hT] with t ht htn
+    change f (toIcoMod hT 0 t) = f t
+    by_cases ht0 : 0 ≤ t
+    · rw [(toIcoMod_eq_self hT).mpr ⟨ht0, by simpa only [zero_add] using htn.2⟩]
+    · have hmod : toIcoMod hT 0 t = t + T := by
+        apply (toIcoMod_eq_iff hT).mpr
+        refine ⟨⟨by linarith [htn.1], by linarith⟩, -1, ?_⟩
+        simp
+      rw [hmod]
+      exact ht
+  · have hxpos : 0 < x := lt_of_le_of_ne hx.1 (Ne.symm hx0)
+    filter_upwards [Ioo_mem_nhds hxpos hx.2] with t ht
+    change f (toIcoMod hT 0 t) = f t
+    rw [(toIcoMod_eq_self hT).mpr ⟨ht.1.le, by simpa only [zero_add] using ht.2⟩]
+
+private theorem
+    Degree.CircleGluing.periodicExtension_germ {N : Type*} {T : ℝ} (hT : 0 < T) {f : ℝ → N}
+    (hmatch : (fun t => f (t + T)) =ᶠ[𝓝 (0 : ℝ)] f) (x : ℝ) :
+    ∃ c : ℝ, x + c ∈ Set.Ico (0 : ℝ) T ∧ periodicExtension hT f =ᶠ[𝓝 x] (fun t => f (t + c)) := by
+  let n : ℤ := toIcoDiv hT 0 x
+  let c : ℝ := -(n • T)
+  have hx : x + c = toIcoMod hT 0 x := by
+    change x - n • T = toIcoMod hT 0 x
+    rfl
+  have hxc : x + c ∈ Set.Ico (0 : ℝ) T := by
+    rw [hx]
+    simpa only [zero_add] using toIcoMod_mem_Ico hT 0 x
+  have hg := periodicExtension_germ_in_fundamental_interval hT hmatch hxc
+  have ht : Filter.Tendsto (fun t : ℝ => t + c) (𝓝 x) (𝓝 (x + c)) :=
+    (continuous_id.add continuous_const).continuousAt
+  refine ⟨c, hxc, ?_⟩
+  filter_upwards [hg.comp_tendsto ht] with t ht
+  have heq : periodicExtension hT f (t + c) = periodicExtension hT f t :=
+    congrArg f (toIcoMod_sub_zsmul hT 0 t n)
+  exact heq.symm.trans ht
+
+private theorem Degree.CircleGluing.periodicExtension_contMDiff {N : Type*} {T : ℝ} {G H : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [TopologicalSpace N] [ChartedSpace H N] (hT : 0 < T) {f : ℝ → N}
+    (hmatch : (fun t => f (t + T)) =ᶠ[𝓝 (0 : ℝ)] f)
+    (hf : ∀ t ∈ Set.Ico (0 : ℝ) T, ContMDiffAt 𝓘(ℝ, ℝ) J ∞ f t) :
+    ContMDiff 𝓘(ℝ, ℝ) J ∞ (periodicExtension hT f) := by
+  intro x
+  obtain ⟨c, hc, heq⟩ := periodicExtension_germ hT hmatch x
+  exact
+    ((hf (x + c) hc).comp x (contMDiff_id.add contMDiff_const).contMDiffAt).congr_of_eventuallyEq
+      heq
+
+private theorem Degree.CircleGluing.periodicExtension_derivative_injective {N : Type*} {T : ℝ}
+    {G H : Type*} [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [TopologicalSpace N] [ChartedSpace H N] (hT : 0 < T) {f : ℝ → N}
+    (hmatch : (fun t => f (t + T)) =ᶠ[𝓝 (0 : ℝ)] f)
+    (hf : ∀ t ∈ Set.Ico (0 : ℝ) T, MDifferentiableAt 𝓘(ℝ, ℝ) J f t)
+    (hi : ∀ t ∈ Set.Ico (0 : ℝ) T, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J f t)) (x : ℝ) :
+    Function.Injective (mfderiv 𝓘(ℝ, ℝ) J (periodicExtension hT f) x) := by
+  obtain ⟨c, hc, heq⟩ := periodicExtension_germ hT hmatch x
+  rw [heq.mfderiv_eq]
+  exact MorseCancel.injective_mfderiv_curve_translate (hf (x + c) hc) (hi (x + c) hc)
+
+attribute [local instance 100] Classical.propDecidable in
+private def Degree.CircleGluing.joinedArc {N : Type*} (α β : ℝ → N) (r t : ℝ) : N :=
+  if t ≤ 2 * r then α (t + (-r)) else β (t + (-2 * r))
+
+private theorem
+    Degree.CircleGluing.joinedArc_left {N : Type*} {α β : ℝ → N} {r t : ℝ} (ht : t ≤ 2 * r) :
+    joinedArc α β r t = α (t + (-r)) :=
+  ite_eq_left ht
+
+private theorem
+    Degree.CircleGluing.joinedArc_right {N : Type*} {α β : ℝ → N} {r t : ℝ} (ht : 2 * r < t) :
+    joinedArc α β r t = β (t + (-2 * r)) :=
+  ite_eq_right (not_le.mpr ht)
+
+private theorem Degree.CircleGluing.joinedArc_left_germ {N : Type*} {α β : ℝ → N} {r t : ℝ}
+    (ht : t < 2 * r) : joinedArc α β r =ᶠ[𝓝 t] (fun s => α (s + (-r))) := by
+  filter_upwards [Iio_mem_nhds ht] with s hs
+  exact joinedArc_left hs.le
+
+private theorem Degree.CircleGluing.joinedArc_right_germ {N : Type*} {α β : ℝ → N} {r t : ℝ}
+    (ht : 2 * r < t) : joinedArc α β r =ᶠ[𝓝 t] (fun s => β (s + (-2 * r))) := by
+  filter_upwards [Ioi_mem_nhds ht] with s hs
+  exact joinedArc_right hs
+
+private theorem Degree.CircleGluing.joinedArc_seam_germ {N : Type*} {α β : ℝ → N} {r : ℝ}
+    (h0 : β =ᶠ[𝓝 (0 : ℝ)] (fun t => α (t + r))) :
+    joinedArc α β r =ᶠ[𝓝 (2 * r)] (fun s => α (s + (-r))) := by
+  have ht : Filter.Tendsto (fun t : ℝ => t + (-2 * r)) (𝓝 (2 * r)) (𝓝 0) := by
+    have hc : Continuous (fun t : ℝ => t + (-2 * r)) := continuous_id.add continuous_const
+    simpa only [show 2 * r + (-2 * r) = 0 by ring] using hc.continuousAt.tendsto (x := 2 * r)
+  filter_upwards [h0.comp_tendsto ht] with t ht
+  change β (t + (-2 * r)) = α (t + (-2 * r) + r) at ht
+  by_cases htr : t ≤ 2 * r
+  · exact joinedArc_left htr
+  · rw [joinedArc_right (lt_of_not_ge htr), ht]
+    congr 1
+    ring
+
+private theorem
+    Degree.CircleGluing.joinedArc_periodic_germ {N : Type*} {α β : ℝ → N} {r : ℝ} (hr : 0 < r)
+    (h1 : β =ᶠ[𝓝 (1 : ℝ)] (fun t => α (t + (-1 - r)))) :
+    (fun t => joinedArc α β r (t + (2 * r + 1))) =ᶠ[𝓝 (0 : ℝ)] joinedArc α β r := by
+  have ht : Filter.Tendsto (fun t : ℝ => t + 1) (𝓝 (0 : ℝ)) (𝓝 1) := by
+    have hc : Continuous (fun t : ℝ => t + 1) := continuous_id.add continuous_const
+    simpa only [zero_add] using hc.continuousAt.tendsto (x := 0)
+  filter_upwards [h1.comp_tendsto ht,
+    Ioo_mem_nhds (show (-1 : ℝ) < 0 by norm_num) (show 0 < 2 * r by linarith)] with t ht htn
+  change β (t + 1) = α (t + 1 + (-1 - r)) at ht
+  rw [joinedArc_right (by linarith [htn.1]), joinedArc_left htn.2.le,
+    show t + (2 * r + 1) + (-2 * r) = t + 1 by ring, ht]
+  congr 1
+  ring
+
+private theorem Degree.CircleGluing.joinedArc_injOn {N : Type*} {α β : ℝ → N} {r : ℝ}
+    (hα : Set.InjOn α (Set.Icc (-r) r)) (hβ : Set.InjOn β (Set.Icc (0 : ℝ) 1))
+    (havoid : ∀ t ∈ Set.Ioo (0 : ℝ) 1, β t ∉ α '' Set.Icc (-r) r) :
+    Set.InjOn (joinedArc α β r) (Set.Ico (0 : ℝ) (2 * r + 1)) := by
+  intro x hx y hy hxy
+  have hleft {t : ℝ} (ht : t ∈ Set.Ico (0 : ℝ) (2 * r + 1)) (hle : t ≤ 2 * r) :
+    t + (-r) ∈ Set.Icc (-r) r := ⟨by linarith [ht.1], by linarith⟩
+  have hright {t : ℝ} (ht : t ∈ Set.Ico (0 : ℝ) (2 * r + 1)) (hlt : 2 * r < t) :
+    t + (-2 * r) ∈ Set.Ioo (0 : ℝ) 1 := ⟨by linarith, by linarith [ht.2]⟩
+  by_cases hxl : x ≤ 2 * r <;> by_cases hyl : y ≤ 2 * r
+  · rw [joinedArc_left hxl, joinedArc_left hyl] at hxy
+    have heq := hα (hleft hx hxl) (hleft hy hyl) hxy
+    linarith
+  · rw [joinedArc_left hxl, joinedArc_right (lt_of_not_ge hyl)] at hxy
+    exact False.elim (havoid _ (hright hy (lt_of_not_ge hyl)) ⟨_, hleft hx hxl, hxy⟩)
+  · rw [joinedArc_right (lt_of_not_ge hxl), joinedArc_left hyl] at hxy
+    exact False.elim (havoid _ (hright hx (lt_of_not_ge hxl)) ⟨_, hleft hy hyl, hxy.symm⟩)
+  · rw [joinedArc_right (lt_of_not_ge hxl), joinedArc_right (lt_of_not_ge hyl)] at hxy
+    have heq :=
+      hβ (Set.Ioo_subset_Icc_self (hright hx (lt_of_not_ge hxl)))
+        (Set.Ioo_subset_Icc_self (hright hy (lt_of_not_ge hyl))) hxy
+    linarith
+
+private theorem
+    Degree.CircleGluing.joinedArc_contMDiffAt {N : Type*} {G H : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [TopologicalSpace N]
+    [ChartedSpace H N] {α β : ℝ → N} {R r : ℝ} (hrR : r < R)
+    (hα : ContMDiffOn 𝓘(ℝ, ℝ) J ∞ α (Set.Ioo (-R) R)) (hβ : ContMDiff 𝓘(ℝ, ℝ) J ∞ β)
+    (h0 : β =ᶠ[𝓝 (0 : ℝ)] (fun t => α (t + r))) {t : ℝ} (ht : t ∈ Set.Ico (0 : ℝ) (2 * r + 1)) :
+    ContMDiffAt 𝓘(ℝ, ℝ) J ∞ (joinedArc α β r) t := by
+  by_cases htle : t ≤ 2 * r
+  · have htα : t + (-r) ∈ Set.Ioo (-R) R := ⟨by linarith [ht.1], by linarith⟩
+    have hs :=
+      (hα.contMDiffAt (Ioo_mem_nhds htα.1 htα.2)).comp t
+        (contMDiff_id.add contMDiff_const).contMDiffAt
+    apply hs.congr_of_eventuallyEq
+    rcases htle.eq_or_lt with rfl | hlt
+    · exact joinedArc_seam_germ h0
+    · exact joinedArc_left_germ hlt
+  · exact
+      (hβ.comp (contMDiff_id.add contMDiff_const)).contMDiffAt.congr_of_eventuallyEq
+        (joinedArc_right_germ (lt_of_not_ge htle))
+
+private theorem Degree.CircleGluing.joinedArc_derivative_injective {N : Type*} {G H : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [TopologicalSpace N] [ChartedSpace H N] {α β : ℝ → N} {R r : ℝ} (hrR : r < R)
+    (hα : ContMDiffOn 𝓘(ℝ, ℝ) J ∞ α (Set.Ioo (-R) R)) (hβ : ContMDiff 𝓘(ℝ, ℝ) J ∞ β)
+    (h0 : β =ᶠ[𝓝 (0 : ℝ)] (fun t => α (t + r)))
+    (hiα : ∀ s ∈ Set.Ioo (-R) R, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J α s))
+    (hiβ : ∀ s ∈ Set.Icc (0 : ℝ) 1, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J β s)) {t : ℝ}
+    (ht : t ∈ Set.Ico (0 : ℝ) (2 * r + 1)) :
+    Function.Injective (mfderiv 𝓘(ℝ, ℝ) J (joinedArc α β r) t) := by
+  by_cases htle : t ≤ 2 * r
+  · have htα : t + (-r) ∈ Set.Ioo (-R) R := ⟨by linarith [ht.1], by linarith⟩
+    have heq : joinedArc α β r =ᶠ[𝓝 t] (fun s => α (s + (-r))) := by
+      rcases htle.eq_or_lt with rfl | hlt
+      · exact joinedArc_seam_germ h0
+      · exact joinedArc_left_germ hlt
+    rw [heq.mfderiv_eq]
+    exact
+      MorseCancel.injective_mfderiv_curve_translate
+        ((hα.contMDiffAt (Ioo_mem_nhds htα.1 htα.2)).mdifferentiableAt (by simp)) (hiα _ htα)
+  · have htβ : t + (-2 * r) ∈ Set.Icc (0 : ℝ) 1 := ⟨by linarith, by linarith [ht.2]⟩
+    rw [(joinedArc_right_germ (α := α) (β := β) (lt_of_not_ge htle)).mfderiv_eq]
+    exact
+      MorseCancel.injective_mfderiv_curve_translate (hβ.mdifferentiableAt (by simp)) (hiβ _ htβ)
+
+private def Degree.CircleGluing.joinedLoop {N : Type*} {r : ℝ} (hr : 0 < r) (α β : ℝ → N) : ℝ → N :=
+  periodicExtension (show 0 < 2 * r + 1 by linarith) (joinedArc α β r)
+
+private theorem
+    Degree.CircleGluing.joinedLoop_periodic {N : Type*} {r : ℝ} (hr : 0 < r) (α β : ℝ → N) :
+    Function.Periodic (joinedLoop hr α β) (2 * r + 1) :=
+  periodicExtension_periodic _ _
+
+private theorem
+    Degree.CircleGluing.joinedLoop_left {N : Type*} {r : ℝ} (hr : 0 < r) (α β : ℝ → N) {s : ℝ}
+    (hs : s ∈ Set.Icc (-r) r) : joinedLoop hr α β (s + r) = α s := by
+  change joinedArc α β r (toIcoMod _ 0 (s + r)) = α s
+  rw [(toIcoMod_eq_self _).mpr ⟨by linarith [hs.1], by linarith [hs.2]⟩,
+    joinedArc_left (by linarith [hs.2])]
+  congr 1
+  ring
+
+private theorem Degree.CircleGluing.joinedLoop_right {N : Type*} {r : ℝ} (hr : 0 < r) {α β : ℝ → N}
+    (h0 : β 0 = α r) (h1 : β 1 = α (-r)) {s : ℝ} (hs : s ∈ Set.Icc (0 : ℝ) 1) :
+    joinedLoop hr α β (2 * r + s) = β s := by
+  by_cases hs1 : s = 1
+  · subst s
+    have hper := (joinedLoop_periodic hr α β) 0
+    rw [zero_add] at hper
+    have hz : joinedLoop hr α β 0 = α (-r) := by
+      simpa only [neg_add_cancel] using joinedLoop_left hr α β (s := -r) ⟨le_rfl, by linarith⟩
+    exact hper.trans (hz.trans h1.symm)
+  · change joinedArc α β r (toIcoMod _ 0 (2 * r + s)) = β s
+    rw [(toIcoMod_eq_self _).mpr
+        ⟨by linarith [hs.1], by
+          have hlt : s < 1 := lt_of_le_of_ne hs.2 hs1
+          linarith⟩]
+    by_cases hs0 : s = 0
+    · subst s
+      rw [add_zero, joinedArc_left le_rfl]
+      simpa only [show 2 * r + (-r) = r by ring] using h0.symm
+    · rw [joinedArc_right
+          (by
+            have hpos : 0 < s := lt_of_le_of_ne hs.1 (Ne.symm hs0)
+            linarith)]
+      congr 1
+      ring
+
+private theorem Degree.CircleGluing.joinedLoop_range {N : Type*} {r : ℝ} (hr : 0 < r) {α β : ℝ → N}
+    (h0 : β 0 = α r) (h1 : β 1 = α (-r)) :
+    Set.range (joinedLoop hr α β) = α '' Set.Icc (-r) r ∪ β '' Set.Icc (0 : ℝ) 1 := by
+  ext z
+  constructor
+  · rintro ⟨t, rfl⟩
+    let q := toIcoMod (show 0 < 2 * r + 1 by linarith) 0 t
+    have hq : q ∈ Set.Ico (0 : ℝ) (2 * r + 1) := by
+      simpa only [zero_add] using toIcoMod_mem_Ico (show 0 < 2 * r + 1 by linarith) 0 t
+    change joinedArc α β r q ∈ _
+    by_cases hqr : q ≤ 2 * r
+    · rw [joinedArc_left hqr]
+      exact Or.inl ⟨_, ⟨by linarith [hq.1], by linarith⟩, rfl⟩
+    · rw [joinedArc_right (lt_of_not_ge hqr)]
+      exact Or.inr ⟨_, ⟨by linarith, by linarith [hq.2]⟩, rfl⟩
+  · rintro (⟨s, hs, rfl⟩ | ⟨s, hs, rfl⟩)
+    · exact ⟨s + r, joinedLoop_left hr α β hs⟩
+    · exact ⟨2 * r + s, joinedLoop_right hr h0 h1 hs⟩
+
+private theorem Degree.CircleGluing.joinedLoop_injOn {N : Type*} {r : ℝ} (hr : 0 < r) {α β : ℝ → N}
+    (hα : Set.InjOn α (Set.Icc (-r) r)) (hβ : Set.InjOn β (Set.Icc (0 : ℝ) 1))
+    (havoid : ∀ t ∈ Set.Ioo (0 : ℝ) 1, β t ∉ α '' Set.Icc (-r) r) :
+    Set.InjOn (joinedLoop hr α β) (Set.Ico (0 : ℝ) (2 * r + 1)) := by
+  intro x hx y hy hxy
+  apply joinedArc_injOn hα hβ havoid hx hy
+  change joinedArc α β r (toIcoMod _ 0 x) = joinedArc α β r (toIcoMod _ 0 y) at hxy
+  rw [(toIcoMod_eq_self _).mpr (by simpa only [zero_add] using hx),
+    (toIcoMod_eq_self _).mpr (by simpa only [zero_add] using hy)] at hxy
+  exact hxy
+
+private theorem Degree.CircleGluing.joinedLoop_contMDiff {N : Type*} {r : ℝ} {G H : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [TopologicalSpace N] [ChartedSpace H N] (hr : 0 < r) {α β : ℝ → N} {R : ℝ} (hrR : r < R)
+    (hα : ContMDiffOn 𝓘(ℝ, ℝ) J ∞ α (Set.Ioo (-R) R)) (hβ : ContMDiff 𝓘(ℝ, ℝ) J ∞ β)
+    (h0 : β =ᶠ[𝓝 (0 : ℝ)] (fun t => α (t + r)))
+    (h1 : β =ᶠ[𝓝 (1 : ℝ)] (fun t => α (t + (-1 - r)))) :
+    ContMDiff 𝓘(ℝ, ℝ) J ∞ (joinedLoop hr α β) :=
+  periodicExtension_contMDiff _ (joinedArc_periodic_germ hr h1)
+    (fun _ ht => joinedArc_contMDiffAt hrR hα hβ h0 ht)
+
+private theorem
+    Degree.CircleGluing.joinedLoop_derivative_injective {N : Type*} {r : ℝ} {G H : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [TopologicalSpace N] [ChartedSpace H N] (hr : 0 < r) {α β : ℝ → N} {R : ℝ} (hrR : r < R)
+    (hα : ContMDiffOn 𝓘(ℝ, ℝ) J ∞ α (Set.Ioo (-R) R)) (hβ : ContMDiff 𝓘(ℝ, ℝ) J ∞ β)
+    (h0 : β =ᶠ[𝓝 (0 : ℝ)] (fun t => α (t + r))) (h1 : β =ᶠ[𝓝 (1 : ℝ)] (fun t => α (t + (-1 - r))))
+    (hiα : ∀ s ∈ Set.Ioo (-R) R, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J α s))
+    (hiβ : ∀ s ∈ Set.Icc (0 : ℝ) 1, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J β s)) (t : ℝ) :
+    Function.Injective (mfderiv 𝓘(ℝ, ℝ) J (joinedLoop hr α β) t) :=
+  periodicExtension_derivative_injective _ (joinedArc_periodic_germ hr h1)
+    (fun _ ht => (joinedArc_contMDiffAt hrR hα hβ h0 ht).mdifferentiableAt (by simp))
+    (fun _ ht => joinedArc_derivative_injective hrR hα hβ h0 hiα hiβ ht) t
+
+private theorem Degree.CircleGluing.circleExp_derivative_injective (t : ℝ) :
+    Function.Injective (mfderiv 𝓘(ℝ, ℝ) (𝓡 1) Circle.exp t) := by
+  let _ : Fact (Module.finrank ℝ ℂ = 1 + 1) := ⟨Complex.finrank_real_complex⟩
+  have hd :
+    HasDerivAt (fun s : ℝ => (Circle.exp s : ℂ)) (Complex.exp ((t : ℂ) * Complex.I) * Complex.I)
+      t := by
+    simpa only [Circle.coe_exp, Complex.real_smul, id_eq, one_mul] using
+      ((hasDerivAt_id (t : ℂ)).mul_const Complex.I).cexp.comp_ofReal
+  have hdne : (Complex.exp ((t : ℂ) * Complex.I) * Complex.I : ℂ) ≠ 0 :=
+    mul_ne_zero (Complex.exp_ne_zero _) Complex.I_ne_zero
+  have hi0 : Function.Injective (fderiv ℝ (fun s : ℝ => (Circle.exp s : ℂ)) t) := by
+    rw [hd.hasFDerivAt.fderiv]
+    exact smul_left_injective ℝ hdne
+  let c : Circle → ℂ := fun z => (z : ℂ)
+  have hc : ContMDiff (𝓡 1) 𝓘(ℝ, ℂ) ∞ c := contMDiff_coe_sphere
+  have hi : Function.Injective (mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, ℂ) (c ∘ (fun s : ℝ => Circle.exp s)) t) := by
+    rw [mfderiv_eq_fderiv]
+    exact hi0
+  rw [mfderiv_comp t (hc.mdifferentiableAt (by simp))
+      ((contMDiff_circleExp (m := ∞)).mdifferentiableAt (by simp))] at hi
+  intro x y hxy
+  exact hi (congrArg (mfderiv (𝓡 1) 𝓘(ℝ, ℂ) c (Circle.exp t)) hxy)
+
+private theorem Degree.CircleGluing.circleExp_localDiffeomorph (t : ℝ) :
+    IsLocalDiffeomorphAt 𝓘(ℝ, ℝ) (𝓡 1) ∞ Circle.exp t := by
+  let L : ℝ →L[ℝ] EuclideanSpace ℝ (Fin 1) := mfderiv 𝓘(ℝ, ℝ) (𝓡 1) Circle.exp t
+  have hi : Function.Injective L := circleExp_derivative_injective t
+  have hs : Function.Surjective L :=
+    (LinearMap.injective_iff_surjective_of_finrank_eq_finrank (f := L.toLinearMap) (by simp)).mp
+      hi
+  apply
+    Smale.isLocalDiffeomorphAt_boundaryless isOpen_univ (Set.mem_univ t)
+      (contMDiff_circleExp (m := ∞)).contMDiffOn
+  exact ⟨(LinearEquiv.ofBijective L.toLinearMap ⟨hi, hs⟩).toContinuousLinearEquiv, rfl⟩
+
+private theorem
+    Degree.CircleGluing.contMDiff_of_comp_circleExp {G H N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [TopologicalSpace N]
+    [ChartedSpace H N] {γ : Circle → N} (hγ : ContMDiff 𝓘(ℝ, ℝ) J ∞ (γ ∘ Circle.exp)) :
+    ContMDiff (𝓡 1) J ∞ γ := by
+  intro z
+  obtain ⟨t, rfl⟩ := Circle.exp_surjective z
+  let h := circleExp_localDiffeomorph t
+  have hs : ContMDiffAt (𝓡 1) J ∞ ((γ ∘ Circle.exp) ∘ h.localInverse) (Circle.exp t) :=
+    (hγ.contMDiffAt (x := h.localInverse (Circle.exp t))).comp _ h.localInverse_contMDiffAt
+  apply hs.congr_of_eventuallyEq
+  filter_upwards [h.localInverse_eventuallyEq_right] with y hy
+  exact (congrArg γ hy).symm
+
+private def Degree.CircleGluing.periodicCircle {N : Type*} {T : ℝ} {f : ℝ → N} (hT : T ≠ 0)
+    (hper : Function.Periodic f T) (z : Circle) : N :=
+  hper.lift ((AddCircle.homeomorphCircle hT).symm z)
+
+private theorem Degree.CircleGluing.periodicCircle_exp {N : Type*} {T : ℝ} {f : ℝ → N} (hT : T ≠ 0)
+    (hper : Function.Periodic f T) (t : ℝ) :
+    periodicCircle hT hper (Circle.exp (2 * Real.pi / T * t)) = f t := by
+  have heq : Circle.exp (2 * Real.pi / T * t) = AddCircle.homeomorphCircle hT (t : AddCircle T) :=
+    by rw [AddCircle.homeomorphCircle_apply, AddCircle.toCircle_apply_mk]
+  rw [heq, periodicCircle, Homeomorph.symm_apply_apply, Function.Periodic.lift_coe]
+
+private theorem
+    Degree.CircleGluing.periodicCircle_comp_exp {N : Type*} {T : ℝ} {f : ℝ → N} (hT : T ≠ 0)
+    (hper : Function.Periodic f T) :
+    periodicCircle hT hper ∘ Circle.exp = (fun t => f (T / (2 * Real.pi) * t)) := by
+  funext t
+  have heq : 2 * Real.pi / T * (T / (2 * Real.pi) * t) = t := by field_simp [hT, Real.pi_ne_zero]
+  have hh := periodicCircle_exp hT hper (T / (2 * Real.pi) * t)
+  rw [heq] at hh
+  exact hh
+
+private theorem
+    Degree.CircleGluing.periodicCircle_injective {N : Type*} {T : ℝ} {f : ℝ → N} (hT : 0 < T)
+    (hper : Function.Periodic f T) (hi : Set.InjOn f (Set.Ico (0 : ℝ) T)) :
+    Function.Injective (periodicCircle hT.ne' hper) := by
+  let _ : Fact (0 < T) := ⟨hT⟩
+  let e := AddCircle.homeomorphCircle hT.ne'
+  intro z w hzw
+  let x := AddCircle.equivIco T 0 (e.symm z)
+  let y := AddCircle.equivIco T 0 (e.symm w)
+  have hx : (x.val : AddCircle T) = e.symm z := AddCircle.coe_equivIco
+  have hy : (y.val : AddCircle T) = e.symm w := AddCircle.coe_equivIco
+  have hval : f x.val = f y.val := by
+    change hper.lift (e.symm z) = hper.lift (e.symm w) at hzw
+    rw [← hx, ← hy, Function.Periodic.lift_coe, Function.Periodic.lift_coe] at hzw
+    exact hzw
+  have hxy : x.val = y.val :=
+    hi (by simpa only [zero_add] using x.property) (by simpa only [zero_add] using y.property)
+      hval
+  apply e.symm.injective
+  rw [← hx, ← hy, hxy]
+
+private theorem
+    Degree.CircleGluing.periodicCircle_range {N : Type*} {T : ℝ} {f : ℝ → N} (hT : T ≠ 0)
+    (hper : Function.Periodic f T) : Set.range (periodicCircle hT hper) = Set.range f := by
+  ext z
+  constructor
+  · rintro ⟨w, rfl⟩
+    obtain ⟨t, rfl⟩ := Circle.exp_surjective w
+    have hh := congrFun (periodicCircle_comp_exp hT hper) t
+    exact ⟨T / (2 * Real.pi) * t, hh.symm⟩
+  · rintro ⟨t, rfl⟩
+    exact ⟨Circle.exp (2 * Real.pi / T * t), periodicCircle_exp hT hper t⟩
+
+private theorem
+    Degree.CircleGluing.periodicCircle_contMDiff {N : Type*} {T : ℝ} {f : ℝ → N} {G H : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [TopologicalSpace N] [ChartedSpace H N] (hT : T ≠ 0) (hper : Function.Periodic f T)
+    (hf : ContMDiff 𝓘(ℝ, ℝ) J ∞ f) : ContMDiff (𝓡 1) J ∞ (periodicCircle hT hper) := by
+  apply contMDiff_of_comp_circleExp
+  rw [periodicCircle_comp_exp]
+  exact hf.comp (contDiff_const.mul contDiff_id).contMDiff
+
+private theorem Degree.CircleGluing.injective_mfderiv_curve_const_mul {N : Type*} {G H : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [TopologicalSpace N] [ChartedSpace H N] {α : ℝ → N} {s a : ℝ} (ha : a ≠ 0)
+    (hα : MDifferentiableAt 𝓘(ℝ, ℝ) J α (a * s))
+    (hi : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J α (a * s))) :
+    Function.Injective (mfderiv 𝓘(ℝ, ℝ) J (fun t => α (a * t)) s) := by
+  have hd : HasDerivAt (fun t : ℝ => a * t) a s := by
+    simpa only [id_eq, mul_one] using (hasDerivAt_id s).const_mul a
+  have hmul : Function.Injective (mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) (fun t : ℝ => a * t) s) := by
+    rw [mfderiv_eq_fderiv]
+    have hh : Function.Injective (fderiv ℝ (fun t : ℝ => a * t) s) := by
+      rw [hd.hasFDerivAt.fderiv]
+      exact smul_left_injective ℝ ha
+    exact hh
+  change Function.Injective (mfderiv 𝓘(ℝ, ℝ) J (α ∘ (fun t : ℝ => a * t)) s)
+  rw [mfderiv_comp s hα hd.differentiableAt.mdifferentiableAt]
+  intro x y hxy
+  exact hmul (hi hxy)
+
+private theorem
+    Degree.CircleGluing.periodicCircle_derivative_injective {N : Type*} {T : ℝ} {f : ℝ → N}
+    {G H : Type*} [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [TopologicalSpace N] [ChartedSpace H N] (hT : T ≠ 0)
+    (hper : Function.Periodic f T) (hf : ContMDiff 𝓘(ℝ, ℝ) J ∞ f)
+    (hi : ∀ t, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J f t)) (z : Circle) :
+    Function.Injective (mfderiv (𝓡 1) J (periodicCircle hT hper) z) := by
+  obtain ⟨t, rfl⟩ := Circle.exp_surjective z
+  have hc : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J (periodicCircle hT hper ∘ Circle.exp) t) := by
+    rw [periodicCircle_comp_exp]
+    exact
+      injective_mfderiv_curve_const_mul
+        (div_ne_zero hT (mul_ne_zero (by norm_num) Real.pi_ne_zero))
+        (hf.mdifferentiableAt (by simp)) (hi _)
+  rw [mfderiv_comp t ((periodicCircle_contMDiff hT hper hf).mdifferentiableAt (by simp))
+      ((contMDiff_circleExp (m := ∞)).mdifferentiableAt (by simp))] at hc
+  have hs := ((circleExp_localDiffeomorph t).mfderivToContinuousLinearEquiv (by simp)).surjective
+  intro x y hxy
+  obtain ⟨u, hu⟩ := hs x
+  obtain ⟨v, hv⟩ := hs y
+  have hux : mfderiv 𝓘(ℝ, ℝ) (𝓡 1) Circle.exp t u = x := hu
+  have hvy : mfderiv 𝓘(ℝ, ℝ) (𝓡 1) Circle.exp t v = y := hv
+  have huv : u = v :=
+    hc
+      (by
+        change
+          mfderiv (𝓡 1) J (periodicCircle hT hper) (Circle.exp t)
+              (mfderiv 𝓘(ℝ, ℝ) (𝓡 1) Circle.exp t u) =
+            mfderiv (𝓡 1) J (periodicCircle hT hper) (Circle.exp t)
+              (mfderiv 𝓘(ℝ, ℝ) (𝓡 1) Circle.exp t v)
+        rw [hux, hvy]
+        exact hxy)
+  exact hux.symm.trans ((congrArg (mfderiv 𝓘(ℝ, ℝ) (𝓡 1) Circle.exp t) huv).trans hvy)
+
+private theorem Smale.NativeOpenSubmanifold.injective_mfderiv_subtype_val {E H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [TopologicalSpace M] [ChartedSpace H M] (U : TopologicalSpace.Opens M) (p : U) :
+    Function.Injective (mfderiv I I (Subtype.val : U → M) p) := by
+  classical
+  let g : M → U := fun x => if hx : x ∈ U then ⟨x, hx⟩ else p
+  have hval : (Subtype.val ∘ g) =ᶠ[𝓝 (p : M)] id := by
+    apply Filter.mem_of_superset (U.isOpen.mem_nhds p.property)
+    intro x hx
+    change x ∈ U at hx
+    change (g x : M) = x
+    dsimp [g]
+    rw [dite_eq_left hx]
+  have hg : ContMDiffAt I I ∞ g (p : M) := by
+    apply (ContMDiffAt.subtypeVal_comp_iff U g (p : M)).mp
+    exact contMDiffAt_id.congr_of_eventuallyEq hval
+  have hv : ContMDiff I I ∞ (Subtype.val : U → M) := contMDiff_subtype_val
+  have hleft : g ∘ (Subtype.val : U → M) = id := by
+    funext x
+    apply Subtype.ext
+    simp only [Function.comp_apply, g, dite_eq_left x.property, id_eq]
+  have heq := mfderiv_comp p (hg.mdifferentiableAt (by simp)) (hv.mdifferentiableAt (by simp))
+  rw [hleft, mfderiv_id] at heq
+  intro v w hvw
+  have hh := congrArg (mfderiv I I g (p : M)) hvw
+  have hv' := congrArg (fun L => L v) heq
+  have hw' := congrArg (fun L => L w) heq
+  exact hv'.trans (hh.trans hw'.symm)
+
+private theorem
+    MorseCancel.exists_embedded_circle_through_arc {G H N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N]
+    (S : TopologicalSpace.Opens N) {α : ℝ → N} {R r : ℝ} (hr : 0 < r) (hrR : r < R)
+    (hα : ContMDiffOn 𝓘(ℝ, ℝ) J ∞ α (Set.Ioo (-R) R)) (hinj : Set.InjOn α (Set.Icc (-R) R))
+    (hderiv : ∀ s ∈ Set.Ioo (-R) R, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J α s)) (hplus : α r ∈ S)
+    (hminus : α (-r) ∈ S) (η : Path (⟨α r, hplus⟩ : S) (⟨α (-r), hminus⟩ : S))
+    (hdim : 3 ≤ Module.finrank ℝ G) :
+    ∃ γ : C(Circle, N),
+      ContMDiff (𝓡 1) J ∞ γ ∧
+        Function.Injective γ ∧
+          (∀ z, Function.Injective (mfderiv (𝓡 1) J γ z)) ∧
+            (∀ s ∈ Set.Icc (-r) r, γ (Circle.exp (2 * Real.pi / (2 * r + 1) * (s + r))) = α s) ∧
+              Set.range γ ⊆ α '' Set.Icc (-r) r ∪ (S : Set N) := by
+  obtain ⟨b, hb, hb0, hb1, hemb, hbd, havoid⟩ :=
+    exists_disjoint_embedded_return_arc S hr hrR hα hinj hderiv hplus hminus η hdim
+  let β : ℝ → N := Subtype.val ∘ b
+  have hβ : ContMDiff 𝓘(ℝ, ℝ) J ∞ β := contMDiff_subtype_val.comp hb
+  have hβi : Set.InjOn β (Set.Icc (0 : ℝ) 1) := by
+    intro x hx y hy hxy
+    have hbx : b x = b y := Subtype.ext hxy
+    exact congrArg Subtype.val (hemb.injective (a₁ := ⟨x, hx⟩) (a₂ := ⟨y, hy⟩) hbx)
+  have hβd : ∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J β t) := by
+    intro t ht
+    rw [show β = Subtype.val ∘ b from rfl,
+      mfderiv_comp t ((contMDiff_subtype_val (n := ∞)).mdifferentiableAt (by simp))
+        (hb.mdifferentiableAt (by simp))]
+    exact (Smale.NativeOpenSubmanifold.injective_mfderiv_subtype_val S (b t)).comp (hbd t ht)
+  have h0 : β 0 = α r := by simpa only [zero_add] using hb0.eq_of_nhds
+  have h1 : β 1 = α (-r) := by
+    simpa only [show (1 : ℝ) + (-1 - r) = -r by ring] using hb1.eq_of_nhds
+  let F := Degree.CircleGluing.joinedLoop hr α β
+  have hF : ContMDiff 𝓘(ℝ, ℝ) J ∞ F :=
+    Degree.CircleGluing.joinedLoop_contMDiff hr hrR hα hβ hb0 hb1
+  have hFd : ∀ t, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J F t) :=
+    Degree.CircleGluing.joinedLoop_derivative_injective hr hrR hα hβ hb0 hb1 hderiv hβd
+  have hsub : Set.Icc (-r) r ⊆ Set.Icc (-R) R := by
+    intro s hs
+    exact ⟨by linarith [hs.1], by linarith [hs.2]⟩
+  have hαi : Set.InjOn α (Set.Icc (-r) r) := hinj.mono hsub
+  have hFi : Set.InjOn F (Set.Ico (0 : ℝ) (2 * r + 1)) :=
+    Degree.CircleGluing.joinedLoop_injOn hr hαi hβi havoid
+  have hT : 0 < 2 * r + 1 := by linarith
+  have hper : Function.Periodic F (2 * r + 1) := Degree.CircleGluing.joinedLoop_periodic hr α β
+  let Γ := Degree.CircleGluing.periodicCircle hT.ne' hper
+  have hΓ : ContMDiff (𝓡 1) J ∞ Γ := Degree.CircleGluing.periodicCircle_contMDiff hT.ne' hper hF
+  refine
+    ⟨⟨Γ, hΓ.continuous⟩, hΓ, Degree.CircleGluing.periodicCircle_injective hT hper hFi,
+      Degree.CircleGluing.periodicCircle_derivative_injective hT.ne' hper hF hFd, ?_, ?_⟩
+  · intro s hs
+    exact
+      (Degree.CircleGluing.periodicCircle_exp hT.ne' hper (s + r)).trans
+        (Degree.CircleGluing.joinedLoop_left hr α β hs)
+  · intro z hz
+    change z ∈ Set.range Γ at hz
+    rw [Degree.CircleGluing.periodicCircle_range,
+      Degree.CircleGluing.joinedLoop_range hr h0 h1] at hz
+    rcases hz with hz | ⟨t, -, rfl⟩
+    · exact Or.inl hz
+    · exact Or.inr (b t).property
+
+private theorem MorseCancel.dense_section_of_flow_cylinder {N X : Type*} [TopologicalSpace N]
+    [TopologicalSpace X] (A : OpenPartialHomeomorph (N × ℝ) X) (hsource : A.source = Set.univ)
+    (F : Flow ℝ X) (ι : N → X) (hformula : ∀ z, A z = F z.2 (ι z.1)) {B : Set X} (hB : Dense B)
+    (hinv : ∀ t x, F t x ∈ B ↔ x ∈ B) : Dense (ι ⁻¹' B) := by
+  apply dense_iff_inter_open.mpr
+  intro U hU hne
+  have hdom : U ×ˢ (Set.univ : Set ℝ) ⊆ A.source := by rw [hsource]; exact Set.subset_univ _
+  have hopen : IsOpen (A '' (U ×ˢ (Set.univ : Set ℝ))) :=
+    A.isOpen_image_of_subset_source (hU.prod isOpen_univ) hdom
+  obtain ⟨z, hz⟩ := hne
+  have himage : (A '' (U ×ˢ (Set.univ : Set ℝ))).Nonempty :=
+    ⟨A (z, 0), (z, 0), ⟨hz, Set.mem_univ _⟩, rfl⟩
+  obtain ⟨x, hx, hxB⟩ := hB.inter_open_nonempty _ hopen himage
+  obtain ⟨⟨w, t⟩, ⟨hw, -⟩, rfl⟩ := hx
+  refine ⟨w, hw, ?_⟩
+  apply (hinv t (ι w)).mp
+  rwa [hformula] at hxB
+
+private theorem
+    AdaptedWindows.dense_regular_level_minimum_basins {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a : ℝ}
+    (hreg : ∀ x, f x = a → x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    Dense
+      {x : { y : M // f y = a } |
+        ∃ p : Smale.ManifoldMorse.criticalPoints E f,
+          MorseCancel.nativeMorseIndex E f p = 0 ∧
+            Filter.Tendsto (fun t => S.flow t x) Filter.atTop (𝓝 p.val)} := by
+  let L := { y : M // f y = a }
+  rcases isEmpty_or_nonempty L with h | h
+  · exact fun x => isEmptyElim x
+  · let _ := Smale.RegularLevel.chartedSpace hf hreg
+    obtain ⟨A, hsource, -, hformula, -⟩ :=
+      Degree.FlowCancellation.exists_native_level_flow_cylinder hf hreg S.smooth S.flow S.integral
+        (fun x hx => S.descent x (hreg x hx)) (Classical.arbitrary L)
+    apply
+      MorseCancel.dense_section_of_flow_cylinder A.toOpenPartialHomeomorph hsource S.flow
+        Subtype.val hformula (S.dense_minimum_forward_basins hf)
+    intro t x
+    constructor
+    · rintro ⟨p, hp, hlim⟩
+      exact ⟨p, hp, (MorseCancel.flow_time_atTop_limit_iff S.flow t x p.val).mp hlim⟩
+    · rintro ⟨p, hp, hlim⟩
+      exact ⟨p, hp, (MorseCancel.flow_time_atTop_limit_iff S.flow t x p.val).mpr hlim⟩
+
+private abbrev Degree.Handle.Space {N P : Type*} [NormedAddCommGroup N] [NormedAddCommGroup P] :=
+  Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P
+
+private def Degree.Handle.denominator {N P : Type*} [NormedAddCommGroup N] [NormedAddCommGroup P]
+    (z : Space (N := N) (P := P)) : ℝ :=
+  Max.max ‖(z.1 : N)‖ (1 - ‖(z.2 : P)‖ / 2)
+
+private theorem Degree.Handle.half_le_denominator {N P : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] (z : Space (N := N) (P := P)) : (1 / 2 : ℝ) ≤ denominator z := by
+  have hv : ‖(z.2 : P)‖ ≤ 1 := mem_closedBall_zero_iff.mp z.2.property
+  have hd := le_max_right ‖(z.1 : N)‖ (1 - ‖(z.2 : P)‖ / 2)
+  change (1 / 2 : ℝ) ≤ Max.max ‖(z.1 : N)‖ (1 - ‖(z.2 : P)‖ / 2)
+  linarith
+
+private theorem
+    Degree.Handle.denominator_pos {N P : Type*} [NormedAddCommGroup N] [NormedAddCommGroup P]
+    (z : Space (N := N) (P := P)) : 0 < denominator z :=
+  lt_of_lt_of_le (by norm_num) (half_le_denominator z)
+
+private theorem Degree.Handle.denominator_le_one {N P : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] (z : Space (N := N) (P := P)) : denominator z ≤ 1 := by
+  apply max_le (mem_closedBall_zero_iff.mp z.1.property)
+  linarith [norm_nonneg (z.2 : P)]
+
+private def
+    Degree.Handle.positiveMultiplier {N P : Type*} [NormedAddCommGroup N] [NormedAddCommGroup P]
+    (z : Space (N := N) (P := P)) : ℝ :=
+  (2 * denominator z + ‖(z.2 : P)‖ - 2) / (‖(z.2 : P)‖ * denominator z)
+
+private theorem Degree.Handle.positiveMultiplier_nonneg {N P : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] (z : Space (N := N) (P := P)) : 0 ≤ positiveMultiplier z := by
+  apply div_nonneg
+  · have hd := le_max_right ‖(z.1 : N)‖ (1 - ‖(z.2 : P)‖ / 2)
+    change 0 ≤ 2 * Max.max ‖(z.1 : N)‖ (1 - ‖(z.2 : P)‖ / 2) + ‖(z.2 : P)‖ - 2
+    linarith
+  · exact mul_nonneg (norm_nonneg _) (denominator_pos z).le
+
+private theorem Degree.Handle.positiveMultiplier_le_one {N P : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] (z : Space (N := N) (P := P)) : positiveMultiplier z ≤ 1 := by
+  by_cases hv : (z.2 : P) = 0
+  · simp [positiveMultiplier, hv]
+  · apply (div_le_one (mul_pos (norm_pos_iff.mpr hv) (denominator_pos z))).mpr
+    have hb : ‖(z.2 : P)‖ ≤ 1 := mem_closedBall_zero_iff.mp z.2.property
+    have hprod :=
+      mul_nonneg (sub_nonneg.mpr (denominator_le_one z)) (show 0 ≤ 2 - ‖(z.2 : P)‖ by linarith)
+    nlinarith
+
+private def Degree.Handle.negative {N P : Type*} [NormedAddCommGroup N] [NormedAddCommGroup P]
+    [NormedSpace ℝ N] (z : Space (N := N) (P := P)) : N :=
+  (denominator z)⁻¹ • (z.1 : N)
+
+private def Degree.Handle.positive {N P : Type*} [NormedAddCommGroup N] [NormedAddCommGroup P]
+    [NormedSpace ℝ P] (z : Space (N := N) (P := P)) : P :=
+  positiveMultiplier z • (z.2 : P)
+
+private theorem Degree.Handle.norm_negative_le_one {N P : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [NormedSpace ℝ N] (z : Space (N := N) (P := P)) : ‖negative z‖ ≤ 1 := by
+  rw [negative, norm_smul, Real.norm_of_nonneg (inv_nonneg.mpr (denominator_pos z).le)]
+  have h :=
+    mul_le_mul_of_nonneg_left (le_max_left ‖(z.1 : N)‖ (1 - ‖(z.2 : P)‖ / 2))
+      (inv_nonneg.mpr (denominator_pos z).le)
+  exact h.trans_eq (inv_mul_cancel₀ (denominator_pos z).ne')
+
+private theorem
+    Degree.Handle.norm_positive_le {N P : Type*} [NormedAddCommGroup N] [NormedAddCommGroup P]
+    [NormedSpace ℝ P] (z : Space (N := N) (P := P)) : ‖positive z‖ ≤ ‖(z.2 : P)‖ := by
+  rw [positive, norm_smul, Real.norm_of_nonneg (positiveMultiplier_nonneg z)]
+  exact
+    (mul_le_mul_of_nonneg_right (positiveMultiplier_le_one z) (norm_nonneg _)).trans_eq
+      (one_mul _)
+
+private theorem Degree.Handle.positive_eq_zero_of_snd_eq_zero {N P : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (z : Space (N := N) (P := P)) (hz : (z.2 : P) = 0) :
+    positive z = 0 := by simp only [positive, hz, smul_zero]
+
+private theorem Degree.Handle.denominator_eq_one_of_snd_eq_zero {N P : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] (z : Space (N := N) (P := P)) (hz : (z.2 : P) = 0) :
+    denominator z = 1 := by
+  simp only [denominator, hz, norm_zero, zero_div, sub_zero]
+  exact max_eq_right (mem_closedBall_zero_iff.mp z.1.property)
+
+private theorem Degree.Handle.continuous_denominator {N P : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] : Continuous (denominator (N := N) (P := P)) := by
+  unfold denominator
+  fun_prop
+
+private theorem
+    Degree.Handle.continuous_negative {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] : Continuous (negative (N := N) (P := P)) :=
+  (continuous_denominator.inv₀ (fun z => (denominator_pos z).ne')).smul
+    (continuous_subtype_val.comp continuous_fst)
+
+private theorem Degree.Handle.continuous_positive {N P : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] : Continuous (positive (N := N) (P := P)) := by
+  have hv : Continuous (fun z : Space (N := N) (P := P) => (z.2 : P)) :=
+    continuous_subtype_val.comp continuous_snd
+  apply continuous_iff_continuousAt.mpr
+  intro z
+  by_cases hz : (z.2 : P) = 0
+  · change Filter.Tendsto positive (𝓝 z) (𝓝 (positive z))
+    rw [positive_eq_zero_of_snd_eq_zero z hz]
+    apply squeeze_zero_norm norm_positive_le
+    simpa only [hz, norm_zero] using hv.norm.continuousAt.tendsto (x := z)
+  · have hn :
+      Continuous (fun w : Space (N := N) (P := P) => 2 * denominator w + ‖(w.2 : P)‖ - 2) :=
+      ((continuous_const.mul continuous_denominator).add hv.norm).sub continuous_const
+    have hd : Continuous (fun w : Space (N := N) (P := P) => ‖(w.2 : P)‖ * denominator w) :=
+      hv.norm.mul continuous_denominator
+    exact
+      (hn.continuousAt.div hd.continuousAt
+            (mul_ne_zero (norm_ne_zero_iff.mpr hz) (denominator_pos z).ne')).smul
+        hv.continuousAt
+
+private def Degree.Handle.retraction {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] : C(Space (N := N) (P := P), Space (N := N) (P := P))
+    where
+  toFun
+    z :=
+    (⟨negative z, mem_closedBall_zero_iff.mpr (norm_negative_le_one z)⟩,
+      ⟨positive z,
+        mem_closedBall_zero_iff.mpr
+          ((norm_positive_le z).trans (mem_closedBall_zero_iff.mp z.2.property))⟩)
+  continuous_toFun := (continuous_negative.subtype_mk _).prodMk (continuous_positive.subtype_mk _)
+
+private def Degree.Handle.faceCore {N P : Type*} [NormedAddCommGroup N] [NormedAddCommGroup P] :
+    Set (Space (N := N) (P := P)) :=
+  {z | ‖(z.1 : N)‖ = 1 ∨ (z.2 : P) = 0}
+
+private theorem Degree.Handle.retraction_mem_faceCore {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] (z : Space (N := N) (P := P)) :
+    retraction z ∈ faceCore := by
+  by_cases hz : 1 - ‖(z.2 : P)‖ / 2 ≤ ‖(z.1 : N)‖
+  · left
+    change ‖negative z‖ = 1
+    have hd : denominator z = ‖(z.1 : N)‖ := max_eq_left hz
+    rw [negative, norm_smul, Real.norm_of_nonneg (inv_nonneg.mpr (denominator_pos z).le)]
+    rw [← hd, inv_mul_cancel₀ (denominator_pos z).ne']
+  · right
+    change positive z = 0
+    have hd : denominator z = 1 - ‖(z.2 : P)‖ / 2 := max_eq_right (le_of_not_ge hz)
+    have hn : 2 * denominator z + ‖(z.2 : P)‖ - 2 = 0 := by rw [hd]; ring
+    simp only [positive, positiveMultiplier, hn, zero_div, zero_smul]
+
+private theorem
+    Degree.Handle.retraction_eq_self {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (z : Space (N := N) (P := P)) (hz : z ∈ faceCore) :
+    retraction z = z := by
+  have hd : denominator z = 1 := by
+    rcases hz with hu | hv
+    · unfold denominator
+      rw [hu]
+      apply max_eq_left
+      linarith [norm_nonneg (z.2 : P)]
+    · exact denominator_eq_one_of_snd_eq_zero z hv
+  apply Prod.ext
+  · apply Subtype.ext
+    change negative z = (z.1 : N)
+    simp only [negative, hd, inv_one, one_smul]
+  · apply Subtype.ext
+    change positive z = (z.2 : P)
+    by_cases hv : (z.2 : P) = 0
+    · simp only [positive, hv, smul_zero]
+    · have hm : positiveMultiplier z = 1 := by
+        unfold positiveMultiplier
+        rw [hd]
+        field_simp
+        ring
+      rw [positive, hm, one_smul]
+
+private abbrev Degree.DiskCylinder.Disk {E : Type*} [NormedAddCommGroup E] :=
+  Metric.closedBall (0 : E) 1
+
+private abbrev Degree.DiskCylinder.Sphere {E : Type*} [NormedAddCommGroup E] :=
+  Metric.sphere (0 : E) 1
+
+private def Degree.DiskCylinder.toHandle {E : Type*} [NormedAddCommGroup E] :
+    C((unitInterval) × Disk (E := E), Degree.Handle.Space (N := E) (P := ℝ))
+    where
+  toFun
+    p :=
+    (p.2,
+      ⟨p.1.val,
+        mem_closedBall_zero_iff.mpr
+          (by
+            rw [Real.norm_of_nonneg p.1.property.1]
+            exact p.1.property.2)⟩)
+  continuous_toFun :=
+    continuous_snd.prodMk ((continuous_subtype_val.comp continuous_fst).subtype_mk _)
+
+private def Degree.DiskCylinder.retractedTime {E : Type*} [NormedAddCommGroup E]
+    (p : (unitInterval) × Disk (E := E)) : (unitInterval) :=
+  ⟨Degree.Handle.positiveMultiplier (toHandle p) * p.1.val,
+    mul_nonneg (Degree.Handle.positiveMultiplier_nonneg _) p.1.property.1,
+    (by
+      have h :=
+        mul_le_mul_of_nonneg_right (Degree.Handle.positiveMultiplier_le_one (toHandle p))
+          p.1.property.1
+      exact (h.trans_eq (one_mul p.1.val)).trans p.1.property.2)⟩
+
+private theorem Degree.DiskCylinder.continuous_retractedTime {E : Type*} [NormedAddCommGroup E] :
+    Continuous (retractedTime (E := E)) :=
+  (Degree.Handle.continuous_positive.comp toHandle.continuous).subtype_mk _
+
+private def Degree.DiskCylinder.retractedDisk {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (p : (unitInterval) × Disk (E := E)) : Disk (E := E) :=
+  (Degree.Handle.retraction (toHandle p)).1
+
+private theorem Degree.DiskCylinder.continuous_retractedDisk {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] : Continuous (retractedDisk (E := E)) :=
+  continuous_fst.comp (Degree.Handle.retraction.continuous.comp toHandle.continuous)
+
+private def Degree.DiskCylinder.bottomOrSide {E : Type*} [NormedAddCommGroup E] :
+    Set ((unitInterval) × Disk (E := E)) :=
+  {p | p.1 = 0 ∨ ‖(p.2 : E)‖ = 1}
+
+private theorem Degree.DiskCylinder.retracted_mem_bottomOrSide {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (p : (unitInterval) × Disk (E := E)) :
+    (retractedTime p, retractedDisk p) ∈ bottomOrSide := by
+  rcases Degree.Handle.retraction_mem_faceCore (toHandle p) with hp | hp
+  · exact Or.inr hp
+  · apply Or.inl
+    apply Subtype.ext
+    exact hp
+
+private def Degree.DiskCylinder.retraction {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] :
+    C((unitInterval) × Disk (E := E), bottomOrSide (E := E)) :=
+  ⟨fun p => ⟨(retractedTime p, retractedDisk p), retracted_mem_bottomOrSide p⟩,
+    (continuous_retractedTime.prodMk continuous_retractedDisk).subtype_mk _⟩
+
+private theorem
+    Degree.DiskCylinder.retraction_fixed {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (p : (unitInterval) × Disk (E := E)) (hp : p ∈ bottomOrSide) : (retraction p).val = p := by
+  have hh : toHandle p ∈ Degree.Handle.faceCore := by
+    rcases hp with ht | hx
+    · exact Or.inr (congrArg Subtype.val ht)
+    · exact Or.inl hx
+  have hr := Degree.Handle.retraction_eq_self (toHandle p) hh
+  apply Prod.ext
+  · apply Subtype.ext
+    exact congrArg (fun z : Degree.Handle.Space (N := E) (P := ℝ) => (z.2 : ℝ)) hr
+  · exact congrArg Prod.fst hr
+
+private def Degree.DiskCylinder.boundaryToDisk {E : Type*} [NormedAddCommGroup E] :
+    C(Sphere (E := E), Disk (E := E)) :=
+  ⟨fun u => ⟨u.val, Metric.sphere_subset_closedBall u.property⟩,
+    continuous_subtype_val.subtype_mk _⟩
+
+private def Degree.DiskCylinder.bottomMap {E : Type*} [NormedAddCommGroup E] :
+    C(Disk (E := E), bottomOrSide (E := E)) :=
+  ⟨fun u => ⟨(0, u), Or.inl rfl⟩, (continuous_const.prodMk continuous_id).subtype_mk _⟩
+
+private def Degree.DiskCylinder.sideMap {E : Type*} [NormedAddCommGroup E] :
+    C((unitInterval) × Sphere (E := E), bottomOrSide (E := E)) :=
+  ⟨fun p => ⟨(p.1, boundaryToDisk p.2), Or.inr (mem_sphere_zero_iff_norm.mp p.2.property)⟩,
+    (continuous_fst.prodMk (boundaryToDisk.continuous.comp continuous_snd)).subtype_mk _⟩
+
+private def Degree.DiskCylinder.bottomSideQuotient {E : Type*} [NormedAddCommGroup E] :
+    C(Disk (E := E) ⊕ ((unitInterval) × Sphere (E := E)), bottomOrSide (E := E)) :=
+  ⟨Sum.elim bottomMap sideMap, bottomMap.continuous.sumElim sideMap.continuous⟩
+
+private theorem
+    Degree.DiskCylinder.bottomSideQuotient_surjective {E : Type*} [NormedAddCommGroup E] :
+    Function.Surjective (bottomSideQuotient (E := E)) := by
+  rintro ⟨⟨t, u⟩, ht | hu⟩
+  · change t = 0 at ht
+    subst t
+    exact ⟨.inl u, rfl⟩
+  · exact ⟨.inr (t, ⟨u.val, mem_sphere_zero_iff_norm.mpr hu⟩), rfl⟩
+
+private theorem
+    Degree.DiskCylinder.bottomSideQuotient_isQuotientMap {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] :
+    Topology.IsQuotientMap (bottomSideQuotient (E := E)) :=
+  .of_surjective_continuous bottomSideQuotient_surjective bottomSideQuotient.continuous
+
+private def Degree.DiskCylinder.bottomSideData {E : Type*} [NormedAddCommGroup E] {X : Type*}
+    [TopologicalSpace X] (f : C(Disk (E := E), X)) (G : C((unitInterval) × Sphere (E := E), X)) :
+    C(Disk (E := E) ⊕ ((unitInterval) × Sphere (E := E)), X) :=
+  ⟨Sum.elim f G, f.continuous.sumElim G.continuous⟩
+
+private theorem
+    Degree.DiskCylinder.bottomSideData_constant_on_fibres {E : Type*} [NormedAddCommGroup E]
+    {X : Type*} [TopologicalSpace X] (f : C(Disk (E := E), X))
+    (G : C((unitInterval) × Sphere (E := E), X)) (h0 : ∀ u, G (0, u) = f (boundaryToDisk u))
+    (a b : Disk (E := E) ⊕ ((unitInterval) × Sphere (E := E)))
+    (h : bottomSideQuotient a = bottomSideQuotient b) :
+    bottomSideData f G a = bottomSideData f G b := by
+  have he := congrArg Subtype.val h
+  cases a with
+  | inl a =>
+    cases b with
+    | inl b => exact congrArg f (congrArg Prod.snd he)
+    | inr b =>
+      have ht : (0 : (unitInterval)) = b.1 := congrArg Prod.fst he
+      have hu : a = boundaryToDisk b.2 := congrArg Prod.snd he
+      exact (congrArg f hu).trans ((h0 b.2).symm.trans (congrArg G (Prod.ext ht rfl)))
+  | inr a =>
+    cases b with
+    | inl b =>
+      change G a = f b
+      have ht : a.1 = (0 : (unitInterval)) := congrArg Prod.fst he
+      have hu : boundaryToDisk a.2 = b := congrArg Prod.snd he
+      have ha : a = (0, a.2) := Prod.ext ht rfl
+      exact (congrArg G ha).trans ((h0 a.2).trans (congrArg f hu))
+    | inr b =>
+      change G a = G b
+      have ht : a.1 = b.1 := congrArg (fun p : (unitInterval) × Disk (E := E) => p.1) he
+      have hu : a.2.val = b.2.val :=
+        congrArg (fun p : (unitInterval) × Disk (E := E) => p.2.val) he
+      exact congrArg G (Prod.ext ht (Subtype.ext hu))
+
+private def Degree.DiskCylinder.gluedBottomSide {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] {X : Type*} [TopologicalSpace X] (f : C(Disk (E := E), X))
+    (G : C((unitInterval) × Sphere (E := E), X)) (h0 : ∀ u, G (0, u) = f (boundaryToDisk u)) :
+    C(bottomOrSide (E := E), X) :=
+  bottomSideQuotient_isQuotientMap.lift (bottomSideData f G)
+    (bottomSideData_constant_on_fibres f G h0)
+
+@[simp]
+private theorem Degree.DiskCylinder.gluedBottomSide_apply {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {X : Type*} [TopologicalSpace X]
+    (f : C(Disk (E := E), X)) (G : C((unitInterval) × Sphere (E := E), X))
+    (h0 : ∀ u, G (0, u) = f (boundaryToDisk u))
+    (z : Disk (E := E) ⊕ ((unitInterval) × Sphere (E := E))) :
+    gluedBottomSide f G h0 (bottomSideQuotient z) = bottomSideData f G z :=
+  ContinuousMap.congr_fun
+    (bottomSideQuotient_isQuotientMap.lift_comp (bottomSideData f G)
+      (bottomSideData_constant_on_fibres f G h0))
+    z
+
+@[simp]
+private theorem Degree.DiskCylinder.gluedBottomSide_bottom {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {X : Type*} [TopologicalSpace X]
+    (f : C(Disk (E := E), X)) (G : C((unitInterval) × Sphere (E := E), X))
+    (h0 : ∀ u, G (0, u) = f (boundaryToDisk u)) (u : Disk (E := E)) :
+    gluedBottomSide f G h0 (bottomMap u) = f u :=
+  gluedBottomSide_apply f G h0 (.inl u)
+
+@[simp]
+private theorem Degree.DiskCylinder.gluedBottomSide_side {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {X : Type*} [TopologicalSpace X]
+    (f : C(Disk (E := E), X)) (G : C((unitInterval) × Sphere (E := E), X))
+    (h0 : ∀ u, G (0, u) = f (boundaryToDisk u)) (p : (unitInterval) × Sphere (E := E)) :
+    gluedBottomSide f G h0 (sideMap p) = G p :=
+  gluedBottomSide_apply f G h0 (.inr p)
+
+private theorem
+    Degree.DiskCylinder.retraction_bottom {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (u : Disk (E := E)) : retraction (0, u) = bottomMap u :=
+  Subtype.ext (retraction_fixed (0, u) (Or.inl rfl))
+
+private theorem
+    Degree.DiskCylinder.retraction_side {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (p : (unitInterval) × Sphere (E := E)) : retraction (p.1, boundaryToDisk p.2) = sideMap p :=
+  Subtype.ext
+    (retraction_fixed (p.1, boundaryToDisk p.2)
+      (Or.inr (mem_sphere_zero_iff_norm.mp p.2.property)))
+
+private def Degree.DiskCylinder.extend {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] {X : Type*} [TopologicalSpace X] (f : C(Disk (E := E), X))
+    (G : C((unitInterval) × Sphere (E := E), X)) (h0 : ∀ u, G (0, u) = f (boundaryToDisk u)) :
+    C((unitInterval) × Disk (E := E), X) :=
+  (gluedBottomSide f G h0).comp retraction
+
+@[simp]
+private theorem
+    Degree.DiskCylinder.extend_bottom {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] {X : Type*} [TopologicalSpace X] (f : C(Disk (E := E), X))
+    (G : C((unitInterval) × Sphere (E := E), X)) (h0 : ∀ u, G (0, u) = f (boundaryToDisk u))
+    (u : Disk (E := E)) : Degree.DiskCylinder.extend f G h0 (0, u) = f u := by
+  change gluedBottomSide f G h0 (retraction (0, u)) = f u
+  rw [retraction_bottom, gluedBottomSide_bottom]
+
+@[simp]
+private theorem Degree.DiskCylinder.extend_side {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] {X : Type*} [TopologicalSpace X] (f : C(Disk (E := E), X))
+    (G : C((unitInterval) × Sphere (E := E), X)) (h0 : ∀ u, G (0, u) = f (boundaryToDisk u))
+    (t : (unitInterval)) (u : Sphere (E := E)) :
+    Degree.DiskCylinder.extend f G h0 (t, boundaryToDisk u) = G (t, u) := by
+  change gluedBottomSide f G h0 (retraction (t, boundaryToDisk u)) = G (t, u)
+  rw [retraction_side (t, u), gluedBottomSide_side]
+
+private def
+    Degree.DiskCylinder.extensionEndpoint {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] {X : Type*} [TopologicalSpace X] (f : C(Disk (E := E), X))
+    (G : C((unitInterval) × Sphere (E := E), X)) (h0 : ∀ u, G (0, u) = f (boundaryToDisk u)) :
+    C(Disk (E := E), X) :=
+  (Degree.DiskCylinder.extend f G h0).comp
+    ⟨fun u => (1, u), continuous_const.prodMk continuous_id⟩
+
+private def
+    Degree.DiskCylinder.extensionHomotopy {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] {X : Type*} [TopologicalSpace X] (f : C(Disk (E := E), X))
+    (G : C((unitInterval) × Sphere (E := E), X)) (h0 : ∀ u, G (0, u) = f (boundaryToDisk u)) :
+    f.Homotopy (extensionEndpoint f G h0)
+    where
+  toContinuousMap := Degree.DiskCylinder.extend f G h0
+  map_zero_left := extend_bottom f G h0
+  map_one_left _ := rfl
+
+private def Degree.DiskCone.radial {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] :
+    C((unitInterval) × Degree.DiskCylinder.Sphere (E := E), Degree.DiskCylinder.Disk (E := E))
+    where
+  toFun
+    p :=
+    ⟨p.1.val • p.2.val,
+      mem_closedBall_zero_iff.mpr
+        (by
+          rw [norm_smul, Real.norm_of_nonneg p.1.property.1,
+            mem_sphere_zero_iff_norm.mp p.2.property, mul_one]
+          exact p.1.property.2)⟩
+  continuous_toFun :=
+    ((continuous_subtype_val.comp continuous_fst).smul
+          (continuous_subtype_val.comp continuous_snd)).subtype_mk
+      _
+
+private theorem Degree.DiskCone.radial_norm {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (p : (unitInterval) × Degree.DiskCylinder.Sphere (E := E)) : ‖(radial p : E)‖ = p.1.val := by
+  change ‖p.1.val • p.2.val‖ = p.1.val
+  rw [norm_smul, Real.norm_of_nonneg p.1.property.1, mem_sphere_zero_iff_norm.mp p.2.property,
+    mul_one]
+
+@[simp]
+private theorem Degree.DiskCone.radial_one {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (s : Degree.DiskCylinder.Sphere (E := E)) :
+    radial (1, s) = Degree.DiskCylinder.boundaryToDisk s :=
+  Subtype.ext (one_smul ℝ s.val)
+
+@[simp]
+private theorem Degree.DiskCone.radial_zero {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (s : Degree.DiskCylinder.Sphere (E := E)) :
+    radial (0, s) = (⟨0, by simp⟩ : Degree.DiskCylinder.Disk (E := E)) :=
+  Subtype.ext (zero_smul ℝ s.val)
+
+private theorem
+    Degree.DiskCone.radial_surjective {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (s0 : Degree.DiskCylinder.Sphere (E := E)) : Function.Surjective (radial (E := E)) := by
+  intro z
+  by_cases hz : z.val = 0
+  · exact ⟨(0, s0), (radial_zero s0).trans (Subtype.ext hz.symm)⟩
+  · let t : (unitInterval) := ⟨‖z.val‖, norm_nonneg _, mem_closedBall_zero_iff.mp z.property⟩
+    let s : Degree.DiskCylinder.Sphere (E := E) :=
+      ⟨NormedSpace.normalize z.val, mem_sphere_zero_iff_norm.mpr (NormedSpace.norm_normalize hz)⟩
+    exact ⟨(t, s), Subtype.ext (NormedSpace.norm_smul_normalize z.val)⟩
+
+private theorem Degree.DiskCone.radial_eq_iff {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (p q : (unitInterval) × Degree.DiskCylinder.Sphere (E := E)) :
+    radial p = radial q ↔ p = q ∨ p.1 = 0 ∧ q.1 = 0 := by
+  constructor
+  · intro h
+    have ht : p.1 = q.1 :=
+      Subtype.ext
+        ((radial_norm p).symm.trans
+          ((congrArg (fun z : Degree.DiskCylinder.Disk (E := E) => ‖(z : E)‖) h).trans
+            (radial_norm q)))
+    by_cases hp : p.1 = 0
+    · exact Or.inr ⟨hp, ht.symm.trans hp⟩
+    · left
+      apply Prod.ext ht
+      apply Subtype.ext
+      have hn : p.1.val ≠ 0 := fun he => hp (Subtype.ext he)
+      have hv : p.1.val • p.2.val = q.1.val • q.2.val := congrArg Subtype.val h
+      rw [← ht] at hv
+      exact (smul_right_inj hn).mp hv
+  · rintro (rfl | ⟨hp, hq⟩)
+    · rfl
+    · change radial (p.1, p.2) = radial (q.1, q.2)
+      rw [hp, hq, radial_zero, radial_zero]
+
+private theorem
+    Degree.DiskCone.radial_isQuotientMap {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] (s0 : Degree.DiskCylinder.Sphere (E := E)) :
+    Topology.IsQuotientMap (radial (E := E)) :=
+  .of_surjective_continuous (radial_surjective s0) radial.continuous
+
+private theorem Degree.DiskCone.constant_on_radial_fibres {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {X : Type*} [TopologicalSpace X]
+    (G : C((unitInterval) × Degree.DiskCylinder.Sphere (E := E), X)) (x : X)
+    (hG : ∀ s, G (0, s) = x) (p q : (unitInterval) × Degree.DiskCylinder.Sphere (E := E))
+    (h : radial p = radial q) : G p = G q := by
+  rcases (radial_eq_iff p q).mp h with rfl | ⟨hp, hq⟩
+  · rfl
+  · change G (p.1, p.2) = G (q.1, q.2)
+    rw [hp, hq, hG, hG]
+
+private def Degree.DiskCone.extension {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] {X : Type*} [TopologicalSpace X]
+    (s0 : Degree.DiskCylinder.Sphere (E := E))
+    (G : C((unitInterval) × Degree.DiskCylinder.Sphere (E := E), X)) (x : X)
+    (hG : ∀ s, G (0, s) = x) : C(Degree.DiskCylinder.Disk (E := E), X) :=
+  (radial_isQuotientMap s0).lift G (constant_on_radial_fibres G x hG)
+
+private theorem
+    Degree.DiskCone.extension_radial {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] {X : Type*} [TopologicalSpace X]
+    (s0 : Degree.DiskCylinder.Sphere (E := E))
+    (G : C((unitInterval) × Degree.DiskCylinder.Sphere (E := E), X)) (x : X)
+    (hG : ∀ s, G (0, s) = x) (t : (unitInterval)) (s : Degree.DiskCylinder.Sphere (E := E)) :
+    extension s0 G x hG (radial (t, s)) = G (t, s) :=
+  ContinuousMap.congr_fun
+    ((radial_isQuotientMap s0).lift_comp G (constant_on_radial_fibres G x hG)) (t, s)
+
+private theorem
+    Degree.DiskCone.extension_boundary {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] {X : Type*} [TopologicalSpace X]
+    (s0 : Degree.DiskCylinder.Sphere (E := E))
+    (G : C((unitInterval) × Degree.DiskCylinder.Sphere (E := E), X)) (x : X)
+    (hG : ∀ s, G (0, s) = x) (s : Degree.DiskCylinder.Sphere (E := E)) :
+    extension s0 G x hG (Degree.DiskCylinder.boundaryToDisk s) = G (1, s) := by
+  rw [← radial_one, extension_radial]
+
+private theorem
+    Degree.DiskCone.extension_center {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] {X : Type*} [TopologicalSpace X]
+    (s0 : Degree.DiskCylinder.Sphere (E := E))
+    (G : C((unitInterval) × Degree.DiskCylinder.Sphere (E := E), X)) (x : X)
+    (hG : ∀ s, G (0, s) = x) : extension s0 G x hG ⟨0, by simp⟩ = x := by
+  rw [← radial_zero s0, extension_radial, hG]
+
+private theorem Degree.UnitSphereEquiv.vector_ne_zero {E : Type*} [NormedAddCommGroup E]
+    (u : Degree.DiskCylinder.Sphere (E := E)) : u.val ≠ 0 := by
+  intro h
+  have hn := mem_sphere_zero_iff_norm.mp u.property
+  rw [h, norm_zero] at hn
+  exact zero_ne_one hn
+
+private theorem Degree.UnitSphereEquiv.image_ne_zero {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] (L : E ≃L[ℝ] F)
+    (u : Degree.DiskCylinder.Sphere (E := E)) : L u.val ≠ 0 := by
+  intro h
+  exact vector_ne_zero u (L.injective (h.trans (L.map_zero).symm))
+
+private def Degree.UnitSphereEquiv.map {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (L : E ≃L[ℝ] F) :
+    C(Degree.DiskCylinder.Sphere (E := E), Degree.DiskCylinder.Sphere (E := F))
+    where
+  toFun
+    u :=
+    ⟨NormedSpace.normalize (L u.val),
+      mem_sphere_zero_iff_norm.mpr (NormedSpace.norm_normalize (image_ne_zero L u))⟩
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    exact
+      (((L.continuous.comp continuous_subtype_val).norm.inv₀
+            (fun u => norm_ne_zero_iff.mpr (image_ne_zero L u))).smul
+        (L.continuous.comp continuous_subtype_val))
+
+private theorem
+    Degree.UnitSphereEquiv.map_inverse {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (L : E ≃L[ℝ] F)
+    (u : Degree.DiskCylinder.Sphere (E := E)) :
+    Degree.UnitSphereEquiv.map L.symm (Degree.UnitSphereEquiv.map L u) = u := by
+  apply Subtype.ext
+  change NormedSpace.normalize (L.symm (‖L u.val‖⁻¹ • L u.val)) = u.val
+  rw [map_smul, L.symm_apply_apply,
+    NormedSpace.normalize_smul_of_pos (inv_pos.mpr (norm_pos_iff.mpr (image_ne_zero L u)))]
+  exact NormedSpace.normalize_eq_self_of_norm_eq_one (mem_sphere_zero_iff_norm.mp u.property)
+
+private def Degree.UnitSphereEquiv.homeomorph {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (L : E ≃L[ℝ] F) :
+    Degree.DiskCylinder.Sphere (E := E) ≃ₜ Degree.DiskCylinder.Sphere (E := F)
+    where
+  toFun := Degree.UnitSphereEquiv.map L
+  invFun := Degree.UnitSphereEquiv.map L.symm
+  left_inv := map_inverse L
+  right_inv := map_inverse L.symm
+  continuous_toFun := (Degree.UnitSphereEquiv.map L).continuous
+  continuous_invFun := (Degree.UnitSphereEquiv.map L.symm).continuous
+
+private theorem
+    MorseCancel.unitSphere_eq_two_points_of_finrank_one {V : Type} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [FiniteDimensional ℝ V] (hdim : Module.finrank ℝ V = 1)
+    (u v : Metric.sphere (0 : V) 1) (huv : u ≠ v) (w : Metric.sphere (0 : V) 1) : w = u ∨ w = v :=
+  by
+  obtain ⟨L⟩ :=
+    FiniteDimensional.nonempty_continuousLinearEquiv_of_finrank_eq
+      (show Module.finrank ℝ V = Module.finrank ℝ ℝ by simpa using hdim)
+  let e := Degree.UnitSphereEquiv.homeomorph L
+  have hpoint (z : Metric.sphere (0 : V) 1) : (e z : ℝ) = 1 ∨ (e z : ℝ) = -1 := by
+    have hz : |(e z : ℝ)| = |(1 : ℝ)| := by
+      simpa only [Real.norm_eq_abs, abs_one] using mem_sphere_zero_iff_norm.mp (e z).property
+    exact abs_eq_abs.mp hz
+  have hne : (e u : ℝ) ≠ (e v : ℝ) := fun h => huv (e.injective (Subtype.ext h))
+  have heq : (e w : ℝ) = (e u : ℝ) ∨ (e w : ℝ) = (e v : ℝ) := by
+    rcases hpoint u with hu | hu <;> rcases hpoint v with hv | hv <;>
+        rcases hpoint w with hw | hw <;>
+      simp_all
+  exact
+    heq.elim (fun h => Or.inl (e.injective (Subtype.ext h)))
+      (fun h => Or.inr (e.injective (Subtype.ext h)))
+
+private theorem MorseCancel.exists_positive_height_rescaling {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    {χ : M → ℝ} (hχ : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ χ) (hχrange : ∀ x, χ x ∈ Set.Icc (0 : ℝ) 1)
+    (hdesc : ∀ x ∈ tsupport χ, mvfderiv 𝓘(ℝ, E) f x (V x) < 0) :
+    ∃ ρ : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ ρ ∧
+        (∀ x, 0 < ρ x) ∧
+          ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞
+              (fun x => (⟨x, ρ x • V x⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+            (∀ x, ρ x • V x = 0 ↔ V x = 0) ∧
+              (∀ x, mvfderiv 𝓘(ℝ, E) f x (V x) < 0 → mvfderiv 𝓘(ℝ, E) f x (ρ x • V x) < 0) ∧
+                (∀ x, χ x = 1 → mvfderiv 𝓘(ℝ, E) f x (ρ x • V x) = -1) ∧
+                  ∀ x ∉ tsupport χ, ∀ᶠ y in 𝓝 x, ρ y = 1 := by
+  let D (x : M) := mvfderiv 𝓘(ℝ, E) f x (V x)
+  let ρ (x : M) := 1 - χ x + χ x / (-D x)
+  have hD : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ D := contMDiff_directionalDerivative hf hV
+  have hρ : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ ρ :=
+    (contMDiff_const.sub hχ).add
+      (contMDiff_supported_division hχ hD.neg (fun x hx => neg_ne_zero.mpr (hdesc x hx).ne))
+  have hpos (x : M) : 0 < ρ x := by
+    by_cases hx : x ∈ tsupport χ
+    · have hdx : 0 < -D x := neg_pos.mpr (hdesc x hx)
+      by_cases he : χ x = 1
+      · simpa only [ρ, he, sub_self, zero_add] using one_div_pos.mpr hdx
+      · exact
+          add_pos_of_pos_of_nonneg (sub_pos.mpr (lt_of_le_of_ne (hχrange x).2 he))
+            (div_nonneg (hχrange x).1 hdx.le)
+    · simp only [ρ, image_eq_zero_of_notMem_tsupport hx, sub_zero, zero_div, add_zero]
+      exact zero_lt_one
+  refine ⟨ρ, hρ, hpos, hρ.smul_section hV, ?_, ?_, ?_, ?_⟩
+  · intro x
+    exact smul_eq_zero.trans (or_iff_right (hpos x).ne')
+  · intro x hx
+    rw [map_smul, smul_eq_mul]
+    exact mul_neg_of_pos_of_neg (hpos x) hx
+  · intro x hx
+    have hs : x ∈ tsupport χ := subset_tsupport χ (by simp [Function.mem_support, hx])
+    have hd : D x ≠ 0 := (hdesc x hs).ne
+    rw [map_smul, smul_eq_mul]
+    change (1 - χ x + χ x / (-D x)) * D x = -1
+    rw [hx]
+    field_simp
+    ring
+  · intro x hx
+    filter_upwards [(isClosed_tsupport χ).isOpen_compl.mem_nhds hx] with y hy
+    simp only [ρ, image_eq_zero_of_notMem_tsupport hy, sub_zero, zero_div, add_zero]
+
+private theorem MorseCancel.exists_positive_band_normalization {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} [CompactSpace M] (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    {a b : ℝ} (hband : ∀ x, f x ∈ Set.Icc a b → x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    ∃ (ρ : M → ℝ) (U : Set ℝ),
+      IsOpen U ∧
+        Set.Icc a b ⊆ U ∧
+          ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ ρ ∧
+            (∀ x, 0 < ρ x) ∧
+              ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞
+                  (fun x => (⟨x, ρ x • V x⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+                (∀ x, ρ x • V x = 0 ↔ V x = 0) ∧
+                  (∀ x,
+                      x ∉ Smale.ManifoldMorse.criticalPoints E f →
+                        mvfderiv 𝓘(ℝ, E) f x (ρ x • V x) < 0) ∧
+                    (∀ x, f x ∈ U → mvfderiv 𝓘(ℝ, E) f x (ρ x • V x) = -1) ∧
+                      ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ y in 𝓝 x, ρ y = 1 := by
+  let B := f '' Smale.ManifoldMorse.criticalPoints E f
+  have hB : IsClosed B :=
+    ((Smale.ManifoldMorse.criticalPoints_isClosed hf).isCompact.image hf.continuous).isClosed
+  have hAB : Set.Icc a b ⊆ Bᶜ := by
+    rintro y hy ⟨x, hx, rfl⟩
+    exact hband x hy hx
+  obtain ⟨φ, hφ, hsupp, U, hU, hAU, -, hφU⟩ :=
+    LineBundleTransport.exists_smooth_cutoff_near_closed isClosed_Icc hB.isOpen_compl hAB
+  let χ := Real.smoothTransition ∘ φ ∘ f
+  have hχ : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ χ :=
+    (Real.smoothTransition.contDiff.comp hφ).contMDiff.comp hf
+  have hχsupport : tsupport χ ⊆ (Smale.ManifoldMorse.criticalPoints E f)ᶜ := by
+    intro x hx hcrit
+    have hp := tsupport_comp_subset Real.smoothTransition.zero (φ ∘ f) hx
+    exact hsupp (tsupport_comp_subset_preimage φ hf.continuous hp) ⟨x, hcrit, rfl⟩
+  obtain ⟨ρ, hρ, hpos, hW, hzero, hneg, hspeed, hgerm⟩ :=
+    exists_positive_height_rescaling hf hV hχ
+      (fun x => ⟨Real.smoothTransition.nonneg _, Real.smoothTransition.le_one _⟩)
+      (fun x hx => hdesc x (hχsupport hx))
+  refine ⟨ρ, U, hU, hAU, hρ, hpos, hW, hzero, fun x hx => hneg x (hdesc x hx), ?_, ?_⟩
+  · intro x hx
+    apply hspeed
+    simp only [χ, Function.comp_apply, hφU hx, Real.smoothTransition.one]
+  · intro x hx
+    exact hgerm x (fun h => hχsupport h hx)
+
+private theorem
+    Degree.FlowTimeChange.local_affine_height_germ {γ : ℝ → ℝ} (hγ : Continuous γ) {U : Set ℝ}
+    (hU : IsOpen U) (hd : ∀ t, γ t ∈ U → HasDerivAt γ (-1) t) {t : ℝ} (ht : γ t ∈ U) :
+    ∀ᶠ s in 𝓝 t, γ s + s = γ t + t := by
+  obtain ⟨l, u, htu, hsub⟩ := mem_nhds_iff_exists_Ioo_subset.mp ((hU.preimage hγ).mem_nhds ht)
+  have hder (s : ℝ) (hs : s ∈ Set.Ioo l u) : HasDerivAt (fun r => γ r + r) 0 s := by
+    convert! (hd s (hsub hs)).add (hasDerivAt_id s) using 1
+    norm_num
+  filter_upwards [Ioo_mem_nhds htu.1 htu.2] with s hs
+  exact
+    isOpen_Ioo.is_const_of_deriv_eq_zero isPreconnected_Ioo
+      (fun r hr => (hder r hr).differentiableAt.differentiableWithinAt)
+      (fun r hr => (hder r hr).deriv) hs htu
+
+private theorem
+    Degree.FlowTimeChange.scalar_local_height_translation {γ : ℝ → ℝ} (hγ : Continuous γ)
+    {U : Set ℝ} (hU : IsOpen U) {a b c t : ℝ} (hIU : Set.Icc a b ⊆ U)
+    (hd : ∀ s, γ s ∈ U → HasDerivAt γ (-1) s) (hzero : γ 0 = c) (hc : c ∈ Set.Icc a b)
+    (ht : c - t ∈ Set.Icc a b) : γ t = c - t := by
+  let J := Set.Icc (c - b) (c - a)
+  let _ : PreconnectedSpace J := isPreconnected_iff_preconnectedSpace.mp isPreconnected_Icc
+  let P : J → Prop := fun s => γ s = c - s
+  have hloc : IsLocallyConstant P := by
+    apply (IsLocallyConstant.iff_eventually_eq P).mpr
+    intro s
+    by_cases hs : P s
+    · have hsU : γ s ∈ U := by
+        rw [show γ s = c - s from hs]
+        exact hIU ⟨by linarith [s.property.2], by linarith [s.property.1]⟩
+      have heq := local_affine_height_germ hγ hU hd hsU
+      filter_upwards [continuous_subtype_val.continuousAt heq] with r hr
+      apply propext
+      constructor
+      · intro _
+        exact hs
+      · intro _
+        change γ r = c - r
+        change γ s = c - s at hs
+        change γ r + r = γ s + s at hr
+        linarith
+    · have hn : (s : ℝ) ∈ {r : ℝ | γ r = c - r}ᶜ := hs
+      have hopen : IsOpen {r : ℝ | γ r = c - r}ᶜ :=
+        (isClosed_eq hγ ((continuous_const (y := c)).sub continuous_id)).isOpen_compl
+      filter_upwards [continuous_subtype_val.continuousAt (hopen.mem_nhds hn)] with r hr
+      exact propext ⟨fun h => (hr h).elim, fun h => (hs h).elim⟩
+  let s₀ : J := ⟨0, ⟨by linarith [hc.2], by linarith [hc.1]⟩⟩
+  let s₁ : J := ⟨t, ⟨by linarith [ht.2], by linarith [ht.1]⟩⟩
+  have hinit : P s₀ := by simpa only [P, s₀, sub_zero] using hzero
+  have heq : P s₀ = P s₁ := hloc.apply_eq_of_preconnectedSpace s₀ s₁
+  have hfinish : P s₁ := heq ▸ hinit
+  exact hfinish
+
+private theorem
+    Degree.FlowTimeChange.native_local_height_translation {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) {U : Set ℝ} (hU : IsOpen U)
+    {a b : ℝ} (hIU : Set.Icc a b ⊆ U) (hspeed : ∀ x, f x ∈ U → mvfderiv 𝓘(ℝ, E) f x (V x) = -1)
+    (x : M) (t : ℝ) (hx : f x ∈ Set.Icc a b) (ht : f x - t ∈ Set.Icc a b) : f (F t x) = f x - t :=
+  by
+  apply
+    scalar_local_height_translation
+      (hf.continuous.comp (F.continuous continuous_id continuous_const)) hU hIU (γ := fun s =>
+      f (F s x)) ?_ (by rw [F.map_zero_apply]) hx ht
+  intro s hs
+  have hd := Smale.FlowConstruction.hasDerivAt_comp_integralCurve hf (hcurve x) s
+  rw [hspeed (F s x) hs] at hd
+  exact hd
+
+private theorem Degree.FlowTimeChange.normalized_flow_level_image {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f : X → ℝ} {a b : ℝ} (hab : a ≤ b)
+    (hshift : ∀ x t, f x ∈ Set.Icc a b → f x - t ∈ Set.Icc a b → f (F t x) = f x - t) :
+    F (a - b) '' {x : X | f x = a} = {x : X | f x = b} := by
+  ext y
+  constructor
+  · rintro ⟨x, hx, rfl⟩
+    change f x = a at hx
+    have hh :=
+      hshift x (a - b) (by rw [hx]; exact ⟨le_rfl, hab⟩) (by rw [hx]; constructor <;> linarith)
+    change f (F (a - b) x) = b
+    linarith
+  · intro hy
+    change f y = b at hy
+    have hh :=
+      hshift y (b - a) (by rw [hy]; exact ⟨hab, le_rfl⟩) (by rw [hy]; constructor <;> linarith)
+    refine ⟨F (b - a) y, ?_, ?_⟩
+    · change f (F (b - a) y) = a
+      linarith
+    · rw [← F.map_add, show a - b + (b - a) = 0 by ring, F.map_zero_apply]
+
+private theorem Degree.FlowTimeChange.normalized_flow_sublevel_iff {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f : X → ℝ} (hf : Continuous f) {a b : ℝ} (hab : a ≤ b)
+    (hshift : ∀ x t, f x ∈ Set.Icc a b → f x - t ∈ Set.Icc a b → f (F t x) = f x - t) (x : X) :
+    f (F (a - b) x) ≤ b ↔ f x ≤ a := by
+  let γ : ℝ → ℝ := fun s => f (F (-s) x) - (a + s)
+  have hγ : Continuous γ :=
+    (hf.comp (F.continuous ContinuousNeg.continuous_neg continuous_const)).sub
+      (continuous_const.add continuous_id)
+  have hstart : γ 0 = f x - a := by simp only [γ, neg_zero, F.map_zero_apply, add_zero]
+  have hend : γ (b - a) = f (F (a - b) x) - b := by
+    dsimp [γ]
+    rw [neg_sub, show a + (b - a) = b by ring]
+  have hzero (s : ℝ) (hs : s ∈ Set.Icc 0 (b - a)) (hgs : γ s = 0) : f x = a := by
+    have hz : f (F (-s) x) = a + s := by dsimp [γ] at hgs; linarith
+    have hh :=
+      hshift (F (-s) x) s (by rw [hz]; constructor <;> linarith [hs.1, hs.2])
+        (by rw [hz]; constructor <;> linarith)
+    rw [← F.map_add, add_neg_cancel, F.map_zero_apply] at hh
+    linarith
+  have hzeroEnd (hx : f x = a) : γ (b - a) = 0 := by
+    have hh :=
+      hshift x (a - b) (by rw [hx]; exact ⟨le_rfl, hab⟩) (by rw [hx]; constructor <;> linarith)
+    rw [hend]
+    linarith
+  constructor
+  · intro hy
+    by_contra hx
+    have hx' : a < f x := lt_of_not_ge hx
+    obtain ⟨s, hs, hgs⟩ :=
+      intermediate_value_Icc' (sub_nonneg.mpr hab) hγ.continuousOn
+        (show (0 : ℝ) ∈ Set.Icc (γ (b - a)) (γ 0) by rw [hstart, hend]; constructor <;> linarith)
+    linarith [hzero s hs hgs]
+  · intro hx
+    by_contra hy
+    have hy' : b < f (F (a - b) x) := lt_of_not_ge hy
+    obtain ⟨s, hs, hgs⟩ :=
+      intermediate_value_Icc (sub_nonneg.mpr hab) hγ.continuousOn
+        (show (0 : ℝ) ∈ Set.Icc (γ 0) (γ (b - a)) by rw [hstart, hend]; constructor <;> linarith)
+    have hh := hzeroEnd (hzero s hs hgs)
+    rw [hend] at hh
+    linarith
+
+private theorem
+    Degree.FlowTimeChange.normalized_flow_sublevel_image {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f : X → ℝ} (hf : Continuous f) {a b : ℝ} (hab : a ≤ b)
+    (hshift : ∀ x t, f x ∈ Set.Icc a b → f x - t ∈ Set.Icc a b → f (F t x) = f x - t) :
+    F (a - b) '' {x : X | f x ≤ a} = {x : X | f x ≤ b} := by
+  ext y
+  constructor
+  · rintro ⟨x, hx, rfl⟩
+    exact (normalized_flow_sublevel_iff F hf hab hshift x).mpr hx
+  · intro hy
+    have hi : F (a - b) (F (b - a) y) = y := by
+      rw [← F.map_add, show a - b + (b - a) = 0 by ring, F.map_zero_apply]
+    refine ⟨F (b - a) y, ?_, hi⟩
+    apply (normalized_flow_sublevel_iff F hf hab hshift _).mp
+    rw [hi]
+    exact hy
+
+private theorem Degree.FlowTimeChange.exists_positive_integral_clock {a : ℝ → ℝ} (ha : Continuous a)
+    {δ : ℝ} (hδ : 0 < δ) (hlower : ∀ t, δ ≤ a t) :
+    ∃ c : ℝ ≃o ℝ,
+      c 0 = 0 ∧
+        (∀ t, c t = ∫ s in (0 : ℝ)..t, a s) ∧
+          (∀ t, HasDerivAt c (a t) t) ∧ ∀ t, HasDerivAt c.symm (a (c.symm t))⁻¹ t := by
+  let g : ℝ → ℝ := fun t => ∫ s in (0 : ℝ)..t, a s
+  have hd (t : ℝ) : HasDerivAt g (a t) t :=
+    intervalIntegral.integral_hasDerivAt_right (ha.intervalIntegrable _ _)
+      ha.aestronglyMeasurable.stronglyMeasurableAtFilter ha.continuousAt
+  have hg : Differentiable ℝ g := fun t => (hd t).differentiableAt
+  have hzero : g 0 = 0 := by simp [g]
+  have hmono : StrictMono g := strictMono_of_hasDerivAt_pos hd (fun t => hδ.trans_le (hlower t))
+  have hbound {s t : ℝ} (hst : s ≤ t) : δ * (t - s) ≤ g t - g s :=
+    mul_sub_le_image_sub_of_le_deriv hg (fun t => by rw [(hd t).deriv]; exact hlower t) hst
+  have hsurj : Function.Surjective g := by
+    intro y
+    apply mem_range_of_exists_le_of_exists_ge hg.continuous
+    · refine ⟨Min.min 0 (y / δ), ?_⟩
+      have hh := hbound (min_le_left 0 (y / δ))
+      have hm : δ * Min.min 0 (y / δ) ≤ y := by
+        calc
+          δ * Min.min 0 (y / δ) ≤ δ * (y / δ) :=
+            mul_le_mul_of_nonneg_left (min_le_right _ _) hδ.le
+          _ = y := by field_simp
+      rw [hzero] at hh
+      linarith
+    · refine ⟨Max.max 0 (y / δ), ?_⟩
+      have hh := hbound (le_max_left 0 (y / δ))
+      have hm : y ≤ δ * Max.max 0 (y / δ) := by
+        calc
+          y = δ * (y / δ) := by field_simp
+          _ ≤ δ * Max.max 0 (y / δ) := mul_le_mul_of_nonneg_left (le_max_right _ _) hδ.le
+      rw [hzero] at hh
+      linarith
+  let c : ℝ ≃o ℝ := hmono.orderIsoOfSurjective g hsurj
+  refine ⟨c, hzero, fun _ => rfl, hd, ?_⟩
+  intro t
+  exact
+    HasDerivAt.of_local_left_inverse c.symm.continuous.continuousAt (hd (c.symm t))
+      (ne_of_gt (hδ.trans_le (hlower _))) (Filter.Eventually.of_forall c.apply_symm_apply)
+
+private theorem Degree.FlowTimeChange.native_curve_positive_reparametrization {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {ρ : M → ℝ} {γ : ℝ → M} (hγ : IsMIntegralCurve γ V)
+    {c : ℝ → ℝ} (hc : ∀ t, HasDerivAt c (ρ (γ (c t))) t) :
+    IsMIntegralCurve (γ ∘ c) (fun x => ρ x • V x) := by
+  intro t
+  have hh := (hγ (c t)).comp t (hc t).hasFDerivAt.hasMFDerivAt
+  have he :
+    (1 : ℝ →L[ℝ] ℝ).smulRight (ρ (γ (c t)) • V (γ (c t))) =
+      ((1 : ℝ →L[ℝ] ℝ).smulRight (V (γ (c t)))).comp
+        (ContinuousLinearMap.toSpanSingleton ℝ (ρ (γ (c t)))) := by
+    ext
+    simp [smul_smul, mul_comm]
+  change
+    HasMFDerivAt 𝓘(ℝ, ℝ) 𝓘(ℝ, E) (γ ∘ c) t ((1 : ℝ →L[ℝ] ℝ).smulRight (ρ (γ (c t)) • V (γ (c t))))
+  rw [he]
+  exact hh
+
+private theorem
+    Degree.FlowTimeChange.exists_native_flow_time_change {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} [CompactSpace M] {ρ : M → ℝ} (hρ : Continuous ρ)
+    (hρpos : ∀ x, 0 < ρ x)
+    (hW :
+      ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, ρ x • V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F G : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hG : ∀ x, IsMIntegralCurve (fun t => G t x) (fun y => ρ y • V y)) (x : M) :
+    ∃ c : ℝ ≃o ℝ,
+      c 0 = 0 ∧
+        (∀ t, c t = ∫ s in (0 : ℝ)..t, (ρ (F s x))⁻¹) ∧
+          (∀ t, HasDerivAt c.symm (ρ (F (c.symm t) x)) t) ∧ ∀ t, G t x = F (c.symm t) x := by
+  obtain ⟨R, hR⟩ := (isCompact_univ.image hρ).bddAbove
+  have hbound (y : M) : ρ y ≤ R := hR ⟨y, Set.mem_univ _, rfl⟩
+  have hRpos : 0 < R := (hρpos x).trans_le (hbound x)
+  have ha : Continuous (fun t => (ρ (F t x))⁻¹) :=
+    (hρ.comp (F.continuous continuous_id continuous_const)).inv₀ (fun t => (hρpos _).ne')
+  have hlower (t : ℝ) : R⁻¹ ≤ (ρ (F t x))⁻¹ := by
+    simpa only [one_div] using one_div_le_one_div_of_le (hρpos (F t x)) (hbound (F t x))
+  obtain ⟨c, hc0, hcint, -, hcinv⟩ := exists_positive_integral_clock ha (inv_pos.mpr hRpos) hlower
+  have hcinv' (t : ℝ) : HasDerivAt c.symm (ρ (F (c.symm t) x)) t := by
+    simpa only [inv_inv] using hcinv t
+  have hcurve := native_curve_positive_reparametrization (hF x) hcinv'
+  have hc0' : c.symm 0 = 0 := by
+    apply c.injective
+    rw [c.apply_symm_apply]
+    exact hc0.symm
+  have heq :=
+    isMIntegralCurve_Ioo_eq_of_contMDiff_boundaryless hW (hG x) hcurve (t₀ := 0)
+      (by simp only [Function.comp_apply, hc0', F.map_zero_apply, G.map_zero_apply])
+  exact ⟨c, hc0, hcint, hcinv', fun t => congrFun heq t⟩
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Recognition/Degree2.lean b/LeanPool/HopfProblem/Recognition/Degree2.lean
new file mode 100644
index 000000000..c4f7f25c3
--- /dev/null
+++ b/LeanPool/HopfProblem/Recognition/Degree2.lean
@@ -0,0 +1,5633 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import all LeanPool.HopfProblem.Foundations.LineBundleTransport
+import all LeanPool.HopfProblem.Recognition.Smale1
+import all LeanPool.HopfProblem.Recognition.Smale2
+import all LeanPool.HopfProblem.Recognition.Smale3
+import all LeanPool.HopfProblem.Recognition.Smale4
+import all LeanPool.HopfProblem.Recognition.Smale5
+import all LeanPool.HopfProblem.Recognition.Degree1
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods6
+
+/-!
+# Hopf problem: recognition · degree 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem
+    Degree.FlowTimeChange.native_flow_time_change_orbits {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} [CompactSpace M] {ρ : M → ℝ} (hρ : Continuous ρ)
+    (hρpos : ∀ x, 0 < ρ x)
+    (hW :
+      ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, ρ x • V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F G : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hG : ∀ x, IsMIntegralCurve (fun t => G t x) (fun y => ρ y • V y)) (x : M) :
+    Set.range (fun t => G t x) = Set.range (fun t => F t x) ∧
+      (∀ p,
+          Filter.Tendsto (fun t => G t x) Filter.atTop (𝓝 p) ↔
+            Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p)) ∧
+        ∀ p,
+          Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 p) ↔
+            Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p) := by
+  obtain ⟨c, -, -, -, heq⟩ := exists_native_flow_time_change hρ hρpos hW F G hF hG x
+  have heq' (t : ℝ) : F t x = G (c t) x := by rw [heq, c.symm_apply_apply]
+  refine ⟨?_, ?_, ?_⟩
+  · ext y
+    constructor
+    · rintro ⟨t, rfl⟩
+      exact ⟨c.symm t, (heq t).symm⟩
+    · rintro ⟨t, rfl⟩
+      exact ⟨c t, (heq' t).symm⟩
+  · intro p
+    constructor
+    · intro h
+      exact (h.comp c.tendsto_atTop).congr (fun t => (heq' t).symm)
+    · intro h
+      exact (h.comp c.symm.tendsto_atTop).congr (fun t => (heq t).symm)
+  · intro p
+    constructor
+    · intro h
+      exact (h.comp c.tendsto_atBot).congr (fun t => (heq' t).symm)
+    · intro h
+      exact (h.comp c.symm.tendsto_atBot).congr (fun t => (heq t).symm)
+
+private theorem Degree.FlowTimeChange.exists_orbit_preserving_band_normalization {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {a b : ℝ}
+    (hband : ∀ x, f x ∈ Set.Icc a b → x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    ∃ (U : Set ℝ) (W : (x : M) → TangentSpace 𝓘(ℝ, E) x) (G : Flow ℝ M),
+      IsOpen U ∧
+        Set.Icc a b ⊆ U ∧
+          ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, W x⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+            (∀ x, IsMIntegralCurve (fun t => G t x) W) ∧
+              (∀ x, W x = 0 ↔ V x = 0) ∧
+                (∀ x,
+                    x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (W x) < 0) ∧
+                  (∀ x, f x ∈ U → mvfderiv 𝓘(ℝ, E) f x (W x) = -1) ∧
+                    (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ y in 𝓝 x, W y = V y) ∧
+                      (∀ x, ∃ c : ℝ ≃o ℝ, c 0 = 0 ∧ ∀ t, G t x = F (c.symm t) x) ∧
+                        ∀ x,
+                          Set.range (fun t => G t x) = Set.range (fun t => F t x) ∧
+                            (∀ p,
+                                Filter.Tendsto (fun t => G t x) Filter.atTop (𝓝 p) ↔
+                                  Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p)) ∧
+                              ∀ p,
+                                Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 p) ↔
+                                  Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p) := by
+  obtain ⟨ρ, U, hU, hAU, hρ, hpos, hW, hzeros, hneg, hspeed, hgerm⟩ :=
+    MorseCancel.exists_positive_band_normalization hf hV hdesc hband
+  have hW₁ := hW.of_le (show (1 : WithTop ℕ∞) ≤ (↑(⊤ : ℕ∞) : ℕ∞ω) by simp)
+  let W : (x : M) → TangentSpace 𝓘(ℝ, E) x := fun x => ρ x • V x
+  let G := Smale.FlowConstruction.compactFlow hW₁
+  have hG (x : M) : IsMIntegralCurve (fun t => G t x) W :=
+    Smale.FlowConstruction.isMIntegralCurve_compactFlow hW₁ x
+  refine ⟨U, W, G, hU, hAU, hW, hG, hzeros, hneg, hspeed, ?_, ?_, ?_⟩
+  · intro x hx
+    filter_upwards [hgerm x hx] with y hy
+    simp only [W, hy, one_smul]
+  · intro x
+    obtain ⟨c, hc0, -, -, heq⟩ :=
+      exists_native_flow_time_change hρ.continuous hpos hW₁ F G hF hG x
+    exact ⟨c, hc0, heq⟩
+  · exact native_flow_time_change_orbits hρ.continuous hpos hW₁ F G hF hG
+
+private theorem Degree.FlowTimeChange.exists_orbit_preserving_ambient_band_bridge {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {a b : ℝ} (hab : a ≤ b)
+    (hband : ∀ x, f x ∈ Set.Icc a b → x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    ∃ D : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞,
+      D '' {x : M | f x = a} = {x : M | f x = b} ∧
+        D '' {x : M | f x ≤ a} = {x : M | f x ≤ b} ∧ ∀ x, ∃ t, F t x = D x := by
+  obtain ⟨U, W, G, hU, hIU, hW, hG, -, -, hspeed, -, -, hgeometry⟩ :=
+    exists_orbit_preserving_band_normalization hf hV hdesc F hF hband
+  have hshift := native_local_height_translation hf G hG hU hIU hspeed
+  let D := Degree.SmoothODE.nativeFlowTimeDiffeomorph_of_field hW G hG (a - b)
+  refine
+    ⟨D, normalized_flow_level_image G hab hshift,
+      normalized_flow_sublevel_image G hf.continuous hab hshift, ?_⟩
+  intro x
+  have hm : D x ∈ Set.range (fun t => G t x) := ⟨a - b, rfl⟩
+  rw [(hgeometry x).1] at hm
+  exact hm
+
+private theorem Degree.FlowTimeChange.exists_orbit_preserving_native_band_bridge {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {a b : ℝ} (hab : a ≤ b)
+    (hband : ∀ x, f x ∈ Set.Icc a b → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (ha : ∀ x, f x = a → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hb : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    letI := Smale.RegularLevel.chartedSpace hf ha
+    letI := Smale.RegularLevel.chartedSpace hf hb
+    ∃ D : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞,
+      ∃ e :
+        Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+          { x : M // f x = a } { x : M // f x = b } ∞,
+        D '' {x : M | f x ≤ a} = {x : M | f x ≤ b} ∧
+          (∀ x, (e x : M) = D x) ∧ ∀ x, ∃ t, F t x = D x := by
+  let _ := Smale.RegularLevel.chartedSpace hf ha
+  let _ := Smale.RegularLevel.chartedSpace hf hb
+  obtain ⟨D, hlevel, hsublevel, horbit⟩ :=
+    exists_orbit_preserving_ambient_band_bridge hf hV hdesc F hF hab hband
+  obtain ⟨e, he⟩ := Smale.RegularLevel.exists_levelDiffeomorph_of_ambient hf ha hb D hlevel
+  exact ⟨D, e, hsublevel, he, horbit⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem AdaptedWindows.exists_orbit_bandBridge {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p q : Smale.ManifoldMorse.criticalPoints E f)
+    (hpq : f p < f q)
+    (hconsecutive : ∀ r : Smale.ManifoldMorse.criticalPoints E f, ¬(f p < f r ∧ f r < f q)) :
+    letI := Smale.RegularLevel.chartedSpace hf (S.data p).upper_regular
+    letI := Smale.RegularLevel.chartedSpace hf (S.data q).lower_regular
+    ∃ D : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞,
+      ∃ e :
+        Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+          (S.data p).UpperLevel (S.data q).LowerLevel ∞,
+        D '' {x : M | f x ≤ f p + (S.data p).radius ^ 2} =
+            {x : M | f x ≤ f q - (S.data q).radius ^ 2} ∧
+          (∀ x, (e x : M) = D x) ∧ ∀ x, ∃ t, S.flow t x = D x :=
+  Degree.FlowTimeChange.exists_orbit_preserving_native_band_bridge hf S.smooth S.descent S.flow
+    S.integral (S.separated p q hpq).le (S.toSurgeryWindows.regular_between p q hconsecutive)
+    (S.data p).upper_regular (S.data q).lower_regular
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem AdaptedWindows.transported_attaching_basin_iff {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p q : Smale.ManifoldMorse.criticalPoints E f) (n : ℕ)
+    [Fact (Module.finrank ℝ (S.data q).chart.NegativeCoordinates = n + 1)]
+    (e : (S.data p).UpperLevel ≃ₜ (S.data q).LowerLevel)
+    (horbit : ∀ x : (S.data p).UpperLevel, ∃ t, S.flow t x = (e x : M))
+    (x : (S.data p).UpperLevel) :
+    Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 q.val) ↔
+      x ∈ Set.range ((S.data p).transportedAttachingSphere (S.data q) n e) := by
+  rw [(S.data p).range_transportedAttachingSphere (S.data q) n e]
+  change
+    Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 q.val) ↔
+      e x ∈ Set.range (S.data q).surgery.attachingSphere
+  rw [← S.attaching_basin_iff hf q (e x)]
+  obtain ⟨t, ht⟩ := horbit x
+  rw [← ht]
+  exact (MorseCancel.flow_time_atBot_limit_iff S.flow t (x : M) q.val).symm
+
+private theorem Degree.FlowSuspension.native_model_pullback_zero_iff {D E H X M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace H] [TopologicalSpace X] [ChartedSpace H X] {I : ModelWithCorners ℝ D H}
+    [TopologicalSpace M] [ChartedSpace E M] (e : PartialDiffeomorph 𝓘(ℝ, E) I M X ∞)
+    (W : (z : X) → TangentSpace I z) {x : M} (hx : x ∈ e.source) :
+    VectorField.mpullback 𝓘(ℝ, E) I e W x = 0 ↔ W (e x) = 0 := by
+  let e' := e.toOpenPartialHomeomorph
+  have he : e'.MDifferentiable 𝓘(ℝ, E) I :=
+    ⟨e.contMDiffOn.mdifferentiableOn (by simp), e.symm.contMDiffOn.mdifferentiableOn (by simp)⟩
+  let L := he.mfderiv hx
+  rw [VectorField.mpullback_apply]
+  change L.toContinuousLinearMap.inverse (W (e x)) = 0 ↔ W (e x) = 0
+  rw [ContinuousLinearMap.inverse_equiv]
+  constructor
+  · intro h
+    exact L.symm.injective (h.trans (map_zero L.symm).symm)
+  · intro h
+    rw [h]
+    exact map_zero L.symm
+
+private theorem Degree.FlowSuspension.contMDiffOn_native_model_pullback {D E H X M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace H] [TopologicalSpace X] [ChartedSpace H X] {I : ModelWithCorners ℝ D H}
+    [TopologicalSpace M] [ChartedSpace E M] [FiniteDimensional ℝ E] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [IsManifold I ∞ X] (e : PartialDiffeomorph 𝓘(ℝ, E) I M X ∞) (W : (z : X) → TangentSpace I z)
+    (hW : ContMDiff I I.tangent ∞ (fun z => (⟨z, W z⟩ : TangentBundle I X))) :
+    ContMDiffOn 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞
+      (fun x => (⟨x, VectorField.mpullback 𝓘(ℝ, E) I e W x⟩ : TangentBundle 𝓘(ℝ, E) M))
+      e.source := by
+  let e' := e.toOpenPartialHomeomorph
+  have he : e'.MDifferentiable 𝓘(ℝ, E) I :=
+    ⟨e.contMDiffOn.mdifferentiableOn (by simp), e.symm.contMDiffOn.mdifferentiableOn (by simp)⟩
+  intro x hx
+  have hinv : (mfderiv 𝓘(ℝ, E) I e x).IsInvertible := ⟨he.mfderiv hx, rfl⟩
+  exact
+    ((hW (e x)).mpullback_vectorField_preimage
+        (e.contMDiffOn_toFun.contMDiffAt (e.open_source.mem_nhds hx)) hinv
+        (by simp)).contMDiffWithinAt
+
+private theorem Degree.FlowSuspension.exists_native_model_field_replacement {D E H X M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace H] [TopologicalSpace X] [ChartedSpace H X] {I : ModelWithCorners ℝ D H}
+    [TopologicalSpace M] [ChartedSpace E M] [FiniteDimensional ℝ E] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [IsManifold I ∞ X] [T2Space M] (A : PartialDiffeomorph I 𝓘(ℝ, E) X M ∞)
+    (V : (y : M) → TangentSpace 𝓘(ℝ, E) y)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun y => (⟨y, V y⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (W₀ W : (z : X) → TangentSpace I z)
+    (hW : ContMDiff I I.tangent ∞ (fun z => (⟨z, W z⟩ : TangentBundle I X)))
+    (hmodel : ∀ y ∈ A.target, V y = VectorField.mpullback 𝓘(ℝ, E) I A.symm W₀ y)
+    (hregular₀ : ∀ z ∈ A.source, W₀ z ≠ 0) (hregular : ∀ z ∈ A.source, W z ≠ 0) {K : Set X}
+    (hK : IsCompact K) (hKA : K ⊆ A.source) (hfix : ∀ z ∉ K, W z = W₀ z) :
+    ∃ V' : (y : M) → TangentSpace 𝓘(ℝ, E) y,
+      ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun y => (⟨y, V' y⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+        (∀ y ∈ A.target, V' y = VectorField.mpullback 𝓘(ℝ, E) I A.symm W y) ∧
+          (∀ y, V' y = 0 ↔ V y = 0) ∧ ∀ y ∉ A '' K, ∀ᶠ z in 𝓝 y, V' z = V z := by
+  let Wn := VectorField.mpullback 𝓘(ℝ, E) I A.symm W
+  have hWn := contMDiffOn_native_model_pullback A.symm W hW
+  have hreg (y : M) (hy : y ∈ A.target) : Wn y ≠ 0 := fun h =>
+    hregular (A.symm y) (A.map_target' hy) ((native_model_pullback_zero_iff A.symm W hy).mp h)
+  have hregV (y : M) (hy : y ∈ A.target) : V y ≠ 0 := by
+    rw [hmodel y hy]
+    exact fun h =>
+      hregular₀ (A.symm y) (A.map_target' hy) ((native_model_pullback_zero_iff A.symm W₀ hy).mp h)
+  have hkeep (y : M) (hy : y ∈ A.target) (hout : y ∉ A '' K) : Wn y = V y := by
+    have hn : A.symm y ∉ K := fun h => hout ⟨A.symm y, h, A.right_inv' hy⟩
+    rw [hmodel y hy]
+    change
+      VectorField.mpullback 𝓘(ℝ, E) I A.symm W y = VectorField.mpullback 𝓘(ℝ, E) I A.symm W₀ y
+    rw [VectorField.mpullback_apply, VectorField.mpullback_apply, hfix (A.symm y) hn]
+  obtain ⟨V', hV', hnew, hzero, hgerm⟩ :=
+    Degree.LocalFieldReplacement.exists_smooth_field_replacement A V Wn hV hWn hK hKA hkeep hreg
+  refine ⟨V', hV', hnew, ?_, hgerm⟩
+  intro y
+  exact (hzero y).trans ⟨And.left, fun hy => ⟨hy, fun ht => hregV y ht hy⟩⟩
+
+private theorem
+    Degree.FlowSuspension.native_chart_flow_all_time {B M : Type*} [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [TopologicalSpace M] [ChartedSpace B M] [IsManifold 𝓘(ℝ, B) 1 M] [T2Space M]
+    {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] {V : (x : M) → TangentSpace 𝓘(ℝ, B) x}
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, B) E M ∞)
+    (hV : ContMDiff 𝓘(ℝ, B) (𝓘(ℝ, B).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, B) M)))
+    (G : Flow ℝ M) (hG : ∀ x, IsMIntegralCurve (fun t => G t x) V) (F : Flow ℝ E) (W : E → E)
+    (hF : ∀ p t, HasDerivAt (fun s => F s p) (W (F t p)) t)
+    (hmodel : ∀ x ∈ Φ.target, V x = Smale.FlowConstruction.partialChartField Φ.symm W x) {p : E}
+    (hstay : ∀ t, F t p ∈ Φ.source) : ∀ t, G t (Φ p) = Φ (F t p) := by
+  let γ : ℝ → M := fun t => Φ (F t p)
+  have hγ : IsMIntegralCurve γ V := by
+    intro t
+    have hd :=
+      Smale.FlowConstruction.hasMFDerivAt_lift_partialChartCurve Φ.symm W (hF p t) (hstay t)
+    have hy := Φ.map_source' (hstay t)
+    have hd' :
+      HasMFDerivAt 𝓘(ℝ, ℝ) 𝓘(ℝ, B) γ t
+        ((1 : ℝ →L[ℝ] ℝ).smulRight (Smale.FlowConstruction.partialChartField Φ.symm W (γ t))) :=
+      hd
+    rw [← hmodel (γ t) hy] at hd'
+    exact hd'
+  have heq :=
+    isMIntegralCurve_Ioo_eq_of_contMDiff_boundaryless hV (hG (Φ p)) hγ (t₀ := 0)
+      (by simp only [γ, G.map_zero_apply, F.map_zero_apply])
+  exact fun t => congrFun heq t
+
+private theorem
+    Degree.FlowSuspension.native_chart_target_invariant {B M : Type*} [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [TopologicalSpace M] [ChartedSpace B M] [IsManifold 𝓘(ℝ, B) 1 M] [T2Space M]
+    {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] {V : (x : M) → TangentSpace 𝓘(ℝ, B) x}
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, B) E M ∞)
+    (hV : ContMDiff 𝓘(ℝ, B) (𝓘(ℝ, B).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, B) M)))
+    (G : Flow ℝ M) (hG : ∀ x, IsMIntegralCurve (fun t => G t x) V) (F : Flow ℝ E) (W : E → E)
+    (hF : ∀ p t, HasDerivAt (fun s => F s p) (W (F t p)) t)
+    (hmodel : ∀ x ∈ Φ.target, V x = Smale.FlowConstruction.partialChartField Φ.symm W x)
+    (hstay : ∀ p ∈ Φ.source, ∀ t, F t p ∈ Φ.source) : ∀ x ∈ Φ.target, ∀ t, G t x ∈ Φ.target := by
+  intro x hx t
+  have hp := Φ.map_target' hx
+  have heq := native_chart_flow_all_time Φ hV G hG F W hF hmodel (hstay _ hp) t
+  rw [Φ.right_inv' hx] at heq
+  rw [heq]
+  exact Φ.map_source' (hstay _ hp t)
+
+private theorem Degree.FlowSuspension.flow_complement_invariant {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {S : Set X} (hS : ∀ x ∈ S, ∀ t, F t x ∈ S) : ∀ x ∉ S, ∀ t, F t x ∉ S := by
+  intro x hx t ht
+  have hh := hS (F t x) ht (-t)
+  rw [← F.map_add, neg_add_cancel, F.map_zero_apply] at hh
+  exact hx hh
+
+private theorem Degree.FlowSuspension.native_model_pullback_eq_mfderiv_symm {D E H X M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace H] [TopologicalSpace X] [ChartedSpace H X] {I : ModelWithCorners ℝ D H}
+    [TopologicalSpace M] [ChartedSpace E M] (e : PartialDiffeomorph 𝓘(ℝ, E) I M X ∞)
+    (W : (z : X) → TangentSpace I z) {x : M} (hx : x ∈ e.source) :
+    VectorField.mpullback 𝓘(ℝ, E) I e W x = mfderiv I 𝓘(ℝ, E) e.symm (e x) (W (e x)) := by
+  let e' := e.toOpenPartialHomeomorph
+  have he : e'.MDifferentiable 𝓘(ℝ, E) I :=
+    ⟨e.contMDiffOn.mdifferentiableOn (by simp), e.symm.contMDiffOn.mdifferentiableOn (by simp)⟩
+  have h₁ := he.comp_symm_deriv (e'.map_source hx)
+  rw [e'.left_inv hx] at h₁
+  have hi := ContinuousLinearMap.inverse_eq h₁ (he.symm_comp_deriv hx)
+  rw [VectorField.mpullback_apply]
+  change (mfderiv 𝓘(ℝ, E) I e' x).inverse (W (e' x)) = _
+  rw [hi]
+  rfl
+
+private theorem Degree.FlowSuspension.hasMFDerivAt_lift_native_model_curve {D E H X M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace H] [TopologicalSpace X] [ChartedSpace H X] {I : ModelWithCorners ℝ D H}
+    [TopologicalSpace M] [ChartedSpace E M] (e : PartialDiffeomorph 𝓘(ℝ, E) I M X ∞)
+    (W : (z : X) → TangentSpace I z) {α : ℝ → X} {t : ℝ}
+    (hα : HasMFDerivAt 𝓘(ℝ, ℝ) I α t ((1 : ℝ →L[ℝ] ℝ).smulRight (W (α t))))
+    (ht : α t ∈ e.target) :
+    HasMFDerivAt 𝓘(ℝ, ℝ) 𝓘(ℝ, E) (e.symm ∘ α) t
+      ((1 : ℝ →L[ℝ] ℝ).smulRight (VectorField.mpullback 𝓘(ℝ, E) I e W (e.symm (α t)))) := by
+  have hi :=
+    (e.symm.contMDiffOn_toFun.contMDiffAt (e.open_target.mem_nhds ht)).mdifferentiableAt (by simp)
+  have hd := hi.hasMFDerivAt.comp t hα
+  apply hd.congr_mfderiv
+  apply ContinuousLinearMap.ext
+  intro a
+  let s : ℝ := a
+  change
+    (mfderiv I 𝓘(ℝ, E) e.symm (α t)) (s • W (α t)) =
+      s • VectorField.mpullback 𝓘(ℝ, E) I e W (e.symm (α t))
+  rw [map_smul]
+  have hp := native_model_pullback_eq_mfderiv_symm e W (x := e.symm (α t)) (e.map_target' ht)
+  have hr : e (e.symm (α t)) = α t := e.right_inv' ht
+  rw [hr] at hp
+  exact congrArg (fun v : TangentSpace 𝓘(ℝ, E) (e.symm (α t)) => s • v) hp.symm
+
+private theorem Degree.FlowSuspension.native_model_flow_all_time {D E H X M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace H] [TopologicalSpace X] [ChartedSpace H X] {I : ModelWithCorners ℝ D H}
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (A : PartialDiffeomorph I 𝓘(ℝ, E) X M ∞)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (G : Flow ℝ M) (hG : ∀ x, IsMIntegralCurve (fun t => G t x) V) (F : Flow ℝ X)
+    (W : (z : X) → TangentSpace I z) (hF : ∀ p, IsMIntegralCurve (fun t => F t p) W)
+    (hmodel : ∀ x ∈ A.target, V x = VectorField.mpullback 𝓘(ℝ, E) I A.symm W x) {p : X}
+    (hstay : ∀ t, F t p ∈ A.source) : ∀ t, G t (A p) = A (F t p) := by
+  let γ : ℝ → M := fun t => A (F t p)
+  have hγ : IsMIntegralCurve γ V := by
+    intro t
+    have hd := hasMFDerivAt_lift_native_model_curve A.symm W (hF p t) (hstay t)
+    have hd' :
+      HasMFDerivAt 𝓘(ℝ, ℝ) 𝓘(ℝ, E) γ t
+        ((1 : ℝ →L[ℝ] ℝ).smulRight (VectorField.mpullback 𝓘(ℝ, E) I A.symm W (γ t))) :=
+      hd
+    rw [← hmodel (γ t) (A.map_source' (hstay t))] at hd'
+    exact hd'
+  have heq :=
+    isMIntegralCurve_Ioo_eq_of_contMDiff_boundaryless hV (hG (A p)) hγ (t₀ := 0)
+      (by simp only [γ, G.map_zero_apply, F.map_zero_apply])
+  exact fun t => congrFun heq t
+
+private theorem Degree.FlowSuspension.native_model_target_invariant {D E H X M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace H] [TopologicalSpace X] [ChartedSpace H X] {I : ModelWithCorners ℝ D H}
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (A : PartialDiffeomorph I 𝓘(ℝ, E) X M ∞)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (G : Flow ℝ M) (hG : ∀ x, IsMIntegralCurve (fun t => G t x) V) (F : Flow ℝ X)
+    (W : (z : X) → TangentSpace I z) (hF : ∀ p, IsMIntegralCurve (fun t => F t p) W)
+    (hmodel : ∀ x ∈ A.target, V x = VectorField.mpullback 𝓘(ℝ, E) I A.symm W x)
+    (hstay : ∀ p ∈ A.source, ∀ t, F t p ∈ A.source) : ∀ x ∈ A.target, ∀ t, G t x ∈ A.target := by
+  intro x hx t
+  have hp := A.map_target' hx
+  have heq := native_model_flow_all_time A hV G hG F W hF hmodel (hstay _ hp) t
+  rw [A.right_inv' hx] at heq
+  rw [heq]
+  exact A.map_source' (hstay _ hp t)
+
+private theorem
+    Degree.FlowSuspension.exists_native_base_suspension {Z N : Type*} [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [TopologicalSpace N] [ChartedSpace Z N]
+    [IsManifold 𝓘(ℝ, Z) ∞ N] (D : Diffeomorph 𝓘(ℝ, Z) 𝓘(ℝ, Z) N N ∞) {K S : Set N}
+    (I : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy D K S) :
+    ∃ Ψ : Diffeomorph (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (N × ℝ) (N × ℝ) ∞,
+      (∀ p, (Ψ p).2 = p.2) ∧
+        (∀ p, p.2 ≤ 1 / 3 → Ψ p = p) ∧
+          (∀ p, 2 / 3 ≤ p.2 → Ψ p = (D p.1, p.2)) ∧
+            (∀ p, p.1 ∉ K → Ψ p = p) ∧ ∀ p, p.1 ∈ S → Ψ p = p := by
+  let τ : ℝ → ℝ := fun t => Real.smoothTransition (3 * t - 1)
+  have hτ : ContDiff ℝ ∞ τ :=
+    Real.smoothTransition.contDiff.comp ((contDiff_const.mul contDiff_id).sub contDiff_const)
+  have hlow (t : ℝ) (ht : t ≤ 1 / 3) : τ t = 0 :=
+    Real.smoothTransition.zero_of_nonpos (by linarith)
+  have hhigh (t : ℝ) (ht : 2 / 3 ≤ t) : τ t = 1 :=
+    Real.smoothTransition.one_of_one_le (by linarith)
+  let A : N × ℝ → N := fun p => I.family (τ p.2, p.1)
+  have hA : ContMDiff (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, Z) ∞ A :=
+    I.smooth.comp ((hτ.contMDiff.comp contMDiff_snd).prodMk contMDiff_fst)
+  have hslice : ∀ t, ∃ d : Diffeomorph 𝓘(ℝ, Z) 𝓘(ℝ, Z) N N ∞, ∀ x, d x = A (x, t) := fun t =>
+    I.slices (τ t)
+  let Ψ := Smale.FiberwiseDiffeomorph.diffeomorph hA hslice
+  have hmap (p : N × ℝ) : Ψ p = (I.family (τ p.2, p.1), p.2) := rfl
+  refine ⟨Ψ, fun _ => rfl, ?_, ?_, ?_, ?_⟩
+  · intro p hp
+    rw [hmap, hlow p.2 hp, I.zero]
+  · intro p hp
+    rw [hmap, hhigh p.2 hp, I.one]
+  · intro p hp
+    rw [hmap, I.fixedOutside (τ p.2) p.1 hp]
+  · intro p hp
+    rw [hmap, I.fixedOn (τ p.2) p.1 hp]
+
+private def Degree.FlowSuspension.nativeSuspensionFlow {Z N : Type*} [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [TopologicalSpace N] [ChartedSpace Z N]
+    (Ψ : Diffeomorph (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (N × ℝ) (N × ℝ) ∞) :
+    Flow ℝ (N × ℝ) where
+  toFun t p := Ψ ((Ψ.symm p).1, (Ψ.symm p).2 + t)
+  cont' :=
+    Ψ.continuous.comp
+      ((Ψ.symm.continuous.comp continuous_snd).fst.prodMk
+        ((Ψ.symm.continuous.comp continuous_snd).snd.add continuous_fst))
+  map_zero' p := by simp only [add_zero, Prod.mk.eta, Ψ.apply_symm_apply]
+  map_add' s t
+    p := by
+    simp only [Ψ.symm_apply_apply]
+    congr 1
+    apply Prod.ext
+    · rfl
+    · ring
+
+private theorem
+    Degree.FlowSuspension.nativeSuspensionFlow_chart {Z N : Type*} [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [TopologicalSpace N] [ChartedSpace Z N]
+    (Ψ : Diffeomorph (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (N × ℝ) (N × ℝ) ∞) (t : ℝ)
+    (p : N × ℝ) : nativeSuspensionFlow Ψ t (Ψ p) = Ψ (p.1, p.2 + t) := by
+  change Ψ ((Ψ.symm (Ψ p)).1, (Ψ.symm (Ψ p)).2 + t) = _
+  rw [Ψ.symm_apply_apply]
+
+private def Degree.FlowSuspension.nativeVerticalField {Z N : Type*} [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [TopologicalSpace N] [ChartedSpace Z N] (p : N × ℝ) :
+    TangentSpace (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) p :=
+  (show Z × ℝ from (0, 1))
+
+private theorem
+    Degree.FlowSuspension.contMDiff_nativeVerticalField {Z N : Type*} [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [TopologicalSpace N] [ChartedSpace Z N]
+    [IsManifold 𝓘(ℝ, Z) ∞ N] :
+    ContMDiff (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)).tangent ∞
+      (fun p : N × ℝ =>
+        (⟨p, nativeVerticalField p⟩ : TangentBundle (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (N × ℝ))) := by
+  have hz :
+    ContMDiff 𝓘(ℝ, Z) (𝓘(ℝ, Z).tangent) ∞
+      (fun x : N => (⟨x, (0 : Z)⟩ : TangentBundle 𝓘(ℝ, Z) N)) :=
+    Bundle.contMDiff_zeroSection ℝ (TangentSpace 𝓘(ℝ, Z) : N → Type _)
+  have ho :
+    ContMDiff 𝓘(ℝ, ℝ) (𝓘(ℝ, ℝ).tangent) ∞
+      (fun t : ℝ => (⟨t, (1 : ℝ)⟩ : TangentBundle 𝓘(ℝ, ℝ) ℝ)) := by
+    have hpair :
+      ContMDiff 𝓘(ℝ, ℝ) (𝓘(ℝ, ℝ).tangent) ∞ (fun t : ℝ => (show ModelProd ℝ ℝ from (t, 1))) := by
+      unfold ModelWithCorners.tangent
+      rw [← modelWithCornersSelf_prod]
+      exact (contDiff_id.prodMk contDiff_const).contMDiff
+    exact (contMDiff_tangentBundleModelSpaceHomeomorph_symm (I := 𝓘(ℝ, ℝ)) (n := ∞)).comp hpair
+  have hp :=
+    (contMDiff_equivTangentBundleProd_symm (I := 𝓘(ℝ, Z)) (I' := 𝓘(ℝ, ℝ)) (M := N) (M' := ℝ) (n :=
+          ∞)).comp
+      ((hz.comp contMDiff_fst).prodMk (ho.comp contMDiff_snd))
+  exact hp
+
+private def Degree.FlowSuspension.nativeSuspensionField {Z N : Type*} [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [TopologicalSpace N] [ChartedSpace Z N]
+    (Ψ : Diffeomorph (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (N × ℝ) (N × ℝ) ∞)
+    (p : N × ℝ) : TangentSpace (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) p :=
+  mfderiv (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) Ψ (Ψ.symm p)
+    (nativeVerticalField (Ψ.symm p))
+
+private theorem
+    Degree.FlowSuspension.contMDiff_nativeSuspensionField {Z N : Type*} [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [TopologicalSpace N] [ChartedSpace Z N]
+    [IsManifold 𝓘(ℝ, Z) ∞ N]
+    (Ψ : Diffeomorph (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (N × ℝ) (N × ℝ) ∞) :
+    ContMDiff (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)).tangent ∞
+      (fun p : N × ℝ =>
+        (⟨p, nativeSuspensionField Ψ p⟩ : TangentBundle (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (N × ℝ))) := by
+  have ht :=
+    (Ψ.contMDiff.contMDiff_tangentMap (m := ∞) (by simp)).comp
+      (contMDiff_nativeVerticalField.comp Ψ.symm.contMDiff)
+  convert! ht using 1
+  funext p
+  apply Bundle.TotalSpace.ext (Ψ.apply_symm_apply p).symm
+  rfl
+
+private theorem Degree.FlowSuspension.nativeVerticalField_integralCurve {Z N : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [TopologicalSpace N]
+    [ChartedSpace Z N] (p : N × ℝ) :
+    IsMIntegralCurve (fun t : ℝ => (p.1, p.2 + t)) (nativeVerticalField (Z := Z)) := by
+  intro t
+  have hn : HasMFDerivAt 𝓘(ℝ, ℝ) 𝓘(ℝ, Z) (fun _ : ℝ => p.1) t (0 : ℝ →L[ℝ] Z) :=
+    hasMFDerivAt_const p.1 t
+  have ht :=
+    (hasMFDerivAt_const (I := 𝓘(ℝ, ℝ)) (I' := 𝓘(ℝ, ℝ)) p.2 t).add
+      (hasMFDerivAt_id (I := 𝓘(ℝ, ℝ)) t)
+  apply (hn.prodMk ht).congr_mfderiv
+  apply ContinuousLinearMap.ext
+  intro r
+  let s : ℝ := r
+  change ((0 : Z), (0 : ℝ) + s) = s • ((0 : Z), (1 : ℝ))
+  simp
+
+private theorem Degree.FlowSuspension.nativeSuspensionFlow_integralCurve {Z N : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [TopologicalSpace N]
+    [ChartedSpace Z N]
+    (Ψ : Diffeomorph (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (N × ℝ) (N × ℝ) ∞)
+    (p : N × ℝ) :
+    IsMIntegralCurve (fun t : ℝ => nativeSuspensionFlow Ψ t p) (nativeSuspensionField Ψ) := by
+  intro t
+  let γ : ℝ → N × ℝ := fun s => ((Ψ.symm p).1, (Ψ.symm p).2 + s)
+  have hb := nativeVerticalField_integralCurve (Z := Z) (Ψ.symm p) t
+  have hd := (Ψ.contMDiff.mdifferentiableAt (by simp)).hasMFDerivAt.comp (f := γ) t hb
+  change
+    HasMFDerivAt 𝓘(ℝ, ℝ) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (fun s => Ψ (γ s)) t
+      ((1 : ℝ →L[ℝ] ℝ).smulRight
+        (mfderiv (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) Ψ (Ψ.symm (Ψ (γ t)))
+          (nativeVerticalField (Ψ.symm (Ψ (γ t))))))
+  rw [Ψ.symm_apply_apply]
+  change
+    HasMFDerivAt 𝓘(ℝ, ℝ) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (fun s => Ψ (γ s)) t
+      ((mfderiv (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) Ψ (γ t)).comp
+        ((1 : ℝ →L[ℝ] ℝ).smulRight (nativeVerticalField (γ t)))) at hd
+  apply hd.congr_mfderiv
+  apply ContinuousLinearMap.ext
+  intro r
+  exact
+    (mfderiv (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) Ψ (γ t)).map_smul (r : ℝ)
+      (nativeVerticalField (γ t))
+
+private theorem
+    Degree.FlowSuspension.nativeSuspensionFlow_height {Z N : Type*} [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [TopologicalSpace N] [ChartedSpace Z N]
+    (Ψ : Diffeomorph (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (N × ℝ) (N × ℝ) ∞)
+    (hheight : ∀ p, (Ψ p).2 = p.2) (t : ℝ) (p : N × ℝ) :
+    (nativeSuspensionFlow Ψ t p).2 = p.2 + t := by
+  have hi : (Ψ.symm p).2 = p.2 := by
+    have hh := hheight (Ψ.symm p)
+    rw [Ψ.apply_symm_apply] at hh
+    exact hh.symm
+  change (Ψ ((Ψ.symm p).1, (Ψ.symm p).2 + t)).2 = p.2 + t
+  rw [hheight, hi]
+
+private theorem Degree.FlowSuspension.native_level_flow_chart_vertical {Z E N M : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace N] [ChartedSpace Z N]
+    [TopologicalSpace M] [ChartedSpace E M] {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (A : PartialDiffeomorph (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) (N × ℝ) M ∞) (F : Flow ℝ M)
+    (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) (ι : N → M)
+    (hformula : ∀ p : N × ℝ, A p = F p.2 (ι p.1)) :
+    ∀ x ∈ A.target,
+      V x = VectorField.mpullback 𝓘(ℝ, E) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) A.symm nativeVerticalField x := by
+  intro x hx
+  let p := A.symm x
+  have hp : p ∈ A.source := A.map_target' hx
+  let α : ℝ → N × ℝ := fun t => (p.1, t)
+  have hα :
+    HasMFDerivAt 𝓘(ℝ, ℝ) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) α p.2
+      ((1 : ℝ →L[ℝ] ℝ).smulRight (nativeVerticalField (α p.2))) := by
+    have hn : HasMFDerivAt 𝓘(ℝ, ℝ) 𝓘(ℝ, Z) (fun _ : ℝ => p.1) p.2 (0 : ℝ →L[ℝ] Z) :=
+      hasMFDerivAt_const p.1 p.2
+    apply (hn.prodMk (hasMFDerivAt_id (I := 𝓘(ℝ, ℝ)) p.2)).congr_mfderiv
+    apply ContinuousLinearMap.ext
+    intro r
+    let u : ℝ := r
+    change ((0 : Z), u) = u • ((0 : Z), (1 : ℝ))
+    simp
+  have hd := hasMFDerivAt_lift_native_model_curve A.symm nativeVerticalField hα hp
+  have heq : A.symm.symm ∘ α = fun t => F t (ι p.1) := funext (fun t => hformula (p.1, t))
+  rw [heq] at hd
+  change
+    HasMFDerivAt 𝓘(ℝ, ℝ) 𝓘(ℝ, E) (fun t => F t (ι p.1)) p.2
+      ((1 : ℝ →L[ℝ] ℝ).smulRight
+        (VectorField.mpullback 𝓘(ℝ, E) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) A.symm nativeVerticalField
+          (A p))) at hd
+  rw [hformula p] at hd
+  have hpF : F p.2 (ι p.1) = x := (hformula p).symm.trans (A.right_inv' hx)
+  have hh := (hcurve (ι p.1) p.2).mfderiv.symm.trans hd.mfderiv
+  have hv := congrArg (fun L : ℝ →L[ℝ] TangentSpace 𝓘(ℝ, E) (F p.2 (ι p.1)) => L (1 : ℝ)) hh
+  simp only [ContinuousLinearMap.smulRight_apply, one_apply_eq_self, one_smul] at hv
+  change
+    V (F p.2 (ι p.1)) =
+      VectorField.mpullback 𝓘(ℝ, E) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) A.symm nativeVerticalField
+        (F p.2 (ι p.1)) at hv
+  rw [hpF] at hv
+  exact hv
+
+private theorem Degree.FlowSuspension.exists_native_level_flow_cylinder_with_field {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} [FiniteDimensional ℝ E] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [CompactSpace M] {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {c : ℝ}
+    (hreg : ∀ x, f x = c → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hboundary : ∀ x, f x = c → mvfderiv 𝓘(ℝ, E) f x (V x) < 0) (z : { x : M // f x = c }) :
+    letI := Smale.RegularLevel.chartedSpace hf hreg
+    ∃ A :
+      PartialDiffeomorph (𝓘(ℝ, Smale.RegularLevel.Model E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E)
+        ({ x : M // f x = c } × ℝ) M ∞,
+      A.source = Set.univ ∧
+        A.target = Degree.FlowCancellation.levelBasin F f c ∧
+          (∀ p, A p = F p.2 p.1) ∧
+            ∀ x ∈ A.target,
+              V x =
+                VectorField.mpullback 𝓘(ℝ, E) (𝓘(ℝ, Smale.RegularLevel.Model E).prod 𝓘(ℝ, ℝ))
+                  A.symm nativeVerticalField x := by
+  let _ := Smale.RegularLevel.chartedSpace hf hreg
+  let _ := Smale.RegularLevel.isManifold hf hreg
+  obtain ⟨A, hsource, htarget, hformula, -⟩ :=
+    Degree.FlowCancellation.exists_native_level_flow_cylinder hf hreg hV F hcurve hboundary z
+  exact
+    ⟨A, hsource, htarget, hformula,
+      native_level_flow_chart_vertical A F hcurve Subtype.val hformula⟩
+
+private theorem Degree.FlowTimeChange.mfderiv_height_div_const {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {x : M}
+    (hf : MDifferentiableAt 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f x) (r : ℝ) :
+    mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) (fun y => f y / r) x = r⁻¹ • mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f x := by
+  have heq : (fun y => f y / r) = r⁻¹ • f := by
+    ext y
+    simp only [Pi.smul_apply, smul_eq_mul, div_eq_mul_inv, mul_comm]
+  rw [heq]
+  exact (hf.hasMFDerivAt.const_smul r⁻¹).mfderiv
+
+private theorem Degree.FlowTimeChange.mvfderiv_height_div_const {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {x : M}
+    (hf : MDifferentiableAt 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f x) (r : ℝ) (v : TangentSpace 𝓘(ℝ, E) x) :
+    mvfderiv 𝓘(ℝ, E) (fun y => f y / r) x v = mvfderiv 𝓘(ℝ, E) f x v / r := by
+  have heq : (fun y => f y / r) = (fun y => r⁻¹ * f y) := by
+    ext y
+    simp only [div_eq_mul_inv, mul_comm]
+  rw [heq, mvfderiv_fun_mul mdifferentiableAt_const hf]
+  have hconst : mvfderiv 𝓘(ℝ, E) (fun _ : M => r⁻¹) x = 0 := by simp [mvfderiv, mfderiv_const]
+  simp [hconst, div_eq_mul_inv, mul_comm]
+
+private theorem
+    Degree.FlowTimeChange.criticalPoints_height_div_const {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {r : ℝ} (hr : r ≠ 0) :
+    Smale.ManifoldMorse.criticalPoints E (fun y => f y / r) =
+      Smale.ManifoldMorse.criticalPoints E f := by
+  ext x
+  change mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) (fun y => f y / r) x = 0 ↔ mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f x = 0
+  rw [mfderiv_height_div_const (hf.mdifferentiableAt (by simp))]
+  exact smul_eq_zero.trans (or_iff_right (inv_ne_zero hr))
+
+private theorem
+    Degree.FlowTimeChange.descending_height_div_const_iff {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {x : M}
+    (hf : MDifferentiableAt 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f x) {r : ℝ} (hr : 0 < r)
+    (v : TangentSpace 𝓘(ℝ, E) x) :
+    mvfderiv 𝓘(ℝ, E) (fun y => f y / r) x v < 0 ↔ mvfderiv 𝓘(ℝ, E) f x v < 0 := by
+  rw [mvfderiv_height_div_const hf r]
+  rw [div_lt_iff₀ hr, MulZeroClass.zero_mul]
+
+private theorem Degree.FlowTimeChange.exists_normalized_whole_level_cylinder {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun y => (⟨y, V y⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hdesc : ∀ y, y ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f y (V y) < 0)
+    (F : Flow ℝ M) (hF : ∀ y, IsMIntegralCurve (fun t => F t y) V) {a b c : ℝ} (ha : a < c)
+    (hb : c < b) (hband : ∀ y, f y ∈ Set.Icc a b → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hreg : ∀ y, f y = c → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (z : { y : M // f y = c }) :
+    letI := Smale.RegularLevel.chartedSpace hf hreg
+    ∃ (r : ℝ) (W : (y : M) → TangentSpace 𝓘(ℝ, E) y) (G : Flow ℝ M) (A :
+      PartialDiffeomorph (𝓘(ℝ, Smale.RegularLevel.Model E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E)
+        ({ y : M // f y = c } × ℝ) M ∞),
+      0 < r ∧
+        r < c - a ∧
+          ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun y => (⟨y, W y⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+            (∀ y, IsMIntegralCurve (fun t => G t y) W) ∧
+              (∀ y, W y = 0 ↔ V y = 0) ∧
+                (∀ y,
+                    y ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f y (W y) < 0) ∧
+                  (∀ y ∈ Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ x in 𝓝 y, W x = V x) ∧
+                    (∀ y,
+                        Set.range (fun t => G t y) = Set.range (fun t => F t y) ∧
+                          (∀ p,
+                              Filter.Tendsto (fun t => G t y) Filter.atTop (𝓝 p) ↔
+                                Filter.Tendsto (fun t => F t y) Filter.atTop (𝓝 p)) ∧
+                            ∀ p,
+                              Filter.Tendsto (fun t => G t y) Filter.atBot (𝓝 p) ↔
+                                Filter.Tendsto (fun t => F t y) Filter.atBot (𝓝 p)) ∧
+                      A.source = Set.univ ∧
+                        A.target = Degree.FlowCancellation.levelBasin G f c ∧
+                          (∀ p, A p = G p.2 p.1) ∧
+                            (∀ p, p.2 ∈ Set.Icc (0 : ℝ) 1 → f (A p) = c - r * p.2) ∧
+                              ∀ y ∈ A.target,
+                                W y =
+                                  VectorField.mpullback 𝓘(ℝ, E)
+                                    (𝓘(ℝ, Smale.RegularLevel.Model E).prod 𝓘(ℝ, ℝ)) A.symm
+                                    Degree.FlowSuspension.nativeVerticalField y := by
+  let _ := Smale.RegularLevel.chartedSpace hf hreg
+  let _ := Smale.RegularLevel.isManifold hf hreg
+  let r : ℝ := (c - a) / 2
+  have hr : 0 < r := div_pos (sub_pos.mpr ha) (by norm_num)
+  have hrbound : r < c - a := by dsimp [r]; linarith
+  let g : M → ℝ := fun y => f y / r
+  have hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g := hf.div_const r
+  have hcrit : Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f :=
+    criticalPoints_height_div_const hf hr.ne'
+  have hdescent :
+    ∀ y, y ∉ Smale.ManifoldMorse.criticalPoints E g → mvfderiv 𝓘(ℝ, E) g y (V y) < 0 := by
+    intro y hy
+    rw [hcrit] at hy
+    exact
+      (descending_height_div_const_iff (hf.mdifferentiableAt (by simp)) hr (V y)).mpr (hdesc y hy)
+  have hregular :
+    ∀ y, g y ∈ Set.Icc (a / r) (b / r) → y ∉ Smale.ManifoldMorse.criticalPoints E g := by
+    intro y hy
+    rw [hcrit]
+    exact
+      hband y ⟨(div_le_div_iff_of_pos_right hr).mp hy.1, (div_le_div_iff_of_pos_right hr).mp hy.2⟩
+  obtain ⟨U, W, G, hU, hIU, hW, hG, hzero, hneg, hspeed, hgerm, -, hgeometry⟩ :=
+    exists_orbit_preserving_band_normalization hg hV hdescent F hF hregular
+  have hnegf (y : M) (hy : y ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    mvfderiv 𝓘(ℝ, E) f y (W y) < 0 :=
+    (descending_height_div_const_iff (hf.mdifferentiableAt (by simp)) hr (W y)).mp
+      (hneg y (hcrit ▸ hy))
+  obtain ⟨A, hsource, htarget, hformula, hfield⟩ :=
+    Degree.FlowSuspension.exists_native_level_flow_cylinder_with_field hf hreg hW G hG
+      (fun y hy => hnegf y (hreg y hy)) z
+  have hc : c / r ∈ Set.Icc (a / r) (b / r) :=
+    ⟨div_le_div_of_nonneg_right ha.le hr.le, div_le_div_of_nonneg_right hb.le hr.le⟩
+  refine
+    ⟨r, W, G, A, hr, hrbound, hW, hG, hzero, hnegf, (fun y hy => hgerm y (hcrit ▸ hy)), hgeometry,
+      hsource, htarget, hformula, ?_, hfield⟩
+  intro p ht
+  have hi : g p.1 = c / r := by change f p.1 / r = c / r; rw [p.1.property]
+  have he : c / r - p.2 = (c - r * p.2) / r := by field_simp
+  have hend : g p.1 - p.2 ∈ Set.Icc (a / r) (b / r) := by
+    rw [hi, he]
+    constructor
+    · apply div_le_div_of_nonneg_right _ hr.le
+      nlinarith [ht.2]
+    · apply div_le_div_of_nonneg_right _ hr.le
+      nlinarith [mul_nonneg hr.le ht.1]
+  have hh := native_local_height_translation hg G hG hU hIU hspeed p.1 p.2 (hi ▸ hc) hend
+  rw [hi, he] at hh
+  rw [hformula]
+  exact (div_left_inj' hr.ne').mp hh
+
+private theorem
+    Degree.FlowSuspension.nativeSuspensionField_height {Z N : Type*} [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [TopologicalSpace N] [ChartedSpace Z N]
+    (Ψ : Diffeomorph (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (N × ℝ) (N × ℝ) ∞)
+    (hheight : ∀ p, (Ψ p).2 = p.2) (p : N × ℝ) : (nativeSuspensionField Ψ p).2 = 1 := by
+  let q := Ψ.symm p
+  have hproj : (Prod.snd : N × ℝ → ℝ) ∘ Ψ = Prod.snd := funext hheight
+  have hc :=
+    mfderiv_comp q
+      (show MDifferentiableAt (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, ℝ) (Prod.snd : N × ℝ → ℝ) (Ψ q) from
+        mdifferentiableAt_snd)
+      (Ψ.contMDiff.mdifferentiableAt (by simp))
+  rw [hproj, mfderiv_snd, mfderiv_snd] at hc
+  have hv := congrArg (fun L : (Z × ℝ) →L[ℝ] ℝ => L (0, 1)) hc
+  change (1 : ℝ) = (nativeSuspensionField Ψ p).2 at hv
+  exact hv.symm
+
+private theorem
+    Degree.FlowSuspension.nativeSuspensionField_ne_zero {Z N : Type*} [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [TopologicalSpace N] [ChartedSpace Z N]
+    (Ψ : Diffeomorph (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (N × ℝ) (N × ℝ) ∞)
+    (hheight : ∀ p, (Ψ p).2 = p.2) (p : N × ℝ) : nativeSuspensionField Ψ p ≠ 0 := by
+  intro hz
+  have hh := congrArg (fun v : Z × ℝ => v.2) hz
+  rw [nativeSuspensionField_height Ψ hheight p] at hh
+  exact one_ne_zero hh
+
+private theorem Degree.FlowSuspension.nativeSuspensionField_eq_vertical_of_flow_germ {Z N : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [TopologicalSpace N]
+    [ChartedSpace Z N]
+    (Ψ : Diffeomorph (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (N × ℝ) (N × ℝ) ∞) (p : N × ℝ)
+    (heq : (fun t : ℝ => nativeSuspensionFlow Ψ t p) =ᶠ[𝓝 0] (fun t : ℝ => (p.1, p.2 + t))) :
+    nativeSuspensionField Ψ p = nativeVerticalField p := by
+  have hw := nativeSuspensionFlow_integralCurve Ψ p 0
+  have hv := nativeVerticalField_integralCurve (Z := Z) p 0
+  have hh := hw.mfderiv.symm.trans (heq.mfderiv_eq.trans hv.mfderiv)
+  have hval := congrArg (fun L : ℝ →L[ℝ] (Z × ℝ) => L 1) hh
+  change
+    (1 : ℝ) • nativeSuspensionField Ψ (nativeSuspensionFlow Ψ 0 p) =
+      (1 : ℝ) • nativeVerticalField (p.1, p.2 + 0) at hval
+  have h0 : nativeSuspensionFlow Ψ (0 : ℝ) p = p := by
+    change Ψ ((Ψ.symm p).1, (Ψ.symm p).2 + 0) = p
+    rw [add_zero, Prod.mk.eta, Ψ.apply_symm_apply]
+  rw [one_smul, one_smul, h0] at hval
+  convert! hval using 1
+
+private theorem Degree.FlowSuspension.nativeSuspensionField_eq_vertical_off_base {Z N : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [TopologicalSpace N]
+    [ChartedSpace Z N]
+    (Ψ : Diffeomorph (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (N × ℝ) (N × ℝ) ∞) {K : Set N}
+    (hfix : ∀ p, p.1 ∉ K → Ψ p = p) (p : N × ℝ) (hp : p.1 ∉ K) :
+    nativeSuspensionField Ψ p = nativeVerticalField p := by
+  have hi : Ψ.symm p = p := by
+    have hh := congrArg Ψ.symm (hfix p hp)
+    rw [Ψ.symm_apply_apply] at hh
+    exact hh.symm
+  apply nativeSuspensionField_eq_vertical_of_flow_germ Ψ p
+  apply Filter.Eventually.of_forall
+  intro t
+  change Ψ ((Ψ.symm p).1, (Ψ.symm p).2 + t) = (p.1, p.2 + t)
+  rw [hi]
+  exact hfix (p.1, p.2 + t) hp
+
+private theorem Degree.FlowSuspension.nativeSuspensionField_eq_vertical_below {Z N : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [TopologicalSpace N]
+    [ChartedSpace Z N]
+    (Ψ : Diffeomorph (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (N × ℝ) (N × ℝ) ∞) {a : ℝ}
+    (hleft : ∀ p, p.2 ≤ a → Ψ p = p) (p : N × ℝ) (hp : p.2 < a) :
+    nativeSuspensionField Ψ p = nativeVerticalField p := by
+  have hi : Ψ.symm p = p := by
+    have hh := congrArg Ψ.symm (hleft p hp.le)
+    rw [Ψ.symm_apply_apply] at hh
+    exact hh.symm
+  apply nativeSuspensionField_eq_vertical_of_flow_germ Ψ p
+  filter_upwards [eventually_lt_nhds (sub_pos.mpr hp)] with t ht
+  change Ψ ((Ψ.symm p).1, (Ψ.symm p).2 + t) = (p.1, p.2 + t)
+  rw [hi]
+  exact hleft (p.1, p.2 + t) (by dsimp; linarith)
+
+private theorem Degree.FlowSuspension.nativeSuspensionField_eq_vertical_above {Z N : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [TopologicalSpace N]
+    [ChartedSpace Z N]
+    (Ψ : Diffeomorph (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (N × ℝ) (N × ℝ) ∞) (D : N → N)
+    {b : ℝ} (hheight : ∀ p, (Ψ p).2 = p.2) (hright : ∀ p, b ≤ p.2 → Ψ p = (D p.1, p.2))
+    (p : N × ℝ) (hp : b < p.2) : nativeSuspensionField Ψ p = nativeVerticalField p := by
+  let q := Ψ.symm p
+  have hq : Ψ q = p := Ψ.apply_symm_apply p
+  have htime : q.2 = p.2 := (hheight q).symm.trans (congrArg Prod.snd hq)
+  have hbase : D q.1 = p.1 := by
+    have hh := hright q (by rw [htime]; exact hp.le)
+    rw [hq] at hh
+    exact (congrArg Prod.fst hh).symm
+  apply nativeSuspensionField_eq_vertical_of_flow_germ Ψ p
+  filter_upwards [eventually_gt_nhds (show b - p.2 < (0 : ℝ) by linarith)] with t ht
+  change Ψ (q.1, q.2 + t) = (p.1, p.2 + t)
+  rw [hright (q.1, q.2 + t) (by dsimp; rw [htime]; linarith), hbase, htime]
+
+private theorem
+    Degree.FlowSuspension.nativeSuspensionFlow_fixed_line {Z N : Type*} [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [TopologicalSpace N] [ChartedSpace Z N]
+    (Ψ : Diffeomorph (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (N × ℝ) (N × ℝ) ∞) {x : N}
+    (hfix : ∀ s : ℝ, Ψ (x, s) = (x, s)) (s t : ℝ) :
+    nativeSuspensionFlow Ψ t (x, s) = (x, s + t) := by
+  have hi : Ψ.symm (x, s) = (x, s) := by
+    have hh := congrArg Ψ.symm (hfix s)
+    rw [Ψ.symm_apply_apply] at hh
+    exact hh.symm
+  change Ψ ((Ψ.symm (x, s)).1, (Ψ.symm (x, s)).2 + t) = _
+  rw [hi]
+  exact hfix (s + t)
+
+private theorem Degree.FlowSuspension.exists_compact_native_level_suspension {Z N : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [TopologicalSpace N]
+    [ChartedSpace Z N] [IsManifold 𝓘(ℝ, Z) ∞ N] [T2Space N]
+    (D : Diffeomorph 𝓘(ℝ, Z) 𝓘(ℝ, Z) N N ∞) {K S : Set N} (hK : IsCompact K)
+    (I : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy D K S) :
+    ∃ Ψ : Diffeomorph (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (N × ℝ) (N × ℝ) ∞,
+      IsCompact (K ×ˢ Set.Icc (1 / 3 : ℝ) (2 / 3)) ∧
+        (∀ p, (Ψ p).2 = p.2) ∧
+          (∀ p, p.2 ≤ 1 / 3 → Ψ p = p) ∧
+            (∀ p, 2 / 3 ≤ p.2 → Ψ p = (D p.1, p.2)) ∧
+              ContMDiff (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)).tangent ∞
+                  (fun p : N × ℝ =>
+                    (⟨p, nativeSuspensionField Ψ p⟩ :
+                      TangentBundle (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (N × ℝ))) ∧
+                (∀ p,
+                    IsMIntegralCurve (fun t : ℝ => nativeSuspensionFlow Ψ t p)
+                      (nativeSuspensionField Ψ)) ∧
+                  (∀ p, (nativeSuspensionField Ψ p).2 = 1) ∧
+                    (∀ p, nativeSuspensionField Ψ p ≠ 0) ∧
+                      (∀ p ∉ K ×ˢ Set.Icc (1 / 3 : ℝ) (2 / 3),
+                          nativeSuspensionField Ψ p = nativeVerticalField p) ∧
+                        (∀ p ∉ K ×ˢ Set.Icc (1 / 3 : ℝ) (2 / 3),
+                            ∀ᶠ q in 𝓝 p, nativeSuspensionField Ψ q = nativeVerticalField q) ∧
+                          (∀ x, nativeSuspensionFlow Ψ 1 (x, 0) = (D x, 1)) ∧
+                            (∀ t p, (nativeSuspensionFlow Ψ t p).2 = p.2 + t) ∧
+                              (∀ x ∉ K, ∀ s t : ℝ, nativeSuspensionFlow Ψ t (x, s) = (x, s + t)) ∧
+                                ∀ x ∈ S,
+                                  ∀ s t : ℝ, nativeSuspensionFlow Ψ t (x, s) = (x, s + t) := by
+  obtain ⟨Ψ, hheight, hleft, hright, hout, hfixed⟩ := exists_native_base_suspension D I
+  have hC : IsCompact (K ×ˢ Set.Icc (1 / 3 : ℝ) (2 / 3)) := hK.prod CompactIccSpace.isCompact_Icc
+  have hfield (p : N × ℝ) (hp : p ∉ K ×ˢ Set.Icc (1 / 3 : ℝ) (2 / 3)) :
+    nativeSuspensionField Ψ p = nativeVerticalField p := by
+    by_cases hx : p.1 ∈ K
+    · have ht : p.2 ∉ Set.Icc (1 / 3 : ℝ) (2 / 3) := fun ht => hp ⟨hx, ht⟩
+      by_cases hlo : p.2 < 1 / 3
+      · exact nativeSuspensionField_eq_vertical_below Ψ hleft p hlo
+      · have hhi : 2 / 3 < p.2 := lt_of_not_ge (fun hh => ht ⟨le_of_not_gt hlo, hh⟩)
+        exact nativeSuspensionField_eq_vertical_above Ψ D hheight hright p hhi
+    · exact nativeSuspensionField_eq_vertical_off_base Ψ hout p hx
+  have hgerm (p : N × ℝ) (hp : p ∉ K ×ˢ Set.Icc (1 / 3 : ℝ) (2 / 3)) :
+    ∀ᶠ q in 𝓝 p, nativeSuspensionField Ψ q = nativeVerticalField q := by
+    filter_upwards [hC.isClosed.isOpen_compl.mem_nhds hp] with q hq
+    exact hfield q hq
+  refine
+    ⟨Ψ, hC, hheight, hleft, hright, contMDiff_nativeSuspensionField Ψ,
+      nativeSuspensionFlow_integralCurve Ψ, nativeSuspensionField_height Ψ hheight,
+      nativeSuspensionField_ne_zero Ψ hheight, hfield, hgerm, ?_,
+      nativeSuspensionFlow_height Ψ hheight, ?_, ?_⟩
+  · intro x
+    have hzero : Ψ (x, (0 : ℝ)) = (x, 0) := hleft (x, 0) (by norm_num)
+    rw [← hzero, nativeSuspensionFlow_chart, zero_add]
+    exact hright (x, 1) (by norm_num)
+  · intro x hx s t
+    exact nativeSuspensionFlow_fixed_line Ψ (fun u => hout (x, u) hx) s t
+  · intro x hx s t
+    exact nativeSuspensionFlow_fixed_line Ψ (fun u => hfixed (x, u) hx) s t
+
+private theorem Degree.FlowSuspension.mvfderiv_native_model_pullback {D E H X M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace H] [TopologicalSpace X] [ChartedSpace H X] {I : ModelWithCorners ℝ D H}
+    [TopologicalSpace M] [ChartedSpace E M] (A : PartialDiffeomorph I 𝓘(ℝ, E) X M ∞) {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (W : (z : X) → TangentSpace I z) {x : M}
+    (hx : x ∈ A.target) :
+    mvfderiv 𝓘(ℝ, E) f x (VectorField.mpullback 𝓘(ℝ, E) I A.symm W x) =
+      mvfderiv I (f ∘ A) (A.symm x) (W (A.symm x)) := by
+  rw [native_model_pullback_eq_mfderiv_symm A.symm W hx]
+  exact
+    (mvfderiv_comp_apply_of_eq (A.symm x) (hf.mdifferentiableAt (by simp))
+        ((A.contMDiffOn_toFun.contMDiffAt
+              (A.open_source.mem_nhds (A.map_target' hx))).mdifferentiableAt
+          (by simp))
+        (A.right_inv' hx) (W (A.symm x))).symm
+
+private theorem
+    Degree.FlowSuspension.mvfderiv_native_level_height {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {Z N : Type*} [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [TopologicalSpace N] [ChartedSpace Z N]
+    (A : PartialDiffeomorph (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) (N × ℝ) M ∞) {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {b s : ℝ}
+    (hheight : ∀ p ∈ A.source, f (A p) = b - s * p.2)
+    (W : (p : N × ℝ) → TangentSpace (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) p) {x : M} (hx : x ∈ A.target) :
+    mvfderiv 𝓘(ℝ, E) f x (VectorField.mpullback 𝓘(ℝ, E) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) A.symm W x) =
+      -s * (W (A.symm x)).2 := by
+  let q := A.symm x
+  have heq : (f ∘ A) =ᶠ[𝓝 q] (fun p : N × ℝ => b - s * p.2) := by
+    filter_upwards [A.open_source.mem_nhds (A.map_target' hx)] with p hp
+    exact hheight p hp
+  have hd :
+    mfderiv (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, ℝ) (f ∘ A) q =
+      mfderiv (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, ℝ) (fun p : N × ℝ => b - s * p.2) q :=
+    heq.mfderiv_eq
+  rw [mvfderiv_native_model_pullback A hf W hx]
+  change mfderiv (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, ℝ) (f ∘ A) q (W q) = _
+  rw [hd]
+  have hsnd :
+    HasMFDerivAt (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, ℝ) (Prod.snd : N × ℝ → ℝ) q
+      (ContinuousLinearMap.snd ℝ Z ℝ) :=
+    hasMFDerivAt_snd q
+  have hh :=
+    (hasMFDerivAt_const (I := 𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) b q).sub
+      ((hasMFDerivAt_const (I := 𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) s q).mul hsnd)
+  have hh' :
+    mfderiv (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, ℝ) (fun p : N × ℝ => b - s * p.2) q =
+      (0 : (Z × ℝ) →L[ℝ] ℝ) - (s • ContinuousLinearMap.snd ℝ Z ℝ + q.2 • (0 : (Z × ℝ) →L[ℝ] ℝ)) :=
+    hh.mfderiv
+  rw [hh']
+  change (0 : ℝ) - (s * (W q).2 + q.2 * (0 : ℝ)) = -s * (W q).2
+  ring
+
+private theorem Degree.FlowSuspension.exists_native_whole_level_holonomy {Z E N M : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace N] [ChartedSpace Z N]
+    [IsManifold 𝓘(ℝ, Z) ∞ N] [T2Space N] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    (A : PartialDiffeomorph (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) (N × ℝ) M ∞)
+    (hsource : A.source = Set.univ) {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {b s : ℝ}
+    (hs : 0 < s) (hheight : ∀ p, p.2 ∈ Set.Ioo (0 : ℝ) 1 → f (A p) = b - s * p.2)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hmodel :
+      ∀ x ∈ A.target,
+        V x = VectorField.mpullback 𝓘(ℝ, E) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) A.symm nativeVerticalField x)
+    (H : Flow ℝ M) (hH : ∀ x, IsMIntegralCurve (fun t => H t x) V)
+    (D : Diffeomorph 𝓘(ℝ, Z) 𝓘(ℝ, Z) N N ∞) {K S : Set N} (hK : IsCompact K)
+    (I : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy D K S) :
+    ∃ (C : Set M) (V' : (x : M) → TangentSpace 𝓘(ℝ, E) x) (G : Flow ℝ M) (Ψ :
+      Diffeomorph (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (N × ℝ) (N × ℝ) ∞),
+      IsCompact C ∧
+        C ⊆ A.target ∩ f ⁻¹' Set.Ioo (b - s) b ∧
+          ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V' x⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+            (∀ x, IsMIntegralCurve (fun t => G t x) V') ∧
+              (∀ x, V' x = 0 ↔ V x = 0) ∧
+                (∀ x, mvfderiv 𝓘(ℝ, E) f x (V x) < 0 → mvfderiv 𝓘(ℝ, E) f x (V' x) < 0) ∧
+                  (∀ x ∉ C, ∀ᶠ y in 𝓝 x, V' y = V y) ∧
+                    (∀ x ∈ A.target, ∀ t, G t x ∈ A.target) ∧
+                      (∀ x ∉ A.target, ∀ t, G t x = H t x) ∧
+                        (∀ p t, G t (A p) = A (nativeSuspensionFlow Ψ t p)) ∧
+                          (∀ x, G 1 (A (x, 0)) = A (D x, 1)) ∧
+                            (∀ x ∈ S, ∀ u t : ℝ, G t (A (x, u)) = A (x, u + t)) ∧
+                              (∀ p, (Ψ p).2 = p.2) ∧
+                                (∀ p, p.2 ≤ 1 / 3 → Ψ p = p) ∧
+                                  (∀ p, 2 / 3 ≤ p.2 → Ψ p = (D p.1, p.2)) ∧
+                                    ∀ x ∈ A.target,
+                                      V' x =
+                                        VectorField.mpullback 𝓘(ℝ, E) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ))
+                                          A.symm (nativeSuspensionField Ψ) x := by
+  obtain
+    ⟨Ψ, hL, hΨheight, hleft, hright, hW, hF, hWheight, hWzero, hfix, -, hend, -, -, hfixed⟩ :=
+    exists_compact_native_level_suspension D hK I
+  let L : Set (N × ℝ) := K ×ˢ Set.Icc (1 / 3 : ℝ) (2 / 3)
+  have hLA : L ⊆ A.source := by rw [hsource]; exact Set.subset_univ L
+  have hvertical (p : N × ℝ) (_ : p ∈ A.source) : nativeVerticalField (Z := Z) p ≠ 0 := by
+    intro hz
+    have hh := congrArg (fun v : Z × ℝ => v.2) hz
+    exact one_ne_zero hh
+  obtain ⟨V', hV', hnew, hzero, hgerm⟩ :=
+    exists_native_model_field_replacement A V hV nativeVerticalField (nativeSuspensionField Ψ) hW
+      hmodel hvertical (fun p _ => hWzero p) hL hLA hfix
+  let C := A '' L
+  have hC : IsCompact C := hL.image_of_continuousOn (A.contMDiffOn_toFun.continuousOn.mono hLA)
+  have hslab (p : N × ℝ) (hp : p ∈ L) : p.2 ∈ Set.Ioo (0 : ℝ) 1 := by
+    constructor <;> linarith [hp.2.1, hp.2.2]
+  have hCsub : C ⊆ A.target ∩ f ⁻¹' Set.Ioo (b - s) b := by
+    rintro x ⟨p, hp, rfl⟩
+    refine ⟨A.map_source' (hLA hp), ?_⟩
+    change f (A p) ∈ Set.Ioo (b - s) b
+    rw [hheight p (hslab p hp)]
+    constructor <;> nlinarith [(hslab p hp).1, (hslab p hp).2]
+  let R :=
+    Smale.PartialChart.restrictSource A
+      (isOpen_univ.prod (isOpen_Ioo : IsOpen (Set.Ioo (0 : ℝ) 1)))
+  have hRheight (p : N × ℝ) (hp : p ∈ R.source) : f (R p) = b - s * p.2 := hheight p hp.2.2
+  have hnegC (x : M) (hx : x ∈ C) : mvfderiv 𝓘(ℝ, E) f x (V' x) = -s := by
+    rcases hx with ⟨p, hp, rfl⟩
+    have hpR : p ∈ R.source := ⟨hLA hp, Set.mem_univ _, hslab p hp⟩
+    rw [hnew (A p) (A.map_source' (hLA hp))]
+    change
+      mvfderiv 𝓘(ℝ, E) f (R p)
+          (VectorField.mpullback 𝓘(ℝ, E) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) R.symm (nativeSuspensionField Ψ)
+            (R p)) =
+        -s
+    rw [mvfderiv_native_level_height R hf hRheight _ (R.map_source' hpR), hWheight, mul_one]
+  have hV'₁ := hV'.of_le (show (1 : WithTop ℕ∞) ≤ (↑(⊤ : ℕ∞) : ℕ∞ω) by simp)
+  let G := Smale.FlowConstruction.compactFlow hV'₁
+  have hG (x : M) : IsMIntegralCurve (fun t => G t x) V' :=
+    Smale.FlowConstruction.isMIntegralCurve_compactFlow hV'₁ x
+  have hstay (p : N × ℝ) (t : ℝ) : nativeSuspensionFlow Ψ t p ∈ A.source := by
+    rw [hsource]
+    exact Set.mem_univ _
+  have hfull (p : N × ℝ) (t : ℝ) : G t (A p) = A (nativeSuspensionFlow Ψ t p) :=
+    native_model_flow_all_time A hV'₁ G hG (nativeSuspensionFlow Ψ) (nativeSuspensionField Ψ) hF
+      hnew (hstay p) t
+  have hinv :=
+    native_model_target_invariant A hV'₁ G hG (nativeSuspensionFlow Ψ) (nativeSuspensionField Ψ)
+      hF hnew (fun p _ => hstay p)
+  have hcomp := flow_complement_invariant G hinv
+  refine
+    ⟨C, V', G, Ψ, hC, hCsub, hV', hG, hzero, ?_, hgerm, hinv, ?_, hfull, ?_, ?_, hΨheight, hleft,
+      hright, hnew⟩
+  · intro x hx
+    by_cases hc : x ∈ C
+    · rw [hnegC x hc]
+      exact neg_neg_of_pos hs
+    · rw [(hgerm x hc).self_of_nhds]
+      exact hx
+  · intro x hx t
+    have hagree (u : ℝ) : V' (G u x) = V (G u x) :=
+      (hgerm (G u x) (fun h => hcomp x hx u (hCsub h).1)).self_of_nhds
+    rcases le_total 0 t with ht | ht
+    · exact
+        Degree.FlowCancellation.native_flow_eq_on_positive_halfline (hV.of_le (by simp)) H G hH hG
+          (fun u _ => hagree u) t ht
+    · exact
+        Degree.FlowCancellation.native_flow_eq_on_negative_halfline (hV.of_le (by simp)) H G hH hG
+          (fun u _ => hagree u) t ht
+  · intro x
+    rw [hfull, hend]
+  · intro x hx u t
+    rw [hfull, hfixed x hx u t]
+
+private theorem Degree.FlowSuspension.native_whole_level_exterior_tails {Z N M : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [TopologicalSpace N]
+    [ChartedSpace Z N] [TopologicalSpace M] (A : N × ℝ → M) (ι : N → M)
+    (H G : Flow ℝ M) (hformula : ∀ p, A p = H p.2 (ι p.1)) (D : Diffeomorph 𝓘(ℝ, Z) 𝓘(ℝ, Z) N N ∞)
+    (Ψ : Diffeomorph (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, Z).prod 𝓘(ℝ, ℝ)) (N × ℝ) (N × ℝ) ∞)
+    (hleft : ∀ p, p.2 ≤ 1 / 3 → Ψ p = p) (hright : ∀ p, 2 / 3 ≤ p.2 → Ψ p = (D p.1, p.2))
+    (hfull : ∀ p t, G t (A p) = A (nativeSuspensionFlow Ψ t p)) :
+    (∀ x, ∀ t : ℝ, t ≤ 0 → G t (A (x, 0)) = H t (A (x, 0))) ∧
+      ∀ x, ∀ t : ℝ, 0 ≤ t → G t (A (x, 1)) = H t (A (x, 1)) := by
+  constructor
+  · intro x t ht
+    have h0 : Ψ (x, (0 : ℝ)) = (x, 0) := hleft (x, 0) (by norm_num)
+    have hf : nativeSuspensionFlow Ψ t (x, 0) = (x, t) := by
+      rw [← h0, nativeSuspensionFlow_chart, zero_add]
+      exact hleft (x, t) (by linarith)
+    rw [hfull, hf, hformula, hformula, H.map_zero_apply]
+  · intro x t ht
+    have h1 : Ψ (D.symm x, (1 : ℝ)) = (x, 1) := by
+      rw [hright (D.symm x, 1) (by norm_num), D.apply_symm_apply]
+    have hf : nativeSuspensionFlow Ψ t (x, 1) = (x, 1 + t) := by
+      rw [← h1, nativeSuspensionFlow_chart]
+      rw [hright (D.symm x, 1 + t) (by linarith), D.apply_symm_apply]
+    rw [hfull, hf, hformula, hformula, ← H.map_add]
+    congr 1
+    ring
+
+private theorem Degree.FlowSuspension.exists_native_regular_level_isotopy_realization {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun y => (⟨y, V y⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hdesc : ∀ y, y ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f y (V y) < 0)
+    (F : Flow ℝ M) (hF : ∀ y, IsMIntegralCurve (fun t => F t y) V) {a b c : ℝ} (ha : a < c)
+    (hb : c < b) (hband : ∀ y, f y ∈ Set.Icc a b → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hreg : ∀ y, f y = c → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (z : { y : M // f y = c }) :
+    letI := Smale.RegularLevel.chartedSpace hf hreg
+    ∀ D :
+      Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+        { y : M // f y = c } { y : M // f y = c } ∞,
+      Smale.SupportedDiffeomorph.IsotopicToIdentity D →
+        ∃ (r : ℝ) (C : Set M) (W V' : (y : M) → TangentSpace 𝓘(ℝ, E) y) (H G : Flow ℝ M),
+          0 < r ∧
+            r < c - a ∧
+              IsCompact C ∧
+                C ⊆ f ⁻¹' Set.Ioo a b ∧
+                  ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞
+                      (fun y => (⟨y, W y⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+                    (∀ y, IsMIntegralCurve (fun t => H t y) W) ∧
+                      (∀ y,
+                          Set.range (fun t => H t y) = Set.range (fun t => F t y) ∧
+                            (∀ p,
+                                Filter.Tendsto (fun t => H t y) Filter.atTop (𝓝 p) ↔
+                                  Filter.Tendsto (fun t => F t y) Filter.atTop (𝓝 p)) ∧
+                              ∀ p,
+                                Filter.Tendsto (fun t => H t y) Filter.atBot (𝓝 p) ↔
+                                  Filter.Tendsto (fun t => F t y) Filter.atBot (𝓝 p)) ∧
+                        ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞
+                            (fun y => (⟨y, V' y⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+                          (∀ y, IsMIntegralCurve (fun t => G t y) V') ∧
+                            (∀ y, V' y = 0 ↔ V y = 0) ∧
+                              (∀ y,
+                                  y ∉ Smale.ManifoldMorse.criticalPoints E f →
+                                    mvfderiv 𝓘(ℝ, E) f y (V' y) < 0) ∧
+                                (∀ y ∈ Smale.ManifoldMorse.criticalPoints E f,
+                                    ∀ᶠ x in 𝓝 y, V' x = V x) ∧
+                                  (∀ y ∉ C, ∀ᶠ x in 𝓝 y, V' x = W x) ∧
+                                    (∀ x : { y : M // f y = c }, G 1 x = H 1 (D x)) ∧
+                                      (∀ x : { y : M // f y = c }, f (H 1 x) = c - r) ∧
+                                        (∀ x : { y : M // f y = c },
+                                            ∀ t : ℝ, t ≤ 0 → G t x = H t x) ∧
+                                          ∀ x : { y : M // f y = c },
+                                            ∀ t : ℝ, 0 ≤ t → G t (H 1 x) = H t (H 1 x) := by
+  let _ := Smale.RegularLevel.chartedSpace hf hreg
+  let _ := Smale.RegularLevel.isManifold hf hreg
+  let L := { y : M // f y = c }
+  let _ : CompactSpace L :=
+    isCompact_iff_compactSpace.mp (isClosed_eq hf.continuous continuous_const).isCompact
+  intro D hD
+  obtain ⟨B, hB, hBzero, hBone, hBslices⟩ := hD
+  let I : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy D Set.univ ∅ :=
+    { family := B
+      smooth := hB
+      zero := hBzero
+      one := hBone
+      slices := fun t => by
+        obtain ⟨d, hd⟩ := hBslices t
+        exact ⟨d, fun x => (hd x).symm⟩
+      fixedOutside := fun _ x hx => (hx (Set.mem_univ x)).elim
+      fixedOn := fun _ _ hx => hx.elim }
+  obtain
+    ⟨r, W, H, A, hr, hrbound, hW, hH, hWzero, hWneg, hWgerm, hgeometry, hsource, -, hformula,
+      hheight, hmodel⟩ :=
+    Degree.FlowTimeChange.exists_normalized_whole_level_cylinder hf hV hdesc F hF ha hb hband hreg
+      z
+  obtain
+    ⟨C, V', G, Ψ, hC, hCsub, hV', hG, hzero, hneg, hgerm, -, -, hfull, hend, -, -, hleft, hright,
+      -⟩ :=
+    exists_native_whole_level_holonomy A hsource hf hr (fun p hp => hheight p ⟨hp.1.le, hp.2.le⟩)
+      W hW hmodel H hH D isCompact_univ I
+  have hCband : C ⊆ f ⁻¹' Set.Ioo a b := by
+    intro y hy
+    have hh := (hCsub hy).2
+    change f y ∈ Set.Ioo (c - r) c at hh
+    exact ⟨by linarith [hh.1], lt_trans hh.2 hb⟩
+  have hcritical (y : M) (hy : y ∈ Smale.ManifoldMorse.criticalPoints E f) :
+    ∀ᶠ x in 𝓝 y, V' x = V x := by
+    have hout : y ∉ C := fun hc => hband y ⟨(hCband hc).1.le, (hCband hc).2.le⟩ hy
+    filter_upwards [hgerm y hout, hWgerm y hy] with x hx hx'
+    exact hx.trans hx'
+  obtain ⟨htailLeft, htailRight⟩ :=
+    native_whole_level_exterior_tails A Subtype.val H G hformula D Ψ hleft hright hfull
+  have hA0 (x : L) : A (x, 0) = (x : M) := by rw [hformula, H.map_zero_apply]
+  have hA1 (x : L) : A (x, 1) = H 1 x := hformula (x, 1)
+  refine
+    ⟨r, C, W, V', H, G, hr, hrbound, hC, hCband, hW, hH, hgeometry, hV', hG, fun y =>
+      (hzero y).trans (hWzero y), fun y hy => hneg y (hWneg y hy), hcritical, hgerm, ?_, ?_, ?_,
+      ?_⟩
+  · intro x
+    rw [← hA0 x, hend, hA1]
+  · intro x
+    have hh := hheight (x, 1) (show (1 : ℝ) ∈ Set.Icc 0 1 by constructor <;> norm_num)
+    rw [hA1, mul_one] at hh
+    exact hh
+  · intro x t ht
+    simpa only [hA0] using htailLeft x t ht
+  · intro x t ht
+    simpa only [hA1] using htailRight x t ht
+
+public
+theorem Degree.FlowSuspension.whole_level_basins_of_holonomy {X M : Type*} [TopologicalSpace M]
+    (F H G : Flow ℝ M) (ι : X → M) (D : X → X)
+    (hHtop :
+      ∀ x p,
+        Filter.Tendsto (fun t => H t x) Filter.atTop (𝓝 p) ↔
+          Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p))
+    (hHbot :
+      ∀ x p,
+        Filter.Tendsto (fun t => H t x) Filter.atBot (𝓝 p) ↔
+          Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p))
+    (hend : ∀ x, G 1 (ι x) = H 1 (ι (D x))) (hleft : ∀ x, ∀ t : ℝ, t ≤ 0 → G t (ι x) = H t (ι x))
+    (hright : ∀ x, ∀ t : ℝ, 0 ≤ t → G t (H 1 (ι x)) = H t (H 1 (ι x))) :
+    (∀ x p,
+        Filter.Tendsto (fun t => G t (ι x)) Filter.atBot (𝓝 p) ↔
+          Filter.Tendsto (fun t => F t (ι x)) Filter.atBot (𝓝 p)) ∧
+      ∀ x p,
+        Filter.Tendsto (fun t => G t (ι x)) Filter.atTop (𝓝 p) ↔
+          Filter.Tendsto (fun t => F t (ι (D x))) Filter.atTop (𝓝 p) := by
+  constructor
+  · intro x p
+    have heq : (fun t => G t (ι x)) =ᶠ[Filter.atBot] (fun t => H t (ι x)) := by
+      filter_upwards [Filter.eventually_le_atBot (0 : ℝ)] with t ht
+      exact hleft x t ht
+    exact (Filter.tendsto_congr' heq).trans (hHbot (ι x) p)
+  · intro x p
+    have heq : (fun t => G t (H 1 (ι (D x)))) =ᶠ[Filter.atTop] (fun t => H t (H 1 (ι (D x)))) := by
+      filter_upwards [Filter.eventually_ge_atTop (0 : ℝ)] with t ht
+      exact hright (D x) t ht
+    calc
+      Filter.Tendsto (fun t => G t (ι x)) Filter.atTop (𝓝 p) ↔
+          Filter.Tendsto (fun t => G t (G 1 (ι x))) Filter.atTop (𝓝 p) :=
+        (MorseCancel.flow_time_atTop_limit_iff G 1 (ι x) p).symm
+      _ ↔ Filter.Tendsto (fun t => G t (H 1 (ι (D x)))) Filter.atTop (𝓝 p) := by rw [hend]
+      _ ↔ Filter.Tendsto (fun t => H t (H 1 (ι (D x)))) Filter.atTop (𝓝 p) :=
+        (Filter.tendsto_congr' heq)
+      _ ↔ Filter.Tendsto (fun t => H t (ι (D x))) Filter.atTop (𝓝 p) :=
+        (MorseCancel.flow_time_atTop_limit_iff H 1 (ι (D x)) p)
+      _ ↔ Filter.Tendsto (fun t => F t (ι (D x))) Filter.atTop (𝓝 p) := hHtop (ι (D x)) p
+
+private theorem Degree.FlowSuspension.unique_connection_of_level_basin_intersection {M : Type*}
+    [TopologicalSpace M] (F G : Flow ℝ M) {f : M → ℝ} (hf : Continuous f) {p q : M} {c : ℝ}
+    (hpc : c < f p) (hqc : f q < c) (D : { x : M // f x = c } → { x : M // f x = c })
+    (hback :
+      ∀ x : { y : M // f y = c },
+        Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 p) ↔
+          Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p))
+    (hforward :
+      ∀ x : { y : M // f y = c },
+        Filter.Tendsto (fun t => G t x) Filter.atTop (𝓝 q) ↔
+          Filter.Tendsto (fun t => F t (D x)) Filter.atTop (𝓝 q))
+    (z : { y : M // f y = c }) (hzback : Filter.Tendsto (fun t => F t z) Filter.atBot (𝓝 p))
+    (hzforward : Filter.Tendsto (fun t => F t (D z)) Filter.atTop (𝓝 q))
+    (hunique :
+      ∀ x : { y : M // f y = c },
+        Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p) →
+          Filter.Tendsto (fun t => F t (D x)) Filter.atTop (𝓝 q) → x = z) :
+    Filter.Tendsto (fun t => G t z) Filter.atBot (𝓝 p) ∧
+      Filter.Tendsto (fun t => G t z) Filter.atTop (𝓝 q) ∧
+        ∀ x,
+          Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 p) →
+            Filter.Tendsto (fun t => G t x) Filter.atTop (𝓝 q) → ∃ t, G t z = x := by
+  refine ⟨(hback z).mpr hzback, (hforward z).mpr hzforward, ?_⟩
+  intro x hxback hxforward
+  obtain ⟨s, hs⟩ :=
+    Degree.FlowCancellation.exists_level_crossing_of_endpoint_limits G hf hxback hxforward hpc hqc
+  let u : { y : M // f y = c } := ⟨G s x, hs⟩
+  have hub : Filter.Tendsto (fun t => G t u) Filter.atBot (𝓝 p) :=
+    (MorseCancel.flow_time_atBot_limit_iff G s x p).mpr hxback
+  have huf : Filter.Tendsto (fun t => G t u) Filter.atTop (𝓝 q) :=
+    (MorseCancel.flow_time_atTop_limit_iff G s x q).mpr hxforward
+  have huz : u = z := hunique u ((hback u).mp hub) ((hforward u).mp huf)
+  have hv : G s x = (z : M) := congrArg Subtype.val huz
+  refine ⟨-s, ?_⟩
+  rw [← hv, ← G.map_add, neg_add_cancel, G.map_zero_apply]
+
+private theorem Degree.FlowSuspension.exists_unique_connection_of_unit_level_count {M : Type*}
+    [TopologicalSpace M] (F G : Flow ℝ M) {f : M → ℝ} (hf : Continuous f) {p q : M} {c : ℝ}
+    (hpc : c < f p) (hqc : f q < c) (D : { x : M // f x = c } → { x : M // f x = c })
+    (hback :
+      ∀ x : { y : M // f y = c },
+        Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 p) ↔
+          Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p))
+    (hforward :
+      ∀ x : { y : M // f y = c },
+        Filter.Tendsto (fun t => G t x) Filter.atTop (𝓝 q) ↔
+          Filter.Tendsto (fun t => F t (D x)) Filter.atTop (𝓝 q))
+    (hcount :
+      {x : { y : M // f y = c } |
+            Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p) ∧
+              Filter.Tendsto (fun t => F t (D x)) Filter.atTop (𝓝 q)}.ncard =
+        1) :
+    ∃ z : { y : M // f y = c },
+      Filter.Tendsto (fun t => G t z) Filter.atBot (𝓝 p) ∧
+        Filter.Tendsto (fun t => G t z) Filter.atTop (𝓝 q) ∧
+          ∀ x,
+            Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 p) →
+              Filter.Tendsto (fun t => G t x) Filter.atTop (𝓝 q) → ∃ t, G t z = x := by
+  let C :=
+    {x : { y : M // f y = c } |
+      Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p) ∧
+        Filter.Tendsto (fun t => F t (D x)) Filter.atTop (𝓝 q)}
+  obtain ⟨z, hz⟩ := Set.ncard_eq_one.mp hcount
+  have hmem : z ∈ C := by rw [show C = { z } from hz]; exact Set.mem_singleton z
+  have hu (x : { y : M // f y = c }) (hb : Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p))
+    (hf' : Filter.Tendsto (fun t => F t (D x)) Filter.atTop (𝓝 q)) : x = z := by
+    have hx : x ∈ C := ⟨hb, hf'⟩
+    rw [show C = { z } from hz] at hx
+    exact Set.mem_singleton_iff.mp hx
+  exact
+    ⟨z,
+      unique_connection_of_level_basin_intersection F G hf hpc hqc D hback hforward z hmem.1
+        hmem.2 hu⟩
+
+private theorem Degree.FlowSuspension.no_connection_of_level_basin_disjointness {M : Type*}
+    [TopologicalSpace M] (F G : Flow ℝ M) {f : M → ℝ} (hf : Continuous f) {p q : M} {c : ℝ}
+    (hpc : c < f p) (hqc : f q < c) (D : { x : M // f x = c } → { x : M // f x = c })
+    (hback :
+      ∀ x : { y : M // f y = c },
+        Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 p) ↔
+          Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p))
+    (hforward :
+      ∀ x : { y : M // f y = c },
+        Filter.Tendsto (fun t => G t x) Filter.atTop (𝓝 q) ↔
+          Filter.Tendsto (fun t => F t (D x)) Filter.atTop (𝓝 q))
+    (hdisjoint :
+      ∀ x : { y : M // f y = c },
+        ¬(Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p) ∧
+            Filter.Tendsto (fun t => F t (D x)) Filter.atTop (𝓝 q))) :
+    ∀ x,
+      ¬(Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 p) ∧
+          Filter.Tendsto (fun t => G t x) Filter.atTop (𝓝 q)) := by
+  rintro x ⟨hxback, hxforward⟩
+  obtain ⟨s, hs⟩ :=
+    Degree.FlowCancellation.exists_level_crossing_of_endpoint_limits G hf hxback hxforward hpc hqc
+  let u : { y : M // f y = c } := ⟨G s x, hs⟩
+  have hub : Filter.Tendsto (fun t => G t u) Filter.atBot (𝓝 p) :=
+    (MorseCancel.flow_time_atBot_limit_iff G s x p).mpr hxback
+  have huf : Filter.Tendsto (fun t => G t u) Filter.atTop (𝓝 q) :=
+    (MorseCancel.flow_time_atTop_limit_iff G s x q).mpr hxforward
+  exact hdisjoint u ⟨(hback u).mp hub, (hforward u).mp huf⟩
+
+private def
+    Degree.TransverseGerms.timeLiftLinear {A Z : Type*} [NormedAddCommGroup A] [NormedSpace ℝ A]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] (L : A →L[ℝ] Z) (α : A →L[ℝ] ℝ) :
+    (A × ℝ) →L[ℝ] (Z × ℝ) :=
+  (L.comp (ContinuousLinearMap.fst ℝ A ℝ)).prod
+    (ContinuousLinearMap.snd ℝ A ℝ + α.comp (ContinuousLinearMap.fst ℝ A ℝ))
+
+private theorem
+    Degree.TransverseGerms.surjective_time_lift_coprod {A B Z : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] (L : A →L[ℝ] Z) (R : B →L[ℝ] Z) (α : A →L[ℝ] ℝ) (β : B →L[ℝ] ℝ)
+    (h : Function.Surjective (L.coprod R)) :
+    Function.Surjective ((timeLiftLinear L α).coprod (timeLiftLinear R β)) := by
+  rintro ⟨z, t⟩
+  obtain ⟨⟨a, b⟩, hab⟩ := h z
+  refine ⟨((a, t - α a - β b), (b, 0)), ?_⟩
+  apply Prod.ext
+  · exact hab
+  · change (t - α a - β b + α a) + (0 + β b) = t
+    ring
+
+private theorem
+    Degree.TransverseGerms.native_time_lift_derivative {A Z : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup Z] [NormedSpace ℝ Z] {HA HZ X N : Type*}
+    [TopologicalSpace HA] [TopologicalSpace HZ] {I : ModelWithCorners ℝ A HA}
+    {J : ModelWithCorners ℝ Z HZ} [TopologicalSpace X] [ChartedSpace HA X] [TopologicalSpace N]
+    [ChartedSpace HZ N] {f : X → N} {v : X → ℝ} {x : X} (s : ℝ) (hf : MDifferentiableAt I J f x)
+    (hv : MDifferentiableAt I 𝓘(ℝ, ℝ) v x) :
+    (mfderiv (I.prod 𝓘(ℝ, ℝ)) (J.prod 𝓘(ℝ, ℝ)) (fun p : X × ℝ => (f p.1, p.2 + v p.1)) (x, s) :
+        (A × ℝ) →L[ℝ] (Z × ℝ)) =
+      timeLiftLinear (A := A) (Z := Z) (mfderiv I J f x) (mvfderiv I v x) := by
+  have hn := hf.hasMFDerivAt.comp (x, s) (hasMFDerivAt_fst (I := I) (I' := 𝓘(ℝ, ℝ)) (x, s))
+  have hp := hv.hasMFDerivAt.comp (x, s) (hasMFDerivAt_fst (I := I) (I' := 𝓘(ℝ, ℝ)) (x, s))
+  have ht := (hasMFDerivAt_snd (I := I) (I' := 𝓘(ℝ, ℝ)) (x, s)).add hp
+  exact (hn.prodMk ht).mfderiv
+
+private theorem Degree.TransverseGerms.native_transversality_time_lifts {A B Z : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] {HA HB HZ X Y N : Type*} [TopologicalSpace HA]
+    [TopologicalSpace HB] [TopologicalSpace HZ] {I : ModelWithCorners ℝ A HA}
+    {I' : ModelWithCorners ℝ B HB} {J : ModelWithCorners ℝ Z HZ} [TopologicalSpace X]
+    [ChartedSpace HA X] [TopologicalSpace Y] [ChartedSpace HB Y] [TopologicalSpace N]
+    [ChartedSpace HZ N] {f : X → N} {g : Y → N} {v : X → ℝ} {w : Y → ℝ} {x : X} {y : Y}
+    (hf : MDifferentiableAt I J f x) (hg : MDifferentiableAt I' J g y)
+    (hv : MDifferentiableAt I 𝓘(ℝ, ℝ) v x) (hw : MDifferentiableAt I' 𝓘(ℝ, ℝ) w y)
+    (hxy : g y = f x) (htrans : Smale.NativeTransversality.At I I' J f g x y) (s t : ℝ) :
+    Smale.NativeTransversality.At (I.prod 𝓘(ℝ, ℝ)) (I'.prod 𝓘(ℝ, ℝ)) (J.prod 𝓘(ℝ, ℝ))
+      (fun p : X × ℝ => (f p.1, p.2 + v p.1)) (fun p : Y × ℝ => (g p.1, p.2 + w p.1)) (x, s)
+      (y, t) := by
+  intro _
+  rw [native_time_lift_derivative s hf hv, native_time_lift_derivative t hg hw]
+  exact surjective_time_lift_coprod _ _ _ _ (htrans hxy)
+
+private theorem Degree.TransverseGerms.native_transverse_sheets_of_level_maps
+    {A B Z E HA HB HZ HE X Y N M : Type*} [NormedAddCommGroup A] [NormedSpace ℝ A]
+    [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace HA] [TopologicalSpace HB]
+    [TopologicalSpace HZ] [TopologicalSpace HE] {I : ModelWithCorners ℝ A HA}
+    {I' : ModelWithCorners ℝ B HB} {J : ModelWithCorners ℝ Z HZ} {J' : ModelWithCorners ℝ E HE}
+    [TopologicalSpace X] [ChartedSpace HA X] [TopologicalSpace Y] [ChartedSpace HB Y]
+    [TopologicalSpace N] [ChartedSpace HZ N] [TopologicalSpace M] [ChartedSpace HE M]
+    (C : PartialDiffeomorph (J.prod 𝓘(ℝ, ℝ)) J' (N × ℝ) M ∞) {f : X → N} {g : Y → N} {v : X → ℝ}
+    {w : Y → ℝ} {x : X} {y : Y} (hf : MDifferentiableAt I J f x) (hg : MDifferentiableAt I' J g y)
+    (hv : MDifferentiableAt I 𝓘(ℝ, ℝ) v x) (hw : MDifferentiableAt I' 𝓘(ℝ, ℝ) w y)
+    (hxy : g y = f x) (htrans : Smale.NativeTransversality.At I I' J f g x y) {s t : ℝ}
+    (hphase : t + w y = s + v x) (hsource : (f x, s + v x) ∈ C.source) :
+    Smale.NativeTransversality.At (I.prod 𝓘(ℝ, ℝ)) (I'.prod 𝓘(ℝ, ℝ)) J'
+      (fun p : X × ℝ => C (f p.1, p.2 + v p.1)) (fun p : Y × ℝ => C (g p.1, p.2 + w p.1)) (x, s)
+      (y, t) := by
+  let F : X × ℝ → N × ℝ := fun p => (f p.1, p.2 + v p.1)
+  let G : Y × ℝ → N × ℝ := fun p => (g p.1, p.2 + w p.1)
+  have hF : MDifferentiableAt (I.prod 𝓘(ℝ, ℝ)) (J.prod 𝓘(ℝ, ℝ)) F (x, s) :=
+    (hf.comp (x, s) mdifferentiableAt_fst).prodMk
+      (mdifferentiableAt_snd.add (hv.comp (x, s) mdifferentiableAt_fst))
+  have hG : MDifferentiableAt (I'.prod 𝓘(ℝ, ℝ)) (J.prod 𝓘(ℝ, ℝ)) G (y, t) :=
+    (hg.comp (y, t) mdifferentiableAt_fst).prodMk
+      (mdifferentiableAt_snd.add (hw.comp (y, t) mdifferentiableAt_fst))
+  have hcross : G (y, t) = F (x, s) := Prod.ext hxy hphase
+  exact
+    (native_transversality_partial_diffeomorph_iff C hF hG hcross hsource).mp
+      (native_transversality_time_lifts hf hg hv hw hxy htrans s t)
+
+private theorem Degree.FlowSuspension.native_transverse_basin_tubes_of_level_maps {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M]
+    {A B HA HB X Y : Type*} [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [TopologicalSpace HA] [TopologicalSpace HB] {I : ModelWithCorners ℝ A HA}
+    {I' : ModelWithCorners ℝ B HB} [TopologicalSpace X] [ChartedSpace HA X] [TopologicalSpace Y]
+    [ChartedSpace HB Y] {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {c : ℝ}
+    (hreg : ∀ z, f z = c → z ∉ Smale.ManifoldMorse.criticalPoints E f)
+    {V : (z : M) → TangentSpace 𝓘(ℝ, E) z}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun z => (⟨z, V z⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ z, IsMIntegralCurve (fun t => F t z) V)
+    (hboundary : ∀ z, f z = c → mvfderiv 𝓘(ℝ, E) f z (V z) < 0) {p q : M} :
+    letI := Smale.RegularLevel.chartedSpace hf hreg
+    ∀ (α : X → { z : M // f z = c }) (β : Y → { z : M // f z = c }) (x : X) (y : Y),
+      MDifferentiableAt I 𝓘(ℝ, Smale.RegularLevel.Model E) α x →
+        MDifferentiableAt I' 𝓘(ℝ, Smale.RegularLevel.Model E) β y →
+          β y = α x →
+            Smale.NativeTransversality.At I I' 𝓘(ℝ, Smale.RegularLevel.Model E) α β x y →
+              (∀ᶠ u in 𝓝 x, Filter.Tendsto (fun t => F t (α u)) Filter.atBot (𝓝 q)) →
+                (∀ᶠ u in 𝓝 y, Filter.Tendsto (fun t => F t (β u)) Filter.atTop (𝓝 p)) →
+                  let S : X × ℝ → M := fun w => F w.2 (α w.1)
+                  let T : Y × ℝ → M := fun w => F w.2 (β w.1)
+                  MDifferentiableAt (I.prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) S (x, 0) ∧
+                    MDifferentiableAt (I'.prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) T (y, 0) ∧
+                      S (x, 0) = (α x : M) ∧
+                        T (y, 0) = (α x : M) ∧
+                          (∀ᶠ u in 𝓝 (x, (0 : ℝ)),
+                              Filter.Tendsto (fun t => F t (S u)) Filter.atBot (𝓝 q)) ∧
+                            (∀ᶠ u in 𝓝 (y, (0 : ℝ)),
+                                Filter.Tendsto (fun t => F t (T u)) Filter.atTop (𝓝 p)) ∧
+                              Smale.NativeTransversality.At (I.prod 𝓘(ℝ, ℝ)) (I'.prod 𝓘(ℝ, ℝ))
+                                𝓘(ℝ, E) S T (x, 0) (y, 0) := by
+  let _ := Smale.RegularLevel.chartedSpace hf hreg
+  let _ := Smale.RegularLevel.isManifold hf hreg
+  intro α β x y hα hβ hcross htrans hαbasin hβbasin
+  obtain ⟨C, hsource, -, hformula, -⟩ :=
+    exists_native_level_flow_cylinder_with_field hf hreg hV F hF hboundary (α x)
+  have hxC : (α x, (0 : ℝ)) ∈ C.source := by rw [hsource]; exact Set.mem_univ _
+  have hyC : (β y, (0 : ℝ)) ∈ C.source := by rw [hsource]; exact Set.mem_univ _
+  have hS : MDifferentiableAt (I.prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) (fun w : X × ℝ => C (α w.1, w.2)) (x, 0) :=
+    (C.mdifferentiableAt (by simp) hxC).comp (x, 0)
+      ((hα.comp (x, 0) mdifferentiableAt_fst).prodMk mdifferentiableAt_snd)
+  have hT :
+    MDifferentiableAt (I'.prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) (fun w : Y × ℝ => C (β w.1, w.2)) (y, 0) :=
+    (C.mdifferentiableAt (by simp) hyC).comp (y, 0)
+      ((hβ.comp (y, 0) mdifferentiableAt_fst).prodMk mdifferentiableAt_snd)
+  have ht :=
+    Degree.TransverseGerms.native_transverse_sheets_of_level_maps C hα hβ (v := fun _ : X =>
+      (0 : ℝ)) (w := fun _ : Y => (0 : ℝ)) mdifferentiableAt_const mdifferentiableAt_const hcross
+      htrans (s := 0) (t := 0) rfl (by simpa only [add_zero] using hxC)
+  refine ⟨?_, ?_, F.map_zero_apply _, ?_, ?_, ?_, ?_⟩
+  · simpa only [hformula] using hS
+  · simpa only [hformula] using hT
+  · change F 0 (β y) = (α x : M)
+    rw [F.map_zero_apply, hcross]
+  · filter_upwards [continuous_fst.continuousAt hαbasin] with u hu
+    exact (MorseCancel.flow_time_atBot_limit_iff F u.2 (α u.1) q).mpr hu
+  · filter_upwards [continuous_fst.continuousAt hβbasin] with u hu
+    exact (MorseCancel.flow_time_atTop_limit_iff F u.2 (β u.1) p).mpr hu
+  · simpa only [add_zero, hformula] using ht
+
+private theorem
+    Degree.FlowSuspension.native_vertical_cylinder_flow {Z E M : Type*} [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, E) (Z × ℝ) M ∞) {U : Set Z}
+    (hsource : Φ.source = U ×ˢ Set.univ) {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hmodel :
+      ∀ x ∈ Φ.target,
+        V x = Smale.FlowConstruction.partialChartField Φ.symm (fun _ : Z × ℝ => (0, 1)) x)
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) (z : Z) (hz : z ∈ U)
+    (s t : ℝ) : F t (Φ (z, s)) = Φ (z, s + t) := by
+  let γ : ℝ → M := fun t => Φ (z, s + t)
+  have hγ : IsMIntegralCurve γ V := by
+    intro t
+    have hstay : (z, s + t) ∈ Φ.source := by rw [hsource]; exact ⟨hz, Set.mem_univ _⟩
+    have hcoord : HasDerivAt (fun r : ℝ => (z, s + r)) (0, 1) t :=
+      (hasDerivAt_const t z).prodMk ((hasDerivAt_id t).const_add s)
+    have hd :=
+      Smale.FlowConstruction.hasMFDerivAt_lift_partialChartCurve Φ.symm (fun _ : Z × ℝ => (0, 1))
+        hcoord hstay
+    change
+      HasMFDerivAt 𝓘(ℝ, ℝ) 𝓘(ℝ, E) γ t
+        ((1 : ℝ →L[ℝ] ℝ).smulRight
+          (Smale.FlowConstruction.partialChartField Φ.symm (fun _ : Z × ℝ => (0, 1)) (γ t))) at hd
+    rw [← hmodel (γ t) (Φ.map_source' hstay)] at hd
+    exact hd
+  have heq :=
+    isMIntegralCurve_Ioo_eq_of_contMDiff_boundaryless hV (hF (Φ (z, s))) hγ (t₀ := 0)
+      (by simp only [γ, F.map_zero_apply, add_zero])
+  exact congrFun heq t
+
+private theorem Degree.FlowSuspension.native_corrected_cylinder_tails {Z E M : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M]
+    (Φ Ω : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, E) (Z × ℝ) M ∞) {U : Set Z}
+    (hΦsource : Φ.source = U ×ˢ Set.univ) (hΩsource : Ω.source = U ×ˢ Set.univ)
+    {V W : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hW : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, W x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hΦmodel :
+      ∀ x ∈ Φ.target,
+        V x = Smale.FlowConstruction.partialChartField Φ.symm (fun _ : Z × ℝ => (0, 1)) x)
+    (hΩmodel :
+      ∀ x ∈ Ω.target,
+        W x = Smale.FlowConstruction.partialChartField Ω.symm (fun _ : Z × ℝ => (0, 1)) x)
+    (F G : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hG : ∀ x, IsMIntegralCurve (fun t => G t x) W) (D : Z → Z) (hDU : Set.MapsTo D U U)
+    (hleft : ∀ p, p.2 ≤ 0 → Ω p = Φ p) (hright : ∀ p, 1 ≤ p.2 → Ω p = Φ (D p.1, p.2)) :
+    (∀ z ∈ U, ∀ t : ℝ, t ≤ 0 → G t (Φ (z, 0)) = F t (Φ (z, 0))) ∧
+      (∀ z ∈ U, ∀ t : ℝ, 0 ≤ t → G t (Ω (z, 1)) = F t (Ω (z, 1))) := by
+  constructor
+  · intro z hz t ht
+    rw [← hleft (z, 0) le_rfl, native_vertical_cylinder_flow Ω hΩsource hW hΩmodel G hG z hz 0 t,
+      zero_add, hleft (z, t) ht, hleft (z, 0) le_rfl,
+      native_vertical_cylinder_flow Φ hΦsource hV hΦmodel F hF z hz 0 t, zero_add]
+  · intro z hz t ht
+    rw [native_vertical_cylinder_flow Ω hΩsource hW hΩmodel G hG z hz 1 t,
+      hright (z, 1 + t) (by dsimp; linarith), hright (z, 1) le_rfl,
+      native_vertical_cylinder_flow Φ hΦsource hV hΦmodel F hF (D z) (hDU hz) 1 t]
+
+private theorem Degree.FlowSuspension.phase_slice_flow_coordinates {D Z E M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (A : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, E) (Z × ℝ) M ∞) {U : Set Z}
+    (hsource : A.source = U ×ˢ Set.univ) (F : Flow ℝ M)
+    (hflow : ∀ z ∈ U, ∀ s t : ℝ, F t (A (z, s)) = A (z, s + t))
+    (Q : PartialDiffeomorph 𝓘(ℝ, D) 𝓘(ℝ, Z) D Z ∞) (hQU : Q.target ⊆ U) (S : D → M) (v : D → ℝ)
+    (T : ℝ) (hphase : ∀ u ∈ Q.source, S u = A (Q u, T + v u)) :
+    ∀ u ∈ Q.source,
+      ∀ t : ℝ, F (t - T) (S u) = A (Q u, t + v u) ∧ A.symm (F (t - T) (S u)) = (Q u, t + v u) := by
+  intro u hu t
+  have hq := hQU (Q.map_source' hu)
+  have hh : F (t - T) (S u) = A (Q u, t + v u) := by
+    rw [hphase u hu, hflow (Q u) hq]
+    exact congrArg (fun s : ℝ => A (Q u, s)) (by ring)
+  refine ⟨hh, ?_⟩
+  rw [hh]
+  apply A.left_inv'
+  rw [hsource]
+  exact ⟨hq, Set.mem_univ _⟩
+
+private theorem Degree.FlowSuspension.phase_flow_sheet_contMDiffAt {D Z E M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (A : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, E) (Z × ℝ) M ∞) {U : Set Z}
+    (hsource : A.source = U ×ˢ Set.univ) (F : Flow ℝ M)
+    (hflow : ∀ z ∈ U, ∀ s t : ℝ, F t (A (z, s)) = A (z, s + t))
+    (Q : PartialDiffeomorph 𝓘(ℝ, D) 𝓘(ℝ, Z) D Z ∞) (hQU : Q.target ⊆ U) (h0 : (0 : D) ∈ Q.source)
+    (hQ0 : Q 0 = 0) (S : D → M) (v : D → ℝ) (T : ℝ) (hv : ContDiff ℝ ∞ v) (hv0 : v 0 = 0)
+    (hphase : ∀ u ∈ Q.source, S u = A (Q u, T + v u)) :
+    ContMDiffAt 𝓘(ℝ, ℝ × D) 𝓘(ℝ, E) ∞ (fun w : ℝ × D => F (w.1 - T) (S w.2)) 0 := by
+  have h0U : (0 : Z) ∈ U := hQ0 ▸ hQU (Q.map_source' h0)
+  have h0A : ((0 : Z), (0 : ℝ)) ∈ A.source := by
+    rw [hsource]
+    exact ⟨h0U, Set.mem_univ _⟩
+  have hQ : ContDiffAt ℝ ∞ Q (0 : D) :=
+    Q.contMDiffOn_toFun.contDiffOn.contDiffAt (Q.open_source.mem_nhds h0)
+  have hparam : ContDiffAt ℝ ∞ (fun w : ℝ × D => (Q w.2, w.1 + v w.2)) 0 :=
+    (hQ.comp (f := fun w : ℝ × D => w.2) 0 contDiffAt_snd).prodMk
+      (contDiffAt_fst.add (hv.contDiffAt.comp (f := fun w : ℝ × D => w.2) 0 contDiffAt_snd))
+  have hAparam : (Q ((0 : ℝ × D).2), (0 : ℝ × D).1 + v (0 : ℝ × D).2) ∈ A.source := by
+    simpa only [Prod.fst_zero, Prod.snd_zero, hQ0, hv0, add_zero] using h0A
+  have hcomp : ContMDiffAt 𝓘(ℝ, ℝ × D) 𝓘(ℝ, E) ∞ (fun w : ℝ × D => A (Q w.2, w.1 + v w.2)) 0 :=
+    (A.contMDiffOn_toFun.contMDiffAt (A.open_source.mem_nhds hAparam)).comp (f := fun w : ℝ × D =>
+      (Q w.2, w.1 + v w.2)) 0 hparam.contMDiffAt
+  have hnear : ∀ᶠ w : ℝ × D in 𝓝 0, w.2 ∈ Q.source :=
+    continuous_snd.continuousAt.eventually (Q.open_source.mem_nhds h0)
+  apply hcomp.congr_of_eventuallyEq
+  filter_upwards [hnear] with w hw
+  exact (phase_slice_flow_coordinates A hsource F hflow Q hQU S v T hphase w.2 hw w.1).1
+
+private theorem Degree.FlowSuspension.phase_flow_subsheet_properties {D Z E M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {B : Type*}
+    [NormedAddCommGroup B] [NormedSpace ℝ B]
+    (A : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, E) (Z × ℝ) M ∞) {U : Set Z}
+    (hsource : A.source = U ×ˢ Set.univ) (F : Flow ℝ M)
+    (hflow : ∀ z ∈ U, ∀ s t : ℝ, F t (A (z, s)) = A (z, s + t))
+    (Q : PartialDiffeomorph 𝓘(ℝ, D) 𝓘(ℝ, Z) D Z ∞) (hQU : Q.target ⊆ U) (h0 : (0 : D) ∈ Q.source)
+    (hQ0 : Q 0 = 0) (S : D → M) (v : D → ℝ) (T : ℝ) (hv : ContDiff ℝ ∞ v) (hv0 : v 0 = 0)
+    (hphase : ∀ u ∈ Q.source, S u = A (Q u, T + v u)) (L : B →L[ℝ] D) :
+    ContMDiffAt 𝓘(ℝ, ℝ × B) 𝓘(ℝ, E) ∞ (fun w : ℝ × B => F (w.1 - T) (S (L w.2))) 0 ∧
+      F (-T) (S (L 0)) = A 0 ∧
+        (fun w : ℝ × B => (A.symm (F (w.1 - T) (S (L w.2)))).1) =ᶠ[𝓝 0]
+          (fun w : ℝ × B => Q (L w.2)) := by
+  have hbase := phase_flow_sheet_contMDiffAt A hsource F hflow Q hQU h0 hQ0 S v T hv hv0 hphase
+  have hparam : ContDiff ℝ ∞ (fun w : ℝ × B => (w.1, L w.2)) :=
+    contDiff_fst.prodMk (L.contDiff.comp contDiff_snd)
+  have hparam0 : ((0 : ℝ × B).1, L (0 : ℝ × B).2) = (0 : ℝ × D) := by simp
+  have hbase' :
+    ContMDiffAt 𝓘(ℝ, ℝ × D) 𝓘(ℝ, E) ∞ (fun w : ℝ × D => F (w.1 - T) (S w.2))
+      ((0 : ℝ × B).1, L (0 : ℝ × B).2) := by
+    rw [hparam0]
+    exact hbase
+  refine ⟨hbase'.comp (f := fun w : ℝ × B => (w.1, L w.2)) 0 hparam.contMDiff.contMDiffAt, ?_, ?_⟩
+  · have hh := (phase_slice_flow_coordinates A hsource F hflow Q hQU S v T hphase 0 h0 0).1
+    change F (-T) (S (L 0)) = A ((0 : Z), (0 : ℝ))
+    simpa only [map_zero, zero_sub, zero_add, hQ0, hv0] using hh
+  · have hnear : ∀ᶠ w : ℝ × B in 𝓝 0, L w.2 ∈ Q.source :=
+      (L.continuous.comp continuous_snd).continuousAt.eventually
+        (Q.open_source.mem_nhds (by simpa using h0))
+    filter_upwards [hnear] with w hw
+    exact
+      congrArg Prod.fst
+        (phase_slice_flow_coordinates A hsource F hflow Q hQU S v T hphase (L w.2) hw w.1).2
+
+private def Degree.FlowSuspension.phaseCylinderChart {E Z : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    (Q : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, Z) E Z ∞) (v : E → ℝ) (hv : ContDiff ℝ ∞ v) :
+    PartialDiffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, Z × ℝ) (E × ℝ) (Z × ℝ) ∞ := by
+  have hQ : ContDiffOn ℝ ∞ (fun p : E × ℝ => Q p.1) (Q.source ×ˢ Set.univ) :=
+    Q.contMDiffOn_toFun.contDiffOn.comp contDiff_fst.contDiffOn (fun p hp => hp.1)
+  have hQi : ContDiffOn ℝ ∞ (fun p : Z × ℝ => Q.symm p.1) (Q.target ×ˢ Set.univ) :=
+    Q.contMDiffOn_invFun.contDiffOn.comp contDiff_fst.contDiffOn (fun p hp => hp.1)
+  refine
+    { toFun := fun p => (Q p.1, p.2 + v p.1)
+      invFun := fun p => (Q.symm p.1, p.2 - v (Q.symm p.1))
+      source := Q.source ×ˢ Set.univ
+      target := Q.target ×ˢ Set.univ
+      map_source' := fun p hp => ⟨Q.map_source' hp.1, Set.mem_univ _⟩
+      map_target' := fun p hp => ⟨Q.map_target' hp.1, Set.mem_univ _⟩
+      left_inv' := ?_
+      right_inv' := ?_
+      open_source := Q.open_source.prod isOpen_univ
+      open_target := Q.open_target.prod isOpen_univ
+      contMDiffOn_toFun := ?_
+      contMDiffOn_invFun := ?_ }
+  · intro p hp
+    have hi : Q.symm (Q p.1) = p.1 := Q.left_inv' hp.1
+    change (Q.symm (Q p.1), p.2 + v p.1 - v (Q.symm (Q p.1))) = p
+    rw [hi, add_sub_cancel_right]
+  · intro p hp
+    have hi : Q (Q.symm p.1) = p.1 := Q.right_inv' hp.1
+    change (Q (Q.symm p.1), p.2 - v (Q.symm p.1) + v (Q.symm p.1)) = p
+    rw [hi, sub_add_cancel]
+  · exact (hQ.prodMk (contDiff_snd.contDiffOn.add (hv.comp contDiff_fst).contDiffOn)).contMDiffOn
+  · exact
+      (hQi.prodMk
+          (contDiff_snd.contDiffOn.sub
+            (hv.contDiffOn.comp hQi (Set.mapsTo_univ _ _)))).contMDiffOn
+
+private theorem Degree.FlowSuspension.phaseCylinderChart_target {E Z : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    (Q : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, Z) E Z ∞) (v : E → ℝ) (hv : ContDiff ℝ ∞ v) :
+    (phaseCylinderChart Q v hv).target = Q.target ×ˢ Set.univ :=
+  rfl
+
+private theorem
+    Degree.FlowSuspension.phaseCylinderChart_vertical {E Z : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    (Q : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, Z) E Z ∞) (v : E → ℝ) (hv : ContDiff ℝ ∞ v) {p : E × ℝ}
+    (hp : p ∈ (phaseCylinderChart Q v hv).source) :
+    fderiv ℝ (phaseCylinderChart Q v hv) p (0, 1) = (0, 1) := by
+  let R := phaseCylinderChart Q v hv
+  have hdiff :=
+    (R.contMDiffOn_toFun.contDiffOn.contDiffAt (R.open_source.mem_nhds hp)).differentiableAt
+      (by simp)
+  have hcurve : HasDerivAt (fun t : ℝ => (p.1, p.2 + t)) (0, 1) 0 :=
+    (hasDerivAt_const 0 p.1).prodMk ((hasDerivAt_id (0 : ℝ)).const_add p.2)
+  have hdiff' : HasFDerivAt R (fderiv ℝ R p) (p.1, p.2 + 0) := by
+    simpa only [add_zero, Prod.mk.eta] using hdiff.hasFDerivAt
+  have hd := hdiff'.comp_hasDerivAt (0 : ℝ) hcurve
+  have hd' : HasDerivAt (fun t : ℝ => (Q p.1, p.2 + t + v p.1)) (fderiv ℝ R p (0, 1)) 0 := by
+    convert! hd using 1
+  have he : HasDerivAt (fun t : ℝ => (Q p.1, p.2 + t + v p.1)) (0, 1) 0 :=
+    (hasDerivAt_const 0 (Q p.1)).prodMk
+      (((hasDerivAt_id (0 : ℝ)).const_add p.2).add_const (v p.1))
+  exact hd'.unique he
+
+private theorem Degree.FlowSuspension.exists_phase_flow_basin_chart {D Z E M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (A : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, E) (Z × ℝ) M ∞) {U : Set Z}
+    (hsource : A.source = U ×ˢ Set.univ) (F : Flow ℝ M)
+    (hflow : ∀ z ∈ U, ∀ s t : ℝ, F t (A (z, s)) = A (z, s + t))
+    (Q : PartialDiffeomorph 𝓘(ℝ, D) 𝓘(ℝ, Z) D Z ∞) (hQU : Q.target ⊆ U) (h0 : (0 : D) ∈ Q.source)
+    (hQ0 : Q 0 = 0) (S : D → M) (v : D → ℝ) (T : ℝ) (hv : ContDiff ℝ ∞ v) (hv0 : v 0 = 0)
+    (hphase : ∀ u ∈ Q.source, S u = A (Q u, T + v u)) (Basin : M → Prop)
+    (hshift : ∀ t x, Basin (F t x) ↔ Basin x) (R : D → Prop)
+    (hbasin : ∀ u ∈ Q.source, Basin (S u) ↔ R u) :
+    ∃ P : PartialDiffeomorph 𝓘(ℝ, D × ℝ) 𝓘(ℝ, E) (D × ℝ) M ∞,
+      P.source = Q.source ×ˢ Set.univ ∧
+        (0 : D × ℝ) ∈ P.source ∧
+          P 0 = A 0 ∧
+            (∀ u ∈ Q.source, ∀ t, P (u, t) = F (t - T) (S u)) ∧
+              ∀ w ∈ P.source, Basin (P w) ↔ R w.1 := by
+  let C := phaseCylinderChart Q v hv
+  let P := C.trans A
+  have hPsource : P.source = Q.source ×ˢ Set.univ := by
+    ext w
+    change (w ∈ Q.source ×ˢ Set.univ ∧ (Q w.1, w.2 + v w.1) ∈ A.source) ↔ w ∈ Q.source ×ˢ Set.univ
+    constructor
+    · exact And.left
+    · intro hw
+      refine ⟨hw, ?_⟩
+      rw [hsource]
+      exact ⟨hQU (Q.map_source' hw.1), Set.mem_univ _⟩
+  have hP0 : (0 : D × ℝ) ∈ P.source := by
+    rw [hPsource]
+    exact ⟨h0, Set.mem_univ _⟩
+  have hPzero : P 0 = A 0 := by
+    change A (Q 0, 0 + v 0) = A (0, 0)
+    rw [hQ0, hv0, zero_add]
+  have hPflow (u : D) (hu : u ∈ Q.source) (t : ℝ) : P (u, t) = F (t - T) (S u) :=
+    (phase_slice_flow_coordinates A hsource F hflow Q hQU S v T hphase u hu t).1.symm
+  refine ⟨P, hPsource, hP0, hPzero, hPflow, ?_⟩
+  intro w hw
+  rw [hPsource] at hw
+  rw [show P w = F (w.2 - T) (S w.1) from hPflow w.1 hw.1 w.2]
+  exact (hshift (w.2 - T) (S w.1)).trans (hbasin w.1 hw.1)
+
+private theorem Degree.FlowSuspension.phase_flow_chart_subsheet_germ {D E M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {B : Type*} [NormedAddCommGroup B] [NormedSpace ℝ B]
+    (P : PartialDiffeomorph 𝓘(ℝ, D × ℝ) 𝓘(ℝ, E) (D × ℝ) M ∞) {O : Set D} (hO : IsOpen O)
+    (h0 : (0 : D) ∈ O) (F : Flow ℝ M) (S : D → M) (T : ℝ)
+    (hformula : ∀ u ∈ O, ∀ t, P (u, t) = F (t - T) (S u)) (L : B →L[ℝ] D) :
+    (fun w : ℝ × B => F (w.1 - T) (S (L w.2))) =ᶠ[𝓝 0] (fun w : ℝ × B => P (L w.2, w.1)) := by
+  have hnear : ∀ᶠ w : ℝ × B in 𝓝 0, L w.2 ∈ O :=
+    (L.continuous.comp continuous_snd).continuousAt.eventually
+      (hO.mem_nhds (by simpa only [Function.comp_apply, Prod.snd_zero, map_zero] using h0))
+  filter_upwards [hnear] with w hw
+  exact (hformula (L w.2) hw w.1).symm
+
+private theorem
+    Degree.FlowCancellation.native_flow_chart_vertical {D E M : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (Φ : PartialDiffeomorph 𝓘(ℝ, D × ℝ) 𝓘(ℝ, E) (D × ℝ) M ∞) (F : Flow ℝ M)
+    (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) (ι : D → M)
+    (hformula : ∀ p : D × ℝ, Φ p = F p.2 (ι p.1)) :
+    ∀ x ∈ Φ.target, V x = Smale.FlowConstruction.partialChartField Φ.symm (fun _ => (0, 1)) x := by
+  intro x hx
+  let p := Φ.symm x
+  have hp : p ∈ Φ.source := Φ.map_target' hx
+  let α : ℝ → D × ℝ := fun t => (p.1, t)
+  have hα : HasDerivAt α ((0 : D), (1 : ℝ)) p.2 :=
+    (hasDerivAt_const p.2 p.1).prodMk (hasDerivAt_id p.2)
+  have hd :=
+    Smale.FlowConstruction.hasMFDerivAt_lift_partialChartCurve Φ.symm (fun _ : D × ℝ => (0, 1)) hα
+      hp
+  have heq : Φ.symm.symm ∘ α = fun t => F t (ι p.1) := funext (fun t => hformula (p.1, t))
+  rw [heq] at hd
+  change
+    HasMFDerivAt 𝓘(ℝ, ℝ) 𝓘(ℝ, E) (fun t => F t (ι p.1)) p.2
+      ((1 : ℝ →L[ℝ] ℝ).smulRight
+        (Smale.FlowConstruction.partialChartField Φ.symm (fun _ : D × ℝ => (0, 1)) (Φ p))) at hd
+  rw [hformula p] at hd
+  have hpF : F p.2 (ι p.1) = x := (hformula p).symm.trans (Φ.right_inv' hx)
+  have hh := (hcurve (ι p.1) p.2).mfderiv.symm.trans hd.mfderiv
+  have hv := congrArg (fun L : ℝ →L[ℝ] TangentSpace 𝓘(ℝ, E) (F p.2 (ι p.1)) => L (1 : ℝ)) hh
+  simp only [ContinuousLinearMap.smulRight_apply, one_apply_eq_self, one_smul] at hv
+  change
+    V (F p.2 (ι p.1)) =
+      Smale.FlowConstruction.partialChartField Φ.symm (fun _ : D × ℝ => (0, 1))
+        (F p.2 (ι p.1)) at hv
+  rw [hpF] at hv
+  exact hv
+
+private theorem Degree.FlowCancellation.exists_euclidean_level_flow_cylinder {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} [FiniteDimensional ℝ E] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [CompactSpace M] {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {c : ℝ}
+    (hreg : ∀ x, f x = c → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hboundary : ∀ x, f x = c → mvfderiv 𝓘(ℝ, E) f x (V x) < 0) {x : M} (hx : f x = c) :
+    ∃ (U : Set (Smale.RegularLevel.Model E)) (ι : Smale.RegularLevel.Model E → M) (Φ :
+      PartialDiffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E × ℝ) 𝓘(ℝ, E)
+        (Smale.RegularLevel.Model E × ℝ) M ∞),
+      IsOpen U ∧
+        (0 : Smale.RegularLevel.Model E) ∈ U ∧
+          ι 0 = x ∧
+            Φ.source = U ×ˢ Set.univ ∧
+              (∀ y ∈ U, f (ι y) = c) ∧
+                (∀ p, Φ p = F p.2 (ι p.1)) ∧
+                  ∀ y ∈ Φ.target,
+                    V y = Smale.FlowConstruction.partialChartField Φ.symm (fun _ => (0, 1)) y := by
+  let _ := Smale.RegularLevel.chartedSpace hf hreg
+  let _ := Smale.RegularLevel.isManifold hf hreg
+  let z : { x : M // f x = c } := ⟨x, hx⟩
+  obtain ⟨C, hCsource, -, hCformula, -⟩ :=
+    exists_native_level_flow_cylinder hf hreg hV F hcurve hboundary z
+  let Q := Smale.NativeParametrization.centered (D := Smale.RegularLevel.Model E) z
+  have hz : (0 : Smale.RegularLevel.Model E) ∈ Q.source :=
+    Smale.NativeParametrization.zero_mem_centered_source z
+  let A := Smale.PartialChart.prod Q (Diffeomorph.refl 𝓘(ℝ, ℝ) ℝ ∞).toPartialDiffeomorph
+  let P := (Smale.PartialChart.vectorProduct (Smale.RegularLevel.Model E) ℝ).toPartialDiffeomorph
+  let Φ := (P.trans A).trans C
+  let ι : Smale.RegularLevel.Model E → M := fun y => Q y
+  have hsource : Φ.source = Q.source ×ˢ Set.univ := by
+    ext p
+    change (p ∈ Set.univ ∧ (p.1 ∈ Q.source ∧ p.2 ∈ Set.univ)) ∧ A (P p) ∈ C.source ↔ _
+    rw [hCsource]
+    simp only [Set.mem_univ, true_and, and_true, Set.mem_prod]
+  have hformula (p : Smale.RegularLevel.Model E × ℝ) : Φ p = F p.2 (ι p.1) := hCformula (A (P p))
+  refine
+    ⟨Q.source, ι, Φ, Q.open_source, hz, ?_, hsource, fun y _ => (Q y).property, hformula,
+      native_flow_chart_vertical Φ F hcurve ι hformula⟩
+  exact congrArg Subtype.val (Smale.NativeParametrization.centered_zero z)
+
+private theorem Degree.FlowSuspension.exists_native_phase_cylinder {Z E B M : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup B] [NormedSpace ℝ B] [TopologicalSpace M] [ChartedSpace B M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, B) (Z × ℝ) M ∞) {U : Set Z}
+    (hsource : Φ.source = U ×ˢ Set.univ) (Q : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, Z) E Z ∞)
+    (hQtarget : Q.target = U) (v : E → ℝ) (hv : ContDiff ℝ ∞ v)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, B) x)
+    (hmodel :
+      ∀ y ∈ Φ.target,
+        V y = Smale.FlowConstruction.partialChartField Φ.symm (fun _ : Z × ℝ => (0, 1)) y) :
+    ∃ Ψ : PartialDiffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, B) (E × ℝ) M ∞,
+      Ψ.source = Q.source ×ˢ Set.univ ∧
+        Ψ.target = Φ.target ∧
+          (∀ p, Ψ p = Φ (Q p.1, p.2 + v p.1)) ∧
+            ∀ y ∈ Ψ.target,
+              V y = Smale.FlowConstruction.partialChartField Ψ.symm (fun _ : E × ℝ => (0, 1)) y :=
+  by
+  let R := phaseCylinderChart Q v hv
+  let Ψ := R.trans Φ
+  have hRtarget : R.target = Φ.source := by rw [phaseCylinderChart_target, hQtarget, hsource]
+  have hΨsource : Ψ.source = Q.source ×ˢ Set.univ := by
+    ext p
+    change (p ∈ R.source ∧ R p ∈ Φ.source) ↔ p ∈ Q.source ×ˢ Set.univ
+    constructor
+    · exact fun hp => hp.1
+    · intro hp
+      exact ⟨hp, hRtarget ▸ R.map_source' hp⟩
+  have hΨtarget : Ψ.target = Φ.target := by
+    ext y
+    change (y ∈ Φ.target ∧ Φ.symm y ∈ R.target) ↔ y ∈ Φ.target
+    constructor
+    · exact And.left
+    · exact fun hy => ⟨hy, hRtarget.symm ▸ Φ.map_target' hy⟩
+  refine ⟨Ψ, hΨsource, hΨtarget, fun _ => rfl, ?_⟩
+  intro y hy
+  rw [hmodel y (hΨtarget ▸ hy)]
+  exact
+    (MorseCancel.partialChartField_of_model_conjugacy R Φ (fun _ : E × ℝ => (0, 1))
+        (fun _ : Z × ℝ => (0, 1)) (fun p hp => phaseCylinderChart_vertical Q v hv hp) hy).symm
+
+private theorem Degree.FlowTimeChange.exists_arbitrary_gap_flow_cylinder {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {m : ℕ}
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = m + 1)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun y => (⟨y, V y⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hdesc : ∀ y, y ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f y (V y) < 0)
+    (F : Flow ℝ M) (hF : ∀ y, IsMIntegralCurve (fun t => F t y) V) {a b c : ℝ} (ha : a < c)
+    (hb : c < b) (hband : ∀ y, f y ∈ Set.Icc a b → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    {x : M} (hx : f x = c) :
+    ∃ (r : ℝ) (W : (y : M) → TangentSpace 𝓘(ℝ, E) y) (G : Flow ℝ M) (U : Set (Fin m → ℝ)) (Φ :
+      PartialDiffeomorph 𝓘(ℝ, (Fin m → ℝ) × ℝ) 𝓘(ℝ, E) ((Fin m → ℝ) × ℝ) M ∞),
+      0 < r ∧
+        ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun y => (⟨y, W y⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+          (∀ y, IsMIntegralCurve (fun t => G t y) W) ∧
+            (∀ y, W y = 0 ↔ V y = 0) ∧
+              (∀ y, y ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f y (W y) < 0) ∧
+                (∀ y ∈ Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ z in 𝓝 y, W z = V z) ∧
+                  (∀ y,
+                      Set.range (fun t => G t y) = Set.range (fun t => F t y) ∧
+                        (∀ p,
+                            Filter.Tendsto (fun t => G t y) Filter.atTop (𝓝 p) ↔
+                              Filter.Tendsto (fun t => F t y) Filter.atTop (𝓝 p)) ∧
+                          ∀ p,
+                            Filter.Tendsto (fun t => G t y) Filter.atBot (𝓝 p) ↔
+                              Filter.Tendsto (fun t => F t y) Filter.atBot (𝓝 p)) ∧
+                    IsOpen U ∧
+                      (0 : Fin m → ℝ) ∈ U ∧
+                        Φ.source = U ×ˢ Set.univ ∧
+                          (∀ t : ℝ, Φ (0, t) = G t x) ∧
+                            (∀ z ∈ Φ.source, z.2 ∈ Set.Icc (0 : ℝ) 1 → f (Φ z) = c - r * z.2) ∧
+                              ∀ y ∈ Φ.target,
+                                W y =
+                                  Smale.FlowConstruction.partialChartField Φ.symm
+                                    (fun _ : (Fin m → ℝ) × ℝ => (0, 1)) y := by
+  let r : ℝ := (c - a) / 2
+  have hr : 0 < r := div_pos (sub_pos.mpr ha) (by norm_num)
+  let g : M → ℝ := fun y => f y / r
+  have hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g := hf.div_const r
+  have hcrit : Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f :=
+    criticalPoints_height_div_const hf hr.ne'
+  have hdescent :
+    ∀ y, y ∉ Smale.ManifoldMorse.criticalPoints E g → mvfderiv 𝓘(ℝ, E) g y (V y) < 0 := by
+    intro y hy
+    rw [hcrit] at hy
+    exact
+      (descending_height_div_const_iff (hf.mdifferentiableAt (by simp)) hr (V y)).mpr (hdesc y hy)
+  have hregular :
+    ∀ y, g y ∈ Set.Icc (a / r) (b / r) → y ∉ Smale.ManifoldMorse.criticalPoints E g := by
+    intro y hy
+    rw [hcrit]
+    exact
+      hband y ⟨(div_le_div_iff_of_pos_right hr).mp hy.1, (div_le_div_iff_of_pos_right hr).mp hy.2⟩
+  obtain ⟨H, W, G, hH, hIH, hW, hG, hzero, hneg, hspeed, hgerms, _, hgeometry⟩ :=
+    exists_orbit_preserving_band_normalization hg hV hdescent F hF hregular
+  have hc : c / r ∈ Set.Icc (a / r) (b / r) :=
+    ⟨div_le_div_of_nonneg_right ha.le hr.le, div_le_div_of_nonneg_right hb.le hr.le⟩
+  have hreg (y : M) (hy : g y = c / r) : y ∉ Smale.ManifoldMorse.criticalPoints E g :=
+    hregular y (hy ▸ hc)
+  have hboundary (y : M) (hy : g y = c / r) : mvfderiv 𝓘(ℝ, E) g y (W y) < 0 := by
+    rw [hspeed y (hy ▸ hIH hc)]
+    norm_num
+  obtain ⟨O, ι, A, hO, h0O, hι0, hAsource, hlevel, hAmap, hAfield⟩ :=
+    Degree.FlowCancellation.exists_euclidean_level_flow_cylinder hg hreg hW G hG hboundary
+      (show g x = c / r by change f x / r = c / r; rw [hx])
+  let e : (Fin m → ℝ) ≃L[ℝ] Smale.RegularLevel.Model E :=
+    ContinuousLinearEquiv.ofFinrankEq (by simp [Smale.RegularLevel.Model, hdim])
+  let Q := Smale.PartialChart.restrictTarget e.toDiffeomorph.toPartialDiffeomorph hO
+  have hQtarget : Q.target = O := by
+    ext z
+    change (z ∈ (Set.univ : Set (Smale.RegularLevel.Model E)) ∧ z ∈ O) ↔ z ∈ O
+    simp only [Set.mem_univ, true_and]
+  have hQ0 : (0 : Fin m → ℝ) ∈ Q.source := by
+    change (0 : Fin m → ℝ) ∈ Set.univ ∧ e 0 ∈ O
+    rw [map_zero]
+    exact ⟨Set.mem_univ _, h0O⟩
+  obtain ⟨Φ, hΦsource, _, hΦmap, hΦfield⟩ :=
+    Degree.FlowSuspension.exists_native_phase_cylinder A hAsource Q hQtarget (fun _ => (0 : ℝ))
+      contDiff_const W hAfield
+  have hmap (z : (Fin m → ℝ) × ℝ) : Φ z = A (Q z.1, z.2) := by rw [hΦmap, add_zero]
+  have hnegf (y : M) (hy : y ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    mvfderiv 𝓘(ℝ, E) f y (W y) < 0 :=
+    (descending_height_div_const_iff (hf.mdifferentiableAt (by simp)) hr (W y)).mp
+      (hneg y (hcrit ▸ hy))
+  refine
+    ⟨r, W, G, Q.source, Φ, hr, hW, hG, hzero, hnegf, (fun y hy => hgerms y (hcrit ▸ hy)),
+      hgeometry, Q.open_source, hQ0, hΦsource, ?_, ?_, hΦfield⟩
+  · intro t
+    rw [hmap, hAmap]
+    change G t (ι (e 0)) = G t x
+    rw [map_zero, hι0]
+  · intro z hz ht
+    rw [hΦsource] at hz
+    have hQo : Q z.1 ∈ O := hQtarget ▸ Q.map_source' hz.1
+    have hi : g (ι (Q z.1)) = c / r := hlevel _ hQo
+    have he : c / r - z.2 = (c - r * z.2) / r := by field_simp
+    have hend : g (ι (Q z.1)) - z.2 ∈ Set.Icc (a / r) (b / r) := by
+      rw [hi, he]
+      constructor
+      · apply div_le_div_of_nonneg_right _ hr.le
+        dsimp [r]
+        nlinarith [ht.2]
+      · apply div_le_div_of_nonneg_right _ hr.le
+        nlinarith [mul_nonneg hr.le ht.1]
+    have hh :=
+      native_local_height_translation hg G hG hH hIH hspeed (ι (Q z.1)) z.2 (hi ▸ hc) hend
+    rw [hi, he] at hh
+    have hhf : f (G z.2 (ι (Q z.1))) = c - r * z.2 := (div_left_inj' hr.ne').mp hh
+    rw [hmap, hAmap]
+    exact hhf
+
+private theorem Degree.FlowTimeChange.exists_normalized_connection_cylinder {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {m : ℕ} {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hdim : Module.finrank ℝ E = m + 1)
+    (V : (y : M) → TangentSpace 𝓘(ℝ, E) y)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun y => (⟨y, V y⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hzero : ∀ y ∈ Smale.ManifoldMorse.criticalPoints E f, V y = 0)
+    (hdesc : ∀ y, y ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f y (V y) < 0)
+    (F : Flow ℝ M) (hF : ∀ y, IsMIntegralCurve (fun t => F t y) V) {p q x : M} (hpq : f p < f q)
+    {c d : ℝ} (hc : c < f p) (hd : f q < d)
+    (hpair : ∀ y ∈ Smale.ManifoldMorse.criticalPoints E f, f y ∈ Set.Icc c d → y = p ∨ y = q)
+    (hp : Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p))
+    (hq : Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 q))
+    (hunique :
+      ∀ y,
+        Filter.Tendsto (fun t => F t y) Filter.atBot (𝓝 q) →
+          Filter.Tendsto (fun t => F t y) Filter.atTop (𝓝 p) → ∃ t, F t x = y) :
+    ∃ (x₀ : M) (r b : ℝ) (W : (y : M) → TangentSpace 𝓘(ℝ, E) y) (G : Flow ℝ M) (U :
+      Set (Fin m → ℝ)) (A :
+      PartialDiffeomorph 𝓘(ℝ, (Fin m → ℝ) × ℝ) 𝓘(ℝ, E) ((Fin m → ℝ) × ℝ) M ∞),
+      x₀ ≠ p ∧
+        x₀ ≠ q ∧
+          0 < r ∧
+            ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞
+                (fun y => (⟨y, W y⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+              (∀ y, IsMIntegralCurve (fun t => G t y) W) ∧
+                (∀ y ∈ Smale.ManifoldMorse.criticalPoints E f, W y = 0) ∧
+                  (∀ y,
+                      y ∉ Smale.ManifoldMorse.criticalPoints E f →
+                        mvfderiv 𝓘(ℝ, E) f y (W y) < 0) ∧
+                    (∀ y ∈ Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ z in 𝓝 y, W z = V z) ∧
+                      (∀ y, Antitone (fun t => f (G t y))) ∧
+                        Filter.Tendsto (fun t => G t x₀) Filter.atTop (𝓝 p) ∧
+                          Filter.Tendsto (fun t => G t x₀) Filter.atBot (𝓝 q) ∧
+                            (∀ y,
+                                Filter.Tendsto (fun t => G t y) Filter.atBot (𝓝 q) →
+                                  Filter.Tendsto (fun t => G t y) Filter.atTop (𝓝 p) →
+                                    ∃ t, G t x₀ = y) ∧
+                              IsOpen U ∧
+                                (0 : Fin m → ℝ) ∈ U ∧
+                                  A.source = U ×ˢ Set.univ ∧
+                                    (∀ t : ℝ, A (0, t) = G t x₀) ∧
+                                      (∀ z ∈ A.source,
+                                          z.2 ∈ Set.Icc (0 : ℝ) 1 → f (A z) = b - r * z.2) ∧
+                                        (∀ y ∈ A.target,
+                                            W y =
+                                              Smale.FlowConstruction.partialChartField A.symm
+                                                (fun _ : (Fin m → ℝ) × ℝ => (0, 1)) y) ∧
+                                          (∀ y,
+                                              Set.range (fun t => G t y) =
+                                                  Set.range (fun t => F t y) ∧
+                                                (∀ z,
+                                                    Filter.Tendsto (fun t => G t y) Filter.atTop
+                                                        (𝓝 z) ↔
+                                                      Filter.Tendsto (fun t => F t y) Filter.atTop
+                                                        (𝓝 z)) ∧
+                                                  ∀ z,
+                                                    Filter.Tendsto (fun t => G t y) Filter.atBot
+                                                        (𝓝 z) ↔
+                                                      Filter.Tendsto (fun t => F t y) Filter.atBot
+                                                        (𝓝 z)) ∧
+                                            ∃ t, F t x = x₀ := by
+  let b : ℝ := (f p + f q) / 2
+  let lo : ℝ := (f p + b) / 2
+  let hi : ℝ := (b + f q) / 2
+  have hpb : f p < b := by dsimp [b]; linarith
+  have hbq : b < f q := by dsimp [b]; linarith
+  have hplo : f p < lo := by dsimp [lo]; linarith
+  have hlob : lo < b := by dsimp [lo]; linarith
+  have hbhi : b < hi := by dsimp [hi]; linarith
+  have hhiq : hi < f q := by dsimp [hi]; linarith
+  have hband : ∀ y, f y ∈ Set.Icc lo hi → y ∉ Smale.ManifoldMorse.criticalPoints E f := by
+    intro y hy hcrit
+    have houter : f y ∈ Set.Icc c d := ⟨by linarith [hy.1], by linarith [hy.2]⟩
+    rcases hpair y hcrit houter with he | he
+    · rw [he] at hy
+      exact (not_le_of_gt hplo) hy.1
+    · rw [he] at hy
+      exact (not_le_of_gt hhiq) hy.2
+  obtain ⟨t₀, ht₀⟩ :=
+    Degree.FlowCancellation.exists_level_crossing_of_endpoint_limits F hf.continuous hq hp hbq hpb
+  let x₀ := F t₀ x
+  have hxp : x₀ ≠ p := by
+    intro hh
+    have hv : f p = b := hh ▸ ht₀
+    exact hpb.ne hv
+  have hxq : x₀ ≠ q := by
+    intro hh
+    have hv : f q = b := hh ▸ ht₀
+    exact hbq.ne hv.symm
+  have hp₀ : Filter.Tendsto (fun t => F t x₀) Filter.atTop (𝓝 p) :=
+    (MorseCancel.flow_time_atTop_limit_iff F t₀ x p).mpr hp
+  have hq₀ : Filter.Tendsto (fun t => F t x₀) Filter.atBot (𝓝 q) :=
+    (MorseCancel.flow_time_atBot_limit_iff F t₀ x q).mpr hq
+  have hunique₀ :
+    ∀ y,
+      Filter.Tendsto (fun t => F t y) Filter.atBot (𝓝 q) →
+        Filter.Tendsto (fun t => F t y) Filter.atTop (𝓝 p) → ∃ t, F t x₀ = y := by
+    intro y hyq hyp
+    obtain ⟨t, ht⟩ := hunique y hyq hyp
+    refine ⟨t - t₀, ?_⟩
+    change F (t - t₀) (F t₀ x) = y
+    rw [← F.map_add, sub_add_cancel]
+    exact ht
+  obtain
+    ⟨r, W, G, U, A, hr, hW, hG, hWzero, hWdesc, hgerms, hgeometry, hU, h0U, hsource, haxis,
+      hheight, hfield⟩ :=
+    exists_arbitrary_gap_flow_cylinder hf hdim hV hdesc F hF hlob hbhi hband ht₀
+  have hzeros : ∀ y ∈ Smale.ManifoldMorse.criticalPoints E f, W y = 0 := fun y hy =>
+    (hWzero y).mpr (hzero y hy)
+  have huniqueG :
+    ∀ y,
+      Filter.Tendsto (fun t => G t y) Filter.atBot (𝓝 q) →
+        Filter.Tendsto (fun t => G t y) Filter.atTop (𝓝 p) → ∃ t, G t x₀ = y := by
+    intro y hyq hyp
+    have hh : y ∈ Set.range (fun t => F t x₀) :=
+      hunique₀ y ((hgeometry y).2.2 q |>.mp hyq) ((hgeometry y).2.1 p |>.mp hyp)
+    rw [← (hgeometry x₀).1] at hh
+    exact hh
+  exact
+    ⟨x₀, r, b, W, G, U, A, hxp, hxq, hr, hW, hG, hzeros, hWdesc, hgerms,
+      Smale.FlowConstruction.antitone_flow_height hf G hG hzeros hWdesc,
+      (hgeometry x₀).2.1 p |>.mpr hp₀, (hgeometry x₀).2.2 q |>.mpr hq₀, huniqueG, hU, h0U,
+      hsource, haxis, hheight, hfield, hgeometry, t₀, rfl⟩
+
+private theorem MorseCancel.cubicFlowCylinder_pushforward_vertical {m : ℕ} (σ : Fin m → ℝ) (a : ℝ)
+    (p : (Fin m → ℝ) × ℝ) :
+    fderiv ℝ (cubicFlowCylinder σ a) p (0, 1) =
+      cubicDescent σ (-(a ^ 2)) (cubicFlowCylinder σ a p) := by
+  have hd :=
+    ((contDiff_cubicFlowCylinder σ a).differentiable (by simp) p).hasFDerivAt |>.comp_hasDerivAt
+      p.2 ((hasDerivAt_const p.2 p.1).prodMk (hasDerivAt_id p.2))
+  have hd' := hasDerivAt_cubicFlowCylinder σ a p.1 p.2
+  exact hd.unique hd'
+
+private theorem Degree.FlowSuspension.native_field_transition_pushforward {D B E M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (A : PartialDiffeomorph 𝓘(ℝ, D) 𝓘(ℝ, E) D M ∞) (C : PartialDiffeomorph 𝓘(ℝ, B) 𝓘(ℝ, E) B M ∞)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x) (WA : D → D) (WC : B → B)
+    (hA : ∀ x ∈ A.target, V x = Smale.FlowConstruction.partialChartField A.symm WA x)
+    (hC : ∀ x ∈ C.target, V x = Smale.FlowConstruction.partialChartField C.symm WC x) {p : D}
+    (hp : p ∈ (A.trans C.symm).source) : fderiv ℝ (C.symm ∘ A) p (WA p) = WC (C.symm (A p)) := by
+  have hpA : p ∈ A.source := hp.1
+  have hpC : A p ∈ C.target := hp.2
+  have hpushA :
+    mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) A p ((NormedSpace.fromTangentSpace p).symm (WA p)) = V (A p) := by
+    have hh := hA (A p) (A.map_source' hpA)
+    rw [Smale.FlowConstruction.partialChartField_eq_mfderiv_symm A.symm WA
+        (A.map_source' hpA)] at hh
+    have hi : A.symm (A p) = p := A.left_inv' hpA
+    rw [hi] at hh
+    exact hh.symm
+  have hdiff : C.symm.toOpenPartialHomeomorph.MDifferentiable 𝓘(ℝ, E) 𝓘(ℝ, B) :=
+    ⟨C.symm.mdifferentiableOn (by simp), C.mdifferentiableOn (by simp)⟩
+  have hinv : (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, B) C.symm (A p)).IsInvertible := ⟨hdiff.mfderiv hpC, rfl⟩
+  have hpushC :
+    mfderiv 𝓘(ℝ, E) 𝓘(ℝ, B) C.symm (A p) (V (A p)) =
+      (NormedSpace.fromTangentSpace (C.symm (A p))).symm (WC (C.symm (A p))) := by
+    rw [hC (A p) hpC]
+    unfold Smale.FlowConstruction.partialChartField
+    rw [VectorField.mpullback_apply]
+    exact hinv.self_apply_inverse _
+  rw [← mfderiv_eq_fderiv,
+    mfderiv_comp p (C.symm.mdifferentiableAt (by simp) hpC) (A.mdifferentiableAt (by simp) hpA)]
+  change
+    (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, B) C.symm (A p))
+        ((mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) A p) ((NormedSpace.fromTangentSpace p).symm (WA p))) =
+      _
+  rw [hpushA]
+  exact hpushC
+
+private theorem Degree.FlowSuspension.native_vertical_transition_derivative {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {Z : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    (A C : PartialDiffeomorph 𝓘(ℝ, ℝ × Z) 𝓘(ℝ, E) (ℝ × Z) M ∞)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hA :
+      ∀ x ∈ A.target,
+        V x = Smale.FlowConstruction.partialChartField A.symm (fun _ : ℝ × Z => (1, 0)) x)
+    (hC :
+      ∀ x ∈ C.target,
+        V x = Smale.FlowConstruction.partialChartField C.symm (fun _ : ℝ × Z => (1, 0)) x)
+    {p : ℝ × Z} (hp : p ∈ (A.trans C.symm).source) : fderiv ℝ (C.symm ∘ A) p (1, 0) = (1, 0) :=
+  native_field_transition_pushforward A C V (fun _ => (1, 0)) (fun _ => (1, 0)) hA hC hp
+
+private theorem Degree.FlowSuspension.vertical_transition_formula {Z : Type*} [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] (R : PartialDiffeomorph 𝓘(ℝ, ℝ × Z) 𝓘(ℝ, ℝ × Z) (ℝ × Z) (ℝ × Z) ∞)
+    (hvertical : ∀ p ∈ R.source, fderiv ℝ R p (1, 0) = (1, 0)) {I : Set ℝ} (hI : IsOpen I)
+    (hconn : IsPreconnected I) {U : Set Z} (hsub : I ×ˢ U ⊆ R.source) {t₀ t : ℝ} (h₀ : t₀ ∈ I)
+    (ht : t ∈ I) {z : Z} (hz : z ∈ U) : R (t, z) = (t + ((R (t₀, z)).1 - t₀), (R (t₀, z)).2) := by
+  let γ : ℝ → ℝ × Z := fun s => R (s, z) - (s, 0)
+  have hd (s : ℝ) (hs : s ∈ I) : HasDerivAt γ 0 s := by
+    have hp := hsub (show (s, z) ∈ I ×ˢ U from ⟨hs, hz⟩)
+    have hR :=
+      (R.contMDiffOn_toFun.contDiffOn.contDiffAt (R.open_source.mem_nhds hp)).differentiableAt
+        (by simp)
+    have hh := hR.hasFDerivAt.comp_hasDerivAt s ((hasDerivAt_id s).prodMk (hasDerivAt_const s z))
+    have hh' : HasDerivAt (fun u => R (u, z)) (1, (0 : Z)) s := by
+      convert! hh using 1
+      exact (hvertical (s, z) hp).symm
+    have hdiff := hh'.sub ((hasDerivAt_id s).prodMk (hasDerivAt_const s (0 : Z)))
+    convert! hdiff using 1; simp []
+  have heq : γ t = γ t₀ :=
+    hI.is_const_of_deriv_eq_zero hconn
+      (fun s hs => (hd s hs).differentiableAt.differentiableWithinAt)
+      (fun s hs => (hd s hs).deriv) ht h₀
+  apply Prod.ext
+  · have hh : (R (t, z)).1 - t = (R (t₀, z)).1 - t₀ := congrArg Prod.fst heq
+    linarith
+  · have hh : (R (t, z)).2 - 0 = (R (t₀, z)).2 - 0 := congrArg Prod.snd heq
+    simpa only [sub_zero] using hh
+
+private theorem
+    Degree.FlowSuspension.exists_vertical_transition_phase {Z : Type*} [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] (R : PartialDiffeomorph 𝓘(ℝ, ℝ × Z) 𝓘(ℝ, ℝ × Z) (ℝ × Z) (ℝ × Z) ∞)
+    (hvertical : ∀ p ∈ R.source, fderiv ℝ R p (1, 0) = (1, 0)) {t₀ : ℝ}
+    (hp : (t₀, (0 : Z)) ∈ R.source) (hfix : R (t₀, 0) = (t₀, 0)) :
+    ∃ (ε : ℝ) (P : Z → Z) (v : Z → ℝ),
+      0 < ε ∧
+        ContDiffOn ℝ ∞ P (Metric.ball 0 ε) ∧
+          ContDiffOn ℝ ∞ v (Metric.ball 0 ε) ∧
+            P 0 = 0 ∧
+              v 0 = 0 ∧
+                Set.Ioo (t₀ - ε) (t₀ + ε) ×ˢ Metric.ball (0 : Z) ε ⊆ R.source ∧
+                  ∀ t ∈ Set.Ioo (t₀ - ε) (t₀ + ε),
+                    ∀ z ∈ Metric.ball (0 : Z) ε, R (t, z) = (t + v z, P z) := by
+  obtain ⟨ε, hε, hball⟩ := Metric.mem_nhds_iff.mp (R.open_source.mem_nhds hp)
+  have hsub : Set.Ioo (t₀ - ε) (t₀ + ε) ×ˢ Metric.ball (0 : Z) ε ⊆ R.source := by
+    rintro ⟨t, z⟩ ⟨ht, hz⟩
+    apply hball
+    rw [← ball_prod_same]
+    refine ⟨?_, hz⟩
+    rw [Metric.mem_ball, Real.dist_eq]
+    exact abs_lt.mpr ⟨by linarith [ht.1], by linarith [ht.2]⟩
+  have ht₀ : t₀ ∈ Set.Ioo (t₀ - ε) (t₀ + ε) := ⟨by linarith, by linarith⟩
+  let P : Z → Z := fun z => (R (t₀, z)).2
+  let v : Z → ℝ := fun z => (R (t₀, z)).1 - t₀
+  have hc : ContDiffOn ℝ ∞ (fun z : Z => R (t₀, z)) (Metric.ball 0 ε) :=
+    R.contMDiffOn_toFun.contDiffOn.comp (contDiff_const.prodMk contDiff_id).contDiffOn
+      (fun z hz => hsub ⟨ht₀, hz⟩)
+  refine
+    ⟨ε, P, v, hε, contDiff_snd.comp_contDiffOn hc,
+      (contDiff_fst.comp_contDiffOn hc).sub contDiffOn_const, ?_, ?_, hsub, ?_⟩
+  · change (R (t₀, 0)).2 = 0
+    rw [hfix]
+  · change (R (t₀, 0)).1 - t₀ = 0
+    rw [hfix, sub_self]
+  · intro t ht z hz
+    exact vertical_transition_formula R hvertical isOpen_Ioo isPreconnected_Ioo hsub ht₀ ht hz
+
+private theorem Degree.FlowSuspension.exists_transverse_transition_chart {Z : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z]
+    (R : PartialDiffeomorph 𝓘(ℝ, ℝ × Z) 𝓘(ℝ, ℝ × Z) (ℝ × Z) (ℝ × Z) ∞)
+    (hvertical : ∀ p ∈ R.source, fderiv ℝ R p (1, 0) = (1, 0)) {t₀ : ℝ}
+    (hp : (t₀, (0 : Z)) ∈ R.source) (hfix : R (t₀, 0) = (t₀, 0)) :
+    ∃ (ε : ℝ) (P : PartialDiffeomorph 𝓘(ℝ, Z) 𝓘(ℝ, Z) Z Z ∞) (v : Z → ℝ),
+      0 < ε ∧
+        (0 : Z) ∈ P.source ∧
+          P 0 = 0 ∧
+            v 0 = 0 ∧
+              ContDiffOn ℝ ∞ v P.source ∧
+                Set.Ioo (t₀ - ε) (t₀ + ε) ×ˢ P.source ⊆ R.source ∧
+                  ∀ t ∈ Set.Ioo (t₀ - ε) (t₀ + ε), ∀ z ∈ P.source, R (t, z) = (t + v z, P z) := by
+  obtain ⟨ε, Q, v, hε, hQ, hv, hQ0, hv0, hsub, hformula⟩ :=
+    exists_vertical_transition_phase R hvertical hp hfix
+  have ht₀ : t₀ ∈ Set.Ioo (t₀ - ε) (t₀ + ε) := ⟨by linarith, by linarith⟩
+  have hQeq : Q =ᶠ[𝓝 (0 : Z)] (fun z => (R (t₀, z)).2) := by
+    filter_upwards [Metric.ball_mem_nhds (0 : Z) hε] with z hz
+    exact (congrArg Prod.snd (hformula t₀ ht₀ z hz)).symm
+  have hRdiff :=
+    (R.contMDiffOn_toFun.contDiffOn.contDiffAt (R.open_source.mem_nhds hp)).differentiableAt
+      (by simp)
+  have hι : HasFDerivAt (fun z : Z => (t₀, z)) (ContinuousLinearMap.inr ℝ ℝ Z) 0 := by
+    exact (hasFDerivAt_const t₀ (0 : Z)).prodMk (hasFDerivAt_id (0 : Z))
+  have hslice :
+    HasFDerivAt (fun z : Z => (R (t₀, z)).2)
+      (Degree.AxisCoordinates.transverseBlock (fderiv ℝ R (t₀, 0))) 0 :=
+    (hasFDerivAt_snd (𝕜 := ℝ) (p := R (t₀, 0))).comp 0 (hRdiff.hasFDerivAt.comp 0 hι)
+  have hfull : (fderiv ℝ R (t₀, 0)).IsInvertible := by
+    have hl : IsLocalDiffeomorphAt 𝓘(ℝ, ℝ × Z) 𝓘(ℝ, ℝ × Z) ∞ R (t₀, 0) := ⟨R, hp, fun _ _ => rfl⟩
+    refine ⟨hl.mfderivToContinuousLinearEquiv (by simp), ?_⟩
+    have he := hl.mfderivToContinuousLinearEquiv_coe (by simp)
+    rw [mfderiv_eq_fderiv] at he
+    exact he
+  have hQinv : (fderiv ℝ Q 0).IsInvertible := by
+    rw [hQeq.fderiv_eq, hslice.fderiv]
+    exact Degree.AxisCoordinates.isInvertible_transverseBlock _ (hvertical (t₀, 0) hp) hfull
+  obtain ⟨P, hP0, hPsub, hPmap⟩ :=
+    NoExotic.exists_partialDiffeomorph_of_contDiffOn Metric.isOpen_ball (Metric.mem_ball_self hε)
+      hQ hQinv
+  refine ⟨ε, P, v, hε, hP0, ?_, hv0, hv.mono hPsub, ?_, ?_⟩
+  · rw [hPmap]
+    exact hQ0
+  · rintro ⟨t, z⟩ ⟨ht, hz⟩
+    exact hsub ⟨ht, hPsub hz⟩
+  · intro t ht z hz
+    rw [hPmap]
+    exact hformula t ht z (hPsub hz)
+
+private theorem Degree.FlowSuspension.exists_native_transition_phase {Z E M : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (A C : PartialDiffeomorph 𝓘(ℝ, ℝ × Z) 𝓘(ℝ, E) (ℝ × Z) M ∞)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hA :
+      ∀ x ∈ A.target,
+        V x = Smale.FlowConstruction.partialChartField A.symm (fun _ : ℝ × Z => (1, 0)) x)
+    (hC :
+      ∀ x ∈ C.target,
+        V x = Smale.FlowConstruction.partialChartField C.symm (fun _ : ℝ × Z => (1, 0)) x)
+    {t₀ : ℝ} (hpA : (t₀, (0 : Z)) ∈ A.source) (hpC : (t₀, (0 : Z)) ∈ C.source)
+    (hpoint : A (t₀, 0) = C (t₀, 0)) :
+    ∃ (ε : ℝ) (P : PartialDiffeomorph 𝓘(ℝ, Z) 𝓘(ℝ, Z) Z Z ∞) (v : Z → ℝ),
+      0 < ε ∧
+        (0 : Z) ∈ P.source ∧
+          P 0 = 0 ∧
+            v 0 = 0 ∧
+              ContDiffOn ℝ ∞ v P.source ∧
+                ∀ t ∈ Set.Ioo (t₀ - ε) (t₀ + ε),
+                  ∀ z ∈ P.source,
+                    (t, z) ∈ A.source ∧ (t + v z, P z) ∈ C.source ∧ A (t, z) = C (t + v z, P z) :=
+  by
+  let R := A.trans C.symm
+  have hp : (t₀, (0 : Z)) ∈ R.source := by
+    refine ⟨hpA, ?_⟩
+    change A (t₀, 0) ∈ C.target
+    rw [hpoint]
+    exact C.map_source' hpC
+  have hfix : R (t₀, 0) = (t₀, 0) := by
+    change C.symm (A (t₀, 0)) = (t₀, 0)
+    rw [hpoint]
+    exact C.left_inv' hpC
+  have hvertical (p : ℝ × Z) (hp : p ∈ R.source) : fderiv ℝ R p (1, 0) = (1, 0) :=
+    native_vertical_transition_derivative A C V hA hC hp
+  obtain ⟨ε, P, v, hε, hP0, hPzero, hv0, hv, hsub, hformula⟩ :=
+    exists_transverse_transition_chart R hvertical hp hfix
+  refine ⟨ε, P, v, hε, hP0, hPzero, hv0, hv, ?_⟩
+  intro t ht z hz
+  have hpR : (t, z) ∈ R.source := hsub ⟨ht, hz⟩
+  have hmap : C.symm (A (t, z)) = (t + v z, P z) := hformula t ht z hz
+  refine ⟨hpR.1, ?_, ?_⟩
+  · have hh : C.symm (A (t, z)) ∈ C.source := C.map_target' hpR.2
+    rwa [hmap] at hh
+  · have hh : C (C.symm (A (t, z))) = A (t, z) := C.right_inv' hpR.2
+    rw [hmap] at hh
+    exact hh.symm
+
+private theorem Degree.FlowSuspension.exists_global_native_transition_phase {Z E M : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (A C : PartialDiffeomorph 𝓘(ℝ, ℝ × Z) 𝓘(ℝ, E) (ℝ × Z) M ∞)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hA :
+      ∀ x ∈ A.target,
+        V x = Smale.FlowConstruction.partialChartField A.symm (fun _ : ℝ × Z => (1, 0)) x)
+    (hC :
+      ∀ x ∈ C.target,
+        V x = Smale.FlowConstruction.partialChartField C.symm (fun _ : ℝ × Z => (1, 0)) x)
+    {t₀ : ℝ} (hpA : (t₀, (0 : Z)) ∈ A.source) (hpC : (t₀, (0 : Z)) ∈ C.source)
+    (hpoint : A (t₀, 0) = C (t₀, 0)) :
+    ∃ (ε : ℝ) (P : PartialDiffeomorph 𝓘(ℝ, Z) 𝓘(ℝ, Z) Z Z ∞) (v : Z → ℝ),
+      0 < ε ∧
+        (0 : Z) ∈ P.source ∧
+          P 0 = 0 ∧
+            v 0 = 0 ∧
+              ContDiff ℝ ∞ v ∧
+                ∀ t ∈ Set.Ioo (t₀ - ε) (t₀ + ε),
+                  ∀ z ∈ P.source,
+                    (t, z) ∈ A.source ∧ (t + v z, P z) ∈ C.source ∧ A (t, z) = C (t + v z, P z) :=
+  by
+  obtain ⟨ε, P, v, hε, hP0, hPzero, hv0, hv, hformula⟩ :=
+    exists_native_transition_phase A C V hA hC hpA hpC hpoint
+  have hzero : ({0} : Set Z) ⊆ P.source := Set.singleton_subset_iff.mpr hP0
+  obtain ⟨g, hg, W, hW, h0W, hWsub, heq⟩ :=
+    LineBundleTransport.exists_smooth_extension_near_closed isClosed_singleton P.open_source hzero
+      hv
+  let Q := Smale.PartialChart.restrictSource P hW
+  have hQ0 : (0 : Z) ∈ Q.source := ⟨hP0, h0W (Set.mem_singleton 0)⟩
+  have hg0 : g 0 = 0 := (heq (h0W (Set.mem_singleton 0))).trans hv0
+  refine ⟨ε, Q, g, hε, hQ0, hPzero, hg0, hg, ?_⟩
+  intro t ht z hz
+  have hh := hformula t ht z hz.1
+  change (t, z) ∈ A.source ∧ (t + g z, P z) ∈ C.source ∧ A (t, z) = C (t + g z, P z)
+  rw [heq hz.2]
+  exact hh
+
+private theorem Degree.FlowSuspension.exists_time_last_native_transition_phase {Z E M : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (A C : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, E) (Z × ℝ) M ∞)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hA :
+      ∀ x ∈ A.target,
+        V x = Smale.FlowConstruction.partialChartField A.symm (fun _ : Z × ℝ => (0, 1)) x)
+    (hC :
+      ∀ x ∈ C.target,
+        V x = Smale.FlowConstruction.partialChartField C.symm (fun _ : Z × ℝ => (0, 1)) x)
+    {T : ℝ} (hpA : ((0 : Z), T) ∈ A.source) (hpC : ((0 : Z), T) ∈ C.source)
+    (hpoint : A (0, T) = C (0, T)) :
+    ∃ (ε : ℝ) (P : PartialDiffeomorph 𝓘(ℝ, Z) 𝓘(ℝ, Z) Z Z ∞) (v : Z → ℝ),
+      0 < ε ∧
+        (0 : Z) ∈ P.source ∧
+          P 0 = 0 ∧
+            v 0 = 0 ∧
+              ContDiff ℝ ∞ v ∧
+                ∀ t ∈ Set.Ioo (T - ε) (T + ε),
+                  ∀ z ∈ P.source,
+                    (z, t) ∈ A.source ∧ (P z, t + v z) ∈ C.source ∧ A (z, t) = C (P z, t + v z) :=
+  by
+  let e := ContinuousLinearEquiv.prodComm ℝ ℝ Z
+  let D := e.toDiffeomorph.toPartialDiffeomorph
+  have hpush (p : ℝ × Z) (_ : p ∈ D.source) : fderiv ℝ D p (1, 0) = ((0 : Z), (1 : ℝ)) := by
+    change fderiv ℝ e p (1, 0) = ((0 : Z), (1 : ℝ))
+    rw [e.fderiv]
+    rfl
+  have hfield (B : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, E) (Z × ℝ) M ∞)
+    (hB :
+      ∀ x ∈ B.target,
+        V x = Smale.FlowConstruction.partialChartField B.symm (fun _ : Z × ℝ => (0, 1)) x) :
+    ∀ x ∈ (D.trans B).target,
+      V x =
+        Smale.FlowConstruction.partialChartField (D.trans B).symm (fun _ : ℝ × Z => (1, 0)) x := by
+    intro x hx
+    exact
+      (hB x hx.1).trans
+        (MorseCancel.partialChartField_of_model_conjugacy D B (fun _ : ℝ × Z => (1, 0))
+            (fun _ : Z × ℝ => (0, 1)) hpush hx).symm
+  have hAs : (T, (0 : Z)) ∈ (D.trans A).source := ⟨Set.mem_univ _, hpA⟩
+  have hCs : (T, (0 : Z)) ∈ (D.trans C).source := ⟨Set.mem_univ _, hpC⟩
+  obtain ⟨ε, P, v, hε, hP0, hPfix, hv0, hv, hformula⟩ :=
+    exists_global_native_transition_phase (D.trans A) (D.trans C) V (hfield A hA) (hfield C hC)
+      hAs hCs hpoint
+  refine ⟨ε, P, v, hε, hP0, hPfix, hv0, hv, ?_⟩
+  intro t ht z hz
+  have hh := hformula t ht z hz
+  exact ⟨hh.1.2, hh.2.1.2, hh.2.2⟩
+
+private theorem Degree.FlowSuspension.exists_native_endpoint_slice_phase {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {m : ℕ}
+    (σ : Fin m → ℝ) {a : ℝ} (ha : 0 < a)
+    (Φ : PartialDiffeomorph 𝓘(ℝ, MorseCancel.Model m) 𝓘(ℝ, E) (MorseCancel.Model m) M ∞)
+    (A : PartialDiffeomorph 𝓘(ℝ, (Fin m → ℝ) × ℝ) 𝓘(ℝ, E) ((Fin m → ℝ) × ℝ) M ∞)
+    {U : Set (Fin m → ℝ)} (hsource : A.source = U ×ˢ Set.univ) (h0U : 0 ∈ U)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hΦ : ∀ y ∈ Φ.target, V y = MorseCancel.nativeCubicDescent σ Φ (-(a ^ 2)) y)
+    (hA :
+      ∀ y ∈ A.target,
+        V y =
+          Smale.FlowConstruction.partialChartField A.symm (fun _ : (Fin m → ℝ) × ℝ => (0, 1)) y)
+    {c r δ T : ℝ} (hδ : 0 < δ) (hbox : Metric.closedBall (c, (0 : Fin m → ℝ)) r ⊆ Φ.source)
+    (hslice :
+      ∀ z : Fin m → ℝ,
+        ‖z‖ ≤ δ → MorseCancel.cubicFlowCylinder σ a (z, T) ∈ Metric.ball (c, (0 : Fin m → ℝ)) r)
+    (hpoint : Φ (MorseCancel.cubicFlowCylinder σ a (0, T)) = A (0, T)) :
+    ∃ (P : PartialDiffeomorph 𝓘(ℝ, Fin m → ℝ) 𝓘(ℝ, Fin m → ℝ) (Fin m → ℝ) (Fin m → ℝ) ∞) (v :
+      (Fin m → ℝ) → ℝ),
+      (0 : Fin m → ℝ) ∈ P.source ∧
+        P 0 = 0 ∧
+          v 0 = 0 ∧
+            ContDiff ℝ ∞ v ∧
+              P.target ⊆ U ∧
+                (∀ z ∈ P.source,
+                    MorseCancel.cubicFlowCylinder σ a (z, T) ∈
+                      Metric.closedBall (c, (0 : Fin m → ℝ)) r) ∧
+                  ∀ z ∈ P.source,
+                    Φ (MorseCancel.cubicFlowCylinder σ a (z, T)) = A (P z, T + v z) := by
+  let C := MorseCancel.cubicFlowCylinderChart σ ha
+  let B := C.trans Φ
+  have hB0 : ((0 : Fin m → ℝ), T) ∈ B.source :=
+    ⟨Set.mem_univ _, hbox (Metric.ball_subset_closedBall (hslice 0 (by simpa using hδ.le)))⟩
+  have hBfield :
+    ∀ y ∈ B.target,
+      V y =
+        Smale.FlowConstruction.partialChartField B.symm (fun _ : (Fin m → ℝ) × ℝ => (0, 1)) y := by
+    intro y hy
+    exact
+      (hΦ y hy.1).trans
+        (MorseCancel.partialChartField_of_model_conjugacy C Φ (fun _ : (Fin m → ℝ) × ℝ => (0, 1))
+            (MorseCancel.cubicDescent σ (-(a ^ 2)))
+            (fun p _ => MorseCancel.cubicFlowCylinder_pushforward_vertical σ a p) hy).symm
+  have hA0 : ((0 : Fin m → ℝ), T) ∈ A.source := by
+    rw [hsource]
+    exact ⟨h0U, Set.mem_univ _⟩
+  obtain ⟨ε, P, v, hε, hP0, hPfix, hv0, hv, hformula⟩ :=
+    exists_time_last_native_transition_phase B A V hBfield hA hB0 hA0 hpoint
+  let Q :=
+    Smale.PartialChart.restrictSource P
+      (Metric.isOpen_ball : IsOpen (Metric.ball (0 : Fin m → ℝ) δ))
+  have hT : T ∈ Set.Ioo (T - ε) (T + ε) := ⟨by linarith, by linarith⟩
+  have hQ0 : (0 : Fin m → ℝ) ∈ Q.source := ⟨hP0, Metric.mem_ball_self hδ⟩
+  refine ⟨Q, v, hQ0, hPfix, hv0, hv, ?_, ?_, ?_⟩
+  · intro z hz
+    have hu := Q.map_target' hz
+    have hh := (hformula T hT (Q.symm z) hu.1).2.1
+    rw [hsource] at hh
+    have hi : P (Q.symm z) = z := Q.right_inv' hz
+    exact hi ▸ hh.1
+  · intro z hz
+    exact
+      Metric.ball_subset_closedBall
+        (hslice z (le_of_lt (by simpa only [Metric.mem_ball, dist_zero_right] using hz.2)))
+  · intro z hz
+    exact (hformula T hT z hz.1).2.2
+
+private def Degree.TransverseGerms.compose_supported_isotopies {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {D₁ D₂ : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞} {K₁ K₂ S : Set E}
+    (A : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy D₁ K₁ S)
+    (B : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy D₂ K₂ S) :
+    Smale.SupportedDiffeomorph.SupportedRelativeIsotopy (D₁.trans D₂) (K₁ ∪ K₂) S
+    where
+  family := fun p => B.family (p.1, A.family p)
+  smooth := B.smooth.comp (contMDiff_fst.prodMk A.smooth)
+  zero := fun x => by rw [A.zero, B.zero]
+  one := fun x => by change B.family (1, A.family (1, x)) = D₂ (D₁ x); rw [A.one, B.one]
+  slices := by
+    intro t
+    obtain ⟨d₁, hd₁⟩ := A.slices t
+    obtain ⟨d₂, hd₂⟩ := B.slices t
+    refine ⟨d₁.trans d₂, ?_⟩
+    intro x
+    change d₂ (d₁ x) = B.family (t, A.family (t, x))
+    rw [hd₁, hd₂]
+  fixedOutside := by
+    intro t x hx
+    rw [A.fixedOutside t x (fun h => hx (Or.inl h)), B.fixedOutside t x (fun h => hx (Or.inr h))]
+  fixedOn := by
+    intro t x hx
+    rw [A.fixedOn t x hx, B.fixedOn t x hx]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Degree.TransverseGerms.exists_transported_transition_correction {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] {Z : Type*} [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    (Q P : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, Z) E Z ∞)
+    (H : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞) (hQ0 : (0 : E) ∈ Q.source)
+    (hP0 : (0 : E) ∈ P.source) (hQzero : Q 0 = 0) (hPzero : P 0 = 0) (hHs : H.source ⊆ Q.source)
+    (hHt : H.target ⊆ P.source) (hdiagram : ∀ z ∈ H.source, P (H z) = Q z)
+    (Dₛ Dₜ : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞) {Kₛ Kₜ Sₛ Sₜ : Set E} (hKₛ : IsCompact Kₛ)
+    (hKₜ : IsCompact Kₜ) (hKs : Kₛ ⊆ H.source) (hKt : Kₜ ⊆ H.target) (hSₛ : (0 : E) ∈ Sₛ)
+    (hSₜ : (0 : E) ∈ Sₜ) (A : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy Dₛ Kₛ Sₛ)
+    (B : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy Dₜ Kₜ Sₜ) :
+    ∃ (D : Diffeomorph 𝓘(ℝ, Z) 𝓘(ℝ, Z) Z Z ∞) (K : Set Z),
+      IsCompact K ∧
+        K = Q '' Kₛ ∪ P '' Kₜ ∧
+          K ⊆ Q.target ∩ P.target ∧
+            Nonempty (Smale.SupportedDiffeomorph.SupportedRelativeIsotopy D K {(0 : Z)}) ∧
+              D 0 = 0 ∧ ∀ z ∈ H.source, D (Q z) = P (Dₜ (H (Dₛ z))) := by
+  have hKQ : Kₛ ⊆ Q.source := hKs.trans hHs
+  have hKP : Kₜ ⊆ P.source := hKt.trans hHt
+  have hfixedQ (z : E) (hz : z ∈ Q.source) (h : Q z ∈ ({(0 : Z)} : Set Z)) : z ∈ Sₛ := by
+    have he : z = 0 :=
+      Q.toOpenPartialHomeomorph.injOn hz hQ0 ((Set.mem_singleton_iff.mp h).trans hQzero.symm)
+    exact he.symm ▸ hSₛ
+  have hfixedP (z : E) (hz : z ∈ P.source) (h : P z ∈ ({(0 : Z)} : Set Z)) : z ∈ Sₜ := by
+    have he : z = 0 :=
+      P.toOpenPartialHomeomorph.injOn hz hP0 ((Set.mem_singleton_iff.mp h).trans hPzero.symm)
+    exact he.symm ▸ hSₜ
+  let A' := A.extension Q hKₛ hKQ hfixedQ
+  let B' := B.extension P hKₜ hKP hfixedP
+  let DQ := Smale.SupportedDiffeomorph.extension Q Dₛ hKₛ hKQ A.endpoint_fixed_outside
+  let DP := Smale.SupportedDiffeomorph.extension P Dₜ hKₜ hKP B.endpoint_fixed_outside
+  let D := DQ.trans DP
+  let K := Q '' Kₛ ∪ P '' Kₜ
+  have hK : IsCompact K :=
+    (hKₛ.image_of_continuousOn (Q.contMDiffOn_toFun.continuousOn.mono hKQ)).union
+      (hKₜ.image_of_continuousOn (P.contMDiffOn_toFun.continuousOn.mono hKP))
+  have I : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy D K {(0 : Z)} :=
+    compose_supported_isotopies A' B'
+  have hKU : K ⊆ Q.target ∩ P.target := by
+    rintro y (⟨z, hz, rfl⟩ | ⟨z, hz, rfl⟩)
+    · refine ⟨Q.map_source' (hKQ hz), ?_⟩
+      rw [← hdiagram z (hKs hz)]
+      exact P.map_source' (hHt (H.map_source' (hKs hz)))
+    · refine ⟨?_, P.map_source' (hKP hz)⟩
+      have hh := hdiagram (H.symm z) (H.map_target' (hKt hz))
+      have hi : H (H.symm z) = z := H.right_inv' (hKt hz)
+      rw [hi] at hh
+      rw [hh]
+      exact Q.map_source' (hHs (H.map_target' (hKt hz)))
+  refine ⟨D, K, hK, rfl, hKU, ⟨I⟩, I.endpoint_fixed_on 0 rfl, ?_⟩
+  intro z hz
+  have hDz : Dₛ z ∈ H.source :=
+    Smale.SupportedDiffeomorph.mapsTo_source H Dₛ.toEquiv hKs A.endpoint_fixed_outside hz
+  change DP (DQ (Q z)) = P (Dₜ (H (Dₛ z)))
+  rw [Smale.SupportedDiffeomorph.extension_chart Q Dₛ hKₛ hKQ A.endpoint_fixed_outside (hHs hz)]
+  rw [← hdiagram (Dₛ z) hDz]
+  exact
+    Smale.SupportedDiffeomorph.extension_chart P Dₜ hKₜ hKP B.endpoint_fixed_outside
+      (hHt (H.map_source' hDz))
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Degree.TransverseGerms.exists_common_transverse_range {E Z : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    (Q P : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, Z) E Z ∞)
+    (H : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞) (h0 : (0 : E) ∈ H.source) (hQzero : Q 0 = 0)
+    (hHs : H.source ⊆ Q.source) (hHt : H.target ⊆ P.source)
+    (hdiagram : ∀ z ∈ H.source, P (H z) = Q z) :
+    ∃ (Q' P' : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, Z) E Z ∞) (U : Set Z),
+      IsOpen U ∧
+        (0 : Z) ∈ U ∧
+          Q'.source = H.source ∧
+            P'.source = H.target ∧
+              Q'.target = U ∧
+                P'.target = U ∧ U ⊆ Q.target ∩ P.target ∧ (∀ z, Q' z = Q z) ∧ (∀ z, P' z = P z) :=
+  by
+  let Q' := Smale.PartialChart.restrictSource Q H.open_source
+  let P' := Smale.PartialChart.restrictSource P H.open_target
+  have hQs : Q'.source = H.source := Set.inter_eq_right.mpr hHs
+  have hPs : P'.source = H.target := Set.inter_eq_right.mpr hHt
+  have hsame : Q'.target = P'.target := by
+    ext y
+    constructor
+    · intro hy
+      have hz : Q'.symm y ∈ H.source := hQs ▸ Q'.map_target' hy
+      have hw : H (Q'.symm y) ∈ P'.source := hPs.symm ▸ H.map_source' hz
+      have heq : P' (H (Q'.symm y)) = y := (hdiagram _ hz).trans (Q'.right_inv' hy)
+      exact heq ▸ P'.map_source' hw
+    · intro hy
+      have hz : P'.symm y ∈ H.target := hPs ▸ P'.map_target' hy
+      have hw : H.symm (P'.symm y) ∈ Q'.source := hQs.symm ▸ H.map_target' hz
+      have heq : Q' (H.symm (P'.symm y)) = y := by
+        have hh := hdiagram (H.symm (P'.symm y)) (H.map_target' hz)
+        have hi : H (H.symm (P'.symm y)) = P'.symm y := H.right_inv' hz
+        rw [hi] at hh
+        exact hh.symm.trans (P'.right_inv' hy)
+      exact heq ▸ Q'.map_source' hw
+  have h0U : (0 : Z) ∈ Q'.target := by
+    have hh := Q'.map_source' (hQs.symm ▸ h0)
+    change Q 0 ∈ Q'.target at hh
+    rwa [hQzero] at hh
+  refine
+    ⟨Q', P', Q'.target, Q'.open_target, h0U, hQs, hPs, rfl, hsame.symm, ?_, fun _ => rfl, fun _ =>
+      rfl⟩
+  intro y hy
+  have hyP : y ∈ P'.target := hsame ▸ hy
+  exact ⟨hy.1, hyP.1⟩
+
+private theorem Degree.TransverseGerms.exists_common_transverse_coordinates {D B Z : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] (e : D ≃L[ℝ] B)
+    (Q P : PartialDiffeomorph 𝓘(ℝ, D) 𝓘(ℝ, Z) D Z ∞) (hQ0 : (0 : D) ∈ Q.source)
+    (hP0 : (0 : D) ∈ P.source) (hQfix : Q 0 = 0) (hPfix : P 0 = 0) :
+    ∃ (Q' P' : PartialDiffeomorph 𝓘(ℝ, B) 𝓘(ℝ, Z) B Z ∞) (H :
+      PartialDiffeomorph 𝓘(ℝ, B) 𝓘(ℝ, B) B B ∞) (U : Set Z),
+      IsOpen U ∧
+        (0 : Z) ∈ U ∧
+          (0 : B) ∈ H.source ∧
+            H 0 = 0 ∧
+              Q' 0 = 0 ∧
+                P' 0 = 0 ∧
+                  Q'.source = H.source ∧
+                    P'.source = H.target ∧
+                      Q'.target = U ∧
+                        P'.target = U ∧
+                          U ⊆ Q.target ∩ P.target ∧
+                            (∀ u ∈ Q'.source, e.symm u ∈ Q.source) ∧
+                              (∀ u ∈ P'.source, e.symm u ∈ P.source) ∧
+                                (∀ u, Q' u = Q (e.symm u)) ∧
+                                  (∀ u, P' u = P (e.symm u)) ∧
+                                    (∀ u ∈ H.source, P' (H u) = Q' u) ∧
+                                      ∀ u, H u = e (P.symm (Q (e.symm u))) := by
+  let R := e.symm.toDiffeomorph.toPartialDiffeomorph
+  let Qe := R.trans Q
+  let Pe := R.trans P
+  have hQe0 : (0 : B) ∈ Qe.source := by
+    change (0 : B) ∈ Set.univ ∧ e.symm 0 ∈ Q.source
+    rw [map_zero]
+    exact ⟨Set.mem_univ _, hQ0⟩
+  have hPe0 : (0 : B) ∈ Pe.source := by
+    change (0 : B) ∈ Set.univ ∧ e.symm 0 ∈ P.source
+    rw [map_zero]
+    exact ⟨Set.mem_univ _, hP0⟩
+  have hQezero : Qe 0 = 0 := by change Q (e.symm 0) = 0; rw [map_zero, hQfix]
+  have hPezero : Pe 0 = 0 := by change P (e.symm 0) = 0; rw [map_zero, hPfix]
+  let H := Qe.trans Pe.symm
+  have h0 : (0 : B) ∈ H.source := by
+    refine ⟨hQe0, ?_⟩
+    change Qe 0 ∈ Pe.target
+    rw [hQezero, ← hPezero]
+    exact Pe.map_source' hPe0
+  have hH0 : H 0 = 0 := by
+    change Pe.symm (Qe 0) = 0
+    rw [hQezero, ← hPezero]
+    exact Pe.left_inv' hPe0
+  have hHs : H.source ⊆ Qe.source := fun _ hu => hu.1
+  have hHt : H.target ⊆ Pe.source := fun _ hu => hu.1
+  have hdiagram (u : B) (hu : u ∈ H.source) : Pe (H u) = Qe u := Pe.right_inv' hu.2
+  obtain ⟨Q', P', U, hU, h0U, hQs, hPs, hQt, hPt, hUsub, hQmap, hPmap⟩ :=
+    exists_common_transverse_range Qe Pe H h0 hQezero hHs hHt hdiagram
+  refine
+    ⟨Q', P', H, U, hU, h0U, h0, hH0, (hQmap 0).trans hQezero, (hPmap 0).trans hPezero, hQs, hPs,
+      hQt, hPt, ?_, ?_, ?_, hQmap, hPmap, ?_, fun _ => rfl⟩
+  · intro z hz
+    exact ⟨(hUsub hz).1.1, (hUsub hz).2.1⟩
+  · intro u hu
+    exact (hHs (hQs ▸ hu)).2
+  · intro u hu
+    exact (hHt (hPs ▸ hu)).2
+  · intro u hu
+    exact (hPmap (H u)).trans ((hdiagram u hu).trans (hQmap u).symm)
+
+private theorem Degree.TransverseGerms.exists_restricted_native_cylinder {Z E M : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M]
+    (A : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, E) (Z × ℝ) M ∞) {U O : Set Z}
+    (hsource : A.source = U ×ˢ Set.univ) (hO : IsOpen O) (hOU : O ⊆ U)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hA :
+      ∀ y ∈ A.target,
+        V y = Smale.FlowConstruction.partialChartField A.symm (fun _ : Z × ℝ => (0, 1)) y) :
+    ∃ B : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, E) (Z × ℝ) M ∞,
+      B.source = O ×ˢ Set.univ ∧
+        B.source ⊆ A.source ∧
+          B.target ⊆ A.target ∧
+            (∀ z, B z = A z) ∧
+              ∀ y ∈ B.target,
+                V y =
+                  Smale.FlowConstruction.partialChartField B.symm (fun _ : Z × ℝ => (0, 1)) y := by
+  let B := Smale.PartialChart.restrictSource A (hO.prod isOpen_univ)
+  have hsub : O ×ˢ (Set.univ : Set ℝ) ⊆ A.source := by
+    rw [hsource]
+    exact fun z hz => ⟨hOU hz.1, hz.2⟩
+  have hBs : B.source = O ×ˢ Set.univ := Set.inter_eq_right.mpr hsub
+  exact ⟨B, hBs, fun _ hz => hz.1, fun _ hy => hy.1, fun _ => rfl, fun y hy => hA y hy.1⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Degree.TransverseGerms.splitCoordinates_negative_zero_iff {ι : Type*} [Fintype ι]
+    (w : ι → ℝ) (z : ι → ℝ) :
+    (Smale.MorseHandle.splitCoordinates w z).1 = 0 ↔ ∀ i, w i = -1 → z i = 0 := by
+  constructor
+  · intro h i hi
+    have hh := congrArg (fun v : Smale.MorseHandle.NegativeSpace w => v ⟨i, hi⟩) h
+    exact hh
+  · intro h
+    ext i
+    exact h i.1 i.2
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Degree.TransverseGerms.splitCoordinates_positive_zero_iff {ι : Type*} [Fintype ι]
+    (w : ι → ℝ) (hw : ∀ i, w i = -1 ∨ w i = 1) (z : ι → ℝ) :
+    (Smale.MorseHandle.splitCoordinates w z).2 = 0 ↔ ∀ i, w i = 1 → z i = 0 := by
+  constructor
+  · intro h i hi
+    have hn : w i ≠ -1 := by rw [hi]; norm_num
+    have hh := congrArg (fun v : Smale.MorseHandle.PositiveSpace w => v ⟨i, hn⟩) h
+    exact hh
+  · intro h
+    ext i
+    exact h i.1 ((hw i.1).resolve_left i.2)
+
+private structure MorseCancel.NativeEndpointSliceData {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {m : ℕ} (σ : Fin m → ℝ) (a : ℝ)
+    (Φq Φp : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (A : PartialDiffeomorph 𝓘(ℝ, (Fin m → ℝ) × ℝ) 𝓘(ℝ, E) ((Fin m → ℝ) × ℝ) M ∞)
+    (Rq Rp Tq Tp : ℝ) where
+  labelDomain : Set (Fin m → ℝ)
+  open_domain : IsOpen labelDomain
+  zero_domain : (0 : Fin m → ℝ) ∈ labelDomain
+  source : A.source = labelDomain ×ˢ Set.univ
+  Q :
+    PartialDiffeomorph 𝓘(ℝ, Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ)
+      𝓘(ℝ, Fin m → ℝ) (Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ)
+      (Fin m → ℝ) ∞
+  P :
+    PartialDiffeomorph 𝓘(ℝ, Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ)
+      𝓘(ℝ, Fin m → ℝ) (Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ)
+      (Fin m → ℝ) ∞
+  H :
+    PartialDiffeomorph 𝓘(ℝ, Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ)
+      𝓘(ℝ, Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ)
+      (Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ)
+      (Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ) ∞
+  zero_source : 0 ∈ H.source
+  H_zero : H 0 = 0
+  Q_zero : Q 0 = 0
+  P_zero : P 0 = 0
+  Q_source : Q.source = H.source
+  P_source : P.source = H.target
+  Q_target : Q.target = labelDomain
+  P_target : P.target = labelDomain
+  diagram : ∀ u ∈ H.source, P (H u) = Q u
+  phaseQ : (Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ) → ℝ
+  phaseP : (Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ) → ℝ
+  smooth_phaseQ : ContDiff ℝ ∞ phaseQ
+  smooth_phaseP : ContDiff ℝ ∞ phaseP
+  zero_phaseQ : phaseQ 0 = 0
+  zero_phaseP : phaseP 0 = 0
+  sliceQ :
+    ∀ u ∈ Q.source,
+      cubicFlowCylinder σ a ((Smale.MorseHandle.splitCoordinates σ).symm u, Tq) ∈
+        Metric.closedBall (-a, (0 : Fin m → ℝ)) Rq
+  sliceP :
+    ∀ u ∈ P.source,
+      cubicFlowCylinder σ a ((Smale.MorseHandle.splitCoordinates σ).symm u, Tp) ∈
+        Metric.closedBall (a, (0 : Fin m → ℝ)) Rp
+  formulaQ :
+    ∀ u ∈ Q.source,
+      Φq (cubicFlowCylinder σ a ((Smale.MorseHandle.splitCoordinates σ).symm u, Tq)) =
+        A (Q u, Tq + phaseQ u)
+  formulaP :
+    ∀ u ∈ P.source,
+      Φp (cubicFlowCylinder σ a ((Smale.MorseHandle.splitCoordinates σ).symm u, Tp)) =
+        A (P u, Tp + phaseP u)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_original_endpoint_slice_data {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {m : ℕ} (σ : Fin m → ℝ) {a : ℝ}
+    (ha : 0 < a) (Φq Φp : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (A : PartialDiffeomorph 𝓘(ℝ, (Fin m → ℝ) × ℝ) 𝓘(ℝ, E) ((Fin m → ℝ) × ℝ) M ∞)
+    {U : Set (Fin m → ℝ)} (hsource : A.source = U ×ˢ Set.univ) (h0U : 0 ∈ U)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hqfield : ∀ y ∈ Φq.target, V y = nativeCubicDescent σ Φq (-(a ^ 2)) y)
+    (hpfield : ∀ y ∈ Φp.target, V y = nativeCubicDescent σ Φp (-(a ^ 2)) y)
+    (hAfield :
+      ∀ y ∈ A.target,
+        V y =
+          Smale.FlowConstruction.partialChartField A.symm (fun _ : (Fin m → ℝ) × ℝ => (0, 1)) y)
+    {Rq Rp δq δp Tq Tp : ℝ} (hδq : 0 < δq) (hδp : 0 < δp)
+    (hboxq : Metric.closedBall (-a, (0 : Fin m → ℝ)) Rq ⊆ Φq.source)
+    (hboxp : Metric.closedBall (a, (0 : Fin m → ℝ)) Rp ⊆ Φp.source)
+    (hsliceq :
+      ∀ z : Fin m → ℝ,
+        ‖z‖ ≤ δq → cubicFlowCylinder σ a (z, Tq) ∈ Metric.ball (-a, (0 : Fin m → ℝ)) Rq)
+    (hslicep :
+      ∀ z : Fin m → ℝ,
+        ‖z‖ ≤ δp → cubicFlowCylinder σ a (z, Tp) ∈ Metric.ball (a, (0 : Fin m → ℝ)) Rp)
+    (hpointq : Φq (cubicFlowCylinder σ a (0, Tq)) = A (0, Tq))
+    (hpointp : Φp (cubicFlowCylinder σ a (0, Tp)) = A (0, Tp)) :
+    ∃ B : PartialDiffeomorph 𝓘(ℝ, (Fin m → ℝ) × ℝ) 𝓘(ℝ, E) ((Fin m → ℝ) × ℝ) M ∞,
+      B.source ⊆ A.source ∧
+        B.target ⊆ A.target ∧
+          (∀ z, B z = A z) ∧
+            (∀ y ∈ B.target,
+                V y =
+                  Smale.FlowConstruction.partialChartField B.symm
+                    (fun _ : (Fin m → ℝ) × ℝ => (0, 1)) y) ∧
+              Nonempty (NativeEndpointSliceData σ a Φq Φp B Rq Rp Tq Tp) := by
+  obtain ⟨Q, v, hQ0, hQfix, hv0, hv, hQU, hQslice, hQphase⟩ :=
+    Degree.FlowSuspension.exists_native_endpoint_slice_phase σ ha Φq A hsource h0U V hqfield
+      hAfield hδq hboxq hsliceq hpointq
+  obtain ⟨P, w, hP0, hPfix, hw0, hw, hPU, hPslice, hPphase⟩ :=
+    Degree.FlowSuspension.exists_native_endpoint_slice_phase σ ha Φp A hsource h0U V hpfield
+      hAfield hδp hboxp hslicep hpointp
+  let e := Smale.MorseHandle.splitCoordinates σ
+  obtain
+    ⟨Q', P', H, O, hO, h0O, h0H, hH0, hQ'0, hP'0, hQ's, hP's, hQ't, hP't, hOsub, hQ'sub, hP'sub,
+      hQ'map, hP'map, hdiagram, _⟩ :=
+    Degree.TransverseGerms.exists_common_transverse_coordinates e Q P hQ0 hP0 hQfix hPfix
+  have hOU : O ⊆ U := fun _ hz => hQU (hOsub hz).1
+  obtain ⟨B, hBs, hBsub, hBt, hBmap, hBfield⟩ :=
+    Degree.TransverseGerms.exists_restricted_native_cylinder A hsource hO hOU V hAfield
+  refine
+    ⟨B, hBsub, hBt, hBmap, hBfield,
+      ⟨{  labelDomain := O
+          open_domain := hO
+          zero_domain := h0O
+          source := hBs
+          Q := Q'
+          P := P'
+          H := H
+          zero_source := h0H
+          H_zero := hH0
+          Q_zero := hQ'0
+          P_zero := hP'0
+          Q_source := hQ's
+          P_source := hP's
+          Q_target := hQ't
+          P_target := hP't
+          diagram := hdiagram
+          phaseQ := fun u => v (e.symm u)
+          phaseP := fun u => w (e.symm u)
+          smooth_phaseQ := hv.comp e.symm.contDiff
+          smooth_phaseP := hw.comp e.symm.contDiff
+          zero_phaseQ := by rw [map_zero, hv0]
+          zero_phaseP := by rw [map_zero, hw0]
+          sliceQ := fun u hu => hQslice (e.symm u) (hQ'sub u hu)
+          sliceP := fun u hu => hPslice (e.symm u) (hP'sub u hu)
+          formulaQ := ?_
+          formulaP := ?_ }⟩⟩
+  · intro u hu
+    rw [hBmap, hQ'map]
+    exact hQphase (e.symm u) (hQ'sub u hu)
+  · intro u hu
+    rw [hBmap, hP'map]
+    exact hPphase (e.symm u) (hP'sub u hu)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.incoming_linear_stable_plane {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {x : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) {m : ℕ} (σ : Fin m → ℝ)
+    (hσ : ∀ i, σ i = -1 ∨ σ i = 1)
+    (L : Model m ≃L[ℝ] (c.NegativeCoordinates × c.PositiveCoordinates))
+    (hL : ∀ p, L (endpointLinearField σ (1 / 2) 1 p) = Smale.MorseHandle.descent (L p))
+    (p : Model m) : (L p).1 = 0 ↔ ∀ i, σ i = -1 → p.2 i = 0 := by
+  have heig : (L p).1 = 0 ↔ endpointLinearField σ (1 / 2) 1 p = -p := by
+    constructor
+    · intro hz
+      apply L.injective
+      rw [hL, map_neg]
+      apply Prod.ext
+      · change (L p).1 = -(L p).1
+        rw [hz, neg_zero]
+      · rfl
+    · intro h
+      have hh := congrArg Prod.fst (hL p)
+      rw [h, map_neg] at hh
+      have hs : (2 : ℝ) • (L p).1 = 0 := by
+        rw [two_smul]
+        exact (congrArg (fun z => z + (L p).1) hh.symm).trans (neg_add_cancel _)
+      exact (smul_eq_zero.mp hs).resolve_left (by norm_num)
+  rw [heig]
+  constructor
+  · intro h i hi
+    have hh := congrArg (fun q : Model m => q.2 i) h
+    change -σ i * p.2 i = -p.2 i at hh
+    rw [hi] at hh
+    linarith
+  · intro h
+    apply Prod.ext
+    · simp [endpointLinearField]
+    · funext i
+      rcases hσ i with hi | hi
+      · simp [endpointLinearField, hi, h i hi]
+      · simp [endpointLinearField, hi]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.outgoing_linear_unstable_plane {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {x : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) {m : ℕ} (σ : Fin m → ℝ)
+    (hσ : ∀ i, σ i = -1 ∨ σ i = 1)
+    (L : Model m ≃L[ℝ] (c.NegativeCoordinates × c.PositiveCoordinates))
+    (hL : ∀ p, L (endpointLinearField σ (1 / 2) (-1) p) = Smale.MorseHandle.descent (L p))
+    (p : Model m) : (L p).2 = 0 ↔ ∀ i, σ i = 1 → p.2 i = 0 := by
+  have heig : (L p).2 = 0 ↔ endpointLinearField σ (1 / 2) (-1) p = p := by
+    constructor
+    · intro hz
+      apply L.injective
+      rw [hL]
+      apply Prod.ext
+      · rfl
+      · change -(L p).2 = (L p).2
+        rw [hz, neg_zero]
+    · intro h
+      have hh := congrArg Prod.snd (hL p)
+      rw [h] at hh
+      have hs : (2 : ℝ) • (L p).2 = 0 := by
+        rw [two_smul]
+        exact (congrArg (fun z => z + (L p).2) hh).trans (neg_add_cancel _)
+      exact (smul_eq_zero.mp hs).resolve_left (by norm_num)
+  rw [heig]
+  constructor
+  · intro h i hi
+    have hh := congrArg (fun q : Model m => q.2 i) h
+    simp only [endpointLinearField, hi] at hh
+    linarith
+  · intro h
+    apply Prod.ext
+    · simp [endpointLinearField]
+    · funext i
+      rcases hσ i with hi | hi
+      · simp [endpointLinearField, hi]
+      · simp [endpointLinearField, hi, h i hi]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.endpoint_axis_tail_of_restriction {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {p : M} {m : ℕ} (Φ Ψ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (hsub : Ψ.source ⊆ Φ.source) (hmap : ∀ z, Ψ z = Φ z) {a b c : ℝ}
+    (hc : (c, (0 : Fin m → ℝ)) ∈ Ψ.source) (hcenter : Ψ (c, 0) = p) (F : Flow ℝ M) (x : M)
+    {l : Filter ℝ} (hlim : Filter.Tendsto (fun t => F t x) l (𝓝 p))
+    (htail : ∀ᶠ t in l, ∃ s ∈ Set.Ioo a b, (s, (0 : Fin m → ℝ)) ∈ Φ.source ∧ Φ (s, 0) = F t x) :
+    ∀ᶠ t in l, ∃ s ∈ Set.Ioo a b, (s, (0 : Fin m → ℝ)) ∈ Ψ.source ∧ Ψ (s, 0) = F t x := by
+  have hp : p ∈ Ψ.target := hcenter ▸ Ψ.map_source' hc
+  filter_upwards [htail, hlim.eventually (Ψ.open_target.mem_nhds hp)] with t ht htΨ
+  obtain ⟨s, hs, hsΦ, hval⟩ := ht
+  have hz : Ψ.symm (F t x) ∈ Ψ.source := Ψ.map_target' htΨ
+  have hzval : Ψ (Ψ.symm (F t x)) = F t x := Ψ.right_inv' htΨ
+  have heq : Ψ.symm (F t x) = (s, (0 : Fin m → ℝ)) :=
+    Φ.toOpenPartialHomeomorph.injOn (hsub hz) hsΦ ((hmap _).symm.trans (hzval.trans hval.symm))
+  exact ⟨s, hs, heq ▸ hz, (hmap _).trans hval⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.exists_cubic_endpoint_basin_restriction {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (hf : Continuous f) {m : ℕ} (σ : Fin m → ℝ) (hσ : ∀ i, σ i = -1 ∨ σ i = 1) {e : ℝ}
+    (L : Model m ≃L[ℝ] (c.NegativeCoordinates × c.PositiveCoordinates))
+    (hL : ∀ z, L (endpointLinearField σ (1 / 2) e z) = Smale.MorseHandle.descent (L z))
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hmono : ∀ x, Antitone (fun t => f (F t x))) (heq : ∀ᶠ y in 𝓝 p, V y = c.descentField y)
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (hc : (e / 2, (0 : Fin m → ℝ)) ∈ Φ.source) (hcenter : Φ (e / 2, 0) = p)
+    (hfield : ∀ y ∈ Φ.target, V y = nativeCubicDescent σ Φ (-(1 / 2 : ℝ) ^ 2) y)
+    (hcoord : ∀ z ∈ Φ.source, c.splitChart (Φ z) = L (endpointFieldProduct (1 / 2) e z)) :
+    ∃ Ψ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞,
+      Ψ.source ⊆ Φ.source ∧
+        (∀ z, Ψ z = Φ z) ∧
+          (e / 2, (0 : Fin m → ℝ)) ∈ Ψ.source ∧
+            Ψ (e / 2, 0) = p ∧
+              Ψ.target ⊆ c.splitChart.source ∧
+                (∀ y ∈ Ψ.target, V y = nativeCubicDescent σ Ψ (-(1 / 2 : ℝ) ^ 2) y) ∧
+                  ∀ z ∈ Ψ.source,
+                    (e = 1 →
+                        (Filter.Tendsto (fun t => F t (Ψ z)) Filter.atTop (𝓝 p) ↔
+                          ∀ i, σ i = -1 → z.2 i = 0)) ∧
+                      (e = -1 →
+                        (Filter.Tendsto (fun t => F t (Ψ z)) Filter.atBot (𝓝 p) ↔
+                          ∀ i, σ i = 1 → z.2 i = 0)) := by
+  obtain ⟨r, hr, _, hbasin⟩ := exists_native_morse_basin_block c hf hV F hF hmono heq
+  have hct : ContinuousAt c.splitChart p :=
+    c.splitChart.toOpenPartialHomeomorph.continuousAt c.splitChart_mem_source
+  have hnear :
+    ∀ᶠ y in 𝓝 p, y ∈ c.splitChart.source ∧ ‖(c.splitChart y).1‖ < r ∧ ‖(c.splitChart y).2‖ < r := by
+    have hB :
+      Metric.ball (0 : c.NegativeCoordinates) r ×ˢ Metric.ball (0 : c.PositiveCoordinates) r ∈
+        𝓝 (c.splitChart p) := by
+      rw [c.splitChart_center]
+      exact
+        (Metric.isOpen_ball.prod Metric.isOpen_ball).mem_nhds
+          ⟨Metric.mem_ball_self hr, Metric.mem_ball_self hr⟩
+    filter_upwards [c.splitChart.open_source.mem_nhds c.splitChart_mem_source,
+      hct.eventually hB] with y hy hby
+    exact ⟨hy, mem_ball_zero_iff.mp hby.1, mem_ball_zero_iff.mp hby.2⟩
+  obtain ⟨U, hUsub, hU, hpU⟩ := mem_nhds_iff.mp hnear
+  let Ψ := Smale.PartialChart.restrictTarget Φ hU
+  have hsource : Ψ.source ⊆ Φ.source := fun _ hz => hz.1
+  have hΨc : (e / 2, (0 : Fin m → ℝ)) ∈ Ψ.source := by
+    change (e / 2, 0) ∈ Φ.source ∧ Φ (e / 2, 0) ∈ U
+    exact ⟨hc, hcenter.symm ▸ hpU⟩
+  refine ⟨Ψ, hsource, fun _ => rfl, hΨc, hcenter, fun y hy => (hUsub hy.2).1, ?_, ?_⟩
+  · intro y hy
+    exact hfield y hy.1
+  · intro z hz
+    obtain ⟨hy, hn, hp⟩ := hUsub (Ψ.map_source' hz).2
+    have hclass := hbasin (Ψ z) hy hn hp
+    have hcz : c.splitChart (Ψ z) = L (endpointFieldProduct (1 / 2) e z) := hcoord z (hsource hz)
+    constructor
+    · intro he
+      subst e
+      rw [hclass.1, hcz]
+      exact incoming_linear_stable_plane c σ hσ L hL (endpointFieldProduct (1 / 2) 1 z)
+    · intro he
+      subst e
+      rw [hclass.2, hcz]
+      exact outgoing_linear_unstable_plane c σ hσ L hL (endpointFieldProduct (1 / 2) (-1) z)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_actual_incoming_cubic_basin {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (hf : Continuous f) {m : ℕ} (ρ : Option (Fin m) ≃ Fin (Module.finrank ℝ E))
+    (he : c.weights (ρ Option.none) = 1) {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hmono : ∀ x, Antitone (fun t => f (F t x))) {x : M} (hxp : x ≠ p)
+    (hlim : Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p))
+    (heq : ∀ᶠ y in 𝓝 p, V y = c.descentField y) :
+    let σ := fun i : Fin m => c.weights (ρ (Option.some i))
+    ∃ Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞,
+      (1 / 2, (0 : Fin m → ℝ)) ∈ Φ.source ∧
+        Φ (1 / 2, 0) = p ∧
+          Φ.target ⊆ c.splitChart.source ∧
+            (∀ y ∈ Φ.target, V y = nativeCubicDescent σ Φ (-(1 / 2 : ℝ) ^ 2) y) ∧
+              (∀ z ∈ Φ.source,
+                  Filter.Tendsto (fun t => F t (Φ z)) Filter.atTop (𝓝 p) ↔
+                    ∀ i, σ i = -1 → z.2 i = 0) ∧
+                ∀ᶠ t in Filter.atTop,
+                  ∃ s ∈ Set.Ioo (-(1 / 2 : ℝ)) (1 / 2),
+                    (s, (0 : Fin m → ℝ)) ∈ Φ.source ∧ Φ (s, 0) = F t x := by
+  let σ := fun i : Fin m => c.weights (ρ (Option.some i))
+  obtain ⟨Φ, hc, hcenter, _, hfield, htail, L, hL, hcoord⟩ :=
+    exists_actual_incoming_cubic_endpoint c ρ he hV F hF hxp hlim heq
+  obtain ⟨Ψ, hsub, hmap, hΨc, hΨcenter, htarget, hΨfield, hbasin⟩ :=
+    exists_cubic_endpoint_basin_restriction c hf σ (fun i => c.signs _) L hL hV F hF hmono heq Φ
+      hc hcenter hfield hcoord
+  refine ⟨Ψ, hΨc, hΨcenter, htarget, hΨfield, ?_, ?_⟩
+  · exact fun z hz => (hbasin z hz).1 rfl
+  · exact endpoint_axis_tail_of_restriction Φ Ψ hsub hmap hΨc hΨcenter F x hlim htail
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_actual_outgoing_cubic_basin {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (hf : Continuous f) {m : ℕ} (ρ : Option (Fin m) ≃ Fin (Module.finrank ℝ E))
+    (he : c.weights (ρ Option.none) = -1) {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hmono : ∀ x, Antitone (fun t => f (F t x))) {x : M} (hxp : x ≠ p)
+    (hlim : Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p))
+    (heq : ∀ᶠ y in 𝓝 p, V y = c.descentField y) :
+    let σ := fun i : Fin m => c.weights (ρ (Option.some i))
+    ∃ Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞,
+      (-(1 / 2 : ℝ), (0 : Fin m → ℝ)) ∈ Φ.source ∧
+        Φ (-(1 / 2 : ℝ), 0) = p ∧
+          Φ.target ⊆ c.splitChart.source ∧
+            (∀ y ∈ Φ.target, V y = nativeCubicDescent σ Φ (-(1 / 2 : ℝ) ^ 2) y) ∧
+              (∀ z ∈ Φ.source,
+                  Filter.Tendsto (fun t => F t (Φ z)) Filter.atBot (𝓝 p) ↔
+                    ∀ i, σ i = 1 → z.2 i = 0) ∧
+                ∀ᶠ t in Filter.atBot,
+                  ∃ s ∈ Set.Ioo (-(1 / 2 : ℝ)) (1 / 2),
+                    (s, (0 : Fin m → ℝ)) ∈ Φ.source ∧ Φ (s, 0) = F t x := by
+  let σ := fun i : Fin m => c.weights (ρ (Option.some i))
+  obtain ⟨Φ, hc, hcenter, _, hfield, htail, L, hL, hcoord⟩ :=
+    exists_actual_outgoing_cubic_endpoint c ρ he hV F hF hxp hlim heq
+  have hc' : ((-1 : ℝ) / 2, (0 : Fin m → ℝ)) ∈ Φ.source := by convert! hc using 1; norm_num
+  have hcenter' : Φ ((-1 : ℝ) / 2, 0) = p := by convert! hcenter using 1; norm_num
+  obtain ⟨Ψ, hsub, hmap, hΨc, hΨcenter, htarget, hΨfield, hbasin⟩ :=
+    exists_cubic_endpoint_basin_restriction c hf σ (fun i => c.signs _) L hL hV F hF hmono heq Φ
+      hc' hcenter' hfield hcoord
+  have hΨc' : (-(1 / 2 : ℝ), (0 : Fin m → ℝ)) ∈ Ψ.source := by convert! hΨc using 1; norm_num
+  have hΨcenter' : Ψ (-(1 / 2 : ℝ), 0) = p := by convert! hΨcenter using 1; norm_num
+  refine ⟨Ψ, hΨc', hΨcenter', htarget, hΨfield, ?_, ?_⟩
+  · exact fun z hz => (hbasin z hz).2 rfl
+  · exact endpoint_axis_tail_of_restriction Φ Ψ hsub hmap hΨc' hΨcenter' F x hlim htail
+
+private theorem Degree.SignedCoordinates.positive_of_not_negative {ι : Type*} {w : ι → ℝ}
+    (hw : ∀ i, w i = -1 ∨ w i = 1) {i : ι} (hi : w i ≠ -1) : w i = 1 :=
+  (hw i).resolve_left hi
+
+private theorem Degree.SignedCoordinates.exists_equiv_of_negative_card_eq {ι κ : Type*} [Fintype ι]
+    [Fintype κ] (w₀ : ι → ℝ) (w₁ : κ → ℝ) (h₀ : ∀ i, w₀ i = -1 ∨ w₀ i = 1)
+    (h₁ : ∀ i, w₁ i = -1 ∨ w₁ i = 1) (hcard : Fintype.card ι = Fintype.card κ)
+    [Fintype { i // w₀ i = -1 }] [Fintype { i // w₁ i = -1 }]
+    (hneg : Fintype.card { i // w₀ i = -1 } = Fintype.card { i // w₁ i = -1 }) :
+    ∃ e : ι ≃ κ, ∀ i, w₁ (e i) = w₀ i := by
+  classical
+  let eN : { i // w₀ i = -1 } ≃ { i // w₁ i = -1 } := Fintype.equivOfCardEq hneg
+  have hpos : Fintype.card { i // ¬w₀ i = -1 } = Fintype.card { i // ¬w₁ i = -1 } := by
+    rw [Fintype.card_subtype_compl, Fintype.card_subtype_compl, hcard, hneg]
+  let eP : { i // ¬w₀ i = -1 } ≃ { i // ¬w₁ i = -1 } := Fintype.equivOfCardEq hpos
+  let e₀ := Equiv.sumCompl (fun i : ι => w₀ i = -1)
+  let e₁ := Equiv.sumCompl (fun i : κ => w₁ i = -1)
+  let e := e₀.symm.trans ((Equiv.sumCongr eN eP).trans e₁)
+  refine ⟨e, ?_⟩
+  intro i
+  obtain ⟨z, rfl⟩ := e₀.surjective i
+  simp only [e, Equiv.trans_apply, Equiv.symm_apply_apply]
+  cases z with
+  | inl x =>
+    change w₁ (eN x) = w₀ x
+    exact (eN x).property.trans x.property.symm
+  | inr x =>
+    change w₁ (eP x) = w₀ x
+    exact
+      (positive_of_not_negative h₁ (eP x).property).trans
+        (positive_of_not_negative h₀ x.property).symm
+
+private theorem MorseCancel.exists_coordinate_enum {m n : ℕ} (hn : n = m + 1) (j : Fin n) :
+    ∃ ρ : Option (Fin m) ≃ Fin n, ρ Option.none = j := by
+  let ρ₀ : Option (Fin m) ≃ Fin n := Fintype.equivOfCardEq (by simp [hn])
+  exact ⟨ρ₀.trans (Equiv.swap (ρ₀ Option.none) j), by simp⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Degree.SignedCoordinates.negative_card_split {m n : ℕ} (ρ : Option (Fin m) ≃ Fin n)
+    (w : Fin n → ℝ) :
+    Fintype.card { j // w j = -1 } =
+      (if w (ρ Option.none) = -1 then 1 else 0) +
+        Fintype.card { i : Fin m // w (ρ (Option.some i)) = -1 } := by
+  have he : { i : Option (Fin m) // w (ρ i) = -1 } ≃ { j : Fin n // w j = -1 } :=
+    ρ.subtypeEquiv (fun _ => Iff.rfl)
+  rw [← Fintype.card_congr he]
+  simp only [Fintype.card_subtype, Finset.card_eq_sum_ones, Finset.sum_filter, Fintype.sum_option]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Degree.SignedCoordinates.exists_adjacent_sign_enumerations {m : ℕ}
+    (w₀ w₁ : Fin (m + 1) → ℝ) (h₀ : ∀ i, w₀ i = -1 ∨ w₀ i = 1) (h₁ : ∀ i, w₁ i = -1 ∨ w₁ i = 1)
+    (hindex : Fintype.card { i // w₁ i = -1 } = Fintype.card { i // w₀ i = -1 } + 1) :
+    ∃ ρ₀ ρ₁ : Option (Fin m) ≃ Fin (m + 1),
+      w₀ (ρ₀ Option.none) = 1 ∧
+        w₁ (ρ₁ Option.none) = -1 ∧ ∀ i, w₀ (ρ₀ (Option.some i)) = w₁ (ρ₁ (Option.some i)) := by
+  have hbound := Fintype.card_subtype_le (fun i : Fin (m + 1) => w₁ i = -1)
+  have hNpos : 0 < Fintype.card { i // w₁ i = -1 } := by omega
+  have hPpos : 0 < Fintype.card { i // ¬w₀ i = -1 } := by
+    rw [Fintype.card_subtype_compl]
+    omega
+  let j₀ := Classical.choice (Fintype.card_pos_iff.mp hPpos)
+  let j₁ := Classical.choice (Fintype.card_pos_iff.mp hNpos)
+  obtain ⟨ρ₀, hρ₀⟩ := MorseCancel.exists_coordinate_enum rfl j₀.1
+  obtain ⟨ρ₁, hρ₁⟩ := MorseCancel.exists_coordinate_enum rfl j₁.1
+  have hfirst₀ : w₀ (ρ₀ Option.none) = 1 := by
+    rw [hρ₀]
+    exact positive_of_not_negative h₀ j₀.2
+  have hfirst₁ : w₁ (ρ₁ Option.none) = -1 := by
+    rw [hρ₁]
+    exact j₁.2
+  let σ₀ := fun i : Fin m => w₀ (ρ₀ (Option.some i))
+  let σ₁ := fun i : Fin m => w₁ (ρ₁ (Option.some i))
+  have hrest : Fintype.card { i // σ₀ i = -1 } = Fintype.card { i // σ₁ i = -1 } := by
+    have hcount₀ := negative_card_split ρ₀ w₀
+    have hcount₁ := negative_card_split ρ₁ w₁
+    rw [hfirst₀] at hcount₀
+    rw [hfirst₁] at hcount₁
+    norm_num at hcount₀ hcount₁
+    change
+      Fintype.card { i // w₀ (ρ₀ (Option.some i)) = -1 } =
+        Fintype.card { i // w₁ (ρ₁ (Option.some i)) = -1 }
+    omega
+  obtain ⟨η, hη⟩ :=
+    exists_equiv_of_negative_card_eq σ₀ σ₁ (fun i => h₀ _) (fun i => h₁ _) rfl hrest
+  refine ⟨ρ₀, (Equiv.optionCongr η).trans ρ₁, hfirst₀, ?_, ?_⟩
+  · simpa using hfirst₁
+  · intro i
+    exact (hη i).symm
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Degree.SignedCoordinates.exists_adjacent_sign_enumerations_of_dimension {m n : ℕ}
+    (hn : n = m + 1) (w₀ w₁ : Fin n → ℝ) (h₀ : ∀ i, w₀ i = -1 ∨ w₀ i = 1)
+    (h₁ : ∀ i, w₁ i = -1 ∨ w₁ i = 1)
+    (hindex : Fintype.card { i // w₁ i = -1 } = Fintype.card { i // w₀ i = -1 } + 1) :
+    ∃ ρ₀ ρ₁ : Option (Fin m) ≃ Fin n,
+      w₀ (ρ₀ Option.none) = 1 ∧
+        w₁ (ρ₁ Option.none) = -1 ∧ ∀ i, w₀ (ρ₀ (Option.some i)) = w₁ (ρ₁ (Option.some i)) := by
+  subst n
+  exact exists_adjacent_sign_enumerations w₀ w₁ h₀ h₁ hindex
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.exists_matched_connection_basin_endpoints {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} {p q : M} (cp : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (cq : Smale.ManifoldMorse.SignedMorseChart (E := E) f q) (hf : Continuous f) {m : ℕ}
+    (hdim : Module.finrank ℝ E = m + 1)
+    (hindex :
+      Fintype.card { i // cq.weights i = -1 } = Fintype.card { i // cp.weights i = -1 } + 1)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hmono : ∀ x, Antitone (fun t => f (F t x))) {x : M} (hxp : x ≠ p) (hxq : x ≠ q)
+    (hp : Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p))
+    (hq : Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 q))
+    (heqp : ∀ᶠ y in 𝓝 p, V y = cp.descentField y) (heqq : ∀ᶠ y in 𝓝 q, V y = cq.descentField y) :
+    ∃ (σ : Fin m → ℝ) (Φp Φq : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞),
+      (∀ i, σ i = -1 ∨ σ i = 1) ∧
+        (1 / 2, (0 : Fin m → ℝ)) ∈ Φp.source ∧
+          Φp (1 / 2, 0) = p ∧
+            (-(1 / 2 : ℝ), (0 : Fin m → ℝ)) ∈ Φq.source ∧
+              Φq (-(1 / 2 : ℝ), 0) = q ∧
+                (∀ y ∈ Φp.target, V y = nativeCubicDescent σ Φp (-(1 / 2 : ℝ) ^ 2) y) ∧
+                  (∀ y ∈ Φq.target, V y = nativeCubicDescent σ Φq (-(1 / 2 : ℝ) ^ 2) y) ∧
+                    (∀ z ∈ Φp.source,
+                        Filter.Tendsto (fun t => F t (Φp z)) Filter.atTop (𝓝 p) ↔
+                          ∀ i, σ i = -1 → z.2 i = 0) ∧
+                      (∀ z ∈ Φq.source,
+                          Filter.Tendsto (fun t => F t (Φq z)) Filter.atBot (𝓝 q) ↔
+                            ∀ i, σ i = 1 → z.2 i = 0) ∧
+                        (∀ᶠ t in Filter.atTop,
+                            ∃ s ∈ Set.Ioo (-(1 / 2 : ℝ)) (1 / 2),
+                              (s, (0 : Fin m → ℝ)) ∈ Φp.source ∧ Φp (s, 0) = F t x) ∧
+                          ∀ᶠ t in Filter.atBot,
+                            ∃ s ∈ Set.Ioo (-(1 / 2 : ℝ)) (1 / 2),
+                              (s, (0 : Fin m → ℝ)) ∈ Φq.source ∧ Φq (s, 0) = F t x := by
+  obtain ⟨ρp, ρq, hρp, hρq, hmatch⟩ :=
+    Degree.SignedCoordinates.exists_adjacent_sign_enumerations_of_dimension hdim cp.weights
+      cq.weights cp.signs cq.signs hindex
+  let σ := fun i : Fin m => cp.weights (ρp (Option.some i))
+  obtain ⟨Φp, hpc, hpv, _, hpfield, hpbasin, hptail⟩ :=
+    exists_actual_incoming_cubic_basin cp hf ρp hρp hV F hF hmono hxp hp heqp
+  obtain ⟨Φq, hqc, hqv, _, hqfield, hqbasin, hqtail⟩ :=
+    exists_actual_outgoing_cubic_basin cq hf ρq hρq hV F hF hmono hxq hq heqq
+  have hsigma : (fun i : Fin m => cq.weights (ρq (Option.some i))) = σ :=
+    funext (fun i => (hmatch i).symm)
+  rw [hsigma] at hqfield hqbasin
+  exact
+    ⟨σ, Φp, Φq, fun i => cp.signs _, hpc, hpv, hqc, hqv, hpfield, hqfield, hpbasin, hqbasin,
+      hptail, hqtail⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_actual_connection_slice_data {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {m : ℕ} {f : M → ℝ} {p q x : M}
+    (cp : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (cq : Smale.ManifoldMorse.SignedMorseChart (E := E) f q) (hf : Continuous f)
+    (hdim : Module.finrank ℝ E = m + 1)
+    (hindex :
+      Fintype.card { i // cq.weights i = -1 } = Fintype.card { i // cp.weights i = -1 } + 1)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun y => (⟨y, V y⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ y, IsMIntegralCurve (fun t => F t y) V)
+    (hmono : ∀ y, Antitone (fun t => f (F t y))) (hxp : x ≠ p) (hxq : x ≠ q)
+    (hp : Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p))
+    (hq : Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 q))
+    (heqp : ∀ᶠ y in 𝓝 p, V y = cp.descentField y) (heqq : ∀ᶠ y in 𝓝 q, V y = cq.descentField y)
+    (A : PartialDiffeomorph 𝓘(ℝ, (Fin m → ℝ) × ℝ) 𝓘(ℝ, E) ((Fin m → ℝ) × ℝ) M ∞)
+    {U : Set (Fin m → ℝ)} (hAsource : A.source = U ×ˢ Set.univ) (h0U : 0 ∈ U)
+    (hAfield :
+      ∀ y ∈ A.target,
+        V y =
+          Smale.FlowConstruction.partialChartField A.symm (fun _ : (Fin m → ℝ) × ℝ => (0, 1)) y)
+    (hAaxis : ∀ t : ℝ, A (0, t) = F t x) :
+    ∃ (σ : Fin m → ℝ) (Ψq Ψp : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞) (B :
+      PartialDiffeomorph 𝓘(ℝ, (Fin m → ℝ) × ℝ) 𝓘(ℝ, E) ((Fin m → ℝ) × ℝ) M ∞) (Rq Rp Tq Tp : ℝ),
+      (∀ i, σ i = -1 ∨ σ i = 1) ∧
+        0 < Rq ∧
+          0 < Rp ∧
+            Ψq (-(1 / 2 : ℝ), 0) = q ∧
+              Ψp (1 / 2, 0) = p ∧
+                Metric.closedBall (-(1 / 2 : ℝ), (0 : Fin m → ℝ)) Rq ⊆ Ψq.source ∧
+                  Metric.closedBall (1 / 2, (0 : Fin m → ℝ)) Rp ⊆ Ψp.source ∧
+                    (∀ y ∈ Ψq.target, V y = nativeCubicDescent σ Ψq (-(1 / 2 : ℝ) ^ 2) y) ∧
+                      (∀ y ∈ Ψp.target, V y = nativeCubicDescent σ Ψp (-(1 / 2 : ℝ) ^ 2) y) ∧
+                        (∀ z ∈ Ψq.source,
+                            Filter.Tendsto (fun t => F t (Ψq z)) Filter.atBot (𝓝 q) ↔
+                              ∀ i, σ i = 1 → z.2 i = 0) ∧
+                          (∀ z ∈ Ψp.source,
+                              Filter.Tendsto (fun t => F t (Ψp z)) Filter.atTop (𝓝 p) ↔
+                                ∀ i, σ i = -1 → z.2 i = 0) ∧
+                            B.source ⊆ A.source ∧
+                              B.target ⊆ A.target ∧
+                                (∀ z, B z = A z) ∧
+                                  (∀ y ∈ B.target,
+                                      V y =
+                                        Smale.FlowConstruction.partialChartField B.symm
+                                          (fun _ : (Fin m → ℝ) × ℝ => (0, 1)) y) ∧
+                                    Nonempty
+                                      (NativeEndpointSliceData σ (1 / 2) Ψq Ψp B Rq Rp Tq Tp) := by
+  have ha : (0 : ℝ) < 1 / 2 := by norm_num
+  obtain
+    ⟨σ, Φp, Φq, hσ, hpc, hpv, hqc, hqv, hpfield, hqfield, hpbasin, hqbasin, hptail, hqtail⟩ :=
+    exists_matched_connection_basin_endpoints cp cq hf hdim hindex (hV.of_le (by simp)) F hF hmono
+      hxp hxq hp hq heqp heqq
+  obtain ⟨Ψp, Rp, δp, Tp, hps, hpval, hRp, hδp, hpbox, hpslice, hpf, hpaxis, hplimits⟩ :=
+    exists_basin_preserving_endpoint_clock σ ha Φp hV hpfield F hF
+      (show (1 / 2 : ℝ) ∈ Set.Icc (-(1 / 2 : ℝ)) (1 / 2) by constructor <;> norm_num) rfl hpc x
+      (by rw [hpv]; exact hp) hptail
+  obtain ⟨Ψq, Rq, δq, Tq, hqs, hqval, hRq, hδq, hqbox, hqslice, hqf, hqaxis, hqlimits⟩ :=
+    exists_basin_preserving_endpoint_clock σ ha Φq hV hqfield F hF
+      (show (-(1 / 2 : ℝ)) ∈ Set.Icc (-(1 / 2 : ℝ)) (1 / 2) by constructor <;> norm_num) (by ring)
+      hqc x (by rw [hqv]; exact hq) hqtail
+  have hqp : Ψq (cubicFlowCylinder σ (1 / 2) (0, Tq)) = A (0, Tq) :=
+    (hqaxis Tq (Metric.ball_subset_closedBall (hqslice 0 (by simpa using hδq.le)))).trans
+      (hAaxis Tq).symm
+  have hpp : Ψp (cubicFlowCylinder σ (1 / 2) (0, Tp)) = A (0, Tp) :=
+    (hpaxis Tp (Metric.ball_subset_closedBall (hpslice 0 (by simpa using hδp.le)))).trans
+      (hAaxis Tp).symm
+  obtain ⟨B, hBs, hBt, hBmap, hBfield, hdata⟩ :=
+    exists_original_endpoint_slice_data σ ha Ψq Ψp A hAsource h0U V hqf hpf hAfield hδq hδp hqbox
+      hpbox hqslice hpslice hqp hpp
+  refine
+    ⟨σ, Ψq, Ψp, B, Rq, Rp, Tq, Tp, hσ, hRq, hRp, hqval.trans hqv, hpval.trans hpv, hqbox, hpbox,
+      hqf, hpf, ?_, ?_, hBs, hBt, hBmap, hBfield, hdata⟩
+  · intro z hz
+    exact (hqlimits z q).2.trans (hqbasin z (hqs ▸ hz))
+  · intro z hz
+    exact (hplimits z p).1.trans (hpbasin z (hps ▸ hz))
+
+private theorem
+    Degree.TransverseGerms.hasFDerivAt_scalar_displacement {A : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] {f g : A → A} (hfzero : f 0 = 0)
+    (hf : HasFDerivAt f (ContinuousLinearMap.id ℝ A) 0)
+    (hscalar : ∀ x, ∃ α ∈ Set.Icc (0 : ℝ) 1, g x = x + α • (f x - x)) :
+    HasFDerivAt g (ContinuousLinearMap.id ℝ A) 0 := by
+  have hgzero : g 0 = 0 := by
+    obtain ⟨α, -, he⟩ := hscalar 0
+    simpa only [hfzero, sub_self, smul_zero, add_zero] using he
+  apply HasFDerivAt.of_isLittleO
+  apply Asymptotics.IsLittleO.of_bound
+  intro ε hε
+  filter_upwards [hf.isLittleO.bound hε] with x hx
+  simp only [hfzero, hgzero, sub_zero, ContinuousLinearMap.id_apply] at hx ⊢
+  obtain ⟨α, hα, he⟩ := hscalar x
+  rw [he, add_sub_cancel_left, norm_smul, Real.norm_eq_abs, abs_of_nonneg hα.1]
+  exact (mul_le_of_le_one_left (norm_nonneg _) hα.2).trans hx
+
+private theorem Degree.TransverseGerms.exists_open_transverse_convex_blend {A B : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    {φ : (A × B) → (A × B)} {U : Set (A × B)} (hU : IsOpen U) (hzero : (0 : A × B) ∈ U)
+    (hφ : ContDiffOn ℝ ∞ φ U) (hφzero : φ 0 = 0) (L : (A × B) →L[ℝ] (A × B))
+    (hder : fderiv ℝ φ 0 = L) (P : A ≃L[ℝ] A) (hP : ∀ x : A, (L (x, 0)).1 = P x) :
+    ∃ W : Set (A × B),
+      IsOpen W ∧
+        (0 : A × B) ∈ W ∧
+          W ⊆ U ∧
+            ∀ x : A,
+              (x, (0 : B)) ∈ W →
+                ∀ α ∈ Set.Icc (0 : ℝ) 1, (φ (x, 0) + α • (L (x, 0) - φ (x, 0))).1 = 0 ↔ x = 0 := by
+  let ι := ContinuousLinearMap.inl ℝ A B
+  let π := ContinuousLinearMap.fst ℝ A B
+  let H : A → A := fun x => P.symm ((φ (x, 0)).1)
+  let S : Set A := ι ⁻¹' U
+  have hS : IsOpen S := hU.preimage ι.continuous
+  have hSzero : (0 : A) ∈ S := hzero
+  have hH : ContDiffOn ℝ ∞ H S :=
+    P.symm.contDiff.comp_contDiffOn
+      (π.contDiff.comp_contDiffOn (hφ.comp ι.contDiff.contDiffOn (fun x hx => hx)))
+  have hfd : HasFDerivAt φ L 0 := by
+    rw [← hder]
+    exact ((hφ.contDiffAt (hU.mem_nhds hzero)).differentiableAt (by simp)).hasFDerivAt
+  have hHd : HasFDerivAt H (P.symm.toContinuousLinearMap.comp (π.comp (L.comp ι))) 0 :=
+    P.symm.toContinuousLinearMap.hasFDerivAt.comp (0 : A)
+      (π.hasFDerivAt.comp (0 : A) (hfd.comp (f := ι) (0 : A) ι.hasFDerivAt))
+  have hlinear :
+    P.symm.toContinuousLinearMap.comp (π.comp (L.comp ι)) = ContinuousLinearMap.id ℝ A := by
+    apply ContinuousLinearMap.ext
+    intro x
+    change P.symm ((L (x, 0)).1) = x
+    rw [hP, P.symm_apply_apply]
+  rw [hlinear] at hHd
+  let u : A → A := fun x => H x - x
+  have hu : ContDiffOn ℝ ∞ u S := hH.sub contDiffOn_id
+  have hu0 : u 0 = 0 := by
+    change P.symm ((φ (0 : A × B)).1) - 0 = 0
+    rw [hφzero]
+    simp
+  have hdu : fderiv ℝ u 0 = 0 := by
+    have hh := hHd.sub (hasFDerivAt_id (0 : A))
+    change fderiv ℝ (H - id) 0 = 0
+    simpa only [sub_self] using hh.fderiv
+  obtain ⟨ρ, hρ, -, hlip⟩ :=
+    Smale.SmallPerturbation.exists_closedBall_small_lipschitz_of_fderiv_zero hS hSzero hu hdu
+      (show (0 : ℝ≥0) < 1 / 2 by norm_num)
+  let W := U ∩ Metric.ball (0 : A × B) ρ
+  refine
+    ⟨W, hU.inter Metric.isOpen_ball, ⟨hzero, Metric.mem_ball_self hρ⟩, Set.inter_subset_left, ?_⟩
+  intro x hx α hα
+  have hxρ : x ∈ Metric.closedBall (0 : A) ρ := by
+    have hh := mem_ball_zero_iff.mp hx.2
+    apply mem_closedBall_zero_iff.mpr
+    simpa only [Prod.norm_def, norm_zero, max_eq_left (norm_nonneg x)] using hh.le
+  have h0ρ : (0 : A) ∈ Metric.closedBall (0 : A) ρ := Metric.mem_closedBall_self hρ.le
+  have herr : ‖u x‖ ≤ (1 / 2 : ℝ) * ‖x‖ := by
+    have hh := hlip.dist_le_mul x hxρ 0 h0ρ
+    simpa only [hu0, dist_zero_right, NNReal.coe_div, NNReal.coe_one, NNReal.coe_ofNat] using hh
+  constructor
+  · intro hz
+    have he : x + (1 - α) • u x = 0 := by
+      have hh := congrArg P.symm hz
+      change P.symm ((φ (x, 0)).1 + α • ((L (x, 0)).1 - (φ (x, 0)).1)) = P.symm 0 at hh
+      simp only [map_add, map_smul, map_sub, hP, P.symm_apply_apply, map_zero] at hh
+      change H x + α • (x - H x) = 0 at hh
+      calc
+        x + (1 - α) • u x = H x + α • (x - H x) := by dsimp [u]; module
+        _ = 0 := hh
+    have he' : x = -((1 - α) • u x) := eq_neg_of_add_eq_zero_left he
+    have hnorm : ‖x‖ ≤ (1 / 2 : ℝ) * ‖x‖ :=
+      calc
+        ‖x‖ = ‖-((1 - α) • u x)‖ := congrArg Norm.norm he'
+        _ = ‖(1 - α) • u x‖ := (norm_neg _)
+        _ = (1 - α) * ‖u x‖ := by
+          rw [norm_smul, Real.norm_eq_abs, abs_of_nonneg (by linarith [hα.2])]
+        _ ≤ ‖u x‖ := (mul_le_of_le_one_left (norm_nonneg _) (by linarith [hα.1]))
+        _ ≤ (1 / 2 : ℝ) * ‖x‖ := herr
+    exact norm_eq_zero.mp (le_antisymm (by linarith [norm_nonneg x]) (norm_nonneg x))
+  · rintro rfl
+    simp only [show ((0 : A), (0 : B)) = (0 : A × B) from rfl, hφzero, map_zero, sub_self,
+      smul_zero, add_zero, Prod.fst_zero]
+
+private theorem Degree.TransverseGerms.exists_supported_transverse_germ_linearization {A B : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [FiniteDimensional ℝ B]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, A × B) (A × B) (A × B) ∞)
+    (hzero : (0 : A × B) ∈ Φ.source) (hΦzero : Φ 0 = 0) (P : A ≃L[ℝ] A)
+    (hP : ∀ x : A, (fderiv ℝ Φ 0 (x, 0)).1 = P x)
+    (hunique : ∀ x : A, (x, (0 : B)) ∈ Φ.source → ((Φ (x, 0)).1 = 0 ↔ x = 0)) :
+    ∃ (C : (A × B) ≃L[ℝ] (A × B)) (H : ℝ × (A × B) → A × B) (K : Set (A × B)),
+      C.toContinuousLinearMap = fderiv ℝ Φ 0 ∧
+        IsCompact K ∧
+          K ⊆ Φ.target ∧
+            ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, A × B)) 𝓘(ℝ, A × B) ∞ H ∧
+              (∀ y, H (0, y) = y) ∧
+                (∀ t,
+                    ∃ D : Diffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, A × B) (A × B) (A × B) ∞,
+                      ∀ y, D y = H (t, y)) ∧
+                  (∀ t y, y ∉ K → H (t, y) = y) ∧
+                    (∀ t, H (t, 0) = 0) ∧
+                      (∀ t x, (x, (0 : B)) ∈ Φ.source → ((H (t, Φ (x, 0))).1 = 0 ↔ x = 0)) ∧
+                        (∀ t, fderiv ℝ (fun x => H (t, Φ x)) 0 = fderiv ℝ Φ 0) ∧
+                          (fun x => H (1, Φ x)) =ᶠ[𝓝 (0 : A × B)] C := by
+  have hΦ : ContDiffOn ℝ ∞ (Φ : (A × B) → A × B) Φ.source := Φ.contMDiffOn_toFun.contDiffOn
+  have hbij : Function.Bijective (fderiv ℝ Φ 0) := by
+    have hh := Smale.PartialChart.bijective_mfderiv Φ hzero
+    change Function.Bijective (mfderiv 𝓘(ℝ, A × B) 𝓘(ℝ, A × B) Φ 0 : (A × B) →L[ℝ] (A × B)) at hh
+    rwa [mfderiv_eq_fderiv] at hh
+  let C := (LinearEquiv.ofBijective (fderiv ℝ Φ 0).toLinearMap hbij).toContinuousLinearEquiv
+  have hC : C.toContinuousLinearMap = fderiv ℝ Φ 0 := rfl
+  obtain ⟨W, hW, hWzero, hWsource, hblend⟩ :=
+    exists_open_transverse_convex_blend Φ.open_source hzero hΦ hΦzero C.toContinuousLinearMap
+      hC.symm P hP
+  let U := Φ '' W
+  have hU : IsOpen U := Φ.toOpenPartialHomeomorph.isOpen_image_of_subset_source hW hWsource
+  have hUzero : (0 : A × B) ∈ U := ⟨0, hWzero, hΦzero⟩
+  have hUtarget : U ⊆ Φ.target := by
+    rintro y ⟨x, hx, rfl⟩
+    exact Φ.map_source' (hWsource hx)
+  have htzero : (0 : A × B) ∈ Φ.target := hUtarget hUzero
+  have hinvzero : Φ.symm 0 = 0 := by
+    have hh := Φ.left_inv' hzero
+    change Φ.symm (Φ 0) = 0 at hh
+    rwa [hΦzero] at hh
+  let G : (A × B) → A × B := C ∘ Φ.symm
+  have hG : ContDiffOn ℝ ∞ G U :=
+    C.contDiff.comp_contDiffOn (Φ.contMDiffOn_invFun.contDiffOn.mono hUtarget)
+  have hGzero : G 0 = 0 := by simp only [G, Function.comp_apply, hinvzero, map_zero]
+  have hdf :=
+    ((hΦ.contDiffAt (Φ.open_source.mem_nhds hzero)).differentiableAt (by simp)).hasFDerivAt
+  have hdi :=
+    ((Φ.contMDiffOn_invFun.contDiffOn.contDiffAt (Φ.open_target.mem_nhds htzero)).differentiableAt
+        (by simp)).hasFDerivAt
+  have hdf' : HasFDerivAt (Φ : (A × B) → A × B) (fderiv ℝ Φ 0) (Φ.symm 0) := by
+    rw [hinvzero]
+    exact hdf
+  have hcomp := hdf'.comp (f := Φ.symm) (0 : A × B) hdi
+  have hid : (Φ ∘ Φ.symm) =ᶠ[𝓝 (0 : A × B)] id := by
+    filter_upwards [Φ.open_target.mem_nhds htzero] with y hy
+    exact Φ.right_inv' hy
+  have hcancel : (fderiv ℝ Φ 0).comp (fderiv ℝ Φ.symm 0) = ContinuousLinearMap.id ℝ (A × B) :=
+    hcomp.fderiv.symm.trans (hid.fderiv_eq.trans fderiv_id)
+  have hdG : fderiv ℝ G 0 = ContinuousLinearMap.id ℝ (A × B) := by
+    have hh := C.toContinuousLinearMap.hasFDerivAt.comp (f := Φ.symm) (0 : A × B) hdi
+    exact hh.fderiv.trans (by rw [hC]; exact hcancel)
+  obtain ⟨H, K, hK, hKU, hH, hH0, hdiff, hfix, hscalar, hgerm⟩ :=
+    Smale.SmallPerturbation.exists_supported_tangent_identity_isotopy hU hUzero hG hGzero hdG
+  have hHorigin (t : ℝ) : H (t, 0) = 0 := by
+    obtain ⟨α, -, hα⟩ := hscalar t 0
+    simpa only [hGzero, sub_self, smul_zero, add_zero] using hα
+  have hdG' : HasFDerivAt G (ContinuousLinearMap.id ℝ (A × B)) 0 := by
+    rw [← hdG]
+    exact ((hG.contDiffAt (hU.mem_nhds hUzero)).differentiableAt (by simp)).hasFDerivAt
+  have hHder (t : ℝ) : HasFDerivAt (fun y => H (t, y)) (ContinuousLinearMap.id ℝ (A × B)) 0 :=
+    hasFDerivAt_scalar_displacement hGzero hdG' (hscalar t)
+  refine ⟨C, H, K, hC, hK, hKU.trans hUtarget, hH, hH0, hdiff, hfix, hHorigin, ?_, ?_, ?_⟩
+  · intro t x hx
+    by_cases hxin : Φ (x, 0) ∈ K
+    · obtain ⟨z, hz, hzeq⟩ := hKU hxin
+      have hzx : z = (x, 0) := Φ.toOpenPartialHomeomorph.injOn (hWsource hz) hx hzeq
+      have hxW : (x, (0 : B)) ∈ W := hzx ▸ hz
+      obtain ⟨α, hα, he⟩ := hscalar t (Φ (x, 0))
+      have hGΦ : G (Φ (x, 0)) = C (x, 0) := by
+        dsimp [G]
+        exact congrArg C (Φ.left_inv' hx)
+      rw [he, hGΦ]
+      exact hblend x hxW α hα
+    · rw [hfix t _ hxin]
+      exact hunique x hx
+  · intro t
+    have hh : HasFDerivAt (fun y => H (t, y)) (ContinuousLinearMap.id ℝ (A × B)) (Φ 0) := by
+      rw [hΦzero]
+      exact hHder t
+    simpa only [ContinuousLinearMap.id_comp, Function.comp_def] using
+      (hh.comp (f := Φ) (0 : A × B) hdf).fderiv
+  · have hΦtend : Filter.Tendsto Φ (𝓝 (0 : A × B)) (𝓝 0) := by
+      have hh := Φ.toOpenPartialHomeomorph.continuousAt hzero
+      change Filter.Tendsto Φ (𝓝 (0 : A × B)) (𝓝 (Φ 0)) at hh
+      rwa [hΦzero] at hh
+    filter_upwards [hgerm.comp_tendsto hΦtend, Φ.open_source.mem_nhds hzero] with x hx hxsource
+    change H (1, Φ x) = C x
+    change H (1, Φ x) = G (Φ x) at hx
+    rw [hx]
+    dsimp [G]
+    exact congrArg C (Φ.left_inv' hxsource)
+
+private def Degree.TransverseGerms.transverseBlockMap {A B : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] (P : A ≃L[ℝ] A) (S : B ≃L[ℝ] B)
+    (Q : B →L[ℝ] A) (R : A →L[ℝ] B) : (A × B) →L[ℝ] (A × B) :=
+  let T :=
+    P.toContinuousLinearMap.comp
+      (ContinuousLinearMap.fst ℝ A B + Q.comp (ContinuousLinearMap.snd ℝ A B))
+  T.prod (S.toContinuousLinearMap.comp (ContinuousLinearMap.snd ℝ A B) + R.comp T)
+
+private theorem Degree.TransverseGerms.exists_transverse_block_factorization {A B : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [FiniteDimensional ℝ B] (C : (A × B) ≃L[ℝ] (A × B)) (P : A ≃L[ℝ] A)
+    (hP : ∀ x : A, (C (x, 0)).1 = P x) :
+    ∃ (Q : B →L[ℝ] A) (R : A →L[ℝ] B) (S : B ≃L[ℝ] B),
+      C.toContinuousLinearMap = transverseBlockMap P S Q R := by
+  let Q : B →L[ℝ] A :=
+    P.symm.toContinuousLinearMap.comp
+      ((ContinuousLinearMap.fst ℝ A B).comp
+        (C.toContinuousLinearMap.comp (ContinuousLinearMap.inr ℝ A B)))
+  let R : A →L[ℝ] B :=
+    (ContinuousLinearMap.snd ℝ A B).comp
+      (C.toContinuousLinearMap.comp
+        ((ContinuousLinearMap.inl ℝ A B).comp P.symm.toContinuousLinearMap))
+  let S₀ : B →L[ℝ] B :=
+    (ContinuousLinearMap.snd ℝ A B).comp
+        (C.toContinuousLinearMap.comp (ContinuousLinearMap.inr ℝ A B)) -
+      R.comp
+        ((ContinuousLinearMap.fst ℝ A B).comp
+          (C.toContinuousLinearMap.comp (ContinuousLinearMap.inr ℝ A B)))
+  have hQ (y : B) : P (Q y) = (C (0, y)).1 := P.apply_symm_apply _
+  have hR (x : A) : R (P x) = (C (x, 0)).2 := by
+    change (C (P.symm (P x), 0)).2 = _
+    rw [P.symm_apply_apply]
+  have hsplit (p : A × B) : C p = C (p.1, 0) + C (0, p.2) := by
+    rw [← map_add]
+    congr 1
+    simp
+  have hmodel (p : A × B) : C p = (P (p.1 + Q p.2), S₀ p.2 + R (P (p.1 + Q p.2))) := by
+    apply Prod.ext
+    · rw [hsplit, Prod.fst_add, map_add, hP, hQ]
+    · rw [hsplit, Prod.snd_add, map_add, map_add, hR, hQ]
+      change
+        (C (p.1, 0)).2 + (C (0, p.2)).2 =
+          ((C (0, p.2)).2 - R ((C (0, p.2)).1)) + ((C (p.1, 0)).2 + R ((C (0, p.2)).1))
+      abel
+  have haxis (y : B) : C (-Q y, y) = (0, S₀ y) := by
+    rw [hmodel]
+    simp
+  have hbij : Function.Bijective S₀ := by
+    constructor
+    · intro x y hxy
+      have he : C (-Q x, x) = C (-Q y, y) := by rw [haxis, haxis, hxy]
+      exact congrArg Prod.snd (C.injective he)
+    · intro y
+      obtain ⟨p, hp⟩ := C.surjective (0, y)
+      have hfirst : P (p.1 + Q p.2) = 0 := by
+        have hh := congrArg Prod.fst hp
+        rwa [hmodel] at hh
+      have hsecond : S₀ p.2 + R (P (p.1 + Q p.2)) = y := by
+        have hh := congrArg Prod.snd hp
+        rwa [hmodel] at hh
+      exact ⟨p.2, by simpa only [hfirst, map_zero, add_zero] using hsecond⟩
+  let S := (LinearEquiv.ofBijective S₀.toLinearMap hbij).toContinuousLinearEquiv
+  refine ⟨Q, R, S, ?_⟩
+  apply ContinuousLinearMap.ext
+  intro p
+  exact hmodel p
+
+private theorem Degree.TransverseGerms.exists_supported_lower_shear_isotopy {A B : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [FiniteDimensional ℝ B] (R : A →L[ℝ] B) {U : Set (A × B)} (hU : IsOpen U)
+    (hzero : (0 : A × B) ∈ U) :
+    ∃ (H : ℝ × (A × B) → A × B) (K : Set (A × B)),
+      IsCompact K ∧
+        K ⊆ U ∧
+          ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, A × B)) 𝓘(ℝ, A × B) ∞ H ∧
+            (∀ p, H (0, p) = p) ∧
+              (∀ t,
+                  ∃ D : Diffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, A × B) (A × B) (A × B) ∞,
+                    ∀ p, D p = H (t, p)) ∧
+                (∀ t p, p ∉ K → H (t, p) = p) ∧
+                  (∀ t p, (H (t, p)).1 = p.1) ∧
+                    (∀ t y, H (t, ((0 : A), y)) = (0, y)) ∧
+                      (fun p => H (1, p)) =ᶠ[𝓝 (0 : A × B)] (fun p => (p.1, p.2 + R p.1)) := by
+  let e := ContinuousLinearEquiv.prodComm ℝ A B
+  let U' := e.symm ⁻¹' U
+  have hU' : IsOpen U' := hU.preimage e.symm.continuous
+  have hzero' : (0 : B × A) ∈ U' := by simpa only [U', Set.mem_preimage, map_zero] using hzero
+  obtain ⟨J, K', hK', hK'U', hJ, hJ0, hdiff, hfix, hsecond, hcore, hgerm⟩ :=
+    Smale.SupportedDiffeomorph.exists_supported_shear_isotopy R hU' hzero'
+  let H : ℝ × (A × B) → A × B := fun p => e.symm (J (p.1, e p.2))
+  let K := e.symm '' K'
+  have hK : IsCompact K := hK'.image e.symm.continuous
+  have hKU : K ⊆ U := by
+    rintro x ⟨y, hy, rfl⟩
+    exact hK'U' hy
+  have hH : ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, A × B)) 𝓘(ℝ, A × B) ∞ H :=
+    e.symm.contDiff.contMDiff.comp
+      (hJ.comp (contMDiff_fst.prodMk (e.contDiff.contMDiff.comp contMDiff_snd)))
+  refine ⟨H, K, hK, hKU, hH, ?_, ?_, ?_, ?_, ?_, ?_⟩
+  · intro p
+    change e.symm (J (0, e p)) = p
+    rw [hJ0, e.symm_apply_apply]
+  · intro t
+    obtain ⟨D, hD⟩ := hdiff t
+    refine ⟨(e.toDiffeomorph.trans D).trans e.symm.toDiffeomorph, ?_⟩
+    intro p
+    change e.symm (D (e p)) = e.symm (J (t, e p))
+    rw [hD]
+  · intro t p hp
+    have hnot : e p ∉ K' := fun h => hp ⟨e p, h, e.symm_apply_apply p⟩
+    change e.symm (J (t, e p)) = p
+    rw [hfix t _ hnot, e.symm_apply_apply]
+  · intro t p
+    exact hsecond t (e p)
+  · intro t y
+    change e.symm (J (t, (y, (0 : A)))) = (0, y)
+    rw [hcore]
+    rfl
+  · have ht : Filter.Tendsto e (𝓝 (0 : A × B)) (𝓝 0) := by
+      simpa only [map_zero] using e.continuous.tendsto (0 : A × B)
+    filter_upwards [hgerm.comp_tendsto ht] with p hp
+    change J (1, e p) = ((e p).1 + R (e p).2, (e p).2) at hp
+    change e.symm (J (1, e p)) = (p.1, p.2 + R p.1)
+    rw [hp]
+    rfl
+
+private theorem Degree.TransverseGerms.exists_supported_transverse_block_reduction {A B : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [FiniteDimensional ℝ B]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, A × B) (A × B) (A × B) ∞)
+    (hzero : (0 : A × B) ∈ Φ.source) (hΦzero : Φ 0 = 0) (P : A ≃L[ℝ] A)
+    (hP : ∀ x : A, (fderiv ℝ Φ 0 (x, 0)).1 = P x)
+    (hunique : ∀ x : A, (x, (0 : B)) ∈ Φ.source → ((Φ (x, 0)).1 = 0 ↔ x = 0)) :
+    ∃ (S : B ≃L[ℝ] B) (Dₛ Dₜ : Diffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, A × B) (A × B) (A × B) ∞) (Kₛ Kₜ :
+      Set (A × B)),
+      IsCompact Kₛ ∧
+        Kₛ ⊆ Φ.source ∧
+          IsCompact Kₜ ∧
+            Kₜ ⊆ Φ.target ∧
+              Nonempty
+                  (Smale.SupportedDiffeomorph.SupportedRelativeIsotopy Dₛ Kₛ
+                    {p : A × B | p.2 = 0}) ∧
+                Nonempty
+                    (Smale.SupportedDiffeomorph.SupportedRelativeIsotopy Dₜ Kₜ {(0 : A × B)}) ∧
+                  Set.MapsTo Dₛ Φ.source Φ.source ∧
+                    Set.MapsTo Dₜ Φ.target Φ.target ∧
+                      (∀ x : A, (x, (0 : B)) ∈ Φ.source → ((Dₜ (Φ (Dₛ (x, 0)))).1 = 0 ↔ x = 0)) ∧
+                        (fun p => Dₜ (Φ (Dₛ p))) =ᶠ[𝓝 (0 : A × B)] (fun p => (P p.1, S p.2)) := by
+  obtain ⟨C, H, K₁, hC, hK₁, hK₁target, hH, hH0, hHdiff, hHfix, hHorigin, hHunique, -, hHgerm⟩ :=
+    exists_supported_transverse_germ_linearization Φ hzero hΦzero P hP hunique
+  have hCP (x : A) : (C (x, 0)).1 = P x := by
+    change (C.toContinuousLinearMap (x, 0)).1 = P x
+    rw [hC]
+    exact hP x
+  obtain ⟨Q, R, S, hfactor⟩ := exists_transverse_block_factorization C P hCP
+  obtain ⟨J, K₂, hK₂, hK₂source, hJ, hJ0, hJdiff, hJfix, -, hJcore, hJgerm⟩ :=
+    Smale.SupportedDiffeomorph.exists_supported_shear_isotopy (-Q) Φ.open_source hzero
+  have htzero : (0 : A × B) ∈ Φ.target := by
+    have hh := Φ.map_source' hzero
+    rwa [hΦzero] at hh
+  obtain ⟨L, K₃, hK₃, hK₃target, hL, hL0, hLdiff, hLfix, hLfirst, hLcore, hLgerm⟩ :=
+    exists_supported_lower_shear_isotopy (-R) Φ.open_target htzero
+  obtain ⟨Dₕ, hDₕ⟩ := hHdiff 1
+  obtain ⟨Dₛ, hDₛ⟩ := hJdiff 1
+  obtain ⟨Dₗ, hDₗ⟩ := hLdiff 1
+  let Dₜ := Dₕ.trans Dₗ
+  let Kₜ := K₁ ∪ K₃
+  have hKₜ : IsCompact Kₜ := hK₁.union hK₃
+  have hKₜtarget : Kₜ ⊆ Φ.target := Set.union_subset hK₁target hK₃target
+  have hsrc : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy Dₛ K₂ {p : A × B | p.2 = 0} := by
+    refine ⟨J, hJ, hJ0, fun p => (hDₛ p).symm, hJdiff, hJfix, ?_⟩
+    rintro t ⟨x, y⟩ hy
+    change y = 0 at hy
+    subst y
+    exact hJcore t x
+  have htgt : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy Dₜ Kₜ {(0 : A × B)} := by
+    let T : ℝ × (A × B) → A × B := fun p => L (p.1, H p)
+    have hT : ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, A × B)) 𝓘(ℝ, A × B) ∞ T :=
+      hL.comp (contMDiff_fst.prodMk hH)
+    refine ⟨T, hT, ?_, ?_, ?_, ?_, ?_⟩
+    · intro p
+      change L (0, H (0, p)) = p
+      rw [hH0, hL0]
+    · intro p
+      change L (1, H (1, p)) = Dₗ (Dₕ p)
+      rw [hDₗ, hDₕ]
+    · intro t
+      obtain ⟨Eₕ, hEₕ⟩ := hHdiff t
+      obtain ⟨Eₗ, hEₗ⟩ := hLdiff t
+      refine ⟨Eₕ.trans Eₗ, ?_⟩
+      intro p
+      change Eₗ (Eₕ p) = L (t, H (t, p))
+      rw [hEₗ, hEₕ]
+    · intro t p hp
+      change L (t, H (t, p)) = p
+      rw [hHfix t p (fun h => hp (Or.inl h)), hLfix t p (fun h => hp (Or.inr h))]
+    · intro t p hp
+      have hp0 : p = 0 := Set.mem_singleton_iff.mp hp
+      subst p
+      change L (t, H (t, 0)) = 0
+      rw [hHorigin]
+      exact hLcore t 0
+  have hsrczero : Dₛ (0 : A × B) = 0 := hsrc.endpoint_fixed_on 0 rfl
+  have hsrctend : Filter.Tendsto Dₛ (𝓝 (0 : A × B)) (𝓝 0) := by
+    have hh := Dₛ.continuous.tendsto (0 : A × B)
+    rwa [hsrczero] at hh
+  refine
+    ⟨S, Dₛ, Dₜ, K₂, Kₜ, hK₂, hK₂source, hKₜ, hKₜtarget, ⟨hsrc⟩, ⟨htgt⟩,
+      Smale.SupportedDiffeomorph.mapsTo_source Φ Dₛ.toEquiv hK₂source hsrc.endpoint_fixed_outside,
+      Smale.SupportedDiffeomorph.mapsTo_source Φ.symm Dₜ.toEquiv hKₜtarget
+        htgt.endpoint_fixed_outside,
+      ?_, ?_⟩
+  · intro x hx
+    have hfixed : Dₛ (x, (0 : B)) = (x, 0) := hsrc.endpoint_fixed_on (x, 0) rfl
+    rw [hfixed]
+    change (Dₗ (Dₕ (Φ (x, 0)))).1 = 0 ↔ x = 0
+    rw [hDₗ, hLfirst, hDₕ]
+    exact hHunique 1 x hx
+  · have hCtend : Filter.Tendsto (fun p => C (Dₛ p)) (𝓝 (0 : A × B)) (𝓝 0) := by
+      have hh : Filter.Tendsto C (𝓝 (0 : A × B)) (𝓝 0) := by
+        simpa only [map_zero] using C.continuous.tendsto (0 : A × B)
+      exact hh.comp hsrctend
+    filter_upwards [hHgerm.comp_tendsto hsrctend, hLgerm.comp_tendsto hCtend, hJgerm] with p hpH
+      hpL hpJ
+    change H (1, Φ (Dₛ p)) = C (Dₛ p) at hpH
+    change L (1, C (Dₛ p)) = ((C (Dₛ p)).1, (C (Dₛ p)).2 + (-R) (C (Dₛ p)).1) at hpL
+    change J (1, p) = (p.1 + (-Q) p.2, p.2) at hpJ
+    change Dₗ (Dₕ (Φ (Dₛ p))) = (P p.1, S p.2)
+    rw [hDₗ, hDₕ, hpH, hpL, hDₛ, hpJ]
+    have hmodel (z : A × B) : C z = (P (z.1 + Q z.2), S z.2 + R (P (z.1 + Q z.2))) := by
+      have hh := congrArg (fun T : (A × B) →L[ℝ] (A × B) => T z) hfactor
+      exact hh
+    rw [hmodel]
+    simp only [neg_apply, add_neg_cancel_right, neg_add_cancel_right]
+
+private theorem Degree.TransverseGerms.exists_projected_equiv_of_native_transverse {A B : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup B]
+    [NormedSpace ℝ B]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, A × B) (A × B) (A × B) ∞)
+    (hzero : (0 : A × B) ∈ Φ.source) (hΦzero : Φ 0 = 0)
+    (htrans :
+      Smale.NativeTransversality.At 𝓘(ℝ, A) 𝓘(ℝ, B) 𝓘(ℝ, A × B) (fun x : A => Φ (x, 0))
+        (fun y : B => (0, y)) 0 0) :
+    ∃ P : A ≃L[ℝ] A, ∀ x : A, (fderiv ℝ Φ 0 (x, 0)).1 = P x := by
+  let D : A →L[ℝ] (A × B) := (fderiv ℝ Φ 0).comp (ContinuousLinearMap.inl ℝ A B)
+  let N : (A × B) →L[ℝ] A := ContinuousLinearMap.fst ℝ A B
+  let J : B →L[ℝ] (A × B) := ContinuousLinearMap.inr ℝ A B
+  have hdiff :=
+    (Φ.contMDiffOn_toFun.contDiffOn.contDiffAt (Φ.open_source.mem_nhds hzero)).differentiableAt
+      (by simp)
+  have hι : HasFDerivAt (fun x : A => (x, (0 : B))) (ContinuousLinearMap.inl ℝ A B) (0 : A) :=
+    (ContinuousLinearMap.inl ℝ A B).hasFDerivAt
+  have hd : HasFDerivAt (fun x : A => Φ (x, 0)) D 0 :=
+    hdiff.hasFDerivAt.comp (f := fun x : A => (x, (0 : B))) (0 : A) hι
+  have hj : HasFDerivAt (fun y : B => (0, y)) J 0 := (ContinuousLinearMap.inr ℝ A B).hasFDerivAt
+  have hcross : (0, (0 : B)) = Φ ((0 : A), 0) := hΦzero.symm
+  have ht := htrans hcross
+  rw [mfderiv_eq_fderiv, mfderiv_eq_fderiv, hd.fderiv, hj.fderiv] at ht
+  have hNJ : N.comp J = 0 := by
+    apply ContinuousLinearMap.ext
+    intro y
+    rfl
+  have hN : Function.Surjective N := fun x => ⟨(x, 0), rfl⟩
+  have hJD : Function.Surjective (J.coprod D) :=
+    Smale.TransverseCoordinates.surjective_coprod_swap D J ht
+  have hbij : Function.Bijective (N.comp D) :=
+    Smale.TransverseCoordinates.bijective_normal_comp N J D hN hJD hNJ rfl
+  let P := (LinearEquiv.ofBijective (N.comp D).toLinearMap hbij).toContinuousLinearEquiv
+  exact ⟨P, fun _ => rfl⟩
+
+private theorem Degree.TransverseGerms.exists_block_reduction_of_native_transverse {A B : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [FiniteDimensional ℝ B]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, A × B) (A × B) (A × B) ∞)
+    (hzero : (0 : A × B) ∈ Φ.source) (hΦzero : Φ 0 = 0)
+    (htrans :
+      Smale.NativeTransversality.At 𝓘(ℝ, A) 𝓘(ℝ, B) 𝓘(ℝ, A × B) (fun x : A => Φ (x, 0))
+        (fun y : B => (0, y)) 0 0)
+    (hunique : ∀ x : A, (x, (0 : B)) ∈ Φ.source → ((Φ (x, 0)).1 = 0 ↔ x = 0)) :
+    ∃ P : A ≃L[ℝ] A,
+      (∀ x : A, (fderiv ℝ Φ 0 (x, 0)).1 = P x) ∧
+        ∃ (S : B ≃L[ℝ] B) (Dₛ Dₜ : Diffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, A × B) (A × B) (A × B) ∞) (Kₛ Kₜ :
+          Set (A × B)),
+          IsCompact Kₛ ∧
+            Kₛ ⊆ Φ.source ∧
+              IsCompact Kₜ ∧
+                Kₜ ⊆ Φ.target ∧
+                  Nonempty
+                      (Smale.SupportedDiffeomorph.SupportedRelativeIsotopy Dₛ Kₛ
+                        {p : A × B | p.2 = 0}) ∧
+                    Nonempty
+                        (Smale.SupportedDiffeomorph.SupportedRelativeIsotopy Dₜ Kₜ
+                          {(0 : A × B)}) ∧
+                      Set.MapsTo Dₛ Φ.source Φ.source ∧
+                        Set.MapsTo Dₜ Φ.target Φ.target ∧
+                          (∀ x : A,
+                              (x, (0 : B)) ∈ Φ.source → ((Dₜ (Φ (Dₛ (x, 0)))).1 = 0 ↔ x = 0)) ∧
+                            (fun p => Dₜ (Φ (Dₛ p))) =ᶠ[𝓝 (0 : A × B)]
+                              (fun p => (P p.1, S p.2)) := by
+  obtain ⟨P, hP⟩ := exists_projected_equiv_of_native_transverse Φ hzero hΦzero htrans
+  exact ⟨P, hP, exists_supported_transverse_block_reduction Φ hzero hΦzero P hP hunique⟩
+
+private theorem Degree.TransverseGerms.label_sheets_transverse_in_incoming_chart {A B Z : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    (Q P : PartialDiffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, Z) (A × B) Z ∞) (hQsrc : (0 : A × B) ∈ Q.source)
+    (hPsrc : (0 : A × B) ∈ P.source) (hQ0 : Q 0 = 0) (hP0 : P 0 = 0)
+    (htrans :
+      Smale.NativeTransversality.At 𝓘(ℝ, A) 𝓘(ℝ, B) 𝓘(ℝ, Z) (fun x : A => Q (x, 0))
+        (fun y : B => P (0, y)) 0 0) :
+    Function.Surjective
+      ((mfderiv 𝓘(ℝ, A) 𝓘(ℝ, A × B) (fun x : A => P.symm (Q (x, 0))) 0).coprod
+        (mfderiv 𝓘(ℝ, B) 𝓘(ℝ, A × B) (fun y : B => P.symm (P (0, y))) 0)) := by
+  have hcross : P ((0 : A), (0 : B)) = Q (0, 0) := hP0.trans hQ0.symm
+  have htarget : Q ((0 : A), (0 : B)) ∈ P.target := by
+    change Q (0 : A × B) ∈ P.target
+    rw [hQ0, ← hP0]
+    exact P.map_source' hPsrc
+  have hι : MDifferentiableAt 𝓘(ℝ, A) 𝓘(ℝ, A × B) (fun x : A => (x, (0 : B))) 0 :=
+    ((contDiff_id : ContDiff ℝ ∞ (fun x : A => x)).prodMk
+          contDiff_const).contMDiff.mdifferentiableAt
+      (by simp)
+  have hκ : MDifferentiableAt 𝓘(ℝ, B) 𝓘(ℝ, A × B) (fun y : B => ((0 : A), y)) 0 :=
+    (contDiff_const.prodMk
+          (contDiff_id : ContDiff ℝ ∞ (fun y : B => y))).contMDiff.mdifferentiableAt
+      (by simp)
+  have hqdiff : MDifferentiableAt 𝓘(ℝ, A) 𝓘(ℝ, Z) (fun x : A => Q (x, 0)) 0 :=
+    (Q.mdifferentiableAt (by simp) hQsrc).comp (f := fun x : A => (x, (0 : B))) 0 hι
+  have hpdiff : MDifferentiableAt 𝓘(ℝ, B) 𝓘(ℝ, Z) (fun y : B => P (0, y)) 0 :=
+    (P.mdifferentiableAt (by simp) hPsrc).comp (f := fun y : B => ((0 : A), y)) 0 hκ
+  exact
+    Smale.ChartMapPerturbation.transverse_in_chart P.symm hqdiff hpdiff hcross htarget
+      (htrans hcross)
+
+private theorem
+    Degree.TransverseGerms.relative_label_sheet_germs {A B Z : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] (Q P : PartialDiffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, Z) (A × B) Z ∞)
+    (H : PartialDiffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, A × B) (A × B) (A × B) ∞)
+    (h0 : (0 : A × B) ∈ H.source) (hPsrc : (0 : A × B) ∈ P.source) (hHt : H.target ⊆ P.source)
+    (hdiagram : ∀ u ∈ H.source, P (H u) = Q u) :
+    ((fun x : A => P.symm (Q (x, (0 : B)))) =ᶠ[𝓝 0] (fun x : A => H (x, 0))) ∧
+      ((fun y : B => P.symm (P ((0 : A), y))) =ᶠ[𝓝 0] (fun y : B => (0, y))) := by
+  have hnearH : ∀ᶠ x : A in 𝓝 0, (x, (0 : B)) ∈ H.source :=
+    (continuous_id.prodMk continuous_const).continuousAt.eventually (H.open_source.mem_nhds h0)
+  have heqH : (fun x : A => P.symm (Q (x, (0 : B)))) =ᶠ[𝓝 0] (fun x : A => H (x, 0)) := by
+    filter_upwards [hnearH] with x hx
+    rw [← hdiagram (x, 0) hx]
+    exact P.left_inv' (hHt (H.map_source' hx))
+  have hnearP : ∀ᶠ y : B in 𝓝 0, ((0 : A), y) ∈ P.source :=
+    (continuous_const.prodMk continuous_id).continuousAt.eventually (P.open_source.mem_nhds hPsrc)
+  have heqP : (fun y : B => P.symm (P ((0 : A), y))) =ᶠ[𝓝 0] (fun y : B => (0, y)) := by
+    filter_upwards [hnearP] with y hy
+    exact P.left_inv' hy
+  exact ⟨heqH, heqP⟩
+
+private theorem Degree.TransverseGerms.relative_transverse_of_label_sheets {A B Z : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    (Q P : PartialDiffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, Z) (A × B) Z ∞)
+    (H : PartialDiffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, A × B) (A × B) (A × B) ∞)
+    (h0 : (0 : A × B) ∈ H.source) (hH0 : H 0 = 0) (hQ0 : Q 0 = 0) (hP0 : P 0 = 0)
+    (hHs : H.source ⊆ Q.source) (hHt : H.target ⊆ P.source)
+    (hdiagram : ∀ u ∈ H.source, P (H u) = Q u)
+    (htrans :
+      Smale.NativeTransversality.At 𝓘(ℝ, A) 𝓘(ℝ, B) 𝓘(ℝ, Z) (fun x : A => Q (x, 0))
+        (fun y : B => P (0, y)) 0 0) :
+    Smale.NativeTransversality.At 𝓘(ℝ, A) 𝓘(ℝ, B) 𝓘(ℝ, A × B) (fun x : A => H (x, 0))
+      (fun y : B => (0, y)) 0 0 := by
+  have hPsrc : (0 : A × B) ∈ P.source := by
+    have hh := hHt (H.map_source' h0)
+    rwa [hH0] at hh
+  have ht := label_sheets_transverse_in_incoming_chart Q P (hHs h0) hPsrc hQ0 hP0 htrans
+  obtain ⟨heqH, heqP⟩ := relative_label_sheet_germs Q P H h0 hPsrc hHt hdiagram
+  rw [heqH.mfderiv_eq, heqP.mfderiv_eq] at ht
+  exact fun _ => ht
+
+private theorem Degree.FlowSuspension.relative_intersection_of_native_unique_connection
+    {A B Z E M : Type*} [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, E) (Z × ℝ) M ∞) {U : Set Z}
+    (hsource : Φ.source = U ×ˢ Set.univ) (h0U : (0 : Z) ∈ U) (F : Flow ℝ M)
+    (hflow : ∀ z ∈ U, ∀ t : ℝ, Φ (z, t) = F t (Φ (z, 0)))
+    (Q P : PartialDiffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, Z) (A × B) Z ∞)
+    (H : PartialDiffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, A × B) (A × B) (A × B) ∞)
+    (h0 : (0 : A × B) ∈ H.source) (hH0 : H 0 = 0) (hQ0 : Q 0 = 0) (hHs : H.source ⊆ Q.source)
+    (hQU : Q.target ⊆ U) (hdiagram : ∀ z ∈ H.source, P (H z) = Q z) {p q : M}
+    (hleftBasin :
+      ∀ z ∈ U,
+        Filter.Tendsto (fun t => F t (Φ (z, 0))) Filter.atBot (𝓝 q) ↔
+          ∃ x : A, (x, (0 : B)) ∈ H.source ∧ Q (x, 0) = z)
+    (hrightBasin :
+      ∀ z ∈ U,
+        Filter.Tendsto (fun t => F t (Φ (z, 1))) Filter.atTop (𝓝 p) ↔
+          ∃ y ∈ H.target, y.1 = 0 ∧ P y = z)
+    (hunique :
+      ∀ x,
+        Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 q) →
+          Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p) → ∃ t, F t (Φ (0, 0)) = x) :
+    ∀ x : A, (x, (0 : B)) ∈ H.source → ((H (x, 0)).1 = 0 ↔ x = 0) := by
+  intro x hx
+  constructor
+  · intro hfirst
+    have hzU : Q (x, 0) ∈ U := hQU (Q.map_source' (hHs hx))
+    have hbot : Filter.Tendsto (fun t => F t (Φ (Q (x, 0), 0))) Filter.atBot (𝓝 q) :=
+      (hleftBasin _ hzU).mpr ⟨x, hx, rfl⟩
+    have htop1 : Filter.Tendsto (fun t => F t (Φ (Q (x, 0), 1))) Filter.atTop (𝓝 p) :=
+      (hrightBasin _ hzU).mpr ⟨H (x, 0), H.map_source' hx, hfirst, hdiagram _ hx⟩
+    rw [hflow _ hzU 1] at htop1
+    have htop := (MorseCancel.flow_time_atTop_limit_iff F 1 (Φ (Q (x, 0), 0)) p).mp htop1
+    obtain ⟨t, ht⟩ := hunique _ hbot htop
+    have hsrc0 : ((0 : Z), t) ∈ Φ.source := by rw [hsource]; exact ⟨h0U, Set.mem_univ _⟩
+    have hsrcx : (Q (x, 0), (0 : ℝ)) ∈ Φ.source := by rw [hsource]; exact ⟨hzU, Set.mem_univ _⟩
+    have hpoints : Φ (0, t) = Φ (Q (x, 0), 0) := (hflow 0 h0U t).trans ht
+    have hlabel : (0 : Z) = Q (x, 0) :=
+      congrArg Prod.fst (Φ.toOpenPartialHomeomorph.injOn hsrc0 hsrcx hpoints)
+    have hpair : (x, (0 : B)) = (0 : A × B) :=
+      Q.toOpenPartialHomeomorph.injOn (hHs hx) (hHs h0) (hlabel.symm.trans hQ0.symm)
+    exact congrArg Prod.fst hpair
+  · intro hx0
+    subst x
+    change (H (0 : A × B)).1 = 0
+    rw [hH0]
+    rfl
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Degree.TransverseGerms.exists_cylinder_block_correction {A B Z : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [FiniteDimensional ℝ B] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    (Q P : PartialDiffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, Z) (A × B) Z ∞)
+    (H : PartialDiffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, A × B) (A × B) (A × B) ∞)
+    (h0 : (0 : A × B) ∈ H.source) (hH0 : H 0 = 0) (hQzero : Q 0 = 0) (hPzero : P 0 = 0)
+    (hHs : H.source ⊆ Q.source) (hHt : H.target ⊆ P.source)
+    (hdiagram : ∀ z ∈ H.source, P (H z) = Q z)
+    (htrans :
+      Smale.NativeTransversality.At 𝓘(ℝ, A) 𝓘(ℝ, B) 𝓘(ℝ, A × B) (fun x : A => H (x, 0))
+        (fun y : B => (0, y)) 0 0)
+    (hunique : ∀ x : A, (x, (0 : B)) ∈ H.source → ((H (x, 0)).1 = 0 ↔ x = 0)) :
+    ∃ (L₁ : A ≃L[ℝ] A) (L₂ : B ≃L[ℝ] B) (D : Diffeomorph 𝓘(ℝ, Z) 𝓘(ℝ, Z) Z Z ∞) (K : Set Z),
+      IsCompact K ∧
+        K ⊆ Q.target ∩ P.target ∧
+          Nonempty (Smale.SupportedDiffeomorph.SupportedRelativeIsotopy D K {(0 : Z)}) ∧
+            D 0 = 0 ∧
+              (∀ z ∈ H.source, D (Q z) ∈ P.target) ∧
+                (∀ x : A, (x, (0 : B)) ∈ H.source → ((P.symm (D (Q (x, 0)))).1 = 0 ↔ x = 0)) ∧
+                  (fun z => D (Q z)) =ᶠ[𝓝 (0 : A × B)] (fun z => P (L₁ z.1, L₂ z.2)) := by
+  obtain ⟨L₁, _, L₂, Dₛ, Dₜ, Kₛ, Kₜ, hKₛ, hKs, hKₜ, hKt, ⟨Iₛ⟩, ⟨Iₜ⟩, hDₛ, hDₜ, huniq, hgerm⟩ :=
+    exists_block_reduction_of_native_transverse H h0 hH0 htrans hunique
+  have hP0 : (0 : A × B) ∈ P.source := by
+    have hh := hHt (H.map_source' h0)
+    rwa [hH0] at hh
+  obtain ⟨D, K, hK, _, hKU, hI, hD0, hformula⟩ :=
+    exists_transported_transition_correction Q P H (hHs h0) hP0 hQzero hPzero hHs hHt hdiagram Dₛ
+      Dₜ hKₛ hKₜ hKs hKt (show (0 : A × B) ∈ {p : A × B | p.2 = 0} from rfl)
+      (show (0 : A × B) ∈ ({(0 : A × B)} : Set (A × B)) from rfl) Iₛ Iₜ
+  have hPt (z : A × B) (hz : z ∈ H.source) : Dₜ (H (Dₛ z)) ∈ P.source :=
+    hHt (hDₜ (H.map_source' (hDₛ hz)))
+  have hinverse (z : A × B) (hz : z ∈ H.source) : P.symm (D (Q z)) = Dₜ (H (Dₛ z)) := by
+    rw [hformula z hz]
+    exact P.left_inv' (hPt z hz)
+  refine ⟨L₁, L₂, D, K, hK, hKU, hI, hD0, ?_, ?_, ?_⟩
+  · intro z hz
+    rw [hformula z hz]
+    exact P.map_source' (hPt z hz)
+  · intro x hx
+    rw [hinverse (x, 0) hx]
+    exact huniq x hx
+  · filter_upwards [H.open_source.mem_nhds h0, hgerm] with z hz hg
+    rw [hformula z hz, hg]
+
+private theorem Degree.FlowSuspension.flow_preserves_base_region {E : Type*} [NormedAddCommGroup E]
+     (F : Flow ℝ (E × ℝ)) {K U : Set E} (hKU : K ⊆ U)
+    (hfix : ∀ x ∉ K, ∀ s t : ℝ, F t (x, s) = (x, s + t)) {p : E × ℝ} (hp : p.1 ∈ U) (t : ℝ) :
+    (F t p).1 ∈ U := by
+  by_contra hout
+  have hnotK : (F t p).1 ∉ K := fun h => hout (hKU h)
+  have hh := hfix (F t p).1 hnotK (F t p).2 (-t)
+  change F (-t) (F t p) = ((F t p).1, (F t p).2 + -t) at hh
+  rw [← F.map_add, neg_add_cancel, F.map_zero_apply] at hh
+  have he := congrArg (fun z : E × ℝ => z.1) hh
+  change p.1 = (F t p).1 at he
+  exact hout (he ▸ hp)
+
+private theorem Degree.FlowSuspension.exists_native_suspension_chart {E B M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [TopologicalSpace M] [ChartedSpace B M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, B) (E × ℝ) M ∞) {U : Set E}
+    (hsource : Φ.source = U ×ˢ Set.univ) {D : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞} {K : Set E}
+    (hKU : K ⊆ U) {W : (E × ℝ) → E × ℝ} {F : Flow ℝ (E × ℝ)} (C : SuspensionCoordinates D K W F)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, B) x)
+    (hmodel : ∀ y ∈ Φ.target, V y = Smale.FlowConstruction.partialChartField Φ.symm W y) :
+    ∃ Ω : PartialDiffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, B) (E × ℝ) M ∞,
+      Ω.source = Φ.source ∧
+        Ω.target = Φ.target ∧
+          (∀ p, Ω p = Φ (C.chart p)) ∧
+            (∀ y ∈ Ω.target,
+                V y =
+                  Smale.FlowConstruction.partialChartField Ω.symm (fun _ : E × ℝ => (0, 1)) y) ∧
+              (∀ p, p.2 ≤ 0 → Ω p = Φ p) ∧ (∀ p, 1 ≤ p.2 → Ω p = Φ (D p.1, p.2)) := by
+  let Ω := C.chart.toPartialDiffeomorph.trans Φ
+  have hΩsource : Ω.source = Φ.source := by
+    ext p
+    change (p ∈ (Set.univ : Set (E × ℝ)) ∧ C.chart p ∈ Φ.source) ↔ p ∈ Φ.source
+    rw [hsource]
+    simp only [Set.mem_univ, true_and, Set.mem_prod, and_true, C.base_iff U hKU]
+  have hΩtarget : Ω.target = Φ.target := by
+    ext y
+    change (y ∈ Φ.target ∧ Φ.symm y ∈ (Set.univ : Set (E × ℝ))) ↔ y ∈ Φ.target
+    simp only [Set.mem_univ, and_true]
+  have hpush (p : E × ℝ) (_ : p ∈ C.chart.toPartialDiffeomorph.source) :
+    fderiv ℝ C.chart.toPartialDiffeomorph p (0, 1) = W (C.chart p) := by
+    calc
+      fderiv ℝ C.chart.toPartialDiffeomorph p (0, 1) = suspensionField C.chart (C.chart p) := by
+        simp only [suspensionField, C.chart.symm_apply_apply]
+        rfl
+      _ = W (C.chart p) := (congrArg (fun w => w (C.chart p)) C.field_eq).symm
+  refine ⟨Ω, hΩsource, hΩtarget, fun _ => rfl, ?_, ?_, ?_⟩
+  · intro y hy
+    have hyt : y ∈ Φ.target := hΩtarget ▸ hy
+    rw [hmodel y hyt]
+    exact
+      (MorseCancel.partialChartField_of_model_conjugacy C.chart.toPartialDiffeomorph Φ
+          (fun _ : E × ℝ => (0, 1)) W hpush hy).symm
+  · intro p hp
+    change Φ (C.chart p) = Φ p
+    rw [C.lower p hp]
+  · intro p hp
+    change Φ (C.chart p) = Φ (D p.1, p.2)
+    rw [C.upper p hp]
+
+private theorem
+    Degree.FlowSuspension.exists_full_cylinder_holonomy {E B M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [FiniteDimensional ℝ B] [TopologicalSpace M] [ChartedSpace B M] [IsManifold 𝓘(ℝ, B) ∞ M]
+    [T2Space M] [CompactSpace M] (Φ : PartialDiffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, B) (E × ℝ) M ∞)
+    {U : Set E} (hsource : Φ.source = U ×ˢ Set.univ) {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, B) 𝓘(ℝ, ℝ) ∞ f) {c : ℝ}
+    (hheight : ∀ p ∈ Φ.source, p.2 ∈ Set.Ioo (0 : ℝ) 1 → f (Φ p) = c - p.2)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, B) x)
+    (hV : ContMDiff 𝓘(ℝ, B) (𝓘(ℝ, B).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, B) M)))
+    (hmodel :
+      ∀ x ∈ Φ.target,
+        V x = Smale.FlowConstruction.partialChartField Φ.symm (fun _ : E × ℝ => (0, 1)) x)
+    (H : Flow ℝ M) (hH : ∀ x, IsMIntegralCurve (fun t => H t x) V)
+    (D : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞) {K S : Set E} (hK : IsCompact K) (hKU : K ⊆ U)
+    (I : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy D K S) :
+    ∃ (N : Set M) (V' : (x : M) → TangentSpace 𝓘(ℝ, B) x) (G : Flow ℝ M),
+      IsCompact N ∧
+        N ⊆ Φ.target ∩ f ⁻¹' Set.Ioo (c - 1) c ∧
+          ContMDiff 𝓘(ℝ, B) (𝓘(ℝ, B).tangent) ∞ (fun x => (⟨x, V' x⟩ : TangentBundle 𝓘(ℝ, B) M)) ∧
+            (∀ x, IsMIntegralCurve (fun t => G t x) V') ∧
+              (∀ x, V' x = 0 ↔ V x = 0) ∧
+                (∀ x, mvfderiv 𝓘(ℝ, B) f x (V x) < 0 → mvfderiv 𝓘(ℝ, B) f x (V' x) < 0) ∧
+                  (∀ x ∉ N, ∀ᶠ y in 𝓝 x, V' y = V y) ∧
+                    (∀ x ∈ Φ.target, ∀ t, G t x ∈ Φ.target) ∧
+                      (∀ x ∉ Φ.target, ∀ t, G t x = H t x) ∧
+                        (∀ x ∈ U, G 1 (Φ (x, 0)) = Φ (D x, 1)) ∧
+                          (∀ x ∈ U ∩ S, ∀ s t : ℝ, G t (Φ (x, s)) = Φ (x, s + t)) ∧
+                            ∃ Ω : PartialDiffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, B) (E × ℝ) M ∞,
+                              Ω.source = U ×ˢ Set.univ ∧
+                                Ω.target = Φ.target ∧
+                                  (∀ y ∈ Ω.target,
+                                      V' y =
+                                        Smale.FlowConstruction.partialChartField Ω.symm
+                                          (fun _ : E × ℝ => (0, 1)) y) ∧
+                                    (∀ p, p.2 ≤ 0 → Ω p = Φ p) ∧
+                                      (∀ p, 1 ≤ p.2 → Ω p = Φ (D p.1, p.2)) ∧
+                                        (∀ z ∈ U, ∀ t : ℝ, Ω (z, t) = G t (Φ (z, 0))) ∧
+                                          (∀ z ∈ U, ∃ w ∈ U, Ω (z, 1) = Φ (w, 1)) ∧
+                                            (∀ z ∈ U,
+                                                ∀ t : ℝ,
+                                                  t ≤ 0 → G t (Φ (z, 0)) = H t (Φ (z, 0))) ∧
+                                              (∀ z ∈ U,
+                                                ∀ t : ℝ,
+                                                  0 ≤ t → G t (Ω (z, 1)) = H t (Ω (z, 1))) := by
+  obtain ⟨W, F, hW, hWheight, -, hsupp, hF, hFend, -, hFoutside, hFfixed, ⟨Cdata⟩⟩ :=
+    exists_compact_isotopy_suspension D hK I
+  let C : Set (E × ℝ) := K ×ˢ Set.Icc (1 / 3 : ℝ) (2 / 3)
+  have hC : IsCompact C := hK.prod CompactIccSpace.isCompact_Icc
+  have hCsource : C ⊆ Φ.source := by
+    rw [hsource]
+    exact fun p hp => ⟨hKU hp.1, Set.mem_univ _⟩
+  have hWfix (p : E × ℝ) (hp : p ∉ C) : W p = (0, 1) := by
+    have hn : p ∉ tsupport (fun z : E × ℝ => W z - (0, 1)) := fun h => hp (hsupp h)
+    have hh := image_eq_zero_of_notMem_tsupport hn
+    exact sub_eq_zero.mp hh
+  obtain ⟨V', hV', hnew, hzeros, hgerm⟩ :=
+    exists_native_vertical_field_replacement Φ V hV hmodel hW hWheight hC hCsource hWfix
+  let N := Φ '' C
+  have hN : IsCompact N :=
+    hC.image_of_continuousOn (Φ.contMDiffOn_toFun.continuousOn.mono hCsource)
+  have hslab (p : E × ℝ) (hp : p ∈ C) : p.2 ∈ Set.Ioo (0 : ℝ) 1 := by
+    constructor <;> linarith [hp.2.1, hp.2.2]
+  have hNsub : N ⊆ Φ.target ∩ f ⁻¹' Set.Ioo (c - 1) c := by
+    rintro y ⟨p, hp, rfl⟩
+    refine ⟨Φ.map_source' (hCsource hp), ?_⟩
+    change f (Φ p) ∈ Set.Ioo (c - 1) c
+    rw [hheight p (hCsource hp) (hslab p hp)]
+    constructor <;> linarith [(hslab p hp).1, (hslab p hp).2]
+  let R :=
+    Smale.PartialChart.restrictSource Φ
+      (isOpen_univ.prod (isOpen_Ioo : IsOpen (Set.Ioo (0 : ℝ) 1)))
+  have hRheight (p : E × ℝ) (hp : p ∈ R.source) : f (R p) = c - p.2 := hheight p hp.1 hp.2.2
+  have hnegN (y : M) (hy : y ∈ N) : mvfderiv 𝓘(ℝ, B) f y (V' y) = -1 := by
+    rcases hy with ⟨p, hp, rfl⟩
+    have hpR : p ∈ R.source := ⟨hCsource hp, Set.mem_univ _, hslab p hp⟩
+    rw [hnew (Φ p) (Φ.map_source' (hCsource hp))]
+    change mvfderiv 𝓘(ℝ, B) f (R p) (Smale.FlowConstruction.partialChartField R.symm W (R p)) = -1
+    rw [mvfderiv_native_height_field R hf hRheight W (R.map_source' hpR), hWheight]
+  have hV'₁ := hV'.of_le (show (1 : WithTop ℕ∞) ≤ (↑(⊤ : ℕ∞) : ℕ∞ω) by simp)
+  let G := Smale.FlowConstruction.compactFlow hV'₁
+  have hG (x : M) : IsMIntegralCurve (fun t => G t x) V' :=
+    Smale.FlowConstruction.isMIntegralCurve_compactFlow hV'₁ x
+  have hstay (p : E × ℝ) (hp : p ∈ Φ.source) (t : ℝ) : F t p ∈ Φ.source := by
+    rw [hsource] at hp ⊢
+    exact ⟨flow_preserves_base_region F hKU hFoutside hp.1 t, Set.mem_univ _⟩
+  have hfull (p : E × ℝ) (hp : p ∈ Φ.source) (t : ℝ) : G t (Φ p) = Φ (F t p) :=
+    native_chart_flow_all_time Φ hV'₁ G hG F W hF hnew (hstay p hp) t
+  have hinv := native_chart_target_invariant Φ hV'₁ G hG F W hF hnew hstay
+  have hcomp := flow_complement_invariant G hinv
+  obtain ⟨Ω, hΩsource, hΩtarget, hΩmap, hΩfield, hΩlower, hΩupper⟩ :=
+    exists_native_suspension_chart Φ hsource hKU Cdata V' hnew
+  have hΩflow (z : E) (hz : z ∈ U) (t : ℝ) : Ω (z, t) = G t (Φ (z, 0)) := by
+    have h0 : (z, (0 : ℝ)) ∈ Φ.source := by rw [hsource]; exact ⟨hz, Set.mem_univ _⟩
+    have hC0 : Cdata.chart (z, (0 : ℝ)) = (z, 0) := Cdata.lower _ le_rfl
+    have hFt : F t (z, 0) = Cdata.chart (z, t) := by
+      calc
+        F t (z, 0) = suspensionFlow Cdata.chart t (z, 0) :=
+          congrArg (fun A : Flow ℝ (E × ℝ) => A t (z, 0)) Cdata.flow_eq
+        _ = suspensionFlow Cdata.chart t (Cdata.chart (z, 0)) :=
+          (congrArg (suspensionFlow Cdata.chart t) hC0.symm)
+        _ = Cdata.chart (z, 0 + t) := (suspensionFlow_chart Cdata.chart t (z, 0))
+        _ = Cdata.chart (z, t) := by rw [zero_add]
+    rw [hΩmap]
+    exact ((hfull (z, 0) h0 t).trans (congrArg Φ hFt)).symm
+  have hDU : Set.MapsTo D U U :=
+    Smale.SupportedDiffeomorph.mapsTo_of_fixed_outside D.toEquiv
+      (fun z hz => I.endpoint_fixed_outside z (fun h => hz (hKU h)))
+  have hΩsection (z : E) (hz : z ∈ U) : ∃ w ∈ U, Ω (z, 1) = Φ (w, 1) :=
+    ⟨D z, hDU hz, hΩupper (z, 1) le_rfl⟩
+  obtain ⟨hleftTail, hrightTail⟩ :=
+    native_corrected_cylinder_tails Φ Ω hsource (hΩsource.trans hsource) (hV.of_le (by simp)) hV'₁
+      hmodel hΩfield H G hH hG D hDU hΩlower hΩupper
+  refine
+    ⟨N, V', G, hN, hNsub, hV', hG, hzeros, ?_, hgerm, hinv, ?_, ?_, ?_, Ω, hΩsource.trans hsource,
+      hΩtarget, hΩfield, hΩlower, hΩupper, hΩflow, hΩsection, hleftTail, hrightTail⟩
+  · intro x hx
+    by_cases hn : x ∈ N
+    · rw [hnegN x hn]
+      norm_num
+    · rw [(hgerm x hn).self_of_nhds]
+      exact hx
+  · intro x hx t
+    have hagree (s : ℝ) : V' (G s x) = V (G s x) :=
+      (hgerm (G s x) (fun h => hcomp x hx s (hNsub h).1)).self_of_nhds
+    rcases le_total 0 t with ht | ht
+    · exact
+        Degree.FlowCancellation.native_flow_eq_on_positive_halfline (hV.of_le (by simp)) H G hH hG
+          (fun s _ => hagree s) t ht
+    · exact
+        Degree.FlowCancellation.native_flow_eq_on_negative_halfline (hV.of_le (by simp)) H G hH hG
+          (fun s _ => hagree s) t ht
+  · intro x hx
+    have hp : (x, (0 : ℝ)) ∈ Φ.source := by rw [hsource]; exact ⟨hx, Set.mem_univ _⟩
+    rw [hfull _ hp, hFend]
+  · intro x hx s t
+    have hp : (x, s) ∈ Φ.source := by rw [hsource]; exact ⟨hx.1, Set.mem_univ _⟩
+    rw [hfull _ hp, hFfixed x hx.2 s t]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Degree.FlowSuspension.exists_native_block_holonomy {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [FiniteDimensional ℝ B] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [FiniteDimensional ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, E) (Z × ℝ) M ∞) {U : Set Z}
+    (hsource : Φ.source = U ×ˢ Set.univ) {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {c : ℝ}
+    (hheight : ∀ p ∈ Φ.source, p.2 ∈ Set.Ioo (0 : ℝ) 1 → f (Φ p) = c - p.2)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hmodel :
+      ∀ x ∈ Φ.target,
+        V x = Smale.FlowConstruction.partialChartField Φ.symm (fun _ : Z × ℝ => (0, 1)) x)
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (Q P : PartialDiffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, Z) (A × B) Z ∞)
+    (H : PartialDiffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, A × B) (A × B) (A × B) ∞)
+    (h0 : (0 : A × B) ∈ H.source) (hH0 : H 0 = 0) (hQzero : Q 0 = 0) (hPzero : P 0 = 0)
+    (hHs : H.source ⊆ Q.source) (hHt : H.target ⊆ P.source) (hQU : Q.target ⊆ U)
+    (hPU : P.target ⊆ U) (hdiagram : ∀ z ∈ H.source, P (H z) = Q z)
+    (htrans :
+      Smale.NativeTransversality.At 𝓘(ℝ, A) 𝓘(ℝ, B) 𝓘(ℝ, A × B) (fun x : A => H (x, 0))
+        (fun y : B => (0, y)) 0 0)
+    (hunique : ∀ x : A, (x, (0 : B)) ∈ H.source → ((H (x, 0)).1 = 0 ↔ x = 0)) :
+    ∃ (L₁ : A ≃L[ℝ] A) (L₂ : B ≃L[ℝ] B) (N : Set M) (W : (x : M) → TangentSpace 𝓘(ℝ, E) x) (G :
+      Flow ℝ M) (Ω : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, E) (Z × ℝ) M ∞),
+      IsCompact N ∧
+        N ⊆ Φ.target ∩ f ⁻¹' Set.Ioo (c - 1) c ∧
+          ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, W x⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+            (∀ x, IsMIntegralCurve (fun t => G t x) W) ∧
+              (∀ x, W x = 0 ↔ V x = 0) ∧
+                (∀ x, mvfderiv 𝓘(ℝ, E) f x (V x) < 0 → mvfderiv 𝓘(ℝ, E) f x (W x) < 0) ∧
+                  (∀ x ∉ N, ∀ᶠ y in 𝓝 x, W y = V y) ∧
+                    (∀ x ∉ Φ.target, ∀ t, G t x = F t x) ∧
+                      Ω.source = U ×ˢ Set.univ ∧
+                        Ω.target = Φ.target ∧
+                          (∀ y ∈ Ω.target,
+                              W y =
+                                Smale.FlowConstruction.partialChartField Ω.symm
+                                  (fun _ : Z × ℝ => (0, 1)) y) ∧
+                            (∀ z ∈ U, ∀ t : ℝ, Ω (z, t) = G t (Φ (z, 0))) ∧
+                              (∀ p, p.2 ≤ 0 → Ω p = Φ p) ∧
+                                (∀ s t : ℝ, G t (Φ (0, s)) = Φ (0, s + t)) ∧
+                                  (∀ z ∈ U, ∃ w ∈ U, Ω (z, 1) = Φ (w, 1)) ∧
+                                    (∀ z ∈ U, ∀ t : ℝ, t ≤ 0 → G t (Φ (z, 0)) = F t (Φ (z, 0))) ∧
+                                      (∀ z ∈ U,
+                                          ∀ t : ℝ, 0 ≤ t → G t (Ω (z, 1)) = F t (Ω (z, 1))) ∧
+                                        (∀ x : A,
+                                            (x, (0 : B)) ∈ H.source →
+                                              ∀ y ∈ H.target,
+                                                y.1 = 0 →
+                                                  Ω (Q (x, 0), 1) = Φ (P y, 1) → x = 0 ∧ y = 0) ∧
+                                          ∀ᶠ z in 𝓝 (0 : A × B),
+                                            ∀ t : ℝ,
+                                              1 ≤ t → Ω (Q z, t) = Φ (P (L₁ z.1, L₂ z.2), t) := by
+  obtain ⟨L₁, L₂, D, K, hK, hKU, ⟨I⟩, hD0, hDP, huniq, hgerm⟩ :=
+    Degree.TransverseGerms.exists_cylinder_block_correction Q P H h0 hH0 hQzero hPzero hHs hHt
+      hdiagram htrans hunique
+  have hKU' : K ⊆ U := fun z hz => hQU (hKU hz).1
+  have h0U : (0 : Z) ∈ U := by
+    have hh := hQU (Q.map_source' (hHs h0))
+    rwa [hQzero] at hh
+  obtain
+    ⟨N, W, G, hN, hNsub, hW, hG, hzero, hdesc, hgerms, _, hout, _, haxis, Ω, hΩsource, hΩtarget,
+      hΩfield, hΩlower, hΩupper, hΩflow, hΩsection, hleftTail, hrightTail⟩ :=
+    exists_full_cylinder_holonomy Φ hsource hf hheight V hV hmodel F hF D hK hKU' I
+  refine
+    ⟨L₁, L₂, N, W, G, Ω, hN, hNsub, hW, hG, hzero, hdesc, hgerms, hout, hΩsource, hΩtarget,
+      hΩfield, hΩflow, hΩlower, haxis 0 ⟨h0U, rfl⟩, hΩsection, hleftTail, hrightTail, ?_, ?_⟩
+  · intro x hx y hy hy0 heq
+    have hw : D (Q (x, 0)) ∈ P.target := hDP (x, 0) hx
+    have hs₁ : (D (Q (x, 0)), (1 : ℝ)) ∈ Φ.source := by
+      rw [hsource]
+      exact ⟨hPU hw, Set.mem_univ _⟩
+    have hs₂ : (P y, (1 : ℝ)) ∈ Φ.source := by
+      rw [hsource]
+      exact ⟨hPU (P.map_source' (hHt hy)), Set.mem_univ _⟩
+    rw [hΩupper _ le_rfl] at heq
+    have hlabel : D (Q (x, 0)) = P y :=
+      congrArg Prod.fst (Φ.toOpenPartialHomeomorph.injOn hs₁ hs₂ heq)
+    have hinv : P.symm (D (Q (x, 0))) = y := by
+      rw [hlabel]
+      exact P.left_inv' (hHt hy)
+    have hx0 : x = 0 := (huniq x hx).mp (by rw [hinv]; exact hy0)
+    refine ⟨hx0, ?_⟩
+    have hP0 : (0 : A × B) ∈ P.source := by
+      have hh := hHt (H.map_source' h0)
+      rwa [hH0] at hh
+    have hPy : P y = 0 := by
+      rw [← hlabel, hx0]
+      change D (Q (0 : A × B)) = 0
+      rw [hQzero, hD0]
+    exact P.toOpenPartialHomeomorph.injOn (hHt hy) hP0 (hPy.trans hPzero.symm)
+  · filter_upwards [hgerm] with z hz
+    intro t ht
+    rw [hΩupper _ ht, hz]
+
+private theorem Degree.FlowSuspension.corrected_cylinder_unique_connection {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedAddCommGroup B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M]
+    (Φ Ω : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, E) (Z × ℝ) M ∞) {U : Set Z} (h0U : (0 : Z) ∈ U)
+    (hΦsource : Φ.source = U ×ˢ Set.univ) (hΩsource : Ω.source = U ×ˢ Set.univ)
+    (hΩtarget : Ω.target = Φ.target) (F G : Flow ℝ M)
+    (hΦflow : ∀ z ∈ U, ∀ t : ℝ, Φ (z, t) = F t (Φ (z, 0)))
+    (hΩflow : ∀ z ∈ U, ∀ t : ℝ, Ω (z, t) = G t (Φ (z, 0)))
+    (hΩsection : ∀ z ∈ U, ∃ w ∈ U, Ω (z, 1) = Φ (w, 1))
+    (hleft : ∀ z ∈ U, ∀ t : ℝ, t ≤ 0 → G t (Φ (z, 0)) = F t (Φ (z, 0)))
+    (hright : ∀ z ∈ U, ∀ t : ℝ, 0 ≤ t → G t (Ω (z, 1)) = F t (Ω (z, 1)))
+    (hout : ∀ x ∉ Φ.target, ∀ t, G t x = F t x) (Q P : (A × B) → Z) (hQ0 : Q 0 = 0)
+    (S T : Set (A × B)) {p q : M}
+    (hleftBasin :
+      ∀ z ∈ U,
+        Filter.Tendsto (fun t => F t (Φ (z, 0))) Filter.atBot (𝓝 q) ↔
+          ∃ x : A, (x, (0 : B)) ∈ S ∧ Q (x, 0) = z)
+    (hrightBasin :
+      ∀ z ∈ U,
+        Filter.Tendsto (fun t => F t (Φ (z, 1))) Filter.atTop (𝓝 p) ↔ ∃ y ∈ T, y.1 = 0 ∧ P y = z)
+    (hsection :
+      ∀ x : A, (x, (0 : B)) ∈ S → ∀ y ∈ T, y.1 = 0 → Ω (Q (x, 0), 1) = Φ (P y, 1) → x = 0 ∧ y = 0)
+    (hold :
+      ∀ x,
+        Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 q) →
+          Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p) → ∃ t, F t (Φ (0, 0)) = x) :
+    ∀ x,
+      Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 q) →
+        Filter.Tendsto (fun t => G t x) Filter.atTop (𝓝 p) → ∃ t, G t (Φ (0, 0)) = x := by
+  intro x hbot htop
+  by_cases hx : x ∈ Φ.target
+  · have hxΩ : x ∈ Ω.target := hΩtarget.symm ▸ hx
+    let w := Ω.symm x
+    have hw : w ∈ Ω.source := Ω.map_target' hxΩ
+    have hwU : w.1 ∈ U := by rw [hΩsource] at hw; exact hw.1
+    have hpoint : x = G w.2 (Φ (w.1, 0)) := by
+      calc
+        x = Ω w := (Ω.right_inv' hxΩ).symm
+        _ = G w.2 (Φ (w.1, 0)) := hΩflow w.1 hwU w.2
+    have hbot0 : Filter.Tendsto (fun t => G t (Φ (w.1, 0))) Filter.atBot (𝓝 q) := by
+      apply (MorseCancel.flow_time_atBot_limit_iff G w.2 (Φ (w.1, 0)) q).mp
+      rwa [← hpoint]
+    have htop0 : Filter.Tendsto (fun t => G t (Φ (w.1, 0))) Filter.atTop (𝓝 p) := by
+      apply (MorseCancel.flow_time_atTop_limit_iff G w.2 (Φ (w.1, 0)) p).mp
+      rwa [← hpoint]
+    have htop1 : Filter.Tendsto (fun t => G t (Ω (w.1, 1))) Filter.atTop (𝓝 p) := by
+      rw [hΩflow w.1 hwU 1]
+      exact (MorseCancel.flow_time_atTop_limit_iff G 1 (Φ (w.1, 0)) p).mpr htop0
+    have hbotF : Filter.Tendsto (fun t => F t (Φ (w.1, 0))) Filter.atBot (𝓝 q) := by
+      apply hbot0.congr'
+      filter_upwards [Filter.eventually_le_atBot (0 : ℝ)] with t ht
+      exact hleft w.1 hwU t ht
+    have htopF : Filter.Tendsto (fun t => F t (Ω (w.1, 1))) Filter.atTop (𝓝 p) := by
+      apply htop1.congr'
+      filter_upwards [Filter.eventually_ge_atTop (0 : ℝ)] with t ht
+      exact hright w.1 hwU t ht
+    obtain ⟨a, ha, hQa⟩ := (hleftBasin w.1 hwU).mp hbotF
+    obtain ⟨v, hv, hΩv⟩ := hΩsection w.1 hwU
+    rw [hΩv] at htopF
+    obtain ⟨y, hy, hy0, hPy⟩ := (hrightBasin v hv).mp htopF
+    have hcross : Ω (Q (a, 0), 1) = Φ (P y, 1) := by rw [hQa, hPy]; exact hΩv
+    have ha0 := (hsection a ha y hy hy0 hcross).1
+    have hw0 : w.1 = 0 := by
+      rw [← hQa, ha0]
+      exact hQ0
+    refine ⟨w.2, ?_⟩
+    rw [hpoint, hw0]
+  · have hbotF : Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 q) :=
+      hbot.congr' (Filter.Eventually.of_forall (hout x hx))
+    have htopF : Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p) :=
+      htop.congr' (Filter.Eventually.of_forall (hout x hx))
+    obtain ⟨t, ht⟩ := hold x hbotF htopF
+    have hsource : (0, t) ∈ Φ.source := by rw [hΦsource]; exact ⟨h0U, Set.mem_univ _⟩
+    have hxt : x ∈ Φ.target := by
+      rw [← ht, ← hΦflow 0 h0U t]
+      exact Φ.map_source' hsource
+    exact (hx hxt).elim
+
+private theorem Degree.FlowTimeChange.exists_small_supported_scalar_germ {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] {v : E → ℝ}
+    (hv : ContDiff ℝ ∞ v) (hv0 : v 0 = 0) {U : Set E} (hU : IsOpen U) (h0U : (0 : E) ∈ U) {ε : ℝ}
+    (hε : 0 < ε) :
+    ∃ (K : Set E) (g : E → ℝ),
+      IsCompact K ∧
+        K ⊆ U ∧ ContDiff ℝ ∞ g ∧ tsupport g ⊆ K ∧ g =ᶠ[𝓝 0] v ∧ g 0 = 0 ∧ ∀ x, |g x| < ε := by
+  have hnear : ∀ᶠ x in 𝓝 (0 : E), x ∈ U ∧ |v x| < ε := by
+    have hp : |v 0| < ε := by simpa only [hv0, abs_zero] using hε
+    have hmem : ∀ᶠ x in 𝓝 (0 : E), x ∈ U := hU.mem_nhds h0U
+    exact hmem.and (hv.continuous.abs.continuousAt (eventually_lt_nhds hp))
+  obtain ⟨r, hr, hrsub⟩ := Metric.eventually_nhds_iff.mp hnear
+  let β : ContDiffBump (0 : E) := ⟨r / 4, r / 2, by positivity, by linarith⟩
+  let K := Metric.closedBall (0 : E) β.rOut
+  let g (x : E) := β x * v x
+  have hKsmall {x : E} (hx : x ∈ K) : Dist.dist x 0 < r := by
+    have hh : Dist.dist x 0 ≤ r / 2 := hx
+    linarith
+  have hKU : K ⊆ U := fun _ hx => (hrsub (hKsmall hx)).1
+  have hsupp : tsupport g ⊆ K := by
+    have hh := tsupport_mul_subset_left (f := fun x : E => β x) (g := v)
+    rw [β.tsupport_eq] at hh
+    exact hh
+  have hgerm : g =ᶠ[𝓝 0] v := by
+    filter_upwards [Metric.ball_mem_nhds (0 : E) β.rIn_pos] with x hx
+    change β x * v x = v x
+    rw [β.one_of_mem_closedBall (Metric.ball_subset_closedBall hx), one_mul]
+  refine
+    ⟨K, g, ProperSpace.isCompact_closedBall _ _, hKU, β.contDiff.mul hv, hsupp, hgerm,
+      hgerm.eq_of_nhds.trans hv0, ?_⟩
+  intro x
+  by_cases hx : β x = 0
+  · simpa only [g, hx, MulZeroClass.zero_mul, abs_zero] using hε
+  · have hxin : x ∈ K := by
+      change x ∈ Metric.closedBall (0 : E) β.rOut
+      rw [← β.tsupport_eq]
+      exact subset_tsupport β hx
+    have hvx : |v x| < ε := (hrsub (hKsmall hxin)).2
+    change |β x * v x| < ε
+    rw [abs_mul, abs_of_nonneg β.nonneg]
+    exact (mul_le_of_le_one_left (abs_nonneg (v x)) β.le_one).trans_lt hvx
+
+private theorem Degree.FlowTimeChange.exists_bounded_step_profile :
+    ∃ (τ : ℝ → ℝ) (L : ℝ),
+      ContDiff ℝ ∞ τ ∧
+        0 < L ∧
+          (∀ t, τ t ∈ Set.Icc (0 : ℝ) 1) ∧
+            (∀ t, t ≤ 1 / 3 → τ t = 0) ∧
+              (∀ t, 2 / 3 ≤ t → τ t = 1) ∧
+                (∀ t, t ∉ Set.Icc (1 / 3 : ℝ) (2 / 3) → deriv τ t = 0) ∧ ∀ t, |deriv τ t| ≤ L := by
+  let τ : ℝ → ℝ := fun t => Real.smoothTransition (3 * t - 1)
+  have hτ : ContDiff ℝ ∞ τ :=
+    Real.smoothTransition.contDiff.comp ((contDiff_const.mul contDiff_id).sub contDiff_const)
+  have hzero (t : ℝ) (ht : t ≤ 1 / 3) : τ t = 0 :=
+    Real.smoothTransition.zero_of_nonpos (by linarith)
+  have hone (t : ℝ) (ht : 2 / 3 ≤ t) : τ t = 1 :=
+    Real.smoothTransition.one_of_one_le (by linarith)
+  have hout (t : ℝ) (ht : t ∉ Set.Icc (1 / 3 : ℝ) (2 / 3)) : deriv τ t = 0 := by
+    by_cases hlo : t < 1 / 3
+    · have hg : τ =ᶠ[𝓝 t] (fun _ => (0 : ℝ)) := by
+        filter_upwards [eventually_lt_nhds hlo] with s hs
+        exact hzero s hs.le
+      rw [hg.deriv_eq]
+      exact deriv_const _ _
+    · have hhi : 2 / 3 < t := by
+        by_contra hn
+        exact ht ⟨le_of_not_gt hlo, le_of_not_gt hn⟩
+      have hg : τ =ᶠ[𝓝 t] (fun _ => (1 : ℝ)) := by
+        filter_upwards [eventually_gt_nhds hhi] with s hs
+        exact hone s hs.le
+      rw [hg.deriv_eq]
+      exact deriv_const _ _
+  have hcomp : HasCompactSupport (deriv τ) :=
+    HasCompactSupport.intro
+      (CompactIccSpace.isCompact_Icc : IsCompact (Set.Icc (1 / 3 : ℝ) (2 / 3))) hout
+  obtain ⟨C, hC⟩ := hcomp.exists_bound_of_continuous (hτ.continuous_deriv (by simp))
+  let L : ℝ := Max.max C 0 + 1
+  refine ⟨τ, L, hτ, by dsimp [L]; positivity, ?_, hzero, hone, hout, ?_⟩
+  · intro t
+    exact ⟨Real.smoothTransition.nonneg _, Real.smoothTransition.le_one _⟩
+  · intro t
+    have hh : |deriv τ t| ≤ C := by simpa only [Real.norm_eq_abs] using hC t
+    exact hh.trans (by dsimp [L]; linarith [le_max_left C 0])
+
+private theorem
+    Degree.FlowTimeChange.exists_supported_phase_clock {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {v : E → ℝ} (hv : ContDiff ℝ ∞ v) (hv0 : v 0 = 0)
+    {U : Set E} (hU : IsOpen U) (h0U : (0 : E) ∈ U) :
+    ∃ (K : Set E) (g : E → ℝ) (τ : ℝ → ℝ) (D :
+      Diffeomorph 𝓘(ℝ, ℝ × E) 𝓘(ℝ, ℝ × E) (ℝ × E) (ℝ × E) ∞),
+      IsCompact K ∧
+        K ⊆ U ∧
+          ContDiff ℝ ∞ g ∧
+            tsupport g ⊆ K ∧
+              g =ᶠ[𝓝 0] v ∧
+                g 0 = 0 ∧
+                  (∀ x, |g x| < 1 / 12) ∧
+                    ContDiff ℝ ∞ τ ∧
+                      (∀ t, τ t ∈ Set.Icc (0 : ℝ) 1) ∧
+                        (∀ p, D p = (p.1 + τ p.1 * g p.2, p.2)) ∧
+                          (∀ s, D (s, 0) = (s, 0)) ∧
+                            (∀ p, p.1 ≤ 1 / 3 → D p = p) ∧
+                              (∀ p, 2 / 3 ≤ p.1 → D p = (p.1 + g p.2, p.2)) ∧
+                                ∀ p, 1 / 2 < fderiv ℝ (fun q => (D q).1) p (1, 0) := by
+  obtain ⟨τ, L, hτ, hL, hrange, hleft, hright, -, hder⟩ := exists_bounded_step_profile
+  let ε : ℝ := Min.min (1 / 12) (1 / (2 * L))
+  have hε : 0 < ε := lt_min (by norm_num) (by positivity)
+  obtain ⟨K, g, hK, hKU, hg, hsupp, hgerm, hg0, hsmall⟩ :=
+    exists_small_supported_scalar_germ hv hv0 hU h0U hε
+  let u (p : ℝ × E) := τ p.1 * g p.2
+  have hu : ContDiff ℝ ∞ u := (hτ.comp contDiff_fst).mul (hg.comp contDiff_snd)
+  have hbound (p : ℝ × E) : |u p| ≤ ε := by
+    change |τ p.1 * g p.2| ≤ ε
+    rw [abs_mul, abs_of_nonneg (hrange p.1).1]
+    exact (mul_le_of_le_one_left (abs_nonneg (g p.2)) (hrange p.1).2).trans (hsmall p.2).le
+  have hrate (p : ℝ × E) :
+    fderiv ℝ (Degree.RegularHeightCoordinates.displacedHeight u) p (1, 0) =
+      1 + deriv τ p.1 * g p.2 := by
+    have ha :=
+      (Degree.RegularHeightCoordinates.scalar_derivative
+          (Degree.RegularHeightCoordinates.contDiff_displacedHeight hu) p.1 p.2).deriv
+    have hb :=
+      ((hasDerivAt_id p.1).add
+          ((hτ.differentiable (by simp) p.1).hasDerivAt.mul_const (g p.2))).deriv
+    exact ha.symm.trans hb
+  have hsmall' (p : ℝ × E) : |deriv τ p.1 * g p.2| < 1 / 2 := by
+    rw [abs_mul]
+    calc
+      |deriv τ p.1| * |g p.2| ≤ L * |g p.2| := mul_le_mul_of_nonneg_right (hder _) (abs_nonneg _)
+      _ < L * ε := (mul_lt_mul_of_pos_left (hsmall _) hL)
+      _ ≤ L * (1 / (2 * L)) := (mul_le_mul_of_nonneg_left (min_le_right _ _) hL.le)
+      _ = 1 / 2 := by field_simp
+  have hpositive (p : ℝ × E) :
+    1 / 2 < fderiv ℝ (Degree.RegularHeightCoordinates.displacedHeight u) p (1, 0) := by
+    rw [hrate]
+    linarith [(abs_lt.mp (hsmall' p)).1]
+  have hpos (p : ℝ × E) :
+    0 < fderiv ℝ (Degree.RegularHeightCoordinates.displacedHeight u) p (1, 0) :=
+    (by norm_num : (0 : ℝ) < 1 / 2).trans (hpositive p)
+  have hF := Degree.RegularHeightCoordinates.contDiff_displacedHeight hu
+  have hlocal :
+    IsLocalDiffeomorph 𝓘(ℝ, ℝ × E) 𝓘(ℝ, ℝ × E) ∞
+      (Degree.RegularHeightCoordinates.heightMap
+        (Degree.RegularHeightCoordinates.displacedHeight u)) :=
+    fun p => Degree.RegularHeightCoordinates.heightMap_localDiffeomorph hF (hpos p).ne'
+  let D :=
+    hlocal.diffeomorphOfBijective
+      ⟨Degree.RegularHeightCoordinates.heightMap_injective_of_positive hF hpos,
+        Degree.RegularHeightCoordinates.heightMap_surjective_of_bounded hu.continuous ε hε.le
+          hbound⟩
+  have hD (p : ℝ × E) : D p = (p.1 + τ p.1 * g p.2, p.2) := rfl
+  refine
+    ⟨K, g, τ, D, hK, hKU, hg, hsupp, hgerm, hg0, fun x => (hsmall x).trans_le (min_le_left _ _),
+      hτ, hrange, hD, ?_, ?_, ?_, ?_⟩
+  · intro s
+    rw [hD, hg0, MulZeroClass.mul_zero, add_zero]
+  · intro p hp
+    rw [hD, hleft p.1 hp, MulZeroClass.zero_mul, add_zero]
+  · intro p hp
+    rw [hD, hright p.1 hp, one_mul]
+  · exact hpositive
+
+private def Degree.FlowTimeChange.phaseConjugatingDiffeomorph {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (D : Diffeomorph 𝓘(ℝ, ℝ × E) 𝓘(ℝ, ℝ × E) (ℝ × E) (ℝ × E) ∞) :
+    Diffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, E × ℝ) (E × ℝ) (E × ℝ) ∞ :=
+  ((ContinuousLinearEquiv.prodComm ℝ E ℝ).toDiffeomorph.trans D).trans
+    (ContinuousLinearEquiv.prodComm ℝ ℝ E).toDiffeomorph
+
+private theorem Degree.FlowTimeChange.phaseClockFlow_base {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (D : Diffeomorph 𝓘(ℝ, ℝ × E) 𝓘(ℝ, ℝ × E) (ℝ × E) (ℝ × E) ∞)
+    (hbase : ∀ p, (D p).2 = p.2) (p : E × ℝ) (t : ℝ) :
+    (Degree.FlowSuspension.suspensionFlow (phaseConjugatingDiffeomorph D) t p).1 = p.1 := by
+  let Q := phaseConjugatingDiffeomorph D
+  let z := Q.symm p
+  have hh := congrArg (fun w : E × ℝ => w.1) (Q.apply_symm_apply p)
+  change (D (z.2, z.1)).2 = p.1 at hh
+  rw [hbase] at hh
+  change (D (z.2 + t, z.1)).2 = p.1
+  rw [hbase]
+  exact hh
+
+private theorem Degree.FlowTimeChange.phaseClockField_base_zero {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (D : Diffeomorph 𝓘(ℝ, ℝ × E) 𝓘(ℝ, ℝ × E) (ℝ × E) (ℝ × E) ∞)
+    (hbase : ∀ p, (D p).2 = p.2) (p : E × ℝ) :
+    (Degree.FlowSuspension.suspensionField (phaseConjugatingDiffeomorph D) p).1 = 0 := by
+  have hd :
+    HasDerivAt
+      (fun t => (Degree.FlowSuspension.suspensionFlow (phaseConjugatingDiffeomorph D) t p).1)
+      (Degree.FlowSuspension.suspensionField (phaseConjugatingDiffeomorph D) p).1 0 :=
+    (Degree.FlowSuspension.hasDerivAt_suspensionFlow_zero (phaseConjugatingDiffeomorph D) p).fst
+  have heq :
+    (fun t => (Degree.FlowSuspension.suspensionFlow (phaseConjugatingDiffeomorph D) t p).1) =
+      (fun _ => p.1) :=
+    funext (phaseClockFlow_base D hbase p)
+  rw [heq] at hd
+  exact hd.unique (hasDerivAt_const 0 p.1)
+
+private theorem
+    Degree.FlowTimeChange.phaseClockField_time_derivative {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (D : Diffeomorph 𝓘(ℝ, ℝ × E) 𝓘(ℝ, ℝ × E) (ℝ × E) (ℝ × E) ∞) (p : E × ℝ) :
+    (Degree.FlowSuspension.suspensionField (phaseConjugatingDiffeomorph D) p).2 =
+      fderiv ℝ (fun q => (D q).1) ((phaseConjugatingDiffeomorph D).symm p).swap (1, 0) := by
+  let Q := phaseConjugatingDiffeomorph D
+  let z := Q.symm p
+  have hd :
+    HasDerivAt (fun t => (Degree.FlowSuspension.suspensionFlow Q t p).2)
+      (Degree.FlowSuspension.suspensionField Q p).2 0 :=
+    (Degree.FlowSuspension.hasDerivAt_suspensionFlow_zero Q p).snd
+  have hD : ContDiff ℝ ∞ (fun q : ℝ × E => (D q).1) := D.contMDiff.contDiff.fst
+  have hc : HasDerivAt (fun t : ℝ => (z.2 + t, z.1)) ((1 : ℝ), (0 : E)) 0 :=
+    ((hasDerivAt_id 0).const_add z.2).prodMk (hasDerivAt_const 0 z.1)
+  have hi := (hD.differentiable (by simp) (z.2 + 0, z.1)).hasFDerivAt.comp_hasDerivAt 0 hc
+  simp only [add_zero] at hi
+  change
+    HasDerivAt (fun t => (D (z.2 + t, z.1)).1) (Degree.FlowSuspension.suspensionField Q p).2
+      0 at hd
+  exact hd.unique hi
+
+private theorem
+    Degree.FlowTimeChange.phaseClockField_time_positive {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (D : Diffeomorph 𝓘(ℝ, ℝ × E) 𝓘(ℝ, ℝ × E) (ℝ × E) (ℝ × E) ∞)
+    (hpos : ∀ q, 1 / 2 < fderiv ℝ (fun p => (D p).1) q (1, 0)) (p : E × ℝ) :
+    1 / 2 < (Degree.FlowSuspension.suspensionField (phaseConjugatingDiffeomorph D) p).2 := by
+  rw [phaseClockField_time_derivative]
+  exact hpos _
+
+private theorem Degree.FlowTimeChange.phaseClockField_eq_vertical_of_translation_germ {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (D : Diffeomorph 𝓘(ℝ, ℝ × E) 𝓘(ℝ, ℝ × E) (ℝ × E) (ℝ × E) ∞) (p : E × ℝ) {h : ℝ}
+    (hgerm :
+      ∀ᶠ s in 𝓝 ((phaseConjugatingDiffeomorph D).symm p).2,
+        D (s, ((phaseConjugatingDiffeomorph D).symm p).1) =
+          (s + h, ((phaseConjugatingDiffeomorph D).symm p).1)) :
+    Degree.FlowSuspension.suspensionField (phaseConjugatingDiffeomorph D) p = (0, 1) := by
+  let Q := phaseConjugatingDiffeomorph D
+  let z := Q.symm p
+  have ht : Filter.Tendsto (fun t : ℝ => z.2 + t) (𝓝 0) (𝓝 z.2) := by
+    have hc : Continuous (fun t : ℝ => z.2 + t) := continuous_const.add continuous_id
+    simpa only [add_zero] using hc.tendsto (0 : ℝ)
+  have heq :
+    (fun t => Degree.FlowSuspension.suspensionFlow Q t p) =ᶠ[𝓝 0] (fun t => (z.1, z.2 + t + h)) :=
+    by
+    filter_upwards [ht.eventually hgerm] with t hts
+    change ((D (z.2 + t, z.1)).2, (D (z.2 + t, z.1)).1) = _
+    rw [hts]
+  have hd :=
+    (Degree.FlowSuspension.hasDerivAt_suspensionFlow_zero Q p).congr_of_eventuallyEq heq.symm
+  exact
+    hd.unique
+      ((hasDerivAt_const 0 z.1).prodMk (((hasDerivAt_id (0 : ℝ)).const_add z.2).add_const h))
+
+private theorem Degree.FlowTimeChange.exists_compact_phase_field_support {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (D : Diffeomorph 𝓘(ℝ, ℝ × E) 𝓘(ℝ, ℝ × E) (ℝ × E) (ℝ × E) ∞) {g : E → ℝ} {τ : ℝ → ℝ}
+    {K : Set E} (hK : IsCompact K) (hsupp : tsupport g ⊆ K) (hsmall : ∀ x, |g x| < 1 / 12)
+    (hrange : ∀ t, τ t ∈ Set.Icc (0 : ℝ) 1) (hD : ∀ p, D p = (p.1 + τ p.1 * g p.2, p.2))
+    (hleft : ∀ p, p.1 ≤ 1 / 3 → D p = p) (hright : ∀ p, 2 / 3 ≤ p.1 → D p = (p.1 + g p.2, p.2)) :
+    ∃ C : Set (E × ℝ),
+      IsCompact C ∧
+        C ⊆ K ×ˢ Set.Ioo (0 : ℝ) 1 ∧
+          ∀ p ∉ C,
+            Degree.FlowSuspension.suspensionField (phaseConjugatingDiffeomorph D) p = (0, 1) := by
+  let Q := phaseConjugatingDiffeomorph D
+  let C := Q '' (K ×ˢ Set.Icc (1 / 3 : ℝ) (2 / 3))
+  have hC : IsCompact C := (hK.prod CompactIccSpace.isCompact_Icc).image Q.continuous
+  have hsub : C ⊆ K ×ˢ Set.Ioo (0 : ℝ) 1 := by
+    rintro p ⟨⟨z, t⟩, ⟨hz, ht⟩, rfl⟩
+    change ((D (t, z)).2, (D (t, z)).1) ∈ K ×ˢ Set.Ioo (0 : ℝ) 1
+    rw [hD]
+    have hamp : |τ t * g z| < 1 / 12 := by
+      rw [abs_mul, abs_of_nonneg (hrange t).1]
+      exact (mul_le_of_le_one_left (abs_nonneg (g z)) (hrange t).2).trans_lt (hsmall z)
+    refine ⟨hz, ?_, ?_⟩ <;> linarith [(abs_lt.mp hamp).1, (abs_lt.mp hamp).2, ht.1, ht.2]
+  refine ⟨C, hC, hsub, ?_⟩
+  intro p hp
+  let z := Q.symm p
+  have hz : z ∉ K ×ˢ Set.Icc (1 / 3 : ℝ) (2 / 3) := fun hh => hp ⟨z, hh, Q.apply_symm_apply p⟩
+  by_cases hbase : z.1 ∈ K
+  · have htime : z.2 ∉ Set.Icc (1 / 3 : ℝ) (2 / 3) := fun ht => hz ⟨hbase, ht⟩
+    by_cases hlo : z.2 < 1 / 3
+    · apply phaseClockField_eq_vertical_of_translation_germ D p (h := 0)
+      filter_upwards [eventually_lt_nhds hlo] with s hs
+      simpa only [add_zero] using hleft (s, z.1) hs.le
+    · have hhi : 2 / 3 < z.2 := by
+        by_contra hn
+        exact htime ⟨le_of_not_gt hlo, le_of_not_gt hn⟩
+      apply phaseClockField_eq_vertical_of_translation_germ D p (h := g z.1)
+      filter_upwards [eventually_gt_nhds hhi] with s hs
+      exact hright (s, z.1) hs.le
+  · have hg : g z.1 = 0 := image_eq_zero_of_notMem_tsupport (fun h => hbase (hsupp h))
+    apply phaseClockField_eq_vertical_of_translation_germ D p (h := 0)
+    apply Filter.Eventually.of_forall
+    intro s
+    rw [hD, hg, MulZeroClass.mul_zero]
+
+private structure Degree.FlowTimeChange.PhaseFlowCoordinates {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (g : E → ℝ) (W : (E × ℝ) → E × ℝ) (F : Flow ℝ (E × ℝ)) where
+  chart : Diffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, E × ℝ) (E × ℝ) (E × ℝ) ∞
+  field_eq : W = Degree.FlowSuspension.suspensionField chart
+  flow_eq : F = Degree.FlowSuspension.suspensionFlow chart
+  base : ∀ p, (chart p).1 = p.1
+  lower : ∀ p, p.2 ≤ 1 / 3 → chart p = p
+  upper : ∀ p, 2 / 3 ≤ p.2 → chart p = (p.1, p.2 + g p.1)
+  axis : ∀ t : ℝ, chart (0, t) = (0, t)
+
+private theorem Degree.FlowTimeChange.exists_compact_phase_flow {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {v : E → ℝ} (hv : ContDiff ℝ ∞ v) (hv0 : v 0 = 0)
+    {U : Set E} (hU : IsOpen U) (h0U : (0 : E) ∈ U) :
+    ∃ (K : Set E) (C : Set (E × ℝ)) (g : E → ℝ) (W : E × ℝ → E × ℝ) (F : Flow ℝ (E × ℝ)),
+      IsCompact K ∧
+        K ⊆ U ∧
+          IsCompact C ∧
+            C ⊆ K ×ˢ Set.Ioo (0 : ℝ) 1 ∧
+              ContDiff ℝ ∞ g ∧
+                tsupport g ⊆ K ∧
+                  g =ᶠ[𝓝 0] v ∧
+                    g 0 = 0 ∧
+                      ContDiff ℝ ∞ W ∧
+                        (∀ p, (W p).1 = 0) ∧
+                          (∀ p, 1 / 2 < (W p).2) ∧
+                            (∀ p ∉ C, W p = (0, 1)) ∧
+                              (∀ p t, HasDerivAt (fun s => F s p) (W (F t p)) t) ∧
+                                (∀ p t, (F t p).1 = p.1) ∧
+                                  (∀ z t, t ≤ 1 / 3 → F t (z, 0) = (z, t)) ∧
+                                    (∀ z t, 2 / 3 ≤ t → F t (z, 0) = (z, t + g z)) ∧
+                                      (∀ s t : ℝ, F t (0, s) = (0, s + t)) ∧
+                                        Nonempty (PhaseFlowCoordinates g W F) := by
+  obtain
+    ⟨K, g, τ, D, hK, hKU, hg, hsupp, hgerm, hg0, hsmall, hτ, hrange, hD, haxis, hleft, hright,
+      hpos⟩ :=
+    exists_supported_phase_clock hv hv0 hU h0U
+  let Q := phaseConjugatingDiffeomorph D
+  let W := Degree.FlowSuspension.suspensionField Q
+  let F := Degree.FlowSuspension.suspensionFlow Q
+  have hbase (p : ℝ × E) : (D p).2 = p.2 := by rw [hD]
+  obtain ⟨C, hC, hCsub, hoff⟩ :=
+    exists_compact_phase_field_support D hK hsupp hsmall hrange hD hleft hright
+  have hinitial (z : E) : Q (z, 0) = (z, 0) := by
+    change ((D (0, z)).2, (D (0, z)).1) = (z, 0)
+    rw [hleft (0, z) (by norm_num)]
+  have hinverse (z : E) : Q.symm (z, 0) = (z, 0) := by
+    have hh := Q.symm_apply_apply (z, 0)
+    rw [hinitial] at hh
+    exact hh
+  have hfromzero (z : E) (t : ℝ) : F t (z, 0) = ((D (t, z)).2, (D (t, z)).1) := by
+    change Q ((Q.symm (z, 0)).1, (Q.symm (z, 0)).2 + t) = _
+    rw [hinverse, zero_add]
+    rfl
+  have hcoords : PhaseFlowCoordinates g W F := by
+    refine ⟨Q, rfl, rfl, ?_, ?_, ?_, ?_⟩
+    · intro p
+      change (D (p.2, p.1)).2 = p.1
+      rw [hD]
+    · intro p hp
+      change ((D (p.2, p.1)).2, (D (p.2, p.1)).1) = p
+      rw [hleft (p.2, p.1) hp]
+    · intro p hp
+      change ((D (p.2, p.1)).2, (D (p.2, p.1)).1) = (p.1, p.2 + g p.1)
+      rw [hright (p.2, p.1) hp]
+    · intro t
+      change ((D (t, 0)).2, (D (t, 0)).1) = (0, t)
+      rw [haxis]
+  refine
+    ⟨K, C, g, W, F, hK, hKU, hC, hCsub, hg, hsupp, hgerm, hg0,
+      Degree.FlowSuspension.contDiff_suspensionField Q, phaseClockField_base_zero D hbase,
+      phaseClockField_time_positive D hpos, hoff,
+      Degree.FlowSuspension.hasDerivAt_suspensionFlow Q, phaseClockFlow_base D hbase, ?_, ?_, ?_,
+      ⟨hcoords⟩⟩
+  · intro z t ht
+    rw [hfromzero, hleft (t, z) ht]
+  · intro z t ht
+    rw [hfromzero, hright (t, z) ht]
+  · intro s t
+    have hQaxis (r : ℝ) : Q (0, r) = (0, r) := by
+      change ((D (r, 0)).2, (D (r, 0)).1) = (0, r)
+      rw [haxis]
+    have hiaxis : Q.symm (0, s) = (0, s) := by
+      have hh := Q.symm_apply_apply (0, s)
+      rw [hQaxis] at hh
+      exact hh
+    change Q ((Q.symm (0, s)).1, (Q.symm (0, s)).2 + t) = _
+    rw [hiaxis, hQaxis]
+
+private theorem Degree.FlowTimeChange.partialChartField_vertical_factor {E B M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [TopologicalSpace M] [ChartedSpace B M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, B) (E × ℝ) M ∞) (W : (E × ℝ) → E × ℝ)
+    (hbase : ∀ p, (W p).1 = 0) (x : M) :
+    Smale.FlowConstruction.partialChartField Φ.symm W x =
+      (W (Φ.symm x)).2 •
+        Smale.FlowConstruction.partialChartField Φ.symm (fun _ : E × ℝ => (0, 1)) x := by
+  have hw (p : E × ℝ) : W p = (W p).2 • ((0 : E), (1 : ℝ)) := by
+    apply Prod.ext
+    · simpa only [Prod.smul_fst, smul_zero] using hbase p
+    · simp only [Prod.smul_snd, smul_eq_mul, mul_one]
+  unfold Smale.FlowConstruction.partialChartField
+  rw [VectorField.mpullback_apply, VectorField.mpullback_apply]
+  conv_lhs => rw [hw]
+  rw [map_smul, map_smul]
+
+private theorem Degree.FlowTimeChange.exists_native_positive_cylinder_rescaling {E B M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [TopologicalSpace M] [ChartedSpace B M] [T2Space M] [IsManifold 𝓘(ℝ, B) ∞ M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, B) (E × ℝ) M ∞)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, B) x)
+    (hV : ContMDiff 𝓘(ℝ, B) (𝓘(ℝ, B).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, B) M)))
+    (hmodel :
+      ∀ x ∈ Φ.target,
+        V x = Smale.FlowConstruction.partialChartField Φ.symm (fun _ : E × ℝ => (0, 1)) x)
+    (W : (E × ℝ) → E × ℝ) (hW : ContDiff ℝ ∞ W) (hbase : ∀ p, (W p).1 = 0)
+    (hpos : ∀ p, 0 < (W p).2) {C : Set (E × ℝ)} (hC : IsCompact C) (hCsource : C ⊆ Φ.source)
+    (hfix : ∀ p ∉ C, W p = (0, 1)) :
+    ∃ ρ : M → ℝ,
+      ContMDiff 𝓘(ℝ, B) 𝓘(ℝ, ℝ) ∞ ρ ∧
+        (∀ x, 0 < ρ x) ∧
+          ContMDiff 𝓘(ℝ, B) (𝓘(ℝ, B).tangent) ∞
+              (fun x => (⟨x, ρ x • V x⟩ : TangentBundle 𝓘(ℝ, B) M)) ∧
+            (∀ x ∈ Φ.target, ρ x • V x = Smale.FlowConstruction.partialChartField Φ.symm W x) ∧
+              (∀ x, ρ x • V x = 0 ↔ V x = 0) ∧
+                (∀ (f : M → ℝ) x,
+                    mvfderiv 𝓘(ℝ, B) f x (V x) < 0 → mvfderiv 𝓘(ℝ, B) f x (ρ x • V x) < 0) ∧
+                  ∀ x ∉ Φ '' C, ∀ᶠ y in 𝓝 x, ρ y = 1 := by
+  let w (p : E × ℝ) := (W p).2
+  let ρ := Degree.LocalFunctionReplacement.replace Φ (fun _ : M => 1) w
+  have hw : ContDiff ℝ ∞ w := hW.snd
+  have hwfix (p : E × ℝ) (hp : p ∉ C) : w p = 1 := by
+    change (W p).2 = 1
+    rw [hfix p hp]
+  have hρ : ContMDiff 𝓘(ℝ, B) 𝓘(ℝ, ℝ) ∞ ρ :=
+    Degree.LocalFunctionReplacement.contMDiff_replace Φ contMDiff_const hw hC hCsource
+      (fun _ _ => rfl) hwfix
+  have hρpos (x : M) : 0 < ρ x := by
+    change 0 < Degree.LocalFunctionReplacement.replace Φ (fun _ : M => 1) w x
+    by_cases hx : x ∈ Φ.target
+    · rw [Degree.LocalFunctionReplacement.replace_of_mem Φ (fun _ => 1) w hx]
+      exact hpos _
+    · rw [Degree.LocalFunctionReplacement.replace_of_notMem Φ (fun _ => 1) w hx]
+      exact zero_lt_one
+  refine ⟨ρ, hρ, hρpos, hρ.smul_section hV, ?_, ?_, ?_, ?_⟩
+  · intro x hx
+    change Degree.LocalFunctionReplacement.replace Φ (fun _ : M => 1) w x • V x = _
+    rw [Degree.LocalFunctionReplacement.replace_of_mem Φ (fun _ => 1) w hx, hmodel x hx,
+      partialChartField_vertical_factor Φ W hbase x]
+  · intro x
+    exact smul_eq_zero.trans (or_iff_right (hρpos x).ne')
+  · intro f x hx
+    rw [map_smul, smul_eq_mul]
+    exact mul_neg_of_pos_of_neg (hρpos x) hx
+  · intro x hx
+    exact
+      Degree.LocalFunctionReplacement.replace_germ_off_support Φ hC hCsource (fun _ _ => rfl)
+        hwfix hx
+
+private theorem Degree.FlowSuspension.exists_native_cylinder_conjugacy {Z E M : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, E) (Z × ℝ) M ∞) {U : Set Z}
+    (hsource : Φ.source = U ×ˢ Set.univ)
+    (D : Diffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, Z × ℝ) (Z × ℝ) (Z × ℝ) ∞)
+    (hbase : ∀ p, (D p).1 ∈ U ↔ p.1 ∈ U) (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hmodel :
+      ∀ y ∈ Φ.target,
+        V y = Smale.FlowConstruction.partialChartField Φ.symm (suspensionField D) y) :
+    ∃ Ω : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, E) (Z × ℝ) M ∞,
+      Ω.source = U ×ˢ Set.univ ∧
+        Ω.target = Φ.target ∧
+          (∀ p, Ω p = Φ (D p)) ∧
+            ∀ y ∈ Ω.target,
+              V y = Smale.FlowConstruction.partialChartField Ω.symm (fun _ : Z × ℝ => (0, 1)) y :=
+  by
+  let Ω := D.toPartialDiffeomorph.trans Φ
+  have hΩsource : Ω.source = U ×ˢ Set.univ := by
+    ext p
+    change (p ∈ (Set.univ : Set (Z × ℝ)) ∧ D p ∈ Φ.source) ↔ p ∈ U ×ˢ Set.univ
+    rw [hsource]
+    simp only [Set.mem_univ, true_and, Set.mem_prod, and_true, hbase]
+  have hΩtarget : Ω.target = Φ.target := by
+    ext y
+    change (y ∈ Φ.target ∧ Φ.symm y ∈ (Set.univ : Set (Z × ℝ))) ↔ y ∈ Φ.target
+    simp only [Set.mem_univ, and_true]
+  have hpush (p : Z × ℝ) (_ : p ∈ D.toPartialDiffeomorph.source) :
+    fderiv ℝ D.toPartialDiffeomorph p (0, 1) = suspensionField D (D p) := by
+    simp only [suspensionField, D.symm_apply_apply]
+    rfl
+  refine ⟨Ω, hΩsource, hΩtarget, fun _ => rfl, ?_⟩
+  intro y hy
+  rw [hmodel y (hΩtarget ▸ hy)]
+  exact
+    (MorseCancel.partialChartField_of_model_conjugacy D.toPartialDiffeomorph Φ
+        (fun _ : Z × ℝ => (0, 1)) (suspensionField D) hpush hy).symm
+
+private theorem Degree.FlowTimeChange.exists_native_phase_realization {E B M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [FiniteDimensional ℝ B] [TopologicalSpace M] [ChartedSpace B M]
+    [IsManifold 𝓘(ℝ, B) ∞ M] [T2Space M] [CompactSpace M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, B) (E × ℝ) M ∞) {U : Set E} (hU : IsOpen U)
+    (h0U : (0 : E) ∈ U) (hsource : Φ.source = U ×ˢ Set.univ)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, B) x)
+    (hV : ContMDiff 𝓘(ℝ, B) (𝓘(ℝ, B).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, B) M)))
+    (hmodel :
+      ∀ x ∈ Φ.target,
+        V x = Smale.FlowConstruction.partialChartField Φ.symm (fun _ : E × ℝ => (0, 1)) x)
+    (H : Flow ℝ M) (hH : ∀ x, IsMIntegralCurve (fun t => H t x) V) {v : E → ℝ}
+    (hv : ContDiff ℝ ∞ v) (hv0 : v 0 = 0) :
+    ∃ (N : Set M) (g : E → ℝ) (V' : (x : M) → TangentSpace 𝓘(ℝ, B) x) (G : Flow ℝ M),
+      IsCompact N ∧
+        N ⊆ Φ.target ∩ Φ '' (U ×ˢ Set.Ioo (0 : ℝ) 1) ∧
+          ContDiff ℝ ∞ g ∧
+            g =ᶠ[𝓝 0] v ∧
+              g 0 = 0 ∧
+                ContMDiff 𝓘(ℝ, B) (𝓘(ℝ, B).tangent) ∞
+                    (fun x => (⟨x, V' x⟩ : TangentBundle 𝓘(ℝ, B) M)) ∧
+                  (∀ x, IsMIntegralCurve (fun t => G t x) V') ∧
+                    (∀ x, V' x = 0 ↔ V x = 0) ∧
+                      (∀ (f : M → ℝ) x,
+                          mvfderiv 𝓘(ℝ, B) f x (V x) < 0 → mvfderiv 𝓘(ℝ, B) f x (V' x) < 0) ∧
+                        (∀ x ∉ N, ∀ᶠ y in 𝓝 x, V' y = V y) ∧
+                          (∀ x,
+                              Set.range (fun t => G t x) = Set.range (fun t => H t x) ∧
+                                (∀ p,
+                                    Filter.Tendsto (fun t => G t x) Filter.atTop (𝓝 p) ↔
+                                      Filter.Tendsto (fun t => H t x) Filter.atTop (𝓝 p)) ∧
+                                  ∀ p,
+                                    Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 p) ↔
+                                      Filter.Tendsto (fun t => H t x) Filter.atBot (𝓝 p)) ∧
+                            (∀ z ∈ U, ∀ t : ℝ, t ≤ 1 / 3 → G t (Φ (z, 0)) = Φ (z, t)) ∧
+                              (∀ z ∈ U, ∀ t : ℝ, 2 / 3 ≤ t → G t (Φ (z, 0)) = Φ (z, t + g z)) ∧
+                                (∀ s t : ℝ, G t (Φ (0, s)) = Φ (0, s + t)) ∧
+                                  ∃ Ω : PartialDiffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, B) (E × ℝ) M ∞,
+                                    Ω.source = U ×ˢ Set.univ ∧
+                                      Ω.target = Φ.target ∧
+                                        (∀ y ∈ Ω.target,
+                                            V' y =
+                                              Smale.FlowConstruction.partialChartField Ω.symm
+                                                (fun _ : E × ℝ => (0, 1)) y) ∧
+                                          (∀ p, p.2 ≤ 1 / 3 → Ω p = Φ p) ∧
+                                            (∀ p, 2 / 3 ≤ p.2 → Ω p = Φ (p.1, p.2 + g p.1)) ∧
+                                              (∀ t : ℝ, Ω (0, t) = Φ (0, t)) ∧
+                                                ∀ z ∈ U, ∀ t : ℝ, Ω (z, t) = G t (Φ (z, 0)) := by
+  obtain
+    ⟨K, C, g, W, F, -, hKU, hC, hCsub, hg, -, hgerm, hg0, hW, hWbase, hWpos, hWfix, hF, hFbase,
+      hleft, hright, haxis, ⟨Cdata⟩⟩ :=
+    exists_compact_phase_flow hv hv0 hU h0U
+  have hCsource : C ⊆ Φ.source := by
+    rw [hsource]
+    exact fun p hp => ⟨hKU (hCsub hp).1, Set.mem_univ _⟩
+  obtain ⟨ρ, hρ, hρpos, hV', hnew, hzeros, hneg, hρgerm⟩ :=
+    exists_native_positive_cylinder_rescaling Φ V hV hmodel W hW hWbase
+      (fun p => (by norm_num : (0 : ℝ) < 1 / 2).trans (hWpos p)) hC hCsource hWfix
+  let V' : (x : M) → TangentSpace 𝓘(ℝ, B) x := fun x => ρ x • V x
+  let N := Φ '' C
+  have hN : IsCompact N :=
+    hC.image_of_continuousOn (Φ.contMDiffOn_toFun.continuousOn.mono hCsource)
+  have hNsub : N ⊆ Φ.target ∩ Φ '' (U ×ˢ Set.Ioo (0 : ℝ) 1) := by
+    rintro x ⟨p, hp, rfl⟩
+    exact ⟨Φ.map_source' (hCsource hp), ⟨p, ⟨hKU (hCsub hp).1, (hCsub hp).2⟩, rfl⟩⟩
+  have hV'₁ := hV'.of_le (show (1 : WithTop ℕ∞) ≤ (↑(⊤ : ℕ∞) : ℕ∞ω) by simp)
+  let G := Smale.FlowConstruction.compactFlow hV'₁
+  have hG (x : M) : IsMIntegralCurve (fun t => G t x) V' :=
+    Smale.FlowConstruction.isMIntegralCurve_compactFlow hV'₁ x
+  have hstay (p : E × ℝ) (hp : p ∈ Φ.source) (t : ℝ) : F t p ∈ Φ.source := by
+    rw [hsource] at hp ⊢
+    exact ⟨(hFbase p t) ▸ hp.1, Set.mem_univ _⟩
+  have hfull (p : E × ℝ) (hp : p ∈ Φ.source) (t : ℝ) : G t (Φ p) = Φ (F t p) :=
+    Degree.FlowSuspension.native_chart_flow_all_time Φ hV'₁ G hG F W hF hnew (hstay p hp) t
+  have hnew' (y : M) (hy : y ∈ Φ.target) :
+    V' y =
+      Smale.FlowConstruction.partialChartField Φ.symm
+        (Degree.FlowSuspension.suspensionField Cdata.chart) y := by
+    exact
+      (hnew y hy).trans
+        (congrArg (fun w => Smale.FlowConstruction.partialChartField Φ.symm w y) Cdata.field_eq)
+  obtain ⟨Ω, hΩsource, hΩtarget, hΩmap, hΩfield⟩ :=
+    Degree.FlowSuspension.exists_native_cylinder_conjugacy Φ hsource Cdata.chart
+      (fun p => by rw [Cdata.base]) V' hnew'
+  have hΩlower (p : E × ℝ) (hp : p.2 ≤ 1 / 3) : Ω p = Φ p := by rw [hΩmap, Cdata.lower p hp]
+  have hΩupper (p : E × ℝ) (hp : 2 / 3 ≤ p.2) : Ω p = Φ (p.1, p.2 + g p.1) := by
+    rw [hΩmap, Cdata.upper p hp]
+  have hΩaxis (t : ℝ) : Ω (0, t) = Φ (0, t) := by rw [hΩmap, Cdata.axis]
+  have hΩflow (z : E) (hz : z ∈ U) (t : ℝ) : Ω (z, t) = G t (Φ (z, 0)) := by
+    have h0 : (z, (0 : ℝ)) ∈ Φ.source := by rw [hsource]; exact ⟨hz, Set.mem_univ _⟩
+    have hC0 : Cdata.chart (z, (0 : ℝ)) = (z, 0) := Cdata.lower _ (by norm_num)
+    have hFt : F t (z, 0) = Cdata.chart (z, t) := by
+      calc
+        F t (z, 0) = Degree.FlowSuspension.suspensionFlow Cdata.chart t (z, 0) :=
+          congrArg (fun A : Flow ℝ (E × ℝ) => A t (z, 0)) Cdata.flow_eq
+        _ = Degree.FlowSuspension.suspensionFlow Cdata.chart t (Cdata.chart (z, 0)) :=
+          (congrArg (Degree.FlowSuspension.suspensionFlow Cdata.chart t) hC0.symm)
+        _ = Cdata.chart (z, 0 + t) :=
+          (Degree.FlowSuspension.suspensionFlow_chart Cdata.chart t (z, 0))
+        _ = Cdata.chart (z, t) := by rw [zero_add]
+    rw [hΩmap]
+    exact ((hfull (z, 0) h0 t).trans (congrArg Φ hFt)).symm
+  refine
+    ⟨N, g, V', G, hN, hNsub, hg, hgerm, hg0, hV', hG, hzeros, hneg, ?_,
+      native_flow_time_change_orbits hρ.continuous hρpos hV'₁ H G hH hG, ?_, ?_, ?_, Ω, hΩsource,
+      hΩtarget, hΩfield, hΩlower, hΩupper, hΩaxis, hΩflow⟩
+  · intro x hx
+    filter_upwards [hρgerm x hx] with y hy
+    simp only [V', hy, one_smul]
+  · intro z hz t ht
+    have hp : (z, (0 : ℝ)) ∈ Φ.source := by rw [hsource]; exact ⟨hz, Set.mem_univ _⟩
+    rw [hfull _ hp, hleft z t ht]
+  · intro z hz t ht
+    have hp : (z, (0 : ℝ)) ∈ Φ.source := by rw [hsource]; exact ⟨hz, Set.mem_univ _⟩
+    rw [hfull _ hp, hright z t ht]
+  · intro s t
+    have hp : ((0 : E), s) ∈ Φ.source := by rw [hsource]; exact ⟨h0U, Set.mem_univ _⟩
+    rw [hfull _ hp, haxis]
+
+private theorem Degree.FlowTimeChange.exists_native_matched_phase_cylinder {E Z B M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [FiniteDimensional ℝ B] [TopologicalSpace M] [ChartedSpace B M] [IsManifold 𝓘(ℝ, B) ∞ M]
+    [T2Space M] [CompactSpace M] (Φ Ω : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, B) (Z × ℝ) M ∞)
+    {U : Set Z} (hsource : Ω.source = U ×ˢ Set.univ)
+    (Q : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, Z) E Z ∞) (hQtarget : Q.target = U)
+    (hQ0 : (0 : E) ∈ Q.source) (hQzero : Q 0 = 0) (P : E → Z) {v₀ v₁ : E → ℝ}
+    (hv₀ : ContDiff ℝ ∞ v₀) (hv₁ : ContDiff ℝ ∞ v₁) (hv₀zero : v₀ 0 = 0) (hv₁zero : v₁ 0 = 0)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, B) x)
+    (hV : ContMDiff 𝓘(ℝ, B) (𝓘(ℝ, B).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, B) M)))
+    (hmodel :
+      ∀ y ∈ Ω.target,
+        V y = Smale.FlowConstruction.partialChartField Ω.symm (fun _ : Z × ℝ => (0, 1)) y)
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hleft : ∀ p, p.2 ≤ 0 → Ω p = Φ p)
+    (hright : ∀ᶠ z in 𝓝 (0 : E), ∀ t : ℝ, 1 ≤ t → Ω (Q z, t) = Φ (P z, t)) :
+    ∃ (N : Set M) (W : (x : M) → TangentSpace 𝓘(ℝ, B) x) (G : Flow ℝ M) (Ξ :
+      PartialDiffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, B) (E × ℝ) M ∞),
+      IsCompact N ∧
+        N ⊆ Ω.target ∧
+          ContMDiff 𝓘(ℝ, B) (𝓘(ℝ, B).tangent) ∞ (fun x => (⟨x, W x⟩ : TangentBundle 𝓘(ℝ, B) M)) ∧
+            (∀ x, IsMIntegralCurve (fun t => G t x) W) ∧
+              (∀ x, W x = 0 ↔ V x = 0) ∧
+                (∀ (f : M → ℝ) x,
+                    mvfderiv 𝓘(ℝ, B) f x (V x) < 0 → mvfderiv 𝓘(ℝ, B) f x (W x) < 0) ∧
+                  (∀ x ∉ N, ∀ᶠ y in 𝓝 x, W y = V y) ∧
+                    (∀ x,
+                        Set.range (fun t => G t x) = Set.range (fun t => F t x) ∧
+                          (∀ p,
+                              Filter.Tendsto (fun t => G t x) Filter.atTop (𝓝 p) ↔
+                                Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p)) ∧
+                            ∀ p,
+                              Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 p) ↔
+                                Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p)) ∧
+                      Ξ.source = Q.source ×ˢ Set.univ ∧
+                        Ξ.target = Ω.target ∧
+                          (∀ y ∈ Ξ.target,
+                              W y =
+                                Smale.FlowConstruction.partialChartField Ξ.symm
+                                  (fun _ : E × ℝ => (0, 1)) y) ∧
+                            (∀ t : ℝ, Ξ (0, t) = Ω (0, t)) ∧
+                              ∀ᶠ z in 𝓝 (0 : E),
+                                (∀ t : ℝ, t ≤ -1 → Ξ (z, t) = Φ (Q z, t + v₀ z)) ∧
+                                  (∀ t : ℝ, 2 ≤ t → Ξ (z, t) = Φ (P z, t + v₁ z)) := by
+  obtain ⟨Ψ, hΨsource, hΨtarget, hΨmap, hΨmodel⟩ :=
+    Degree.FlowSuspension.exists_native_phase_cylinder Ω hsource Q hQtarget v₀ hv₀ V hmodel
+  let v : E → ℝ := fun z => v₁ z - v₀ z
+  have hv : ContDiff ℝ ∞ v := hv₁.sub hv₀
+  have hvzero : v 0 = 0 := by simp only [v, hv₁zero, hv₀zero, sub_self]
+  obtain
+    ⟨N, g, W, G, hN, hNsub, _, hgerm, _, hW, hG, hzero, hdesc, hfield, hgeometry, _, _, _, Ξ,
+      hΞsource, hΞtarget, hΞmodel, hΞleft, hΞright, hΞaxis, _⟩ :=
+    exists_native_phase_realization Ψ Q.open_source hQ0 hΨsource V hV hΨmodel F hF hv hvzero
+  have hsmall₀ : ∀ᶠ z in 𝓝 (0 : E), v₀ z ∈ Set.Ioo (-(1 / 2 : ℝ)) (1 / 2) :=
+    hv₀.continuous.continuousAt.eventually
+      (isOpen_Ioo.mem_nhds (by rw [hv₀zero]; constructor <;> norm_num))
+  have hsmall₁ : ∀ᶠ z in 𝓝 (0 : E), v₁ z ∈ Set.Ioo (-(1 / 2 : ℝ)) (1 / 2) :=
+    hv₁.continuous.continuousAt.eventually
+      (isOpen_Ioo.mem_nhds (by rw [hv₁zero]; constructor <;> norm_num))
+  refine
+    ⟨N, W, G, Ξ, hN, fun x hx => hΨtarget ▸ (hNsub hx).1, hW, hG, hzero, hdesc, hfield, hgeometry,
+      hΞsource, hΞtarget.trans hΨtarget, hΞmodel, ?_, ?_⟩
+  · intro t
+    rw [hΞaxis, hΨmap, hQzero, hv₀zero, add_zero]
+  · filter_upwards [hgerm, hright, hsmall₀, hsmall₁] with z hg hr h₀ h₁
+    constructor
+    · intro t ht
+      rw [hΞleft (z, t) (by dsimp; linarith), hΨmap]
+      exact hleft (Q z, t + v₀ z) (by dsimp; linarith [h₀.2])
+    · intro t ht
+      have hclock : t + g z + v₀ z = t + v₁ z := by
+        change g z = v₁ z - v₀ z at hg
+        rw [hg]
+        ring
+      rw [hΞright (z, t) (by dsimp; linarith), hΨmap, hclock]
+      exact hr (t + v₁ z) (by linarith [h₁.1])
+
+private theorem Degree.FlowSuspension.exists_unique_phase_corrected_cylinder {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [FiniteDimensional ℝ B] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [FiniteDimensional ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, E) (Z × ℝ) M ∞) {U : Set Z}
+    (hsource : Φ.source = U ×ˢ Set.univ) {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {c : ℝ}
+    (hheight : ∀ p ∈ Φ.source, p.2 ∈ Set.Ioo (0 : ℝ) 1 → f (Φ p) = c - p.2)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hmodel :
+      ∀ x ∈ Φ.target,
+        V x = Smale.FlowConstruction.partialChartField Φ.symm (fun _ : Z × ℝ => (0, 1)) x)
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (Q P : PartialDiffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, Z) (A × B) Z ∞)
+    (H : PartialDiffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, A × B) (A × B) (A × B) ∞)
+    (h0 : (0 : A × B) ∈ H.source) (hH0 : H 0 = 0) (hQ0 : Q 0 = 0) (hP0 : P 0 = 0)
+    (hHs : H.source ⊆ Q.source) (hHt : H.target ⊆ P.source) (hQtarget : Q.target = U)
+    (hPtarget : P.target = U) (hdiagram : ∀ z ∈ H.source, P (H z) = Q z)
+    (htrans :
+      Smale.NativeTransversality.At 𝓘(ℝ, A) 𝓘(ℝ, B) 𝓘(ℝ, A × B) (fun x : A => H (x, 0))
+        (fun y : B => (0, y)) 0 0)
+    {p q : M}
+    (hleftBasin :
+      ∀ z ∈ U,
+        Filter.Tendsto (fun t => F t (Φ (z, 0))) Filter.atBot (𝓝 q) ↔
+          ∃ x : A, (x, (0 : B)) ∈ H.source ∧ Q (x, 0) = z)
+    (hrightBasin :
+      ∀ z ∈ U,
+        Filter.Tendsto (fun t => F t (Φ (z, 1))) Filter.atTop (𝓝 p) ↔
+          ∃ y ∈ H.target, y.1 = 0 ∧ P y = z)
+    (hold :
+      ∀ x,
+        Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 q) →
+          Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p) → ∃ t, F t (Φ (0, 0)) = x)
+    {v₀ v₁ : (A × B) → ℝ} (hv₀ : ContDiff ℝ ∞ v₀) (hv₁ : ContDiff ℝ ∞ v₁) (hv₀zero : v₀ 0 = 0)
+    (hv₁zero : v₁ 0 = 0) :
+    ∃ (L₁ : A ≃L[ℝ] A) (L₂ : B ≃L[ℝ] B) (N : Set M) (W : (x : M) → TangentSpace 𝓘(ℝ, E) x) (G :
+      Flow ℝ M) (Ξ : PartialDiffeomorph 𝓘(ℝ, (A × B) × ℝ) 𝓘(ℝ, E) ((A × B) × ℝ) M ∞),
+      IsCompact N ∧
+        N ⊆ Φ.target ∧
+          ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, W x⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+            (∀ x, IsMIntegralCurve (fun t => G t x) W) ∧
+              (∀ x, W x = 0 ↔ V x = 0) ∧
+                (∀ x, mvfderiv 𝓘(ℝ, E) f x (V x) < 0 → mvfderiv 𝓘(ℝ, E) f x (W x) < 0) ∧
+                  (∀ x ∉ N, ∀ᶠ y in 𝓝 x, W y = V y) ∧
+                    Ξ.source = Q.source ×ˢ Set.univ ∧
+                      Ξ.target = Φ.target ∧
+                        (∀ y ∈ Ξ.target,
+                            W y =
+                              Smale.FlowConstruction.partialChartField Ξ.symm
+                                (fun _ : (A × B) × ℝ => (0, 1)) y) ∧
+                          (∀ t : ℝ, Ξ (0, t) = Φ (0, t)) ∧
+                            (∀ x,
+                                Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 q) →
+                                  Filter.Tendsto (fun t => G t x) Filter.atTop (𝓝 p) →
+                                    ∃ t, G t (Φ (0, 0)) = x) ∧
+                              ∀ᶠ u in 𝓝 (0 : A × B),
+                                (∀ t : ℝ, t ≤ -1 → Ξ (u, t) = Φ (Q u, t + v₀ u)) ∧
+                                  (∀ t : ℝ,
+                                    2 ≤ t →
+                                      Ξ (u, t) =
+                                        Φ (P (L₁ u.1, L₂ u.2), t + v₁ (L₁ u.1, L₂ u.2))) := by
+  have hQU : Q.target ⊆ U := fun _ hz => hQtarget ▸ hz
+  have hPU : P.target ⊆ U := fun _ hz => hPtarget ▸ hz
+  have h0U : (0 : Z) ∈ U := by
+    have hh := hQU (Q.map_source' (hHs h0))
+    rwa [hQ0] at hh
+  have hflow (z : Z) (hz : z ∈ U) (t : ℝ) : Φ (z, t) = F t (Φ (z, 0)) := by
+    simpa only [zero_add] using
+      (native_vertical_cylinder_flow Φ hsource (hV.of_le (by simp)) hmodel F hF z hz 0 t).symm
+  have hrelative :=
+    relative_intersection_of_native_unique_connection Φ hsource h0U F hflow Q P H h0 hH0 hQ0 hHs
+      hQU hdiagram hleftBasin hrightBasin hold
+  obtain
+    ⟨L₁, L₂, N₁, V₁, G₁, Ω, hN₁, hN₁sub, hV₁, hG₁, hzero₁, hdesc₁, hgerm₁, hout₁, hΩsource,
+      hΩtarget, hΩfield, hΩflow, hΩleft, haxis₁, hΩsection, hleftTail, hrightTail, hsection,
+      hΩright⟩ :=
+    exists_native_block_holonomy Φ hsource hf hheight V hV hmodel F hF Q P H h0 hH0 hQ0 hP0 hHs
+      hHt hQU hPU hdiagram htrans hrelative
+  have hunique₁ :=
+    corrected_cylinder_unique_connection Φ Ω h0U hsource hΩsource hΩtarget F G₁ hflow hΩflow
+      hΩsection hleftTail hrightTail hout₁ Q P hQ0 H.source H.target hleftBasin hrightBasin
+      hsection hold
+  let L := L₁.prodCongr L₂
+  have hv₁L : ContDiff ℝ ∞ (fun u : A × B => v₁ (L u)) := hv₁.comp L.contDiff
+  have hv₁L0 : v₁ (L (0 : A × B)) = 0 := by rw [map_zero, hv₁zero]
+  obtain
+    ⟨N₂, W, G, Ξ, hN₂, hN₂sub, hW, hG, hzero₂, hdesc₂, hgerm₂, hgeometry, hΞsource, hΞtarget,
+      hΞfield, hΞaxis, hΞmatch⟩ :=
+    Degree.FlowTimeChange.exists_native_matched_phase_cylinder Φ Ω hΩsource Q hQtarget (hHs h0)
+      hQ0 (fun u => P (L u)) hv₀ hv₁L hv₀zero hv₁L0 V₁ hV₁ hΩfield G₁ hG₁ hΩleft hΩright
+  let N := N₁ ∪ N₂
+  have hN : IsCompact N := hN₁.union hN₂
+  have hNsub : N ⊆ Φ.target := by
+    intro x hx
+    rcases hx with hx | hx
+    · exact (hN₁sub hx).1
+    · exact hΩtarget ▸ hN₂sub hx
+  have hkeep (x : M) (hx : x ∉ N) : ∀ᶠ y in 𝓝 x, W y = V y := by
+    filter_upwards [hgerm₂ x (fun h => hx (Or.inr h)), hgerm₁ x (fun h => hx (Or.inl h))] with y
+      h₂ h₁
+    exact h₂.trans h₁
+  have haxis (t : ℝ) : Ξ (0, t) = Φ (0, t) := by rw [hΞaxis, hΩflow 0 h0U t, haxis₁ 0 t, zero_add]
+  have hunique :
+    ∀ x,
+      Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 q) →
+        Filter.Tendsto (fun t => G t x) Filter.atTop (𝓝 p) → ∃ t, G t (Φ (0, 0)) = x := by
+    intro x hbot htop
+    obtain ⟨t, ht⟩ := hunique₁ x ((hgeometry x).2.2 q |>.mp hbot) ((hgeometry x).2.1 p |>.mp htop)
+    have hmem : x ∈ Set.range (fun t => G₁ t (Φ (0, 0))) := ⟨t, ht⟩
+    rw [← (hgeometry (Φ (0, 0))).1] at hmem
+    exact hmem
+  exact
+    ⟨L₁, L₂, N, W, G, Ξ, hN, hNsub, hW, hG, fun x => (hzero₂ x).trans (hzero₁ x), fun x hx =>
+      hdesc₂ f x (hdesc₁ x hx), hkeep, hΞsource, hΞtarget.trans hΩtarget, hΞfield, haxis, hunique,
+      hΞmatch⟩
+
+private theorem MorseCancel.native_endpoint_phase_through_box {E Z M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M] {m : ℕ}
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (σ : Fin m → ℝ) {a : ℝ} (ha : 0 < a)
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (A : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, E) (Z × ℝ) M ∞) {U : Set Z}
+    (hAsource : A.source = U ×ˢ Set.univ)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hΦmodel : ∀ y ∈ Φ.target, V y = nativeCubicDescent σ Φ (-(a ^ 2)) y)
+    (hAmodel :
+      ∀ y ∈ A.target,
+        V y = Smale.FlowConstruction.partialChartField A.symm (fun _ : Z × ℝ => (0, 1)) y)
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {c r : ℝ}
+    (hbox : Metric.closedBall (c, (0 : Fin m → ℝ)) r ⊆ Φ.source) (z : Fin m → ℝ) {q : Z}
+    (hq : q ∈ U) {T v : ℝ}
+    (hstart : cubicFlowCylinder σ a (z, T) ∈ Metric.closedBall (c, (0 : Fin m → ℝ)) r)
+    (hmatch : Φ (cubicFlowCylinder σ a (z, T)) = A (q, T + v)) :
+    ∀ t : ℝ,
+      cubicFlowCylinder σ a (z, t) ∈ Metric.closedBall (c, (0 : Fin m → ℝ)) r →
+        Φ (cubicFlowCylinder σ a (z, t)) = A (q, t + v) := by
+  intro t ht
+  calc
+    Φ (cubicFlowCylinder σ a (z, t)) = F (t - T) (Φ (cubicFlowCylinder σ a (z, T))) :=
+      (native_cubic_flow_between_box_points σ ha Φ hV hΦmodel F hF hbox z hstart ht).symm
+    _ = F (t - T) (A (q, T + v)) := (congrArg (F (t - T)) hmatch)
+    _ = A (q, (T + v) + (t - T)) :=
+      (Degree.FlowSuspension.native_vertical_cylinder_flow A hAsource hV hAmodel F hF q hq (T + v)
+        (t - T))
+    _ = A (q, t + v) := congrArg (fun s : ℝ => A (q, s)) (by ring)
+
+private theorem MorseCancel.matched_cubic_time_formulas {E Z B M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [TopologicalSpace M] [ChartedSpace B M] [IsManifold 𝓘(ℝ, B) 1 M] [T2Space M]
+    {m : ℕ} {V : (x : M) → TangentSpace 𝓘(ℝ, B) x} (σ : Fin m → ℝ) {a : ℝ} (ha : 0 < a)
+    (Φq Φp : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, B) (Model m) M ∞)
+    (A : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, B) (Z × ℝ) M ∞) {U : Set Z}
+    (hAsource : A.source = U ×ˢ Set.univ)
+    (hV : ContMDiff 𝓘(ℝ, B) (𝓘(ℝ, B).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, B) M)))
+    (hqfield : ∀ y ∈ Φq.target, V y = nativeCubicDescent σ Φq (-(a ^ 2)) y)
+    (hpfield : ∀ y ∈ Φp.target, V y = nativeCubicDescent σ Φp (-(a ^ 2)) y)
+    (hAfield :
+      ∀ y ∈ A.target,
+        V y = Smale.FlowConstruction.partialChartField A.symm (fun _ : Z × ℝ => (0, 1)) y)
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) (e : (Fin m → ℝ) ≃L[ℝ] E)
+    (L : E ≃L[ℝ] E) (Q P : E → Z) (v₀ v₁ : E → ℝ) {Oq Op : Set E} (hOq : IsOpen Oq)
+    (hOp : IsOpen Op) (h0q : (0 : E) ∈ Oq) (h0p : (0 : E) ∈ Op) (hQU : ∀ u ∈ Oq, Q u ∈ U)
+    (hPU : ∀ u ∈ Op, P u ∈ U) {Rq Rp Tq Tp : ℝ}
+    (hboxq : Metric.closedBall (-a, (0 : Fin m → ℝ)) Rq ⊆ Φq.source)
+    (hboxp : Metric.closedBall (a, (0 : Fin m → ℝ)) Rp ⊆ Φp.source)
+    (hsliceq :
+      ∀ u ∈ Oq, cubicFlowCylinder σ a (e.symm u, Tq) ∈ Metric.closedBall (-a, (0 : Fin m → ℝ)) Rq)
+    (hslicep :
+      ∀ u ∈ Op, cubicFlowCylinder σ a (e.symm u, Tp) ∈ Metric.closedBall (a, (0 : Fin m → ℝ)) Rp)
+    (hphaseq : ∀ u ∈ Oq, Φq (cubicFlowCylinder σ a (e.symm u, Tq)) = A (Q u, Tq + v₀ u))
+    (hphasep : ∀ u ∈ Op, Φp (cubicFlowCylinder σ a (e.symm u, Tp)) = A (P u, Tp + v₁ u))
+    (Ψq Ψp Φm : Model m → M) (Ξ : E × ℝ → M) (hnewq : ∀ p, Ψq p = Φq p)
+    (hnewp :
+      ∀ z t, Ψp (cubicFlowCylinder σ a (z, t)) = Φp (cubicFlowCylinder σ a (e.symm (L (e z)), t)))
+    (hmid : ∀ z t, Φm (cubicFlowCylinder σ a (z, t)) = Ξ (e z, t)) {rq rp : ℝ}
+    (hcontrolq :
+      Metric.closedBall (-a, (0 : Fin m → ℝ)) rq ⊆ Metric.closedBall (-a, (0 : Fin m → ℝ)) Rq)
+    (hcontrolp :
+      ∀ z t,
+        cubicFlowCylinder σ a (z, t) ∈ Metric.closedBall (a, (0 : Fin m → ℝ)) rp →
+          cubicFlowCylinder σ a (e.symm (L (e z)), t) ∈ Metric.closedBall (a, (0 : Fin m → ℝ)) Rp)
+    (hleft : ∀ᶠ u in 𝓝 (0 : E), ∀ t : ℝ, t ≤ -1 → Ξ (u, t) = A (Q u, t + v₀ u))
+    (hright : ∀ᶠ u in 𝓝 (0 : E), ∀ t : ℝ, 2 ≤ t → Ξ (u, t) = A (P (L u), t + v₁ (L u))) :
+    (∀ᶠ z : Fin m → ℝ in 𝓝 0,
+        ∀ t : ℝ,
+          t ≤ -1 →
+            cubicFlowCylinder σ a (z, t) ∈ Metric.closedBall (-a, (0 : Fin m → ℝ)) rq →
+              Ψq (cubicFlowCylinder σ a (z, t)) = Φm (cubicFlowCylinder σ a (z, t))) ∧
+      (∀ᶠ z : Fin m → ℝ in 𝓝 0,
+        ∀ t : ℝ,
+          2 ≤ t →
+            cubicFlowCylinder σ a (z, t) ∈ Metric.closedBall (a, (0 : Fin m → ℝ)) rp →
+              Ψp (cubicFlowCylinder σ a (z, t)) = Φm (cubicFlowCylinder σ a (z, t))) := by
+  have he : Filter.Tendsto e (𝓝 (0 : Fin m → ℝ)) (𝓝 (0 : E)) := by
+    simpa only [map_zero] using e.continuous.tendsto 0
+  have heL : Filter.Tendsto (fun z : Fin m → ℝ => L (e z)) (𝓝 0) (𝓝 (0 : E)) := by
+    have hh : Filter.Tendsto L (𝓝 (0 : E)) (𝓝 (0 : E)) := by
+      simpa only [map_zero] using L.continuous.tendsto 0
+    exact hh.comp he
+  constructor
+  · filter_upwards [he.eventually hleft, he.eventually (hOq.mem_nhds h0q)] with z hformula hz
+    intro t ht hp
+    have hstart : cubicFlowCylinder σ a (z, Tq) ∈ Metric.closedBall (-a, (0 : Fin m → ℝ)) Rq := by
+      simpa only [e.symm_apply_apply] using hsliceq (e z) hz
+    have hphase : Φq (cubicFlowCylinder σ a (z, Tq)) = A (Q (e z), Tq + v₀ (e z)) := by
+      simpa only [e.symm_apply_apply] using hphaseq (e z) hz
+    calc
+      Ψq (cubicFlowCylinder σ a (z, t)) = Φq (cubicFlowCylinder σ a (z, t)) := hnewq _
+      _ = A (Q (e z), t + v₀ (e z)) :=
+        (native_endpoint_phase_through_box σ ha Φq A hAsource hV hqfield hAfield F hF hboxq z
+          (hQU (e z) hz) hstart hphase t (hcontrolq hp))
+      _ = Ξ (e z, t) := (hformula t ht).symm
+      _ = Φm (cubicFlowCylinder σ a (z, t)) := (hmid z t).symm
+  · filter_upwards [he.eventually hright, heL.eventually (hOp.mem_nhds h0p)] with z hformula hz
+    intro t ht hp
+    calc
+      Ψp (cubicFlowCylinder σ a (z, t)) = Φp (cubicFlowCylinder σ a (e.symm (L (e z)), t)) :=
+        hnewp z t
+      _ = A (P (L (e z)), t + v₁ (L (e z))) :=
+        (native_endpoint_phase_through_box σ ha Φp A hAsource hV hpfield hAfield F hF hboxp
+          (e.symm (L (e z))) (hPU (L (e z)) hz) (hslicep (L (e z)) hz) (hphasep (L (e z)) hz) t
+          (hcontrolp z t hp))
+      _ = Ξ (e z, t) := (hformula t ht).symm
+      _ = Φm (cubicFlowCylinder σ a (z, t)) := (hmid z t).symm
+
+private theorem Degree.FieldChartGluing.partialChartField_eq_of_forward_germ {D E M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] (Φ Ψ : PartialDiffeomorph 𝓘(ℝ, D) 𝓘(ℝ, E) D M ∞)
+    (W : D → D) {p : D} (hpΦ : p ∈ Φ.source) (hpΨ : p ∈ Ψ.source) (heq : (Φ : D → M) =ᶠ[𝓝 p] Ψ) :
+    Smale.FlowConstruction.partialChartField Φ.symm W (Φ p) =
+      Smale.FlowConstruction.partialChartField Ψ.symm W (Φ p) := by
+  have hval : Φ p = Ψ p := heq.eq_of_nhds
+  have hyΨ : Φ p ∈ Ψ.target := hval.symm ▸ Ψ.map_source' hpΨ
+  have hiΦ : Φ.symm (Φ p) = p := Φ.left_inv' hpΦ
+  have hiΨ : Ψ.symm (Φ p) = p := by rw [hval]; exact Ψ.left_inv' hpΨ
+  rw [Smale.FlowConstruction.partialChartField_eq_mfderiv_symm Φ.symm W (Φ.map_source' hpΦ),
+    Smale.FlowConstruction.partialChartField_eq_mfderiv_symm Ψ.symm W hyΨ]
+  change
+    mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) Φ (Φ.symm (Φ p))
+        ((NormedSpace.fromTangentSpace (Φ.symm (Φ p))).symm (W (Φ.symm (Φ p)))) =
+      mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) Ψ (Ψ.symm (Φ p))
+        ((NormedSpace.fromTangentSpace (Ψ.symm (Φ p))).symm (W (Ψ.symm (Φ p))))
+  rw [hiΦ, hiΨ, heq.mfderiv_eq]
+  rfl
+
+private theorem Degree.FieldChartGluing.isLocalDiffeomorphAt_of_chart_germ {D E M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] (Φ : PartialDiffeomorph 𝓘(ℝ, D) 𝓘(ℝ, E) D M ∞)
+    {f : D → M} {p : D} (hp : p ∈ Φ.source) (heq : f =ᶠ[𝓝 p] Φ) :
+    IsLocalDiffeomorphAt 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f p := by
+  obtain ⟨U, hUsub, hU, hpU⟩ := mem_nhds_iff.mp heq
+  let Ψ := Smale.PartialChart.restrictSource Φ hU
+  exact ⟨Ψ, ⟨hp, hpU⟩, fun x hx => hUsub hx.2⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Degree.FieldChartGluing.exists_native_field_chart_near_compact {D E M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [T2Space M] (f : D → M) (W : D → D)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x) {K : Set D} (hK : IsCompact K) (hinj : Set.InjOn f K)
+    (hlocal :
+      ∀ p ∈ K,
+        ∃ Φ : PartialDiffeomorph 𝓘(ℝ, D) 𝓘(ℝ, E) D M ∞,
+          p ∈ Φ.source ∧
+            f =ᶠ[𝓝 p] Φ ∧
+              ∀ y ∈ Φ.target, V y = Smale.FlowConstruction.partialChartField Φ.symm W y) :
+    ∃ Φ : PartialDiffeomorph 𝓘(ℝ, D) 𝓘(ℝ, E) D M ∞,
+      K ⊆ Φ.source ∧
+        (∀ p, Φ p = f p) ∧
+          ∀ y ∈ Φ.target, V y = Smale.FlowConstruction.partialChartField Φ.symm W y := by
+  let U : Set D :=
+    {p |
+      ∃ Φ : PartialDiffeomorph 𝓘(ℝ, D) 𝓘(ℝ, E) D M ∞,
+        p ∈ Φ.source ∧
+          f =ᶠ[𝓝 p] Φ ∧ ∀ y ∈ Φ.target, V y = Smale.FlowConstruction.partialChartField Φ.symm W y}
+  have hU : IsOpen U := by
+    rw [isOpen_iff_mem_nhds]
+    rintro p ⟨Ψ, hp, heq, hfield⟩
+    filter_upwards [Ψ.open_source.mem_nhds hp, heq.eventuallyEq_nhds] with q hq hqeq
+    exact ⟨Ψ, hq, hqeq, hfield⟩
+  have hloc (p : D) (hp : p ∈ K) : IsLocalDiffeomorphAt 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f p := by
+    obtain ⟨Ψ, hpΨ, heq, _⟩ := hlocal p hp
+    exact isLocalDiffeomorphAt_of_chart_germ Ψ hpΨ heq
+  obtain ⟨Φ, hKΦ, hΦU, hmap⟩ :=
+    Smale.exists_partialDiffeomorph_near_compact hK hinj hloc hU hlocal
+  refine ⟨Φ, hKΦ, fun p => congrFun hmap p, ?_⟩
+  intro y hy
+  have hp : Φ.symm y ∈ Φ.source := Φ.map_target' hy
+  obtain ⟨Ψ, hpΨ, heq, hfield⟩ := hΦU hp
+  have hΦeq : (Φ : D → M) =ᶠ[𝓝 (Φ.symm y)] Ψ := by rw [hmap]; exact heq
+  have hi : Φ (Φ.symm y) = y := Φ.right_inv' hy
+  have hΨval : Ψ (Φ.symm y) = y := hΦeq.eq_of_nhds.symm.trans hi
+  have hyΨ : y ∈ Ψ.target := hΨval ▸ Ψ.map_source' hpΨ
+  have hsame := partialChartField_eq_of_forward_germ Φ Ψ W hp hpΨ hΦeq
+  rw [hi] at hsame
+  exact (hfield y hyΨ).trans hsame.symm
+
+private theorem Degree.FieldChartGluing.exists_controlled_field_germ_chart {D E M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] (Φ : PartialDiffeomorph 𝓘(ℝ, D) 𝓘(ℝ, E) D M ∞)
+    (W : D → D) (V V' : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hmodel : ∀ y ∈ Φ.target, V y = Smale.FlowConstruction.partialChartField Φ.symm W y) {c : D}
+    (hc : c ∈ Φ.source) (hfield : ∀ᶠ y in 𝓝 (Φ c), V' y = V y) {O : Set D} (hO : IsOpen O)
+    (hcO : c ∈ O) :
+    ∃ (Ψ : PartialDiffeomorph 𝓘(ℝ, D) 𝓘(ℝ, E) D M ∞) (r : ℝ),
+      0 < r ∧
+        Metric.closedBall c r ⊆ Ψ.source ∧
+          Ψ.source ⊆ Φ.source ∩ O ∧
+            Ψ.target ⊆ Φ.target ∧
+              (∀ z, Ψ z = Φ z) ∧
+                ∀ y ∈ Ψ.target, V' y = Smale.FlowConstruction.partialChartField Ψ.symm W y := by
+  obtain ⟨U, hUsub, hU, hcenter⟩ := mem_nhds_iff.mp hfield
+  let R := Smale.PartialChart.restrictTarget Φ hU
+  let Ψ := Smale.PartialChart.restrictSource R hO
+  have hcΨ : c ∈ Ψ.source := by
+    change (c ∈ Φ.source ∧ Φ c ∈ U) ∧ c ∈ O
+    exact ⟨⟨hc, hcenter⟩, hcO⟩
+  obtain ⟨r, hr, hball⟩ := Metric.nhds_basis_closedBall.mem_iff.mp (Ψ.open_source.mem_nhds hcΨ)
+  refine ⟨Ψ, r, hr, hball, fun z hz => ⟨hz.1.1, hz.2⟩, fun y hy => hy.1.1, fun _ => rfl, ?_⟩
+  intro y hy
+  exact (hUsub hy.1.2).trans (hmodel y hy.1.1)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.signed_split_transverse_rate {m : ℕ} (σ : Fin m → ℝ)
+    (hσ : ∀ i, σ i = -1 ∨ σ i = 1) (z : Fin m → ℝ) :
+    Smale.MorseHandle.splitCoordinates σ (fun i => σ i * z i) =
+      ((-1 : ℝ) • (Smale.MorseHandle.splitCoordinates σ z).1,
+        (1 : ℝ) • (Smale.MorseHandle.splitCoordinates σ z).2) := by
+  apply Prod.ext
+  · ext i
+    change σ i.1 * z i.1 = (-1 : ℝ) * z i.1
+    simp [i.2]
+  · ext i
+    change σ i.1 * z i.1 = (1 : ℝ) * z i.1
+    simp [(hσ i.1).resolve_left i.2]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.signed_split_transverse_exponential {m : ℕ} (σ : Fin m → ℝ)
+    (hσ : ∀ i, σ i = -1 ∨ σ i = 1) (t : ℝ) (z : Fin m → ℝ) :
+    Smale.MorseHandle.splitCoordinates σ (fun i => Real.exp (-σ i * t) * z i) =
+      (Real.exp t • (Smale.MorseHandle.splitCoordinates σ z).1,
+        Real.exp (-t) • (Smale.MorseHandle.splitCoordinates σ z).2) := by
+  apply Prod.ext
+  · ext i
+    change Real.exp (-σ i.1 * t) * z i.1 = Real.exp t * z i.1
+    simp [i.2]
+  · ext i
+    change Real.exp (-σ i.1 * t) * z i.1 = Real.exp (-t) * z i.1
+    simp [(hσ i.1).resolve_left i.2]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.signed_block_change_cubic_cylinder {m : ℕ} (σ : Fin m → ℝ)
+    (hσ : ∀ i, σ i = -1 ∨ σ i = 1)
+    (P : Smale.MorseHandle.NegativeSpace σ ≃L[ℝ] Smale.MorseHandle.NegativeSpace σ)
+    (S : Smale.MorseHandle.PositiveSpace σ ≃L[ℝ] Smale.MorseHandle.PositiveSpace σ) (a t : ℝ)
+    (z : Fin m → ℝ) :
+    transverseFieldChange (splitTransverseChange (Smale.MorseHandle.splitCoordinates σ) P S)
+        (cubicFlowCylinder σ a (z, t)) =
+      cubicFlowCylinder σ a
+        (splitTransverseChange (Smale.MorseHandle.splitCoordinates σ) P S z, t) := by
+  apply Prod.ext
+  · rfl
+  · exact
+      splitTransverseChange_commutes (fun i => Real.exp (-σ i * t))
+        (Smale.MorseHandle.splitCoordinates σ) (Real.exp t) (Real.exp (-t))
+        (signed_split_transverse_exponential σ hσ t) P S z
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_signed_block_changed_cubic_chart {m : ℕ} {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (σ : Fin m → ℝ) (hσ : ∀ i, σ i = -1 ∨ σ i = 1)
+    (P : Smale.MorseHandle.NegativeSpace σ ≃L[ℝ] Smale.MorseHandle.NegativeSpace σ)
+    (S : Smale.MorseHandle.PositiveSpace σ ≃L[ℝ] Smale.MorseHandle.PositiveSpace σ)
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x) (τ : ℝ)
+    (hmodel : ∀ y ∈ Φ.target, V y = nativeCubicDescent σ Φ τ y) :
+    ∃ Ψ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞,
+      Ψ.target = Φ.target ∧
+        (∀ s : ℝ, ((s, (0 : Fin m → ℝ)) ∈ Ψ.source ↔ (s, 0) ∈ Φ.source)) ∧
+          (∀ s : ℝ, Ψ (s, 0) = Φ (s, 0)) ∧
+            (∀ y ∈ Ψ.target, V y = nativeCubicDescent σ Ψ τ y) ∧
+              ∀ (a t : ℝ)
+                (u : Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ),
+                Ψ (cubicFlowCylinder σ a ((Smale.MorseHandle.splitCoordinates σ).symm u, t)) =
+                  Φ
+                    (cubicFlowCylinder σ a
+                      ((Smale.MorseHandle.splitCoordinates σ).symm (P u.1, S u.2), t)) := by
+  let T := splitTransverseChange (Smale.MorseHandle.splitCoordinates σ) P S
+  let D := transverseFieldChange T
+  let Ψ := D.toDiffeomorph.toPartialDiffeomorph.trans Φ
+  have htarget : Ψ.target = Φ.target := by
+    ext y
+    change (y ∈ Φ.target ∧ Φ.symm y ∈ (Set.univ : Set (Model m))) ↔ y ∈ Φ.target
+    simp only [Set.mem_univ, and_true]
+  have hDaxis (s : ℝ) : D (s, 0) = (s, 0) := by
+    change (s, T 0) = (s, 0)
+    rw [map_zero]
+  have hpush (p : Model m) (_ : p ∈ D.toDiffeomorph.toPartialDiffeomorph.source) :
+    fderiv ℝ D.toDiffeomorph.toPartialDiffeomorph p (cubicDescent σ τ p) =
+      cubicDescent σ τ (D p) := by
+    change fderiv ℝ D p (cubicDescent σ τ p) = _
+    rw [D.fderiv]
+    exact
+      transverseFieldChange_cubicDescent σ T
+        (splitTransverseChange_commutes σ (Smale.MorseHandle.splitCoordinates σ) (-1) 1
+          (signed_split_transverse_rate σ hσ) P S)
+        τ p
+  refine ⟨Ψ, htarget, ?_, ?_, ?_, ?_⟩
+  · intro s
+    change ((s, (0 : Fin m → ℝ)) ∈ Set.univ ∧ D (s, 0) ∈ Φ.source) ↔ (s, 0) ∈ Φ.source
+    rw [hDaxis]
+    simp only [Set.mem_univ, true_and]
+  · intro s
+    change Φ (D (s, 0)) = Φ (s, 0)
+    rw [hDaxis]
+  · intro y hy
+    rw [hmodel y (htarget ▸ hy)]
+    exact
+      (partialChartField_of_model_conjugacy D.toDiffeomorph.toPartialDiffeomorph Φ
+          (cubicDescent σ τ) (cubicDescent σ τ) hpush hy).symm
+  · intro a t u
+    change Φ (D (cubicFlowCylinder σ a ((Smale.MorseHandle.splitCoordinates σ).symm u, t))) = _
+    rw [signed_block_change_cubic_cylinder σ hσ P S]
+    have hT :
+      T ((Smale.MorseHandle.splitCoordinates σ).symm u) =
+        (Smale.MorseHandle.splitCoordinates σ).symm (P u.1, S u.2) := by
+      simp only [T, splitTransverseChange, ContinuousLinearEquiv.trans_apply,
+        ContinuousLinearEquiv.apply_symm_apply, ContinuousLinearEquiv.prodCongr_apply]
+    change Φ (cubicFlowCylinder σ a (T ((Smale.MorseHandle.splitCoordinates σ).symm u), t)) = _
+    rw [hT]
+
+private theorem
+    MorseCancel.exists_native_regular_cubic_field_chart {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {m : ℕ} (σ : Fin m → ℝ) {a : ℝ}
+    (ha : 0 < a) (Φ : PartialDiffeomorph 𝓘(ℝ, (Fin m → ℝ) × ℝ) 𝓘(ℝ, E) ((Fin m → ℝ) × ℝ) M ∞)
+    {U : Set (Fin m → ℝ)} (hsource : Φ.source = U ×ˢ Set.univ) (h0 : (0 : Fin m → ℝ) ∈ U)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x) (F : Flow ℝ M)
+    (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) (ι : (Fin m → ℝ) → M)
+    (hformula : ∀ p ∈ Φ.source, Φ p = F p.2 (ι p.1)) :
+    ∃ Ψ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞,
+      Ψ.target = Φ.target ∧
+        Set.Ioo (-a) a ×ˢ {(0 : Fin m → ℝ)} ⊆ Ψ.source ∧
+          (∀ s, Ψ (s, 0) = F (cubicAxisClock a s) (ι 0)) ∧
+            (∀ x ∈ Ψ.target, V x = nativeCubicDescent σ Ψ (-(a ^ 2)) x) ∧
+              Ψ.source ⊆ Set.Ioo (-a) a ×ˢ Set.univ ∧ ∀ p, Ψ (cubicFlowCylinder σ a p) = Φ p := by
+  let C := cubicFlowCylinderChart σ ha
+  let Ψ := C.symm.trans Φ
+  have htarget : Ψ.target = Φ.target := by
+    ext x
+    change x ∈ Φ.target ∧ Φ.symm x ∈ Set.univ ↔ x ∈ Φ.target
+    simp only [Set.mem_univ, and_true]
+  have hcompose (p : (Fin m → ℝ) × ℝ) : Ψ (C p) = Φ p := by
+    change Φ (C.symm (C p)) = Φ p
+    have hh : C.symm (C p) = p := C.left_inv' (Set.mem_univ p)
+    exact congrArg Φ hh
+  have hopenaxis : Set.Ioo (-a) a ×ˢ {(0 : Fin m → ℝ)} ⊆ Ψ.source := by
+    rintro ⟨s, z⟩ ⟨hs, hz⟩
+    have hz0 : z = 0 := hz
+    subst z
+    change (s, (0 : Fin m → ℝ)) ∈ C.target ∧ C.symm (s, 0) ∈ Φ.source
+    refine ⟨⟨hs, Set.mem_univ _⟩, ?_⟩
+    rw [hsource]
+    change (fun i => Real.exp (σ i * cubicAxisClock a s) * (0 : Fin m → ℝ) i) ∈ U ∧ _
+    simp only [Pi.zero_apply, MulZeroClass.mul_zero]
+    exact ⟨h0, Set.mem_univ _⟩
+  refine ⟨Ψ, htarget, hopenaxis, ?_, ?_, fun _ hp => hp.1, hcompose⟩
+  · intro s
+    change Φ (cubicFlowCylinderInverse σ a (s, 0)) = _
+    have hsΦ : cubicFlowCylinderInverse σ a (s, 0) ∈ Φ.source := by
+      rw [hsource]
+      simp only [cubicFlowCylinderInverse, Pi.zero_apply, MulZeroClass.mul_zero]
+      exact ⟨h0, Set.mem_univ _⟩
+    rw [hformula _ hsΦ]
+    simp only [cubicFlowCylinderInverse, Pi.zero_apply, MulZeroClass.mul_zero]
+    rfl
+  · intro x hx
+    have hxΦ : x ∈ Φ.target := htarget ▸ hx
+    let p := Φ.symm x
+    have hp : p ∈ Φ.source := Φ.map_target' hxΦ
+    have hpU : p.1 ∈ U := by rw [hsource] at hp; exact hp.1
+    have hpC : C p ∈ Ψ.source := by
+      change C p ∈ C.target ∧ C.symm (C p) ∈ Φ.source
+      have hh : C.symm (C p) = p := C.left_inv' (Set.mem_univ p)
+      exact ⟨C.map_source' (Set.mem_univ p), hh.symm ▸ hp⟩
+    let α : ℝ → Model m := fun s => C (p.1, s)
+    have hα : HasDerivAt α (cubicDescent σ (-(a ^ 2)) (α p.2)) p.2 :=
+      hasDerivAt_cubicFlowCylinder σ a p.1 p.2
+    have hd :=
+      Smale.FlowConstruction.hasMFDerivAt_lift_partialChartCurve Ψ.symm
+        (cubicDescent σ (-(a ^ 2))) hα hpC
+    have hcurveeq : Ψ.symm.symm ∘ α = fun t => F t (ι p.1) := by
+      funext t
+      have hpt : (p.1, t) ∈ Φ.source := by rw [hsource]; exact ⟨hpU, Set.mem_univ _⟩
+      exact (hcompose (p.1, t)).trans (hformula (p.1, t) hpt)
+    rw [hcurveeq] at hd
+    change
+      HasMFDerivAt 𝓘(ℝ, ℝ) 𝓘(ℝ, E) (fun t => F t (ι p.1)) p.2
+        ((1 : ℝ →L[ℝ] ℝ).smulRight
+          (Smale.FlowConstruction.partialChartField Ψ.symm (cubicDescent σ (-(a ^ 2)))
+            (Ψ (C p)))) at hd
+    rw [hcompose p, hformula p hp] at hd
+    have hh := (hF (ι p.1) p.2).mfderiv.symm.trans hd.mfderiv
+    have hv := congrArg (fun L : ℝ →L[ℝ] TangentSpace 𝓘(ℝ, E) (F p.2 (ι p.1)) => L 1) hh
+    simp only [ContinuousLinearMap.smulRight_apply, one_apply_eq_self, one_smul] at hv
+    have hpx : F p.2 (ι p.1) = x := (hformula p hp).symm.trans (Φ.right_inv' hxΦ)
+    rw [hpx] at hv
+    exact hv
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Recognition/Degree3.lean b/LeanPool/HopfProblem/Recognition/Degree3.lean
new file mode 100644
index 000000000..200dbcd65
--- /dev/null
+++ b/LeanPool/HopfProblem/Recognition/Degree3.lean
@@ -0,0 +1,5698 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Threefold.SpecialPeriods12
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.Recognition.Smale1
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology1
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology2
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz2
+import all LeanPool.HopfProblem.Hurewicz.SecondHurewicz
+import all LeanPool.HopfProblem.Recognition.Smale2
+import all LeanPool.HopfProblem.Recognition.Smale3
+import all LeanPool.HopfProblem.Recognition.Smale4
+import all LeanPool.HopfProblem.Recognition.Smale5
+import all LeanPool.HopfProblem.Recognition.Degree1
+import all LeanPool.HopfProblem.Recognition.Degree2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods8
+import all LeanPool.HopfProblem.Recognition.Smale6
+import all LeanPool.HopfProblem.Recognition.Smale8
+import all LeanPool.HopfProblem.Recognition.Smale9
+import all LeanPool.HopfProblem.Recognition.Smale10
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods11
+import all LeanPool.HopfProblem.MainTheorem.SixSphereCube1
+import all LeanPool.HopfProblem.Recognition.Smale11
+import all LeanPool.HopfProblem.Hurewicz.HigherHurewicz1
+import all LeanPool.HopfProblem.MainTheorem.SixSphereCube2
+import all LeanPool.HopfProblem.Recognition.Smale12
+import all LeanPool.HopfProblem.Hurewicz.SixthHurewicz
+import all LeanPool.HopfProblem.MainTheorem.SixSphereCube3
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods12
+
+/-!
+# Hopf problem: recognition · degree 3
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem Degree.sphereMap_piSix_bijective (x : SpecialPeriods.Threefold.Space) :
+    Function.Bijective
+      (SixthHurewicz.homotopyMap (SpecialPeriods.Threefold.SphereHomologyEquivalence.sphereMap x)
+        SixSphereCube.sphereBasePoint) := by
+  let f := SpecialPeriods.Threefold.SphereHomologyEquivalence.sphereMap x
+  let := Sphere.piTwo_subsingleton SixSphereCube.sphereBasePoint
+  let := Sphere.piThree_subsingleton SixSphereCube.sphereBasePoint
+  let := Sphere.piFour_subsingleton SixSphereCube.sphereBasePoint
+  let := Sphere.piFive_subsingleton SixSphereCube.sphereBasePoint
+  let := SpecialPeriods.Threefold.space_simplyConnected
+  let := SpecialPeriods.Threefold.HomotopyTwo.piTwo_subsingleton (f SixSphereCube.sphereBasePoint)
+  let :=
+    SpecialPeriods.Threefold.HomotopyThree.piThree_subsingleton (f SixSphereCube.sphereBasePoint)
+  let :=
+    SpecialPeriods.Threefold.HomotopyFour.piFour_subsingleton (f SixSphereCube.sphereBasePoint)
+  let :=
+    SpecialPeriods.Threefold.HomotopyFive.piFive_subsingleton (f SixSphereCube.sphereBasePoint)
+  let source := SixthHurewicz.hurewiczLinearEquiv SixSphereCube.sphereBasePoint
+  let target := SixthHurewicz.hurewiczLinearEquiv (f SixSphereCube.sphereBasePoint)
+  let middle := SpecialPeriods.Threefold.SphereHomologyEquivalence.homologyEquiv x 6
+  have natural (a : π_ 6 SixSphereCube.StandardSphere SixSphereCube.sphereBasePoint) :
+    middle (source (Additive.ofMul a)) =
+      target (Additive.ofMul (SixthHurewicz.homotopyMap f SixSphereCube.sphereBasePoint a)) :=
+    SixthHurewicz.hurewiczLinearEquiv_natural f SixSphereCube.sphereBasePoint (Additive.ofMul a)
+  constructor
+  · intro a b hab
+    have hm : middle (source (Additive.ofMul a)) = middle (source (Additive.ofMul b)) :=
+      (natural a).trans
+        ((congrArg (fun c => target (Additive.ofMul c)) hab).trans (natural b).symm)
+    exact congrArg Additive.toMul (source.injective (middle.injective hm))
+  · intro b
+    let a := source.symm (middle.symm (target (Additive.ofMul b)))
+    refine ⟨Additive.toMul a, ?_⟩
+    have ht :
+      target
+          (Additive.ofMul
+            (SixthHurewicz.homotopyMap f SixSphereCube.sphereBasePoint (Additive.toMul a))) =
+        target (Additive.ofMul b) := by
+      calc
+        _ = middle (source a) := (natural (Additive.toMul a)).symm
+        _ = target (Additive.ofMul b) := by
+          dsimp [a]
+          rw [source.apply_symm_apply, middle.apply_symm_apply]
+    exact congrArg Additive.toMul (target.injective ht)
+
+private theorem Degree.BasedDiskLifting.exists_based_disk_lift {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [FiniteDimensional ℝ V] (x : SpecialPeriods.Threefold.Space)
+    (L : V ≃L[ℝ] (Fin 6 → ℝ))
+    (u : C(Degree.DiskCylinder.Disk (E := V), SpecialPeriods.Threefold.Space))
+    (hu :
+      ∀ z : Degree.DiskCylinder.Disk (E := V),
+        ‖(z : V)‖ = 1 →
+          u z =
+            SpecialPeriods.Threefold.SphereHomologyEquivalence.sphereMap x
+              SixSphereCube.sphereBasePoint) :
+    ∃ v : C(Degree.DiskCylinder.Disk (E := V), SixSphereCube.StandardSphere),
+      (∀ z : Degree.DiskCylinder.Disk (E := V),
+          ‖(z : V)‖ = 1 → v z = SixSphereCube.sphereBasePoint) ∧
+        ((SpecialPeriods.Threefold.SphereHomologyEquivalence.sphereMap x).comp v).HomotopicRel u
+          {z : Degree.DiskCylinder.Disk (E := V) | ‖(z : V)‖ = 1} := by
+  let F := SpecialPeriods.Threefold.SphereHomologyEquivalence.sphereMap x
+  let e := Degree.DiskCube.homeomorph L
+  let q : GenLoop (Fin 6) SpecialPeriods.Threefold.Space (F SixSphereCube.sphereBasePoint) :=
+    ⟨u.comp (e.symm : C(_, _)), fun z hz =>
+      hu (e.symm z) ((Degree.DiskCube.symm_boundary_iff L z).mpr hz)⟩
+  obtain ⟨a, ha⟩ := (Degree.sphereMap_piSix_bijective x).2 ⟦q⟧
+  obtain ⟨p, hp⟩ := Quotient.exists_rep a
+  have he : SixthHurewicz.homotopyMap F SixSphereCube.sphereBasePoint ⟦p⟧ = ⟦q⟧ :=
+    (congrArg (SixthHurewicz.homotopyMap F SixSphereCube.sphereBasePoint) hp).trans ha
+  have hh : GenLoop.Homotopic (SecondHurewicz.mapGenLoop F SixSphereCube.sphereBasePoint p) q :=
+    Quotient.exact he
+  obtain ⟨H⟩ := hh
+  let v : C(Degree.DiskCylinder.Disk (E := V), SixSphereCube.StandardSphere) :=
+    p.val.comp (e : C(_, _))
+  refine
+    ⟨v, ?_,
+      ⟨{  toFun := fun z => H (z.1, e z.2)
+          continuous_toFun :=
+            H.continuous.comp (continuous_fst.prodMk (e.continuous.comp continuous_snd))
+          map_zero_left := ?_
+          map_one_left := ?_
+          prop' := ?_ }⟩⟩
+  · intro z hz
+    exact p.property (e z) ((Degree.DiskCube.boundary_iff L z).mpr hz)
+  · intro z
+    exact H.apply_zero (e z)
+  · intro z
+    exact (H.apply_one (e z)).trans (congrArg u (e.symm_apply_apply z))
+  · intro t z hz
+    exact H.eq_fst t ((Degree.DiskCube.boundary_iff L z).mpr hz)
+
+private def Degree.CylinderBall.boundary {V : Type*} [NormedAddCommGroup V] :
+    Set ((unitInterval) × Degree.DiskCylinder.Disk (E := V)) :=
+  {p | p.1 = 0 ∨ p.1 = 1 ∨ ‖(p.2 : V)‖ = 1}
+
+private theorem
+    Degree.CylinderBall.time_norm_le (t : (unitInterval)) : ‖(2 * t.val - 1 : ℝ)‖ ≤ 1 := by
+  rw [Real.norm_eq_abs, abs_le]
+  constructor <;> linarith [t.property.1, t.property.2]
+
+private def Degree.CylinderBall.forward {V : Type*} [NormedAddCommGroup V] :
+    C((unitInterval) × Degree.DiskCylinder.Disk (E := V), Degree.DiskCylinder.Disk (E := ℝ × V))
+    where
+  toFun
+    p :=
+    ⟨(2 * p.1.val - 1, p.2.val),
+      mem_closedBall_zero_iff.mpr
+        (max_le (time_norm_le p.1) (mem_closedBall_zero_iff.mp p.2.property))⟩
+  continuous_toFun :=
+    (((continuous_const.mul (continuous_subtype_val.comp continuous_fst)).sub
+              continuous_const).prodMk
+          (continuous_subtype_val.comp continuous_snd)).subtype_mk
+      _
+
+private def Degree.CylinderBall.inverseTime {V : Type*} [NormedAddCommGroup V]
+    (z : Degree.DiskCylinder.Disk (E := ℝ × V)) : (unitInterval) :=
+  ⟨(z.val.1 + 1) / 2,
+    by
+    have hn : |z.val.1| ≤ 1 := (max_le_iff.mp (mem_closedBall_zero_iff.mp z.property)).1
+    rcases abs_le.mp hn with ⟨hl, hu⟩
+    constructor <;> linarith⟩
+
+private def Degree.CylinderBall.inverseSpace {V : Type*} [NormedAddCommGroup V]
+    (z : Degree.DiskCylinder.Disk (E := ℝ × V)) : Degree.DiskCylinder.Disk (E := V) :=
+  ⟨z.val.2,
+    mem_closedBall_zero_iff.mpr ((max_le_iff.mp (mem_closedBall_zero_iff.mp z.property)).2)⟩
+
+private def Degree.CylinderBall.inverse {V : Type*} [NormedAddCommGroup V] :
+    C(Degree.DiskCylinder.Disk (E := ℝ × V), (unitInterval) × Degree.DiskCylinder.Disk (E := V))
+    where
+  toFun z := (inverseTime z, inverseSpace z)
+  continuous_toFun := by
+    have ht : Continuous (fun z : Degree.DiskCylinder.Disk (E := ℝ × V) => (z.val.1 + 1) / 2) := by
+      fun_prop
+    exact (ht.subtype_mk _).prodMk ((continuous_snd.comp continuous_subtype_val).subtype_mk _)
+
+private def Degree.CylinderBall.homeomorph {V : Type*} [NormedAddCommGroup V] :
+    ((unitInterval) × Degree.DiskCylinder.Disk (E := V)) ≃ₜ Degree.DiskCylinder.Disk (E := ℝ × V)
+    where
+  toFun := forward
+  invFun := inverse
+  left_inv
+    p := by
+    apply Prod.ext
+    · apply Subtype.ext
+      change ((2 * p.1.val - 1) + 1) / 2 = p.1.val
+      ring
+    · rfl
+  right_inv
+    z := by
+    apply Subtype.ext
+    apply Prod.ext
+    · change 2 * ((z.val.1 + 1) / 2) - 1 = z.val.1
+      ring
+    · rfl
+  continuous_toFun := forward.continuous
+  continuous_invFun := inverse.continuous
+
+private theorem Degree.CylinderBall.norm_eq_one_iff {V : Type*} [NormedAddCommGroup V]
+    (p : (unitInterval) × Degree.DiskCylinder.Disk (E := V)) :
+    ‖((homeomorph (V := V) p).val)‖ = 1 ↔ p ∈ boundary := by
+  change Max.max ‖(2 * p.1.val - 1 : ℝ)‖ ‖p.2.val‖ = 1 ↔ _
+  constructor
+  · intro he
+    rcases le_total ‖(2 * p.1.val - 1 : ℝ)‖ ‖p.2.val‖ with h | h
+    · exact Or.inr (Or.inr (by rwa [max_eq_right h] at he))
+    · rw [max_eq_left h, Real.norm_eq_abs] at he
+      have he' : |2 * p.1.val - 1| = |(1 : ℝ)| := by simpa using he
+      rcases abs_eq_abs.mp he' with h | h
+      · exact Or.inr (Or.inl (Subtype.ext (show p.1.val = (1 : ℝ) by linarith)))
+      · exact Or.inl (Subtype.ext (show p.1.val = (0 : ℝ) by linarith))
+  · rintro (h | h | h)
+    · have ht : p.1.val = 0 := congrArg Subtype.val h
+      rw [ht]
+      norm_num
+      exact mem_closedBall_zero_iff.mp p.2.property
+    · have ht : p.1.val = 1 := congrArg Subtype.val h
+      rw [ht]
+      norm_num
+      exact mem_closedBall_zero_iff.mp p.2.property
+    · rw [h, max_eq_right (time_norm_le p.1)]
+
+private def Degree.CylinderBall.diskSphereHomeomorph {V : Type*} [NormedAddCommGroup V] :
+    { z : Degree.DiskCylinder.Disk (E := V) // ‖(z : V)‖ = 1 } ≃ₜ
+      Degree.DiskCylinder.Sphere (E := V)
+    where
+  toFun z := ⟨z.val.val, mem_sphere_zero_iff_norm.mpr z.property⟩
+  invFun s := ⟨Degree.DiskCylinder.boundaryToDisk s, mem_sphere_zero_iff_norm.mp s.property⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := (continuous_subtype_val.comp continuous_subtype_val).subtype_mk _
+  continuous_invFun := Degree.DiskCylinder.boundaryToDisk.continuous.subtype_mk _
+
+private def Degree.CylinderBall.boundaryHomeomorph {V : Type*} [NormedAddCommGroup V] :
+    boundary (V := V) ≃ₜ Degree.DiskCylinder.Sphere (E := ℝ × V) :=
+  ((homeomorph (V := V)).subtype (fun p => (norm_eq_one_iff p).symm)).trans diskSphereHomeomorph
+
+private def Degree.CylinderBoundary.lower {V : Type*} [NormedAddCommGroup V] :
+    C(Degree.DiskCylinder.bottomOrSide (E := V), Degree.CylinderBall.boundary (V := V)) :=
+  ⟨fun p => ⟨p.val, p.property.elim Or.inl (fun h => Or.inr (Or.inr h))⟩,
+    continuous_subtype_val.subtype_mk _⟩
+
+private def Degree.CylinderBoundary.top {V : Type*} [NormedAddCommGroup V] :
+    C(Degree.DiskCylinder.Disk (E := V), Degree.CylinderBall.boundary (V := V)) :=
+  ⟨fun z => ⟨(1, z), Or.inr (Or.inl rfl)⟩, (continuous_const.prodMk continuous_id).subtype_mk _⟩
+
+private def Degree.CylinderBoundary.quotient {V : Type*} [NormedAddCommGroup V] :
+    C(Degree.DiskCylinder.bottomOrSide (E := V) ⊕ Degree.DiskCylinder.Disk (E := V),
+      Degree.CylinderBall.boundary (V := V)) :=
+  ⟨Sum.elim Degree.CylinderBoundary.lower top,
+    Degree.CylinderBoundary.lower.continuous.sumElim top.continuous⟩
+
+private theorem Degree.CylinderBoundary.quotient_surjective {V : Type*} [NormedAddCommGroup V] :
+    Function.Surjective (quotient (V := V)) := by
+  rintro ⟨⟨t, z⟩, ht | ht | hz⟩
+  · exact ⟨.inl ⟨(t, z), Or.inl ht⟩, rfl⟩
+  · change t = 1 at ht
+    subst t
+    exact ⟨.inr z, rfl⟩
+  · exact ⟨.inl ⟨(t, z), Or.inr hz⟩, rfl⟩
+
+private theorem Degree.CylinderBoundary.quotient_isQuotientMap {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [FiniteDimensional ℝ V] : Topology.IsQuotientMap (quotient (V := V)) := by
+  have hclosed : IsClosed (Degree.DiskCylinder.bottomOrSide (E := V)) :=
+    (isClosed_eq continuous_fst continuous_const).union
+      (isClosed_eq (continuous_subtype_val.comp continuous_snd).norm continuous_const)
+  let : CompactSpace (Degree.DiskCylinder.bottomOrSide (E := V)) :=
+    isCompact_iff_compactSpace.mp hclosed.isCompact
+  exact .of_surjective_continuous quotient_surjective quotient.continuous
+
+private theorem Degree.CylinderBoundary.lower_top_compat {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [FiniteDimensional ℝ V] {X : Type*} [TopologicalSpace X]
+    (f g : C(Degree.DiskCylinder.Disk (E := V), X))
+    (H : C((unitInterval) × Degree.DiskCylinder.Sphere (E := V), X))
+    (h0 : ∀ s, H (0, s) = f (Degree.DiskCylinder.boundaryToDisk s))
+    (h1 : ∀ s, H (1, s) = g (Degree.DiskCylinder.boundaryToDisk s))
+    (a : Degree.DiskCylinder.bottomOrSide (E := V)) (b : Degree.DiskCylinder.Disk (E := V))
+    (he : Degree.CylinderBoundary.lower a = top b) :
+    Degree.DiskCylinder.gluedBottomSide f H h0 a = g b := by
+  have ht : a.val.1 = (1 : (unitInterval)) :=
+    congrArg (fun p : Degree.CylinderBall.boundary (V := V) => p.val.1) he
+  have hz : a.val.2 = b := congrArg (fun p : Degree.CylinderBall.boundary (V := V) => p.val.2) he
+  have hs : ‖(a.val.2 : V)‖ = 1 := by
+    rcases a.property with h | h
+    · exact False.elim (zero_ne_one (h.symm.trans ht))
+    · exact h
+  let s : Degree.DiskCylinder.Sphere (E := V) := ⟨a.val.2.val, mem_sphere_zero_iff_norm.mpr hs⟩
+  have ha : a = Degree.DiskCylinder.sideMap (1, s) := Subtype.ext (Prod.ext ht rfl)
+  rw [ha, Degree.DiskCylinder.gluedBottomSide_side]
+  exact (h1 s).trans (congrArg g hz)
+
+private def Degree.CylinderBoundary.data {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    [FiniteDimensional ℝ V] {X : Type*} [TopologicalSpace X]
+    (f g : C(Degree.DiskCylinder.Disk (E := V), X))
+    (H : C((unitInterval) × Degree.DiskCylinder.Sphere (E := V), X))
+    (h0 : ∀ s, H (0, s) = f (Degree.DiskCylinder.boundaryToDisk s)) :
+    C(Degree.DiskCylinder.bottomOrSide (E := V) ⊕ Degree.DiskCylinder.Disk (E := V), X) :=
+  ⟨Sum.elim (Degree.DiskCylinder.gluedBottomSide f H h0) g,
+    (Degree.DiskCylinder.gluedBottomSide f H h0).continuous.sumElim g.continuous⟩
+
+private theorem Degree.CylinderBoundary.data_constant_on_fibres {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [FiniteDimensional ℝ V] {X : Type*} [TopologicalSpace X]
+    (f g : C(Degree.DiskCylinder.Disk (E := V), X))
+    (H : C((unitInterval) × Degree.DiskCylinder.Sphere (E := V), X))
+    (h0 : ∀ s, H (0, s) = f (Degree.DiskCylinder.boundaryToDisk s))
+    (h1 : ∀ s, H (1, s) = g (Degree.DiskCylinder.boundaryToDisk s))
+    (a b : Degree.DiskCylinder.bottomOrSide (E := V) ⊕ Degree.DiskCylinder.Disk (E := V))
+    (he : quotient a = quotient b) : data f g H h0 a = data f g H h0 b := by
+  cases a with
+  | inl a =>
+    cases b with
+    | inl
+      b =>
+      have hv : a.val = b.val :=
+        congrArg (fun p : Degree.CylinderBall.boundary (V := V) => p.val) he
+      exact congrArg (Degree.DiskCylinder.gluedBottomSide f H h0) (Subtype.ext hv)
+    | inr b => exact lower_top_compat f g H h0 h1 a b he
+  | inr a =>
+    cases b with
+    | inl b => exact (lower_top_compat f g H h0 h1 b a he.symm).symm
+    | inr b =>
+      exact congrArg g (congrArg (fun p : Degree.CylinderBall.boundary (V := V) => p.val.2) he)
+
+private def Degree.CylinderBoundary.glued {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    [FiniteDimensional ℝ V] {X : Type*} [TopologicalSpace X]
+    (f g : C(Degree.DiskCylinder.Disk (E := V), X))
+    (H : C((unitInterval) × Degree.DiskCylinder.Sphere (E := V), X))
+    (h0 : ∀ s, H (0, s) = f (Degree.DiskCylinder.boundaryToDisk s))
+    (h1 : ∀ s, H (1, s) = g (Degree.DiskCylinder.boundaryToDisk s)) :
+    C(Degree.CylinderBall.boundary (V := V), X) :=
+  quotient_isQuotientMap.lift (data f g H h0) (data_constant_on_fibres f g H h0 h1)
+
+private theorem
+    Degree.CylinderBoundary.glued_lower {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    [FiniteDimensional ℝ V] {X : Type*} [TopologicalSpace X]
+    (f g : C(Degree.DiskCylinder.Disk (E := V), X))
+    (H : C((unitInterval) × Degree.DiskCylinder.Sphere (E := V), X))
+    (h0 : ∀ s, H (0, s) = f (Degree.DiskCylinder.boundaryToDisk s))
+    (h1 : ∀ s, H (1, s) = g (Degree.DiskCylinder.boundaryToDisk s))
+    (a : Degree.DiskCylinder.bottomOrSide (E := V)) :
+    glued f g H h0 h1 (Degree.CylinderBoundary.lower a) =
+      Degree.DiskCylinder.gluedBottomSide f H h0 a :=
+  ContinuousMap.congr_fun
+    (quotient_isQuotientMap.lift_comp (data f g H h0) (data_constant_on_fibres f g H h0 h1))
+    (.inl a)
+
+private theorem
+    Degree.CylinderBoundary.glued_top {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    [FiniteDimensional ℝ V] {X : Type*} [TopologicalSpace X]
+    (f g : C(Degree.DiskCylinder.Disk (E := V), X))
+    (H : C((unitInterval) × Degree.DiskCylinder.Sphere (E := V), X))
+    (h0 : ∀ s, H (0, s) = f (Degree.DiskCylinder.boundaryToDisk s))
+    (h1 : ∀ s, H (1, s) = g (Degree.DiskCylinder.boundaryToDisk s))
+    (z : Degree.DiskCylinder.Disk (E := V)) : glued f g H h0 h1 (top z) = g z :=
+  ContinuousMap.congr_fun
+    (quotient_isQuotientMap.lift_comp (data f g H h0) (data_constant_on_fibres f g H h0 h1))
+    (.inr z)
+
+private theorem
+    Degree.CylinderBoundary.glued_bottom {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    [FiniteDimensional ℝ V] {X : Type*} [TopologicalSpace X]
+    (f g : C(Degree.DiskCylinder.Disk (E := V), X))
+    (H : C((unitInterval) × Degree.DiskCylinder.Sphere (E := V), X))
+    (h0 : ∀ s, H (0, s) = f (Degree.DiskCylinder.boundaryToDisk s))
+    (h1 : ∀ s, H (1, s) = g (Degree.DiskCylinder.boundaryToDisk s))
+    (z : Degree.DiskCylinder.Disk (E := V)) :
+    glued f g H h0 h1 (Degree.CylinderBoundary.lower (Degree.DiskCylinder.bottomMap z)) = f z := by
+  rw [glued_lower, Degree.DiskCylinder.gluedBottomSide_bottom]
+
+private theorem
+    Degree.CylinderBoundary.glued_side {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    [FiniteDimensional ℝ V] {X : Type*} [TopologicalSpace X]
+    (f g : C(Degree.DiskCylinder.Disk (E := V), X))
+    (H : C((unitInterval) × Degree.DiskCylinder.Sphere (E := V), X))
+    (h0 : ∀ s, H (0, s) = f (Degree.DiskCylinder.boundaryToDisk s))
+    (h1 : ∀ s, H (1, s) = g (Degree.DiskCylinder.boundaryToDisk s)) (t : (unitInterval))
+    (s : Degree.DiskCylinder.Sphere (E := V)) :
+    glued f g H h0 h1 (Degree.CylinderBoundary.lower (Degree.DiskCylinder.sideMap (t, s))) =
+      H (t, s) := by rw [glued_lower, Degree.DiskCylinder.gluedBottomSide_side]
+
+private abbrev Degree.SphereCube.Sphere (n : ℕ) :=
+  Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1
+
+private def Degree.SphereCube.compactification (n : ℕ) :
+    OnePoint (SixSphereCube.CubeInteriorN n) ≃ₜ Sphere n :=
+  (SixSphereCube.cubeInteriorEuclideanHomeomorph n).onePointCongr.trans
+    (onePointEquivSphereOfFinrankEq (V := EuclideanSpace ℝ (Fin n)) (ι := Fin (n + 1)) (by simp))
+
+private def Degree.SphereCube.point (n : ℕ) : Sphere n :=
+  compactification n (OnePoint.infty)
+
+private def Degree.SphereCube.quotient (n : ℕ) : C(Fin n → (unitInterval), Sphere n) :=
+  (compactification n : C(OnePoint (SixSphereCube.CubeInteriorN n), Sphere n)).comp
+    (SixSphereCube.collapseMap (Cube.boundary (Fin n)) (SixSphereCube.isClosed_cubeBoundaryN n))
+
+private theorem Degree.SphereCube.quotient_boundary (n : ℕ) (z : Fin n → (unitInterval))
+    (hz : z ∈ Cube.boundary (Fin n)) : quotient n z = point n := by
+  change
+    compactification n (SixSphereCube.collapse (Cube.boundary (Fin n)) z) =
+      compactification n (OnePoint.infty)
+  rw [SixSphereCube.collapse_of_mem _ hz]
+
+private theorem Degree.SphereCube.zero_boundary {n : ℕ} (hn : 0 < n) :
+    (0 : Fin n → (unitInterval)) ∈ Cube.boundary (Fin n) :=
+  ⟨⟨0, hn⟩, Or.inl rfl⟩
+
+private theorem Degree.SphereCube.quotient_surjective {n : ℕ} (hn : 0 < n) :
+    Function.Surjective (quotient n) :=
+  (compactification n).surjective.comp
+    (SixSphereCube.collapse_surjective (Cube.boundary (Fin n)) ⟨0, zero_boundary hn⟩)
+
+private theorem Degree.SphereCube.quotient_eq_iff (n : ℕ) (z w : Fin n → (unitInterval)) :
+    quotient n z = quotient n w ↔ z = w ∨ z ∈ Cube.boundary (Fin n) ∧ w ∈ Cube.boundary (Fin n) :=
+  by
+  change
+    compactification n (SixSphereCube.collapse (Cube.boundary (Fin n)) z) =
+        compactification n (SixSphereCube.collapse (Cube.boundary (Fin n)) w) ↔
+      _
+  rw [(compactification n).injective.eq_iff, SixSphereCube.collapse_eq_iff]
+
+private def Degree.SphereCube.cylinder (n : ℕ) :
+    C((unitInterval) × (Fin n → (unitInterval)), (unitInterval) × Sphere n) :=
+  (ContinuousMap.id (unitInterval)).prodMap (quotient n)
+
+private theorem Degree.SphereCube.cylinder_surjective {n : ℕ} (hn : 0 < n) :
+    Function.Surjective (cylinder n) := by
+  rintro ⟨t, z⟩
+  obtain ⟨w, rfl⟩ := quotient_surjective hn z
+  exact ⟨(t, w), rfl⟩
+
+private theorem Degree.SphereCube.cylinder_isQuotientMap {n : ℕ} (hn : 0 < n) :
+    Topology.IsQuotientMap (cylinder n) :=
+  .of_surjective_continuous (cylinder_surjective hn) (cylinder n).continuous
+
+private def
+    Degree.SphereCube.basedCube {n : ℕ} {X : Type*} [TopologicalSpace X] (u : C(Sphere n, X)) :
+    GenLoop (Fin n) X (u (point n)) :=
+  ⟨u.comp (quotient n), fun z hz => congrArg u (quotient_boundary n z hz)⟩
+
+private theorem Degree.SphereCube.homotopicRel_const_of_subsingleton {n : ℕ} {X : Type*}
+    [TopologicalSpace X] (hn : 0 < n) (u : C(Sphere n, X)) [Subsingleton (π_ n X (u (point n)))] :
+    u.HomotopicRel (ContinuousMap.const (Sphere n) (u (point n))) {point n} := by
+  let H := HigherHurewicz.nativeCubeNullHomotopy (basedCube u)
+  have hfib : ∀ a b, cylinder n a = cylinder n b → H a = H b := by
+    rintro ⟨t, z⟩ ⟨s, w⟩ h
+    have ht : t = s := congrArg Prod.fst h
+    subst s
+    have hzw : quotient n z = quotient n w := congrArg Prod.snd h
+    rcases (quotient_eq_iff n z w).mp hzw with rfl | ⟨hz, hw⟩
+    · rfl
+    · exact
+        ((H.eq_fst t hz).trans ((basedCube u).property z hz)).trans
+          ((H.eq_fst t hw).trans ((basedCube u).property w hw)).symm
+  let G := (cylinder_isQuotientMap hn).lift H.toHomotopy.toContinuousMap hfib
+  have hG (t : (unitInterval)) (z : Fin n → (unitInterval)) : G (t, quotient n z) = H (t, z) :=
+    ContinuousMap.congr_fun
+      ((cylinder_isQuotientMap hn).lift_comp H.toHomotopy.toContinuousMap hfib) (t, z)
+  refine
+    ⟨{  toContinuousMap := G
+        map_zero_left := ?_
+        map_one_left := ?_
+        prop' := ?_ }⟩
+  · intro z
+    obtain ⟨w, rfl⟩ := quotient_surjective hn z
+    exact (hG 0 w).trans (H.apply_zero w)
+  · intro z
+    obtain ⟨w, rfl⟩ := quotient_surjective hn z
+    exact (hG 1 w).trans (H.apply_one w)
+  · intro t z hz
+    have hz' : z = point n := hz
+    subst z
+    change G (t, point n) = u (point n)
+    rw [← quotient_boundary n 0 (zero_boundary hn), hG]
+    exact H.eq_fst t (zero_boundary hn)
+
+private theorem Degree.Sphere.pi_subsingleton {n : ℕ} (hn : 0 < n) (hn6 : n < 6)
+    (x : SixSphereCube.StandardSphere) : Subsingleton (π_ n SixSphereCube.StandardSphere x) := by
+  have hn5 : n ≤ 5 := by omega
+  interval_cases n
+  · exact (HomotopyGroup.pi1EquivFundamentalGroup).injective.subsingleton
+  · exact piTwo_subsingleton x
+  · exact piThree_subsingleton x
+  · exact piFour_subsingleton x
+  · exact piFive_subsingleton x
+
+private theorem Degree.Sphere.homotopic_const_discrete {Z X : Type} [TopologicalSpace Z]
+    [DiscreteTopology Z] [TopologicalSpace X] [PathConnectedSpace X] (u : C(Z, X)) (x : X) :
+    u.Homotopic (ContinuousMap.const Z x) := by
+  refine
+    ⟨{  toFun := fun p => (PathConnectedSpace.somePath (u p.2) x) p.1
+        continuous_toFun :=
+          continuous_prod_of_discrete_right.mpr
+            (fun z => (PathConnectedSpace.somePath (u z) x).continuous)
+        map_zero_left := fun z => (PathConnectedSpace.somePath (u z) x).source
+        map_one_left := fun z => (PathConnectedSpace.somePath (u z) x).target }⟩
+
+private theorem Degree.Sphere.real_unitSphere_finite : (Metric.sphere (0 : ℝ) 1).Finite := by
+  apply (Set.toFinite ({1, -1} : Set ℝ)).subset
+  intro x hx
+  have h : |x| = |(1 : ℝ)| := by simpa using mem_sphere_zero_iff_norm.mp hx
+  rcases abs_eq_abs.mp h with h | h <;> simp [h]
+
+private theorem Degree.Sphere.homotopic_const_of_homeomorph {Z W X : Type} [TopologicalSpace Z]
+    [TopologicalSpace W] [TopologicalSpace X] (e : Z ≃ₜ W) (u : C(Z, X)) (x : X)
+    (h : (u.comp (e.symm : C(W, Z))).Homotopic (ContinuousMap.const W x)) :
+    u.Homotopic (ContinuousMap.const Z x) := by
+  have hh := h.comp (ContinuousMap.Homotopic.refl (e : C(Z, W)))
+  convert hh using 1
+  · apply ContinuousMap.ext
+    intro z
+    exact (congrArg u (e.symm_apply_apply z)).symm
+  · rfl
+
+private theorem Degree.Sphere.boundary_homotopic_const_of_pi {V : Type} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [FiniteDimensional ℝ V] {X : Type} [TopologicalSpace X]
+    [PathConnectedSpace X] {d : ℕ} (hpi : ∀ n, 0 < n → n < d → ∀ x : X, Subsingleton (π_ n X x))
+    (hd : Module.finrank ℝ V ≤ d) (u : C(Degree.DiskCylinder.Sphere (E := V), X)) (x : X) :
+    u.Homotopic (ContinuousMap.const _ x) := by
+  classical
+    cases subsingleton_or_nontrivial V with
+  | inl
+    h =>
+    have hempty (s : Degree.DiskCylinder.Sphere (E := V)) : False :=
+      Degree.UnitSphereEquiv.vector_ne_zero s (Subsingleton.elim _ _)
+    have he : u = ContinuousMap.const _ x := ContinuousMap.ext (fun s => (hempty s).elim)
+    rw [he]
+  | inr h =>
+    by_cases hd1 : Module.finrank ℝ V = 1
+    · obtain ⟨L⟩ :=
+        FiniteDimensional.nonempty_continuousLinearEquiv_of_finrank_eq
+          (show Module.finrank ℝ V = Module.finrank ℝ ℝ by simpa using hd1)
+      let e := Degree.UnitSphereEquiv.homeomorph L
+      let : Finite (Degree.DiskCylinder.Sphere (E := ℝ)) := real_unitSphere_finite.to_subtype
+      let : Finite (Degree.DiskCylinder.Sphere (E := V)) := Finite.of_injective e e.injective
+      exact homotopic_const_discrete u x
+    · have hdpos : 0 < Module.finrank ℝ V := Module.finrank_pos
+      let n := Module.finrank ℝ V - 1
+      have hn : 0 < n := by dsimp [n]; omega
+      have hnd : n < d := by dsimp [n]; omega
+      obtain ⟨L⟩ :=
+        FiniteDimensional.nonempty_continuousLinearEquiv_of_finrank_eq
+          (show Module.finrank ℝ V = Module.finrank ℝ (EuclideanSpace ℝ (Fin (n + 1)))
+            by
+            simp only [finrank_euclideanSpace, Fintype.card_fin]
+            dsimp [n]
+            omega)
+      let e := Degree.UnitSphereEquiv.homeomorph L
+      let v : C(Degree.SphereCube.Sphere n, X) := u.comp (e.symm : C(_, _))
+      let := hpi n hn hnd (v (Degree.SphereCube.point n))
+      obtain ⟨H⟩ := Degree.SphereCube.homotopicRel_const_of_subsingleton hn v
+      have hstart : v.Homotopic (ContinuousMap.const _ (v (Degree.SphereCube.point n))) :=
+        ⟨H.toHomotopy⟩
+      have hv : v.Homotopic (ContinuousMap.const _ x) :=
+        hstart.trans
+          ⟨(PathConnectedSpace.somePath (v (Degree.SphereCube.point n)) x).toHomotopyConst⟩
+      exact homotopic_const_of_homeomorph e u x hv
+
+private theorem Degree.Sphere.exists_boundary_extension_of_pi {V : Type} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [FiniteDimensional ℝ V] {X : Type} [TopologicalSpace X]
+    [PathConnectedSpace X] {d : ℕ} (hpi : ∀ n, 0 < n → n < d → ∀ x : X, Subsingleton (π_ n X x))
+    (hd : Module.finrank ℝ V ≤ d) (u : C(Degree.DiskCylinder.Sphere (E := V), X)) (x : X) :
+    ∃ v : C(Degree.DiskCylinder.Disk (E := V), X),
+      (∀ s, v (Degree.DiskCylinder.boundaryToDisk s) = u s) ∧ v ⟨0, by simp⟩ = x := by
+  classical
+    cases isEmpty_or_nonempty (Degree.DiskCylinder.Sphere (E := V)) with
+  | inl h => exact ⟨ContinuousMap.const _ x, fun s => isEmptyElim s, rfl⟩
+  | inr h =>
+    let s0 : Degree.DiskCylinder.Sphere (E := V) := Classical.choice h
+    obtain ⟨H⟩ := (boundary_homotopic_const_of_pi hpi hd u x).symm
+    let G := H.toContinuousMap
+    have h0 : ∀ s, G (0, s) = x := H.map_zero_left
+    refine ⟨Degree.DiskCone.extension s0 G x h0, ?_, Degree.DiskCone.extension_center s0 G x h0⟩
+    intro s
+    exact (Degree.DiskCone.extension_boundary s0 G x h0 s).trans (H.map_one_left s)
+
+private theorem
+    Degree.Sphere.boundary_homotopic_const {V : Type} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    [FiniteDimensional ℝ V] (hd : Module.finrank ℝ V ≤ 6)
+    (u : C(Degree.DiskCylinder.Sphere (E := V), SixSphereCube.StandardSphere))
+    (x : SixSphereCube.StandardSphere) : u.Homotopic (ContinuousMap.const _ x) :=
+  boundary_homotopic_const_of_pi (fun _ hn hn6 => pi_subsingleton hn hn6) hd u x
+
+private theorem Degree.Sphere.exists_boundary_extension {V : Type} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [FiniteDimensional ℝ V] (hd : Module.finrank ℝ V ≤ 6)
+    (u : C(Degree.DiskCylinder.Sphere (E := V), SixSphereCube.StandardSphere))
+    (x : SixSphereCube.StandardSphere) :
+    ∃ v : C(Degree.DiskCylinder.Disk (E := V), SixSphereCube.StandardSphere),
+      (∀ s, v (Degree.DiskCylinder.boundaryToDisk s) = u s) ∧ v ⟨0, by simp⟩ = x :=
+  exists_boundary_extension_of_pi (fun _ hn hn6 => pi_subsingleton hn hn6) hd u x
+
+private theorem Degree.CylinderFilling.exists_filling {V X : Type} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [FiniteDimensional ℝ V] [TopologicalSpace X] [PathConnectedSpace X] {d : ℕ}
+    (hpi : ∀ n, 0 < n → n < d → ∀ x : X, Subsingleton (π_ n X x))
+    (hd : Module.finrank ℝ V + 1 ≤ d) (f g : C(Degree.DiskCylinder.Disk (E := V), X))
+    (H : C((unitInterval) × Degree.DiskCylinder.Sphere (E := V), X))
+    (h0 : ∀ s, H (0, s) = f (Degree.DiskCylinder.boundaryToDisk s))
+    (h1 : ∀ s, H (1, s) = g (Degree.DiskCylinder.boundaryToDisk s)) (x : X) :
+    ∃ G : C((unitInterval) × Degree.DiskCylinder.Disk (E := V), X),
+      (∀ z, G (0, z) = f z) ∧
+        (∀ z, G (1, z) = g z) ∧ ∀ t s, G (t, Degree.DiskCylinder.boundaryToDisk s) = H (t, s) := by
+  let b := Degree.CylinderBoundary.glued f g H h0 h1
+  let e := Degree.CylinderBall.boundaryHomeomorph (V := V)
+  let u :=
+    b.comp
+      (e.symm : C(Degree.DiskCylinder.Sphere (E := ℝ × V), Degree.CylinderBall.boundary (V := V)))
+  have hdim : Module.finrank ℝ (ℝ × V) ≤ d := by
+    simpa only [Module.finrank_prod, Module.finrank_self, Nat.add_comm] using hd
+  obtain ⟨v, hv, _⟩ := Degree.Sphere.exists_boundary_extension_of_pi hpi hdim u x
+  let G : C((unitInterval) × Degree.DiskCylinder.Disk (E := V), X) :=
+    v.comp (Degree.CylinderBall.homeomorph (V := V) : C(_, _))
+  have hb (p : Degree.CylinderBall.boundary (V := V)) : G p.val = b p := by
+    change v (Degree.DiskCylinder.boundaryToDisk (Degree.CylinderBall.boundaryHomeomorph p)) = b p
+    exact
+      (hv (Degree.CylinderBall.boundaryHomeomorph p)).trans
+        (congrArg b (Degree.CylinderBall.boundaryHomeomorph.symm_apply_apply p))
+  refine ⟨G, ?_, ?_, ?_⟩
+  · intro z
+    exact
+      (hb (Degree.CylinderBoundary.lower (Degree.DiskCylinder.bottomMap z))).trans
+        (Degree.CylinderBoundary.glued_bottom f g H h0 h1 z)
+  · intro z
+    exact
+      (hb (Degree.CylinderBoundary.top z)).trans (Degree.CylinderBoundary.glued_top f g H h0 h1 z)
+  · intro t s
+    exact
+      (hb (Degree.CylinderBoundary.lower (Degree.DiskCylinder.sideMap (t, s)))).trans
+        (Degree.CylinderBoundary.glued_side f g H h0 h1 t s)
+
+private abbrev
+    Degree.Attachment.Union {K M : Type*} [TopologicalSpace K] [TopologicalSpace M] (A : Set M)
+    (h : C(K, M)) :=
+  ↥(A ∪ Set.range h)
+
+private def Degree.Attachment.sumQuotient {K M : Type*} [TopologicalSpace K] [TopologicalSpace M]
+    (A : Set M) (h : C(K, M)) : C(A ⊕ K, Degree.Attachment.Union A h) :=
+  ⟨Smale.ClosedAttachment.sumMap A h, Smale.ClosedAttachment.continuous_sumMap A h⟩
+
+private theorem Degree.Attachment.sumQuotient_surjective {K M : Type*} [TopologicalSpace K]
+    [TopologicalSpace M] (A : Set M) (h : C(K, M)) : Function.Surjective (sumQuotient A h) := by
+  rintro ⟨x, hx | ⟨k, rfl⟩⟩
+  · exact ⟨.inl ⟨x, hx⟩, rfl⟩
+  · exact ⟨.inr k, rfl⟩
+
+private def
+    Degree.Attachment.cylinderQuotient {K M : Type*} [TopologicalSpace K] [TopologicalSpace M]
+    (A : Set M) (h : C(K, M)) :
+    C((unitInterval) × (A ⊕ K), (unitInterval) × Degree.Attachment.Union A h) :=
+  (ContinuousMap.id (unitInterval)).prodMap (sumQuotient A h)
+
+private theorem Degree.Attachment.cylinderQuotient_surjective {K M : Type*} [TopologicalSpace K]
+    [TopologicalSpace M] (A : Set M) (h : C(K, M)) : Function.Surjective (cylinderQuotient A h) :=
+  by
+  rintro ⟨t, x⟩
+  obtain ⟨z, rfl⟩ := sumQuotient_surjective A h x
+  exact ⟨(t, z), rfl⟩
+
+private theorem Degree.Attachment.cylinderQuotient_isQuotientMap {K M : Type*} [TopologicalSpace K]
+    [CompactSpace K] [TopologicalSpace M] [T2Space M] (A : Set M) [CompactSpace A] (h : C(K, M)) :
+    Topology.IsQuotientMap (cylinderQuotient A h) :=
+  .of_surjective_continuous (cylinderQuotient_surjective A h) (cylinderQuotient A h).continuous
+
+private def Degree.Attachment.familyOnSum {K M : Type*} [TopologicalSpace K] [TopologicalSpace M]
+    (A : Set M) (B : Set K) (h : C(K, M)) {r : C(K, K)}
+    (H : (ContinuousMap.id K).HomotopyRel r B) :
+    C((unitInterval) × (A ⊕ K), Degree.Attachment.Union A h)
+    where
+  toFun
+    p :=
+    match p.2 with
+    | .inl a => ⟨a.val, Or.inl a.property⟩
+    | .inr k => ⟨h (H (p.1, k)), Or.inr ⟨H (p.1, k), rfl⟩⟩
+  continuous_toFun := by
+    have ha :
+      Continuous
+        (fun p : (unitInterval) × A =>
+          (⟨p.2.val, Or.inl p.2.property⟩ : Degree.Attachment.Union A h)) :=
+      (continuous_subtype_val.comp continuous_snd).subtype_mk _
+    have hk :
+      Continuous
+        (fun p : (unitInterval) × K =>
+          (⟨h (H p), Or.inr ⟨H p, rfl⟩⟩ : Degree.Attachment.Union A h)) :=
+      (h.continuous.comp H.continuous).subtype_mk _
+    convert
+      (ha.sumElim hk).comp
+        (Homeomorph.prodSumDistrib : (unitInterval) × (A ⊕ K) ≃ₜ _).continuous using
+      1
+    funext p
+    rcases p with ⟨t, a | k⟩ <;> rfl
+
+private theorem Degree.Attachment.familyOnSum_constant_on_fibres {K M : Type*} [TopologicalSpace K]
+    [TopologicalSpace M] (A : Set M) (B : Set K) (h : C(K, M)) {r : C(K, K)}
+    (H : (ContinuousMap.id K).HomotopyRel r B) (hinj : Function.Injective h)
+    (hface : ∀ k, h k ∈ A ↔ k ∈ B) (p q : (unitInterval) × (A ⊕ K))
+    (heq : cylinderQuotient A h p = cylinderQuotient A h q) :
+    familyOnSum A B h H p = familyOnSum A B h H q := by
+  rcases p with ⟨t, a⟩
+  rcases q with ⟨s, b⟩
+  have ht : t = s := congrArg Prod.fst heq
+  subst s
+  have hab : sumQuotient A h a = sumQuotient A h b := congrArg Prod.snd heq
+  have hv := congrArg Subtype.val hab
+  cases a with
+  | inl a =>
+    cases b with
+    | inl b => exact Subtype.ext hv
+    | inr k =>
+      change a.val = h k at hv
+      have hk : k ∈ B := (hface k).mp (hv ▸ a.property)
+      apply Subtype.ext
+      change a.val = h (H (t, k))
+      rw [H.eq_fst t hk]
+      exact hv
+  | inr k =>
+    cases b with
+    | inl b =>
+      change h k = b.val at hv
+      have hk : k ∈ B := (hface k).mp (hv.symm ▸ b.property)
+      apply Subtype.ext
+      change h (H (t, k)) = b.val
+      rw [H.eq_fst t hk]
+      exact hv
+    | inr l =>
+      have hkl : k = l := hinj hv
+      subst l
+      rfl
+
+private def Degree.Attachment.unionFamily {K M : Type*} [TopologicalSpace K] [CompactSpace K]
+    [TopologicalSpace M] [T2Space M] (A : Set M) [CompactSpace A] (B : Set K) (h : C(K, M))
+    {r : C(K, K)} (H : (ContinuousMap.id K).HomotopyRel r B) (hinj : Function.Injective h)
+    (hface : ∀ k, h k ∈ A ↔ k ∈ B) :
+    C((unitInterval) × Degree.Attachment.Union A h, Degree.Attachment.Union A h) :=
+  (cylinderQuotient_isQuotientMap A h).lift (familyOnSum A B h H)
+    (familyOnSum_constant_on_fibres A B h H hinj hface)
+
+@[simp]
+private theorem
+    Degree.Attachment.unionFamily_apply {K M : Type*} [TopologicalSpace K] [CompactSpace K]
+    [TopologicalSpace M] [T2Space M] (A : Set M) [CompactSpace A] (B : Set K) (h : C(K, M))
+    {r : C(K, K)} (H : (ContinuousMap.id K).HomotopyRel r B) (hinj : Function.Injective h)
+    (hface : ∀ k, h k ∈ A ↔ k ∈ B) (t : (unitInterval)) (z : A ⊕ K) :
+    unionFamily A B h H hinj hface (t, sumQuotient A h z) = familyOnSum A B h H (t, z) :=
+  ContinuousMap.congr_fun
+    ((cylinderQuotient_isQuotientMap A h).lift_comp (familyOnSum A B h H)
+      (familyOnSum_constant_on_fibres A B h H hinj hface))
+    (t, z)
+
+private theorem Degree.Attachment.unionFamily_fixed_lower {K M : Type*} [TopologicalSpace K]
+    [CompactSpace K] [TopologicalSpace M] [T2Space M] (A : Set M) [CompactSpace A] (B : Set K)
+    (h : C(K, M)) {r : C(K, K)} (H : (ContinuousMap.id K).HomotopyRel r B)
+    (hinj : Function.Injective h) (hface : ∀ k, h k ∈ A ↔ k ∈ B) (t : (unitInterval)) (a : A) :
+    unionFamily A B h H hinj hface (t, ⟨a.val, Or.inl a.property⟩) = ⟨a.val, Or.inl a.property⟩ :=
+  unionFamily_apply A B h H hinj hface t (.inl a)
+
+private theorem Degree.Attachment.unionFamily_on_handle {K M : Type*} [TopologicalSpace K]
+    [CompactSpace K] [TopologicalSpace M] [T2Space M] (A : Set M) [CompactSpace A] (B : Set K)
+    (h : C(K, M)) {r : C(K, K)} (H : (ContinuousMap.id K).HomotopyRel r B)
+    (hinj : Function.Injective h) (hface : ∀ k, h k ∈ A ↔ k ∈ B) (t : (unitInterval)) (k : K) :
+    (unionFamily A B h H hinj hface (t, ⟨h k, Or.inr ⟨k, rfl⟩⟩)).val = h (H (t, k)) :=
+  congrArg Subtype.val (unionFamily_apply A B h H hinj hface t (.inr k))
+
+private theorem
+    Degree.Attachment.unionFamily_zero {K M : Type*} [TopologicalSpace K] [CompactSpace K]
+    [TopologicalSpace M] [T2Space M] (A : Set M) [CompactSpace A] (B : Set K) (h : C(K, M))
+    {r : C(K, K)} (H : (ContinuousMap.id K).HomotopyRel r B) (hinj : Function.Injective h)
+    (hface : ∀ k, h k ∈ A ↔ k ∈ B) (x : Degree.Attachment.Union A h) :
+    unionFamily A B h H hinj hface (0, x) = x := by
+  obtain ⟨z, rfl⟩ := sumQuotient_surjective A h x
+  rw [unionFamily_apply]
+  cases z with
+  | inl a => rfl
+  | inr k =>
+    apply Subtype.ext
+    exact congrArg h (H.apply_zero k)
+
+private def Degree.Handle.interpolate {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (t : (unitInterval)) (z : Space (N := N) (P := P)) :
+    Space (N := N) (P := P) :=
+  (⟨(1 - (t : ℝ)) • (z.1 : N) + (t : ℝ) • ((retraction z).1 : N),
+      (convex_closedBall (0 : N) 1 : Convex ℝ _) z.1.property (retraction z).1.property
+        (sub_nonneg.mpr t.property.2) t.property.1 (by ring)⟩,
+    ⟨(1 - (t : ℝ)) • (z.2 : P) + (t : ℝ) • ((retraction z).2 : P),
+      (convex_closedBall (0 : P) 1 : Convex ℝ _) z.2.property (retraction z).2.property
+        (sub_nonneg.mpr t.property.2) t.property.1 (by ring)⟩)
+
+private theorem Degree.Handle.continuous_interpolate {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] :
+    Continuous (fun tz : (unitInterval) × Space (N := N) (P := P) => interpolate tz.1 tz.2) := by
+  have ht : Continuous (fun tz : (unitInterval) × Space (N := N) (P := P) => (tz.1 : ℝ)) :=
+    continuous_subtype_val.comp continuous_fst
+  have hu : Continuous (fun tz : (unitInterval) × Space (N := N) (P := P) => (tz.2.1 : N)) :=
+    continuous_subtype_val.comp (continuous_fst.comp continuous_snd)
+  have hv : Continuous (fun tz : (unitInterval) × Space (N := N) (P := P) => (tz.2.2 : P)) :=
+    continuous_subtype_val.comp (continuous_snd.comp continuous_snd)
+  have hr : Continuous (fun tz : (unitInterval) × Space (N := N) (P := P) => retraction tz.2) :=
+    retraction.continuous.comp continuous_snd
+  exact
+    (((continuous_const.sub ht).smul hu).add
+            (ht.smul (continuous_subtype_val.comp (continuous_fst.comp hr)))).subtype_mk
+        _ |>.prodMk
+      ((((continuous_const.sub ht).smul hv).add
+            (ht.smul (continuous_subtype_val.comp (continuous_snd.comp hr)))).subtype_mk
+        _)
+
+@[simp]
+private theorem
+    Degree.Handle.interpolate_zero {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (z : Space (N := N) (P := P)) :
+    interpolate 0 z = z := by apply Prod.ext <;> apply Subtype.ext <;> simp [interpolate]
+
+@[simp]
+private theorem Degree.Handle.interpolate_one {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (z : Space (N := N) (P := P)) :
+    interpolate 1 z = retraction z := by
+  apply Prod.ext <;> apply Subtype.ext <;> simp [interpolate]
+
+private theorem
+    Degree.Handle.interpolate_fixed {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (t : (unitInterval)) (z : Space (N := N) (P := P))
+    (hz : z ∈ faceCore) : interpolate t z = z := by
+  have hr := retraction_eq_self z hz
+  apply Prod.ext <;> apply Subtype.ext <;> simp [interpolate, hr, ← add_smul]
+
+private def Degree.Handle.deformation {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] :
+    (ContinuousMap.id (Space (N := N) (P := P))).HomotopyRel retraction faceCore
+    where
+  toFun tz := interpolate tz.1 tz.2
+  continuous_toFun := continuous_interpolate
+  map_zero_left := interpolate_zero
+  map_one_left := interpolate_one
+  prop' := interpolate_fixed
+
+private abbrev
+    Degree.CoreAttachment.Core {N P : Type*} [NormedAddCommGroup N] [NormedAddCommGroup P] :
+    Set (Degree.Handle.Space (N := N) (P := P)) :=
+  {z | (z.2 : P) = 0}
+
+private abbrev
+    Degree.CoreAttachment.Face {N P : Type*} [NormedAddCommGroup N] [NormedAddCommGroup P] :
+    Set (Degree.Handle.Space (N := N) (P := P)) :=
+  {z | ‖(z.1 : N)‖ = 1}
+
+private def
+    Degree.CoreAttachment.faceDeformation {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] :
+    (ContinuousMap.id (Degree.Handle.Space (N := N) (P := P))).HomotopyRel
+      Degree.Handle.retraction Face
+    where
+  __ := Degree.Handle.deformation.toHomotopy
+  prop' t z hz := Degree.Handle.interpolate_fixed t z (Or.inl hz)
+
+private abbrev Degree.CoreAttachment.CoreUnion {N P M : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace M] (A : Set M)
+    (h : C(Degree.Handle.Space (N := N) (P := P), M)) :=
+  ↥(A ∪ h '' Core)
+
+private def Degree.CoreAttachment.family {N P M : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] [FiniteDimensional ℝ N] [FiniteDimensional ℝ P]
+    [TopologicalSpace M] [T2Space M] (A : Set M) [CompactSpace A]
+    (h : C(Degree.Handle.Space (N := N) (P := P), M)) (hinj : Function.Injective h)
+    (hface : ∀ z, h z ∈ A ↔ z ∈ Face) :
+    C((unitInterval) × Degree.Attachment.Union A h, Degree.Attachment.Union A h) :=
+  Degree.Attachment.unionFamily A Face h faceDeformation hinj hface
+
+private theorem
+    Degree.CoreAttachment.family_zero {N P M : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] [FiniteDimensional ℝ N] [FiniteDimensional ℝ P]
+    [TopologicalSpace M] [T2Space M] (A : Set M) [CompactSpace A]
+    (h : C(Degree.Handle.Space (N := N) (P := P), M)) (hinj : Function.Injective h)
+    (hface : ∀ z, h z ∈ A ↔ z ∈ Face) (x : Degree.Attachment.Union A h) :
+    family A h hinj hface (0, x) = x :=
+  Degree.Attachment.unionFamily_zero A Face h faceDeformation hinj hface x
+
+private theorem Degree.CoreAttachment.family_fixed_lower {N P M : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] [FiniteDimensional ℝ N]
+    [FiniteDimensional ℝ P] [TopologicalSpace M] [T2Space M] (A : Set M) [CompactSpace A]
+    (h : C(Degree.Handle.Space (N := N) (P := P), M)) (hinj : Function.Injective h)
+    (hface : ∀ z, h z ∈ A ↔ z ∈ Face) (t : (unitInterval)) (a : A) :
+    family A h hinj hface (t, ⟨a.val, Or.inl a.property⟩) = ⟨a.val, Or.inl a.property⟩ :=
+  Degree.Attachment.unionFamily_fixed_lower A Face h faceDeformation hinj hface t a
+
+private theorem Degree.CoreAttachment.family_on_handle {N P M : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] [FiniteDimensional ℝ N]
+    [FiniteDimensional ℝ P] [TopologicalSpace M] [T2Space M] (A : Set M) [CompactSpace A]
+    (h : C(Degree.Handle.Space (N := N) (P := P), M)) (hinj : Function.Injective h)
+    (hface : ∀ z, h z ∈ A ↔ z ∈ Face) (t : (unitInterval))
+    (z : Degree.Handle.Space (N := N) (P := P)) :
+    (family A h hinj hface (t, ⟨h z, Or.inr ⟨z, rfl⟩⟩)).val = h (Degree.Handle.interpolate t z) :=
+  Degree.Attachment.unionFamily_on_handle A Face h faceDeformation hinj hface t z
+
+private theorem
+    Degree.CoreAttachment.family_one_mem_coreUnion {N P M : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] [FiniteDimensional ℝ N]
+    [FiniteDimensional ℝ P] [TopologicalSpace M] [T2Space M] (A : Set M) [CompactSpace A]
+    (h : C(Degree.Handle.Space (N := N) (P := P), M)) (hinj : Function.Injective h)
+    (hface : ∀ z, h z ∈ A ↔ z ∈ Face) (x : Degree.Attachment.Union A h) :
+    (family A h hinj hface (1, x)).val ∈ A ∪ h '' Core := by
+  rcases x with ⟨x, hx | ⟨z, rfl⟩⟩
+  · have he := family_fixed_lower A h hinj hface 1 ⟨x, hx⟩
+    exact Or.inl (congrArg Subtype.val he ▸ hx)
+  · rw [family_on_handle, Degree.Handle.interpolate_one]
+    rcases Degree.Handle.retraction_mem_faceCore z with hz | hz
+    · exact Or.inl ((hface (Degree.Handle.retraction z)).mpr hz)
+    · exact Or.inr ⟨Degree.Handle.retraction z, hz, rfl⟩
+
+private def
+    Degree.CoreAttachment.inclusion {N P M : Type*} [NormedAddCommGroup N] [NormedAddCommGroup P]
+    [TopologicalSpace M] (A : Set M) (h : C(Degree.Handle.Space (N := N) (P := P), M)) :
+    C(CoreUnion A h, Degree.Attachment.Union A h) :=
+  ⟨fun x =>
+    ⟨x.val,
+      x.property.elim Or.inl (fun hx => Or.inr (by obtain ⟨z, _, hz⟩ := hx; exact ⟨z, hz⟩))⟩,
+    continuous_subtype_val.subtype_mk _⟩
+
+private def Degree.CoreAttachment.reduce {N P M : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] [FiniteDimensional ℝ N] [FiniteDimensional ℝ P]
+    [TopologicalSpace M] [T2Space M] (A : Set M) [CompactSpace A]
+    (h : C(Degree.Handle.Space (N := N) (P := P), M)) (hinj : Function.Injective h)
+    (hface : ∀ z, h z ∈ A ↔ z ∈ Face) : C(Degree.Attachment.Union A h, CoreUnion A h) :=
+  ⟨fun x => ⟨(family A h hinj hface (1, x)).val, family_one_mem_coreUnion A h hinj hface x⟩,
+    ((continuous_subtype_val.comp (family A h hinj hface).continuous).comp
+          (continuous_const.prodMk continuous_id)).subtype_mk
+      _⟩
+
+private theorem Degree.CoreAttachment.family_fixed_coreUnion {N P M : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] [FiniteDimensional ℝ N]
+    [FiniteDimensional ℝ P] [TopologicalSpace M] [T2Space M] (A : Set M) [CompactSpace A]
+    (h : C(Degree.Handle.Space (N := N) (P := P), M)) (hinj : Function.Injective h)
+    (hface : ∀ z, h z ∈ A ↔ z ∈ Face) (t : (unitInterval)) (x : CoreUnion A h) :
+    family A h hinj hface (t, Degree.CoreAttachment.inclusion A h x) =
+      Degree.CoreAttachment.inclusion A h x := by
+  rcases x with ⟨x, hx | ⟨z, hz, rfl⟩⟩
+  · exact family_fixed_lower A h hinj hface t ⟨x, hx⟩
+  · apply Subtype.ext
+    change (family A h hinj hface (t, ⟨h z, Or.inr ⟨z, rfl⟩⟩)).val = h z
+    rw [family_on_handle, Degree.Handle.interpolate_fixed t z (Or.inr hz)]
+
+private def Degree.CoreAttachment.coreUnionHomotopyEquiv {N P M : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] [FiniteDimensional ℝ N]
+    [FiniteDimensional ℝ P] [TopologicalSpace M] [T2Space M] (A : Set M) [CompactSpace A]
+    (h : C(Degree.Handle.Space (N := N) (P := P), M)) (hinj : Function.Injective h)
+    (hface : ∀ z, h z ∈ A ↔ z ∈ Face) : CoreUnion A h ≃ₕ Degree.Attachment.Union A h
+    where
+  toFun := Degree.CoreAttachment.inclusion A h
+  invFun := reduce A h hinj hface
+  left_inv := by
+    have he :
+      (reduce A h hinj hface).comp (Degree.CoreAttachment.inclusion A h) =
+        ContinuousMap.id (CoreUnion A h) := by
+      apply ContinuousMap.ext
+      intro x
+      apply Subtype.ext
+      change (family A h hinj hface (1, Degree.CoreAttachment.inclusion A h x)).val = x.val
+      exact congrArg Subtype.val (family_fixed_coreUnion A h hinj hface 1 x)
+    rw [he]
+  right_inv := by
+    let H :
+      (ContinuousMap.id (Degree.Attachment.Union A h)).Homotopy
+        ((Degree.CoreAttachment.inclusion A h).comp (reduce A h hinj hface)) :=
+      { toContinuousMap := family A h hinj hface
+        map_zero_left := family_zero A h hinj hface
+        map_one_left := fun _ => rfl }
+    exact ⟨H.symm⟩
+
+private theorem
+    Degree.MorseCells.core_dimension_le {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) :
+    Module.finrank ℝ c.NegativeCoordinates ≤ Module.finrank ℝ E := by
+  classical
+  change Module.finrank ℝ (EuclideanSpace ℝ (Smale.MorseHandle.Negative c.weights)) ≤ _
+  rw [finrank_euclideanSpace]
+  exact (Fintype.card_subtype_le (fun i => c.weights i = -1)).trans_eq (Fintype.card_fin _)
+
+private def Degree.MorseCells.coreCellMap {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target) :
+    C(Smale.MorseHandle.UnitDisk c.NegativeCoordinates, M) :=
+  (c.attachingHandleMap ρ hρ hblock).comp
+    ⟨fun u => (u, ⟨0, by simp⟩), continuous_id.prodMk continuous_const⟩
+
+private theorem Degree.MorseCells.coreCellMap_injective {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target) :
+    Function.Injective (coreCellMap c ρ hρ hblock) := by
+  intro u v h
+  exact congrArg Prod.fst (c.attachingHandleMap_injective ρ hρ hblock h)
+
+private theorem Degree.MorseCells.coreCellMap_lower_iff {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (u : Smale.MorseHandle.UnitDisk c.NegativeCoordinates) :
+    f (coreCellMap c ρ hρ hblock u) ≤ f p - ρ ^ 2 ↔ ‖(u : c.NegativeCoordinates)‖ = 1 :=
+  c.attachingHandleMap_lower_iff ρ hρ hblock (u, ⟨0, by simp⟩)
+
+private theorem Degree.MorseCells.image_core {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target) :
+    (c.attachingHandleMap ρ hρ hblock) '' Degree.CoreAttachment.Core =
+      Set.range (coreCellMap c ρ hρ hblock) := by
+  ext x
+  constructor
+  · rintro ⟨z, hz, rfl⟩
+    refine ⟨z.1, ?_⟩
+    apply congrArg (c.attachingHandleMap ρ hρ hblock)
+    exact Prod.ext rfl (Subtype.ext hz.symm)
+  · rintro ⟨u, rfl⟩
+    exact ⟨(u, ⟨0, by simp⟩), rfl, rfl⟩
+
+private def Degree.MorseCells.cellHandleHomotopyEquiv {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    [T2Space M] [CompactSpace M] (hf : Continuous f) :
+    Smale.ClosedAttachment.Space {x : M | f x ≤ f p - ρ ^ 2}
+        {u : Smale.MorseHandle.UnitDisk c.NegativeCoordinates | ‖(u : c.NegativeCoordinates)‖ = 1}
+        (coreCellMap c ρ hρ hblock) ≃ₕ
+      Smale.ClosedAttachment.Space {x : M | f x ≤ f p - ρ ^ 2}
+        {z | ‖(z.1 : c.NegativeCoordinates)‖ = 1} (c.attachingHandleMap ρ hρ hblock) := by
+  let A := {x : M | f x ≤ f p - ρ ^ 2}
+  have hA : IsCompact A := (isClosed_le hf continuous_const).isCompact
+  letI : CompactSpace A := isCompact_iff_compactSpace.mp hA
+  let cell :=
+    Smale.ClosedAttachment.unionHomeomorph A _ (coreCellMap c ρ hρ hblock) hA
+      (coreCellMap_injective c ρ hρ hblock) (coreCellMap_lower_iff c ρ hρ hblock)
+  let core :=
+    Degree.CoreAttachment.coreUnionHomotopyEquiv A (c.attachingHandleMap ρ hρ hblock)
+      (c.attachingHandleMap_injective ρ hρ hblock) (c.attachingHandleMap_lower_iff ρ hρ hblock)
+  let mark := Homeomorph.setCongr (congrArg (fun S : Set M => A ∪ S) (image_core c ρ hρ hblock))
+  exact
+    cell.toHomotopyEquiv.trans
+      (mark.symm.toHomotopyEquiv.trans
+        (core.trans (c.attachingHandleUnionHomeomorph hf ρ hρ hblock).symm.toHomotopyEquiv))
+
+private inductive Degree.FiniteCells.Built (d : ℕ) : (X : Type) → [TopologicalSpace X] → Prop
+  | empty (X : Type) [TopologicalSpace X] [IsEmpty X] : Built d X
+  |
+  equiv {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y] (e : X ≃ₕ Y) (h : Built d X) :
+    Built d Y
+  |
+  attach {V M : Type} [NormedAddCommGroup V] [NormedSpace ℝ V] [FiniteDimensional ℝ V]
+    [TopologicalSpace M] (A : Set M) (h : C(Smale.MorseHandle.UnitDisk V, M))
+    (hboundary : ∀ u : Smale.MorseHandle.UnitDisk V, ‖(u : V)‖ = 1 → h u ∈ A)
+    (hdim : Module.finrank ℝ V ≤ d) (hA : Built d A) :
+    Built d (Smale.ClosedAttachment.Space A {u : Smale.MorseHandle.UnitDisk V | ‖(u : V)‖ = 1} h)
+
+private def
+    Degree.AttachmentMaps.oldInclusion {K M : Type*} [TopologicalSpace K] [TopologicalSpace M]
+    (A : Set M) (B : Set K) (h : C(K, M)) : C(A, Smale.ClosedAttachment.Space A B h) :=
+  ⟨fun a => Quot.mk _ (.inl a), continuous_quot_mk.comp continuous_inl⟩
+
+private def
+    Degree.AttachmentMaps.cellInclusion {K M : Type*} [TopologicalSpace K] [TopologicalSpace M]
+    (A : Set M) (B : Set K) (h : C(K, M)) : C(K, Smale.ClosedAttachment.Space A B h) :=
+  ⟨fun k => Quot.mk _ (.inr k), continuous_quot_mk.comp continuous_inr⟩
+
+private theorem
+    Degree.AttachmentMaps.boundary_eq {K M : Type*} [TopologicalSpace K] [TopologicalSpace M]
+    (A : Set M) (B : Set K) (h : C(K, M)) (a : A) (k : K) (hk : k ∈ B) (ha : a.val = h k) :
+    oldInclusion A B h a = cellInclusion A B h k :=
+  Quot.sound ⟨hk, ha⟩
+
+private theorem Degree.AttachmentMaps.sum_respects {K M X : Type*} [TopologicalSpace K]
+    [TopologicalSpace M] [TopologicalSpace X] (A : Set M) (B : Set K) (h : C(K, M)) (f : C(A, X))
+    (g : C(K, X)) (hc : ∀ a k, k ∈ B → a.val = h k → f a = g k) (a b : A ⊕ K)
+    (hab : Smale.ClosedAttachment.Rel A B h a b) : Sum.elim f g a = Sum.elim f g b := by
+  cases a with
+  | inl a =>
+    cases b with
+    | inl b => exact hab.elim
+    | inr k => exact hc a k hab.1 hab.2
+  | inr k => cases b <;> exact hab.elim
+
+private def Degree.AttachmentMaps.glue {K M X : Type*} [TopologicalSpace K] [TopologicalSpace M]
+    [TopologicalSpace X] (A : Set M) (B : Set K) (h : C(K, M)) (f : C(A, X)) (g : C(K, X))
+    (hc : ∀ a k, k ∈ B → a.val = h k → f a = g k) : C(Smale.ClosedAttachment.Space A B h, X)
+    where
+  toFun := Quot.lift (Sum.elim f g) (sum_respects A B h f g hc)
+  continuous_toFun := continuous_quot_lift _ (continuous_sum_dom.mpr ⟨f.continuous, g.continuous⟩)
+
+private def Degree.AttachmentMaps.familyOld {M X : Type*} [TopologicalSpace M] [TopologicalSpace X]
+    (A : Set M) (F : C((unitInterval) × A, X)) (t : (unitInterval)) : C(A, X) :=
+  F.comp ⟨fun a => (t, a), continuous_const.prodMk continuous_id⟩
+
+private def Degree.AttachmentMaps.familyCell {K X : Type*} [TopologicalSpace K] [TopologicalSpace X]
+    (G : C((unitInterval) × K, X)) (t : (unitInterval)) : C(K, X) :=
+  G.comp ⟨fun k => (t, k), continuous_const.prodMk continuous_id⟩
+
+private def
+    Degree.AttachmentMaps.glueFamily {K M X : Type*} [TopologicalSpace K] [TopologicalSpace M]
+    [TopologicalSpace X] (A : Set M) (B : Set K) (h : C(K, M)) (F : C((unitInterval) × A, X))
+    (G : C((unitInterval) × K, X)) (hFG : ∀ t a k, k ∈ B → a.val = h k → F (t, a) = G (t, k)) :
+    C((unitInterval) × Smale.ClosedAttachment.Space A B h, X)
+    where
+  toFun p := glue A B h (familyOld A F p.1) (familyCell G p.1) (hFG p.1) p.2
+  continuous_toFun := by
+    apply isQuotientMap_quot_mk.continuous_lift_prod_right
+    have hc :
+      Continuous (fun p : ((unitInterval) × A) ⊕ ((unitInterval) × K) => Sum.elim F G p) :=
+      continuous_sum_dom.mpr ⟨F.continuous, G.continuous⟩
+    convert hc.comp (Homeomorph.prodSumDistrib : (unitInterval) × (A ⊕ K) ≃ₜ _).continuous using 1
+    funext p
+    rcases p with ⟨t, a | k⟩ <;> rfl
+
+private def
+    Degree.FiniteCells.RelativeDiskLifting {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (F : C(X, Y)) (d : ℕ) : Prop :=
+  ∀ (V : Type) [NormedAddCommGroup V] [NormedSpace ℝ V] [FiniteDimensional ℝ V],
+    Module.finrank ℝ V ≤ d →
+      ∀ (a : C(Degree.DiskCylinder.Sphere (E := V), X))
+        (u : C(Degree.DiskCylinder.Disk (E := V), Y))
+        (H : C((unitInterval) × Degree.DiskCylinder.Sphere (E := V), Y)),
+        (∀ s, H (0, s) = F (a s)) →
+          (∀ s, H (1, s) = u (Degree.DiskCylinder.boundaryToDisk s)) →
+            ∃ (v : C(Degree.DiskCylinder.Disk (E := V), X)) (G :
+              C((unitInterval) × Degree.DiskCylinder.Disk (E := V), Y)),
+              (∀ s, v (Degree.DiskCylinder.boundaryToDisk s) = a s) ∧
+                (∀ z, G (0, z) = F (v z)) ∧
+                  (∀ z, G (1, z) = u z) ∧
+                    ∀ t s, G (t, Degree.DiskCylinder.boundaryToDisk s) = H (t, s)
+
+private def Degree.FiniteCells.MapsLift {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (F : C(X, Y)) (Z : Type) [TopologicalSpace Z] : Prop :=
+  ∀ u : C(Z, Y), ∃ v : C(Z, X), (F.comp v).Homotopic u
+
+private theorem
+    Degree.FiniteCells.mapsLift_empty {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (F : C(X, Y)) (Z : Type) [TopologicalSpace Z] [IsEmpty Z] : MapsLift F Z := by
+  intro u
+  let v : C(Z, X) := ⟨isEmptyElim, continuous_iff_continuousAt.mpr (fun z => isEmptyElim z)⟩
+  refine ⟨v, ?_⟩
+  have he : F.comp v = u := ContinuousMap.ext (fun z => isEmptyElim z)
+  rw [he]
+
+private theorem
+    Degree.FiniteCells.mapsLift_equiv {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (F : C(X, Y)) {Z W : Type} [TopologicalSpace Z] [TopologicalSpace W] (e : Z ≃ₕ W)
+    (h : MapsLift F Z) : MapsLift F W := by
+  intro u
+  obtain ⟨v, hv⟩ := h (u.comp e.toFun)
+  refine ⟨v.comp e.invFun, ?_⟩
+  have h₁ := hv.comp (ContinuousMap.Homotopic.refl e.invFun)
+  have h₂ := (ContinuousMap.Homotopic.refl u).comp e.right_inv
+  simpa only [ContinuousMap.comp_assoc, ContinuousMap.comp_id] using h₁.trans h₂
+
+private theorem
+    Degree.FiniteCells.mapsLift_attach {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (F : C(X, Y)) {d : ℕ} (hF : RelativeDiskLifting F d) {V M : Type} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [FiniteDimensional ℝ V] [TopologicalSpace M] (A : Set M)
+    (h : C(Smale.MorseHandle.UnitDisk V, M))
+    (hb : ∀ z : Smale.MorseHandle.UnitDisk V, ‖(z : V)‖ = 1 → h z ∈ A)
+    (hd : Module.finrank ℝ V ≤ d) (hA : MapsLift F A) :
+    MapsLift F
+      (Smale.ClosedAttachment.Space A {z : Smale.MorseHandle.UnitDisk V | ‖(z : V)‖ = 1} h) := by
+  intro u
+  let B : Set (Smale.MorseHandle.UnitDisk V) := {z | ‖(z : V)‖ = 1}
+  let iA := Degree.AttachmentMaps.oldInclusion A B h
+  let iD := Degree.AttachmentMaps.cellInclusion A B h
+  obtain ⟨vA, ⟨HA⟩⟩ := hA (u.comp iA)
+  let b : C(Degree.DiskCylinder.Sphere (E := V), A) :=
+    ⟨fun s =>
+      ⟨h (Degree.DiskCylinder.boundaryToDisk s),
+        hb (Degree.DiskCylinder.boundaryToDisk s) (mem_sphere_zero_iff_norm.mp s.property)⟩,
+      (h.continuous.comp Degree.DiskCylinder.boundaryToDisk.continuous).subtype_mk _⟩
+  let H : C((unitInterval) × Degree.DiskCylinder.Sphere (E := V), Y) :=
+    HA.toContinuousMap.comp ((ContinuousMap.id (unitInterval)).prodMap b)
+  have h0 : ∀ s, H (0, s) = F ((vA.comp b) s) := fun s => HA.map_zero_left (b s)
+  have h1 : ∀ s, H (1, s) = (u.comp iD) (Degree.DiskCylinder.boundaryToDisk s) := by
+    intro s
+    change HA (1, b s) = u (iD (Degree.DiskCylinder.boundaryToDisk s))
+    exact
+      (HA.map_one_left (b s)).trans
+        (congrArg u
+          (Degree.AttachmentMaps.boundary_eq A B h (b s) (Degree.DiskCylinder.boundaryToDisk s)
+            (mem_sphere_zero_iff_norm.mp s.property) rfl))
+  obtain ⟨vD, GD, hvD, hGD0, hGD1, hGDside⟩ := hF V hd (vA.comp b) (u.comp iD) H h0 h1
+  have hcompat : ∀ a z, z ∈ B → a.val = h z → vA a = vD z := by
+    intro a z hz ha
+    let s : Degree.DiskCylinder.Sphere (E := V) := ⟨z.val, mem_sphere_zero_iff_norm.mpr hz⟩
+    have hab : a = b s := Subtype.ext ha
+    exact (congrArg vA hab).trans (hvD s).symm
+  let v := Degree.AttachmentMaps.glue A B h vA vD hcompat
+  have hhom : ∀ t a z, z ∈ B → a.val = h z → HA (t, a) = GD (t, z) := by
+    intro t a z hz ha
+    let s : Degree.DiskCylinder.Sphere (E := V) := ⟨z.val, mem_sphere_zero_iff_norm.mpr hz⟩
+    have hab : a = b s := Subtype.ext ha
+    exact (congrArg (fun a => HA (t, a)) hab).trans (hGDside t s).symm
+  refine
+    ⟨v, ⟨{
+          toContinuousMap := Degree.AttachmentMaps.glueFamily A B h HA.toContinuousMap GD hhom
+          map_zero_left := ?_
+          map_one_left := ?_ }⟩⟩
+  · intro z
+    induction z using Quot.inductionOn with
+    | _ z =>
+      cases z with
+      | inl a => exact HA.map_zero_left a
+      | inr z => exact hGD0 z
+  · intro z
+    induction z using Quot.inductionOn with
+    | _ z =>
+      cases z with
+      | inl a => exact HA.map_one_left a
+      | inr z => exact hGD1 z
+
+private theorem Degree.FiniteCells.mapsLift_of_built {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (F : C(X, Y)) {d : ℕ} (hF : RelativeDiskLifting F d) {Z : Type}
+    [TopologicalSpace Z] (hZ : Built d Z) : MapsLift F Z := by
+  induction hZ with
+  | empty Z => exact mapsLift_empty F Z
+  | equiv e _ ih => exact mapsLift_equiv F e ih
+  | attach A h hb hd _ ih => exact mapsLift_attach F hF A h hb hd ih
+
+private theorem Degree.LowCellLifting.relativeDiskLifting_five {Y : Type} [TopologicalSpace Y]
+    [PathConnectedSpace Y] (F : C(SixSphereCube.StandardSphere, Y))
+    (hpi : ∀ n, 0 < n → n < 6 → ∀ y : Y, Subsingleton (π_ n Y y)) :
+    Degree.FiniteCells.RelativeDiskLifting F 5 := by
+  intro V _ _ _ hd a u H h0 h1
+  obtain ⟨v, hv, _⟩ :=
+    Degree.Sphere.exists_boundary_extension (hd.trans (by decide)) a SixSphereCube.sphereBasePoint
+  have h0' : ∀ s, H (0, s) = (F.comp v) (Degree.DiskCylinder.boundaryToDisk s) := by
+    intro s
+    exact (h0 s).trans (congrArg F (hv s).symm)
+  obtain ⟨G, hG0, hG1, hGside⟩ :=
+    Degree.CylinderFilling.exists_filling hpi (by omega : Module.finrank ℝ V + 1 ≤ 6) (F.comp v) u
+      H h0' h1 (F SixSphereCube.sphereBasePoint)
+  exact ⟨v, G, hv, hG0, hG1, hGside⟩
+
+attribute [local instance] SpecialPeriods.Threefold.space_simplyConnected in
+private theorem Degree.LowCellLifting.threefold_pi_subsingleton {n : ℕ} (hn : 0 < n) (hn6 : n < 6)
+    (x : SpecialPeriods.Threefold.Space) : Subsingleton (π_ n SpecialPeriods.Threefold.Space x) :=
+  by
+  have hn5 : n ≤ 5 := by omega
+  interval_cases n
+  · exact (HomotopyGroup.pi1EquivFundamentalGroup).injective.subsingleton
+  · exact SpecialPeriods.Threefold.HomotopyTwo.piTwo_subsingleton x
+  · exact SpecialPeriods.Threefold.HomotopyThree.piThree_subsingleton x
+  · exact SpecialPeriods.Threefold.HomotopyFour.piFour_subsingleton x
+  · exact SpecialPeriods.Threefold.HomotopyFive.piFive_subsingleton x
+
+attribute [local instance] SpecialPeriods.Threefold.space_simplyConnected in
+private theorem Degree.LowCellLifting.sphereMap_relativeDiskLifting_five
+    (x : SpecialPeriods.Threefold.Space) :
+    Degree.FiniteCells.RelativeDiskLifting
+      (SpecialPeriods.Threefold.SphereHomologyEquivalence.sphereMap x) 5 :=
+  relativeDiskLifting_five _ (fun _ hn hn6 => threefold_pi_subsingleton hn hn6)
+
+private def Degree.MappingPaths.ofHomotopy {A B : Type*} [TopologicalSpace A] [TopologicalSpace B]
+    {f g : C(A, B)} (H : f.Homotopy g) : Path f g
+    where
+  toContinuousMap := H.curry
+  source' := H.curry_zero
+  target' := H.curry_one
+
+private def Degree.MappingPaths.toHomotopy {A B : Type*} [TopologicalSpace A] [TopologicalSpace B]
+    [LocallyCompactSpace A] {f g : C(A, B)} (p : Path f g) : f.Homotopy g
+    where
+  toContinuousMap := p.toContinuousMap.uncurry
+  map_zero_left a := ContinuousMap.congr_fun p.source a
+  map_one_left a := ContinuousMap.congr_fun p.target a
+
+private def
+    Degree.MappingPaths.Over {A B : Type*} [TopologicalSpace A] [TopologicalSpace B] {a₀ a₁ : A}
+    {b₀ b₁ : B} (r : A → B) (p : Path a₀ a₁) (q : Path b₀ b₁) : Prop :=
+  ∀ t, r (p t) = q t
+
+private theorem
+    Degree.MappingPaths.Over.symm {A B : Type*} [TopologicalSpace A] [TopologicalSpace B]
+    {a₀ a₁ : A} {b₀ b₁ : B} {r : A → B} {p : Path a₀ a₁} {q : Path b₀ b₁}
+    (h : Degree.MappingPaths.Over r p q) : Degree.MappingPaths.Over r p.symm q.symm := fun t =>
+  h (unitInterval.symm t)
+
+private theorem
+    Degree.MappingPaths.Over.trans {A B : Type*} [TopologicalSpace A] [TopologicalSpace B]
+    {a₀ a₁ a₂ : A} {b₀ b₁ b₂ : B} {r : A → B} {p₀ : Path a₀ a₁} {p₁ : Path a₁ a₂}
+    {q₀ : Path b₀ b₁} {q₁ : Path b₁ b₂} (h₀ : Degree.MappingPaths.Over r p₀ q₀)
+    (h₁ : Degree.MappingPaths.Over r p₁ q₁) :
+    Degree.MappingPaths.Over r (p₀.trans p₁) (q₀.trans q₁) := by
+  intro t
+  simp only [Path.trans_apply]
+  split_ifs <;>
+    first
+    | exact h₀ _
+    | exact h₁ _
+
+private theorem Degree.MappingPaths.normalization_cancellation {B : Type*} [TopologicalSpace B]
+    {b₀ b₁ b₂ : B} (a : Path b₀ b₁) (h : Path b₁ b₂) :
+    (a.symm.trans ((Path.refl b₀).trans ((h.symm.trans a.symm).symm))).Homotopic h := by
+  rw [Path.trans_symm, Path.symm_symm, Path.symm_symm]
+  have hunit := Path.Homotopic.refl_trans (a.trans h)
+  have hfirst := (Path.Homotopic.refl a.symm).hcomp hunit
+  have hassoc := (Path.Homotopic.trans_assoc a.symm a h).symm
+  have hcancel := (Path.Homotopic.symm_trans a).hcomp (Path.Homotopic.refl h)
+  exact hfirst.trans (hassoc.trans (hcancel.trans (Path.Homotopic.refl_trans h)))
+
+private theorem Degree.BoundaryPathTransport.exists_transport {V Y : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [FiniteDimensional ℝ V] [TopologicalSpace Y]
+    (f : C(Degree.DiskCylinder.Disk (E := V), Y))
+    {a b : C(Degree.DiskCylinder.Sphere (E := V), Y)} (A : Path a b)
+    (ha : f.comp Degree.DiskCylinder.boundaryToDisk = a) :
+    ∃ g : C(Degree.DiskCylinder.Disk (E := V), Y),
+      ∃ P : Path f g,
+        Degree.MappingPaths.Over
+            (fun v : C(Degree.DiskCylinder.Disk (E := V), Y) =>
+              v.comp Degree.DiskCylinder.boundaryToDisk)
+            P A ∧
+          g.comp Degree.DiskCylinder.boundaryToDisk = b := by
+  let H : C((unitInterval) × Degree.DiskCylinder.Sphere (E := V), Y) := A.toContinuousMap.uncurry
+  have h0 : ∀ s, H (0, s) = f (Degree.DiskCylinder.boundaryToDisk s) := by
+    intro s
+    exact (ContinuousMap.congr_fun A.source s).trans (ContinuousMap.congr_fun ha.symm s)
+  let g := Degree.DiskCylinder.extensionEndpoint f H h0
+  let P := Degree.MappingPaths.ofHomotopy (Degree.DiskCylinder.extensionHomotopy f H h0)
+  have hP :
+    Degree.MappingPaths.Over
+      (fun v : C(Degree.DiskCylinder.Disk (E := V), Y) =>
+        v.comp Degree.DiskCylinder.boundaryToDisk)
+      P A := by
+    intro t
+    apply ContinuousMap.ext
+    intro s
+    exact Degree.DiskCylinder.extend_side f H h0 t s
+  refine ⟨g, P, hP, ?_⟩
+  simpa using hP 1
+
+private def Degree.CylinderBoundaryFamilies.bottomFamily {V Y : Type*} [NormedAddCommGroup V]
+    [TopologicalSpace Y] (f : C((unitInterval) × Degree.DiskCylinder.Disk (E := V), Y)) :
+    C(Degree.DiskCylinder.Disk (E := V), C((unitInterval), Y)) :=
+  (f.comp ContinuousMap.prodSwap).curry
+
+private def Degree.CylinderBoundaryFamilies.topFamily {V Y : Type*} [NormedAddCommGroup V]
+    [TopologicalSpace Y] (g : C((unitInterval) × Degree.DiskCylinder.Disk (E := V), Y)) :
+    C(Degree.DiskCylinder.Disk (E := V), C((unitInterval), Y)) :=
+  (g.comp ContinuousMap.prodSwap).curry
+
+private def Degree.CylinderBoundaryFamilies.sideFamily {V Y : Type*} [NormedAddCommGroup V]
+    [TopologicalSpace Y]
+    (H : C((unitInterval) × ((unitInterval) × Degree.DiskCylinder.Sphere (E := V)), Y)) :
+    C((unitInterval) × Degree.DiskCylinder.Sphere (E := V), C((unitInterval), Y)) :=
+  (H.comp ContinuousMap.prodSwap).curry
+
+private def
+    Degree.CylinderBoundaryFamilies.glued {V Y : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    [FiniteDimensional ℝ V] [TopologicalSpace Y]
+    (f g : C((unitInterval) × Degree.DiskCylinder.Disk (E := V), Y))
+    (H : C((unitInterval) × ((unitInterval) × Degree.DiskCylinder.Sphere (E := V)), Y))
+    (h0 : ∀ t s, H (t, 0, s) = f (t, Degree.DiskCylinder.boundaryToDisk s))
+    (h1 : ∀ t s, H (t, 1, s) = g (t, Degree.DiskCylinder.boundaryToDisk s)) :
+    C((unitInterval) × Degree.CylinderBall.boundary (V := V), Y) :=
+  (Degree.CylinderBoundary.glued (bottomFamily f) (topFamily g) (sideFamily H)
+        (fun s => ContinuousMap.ext (fun t => h0 t s))
+        (fun s => ContinuousMap.ext (fun t => h1 t s))).uncurry.comp
+    ContinuousMap.prodSwap
+
+private theorem Degree.CylinderBoundaryFamilies.glued_bottom {V Y : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [FiniteDimensional ℝ V] [TopologicalSpace Y]
+    (f g : C((unitInterval) × Degree.DiskCylinder.Disk (E := V), Y))
+    (H : C((unitInterval) × ((unitInterval) × Degree.DiskCylinder.Sphere (E := V)), Y))
+    (h0 : ∀ t s, H (t, 0, s) = f (t, Degree.DiskCylinder.boundaryToDisk s))
+    (h1 : ∀ t s, H (t, 1, s) = g (t, Degree.DiskCylinder.boundaryToDisk s)) (t : (unitInterval))
+    (z : Degree.DiskCylinder.Disk (E := V)) :
+    glued f g H h0 h1 (t, Degree.CylinderBoundary.lower (Degree.DiskCylinder.bottomMap z)) =
+      f (t, z) :=
+  ContinuousMap.congr_fun
+    (Degree.CylinderBoundary.glued_bottom (bottomFamily f) (topFamily g) (sideFamily H)
+      (fun s => ContinuousMap.ext (fun t => h0 t s))
+      (fun s => ContinuousMap.ext (fun t => h1 t s)) z)
+    t
+
+private theorem Degree.CylinderBoundaryFamilies.glued_top {V Y : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [FiniteDimensional ℝ V] [TopologicalSpace Y]
+    (f g : C((unitInterval) × Degree.DiskCylinder.Disk (E := V), Y))
+    (H : C((unitInterval) × ((unitInterval) × Degree.DiskCylinder.Sphere (E := V)), Y))
+    (h0 : ∀ t s, H (t, 0, s) = f (t, Degree.DiskCylinder.boundaryToDisk s))
+    (h1 : ∀ t s, H (t, 1, s) = g (t, Degree.DiskCylinder.boundaryToDisk s)) (t : (unitInterval))
+    (z : Degree.DiskCylinder.Disk (E := V)) :
+    glued f g H h0 h1 (t, Degree.CylinderBoundary.top z) = g (t, z) :=
+  ContinuousMap.congr_fun
+    (Degree.CylinderBoundary.glued_top (bottomFamily f) (topFamily g) (sideFamily H)
+      (fun s => ContinuousMap.ext (fun t => h0 t s))
+      (fun s => ContinuousMap.ext (fun t => h1 t s)) z)
+    t
+
+private theorem Degree.CylinderBoundaryFamilies.glued_side {V Y : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [FiniteDimensional ℝ V] [TopologicalSpace Y]
+    (f g : C((unitInterval) × Degree.DiskCylinder.Disk (E := V), Y))
+    (H : C((unitInterval) × ((unitInterval) × Degree.DiskCylinder.Sphere (E := V)), Y))
+    (h0 : ∀ t s, H (t, 0, s) = f (t, Degree.DiskCylinder.boundaryToDisk s))
+    (h1 : ∀ t s, H (t, 1, s) = g (t, Degree.DiskCylinder.boundaryToDisk s)) (t r : (unitInterval))
+    (s : Degree.DiskCylinder.Sphere (E := V)) :
+    glued f g H h0 h1 (t, Degree.CylinderBoundary.lower (Degree.DiskCylinder.sideMap (r, s))) =
+      H (t, r, s) :=
+  ContinuousMap.congr_fun
+    (Degree.CylinderBoundary.glued_side (bottomFamily f) (topFamily g) (sideFamily H)
+      (fun s => ContinuousMap.ext (fun t => h0 t s))
+      (fun s => ContinuousMap.ext (fun t => h1 t s)) r s)
+    t
+
+private theorem
+    Degree.CylinderHEP.exists_extension {V Y : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    [FiniteDimensional ℝ V] [TopologicalSpace Y]
+    (f : C((unitInterval) × Degree.DiskCylinder.Disk (E := V), Y))
+    (J : C((unitInterval) × Degree.CylinderBall.boundary (V := V), Y))
+    (h0 : ∀ p, J (0, p) = f p.val) :
+    ∃ K : C((unitInterval) × ((unitInterval) × Degree.DiskCylinder.Disk (E := V)), Y),
+      (∀ p, K (0, p) = f p) ∧
+        ∀ (t : (unitInterval)) (p : Degree.CylinderBall.boundary (V := V)),
+          K (t, p.val) = J (t, p) := by
+  let e := Degree.CylinderBall.homeomorph (V := V)
+  let b := Degree.CylinderBall.boundaryHomeomorph (V := V)
+  let f' : C(Degree.DiskCylinder.Disk (E := ℝ × V), Y) := f.comp (e.symm : C(_, _))
+  let J' : C((unitInterval) × Degree.DiskCylinder.Sphere (E := ℝ × V), Y) :=
+    J.comp ((ContinuousMap.id (unitInterval)).prodMap (b.symm : C(_, _)))
+  have h0' : ∀ s, J' (0, s) = f' (Degree.DiskCylinder.boundaryToDisk s) := fun s => h0 (b.symm s)
+  let H := Degree.DiskCylinder.extend f' J' h0'
+  let K : C((unitInterval) × ((unitInterval) × Degree.DiskCylinder.Disk (E := V)), Y) :=
+    H.comp ((ContinuousMap.id (unitInterval)).prodMap (e : C(_, _)))
+  refine ⟨K, ?_, ?_⟩
+  · intro p
+    change H (0, e p) = f p
+    exact
+      (Degree.DiskCylinder.extend_bottom f' J' h0' (e p)).trans
+        (congrArg f (e.symm_apply_apply p))
+  · intro t p
+    change H (t, Degree.DiskCylinder.boundaryToDisk (b p)) = J (t, p)
+    exact
+      (Degree.DiskCylinder.extend_side f' J' h0' t (b p)).trans
+        (congrArg (fun p => J (t, p)) (b.symm_apply_apply p))
+
+private theorem Degree.SideRectification.boundary_cases {V : Type*} [NormedAddCommGroup V]
+    (p : Degree.CylinderBall.boundary (V := V)) :
+    (∃ z, p = Degree.CylinderBoundary.lower (Degree.DiskCylinder.bottomMap z)) ∨
+      (∃ z, p = Degree.CylinderBoundary.top z) ∨
+        ∃ t s, p = Degree.CylinderBoundary.lower (Degree.DiskCylinder.sideMap (t, s)) := by
+  rcases p with ⟨⟨t, z⟩, ht | ht | hz⟩
+  · change t = 0 at ht
+    subst t
+    exact Or.inl ⟨z, rfl⟩
+  · change t = 1 at ht
+    subst t
+    exact Or.inr (Or.inl ⟨z, rfl⟩)
+  · exact Or.inr (Or.inr ⟨t, ⟨z.val, mem_sphere_zero_iff_norm.mpr hz⟩, rfl⟩)
+
+private theorem Degree.SideRectification.exists_rectification {V Y : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [FiniteDimensional ℝ V] [TopologicalSpace Y]
+    {f g : C(Degree.DiskCylinder.Disk (E := V), Y)} (P : Path f g)
+    {a b : C(Degree.DiskCylinder.Sphere (E := V), Y)} (Q H : Path a b)
+    (hP :
+      Degree.MappingPaths.Over
+        (fun v : C(Degree.DiskCylinder.Disk (E := V), Y) =>
+          v.comp Degree.DiskCylinder.boundaryToDisk)
+        P Q)
+    (hQ : Q.Homotopic H) :
+    ∃ G : C((unitInterval) × Degree.DiskCylinder.Disk (E := V), Y),
+      (∀ z, G (0, z) = f z) ∧
+        (∀ z, G (1, z) = g z) ∧ ∀ t s, G (t, Degree.DiskCylinder.boundaryToDisk s) = H t s := by
+  obtain ⟨K⟩ := hQ
+  have hfa : f.comp Degree.DiskCylinder.boundaryToDisk = a := by simpa using hP 0
+  have hgb : g.comp Degree.DiskCylinder.boundaryToDisk = b := by simpa using hP 1
+  let side : C((unitInterval) × ((unitInterval) × Degree.DiskCylinder.Sphere (E := V)), Y) :=
+    K.toHomotopy.toContinuousMap.uncurry.comp
+      ((Homeomorph.prodAssoc (unitInterval) (unitInterval)
+            (Degree.DiskCylinder.Sphere (E := V))).symm :
+        C(_, _))
+  let fb : C((unitInterval) × Degree.DiskCylinder.Disk (E := V), Y) := f.comp ContinuousMap.snd
+  let gt : C((unitInterval) × Degree.DiskCylinder.Disk (E := V), Y) := g.comp ContinuousMap.snd
+  have hs0 : ∀ t s, side (t, 0, s) = fb (t, Degree.DiskCylinder.boundaryToDisk s) := by
+    intro t s
+    have he : K (t, 0) = a := (K.eq_fst t (by simp)).trans Q.source
+    exact (congrArg (fun v => v s) he).trans (ContinuousMap.congr_fun hfa.symm s)
+  have hs1 : ∀ t s, side (t, 1, s) = gt (t, Degree.DiskCylinder.boundaryToDisk s) := by
+    intro t s
+    have he : K (t, 1) = b := (K.eq_fst t (by simp)).trans Q.target
+    exact (congrArg (fun v => v s) he).trans (ContinuousMap.congr_fun hgb.symm s)
+  let J := Degree.CylinderBoundaryFamilies.glued fb gt side hs0 hs1
+  have hJ0 :
+    ∀ p : Degree.CylinderBall.boundary (V := V),
+      J (0, p) = Degree.MappingPaths.toHomotopy P p.val := by
+    intro p
+    rcases boundary_cases p with ⟨z, rfl⟩ | ⟨z, rfl⟩ | ⟨t, s, rfl⟩
+    · exact
+        (Degree.CylinderBoundaryFamilies.glued_bottom fb gt side hs0 hs1 0 z).trans
+          (ContinuousMap.congr_fun P.source z).symm
+    · exact
+        (Degree.CylinderBoundaryFamilies.glued_top fb gt side hs0 hs1 0 z).trans
+          (ContinuousMap.congr_fun P.target z).symm
+    · exact
+        (Degree.CylinderBoundaryFamilies.glued_side fb gt side hs0 hs1 0 t s).trans
+          ((congrArg (fun v => v s) (K.apply_zero t)).trans
+            (ContinuousMap.congr_fun (hP t) s).symm)
+  obtain ⟨W, _, hW⟩ :=
+    Degree.CylinderHEP.exists_extension (Degree.MappingPaths.toHomotopy P).toContinuousMap J hJ0
+  let G : C((unitInterval) × Degree.DiskCylinder.Disk (E := V), Y) :=
+    W.comp ⟨fun p => (1, p), continuous_const.prodMk continuous_id⟩
+  refine ⟨G, ?_, ?_, ?_⟩
+  · intro z
+    exact
+      (hW 1 (Degree.CylinderBoundary.lower (Degree.DiskCylinder.bottomMap z))).trans
+        (Degree.CylinderBoundaryFamilies.glued_bottom fb gt side hs0 hs1 1 z)
+  · intro z
+    exact
+      (hW 1 (Degree.CylinderBoundary.top z)).trans
+        (Degree.CylinderBoundaryFamilies.glued_top fb gt side hs0 hs1 1 z)
+  · intro t s
+    exact
+      (hW 1 (Degree.CylinderBoundary.lower (Degree.DiskCylinder.sideMap (t, s)))).trans
+        ((Degree.CylinderBoundaryFamilies.glued_side fb gt side hs0 hs1 1 t s).trans
+          (congrArg (fun v => v s) (K.apply_one t)))
+
+private theorem Degree.TopCellLifting.exists_top_disk_lift {V : Type} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [FiniteDimensional ℝ V] (x : SpecialPeriods.Threefold.Space)
+    (L : V ≃L[ℝ] (Fin 6 → ℝ)) (hd : Module.finrank ℝ V ≤ 6)
+    (a : C(Degree.DiskCylinder.Sphere (E := V), SixSphereCube.StandardSphere))
+    (u : C(Degree.DiskCylinder.Disk (E := V), SpecialPeriods.Threefold.Space))
+    (H : C((unitInterval) × Degree.DiskCylinder.Sphere (E := V), SpecialPeriods.Threefold.Space))
+    (h0 : ∀ s, H (0, s) = SpecialPeriods.Threefold.SphereHomologyEquivalence.sphereMap x (a s))
+    (h1 : ∀ s, H (1, s) = u (Degree.DiskCylinder.boundaryToDisk s)) :
+    ∃ (v : C(Degree.DiskCylinder.Disk (E := V), SixSphereCube.StandardSphere)) (G :
+      C((unitInterval) × Degree.DiskCylinder.Disk (E := V), SpecialPeriods.Threefold.Space)),
+      (∀ s, v (Degree.DiskCylinder.boundaryToDisk s) = a s) ∧
+        (∀ z, G (0, z) = SpecialPeriods.Threefold.SphereHomologyEquivalence.sphereMap x (v z)) ∧
+          (∀ z, G (1, z) = u z) ∧ ∀ t s, G (t, Degree.DiskCylinder.boundaryToDisk s) = H (t, s) :=
+  by
+  let F := SpecialPeriods.Threefold.SphereHomologyEquivalence.sphereMap x
+  let c : C(Degree.DiskCylinder.Sphere (E := V), SixSphereCube.StandardSphere) :=
+    ContinuousMap.const _ SixSphereCube.sphereBasePoint
+  obtain ⟨Ac⟩ := (Degree.Sphere.boundary_homotopic_const hd a SixSphereCube.sphereBasePoint).symm
+  let A : Path c a := Degree.MappingPaths.ofHomotopy Ac
+  let FA : Path (F.comp c) (F.comp a) := A.map (ContinuousMap.continuous_postcomp F)
+  let HP : Path (F.comp a) (u.comp Degree.DiskCylinder.boundaryToDisk) :=
+    { toContinuousMap := H.curry
+      source' := ContinuousMap.ext h0
+      target' := ContinuousMap.ext h1 }
+  let K := HP.symm.trans FA.symm
+  obtain ⟨u₀, E, hE, hu₀⟩ := Degree.BoundaryPathTransport.exists_transport u K rfl
+  have hu₀' :
+    ∀ z : Degree.DiskCylinder.Disk (E := V),
+      ‖(z : V)‖ = 1 → u₀ z = F SixSphereCube.sphereBasePoint := by
+    intro z hz
+    exact ContinuousMap.congr_fun hu₀ ⟨z.val, mem_sphere_zero_iff_norm.mpr hz⟩
+  obtain ⟨p, hp, ⟨B⟩⟩ := Degree.BasedDiskLifting.exists_based_disk_lift x L u₀ hu₀'
+  have hp' : p.comp Degree.DiskCylinder.boundaryToDisk = c := by
+    apply ContinuousMap.ext
+    intro s
+    exact hp (Degree.DiskCylinder.boundaryToDisk s) (mem_sphere_zero_iff_norm.mp s.property)
+  obtain ⟨v, P, hP, hv⟩ := Degree.BoundaryPathTransport.exists_transport p A hp'
+  let FP : Path (F.comp p) (F.comp v) := P.map (ContinuousMap.continuous_postcomp F)
+  let BP := Degree.MappingPaths.ofHomotopy B.toHomotopy
+  have hFP :
+    Degree.MappingPaths.Over
+      (fun w : C(Degree.DiskCylinder.Disk (E := V), SpecialPeriods.Threefold.Space) =>
+        w.comp Degree.DiskCylinder.boundaryToDisk)
+      FP FA := by
+    intro t
+    apply ContinuousMap.ext
+    intro s
+    exact congrArg F (ContinuousMap.congr_fun (hP t) s)
+  have hBP :
+    Degree.MappingPaths.Over
+      (fun w : C(Degree.DiskCylinder.Disk (E := V), SpecialPeriods.Threefold.Space) =>
+        w.comp Degree.DiskCylinder.boundaryToDisk)
+      BP (Path.refl (F.comp c)) := by
+    intro t
+    apply ContinuousMap.ext
+    intro s
+    have hs : ‖(Degree.DiskCylinder.boundaryToDisk s : V)‖ = 1 :=
+      mem_sphere_zero_iff_norm.mp s.property
+    exact (B.eq_fst t hs).trans (congrArg F (hp (Degree.DiskCylinder.boundaryToDisk s) hs))
+  let R := FP.symm.trans (BP.trans E.symm)
+  let Q := FA.symm.trans ((Path.refl (F.comp c)).trans K.symm)
+  have hR :
+    Degree.MappingPaths.Over
+      (fun w : C(Degree.DiskCylinder.Disk (E := V), SpecialPeriods.Threefold.Space) =>
+        w.comp Degree.DiskCylinder.boundaryToDisk)
+      R Q :=
+    hFP.symm.trans (hBP.trans hE.symm)
+  have hQ : Q.Homotopic HP := Degree.MappingPaths.normalization_cancellation FA HP
+  obtain ⟨G, hG0, hG1, hGside⟩ := Degree.SideRectification.exists_rectification R Q HP hR hQ
+  exact ⟨v, G, fun s => ContinuousMap.congr_fun hv s, hG0, hG1, hGside⟩
+
+private theorem Degree.TopCellLifting.sphereMap_relativeDiskLifting_six
+    (x : SpecialPeriods.Threefold.Space) :
+    Degree.FiniteCells.RelativeDiskLifting
+      (SpecialPeriods.Threefold.SphereHomologyEquivalence.sphereMap x) 6 := by
+  intro V _ _ _ hd a u H h0 h1
+  by_cases hlow : Module.finrank ℝ V ≤ 5
+  · exact Degree.LowCellLifting.sphereMap_relativeDiskLifting_five x V hlow a u H h0 h1
+  · have heq : Module.finrank ℝ V = 6 := by omega
+    obtain ⟨L⟩ :=
+      FiniteDimensional.nonempty_continuousLinearEquiv_of_finrank_eq
+        (show Module.finrank ℝ V = Module.finrank ℝ (Fin 6 → ℝ) by simpa using heq)
+    exact exists_top_disk_lift x L hd a u H h0 h1
+
+private theorem
+    Degree.MorseCells.exists_morse_cell_attachment_lt {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f) {p : M}
+    (hp : p ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hunique : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, f x = f p → x = p) {R : ℝ}
+    (hR : 0 < R) :
+    ∃ (ρ : ℝ) (hρ : 0 < ρ),
+      ρ < R ∧
+        ∃ c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p,
+          ∃ hblock :
+            Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+                Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+              c.splitChart.target,
+            (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+                f x ∈ Set.Icc (f p - ρ ^ 2) (f p + ρ ^ 2) → x = p) ∧
+              Module.finrank ℝ c.NegativeCoordinates ≤ Module.finrank ℝ E ∧
+                Nonempty
+                  (Smale.ClosedAttachment.Space {x : M | f x ≤ f p - ρ ^ 2}
+                      {u : Smale.MorseHandle.UnitDisk c.NegativeCoordinates |
+                        ‖(u : c.NegativeCoordinates)‖ = 1}
+                      (coreCellMap c ρ hρ hblock) ≃ₕ
+                    { x : M // f x ≤ f p + ρ ^ 2 }) := by
+  obtain ⟨V, F, hV, hcurve, hzero, hdesc, hcharts, _, _, _⟩ :=
+    Smale.FlowConstruction.exists_adaptedDescentFlow hf hm
+  obtain ⟨c, heq⟩ := hcharts p hp
+  obtain ⟨r, hr, W, hW, _, heqW, hblockr⟩ := c.exists_fieldCompatibleBlock V heq
+  obtain ⟨ρ, hρ, hρmin, hband⟩ :=
+    Smale.ManifoldMorse.exists_isolating_radius (Smale.ManifoldMorse.finite_criticalPoints hf hm)
+      p hunique (lt_min hr hR)
+  have hρr : ρ < r := hρmin.trans_le (min_le_left r R)
+  have hρR : ρ < R := hρmin.trans_le (min_le_right r R)
+  have hblockW :
+    Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+        Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+      c.splitChart.target ∩ c.splitChart.symm ⁻¹' W := by
+    intro z hz
+    apply hblockr
+    have hrad : 2 * ρ ≤ 2 * r := by linarith
+    exact
+      ⟨Metric.closedBall_subset_closedBall hrad hz.1,
+        Metric.closedBall_subset_closedBall hrad hz.2⟩
+  have hblock :
+    Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+        Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+      c.splitChart.target :=
+    fun z hz => (hblockW hz).1
+  have hagreement :
+    ∀ x ∈ Set.range (c.attachingHandleMap ρ hρ hblock), ∀ᶠ y in 𝓝 x, V y = c.descentField y := by
+    rintro _ ⟨z, rfl⟩
+    have hxW : c.attachingHandleMap ρ hρ hblock z ∈ W :=
+      (hblockW (Smale.MorseHandle.modelMap_mem_product hρ z)).2
+    filter_upwards [hW.mem_nhds hxW] with y hy
+    exact heqW y hy
+  obtain ⟨e, _⟩ :=
+    c.exists_attachingUnionHomotopyEquiv hf hV hzero hdesc F hcurve ρ hρ hblock hagreement hband
+  refine ⟨ρ, hρ, hρR, c, hblock, hband, core_dimension_le c, ?_⟩
+  exact
+    ⟨(cellHandleHomotopyEquiv c ρ hρ hblock hf.continuous).trans
+        ((c.attachingHandleUnionHomeomorph hf.continuous ρ hρ hblock).toHomotopyEquiv.trans e)⟩
+
+private structure Degree.MorseCells.Cell {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] (f : M → ℝ) (p : M) where
+  radius : ℝ
+  radius_pos : 0 < radius
+  chart : Smale.ManifoldMorse.SignedMorseChart (E := E) f p
+  block :
+    Metric.closedBall (0 : chart.NegativeCoordinates) (2 * radius) ×ˢ
+        Metric.closedBall (0 : chart.PositiveCoordinates) (2 * radius) ⊆
+      chart.splitChart.target
+  isolated :
+    ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+      f x ∈ Set.Icc (f p - radius ^ 2) (f p + radius ^ 2) → x = p
+  dimension_le : Module.finrank ℝ chart.NegativeCoordinates ≤ Module.finrank ℝ E
+  comparison :
+    Smale.ClosedAttachment.Space {x : M | f x ≤ f p - radius ^ 2}
+        {u : Smale.MorseHandle.UnitDisk chart.NegativeCoordinates |
+          ‖(u : chart.NegativeCoordinates)‖ = 1}
+        (coreCellMap chart radius radius_pos block) ≃ₕ
+      { x : M // f x ≤ f p + radius ^ 2 }
+
+private def Degree.MorseCells.Cell.band {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Degree.MorseCells.Cell (E := E) f p) : Set ℝ :=
+  Set.Icc (f p - c.radius ^ 2) (f p + c.radius ^ 2)
+
+private theorem
+    Degree.MorseCells.exists_cell_lt {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [FiniteDimensional ℝ E] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [T2Space M] [CompactSpace M] {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) {p : M}
+    (hp : p ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hunique : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, f x = f p → x = p) {R : ℝ}
+    (hR : 0 < R) : ∃ c : Cell (E := E) f p, c.radius < R := by
+  obtain ⟨ρ, hρ, hlt, c, hb, hi, hd, ⟨e⟩⟩ := exists_morse_cell_attachment_lt hf hm hp hunique hR
+  exact ⟨⟨ρ, hρ, c, hb, hi, hd, e⟩, hlt⟩
+
+private theorem Degree.MorseCells.exists_disjoint_cells {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f)) :
+    ∃ c : (p : Smale.ManifoldMorse.criticalPoints E f) → Cell (E := E) f p.val,
+      ∀ p q, p ≠ q → Disjoint (c p).band (c q).band := by
+  have hR (p : Smale.ManifoldMorse.criticalPoints E f) :
+    ∃ R > (0 : ℝ),
+      ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+        f x ∈ Set.Icc (f p - R ^ 2) (f p + R ^ 2) → x = p := by
+    obtain ⟨R, hR, _, hi⟩ :=
+      Smale.ManifoldMorse.exists_isolating_radius
+        (Smale.ManifoldMorse.finite_criticalPoints hf hm) p.val
+        (fun x hx heq => hinj hx p.property heq) zero_lt_one
+    exact ⟨R, hR, hi⟩
+  choose R hR hiso using hR
+  have hc (p : Smale.ManifoldMorse.criticalPoints E f) :
+    ∃ c : Cell (E := E) f p.val, c.radius < R p / 2 :=
+    exists_cell_lt hf hm p.property (fun x hx heq => hinj hx p.property heq) (half_pos (hR p))
+  choose c hc using hc
+  refine ⟨c, ?_⟩
+  have hordered (p q : Smale.ManifoldMorse.criticalPoints E f) (hpq : f p < f q) :
+    Disjoint (c p).band (c q).band := by
+    have hne : (p : M) ≠ q := fun he => (ne_of_lt hpq) (congrArg f he)
+    have hp : (R p) ^ 2 < f q - f p := by
+      by_contra h
+      have he :=
+        hiso p q q.property
+          (show f q ∈ Set.Icc (f p - (R p) ^ 2) (f p + (R p) ^ 2) from
+            ⟨by nlinarith [sq_nonneg (R p)], by linarith⟩)
+      exact hne he.symm
+    have hq : (R q) ^ 2 < f q - f p := by
+      by_contra h
+      have he :=
+        hiso q p p.property
+          (show f p ∈ Set.Icc (f q - (R q) ^ 2) (f q + (R q) ^ 2) from
+            ⟨by linarith, by nlinarith [sq_nonneg (R q)]⟩)
+      exact hne he
+    have hsp : (c p).radius ^ 2 < (R p / 2) ^ 2 :=
+      (sq_lt_sq₀ (c p).radius_pos.le (half_pos (hR p)).le).mpr (hc p)
+    have hsq : (c q).radius ^ 2 < (R q / 2) ^ 2 :=
+      (sq_lt_sq₀ (c q).radius_pos.le (half_pos (hR q)).le).mpr (hc q)
+    apply Set.disjoint_left.mpr
+    intro t htp htq
+    change f p - (c p).radius ^ 2 ≤ t ∧ t ≤ f p + (c p).radius ^ 2 at htp
+    change f q - (c q).radius ^ 2 ≤ t ∧ t ≤ f q + (c q).radius ^ 2 at htq
+    nlinarith [htp.2, htq.1]
+  intro p q hpq
+  rcases lt_trichotomy (f p) (f q) with h | h | h
+  · exact hordered p q h
+  · exact (hpq (Subtype.ext (hinj p.property q.property h))).elim
+  · exact (hordered q p h).symm
+
+private theorem Degree.MorseCells.upper_lt_lower_of_disjoint {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p q : M}
+    (c : Cell (E := E) f p) (d : Cell (E := E) f q) (h : Disjoint c.band d.band)
+    (hpq : f p < f q) : f p + c.radius ^ 2 < f q - d.radius ^ 2 := by
+  by_contra hn
+  have hle : f q - d.radius ^ 2 ≤ f p + c.radius ^ 2 := le_of_not_gt hn
+  let t := Max.max (f p - c.radius ^ 2) (f q - d.radius ^ 2)
+  have hc : t ∈ c.band := by
+    exact ⟨le_max_left _ _, max_le (by nlinarith [sq_nonneg c.radius]) hle⟩
+  have hd : t ∈ d.band := by
+    refine ⟨le_max_right _ _, max_le ?_ ?_⟩
+    · nlinarith [sq_nonneg c.radius, sq_nonneg d.radius]
+    · nlinarith [sq_nonneg d.radius]
+  exact Set.disjoint_left.mp h hc hd
+
+private theorem
+    Degree.MorseCells.isEmpty_sublevel_of_no_critical {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} [IsManifold 𝓘(ℝ, E) ∞ M]
+    [CompactSpace M] (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a : ℝ}
+    (h : ∀ p ∈ Smale.ManifoldMorse.criticalPoints E f, ¬f p ≤ a) : IsEmpty { x : M // f x ≤ a } :=
+  by
+  refine ⟨fun x => ?_⟩
+  obtain ⟨p, _, hmin⟩ :=
+    isCompact_univ.exists_isMinOn ⟨x.val, Set.mem_univ _⟩ hf.continuous.continuousOn
+  have hp : p ∈ Smale.ManifoldMorse.criticalPoints E f :=
+    Smale.ManifoldMorse.mem_criticalPoints_of_localMin hf
+      (Filter.Eventually.of_forall (fun y => hmin (Set.mem_univ y)))
+  exact h p hp ((hmin (Set.mem_univ x.val)).trans x.property)
+
+private theorem Degree.MorseCells.built_upper_sublevels {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f))
+    (c : (p : Smale.ManifoldMorse.criticalPoints E f) → Cell (E := E) f p.val)
+    (hdis : ∀ p q, p ≠ q → Disjoint (c p).band (c q).band)
+    (p : Smale.ManifoldMorse.criticalPoints E f) :
+    Degree.FiniteCells.Built (Module.finrank ℝ E) { x : M // f x ≤ f p + (c p).radius ^ 2 } := by
+  classical
+  let K := Smale.ManifoldMorse.criticalPoints E f
+  let : Fintype K := (Smale.ManifoldMorse.finite_criticalPoints hf hm).fintype
+  let : LinearOrder K :=
+    LinearOrder.lift' (fun p : K => f p.val)
+      (fun p q h => Subtype.ext (hinj p.property q.property h))
+  have hstep (p : K) :
+    Degree.FiniteCells.Built (Module.finrank ℝ E) { x : M // f x ≤ f p + (c p).radius ^ 2 } := by
+    induction p using WellFoundedLT.induction with
+    | ind p
+      ih =>
+      have hlower :
+        Degree.FiniteCells.Built (Module.finrank ℝ E) { x : M // f x ≤ f p - (c p).radius ^ 2 } :=
+        by
+        by_cases hex : ∃ q : K, q < p
+        · let s : Finset K := Finset.univ.filter (fun q => q < p)
+          have hs : s.Nonempty := by
+            obtain ⟨q, hq⟩ := hex
+            exact ⟨q, Finset.mem_filter.mpr ⟨Finset.mem_univ _, hq⟩⟩
+          let q := s.max' hs
+          have hqp : q < p := (Finset.mem_filter.mp (s.max'_mem hs)).2
+          have hgap : f q + (c q).radius ^ 2 < f p - (c p).radius ^ 2 :=
+            upper_lt_lower_of_disjoint (c q) (c p) (hdis q p (ne_of_lt hqp)) hqp
+          obtain ⟨e, _⟩ :=
+            Smale.FlowConstruction.exists_regularSublevelHomotopyEquiv hf hgap.le
+              (by
+                intro x hx hcrit
+                let r : K := ⟨x, hcrit⟩
+                have hrp : r < p := by
+                  change f x < f p
+                  nlinarith [sq_pos_of_pos (c p).radius_pos, hx.2]
+                have hrq : r ≤ q := s.le_max' r (Finset.mem_filter.mpr ⟨Finset.mem_univ _, hrp⟩)
+                change f x ≤ f q at hrq
+                nlinarith [sq_pos_of_pos (c q).radius_pos, hx.1])
+          exact Degree.FiniteCells.Built.equiv e (ih q hqp)
+        · let : IsEmpty { x : M // f x ≤ f p - (c p).radius ^ 2 } :=
+            isEmpty_sublevel_of_no_critical hf
+              (by
+                intro x hx hle
+                apply hex
+                refine ⟨⟨x, hx⟩, ?_⟩
+                change f x < f p
+                nlinarith [sq_pos_of_pos (c p).radius_pos])
+          exact Degree.FiniteCells.Built.empty _
+      apply Degree.FiniteCells.Built.equiv (c p).comparison
+      exact
+        Degree.FiniteCells.Built.attach _
+          (coreCellMap (c p).chart (c p).radius (c p).radius_pos (c p).block)
+          (fun u hu =>
+            (coreCellMap_lower_iff (c p).chart (c p).radius (c p).radius_pos (c p).block u).mpr
+              hu)
+          (c p).dimension_le hlower
+  exact hstep p
+
+private theorem
+    Degree.MorseCells.built_of_compact_smooth_manifold {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] :
+    Degree.FiniteCells.Built (Module.finrank ℝ E) M := by
+  classical
+    cases isEmpty_or_nonempty M with
+  | inl h => exact Degree.FiniteCells.Built.empty _
+  | inr
+    h =>
+    obtain ⟨f, hf, hm, _, hinj⟩ :=
+      Smale.ManifoldMorse.exists_morse_function_with_distinct_critical_values E M
+    obtain ⟨c, hdis⟩ := exists_disjoint_cells hf hm hinj
+    obtain ⟨p, _, hmax⟩ :=
+      isCompact_univ.exists_isMaxOn (Set.univ_nonempty) hf.continuous.continuousOn
+    have hp : p ∈ Smale.ManifoldMorse.criticalPoints E f :=
+      Smale.ManifoldMorse.mem_criticalPoints_of_localMax hf
+        (Filter.Eventually.of_forall (fun y => hmax (Set.mem_univ y)))
+    let q : Smale.ManifoldMorse.criticalPoints E f := ⟨p, hp⟩
+    have hb := built_upper_sublevels hf hm hinj c hdis q
+    have hfull : {x : M | f x ≤ f q + (c q).radius ^ 2} = Set.univ := by
+      apply Set.eq_univ_of_forall
+      intro x
+      change f x ≤ f p + (c q).radius ^ 2
+      exact (hmax (Set.mem_univ x)).trans (le_add_of_nonneg_right (sq_nonneg (c q).radius))
+    exact
+      Degree.FiniteCells.Built.equiv
+        ((Homeomorph.setCongr hfull).trans (Homeomorph.Set.univ M)).toHomotopyEquiv hb
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_compact SpecialPeriods.Threefold.space_t2Space
+    SpecialPeriods.Threefold.space_isSmoothRealManifold in
+private theorem Degree.Threefold.finite_homotopy_cells :
+    Degree.FiniteCells.Built 6 SpecialPeriods.Threefold.Space := by
+  simpa only [SpecialPeriods.Threefold.real_dimension] using
+    (Degree.MorseCells.built_of_compact_smooth_manifold (E := ℂ × ComplexPlane₂) (M :=
+      SpecialPeriods.Threefold.Space))
+
+private theorem Degree.exists_right_homotopy_inverse (x : SpecialPeriods.Threefold.Space) :
+    ∃ g : C(SpecialPeriods.Threefold.Space, SixSphereCube.StandardSphere),
+      ((SpecialPeriods.Threefold.SphereHomologyEquivalence.sphereMap x).comp g).Homotopic
+        (ContinuousMap.id SpecialPeriods.Threefold.Space) :=
+  FiniteCells.mapsLift_of_built (SpecialPeriods.Threefold.SphereHomologyEquivalence.sphereMap x)
+    (TopCellLifting.sphereMap_relativeDiskLifting_six x) Threefold.finite_homotopy_cells
+    (ContinuousMap.id SpecialPeriods.Threefold.Space)
+
+private def Degree.cylinderQuotient :
+    C((unitInterval) × (Fin 6 → (unitInterval)), (unitInterval) × SixSphereCube.StandardSphere) :=
+  (ContinuousMap.id (unitInterval)).prodMap SixSphereCube.cubeSphereMap
+
+private theorem Degree.cylinderQuotient_surjective : Function.Surjective cylinderQuotient := by
+  rintro ⟨t, z⟩
+  obtain ⟨u, rfl⟩ := SixSphereCube.cubeSphereMap_surjective z
+  exact ⟨(t, u), rfl⟩
+
+private theorem Degree.cylinderQuotient_isQuotientMap : Topology.IsQuotientMap cylinderQuotient :=
+  .of_surjective_continuous cylinderQuotient_surjective cylinderQuotient.continuous
+
+private theorem
+    Degree.cubeHomotopy_constant_on_cylinderFibres {X : Type*} [TopologicalSpace X] {x : X}
+    {p q : GenLoop (Fin 6) X x} (H : p.val.HomotopyRel q.val (Cube.boundary (Fin 6)))
+    (a b : (unitInterval) × (Fin 6 → (unitInterval)))
+    (h : cylinderQuotient a = cylinderQuotient b) : H a = H b := by
+  rcases a with ⟨t, u⟩
+  rcases b with ⟨s, v⟩
+  have ht : t = s := congrArg Prod.fst h
+  subst s
+  have huv : SixSphereCube.cubeSphereMap u = SixSphereCube.cubeSphereMap v := congrArg Prod.snd h
+  rcases (SixSphereCube.cubeSphereMap_eq_iff u v).mp huv with rfl | ⟨hu, hv⟩
+  · rfl
+  · exact
+      ((H.eq_fst t hu).trans (p.property u hu)).trans
+        ((H.eq_fst t hv).trans (p.property v hv)).symm
+
+private def
+    Degree.cubeHomotopyLift {X : Type*} [TopologicalSpace X] {x : X} {p q : GenLoop (Fin 6) X x}
+    (H : p.val.HomotopyRel q.val (Cube.boundary (Fin 6))) :
+    C((unitInterval) × SixSphereCube.StandardSphere, X) :=
+  cylinderQuotient_isQuotientMap.lift H.toHomotopy.toContinuousMap
+    (cubeHomotopy_constant_on_cylinderFibres H)
+
+private theorem Degree.cubeHomotopyLift_apply {X : Type*} [TopologicalSpace X] {x : X}
+    {p q : GenLoop (Fin 6) X x} (H : p.val.HomotopyRel q.val (Cube.boundary (Fin 6)))
+    (t : (unitInterval)) (u : Fin 6 → (unitInterval)) :
+    cubeHomotopyLift H (t, SixSphereCube.cubeSphereMap u) = H (t, u) :=
+  ContinuousMap.congr_fun
+    (cylinderQuotient_isQuotientMap.lift_comp H.toHomotopy.toContinuousMap
+      (cubeHomotopy_constant_on_cylinderFibres H))
+    (t, u)
+
+private def
+    Degree.factorHomotopy {X : Type*} [TopologicalSpace X] {x : X} {p q : GenLoop (Fin 6) X x}
+    (H : p.val.HomotopyRel q.val (Cube.boundary (Fin 6))) :
+    (SixSphereCube.factorMap p).HomotopyRel (SixSphereCube.factorMap q)
+      { SixSphereCube.sphereBasePoint }
+    where
+  toContinuousMap := cubeHomotopyLift H
+  map_zero_left
+    z := by
+    obtain ⟨u, rfl⟩ := SixSphereCube.cubeSphereMap_surjective z
+    change
+      cubeHomotopyLift H (0, SixSphereCube.cubeSphereMap u) =
+        SixSphereCube.factorMap p (SixSphereCube.cubeSphereMap u)
+    rw [cubeHomotopyLift_apply, H.apply_zero, SixSphereCube.factorMap_cubeSphereMap]
+    rfl
+  map_one_left
+    z := by
+    obtain ⟨u, rfl⟩ := SixSphereCube.cubeSphereMap_surjective z
+    change
+      cubeHomotopyLift H (1, SixSphereCube.cubeSphereMap u) =
+        SixSphereCube.factorMap q (SixSphereCube.cubeSphereMap u)
+    rw [cubeHomotopyLift_apply, H.apply_one, SixSphereCube.factorMap_cubeSphereMap]
+    rfl
+  prop' t z
+    hz := by
+    have hz' : z = SixSphereCube.sphereBasePoint := hz
+    subst z
+    change
+      cubeHomotopyLift H (t, SixSphereCube.sphereBasePoint) =
+        SixSphereCube.factorMap p SixSphereCube.sphereBasePoint
+    rw [← SixSphereCube.cubeSphereMap_boundary 0 SixSphereCube.zero_mem_cubeBoundary,
+      cubeHomotopyLift_apply]
+    rw [H.eq_fst t SixSphereCube.zero_mem_cubeBoundary, SixSphereCube.factorMap_cubeSphereMap]
+    rfl
+
+private theorem Degree.factorMap_homotopicRel {X : Type*} [TopologicalSpace X] {x : X}
+    {p q : GenLoop (Fin 6) X x} (h : GenLoop.Homotopic p q) :
+    (SixSphereCube.factorMap p).HomotopicRel (SixSphereCube.factorMap q)
+      { SixSphereCube.sphereBasePoint } := by
+  obtain ⟨H⟩ := h
+  exact ⟨factorHomotopy H⟩
+
+private theorem Degree.SphereBasepoint.exists_adjustment {Y : Type*} [TopologicalSpace Y] {y : Y}
+    (u : C(SixSphereCube.StandardSphere, Y)) (P : Path (u SixSphereCube.sphereBasePoint) y) :
+    ∃ v : C(SixSphereCube.StandardSphere, Y),
+      v SixSphereCube.sphereBasePoint = y ∧ u.Homotopic v := by
+  let V := Fin 6 → ℝ
+  let L : V ≃L[ℝ] V := ContinuousLinearEquiv.refl ℝ V
+  let e := Degree.DiskCube.homeomorph L
+  let f : C(Degree.DiskCylinder.Disk (E := V), Y) :=
+    u.comp (SixSphereCube.cubeSphereMap.comp (e : C(_, _)))
+  let side : C((unitInterval) × Degree.DiskCylinder.Sphere (E := V), Y) :=
+    P.toContinuousMap.comp ContinuousMap.fst
+  have h0 : ∀ s, side (0, s) = f (Degree.DiskCylinder.boundaryToDisk s) := by
+    intro s
+    have hs :=
+      (Degree.DiskCube.boundary_iff L (Degree.DiskCylinder.boundaryToDisk s)).mpr
+        (mem_sphere_zero_iff_norm.mp s.property)
+    exact P.source.trans (congrArg u (SixSphereCube.cubeSphereMap_boundary _ hs)).symm
+  let W := Degree.DiskCylinder.extend f side h0
+  let C : C((unitInterval) × (Fin 6 → (unitInterval)), Y) :=
+    W.comp ((ContinuousMap.id (unitInterval)).prodMap (e.symm : C(_, _)))
+  have hCboundary (t : (unitInterval)) (z : Fin 6 → (unitInterval))
+    (hz : z ∈ Cube.boundary (Fin 6)) : C (t, z) = P t := by
+    let s : Degree.DiskCylinder.Sphere (E := V) :=
+      ⟨(e.symm z).val,
+        mem_sphere_zero_iff_norm.mpr ((Degree.DiskCube.symm_boundary_iff L z).mpr hz)⟩
+    exact Degree.DiskCylinder.extend_side f side h0 t s
+  have hfib : ∀ a b, Degree.cylinderQuotient a = Degree.cylinderQuotient b → C a = C b := by
+    rintro ⟨t, z⟩ ⟨s, w⟩ h
+    have ht : t = s := congrArg Prod.fst h
+    subst s
+    have hzw : SixSphereCube.cubeSphereMap z = SixSphereCube.cubeSphereMap w :=
+      congrArg Prod.snd h
+    rcases (SixSphereCube.cubeSphereMap_eq_iff z w).mp hzw with rfl | ⟨hz, hw⟩
+    · rfl
+    · exact (hCboundary t z hz).trans (hCboundary t w hw).symm
+  let G := Degree.cylinderQuotient_isQuotientMap.lift C hfib
+  have hG (t : (unitInterval)) (z : Fin 6 → (unitInterval)) :
+    G (t, SixSphereCube.cubeSphereMap z) = C (t, z) :=
+    ContinuousMap.congr_fun (Degree.cylinderQuotient_isQuotientMap.lift_comp C hfib) (t, z)
+  let v : C(SixSphereCube.StandardSphere, Y) :=
+    G.comp ⟨fun z => (1, z), continuous_const.prodMk continuous_id⟩
+  refine
+    ⟨v, ?_,
+      ⟨{  toContinuousMap := G
+          map_zero_left := ?_
+          map_one_left := fun _ => rfl }⟩⟩
+  · change G (1, SixSphereCube.sphereBasePoint) = y
+    rw [← SixSphereCube.cubeSphereMap_boundary 0 SixSphereCube.zero_mem_cubeBoundary, hG]
+    exact (hCboundary 1 0 SixSphereCube.zero_mem_cubeBoundary).trans P.target
+  · intro z
+    obtain ⟨w, rfl⟩ := SixSphereCube.cubeSphereMap_surjective z
+    exact
+      (hG 0 w).trans
+        ((Degree.DiskCylinder.extend_bottom f side h0 (e.symm w)).trans
+          (congrArg (fun q => u (SixSphereCube.cubeSphereMap q)) (e.apply_symm_apply w)))
+
+private def Degree.basedSphereCube {X : Type} [TopologicalSpace X] {x : X}
+    (f : C(SixSphereCube.StandardSphere, X)) (hf : f SixSphereCube.sphereBasePoint = x) :
+    GenLoop (Fin 6) X x :=
+  ⟨f.comp SixSphereCube.cubeSphereMap, by
+    intro u hu
+    change f (SixSphereCube.cubeSphereMap u) = x
+    rw [SixSphereCube.cubeSphereMap_boundary u hu]
+    exact hf⟩
+
+@[simp]
+private theorem Degree.factorMap_basedSphereCube {X : Type} [TopologicalSpace X] {x : X}
+    (f : C(SixSphereCube.StandardSphere, X)) (hf : f SixSphereCube.sphereBasePoint = x) :
+    SixSphereCube.factorMap (basedSphereCube f hf) = f := by
+  symm
+  apply SixSphereCube.factorMap_unique
+  rfl
+
+private theorem Degree.basedSphereCube_homologyClass {X : Type} [TopologicalSpace X] {x : X}
+    (f : C(SixSphereCube.StandardSphere, X)) (hf : f SixSphereCube.sphereBasePoint = x) :
+    SixthHurewicz.cubeHomologyClass (basedSphereCube f hf) =
+      SingularMayerVietoris.singularHomologyMap f 6
+        (SixthHurewicz.cubeHomologyClass SixSphereCube.cubeSphereLoop) := by
+  rw [← SixSphereCube.factor_cubeHomologyClass, factorMap_basedSphereCube]
+
+private theorem Degree.sphere_homotopicRel_of_topClass_eq {X : Type} [TopologicalSpace X] {x : X}
+    [SimplyConnectedSpace X] [Subsingleton (π_ 2 X x)] [Subsingleton (π_ 3 X x)]
+    [Subsingleton (π_ 4 X x)] [Subsingleton (π_ 5 X x)] (f g : C(SixSphereCube.StandardSphere, X))
+    (hf : f SixSphereCube.sphereBasePoint = x) (hg : g SixSphereCube.sphereBasePoint = x)
+    (h :
+      SingularMayerVietoris.singularHomologyMap f 6
+          (SixthHurewicz.cubeHomologyClass SixSphereCube.cubeSphereLoop) =
+        SingularMayerVietoris.singularHomologyMap g 6
+          (SixthHurewicz.cubeHomologyClass SixSphereCube.cubeSphereLoop)) :
+    f.HomotopicRel g { SixSphereCube.sphereBasePoint } := by
+  have he : (⟦basedSphereCube f hf⟧ : π_ 6 X x) = ⟦basedSphereCube g hg⟧ := by
+    apply (SixthHurewicz.hurewiczPi6Equiv x).injective
+    change
+      Multiplicative.ofAdd (SixthHurewicz.cubeHomologyClass (basedSphereCube f hf)) =
+        Multiplicative.ofAdd (SixthHurewicz.cubeHomologyClass (basedSphereCube g hg))
+    rw [basedSphereCube_homologyClass, basedSphereCube_homologyClass, h]
+  have hh := factorMap_homotopicRel (Quotient.exact he)
+  simpa only [factorMap_basedSphereCube] using hh
+
+private theorem Degree.Sphere.based_homotopicRel_id_of_topClass
+    (g : C(SixSphereCube.StandardSphere, SixSphereCube.StandardSphere))
+    (hg : g SixSphereCube.sphereBasePoint = SixSphereCube.sphereBasePoint)
+    (hd :
+      SingularMayerVietoris.singularHomologyMap g 6
+          (SixthHurewicz.cubeHomologyClass SixSphereCube.cubeSphereLoop) =
+        SixthHurewicz.cubeHomologyClass SixSphereCube.cubeSphereLoop) :
+    g.HomotopicRel (ContinuousMap.id SixSphereCube.StandardSphere)
+      { SixSphereCube.sphereBasePoint } := by
+  let := piTwo_subsingleton SixSphereCube.sphereBasePoint
+  let := piThree_subsingleton SixSphereCube.sphereBasePoint
+  let := piFour_subsingleton SixSphereCube.sphereBasePoint
+  let := piFive_subsingleton SixSphereCube.sphereBasePoint
+  apply
+    Degree.sphere_homotopicRel_of_topClass_eq g (ContinuousMap.id SixSphereCube.StandardSphere) hg
+      rfl
+  simpa only [PeriodTorusHigherHomology.singularHomologyMap_id, LinearMap.id_apply] using hd
+
+private theorem Degree.Sphere.homotopic_id_of_topClass
+    (g : C(SixSphereCube.StandardSphere, SixSphereCube.StandardSphere))
+    (hd :
+      SingularMayerVietoris.singularHomologyMap g 6
+          (SixthHurewicz.cubeHomologyClass SixSphereCube.cubeSphereLoop) =
+        SixthHurewicz.cubeHomologyClass SixSphereCube.cubeSphereLoop) :
+    g.Homotopic (ContinuousMap.id SixSphereCube.StandardSphere) := by
+  obtain ⟨v, hv, hgv⟩ :=
+    Degree.SphereBasepoint.exists_adjustment g
+      (PathConnectedSpace.somePath (g SixSphereCube.sphereBasePoint)
+        SixSphereCube.sphereBasePoint)
+  have hmap := PeriodTorusHigherHomology.homotopic_homologyMap hgv 6
+  have hvd :
+    SingularMayerVietoris.singularHomologyMap v 6
+        (SixthHurewicz.cubeHomologyClass SixSphereCube.cubeSphereLoop) =
+      SixthHurewicz.cubeHomologyClass SixSphereCube.cubeSphereLoop :=
+    (LinearMap.congr_fun hmap _).symm.trans hd
+  obtain ⟨H⟩ := based_homotopicRel_id_of_topClass v hv hvd
+  exact hgv.trans ⟨H.toHomotopy⟩
+
+private theorem Degree.right_inverse_is_left_inverse (x : SpecialPeriods.Threefold.Space)
+    (g : C(SpecialPeriods.Threefold.Space, SixSphereCube.StandardSphere))
+    (hfg :
+      ((SpecialPeriods.Threefold.SphereHomologyEquivalence.sphereMap x).comp g).Homotopic
+        (ContinuousMap.id SpecialPeriods.Threefold.Space)) :
+    (g.comp (SpecialPeriods.Threefold.SphereHomologyEquivalence.sphereMap x)).Homotopic
+      (ContinuousMap.id SixSphereCube.StandardSphere) := by
+  let F := SpecialPeriods.Threefold.SphereHomologyEquivalence.sphereMap x
+  have hh : (F.comp (g.comp F)).Homotopic F := by
+    simpa only [ContinuousMap.comp_assoc, ContinuousMap.id_comp] using
+      hfg.comp (ContinuousMap.Homotopic.refl F)
+  apply Sphere.homotopic_id_of_topClass
+  apply (SpecialPeriods.Threefold.SphereHomologyEquivalence.homologyMap_bijective x 6).1
+  have he :=
+    LinearMap.congr_fun (PeriodTorusHigherHomology.homotopic_homologyMap hh 6)
+      (SixthHurewicz.cubeHomologyClass SixSphereCube.cubeSphereLoop)
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply] at he
+  exact he
+
+private def Degree.sphereHomotopyEquiv (x : SpecialPeriods.Threefold.Space) :
+    SixSphereCube.StandardSphere ≃ₕ SpecialPeriods.Threefold.Space := by
+  let g := Classical.choose (exists_right_homotopy_inverse x)
+  have hfg := Classical.choose_spec (exists_right_homotopy_inverse x)
+  exact
+    { toFun := SpecialPeriods.Threefold.SphereHomologyEquivalence.sphereMap x
+      invFun := g
+      left_inv := right_inverse_is_left_inverse x g hfg
+      right_inv := hfg }
+
+private def Degree.threefoldHomotopyEquiv :
+    SpecialPeriods.Threefold.Space ≃ₕ Metric.sphere (0 : EuclideanSpace ℝ (Fin 7)) 1 :=
+  (sphereHomotopyEquiv (Classical.choice SpecialPeriods.Threefold.space_nonempty)).symm
+
+private theorem MorseCancel.nativeMorseCount_eq_interval_length {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+        {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (k a b : ℕ) (hab : a ≤ b) (hb : b ≤ S.count)
+    (hindex : ∀ i : Fin S.count, nativeMorseIndex E f (S.point i) = k ↔ a ≤ i.val ∧ i.val < b) :
+    nativeMorseCount E f k = b - a := by
+  let K : Set M := {x | x ∈ Smale.ManifoldMorse.criticalPoints E f ∧ nativeMorseIndex E f x = k}
+  let u : Fin (b - a) → K := fun j =>
+    ⟨(S.point ⟨a + j.val, by omega⟩).val, (S.point ⟨a + j.val, by omega⟩).property,
+      (hindex ⟨a + j.val, by omega⟩).mpr
+        (show a ≤ a + j.val ∧ a + j.val < b from ⟨by omega, by omega⟩)⟩
+  have hu : Function.Bijective u := by
+    constructor
+    · intro i j hij
+      have hv : (u i).val = (u j).val := congrArg Subtype.val hij
+      have hp : S.point ⟨a + i.val, by omega⟩ = S.point ⟨a + j.val, by omega⟩ := Subtype.ext hv
+      have he := congrArg Fin.val (S.point.injective hp)
+      exact Fin.ext (by simpa only [Nat.add_left_cancel_iff] using he)
+    · intro x
+      let i := S.point.symm ⟨x.val, x.property.1⟩
+      have hi : S.point i = ⟨x.val, x.property.1⟩ := S.point.apply_symm_apply _
+      have hxi : nativeMorseIndex E f (S.point i) = k := by
+        rw [hi]
+        exact x.property.2
+      have hib := (hindex i).mp hxi
+      refine ⟨⟨i.val - a, by omega⟩, ?_⟩
+      apply Subtype.ext
+      change (S.point ⟨a + (i.val - a), _⟩).val = x.val
+      have he : (⟨a + (i.val - a), by omega⟩ : Fin S.count) = i :=
+        Fin.ext (show a + (i.val - a) = i.val by omega)
+      rw [he, hi]
+  have hc := (Nat.card_congr (Equiv.ofBijective u hu)).symm
+  change K.ncard = b - a
+  rw [← Nat.card_coe_set_eq]
+  simpa only [Nat.card_fin] using hc
+
+private theorem MorseCancel.native_middle_block_counts {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] [Nonempty M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (r c : ℕ)
+    (htwo : S.HasIndexTwoPrefix r) (hc : r + c < S.count) (hthree : S.HasIndexThreeBlock r c)
+    (hafter :
+      ∀ i : Fin S.count,
+        r + c < i.val → 4 ≤ Module.finrank ℝ (S.data (S.point i)).chart.NegativeCoordinates) :
+    nativeMorseCount E f 2 = r ∧ nativeMorseCount E f 3 = c := by
+  have hn := S.count_pos hf
+  have hi0 (i : Fin S.count) (hi : i.val = 0) : nativeMorseIndex E f (S.point i) = 0 := by
+    have he : i = ⟨0, hn⟩ := Fin.ext hi
+    rw [he]
+    exact (nativeMorseIndex_eq_chart (S.data (S.first hn)).chart).trans (S.first_index_zero hf hn)
+  have hi2 (i : Fin S.count) (hi : 0 < i.val) (hir : i.val ≤ r) :
+    nativeMorseIndex E f (S.point i) = 2 :=
+    (nativeMorseIndex_eq_chart (S.data (S.point i)).chart).trans (htwo i hi hir)
+  have hi3 (i : Fin S.count) (hri : r < i.val) (hic : i.val ≤ r + c) :
+    nativeMorseIndex E f (S.point i) = 3 :=
+    (nativeMorseIndex_eq_chart (S.data (S.point i)).chart).trans (hthree i hri hic)
+  have hi4 (i : Fin S.count) (hic : r + c < i.val) : 4 ≤ nativeMorseIndex E f (S.point i) := by
+    rw [nativeMorseIndex_eq_chart (S.data (S.point i)).chart]
+    exact hafter i hic
+  have hcases (i : Fin S.count) :
+    (i.val = 0 ∧ nativeMorseIndex E f (S.point i) = 0) ∨
+      (0 < i.val ∧ i.val ≤ r ∧ nativeMorseIndex E f (S.point i) = 2) ∨
+        (r < i.val ∧ i.val ≤ r + c ∧ nativeMorseIndex E f (S.point i) = 3) ∨
+          (r + c < i.val ∧ 4 ≤ nativeMorseIndex E f (S.point i)) := by
+    by_cases hz : i.val = 0
+    · exact Or.inl ⟨hz, hi0 i hz⟩
+    by_cases hr : i.val ≤ r
+    · exact Or.inr (Or.inl ⟨by omega, hr, hi2 i (by omega) hr⟩)
+    by_cases hrc : i.val ≤ r + c
+    · exact Or.inr (Or.inr (Or.inl ⟨by omega, hrc, hi3 i (by omega) hrc⟩))
+    · exact Or.inr (Or.inr (Or.inr ⟨by omega, hi4 i (by omega)⟩))
+  constructor
+  · have hh :=
+      nativeMorseCount_eq_interval_length S 2 1 (r + 1) (by omega) (by omega)
+        (fun i => by have h := hcases i; omega)
+    simpa only [Nat.add_sub_cancel_right] using hh
+  · have hh :=
+      nativeMorseCount_eq_interval_length S 3 (r + 1) (r + c + 1) (by omega) (by omega)
+        (fun i => by have h := hcases i; omega)
+    have he : r + c + 1 - (r + 1) = c := by omega
+    simpa only [he] using hh
+
+private theorem AdaptedWindows.attaching_sphere_reaches_of_compact_basin_section {E M X : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    [TopologicalSpace X] [CompactSpace X] (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f) (n : ℕ)
+    [Fact (Module.finrank ℝ (S.data p).chart.NegativeCoordinates = n + 1)]
+    [PreconnectedSpace (Smale.Hemisphere.Sphere n)] {a : ℝ}
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (α : C(X, { y : M // f y = a })) (x₀ : X)
+    (hfull :
+      ∀ y, y ∈ Set.range α ↔ Filter.Tendsto (fun t => S.flow t y.val) Filter.atBot (𝓝 p.val)) :
+    ∀ u : Metric.sphere (0 : (S.data p).chart.NegativeCoordinates) 1,
+      ((S.data p).surgery.attachingSphere u).val ∈
+        Degree.FlowCancellation.levelBasin S.flow f a := by
+  let _ := Smale.RegularLevel.chartedSpace hf ha
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data p).lower_regular
+  have hback (x : X) := (hfull (α x)).mp (Set.mem_range_self x)
+  have hreach (x : X) :=
+    S.backward_basin_reaches_attaching_level hf p (ha (α x).val (α x).property) (hback x)
+  obtain ⟨t₀, ht₀⟩ := hreach x₀
+  obtain ⟨D, hsource, htarget, horbit⟩ :=
+    S.exists_native_level_basin_transport hf ha (S.data p).lower_regular (α x₀)
+      ⟨S.flow t₀ (α x₀).val, ht₀⟩
+  have hsrc (x : X) : α x ∈ D.source := hsource.symm ▸ hreach x
+  let β : X → (S.data p).LowerLevel := D ∘ α
+  have hβ : Continuous β := by
+    apply continuous_iff_continuousAt.mpr
+    intro x
+    exact
+      (D.contMDiffOn_toFun.continuousOn.continuousAt (D.open_source.mem_nhds (hsrc x))).comp
+        α.continuous.continuousAt
+  have hβback (x : X) : Filter.Tendsto (fun t => S.flow t (β x).val) Filter.atBot (𝓝 p.val) := by
+    obtain ⟨t, ht⟩ := horbit (α x) (hsrc x)
+    change Filter.Tendsto (fun t => S.flow t (D (α x)).val) Filter.atBot (𝓝 p.val)
+    rw [← ht]
+    exact (MorseCancel.flow_time_atBot_limit_iff S.flow t (α x).val p.val).mpr (hback x)
+  let e :=
+    (Smale.SphereCoordinates.standardParametrization (S.data p).chart.NegativeCoordinates
+        n).toHomeomorph
+  let A : C(Smale.Hemisphere.Sphere n, (S.data p).LowerLevel) :=
+    (S.data p).surgery.attachingSphere.comp (e : C(_, _))
+  let U : Set (Smale.Hemisphere.Sphere n) := A ⁻¹' D.target
+  have hUeq : U = A ⁻¹' Set.range β := by
+    ext u
+    constructor
+    · intro hu
+      have hxu : D.symm (A u) ∈ D.source := D.map_target' hu
+      have hright : D (D.symm (A u)) = A u := D.right_inv' hu
+      obtain ⟨t, ht⟩ := horbit (D.symm (A u)) hxu
+      rw [hright] at ht
+      have hAback : Filter.Tendsto (fun t => S.flow t (A u).val) Filter.atBot (𝓝 p.val) :=
+        (S.attaching_basin_iff hf p (A u)).mpr ⟨e u, rfl⟩
+      have hxb : Filter.Tendsto (fun t => S.flow t (D.symm (A u)).val) Filter.atBot (𝓝 p.val) := by
+        rw [← ht] at hAback
+        exact (MorseCancel.flow_time_atBot_limit_iff S.flow t (D.symm (A u)).val p.val).mp hAback
+      obtain ⟨x, hx⟩ := (hfull (D.symm (A u))).mpr hxb
+      exact ⟨x, (congrArg D hx).trans hright⟩
+    · rintro ⟨x, hx⟩
+      change A u ∈ D.target
+      rw [← hx]
+      exact D.map_source' (hsrc x)
+  have hUopen : IsOpen U := D.open_target.preimage A.continuous
+  have hUclosed : IsClosed U := by
+    rw [hUeq]
+    exact (isCompact_range hβ).isClosed.preimage A.continuous
+  have hUne : U.Nonempty := by
+    obtain ⟨u, hu⟩ := (S.attaching_basin_iff hf p (β x₀)).mp (hβback x₀)
+    obtain ⟨v, hv⟩ := e.surjective u
+    refine ⟨v, ?_⟩
+    change A v ∈ D.target
+    have heq : A v = β x₀ := by change (S.data p).surgery.attachingSphere (e v) = _; rw [hv, hu]
+    rw [heq]
+    exact D.map_source' (hsrc x₀)
+  have hUall : U = Set.univ := IsClopen.eq_univ ⟨hUclosed, hUopen⟩ hUne
+  intro u
+  obtain ⟨v, rfl⟩ := e.surjective u
+  have hv : A v ∈ D.target := show v ∈ U from hUall.symm ▸ Set.mem_univ v
+  rw [htarget] at hv
+  exact hv
+
+private theorem
+    MorseCancel.nativeIndexThreeAttachingSphere_regular {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f)
+    (hp : nativeMorseIndex E f p = 3) :
+    let _ := Smale.RegularLevel.chartedSpace hf (S.data p).lower_regular
+    ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ (nativeIndexThreeAttachingSphere S p hp) ∧
+      Topology.IsClosedEmbedding (nativeIndexThreeAttachingSphere S p hp) ∧
+        ∀ x,
+          Function.Injective
+            (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E)
+              (nativeIndexThreeAttachingSphere S p hp) x) := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data p).lower_regular
+  let _ : Fact (Module.finrank ℝ (S.data p).chart.NegativeCoordinates = 2 + 1) :=
+    ⟨(nativeMorseIndex_eq_chart (S.data p).chart).symm.trans hp⟩
+  let e := Smale.SphereCoordinates.standardParametrization (S.data p).chart.NegativeCoordinates 2
+  have hs :
+    ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ (nativeIndexThreeAttachingSphere S p hp) :=
+    ((S.data p).attaching_smooth hf 2).comp e.contMDiff
+  have hi : Function.Injective (nativeIndexThreeAttachingSphere S p hp) :=
+    (S.data p).attaching_isClosedEmbedding.injective.comp e.injective
+  refine ⟨hs, hs.continuous.isClosedEmbedding hi, ?_⟩
+  intro x
+  change
+    Function.Injective
+      (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ((S.data p).surgery.attachingSphere ∘ e) x)
+  rw [mfderiv_comp x (((S.data p).attaching_smooth hf 2).mdifferentiableAt (by simp))
+      (e.contMDiff.mdifferentiableAt (by simp))]
+  exact
+    ((S.data p).attaching_derivative_injective hf 2 (e x)).comp
+      (e.mfderivToContinuousLinearEquiv (by simp) x).injective
+
+private theorem AdaptedWindows.exists_canonical_basin_sphere {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f)
+    (hp : MorseCancel.nativeMorseIndex E f p = 3) {X : Type} [TopologicalSpace X] [CompactSpace X]
+    {a : ℝ} (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (α : C(X, { y : M // f y = a })) (x₀ : X)
+    (hfull :
+      ∀ y, y ∈ Set.range α ↔ Filter.Tendsto (fun t => S.flow t y.val) Filter.atBot (𝓝 p.val)) :
+    let _ := Smale.RegularLevel.chartedSpace hf ha
+    ∃ γ : C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }),
+      ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ γ ∧
+        Topology.IsClosedEmbedding γ ∧
+          (∀ x, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) γ x)) ∧
+            Set.range γ = Set.range α ∧
+              (∀ x,
+                  ∃ t : ℝ,
+                    S.flow t (MorseCancel.nativeIndexThreeAttachingSphere S p hp x).val =
+                      (γ x).val) ∧
+                ∀ y,
+                  y ∈ Set.range γ ↔
+                    Filter.Tendsto (fun t => S.flow t y.val) Filter.atBot (𝓝 p.val) := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data p).lower_regular
+  let _ := Smale.RegularLevel.chartedSpace hf ha
+  let _ : Fact (Module.finrank ℝ (S.data p).chart.NegativeCoordinates = 2 + 1) :=
+    ⟨(MorseCancel.nativeMorseIndex_eq_chart (S.data p).chart).symm.trans hp⟩
+  have hreach := S.attaching_sphere_reaches_of_compact_basin_section hf p 2 ha α x₀ hfull
+  obtain ⟨hs, he, hi⟩ := MorseCancel.nativeIndexThreeAttachingSphere_regular S hf p hp
+  let z₀ : (Smale.Hemisphere.Sphere 2) := Smale.Hemisphere.point Bool.true ⟨0, by simp⟩
+  obtain ⟨D, -, -, γ, hγ, hγi, hγd, -, -, horbit⟩ :=
+    S.exists_embedded_level_transport hf (S.data p).lower_regular ha
+      (MorseCancel.nativeIndexThreeAttachingSphere S p hp) z₀ hs he.injective hi
+      (fun z => hreach _)
+  have hγfull (y : { x : M // f x = a }) :
+    y ∈ Set.range γ ↔ Filter.Tendsto (fun t => S.flow t y.val) Filter.atBot (𝓝 p.val) :=
+    S.transported_attaching_range_iff hf p ha
+      (Smale.SphereCoordinates.standardParametrization (S.data p).chart.NegativeCoordinates 2)
+      (Smale.SphereCoordinates.standardParametrization (S.data p).chart.NegativeCoordinates
+          2).surjective
+      γ horbit y
+  exact
+    ⟨γ, hγ, hγ.continuous.isClosedEmbedding hγi, hγd,
+      Set.ext (fun y => (hγfull y).trans (hfull y).symm), horbit, hγfull⟩
+
+private theorem AdaptedWindows.exists_canonical_middle_family {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a : ℝ}
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f) {n : ℕ}
+    (p : Fin n → Smale.ManifoldMorse.criticalPoints E f)
+    (hp : ∀ j, MorseCancel.nativeMorseIndex E f (p j) = 3)
+    (α : Fin n → (Smale.Hemisphere.Sphere 2) → { y : M // f y = a })
+    (hα : MorseCancel.IsNativeMiddleBasinFamily S hf ha p α) :
+    ∃ γ : Fin n → (Smale.Hemisphere.Sphere 2) → { y : M // f y = a },
+      MorseCancel.IsNativeMiddleBasinFamily S hf ha p γ ∧
+        (∀ j, Set.range (γ j) = Set.range (α j)) ∧
+          ∀ j x,
+            ∃ t : ℝ,
+              S.flow t (MorseCancel.nativeIndexThreeAttachingSphere S (p j) (hp j) x).val =
+                (γ j x).val := by
+  let _ := Smale.RegularLevel.chartedSpace hf ha
+  obtain ⟨hαs, -, -, hαpair, hαfull⟩ := hα
+  let x₀ : (Smale.Hemisphere.Sphere 2) := Smale.Hemisphere.point Bool.true ⟨0, by simp⟩
+  have hex (j : Fin n) :=
+    S.exists_canonical_basin_sphere hf (p j) (hp j) ha ⟨α j, (hαs j).continuous⟩ x₀ (hαfull j)
+  choose γ hγs hγe hγi hγrange hγflow hγfull using hex
+  refine ⟨fun j => γ j, ⟨hγs, hγe, hγi, ?_, hγfull⟩, hγrange, hγflow⟩
+  intro i j hij
+  rw [hγrange i, hγrange j]
+  exact hαpair hij
+
+private def MorseCancel.levelSublevelMap {M : Type} [TopologicalSpace M] (f : M → ℝ) {a b : ℝ}
+    (hab : a ≤ b) : C({ y : M // f y = a }, { y : M // f y ≤ b }) :=
+  ⟨fun y => ⟨y.val, y.property.le.trans hab⟩, continuous_subtype_val.subtype_mk _⟩
+
+private theorem
+    AdaptedWindows.level_transport_homotopic_in_sublevel {E M X : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] {f : M → ℝ} [TopologicalSpace X]
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ} (hab : a < b)
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (g : C(X, { y : M // f y = b })) (γ : C(X, { y : M // f y = a }))
+    (horbit : ∀ x, ∃ t : ℝ, S.flow t (g x).val = (γ x).val) :
+    ContinuousMap.Homotopic ((MorseCancel.levelSublevelMap f le_rfl).comp g)
+      ((MorseCancel.levelSublevelMap f hab.le).comp γ) := by
+  have hboundary (y : M) (hy : f y = a) : mvfderiv 𝓘(ℝ, E) f y (S.field y) < 0 :=
+    S.descent y (ha y hy)
+  have hreach (x : X) : (g x).val ∈ Degree.FlowCancellation.levelBasin S.flow f a := by
+    obtain ⟨t, ht⟩ := horbit x
+    exact ⟨t, by rw [ht]; exact (γ x).property⟩
+  let θ : X → ℝ := fun x => Degree.FlowCancellation.signedLevelTime S.flow f a (g x).val
+  obtain ⟨hB, htime, -⟩ :=
+    Degree.FlowCancellation.smooth_signed_level_time hf S.smooth S.flow S.integral hboundary
+  have hθ : Continuous θ := by
+    apply continuous_iff_continuousAt.mpr
+    intro x
+    exact
+      ContinuousAt.comp (f := fun y : X => (g y).val)
+        (htime.continuousOn.continuousAt (hB.mem_nhds (hreach x)))
+        (continuous_subtype_val.comp g.continuous).continuousAt
+  have hhit (x : X) : f (S.flow (θ x) (g x).val) = a :=
+    Degree.FlowCancellation.signedLevelTime_hits S.flow f a (hreach x)
+  have hθpos (x : X) : 0 < θ x := by
+    by_contra h
+    have hh :=
+      Smale.FlowConstruction.antitone_flow_height hf S.flow S.integral S.zero S.descent (g x).val
+        (le_of_not_gt h)
+    change f (S.flow 0 (g x).val) ≤ f (S.flow (θ x) (g x).val) at hh
+    rw [S.flow.map_zero_apply, (g x).property, hhit x] at hh
+    exact not_le_of_gt hab hh
+  have hend (x : X) : S.flow (θ x) (g x).val = (γ x).val := by
+    obtain ⟨t, ht⟩ := horbit x
+    have hθt : θ x = t :=
+      Degree.FlowCancellation.signedLevelTime_eq_of_level S.flow hf.continuous
+        (MorseCancel.contMDiff_directionalDerivative hf S.smooth).continuous
+        (fun y s => Smale.FlowConstruction.hasDerivAt_comp_integralCurve hf (S.integral y) s)
+        hboundary (by rw [ht]; exact (γ x).property)
+    rw [hθt]
+    exact ht
+  have hstay (u : unitInterval) (x : X) : f (S.flow ((u : ℝ) * θ x) (g x).val) ≤ b := by
+    have hh :=
+      Smale.FlowConstruction.antitone_flow_height hf S.flow S.integral S.zero S.descent (g x).val
+        (mul_nonneg u.property.1 (hθpos x).le)
+    simpa only [S.flow.map_zero_apply, (g x).property] using hh
+  refine
+    ⟨{  toFun := fun z => ⟨S.flow ((z.1 : ℝ) * θ z.2) (g z.2).val, hstay z.1 z.2⟩
+        continuous_toFun :=
+          (S.flow.continuous
+                ((continuous_subtype_val.comp continuous_fst).mul (hθ.comp continuous_snd))
+                (continuous_subtype_val.comp (g.continuous.comp continuous_snd))).subtype_mk
+            _
+        map_zero_left := ?_
+        map_one_left := ?_ }⟩
+  · intro x
+    apply Subtype.ext
+    change S.flow ((0 : ℝ) * θ x) (g x).val = (g x).val
+    simp
+  · intro x
+    apply Subtype.ext
+    change S.flow ((1 : ℝ) * θ x) (g x).val = (γ x).val
+    simpa only [one_mul] using hend x
+
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.indexThreeAttachingClass_parametrized {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    [hindex : Fact (Module.finrank ℝ d.chart.NegativeCoordinates = 2 + 1)] :
+    d.indexThreeAttachingClass hindex.out =
+      SingularMayerVietoris.singularHomologyMap
+        (d.coreBoundaryMap.comp
+          (Smale.SphereCoordinates.standardParametrization d.chart.NegativeCoordinates
+              2).toHomeomorph.toHomotopyEquiv.toFun)
+        2 (SphereHomology.unitSphereTopClass 1) := by
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp]
+  rfl
+
+private def
+    MorseCancel.sublevelMap {M : Type} [TopologicalSpace M] (f : M → ℝ) {a b : ℝ} (hab : a ≤ b) :
+    C({ y : M // f y ≤ a }, { y : M // f y ≤ b }) :=
+  ⟨fun y => ⟨y.val, y.property.trans hab⟩, continuous_subtype_val.subtype_mk _⟩
+
+private def MorseCancel.middleSectionClass {M : Type} [TopologicalSpace M] {f : M → ℝ} {a : ℝ}
+    (γ : C((Smale.Hemisphere.Sphere 2), { y : M // f y = a })) :
+    SingularMayerVietoris.SingularHomology { y : M // f y ≤ a } 2 :=
+  SingularMayerVietoris.singularHomologyMap ((levelSublevelMap f le_rfl).comp γ) 2
+    (SphereHomology.unitSphereTopClass 1)
+
+private theorem
+    AdaptedWindows.native_attaching_class_of_flow_section {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f)
+    (hp : MorseCancel.nativeMorseIndex E f p = 3) {a : ℝ}
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hab : a < S.toSurgeryWindows.lower p)
+    (γ : C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (horbit :
+      ∀ x,
+        ∃ t : ℝ,
+          S.flow t (MorseCancel.nativeIndexThreeAttachingSphere S p hp x).val = (γ x).val) :
+    SingularMayerVietoris.singularHomologyMap (MorseCancel.sublevelMap f hab.le) 2
+        (MorseCancel.middleSectionClass γ) =
+      (S.data p).indexThreeAttachingClass
+        ((MorseCancel.nativeMorseIndex_eq_chart (S.data p).chart).symm.trans hp) := by
+  let _ : Fact (Module.finrank ℝ (S.data p).chart.NegativeCoordinates = 2 + 1) :=
+    ⟨(MorseCancel.nativeMorseIndex_eq_chart (S.data p).chart).symm.trans hp⟩
+  have hh :=
+    S.level_transport_homotopic_in_sublevel hf hab ha
+      (MorseCancel.nativeIndexThreeAttachingSphere S p hp) γ horbit
+  have hm := PeriodTorusHigherHomology.homotopic_homologyMap hh 2
+  have hparam :
+    SingularMayerVietoris.singularHomologyMap
+        ((MorseCancel.levelSublevelMap f (le_refl (S.toSurgeryWindows.lower p))).comp
+          (MorseCancel.nativeIndexThreeAttachingSphere S p hp))
+        2 (SphereHomology.unitSphereTopClass 1) =
+      (S.data p).indexThreeAttachingClass
+        ((MorseCancel.nativeMorseIndex_eq_chart (S.data p).chart).symm.trans hp) :=
+    (S.data p).indexThreeAttachingClass_parametrized.symm
+  rw [← hparam, hm]
+  rw [MorseCancel.middleSectionClass, ← LinearMap.comp_apply, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+  rfl
+
+private theorem
+    AdaptedWindows.exists_native_core_inclusion_equiv {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f) :
+    ∃ e :
+      ↥({y : M | f y ≤ S.toSurgeryWindows.lower p} ∪ Set.range (S.data p).coreMap) ≃ₕ
+        { y : M // f y ≤ S.toSurgeryWindows.upper p },
+      ∀ x, (e x).val = x.val := by
+  let d := S.data p
+  have hagreement :
+    ∀ x ∈ Set.range (d.chart.attachingHandleMap d.radius d.radius_pos d.block),
+      ∀ᶠ y in 𝓝 x, S.field y = d.chart.descentField y := by
+    rintro x ⟨z, rfl⟩
+    exact S.model_germ p _ (Smale.MorseHandle.modelMap_mem_product d.radius_pos z)
+  obtain ⟨B, hB⟩ :=
+    d.chart.exists_attachingUnionHomotopyEquiv hf S.smooth S.zero S.descent S.flow S.integral
+      d.radius d.radius_pos d.block hagreement (S.isolated p)
+  let C :=
+    Smale.ClosedHandleCore.unionHomotopyEquiv {y : M | f y ≤ S.toSurgeryWindows.lower p}
+      d.handleMap (isClosed_le hf.continuous continuous_const)
+      (d.chart.attachingHandleMap_isClosedEmbedding d.radius d.radius_pos d.block)
+      (d.chart.attachingHandleMap_lower_iff d.radius d.radius_pos d.block)
+  exact ⟨C.trans B, fun x => hB (C x)⟩
+
+private theorem AdaptedWindows.exists_core_inclusion_homology_comparison {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (p : Smale.ManifoldMorse.criticalPoints E f) (k : ℕ) :
+    ∃ A :
+      SingularMayerVietoris.SingularHomology
+          (↥({y : M | f y ≤ S.toSurgeryWindows.lower p} ∪ Set.range (S.data p).coreMap)) k ≃ₗ[ℤ]
+        SingularMayerVietoris.SingularHomology { y : M // f y ≤ S.toSurgeryWindows.upper p } k,
+      ∀ a,
+        A
+            (((S.data p).coreCellPresentation hf.continuous).oldHomologyMap k
+              ((S.data p).cellOldHomologyEquiv hf.continuous k a)) =
+          SingularMayerVietoris.singularHomologyMap
+            (MorseCancel.sublevelMap f
+              ((S.toSurgeryWindows.lower_lt_value p).trans
+                  (S.toSurgeryWindows.value_lt_upper p)).le)
+            k a := by
+  obtain ⟨B, hB⟩ := S.exists_native_core_inclusion_equiv hf p
+  let d := S.data p
+  let A := PeriodTorusHigherHomology.homotopyEquivHomologyEquiv B k
+  let old :=
+    (⟨Subtype.val, continuous_subtype_val⟩ :
+      C((d.coreCellPresentation hf.continuous).old,
+        ↥({y : M | f y ≤ S.toSurgeryWindows.lower p} ∪ Set.range d.coreMap)))
+  have hmaps :
+    (B.toFun.comp old).comp (d.cellOldHomeomorph hf.continuous).toHomotopyEquiv.toFun =
+      MorseCancel.sublevelMap f
+        ((S.toSurgeryWindows.lower_lt_value p).trans (S.toSurgeryWindows.value_lt_upper p)).le := by
+    apply ContinuousMap.ext
+    intro x
+    exact Subtype.ext (hB _)
+  refine ⟨A, ?_⟩
+  intro a
+  change
+    SingularMayerVietoris.singularHomologyMap B.toFun k
+        (SingularMayerVietoris.singularHomologyMap old k
+          (SingularMayerVietoris.singularHomologyMap
+            (d.cellOldHomeomorph hf.continuous).toHomotopyEquiv.toFun k a)) =
+      _
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp, ←
+    LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp, hmaps]
+  rfl
+
+private theorem AdaptedWindows.native_sublevel_inclusion_exact {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f) (k : ℕ)
+    (hk : k ≠ 0) :
+    LinearMap.range ((S.data p).coreBoundaryHomologyMap k) =
+      LinearMap.ker
+        (SingularMayerVietoris.singularHomologyMap
+          (MorseCancel.sublevelMap f
+            ((S.toSurgeryWindows.lower_lt_value p).trans
+                (S.toSurgeryWindows.value_lt_upper p)).le)
+          k) := by
+  obtain ⟨A, hA⟩ := S.exists_core_inclusion_homology_comparison hf p k
+  let d := S.data p
+  refine
+    Smale.HomologyTransport.exact_of_equivalences (LinearEquiv.refl ℤ _)
+      (d.cellOldHomologyEquiv hf.continuous k).symm A
+      ((d.coreCellPresentation hf.continuous).attachingHomologyMap k)
+      ((d.coreCellPresentation hf.continuous).oldHomologyMap k) (d.coreBoundaryHomologyMap k) _ ?_
+      ?_ ((d.coreCellPresentation hf.continuous).cell_exact_at_old k hk)
+  · intro a
+    change
+      d.coreBoundaryHomologyMap k a =
+        (d.cellOldHomologyEquiv hf.continuous k).symm
+          ((d.coreCellPresentation hf.continuous).attachingHomologyMap k a)
+    rw [d.cellAttachingHomology_compare, LinearEquiv.symm_apply_apply]
+  · intro a
+    have hh := hA ((d.cellOldHomologyEquiv hf.continuous k).symm a)
+    rw [LinearEquiv.apply_symm_apply] at hh
+    exact hh.symm
+
+private theorem
+    AdaptedWindows.native_index_three_inclusion_relation {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f)
+    (hp : MorseCancel.nativeMorseIndex E f p = 3) :
+    let I :=
+      SingularMayerVietoris.singularHomologyMap
+        (MorseCancel.sublevelMap f
+          ((S.toSurgeryWindows.lower_lt_value p).trans (S.toSurgeryWindows.value_lt_upper p)).le)
+        2
+    Function.Surjective I ∧
+      LinearMap.ker I =
+        Submodule.span ℤ
+          {(S.data p).indexThreeAttachingClass
+              ((MorseCancel.nativeMorseIndex_eq_chart (S.data p).chart).symm.trans hp)} := by
+  let d := S.data p
+  have hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 3 :=
+    (MorseCancel.nativeMorseIndex_eq_chart d.chart).symm.trans hp
+  let _ :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology (Metric.sphere (0 : d.chart.NegativeCoordinates) 1)
+        1) :=
+    d.attachingHomology_subsingleton_of_index 1 one_ne_zero (by omega) (by omega)
+  have hsurj : Function.Surjective ((d.coreCellPresentation hf.continuous).oldHomologyMap 2) := by
+    intro a
+    have ha : a ∈ LinearMap.ker ((d.coreCellPresentation hf.continuous).cellConnectingMap 1) :=
+      Subsingleton.elim _ _
+    rw [← (d.coreCellPresentation hf.continuous).cell_exact_at_ambient 1] at ha
+    exact ha
+  obtain ⟨A, hA⟩ := S.exists_core_inclusion_homology_comparison hf p 2
+  constructor
+  · intro a
+    obtain ⟨x, hx⟩ := hsurj (A.symm a)
+    refine ⟨(d.cellOldHomologyEquiv hf.continuous 2).symm x, ?_⟩
+    have hh := hA ((d.cellOldHomologyEquiv hf.continuous 2).symm x)
+    rw [LinearEquiv.apply_symm_apply, hx, LinearEquiv.apply_symm_apply] at hh
+    exact hh.symm
+  · rw [← S.native_sublevel_inclusion_exact hf p 2 (by decide), d.coreBoundary_two_range hindex]
+
+private theorem
+    MorseCancel.sublevelMap_trans {M : Type} [TopologicalSpace M]
+    (f : M → ℝ) {a b c : ℝ} (hab : a ≤ b) (hbc : b ≤ c) :
+    (sublevelMap f hbc).comp (sublevelMap f hab) = sublevelMap f (hab.trans hbc) :=
+  rfl
+
+private theorem MorseCancel.sublevelHomologyMap_comp {M : Type} [TopologicalSpace M]
+     (f : M → ℝ) {a b c : ℝ} (hab : a ≤ b) (hbc : b ≤ c) (k : ℕ) :
+    (SingularMayerVietoris.singularHomologyMap (sublevelMap f hbc) k).comp
+        (SingularMayerVietoris.singularHomologyMap (sublevelMap f hab) k) =
+      SingularMayerVietoris.singularHomologyMap (sublevelMap f (hab.trans hbc)) k := by
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp, sublevelMap_trans]
+
+private theorem MorseCancel.regular_sublevel_inclusion_bijective {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ} (hab : a ≤ b)
+    (hband : ∀ x, f x ∈ Set.Icc a b → x ∉ Smale.ManifoldMorse.criticalPoints E f) (k : ℕ) :
+    Function.Bijective (SingularMayerVietoris.singularHomologyMap (sublevelMap f hab) k) := by
+  obtain ⟨e, he⟩ := Smale.FlowConstruction.exists_regularSublevelHomotopyEquiv hf hab hband
+  have hmap : e.toFun = sublevelMap f hab := by
+    apply ContinuousMap.ext
+    intro x
+    exact Subtype.ext (he x)
+  have hh := (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv e k).bijective
+  change Function.Bijective (SingularMayerVietoris.singularHomologyMap e.toFun k) at hh
+  rwa [hmap] at hh
+
+private theorem
+    AdaptedWindows.middle_inclusion_step {E M : Type} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f)
+    (hp : MorseCancel.nativeMorseIndex E f p = 3) {a b : ℝ} (hab : a ≤ b)
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hbp : b < S.toSurgeryWindows.lower p)
+    (hband :
+      ∀ y,
+        f y ∈ Set.Icc b (S.toSurgeryWindows.lower p) → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (γ : C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (horbit :
+      ∀ x,
+        ∃ t : ℝ, S.flow t (MorseCancel.nativeIndexThreeAttachingSphere S p hp x).val = (γ x).val)
+    (hsurj :
+      Function.Surjective
+        (SingularMayerVietoris.singularHomologyMap (MorseCancel.sublevelMap f hab) 2)) :
+    let hau :=
+      (hab.trans hbp.le).trans
+        ((S.toSurgeryWindows.lower_lt_value p).trans (S.toSurgeryWindows.value_lt_upper p)).le
+    Function.Surjective
+        (SingularMayerVietoris.singularHomologyMap (MorseCancel.sublevelMap f hau) 2) ∧
+      LinearMap.ker
+          (SingularMayerVietoris.singularHomologyMap (MorseCancel.sublevelMap f hau) 2) =
+        LinearMap.ker
+            (SingularMayerVietoris.singularHomologyMap (MorseCancel.sublevelMap f hab) 2) ⊔
+          Submodule.span ℤ {MorseCancel.middleSectionClass γ} := by
+  let hl := (S.toSurgeryWindows.lower_lt_value p).trans (S.toSurgeryWindows.value_lt_upper p)
+  let P := SingularMayerVietoris.singularHomologyMap (MorseCancel.sublevelMap f hab) 2
+  let J := SingularMayerVietoris.singularHomologyMap (MorseCancel.sublevelMap f hbp.le) 2
+  let Q := SingularMayerVietoris.singularHomologyMap (MorseCancel.sublevelMap f hl.le) 2
+  have hJ : Function.Bijective J :=
+    MorseCancel.regular_sublevel_inclusion_bijective hf hbp.le hband 2
+  obtain ⟨hQ, hkerQ⟩ := S.native_index_three_inclusion_relation hf p hp
+  have hclass := S.native_attaching_class_of_flow_section hf p hp ha (hab.trans_lt hbp) γ horbit
+  have hcomp :
+    J.comp P =
+      SingularMayerVietoris.singularHomologyMap (MorseCancel.sublevelMap f (hab.trans hbp.le))
+        2 :=
+    MorseCancel.sublevelHomologyMap_comp f hab hbp.le 2
+  have htotal :
+    Q.comp (J.comp P) =
+      SingularMayerVietoris.singularHomologyMap
+        (MorseCancel.sublevelMap f ((hab.trans hbp.le).trans hl.le)) 2 := by
+    rw [hcomp]
+    exact MorseCancel.sublevelHomologyMap_comp f (hab.trans hbp.le) hl.le 2
+  have hkerJ : LinearMap.ker (J.comp P) = LinearMap.ker P := by
+    ext v
+    change J (P v) = 0 ↔ P v = 0
+    exact ⟨fun h => hJ.injective (h.trans (map_zero J).symm), fun h => by rw [h, map_zero]⟩
+  have hker :
+    LinearMap.ker Q = Submodule.span ℤ {(J.comp P) (MorseCancel.middleSectionClass γ)} := by
+    rw [hcomp, hclass]
+    exact hkerQ
+  constructor
+  · rw [← htotal]
+    exact hQ.comp (hJ.surjective.comp hsurj)
+  · rw [← htotal,
+      Smale.HomologyTransport.ker_comp_span_singleton (J.comp P) Q
+        (MorseCancel.middleSectionClass γ) hker,
+      hkerJ]
+
+private theorem MorseCancel.span_prefix_succ {A : Type} [AddCommGroup A] [Module ℤ A] {n k : ℕ}
+    (v : Fin n → A) (hk : k < n) :
+    Submodule.span ℤ (Set.range (fun j : Fin k => v ⟨j.val, j.isLt.trans hk⟩)) ⊔
+        Submodule.span ℤ {v ⟨k, hk⟩} =
+      Submodule.span ℤ (Set.range (fun j : Fin (k + 1) => v ⟨j.val, by omega⟩)) := by
+  have heq :
+    (fun j : Fin (k + 1) => v ⟨j.val, by omega⟩) =
+      Fin.snoc (fun j : Fin k => v ⟨j.val, j.isLt.trans hk⟩) (v ⟨k, hk⟩) := by
+    funext j
+    cases j using Fin.lastCases <;> simp
+  rw [heq, Fin.range_snoc, Submodule.span_insert, sup_comm]
+
+private theorem AdaptedWindows.finite_middle_inclusion_relations {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (n : ℕ)
+    (p : Fin n → Smale.ManifoldMorse.criticalPoints E f)
+    (hp : ∀ j, MorseCancel.nativeMorseIndex E f (p j) = 3) (cut : Fin (n + 1) → ℝ)
+    (ha : ∀ y, f y = cut 0 → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hbase : ∀ i, cut 0 ≤ cut i) (hnext : ∀ j, cut j.succ = S.toSurgeryWindows.upper (p j))
+    (hlower : ∀ j, cut j.castSucc < S.toSurgeryWindows.lower (p j))
+    (hband :
+      ∀ j y,
+        f y ∈ Set.Icc (cut j.castSucc) (S.toSurgeryWindows.lower (p j)) →
+          y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = cut 0 }))
+    (horbit :
+      ∀ j x,
+        ∃ t : ℝ,
+          S.flow t (MorseCancel.nativeIndexThreeAttachingSphere S (p j) (hp j) x).val =
+            (γ j x).val) :
+    Function.Surjective
+        (SingularMayerVietoris.singularHomologyMap
+          (MorseCancel.sublevelMap f (hbase (Fin.last n))) 2) ∧
+      LinearMap.ker
+          (SingularMayerVietoris.singularHomologyMap
+            (MorseCancel.sublevelMap f (hbase (Fin.last n))) 2) =
+        Submodule.span ℤ (Set.range (fun j => MorseCancel.middleSectionClass (γ j))) := by
+  have hprefix (k : ℕ) :
+    ∀ hk : k ≤ n,
+      Function.Surjective
+          (SingularMayerVietoris.singularHomologyMap
+            (MorseCancel.sublevelMap f (hbase ⟨k, by omega⟩)) 2) ∧
+        LinearMap.ker
+            (SingularMayerVietoris.singularHomologyMap
+              (MorseCancel.sublevelMap f (hbase ⟨k, by omega⟩)) 2) =
+          Submodule.span ℤ
+            (Set.range
+              (fun j : Fin k =>
+                MorseCancel.middleSectionClass (γ ⟨j.val, j.isLt.trans_le hk⟩))) := by
+    induction k with
+    | zero =>
+      intro hk
+      have hid :
+        SingularMayerVietoris.singularHomologyMap
+            (MorseCancel.sublevelMap f (hbase ⟨0, by omega⟩)) 2 =
+          LinearMap.id := by
+        change
+          SingularMayerVietoris.singularHomologyMap (ContinuousMap.id { y : M // f y ≤ cut 0 })
+              2 =
+            _
+        exact PeriodTorusHigherHomology.singularHomologyMap_id _ _
+      constructor
+      · rw [hid]
+        exact Function.surjective_id
+      · rw [hid]
+        simp only [Set.range_eq_empty, Submodule.span_empty]
+        ext v
+        rfl
+    | succ k ih =>
+      intro hk
+      have hkn : k < n := by omega
+      let j : Fin n := ⟨k, hkn⟩
+      obtain ⟨hprev, hkernel⟩ := ih (by omega)
+      have hstep :=
+        S.middle_inclusion_step hf (p j) (hp j) (hbase j.castSucc) ha (hlower j) (hband j) (γ j)
+          (horbit j) hprev
+      have hstep' :
+        Function.Surjective
+            (SingularMayerVietoris.singularHomologyMap
+              (MorseCancel.sublevelMap f (hbase ⟨k + 1, by omega⟩)) 2) ∧
+          LinearMap.ker
+              (SingularMayerVietoris.singularHomologyMap
+                (MorseCancel.sublevelMap f (hbase ⟨k + 1, by omega⟩)) 2) =
+            LinearMap.ker
+                (SingularMayerVietoris.singularHomologyMap
+                  (MorseCancel.sublevelMap f (hbase j.castSucc)) 2) ⊔
+              Submodule.span ℤ {MorseCancel.middleSectionClass (γ j)} := by
+        have heq : cut ⟨k + 1, by omega⟩ = S.toSurgeryWindows.upper (p j) := hnext j
+        have aux (b : ℝ) (hb : cut 0 ≤ b) (he : b = S.toSurgeryWindows.upper (p j)) :
+          Function.Surjective
+              (SingularMayerVietoris.singularHomologyMap (MorseCancel.sublevelMap f hb) 2) ∧
+            LinearMap.ker
+                (SingularMayerVietoris.singularHomologyMap (MorseCancel.sublevelMap f hb) 2) =
+              LinearMap.ker
+                  (SingularMayerVietoris.singularHomologyMap
+                    (MorseCancel.sublevelMap f (hbase j.castSucc)) 2) ⊔
+                Submodule.span ℤ {MorseCancel.middleSectionClass (γ j)} := by
+          subst b
+          exact hstep
+        exact aux _ _ heq
+      refine ⟨hstep'.1, ?_⟩
+      rw [hstep'.2, hkernel]
+      exact MorseCancel.span_prefix_succ (fun i => MorseCancel.middleSectionClass (γ i)) hkn
+  simpa only using hprefix n le_rfl
+
+private def MorseCancel.nativeMiddleBaseCut {E M : Type} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (r n : ℕ) (hn : r + n < S.toSurgeryWindows.count) : ℝ :=
+  S.toSurgeryWindows.upper (S.toSurgeryWindows.point ⟨r, by omega⟩)
+
+private def
+    MorseCancel.nativeMiddleCutSequence {E M : Type} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    (S T : AdaptedWindows E f) (r n : ℕ) (hn : r + n < S.toSurgeryWindows.count) :
+    Fin (n + 1) → ℝ :=
+  Fin.cases (nativeMiddleBaseCut S r n hn)
+    (fun j => T.toSurgeryWindows.upper (nativeMiddleBlockPoint S r n hn j))
+
+private theorem MorseCancel.nativeMiddleCutSequence_bands {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} (S T : AdaptedWindows E f)
+    (r n : ℕ) (hn : r + n < S.toSurgeryWindows.count)
+    (hbefore :
+      ∀ j,
+        nativeMiddleBaseCut S r n hn <
+          T.toSurgeryWindows.lower (nativeMiddleBlockPoint S r n hn j)) :
+    let p := nativeMiddleBlockPoint S r n hn
+    let cut := nativeMiddleCutSequence S T r n hn
+    (∀ i, cut 0 ≤ cut i) ∧
+      (∀ j, cut j.succ = T.toSurgeryWindows.upper (p j)) ∧
+        (∀ j, cut j.castSucc < T.toSurgeryWindows.lower (p j)) ∧
+          ∀ j y,
+            f y ∈ Set.Icc (cut j.castSucc) (T.toSurgeryWindows.lower (p j)) →
+              y ∉ Smale.ManifoldMorse.criticalPoints E f := by
+  let p := nativeMiddleBlockPoint S r n hn
+  let cut := nativeMiddleCutSequence S T r n hn
+  have hbase (i : Fin (n + 1)) : cut 0 ≤ cut i := by
+    cases i using Fin.cases with
+    | zero => exact le_rfl
+    | succ j =>
+      exact
+        ((hbefore j).trans
+            ((T.toSurgeryWindows.lower_lt_value (p j)).trans
+              (T.toSurgeryWindows.value_lt_upper (p j)))).le
+  have hstep (j : Fin n) : cut j.castSucc < T.toSurgeryWindows.lower (p j) := by
+    cases n with
+    | zero => exact Fin.elim0 j
+    | succ n =>
+      cases j using Fin.cases with
+      | zero => exact hbefore 0
+      | succ
+        j =>
+        change T.toSurgeryWindows.upper (p j.castSucc) < T.toSurgeryWindows.lower (p j.succ)
+        apply T.separated
+        apply S.toSurgeryWindows.point_strictMono
+        change r + j.val + 1 < r + (j.val + 1) + 1
+        omega
+  have hpred (j : Fin n) : f (S.toSurgeryWindows.point ⟨r + j.val, by omega⟩) < cut j.castSucc := by
+    cases n with
+    | zero => exact Fin.elim0 j
+    | succ n =>
+      cases j using Fin.cases with
+      | zero => exact S.toSurgeryWindows.value_lt_upper _
+      | succ j => exact T.toSurgeryWindows.value_lt_upper (p j.castSucc)
+  refine ⟨hbase, fun _ => rfl, hstep, ?_⟩
+  intro j y hy hcrit
+  have hconsecutive :=
+    S.toSurgeryWindows.point_consecutive ⟨r + j.val, by omega⟩ ⟨r + j.val + 1, by omega⟩ rfl
+  exact
+    hconsecutive ⟨y, hcrit⟩
+      ⟨(hpred j).trans_le hy.1, hy.2.trans_lt (T.toSurgeryWindows.lower_lt_value (p j))⟩
+
+private theorem MorseCancel.ordered_middle_inclusion_relations {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S T : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (r n : ℕ) (hn : r + n < S.toSurgeryWindows.count)
+    (hp : ∀ j, nativeMorseIndex E f (nativeMiddleBlockPoint S r n hn j) = 3)
+    (hbefore :
+      ∀ j,
+        nativeMiddleBaseCut S r n hn <
+          T.toSurgeryWindows.lower (nativeMiddleBlockPoint S r n hn j))
+    (γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = nativeMiddleBaseCut S r n hn }))
+    (horbit :
+      ∀ j x,
+        ∃ t : ℝ,
+          T.flow t
+              (nativeIndexThreeAttachingSphere T (nativeMiddleBlockPoint S r n hn j) (hp j)
+                  x).val =
+            (γ j x).val) :
+    ∃ h : nativeMiddleBaseCut S r n hn ≤ nativeMiddleCutSequence S T r n hn (Fin.last n),
+      Function.Surjective (SingularMayerVietoris.singularHomologyMap (sublevelMap f h) 2) ∧
+        LinearMap.ker (SingularMayerVietoris.singularHomologyMap (sublevelMap f h) 2) =
+          Submodule.span ℤ (Set.range (fun j => middleSectionClass (γ j))) := by
+  obtain ⟨hbase, hnext, hlower, hband⟩ := nativeMiddleCutSequence_bands S T r n hn hbefore
+  refine ⟨hbase (Fin.last n), ?_⟩
+  exact
+    T.finite_middle_inclusion_relations hf n (nativeMiddleBlockPoint S r n hn) hp
+      (nativeMiddleCutSequence S T r n hn)
+      (S.data (S.toSurgeryWindows.point ⟨r, by omega⟩)).upper_regular hbase hnext hlower hband γ
+      horbit
+
+private theorem MorseCancel.native_middle_terminal_homology_subsingleton {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [Nonempty M]
+    {f : M → ℝ} (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (e : M ≃ₕ SixSphere)
+    (horder :
+      ∀ p q : Smale.ManifoldMorse.criticalPoints E f,
+        f p < f q → nativeMorseIndex E f p ≤ nativeMorseIndex E f q)
+    (hzero : nativeMorseCount E f 0 = 1) (hone : nativeMorseCount E f 1 = 0) (r n : ℕ)
+    (hr : nativeMorseCount E f 2 = r) (hn : nativeMorseCount E f 3 = n) :
+    ∃ hrc : r + n < S.toSurgeryWindows.count,
+      Subsingleton
+        (SingularMayerVietoris.SingularHomology
+          { y : M // f y ≤ S.toSurgeryWindows.upper (S.toSurgeryWindows.point ⟨r + n, hrc⟩) }
+          2) := by
+  obtain ⟨r', n', htwo, hrc, hthree, hj, hafter⟩ :=
+    exists_middle_index_blocks S.toSurgeryWindows hf hdim horder hzero hone
+  obtain ⟨hr', hn'⟩ :=
+    native_middle_block_counts S.toSurgeryWindows hf r' n' htwo hrc hthree hafter
+  have hrr : r' = r := hr'.symm.trans hr
+  have hnn : n' = n := hn'.symm.trans hn
+  rw [hrr, hnn] at hrc hj hafter
+  refine ⟨hrc, ?_⟩
+  exact
+    S.toSurgeryWindows.upper_homology_subsingleton_of_later_indices hf hdim e ⟨r + n, hrc⟩ hj 2
+      (by norm_num) (by norm_num)
+      (fun i hi _ => by have hh := hafter i hi; exact ⟨by omega, by omega⟩)
+
+private theorem MorseCancel.nativeMiddleCutSequence_terminal_homology_subsingleton {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [Nonempty M]
+    {f : M → ℝ} (S T : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (e : M ≃ₕ SixSphere)
+    (horder :
+      ∀ p q : Smale.ManifoldMorse.criticalPoints E f,
+        f p < f q → nativeMorseIndex E f p ≤ nativeMorseIndex E f q)
+    (hzero : nativeMorseCount E f 0 = 1) (hone : nativeMorseCount E f 1 = 0) (r n : ℕ)
+    (hr : nativeMorseCount E f 2 = r) (hn : nativeMorseCount E f 3 = n)
+    (hrc : r + n < S.toSurgeryWindows.count) :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology
+        { y : M // f y ≤ nativeMiddleCutSequence S T r n hrc (Fin.last n) } 2) := by
+  cases n with
+  |
+    zero =>
+    obtain ⟨h, hH⟩ :=
+      native_middle_terminal_homology_subsingleton S hf hdim e horder hzero hone r 0 hr hn
+    exact hH
+  | succ
+    n =>
+    obtain ⟨h, hH⟩ :=
+      native_middle_terminal_homology_subsingleton T hf hdim e horder hzero hone r (n + 1) hr hn
+    exact hH
+
+private theorem MorseCancel.middle_section_classes_span {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [Nonempty M] {f : M → ℝ}
+    (S T : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (e : M ≃ₕ SixSphere)
+    (horder :
+      ∀ p q : Smale.ManifoldMorse.criticalPoints E f,
+        f p < f q → nativeMorseIndex E f p ≤ nativeMorseIndex E f q)
+    (hzero : nativeMorseCount E f 0 = 1) (hone : nativeMorseCount E f 1 = 0) (r n : ℕ)
+    (hr : nativeMorseCount E f 2 = r) (hn : nativeMorseCount E f 3 = n)
+    (hrc : r + n < S.toSurgeryWindows.count)
+    (hp : ∀ j, nativeMorseIndex E f (nativeMiddleBlockPoint S r n hrc j) = 3)
+    (hbefore :
+      ∀ j,
+        nativeMiddleBaseCut S r n hrc <
+          T.toSurgeryWindows.lower (nativeMiddleBlockPoint S r n hrc j))
+    (γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = nativeMiddleBaseCut S r n hrc }))
+    (horbit :
+      ∀ j x,
+        ∃ t : ℝ,
+          T.flow t
+              (nativeIndexThreeAttachingSphere T (nativeMiddleBlockPoint S r n hrc j) (hp j)
+                  x).val =
+            (γ j x).val) :
+    Submodule.span ℤ (Set.range (fun j => middleSectionClass (γ j))) = ⊤ := by
+  obtain ⟨h, -, hker⟩ := ordered_middle_inclusion_relations S T hf r n hrc hp hbefore γ horbit
+  let _ :=
+    nativeMiddleCutSequence_terminal_homology_subsingleton S T hf hdim e horder hzero hone r n hr
+      hn hrc
+  apply top_unique
+  intro v hv
+  rw [← hker]
+  exact Subsingleton.elim _ _
+
+private def MorseCancel.classCoordinateMatrix {A : Type} [AddCommGroup A] [Module ℤ A] {r n : ℕ}
+    (B : (Fin r → ℤ) ≃ₗ[ℤ] A) (v : Fin n → A) : Matrix (Fin r) (Fin n) ℤ := fun i j =>
+  B.symm (v j) i
+
+private theorem MorseCancel.classCoordinateMatrix_mulVec {A : Type} [AddCommGroup A] [Module ℤ A]
+    {r n : ℕ} (B : (Fin r → ℤ) ≃ₗ[ℤ] A) (v : Fin n → A) (z : Fin n → ℤ) :
+    B ((classCoordinateMatrix B v).mulVec z) = ∑ j, z j • v j := by
+  have hvec : (classCoordinateMatrix B v).mulVec z = ∑ j, z j • B.symm (v j) := by
+    funext i
+    simp [classCoordinateMatrix, Matrix.mulVec, dotProduct, mul_comm]
+  rw [hvec, map_sum]
+  apply Finset.sum_congr rfl
+  intro j hj
+  rw [map_zsmul, LinearEquiv.apply_symm_apply]
+
+private theorem
+    MorseCancel.classCoordinateMatrix_surjective {A : Type} [AddCommGroup A] [hA : Module ℤ A]
+    {r n : ℕ} (B : (Fin r → ℤ) ≃ₗ[ℤ] A) (v : Fin n → A)
+    (hspan : Submodule.span ℤ (Set.range v) = ⊤) :
+    Function.Surjective (classCoordinateMatrix B v).mulVec := by
+  intro w
+  have hw : B w ∈ Submodule.span ℤ (Set.range v) := by rw [hspan]; trivial
+  obtain ⟨z, hz⟩ := (Submodule.mem_span_range_iff_exists_fun ℤ).mp hw
+  refine ⟨z, B.injective ?_⟩
+  rw [classCoordinateMatrix_mulVec]
+  have hsum : (∑ j, z j • v j) = ∑ j, hA.smul (z j) (v j) := by
+    apply Finset.sum_congr rfl
+    intro j hj
+    exact (int_smul_eq_zsmul hA (z j) (v j)).symm
+  exact hsum.trans hz
+
+private def MorseCancel.canonicalMiddleMatrix {M : Type} [TopologicalSpace M] {f : M → ℝ} {r n : ℕ}
+    {a : ℝ} (B : (Fin r → ℤ) ≃ₗ[ℤ] SingularMayerVietoris.SingularHomology { y : M // f y ≤ a } 2)
+    (γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a })) :
+    Matrix (Fin r) (Fin n) ℤ :=
+  classCoordinateMatrix B (fun j => middleSectionClass (γ j))
+
+private theorem MorseCancel.canonical_middle_matrix_surjective {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [Nonempty M] {f : M → ℝ}
+    (S T : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (e : M ≃ₕ SixSphere)
+    (horder :
+      ∀ p q : Smale.ManifoldMorse.criticalPoints E f,
+        f p < f q → nativeMorseIndex E f p ≤ nativeMorseIndex E f q)
+    (hzero : nativeMorseCount E f 0 = 1) (hone : nativeMorseCount E f 1 = 0) (r n : ℕ)
+    (hr : nativeMorseCount E f 2 = r) (hn : nativeMorseCount E f 3 = n)
+    (hrc : r + n < S.toSurgeryWindows.count)
+    (hp : ∀ j, nativeMorseIndex E f (nativeMiddleBlockPoint S r n hrc j) = 3)
+    (hbefore :
+      ∀ j,
+        nativeMiddleBaseCut S r n hrc <
+          T.toSurgeryWindows.lower (nativeMiddleBlockPoint S r n hrc j))
+    (B :
+      (Fin r → ℤ) ≃ₗ[ℤ]
+        SingularMayerVietoris.SingularHomology { y : M // f y ≤ nativeMiddleBaseCut S r n hrc } 2)
+    (γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = nativeMiddleBaseCut S r n hrc }))
+    (horbit :
+      ∀ j x,
+        ∃ t : ℝ,
+          T.flow t
+              (nativeIndexThreeAttachingSphere T (nativeMiddleBlockPoint S r n hrc j) (hp j)
+                  x).val =
+            (γ j x).val) :
+    Function.Surjective (canonicalMiddleMatrix B γ).mulVec :=
+  classCoordinateMatrix_surjective B _
+    (middle_section_classes_span S T hf hdim e horder hzero hone r n hr hn hrc hp hbefore γ
+      horbit)
+
+private theorem AdaptedWindows.no_connection_above_canonical_cut {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p q : Smale.ManifoldMorse.criticalPoints E f)
+    (hpq : f p < f q) (hq : MorseCancel.nativeMorseIndex E f q = 3) {a : ℝ} (hap : a < f p)
+    (γ : C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (horbit :
+      ∀ x,
+        ∃ t : ℝ,
+          S.flow t (MorseCancel.nativeIndexThreeAttachingSphere S q hq x).val = (γ x).val) :
+    ∀ x,
+      ¬(Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 q.val) ∧
+          Filter.Tendsto (fun t => S.flow t x) Filter.atTop (𝓝 p.val)) := by
+  let _ : Fact (Module.finrank ℝ (S.data q).chart.NegativeCoordinates = 2 + 1) :=
+    ⟨(MorseCancel.nativeMorseIndex_eq_chart (S.data q).chart).symm.trans hq⟩
+  let e := Smale.SphereCoordinates.standardParametrization (S.data q).chart.NegativeCoordinates 2
+  intro x hx
+  have hplower : f p < S.toSurgeryWindows.lower q :=
+    (S.toSurgeryWindows.value_lt_upper p).trans (S.separated p q hpq)
+  obtain ⟨t, ht⟩ :=
+    Degree.FlowCancellation.exists_level_crossing_of_endpoint_limits S.flow hf.continuous hx.1
+      hx.2 (S.toSurgeryWindows.lower_lt_value q) hplower
+  let y : (S.data q).LowerLevel := ⟨S.flow t x, ht⟩
+  have hyback : Filter.Tendsto (fun s => S.flow s y.val) Filter.atBot (𝓝 q.val) :=
+    (MorseCancel.flow_time_atBot_limit_iff S.flow t x q.val).mpr hx.1
+  obtain ⟨u, hu⟩ := (S.attaching_basin_iff hf q y).mp hyback
+  obtain ⟨z, hz⟩ := e.surjective u
+  have hpoint : MorseCancel.nativeIndexThreeAttachingSphere S q hq z = y := by
+    change (S.data q).surgery.attachingSphere (e z) = y
+    exact (congrArg (S.data q).surgery.attachingSphere (show e z = u from hz)).trans hu
+  obtain ⟨s, hs⟩ := horbit z
+  rw [hpoint] at hs
+  have hyforward : Filter.Tendsto (fun v => S.flow v y.val) Filter.atTop (𝓝 p.val) :=
+    (MorseCancel.flow_time_atTop_limit_iff S.flow t x p.val).mpr hx.2
+  have hγforward := (MorseCancel.flow_time_atTop_limit_iff S.flow s y.val p.val).mpr hyforward
+  rw [hs] at hγforward
+  have hheight : Filter.Tendsto (fun v => f (S.flow v (γ z).val)) Filter.atTop (𝓝 (f p)) :=
+    hf.continuous.continuousAt.tendsto.comp hγforward
+  have hh :=
+    (Smale.FlowConstruction.antitone_flow_height hf S.flow S.integral S.zero S.descent
+          (γ z).val).le_of_tendsto
+      hheight 0
+  have hpa : f p ≤ a := by simpa only [S.flow.map_zero_apply, (γ z).property] using hh
+  exact not_le_of_gt hap hpa
+
+private theorem
+    MorseCancel.lower_cuts_preserved_of_critical_bound {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [CompactSpace M] {f g : M → ℝ} (hf : Continuous f) (hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g)
+    {l a : ℝ} (ha : a < l) (hexterior : ∀ y, f y ≤ l → g =ᶠ[𝓝 y] f)
+    (hcritical : ∀ y ∈ Smale.ManifoldMorse.criticalPoints E g, l ≤ f y → l ≤ g y) :
+    (∀ y, g y ≤ a ↔ f y ≤ a) ∧ (∀ y, g y = a ↔ f y = a) ∧ ∀ y, f y ≤ a → g =ᶠ[𝓝 y] f := by
+  have hbound :=
+    superlevel_bound_of_critical_bound hf hg
+      (fun y hy => (hexterior y hy.le).self_of_nhds.trans hy) hcritical
+  have hbelow (y : M) (hy : g y ≤ a) : f y ≤ l := by
+    by_contra h
+    exact (ha.trans_le (hbound y (le_of_not_ge h))).not_ge hy
+  refine ⟨?_, ?_, fun y hy => hexterior y (hy.trans ha.le)⟩
+  · intro y
+    constructor
+    · intro hy
+      exact ((hexterior y (hbelow y hy)).self_of_nhds) ▸ hy
+    · intro hy
+      rw [(hexterior y (hy.trans ha.le)).self_of_nhds]
+      exact hy
+  · intro y
+    constructor
+    · intro hy
+      exact ((hexterior y (hbelow y hy.le)).self_of_nhds).symm.trans hy
+    · intro hy
+      exact (hexterior y (hy ▸ ha.le)).self_of_nhds.trans hy
+
+private theorem AdaptedWindows.exists_common_cut_value_exchange {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [CompactSpace M] {f : M → ℝ} [FiniteDimensional ℝ E] [T2Space M] [PreconnectedSpace M]
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) {a : ℝ}
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (p q : Smale.ManifoldMorse.criticalPoints E f) (hpq : f p < f q)
+    (hconsecutive : ∀ r : Smale.ManifoldMorse.criticalPoints E f, ¬(f p < f r ∧ f r < f q))
+    (hq : MorseCancel.nativeMorseIndex E f q = 3) (hal : a < S.toSurgeryWindows.lower p)
+    (γ : C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (horbit :
+      ∀ x,
+        ∃ t : ℝ,
+          S.flow t (MorseCancel.nativeIndexThreeAttachingSphere S q hq x).val = (γ x).val) :
+    ∃ g : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+        Smale.ManifoldMorse.IsMorse E g ∧
+          Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f ∧
+            Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) ∧
+              g p = f q ∧
+                g q = f p ∧
+                  (∀ z,
+                      f z ∉ Set.Ioo (S.toSurgeryWindows.lower p) (S.toSurgeryWindows.upper q) →
+                        g =ᶠ[𝓝 z] f) ∧
+                    (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+                        z ≠ p.val → z ≠ q.val → g =ᶠ[𝓝 z] f) ∧
+                      (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+                          MorseCancel.nativeMorseIndex E g z =
+                            MorseCancel.nativeMorseIndex E f z) ∧
+                        (∀ k,
+                            MorseCancel.nativeMorseCount E g k =
+                              MorseCancel.nativeMorseCount E f k) ∧
+                          (∀ y, g y ≤ a ↔ f y ≤ a) ∧
+                            (∀ y, g y = a ↔ f y = a) ∧
+                              (∀ y, f y ≤ a → g =ᶠ[𝓝 y] f) ∧
+                                (∀ y, g y = a → y ∉ Smale.ManifoldMorse.criticalPoints E g) ∧
+                                  ∃ T : AdaptedWindows E g,
+                                    T.field = S.field ∧
+                                      T.flow = S.flow ∧
+                                        (∀ r : Smale.ManifoldMorse.criticalPoints E g,
+                                            g r < a → T.toSurgeryWindows.upper r < a) ∧
+                                          ∀ r : Smale.ManifoldMorse.criticalPoints E g,
+                                            a < g r → a < T.toSurgeryWindows.lower r := by
+  have hpband : f p ∈ Set.Ioo (S.toSurgeryWindows.lower p) (S.toSurgeryWindows.upper q) :=
+    ⟨S.toSurgeryWindows.lower_lt_value p, hpq.trans (S.toSurgeryWindows.value_lt_upper q)⟩
+  have hqband : f q ∈ Set.Ioo (S.toSurgeryWindows.lower p) (S.toSurgeryWindows.upper q) :=
+    ⟨(S.toSurgeryWindows.lower_lt_value p).trans hpq, S.toSurgeryWindows.value_lt_upper q⟩
+  have hnoconnection :=
+    S.no_connection_above_canonical_cut hf p q hpq hq
+      (hal.trans (S.toSurgeryWindows.lower_lt_value p)) γ horbit
+  obtain ⟨g, hg, hmg, hcrit, hgp, hgq, hdesc, hexterior, hpgerm, hqgerm, hothers, hindices⟩ :=
+    Degree.MorseRearrangement.exists_morse_rearrangement_of_no_connection hf hm S.smooth S.flow
+      S.integral S.zero S.descent S.distinct (S.data p).chart (S.data q).chart
+      (S.critical_model_germ p) (S.critical_model_germ q) hpband hqband hpq hqband hpband
+      (MorseCancel.surgery_pair_band_isolation S.toSurgeryWindows p q hconsecutive) hnoconnection
+  have hinjg : Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) := by
+    rw [hcrit]
+    exact
+      MorseCancel.injOn_of_exchanged_values S.distinct p.property q.property hgp hgq
+        (fun x hx hxp hxq => (hothers x hx hxp hxq).self_of_nhds)
+  have hnewmodels (r : Smale.ManifoldMorse.criticalPoints E g) :
+    ∃ c : Smale.ManifoldMorse.SignedMorseChart (E := E) g r.val,
+      ∀ᶠ y in 𝓝 r.val, S.field y = c.descentField y := by
+    have hr : r.val ∈ Smale.ManifoldMorse.criticalPoints E f := hcrit ▸ r.property
+    by_cases hrp : r.val = p.val
+    · obtain ⟨c, hc⟩ :=
+        MorseCancel.exists_signed_morse_chart_of_shift_germ_preserving_field (S.data p).chart
+          hpgerm
+      rw [hrp]
+      exact ⟨c, hc ▸ S.critical_model_germ p⟩
+    by_cases hrq : r.val = q.val
+    · obtain ⟨c, hc⟩ :=
+        MorseCancel.exists_signed_morse_chart_of_shift_germ_preserving_field (S.data q).chart
+          hqgerm
+      rw [hrq]
+      exact ⟨c, hc ▸ S.critical_model_germ q⟩
+    obtain ⟨c, hc⟩ :=
+      MorseCancel.exists_signed_morse_chart_of_germ_preserving_field (S.data ⟨r.val, hr⟩).chart
+        (hothers r hr hrp hrq)
+    exact ⟨c, hc ▸ S.critical_model_germ ⟨r.val, hr⟩⟩
+  have hout (y : M) (hy : f y ≤ S.toSurgeryWindows.lower p) : g =ᶠ[𝓝 y] f :=
+    hexterior y (fun h => h.1.not_ge hy)
+  have hbound (y : M) (hy : y ∈ Smale.ManifoldMorse.criticalPoints E g)
+    (hfy : S.toSurgeryWindows.lower p ≤ f y) : S.toSurgeryWindows.lower p ≤ g y := by
+    by_cases hyp : y = p.val
+    · rw [hyp, hgp]
+      exact hqband.1.le
+    by_cases hyq : y = q.val
+    · rw [hyq, hgq]
+      exact hpband.1.le
+    rw [(hothers y (hcrit ▸ hy) hyp hyq).self_of_nhds]
+    exact hfy
+  obtain ⟨hsub, hlevel, hgerm⟩ :=
+    MorseCancel.lower_cuts_preserved_of_critical_bound hf.continuous hg hal hout hbound
+  have hga (y : M) (hy : g y = a) : y ∉ Smale.ManifoldMorse.criticalPoints E g := by
+    rw [hcrit]
+    exact ha y ((hlevel y).mp hy)
+  choose c hc using hnewmodels
+  obtain ⟨T₀, hfield₀, hflow₀, -⟩ :=
+    MorseCancel.exists_adapted_windows_with_prescribed_flow hg hmg hinjg S.smooth S.flow
+      S.integral (fun x hx => S.zero x (hcrit ▸ hx)) (fun x hx => hdesc x (hcrit ▸ hx)) c hc
+  obtain ⟨T, hfield, hflow, -, hbelow, habove⟩ :=
+    T₀.exists_same_flow_windows_avoiding_level hg hmg hga
+  exact
+    ⟨g, hg, hmg, hcrit, hinjg, hgp, hgq, hexterior, hothers, hindices,
+      MorseCancel.nativeMorseCount_eq_of_preserved_indices hcrit hindices, hsub, hlevel, hgerm,
+      hga, T, hfield.trans hfield₀, hflow.trans hflow₀, hbelow, habove⟩
+
+private def MorseCancel.equalCutSection {M : Type} [TopologicalSpace M] {f g : M → ℝ} {a : ℝ}
+    (hlevel : ∀ y, g y = a ↔ f y = a) (γ : C((Smale.Hemisphere.Sphere 2), { y : M // f y = a })) :
+    C((Smale.Hemisphere.Sphere 2), { y : M // g y = a }) :=
+  ⟨fun x => ⟨(γ x).val, (hlevel _).mpr (γ x).property⟩,
+    (continuous_subtype_val.comp γ.continuous).subtype_mk _⟩
+
+private def
+    MorseCancel.equalCutSublevelHomeomorph {M : Type} [TopologicalSpace M] {f g : M → ℝ} {a : ℝ}
+    (hsub : ∀ y, g y ≤ a ↔ f y ≤ a) : { y : M // f y ≤ a } ≃ₜ { y : M // g y ≤ a }
+    where
+  toFun y := ⟨y.val, (hsub y).mpr y.property⟩
+  invFun y := ⟨y.val, (hsub y).mp y.property⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := continuous_subtype_val.subtype_mk _
+  continuous_invFun := continuous_subtype_val.subtype_mk _
+
+private def MorseCancel.equalCutHomologyEquiv {M : Type} [TopologicalSpace M] {f g : M → ℝ} {a : ℝ}
+    (hsub : ∀ y, g y ≤ a ↔ f y ≤ a) :
+    SingularMayerVietoris.SingularHomology { y : M // f y ≤ a } 2 ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology { y : M // g y ≤ a } 2 :=
+  PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+    (equalCutSublevelHomeomorph hsub).toHomotopyEquiv 2
+
+private theorem MorseCancel.equalCutSection_class {M : Type} [TopologicalSpace M]
+     {f g : M → ℝ} {a : ℝ} (hsub : ∀ y, g y ≤ a ↔ f y ≤ a)
+    (hlevel : ∀ y, g y = a ↔ f y = a) (γ : C((Smale.Hemisphere.Sphere 2), { y : M // f y = a })) :
+    equalCutHomologyEquiv hsub (middleSectionClass γ) =
+      middleSectionClass (equalCutSection hlevel γ) := by
+  have hmaps :
+    (equalCutSublevelHomeomorph hsub).toHomotopyEquiv.toFun.comp
+        ((levelSublevelMap f le_rfl).comp γ) =
+      (levelSublevelMap g le_rfl).comp (equalCutSection hlevel γ) := by
+    apply ContinuousMap.ext
+    intro x
+    rfl
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (equalCutSublevelHomeomorph hsub).toHomotopyEquiv.toFun 2 (middleSectionClass γ) =
+      _
+  rw [middleSectionClass, ← LinearMap.comp_apply, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp, hmaps]
+  rfl
+
+private theorem
+    MorseCancel.canonicalMiddleMatrix_equalCut {M : Type} [TopologicalSpace M]
+     {f g : M → ℝ} {a : ℝ} (hsub : ∀ y, g y ≤ a ↔ f y ≤ a)
+    (hlevel : ∀ y, g y = a ↔ f y = a) {r n : ℕ}
+    (B : (Fin r → ℤ) ≃ₗ[ℤ] SingularMayerVietoris.SingularHomology { y : M // f y ≤ a } 2)
+    (γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a })) :
+    canonicalMiddleMatrix (B.trans (equalCutHomologyEquiv hsub))
+        (fun j => equalCutSection hlevel (γ j)) =
+      canonicalMiddleMatrix B γ := by
+  funext i j
+  change
+    B.symm ((equalCutHomologyEquiv hsub).symm (middleSectionClass (equalCutSection hlevel (γ j))))
+        i =
+      B.symm (middleSectionClass (γ j)) i
+  rw [← equalCutSection_class hsub hlevel, LinearEquiv.symm_apply_apply]
+
+private theorem MorseCancel.nativeMiddleBasinFamily_equalCut {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f g : M → ℝ} {a : ℝ}
+    (S : AdaptedWindows E f) (T : AdaptedWindows E g) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g)
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hga : ∀ y, g y = a → y ∉ Smale.ManifoldMorse.criticalPoints E g)
+    (hcrit : Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f)
+    (hlevel : ∀ y, g y = a ↔ f y = a) (hflow : T.flow = S.flow) {n : ℕ}
+    (p : Fin n → Smale.ManifoldMorse.criticalPoints E f)
+    (γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (hγ : IsNativeMiddleBasinFamily S hf ha p (fun j => γ j)) :
+    IsNativeMiddleBasinFamily T hg hga (fun j => ⟨(p j).val, hcrit.symm ▸ (p j).property⟩)
+      (fun j => equalCutSection hlevel (γ j)) := by
+  let _ := Smale.RegularLevel.chartedSpace hf ha
+  let _ := Smale.RegularLevel.chartedSpace hg hga
+  let e := equalLevelDiffeomorph hf hg ha hga hlevel
+  obtain ⟨hs, he, hi, hpair, hfull⟩ := hγ
+  have hβs (j : Fin n) :
+    ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ (equalCutSection hlevel (γ j)) := by
+    change ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ (e ∘ γ j)
+    exact e.contMDiff.comp (hs j)
+  refine ⟨hβs, ?_, ?_, ?_, ?_⟩
+  · intro j
+    apply (hβs j).continuous.isClosedEmbedding
+    change Function.Injective (e ∘ γ j)
+    exact e.injective.comp (he j).injective
+  · intro j x
+    change Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) (e ∘ γ j) x)
+    rw [mfderiv_comp x (e.contMDiff.mdifferentiableAt (by simp))
+        ((hs j).mdifferentiableAt (by simp))]
+    exact (e.mfderivToContinuousLinearEquiv (by simp) (γ j x)).injective.comp (hi j x)
+  · intro i j hij
+    apply Set.disjoint_left.mpr
+    intro y hiy hjy
+    obtain ⟨x, hx⟩ := hiy
+    obtain ⟨z, hz⟩ := hjy
+    have hsame : γ i x = γ j z := e.injective (hx.trans hz.symm)
+    exact Set.disjoint_left.mp (hpair hij) (Set.mem_range_self x) ⟨z, hsame.symm⟩
+  · intro j y
+    have hmem : y ∈ Set.range (equalCutSection hlevel (γ j)) ↔ e.symm y ∈ Set.range (γ j) := by
+      constructor
+      · rintro ⟨x, hx⟩
+        refine ⟨x, ?_⟩
+        apply e.injective
+        exact hx.trans (e.apply_symm_apply y).symm
+      · rintro ⟨x, hx⟩
+        exact ⟨x, (congrArg e hx).trans (e.apply_symm_apply y)⟩
+    rw [hmem, hfull j]
+    rw [hflow]
+    rfl
+
+private theorem
+    MorseCancel.native_index_order_of_equal_index_exchange {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+       {f g : M → ℝ}
+    (horder :
+      ∀ x y : Smale.ManifoldMorse.criticalPoints E f,
+        f x < f y → nativeMorseIndex E f x ≤ nativeMorseIndex E f y)
+    (p q : Smale.ManifoldMorse.criticalPoints E f)
+    (hequal : nativeMorseIndex E f p = nativeMorseIndex E f q)
+    (hcrit : Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f)
+    (hgp : g p = f q) (hgq : g q = f p)
+    (hothers : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, x ≠ p.val → x ≠ q.val → g x = f x)
+    (hindices :
+      ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+        nativeMorseIndex E g x = nativeMorseIndex E f x) :
+    ∀ x y : Smale.ManifoldMorse.criticalPoints E g,
+      g x < g y → nativeMorseIndex E g x ≤ nativeMorseIndex E g y := by
+  classical
+  have hform (x : Smale.ManifoldMorse.criticalPoints E f) : g x = f (Equiv.swap p q x) := by
+    by_cases hxp : x = p
+    · subst x
+      simpa only [Equiv.swap_apply_left] using hgp
+    by_cases hxq : x = q
+    · subst x
+      simpa only [Equiv.swap_apply_right] using hgq
+    simpa only [Equiv.swap_apply_def, ite_eq_right hxp, ite_eq_right hxq] using
+      hothers x x.property (fun h => hxp (Subtype.ext h)) (fun h => hxq (Subtype.ext h))
+  have hind (x : Smale.ManifoldMorse.criticalPoints E f) :
+    nativeMorseIndex E f (Equiv.swap p q x) = nativeMorseIndex E f x := by
+    by_cases hxp : x = p
+    · subst x
+      simpa only [Equiv.swap_apply_left] using hequal.symm
+    by_cases hxq : x = q
+    · subst x
+      simpa only [Equiv.swap_apply_right] using hequal
+    simp only [Equiv.swap_apply_def, ite_eq_right hxp, ite_eq_right hxq]
+  intro x y hxy
+  let x' : Smale.ManifoldMorse.criticalPoints E f := ⟨x.val, hcrit ▸ x.property⟩
+  let y' : Smale.ManifoldMorse.criticalPoints E f := ⟨y.val, hcrit ▸ y.property⟩
+  have hxy' : f (Equiv.swap p q x') < f (Equiv.swap p q y') := by
+    rw [← hform, ← hform]
+    exact hxy
+  have hh := horder (Equiv.swap p q x') (Equiv.swap p q y') hxy'
+  rw [hind, hind] at hh
+  rw [hindices x x'.property, hindices y y'.property]
+  exact hh
+
+private theorem
+    AdaptedWindows.exists_middle_family_value_exchange {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} [PreconnectedSpace M]
+     (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) {a : ℝ}
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (horder :
+      ∀ x y : Smale.ManifoldMorse.criticalPoints E f,
+        f x < f y → MorseCancel.nativeMorseIndex E f x ≤ MorseCancel.nativeMorseIndex E f y)
+    {r n : ℕ} (p : Fin n → Smale.ManifoldMorse.criticalPoints E f)
+    (hp : ∀ j, MorseCancel.nativeMorseIndex E f (p j) = 3)
+    (hlower : ∀ j, a < S.toSurgeryWindows.lower (p j))
+    (B : (Fin r → ℤ) ≃ₗ[ℤ] SingularMayerVietoris.SingularHomology { y : M // f y ≤ a } 2)
+    (γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (hγ : MorseCancel.IsNativeMiddleBasinFamily S hf ha p (fun j => γ j))
+    (hsurj : Function.Surjective (MorseCancel.canonicalMiddleMatrix B γ).mulVec) (i j : Fin n)
+    (hij : f (p i) < f (p j))
+    (hconsecutive :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E f, ¬(f (p i) < f z ∧ f z < f (p j))) :
+    ∃ g : M → ℝ,
+      ∃ hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g,
+        Smale.ManifoldMorse.IsMorse E g ∧
+          ∃ hcrit :
+            Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f,
+            Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) ∧
+              g (p i) = f (p j) ∧
+                g (p j) = f (p i) ∧
+                  (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+                      z ≠ (p i).val → z ≠ (p j).val → g z = f z) ∧
+                    (∀ x y : Smale.ManifoldMorse.criticalPoints E g,
+                        g x < g y →
+                          MorseCancel.nativeMorseIndex E g x ≤
+                            MorseCancel.nativeMorseIndex E g y) ∧
+                      (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+                          MorseCancel.nativeMorseIndex E g z =
+                            MorseCancel.nativeMorseIndex E f z) ∧
+                        (∀ k,
+                            MorseCancel.nativeMorseCount E g k =
+                              MorseCancel.nativeMorseCount E f k) ∧
+                          ∃ hsub : ∀ y, g y ≤ a ↔ f y ≤ a,
+                            ∃ hlevel : ∀ y, g y = a ↔ f y = a,
+                              ∃ hga : ∀ y, g y = a → y ∉ Smale.ManifoldMorse.criticalPoints E g,
+                                ∃ T : AdaptedWindows E g,
+                                  T.field = S.field ∧
+                                    T.flow = S.flow ∧
+                                      (∀ y, f y ≤ a → g =ᶠ[𝓝 y] f) ∧
+                                        let p' : Fin n → Smale.ManifoldMorse.criticalPoints E g :=
+                                          fun k => ⟨(p k).val, hcrit.symm ▸ (p k).property⟩
+                                        let B' := B.trans (MorseCancel.equalCutHomologyEquiv hsub)
+                                        let γ' := fun k =>
+                                          MorseCancel.equalCutSection hlevel (γ k)
+                                        (∀ k, MorseCancel.nativeMorseIndex E g (p' k) = 3) ∧
+                                          (∀ k, a < T.toSurgeryWindows.lower (p' k)) ∧
+                                            MorseCancel.IsNativeMiddleBasinFamily T hg hga p'
+                                                (fun k => γ' k) ∧
+                                              (∀ k x, (γ' k x).val = (γ k x).val) ∧
+                                                MorseCancel.canonicalMiddleMatrix B' γ' =
+                                                    MorseCancel.canonicalMiddleMatrix B γ ∧
+                                                  Function.Surjective
+                                                    (MorseCancel.canonicalMiddleMatrix B'
+                                                        γ').mulVec := by
+  obtain ⟨δ, -, -, -, -, horbit, -⟩ :=
+    S.exists_canonical_basin_sphere hf (p j) (hp j) ha (γ j)
+      (Smale.Hemisphere.point Bool.true ⟨0, by simp⟩) (hγ.2.2.2.2 j)
+  obtain
+    ⟨g, hg, hmg, hcrit, hinj, hgp, hgq, -, hothers, hindices, hcounts, hsub, hlevel, hgerm, hga,
+      T, hfield, hflow, -, habove⟩ :=
+    S.exists_common_cut_value_exchange hf hm ha (p i) (p j) hij hconsecutive (hp j) (hlower i) δ
+      horbit
+  have hneworder :=
+    MorseCancel.native_index_order_of_equal_index_exchange horder (p i) (p j)
+      ((hp i).trans (hp j).symm) hcrit hgp hgq
+      (fun x hx hxi hxj => (hothers x hx hxi hxj).self_of_nhds) hindices
+  have hheight (k : Fin n) : a < g (p k) := by
+    by_cases hki : (p k).val = (p i).val
+    · rw [hki, hgp]
+      exact (hlower j).trans (S.toSurgeryWindows.lower_lt_value (p j))
+    by_cases hkj : (p k).val = (p j).val
+    · rw [hkj, hgq]
+      exact (hlower i).trans (S.toSurgeryWindows.lower_lt_value (p i))
+    rw [(hothers (p k) (p k).property hki hkj).self_of_nhds]
+    exact (hlower k).trans (S.toSurgeryWindows.lower_lt_value (p k))
+  have hmatrix := MorseCancel.canonicalMiddleMatrix_equalCut hsub hlevel B γ
+  refine
+    ⟨g, hg, hmg, hcrit, hinj, hgp, hgq, (fun z hz hzi hzj => (hothers z hz hzi hzj).self_of_nhds),
+      hneworder, hindices, hcounts, hsub, hlevel, hga, T, hfield, hflow, hgerm, ?_, ?_, ?_, ?_,
+      hmatrix, ?_⟩
+  · intro k
+    exact (hindices (p k) (p k).property).trans (hp k)
+  · intro k
+    exact habove ⟨(p k).val, hcrit.symm ▸ (p k).property⟩ (hheight k)
+  · exact MorseCancel.nativeMiddleBasinFamily_equalCut S T hf hg ha hga hcrit hlevel hflow p γ hγ
+  · intro k x
+    rfl
+  · rw [hmatrix]
+    exact hsurj
+
+private theorem
+    MorseCancel.nativeMiddleBasinFamily_labels_injective {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a : ℝ}
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f) {n : ℕ}
+    (p : Fin n → Smale.ManifoldMorse.criticalPoints E f)
+    (γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (hγ : IsNativeMiddleBasinFamily S hf ha p (fun j => γ j)) : Function.Injective p := by
+  intro i j hij
+  by_contra hne
+  let x : (Smale.Hemisphere.Sphere 2) := Smale.Hemisphere.point Bool.true ⟨0, by simp⟩
+  have hbasin := (hγ.2.2.2.2 i (γ i x)).mp (Set.mem_range_self x)
+  have hj : γ i x ∈ Set.range (γ j) := by
+    apply (hγ.2.2.2.2 j (γ i x)).mpr
+    simpa only [hij] using hbasin
+  exact Set.disjoint_left.mp (hγ.2.2.2.1 hne) (Set.mem_range_self x) hj
+
+private theorem AdaptedWindows.exists_first_middle_pivot {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} [PreconnectedSpace M]
+     (S₀ : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) {a : ℝ}
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (horder :
+      ∀ x y : Smale.ManifoldMorse.criticalPoints E f,
+        f x < f y → MorseCancel.nativeMorseIndex E f x ≤ MorseCancel.nativeMorseIndex E f y)
+    {r n : ℕ} (p : Fin n → Smale.ManifoldMorse.criticalPoints E f)
+    (hp : ∀ j, MorseCancel.nativeMorseIndex E f (p j) = 3)
+    (hcomplete :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E f,
+        MorseCancel.nativeMorseIndex E f z = 3 → ∃ j, p j = z)
+    (hlower : ∀ j, a < S₀.toSurgeryWindows.lower (p j))
+    (B : (Fin r → ℤ) ≃ₗ[ℤ] SingularMayerVietoris.SingularHomology { y : M // f y ≤ a } 2)
+    (γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (hγ : MorseCancel.IsNativeMiddleBasinFamily S₀ hf ha p (fun j => γ j))
+    (hsurj : Function.Surjective (MorseCancel.canonicalMiddleMatrix B γ).mulVec) (q : Fin n) :
+    ∃ g : M → ℝ,
+      ∃ hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g,
+        Smale.ManifoldMorse.IsMorse E g ∧
+          ∃ hcrit :
+            Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f,
+            (∀ x y : Smale.ManifoldMorse.criticalPoints E g,
+                g x < g y →
+                  MorseCancel.nativeMorseIndex E g x ≤ MorseCancel.nativeMorseIndex E g y) ∧
+              (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+                  MorseCancel.nativeMorseIndex E g z = MorseCancel.nativeMorseIndex E f z) ∧
+                (∀ k, MorseCancel.nativeMorseCount E g k = MorseCancel.nativeMorseCount E f k) ∧
+                  (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+                      (∀ j, z ≠ (p j).val) → g z = f z) ∧
+                    (∀ j, j ≠ q → g (p q) < g (p j)) ∧
+                      ∃ hsub : ∀ y, g y ≤ a ↔ f y ≤ a,
+                        ∃ hlevel : ∀ y, g y = a ↔ f y = a,
+                          ∃ hga : ∀ y, g y = a → y ∉ Smale.ManifoldMorse.criticalPoints E g,
+                            ∃ T : AdaptedWindows E g,
+                              T.field = S₀.field ∧
+                                T.flow = S₀.flow ∧
+                                  (∀ y, f y ≤ a → g =ᶠ[𝓝 y] f) ∧
+                                    let p' : Fin n → Smale.ManifoldMorse.criticalPoints E g :=
+                                      fun j => ⟨(p j).val, hcrit.symm ▸ (p j).property⟩
+                                    let B' := B.trans (MorseCancel.equalCutHomologyEquiv hsub)
+                                    let γ' := fun j => MorseCancel.equalCutSection hlevel (γ j)
+                                    (∀ j, MorseCancel.nativeMorseIndex E g (p' j) = 3) ∧
+                                      (∀ j, a < T.toSurgeryWindows.lower (p' j)) ∧
+                                        MorseCancel.IsNativeMiddleBasinFamily T hg hga p'
+                                            (fun j => γ' j) ∧
+                                          (∀ j x, (γ' j x).val = (γ j x).val) ∧
+                                            MorseCancel.canonicalMiddleMatrix B' γ' =
+                                                MorseCancel.canonicalMiddleMatrix B γ ∧
+                                              Function.Surjective
+                                                (MorseCancel.canonicalMiddleMatrix B'
+                                                    γ').mulVec := by
+  classical
+  have hpinj := MorseCancel.nativeMiddleBasinFamily_labels_injective S₀ hf ha p γ hγ
+  let P : ℕ → Prop := fun m =>
+    ∃ g : M → ℝ,
+      ∃ hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g,
+        Smale.ManifoldMorse.IsMorse E g ∧
+          ∃ hc : Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f,
+            ∃ hs : ∀ y, g y ≤ a ↔ f y ≤ a,
+              ∃ hl : ∀ y, g y = a ↔ f y = a,
+                ∃ hga : ∀ y, g y = a → y ∉ Smale.ManifoldMorse.criticalPoints E g,
+                  ∃ T : AdaptedWindows E g,
+                    (∀ x y : Smale.ManifoldMorse.criticalPoints E g,
+                        g x < g y →
+                          MorseCancel.nativeMorseIndex E g x ≤
+                            MorseCancel.nativeMorseIndex E g y) ∧
+                      (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+                          MorseCancel.nativeMorseIndex E g z =
+                            MorseCancel.nativeMorseIndex E f z) ∧
+                        (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+                            (∀ j, z ≠ (p j).val) → g z = f z) ∧
+                          T.field = S₀.field ∧
+                            T.flow = S₀.flow ∧
+                              (∀ y, f y ≤ a → g =ᶠ[𝓝 y] f) ∧
+                                (∀ j,
+                                    a <
+                                      T.toSurgeryWindows.lower
+                                        ⟨(p j).val, hc.symm ▸ (p j).property⟩) ∧
+                                  Degree.MorseRearrangement.beforeValueRank (fun j => g (p j)) q =
+                                    m
+  have hex : ∃ m, P m :=
+    ⟨Degree.MorseRearrangement.beforeValueRank (fun j => f (p j)) q, f, hf, hm, rfl, fun _ =>
+      Iff.rfl, fun _ => Iff.rfl, ha, S₀, horder, fun _ _ => rfl, fun _ _ _ => rfl, rfl, rfl,
+      fun _ _ => Filter.EventuallyEq.rfl, hlower, rfl⟩
+  obtain
+    ⟨g, hg, hmg, hcrit, hsub, hlevel, hga, T, hgorder, hindices, houtside, hfield, hflow, hgerm,
+      hglower, hrank⟩ :=
+    Nat.find_spec hex
+  let pg : Fin n → Smale.ManifoldMorse.criticalPoints E g := fun j =>
+    ⟨(p j).val, hcrit.symm ▸ (p j).property⟩
+  let Bg := B.trans (MorseCancel.equalCutHomologyEquiv hsub)
+  let γg := fun j => MorseCancel.equalCutSection hlevel (γ j)
+  have hpg (j : Fin n) : MorseCancel.nativeMorseIndex E g (pg j) = 3 :=
+    (hindices (p j) (p j).property).trans (hp j)
+  have hfamily : MorseCancel.IsNativeMiddleBasinFamily T hg hga pg (fun j => γg j) :=
+    MorseCancel.nativeMiddleBasinFamily_equalCut S₀ T hf hg ha hga hcrit hlevel hflow p γ hγ
+  have hmatrix :
+    MorseCancel.canonicalMiddleMatrix Bg γg = MorseCancel.canonicalMiddleMatrix B γ :=
+    MorseCancel.canonicalMiddleMatrix_equalCut hsub hlevel B γ
+  have hgsurj : Function.Surjective (MorseCancel.canonicalMiddleMatrix Bg γg).mulVec := by
+    rw [hmatrix]
+    exact hsurj
+  have hvalueinj : Function.Injective (fun j => g (p j)) := by
+    intro i j hij
+    exact hpinj (Subtype.ext (T.distinct (pg i).property (pg j).property hij))
+  have hfirst : ∀ j, j ≠ q → g (p q) < g (p j) := by
+    intro j hj
+    by_contra hnot
+    have hjq : g (p j) < g (p q) :=
+      lt_of_le_of_ne (le_of_not_gt hnot) (fun heq => hj (hvalueinj heq))
+    let K := Finset.univ.filter (fun k => g (p k) < g (p q))
+    have hjK : j ∈ K := Finset.mem_filter.mpr ⟨Finset.mem_univ _, hjq⟩
+    obtain ⟨i, hi, hmax⟩ := K.exists_max_image (fun k => g (p k)) ⟨j, hjK⟩
+    have hiq : g (p i) < g (p q) := (Finset.mem_filter.mp hi).2
+    have hconsecutive : ∀ k, ¬(g (p i) < g (p k) ∧ g (p k) < g (p q)) := by
+      intro k hk
+      exact (not_lt_of_ge (hmax k (Finset.mem_filter.mpr ⟨Finset.mem_univ _, hk.2⟩))) hk.1
+    have hglobal :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E g, ¬(g (pg i) < g z ∧ g z < g (pg q)) := by
+      intro z hz
+      have hidx : MorseCancel.nativeMorseIndex E g z = 3 := by
+        apply Nat.le_antisymm
+        · exact (hgorder z (pg q) hz.2).trans_eq (hpg q)
+        · exact (hpg i).symm.trans_le (hgorder (pg i) z hz.1)
+      let zf : Smale.ManifoldMorse.criticalPoints E f := ⟨z.val, hcrit ▸ z.property⟩
+      have hzf : MorseCancel.nativeMorseIndex E f zf = 3 :=
+        (hindices z zf.property).symm.trans hidx
+      obtain ⟨k, hk⟩ := hcomplete zf hzf
+      exact hconsecutive k (by simpa only [hk] using hz)
+    obtain
+      ⟨u, hu, hmu, hcu, -, hui, huq, huothers, huorder, huindices, -, hus, hul, hua, U, hufield,
+        huflow, hugerm, -, hulower, -, -, -, -⟩ :=
+      T.exists_middle_family_value_exchange hg hmg hga hgorder pg hpg hglower Bg γg hfamily hgsurj
+        i q hiq hglobal
+    have hdecrease :
+      Degree.MorseRearrangement.beforeValueRank (fun k => u (p k)) q <
+        Degree.MorseRearrangement.beforeValueRank (fun k => g (p k)) q := by
+      apply
+        Degree.MorseRearrangement.beforeValueRank_exchange_lt hvalueinj hiq hconsecutive hui huq
+      intro k hki hkq
+      apply huothers (pg k) (pg k).property
+      · exact fun heq => hki (hpinj (Subtype.ext heq))
+      · exact fun heq => hkq (hpinj (Subtype.ext heq))
+    have hminimal :=
+      Nat.find_min' hex
+        (show P (Degree.MorseRearrangement.beforeValueRank (fun k => u (p k)) q) from
+          ⟨u, hu, hmu, hcu.trans hcrit, fun y => (hus y).trans (hsub y), fun y =>
+            (hul y).trans (hlevel y), hua, U, huorder, fun z hz =>
+            (huindices z (hcrit.symm ▸ hz)).trans (hindices z hz), fun z hz hzoutside =>
+            (huothers z (hcrit.symm ▸ hz) (hzoutside i) (hzoutside q)).trans
+              (houtside z hz hzoutside),
+            hufield.trans hfield, huflow.trans hflow, fun y hy =>
+            (hugerm y ((hsub y).mpr hy)).trans (hgerm y hy), hulower, rfl⟩)
+    rw [← hrank] at hminimal
+    exact (not_le_of_gt hdecrease) hminimal
+  exact
+    ⟨g, hg, hmg, hcrit, hgorder, hindices,
+      MorseCancel.nativeMorseCount_eq_of_preserved_indices hcrit hindices, houtside, hfirst, hsub,
+      hlevel, hga, T, hfield, hflow, hgerm, hpg, hglower, hfamily, fun _ _ => rfl, hmatrix,
+      hgsurj⟩
+
+private theorem
+    AdaptedWindows.backward_basin_reaches_compact_section {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f)
+    (hp : MorseCancel.nativeMorseIndex E f p = 3) {a : ℝ}
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (α : C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (hfull :
+      ∀ y, y ∈ Set.range α ↔ Filter.Tendsto (fun t => S.flow t y.val) Filter.atBot (𝓝 p.val))
+    {x : M} (hx : x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hback : Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 p.val)) :
+    x ∈ Degree.FlowCancellation.levelBasin S.flow f a := by
+  let _ : Fact (Module.finrank ℝ (S.data p).chart.NegativeCoordinates = 2 + 1) :=
+    ⟨(MorseCancel.nativeMorseIndex_eq_chart (S.data p).chart).symm.trans hp⟩
+  have hreach :=
+    S.attaching_sphere_reaches_of_compact_basin_section hf p 2 ha α
+      (Smale.Hemisphere.point Bool.true ⟨0, by simp⟩) hfull
+  obtain ⟨t, ht⟩ := S.backward_basin_reaches_attaching_level hf p hx hback
+  let y : (S.data p).LowerLevel := ⟨S.flow t x, ht⟩
+  have hyback : Filter.Tendsto (fun s => S.flow s y.val) Filter.atBot (𝓝 p.val) :=
+    (MorseCancel.flow_time_atBot_limit_iff S.flow t x p.val).mpr hback
+  obtain ⟨u, hu⟩ := (S.attaching_basin_iff hf p y).mp hyback
+  apply (Degree.FlowCancellation.levelBasin_flow_iff S.flow f a t x).mp
+  change y.val ∈ Degree.FlowCancellation.levelBasin S.flow f a
+  rw [← hu]
+  exact hreach u
+
+private theorem
+    AdaptedWindows.backward_basin_reaches_intermediate_cut {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {x p : M}
+    (hback : Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 p)) {b : ℝ} (hxb : f x < b)
+    (hbp : b < f p) : x ∈ Degree.FlowCancellation.levelBasin S.flow f b := by
+  have hh : Filter.Tendsto (fun t => f (S.flow t x)) Filter.atBot (𝓝 (f p)) :=
+    hf.continuous.continuousAt.tendsto.comp hback
+  obtain ⟨t, ht⟩ := (hh.eventually (eventually_gt_nhds hbp)).exists
+  apply
+    mem_range_of_exists_le_of_exists_ge
+      (hf.continuous.comp (S.flow.continuous continuous_id continuous_const))
+  · refine ⟨0, ?_⟩
+    change f (S.flow 0 x) ≤ b
+    rw [S.flow.map_zero_apply]
+    exact hxb.le
+  · exact ⟨t, ht.le⟩
+
+private theorem
+    AdaptedWindows.transported_basin_image_of_reaching {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {X : Type} {a b : ℝ}
+    (hb : ∀ y, f y = b → y ∉ Smale.ManifoldMorse.criticalPoints E f) (p : M)
+    (α : X → { y : M // f y = a }) (β : X → { y : M // f y = b })
+    (hfull : ∀ y, y ∈ Set.range α ↔ Filter.Tendsto (fun t => S.flow t y.val) Filter.atBot (𝓝 p))
+    (horbit : ∀ x, ∃ t : ℝ, S.flow t (α x).val = (β x).val)
+    (hreach :
+      ∀ y : { z : M // f z = b },
+        Filter.Tendsto (fun t => S.flow t y.val) Filter.atBot (𝓝 p) →
+          y.val ∈ Degree.FlowCancellation.levelBasin S.flow f a) :
+    ∀ y, y ∈ Set.range β ↔ Filter.Tendsto (fun t => S.flow t y.val) Filter.atBot (𝓝 p) := by
+  intro y
+  constructor
+  · rintro ⟨z, rfl⟩
+    obtain ⟨t, ht⟩ := horbit z
+    rw [← ht]
+    exact
+      (MorseCancel.flow_time_atBot_limit_iff S.flow t (α z).val p).mpr
+        ((hfull (α z)).mp (Set.mem_range_self z))
+  · intro hy
+    obtain ⟨s, hs⟩ := hreach y hy
+    let x : { z : M // f z = a } := ⟨S.flow s y.val, hs⟩
+    have hx : Filter.Tendsto (fun t => S.flow t x.val) Filter.atBot (𝓝 p) :=
+      (MorseCancel.flow_time_atBot_limit_iff S.flow s y.val p).mpr hy
+    obtain ⟨z, hz⟩ := (hfull x).mpr hx
+    obtain ⟨t, ht⟩ := horbit z
+    have hshared : S.flow 0 (β z).val = S.flow (t + s) y.val := by
+      rw [S.flow.map_zero_apply, ← ht, hz]
+      exact (S.flow.map_add t s y.val).symm
+    refine ⟨z, Subtype.ext ?_⟩
+    exact
+      MorseCancel.native_same_level_orbit_points hf S.smooth S.flow S.integral
+        (fun z hz => S.descent z (hb z hz)) (β z).property y.property hshared
+
+private theorem AdaptedWindows.exists_higher_middle_family {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ} (hab : a < b)
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hb : ∀ y, f y = b → y ∉ Smale.ManifoldMorse.criticalPoints E f) {n : ℕ}
+    (p : Fin n → Smale.ManifoldMorse.criticalPoints E f) (j₀ : Fin n)
+    (hp : ∀ j, MorseCancel.nativeMorseIndex E f (p j) = 3) (hpb : ∀ j, b < f (p j))
+    (α : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (hα : MorseCancel.IsNativeMiddleBasinFamily S hf ha p (fun j => α j)) :
+    ∃ β : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = b }),
+      MorseCancel.IsNativeMiddleBasinFamily S hf hb p (fun j => β j) ∧
+        ∀ j x, ∃ t : ℝ, S.flow t (α j x).val = (β j x).val := by
+  let _ := Smale.RegularLevel.chartedSpace hf ha
+  let _ := Smale.RegularLevel.chartedSpace hf hb
+  obtain ⟨hs, he, hi, hpair, hfull⟩ := hα
+  have hreach (j : Fin n) (x : (Smale.Hemisphere.Sphere 2)) :
+    (α j x).val ∈ Degree.FlowCancellation.levelBasin S.flow f b := by
+    apply
+      S.backward_basin_reaches_intermediate_cut hf ((hfull j (α j x)).mp (Set.mem_range_self x))
+    · simpa only [(α j x).property] using hab
+    · exact hpb j
+  let x₀ : (Smale.Hemisphere.Sphere 2) := Smale.Hemisphere.point Bool.true ⟨0, by simp⟩
+  obtain ⟨t₀, ht₀⟩ := hreach j₀ x₀
+  obtain ⟨β, hβs, hβe, hβi, hβpair, horbit⟩ :=
+    S.exists_native_family_level_transport hf ha hb (α j₀ x₀) ⟨S.flow t₀ (α j₀ x₀).val, ht₀⟩
+      (fun j => α j) hs (fun j => (he j).injective) hi hpair hreach
+  refine ⟨fun j => ⟨β j, (hβs j).continuous⟩, ⟨hβs, hβe, hβi, hβpair, ?_⟩, horbit⟩
+  intro j
+  apply S.transported_basin_image_of_reaching hf hb (p j).val (α j) (β j) (hfull j) (horbit j)
+  intro y hy
+  exact
+    S.backward_basin_reaches_compact_section hf (p j) (hp j) ha (α j) (hfull j)
+      (hb y.val y.property) hy
+
+private theorem
+    AdaptedWindows.upper_point_not_on_belt_of_lower_orbit {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (q : Smale.ManifoldMorse.criticalPoints E f) {a : ℝ}
+    (ha : a < f q) (x : { y : M // f y = a }) (y : (S.data q).UpperLevel)
+    (horbit : ∃ t : ℝ, S.flow t x.val = y.val) : y ∉ Set.range (S.data q).surgery.beltSphere := by
+  intro hy
+  have hyforward := (S.belt_basin_iff hf q y).mpr hy
+  obtain ⟨t, ht⟩ := horbit
+  have hxforward : Filter.Tendsto (fun s => S.flow s x.val) Filter.atTop (𝓝 q.val) := by
+    rw [← ht] at hyforward
+    exact (MorseCancel.flow_time_atTop_limit_iff S.flow t x.val q.val).mp hyforward
+  have hheight : Filter.Tendsto (fun s => f (S.flow s x.val)) Filter.atTop (𝓝 (f q)) :=
+    hf.continuous.continuousAt.tendsto.comp hxforward
+  have hh :=
+    (Smale.FlowConstruction.antitone_flow_height hf S.flow S.integral S.zero S.descent
+          x.val).le_of_tendsto
+      hheight 0
+  have hqa : f q ≤ a := by simpa only [S.flow.map_zero_apply, x.property] using hh
+  exact ha.not_ge hqa
+
+private theorem MorseCancel.lower_backward_basins_preserved {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ} (S T : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {W : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hW : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, W x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (H : Flow ℝ M) (hH : ∀ x, IsMIntegralCurve (fun t => H t x) W)
+    (hgeometry :
+      ∀ x,
+        Set.range (fun t => H t x) = Set.range (fun t => S.flow t x) ∧
+          (∀ p,
+              Filter.Tendsto (fun t => H t x) Filter.atTop (𝓝 p) ↔
+                Filter.Tendsto (fun t => S.flow t x) Filter.atTop (𝓝 p)) ∧
+            ∀ p,
+              Filter.Tendsto (fun t => H t x) Filter.atBot (𝓝 p) ↔
+                Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 p))
+    {l : ℝ} (hout : ∀ y, f y ≤ l → T.field y = W y) (p : M) (hp : f p ≤ l) :
+    (∀ x,
+        Filter.Tendsto (fun t => T.flow t x) Filter.atBot (𝓝 p) ↔
+          Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 p)) ∧
+      ∀ x,
+        Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 p) →
+          Set.range (fun t => T.flow t x) = Set.range (fun t => S.flow t x) := by
+  have hnew (x : M) (hx : Filter.Tendsto (fun t => T.flow t x) Filter.atBot (𝓝 p)) :
+    ∀ t, T.flow t x = H t x := by
+    have hheight := hf.continuous.continuousAt.tendsto.comp hx
+    have hmono :=
+      Smale.FlowConstruction.antitone_flow_height hf T.flow T.integral T.zero T.descent x
+    have hagree (t : ℝ) : T.field (T.flow t x) = W (T.flow t x) :=
+      hout _ ((hmono.ge_of_tendsto hheight t).trans hp)
+    intro t
+    rcases le_total 0 t with ht | ht
+    · exact
+        Degree.FlowCancellation.native_flow_eq_on_positive_halfline (hW.of_le (by simp)) H T.flow
+          hH T.integral (fun s _ => hagree s) t ht
+    · exact
+        Degree.FlowCancellation.native_flow_eq_on_negative_halfline (hW.of_le (by simp)) H T.flow
+          hH T.integral (fun s _ => hagree s) t ht
+  have hold (x : M) (hx : Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 p)) :
+    ∀ t, H t x = T.flow t x := by
+    have hheight := hf.continuous.continuousAt.tendsto.comp hx
+    have hmono :=
+      Smale.FlowConstruction.antitone_flow_height hf S.flow S.integral S.zero S.descent x
+    have hbound (t : ℝ) : f (H t x) ≤ l := by
+      have hm : H t x ∈ Set.range (fun s => S.flow s x) := (hgeometry x).1 ▸ Set.mem_range_self t
+      obtain ⟨s, hs⟩ := hm
+      rw [← hs]
+      exact (hmono.ge_of_tendsto hheight s).trans hp
+    have hagree (t : ℝ) : W (H t x) = T.field (H t x) := (hout _ (hbound t)).symm
+    intro t
+    rcases le_total 0 t with ht | ht
+    · exact
+        Degree.FlowCancellation.native_flow_eq_on_positive_halfline (T.smooth.of_le (by simp))
+          T.flow H T.integral hH (fun s _ => hagree s) t ht
+    · exact
+        Degree.FlowCancellation.native_flow_eq_on_negative_halfline (T.smooth.of_le (by simp))
+          T.flow H T.integral hH (fun s _ => hagree s) t ht
+  refine ⟨?_, ?_⟩
+  · intro x
+    constructor
+    · intro hx
+      have heq : (fun t => T.flow t x) = fun t => H t x := funext (hnew x hx)
+      rw [heq] at hx
+      exact ((hgeometry x).2.2 p).mp hx
+    · intro hx
+      have heq : (fun t => H t x) = fun t => T.flow t x := funext (hold x hx)
+      have hh := ((hgeometry x).2.2 p).mpr hx
+      rwa [heq] at hh
+  · intro x hx
+    have heq : (fun t => H t x) = fun t => T.flow t x := funext (hold x hx)
+    rw [← heq]
+    exact (hgeometry x).1
+
+private theorem MorseCancel.lower_forward_basins_preserved {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ} (S T : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {W : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hW : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, W x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (H : Flow ℝ M) (hH : ∀ x, IsMIntegralCurve (fun t => H t x) W)
+    (hgeometry :
+      ∀ x p,
+        Filter.Tendsto (fun t => H t x) Filter.atTop (𝓝 p) ↔
+          Filter.Tendsto (fun t => S.flow t x) Filter.atTop (𝓝 p))
+    {l : ℝ} (hout : ∀ y, f y ≤ l → T.field y = W y) (y : M) (hy : f y ≤ l) :
+    ∀ p,
+      Filter.Tendsto (fun t => T.flow t y) Filter.atTop (𝓝 p) ↔
+        Filter.Tendsto (fun t => S.flow t y) Filter.atTop (𝓝 p) := by
+  have hmono :=
+    Smale.FlowConstruction.antitone_flow_height hf T.flow T.integral T.zero T.descent y
+  have hbound (t : ℝ) (ht : 0 ≤ t) : f (T.flow t y) ≤ l := by
+    have hh := hmono ht
+    change f (T.flow t y) ≤ f (T.flow 0 y) at hh
+    rw [T.flow.map_zero_apply] at hh
+    exact hh.trans hy
+  have heq : (fun t => T.flow t y) =ᶠ[Filter.atTop] (fun t => H t y) := by
+    filter_upwards [Filter.eventually_ge_atTop (0 : ℝ)] with t ht
+    exact
+      Degree.FlowCancellation.native_flow_eq_on_positive_halfline (hW.of_le (by simp)) H T.flow hH
+        T.integral (fun s hs => hout _ (hbound s hs)) t ht
+  intro p
+  exact (Filter.tendsto_congr' heq).trans (hgeometry y p)
+
+private theorem AdaptedWindows.reaches_cut_of_forward_holonomy {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S T : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ} (hab : a < b)
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hb : ∀ y, f y = b → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (D : { y : M // f y = b } → { y : M // f y = b })
+    (hforward :
+      ∀ x : { y : M // f y = b },
+        ∀ p : M,
+          Filter.Tendsto (fun t => T.flow t x.val) Filter.atTop (𝓝 p) ↔
+            Filter.Tendsto (fun t => S.flow t (D x).val) Filter.atTop (𝓝 p))
+    (x : { y : M // f y = b }) (y : { z : M // f z = a })
+    (horbit : ∃ t : ℝ, S.flow t (D x).val = y.val) :
+    x.val ∈ Degree.FlowCancellation.levelBasin T.flow f a := by
+  obtain ⟨p, hp, q, hq, -, hytop, hyheight⟩ :=
+    Degree.FlowCancellation.exists_native_descent_endpoints hf S.smooth S.flow S.integral S.zero
+      S.descent S.distinct y.val
+  have hqa : f q < a := by simpa only [y.property] using (hyheight (ha y.val y.property)).1
+  obtain ⟨t, ht⟩ := horbit
+  have hDx : Filter.Tendsto (fun s => S.flow s (D x).val) Filter.atTop (𝓝 q) := by
+    rw [← ht] at hytop
+    exact (MorseCancel.flow_time_atTop_limit_iff S.flow t (D x).val q).mp hytop
+  have hxtop := (hforward x q).mpr hDx
+  obtain ⟨r, hr, s, hs, hxback, -, hxheight⟩ :=
+    Degree.FlowCancellation.exists_native_descent_endpoints hf T.smooth T.flow T.integral T.zero
+      T.descent T.distinct x.val
+  have hbr : b < f r := by simpa only [x.property] using (hxheight (hb x.val x.property)).2
+  exact
+    Degree.FlowCancellation.exists_level_crossing_of_endpoint_limits T.flow hf.continuous hxback
+      hxtop (hab.trans hbr) hqa
+
+private theorem
+    AdaptedWindows.exists_relative_surgery_cut_transport {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f)
+    (q : Smale.ManifoldMorse.criticalPoints E f) (z : (S.data q).UpperLevel)
+    (ε : Smale.ManifoldMorse.criticalPoints E f → ℝ) (hε : ∀ p, 0 < ε p) :
+    let _ := Smale.RegularLevel.chartedSpace hf (S.data q).upper_regular
+    ∀
+      (D :
+        Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+          (S.data q).UpperLevel (S.data q).UpperLevel ∞)
+      (K P : Set (S.data q).UpperLevel),
+      IsCompact K →
+        Smale.SupportedDiffeomorph.SupportedRelativeIsotopy D K P →
+          ∃ T : AdaptedWindows E f,
+            (∀ p, (T.data p).chart = (S.data p).chart) ∧
+              (∀ p, (T.data p).radius < ε p) ∧
+                (∀ p ∈ Smale.ManifoldMorse.criticalPoints E f,
+                    ∀ᶠ y in 𝓝 p, T.field y = S.field y) ∧
+                  (∀ x : (S.data q).UpperLevel,
+                      ∀ p : M,
+                        Filter.Tendsto (fun t => T.flow t x.val) Filter.atBot (𝓝 p) ↔
+                          Filter.Tendsto (fun t => S.flow t x.val) Filter.atBot (𝓝 p)) ∧
+                    (∀ x : (S.data q).UpperLevel,
+                        ∀ p : M,
+                          Filter.Tendsto (fun t => T.flow t x.val) Filter.atTop (𝓝 p) ↔
+                            Filter.Tendsto (fun t => S.flow t (D x).val) Filter.atTop (𝓝 p)) ∧
+                      (∀ x ∈ P,
+                          Set.range (fun t => T.flow t x.val) =
+                            Set.range (fun t => S.flow t x.val)) ∧
+                        (∀ x : (S.data q).UpperLevel,
+                            ∀ {b : ℝ},
+                              b < f q →
+                                (∀ y, f y = b → y ∉ Smale.ManifoldMorse.criticalPoints E f) →
+                                  ∀ y : { z : M // f z = b },
+                                    (∃ t : ℝ, T.flow t x.val = y.val) ↔
+                                      ∃ t : ℝ, S.flow t (D x).val = y.val) ∧
+                          ∀ p : M,
+                            f p ≤ f q →
+                              (∀ x,
+                                  Filter.Tendsto (fun t => T.flow t x) Filter.atBot (𝓝 p) ↔
+                                    Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 p)) ∧
+                                (∀ x,
+                                    Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 p) →
+                                      Set.range (fun t => T.flow t x) =
+                                        Set.range (fun t => S.flow t x)) ∧
+                                  ∀ v,
+                                    Filter.Tendsto (fun t => T.flow t p) Filter.atTop (𝓝 v) ↔
+                                      Filter.Tendsto (fun t => S.flow t p) Filter.atTop (𝓝 v) := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data q).upper_regular
+  dsimp only
+  intro D K P hK I
+  obtain ⟨l, u, hl, hu, hband⟩ := S.regular_interval_around_level (S.data q).upper_regular
+  have hql : f q < l := by
+    by_contra h
+    exact
+      hband q ⟨le_of_not_gt h, (S.toSurgeryWindows.value_lt_upper q).le.trans hu.le⟩ q.property
+  obtain
+    ⟨r, C, W, V, H, G, hr, hrbound, hC, hCband, hW, hH, hgeometry, hV, hG, hzero, hdesc, hgerms,
+      houtside, hend, hheight, hleft, hright, hprotected⟩ :=
+    Degree.FlowSuspension.exists_relative_regular_level_isotopy_realization hf S.smooth S.descent
+      S.flow S.integral hl hu hband (S.data q).upper_regular z D K P hK I
+  have hmodel (p : Smale.ManifoldMorse.criticalPoints E f) :
+    ∀ᶠ y in 𝓝 p.val, V y = (S.data p).chart.descentField y := by
+    filter_upwards [hgerms p.val p.property, S.critical_model_germ p] with y hy hys
+    exact hy.trans hys
+  obtain ⟨T, hfield, hflow, hcharts, hradii⟩ :=
+    MorseCancel.exists_adapted_windows_with_prescribed_flow_lt hf hm S.distinct hV G hG
+      (fun y hy => (hzero y).mpr (S.zero y hy)) hdesc (fun p => (S.data p).chart) hmodel ε hε
+  obtain ⟨hback₀, hforward₀⟩ :=
+    Degree.FlowSuspension.whole_level_basins_of_holonomy S.flow H G Subtype.val D
+      (fun x p => (hgeometry x).2.1 p) (fun x p => (hgeometry x).2.2 p) hend hleft hright
+  have hback (x : (S.data q).UpperLevel) (p : M) :
+    Filter.Tendsto (fun t => T.flow t x.val) Filter.atBot (𝓝 p) ↔
+      Filter.Tendsto (fun t => S.flow t x.val) Filter.atBot (𝓝 p) := by
+    rw [hflow]
+    exact hback₀ x p
+  have hforward (x : (S.data q).UpperLevel) (p : M) :
+    Filter.Tendsto (fun t => T.flow t x.val) Filter.atTop (𝓝 p) ↔
+      Filter.Tendsto (fun t => S.flow t (D x).val) Filter.atTop (𝓝 p) := by
+    rw [hflow]
+    exact hforward₀ x p
+  have hlowexit {b : ℝ} (hb : b < f q) : b < S.toSurgeryWindows.upper q - r := by
+    have hr' : r < S.toSurgeryWindows.upper q - l := hrbound
+    linarith
+  have htransport (x : (S.data q).UpperLevel) {b : ℝ} (hb : b < f q) (y : { z : M // f z = b })
+    (hxy : ∃ t : ℝ, T.flow t x.val = y.val) : ∃ t : ℝ, S.flow t (D x).val = y.val := by
+    obtain ⟨t, ht⟩ := hxy
+    have hstart : f (T.flow 1 x.val) = S.toSurgeryWindows.upper q - r := by
+      rw [hflow, hend, hheight]
+      rfl
+    have htone : 1 < t := by
+      by_contra h
+      have hh :=
+        (Smale.FlowConstruction.antitone_flow_height hf T.flow T.integral T.zero T.descent x.val)
+          (le_of_not_gt h)
+      change f (T.flow 1 x.val) ≤ f (T.flow t x.val) at hh
+      rw [hstart, ht, y.property] at hh
+      exact (hlowexit hb).not_ge hh
+    have heq : G t x.val = H t (D x).val := by
+      calc
+        G t x.val = G (t - 1) (G 1 x.val) := by rw [← G.map_add, sub_add_cancel]
+        _ = H (t - 1) (H 1 (D x).val) := by
+          rw [hend, hright (D x) (t - 1) (sub_nonneg.mpr htone.le)]
+        _ = H t (D x).val := by rw [← H.map_add, sub_add_cancel]
+    have hmem : H t (D x).val ∈ Set.range (fun s => S.flow s (D x).val) :=
+      (hgeometry (D x).val).1 ▸ Set.mem_range_self t
+    obtain ⟨s, hs⟩ := hmem
+    exact ⟨s, hs.trans (heq.symm.trans (hflow ▸ ht))⟩
+  refine ⟨T, hcharts, hradii, ?_, hback, hforward, ?_, ?_, ?_⟩
+  · intro p hp
+    rw [hfield]
+    exact hgerms p hp
+  · intro x hx
+    rw [hflow]
+    have heq : (fun t => G t x.val) = fun t => H t x.val := funext (hprotected x hx)
+    rw [heq]
+    exact (hgeometry x.val).1
+  · intro x b hbq hb y
+    refine ⟨htransport x hbq y, ?_⟩
+    rintro ⟨t, ht⟩
+    obtain ⟨s, hs⟩ :=
+      S.reaches_cut_of_forward_holonomy T hf (hbq.trans (S.toSurgeryWindows.value_lt_upper q)) hb
+        (S.data q).upper_regular D hforward x y ⟨t, ht⟩
+    let y' : { z : M // f z = b } := ⟨T.flow s x.val, hs⟩
+    obtain ⟨v, hv⟩ := htransport x hbq y' ⟨s, rfl⟩
+    have hshared : S.flow 0 y'.val = S.flow (v - t) y.val := by
+      rw [S.flow.map_zero_apply, ← hv, ← ht, ← S.flow.map_add, sub_add_cancel]
+    have heq : y'.val = y.val :=
+      MorseCancel.native_same_level_orbit_points hf S.smooth S.flow S.integral
+        (fun z hz => S.descent z (hb z hz)) y'.property y.property hshared
+    exact ⟨s, heq⟩
+  · intro p hp
+    have hlow (y : M) (hy : f y ≤ l) : T.field y = W y := by
+      rw [hfield]
+      exact (houtside y (fun h => (hCband h).1.not_ge hy)).self_of_nhds
+    have hb :=
+      MorseCancel.lower_backward_basins_preserved S T hf hW H hH hgeometry hlow p
+        (hp.trans hql.le)
+    exact
+      ⟨hb.1, hb.2,
+        MorseCancel.lower_forward_basins_preserved S T hf hW H hH (fun x v => (hgeometry x).2.1 v)
+          hlow p (hp.trans hql.le)⟩
+
+private theorem
+    AdaptedWindows.exists_relative_family_lower_transport {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f)
+    (q : Smale.ManifoldMorse.criticalPoints E f) (hq : MorseCancel.nativeMorseIndex E f q = 3)
+    {n : ℕ} (p : Fin n → Smale.ManifoldMorse.criticalPoints E f) (i : Fin n)
+    (hhigh : ∀ j, S.toSurgeryWindows.upper q < f (p j))
+    (α : Fin n → C((Smale.Hemisphere.Sphere 2), (S.data q).UpperLevel))
+    (hα : MorseCancel.IsNativeMiddleBasinFamily S hf (S.data q).upper_regular p (fun j => α j))
+    (havoid : ∀ j, Disjoint (Set.range (α j)) (Set.range (S.data q).surgery.beltSphere))
+    (ε : Smale.ManifoldMorse.criticalPoints E f → ℝ) (hε : ∀ z, 0 < ε z) :
+    let _ := Smale.RegularLevel.chartedSpace hf (S.data q).upper_regular
+    ∀
+      (D :
+        Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+          (S.data q).UpperLevel (S.data q).UpperLevel ∞)
+      (K : Set (S.data q).UpperLevel),
+      IsCompact K →
+        Smale.SupportedDiffeomorph.SupportedRelativeIsotopy D K
+            (Degree.MorseRearrangement.otherSheetImages (fun j => α j) i) →
+          (∀ j, Disjoint (Set.range (D ∘ α j)) (Set.range (S.data q).surgery.beltSphere)) →
+            ∃ T : AdaptedWindows E f,
+              (∀ z, (T.data z).chart = (S.data z).chart) ∧
+                (∀ z, (T.data z).radius < ε z) ∧
+                  (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+                      ∀ᶠ y in 𝓝 z, T.field y = S.field y) ∧
+                    ∃ β δ : Fin n → C((Smale.Hemisphere.Sphere 2), (S.data q).LowerLevel),
+                      MorseCancel.IsNativeMiddleBasinFamily S hf (S.data q).lower_regular p
+                          (fun j => β j) ∧
+                        MorseCancel.IsNativeMiddleBasinFamily T hf (S.data q).lower_regular p
+                            (fun j => δ j) ∧
+                          (∀ j x, ∃ t : ℝ, S.flow t (α j x).val = (β j x).val) ∧
+                            (∀ j x, ∃ t : ℝ, T.flow t (α j x).val = (δ j x).val) ∧
+                              (∀ j x, ∃ t : ℝ, S.flow t (D (α j x)).val = (δ j x).val) ∧
+                                (∀ j, j ≠ i → δ j = β j) ∧
+                                  (∀ j,
+                                      j ≠ i →
+                                        ∀ x,
+                                          Set.range (fun t => T.flow t (α j x).val) =
+                                            Set.range (fun t => S.flow t (α j x).val)) ∧
+                                    ∀ z : M,
+                                      f z ≤ f q →
+                                        (∀ x,
+                                            Filter.Tendsto (fun t => T.flow t x) Filter.atBot
+                                                (𝓝 z) ↔
+                                              Filter.Tendsto (fun t => S.flow t x) Filter.atBot
+                                                (𝓝 z)) ∧
+                                          (∀ x,
+                                              Filter.Tendsto (fun t => S.flow t x) Filter.atBot
+                                                  (𝓝 z) →
+                                                Set.range (fun t => T.flow t x) =
+                                                  Set.range (fun t => S.flow t x)) ∧
+                                            ∀ v,
+                                              Filter.Tendsto (fun t => T.flow t z) Filter.atTop
+                                                  (𝓝 v) ↔
+                                                Filter.Tendsto (fun t => S.flow t z) Filter.atTop
+                                                  (𝓝 v) := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data q).upper_regular
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data q).lower_regular
+  let _ : Fact (Module.finrank ℝ (S.data q).chart.NegativeCoordinates = 2 + 1) :=
+    ⟨(MorseCancel.nativeMorseIndex_eq_chart (S.data q).chart).symm.trans hq⟩
+  dsimp only
+  intro D K hK I hDavoid
+  let x₀ : (Smale.Hemisphere.Sphere 2) := Smale.Hemisphere.point Bool.true ⟨0, by simp⟩
+  let u :=
+    Smale.SphereCoordinates.standardParametrization (S.data q).chart.NegativeCoordinates 2 x₀
+  obtain ⟨T, hcharts, hradii, hgerms, hback, hforward, hprotected, hcut, hkeep⟩ :=
+    S.exists_relative_surgery_cut_transport hf hm q (α i x₀) ε hε D K
+      (Degree.MorseRearrangement.otherSheetImages (fun j => α j) i) hK I
+  obtain ⟨hs, he, hi, hpair, hfull⟩ := hα
+  have holdreach (j : Fin n) (x : (Smale.Hemisphere.Sphere 2)) :=
+    S.belt_complement_reaches_lower_level hf q (α j x)
+      (fun h => Set.disjoint_left.mp (havoid j) (Set.mem_range_self x) h)
+  have hnewreach (j : Fin n) (x : (Smale.Hemisphere.Sphere 2)) :=
+    S.reaches_old_lower_of_belt_avoidance T hf q D hforward (α j x)
+      (fun h => Set.disjoint_left.mp (hDavoid j) (Set.mem_range_self x) h)
+  obtain ⟨β₀, hβs, hβe, hβi, hβpair, hβflow⟩ :=
+    S.exists_native_family_level_transport hf (S.data q).upper_regular (S.data q).lower_regular
+      (α i x₀) ((S.data q).surgery.attachingSphere u) (fun j => α j) hs
+      (fun j => (he j).injective) hi hpair holdreach
+  obtain ⟨δ₀, hδs, hδe, hδi, hδpair, hδflow⟩ :=
+    T.exists_native_family_level_transport hf (S.data q).upper_regular (S.data q).lower_regular
+      (α i x₀) ((S.data q).surgery.attachingSphere u) (fun j => α j) hs
+      (fun j => (he j).injective) hi hpair hnewreach
+  let β : Fin n → C((Smale.Hemisphere.Sphere 2), (S.data q).LowerLevel) := fun j =>
+    ⟨β₀ j, (hβs j).continuous⟩
+  let δ : Fin n → C((Smale.Hemisphere.Sphere 2), (S.data q).LowerLevel) := fun j =>
+    ⟨δ₀ j, (hδs j).continuous⟩
+  have hδold (j : Fin n) (x : (Smale.Hemisphere.Sphere 2)) :
+    ∃ t : ℝ, S.flow t (D (α j x)).val = (δ j x).val :=
+    (hcut (α j x) (S.toSurgeryWindows.lower_lt_value q) (S.data q).lower_regular (δ j x)).mp
+      (hδflow j x)
+  have hab := (S.toSurgeryWindows.lower_lt_value q).trans (S.toSurgeryWindows.value_lt_upper q)
+  refine ⟨T, hcharts, hradii, hgerms, β, δ, ?_, ?_, hβflow, hδflow, hδold, ?_, ?_, hkeep⟩
+  · refine ⟨hβs, hβe, hβi, hβpair, ?_⟩
+    intro j
+    exact
+      S.transported_backward_basin_image hf hab (S.data q).lower_regular (p j).val (hhigh j) (α j)
+        (β j) (hfull j) (hβflow j)
+  · refine ⟨hδs, hδe, hδi, hδpair, ?_⟩
+    intro j
+    apply
+      T.transported_backward_basin_image hf hab (S.data q).lower_regular (p j).val (hhigh j) (α j)
+        (δ j) ?_ (hδflow j)
+    intro x
+    exact (hfull j x).trans (hback x (p j).val).symm
+  · intro j hji
+    apply ContinuousMap.ext
+    intro x
+    obtain ⟨s, hs⟩ := hδold j x
+    have hfix : D (α j x) = α j x :=
+      I.endpoint_fixed_on (α j x)
+        (Degree.MorseRearrangement.mem_otherSheetImages (fun j => α j) i j hji x)
+    rw [hfix] at hs
+    obtain ⟨t, ht⟩ := hβflow j x
+    change S.flow t (α j x).val = (β j x).val at ht
+    have hshared : S.flow 0 (δ j x).val = S.flow (s - t) (β j x).val := by
+      rw [S.flow.map_zero_apply, ← hs, ← ht, ← S.flow.map_add, sub_add_cancel]
+    apply Subtype.ext
+    exact
+      MorseCancel.native_same_level_orbit_points hf S.smooth S.flow S.integral
+        (fun z hz => S.descent z ((S.data q).lower_regular z hz)) (δ j x).property
+        (β j x).property hshared
+  · intro j hji x
+    exact
+      hprotected (α j x) (Degree.MorseRearrangement.mem_otherSheetImages (fun j => α j) i j hji x)
+
+private theorem AdaptedWindows.section_class_of_flow_transport {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ} (hab : a < b)
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (β : C((Smale.Hemisphere.Sphere 2), { y : M // f y = b }))
+    (α : C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (horbit : ∀ x, ∃ t : ℝ, S.flow t (β x).val = (α x).val) :
+    SingularMayerVietoris.singularHomologyMap (MorseCancel.sublevelMap f hab.le) 2
+        (MorseCancel.middleSectionClass α) =
+      MorseCancel.middleSectionClass β := by
+  have hm :=
+    PeriodTorusHigherHomology.homotopic_homologyMap
+      (S.level_transport_homotopic_in_sublevel hf hab ha β α horbit) 2
+  have hmaps :
+    (MorseCancel.sublevelMap f hab.le).comp ((MorseCancel.levelSublevelMap f le_rfl).comp α) =
+      (MorseCancel.levelSublevelMap f hab.le).comp α := by
+    apply ContinuousMap.ext
+    intro x
+    rfl
+  rw [MorseCancel.middleSectionClass, ← LinearMap.comp_apply, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp, hmaps, ← hm]
+  rfl
+
+private theorem
+    MorseCancel.signed_relation_of_regular_cut_transport {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S T : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ} (hab : a < b)
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hband : ∀ y, f y ∈ Set.Icc a b → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (β δ γ : C((Smale.Hemisphere.Sphere 2), { y : M // f y = b }))
+    (α ζ θ : C((Smale.Hemisphere.Sphere 2), { y : M // f y = a })) (k : ℤ)
+    (hβ : ∀ x, ∃ t : ℝ, S.flow t (β x).val = (α x).val)
+    (hδ : ∀ x, ∃ t : ℝ, T.flow t (δ x).val = (ζ x).val)
+    (hγ : ∀ x, ∃ t : ℝ, S.flow t (γ x).val = (θ x).val)
+    (hmap :
+      SingularMayerVietoris.singularHomologyMap δ 2 =
+        SingularMayerVietoris.singularHomologyMap β 2 +
+          k • SingularMayerVietoris.singularHomologyMap γ 2) :
+    middleSectionClass ζ = middleSectionClass α + k • middleSectionClass θ := by
+  have heval :
+    (k • SingularMayerVietoris.singularHomologyMap γ 2) (SphereHomology.unitSphereTopClass 1) =
+      k • SingularMayerVietoris.singularHomologyMap γ 2 (SphereHomology.unitSphereTopClass 1) :=
+    map_zsmul (LinearMap.evalAddMonoidHom (SphereHomology.unitSphereTopClass 1)) k
+      (SingularMayerVietoris.singularHomologyMap γ 2)
+  have hclasses : middleSectionClass δ = middleSectionClass β + k • middleSectionClass γ := by
+    simp only [middleSectionClass, PeriodTorusHigherHomology.singularHomologyMap_comp,
+      LinearMap.comp_apply, hmap, LinearMap.add_apply, heval, map_add, map_zsmul]
+  apply (regular_sublevel_inclusion_bijective hf hab.le hband 2).1
+  rw [map_add, map_zsmul, T.section_class_of_flow_transport hf hab ha δ ζ hδ,
+    S.section_class_of_flow_transport hf hab ha β α hβ,
+    S.section_class_of_flow_transport hf hab ha γ θ hγ]
+  exact hclasses
+
+private theorem MorseCancel.same_image_sphere_maps_unit {Y : Type} [TopologicalSpace Y]
+    (α β : C((Smale.Hemisphere.Sphere 2), Y)) (hα : Topology.IsEmbedding α)
+    (hβ : Topology.IsEmbedding β) (hrange : Set.range β = Set.range α) :
+    ∃ k : ℤ,
+      (k = 1 ∨ k = -1) ∧
+        SingularMayerVietoris.singularHomologyMap β 2 =
+          k • SingularMayerVietoris.singularHomologyMap α 2 := by
+  let e : (Smale.Hemisphere.Sphere 2) ≃ₜ (Smale.Hemisphere.Sphere 2) :=
+    hβ.toHomeomorph.trans ((Homeomorph.setCongr hrange).trans hα.toHomeomorph.symm)
+  have heq : α.comp (e : C((Smale.Hemisphere.Sphere 2), (Smale.Hemisphere.Sphere 2))) = β := by
+    apply ContinuousMap.ext
+    intro x
+    have hh :=
+      congrArg Subtype.val
+        (hα.toHomeomorph.apply_symm_apply ((Homeomorph.setCongr hrange) (hβ.toHomeomorph x)))
+    exact hh
+  have hbij :
+    Function.Bijective
+      (SingularMayerVietoris.singularHomologyMap
+        (e : C((Smale.Hemisphere.Sphere 2), (Smale.Hemisphere.Sphere 2))) 2) :=
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv e 2).bijective
+  obtain ⟨k, hk, hu⟩ :=
+    two_sphere_map_unit_of_homology_bijective (Homeomorph.refl (Smale.Hemisphere.Sphere 2))
+      (e : C((Smale.Hemisphere.Sphere 2), (Smale.Hemisphere.Sphere 2))) hbij
+  rcases hk with rfl | rfl
+  · refine ⟨1, Or.inl rfl, ?_⟩
+    simp only [one_smul] at hu ⊢
+    rw [← heq, PeriodTorusHigherHomology.singularHomologyMap_comp, hu]
+    change
+      (SingularMayerVietoris.singularHomologyMap α 2).comp
+          (SingularMayerVietoris.singularHomologyMap
+            (ContinuousMap.id (Smale.Hemisphere.Sphere 2)) 2) =
+        _
+    rw [PeriodTorusHigherHomology.singularHomologyMap_id, LinearMap.comp_id]
+  · refine ⟨-1, Or.inr rfl, ?_⟩
+    simp only [neg_one_zsmul] at hu ⊢
+    rw [← heq, PeriodTorusHigherHomology.singularHomologyMap_comp, hu, LinearMap.comp_neg]
+    change
+      -((SingularMayerVietoris.singularHomologyMap α 2).comp
+            (SingularMayerVietoris.singularHomologyMap
+              (ContinuousMap.id (Smale.Hemisphere.Sphere 2)) 2)) =
+        _
+    rw [PeriodTorusHigherHomology.singularHomologyMap_id, LinearMap.comp_id]
+
+private theorem
+    MorseCancel.same_image_section_classes_unit {M : Type} [TopologicalSpace M]
+     {f : M → ℝ} {a : ℝ}
+    (α β : C((Smale.Hemisphere.Sphere 2), { y : M // f y = a })) (hα : Topology.IsEmbedding α)
+    (hβ : Topology.IsEmbedding β) (hrange : Set.range β = Set.range α) :
+    ∃ k : ℤ, (k = 1 ∨ k = -1) ∧ middleSectionClass β = k • middleSectionClass α := by
+  obtain ⟨k, hk, hm⟩ := same_image_sphere_maps_unit α β hα hβ hrange
+  have heval :
+    (k • SingularMayerVietoris.singularHomologyMap α 2) (SphereHomology.unitSphereTopClass 1) =
+      k • SingularMayerVietoris.singularHomologyMap α 2 (SphereHomology.unitSphereTopClass 1) :=
+    map_zsmul (LinearMap.evalAddMonoidHom (SphereHomology.unitSphereTopClass 1)) k
+      (SingularMayerVietoris.singularHomologyMap α 2)
+  refine ⟨k, hk, ?_⟩
+  simp only [middleSectionClass, PeriodTorusHigherHomology.singularHomologyMap_comp,
+    LinearMap.comp_apply, hm, heval, map_zsmul]
+
+private theorem MorseCancel.nativeMiddleBasinFamily_replace_zero {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a : ℝ}
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f) {n : ℕ}
+    (q : Smale.ManifoldMorse.criticalPoints E f)
+    (p : Fin n → Smale.ManifoldMorse.criticalPoints E f)
+    (αq βq : C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (α : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (hfamily : IsNativeMiddleBasinFamily S hf ha (Fin.cases q p) (Fin.cases αq (fun j => α j)))
+    (hrange : Set.range βq = Set.range αq) :
+    let _ := Smale.RegularLevel.chartedSpace hf ha
+    ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ βq →
+      Topology.IsClosedEmbedding βq →
+        (∀ x, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) βq x)) →
+          IsNativeMiddleBasinFamily S hf ha (Fin.cases q p) (Fin.cases βq (fun j => α j)) := by
+  let _ := Smale.RegularLevel.chartedSpace hf ha
+  dsimp only
+  intro hβs hβe hβi
+  have hr (j : Fin (n + 1)) :
+    Set.range (Fin.cases βq (fun j => α j) j) = Set.range (Fin.cases αq (fun j => α j) j) := by
+    cases j using Fin.cases with
+    | zero => exact hrange
+    | succ j => rfl
+  refine ⟨?_, ?_, ?_, ?_, ?_⟩
+  · intro j
+    cases j using Fin.cases with
+    | zero => exact hβs
+    | succ j => exact hfamily.1 j.succ
+  · intro j
+    cases j using Fin.cases with
+    | zero => exact hβe
+    | succ j => exact hfamily.2.1 j.succ
+  · intro j
+    cases j using Fin.cases with
+    | zero => exact hβi
+    | succ j => exact hfamily.2.2.1 j.succ
+  · intro j k hjk
+    rw [hr j, hr k]
+    exact hfamily.2.2.2.1 hjk
+  · intro j y
+    rw [hr j]
+    exact hfamily.2.2.2.2 j y
+
+public
+theorem MorseCancel.mul_transvection_surjective {r n : ℕ} (A : Matrix (Fin r) (Fin n) ℤ)
+    (i j : Fin n) (hij : i ≠ j) (k : ℤ) (hA : Function.Surjective A.mulVec) :
+    Function.Surjective (A * Matrix.transvection i j k).mulVec := by
+  intro y
+  obtain ⟨z, hz⟩ := hA y
+  refine ⟨(Matrix.transvection i j (-k)).mulVec z, ?_⟩
+  rw [Matrix.mulVec_mulVec, Matrix.mul_assoc, Matrix.transvection_mul_transvection_same i j hij,
+    add_neg_cancel, Matrix.transvection_zero, Matrix.mul_one]
+  exact hz
+
+private theorem
+    MorseCancel.eq_mul_transvection_of_columns {r n : ℕ} (A A' : Matrix (Fin r) (Fin n) ℤ)
+    (i j : Fin n) (k : ℤ) (hchanged : ∀ u, A' u j = A u j + k * A u i)
+    (hother : ∀ u v, v ≠ j → A' u v = A u v) : A' = A * Matrix.transvection i j k := by
+  funext u v
+  by_cases hv : v = j
+  · subst v
+    exact (hchanged u).trans (Matrix.mul_transvection_apply_same i j u k A).symm
+  · exact (hother u v hv).trans (Matrix.mul_transvection_apply_of_ne i j u v hv k A).symm
+
+private theorem
+    MorseCancel.exists_sheet_arc_tube_with_normal_change {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {a : ℝ → M}
+    (ha : ContMDiff 𝓘(ℝ, ℝ) 𝓘(ℝ, E) ∞ a) (hinj : Set.InjOn a (Set.Icc (0 : ℝ) 1))
+    (hi : ∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Injective (mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, E) a t))
+    (hdim : Module.finrank ℝ E = 5)
+    (Φ₀ Φ₁ :
+      PartialDiffeomorph 𝓘(ℝ, (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))))
+        𝓘(ℝ, E) (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) M ∞)
+    (hΦ₀ : (0 : (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))) ∈ Φ₀.source)
+    (hΦ₁ : ((1 : ℝ), (0 : ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))) ∈ Φ₁.source)
+    (hleft : a =ᶠ[𝓝 (0 : ℝ)] fun t => Φ₀ (t, 0)) (hright : a =ᶠ[𝓝 (1 : ℝ)] fun t => Φ₁ (t, 0))
+    {O : Set M} (hO : IsOpen O) (haO : Set.MapsTo a (Set.Icc (0 : ℝ) 1) O)
+    (C : (EuclideanSpace ℝ (Fin 2)) ≃L[ℝ] (EuclideanSpace ℝ (Fin 2))) :
+    ∃ (R : (EuclideanSpace ℝ (Fin 2)) ≃L[ℝ] (EuclideanSpace ℝ (Fin 2))) (ε : ℝ),
+      0 < ε ∧
+        ∃ Φ :
+          PartialDiffeomorph 𝓘(ℝ, (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))))
+            𝓘(ℝ, E) (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) M ∞,
+          Set.Icc (0 : ℝ) 1 ×ˢ
+                Metric.closedBall (0 : ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))
+                  ε ⊆
+              Φ.source ∧
+            (∀ t : ℝ, Φ (t, 0) = a t) ∧
+              ((Φ :
+                    (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) →
+                      M) =ᶠ[𝓝
+                    (0 : (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))))]
+                  Φ₀) ∧
+                ((Φ :
+                      (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) →
+                        M) =ᶠ[𝓝
+                      ((1 : ℝ), (0 : ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))))]
+                    linearTransverseChart (C.prodCongr R) Φ₁) ∧
+                  Φ.target ⊆ O := by
+  let Φ₂ :=
+    linearTransverseChart (C.prodCongr (ContinuousLinearEquiv.refl ℝ (EuclideanSpace ℝ (Fin 2))))
+      Φ₁
+  have hΦ₂ :
+    ((1 : ℝ), (0 : ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))) ∈ Φ₂.source :=
+    (linearTransverseChart_axis_source _ Φ₁ 1).mpr hΦ₁
+  have hright₂ : a =ᶠ[𝓝 (1 : ℝ)] fun t => Φ₂ (t, 0) := by
+    filter_upwards [hright] with t ht
+    exact ht.trans (linearTransverseChart_axis _ Φ₁ t).symm
+  obtain ⟨R, ε, hε, Φ, hprod, haxis, hgl, hgr, htarget⟩ :=
+    exists_sheet_arc_tube ha hinj hi hdim Φ₀ Φ₂ hΦ₀ hΦ₂ hleft hright₂ hO haO
+  refine ⟨R, ε, hε, Φ, hprod, haxis, hgl, ?_, htarget⟩
+  filter_upwards [hgr] with z hz
+  exact hz
+
+private theorem MorseCancel.exists_clean_sheet_arc_tube_with_normal_change {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {a : ℝ → M}
+    (ha : ContMDiff 𝓘(ℝ, ℝ) 𝓘(ℝ, E) ∞ a) (hinj : Set.InjOn a (Set.Icc (0 : ℝ) 1))
+    (hi : ∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Injective (mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, E) a t))
+    (hdim : Module.finrank ℝ E = 5)
+    (Φ₀ Φ₁ :
+      PartialDiffeomorph 𝓘(ℝ, (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))))
+        𝓘(ℝ, E) (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) M ∞)
+    (hΦ₀ : (0 : (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))) ∈ Φ₀.source)
+    (hΦ₁ : ((1 : ℝ), (0 : ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))) ∈ Φ₁.source)
+    (hleft : a =ᶠ[𝓝 (0 : ℝ)] fun t => Φ₀ (t, 0)) (hright : a =ᶠ[𝓝 (1 : ℝ)] fun t => Φ₁ (t, 0))
+    {S T O : Set M} (hS : IsClosed S) (hT : IsClosed T)
+    (hrec₀ : ∀ z ∈ Φ₀.source, Φ₀ z ∈ S ↔ z.1 = 0 ∧ z.2.2 = 0)
+    (hrec₁ : ∀ z ∈ Φ₁.source, Φ₁ z ∈ T ↔ z.1 = 1 ∧ z.2.1 = 0)
+    (hcount₀ : ∀ t ∈ Set.Icc (0 : ℝ) 1, a t ∈ S ↔ t = 0)
+    (hcount₁ : ∀ t ∈ Set.Icc (0 : ℝ) 1, a t ∈ T ↔ t = 1) (hO : IsOpen O)
+    (haO : Set.MapsTo a (Set.Icc (0 : ℝ) 1) O)
+    (C : (EuclideanSpace ℝ (Fin 2)) ≃L[ℝ] (EuclideanSpace ℝ (Fin 2))) :
+    ∃ (R : (EuclideanSpace ℝ (Fin 2)) ≃L[ℝ] (EuclideanSpace ℝ (Fin 2))) (ε : ℝ),
+      0 < ε ∧
+        ∃ Φ :
+          PartialDiffeomorph 𝓘(ℝ, (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))))
+            𝓘(ℝ, E) (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) M ∞,
+          Set.Icc (0 : ℝ) 1 ×ˢ
+                Metric.closedBall (0 : ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))
+                  ε ⊆
+              Φ.source ∧
+            (∀ t : ℝ, Φ (t, 0) = a t) ∧
+              ((Φ :
+                    (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) →
+                      M) =ᶠ[𝓝
+                    (0 : (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))))]
+                  Φ₀) ∧
+                ((Φ :
+                      (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) →
+                        M) =ᶠ[𝓝
+                      ((1 : ℝ), (0 : ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))))]
+                    linearTransverseChart (C.prodCongr R) Φ₁) ∧
+                  (∀ z ∈ Φ.source, Φ z ∈ S ↔ z.1 = 0 ∧ z.2.2 = 0) ∧
+                    (∀ z ∈ Φ.source, Φ z ∈ T ↔ z.1 = 1 ∧ z.2.1 = 0) ∧ Φ.target ⊆ O := by
+  obtain ⟨R, r, hr, Ψ, hΨprod, haxis, hgl, hgr, hΨO⟩ :=
+    exists_sheet_arc_tube_with_normal_change ha hinj hi hdim Φ₀ Φ₁ hΦ₀ hΦ₁ hleft hright hO haO C
+  let Φ₂ := linearTransverseChart (C.prodCongr R) Φ₁
+  have hΦ₂ :
+    ((1 : ℝ), (0 : ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))) ∈ Φ₂.source :=
+    (linearTransverseChart_axis_source _ Φ₁ 1).mpr hΦ₁
+  have hrec₂ : ∀ z ∈ Φ₂.source, Φ₂ z ∈ T ↔ z.1 = 1 ∧ z.2.1 = 0 := by
+    intro z hz
+    change Φ₁ (z.1, (C z.2.1, R z.2.2)) ∈ T ↔ _
+    rw [hrec₁ (z.1, (C z.2.1, R z.2.2)) hz.2, map_eq_zero_iff C C.injective]
+  have hlocal₀ :
+    ∀ᶠ z : (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) in
+      𝓝 (0 : (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))),
+      Ψ z ∈ S ↔ z.1 = 0 ∧ z.2.2 = 0 := by
+    filter_upwards [hgl, Φ₀.open_source.mem_nhds hΦ₀] with z he hz
+    rw [he]
+    exact hrec₀ z hz
+  have hlocal₁ :
+    ∀ᶠ z : (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) in
+      𝓝 ((1 : ℝ), (0 : ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))),
+      Ψ z ∈ T ↔ z.1 = 1 ∧ z.2.1 = 0 := by
+    filter_upwards [hgr, Φ₂.open_source.mem_nhds hΦ₂] with z he hz
+    rw [he]
+    exact hrec₂ z hz
+  have hzero :
+    Set.Icc (0 : ℝ) 1 ×ˢ {(0 : ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))} ⊆
+      Ψ.source := by
+    rintro ⟨t, z⟩ ⟨ht, hz⟩
+    have hz0 : z = 0 := hz
+    subst z
+    exact hΨprod ⟨ht, Metric.mem_closedBall_self hr.le⟩
+  have haway₀ : ∀ t ∈ Set.Icc (0 : ℝ) 1, t ≠ 0 → Ψ (t, 0) ∉ S := by
+    intro t ht hne hh
+    rw [haxis] at hh
+    exact hne ((hcount₀ t ht).mp hh)
+  have haway₁ : ∀ t ∈ Set.Icc (0 : ℝ) 1, t ≠ 1 → Ψ (t, 0) ∉ T := by
+    intro t ht hne hh
+    rw [haxis] at hh
+    exact hne ((hcount₁ t ht).mp hh)
+  obtain ⟨ε, hε, Φ, hprod, hformula, hΦΨ, hrecS, hrecT⟩ :=
+    exists_clean_axis_tube_restriction Ψ CompactIccSpace.isCompact_Icc hzero hS hT 0 1
+      {v : ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))) | v.2 = 0}
+      {v : ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))) | v.1 = 0} hlocal₀ hlocal₁
+      haway₀ haway₁
+  refine
+    ⟨R, ε, hε, Φ, hprod, fun t => (hformula _).trans (haxis t), ?_, ?_, hrecS, hrecT,
+      hΦΨ.trans hΨO⟩
+  · filter_upwards [hgl] with z hz
+    exact (hformula z).trans hz
+  · filter_upwards [hgr] with z hz
+    exact (hformula z).trans hz
+
+private theorem MorseCancel.exists_relative_sheet_passages_with_normal_change {E M X Y Z : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [TopologicalSpace X]
+    [ChartedSpace (EuclideanSpace ℝ (Fin 2)) X] [IsManifold (𝓡 2) ∞ X] [CompactSpace X]
+    [SecondCountableTopology X] [TopologicalSpace Y] [ChartedSpace (EuclideanSpace ℝ (Fin 2)) Y]
+    [IsManifold (𝓡 2) ∞ Y] [CompactSpace Y] [SecondCountableTopology Y] [TopologicalSpace Z]
+    [ChartedSpace (EuclideanSpace ℝ (Fin 2)) Z] [IsManifold (𝓡 2) ∞ Z] [SecondCountableTopology Z]
+    {f : X → M} {g : Y → M} {b : Z → M} (hf : ContMDiff (𝓡 2) 𝓘(ℝ, E) ∞ f)
+    (hg : ContMDiff (𝓡 2) 𝓘(ℝ, E) ∞ g) (hfe : Topology.IsEmbedding f)
+    (hge : Topology.IsEmbedding g) (hfi : ∀ x, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, E) f x))
+    (hgi : ∀ y, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, E) g y))
+    (hdisj : Disjoint (Set.range f) (Set.range g)) (hb : ContMDiff (𝓡 2) 𝓘(ℝ, E) ∞ b)
+    (hbc : IsClosed (Set.range b)) (hdim : Module.finrank ℝ E = 5) (x : X) (y : Y)
+    (hbx : f x ∉ Set.range b) (hby : g y ∉ Set.range b) (γ : Path (f x) (g y)) :
+    ∃ Φ₀ Φ₁ :
+      PartialDiffeomorph 𝓘(ℝ, (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))))
+        𝓘(ℝ, E) (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) M ∞,
+      (0 : (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))) ∈ Φ₀.source ∧
+        ((1 : ℝ), (0 : ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))) ∈ Φ₁.source ∧
+          Φ₀ 0 = f x ∧
+            Φ₁ (1, 0) = g y ∧
+              (∀ z ∈ Φ₀.source, Φ₀ z ∈ Set.range f ↔ z.1 = 0 ∧ z.2.2 = 0) ∧
+                (∀ z ∈ Φ₁.source, Φ₁ z ∈ Set.range g ↔ z.1 = 1 ∧ z.2.1 = 0) ∧
+                  ∀ C : (EuclideanSpace ℝ (Fin 2)) ≃L[ℝ] (EuclideanSpace ℝ (Fin 2)),
+                    ∃ (R : (EuclideanSpace ℝ (Fin 2)) ≃L[ℝ] (EuclideanSpace ℝ (Fin 2))) (ε : ℝ),
+                      0 < ε ∧
+                        ∃ Φ :
+                          PartialDiffeomorph
+                            𝓘(ℝ, (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))))
+                            𝓘(ℝ, E)
+                            (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) M ∞,
+                          ∃ A : LongitudinalTubeMotion Φ,
+                            Set.Icc (0 : ℝ) 1 ×ˢ
+                                  Metric.closedBall
+                                    (0 :
+                                      ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))
+                                    ε ⊆
+                                Φ.source ∧
+                              Φ 0 = f x ∧
+                                Φ (1, 0) = g y ∧
+                                  ((Φ :
+                                        (ℝ ×
+                                            ((EuclideanSpace ℝ (Fin 2)) ×
+                                              (EuclideanSpace ℝ (Fin 2)))) →
+                                          M) =ᶠ[𝓝
+                                        (0 :
+                                          (ℝ ×
+                                            ((EuclideanSpace ℝ (Fin 2)) ×
+                                              (EuclideanSpace ℝ (Fin 2)))))]
+                                      Φ₀) ∧
+                                    ((Φ :
+                                          (ℝ ×
+                                              ((EuclideanSpace ℝ (Fin 2)) ×
+                                                (EuclideanSpace ℝ (Fin 2)))) →
+                                            M) =ᶠ[𝓝
+                                          ((1 : ℝ),
+                                            (0 :
+                                              ((EuclideanSpace ℝ (Fin 2)) ×
+                                                (EuclideanSpace ℝ (Fin 2)))))]
+                                        linearTransverseChart (C.prodCongr R) Φ₁) ∧
+                                      (∀ z ∈ Φ.source, Φ z ∈ Set.range f ↔ z.1 = 0 ∧ z.2.2 = 0) ∧
+                                        (∀ z ∈ Φ.source,
+                                            Φ z ∈ Set.range g ↔ z.1 = 1 ∧ z.2.1 = 0) ∧
+                                          Φ.target ⊆ (Set.range b)ᶜ ∧
+                                            (∀ t z, z ∈ Set.range b → A.family (t, z) = z) ∧
+                                              (∀ t ∈ Set.Icc (0 : ℝ) 1,
+                                                  ∀ u : X,
+                                                    ∀ v : Y,
+                                                      A.family (t, f u) = g v ↔
+                                                        t = A.time ∧ u = x ∧ v = y) ∧
+                                                Smale.NativeTransversality.At (𝓘(ℝ, ℝ).prod (𝓡 2))
+                                                  (𝓡 2) 𝓘(ℝ, E)
+                                                  (fun p : ℝ × X => A.family (p.1, f p.2)) g
+                                                  (A.time, x) y := by
+  have hx : f x ∉ Set.range g := fun h => (Set.disjoint_left.mp hdisj) ⟨x, rfl⟩ h
+  have hy : g y ∉ Set.range f := fun h => (Set.disjoint_left.mp hdisj) h ⟨y, rfl⟩
+  obtain
+    ⟨Φ₀, Φ₁, hΦ₀, hΦ₁, hΦx, hΦy, hrec₀, hrec₁, a, ha, hleft, hright, hemb, hi, hcount₀, hcount₁,
+      haO⟩ :=
+    exists_clean_two_sheet_arc_avoiding hf hg hfe hge hfi hgi hb hbc hdim x y hx hy hbx hby γ
+  refine ⟨Φ₀, Φ₁, hΦ₀, hΦ₁, hΦx, hΦy, hrec₀, hrec₁, ?_⟩
+  intro C
+  have hinj : Set.InjOn a (Set.Icc (0 : ℝ) 1) := by
+    intro s hs t ht hst
+    exact congrArg Subtype.val (hemb.injective (a₁ := ⟨s, hs⟩) (a₂ := ⟨t, ht⟩) hst)
+  obtain ⟨R, ε, hε, Φ, hprod, haxis, hgl, hgr, hrecf, hrecg, hΦO⟩ :=
+    exists_clean_sheet_arc_tube_with_normal_change ha hinj hi hdim Φ₀ Φ₁ hΦ₀ hΦ₁ hleft hright
+      (isCompact_range hf.continuous).isClosed (isCompact_range hg.continuous).isClosed hrec₀
+      hrec₁ hcount₀ hcount₁ hbc.isOpen_compl haO C
+  have hzero :
+    Set.Icc (0 : ℝ) 1 ×ˢ {(0 : ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))} ⊆
+      Φ.source := by
+    rintro ⟨t, z⟩ ⟨ht, hz⟩
+    have hz0 : z = 0 := hz
+    subst z
+    exact hprod ⟨ht, Metric.mem_closedBall_self hε.le⟩
+  have h0 : (0 : (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))) ∈ Φ.source :=
+    hzero ⟨⟨le_rfl, zero_le_one⟩, rfl⟩
+  have hfx : Φ 0 = f x := (haxis 0).trans (hleft.eq_of_nhds.trans hΦx)
+  have hgy : Φ (1, 0) = g y := (haxis 1).trans (hright.eq_of_nhds.trans hΦy)
+  obtain ⟨A⟩ := nonempty_longitudinalTubeMotion Φ hzero
+  refine
+    ⟨R, ε, hε, Φ, A, hprod, hfx, hgy, hgl, hgr, hrecf, hrecg, hΦO, ?_,
+      A.whole_sheet_crossing_iff hfe.injective hge.injective hdisj hrecf hrecg x y hfx hgy h0,
+      A.whole_sheet_transverse (hf.mdifferentiable (by simp) x) (hg.mdifferentiable (by simp) y)
+        (hfi x) (hgi y) hrecf hrecg hfx hgy h0⟩
+  intro t z hz
+  exact A.fixed_outside_target t z (fun h => hΦO h hz)
+
+private theorem
+    MorseCancel.LongitudinalTubeMotion.sheet_trace_germ_of_endpoint_germs {U V E M X : Type*}
+    [NormedAddCommGroup U] [NormedSpace ℝ U] [NormedAddCommGroup V] [NormedSpace ℝ V]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [TopologicalSpace X] {Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × (U × V)) 𝓘(ℝ, E) (ℝ × (U × V)) M ∞}
+    (A : MorseCancel.LongitudinalTubeMotion Φ)
+    (Φ₀ Φ₁ : PartialDiffeomorph 𝓘(ℝ, ℝ × (U × V)) 𝓘(ℝ, E) (ℝ × (U × V)) M ∞) (C : U ≃L[ℝ] U)
+    (R : V ≃L[ℝ] V) {f : X → M} {x : X} (hf : ContinuousAt f x)
+    (h0 : (0 : ℝ × (U × V)) ∈ Φ.source) (hΦ₀ : (0 : ℝ × (U × V)) ∈ Φ₀.source) (hx : Φ₀ 0 = f x)
+    (hrec : ∀ z ∈ Φ₀.source, Φ₀ z ∈ Set.range f ↔ z.1 = 0 ∧ z.2.2 = 0)
+    (hleft : (Φ : ℝ × (U × V) → M) =ᶠ[𝓝 (0 : ℝ × (U × V))] Φ₀)
+    (hright :
+      (Φ : ℝ × (U × V) → M) =ᶠ[𝓝 ((1 : ℝ), (0 : U × V))]
+        MorseCancel.linearTransverseChart (C.prodCongr R) Φ₁) :
+    (fun p : ℝ × X => A.family (p.1, f p.2)) =ᶠ[𝓝 (A.time, x)] fun p =>
+      Φ₁ (Real.smoothTransition p.1 * A.destination, (C (Φ₀.symm (f p.2)).2.1, 0)) := by
+  let W := ℝ × (U × V)
+  let a : X → W := Φ₀.symm ∘ f
+  have hfx : f x ∈ Φ₀.target := hx ▸ Φ₀.map_source hΦ₀
+  have ha : ContinuousAt a x :=
+    (Φ₀.symm.contMDiffOn_toFun.continuousOn.continuousAt (Φ₀.open_target.mem_nhds hfx)).comp hf
+  have ha0 : a x = 0 := (congrArg Φ₀.symm hx).symm.trans (Φ₀.left_inv hΦ₀)
+  have hat : Filter.Tendsto a (𝓝 x) (𝓝 (0 : W)) := by simpa only [ha0] using ha.tendsto
+  have hfn : ∀ᶠ q in 𝓝 x, f q ∈ Φ₀.target := hf.eventually (Φ₀.open_target.mem_nhds hfx)
+  have hplane : ∀ᶠ q in 𝓝 x, (a q).1 = 0 ∧ (a q).2.2 = 0 := by
+    filter_upwards [hfn] with q hq
+    exact (hrec (a q) (Φ₀.map_target hq)).mp ⟨q, (Φ₀.right_inv hq).symm⟩
+  have hat' : Filter.Tendsto (fun p : ℝ × X => a p.2) (𝓝 (A.time, x)) (𝓝 (0 : W)) :=
+    hat.comp continuous_snd.continuousAt
+  have hpair :
+    Filter.Tendsto (fun p : ℝ × X => (p.1, a p.2)) (𝓝 (A.time, x)) (𝓝 (A.time, (0 : W))) :=
+    continuous_fst.continuousAt.prodMk_nhds hat'
+  let z : ℝ × X → W := fun p => (Real.smoothTransition p.1 * A.destination, ((a p.2).2.1, 0))
+  have hap : ContinuousAt (fun p : ℝ × X => a p.2) (A.time, x) :=
+    ContinuousAt.comp (g := a) (f := fun p : ℝ × X => p.2) ha continuousAt_snd
+  have hz : ContinuousAt z (A.time, x) :=
+    ((Real.smoothTransition.continuous.continuousAt.comp continuousAt_fst).mul
+          continuousAt_const).prodMk
+      (hap.snd.fst.prodMk continuousAt_const)
+  have hz0 : z (A.time, x) = (1, 0) := by
+    simp only [z, A.time_value, ha0, Prod.fst_zero, Prod.snd_zero]
+    rfl
+  have hzt : Filter.Tendsto z (𝓝 (A.time, x)) (𝓝 ((1 : ℝ), (0 : U × V))) := by
+    simpa only [hz0] using hz.tendsto
+  filter_upwards [hpair.eventually (A.native_germ h0 A.time), hat'.eventually hleft,
+    continuous_snd.continuousAt.eventually hfn, continuous_snd.continuousAt.eventually hplane,
+    hzt.eventually hright] with p hm hl hf' hp hr
+  have hpoint : Φ (a p.2) = f p.2 := hl.trans (Φ₀.right_inv hf')
+  calc
+    A.family (p.1, f p.2) = A.family (p.1, Φ (a p.2)) :=
+      congrArg (fun y => A.family (p.1, y)) hpoint.symm
+    _ = Φ ((a p.2).1 + Real.smoothTransition p.1 * A.destination, (a p.2).2) := hm
+    _ = Φ (z p) := by
+      apply congrArg Φ
+      rw [hp.1, zero_add]
+      exact Prod.ext rfl (Prod.ext rfl hp.2)
+    _ = Φ₁ (Real.smoothTransition p.1 * A.destination, (C (Φ₀.symm (f p.2)).2.1, 0)) := by
+      change Φ (z p) = Φ₁ (Real.smoothTransition p.1 * A.destination, (C (a p.2).2.1, 0))
+      rw [hr]
+      change Φ₁ (Real.smoothTransition p.1 * A.destination, (C (a p.2).2.1, R 0)) = _
+      rw [map_zero]
+
+private theorem MorseCancel.exists_centered_passage_clock {τ : ℝ} (hτ : τ ∈ Set.Ioo (0 : ℝ) 1) :
+    ∃ D : Diffeomorph 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) ℝ ℝ ∞,
+      D 0 = 0 ∧
+        D 1 = 1 ∧
+          D (1 / 2) = τ ∧
+            StrictMono D ∧
+              Set.MapsTo D (Set.Icc (0 : ℝ) 1) (Set.Icc (0 : ℝ) 1) ∧
+                ((D : ℝ → ℝ) =ᶠ[𝓝 (1 / 2 : ℝ)] fun t => t + (τ - 1 / 2)) ∧
+                  HasDerivAt (D : ℝ → ℝ) 1 (1 / 2) := by
+  obtain ⟨D, hfix, hgerm, hpoint, hmono, -⟩ :=
+    Degree.MorseRearrangement.exists_increasing_interval_translation
+      (show (1 / 2 : ℝ) ∈ Set.Ioo (0 : ℝ) 1 by constructor <;> norm_num) hτ
+  have h0 : D 0 = 0 := hfix 0 (by simp)
+  have h1 : D 1 = 1 := hfix 1 (by simp)
+  refine ⟨D, h0, h1, hpoint, hmono, ?_, hgerm, ?_⟩
+  · intro t ht
+    exact ⟨h0 ▸ hmono.monotone ht.1, h1 ▸ hmono.monotone ht.2⟩
+  · exact ((hasDerivAt_id (1 / 2 : ℝ)).add_const (τ - 1 / 2)).congr_of_eventuallyEq hgerm
+
+private theorem MorseCancel.exists_radial_link_meridian_with_derivative {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (H : C(ℝ × (Smale.Hemisphere.Sphere 2), d.UpperLevel)) {τ : ℝ} (hτ : τ ∈ Set.Ioo (0 : ℝ) 1)
+    (x₀ : (Smale.Hemisphere.Sphere 2)) (v : Metric.sphere (0 : d.chart.PositiveCoordinates) 1)
+    (hpoint : d.surgery.beltSphere v = H (τ, x₀))
+    (hcross :
+      ∀ t ∈ Set.Icc (0 : ℝ) 1,
+        ∀ x : (Smale.Hemisphere.Sphere 2),
+          H (t, x) ∈ Set.range d.surgery.beltSphere ↔ t = τ ∧ x = x₀)
+    (L : (EuclideanSpace ℝ (Fin 3)) ≃L[ℝ] d.chart.NegativeCoordinates)
+    (hL :
+      HasFDerivAt
+        (fun z : (EuclideanSpace ℝ (Fin 3)) => d.beltNormal (H (radialParameterChart τ x₀ z)))
+        L.toContinuousLinearMap 0) :
+    let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    ContMDiffAt (𝓘(ℝ, ℝ).prod (𝓡 2)) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ H (τ, x₀) →
+      ∃ (ε : ℝ) (hε : 0 < ε) (hεx : ε < Real.exp τ),
+        ∃ (w : Metric.sphere (0 : d.chart.PositiveCoordinates) 1) (β :
+          C((Smale.Hemisphere.Sphere 2), Metric.sphere (0 : d.chart.NegativeCoordinates) 1)),
+          SingularMayerVietoris.singularHomologyMap β 2 =
+              SingularMayerVietoris.singularHomologyMap
+                (Smale.LinearSphereAction.sphereMap L.toContinuousLinearMap L.injective) 2 ∧
+            ((Degree.PassageHomology.puncturedPassageTrace H (Set.range d.surgery.beltSphere) hτ
+                      x₀ hcross).comp
+                  (Degree.PassageHomology.cylinderLink τ x₀ ε hε hεx)).Homotopic
+              ((nativeBeltTubeMeridian d w (1 / 2) (by norm_num) (by norm_num)).comp β) := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  dsimp only
+  intro hg
+  let Ψ := radialParameterChart τ x₀
+  have hΨ0 : (0 : (EuclideanSpace ℝ (Fin 3))) ∈ Ψ.source :=
+    radialParameterChart_zero_mem_source τ x₀
+  have hΨ : ContMDiffAt (𝓡 3) (𝓘(ℝ, ℝ).prod (𝓡 2)) ∞ Ψ 0 :=
+    Ψ.contMDiffOn_toFun.contMDiffAt (Ψ.open_source.mem_nhds hΨ0)
+  have hΨc : ContinuousAt Ψ 0 := hΨ.continuousAt
+  have htime :
+    (fun z : (EuclideanSpace ℝ (Fin 3)) => (Ψ z).1) ⁻¹' Set.Ioo (0 : ℝ) 1 ∈
+      𝓝 (0 : (EuclideanSpace ℝ (Fin 3))) := by
+    apply hΨc.fst.preimage_mem_nhds
+    apply isOpen_Ioo.mem_nhds
+    simpa only [Ψ, radialParameterChart_zero] using hτ
+  let t :=
+    Ψ.source ∩
+      (Metric.ball (0 : (EuclideanSpace ℝ (Fin 3))) (Real.exp τ) ∩
+        (fun z : (EuclideanSpace ℝ (Fin 3)) => (Ψ z).1) ⁻¹' Set.Ioo (0 : ℝ) 1)
+  have ht : t ∈ 𝓝 (0 : (EuclideanSpace ℝ (Fin 3))) :=
+    Filter.inter_mem (Ψ.open_source.mem_nhds hΨ0)
+      (Filter.inter_mem (Metric.ball_mem_nhds _ (Real.exp_pos τ)) htime)
+  have hc : ContinuousOn (fun z : (EuclideanSpace ℝ (Fin 3)) => H (Ψ z)) t :=
+    H.continuous.comp_continuousOn (Ψ.contMDiffOn_toFun.continuousOn.mono Set.inter_subset_left)
+  have hcenter : H (Ψ 0) = d.surgery.beltSphere v := by
+    rw [show Ψ 0 = (τ, x₀) from radialParameterChart_zero τ x₀]
+    exact hpoint.symm
+  obtain ⟨s, hs, hst, hcs, hdomain, hsmall⟩ :=
+    exists_small_native_belt_neighborhood d (fun z : (EuclideanSpace ℝ (Fin 3)) => H (Ψ z)) v ht
+      hc hcenter
+  have hgΨ : ContMDiffAt (𝓘(ℝ, ℝ).prod (𝓡 2)) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ H (Ψ 0) := by
+    rw [show Ψ 0 = (τ, x₀) from radialParameterChart_zero τ x₀]
+    exact hg
+  have hnormal :=
+    d.contMDiffOn_beltNormal hf |>.contMDiffAt
+      (d.isOpen_beltNormalDomain.mem_nhds (d.belt_mem_normalDomain v))
+  have hnormal' :
+    ContMDiffAt 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, d.chart.NegativeCoordinates) ∞ d.beltNormal
+      (H (Ψ 0)) := by
+    rw [hcenter]
+    exact hnormal
+  have hF : ContDiffAt ℝ ∞ (fun z : (EuclideanSpace ℝ (Fin 3)) => d.beltNormal (H (Ψ z))) 0 :=
+    (ContMDiffAt.comp (g := d.beltNormal) (f := fun z : (EuclideanSpace ℝ (Fin 3)) => H (Ψ z)) 0
+        hnormal' (hgΨ.comp 0 hΨ)).contDiffAt
+  have hF0 : d.beltNormal (H (Ψ 0)) = 0 := by rw [hcenter, d.beltNormal_belt]
+  obtain ⟨b⟩ := Smale.LocalDegree.nonempty_boundaryData_of_contDiffAt L hL hF0 hs hF
+  have hball (u : (Smale.Hemisphere.Sphere 2)) : b.radius • u.val ∈ s := by
+    apply b.ball_subset
+    rw [mem_closedBall_zero_iff, Smale.LocalDegree.norm_radius_smul b.radius b.radius_pos u]
+  have hεx : b.radius < Real.exp τ := by
+    have hh := (hst (hball x₀)).2.1
+    rwa [mem_ball_zero_iff, Smale.LocalDegree.norm_radius_smul b.radius b.radius_pos x₀] at hh
+  obtain ⟨J, hJ, w, hmeridian⟩ :=
+    normal_boundary_homotopic_native_meridian d (fun z : (EuclideanSpace ℝ (Fin 3)) => H (Ψ z)) b
+      hcs hdomain hsmall (1 / 2) (by norm_num) (by norm_num)
+  have hlink :
+    (Degree.PassageHomology.puncturedPassageTrace H (Set.range d.surgery.beltSphere) hτ x₀
+            hcross).comp
+        (Degree.PassageHomology.cylinderLink τ x₀ b.radius b.radius_pos hεx) =
+      J := by
+    apply ContinuousMap.ext
+    intro u
+    apply Subtype.ext
+    have htimeu :
+      (Degree.PassageHomology.cylinderLink τ x₀ b.radius b.radius_pos hεx u).val.1 ∈
+        Set.Icc (0 : ℝ) 1 := by
+      rw [← radialParameterChart_link τ x₀ b.radius b.radius_pos hεx u]
+      exact ⟨(hst (hball u)).2.2.1.le, (hst (hball u)).2.2.2.le⟩
+    rw [ContinuousMap.comp_apply,
+      Degree.PassageHomology.puncturedPassageTrace_on_interval H (Set.range d.surgery.beltSphere)
+        hτ x₀ hcross _ htimeu,
+      hJ]
+    rw [show Ψ (b.radius • u.val) = _ from
+        radialParameterChart_link τ x₀ b.radius b.radius_pos hεx u]
+  refine ⟨b.radius, b.radius_pos, hεx, w, b.normalizedMap, b.normalized_homology_compare 2, ?_⟩
+  rw [hlink]
+  exact hmeridian
+
+private theorem AdaptedWindows.exists_passage_derivative_class_addition {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (p : Smale.ManifoldMorse.criticalPoints E f)
+    [Fact (Module.finrank ℝ (S.data p).chart.NegativeCoordinates = 2 + 1)]
+    (H : C(ℝ × (Smale.Hemisphere.Sphere 2), (S.data p).UpperLevel)) {τ : ℝ}
+    (hτ : τ ∈ Set.Ioo (0 : ℝ) 1) (x₀ : (Smale.Hemisphere.Sphere 2))
+    (v : Metric.sphere (0 : (S.data p).chart.PositiveCoordinates) 1)
+    (hpoint : (S.data p).surgery.beltSphere v = H (τ, x₀))
+    (hcross :
+      ∀ t ∈ Set.Icc (0 : ℝ) 1,
+        ∀ x : (Smale.Hemisphere.Sphere 2),
+          H (t, x) ∈ Set.range (S.data p).surgery.beltSphere ↔ t = τ ∧ x = x₀)
+    (L : (EuclideanSpace ℝ (Fin 3)) ≃L[ℝ] (S.data p).chart.NegativeCoordinates)
+    (hL :
+      HasFDerivAt
+        (fun z : (EuclideanSpace ℝ (Fin 3)) =>
+          (S.data p).beltNormal (H (MorseCancel.radialParameterChart τ x₀ z)))
+        L.toContinuousLinearMap 0) :
+    let _ := Smale.RegularLevel.chartedSpace hf (S.data p).upper_regular
+    ContMDiffAt (𝓘(ℝ, ℝ).prod (𝓡 2)) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ H (τ, x₀) →
+      ∃ D :
+        C(((Set.range (S.data p).surgery.beltSphere)ᶜ : Set (S.data p).UpperLevel),
+          (S.data p).LowerLevel),
+        (∀ x, ∃ t : ℝ, S.flow t x.val.val = (D x).val) ∧
+          (∀ x (y : (S.data p).LowerLevel) (t : ℝ), S.flow t x.val.val = y.val → D x = y) ∧
+            let G :=
+              D.comp
+                (Degree.PassageHomology.puncturedPassageTrace H
+                  (Set.range (S.data p).surgery.beltSphere) hτ x₀ hcross)
+            SingularMayerVietoris.singularHomologyMap
+                (G.comp (Degree.PassageHomology.cylinderSlice τ x₀ 1 hτ.2.ne')) 2 =
+              SingularMayerVietoris.singularHomologyMap
+                  (G.comp (Degree.PassageHomology.cylinderSlice τ x₀ 0 hτ.1.ne)) 2 +
+                SingularMayerVietoris.singularHomologyMap
+                  ((S.data p).surgery.attachingSphere.comp
+                    (Smale.LinearSphereAction.sphereMap L.toContinuousLinearMap L.injective))
+                  2 := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data p).upper_regular
+  dsimp only
+  intro hg
+  let e :
+    (Smale.Hemisphere.Sphere 2) ≃ₜ Metric.sphere (0 : (S.data p).chart.NegativeCoordinates) 1 :=
+    (Smale.SphereCoordinates.standardParametrization (S.data p).chart.NegativeCoordinates
+        2).toHomeomorph
+  obtain ⟨D, horbit, hunique, hmeridian, _, hrelation⟩ :=
+    S.exists_lower_passage_homology_relation hf p (e x₀) v H hτ x₀ hcross
+  obtain ⟨ε, hε, hεx, w, β, hβ, hlink⟩ :=
+    MorseCancel.exists_radial_link_meridian_with_derivative (S.data p) hf H hτ x₀ v hpoint hcross
+      L hL hg
+  let σ : unitInterval := ⟨1 / 2, by norm_num, by norm_num⟩
+  have hσ : 0 < (σ : ℝ) := by norm_num [σ]
+  have htube :
+    MorseCancel.nativeBeltTubeMeridian (S.data p) w (1 / 2) (by norm_num) (by norm_num) =
+      MorseCancel.nativeUpperMeridianInComplement S p w σ hσ :=
+    MorseCancel.nativeBeltTubeMeridian_eq S p w (1 / 2) (by norm_num) (by norm_num)
+  rw [htube] at hlink
+  let G :=
+    D.comp
+      (Degree.PassageHomology.puncturedPassageTrace H (Set.range (S.data p).surgery.beltSphere) hτ
+        x₀ hcross)
+  have hDlink :
+    (G.comp (Degree.PassageHomology.cylinderLink τ x₀ ε hε hεx)).Homotopic
+      ((D.comp (MorseCancel.nativeUpperMeridianInComplement S p w σ hσ)).comp β) :=
+    (ContinuousMap.Homotopic.refl D).comp hlink
+  have hatt :
+    ((D.comp (MorseCancel.nativeUpperMeridianInComplement S p w σ hσ)).comp β).Homotopic
+      ((S.data p).surgery.attachingSphere.comp β) :=
+    (hmeridian w σ hσ).comp (ContinuousMap.Homotopic.refl β)
+  have hlinkMap := PeriodTorusHigherHomology.homotopic_homologyMap (hDlink.trans hatt) 2
+  have hderivativeMap :
+    SingularMayerVietoris.singularHomologyMap ((S.data p).surgery.attachingSphere.comp β) 2 =
+      SingularMayerVietoris.singularHomologyMap
+        ((S.data p).surgery.attachingSphere.comp
+          (Smale.LinearSphereAction.sphereMap L.toContinuousLinearMap L.injective))
+        2 := by
+    rw [PeriodTorusHigherHomology.singularHomologyMap_comp,
+      PeriodTorusHigherHomology.singularHomologyMap_comp, hβ]
+  refine ⟨D, horbit, hunique, ?_⟩
+  have hh := hrelation ε hε hεx
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (G.comp (Degree.PassageHomology.cylinderSlice τ x₀ 1 hτ.2.ne')) 2 =
+      SingularMayerVietoris.singularHomologyMap
+          (G.comp (Degree.PassageHomology.cylinderSlice τ x₀ 0 hτ.1.ne)) 2 +
+        SingularMayerVietoris.singularHomologyMap
+          (G.comp (Degree.PassageHomology.cylinderLink τ x₀ ε hε hεx)) 2 at hh
+  rw [hlinkMap, hderivativeMap] at hh
+  exact hh
+
+private theorem MorseCancel.attaching_contributions_opposite_of_relative_det_neg {N Y : Type}
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [TopologicalSpace Y]
+    (a : C(Metric.sphere (0 : N) 1, Y)) (L₀ L₁ : (EuclideanSpace ℝ (Fin 3)) ≃L[ℝ] N)
+    (hdet : (L₁.trans L₀.symm).toLinearEquiv.toLinearMap.det < 0) :
+    SingularMayerVietoris.singularHomologyMap
+        (a.comp (Smale.LinearSphereAction.sphereMap L₁.toContinuousLinearMap L₁.injective)) 2 =
+      -SingularMayerVietoris.singularHomologyMap
+          (a.comp (Smale.LinearSphereAction.sphereMap L₀.toContinuousLinearMap L₀.injective)) 2 :=
+  by
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp,
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+  apply LinearMap.ext
+  intro u
+  have h := Smale.LinearSphereAction.homology_relative_sign 1 L₁ L₀ 1 u
+  rw [sign_eq_neg_one_iff.mpr hdet] at h
+  simp only [SignType.coe_neg, SignType.coe_one, neg_one_zsmul] at h
+  change
+    SingularMayerVietoris.singularHomologyMap a 2
+        (SingularMayerVietoris.singularHomologyMap
+          (Smale.LinearSphereAction.sphereMap L₁.toContinuousLinearMap L₁.injective) 2 u) =
+      -SingularMayerVietoris.singularHomologyMap a 2
+          (SingularMayerVietoris.singularHomologyMap
+            (Smale.LinearSphereAction.sphereMap L₀.toContinuousLinearMap L₀.injective) 2 u)
+  rw [h, map_neg]
+
+private def
+    MorseCancel.passageNormalProduct {U : Type} [NormedAddCommGroup U] [NormedSpace ℝ U] (c : ℝ)
+    (hc : c ≠ 0) (C : U ≃L[ℝ] U) : (ℝ × U) ≃L[ℝ] (ℝ × U) :=
+  (LinearEquiv.smulOfNeZero ℝ ℝ c hc).toContinuousLinearEquiv.prodCongr C
+
+private theorem
+    MorseCancel.passageNormalProduct_det {U : Type} [NormedAddCommGroup U] [NormedSpace ℝ U]
+    [FiniteDimensional ℝ U] (c : ℝ) (hc : c ≠ 0) (C : U ≃L[ℝ] U) :
+    (passageNormalProduct c hc C).toLinearMap.det = c * C.toLinearMap.det := by
+  have hscale :
+    (LinearEquiv.smulOfNeZero ℝ ℝ c hc).toLinearMap = c • (LinearMap.id : ℝ →ₗ[ℝ] ℝ) := by
+    ext
+    rfl
+  change LinearMap.det ((LinearEquiv.smulOfNeZero ℝ ℝ c hc).toLinearMap.prodMap C.toLinearMap) = _
+  rw [LinearMap.det_prodMap, hscale, LinearMap.det_smul, Module.finrank_self, pow_one,
+    LinearMap.det_id, mul_one]
+
+private theorem MorseCancel.relative_normal_frame_det {U N : Type} [NormedAddCommGroup U]
+    [NormedSpace ℝ U] [NormedAddCommGroup N] [NormedSpace ℝ N]
+    (P : (EuclideanSpace ℝ (Fin 3)) ≃L[ℝ] (ℝ × U)) (B : (ℝ × U) ≃L[ℝ] N)
+    (Q₀ Q₁ : (ℝ × U) ≃L[ℝ] (ℝ × U)) :
+    (((P.trans Q₁).trans B).trans ((P.trans Q₀).trans B).symm).toLinearMap.det =
+      Q₀.toLinearMap.det⁻¹ * Q₁.toLinearMap.det := by
+  have heq :
+    (((P.trans Q₁).trans B).trans ((P.trans Q₀).trans B).symm).toLinearMap =
+      P.symm.toLinearMap.comp ((Q₀.symm.toLinearMap.comp Q₁.toLinearMap).comp P.toLinearMap) := by
+    apply LinearMap.ext
+    intro z
+    change P.symm (Q₀.symm (B.symm (B (Q₁ (P z))))) = P.symm (Q₀.symm (Q₁ (P z)))
+    rw [B.symm_apply_apply]
+  rw [heq]
+  have hconj := LinearMap.det_conj (Q₀.symm.toLinearMap.comp Q₁.toLinearMap) P.symm.toLinearEquiv
+  calc
+    _ = (Q₀.symm.toLinearMap.comp Q₁.toLinearMap).det := hconj
+    _ = _ := by
+      rw [LinearMap.det_comp]
+      exact
+        congrArg (fun t : ℝ => t * Q₁.toLinearMap.det) (LinearEquiv.det_coe_symm Q₀.toLinearEquiv)
+
+private theorem MorseCancel.passage_normal_relative_det_neg {U N : Type} [NormedAddCommGroup U]
+    [NormedSpace ℝ U] [FiniteDimensional ℝ U] [NormedAddCommGroup N] [NormedSpace ℝ N]
+    (P : (EuclideanSpace ℝ (Fin 3)) ≃L[ℝ] (ℝ × U)) (B : (ℝ × U) ≃L[ℝ] N) {c₀ c₁ : ℝ}
+    (hc₀ : 0 < c₀) (hc₁ : 0 < c₁) (C : U ≃L[ℝ] U) (hC : C.toLinearMap.det < 0) :
+    (((P.trans (passageNormalProduct c₁ hc₁.ne' C)).trans B).trans
+          ((P.trans (passageNormalProduct c₀ hc₀.ne' (ContinuousLinearEquiv.refl ℝ U))).trans
+              B).symm).toLinearMap.det <
+      0 := by
+  rw [relative_normal_frame_det, passageNormalProduct_det, passageNormalProduct_det]
+  change (c₀ * (LinearMap.id : U →ₗ[ℝ] U).det)⁻¹ * (c₁ * C.toLinearMap.det) < 0
+  rw [LinearMap.det_id, mul_one]
+  exact mul_neg_of_pos_of_neg (inv_pos.mpr hc₀) (mul_neg_of_pos_of_neg hc₁ hC)
+
+private theorem MorseCancel.mfderiv_normal_trace_model {U H X N : Type*} [NormedAddCommGroup U]
+    [NormedSpace ℝ U] [TopologicalSpace H] {I : ModelWithCorners ℝ U H} [TopologicalSpace X]
+    [ChartedSpace H X] [NormedAddCommGroup N] [NormedSpace ℝ N] {α : X → U} {x : X}
+    (hα : MDifferentiableAt I 𝓘(ℝ, U) α x) (hα0 : α x = 0) {η : ℝ → ℝ} {τ κ : ℝ}
+    (hη : HasDerivAt η κ τ) (hη1 : η τ = 1) (C : U ≃L[ℝ] U) {G : (ℝ × U) → N}
+    {B : (ℝ × U) →L[ℝ] N} (hG : HasFDerivAt G B 0) :
+    (mfderiv (𝓘(ℝ, ℝ).prod I) 𝓘(ℝ, N) (fun p : ℝ × X => G (η p.1 - 1, C (α p.2))) (τ, x) :
+        (ℝ × U) →L[ℝ] N) =
+      B.comp
+        ((ContinuousLinearMap.smulRight (1 : ℝ →L[ℝ] ℝ) κ).prodMap
+          (C.toContinuousLinearMap.comp (mfderiv I 𝓘(ℝ, U) α x))) := by
+  have ht :=
+    (hη.sub_const 1).hasFDerivAt.hasMFDerivAt.comp (τ, x)
+      (hasMFDerivAt_fst (I := 𝓘(ℝ, ℝ)) (I' := I) (τ, x))
+  have hu := C.hasFDerivAt.hasMFDerivAt.comp x hα.hasMFDerivAt
+  have hu' := hu.comp (τ, x) (hasMFDerivAt_snd (I := 𝓘(ℝ, ℝ)) (I' := I) (τ, x))
+  have hpair :
+    HasMFDerivAt (𝓘(ℝ, ℝ).prod I) 𝓘(ℝ, ℝ × U) (fun p : ℝ × X => (η p.1 - 1, C (α p.2))) (τ, x)
+      ((ContinuousLinearMap.smulRight (1 : ℝ →L[ℝ] ℝ) κ).prodMap
+        (C.toContinuousLinearMap.comp (mfderiv I 𝓘(ℝ, U) α x))) := by convert! ht.prodMk hu' using 1
+  have hcenter : (η τ - 1, C (α x)) = (0 : ℝ × U) := by
+    rw [hη1, hα0, map_zero, sub_self]
+    rfl
+  have hG' : HasFDerivAt G B (η τ - 1, C (α x)) := by rw [hcenter]; exact hG
+  exact (hG'.hasMFDerivAt.comp (τ, x) hpair).mfderiv
+
+private theorem MorseCancel.LongitudinalTubeMotion.normal_trace_mfderiv {U H X N : Type*}
+    [NormedAddCommGroup U] [NormedSpace ℝ U] [TopologicalSpace H] {I : ModelWithCorners ℝ U H}
+    [TopologicalSpace X] [ChartedSpace H X] [NormedAddCommGroup N] [NormedSpace ℝ N]
+    {V E M : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × (U × V)) 𝓘(ℝ, E) (ℝ × (U × V)) M ∞}
+    (A : MorseCancel.LongitudinalTubeMotion Φ)
+    (Φ₀ Φ₁ : PartialDiffeomorph 𝓘(ℝ, ℝ × (U × V)) 𝓘(ℝ, E) (ℝ × (U × V)) M ∞) (C : U ≃L[ℝ] U)
+    (R : V ≃L[ℝ] V) {f : X → M} {x : X} (hf : MDifferentiableAt I 𝓘(ℝ, E) f x)
+    (h0 : (0 : ℝ × (U × V)) ∈ Φ.source) (hΦ₀ : (0 : ℝ × (U × V)) ∈ Φ₀.source) (hx : Φ₀ 0 = f x)
+    (hrec : ∀ z ∈ Φ₀.source, Φ₀ z ∈ Set.range f ↔ z.1 = 0 ∧ z.2.2 = 0)
+    (hleft : (Φ : ℝ × (U × V) → M) =ᶠ[𝓝 (0 : ℝ × (U × V))] Φ₀)
+    (hright :
+      (Φ : ℝ × (U × V) → M) =ᶠ[𝓝 ((1 : ℝ), (0 : U × V))]
+        MorseCancel.linearTransverseChart (C.prodCongr R) Φ₁)
+    (n : M → N) (B : (ℝ × U) →L[ℝ] N)
+    (hB : HasFDerivAt (fun z : ℝ × U => n (Φ₁ (1 + z.1, (z.2, 0)))) B 0) :
+    (mfderiv (𝓘(ℝ, ℝ).prod I) 𝓘(ℝ, N) (fun p : ℝ × X => n (A.family (p.1, f p.2))) (A.time, x) :
+        (ℝ × U) →L[ℝ] N) =
+      B.comp
+        ((ContinuousLinearMap.smulRight (1 : ℝ →L[ℝ] ℝ)
+              (deriv Real.smoothTransition A.time * A.destination)).prodMap
+          (C.toContinuousLinearMap.comp
+            (mfderiv I 𝓘(ℝ, U) (fun q : X => (Φ₀.symm (f q)).2.1) x))) := by
+  let W := ℝ × (U × V)
+  let a : X → W := Φ₀.symm ∘ f
+  let P : W →L[ℝ] U := (ContinuousLinearMap.fst ℝ U V).comp (ContinuousLinearMap.snd ℝ ℝ (U × V))
+  let α : X → U := P ∘ a
+  have hfx : f x ∈ Φ₀.target := hx ▸ Φ₀.map_source hΦ₀
+  have ha : MDifferentiableAt I 𝓘(ℝ, W) a x := (Φ₀.symm.mdifferentiableAt (by simp) hfx).comp x hf
+  have hα : MDifferentiableAt I 𝓘(ℝ, U) α x := P.differentiableAt.mdifferentiableAt.comp x ha
+  have ha0 : a x = 0 := (congrArg Φ₀.symm hx).symm.trans (Φ₀.left_inv hΦ₀)
+  have hα0 : α x = 0 := by change P (a x) = 0; rw [ha0, map_zero]
+  let η : ℝ → ℝ := fun t => Real.smoothTransition t * A.destination
+  have hη : HasDerivAt η (deriv Real.smoothTransition A.time * A.destination) A.time :=
+    ((Real.smoothTransition.contDiff (n := ⊤)).differentiable (by simp)
+          A.time).hasDerivAt.mul_const
+      _
+  let G : (ℝ × U) → N := fun z => n (Φ₁ (1 + z.1, (z.2, 0)))
+  have htrace :=
+    A.sheet_trace_germ_of_endpoint_germs Φ₀ Φ₁ C R hf.continuousAt h0 hΦ₀ hx hrec hleft hright
+  have heq :
+    (fun p : ℝ × X => n (A.family (p.1, f p.2))) =ᶠ[𝓝 (A.time, x)] fun p =>
+      G (η p.1 - 1, C (α p.2)) := by
+    filter_upwards [htrace] with p hp
+    rw [hp]
+    change n (Φ₁ (η p.1, (C (α p.2), 0))) = n (Φ₁ (1 + (η p.1 - 1), (C (α p.2), 0)))
+    rw [show 1 + (η p.1 - 1) = η p.1 by ring]
+  rw [heq.mfderiv_eq]
+  exact MorseCancel.mfderiv_normal_trace_model hα hα0 hη A.time_value C hB
+
+private theorem MorseCancel.mfderiv_retime_unit_rate {U H X N : Type*} [NormedAddCommGroup U]
+    [NormedSpace ℝ U] [TopologicalSpace H] {I : ModelWithCorners ℝ U H} [TopologicalSpace X]
+    [ChartedSpace H X] [NormedAddCommGroup N] [NormedSpace ℝ N] {F : ℝ × X → N} {x : X} {σ τ : ℝ}
+    (hF : MDifferentiableAt (𝓘(ℝ, ℝ).prod I) 𝓘(ℝ, N) F (τ, x)) {D : ℝ → ℝ} (hD : HasDerivAt D 1 σ)
+    (hpoint : D σ = τ) :
+    (mfderiv (𝓘(ℝ, ℝ).prod I) 𝓘(ℝ, N) (fun p : ℝ × X => F (D p.1, p.2)) (σ, x) :
+        (ℝ × U) →L[ℝ] N) =
+      mfderiv (𝓘(ℝ, ℝ).prod I) 𝓘(ℝ, N) F (τ, x) := by
+  subst τ
+  have hDmf : HasMFDerivAt 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) D σ (ContinuousLinearMap.id ℝ ℝ) := by
+    have hid : ContinuousLinearMap.toSpanSingleton ℝ (1 : ℝ) = ContinuousLinearMap.id ℝ ℝ := by
+      ext
+      simp
+    have h := hD.hasFDerivAt
+    change HasFDerivAt D (ContinuousLinearMap.toSpanSingleton ℝ (1 : ℝ)) σ at h
+    rw [hid] at h
+    exact h.hasMFDerivAt
+  have ht := hDmf.comp (σ, x) (hasMFDerivAt_fst (I := 𝓘(ℝ, ℝ)) (I' := I) (σ, x))
+  have hp :
+    HasMFDerivAt (𝓘(ℝ, ℝ).prod I) (𝓘(ℝ, ℝ).prod I) (fun p : ℝ × X => (D p.1, p.2)) (σ, x)
+      (ContinuousLinearMap.id ℝ (ℝ × U)) := by
+    convert! ht.prodMk (hasMFDerivAt_snd (I := 𝓘(ℝ, ℝ)) (I' := I) (σ, x)) using 1
+  have hF' : MDifferentiableAt (𝓘(ℝ, ℝ).prod I) 𝓘(ℝ, N) F (D σ, x) := hF
+  have hc := (hF'.hasMFDerivAt.comp (σ, x) hp).mfderiv
+  change
+    (mfderiv (𝓘(ℝ, ℝ).prod I) 𝓘(ℝ, N) (fun p : ℝ × X => F (D p.1, p.2)) (σ, x) :
+        (ℝ × U) →L[ℝ] N) =
+      (mfderiv (𝓘(ℝ, ℝ).prod I) 𝓘(ℝ, N) F (D σ, x) : (ℝ × U) →L[ℝ] N).comp
+        (ContinuousLinearMap.id ℝ (ℝ × U)) at hc
+  apply ContinuousLinearMap.ext
+  intro z
+  exact congrArg (fun L : (ℝ × U) →L[ℝ] N => L z) hc
+
+private theorem MorseCancel.fderiv_retimed_trace_parameter {U H X N : Type*} [NormedAddCommGroup U]
+    [NormedSpace ℝ U] [TopologicalSpace H] {I : ModelWithCorners ℝ U H} [TopologicalSpace X]
+    [ChartedSpace H X] [NormedAddCommGroup N] [NormedSpace ℝ N] {A : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] {F : ℝ × X → N} {x : X} {σ τ : ℝ}
+    (hF : MDifferentiableAt (𝓘(ℝ, ℝ).prod I) 𝓘(ℝ, N) F (τ, x)) {D : ℝ → ℝ} (hD : HasDerivAt D 1 σ)
+    (hpoint : D σ = τ) (Ψ : PartialDiffeomorph 𝓘(ℝ, A) (𝓘(ℝ, ℝ).prod I) A (ℝ × X) ∞)
+    (hΨ : (0 : A) ∈ Ψ.source) (hcenter : Ψ 0 = (σ, x)) :
+    fderiv ℝ (fun z : A => F (D (Ψ z).1, (Ψ z).2)) 0 =
+      (mfderiv (𝓘(ℝ, ℝ).prod I) 𝓘(ℝ, N) F (τ, x) : (ℝ × U) →L[ℝ] N).comp
+        (mfderiv 𝓘(ℝ, A) (𝓘(ℝ, ℝ).prod I) Ψ 0) := by
+  let G : ℝ × X → N := fun p => F (D p.1, p.2)
+  have hF' : MDifferentiableAt (𝓘(ℝ, ℝ).prod I) 𝓘(ℝ, N) F (D σ, x) := by
+    rw [hpoint]
+    exact hF
+  have hG : MDifferentiableAt (𝓘(ℝ, ℝ).prod I) 𝓘(ℝ, N) G (σ, x) :=
+    hF'.comp (σ, x)
+      ((hD.differentiableAt.mdifferentiableAt.comp (σ, x) mdifferentiableAt_fst).prodMk
+        mdifferentiableAt_snd)
+  have hG' : MDifferentiableAt (𝓘(ℝ, ℝ).prod I) 𝓘(ℝ, N) G (Ψ 0) := by
+    rw [hcenter]
+    exact hG
+  change fderiv ℝ (G ∘ Ψ) 0 = _
+  rw [← mfderiv_eq_fderiv, mfderiv_comp 0 hG' (Ψ.mdifferentiableAt (by simp) hΨ), hcenter]
+  rw [show
+      (mfderiv (𝓘(ℝ, ℝ).prod I) 𝓘(ℝ, N) G (σ, x) : (ℝ × U) →L[ℝ] N) =
+        mfderiv (𝓘(ℝ, ℝ).prod I) 𝓘(ℝ, N) F (τ, x)
+      from mfderiv_retime_unit_rate hF hD hpoint]
+  rfl
+
+private theorem MorseCancel.exists_shared_passage_frames {N : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [FiniteDimensional ℝ N]
+    (P : (EuclideanSpace ℝ (Fin 3)) →L[ℝ] (ℝ × (EuclideanSpace ℝ (Fin 2))))
+    (B : (ℝ × (EuclideanSpace ℝ (Fin 2))) →L[ℝ] N)
+    (Q : (ℝ × (EuclideanSpace ℝ (Fin 2))) ≃L[ℝ] (ℝ × (EuclideanSpace ℝ (Fin 2))))
+    (hdim : Module.finrank ℝ N = 3)
+    (hbij : Function.Bijective (B.comp (Q.toContinuousLinearMap.comp P))) :
+    ∃ (P' : (EuclideanSpace ℝ (Fin 3)) ≃L[ℝ] (ℝ × (EuclideanSpace ℝ (Fin 2)))) (B' :
+      (ℝ × (EuclideanSpace ℝ (Fin 2))) ≃L[ℝ] N),
+      P'.toContinuousLinearMap = P ∧ B'.toContinuousLinearMap = B := by
+  have hPi : Function.Injective P := by
+    intro x y hxy
+    apply hbij.injective
+    change B (Q (P x)) = B (Q (P y))
+    rw [hxy]
+  have hBs : Function.Surjective B := by
+    intro y
+    obtain ⟨x, hx⟩ := hbij.surjective y
+    exact ⟨Q (P x), hx⟩
+  have hdimP :
+    Module.finrank ℝ (EuclideanSpace ℝ (Fin 3)) =
+      Module.finrank ℝ (ℝ × (EuclideanSpace ℝ (Fin 2))) := by
+    simp only [Module.finrank_prod, Module.finrank_self, finrank_euclideanSpace_fin]
+  have hdimB : Module.finrank ℝ (ℝ × (EuclideanSpace ℝ (Fin 2))) = Module.finrank ℝ N := by
+    simp only [Module.finrank_prod, Module.finrank_self, finrank_euclideanSpace_fin, hdim]
+  have hPb : Function.Bijective P :=
+    ⟨hPi, (LinearMap.injective_iff_surjective_of_finrank_eq_finrank hdimP).mp hPi⟩
+  have hBb : Function.Bijective B :=
+    ⟨(LinearMap.injective_iff_surjective_of_finrank_eq_finrank hdimB).mpr hBs, hBs⟩
+  exact
+    ⟨(LinearEquiv.ofBijective P.toLinearMap hPb).toContinuousLinearEquiv,
+      (LinearEquiv.ofBijective B.toLinearMap hBb).toContinuousLinearEquiv, rfl, rfl⟩
+
+private structure MorseCancel.CenteredSheetPassage (E : Type*) {M : Type*} {X : Type*} {Y : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] (f : X → M)
+    (g : Y → M) (x : X) (y : Y) (O : Set M) where
+  family : ℝ × M → M
+  support : Set M
+  compact_support : IsCompact support
+  avoids : support ⊆ Oᶜ
+  smooth : ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, E)) 𝓘(ℝ, E) ∞ family
+  zero : ∀ z, family (0, z) = z
+  slices : ∀ t, ∃ d : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞, ∀ z, d z = family (t, z)
+  fixedOutside : ∀ t z, z ∉ support → family (t, z) = z
+  crossing :
+    ∀ t ∈ Set.Icc (0 : ℝ) 1, ∀ u : X, ∀ v : Y, family (t, f u) = g v ↔ t = 1 / 2 ∧ u = x ∧ v = y
+
+private def MorseCancel.LongitudinalTubeMotion.centeredSheetPassage {E M X Y : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {V : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℝ V]
+    {Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × V) 𝓘(ℝ, E) (ℝ × V) M ∞}
+    (A : MorseCancel.LongitudinalTubeMotion Φ) (D : Diffeomorph 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) ℝ ℝ ∞)
+    (hD0 : D 0 = 0) (hpoint : D (1 / 2) = A.time)
+    (hinterval : Set.MapsTo D (Set.Icc (0 : ℝ) 1) (Set.Icc (0 : ℝ) 1)) {f : X → M} {g : Y → M}
+    {x : X} {y : Y} {O : Set M} (havoid : Φ.target ⊆ Oᶜ)
+    (hcross :
+      ∀ t ∈ Set.Icc (0 : ℝ) 1,
+        ∀ u : X, ∀ v : Y, A.family (t, f u) = g v ↔ t = A.time ∧ u = x ∧ v = y) :
+    MorseCancel.CenteredSheetPassage E f g x y O
+    where
+  family := fun p => A.family (D p.1, p.2)
+  support := A.support
+  compact_support := A.compact_support
+  avoids := A.support_subset.trans havoid
+  smooth := A.smooth.comp ((D.contMDiff.comp contMDiff_fst).prodMk contMDiff_snd)
+  zero := by intro z; change A.family (D 0, z) = z; rw [hD0, A.zero]
+  slices := fun t => A.slices (D t)
+  fixedOutside := fun t z hz => A.fixedOutside (D t) z hz
+  crossing := by
+    intro t ht u v
+    rw [hcross (D t) (hinterval ht) u v]
+    constructor
+    · rintro ⟨h, hu, hv⟩
+      exact ⟨D.injective (h.trans hpoint.symm), hu, hv⟩
+    · rintro ⟨rfl, rfl, rfl⟩
+      exact ⟨hpoint, rfl, rfl⟩
+
+private theorem MorseCancel.bijective_trace_normal_of_native_transverse {E M U H X V H' Y N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [NormedAddCommGroup U] [NormedSpace ℝ U] [FiniteDimensional ℝ U] [TopologicalSpace H]
+    {I : ModelWithCorners ℝ U H} [TopologicalSpace X] [ChartedSpace H X] [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [TopologicalSpace H'] {I' : ModelWithCorners ℝ V H'} [TopologicalSpace Y]
+    [ChartedSpace H' Y] [NormedAddCommGroup N] [NormedSpace ℝ N] [FiniteDimensional ℝ N]
+    {f : X → M} {g : Y → M} {n : M → N} {x : X} {y : Y} (hf : MDifferentiableAt I 𝓘(ℝ, E) f x)
+    (hn : MDifferentiableAt 𝓘(ℝ, E) 𝓘(ℝ, N) n (g y)) (hpoint : g y = f x)
+    (htrans : Smale.NativeTransversality.At I I' 𝓘(ℝ, E) f g x y)
+    (hsurj : Function.Surjective (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, N) n (g y)))
+    (hzero : (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, N) n (g y) : E →L[ℝ] N).comp (mfderiv I' 𝓘(ℝ, E) g y) = 0)
+    (hdim : Module.finrank ℝ U = Module.finrank ℝ N) :
+    Function.Bijective (mfderiv I 𝓘(ℝ, N) (n ∘ f) x) := by
+  let Q : E →L[ℝ] N := mfderiv 𝓘(ℝ, E) 𝓘(ℝ, N) n (g y)
+  let B : V →L[ℝ] E := mfderiv I' 𝓘(ℝ, E) g y
+  let A : U →L[ℝ] E := mfderiv I 𝓘(ℝ, E) f x
+  have hbij : Function.Bijective (Q.comp A) :=
+    Smale.TransverseCoordinates.bijective_normal_comp Q B A hsurj
+      (Smale.TransverseCoordinates.surjective_coprod_swap A B (htrans hpoint)) hzero hdim
+  have hn' : MDifferentiableAt 𝓘(ℝ, E) 𝓘(ℝ, N) n (f x) := hpoint ▸ hn
+  have hder : (mfderiv I 𝓘(ℝ, N) (n ∘ f) x : U →L[ℝ] N) = Q.comp A := by
+    rw [mfderiv_comp x hn' hf, ← hpoint]
+    rfl
+  rw [hder]
+  exact hbij
+
+private theorem
+    MorseCancel.hasFDerivAt_terminal_normal_factor {E M U V N : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [NormedAddCommGroup U]
+    [NormedSpace ℝ U] [NormedAddCommGroup V] [NormedSpace ℝ V] [NormedAddCommGroup N]
+    [NormedSpace ℝ N] (Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × (U × V)) 𝓘(ℝ, E) (ℝ × (U × V)) M ∞)
+    (hΦ : ((1 : ℝ), (0 : U × V)) ∈ Φ.source) {n : M → N}
+    (hn : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, N) ∞ n (Φ (1, 0))) :
+    HasFDerivAt (fun z : ℝ × U => n (Φ (1 + z.1, (z.2, 0))))
+      (fderiv ℝ (fun z : ℝ × U => n (Φ (1 + z.1, (z.2, 0)))) 0) 0 := by
+  let Q : (ℝ × U) → ℝ × (U × V) := fun z => (1 + z.1, (z.2, 0))
+  have hQ : ContDiff ℝ ∞ Q :=
+    (contDiff_const.add contDiff_fst).prodMk (contDiff_snd.prodMk contDiff_const)
+  have hQ0 : Q 0 = (1, 0) := by
+    change ((1 : ℝ) + 0, ((0 : U), (0 : V))) = (1, 0)
+    rw [add_zero]
+    rfl
+  have hΦ' : ContMDiffAt 𝓘(ℝ, ℝ × (U × V)) 𝓘(ℝ, E) ∞ Φ (Q 0) := by
+    rw [hQ0]
+    exact Φ.contMDiffOn_toFun.contMDiffAt (Φ.open_source.mem_nhds hΦ)
+  have hn' : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, N) ∞ n (Φ (Q 0)) := by rw [hQ0]; exact hn
+  have hs : ContDiffAt ℝ ∞ (fun z : ℝ × U => n (Φ (Q z))) 0 :=
+    (ContMDiffAt.comp (g := n) (f := fun z : ℝ × U => Φ (Q z)) 0 hn'
+        (hΦ'.comp 0 hQ.contMDiff.contMDiffAt)).contDiffAt
+  exact (hs.differentiableAt (by simp)).hasFDerivAt
+
+private theorem MorseCancel.exists_centered_passage_normal_factors {E M Y Z N : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [TopologicalSpace Y]
+    [ChartedSpace (EuclideanSpace ℝ (Fin 2)) Y] [IsManifold (𝓡 2) ∞ Y] [CompactSpace Y]
+    [SecondCountableTopology Y] [TopologicalSpace Z] [ChartedSpace (EuclideanSpace ℝ (Fin 2)) Z]
+    [IsManifold (𝓡 2) ∞ Z] [SecondCountableTopology Z] [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [FiniteDimensional ℝ N] {f : (Smale.Hemisphere.Sphere 2) → M} {g : Y → M} {b : Z → M}
+    (hf : ContMDiff (𝓡 2) 𝓘(ℝ, E) ∞ f) (hg : ContMDiff (𝓡 2) 𝓘(ℝ, E) ∞ g)
+    (hfe : Topology.IsEmbedding f) (hge : Topology.IsEmbedding g)
+    (hfi : ∀ x, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, E) f x))
+    (hgi : ∀ y, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, E) g y))
+    (hdisj : Disjoint (Set.range f) (Set.range g)) (hb : ContMDiff (𝓡 2) 𝓘(ℝ, E) ∞ b)
+    (hbc : IsClosed (Set.range b)) (hdim : Module.finrank ℝ E = 5)
+    (x : (Smale.Hemisphere.Sphere 2)) (y : Y) (hbx : f x ∉ Set.range b) (hby : g y ∉ Set.range b)
+    (γ : Path (f x) (g y)) (n : M → N) (hn : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, N) ∞ n (g y))
+    (hsurj : Function.Surjective (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, N) n (g y)))
+    (hzero : (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, N) n (g y) : E →L[ℝ] N).comp (mfderiv (𝓡 2) 𝓘(ℝ, E) g y) = 0)
+    (hdimN : Module.finrank ℝ N = 3) :
+    ∃ (P : (EuclideanSpace ℝ (Fin 3)) →L[ℝ] (ℝ × (EuclideanSpace ℝ (Fin 2)))) (B :
+      (ℝ × (EuclideanSpace ℝ (Fin 2))) →L[ℝ] N),
+      ∀ C : (EuclideanSpace ℝ (Fin 2)) ≃L[ℝ] (EuclideanSpace ℝ (Fin 2)),
+        ∃ (c : ℝ) (hc : 0 < c),
+          ∃ A : CenteredSheetPassage E f g x y (Set.range b),
+            HasFDerivAt
+                (fun z : (EuclideanSpace ℝ (Fin 3)) =>
+                  n
+                    (A.family
+                      ((radialParameterChart (1 / 2) x z).1,
+                        f (radialParameterChart (1 / 2) x z).2)))
+                (B.comp ((passageNormalProduct c hc.ne' C).toContinuousLinearMap.comp P)) 0 ∧
+              Function.Bijective
+                (B.comp ((passageNormalProduct c hc.ne' C).toContinuousLinearMap.comp P)) := by
+  obtain ⟨Φ₀, Φ₁, hΦ₀, hΦ₁, hΦx, hΦy, hrec₀, _, hchoices⟩ :=
+    exists_relative_sheet_passages_with_normal_change hf hg hfe hge hfi hgi hdisj hb hbc hdim x y
+      hbx hby γ
+  let Ψ := radialParameterChart (1 / 2) x
+  have hΨ0 : (0 : (EuclideanSpace ℝ (Fin 3))) ∈ Ψ.source :=
+    radialParameterChart_zero_mem_source (1 / 2) x
+  have hΨpoint : Ψ 0 = ((1 / 2 : ℝ), x) := radialParameterChart_zero (1 / 2) x
+  let J : (EuclideanSpace ℝ (Fin 3)) →L[ℝ] (ℝ × (EuclideanSpace ℝ (Fin 2))) :=
+    mfderiv (𝓡 3) (𝓘(ℝ, ℝ).prod (𝓡 2)) Ψ 0
+  let K : (EuclideanSpace ℝ (Fin 2)) →L[ℝ] (EuclideanSpace ℝ (Fin 2)) :=
+    mfderiv (𝓡 2) 𝓘(ℝ, (EuclideanSpace ℝ (Fin 2)))
+      (fun q : (Smale.Hemisphere.Sphere 2) => (Φ₀.symm (f q)).2.1) x
+  let P : (EuclideanSpace ℝ (Fin 3)) →L[ℝ] (ℝ × (EuclideanSpace ℝ (Fin 2))) :=
+    ((ContinuousLinearMap.id ℝ ℝ).prodMap K).comp J
+  let G : (ℝ × (EuclideanSpace ℝ (Fin 2))) → N := fun z => n (Φ₁ (1 + z.1, (z.2, 0)))
+  let B : (ℝ × (EuclideanSpace ℝ (Fin 2))) →L[ℝ] N := fderiv ℝ G 0
+  have hnΦ : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, N) ∞ n (Φ₁ (1, 0)) := by rw [hΦy]; exact hn
+  have hB : HasFDerivAt G B 0 := hasFDerivAt_terminal_normal_factor Φ₁ hΦ₁ hnΦ
+  refine ⟨P, B, ?_⟩
+  intro C
+  obtain ⟨R, ε, hε, Φ, A, hprod, _, _, hleft, hright, _, _, havoid, _, hcross, htrans⟩ :=
+    hchoices C
+  have h0 : (0 : (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))) ∈ Φ.source :=
+    hprod ⟨⟨le_rfl, zero_le_one⟩, Metric.mem_closedBall_self hε.le⟩
+  obtain ⟨D, hD0, _, hDpoint, _, hDinterval, _, hDder⟩ := exists_centered_passage_clock A.time_mem
+  let T := A.centeredSheetPassage D hD0 hDpoint hDinterval havoid hcross
+  let c : ℝ := deriv Real.smoothTransition A.time * A.destination
+  have hc : 0 < c := A.time_rate
+  let F : ℝ × (Smale.Hemisphere.Sphere 2) → M := fun p => A.family (p.1, f p.2)
+  have hF : ContMDiff (𝓘(ℝ, ℝ).prod (𝓡 2)) 𝓘(ℝ, E) ∞ F :=
+    A.smooth.comp (contMDiff_fst.prodMk (hf.comp contMDiff_snd))
+  have hpoint : F (A.time, x) = g y :=
+    (hcross A.time ⟨A.time_mem.1.le, A.time_mem.2.le⟩ x y).mpr ⟨rfl, rfl, rfl⟩
+  have hnF : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, N) ∞ n (F (A.time, x)) := by rw [hpoint]; exact hn
+  let NF : ℝ × (Smale.Hemisphere.Sphere 2) → N := n ∘ F
+  have hNF : MDifferentiableAt (𝓘(ℝ, ℝ).prod (𝓡 2)) 𝓘(ℝ, N) NF (A.time, x) :=
+    (hnF.comp (A.time, x) hF.contMDiffAt).mdifferentiableAt (by simp)
+  have hNFbij : Function.Bijective (mfderiv (𝓘(ℝ, ℝ).prod (𝓡 2)) 𝓘(ℝ, N) NF (A.time, x)) :=
+    bijective_trace_normal_of_native_transverse (hF.mdifferentiable (by simp) (A.time, x))
+      (hn.mdifferentiableAt (by simp)) hpoint.symm htrans hsurj hzero
+      (by simp only [Module.finrank_prod, Module.finrank_self, finrank_euclideanSpace_fin, hdimN])
+  have hret :
+    fderiv ℝ (fun z : (EuclideanSpace ℝ (Fin 3)) => n (T.family ((Ψ z).1, f (Ψ z).2))) 0 =
+      (mfderiv (𝓘(ℝ, ℝ).prod (𝓡 2)) 𝓘(ℝ, N) NF (A.time, x) :
+            (ℝ × (EuclideanSpace ℝ (Fin 2))) →L[ℝ] N).comp
+        J :=
+    fderiv_retimed_trace_parameter hNF hDder hDpoint Ψ hΨ0 hΨpoint
+  have hfactor :
+    (mfderiv (𝓘(ℝ, ℝ).prod (𝓡 2)) 𝓘(ℝ, N) NF (A.time, x) :
+        (ℝ × (EuclideanSpace ℝ (Fin 2))) →L[ℝ] N) =
+      B.comp
+        ((ContinuousLinearMap.smulRight (1 : ℝ →L[ℝ] ℝ) c).prodMap
+          (C.toContinuousLinearMap.comp K)) :=
+    A.normal_trace_mfderiv Φ₀ Φ₁ C R (hf.mdifferentiable (by simp) x) h0 hΦ₀ hΦx hrec₀ hleft
+      hright n B hB
+  have heq :
+    fderiv ℝ (fun z : (EuclideanSpace ℝ (Fin 3)) => n (T.family ((Ψ z).1, f (Ψ z).2))) 0 =
+      B.comp ((passageNormalProduct c hc.ne' C).toContinuousLinearMap.comp P) := by
+    rw [hret, hfactor]
+    apply ContinuousLinearMap.ext
+    intro z
+    change B ((J z).1 * c, C (K (J z).2)) = B (c * (J z).1, C (K (J z).2))
+    rw [mul_comm]
+  let H : ℝ × (Smale.Hemisphere.Sphere 2) → N := fun p => NF (D p.1, p.2)
+  have hNF' : MDifferentiableAt (𝓘(ℝ, ℝ).prod (𝓡 2)) 𝓘(ℝ, N) NF (D (1 / 2), x) := by
+    rw [hDpoint]
+    exact hNF
+  have hH : MDifferentiableAt (𝓘(ℝ, ℝ).prod (𝓡 2)) 𝓘(ℝ, N) H (1 / 2, x) :=
+    MDifferentiableAt.comp (g := NF) (f := fun p : ℝ × (Smale.Hemisphere.Sphere 2) =>
+      (D p.1, p.2)) (1 / 2, x) hNF'
+      ((hDder.differentiableAt.mdifferentiableAt.comp (1 / 2, x) mdifferentiableAt_fst).prodMk
+        mdifferentiableAt_snd)
+  have hH' : MDifferentiableAt (𝓘(ℝ, ℝ).prod (𝓡 2)) 𝓘(ℝ, N) H (Ψ 0) := by
+    rw [hΨpoint]
+    exact hH
+  have hdiff :
+    DifferentiableAt ℝ (fun z : (EuclideanSpace ℝ (Fin 3)) => n (T.family ((Ψ z).1, f (Ψ z).2)))
+      0 :=
+    (hH'.comp 0 (Ψ.mdifferentiableAt (by simp) hΨ0)).differentiableAt
+  have hder :
+    HasFDerivAt (fun z : (EuclideanSpace ℝ (Fin 3)) => n (T.family ((Ψ z).1, f (Ψ z).2)))
+      (B.comp ((passageNormalProduct c hc.ne' C).toContinuousLinearMap.comp P)) 0 := by
+    rw [← heq]
+    exact hdiff.hasFDerivAt
+  have hbij :
+    Function.Bijective
+      (fderiv ℝ (fun z : (EuclideanSpace ℝ (Fin 3)) => n (T.family ((Ψ z).1, f (Ψ z).2))) 0) := by
+    rw [hret]
+    exact hNFbij.comp (Smale.PartialChart.bijective_mfderiv Ψ hΨ0)
+  exact ⟨c, hc, T, hder, heq ▸ hbij⟩
+
+private theorem MorseCancel.opposite_centered_passages_of_normal_factors {E M Y N : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [FiniteDimensional ℝ N]
+    {f : (Smale.Hemisphere.Sphere 2) → M} {g : Y → M} {x : (Smale.Hemisphere.Sphere 2)} {y : Y}
+    {O : Set M} (n : M → N) (hdim : Module.finrank ℝ N = 3)
+    (P : (EuclideanSpace ℝ (Fin 3)) →L[ℝ] (ℝ × (EuclideanSpace ℝ (Fin 2))))
+    (B : (ℝ × (EuclideanSpace ℝ (Fin 2))) →L[ℝ] N)
+    (hchoices :
+      ∀ C : (EuclideanSpace ℝ (Fin 2)) ≃L[ℝ] (EuclideanSpace ℝ (Fin 2)),
+        ∃ (c : ℝ) (hc : 0 < c),
+          ∃ A : CenteredSheetPassage E f g x y O,
+            HasFDerivAt
+                (fun z : (EuclideanSpace ℝ (Fin 3)) =>
+                  n
+                    (A.family
+                      ((radialParameterChart (1 / 2) x z).1,
+                        f (radialParameterChart (1 / 2) x z).2)))
+                (B.comp ((passageNormalProduct c hc.ne' C).toContinuousLinearMap.comp P)) 0 ∧
+              Function.Bijective
+                (B.comp ((passageNormalProduct c hc.ne' C).toContinuousLinearMap.comp P))) :
+    ∃ A₀ A₁ : CenteredSheetPassage E f g x y O,
+      ∃ L₀ L₁ : (EuclideanSpace ℝ (Fin 3)) ≃L[ℝ] N,
+        HasFDerivAt
+            (fun z : (EuclideanSpace ℝ (Fin 3)) =>
+              n
+                (A₀.family
+                  ((radialParameterChart (1 / 2) x z).1, f (radialParameterChart (1 / 2) x z).2)))
+            L₀.toContinuousLinearMap 0 ∧
+          HasFDerivAt
+              (fun z : (EuclideanSpace ℝ (Fin 3)) =>
+                n
+                  (A₁.family
+                    ((radialParameterChart (1 / 2) x z).1,
+                      f (radialParameterChart (1 / 2) x z).2)))
+              L₁.toContinuousLinearMap 0 ∧
+            (L₁.trans L₀.symm).toLinearMap.det < 0 := by
+  obtain ⟨C, hC⟩ :=
+    Degree.SupportedGerms.exists_linearEquiv_with_det (EuclideanSpace.basisFun (Fin 2) ℝ).toBasis
+      (0 : Fin 2) (show (-1 : ℝ) ≠ 0 by norm_num)
+  have hCneg : C.toLinearMap.det < 0 := by rw [hC]; norm_num
+  obtain ⟨c₀, hc₀, A₀, hA₀, hbij₀⟩ :=
+    hchoices (ContinuousLinearEquiv.refl ℝ (EuclideanSpace ℝ (Fin 2)))
+  obtain ⟨c₁, hc₁, A₁, hA₁, _⟩ := hchoices C
+  let Q₀ :=
+    passageNormalProduct c₀ hc₀.ne' (ContinuousLinearEquiv.refl ℝ (EuclideanSpace ℝ (Fin 2)))
+  let Q₁ := passageNormalProduct c₁ hc₁.ne' C
+  obtain ⟨P', B', hP, hB⟩ := exists_shared_passage_frames P B Q₀ hdim hbij₀
+  let L₀ := (P'.trans Q₀).trans B'
+  let L₁ := (P'.trans Q₁).trans B'
+  have hL₀ : L₀.toContinuousLinearMap = B.comp (Q₀.toContinuousLinearMap.comp P) := by
+    change
+      B'.toContinuousLinearMap.comp (Q₀.toContinuousLinearMap.comp P'.toContinuousLinearMap) = _
+    rw [hP, hB]
+  have hL₁ : L₁.toContinuousLinearMap = B.comp (Q₁.toContinuousLinearMap.comp P) := by
+    change
+      B'.toContinuousLinearMap.comp (Q₁.toContinuousLinearMap.comp P'.toContinuousLinearMap) = _
+    rw [hP, hB]
+  refine ⟨A₀, A₁, L₀, L₁, ?_, ?_, ?_⟩
+  · rw [hL₀]
+    exact hA₀
+  · rw [hL₁]
+    exact hA₁
+  · exact passage_normal_relative_det_neg P' B' hc₀ hc₁ C hCneg
+
+private theorem
+    MorseCancel.exists_native_opposite_centered_passages {E M Z : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} {p : M} [TopologicalSpace Z]
+    [ChartedSpace (EuclideanSpace ℝ (Fin 2)) Z] [IsManifold (𝓡 2) ∞ Z] [SecondCountableTopology Z]
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) [Fact (Module.finrank ℝ d.chart.PositiveCoordinates = 2 + 1)]
+    [Fact (Module.finrank ℝ d.chart.NegativeCoordinates = 2 + 1)]
+    (α : C((Smale.Hemisphere.Sphere 2), d.UpperLevel)) (hαe : Topology.IsEmbedding α)
+    (hdisj : Disjoint (Set.range α) (Set.range d.surgery.beltSphere)) (b : Z → d.UpperLevel)
+    (hbc : IsClosed (Set.range b)) (x : (Smale.Hemisphere.Sphere 2))
+    (v : Metric.sphere (0 : d.chart.PositiveCoordinates) 1) (hx : α x ∉ Set.range b)
+    (hv : d.surgery.beltSphere v ∉ Set.range b) (γ : Path (α x) (d.surgery.beltSphere v)) :
+    let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ α →
+      (∀ z, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) α z)) →
+        ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ b →
+          ∃ A₀ A₁ :
+            CenteredSheetPassage (Smale.RegularLevel.Model E) α d.surgery.beltSphere x v
+              (Set.range b),
+            ∃ L₀ L₁ : (EuclideanSpace ℝ (Fin 3)) ≃L[ℝ] d.chart.NegativeCoordinates,
+              HasFDerivAt
+                  (fun z : (EuclideanSpace ℝ (Fin 3)) =>
+                    d.beltNormal
+                      (A₀.family
+                        ((radialParameterChart (1 / 2) x z).1,
+                          α (radialParameterChart (1 / 2) x z).2)))
+                  L₀.toContinuousLinearMap 0 ∧
+                HasFDerivAt
+                    (fun z : (EuclideanSpace ℝ (Fin 3)) =>
+                      d.beltNormal
+                        (A₁.family
+                          ((radialParameterChart (1 / 2) x z).1,
+                            α (radialParameterChart (1 / 2) x z).2)))
+                    L₁.toContinuousLinearMap 0 ∧
+                  (L₁.trans L₀.symm).toLinearMap.det < 0 := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  let _ := Smale.RegularLevel.isManifold hf d.upper_regular
+  let _ : CompactSpace d.UpperLevel :=
+    isCompact_iff_compactSpace.mp (isClosed_eq hf.continuous continuous_const).isCompact
+  dsimp only
+  intro hα hαi hb
+  have hleveldim : Module.finrank ℝ (Smale.RegularLevel.Model E) = 5 := by
+    simp [Smale.RegularLevel.Model, hdim]
+  have hn :=
+    d.contMDiffOn_beltNormal hf |>.contMDiffAt
+      (d.isOpen_beltNormalDomain.mem_nhds (d.belt_mem_normalDomain v))
+  obtain ⟨P, B, hchoices⟩ :=
+    exists_centered_passage_normal_factors hα (d.belt_smooth hf 2) hαe
+      d.belt_isClosedEmbedding.isEmbedding hαi (d.belt_derivative_injective hf 2) hdisj hb hbc
+      hleveldim x v hx hv γ d.beltNormal hn (d.surjective_beltNormal_derivative hf v)
+      (d.beltNormal_derivative_comp_belt hf 2 v) (by exact Fact.out)
+  exact opposite_centered_passages_of_normal_factors d.beltNormal (by exact Fact.out) P B hchoices
+
+private theorem MorseCancel.choose_prescribed_normal_passage {E M Y N : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [NormedAddCommGroup N]
+    [NormedSpace ℝ N] {f : (Smale.Hemisphere.Sphere 2) → M} {g : Y → M}
+    {x : (Smale.Hemisphere.Sphere 2)} {y : Y} {O : Set M} (n : M → N)
+    (e : (Smale.Hemisphere.Sphere 2) ≃ₜ Metric.sphere (0 : N) 1)
+    (A₀ A₁ : CenteredSheetPassage E f g x y O) (L₀ L₁ : (EuclideanSpace ℝ (Fin 3)) ≃L[ℝ] N)
+    (hL₀ :
+      HasFDerivAt
+        (fun z : (EuclideanSpace ℝ (Fin 3)) =>
+          n
+            (A₀.family
+              ((radialParameterChart (1 / 2) x z).1, f (radialParameterChart (1 / 2) x z).2)))
+        L₀.toContinuousLinearMap 0)
+    (hL₁ :
+      HasFDerivAt
+        (fun z : (EuclideanSpace ℝ (Fin 3)) =>
+          n
+            (A₁.family
+              ((radialParameterChart (1 / 2) x z).1, f (radialParameterChart (1 / 2) x z).2)))
+        L₁.toContinuousLinearMap 0)
+    (hdet : (L₁.trans L₀.symm).toLinearMap.det < 0) (k : ℤ) (hk : k = 1 ∨ k = -1) :
+    ∃ (A : CenteredSheetPassage E f g x y O) (L : (EuclideanSpace ℝ (Fin 3)) ≃L[ℝ] N),
+      HasFDerivAt
+          (fun z : (EuclideanSpace ℝ (Fin 3)) =>
+            n
+              (A.family
+                ((radialParameterChart (1 / 2) x z).1, f (radialParameterChart (1 / 2) x z).2)))
+          L.toContinuousLinearMap 0 ∧
+        SingularMayerVietoris.singularHomologyMap
+            (Smale.LinearSphereAction.sphereMap L.toContinuousLinearMap L.injective) 2 =
+          k •
+            SingularMayerVietoris.singularHomologyMap
+              (e : C((Smale.Hemisphere.Sphere 2), Metric.sphere (0 : N) 1)) 2 := by
+  have hbij :
+    Function.Bijective
+      (SingularMayerVietoris.singularHomologyMap
+        (Smale.LinearSphereAction.sphereMap L₀.toContinuousLinearMap L₀.injective) 2) := by
+    have heq :
+      (Smale.LinearSphereAction.homologyEquiv L₀ 2 :
+          SingularMayerVietoris.SingularHomology (Smale.Hemisphere.Sphere 2) 2 →
+            SingularMayerVietoris.SingularHomology (Metric.sphere (0 : N) 1) 2) =
+        SingularMayerVietoris.singularHomologyMap
+          (Smale.LinearSphereAction.sphereMap L₀.toContinuousLinearMap L₀.injective) 2 :=
+      funext (Smale.LinearSphereAction.homologyEquiv_apply L₀ 2)
+    rw [← heq]
+    exact (Smale.LinearSphereAction.homologyEquiv L₀ 2).bijective
+  obtain ⟨u, hu, hunit⟩ :=
+    two_sphere_map_unit_of_homology_bijective e
+      (Smale.LinearSphereAction.sphereMap L₀.toContinuousLinearMap L₀.injective) hbij
+  have hopp :
+    SingularMayerVietoris.singularHomologyMap
+        (Smale.LinearSphereAction.sphereMap L₁.toContinuousLinearMap L₁.injective) 2 =
+      -SingularMayerVietoris.singularHomologyMap
+          (Smale.LinearSphereAction.sphereMap L₀.toContinuousLinearMap L₀.injective) 2 := by
+    simpa using
+      attaching_contributions_opposite_of_relative_det_neg
+        (ContinuousMap.id (Metric.sphere (0 : N) 1)) L₀ L₁ hdet
+  by_cases huk : u = k
+  · exact ⟨A₀, L₀, hL₀, huk ▸ hunit⟩
+  · have hneg : -u = k := by
+      rcases hu with rfl | rfl <;> rcases hk with rfl | rfl <;> norm_num at *
+    refine ⟨A₁, L₁, hL₁, ?_⟩
+    rw [hopp, hunit, ← neg_zsmul, hneg]
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Recognition/Smale1.lean b/LeanPool/HopfProblem/Recognition/Smale1.lean
new file mode 100644
index 000000000..e90d29a93
--- /dev/null
+++ b/LeanPool/HopfProblem/Recognition/Smale1.lean
@@ -0,0 +1,5669 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Foundations.TriangleRegularBaseFundamentalGroup
+import all LeanPool.HopfProblem.Foundations.LineBundleTransport
+import all LeanPool.HopfProblem.Foundations.TriangleRegularBaseFundamentalGroup
+import all Mathlib.Analysis.Calculus.Implicit
+import all Mathlib.Geometry.Manifold.LocalDiffeomorph
+
+/-!
+# Hopf problem: recognition · smale 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private abbrev Smale.MorseHandle.UnitDisk (V : Type*) [NormedAddCommGroup V] :=
+  Metric.closedBall (0 : V) 1
+
+private def Smale.MorseHandle.modelMap {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (ρ : ℝ) (z : UnitDisk N × UnitDisk P) : N × P :=
+  ((ρ * Real.sqrt (1 + ‖(z.2 : P)‖ ^ 2)) • (z.1 : N), ρ • (z.2 : P))
+
+private theorem Smale.MorseHandle.continuous_modelMap {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] (ρ : ℝ) :
+    Continuous (modelMap (N := N) (P := P) ρ) := by
+  have hu : Continuous (fun z : UnitDisk N × UnitDisk P => (z.1 : N)) :=
+    continuous_subtype_val.comp continuous_fst
+  have hv : Continuous (fun z : UnitDisk N × UnitDisk P => (z.2 : P)) :=
+    continuous_subtype_val.comp continuous_snd
+  exact
+    ((continuous_const.mul
+              (Real.continuous_sqrt.comp (continuous_const.add (hv.norm.pow 2)))).smul
+          hu).prodMk
+      (continuous_const.smul hv)
+
+private theorem Smale.MorseHandle.negative_scale_pos {N P : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] {ρ : ℝ} (hρ : 0 < ρ) (z : UnitDisk N × UnitDisk P) :
+    0 < ρ * Real.sqrt (1 + ‖(z.2 : P)‖ ^ 2) :=
+  mul_pos hρ (Real.sqrt_pos.mpr (by positivity))
+
+private theorem Smale.MorseHandle.modelMap_injective {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ : ℝ} (hρ : 0 < ρ) :
+    Function.Injective (modelMap (N := N) (P := P) ρ) := by
+  rintro ⟨u, v⟩ ⟨u', v'⟩ h
+  have hv : (v : P) = (v' : P) := by
+    have hh := congrArg (fun z : N × P => ρ⁻¹ • z.2) h
+    simpa only [modelMap, smul_smul, inv_mul_cancel₀ hρ.ne', one_smul] using hh
+  have hv' : v = v' := Subtype.ext hv
+  subst v'
+  have hu : (u : N) = (u' : N) := by
+    have hh := congrArg (fun z : N × P => (ρ * Real.sqrt (1 + ‖(v : P)‖ ^ 2))⁻¹ • z.1) h
+    simpa only [modelMap, smul_smul, inv_mul_cancel₀ (negative_scale_pos hρ (u, v)).ne',
+      one_smul] using hh
+  exact Prod.ext (Subtype.ext hu) rfl
+
+private theorem Smale.MorseHandle.modelMap_mem_product {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ : ℝ} (hρ : 0 < ρ)
+    (z : UnitDisk N × UnitDisk P) :
+    modelMap ρ z ∈ Metric.closedBall (0 : N) (2 * ρ) ×ˢ Metric.closedBall (0 : P) (2 * ρ) := by
+  have hu : ‖(z.1 : N)‖ ≤ 1 := mem_closedBall_zero_iff.mp z.1.2
+  have hv : ‖(z.2 : P)‖ ≤ 1 := mem_closedBall_zero_iff.mp z.2.2
+  have hv₂ : ‖(z.2 : P)‖ ^ 2 ≤ 1 := by nlinarith [norm_nonneg (z.2 : P)]
+  have hs : Real.sqrt (1 + ‖(z.2 : P)‖ ^ 2) ≤ 2 :=
+    (Real.sqrt_le_iff).mpr ⟨by norm_num, by linarith⟩
+  constructor
+  · rw [mem_closedBall_zero_iff]
+    change ‖(ρ * Real.sqrt (1 + ‖(z.2 : P)‖ ^ 2)) • (z.1 : N)‖ ≤ 2 * ρ
+    rw [norm_smul, Real.norm_eq_abs, abs_of_pos (negative_scale_pos hρ z)]
+    calc
+      _ ≤ ρ * Real.sqrt (1 + ‖(z.2 : P)‖ ^ 2) :=
+        mul_le_of_le_one_right (negative_scale_pos hρ z).le hu
+      _ ≤ ρ * 2 := (mul_le_mul_of_nonneg_left hs hρ.le)
+      _ = _ := mul_comm _ _
+  · rw [mem_closedBall_zero_iff]
+    change ‖ρ • (z.2 : P)‖ ≤ 2 * ρ
+    rw [norm_smul, Real.norm_eq_abs, abs_of_pos hρ]
+    have hh := mul_le_mul_of_nonneg_left hv hρ.le
+    linarith
+
+private theorem
+    Smale.MorseHandle.modelMap_height {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ : ℝ} (hρ : 0 < ρ) (z : UnitDisk N × UnitDisk P) :
+    -‖(modelMap ρ z).1‖ ^ 2 + ‖(modelMap ρ z).2‖ ^ 2 =
+      ρ ^ 2 * ((1 + ‖(z.2 : P)‖ ^ 2) * (1 - ‖(z.1 : N)‖ ^ 2) - 1) := by
+  simp only [modelMap, norm_smul, Real.norm_eq_abs, abs_of_pos (negative_scale_pos hρ z),
+    abs_of_pos hρ, mul_pow, Real.sq_sqrt (show 0 ≤ 1 + ‖(z.2 : P)‖ ^ 2 by positivity)]
+  ring
+
+private theorem Smale.MorseHandle.modelMap_lower_iff {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ : ℝ} (hρ : 0 < ρ)
+    (z : UnitDisk N × UnitDisk P) :
+    -‖(modelMap ρ z).1‖ ^ 2 + ‖(modelMap ρ z).2‖ ^ 2 ≤ -(ρ ^ 2) ↔ ‖(z.1 : N)‖ = 1 := by
+  rw [modelMap_height hρ z]
+  have hu : ‖(z.1 : N)‖ ≤ 1 := mem_closedBall_zero_iff.mp z.1.2
+  have hu₀ := norm_nonneg (z.1 : N)
+  have hpos : 0 < ρ ^ 2 * (1 + ‖(z.2 : P)‖ ^ 2) := mul_pos (sq_pos_of_pos hρ) (by positivity)
+  constructor
+  · intro h
+    have hp : (ρ ^ 2 * (1 + ‖(z.2 : P)‖ ^ 2)) * (1 - ‖(z.1 : N)‖ ^ 2) ≤ 0 := by
+      calc
+        _ = ρ ^ 2 * ((1 + ‖(z.2 : P)‖ ^ 2) * (1 - ‖(z.1 : N)‖ ^ 2) - 1) + ρ ^ 2 := by ring
+        _ ≤ 0 := by linarith
+    have hm : 1 - ‖(z.1 : N)‖ ^ 2 ≤ 0 :=
+      (mul_le_mul_iff_right₀ hpos).mp (by simpa only [MulZeroClass.mul_zero] using hp)
+    nlinarith
+  · intro h
+    simp only [h, one_pow, sub_self, MulZeroClass.mul_zero, zero_sub, mul_neg, mul_one, le_refl]
+
+private theorem
+    Smale.MorseHandle.modelMap_upper {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ : ℝ} (hρ : 0 < ρ) (z : UnitDisk N × UnitDisk P) :
+    -‖(modelMap ρ z).1‖ ^ 2 + ‖(modelMap ρ z).2‖ ^ 2 ≤ ρ ^ 2 := by
+  rw [modelMap_height hρ z]
+  have hv : ‖(z.2 : P)‖ ≤ 1 := mem_closedBall_zero_iff.mp z.2.2
+  have hv₂ : ‖(z.2 : P)‖ ^ 2 ≤ 1 := by nlinarith [norm_nonneg (z.2 : P)]
+  have hu₂ : 0 ≤ ‖(z.1 : N)‖ ^ 2 := sq_nonneg _
+  have hfactor : 0 ≤ 1 + ‖(z.2 : P)‖ ^ 2 := by positivity
+  have hsmall : (1 + ‖(z.2 : P)‖ ^ 2) * (1 - ‖(z.1 : N)‖ ^ 2) - 1 ≤ 1 := by
+    nlinarith [mul_nonneg hfactor hu₂]
+  simpa only [mul_one] using mul_le_mul_of_nonneg_left hsmall (sq_nonneg ρ)
+
+private def Smale.MorseHandle.beltFaceScale (r : ℝ) : ℝ :=
+  Real.sqrt (1 + r ^ 2) / Real.sqrt 2
+
+private theorem Smale.MorseHandle.beltFaceScale_pos (r : ℝ) : 0 < beltFaceScale r :=
+  div_pos (Real.sqrt_pos.mpr (by positivity)) (Real.sqrt_pos.mpr (by norm_num))
+
+private theorem Smale.MorseHandle.continuous_beltFaceScale : Continuous beltFaceScale :=
+  (Real.continuous_sqrt.comp (continuous_const.add (continuous_id.pow 2))).div_const _
+
+private theorem Smale.MorseHandle.beltFaceScale_one : beltFaceScale 1 = 1 := by
+  simp only [beltFaceScale, one_pow, one_add_one_eq_two]
+  exact div_self (Real.sqrt_pos.mpr (by norm_num)).ne'
+
+private theorem
+    Smale.MorseHandle.beltFaceScale_monotone : MonotoneOn beltFaceScale (Set.Ici 0) := by
+  intro r hr s hs hrs
+  apply div_le_div_of_nonneg_right _ (Real.sqrt_nonneg 2)
+  apply Real.sqrt_le_sqrt
+  have hsq : r ^ 2 ≤ s ^ 2 := (sq_le_sq₀ hr hs).mpr hrs
+  linarith
+
+private theorem Smale.MorseHandle.beltFaceRadius_strictMono :
+    StrictMonoOn (fun r => beltFaceScale r * r) (Set.Ici 0) := by
+  intro r hr s hs hrs
+  exact
+    (mul_lt_mul_of_pos_left hrs (beltFaceScale_pos r)).trans_le
+      (mul_le_mul_of_nonneg_right (beltFaceScale_monotone hr hs hrs.le) hs)
+
+private def
+    Smale.MorseHandle.beltFaceMap {N : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N] (u : N) :
+    N :=
+  beltFaceScale ‖u‖ • u
+
+private theorem Smale.MorseHandle.continuous_beltFaceMap {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] : Continuous (beltFaceMap (N := N)) :=
+  (continuous_beltFaceScale.comp continuous_norm).smul continuous_id
+
+private theorem
+    Smale.MorseHandle.norm_beltFaceMap {N : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    (u : N) : ‖beltFaceMap u‖ = beltFaceScale ‖u‖ * ‖u‖ := by
+  rw [beltFaceMap, norm_smul, Real.norm_eq_abs, abs_of_pos (beltFaceScale_pos _)]
+
+private theorem
+    Smale.MorseHandle.beltFaceMap_zero {N : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N] :
+    beltFaceMap (0 : N) = 0 := by simp only [beltFaceMap, smul_zero]
+
+private theorem Smale.MorseHandle.norm_beltFaceMap_lt_one_iff {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] (u : N) : ‖beltFaceMap u‖ < 1 ↔ ‖u‖ < 1 := by
+  have hh := beltFaceRadius_strictMono.lt_iff_lt (norm_nonneg u) (show 0 ≤ (1 : ℝ) by norm_num)
+  simpa only [beltFaceScale_one, mul_one, norm_beltFaceMap] using hh
+
+private theorem Smale.MorseHandle.beltFaceMap_mem_disk {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] {u : N} (hu : ‖u‖ ≤ 1) : ‖beltFaceMap u‖ ≤ 1 := by
+  rw [norm_beltFaceMap]
+  have hs : beltFaceScale ‖u‖ ≤ 1 := by
+    rw [← beltFaceScale_one]
+    exact beltFaceScale_monotone (norm_nonneg u) (by norm_num) hu
+  exact (mul_le_mul_of_nonneg_right hs (norm_nonneg u)).trans (by simpa only [one_mul])
+
+private theorem Smale.MorseHandle.beltFaceMap_injective {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] : Function.Injective (beltFaceMap (N := N)) := by
+  intro u v huv
+  have hn : ‖u‖ = ‖v‖ := by
+    apply beltFaceRadius_strictMono.injOn (norm_nonneg u) (norm_nonneg v)
+    simpa only [norm_beltFaceMap] using congrArg Norm.norm huv
+  change beltFaceScale ‖u‖ • u = beltFaceScale ‖v‖ • v at huv
+  rw [hn] at huv
+  exact (smul_right_injective N (beltFaceScale_pos ‖v‖).ne') huv
+
+private theorem Smale.MorseHandle.beltFaceMap_surjOn_disk {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] :
+    Set.SurjOn (beltFaceMap (N := N)) (Metric.closedBall 0 1) (Metric.closedBall 0 1) := by
+  intro v hv
+  by_cases hvzero : v = 0
+  · subst v
+    exact ⟨0, mem_closedBall_zero_iff.mpr (by norm_num), beltFaceMap_zero⟩
+  have hvpos : 0 < ‖v‖ := norm_pos_iff.mpr hvzero
+  have hvrange : ‖v‖ ∈ Set.Icc (beltFaceScale 0 * 0) (beltFaceScale 1 * 1) := by
+    simpa only [MulZeroClass.mul_zero, beltFaceScale_one, mul_one, Set.mem_Icc] using
+      And.intro hvpos.le (mem_closedBall_zero_iff.mp hv)
+  obtain ⟨r, hr, hrv⟩ :=
+    intermediate_value_Icc (a := (0 : ℝ)) (b := 1) (by norm_num)
+      (continuous_beltFaceScale.mul continuous_id).continuousOn hvrange
+  change beltFaceScale r * r = ‖v‖ at hrv
+  let u : N := (r / ‖v‖) • v
+  have hnorm : ‖u‖ = r := by
+    change ‖(r / ‖v‖) • v‖ = r
+    rw [norm_smul, Real.norm_eq_abs, abs_of_nonneg (div_nonneg hr.1 hvpos.le),
+      div_mul_cancel₀ _ hvpos.ne']
+  refine ⟨u, mem_closedBall_zero_iff.mpr (hnorm ▸ hr.2), ?_⟩
+  change beltFaceScale ‖u‖ • ((r / ‖v‖) • v) = v
+  rw [hnorm, smul_smul, ← mul_div_assoc, hrv, div_self hvpos.ne', one_smul]
+
+private def Smale.MorseHandle.beltFaceDiskMap {N : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N] :
+    UnitDisk N → UnitDisk N := fun u =>
+  ⟨beltFaceMap u.val,
+    mem_closedBall_zero_iff.mpr (beltFaceMap_mem_disk (mem_closedBall_zero_iff.mp u.property))⟩
+
+private theorem Smale.MorseHandle.continuous_beltFaceDiskMap {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] : Continuous (beltFaceDiskMap (N := N)) :=
+  (continuous_beltFaceMap.comp continuous_subtype_val).subtype_mk _
+
+private theorem Smale.MorseHandle.beltFaceDiskMap_bijective {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] : Function.Bijective (beltFaceDiskMap (N := N)) := by
+  constructor
+  · intro u v huv
+    exact Subtype.ext (beltFaceMap_injective (congrArg Subtype.val huv))
+  · intro v
+    obtain ⟨u, hu, huv⟩ := beltFaceMap_surjOn_disk v.property
+    exact ⟨⟨u, hu⟩, Subtype.ext huv⟩
+
+private def
+    Smale.MorseHandle.beltFaceDiskHomeomorph {N : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [FiniteDimensional ℝ N] : UnitDisk N ≃ₜ UnitDisk N :=
+  Continuous.homeoOfEquivCompactToT2 (f :=
+    Equiv.ofBijective beltFaceDiskMap beltFaceDiskMap_bijective) continuous_beltFaceDiskMap
+
+private def Smale.MorseHandle.ambientMap {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (ρ : ℝ) (z : N × P) : N × P :=
+  ((ρ * Real.sqrt (1 + ‖z.2‖ ^ 2)) • z.1, ρ • z.2)
+
+private def Smale.MorseHandle.ambientInverse {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (ρ : ℝ) (z : N × P) : N × P :=
+  ((ρ * Real.sqrt (1 + ‖ρ⁻¹ • z.2‖ ^ 2))⁻¹ • z.1, ρ⁻¹ • z.2)
+
+private theorem Smale.MorseHandle.ambientInverse_ambientMap {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ : ℝ} (hρ : 0 < ρ) (z : N × P) :
+    ambientInverse ρ (ambientMap ρ z) = z := by
+  have hscale : 0 < ρ * Real.sqrt (1 + ‖z.2‖ ^ 2) :=
+    mul_pos hρ (Real.sqrt_pos.mpr (by positivity))
+  apply Prod.ext
+  · simp only [ambientInverse, ambientMap, smul_smul, inv_mul_cancel₀ hρ.ne', one_smul,
+      inv_mul_cancel₀ hscale.ne']
+  · simp only [ambientInverse, ambientMap, smul_smul, inv_mul_cancel₀ hρ.ne', one_smul]
+
+private theorem Smale.MorseHandle.ambientMap_ambientInverse {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ : ℝ} (hρ : 0 < ρ) (z : N × P) :
+    ambientMap ρ (ambientInverse ρ z) = z := by
+  have hscale : 0 < ρ * Real.sqrt (1 + ‖ρ⁻¹ • z.2‖ ^ 2) :=
+    mul_pos hρ (Real.sqrt_pos.mpr (by positivity))
+  apply Prod.ext
+  · simp only [ambientInverse, ambientMap, smul_smul, mul_inv_cancel₀ hscale.ne', one_smul]
+  · simp only [ambientInverse, ambientMap, smul_smul, mul_inv_cancel₀ hρ.ne', one_smul]
+
+private def
+    Smale.MorseHandle.ambientHomeomorph {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (ρ : ℝ) (hρ : 0 < ρ) : (N × P) ≃ₜ (N × P) := by
+  have hscale (v : P) : 0 < ρ * Real.sqrt (1 + ‖v‖ ^ 2) :=
+    mul_pos hρ (Real.sqrt_pos.mpr (by positivity))
+  refine
+    { toFun := ambientMap ρ
+      invFun := ambientInverse ρ
+      left_inv := ambientInverse_ambientMap hρ
+      right_inv := ambientMap_ambientInverse hρ
+      continuous_toFun := ?_
+      continuous_invFun := ?_ }
+  · exact
+      ((continuous_const.mul
+                (Real.continuous_sqrt.comp
+                  (continuous_const.add (continuous_snd.norm.pow 2)))).smul
+            continuous_fst).prodMk
+        (continuous_const.smul continuous_snd)
+  · have hv : Continuous (fun z : N × P => ρ⁻¹ • z.2) := continuous_const.smul continuous_snd
+    have hc : Continuous (fun z : N × P => ρ * Real.sqrt (1 + ‖ρ⁻¹ • z.2‖ ^ 2)) :=
+      continuous_const.mul (Real.continuous_sqrt.comp (continuous_const.add (hv.norm.pow 2)))
+    exact ((hc.inv₀ (fun z => (hscale (ρ⁻¹ • z.2)).ne')).smul continuous_fst).prodMk hv
+
+@[simp]
+private theorem Smale.MorseHandle.ambientHomeomorph_zero {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] (ρ : ℝ) (hρ : 0 < ρ) :
+    ambientHomeomorph (N := N) (P := P) ρ hρ 0 = 0 := by
+  change ambientMap ρ (0 : N × P) = 0
+  simp only [ambientMap, Prod.fst_zero, Prod.snd_zero, smul_zero, Prod.mk_zero_zero]
+
+private theorem Smale.MorseHandle.range_modelMap_mem_nhds_zero {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ : ℝ} (hρ : 0 < ρ) :
+    Set.range (modelMap (N := N) (P := P) ρ) ∈ 𝓝 (0 : N × P) := by
+  let e := ambientHomeomorph (N := N) (P := P) ρ hρ
+  let O := Metric.ball (0 : N) 1 ×ˢ Metric.ball (0 : P) 1
+  have hO : IsOpen (e '' O) := e.isOpenMap O (Metric.isOpen_ball.prod Metric.isOpen_ball)
+  have hzero : (0 : N × P) ∈ e '' O := by
+    refine ⟨0, ?_, ambientHomeomorph_zero ρ hρ⟩
+    exact ⟨by simp, by simp⟩
+  have hsub : e '' O ⊆ Set.range (modelMap (N := N) (P := P) ρ) := by
+    rintro _ ⟨z, hz, rfl⟩
+    exact
+      ⟨(⟨z.1, Metric.ball_subset_closedBall hz.1⟩, ⟨z.2, Metric.ball_subset_closedBall hz.2⟩),
+        rfl⟩
+  exact Filter.mem_of_superset (hO.mem_nhds hzero) hsub
+
+private theorem
+    Smale.MorseHandle.inverse_scale_sq {P : Type*} [NormedAddCommGroup P] [NormedSpace ℝ P]
+    {ρ : ℝ} (hρ : 0 < ρ) (v : P) : (ρ * Real.sqrt (1 + ‖ρ⁻¹ • v‖ ^ 2)) ^ 2 = ρ ^ 2 + ‖v‖ ^ 2 := by
+  rw [mul_pow, Real.sq_sqrt (by positivity), norm_smul, Real.norm_eq_abs,
+    abs_of_pos (inv_pos.mpr hρ)]
+  field_simp
+
+private theorem Smale.MorseHandle.mem_range_modelMap_iff {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ : ℝ} (hρ : 0 < ρ) (z : N × P) :
+    z ∈ Set.range (modelMap ρ) ↔ ‖z.2‖ ≤ ρ ∧ -(ρ ^ 2) ≤ -‖z.1‖ ^ 2 + ‖z.2‖ ^ 2 := by
+  let A := ρ * Real.sqrt (1 + ‖ρ⁻¹ • z.2‖ ^ 2)
+  have hA : 0 < A := mul_pos hρ (Real.sqrt_pos.mpr (by positivity))
+  have hA₂ : A ^ 2 = ρ ^ 2 + ‖z.2‖ ^ 2 := inverse_scale_sq hρ z.2
+  have hneg : ‖A⁻¹ • z.1‖ ≤ 1 ↔ -(ρ ^ 2) ≤ -‖z.1‖ ^ 2 + ‖z.2‖ ^ 2 := by
+    rw [norm_smul, Real.norm_eq_abs, abs_of_pos (inv_pos.mpr hA), inv_mul_le_one₀ hA, ←
+      sq_le_sq₀ (norm_nonneg z.1) hA.le, hA₂]
+    constructor <;> intro h <;> linarith
+  have hpos : ‖ρ⁻¹ • z.2‖ ≤ 1 ↔ ‖z.2‖ ≤ ρ := by
+    rw [norm_smul, Real.norm_eq_abs, abs_of_pos (inv_pos.mpr hρ), inv_mul_le_one₀ hρ]
+  constructor
+  · rintro ⟨w, hw⟩
+    have hi : ambientInverse ρ z = ((w.1 : N), (w.2 : P)) := by
+      rw [← hw]
+      exact ambientInverse_ambientMap hρ ((w.1 : N), (w.2 : P))
+    have h₁ : A⁻¹ • z.1 = (w.1 : N) := congrArg Prod.fst hi
+    have h₂ : ρ⁻¹ • z.2 = (w.2 : P) := congrArg Prod.snd hi
+    exact
+      ⟨hpos.mp (by rw [h₂]; exact mem_closedBall_zero_iff.mp w.2.2),
+        hneg.mp (by rw [h₁]; exact mem_closedBall_zero_iff.mp w.1.2)⟩
+  · intro hz
+    refine
+      ⟨(⟨A⁻¹ • z.1, mem_closedBall_zero_iff.mpr (hneg.mpr hz.2)⟩,
+          ⟨ρ⁻¹ • z.2, mem_closedBall_zero_iff.mpr (hpos.mpr hz.1)⟩),
+        ?_⟩
+    exact ambientMap_ambientInverse hρ z
+
+private def Smale.MorseHandle.quadratic {N P : Type*} [NormedAddCommGroup N] [NormedAddCommGroup P]
+    (z : N × P) : ℝ :=
+  -‖z.1‖ ^ 2 + ‖z.2‖ ^ 2
+
+private def Smale.MorseHandle.descent {N P : Type*} [NormedAddCommGroup P] (z : N × P) : N × P :=
+  (z.1, -z.2)
+
+private theorem Smale.MorseHandle.contDiff_descent {N P : Type*} [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] [NormedAddCommGroup P] [InnerProductSpace ℝ P] :
+    ContDiff ℝ ∞ (descent (N := N) (P := P)) :=
+  contDiff_fst.prodMk contDiff_snd.neg
+
+private theorem Smale.MorseHandle.fderiv_quadratic_descent {N P : Type*} [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] [NormedAddCommGroup P] [InnerProductSpace ℝ P] (z : N × P) :
+    fderiv ℝ quadratic z (descent z) = -2 * (‖z.1‖ ^ 2 + ‖z.2‖ ^ 2) := by
+  have hd :=
+    (hasFDerivAt_fst (𝕜 := ℝ) (p := z)).norm_sq.neg.add
+      (hasFDerivAt_snd (𝕜 := ℝ) (p := z)).norm_sq
+  have hd' := hd.fderiv
+  change fderiv ℝ quadratic z = _ at hd'
+  rw [hd']
+  simp only [descent, add_apply, neg_apply, ContinuousLinearMap.comp_apply,
+    ContinuousLinearMap.coe_fst', ContinuousLinearMap.coe_snd', innerSL_apply_apply,
+    inner_neg_right, real_inner_self_eq_norm_sq, two_smul]
+  ring
+
+private theorem Smale.MorseHandle.fderiv_quadratic_descent_neg {N P : Type*} [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] [NormedAddCommGroup P] [InnerProductSpace ℝ P] {z : N × P}
+    (hz : z ≠ 0) : fderiv ℝ quadratic z (descent z) < 0 := by
+  rw [fderiv_quadratic_descent]
+  have hsum : 0 < ‖z.1‖ ^ 2 + ‖z.2‖ ^ 2 := by
+    by_contra! h
+    have hu : ‖z.1‖ = 0 := by nlinarith [sq_nonneg ‖z.1‖, sq_nonneg ‖z.2‖]
+    have hv : ‖z.2‖ = 0 := by nlinarith [sq_nonneg ‖z.1‖, sq_nonneg ‖z.2‖]
+    exact hz (Prod.ext (norm_eq_zero.mp hu) (norm_eq_zero.mp hv))
+  nlinarith
+
+private def Smale.MorseHandle.descentFlow {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] : Flow ℝ (N × P)
+    where
+  toFun t z := (Real.exp t • z.1, Real.exp (-t) • z.2)
+  cont' :=
+    ((Real.continuous_exp.comp continuous_fst).smul continuous_snd.fst).prodMk
+      ((Real.continuous_exp.comp continuous_fst.neg).smul continuous_snd.snd)
+  map_add' s t z := by simp only [Real.exp_add, neg_add, smul_smul]
+  map_zero' z := by simp
+
+private theorem Smale.MorseHandle.hasDerivAt_descentFlow {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] (z : N × P) (t : ℝ) :
+    HasDerivAt (fun s => descentFlow s z) (descent (descentFlow t z)) t := by
+  have h₁ := (Real.hasDerivAt_exp t).smul_const z.1
+  have h₂ := ((hasDerivAt_id t).neg.exp).smul_const z.2
+  simpa only [descentFlow, descent, id_eq, Pi.neg_apply, mul_neg, mul_one, neg_smul] using
+    h₁.prodMk h₂
+
+private theorem Smale.MorseHandle.norm_descentFlow_fst {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] (t : ℝ) (z : N × P) :
+    ‖(descentFlow t z).1‖ = Real.exp t * ‖z.1‖ := by
+  change ‖Real.exp t • z.1‖ = _
+  rw [norm_smul, Real.norm_eq_abs, abs_of_pos (Real.exp_pos t)]
+
+private theorem Smale.MorseHandle.norm_descentFlow_snd {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] (t : ℝ) (z : N × P) :
+    ‖(descentFlow t z).2‖ = Real.exp (-t) * ‖z.2‖ := by
+  change ‖Real.exp (-t) • z.2‖ = _
+  rw [norm_smul, Real.norm_eq_abs, abs_of_pos (Real.exp_pos (-t))]
+
+private theorem Smale.MorseHandle.norm_fst_le_descentFlow {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {t : ℝ} (ht : 0 ≤ t) (z : N × P) :
+    ‖z.1‖ ≤ ‖(descentFlow t z).1‖ := by
+  rw [norm_descentFlow_fst]
+  exact le_mul_of_one_le_left (norm_nonneg _) (Real.one_le_exp_iff.mpr ht)
+
+private theorem Smale.MorseHandle.norm_snd_descentFlow_le {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {t : ℝ} (ht : 0 ≤ t) (z : N × P) :
+    ‖(descentFlow t z).2‖ ≤ ‖z.2‖ := by
+  rw [norm_descentFlow_snd]
+  exact mul_le_of_le_one_left (norm_nonneg _) (Real.exp_le_one_iff.mpr (neg_nonpos.mpr ht))
+
+private theorem Smale.MorseHandle.mem_lower_union_handle_iff {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ : ℝ} (hρ : 0 < ρ) (z : N × P) :
+    z ∈ {w | quadratic w ≤ -(ρ ^ 2)} ∪ Set.range (modelMap ρ) ↔
+      quadratic z ≤ -(ρ ^ 2) ∨ ‖z.2‖ ≤ ρ := by
+  rw [Set.mem_union, Set.mem_ofPred_eq, mem_range_modelMap_iff hρ]
+  change quadratic z ≤ -(ρ ^ 2) ∨ (‖z.2‖ ≤ ρ ∧ -(ρ ^ 2) ≤ quadratic z) ↔ _
+  constructor
+  · rintro (h | h)
+    · exact Or.inl h
+    · exact Or.inr h.1
+  · rintro (h | h)
+    · exact Or.inl h
+    · by_cases hq : quadratic z ≤ -(ρ ^ 2)
+      · exact Or.inl hq
+      · exact Or.inr ⟨h, le_of_not_ge hq⟩
+
+private def Smale.MorseHandle.beltFaceTime (r : ℝ) : ℝ :=
+  Real.log (Real.sqrt (1 + r ^ 2))
+
+private theorem Smale.MorseHandle.beltFaceTime_nonneg (r : ℝ) : 0 ≤ beltFaceTime r :=
+  Real.log_nonneg (Real.one_le_sqrt.mpr (by nlinarith [sq_nonneg r]))
+
+private theorem Smale.MorseHandle.exp_beltFaceTime (r : ℝ) :
+    Real.exp (beltFaceTime r) = Real.sqrt (1 + r ^ 2) :=
+  Real.exp_log (Real.sqrt_pos.mpr (by positivity))
+
+private def Smale.MorseHandle.beltLevelModel {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (ρ : ℝ) (u : N) (v : P) : N × P :=
+  (ρ • u, (ρ * Real.sqrt (1 + ‖u‖ ^ 2)) • v)
+
+private theorem Smale.MorseHandle.beltLevelModel_height {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ : ℝ} (hρ : 0 < ρ) (u : N)
+    {v : P} (hv : ‖v‖ = 1) : quadratic (beltLevelModel ρ u v) = ρ ^ 2 := by
+  have hs : 0 < Real.sqrt (1 + ‖u‖ ^ 2) := Real.sqrt_pos.mpr (by positivity)
+  simp only [quadratic, beltLevelModel, norm_smul, Real.norm_eq_abs, abs_of_pos hρ,
+    abs_of_pos (mul_pos hρ hs), hv, mul_one, mul_pow,
+    Real.sq_sqrt (show 0 ≤ 1 + ‖u‖ ^ 2 by positivity)]
+  ring
+
+private theorem Smale.MorseHandle.descentFlow_beltFaceTime {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] (ρ : ℝ) (u : UnitDisk N)
+    (v : UnitDisk P) (hv : ‖v.val‖ = 1) :
+    descentFlow (beltFaceTime ‖u.val‖) (beltLevelModel ρ u.val v.val) =
+      modelMap ρ (beltFaceDiskMap u, v) := by
+  have hs : Real.sqrt 2 ≠ 0 := (Real.sqrt_pos.mpr (by norm_num)).ne'
+  have hu : Real.sqrt (1 + ‖u.val‖ ^ 2) ≠ 0 := (Real.sqrt_pos.mpr (by positivity)).ne'
+  apply Prod.ext
+  · change
+      Real.exp (beltFaceTime ‖u.val‖) • (ρ • u.val) =
+        (ρ * Real.sqrt (1 + ‖v.val‖ ^ 2)) • (beltFaceScale ‖u.val‖ • u.val)
+    rw [exp_beltFaceTime, hv, one_pow, one_add_one_eq_two, smul_smul, smul_smul]
+    congr 1
+    unfold beltFaceScale
+    field_simp
+  · change
+      Real.exp (-beltFaceTime ‖u.val‖) • ((ρ * Real.sqrt (1 + ‖u.val‖ ^ 2)) • v.val) = ρ • v.val
+    rw [Real.exp_neg, exp_beltFaceTime, smul_smul]
+    congr 1
+    field_simp
+
+private theorem Smale.MorseHandle.descentFlow_beltLevelModel_mem_block {N P : Type*}
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ : ℝ}
+    (hρ : 0 < ρ) (u : UnitDisk N) {v : P} (hv : ‖v‖ = 1) {t : ℝ}
+    (ht : t ∈ Set.Icc 0 (beltFaceTime ‖u.val‖)) :
+    descentFlow t (beltLevelModel ρ u.val v) ∈
+      Metric.closedBall (0 : N) (2 * ρ) ×ˢ Metric.closedBall (0 : P) (2 * ρ) := by
+  have hu : ‖u.val‖ ≤ 1 := mem_closedBall_zero_iff.mp u.property
+  have hspos : 0 < Real.sqrt (1 + ‖u.val‖ ^ 2) := Real.sqrt_pos.mpr (by positivity)
+  have hs : Real.sqrt (1 + ‖u.val‖ ^ 2) ≤ 2 :=
+    Real.sqrt_le_iff.mpr ⟨by norm_num, by nlinarith [norm_nonneg u.val]⟩
+  have he : Real.exp t ≤ Real.sqrt (1 + ‖u.val‖ ^ 2) := by
+    rw [← exp_beltFaceTime]
+    exact Real.exp_le_exp.mpr ht.2
+  have hen : Real.exp (-t) ≤ 1 := Real.exp_le_one_iff.mpr (neg_nonpos.mpr ht.1)
+  constructor
+  · rw [mem_closedBall_zero_iff, norm_descentFlow_fst]
+    change Real.exp t * ‖ρ • u.val‖ ≤ 2 * ρ
+    rw [norm_smul, Real.norm_eq_abs, abs_of_pos hρ]
+    calc
+      _ ≤ Real.exp t * ρ :=
+        mul_le_mul_of_nonneg_left (mul_le_of_le_one_right hρ.le hu) (Real.exp_pos t).le
+      _ ≤ 2 * ρ := mul_le_mul_of_nonneg_right (he.trans hs) hρ.le
+  · rw [mem_closedBall_zero_iff, norm_descentFlow_snd]
+    change Real.exp (-t) * ‖(ρ * Real.sqrt (1 + ‖u.val‖ ^ 2)) • v‖ ≤ 2 * ρ
+    rw [norm_smul, Real.norm_eq_abs, abs_of_pos (mul_pos hρ hspos), hv, mul_one]
+    calc
+      _ ≤ ρ * Real.sqrt (1 + ‖u.val‖ ^ 2) := mul_le_of_le_one_left (mul_pos hρ hspos).le hen
+      _ ≤ ρ * 2 := (mul_le_mul_of_nonneg_left hs hρ.le)
+      _ = 2 * ρ := mul_comm _ _
+
+private theorem Smale.MorseHandle.descentFlow_neg_beltFaceTime {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] (ρ : ℝ) (u : UnitDisk N)
+    (v : UnitDisk P) (hv : ‖v.val‖ = 1) :
+    descentFlow (-beltFaceTime ‖u.val‖) (modelMap ρ (beltFaceDiskMap u, v)) =
+      beltLevelModel ρ u.val v.val := by
+  rw [← descentFlow_beltFaceTime ρ u v hv, ← descentFlow.map_add, neg_add_cancel,
+    descentFlow.map_zero_apply]
+
+private theorem
+    Smale.MorseHandle.descentFlow_positiveFace_mem_block {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ : ℝ} (hρ : 0 < ρ)
+    (u : UnitDisk N) (v : UnitDisk P) (hv : ‖v.val‖ = 1) {t : ℝ}
+    (ht : t ∈ Set.uIcc 0 (-beltFaceTime ‖u.val‖)) :
+    descentFlow t (modelMap ρ (beltFaceDiskMap u, v)) ∈
+      Metric.closedBall (0 : N) (2 * ρ) ×ˢ Metric.closedBall (0 : P) (2 * ρ) := by
+  rw [Set.uIcc_of_ge (neg_nonpos.mpr (beltFaceTime_nonneg ‖u.val‖))] at ht
+  rw [← descentFlow_beltFaceTime ρ u v hv, ← descentFlow.map_add]
+  apply descentFlow_beltLevelModel_mem_block hρ u hv
+  constructor <;> linarith [ht.1, ht.2]
+
+private def Degree.BeltPassage.time (s : ℝ) : ℝ :=
+  Real.log (Real.sqrt (1 + s ^ 2) / s)
+
+private theorem Degree.BeltPassage.time_nonneg {s : ℝ} (hs : 0 < s) : 0 ≤ time s := by
+  have hroot := Real.sqrt_nonneg (1 + s ^ 2)
+  have hsquare := Real.sq_sqrt (show 0 ≤ 1 + s ^ 2 by positivity)
+  apply Real.log_nonneg
+  apply (le_div_iff₀ hs).mpr
+  nlinarith
+
+private theorem Degree.BeltPassage.exp_time {s : ℝ} (hs : 0 < s) :
+    Real.exp (time s) = Real.sqrt (1 + s ^ 2) / s :=
+  Real.exp_log (div_pos (Real.sqrt_pos.mpr (by positivity)) hs)
+
+private def Degree.BeltPassage.upper {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (ρ s : ℝ) (u : N) (v : P) : N × P :=
+  ((ρ * s) • u, (ρ * Real.sqrt (1 + s ^ 2)) • v)
+
+private def Degree.BeltPassage.lower {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (ρ s : ℝ) (u : N) (v : P) : N × P :=
+  ((ρ * Real.sqrt (1 + s ^ 2)) • u, (ρ * s) • v)
+
+private theorem
+    Degree.BeltPassage.descentFlow_time {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (ρ : ℝ) {s : ℝ} (hs : 0 < s) (u : N) (v : P) :
+    Smale.MorseHandle.descentFlow (time s) (Degree.BeltPassage.upper ρ s u v) =
+      Degree.BeltPassage.lower ρ s u v := by
+  have hr : Real.sqrt (1 + s ^ 2) ≠ 0 := (Real.sqrt_pos.mpr (by positivity)).ne'
+  apply Prod.ext
+  · change Real.exp (time s) • ((ρ * s) • u) = (ρ * Real.sqrt (1 + s ^ 2)) • u
+    rw [exp_time hs, smul_smul]
+    congr 1
+    field_simp
+  · change Real.exp (-time s) • ((ρ * Real.sqrt (1 + s ^ 2)) • v) = (ρ * s) • v
+    rw [Real.exp_neg, exp_time hs, smul_smul]
+    congr 1
+    field_simp
+
+private theorem Degree.BeltPassage.descentFlow_mem_block {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ s : ℝ} (hρ : 0 < ρ) (hs : 0 < s)
+    (hs₁ : s ≤ 1) {u : N} (hu : ‖u‖ = 1) {v : P} (hv : ‖v‖ = 1) {t : ℝ}
+    (ht : t ∈ Set.Icc 0 (time s)) :
+    Smale.MorseHandle.descentFlow t (Degree.BeltPassage.upper ρ s u v) ∈
+      Metric.closedBall (0 : N) (2 * ρ) ×ˢ Metric.closedBall (0 : P) (2 * ρ) := by
+  have hrpos : 0 < Real.sqrt (1 + s ^ 2) := Real.sqrt_pos.mpr (by positivity)
+  have hr : Real.sqrt (1 + s ^ 2) ≤ 2 := Real.sqrt_le_iff.mpr ⟨by norm_num, by nlinarith⟩
+  have hpos : 0 ≤ ρ * s := (mul_pos hρ hs).le
+  constructor
+  · rw [mem_closedBall_zero_iff, Smale.MorseHandle.norm_descentFlow_fst]
+    change Real.exp t * ‖(ρ * s) • u‖ ≤ 2 * ρ
+    rw [norm_smul, Real.norm_eq_abs, abs_of_nonneg hpos, hu, mul_one]
+    calc
+      _ ≤ Real.exp (time s) * (ρ * s) :=
+        mul_le_mul_of_nonneg_right (Real.exp_le_exp.mpr ht.2) hpos
+      _ = ρ * Real.sqrt (1 + s ^ 2) := by rw [exp_time hs]; field_simp
+      _ ≤ ρ * 2 := (mul_le_mul_of_nonneg_left hr hρ.le)
+      _ = 2 * ρ := mul_comm _ _
+  · rw [mem_closedBall_zero_iff, Smale.MorseHandle.norm_descentFlow_snd]
+    change Real.exp (-t) * ‖(ρ * Real.sqrt (1 + s ^ 2)) • v‖ ≤ 2 * ρ
+    rw [norm_smul, Real.norm_eq_abs, abs_of_pos (mul_pos hρ hrpos), hv, mul_one]
+    calc
+      _ ≤ ρ * Real.sqrt (1 + s ^ 2) :=
+        mul_le_of_le_one_left (mul_pos hρ hrpos).le
+          (Real.exp_le_one_iff.mpr (neg_nonpos.mpr ht.1))
+      _ ≤ ρ * 2 := (mul_le_mul_of_nonneg_left hr hρ.le)
+      _ = 2 * ρ := mul_comm _ _
+
+private theorem
+    Degree.BeltPassage.contDiff_lower {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (ρ : ℝ) (u : N) (v : P) :
+    ContDiff ℝ ∞ (fun s => Degree.BeltPassage.lower ρ s u v) :=
+  ((contDiff_const.mul
+            ((contDiff_const.add (contDiff_id.pow 2)).sqrt (fun _ => by positivity))).smul
+        contDiff_const).prodMk
+    ((contDiff_const.mul contDiff_id).smul contDiff_const)
+
+private theorem Degree.BeltPassage.lower_zero {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (ρ : ℝ) (u : N) (v : P) :
+    Degree.BeltPassage.lower ρ 0 u v = (ρ • u, 0) := by
+  simp only [Degree.BeltPassage.lower, zero_pow (by decide : 2 ≠ 0), add_zero, Real.sqrt_one,
+    mul_one, MulZeroClass.mul_zero, zero_smul]
+
+private theorem Degree.BeltPassage.upper_neg {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (ρ s : ℝ) (u : N) (v : P) :
+    Degree.BeltPassage.upper ρ (-s) u v = Degree.BeltPassage.upper ρ s (-u) v := by
+  simp only [Degree.BeltPassage.upper, neg_sq, mul_neg, neg_smul, smul_neg]
+
+private theorem
+    Degree.BeltPassage.upper_height {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (ρ s : ℝ) {u : N} (hu : ‖u‖ = 1) {v : P}
+    (hv : ‖v‖ = 1) : Smale.MorseHandle.quadratic (Degree.BeltPassage.upper ρ s u v) = ρ ^ 2 := by
+  simp only [Smale.MorseHandle.quadratic, Degree.BeltPassage.upper, norm_smul, Real.norm_eq_abs,
+    hu, hv, mul_one, sq_abs, mul_pow, Real.sq_sqrt (show 0 ≤ 1 + s ^ 2 by positivity)]
+  ring
+
+private theorem
+    Degree.BeltPassage.contDiff_upper {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (ρ : ℝ) (u : N) (v : P) :
+    ContDiff ℝ ∞ (fun s => Degree.BeltPassage.upper ρ s u v) :=
+  ((contDiff_const.mul contDiff_id).smul contDiff_const).prodMk
+    ((contDiff_const.mul
+          ((contDiff_const.add (contDiff_id.pow 2)).sqrt (fun _ => by positivity))).smul
+      contDiff_const)
+
+private theorem Degree.BeltPassage.upper_zero {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (ρ : ℝ) (u : N) (v : P) :
+    Degree.BeltPassage.upper ρ 0 u v = (0, ρ • v) := by
+  simp only [Degree.BeltPassage.upper, zero_pow (by decide : 2 ≠ 0), add_zero, Real.sqrt_one,
+    mul_one, MulZeroClass.mul_zero, zero_smul]
+
+private theorem
+    Degree.BeltPassage.upper_mem_block {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ s : ℝ} (hρ : 0 < ρ) (hs : |s| ≤ 1) {u : N}
+    (hu : ‖u‖ = 1) {v : P} (hv : ‖v‖ = 1) :
+    Degree.BeltPassage.upper ρ s u v ∈
+      Metric.closedBall (0 : N) (2 * ρ) ×ˢ Metric.closedBall (0 : P) (2 * ρ) := by
+  have hrpos : 0 < Real.sqrt (1 + s ^ 2) := Real.sqrt_pos.mpr (by positivity)
+  have hr : Real.sqrt (1 + s ^ 2) ≤ 2 :=
+    Real.sqrt_le_iff.mpr ⟨by norm_num, by nlinarith [sq_abs s, abs_nonneg s]⟩
+  constructor
+  · rw [mem_closedBall_zero_iff]
+    change ‖(ρ * s) • u‖ ≤ 2 * ρ
+    rw [norm_smul, Real.norm_eq_abs, hu, mul_one, abs_mul, abs_of_pos hρ]
+    have hh := mul_le_mul_of_nonneg_left hs hρ.le
+    linarith
+  · rw [mem_closedBall_zero_iff]
+    change ‖(ρ * Real.sqrt (1 + s ^ 2)) • v‖ ≤ 2 * ρ
+    rw [norm_smul, Real.norm_eq_abs, abs_of_pos (mul_pos hρ hrpos), hv, mul_one]
+    exact (mul_le_mul_of_nonneg_left hr hρ.le).trans_eq (mul_comm _ _)
+
+private def Smale.RegularValues.singularPoints {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (f : E → E) : Set E :=
+  {x | (fderiv ℝ f x).det = 0}
+
+private def Smale.RegularValues.regularValues {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (f : E → E) : Set E :=
+  (f '' singularPoints f)ᶜ
+
+private theorem Smale.RegularValues.mem_regularValues_iff {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (f : E → E) (y : E) :
+    y ∈ regularValues f ↔ ∀ x, f x = y → (fderiv ℝ f x).det ≠ 0 := by
+  constructor
+  · intro hy x hx hdet
+    exact hy ⟨x, hdet, hx⟩
+  · intro hy ⟨x, hx, hxy⟩
+    exact hy x hxy hx
+
+private theorem Smale.RegularValues.bijective_iff_det_ne_zero {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] (A : E →L[ℝ] E) :
+    Function.Bijective A ↔ A.det ≠ 0 := by
+  constructor
+  · intro h hdet
+    exact (LinearMap.det_eq_zero_iff_ker_ne_bot.mp hdet) (LinearMap.ker_eq_bot.mpr h.1)
+  · intro hdet
+    have hker : A.toLinearMap.ker = ⊥ := by
+      by_contra hn
+      exact hdet (LinearMap.det_eq_zero_iff_ker_ne_bot.mpr hn)
+    have hi := LinearMap.ker_eq_bot.mp hker
+    exact ⟨hi, LinearMap.injective_iff_surjective.mp hi⟩
+
+private theorem Smale.RegularValues.bijective_fderiv_of_mem_regularValues {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] {f : E → E} {y : E}
+    (hy : y ∈ regularValues f) {x : E} (hx : f x = y) : Function.Bijective (fderiv ℝ f x) := by
+  have hdet := (mem_regularValues_iff f y).mp hy x hx
+  exact (bijective_iff_det_ne_zero _).mpr hdet
+
+private theorem
+    Smale.RegularValues.measure_singularValues_eq_zero {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [MeasurableSpace E] [BorelSpace E]
+    (μ : MeasureTheory.Measure E) [MeasureTheory.Measure.IsAddHaarMeasure μ] {f : E → E}
+    (hf : Differentiable ℝ f) : μ (f '' singularPoints f) = 0 :=
+  MeasureTheory.addHaar_image_eq_zero_of_det_fderivWithin_eq_zero μ
+    (fun x _ => (hf x).hasFDerivAt.hasFDerivWithinAt) (fun _ hx => hx)
+
+private theorem Smale.RegularValues.dense_regularValues {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [MeasurableSpace E] [BorelSpace E]
+    (μ : MeasureTheory.Measure E) [MeasureTheory.Measure.IsAddHaarMeasure μ] {f : E → E}
+    (hf : Differentiable ℝ f) : Dense (regularValues f) := by
+  have he : ∀ᵐ y ∂μ, y ∉ f '' singularPoints f := by
+    rw [MeasureTheory.ae_iff]
+    have hs : {y : E | ¬y ∉ f '' singularPoints f} = f '' singularPoints f := by
+      ext y
+      simp
+    rw [hs]
+    exact measure_singularValues_eq_zero μ hf
+  exact μ.dense_of_ae he
+
+private def Smale.MorsePerturbation.dualEquiv {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] : E ≃L[ℝ] (E →L[ℝ] ℝ) := by
+  classical
+    exact
+    ((Module.Basis.ofVectorSpace ℝ E).toDualEquiv.trans
+        LinearMap.toContinuousLinearMap).toContinuousLinearEquiv
+
+private def Smale.MorsePerturbation.coordinateGradient {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] (f : E → ℝ) (x : E) : E :=
+  dualEquiv.symm (fderiv ℝ f x)
+
+private def Smale.MorsePerturbation.linearPerturbation {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] (f : E → ℝ) (a : E) (x : E) : ℝ :=
+  f x - dualEquiv a x
+
+private def Smale.MorsePerturbation.IsMorse {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (f : E → ℝ) : Prop :=
+  ∀ x, fderiv ℝ f x = 0 → Function.Bijective (fderiv ℝ (fderiv ℝ f) x)
+
+private theorem Smale.MorsePerturbation.contDiff_fderiv {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {f : E → ℝ} (hf : ContDiff ℝ ∞ f) : ContDiff ℝ ∞ (fderiv ℝ f) :=
+  hf.fderiv_right (by simp)
+
+private theorem
+    Smale.MorsePerturbation.contDiff_coordinateGradient {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {f : E → ℝ} (hf : ContDiff ℝ ∞ f) :
+    ContDiff ℝ ∞ (coordinateGradient f) :=
+  dualEquiv.symm.contDiff.comp (contDiff_fderiv hf)
+
+private theorem Smale.MorsePerturbation.fderiv_linearPerturbation {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {f : E → ℝ} (hf : ContDiff ℝ ∞ f) (a x : E) :
+    fderiv ℝ (linearPerturbation f a) x = fderiv ℝ f x - dualEquiv a := by
+  unfold linearPerturbation
+  rw [fderiv_fun_sub (hf.differentiable (by simp) x) (dualEquiv a).differentiableAt,
+    ContinuousLinearMap.fderiv]
+
+private theorem
+    Smale.MorsePerturbation.hessian_linearPerturbation {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {f : E → ℝ} (hf : ContDiff ℝ ∞ f) (a x : E) :
+    fderiv ℝ (fderiv ℝ (linearPerturbation f a)) x = fderiv ℝ (fderiv ℝ f) x := by
+  have heq : fderiv ℝ (linearPerturbation f a) = fun y => fderiv ℝ f y - dualEquiv a :=
+    funext (fderiv_linearPerturbation hf a)
+  rw [heq, fderiv_sub_const]
+
+private theorem Smale.MorsePerturbation.fderiv_coordinateGradient {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {f : E → ℝ} (hf : ContDiff ℝ ∞ f) (x : E) :
+    fderiv ℝ (coordinateGradient f) x =
+      dualEquiv.symm.toContinuousLinearMap.comp (fderiv ℝ (fderiv ℝ f) x) := by
+  exact
+    (dualEquiv.symm.hasFDerivAt.comp x
+        ((contDiff_fderiv hf).differentiable (by simp) x).hasFDerivAt).fderiv
+
+private theorem Smale.MorsePerturbation.isMorse_of_regularValue {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {f : E → ℝ} (hf : ContDiff ℝ ∞ f) {a : E}
+    (ha : a ∈ Smale.RegularValues.regularValues (coordinateGradient f)) :
+    IsMorse (linearPerturbation f a) := by
+  intro x hx
+  rw [fderiv_linearPerturbation hf a x, sub_eq_zero] at hx
+  have hxa : coordinateGradient f x = a := by simp [coordinateGradient, hx]
+  have hbij := Smale.RegularValues.bijective_fderiv_of_mem_regularValues ha hxa
+  rw [hessian_linearPerturbation hf a x]
+  have heq :
+    (fun v : E => dualEquiv (fderiv ℝ (coordinateGradient f) x v)) = fderiv ℝ (fderiv ℝ f) x := by
+    funext v
+    rw [fderiv_coordinateGradient hf x]
+    exact dualEquiv.apply_symm_apply _
+  rw [← heq]
+  exact dualEquiv.bijective.comp hbij
+
+public
+theorem Smale.MorsePerturbation.isOpen_forall_mem_compact {P X : Type*} [TopologicalSpace P]
+    [TopologicalSpace X] {K : Set X} (hK : IsCompact K) {U : Set (P × X)} (hU : IsOpen U) :
+    IsOpen {p : P | ∀ x ∈ K, (p, x) ∈ U} := by
+  let : CompactSpace K := isCompact_iff_compactSpace.mp hK
+  let B : Set (P × K) := {q | (q.1, (q.2 : X)) ∉ U}
+  have hB : IsClosed B :=
+    hU.isClosed_compl.preimage
+      (continuous_fst.prodMk (continuous_subtype_val.comp continuous_snd))
+  have hproj : IsClosed ((Prod.fst : P × K → P) '' B) := isClosedMap_fst_of_compactSpace B hB
+  have heq : {p : P | ∀ x ∈ K, (p, x) ∈ U} = ((Prod.fst : P × K → P) '' B)ᶜ := by
+    ext p
+    constructor
+    · intro hp ⟨⟨q, x⟩, hbad, hq⟩
+      change q = p at hq
+      subst q
+      exact hbad (hp x x.property)
+    · intro hp x hx
+      by_contra hbad
+      exact hp ⟨(p, ⟨x, hx⟩), hbad, rfl⟩
+  rw [heq]
+  exact hproj.isOpen_compl
+
+private theorem
+    Smale.MorsePerturbation.contDiff_spatialDerivative {P E F : Type*} [NormedAddCommGroup P]
+    [NormedSpace ℝ P] [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {f : P → E → F} (hf : ContDiff ℝ ∞ (Function.uncurry f)) :
+    ContDiff ℝ ∞ (fun q : P × E => fderiv ℝ (f q.1) q.2) := by
+  let g : (P × E) → E → F := fun q x => f q.1 x
+  have hg : ContDiff ℝ ∞ (Function.uncurry g) := hf.comp (contDiff_fst.fst.prodMk contDiff_snd)
+  exact hg.fderiv contDiff_snd (by simp)
+
+private theorem Smale.MorsePerturbation.bijective_hessian_iff {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] (A : E →L[ℝ] (E →L[ℝ] ℝ)) :
+    Function.Bijective A ↔ (dualEquiv.symm.toContinuousLinearMap.comp A).det ≠ 0 := by
+  rw [← Smale.RegularValues.bijective_iff_det_ne_zero]
+  constructor
+  · intro hA
+    exact dualEquiv.symm.bijective.comp hA
+  · intro hA
+    have heq : (fun x : E => dualEquiv ((dualEquiv.symm.toContinuousLinearMap.comp A) x)) = A := by
+      funext x
+      exact dualEquiv.apply_symm_apply _
+    rw [← heq]
+    exact dualEquiv.bijective.comp hA
+
+private theorem Smale.MorsePerturbation.contDiffAt_spatialDerivative {P E F : Type*}
+    [NormedAddCommGroup P] [NormedSpace ℝ P] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] {f : P → E → F} {q : P × E}
+    (hf : ContDiffAt ℝ ∞ (Function.uncurry f) q) :
+    ContDiffAt ℝ ∞ (fun r : P × E => fderiv ℝ (f r.1) r.2) q := by
+  let g : (P × E) → E → F := fun r x => f r.1 x
+  have hg : ContDiffAt ℝ ∞ (Function.uncurry g) (q, q.2) :=
+    hf.comp (q, q.2) (contDiffAt_fst.fst.prodMk contDiffAt_snd)
+  exact hg.fderiv contDiffAt_snd (by simp)
+
+private theorem Smale.MorsePerturbation.contDiffOn_spatialDerivative {P E F : Type*}
+    [NormedAddCommGroup P] [NormedSpace ℝ P] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] {f : P → E → F} {U : Set (P × E)} (hU : IsOpen U)
+    (hf : ContDiffOn ℝ ∞ (Function.uncurry f) U) :
+    ContDiffOn ℝ ∞ (fun q : P × E => fderiv ℝ (f q.1) q.2) U := by
+  intro q hq
+  exact (contDiffAt_spatialDerivative (hf.contDiffAt (hU.mem_nhds hq))).contDiffWithinAt
+
+private theorem Smale.MorsePerturbation.isOpen_goodJetOn {P E : Type*} [NormedAddCommGroup P]
+    [NormedSpace ℝ P] [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    {f : P → E → ℝ} {U : Set (P × E)} (hU : IsOpen U)
+    (hf : ContDiffOn ℝ ∞ (Function.uncurry f) U) :
+    IsOpen
+      {q : P × E |
+        q ∈ U ∧
+          (fderiv ℝ (f q.1) q.2 ≠ 0 ∨ Function.Bijective (fderiv ℝ (fderiv ℝ (f q.1)) q.2))} := by
+  have h₁ := contDiffOn_spatialDerivative hU hf
+  have h₂ := contDiffOn_spatialDerivative (f := fun p x => fderiv ℝ (f p) x) hU h₁
+  have hd :
+    ContinuousOn
+      (fun q : P × E =>
+        (dualEquiv.symm.toContinuousLinearMap.comp (fderiv ℝ (fderiv ℝ (f q.1)) q.2)).det)
+      U :=
+    ContinuousLinearMap.continuous_det.comp_continuousOn
+      (continuousOn_const.clm_comp h₂.continuousOn)
+  have ha :=
+    h₁.continuousOn.isOpen_inter_preimage hU
+      (isClosed_singleton (x := (0 : E →L[ℝ] ℝ))).isOpen_compl
+  have hb := hd.isOpen_inter_preimage hU (isClosed_singleton (x := (0 : ℝ))).isOpen_compl
+  have heq :
+    {q : P × E |
+        q ∈ U ∧
+          (fderiv ℝ (f q.1) q.2 ≠ 0 ∨ Function.Bijective (fderiv ℝ (fderiv ℝ (f q.1)) q.2))} =
+      (U ∩ (fun q : P × E => fderiv ℝ (f q.1) q.2) ⁻¹' {0}ᶜ) ∪
+        (U ∩
+          (fun q : P × E =>
+              (dualEquiv.symm.toContinuousLinearMap.comp
+                  (fderiv ℝ (fderiv ℝ (f q.1)) q.2)).det) ⁻¹'
+            {0}ᶜ) := by
+    ext q
+    simp only [Set.mem_ofPred_eq, Set.mem_union, Set.mem_inter_iff, Set.mem_preimage,
+      Set.mem_compl_iff, Set.mem_singleton_iff, bijective_hessian_iff]
+    exact and_or_left
+  rw [heq]
+  exact ha.union hb
+
+private def Smale.ManifoldPerturbation.coordinateVector {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M] {p : M}
+    (φ : SmoothBumpFunction 𝓘(ℝ, E) p) (x : M) : E :=
+  φ x • extChartAt 𝓘(ℝ, E) p x
+
+private theorem
+    Smale.ManifoldPerturbation.contMDiff_coordinateVector {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [T2Space M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {p : M} (φ : SmoothBumpFunction 𝓘(ℝ, E) p) :
+    ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, E) ∞ (coordinateVector φ) :=
+  φ.contMDiff_smul contMDiffOn_extChartAt
+
+private def
+    Smale.ManifoldPerturbation.perturb {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M] {p : M}
+    (φ : SmoothBumpFunction 𝓘(ℝ, E) p) (f : M → ℝ) (a : E) (x : M) : ℝ :=
+  f x - Smale.MorsePerturbation.dualEquiv a (coordinateVector φ x)
+
+private theorem Smale.ManifoldPerturbation.contMDiff_perturb {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [T2Space M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {p : M} (φ : SmoothBumpFunction 𝓘(ℝ, E) p) {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) :
+    ContMDiff (𝓘(ℝ, E).prod 𝓘(ℝ, E)) 𝓘(ℝ, ℝ) ∞ (fun q : E × M => perturb φ f q.1 q.2) :=
+  (hf.comp contMDiff_snd).sub
+    ((Smale.MorsePerturbation.dualEquiv.contDiff.contMDiff.comp contMDiff_fst).clm_apply
+      ((contMDiff_coordinateVector φ).comp contMDiff_snd))
+
+@[simp]
+private theorem Smale.ManifoldPerturbation.perturb_zero {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M] {p : M}
+    (φ : SmoothBumpFunction 𝓘(ℝ, E) p) (f : M → ℝ) : perturb φ f 0 = f := by
+  funext x
+  simp [perturb]
+
+private def
+    Smale.ManifoldMorse.IsMorseAt (E : Type*) {M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] (f : M → ℝ) (x : M) : Prop :=
+  ∃ e : OpenPartialHomeomorph M E,
+    e ∈ IsManifold.maximalAtlas 𝓘(ℝ, E) ∞ M ∧
+      x ∈ e.source ∧
+        (fderiv ℝ (f ∘ e.symm) (e x) ≠ 0 ∨
+          Function.Bijective (fderiv ℝ (fderiv ℝ (f ∘ e.symm)) (e x)))
+
+private def
+    Smale.ManifoldMorse.IsMorseOn (E : Type*) {M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] (f : M → ℝ) (K : Set M) : Prop :=
+  ∀ x ∈ K, IsMorseAt E f x
+
+private def
+    Smale.ManifoldMorse.IsMorse (E : Type*) {M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] (f : M → ℝ) : Prop :=
+  ∀ x, IsMorseAt E f x
+
+private theorem Smale.ManifoldMorse.IsMorseOn.union {E : Type*} {M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {K L : Set M}
+    (hK : Smale.ManifoldMorse.IsMorseOn E f K) (hL : Smale.ManifoldMorse.IsMorseOn E f L) :
+    Smale.ManifoldMorse.IsMorseOn E f (K ∪ L) := by
+  intro x hx
+  rcases hx with hx | hx
+  · exact hK x hx
+  · exact hL x hx
+
+private theorem Smale.ManifoldMorse.contDiffOn_chartExpression {E : Type*} {M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {e : OpenPartialHomeomorph M E}
+    (he : e ∈ IsManifold.maximalAtlas 𝓘(ℝ, E) ∞ M) : ContDiffOn ℝ ∞ (f ∘ e.symm) e.target :=
+  (hf.comp_contMDiffOn (contMDiffOn_symm_of_mem_maximalAtlas he)).contDiffOn
+
+private theorem Smale.ManifoldMorse.isMorseAt_of_chart_eventuallyEq {E : Type*} {M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {g : E → ℝ} {x : M} {e : OpenPartialHomeomorph M E}
+    (he : e ∈ IsManifold.maximalAtlas 𝓘(ℝ, E) ∞ M) (hx : x ∈ e.source)
+    (hg : Smale.MorsePerturbation.IsMorse g) (heq : f ∘ e.symm =ᶠ[𝓝 (e x)] g) : IsMorseAt E f x :=
+  by
+  refine ⟨e, he, hx, ?_⟩
+  by_cases hc : fderiv ℝ (f ∘ e.symm) (e x) = 0
+  · right
+    rw [(heq.fderiv (𝕜 := ℝ)).fderiv_eq]
+    exact hg (e x) ((heq.fderiv_eq (𝕜 := ℝ)).symm.trans hc)
+  · exact Or.inl hc
+
+private theorem
+    Smale.ManifoldMorse.contDiffOn_inChart {E : Type*} {M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {P : Type*} [NormedAddCommGroup P]
+    [NormedSpace ℝ P] {f : P → M → ℝ}
+    (hf : ContMDiff (𝓘(ℝ, P).prod 𝓘(ℝ, E)) 𝓘(ℝ, ℝ) ∞ (Function.uncurry f))
+    {e : OpenPartialHomeomorph M E} (he : e ∈ IsManifold.maximalAtlas 𝓘(ℝ, E) ∞ M) :
+    ContDiffOn ℝ ∞ (fun q : P × E => f q.1 (e.symm q.2)) {q : P × E | q.2 ∈ e.target} := by
+  intro q hq
+  have hi := contMDiffAt_symm_of_mem_maximalAtlas he hq
+  have hmap :
+    ContMDiffAt 𝓘(ℝ, P × E) (𝓘(ℝ, P).prod 𝓘(ℝ, E)) ∞ (fun r : P × E => (r.1, e.symm r.2)) q :=
+    contDiffAt_fst.contMDiffAt.prodMk (hi.comp q contDiffAt_snd.contMDiffAt)
+  exact (hf.contMDiffAt.comp q hmap).contDiffAt.contDiffWithinAt
+
+private theorem
+    Smale.ManifoldMorse.isOpen_morseInChart {E : Type*} {M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M] {P : Type*}
+    [NormedAddCommGroup P] [NormedSpace ℝ P] {f : P → M → ℝ}
+    (hf : ContMDiff (𝓘(ℝ, P).prod 𝓘(ℝ, E)) 𝓘(ℝ, ℝ) ∞ (Function.uncurry f))
+    {e : OpenPartialHomeomorph M E} (he : e ∈ IsManifold.maximalAtlas 𝓘(ℝ, E) ∞ M) :
+    IsOpen
+      {q : P × M |
+        q.2 ∈ e.source ∧
+          (fderiv ℝ (f q.1 ∘ e.symm) (e q.2) ≠ 0 ∨
+            Function.Bijective (fderiv ℝ (fderiv ℝ (f q.1 ∘ e.symm)) (e q.2)))} := by
+  have hg :=
+    Smale.MorsePerturbation.isOpen_goodJetOn (f := fun a y => f a (e.symm y))
+      (e.open_target.preimage (continuous_snd : Continuous (Prod.snd : P × E → E)))
+      (contDiffOn_inChart hf he)
+  let S : Set (P × M) := {q | q.2 ∈ e.source}
+  have hS : IsOpen S := e.open_source.preimage continuous_snd
+  have hm : ContinuousOn (fun q : P × M => (q.1, e q.2)) S :=
+    continuous_fst.continuousOn.prodMk
+      (e.continuousOn.comp continuous_snd.continuousOn (fun _ hq => hq))
+  convert hm.isOpen_inter_preimage hS hg using 1
+  ext q
+  simp only [Set.mem_ofPred_eq, Set.mem_inter_iff, Set.mem_preimage, S]
+  constructor
+  · rintro ⟨hq, hg⟩
+    exact ⟨hq, e.map_source hq, hg⟩
+  · rintro ⟨hq, -, hg⟩
+    exact ⟨hq, hg⟩
+
+private theorem Smale.ManifoldMorse.isOpen_isMorseAt {E : Type*} {M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M] {P : Type*}
+    [NormedAddCommGroup P] [NormedSpace ℝ P] {f : P → M → ℝ}
+    (hf : ContMDiff (𝓘(ℝ, P).prod 𝓘(ℝ, E)) 𝓘(ℝ, ℝ) ∞ (Function.uncurry f)) :
+    IsOpen {q : P × M | IsMorseAt E (f q.1) q.2} := by
+  have heq :
+    {q : P × M | IsMorseAt E (f q.1) q.2} =
+      ⋃ (e : OpenPartialHomeomorph M E) (_ : e ∈ IsManifold.maximalAtlas 𝓘(ℝ, E) ∞ M),
+        {q : P × M |
+          q.2 ∈ e.source ∧
+            (fderiv ℝ (f q.1 ∘ e.symm) (e q.2) ≠ 0 ∨
+              Function.Bijective (fderiv ℝ (fderiv ℝ (f q.1 ∘ e.symm)) (e q.2)))} := by
+    ext q
+    simp only [Set.mem_ofPred_eq, IsMorseAt, Set.mem_iUnion, exists_prop]
+  rw [heq]
+  exact isOpen_iUnion fun e => isOpen_iUnion fun he => isOpen_morseInChart hf he
+
+private theorem Smale.ManifoldMorse.isOpen_isMorseOn {E : Type*} {M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M] {P : Type*}
+    [NormedAddCommGroup P] [NormedSpace ℝ P] {f : P → M → ℝ}
+    (hf : ContMDiff (𝓘(ℝ, P).prod 𝓘(ℝ, E)) 𝓘(ℝ, ℝ) ∞ (Function.uncurry f)) {K : Set M}
+    (hK : IsCompact K) : IsOpen {p : P | IsMorseOn E (f p) K} :=
+  Smale.MorsePerturbation.isOpen_forall_mem_compact hK (isOpen_isMorseAt hf)
+
+private def
+    Smale.MorsePerturbation.hessianEquiv {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] (f : E → ℝ) (x : E)
+    (h : Function.Bijective (fderiv ℝ (fderiv ℝ f) x)) : E ≃L[ℝ] (E →L[ℝ] ℝ) :=
+  (LinearEquiv.ofBijective (fderiv ℝ (fderiv ℝ f) x).toLinearMap h).toContinuousLinearEquiv
+
+@[simp]
+private theorem Smale.MorsePerturbation.hessianEquiv_toContinuousLinearMap {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] (f : E → ℝ) (x : E)
+    (h : Function.Bijective (fderiv ℝ (fderiv ℝ f) x)) :
+    (hessianEquiv f x h).toContinuousLinearMap = fderiv ℝ (fderiv ℝ f) x := by
+  ext v w
+  rfl
+
+private def Smale.ManifoldMorse.criticalPoints {M : Type*} [TopologicalSpace M] (E : Type*)
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [ChartedSpace E M] (f : M → ℝ) : Set M :=
+  {x | mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f x = 0}
+
+private theorem Smale.ManifoldMorse.mem_criticalPoints_iff {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {e : OpenPartialHomeomorph M E}
+    (he : e ∈ IsManifold.maximalAtlas 𝓘(ℝ, E) ∞ M) {x : M} (hx : x ∈ e.source) :
+    x ∈ criticalPoints E f ↔ fderiv ℝ (f ∘ e.symm) (e x) = 0 := by
+  have he' : e.MDifferentiable 𝓘(ℝ, E) 𝓘(ℝ, E) :=
+    ⟨(contMDiffOn_of_mem_maximalAtlas he).mdifferentiableOn (by simp),
+      (contMDiffOn_symm_of_mem_maximalAtlas he).mdifferentiableOn (by simp)⟩
+  have hcomp :
+    fderiv ℝ (f ∘ e.symm) (e x) =
+      (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f x).comp (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) e.symm (e x)) := by
+    rw [← mfderiv_eq_fderiv,
+      mfderiv_comp (e x) (hf.mdifferentiableAt (by simp))
+        (he'.mdifferentiableAt_symm (e.map_source hx))]
+    rw [e.left_inv hx]
+  rw [hcomp]
+  change mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f x = 0 ↔ _
+  constructor
+  · intro h
+    rw [h]
+    ext v
+    rfl
+  · intro h
+    ext v
+    obtain ⟨w, hw⟩ := he'.symm.mfderiv_surjective (e.map_source hx) v
+    have hh := congrArg (fun A : E →L[ℝ] ℝ => A w) h
+    change (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f x) ((mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) e.symm (e x)) w) = 0 at hh
+    rw [hw] at hh
+    exact hh
+
+private theorem Smale.ManifoldMorse.criticalPoints_isClosed {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) : IsClosed (criticalPoints E f) := by
+  apply isOpen_compl_iff.mp
+  rw [isOpen_iff_mem_nhds]
+  intro x hx
+  let e := chartAt E x
+  have he : e ∈ IsManifold.maximalAtlas 𝓘(ℝ, E) ∞ M := IsManifold.chart_mem_maximalAtlas x
+  have hxS : x ∈ e.source := mem_chart_source E x
+  have hd := (contDiffOn_chartExpression hf he).fderiv_of_isOpen e.open_target (m := ∞) (by simp)
+  let V : Set E := e.target ∩ (fderiv ℝ (f ∘ e.symm)) ⁻¹' {0}ᶜ
+  have hV : IsOpen V :=
+    hd.continuousOn.isOpen_inter_preimage e.open_target
+      (isClosed_singleton (x := (0 : E →L[ℝ] ℝ))).isOpen_compl
+  have hU := e.continuousOn.isOpen_inter_preimage e.open_source hV
+  have hxU : x ∈ e.source ∩ e ⁻¹' V :=
+    ⟨hxS, e.map_source hxS, fun h => hx ((mem_criticalPoints_iff hf he hxS).mpr h)⟩
+  apply Filter.mem_of_superset (hU.mem_nhds hxU)
+  intro y hy hc
+  exact hy.2.2 ((mem_criticalPoints_iff hf he hy.1).mp hc)
+
+private theorem Smale.ManifoldMorse.criticalPoints_isDiscrete {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : IsMorse E f) : IsDiscrete (criticalPoints E f) := by
+  rw [isDiscrete_iff_forall_mem_exists_isOpen]
+  intro x hx
+  obtain ⟨e, he, hxS, hreg | hH⟩ := hm x
+  · exact False.elim (hreg ((mem_criticalPoints_iff hf he hxS).mp hx))
+  · have hc : fderiv ℝ (f ∘ e.symm) (e x) = 0 := (mem_criticalPoints_iff hf he hxS).mp hx
+    have hloc :=
+      (contDiffOn_chartExpression hf he).contDiffAt (e.open_target.mem_nhds (e.map_source hxS))
+    have hdf := hloc.fderiv_right (m := ∞) (by simp)
+    let L := Smale.MorsePerturbation.hessianEquiv (f ∘ e.symm) (e x) hH
+    have hL : HasFDerivAt (fderiv ℝ (f ∘ e.symm)) L.toContinuousLinearMap (e x) := by
+      rw [show L.toContinuousLinearMap = fderiv ℝ (fderiv ℝ (f ∘ e.symm)) (e x) from
+          Smale.MorsePerturbation.hessianEquiv_toContinuousLinearMap _ _ hH]
+      exact (hdf.differentiableAt (by simp)).hasFDerivAt
+    let d := hdf.toOpenPartialHomeomorph (fderiv ℝ (f ∘ e.symm)) hL (by simp)
+    have hd : e x ∈ d.source := hdf.mem_toOpenPartialHomeomorph_source hL (by simp)
+    let U := e.source ∩ e ⁻¹' d.source
+    have hU : IsOpen U := e.continuousOn.isOpen_inter_preimage e.open_source d.open_source
+    refine ⟨U, hU, ?_⟩
+    ext y
+    constructor
+    · rintro ⟨hy, hyc⟩
+      apply Set.mem_singleton_iff.mpr
+      apply e.injOn hy.1 hxS
+      apply d.injOn hy.2 hd
+      exact ((mem_criticalPoints_iff hf he hy.1).mp hyc).trans hc.symm
+    · intro hy
+      rcases Set.mem_singleton_iff.mp hy with rfl
+      exact ⟨⟨hxS, hd⟩, hx⟩
+
+private theorem Smale.ManifoldMorse.finite_criticalPoints {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : IsMorse E f) : (criticalPoints E f).Finite :=
+  (criticalPoints_isClosed hf).isCompact.finite (criticalPoints_isDiscrete hf hm)
+
+private def
+    Smale.FlowConstruction.chartDirection {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] (e : OpenPartialHomeomorph M E) (w : E) :
+    (x : M) → TangentSpace 𝓘(ℝ, E) x :=
+  VectorField.mpullback 𝓘(ℝ, E) 𝓘(ℝ, E) e (fun y => (NormedSpace.fromTangentSpace y).symm w)
+
+private theorem
+    Smale.FlowConstruction.contMDiffOn_chartDirection {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {e : OpenPartialHomeomorph M E}
+    (he : e ∈ IsManifold.maximalAtlas 𝓘(ℝ, E) ∞ M) (w : E) :
+    ContMDiffOn 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞
+      (fun x => (⟨x, chartDirection e w x⟩ : TangentBundle 𝓘(ℝ, E) M)) e.source := by
+  have hW :
+    ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞
+      (fun y : E => (⟨y, (NormedSpace.fromTangentSpace y).symm w⟩ : TangentBundle 𝓘(ℝ, E) E)) :=
+    contMDiff_vectorSpace_iff_contDiff.mpr contDiff_const
+  have he' : e.MDifferentiable 𝓘(ℝ, E) 𝓘(ℝ, E) :=
+    ⟨(contMDiffOn_of_mem_maximalAtlas he).mdifferentiableOn (by simp),
+      (contMDiffOn_symm_of_mem_maximalAtlas he).mdifferentiableOn (by simp)⟩
+  intro x hx
+  have hinv : (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) e x).IsInvertible := ⟨he'.mfderiv hx, rfl⟩
+  exact
+    ((hW (e x)).mpullback_vectorField_preimage (contMDiffAt_of_mem_maximalAtlas he hx) hinv
+        (by simp)).contMDiffWithinAt
+
+private theorem Smale.FlowConstruction.mvfderiv_chartDirection {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {e : OpenPartialHomeomorph M E}
+    (he : e ∈ IsManifold.maximalAtlas 𝓘(ℝ, E) ∞ M) (w : E) {x : M} (hx : x ∈ e.source) :
+    mvfderiv 𝓘(ℝ, E) f x (chartDirection e w x) = fderiv ℝ (f ∘ e.symm) (e x) w := by
+  have he' : e.MDifferentiable 𝓘(ℝ, E) 𝓘(ℝ, E) :=
+    ⟨(contMDiffOn_of_mem_maximalAtlas he).mdifferentiableOn (by simp),
+      (contMDiffOn_symm_of_mem_maximalAtlas he).mdifferentiableOn (by simp)⟩
+  have h₁ := he'.comp_symm_deriv (e.map_source hx)
+  rw [e.left_inv hx] at h₁
+  have hi := ContinuousLinearMap.inverse_eq h₁ (he'.symm_comp_deriv hx)
+  have hc :
+    fderiv ℝ (f ∘ e.symm) (e x) =
+      (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f x).comp (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) e.symm (e x)) := by
+    rw [← mfderiv_eq_fderiv,
+      mfderiv_comp (e x) (hf.mdifferentiableAt (by simp))
+        (he'.mdifferentiableAt_symm (e.map_source hx))]
+    rw [e.left_inv hx]
+  unfold chartDirection
+  rw [VectorField.mpullback_apply, hi]
+  exact (congrArg (fun A : E →L[ℝ] ℝ => A w) hc).symm
+
+private theorem Smale.FlowConstruction.exists_unitSpeedField_near_regular {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    {p : M} (hp : p ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    ∃ U : Set M,
+      IsOpen U ∧
+        p ∈ U ∧
+          ∃ V : (x : M) → TangentSpace 𝓘(ℝ, E) x,
+            ContMDiffOn 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞
+                (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)) U ∧
+              ∀ x ∈ U, mvfderiv 𝓘(ℝ, E) f x (V x) = 1 := by
+  classical
+  let e := chartAt E p
+  have he : e ∈ IsManifold.maximalAtlas 𝓘(ℝ, E) ∞ M := IsManifold.chart_mem_maximalAtlas p
+  have hpS : p ∈ e.source := mem_chart_source E p
+  have hdf : fderiv ℝ (f ∘ e.symm) (e p) ≠ 0 := fun h =>
+    hp ((Smale.ManifoldMorse.mem_criticalPoints_iff hf he hpS).mpr h)
+  have hw : ∃ w : E, fderiv ℝ (f ∘ e.symm) (e p) w ≠ 0 := by
+    by_contra! h
+    exact hdf (ContinuousLinearMap.ext h)
+  obtain ⟨w, hw⟩ := hw
+  let D : M → ℝ := fun x => fderiv ℝ (f ∘ e.symm) (e x) w
+  have hder :=
+    (Smale.ManifoldMorse.contDiffOn_chartExpression hf he).fderiv_of_isOpen e.open_target (m := ∞)
+      (by simp)
+  have hD : ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ D e.source :=
+    (hder.clm_apply contDiffOn_const).contMDiffOn.comp (contMDiffOn_of_mem_maximalAtlas he)
+      (fun _ hx => e.map_source hx)
+  let U : Set M := e.source ∩ D ⁻¹' {0}ᶜ
+  have hU : IsOpen U :=
+    hD.continuousOn.isOpen_inter_preimage e.open_source
+      (isClosed_singleton (x := (0 : ℝ))).isOpen_compl
+  let V : (x : M) → TangentSpace 𝓘(ℝ, E) x := fun x => (D x)⁻¹ • chartDirection e w x
+  refine ⟨U, hU, ⟨hpS, hw⟩, V, ?_, ?_⟩
+  · exact
+      ((hD.mono Set.inter_subset_left).inv₀ (fun _ hx => hx.2)).smul_section
+        ((contMDiffOn_chartDirection he w).mono Set.inter_subset_left)
+  · intro x hx
+    change mvfderiv 𝓘(ℝ, E) f x ((D x)⁻¹ • chartDirection e w x) = 1
+    rw [map_smul, smul_eq_mul, mvfderiv_chartDirection hf he w hx.1]
+    exact inv_mul_cancel₀ hx.2
+
+private theorem Smale.FlowConstruction.exists_prescribedDerivativeField {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [SigmaCompactSpace M] {f χ : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hχ : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ χ)
+    (hsupp : tsupport χ ⊆ (Smale.ManifoldMorse.criticalPoints E f)ᶜ) :
+    ∃ V : (x : M) → TangentSpace 𝓘(ℝ, E) x,
+      ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+        ∀ x, mvfderiv 𝓘(ℝ, E) f x (V x) = χ x := by
+  let C : (x : M) → Set (TangentSpace 𝓘(ℝ, E) x) := fun x => {w | mvfderiv 𝓘(ℝ, E) f x w = χ x}
+  have hC (x : M) : Convex ℝ (C x) :=
+    (convex_singleton (χ x)).linear_preimage (mvfderiv 𝓘(ℝ, E) f x).toLinearMap
+  have hlocal :
+    ∀ p : M,
+      ∃ U ∈ 𝓝 p,
+        ∃ V : (x : M) → TangentSpace 𝓘(ℝ, E) x,
+          ContMDiffOn 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M))
+              U ∧
+            ∀ x ∈ U, V x ∈ C x := by
+    intro p
+    by_cases hp : p ∉ Smale.ManifoldMorse.criticalPoints E f
+    · obtain ⟨U, hU, hpU, V, hV, hVunit⟩ := exists_unitSpeedField_near_regular hf hp
+      refine ⟨U, hU.mem_nhds hpU, (fun x => χ x • V x), hχ.contMDiffOn.smul_section hV, ?_⟩
+      intro x hx
+      change mvfderiv 𝓘(ℝ, E) f x (χ x • V x) = χ x
+      rw [map_smul, hVunit x hx, smul_eq_mul, mul_one]
+    · have hps : p ∉ tsupport χ := fun h => hp (hsupp h)
+      refine
+        ⟨(tsupport χ)ᶜ, (isClosed_tsupport χ).isOpen_compl.mem_nhds hps, (fun _ => 0),
+          (Bundle.contMDiff_zeroSection ℝ (TangentSpace 𝓘(ℝ, E))).contMDiffOn, ?_⟩
+      intro x hx
+      change mvfderiv 𝓘(ℝ, E) f x 0 = χ x
+      rw [map_zero, image_eq_zero_of_notMem_tsupport hx]
+  obtain ⟨V, hV⟩ :=
+    exists_contMDiffSection_forall_mem_convex_of_local (n := ⊤) 𝓘(ℝ, E)
+      (TangentSpace 𝓘(ℝ, E) (M := M)) C hC hlocal
+  exact ⟨V, V.contMDiff, hV⟩
+
+private theorem Smale.FlowConstruction.exists_gluedDescentField {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [SigmaCompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {ι : Type*} [Finite ι] (U K : ι → Set M)
+    (hU : ∀ i, IsOpen (U i)) (hK : ∀ i, IsClosed (K i)) (hKU : ∀ i, K i ⊆ U i)
+    (hdisj : Pairwise (fun i j => Disjoint (U i) (U j)))
+    (hcover : Smale.ManifoldMorse.criticalPoints E f ⊆ ⋃ i, K i)
+    (Vloc : ι → (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hVloc :
+      ∀ i,
+        ContMDiffOn 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞
+          (fun x => (⟨x, Vloc i x⟩ : TangentBundle 𝓘(ℝ, E) M)) (U i))
+    (hdesc :
+      ∀ i x,
+        x ∈ U i →
+          x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (Vloc i x) < 0) :
+    ∃ V : (x : M) → TangentSpace 𝓘(ℝ, E) x,
+      ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+        (∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0) ∧
+          ∀ i x, x ∈ K i → V x = Vloc i x := by
+  let C : (x : M) → Set (TangentSpace 𝓘(ℝ, E) x) := fun x =>
+    {w |
+      (x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x w < 0) ∧
+        ∀ i, x ∈ K i → w = Vloc i x}
+  have hC (x : M) : Convex ℝ (C x) := by
+    intro u hu v hv a b ha hb hab
+    refine ⟨?_, ?_⟩
+    · intro hreg
+      have h := (convex_Iio (0 : ℝ)) (hu.1 hreg) (hv.1 hreg) ha hb hab
+      simpa only [map_add, map_smul, smul_eq_mul, Set.mem_Iio] using h
+    · intro i hxi
+      rw [hu.2 i hxi, hv.2 i hxi, ← add_smul, hab, one_smul]
+  have hclosed : IsClosed (⋃ i, K i) := isClosed_iUnion_of_finite hK
+  have hlocal :
+    ∀ p : M,
+      ∃ W ∈ 𝓝 p,
+        ∃ V : (x : M) → TangentSpace 𝓘(ℝ, E) x,
+          ContMDiffOn 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M))
+              W ∧
+            ∀ x ∈ W, V x ∈ C x := by
+    intro p
+    by_cases hp : p ∈ ⋃ i, K i
+    · obtain ⟨i, hpi⟩ := Set.mem_iUnion.mp hp
+      refine ⟨U i, (hU i).mem_nhds (hKU i hpi), Vloc i, hVloc i, ?_⟩
+      intro x hx
+      refine ⟨hdesc i x hx, ?_⟩
+      intro j hxj
+      by_cases hij : i = j
+      · subst j
+        rfl
+      · exact False.elim (Set.disjoint_left.mp (hdisj hij) hx (hKU j hxj))
+    · have hpreg : p ∉ Smale.ManifoldMorse.criticalPoints E f := fun h => hp (hcover h)
+      obtain ⟨W, hW, hpW, V, hV, hVf⟩ := exists_unitSpeedField_near_regular hf hpreg
+      refine
+        ⟨W ∩ (⋃ i, K i)ᶜ, (hW.inter hclosed.isOpen_compl).mem_nhds ⟨hpW, hp⟩, (fun x => -(V x)),
+          hV.neg_section.mono Set.inter_subset_left, ?_⟩
+      intro x hx
+      refine ⟨?_, ?_⟩
+      · intro _
+        change mvfderiv 𝓘(ℝ, E) f x (-V x) < 0
+        rw [map_neg, hVf x hx.1]
+        norm_num
+      · intro i hxi
+        exact False.elim (hx.2 (Set.mem_iUnion.mpr ⟨i, hxi⟩))
+  obtain ⟨V, hV⟩ :=
+    exists_contMDiffSection_forall_mem_convex_of_local (n := ⊤) 𝓘(ℝ, E)
+      (TangentSpace 𝓘(ℝ, E) (M := M)) C hC hlocal
+  exact ⟨V, V.contMDiff, fun x => (hV x).1, fun i x hx => (hV x).2 i hx⟩
+
+private theorem MorseCancel.exists_closed_patch_descent_field {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [SigmaCompactSpace M] {f : M → ℝ}
+    (V₀ : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hV₀ : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V₀ x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hzero₀ : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V₀ x = 0)
+    (hdesc₀ : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V₀ x) < 0)
+    {ι : Type*} [Finite ι] (K U : ι → Set M) (hK : ∀ i, IsClosed (K i)) (hU : ∀ i, IsOpen (U i))
+    (hKU : ∀ i, K i ⊆ U i) (hdisj : Pairwise (fun i j => Disjoint (K i) (K j)))
+    (Vloc : ι → (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hVloc :
+      ∀ i,
+        ContMDiffOn 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞
+          (fun x => (⟨x, Vloc i x⟩ : TangentBundle 𝓘(ℝ, E) M)) (U i))
+    (hzero : ∀ i x, x ∈ U i → x ∈ Smale.ManifoldMorse.criticalPoints E f → Vloc i x = 0)
+    (hdesc :
+      ∀ i x,
+        x ∈ U i →
+          x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (Vloc i x) < 0) :
+    ∃ V : (x : M) → TangentSpace 𝓘(ℝ, E) x,
+      ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+        (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0) ∧
+          (∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0) ∧
+            ∀ i x, x ∈ K i → V x = Vloc i x := by
+  classical
+  let C : (x : M) → Set (TangentSpace 𝓘(ℝ, E) x) := fun x =>
+    {w |
+      (x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x w < 0) ∧
+        (x ∈ Smale.ManifoldMorse.criticalPoints E f → w = 0) ∧ ∀ i, x ∈ K i → w = Vloc i x}
+  have hC (x : M) : Convex ℝ (C x) := by
+    intro u hu v hv a b ha hb hab
+    refine ⟨?_, ?_, ?_⟩
+    · intro hreg
+      have h := (convex_Iio (0 : ℝ)) (hu.1 hreg) (hv.1 hreg) ha hb hab
+      simpa only [map_add, map_smul, smul_eq_mul, Set.mem_Iio] using h
+    · intro hcrit
+      rw [hu.2.1 hcrit, hv.2.1 hcrit, smul_zero, smul_zero, add_zero]
+    · intro i hxi
+      rw [hu.2.2 i hxi, hv.2.2 i hxi, ← add_smul, hab, one_smul]
+  have hclosed : IsClosed (⋃ i, K i) := isClosed_iUnion_of_finite hK
+  have hlocal :
+    ∀ p : M,
+      ∃ O ∈ 𝓝 p,
+        ∃ V : (x : M) → TangentSpace 𝓘(ℝ, E) x,
+          ContMDiffOn 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M))
+              O ∧
+            ∀ x ∈ O, V x ∈ C x := by
+    intro p
+    by_cases hp : p ∈ ⋃ i, K i
+    · obtain ⟨i, hpi⟩ := Set.mem_iUnion.mp hp
+      let R := ⋃ j : { j : ι // j ≠ i }, K j
+      have hR : IsClosed R := isClosed_iUnion_of_finite (fun j => hK j)
+      have hpR : p ∉ R := by
+        intro hpR
+        obtain ⟨j, hpj⟩ := Set.mem_iUnion.mp hpR
+        exact Set.disjoint_left.mp (hdisj (fun h => j.property h.symm)) hpi hpj
+      refine
+        ⟨U i ∩ Rᶜ, ((hU i).inter hR.isOpen_compl).mem_nhds ⟨hKU i hpi, hpR⟩, Vloc i,
+          (hVloc i).mono Set.inter_subset_left, ?_⟩
+      intro x hx
+      refine ⟨hdesc i x hx.1, hzero i x hx.1, ?_⟩
+      intro j hxj
+      by_cases hij : i = j
+      · subst j
+        rfl
+      · exact False.elim (hx.2 (Set.mem_iUnion.mpr ⟨⟨j, fun h => hij h.symm⟩, hxj⟩))
+    · refine ⟨(⋃ i, K i)ᶜ, hclosed.isOpen_compl.mem_nhds hp, V₀, hV₀.contMDiffOn, ?_⟩
+      intro x hx
+      refine ⟨hdesc₀ x, hzero₀ x, ?_⟩
+      intro i hxi
+      exact False.elim (hx (Set.mem_iUnion.mpr ⟨i, hxi⟩))
+  obtain ⟨V, hV⟩ :=
+    exists_contMDiffSection_forall_mem_convex_of_local (n := ⊤) 𝓘(ℝ, E)
+      (TangentSpace 𝓘(ℝ, E) (M := M)) C hC hlocal
+  exact ⟨V, V.contMDiff, fun x => (hV x).2.1, fun x => (hV x).1, fun i x hx => (hV x).2.2 i hx⟩
+
+private def Smale.FlowConstruction.partialChartField {E F M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace M]
+    [ChartedSpace E M] (e : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, F) M F ∞) (W : F → F) :
+    (x : M) → TangentSpace 𝓘(ℝ, E) x :=
+  VectorField.mpullback 𝓘(ℝ, E) 𝓘(ℝ, F) e (fun y => (NormedSpace.fromTangentSpace y).symm (W y))
+
+private theorem Smale.FlowConstruction.contMDiffOn_partialChartField {E F M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace M] [ChartedSpace E M] [CompleteSpace E] [IsManifold 𝓘(ℝ, E) ∞ M]
+    (e : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, F) M F ∞) {W : F → F} (hW : ContDiff ℝ ∞ W) :
+    ContMDiffOn 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞
+      (fun x => (⟨x, partialChartField e W x⟩ : TangentBundle 𝓘(ℝ, E) M)) e.source := by
+  let e' := e.toOpenPartialHomeomorph
+  have he : e'.MDifferentiable 𝓘(ℝ, E) 𝓘(ℝ, F) :=
+    ⟨e.contMDiffOn.mdifferentiableOn (by simp), e.symm.contMDiffOn.mdifferentiableOn (by simp)⟩
+  have hW' :
+    ContMDiff 𝓘(ℝ, F) (𝓘(ℝ, F).tangent) ∞
+      (fun y : F =>
+        (⟨y, (NormedSpace.fromTangentSpace y).symm (W y)⟩ : TangentBundle 𝓘(ℝ, F) F)) :=
+    contMDiff_vectorSpace_iff_contDiff.mpr hW
+  intro x hx
+  have hinv : (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, F) e x).IsInvertible := ⟨he.mfderiv hx, rfl⟩
+  exact
+    ((hW' (e x)).mpullback_vectorField_preimage
+        ((e.contMDiffOn x hx).contMDiffAt (e.open_source.mem_nhds hx)) hinv
+        (by simp)).contMDiffWithinAt
+
+private theorem
+    Smale.FlowConstruction.mvfderiv_partialChartField {E F M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace M]
+    [ChartedSpace E M] {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (e : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, F) M F ∞) (W : F → F) {x : M} (hx : x ∈ e.source) :
+    mvfderiv 𝓘(ℝ, E) f x (partialChartField e W x) = fderiv ℝ (f ∘ e.symm) (e x) (W (e x)) := by
+  let e' := e.toOpenPartialHomeomorph
+  have he : e'.MDifferentiable 𝓘(ℝ, E) 𝓘(ℝ, F) :=
+    ⟨e.contMDiffOn.mdifferentiableOn (by simp), e.symm.contMDiffOn.mdifferentiableOn (by simp)⟩
+  have h₁ := he.comp_symm_deriv (e'.map_source hx)
+  rw [e'.left_inv hx] at h₁
+  have hi := ContinuousLinearMap.inverse_eq h₁ (he.symm_comp_deriv hx)
+  have hc :
+    fderiv ℝ (f ∘ e'.symm) (e' x) =
+      (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f x).comp (mfderiv 𝓘(ℝ, F) 𝓘(ℝ, E) e'.symm (e' x)) := by
+    rw [← mfderiv_eq_fderiv,
+      mfderiv_comp (e' x) (hf.mdifferentiableAt (by simp))
+        (he.mdifferentiableAt_symm (e'.map_source hx))]
+    rw [e'.left_inv hx]
+  unfold partialChartField
+  rw [VectorField.mpullback_apply]
+  change
+    mvfderiv 𝓘(ℝ, E) f x
+        ((mfderiv 𝓘(ℝ, E) 𝓘(ℝ, F) e' x).inverse
+          ((NormedSpace.fromTangentSpace (e' x)).symm (W (e' x)))) =
+      _
+  rw [hi]
+  exact (congrArg (fun A : F →L[ℝ] ℝ => A (W (e' x))) hc).symm
+
+private theorem Smale.ManifoldMorse.exists_compact_plateau {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M] (p : M) :
+    ∃ (φ : SmoothBumpFunction 𝓘(ℝ, E) p) (U L : Set M),
+      IsOpen U ∧
+        U ⊆ (chartAt E p).source ∧ Set.EqOn φ (fun _ => 1) U ∧ IsCompact L ∧ L ∈ 𝓝 p ∧ L ⊆ U := by
+  let : LocallyCompactSpace M := ChartedSpace.locallyCompactSpace E M
+  let φ : SmoothBumpFunction 𝓘(ℝ, E) p := Classical.choice inferInstance
+  have hN : {x : M | φ x = 1} ∩ (chartAt E p).source ∈ 𝓝 p :=
+    Filter.inter_mem φ.eventuallyEq_one
+      ((chartAt E p).open_source.mem_nhds (mem_chart_source E p))
+  obtain ⟨U, hUN, hU, hpU⟩ := mem_nhds_iff.mp hN
+  obtain ⟨L, hpL, hLU, hL⟩ := local_compact_nhds (hU.mem_nhds hpU)
+  exact ⟨φ, U, L, hU, fun x hx => (hUN hx).2, fun x hx => (hUN hx).1, hL, hpL, hLU⟩
+
+private theorem
+    Smale.ManifoldMorse.perturb_inChart_eventuallyEq {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M] {p : M}
+    (φ : SmoothBumpFunction 𝓘(ℝ, E) p) {f : M → ℝ} {G : E → ℝ} {U : Set M} {V : Set E}
+    (hU : IsOpen U) (hUs : U ⊆ (chartAt E p).source) (hφ : Set.EqOn φ (fun _ => 1) U)
+    (hV : IsOpen V) (hG : Set.EqOn G (f ∘ (chartAt E p).symm) V) (a : E) {x : M} (hx : x ∈ U)
+    (hxV : chartAt E p x ∈ V) :
+    Smale.ManifoldPerturbation.perturb φ f a ∘ (chartAt E p).symm =ᶠ[𝓝 (chartAt E p x)]
+      Smale.MorsePerturbation.linearPerturbation G a := by
+  let e := chartAt E p
+  have hxt : e x ∈ e.target := e.map_source (hUs hx)
+  have hi : ContinuousAt e.symm (e x) := e.symm.continuousAt hxt
+  have hpre : e.symm ⁻¹' U ∈ 𝓝 (e x) := by
+    apply hi.preimage_mem_nhds
+    simpa only [e.left_inv (hUs hx)] using hU.mem_nhds hx
+  filter_upwards [hpre, e.open_target.mem_nhds hxt, hV.mem_nhds hxV] with y hyU hyt hyV
+  have hφy := hφ hyU
+  have hGy := hG hyV
+  change G y = f (e.symm y) at hGy
+  change
+    f (e.symm y) -
+        Smale.MorsePerturbation.dualEquiv a (φ (e.symm y) • extChartAt 𝓘(ℝ, E) p (e.symm y)) =
+      G y - Smale.MorsePerturbation.dualEquiv a y
+  rw [hφy, one_smul, ← hGy]
+  congr 2
+  simpa only [extChartAt_coe, Function.comp_apply, modelWithCornersSelf_coe, id_eq] using
+    e.right_inv hyt
+
+private theorem Smale.ManifoldMorse.exists_morse_extension {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [T2Space M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [MeasurableSpace E] [BorelSpace E] (μ : MeasureTheory.Measure E)
+    [MeasureTheory.Measure.IsAddHaarMeasure μ] {p : M} (φ : SmoothBumpFunction 𝓘(ℝ, E) p)
+    {U L K : Set M} (hU : IsOpen U) (hUs : U ⊆ (chartAt E p).source)
+    (hφ : Set.EqOn φ (fun _ => 1) U) (hL : IsCompact L) (hLU : L ⊆ U) {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hK : IsCompact K) (hfK : IsMorseOn E f K) {ε : ℝ}
+    (hε : 0 < ε) :
+    ∃ a : E,
+      ‖a‖ < ε ∧
+        ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ (Smale.ManifoldPerturbation.perturb φ f a) ∧
+          IsMorseOn E (Smale.ManifoldPerturbation.perturb φ f a) (L ∪ K) := by
+  let e := chartAt E p
+  have he : e ∈ IsManifold.maximalAtlas 𝓘(ℝ, E) ∞ M := IsManifold.chart_mem_maximalAtlas p
+  have hLc : IsCompact (e '' L) := hL.image_of_continuousOn (e.continuousOn.mono (hLU.trans hUs))
+  have hLt : e '' L ⊆ e.target := by
+    rintro _ ⟨x, hx, rfl⟩
+    exact e.map_source (hUs (hLU hx))
+  obtain ⟨G, hG, V, hV, hLV, -, hGV⟩ :=
+    LineBundleTransport.exists_smooth_extension_near_closed hLc.isClosed e.open_target hLt
+      (contDiffOn_chartExpression hf he)
+  have hfamily := Smale.ManifoldPerturbation.contMDiff_perturb φ hf
+  let A : Set E := {a | IsMorseOn E (Smale.ManifoldPerturbation.perturb φ f a) K}
+  have hA : IsOpen A := isOpen_isMorseOn (f := Smale.ManifoldPerturbation.perturb φ f) hfamily hK
+  have hA₀ : (0 : E) ∈ A := by simpa [A] using hfK
+  have hd :=
+    Smale.RegularValues.dense_regularValues μ
+      ((Smale.MorsePerturbation.contDiff_coordinateGradient hG).differentiable (by simp))
+  obtain ⟨a, ha, haA, haε⟩ :=
+    hd.exists_mem_open (hA.inter Metric.isOpen_ball) ⟨0, hA₀, Metric.mem_ball_self hε⟩
+  refine ⟨a, mem_ball_zero_iff.mp haε, ?_, ?_⟩
+  · exact hfamily.comp (contMDiff_const.prodMk contMDiff_id)
+  · refine IsMorseOn.union ?_ haA
+    intro x hx
+    apply
+      isMorseAt_of_chart_eventuallyEq he (hUs (hLU hx))
+        (Smale.MorsePerturbation.isMorse_of_regularValue hG ha)
+    exact
+      perturb_inChart_eventuallyEq φ hU hUs hφ hV hGV a (hLU hx) (hLV (Set.mem_image_of_mem e hx))
+
+private theorem
+    Smale.ManifoldMorse.exists_morse_function_of_haar {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [T2Space M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] [MeasurableSpace E] [BorelSpace E]
+    (μ : MeasureTheory.Measure E) [MeasureTheory.Measure.IsAddHaarMeasure μ] :
+    ∃ f : M → ℝ, ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f ∧ IsMorse E f := by
+  classical
+  choose φ U L hU hUs hφ hL hn hLU using exists_compact_plateau (E := E) (M := M)
+  obtain ⟨s, hs⟩ := finite_cover_nhds hn
+  have hfinite :
+    ∀ t : Finset M, ∃ f : M → ℝ, ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f ∧ IsMorseOn E f (⋃ p ∈ t, L p) := by
+    intro t
+    induction t using Finset.induction_on with
+    | empty =>
+      refine ⟨fun _ => 0, contMDiff_const, ?_⟩
+      intro x hx
+      simp at hx
+    | @insert p t hp ih =>
+      obtain ⟨f, hf, hm⟩ := ih
+      have hK : IsCompact (⋃ q ∈ t, L q) := t.isCompact_biUnion (fun q _ => hL q)
+      obtain ⟨a, -, hfa, hma⟩ :=
+        exists_morse_extension μ (φ p) (hU p) (hUs p) (hφ p) (hL p) (hLU p) hf hK hm (ε := 1)
+          zero_lt_one
+      refine ⟨Smale.ManifoldPerturbation.perturb (φ p) f a, hfa, ?_⟩
+      have heq : (⋃ q ∈ Insert.insert p t, L q) = L p ∪ ⋃ q ∈ t, L q := by
+        ext x
+        simp only [Set.mem_iUnion, Finset.mem_insert, Set.mem_union]
+        constructor
+        · rintro ⟨q, hq | hq, hx⟩
+          · subst q
+            exact Or.inl hx
+          · exact Or.inr ⟨q, hq, hx⟩
+        · rintro (hx | ⟨q, hq, hx⟩)
+          · exact ⟨p, Or.inl rfl, hx⟩
+          · exact ⟨q, Or.inr hq, hx⟩
+      rw [heq]
+      exact hma
+  obtain ⟨f, hf, hm⟩ := hfinite s
+  refine ⟨f, hf, fun x => hm x ?_⟩
+  rw [hs]
+  exact Set.mem_univ x
+
+private theorem
+    Smale.ManifoldMorse.exists_morse_function (E : Type*) (M : Type*) [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [T2Space M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] :
+    ∃ f : M → ℝ, ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f ∧ IsMorse E f := by
+  let : MeasurableSpace E := borel E
+  let : BorelSpace E := ⟨rfl⟩
+  exact exists_morse_function_of_haar (E := E) (M := M) MeasureTheory.Measure.addHaar
+
+private theorem SmoothMorseLemma.contDiff_parametric_intervalIntegral_of_le {P F : Type*}
+    [NormedAddCommGroup P] [NormedSpace ℝ P] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (G : P × ℝ → F) (hG : ContDiff ℝ ∞ G) (a b : ℝ) (hab : a ≤ b) :
+    ContDiff ℝ ∞ (fun p => ∫ t in a..b, G (p, t)) := by
+  obtain ⟨χ, hχ, hχc, hχone⟩ := LineBundleTransport.exists_interval_cutoff a b
+  let μ : MeasureTheory.Measure ℝ := MeasureTheory.MeasureSpace.volume.restrict (Set.Ioc a b)
+  let L : ℝ →L[ℝ] F →L[ℝ] F := ContinuousLinearMap.lsmul ℝ ℝ
+  let g : P → ℝ → F := fun p t => χ (-t) • G (p, -t)
+  have hg : ContDiff ℝ ∞ (fun q : P × ℝ => g q.1 q.2) :=
+    (hχ.comp contDiff_snd.neg).smul (hG.comp (contDiff_fst.prodMk contDiff_snd.neg))
+  have hk : IsCompact (-tsupport χ) := hχc.isCompact.neg
+  have hgs : ∀ p t, p ∈ (Set.univ : Set P) → t ∉ -tsupport χ → g p t = 0 := by
+    intro p t _ ht
+    have ht' : -t ∉ tsupport χ := by simpa using ht
+    change χ (-t) • G (p, -t) = 0
+    rw [image_eq_zero_of_notMem_tsupport ht', zero_smul]
+  have hf : MeasureTheory.LocallyIntegrable (fun _ : ℝ => (1 : ℝ)) μ :=
+    MeasureTheory.locallyIntegrable_const _
+  have hc :=
+    MeasureTheory.contDiffOn_convolution_right_with_param_comp (μ := μ) (n := (⊤ : ℕ∞)) L (v :=
+      fun _ : P => (0 : ℝ)) contDiffOn_const isOpen_univ hk hgs hf hg.contDiffOn
+  have heq (p : P) : ((fun _ : ℝ => (1 : ℝ)) ⋆[L, μ] g p) 0 = ∫ t in a..b, G (p, t) := by
+    rw [intervalIntegral.integral_of_le hab]
+    change (∫ t, (1 : ℝ) • (χ (-(0 - t)) • G (p, -(0 - t))) ∂μ) = ∫ t in Set.Ioc a b, G (p, t)
+    apply MeasureTheory.integral_congr_ae
+    filter_upwards [MeasureTheory.ae_restrict_mem measurableSet_Ioc] with t ht
+    have hχt : χ t = 1 := hχone (Set.mem_uIcc_of_le ht.1.le ht.2)
+    simp only [zero_sub, neg_neg, hχt, one_smul]
+  have hfun :
+    (fun p => ((fun _ : ℝ => (1 : ℝ)) ⋆[L, μ] g p) 0) = (fun p => ∫ t in a..b, G (p, t)) :=
+    funext heq
+  rw [← hfun]
+  exact contDiffOn_univ.mp hc
+
+private theorem
+    SmoothMorseLemma.contDiff_parametric_intervalIntegral {P F : Type*} [NormedAddCommGroup P]
+    [NormedSpace ℝ P] [NormedAddCommGroup F] [NormedSpace ℝ F] (G : P × ℝ → F)
+    (hG : ContDiff ℝ ∞ G) (a b : ℝ) : ContDiff ℝ ∞ (fun p => ∫ t in a..b, G (p, t)) := by
+  rcases le_total a b with hab | hba
+  · exact contDiff_parametric_intervalIntegral_of_le G hG a b hab
+  · have he : (fun p => ∫ t in a..b, G (p, t)) = (fun p => -(∫ t in b..a, G (p, t))) :=
+      funext fun _ => intervalIntegral.integral_symm b a
+    rw [he]
+    exact (contDiff_parametric_intervalIntegral_of_le G hG b a hba).neg
+
+private def
+    SmoothMorseLemma.taylorHessianIntegrand {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (f : E → ℝ) (q : E × ℝ) : E →L[ℝ] E →L[ℝ] ℝ :=
+  (1 - q.2) • fderiv ℝ (fderiv ℝ f) (q.2 • q.1)
+
+private def SmoothMorseLemma.secondTaylorFactor {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (f : E → ℝ) (x : E) : E →L[ℝ] E →L[ℝ] ℝ :=
+  (2 : ℝ) • ∫ t in (0 : ℝ)..1, taylorHessianIntegrand f (x, t)
+
+private theorem SmoothMorseLemma.contDiff_taylorHessianIntegrand {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {f : E → ℝ} (hf : ContDiff ℝ ∞ f) :
+    ContDiff ℝ ∞ (taylorHessianIntegrand f) := by
+  let : IsBoundedSMul ℝ (E →L[ℝ] E →L[ℝ] ℝ) := .of_norm_smul_le (fun c B => norm_smul_le c B)
+  have hdf : ContDiff ℝ ∞ (fderiv ℝ f) := (contDiff_infty_iff_fderiv.mp hf).2
+  have hH : ContDiff ℝ ∞ (fderiv ℝ (fderiv ℝ f)) := (contDiff_infty_iff_fderiv.mp hdf).2
+  exact (contDiff_const.sub contDiff_snd).smul (hH.comp (contDiff_snd.smul contDiff_fst))
+
+private theorem SmoothMorseLemma.contDiff_secondTaylorFactor {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {f : E → ℝ} (hf : ContDiff ℝ ∞ f) : ContDiff ℝ ∞ (secondTaylorFactor f) :=
+  (contDiff_parametric_intervalIntegral (taylorHessianIntegrand f)
+        (contDiff_taylorHessianIntegrand hf) 0 1).const_smul
+    (2 : ℝ)
+
+private theorem SmoothMorseLemma.secondTaylorFactor_apply {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {f : E → ℝ} (hf : ContDiff ℝ ∞ f) (x u v : E) :
+    secondTaylorFactor f x u v =
+      2 * ∫ t in (0 : ℝ)..1, (1 - t) * fderiv ℝ (fderiv ℝ f) (t • x) u v := by
+  have hc : Continuous (fun t : ℝ => taylorHessianIntegrand f (x, t)) :=
+    (contDiff_taylorHessianIntegrand hf).continuous.comp (continuous_const.prodMk continuous_id)
+  have hi :
+    IntervalIntegrable (fun t : ℝ => taylorHessianIntegrand f (x, t))
+      MeasureTheory.MeasureSpace.volume 0 1 :=
+    hc.intervalIntegrable 0 1
+  have hiu :
+    IntervalIntegrable (fun t : ℝ => taylorHessianIntegrand f (x, t) u)
+      MeasureTheory.MeasureSpace.volume 0 1 :=
+    (hc.clm_apply continuous_const).intervalIntegrable 0 1
+  simp only [secondTaylorFactor, smul_apply]
+  rw [ContinuousLinearMap.intervalIntegral_apply hi u,
+    ContinuousLinearMap.intervalIntegral_apply hiu v]
+  simp only [taylorHessianIntegrand, smul_apply, smul_eq_mul]
+
+private theorem SmoothMorseLemma.secondTaylorFactor_zero {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (f : E → ℝ) : secondTaylorFactor f 0 = fderiv ℝ (fderiv ℝ f) 0 := by
+  have hw : (∫ t in (0 : ℝ)..1, (1 - t)) = (1 / 2 : ℝ) := by
+    calc
+      (∫ t in (0 : ℝ)..1, (1 - t)) = (∫ _t in (0 : ℝ)..1, (1 : ℝ)) - ∫ t in (0 : ℝ)..1, t :=
+        intervalIntegral.integral_sub (f := fun _ : ℝ => (1 : ℝ)) (g := fun t : ℝ => t)
+          intervalIntegrable_const (continuous_id.intervalIntegrable 0 1)
+      _ = 1 / 2 := by norm_num [integral_id]
+  have hz :
+    (∫ t in (0 : ℝ)..1, (1 - t) • fderiv ℝ (fderiv ℝ f) 0) =
+      (1 / 2 : ℝ) • fderiv ℝ (fderiv ℝ f) 0 :=
+    (intervalIntegral.integral_smul_const (fun t : ℝ => 1 - t) (fderiv ℝ (fderiv ℝ f) 0)).trans
+      (congrArg (fun c : ℝ => c • fderiv ℝ (fderiv ℝ f) 0) hw)
+  simp only [secondTaylorFactor, taylorHessianIntegrand, smul_zero]
+  exact (congrArg (fun B : E →L[ℝ] E →L[ℝ] ℝ => (2 : ℝ) • B) hz).trans (by norm_num [smul_smul])
+
+private theorem SmoothMorseLemma.secondTaylorFactor_symmetric {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {f : E → ℝ} (hf : ContDiff ℝ ∞ f) (x u v : E) :
+    secondTaylorFactor f x u v = secondTaylorFactor f x v u := by
+  rw [secondTaylorFactor_apply hf, secondTaylorFactor_apply hf]
+  apply congrArg (fun r : ℝ => 2 * r)
+  apply intervalIntegral.integral_congr
+  intro t _
+  have hs : IsSymmSndFDerivAt ℝ f (t • x) :=
+    hf.contDiffAt.isSymmSndFDerivAt
+      (by
+        simp only [minSmoothness_of_isRCLikeNormedField]
+        change (↑(2 : ℕ∞) : ℕ∞ω) ≤ ↑(⊤ : ℕ∞)
+        exact WithTop.coe_le_coe.mpr le_top)
+  exact congrArg (fun r : ℝ => (1 - t) * r) (hs u v)
+
+private theorem SmoothMorseLemma.map_eq_add_linear_add_secondTaylorFactor {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] {f : E → ℝ} (hf : ContDiff ℝ ∞ f) (x : E) :
+    f x = f 0 + fderiv ℝ f 0 x + (1 / 2 : ℝ) * secondTaylorFactor f x x x := by
+  have ht :=
+    map_add_eq_sum_add_integral_iteratedFDeriv (f := f) (x := 0) (y := x) (n := 1)
+      (fun t _ => hf.contDiffAt.of_le (ENat.natCast_le_of_coe_top_le_withTop le_rfl 2))
+  have ht' :
+    f x = f 0 + fderiv ℝ f 0 x + ∫ t in (0 : ℝ)..1, (1 - t) * fderiv ℝ (fderiv ℝ f) (t • x) x x :=
+    by simpa [Finset.sum_range_succ, iteratedFDeriv_two_apply, smul_eq_mul] using ht
+  rw [secondTaylorFactor_apply hf]
+  calc
+    f x = f 0 + fderiv ℝ f 0 x + ∫ t in (0 : ℝ)..1, (1 - t) * fderiv ℝ (fderiv ℝ f) (t • x) x x :=
+      ht'
+    _ =
+        f 0 + fderiv ℝ f 0 x +
+          (1 / 2 : ℝ) * (2 * ∫ t in (0 : ℝ)..1, (1 - t) * fderiv ℝ (fderiv ℝ f) (t • x) x x) := by
+      ring
+
+private abbrev SmoothMorseLemma.Bilinear (E : Type*) [NormedAddCommGroup E] [NormedSpace ℝ E] :=
+  E →L[ℝ] E →L[ℝ] ℝ
+
+private def SmoothMorseLemma.symmetricForms (E : Type*) [NormedAddCommGroup E] [NormedSpace ℝ E] :
+    Submodule ℝ (Bilinear E)
+    where
+  carrier := {B | ∀ u v, B u v = B v u}
+  zero_mem' := fun _ _ => rfl
+  add_mem' := by
+    intro B C hB hC u v
+    change B u v + C u v = B v u + C v u
+    rw [hB u v, hC u v]
+  smul_mem' := by
+    intro c B hB u v
+    change c * B u v = c * B v u
+    rw [hB u v]
+
+private abbrev
+    SmoothMorseLemma.SymmetricForm (E : Type*) [NormedAddCommGroup E] [NormedSpace ℝ E] :=
+  symmetricForms E
+
+@[ext]
+private theorem
+    SmoothMorseLemma.symmetricForm_ext (E : Type*) [NormedAddCommGroup E] [NormedSpace ℝ E]
+    {S T : SymmetricForm E} (h : ∀ u v, S.val u v = T.val u v) : S = T :=
+  Subtype.ext (ContinuousLinearMap.ext fun u => ContinuousLinearMap.ext fun v => h u v)
+
+private def SmoothMorseLemma.flipBilinear (E : Type*) [NormedAddCommGroup E] [NormedSpace ℝ E] :
+    Bilinear E →L[ℝ] Bilinear E :=
+  (ContinuousLinearMap.flipₗᵢ ℝ E E ℝ).toContinuousLinearEquiv.toContinuousLinearMap
+
+private def SmoothMorseLemma.symmetrize (E : Type*) [NormedAddCommGroup E] [NormedSpace ℝ E] :
+    Bilinear E →L[ℝ] SymmetricForm E :=
+  (((2 : ℝ)⁻¹) • (ContinuousLinearMap.id ℝ (Bilinear E) + flipBilinear E)).codRestrict
+    (symmetricForms E)
+    (fun B u v => by
+      change (2 : ℝ)⁻¹ * (B u v + B v u) = (2 : ℝ)⁻¹ * (B v u + B u v)
+      ring)
+
+@[simp]
+private theorem
+    SmoothMorseLemma.symmetrize_apply (E : Type*) [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (B : Bilinear E) (u v : E) : (symmetrize E B).val u v = (2 : ℝ)⁻¹ * (B u v + B v u) :=
+  rfl
+
+private def SmoothMorseLemma.congruence {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (B : Bilinear E) (L : E →L[ℝ] E) : Bilinear E :=
+  B.bilinearComp L L
+
+@[simp]
+private theorem
+    SmoothMorseLemma.congruence_apply {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (B : Bilinear E) (L : E →L[ℝ] E) (u v : E) : congruence B L u v = B (L u) (L v) :=
+  rfl
+
+@[simp]
+private theorem
+    SmoothMorseLemma.congruence_zero {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (B : Bilinear E) : congruence B (0 : E →L[ℝ] E) = 0 := by
+  ext u v
+  simp [congruence]
+
+private theorem
+    SmoothMorseLemma.contDiff_congruence {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (B : Bilinear E) : ContDiff ℝ ∞ (congruence B) := by
+  have h₁ : ContDiff ℝ ∞ (fun L : E →L[ℝ] E => B.comp L) := contDiff_const.clm_comp contDiff_id
+  have h₂ : ContDiff ℝ ∞ (fun L : E →L[ℝ] E => (B.comp L).flip) :=
+    (flipBilinear E).contDiff.comp h₁
+  exact (flipBilinear E).contDiff.comp (h₂.clm_comp contDiff_id)
+
+private def SmoothMorseLemma.raiseIndex {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (H : E ≃L[ℝ] (E →L[ℝ] ℝ)) : Bilinear E →L[ℝ] (E →L[ℝ] E) :=
+  ContinuousLinearMap.compL ℝ E (E →L[ℝ] ℝ) E H.symm.toContinuousLinearMap
+
+private def
+    SmoothMorseLemma.symmetricTaylorFactor {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (f : E → ℝ) (x : E) : SymmetricForm E :=
+  symmetrize E (secondTaylorFactor f x)
+
+private theorem SmoothMorseLemma.contDiff_symmetricTaylorFactor {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {f : E → ℝ} (hf : ContDiff ℝ ∞ f) :
+    ContDiff ℝ ∞ (symmetricTaylorFactor f) :=
+  (symmetrize E).contDiff.comp (contDiff_secondTaylorFactor hf)
+
+private theorem SmoothMorseLemma.symmetricTaylorFactor_coe {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {f : E → ℝ} (hf : ContDiff ℝ ∞ f) (x : E) :
+    (symmetricTaylorFactor f x).val = secondTaylorFactor f x := by
+  ext u v
+  change
+    (2 : ℝ)⁻¹ * (secondTaylorFactor f x u v + secondTaylorFactor f x v u) =
+      secondTaylorFactor f x u v
+  rw [secondTaylorFactor_symmetric hf x v u]
+  ring
+
+private theorem SmoothMorseLemma.symmetricTaylorFactor_zero {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {f : E → ℝ} (hf : ContDiff ℝ ∞ f) :
+    (symmetricTaylorFactor f 0).val = fderiv ℝ (fderiv ℝ f) 0 := by
+  rw [symmetricTaylorFactor_coe hf, secondTaylorFactor_zero]
+
+private theorem SmoothMorseLemma.map_eq_add_symmetricTaylorFactor {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {f : E → ℝ} (hf : ContDiff ℝ ∞ f) (hc : fderiv ℝ f 0 = 0) (x : E) :
+    f x = f 0 + (1 / 2 : ℝ) * (symmetricTaylorFactor f x).val x x := by
+  rw [symmetricTaylorFactor_coe hf]
+  simpa only [hc, zero_apply, add_zero] using map_eq_add_linear_add_secondTaylorFactor hf x
+
+private theorem SmoothMorseLemma.exists_partialDiffeomorph_of_contDiffOn {E F : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [CompleteSpace E] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {U : Set E} (hU : IsOpen U) {f : E → F} (hf : ContDiffOn ℝ ∞ f U) (a : E)
+    (ha : a ∈ U) (f' : E ≃L[ℝ] F) (hderiv : HasFDerivAt f (f' : E →L[ℝ] F) a) :
+    ∃ e : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, F) E F ∞,
+      a ∈ e.source ∧ e.source ⊆ U ∧ ∀ x : E, e x = f x := by
+  have hfa : ContDiffAt ℝ ∞ f a := hf.contDiffAt (hU.mem_nhds ha)
+  have hdc : ContinuousAt (fderiv ℝ f) a :=
+    (hf.continuousOn_fderiv_of_isOpen hU (by simp)).continuousAt (hU.mem_nhds ha)
+  have hinv : {x : E | ∃ l : E ≃L[ℝ] F, (l : E →L[ℝ] F) = fderiv ℝ f x} ∈ 𝓝 a := by
+    have hn := f'.nhds
+    rw [← hderiv.fderiv] at hn
+    exact hdc.preimage_mem_nhds hn
+  obtain ⟨W, hWsub, hWopen, haW⟩ := mem_nhds_iff.mp (Filter.inter_mem (hU.mem_nhds ha) hinv)
+  let e : OpenPartialHomeomorph E F := (hfa.toOpenPartialHomeomorph f hderiv (by simp)).restr W
+  have heW : e.source ⊆ W := by
+    intro x hx
+    change x ∈ ((hfa.toOpenPartialHomeomorph f hderiv (by simp)).restr W).source at hx
+    rw [OpenPartialHomeomorph.restr_source' _ _ hWopen] at hx
+    exact hx.2
+  have heU : e.source ⊆ U := fun x hx => (hWsub (heW hx)).1
+  have hae : a ∈ e.source := by
+    change a ∈ ((hfa.toOpenPartialHomeomorph f hderiv (by simp)).restr W).source
+    rw [OpenPartialHomeomorph.restr_source' _ _ hWopen]
+    exact ⟨hfa.mem_toOpenPartialHomeomorph_source hderiv (by simp), haW⟩
+  refine
+    ⟨{  toPartialEquiv := e.toPartialEquiv
+        open_source := e.open_source
+        open_target := e.open_target
+        contMDiffOn_toFun := ?_
+        contMDiffOn_invFun := ?_ }, hae, heU, fun _ => rfl⟩
+  · change ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, F) ∞ f e.source
+    exact (hf.mono heU).contMDiffOn
+  · apply ContDiffOn.contMDiffOn
+    intro y hy
+    have hxW := heW (e.map_target hy)
+    obtain ⟨hxU, l, hl⟩ := hWsub hxW
+    have hfx : ContDiffAt ℝ ∞ f (e.symm y) := hf.contDiffAt (hU.mem_nhds hxU)
+    have hdx : HasFDerivAt f (l : E →L[ℝ] F) (e.symm y) := by
+      rw [hl]
+      exact (hfx.differentiableAt (by simp)).hasFDerivAt
+    exact (e.contDiffAt_symm hy hdx hfx).contDiffWithinAt
+
+private theorem SmoothMorseLemma.exists_partialDiffeomorph_of_contDiff {E F : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [CompleteSpace E] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {f : E → F} (hf : ContDiff ℝ ∞ f) (a : E) (f' : E ≃L[ℝ] F)
+    (hderiv : HasFDerivAt f (f' : E →L[ℝ] F) a) :
+    ∃ e : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, F) E F ∞, a ∈ e.source ∧ ∀ x : E, e x = f x := by
+  obtain ⟨e, ha, _, he⟩ :=
+    exists_partialDiffeomorph_of_contDiffOn isOpen_univ hf.contDiffOn a (Set.mem_univ a) f' hderiv
+  exact ⟨e, ha, he⟩
+
+private theorem SmoothMorseLemma.exists_quadratic_chart_of_smooth_congruence {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [CompleteSpace E] (f : E → ℝ)
+    (A : E → SymmetricForm E) (hA : ContDiff ℝ ∞ A) (H : SymmetricForm E) (hA0 : A 0 = H)
+    (hfactor : ∀ x, f x = f 0 + (1 / 2 : ℝ) * (A x).val x x) (V : Set (SymmetricForm E))
+    (hV : IsOpen V) (hHV : H ∈ V) (L : SymmetricForm E → E →L[ℝ] E) (hL : ContDiffOn ℝ ∞ L V)
+    (hL0 : L H = ContinuousLinearMap.id ℝ E) (hcong : ∀ B ∈ V, congruence H.val (L B) = B.val) :
+    ∃ e : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞,
+      (0 : E) ∈ e.source ∧
+        e 0 = 0 ∧
+          HasFDerivAt e (ContinuousLinearMap.id ℝ E) 0 ∧
+            (∀ x ∈ e.source, f x = f 0 + (1 / 2 : ℝ) * H.val (e x) (e x)) ∧
+              (∀ y ∈ e.target, f (e.symm y) = f 0 + (1 / 2 : ℝ) * H.val y y) := by
+  let U : Set E := A ⁻¹' V
+  have hU : IsOpen U := hV.preimage hA.continuous
+  have h0 : (0 : E) ∈ U := by
+    change A 0 ∈ V
+    rw [hA0]
+    exact hHV
+  have hLA : ContDiffOn ℝ ∞ (fun x => L (A x)) U := hL.comp hA.contDiffOn (fun _ hx => hx)
+  let φ : E → E := fun x => L (A x) x
+  have hφ : ContDiffOn ℝ ∞ φ U := hLA.clm_apply contDiffOn_id
+  have hLA0 : L (A 0) = ContinuousLinearMap.id ℝ E := by rw [hA0, hL0]
+  have hd : HasFDerivAt φ (ContinuousLinearMap.id ℝ E) 0 := by
+    have h := ((hLA.contDiffAt (hU.mem_nhds h0)).differentiableAt (by simp)).hasFDerivAt
+    simpa only [id_eq, hLA0, ContinuousLinearMap.comp_id, map_zero, add_zero] using
+      h.clm_apply (hasFDerivAt_id (0 : E))
+  obtain ⟨e, he0, heU, he⟩ :=
+    exists_partialDiffeomorph_of_contDiffOn hU hφ 0 h0 (ContinuousLinearEquiv.refl ℝ E) hd
+  have heφ : (e : E → E) = φ := funext he
+  have hezero : e 0 = 0 := by
+    rw [he]
+    exact map_zero (L (A 0))
+  have hnormal (x : E) (hx : x ∈ e.source) : f x = f 0 + (1 / 2 : ℝ) * H.val (e x) (e x) := by
+    have hquad := congrArg (fun B : Bilinear E => B x x) (hcong (A x) (heU hx))
+    change H.val (L (A x) x) (L (A x) x) = (A x).val x x at hquad
+    rw [he]
+    change f x = f 0 + (1 / 2 : ℝ) * H.val (L (A x) x) (L (A x) x)
+    rw [hquad]
+    exact hfactor x
+  refine ⟨e, he0, hezero, ?_, hnormal, ?_⟩
+  · rw [heφ]
+    exact hd
+  · intro y hy
+    have hr : e (e.symm y) = y := e.right_inv hy
+    simpa only [hr] using hnormal (e.symm y) (e.map_target hy)
+
+private def
+    SmoothMorseLemma.raiseSymmetricIndex {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (H : E ≃L[ℝ] (E →L[ℝ] ℝ)) : SymmetricForm E →L[ℝ] (E →L[ℝ] E) :=
+  (raiseIndex H).comp (symmetricForms E).subtypeL
+
+@[simp]
+private theorem SmoothMorseLemma.raiseSymmetricIndex_apply {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (H : E ≃L[ℝ] (E →L[ℝ] ℝ)) (S : SymmetricForm E) (u : E) :
+    raiseSymmetricIndex H S u = H.symm (S.val u) :=
+  rfl
+
+private theorem SmoothMorseLemma.hasFDerivAt_congruence_zero {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (B : Bilinear E) :
+    HasFDerivAt (congruence B) (0 : (E →L[ℝ] E) →L[ℝ] Bilinear E) 0 := by
+  have h₁ := (hasFDerivAt_const B (0 : E →L[ℝ] E)).clm_comp (hasFDerivAt_id (0 : E →L[ℝ] E))
+  have h₂ := (flipBilinear E).hasFDerivAt.comp 0 h₁
+  have h₃ := h₂.clm_comp (hasFDerivAt_id (0 : E →L[ℝ] E))
+  have h₄ := (flipBilinear E).hasFDerivAt.comp 0 h₃
+  convert h₄ using 1 <;>
+    first
+    | rfl
+    | simp
+
+private def
+    SmoothMorseLemma.congruencePolynomial {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (H : E ≃L[ℝ] (E →L[ℝ] ℝ)) (S : SymmetricForm E) : SymmetricForm E :=
+  (2 : ℝ) • S + symmetrize E (congruence H.toContinuousLinearMap (raiseSymmetricIndex H S))
+
+@[simp]
+private theorem SmoothMorseLemma.congruencePolynomial_zero {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (H : E ≃L[ℝ] (E →L[ℝ] ℝ)) : congruencePolynomial H 0 = 0 := by
+  simp [congruencePolynomial]
+
+private theorem SmoothMorseLemma.contDiff_congruencePolynomial {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (H : E ≃L[ℝ] (E →L[ℝ] ℝ)) : ContDiff ℝ ∞ (congruencePolynomial H) :=
+  (contDiff_id.const_smul (2 : ℝ)).add
+    ((symmetrize E).contDiff.comp
+      ((contDiff_congruence H.toContinuousLinearMap).comp (raiseSymmetricIndex H).contDiff))
+
+private theorem
+    SmoothMorseLemma.hasFDerivAt_congruencePolynomial_zero {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (H : E ≃L[ℝ] (E →L[ℝ] ℝ)) :
+    HasFDerivAt (congruencePolynomial H) ((2 : ℝ) • ContinuousLinearMap.id ℝ (SymmetricForm E))
+      0 := by
+  have hc :
+    HasFDerivAt (congruence H.toContinuousLinearMap) (0 : (E →L[ℝ] E) →L[ℝ] Bilinear E)
+      (raiseSymmetricIndex H (0 : SymmetricForm E)) := by
+    simpa only [map_zero] using hasFDerivAt_congruence_zero H.toContinuousLinearMap
+  have hq := hc.comp (0 : SymmetricForm E) (raiseSymmetricIndex H).hasFDerivAt
+  have hs := (symmetrize E).hasFDerivAt.comp (0 : SymmetricForm E) hq
+  have h := ((hasFDerivAt_id (0 : SymmetricForm E)).const_smul (2 : ℝ)).add hs
+  convert h using 1 <;>
+    first
+    | rfl
+    | simp
+
+private def
+    SmoothMorseLemma.referenceSymmetricForm {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (H : E ≃L[ℝ] (E →L[ℝ] ℝ)) (hH : ∀ u v, H u v = H v u) : SymmetricForm E :=
+  ⟨H.toContinuousLinearMap, hH⟩
+
+@[simp]
+private theorem SmoothMorseLemma.referenceSymmetricForm_apply {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (H : E ≃L[ℝ] (E →L[ℝ] ℝ)) (hH : ∀ u v, H u v = H v u) (u v : E) :
+    (referenceSymmetricForm H hH).val u v = H u v :=
+  rfl
+
+private theorem
+    SmoothMorseLemma.congruencePolynomial_add_reference {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (H : E ≃L[ℝ] (E →L[ℝ] ℝ)) (hH : ∀ u v, H u v = H v u)
+    (S : SymmetricForm E) :
+    (congruencePolynomial H S + referenceSymmetricForm H hH).val =
+      congruence H.toContinuousLinearMap (ContinuousLinearMap.id ℝ E + raiseSymmetricIndex H S) :=
+  by
+  ext u v
+  have hcross : H u (H.symm (S.val v)) = S.val u v := by
+    rw [hH, H.apply_symm_apply, S.property v u]
+  have hquad :
+    H (H.symm (S.val v)) (H.symm (S.val u)) = H (H.symm (S.val u)) (H.symm (S.val v)) := hH _ _
+  have hquad' : S.val v (H.symm (S.val u)) = S.val u (H.symm (S.val v)) := by
+    simpa only [H.apply_symm_apply] using hquad
+  simp only [congruencePolynomial, Submodule.coe_add, Submodule.coe_smul, add_apply, smul_apply,
+    smul_eq_mul, symmetrize_apply, congruence_apply, raiseSymmetricIndex_apply,
+    referenceSymmetricForm_apply, ContinuousLinearMap.id_apply, ContinuousLinearEquiv.coe_coe,
+    map_add, hcross, H.apply_symm_apply, hquad']
+  ring
+
+private def
+    SmoothMorseLemma.congruenceDoubleEquiv (E : Type*) [NormedAddCommGroup E] [NormedSpace ℝ E] :
+    SymmetricForm E ≃L[ℝ] SymmetricForm E :=
+  ContinuousLinearEquiv.smulLeft (R₁ := ℝ) (M₁ := SymmetricForm E)
+    (Units.mk0 (2 : ℝ) (by norm_num))
+
+private theorem SmoothMorseLemma.congruenceDoubleEquiv_toContinuousLinearMap {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] :
+    (congruenceDoubleEquiv E).toContinuousLinearMap =
+      (2 : ℝ) • ContinuousLinearMap.id ℝ (SymmetricForm E) := by
+  ext S
+  rfl
+
+private theorem SmoothMorseLemma.exists_congruencePolynomial_partialDiffeomorph {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] (H : E ≃L[ℝ] (E →L[ℝ] ℝ)) :
+    ∃ e :
+      PartialDiffeomorph 𝓘(ℝ, SymmetricForm E) 𝓘(ℝ, SymmetricForm E) (SymmetricForm E)
+        (SymmetricForm E) ∞,
+      (0 : SymmetricForm E) ∈ e.source ∧ ∀ S, e S = congruencePolynomial H S := by
+  apply
+    exists_partialDiffeomorph_of_contDiff (contDiff_congruencePolynomial H) 0
+      (congruenceDoubleEquiv E)
+  rw [congruenceDoubleEquiv_toContinuousLinearMap]
+  exact hasFDerivAt_congruencePolynomial_zero H
+
+private theorem SmoothMorseLemma.exists_smooth_congruence_factor {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] (H : E ≃L[ℝ] (E →L[ℝ] ℝ))
+    (hH : ∀ u v, H u v = H v u) :
+    ∃ U : Set (SymmetricForm E),
+      IsOpen U ∧
+        referenceSymmetricForm H hH ∈ U ∧
+          ∃ L : SymmetricForm E → (E →L[ℝ] E),
+            ContDiffOn ℝ ∞ L U ∧
+              L (referenceSymmetricForm H hH) = ContinuousLinearMap.id ℝ E ∧
+                ∀ A ∈ U, congruence H.toContinuousLinearMap (L A) = A.val := by
+  obtain ⟨e, he0, he⟩ := exists_congruencePolynomial_partialDiffeomorph H
+  have he_zero : e (0 : SymmetricForm E) = 0 := by rw [he, congruencePolynomial_zero]
+  have hzero_target : (0 : SymmetricForm E) ∈ e.target := by
+    simpa only [he_zero] using e.toPartialEquiv.map_source he0
+  have he_symm_zero : e.invFun (0 : SymmetricForm E) = 0 := by
+    have h := e.toPartialEquiv.left_inv he0
+    change e.invFun (e.toFun 0) = 0 at h
+    change e.toFun 0 = 0 at he_zero
+    rwa [he_zero] at h
+  let U : Set (SymmetricForm E) := (fun A => A - referenceSymmetricForm H hH) ⁻¹' e.target
+  let L : SymmetricForm E → (E →L[ℝ] E) := fun A =>
+    ContinuousLinearMap.id ℝ E +
+      raiseSymmetricIndex H (e.invFun (A - referenceSymmetricForm H hH))
+  have hU : IsOpen U := e.open_target.preimage (continuous_id.sub continuous_const)
+  have hHU : referenceSymmetricForm H hH ∈ U := by
+    simpa only [U, Set.mem_preimage, sub_self] using hzero_target
+  have hinv : ContDiffOn ℝ ∞ (fun A => e.invFun (A - referenceSymmetricForm H hH)) U :=
+    e.contMDiffOn_invFun.contDiffOn.comp (contDiff_id.sub contDiff_const).contDiffOn
+      (fun _ hA => hA)
+  refine ⟨U, hU, hHU, L, ?_, ?_, ?_⟩
+  · exact contDiffOn_const.add ((raiseSymmetricIndex H).contDiff.comp_contDiffOn hinv)
+  · simp only [L, sub_self, he_symm_zero, map_zero, add_zero]
+  · intro A hA
+    have hq :
+      congruencePolynomial H (e.invFun (A - referenceSymmetricForm H hH)) =
+        A - referenceSymmetricForm H hH := by
+      rw [← he]
+      exact e.toPartialEquiv.right_inv hA
+    change
+      congruence H.toContinuousLinearMap
+          (ContinuousLinearMap.id ℝ E +
+            raiseSymmetricIndex H (e.invFun (A - referenceSymmetricForm H hH))) =
+        A.val
+    rw [← congruencePolynomial_add_reference H hH, hq, sub_add_cancel]
+
+private def SmoothMorseLemma.hessianEquiv {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] (f : E → ℝ) (a : E)
+    (hn : Function.Bijective (fderiv ℝ (fderiv ℝ f) a)) : E ≃L[ℝ] (E →L[ℝ] ℝ) :=
+  (LinearEquiv.ofBijective (fderiv ℝ (fderiv ℝ f) a).toLinearMap hn).toContinuousLinearEquiv
+
+private theorem SmoothMorseLemma.exists_morse_chart_zero {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {f : E → ℝ} (hf : ContDiff ℝ ∞ f)
+    (hc : fderiv ℝ f 0 = 0) (hn : Function.Bijective (fderiv ℝ (fderiv ℝ f) 0)) :
+    ∃ e : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞,
+      (0 : E) ∈ e.source ∧
+        e 0 = 0 ∧
+          HasFDerivAt e (ContinuousLinearMap.id ℝ E) 0 ∧
+            (∀ x ∈ e.source, f x = f 0 + (1 / 2 : ℝ) * fderiv ℝ (fderiv ℝ f) 0 (e x) (e x)) ∧
+              (∀ y ∈ e.target, f (e.symm y) = f 0 + (1 / 2 : ℝ) * fderiv ℝ (fderiv ℝ f) 0 y y) := by
+  let H := hessianEquiv f 0 hn
+  have hH : ∀ u v, H u v = H v u := by
+    intro u v
+    have hs := (symmetricTaylorFactor f 0).property u v
+    rw [symmetricTaylorFactor_zero hf] at hs
+    exact hs
+  obtain ⟨V, hV, hHV, L, hL, hL0, hcong⟩ := exists_smooth_congruence_factor H hH
+  have hA0 : symmetricTaylorFactor f 0 = referenceSymmetricForm H hH := by
+    apply Subtype.ext
+    exact symmetricTaylorFactor_zero hf
+  obtain ⟨e, he0, hezero, hederiv, hnormal, hinverse⟩ :=
+    exists_quadratic_chart_of_smooth_congruence f (symmetricTaylorFactor f)
+      (contDiff_symmetricTaylorFactor hf) (referenceSymmetricForm H hH) hA0
+      (map_eq_add_symmetricTaylorFactor hf hc) V hV hHV L hL hL0 hcong
+  exact ⟨e, he0, hezero, hederiv, hnormal, hinverse⟩
+
+private theorem SmoothMorseLemma.exists_contDiff_compactlySupported_eqOn_closedBall {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] {f : E → ℝ} {U : Set E}
+    {a : E} (hf : ContDiffOn ℝ ∞ f U) (hU : IsOpen U) (ha : a ∈ U) :
+    ∃ g : E → ℝ,
+      ContDiff ℝ ∞ g ∧
+        HasCompactSupport g ∧
+          tsupport g ⊆ U ∧
+            ∃ r : ℝ, 0 < r ∧ Metric.closedBall a r ⊆ U ∧ Set.EqOn g f (Metric.closedBall a r) := by
+  obtain ⟨r, hr, hrU⟩ : ∃ r : ℝ, 0 < r ∧ Metric.closedBall a r ⊆ U :=
+    Metric.nhds_basis_closedBall.mem_iff.mp (hU.mem_nhds ha)
+  let β : ContDiffBump a :=
+    { rIn := r / 2
+      rOut := r
+      rIn_pos := half_pos hr
+      rIn_lt_rOut := half_lt_self hr }
+  have hβU : tsupport (β : E → ℝ) ⊆ U := by
+    rw [β.tsupport_eq]
+    exact hrU
+  have hg : ContDiff ℝ ∞ (fun x => β x * f x) := by
+    apply contDiff_iff_contDiffAt.mpr
+    intro x
+    by_cases hx : x ∈ tsupport (β : E → ℝ)
+    · exact β.contDiffAt.mul (hf.contDiffAt (hU.mem_nhds (hβU hx)))
+    · have hzero : (β : E → ℝ) =ᶠ[𝓝 x] 0 := notMem_tsupport_iff_eventuallyEq.mp hx
+      have hconst : ContDiffAt ℝ ∞ (fun _ : E => (0 : ℝ)) x := contDiffAt_const
+      apply hconst.congr_of_eventuallyEq
+      filter_upwards [hzero] with y hy
+      simp only [hy, Pi.zero_apply, MulZeroClass.zero_mul]
+  refine
+    ⟨fun x => β x * f x, hg, β.hasCompactSupport.mul_right, tsupport_mul_subset_left.trans hβU,
+      β.rIn, β.rIn_pos, ?_, ?_⟩
+  · exact (Metric.closedBall_subset_closedBall β.rIn_lt_rOut.le).trans hrU
+  · intro x hx
+    change β x * f x = f x
+    rw [β.one_of_mem_closedBall hx, one_mul]
+
+private theorem SmoothMorseLemma.exists_contDiff_extension {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {f : E → ℝ} {U : Set E} {a : E}
+    (hf : ContDiffOn ℝ ∞ f U) (hU : IsOpen U) (ha : a ∈ U) :
+    ∃ g : E → ℝ, ContDiff ℝ ∞ g ∧ g =ᶠ[𝓝 a] f := by
+  obtain ⟨g, hg, _, _, r, hr, _, he⟩ :=
+    exists_contDiff_compactlySupported_eqOn_closedBall hf hU ha
+  refine ⟨g, hg, ?_⟩
+  filter_upwards [Metric.ball_mem_nhds a hr] with x hx
+  exact he (Metric.ball_subset_closedBall hx)
+
+private theorem SmoothMorseLemma.exists_contDiff_extension_preserving_derivatives {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] {f : E → ℝ} {U : Set E}
+    {a : E} (hf : ContDiffOn ℝ ∞ f U) (hU : IsOpen U) (ha : a ∈ U) :
+    ∃ g : E → ℝ,
+      ContDiff ℝ ∞ g ∧
+        g =ᶠ[𝓝 a] f ∧
+          g a = f a ∧
+            fderiv ℝ g a = fderiv ℝ f a ∧
+              fderiv ℝ (fderiv ℝ g) a = fderiv ℝ (fderiv ℝ f) a ∧
+                ∀ n : ℕ, iteratedFDeriv ℝ n g =ᶠ[𝓝 a] iteratedFDeriv ℝ n f := by
+  obtain ⟨g, hg, he⟩ := exists_contDiff_extension hf hU ha
+  exact
+    ⟨g, hg, he, he.self_of_nhds, he.fderiv_eq, he.fderiv.fderiv_eq, fun n =>
+      he.iteratedFDeriv ℝ n⟩
+
+private def SmoothMorseLemma.restrictChart {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (e : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, F) E F ∞)
+    (U : Set E) (hU : IsOpen U) : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, F) E F ∞
+    where
+  __ := e.toOpenPartialHomeomorph.restrOpen U hU
+  contMDiffOn_toFun := e.contMDiffOn_toFun.mono Set.inter_subset_left
+  contMDiffOn_invFun := e.contMDiffOn_invFun.mono Set.inter_subset_left
+
+@[simp]
+private theorem SmoothMorseLemma.restrictChart_apply {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (e : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, F) E F ∞) (U : Set E) (hU : IsOpen U) (x : E) :
+    restrictChart e U hU x = e x :=
+  rfl
+
+private def SmoothMorseLemma.translationToZero {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (a : E) : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞
+    where
+  toFun x := x - a
+  invFun x := a + x
+  left_inv x := by simp [sub_eq_add_neg]
+  right_inv x := by simp [sub_eq_add_neg, add_assoc]
+  contMDiff_toFun :=
+    (show ContDiff ℝ ∞ (fun x : E => x - a) from contDiff_id.sub contDiff_const).contMDiff
+  contMDiff_invFun :=
+    (show ContDiff ℝ ∞ (fun x : E => a + x) from contDiff_const.add contDiff_id).contMDiff
+
+private def SmoothMorseLemma.translateChart {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (a : E)
+    (e : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, F) E F ∞) : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, F) E F ∞ :=
+  (translationToZero a).toPartialDiffeomorph.trans e
+
+@[simp]
+private theorem SmoothMorseLemma.translateChart_apply {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] (a : E)
+    (e : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, F) E F ∞) (x : E) : translateChart a e x = e (x - a) :=
+  rfl
+
+@[simp]
+private theorem SmoothMorseLemma.mem_translateChart_source {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] (a : E)
+    (e : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, F) E F ∞) (x : E) :
+    x ∈ (translateChart a e).source ↔ x - a ∈ e.source := by
+  change (x ∈ Set.univ ∧ x - a ∈ e.source) ↔ x - a ∈ e.source
+  simp only [Set.mem_univ, true_and]
+
+private theorem SmoothMorseLemma.hessian_comp_add_left {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (f : E → ℝ) (a x : E) :
+    fderiv ℝ (fderiv ℝ (fun y => f (a + y))) x = fderiv ℝ (fderiv ℝ f) (a + x) := by
+  have h : fderiv ℝ (fun y => f (a + y)) = fun y => fderiv ℝ f (a + y) :=
+    funext fun y => fderiv_comp_add_left a
+  rw [h, fderiv_comp_add_left]
+
+private theorem
+    SmoothMorseLemma.exists_morse_chart {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] {f : E → ℝ} (hf : ContDiff ℝ ∞ f) (a : E) (hc : fderiv ℝ f a = 0)
+    (hn : Function.Bijective (fderiv ℝ (fderiv ℝ f) a)) :
+    ∃ e : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞,
+      a ∈ e.source ∧
+        e a = 0 ∧
+          HasFDerivAt e (ContinuousLinearMap.id ℝ E) a ∧
+            (∀ x ∈ e.source, f x = f a + (1 / 2 : ℝ) * fderiv ℝ (fderiv ℝ f) a (e x) (e x)) ∧
+              (∀ y ∈ e.target, f (e.symm y) = f a + (1 / 2 : ℝ) * fderiv ℝ (fderiv ℝ f) a y y) := by
+  let g : E → ℝ := fun x => f (a + x)
+  have hg : ContDiff ℝ ∞ g := hf.comp (contDiff_const.add contDiff_id)
+  have hgc : fderiv ℝ g 0 = 0 := by simpa only [g, fderiv_comp_add_left, add_zero] using hc
+  have hgn : Function.Bijective (fderiv ℝ (fderiv ℝ g) 0) := by
+    simpa only [g, hessian_comp_add_left, add_zero] using hn
+  obtain ⟨e, he0, hezero, hederiv, hnormal, _⟩ := exists_morse_chart_zero hg hgc hgn
+  let φ := translateChart a e
+  have haφ : a ∈ φ.source := by
+    change a ∈ (translateChart a e).source
+    rw [mem_translateChart_source, sub_self]
+    exact he0
+  have hφzero : φ a = 0 := by
+    change e (a - a) = 0
+    rw [sub_self, hezero]
+  have hφderiv : HasFDerivAt φ (ContinuousLinearMap.id ℝ E) a := by
+    have hφfun : (φ : E → E) = fun x => e (x - a) := funext (translateChart_apply a e)
+    rw [hφfun]
+    have hdshift : HasFDerivAt (fun x : E => x - a) (ContinuousLinearMap.id ℝ E) a :=
+      (hasFDerivAt_id a).sub_const a
+    have hdouter : HasFDerivAt e (ContinuousLinearMap.id ℝ E) (a - a) := by
+      simpa only [sub_self] using hederiv
+    simpa only [Function.comp_def, ContinuousLinearMap.comp_id] using
+      hdouter.comp (f := fun x : E => x - a) a hdshift
+  have hφnormal (x : E) (hx : x ∈ φ.source) :
+    f x = f a + (1 / 2 : ℝ) * fderiv ℝ (fderiv ℝ f) a (φ x) (φ x) := by
+    have hx' : x - a ∈ e.source := (mem_translateChart_source a e x).mp hx
+    have hpoint : a + (x - a) = x := by simp [sub_eq_add_neg]
+    simpa only [g, hessian_comp_add_left, add_zero, hpoint, φ, translateChart_apply] using
+      hnormal (x - a) hx'
+  refine ⟨φ, haφ, hφzero, hφderiv, hφnormal, ?_⟩
+  intro y hy
+  have hr : φ (φ.symm y) = y := φ.right_inv hy
+  simpa only [hr] using hφnormal (φ.symm y) (φ.map_target hy)
+
+private theorem SmoothMorseLemma.exists_morse_chart_of_contDiffOn {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {f : E → ℝ} {U : Set E} (hf : ContDiffOn ℝ ∞ f U)
+    (hU : IsOpen U) (a : E) (ha : a ∈ U) (hc : fderiv ℝ f a = 0)
+    (hn : Function.Bijective (fderiv ℝ (fderiv ℝ f) a)) :
+    ∃ e : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞,
+      a ∈ e.source ∧
+        e.source ⊆ U ∧
+          e a = 0 ∧
+            HasFDerivAt e (ContinuousLinearMap.id ℝ E) a ∧
+              (∀ x ∈ e.source, f x = f a + (1 / 2 : ℝ) * fderiv ℝ (fderiv ℝ f) a (e x) (e x)) ∧
+                (∀ y ∈ e.target,
+                  f (e.symm y) = f a + (1 / 2 : ℝ) * fderiv ℝ (fderiv ℝ f) a y y) := by
+  obtain ⟨g, hg, heq, hga, hdf, hH, _⟩ :=
+    exists_contDiff_extension_preserving_derivatives hf hU ha
+  have hgc : fderiv ℝ g a = 0 := hdf.trans hc
+  have hgn : Function.Bijective (fderiv ℝ (fderiv ℝ g) a) := by
+    rw [hH]
+    exact hn
+  obtain ⟨e, hea, hezero, hederiv, hnormal, _⟩ := exists_morse_chart hg a hgc hgn
+  obtain ⟨W, hWsub, hWopen, haW⟩ := mem_nhds_iff.mp (Filter.inter_mem (hU.mem_nhds ha) heq)
+  let φ := restrictChart e W hWopen
+  have haφ : a ∈ φ.source := ⟨hea, haW⟩
+  have hφU : φ.source ⊆ U := fun _ hx => (hWsub hx.2).1
+  have hφnormal (x : E) (hx : x ∈ φ.source) :
+    f x = f a + (1 / 2 : ℝ) * fderiv ℝ (fderiv ℝ f) a (φ x) (φ x) := by
+    have hxeq : g x = f x := (hWsub hx.2).2
+    simpa only [φ, restrictChart_apply, hxeq, hga, hH] using hnormal x hx.1
+  refine ⟨φ, haφ, hφU, hezero, hederiv, hφnormal, ?_⟩
+  intro y hy
+  have hr : φ (φ.symm y) = y := φ.right_inv hy
+  simpa only [hr] using hφnormal (φ.symm y) (φ.map_target hy)
+
+private def
+    SmoothMorseLemma.halfHessianQuadratic {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (H : Bilinear E) : QuadraticForm ℝ E :=
+  LinearMap.BilinMap.toQuadraticMap ((1 / 2 : ℝ) • H.toLinearMap₁₂)
+
+@[simp]
+private theorem SmoothMorseLemma.halfHessianQuadratic_apply {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (H : Bilinear E) (x : E) : halfHessianQuadratic H x = (1 / 2 : ℝ) * H x x :=
+  rfl
+
+private theorem SmoothMorseLemma.halfHessianQuadratic_associated {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (H : Bilinear E) (hH : ∀ x y, H x y = H y x) :
+    QuadraticMap.associated (halfHessianQuadratic H) = (1 / 2 : ℝ) • H.toLinearMap₁₂ := by
+  apply QuadraticMap.associated_left_inverse ℝ (B₁ := (1 / 2 : ℝ) • H.toLinearMap₁₂)
+  intro x y
+  change (1 / 2 : ℝ) * H x y = (1 / 2 : ℝ) * H y x
+  rw [hH]
+
+private theorem
+    SmoothMorseLemma.halfHessianQuadratic_separatingLeft {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (H : Bilinear E) (hH : ∀ x y, H x y = H y x)
+    (hHinj : Function.Injective H) :
+    (QuadraticMap.associated (halfHessianQuadratic H)).SeparatingLeft := by
+  rw [halfHessianQuadratic_associated H hH]
+  intro x hx
+  apply hHinj
+  ext y
+  have hxy := hx y
+  change (1 / 2 : ℝ) * H x y = 0 at hxy
+  simpa using (mul_eq_zero.mp hxy).resolve_left (by norm_num)
+
+private theorem SmoothMorseLemma.exists_signed_coordinates {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] (H : Bilinear E) (hH : ∀ x y, H x y = H y x)
+    (hHbij : Function.Bijective H) :
+    ∃ w : Fin (Module.finrank ℝ E) → ℝ,
+      (∀ i, w i = -1 ∨ w i = 1) ∧
+        ∃ C : E ≃L[ℝ] (Fin (Module.finrank ℝ E) → ℝ),
+          ∀ x, (1 / 2 : ℝ) * H x x = ∑ i, w i * (C x i) ^ 2 := by
+  obtain ⟨w, hw, ⟨C⟩⟩ :=
+    (halfHessianQuadratic H).equivalent_one_neg_one_weighted_sum_squared
+      (halfHessianQuadratic_separatingLeft H hH hHbij.1)
+  refine ⟨w, hw, C.toLinearEquiv.toContinuousLinearEquiv, ?_⟩
+  intro x
+  change (1 / 2 : ℝ) * H x x = ∑ i, w i * (C x i) ^ 2
+  simpa only [QuadraticMap.weightedSumSquares_apply, halfHessianQuadratic_apply, smul_eq_mul,
+    pow_two] using (C.map_app x).symm
+
+private theorem SmoothMorseLemma.exists_signed_diffeomorph {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] (H : Bilinear E) (hH : ∀ x y, H x y = H y x)
+    (hHbij : Function.Bijective H) :
+    ∃ w : Fin (Module.finrank ℝ E) → ℝ,
+      (∀ i, w i = -1 ∨ w i = 1) ∧
+        ∃ C : E ≃ₘ[ℝ] (Fin (Module.finrank ℝ E) → ℝ),
+          C 0 = 0 ∧ ∀ x, (1 / 2 : ℝ) * H x x = ∑ i, w i * (C x i) ^ 2 := by
+  obtain ⟨w, hw, C, hC⟩ := exists_signed_coordinates H hH hHbij
+  exact ⟨w, hw, C.toDiffeomorph, C.map_zero, hC⟩
+
+private theorem SmoothMorseLemma.hessian_symmetric_of_contDiffOn {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {f : E → ℝ} {U : Set E} (hf : ContDiffOn ℝ ∞ f U) (hU : IsOpen U) {a : E}
+    (ha : a ∈ U) (u v : E) : fderiv ℝ (fderiv ℝ f) a u v = fderiv ℝ (fderiv ℝ f) a v u := by
+  have hs :=
+    (hf.contDiffAt (hU.mem_nhds ha)).isSymmSndFDerivAt
+      (by
+        simp only [minSmoothness_of_isRCLikeNormedField]
+        change (↑(2 : ℕ∞) : ℕ∞ω) ≤ ↑(⊤ : ℕ∞)
+        exact WithTop.coe_le_coe.mpr le_top)
+  exact hs u v
+
+private theorem SmoothMorseLemma.exists_signed_morse_chart_of_contDiffOn {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] {f : E → ℝ} {U : Set E}
+    (hf : ContDiffOn ℝ ∞ f U) (hU : IsOpen U) (a : E) (ha : a ∈ U) (hc : fderiv ℝ f a = 0)
+    (hn : Function.Bijective (fderiv ℝ (fderiv ℝ f) a)) :
+    ∃ w : Fin (Module.finrank ℝ E) → ℝ,
+      (∀ i, w i = -1 ∨ w i = 1) ∧
+        ∃ e :
+          PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, Fin (Module.finrank ℝ E) → ℝ) E
+            (Fin (Module.finrank ℝ E) → ℝ) ∞,
+          a ∈ e.source ∧
+            e.source ⊆ U ∧
+              e a = 0 ∧
+                (∀ x ∈ e.source, f x = f a + ∑ i, w i * (e x i) ^ 2) ∧
+                  (∀ y ∈ e.target, f (e.symm y) = f a + ∑ i, w i * y i ^ 2) := by
+  obtain ⟨e, hea, heU, hezero, _, hnormal, _⟩ := exists_morse_chart_of_contDiffOn hf hU a ha hc hn
+  obtain ⟨w, hw, C, hCzero, hC⟩ :=
+    exists_signed_diffeomorph (fderiv ℝ (fderiv ℝ f) a) (hessian_symmetric_of_contDiffOn hf hU ha)
+      hn
+  let φ := e.trans C.toPartialDiffeomorph
+  have hsource : φ.source = e.source := by
+    ext x
+    change (x ∈ e.source ∧ e x ∈ (Set.univ : Set E)) ↔ x ∈ e.source
+    simp only [Set.mem_univ, and_true]
+  have haφ : a ∈ φ.source := hsource ▸ hea
+  have hφU : φ.source ⊆ U := hsource ▸ heU
+  have hφzero : φ a = 0 := by
+    change C (e a) = 0
+    rw [hezero, hCzero]
+  have hφnormal (x : E) (hx : x ∈ φ.source) : f x = f a + ∑ i, w i * (φ x i) ^ 2 := by
+    have hx' : x ∈ e.source := hsource ▸ hx
+    calc
+      f x = f a + (1 / 2 : ℝ) * fderiv ℝ (fderiv ℝ f) a (e x) (e x) := hnormal x hx'
+      _ = f a + ∑ i, w i * (C (e x) i) ^ 2 := by rw [hC]
+      _ = f a + ∑ i, w i * (φ x i) ^ 2 := rfl
+  refine ⟨w, hw, φ, haφ, hφU, hφzero, hφnormal, ?_⟩
+  intro y hy
+  have hr : φ (φ.symm y) = y := φ.right_inv hy
+  simpa only [hr] using hφnormal (φ.symm y) (φ.map_target hy)
+
+private def Smale.ManifoldMorse.chartPartialDiffeomorph {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] (e : OpenPartialHomeomorph M E)
+    (he : e ∈ IsManifold.maximalAtlas 𝓘(ℝ, E) ∞ M) : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M E ∞
+    where
+  toPartialEquiv := e.toPartialEquiv
+  open_source := e.open_source
+  open_target := e.open_target
+  contMDiffOn_toFun := contMDiffOn_of_mem_maximalAtlas he
+  contMDiffOn_invFun := contMDiffOn_symm_of_mem_maximalAtlas he
+
+private structure Smale.ManifoldMorse.SignedMorseChart {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] (f : M → ℝ) (x : M) where
+  weights : Fin (Module.finrank ℝ E) → ℝ
+  signs : ∀ i, weights i = -1 ∨ weights i = 1
+  chart :
+    PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, Fin (Module.finrank ℝ E) → ℝ) M (Fin (Module.finrank ℝ E) → ℝ)
+      ∞
+  mem_source : x ∈ chart.source
+  center : chart x = 0
+  equation : ∀ y ∈ chart.source, f y = f x + ∑ i, weights i * (chart y i) ^ 2
+  inverse_equation : ∀ y ∈ chart.target, f (chart.symm y) = f x + ∑ i, weights i * y i ^ 2
+
+private theorem Smale.ManifoldMorse.nonempty_signedMorseChart {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : IsMorse E f) (x : M)
+    (hx : x ∈ criticalPoints E f) : Nonempty (SignedMorseChart (E := E) f x) := by
+  obtain ⟨e, he, hxS, hreg | hH⟩ := hm x
+  · exact False.elim (hreg ((mem_criticalPoints_iff hf he hxS).mp hx))
+  · have hc := (mem_criticalPoints_iff hf he hxS).mp hx
+    obtain ⟨w, hw, d, hdx, -, hd₀, hdeq, hdinv⟩ :=
+      SmoothMorseLemma.exists_signed_morse_chart_of_contDiffOn (contDiffOn_chartExpression hf he)
+        e.open_target (e x) (e.map_source hxS) hc hH
+    let c := (chartPartialDiffeomorph e he).trans d
+    refine ⟨⟨w, hw, c, ⟨hxS, hdx⟩, hd₀, ?_, ?_⟩⟩
+    · intro y hy
+      have hyS : y ∈ e.source := hy.1
+      have hyd : e y ∈ d.source := hy.2
+      change f y = f x + ∑ i, w i * (d (e y) i) ^ 2
+      simpa only [Function.comp_apply, e.left_inv hyS, e.left_inv hxS] using hdeq (e y) hyd
+    · intro y hy
+      have hyd : y ∈ d.target := hy.1
+      change f (e.symm (d.symm y)) = f x + ∑ i, w i * y i ^ 2
+      simpa only [Function.comp_apply, e.left_inv hxS] using hdinv y hyd
+
+private abbrev Smale.MorseHandle.Negative {ι : Type*} (w : ι → ℝ) :=
+  { i // w i = -1 }
+
+private abbrev Smale.MorseHandle.Positive {ι : Type*} (w : ι → ℝ) :=
+  { i // w i ≠ -1 }
+
+private abbrev Smale.MorseHandle.NegativeSpace {ι : Type*} (w : ι → ℝ) :=
+  EuclideanSpace ℝ (Negative w)
+
+private abbrev Smale.MorseHandle.PositiveSpace {ι : Type*} (w : ι → ℝ) :=
+  EuclideanSpace ℝ (Positive w)
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.MorseHandle.splitLinearEquiv {ι : Type*} (w : ι → ℝ) :
+    (ι → ℝ) ≃ₗ[ℝ] (NegativeSpace w × PositiveSpace w) := by
+  let e : (ι → ℝ) ≃ₗ[ℝ] ((Negative w → ℝ) × (Positive w → ℝ)) :=
+    { toEquiv := Equiv.piEquivPiSubtypeProd (fun i => w i = -1) (fun _ => ℝ)
+      map_add' := fun _ _ => rfl
+      map_smul' := fun _ _ => rfl }
+  exact
+    e.trans
+      (LinearEquiv.prodCongr (WithLp.linearEquiv 2 ℝ (Negative w → ℝ)).symm
+        (WithLp.linearEquiv 2 ℝ (Positive w → ℝ)).symm)
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.MorseHandle.splitCoordinates {ι : Type*} [Fintype ι] (w : ι → ℝ) :
+    (ι → ℝ) ≃L[ℝ] (NegativeSpace w × PositiveSpace w) :=
+  (splitLinearEquiv w).toContinuousLinearEquiv
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.MorseHandle.signedSum_eq_norms {ι : Type*} [Fintype ι] (w : ι → ℝ)
+    (hw : ∀ i, w i = -1 ∨ w i = 1) (z : ι → ℝ) :
+    ∑ i, w i * (z i) ^ 2 = -‖(splitCoordinates w z).1‖ ^ 2 + ‖(splitCoordinates w z).2‖ ^ 2 := by
+  rw [EuclideanSpace.real_norm_sq_eq, EuclideanSpace.real_norm_sq_eq]
+  have hneg : (∑ i : Negative w, w i.1 * (z i.1) ^ 2) = -∑ i : Negative w, (z i.1) ^ 2 := by
+    calc
+      _ = ∑ i : Negative w, -(z i.1) ^ 2 := by
+        apply Finset.sum_congr rfl
+        intro i _
+        rw [i.2, neg_one_mul]
+      _ = _ := by rw [Finset.sum_neg_distrib]
+  have hpos : (∑ i : Positive w, w i.1 * (z i.1) ^ 2) = ∑ i : Positive w, (z i.1) ^ 2 := by
+    apply Finset.sum_congr rfl
+    intro i _
+    rw [(hw i.1).resolve_left i.2, one_mul]
+  calc
+    ∑ i, w i * (z i) ^ 2 =
+        (∑ i : Negative w, w i.1 * (z i.1) ^ 2) + ∑ i : Positive w, w i.1 * (z i.1) ^ 2 :=
+      (Fintype.sum_subtype_add_sum_subtype (fun i => w i = -1) (fun i => w i * (z i) ^ 2)).symm
+    _ = _ := by rw [hneg, hpos]; rfl
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.MorseHandle.signedSum_symm_eq_norms {ι : Type*} [Fintype ι] (w : ι → ℝ)
+    (hw : ∀ i, w i = -1 ∨ w i = 1) (z : NegativeSpace w × PositiveSpace w) :
+    ∑ i, w i * ((splitCoordinates w).symm z i) ^ 2 = -‖z.1‖ ^ 2 + ‖z.2‖ ^ 2 := by
+  simpa only [ContinuousLinearEquiv.apply_symm_apply] using
+    signedSum_eq_norms w hw ((splitCoordinates w).symm z)
+
+private abbrev Smale.ManifoldMorse.SignedMorseChart.NegativeCoordinates {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {x : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) :=
+  Smale.MorseHandle.NegativeSpace c.weights
+
+private abbrev Smale.ManifoldMorse.SignedMorseChart.PositiveCoordinates {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {x : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) :=
+  Smale.MorseHandle.PositiveSpace c.weights
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.finrank_negative_add_positive {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {x : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) :
+    Module.finrank ℝ c.NegativeCoordinates + Module.finrank ℝ c.PositiveCoordinates =
+      Module.finrank ℝ E := by
+  have h := (Smale.MorseHandle.splitLinearEquiv c.weights).finrank_eq
+  simpa only [Module.finrank_prod, Module.finrank_fin_fun] using h.symm
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.SignedMorseChart.splitChart {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {x : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) :
+    PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, c.NegativeCoordinates × c.PositiveCoordinates) M
+      (c.NegativeCoordinates × c.PositiveCoordinates) ∞ :=
+  c.chart.trans (Smale.MorseHandle.splitCoordinates c.weights).toDiffeomorph.toPartialDiffeomorph
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.splitChart_mem_source {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {x : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) : x ∈ c.splitChart.source :=
+  ⟨c.mem_source, Set.mem_univ _⟩
+
+attribute [local instance 100] Classical.propDecidable in
+@[simp]
+private theorem Smale.ManifoldMorse.SignedMorseChart.splitChart_center {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {x : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) : c.splitChart x = 0 := by
+  change Smale.MorseHandle.splitCoordinates c.weights (c.chart x) = 0
+  rw [c.center, map_zero]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.splitChart_equation {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {x : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) {y : M}
+    (hy : y ∈ c.splitChart.source) :
+    f y = f x - ‖(c.splitChart y).1‖ ^ 2 + ‖(c.splitChart y).2‖ ^ 2 := by
+  rw [c.equation y hy.1, Smale.MorseHandle.signedSum_eq_norms c.weights c.signs]
+  change f x + (-‖(c.splitChart y).1‖ ^ 2 + ‖(c.splitChart y).2‖ ^ 2) = _
+  ring
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.splitChart_inverse_equation {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {x : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x)
+    {y : c.NegativeCoordinates × c.PositiveCoordinates} (hy : y ∈ c.splitChart.target) :
+    f (c.splitChart.symm y) = f x - ‖y.1‖ ^ 2 + ‖y.2‖ ^ 2 := by
+  change f (c.chart.symm ((Smale.MorseHandle.splitCoordinates c.weights).symm y)) = _
+  rw [c.inverse_equation ((Smale.MorseHandle.splitCoordinates c.weights).symm y) hy.2,
+    Smale.MorseHandle.signedSum_symm_eq_norms c.weights c.signs]
+  ring
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.exists_closed_productBlock {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {x : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) :
+    ∃ r > (0 : ℝ),
+      Metric.closedBall (0 : c.NegativeCoordinates) r ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) r ⊆
+        c.splitChart.target := by
+  have hzero : (0 : c.NegativeCoordinates × c.PositiveCoordinates) ∈ c.splitChart.target := by
+    rw [← c.splitChart_center]
+    exact c.splitChart.toOpenPartialHomeomorph.map_source c.splitChart_mem_source
+  obtain ⟨r, hr, hsub⟩ :=
+    Metric.nhds_basis_closedBall.mem_iff.mp (c.splitChart.open_target.mem_nhds hzero)
+  refine ⟨r, hr, ?_⟩
+  rw [closedBall_prod_same]
+  exact hsub
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.SignedMorseChart.descentField {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) : (x : M) → TangentSpace 𝓘(ℝ, E) x :=
+  Smale.FlowConstruction.partialChartField c.splitChart Smale.MorseHandle.descent
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.contMDiffOn_descentField {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) [CompleteSpace E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] :
+    ContMDiffOn 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞
+      (fun x => (⟨x, c.descentField x⟩ : TangentBundle 𝓘(ℝ, E) M)) c.splitChart.source :=
+  Smale.FlowConstruction.contMDiffOn_partialChartField c.splitChart
+    Smale.MorseHandle.contDiff_descent
+
+attribute [local instance 100] Classical.propDecidable in
+@[simp]
+private theorem Smale.ManifoldMorse.SignedMorseChart.descentField_center {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) : c.descentField p = 0 := by
+  have hzero : Smale.MorseHandle.descent (c.splitChart p) = 0 := by
+    rw [c.splitChart_center]
+    simp [Smale.MorseHandle.descent]
+  unfold descentField Smale.FlowConstruction.partialChartField
+  rw [VectorField.mpullback_apply, hzero, map_zero, map_zero]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.mvfderiv_descentField {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {x : M} (hx : x ∈ c.splitChart.source) :
+    mvfderiv 𝓘(ℝ, E) f x (c.descentField x) =
+      -2 * (‖(c.splitChart x).1‖ ^ 2 + ‖(c.splitChart x).2‖ ^ 2) := by
+  rw [descentField, Smale.FlowConstruction.mvfderiv_partialChartField hf c.splitChart _ hx]
+  have hcoord :
+    (f ∘ c.splitChart.symm) =ᶠ[𝓝 (c.splitChart x)]
+      (fun z => f p + Smale.MorseHandle.quadratic z) := by
+    filter_upwards [c.splitChart.open_target.mem_nhds
+        (c.splitChart.toOpenPartialHomeomorph.map_source hx)] with
+      z hz
+    change f (c.splitChart.symm z) = f p + (-‖z.1‖ ^ 2 + ‖z.2‖ ^ 2)
+    rw [c.splitChart_inverse_equation hz]
+    ring
+  rw [hcoord.fderiv_eq, fderiv_const_add]
+  exact Smale.MorseHandle.fderiv_quadratic_descent _
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.mvfderiv_descentField_neg {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {x : M} (hx : x ∈ c.splitChart.source) (hxp : x ≠ p) :
+    mvfderiv 𝓘(ℝ, E) f x (c.descentField x) < 0 := by
+  have hcoord : c.splitChart x ≠ 0 := by
+    intro h
+    apply hxp
+    exact
+      c.splitChart.toOpenPartialHomeomorph.injOn hx c.splitChart_mem_source
+        (h.trans c.splitChart_center.symm)
+  rw [c.mvfderiv_descentField hf hx]
+  simpa only [Smale.MorseHandle.fderiv_quadratic_descent] using
+    Smale.MorseHandle.fderiv_quadratic_descent_neg hcoord
+
+private theorem Smale.ManifoldMorse.exists_adaptedDescentField {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : IsMorse E f) :
+    ∃ V : (x : M) → TangentSpace 𝓘(ℝ, E) x,
+      ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+        (∀ x ∈ criticalPoints E f, V x = 0) ∧
+          (∀ x, x ∉ criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0) ∧
+            ∀ p ∈ criticalPoints E f,
+              ∃ c : SignedMorseChart (E := E) f p, ∀ᶠ x in 𝓝 p, V x = c.descentField x := by
+  classical
+  let S := criticalPoints E f
+  have hS : S.Finite := finite_criticalPoints hf hm
+  let : Fintype S := hS.fintype
+  let c (p : S) : SignedMorseChart (E := E) f (p : M) :=
+    Classical.choice (nonempty_signedMorseChart hf hm p.1 p.2)
+  obtain ⟨U₀, hU₀, hdisj₀⟩ := hS.t2_separation
+  let U (p : S) : Set M := U₀ p ∩ (c p).splitChart.source
+  have hU (p : S) : IsOpen (U p) := (hU₀ p).2.inter (c p).splitChart.open_source
+  have hpU (p : S) : (p : M) ∈ U p := ⟨(hU₀ p).1, (c p).splitChart_mem_source⟩
+  have hdisj : Pairwise (fun p q : S => Disjoint (U p) (U q)) := by
+    intro p q hpq
+    exact
+      (hdisj₀ p.2 q.2 (fun h => hpq (Subtype.ext h))).mono Set.inter_subset_left
+        Set.inter_subset_left
+  choose K hKnhds hKclosed hKU using
+    (fun p : S => exists_mem_nhds_isClosed_subset ((hU p).mem_nhds (hpU p)))
+  have hcover : criticalPoints E f ⊆ ⋃ p : S, K p := by
+    intro p hp
+    exact Set.mem_iUnion.mpr ⟨⟨p, hp⟩, mem_of_mem_nhds (hKnhds ⟨p, hp⟩)⟩
+  have hVloc (p : S) :
+    ContMDiffOn 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞
+      (fun x => (⟨x, (c p).descentField x⟩ : TangentBundle 𝓘(ℝ, E) M)) (U p) :=
+    (c p).contMDiffOn_descentField.mono Set.inter_subset_right
+  have hdesc (p : S) (x : M) (hx : x ∈ U p) (hreg : x ∉ criticalPoints E f) :
+    mvfderiv 𝓘(ℝ, E) f x ((c p).descentField x) < 0 :=
+    (c p).mvfderiv_descentField_neg hf hx.2 (fun h => hreg (h.symm ▸ p.2))
+  obtain ⟨V, hV, hstrict, hmatch⟩ :=
+    Smale.FlowConstruction.exists_gluedDescentField hf U K hU hKclosed hKU hdisj hcover
+      (fun p => (c p).descentField) hVloc hdesc
+  refine ⟨V, hV, ?_, hstrict, ?_⟩
+  · intro p hp
+    rw [hmatch ⟨p, hp⟩ p (mem_of_mem_nhds (hKnhds ⟨p, hp⟩))]
+    exact (c ⟨p, hp⟩).descentField_center
+  · intro p hp
+    refine ⟨c ⟨p, hp⟩, ?_⟩
+    filter_upwards [hKnhds ⟨p, hp⟩] with x hx
+    exact hmatch ⟨p, hp⟩ x hx
+
+private theorem MorseCancel.morse_descentField_zero_at_critical {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+      {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    {x : M} (hx : x ∈ c.splitChart.source) (hcrit : x ∈ Smale.ManifoldMorse.criticalPoints E f) :
+    c.descentField x = 0 := by
+  by_cases hxp : x = p
+  · subst x
+    exact c.descentField_center
+  · have hneg := c.mvfderiv_descentField_neg hf hx hxp
+    have hc : mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f x = 0 := hcrit
+    have hz : mvfderiv 𝓘(ℝ, E) f x (c.descentField x) = 0 := by
+      unfold mvfderiv
+      rw [hc]
+      rfl
+    rw [hz] at hneg
+    exact False.elim (lt_irrefl (0 : ℝ) hneg)
+
+private theorem MorseCancel.exists_prescribed_morse_patch_field {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f) {ι : Type*}
+    [Finite ι] (p : ι → M) (hp : ∀ i, p i ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (c : ∀ i, Smale.ManifoldMorse.SignedMorseChart (E := E) f (p i)) (K : ι → Set M)
+    (hK : ∀ i, IsClosed (K i)) (hKchart : ∀ i, K i ⊆ (c i).splitChart.source)
+    (hdisj : Pairwise (fun i j => Disjoint (K i) (K j))) :
+    ∃ V : (x : M) → TangentSpace 𝓘(ℝ, E) x,
+      ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+        (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0) ∧
+          (∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0) ∧
+            ∀ i x, x ∈ K i → V x = (c i).descentField x := by
+  obtain ⟨V₀, hV₀, hzero₀, hdesc₀, -⟩ := Smale.ManifoldMorse.exists_adaptedDescentField hf hm
+  apply
+    exists_closed_patch_descent_field V₀ hV₀ hzero₀ hdesc₀ K (fun i => (c i).splitChart.source) hK
+      (fun i => (c i).splitChart.open_source) hKchart hdisj (fun i => (c i).descentField)
+      (fun i => (c i).contMDiffOn_descentField)
+  · exact fun i x hx hc => morse_descentField_zero_at_critical (c i) hf hx hc
+  · intro i x hx hreg
+    exact (c i).mvfderiv_descentField_neg hf hx (fun h => hreg (h.symm ▸ hp i))
+
+attribute [local instance 100] Classical.propDecidable in
+private def MorseCancel.morseClosedBlock {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (R : ℝ) : Set M :=
+  c.splitChart.symm ''
+    (Metric.closedBall (0 : c.NegativeCoordinates) R ×ˢ
+      Metric.closedBall (0 : c.PositiveCoordinates) R)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.morseClosedBlock_subset_source {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (R : ℝ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) R ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) R ⊆
+        c.splitChart.target) :
+    morseClosedBlock c R ⊆ c.splitChart.source := by
+  rintro x ⟨z, hz, rfl⟩
+  exact c.splitChart.map_target' (hblock hz)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.morseClosedBlock_height {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (R : ℝ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) R ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) R ⊆
+        c.splitChart.target) :
+    morseClosedBlock c R ⊆ f ⁻¹' Set.Icc (f p - R ^ 2) (f p + R ^ 2) := by
+  rintro x ⟨z, hz, rfl⟩
+  have hn : ‖z.1‖ ≤ R := mem_closedBall_zero_iff.mp hz.1
+  have hp : ‖z.2‖ ≤ R := mem_closedBall_zero_iff.mp hz.2
+  have hn2 : ‖z.1‖ ^ 2 ≤ R ^ 2 := pow_le_pow_left₀ (norm_nonneg _) hn 2
+  have hp2 : ‖z.2‖ ^ 2 ≤ R ^ 2 := pow_le_pow_left₀ (norm_nonneg _) hp 2
+  change f (c.splitChart.symm z) ∈ Set.Icc (f p - R ^ 2) (f p + R ^ 2)
+  rw [c.splitChart_inverse_equation (hblock hz)]
+  constructor <;> nlinarith [sq_nonneg ‖z.1‖, sq_nonneg ‖z.2‖]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.morseClosedBlock_mem_nhds {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (R : ℝ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) R ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) R ⊆
+        c.splitChart.target)
+    {z : c.NegativeCoordinates × c.PositiveCoordinates} (hn : ‖z.1‖ < R) (hp : ‖z.2‖ < R) :
+    morseClosedBlock c R ∈ 𝓝 (c.splitChart.symm z) := by
+  have hz : z ∈ c.splitChart.target :=
+    hblock ⟨mem_closedBall_zero_iff.mpr hn.le, mem_closedBall_zero_iff.mpr hp.le⟩
+  have hx : c.splitChart.symm z ∈ c.splitChart.source := c.splitChart.map_target' hz
+  have hc : c.splitChart (c.splitChart.symm z) = z := c.splitChart.right_inv' hz
+  have ho :
+    Metric.ball (0 : c.NegativeCoordinates) R ×ˢ Metric.ball (0 : c.PositiveCoordinates) R ∈
+      𝓝 (c.splitChart (c.splitChart.symm z)) := by
+    rw [hc]
+    exact
+      (Metric.isOpen_ball.prod Metric.isOpen_ball).mem_nhds
+        ⟨mem_ball_zero_iff.mpr hn, mem_ball_zero_iff.mpr hp⟩
+  have hnear := (c.splitChart.toOpenPartialHomeomorph.continuousAt hx) ho
+  filter_upwards [c.splitChart.open_source.mem_nhds hx, hnear] with y hy hcy
+  exact
+    ⟨c.splitChart y, ⟨Metric.ball_subset_closedBall hcy.1, Metric.ball_subset_closedBall hcy.2⟩,
+      c.splitChart.left_inv' hy⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.isCompact_morseClosedBlock {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+     (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (R : ℝ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) R ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) R ⊆
+        c.splitChart.target) :
+    IsCompact (morseClosedBlock c R) :=
+  (ProperSpace.isCompact_closedBall (0 : c.NegativeCoordinates) R).prod
+      (ProperSpace.isCompact_closedBall (0 : c.PositiveCoordinates) R) |>.image_of_continuousOn
+    (c.splitChart.symm.contMDiffOn_toFun.continuousOn.mono hblock)
+
+private theorem Smale.FlowConstruction.exists_localFlow_in_open {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [CompleteSpace E] {v : E → E} {x₀ : E} (hv : ContDiffAt ℝ 1 v x₀)
+    {U : Set E} (hU : IsOpen U) (hxU : x₀ ∈ U) :
+    ∃ r > (0 : ℝ),
+      ∃ ε > (0 : ℝ),
+        ∃ α : E × ℝ → E,
+          ContinuousOn α (Metric.ball x₀ r ×ˢ Set.Ioo (-ε) ε) ∧
+            ∀ x ∈ Metric.ball x₀ r,
+              α (x, 0) = x ∧
+                ∀ t ∈ Set.Ioo (-ε) ε,
+                  α (x, t) ∈ U ∧ HasDerivAt (fun s => α (x, s)) (v (α (x, t))) t := by
+  obtain ⟨ε, hε, a, r, L, K, hr, hpl⟩ := IsPicardLindelof.of_contDiffAt_one hv
+  obtain ⟨α, hα, hc⟩ := (hpl 0).exists_forall_mem_closedBall_eq_hasDerivWithinAt_continuousOn
+  simp only [zero_sub, zero_add] at hα hc
+  have hr' : (0 : ℝ) < r := hr
+  have hc₀ : ContinuousAt α (x₀, 0) :=
+    hc.continuousAt
+      (prod_mem_nhds (Metric.closedBall_mem_nhds x₀ hr') (Icc_mem_nhds (neg_lt_zero.mpr hε) hε))
+  have hα₀ : α (x₀, 0) = x₀ := (hα x₀ (Metric.mem_closedBall_self hr'.le)).1
+  have hpre : α ⁻¹' U ∈ 𝓝 (x₀, 0) := hc₀.preimage_mem_nhds (hU.mem_nhds (hα₀.symm ▸ hxU))
+  have hD : Metric.ball x₀ (r : ℝ) ×ˢ Set.Ioo (-ε) ε ∈ 𝓝 (x₀, 0) :=
+    prod_mem_nhds (Metric.ball_mem_nhds x₀ hr') (Ioo_mem_nhds (neg_lt_zero.mpr hε) hε)
+  obtain ⟨δ, hδ, hδsub⟩ := Metric.mem_nhds_iff.mp (Filter.inter_mem hD hpre)
+  have hs :
+    Metric.ball x₀ δ ×ˢ Set.Ioo (-δ) δ ⊆ (Metric.ball x₀ (r : ℝ) ×ˢ Set.Ioo (-ε) ε) ∩ α ⁻¹' U := by
+    intro q hq
+    apply hδsub
+    rw [Metric.mem_ball, Prod.dist_eq, max_lt_iff]
+    exact ⟨hq.1, by simpa only [dist_zero_right, Real.norm_eq_abs] using abs_lt.mpr hq.2⟩
+  refine ⟨δ, hδ, δ, hδ, α, hc.mono ?_, ?_⟩
+  · intro q hq
+    exact ⟨Metric.ball_subset_closedBall (hs hq).1.1, Set.Ioo_subset_Icc_self (hs hq).1.2⟩
+  · intro x hx
+    have hx₀ : (x, (0 : ℝ)) ∈ Metric.ball x₀ δ ×ˢ Set.Ioo (-δ) δ := ⟨hx, neg_lt_zero.mpr hδ, hδ⟩
+    have hx' : x ∈ Metric.closedBall x₀ (r : ℝ) := Metric.ball_subset_closedBall (hs hx₀).1.1
+    refine ⟨(hα x hx').1, ?_⟩
+    intro t ht
+    have hq : (x, t) ∈ Metric.ball x₀ δ ×ˢ Set.Ioo (-δ) δ := ⟨hx, ht⟩
+    refine ⟨(hs hq).2, ?_⟩
+    have ht' := (hs hq).1.2
+    exact ((hα x hx').2 t (Set.Ioo_subset_Icc_self ht')).hasDerivAt (Icc_mem_nhds ht'.1 ht'.2)
+
+private def
+    Smale.FlowConstruction.coordinateField {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) 1 M]
+    (v : (x : M) → TangentSpace 𝓘(ℝ, E) x) (p : M) (y : E) : E :=
+  tangentCoordChange 𝓘(ℝ, E) ((chartAt E p).symm y) p ((chartAt E p).symm y)
+    (v ((chartAt E p).symm y))
+
+private theorem
+    Smale.FlowConstruction.contDiffAt_coordinateField {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) 1 M]
+    {v : (x : M) → TangentSpace 𝓘(ℝ, E) x} {p : M}
+    (hv :
+      ContMDiffAt 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, v x⟩ : TangentBundle 𝓘(ℝ, E) M)) p) :
+    ContDiffAt ℝ 1 (coordinateField v p) (chartAt E p p) := by
+  rw [contMDiffAt_iff] at hv
+  have h :=
+    hv.2.contDiffAt
+      (range_mem_nhds_isInteriorPoint (I := 𝓘(ℝ, E))
+        (BoundarylessManifold.isInteriorPoint (x := p)))
+  convert h.snd using 1 <;> rfl
+
+private theorem
+    Smale.FlowConstruction.coordinateField_eq_mfderiv {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) 1 M]
+    (v : (x : M) → TangentSpace 𝓘(ℝ, E) x) (p : M) {y : E} (hy : y ∈ (chartAt E p).target) :
+    coordinateField v p y =
+      mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) (chartAt E p) ((chartAt E p).symm y) (v ((chartAt E p).symm y)) := by
+  rw [mfderiv_chartAt_eq_tangentCoordChange ((chartAt E p).map_target hy)]
+  rfl
+
+private theorem
+    Smale.FlowConstruction.mfderiv_symm_coordinateField {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) 1 M]
+    (v : (x : M) → TangentSpace 𝓘(ℝ, E) x) (p : M) {y : E} (hy : y ∈ (chartAt E p).target) :
+    mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) (chartAt E p).symm y
+        ((NormedSpace.fromTangentSpace y).symm (coordinateField v p y)) =
+      v ((chartAt E p).symm y) := by
+  let e := chartAt E p
+  have he := (mdifferentiable_chart (I := 𝓘(ℝ, E)) p).symm_comp_deriv (e.map_target hy)
+  rw [e.right_inv hy] at he
+  rw [coordinateField_eq_mfderiv v p hy]
+  exact congrArg (fun A : E →L[ℝ] E => A (v (e.symm y))) he
+
+private theorem Smale.FlowConstruction.hasMFDerivAt_lift_coordinateCurve {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) 1 M] {v : (x : M) → TangentSpace 𝓘(ℝ, E) x} {p : M} {α : ℝ → E} {t : ℝ}
+    (hα : HasDerivAt α (coordinateField v p (α t)) t) (ht : α t ∈ (chartAt E p).target) :
+    HasMFDerivAt 𝓘(ℝ, ℝ) 𝓘(ℝ, E) ((chartAt E p).symm ∘ α) t
+      ((1 : ℝ →L[ℝ] ℝ).smulRight (v ((chartAt E p).symm (α t)))) := by
+  have hi := ((mdifferentiable_chart (I := 𝓘(ℝ, E)) p).mdifferentiableAt_symm ht).hasMFDerivAt
+  have h := hi.comp t hα.hasFDerivAt.hasMFDerivAt
+  apply h.congr_mfderiv
+  apply ContinuousLinearMap.ext
+  intro a
+  change
+    (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) (chartAt E p).symm (α t))
+        ((NormedSpace.fromTangentSpace t a) •
+          (NormedSpace.fromTangentSpace (α t)).symm (coordinateField v p (α t))) =
+      (NormedSpace.fromTangentSpace t a) • v ((chartAt E p).symm (α t))
+  rw [map_smul, mfderiv_symm_coordinateField v p ht]
+
+private theorem Smale.FlowConstruction.exists_manifoldLocalFlow {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [CompleteSpace E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) 1 M] {v : (x : M) → TangentSpace 𝓘(ℝ, E) x} (p : M)
+    (hv :
+      ContMDiffAt 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, v x⟩ : TangentBundle 𝓘(ℝ, E) M)) p) :
+    ∃ U : Set M,
+      IsOpen U ∧
+        p ∈ U ∧
+          ∃ ε > (0 : ℝ),
+            ∃ F : M × ℝ → M,
+              ContinuousOn F (U ×ˢ Set.Ioo (-ε) ε) ∧
+                ∀ x ∈ U,
+                  F (x, 0) = x ∧ IsMIntegralCurveOn (fun t => F (x, t)) v (Set.Ioo (-ε) ε) := by
+  let e := chartAt E p
+  obtain ⟨r, hr, ε, hε, α, hαc, hα⟩ :=
+    exists_localFlow_in_open (contDiffAt_coordinateField hv) e.open_target
+      (e.map_source (mem_chart_source E p))
+  let U : Set M := e.source ∩ e ⁻¹' Metric.ball (e p) r
+  have hU : IsOpen U := e.continuousOn.isOpen_inter_preimage e.open_source Metric.isOpen_ball
+  have hpU : p ∈ U := ⟨mem_chart_source E p, Metric.mem_ball_self hr⟩
+  let F : M × ℝ → M := fun q => e.symm (α (e q.1, q.2))
+  have hc : ContinuousOn (fun q : M × ℝ => (e q.1, q.2)) (U ×ˢ Set.Ioo (-ε) ε) :=
+    (e.continuousOn.comp continuous_fst.continuousOn (fun _ hq => hq.1.1)).prodMk
+      continuous_snd.continuousOn
+  have hd :
+    Set.MapsTo (fun q : M × ℝ => (e q.1, q.2)) (U ×ˢ Set.Ioo (-ε) ε)
+      (Metric.ball (e p) r ×ˢ Set.Ioo (-ε) ε) :=
+    fun _ hq => ⟨hq.1.2, hq.2⟩
+  have hFc : ContinuousOn F (U ×ˢ Set.Ioo (-ε) ε) :=
+    e.symm.continuousOn.comp (hαc.comp hc hd) (fun q hq => ((hα (e q.1) hq.1.2).2 q.2 hq.2).1)
+  refine ⟨U, hU, hpU, ε, hε, F, hFc, ?_⟩
+  intro x hx
+  refine ⟨?_, ?_⟩
+  · change e.symm (α (e x, 0)) = x
+    rw [(hα (e x) hx.2).1, e.left_inv hx.1]
+  · intro t ht
+    have hcurve := (hα (e x) hx.2).2 t ht
+    exact (hasMFDerivAt_lift_coordinateCurve hcurve.2 hcurve.1).hasMFDerivWithinAt
+
+private theorem
+    Smale.FlowConstruction.exists_uniformIntegralCurves {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [CompleteSpace E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) 1 M] [CompactSpace M] {v : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hv : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, v x⟩ : TangentBundle 𝓘(ℝ, E) M))) :
+    ∃ ε > (0 : ℝ), ∀ x : M, ∃ γ : ℝ → M, γ 0 = x ∧ IsMIntegralCurveOn γ v (Set.Ioo (-ε) ε) := by
+  classical
+  choose U hU hp ε hε F hFc hF using fun p : M => exists_manifoldLocalFlow p (hv p)
+  obtain ⟨s, hs⟩ :=
+    isCompact_univ.elim_finite_subcover U hU (fun x _ => Set.mem_iUnion.mpr ⟨x, hp x⟩)
+  have hN : (⋂ p ∈ s, Set.Ioo (-(ε p)) (ε p)) ∈ 𝓝 (0 : ℝ) :=
+    (Filter.biInter_finset_mem s).mpr fun p _ => Ioo_mem_nhds (neg_lt_zero.mpr (hε p)) (hε p)
+  obtain ⟨δ, hδ, hδsub⟩ := Metric.mem_nhds_iff.mp hN
+  refine ⟨δ, hδ, ?_⟩
+  intro x
+  obtain ⟨p, hps, hx⟩ := Set.mem_iUnion₂.mp (hs (Set.mem_univ x))
+  refine ⟨fun t => F p (x, t), (hF p x hx).1, (hF p x hx).2.mono ?_⟩
+  intro t ht
+  apply Set.mem_iInter₂.mp (hδsub ?_) p hps
+  simpa only [Metric.mem_ball, dist_zero_right, Real.norm_eq_abs] using abs_lt.mpr ht
+
+private theorem
+    Smale.FlowConstruction.exists_globalIntegralCurve {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [CompleteSpace E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M] [CompactSpace M] {v : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hv : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, v x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (x : M) : ∃ γ : ℝ → M, γ 0 = x ∧ IsMIntegralCurve γ v := by
+  obtain ⟨ε, hε, h⟩ := exists_uniformIntegralCurves hv
+  exact exists_isMIntegralCurve_of_isMIntegralCurveOn hv hε h x
+
+private def Smale.FlowConstruction.flow {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [CompleteSpace E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M]
+    [CompactSpace M] {v : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hv : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, v x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (t : ℝ) (x : M) : M :=
+  (exists_globalIntegralCurve hv x).choose t
+
+@[simp]
+private theorem
+    Smale.FlowConstruction.flow_zero {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [CompleteSpace E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M]
+    [CompactSpace M] {v : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hv : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, v x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (x : M) : flow hv 0 x = x :=
+  (exists_globalIntegralCurve hv x).choose_spec.1
+
+private theorem Smale.FlowConstruction.isMIntegralCurve_flow {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [CompleteSpace E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M] [CompactSpace M] {v : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hv : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, v x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (x : M) : IsMIntegralCurve (fun t => flow hv t x) v :=
+  (exists_globalIntegralCurve hv x).choose_spec.2
+
+private theorem
+    Smale.FlowConstruction.flow_add {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [CompleteSpace E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M]
+    [CompactSpace M] {v : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hv : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, v x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (s t : ℝ) (x : M) : flow hv (s + t) x = flow hv s (flow hv t x) := by
+  have h₁ := (isMIntegralCurve_flow hv x).comp_add t
+  have h₂ := isMIntegralCurve_flow hv (flow hv t x)
+  have heq :=
+    isMIntegralCurve_Ioo_eq_of_contMDiff_boundaryless hv h₁ h₂ (t₀ := 0)
+      (by simp only [Function.comp_apply, zero_add, flow_zero])
+  exact congrFun heq s
+
+private theorem Smale.FlowConstruction.flow_eq_local {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [CompleteSpace E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M] [CompactSpace M] {v : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hv : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, v x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    {U : Set M} {ε : ℝ} (hε : 0 < ε) {F : M × ℝ → M}
+    (hF : ∀ x ∈ U, F (x, 0) = x ∧ IsMIntegralCurveOn (fun t => F (x, t)) v (Set.Ioo (-ε) ε))
+    {x : M} (hx : x ∈ U) {t : ℝ} (ht : t ∈ Set.Ioo (-ε) ε) : flow hv t x = F (x, t) :=
+  isMIntegralCurveOn_Ioo_eqOn_of_contMDiff_boundaryless (t₀ := 0) ⟨neg_lt_zero.mpr hε, hε⟩ hv
+    ((isMIntegralCurve_flow hv x).isMIntegralCurveOn _) (hF x hx).2
+    ((flow_zero hv x).trans (hF x hx).1.symm) ht
+
+private theorem Smale.FlowConstruction.exists_continuousOn_flow {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [CompleteSpace E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M] [CompactSpace M] {v : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hv : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, v x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (p : M) :
+    ∃ U : Set M,
+      IsOpen U ∧
+        p ∈ U ∧ ∃ ε > (0 : ℝ), ContinuousOn (Function.uncurry (flow hv)) (Set.Ioo (-ε) ε ×ˢ U) := by
+  obtain ⟨U, hU, hp, ε, hε, F, hFc, hF⟩ := exists_manifoldLocalFlow p (hv p)
+  refine ⟨U, hU, hp, ε, hε, ?_⟩
+  have hc : ContinuousOn (fun q : ℝ × M => F (q.2, q.1)) (Set.Ioo (-ε) ε ×ˢ U) :=
+    hFc.comp continuous_swap.continuousOn (fun _ hq => ⟨hq.2, hq.1⟩)
+  exact hc.congr (fun q hq => flow_eq_local hv hε hF hq.2 hq.1)
+
+private theorem
+    Smale.FlowConstruction.exists_smalltime_continuous {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [CompleteSpace E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M] [CompactSpace M] {v : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hv : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, v x⟩ : TangentBundle 𝓘(ℝ, E) M))) :
+    ∃ ε > (0 : ℝ), ∀ t ∈ Set.Ioo (-ε) ε, Continuous (flow hv t) := by
+  classical
+  choose U hU hp ε hε hF using exists_continuousOn_flow hv
+  obtain ⟨s, hs⟩ :=
+    isCompact_univ.elim_finite_subcover U hU (fun x _ => Set.mem_iUnion.mpr ⟨x, hp x⟩)
+  have hN : (⋂ p ∈ s, Set.Ioo (-(ε p)) (ε p)) ∈ 𝓝 (0 : ℝ) :=
+    (Filter.biInter_finset_mem s).mpr fun p _ => Ioo_mem_nhds (neg_lt_zero.mpr (hε p)) (hε p)
+  obtain ⟨δ, hδ, hδsub⟩ := Metric.mem_nhds_iff.mp hN
+  refine ⟨δ, hδ, ?_⟩
+  intro t ht
+  have htall : t ∈ ⋂ p ∈ s, Set.Ioo (-(ε p)) (ε p) :=
+    hδsub (by simpa only [Metric.mem_ball, dist_zero_right, Real.norm_eq_abs] using abs_lt.mpr ht)
+  apply continuous_iff_continuousAt.mpr
+  intro x
+  obtain ⟨p, hps, hxp⟩ := Set.mem_iUnion₂.mp (hs (Set.mem_univ x))
+  have htp := Set.mem_iInter₂.mp htall p hps
+  exact
+    ((hF p).continuousAt (prod_mem_nhds (Ioo_mem_nhds htp.1 htp.2) ((hU p).mem_nhds hxp))).comp
+      (continuousAt_const.prodMk continuousAt_id)
+
+private theorem Smale.FlowConstruction.continuous_flow_time {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [CompleteSpace E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M] [CompactSpace M] {v : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hv : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, v x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (t : ℝ) : Continuous (flow hv t) := by
+  obtain ⟨ε, hε, hsmall⟩ := exists_smalltime_continuous hv
+  let S : Set ℝ := {s | Continuous (flow hv s)}
+  have hstep {s u : ℝ} (hs : s ∈ S) (hu : Dist.dist u s < ε) : u ∈ S := by
+    have hus : u - s ∈ Set.Ioo (-ε) ε := by
+      exact abs_lt.mp (by simpa only [Real.dist_eq] using hu)
+    have hc := (hsmall (u - s) hus).comp hs
+    have heq : (fun x => flow hv (u - s) (flow hv s x)) = flow hv u := by
+      funext x
+      rw [← flow_add, sub_add_cancel]
+    change Continuous (flow hv u)
+    rw [← heq]
+    exact hc
+  have hS : IsOpen S :=
+    isOpen_iff_mem_nhds.mpr fun s hs =>
+      Filter.mem_of_superset (Metric.ball_mem_nhds s hε) (fun u hu => hstep hs hu)
+  have hSc : IsOpen Sᶜ :=
+    isOpen_iff_mem_nhds.mpr fun s hs =>
+      Filter.mem_of_superset (Metric.ball_mem_nhds s hε)
+        (fun u hu h =>
+          hs
+            (hstep h
+              (by
+                change Dist.dist u s < ε at hu
+                rwa [dist_comm])))
+  have hzero : (0 : ℝ) ∈ S := by
+    change Continuous (flow hv 0)
+    have heq : flow hv 0 = id := funext (flow_zero hv)
+    rw [heq]
+    exact continuous_id
+  have hSuniv : S = Set.univ :=
+    (show IsClopen S from ⟨isOpen_compl_iff.mp hSc, hS⟩).eq_univ ⟨0, hzero⟩
+  change t ∈ S
+  rw [hSuniv]
+  exact Set.mem_univ t
+
+private theorem Smale.FlowConstruction.continuous_flow {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [CompleteSpace E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M] [CompactSpace M] {v : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hv : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, v x⟩ : TangentBundle 𝓘(ℝ, E) M))) :
+    Continuous (Function.uncurry (flow hv)) := by
+  apply continuous_iff_continuousAt.mpr
+  intro q
+  obtain ⟨U, hU, hp, ε, hε, hF⟩ := exists_continuousOn_flow hv (flow hv q.1 q.2)
+  have hzero :=
+    hF.continuousAt (prod_mem_nhds (Ioo_mem_nhds (neg_lt_zero.mpr hε) hε) (hU.mem_nhds hp))
+  have hmap : ContinuousAt (fun r : ℝ × M => (r.1 - q.1, flow hv q.1 r.2)) q :=
+    (continuousAt_fst.sub continuousAt_const).prodMk
+      ((continuous_flow_time hv q.1).continuousAt.comp continuousAt_snd)
+  have hzero' :
+    ContinuousAt (Function.uncurry (flow hv))
+      ((fun r : ℝ × M => (r.1 - q.1, flow hv q.1 r.2)) q) := by simpa only [sub_self] using hzero
+  have hcomp := hzero'.comp (f := fun r : ℝ × M => (r.1 - q.1, flow hv q.1 r.2)) hmap
+  have heq :
+    (fun r : ℝ × M => flow hv (r.1 - q.1) (flow hv q.1 r.2)) = Function.uncurry (flow hv) := by
+    funext r
+    rw [← flow_add, sub_add_cancel]
+    rfl
+  exact heq ▸ hcomp
+
+private def
+    Smale.FlowConstruction.compactFlow {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [CompleteSpace E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M]
+    [CompactSpace M] {v : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hv : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, v x⟩ : TangentBundle 𝓘(ℝ, E) M))) :
+    Flow ℝ M where
+  toFun := flow hv
+  cont' := continuous_flow hv
+  map_add' := flow_add hv
+  map_zero' := flow_zero hv
+
+private theorem
+    Smale.FlowConstruction.isMIntegralCurve_compactFlow {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [CompleteSpace E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M] [CompactSpace M] {v : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hv : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, v x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (x : M) : IsMIntegralCurve (fun t => compactFlow hv t x) v :=
+  isMIntegralCurve_flow hv x
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_disjoint_morse_block_field {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f) {ι : Type*}
+    [Finite ι] (p : ι → M) (hp : ∀ i, p i ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (c : ∀ i, Smale.ManifoldMorse.SignedMorseChart (E := E) f (p i)) (R : ι → ℝ)
+    (hblock :
+      ∀ i,
+        Metric.closedBall (0 : (c i).NegativeCoordinates) (R i) ×ˢ
+            Metric.closedBall (0 : (c i).PositiveCoordinates) (R i) ⊆
+          (c i).splitChart.target)
+    (hintervals :
+      Pairwise
+        (fun i j =>
+          Disjoint (Set.Icc (f (p i) - R i ^ 2) (f (p i) + R i ^ 2))
+            (Set.Icc (f (p j) - R j ^ 2) (f (p j) + R j ^ 2)))) :
+    ∃ (V : (x : M) → TangentSpace 𝓘(ℝ, E) x) (F : Flow ℝ M),
+      ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+        (∀ x, IsMIntegralCurve (fun t => F t x) V) ∧
+          (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0) ∧
+            (∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0) ∧
+              ∀ i (z : (c i).NegativeCoordinates × (c i).PositiveCoordinates),
+                ‖z.1‖ < R i →
+                  ‖z.2‖ < R i → ∀ᶠ y in 𝓝 ((c i).splitChart.symm z), V y = (c i).descentField y :=
+  by
+  let K := fun i => morseClosedBlock (c i) (R i)
+  have hK (i : ι) : IsClosed (K i) := (isCompact_morseClosedBlock (c i) (R i) (hblock i)).isClosed
+  have hKsource (i : ι) : K i ⊆ (c i).splitChart.source :=
+    morseClosedBlock_subset_source (c i) (R i) (hblock i)
+  have hdisj : Pairwise (fun i j => Disjoint (K i) (K j)) := by
+    intro i j hij
+    apply Set.disjoint_left.mpr
+    intro x hxi hxj
+    exact
+      Set.disjoint_left.mp (hintervals hij) (morseClosedBlock_height (c i) (R i) (hblock i) hxi)
+        (morseClosedBlock_height (c j) (R j) (hblock j) hxj)
+  obtain ⟨V, hV, hzero, hdesc, hmatch⟩ :=
+    exists_prescribed_morse_patch_field hf hm p hp c K hK hKsource hdisj
+  have hV₁ := hV.of_le (show (1 : WithTop ℕ∞) ≤ (↑(⊤ : ℕ∞) : ℕ∞ω) by simp)
+  let F := Smale.FlowConstruction.compactFlow hV₁
+  refine ⟨V, F, hV, Smale.FlowConstruction.isMIntegralCurve_compactFlow hV₁, hzero, hdesc, ?_⟩
+  intro i z hn hp
+  filter_upwards [morseClosedBlock_mem_nhds (c i) (R i) (hblock i) hn hp] with y hy
+  exact hmatch i y hy
+
+private theorem MorseCancel.exists_larger_closedBall_inside_open {A : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [ProperSpace A] {U : Set A} (hU : IsOpen U) {R B : ℝ} (hR : 0 ≤ R)
+    (hRB : R < B) (hsub : Metric.closedBall (0 : A) R ⊆ U) :
+    ∃ S, R < S ∧ S < B ∧ Metric.closedBall (0 : A) S ⊆ U := by
+  obtain ⟨δ, hδ, hδU⟩ :=
+    (ProperSpace.isCompact_closedBall (0 : A) R).exists_cthickening_subset_open hU hsub
+  rw [cthickening_closedBall hδ.le hR] at hδU
+  obtain ⟨S, hRS, hSm⟩ := exists_between (lt_min (by linarith : R < δ + R) hRB)
+  exact
+    ⟨S, hRS, hSm.trans_le (min_le_right _ _),
+      (Metric.closedBall_subset_closedBall (hSm.le.trans (min_le_left _ _))).trans hδU⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_morse_block_enlargement {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) {r : ℝ} (hr : 0 < r)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) ⊆
+        c.splitChart.target) :
+    ∃ R,
+      2 * r < R ∧
+        R < 3 * r ∧
+          Metric.closedBall (0 : c.NegativeCoordinates) R ×ˢ
+              Metric.closedBall (0 : c.PositiveCoordinates) R ⊆
+            c.splitChart.target := by
+  have hb :
+    Metric.closedBall (0 : c.NegativeCoordinates × c.PositiveCoordinates) (2 * r) ⊆
+      c.splitChart.target := by simpa only [closedBall_prod_same, Prod.mk_zero_zero] using hblock
+  obtain ⟨R, hR, hR', hsub⟩ :=
+    exists_larger_closedBall_inside_open c.splitChart.open_target (by positivity : 0 ≤ 2 * r)
+      (by linarith : 2 * r < 3 * r) hb
+  refine ⟨R, hR, hR', ?_⟩
+  simpa only [closedBall_prod_same, Prod.mk_zero_zero] using hsub
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_disjoint_surgery_block_field {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f) {ι : Type*}
+    [Finite ι] (p : ι → M) (hp : ∀ i, p i ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (c : ∀ i, Smale.ManifoldMorse.SignedMorseChart (E := E) f (p i)) (r : ι → ℝ)
+    (hr : ∀ i, 0 < r i)
+    (hblock :
+      ∀ i,
+        Metric.closedBall (0 : (c i).NegativeCoordinates) (2 * r i) ×ˢ
+            Metric.closedBall (0 : (c i).PositiveCoordinates) (2 * r i) ⊆
+          (c i).splitChart.target)
+    (hintervals :
+      Pairwise
+        (fun i j =>
+          Disjoint (Set.Icc (f (p i) - 9 * r i ^ 2) (f (p i) + 9 * r i ^ 2))
+            (Set.Icc (f (p j) - 9 * r j ^ 2) (f (p j) + 9 * r j ^ 2)))) :
+    ∃ (V : (x : M) → TangentSpace 𝓘(ℝ, E) x) (F : Flow ℝ M),
+      ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+        (∀ x, IsMIntegralCurve (fun t => F t x) V) ∧
+          (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0) ∧
+            (∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0) ∧
+              ∀ i z,
+                z ∈
+                    Metric.closedBall (0 : (c i).NegativeCoordinates) (2 * r i) ×ˢ
+                      Metric.closedBall (0 : (c i).PositiveCoordinates) (2 * r i) →
+                  ∀ᶠ y in 𝓝 ((c i).splitChart.symm z), V y = (c i).descentField y := by
+  choose R hR hR' hlarge using fun i => exists_morse_block_enlargement (c i) (hr i) (hblock i)
+  have hRpos (i : ι) : 0 < R i := (mul_pos (show (0 : ℝ) < 2 by norm_num) (hr i)).trans (hR i)
+  have hsq (i : ι) : R i ^ 2 < 9 * r i ^ 2 := by
+    have hh :=
+      mul_pos (sub_pos.mpr (hR' i))
+        (add_pos (mul_pos (show (0 : ℝ) < 3 by norm_num) (hr i)) (hRpos i))
+    nlinarith
+  have hsub (i : ι) :
+    Set.Icc (f (p i) - R i ^ 2) (f (p i) + R i ^ 2) ⊆
+      Set.Icc (f (p i) - 9 * r i ^ 2) (f (p i) + 9 * r i ^ 2) := by
+    intro v hv
+    constructor <;> linarith [hv.1, hv.2, hsq i]
+  obtain ⟨V, F, hV, hF, hzero, hdesc, hmatch⟩ :=
+    exists_disjoint_morse_block_field hf hm p hp c R hlarge
+      (fun i j hij => (hintervals hij).mono (hsub i) (hsub j))
+  refine ⟨V, F, hV, hF, hzero, hdesc, ?_⟩
+  intro i z hz
+  exact
+    hmatch i z ((mem_closedBall_zero_iff.mp hz.1).trans_lt (hR i))
+      ((mem_closedBall_zero_iff.mp hz.2).trans_lt (hR i))
+
+private theorem
+    NoExotic.exists_partialDiffeomorph_of_contDiffOn {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [CompleteSpace E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F}
+    {U : Set E} {x : E} (hU : IsOpen U) (hx : x ∈ U) (hf : ContDiffOn ℝ ∞ f U)
+    (hinv : (fderiv ℝ f x).IsInvertible) :
+    ∃ Φ : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, F) E F ∞,
+      x ∈ Φ.source ∧ Φ.source ⊆ U ∧ (Φ : E → F) = f := by
+  have hfx := hf.contDiffAt (hU.mem_nhds hx)
+  obtain ⟨A, hA⟩ := hinv
+  have hfd : HasFDerivAt f (A : E →L[ℝ] F) x := by
+    rw [hA]
+    exact (hfx.differentiableAt (by simp)).hasFDerivAt
+  let g := hfx.toOpenPartialHomeomorph f hfd (by simp)
+  let W := U ∩ interior {y | (fderiv ℝ f y).IsInvertible}
+  have hW : IsOpen W := hU.inter isOpen_interior
+  have hxW : x ∈ W := by
+    refine ⟨hx, mem_interior_iff_mem_nhds.mpr ?_⟩
+    have ho : IsOpen {L : E →L[ℝ] F | L.IsInvertible} := ContinuousLinearEquiv.isOpen
+    exact (hfx.continuousAt_fderiv (by simp)) (ho.mem_nhds ⟨A, hA⟩)
+  let r := g.restrOpen W hW
+  have hsource : r.source ⊆ U := fun _ h ↦ h.2.1
+  have hto : ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, F) ∞ r r.source := (hf.mono hsource).contMDiffOn
+  have hsymm : ContMDiffOn 𝓘(ℝ, F) 𝓘(ℝ, E) ∞ r.symm r.target := by
+    intro y hy
+    have hys := r.map_target hy
+    have hiy : (fderiv ℝ f (r.symm y)).IsInvertible :=
+      interior_subset (s := {z : E | (fderiv ℝ f z).IsInvertible}) hys.2.2
+    obtain ⟨Ay, hAy⟩ := hiy
+    have hfy : ContDiffAt ℝ ∞ f (r.symm y) := hf.contDiffAt (hU.mem_nhds hys.2.1)
+    have hfdy : HasFDerivAt r (Ay : E →L[ℝ] F) (r.symm y) := by
+      change HasFDerivAt f (Ay : E →L[ℝ] F) (r.symm y)
+      rw [hAy]
+      exact (hfy.differentiableAt (by simp)).hasFDerivAt
+    exact (r.contDiffAt_symm hy hfdy hfy).contMDiffAt.contMDiffWithinAt
+  refine
+    ⟨{ r.toPartialEquiv with
+        open_source := r.open_source
+        open_target := r.open_target
+        contMDiffOn_toFun := hto
+        contMDiffOn_invFun := hsymm },
+      ?_, hsource, rfl⟩
+  exact ⟨hfx.mem_toOpenPartialHomeomorph_source hfd (by simp), hxW⟩
+
+private def
+    NoExotic.tangentModelEquiv {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] {H M : Type*}
+    [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [TopologicalSpace M] [ChartedSpace H M]
+    (x : M) : TangentSpace I x ≃L[ℝ] E where
+  toFun v := v
+  invFun v := v
+  left_inv _ := rfl
+  right_inv _ := rfl
+  map_add' _ _ := rfl
+  map_smul' _ _ := rfl
+  continuous_toFun := continuous_id
+  continuous_invFun := continuous_id
+
+private noncomputable def NoExotic.modelChartPartialDiffeomorph {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {H M : Type*} [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [I.Boundaryless] [TopologicalSpace M] [ChartedSpace H M] [IsManifold I ∞ M] (x : M) :
+    PartialDiffeomorph I 𝓘(ℝ, E) M E ∞
+    where
+  toPartialEquiv := extChartAt I x
+  open_source := isOpen_extChartAt_source x
+  open_target := isOpen_extChartAt_target x
+  contMDiffOn_toFun := by
+    simpa only [extChartAt_source] using (contMDiffOn_extChartAt (I := I) (x := x) (n := ∞))
+  contMDiffOn_invFun := contMDiffOn_extChartAt_symm x
+
+private theorem
+    NoExotic.isLocalDiffeomorphAt_of_invertible_mvfderiv {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [CompleteSpace E] [NormedAddCommGroup F] [NormedSpace ℝ F] {H M : Type*}
+    [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [I.Boundaryless] [TopologicalSpace M]
+    [ChartedSpace H M] [IsManifold I ∞ M] {f : M → F} {x : M} (hf : ContMDiff I 𝓘(ℝ, F) ∞ f)
+    (hinv : (mvfderiv I f x).IsInvertible) : IsLocalDiffeomorphAt I 𝓘(ℝ, F) ∞ f x := by
+  let c := modelChartPartialDiffeomorph (I := I) x
+  let fc : E → F := f ∘ c.symm
+  have hfc : ContDiffOn ℝ ∞ fc c.target := (hf.comp_contMDiffOn c.contMDiffOn_invFun).contDiffOn
+  have hc : x ∈ c.source := mem_extChartAt_source x
+  have hderiv : mvfderiv I f x = fderiv ℝ fc (c x) := by
+    simpa [fc, c, modelChartPartialDiffeomorph, writtenInExtChartAt, extChartAt_self_eq,
+      chartAt_self_eq, ModelWithCorners.range_eq_univ] using
+      (hf.mdifferentiable (by simp) x).mvfderiv
+  have hfcinv : (fderiv ℝ fc (c x)).IsInvertible := by
+    obtain ⟨A, hA⟩ := hinv
+    refine ⟨(tangentModelEquiv (I := I) x).symm.trans A, ?_⟩
+    apply ContinuousLinearMap.ext
+    intro v
+    exact congrArg (fun L : TangentSpace I x →L[ℝ] F ↦ L v) (hA.trans hderiv)
+  obtain ⟨d, hd, _, hdf⟩ :=
+    exists_partialDiffeomorph_of_contDiffOn c.open_target (c.map_source' hc) hfc hfcinv
+  refine ⟨c.trans d, ⟨hc, hd⟩, ?_⟩
+  intro y hy
+  change f y = d (c y)
+  rw [hdf]
+  change f y = f (c.symm (c y))
+  exact (congrArg f (c.left_inv' hy.1)).symm
+
+private theorem Smale.RegularLevel.surjective_of_ne_zero {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {L : E →L[ℝ] ℝ} (hL : L ≠ 0) : Function.Surjective L := by
+  have hex : ∃ v, L v ≠ 0 := by
+    by_contra! h
+    exact hL (ContinuousLinearMap.ext h)
+  obtain ⟨v, hv⟩ := hex
+  intro r
+  refine ⟨(r / L v) • v, ?_⟩
+  rw [map_smul, smul_eq_mul, div_mul_cancel₀ _ hv]
+
+private theorem Smale.RegularLevel.finrank_kernel_add_one {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {L : E →L[ℝ] ℝ} (hL : L ≠ 0) :
+    Module.finrank ℝ L.ker + 1 = Module.finrank ℝ E := by
+  have hr : L.range = ⊤ := LinearMap.range_eq_top.mpr (surjective_of_ne_zero hL)
+  have hdim := L.toLinearMap.finrank_range_add_finrank_ker
+  change Module.finrank ℝ L.range + Module.finrank ℝ L.ker = Module.finrank ℝ E at hdim
+  rw [hr, finrank_top, Module.finrank_self] at hdim
+  omega
+
+private theorem
+    Smale.RegularLevel.exists_height_partialDiffeomorph {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {f : E → ℝ} {U : Set E} {x : E} (hU : IsOpen U)
+    (hx : x ∈ U) (hf : ContDiffOn ℝ ∞ f U) (hreg : fderiv ℝ f x ≠ 0) :
+    ∃ Φ : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, ℝ × (fderiv ℝ f x).ker) E (ℝ × (fderiv ℝ f x).ker) ∞,
+      x ∈ Φ.source ∧ Φ.source ⊆ U ∧ (∀ y, (Φ y).1 = f y) ∧ Φ x = (f x, 0) := by
+  let L := fderiv ℝ f x
+  have hs : HasStrictFDerivAt f L x :=
+    (hf.contDiffAt (hU.mem_nhds hx)).hasStrictFDerivAt (by simp)
+  have hr : L.range = ⊤ := LinearMap.range_eq_top.mpr (surjective_of_ne_zero hreg)
+  have hk : L.ker.ClosedComplemented := L.ker_closedComplemented_of_finiteDimensional_range
+  let φ := hs.implicitFunctionDataOfComplemented f L hr hk
+  have hg : ContDiffOn ℝ ∞ φ.prodFun U := by
+    apply hf.prodMk
+    change ContDiffOn ℝ ∞ (fun y => Classical.choose hk (y - x)) U
+    exact (Classical.choose hk).contDiff.comp_contDiffOn (contDiffOn_id.sub contDiffOn_const)
+  obtain ⟨Φ, hΦ, hΦU, hΦf⟩ :=
+    NoExotic.exists_partialDiffeomorph_of_contDiffOn hU hx hg φ.isInvertible_fderiv_prodFun
+  refine ⟨Φ, hΦ, hΦU, ?_, ?_⟩
+  · intro y
+    rw [hΦf]
+    rfl
+  · rw [hΦf]
+    change (f x, Classical.choose hk (x - x)) = (f x, 0)
+    simp
+
+private abbrev Smale.RegularLevel.Model (E : Type*) [NormedAddCommGroup E] [NormedSpace ℝ E] :=
+  EuclideanSpace ℝ (Fin (Module.finrank ℝ E - 1))
+
+private theorem Smale.RegularLevel.exists_native_height_chart {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {x : M}
+    (hx : x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    ∃ Φ : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, ℝ × Model E) M (ℝ × Model E) ∞,
+      x ∈ Φ.source ∧ (∀ y ∈ Φ.source, (Φ y).1 = f y) ∧ Φ x = (f x, 0) := by
+  let e := chartAt E x
+  have he : e ∈ IsManifold.maximalAtlas 𝓘(ℝ, E) ∞ M := IsManifold.chart_mem_maximalAtlas x
+  have hxe : x ∈ e.source := mem_chart_source E x
+  let c : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M E ∞ :=
+    { e.toPartialEquiv with
+      open_source := e.open_source
+      open_target := e.open_target
+      contMDiffOn_toFun := contMDiffOn_of_mem_maximalAtlas he
+      contMDiffOn_invFun := contMDiffOn_symm_of_mem_maximalAtlas he }
+  have hreg : fderiv ℝ (f ∘ e.symm) (e x) ≠ 0 := fun h =>
+    hx ((Smale.ManifoldMorse.mem_criticalPoints_iff hf he hxe).mpr h)
+  obtain ⟨d, hd, -, hfirst, hcenter⟩ :=
+    exists_height_partialDiffeomorph e.open_target (e.map_source hxe)
+      (Smale.ManifoldMorse.contDiffOn_chartExpression hf he) hreg
+  let L := fderiv ℝ (f ∘ e.symm) (e x)
+  have hdim : Module.finrank ℝ L.ker = Module.finrank ℝ (Model E) := by
+    have hh := finrank_kernel_add_one hreg
+    change Module.finrank ℝ L.ker + 1 = Module.finrank ℝ E at hh
+    rw [finrank_euclideanSpace_fin]
+    omega
+  let j : L.ker ≃L[ℝ] Model E := ContinuousLinearEquiv.ofFinrankEq hdim
+  let J : (ℝ × L.ker) ≃L[ℝ] (ℝ × Model E) := (ContinuousLinearEquiv.refl ℝ ℝ).prodCongr j
+  let τ := J.toDiffeomorph.toPartialDiffeomorph
+  refine ⟨(c.trans d).trans τ, ⟨⟨hxe, hd⟩, Set.mem_univ _⟩, ?_, ?_⟩
+  · intro y hy
+    change (d (e y)).1 = f y
+    rw [hfirst]
+    exact congrArg f (e.left_inv hy.1.1)
+  · change J (d (e x)) = (f x, 0)
+    rw [hcenter]
+    change (f (e.symm (e x)), j 0) = (f x, 0)
+    rw [e.left_inv hxe, map_zero]
+
+private theorem
+    Smale.RegularLevel.inverse_height {M D : Type*} [TopologicalSpace M] [TopologicalSpace D]
+    {f : M → ℝ} {b : ℝ} (e : OpenPartialHomeomorph M (ℝ × D)) (he : ∀ y ∈ e.source, (e y).1 = f y)
+    {v : D} (hv : (b, v) ∈ e.target) : f (e.symm (b, v)) = b := by
+  have h := he (e.symm (b, v)) (e.map_target hv)
+  rw [e.right_inv hv] at h
+  exact h.symm
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.RegularLevel.sliceInverse {M D : Type*} [TopologicalSpace M] [TopologicalSpace D]
+    {f : M → ℝ} {b : ℝ} (e : OpenPartialHomeomorph M (ℝ × D)) (he : ∀ y ∈ e.source, (e y).1 = f y)
+    (base : { x : M // f x = b }) (v : D) : { x : M // f x = b } :=
+  if hv : (b, v) ∈ e.target then ⟨e.symm (b, v), inverse_height e he hv⟩ else base
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.RegularLevel.sliceChart {M D : Type*} [TopologicalSpace M] [TopologicalSpace D]
+    {f : M → ℝ} {b : ℝ} (e : OpenPartialHomeomorph M (ℝ × D)) (he : ∀ y ∈ e.source, (e y).1 = f y)
+    (base : { x : M // f x = b }) : OpenPartialHomeomorph { x : M // f x = b } D
+    where
+  toFun x := (e x).2
+  invFun := sliceInverse e he base
+  source := {x | (x : M) ∈ e.source}
+  target := {v | (b, v) ∈ e.target}
+  map_source' := by
+    intro x hx
+    have hp : (b, (e x).2) = e x := Prod.ext ((he x hx).trans x.property).symm rfl
+    change (b, (e x).2) ∈ e.target
+    rw [hp]
+    exact e.map_source hx
+  map_target' := by
+    intro v hv
+    change (b, v) ∈ e.target at hv
+    change (sliceInverse e he base v : M) ∈ e.source
+    simp only [sliceInverse, dite_eq_left hv]
+    exact e.map_target hv
+  left_inv' := by
+    intro x hx
+    have hp : (b, (e x).2) = e x := Prod.ext ((he x hx).trans x.property).symm rfl
+    have ht : (b, (e x).2) ∈ e.target := hp ▸ e.map_source hx
+    simp only [sliceInverse, dite_eq_left ht]
+    apply Subtype.ext
+    change e.symm (b, (e x).2) = x
+    rw [hp]
+    exact e.left_inv hx
+  right_inv' := by
+    intro v hv
+    change (b, v) ∈ e.target at hv
+    simp only [sliceInverse, dite_eq_left hv]
+    rw [e.right_inv hv]
+  open_source := e.open_source.preimage continuous_subtype_val
+  open_target := e.open_target.preimage (continuous_const.prodMk continuous_id)
+  continuousOn_toFun :=
+    continuous_snd.comp_continuousOn
+      (e.continuousOn.comp continuous_subtype_val.continuousOn (fun _ hx => hx))
+  continuousOn_invFun := by
+    apply Topology.IsInducing.subtypeVal.continuousOn_iff.mpr
+    apply
+      (e.symm.continuousOn.comp (continuous_const.prodMk continuous_id).continuousOn
+          (fun _ hv => hv)).congr
+    intro v hv
+    change (b, v) ∈ e.target at hv
+    simp only [Function.comp_apply, sliceInverse, dite_eq_left hv]
+    rfl
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.RegularLevel.sliceChart_symm_coe {M D : Type*} [TopologicalSpace M]
+    [TopologicalSpace D] {f : M → ℝ} {b : ℝ} (e : OpenPartialHomeomorph M (ℝ × D))
+    (he : ∀ y ∈ e.source, (e y).1 = f y) (base : { x : M // f x = b }) {v : D}
+    (hv : v ∈ (sliceChart e he base).target) :
+    ((sliceChart e he base).symm v : M) = e.symm (b, v) := by
+  change (b, v) ∈ e.target at hv
+  change (sliceInverse e he base v : M) = _
+  simp only [sliceInverse, dite_eq_left hv]
+
+private theorem
+    Smale.RegularLevel.contDiffOn_slice_transition {E D M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup D] [NormedSpace ℝ D] [TopologicalSpace M]
+    [ChartedSpace E M] {f : M → ℝ} {b : ℝ}
+    (Φ Ψ : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, ℝ × D) M (ℝ × D) ∞)
+    (hΦ : ∀ y ∈ Φ.source, (Φ y).1 = f y) (hΨ : ∀ y ∈ Ψ.source, (Ψ y).1 = f y)
+    (x y : { z : M // f z = b }) :
+    let c := sliceChart Φ.toOpenPartialHomeomorph hΦ x
+    let d := sliceChart Ψ.toOpenPartialHomeomorph hΨ y
+    ContDiffOn ℝ ∞ (c.symm.trans d) (c.symm.trans d).source := by
+  let c := sliceChart Φ.toOpenPartialHomeomorph hΦ x
+  let d := sliceChart Ψ.toOpenPartialHomeomorph hΨ y
+  let S := (c.symm.trans d).source
+  have hS (v : D) (hv : v ∈ S) : (b, v) ∈ Φ.target ∧ Φ.symm (b, v) ∈ Ψ.source := by
+    refine ⟨hv.1, ?_⟩
+    have hh : (c.symm v : M) ∈ Ψ.source := hv.2
+    rwa [sliceChart_symm_coe Φ.toOpenPartialHomeomorph hΦ x hv.1] at hh
+  have hfirst : ContMDiffOn 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ (fun v => Φ.symm (b, v)) S :=
+    Φ.contMDiffOn_invFun.comp ((contDiff_const.prodMk contDiff_id).contMDiff.contMDiffOn)
+      (fun v hv => (hS v hv).1)
+  have hsecond := Ψ.contMDiffOn_toFun.comp hfirst (fun v hv => (hS v hv).2)
+  have hfull : ContDiffOn ℝ ∞ (fun v => (Ψ (Φ.symm (b, v))).2) S :=
+    (contDiff_snd.contMDiff.comp_contMDiffOn hsecond).contDiffOn
+  apply hfull.congr
+  intro v hv
+  change (Ψ (c.symm v : M)).2 = (Ψ (Φ.symm (b, v))).2
+  rw [sliceChart_symm_coe Φ.toOpenPartialHomeomorph hΦ x hv.1]
+  rfl
+
+private def Smale.RegularLevel.heightChart {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    {f : M → ℝ} {b : ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (x : { x : M // f x = b }) : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, ℝ × Model E) M (ℝ × Model E) ∞ :=
+  Classical.choose (exists_native_height_chart hf (hreg x x.property))
+
+private theorem Smale.RegularLevel.heightChart_mem_source {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {b : ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (x : { x : M // f x = b }) : (x : M) ∈ (heightChart hf hreg x).source :=
+  (Classical.choose_spec (exists_native_height_chart hf (hreg x x.property))).1
+
+private theorem Smale.RegularLevel.heightChart_height {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {b : ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (x : { x : M // f x = b }) :
+    ∀ y ∈ (heightChart hf hreg x).source, (heightChart hf hreg x y).1 = f y :=
+  (Classical.choose_spec (exists_native_height_chart hf (hreg x x.property))).2.1
+
+private def Smale.RegularLevel.levelChart {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    {f : M → ℝ} {b : ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (x : { x : M // f x = b }) : OpenPartialHomeomorph { x : M // f x = b } (Model E) :=
+  sliceChart (heightChart hf hreg x).toOpenPartialHomeomorph (heightChart_height hf hreg x) x
+
+@[instance_reducible]
+private def Smale.RegularLevel.chartedSpace {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    {f : M → ℝ} {b : ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    ChartedSpace (Model E) { x : M // f x = b }
+    where
+  atlas := Set.range (levelChart hf hreg)
+  chartAt := levelChart hf hreg
+  mem_chart_source := heightChart_mem_source hf hreg
+  chart_mem_atlas := fun x => ⟨x, rfl⟩
+
+private theorem Smale.RegularLevel.isManifold {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    {f : M → ℝ} {b : ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    letI := chartedSpace hf hreg
+    IsManifold 𝓘(ℝ, Model E) ∞ { x : M // f x = b } := by
+  let _ := chartedSpace hf hreg
+  apply isManifold_of_contDiffOn
+  intro c d hc hd
+  obtain ⟨x, rfl⟩ := hc
+  obtain ⟨y, rfl⟩ := hd
+  simpa only [mfld_simps, levelChart] using
+    contDiffOn_slice_transition (heightChart hf hreg x) (heightChart hf hreg y)
+      (heightChart_height hf hreg x) (heightChart_height hf hreg y) x y
+
+private theorem Smale.RegularLevel.contMDiff_inclusion {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {b : ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    letI := chartedSpace hf hreg
+    ContMDiff 𝓘(ℝ, Model E) 𝓘(ℝ, E) ∞ (Subtype.val : { x : M // f x = b } → M) := by
+  let _ := chartedSpace hf hreg
+  let _ := isManifold hf hreg
+  intro x
+  let Φ := heightChart hf hreg x
+  let c := levelChart hf hreg x
+  have hx : x ∈ c.source := heightChart_mem_source hf hreg x
+  have hc : ContMDiffAt 𝓘(ℝ, Model E) 𝓘(ℝ, Model E) ∞ c x :=
+    contMDiffAt_of_mem_maximalAtlas (IsManifold.chart_mem_maximalAtlas x) hx
+  have ht : (b, c x) ∈ Φ.target := c.map_source hx
+  have hslice : ContMDiffAt 𝓘(ℝ, Model E) 𝓘(ℝ, E) ∞ (fun v => Φ.symm (b, v)) (c x) :=
+    (Φ.contMDiffOn_invFun.contMDiffAt (Φ.open_target.mem_nhds ht)).comp (c x)
+      (contDiff_const.prodMk contDiff_id).contMDiff.contMDiffAt
+  have hcomp := hslice.comp x hc
+  apply hcomp.congr_of_eventuallyEq
+  filter_upwards [c.open_source.mem_nhds hx] with y hy
+  change (y : M) = Φ.symm (b, c y)
+  have heq : (b, c y) = Φ y :=
+    Prod.ext ((heightChart_height hf hreg x y hy).trans y.property).symm rfl
+  rw [heq]
+  exact (Φ.left_inv' hy).symm
+
+private theorem Smale.RegularLevel.contMDiffAt_iff_inclusion {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {b : ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f) {G H X : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H] (I : ModelWithCorners ℝ G H)
+    [TopologicalSpace X] [ChartedSpace H X] (g : X → { x : M // f x = b }) (x : X) :
+    letI := chartedSpace hf hreg
+    ContMDiffAt I 𝓘(ℝ, Model E) ∞ g x ↔ ContMDiffAt I 𝓘(ℝ, E) ∞ (Subtype.val ∘ g) x := by
+  let _ := chartedSpace hf hreg
+  constructor
+  · intro hg
+    exact (Smale.RegularLevel.contMDiff_inclusion hf hreg).contMDiffAt.comp x hg
+  · intro hg
+    apply contMDiffAt_iff_target.mpr
+    refine ⟨Topology.IsInducing.subtypeVal.continuousAt_iff.mpr hg.continuousAt, ?_⟩
+    let Φ := heightChart hf hreg (g x)
+    have hΦ : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, ℝ × Model E) ∞ Φ (g x) :=
+      Φ.contMDiffOn_toFun.contMDiffAt
+        (Φ.open_source.mem_nhds (heightChart_mem_source hf hreg (g x)))
+    have hcomp := hΦ.comp x hg
+    change ContMDiffAt I 𝓘(ℝ, Model E) ∞ (fun y => (Φ (g y)).2) x
+    exact contDiff_snd.contMDiff.contMDiffAt.comp x hcomp
+
+private theorem Smale.RegularLevel.contMDiff_iff_inclusion {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {b : ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f) {G H X : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H] (I : ModelWithCorners ℝ G H)
+    [TopologicalSpace X] [ChartedSpace H X] (g : X → { x : M // f x = b }) :
+    letI := chartedSpace hf hreg
+    ContMDiff I 𝓘(ℝ, Model E) ∞ g ↔ ContMDiff I 𝓘(ℝ, E) ∞ (Subtype.val ∘ g) := by
+  let _ := chartedSpace hf hreg
+  exact forall_congr' (contMDiffAt_iff_inclusion hf hreg I g)
+
+private theorem
+    Smale.RegularLevel.injective_mfderiv_of_inclusion {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {b : ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f) {G H X : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H] (I : ModelWithCorners ℝ G H)
+    [TopologicalSpace X] [ChartedSpace H X] (g : X → { x : M // f x = b }) (x : X)
+    (hg : ContMDiffAt I 𝓘(ℝ, E) ∞ (Subtype.val ∘ g) x)
+    (hi : Function.Injective (mfderiv I 𝓘(ℝ, E) (Subtype.val ∘ g) x)) :
+    letI := chartedSpace hf hreg
+    Function.Injective (mfderiv I 𝓘(ℝ, Model E) g x) := by
+  let _ := chartedSpace hf hreg
+  have hgl := (contMDiffAt_iff_inclusion hf hreg I g x).mpr hg
+  have hv := (Smale.RegularLevel.contMDiff_inclusion hf hreg).contMDiffAt (x := g x)
+  rw [mfderiv_comp x (hv.mdifferentiableAt (by simp)) (hgl.mdifferentiableAt (by simp))] at hi
+  exact fun v w hvw =>
+    hi
+      (congrArg (mfderiv 𝓘(ℝ, Model E) 𝓘(ℝ, E) (Subtype.val : { x : M // f x = b } → M) (g x))
+        hvw)
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    Smale.ManifoldMorse.SignedMorseChart.attachingHandleMap {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {x : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target) :
+    C(Smale.MorseHandle.UnitDisk c.NegativeCoordinates ×
+        Smale.MorseHandle.UnitDisk c.PositiveCoordinates,
+      M)
+    where
+  toFun z := c.splitChart.symm (Smale.MorseHandle.modelMap ρ z)
+  continuous_toFun :=
+    c.splitChart.toOpenPartialHomeomorph.symm.continuousOn.comp_continuous
+      (Smale.MorseHandle.continuous_modelMap ρ)
+      (fun z => hblock (Smale.MorseHandle.modelMap_mem_product hρ z))
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.attachingHandleMap_injective {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {x : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target) :
+    Function.Injective (c.attachingHandleMap ρ hρ hblock) := by
+  intro z w h
+  apply Smale.MorseHandle.modelMap_injective hρ
+  exact
+    c.splitChart.toOpenPartialHomeomorph.symm.injOn
+      (hblock (Smale.MorseHandle.modelMap_mem_product hρ z))
+      (hblock (Smale.MorseHandle.modelMap_mem_product hρ w)) h
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SignedMorseChart.attachingHandleMap_isClosedEmbedding {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {x : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) [T2Space M] (ρ : ℝ)
+    (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target) :
+    Topology.IsClosedEmbedding (c.attachingHandleMap ρ hρ hblock) :=
+  (c.attachingHandleMap ρ hρ hblock).continuous.isClosedEmbedding
+    (c.attachingHandleMap_injective ρ hρ hblock)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.attachingHandleMap_quadratic {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {x : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (z :
+      Smale.MorseHandle.UnitDisk c.NegativeCoordinates ×
+        Smale.MorseHandle.UnitDisk c.PositiveCoordinates) :
+    f (c.attachingHandleMap ρ hρ hblock z) =
+      f x +
+        (-‖(Smale.MorseHandle.modelMap ρ z).1‖ ^ 2 + ‖(Smale.MorseHandle.modelMap ρ z).2‖ ^ 2) := by
+  change f (c.splitChart.symm (Smale.MorseHandle.modelMap ρ z)) = _
+  rw [c.splitChart_inverse_equation (hblock (Smale.MorseHandle.modelMap_mem_product hρ z))]
+  ring
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.attachingHandleMap_lower_iff {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {x : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (z :
+      Smale.MorseHandle.UnitDisk c.NegativeCoordinates ×
+        Smale.MorseHandle.UnitDisk c.PositiveCoordinates) :
+    f (c.attachingHandleMap ρ hρ hblock z) ≤ f x - ρ ^ 2 ↔ ‖(z.1 : c.NegativeCoordinates)‖ = 1 := by
+  rw [c.attachingHandleMap_quadratic, sub_eq_add_neg, add_le_add_iff_left]
+  exact Smale.MorseHandle.modelMap_lower_iff hρ z
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.attachingHandleMap_upper {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {x : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (z :
+      Smale.MorseHandle.UnitDisk c.NegativeCoordinates ×
+        Smale.MorseHandle.UnitDisk c.PositiveCoordinates) :
+    f (c.attachingHandleMap ρ hρ hblock z) ≤ f x + ρ ^ 2 := by
+  rw [c.attachingHandleMap_quadratic]
+  exact add_le_add le_rfl (Smale.MorseHandle.modelMap_upper hρ z)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.range_attachingHandleMap_mem_nhds {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target) :
+    Set.range (c.attachingHandleMap ρ hρ hblock) ∈ 𝓝 p := by
+  let e := c.splitChart.toOpenPartialHomeomorph
+  have hzero : (0 : c.NegativeCoordinates × c.PositiveCoordinates) ∈ e.target := by
+    rw [← c.splitChart_center]
+    exact e.map_source c.splitChart_mem_source
+  have hinv : e.symm 0 = p := by
+    rw [← c.splitChart_center]
+    exact e.left_inv c.splitChart_mem_source
+  have hnhds :=
+    e.symm.image_mem_nhds hzero
+      (Smale.MorseHandle.range_modelMap_mem_nhds_zero (N := c.NegativeCoordinates) (P :=
+        c.PositiveCoordinates) hρ)
+  rw [hinv] at hnhds
+  apply Filter.mem_of_superset hnhds
+  rintro _ ⟨_, ⟨z, rfl⟩, rfl⟩
+  exact ⟨z, rfl⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SignedMorseChart.mem_interior_range_attachingHandleMap {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target) :
+    p ∈ interior (Set.range (c.attachingHandleMap ρ hρ hblock)) :=
+  mem_interior_iff_mem_nhds.mpr (c.range_attachingHandleMap_mem_nhds ρ hρ hblock)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.mem_range_attachingHandleMap_iff {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    {y : M} (hy : y ∈ c.splitChart.source) :
+    y ∈ Set.range (c.attachingHandleMap ρ hρ hblock) ↔
+      c.splitChart y ∈ Set.range (Smale.MorseHandle.modelMap ρ) := by
+  constructor
+  · rintro ⟨z, rfl⟩
+    refine ⟨z, ?_⟩
+    exact
+      (c.splitChart.toOpenPartialHomeomorph.right_inv
+          (hblock (Smale.MorseHandle.modelMap_mem_product hρ z))).symm
+  · rintro ⟨z, hz⟩
+    refine ⟨z, ?_⟩
+    change c.splitChart.symm (Smale.MorseHandle.modelMap ρ z) = y
+    rw [hz]
+    exact c.splitChart.toOpenPartialHomeomorph.left_inv hy
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.mem_range_attachingHandleMap_iff_inequalities
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {f : M → ℝ} {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ)
+    (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    {y : M} (hy : y ∈ c.splitChart.source) :
+    y ∈ Set.range (c.attachingHandleMap ρ hρ hblock) ↔
+      ‖(c.splitChart y).2‖ ≤ ρ ∧ f p - ρ ^ 2 ≤ f y := by
+  rw [c.mem_range_attachingHandleMap_iff ρ hρ hblock hy,
+    Smale.MorseHandle.mem_range_modelMap_iff hρ]
+  apply and_congr_right
+  intro _
+  rw [c.splitChart_equation hy]
+  constructor <;> intro h <;> linarith
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.mem_attachingUnion_iff_model {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    {y : M} (hy : y ∈ c.splitChart.source) :
+    y ∈ {z | f z ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock) ↔
+      c.splitChart y ∈
+        {z | Smale.MorseHandle.quadratic z ≤ -(ρ ^ 2)} ∪
+          Set.range (Smale.MorseHandle.modelMap ρ) := by
+  change
+    (f y ≤ f p - ρ ^ 2 ∨ y ∈ Set.range (c.attachingHandleMap ρ hρ hblock)) ↔
+      (Smale.MorseHandle.quadratic (c.splitChart y) ≤ -(ρ ^ 2) ∨
+        c.splitChart y ∈ Set.range (Smale.MorseHandle.modelMap ρ))
+  rw [c.mem_range_attachingHandleMap_iff ρ hρ hblock hy]
+  apply or_congr_left
+  rw [c.splitChart_equation hy]
+  unfold Smale.MorseHandle.quadratic
+  constructor <;> intro h <;> linarith
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SignedMorseChart.mem_interior_attachingUnion_of_model {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    {y : M} (hy : y ∈ c.splitChart.source)
+    (hi :
+      c.splitChart y ∈
+        interior
+          ({z | Smale.MorseHandle.quadratic z ≤ -(ρ ^ 2)} ∪
+            Set.range (Smale.MorseHandle.modelMap ρ))) :
+    y ∈ interior ({z | f z ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock)) := by
+  apply mem_interior_iff_mem_nhds.mpr
+  have hp :=
+    (c.splitChart.toOpenPartialHomeomorph.continuousAt hy).preimage_mem_nhds
+      (mem_interior_iff_mem_nhds.mp hi)
+  apply Filter.mem_of_superset (Filter.inter_mem (c.splitChart.open_source.mem_nhds hy) hp)
+  intro z hz
+  exact (c.mem_attachingUnion_iff_model ρ hρ hblock hz.1).mpr hz.2
+
+private def
+    Smale.MorseHandle.attachmentRegion {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (ρ : ℝ) : Set (N × P) :=
+  {z | quadratic z ≤ -(ρ ^ 2)} ∪ Set.range (modelMap ρ)
+
+private theorem Smale.MorseHandle.continuous_quadratic {N P : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] : Continuous (quadratic (N := N) (P := P)) := by
+  unfold quadratic
+  fun_prop
+
+private theorem Smale.MorseHandle.isClosed_attachmentRegion {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ : ℝ} (hρ : 0 < ρ) :
+    IsClosed (attachmentRegion (N := N) (P := P) ρ) := by
+  have heq :
+    attachmentRegion (N := N) (P := P) ρ = {z | quadratic z ≤ -(ρ ^ 2)} ∪ {z | ‖z.2‖ ≤ ρ} := by
+    ext z
+    exact mem_lower_union_handle_iff hρ z
+  rw [heq]
+  exact
+    (isClosed_le continuous_quadratic continuous_const).union
+      (isClosed_le continuous_snd.norm continuous_const)
+
+private theorem Smale.MorseHandle.notMem_interior_attachmentRegion_of_bounds {N P : Type*}
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ : ℝ}
+    (hρ : 0 < ρ) (z : N × P) (hq : -(ρ ^ 2) ≤ quadratic z) (hv : ρ ≤ ‖z.2‖) :
+    z ∉ interior (attachmentRegion ρ) := by
+  intro hi
+  have hpath : ContinuousAt (fun r : ℝ => (z.1, r • z.2)) 1 := by fun_prop
+  have hnear : ∀ᶠ r : ℝ in 𝓝 1, (z.1, r • z.2) ∈ attachmentRegion ρ := by
+    apply hpath.preimage_mem_nhds
+    simpa only [one_smul, Prod.eta] using mem_interior_iff_mem_nhds.mp hi
+  obtain ⟨r, hr, hmem⟩ := hnear.exists_gt
+  have hrpos : 0 < r := lt_trans zero_lt_one hr
+  have hvpos : 0 < ‖z.2‖ := hρ.trans_le hv
+  have hnorm : ‖r • z.2‖ = r * ‖z.2‖ := by rw [norm_smul, Real.norm_eq_abs, abs_of_pos hrpos]
+  have hnormlt : ‖z.2‖ < ‖r • z.2‖ := by
+    rw [hnorm]
+    nlinarith
+  have hquadlt : quadratic z < quadratic (z.1, r • z.2) := by
+    unfold quadratic
+    nlinarith [norm_nonneg (r • z.2), norm_nonneg z.2]
+  rcases (mem_lower_union_handle_iff hρ (z.1, r • z.2)).mp hmem with h | h
+  · exact (not_lt_of_ge h) (hq.trans_lt hquadlt)
+  · exact (not_lt_of_ge h) (hv.trans_lt hnormlt)
+
+private theorem
+    Smale.MorseHandle.mem_interior_attachmentRegion_iff {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ : ℝ} (hρ : 0 < ρ) (z : N × P) :
+    z ∈ interior (attachmentRegion ρ) ↔ quadratic z < -(ρ ^ 2) ∨ ‖z.2‖ < ρ := by
+  constructor
+  · intro hi
+    by_cases hq : quadratic z < -(ρ ^ 2)
+    · exact Or.inl hq
+    by_cases hv : ‖z.2‖ < ρ
+    · exact Or.inr hv
+    exact
+      (notMem_interior_attachmentRegion_of_bounds hρ z (le_of_not_gt hq) (le_of_not_gt hv)
+          hi).elim
+  · rintro (hq | hv)
+    · apply
+        interior_maximal (t := {w | quadratic w < -(ρ ^ 2)}) _
+          (isOpen_lt continuous_quadratic continuous_const) hq
+      intro w hw
+      exact (mem_lower_union_handle_iff hρ w).mpr (Or.inl hw.le)
+    · apply
+        interior_maximal (t := {w : N × P | ‖w.2‖ < ρ}) _
+          (isOpen_lt continuous_snd.norm continuous_const) hv
+      intro w hw
+      exact (mem_lower_union_handle_iff hρ w).mpr (Or.inr hw.le)
+
+private theorem
+    Smale.MorseHandle.mem_frontier_attachmentRegion_iff {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ : ℝ} (hρ : 0 < ρ) (z : N × P) :
+    z ∈ frontier (attachmentRegion ρ) ↔
+      (quadratic z = -(ρ ^ 2) ∧ ρ ≤ ‖z.2‖) ∨ (‖z.2‖ = ρ ∧ -(ρ ^ 2) ≤ quadratic z) := by
+  rw [frontier, (isClosed_attachmentRegion hρ).closure_eq]
+  change (z ∈ attachmentRegion ρ ∧ z ∉ interior (attachmentRegion ρ)) ↔ _
+  rw [mem_interior_attachmentRegion_iff hρ]
+  rw [show z ∈ attachmentRegion ρ ↔ quadratic z ≤ -(ρ ^ 2) ∨ ‖z.2‖ ≤ ρ from
+      mem_lower_union_handle_iff hρ z]
+  constructor
+  · rintro ⟨hmem, hnot⟩
+    have hq : -(ρ ^ 2) ≤ quadratic z := le_of_not_gt (fun h => hnot (Or.inl h))
+    have hv : ρ ≤ ‖z.2‖ := le_of_not_gt (fun h => hnot (Or.inr h))
+    rcases hmem with h | h
+    · exact Or.inl ⟨le_antisymm h hq, hv⟩
+    · exact Or.inr ⟨le_antisymm h hv, hq⟩
+  · rintro (⟨hq, hv⟩ | ⟨hv, hq⟩)
+    · refine ⟨Or.inl hq.le, ?_⟩
+      rintro (h | h)
+      · exact hq.not_lt h
+      · exact (not_lt_of_ge hv) h
+    · refine ⟨Or.inr hv.le, ?_⟩
+      rintro (h | h)
+      · exact (not_lt_of_ge hq) h
+      · exact hv.not_lt h
+
+private theorem Smale.MorseHandle.modelMap_mem_frontier_attachmentRegion_iff {N P : Type*}
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ : ℝ}
+    (hρ : 0 < ρ) (z : UnitDisk N × UnitDisk P) :
+    modelMap ρ z ∈ frontier (attachmentRegion ρ) ↔ ‖(z.2 : P)‖ = 1 := by
+  have hv : ‖(z.2 : P)‖ ≤ 1 := mem_closedBall_zero_iff.mp z.2.property
+  have hnorm : ‖(modelMap ρ z).2‖ = ρ * ‖(z.2 : P)‖ := by
+    change ‖ρ • (z.2 : P)‖ = _
+    rw [norm_smul, Real.norm_eq_abs, abs_of_pos hρ]
+  rw [mem_frontier_attachmentRegion_iff hρ]
+  constructor
+  · intro hz
+    have hlo : ρ ≤ ‖(modelMap ρ z).2‖ := by
+      rcases hz with hz | hz
+      · exact hz.2
+      · exact hz.1.ge
+    rw [hnorm] at hlo
+    nlinarith
+  · intro hz
+    refine Or.inr ⟨?_, ?_⟩
+    · rw [hnorm, hz, mul_one]
+    · exact ((mem_range_modelMap_iff hρ (modelMap ρ z)).mp ⟨z, rfl⟩).2
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SignedMorseChart.mem_interior_attachingUnion_iff_model {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    {y : M} (hy : y ∈ c.splitChart.source) :
+    y ∈ interior ({z | f z ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock)) ↔
+      c.splitChart y ∈ interior (Smale.MorseHandle.attachmentRegion ρ) := by
+  constructor
+  · intro hi
+    apply mem_interior_iff_mem_nhds.mpr
+    have ht : c.splitChart y ∈ c.splitChart.target := c.splitChart.map_source' hy
+    have hc : ContinuousAt c.splitChart.symm (c.splitChart y) :=
+      c.splitChart.toOpenPartialHomeomorph.symm.continuousAt ht
+    have hleft : c.splitChart.symm (c.splitChart y) = y := c.splitChart.left_inv' hy
+    have hnear :
+      c.splitChart.symm ⁻¹'
+          interior ({z | f z ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock)) ∈
+        𝓝 (c.splitChart y) :=
+      hc.preimage_mem_nhds
+        (by
+          rw [hleft]
+          exact isOpen_interior.mem_nhds hi)
+    apply Filter.mem_of_superset (Filter.inter_mem (c.splitChart.open_target.mem_nhds ht) hnear)
+    intro z hz
+    have hmem :=
+      (c.mem_attachingUnion_iff_model ρ hρ hblock (c.splitChart.map_target' hz.1)).mp
+        (interior_subset hz.2)
+    rwa [c.splitChart.right_inv' hz.1] at hmem
+  · exact c.mem_interior_attachingUnion_of_model ρ hρ hblock hy
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SignedMorseChart.mem_frontier_attachingUnion_iff_model {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) [T2Space M]
+    (hf : Continuous f) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    {y : M} (hy : y ∈ c.splitChart.source) :
+    y ∈ frontier ({z | f z ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock)) ↔
+      c.splitChart y ∈ frontier (Smale.MorseHandle.attachmentRegion ρ) := by
+  have hA : IsClosed ({z | f z ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock)) :=
+    (isClosed_le hf continuous_const).union
+      (c.attachingHandleMap_isClosedEmbedding ρ hρ hblock).isClosed_range
+  rw [frontier, frontier, hA.closure_eq,
+    (Smale.MorseHandle.isClosed_attachmentRegion hρ).closure_eq]
+  exact
+    and_congr (c.mem_attachingUnion_iff_model ρ hρ hblock hy)
+      (not_congr (c.mem_interior_attachingUnion_iff_model ρ hρ hblock hy))
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SignedMorseChart.attachingHandleMap_mem_frontier_iff {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) [T2Space M]
+    (hf : Continuous f) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (z :
+      Smale.MorseHandle.UnitDisk c.NegativeCoordinates ×
+        Smale.MorseHandle.UnitDisk c.PositiveCoordinates) :
+    c.attachingHandleMap ρ hρ hblock z ∈
+        frontier ({y | f y ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock)) ↔
+      ‖(z.2 : c.PositiveCoordinates)‖ = 1 := by
+  have ht := hblock (Smale.MorseHandle.modelMap_mem_product hρ z)
+  have hy : c.attachingHandleMap ρ hρ hblock z ∈ c.splitChart.source :=
+    c.splitChart.map_target' ht
+  rw [c.mem_frontier_attachingUnion_iff_model hf ρ hρ hblock hy]
+  have heq : c.splitChart (c.attachingHandleMap ρ hρ hblock z) = Smale.MorseHandle.modelMap ρ z :=
+    c.splitChart.right_inv' ht
+  rw [heq, Smale.MorseHandle.modelMap_mem_frontier_attachmentRegion_iff hρ]
+
+private def
+    Smale.ClosedAttachment.Rel {K M : Type*} [TopologicalSpace K] [TopologicalSpace M] (A : Set M)
+    (B : Set K) (h : C(K, M)) : A ⊕ K → A ⊕ K → Prop
+  | .inl a, .inr k => k ∈ B ∧ (a : M) = h k
+  | _, _ => False
+
+private abbrev Smale.ClosedAttachment.Space {K M : Type*} [TopologicalSpace K] [TopologicalSpace M]
+    (A : Set M) (B : Set K) (h : C(K, M)) :=
+  Quot (Smale.ClosedAttachment.Rel A B h)
+
+private def Smale.ClosedAttachment.sumMap {K M : Type*} [TopologicalSpace K] [TopologicalSpace M]
+    (A : Set M) (h : C(K, M)) : A ⊕ K → ↥(A ∪ Set.range h)
+  | .inl a => ⟨a, Or.inl a.2⟩
+  | .inr k => ⟨h k, Or.inr ⟨k, rfl⟩⟩
+
+private theorem Smale.ClosedAttachment.continuous_sumMap {K M : Type*} [TopologicalSpace K]
+    [TopologicalSpace M] (A : Set M) (h : C(K, M)) : Continuous (sumMap A h) :=
+  continuous_sum_dom.mpr ⟨continuous_subtype_val.subtype_mk _, h.continuous.subtype_mk _⟩
+
+private theorem Smale.ClosedAttachment.sumMap_respects {K M : Type*} [TopologicalSpace K]
+    [TopologicalSpace M] (A : Set M) (B : Set K) (h : C(K, M)) (x y : A ⊕ K)
+    (hxy : Smale.ClosedAttachment.Rel A B h x y) : sumMap A h x = sumMap A h y := by
+  cases x with
+  | inl a =>
+    cases y with
+    | inl a' => exact hxy.elim
+    | inr k => exact Subtype.ext hxy.2
+  | inr k => cases y <;> exact hxy.elim
+
+private def
+    Smale.ClosedAttachment.quotientMap {K M : Type*} [TopologicalSpace K] [TopologicalSpace M]
+    (A : Set M) (B : Set K) (h : C(K, M)) : Space A B h → ↥(A ∪ Set.range h) :=
+  Quot.lift (sumMap A h) (sumMap_respects A B h)
+
+private theorem Smale.ClosedAttachment.continuous_quotientMap {K M : Type*} [TopologicalSpace K]
+    [TopologicalSpace M] (A : Set M) (B : Set K) (h : C(K, M)) : Continuous (quotientMap A B h) :=
+  continuous_quot_lift (sumMap_respects A B h) (Smale.ClosedAttachment.continuous_sumMap A h)
+
+private theorem Smale.ClosedAttachment.quotientMap_injective {K M : Type*} [TopologicalSpace K]
+    [TopologicalSpace M] (A : Set M) (B : Set K) (h : C(K, M)) (hinj : Function.Injective h)
+    (hface : ∀ k, h k ∈ A ↔ k ∈ B) : Function.Injective (quotientMap A B h) := by
+  intro q r
+  induction q using Quot.inductionOn with
+  | _ x =>
+    induction r using Quot.inductionOn with
+    | _ y =>
+      intro heq
+      have heq' := congrArg Subtype.val heq
+      cases x with
+      | inl a =>
+        cases y with
+        | inl a' =>
+          have haa : a = a' := Subtype.ext heq'
+          subst a'
+          rfl
+        | inr k =>
+          change (a : M) = h k at heq'
+          have hk : h k ∈ A := by rw [← heq']; exact a.2
+          exact Quot.sound ⟨(hface k).mp hk, heq'⟩
+      | inr k =>
+        cases y with
+        | inl a =>
+          change h k = (a : M) at heq'
+          have hk : h k ∈ A := by rw [heq']; exact a.2
+          exact
+            (Quot.sound (r := Smale.ClosedAttachment.Rel A B h) (a := .inl a) (b := .inr k)
+                ⟨(hface k).mp hk, heq'.symm⟩).symm
+        | inr k' =>
+          have hkk : k = k' := hinj heq'
+          subst k'
+          rfl
+
+private theorem Smale.ClosedAttachment.quotientMap_surjective {K M : Type*} [TopologicalSpace K]
+    [TopologicalSpace M] (A : Set M) (B : Set K) (h : C(K, M)) :
+    Function.Surjective (quotientMap A B h) := by
+  rintro ⟨x, hx | ⟨k, rfl⟩⟩
+  · exact ⟨Quot.mk _ (.inl ⟨x, hx⟩), rfl⟩
+  · exact ⟨Quot.mk _ (.inr k), rfl⟩
+
+private def
+    Smale.ClosedAttachment.unionHomeomorph {K M : Type*} [TopologicalSpace K] [TopologicalSpace M]
+    (A : Set M) (B : Set K) (h : C(K, M)) [CompactSpace K] [T2Space M] (hA : IsCompact A)
+    (hinj : Function.Injective h) (hface : ∀ k, h k ∈ A ↔ k ∈ B) :
+    Space A B h ≃ₜ ↥(A ∪ Set.range h) := by
+  letI : CompactSpace A := isCompact_iff_compactSpace.mp hA
+  exact
+    Continuous.homeoOfEquivCompactToT2 (f :=
+      Equiv.ofBijective (quotientMap A B h)
+        ⟨quotientMap_injective A B h hinj hface, quotientMap_surjective A B h⟩)
+      (continuous_quotientMap A B h)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SignedMorseChart.attachingHandleMap_boundary_height {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {x : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (z :
+      Smale.MorseHandle.UnitDisk c.NegativeCoordinates ×
+        Smale.MorseHandle.UnitDisk c.PositiveCoordinates)
+    (hz : ‖(z.1 : c.NegativeCoordinates)‖ = 1) :
+    f (c.attachingHandleMap ρ hρ hblock z) = f x - ρ ^ 2 := by
+  rw [c.attachingHandleMap_quadratic, Smale.MorseHandle.modelMap_height hρ z, hz]
+  ring
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    Smale.ManifoldMorse.SignedMorseChart.attachingBoundaryMap {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {x : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target) :
+    C(Metric.sphere (0 : c.NegativeCoordinates) 1 ×
+        Smale.MorseHandle.UnitDisk c.PositiveCoordinates,
+      { y : M // f y = f x - ρ ^ 2 })
+    where
+  toFun
+    z :=
+    ⟨c.attachingHandleMap ρ hρ hblock (⟨z.1, Metric.sphere_subset_closedBall z.1.2⟩, z.2),
+      c.attachingHandleMap_boundary_height ρ hρ hblock _
+        (by simpa only [Metric.mem_sphere, dist_zero_right] using z.1.2)⟩
+  continuous_toFun :=
+    ((c.attachingHandleMap ρ hρ hblock).continuous.comp
+          (((continuous_subtype_val.comp continuous_fst).subtype_mk _).prodMk
+            continuous_snd)).subtype_mk
+      _
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.SignedMorseChart.attachingHandleUnionHomeomorph {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {x : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) [T2Space M] [CompactSpace M]
+    (hf : Continuous f) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target) :
+    Smale.ClosedAttachment.Space {y : M | f y ≤ f x - ρ ^ 2}
+        {z | ‖(z.1 : c.NegativeCoordinates)‖ = 1} (c.attachingHandleMap ρ hρ hblock) ≃ₜ
+      ↥({y : M | f y ≤ f x - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock)) :=
+  Smale.ClosedAttachment.unionHomeomorph _ _ _ (isClosed_le hf continuous_const).isCompact
+    (c.attachingHandleMap_injective ρ hρ hblock)
+    (fun z => c.attachingHandleMap_lower_iff ρ hρ hblock z)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.attachingHandleUnion_subset_upper {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {x : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target) :
+    {y : M | f y ≤ f x - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock) ⊆
+      {y : M | f y ≤ f x + ρ ^ 2} := by
+  rintro y (hy | ⟨z, rfl⟩)
+  · change f y ≤ f x + ρ ^ 2
+    change f y ≤ f x - ρ ^ 2 at hy
+    nlinarith [sq_nonneg ρ]
+  · exact c.attachingHandleMap_upper ρ hρ hblock z
+
+private def
+    Smale.RadialExtension.direction {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] (x : E)
+    (hx : x ≠ 0) : Metric.sphere (0 : E) 1 :=
+  ⟨‖x‖⁻¹ • x, by simp [norm_smul, hx]⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.RadialExtension.radial {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (f : Metric.sphere (0 : E) 1 → Metric.sphere (0 : F) 1) (x : E) : F :=
+  if hx : x = 0 then 0 else ‖x‖ • (f (direction x hx) : F)
+
+@[simp]
+private theorem
+    Smale.RadialExtension.radial_zero {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (f : Metric.sphere (0 : E) 1 → Metric.sphere (0 : F) 1) : radial f 0 = 0 := by simp [radial]
+
+private theorem Smale.RadialExtension.radial_of_ne_zero {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (f : Metric.sphere (0 : E) 1 → Metric.sphere (0 : F) 1) {x : E} (hx : x ≠ 0) :
+    radial f x = ‖x‖ • (f (direction x hx) : F) := by simp [radial, hx]
+
+@[simp]
+private theorem
+    Smale.RadialExtension.norm_radial {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (f : Metric.sphere (0 : E) 1 → Metric.sphere (0 : F) 1) (x : E) : ‖radial f x‖ = ‖x‖ := by
+  by_cases hx : x = 0
+  · subst x
+    simp
+  rw [radial_of_ne_zero f hx, norm_smul, Real.norm_eq_abs, abs_of_nonneg (norm_nonneg x),
+    mem_sphere_zero_iff_norm.mp (f (direction x hx)).property, mul_one]
+
+@[simp]
+private theorem Smale.RadialExtension.radial_eq_zero_iff {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (f : Metric.sphere (0 : E) 1 → Metric.sphere (0 : F) 1) (x : E) : radial f x = 0 ↔ x = 0 := by
+  rw [← norm_eq_zero, norm_radial, norm_eq_zero]
+
+private theorem Smale.RadialExtension.direction_radial {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (f : Metric.sphere (0 : E) 1 → Metric.sphere (0 : F) 1) {x : E} (hx : x ≠ 0) :
+    direction (radial f x) (fun h => hx ((radial_eq_zero_iff f x).mp h)) = f (direction x hx) := by
+  apply Subtype.ext
+  change ‖radial f x‖⁻¹ • radial f x = (f (direction x hx) : F)
+  rw [norm_radial, radial_of_ne_zero f hx, inv_smul_smul₀ (norm_ne_zero_iff.mpr hx)]
+
+@[simp]
+private theorem Smale.RadialExtension.radial_id {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (x : E) : radial id x = x := by
+  by_cases hx : x = 0
+  · subst x
+    simp
+  rw [radial_of_ne_zero id hx]
+  exact smul_inv_smul₀ (norm_ne_zero_iff.mpr hx) x
+
+private theorem
+    Smale.RadialExtension.radial_comp {E F G : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    (g : Metric.sphere (0 : F) 1 → Metric.sphere (0 : G) 1)
+    (f : Metric.sphere (0 : E) 1 → Metric.sphere (0 : F) 1) (x : E) :
+    radial g (radial f x) = radial (g ∘ f) x := by
+  by_cases hx : x = 0
+  · subst x
+    simp
+  have hy : radial f x ≠ 0 := fun h => hx ((radial_eq_zero_iff f x).mp h)
+  rw [radial_of_ne_zero g hy, norm_radial, direction_radial f hx, radial_of_ne_zero (g ∘ f) hx]
+  rfl
+
+@[simp]
+private theorem Smale.RadialExtension.radial_on_sphere {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (f : Metric.sphere (0 : E) 1 → Metric.sphere (0 : F) 1) (x : Metric.sphere (0 : E) 1) :
+    radial f x = (f x : F) := by
+  have hn : ‖(x : E)‖ = 1 := mem_sphere_zero_iff_norm.mp x.property
+  have hx : (x : E) ≠ 0 := by
+    intro h
+    simp [h] at hn
+  have hd : direction (x : E) hx = x := by
+    apply Subtype.ext
+    simp [direction, hn]
+  rw [radial_of_ne_zero f hx, hn, hd, one_smul]
+
+private theorem Smale.RadialExtension.continuous_radial {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    {f : Metric.sphere (0 : E) 1 → Metric.sphere (0 : F) 1} (hf : Continuous f) :
+    Continuous (radial f) := by
+  have haway : ContinuousOn (radial f) ({0}ᶜ : Set E) := by
+    rw [continuousOn_iff_continuous_domRestrict]
+    have heq :
+      ({0}ᶜ : Set E).domRestrict (radial f) = fun (x : ({0}ᶜ : Set E)) =>
+        ‖(x : E)‖ • (f ((homeomorphUnitSphereProd E x).1) : F) := by
+      funext x
+      rw [Set.domRestrict_apply, radial_of_ne_zero f x.property]
+      have hd : direction (x : E) x.property = (homeomorphUnitSphereProd E x).1 := by
+        apply Subtype.ext
+        simp [direction]
+      rw [hd]
+    rw [heq]
+    exact
+      continuous_subtype_val.norm.smul
+        (continuous_subtype_val.comp (hf.comp (homeomorphUnitSphereProd E).continuous.fst))
+  rw [continuous_iff_continuousAt]
+  intro x
+  by_cases hx : x = 0
+  · subst x
+    rw [Metric.continuousAt_iff]
+    intro ε hε
+    refine ⟨ε, hε, ?_⟩
+    intro y hy
+    simpa only [radial_zero, dist_zero_right, norm_radial] using hy
+  exact (haway x hx).continuousAt (isOpen_compl_singleton.mem_nhds hx)
+
+private def Smale.RadialExtension.homeomorph {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (e : Metric.sphere (0 : E) 1 ≃ₜ Metric.sphere (0 : F) 1) : E ≃ₜ F
+    where
+  toFun := radial e
+  invFun := radial e.symm
+  left_inv
+    x := by
+    rw [radial_comp]
+    have h : (e.symm : Metric.sphere (0 : F) 1 → Metric.sphere (0 : E) 1) ∘ e = id := by
+      funext y
+      exact e.symm_apply_apply y
+    rw [h, radial_id]
+  right_inv
+    x := by
+    rw [radial_comp]
+    have h : (e : Metric.sphere (0 : E) 1 → Metric.sphere (0 : F) 1) ∘ e.symm = id := by
+      funext y
+      exact e.apply_symm_apply y
+    rw [h, radial_id]
+  continuous_toFun := continuous_radial e.continuous
+  continuous_invFun := continuous_radial e.symm.continuous
+
+private def Smale.RadialExtension.closedBallHomeomorph {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (e : Metric.sphere (0 : E) 1 ≃ₜ Metric.sphere (0 : F) 1) :
+    Metric.closedBall (0 : E) 1 ≃ₜ Metric.closedBall (0 : F) 1 :=
+  (homeomorph e).sets
+    (by
+      ext x
+      simp [homeomorph])
+
+@[simp]
+private theorem
+    Smale.RadialExtension.closedBallHomeomorph_on_sphere {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (e : Metric.sphere (0 : E) 1 ≃ₜ Metric.sphere (0 : F) 1) (x : Metric.sphere (0 : E) 1) :
+    closedBallHomeomorph e ⟨x, Metric.sphere_subset_closedBall x.property⟩ =
+      ⟨e x, Metric.sphere_subset_closedBall (e x).property⟩ := by
+  apply Subtype.ext
+  exact radial_on_sphere e x
+
+private abbrev Smale.PuncturedHandle.Radius :=
+  Set.Ioc (0 : ℝ) 1
+
+private abbrev Smale.PuncturedHandle.UnitSphere (E : Type*) [NormedAddCommGroup E] :=
+  Metric.sphere (0 : E) 1
+
+private abbrev Smale.PuncturedHandle.PuncturedBall (E : Type*) [NormedAddCommGroup E] :=
+  { x : E // x ≠ 0 ∧ ‖x‖ ≤ 1 }
+
+private def Smale.PuncturedHandle.point {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (u : UnitSphere E) (r : Radius) : PuncturedBall E := by
+  have hn : ‖(u : E)‖ = 1 := mem_sphere_zero_iff_norm.mp u.property
+  have hnorm : ‖(r : ℝ) • (u : E)‖ = (r : ℝ) := by
+    rw [norm_smul, Real.norm_eq_abs, abs_of_pos r.property.1, hn, mul_one]
+  refine ⟨(r : ℝ) • (u : E), ?_, ?_⟩
+  · exact norm_pos_iff.mp (by rw [hnorm]; exact r.property.1)
+  · rw [hnorm]
+    exact r.property.2
+
+private theorem
+    Smale.PuncturedHandle.norm_point {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (u : UnitSphere E) (r : Radius) : ‖(point u r : E)‖ = (r : ℝ) := by
+  change ‖(r : ℝ) • (u : E)‖ = (r : ℝ)
+  rw [norm_smul, Real.norm_eq_abs, abs_of_pos r.property.1,
+    mem_sphere_zero_iff_norm.mp u.property, mul_one]
+
+private def Smale.PuncturedHandle.polar (E : Type*) [NormedAddCommGroup E] [NormedSpace ℝ E] :
+    PuncturedBall E ≃ₜ (UnitSphere E × Radius)
+    where
+  toFun
+    x :=
+    (Smale.RadialExtension.direction (x : E) x.property.1,
+      ⟨‖(x : E)‖, norm_pos_iff.mpr x.property.1, x.property.2⟩)
+  invFun p := point p.1 p.2
+  left_inv := by
+    intro x
+    apply Subtype.ext
+    change ‖(x : E)‖ • (‖(x : E)‖⁻¹ • (x : E)) = (x : E)
+    exact smul_inv_smul₀ (norm_ne_zero_iff.mpr x.property.1) (x : E)
+  right_inv := by
+    rintro ⟨u, r⟩
+    apply Prod.ext
+    · apply Subtype.ext
+      change ‖(point u r : E)‖⁻¹ • ((r : ℝ) • (u : E)) = (u : E)
+      rw [norm_point, inv_smul_smul₀ r.property.1.ne']
+    · apply Subtype.ext
+      exact norm_point u r
+  continuous_toFun := by
+    have hdir :
+      Continuous
+        (fun x : PuncturedBall E => Smale.RadialExtension.direction (x : E) x.property.1) :=
+      ((continuous_subtype_val.norm.inv₀ (fun x => norm_ne_zero_iff.mpr x.property.1)).smul
+            continuous_subtype_val).subtype_mk
+        _
+    exact hdir.prodMk (continuous_subtype_val.norm.subtype_mk _)
+  continuous_invFun :=
+    ((continuous_subtype_val.comp continuous_snd).smul
+          (continuous_subtype_val.comp continuous_fst)).subtype_mk
+      _
+
+private def Smale.PuncturedHandle.exchange (E F : Type*) [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] :
+    (UnitSphere E × PuncturedBall F) ≃ₜ (PuncturedBall E × UnitSphere F) :=
+  ((Homeomorph.refl (UnitSphere E)).prodCongr (polar F)).trans
+    (((Homeomorph.refl (UnitSphere E)).prodCongr
+          (Homeomorph.prodComm (UnitSphere F) Radius)).trans
+      ((Homeomorph.prodAssoc (UnitSphere E) Radius (UnitSphere F)).symm.trans
+        ((polar E).symm.prodCongr (Homeomorph.refl (UnitSphere F)))))
+
+private theorem Smale.PuncturedHandle.exchange_apply {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] (u : UnitSphere E)
+    (v : PuncturedBall F) :
+    exchange E F (u, v) =
+      (point u ⟨‖(v : F)‖, norm_pos_iff.mpr v.property.1, v.property.2⟩,
+        Smale.RadialExtension.direction (v : F) v.property.1) :=
+  rfl
+
+private def
+    Smale.PuncturedHandle.boundaryPoint {E : Type*} [NormedAddCommGroup E] (u : UnitSphere E) :
+    PuncturedBall E :=
+  ⟨u, Metric.ne_of_mem_sphere u.property one_ne_zero, (mem_sphere_zero_iff_norm.mp u.property).le⟩
+
+private theorem Smale.PuncturedHandle.exchange_boundary {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] (u : UnitSphere E)
+    (v : UnitSphere F) : exchange E F (u, boundaryPoint v) = (boundaryPoint u, v) := by
+  rw [exchange_apply]
+  have hv : ‖(v : F)‖ = 1 := mem_sphere_zero_iff_norm.mp v.property
+  apply Prod.ext
+  · apply Subtype.ext
+    change ‖(v : F)‖ • (u : E) = (u : E)
+    rw [hv, one_smul]
+  · apply Subtype.ext
+    change ‖(v : F)‖⁻¹ • (v : F) = (v : F)
+    rw [hv, inv_one, one_smul]
+
+private abbrev Smale.PuncturedHandle.UnitBall (E : Type*) [NormedAddCommGroup E] :=
+  { x : E // ‖x‖ ≤ 1 }
+
+private def Smale.PuncturedHandle.ballZero {E : Type*} [NormedAddCommGroup E] : UnitBall E :=
+  ⟨0, by simp⟩
+
+private def
+    Smale.PuncturedHandle.sphereToBall {E : Type*} [NormedAddCommGroup E] (u : UnitSphere E) :
+    UnitBall E :=
+  ⟨u, (mem_sphere_zero_iff_norm.mp u.property).le⟩
+
+private def Smale.PuncturedHandle.puncturedToBall {E : Type*} [NormedAddCommGroup E]
+    (u : PuncturedBall E) : UnitBall E :=
+  ⟨u, u.property.2⟩
+
+private theorem Smale.PuncturedHandle.puncturedToBall_injective {E : Type*} [NormedAddCommGroup E] :
+    Function.Injective (puncturedToBall (E := E)) := fun _ _ h =>
+  Subtype.ext (congrArg (fun z : UnitBall E => (z : E)) h)
+
+private def
+    Smale.PuncturedHandle.oldBoundary {E F : Type*} [NormedAddCommGroup E] [NormedAddCommGroup F]
+    (q : UnitSphere E × UnitSphere F) : UnitSphere E × UnitBall F :=
+  (q.1, sphereToBall q.2)
+
+private def
+    Smale.PuncturedHandle.newBoundary {E F : Type*} [NormedAddCommGroup E] [NormedAddCommGroup F]
+    (q : UnitSphere E × UnitSphere F) : UnitBall E × UnitSphere F :=
+  (sphereToBall q.1, q.2)
+
+private def
+    Smale.PuncturedHandle.oldPunctured {E F : Type*} [NormedAddCommGroup E] [NormedAddCommGroup F]
+    (p : UnitSphere E × PuncturedBall F) : UnitSphere E × UnitBall F :=
+  (p.1, puncturedToBall p.2)
+
+private def
+    Smale.PuncturedHandle.newPunctured {E F : Type*} [NormedAddCommGroup E] [NormedAddCommGroup F]
+    (p : PuncturedBall E × UnitSphere F) : UnitBall E × UnitSphere F :=
+  (puncturedToBall p.1, p.2)
+
+private theorem Smale.PuncturedHandle.oldPunctured_injective {E F : Type*} [NormedAddCommGroup E]
+    [NormedAddCommGroup F] : Function.Injective (oldPunctured (E := E) (F := F)) := by
+  intro p q h
+  exact
+    Prod.ext (congrArg (fun z : UnitSphere E × UnitBall F => z.1) h)
+      (puncturedToBall_injective (congrArg (fun z : UnitSphere E × UnitBall F => z.2) h))
+
+private theorem Smale.PuncturedHandle.newPunctured_injective {E F : Type*} [NormedAddCommGroup E]
+    [NormedAddCommGroup F] : Function.Injective (newPunctured (E := E) (F := F)) := by
+  intro p q h
+  exact
+    Prod.ext (puncturedToBall_injective (congrArg (fun z : UnitBall E × UnitSphere F => z.1) h))
+      (congrArg (fun z : UnitBall E × UnitSphere F => z.2) h)
+
+private def Smale.PuncturedHandle.oldPuncturedDomain (E F : Type*) [NormedAddCommGroup E]
+    [NormedAddCommGroup F] :
+    (UnitSphere E × PuncturedBall F) ≃ₜ { p : UnitSphere E × UnitBall F // (p.2 : F) ≠ 0 }
+    where
+  toFun p := ⟨oldPunctured p, p.2.property.1⟩
+  invFun p := (p.val.1, ⟨p.val.2, p.property, p.val.2.property⟩)
+  left_inv := fun _ => rfl
+  right_inv := fun _ => rfl
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    change
+      Continuous
+        (fun p : UnitSphere E × PuncturedBall F =>
+          (p.1, (⟨(p.2 : F), p.2.property.2⟩ : UnitBall F)))
+    exact continuous_fst.prodMk ((continuous_subtype_val.comp continuous_snd).subtype_mk _)
+  continuous_invFun := by
+    apply Continuous.prodMk
+    · exact continuous_fst.comp continuous_subtype_val
+    · exact
+        (continuous_subtype_val.comp (continuous_snd.comp continuous_subtype_val)).subtype_mk _
+
+private def Smale.PuncturedHandle.newPuncturedDomain (E F : Type*) [NormedAddCommGroup E]
+    [NormedAddCommGroup F] :
+    (PuncturedBall E × UnitSphere F) ≃ₜ { p : UnitBall E × UnitSphere F // (p.1 : E) ≠ 0 }
+    where
+  toFun p := ⟨newPunctured p, p.1.property.1⟩
+  invFun p := (⟨p.val.1, p.property, p.val.1.property⟩, p.val.2)
+  left_inv := fun _ => rfl
+  right_inv := fun _ => rfl
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    change
+      Continuous
+        (fun p : PuncturedBall E × UnitSphere F =>
+          ((⟨(p.1 : E), p.1.property.2⟩ : UnitBall E), p.2))
+    exact ((continuous_subtype_val.comp continuous_fst).subtype_mk _).prodMk continuous_snd
+  continuous_invFun := by
+    apply Continuous.prodMk
+    · exact
+        (continuous_subtype_val.comp (continuous_fst.comp continuous_subtype_val)).subtype_mk _
+    · exact continuous_snd.comp continuous_subtype_val
+
+private theorem Smale.PuncturedHandle.oldPunctured_boundary {E F : Type*} [NormedAddCommGroup E]
+    [NormedAddCommGroup F] (q : UnitSphere E × UnitSphere F) :
+    oldPunctured (q.1, boundaryPoint q.2) = oldBoundary q :=
+  rfl
+
+private theorem Smale.PuncturedHandle.newPunctured_boundary {E F : Type*} [NormedAddCommGroup E]
+    [NormedAddCommGroup F] (q : UnitSphere E × UnitSphere F) :
+    newPunctured (boundaryPoint q.1, q.2) = newBoundary q :=
+  rfl
+
+private def
+    Smale.ClosedCover.glue {X Y : Type*} {A B : Set X} (hcover : A ∪ B = Set.univ) (f : A → Y)
+    (g : B → Y) : X → Y := by
+  classical
+    exact fun x =>
+    if hx : x ∈ A then f ⟨x, hx⟩
+    else g ⟨x, (show x ∈ A ∪ B by rw [hcover]; trivial).resolve_left hx⟩
+
+private theorem Smale.ClosedCover.glue_left {X Y : Type*} {A B : Set X} (hcover : A ∪ B = Set.univ)
+    (f : A → Y) (g : B → Y) (x : A) : glue hcover f g x = f x := by
+  classical simp only [glue, dite_eq_left x.property]
+
+private theorem Smale.ClosedCover.glue_right {X Y : Type*} {A B : Set X} (hcover : A ∪ B = Set.univ)
+    (f : A → Y) (g : B → Y) (hagree : ∀ a : A, ∀ b : B, (a : X) = b → f a = g b) (x : B) :
+    glue hcover f g x = g x := by
+  classical
+  by_cases hx : (x : X) ∈ A
+  · rw [glue, dite_eq_left hx]
+    exact hagree ⟨x, hx⟩ x rfl
+  · rw [glue, dite_eq_right hx]
+
+private theorem
+    Smale.ClosedCover.continuous_glue {X Y : Type*} [TopologicalSpace X] [TopologicalSpace Y]
+    {A B : Set X} (hcover : A ∪ B = Set.univ) (hA : IsClosed A) (hB : IsClosed B) (f : A → Y)
+    (g : B → Y) (hf : Continuous f) (hg : Continuous g)
+    (hagree : ∀ a : A, ∀ b : B, (a : X) = b → f a = g b) : Continuous (glue hcover f g) := by
+  have hleft : ContinuousOn (glue hcover f g) A := by
+    rw [continuousOn_iff_continuous_domRestrict]
+    have heq : A.domRestrict (glue hcover f g) = f := funext (fun x => glue_left hcover f g x)
+    rw [heq]
+    exact hf
+  have hright : ContinuousOn (glue hcover f g) B := by
+    rw [continuousOn_iff_continuous_domRestrict]
+    have heq : B.domRestrict (glue hcover f g) = g :=
+      funext (fun x => glue_right hcover f g hagree x)
+    rw [heq]
+    exact hg
+  apply continuousOn_univ.mp
+  rw [← hcover]
+  exact hleft.union_of_isClosed hright hA hB
+
+private def Smale.ClosedCover.homeomorph {X Y : Type*} [TopologicalSpace X] [TopologicalSpace Y]
+    {A B : Set X} {C D : Set Y} (hcover : A ∪ B = Set.univ) (hcover' : C ∪ D = Set.univ)
+    (hA : IsClosed A) (hB : IsClosed B) (hC : IsClosed C) (hD : IsClosed D) (e : A ≃ₜ C)
+    (f : B ≃ₜ D) (hcross : ∀ a : A, ∀ b : B, ((e a : C) : Y) = f b ↔ (a : X) = b) : X ≃ₜ Y := by
+  let e₀ : A → Y := fun x => e x
+  let f₀ : B → Y := fun x => f x
+  let e₁ : C → X := fun y => e.symm y
+  let f₁ : D → X := fun y => f.symm y
+  have hagree : ∀ a : A, ∀ b : B, (a : X) = b → e₀ a = f₀ b := fun a b h => (hcross a b).mpr h
+  have hagreeInv : ∀ c : C, ∀ d : D, (c : Y) = d → e₁ c = f₁ d := by
+    intro c d h
+    apply (hcross (e.symm c) (f.symm d)).mp
+    simpa only [e.apply_symm_apply, f.apply_symm_apply] using h
+  let F := glue hcover e₀ f₀
+  let G := glue hcover' e₁ f₁
+  have hleft : Function.LeftInverse G F := by
+    intro x
+    have hx : x ∈ A ∪ B := by rw [hcover]; trivial
+    rcases hx with hx | hx
+    · calc
+        G (F x) = G (e₀ ⟨x, hx⟩) := congrArg G (glue_left hcover e₀ f₀ ⟨x, hx⟩)
+        _ = e₁ (e ⟨x, hx⟩) := (glue_left hcover' e₁ f₁ (e ⟨x, hx⟩))
+        _ = x := congrArg Subtype.val (e.symm_apply_apply ⟨x, hx⟩)
+    · calc
+        G (F x) = G (f₀ ⟨x, hx⟩) := congrArg G (glue_right hcover e₀ f₀ hagree ⟨x, hx⟩)
+        _ = f₁ (f ⟨x, hx⟩) := (glue_right hcover' e₁ f₁ hagreeInv (f ⟨x, hx⟩))
+        _ = x := congrArg Subtype.val (f.symm_apply_apply ⟨x, hx⟩)
+  have hright : Function.RightInverse G F := by
+    intro y
+    have hy : y ∈ C ∪ D := by rw [hcover']; trivial
+    rcases hy with hy | hy
+    · calc
+        F (G y) = F (e₁ ⟨y, hy⟩) := congrArg F (glue_left hcover' e₁ f₁ ⟨y, hy⟩)
+        _ = e₀ (e.symm ⟨y, hy⟩) := (glue_left hcover e₀ f₀ (e.symm ⟨y, hy⟩))
+        _ = y := congrArg Subtype.val (e.apply_symm_apply ⟨y, hy⟩)
+    · calc
+        F (G y) = F (f₁ ⟨y, hy⟩) := congrArg F (glue_right hcover' e₁ f₁ hagreeInv ⟨y, hy⟩)
+        _ = f₀ (f.symm ⟨y, hy⟩) := (glue_right hcover e₀ f₀ hagree (f.symm ⟨y, hy⟩))
+        _ = y := congrArg Subtype.val (f.apply_symm_apply ⟨y, hy⟩)
+  exact
+    { toEquiv := { toFun := F, invFun := G, left_inv := hleft, right_inv := hright }
+      continuous_toFun :=
+        continuous_glue hcover hA hB e₀ f₀ (continuous_subtype_val.comp e.continuous)
+          (continuous_subtype_val.comp f.continuous) hagree
+      continuous_invFun :=
+        continuous_glue hcover' hC hD e₁ f₁ (continuous_subtype_val.comp e.symm.continuous)
+          (continuous_subtype_val.comp f.symm.continuous) hagreeInv }
+
+private def Smale.ClosedCover.homeomorphOfClosedPieces {R P Q X Y : Type*} [TopologicalSpace R]
+    [TopologicalSpace P] [TopologicalSpace Q] [TopologicalSpace X] [TopologicalSpace Y]
+    (r₀ : R → X) (r₁ : R → Y) (p₀ : P → X) (p₁ : Q → Y) (hr₀ : Topology.IsClosedEmbedding r₀)
+    (hr₁ : Topology.IsClosedEmbedding r₁) (hp₀ : Topology.IsClosedEmbedding p₀)
+    (hp₁ : Topology.IsClosedEmbedding p₁) (hcover₀ : Set.range r₀ ∪ Set.range p₀ = Set.univ)
+    (hcover₁ : Set.range r₁ ∪ Set.range p₁ = Set.univ) (e : P ≃ₜ Q)
+    (hincidence : ∀ r p, r₀ r = p₀ p ↔ r₁ r = p₁ (e p)) : X ≃ₜ Y := by
+  let a₀ := hr₀.isEmbedding.toHomeomorph
+  let a₁ := hr₁.isEmbedding.toHomeomorph
+  let b₀ := hp₀.isEmbedding.toHomeomorph
+  let b₁ := hp₁.isEmbedding.toHomeomorph
+  let a : Set.range r₀ ≃ₜ Set.range r₁ := a₀.symm.trans a₁
+  let b : Set.range p₀ ≃ₜ Set.range p₁ := b₀.symm.trans (e.trans b₁)
+  apply
+    homeomorph hcover₀ hcover₁ hr₀.isClosed_range hp₀.isClosed_range hr₁.isClosed_range
+      hp₁.isClosed_range a b
+  intro x y
+  have hx : r₀ (a₀.symm x) = (x : X) := by exact congrArg Subtype.val (a₀.apply_symm_apply x)
+  have hy : p₀ (b₀.symm y) = (y : X) := by exact congrArg Subtype.val (b₀.apply_symm_apply y)
+  change r₁ (a₀.symm x) = p₁ (e (b₀.symm y)) ↔ (x : X) = (y : X)
+  rw [← hincidence, hx, hy]
+
+private structure Smale.SurgeryBoundaryPair (E F R X Y : Type*) [NormedAddCommGroup E]
+    [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y] where
+  oldExterior : R → X
+  newExterior : R → Y
+  oldPiece : PuncturedHandle.UnitSphere E × PuncturedHandle.UnitBall F → X
+  newPiece : PuncturedHandle.UnitBall E × PuncturedHandle.UnitSphere F → Y
+  oldExterior_closed : Topology.IsClosedEmbedding oldExterior
+  newExterior_closed : Topology.IsClosedEmbedding newExterior
+  oldPiece_closed : Topology.IsClosedEmbedding oldPiece
+  newPiece_closed : Topology.IsClosedEmbedding newPiece
+  old_cover : Set.range oldExterior ∪ Set.range oldPiece = Set.univ
+  new_cover : Set.range newExterior ∪ Set.range newPiece = Set.univ
+  boundary : PuncturedHandle.UnitSphere E × PuncturedHandle.UnitSphere F → R
+  old_overlap :
+    ∀ r p, oldExterior r = oldPiece p ↔ ∃ q, r = boundary q ∧ p = PuncturedHandle.oldBoundary q
+  new_overlap :
+    ∀ r p, newExterior r = newPiece p ↔ ∃ q, r = boundary q ∧ p = PuncturedHandle.newBoundary q
+
+private def Smale.SurgeryBoundaryPair.attachingSphere {E F R X Y : Type*} [NormedAddCommGroup E]
+    [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair E F R X Y) : C(Smale.PuncturedHandle.UnitSphere E, X) :=
+  ⟨fun u => d.oldPiece (u, Smale.PuncturedHandle.ballZero),
+    d.oldPiece_closed.continuous.comp (continuous_id.prodMk continuous_const)⟩
+
+private def Smale.SurgeryBoundaryPair.beltSphere {E F R X Y : Type*} [NormedAddCommGroup E]
+    [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair E F R X Y) : C(Smale.PuncturedHandle.UnitSphere F, Y) :=
+  ⟨fun v => d.newPiece (Smale.PuncturedHandle.ballZero, v),
+    d.newPiece_closed.continuous.comp (continuous_const.prodMk continuous_id)⟩
+
+private abbrev Smale.SurgeryBoundaryPair.OldComplement {E F R X Y : Type*} [NormedAddCommGroup E]
+    [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair E F R X Y) :=
+  (Set.range d.attachingSphere)ᶜ
+
+private abbrev Smale.SurgeryBoundaryPair.NewComplement {E F R X Y : Type*} [NormedAddCommGroup E]
+    [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair E F R X Y) :=
+  (Set.range d.beltSphere)ᶜ
+
+private theorem
+    Smale.SurgeryBoundaryPair.oldPiece_mem_core_iff {E F R X Y : Type*} [NormedAddCommGroup E]
+    [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair E F R X Y)
+    (p : Smale.PuncturedHandle.UnitSphere E × Smale.PuncturedHandle.UnitBall F) :
+    d.oldPiece p ∈ Set.range d.attachingSphere ↔ (p.2 : F) = 0 := by
+  constructor
+  · rintro ⟨u, hu⟩
+    have hp : (u, (Smale.PuncturedHandle.ballZero : Smale.PuncturedHandle.UnitBall F)) = p :=
+      d.oldPiece_closed.injective hu
+    exact
+      (congrArg
+          (fun z : Smale.PuncturedHandle.UnitSphere E × Smale.PuncturedHandle.UnitBall F =>
+            (z.2 : F))
+          hp).symm
+  · intro hp
+    refine ⟨p.1, ?_⟩
+    apply congrArg d.oldPiece
+    exact Prod.ext rfl (Subtype.ext hp.symm)
+
+private theorem
+    Smale.SurgeryBoundaryPair.newPiece_mem_belt_iff {E F R X Y : Type*} [NormedAddCommGroup E]
+    [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair E F R X Y)
+    (p : Smale.PuncturedHandle.UnitBall E × Smale.PuncturedHandle.UnitSphere F) :
+    d.newPiece p ∈ Set.range d.beltSphere ↔ (p.1 : E) = 0 := by
+  constructor
+  · rintro ⟨v, hv⟩
+    have hp : ((Smale.PuncturedHandle.ballZero : Smale.PuncturedHandle.UnitBall E), v) = p :=
+      d.newPiece_closed.injective hv
+    exact
+      (congrArg
+          (fun z : Smale.PuncturedHandle.UnitBall E × Smale.PuncturedHandle.UnitSphere F =>
+            (z.1 : E))
+          hp).symm
+  · intro hp
+    refine ⟨p.2, ?_⟩
+    apply congrArg d.newPiece
+    exact Prod.ext (Subtype.ext hp.symm) rfl
+
+private theorem
+    Smale.SurgeryBoundaryPair.oldExterior_avoids {E F R X Y : Type*} [NormedAddCommGroup E]
+    [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair E F R X Y) (r : R) : d.oldExterior r ∈ d.OldComplement := by
+  rintro ⟨u, hu⟩
+  obtain ⟨q, -, hq⟩ := (d.old_overlap r (u, Smale.PuncturedHandle.ballZero)).mp hu.symm
+  have hz : (q.2 : F) = 0 :=
+    (congrArg
+        (fun z : Smale.PuncturedHandle.UnitSphere E × Smale.PuncturedHandle.UnitBall F =>
+          (z.2 : F))
+        hq).symm
+  exact (Metric.ne_of_mem_sphere q.2.property one_ne_zero) hz
+
+private theorem
+    Smale.SurgeryBoundaryPair.newExterior_avoids {E F R X Y : Type*} [NormedAddCommGroup E]
+    [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair E F R X Y) (r : R) : d.newExterior r ∈ d.NewComplement := by
+  rintro ⟨v, hv⟩
+  obtain ⟨q, -, hq⟩ := (d.new_overlap r (Smale.PuncturedHandle.ballZero, v)).mp hv.symm
+  have hz : (q.1 : E) = 0 :=
+    (congrArg
+        (fun z : Smale.PuncturedHandle.UnitBall E × Smale.PuncturedHandle.UnitSphere F =>
+          (z.1 : E))
+        hq).symm
+  exact (Metric.ne_of_mem_sphere q.1.property one_ne_zero) hz
+
+private theorem Smale.ClosedCover.isClosedEmbedding_codRestrict {A B : Type*} [TopologicalSpace A]
+    [TopologicalSpace B] {f : A → B} (hf : Topology.IsClosedEmbedding f) {s : Set B}
+    (hs : ∀ x, f x ∈ s) : Topology.IsClosedEmbedding (s.codRestrict f hs) :=
+  ⟨hf.isEmbedding.codRestrict s hs, (hf.isClosedMap.codRestrict hs).isClosed_range⟩
+
+private def Smale.SurgeryBoundaryPair.oldExteriorMap {E F R X Y : Type*} [NormedAddCommGroup E]
+    [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair E F R X Y) : R → d.OldComplement :=
+  d.OldComplement.codRestrict d.oldExterior d.oldExterior_avoids
+
+private def Smale.SurgeryBoundaryPair.newExteriorMap {E F R X Y : Type*} [NormedAddCommGroup E]
+    [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair E F R X Y) : R → d.NewComplement :=
+  d.NewComplement.codRestrict d.newExterior d.newExterior_avoids
+
+private def
+    Smale.SurgeryBoundaryPair.oldParameterComplement {E F R X Y : Type*} [NormedAddCommGroup E]
+    [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair E F R X Y) :
+    (Smale.PuncturedHandle.UnitSphere E × Smale.PuncturedHandle.PuncturedBall F) ≃ₜ
+      (d.oldPiece ⁻¹' d.OldComplement) :=
+  (Smale.PuncturedHandle.oldPuncturedDomain E F).trans
+    (Homeomorph.setCongr
+      (by
+        ext p
+        exact (not_congr (d.oldPiece_mem_core_iff p)).symm))
+
+private def
+    Smale.SurgeryBoundaryPair.newParameterComplement {E F R X Y : Type*} [NormedAddCommGroup E]
+    [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair E F R X Y) :
+    (Smale.PuncturedHandle.PuncturedBall E × Smale.PuncturedHandle.UnitSphere F) ≃ₜ
+      (d.newPiece ⁻¹' d.NewComplement) :=
+  (Smale.PuncturedHandle.newPuncturedDomain E F).trans
+    (Homeomorph.setCongr
+      (by
+        ext p
+        exact (not_congr (d.newPiece_mem_belt_iff p)).symm))
+
+private def Smale.SurgeryBoundaryPair.oldPuncturedMap {E F R X Y : Type*} [NormedAddCommGroup E]
+    [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair E F R X Y) :
+    Smale.PuncturedHandle.UnitSphere E × Smale.PuncturedHandle.PuncturedBall F →
+      d.OldComplement :=
+  d.OldComplement.restrictPreimage d.oldPiece ∘ d.oldParameterComplement
+
+private def Smale.SurgeryBoundaryPair.newPuncturedMap {E F R X Y : Type*} [NormedAddCommGroup E]
+    [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair E F R X Y) :
+    Smale.PuncturedHandle.PuncturedBall E × Smale.PuncturedHandle.UnitSphere F →
+      d.NewComplement :=
+  d.NewComplement.restrictPreimage d.newPiece ∘ d.newParameterComplement
+
+private theorem Smale.SurgeryBoundaryPair.isClosedEmbedding_oldExteriorMap {E F R X Y : Type*}
+    [NormedAddCommGroup E] [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X]
+    [TopologicalSpace Y] (d : Smale.SurgeryBoundaryPair E F R X Y) :
+    Topology.IsClosedEmbedding d.oldExteriorMap :=
+  Smale.ClosedCover.isClosedEmbedding_codRestrict d.oldExterior_closed d.oldExterior_avoids
+
+private theorem Smale.SurgeryBoundaryPair.isClosedEmbedding_newExteriorMap {E F R X Y : Type*}
+    [NormedAddCommGroup E] [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X]
+    [TopologicalSpace Y] (d : Smale.SurgeryBoundaryPair E F R X Y) :
+    Topology.IsClosedEmbedding d.newExteriorMap :=
+  Smale.ClosedCover.isClosedEmbedding_codRestrict d.newExterior_closed d.newExterior_avoids
+
+private theorem Smale.SurgeryBoundaryPair.isClosedEmbedding_oldPuncturedMap {E F R X Y : Type*}
+    [NormedAddCommGroup E] [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X]
+    [TopologicalSpace Y] (d : Smale.SurgeryBoundaryPair E F R X Y) :
+    Topology.IsClosedEmbedding d.oldPuncturedMap :=
+  (d.oldPiece_closed.restrictPreimage d.OldComplement).comp
+    d.oldParameterComplement.isClosedEmbedding
+
+private theorem Smale.SurgeryBoundaryPair.isClosedEmbedding_newPuncturedMap {E F R X Y : Type*}
+    [NormedAddCommGroup E] [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X]
+    [TopologicalSpace Y] (d : Smale.SurgeryBoundaryPair E F R X Y) :
+    Topology.IsClosedEmbedding d.newPuncturedMap :=
+  (d.newPiece_closed.restrictPreimage d.NewComplement).comp
+    d.newParameterComplement.isClosedEmbedding
+
+private theorem
+    Smale.SurgeryBoundaryPair.oldComplement_cover {E F R X Y : Type*} [NormedAddCommGroup E]
+    [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair E F R X Y) :
+    Set.range d.oldExteriorMap ∪ Set.range d.oldPuncturedMap = Set.univ := by
+  apply Set.eq_univ_iff_forall.mpr
+  intro z
+  have hz : (z : X) ∈ Set.range d.oldExterior ∪ Set.range d.oldPiece := by
+    rw [d.old_cover]
+    trivial
+  rcases hz with ⟨r, hr⟩ | ⟨p, hp⟩
+  · exact Or.inl ⟨r, Subtype.ext hr⟩
+  · have hpavoid : d.oldPiece p ∈ d.OldComplement := hp.symm ▸ z.property
+    have hpne : (p.2 : F) ≠ 0 := fun h => hpavoid ((d.oldPiece_mem_core_iff p).mpr h)
+    refine Or.inr ⟨(p.1, ⟨p.2, hpne, p.2.property⟩), Subtype.ext ?_⟩
+    exact hp
+
+private theorem
+    Smale.SurgeryBoundaryPair.newComplement_cover {E F R X Y : Type*} [NormedAddCommGroup E]
+    [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair E F R X Y) :
+    Set.range d.newExteriorMap ∪ Set.range d.newPuncturedMap = Set.univ := by
+  apply Set.eq_univ_iff_forall.mpr
+  intro z
+  have hz : (z : Y) ∈ Set.range d.newExterior ∪ Set.range d.newPiece := by
+    rw [d.new_cover]
+    trivial
+  rcases hz with ⟨r, hr⟩ | ⟨p, hp⟩
+  · exact Or.inl ⟨r, Subtype.ext hr⟩
+  · have hpavoid : d.newPiece p ∈ d.NewComplement := hp.symm ▸ z.property
+    have hpne : (p.1 : E) ≠ 0 := fun h => hpavoid ((d.newPiece_mem_belt_iff p).mpr h)
+    refine Or.inr ⟨(⟨p.1, hpne, p.1.property⟩, p.2), Subtype.ext ?_⟩
+    exact hp
+
+private theorem
+    Smale.SurgeryBoundaryPair.oldPunctured_overlap {E F R X Y : Type*} [NormedAddCommGroup E]
+    [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair E F R X Y) (r : R)
+    (p : Smale.PuncturedHandle.UnitSphere E × Smale.PuncturedHandle.PuncturedBall F) :
+    d.oldExteriorMap r = d.oldPuncturedMap p ↔
+      ∃ q, r = d.boundary q ∧ p = (q.1, Smale.PuncturedHandle.boundaryPoint q.2) := by
+  rw [Subtype.ext_iff]
+  change d.oldExterior r = d.oldPiece (Smale.PuncturedHandle.oldPunctured p) ↔ _
+  rw [d.old_overlap]
+  constructor
+  · rintro ⟨q, hr, hp⟩
+    exact
+      ⟨q, hr,
+        Smale.PuncturedHandle.oldPunctured_injective
+          (hp.trans (Smale.PuncturedHandle.oldPunctured_boundary q).symm)⟩
+  · rintro ⟨q, hr, rfl⟩
+    exact ⟨q, hr, Smale.PuncturedHandle.oldPunctured_boundary q⟩
+
+private theorem
+    Smale.SurgeryBoundaryPair.newPunctured_overlap {E F R X Y : Type*} [NormedAddCommGroup E]
+    [NormedAddCommGroup F] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair E F R X Y) (r : R)
+    (p : Smale.PuncturedHandle.PuncturedBall E × Smale.PuncturedHandle.UnitSphere F) :
+    d.newExteriorMap r = d.newPuncturedMap p ↔
+      ∃ q, r = d.boundary q ∧ p = (Smale.PuncturedHandle.boundaryPoint q.1, q.2) := by
+  rw [Subtype.ext_iff]
+  change d.newExterior r = d.newPiece (Smale.PuncturedHandle.newPunctured p) ↔ _
+  rw [d.new_overlap]
+  constructor
+  · rintro ⟨q, hr, hp⟩
+    exact
+      ⟨q, hr,
+        Smale.PuncturedHandle.newPunctured_injective
+          (hp.trans (Smale.PuncturedHandle.newPunctured_boundary q).symm)⟩
+  · rintro ⟨q, hr, rfl⟩
+    exact ⟨q, hr, Smale.PuncturedHandle.newPunctured_boundary q⟩
+
+private structure Smale.AttachmentBoundaryData (N P M : Type*) [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace M] (f : M → ℝ) (a : ℝ) where
+  handle : PuncturedHandle.UnitBall N × PuncturedHandle.UnitBall P → M
+  handle_closed : Topology.IsClosedEmbedding handle
+  height_continuous : Continuous f
+  lower_frontier : frontier {x | f x ≤ a} = {x | f x = a}
+  lower_face : ∀ z, f (handle z) = a ↔ ‖(z.1 : N)‖ = 1
+  upper_face : ∀ z, handle z ∈ frontier ({x | f x ≤ a} ∪ Set.range handle) ↔ ‖(z.2 : P)‖ = 1
+
+private abbrev Smale.AttachmentBoundaryData.Level {N P M : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace M] {f : M → ℝ} {a : ℝ}
+    (_ : Smale.AttachmentBoundaryData N P M f a) :=
+  { x : M // f x = a }
+
+private abbrev Smale.AttachmentBoundaryData.region {N P M : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace M] {f : M → ℝ} {a : ℝ}
+    (d : Smale.AttachmentBoundaryData N P M f a) : Set M :=
+  {x | f x ≤ a} ∪ Set.range d.handle
+
+private abbrev Smale.AttachmentBoundaryData.Boundary {N P M : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace M] {f : M → ℝ} {a : ℝ}
+    (d : Smale.AttachmentBoundaryData N P M f a) :=
+  frontier d.region
+
+private abbrev Smale.AttachmentBoundaryData.Exterior {N P M : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace M] {f : M → ℝ} {a : ℝ}
+    (d : Smale.AttachmentBoundaryData N P M f a) :=
+  { x : M // f x = a ∧ x ∈ d.Boundary }
+
+private def Smale.AttachmentBoundaryData.oldExterior {N P M : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace M] {f : M → ℝ} {a : ℝ}
+    (d : Smale.AttachmentBoundaryData N P M f a) : d.Exterior → d.Level := fun x =>
+  ⟨x, x.property.1⟩
+
+private def Smale.AttachmentBoundaryData.newExterior {N P M : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace M] {f : M → ℝ} {a : ℝ}
+    (d : Smale.AttachmentBoundaryData N P M f a) : d.Exterior → d.Boundary := fun x =>
+  ⟨x, x.property.2⟩
+
+private def Smale.AttachmentBoundaryData.oldPiece {N P M : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace M] {f : M → ℝ} {a : ℝ}
+    (d : Smale.AttachmentBoundaryData N P M f a)
+    (z : Smale.PuncturedHandle.UnitSphere N × Smale.PuncturedHandle.UnitBall P) : d.Level :=
+  ⟨d.handle (Smale.PuncturedHandle.sphereToBall z.1, z.2),
+    (d.lower_face _).mpr (mem_sphere_zero_iff_norm.mp z.1.property)⟩
+
+private def Smale.AttachmentBoundaryData.newPiece {N P M : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace M] {f : M → ℝ} {a : ℝ}
+    (d : Smale.AttachmentBoundaryData N P M f a)
+    (z : Smale.PuncturedHandle.UnitBall N × Smale.PuncturedHandle.UnitSphere P) : d.Boundary :=
+  ⟨d.handle (z.1, Smale.PuncturedHandle.sphereToBall z.2),
+    (d.upper_face _).mpr (mem_sphere_zero_iff_norm.mp z.2.property)⟩
+
+private def Smale.AttachmentBoundaryData.boundary {N P M : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace M] {f : M → ℝ} {a : ℝ}
+    (d : Smale.AttachmentBoundaryData N P M f a)
+    (q : Smale.PuncturedHandle.UnitSphere N × Smale.PuncturedHandle.UnitSphere P) : d.Exterior :=
+  ⟨d.handle (Smale.PuncturedHandle.sphereToBall q.1, Smale.PuncturedHandle.sphereToBall q.2),
+    (d.lower_face _).mpr (mem_sphere_zero_iff_norm.mp q.1.property),
+    (d.upper_face _).mpr (mem_sphere_zero_iff_norm.mp q.2.property)⟩
+
+private theorem
+    Smale.AttachmentBoundaryData.oldExterior_closed {N P M : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace M] {f : M → ℝ} {a : ℝ}
+    (d : Smale.AttachmentBoundaryData N P M f a) : Topology.IsClosedEmbedding d.oldExterior :=
+  Smale.ClosedCover.isClosedEmbedding_codRestrict
+    ((isClosed_eq d.height_continuous continuous_const).inter
+        isClosed_frontier).isClosedEmbedding_subtypeVal
+    (fun x => x.property.1)
+
+private theorem
+    Smale.AttachmentBoundaryData.newExterior_closed {N P M : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace M] {f : M → ℝ} {a : ℝ}
+    (d : Smale.AttachmentBoundaryData N P M f a) : Topology.IsClosedEmbedding d.newExterior :=
+  Smale.ClosedCover.isClosedEmbedding_codRestrict
+    ((isClosed_eq d.height_continuous continuous_const).inter
+        isClosed_frontier).isClosedEmbedding_subtypeVal
+    (fun x => x.property.2)
+
+private theorem
+    Smale.AttachmentBoundaryData.sphereToBall_closed {N : Type*} [NormedAddCommGroup N] :
+    Topology.IsClosedEmbedding (Smale.PuncturedHandle.sphereToBall (E := N)) :=
+  Smale.ClosedCover.isClosedEmbedding_codRestrict
+    Metric.isClosed_sphere.isClosedEmbedding_subtypeVal
+    (fun u => (mem_sphere_zero_iff_norm.mp u.property).le)
+
+private theorem Smale.AttachmentBoundaryData.oldPiece_closed {N P M : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace M] {f : M → ℝ} {a : ℝ}
+    (d : Smale.AttachmentBoundaryData N P M f a) : Topology.IsClosedEmbedding d.oldPiece := by
+  exact
+    Smale.ClosedCover.isClosedEmbedding_codRestrict
+      (d.handle_closed.comp (sphereToBall_closed.prodMap Topology.IsClosedEmbedding.id))
+      (fun z => (d.lower_face _).mpr (mem_sphere_zero_iff_norm.mp z.1.property))
+
+private theorem Smale.AttachmentBoundaryData.newPiece_closed {N P M : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace M] {f : M → ℝ} {a : ℝ}
+    (d : Smale.AttachmentBoundaryData N P M f a) : Topology.IsClosedEmbedding d.newPiece := by
+  apply Smale.ClosedCover.isClosedEmbedding_codRestrict
+  exact d.handle_closed.comp (Topology.IsClosedEmbedding.id.prodMap sphereToBall_closed)
+
+private theorem Smale.AttachmentBoundaryData.old_cover {N P M : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace M] {f : M → ℝ} {a : ℝ}
+    (d : Smale.AttachmentBoundaryData N P M f a) :
+    Set.range d.oldExterior ∪ Set.range d.oldPiece = Set.univ := by
+  apply Set.eq_univ_of_forall
+  intro x
+  by_cases hx : (x : M) ∈ Set.range d.handle
+  · obtain ⟨z, hz⟩ := hx
+    have hnorm : ‖(z.1 : N)‖ = 1 := (d.lower_face z).mp (hz ▸ x.property)
+    refine Or.inr ⟨(⟨z.1, mem_sphere_zero_iff_norm.mpr hnorm⟩, z.2), ?_⟩
+    exact Subtype.ext hz
+  · have hfront : (x : M) ∈ d.Boundary := by
+      have hlow : (x : M) ∈ frontier {y | f y ≤ a} := by
+        rw [d.lower_frontier]
+        exact x.property
+      change (x : M) ∈ frontier d.region
+      rw [frontier] at hlow ⊢
+      refine ⟨closure_mono Set.subset_union_left hlow.1, ?_⟩
+      intro hi
+      apply hlow.2
+      apply mem_interior_iff_mem_nhds.mpr
+      have hnear := mem_interior_iff_mem_nhds.mp hi
+      have hout := d.handle_closed.isClosed_range.isOpen_compl.mem_nhds hx
+      apply Filter.mem_of_superset (Filter.inter_mem hnear hout)
+      intro y hy
+      exact hy.1.resolve_right hy.2
+    exact Or.inl ⟨⟨x, x.property, hfront⟩, rfl⟩
+
+private theorem Smale.AttachmentBoundaryData.new_cover {N P M : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace M] {f : M → ℝ} {a : ℝ}
+    (d : Smale.AttachmentBoundaryData N P M f a) :
+    Set.range d.newExterior ∪ Set.range d.newPiece = Set.univ := by
+  apply Set.eq_univ_of_forall
+  intro x
+  have hclosed : IsClosed d.region :=
+    (isClosed_le d.height_continuous continuous_const).union d.handle_closed.isClosed_range
+  have hx : (x : M) ∈ d.region := by
+    have hc := frontier_subset_closure x.property
+    rwa [hclosed.closure_eq] at hc
+  rcases hx with hx | ⟨z, hz⟩
+  · have heq : f x = a := by
+      apply le_antisymm hx
+      by_contra hn
+      have hlt : f x < a := lt_of_not_ge hn
+      have hi : (x : M) ∈ interior d.region :=
+        interior_maximal (fun y (hy : f y < a) => Or.inl hy.le)
+          (isOpen_lt d.height_continuous continuous_const) hlt
+      exact x.property.2 hi
+    exact Or.inl ⟨⟨x, heq, x.property⟩, rfl⟩
+  · have hnorm : ‖(z.2 : P)‖ = 1 := (d.upper_face z).mp (hz ▸ x.property)
+    refine Or.inr ⟨(z.1, ⟨z.2, mem_sphere_zero_iff_norm.mpr hnorm⟩), ?_⟩
+    exact Subtype.ext hz
+
+private theorem Smale.AttachmentBoundaryData.old_overlap {N P M : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace M] {f : M → ℝ} {a : ℝ}
+    (d : Smale.AttachmentBoundaryData N P M f a) (r : d.Exterior)
+    (z : Smale.PuncturedHandle.UnitSphere N × Smale.PuncturedHandle.UnitBall P) :
+    d.oldExterior r = d.oldPiece z ↔
+      ∃ q, r = d.boundary q ∧ z = Smale.PuncturedHandle.oldBoundary q := by
+  constructor
+  · intro h
+    have hr : (r : M) = d.handle (Smale.PuncturedHandle.sphereToBall z.1, z.2) :=
+      congrArg Subtype.val h
+    have hnorm : ‖(z.2 : P)‖ = 1 := (d.upper_face _).mp (hr ▸ r.property.2)
+    refine ⟨(z.1, ⟨z.2, mem_sphere_zero_iff_norm.mpr hnorm⟩), Subtype.ext hr, rfl⟩
+  · rintro ⟨q, rfl, rfl⟩
+    rfl
+
+private theorem Smale.AttachmentBoundaryData.new_overlap {N P M : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace M] {f : M → ℝ} {a : ℝ}
+    (d : Smale.AttachmentBoundaryData N P M f a) (r : d.Exterior)
+    (z : Smale.PuncturedHandle.UnitBall N × Smale.PuncturedHandle.UnitSphere P) :
+    d.newExterior r = d.newPiece z ↔
+      ∃ q, r = d.boundary q ∧ z = Smale.PuncturedHandle.newBoundary q := by
+  constructor
+  · intro h
+    have hr : (r : M) = d.handle (z.1, Smale.PuncturedHandle.sphereToBall z.2) :=
+      congrArg Subtype.val h
+    have hnorm : ‖(z.1 : N)‖ = 1 := (d.lower_face _).mp (hr ▸ r.property.1)
+    refine ⟨(⟨z.1, mem_sphere_zero_iff_norm.mpr hnorm⟩, z.2), Subtype.ext hr, rfl⟩
+  · rintro ⟨q, rfl, rfl⟩
+    rfl
+
+private def Smale.AttachmentBoundaryData.surgeryBoundaryPair {N P M : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace M] {f : M → ℝ} {a : ℝ}
+    (d : Smale.AttachmentBoundaryData N P M f a) :
+    Smale.SurgeryBoundaryPair N P d.Exterior d.Level d.Boundary
+    where
+  oldExterior := d.oldExterior
+  newExterior := d.newExterior
+  oldPiece := d.oldPiece
+  newPiece := d.newPiece
+  oldExterior_closed := d.oldExterior_closed
+  newExterior_closed := d.newExterior_closed
+  oldPiece_closed := d.oldPiece_closed
+  newPiece_closed := d.newPiece_closed
+  old_cover := d.old_cover
+  new_cover := d.new_cover
+  boundary := d.boundary
+  old_overlap := d.old_overlap
+  new_overlap := d.new_overlap
+
+private def Smale.MorseHandle.unitBallHomeomorph (N : Type*) [NormedAddCommGroup N] :
+    Smale.PuncturedHandle.UnitBall N ≃ₜ UnitDisk N
+    where
+  toFun z := ⟨z, mem_closedBall_zero_iff.mpr z.property⟩
+  invFun z := ⟨z, mem_closedBall_zero_iff.mp z.property⟩
+  left_inv := fun _ => rfl
+  right_inv := fun _ => rfl
+  continuous_toFun := continuous_subtype_val.subtype_mk _
+  continuous_invFun := continuous_subtype_val.subtype_mk _
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.SignedMorseChart.handleBallCoordinates {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) :
+    (Smale.PuncturedHandle.UnitBall c.NegativeCoordinates ×
+        Smale.PuncturedHandle.UnitBall c.PositiveCoordinates) ≃ₜ
+      (Smale.MorseHandle.UnitDisk c.NegativeCoordinates ×
+        Smale.MorseHandle.UnitDisk c.PositiveCoordinates) :=
+  (Smale.MorseHandle.unitBallHomeomorph c.NegativeCoordinates).prodCongr
+    (Smale.MorseHandle.unitBallHomeomorph c.PositiveCoordinates)
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.SignedMorseChart.normHandleMap {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target) :
+    C(Smale.PuncturedHandle.UnitBall c.NegativeCoordinates ×
+        Smale.PuncturedHandle.UnitBall c.PositiveCoordinates,
+      M) :=
+  ⟨fun z => c.attachingHandleMap ρ hρ hblock (c.handleBallCoordinates z),
+    (c.attachingHandleMap ρ hρ hblock).continuous.comp c.handleBallCoordinates.continuous⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.range_normHandleMap {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target) :
+    Set.range (c.normHandleMap ρ hρ hblock) = Set.range (c.attachingHandleMap ρ hρ hblock) := by
+  ext y
+  constructor
+  · rintro ⟨z, rfl⟩
+    exact ⟨c.handleBallCoordinates z, rfl⟩
+  · rintro ⟨z, rfl⟩
+    refine ⟨c.handleBallCoordinates.symm z, ?_⟩
+    change
+      c.attachingHandleMap ρ hρ hblock
+          (c.handleBallCoordinates (c.handleBallCoordinates.symm z)) =
+        _
+    rw [c.handleBallCoordinates.apply_symm_apply]
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.SignedMorseChart.attachmentBoundaryData {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) [T2Space M]
+    (hf : Continuous f) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (hlevel : frontier {x | f x ≤ f p - ρ ^ 2} = {x | f x = f p - ρ ^ 2}) :
+    Smale.AttachmentBoundaryData c.NegativeCoordinates c.PositiveCoordinates M f (f p - ρ ^ 2)
+    where
+  handle := c.normHandleMap ρ hρ hblock
+  handle_closed :=
+    (c.attachingHandleMap_isClosedEmbedding ρ hρ hblock).comp
+      c.handleBallCoordinates.isClosedEmbedding
+  height_continuous := hf
+  lower_frontier := hlevel
+  lower_face := fun z => by
+    constructor
+    · intro hz
+      exact (c.attachingHandleMap_lower_iff ρ hρ hblock (c.handleBallCoordinates z)).mp hz.le
+    · intro hz
+      exact c.attachingHandleMap_boundary_height ρ hρ hblock (c.handleBallCoordinates z) hz
+  upper_face := fun z => by
+    rw [c.range_normHandleMap ρ hρ hblock]
+    exact c.attachingHandleMap_mem_frontier_iff hf ρ hρ hblock (c.handleBallCoordinates z)
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    Smale.ManifoldMorse.SignedMorseChart.attachingCoreMap {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target) :
+    C(Smale.PuncturedHandle.UnitSphere c.NegativeCoordinates, { y : M // f y = f p - ρ ^ 2 }) :=
+  (c.attachingBoundaryMap ρ hρ hblock).comp
+    ⟨fun u => (u, ⟨0, by simp⟩), continuous_id.prodMk continuous_const⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.attachingCoreMap_coe {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (u : Smale.PuncturedHandle.UnitSphere c.NegativeCoordinates) :
+    (c.attachingCoreMap ρ hρ hblock u : M) =
+      c.splitChart.symm (ρ • (u : c.NegativeCoordinates), 0) := by
+  change
+    c.splitChart.symm
+        ((ρ * Real.sqrt (1 + ‖(0 : c.PositiveCoordinates)‖ ^ 2)) • (u : c.NegativeCoordinates),
+          ρ • (0 : c.PositiveCoordinates)) =
+      _
+  simp
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SignedMorseChart.contMDiff_attachingCoreMap_ambient {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (n : ℕ)
+    [Fact (Module.finrank ℝ c.NegativeCoordinates = n + 1)] (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target) :
+    ContMDiff (𝓡 n) 𝓘(ℝ, E) ∞ (Subtype.val ∘ c.attachingCoreMap ρ hρ hblock) := by
+  have heq :
+    Subtype.val ∘ c.attachingCoreMap ρ hρ hblock =
+      fun u : Smale.PuncturedHandle.UnitSphere c.NegativeCoordinates =>
+      c.splitChart.symm (ρ • (u : c.NegativeCoordinates), 0) :=
+    funext (c.attachingCoreMap_coe ρ hρ hblock)
+  rw [heq]
+  have hcoe :
+    ContMDiff (𝓡 n) 𝓘(ℝ, c.NegativeCoordinates) ∞
+      (Subtype.val :
+        Smale.PuncturedHandle.UnitSphere c.NegativeCoordinates → c.NegativeCoordinates) :=
+    contMDiff_coe_sphere (E := c.NegativeCoordinates) (n := n)
+  have hscalar :
+    ContMDiff (𝓡 n) 𝓘(ℝ, ℝ) ∞
+      (fun _ : Smale.PuncturedHandle.UnitSphere c.NegativeCoordinates => ρ) :=
+    contMDiff_const
+  have hnegative :
+    ContMDiff (𝓡 n) 𝓘(ℝ, c.NegativeCoordinates) ∞
+      (fun u : Smale.PuncturedHandle.UnitSphere c.NegativeCoordinates =>
+        ρ • (u : c.NegativeCoordinates)) :=
+    hscalar.smul hcoe
+  have hcoords :
+    ContMDiff (𝓡 n) 𝓘(ℝ, c.NegativeCoordinates × c.PositiveCoordinates) ∞
+      (fun u : Smale.PuncturedHandle.UnitSphere c.NegativeCoordinates =>
+        (ρ • (u : c.NegativeCoordinates), (0 : c.PositiveCoordinates))) :=
+    hnegative.prodMk_space contMDiff_const
+  apply c.splitChart.contMDiffOn_invFun.comp_contMDiff hcoords
+  intro u
+  have hh :=
+    hblock
+      (Smale.MorseHandle.modelMap_mem_product hρ
+        (⟨(u : c.NegativeCoordinates), Metric.sphere_subset_closedBall u.property⟩,
+          (⟨0, by simp⟩ : Smale.MorseHandle.UnitDisk c.PositiveCoordinates)))
+  simpa [Smale.MorseHandle.modelMap] using hh
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.contMDiff_attachingCoreMap {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (n : ℕ) [Fact (Module.finrank ℝ c.NegativeCoordinates = n + 1)]
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (hreg : ∀ x, f x = f p - ρ ^ 2 → x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    letI := Smale.RegularLevel.chartedSpace hf hreg
+    ContMDiff (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ (c.attachingCoreMap ρ hρ hblock) := by
+  let _ := Smale.RegularLevel.chartedSpace hf hreg
+  exact
+    (Smale.RegularLevel.contMDiff_iff_inclusion hf hreg (𝓡 n)
+          (c.attachingCoreMap ρ hρ hblock)).mpr
+      (c.contMDiff_attachingCoreMap_ambient n ρ hρ hblock)
+
+private theorem Smale.MorseHandle.quadratic_descentFlow_lt {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {t : ℝ} (ht : 0 < t) {z : N × P}
+    (hz : z ≠ 0) : quadratic (descentFlow t z) < quadratic z := by
+  have h₁ :=
+    (sq_le_sq₀ (norm_nonneg z.1) (norm_nonneg (descentFlow t z).1)).mpr
+      (norm_fst_le_descentFlow ht.le z)
+  have h₂ :=
+    (sq_le_sq₀ (norm_nonneg (descentFlow t z).2) (norm_nonneg z.2)).mpr
+      (norm_snd_descentFlow_le ht.le z)
+  by_cases hu : z.1 = 0
+  · have hv : z.2 ≠ 0 := fun hv => hz (Prod.ext hu hv)
+    have hvnorm : ‖(descentFlow t z).2‖ < ‖z.2‖ := by
+      rw [norm_descentFlow_snd]
+      exact
+        mul_lt_of_lt_one_left (norm_pos_iff.mpr hv) (Real.exp_lt_one_iff.mpr (neg_neg_of_pos ht))
+    have hv₂ := (sq_lt_sq₀ (norm_nonneg (descentFlow t z).2) (norm_nonneg z.2)).mpr hvnorm
+    exact add_lt_add_of_le_of_lt (neg_le_neg h₁) hv₂
+  · have hunorm : ‖z.1‖ < ‖(descentFlow t z).1‖ := by
+      rw [norm_descentFlow_fst]
+      exact lt_mul_of_one_lt_left (norm_pos_iff.mpr hu) (Real.one_lt_exp_iff.mpr ht)
+    have hu₂ := (sq_lt_sq₀ (norm_nonneg z.1) (norm_nonneg (descentFlow t z).1)).mpr hunorm
+    exact add_lt_add_of_lt_of_le (neg_lt_neg hu₂) h₂
+
+private theorem Smale.MorseHandle.descentFlow_mem_interior_lower_union_handle {N P : Type*}
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ t : ℝ}
+    (hρ : 0 < ρ) (ht : 0 < t) {z : N × P}
+    (hz : z ∈ {w | quadratic w ≤ -(ρ ^ 2)} ∪ Set.range (modelMap ρ)) :
+    descentFlow t z ∈ interior ({w | quadratic w ≤ -(ρ ^ 2)} ∪ Set.range (modelMap ρ)) := by
+  have hc : Continuous (quadratic (N := N) (P := P)) :=
+    (continuous_fst.norm.pow 2).neg.add (continuous_snd.norm.pow 2)
+  rw [mem_lower_union_handle_iff hρ] at hz
+  rcases hz with hq | hv
+  · have hne : z ≠ 0 := by
+      intro h
+      have hq' : (0 : ℝ) ≤ -(ρ ^ 2) := by simpa [h, quadratic] using hq
+      nlinarith [sq_pos_of_pos hρ]
+    have hlt : quadratic (descentFlow t z) < -(ρ ^ 2) :=
+      (quadratic_descentFlow_lt ht hne).trans_le hq
+    apply mem_interior.mpr
+    refine ⟨{w | quadratic w < -(ρ ^ 2)}, ?_, isOpen_lt hc continuous_const, hlt⟩
+    intro w hw
+    exact Or.inl (show quadratic w ≤ -(ρ ^ 2) from le_of_lt hw)
+  · have hlt : ‖(descentFlow t z).2‖ < ρ := by
+      rw [norm_descentFlow_snd]
+      calc
+        _ ≤ Real.exp (-t) * ρ := mul_le_mul_of_nonneg_left hv (Real.exp_pos _).le
+        _ < ρ := mul_lt_of_lt_one_left hρ (Real.exp_lt_one_iff.mpr (neg_neg_of_pos ht))
+    apply mem_interior.mpr
+    refine ⟨{w : N × P | ‖w.2‖ < ρ}, ?_, isOpen_lt continuous_snd.norm continuous_const, hlt⟩
+    intro w hw
+    exact (mem_lower_union_handle_iff hρ w).mpr (Or.inr hw.le)
+
+private theorem Smale.FlowConstruction.partialChartField_eq_mfderiv_symm {E F M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace M] [ChartedSpace E M] (e : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, F) M F ∞)
+    (W : F → F) {x : M} (hx : x ∈ e.source) :
+    partialChartField e W x =
+      mfderiv 𝓘(ℝ, F) 𝓘(ℝ, E) e.symm (e x)
+        ((NormedSpace.fromTangentSpace (e x)).symm (W (e x))) := by
+  let e' := e.toOpenPartialHomeomorph
+  have he : e'.MDifferentiable 𝓘(ℝ, E) 𝓘(ℝ, F) :=
+    ⟨e.contMDiffOn.mdifferentiableOn (by simp), e.symm.contMDiffOn.mdifferentiableOn (by simp)⟩
+  have h₁ := he.comp_symm_deriv (e'.map_source hx)
+  rw [e'.left_inv hx] at h₁
+  have hi := ContinuousLinearMap.inverse_eq h₁ (he.symm_comp_deriv hx)
+  unfold partialChartField
+  rw [VectorField.mpullback_apply]
+  change
+    (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, F) e' x).inverse
+        ((NormedSpace.fromTangentSpace (e' x)).symm (W (e' x))) =
+      _
+  rw [hi]
+  rfl
+
+private theorem Smale.FlowConstruction.hasMFDerivAt_lift_partialChartCurve {E F M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace M] [ChartedSpace E M] (e : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, F) M F ∞)
+    (W : F → F) {α : ℝ → F} {t : ℝ} (hα : HasDerivAt α (W (α t)) t) (ht : α t ∈ e.target) :
+    HasMFDerivAt 𝓘(ℝ, ℝ) 𝓘(ℝ, E) (e.symm ∘ α) t
+      ((1 : ℝ →L[ℝ] ℝ).smulRight (partialChartField e W (e.symm (α t)))) := by
+  let e' := e.toOpenPartialHomeomorph
+  have he : e'.MDifferentiable 𝓘(ℝ, E) 𝓘(ℝ, F) :=
+    ⟨e.contMDiffOn.mdifferentiableOn (by simp), e.symm.contMDiffOn.mdifferentiableOn (by simp)⟩
+  have hi := (he.mdifferentiableAt_symm ht).hasMFDerivAt
+  have hd := hi.comp t hα.hasFDerivAt.hasMFDerivAt
+  apply hd.congr_mfderiv
+  apply ContinuousLinearMap.ext
+  intro a
+  change
+    (mfderiv 𝓘(ℝ, F) 𝓘(ℝ, E) e'.symm (α t))
+        ((NormedSpace.fromTangentSpace t a) •
+          (NormedSpace.fromTangentSpace (α t)).symm (W (α t))) =
+      (NormedSpace.fromTangentSpace t a) • partialChartField e W (e'.symm (α t))
+  rw [map_smul, partialChartField_eq_mfderiv_symm e W (e'.map_target ht)]
+  rw [show e (e'.symm (α t)) = α t from e'.right_inv ht]
+  rfl
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.eventually_flow_eq_descentModel {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) {x : M}
+    (hx : x ∈ c.splitChart.source) (heq : ∀ᶠ y in 𝓝 x, V y = c.descentField y) :
+    ∀ᶠ t in 𝓝 (0 : ℝ),
+      F t x = c.splitChart.symm (Smale.MorseHandle.descentFlow t (c.splitChart x)) := by
+  let e := c.splitChart.toOpenPartialHomeomorph
+  let α : ℝ → c.NegativeCoordinates × c.PositiveCoordinates := fun t =>
+    Smale.MorseHandle.descentFlow t (c.splitChart x)
+  let γ : ℝ → M := e.symm ∘ α
+  have hα : Continuous α :=
+    Smale.MorseHandle.descentFlow.continuous continuous_id continuous_const
+  have hα₀ : α 0 = e x := Smale.MorseHandle.descentFlow.map_zero_apply _
+  have htarget : ∀ᶠ t in 𝓝 (0 : ℝ), α t ∈ e.target :=
+    hα.continuousAt.preimage_mem_nhds (e.open_target.mem_nhds (hα₀ ▸ e.map_source hx))
+  have hγ₀ : γ 0 = x := by
+    change e.symm (α 0) = x
+    rw [hα₀, e.left_inv hx]
+  have hγc : ContinuousAt γ 0 :=
+    (e.continuousAt_symm (hα₀ ▸ e.map_source hx)).comp hα.continuousAt
+  have hγt : Filter.Tendsto γ (𝓝 (0 : ℝ)) (𝓝 x) := by simpa only [ContinuousAt, hγ₀] using hγc
+  have hγ : IsMIntegralCurveAt γ V 0 := by
+    filter_upwards [htarget, hγt.eventually heq] with t ht heqt
+    change HasMFDerivAt 𝓘(ℝ, ℝ) 𝓘(ℝ, E) γ t ((1 : ℝ →L[ℝ] ℝ).smulRight (V (γ t)))
+    rw [heqt]
+    exact
+      Smale.FlowConstruction.hasMFDerivAt_lift_partialChartCurve c.splitChart
+        Smale.MorseHandle.descent (Smale.MorseHandle.hasDerivAt_descentFlow (c.splitChart x) t) ht
+  have h₀ : F 0 x = γ 0 := (F.map_zero_apply x).trans hγ₀.symm
+  exact
+    isMIntegralCurveAt_eventuallyEq_of_contMDiffAt_boundaryless (hV.contMDiffAt)
+      ((hcurve x).isMIntegralCurveAt 0) hγ h₀
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.flow_eqOn_descentModel {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) [T2Space M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) {x : M}
+    (hx : x ∈ c.splitChart.source) {S : Set ℝ} (hS : IsPreconnected S) (hzero : 0 ∈ S)
+    (htarget : ∀ t ∈ S, Smale.MorseHandle.descentFlow t (c.splitChart x) ∈ c.splitChart.target)
+    (heq :
+      ∀ t ∈ S,
+        ∀ᶠ y in 𝓝 (c.splitChart.symm (Smale.MorseHandle.descentFlow t (c.splitChart x))),
+          V y = c.descentField y) :
+    Set.EqOn (fun t => F t x)
+      (fun t => c.splitChart.symm (Smale.MorseHandle.descentFlow t (c.splitChart x))) S := by
+  let α : ℝ → c.NegativeCoordinates × c.PositiveCoordinates := fun t =>
+    Smale.MorseHandle.descentFlow t (c.splitChart x)
+  let γ : ℝ → M := c.splitChart.symm ∘ α
+  have hα : Continuous α :=
+    Smale.MorseHandle.descentFlow.continuous continuous_id continuous_const
+  have hγ : ∀ t ∈ S, IsMIntegralCurveAt γ V t := by
+    intro t ht
+    have hlocal : ∀ᶠ s in 𝓝 t, α s ∈ c.splitChart.target :=
+      hα.continuousAt.preimage_mem_nhds (c.splitChart.open_target.mem_nhds (htarget t ht))
+    have hc : ContinuousAt c.splitChart.toOpenPartialHomeomorph.symm (α t) :=
+      c.splitChart.toOpenPartialHomeomorph.continuousAt_symm (htarget t ht)
+    have hγc : ContinuousAt γ t := hc.comp (f := α) hα.continuousAt
+    filter_upwards [hlocal, hγc.eventually (heq t ht)] with s hs heqs
+    change HasMFDerivAt 𝓘(ℝ, ℝ) 𝓘(ℝ, E) γ s ((1 : ℝ →L[ℝ] ℝ).smulRight (V (γ s)))
+    rw [heqs]
+    exact
+      Smale.FlowConstruction.hasMFDerivAt_lift_partialChartCurve c.splitChart
+        Smale.MorseHandle.descent (Smale.MorseHandle.hasDerivAt_descentFlow (c.splitChart x) s) hs
+  have hγc : Continuous (fun t : S => γ t.val) := by
+    apply continuous_iff_continuousAt.mpr
+    intro t
+    exact ((hγ t.val t.property).continuousAt).comp continuousAt_subtype_val
+  let U : Set S := {t | F t.val x = γ t.val}
+  have hclosed : IsClosed U :=
+    isClosed_eq (F.continuous continuous_subtype_val continuous_const) hγc
+  have hopen : IsOpen U := by
+    apply isOpen_iff_mem_nhds.mpr
+    intro t ht
+    have hlocal :=
+      isMIntegralCurveAt_eventuallyEq_of_contMDiffAt_boundaryless hV.contMDiffAt
+        ((hcurve x).isMIntegralCurveAt t.val) (hγ t.val t.property) ht
+    exact continuousAt_subtype_val.eventually hlocal
+  have hγzero : γ 0 = x := by
+    change c.splitChart.symm (Smale.MorseHandle.descentFlow 0 (c.splitChart x)) = x
+    rw [Smale.MorseHandle.descentFlow.map_zero_apply]
+    exact c.splitChart.left_inv' hx
+  have hnonempty : U.Nonempty := ⟨⟨0, hzero⟩, (F.map_zero_apply x).trans hγzero.symm⟩
+  let : PreconnectedSpace S := Subtype.preconnectedSpace hS
+  have huniv : U = Set.univ := (show IsClopen U from ⟨hclosed, hopen⟩).eq_univ hnonempty
+  intro t ht
+  have hmem : (⟨t, ht⟩ : S) ∈ U := huniv ▸ Set.mem_univ _
+  exact hmem
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.flow_eq_descentModel_of_mem_uIcc {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) [T2Space M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) {x : M}
+    (hx : x ∈ c.splitChart.source) {t : ℝ}
+    (htarget :
+      ∀ s ∈ Set.uIcc 0 t, Smale.MorseHandle.descentFlow s (c.splitChart x) ∈ c.splitChart.target)
+    (heq :
+      ∀ s ∈ Set.uIcc 0 t,
+        ∀ᶠ y in 𝓝 (c.splitChart.symm (Smale.MorseHandle.descentFlow s (c.splitChart x))),
+          V y = c.descentField y) :
+    F t x = c.splitChart.symm (Smale.MorseHandle.descentFlow t (c.splitChart x)) :=
+  c.flow_eqOn_descentModel hV F hcurve hx isPreconnected_uIcc Set.left_mem_uIcc htarget heq
+    Set.right_mem_uIcc
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Recognition/Smale10.lean b/LeanPool/HopfProblem/Recognition/Smale10.lean
new file mode 100644
index 000000000..0ec281779
--- /dev/null
+++ b/LeanPool/HopfProblem/Recognition/Smale10.lean
@@ -0,0 +1,5648 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.PeriodFamily.Core6
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.Recognition.Smale1
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology3
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz1
+import all LeanPool.HopfProblem.Recognition.Smale2
+import all LeanPool.HopfProblem.Recognition.Smale3
+import all LeanPool.HopfProblem.Recognition.Smale4
+import all LeanPool.HopfProblem.Recognition.Smale5
+import all LeanPool.HopfProblem.Recognition.Degree1
+import all LeanPool.HopfProblem.Recognition.Degree2
+import all LeanPool.HopfProblem.Recognition.Smale6
+import all LeanPool.HopfProblem.Recognition.Smale7
+import all LeanPool.HopfProblem.Recognition.Smale8
+import all LeanPool.HopfProblem.Recognition.Smale9
+import all LeanPool.HopfProblem.PeriodFamily.Core6
+
+/-!
+# Hopf problem: recognition · smale 10
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem Degree.MorseRearrangement.native_cylinder_flow_coordinates {Z H N E M : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [TopologicalSpace H] {I : ModelWithCorners ℝ Z H}
+    [TopologicalSpace N] [ChartedSpace H N] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M]
+    (A : PartialDiffeomorph (I.prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) (N × ℝ) M ∞) (hsource : A.source = Set.univ)
+    (F : Flow ℝ M) (ι : N → M) (hformula : ∀ u, A u = F u.2 (ι u.1)) {x : M} (hx : x ∈ A.target)
+    (t : ℝ) : A.symm (F t x) = ((A.symm x).1, t + (A.symm x).2) := by
+  have hright : A (A.symm x) = x := A.right_inv' hx
+  have hexpr : F t x = A ((A.symm x).1, t + (A.symm x).2) := by
+    calc
+      F t x = F t (A (A.symm x)) := congrArg (F t) hright.symm
+      _ = F (t + (A.symm x).2) (ι (A.symm x).1) := by rw [hformula, ← F.map_add]
+      _ = A ((A.symm x).1, t + (A.symm x).2) := (hformula ((A.symm x).1, t + (A.symm x).2)).symm
+  rw [hexpr]
+  exact A.left_inv' (by rw [hsource]; trivial)
+
+private theorem Degree.MorseRearrangement.nativeCylinderWeight_flow {Z H N E M : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [TopologicalSpace H] {I : ModelWithCorners ℝ Z H}
+    [TopologicalSpace N] [ChartedSpace H N] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M]
+    (A : PartialDiffeomorph (I.prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) (N × ℝ) M ∞) (hsource : A.source = Set.univ)
+    (F : Flow ℝ M) (ι : N → M) (hformula : ∀ u, A u = F u.2 (ι u.1)) (θ : N → ℝ) {x : M}
+    (hx : x ∈ A.target) (t : ℝ) : nativeCylinderWeight A θ (F t x) = nativeCylinderWeight A θ x :=
+  by
+  unfold nativeCylinderWeight
+  rw [native_cylinder_flow_coordinates A hsource F ι hformula hx t]
+
+private theorem Degree.MorseRearrangement.exists_native_cylinder_plateau_weight {Z H N E M : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [TopologicalSpace H]
+    {I : ModelWithCorners ℝ Z H} [TopologicalSpace N] [ChartedSpace H N] [IsManifold I ∞ N]
+    [T2Space N] [CompactSpace N] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] (A : PartialDiffeomorph (I.prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) (N × ℝ) M ∞)
+    (hsource : A.source = Set.univ) (F : Flow ℝ M) (ι : N → M)
+    (hformula : ∀ u, A u = F u.2 (ι u.1)) {S₀ S₁ : Set N} (hS₀ : IsClosed S₀) (hS₁ : IsClosed S₁)
+    (hdisj : Disjoint S₀ S₁) :
+    ∃ w : M → ℝ,
+      ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ w A.target ∧
+        (∀ x, w x ∈ Set.Icc (0 : ℝ) 1) ∧
+          (∀ x ∈ A.target, ∀ t, w (F t x) = w x) ∧
+            (∀ x ∈ A.target, (A.symm x).1 ∈ S₀ → w =ᶠ[𝓝 x] fun _ => 0) ∧
+              (∀ x ∈ A.target, (A.symm x).1 ∈ S₁ → w =ᶠ[𝓝 x] fun _ => 1) := by
+  obtain ⟨θ, hθ₀, hθ₁, hθrange⟩ :=
+    exists_contMDiffMap_zero_one_nhds_of_isClosed I hS₀ hS₁ hdisj (n := ⊤)
+  refine
+    ⟨nativeCylinderWeight A θ, contMDiffOn_nativeCylinderWeight A θ.contMDiff,
+      nativeCylinderWeight_mem_Icc A hθrange, fun x hx t =>
+      nativeCylinderWeight_flow A hsource F ι hformula θ hx t, ?_, ?_⟩
+  · intro x hx hlabel
+    have hθpoint : ∀ᶠ y in 𝓝 (A.symm x).1, θ y = 0 := hθ₀.filter_mono (nhds_le_nhdsSet hlabel)
+    have hc : ContinuousAt (fun y => (A.symm y).1) x :=
+      (A.toOpenPartialHomeomorph.symm.continuousAt hx).fst
+    exact hc.tendsto.eventually hθpoint
+  · intro x hx hlabel
+    have hθpoint : ∀ᶠ y in 𝓝 (A.symm x).1, θ y = 1 := hθ₁.filter_mono (nhds_le_nhdsSet hlabel)
+    have hc : ContinuousAt (fun y => (A.symm y).1) x :=
+      (A.toOpenPartialHomeomorph.symm.continuousAt hx).fst
+    exact hc.tendsto.eventually hθpoint
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.eventually_nonzero_positive_coordinate_on_upper_level_basin {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hf : Continuous f)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hmono : ∀ x, Antitone (fun t => f (F t x))) (heq : ∀ᶠ y in 𝓝 p, V y = c.descentField y)
+    {a : ℝ} (ha : f p < a) :
+    ∀ᶠ x in 𝓝 p, x ∈ Degree.FlowCancellation.levelBasin F f a → (c.splitChart x).2 ≠ 0 := by
+  obtain ⟨r, hr, hbox, hfield⟩ := exists_native_morse_field_block c heq
+  filter_upwards [morse_coordinate_neighborhood c hr hr] with x hx
+  rintro ⟨t, ht⟩ hzero
+  have hlim := native_morse_negative_plane_limit c hV F hF hr hbox hfield hx.1 hx.2.1 hzero
+  have hheight : Filter.Tendsto (fun t => f (F t x)) Filter.atBot (𝓝 (f p)) :=
+    hf.continuousAt.tendsto.comp hlim
+  have hh := (hmono x).ge_of_tendsto hheight t
+  rw [ht] at hh
+  exact (not_le_of_gt ha) hh
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.eventually_nonzero_negative_coordinate_on_lower_level_basin {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hf : Continuous f)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hmono : ∀ x, Antitone (fun t => f (F t x))) (heq : ∀ᶠ y in 𝓝 p, V y = c.descentField y)
+    {a : ℝ} (ha : a < f p) :
+    ∀ᶠ x in 𝓝 p, x ∈ Degree.FlowCancellation.levelBasin F f a → (c.splitChart x).1 ≠ 0 := by
+  obtain ⟨r, hr, hbox, hfield⟩ := exists_native_morse_field_block c heq
+  filter_upwards [morse_coordinate_neighborhood c hr hr] with x hx
+  rintro ⟨t, ht⟩ hzero
+  have hlim := native_morse_positive_plane_limit c hV F hF hr hbox hfield hx.1 hx.2.2 hzero
+  have hheight : Filter.Tendsto (fun t => f (F t x)) Filter.atTop (𝓝 (f p)) :=
+    hf.continuousAt.tendsto.comp hlim
+  have hh := (hmono x).le_of_tendsto hheight t
+  rw [ht] at hh
+  exact (not_le_of_gt ha) hh
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.eventually_constant_basin_weight_of_belt_neighborhood {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hf : Continuous f)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hmono : ∀ x, Antitone (fun t => f (F t x))) {r : ℝ} (hr : 0 < r)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) ⊆
+        c.splitChart.target)
+    (hfield :
+      ∀
+        z ∈
+          Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+            Metric.closedBall (0 : c.PositiveCoordinates) (2 * r),
+        ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y)
+    {a k : ℝ} (ha : f p < a) {w : M → ℝ}
+    (hinv : ∀ x ∈ Degree.FlowCancellation.levelBasin F f a, ∀ t : ℝ, w (F t x) = w x) {U : Set M}
+    (hU : IsOpen U)
+    (hcore :
+      ∀ v : Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates,
+        (c.beltCoreMap r hr hblock v : M) ∈ U)
+    (hplateau : ∀ x ∈ U, f x = f p + r ^ 2 → w x = k) :
+    ∀ᶠ x in 𝓝 p, x ∈ Degree.FlowCancellation.levelBasin F f a → w x = k := by
+  have hcenter : c.splitChart.symm (0 : c.NegativeCoordinates × c.PositiveCoordinates) = p := by
+    rw [← c.splitChart_center]
+    exact c.splitChart.left_inv' c.splitChart_mem_source
+  have heq :=
+    hfield (0 : c.NegativeCoordinates × c.PositiveCoordinates)
+      ⟨Metric.mem_closedBall_self (by positivity), Metric.mem_closedBall_self (by positivity)⟩
+  rw [hcenter] at heq
+  filter_upwards [eventually_nonzero_positive_coordinate_on_upper_level_basin c hf hV F hF hmono
+      heq ha,
+    eventually_backward_exit_in_belt_neighborhood c hV F hF hr hblock hfield hU hcore] with x hne
+    hexit
+  intro hx
+  obtain ⟨T, -, hlevel, hU⟩ := hexit (hne hx)
+  exact (hinv x hx T).symm.trans (hplateau _ hU hlevel)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.eventually_constant_basin_weight_of_attaching_neighborhood {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hf : Continuous f)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hmono : ∀ x, Antitone (fun t => f (F t x))) {r : ℝ} (hr : 0 < r)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) ⊆
+        c.splitChart.target)
+    (hfield :
+      ∀
+        z ∈
+          Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+            Metric.closedBall (0 : c.PositiveCoordinates) (2 * r),
+        ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y)
+    {a k : ℝ} (ha : a < f p) {w : M → ℝ}
+    (hinv : ∀ x ∈ Degree.FlowCancellation.levelBasin F f a, ∀ t : ℝ, w (F t x) = w x) {U : Set M}
+    (hU : IsOpen U)
+    (hcore :
+      ∀ v : Smale.PuncturedHandle.UnitSphere c.NegativeCoordinates,
+        (c.attachingCoreMap r hr hblock v : M) ∈ U)
+    (hplateau : ∀ x ∈ U, f x = f p - r ^ 2 → w x = k) :
+    ∀ᶠ x in 𝓝 p, x ∈ Degree.FlowCancellation.levelBasin F f a → w x = k := by
+  have hcenter : c.splitChart.symm (0 : c.NegativeCoordinates × c.PositiveCoordinates) = p := by
+    rw [← c.splitChart_center]
+    exact c.splitChart.left_inv' c.splitChart_mem_source
+  have heq :=
+    hfield (0 : c.NegativeCoordinates × c.PositiveCoordinates)
+      ⟨Metric.mem_closedBall_self (by positivity), Metric.mem_closedBall_self (by positivity)⟩
+  rw [hcenter] at heq
+  filter_upwards [eventually_nonzero_negative_coordinate_on_lower_level_basin c hf hV F hF hmono
+      heq ha,
+    eventually_forward_exit_in_attaching_neighborhood c hV F hF hr hblock hfield hU hcore] with x
+    hne hexit
+  intro hx
+  obtain ⟨T, -, hlevel, hU⟩ := hexit (hne hx)
+  exact (hinv x hx T).symm.trans (hplateau _ hU hlevel)
+
+private theorem
+    Degree.MorseRearrangement.height_side_of_not_levelBasin {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f : X → ℝ} (hf : Continuous f) {a : ℝ} {x : X}
+    (hx : x ∉ Degree.FlowCancellation.levelBasin F f a) (t : ℝ) : f (F t x) < a ↔ f x < a := by
+  have hc : Continuous (fun s : ℝ => f (F s x)) :=
+    hf.comp (F.continuous continuous_id continuous_const)
+  have hside (s u : ℝ) (hs : f (F s x) < a) : f (F u x) < a := by
+    by_contra hu
+    obtain ⟨v, hv⟩ :=
+      intermediate_value_univ s u hc
+        (show a ∈ Set.Icc (f (F s x)) (f (F u x)) from ⟨hs.le, le_of_not_gt hu⟩)
+    exact hx ⟨v, hv⟩
+  constructor
+  · intro ht
+    simpa only [F.map_zero_apply] using hside t 0 ht
+  · intro hx
+    exact hside 0 t (by simpa only [F.map_zero_apply] using hx)
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    Degree.MorseRearrangement.extendedBasinWeight {X : Type*} [TopologicalSpace X] (F : Flow ℝ X)
+    (f : X → ℝ) (a : ℝ) (w : X → ℝ) (x : X) : ℝ :=
+  if x ∈ Degree.FlowCancellation.levelBasin F f a then w x else if f x < a then 1 else 0
+
+private theorem Degree.MorseRearrangement.extendedBasinWeight_eq {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) (f : X → ℝ) (a : ℝ) (w : X → ℝ) {x : X}
+    (hx : x ∈ Degree.FlowCancellation.levelBasin F f a) : extendedBasinWeight F f a w x = w x := by
+  classical simp only [extendedBasinWeight, ite_eq_left hx]
+
+private theorem Degree.MorseRearrangement.extendedBasinWeight_flow {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f : X → ℝ} (hf : Continuous f) (a : ℝ) (w : X → ℝ)
+    (hinv : ∀ x ∈ Degree.FlowCancellation.levelBasin F f a, ∀ t : ℝ, w (F t x) = w x) (x : X)
+    (t : ℝ) : extendedBasinWeight F f a w (F t x) = extendedBasinWeight F f a w x := by
+  classical
+  by_cases hx : x ∈ Degree.FlowCancellation.levelBasin F f a
+  · rw [extendedBasinWeight_eq _ _ _ _
+        ((Degree.FlowCancellation.levelBasin_flow_iff F f a t x).mpr hx),
+      extendedBasinWeight_eq _ _ _ _ hx]
+    exact hinv x hx t
+  · have htx : F t x ∉ Degree.FlowCancellation.levelBasin F f a := fun h =>
+      hx ((Degree.FlowCancellation.levelBasin_flow_iff F f a t x).mp h)
+    simp only [extendedBasinWeight, ite_eq_right hx, ite_eq_right htx,
+      height_side_of_not_levelBasin F hf hx t]
+
+private theorem
+    Degree.MorseRearrangement.extendedBasinWeight_mem_Icc {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) (f : X → ℝ) (a : ℝ) (w : X → ℝ)
+    (hw : ∀ x ∈ Degree.FlowCancellation.levelBasin F f a, w x ∈ Set.Icc (0 : ℝ) 1) (x : X) :
+    extendedBasinWeight F f a w x ∈ Set.Icc (0 : ℝ) 1 := by
+  classical
+  by_cases hx : x ∈ Degree.FlowCancellation.levelBasin F f a
+  · rw [extendedBasinWeight_eq _ _ _ _ hx]
+    exact hw x hx
+  · simp only [extendedBasinWeight, ite_eq_right hx]
+    split_ifs <;> norm_num
+
+private theorem
+    Degree.MorseRearrangement.extendedBasinWeight_lower_germ {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f : X → ℝ} {a : ℝ} {w : X → ℝ} {p : X} (hf : ContinuousAt f p) (hp : f p < a)
+    (hw : ∀ᶠ x in 𝓝 p, x ∈ Degree.FlowCancellation.levelBasin F f a → w x = 1) :
+    extendedBasinWeight F f a w =ᶠ[𝓝 p] fun _ => 1 := by
+  classical
+  have hheight : ∀ᶠ x in 𝓝 p, f x < a := hf (eventually_lt_nhds hp)
+  filter_upwards [hw, hheight] with x hx hfx
+  by_cases hbasin : x ∈ Degree.FlowCancellation.levelBasin F f a
+  · exact (extendedBasinWeight_eq _ _ _ _ hbasin).trans (hx hbasin)
+  · simp only [extendedBasinWeight, ite_eq_right hbasin, ite_eq_left hfx]
+
+private theorem
+    Degree.MorseRearrangement.extendedBasinWeight_upper_germ {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f : X → ℝ} {a : ℝ} {w : X → ℝ} {p : X} (hf : ContinuousAt f p) (hp : a < f p)
+    (hw : ∀ᶠ x in 𝓝 p, x ∈ Degree.FlowCancellation.levelBasin F f a → w x = 0) :
+    extendedBasinWeight F f a w =ᶠ[𝓝 p] fun _ => 0 := by
+  classical
+  have hheight : ∀ᶠ x in 𝓝 p, a < f x := hf (eventually_gt_nhds hp)
+  filter_upwards [hw, hheight] with x hx hfx
+  by_cases hbasin : x ∈ Degree.FlowCancellation.levelBasin F f a
+  · exact (extendedBasinWeight_eq _ _ _ _ hbasin).trans (hx hbasin)
+  · simp only [extendedBasinWeight, ite_eq_right hbasin, ite_eq_right (not_lt_of_gt hfx)]
+
+private theorem
+    Degree.MorseRearrangement.constant_germ_of_endpoint_limit {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {w : X → ℝ} (hinv : ∀ x t, w (F t x) = w x) {p x : X} {k : ℝ} {l : Filter ℝ}
+    [Filter.NeBot l] (hlim : Filter.Tendsto (fun t => F t x) l (𝓝 p))
+    (hgerm : w =ᶠ[𝓝 p] fun _ => k) : w =ᶠ[𝓝 x] fun _ => k := by
+  obtain ⟨t, ht⟩ := (hlim.eventually (eventually_eventually_nhds.mpr hgerm)).exists
+  have hc : Continuous (fun y => F t y) := F.continuous continuous_const continuous_id
+  filter_upwards [hc.continuousAt.tendsto.eventually ht] with y hy
+  exact (hinv y t).symm.trans hy
+
+private theorem
+    Degree.MorseRearrangement.pair_band_basin_complement {X : Type*} [TopologicalSpace X]
+    [CompactSpace X] (F : Flow ℝ X) {f : X → ℝ} (hf : Continuous f) {S : Set X}
+    (hinj : Set.InjOn f S) (hmono : ∀ x, Antitone (fun t : ℝ => f (F t x)))
+    (hstrict : ∀ x ∉ S, StrictAnti (fun t : ℝ => f (F t x))) {p q : X} {l a u : ℝ} (hla : l < a)
+    (hau : a < u) (hp : f p < a) (hq : a < f q)
+    (hpair : ∀ z ∈ S, f z ∈ Set.Icc l u → z = p ∨ z = q) {x : X} (hx : f x ∈ Set.Icc l u)
+    (hnot : x ∉ Degree.FlowCancellation.levelBasin F f a) :
+    (f x < a ∧ Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p)) ∨
+      (a < f x ∧ Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 q)) := by
+  obtain ⟨r, hr, s, hs, hrlim, hslim, -⟩ :=
+    Degree.FlowCancellation.exists_strict_descent_flow_endpoints F hf hinj hmono hstrict x
+  have hrheight : Filter.Tendsto (fun t => f (F t x)) Filter.atBot (𝓝 (f r)) :=
+    hf.continuousAt.tendsto.comp hrlim
+  have hsheight : Filter.Tendsto (fun t => f (F t x)) Filter.atTop (𝓝 (f s)) :=
+    hf.continuousAt.tendsto.comp hslim
+  by_cases hxa : f x < a
+  · have hrle : f r ≤ a :=
+      isClosed_Iic.mem_of_tendsto hrheight
+        (Filter.Eventually.of_forall
+          (fun t => ((height_side_of_not_levelBasin F hf hnot t).mpr hxa).le))
+    have hxr : f x ≤ f r := by
+      simpa only [F.map_zero_apply] using (hmono x).ge_of_tendsto hrheight 0
+    have hrp : r = p :=
+      (hpair r hr ⟨hx.1.trans hxr, hrle.trans hau.le⟩).resolve_right
+        (by
+          intro heq
+          rw [heq] at hrle
+          exact (not_le_of_gt hq) hrle)
+    exact Or.inl ⟨hxa, by simpa only [hrp] using hrlim⟩
+  · have hneq : f x ≠ a := fun heq => hnot ⟨0, by simpa only [F.map_zero_apply] using heq⟩
+    have hax : a < f x := lt_of_le_of_ne (le_of_not_gt hxa) (Ne.symm hneq)
+    have hsge : a ≤ f s :=
+      isClosed_Ici.mem_of_tendsto hsheight
+        (Filter.Eventually.of_forall
+          (fun t =>
+            le_of_not_gt (fun ht => hxa ((height_side_of_not_levelBasin F hf hnot t).mp ht))))
+    have hsx : f s ≤ f x := by
+      simpa only [F.map_zero_apply] using (hmono x).le_of_tendsto hsheight 0
+    have hsq : s = q :=
+      (hpair s hs ⟨hla.le.trans hsge, hsx.trans hx.2⟩).resolve_left
+        (by
+          intro heq
+          rw [heq] at hsge
+          exact (not_le_of_gt hp) hsge)
+    exact Or.inr ⟨hax, by simpa only [hsq] using hslim⟩
+
+private theorem Degree.MorseRearrangement.contMDiffOn_extendedBasinWeight_pair_band {E H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [TopologicalSpace M] [ChartedSpace H M] [CompactSpace M] (F : Flow ℝ M) {f : M → ℝ}
+    (hf : Continuous f) {S : Set M} (hinj : Set.InjOn f S)
+    (hmono : ∀ x, Antitone (fun t : ℝ => f (F t x)))
+    (hstrict : ∀ x ∉ S, StrictAnti (fun t : ℝ => f (F t x))) {p q : M} {l a u : ℝ} (hla : l < a)
+    (hau : a < u) (hp : f p < a) (hq : a < f q)
+    (hpair : ∀ z ∈ S, f z ∈ Set.Icc l u → z = p ∨ z = q)
+    (hB : IsOpen (Degree.FlowCancellation.levelBasin F f a)) {w : M → ℝ}
+    (hw : ContMDiffOn I 𝓘(ℝ, ℝ) ∞ w (Degree.FlowCancellation.levelBasin F f a))
+    (hstationary : ∀ x ∈ Degree.FlowCancellation.levelBasin F f a, ∀ t : ℝ, w (F t x) = w x)
+    (hpw : ∀ᶠ x in 𝓝 p, x ∈ Degree.FlowCancellation.levelBasin F f a → w x = 1)
+    (hqw : ∀ᶠ x in 𝓝 q, x ∈ Degree.FlowCancellation.levelBasin F f a → w x = 0) :
+    ContMDiffOn I 𝓘(ℝ, ℝ) ∞ (extendedBasinWeight F f a w) (f ⁻¹' Set.Icc l u) := by
+  have hpgerm := extendedBasinWeight_lower_germ F hf.continuousAt hp hpw
+  have hqgerm := extendedBasinWeight_upper_germ F hf.continuousAt hq hqw
+  have hinvariant (x : M) (t : ℝ) := extendedBasinWeight_flow F hf a w hstationary x t
+  intro x hx
+  by_cases hxB : x ∈ Degree.FlowCancellation.levelBasin F f a
+  · have heq : extendedBasinWeight F f a w =ᶠ[𝓝 x] w := by
+      filter_upwards [hB.mem_nhds hxB] with y hy
+      exact extendedBasinWeight_eq F f a w hy
+    exact (((hw x hxB).contMDiffAt (hB.mem_nhds hxB)).congr_of_eventuallyEq heq).contMDiffWithinAt
+  · rcases pair_band_basin_complement F hf hinj hmono hstrict hla hau hp hq hpair hx hxB with
+      ⟨-, hlim⟩ | ⟨-, hlim⟩
+    · have heq := constant_germ_of_endpoint_limit F hinvariant hlim hpgerm
+      exact (contMDiffAt_const.congr_of_eventuallyEq heq).contMDiffWithinAt
+    · have heq := constant_germ_of_endpoint_limit F hinvariant hlim hqgerm
+      exact (contMDiffAt_const.congr_of_eventuallyEq heq).contMDiffWithinAt
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Degree.MorseRearrangement.exists_stationary_pair_weight {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PreconnectedSpace M]
+    {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0)
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f)) {p q : M}
+    (cp : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (cq : Smale.ManifoldMorse.SignedMorseChart (E := E) f q) {rp rq l a u : ℝ} (hrp : 0 < rp)
+    (hrq : 0 < rq) (hla : l < a) (hau : a < u)
+    (hpair : ∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, f z ∈ Set.Icc l u → z = p ∨ z = q)
+    (hbp :
+      Metric.closedBall (0 : cp.NegativeCoordinates) (2 * rp) ×ˢ
+          Metric.closedBall (0 : cp.PositiveCoordinates) (2 * rp) ⊆
+        cp.splitChart.target)
+    (hbq :
+      Metric.closedBall (0 : cq.NegativeCoordinates) (2 * rq) ×ˢ
+          Metric.closedBall (0 : cq.PositiveCoordinates) (2 * rq) ⊆
+        cq.splitChart.target)
+    (hfp :
+      ∀
+        z ∈
+          Metric.closedBall (0 : cp.NegativeCoordinates) (2 * rp) ×ˢ
+            Metric.closedBall (0 : cp.PositiveCoordinates) (2 * rp),
+        ∀ᶠ y in 𝓝 (cp.splitChart.symm z), V y = cp.descentField y)
+    (hfq :
+      ∀
+        z ∈
+          Metric.closedBall (0 : cq.NegativeCoordinates) (2 * rq) ×ˢ
+            Metric.closedBall (0 : cq.PositiveCoordinates) (2 * rq),
+        ∀ᶠ y in 𝓝 (cq.splitChart.symm z), V y = cq.descentField y)
+    (hpa : f p + rp ^ 2 ≤ a) (haq : a ≤ f q - rq ^ 2)
+    (hbandp : ∀ x, f x ∈ Set.Icc (f p + rp ^ 2) a → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hbandq : ∀ x, f x ∈ Set.Icc a (f q - rq ^ 2) → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hnoconnection :
+      ∀ x,
+        ¬(Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 q) ∧
+            Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p))) :
+    ∃ W : M → ℝ,
+      ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ W (f ⁻¹' Set.Icc l u) ∧
+        (∀ x, W x ∈ Set.Icc (0 : ℝ) 1) ∧
+          (∀ x t, W (F t x) = W x) ∧ (W =ᶠ[𝓝 p] fun _ => 1) ∧ (W =ᶠ[𝓝 q] fun _ => 0) := by
+  have hpa' : f p < a := by nlinarith [sq_pos_of_pos hrp]
+  have haq' : a < f q := by nlinarith [sq_pos_of_pos hrq]
+  have hreg : ∀ x, f x = a → x ∉ Smale.ManifoldMorse.criticalPoints E f := by
+    intro x hx
+    exact hbandp x (by rw [hx]; exact ⟨hpa, le_rfl⟩)
+  have hboundp : ∀ x, f x = f p + rp ^ 2 → mvfderiv 𝓘(ℝ, E) f x (V x) < 0 := by
+    intro x hx
+    exact hdesc x (hbandp x (by rw [hx]; exact ⟨le_rfl, hpa⟩))
+  have hboundq : ∀ x, f x = f q - rq ^ 2 → mvfderiv 𝓘(ℝ, E) f x (V x) < 0 := by
+    intro x hx
+    exact hdesc x (hbandq x (by rw [hx]; exact ⟨haq, le_rfl⟩))
+  let L := { x : M // f x = a }
+  let _ := Smale.RegularLevel.chartedSpace hf hreg
+  let _ := Smale.RegularLevel.isManifold hf hreg
+  let : CompactSpace L :=
+    isCompact_iff_compactSpace.mp (isClosed_eq hf.continuous continuous_const).isCompact
+  let S₀ : Set L := {x | Filter.Tendsto (fun t => F t (x : M)) Filter.atBot (𝓝 q)}
+  let S₁ : Set L := {x | Filter.Tendsto (fun t => F t (x : M)) Filter.atTop (𝓝 p)}
+  have hS₁ : IsCompact S₁ :=
+    (Degree.FlowCancellation.isCompact_forward_section_iff_of_regular_band hf hV hdesc F hF hpa
+          hbandp p).mpr
+      (MorseCancel.isCompact_native_belt_basin cp hf hV F hF rp hrp hbp hfp hboundp)
+  have hS₀ : IsCompact S₀ :=
+    (Degree.FlowCancellation.isCompact_backward_section_iff_of_regular_band hf hV hdesc F hF haq
+          hbandq q).mp
+      (MorseCancel.isCompact_native_attaching_basin cq hf hV F hF rq hrq hbq hfq hboundq)
+  have hdisj : Disjoint S₀ S₁ :=
+    Set.disjoint_left.mpr (fun x hx₀ hx₁ => hnoconnection x ⟨hx₀, hx₁⟩)
+  obtain ⟨z, hz⟩ := intermediate_value_univ p q hf.continuous ⟨hpa'.le, haq'.le⟩
+  obtain ⟨A, hAsource, hAtarget, hAformula, -⟩ :=
+    Degree.FlowCancellation.exists_native_level_flow_cylinder hf hreg hV F hF
+      (fun x hx => hdesc x (hreg x hx)) (⟨z, hz⟩ : L)
+  obtain ⟨w, hw, hwrange, hwinv, hw₀, hw₁⟩ :=
+    exists_native_cylinder_plateau_weight A hAsource F Subtype.val hAformula hS₀.isClosed
+      hS₁.isClosed hdisj
+  have hmono := Smale.FlowConstruction.antitone_flow_height hf F hF hzero hdesc
+  have hV₁ := hV.of_le (show (1 : WithTop ℕ∞) ≤ (↑(⊤ : ℕ∞) : ℕ∞ω) by simp)
+  have hbasinp :=
+    Degree.FlowCancellation.levelBasin_eq_of_regular_band hf hV hdesc F hF hpa hbandp
+  have hbasinq :=
+    Degree.FlowCancellation.levelBasin_eq_of_regular_band hf hV hdesc F hF haq hbandq
+  have hcorep (v : Smale.PuncturedHandle.UnitSphere cp.PositiveCoordinates) :
+    w =ᶠ[𝓝 (cp.beltCoreMap rp hrp hbp v : M)] fun _ => 1 := by
+    let x : M := cp.beltCoreMap rp hrp hbp v
+    have hx : x ∈ A.target := by
+      rw [hAtarget, ← hbasinp]
+      exact ⟨0, by simpa only [F.map_zero_apply] using (cp.beltCoreMap rp hrp hbp v).property⟩
+    have hmap : F (A.symm x).2 ((A.symm x).1 : M) = x :=
+      (hAformula (A.symm x)).symm.trans (A.right_inv' hx)
+    apply hw₁ x hx
+    have hh := MorseCancel.native_belt_core_forward_limit cp hV₁ F hF rp hrp hbp hfp v
+    apply (MorseCancel.flow_time_atTop_limit_iff F (A.symm x).2 ((A.symm x).1 : M) p).mp
+    rw [hmap]
+    exact hh
+  have hcoreq (v : Smale.PuncturedHandle.UnitSphere cq.NegativeCoordinates) :
+    w =ᶠ[𝓝 (cq.attachingCoreMap rq hrq hbq v : M)] fun _ => 0 := by
+    let x : M := cq.attachingCoreMap rq hrq hbq v
+    have hx : x ∈ A.target := by
+      rw [hAtarget, hbasinq]
+      exact
+        ⟨0, by simpa only [F.map_zero_apply] using (cq.attachingCoreMap rq hrq hbq v).property⟩
+    have hmap : F (A.symm x).2 ((A.symm x).1 : M) = x :=
+      (hAformula (A.symm x)).symm.trans (A.right_inv' hx)
+    apply hw₀ x hx
+    have hh := MorseCancel.native_attaching_core_backward_limit cq hV₁ F hF rq hrq hbq hfq v
+    apply (MorseCancel.flow_time_atBot_limit_iff F (A.symm x).2 ((A.symm x).1 : M) q).mp
+    rw [hmap]
+    exact hh
+  have hstationary : ∀ x ∈ Degree.FlowCancellation.levelBasin F f a, ∀ t, w (F t x) = w x := by
+    simpa only [hAtarget] using hwinv
+  have hpw : ∀ᶠ x in 𝓝 p, x ∈ Degree.FlowCancellation.levelBasin F f a → w x = 1 :=
+    MorseCancel.eventually_constant_basin_weight_of_belt_neighborhood cp hf.continuous hV₁ F hF
+      hmono hrp hbp hfp hpa' hstationary (U := interior {x | w x = 1}) isOpen_interior
+      (fun v => mem_interior_iff_mem_nhds.mpr (hcorep v))
+      (fun _ hx _ => interior_subset (s := {x : M | w x = 1}) hx)
+  have hqw : ∀ᶠ x in 𝓝 q, x ∈ Degree.FlowCancellation.levelBasin F f a → w x = 0 :=
+    MorseCancel.eventually_constant_basin_weight_of_attaching_neighborhood cq hf.continuous hV₁ F
+      hF hmono hrq hbq hfq haq' hstationary (U := interior {x | w x = 0}) isOpen_interior
+      (fun v => mem_interior_iff_mem_nhds.mpr (hcoreq v))
+      (fun _ hx _ => interior_subset (s := {x : M | w x = 0}) hx)
+  have hB : IsOpen (Degree.FlowCancellation.levelBasin F f a) := hAtarget ▸ A.open_target
+  have hwB : ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ w (Degree.FlowCancellation.levelBasin F f a) :=
+    hAtarget ▸ hw
+  refine
+    ⟨extendedBasinWeight F f a w, ?_, extendedBasinWeight_mem_Icc F f a w (fun x _ => hwrange x),
+      extendedBasinWeight_flow F hf.continuous a w hstationary,
+      extendedBasinWeight_lower_germ F hf.continuous.continuousAt hpa' hpw,
+      extendedBasinWeight_upper_germ F hf.continuous.continuousAt haq' hqw⟩
+  exact
+    contMDiffOn_extendedBasinWeight_pair_band F hf.continuous hinj hmono
+      (fun x hx => Smale.FlowConstruction.strictAnti_flow_height hf hV₁ F hF hzero hdesc hx) hla
+      hau hpa' haq' hpair hB hwB hstationary hpw hqw
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.exists_small_native_morse_field_block {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (heq : ∀ᶠ y in 𝓝 p, V y = c.descentField y) {ε : ℝ} (hε : 0 < ε) :
+    ∃ r : ℝ,
+      0 < r ∧
+        r ^ 2 < ε ∧
+          Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+                Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) ⊆
+              c.splitChart.target ∧
+            ∀
+              z ∈
+                Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+                  Metric.closedBall (0 : c.PositiveCoordinates) (2 * r),
+              ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y := by
+  obtain ⟨R, hR, hblock, hfield⟩ := exists_native_morse_field_block c heq
+  obtain ⟨r, hr, hsmall⟩ :=
+    exists_between (lt_min (half_pos hR) (lt_min hε (by norm_num : (0 : ℝ) < 1)))
+  have h2r : 2 * r ≤ R := by linarith [hsmall.trans_le (min_le_left _ _)]
+  have hrε : r < ε := (hsmall.trans_le (min_le_right _ _)).trans_le (min_le_left _ _)
+  have hr1 : r < 1 := (hsmall.trans_le (min_le_right _ _)).trans_le (min_le_right _ _)
+  have hr2 : r ^ 2 < ε := lt_trans (by nlinarith : r ^ 2 < r) hrε
+  have hsub :
+    Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+        Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) ⊆
+      Metric.closedBall (0 : c.NegativeCoordinates) R ×ˢ
+        Metric.closedBall (0 : c.PositiveCoordinates) R :=
+    fun z hz =>
+    ⟨Metric.closedBall_subset_closedBall h2r hz.1, Metric.closedBall_subset_closedBall h2r hz.2⟩
+  exact ⟨r, hr, hr2, hsub.trans hblock, fun z hz => hfield z (hsub hz)⟩
+
+private theorem
+    Degree.MorseRearrangement.blended_height_exterior_germ {M : Type*} [TopologicalSpace M]
+    {f θ : M → ℝ} {P Q : ℝ → ℝ} {l u : ℝ} (hf : Continuous f)
+    (hP : ∀ s ∉ Set.Ioo l u, P =ᶠ[𝓝 s] id) (hQ : ∀ s ∉ Set.Ioo l u, Q =ᶠ[𝓝 s] id) {x : M}
+    (hx : f x ∉ Set.Ioo l u) : (fun y => blendHeight (θ y) P Q (f y)) =ᶠ[𝓝 x] f := by
+  filter_upwards [hf.continuousAt.tendsto.eventually (hP _ hx),
+    hf.continuousAt.tendsto.eventually (hQ _ hx)] with y hyP hyQ
+  exact blendHeight_fixed hyP hyQ _
+
+private theorem Degree.MorseRearrangement.contMDiff_globally_blended_height {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f θ : M → ℝ}
+    {P Q : ℝ → ℝ} {l u : ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hθ : ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ θ (f ⁻¹' Set.Icc l u)) (hP : ContDiff ℝ ∞ P)
+    (hQ : ContDiff ℝ ∞ Q) (hPfix : ∀ s ∉ Set.Ioo l u, P =ᶠ[𝓝 s] id)
+    (hQfix : ∀ s ∉ Set.Ioo l u, Q =ᶠ[𝓝 s] id) :
+    ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ (fun x => blendHeight (θ x) P Q (f x)) := by
+  intro x
+  by_cases hx : f x ∈ Set.Ioo l u
+  · have hnhds : f ⁻¹' Set.Icc l u ∈ 𝓝 x :=
+      Filter.mem_of_superset ((isOpen_Ioo.preimage hf.continuous).mem_nhds hx)
+        (fun _ hy => ⟨hy.1.le, hy.2.le⟩)
+    have hw := (hθ x ⟨hx.1.le, hx.2.le⟩).contMDiffAt hnhds
+    exact
+      (hw.mul (hP.contMDiff.contMDiffAt.comp x (hf x))).add
+        ((contMDiffAt_const.sub hw).mul (hQ.contMDiff.contMDiffAt.comp x (hf x)))
+  · exact (hf x).congr_of_eventuallyEq (blended_height_exterior_germ hf.continuous hPfix hQfix hx)
+
+private theorem Degree.MorseRearrangement.blended_height_one_translation_germ {M : Type*}
+    [TopologicalSpace M] {f θ : M → ℝ} {P Q : ℝ → ℝ} {p : M} {k : ℝ} (hf : ContinuousAt f p)
+    (hθ : θ =ᶠ[𝓝 p] fun _ => 1) (hP : P =ᶠ[𝓝 (f p)] fun s => s + k) :
+    (fun x => blendHeight (θ x) P Q (f x)) =ᶠ[𝓝 p] fun x => f x + k := by
+  filter_upwards [hθ, hf.tendsto.eventually hP] with x hx hPx
+  rw [hx, blendHeight_one]
+  exact hPx
+
+private theorem Degree.MorseRearrangement.blended_height_zero_translation_germ {M : Type*}
+    [TopologicalSpace M] {f θ : M → ℝ} {P Q : ℝ → ℝ} {p : M} {k : ℝ} (hf : ContinuousAt f p)
+    (hθ : θ =ᶠ[𝓝 p] fun _ => 0) (hQ : Q =ᶠ[𝓝 (f p)] fun s => s + k) :
+    (fun x => blendHeight (θ x) P Q (f x)) =ᶠ[𝓝 p] fun x => f x + k := by
+  filter_upwards [hθ, hf.tendsto.eventually hQ] with x hx hQx
+  rw [hx, blendHeight_zero]
+  exact hQx
+
+private theorem Degree.MorseRearrangement.blended_height_directional_derivative {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f θ : M → ℝ}
+    {P Q : ℝ → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ (fun x => blendHeight (θ x) P Q (f x)))
+    (hP : Differentiable ℝ P) (hQ : Differentiable ℝ Q) {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) (hθ : ∀ x t, θ (F t x) = θ x)
+    (x : M) :
+    mvfderiv 𝓘(ℝ, E) (fun y => blendHeight (θ y) P Q (f y)) x (V x) =
+      (θ x * deriv P (f x) + (1 - θ x) * deriv Q (f x)) * mvfderiv 𝓘(ℝ, E) f x (V x) := by
+  have hw : HasDerivAt (fun t => θ (F t x)) 0 0 := by
+    have heq : (fun t => θ (F t x)) = fun _ => θ x := funext (hθ x)
+    rw [heq]
+    exact hasDerivAt_const _ _
+  have hdf := Smale.FlowConstruction.hasDerivAt_comp_integralCurve hf (hF x) 0
+  have hdg := Smale.FlowConstruction.hasDerivAt_comp_integralCurve hg (hF x) 0
+  have hh := hasDerivAt_blended_height hdf hw (hP _).hasDerivAt (hQ _).hasDerivAt
+  have heq := hdg.unique hh
+  have hdf0 := congrArg (fun y : M => mvfderiv 𝓘(ℝ, E) f y (V y)) (F.map_zero_apply x)
+  have hdg0 :=
+    congrArg (fun y : M => mvfderiv 𝓘(ℝ, E) (fun z => blendHeight (θ z) P Q (f z)) y (V y))
+      (F.map_zero_apply x)
+  change
+    mvfderiv 𝓘(ℝ, E) (fun z => blendHeight (θ z) P Q (f z)) (F 0 x) (V (F 0 x)) =
+      (θ (F 0 x) * deriv P (f (F 0 x)) + (1 - θ (F 0 x)) * deriv Q (f (F 0 x))) *
+        mvfderiv 𝓘(ℝ, E) f (F 0 x) (V (F 0 x)) at heq
+  rw [hdg0, hdf0, F.map_zero_apply] at heq
+  exact heq
+
+private theorem Degree.MorseRearrangement.exists_rearranged_morse_function_of_stationary_weight
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f θ : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (F : Flow ℝ M)
+    (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    {p q : M} {l u p' q' : ℝ} (hp : f p ∈ Set.Ioo l u) (hq : f q ∈ Set.Ioo l u)
+    (hp' : p' ∈ Set.Ioo l u) (hq' : q' ∈ Set.Ioo l u)
+    (hpair : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, f x ∈ Set.Ioo l u → x = p ∨ x = q)
+    (hθ : ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ θ (f ⁻¹' Set.Icc l u))
+    (hθrange : ∀ x, θ x ∈ Set.Icc (0 : ℝ) 1) (hθinv : ∀ x t, θ (F t x) = θ x)
+    (hpgerm : θ =ᶠ[𝓝 p] fun _ => 1) (hqgerm : θ =ᶠ[𝓝 q] fun _ => 0) :
+    ∃ g : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+        Smale.ManifoldMorse.IsMorse E g ∧
+          Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f ∧
+            g p = p' ∧
+              g q = q' ∧
+                (∀ x,
+                    x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) g x (V x) < 0) ∧
+                  (∀ x, f x ∉ Set.Ioo l u → g =ᶠ[𝓝 x] f) ∧
+                    (g =ᶠ[𝓝 p] fun x => f x + (p' - f p)) ∧
+                      (g =ᶠ[𝓝 q] fun x => f x + (q' - f q)) ∧
+                        (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+                            x ≠ p → x ≠ q → g =ᶠ[𝓝 x] f) ∧
+                          (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+                            ∃ k : ℝ, g =ᶠ[𝓝 x] fun y => f y + k) := by
+  obtain ⟨P, -, hPtrans, -, -, hPpos, hPfix⟩ :=
+    exists_increasing_interval_translation_with_exterior_germs hp hp'
+  obtain ⟨Q, -, hQtrans, -, -, hQpos, hQfix⟩ :=
+    exists_increasing_interval_translation_with_exterior_germs hq hq'
+  let g : M → ℝ := fun x => blendHeight (θ x) P Q (f x)
+  have hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g :=
+    contMDiff_globally_blended_height hf hθ P.contMDiff.contDiff Q.contMDiff.contDiff hPfix hQfix
+  have hgp : g =ᶠ[𝓝 p] fun x => f x + (p' - f p) :=
+    blended_height_one_translation_germ hf.continuous.continuousAt hpgerm hPtrans
+  have hgq : g =ᶠ[𝓝 q] fun x => f x + (q' - f q) :=
+    blended_height_zero_translation_germ hf.continuous.continuousAt hqgerm hQtrans
+  have hexterior (x : M) (hx : f x ∉ Set.Ioo l u) : g =ᶠ[𝓝 x] f :=
+    blended_height_exterior_germ hf.continuous hPfix hQfix hx
+  have hothers (x : M) (hx : x ∈ Smale.ManifoldMorse.criticalPoints E f) (hxp : x ≠ p)
+    (hxq : x ≠ q) : g =ᶠ[𝓝 x] f := hexterior x (fun hb => (hpair x hx hb).elim hxp hxq)
+  have hkeep (x : M) (hx : x ∈ Smale.ManifoldMorse.criticalPoints E f) :
+    ∃ k : ℝ, g =ᶠ[𝓝 x] fun y => f y + k := by
+    by_cases hxp : x = p
+    · subst x
+      exact ⟨p' - f p, hgp⟩
+    by_cases hxq : x = q
+    · subst x
+      exact ⟨q' - f q, hgq⟩
+    exact ⟨0, by simpa only [add_zero] using hothers x hx hxp hxq⟩
+  have hdescent (x : M) (hx : x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    mvfderiv 𝓘(ℝ, E) g x (V x) < 0 := by
+    rw [blended_height_directional_derivative hf hg
+        (P.contMDiff.contDiff.differentiable (by simp))
+        (Q.contMDiff.contDiff.differentiable (by simp)) F hF hθinv x]
+    exact
+      mul_neg_of_pos_of_neg (positive_blended_slope (hθrange x) (hPpos _) (hQpos _)) (hdesc x hx)
+  have hcrit : Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f := by
+    ext x
+    constructor
+    · intro hx
+      by_contra hnot
+      exact Degree.FlowCancellation.not_critical_of_directional_neg (hdescent x hnot) hx
+    · intro hx
+      obtain ⟨k, hk⟩ := hkeep x hx
+      change mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) g x = 0
+      rw [MorseCancel.mfderiv_of_add_const_germ (hf.mdifferentiableAt (by simp)) hk]
+      exact hx
+  have hmg : Smale.ManifoldMorse.IsMorse E g := by
+    intro x
+    by_cases hx : x ∈ Smale.ManifoldMorse.criticalPoints E f
+    · obtain ⟨k, hk⟩ := hkeep x hx
+      exact MorseCancel.isMorseAt_of_add_const_germ (hm x) hk
+    · have hreg : x ∉ Smale.ManifoldMorse.criticalPoints E g := by rwa [hcrit]
+      exact Degree.MorseCancellationPreservation.isMorseAt_of_regular hg hreg
+  refine ⟨g, hg, hmg, hcrit, ?_, ?_, hdescent, hexterior, hgp, hgq, hothers, hkeep⟩
+  · have hh := hgp.self_of_nhds
+    dsimp only at hh
+    linarith
+  · have hh := hgq.self_of_nhds
+    dsimp only at hh
+    linarith
+
+private theorem Degree.MorseRearrangement.exists_morse_rearrangement_of_no_connection {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PreconnectedSpace M]
+    {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0)
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f)) {p q : M}
+    (cp : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (cq : Smale.ManifoldMorse.SignedMorseChart (E := E) f q)
+    (hfp : ∀ᶠ y in 𝓝 p, V y = cp.descentField y) (hfq : ∀ᶠ y in 𝓝 q, V y = cq.descentField y)
+    {l u p' q' : ℝ} (hp : f p ∈ Set.Ioo l u) (hq : f q ∈ Set.Ioo l u) (hpq : f p < f q)
+    (hp' : p' ∈ Set.Ioo l u) (hq' : q' ∈ Set.Ioo l u)
+    (hpair : ∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, f z ∈ Set.Icc l u → z = p ∨ z = q)
+    (hnoconnection :
+      ∀ x,
+        ¬(Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 q) ∧
+            Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p))) :
+    ∃ g : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+        Smale.ManifoldMorse.IsMorse E g ∧
+          Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f ∧
+            g p = p' ∧
+              g q = q' ∧
+                (∀ x,
+                    x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) g x (V x) < 0) ∧
+                  (∀ x, f x ∉ Set.Ioo l u → g =ᶠ[𝓝 x] f) ∧
+                    (g =ᶠ[𝓝 p] fun x => f x + (p' - f p)) ∧
+                      (g =ᶠ[𝓝 q] fun x => f x + (q' - f q)) ∧
+                        (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+                            x ≠ p → x ≠ q → g =ᶠ[𝓝 x] f) ∧
+                          (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+                            MorseCancel.nativeMorseIndex E g x =
+                              MorseCancel.nativeMorseIndex E f x) := by
+  obtain ⟨a, hpa, haq⟩ := exists_between hpq
+  obtain ⟨rp, hrp, hrpa, hbp, hfieldp⟩ :=
+    MorseCancel.exists_small_native_morse_field_block cp hfp (sub_pos.mpr hpa)
+  obtain ⟨rq, hrq, hrqa, hbq, hfieldq⟩ :=
+    MorseCancel.exists_small_native_morse_field_block cq hfq (sub_pos.mpr haq)
+  have hpa' : f p + rp ^ 2 ≤ a := by linarith
+  have haq' : a ≤ f q - rq ^ 2 := by linarith
+  have hregular (x : M) (hx : f x ∈ Set.Ioo (f p) (f q)) :
+    x ∉ Smale.ManifoldMorse.criticalPoints E f := by
+    intro hcrit
+    rcases hpair x hcrit ⟨hp.1.le.trans hx.1.le, hx.2.le.trans hq.2.le⟩ with heq | heq
+    · rw [heq] at hx
+      exact lt_irrefl _ hx.1
+    · rw [heq] at hx
+      exact lt_irrefl _ hx.2
+  have hbandp :
+    ∀ x, f x ∈ Set.Icc (f p + rp ^ 2) a → x ∉ Smale.ManifoldMorse.criticalPoints E f := by
+    intro x hx
+    apply hregular x
+    exact ⟨by nlinarith [hx.1, sq_pos_of_pos hrp], hx.2.trans_lt haq⟩
+  have hbandq :
+    ∀ x, f x ∈ Set.Icc a (f q - rq ^ 2) → x ∉ Smale.ManifoldMorse.criticalPoints E f := by
+    intro x hx
+    apply hregular x
+    exact ⟨hpa.trans_le hx.1, by nlinarith [hx.2, sq_pos_of_pos hrq]⟩
+  obtain ⟨W, hW, hWrange, hWinv, hWp, hWq⟩ :=
+    exists_stationary_pair_weight hf hV F hF hzero hdesc hinj cp cq hrp hrq (hp.1.trans hpa)
+      (haq.trans hq.2) hpair hbp hbq hfieldp hfieldq hpa' haq' hbandp hbandq hnoconnection
+  obtain ⟨g, hg, hmg, hcrit, hgp, hgq, hdescent, hexterior, hpgerm, hqgerm, hothers, -⟩ :=
+    exists_rearranged_morse_function_of_stationary_weight hf hm F hF hdesc hp hq hp' hq'
+      (fun x hx hband => hpair x hx ⟨hband.1.le, hband.2.le⟩) hW hWrange hWinv hWp hWq
+  refine ⟨g, hg, hmg, hcrit, hgp, hgq, hdescent, hexterior, hpgerm, hqgerm, hothers, ?_⟩
+  intro x hx
+  by_cases hxp : x = p
+  · subst x
+    exact MorseCancel.nativeMorseIndex_of_add_const_germ cp hpgerm
+  by_cases hxq : x = q
+  · subst x
+    exact MorseCancel.nativeMorseIndex_of_add_const_germ cq hqgerm
+  exact MorseCancel.nativeMorseIndex_congr_germ (hothers x hx hxp hxq)
+
+private theorem
+    MorseCancel.injOn_of_exchanged_values {X Y : Type*} {f g : X → Y} {S : Set X} {p q : X}
+    (hinj : Set.InjOn f S) (hp : p ∈ S) (hq : q ∈ S) (hgp : g p = f q) (hgq : g q = f p)
+    (hothers : ∀ x ∈ S, x ≠ p → x ≠ q → g x = f x) : Set.InjOn g S := by
+  classical
+  have hform (x : X) (hx : x ∈ S) : g x = f (Equiv.swap p q x) := by
+    by_cases hxp : x = p
+    · subst x
+      simpa only [Equiv.swap_apply_left] using hgp
+    by_cases hxq : x = q
+    · subst x
+      simpa only [Equiv.swap_apply_right] using hgq
+    simpa only [Equiv.swap_apply_def, ite_eq_right hxp, ite_eq_right hxq] using hothers x hx hxp hxq
+  have hmaps : Set.MapsTo (Equiv.swap p q) S S := by
+    intro x hx
+    by_cases hxp : x = p
+    · subst x
+      simpa only [Equiv.swap_apply_left] using hq
+    by_cases hxq : x = q
+    · subst x
+      simpa only [Equiv.swap_apply_right] using hp
+    simpa only [Equiv.swap_apply_def, ite_eq_right hxp, ite_eq_right hxq] using hx
+  intro x hx y hy hxy
+  apply (Equiv.swap p q).injective
+  apply hinj (hmaps hx) (hmaps hy)
+  rw [← hform x hx, ← hform y hy]
+  exact hxy
+
+private theorem
+    MorseCancel.nativeMorseCount_eq_of_preserved_indices {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ}
+    (hcrit : Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f)
+    (hindex :
+      ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+        nativeMorseIndex E g x = nativeMorseIndex E f x)
+    (k : ℕ) : nativeMorseCount E g k = nativeMorseCount E f k := by
+  have heq :
+    {x : M | x ∈ Smale.ManifoldMorse.criticalPoints E g ∧ nativeMorseIndex E g x = k} =
+      {x : M | x ∈ Smale.ManifoldMorse.criticalPoints E f ∧ nativeMorseIndex E f x = k} := by
+    ext x
+    change (_ ∧ _) ↔ (_ ∧ _)
+    rw [hcrit]
+    by_cases hx : x ∈ Smale.ManifoldMorse.criticalPoints E f
+    · rw [hindex x hx]
+    · simp only [hx, false_and]
+  exact congrArg Set.ncard heq
+
+private theorem MorseCancel.adapted_surgery_system_after_value_exchange {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ}
+    {p q : M} [FiniteDimensional ℝ E] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    (S : AdaptedWindows E f) (hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g)
+    (hmg : Smale.ManifoldMorse.IsMorse E g) (hp : p ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hq : q ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hcrit : Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f)
+    (hgp : g p = f q) (hgq : g q = f p)
+    (hothers : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, x ≠ p → x ≠ q → g =ᶠ[𝓝 x] f) :
+    Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) ∧ Nonempty (AdaptedWindows E g) := by
+  have hinj : Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) := by
+    rw [hcrit]
+    exact
+      injOn_of_exchanged_values S.distinct hp hq hgp hgq
+        (fun x hx hxp hxq => (hothers x hx hxp hxq).self_of_nhds)
+  exact ⟨hinj, nonempty_adaptedSurgeryWindows hg hmg hinj⟩
+
+private theorem
+    MorseCancel.exists_flow_preserving_value_exchange {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PreconnectedSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f))
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0)
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hmodels :
+      ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+        ∃ c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x,
+          ∀ᶠ y in 𝓝 x, V y = c.descentField y)
+    (p q : Smale.ManifoldMorse.criticalPoints E f) (hpq : f p < f q)
+    (hconsecutive : ∀ r : Smale.ManifoldMorse.criticalPoints E f, ¬(f p < f r ∧ f r < f q))
+    (hnoconnection :
+      ∀ x,
+        ¬(Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 q.val) ∧
+            Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p.val))) :
+    ∃ g : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+        Smale.ManifoldMorse.IsMorse E g ∧
+          Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f ∧
+            Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) ∧
+              g p = f q ∧
+                g q = f p ∧
+                  (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+                      x ≠ p.val → x ≠ q.val → g =ᶠ[𝓝 x] f) ∧
+                    (∀ x,
+                        x ∉ Smale.ManifoldMorse.criticalPoints E g →
+                          mvfderiv 𝓘(ℝ, E) g x (V x) < 0) ∧
+                      (∀ x ∈ Smale.ManifoldMorse.criticalPoints E g,
+                          ∃ c : Smale.ManifoldMorse.SignedMorseChart (E := E) g x,
+                            ∀ᶠ y in 𝓝 x, V y = c.descentField y) ∧
+                        (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+                            nativeMorseIndex E g x = nativeMorseIndex E f x) ∧
+                          ∀ k, nativeMorseCount E g k = nativeMorseCount E f k := by
+  obtain ⟨S⟩ := Smale.ManifoldMorse.nonempty_surgeryWindows hf hm hinj
+  obtain ⟨cp, hcp⟩ := hmodels p p.property
+  obtain ⟨cq, hcq⟩ := hmodels q q.property
+  have hp : f p ∈ Set.Ioo (S.lower p) (S.upper q) :=
+    ⟨S.lower_lt_value p, hpq.trans (S.value_lt_upper q)⟩
+  have hq : f q ∈ Set.Ioo (S.lower p) (S.upper q) :=
+    ⟨(S.lower_lt_value p).trans hpq, S.value_lt_upper q⟩
+  obtain ⟨g, hg, hmg, hcrit, hgp, hgq, hdescent, -, hpgerm, hqgerm, hothers, hindices⟩ :=
+    Degree.MorseRearrangement.exists_morse_rearrangement_of_no_connection hf hm hV F hF hzero
+      hdesc hinj cp cq hcp hcq hp hq hpq hq hp (surgery_pair_band_isolation S p q hconsecutive)
+      hnoconnection
+  have hinjg : Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) := by
+    rw [hcrit]
+    exact
+      injOn_of_exchanged_values hinj p.property q.property hgp hgq
+        (fun x hx hxp hxq => (hothers x hx hxp hxq).self_of_nhds)
+  have hnewmodels :
+    ∀ x ∈ Smale.ManifoldMorse.criticalPoints E g,
+      ∃ c : Smale.ManifoldMorse.SignedMorseChart (E := E) g x,
+        ∀ᶠ y in 𝓝 x, V y = c.descentField y := by
+    intro x hx
+    rw [hcrit] at hx
+    by_cases hxp : x = p.val
+    · subst x
+      obtain ⟨c, hc⟩ := exists_signed_morse_chart_of_shift_germ_preserving_field cp hpgerm
+      exact ⟨c, hc ▸ hcp⟩
+    by_cases hxq : x = q.val
+    · subst x
+      obtain ⟨c, hc⟩ := exists_signed_morse_chart_of_shift_germ_preserving_field cq hqgerm
+      exact ⟨c, hc ▸ hcq⟩
+    obtain ⟨c, hc⟩ := hmodels x hx
+    obtain ⟨d, hd⟩ := exists_signed_morse_chart_of_germ_preserving_field c (hothers x hx hxp hxq)
+    exact ⟨d, hd ▸ hc⟩
+  exact
+    ⟨g, hg, hmg, hcrit, hinjg, hgp, hgq, hothers, (fun x hx => hdescent x (hcrit ▸ hx)),
+      hnewmodels, hindices, nativeMorseCount_eq_of_preserved_indices hcrit hindices⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    Degree.MorseRearrangement.upperValueRank {X : Type*} [Fintype X] (h : X → ℝ) (x : X) : ℕ :=
+  (Finset.univ.filter (fun y => h x < h y)).card
+
+private def Degree.MorseRearrangement.finiteIndexDisorder {X : Type*} [Fintype X] (h : X → ℝ)
+    (w : X → ℕ) : ℕ :=
+  ∑ x, w x * upperValueRank h x
+
+private theorem
+    Degree.MorseRearrangement.upperValueRank_comp_equiv {X : Type*} [Fintype X] {Y : Type*}
+    [Fintype Y] (h : Y → ℝ) (e : X ≃ Y) (x : X) :
+    upperValueRank (h ∘ e) x = upperValueRank h (e x) := by
+  classical
+  unfold upperValueRank
+  rw [← Fintype.card_subtype, ← Fintype.card_subtype]
+  exact Fintype.card_congr (e.subtypeEquiv (fun _ => Iff.rfl))
+
+private theorem Degree.MorseRearrangement.finiteIndexDisorder_comp_equiv {X : Type*} [Fintype X]
+    {Y : Type*} [Fintype Y] (h : Y → ℝ) (w : Y → ℕ) (e : X ≃ Y) :
+    finiteIndexDisorder (h ∘ e) (w ∘ e) = finiteIndexDisorder h w := by
+  classical
+  unfold finiteIndexDisorder
+  calc
+    _ = ∑ x, w (e x) * upperValueRank h (e x) := by
+      apply Finset.sum_congr rfl
+      intro x _
+      rw [upperValueRank_comp_equiv]
+      rfl
+    _ = _ := e.sum_comp (fun y => w y * upperValueRank h y)
+
+private theorem
+    Degree.MorseRearrangement.upperValueRank_consecutive {X : Type*} [Fintype X] {h : X → ℝ}
+    (hi : Function.Injective h) {p q : X} (hpq : h p < h q)
+    (hconsecutive : ∀ x, ¬(h p < h x ∧ h x < h q)) :
+    upperValueRank h p = upperValueRank h q + 1 := by
+  classical
+  have hset :
+    Finset.univ.filter (fun x => h p < h x) =
+      Insert.insert q (Finset.univ.filter (fun x => h q < h x)) := by
+    ext x
+    simp only [Finset.mem_filter, Finset.mem_univ, true_and, Finset.mem_insert]
+    constructor
+    · intro hx
+      by_cases hxq : x = q
+      · exact Or.inl hxq
+      · apply Or.inr
+        by_contra hnot
+        have hlt : h x < h q := lt_of_le_of_ne (le_of_not_gt hnot) (fun heq => hxq (hi heq))
+        exact hconsecutive x ⟨hx, hlt⟩
+    · rintro (rfl | hx)
+      · exact hpq
+      · exact hpq.trans hx
+  unfold upperValueRank
+  rw [hset, Finset.card_insert_of_notMem (by simp)]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Degree.MorseRearrangement.sum_erase_two_nat {X : Type*} [Fintype X] (v : X → ℕ) {p q : X}
+    (hpq : p ≠ q) : ∑ x, v x = (∑ x ∈ (Finset.univ.erase p).erase q, v x) + v p + v q := by
+  classical
+  have hp := Finset.sum_erase_add (s := Finset.univ) v (Finset.mem_univ p)
+  have hq :=
+    Finset.sum_erase_add (s := Finset.univ.erase p) v
+      (by simp [Ne.symm hpq] : q ∈ Finset.univ.erase p)
+  omega
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Degree.MorseRearrangement.weighted_sum_swap_identity {X : Type*} [Fintype X] (w v : X → ℕ)
+    {p q : X} (hpq : p ≠ q) :
+    (∑ x, w x * v (Equiv.swap p q x)) + w p * v p + w q * v q =
+      (∑ x, w x * v x) + w p * v q + w q * v p := by
+  classical
+  have hnew := sum_erase_two_nat (fun x => w x * v (Equiv.swap p q x)) hpq
+  have hold := sum_erase_two_nat (fun x => w x * v x) hpq
+  have hrest :
+    (∑ x ∈ (Finset.univ.erase p).erase q, w x * v (Equiv.swap p q x)) =
+      ∑ x ∈ (Finset.univ.erase p).erase q, w x * v x := by
+    apply Finset.sum_congr rfl
+    intro x hx
+    have hxq := (Finset.mem_erase.mp hx).1
+    have hxp := (Finset.mem_erase.mp (Finset.mem_erase.mp hx).2).1
+    simp only [Equiv.swap_apply_def, ite_eq_right hxp, ite_eq_right hxq]
+  rw [hrest] at hnew
+  simp only [Equiv.swap_apply_left, Equiv.swap_apply_right] at hnew
+  omega
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Degree.MorseRearrangement.finiteIndexDisorder_swap_lt {X : Type*} [Fintype X] {h : X → ℝ}
+    (hi : Function.Injective h) (w : X → ℕ) {p q : X} (hpq : h p < h q)
+    (hconsecutive : ∀ x, ¬(h p < h x ∧ h x < h q)) (hw : w q < w p) :
+    finiteIndexDisorder (h ∘ Equiv.swap p q) w < finiteIndexDisorder h w := by
+  classical
+  have hne : p ≠ q := fun heq => (ne_of_lt hpq) (congrArg h heq)
+  have hrank := upperValueRank_consecutive hi hpq hconsecutive
+  have hid := weighted_sum_swap_identity w (upperValueRank h) hne
+  have hnew :
+    finiteIndexDisorder (h ∘ Equiv.swap p q) w = ∑ x, w x * upperValueRank h (Equiv.swap p q x) :=
+    by
+    unfold finiteIndexDisorder
+    apply Finset.sum_congr rfl
+    intro x _
+    rw [upperValueRank_comp_equiv]
+  rw [hrank] at hid
+  simp only [Nat.mul_add, Nat.mul_one] at hid
+  change _ < ∑ x, w x * upperValueRank h x
+  rw [hnew]
+  omega
+
+private theorem Degree.MorseRearrangement.exists_adjacent_index_inversion {X : Type*} [Finite X]
+    {h : X → ℝ} (hi : Function.Injective h) (w : X → ℕ) (hnot : ¬∀ x y, h x < h y → w x ≤ w y) :
+    ∃ p q, h p < h q ∧ (∀ x, ¬(h p < h x ∧ h x < h q)) ∧ w q < w p := by
+  classical
+  let := Fintype.ofFinite X
+  let _ : LinearOrder X := LinearOrder.lift' h hi
+  let _ : LocallyFiniteOrder X := Fintype.toLocallyFiniteOrder
+  have hnotmono : ¬Monotone w := by
+    intro hm
+    apply hnot
+    intro x y hxy
+    exact hm (show x ≤ y from hxy.le)
+  have hnotadj : ¬∀ x y : X, x ⋖ y → w x ≤ w y := by
+    intro hadj
+    exact hnotmono ((monotone_iff_forall_covBy w).mpr hadj)
+  simp only [Classical.not_forall, not_le] at hnotadj
+  obtain ⟨p, q, hcover, hweights⟩ := hnotadj
+  exact ⟨p, q, hcover.lt, fun x hx => hcover.2 hx.1 hx.2, hweights⟩
+
+private theorem
+    Degree.MorseRearrangement.exists_consecutive_below_of_intermediate {X : Type*} [Finite X]
+    {h : X → ℝ} {p q : X} (hintermediate : ∃ x, h p < h x ∧ h x < h q) :
+    ∃ r, h p < h r ∧ h r < h q ∧ ∀ x, ¬(h r < h x ∧ h x < h q) := by
+  classical
+  let := Fintype.ofFinite X
+  obtain ⟨w, hpw, hwq⟩ := hintermediate
+  let K := Finset.univ.filter (fun x => h x < h q)
+  have hw : w ∈ K := Finset.mem_filter.mpr ⟨Finset.mem_univ _, hwq⟩
+  obtain ⟨r, hr, hmax⟩ := K.exists_max_image h ⟨w, hw⟩
+  refine ⟨r, hpw.trans_le (hmax w hw), (Finset.mem_filter.mp hr).2, ?_⟩
+  intro x hx
+  exact (not_lt_of_ge (hmax x (Finset.mem_filter.mpr ⟨Finset.mem_univ _, hx.2⟩))) hx.1
+
+private def
+    Degree.MorseRearrangement.beforeValueRank {X : Type*} [Fintype X] (h : X → ℝ) (q : X) : ℕ :=
+  upperValueRank (fun x => -h x) q
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Degree.MorseRearrangement.beforeValueRank_exchange_lt {X : Type*} [Fintype X]
+    {h g : X → ℝ} (hi : Function.Injective h) {p q : X} (hpq : h p < h q)
+    (hconsecutive : ∀ x, ¬(h p < h x ∧ h x < h q)) (hgp : g p = h q) (hgq : g q = h p)
+    (hothers : ∀ x, x ≠ p → x ≠ q → g x = h x) : beforeValueRank g q < beforeValueRank h q := by
+  classical
+  have hform : (fun x => -g x) = (fun x => -h x) ∘ Equiv.swap p q := by
+    funext x
+    by_cases hxp : x = p
+    · subst x
+      simp only [Function.comp_apply, Equiv.swap_apply_left, hgp]
+    by_cases hxq : x = q
+    · subst x
+      simp only [Function.comp_apply, Equiv.swap_apply_right, hgq]
+    simp only [Function.comp_apply, Equiv.swap_apply_def, ite_eq_right hxp, ite_eq_right hxq,
+      hothers x hxp hxq]
+  have hnew : beforeValueRank g q = beforeValueRank h p := by
+    unfold beforeValueRank
+    rw [hform, upperValueRank_comp_equiv, Equiv.swap_apply_right]
+  have hneg : Function.Injective (fun x => -h x) := fun x y hxy => hi (neg_injective hxy)
+  have hgap : beforeValueRank h q = beforeValueRank h p + 1 := by
+    apply upperValueRank_consecutive hneg (neg_lt_neg hpq)
+    intro x hx
+    exact hconsecutive x ⟨neg_lt_neg_iff.mp hx.2, neg_lt_neg_iff.mp hx.1⟩
+  omega
+
+private theorem
+    MorseCancel.exists_flow_preserving_consecutive_pair {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PreconnectedSpace M] {f₀ : M → ℝ}
+    (hf₀ : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f₀) (hm₀ : Smale.ManifoldMorse.IsMorse E f₀)
+    (hinj₀ : Set.InjOn f₀ (Smale.ManifoldMorse.criticalPoints E f₀))
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f₀, V x = 0)
+    (hdesc₀ : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f₀ → mvfderiv 𝓘(ℝ, E) f₀ x (V x) < 0)
+    (hmodels₀ :
+      ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f₀,
+        ∃ c : Smale.ManifoldMorse.SignedMorseChart (E := E) f₀ x,
+          ∀ᶠ y in 𝓝 x, V y = c.descentField y)
+    (p r q : Smale.ManifoldMorse.criticalPoints E f₀) (hrp : f₀ r < f₀ p) (hpq : f₀ p < f₀ q)
+    (hnoconnection :
+      ∀ j : Smale.ManifoldMorse.criticalPoints E f₀,
+        j ≠ q →
+          j ≠ p →
+            j ≠ r →
+              ∀ x,
+                ¬(Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 q.val) ∧
+                    Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 j.val))) :
+    ∃ f : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f ∧
+        Smale.ManifoldMorse.IsMorse E f ∧
+          Smale.ManifoldMorse.criticalPoints E f = Smale.ManifoldMorse.criticalPoints E f₀ ∧
+            Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f) ∧
+              f p = f₀ p ∧
+                f r = f₀ r ∧
+                  f p < f q ∧
+                    (∀ z : Smale.ManifoldMorse.criticalPoints E f₀, ¬(f p < f z ∧ f z < f q)) ∧
+                      (∀ x,
+                          x ∉ Smale.ManifoldMorse.criticalPoints E f →
+                            mvfderiv 𝓘(ℝ, E) f x (V x) < 0) ∧
+                        (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+                            ∃ c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x,
+                              ∀ᶠ y in 𝓝 x, V y = c.descentField y) ∧
+                          ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f₀,
+                            nativeMorseIndex E f x = nativeMorseIndex E f₀ x := by
+  classical
+  let _ := (Smale.ManifoldMorse.finite_criticalPoints hf₀ hm₀).fintype
+  let P : ℕ → Prop := fun n =>
+    ∃ f : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f ∧
+        Smale.ManifoldMorse.IsMorse E f ∧
+          Smale.ManifoldMorse.criticalPoints E f = Smale.ManifoldMorse.criticalPoints E f₀ ∧
+            Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f) ∧
+              f p = f₀ p ∧
+                f r = f₀ r ∧
+                  f p < f q ∧
+                    (∀ x,
+                        x ∉ Smale.ManifoldMorse.criticalPoints E f →
+                          mvfderiv 𝓘(ℝ, E) f x (V x) < 0) ∧
+                      (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+                          ∃ c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x,
+                            ∀ᶠ y in 𝓝 x, V y = c.descentField y) ∧
+                        (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f₀,
+                            nativeMorseIndex E f x = nativeMorseIndex E f₀ x) ∧
+                          Degree.MorseRearrangement.beforeValueRank
+                              (fun x : Smale.ManifoldMorse.criticalPoints E f₀ => f x) q =
+                            n
+  have hex : ∃ n, P n :=
+    ⟨Degree.MorseRearrangement.beforeValueRank
+        (fun x : Smale.ManifoldMorse.criticalPoints E f₀ => f₀ x) q,
+      f₀, hf₀, hm₀, rfl, hinj₀, rfl, rfl, hpq, hdesc₀, hmodels₀, fun _ _ => rfl, rfl⟩
+  obtain ⟨f, hf, hm, hcrit, hinj, hfp, hfr, hfpq, hdesc, hmodels, hindices, hrank⟩ :=
+    Nat.find_spec hex
+  have hconsecutive : ∀ z : Smale.ManifoldMorse.criticalPoints E f₀, ¬(f p < f z ∧ f z < f q) := by
+    by_contra hnot
+    push Not at hnot
+    obtain ⟨z, hpz, hzq, hbefore⟩ :=
+      Degree.MorseRearrangement.exists_consecutive_below_of_intermediate (h :=
+        fun x : Smale.ManifoldMorse.criticalPoints E f₀ => f x) (p := p) (q := q) hnot
+    have hzp : z.val ≠ p.val := fun h => (ne_of_lt hpz) (congrArg f h).symm
+    have hzq' : z.val ≠ q.val := fun h => (ne_of_lt hzq) (congrArg f h)
+    have hzr : z.val ≠ r.val := by
+      intro h
+      have hrp' : f r < f p := by rw [hfr, hfp]; exact hrp
+      exact (not_lt_of_gt hpz) (by simpa only [h] using hrp')
+    let zf : Smale.ManifoldMorse.criticalPoints E f := ⟨z.val, by rw [hcrit]; exact z.property⟩
+    let qf : Smale.ManifoldMorse.criticalPoints E f := ⟨q.val, by rw [hcrit]; exact q.property⟩
+    have hbeforef : ∀ s : Smale.ManifoldMorse.criticalPoints E f, ¬(f zf < f s ∧ f s < f qf) := by
+      intro s hs
+      exact hbefore ⟨s.val, by rw [← hcrit]; exact s.property⟩ hs
+    obtain ⟨g, hg, hmg, hcritg, hinjg, hgz, hgq, hothers, hdescg, hmodelsg, hindicesg, -⟩ :=
+      exists_flow_preserving_value_exchange hf hm hinj hV F hF (fun x hx => hzero x (hcrit ▸ hx))
+        hdesc hmodels zf qf hzq hbeforef
+        (hnoconnection z (fun h => hzq' (congrArg Subtype.val h))
+          (fun h => hzp (congrArg Subtype.val h)) (fun h => hzr (congrArg Subtype.val h)))
+    have hpcrit : p.val ∈ Smale.ManifoldMorse.criticalPoints E f := by
+      rw [hcrit]
+      exact p.property
+    have hrcrit : r.val ∈ Smale.ManifoldMorse.criticalPoints E f := by
+      rw [hcrit]
+      exact r.property
+    have hpq' : p.val ≠ q.val := fun h => (ne_of_lt hfpq) (congrArg f h)
+    have hrq' : r.val ≠ q.val := by
+      intro h
+      have hrp' : f r < f p := by rw [hfr, hfp]; exact hrp
+      have hlt : f r < f q := hrp'.trans hfpq
+      exact (ne_of_lt hlt) (congrArg f h)
+    have hgp : g p = f p := (hothers p hpcrit hzp.symm hpq').self_of_nhds
+    have hgr : g r = f r := (hothers r hrcrit hzr.symm hrq').self_of_nhds
+    have hidxg₀ (x : M) (hx : x ∈ Smale.ManifoldMorse.criticalPoints E f₀) :
+      nativeMorseIndex E g x = nativeMorseIndex E f₀ x :=
+      (hindicesg x (by rw [hcrit]; exact hx)).trans (hindices x hx)
+    have hdecrease :
+      Degree.MorseRearrangement.beforeValueRank
+          (fun x : Smale.ManifoldMorse.criticalPoints E f₀ => g x) q <
+        Degree.MorseRearrangement.beforeValueRank
+          (fun x : Smale.ManifoldMorse.criticalPoints E f₀ => f x) q := by
+      apply
+        Degree.MorseRearrangement.beforeValueRank_exchange_lt (h :=
+          fun x : Smale.ManifoldMorse.criticalPoints E f₀ => f x) (g :=
+          fun x : Smale.ManifoldMorse.criticalPoints E f₀ => g x) (p := z) (q := q)
+          (fun x y h =>
+            Subtype.ext
+              (hinj (by rw [hcrit]; exact x.property) (by rw [hcrit]; exact y.property) h))
+          hzq hbefore hgz hgq
+      intro x hxz hxq
+      exact
+        (hothers x (by rw [hcrit]; exact x.property) (fun h => hxz (Subtype.ext h))
+            (fun h => hxq (Subtype.ext h))).self_of_nhds
+    have hminimal :=
+      Nat.find_min' hex
+        ⟨g, hg, hmg, hcritg.trans hcrit, hinjg, hgp.trans hfp, hgr.trans hfr,
+          (by rw [hgp, hgq]; exact hpz), hdescg, hmodelsg, hidxg₀, rfl⟩
+    rw [← hrank] at hminimal
+    exact (not_le_of_gt hdecrease) hminimal
+  exact ⟨f, hf, hm, hcrit, hinj, hfp, hfr, hfpq, hconsecutive, hdesc, hmodels, hindices⟩
+
+private theorem
+    MorseCancel.isOpen_forward_basin_of_native_index_zero {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ}
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0)
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hmodel : ∀ᶠ y in 𝓝 p, V y = c.descentField y)
+    (hindex : Module.finrank ℝ c.NegativeCoordinates = 0) :
+    IsOpen {x : M | Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p)} := by
+  let : Subsingleton c.NegativeCoordinates :=
+    (Module.finrank_eq_zero_iff_of_free ℝ c.NegativeCoordinates).mp hindex
+  obtain ⟨r, hr, -, hbasin⟩ :=
+    exists_descending_morse_basin_block c hf (hV.of_le (by simp)) F hF hzero hdesc hmodel
+  have hnear : ∀ᶠ y in 𝓝 p, Filter.Tendsto (fun t => F t y) Filter.atTop (𝓝 p) := by
+    filter_upwards [morse_coordinate_neighborhood c hr hr] with y hy
+    exact ((hbasin y hy.1 hy.2.1 hy.2.2).1).mpr (Subsingleton.elim _ _)
+  apply isOpen_iff_mem_nhds.mpr
+  intro x hx
+  obtain ⟨t, ht⟩ := (hx.eventually (eventually_eventually_nhds.mpr hnear)).exists
+  have hc : Continuous (fun y => F t y) := F.continuous continuous_const continuous_id
+  filter_upwards [hc.continuousAt.tendsto.eventually ht] with y hy
+  exact (flow_time_atTop_limit_iff F t y p).mp hy
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.cancel_unique_zero_one_connection {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {p q z : M}
+    (cp : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (cq : Smale.ManifoldMorse.SignedMorseChart (E := E) f q) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (hindexp : nativeMorseIndex E f p = 0)
+    (hindexq : nativeMorseIndex E f q = 1)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0)
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f))
+    (hpc : p ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hqc : q ∈ Smale.ManifoldMorse.criticalPoints E f) (hpq : f p < f q) {l u : ℝ} (hl : l < f p)
+    (hu : f q < u)
+    (hpair : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, f x ∈ Set.Icc l u → x = p ∨ x = q)
+    (hp : Filter.Tendsto (fun t => F t z) Filter.atTop (𝓝 p))
+    (hq : Filter.Tendsto (fun t => F t z) Filter.atBot (𝓝 q))
+    (hunique :
+      ∀ x,
+        Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 q) →
+          Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p) → ∃ t, F t z = x)
+    (heqp : ∀ᶠ x in 𝓝 p, V x = cp.descentField x) (heqq : ∀ᶠ x in 𝓝 q, V x = cq.descentField x) :
+    ∃ g : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+        Smale.ManifoldMorse.IsMorse E g ∧
+          (Smale.ManifoldMorse.criticalPoints E g).ncard + 2 =
+              (Smale.ManifoldMorse.criticalPoints E f).ncard ∧
+            (∀ x,
+                x ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+                  x ∈ Smale.ManifoldMorse.criticalPoints E f ∧ x ≠ p ∧ x ≠ q) ∧
+              ∀ x, f x ∉ Set.Ioo l u → g =ᶠ[𝓝 x] f := by
+  have hp0 : Module.finrank ℝ cp.NegativeCoordinates = 0 :=
+    (nativeMorseIndex_eq_chart cp).symm.trans hindexp
+  have hq1 : Module.finrank ℝ cq.NegativeCoordinates = 1 :=
+    (nativeMorseIndex_eq_chart cq).symm.trans hindexq
+  have hdim : Module.finrank ℝ E = (Module.finrank ℝ E - 1) + 1 := by
+    have h := cq.finrank_negative_add_positive
+    omega
+  have hindex :
+    Fintype.card { i // cq.weights i = -1 } = Fintype.card { i // cp.weights i = -1 } + 1 := by
+    have h :
+      Module.finrank ℝ cq.NegativeCoordinates = Module.finrank ℝ cp.NegativeCoordinates + 1 := by
+      omega
+    simpa only [Smale.ManifoldMorse.SignedMorseChart.NegativeCoordinates,
+      Smale.MorseHandle.NegativeSpace, finrank_euclideanSpace] using h
+  have hbasin : ∀ᶠ x in 𝓝 z, Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p) :=
+    (isOpen_forward_basin_of_native_index_zero cp hf hV F hF hzero hdesc heqp hp0).mem_nhds hp
+  have htrans :
+    Smale.NativeTransversality.At 𝓘(ℝ, E) 𝓘(ℝ, E) 𝓘(ℝ, E) (fun _ : M => z) (fun x : M => x) z z :=
+    by
+    intro _ w
+    refine ⟨(0, w), ?_⟩
+    change
+      mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) (fun _ : M => z) z 0 +
+          mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) (fun x : M => x) z w =
+        w
+    rw [map_zero, zero_add]
+    change mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) id z w = w
+    rw [mfderiv_id]
+    rfl
+  exact
+    cancel_unique_connection_of_transverse_basin_sheets cp cq hf hm hdim hindex V hV hzero hdesc F
+      hF hinj hpc hqc hpq hl hu hpair hp hq hunique heqp heqq (S := fun _ : M => z) (T :=
+      fun x : M => x) mdifferentiableAt_const mdifferentiableAt_id rfl rfl
+      (Filter.Eventually.of_forall (fun _ => hq)) hbasin htrans
+
+private def Smale.EmbeddedCellAttachment.oldHomologyEquiv {N X : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) (k : ℕ) :
+    SingularMayerVietoris.SingularHomology D.old k ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology D.oldNeighborhood k :=
+  PeriodTorusHigherHomology.homotopyEquivHomologyEquiv D.oldHomotopyEquiv k
+
+private def Smale.EmbeddedCellAttachment.overlapHomologyEquiv {N X : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) (k : ℕ) :
+    SingularMayerVietoris.SingularHomology (Metric.sphere (0 : N) 1) k ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (↥(D.oldNeighborhood ∩ D.diskPatch)) k :=
+  PeriodTorusHigherHomology.homotopyEquivHomologyEquiv D.overlapSphereEquiv k
+
+private def Smale.EmbeddedCellAttachment.attachingHomologyMap {N X : Type} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) (k : ℕ) :
+    SingularMayerVietoris.SingularHomology (Metric.sphere (0 : N) 1) k →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology D.old k :=
+  SingularMayerVietoris.singularHomologyMap D.attachingSphere k
+
+private def Smale.EmbeddedCellAttachment.oldHomologyMap {N X : Type} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) (k : ℕ) :
+    SingularMayerVietoris.SingularHomology D.old k →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology X k :=
+  SingularMayerVietoris.singularHomologyMap (SingularMayerVietoris.subtypeInclusion D.old) k
+
+private def Smale.EmbeddedCellAttachment.cellConnectingMap {N X : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) (k : ℕ) :
+    SingularMayerVietoris.SingularHomology X (k + 1) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (Metric.sphere (0 : N) 1) k :=
+  (D.overlapHomologyEquiv k).symm.toLinearMap.comp
+    (SingularMayerVietoris.connectingHomomorphism D.oldNeighborhood D.diskPatch
+      D.isOpen_oldNeighborhood D.isOpen_diskPatch D.open_cover k)
+
+private theorem Smale.EmbeddedCellAttachment.diskPatch_homology_subsingleton {N X : Type}
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [TopologicalSpace X]
+    (D : Smale.EmbeddedCellAttachment N X) (k : ℕ) (hk : k ≠ 0) :
+    Subsingleton (SingularMayerVietoris.SingularHomology D.diskPatch k) := by
+  let := D.diskPatch_contractible
+  exact PeriodTorusHigherHomology.contractible_homology_subsingleton D.diskPatch k hk
+
+private theorem Smale.EmbeddedCellAttachment.coverLeft_old {N X : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (Metric.sphere (0 : N) 1) k) :
+    (D.oldHomologyEquiv k).symm
+        (SingularMayerVietoris.leftHomologyMap D.oldNeighborhood D.diskPatch k
+            (D.overlapHomologyEquiv k a)).1 =
+      D.attachingHomologyMap k a := by
+  rw [SingularMayerVietoris.leftHomologyMap_apply]
+  change
+    SingularMayerVietoris.singularHomologyMap D.oldRetraction k
+        (SingularMayerVietoris.singularHomologyMap (ContinuousMap.inclusion Set.inter_subset_left)
+          k (SingularMayerVietoris.singularHomologyMap D.overlapSphereEquiv.toFun k a)) =
+      SingularMayerVietoris.singularHomologyMap D.attachingSphere k a
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp, ←
+    LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp]
+  change
+    SingularMayerVietoris.singularHomologyMap (D.overlapOldMap.comp D.overlapSphereEquiv.toFun) k
+        a =
+      _
+  rw [D.overlapOldMap_comp_sphere]
+
+private theorem Smale.EmbeddedCellAttachment.coverRight_old {N X : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology D.old k) :
+    SingularMayerVietoris.rightHomologyMap D.oldNeighborhood D.diskPatch k
+        (D.oldHomologyEquiv k a, 0) =
+      D.oldHomologyMap k a := by
+  rw [SingularMayerVietoris.rightHomologyMap_apply, map_zero, add_zero]
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (SingularMayerVietoris.subtypeInclusion D.oldNeighborhood) k
+        (SingularMayerVietoris.singularHomologyMap D.oldInclusion k a) =
+      SingularMayerVietoris.singularHomologyMap (SingularMayerVietoris.subtypeInclusion D.old) k a
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp]
+  rfl
+
+private theorem Smale.EmbeddedCellAttachment.coverLeft_formula {N X : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) (k : ℕ)
+    (hk : k ≠ 0) (a : SingularMayerVietoris.SingularHomology (Metric.sphere (0 : N) 1) k) :
+    SingularMayerVietoris.leftHomologyMap D.oldNeighborhood D.diskPatch k
+        (D.overlapHomologyEquiv k a) =
+      (D.oldHomologyEquiv k (D.attachingHomologyMap k a), 0) := by
+  let := D.diskPatch_homology_subsingleton k hk
+  apply Prod.ext
+  · exact (D.oldHomologyEquiv k).symm_apply_eq.mp (D.coverLeft_old k a)
+  · exact Subsingleton.elim _ _
+
+private theorem Smale.EmbeddedCellAttachment.coverRight_formula {N X : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) (k : ℕ)
+    (hk : k ≠ 0)
+    (b :
+      SingularMayerVietoris.SingularHomology D.oldNeighborhood k ×
+        SingularMayerVietoris.SingularHomology D.diskPatch k) :
+    SingularMayerVietoris.rightHomologyMap D.oldNeighborhood D.diskPatch k b =
+      D.oldHomologyMap k ((D.oldHomologyEquiv k).symm b.1) := by
+  let := D.diskPatch_homology_subsingleton k hk
+  have hb : (D.oldHomologyEquiv k ((D.oldHomologyEquiv k).symm b.1), 0) = b :=
+    Prod.ext ((D.oldHomologyEquiv k).apply_symm_apply b.1) (Subsingleton.elim _ _)
+  calc
+    _ =
+        SingularMayerVietoris.rightHomologyMap D.oldNeighborhood D.diskPatch k
+          (D.oldHomologyEquiv k ((D.oldHomologyEquiv k).symm b.1), 0) :=
+      congrArg (SingularMayerVietoris.rightHomologyMap D.oldNeighborhood D.diskPatch k) hb.symm
+    _ = _ := D.coverRight_old k _
+
+private theorem Smale.EmbeddedCellAttachment.cellConnecting_eq_zero_iff {N X : Type}
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [TopologicalSpace X]
+    (D : Smale.EmbeddedCellAttachment N X) (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology X (k + 1)) :
+    D.cellConnectingMap k a = 0 ↔
+      SingularMayerVietoris.connectingHomomorphism D.oldNeighborhood D.diskPatch
+          D.isOpen_oldNeighborhood D.isOpen_diskPatch D.open_cover k a =
+        0 := by
+  change (D.overlapHomologyEquiv k).symm _ = 0 ↔ _ = 0
+  constructor
+  · intro h
+    exact (D.overlapHomologyEquiv k).symm.injective (h.trans (map_zero _).symm)
+  · intro h
+    rw [h, map_zero]
+
+private theorem Smale.EmbeddedCellAttachment.range_coverRight {N X : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) (k : ℕ)
+    (hk : k ≠ 0) :
+    LinearMap.range (SingularMayerVietoris.rightHomologyMap D.oldNeighborhood D.diskPatch k) =
+      LinearMap.range (D.oldHomologyMap k) := by
+  ext a
+  constructor
+  · rintro ⟨b, rfl⟩
+    exact ⟨(D.oldHomologyEquiv k).symm b.1, (D.coverRight_formula k hk b).symm⟩
+  · rintro ⟨b, rfl⟩
+    exact ⟨(D.oldHomologyEquiv k b, 0), D.coverRight_old k b⟩
+
+private theorem Smale.EmbeddedCellAttachment.cell_exact_at_old {N X : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) (k : ℕ)
+    (hk : k ≠ 0) :
+    LinearMap.range (D.attachingHomologyMap k) = LinearMap.ker (D.oldHomologyMap k) := by
+  ext a
+  constructor
+  · rintro ⟨s, rfl⟩
+    have hzero :=
+      LinearMap.congr_fun
+        (SingularMayerVietoris.leftHomologyMap_comp_right D.oldNeighborhood D.diskPatch k)
+        (D.overlapHomologyEquiv k s)
+    change
+      SingularMayerVietoris.rightHomologyMap D.oldNeighborhood D.diskPatch k
+          (SingularMayerVietoris.leftHomologyMap D.oldNeighborhood D.diskPatch k
+            (D.overlapHomologyEquiv k s)) =
+        0 at hzero
+    rw [D.coverLeft_formula k hk, D.coverRight_old] at hzero
+    exact hzero
+  · intro ha
+    have hpair :
+      (D.oldHomologyEquiv k a, 0) ∈
+        LinearMap.ker (SingularMayerVietoris.rightHomologyMap D.oldNeighborhood D.diskPatch k) := by
+      change
+        SingularMayerVietoris.rightHomologyMap D.oldNeighborhood D.diskPatch k
+            (D.oldHomologyEquiv k a, 0) =
+          0
+      rw [D.coverRight_old]
+      exact ha
+    rw [←
+      SingularMayerVietoris.exact_at_pair D.oldNeighborhood D.diskPatch D.isOpen_oldNeighborhood
+        D.isOpen_diskPatch D.open_cover k] at hpair
+    obtain ⟨c, hc⟩ := hpair
+    refine ⟨(D.overlapHomologyEquiv k).symm c, ?_⟩
+    have hc' :
+      SingularMayerVietoris.leftHomologyMap D.oldNeighborhood D.diskPatch k
+          (D.overlapHomologyEquiv k ((D.overlapHomologyEquiv k).symm c)) =
+        (D.oldHomologyEquiv k a, 0) := by
+      rw [LinearEquiv.apply_symm_apply]
+      exact hc
+    rw [D.coverLeft_formula k hk] at hc'
+    have heq :=
+      congrArg
+        (fun b :
+            SingularMayerVietoris.SingularHomology D.oldNeighborhood k ×
+              SingularMayerVietoris.SingularHomology D.diskPatch k =>
+          b.1)
+        hc'
+    exact (D.oldHomologyEquiv k).injective heq
+
+private theorem
+    Smale.EmbeddedCellAttachment.cell_exact_at_ambient {N X : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) (k : ℕ) :
+    LinearMap.range (D.oldHomologyMap (k + 1)) = LinearMap.ker (D.cellConnectingMap k) := by
+  rw [← D.range_coverRight (k + 1) (Nat.succ_ne_zero k),
+    SingularMayerVietoris.exact_at_ambient D.oldNeighborhood D.diskPatch D.isOpen_oldNeighborhood
+      D.isOpen_diskPatch D.open_cover k]
+  ext a
+  exact (D.cellConnecting_eq_zero_iff k a).symm
+
+private theorem
+    Smale.EmbeddedCellAttachment.mem_range_cellConnecting {N X : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (Metric.sphere (0 : N) 1) k) :
+    a ∈ LinearMap.range (D.cellConnectingMap k) ↔
+      D.overlapHomologyEquiv k a ∈
+        LinearMap.range
+          (SingularMayerVietoris.connectingHomomorphism D.oldNeighborhood D.diskPatch
+            D.isOpen_oldNeighborhood D.isOpen_diskPatch D.open_cover k) := by
+  constructor
+  · rintro ⟨x, rfl⟩
+    refine ⟨x, ?_⟩
+    change _ = D.overlapHomologyEquiv k ((D.overlapHomologyEquiv k).symm _)
+    rw [LinearEquiv.apply_symm_apply]
+  · rintro ⟨x, hx⟩
+    refine ⟨x, ?_⟩
+    change (D.overlapHomologyEquiv k).symm _ = a
+    rw [hx, LinearEquiv.symm_apply_apply]
+
+private theorem
+    Smale.EmbeddedCellAttachment.coverLeft_eq_zero_iff {N X : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) (k : ℕ)
+    (hk : k ≠ 0) (a : SingularMayerVietoris.SingularHomology (Metric.sphere (0 : N) 1) k) :
+    SingularMayerVietoris.leftHomologyMap D.oldNeighborhood D.diskPatch k
+          (D.overlapHomologyEquiv k a) =
+        0 ↔
+      D.attachingHomologyMap k a = 0 := by
+  rw [D.coverLeft_formula k hk]
+  constructor
+  · intro h
+    have heq :=
+      congrArg
+        (fun b :
+            SingularMayerVietoris.SingularHomology D.oldNeighborhood k ×
+              SingularMayerVietoris.SingularHomology D.diskPatch k =>
+          b.1)
+        h
+    exact (D.oldHomologyEquiv k).injective (heq.trans (map_zero _).symm)
+  · intro h
+    rw [h, map_zero]
+    rfl
+
+private theorem
+    Smale.EmbeddedCellAttachment.cell_exact_at_sphere {N X : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) (k : ℕ)
+    (hk : k ≠ 0) :
+    LinearMap.range (D.cellConnectingMap k) = LinearMap.ker (D.attachingHomologyMap k) := by
+  ext a
+  rw [D.mem_range_cellConnecting k,
+    SingularMayerVietoris.exact_at_intersection D.oldNeighborhood D.diskPatch
+      D.isOpen_oldNeighborhood D.isOpen_diskPatch D.open_cover k]
+  exact D.coverLeft_eq_zero_iff k hk a
+
+private theorem
+    Smale.EmbeddedCellAttachment.cellConnecting_zero_apply {N X : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X)
+    [PathConnectedSpace (Metric.sphere (0 : N) 1)]
+    (a : SingularMayerVietoris.SingularHomology X 1) : D.cellConnectingMap 0 a = 0 := by
+  let : ContractibleSpace D.diskPatch := D.diskPatch_contractible
+  let q : C(Metric.sphere (0 : N) 1, D.diskPatch) :=
+    (ContinuousMap.inclusion Set.inter_subset_right).comp D.overlapSphereEquiv.toFun
+  have hc :
+    D.overlapHomologyEquiv 0 (D.cellConnectingMap 0 a) ∈
+      LinearMap.ker (SingularMayerVietoris.leftHomologyMap D.oldNeighborhood D.diskPatch 0) := by
+    rw [←
+      SingularMayerVietoris.exact_at_intersection D.oldNeighborhood D.diskPatch
+        D.isOpen_oldNeighborhood D.isOpen_diskPatch D.open_cover 0]
+    exact (D.mem_range_cellConnecting 0 _).mp ⟨a, rfl⟩
+  change
+    SingularMayerVietoris.leftHomologyMap D.oldNeighborhood D.diskPatch 0
+        (D.overlapHomologyEquiv 0 (D.cellConnectingMap 0 a)) =
+      0 at hc
+  have h := congrArg Prod.snd hc
+  rw [SingularMayerVietoris.leftHomologyMap_apply] at h
+  have hz : SingularMayerVietoris.singularHomologyMap q 0 (D.cellConnectingMap 0 a) = 0 := by
+    rw [PeriodTorusHigherHomology.singularHomologyMap_comp]
+    exact neg_eq_zero.mp h
+  apply SphereHomology.singularHomologyMap_zero_injective q
+  exact hz.trans (map_zero _).symm
+
+private theorem MorseCancel.cell_oldHomologyMap_zero_injective {N X : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X)
+    [PathConnectedSpace (Metric.sphere (0 : N) 1)] : Function.Injective (D.oldHomologyMap 0) := by
+  let : ContractibleSpace D.diskPatch := D.diskPatch_contractible
+  let q : C(Metric.sphere (0 : N) 1, D.diskPatch) :=
+    (ContinuousMap.inclusion Set.inter_subset_right).comp D.overlapSphereEquiv.toFun
+  apply (LinearMap.ker_eq_bot).mp
+  apply LinearMap.ker_eq_bot'.mpr
+  intro a ha
+  have hpair :
+    (D.oldHomologyEquiv 0 a, 0) ∈
+      LinearMap.ker (SingularMayerVietoris.rightHomologyMap D.oldNeighborhood D.diskPatch 0) := by
+    change
+      SingularMayerVietoris.rightHomologyMap D.oldNeighborhood D.diskPatch 0
+          (D.oldHomologyEquiv 0 a, 0) =
+        0
+    rw [D.coverRight_old]
+    exact ha
+  rw [←
+    SingularMayerVietoris.exact_at_pair D.oldNeighborhood D.diskPatch D.isOpen_oldNeighborhood
+      D.isOpen_diskPatch D.open_cover 0] at hpair
+  obtain ⟨c, hc⟩ := hpair
+  have hq :
+    SingularMayerVietoris.singularHomologyMap q 0 ((D.overlapHomologyEquiv 0).symm c) = 0 := by
+    have h := congrArg Prod.snd hc
+    rw [SingularMayerVietoris.leftHomologyMap_apply] at h
+    rw [PeriodTorusHigherHomology.singularHomologyMap_comp]
+    change
+      SingularMayerVietoris.singularHomologyMap (ContinuousMap.inclusion Set.inter_subset_right) 0
+          (D.overlapHomologyEquiv 0 ((D.overlapHomologyEquiv 0).symm c)) =
+        0
+    rw [LinearEquiv.apply_symm_apply]
+    exact neg_eq_zero.mp h
+  have hz : (D.overlapHomologyEquiv 0).symm c = 0 :=
+    SphereHomology.singularHomologyMap_zero_injective q (hq.trans (map_zero _).symm)
+  have hc0 : c = 0 := by
+    apply (D.overlapHomologyEquiv 0).symm.injective
+    exact hz.trans (map_zero _).symm
+  rw [hc0, map_zero] at hc
+  apply (D.oldHomologyEquiv 0).injective
+  exact (congrArg Prod.fst hc).symm.trans (map_zero _).symm
+
+private theorem MorseCancel.cell_oldHomologyMap_zero_surjective {N X : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X)
+    [PathConnectedSpace (Metric.sphere (0 : N) 1)] : Function.Surjective (D.oldHomologyMap 0) := by
+  let : ContractibleSpace D.diskPatch := D.diskPatch_contractible
+  let q : C(Metric.sphere (0 : N) 1, D.diskPatch) :=
+    (ContinuousMap.inclusion Set.inter_subset_right).comp D.overlapSphereEquiv.toFun
+  intro a
+  obtain ⟨⟨b, c⟩, hbc⟩ :=
+    SingularMayerVietoris.rightHomologyMap_zero_surjective D.oldNeighborhood D.diskPatch
+      D.isOpen_oldNeighborhood D.isOpen_diskPatch D.open_cover a
+  obtain ⟨z, hz⟩ := SphereHomology.singularHomologyMap_zero_surjective q c
+  let v := D.overlapHomologyEquiv 0 z
+  have hv :
+    SingularMayerVietoris.singularHomologyMap (ContinuousMap.inclusion Set.inter_subset_right) 0
+        v =
+      c := by
+    rw [PeriodTorusHigherHomology.singularHomologyMap_comp] at hz
+    exact hz
+  have hzero :=
+    LinearMap.congr_fun
+      (SingularMayerVietoris.leftHomologyMap_comp_right D.oldNeighborhood D.diskPatch 0) v
+  change
+    SingularMayerVietoris.rightHomologyMap D.oldNeighborhood D.diskPatch 0
+        (SingularMayerVietoris.leftHomologyMap D.oldNeighborhood D.diskPatch 0 v) =
+      0 at hzero
+  rw [SingularMayerVietoris.leftHomologyMap_apply, SingularMayerVietoris.rightHomologyMap_apply,
+    map_neg, hv] at hzero
+  have hrel :
+    SingularMayerVietoris.singularHomologyMap
+        (SingularMayerVietoris.subtypeInclusion D.oldNeighborhood) 0
+        (SingularMayerVietoris.singularHomologyMap (ContinuousMap.inclusion Set.inter_subset_left)
+          0 v) =
+      SingularMayerVietoris.singularHomologyMap
+        (SingularMayerVietoris.subtypeInclusion D.diskPatch) 0 c := by
+    apply sub_eq_zero.mp
+    simpa only [sub_eq_add_neg] using hzero
+  refine
+    ⟨(D.oldHomologyEquiv 0).symm
+        (b +
+          SingularMayerVietoris.singularHomologyMap
+            (ContinuousMap.inclusion Set.inter_subset_left) 0 v),
+      ?_⟩
+  rw [← D.coverRight_old, LinearEquiv.apply_symm_apply,
+    SingularMayerVietoris.rightHomologyMap_apply, map_zero, add_zero, map_add, hrel]
+  exact hbc
+
+private theorem MorseCancel.cell_oldHomologyMap_zero_bijective {N X : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X)
+    [PathConnectedSpace (Metric.sphere (0 : N) 1)] : Function.Bijective (D.oldHomologyMap 0) :=
+  ⟨cell_oldHomologyMap_zero_injective D, cell_oldHomologyMap_zero_surjective D⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private def MorseCancel.componentChainWeight {X : Type} [TopologicalSpace X] (x : X) :
+    FirstHurewicz.Chains X 0 →ₗ[ℤ] ℤ :=
+  FirstHurewicz.chainLift X 0 (fun σ => if Joined x (σ (stdSimplex.vertex 0)) then 1 else 0)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.componentChainWeight_point {X : Type} [TopologicalSpace X] (x y : X) :
+    componentChainWeight x (FirstHurewicz.pointChain y) = if Joined x y then 1 else 0 := by
+  exact FirstHurewicz.chainLift_simplex X 0 _ _
+
+private theorem MorseCancel.componentChainWeight_boundary {X : Type} [TopologicalSpace X] (x : X)
+    (b : FirstHurewicz.Chains X 1) : componentChainWeight x (FirstHurewicz.boundaryOne X b) = 0 :=
+  by
+  classical
+  have heq : (componentChainWeight x).comp (FirstHurewicz.boundaryOne X) = 0 := by
+    apply FirstHurewicz.chainMap_ext X 1
+    intro σ
+    simp only [LinearMap.comp_apply, LinearMap.zero_apply, FirstHurewicz.boundaryOne_simplex,
+      map_sub, componentChainWeight, FirstHurewicz.chainLift_simplex, ContinuousMap.comp_apply,
+      FirstHurewicz.simplexFace_zero_zero, FirstHurewicz.simplexFace_zero_one]
+    have hp : Joined (σ (stdSimplex.vertex 0)) (σ (stdSimplex.vertex 1)) :=
+      ⟨FirstHurewicz.simplexPath σ⟩
+    have hi : Joined x (σ (stdSimplex.vertex 1)) ↔ Joined x (σ (stdSimplex.vertex 0)) :=
+      ⟨fun h => h.trans hp.symm, fun h => h.trans hp⟩
+    rw [hi, sub_self]
+  exact LinearMap.congr_fun heq b
+
+private theorem MorseCancel.pointClass_eq_iff_joined {X : Type} [TopologicalSpace X] (x y : X) :
+    PeriodTorusHigherHomology.pointClass x = PeriodTorusHigherHomology.pointClass y ↔
+      Joined x y := by
+  classical
+  constructor
+  · intro h
+    by_contra hn
+    obtain ⟨b, hb⟩ :=
+      (SingularMayerVietoris.ModuleHomology.cycleClass_eq_iff (FirstHurewicz.singularComplex X) 0
+            (PeriodTorusHigherHomology.pointCycle x) (PeriodTorusHigherHomology.pointCycle y)).mp
+        h
+    have he := congrArg (componentChainWeight x) hb
+    change
+      componentChainWeight x (FirstHurewicz.boundaryOne X b) =
+        componentChainWeight x (FirstHurewicz.pointChain x - FirstHurewicz.pointChain y) at he
+    rw [componentChainWeight_boundary, map_sub, componentChainWeight_point,
+      componentChainWeight_point, ite_eq_left (Joined.refl x), ite_eq_right hn] at he
+    norm_num at he
+  · rintro ⟨p⟩
+    apply
+      (SingularMayerVietoris.ModuleHomology.cycleClass_eq_iff (FirstHurewicz.singularComplex X) 0
+          (PeriodTorusHigherHomology.pointCycle x) (PeriodTorusHigherHomology.pointCycle y)).mpr
+    exact ⟨FirstHurewicz.pathChain p.symm, FirstHurewicz.boundaryOne_pathChain p.symm⟩
+
+private theorem MorseCancel.joined_iff_of_homologyZero_injective {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y))
+    (hf : Function.Injective (SingularMayerVietoris.singularHomologyMap f 0)) (x y : X) :
+    Joined (f x) (f y) ↔ Joined x y := by
+  rw [← pointClass_eq_iff_joined, ← pointClass_eq_iff_joined, ←
+    PeriodTorusHigherHomology.singularHomologyMap_pointClass f, ←
+    PeriodTorusHigherHomology.singularHomologyMap_pointClass f, hf.eq_iff]
+
+private theorem
+    MorseCancel.pathConnectedSpace_of_homologyZero_injective {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] [Nonempty X] [PathConnectedSpace Y] (f : C(X, Y))
+    (hf : Function.Injective (SingularMayerVietoris.singularHomologyMap f 0)) :
+    PathConnectedSpace X := by
+  exact
+    ⟨inferInstance, fun x y =>
+      (joined_iff_of_homologyZero_injective f hf x y).mp (PathConnectedSpace.joined (f x) (f y))⟩
+
+private theorem MorseCancel.pathConnectedSpace_of_homotopyEquiv {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] [PathConnectedSpace Y] (e : X ≃ₕ Y) : PathConnectedSpace X := by
+  let : Nonempty X := ⟨e.invFun (Classical.arbitrary Y)⟩
+  exact
+    pathConnectedSpace_of_homologyZero_injective e.toFun
+      (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv e 0).injective
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    Smale.ManifoldMorse.MorseSurgeryData.cellOldHomologyEquiv {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f) (k : ℕ) :
+    SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p - d.radius ^ 2 } k ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (d.coreCellPresentation hf).old k :=
+  PeriodTorusHigherHomology.homeomorphHomologyEquiv (d.cellOldHomeomorph hf) k
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.MorseSurgeryData.cellTotalHomologyEquiv {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (k : ℕ) :
+    SingularMayerVietoris.SingularHomology
+        (↥({y : M | f y ≤ f p - d.radius ^ 2} ∪ Set.range d.coreMap)) k ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p + d.radius ^ 2 } k :=
+  PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (d.coreUnionHomotopyEquiv hf) k
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.MorseSurgeryData.coreBoundaryHomologyMap {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (k : ℕ) :
+    SingularMayerVietoris.SingularHomology (Metric.sphere (0 : d.chart.NegativeCoordinates) 1)
+        k →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p - d.radius ^ 2 } k :=
+  SingularMayerVietoris.singularHomologyMap d.coreBoundaryMap k
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.MorseSurgeryData.lowerRealizationHomologyMap {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (k : ℕ) :
+    SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p - d.radius ^ 2 } k →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p + d.radius ^ 2 } k :=
+  SingularMayerVietoris.singularHomologyMap d.realizedLowerInclusion k
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    Smale.ManifoldMorse.MorseSurgeryData.morseConnectingMap {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f) (k : ℕ) :
+    SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p + d.radius ^ 2 } (k + 1) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (Metric.sphere (0 : d.chart.NegativeCoordinates) 1)
+        k :=
+  ((d.coreCellPresentation hf).cellConnectingMap k).comp
+    (d.cellTotalHomologyEquiv hf (k + 1)).symm.toLinearMap
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.cellAttachingHomology_compare {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (k : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology (Metric.sphere (0 : d.chart.NegativeCoordinates) 1)
+        k) :
+    (d.coreCellPresentation hf).attachingHomologyMap k a =
+      d.cellOldHomologyEquiv hf k (d.coreBoundaryHomologyMap k a) := by
+  change
+    SingularMayerVietoris.singularHomologyMap (d.coreCellPresentation hf).attachingSphere k a =
+      SingularMayerVietoris.singularHomologyMap (d.cellOldHomeomorph hf).toHomotopyEquiv.toFun k
+        (SingularMayerVietoris.singularHomologyMap d.coreBoundaryMap k a)
+  rw [d.coreCell_attaching_eq, PeriodTorusHigherHomology.singularHomologyMap_comp]
+  rfl
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.cellOldHomology_compare {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (k : ℕ) (a : SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p - d.radius ^ 2 } k) :
+    d.cellTotalHomologyEquiv hf k
+        ((d.coreCellPresentation hf).oldHomologyMap k (d.cellOldHomologyEquiv hf k a)) =
+      d.lowerRealizationHomologyMap k a := by
+  change
+    SingularMayerVietoris.singularHomologyMap (d.coreUnionHomotopyEquiv hf).toFun k
+        (SingularMayerVietoris.singularHomologyMap
+          (SingularMayerVietoris.subtypeInclusion (d.coreCellPresentation hf).old) k
+          (SingularMayerVietoris.singularHomologyMap
+            (d.cellOldHomeomorph hf).toHomotopyEquiv.toFun k a)) =
+      SingularMayerVietoris.singularHomologyMap d.realizedLowerInclusion k a
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp, ←
+    LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp]
+  rfl
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.morseConnecting_compare {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (k : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ↥({y : M | f y ≤ f p - d.radius ^ 2} ∪ Set.range d.coreMap) (k + 1)) :
+    d.morseConnectingMap hf k (d.cellTotalHomologyEquiv hf (k + 1) a) =
+      (d.coreCellPresentation hf).cellConnectingMap k a := by
+  change
+    (d.coreCellPresentation hf).cellConnectingMap k
+        ((d.cellTotalHomologyEquiv hf (k + 1)).symm (d.cellTotalHomologyEquiv hf (k + 1) a)) =
+      _
+  rw [LinearEquiv.symm_apply_apply]
+
+public
+theorem Smale.HomologyTransport.exact_of_equivalences {R A B C A' B' C' : Type*} [Ring R]
+    [AddCommGroup A] [Module R A] [AddCommGroup B] [Module R B] [AddCommGroup C] [Module R C]
+    [AddCommGroup A'] [Module R A'] [AddCommGroup B'] [Module R B'] [AddCommGroup C']
+    [Module R C'] (eA : A ≃ₗ[R] A') (eB : B ≃ₗ[R] B') (eC : C ≃ₗ[R] C') (f : A →ₗ[R] B)
+    (g : B →ₗ[R] C) (f' : A' →ₗ[R] B') (g' : B' →ₗ[R] C') (hf : ∀ a, f' (eA a) = eB (f a))
+    (hg : ∀ b, g' (eB b) = eC (g b)) (hexact : LinearMap.range f = LinearMap.ker g) :
+    LinearMap.range f' = LinearMap.ker g' := by
+  ext b'
+  constructor
+  · rintro ⟨a', rfl⟩
+    obtain ⟨a, rfl⟩ := eA.surjective a'
+    have hfa : g (f a) = 0 := by
+      have hmem : f a ∈ LinearMap.range f := ⟨a, rfl⟩
+      rw [hexact] at hmem
+      exact hmem
+    change g' (f' (eA a)) = 0
+    rw [hf, hg, hfa, map_zero]
+  · intro hb'
+    obtain ⟨b, rfl⟩ := eB.surjective b'
+    have hgb : g b = 0 := eC.injective ((hg b).symm.trans (hb'.trans (map_zero eC).symm))
+    have hb : b ∈ LinearMap.range f := by
+      rw [hexact]
+      exact hgb
+    obtain ⟨a, ha⟩ := hb
+    exact ⟨eA a, (hf a).trans (congrArg eB ha)⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.morse_exact_at_lower {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (k : ℕ) (hk : k ≠ 0) :
+    LinearMap.range (d.coreBoundaryHomologyMap k) =
+      LinearMap.ker (d.lowerRealizationHomologyMap k) := by
+  refine
+    Smale.HomologyTransport.exact_of_equivalences (LinearEquiv.refl ℤ _)
+      (d.cellOldHomologyEquiv hf k).symm (d.cellTotalHomologyEquiv hf k)
+      ((d.coreCellPresentation hf).attachingHomologyMap k)
+      ((d.coreCellPresentation hf).oldHomologyMap k) (d.coreBoundaryHomologyMap k)
+      (d.lowerRealizationHomologyMap k) ?_ ?_ ((d.coreCellPresentation hf).cell_exact_at_old k hk)
+  · intro a
+    change
+      d.coreBoundaryHomologyMap k a =
+        (d.cellOldHomologyEquiv hf k).symm ((d.coreCellPresentation hf).attachingHomologyMap k a)
+    rw [d.cellAttachingHomology_compare, LinearEquiv.symm_apply_apply]
+  · intro a
+    have h := d.cellOldHomology_compare hf k ((d.cellOldHomologyEquiv hf k).symm a)
+    rw [LinearEquiv.apply_symm_apply] at h
+    exact h.symm
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.morse_exact_at_upper {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (k : ℕ) :
+    LinearMap.range (d.lowerRealizationHomologyMap (k + 1)) =
+      LinearMap.ker (d.morseConnectingMap hf k) := by
+  refine
+    Smale.HomologyTransport.exact_of_equivalences (d.cellOldHomologyEquiv hf (k + 1)).symm
+      (d.cellTotalHomologyEquiv hf (k + 1)) (LinearEquiv.refl ℤ _)
+      ((d.coreCellPresentation hf).oldHomologyMap (k + 1))
+      ((d.coreCellPresentation hf).cellConnectingMap k) (d.lowerRealizationHomologyMap (k + 1))
+      (d.morseConnectingMap hf k) ?_ ?_ ((d.coreCellPresentation hf).cell_exact_at_ambient k)
+  · intro a
+    have h := d.cellOldHomology_compare hf (k + 1) ((d.cellOldHomologyEquiv hf (k + 1)).symm a)
+    rw [LinearEquiv.apply_symm_apply] at h
+    exact h.symm
+  · exact d.morseConnecting_compare hf k
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.morse_exact_at_attachingSphere {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (k : ℕ) (hk : k ≠ 0) :
+    LinearMap.range (d.morseConnectingMap hf k) = LinearMap.ker (d.coreBoundaryHomologyMap k) := by
+  refine
+    Smale.HomologyTransport.exact_of_equivalences (d.cellTotalHomologyEquiv hf (k + 1))
+      (LinearEquiv.refl ℤ _) (d.cellOldHomologyEquiv hf k).symm
+      ((d.coreCellPresentation hf).cellConnectingMap k)
+      ((d.coreCellPresentation hf).attachingHomologyMap k) (d.morseConnectingMap hf k)
+      (d.coreBoundaryHomologyMap k) ?_ ?_ ((d.coreCellPresentation hf).cell_exact_at_sphere k hk)
+  · exact d.morseConnecting_compare hf k
+  · intro a
+    change
+      d.coreBoundaryHomologyMap k a =
+        (d.cellOldHomologyEquiv hf k).symm ((d.coreCellPresentation hf).attachingHomologyMap k a)
+    rw [d.cellAttachingHomology_compare, LinearEquiv.symm_apply_apply]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.lowerHomology_subsingleton_of_upper_and_sphere
+    {E M : Type} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [T2Space M] {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (hf : Continuous f) (k : ℕ) (hk : k ≠ 0)
+    [Subsingleton
+        (SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p + d.radius ^ 2 } k)]
+    [Subsingleton
+        (SingularMayerVietoris.SingularHomology
+          (Metric.sphere (0 : d.chart.NegativeCoordinates) 1) k)] :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p - d.radius ^ 2 } k) := by
+  have hall :
+    ∀ a : SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p - d.radius ^ 2 } k, a = 0 :=
+    by
+    intro a
+    have ha : a ∈ LinearMap.ker (d.lowerRealizationHomologyMap k) := Subsingleton.elim _ _
+    rw [← d.morse_exact_at_lower hf k hk] at ha
+    obtain ⟨s, hs⟩ := ha
+    have hs0 : s = 0 := Subsingleton.elim _ _
+    rw [hs0, map_zero] at hs
+    exact hs.symm
+  exact ⟨fun a b => (hall a).trans (hall b).symm⟩
+
+private theorem Smale.ManifoldMorse.MorseSurgeryData.attachingSphere_pathConnected {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (hindex : 2 ≤ Module.finrank ℝ d.chart.NegativeCoordinates) :
+    PathConnectedSpace (Metric.sphere (0 : d.chart.NegativeCoordinates) 1) :=
+  isPathConnected_iff_pathConnectedSpace.mp
+    (isPathConnected_sphere (Module.one_lt_rank_of_one_lt_finrank (by omega)) _ zero_le_one)
+
+private theorem Smale.ManifoldMorse.MorseSurgeryData.morseConnecting_zero_apply {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (hindex : 2 ≤ Module.finrank ℝ d.chart.NegativeCoordinates)
+    (a : SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p + d.radius ^ 2 } 1) :
+    d.morseConnectingMap hf 0 a = 0 := by
+  let := d.attachingSphere_pathConnected hindex
+  exact (d.coreCellPresentation hf).cellConnecting_zero_apply _
+
+private theorem Smale.ManifoldMorse.MorseSurgeryData.lowerRealization_one_surjective {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (hindex : 2 ≤ Module.finrank ℝ d.chart.NegativeCoordinates) :
+    Function.Surjective (d.lowerRealizationHomologyMap 1) := by
+  intro a
+  have ha : a ∈ LinearMap.ker (d.morseConnectingMap hf 0) :=
+    d.morseConnecting_zero_apply hf hindex a
+  rw [← d.morse_exact_at_upper hf 0] at ha
+  exact ha
+
+private theorem Smale.ManifoldMorse.MorseSurgeryData.upperHomologyOne_subsingleton {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (hindex : 2 ≤ Module.finrank ℝ d.chart.NegativeCoordinates)
+    [Subsingleton
+        (SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p - d.radius ^ 2 } 1)] :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p + d.radius ^ 2 } 1) :=
+  (d.lowerRealization_one_surjective hf hindex).subsingleton
+
+private theorem
+    MorseCancel.native_lowerRealization_zero_bijective {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (hindex : 2 ≤ Module.finrank ℝ d.chart.NegativeCoordinates) :
+    Function.Bijective (d.lowerRealizationHomologyMap 0) := by
+  let := d.attachingSphere_pathConnected hindex
+  have hi := cell_oldHomologyMap_zero_bijective (d.coreCellPresentation hf)
+  have heq :
+    d.lowerRealizationHomologyMap 0 =
+      (d.cellTotalHomologyEquiv hf 0).toLinearMap.comp
+        (((d.coreCellPresentation hf).oldHomologyMap 0).comp
+          (d.cellOldHomologyEquiv hf 0).toLinearMap) := by
+    ext a
+    exact (d.cellOldHomology_compare hf 0 a).symm
+  rw [heq]
+  exact
+    (d.cellTotalHomologyEquiv hf 0).bijective.comp
+      (hi.comp (d.cellOldHomologyEquiv hf 0).bijective)
+
+private theorem MorseCancel.native_lower_pathConnected_of_upper {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (hindex : 2 ≤ Module.finrank ℝ d.chart.NegativeCoordinates)
+    [PathConnectedSpace { z : M // f z ≤ f p + d.radius ^ 2 }] :
+    PathConnectedSpace { z : M // f z ≤ f p - d.radius ^ 2 } := by
+  let := d.attachingSphere_pathConnected hindex
+  let : Nonempty { z : M // f z ≤ f p - d.radius ^ 2 } :=
+    ⟨d.coreBoundaryMap (Classical.arbitrary (Metric.sphere (0 : d.chart.NegativeCoordinates) 1))⟩
+  exact
+    pathConnectedSpace_of_homologyZero_injective d.realizedLowerInclusion
+      (native_lowerRealization_zero_bijective d hf hindex).1
+
+private def Smale.ManifoldMorse.SurgeryWindows.values {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) : Finset ℝ :=
+  (S.finite.image f).toFinset
+
+private def Smale.ManifoldMorse.SurgeryWindows.count {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) : ℕ :=
+  S.values.card
+
+private def Smale.ManifoldMorse.SurgeryWindows.point {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) :
+    Fin S.count ≃ Smale.ManifoldMorse.criticalPoints E f :=
+  ((S.values.orderIsoOfFin rfl).toEquiv.trans
+        (Equiv.setCongr (S.finite.image f).coe_toFinset)).trans
+    (Equiv.Set.imageOfInjOn f (Smale.ManifoldMorse.criticalPoints E f) S.distinct).symm
+
+private theorem Smale.ManifoldMorse.SurgeryWindows.point_value {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (i : Fin S.count) :
+    f (S.point i) = S.values.orderEmbOfFin rfl i := by
+  let e := Equiv.Set.imageOfInjOn f (Smale.ManifoldMorse.criticalPoints E f) S.distinct
+  let v : f '' Smale.ManifoldMorse.criticalPoints E f :=
+    Equiv.setCongr (S.finite.image f).coe_toFinset (S.values.orderIsoOfFin rfl i)
+  have h :=
+    congrArg (fun x : f '' Smale.ManifoldMorse.criticalPoints E f => (x : ℝ))
+      (e.apply_symm_apply v)
+  exact h
+
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.point_strictMono {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) :
+    StrictMono (fun i : Fin S.count => f (S.point i)) := by
+  intro i j hij
+  change f (S.point i) < f (S.point j)
+  rw [S.point_value, S.point_value]
+  exact (S.values.orderEmbOfFin rfl).strictMono hij
+
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.point_consecutive {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (i j : Fin S.count) (hij : i.val + 1 = j.val) :
+    ∀ r : Smale.ManifoldMorse.criticalPoints E f, ¬(f (S.point i) < f r ∧ f r < f (S.point j)) := by
+  intro r hr
+  obtain ⟨k, rfl⟩ := S.point.surjective r
+  have hik : i < k := S.point_strictMono.lt_iff_lt.mp hr.1
+  have hkj : k < j := S.point_strictMono.lt_iff_lt.mp hr.2
+  have hik' : i.val < k.val := hik
+  have hkj' : k.val < j.val := hkj
+  omega
+
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.ordered_windows {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (i j : Fin S.count) (hij : i < j) :
+    S.upper (S.point i) < S.lower (S.point j) :=
+  S.upper_lt_lower _ _ (S.point_strictMono hij)
+
+private theorem Smale.ManifoldMorse.SurgeryWindows.consecutive_regular {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (i j : Fin S.count) (hij : i.val + 1 = j.val) :
+    ∀ x,
+      f x ∈ Set.Icc (S.upper (S.point i)) (S.lower (S.point j)) →
+        x ∉ Smale.ManifoldMorse.criticalPoints E f :=
+  S.regular_between _ _ (S.point_consecutive i j hij)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SurgeryWindows.exists_consecutiveBandBridge {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) [FiniteDimensional ℝ E] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [T2Space M] [CompactSpace M] (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (i j : Fin S.count)
+    (hij : i.val + 1 = j.val) :
+    letI := Smale.RegularLevel.chartedSpace hf (S.data (S.point i)).upper_regular
+    letI := Smale.RegularLevel.chartedSpace hf (S.data (S.point j)).lower_regular
+    ∃ D : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞,
+      ∃ b :
+        Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+          (S.data (S.point i)).UpperLevel (S.data (S.point j)).LowerLevel ∞,
+        D '' {x : M | f x ≤ S.upper (S.point i)} = {x : M | f x ≤ S.lower (S.point j)} ∧
+          ∀ x : (S.data (S.point i)).UpperLevel, (b x : M) = D x := by
+  have hlt : i < j := by change i.val < j.val; omega
+  exact S.exists_bandBridge hf _ _ (S.point_strictMono hlt) (S.point_consecutive i j hij)
+
+private theorem
+    Smale.ManifoldMorse.mem_criticalPoints_of_localMin {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    {p : M} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hmin : IsLocalMin f p) :
+    p ∈ criticalPoints E f := by
+  let e := chartAt E p
+  have he : e ∈ IsManifold.maximalAtlas 𝓘(ℝ, E) ∞ M := IsManifold.chart_mem_maximalAtlas p
+  have hp : p ∈ e.source := mem_chart_source E p
+  apply (mem_criticalPoints_iff hf he hp).mpr
+  have hmin' : IsLocalMin f (e.symm (e p)) := by rw [e.left_inv hp]; exact hmin
+  exact (hmin'.comp_continuous (e.continuousAt_symm (e.map_source hp))).fderiv_eq_zero
+
+private theorem
+    Smale.ManifoldMorse.mem_criticalPoints_of_localMax {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    {p : M} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hmax : IsLocalMax f p) :
+    p ∈ criticalPoints E f := by
+  let e := chartAt E p
+  have he : e ∈ IsManifold.maximalAtlas 𝓘(ℝ, E) ∞ M := IsManifold.chart_mem_maximalAtlas p
+  have hp : p ∈ e.source := mem_chart_source E p
+  apply (mem_criticalPoints_iff hf he hp).mpr
+  have hmax' : IsLocalMax f (e.symm (e p)) := by rw [e.left_inv hp]; exact hmax
+  exact (hmax'.comp_continuous (e.continuousAt_symm (e.map_source hp))).fderiv_eq_zero
+
+private theorem Smale.ManifoldMorse.unique_extrema_of_two_critical_values {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} [CompactSpace M] (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    {p q : M} (hpq : f p < f q) (hcrit : ∀ x ∈ criticalPoints E f, x = p ∨ x = q) :
+    (∀ x, f x ≤ f p → x = p) ∧ (∀ x, f q ≤ f x → x = q) := by
+  obtain ⟨u, _, hmin⟩ :=
+    isCompact_univ.exists_isMinOn ⟨p, Set.mem_univ p⟩ hf.continuous.continuousOn
+  obtain ⟨v, _, hmax⟩ :=
+    isCompact_univ.exists_isMaxOn ⟨q, Set.mem_univ q⟩ hf.continuous.continuousOn
+  have humin : IsLocalMin f u := Filter.Eventually.of_forall (fun x => hmin (Set.mem_univ x))
+  have hvmax : IsLocalMax f v := Filter.Eventually.of_forall (fun x => hmax (Set.mem_univ x))
+  have hup : u = p := by
+    rcases hcrit u (mem_criticalPoints_of_localMin hf humin) with h | h
+    · exact h
+    · have hle : f u ≤ f p := hmin (Set.mem_univ p)
+      rw [h] at hle
+      exact False.elim (not_le_of_gt hpq hle)
+  have hvq : v = q := by
+    rcases hcrit v (mem_criticalPoints_of_localMax hf hvmax) with h | h
+    · have hle : f q ≤ f v := hmax (Set.mem_univ q)
+      rw [h] at hle
+      exact False.elim (not_le_of_gt hpq hle)
+    · exact h
+  have hglobalMin (x : M) : f p ≤ f x := by rw [← hup]; exact hmin (Set.mem_univ x)
+  have hglobalMax (x : M) : f x ≤ f q := by rw [← hvq]; exact hmax (Set.mem_univ x)
+  constructor
+  · intro x hx
+    have hlocal : IsLocalMin f x := Filter.Eventually.of_forall (fun y => hx.trans (hglobalMin y))
+    rcases hcrit x (mem_criticalPoints_of_localMin hf hlocal) with h | h
+    · exact h
+    · rw [h] at hx
+      exact False.elim (not_le_of_gt hpq hx)
+  · intro x hx
+    have hlocal : IsLocalMax f x := Filter.Eventually.of_forall (fun y => (hglobalMax y).trans hx)
+    rcases hcrit x (mem_criticalPoints_of_localMax hf hlocal) with h | h
+    · rw [h] at hx
+      exact False.elim (not_le_of_gt hpq hx)
+    · exact h
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.negative_eq_zero_of_localMin {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hmin : IsLocalMin f p)
+    (u : c.NegativeCoordinates) : u = 0 := by
+  by_contra hu
+  have hnorm : 0 < ‖u‖ := norm_pos_iff.mpr hu
+  obtain ⟨U, hUmin, hU, hpU⟩ := _root_.mem_nhds_iff.mp hmin
+  obtain ⟨r, hr, hblock⟩ := c.exists_closed_productBlock_in hU hpU
+  let z : c.NegativeCoordinates := (r / ‖u‖) • u
+  have hz : ‖z‖ = r := by
+    rw [show z = (r / ‖u‖) • u from rfl, norm_smul, Real.norm_eq_abs,
+      abs_of_pos (div_pos hr hnorm), div_mul_cancel₀ _ hnorm.ne']
+  have hpoint :=
+    hblock
+      (show (z, (0 : c.PositiveCoordinates)) ∈ Metric.closedBall 0 r ×ˢ Metric.closedBall 0 r from
+        ⟨mem_closedBall_zero_iff.mpr hz.le, by
+          simpa only [mem_closedBall_zero_iff, norm_zero] using hr.le⟩)
+  have hh := hUmin hpoint.2
+  change f p ≤ f (c.splitChart.symm (z, (0 : c.PositiveCoordinates))) at hh
+  rw [c.splitChart_inverse_equation hpoint.1, hz, norm_zero] at hh
+  nlinarith [sq_pos_of_pos hr]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.subsingleton_negative_of_localMin {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hmin : IsLocalMin f p) :
+    Subsingleton c.NegativeCoordinates :=
+  ⟨fun u v =>
+    (c.negative_eq_zero_of_localMin hmin u).trans (c.negative_eq_zero_of_localMin hmin v).symm⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.positive_eq_zero_of_localMax {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hmax : IsLocalMax f p)
+    (v : c.PositiveCoordinates) : v = 0 := by
+  by_contra hv
+  have hnorm : 0 < ‖v‖ := norm_pos_iff.mpr hv
+  obtain ⟨U, hUmax, hU, hpU⟩ := _root_.mem_nhds_iff.mp hmax
+  obtain ⟨r, hr, hblock⟩ := c.exists_closed_productBlock_in hU hpU
+  let z : c.PositiveCoordinates := (r / ‖v‖) • v
+  have hz : ‖z‖ = r := by
+    rw [show z = (r / ‖v‖) • v from rfl, norm_smul, Real.norm_eq_abs,
+      abs_of_pos (div_pos hr hnorm), div_mul_cancel₀ _ hnorm.ne']
+  have hpoint :=
+    hblock
+      (show ((0 : c.NegativeCoordinates), z) ∈ Metric.closedBall 0 r ×ˢ Metric.closedBall 0 r from
+        ⟨by simpa only [mem_closedBall_zero_iff, norm_zero] using hr.le,
+          mem_closedBall_zero_iff.mpr hz.le⟩)
+  have hh := hUmax hpoint.2
+  change f (c.splitChart.symm ((0 : c.NegativeCoordinates), z)) ≤ f p at hh
+  rw [c.splitChart_inverse_equation hpoint.1, norm_zero, hz] at hh
+  nlinarith [sq_pos_of_pos hr]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.subsingleton_positive_of_localMax {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hmax : IsLocalMax f p) :
+    Subsingleton c.PositiveCoordinates :=
+  ⟨fun u v =>
+    (c.positive_eq_zero_of_localMax hmax u).trans (c.positive_eq_zero_of_localMax hmax v).symm⟩
+
+private theorem Smale.exists_small_sublevel_subset {X : Type*} [TopologicalSpace X] [CompactSpace X]
+    {f : X → ℝ} (hf : Continuous f) {p : X} (hunique : ∀ x, f x ≤ f p → x = p) {U : Set X}
+    (hU : IsOpen U) (hpU : p ∈ U) : ∃ ε > (0 : ℝ), {x | f x ≤ f p + ε} ⊆ U := by
+  by_cases hne : Uᶜ.Nonempty
+  · obtain ⟨q, hq, hmin⟩ := hU.isClosed_compl.isCompact.exists_isMinOn hne hf.continuousOn
+    have hgap : f p < f q := by
+      by_contra! h
+      exact hq (hunique q h ▸ hpU)
+    refine ⟨(f q - f p) / 2, half_pos (sub_pos.mpr hgap), ?_⟩
+    intro x hx
+    by_contra hxU
+    have hqx : f q ≤ f x := hmin hxU
+    change f x ≤ f p + (f q - f p) / 2 at hx
+    linarith
+  · refine ⟨1, zero_lt_one, ?_⟩
+    intro x _
+    by_contra hx
+    exact hne ⟨x, hx⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.exists_minimum_disk_sublevel_with_height
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [T2Space M] [CompactSpace M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hf : Continuous f)
+    (hunique : ∀ x, f x ≤ f p → x = p) {b : ℝ} (hb : f p < b) :
+    ∃ ρ > (0 : ℝ),
+      f p + ρ ^ 2 < b ∧
+        ∃ e : Smale.MorseHandle.UnitDisk c.PositiveCoordinates ≃ₜ { x : M // f x ≤ f p + ρ ^ 2 },
+          ∀ v, f (e v).1 = f p + ρ ^ 2 * ‖(v : c.PositiveCoordinates)‖ ^ 2 := by
+  have hglobal : ∀ x, f p ≤ f x := by
+    intro x
+    by_contra! h
+    have hxp := hunique x h.le
+    rw [hxp] at h
+    exact lt_irrefl _ h
+  have hmin : IsLocalMin f p := Filter.Eventually.of_forall hglobal
+  let : Subsingleton c.NegativeCoordinates := c.subsingleton_negative_of_localMin hmin
+  obtain ⟨R, hR, hblockR⟩ := c.exists_closed_productBlock
+  obtain ⟨ε, hε, hsublevel⟩ :=
+    Smale.exists_small_sublevel_subset hf hunique c.splitChart.open_source c.splitChart_mem_source
+  let δ := Min.min ε (b - f p)
+  have hδ : 0 < δ := lt_min hε (sub_pos.mpr hb)
+  let ρ := Min.min (R / 2) (Min.min 1 (δ / 2))
+  have hρ : 0 < ρ := lt_min (half_pos hR) (lt_min zero_lt_one (half_pos hδ))
+  have hρR : ρ ≤ R / 2 := min_le_left _ _
+  have hρone : ρ ≤ 1 := (min_le_right _ _).trans (min_le_left _ _)
+  have hρδ : ρ ≤ δ / 2 := (min_le_right _ _).trans (min_le_right _ _)
+  have hρsq : ρ ^ 2 < δ := by nlinarith
+  have hsqε : ρ ^ 2 < ε := hρsq.trans_le (min_le_left _ _)
+  have hsqb : ρ ^ 2 < b - f p := hρsq.trans_le (min_le_right _ _)
+  have hblock :
+    Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+        Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+      c.splitChart.target := by
+    intro z hz
+    have hr : 2 * ρ ≤ R := by linarith
+    exact
+      hblockR
+        ⟨Metric.closedBall_subset_closedBall hr hz.1, Metric.closedBall_subset_closedBall hr hz.2⟩
+  let z₀ : Smale.MorseHandle.UnitDisk c.NegativeCoordinates := ⟨0, by simp⟩
+  let h : C(Smale.MorseHandle.UnitDisk c.PositiveCoordinates, { x : M // f x ≤ f p + ρ ^ 2 }) :=
+    { toFun := fun v =>
+        ⟨c.attachingHandleMap ρ hρ hblock (z₀, v), c.attachingHandleMap_upper ρ hρ hblock (z₀, v)⟩
+      continuous_toFun :=
+        ((c.attachingHandleMap ρ hρ hblock).continuous.comp
+              (continuous_const.prodMk continuous_id)).subtype_mk
+          _ }
+  have hinj : Function.Injective h := by
+    intro v w hvw
+    have heq := c.attachingHandleMap_injective ρ hρ hblock (congrArg Subtype.val hvw)
+    exact congrArg Prod.snd heq
+  have hsurj : Function.Surjective h := by
+    intro y
+    have hyS : y.1 ∈ c.splitChart.source :=
+      hsublevel
+        (show f y.1 ≤ f p + ε from by
+          have hy := y.2
+          linarith)
+    have heq := c.splitChart_equation hyS
+    have hnegative : (c.splitChart y.1).1 = 0 := Subsingleton.elim _ _
+    rw [hnegative, norm_zero] at heq
+    have hypos : ‖(c.splitChart y.1).2‖ ≤ ρ := by
+      have hy := y.2
+      nlinarith [norm_nonneg (c.splitChart y.1).2]
+    have hylower : f p - ρ ^ 2 ≤ f y.1 := by
+      have hy := hglobal y.1
+      linarith [sq_nonneg ρ]
+    obtain ⟨⟨u, v⟩, huv⟩ :=
+      (c.mem_range_attachingHandleMap_iff_inequalities ρ hρ hblock hyS).mpr ⟨hypos, hylower⟩
+    have hu : u = z₀ := Subsingleton.elim _ _
+    subst u
+    exact ⟨v, Subtype.ext huv⟩
+  refine ⟨ρ, hρ, by linarith, ?_⟩
+  refine
+    ⟨Continuous.homeoOfEquivCompactToT2 (f := Equiv.ofBijective h ⟨hinj, hsurj⟩) h.continuous, ?_⟩
+  intro v
+  change f (c.attachingHandleMap ρ hρ hblock (z₀, v)) = _
+  rw [c.attachingHandleMap_quadratic]
+  change
+    f p +
+        (-‖(ρ * Real.sqrt (1 + ‖(v : c.PositiveCoordinates)‖ ^ 2)) •
+                  (0 : c.NegativeCoordinates)‖ ^
+              2 +
+          ‖ρ • (v : c.PositiveCoordinates)‖ ^ 2) =
+      _
+  simp only [smul_zero, norm_zero, zero_pow (by norm_num : (2 : ℕ) ≠ 0), neg_zero, zero_add,
+    norm_smul, Real.norm_eq_abs, abs_of_pos hρ, mul_pow]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.finrank_positive_of_localMin {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hmin : IsLocalMin f p) :
+    Module.finrank ℝ c.PositiveCoordinates = Module.finrank ℝ E := by
+  let : Unique c.NegativeCoordinates :=
+    { default := 0, uniq := c.negative_eq_zero_of_localMin hmin }
+  let e : (Fin (Module.finrank ℝ E) → ℝ) ≃ₗ[ℝ] c.PositiveCoordinates :=
+    (Smale.MorseHandle.splitLinearEquiv c.weights).trans
+      (LinearEquiv.uniqueProd (R := ℝ) (M := c.PositiveCoordinates) (M₂ := c.NegativeCoordinates))
+  simpa using e.finrank_eq.symm
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.SignedMorseChart.minimumPositiveIsometry {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hmin : IsLocalMin f p) :
+    c.PositiveCoordinates ≃ₗᵢ[ℝ] Smale.Hemisphere.Ambient (Module.finrank ℝ E) :=
+  (stdOrthonormalBasis ℝ c.PositiveCoordinates).repr.trans
+    (LinearIsometryEquiv.piLpCongrLeft 2 ℝ ℝ (finCongr (c.finrank_positive_of_localMin hmin)))
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.SignedMorseChart.minimumDiskHomeomorph {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hmin : IsLocalMin f p) :
+    Smale.MorseHandle.UnitDisk c.PositiveCoordinates ≃ₜ
+      Smale.Hemisphere.Ball (Module.finrank ℝ E) :=
+  (c.minimumPositiveIsometry hmin).toHomeomorph.subtype (p := fun x => x ∈ Metric.closedBall 0 1)
+    (q := fun x => x ∈ Metric.closedBall 0 1)
+    (fun x => by
+      simp only [mem_closedBall_zero_iff, LinearIsometryEquiv.coe_toHomeomorph,
+        LinearIsometryEquiv.norm_map])
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.norm_minimumDiskHomeomorph_symm {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hmin : IsLocalMin f p)
+    (v : Smale.Hemisphere.Ball (Module.finrank ℝ E)) :
+    ‖((c.minimumDiskHomeomorph hmin).symm v : c.PositiveCoordinates)‖ =
+      ‖(v : Smale.Hemisphere.Ambient (Module.finrank ℝ E))‖ := by
+  change
+    ‖(c.minimumPositiveIsometry hmin).symm (v : Smale.Hemisphere.Ambient (Module.finrank ℝ E))‖ =
+      _
+  exact (c.minimumPositiveIsometry hmin).symm.norm_map _
+
+private def Smale.Hemisphere.tail {n : ℕ} (y : Sphere n) : Ambient n :=
+  WithLp.toLp 2 (fun i => (y : Ambient (n + 1)) i.succ)
+
+private theorem Smale.Hemisphere.head_sq_add_tail_norm_sq {n : ℕ} (y : Sphere n) :
+    (y : Ambient (n + 1)) 0 ^ 2 + ‖tail y‖ ^ 2 = 1 := by
+  have hy : ‖(y : Ambient (n + 1))‖ ^ 2 = 1 := by
+    rw [mem_sphere_zero_iff_norm.mp y.property]
+    exact one_pow 2
+  rw [EuclideanSpace.real_norm_sq_eq, Fin.sum_univ_succ] at hy
+  rw [EuclideanSpace.real_norm_sq_eq]
+  exact hy
+
+private theorem Smale.Hemisphere.tail_mem_ball {n : ℕ} (y : Sphere n) :
+    tail y ∈ Metric.closedBall (0 : Ambient n) 1 := by
+  rw [mem_closedBall_zero_iff]
+  have hy := head_sq_add_tail_norm_sq y
+  nlinarith [sq_nonneg ((y : Ambient (n + 1)) 0), norm_nonneg (tail y)]
+
+private def Smale.Hemisphere.disk {n : ℕ} (y : Sphere n) : Ball n :=
+  ⟨tail y, tail_mem_ball y⟩
+
+private theorem Smale.Hemisphere.radius_disk {n : ℕ} (y : Sphere n) :
+    radius (disk y) = |(y : Ambient (n + 1)) 0| := by
+  have hy := head_sq_add_tail_norm_sq y
+  have hs : 1 - ‖tail y‖ ^ 2 = (y : Ambient (n + 1)) 0 ^ 2 := by linarith
+  change Real.sqrt (1 - ‖tail y‖ ^ 2) = _
+  rw [hs, Real.sqrt_sq_eq_abs]
+
+private theorem Smale.Hemisphere.point_disk_of_nonneg {n : ℕ} (y : Sphere n)
+    (hy : 0 ≤ (y : Ambient (n + 1)) 0) : point Bool.true (disk y) = y := by
+  apply Subtype.ext
+  ext i
+  refine Fin.cases ?_ (fun j => ?_) i
+  · simp [radius_disk, abs_of_nonneg hy]
+  · rfl
+
+private theorem Smale.Hemisphere.point_disk_of_nonpos {n : ℕ} (y : Sphere n)
+    (hy : (y : Ambient (n + 1)) 0 ≤ 0) : point Bool.false (disk y) = y := by
+  apply Subtype.ext
+  ext i
+  refine Fin.cases ?_ (fun j => ?_) i
+  · simp [radius_disk, abs_of_nonpos hy]
+  · rfl
+
+private theorem
+    Smale.Hemisphere.point_jointly_surjective {n : ℕ} (y : Sphere n) : ∃ b x, point b x = y :=
+  by
+  rcases le_total 0 ((y : Ambient (n + 1)) 0) with hy | hy
+  · exact ⟨Bool.true, disk y, point_disk_of_nonneg y hy⟩
+  · exact ⟨Bool.false, disk y, point_disk_of_nonpos y hy⟩
+
+private def Smale.DiskDouble.hemisphereMap (n : ℕ) :
+    Smale.Hemisphere.Ball n ⊕ Smale.Hemisphere.Ball n → Smale.Hemisphere.Sphere n :=
+  Sum.elim (Smale.Hemisphere.point Bool.false) (Smale.Hemisphere.point Bool.true)
+
+private theorem Smale.DiskDouble.continuous_hemisphereMap (n : ℕ) : Continuous (hemisphereMap n) :=
+  continuous_sum_dom.mpr
+    ⟨Smale.Hemisphere.continuous_point Bool.false, Smale.Hemisphere.continuous_point Bool.true⟩
+
+private theorem Smale.DiskDouble.hemisphereMap_respects (n : ℕ)
+    (x y : Smale.Hemisphere.Ball n ⊕ Smale.Hemisphere.Ball n)
+    (h : Smale.DiskDouble.Rel (Homeomorph.refl (Boundary (Smale.Hemisphere.Ambient n))) x y) :
+    hemisphereMap n x = hemisphereMap n y := by
+  cases x with
+  | inl x =>
+    cases y with
+    | inl y => exact h.elim
+    | inr y =>
+      obtain ⟨z, rfl, rfl⟩ := h
+      exact Smale.Hemisphere.point_boundary z
+  | inr x => cases y <;> exact h.elim
+
+private def Smale.DiskDouble.sphereMap (n : ℕ) :
+    Space (Homeomorph.refl (Boundary (Smale.Hemisphere.Ambient n))) → Smale.Hemisphere.Sphere n :=
+  Quot.lift (hemisphereMap n) (hemisphereMap_respects n)
+
+private theorem Smale.DiskDouble.continuous_sphereMap (n : ℕ) : Continuous (sphereMap n) :=
+  continuous_quot_lift (hemisphereMap_respects n) (continuous_hemisphereMap n)
+
+private theorem
+    Smale.DiskDouble.sphereMap_injective (n : ℕ) : Function.Injective (sphereMap n) := by
+  intro a b
+  induction a using Quot.inductionOn with
+  | _ x =>
+    induction b using Quot.inductionOn with
+    | _ y =>
+      intro h
+      cases x with
+      | inl x =>
+        cases y with
+        | inl y =>
+          have hxy := Smale.Hemisphere.point_injective Bool.false h
+          subst y
+          rfl
+        | inr y => exact Quot.sound ((Smale.Hemisphere.point_false_eq_true_iff x y).mp h)
+      | inr x =>
+        cases y with
+        | inl y =>
+          exact (Quot.sound ((Smale.Hemisphere.point_false_eq_true_iff y x).mp h.symm)).symm
+        | inr y =>
+          have hxy := Smale.Hemisphere.point_injective Bool.true h
+          subst y
+          rfl
+
+private theorem
+    Smale.DiskDouble.sphereMap_surjective (n : ℕ) : Function.Surjective (sphereMap n) := by
+  intro y
+  obtain ⟨b, x, hx⟩ := Smale.Hemisphere.point_jointly_surjective y
+  cases b
+  · exact ⟨Quot.mk _ (.inl x), hx⟩
+  · exact ⟨Quot.mk _ (.inr x), hx⟩
+
+private def Smale.DiskDouble.homeomorphSphere (n : ℕ) :
+    Space (Homeomorph.refl (Boundary (Smale.Hemisphere.Ambient n))) ≃ₜ
+      Smale.Hemisphere.Sphere n :=
+  Continuous.homeoOfEquivCompactToT2 (f :=
+    Equiv.ofBijective (sphereMap n) ⟨sphereMap_injective n, sphereMap_surjective n⟩)
+    (continuous_sphereMap n)
+
+private def Smale.DiskDouble.twistedHomeomorphSphere (n : ℕ)
+    (e : Boundary (Smale.Hemisphere.Ambient n) ≃ₜ Boundary (Smale.Hemisphere.Ambient n)) :
+    Space e ≃ₜ Smale.Hemisphere.Sphere n :=
+  (homeomorphUntwisted e).trans (homeomorphSphere n)
+
+private structure Smale.TwoDiskDecomposition (n : ℕ) (M : Type*) [TopologicalSpace M] where
+  boundaryEquiv :
+    DiskDouble.Boundary (Hemisphere.Ambient n) ≃ₜ DiskDouble.Boundary (Hemisphere.Ambient n)
+  left : C(Hemisphere.Ball n, M)
+  right : C(Hemisphere.Ball n, M)
+  left_injective : Function.Injective left
+  right_injective : Function.Injective right
+  covers : ∀ p : M, (∃ x, left x = p) ∨ ∃ y, right y = p
+  overlap :
+    ∀ x y,
+      left x = right y ↔
+        ∃ z : DiskDouble.Boundary (Hemisphere.Ambient n),
+          x = DiskDouble.boundary (Hemisphere.Ambient n) z ∧
+            y = DiskDouble.boundary (Hemisphere.Ambient n) (boundaryEquiv z)
+
+private def Smale.TwoDiskDecomposition.sumMap {n : ℕ} {M : Type*} [TopologicalSpace M]
+    (d : Smale.TwoDiskDecomposition n M) :
+    Smale.Hemisphere.Ball n ⊕ Smale.Hemisphere.Ball n → M :=
+  Sum.elim d.left d.right
+
+private theorem
+    Smale.TwoDiskDecomposition.continuous_sumMap {n : ℕ} {M : Type*} [TopologicalSpace M]
+    (d : Smale.TwoDiskDecomposition n M) : Continuous d.sumMap :=
+  continuous_sum_dom.mpr ⟨d.left.continuous, d.right.continuous⟩
+
+private theorem Smale.TwoDiskDecomposition.sumMap_respects {n : ℕ} {M : Type*} [TopologicalSpace M]
+    (d : Smale.TwoDiskDecomposition n M) (x y : Smale.Hemisphere.Ball n ⊕ Smale.Hemisphere.Ball n)
+    (h : Smale.DiskDouble.Rel d.boundaryEquiv x y) : d.sumMap x = d.sumMap y := by
+  cases x with
+  | inl x =>
+    cases y with
+    | inl y => exact h.elim
+    | inr y => exact (d.overlap x y).mpr h
+  | inr x => cases y <;> exact h.elim
+
+private def Smale.TwoDiskDecomposition.quotientMap {n : ℕ} {M : Type*} [TopologicalSpace M]
+    (d : Smale.TwoDiskDecomposition n M) : Smale.DiskDouble.Space d.boundaryEquiv → M :=
+  Quot.lift d.sumMap d.sumMap_respects
+
+private theorem
+    Smale.TwoDiskDecomposition.continuous_quotientMap {n : ℕ} {M : Type*} [TopologicalSpace M]
+    (d : Smale.TwoDiskDecomposition n M) : Continuous d.quotientMap :=
+  continuous_quot_lift d.sumMap_respects d.continuous_sumMap
+
+private theorem
+    Smale.TwoDiskDecomposition.quotientMap_injective {n : ℕ} {M : Type*} [TopologicalSpace M]
+    (d : Smale.TwoDiskDecomposition n M) : Function.Injective d.quotientMap := by
+  intro a b
+  induction a using Quot.inductionOn with
+  | _ x =>
+    induction b using Quot.inductionOn with
+    | _ y =>
+      intro h
+      cases x with
+      | inl x =>
+        cases y with
+        | inl y =>
+          have hxy := d.left_injective h
+          subst y
+          rfl
+        | inr y => exact Quot.sound ((d.overlap x y).mp h)
+      | inr x =>
+        cases y with
+        | inl y => exact (Quot.sound ((d.overlap y x).mp h.symm)).symm
+        | inr y =>
+          have hxy := d.right_injective h
+          subst y
+          rfl
+
+private theorem
+    Smale.TwoDiskDecomposition.quotientMap_surjective {n : ℕ} {M : Type*} [TopologicalSpace M]
+    (d : Smale.TwoDiskDecomposition n M) : Function.Surjective d.quotientMap := by
+  intro p
+  rcases d.covers p with ⟨x, hx⟩ | ⟨y, hy⟩
+  · exact ⟨Quot.mk _ (.inl x), hx⟩
+  · exact ⟨Quot.mk _ (.inr y), hy⟩
+
+private def Smale.TwoDiskDecomposition.quotientHomeomorph {n : ℕ} {M : Type*} [TopologicalSpace M]
+    (d : Smale.TwoDiskDecomposition n M) [T2Space M] :
+    Smale.DiskDouble.Space d.boundaryEquiv ≃ₜ M :=
+  Continuous.homeoOfEquivCompactToT2 (f :=
+    Equiv.ofBijective d.quotientMap ⟨d.quotientMap_injective, d.quotientMap_surjective⟩)
+    d.continuous_quotientMap
+
+private def Smale.TwoDiskDecomposition.homeomorphSphere {n : ℕ} {M : Type*} [TopologicalSpace M]
+    (d : Smale.TwoDiskDecomposition n M) [T2Space M] : M ≃ₜ Smale.Hemisphere.Sphere n :=
+  d.quotientHomeomorph.symm.trans (Smale.DiskDouble.twistedHomeomorphSphere n d.boundaryEquiv)
+
+private structure
+    Smale.SublevelDisk (n : ℕ) {M : Type*} [TopologicalSpace M] (f : M → ℝ) (a : ℝ) where
+  homeomorph : Hemisphere.Ball n ≃ₜ { x : M // f x ≤ a }
+  boundary_iff : ∀ v, f (homeomorph v).1 = a ↔ ‖(v : Hemisphere.Ambient n)‖ = 1
+
+private def Smale.SublevelDisk.map {n : ℕ} {M : Type*} [TopologicalSpace M] {f : M → ℝ} {a : ℝ}
+    (d : Smale.SublevelDisk n f a) : C(Smale.Hemisphere.Ball n, M)
+    where
+  toFun v := (d.homeomorph v).1
+  continuous_toFun := continuous_subtype_val.comp d.homeomorph.continuous
+
+private theorem
+    Smale.SublevelDisk.map_injective {n : ℕ} {M : Type*} [TopologicalSpace M] {f : M → ℝ}
+    {a : ℝ} (d : Smale.SublevelDisk n f a) : Function.Injective d.map := by
+  intro v w h
+  exact d.homeomorph.injective (Subtype.ext h)
+
+private def
+    Smale.SublevelDisk.boundaryMap {n : ℕ} {M : Type*} [TopologicalSpace M] {f : M → ℝ} {a : ℝ}
+    (d : Smale.SublevelDisk n f a) :
+    C(Smale.DiskDouble.Boundary (Smale.Hemisphere.Ambient n), { x : M // f x = a })
+    where
+  toFun
+    z :=
+    ⟨d.map (Smale.DiskDouble.boundary _ z),
+      (d.boundary_iff _).mpr
+        (by simpa only [Smale.DiskDouble.boundary, mem_sphere_zero_iff_norm] using z.2)⟩
+  continuous_toFun :=
+    (d.map.continuous.comp
+          (continuous_subtype_val.subtype_mk
+            (fun z => Metric.sphere_subset_closedBall z.2))).subtype_mk
+      _
+
+private theorem Smale.SublevelDisk.boundaryMap_injective {n : ℕ} {M : Type*} [TopologicalSpace M]
+    {f : M → ℝ} {a : ℝ} (d : Smale.SublevelDisk n f a) : Function.Injective d.boundaryMap := by
+  intro z w h
+  have heq : d.map (Smale.DiskDouble.boundary _ z) = d.map (Smale.DiskDouble.boundary _ w) :=
+    congrArg (fun y : { x : M // f x = a } => y.1) h
+  have h' := d.map_injective heq
+  apply Subtype.ext
+  exact congrArg (fun v : Smale.Hemisphere.Ball n => (v : Smale.Hemisphere.Ambient n)) h'
+
+private theorem Smale.SublevelDisk.boundaryMap_surjective {n : ℕ} {M : Type*} [TopologicalSpace M]
+    {f : M → ℝ} {a : ℝ} (d : Smale.SublevelDisk n f a) : Function.Surjective d.boundaryMap := by
+  intro y
+  let v := d.homeomorph.symm ⟨y.1, y.2.le⟩
+  have hv : (d.homeomorph v).1 = y.1 :=
+    congrArg Subtype.val (d.homeomorph.apply_symm_apply ⟨y.1, y.2.le⟩)
+  have hnorm : ‖(v : Smale.Hemisphere.Ambient n)‖ = 1 :=
+    (d.boundary_iff v).mp (by rw [hv]; exact y.2)
+  let z : Smale.DiskDouble.Boundary (Smale.Hemisphere.Ambient n) :=
+    ⟨v.1, mem_sphere_zero_iff_norm.mpr hnorm⟩
+  refine ⟨z, Subtype.ext ?_⟩
+  exact hv
+
+private def
+    Smale.SublevelDisk.boundaryHomeomorph {n : ℕ} {M : Type*} [TopologicalSpace M] {f : M → ℝ}
+    {a : ℝ} (d : Smale.SublevelDisk n f a) [T2Space M] :
+    Smale.DiskDouble.Boundary (Smale.Hemisphere.Ambient n) ≃ₜ { x : M // f x = a } :=
+  Continuous.homeoOfEquivCompactToT2 (f :=
+    Equiv.ofBijective d.boundaryMap ⟨d.boundaryMap_injective, d.boundaryMap_surjective⟩)
+    d.boundaryMap.continuous
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.exists_minimumSublevelDisk {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    [CompactSpace M] {f : M → ℝ} {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (hf : Continuous f) (hunique : ∀ x, f x ≤ f p → x = p) {b : ℝ} (hb : f p < b) :
+    ∃ a ∈ Set.Ioo (f p) b, Nonempty (Smale.SublevelDisk (Module.finrank ℝ E) f a) := by
+  have hglobal : ∀ x, f p ≤ f x := by
+    intro x
+    by_contra! h
+    have hxp := hunique x h.le
+    rw [hxp] at h
+    exact lt_irrefl _ h
+  have hmin : IsLocalMin f p := Filter.Eventually.of_forall hglobal
+  obtain ⟨ρ, hρ, hab, e, he⟩ := exists_minimum_disk_sublevel_with_height c hf hunique hb
+  let d := (c.minimumDiskHomeomorph hmin).symm.trans e
+  have hd (v : Smale.Hemisphere.Ball (Module.finrank ℝ E)) :
+    f (d v).1 = f p + ρ ^ 2 * ‖(v : Smale.Hemisphere.Ambient (Module.finrank ℝ E))‖ ^ 2 := by
+    change f (e ((c.minimumDiskHomeomorph hmin).symm v)).1 = _
+    rw [he, c.norm_minimumDiskHomeomorph_symm]
+  refine ⟨f p + ρ ^ 2, ⟨by linarith [sq_pos_of_pos hρ], hab⟩, ⟨⟨d, ?_⟩⟩⟩
+  intro v
+  rw [hd]
+  constructor
+  · intro h
+    have hs : ‖(v : Smale.Hemisphere.Ambient (Module.finrank ℝ E))‖ ^ 2 = 1 :=
+      mul_left_cancel₀ (pow_ne_zero 2 hρ.ne') (by linarith)
+    nlinarith [norm_nonneg (v : Smale.Hemisphere.Ambient (Module.finrank ℝ E))]
+  · intro h
+    rw [h, one_pow, mul_one]
+
+private def Smale.FlowConstruction.stretchHeight (c k r : ℝ) : ℝ :=
+  r + (k - 1) * Max.max 0 (r - c)
+
+private theorem Smale.FlowConstruction.stretchHeight_of_le {c k r : ℝ} (hr : r ≤ c) :
+    stretchHeight c k r = r := by
+  simp only [stretchHeight, max_eq_left (sub_nonpos.mpr hr), MulZeroClass.mul_zero, add_zero]
+
+private theorem Smale.FlowConstruction.stretchHeight_of_ge {c k r : ℝ} (hr : c ≤ r) :
+    stretchHeight c k r = c + k * (r - c) := by
+  rw [stretchHeight, max_eq_right (sub_nonneg.mpr hr)]
+  ring
+
+private theorem Smale.FlowConstruction.stretchHeight_inverse {c k : ℝ} (hk : 0 < k) (r : ℝ) :
+    stretchHeight c k⁻¹ (stretchHeight c k r) = r := by
+  by_cases hr : r ≤ c
+  · rw [stretchHeight_of_le hr, stretchHeight_of_le hr]
+  · have hcr : c < r := lt_of_not_ge hr
+    have hs : c ≤ stretchHeight c k r := by
+      rw [stretchHeight_of_ge hcr.le]
+      exact le_add_of_nonneg_right (mul_nonneg hk.le (sub_nonneg.mpr hcr.le))
+    rw [stretchHeight_of_ge hs, stretchHeight_of_ge hcr.le]
+    field_simp
+    ring
+
+private theorem Smale.FlowConstruction.continuous_stretchHeight (c k : ℝ) :
+    Continuous (stretchHeight c k) :=
+  continuous_id.add
+    (continuous_const.mul (continuous_const.max (continuous_id.sub continuous_const)))
+
+private def Smale.FlowConstruction.stretchHeightHomeomorph (c k : ℝ) (hk : 0 < k) : ℝ ≃ₜ ℝ
+    where
+  toFun := stretchHeight c k
+  invFun := stretchHeight c k⁻¹
+  left_inv := stretchHeight_inverse hk
+  right_inv r := by simpa only [inv_inv] using stretchHeight_inverse (c := c) (inv_pos.mpr hk) r
+  continuous_toFun := continuous_stretchHeight c k
+  continuous_invFun := continuous_stretchHeight c k⁻¹
+
+private theorem Smale.FlowConstruction.stretchHeight_endpoint {c a b : ℝ} (hca : c < a) :
+    stretchHeight c ((b - c) / (a - c)) a = b := by
+  rw [stretchHeight_of_ge hca.le, div_mul_cancel₀ _ (sub_ne_zero.mpr hca.ne')]
+  ring
+
+private theorem Smale.FlowConstruction.stretchHeight_endpoint_iff {c a b r : ℝ} (hca : c < a)
+    (hcb : c < b) : stretchHeight c ((b - c) / (a - c)) r = b ↔ r = a := by
+  have hk : 0 < (b - c) / (a - c) := div_pos (sub_pos.mpr hcb) (sub_pos.mpr hca)
+  constructor
+  · intro h
+    exact
+      (stretchHeightHomeomorph c ((b - c) / (a - c)) hk).injective
+        (h.trans (stretchHeight_endpoint hca).symm)
+  · rintro rfl
+    exact stretchHeight_endpoint hca
+
+private theorem
+    Smale.FlowConstruction.stretchHeight_le_target {c a b r : ℝ} (hca : c < a) (hcb : c < b)
+    (hr : r ≤ a) : stretchHeight c ((b - c) / (a - c)) r ≤ b := by
+  by_cases hrc : r ≤ c
+  · rw [stretchHeight_of_le hrc]
+    exact hrc.trans hcb.le
+  · have hcr : c ≤ r := le_of_not_ge hrc
+    have hk : 0 ≤ (b - c) / (a - c) := (div_pos (sub_pos.mpr hcb) (sub_pos.mpr hca)).le
+    rw [stretchHeight_of_ge hcr]
+    calc
+      _ ≤ c + ((b - c) / (a - c)) * (a - c) :=
+        add_le_add le_rfl (mul_le_mul_of_nonneg_left (sub_le_sub_right hr c) hk)
+      _ = b := by rw [div_mul_cancel₀ _ (sub_ne_zero.mpr hca.ne')]; ring
+
+private def
+    Smale.FlowConstruction.stretchFlow {X : Type*} [TopologicalSpace X] (F : Flow ℝ X) (f : X → ℝ)
+    (c k : ℝ) (x : X) : X :=
+  F (stretchHeight c k (f x) - f x) x
+
+private theorem Smale.FlowConstruction.continuous_stretchFlow {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) (f : X → ℝ) (hf : Continuous f) (c k : ℝ) : Continuous (stretchFlow F f c k) :=
+  F.continuous (((continuous_stretchHeight c k).comp hf).sub hf) continuous_id
+
+private theorem
+    Smale.FlowConstruction.stretchFlow_height {X : Type*} [TopologicalSpace X] (F : Flow ℝ X)
+    {f : X → ℝ} {c d a b : ℝ}
+    (hF : ∀ x t, f x ∈ Set.Icc c d → f x + t ∈ Set.Icc c d → f (F t x) = f x + t) (hca : c < a)
+    (hcb : c < b) (ha : a ≤ d) (hb : b ≤ d) {x : X} (hx : f x ≤ a) :
+    f (stretchFlow F f c ((b - c) / (a - c)) x) = stretchHeight c ((b - c) / (a - c)) (f x) := by
+  by_cases hxc : f x ≤ c
+  · simp only [stretchFlow, stretchHeight_of_le hxc, sub_self, F.map_zero_apply]
+  · have hcx : c ≤ f x := le_of_not_ge hxc
+    have hk : 0 < (b - c) / (a - c) := div_pos (sub_pos.mpr hcb) (sub_pos.mpr hca)
+    have hslo : c ≤ stretchHeight c ((b - c) / (a - c)) (f x) := by
+      rw [stretchHeight_of_ge hcx]
+      exact le_add_of_nonneg_right (mul_nonneg hk.le (sub_nonneg.mpr hcx))
+    have hshi := stretchHeight_le_target hca hcb hx
+    have hsum :
+      f x + (stretchHeight c ((b - c) / (a - c)) (f x) - f x) =
+        stretchHeight c ((b - c) / (a - c)) (f x) := by ring
+    have hh :=
+      hF x (stretchHeight c ((b - c) / (a - c)) (f x) - f x) ⟨hcx, hx.trans ha⟩
+        (by rw [hsum]; exact ⟨hslo, hshi.trans hb⟩)
+    exact hh.trans hsum
+
+private theorem Smale.FlowConstruction.stretchFlow_le_target {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f : X → ℝ} {c d a b : ℝ}
+    (hF : ∀ x t, f x ∈ Set.Icc c d → f x + t ∈ Set.Icc c d → f (F t x) = f x + t) (hca : c < a)
+    (hcb : c < b) (ha : a ≤ d) (hb : b ≤ d) {x : X} (hx : f x ≤ a) :
+    f (stretchFlow F f c ((b - c) / (a - c)) x) ≤ b := by
+  rw [stretchFlow_height F hF hca hcb ha hb hx]
+  exact stretchHeight_le_target hca hcb hx
+
+private theorem
+    Smale.FlowConstruction.stretchFlow_inverse {X : Type*} [TopologicalSpace X] (F : Flow ℝ X)
+    {f : X → ℝ} {c d a b : ℝ}
+    (hF : ∀ x t, f x ∈ Set.Icc c d → f x + t ∈ Set.Icc c d → f (F t x) = f x + t) (hca : c < a)
+    (hcb : c < b) (ha : a ≤ d) (hb : b ≤ d) {x : X} (hx : f x ≤ a) :
+    stretchFlow F f c ((a - c) / (b - c)) (stretchFlow F f c ((b - c) / (a - c)) x) = x := by
+  have hh := stretchFlow_height F hF hca hcb ha hb hx
+  have hk : 0 < (b - c) / (a - c) := div_pos (sub_pos.mpr hcb) (sub_pos.mpr hca)
+  have hi : (a - c) / (b - c) = ((b - c) / (a - c))⁻¹ := (inv_div _ _).symm
+  change
+    F
+        (stretchHeight c ((a - c) / (b - c)) (f (stretchFlow F f c ((b - c) / (a - c)) x)) -
+          f (stretchFlow F f c ((b - c) / (a - c)) x))
+        (F (stretchHeight c ((b - c) / (a - c)) (f x) - f x) x) =
+      x
+  rw [hh, hi, stretchHeight_inverse hk, ← F.map_add]
+  rw [show
+      f x - stretchHeight c ((b - c) / (a - c)) (f x) +
+          (stretchHeight c ((b - c) / (a - c)) (f x) - f x) =
+        0
+      by ring,
+    F.map_zero_apply]
+
+private def Smale.FlowConstruction.regularSublevelHomeomorphOfFlow {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f : X → ℝ} {c d a b : ℝ}
+    (hF : ∀ x t, f x ∈ Set.Icc c d → f x + t ∈ Set.Icc c d → f (F t x) = f x + t)
+    (hf : Continuous f) (hca : c < a) (hcb : c < b) (ha : a ≤ d) (hb : b ≤ d) :
+    { x : X // f x ≤ a } ≃ₜ { x : X // f x ≤ b }
+    where
+  toFun
+    x := ⟨stretchFlow F f c ((b - c) / (a - c)) x.1, stretchFlow_le_target F hF hca hcb ha hb x.2⟩
+  invFun
+    x := ⟨stretchFlow F f c ((a - c) / (b - c)) x.1, stretchFlow_le_target F hF hcb hca hb ha x.2⟩
+  left_inv x := Subtype.ext (stretchFlow_inverse F hF hca hcb ha hb x.2)
+  right_inv x := Subtype.ext (stretchFlow_inverse F hF hcb hca hb ha x.2)
+  continuous_toFun :=
+    ((continuous_stretchFlow F f hf c _).comp continuous_subtype_val).subtype_mk _
+  continuous_invFun :=
+    ((continuous_stretchFlow F f hf c _).comp continuous_subtype_val).subtype_mk _
+
+private theorem Smale.FlowConstruction.regularSublevelHomeomorphOfFlow_level_iff {X : Type*}
+    [TopologicalSpace X] (F : Flow ℝ X) {f : X → ℝ} {c d a b : ℝ}
+    (hF : ∀ x t, f x ∈ Set.Icc c d → f x + t ∈ Set.Icc c d → f (F t x) = f x + t)
+    (hf : Continuous f) (hca : c < a) (hcb : c < b) (ha : a ≤ d) (hb : b ≤ d)
+    (x : { x : X // f x ≤ a }) :
+    f ((regularSublevelHomeomorphOfFlow F hF hf hca hcb ha hb) x).1 = b ↔ f x.1 = a := by
+  change f (stretchFlow F f c ((b - c) / (a - c)) x.1) = b ↔ _
+  rw [stretchFlow_height F hF hca hcb ha hb x.2]
+  exact stretchHeight_endpoint_iff hca hcb
+
+private theorem Smale.FlowConstruction.exists_regularSublevelHomeomorph_with_level {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {c a b : ℝ} (hca : c < a) (hcb : c < b)
+    (hband : ∀ x, f x ∈ Set.Icc c (Max.max a b) → x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    ∃ e : { x : M // f x ≤ a } ≃ₜ { x : M // f x ≤ b }, ∀ x, f (e x).1 = b ↔ f x.1 = a := by
+  obtain ⟨F, hF⟩ := exists_heightTranslatingFlow hf hband
+  refine
+    ⟨regularSublevelHomeomorphOfFlow F hF hf.continuous hca hcb (le_max_left a b)
+        (le_max_right a b),
+      ?_⟩
+  exact
+    regularSublevelHomeomorphOfFlow_level_iff F hF hf.continuous hca hcb (le_max_left a b)
+      (le_max_right a b)
+
+private def
+    Smale.SublevelDisk.transport {M : Type*} [TopologicalSpace M] {n : ℕ} {f : M → ℝ} {a b : ℝ}
+    (d : Smale.SublevelDisk n f a) (e : { x : M // f x ≤ a } ≃ₜ { x : M // f x ≤ b })
+    (he : ∀ x, f (e x).1 = b ↔ f x.1 = a) : Smale.SublevelDisk n f b
+    where
+  homeomorph := d.homeomorph.trans e
+  boundary_iff v := (he (d.homeomorph v)).trans (d.boundary_iff v)
+
+private theorem
+    Smale.FlowConstruction.nonempty_regularSublevelDisk {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {n : ℕ} {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {c a b : ℝ} (hca : c < a) (hcb : c < b)
+    (hband : ∀ x, f x ∈ Set.Icc c (Max.max a b) → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (d : Smale.SublevelDisk n f a) : Nonempty (Smale.SublevelDisk n f b) := by
+  obtain ⟨e, he⟩ := exists_regularSublevelHomeomorph_with_level hf hca hcb hband
+  exact ⟨d.transport e he⟩
+
+private theorem Smale.ManifoldMorse.SignedMorseChart.nonempty_sublevelDisk_before_next_critical
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    {f : M → ℝ} {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hunique : ∀ x, f x ≤ f p → x = p) {b : ℝ} (hb : f p < b)
+    (hregular : ∀ x, f p < f x → f x ≤ b → x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    Nonempty (Smale.SublevelDisk (Module.finrank ℝ E) f b) := by
+  obtain ⟨a, ha, ⟨d⟩⟩ := c.exists_minimumSublevelDisk hf.continuous hunique hb
+  obtain ⟨l, hpl, hla⟩ := exists_between ha.1
+  apply Smale.FlowConstruction.nonempty_regularSublevelDisk hf hla (hla.trans ha.2) _ d
+  intro x hx
+  apply hregular x (hpl.trans_le hx.1)
+  exact hx.2.trans (max_le ha.2.le le_rfl)
+
+private theorem Smale.ManifoldMorse.criticalPoints_neg {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] (f : M → ℝ) :
+    criticalPoints E (fun x => -f x) = criticalPoints E f := by
+  ext x
+  change mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) (-f) x = 0 ↔ mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f x = 0
+  rw [mfderiv_neg]
+  exact neg_eq_zero
+
+private def Smale.ManifoldMorse.SignedMorseChart.neg {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) :
+    Smale.ManifoldMorse.SignedMorseChart (E := E) (fun x => -f x) p
+    where
+  weights i := -c.weights i
+  signs
+    i := by
+    rcases c.signs i with h | h
+    · exact Or.inr (by rw [h]; ring)
+    · exact Or.inl (by rw [h])
+  chart := c.chart
+  mem_source := c.mem_source
+  center := c.center
+  equation y
+    hy := by
+    rw [c.equation y hy]
+    simp only [neg_mul, Finset.sum_neg_distrib, neg_add]
+  inverse_equation y
+    hy := by
+    rw [c.inverse_equation y hy]
+    simp only [neg_mul, Finset.sum_neg_distrib, neg_add]
+
+private def Smale.ManifoldMorse.SurgeryWindows.first {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (h : 0 < S.count) :
+    Smale.ManifoldMorse.criticalPoints E f :=
+  S.point ⟨0, h⟩
+
+private def
+    Smale.ManifoldMorse.SurgeryWindows.last {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (h : 0 < S.count) :
+    Smale.ManifoldMorse.criticalPoints E f :=
+  S.point ⟨S.count - 1, Nat.sub_lt h zero_lt_one⟩
+
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.value_first_le {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (h : 0 < S.count)
+    (p : Smale.ManifoldMorse.criticalPoints E f) : f (S.first h) ≤ f p := by
+  have hle : (⟨0, h⟩ : Fin S.count) ≤ S.point.symm p := Nat.zero_le _
+  simpa only [first, Equiv.apply_symm_apply] using S.point_strictMono.monotone hle
+
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.value_le_last {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (h : 0 < S.count)
+    (p : Smale.ManifoldMorse.criticalPoints E f) : f p ≤ f (S.last h) := by
+  have hle : S.point.symm p ≤ (⟨S.count - 1, Nat.sub_lt h zero_lt_one⟩ : Fin S.count) :=
+    Nat.le_sub_one_of_lt (S.point.symm p).isLt
+  simpa only [last, Equiv.apply_symm_apply] using S.point_strictMono.monotone hle
+
+private theorem Smale.ManifoldMorse.SurgeryWindows.count_pos {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M]
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) [Nonempty M] : 0 < S.count := by
+  obtain ⟨p, -, hmin⟩ :=
+    isCompact_univ.exists_isMinOn Set.univ_nonempty hf.continuous.continuousOn
+  have hp : p ∈ Smale.ManifoldMorse.criticalPoints E f :=
+    Smale.ManifoldMorse.mem_criticalPoints_of_localMin hf
+      (Filter.Eventually.of_forall (fun x => hmin (Set.mem_univ x)))
+  exact lt_of_le_of_lt (Nat.zero_le _) (S.point.symm ⟨p, hp⟩).isLt
+
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.first_globalMin {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M]
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (h : 0 < S.count) (x : M) : f (S.first h) ≤ f x := by
+  obtain ⟨p, -, hmin⟩ :=
+    isCompact_univ.exists_isMinOn ⟨x, Set.mem_univ x⟩ hf.continuous.continuousOn
+  have hp : p ∈ Smale.ManifoldMorse.criticalPoints E f :=
+    Smale.ManifoldMorse.mem_criticalPoints_of_localMin hf
+      (Filter.Eventually.of_forall (fun y => hmin (Set.mem_univ y)))
+  exact (S.value_first_le h ⟨p, hp⟩).trans (hmin (Set.mem_univ x))
+
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.last_globalMax {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M]
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (h : 0 < S.count) (x : M) : f x ≤ f (S.last h) := by
+  obtain ⟨p, -, hmax⟩ :=
+    isCompact_univ.exists_isMaxOn ⟨x, Set.mem_univ x⟩ hf.continuous.continuousOn
+  have hp : p ∈ Smale.ManifoldMorse.criticalPoints E f :=
+    Smale.ManifoldMorse.mem_criticalPoints_of_localMax hf
+      (Filter.Eventually.of_forall (fun y => hmax (Set.mem_univ y)))
+  exact (hmax (Set.mem_univ x)).trans (S.value_le_last h ⟨p, hp⟩)
+
+private theorem Smale.ManifoldMorse.SurgeryWindows.unique_first {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M]
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (h : 0 < S.count) (x : M) (hx : f x ≤ f (S.first h)) :
+    x = (S.first h).val := by
+  have hxcrit : x ∈ Smale.ManifoldMorse.criticalPoints E f :=
+    Smale.ManifoldMorse.mem_criticalPoints_of_localMin hf
+      (Filter.Eventually.of_forall (fun y => hx.trans (S.first_globalMin hf h y)))
+  exact S.distinct hxcrit (S.first h).property (le_antisymm hx (S.first_globalMin hf h x))
+
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.last_upper_univ {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M]
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (h : 0 < S.count) :
+    {x : M | f x ≤ S.upper (S.last h)} = Set.univ := by
+  apply Set.eq_univ_of_forall
+  intro x
+  exact (S.last_globalMax hf h x).trans (S.value_lt_upper (S.last h)).le
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.first_index_zero {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M]
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (h : 0 < S.count) :
+    Module.finrank ℝ (S.data (S.first h)).chart.NegativeCoordinates = 0 := by
+  let :=
+    (S.data (S.first h)).chart.subsingleton_negative_of_localMin
+      (Filter.Eventually.of_forall (S.first_globalMin hf h))
+  exact Module.finrank_zero_of_subsingleton
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SurgeryWindows.last_index_dimension {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M]
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (h : 0 < S.count) :
+    Module.finrank ℝ (S.data (S.last h)).chart.NegativeCoordinates = Module.finrank ℝ E := by
+  let :=
+    (S.data (S.last h)).chart.subsingleton_positive_of_localMax
+      (Filter.Eventually.of_forall (S.last_globalMax hf h))
+  have hz : Module.finrank ℝ (S.data (S.last h)).chart.PositiveCoordinates = 0 :=
+    Module.finrank_zero_of_subsingleton
+  simpa only [hz, add_zero] using (S.data (S.last h)).chart.finrank_negative_add_positive
+
+private theorem Smale.ManifoldMorse.SurgeryWindows.nonempty_firstSublevelDisk {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M]
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) [FiniteDimensional ℝ E] [T2Space M] (h : 0 < S.count) :
+    Nonempty (Smale.SublevelDisk (Module.finrank ℝ E) f (S.upper (S.first h))) := by
+  apply
+    (S.data (S.first h)).chart.nonempty_sublevelDisk_before_next_critical hf (S.unique_first hf h)
+      (S.value_lt_upper (S.first h))
+  intro x hxlo hxhi hxcrit
+  have hxlower : S.lower (S.first h) ≤ f x := (S.lower_lt_value (S.first h)).le.trans hxlo.le
+  have hxp := S.isolated (S.first h) x hxcrit ⟨hxlower, hxhi⟩
+  rw [hxp] at hxlo
+  exact lt_irrefl _ hxlo
+
+private def Smale.FlowConstruction.sublevelInclusion {M : Type*} [TopologicalSpace M] {f : M → ℝ}
+    {a b : ℝ} (hab : a ≤ b) : C({ x : M // f x ≤ a }, { x : M // f x ≤ b })
+    where
+  toFun x := ⟨x.1, x.2.trans hab⟩
+  continuous_toFun := continuous_subtype_val.subtype_mk _
+
+private theorem Smale.FlowConstruction.sublevel_deformation_height {M : Type*} [TopologicalSpace M]
+    {f : M → ℝ} {a b : ℝ} (F : Flow ℝ M)
+    (hF : ∀ x t, f x ∈ Set.Icc a b → f x + t ∈ Set.Icc a b → f (F t x) = f x + t) {x : M}
+    (hx : f x ≤ b) {u : ℝ} (hu : u ∈ Set.Icc (0 : ℝ) 1) :
+    f (F (u * Min.min 0 (a - f x)) x) = f x + u * Min.min 0 (a - f x) := by
+  by_cases hxa : f x ≤ a
+  · rw [min_eq_left (sub_nonneg.mpr hxa), MulZeroClass.mul_zero, F.map_zero_apply, add_zero]
+  · have hax : a ≤ f x := (lt_of_not_ge hxa).le
+    rw [min_eq_right (sub_nonpos.mpr hax)]
+    apply hF x _ ⟨hax, hx⟩
+    have htime : u * (a - f x) ≤ 0 := mul_nonpos_of_nonneg_of_nonpos hu.1 (sub_nonpos.mpr hax)
+    have hprod : 0 ≤ (1 - u) * (f x - a) := mul_nonneg (sub_nonneg.mpr hu.2) (sub_nonneg.mpr hax)
+    exact ⟨by nlinarith, by linarith⟩
+
+private theorem Smale.FlowConstruction.sublevel_deformation_mem {M : Type*} [TopologicalSpace M]
+    {f : M → ℝ} {a b : ℝ} (F : Flow ℝ M)
+    (hF : ∀ x t, f x ∈ Set.Icc a b → f x + t ∈ Set.Icc a b → f (F t x) = f x + t) {x : M}
+    (hx : f x ≤ b) {u : ℝ} (hu : u ∈ Set.Icc (0 : ℝ) 1) : f (F (u * Min.min 0 (a - f x)) x) ≤ b :=
+  by
+  rw [sublevel_deformation_height F hF hx hu]
+  exact (add_le_of_nonpos_right (mul_nonpos_of_nonneg_of_nonpos hu.1 (min_le_left _ _))).trans hx
+
+private theorem Smale.FlowConstruction.sublevel_retraction_mem {M : Type*} [TopologicalSpace M]
+    {f : M → ℝ} {a b : ℝ} (F : Flow ℝ M)
+    (hF : ∀ x t, f x ∈ Set.Icc a b → f x + t ∈ Set.Icc a b → f (F t x) = f x + t) {x : M}
+    (hx : f x ≤ b) : f (F (Min.min 0 (a - f x)) x) ≤ a := by
+  have h :=
+    sublevel_deformation_height F hF hx (show (1 : ℝ) ∈ Set.Icc 0 1 from ⟨zero_le_one, le_rfl⟩)
+  simp only [one_mul] at h
+  rw [h]
+  have hm := min_le_right (0 : ℝ) (a - f x)
+  linarith
+
+private def Smale.FlowConstruction.sublevelRetraction {M : Type*} [TopologicalSpace M] {f : M → ℝ}
+    {a b : ℝ} (F : Flow ℝ M)
+    (hF : ∀ x t, f x ∈ Set.Icc a b → f x + t ∈ Set.Icc a b → f (F t x) = f x + t)
+    (hf : Continuous f) : C({ x : M // f x ≤ b }, { x : M // f x ≤ a })
+    where
+  toFun x := ⟨F (Min.min 0 (a - f x.1)) x.1, sublevel_retraction_mem F hF x.2⟩
+  continuous_toFun :=
+    (F.continuous (continuous_const.min (continuous_const.sub (hf.comp continuous_subtype_val)))
+          continuous_subtype_val).subtype_mk
+      _
+
+private theorem Smale.FlowConstruction.sublevelRetraction_inclusion {M : Type*} [TopologicalSpace M]
+    {f : M → ℝ} {a b : ℝ} (F : Flow ℝ M)
+    (hF : ∀ x t, f x ∈ Set.Icc a b → f x + t ∈ Set.Icc a b → f (F t x) = f x + t)
+    (hf : Continuous f) (hab : a ≤ b) (x : { x : M // f x ≤ a }) :
+    sublevelRetraction F hF hf (sublevelInclusion hab x) = x := by
+  apply Subtype.ext
+  change F (Min.min 0 (a - f x.1)) x.1 = x.1
+  rw [min_eq_left (sub_nonneg.mpr x.2), F.map_zero_apply]
+
+private def Smale.FlowConstruction.sublevelDeformation {M : Type*} [TopologicalSpace M] {f : M → ℝ}
+    {a b : ℝ} (F : Flow ℝ M)
+    (hF : ∀ x t, f x ∈ Set.Icc a b → f x + t ∈ Set.Icc a b → f (F t x) = f x + t)
+    (hf : Continuous f) (hab : a ≤ b) :
+    (ContinuousMap.id { x : M // f x ≤ b }).HomotopyRel
+      ((sublevelInclusion hab).comp (sublevelRetraction F hF hf)) {x | f x.1 ≤ a}
+    where
+  toFun
+    p := ⟨F (p.1.1 * Min.min 0 (a - f p.2.1)) p.2.1, sublevel_deformation_mem F hF p.2.2 p.1.2⟩
+  continuous_toFun :=
+    (F.continuous
+          ((continuous_subtype_val.comp continuous_fst).mul
+            (continuous_const.min
+              (continuous_const.sub (hf.comp (continuous_subtype_val.comp continuous_snd)))))
+          (continuous_subtype_val.comp continuous_snd)).subtype_mk
+      _
+  map_zero_left
+    x := by
+    apply Subtype.ext
+    change F ((0 : ℝ) * Min.min 0 (a - f x.1)) x.1 = x.1
+    rw [MulZeroClass.zero_mul, F.map_zero_apply]
+  map_one_left
+    x := by
+    apply Subtype.ext
+    change F ((1 : ℝ) * Min.min 0 (a - f x.1)) x.1 = F (Min.min 0 (a - f x.1)) x.1
+    rw [one_mul]
+  prop' u x
+    hx := by
+    apply Subtype.ext
+    change F (u.1 * Min.min 0 (a - f x.1)) x.1 = x.1
+    rw [min_eq_left (sub_nonneg.mpr hx), MulZeroClass.mul_zero, F.map_zero_apply]
+
+private def
+    Smale.FlowConstruction.regularSublevelHomotopyEquivOfFlow {M : Type*} [TopologicalSpace M]
+    {f : M → ℝ} {a b : ℝ} (F : Flow ℝ M)
+    (hF : ∀ x t, f x ∈ Set.Icc a b → f x + t ∈ Set.Icc a b → f (F t x) = f x + t)
+    (hf : Continuous f) (hab : a ≤ b) : { x : M // f x ≤ a } ≃ₕ { x : M // f x ≤ b }
+    where
+  toFun := sublevelInclusion hab
+  invFun := sublevelRetraction F hF hf
+  left_inv := by
+    have heq :
+      (sublevelRetraction F hF hf).comp (sublevelInclusion hab) =
+        ContinuousMap.id { x : M // f x ≤ a } := by
+      apply ContinuousMap.ext
+      intro x
+      exact sublevelRetraction_inclusion F hF hf hab x
+    rw [heq]
+  right_inv := ⟨(sublevelDeformation F hF hf hab).toHomotopy.symm⟩
+
+private theorem Smale.FlowConstruction.exists_regularSublevelHomotopyEquiv {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ} (hab : a ≤ b)
+    (hband : ∀ x, f x ∈ Set.Icc a b → x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    ∃ e : { x : M // f x ≤ a } ≃ₕ { x : M // f x ≤ b }, ∀ x, (e x).1 = x.1 := by
+  obtain ⟨F, hF⟩ := exists_heightTranslatingFlow hf hband
+  exact ⟨regularSublevelHomotopyEquivOfFlow F hF hf.continuous hab, fun _ => rfl⟩
+
+private theorem MorseCancel.ordered_upper_pathConnected_of_later_transfers {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [PathConnectedSpace M] {f : M → ℝ} (S : Smale.ManifoldMorse.SurgeryWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (i : Fin S.count)
+    (htransfer :
+      ∀ j : Fin S.count,
+        i.val < j.val →
+          PathConnectedSpace { x : M // f x ≤ S.upper (S.point j) } →
+            PathConnectedSpace { x : M // f x ≤ S.lower (S.point j) }) :
+    PathConnectedSpace { x : M // f x ≤ S.upper (S.point i) } := by
+  have hall :
+    ∀ k : ℕ,
+      ∀ i : Fin S.count,
+        S.count - 1 - i.val = k →
+          (∀ j : Fin S.count,
+              i.val < j.val →
+                PathConnectedSpace { x : M // f x ≤ S.upper (S.point j) } →
+                  PathConnectedSpace { x : M // f x ≤ S.lower (S.point j) }) →
+            PathConnectedSpace { x : M // f x ≤ S.upper (S.point i) } := by
+    intro k
+    induction k using Nat.strong_induction_on with
+    | h k ih =>
+      intro i hki hindices
+      have hpos : 0 < S.count := (Nat.zero_le i.val).trans_lt i.isLt
+      by_cases hlast : i.val = S.count - 1
+      · have hi : S.point i = S.last hpos := congrArg S.point (Fin.ext hlast)
+        have hset : {x : M | f x ≤ S.upper (S.point i)} = Set.univ := by
+          rw [hi]
+          exact S.last_upper_univ hf hpos
+        have hp : IsPathConnected {x : M | f x ≤ S.upper (S.point i)} :=
+          hset.symm ▸ isPathConnected_univ
+        exact isPathConnected_iff_pathConnectedSpace.mp hp
+      · have hjlt : i.val + 1 < S.count := by omega
+        let j : Fin S.count := ⟨i.val + 1, hjlt⟩
+        have hjmeasure : S.count - 1 - j.val < k := by
+          dsimp [j]
+          omega
+        have hupper : PathConnectedSpace { x : M // f x ≤ S.upper (S.point j) } :=
+          ih _ hjmeasure j rfl (fun q hq => hindices q (by dsimp [j] at hq; omega))
+        let : PathConnectedSpace { x : M // f x ≤ S.lower (S.point j) } :=
+          hindices j (by dsimp [j]; omega) hupper
+        have hij : i < j := by change i.val < i.val + 1; omega
+        obtain ⟨e, -⟩ :=
+          Smale.FlowConstruction.exists_regularSublevelHomotopyEquiv hf
+            (S.ordered_windows i j hij).le (S.consecutive_regular i j rfl)
+        exact pathConnectedSpace_of_homotopyEquiv e
+  exact hall _ i rfl htransfer
+
+private theorem MorseCancel.cell_old_empty_of_empty_boundary {N X : Type} [NormedAddCommGroup N]
+     [TopologicalSpace X] [PreconnectedSpace X]
+    (D : Smale.EmbeddedCellAttachment N X) [IsEmpty (Metric.sphere (0 : N) 1)] : D.old = ∅ := by
+  have hdisjoint (z : Smale.MorseHandle.UnitDisk N) : D.cell z ∉ D.old := by
+    intro hz
+    exact
+      isEmptyElim
+        (⟨z.val, mem_sphere_zero_iff_norm.mpr ((D.boundary z).mp hz)⟩ : Metric.sphere (0 : N) 1)
+  have heq : D.old = (Set.range D.cell)ᶜ := by
+    ext x
+    constructor
+    · intro hx ⟨z, hz⟩
+      exact hdisjoint z (hz ▸ hx)
+    · intro hx
+      have hc : x ∈ D.old ∪ Set.range D.cell := by rw [D.cover]; trivial
+      exact hc.resolve_right hx
+  have hc : IsClopen D.old := ⟨D.old_closed, heq.symm ▸ D.cell_closed.isClosed_range.isOpen_compl⟩
+  rcases isClopen_iff.mp hc with h | h
+  · exact h
+  · let z : Smale.MorseHandle.UnitDisk N := ⟨0, by simp⟩
+    exact False.elim (hdisjoint z (h ▸ Set.mem_univ _))
+
+private theorem MorseCancel.native_zero_handle_lower_isEmpty {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 0)
+    [PathConnectedSpace { z : M // f z ≤ f p + d.radius ^ 2 }] :
+    IsEmpty { z : M // f z ≤ f p - d.radius ^ 2 } := by
+  let : Subsingleton d.chart.NegativeCoordinates :=
+    (Module.finrank_eq_zero_iff_of_free ℝ d.chart.NegativeCoordinates).mp hindex
+  let : IsEmpty (Metric.sphere (0 : d.chart.NegativeCoordinates) 1) :=
+    ⟨fun v => by
+      have h := mem_sphere_zero_iff_norm.mp v.property
+      rw [Subsingleton.elim v.val 0, norm_zero] at h
+      norm_num at h⟩
+  let : PathConnectedSpace ↥({z : M | f z ≤ f p - d.radius ^ 2} ∪ Set.range d.coreMap) :=
+    pathConnectedSpace_of_homotopyEquiv (d.coreUnionHomotopyEquiv hf)
+  have he := cell_old_empty_of_empty_boundary (d.coreCellPresentation hf)
+  refine ⟨fun x => ?_⟩
+  have hx := (d.cellOldHomeomorph hf x).property
+  exact (Set.eq_empty_iff_forall_notMem.mp he) _ hx
+
+private theorem
+    Smale.SublevelDisk.circle_nullhomotopies {M : Type*} [TopologicalSpace M] [T2Space M]
+    {f : M → ℝ} {a : ℝ} {n : ℕ} (d : Smale.SublevelDisk (n + 1) f a) (hn : 1 < n) :
+    ∀ g : C(Smale.Hemisphere.Sphere 1, { x : M // f x = a }),
+      ∃ q, g.Homotopic (ContinuousMap.const _ q) := by
+  let e : Smale.Hemisphere.Sphere n ≃ₜ { x : M // f x = a } := d.boundaryHomeomorph
+  let forward : C(Smale.Hemisphere.Sphere n, { x : M // f x = a }) := ⟨e, e.continuous⟩
+  let backward : C({ x : M // f x = a }, Smale.Hemisphere.Sphere n) := ⟨e.symm, e.symm.continuous⟩
+  intro g
+  obtain ⟨q, hq⟩ := NoExotic.sphere_sphere_nullhomotopic hn (backward.comp g)
+  have heq : forward.comp (backward.comp g) = g := by
+    apply ContinuousMap.ext
+    intro x
+    exact e.apply_symm_apply (g x)
+  have hh : (forward.comp (backward.comp g)).Homotopic (ContinuousMap.const _ (e q)) :=
+    (ContinuousMap.Homotopic.refl forward).comp hq
+  exact ⟨e q, heq ▸ hh⟩
+
+private def Smale.FlowConstruction.regularLevelHomeomorphOfFlow {M : Type*} [TopologicalSpace M]
+    {f : M → ℝ} {a b : ℝ} (hab : a ≤ b) (F : Flow ℝ M)
+    (hF : ∀ x t, f x ∈ Set.Icc a b → f x + t ∈ Set.Icc a b → f (F t x) = f x + t) :
+    { x : M // f x = a } ≃ₜ { x : M // f x = b } := by
+  have hup (x : { x : M // f x = a }) : f (F (b - a) x) = b := by
+    have hs : f x ∈ Set.Icc a b := by rw [x.property]; exact ⟨le_rfl, hab⟩
+    have ht : f x + (b - a) ∈ Set.Icc a b := by
+      rw [x.property, add_sub_cancel]
+      exact ⟨hab, le_rfl⟩
+    simpa only [x.property, add_sub_cancel] using hF x (b - a) hs ht
+  have hdown (y : { x : M // f x = b }) : f (F (a - b) y) = a := by
+    have hs : f y ∈ Set.Icc a b := by rw [y.property]; exact ⟨hab, le_rfl⟩
+    have ht : f y + (a - b) ∈ Set.Icc a b := by
+      rw [y.property, add_sub_cancel]
+      exact ⟨le_rfl, hab⟩
+    simpa only [y.property, add_sub_cancel] using hF y (a - b) hs ht
+  refine
+    { toFun := fun x => ⟨F (b - a) x, hup x⟩
+      invFun := fun y => ⟨F (a - b) y, hdown y⟩
+      left_inv := ?_
+      right_inv := ?_
+      continuous_toFun := (F.continuous continuous_const continuous_subtype_val).subtype_mk _
+      continuous_invFun := (F.continuous continuous_const continuous_subtype_val).subtype_mk _ }
+  · intro x
+    apply Subtype.ext
+    change F (a - b) (F (b - a) x) = x
+    rw [← F.map_add, show a - b + (b - a) = 0 by ring, F.map_zero_apply]
+  · intro y
+    apply Subtype.ext
+    change F (b - a) (F (a - b) y) = y
+    rw [← F.map_add, show b - a + (a - b) = 0 by ring, F.map_zero_apply]
+
+private theorem Smale.FlowConstruction.nonempty_regularLevelHomeomorph {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ} (hab : a ≤ b)
+    (hband : ∀ x, f x ∈ Set.Icc a b → x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    Nonempty ({ x : M // f x = a } ≃ₜ { x : M // f x = b }) := by
+  obtain ⟨F, hF⟩ := exists_heightTranslatingFlow hf hband
+  exact ⟨regularLevelHomeomorphOfFlow hab F hF⟩
+
+private theorem Smale.FlowConstruction.circle_nullhomotopies_regular_level {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ} (hab : a ≤ b)
+    (hband : ∀ x, f x ∈ Set.Icc a b → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hnull :
+      ∀ g : C(Smale.Hemisphere.Sphere 1, { x : M // f x = a }),
+        ∃ q, g.Homotopic (ContinuousMap.const _ q)) :
+    ∀ g : C(Smale.Hemisphere.Sphere 1, { x : M // f x = b }),
+      ∃ q, g.Homotopic (ContinuousMap.const _ q) := by
+  obtain ⟨e⟩ := nonempty_regularLevelHomeomorph hf hab hband
+  let forward : C({ x : M // f x = a }, { x : M // f x = b }) := ⟨e, e.continuous⟩
+  let backward : C({ x : M // f x = b }, { x : M // f x = a }) := ⟨e.symm, e.symm.continuous⟩
+  intro g
+  obtain ⟨q, hq⟩ := hnull (backward.comp g)
+  have heq : forward.comp (backward.comp g) = g := by
+    apply ContinuousMap.ext
+    intro x
+    exact e.apply_symm_apply (g x)
+  have hh : (forward.comp (backward.comp g)).Homotopic (ContinuousMap.const _ (e q)) :=
+    (ContinuousMap.Homotopic.refl forward).comp hq
+  exact ⟨e q, heq ▸ hh⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SurgeryWindows.lower_circle_nullhomotopies_of_middle_indices
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    {f : M → ℝ} (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (j : Fin S.count) (hj : 0 < j.val)
+    (hindex :
+      ∀ i : Fin S.count,
+        0 < i.val →
+          i.val < j.val →
+            Module.finrank ℝ (S.data (S.point i)).chart.NegativeCoordinates = 2 ∨
+              Module.finrank ℝ (S.data (S.point i)).chart.NegativeCoordinates = 3) :
+    ∀ g : C(Smale.Hemisphere.Sphere 1, (S.data (S.point j)).LowerLevel),
+      ∃ q, g.Homotopic (ContinuousMap.const _ q) := by
+  have hupper :
+    ∀ n : ℕ,
+      ∀ hn : n < S.count,
+        n < j.val →
+          ∀ g : C(Smale.Hemisphere.Sphere 1, (S.data (S.point ⟨n, hn⟩)).UpperLevel),
+            ∃ q, g.Homotopic (ContinuousMap.const _ q) := by
+    intro n
+    induction n with
+    | zero =>
+      intro hn _
+      obtain ⟨d⟩ := S.nonempty_firstSublevelDisk hf hn
+      have d' : Smale.SublevelDisk 6 f (S.upper (S.first hn)) := hdim ▸ d
+      exact d'.circle_nullhomotopies (n := 5) (by norm_num)
+    | succ n ih =>
+      intro hn hnj
+      have hn' : n < S.count := by omega
+      have hprev := ih hn' (by omega)
+      have hlt : (⟨n, hn'⟩ : Fin S.count) < ⟨n + 1, hn⟩ := Nat.lt_succ_self n
+      have hlow :
+        ∀ g : C(Smale.Hemisphere.Sphere 1, (S.data (S.point ⟨n + 1, hn⟩)).LowerLevel),
+          ∃ q, g.Homotopic (ContinuousMap.const _ q) :=
+        Smale.FlowConstruction.circle_nullhomotopies_regular_level hf
+          (S.ordered_windows _ _ hlt).le (S.consecutive_regular _ _ rfl) hprev
+      rcases hindex ⟨n + 1, hn⟩ (Nat.succ_pos n) hnj with htwo | hthree
+      · let :
+          Fact
+            (Module.finrank ℝ (S.data (S.point ⟨n + 1, hn⟩)).chart.NegativeCoordinates = 1 + 1) :=
+          ⟨htwo⟩
+        exact
+          (S.data (S.point ⟨n + 1, hn⟩)).upper_circle_nullhomotopies hf 1 (by norm_num) (by omega)
+            hlow
+      · let :
+          Fact
+            (Module.finrank ℝ (S.data (S.point ⟨n + 1, hn⟩)).chart.NegativeCoordinates = 2 + 1) :=
+          ⟨hthree⟩
+        exact
+          (S.data (S.point ⟨n + 1, hn⟩)).upper_circle_nullhomotopies hf 2 (by norm_num) (by omega)
+            hlow
+  have hprev : j.val - 1 < S.count := by omega
+  have hprevj : (⟨j.val - 1, hprev⟩ : Fin S.count) < j := by
+    change j.val - 1 < j.val
+    omega
+  exact
+    Smale.FlowConstruction.circle_nullhomotopies_regular_level hf
+      (S.ordered_windows _ _ hprevj).le
+      (S.consecutive_regular _ _ (by change j.val - 1 + 1 = j.val; omega))
+      (hupper (j.val - 1) hprev hprevj)
+
+private theorem MorseCancel.native_index_zero_point_unique {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hn : 0 < S.count) (hcount : nativeMorseCount E f 0 = 1) :
+    ∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+      nativeMorseIndex E f z = 0 → z = (S.first hn).val := by
+  have hfirst : nativeMorseIndex E f (S.first hn) = 0 :=
+    (nativeMorseIndex_eq_chart (S.data (S.first hn)).chart).trans (S.first_index_zero hf hn)
+  change
+    {z : M | z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ nativeMorseIndex E f z = 0}.ncard =
+      1 at hcount
+  obtain ⟨z₀, hz₀⟩ := Set.ncard_eq_one.mp hcount
+  have hfirstmem :
+    (S.first hn).val ∈
+      {z : M | z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ nativeMorseIndex E f z = 0} :=
+    ⟨(S.first hn).property, hfirst⟩
+  rw [hz₀, Set.mem_singleton_iff] at hfirstmem
+  intro z hz hi
+  have hzmem :
+    z ∈ {z : M | z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ nativeMorseIndex E f z = 0} :=
+    ⟨hz, hi⟩
+  rw [hz₀, Set.mem_singleton_iff] at hzmem
+  exact hzmem.trans hfirstmem.symm
+
+private theorem MorseCancel.native_index_one_excluded {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+       {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hcount : nativeMorseCount E f 1 = 0) :
+    ∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, nativeMorseIndex E f z ≠ 1 := by
+  have hfinite :
+    {z : M | z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ nativeMorseIndex E f z = 1}.Finite :=
+    S.finite.subset (fun _ hz => hz.1)
+  have hempty :
+    {z : M | z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ nativeMorseIndex E f z = 1} = ∅ :=
+    (Set.ncard_eq_zero hfinite).mp hcount
+  intro z hz hi
+  have hmem :
+    z ∈ {z : M | z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ nativeMorseIndex E f z = 1} :=
+    ⟨hz, hi⟩
+  rw [hempty] at hmem
+  exact hmem
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.lower_circle_nullhomotopies_of_ordered_native_indices {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (p : Smale.ManifoldMorse.criticalPoints E f)
+    (hpindex : nativeMorseIndex E f p = 2) (hzero : nativeMorseCount E f 0 = 1)
+    (hone : nativeMorseCount E f 1 = 0)
+    (horder :
+      ∀ r : Smale.ManifoldMorse.criticalPoints E f, f r < f p → nativeMorseIndex E f r ≤ 2) :
+    ∀ γ : C(Smale.Hemisphere.Sphere 1, (S.data p).LowerLevel),
+      ∃ z, γ.Homotopic (ContinuousMap.const _ z) := by
+  obtain ⟨j, rfl⟩ := S.point.surjective p
+  have hn : 0 < S.count := (Nat.zero_le j.val).trans_lt j.isLt
+  have hpnotfirst : S.point j ≠ S.first hn := by
+    intro hpfirst
+    have hfirst : nativeMorseIndex E f (S.first hn) = 0 :=
+      (nativeMorseIndex_eq_chart (S.data (S.first hn)).chart).trans (S.first_index_zero hf hn)
+    rw [hpfirst] at hpindex
+    omega
+  have hj : 0 < j.val := by
+    by_contra hj
+    have hj0 : j.val = 0 := by omega
+    have heq : S.point j = S.first hn := congrArg S.point (Fin.ext hj0)
+    exact hpnotfirst heq
+  have hmiddle (i : Fin S.count) (hi : 0 < i.val) (hij : i.val < j.val) :
+    Module.finrank ℝ (S.data (S.point i)).chart.NegativeCoordinates = 2 ∨
+      Module.finrank ℝ (S.data (S.point i)).chart.NegativeCoordinates = 3 := by
+    have hvalues : f (S.point i) < f (S.point j) := S.point_strictMono (show i < j from hij)
+    have hle := horder (S.point i) hvalues
+    have hne0 : nativeMorseIndex E f (S.point i) ≠ 0 := by
+      intro hindex
+      have heq : (S.point i).val = (S.first hn).val :=
+        native_index_zero_point_unique S hf hn hzero _ (S.point i).property hindex
+      have heq' : S.point i = S.point ⟨0, hn⟩ := Subtype.ext heq
+      have hival := congrArg Fin.val (S.point.injective heq')
+      change i.val = 0 at hival
+      omega
+    have hne1 := native_index_one_excluded S hone _ (S.point i).property
+    have hindex : nativeMorseIndex E f (S.point i) = 2 := by omega
+    exact Or.inl ((nativeMorseIndex_eq_chart (S.data (S.point i)).chart).symm.trans hindex)
+  exact S.lower_circle_nullhomotopies_of_middle_indices hf hdim j hj hmiddle
+
+private def MorseCancel.zeroChainCycle {X : Type} [TopologicalSpace X] :
+    FirstHurewicz.Chains X 0 →ₗ[ℤ]
+      SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 0
+    where
+  toFun
+    z :=
+    SingularMayerVietoris.ModuleHomology.mkCycle (FirstHurewicz.singularComplex X) 0 z
+      (by
+        have h := (FirstHurewicz.singularComplex X).shape 0 0 (by simp)
+        exact congrArg (fun f => f.hom z) h)
+  map_add' _ _ := rfl
+  map_smul' _ _ := rfl
+
+private def MorseCancel.zeroChainClass {X : Type} [TopologicalSpace X] :
+    FirstHurewicz.Chains X 0 →ₗ[ℤ] SingularMayerVietoris.SingularHomology X 0 :=
+  (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 0).comp
+    zeroChainCycle
+
+private theorem MorseCancel.zeroChainClass_surjective {X : Type} [TopologicalSpace X] :
+    Function.Surjective (zeroChainClass (X := X)) := by
+  intro a
+  obtain ⟨c, rfl⟩ :=
+    SingularMayerVietoris.ModuleHomology.cycleClass_surjective (FirstHurewicz.singularComplex X) 0
+      a
+  exact ⟨c.val, rfl⟩
+
+private theorem MorseCancel.homologyZero_linearMap_ext {X : Type} [TopologicalSpace X] {A : Type}
+    [AddCommGroup A] [Module ℤ A] {L K : SingularMayerVietoris.SingularHomology X 0 →ₗ[ℤ] A}
+    (h :
+      ∀ x : X,
+        L (PeriodTorusHigherHomology.pointClass x) = K (PeriodTorusHigherHomology.pointClass x)) :
+    L = K := by
+  have heq : L.comp zeroChainClass = K.comp zeroChainClass := by
+    apply FirstHurewicz.chainMap_ext X 0
+    intro σ
+    have hσ : σ = ContinuousMap.const (FirstHurewicz.Simplex 0) (σ (stdSimplex.vertex 0)) := by
+      ext t
+      exact congrArg σ (FirstHurewicz.simplexZero_eq_vertex t)
+    rw [hσ]
+    exact h _
+  apply LinearMap.ext
+  intro a
+  obtain ⟨z, rfl⟩ := zeroChainClass_surjective a
+  exact LinearMap.congr_fun heq z
+
+private def
+    MorseCancel.cellDiskBoundaryHomologyMap {N X : Type} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    SingularMayerVietoris.SingularHomology (Metric.sphere (0 : N) 1) 0 →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology D.diskPatch 0 :=
+  SingularMayerVietoris.singularHomologyMap
+    ((ContinuousMap.inclusion Set.inter_subset_right).comp D.overlapSphereEquiv.toFun) 0
+
+private theorem MorseCancel.cell_oldHomologyMap_zero_iff {N X : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X)
+    (a : SingularMayerVietoris.SingularHomology D.old 0) :
+    D.oldHomologyMap 0 a = 0 ↔
+      ∃ z : SingularMayerVietoris.SingularHomology (Metric.sphere (0 : N) 1) 0,
+        D.attachingHomologyMap 0 z = a ∧ cellDiskBoundaryHomologyMap D z = 0 := by
+  constructor
+  · intro ha
+    have hp :
+      (D.oldHomologyEquiv 0 a, 0) ∈
+        LinearMap.ker (SingularMayerVietoris.rightHomologyMap D.oldNeighborhood D.diskPatch 0) := by
+      change
+        SingularMayerVietoris.rightHomologyMap D.oldNeighborhood D.diskPatch 0
+            (D.oldHomologyEquiv 0 a, 0) =
+          0
+      rw [D.coverRight_old]
+      exact ha
+    rw [←
+      SingularMayerVietoris.exact_at_pair D.oldNeighborhood D.diskPatch D.isOpen_oldNeighborhood
+        D.isOpen_diskPatch D.open_cover 0] at hp
+    obtain ⟨c, hc⟩ := hp
+    let z := (D.overlapHomologyEquiv 0).symm c
+    have hL :
+      SingularMayerVietoris.leftHomologyMap D.oldNeighborhood D.diskPatch 0
+          (D.overlapHomologyEquiv 0 z) =
+        (D.oldHomologyEquiv 0 a, 0) := by
+      dsimp [z]
+      rw [LinearEquiv.apply_symm_apply]
+      exact hc
+    refine ⟨z, ?_, ?_⟩
+    · rw [← D.coverLeft_old, hL, LinearEquiv.symm_apply_apply]
+    · have hs := congrArg Prod.snd hL
+      rw [SingularMayerVietoris.leftHomologyMap_apply] at hs
+      change SingularMayerVietoris.singularHomologyMap _ 0 z = 0
+      rw [PeriodTorusHigherHomology.singularHomologyMap_comp]
+      exact neg_eq_zero.mp hs
+  · rintro ⟨z, hza, hz⟩
+    have hL :
+      SingularMayerVietoris.leftHomologyMap D.oldNeighborhood D.diskPatch 0
+          (D.overlapHomologyEquiv 0 z) =
+        (D.oldHomologyEquiv 0 a, 0) := by
+      apply Prod.ext
+      · exact (D.oldHomologyEquiv 0).symm_apply_eq.mp ((D.coverLeft_old 0 z).trans hza)
+      · rw [SingularMayerVietoris.leftHomologyMap_apply]
+        rw [cellDiskBoundaryHomologyMap, PeriodTorusHigherHomology.singularHomologyMap_comp] at hz
+        exact neg_eq_zero.mpr hz
+    have hzero :=
+      LinearMap.congr_fun
+        (SingularMayerVietoris.leftHomologyMap_comp_right D.oldNeighborhood D.diskPatch 0)
+        (D.overlapHomologyEquiv 0 z)
+    change
+      SingularMayerVietoris.rightHomologyMap D.oldNeighborhood D.diskPatch 0
+          (SingularMayerVietoris.leftHomologyMap D.oldNeighborhood D.diskPatch 0
+            (D.overlapHomologyEquiv 0 z)) =
+        0 at hzero
+    rw [hL, D.coverRight_old] at hzero
+    exact hzero
+
+private theorem MorseCancel.cell_oldHomologyMap_injective_of_attaching_component {N X : Type}
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [TopologicalSpace X]
+    (D : Smale.EmbeddedCellAttachment N X) (p : D.old)
+    (hcomponent : ∀ u, Joined (D.attachingSphere u) p) :
+    Function.Injective (D.oldHomologyMap 0) := by
+  let c : C(D.diskPatch, D.old) := ContinuousMap.const _ p
+  have heq :
+    D.attachingHomologyMap 0 =
+      (SingularMayerVietoris.singularHomologyMap c 0).comp (cellDiskBoundaryHomologyMap D) := by
+    apply homologyZero_linearMap_ext
+    intro u
+    change
+      SingularMayerVietoris.singularHomologyMap D.attachingSphere 0
+          (PeriodTorusHigherHomology.pointClass u) =
+        SingularMayerVietoris.singularHomologyMap c 0
+          (SingularMayerVietoris.singularHomologyMap _ 0 (PeriodTorusHigherHomology.pointClass u))
+    rw [PeriodTorusHigherHomology.singularHomologyMap_pointClass,
+      PeriodTorusHigherHomology.singularHomologyMap_pointClass,
+      PeriodTorusHigherHomology.singularHomologyMap_pointClass]
+    exact (pointClass_eq_iff_joined _ _).mpr (hcomponent u)
+  apply LinearMap.ker_eq_bot.mp
+  apply LinearMap.ker_eq_bot'.mpr
+  intro a ha
+  obtain ⟨z, hza, hz⟩ := (cell_oldHomologyMap_zero_iff D a).mp ha
+  rw [← hza, heq, LinearMap.comp_apply, hz, map_zero]
+
+private theorem MorseCancel.cell_old_pathConnected_of_attaching_component {N X : Type}
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [TopologicalSpace X]
+    (D : Smale.EmbeddedCellAttachment N X) [PathConnectedSpace X] (p : D.old)
+    (hcomponent : ∀ u, Joined (D.attachingSphere u) p) : PathConnectedSpace D.old := by
+  let : Nonempty D.old := ⟨p⟩
+  exact
+    pathConnectedSpace_of_homologyZero_injective (SingularMayerVietoris.subtypeInclusion D.old)
+      (cell_oldHomologyMap_injective_of_attaching_component D p hcomponent)
+
+private theorem MorseCancel.native_lower_pathConnected_of_attaching_component {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (a : { z : M // f z ≤ f p - d.radius ^ 2 }) (hcomponent : ∀ u, Joined (d.coreBoundaryMap u) a)
+    [PathConnectedSpace { z : M // f z ≤ f p + d.radius ^ 2 }] :
+    PathConnectedSpace { z : M // f z ≤ f p - d.radius ^ 2 } := by
+  let : PathConnectedSpace ↥({z : M | f z ≤ f p - d.radius ^ 2} ∪ Set.range d.coreMap) :=
+    pathConnectedSpace_of_homotopyEquiv (d.coreUnionHomotopyEquiv hf)
+  let : PathConnectedSpace (d.coreCellPresentation hf).old :=
+    cell_old_pathConnected_of_attaching_component (d.coreCellPresentation hf)
+      (d.cellOldHomeomorph hf a)
+      (fun u => by
+        rw [d.coreCell_attaching_eq]
+        exact (hcomponent u).map (d.cellOldHomeomorph hf).continuous)
+  exact pathConnectedSpace_of_homotopyEquiv (d.cellOldHomeomorph hf).toHomotopyEquiv
+
+private theorem MorseCancel.native_attaching_component_of_pairwise_joined {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (hindex : 0 < Module.finrank ℝ d.chart.NegativeCoordinates)
+    (hjoined : ∀ u v, Joined (d.coreBoundaryMap u) (d.coreBoundaryMap v)) :
+    ∃ a : { z : M // f z ≤ f p - d.radius ^ 2 }, ∀ u, Joined (d.coreBoundaryMap u) a := by
+  let : Nontrivial d.chart.NegativeCoordinates := Module.nontrivial_of_finrank_pos hindex
+  obtain ⟨v, hv⟩ : (Metric.sphere (0 : d.chart.NegativeCoordinates) 1).Nonempty :=
+    NormedSpace.sphere_nonempty.mpr zero_le_one
+  exact ⟨d.coreBoundaryMap ⟨v, hv⟩, fun u => hjoined u ⟨v, hv⟩⟩
+
+private theorem MorseCancel.native_minimum_count_one_of_one_handle_components {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [PathConnectedSpace M] {f : M → ℝ} (S : Smale.ManifoldMorse.SurgeryWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hcomponents :
+      ∀ p : Smale.ManifoldMorse.criticalPoints E f,
+        nativeMorseIndex E f p = 1 →
+          ∃ a : { z : M // f z ≤ f p - (S.data p).radius ^ 2 },
+            ∀ u, Joined ((S.data p).coreBoundaryMap u) a) :
+    nativeMorseCount E f 0 = 1 := by
+  classical
+  have hn := S.count_pos hf
+  have hfirst : nativeMorseIndex E f (S.first hn) = 0 :=
+    (nativeMorseIndex_eq_chart (S.data (S.first hn)).chart).trans (S.first_index_zero hf hn)
+  let K : Finset (Fin S.count) :=
+    Finset.univ.filter (fun i => nativeMorseIndex E f (S.point i) = 0)
+  have hK : K.Nonempty := ⟨⟨0, hn⟩, Finset.mem_filter.mpr ⟨Finset.mem_univ _, hfirst⟩⟩
+  let j : Fin S.count := K.max' hK
+  have hjzero : nativeMorseIndex E f (S.point j) = 0 := (Finset.mem_filter.mp (K.max'_mem hK)).2
+  have hmax (i : Fin S.count) (hi : nativeMorseIndex E f (S.point i) = 0) : i ≤ j :=
+    K.le_max' i (Finset.mem_filter.mpr ⟨Finset.mem_univ _, hi⟩)
+  have htail (i : Fin S.count) (hji : j.val < i.val)
+    (hupper : PathConnectedSpace { x : M // f x ≤ S.upper (S.point i) }) :
+    PathConnectedSpace { x : M // f x ≤ S.lower (S.point i) } := by
+    let : PathConnectedSpace { x : M // f x ≤ f (S.point i) + (S.data (S.point i)).radius ^ 2 } :=
+      hupper
+    have hne : nativeMorseIndex E f (S.point i) ≠ 0 := by
+      intro hi
+      have hm : i.val ≤ j.val := hmax i hi
+      omega
+    have heq := nativeMorseIndex_eq_chart (S.data (S.point i)).chart
+    by_cases hone : nativeMorseIndex E f (S.point i) = 1
+    · obtain ⟨a, ha⟩ := hcomponents (S.point i) hone
+      exact
+        native_lower_pathConnected_of_attaching_component (S.data (S.point i)) hf.continuous a ha
+    · exact native_lower_pathConnected_of_upper (S.data (S.point i)) hf.continuous (by omega)
+  let : PathConnectedSpace { x : M // f x ≤ f (S.point j) + (S.data (S.point j)).radius ^ 2 } :=
+    ordered_upper_pathConnected_of_later_transfers S hf j htail
+  let : IsEmpty { x : M // f x ≤ f (S.point j) - (S.data (S.point j)).radius ^ 2 } :=
+    native_zero_handle_lower_isEmpty (S.data (S.point j)) hf.continuous
+      ((nativeMorseIndex_eq_chart (S.data (S.point j)).chart).symm.trans hjzero)
+  have hjfirst : j.val = 0 := by
+    by_contra hj
+    have hlt : (⟨0, hn⟩ : Fin S.count) < j := by change 0 < j.val; omega
+    have hbelow : f (S.first hn) ≤ S.lower (S.point j) :=
+      (S.value_lt_upper (S.first hn)).le.trans (S.ordered_windows _ _ hlt).le
+    exact
+      isEmptyElim
+        (⟨S.first hn, hbelow⟩ :
+          { x : M // f x ≤ f (S.point j) - (S.data (S.point j)).radius ^ 2 })
+  have hset :
+    {x : M | x ∈ Smale.ManifoldMorse.criticalPoints E f ∧ nativeMorseIndex E f x = 0} =
+      {(S.first hn).val} := by
+    ext x
+    constructor
+    · rintro ⟨hx, hi⟩
+      obtain ⟨i, he⟩ := S.point.surjective ⟨x, hx⟩
+      have hi0 : nativeMorseIndex E f (S.point i) = 0 := by simpa only [he] using hi
+      have hle : i.val ≤ j.val := hmax i hi0
+      have hi0' : i.val = 0 := by omega
+      have hip : S.point i = S.first hn := congrArg S.point (Fin.ext hi0')
+      exact Set.mem_singleton_iff.mpr (congrArg Subtype.val (he.symm.trans hip))
+    · intro hx
+      rw [Set.mem_singleton_iff] at hx
+      exact hx ▸ ⟨(S.first hn).property, hfirst⟩
+  exact Set.ncard_eq_one.mpr ⟨(S.first hn).val, hset⟩
+
+private theorem MorseCancel.exists_native_one_handle_joining_components {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [PathConnectedSpace M] {f : M → ℝ} (S : Smale.ManifoldMorse.SurgeryWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hmin : nativeMorseCount E f 0 ≠ 1) :
+    ∃ p : Smale.ManifoldMorse.criticalPoints E f,
+      nativeMorseIndex E f p = 1 ∧
+        ∃ u v, ¬Joined ((S.data p).coreBoundaryMap u) ((S.data p).coreBoundaryMap v) := by
+  classical
+  by_contra h
+  apply hmin
+  apply native_minimum_count_one_of_one_handle_components S hf
+  intro p hp
+  have hindex : 0 < Module.finrank ℝ (S.data p).chart.NegativeCoordinates := by
+    rw [← nativeMorseIndex_eq_chart (S.data p).chart, hp]
+    exact zero_lt_one
+  apply native_attaching_component_of_pairwise_joined (S.data p) hindex
+  intro u v
+  by_contra huv
+  exact h ⟨p, hp, u, v, huv⟩
+
+private theorem MorseCancel.cancel_realized_higher_minimum {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PathConnectedSpace M] {f₀ : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f₀) (hf₀ : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f₀)
+    (hm₀ : Smale.ManifoldMorse.IsMorse E f₀) {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (G : Flow ℝ M) (hG : ∀ x, IsMIntegralCurve (fun t => G t x) V)
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f₀, V x = 0)
+    (hdesc₀ : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f₀ → mvfderiv 𝓘(ℝ, E) f₀ x (V x) < 0)
+    (hmodels₀ :
+      ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f₀,
+        ∃ c : Smale.ManifoldMorse.SignedMorseChart (E := E) f₀ x,
+          ∀ᶠ y in 𝓝 x, V y = c.descentField y)
+    (p r q : Smale.ManifoldMorse.criticalPoints E f₀) (hpzero : nativeMorseIndex E f₀ p = 0)
+    (hqone : nativeMorseIndex E f₀ q = 1) (hrp : f₀ r < f₀ p) (hp : f₀ p < S.lower q)
+    (u v : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (hback :
+      ∀ x : (S.data q).LowerLevel,
+        Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 q.val) ↔
+          x ∈ Set.range (S.data q).surgery.attachingSphere)
+    (hu :
+      Filter.Tendsto (fun t => G t ((S.data q).surgery.attachingSphere u).val) Filter.atTop
+        (𝓝 p.val))
+    (hv :
+      Filter.Tendsto (fun t => G t ((S.data q).surgery.attachingSphere v).val) Filter.atTop
+        (𝓝 r.val))
+    (hnoconnection :
+      ∀ j : Smale.ManifoldMorse.criticalPoints E f₀,
+        j ≠ q →
+          j ≠ p →
+            j ≠ r →
+              ∀ x,
+                ¬(Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 q.val) ∧
+                    Filter.Tendsto (fun t => G t x) Filter.atTop (𝓝 j.val))) :
+    ∃ g : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+        Smale.ManifoldMorse.IsMorse E g ∧
+          Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) ∧
+            (Smale.ManifoldMorse.criticalPoints E g).ncard + 2 =
+              (Smale.ManifoldMorse.criticalPoints E f₀).ncard := by
+  have hpr : p ≠ r := fun h => (ne_of_lt hrp) (congrArg (fun x => f₀ x.val) h).symm
+  obtain ⟨hzback, hunique⟩ :=
+    unique_connection_of_distinct_minimum_branches S hf₀.continuous G p r q hqone hpr hp u v hback
+      hu hv
+  obtain ⟨f, hf, hm, hcrit, hinj, -, -, hpq, hconsecutive, hdesc, hmodels, hindices⟩ :=
+    exists_flow_preserving_consecutive_pair hf₀ hm₀ S.distinct hV G hG hzero hdesc₀ hmodels₀ p r q
+      hrp (hp.trans (S.lower_lt_value q)) hnoconnection
+  let pf : Smale.ManifoldMorse.criticalPoints E f := ⟨p.val, by rw [hcrit]; exact p.property⟩
+  let qf : Smale.ManifoldMorse.criticalPoints E f := ⟨q.val, by rw [hcrit]; exact q.property⟩
+  have hconsecutivef : ∀ z : Smale.ManifoldMorse.criticalPoints E f, ¬(f pf < f z ∧ f z < f qf) :=
+    by
+    intro z hz
+    exact hconsecutive ⟨z.val, by rw [← hcrit]; exact z.property⟩ hz
+  obtain ⟨T⟩ := Smale.ManifoldMorse.nonempty_surgeryWindows hf hm hinj
+  obtain ⟨cp, hcp⟩ := hmodels pf pf.property
+  obtain ⟨cq, hcq⟩ := hmodels qf qf.property
+  obtain ⟨g, hg, hmg, hcard, hcritg, hexterior⟩ :=
+    cancel_unique_zero_one_connection cp cq hf hm ((hindices p p.property).trans hpzero)
+      ((hindices q q.property).trans hqone) hV G hG (fun x hx => hzero x (hcrit ▸ hx)) hdesc hinj
+      pf.property qf.property hpq (T.lower_lt_value pf) (T.value_lt_upper qf)
+      (surgery_pair_band_isolation T pf qf hconsecutivef) hu hzback hunique hcp hcq
+  have hkeep :=
+    surviving_critical_germs_of_pair_band (surgery_pair_band_isolation T pf qf hconsecutivef)
+      hcritg hexterior
+  have hinjg :=
+    distinct_critical_values_of_surviving_germs hinj (fun x hx => ((hcritg x).mp hx).1) hkeep
+  exact ⟨g, hg, hmg, hinjg, hcard.trans (congrArg Set.ncard hcrit)⟩
+
+private theorem MorseCancel.exists_excellent_morse_reduction_of_multiple_minima {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [PathConnectedSpace M] {f₀ : M → ℝ} (S : AdaptedWindows E f₀)
+    (hf₀ : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f₀) (hm₀ : Smale.ManifoldMorse.IsMorse E f₀)
+    (hmin : nativeMorseCount E f₀ 0 ≠ 1) :
+    ∃ g : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+        Smale.ManifoldMorse.IsMorse E g ∧
+          Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) ∧
+            (Smale.ManifoldMorse.criticalPoints E g).ncard + 2 =
+              (Smale.ManifoldMorse.criticalPoints E f₀).ncard := by
+  obtain ⟨q, hqone, u, v, hnot⟩ :=
+    exists_native_one_handle_joining_components S.toSurgeryWindows hf₀ hmin
+  obtain
+    ⟨V, G, p, r, hV, hG, hzero, hdesc, hgerms, hpzero, hrzero, hpr, hp, hr, hback, hu, hv, -,
+      hnoconnection⟩ :=
+    S.realize_one_handle_minimum_branches hf₀ q hqone u v hnot
+  have hmodels (x : M) (hx : x ∈ Smale.ManifoldMorse.criticalPoints E f₀) :
+    ∃ c : Smale.ManifoldMorse.SignedMorseChart (E := E) f₀ x,
+      ∀ᶠ y in 𝓝 x, V y = c.descentField y := by
+    refine ⟨(S.data ⟨x, hx⟩).chart, ?_⟩
+    filter_upwards [hgerms x hx, S.critical_model_germ ⟨x, hx⟩] with y h₁ h₂
+    exact h₁.trans h₂
+  have hne : f₀ p ≠ f₀ r := fun h => hpr (Subtype.ext (S.distinct p.property r.property h))
+  rcases lt_or_gt_of_ne hne with hlt | hgt
+  · exact
+      cancel_realized_higher_minimum S.toSurgeryWindows hf₀ hm₀ hV G hG hzero hdesc hmodels r p q
+        hrzero hqone hlt hr v u hback hv hu (fun j hjq hjr hjp => hnoconnection j hjq hjp hjr)
+  · exact
+      cancel_realized_higher_minimum S.toSurgeryWindows hf₀ hm₀ hV G hG hzero hdesc hmodels p r q
+        hpzero hqone hgt hp u v hback hu hv hnoconnection
+
+private theorem MorseCancel.isMorseAt_neg {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (hm : Smale.ManifoldMorse.IsMorseAt E f p) :
+    Smale.ManifoldMorse.IsMorseAt E (fun x => -f x) p := by
+  obtain ⟨e, he, hp, hregular | hH⟩ := hm
+  · refine ⟨e, he, hp, Or.inl ?_⟩
+    change fderiv ℝ (fun x => -f (e.symm x)) (e p) ≠ 0
+    rw [fderiv_fun_neg, neg_ne_zero]
+    exact hregular
+  · refine ⟨e, he, hp, Or.inr ?_⟩
+    have hd : fderiv ℝ ((fun x => -f x) ∘ e.symm) = fun z => -fderiv ℝ (f ∘ e.symm) z := by
+      funext z
+      exact fderiv_fun_neg
+    rw [hd, fderiv_fun_neg]
+    change Function.Bijective (fun v => -(fderiv ℝ (fderiv ℝ (f ∘ e.symm)) (e p) v))
+    exact neg_bijective.comp hH
+
+private theorem MorseCancel.isMorse_neg {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} (hm : Smale.ManifoldMorse.IsMorse E f) :
+    Smale.ManifoldMorse.IsMorse E (fun x => -f x) := fun x => isMorseAt_neg (hm x)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.negative_finrank_neg_chart {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) :
+    Module.finrank ℝ c.neg.NegativeCoordinates = Module.finrank ℝ c.PositiveCoordinates := by
+  simp only [Smale.ManifoldMorse.SignedMorseChart.NegativeCoordinates,
+    Smale.ManifoldMorse.SignedMorseChart.PositiveCoordinates, Smale.MorseHandle.NegativeSpace,
+    Smale.MorseHandle.PositiveSpace, finrank_euclideanSpace]
+  apply Fintype.card_congr
+  apply Equiv.subtypeEquivRight
+  intro i
+  change -c.weights i = -1 ↔ c.weights i ≠ -1
+  rcases c.signs i with h | h <;> norm_num [h]
+
+private theorem MorseCancel.nativeMorseIndex_neg_add {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) :
+    nativeMorseIndex E (fun x => -f x) p + nativeMorseIndex E f p = Module.finrank ℝ E := by
+  rw [nativeMorseIndex_eq_chart c.neg, nativeMorseIndex_eq_chart c, negative_finrank_neg_chart]
+  exact (Nat.add_comm _ _).trans c.finrank_negative_add_positive
+
+private theorem
+    MorseCancel.nativeMorseCount_neg {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} [FiniteDimensional ℝ E]
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f) {k : ℕ}
+    (hk : k ≤ Module.finrank ℝ E) :
+    nativeMorseCount E (fun x => -f x) (Module.finrank ℝ E - k) = nativeMorseCount E f k := by
+  unfold nativeMorseCount
+  congr 1
+  ext z
+  rw [Smale.ManifoldMorse.criticalPoints_neg]
+  change
+    (z ∈ Smale.ManifoldMorse.criticalPoints E f ∧
+        nativeMorseIndex E (fun x => -f x) z = Module.finrank ℝ E - k) ↔
+      (z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ nativeMorseIndex E f z = k)
+  constructor
+  · rintro ⟨hz, hi⟩
+    obtain ⟨c⟩ := Smale.ManifoldMorse.nonempty_signedMorseChart hf hm z hz
+    have hsum := nativeMorseIndex_neg_add c
+    exact ⟨hz, by omega⟩
+  · rintro ⟨hz, hi⟩
+    obtain ⟨c⟩ := Smale.ManifoldMorse.nonempty_signedMorseChart hf hm z hz
+    have hsum := nativeMorseIndex_neg_add c
+    exact ⟨hz, by omega⟩
+
+private theorem MorseCancel.exists_minimal_excellent_morse_system (E : Type*) (M : Type*)
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] :
+    ∃ f : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f ∧
+        Smale.ManifoldMorse.IsMorse E f ∧
+          ∃ _ : AdaptedWindows E f,
+            ∀ g : M → ℝ,
+              ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g →
+                Smale.ManifoldMorse.IsMorse E g →
+                  Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) →
+                    (Smale.ManifoldMorse.criticalPoints E f).ncard ≤
+                      (Smale.ManifoldMorse.criticalPoints E g).ncard := by
+  classical
+  let P : ℕ → Prop := fun n =>
+    ∃ f : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f ∧
+        Smale.ManifoldMorse.IsMorse E f ∧
+          Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f) ∧
+            (Smale.ManifoldMorse.criticalPoints E f).ncard = n
+  obtain ⟨f₀, hf₀, hm₀, -, hinj₀⟩ :=
+    Smale.ManifoldMorse.exists_morse_function_with_distinct_critical_values E M
+  have hex : ∃ n, P n :=
+    ⟨(Smale.ManifoldMorse.criticalPoints E f₀).ncard, f₀, hf₀, hm₀, hinj₀, rfl⟩
+  obtain ⟨f, hf, hm, hinj, hcard⟩ := Nat.find_spec hex
+  obtain ⟨S⟩ := nonempty_adaptedSurgeryWindows hf hm hinj
+  refine ⟨f, hf, hm, S, ?_⟩
+  intro g hg hmg hinjg
+  rw [hcard]
+  exact Nat.find_min' hex ⟨g, hg, hmg, hinjg, rfl⟩
+
+private theorem MorseCancel.minimal_excellent_morse_forbids_pair_removal {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] {f g : M → ℝ}
+    (hminimal :
+      ∀ h : M → ℝ,
+        ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ h →
+          Smale.ManifoldMorse.IsMorse E h →
+            Set.InjOn h (Smale.ManifoldMorse.criticalPoints E h) →
+              (Smale.ManifoldMorse.criticalPoints E f).ncard ≤
+                (Smale.ManifoldMorse.criticalPoints E h).ncard)
+    (hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g) (hmg : Smale.ManifoldMorse.IsMorse E g)
+    (hinjg : Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g)) :
+    (Smale.ManifoldMorse.criticalPoints E g).ncard + 2 ≠
+      (Smale.ManifoldMorse.criticalPoints E f).ncard := by
+  have hle := hminimal g hg hmg hinjg
+  omega
+
+private theorem MorseCancel.distinct_critical_values_neg {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f)) :
+    Set.InjOn (fun x => -f x) (Smale.ManifoldMorse.criticalPoints E (fun x => -f x)) := by
+  rw [Smale.ManifoldMorse.criticalPoints_neg]
+  intro x hx y hy hxy
+  exact hinj hx hy (neg_injective hxy)
+
+private theorem MorseCancel.minimal_excellent_morse_neg {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (hminimal :
+      ∀ g : M → ℝ,
+        ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g →
+          Smale.ManifoldMorse.IsMorse E g →
+            Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) →
+              (Smale.ManifoldMorse.criticalPoints E f).ncard ≤
+                (Smale.ManifoldMorse.criticalPoints E g).ncard) :
+    ∀ g : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g →
+        Smale.ManifoldMorse.IsMorse E g →
+          Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) →
+            (Smale.ManifoldMorse.criticalPoints E (fun x => -f x)).ncard ≤
+              (Smale.ManifoldMorse.criticalPoints E g).ncard := by
+  intro g hg hmg hinjg
+  have hh :=
+    hminimal (fun x => -g x) hg.neg (isMorse_neg hmg) (distinct_critical_values_neg hinjg)
+  simpa only [Smale.ManifoldMorse.criticalPoints_neg] using hh
+
+private theorem
+    Smale.FiniteSignedCancellation.opposite_signs_distinct {a b : SignType} (h : a * b = -1) :
+    a ≠ b := by cases a <;> cases b <;> simp_all
+
+private theorem Smale.FiniteSignedCancellation.cast_add_eq_zero_of_opposite {a b : SignType}
+    (h : a * b = -1) : (a : ℤ) + (b : ℤ) = 0 := by cases a <;> cases b <;> simp_all
+
+private theorem
+    Smale.FiniteSignedCancellation.sum_sdiff_pair {X : Type*} [DecidableEq X] (s : Finset X)
+    (σ : X → SignType) {x y : X} (hx : x ∈ s) (hy : y ∈ s) (hxy : σ x * σ y = -1) :
+    ∑ z ∈ s \ { x, y }, (σ z : ℤ) = ∑ z ∈ s, (σ z : ℤ) := by
+  classical
+  have hne : x ≠ y := fun h => opposite_signs_distinct hxy (congrArg σ h)
+  have hsub : ({ x, y } : Finset X) ⊆ s := by
+    intro z hz
+    rcases Finset.mem_insert.mp hz with rfl | hz
+    · exact hx
+    · exact Finset.mem_singleton.mp hz ▸ hy
+  have hsum : ∑ z ∈ ({ x, y } : Finset X), (σ z : ℤ) = 0 := by
+    rw [Finset.sum_pair hne]
+    exact cast_add_eq_zero_of_opposite hxy
+  have h := Finset.sum_sdiff (f := fun z => (σ z : ℤ)) hsub
+  simpa only [hsum, add_zero] using h
+
+private theorem Smale.FiniteSignedCancellation.sum_sdiff_pair_of_eq {X : Type*} [DecidableEq X]
+    (s : Finset X) (σ τ : X → SignType) {x y : X} (hx : x ∈ s) (hy : y ∈ s) (hxy : σ x * σ y = -1)
+    (heq : ∀ z ∈ s \ { x, y }, τ z = σ z) : ∑ z ∈ s \ { x, y }, (τ z : ℤ) = ∑ z ∈ s, (σ z : ℤ) := by
+  calc
+    _ = ∑ z ∈ s \ { x, y }, (σ z : ℤ) :=
+      Finset.sum_congr rfl (fun z hz => congrArg (fun a : SignType => (a : ℤ)) (heq z hz))
+    _ = _ := sum_sdiff_pair s σ hx hy hxy
+
+private theorem Smale.FiniteSignedCancellation.card_eq_natAbs_sum_of_no_opposite {X : Type*}
+    (s : Finset X) (σ : X → SignType) (hunit : ∀ x ∈ s, σ x = 1 ∨ σ x = -1)
+    (hno : ∀ x ∈ s, ∀ y ∈ s, σ x * σ y ≠ -1) : s.card = (∑ x ∈ s, (σ x : ℤ)).natAbs := by
+  classical
+  rcases s.eq_empty_or_nonempty with rfl | ⟨x, hx⟩
+  · simp
+  have heq (y : X) (hy : y ∈ s) : σ y = σ x := by
+    rcases hunit x hx with hxp | hxn <;> rcases hunit y hy with hyp | hyn
+    · exact hyp.trans hxp.symm
+    · exact (hno x hx y hy (by rw [hxp, hyn]; simp)).elim
+    · exact (hno x hx y hy (by rw [hxn, hyp]; simp)).elim
+    · exact hyn.trans hxn.symm
+  have hsum : (∑ y ∈ s, (σ y : ℤ)) = ∑ _ ∈ s, (σ x : ℤ) := by
+    apply Finset.sum_congr rfl
+    intro y hy
+    rw [heq y hy]
+  rw [hsum]
+  rcases hunit x hx with hp | hn
+  · simp [hp]
+  · simp [hn]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.exists_finite_belt_cancellation_step {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} {p : M}
+    (D : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (hindex : Module.finrank ℝ D.chart.NegativeCoordinates = 2)
+    (hnull :
+      ∀ γ : C(Smale.Hemisphere.Sphere 1, D.LowerLevel),
+        ∃ q, γ.Homotopic (ContinuousMap.const _ q))
+    (r : (ℝ × D.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient 3)
+    (P : Finset (Smale.Hemisphere.Sphere 2)) (g : C(Smale.Hemisphere.Sphere 2, D.UpperLevel))
+    (hP : (P : Set (Smale.Hemisphere.Sphere 2)) = D.beltIntersectionPoints 2 g)
+    (hgood : D.IsTransverseBeltSphere hf hdim hindex g) (x y : Smale.Hemisphere.Sphere 2)
+    (hx : x ∈ P) (hy : y ∈ P)
+    (hxy : D.beltIntersectionSign 2 r g x * D.beltIntersectionSign 2 r g y = -1) :
+    letI := Smale.RegularLevel.chartedSpace hf D.upper_regular
+    ∃ e :
+      Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E) D.UpperLevel
+        D.UpperLevel ∞,
+      ∃ g' : C(Smale.Hemisphere.Sphere 2, D.UpperLevel),
+        Smale.SupportedDiffeomorph.IsotopicToIdentity e ∧
+          (∀ z, g' z = e (g z)) ∧
+            D.IsTransverseBeltSphere hf hdim hindex g' ∧
+              ((P \ { x, y } : Finset (Smale.Hemisphere.Sphere 2)) :
+                    Set (Smale.Hemisphere.Sphere 2)) =
+                  D.beltIntersectionPoints 2 g' ∧
+                (∀ z ∈ P \ { x, y }, (g' : Smale.Hemisphere.Sphere 2 → D.UpperLevel) =ᶠ[𝓝 z] g) ∧
+                  (∑ z ∈ P \ { x, y }, (D.beltIntersectionSign 2 r g' z : ℤ)) =
+                    ∑ z ∈ P, (D.beltIntersectionSign 2 r g z : ℤ) := by
+  let _ := Smale.RegularLevel.chartedSpace hf D.upper_regular
+  let _ : Fact (Module.finrank ℝ D.chart.PositiveCoordinates = 3 + 1) :=
+    ⟨by have hh := D.chart.finrank_negative_add_positive; omega⟩
+  obtain ⟨hg, hinj, hi, ht⟩ := hgood
+  have hxB : x ∈ D.beltIntersectionPoints 2 g := hP ▸ hx
+  have hyB : y ∈ D.beltIntersectionPoints 2 g := hP ▸ hy
+  obtain ⟨e, g', hiso, heq, hg', hinj', hi', ht', hpoints, hgerm, hsign⟩ :=
+    D.exists_signed_belt_cancellation_step hf hdim hindex hnull r g hg hinj hi ht x y hxB hyB hxy
+  have hP' :
+    ((P \ { x, y } : Finset (Smale.Hemisphere.Sphere 2)) : Set (Smale.Hemisphere.Sphere 2)) =
+      D.beltIntersectionPoints 2 g' := by
+    rw [hpoints, ← hP]
+    simp only [Finset.coe_sdiff, Finset.coe_insert, Finset.coe_singleton]
+  have hmem (z : Smale.Hemisphere.Sphere 2) (hz : z ∈ P \ { x, y }) :
+    z ∈ D.beltIntersectionPoints 2 g' := hP' ▸ hz
+  refine ⟨e, g', hiso, heq, ⟨hg', hinj', hi', ht'⟩, hP', ?_, ?_⟩
+  · exact fun z hz => hgerm z (hmem z hz)
+  · exact
+      Smale.FiniteSignedCancellation.sum_sdiff_pair_of_eq P (D.beltIntersectionSign 2 r g)
+        (D.beltIntersectionSign 2 r g') (x := x) (y := y) hx hy hxy
+        (fun z hz => hsign z (hmem z hz))
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.exists_finite_belt_reduction {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} {p : M}
+    (D : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (hindex : Module.finrank ℝ D.chart.NegativeCoordinates = 2)
+    (hnull :
+      ∀ γ : C(Smale.Hemisphere.Sphere 1, D.LowerLevel),
+        ∃ q, γ.Homotopic (ContinuousMap.const _ q))
+    (r : (ℝ × D.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient 3)
+    (P : Finset (Smale.Hemisphere.Sphere 2)) (g : C(Smale.Hemisphere.Sphere 2, D.UpperLevel))
+    (hP : (P : Set (Smale.Hemisphere.Sphere 2)) = D.beltIntersectionPoints 2 g)
+    (hgood : D.IsTransverseBeltSphere hf hdim hindex g) :
+    letI := Smale.RegularLevel.chartedSpace hf D.upper_regular
+    ∃ e :
+      Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E) D.UpperLevel
+        D.UpperLevel ∞,
+      ∃ g' : C(Smale.Hemisphere.Sphere 2, D.UpperLevel),
+        ∃ P' : Finset (Smale.Hemisphere.Sphere 2),
+          Smale.SupportedDiffeomorph.IsotopicToIdentity e ∧
+            (∀ x, g' x = e (g x)) ∧
+              D.IsTransverseBeltSphere hf hdim hindex g' ∧
+                (P' : Set (Smale.Hemisphere.Sphere 2)) = D.beltIntersectionPoints 2 g' ∧
+                  P' ⊆ P ∧
+                    (∀ x ∈ P', (g' : Smale.Hemisphere.Sphere 2 → D.UpperLevel) =ᶠ[𝓝 x] g) ∧
+                      (∑ x ∈ P', (D.beltIntersectionSign 2 r g' x : ℤ)) =
+                          ∑ x ∈ P, (D.beltIntersectionSign 2 r g x : ℤ) ∧
+                        ∀ x ∈ P',
+                          ∀ y ∈ P',
+                            D.beltIntersectionSign 2 r g' x * D.beltIntersectionSign 2 r g' y ≠
+                              -1 := by
+  let _ := Smale.RegularLevel.chartedSpace hf D.upper_regular
+  induction P using Finset.strongInductionOn generalizing g with
+  | _ P
+    ih =>
+    by_cases hpair :
+      ∃ x ∈ P, ∃ y ∈ P, D.beltIntersectionSign 2 r g x * D.beltIntersectionSign 2 r g y = -1
+    · obtain ⟨x, hx, y, hy, hxy⟩ := hpair
+      obtain ⟨e₁, g₁, hiso₁, heq₁, hgood₁, hR, hgerm₁, hsum₁⟩ :=
+        D.exists_finite_belt_cancellation_step hf hdim hindex hnull r P g hP hgood x y hx hy hxy
+      let R : Finset (Smale.Hemisphere.Sphere 2) := P \ { x, y }
+      have hsubpair : ({ x, y } : Finset (Smale.Hemisphere.Sphere 2)) ⊆ P := by
+        intro z hz
+        rcases Finset.mem_insert.mp hz with rfl | hz
+        · exact hx
+        · exact Finset.mem_singleton.mp hz ▸ hy
+      have hRlt : R ⊂ P := Finset.sdiff_ssubset hsubpair ⟨x, by simp⟩
+      obtain ⟨e₂, g₂, P₂, hiso₂, heq₂, hgood₂, hP₂, hsub₂, hgerm₂, hsum₂, hno₂⟩ :=
+        ih R hRlt g₁ hR hgood₁
+      refine
+        ⟨e₁.trans e₂, g₂, P₂, hiso₁.trans hiso₂, ?_, hgood₂, hP₂, hsub₂.trans Finset.sdiff_subset,
+          ?_, hsum₂.trans hsum₁, hno₂⟩
+      · intro z
+        change g₂ z = e₂ (e₁ (g z))
+        rw [heq₂, heq₁]
+      · intro z hz
+        exact (hgerm₂ z hz).trans (hgerm₁ z (hsub₂ hz))
+    · refine
+        ⟨Diffeomorph.refl _ _ _, g, P, Smale.SupportedDiffeomorph.isotopicToIdentity_refl,
+          fun _ => rfl, hgood, hP, fun _ hx => hx, fun _ _ => Filter.EventuallyEq.refl _ _, rfl,
+          ?_⟩
+      intro x hx y hy hxy
+      exact hpair ⟨x, hx, y, hy, hxy⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.exists_minimal_signed_belt_sphere {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} {p : M}
+    (D : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (hindex : Module.finrank ℝ D.chart.NegativeCoordinates = 2)
+    (hnull :
+      ∀ γ : C(Smale.Hemisphere.Sphere 1, D.LowerLevel),
+        ∃ q, γ.Homotopic (ContinuousMap.const _ q))
+    (r : (ℝ × D.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient 3)
+    (g : C(Smale.Hemisphere.Sphere 2, D.UpperLevel))
+    (hgood : D.IsTransverseBeltSphere hf hdim hindex g) :
+    letI := Smale.RegularLevel.chartedSpace hf D.upper_regular
+    ∃ e :
+      Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E) D.UpperLevel
+        D.UpperLevel ∞,
+      ∃ g' : C(Smale.Hemisphere.Sphere 2, D.UpperLevel),
+        Smale.SupportedDiffeomorph.IsotopicToIdentity e ∧
+          (∀ x, g' x = e (g x)) ∧
+            D.IsTransverseBeltSphere hf hdim hindex g' ∧
+              D.beltIntersectionPoints 2 g' ⊆ D.beltIntersectionPoints 2 g ∧
+                (∀ x ∈ D.beltIntersectionPoints 2 g',
+                    (g' : Smale.Hemisphere.Sphere 2 → D.UpperLevel) =ᶠ[𝓝 x] g) ∧
+                  (∀ hfin' : (D.beltIntersectionPoints 2 g').Finite,
+                      D.beltIntersectionCount 2 r g' hfin' =
+                        D.beltIntersectionCount 2 r g
+                          (D.finite_points_of_isTransverseBeltSphere hf hdim hindex hgood)) ∧
+                    (D.beltIntersectionPoints 2 g').ncard =
+                      (D.beltIntersectionCount 2 r g
+                          (D.finite_points_of_isTransverseBeltSphere hf hdim hindex
+                            hgood)).natAbs := by
+  let _ := Smale.RegularLevel.chartedSpace hf D.upper_regular
+  let _ : Fact (Module.finrank ℝ D.chart.PositiveCoordinates = 3 + 1) :=
+    ⟨by have hh := D.chart.finrank_negative_add_positive; omega⟩
+  let hfin := D.finite_points_of_isTransverseBeltSphere hf hdim hindex hgood
+  obtain ⟨e, g', P', hiso, heq, hgood', hP', hsub, hgerm, hsum, hno⟩ :=
+    D.exists_finite_belt_reduction hf hdim hindex hnull r hfin.toFinset g hfin.coe_toFinset hgood
+  have hunit :
+    ∀ x ∈ P', D.beltIntersectionSign 2 r g' x = 1 ∨ D.beltIntersectionSign 2 r g' x = -1 := by
+    obtain ⟨hg', _, _, ht'⟩ := hgood'
+    intro x hx
+    exact D.beltIntersectionSign_unit hf 3 2 hindex r g' hg' ht' x (hP' ▸ hx)
+  have hmem (x : Smale.Hemisphere.Sphere 2) (hx : x ∈ D.beltIntersectionPoints 2 g') : x ∈ P' := by
+    change x ∈ (P' : Set (Smale.Hemisphere.Sphere 2))
+    rw [hP']
+    exact hx
+  refine ⟨e, g', hiso, heq, hgood', ?_, ?_, ?_, ?_⟩
+  · intro x hx
+    have hxP : x ∈ P' := hmem x hx
+    exact hfin.mem_toFinset.mp (hsub hxP)
+  · intro x hx
+    exact hgerm x (hmem x hx)
+  · intro hfin'
+    have hPfin : hfin'.toFinset = P' := by
+      apply Finset.coe_injective
+      exact hfin'.coe_toFinset.trans hP'.symm
+    change (∑ x ∈ hfin'.toFinset, (D.beltIntersectionSign 2 r g' x : ℤ)) = _
+    rw [hPfin]
+    exact hsum
+  · calc
+      (D.beltIntersectionPoints 2 g').ncard = P'.card := by rw [← hP', Set.ncard_coe_finset]
+      _ = (∑ x ∈ P', (D.beltIntersectionSign 2 r g' x : ℤ)).natAbs :=
+        (Smale.FiniteSignedCancellation.card_eq_natAbs_sum_of_no_opposite P'
+          (D.beltIntersectionSign 2 r g') hunit hno)
+      _ = _ := congrArg Int.natAbs hsum
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.exists_single_belt_intersection_of_unit_count
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    {f : M → ℝ} {p : M} (D : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hdim : Module.finrank ℝ E = 6)
+    (hindex : Module.finrank ℝ D.chart.NegativeCoordinates = 2)
+    (hnull :
+      ∀ γ : C(Smale.Hemisphere.Sphere 1, D.LowerLevel),
+        ∃ q, γ.Homotopic (ContinuousMap.const _ q))
+    (r : (ℝ × D.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient 3)
+    (g : C(Smale.Hemisphere.Sphere 2, D.UpperLevel))
+    (hgood : D.IsTransverseBeltSphere hf hdim hindex g)
+    (hcount :
+      (D.beltIntersectionCount 2 r g
+            (D.finite_points_of_isTransverseBeltSphere hf hdim hindex hgood)).natAbs =
+        1) :
+    letI := Smale.RegularLevel.chartedSpace hf D.upper_regular
+    ∃ e :
+      Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E) D.UpperLevel
+        D.UpperLevel ∞,
+      ∃ g' : C(Smale.Hemisphere.Sphere 2, D.UpperLevel),
+        ∃ x : Smale.Hemisphere.Sphere 2,
+          Smale.SupportedDiffeomorph.IsotopicToIdentity e ∧
+            (∀ y, g' y = e (g y)) ∧
+              D.IsTransverseBeltSphere hf hdim hindex g' ∧
+                D.beltIntersectionPoints 2 g' = { x } ∧
+                  Set.range g' ∩ Set.range D.surgery.beltSphere = {g' x} := by
+  let _ := Smale.RegularLevel.chartedSpace hf D.upper_regular
+  obtain ⟨e, g', hiso, heq, hgood', _, _, _, hsize⟩ :=
+    D.exists_minimal_signed_belt_sphere hf hdim hindex hnull r g hgood
+  have hone : (D.beltIntersectionPoints 2 g').ncard = 1 := hsize.trans hcount
+  obtain ⟨x, hx⟩ := Set.ncard_eq_one.mp hone
+  refine ⟨e, g', x, hiso, heq, hgood', hx, ?_⟩
+  have himage :
+    g' '' D.beltIntersectionPoints 2 g' = Set.range g' ∩ Set.range D.surgery.beltSphere := by
+    change g' '' (g' ⁻¹' Set.range D.surgery.beltSphere) = _
+    rw [Set.image_preimage_eq_inter_range, Set.inter_comm]
+  rw [← himage, hx, Set.image_singleton]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem AdaptedWindows.remove_connections_of_index_le {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p q : Smale.ManifoldMorse.criticalPoints E f)
+    (hpq : f p < f q)
+    (hconsecutive : ∀ r : Smale.ManifoldMorse.criticalPoints E f, ¬(f p < f r ∧ f r < f q))
+    (n m : ℕ) (hqindex : Module.finrank ℝ (S.data q).chart.NegativeCoordinates = n + 1)
+    (hppos : Module.finrank ℝ (S.data p).chart.PositiveCoordinates = m + 1)
+    (hle :
+      Module.finrank ℝ (S.data q).chart.NegativeCoordinates ≤
+        Module.finrank ℝ (S.data p).chart.NegativeCoordinates) :
+    ∃ (V : (z : M) → TangentSpace 𝓘(ℝ, E) z) (G : Flow ℝ M),
+      ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun z => (⟨z, V z⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+        (∀ z, IsMIntegralCurve (fun t => G t z) V) ∧
+          (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, V z = 0) ∧
+            (∀ z, z ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f z (V z) < 0) ∧
+              (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ y in 𝓝 z, V y = S.field y) ∧
+                ∀ z,
+                  ¬(Filter.Tendsto (fun t => G t z) Filter.atBot (𝓝 q.val) ∧
+                      Filter.Tendsto (fun t => G t z) Filter.atTop (𝓝 p.val)) := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data p).upper_regular
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data q).lower_regular
+  let _ := Smale.RegularLevel.isManifold hf (S.data p).upper_regular
+  let _ : CompactSpace (S.data p).UpperLevel :=
+    isCompact_iff_compactSpace.mp (isClosed_eq hf.continuous continuous_const).isCompact
+  let _ : Fact (Module.finrank ℝ (S.data q).chart.NegativeCoordinates = n + 1) := ⟨hqindex⟩
+  let _ : Fact (Module.finrank ℝ (S.data p).chart.PositiveCoordinates = m + 1) := ⟨hppos⟩
+  obtain ⟨D, b, -, hb, horbit⟩ := S.exists_orbit_bandBridge hf p q hpq hconsecutive
+  have horbit' (x : (S.data p).UpperLevel) : ∃ t, S.flow t x = (b x : M) := by
+    obtain ⟨t, ht⟩ := horbit x
+    exact ⟨t, ht.trans (hb x).symm⟩
+  let α := (S.data p).transportedAttachingSphere (S.data q) n b.toHomeomorph
+  have hα : ContMDiff (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ α :=
+    (S.data p).transportedAttachingSphere_smooth (S.data q) hf n b
+  have hB := (S.data p).belt_smooth hf m
+  have hdim :
+    Module.finrank ℝ (EuclideanSpace ℝ (Fin n)) + Module.finrank ℝ (EuclideanSpace ℝ (Fin m)) <
+      Module.finrank ℝ (Smale.RegularLevel.Model E) := by
+    simp only [Smale.RegularLevel.Model, finrank_euclideanSpace, Fintype.card_fin]
+    have hh := (S.data p).chart.finrank_negative_add_positive
+    omega
+  obtain ⟨e, he, hdisjoint⟩ :=
+    Degree.MorseRearrangement.exists_ambient_disjoint_diffeomorph_of_dimension hα hB hdim
+  have hbasins :
+    ∀ x : (S.data p).UpperLevel,
+      ¬(Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 q.val) ∧
+          Filter.Tendsto (fun t => S.flow t (e x)) Filter.atTop (𝓝 p.val)) := by
+    rintro x ⟨hxq, hxp⟩
+    obtain ⟨v, hv⟩ := (S.transported_attaching_basin_iff hf p q n b.toHomeomorph horbit' x).mp hxq
+    have hB := (S.belt_basin_iff hf p (e x)).mp hxp
+    have hαx : e x ∈ Set.range (e ∘ α) := ⟨v, congrArg e hv⟩
+    exact Set.disjoint_left.mp hdisjoint hαx hB
+  have hpc : f p < f p + (S.data p).radius ^ 2 := S.toSurgeryWindows.value_lt_upper p
+  have hqc : f p + (S.data p).radius ^ 2 < f q :=
+    (S.separated p q hpq).trans (S.toSurgeryWindows.lower_lt_value q)
+  obtain ⟨a, hpa, hac⟩ := exists_between hpc
+  obtain ⟨b', hcb, hbq⟩ := exists_between hqc
+  let z : (S.data p).UpperLevel := α (Classical.arbitrary (Smale.Hemisphere.Sphere n))
+  obtain
+    ⟨_, _, _, V, H, G, -, -, -, -, -, -, hgeometry, hV, hG, hzeros, hneg, hgerms, -, hend, -,
+      hleft, hright⟩ :=
+    Degree.FlowSuspension.exists_native_regular_level_isotopy_realization hf S.smooth S.descent
+      S.flow S.integral hac hcb
+      (MorseCancel.surgery_pair_inner_band_regular p q hconsecutive hpa hbq)
+      (S.data p).upper_regular z e he
+  obtain ⟨hback, hforward⟩ :=
+    Degree.FlowSuspension.whole_level_basins_of_holonomy S.flow H G Subtype.val e
+      (fun x => (hgeometry x).2.1) (fun x => (hgeometry x).2.2) hend hleft hright
+  refine ⟨V, G, hV, hG, fun x hx => (hzeros x).mpr (S.zero x hx), hneg, hgerms, ?_⟩
+  exact
+    Degree.FlowSuspension.no_connection_of_level_basin_disjointness S.flow G hf.continuous hqc hpc
+      e (fun x => hback x q.val) (fun x => hforward x p.val) hbasins
+
+private theorem MorseCancel.unitSphere_isEmpty_of_finrank_zero {A : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [FiniteDimensional ℝ A] (hA : Module.finrank ℝ A = 0) :
+    IsEmpty (Smale.PuncturedHandle.UnitSphere A) := by
+  let _ : Subsingleton A := (Module.finrank_eq_zero_iff_of_free ℝ A).mp hA
+  refine ⟨fun v => ?_⟩
+  have hh := mem_sphere_zero_iff_norm.mp v.property
+  rw [Subsingleton.elim (v : A) 0, norm_zero] at hh
+  norm_num at hh
+
+private theorem
+    AdaptedWindows.no_connection_of_upper_index_zero {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p q : Smale.ManifoldMorse.criticalPoints E f)
+    (hpq : f p < f q) (hqzero : Module.finrank ℝ (S.data q).chart.NegativeCoordinates = 0) :
+    ∀ x,
+      ¬(Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 q.val) ∧
+          Filter.Tendsto (fun t => S.flow t x) Filter.atTop (𝓝 p.val)) := by
+  let _ := MorseCancel.unitSphere_isEmpty_of_finrank_zero hqzero
+  rintro x ⟨hxq, hxp⟩
+  obtain ⟨t, ht⟩ :=
+    Degree.FlowCancellation.exists_level_crossing_of_endpoint_limits S.flow hf.continuous hxq hxp
+      (S.toSurgeryWindows.lower_lt_value q)
+      ((S.toSurgeryWindows.value_lt_upper p).trans (S.separated p q hpq))
+  let y : (S.data q).LowerLevel := ⟨S.flow t x, ht⟩
+  have hlim : Filter.Tendsto (fun s => S.flow s (y : M)) Filter.atBot (𝓝 q.val) :=
+    (MorseCancel.flow_time_atBot_limit_iff S.flow t x q.val).mpr hxq
+  obtain ⟨v, -⟩ := (S.attaching_basin_iff hf q y).mp hlim
+  exact isEmptyElim v
+
+private theorem
+    AdaptedWindows.no_connection_of_lower_positive_zero {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p q : Smale.ManifoldMorse.criticalPoints E f)
+    (hpq : f p < f q) (hpzero : Module.finrank ℝ (S.data p).chart.PositiveCoordinates = 0) :
+    ∀ x,
+      ¬(Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 q.val) ∧
+          Filter.Tendsto (fun t => S.flow t x) Filter.atTop (𝓝 p.val)) := by
+  let _ := MorseCancel.unitSphere_isEmpty_of_finrank_zero hpzero
+  rintro x ⟨hxq, hxp⟩
+  obtain ⟨t, ht⟩ :=
+    Degree.FlowCancellation.exists_level_crossing_of_endpoint_limits S.flow hf.continuous hxq hxp
+      ((S.separated p q hpq).trans (S.toSurgeryWindows.lower_lt_value q))
+      (S.toSurgeryWindows.value_lt_upper p)
+  let y : (S.data p).UpperLevel := ⟨S.flow t x, ht⟩
+  have hlim : Filter.Tendsto (fun s => S.flow s (y : M)) Filter.atTop (𝓝 p.val) :=
+    (MorseCancel.flow_time_atTop_limit_iff S.flow t x p.val).mpr hxp
+  obtain ⟨v, -⟩ := (S.belt_basin_iff hf p y).mp hlim
+  exact isEmptyElim v
+
+private theorem AdaptedWindows.remove_connections_of_nonincreasing_indices {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (p q : Smale.ManifoldMorse.criticalPoints E f) (hpq : f p < f q)
+    (hconsecutive : ∀ r : Smale.ManifoldMorse.criticalPoints E f, ¬(f p < f r ∧ f r < f q))
+    (hle :
+      Module.finrank ℝ (S.data q).chart.NegativeCoordinates ≤
+        Module.finrank ℝ (S.data p).chart.NegativeCoordinates) :
+    ∃ (V : (z : M) → TangentSpace 𝓘(ℝ, E) z) (G : Flow ℝ M),
+      ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun z => (⟨z, V z⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+        (∀ z, IsMIntegralCurve (fun t => G t z) V) ∧
+          (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, V z = 0) ∧
+            (∀ z, z ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f z (V z) < 0) ∧
+              (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ y in 𝓝 z, V y = S.field y) ∧
+                ∀ z,
+                  ¬(Filter.Tendsto (fun t => G t z) Filter.atBot (𝓝 q.val) ∧
+                      Filter.Tendsto (fun t => G t z) Filter.atTop (𝓝 p.val)) := by
+  by_cases hqzero : Module.finrank ℝ (S.data q).chart.NegativeCoordinates = 0
+  · exact
+      ⟨S.field, S.flow, S.smooth, S.integral, S.zero, S.descent, fun _ _ =>
+        Filter.Eventually.of_forall (fun _ => rfl),
+        S.no_connection_of_upper_index_zero hf p q hpq hqzero⟩
+  by_cases hpzero : Module.finrank ℝ (S.data p).chart.PositiveCoordinates = 0
+  · exact
+      ⟨S.field, S.flow, S.smooth, S.integral, S.zero, S.descent, fun _ _ =>
+        Filter.Eventually.of_forall (fun _ => rfl),
+        S.no_connection_of_lower_positive_zero hf p q hpq hpzero⟩
+  exact
+    S.remove_connections_of_index_le hf p q hpq hconsecutive
+      (Module.finrank ℝ (S.data q).chart.NegativeCoordinates - 1)
+      (Module.finrank ℝ (S.data p).chart.PositiveCoordinates - 1) (by omega) (by omega) hle
+
+private theorem
+    AdaptedWindows.exchange_nonincreasing_native_indices {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PreconnectedSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (p q : Smale.ManifoldMorse.criticalPoints E f)
+    (hpq : f p < f q)
+    (hconsecutive : ∀ r : Smale.ManifoldMorse.criticalPoints E f, ¬(f p < f r ∧ f r < f q))
+    (hle : MorseCancel.nativeMorseIndex E f q ≤ MorseCancel.nativeMorseIndex E f p) :
+    ∃ g : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+        Smale.ManifoldMorse.IsMorse E g ∧
+          Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f ∧
+            g p = f q ∧
+              g q = f p ∧
+                (∀ z,
+                    f z ∉ Set.Ioo (S.toSurgeryWindows.lower p) (S.toSurgeryWindows.upper q) →
+                      g =ᶠ[𝓝 z] f) ∧
+                  (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+                      z ≠ p.val → z ≠ q.val → g =ᶠ[𝓝 z] f) ∧
+                    Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) ∧
+                      Nonempty (AdaptedWindows E g) ∧
+                        (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+                            MorseCancel.nativeMorseIndex E g z =
+                              MorseCancel.nativeMorseIndex E f z) ∧
+                          ∀ k,
+                            MorseCancel.nativeMorseCount E g k =
+                              MorseCancel.nativeMorseCount E f k := by
+  have hle' :
+    Module.finrank ℝ (S.data q).chart.NegativeCoordinates ≤
+      Module.finrank ℝ (S.data p).chart.NegativeCoordinates := by
+    rwa [MorseCancel.nativeMorseIndex_eq_chart (S.data q).chart,
+      MorseCancel.nativeMorseIndex_eq_chart (S.data p).chart] at hle
+  obtain ⟨V, G, hV, hG, hzeros, hneg, hgerms, hnoconnection⟩ :=
+    S.remove_connections_of_nonincreasing_indices hf p q hpq hconsecutive hle'
+  have hpgerm : ∀ᶠ y in 𝓝 p.val, V y = (S.data p).chart.descentField y := by
+    filter_upwards [hgerms p p.property, S.critical_model_germ p] with y hy hmodel
+    exact hy.trans hmodel
+  have hqgerm : ∀ᶠ y in 𝓝 q.val, V y = (S.data q).chart.descentField y := by
+    filter_upwards [hgerms q q.property, S.critical_model_germ q] with y hy hmodel
+    exact hy.trans hmodel
+  have hpband : f p ∈ Set.Ioo (S.toSurgeryWindows.lower p) (S.toSurgeryWindows.upper q) :=
+    ⟨S.toSurgeryWindows.lower_lt_value p, hpq.trans (S.toSurgeryWindows.value_lt_upper q)⟩
+  have hqband : f q ∈ Set.Ioo (S.toSurgeryWindows.lower p) (S.toSurgeryWindows.upper q) :=
+    ⟨(S.toSurgeryWindows.lower_lt_value p).trans hpq, S.toSurgeryWindows.value_lt_upper q⟩
+  obtain ⟨g, hg, hmg, hcrit, hgp, hgq, -, hexterior, -, -, hothers, hindices⟩ :=
+    Degree.MorseRearrangement.exists_morse_rearrangement_of_no_connection hf hm hV G hG hzeros
+      hneg S.distinct (S.data p).chart (S.data q).chart hpgerm hqgerm hpband hqband hpq hqband
+      hpband (MorseCancel.surgery_pair_band_isolation S.toSurgeryWindows p q hconsecutive)
+      hnoconnection
+  obtain ⟨hinj, hnew⟩ :=
+    MorseCancel.adapted_surgery_system_after_value_exchange S hg hmg p.property q.property hcrit
+      hgp hgq hothers
+  exact
+    ⟨g, hg, hmg, hcrit, hgp, hgq, hexterior, hothers, hinj, hnew, hindices,
+      MorseCancel.nativeMorseCount_eq_of_preserved_indices hcrit hindices⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private def MorseCancel.nativeIndexDisorder (E : Type*) [NormedAddCommGroup E] [NormedSpace ℝ E]
+    {M : Type*} [TopologicalSpace M] [ChartedSpace E M] (f : M → ℝ) : ℕ :=
+  if hfinite : (Smale.ManifoldMorse.criticalPoints E f).Finite then
+    let _ := hfinite.fintype
+    Degree.MorseRearrangement.finiteIndexDisorder
+      (fun x : Smale.ManifoldMorse.criticalPoints E f => f x)
+      (fun x : Smale.ManifoldMorse.criticalPoints E f => nativeMorseIndex E f x)
+  else 0
+
+private theorem MorseCancel.nativeIndexDisorder_eq_of_finite {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (hfinite : (Smale.ManifoldMorse.criticalPoints E f).Finite) :
+    letI := hfinite.fintype
+    nativeIndexDisorder E f =
+      Degree.MorseRearrangement.finiteIndexDisorder
+        (fun x : Smale.ManifoldMorse.criticalPoints E f => f x)
+        (fun x : Smale.ManifoldMorse.criticalPoints E f => nativeMorseIndex E f x) := by
+  classical simp only [nativeIndexDisorder, dite_eq_left hfinite]
+
+private theorem MorseCancel.nativeIndexDisorder_transport {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ}
+    (hfinite : (Smale.ManifoldMorse.criticalPoints E f).Finite)
+    (hcrit : Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f)
+    (hindex :
+      ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+        nativeMorseIndex E g x = nativeMorseIndex E f x) :
+    letI := hfinite.fintype
+    nativeIndexDisorder E g =
+      Degree.MorseRearrangement.finiteIndexDisorder
+        (fun x : Smale.ManifoldMorse.criticalPoints E f => g x)
+        (fun x : Smale.ManifoldMorse.criticalPoints E f => nativeMorseIndex E f x) := by
+  classical
+  let _ := hfinite.fintype
+  have hgfinite : (Smale.ManifoldMorse.criticalPoints E g).Finite := hcrit.symm ▸ hfinite
+  let _ := hgfinite.fintype
+  let e : Smale.ManifoldMorse.criticalPoints E f ≃ Smale.ManifoldMorse.criticalPoints E g :=
+    Equiv.setCongr hcrit.symm
+  rw [nativeIndexDisorder_eq_of_finite hgfinite]
+  rw [←
+    Degree.MorseRearrangement.finiteIndexDisorder_comp_equiv
+      (fun x : Smale.ManifoldMorse.criticalPoints E g => g x)
+      (fun x : Smale.ManifoldMorse.criticalPoints E g => nativeMorseIndex E g x) e]
+  have hw :
+    ((fun x : Smale.ManifoldMorse.criticalPoints E g => nativeMorseIndex E g x) ∘ e) =
+      fun x : Smale.ManifoldMorse.criticalPoints E f => nativeMorseIndex E f x := by
+    funext x
+    exact hindex x x.property
+  rw [hw]
+  rfl
+
+private theorem MorseCancel.nativeIndexDisorder_exchange_lt {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ}
+    (hfinite : (Smale.ManifoldMorse.criticalPoints E f).Finite)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f))
+    (p q : Smale.ManifoldMorse.criticalPoints E f) (hpq : f p < f q)
+    (hconsecutive : ∀ r : Smale.ManifoldMorse.criticalPoints E f, ¬(f p < f r ∧ f r < f q))
+    (hindexlt : nativeMorseIndex E f q < nativeMorseIndex E f p)
+    (hcrit : Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f)
+    (hgp : g p = f q) (hgq : g q = f p)
+    (hothers : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, x ≠ p.val → x ≠ q.val → g =ᶠ[𝓝 x] f)
+    (hindex :
+      ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+        nativeMorseIndex E g x = nativeMorseIndex E f x) :
+    nativeIndexDisorder E g < nativeIndexDisorder E f := by
+  classical
+  let _ : DecidableEq (Smale.ManifoldMorse.criticalPoints E f) := fun a b =>
+    Classical.propDecidable (a = b)
+  let _ := hfinite.fintype
+  have hform :
+    (fun x : Smale.ManifoldMorse.criticalPoints E f => g x) =
+      (fun x : Smale.ManifoldMorse.criticalPoints E f => f x) ∘ Equiv.swap p q := by
+    funext x
+    by_cases hxp : x = p
+    · subst x
+      simpa only [Function.comp_apply, Equiv.swap_apply_left] using hgp
+    by_cases hxq : x = q
+    · subst x
+      simpa only [Function.comp_apply, Equiv.swap_apply_right] using hgq
+    have hh :=
+      (hothers x x.property (fun h => hxp (Subtype.ext h))
+          (fun h => hxq (Subtype.ext h))).self_of_nhds
+    simpa only [Function.comp_apply, Equiv.swap_apply_def, ite_eq_right hxp,
+      ite_eq_right hxq] using hh
+  rw [nativeIndexDisorder_transport hfinite hcrit hindex,
+    nativeIndexDisorder_eq_of_finite hfinite, hform]
+  have hi : Function.Injective (fun x : Smale.ManifoldMorse.criticalPoints E f => f x) :=
+    fun x y h => Subtype.ext (hinj x.property y.property h)
+  exact
+    Degree.MorseRearrangement.finiteIndexDisorder_swap_lt (h :=
+      fun x : Smale.ManifoldMorse.criticalPoints E f => f x) hi
+      (fun x : Smale.ManifoldMorse.criticalPoints E f => nativeMorseIndex E f x) (p := p) (q := q)
+      hpq hconsecutive hindexlt
+
+private theorem
+    MorseCancel.exists_index_ordered_morse_system_preserving_critical_points {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PreconnectedSpace M]
+    {f₀ : M → ℝ} (S₀ : AdaptedWindows E f₀) (hf₀ : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f₀)
+    (hm₀ : Smale.ManifoldMorse.IsMorse E f₀) :
+    ∃ f : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f ∧
+        Smale.ManifoldMorse.IsMorse E f ∧
+          Smale.ManifoldMorse.criticalPoints E f = Smale.ManifoldMorse.criticalPoints E f₀ ∧
+            (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f₀,
+                nativeMorseIndex E f x = nativeMorseIndex E f₀ x) ∧
+              ∃ _ : AdaptedWindows E f,
+                (∀ p q : Smale.ManifoldMorse.criticalPoints E f,
+                    f p < f q → nativeMorseIndex E f p ≤ nativeMorseIndex E f q) ∧
+                  ∀ k, nativeMorseCount E f k = nativeMorseCount E f₀ k := by
+  classical
+  let P : ℕ → Prop := fun n =>
+    ∃ f : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f ∧
+        Smale.ManifoldMorse.IsMorse E f ∧
+          Smale.ManifoldMorse.criticalPoints E f = Smale.ManifoldMorse.criticalPoints E f₀ ∧
+            (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f₀,
+                nativeMorseIndex E f x = nativeMorseIndex E f₀ x) ∧
+              Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f) ∧ nativeIndexDisorder E f = n
+  have hex : ∃ n, P n :=
+    ⟨nativeIndexDisorder E f₀, f₀, hf₀, hm₀, rfl, fun _ _ => rfl, S₀.distinct, rfl⟩
+  obtain ⟨f, hf, hm, hcrit, hindices, hinj, hdisorder⟩ := Nat.find_spec hex
+  obtain ⟨S⟩ := nonempty_adaptedSurgeryWindows hf hm hinj
+  have horder :
+    ∀ p q : Smale.ManifoldMorse.criticalPoints E f,
+      f p < f q → nativeMorseIndex E f p ≤ nativeMorseIndex E f q := by
+    by_contra hnot
+    let _ := S.finite.fintype
+    obtain ⟨p, q, hpq, hconsecutive, hinversion⟩ :=
+      Degree.MorseRearrangement.exists_adjacent_index_inversion (h :=
+        fun x : Smale.ManifoldMorse.criticalPoints E f => f x)
+        (fun x y h => Subtype.ext (hinj x.property y.property h))
+        (fun x : Smale.ManifoldMorse.criticalPoints E f => nativeMorseIndex E f x) hnot
+    obtain ⟨g, hg, hmg, hcritg, hgp, hgq, -, hothers, hinjg, -, hindicesg, -⟩ :=
+      S.exchange_nonincreasing_native_indices hf hm p q hpq hconsecutive hinversion.le
+    have hdecrease : nativeIndexDisorder E g < nativeIndexDisorder E f :=
+      nativeIndexDisorder_exchange_lt S.finite hinj p q hpq hconsecutive hinversion hcritg hgp hgq
+        hothers hindicesg
+    have hindicesg₀ (x : M) (hx : x ∈ Smale.ManifoldMorse.criticalPoints E f₀) :
+      nativeMorseIndex E g x = nativeMorseIndex E f₀ x :=
+      (hindicesg x (by rw [hcrit]; exact hx)).trans (hindices x hx)
+    have hminimal := Nat.find_min' hex ⟨g, hg, hmg, hcritg.trans hcrit, hindicesg₀, hinjg, rfl⟩
+    rw [← hdisorder] at hminimal
+    exact (not_le_of_gt hdecrease) hminimal
+  exact
+    ⟨f, hf, hm, hcrit, hindices, S, horder,
+      nativeMorseCount_eq_of_preserved_indices hcrit hindices⟩
+
+private theorem
+    MorseCancel.minimal_excellent_morse_minimum_count_one {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PathConnectedSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f)
+    (hminimal :
+      ∀ g : M → ℝ,
+        ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g →
+          Smale.ManifoldMorse.IsMorse E g →
+            Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) →
+              (Smale.ManifoldMorse.criticalPoints E f).ncard ≤
+                (Smale.ManifoldMorse.criticalPoints E g).ncard) :
+    nativeMorseCount E f 0 = 1 := by
+  by_contra hmin
+  obtain ⟨g, hg, hmg, hinjg, hcount⟩ :=
+    exists_excellent_morse_reduction_of_multiple_minima S hf hm hmin
+  exact minimal_excellent_morse_forbids_pair_removal hminimal hg hmg hinjg hcount
+
+private theorem
+    MorseCancel.minimal_excellent_morse_extreme_counts_one {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PathConnectedSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f)
+    (hminimal :
+      ∀ g : M → ℝ,
+        ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g →
+          Smale.ManifoldMorse.IsMorse E g →
+            Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) →
+              (Smale.ManifoldMorse.criticalPoints E f).ncard ≤
+                (Smale.ManifoldMorse.criticalPoints E g).ncard) :
+    nativeMorseCount E f 0 = 1 ∧ nativeMorseCount E f (Module.finrank ℝ E) = 1 := by
+  refine ⟨minimal_excellent_morse_minimum_count_one S hf hm hminimal, ?_⟩
+  obtain ⟨T⟩ :=
+    nonempty_adaptedSurgeryWindows hf.neg (isMorse_neg hm)
+      (distinct_critical_values_neg S.distinct)
+  have hmin :=
+    minimal_excellent_morse_minimum_count_one T hf.neg (isMorse_neg hm)
+      (minimal_excellent_morse_neg hminimal)
+  have hcounts := nativeMorseCount_neg hf hm (le_refl (Module.finrank ℝ E))
+  rw [Nat.sub_self] at hcounts
+  exact hcounts.symm.trans hmin
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    AdaptedWindows.exists_transverse_middle_belt_loop {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hdim : Module.finrank ℝ E = 6)
+    (p q : Smale.ManifoldMorse.criticalPoints E f) (hp : MorseCancel.nativeMorseIndex E f p = 0)
+    (hq : MorseCancel.nativeMorseIndex E f q = 1)
+    [Fact (Module.finrank ℝ (S.data q).chart.PositiveCoordinates = 4 + 1)]
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (hbranches :
+      ∀ w : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1,
+        Filter.Tendsto (fun t => S.flow t ((S.data q).surgery.attachingSphere w).val) Filter.atTop
+          (𝓝 p.val))
+    {a : ℝ} (hqa : S.toSurgeryWindows.upper q ≤ a)
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hlow :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E f,
+        f z ≤ a → MorseCancel.nativeMorseIndex E f z ≤ 2) :
+    let _ := Smale.RegularLevel.chartedSpace hf ha
+    ∃ δ : C(Smale.Hemisphere.Sphere 1, { y : M // f y = a }),
+      ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ δ ∧
+        Function.Injective δ ∧
+          (∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) δ z)) ∧
+            ∃ (z₀ : Smale.Hemisphere.Sphere 1) (v :
+              Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) (β :
+              Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1 → { y : M // f y = a }),
+              MDifferentiableAt (𝓡 4) 𝓘(ℝ, Smale.RegularLevel.Model E) β v ∧
+                β v = δ z₀ ∧
+                  Smale.NativeTransversality.At (𝓡 1) (𝓡 4) 𝓘(ℝ, Smale.RegularLevel.Model E) δ β
+                      z₀ v ∧
+                    (∀ᶠ w in 𝓝 v,
+                        Filter.Tendsto (fun t => S.flow t (β w).val) Filter.atTop (𝓝 q.val)) ∧
+                      (∀ z,
+                          Filter.Tendsto (fun t => S.flow t (δ z).val) Filter.atTop (𝓝 q.val) ↔
+                            z = z₀) ∧
+                        ∀ z,
+                          Filter.Tendsto (fun t => S.flow t (δ z).val) Filter.atTop (𝓝 p.val) ∨
+                            Filter.Tendsto (fun t => S.flow t (δ z).val) Filter.atTop (𝓝 q.val) :=
+  by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data q).upper_regular
+  let _ := Smale.RegularLevel.chartedSpace hf ha
+  let _ := Smale.RegularLevel.isManifold hf (S.data q).upper_regular
+  let _ := Smale.RegularLevel.isManifold hf ha
+  obtain ⟨v, γ, hγ, hγi, hγd, hreach, z₀, hsingle, htrans, hendpoints⟩ :=
+    S.exists_transverse_belt_circle_reaching_level_with_endpoints hf p q hp hq 4 u hbranches hqa
+      ha hlow (by omega) (by omega) (by omega)
+  obtain ⟨t₀, ht₀⟩ := hreach z₀
+  let za : { y : M // f y = a } := ⟨S.flow t₀ (γ z₀).val, ht₀⟩
+  obtain ⟨D, hsource, -, horbit⟩ :=
+    S.exists_native_level_basin_transport hf (S.data q).upper_regular ha (γ z₀) za
+  have hγsource (z : Circle) : γ z ∈ D.source := hsource.symm ▸ hreach z
+  have hΓsmooth : ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ (D ∘ γ) := by
+    intro z
+    exact
+      (D.contMDiffOn_toFun.contMDiffAt (D.open_source.mem_nhds (hγsource z))).comp z
+        hγ.contMDiffAt
+  let Γ : C(Circle, { y : M // f y = a }) := ⟨D ∘ γ, hΓsmooth.continuous⟩
+  have hΓi : Function.Injective Γ := by
+    intro z w hzw
+    exact hγi (D.toPartialEquiv.injOn (hγsource z) (hγsource w) hzw)
+  have hΓd : ∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) Γ z) := by
+    intro z
+    change Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) (D ∘ γ) z)
+    rw [mfderiv_comp z (D.mdifferentiableAt (by simp) (hγsource z))
+        (hγ.mdifferentiableAt (by simp))]
+    exact (Smale.PartialChart.bijective_mfderiv D (hγsource z)).1.comp (hγd z)
+  have hcross : (S.data q).surgery.beltSphere v = γ z₀ := ((hsingle z₀ v).mpr ⟨rfl, rfl⟩).symm
+  have hvsource : (S.data q).surgery.beltSphere v ∈ D.source := hcross.symm ▸ hγsource z₀
+  let β := D ∘ (S.data q).surgery.beltSphere
+  have hβ : MDifferentiableAt (𝓡 4) 𝓘(ℝ, Smale.RegularLevel.Model E) β v :=
+    (D.mdifferentiableAt (by simp) hvsource).comp v
+      (((S.data q).belt_smooth hf 4).mdifferentiableAt (by simp))
+  have hβcross : β v = Γ z₀ := congrArg D hcross
+  have hΓtrans :
+    Smale.NativeTransversality.At (𝓡 1) (𝓡 4) 𝓘(ℝ, Smale.RegularLevel.Model E) Γ β z₀ v :=
+    (Degree.TransverseGerms.native_transversality_partial_diffeomorph_iff D
+          (hγ.mdifferentiableAt (by simp))
+          (((S.data q).belt_smooth hf 4).mdifferentiableAt (by simp)) hcross (hγsource z₀)).mp
+      (fun _ => htrans)
+  have hβbasin :
+    ∀ᶠ w in 𝓝 v, Filter.Tendsto (fun t => S.flow t (β w).val) Filter.atTop (𝓝 q.val) := by
+    have hnear :=
+      (((S.data q).belt_smooth hf 4).continuous.tendsto v) (D.open_source.mem_nhds hvsource)
+    filter_upwards [hnear] with w hw
+    obtain ⟨t, ht⟩ := horbit ((S.data q).surgery.beltSphere w) hw
+    change S.flow t ((S.data q).surgery.beltSphere w).val = (β w).val at ht
+    rw [← ht]
+    exact
+      (MorseCancel.flow_time_atTop_limit_iff S.flow t _ q.val).mpr
+        ((S.belt_basin_iff hf q ((S.data q).surgery.beltSphere w)).mpr ⟨w, rfl⟩)
+  have hforward (z : Circle) :
+    Filter.Tendsto (fun t => S.flow t (Γ z).val) Filter.atTop (𝓝 q.val) ↔ z = z₀ := by
+    obtain ⟨t, ht⟩ := horbit (γ z) (hγsource z)
+    change S.flow t (γ z).val = (Γ z).val at ht
+    have hbasin :
+      Filter.Tendsto (fun s => S.flow s (Γ z).val) Filter.atTop (𝓝 q.val) ↔
+        γ z ∈ Set.range (S.data q).surgery.beltSphere := by
+      rw [← ht]
+      exact
+        (MorseCancel.flow_time_atTop_limit_iff S.flow t (γ z).val q.val).trans
+          (S.belt_basin_iff hf q (γ z))
+    rw [hbasin]
+    constructor
+    · rintro ⟨w, hw⟩
+      exact ((hsingle z w).mp hw.symm).1
+    · intro hz
+      exact ⟨v, ((hsingle z v).mpr ⟨hz, rfl⟩).symm⟩
+  have hΓends (z : Circle) :
+    Filter.Tendsto (fun t => S.flow t (Γ z).val) Filter.atTop (𝓝 p.val) ∨
+      Filter.Tendsto (fun t => S.flow t (Γ z).val) Filter.atTop (𝓝 q.val) := by
+    obtain ⟨t, ht⟩ := horbit (γ z) (hγsource z)
+    change S.flow t (γ z).val = (Γ z).val at ht
+    rw [← ht]
+    exact
+      (hendpoints z).imp ((MorseCancel.flow_time_atTop_limit_iff S.flow t _ p.val).mpr)
+        ((MorseCancel.flow_time_atTop_limit_iff S.flow t _ q.val).mpr)
+  let δ : C(Smale.Hemisphere.Sphere 1, { y : M // f y = a }) :=
+    ⟨Γ ∘ MorseCancel.standardCircleParametrization,
+      Γ.continuous.comp MorseCancel.standardCircleParametrization.continuous⟩
+  let z := MorseCancel.standardCircleParametrization.symm z₀
+  have hz : MorseCancel.standardCircleParametrization z = z₀ :=
+    MorseCancel.standardCircleParametrization.apply_symm_apply z₀
+  have hδcross : β v = δ z := by
+    change β v = Γ (MorseCancel.standardCircleParametrization z)
+    rw [hz]
+    exact hβcross
+  have hδtrans :
+    Smale.NativeTransversality.At (𝓡 1) (𝓡 4) 𝓘(ℝ, Smale.RegularLevel.Model E) δ β z v := by
+    intro _
+    let B : EuclideanSpace ℝ (Fin 4) →L[ℝ] Smale.RegularLevel.Model E :=
+      mfderiv (𝓡 4) 𝓘(ℝ, Smale.RegularLevel.Model E) β v
+    apply MorseCancel.transverse_comp_standardCircle hΓsmooth B z
+    rw [hz]
+    exact hΓtrans hβcross
+  refine
+    ⟨δ, MorseCancel.contMDiff_comp_standardCircle hΓsmooth,
+      MorseCancel.injective_comp_standardCircle hΓi,
+      MorseCancel.injective_derivative_comp_standardCircle hΓsmooth hΓd, z, v, β, hβ, hδcross,
+      hδtrans, hβbasin, ?_, fun w => hΓends (MorseCancel.standardCircleParametrization w)⟩
+  intro w
+  change
+    Filter.Tendsto (fun t => S.flow t (Γ (MorseCancel.standardCircleParametrization w)).val)
+        Filter.atTop (𝓝 q.val) ↔
+      _
+  rw [hforward]
+  exact
+    ⟨fun hw => MorseCancel.standardCircleParametrization.injective (hw.trans hz.symm), fun hw =>
+      hw ▸ hz⟩
+
+private theorem
+    MorseCancel.exists_transverse_sheet_of_circle_placement {A B E HA HB H X Y N : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [TopologicalSpace HA] {I : ModelWithCorners ℝ A HA}
+    [TopologicalSpace X] [ChartedSpace HA X] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [TopologicalSpace HB] {I' : ModelWithCorners ℝ B HB} [TopologicalSpace Y] [ChartedSpace HB Y]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {J : ModelWithCorners ℝ E H}
+    [TopologicalSpace N] [ChartedSpace H N] (P : Diffeomorph J J N N ∞) {γ δ : X → N} {β : Y → N}
+    {x : X} {y : Y} (hγ : MDifferentiableAt I J γ x) (hβ : MDifferentiableAt I' J β y)
+    (hplace : ∀ z, P (γ z) = δ z) (hcross : β y = δ x)
+    (htrans : Smale.NativeTransversality.At I I' J δ β x y) :
+    ∃ β' : Y → N,
+      MDifferentiableAt I' J β' y ∧
+        β' y = γ x ∧ Smale.NativeTransversality.At I I' J γ β' x y ∧ ∀ z, P (β' z) = β z := by
+  let β' := P.symm ∘ β
+  have hβ' : MDifferentiableAt I' J β' y :=
+    (P.symm.contMDiff.mdifferentiableAt (by simp)).comp y hβ
+  have hcross' : β' y = γ x := by
+    apply P.injective
+    change P (P.symm (β y)) = P (γ x)
+    rw [P.apply_symm_apply, hcross, hplace]
+  have hforward (z : Y) : P (β' z) = β z := P.apply_symm_apply (β z)
+  refine ⟨β', hβ', hcross', ?_, hforward⟩
+  apply
+    (Degree.TransverseGerms.native_transversality_partial_diffeomorph_iff P.toPartialDiffeomorph
+        hγ hβ' hcross' (Set.mem_univ _)).mpr
+  have hγeq : P.toPartialDiffeomorph ∘ γ = δ := funext hplace
+  have hβeq : P.toPartialDiffeomorph ∘ β' = β := funext hforward
+  rw [hγeq, hβeq]
+  exact htrans
+
+private theorem Degree.DiskShrinking.exists_embedded_disk_isotopy_of_path {D E M : Type*}
+    [NormedAddCommGroup D] [InnerProductSpace ℝ D] [FiniteDimensional ℝ D] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f g : D → M}
+    (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f) (hg : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ g)
+    (hfi : Set.InjOn f (Metric.closedBall (0 : D) 1))
+    (hgi : Set.InjOn g (Metric.closedBall (0 : D) 1))
+    (hfd : ∀ x ∈ Metric.closedBall (0 : D) 1, Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x))
+    (hgd : ∀ x ∈ Metric.closedBall (0 : D) 1, Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) g x))
+    (n : ℕ) (hn : 0 < n) (hdim : Module.finrank ℝ D + n = Module.finrank ℝ E)
+    (hE : 2 ≤ Module.finrank ℝ E) (γ : Path (f 0) (g 0)) :
+    ∃ P : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞,
+      Smale.SupportedDiffeomorph.IsotopicToIdentity P ∧
+        ∀ x ∈ Metric.closedBall (0 : D) 1, P (f x) = g x := by
+  obtain ⟨P, hP, hP0, -⟩ :=
+    MorseCancel.exists_isotopic_pointMoving_of_path (J := 𝓘(ℝ, E)) isOpen_univ γ
+      (fun _ => Set.mem_univ _)
+  have hPf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ (P ∘ f) := P.contMDiff.comp hf
+  have hPfi : Set.InjOn (P ∘ f) (Metric.closedBall (0 : D) 1) := by
+    intro x hx y hy hh
+    exact hfi hx hy (P.injective hh)
+  have hPfd :
+    ∀ x ∈ Metric.closedBall (0 : D) 1, Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) (P ∘ f) x) := by
+    intro x hx
+    rw [mfderiv_comp x (P.contMDiff.mdifferentiableAt (by simp)) (hf.mdifferentiableAt (by simp))]
+    have hi : Function.Bijective (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) P (f x) : E →L[ℝ] E) :=
+      Smale.PartialChart.bijective_mfderiv P.toPartialDiffeomorph (Set.mem_univ _)
+    exact hi.1.comp (hfd x hx)
+  obtain ⟨Q, hQ, hformula⟩ :=
+    exists_embedded_disk_isotopy_of_same_center hPf hg hPfi hgi hPfd hgd n hn hdim hE hP0
+  exact ⟨P.trans Q, hP.trans hQ, hformula⟩
+
+private theorem
+    Degree.DiskShrinking.exists_embedded_disk_isotopy {D E M : Type*} [NormedAddCommGroup D]
+    [InnerProductSpace ℝ D] [FiniteDimensional ℝ D] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [T2Space M] [CompactSpace M] [PathConnectedSpace M] {f g : D → M}
+    (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f) (hg : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ g)
+    (hfi : Set.InjOn f (Metric.closedBall (0 : D) 1))
+    (hgi : Set.InjOn g (Metric.closedBall (0 : D) 1))
+    (hfd : ∀ x ∈ Metric.closedBall (0 : D) 1, Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x))
+    (hgd : ∀ x ∈ Metric.closedBall (0 : D) 1, Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) g x))
+    (n : ℕ) (hn : 0 < n) (hdim : Module.finrank ℝ D + n = Module.finrank ℝ E)
+    (hE : 2 ≤ Module.finrank ℝ E) :
+    ∃ P : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞,
+      Smale.SupportedDiffeomorph.IsotopicToIdentity P ∧
+        ∀ x ∈ Metric.closedBall (0 : D) 1, P (f x) = g x :=
+  exists_embedded_disk_isotopy_of_path hf hg hfi hgi hfd hgd n hn hdim hE
+    (Joined.somePath (PathConnectedSpace.joined (f 0) (g 0)))
+
+private theorem MorseCancel.exists_embedded_avoidance_into_level_basin {E M A : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [FiniteDimensional ℝ A] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a : ℝ}
+    (hreg : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f) {d : ℕ}
+    (hhigh :
+      ∀ p : Smale.ManifoldMorse.criticalPoints E f,
+        a ≤ f p → Module.finrank ℝ E - nativeMorseIndex E f p ≤ d)
+    (hlow : ∀ p : Smale.ManifoldMorse.criticalPoints E f, f p ≤ a → nativeMorseIndex E f p ≤ d)
+    (f₀ : C(A, M)) (hf₀ : ContMDiff 𝓘(ℝ, A) 𝓘(ℝ, E) ∞ f₀)
+    (hself : 2 * Module.finrank ℝ A < Module.finrank ℝ E)
+    (hobstacle : Module.finrank ℝ A + d < Module.finrank ℝ E) {K L C : Set A} (hK : IsCompact K)
+    (hL : IsCompact L) (hC : IsClosed C) (hinj : Set.InjOn f₀ K)
+    (hderiv : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, A) 𝓘(ℝ, E) f₀ x))
+    (hfixed : ∀ x ∈ L ∩ C, f₀ x ∈ Degree.FlowCancellation.levelBasin S.flow f a) :
+    ∃ g : C(A, M),
+      ContMDiff 𝓘(ℝ, A) 𝓘(ℝ, E) ∞ g ∧
+        f₀.HomotopicRel g C ∧
+          Topology.IsClosedEmbedding (fun x : K => g x) ∧
+            (∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, A) 𝓘(ℝ, E) g x)) ∧
+              (∀ x y, g x = g y → f₀ x = f₀ y) ∧
+                ∀ x,
+                  (f₀ x ∈ Degree.FlowCancellation.levelBasin S.flow f a ∨ x ∈ L) →
+                    g x ∈ Degree.FlowCancellation.levelBasin S.flow f a := by
+  let _ := S.finite.fintype
+  let J := EndpointBasinIndex (E := E) (f := f) a
+  let Z := EuclideanSpace ℝ (Fin 0)
+  let V := EuclideanSpace ℝ (Fin d)
+  let _ : Countable J := endpointBasinIndex_countable S a
+  let _ : DiscreteTopology J := inferInstance
+  let _ : ChartedSpace Z J := ChartedSpace.ofDiscreteTopology
+  let _ : IsManifold 𝓘(ℝ, Z) ∞ J := IsManifold.of_discreteTopology ∞
+  obtain ⟨b, hb, hcover⟩ := S.exists_endpoint_obstruction_global_images hf a hhigh hlow
+  have hs : ContMDiff (𝓘(ℝ, Z).prod 𝓘(ℝ, V)) 𝓘(ℝ, E) ∞ (fun p : J × V => b p.1 p.2) :=
+    contMDiff_discrete_family b hb
+  let B : C(J × V, M) := ⟨fun p => b p.1 p.2, hs.continuous⟩
+  have hrange : Set.range B = (Degree.FlowCancellation.levelBasin S.flow f a)ᶜ := by
+    rw [levelBasin_compl_eq_endpoint_obstruction S hf hreg, hcover]
+    exact range_discrete_family b
+  have hclosed : IsClosed (Set.range B) := by
+    rw [hrange, levelBasin_compl_eq_endpoint_obstruction S hf hreg]
+    exact isClosed_endpoint_obstruction S hf a
+  have hdim : Module.finrank ℝ A + Module.finrank ℝ (Z × V) < Module.finrank ℝ E := by
+    simpa only [Z, V, Module.finrank_prod, finrank_euclideanSpace_fin, zero_add] using hobstacle
+  have hfixed' : ∀ x ∈ L ∩ C, f₀ x ∉ Set.range B := by
+    intro x hx
+    rw [hrange, Set.mem_compl_iff, Classical.not_not]
+    exact hfixed x hx
+  obtain ⟨g, hg, hhom, hemb, hder, hnoNew, havoid⟩ :=
+    Smale.ManifoldImmersion.exists_embedded_avoidance_on_compact_of_isClosed_range f₀ B hf₀ hs
+      hclosed hself hdim hK hL hC hinj hderiv hfixed'
+  refine ⟨g, hg, hhom, hemb, hder, hnoNew, ?_⟩
+  intro x hx
+  have hx' : f₀ x ∉ Set.range B ∨ x ∈ L := by
+    simpa only [hrange, Set.mem_compl_iff, Classical.not_not] using hx
+  simpa only [hrange, Set.mem_compl_iff, Classical.not_not] using havoid x hx'
+
+private theorem Smale.SphereBoundary.exists_extension_immersive_on_sphere {E G H N : Type*}
+    [NormedAddCommGroup E] [InnerProductSpace ℝ E] [FiniteDimensional ℝ E] {n : ℕ}
+    [Fact (Module.finrank ℝ E = n + 1)] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [FiniteDimensional ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [J.Boundaryless]
+    [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] {f : E → N}
+    (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) {γ : Metric.sphere (0 : E) 1 → N}
+    (hext : ∀ x : Metric.sphere (0 : E) 1, f x.1 = γ x)
+    (hγ : ∀ x, Function.Injective (mfderiv (𝓡 n) J γ x))
+    (hdim : n + Module.finrank ℝ E < Module.finrank ℝ G) :
+    ∃ g : C(E, N),
+      ContMDiff 𝓘(ℝ, E) J ∞ g ∧
+        (∀ x : Metric.sphere (0 : E) 1, g x.1 = γ x) ∧
+          ∀ x : Metric.sphere (0 : E) 1, Function.Injective (mfderiv 𝓘(ℝ, E) J g x.1) := by
+  have hb : ContMDiff (𝓡 n) 𝓘(ℝ, E) ∞ (Subtype.val : Metric.sphere (0 : E) 1 → E) :=
+    contMDiff_coe_sphere
+  have hzero (x : Metric.sphere (0 : E) 1) : definingFunction x.1 = 0 :=
+    (definingFunction_eq_zero_iff x.1).mpr x.property
+  have hd :
+    Module.finrank ℝ (EuclideanSpace ℝ (Fin n)) + Module.finrank ℝ E < Module.finrank ℝ G := by
+    simpa only [finrank_euclideanSpace_fin] using hdim
+  obtain ⟨g, hg, hhom, hderiv⟩ :=
+    Smale.ManifoldImmersion.exists_compact_boundary_derivative_repair
+      (⟨f, hf.continuous⟩ : C(E, N)) hf hb contDiff_definingFunction hzero hd
+      (common_kernel_of_immersive_sphere_extension hf hext hγ)
+  refine ⟨g, hg, ?_, ?_⟩
+  · intro x
+    exact (hhom.fst_eq_snd (hzero x)).symm.trans (hext x)
+  · intro x
+    exact hderiv x.1 ⟨x, rfl⟩
+
+private theorem Smale.exists_embedded_disk_extension_of_smooth_extension {G H N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] [T2Space N] {f : Hemisphere.Ambient 2 → N}
+    (hf : ContMDiff 𝓘(ℝ, Hemisphere.Ambient 2) J ∞ f) {γ : Hemisphere.Sphere 1 → N}
+    (hext : ∀ x : Hemisphere.Sphere 1, f x.1 = γ x) (hγinj : Function.Injective γ)
+    (hγderiv : ∀ x, Function.Injective (mfderiv (𝓡 1) J γ x)) (hdim : 5 ≤ Module.finrank ℝ G) :
+    ∃ g : C(Hemisphere.Ambient 2, N),
+      ContMDiff 𝓘(ℝ, Hemisphere.Ambient 2) J ∞ g ∧
+        (∀ x : Hemisphere.Sphere 1, g x.1 = γ x) ∧
+          Topology.IsClosedEmbedding (fun x : Hemisphere.Ball 2 => g x.1) ∧
+            ∀ x : Hemisphere.Ball 2,
+              Function.Injective (mfderiv 𝓘(ℝ, Hemisphere.Ambient 2) J g x.1) := by
+  let : Fact (Module.finrank ℝ (Hemisphere.Ambient 2) = 1 + 1) :=
+    ⟨by simp only [Hemisphere.Ambient, finrank_euclideanSpace_fin]⟩
+  have hd : 1 + Module.finrank ℝ (Hemisphere.Ambient 2) < Module.finrank ℝ G := by
+    simp only [Hemisphere.Ambient, finrank_euclideanSpace_fin]
+    omega
+  obtain ⟨f₁, hf₁, hboundary₁, hderiv₁⟩ :=
+    SphereBoundary.exists_extension_immersive_on_sphere (n := 1) hf hext hγderiv hd
+  let K : Set (Hemisphere.Ambient 2) := Metric.closedBall 0 1
+  let C : Set (Hemisphere.Ambient 2) := Metric.sphere 0 1
+  have hK : IsCompact K := ProperSpace.isCompact_closedBall 0 1
+  have hC : IsClosed C := Metric.isClosed_sphere
+  have hfixed : Set.InjOn f₁ (K ∩ C) := by
+    intro x hx y hy hxy
+    let xs : Hemisphere.Sphere 1 := ⟨x, hx.2⟩
+    let ys : Hemisphere.Sphere 1 := ⟨y, hy.2⟩
+    have hboundaryeq : γ xs = γ ys := (hboundary₁ xs).symm.trans (hxy.trans (hboundary₁ ys))
+    exact congrArg Subtype.val (hγinj hboundaryeq)
+  have hderiv : ∀ x ∈ K ∩ C, Function.Injective (mfderiv 𝓘(ℝ, Hemisphere.Ambient 2) J f₁ x) :=
+    fun x hx => hderiv₁ ⟨x, hx.2⟩
+  obtain ⟨g, hg, hhom, hemb, hderivg⟩ :=
+    ManifoldImmersion.exists_relative_compact_embedding_twoDimensional f₁ hf₁
+      (by simp only [Hemisphere.Ambient, finrank_euclideanSpace_fin]) hdim hK hC hfixed hderiv
+  refine ⟨g, hg, ?_, hemb, fun x => hderivg x.1 x.property⟩
+  intro x
+  exact (hhom.fst_eq_snd x.property).symm.trans (hboundary₁ x)
+
+private def Smale.RadialFilling.direction {n : ℕ} (b : Smale.Hemisphere.Sphere n)
+    (v : Smale.Hemisphere.Ambient (n + 1)) : Smale.Hemisphere.Sphere n := by
+  classical
+    exact
+    if hv : v = 0 then b
+    else
+      ⟨NormedSpace.normalize v, by
+        simpa only [Metric.mem_sphere, dist_zero_right] using NormedSpace.norm_normalize hv⟩
+
+private theorem Smale.RadialFilling.direction_coe {n : ℕ} (b : Smale.Hemisphere.Sphere n)
+    {v : Smale.Hemisphere.Ambient (n + 1)} (hv : v ≠ 0) :
+    (direction b v : Smale.Hemisphere.Ambient (n + 1)) = NormedSpace.normalize v := by
+  classical simp only [direction, dite_eq_right hv]
+
+private theorem
+    Smale.RadialFilling.direction_of_mem_sphere {n : ℕ} (b v : Smale.Hemisphere.Sphere n) :
+    direction b v.1 = v := by
+  have hn : ‖v.1‖ = 1 := mem_sphere_zero_iff_norm.mp v.2
+  have hv : v.1 ≠ 0 := by intro h; simp [h] at hn
+  apply Subtype.ext
+  rw [direction_coe b hv, NormedSpace.normalize_eq_self_of_norm_eq_one hn]
+
+private theorem Smale.RadialFilling.contMDiffAt_direction {n : ℕ} (b : Smale.Hemisphere.Sphere n)
+    {v : Smale.Hemisphere.Ambient (n + 1)} (hv : v ≠ 0) :
+    ContMDiffAt 𝓘(ℝ, Smale.Hemisphere.Ambient (n + 1)) (𝓡 n) ∞ (direction b) v := by
+  let V : TopologicalSpace.Opens (Smale.Hemisphere.Ambient (n + 1)) :=
+    ⟨{w | w ≠ 0}, isOpen_ne_fun continuous_id continuous_const⟩
+  have : Fact (Module.finrank ℝ (Smale.Hemisphere.Ambient (n + 1)) = n + 1) :=
+    ⟨finrank_euclideanSpace_fin⟩
+  have hnorm :
+    ContMDiff 𝓘(ℝ, Smale.Hemisphere.Ambient (n + 1)) 𝓘(ℝ, Smale.Hemisphere.Ambient (n + 1)) ∞
+      (fun w : V => NormedSpace.normalize (w : Smale.Hemisphere.Ambient (n + 1))) :=
+    NoExotic.contMDiff_normalize contMDiff_subtype_val (fun w => w.2)
+  have hmem (w : V) :
+    NormedSpace.normalize (w : Smale.Hemisphere.Ambient (n + 1)) ∈
+      Metric.sphere (0 : Smale.Hemisphere.Ambient (n + 1)) 1 := by
+    simpa only [Metric.mem_sphere, dist_zero_right] using NormedSpace.norm_normalize w.2
+  have hsphere := hnorm.codRestrict_sphere (n := n) hmem
+  have hs :
+    ContMDiff 𝓘(ℝ, Smale.Hemisphere.Ambient (n + 1)) (𝓡 n) ∞ (fun w : V => direction b w.1) := by
+    apply hsphere.congr
+    intro w
+    exact Subtype.ext (direction_coe b w.2)
+  exact (contMDiffAt_subtype_iff (U := V) (f := direction b) (x := ⟨v, hv⟩)).mp (hs ⟨v, hv⟩)
+
+private def Smale.RadialFilling.radialTime {n : ℕ} (v : Smale.Hemisphere.Ambient (n + 1)) :
+    unitInterval :=
+  Set.projIcc 0 1 zero_le_one (1 - ‖v‖)
+
+private theorem Smale.RadialFilling.coe_radialTime {n : ℕ} (v : Smale.Hemisphere.Ambient (n + 1)) :
+    (radialTime v : ℝ) = Max.max 0 (Min.min 1 (1 - ‖v‖)) :=
+  rfl
+
+private theorem
+    Smale.RadialFilling.radialTime_le_quarter {n : ℕ} {v : Smale.Hemisphere.Ambient (n + 1)}
+    (hv : 3 / 4 ≤ ‖v‖) : (radialTime v : ℝ) ≤ 1 / 4 := by
+  rw [coe_radialTime]
+  exact max_le (by norm_num) ((min_le_right _ _).trans (by linarith))
+
+private theorem Smale.RadialFilling.three_quarters_le_radialTime {n : ℕ}
+    {v : Smale.Hemisphere.Ambient (n + 1)} (hv : ‖v‖ ≤ 1 / 4) : 3 / 4 ≤ (radialTime v : ℝ) := by
+  rw [coe_radialTime]
+  exact le_max_of_le_right (le_min (by norm_num) (by linarith))
+
+private theorem
+    Smale.RadialFilling.contMDiffAt_radialTime {n : ℕ} {v : Smale.Hemisphere.Ambient (n + 1)}
+    (hv : 0 < ‖v‖) (hunit : ‖v‖ < 1) :
+    ContMDiffAt 𝓘(ℝ, Smale.Hemisphere.Ambient (n + 1)) (𝓡∂ 1) ∞ radialTime v := by
+  have : Fact ((0 : ℝ) < 1) := ⟨zero_lt_one⟩
+  have hp : ContMDiffOn 𝓘(ℝ, ℝ) (𝓡∂ 1) ∞ (Set.projIcc (0 : ℝ) 1 zero_le_one) (Set.Icc 0 1) :=
+    contMDiffOn_projIcc
+  have hm : 1 - ‖v‖ ∈ Set.Icc (0 : ℝ) 1 := ⟨by linarith, by linarith⟩
+  have hn : Set.Icc (0 : ℝ) 1 ∈ 𝓝 (1 - ‖v‖) := Icc_mem_nhds (by linarith) (by linarith)
+  have hproj := (hp _ hm).contMDiffAt hn
+  have hnorm : ContDiffAt ℝ ∞ (Norm.norm : Smale.Hemisphere.Ambient (n + 1) → ℝ) v :=
+    contDiffAt_norm ℝ (norm_pos_iff.mp hv)
+  exact hproj.comp v (contDiffAt_const.sub hnorm).contMDiffAt
+
+private def Smale.RadialFilling.filling {n : ℕ} {M : Type*} [TopologicalSpace M]
+    {f : C(Smale.Hemisphere.Sphere n, M)} {c : M} (H : f.Homotopy (ContinuousMap.const _ c))
+    (b : Smale.Hemisphere.Sphere n) (v : Smale.Hemisphere.Ambient (n + 1)) : M :=
+  H (radialTime v, direction b v)
+
+private theorem Smale.RadialFilling.filling_eq_center {n : ℕ} {M : Type*} [TopologicalSpace M]
+    {f : C(Smale.Hemisphere.Sphere n, M)} {c : M} (H : f.Homotopy (ContinuousMap.const _ c))
+    (b : Smale.Hemisphere.Sphere n)
+    (htop : ∀ t : unitInterval, ∀ x, 3 / 4 ≤ (t : ℝ) → H (t, x) = c)
+    {v : Smale.Hemisphere.Ambient (n + 1)} (hv : ‖v‖ ≤ 1 / 4) : filling H b v = c :=
+  htop _ _ (three_quarters_le_radialTime hv)
+
+private theorem Smale.RadialFilling.filling_eq_boundary {n : ℕ} {M : Type*} [TopologicalSpace M]
+    {f : C(Smale.Hemisphere.Sphere n, M)} {c : M} (H : f.Homotopy (ContinuousMap.const _ c))
+    (b : Smale.Hemisphere.Sphere n)
+    (hbottom : ∀ t : unitInterval, ∀ x, (t : ℝ) ≤ 1 / 4 → H (t, x) = f x)
+    {v : Smale.Hemisphere.Ambient (n + 1)} (hv : 3 / 4 ≤ ‖v‖) :
+    filling H b v = f (direction b v) :=
+  hbottom _ _ (radialTime_le_quarter hv)
+
+private theorem Smale.RadialFilling.filling_on_sphere {n : ℕ} {M : Type*} [TopologicalSpace M]
+    {f : C(Smale.Hemisphere.Sphere n, M)} {c : M} (H : f.Homotopy (ContinuousMap.const _ c))
+    (b : Smale.Hemisphere.Sphere n)
+    (hbottom : ∀ t : unitInterval, ∀ x, (t : ℝ) ≤ 1 / 4 → H (t, x) = f x)
+    (v : Smale.Hemisphere.Sphere n) : filling H b v.1 = f v := by
+  have hn : ‖v.1‖ = 1 := mem_sphere_zero_iff_norm.mp v.2
+  rw [filling_eq_boundary H b hbottom (by rw [hn]; norm_num), direction_of_mem_sphere]
+
+private theorem Smale.RadialFilling.contMDiff_filling {n : ℕ} {G K M : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace K] {J : ModelWithCorners ℝ G K} [TopologicalSpace M]
+    [ChartedSpace K M] {f : C(Smale.Hemisphere.Sphere n, M)} {c : M}
+    (H : f.Homotopy (ContinuousMap.const _ c)) (b : Smale.Hemisphere.Sphere n)
+    (hf : ContMDiff (𝓡 n) J ∞ f) (hH : ContMDiff ((𝓡∂ 1).prod (𝓡 n)) J ∞ H)
+    (hbottom : ∀ t : unitInterval, ∀ x, (t : ℝ) ≤ 1 / 4 → H (t, x) = f x)
+    (htop : ∀ t : unitInterval, ∀ x, 3 / 4 ≤ (t : ℝ) → H (t, x) = c) :
+    ContMDiff 𝓘(ℝ, Smale.Hemisphere.Ambient (n + 1)) J ∞ (filling H b) := by
+  intro v
+  by_cases hinner : ‖v‖ < 1 / 4
+  · apply (contMDiffAt_const (c := c)).congr_of_eventuallyEq
+    have hn : {w : Smale.Hemisphere.Ambient (n + 1) | ‖w‖ < 1 / 4} ∈ 𝓝 v :=
+      (isOpen_lt continuous_norm continuous_const).mem_nhds hinner
+    filter_upwards [hn] with w hw
+    exact filling_eq_center H b htop (le_of_lt hw)
+  · by_cases houter : 3 / 4 < ‖v‖
+    · have hv : v ≠ 0 := norm_pos_iff.mp (by linarith)
+      have hs := (hf (direction b v)).comp v (contMDiffAt_direction b hv)
+      apply hs.congr_of_eventuallyEq
+      have hn : {w : Smale.Hemisphere.Ambient (n + 1) | 3 / 4 < ‖w‖} ∈ 𝓝 v :=
+        (isOpen_lt continuous_const continuous_norm).mem_nhds houter
+      filter_upwards [hn] with w hw
+      exact filling_eq_boundary H b hbottom (le_of_lt hw)
+    · have hv : 0 < ‖v‖ := by linarith [le_of_not_gt hinner]
+      have hunit : ‖v‖ < 1 := by linarith [le_of_not_gt houter]
+      exact
+        (hH (radialTime v, direction b v)).comp v (f := fun w => (radialTime w, direction b w))
+          ((contMDiffAt_radialTime hv hunit).prodMk
+            (contMDiffAt_direction b (norm_pos_iff.mp hv)))
+
+private theorem Smale.exists_smooth_nullhomotopy_of_homotopySixSphere {E G H X M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [I.Boundaryless]
+    [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X] [T2Space X] [CompactSpace X]
+    [TopologicalSpace M] [ChartedSpace G M] [IsManifold 𝓘(ℝ, G) ∞ M] (e : M ≃ₕ Smale.SixSphere)
+    (hdim : Module.finrank ℝ E < 6) (f : C(X, M)) (hf : ContMDiff I 𝓘(ℝ, G) ∞ f) :
+    ∃ c : M,
+      ∃ H : f.Homotopy (ContinuousMap.const X c),
+        ContMDiff ((𝓡∂ 1).prod I) 𝓘(ℝ, G) ∞ H ∧
+          (∀ t : unitInterval, ∀ x, (t : ℝ) ≤ 1 / 4 → H (t, x) = f x) ∧
+            (∀ t : unitInterval, ∀ x, 3 / 4 ≤ (t : ℝ) → H (t, x) = c) := by
+  obtain ⟨c, ⟨H⟩⟩ := manifoldMap_nullhomotopic_of_homotopySixSphere (I := I) e hdim f
+  obtain ⟨H', hH', hlo, hhi⟩ :=
+    ManifoldSmoothing.exists_smooth_homotopy_with_collars hf contMDiff_const H
+  exact ⟨c, H', hH', hlo, hhi⟩
+
+private theorem Smale.exists_smooth_disk_extension_of_homotopySixSphere {G M : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace M] [ChartedSpace G M]
+    [IsManifold 𝓘(ℝ, G) ∞ M] (e : M ≃ₕ Smale.SixSphere) {n : ℕ} (hn : n < 6)
+    (f : C(Hemisphere.Sphere n, M)) (hf : ContMDiff (𝓡 n) 𝓘(ℝ, G) ∞ f) :
+    ∃ (c : M) (F : Hemisphere.Ambient (n + 1) → M),
+      ContMDiff 𝓘(ℝ, Hemisphere.Ambient (n + 1)) 𝓘(ℝ, G) ∞ F ∧
+        (∀ v : Hemisphere.Sphere n, F v.1 = f v) ∧ ∀ v, ‖v‖ ≤ 1 / 4 → F v = c := by
+  have hd : Module.finrank ℝ (EuclideanSpace ℝ (Fin n)) < 6 := by
+    simpa only [finrank_euclideanSpace_fin] using hn
+  obtain ⟨c, H, hH, hlo, hhi⟩ := exists_smooth_nullhomotopy_of_homotopySixSphere e hd f hf
+  obtain ⟨v, hv⟩ : (Hemisphere.Sphere n).Nonempty := NormedSpace.sphere_nonempty.mpr zero_le_one
+  let b : Hemisphere.Sphere n := ⟨v, hv⟩
+  exact
+    ⟨c, RadialFilling.filling H b, RadialFilling.contMDiff_filling H b hf hH hlo hhi,
+      RadialFilling.filling_on_sphere H b hlo, fun _ hv =>
+      RadialFilling.filling_eq_center H b hhi hv⟩
+
+private theorem Smale.exists_embedded_disk_of_homotopySixSphere {G M : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace M] [ChartedSpace G M]
+    [IsManifold 𝓘(ℝ, G) ∞ M] [T2Space M] (e : M ≃ₕ Smale.SixSphere)
+    (hdim : Module.finrank ℝ G = 6) (γ : C(Hemisphere.Sphere 1, M))
+    (hγ : ContMDiff (𝓡 1) 𝓘(ℝ, G) ∞ γ) (hγinj : Function.Injective γ)
+    (hγderiv : ∀ x, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, G) γ x)) :
+    ∃ g : C(Hemisphere.Ambient 2, M),
+      ContMDiff 𝓘(ℝ, Hemisphere.Ambient 2) 𝓘(ℝ, G) ∞ g ∧
+        (∀ x : Hemisphere.Sphere 1, g x.1 = γ x) ∧
+          Topology.IsClosedEmbedding (fun x : Hemisphere.Ball 2 => g x.1) ∧
+            ∀ x : Hemisphere.Ball 2,
+              Function.Injective (mfderiv 𝓘(ℝ, Hemisphere.Ambient 2) 𝓘(ℝ, G) g x.1) := by
+  obtain ⟨-, f, hf, hext, -⟩ :=
+    exists_smooth_disk_extension_of_homotopySixSphere e (n := 1) (by decide) γ hγ
+  exact exists_embedded_disk_extension_of_smooth_extension hf hext hγinj hγderiv (by omega)
+
+private theorem
+    MorseCancel.exists_disk_in_level_basin_of_index_cut {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (e : M ≃ₕ Smale.SixSphere)
+    (hdim : Module.finrank ℝ E = 6) {a : ℝ}
+    (hreg : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hhigh : ∀ p : Smale.ManifoldMorse.criticalPoints E f, a ≤ f p → 3 ≤ nativeMorseIndex E f p)
+    (hlow : ∀ p : Smale.ManifoldMorse.criticalPoints E f, f p ≤ a → nativeMorseIndex E f p ≤ 3)
+    (γ : C(Smale.Hemisphere.Sphere 1, M)) (hγ : ContMDiff (𝓡 1) 𝓘(ℝ, E) ∞ γ)
+    (hγinj : Function.Injective γ) (hγderiv : ∀ x, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, E) γ x))
+    (hlevel : ∀ z, f (γ z) = a) :
+    ∃ g : C(Smale.Hemisphere.Ambient 2, M),
+      ContMDiff 𝓘(ℝ, Smale.Hemisphere.Ambient 2) 𝓘(ℝ, E) ∞ g ∧
+        (∀ z : Smale.Hemisphere.Sphere 1, g z.val = γ z) ∧
+          Topology.IsClosedEmbedding (fun z : Smale.Hemisphere.Ball 2 => g z.val) ∧
+            (∀ z : Smale.Hemisphere.Ball 2,
+                Function.Injective (mfderiv 𝓘(ℝ, Smale.Hemisphere.Ambient 2) 𝓘(ℝ, E) g z.val)) ∧
+              ∀ z : Smale.Hemisphere.Ball 2,
+                g z.val ∈ Degree.FlowCancellation.levelBasin S.flow f a := by
+  obtain ⟨g₀, hg₀, hboundary, hemb, hderiv⟩ :=
+    Smale.exists_embedded_disk_of_homotopySixSphere e hdim γ hγ hγinj hγderiv
+  let K : Set (Smale.Hemisphere.Ambient 2) := Metric.closedBall 0 1
+  let C : Set (Smale.Hemisphere.Ambient 2) := Metric.sphere 0 1
+  have hK : IsCompact K := ProperSpace.isCompact_closedBall _ _
+  have hC : IsClosed C := Metric.isClosed_sphere
+  have hinj : Set.InjOn g₀ K := by
+    intro x hx y hy hxy
+    exact congrArg Subtype.val (hemb.injective (a₁ := ⟨x, hx⟩) (a₂ := ⟨y, hy⟩) hxy)
+  have hfixed (z : Smale.Hemisphere.Ambient 2) (hz : z ∈ K ∩ C) :
+    g₀ z ∈ Degree.FlowCancellation.levelBasin S.flow f a := by
+    refine ⟨0, ?_⟩
+    rw [S.flow.map_zero_apply, hboundary ⟨z, hz.2⟩, hlevel]
+  have hhigh' (p : Smale.ManifoldMorse.criticalPoints E f) (hp : a ≤ f p) :
+    Module.finrank ℝ E - nativeMorseIndex E f p ≤ 3 := by
+    have hh := hhigh p hp
+    omega
+  obtain ⟨g, hg, hhom, hembg, hderg, -, hbasin⟩ :=
+    exists_embedded_avoidance_into_level_basin S hf hreg hhigh' hlow g₀ hg₀
+      (by simp only [Smale.Hemisphere.Ambient, finrank_euclideanSpace_fin]; omega)
+      (by simp only [Smale.Hemisphere.Ambient, finrank_euclideanSpace_fin]; omega) hK hK hC hinj
+      (fun z hz => hderiv ⟨z, hz⟩) hfixed
+  refine ⟨g, hg, ?_, hembg, fun z => hderg z.val z.property, ?_⟩
+  · intro z
+    exact (hhom.fst_eq_snd z.property).symm.trans (hboundary z)
+  · intro z
+    exact hbasin z.val (Or.inr z.property)
+
+private theorem MorseCancel.exists_actual_regular_level_disk_of_index_cut {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (e : M ≃ₕ Smale.SixSphere)
+    (hdim : Module.finrank ℝ E = 6) {a : ℝ}
+    (hreg : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hhigh : ∀ p : Smale.ManifoldMorse.criticalPoints E f, a ≤ f p → 3 ≤ nativeMorseIndex E f p)
+    (hlow : ∀ p : Smale.ManifoldMorse.criticalPoints E f, f p ≤ a → nativeMorseIndex E f p ≤ 3)
+    (γ : C(Smale.Hemisphere.Sphere 1, M)) (hγ : ContMDiff (𝓡 1) 𝓘(ℝ, E) ∞ γ)
+    (hγinj : Function.Injective γ) (hγderiv : ∀ x, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, E) γ x))
+    (hlevel : ∀ z, f (γ z) = a) :
+    ∃ D : C(Smale.Hemisphere.Ball 2, { y : M // f y = a }),
+      ∀ z : Smale.Hemisphere.Sphere 1,
+        (D ⟨z.val, Metric.sphere_subset_closedBall z.property⟩).val = γ z := by
+  obtain ⟨g, hg, hboundary, -, -, hbasin⟩ :=
+    exists_disk_in_level_basin_of_index_cut S hf e hdim hreg hhigh hlow γ hγ hγinj hγderiv hlevel
+  obtain ⟨v, hv⟩ : (Metric.sphere (0 : Smale.Hemisphere.Ambient 2) 1).Nonempty :=
+    NormedSpace.sphere_nonempty.mpr zero_le_one
+  let z₀ : { y : M // f y = a } := ⟨γ ⟨v, hv⟩, hlevel ⟨v, hv⟩⟩
+  let _ := Smale.RegularLevel.chartedSpace hf hreg
+  obtain ⟨Φ, hsource, htarget, hformula, -⟩ :=
+    Degree.FlowCancellation.exists_native_level_flow_cylinder hf hreg S.smooth S.flow S.integral
+      (fun y hy => S.descent y (hreg y hy)) z₀
+  have hcont : Continuous (fun z : Smale.Hemisphere.Ball 2 => Φ.symm (g z.val)) :=
+    Φ.contMDiffOn_invFun.continuousOn.comp_continuous (g.continuous.comp continuous_subtype_val)
+      (fun z => htarget.symm ▸ hbasin z)
+  let D : C(Smale.Hemisphere.Ball 2, { y : M // f y = a }) :=
+    ⟨fun z => (Φ.symm (g z.val)).1, continuous_fst.comp hcont⟩
+  refine ⟨D, ?_⟩
+  intro z
+  let p : { y : M // f y = a } := ⟨γ z, hlevel z⟩
+  have hp : (p, (0 : ℝ)) ∈ Φ.source := by rw [hsource]; trivial
+  have hφ : Φ (p, 0) = γ z := by rw [hformula, S.flow.map_zero_apply]
+  have hi : Φ.symm (Φ (p, 0)) = (p, 0) := Φ.left_inv' hp
+  rw [hφ] at hi
+  change (Φ.symm (g z.val)).1.val = γ z
+  rw [hboundary z]
+  exact congrArg (fun q : { y : M // f y = a } × ℝ => q.1.val) hi
+
+private theorem MorseCancel.circle_nullhomotopy_of_disk {N : Type*} [TopologicalSpace N]
+    (γ : C(Smale.Hemisphere.Sphere 1, N)) (D : C(Smale.Hemisphere.Ball 2, N))
+    (hboundary :
+      ∀ z : Smale.Hemisphere.Sphere 1,
+        D ⟨z.val, Metric.sphere_subset_closedBall z.property⟩ = γ z) :
+    ∃ c : N, γ.Homotopic (ContinuousMap.const _ c) := by
+  let c := D ⟨0, Metric.mem_closedBall_self zero_le_one⟩
+  let H : γ.Homotopy (ContinuousMap.const _ c) :=
+    { toFun := fun p => D (Smale.DiskCone.point p)
+      continuous_toFun := D.continuous.comp Smale.DiskCone.continuous_point
+      map_zero_left := by
+        intro z
+        have he :
+          Smale.DiskCone.point (0, z) =
+            (⟨z.val, Metric.sphere_subset_closedBall z.property⟩ : Smale.Hemisphere.Ball 2) := by
+          apply Subtype.ext
+          simp [Smale.DiskCone.point]
+        rw [he]
+        exact hboundary z
+      map_one_left := by
+        intro z
+        have he :
+          Smale.DiskCone.point (1, z) =
+            (⟨0, Metric.mem_closedBall_self zero_le_one⟩ : Smale.Hemisphere.Ball 2) := by
+          apply Subtype.ext
+          simp [Smale.DiskCone.point]
+        exact congrArg D he }
+  exact ⟨c, ⟨H⟩⟩
+
+private theorem MorseCancel.exists_smooth_embedded_disk_of_continuous_filling {G N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace N]
+    [ChartedSpace G N] [IsManifold 𝓘(ℝ, G) ∞ N] [T2Space N] (γ : C(Smale.Hemisphere.Sphere 1, N))
+    (hγ : ContMDiff (𝓡 1) 𝓘(ℝ, G) ∞ γ) (hγinj : Function.Injective γ)
+    (hγderiv : ∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, G) γ z))
+    (hdim : 5 ≤ Module.finrank ℝ G) (D : C(Smale.Hemisphere.Ball 2, N))
+    (hboundary :
+      ∀ z : Smale.Hemisphere.Sphere 1,
+        D ⟨z.val, Metric.sphere_subset_closedBall z.property⟩ = γ z) :
+    ∃ g : C(Smale.Hemisphere.Ambient 2, N),
+      ContMDiff 𝓘(ℝ, Smale.Hemisphere.Ambient 2) 𝓘(ℝ, G) ∞ g ∧
+        (∀ z : Smale.Hemisphere.Sphere 1, g z.val = γ z) ∧
+          Topology.IsClosedEmbedding (fun z : Smale.Hemisphere.Ball 2 => g z.val) ∧
+            ∀ z : Smale.Hemisphere.Ball 2,
+              Function.Injective (mfderiv 𝓘(ℝ, Smale.Hemisphere.Ambient 2) 𝓘(ℝ, G) g z.val) := by
+  obtain ⟨c, ⟨H⟩⟩ := circle_nullhomotopy_of_disk γ D hboundary
+  obtain ⟨H', hH', hlo, hhi⟩ :=
+    Smale.ManifoldSmoothing.exists_smooth_homotopy_with_collars hγ contMDiff_const H
+  obtain ⟨v, hv⟩ : (Metric.sphere (0 : Smale.Hemisphere.Ambient 2) 1).Nonempty :=
+    NormedSpace.sphere_nonempty.mpr zero_le_one
+  let b : Smale.Hemisphere.Sphere 1 := ⟨v, hv⟩
+  have hsmooth := Smale.RadialFilling.contMDiff_filling H' b hγ hH' hlo hhi
+  have hext := Smale.RadialFilling.filling_on_sphere H' b hlo
+  exact Smale.exists_embedded_disk_extension_of_smooth_extension hsmooth hext hγinj hγderiv hdim
+
+private theorem MorseCancel.exists_embedded_regular_level_disk_of_index_cut {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (e : M ≃ₕ Smale.SixSphere)
+    (hdim : Module.finrank ℝ E = 6) {a : ℝ}
+    (hreg : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hhigh : ∀ p : Smale.ManifoldMorse.criticalPoints E f, a ≤ f p → 3 ≤ nativeMorseIndex E f p)
+    (hlow : ∀ p : Smale.ManifoldMorse.criticalPoints E f, f p ≤ a → nativeMorseIndex E f p ≤ 3)
+    (γ : C(Smale.Hemisphere.Sphere 1, M)) (hγ : ContMDiff (𝓡 1) 𝓘(ℝ, E) ∞ γ)
+    (hγinj : Function.Injective γ) (hγderiv : ∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, E) γ z))
+    (hlevel : ∀ z, f (γ z) = a) :
+    let _ := Smale.RegularLevel.chartedSpace hf hreg
+    ∃ g : C(Smale.Hemisphere.Ambient 2, { y : M // f y = a }),
+      ContMDiff 𝓘(ℝ, Smale.Hemisphere.Ambient 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g ∧
+        (∀ z : Smale.Hemisphere.Sphere 1, (g z.val).val = γ z) ∧
+          Topology.IsClosedEmbedding (fun z : Smale.Hemisphere.Ball 2 => g z.val) ∧
+            ∀ z : Smale.Hemisphere.Ball 2,
+              Function.Injective
+                (mfderiv 𝓘(ℝ, Smale.Hemisphere.Ambient 2) 𝓘(ℝ, Smale.RegularLevel.Model E) g
+                  z.val) := by
+  let _ := Smale.RegularLevel.chartedSpace hf hreg
+  let _ := Smale.RegularLevel.isManifold hf hreg
+  obtain ⟨D, hD⟩ :=
+    exists_actual_regular_level_disk_of_index_cut S hf e hdim hreg hhigh hlow γ hγ hγinj hγderiv
+      hlevel
+  let γL : C(Smale.Hemisphere.Sphere 1, { y : M // f y = a }) :=
+    ⟨fun z => ⟨γ z, hlevel z⟩, γ.continuous.subtype_mk _⟩
+  have hγL : ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ γL :=
+    (Smale.RegularLevel.contMDiff_iff_inclusion hf hreg (𝓡 1) γL).mpr hγ
+  have hinj : Function.Injective γL := fun x y hxy => hγinj (congrArg Subtype.val hxy)
+  have hderiv (z : Smale.Hemisphere.Sphere 1) :
+    Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) γL z) :=
+    Smale.RegularLevel.injective_mfderiv_of_inclusion hf hreg (𝓡 1) γL z hγ.contMDiffAt
+      (hγderiv z)
+  have hdimL : 5 ≤ Module.finrank ℝ (Smale.RegularLevel.Model E) := by
+    simp only [Smale.RegularLevel.Model, finrank_euclideanSpace_fin, hdim]
+    norm_num
+  have hboundary (z : Smale.Hemisphere.Sphere 1) :
+    D ⟨z.val, Metric.sphere_subset_closedBall z.property⟩ = γL z := Subtype.ext (hD z)
+  obtain ⟨g, hg, hboundaryg, hemb, hderivg⟩ :=
+    exists_smooth_embedded_disk_of_continuous_filling γL hγL hinj hderiv hdimL D hboundary
+  exact ⟨g, hg, fun z => congrArg Subtype.val (hboundaryg z), hemb, hderivg⟩
+
+private theorem
+    MorseCancel.exists_native_middle_level_circle_disk {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (e : M ≃ₕ Smale.SixSphere)
+    (hdim : Module.finrank ℝ E = 6) {a : ℝ}
+    (hreg : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hhigh : ∀ p : Smale.ManifoldMorse.criticalPoints E f, a ≤ f p → 3 ≤ nativeMorseIndex E f p)
+    (hlow : ∀ p : Smale.ManifoldMorse.criticalPoints E f, f p ≤ a → nativeMorseIndex E f p ≤ 3)
+    (γ : C(Smale.Hemisphere.Sphere 1, { y : M // f y = a })) :
+    let _ := Smale.RegularLevel.chartedSpace hf hreg
+    ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ γ →
+      Function.Injective γ →
+        (∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) γ z)) →
+          ∃ g : C(Smale.Hemisphere.Ambient 2, { y : M // f y = a }),
+            ContMDiff 𝓘(ℝ, Smale.Hemisphere.Ambient 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g ∧
+              (∀ z : Smale.Hemisphere.Sphere 1, g z.val = γ z) ∧
+                Topology.IsClosedEmbedding (fun z : Smale.Hemisphere.Ball 2 => g z.val) ∧
+                  (∀ z : Smale.Hemisphere.Ball 2,
+                    Function.Injective
+                      (mfderiv 𝓘(ℝ, Smale.Hemisphere.Ambient 2) 𝓘(ℝ, Smale.RegularLevel.Model E) g
+                        z.val)) := by
+  let _ := Smale.RegularLevel.chartedSpace hf hreg
+  let _ := Smale.RegularLevel.isManifold hf hreg
+  change
+    ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ γ →
+      Function.Injective γ →
+        (∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) γ z)) → _
+  intro hγ hγi hγd
+  let γM : C(Smale.Hemisphere.Sphere 1, M) :=
+    ⟨Subtype.val ∘ γ, continuous_subtype_val.comp γ.continuous⟩
+  have hγM : ContMDiff (𝓡 1) 𝓘(ℝ, E) ∞ γM :=
+    (Smale.RegularLevel.contMDiff_inclusion hf hreg).comp hγ
+  have hγMi : Function.Injective γM := Subtype.val_injective.comp hγi
+  have hγMd : ∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, E) γM z) := by
+    intro z
+    change Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, E) (Subtype.val ∘ γ) z)
+    rw [mfderiv_comp z
+        ((Smale.RegularLevel.contMDiff_inclusion hf hreg).mdifferentiableAt (by simp))
+        (hγ.mdifferentiableAt (by simp))]
+    exact (Smale.RegularLevel.injective_mfderiv_inclusion hf hreg (γ z)).comp (hγd z)
+  obtain ⟨g, hg, hb, hemb, hgd⟩ :=
+    exists_embedded_regular_level_disk_of_index_cut S hf e hdim hreg hhigh hlow γM hγM hγMi hγMd
+      (fun z => (γ z).property)
+  exact ⟨g, hg, fun z => Subtype.ext (hb z), hemb, hgd⟩
+
+private theorem
+    MorseCancel.exists_native_middle_level_circle_isotopy {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} [PathConnectedSpace M]
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (e : M ≃ₕ Smale.SixSphere)
+    (hdim : Module.finrank ℝ E = 6) {a : ℝ}
+    (hreg : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hhigh : ∀ p : Smale.ManifoldMorse.criticalPoints E f, a ≤ f p → 3 ≤ nativeMorseIndex E f p)
+    (hlow : ∀ p : Smale.ManifoldMorse.criticalPoints E f, f p ≤ a → nativeMorseIndex E f p ≤ 3)
+    (γ δ : C(Smale.Hemisphere.Sphere 1, { y : M // f y = a })) :
+    let _ := Smale.RegularLevel.chartedSpace hf hreg
+    ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ γ →
+      Function.Injective γ →
+        (∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) γ z)) →
+          ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ δ →
+            Function.Injective δ →
+              (∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) δ z)) →
+                ∃ P :
+                  Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+                    { y : M // f y = a } { y : M // f y = a } ∞,
+                  Smale.SupportedDiffeomorph.IsotopicToIdentity P ∧ ∀ z, P (γ z) = δ z := by
+  let _ := Smale.RegularLevel.chartedSpace hf hreg
+  let _ := Smale.RegularLevel.isManifold hf hreg
+  let _ : CompactSpace { y : M // f y = a } :=
+    isCompact_iff_compactSpace.mp (isClosed_eq hf.continuous continuous_const).isCompact
+  change
+    ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ γ →
+      Function.Injective γ →
+        (∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) γ z)) →
+          ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ δ →
+            Function.Injective δ →
+              (∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) δ z)) → _
+  intro hγ hγi hγd hδ hδi hδd
+  obtain ⟨g, hg, hgb, hge, hgd⟩ :=
+    exists_native_middle_level_circle_disk S hf e hdim hreg hhigh hlow γ hγ hγi hγd
+  obtain ⟨h, hh, hhb, hhe, hhd⟩ :=
+    exists_native_middle_level_circle_disk S hf e hdim hreg hhigh hlow δ hδ hδi hδd
+  let _ := S.pathConnectedSpace_middle_level hf hdim hreg hhigh hlow (g 0)
+  have hgi : Set.InjOn g (Metric.closedBall (0 : Smale.Hemisphere.Ambient 2) 1) := by
+    intro x hx y hy hxy
+    exact congrArg Subtype.val (hge.injective (a₁ := ⟨x, hx⟩) (a₂ := ⟨y, hy⟩) hxy)
+  have hhi : Set.InjOn h (Metric.closedBall (0 : Smale.Hemisphere.Ambient 2) 1) := by
+    intro x hx y hy hxy
+    exact congrArg Subtype.val (hhe.injective (a₁ := ⟨x, hx⟩) (a₂ := ⟨y, hy⟩) hxy)
+  have hcodim :
+    Module.finrank ℝ (Smale.Hemisphere.Ambient 2) + 3 =
+      Module.finrank ℝ (Smale.RegularLevel.Model E) := by
+    simp only [Smale.Hemisphere.Ambient, Smale.RegularLevel.Model, finrank_euclideanSpace_fin,
+      hdim]
+  have hmodel : 2 ≤ Module.finrank ℝ (Smale.RegularLevel.Model E) := by
+    simp only [Smale.RegularLevel.Model, finrank_euclideanSpace_fin, hdim]
+    omega
+  obtain ⟨P, hP, hformula⟩ :=
+    Degree.DiskShrinking.exists_embedded_disk_isotopy hg hh hgi hhi (fun x hx => hgd ⟨x, hx⟩)
+      (fun x hx => hhd ⟨x, hx⟩) 3 (by omega) hcodim hmodel
+  refine ⟨P, hP, ?_⟩
+  intro z
+  rw [← hgb z, hformula z.val (Metric.sphere_subset_closedBall z.property), hhb z]
+
+private def
+    MorseCancel.cancelled {m : ℕ} (σ : Fin m → ℝ) (φ : Model m → ℝ) (t : ℝ) (p : Model m) : ℝ :=
+  cubic σ (-t) p + 2 * t * φ p * p.1
+
+private theorem MorseCancel.contDiff_cancelled_family {m : ℕ} (σ : Fin m → ℝ) {φ : Model m → ℝ}
+    (hφ : ContDiff ℝ ∞ φ) : ContDiff ℝ ∞ (Function.uncurry (cancelled σ φ)) := by
+  exact
+    ((contDiff_cubic_family σ).comp (contDiff_fst.neg.prodMk contDiff_snd)).add
+      (((contDiff_const.mul contDiff_fst).mul (hφ.comp contDiff_snd)).mul contDiff_snd.fst)
+
+private theorem MorseCancel.cancelled_zero {m : ℕ} (σ : Fin m → ℝ) (φ : Model m → ℝ) :
+    cancelled σ φ 0 = cubic σ 0 := by
+  funext p
+  simp [cancelled]
+
+private theorem MorseCancel.cancelled_germ_plateau {m : ℕ} (σ : Fin m → ℝ) {φ : Model m → ℝ}
+    {U : Set (Model m)} (hU : IsOpen U) (hφU : Set.EqOn φ (fun _ => 1) U) (t : ℝ) {p : Model m}
+    (hp : p ∈ U) : cancelled σ φ t =ᶠ[𝓝 p] cubic σ t := by
+  filter_upwards [hU.mem_nhds hp] with q hq
+  simp [cancelled, cubic, hφU hq]
+  ring
+
+private theorem
+    MorseCancel.cancelled_eq_off_support {m : ℕ} (σ : Fin m → ℝ) (φ : Model m → ℝ) (t : ℝ)
+    {p : Model m} (hp : p ∉ tsupport φ) : cancelled σ φ t p = cubic σ (-t) p := by
+  simp [cancelled, image_eq_zero_of_notMem_tsupport hp]
+
+private theorem
+    MorseCancel.cancelled_germ_off_support {m : ℕ} (σ : Fin m → ℝ) (φ : Model m → ℝ) (t : ℝ)
+    {p : Model m} (hp : p ∉ tsupport φ) : cancelled σ φ t =ᶠ[𝓝 p] cubic σ (-t) := by
+  filter_upwards [(isClosed_tsupport φ).isOpen_compl.mem_nhds hp] with q hq
+  exact cancelled_eq_off_support σ φ t hq
+
+private theorem MorseCancel.exists_exact_cubic_birth {m : ℕ} (σ : Fin m → ℝ) (hσ : ∀ i, σ i ≠ 0)
+    {φ : Model m → ℝ} (hφ : ContDiff ℝ ∞ φ) (hc : HasCompactSupport φ) {U : Set (Model m)}
+    (hU : IsOpen U) (h0 : (0 : Model m) ∈ U) (hφU : Set.EqOn φ (fun _ => 1) U) :
+    ∃ a : ℝ,
+      0 < a ∧
+        (a, (0 : Fin m → ℝ)) ∈ U ∧
+          (-a, (0 : Fin m → ℝ)) ∈ U ∧
+            ∃ g : Model m → ℝ,
+              ContDiff ℝ ∞ g ∧
+                (∀ p, fderiv ℝ g p = 0 ↔ p = (a, 0) ∨ p = (-a, 0)) ∧
+                  (∀ p ∈ U, g =ᶠ[𝓝 p] cubic σ (-(a ^ 2))) ∧
+                    ∀ p, p ∉ tsupport φ → g =ᶠ[𝓝 p] cubic σ (a ^ 2) := by
+  let K := tsupport φ \ U
+  have hK : IsCompact K := hc.diff hU
+  have hD :=
+    (Smale.MorsePerturbation.contDiff_spatialDerivative
+        (contDiff_cancelled_family σ hφ)).continuous
+  have hO : IsOpen {t : ℝ | ∀ p ∈ K, fderiv ℝ (cancelled σ φ t) p ≠ 0} :=
+    Smale.MorsePerturbation.isOpen_forall_mem_compact hK
+      (isClosed_eq hD continuous_const).isOpen_compl
+  have hO0 : (0 : ℝ) ∈ {t : ℝ | ∀ p ∈ K, fderiv ℝ (cancelled σ φ t) p ≠ 0} := by
+    intro p hp hcrit
+    rw [cancelled_zero] at hcrit
+    exact hp.2 ((cubic_zero_unique_critical σ hσ p).mp hcrit ▸ h0)
+  obtain ⟨δ, hδ, hδball⟩ := Metric.mem_nhds_iff.mp (hO.mem_nhds hO0)
+  obtain ⟨r, hr, hrball⟩ := Metric.mem_nhds_iff.mp (hU.mem_nhds h0)
+  obtain ⟨a, ha, har⟩ := exists_between (lt_min hr (lt_min zero_lt_one hδ))
+  have ha1 : a < 1 := (lt_min_iff.mp (lt_min_iff.mp har).2).1
+  have haδ : a < δ := (lt_min_iff.mp (lt_min_iff.mp har).2).2
+  have haa : a ^ 2 < δ := by nlinarith
+  have htrans : ∀ p ∈ K, fderiv ℝ (cancelled σ φ (-(a ^ 2))) p ≠ 0 :=
+    hδball (by simpa [Real.dist_eq, abs_of_nonneg (sq_nonneg a)] using haa)
+  have hp : (a, (0 : Fin m → ℝ)) ∈ U := by
+    apply hrball
+    simpa [mem_ball_zero_iff, abs_of_pos ha] using And.intro (lt_min_iff.mp har).1 hr
+  have hq : (-a, (0 : Fin m → ℝ)) ∈ U := by
+    apply hrball
+    simpa [mem_ball_zero_iff, abs_of_pos ha] using And.intro (lt_min_iff.mp har).1 hr
+  refine
+    ⟨a, ha, hp, hq, cancelled σ φ (-(a ^ 2)),
+      (contDiff_cancelled_family σ hφ).comp (contDiff_const.prodMk contDiff_id), ?_,
+      (fun p hpU => cancelled_germ_plateau σ hU hφU _ hpU), ?_⟩
+  · intro p
+    by_cases hpU : p ∈ U
+    · rw [(cancelled_germ_plateau σ hU hφU (-(a ^ 2)) hpU).fderiv_eq]
+      exact negative_parameter_critical_iff σ hσ a p
+    · have hreg : fderiv ℝ (cancelled σ φ (-(a ^ 2))) p ≠ 0 := by
+        by_cases hpS : p ∈ tsupport φ
+        · exact htrans p ⟨hpS, hpU⟩
+        · rw [(cancelled_germ_off_support σ φ (-(a ^ 2)) hpS).fderiv_eq, neg_neg]
+          exact positive_parameter_no_critical σ hσ (sq_pos_of_pos ha) p
+      constructor
+      · exact fun h => False.elim (hreg h)
+      · rintro (rfl | rfl)
+        · exact False.elim (hpU hp)
+        · exact False.elim (hpU hq)
+  · intro p hpS
+    simpa only [neg_neg] using cancelled_germ_off_support σ φ (-(a ^ 2)) hpS
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Recognition/Smale11.lean b/LeanPool/HopfProblem/Recognition/Smale11.lean
new file mode 100644
index 000000000..7fc454b72
--- /dev/null
+++ b/LeanPool/HopfProblem/Recognition/Smale11.lean
@@ -0,0 +1,5644 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Recognition.Smale10
+public import LeanPool.HopfProblem.HomologyOfX.ThreefoldHomologyStarCoproduct
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.Recognition.Smale1
+import all LeanPool.HopfProblem.CuspFibre.CuspCentralHomology2
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology1
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology3
+import all LeanPool.HopfProblem.Recognition.Smale2
+import all LeanPool.HopfProblem.Recognition.Smale3
+import all LeanPool.HopfProblem.Recognition.Smale4
+import all LeanPool.HopfProblem.Recognition.Smale5
+import all LeanPool.HopfProblem.Recognition.Degree1
+import all LeanPool.HopfProblem.Recognition.Degree2
+import all LeanPool.HopfProblem.Recognition.Smale6
+import all LeanPool.HopfProblem.Recognition.Smale7
+import all LeanPool.HopfProblem.Recognition.Smale8
+import all LeanPool.HopfProblem.Recognition.Smale9
+import all LeanPool.HopfProblem.Recognition.Smale10
+import all LeanPool.HopfProblem.MainTheorem.SixSphereCube1
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldHomologyStarCoproduct
+
+/-!
+# Hopf problem: recognition · smale 11
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem MorseCancel.exists_positive_scalar_cubic_diffeomorph {a : ℝ} (ha : 0 < a) :
+    ∃ e : ℝ ≃ₘ[ℝ] ℝ, ∀ s, e s = s ^ 3 / 3 + a ^ 2 * s := by
+  let g : ℝ → ℝ := fun s => s ^ 3 / 3 + a ^ 2 * s
+  have hg : ContDiff ℝ ∞ g := by unfold g; fun_prop
+  have hd (s : ℝ) : HasDerivAt g (s ^ 2 + a ^ 2) s := by
+    convert!
+      (((hasDerivAt_id s).pow 3).div_const 3).add ((hasDerivAt_id s).const_mul (a ^ 2)) using 1;
+    simp
+  have hpos (s : ℝ) : 0 < s ^ 2 + a ^ 2 :=
+    add_pos_of_nonneg_of_pos (sq_nonneg s) (sq_pos_of_pos ha)
+  have hmono : StrictMono g := strictMono_of_hasDerivAt_pos hd hpos
+  have hbound {s t : ℝ} (hst : s ≤ t) : a ^ 2 * (t - s) ≤ g t - g s :=
+    mul_sub_le_image_sub_of_le_deriv (fun x => (hd x).differentiableAt)
+      (fun x => by rw [(hd x).deriv]; exact le_add_of_nonneg_left (sq_nonneg x)) hst
+  have hzero : g 0 = 0 := by simp [g]
+  have hsurj : Function.Surjective g := by
+    intro y
+    apply mem_range_of_exists_le_of_exists_ge hg.continuous
+    · refine ⟨Min.min 0 (y / a ^ 2), ?_⟩
+      have hh := hbound (min_le_left 0 (y / a ^ 2))
+      have hm : a ^ 2 * Min.min 0 (y / a ^ 2) ≤ y := by
+        calc
+          a ^ 2 * Min.min 0 (y / a ^ 2) ≤ a ^ 2 * (y / a ^ 2) :=
+            mul_le_mul_of_nonneg_left (min_le_right _ _) (sq_nonneg a)
+          _ = y := by field_simp
+      rw [hzero] at hh
+      linarith
+    · refine ⟨Max.max 0 (y / a ^ 2), ?_⟩
+      have hh := hbound (le_max_left 0 (y / a ^ 2))
+      have hm : y ≤ a ^ 2 * Max.max 0 (y / a ^ 2) := by
+        calc
+          y = a ^ 2 * (y / a ^ 2) := by field_simp
+          _ ≤ a ^ 2 * Max.max 0 (y / a ^ 2) :=
+            mul_le_mul_of_nonneg_left (le_max_right _ _) (sq_nonneg a)
+      rw [hzero] at hh
+      linarith
+  let c : ℝ ≃o ℝ := hmono.orderIsoOfSurjective g hsurj
+  have hi : ContDiff ℝ ∞ c.toHomeomorph.symm :=
+    c.toHomeomorph.contDiff_symm_deriv (fun s => (hpos s).ne') hd hg
+  let e : ℝ ≃ₘ[ℝ] ℝ :=
+    { toEquiv := c.toEquiv
+      contMDiff_toFun := hg.contMDiff
+      contMDiff_invFun := hi.contMDiff }
+  exact ⟨e, fun _ => rfl⟩
+
+private theorem MorseCancel.exists_positive_cubic_height_diffeomorph {m : ℕ} (σ : Fin m → ℝ) {a : ℝ}
+    (ha : 0 < a) : ∃ D : Model m ≃ₘ[ℝ] Model m, ∀ p, D p = (cubic σ (a ^ 2) p, p.2) := by
+  obtain ⟨e, he⟩ := exists_positive_scalar_cubic_diffeomorph ha
+  let Q : (Fin m → ℝ) → ℝ := fun z => ∑ i, σ i * z i ^ 2
+  have hQ : ContDiff ℝ ∞ Q := by unfold Q; fun_prop
+  have hec : ContDiff ℝ ∞ e := contMDiff_iff_contDiff.mp e.contMDiff
+  have hei : ContDiff ℝ ∞ e.symm := contMDiff_iff_contDiff.mp e.symm.contMDiff
+  let D : Model m ≃ₘ[ℝ] Model m :=
+    { toFun := fun p => (e p.1 + Q p.2, p.2)
+      invFun := fun p => (e.symm (p.1 - Q p.2), p.2)
+      left_inv := by intro p; simp
+      right_inv := by intro p; simp
+      contMDiff_toFun :=
+        ((hec.comp contDiff_fst |>.add (hQ.comp contDiff_snd)).prodMk contDiff_snd).contMDiff
+      contMDiff_invFun :=
+        ((hei.comp (contDiff_fst.sub (hQ.comp contDiff_snd))).prodMk contDiff_snd).contMDiff }
+  refine ⟨D, ?_⟩
+  intro p
+  change (e p.1 + Q p.2, p.2) = _
+  rw [he]
+  rfl
+
+private theorem MorseCancel.hessian_comp_linearEquiv {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : F → ℝ} (hf : ContDiff ℝ ∞ f)
+    (L : E ≃L[ℝ] F) (x : E) :
+    fderiv ℝ (fderiv ℝ (f ∘ L)) x =
+      ((ContinuousLinearMap.compL ℝ E F ℝ).flip L.toContinuousLinearMap).comp
+        ((fderiv ℝ (fderiv ℝ f) (L x)).comp L.toContinuousLinearMap) := by
+  let A := (ContinuousLinearMap.compL ℝ E F ℝ).flip L.toContinuousLinearMap
+  have hgrad : fderiv ℝ (f ∘ L) = fun y => A (fderiv ℝ f (L y)) := by
+    funext y
+    rw [fderiv_comp y (hf.differentiable (by simp) (L y)) L.differentiableAt, L.fderiv]
+    rfl
+  have hdf : ContDiff ℝ ∞ (fderiv ℝ f) := hf.fderiv_right (by simp)
+  rw [hgrad]
+  exact
+    (A.hasFDerivAt.comp x
+        ((hdf.differentiable (by simp) (L x)).hasFDerivAt.comp x L.hasFDerivAt)).fderiv
+
+private theorem MorseCancel.euclidean_isMorse_comp_linearEquiv {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : F → ℝ} (hf : ContDiff ℝ ∞ f)
+    (hm : Smale.MorsePerturbation.IsMorse f) (L : E ≃L[ℝ] F) :
+    Smale.MorsePerturbation.IsMorse (f ∘ L) := by
+  intro x hx
+  have hcrit : fderiv ℝ f (L x) = 0 := by
+    rw [fderiv_comp x (hf.differentiable (by simp) (L x)) L.differentiableAt, L.fderiv] at hx
+    apply ContinuousLinearMap.ext
+    intro v
+    obtain ⟨w, rfl⟩ := L.surjective v
+    exact congrArg (fun k : E →L[ℝ] ℝ => k w) hx
+  let A := (ContinuousLinearMap.compL ℝ E F ℝ).flip L.toContinuousLinearMap
+  have hA : Function.Bijective A := by
+    constructor
+    · intro k l hkl
+      apply ContinuousLinearMap.ext
+      intro v
+      obtain ⟨w, rfl⟩ := L.surjective v
+      exact congrArg (fun k : E →L[ℝ] ℝ => k w) hkl
+    · intro k
+      refine ⟨k.comp L.symm.toContinuousLinearMap, ?_⟩
+      apply ContinuousLinearMap.ext
+      intro v
+      change k (L.symm (L v)) = k v
+      rw [L.symm_apply_apply]
+  rw [hessian_comp_linearEquiv hf L]
+  exact hA.comp ((hm (L x) hcrit).comp L.bijective)
+
+private theorem MorseCancel.isMorseAt_of_native_model_germ {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {M : Type*} [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, F) 𝓘(ℝ, E) F M ∞) (L : E ≃L[ℝ] F) {f : M → ℝ} {b : F → ℝ} {p : F}
+    (hp : p ∈ Φ.source) (hb : ContDiff ℝ ∞ b) (hmb : Smale.MorsePerturbation.IsMorse b)
+    (hmodel : f ∘ Φ =ᶠ[𝓝 p] b) : Smale.ManifoldMorse.IsMorseAt E f (Φ p) := by
+  let Ψ := L.toDiffeomorph.toPartialDiffeomorph.trans Φ
+  have hpΨ : Φ p ∈ Ψ.target := by exact ⟨Φ.map_source' hp, Set.mem_univ _⟩
+  have he : Ψ.symm.toOpenPartialHomeomorph ∈ IsManifold.maximalAtlas 𝓘(ℝ, E) ∞ M :=
+    Ψ.symm.toOpenPartialHomeomorph.mem_maximalAtlas_of_contMDiffOn Ψ.contMDiffOn_invFun
+      Ψ.contMDiffOn_toFun
+  apply
+    Smale.ManifoldMorse.isMorseAt_of_chart_eventuallyEq he hpΨ
+      (euclidean_isMorse_comp_linearEquiv hb hmb L)
+  have hcenter : Ψ.symm (Φ p) = L.symm p := by
+    change L.symm (Φ.symm (Φ p)) = L.symm p
+    exact congrArg L.symm (Φ.left_inv' hp)
+  change f ∘ Ψ =ᶠ[𝓝 (Ψ.symm (Φ p))] b ∘ L
+  rw [hcenter]
+  have ht : Filter.Tendsto L (𝓝 (L.symm p)) (𝓝 p) := by
+    simpa only [L.apply_symm_apply] using L.continuous.continuousAt.tendsto (x := L.symm p)
+  exact hmodel.comp_tendsto ht
+
+private theorem
+    MorseCancel.euclidean_isMorse_affine {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    {f : E → ℝ} (hf : ContDiff ℝ ∞ f) (hm : Smale.MorsePerturbation.IsMorse f) {c : ℝ}
+    (hc : c ≠ 0) (b : ℝ) : Smale.MorsePerturbation.IsMorse (fun x => b + c * f x) := by
+  have hgrad : fderiv ℝ (fun x => b + c * f x) = fun x => c • fderiv ℝ f x := by
+    funext x
+    rw [fderiv_const_add, fderiv_const_mul (hf.differentiable (by simp) x)]
+  have hdf : ContDiff ℝ ∞ (fderiv ℝ f) := hf.fderiv_right (by simp)
+  intro x hx
+  rw [hgrad] at hx ⊢
+  have hcrit : fderiv ℝ f x = 0 := (smul_eq_zero.mp hx).resolve_left hc
+  change Function.Bijective (fderiv ℝ (c • fderiv ℝ f) x)
+  rw [fderiv_const_smul (hdf.differentiable (by simp) x)]
+  exact (isUnit_iff_ne_zero.mpr hc).smul_bijective.comp (hm x hcrit)
+
+private theorem MorseCancel.exists_pos_compact_smul_subset {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {K U : Set E} (hK : IsCompact K) (hU : IsOpen U) (h0 : (0 : E) ∈ U) :
+    ∃ δ : ℝ, 0 < δ ∧ (fun x : E => δ • x) '' K ⊆ U := by
+  obtain ⟨r, hr, hrU⟩ := Metric.mem_nhds_iff.mp (hU.mem_nhds h0)
+  obtain ⟨C, hC⟩ := hK.isBounded.exists_norm_le
+  let R := Max.max C 0 + 1
+  have hR : 0 < R := by dsimp [R]; positivity
+  have hCR : C < R := by dsimp [R]; linarith [le_max_left C 0]
+  let δ := r / (2 * R)
+  have hδ : 0 < δ := div_pos hr (mul_pos (by norm_num) hR)
+  refine ⟨δ, hδ, ?_⟩
+  rintro _ ⟨x, hx, rfl⟩
+  apply hrU
+  rw [mem_ball_zero_iff, norm_smul, Real.norm_eq_abs, abs_of_pos hδ]
+  have hnorm : ‖x‖ < R := (hC x hx).trans_lt hCR
+  have hm : δ * ‖x‖ < δ * R := mul_lt_mul_of_pos_left hnorm hδ
+  have heq : δ * R = r / 2 := by dsimp [δ]; field_simp
+  rw [heq] at hm
+  linarith
+
+private theorem MorseCancel.exists_centered_native_height_chart {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {M : Type*} [TopologicalSpace M] [ChartedSpace E M] [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {x : M}
+    (hx : x ∉ Smale.ManifoldMorse.criticalPoints E f) {m : ℕ} (hdim : 1 + m = Module.finrank ℝ E)
+    {U : Set M} (hU : IsOpen U) (hxU : x ∈ U) :
+    ∃ Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞,
+      (0 : Model m) ∈ Φ.source ∧ Φ 0 = x ∧ Φ.target ⊆ U ∧ ∀ p ∈ Φ.source, f (Φ p) = f x + p.1 := by
+  obtain ⟨Q, hxQ, hQ, hQx⟩ := Smale.RegularLevel.exists_native_height_chart hf hx
+  have hdim' : Module.finrank ℝ (Fin m → ℝ) = Module.finrank ℝ (Smale.RegularLevel.Model E) := by
+    simp only [Module.finrank_pi, Fintype.card_fin, Smale.RegularLevel.Model,
+      finrank_euclideanSpace_fin]
+    omega
+  let L : (Fin m → ℝ) ≃L[ℝ] Smale.RegularLevel.Model E := ContinuousLinearEquiv.ofFinrankEq hdim'
+  let D :
+    Diffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, ℝ × Smale.RegularLevel.Model E) (Model m)
+      (ℝ × Smale.RegularLevel.Model E) ∞ :=
+    { toFun := fun p => (f x + p.1, L p.2)
+      invFun := fun p => (p.1 - f x, L.symm p.2)
+      left_inv := by intro p; simp
+      right_inv := by intro p; simp
+      contMDiff_toFun :=
+        ((contDiff_const.add contDiff_fst).prodMk (L.contDiff.comp contDiff_snd)).contMDiff
+      contMDiff_invFun :=
+        ((contDiff_fst.sub contDiff_const).prodMk (L.symm.contDiff.comp contDiff_snd)).contMDiff }
+  let P := D.toPartialDiffeomorph.trans Q.symm
+  let Φ := Smale.PartialChart.restrictTarget P hU
+  have hD0 : D 0 = Q x := by
+    rw [hQx]
+    change (f x + (0 : ℝ), L 0) = (f x, 0)
+    simp
+  have h0P : (0 : Model m) ∈ P.source := by
+    change (0 : Model m) ∈ Set.univ ∧ D 0 ∈ Q.target
+    exact ⟨Set.mem_univ _, hD0.symm ▸ Q.map_source' hxQ⟩
+  have hP0 : P 0 = x := by
+    change Q.symm (D 0) = x
+    rw [hD0]
+    exact Q.left_inv' hxQ
+  have h0Φ : (0 : Model m) ∈ Φ.source := by
+    change (0 : Model m) ∈ P.source ∧ P 0 ∈ U
+    exact ⟨h0P, hP0.symm ▸ hxU⟩
+  refine ⟨Φ, h0Φ, hP0, fun _ hy => hy.2, ?_⟩
+  intro p hp
+  have hpt : D p ∈ Q.target := hp.1.2
+  have hh := hQ (Q.symm (D p)) (Q.map_target' hpt)
+  have hright : Q (Q.symm (D p)) = D p := Q.right_inv' hpt
+  rw [hright] at hh
+  exact hh.symm
+
+private theorem MorseCancel.insert_morse_chart_pair {E D M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup D] [NormedSpace ℝ D]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, D) 𝓘(ℝ, E) D M ∞) (L : E ≃L[ℝ] D) {f : M → ℝ} {b₀ b₁ : D → ℝ}
+    {K : Set D} {p q : D} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (hb₀ : ContDiff ℝ ∞ b₀) (hb₁ : ContDiff ℝ ∞ b₁)
+    (hmb₁ : Smale.MorsePerturbation.IsMorse b₁) (hK : IsCompact K) (hKΦ : K ⊆ Φ.source)
+    (hmodel : ∀ x ∈ Φ.source, f (Φ x) = b₀ x) (hfix : ∀ x ∉ K, b₁ x = b₀ x) (hp : p ∈ Φ.source)
+    (hq : q ∈ Φ.source) (hpq : p ≠ q) (hreg : ∀ x, fderiv ℝ b₀ x ≠ 0)
+    (hcrit : ∀ x, fderiv ℝ b₁ x = 0 ↔ x = p ∨ x = q) :
+    ∃ g : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+        Smale.ManifoldMorse.IsMorse E g ∧
+          (Smale.ManifoldMorse.criticalPoints E g).ncard =
+              (Smale.ManifoldMorse.criticalPoints E f).ncard + 2 ∧
+            (∀ y,
+                y ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+                  y ∈ Smale.ManifoldMorse.criticalPoints E f ∨ y = Φ p ∨ y = Φ q) ∧
+              (∀ y, y ∉ Φ '' K → g =ᶠ[𝓝 y] f) ∧
+                (∀ y ∈ Smale.ManifoldMorse.criticalPoints E f, g =ᶠ[𝓝 y] f) ∧
+                  ∀ z ∈ Φ.source, g (Φ z) = b₁ z := by
+  let g := Degree.LocalFunctionReplacement.replace Φ f b₁
+  have hg := Degree.LocalFunctionReplacement.contMDiff_replace Φ hf hb₁ hK hKΦ hmodel hfix
+  have houtside (y : M) (hy : y ∉ Φ '' K) : g =ᶠ[𝓝 y] f :=
+    Degree.LocalFunctionReplacement.replace_germ_off_support Φ hK hKΦ hmodel hfix hy
+  have hnot (y : M) (hy : y ∈ Φ.target) : y ∉ Smale.ManifoldMorse.criticalPoints E f := by
+    intro hc
+    have he := Degree.LocalFunctionReplacement.replace_critical_iff Φ f hb₀ hy
+    rw [Degree.LocalFunctionReplacement.replace_self Φ hmodel] at he
+    exact hreg (Φ.symm y) (he.mp hc)
+  have hcritg (y : M) :
+    y ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+      y ∈ Smale.ManifoldMorse.criticalPoints E f ∨ y = Φ p ∨ y = Φ q := by
+    by_cases hy : y ∈ Φ.target
+    · have he := Degree.LocalFunctionReplacement.replace_critical_iff Φ f hb₁ hy
+      change mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) g y = 0 ↔ _
+      rw [he, hcrit]
+      constructor
+      · rintro (h | h)
+        · exact Or.inr (Or.inl ((Φ.right_inv' hy).symm.trans (congrArg Φ h)))
+        · exact Or.inr (Or.inr ((Φ.right_inv' hy).symm.trans (congrArg Φ h)))
+      · rintro (hc | rfl | rfl)
+        · exact False.elim (hnot y hy hc)
+        · exact Or.inl (Φ.left_inv' hp)
+        · exact Or.inr (Φ.left_inv' hq)
+    · have hyK : y ∉ Φ '' K := by
+        rintro ⟨z, hz, rfl⟩
+        exact hy (Φ.map_source' (hKΦ hz))
+      have hyp : y ≠ Φ p := fun h => hy (h.symm ▸ Φ.map_source' hp)
+      have hyq : y ≠ Φ q := fun h => hy (h.symm ▸ Φ.map_source' hq)
+      have he :
+        y ∈ Smale.ManifoldMorse.criticalPoints E g ↔ y ∈ Smale.ManifoldMorse.criticalPoints E f :=
+        by
+        change mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) g y = 0 ↔ _
+        rw [(houtside y hyK).mfderiv_eq]
+        rfl
+      simpa only [hyp, hyq, or_false] using he
+  have hmg : Smale.ManifoldMorse.IsMorse E g := by
+    intro y
+    by_cases hy : y ∈ Φ.target
+    · have hx := Φ.map_target' hy
+      have hmodelg : g ∘ Φ =ᶠ[𝓝 (Φ.symm y)] b₁ := by
+        filter_upwards [Φ.open_source.mem_nhds hx] with z hz
+        exact Degree.LocalFunctionReplacement.replace_chart Φ f b₁ hz
+      have hh := isMorseAt_of_native_model_germ Φ L hx hb₁ hmb₁ hmodelg
+      have hright : Φ (Φ.symm y) = y := Φ.right_inv' hy
+      exact hright ▸ hh
+    · apply Degree.MorseCancellationPreservation.isMorseAt_of_same_germ (hm y)
+      apply houtside y
+      rintro ⟨z, hz, rfl⟩
+      exact hy (Φ.map_source' (hKΦ hz))
+  have hneq : Φ p ≠ Φ q := fun h => hpq (Φ.toOpenPartialHomeomorph.injOn hp hq h)
+  have hpnot := hnot (Φ p) (Φ.map_source' hp)
+  have hqnot := hnot (Φ q) (Φ.map_source' hq)
+  have heq :
+    Smale.ManifoldMorse.criticalPoints E g =
+      Insert.insert (Φ p) (Insert.insert (Φ q) (Smale.ManifoldMorse.criticalPoints E f)) := by
+    ext y
+    rw [hcritg]
+    simp only [Set.mem_insert_iff]
+    tauto
+  refine
+    ⟨g, hg, hmg, ?_, hcritg, houtside, ?_, fun z hz =>
+      Degree.LocalFunctionReplacement.replace_chart Φ f b₁ hz⟩
+  · rw [heq,
+      Set.ncard_insert_of_notMem
+        (by simp only [Set.mem_insert_iff, hneq, hpnot, or_self, not_false_eq_true])
+        ((Smale.ManifoldMorse.finite_criticalPoints hf hm).insert (Φ q)),
+      Set.ncard_insert_of_notMem hqnot (Smale.ManifoldMorse.finite_criticalPoints hf hm)]
+  · intro y hy
+    apply houtside y
+    rintro ⟨z, hz, rfl⟩
+    exact hnot (Φ z) (Φ.map_source' (hKΦ hz)) hy
+
+private theorem MorseCancel.exists_native_morse_birth {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f) {x : M}
+    (hx : x ∉ Smale.ManifoldMorse.criticalPoints E f) {m : ℕ} (hdim : 1 + m = Module.finrank ℝ E)
+    (σ : Fin m → ℝ) (hσ : ∀ i, σ i ≠ 0) {U : Set M} (hU : IsOpen U) (hxU : x ∈ U) :
+    ∃ a δ : ℝ,
+      0 < a ∧
+        0 < δ ∧
+          ∃ Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞,
+            (a, (0 : Fin m → ℝ)) ∈ Φ.source ∧
+              (-a, (0 : Fin m → ℝ)) ∈ Φ.source ∧
+                Φ.target ⊆ U ∧
+                  (∀ z ∈ Φ.source, f (Φ z) = f x + δ * cubic σ (a ^ 2) z) ∧
+                    ∃ g : M → ℝ,
+                      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+                        Smale.ManifoldMorse.IsMorse E g ∧
+                          (Smale.ManifoldMorse.criticalPoints E g).ncard =
+                              (Smale.ManifoldMorse.criticalPoints E f).ncard + 2 ∧
+                            (∀ y,
+                                y ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+                                  y ∈ Smale.ManifoldMorse.criticalPoints E f ∨
+                                    y = Φ (a, 0) ∨ y = Φ (-a, 0)) ∧
+                              (∀ y, y ∉ U → g =ᶠ[𝓝 y] f) ∧
+                                (∀ y ∈ Smale.ManifoldMorse.criticalPoints E f, g =ᶠ[𝓝 y] f) ∧
+                                  (g ∘ Φ =ᶠ[𝓝 (a, 0)] fun z => f x + δ * cubic σ (-(a ^ 2)) z) ∧
+                                    (g ∘ Φ =ᶠ[𝓝 (-a, 0)] fun z =>
+                                      f x + δ * cubic σ (-(a ^ 2)) z) := by
+  obtain ⟨H, h0H, -, hHU, hH⟩ := exists_centered_native_height_chart hf hx hdim hU hxU
+  obtain ⟨φ, hφ, hc, -, W, hW, h0W, hφW⟩ :=
+    Degree.NativeCubicCancellation.exists_cutoff (m := m) isOpen_univ (Set.mem_univ _)
+  obtain ⟨a, ha, hpW, hqW, b, hb, hcritb, hgerms, hfix⟩ :=
+    exists_exact_cubic_birth σ hσ hφ hc hW h0W hφW
+  have hmb : Smale.MorsePerturbation.IsMorse b := by
+    intro z hz
+    have hzW : z ∈ W := (hcritb z).mp hz |>.elim (fun h => h ▸ hpW) (fun h => h ▸ hqW)
+    have heq := hgerms z hzW
+    rw [(heq.fderiv (𝕜 := ℝ)).fderiv_eq]
+    apply cubic_isMorse σ hσ (neg_ne_zero.mpr (pow_ne_zero 2 ha.ne'))
+    rw [← heq.fderiv_eq]
+    exact hz
+  obtain ⟨D, hD⟩ := exists_positive_cubic_height_diffeomorph σ ha
+  obtain ⟨δ, hδ, hsmall⟩ :=
+    exists_pos_compact_smul_subset (hc.image D.continuous) H.open_source h0H
+  let A : Model m ≃L[ℝ] Model m :=
+    (LinearEquiv.smulOfNeZero ℝ (Model m) δ hδ.ne').toContinuousLinearEquiv
+  let C := D.trans A.toDiffeomorph
+  let Φ := C.toPartialDiffeomorph.trans H
+  have hC (z : Model m) : C z = δ • D z := rfl
+  have hKΦ : tsupport φ ⊆ Φ.source := by
+    intro z hz
+    change z ∈ Set.univ ∧ C z ∈ H.source
+    exact ⟨Set.mem_univ _, hsmall ⟨D z, Set.mem_image_of_mem D hz, rfl⟩⟩
+  have hWK : W ⊆ tsupport φ := by
+    intro z hz
+    apply subset_tsupport φ
+    change φ z ≠ 0
+    rw [hφW hz]
+    norm_num
+  have hpΦ := hKΦ (hWK hpW)
+  have hqΦ := hKΦ (hWK hqW)
+  have hΦU : Φ.target ⊆ U := fun _ hy => hHU hy.1
+  let b₀ : Model m → ℝ := fun z => f x + δ * cubic σ (a ^ 2) z
+  let b₁ : Model m → ℝ := fun z => f x + δ * b z
+  have hb₀ : ContDiff ℝ ∞ b₀ := contDiff_const.add (contDiff_const.mul (contDiff_cubic σ _))
+  have hb₁ : ContDiff ℝ ∞ b₁ := contDiff_const.add (contDiff_const.mul hb)
+  have hmb₁ : Smale.MorsePerturbation.IsMorse b₁ := euclidean_isMorse_affine hb hmb hδ.ne' (f x)
+  have hmodel (z : Model m) (hz : z ∈ Φ.source) : f (Φ z) = b₀ z := by
+    change f (H (C z)) = _
+    rw [hH (C z) hz.2, hC, hD]
+    rfl
+  have hfix₁ (z : Model m) (hz : z ∉ tsupport φ) : b₁ z = b₀ z := by
+    dsimp [b₁, b₀]
+    rw [(hfix z hz).self_of_nhds]
+  have hderiv (v : Model m → ℝ) (hv : ContDiff ℝ ∞ v) (z : Model m) :
+    fderiv ℝ (fun y => f x + δ * v y) z = δ • fderiv ℝ v z := by
+    rw [fderiv_const_add, fderiv_const_mul (hv.differentiable (by simp) z)]
+  have hreg₀ (z : Model m) : fderiv ℝ b₀ z ≠ 0 := by
+    rw [hderiv _ (contDiff_cubic σ _) z]
+    exact smul_ne_zero hδ.ne' (positive_parameter_no_critical σ hσ (sq_pos_of_pos ha) z)
+  have hcrit₁ (z : Model m) : fderiv ℝ b₁ z = 0 ↔ z = (a, 0) ∨ z = (-a, 0) := by
+    rw [hderiv b hb z, smul_eq_zero]
+    simp only [hδ.ne', false_or, hcritb]
+  have hpq : (a, (0 : Fin m → ℝ)) ≠ (-a, 0) := by
+    intro h
+    have hh := congrArg Prod.fst h
+    change a = -a at hh
+    linarith
+  let L : E ≃L[ℝ] Model m :=
+    ContinuousLinearEquiv.ofFinrankEq
+      (by
+        simp only [Model, Module.finrank_prod, Module.finrank_self, Module.finrank_pi,
+          Fintype.card_fin]
+        exact hdim.symm)
+  obtain ⟨g, hg, hmg, hcount, hcritg, hexterior, hkeep, hnew⟩ :=
+    insert_morse_chart_pair Φ L hf hm hb₀ hb₁ hmb₁ hc hKΦ hmodel hfix₁ hpΦ hqΦ hpq hreg₀ hcrit₁
+  have hend (z : Model m) (hzΦ : z ∈ Φ.source) (hzW : z ∈ W) :
+    g ∘ Φ =ᶠ[𝓝 z] fun w => f x + δ * cubic σ (-(a ^ 2)) w := by
+    filter_upwards [Φ.open_source.mem_nhds hzΦ, hgerms z hzW] with w hw heq
+    change g (Φ w) = _
+    rw [hnew w hw]
+    change f x + δ * b w = _
+    rw [heq]
+  refine
+    ⟨a, δ, ha, hδ, Φ, hpΦ, hqΦ, hΦU, hmodel, g, hg, hmg, hcount, hcritg, ?_, hkeep,
+      hend _ hpΦ hpW, hend _ hqΦ hqW⟩
+  intro y hy
+  apply hexterior y
+  rintro ⟨z, hz, rfl⟩
+  exact hy (hΦU (Φ.map_source' (hKΦ hz)))
+
+private theorem MorseCancel.injOn_of_two_new_values {X : Type*} {f g : X → ℝ} {C : Set X} {p q : X}
+    (hinj : Set.InjOn f C) (hkeep : ∀ y ∈ C, g y = f y) (hp : g p ∉ f '' C) (hq : g q ∉ f '' C)
+    (hpq : g p ≠ g q) : Set.InjOn g {y | y ∈ C ∨ y = p ∨ y = q} := by
+  intro y hy z hz heq
+  rcases hy with hy | rfl | rfl
+  · rcases hz with hz | rfl | rfl
+    · exact hinj hy hz ((hkeep y hy).symm.trans (heq.trans (hkeep z hz)))
+    · exact False.elim (hp ⟨y, hy, (hkeep y hy).symm.trans heq⟩)
+    · exact False.elim (hq ⟨y, hy, (hkeep y hy).symm.trans heq⟩)
+  · rcases hz with hz | rfl | rfl
+    · exact False.elim (hp ⟨z, hz, (hkeep z hz).symm.trans heq.symm⟩)
+    · rfl
+    · exact False.elim (hpq heq)
+  · rcases hz with hz | rfl | rfl
+    · exact False.elim (hq ⟨z, hz, (hkeep z hz).symm.trans heq.symm⟩)
+    · exact False.elim (hpq heq.symm)
+    · rfl
+
+private theorem MorseCancel.exists_excellent_native_morse_birth {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f)) {l u : ℝ}
+    (hband : ∀ y, f y ∈ Set.Ioo l u → y ∉ Smale.ManifoldMorse.criticalPoints E f) {x : M}
+    (hx : f x ∈ Set.Ioo l u) {m : ℕ} (hdim : 1 + m = Module.finrank ℝ E) (σ : Fin m → ℝ)
+    (hσ : ∀ i, σ i ≠ 0) {U : Set M} (hU : IsOpen U) (hxU : x ∈ U) :
+    ∃ a δ : ℝ,
+      0 < a ∧
+        0 < δ ∧
+          ∃ Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞,
+            (a, (0 : Fin m → ℝ)) ∈ Φ.source ∧
+              (-a, (0 : Fin m → ℝ)) ∈ Φ.source ∧
+                Φ.target ⊆ U ∧
+                  ∃ g : M → ℝ,
+                    ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+                      Smale.ManifoldMorse.IsMorse E g ∧
+                        Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) ∧
+                          (Smale.ManifoldMorse.criticalPoints E g).ncard =
+                              (Smale.ManifoldMorse.criticalPoints E f).ncard + 2 ∧
+                            (∀ y,
+                                y ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+                                  y ∈ Smale.ManifoldMorse.criticalPoints E f ∨
+                                    y = Φ (a, 0) ∨ y = Φ (-a, 0)) ∧
+                              (∀ y, y ∉ U → g =ᶠ[𝓝 y] f) ∧
+                                (∀ y ∈ Smale.ManifoldMorse.criticalPoints E f, g =ᶠ[𝓝 y] f) ∧
+                                  g (Φ (a, 0)) < g (Φ (-a, 0)) ∧
+                                    g (Φ (a, 0)) ∈ Set.Ioo l u ∧
+                                      g (Φ (-a, 0)) ∈ Set.Ioo l u ∧
+                                        (g ∘ Φ =ᶠ[𝓝 (a, 0)] fun z =>
+                                            f x + δ * cubic σ (-(a ^ 2)) z) ∧
+                                          (g ∘ Φ =ᶠ[𝓝 (-a, 0)] fun z =>
+                                            f x + δ * cubic σ (-(a ^ 2)) z) := by
+  obtain
+    ⟨a, δ, ha, hδ, Φ, hp, hq, hΦ, hmodel, g, hg, hmg, hcount, hcrit, hexterior, hkeep, hgp,
+      hgq⟩ :=
+    exists_native_morse_birth hf hm (hband x hx) hdim σ hσ
+      (hU.inter (isOpen_Ioo.preimage hf.continuous)) ⟨hxU, hx⟩
+  have hpa : f (Φ (a, 0)) = f x + δ * (4 * a ^ 3 / 3) := by
+    rw [hmodel (a, 0) hp]
+    simp only [cubic, Pi.zero_apply, zero_pow (by decide : 2 ≠ 0), MulZeroClass.mul_zero,
+      Finset.sum_const_zero, add_zero]
+    ring
+  have hqa : f (Φ (-a, 0)) = f x - δ * (4 * a ^ 3 / 3) := by
+    rw [hmodel (-a, 0) hq]
+    simp only [cubic, Pi.zero_apply, zero_pow (by decide : 2 ≠ 0), MulZeroClass.mul_zero,
+      Finset.sum_const_zero, add_zero]
+    ring
+  have hpval : g (Φ (a, 0)) = f x - δ * (2 * a ^ 3 / 3) := by
+    have hh := hgp.self_of_nhds
+    change g (Φ (a, 0)) = f x + δ * cubic σ (-(a ^ 2)) (a, 0) at hh
+    rw [(cubic_critical_values σ a).1] at hh
+    exact hh.trans (by ring)
+  have hqval : g (Φ (-a, 0)) = f x + δ * (2 * a ^ 3 / 3) := by
+    have hh := hgq.self_of_nhds
+    change g (Φ (-a, 0)) = f x + δ * cubic σ (-(a ^ 2)) (-a, 0) at hh
+    rw [(cubic_critical_values σ a).2] at hh
+    exact hh
+  have hpos : 0 < δ * (2 * a ^ 3 / 3) := by positivity
+  have hpq : g (Φ (a, 0)) < g (Φ (-a, 0)) := by rw [hpval, hqval]; linarith
+  have hpband : g (Φ (a, 0)) ∈ Set.Ioo l u := by
+    have hb := (hΦ (Φ.map_source' hq)).2
+    change f (Φ (-a, 0)) ∈ Set.Ioo l u at hb
+    rw [hqa] at hb
+    rw [hpval]
+    constructor <;> nlinarith [hb.1, hx.2]
+  have hqband : g (Φ (-a, 0)) ∈ Set.Ioo l u := by
+    have hb := (hΦ (Φ.map_source' hp)).2
+    change f (Φ (a, 0)) ∈ Set.Ioo l u at hb
+    rw [hpa] at hb
+    rw [hqval]
+    constructor <;> nlinarith [hx.1, hb.2]
+  have hnot (v : ℝ) (hv : v ∈ Set.Ioo l u) : v ∉ f '' Smale.ManifoldMorse.criticalPoints E f := by
+    rintro ⟨y, hy, rfl⟩
+    exact hband y hv hy
+  have hinjg : Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) := by
+    have hh :=
+      injOn_of_two_new_values hinj (fun y hy => (hkeep y hy).self_of_nhds) (hnot _ hpband)
+        (hnot _ hqband) hpq.ne
+    intro y hy z hz heq
+    exact hh ((hcrit y).mp hy) ((hcrit z).mp hz) heq
+  refine
+    ⟨a, δ, ha, hδ, Φ, hp, hq, fun _ hy => (hΦ hy).1, g, hg, hmg, hinjg, hcount, hcrit, ?_, hkeep,
+      hpq, hpband, hqband, hgp, hgq⟩
+  intro y hy
+  exact hexterior y (fun hh => hy hh.1)
+
+private theorem
+    MorseCancel.exists_signed_chart_of_split_quadratic {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M} {m : ℕ}
+    (P : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, Model m) M (Model m) ∞) (hp : p ∈ P.source)
+    (hcenter : P p = 0) (ρ : Option (Fin m) ≃ Fin (Module.finrank ℝ E)) (e : ℝ) (σ : Fin m → ℝ)
+    (he : e = -1 ∨ e = 1) (hσ : ∀ i, σ i = -1 ∨ σ i = 1)
+    (hformula : ∀ y ∈ P.source, f y = f p + e * (P y).1 ^ 2 + ∑ i, σ i * (P y).2 i ^ 2) :
+    ∃ c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p,
+      c.weights (ρ Option.none) = e ∧ ∀ i, c.weights (ρ (Option.some i)) = σ i := by
+  let w : Fin (Module.finrank ℝ E) → ℝ := fun j => (ρ.symm j).elim e σ
+  have hwn : w (ρ Option.none) = e := by simp [w]
+  have hws (i : Fin m) : w (ρ (Option.some i)) = σ i := by simp [w]
+  have hw (j : Fin (Module.finrank ℝ E)) : w j = -1 ∨ w j = 1 := by
+    change (ρ.symm j).elim e σ = -1 ∨ (ρ.symm j).elim e σ = 1
+    cases h : ρ.symm j with
+    | none => exact he
+    | some i => exact hσ i
+  have hsum (z : Model m) :
+    (∑ j, w j * splitEquiv ρ z j ^ 2) = e * z.1 ^ 2 + ∑ i, σ i * z.2 i ^ 2 := by
+    rw [split_signed_sum, hwn]
+    simp only [hws]
+  let C := P.trans (splitEquiv ρ).toDiffeomorph.toPartialDiffeomorph
+  have hpC : p ∈ C.source := ⟨hp, Set.mem_univ _⟩
+  have hC0 : C p = 0 := by
+    change splitEquiv ρ (P p) = 0
+    rw [hcenter, map_zero]
+  have hCformula (y : M) (hy : y ∈ C.source) : f y = f p + ∑ i, w i * (C y i) ^ 2 := by
+    change f y = f p + ∑ i, w i * splitEquiv ρ (P y) i ^ 2
+    rw [hsum, hformula y hy.1]
+    ring
+  let c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p :=
+    { weights := w
+      signs := hw
+      chart := C
+      mem_source := hpC
+      center := hC0
+      equation := hCformula
+      inverse_equation := by
+        intro z hz
+        have h := hCformula (C.symm z) (C.map_target' hz)
+        have hr : C (C.symm z) = z := C.right_inv' hz
+        rw [hr] at h
+        exact h }
+  exact ⟨c, hwn, hws⟩
+
+private theorem
+    MorseCancel.exists_signed_chart_of_scaled_cubic_germ {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {m : ℕ}
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (ρ : Option (Fin m) ≃ Fin (Module.finrank ℝ E)) (σ : Fin m → ℝ) (hσ : ∀ i, σ i = -1 ∨ σ i = 1)
+    {a δ b : ℝ} (ha : 0 < a) (hδ : 0 < δ) (e : ℝ) (he : e = -1 ∨ e = 1)
+    (hp : (e * a, (0 : Fin m → ℝ)) ∈ Φ.source)
+    (hgerm : f ∘ Φ =ᶠ[𝓝 (e * a, 0)] fun z => b + δ * cubic σ (-(a ^ 2)) z) :
+    ∃ c : Smale.ManifoldMorse.SignedMorseChart (E := E) f (Φ (e * a, 0)),
+      c.weights (ρ Option.none) = e ∧ ∀ i, c.weights (ρ (Option.some i)) = σ i := by
+  obtain ⟨W, hWsub, hW, hpW⟩ := mem_nhds_iff.mp hgerm
+  let T := Smale.PartialChart.restrictSource Φ hW
+  have hpT : (e * a, (0 : Fin m → ℝ)) ∈ T.source := ⟨hp, hpW⟩
+  have he2 : e ^ 2 = 1 := by rcases he with rfl | rfl <;> norm_num
+  obtain ⟨P, hpP, hP0, -, hP⟩ := exists_endpoint_product_chart σ ha e he2
+  let B : Model m ≃L[ℝ] Model m :=
+    (LinearEquiv.smulOfNeZero ℝ (Model m) (Real.sqrt δ)
+        (Real.sqrt_pos.mpr hδ).ne').toContinuousLinearEquiv
+  let C := (T.symm.trans P).trans B.toDiffeomorph.toPartialDiffeomorph
+  have hTinv : T.symm (Φ (e * a, 0)) = (e * a, 0) := T.left_inv' hpT
+  have hpC : Φ (e * a, 0) ∈ C.source := by
+    change (Φ (e * a, 0) ∈ T.target ∧ T.symm (Φ (e * a, 0)) ∈ P.source) ∧ _
+    exact ⟨⟨T.map_source' hpT, hTinv.symm ▸ hpP⟩, Set.mem_univ _⟩
+  have hC0 : C (Φ (e * a, 0)) = 0 := by
+    change B (P (T.symm (Φ (e * a, 0)))) = 0
+    rw [hTinv, hP0, map_zero]
+  have hvalue : f (Φ (e * a, 0)) = b + δ * cubic σ (-(a ^ 2)) (e * a, 0) := hgerm.self_of_nhds
+  have hscale (z : Model m) :
+    e * (B z).1 ^ 2 + ∑ i, σ i * (B z).2 i ^ 2 = δ * (e * z.1 ^ 2 + ∑ i, σ i * z.2 i ^ 2) := by
+    change e * (Real.sqrt δ * z.1) ^ 2 + (∑ i, σ i * (Real.sqrt δ * z.2 i) ^ 2) = _
+    simp only [mul_pow, Real.sq_sqrt hδ.le]
+    rw [mul_add, Finset.mul_sum]
+    congr 1
+    · ring
+    · apply Finset.sum_congr rfl
+      intro i _
+      ring
+  apply exists_signed_chart_of_split_quadratic C hpC hC0 ρ e σ he hσ
+  intro y hy
+  have hyT : y ∈ T.target := hy.1.1
+  have hzT := T.map_target' hyT
+  have hzP : T.symm y ∈ P.source := hy.1.2
+  have hfy : f y = b + δ * cubic σ (-(a ^ 2)) (T.symm y) := by
+    have hh := hWsub hzT.2
+    change f (T (T.symm y)) = b + δ * cubic σ (-(a ^ 2)) (T.symm y) at hh
+    have hr : T (T.symm y) = y := T.right_inv' hyT
+    rw [hr] at hh
+    exact hh
+  change
+    f y = f (Φ (e * a, 0)) + e * (B (P (T.symm y))).1 ^ 2 + ∑ i, σ i * (B (P (T.symm y))).2 i ^ 2
+  rw [hfy, hvalue, hP (T.symm y) hzP]
+  have hs := hscale (P (T.symm y))
+  linarith
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.negative_card_split {m n : ℕ} (ρ : Option (Fin m) ≃ Fin n) (w : Fin n → ℝ) :
+    Fintype.card { j // w j = -1 } =
+      (if w (ρ Option.none) = -1 then 1 else 0) +
+        Fintype.card { i // w (ρ (Option.some i)) = -1 } := by
+  simp only [Fintype.card_subtype, Finset.card_filter]
+  rw [← ρ.sum_comp, Fintype.sum_option]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.native_index_of_scaled_cubic_germ {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {m : ℕ}
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (hdim : 1 + m = Module.finrank ℝ E) (σ : Fin m → ℝ) (hσ : ∀ i, σ i = -1 ∨ σ i = 1) {a δ b : ℝ}
+    (ha : 0 < a) (hδ : 0 < δ) (e : ℝ) (he : e = -1 ∨ e = 1)
+    (hp : (e * a, (0 : Fin m → ℝ)) ∈ Φ.source)
+    (hgerm : f ∘ Φ =ᶠ[𝓝 (e * a, 0)] fun z => b + δ * cubic σ (-(a ^ 2)) z) :
+    nativeMorseIndex E f (Φ (e * a, 0)) =
+      (if e = -1 then 1 else 0) + Fintype.card { i // σ i = -1 } := by
+  let ρ : Option (Fin m) ≃ Fin (Module.finrank ℝ E) := Fintype.equivOfCardEq (by simp; omega)
+  obtain ⟨c, hce, hcσ⟩ := exists_signed_chart_of_scaled_cubic_germ Φ ρ σ hσ ha hδ e he hp hgerm
+  rw [nativeMorseIndex_eq_chart c]
+  simp only [Smale.ManifoldMorse.SignedMorseChart.NegativeCoordinates,
+    Smale.MorseHandle.NegativeSpace, finrank_euclideanSpace]
+  rw [negative_card_split ρ c.weights, hce]
+  simp only [hcσ]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.native_indices_of_cubic_birth_germs {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {m : ℕ}
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (hdim : 1 + m = Module.finrank ℝ E) (σ : Fin m → ℝ) (hσ : ∀ i, σ i = -1 ∨ σ i = 1) {a δ b : ℝ}
+    (ha : 0 < a) (hδ : 0 < δ) (hp : (a, (0 : Fin m → ℝ)) ∈ Φ.source)
+    (hq : (-a, (0 : Fin m → ℝ)) ∈ Φ.source)
+    (hgp : f ∘ Φ =ᶠ[𝓝 (a, 0)] fun z => b + δ * cubic σ (-(a ^ 2)) z)
+    (hgq : f ∘ Φ =ᶠ[𝓝 (-a, 0)] fun z => b + δ * cubic σ (-(a ^ 2)) z) :
+    nativeMorseIndex E f (Φ (a, 0)) = Fintype.card { i // σ i = -1 } ∧
+      nativeMorseIndex E f (Φ (-a, 0)) = Fintype.card { i // σ i = -1 } + 1 := by
+  constructor
+  · have h :=
+      native_index_of_scaled_cubic_germ Φ hdim σ hσ ha hδ 1 (Or.inr rfl)
+        (by simpa only [one_mul] using hp) (by simpa only [one_mul] using hgp)
+    simpa only [one_mul, ite_eq_right (by norm_num : (1 : ℝ) ≠ -1), zero_add] using h
+  · have h :=
+      native_index_of_scaled_cubic_germ Φ hdim σ hσ ha hδ (-1) (Or.inl rfl)
+        (by simpa only [neg_one_mul] using hq) (by simpa only [neg_one_mul] using hgq)
+    simpa [Nat.add_comm] using h
+
+private theorem MorseCancel.exists_transverse_signs_of_count {m k : ℕ} (hk : k ≤ m) :
+    ∃ σ : Fin m → ℝ, (∀ i, σ i = -1 ∨ σ i = 1) ∧ {i | σ i = -1}.ncard = k := by
+  classical
+  let σ : Fin m → ℝ := fun i => if i.val < k then -1 else 1
+  refine ⟨σ, ?_, ?_⟩
+  · intro i
+    by_cases hi : i.val < k
+    · exact Or.inl (ite_eq_left hi)
+    · exact Or.inr (ite_eq_right hi)
+  · have heq : {i : Fin m | σ i = -1} = {i : Fin m | i.val < k} := by
+      ext i
+      by_cases hi : i.val < k <;> norm_num [σ, hi]
+    rw [heq, ← Set.fintypeCard_eq_ncard, Fintype.card_subtype]
+    simp only [Set.mem_ofPred_eq]
+    rw [Fin.card_filter_val_lt, min_eq_right hk]
+
+private theorem
+    MorseCancel.exists_excellent_indexed_morse_birth {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f)) {l u : ℝ}
+    (hband : ∀ y, f y ∈ Set.Ioo l u → y ∉ Smale.ManifoldMorse.criticalPoints E f) {x : M}
+    (hx : f x ∈ Set.Ioo l u) {k : ℕ} (hk : k < Module.finrank ℝ E) {U : Set M} (hU : IsOpen U)
+    (hxU : x ∈ U) :
+    ∃ (g : M → ℝ) (p q : M),
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+        Smale.ManifoldMorse.IsMorse E g ∧
+          Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) ∧
+            p ∈ U ∧
+              q ∈ U ∧
+                nativeMorseIndex E g p = k ∧
+                  nativeMorseIndex E g q = k + 1 ∧
+                    g p < g q ∧
+                      g p ∈ Set.Ioo l u ∧
+                        g q ∈ Set.Ioo l u ∧
+                          (Smale.ManifoldMorse.criticalPoints E g).ncard =
+                              (Smale.ManifoldMorse.criticalPoints E f).ncard + 2 ∧
+                            (∀ y,
+                                y ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+                                  y ∈ Smale.ManifoldMorse.criticalPoints E f ∨ y = p ∨ y = q) ∧
+                              (∀ y, y ∉ U → g =ᶠ[𝓝 y] f) ∧
+                                (∀ y ∈ Smale.ManifoldMorse.criticalPoints E f, g =ᶠ[𝓝 y] f) ∧
+                                  nativeMorseCount E g k = nativeMorseCount E f k + 1 ∧
+                                    nativeMorseCount E g (k + 1) =
+                                        nativeMorseCount E f (k + 1) + 1 ∧
+                                      ∀ j,
+                                        j ≠ k →
+                                          j ≠ k + 1 →
+                                            nativeMorseCount E g j = nativeMorseCount E f j := by
+  classical
+  let m := Module.finrank ℝ E - 1
+  have hdim : 1 + m = Module.finrank ℝ E := by dsimp [m]; omega
+  have hkm : k ≤ m := by dsimp [m]; omega
+  obtain ⟨σ, hσ, hcard⟩ := exists_transverse_signs_of_count hkm
+  have hσne (i : Fin m) : σ i ≠ 0 := by rcases hσ i with h | h <;> rw [h] <;> norm_num
+  obtain
+    ⟨a, δ, ha, hδ, Φ, hp, hq, hΦ, g, hg, hmg, hinjg, hcount, hcrit, hexterior, hkeep, hpq, hpband,
+      hqband, hgp, hgq⟩ :=
+    exists_excellent_native_morse_birth hf hm hinj hband hx hdim σ hσne hU hxU
+  obtain ⟨hip, hiq⟩ := native_indices_of_cubic_birth_germs Φ hdim σ hσ ha hδ hp hq hgp hgq
+  have hc : Fintype.card { i // σ i = -1 } = k := (Set.fintypeCard_eq_ncard _).trans hcard
+  rw [hc] at hip hiq
+  have hpnot : Φ (a, 0) ∉ Smale.ManifoldMorse.criticalPoints E f := by
+    intro h
+    have hv : g (Φ (a, 0)) = f (Φ (a, 0)) := (hkeep _ h).self_of_nhds
+    exact hband _ (hv ▸ hpband) h
+  have hqnot : Φ (-a, 0) ∉ Smale.ManifoldMorse.criticalPoints E f := by
+    intro h
+    have hv : g (Φ (-a, 0)) = f (Φ (-a, 0)) := (hkeep _ h).self_of_nhds
+    exact hband _ (hv ▸ hqband) h
+  have hreverse (y : M) :
+    y ∈ Smale.ManifoldMorse.criticalPoints E f ↔
+      y ∈ Smale.ManifoldMorse.criticalPoints E g ∧ y ≠ Φ (a, 0) ∧ y ≠ Φ (-a, 0) := by
+    rw [hcrit]
+    constructor
+    · intro hy
+      exact ⟨Or.inl hy, fun h => hpnot (h ▸ hy), fun h => hqnot (h ▸ hy)⟩
+    · rintro ⟨hy | hp' | hq', hnp, hnq⟩
+      · exact hy
+      · exact False.elim (hnp hp')
+      · exact False.elim (hnq hq')
+  have hpcrit := (hcrit (Φ (a, 0))).mpr (Or.inr (Or.inl rfl))
+  have hqcrit := (hcrit (Φ (-a, 0))).mpr (Or.inr (Or.inr rfl))
+  have hneq : Φ (a, 0) ≠ Φ (-a, 0) := fun h => hpq.ne (congrArg g h)
+  obtain ⟨hck, hck', hcothers⟩ :=
+    nativeMorseCount_adjacent_pair (Smale.ManifoldMorse.finite_criticalPoints hg hmg) hpcrit
+      hqcrit hneq hreverse (fun y hy => (hkeep y hy).symm) hip hiq
+  exact
+    ⟨g, Φ (a, 0), Φ (-a, 0), hg, hmg, hinjg, hΦ (Φ.map_source' hp), hΦ (Φ.map_source' hq), hip,
+      hiq, hpq, hpband, hqband, hcount, hcrit, hexterior, hkeep, hck.symm, hck'.symm,
+      fun j hj hj' => (hcothers j hj hj').symm⟩
+
+private theorem MorseCancel.superlevel_bound_of_critical_bound {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [CompactSpace M] {f g : M → ℝ} (hf : Continuous f) (hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g)
+    {l : ℝ} (hboundary : ∀ y, f y = l → g y = l)
+    (hcritical : ∀ y ∈ Smale.ManifoldMorse.criticalPoints E g, l ≤ f y → l ≤ g y) :
+    ∀ x, l ≤ f x → l ≤ g x := by
+  intro x hx
+  have hK : IsCompact {y : M | l ≤ f y} := (isClosed_le continuous_const hf).isCompact
+  obtain ⟨p, hp, hmin⟩ := hK.exists_isMinOn ⟨x, hx⟩ hg.continuous.continuousOn
+  have hgp : l ≤ g p := by
+    by_cases hlt : l < f p
+    · have hlocal : IsLocalMin g p := by
+        filter_upwards [(isOpen_lt continuous_const hf).mem_nhds hlt] with y hy
+        exact hmin hy.le
+      exact hcritical p (Smale.ManifoldMorse.mem_criticalPoints_of_localMin hg hlocal) hp
+    · have heq : f p = l := le_antisymm (le_of_not_gt hlt) hp
+      exact (hboundary p heq).ge
+  exact hgp.trans (hmin hx)
+
+private theorem MorseCancel.birth_preserves_lower_levels {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [CompactSpace M] {f g : M → ℝ} (hf : Continuous f) (hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g)
+    {l : ℝ} {U : Set M} {p q : M} (hU : U ⊆ {y : M | l < f y})
+    (hexterior : ∀ y, y ∉ U → g =ᶠ[𝓝 y] f)
+    (hkeep : ∀ y ∈ Smale.ManifoldMorse.criticalPoints E f, g =ᶠ[𝓝 y] f)
+    (hcrit :
+      ∀ y ∈ Smale.ManifoldMorse.criticalPoints E g,
+        y ∈ Smale.ManifoldMorse.criticalPoints E f ∨ y = p ∨ y = q)
+    (hp : l ≤ g p) (hq : l ≤ g q) {a : ℝ} (ha : a < l) :
+    (∀ y, g y = a ↔ f y = a) ∧ (∀ y, f y ≤ a → g =ᶠ[𝓝 y] f) := by
+  have hout (y : M) (hy : f y ≤ l) : y ∉ U := fun h => (hU h).not_ge hy
+  have hbound : ∀ y, l ≤ f y → l ≤ g y := by
+    apply superlevel_bound_of_critical_bound hf hg
+    · intro y hy
+      exact (hexterior y (hout y hy.le)).self_of_nhds.trans hy
+    · intro y hy hfy
+      rcases hcrit y hy with hold | rfl | rfl
+      · rw [(hkeep y hold).self_of_nhds]
+        exact hfy
+      · exact hp
+      · exact hq
+  refine ⟨?_, fun y hy => hexterior y (hout y (hy.trans ha.le))⟩
+  intro y
+  constructor
+  · intro hgy
+    have hfy : f y ≤ l := by
+      by_contra h
+      have hh := hbound y (le_of_not_ge h)
+      rw [hgy] at hh
+      exact ha.not_ge hh
+    exact ((hexterior y (hout y hfy)).self_of_nhds).symm.trans hgy
+  · intro hfy
+    exact (hexterior y (hout y (hfy ▸ ha.le))).self_of_nhds.trans hfy
+
+private def MorseCancel.equalLevelDiffeomorph {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    {f g : M → ℝ} {a : ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g)
+    (hfr : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hgr : ∀ y, g y = a → y ∉ Smale.ManifoldMorse.criticalPoints E g)
+    (heq : ∀ y, g y = a ↔ f y = a) :
+    let _ := Smale.RegularLevel.chartedSpace hf hfr
+    let _ := Smale.RegularLevel.chartedSpace hg hgr
+    Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+      { y : M // f y = a } { y : M // g y = a } ∞ := by
+  let _ := Smale.RegularLevel.chartedSpace hf hfr
+  let _ := Smale.RegularLevel.chartedSpace hg hgr
+  let F : { y : M // f y = a } → { y : M // g y = a } := fun y => ⟨y, (heq y).mpr y.property⟩
+  let G : { y : M // g y = a } → { y : M // f y = a } := fun y => ⟨y, (heq y).mp y.property⟩
+  exact
+    { toFun := F
+      invFun := G
+      left_inv := fun _ => rfl
+      right_inv := fun _ => rfl
+      contMDiff_toFun :=
+        (Smale.RegularLevel.contMDiff_iff_inclusion hg hgr 𝓘(ℝ, Smale.RegularLevel.Model E) F).mpr
+          (Smale.RegularLevel.contMDiff_inclusion hf hfr)
+      contMDiff_invFun :=
+        (Smale.RegularLevel.contMDiff_iff_inclusion hf hfr 𝓘(ℝ, Smale.RegularLevel.Model E) G).mpr
+          (Smale.RegularLevel.contMDiff_inclusion hg hgr) }
+
+private theorem
+    MorseCancel.regular_level_of_retained_critical_germs {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+     {f g : M → ℝ} {a : ℝ}
+    (hfr : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f) {p q : M}
+    (hcrit :
+      ∀ y ∈ Smale.ManifoldMorse.criticalPoints E g,
+        y ∈ Smale.ManifoldMorse.criticalPoints E f ∨ y = p ∨ y = q)
+    (hkeep : ∀ y ∈ Smale.ManifoldMorse.criticalPoints E f, g =ᶠ[𝓝 y] f) (hp : a < g p)
+    (hq : a < g q) : ∀ y, g y = a → y ∉ Smale.ManifoldMorse.criticalPoints E g := by
+  intro y hy hcy
+  rcases hcrit y hcy with hold | rfl | rfl
+  · exact hfr y (((hkeep y hold).self_of_nhds).symm.trans hy) hold
+  · exact hp.ne' hy
+  · exact hq.ne' hy
+
+private theorem MorseCancel.isotopicToIdentity_conj {E F H H' M N : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [TopologicalSpace M]
+    [ChartedSpace H M] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H']
+    {J : ModelWithCorners ℝ F H'} [TopologicalSpace N] [ChartedSpace H' N]
+    (e : Diffeomorph I J M N ∞) {d : Diffeomorph I I M M ∞}
+    (hd : Smale.SupportedDiffeomorph.IsotopicToIdentity d) :
+    Smale.SupportedDiffeomorph.IsotopicToIdentity ((e.symm.trans d).trans e) := by
+  obtain ⟨A, hA, hA0, hA1, hslices⟩ := hd
+  refine
+    ⟨(fun p => e (A (p.1, e.symm p.2))),
+      e.contMDiff.comp (hA.comp (contMDiff_fst.prodMk (e.symm.contMDiff.comp contMDiff_snd))), ?_,
+      ?_, ?_⟩
+  · intro y
+    change e (A (0, e.symm y)) = y
+    rw [hA0, e.apply_symm_apply]
+  · intro y
+    change e (A (1, e.symm y)) = e (d (e.symm y))
+    rw [hA1]
+  · intro t
+    obtain ⟨dₜ, hdₜ⟩ := hslices t
+    refine ⟨(e.symm.trans dₜ).trans e, ?_⟩
+    intro y
+    change e (A (t, e.symm y)) = e (dₜ (e.symm y))
+    rw [hdₜ]
+
+private theorem MorseCancel.exists_equal_level_circle_isotopy {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PathConnectedSpace M] {f g : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g) (e : M ≃ₕ Smale.SixSphere)
+    (hdim : Module.finrank ℝ E = 6) {a : ℝ}
+    (hfr : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hgr : ∀ y, g y = a → y ∉ Smale.ManifoldMorse.criticalPoints E g)
+    (heq : ∀ y, g y = a ↔ f y = a)
+    (hhigh : ∀ p : Smale.ManifoldMorse.criticalPoints E f, a ≤ f p → 3 ≤ nativeMorseIndex E f p)
+    (hlow : ∀ p : Smale.ManifoldMorse.criticalPoints E f, f p ≤ a → nativeMorseIndex E f p ≤ 3)
+    (γ δ : C(Smale.Hemisphere.Sphere 1, { y : M // g y = a })) :
+    let _ := Smale.RegularLevel.chartedSpace hg hgr
+    ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ γ →
+      Function.Injective γ →
+        (∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) γ z)) →
+          ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ δ →
+            Function.Injective δ →
+              (∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) δ z)) →
+                ∃ P :
+                  Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+                    { y : M // g y = a } { y : M // g y = a } ∞,
+                  Smale.SupportedDiffeomorph.IsotopicToIdentity P ∧ ∀ z, P (γ z) = δ z := by
+  let _ := Smale.RegularLevel.chartedSpace hf hfr
+  let _ := Smale.RegularLevel.chartedSpace hg hgr
+  let _ := Smale.RegularLevel.isManifold hf hfr
+  let _ := Smale.RegularLevel.isManifold hg hgr
+  change
+    ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ γ →
+      Function.Injective γ →
+        (∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) γ z)) →
+          ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ δ →
+            Function.Injective δ →
+              (∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) δ z)) → _
+  intro hγ hγi hγd hδ hδi hδd
+  let L := equalLevelDiffeomorph hf hg hfr hgr heq
+  let γ' : C(Smale.Hemisphere.Sphere 1, { y : M // f y = a }) :=
+    ⟨L.symm ∘ γ, L.symm.continuous.comp γ.continuous⟩
+  let δ' : C(Smale.Hemisphere.Sphere 1, { y : M // f y = a }) :=
+    ⟨L.symm ∘ δ, L.symm.continuous.comp δ.continuous⟩
+  have hγ' : ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ γ' := L.symm.contMDiff.comp hγ
+  have hδ' : ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ δ' := L.symm.contMDiff.comp hδ
+  have hderiv (κ : C(Smale.Hemisphere.Sphere 1, { y : M // g y = a }))
+    (hk : ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ κ)
+    (hkd : ∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) κ z)) (z) :
+    Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) (L.symm ∘ κ) z) := by
+    rw [mfderiv_comp z (L.symm.contMDiff.mdifferentiableAt (by simp))
+        (hk.mdifferentiableAt (by simp))]
+    exact (L.symm.mfderivToContinuousLinearEquiv (by simp) (κ z)).injective.comp (hkd z)
+  obtain ⟨Q, hQ, hformula⟩ :=
+    exists_native_middle_level_circle_isotopy S hf e hdim hfr hhigh hlow γ' δ' hγ'
+      (L.symm.injective.comp hγi) (hderiv γ hγ hγd) hδ' (L.symm.injective.comp hδi)
+      (hderiv δ hδ hδd)
+  refine ⟨(L.symm.trans Q).trans L, isotopicToIdentity_conj L hQ, ?_⟩
+  intro z
+  change L (Q (γ' z)) = δ z
+  rw [hformula]
+  exact L.apply_symm_apply (δ z)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.exists_new_attaching_circle_placement {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PathConnectedSpace M] {f g : M → ℝ}
+    (S : AdaptedWindows E f) (T : AdaptedWindows E g) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g) (e : M ≃ₕ Smale.SixSphere)
+    (hdim : Module.finrank ℝ E = 6) {a : ℝ}
+    (hfr : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hgr : ∀ y, g y = a → y ∉ Smale.ManifoldMorse.criticalPoints E g)
+    (heq : ∀ y, g y = a ↔ f y = a)
+    (hhigh : ∀ q : Smale.ManifoldMorse.criticalPoints E f, a ≤ f q → 3 ≤ nativeMorseIndex E f q)
+    (hlow : ∀ q : Smale.ManifoldMorse.criticalPoints E f, f q ≤ a → nativeMorseIndex E f q ≤ 3)
+    (p : Smale.ManifoldMorse.criticalPoints E g)
+    [Fact (Module.finrank ℝ (T.data p).chart.NegativeCoordinates = 1 + 1)] (hap : a < g p)
+    (hgap : ∀ q : Smale.ManifoldMorse.criticalPoints E g, g q < g p → g q < a)
+    (δ : C(Smale.Hemisphere.Sphere 1, { y : M // g y = a })) :
+    let _ := Smale.RegularLevel.chartedSpace hg hgr
+    ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ δ →
+      Function.Injective δ →
+        (∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) δ z)) →
+          ∃ Γ : C(Smale.Hemisphere.Sphere 1, { y : M // g y = a }),
+            ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ Γ ∧
+              Function.Injective Γ ∧
+                (∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) Γ z)) ∧
+                  (∀ x,
+                      x ∈ Set.range Γ ↔
+                        Filter.Tendsto (fun t => T.flow t x.val) Filter.atBot (𝓝 p.val)) ∧
+                    ∃ P :
+                      Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E)
+                        𝓘(ℝ, Smale.RegularLevel.Model E) { y : M // g y = a } { y : M // g y = a }
+                        ∞,
+                      Smale.SupportedDiffeomorph.IsotopicToIdentity P ∧
+                        (∀ z, P (Γ z) = δ z) ∧
+                          ∀ x,
+                            Filter.Tendsto (fun t => T.flow t x.val) Filter.atBot (𝓝 p.val) ↔
+                              P x ∈ Set.range δ := by
+  let _ := Smale.RegularLevel.chartedSpace hg hgr
+  let _ := Smale.RegularLevel.chartedSpace hg (T.data p).lower_regular
+  let _ := Smale.RegularLevel.isManifold hg hgr
+  let _ := Smale.RegularLevel.isManifold hg (T.data p).lower_regular
+  change
+    ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ δ →
+      Function.Injective δ →
+        (∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) δ z)) → _
+  intro hδ hδi hδd
+  obtain ⟨σ, D, -, -, Γ, hΓ, hΓi, hΓd, -, -, hflow⟩ :=
+    T.exists_attaching_circle_lower_transport hg p hgr hap hgap
+  have hrange (x : { y : M // g y = a }) :
+    x ∈ Set.range Γ ↔ Filter.Tendsto (fun t => T.flow t x.val) Filter.atBot (𝓝 p.val) :=
+    T.transported_attaching_range_iff hg p hgr σ σ.surjective Γ hflow x
+  obtain ⟨P, hP, hformula⟩ :=
+    exists_equal_level_circle_isotopy S hf hg e hdim hfr hgr heq hhigh hlow Γ δ hΓ hΓi hΓd hδ hδi
+      hδd
+  refine ⟨Γ, hΓ, hΓi, hΓd, hrange, P, hP, hformula, ?_⟩
+  intro x
+  rw [← hrange]
+  constructor
+  · rintro ⟨z, rfl⟩
+    exact ⟨z, (hformula z).symm⟩
+  · rintro ⟨z, hz⟩
+    exact ⟨z, P.injective ((hformula z).trans hz)⟩
+
+private theorem MorseCancel.unit_level_count_of_circle_placement {M X : Type*} [TopologicalSpace M]
+    (F : Flow ℝ M) {f : M → ℝ} {a : ℝ} {p q : M} (P : { y : M // f y = a } ≃ { y : M // f y = a })
+    (δ : X → { y : M // f y = a }) (z₀ : X)
+    (hplacement : ∀ x, Filter.Tendsto (fun t => F t x.val) Filter.atBot (𝓝 p) ↔ P x ∈ Set.range δ)
+    (hsingle : ∀ z, Filter.Tendsto (fun t => F t (δ z).val) Filter.atTop (𝓝 q) ↔ z = z₀) :
+    {x : { y : M // f y = a } |
+          Filter.Tendsto (fun t => F t x.val) Filter.atBot (𝓝 p) ∧
+            Filter.Tendsto (fun t => F t (P x).val) Filter.atTop (𝓝 q)}.ncard =
+      1 := by
+  have heq :
+    {x : { y : M // f y = a } |
+        Filter.Tendsto (fun t => F t x.val) Filter.atBot (𝓝 p) ∧
+          Filter.Tendsto (fun t => F t (P x).val) Filter.atTop (𝓝 q)} =
+      {P.symm (δ z₀)} := by
+    ext x
+    constructor
+    · rintro ⟨hx, hforward⟩
+      obtain ⟨z, hz⟩ := (hplacement x).mp hx
+      have hz0 : z = z₀ := (hsingle z).mp (hz.symm ▸ hforward)
+      apply Set.mem_singleton_iff.mpr
+      apply P.injective
+      rw [P.apply_symm_apply, ← hz, hz0]
+    · intro hx
+      rcases Set.mem_singleton_iff.mp hx with rfl
+      refine ⟨(hplacement _).mpr ⟨z₀, (P.apply_symm_apply _).symm⟩, ?_⟩
+      rw [P.apply_symm_apply]
+      exact (hsingle z₀).mpr rfl
+  rw [heq]
+  exact Set.ncard_singleton _
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.exists_handle_trade_transverse_level_data {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PathConnectedSpace M] {f g : M → ℝ}
+    (S : AdaptedWindows E f) (T : AdaptedWindows E g) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g) (e : M ≃ₕ Smale.SixSphere)
+    (hdim : Module.finrank ℝ E = 6) {a : ℝ}
+    (hfr : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hgr : ∀ y, g y = a → y ∉ Smale.ManifoldMorse.criticalPoints E g)
+    (heq : ∀ y, g y = a ↔ f y = a)
+    (hhigh : ∀ z : Smale.ManifoldMorse.criticalPoints E f, a ≤ f z → 3 ≤ nativeMorseIndex E f z)
+    (hlow : ∀ z : Smale.ManifoldMorse.criticalPoints E f, f z ≤ a → nativeMorseIndex E f z ≤ 3)
+    (m q r : Smale.ManifoldMorse.criticalPoints E g) (hm : nativeMorseIndex E g m = 0)
+    (hq : nativeMorseIndex E g q = 1) (hr : nativeMorseIndex E g r = 2)
+    [Fact (Module.finrank ℝ (T.data q).chart.PositiveCoordinates = 4 + 1)]
+    (u : Metric.sphere (0 : (T.data q).chart.NegativeCoordinates) 1)
+    (hbranches :
+      ∀ w : Metric.sphere (0 : (T.data q).chart.NegativeCoordinates) 1,
+        Filter.Tendsto (fun t => T.flow t ((T.data q).surgery.attachingSphere w).val) Filter.atTop
+          (𝓝 m.val))
+    (hqa : T.toSurgeryWindows.upper q ≤ a) (har : a < g r)
+    (hgap : ∀ z : Smale.ManifoldMorse.criticalPoints E g, g z < g r → g z < a)
+    (hnewlow :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E g, g z ≤ a → nativeMorseIndex E g z ≤ 2) :
+    let _ := Smale.RegularLevel.chartedSpace hg hgr
+    ∃ P :
+      Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+        { y : M // g y = a } { y : M // g y = a } ∞,
+      Smale.SupportedDiffeomorph.IsotopicToIdentity P ∧
+        {x : { y : M // g y = a } |
+                Filter.Tendsto (fun t => T.flow t x.val) Filter.atBot (𝓝 r.val) ∧
+                  Filter.Tendsto (fun t => T.flow t (P x).val) Filter.atTop (𝓝 q.val)}.ncard =
+            1 ∧
+          ∃ (α : C(Smale.Hemisphere.Sphere 1, { y : M // g y = a })) (z₀ :
+            Smale.Hemisphere.Sphere 1) (β :
+            Metric.sphere (0 : (T.data q).chart.PositiveCoordinates) 1 → { y : M // g y = a }) (v
+            : Metric.sphere (0 : (T.data q).chart.PositiveCoordinates) 1),
+            ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ α ∧
+              MDifferentiableAt (𝓡 4) 𝓘(ℝ, Smale.RegularLevel.Model E) β v ∧
+                β v = α z₀ ∧
+                  Smale.NativeTransversality.At (𝓡 1) (𝓡 4) 𝓘(ℝ, Smale.RegularLevel.Model E) α β
+                      z₀ v ∧
+                    (∀ z, Filter.Tendsto (fun t => T.flow t (α z).val) Filter.atBot (𝓝 r.val)) ∧
+                      (∀ᶠ w in 𝓝 v,
+                          Filter.Tendsto (fun t => T.flow t (P (β w)).val) Filter.atTop
+                            (𝓝 q.val)) ∧
+                        ∀ x : { y : M // g y = a },
+                          Filter.Tendsto (fun t => T.flow t x.val) Filter.atBot (𝓝 r.val) →
+                            Filter.Tendsto (fun t => T.flow t (P x).val) Filter.atTop (𝓝 m.val) ∨
+                              Filter.Tendsto (fun t => T.flow t (P x).val) Filter.atTop
+                                (𝓝 q.val) := by
+  let _ := Smale.RegularLevel.chartedSpace hg hgr
+  let _ := Smale.RegularLevel.isManifold hg hgr
+  let _ : Fact (Module.finrank ℝ (T.data r).chart.NegativeCoordinates = 1 + 1) :=
+    ⟨(nativeMorseIndex_eq_chart (T.data r).chart).symm.trans hr⟩
+  obtain ⟨δ, hδ, hδi, hδd, z₀, v, β₀, hβ₀, hcross₀, htrans₀, hβbasin, hsingle, hendpoints⟩ :=
+    T.exists_transverse_middle_belt_loop hg hdim m q hm hq u hbranches hqa hgr hnewlow
+  obtain ⟨α, hα, -, -, hrange, P, hP, hplace, hplacement⟩ :=
+    exists_new_attaching_circle_placement S T hf hg e hdim hfr hgr heq hhigh hlow r har hgap δ hδ
+      hδi hδd
+  obtain ⟨β, hβ, hcross, htrans, hPβ⟩ :=
+    exists_transverse_sheet_of_circle_placement P (hα.mdifferentiableAt (by simp)) hβ₀ hplace
+      hcross₀ htrans₀
+  refine
+    ⟨P, hP, unit_level_count_of_circle_placement T.flow P.toEquiv δ z₀ hplacement hsingle, α, z₀,
+      β, v, hα, hβ, hcross, htrans, ?_, ?_, ?_⟩
+  · intro z
+    exact (hrange (α z)).mp ⟨z, rfl⟩
+  · filter_upwards [hβbasin] with w hw
+    rw [hPβ w]
+    exact hw
+  · intro x hx
+    obtain ⟨z, hz⟩ := (hplacement x).mp hx
+    rw [← hz]
+    exact hendpoints z
+
+private theorem AdaptedWindows.realize_unit_level_isotopy {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p q : Smale.ManifoldMorse.criticalPoints E f) {a : ℝ}
+    (hpa : a < f p) (hqa : f q < a)
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    let _ := Smale.RegularLevel.chartedSpace hf ha
+    ∀ P :
+      Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+        { y : M // f y = a } { y : M // f y = a } ∞,
+      Smale.SupportedDiffeomorph.IsotopicToIdentity P →
+        {x : { y : M // f y = a } |
+                Filter.Tendsto (fun t => S.flow t x.val) Filter.atBot (𝓝 p.val) ∧
+                  Filter.Tendsto (fun t => S.flow t (P x).val) Filter.atTop (𝓝 q.val)}.ncard =
+            1 →
+          ∃ (V : (x : M) → TangentSpace 𝓘(ℝ, E) x) (G : Flow ℝ M) (z : { y : M // f y = a }),
+            ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞
+                (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+              (∀ x, IsMIntegralCurve (fun t => G t x) V) ∧
+                (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0) ∧
+                  (∀ x,
+                      x ∉ Smale.ManifoldMorse.criticalPoints E f →
+                        mvfderiv 𝓘(ℝ, E) f x (V x) < 0) ∧
+                    (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ y in 𝓝 x, V y = S.field y) ∧
+                      Filter.Tendsto (fun t => G t z.val) Filter.atBot (𝓝 p.val) ∧
+                        Filter.Tendsto (fun t => G t z.val) Filter.atTop (𝓝 q.val) ∧
+                          (∀ x,
+                              Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 p.val) →
+                                Filter.Tendsto (fun t => G t x) Filter.atTop (𝓝 q.val) →
+                                  ∃ t, G t z.val = x) ∧
+                            (∀ (x : { y : M // f y = a }) y,
+                                Filter.Tendsto (fun t => G t x.val) Filter.atBot (𝓝 y) ↔
+                                  Filter.Tendsto (fun t => S.flow t x.val) Filter.atBot (𝓝 y)) ∧
+                              ∀ (x : { y : M // f y = a }) y,
+                                Filter.Tendsto (fun t => G t x.val) Filter.atTop (𝓝 y) ↔
+                                  Filter.Tendsto (fun t => S.flow t (P x).val) Filter.atTop
+                                    (𝓝 y) := by
+  let _ := Smale.RegularLevel.chartedSpace hf ha
+  let _ := Smale.RegularLevel.isManifold hf ha
+  change
+    ∀ P :
+      Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+        { y : M // f y = a } { y : M // f y = a } ∞,
+      Smale.SupportedDiffeomorph.IsotopicToIdentity P →
+        {x : { y : M // f y = a } |
+                Filter.Tendsto (fun t => S.flow t x.val) Filter.atBot (𝓝 p.val) ∧
+                  Filter.Tendsto (fun t => S.flow t (P x).val) Filter.atTop (𝓝 q.val)}.ncard =
+            1 →
+          _
+  intro P hP hcount
+  obtain ⟨z₀, -⟩ := Set.ncard_eq_one.mp hcount
+  obtain ⟨l, b, hl, hb, hband⟩ := S.regular_interval_around_level ha
+  obtain
+    ⟨r, C, W, V, H, G, -, -, -, -, -, -, hgeometry, hV, hG, hzero, hdesc, hgerms, -, hend, -,
+      hleft, hright⟩ :=
+    Degree.FlowSuspension.exists_native_regular_level_isotopy_realization hf S.smooth S.descent
+      S.flow S.integral hl hb hband ha z₀ P hP
+  obtain ⟨hback, hforward⟩ :=
+    Degree.FlowSuspension.whole_level_basins_of_holonomy S.flow H G Subtype.val P
+      (fun x y => (hgeometry x).2.1 y) (fun x y => (hgeometry x).2.2 y) hend hleft hright
+  obtain ⟨z, hzb, hzf, hunique⟩ :=
+    Degree.FlowSuspension.exists_unique_connection_of_unit_level_count S.flow G hf.continuous hpa
+      hqa P (fun x => hback x p.val) (fun x => hforward x q.val) hcount
+  exact
+    ⟨V, G, z, hV, hG, (fun x hx => (hzero x).mpr (S.zero x hx)), hdesc, hgerms, hzb, hzf, hunique,
+      hback, hforward⟩
+
+private theorem
+    AdaptedWindows.realize_unit_transverse_level_isotopy {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} {A B HA HB X Y : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [TopologicalSpace HA] [TopologicalSpace HB] {I : ModelWithCorners ℝ A HA}
+    {I' : ModelWithCorners ℝ B HB} [TopologicalSpace X] [ChartedSpace HA X] [TopologicalSpace Y]
+    [ChartedSpace HB Y] (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (p q : Smale.ManifoldMorse.criticalPoints E f) {a : ℝ} (hpa : a < f p) (hqa : f q < a)
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    let _ := Smale.RegularLevel.chartedSpace hf ha
+    ∀ P :
+      Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+        { y : M // f y = a } { y : M // f y = a } ∞,
+      Smale.SupportedDiffeomorph.IsotopicToIdentity P →
+        {x : { y : M // f y = a } |
+                Filter.Tendsto (fun t => S.flow t x.val) Filter.atBot (𝓝 p.val) ∧
+                  Filter.Tendsto (fun t => S.flow t (P x).val) Filter.atTop (𝓝 q.val)}.ncard =
+            1 →
+          ∀ (α : X → { y : M // f y = a }) (β : Y → { y : M // f y = a }) (x : X) (y : Y),
+            MDifferentiableAt I 𝓘(ℝ, Smale.RegularLevel.Model E) α x →
+              MDifferentiableAt I' 𝓘(ℝ, Smale.RegularLevel.Model E) β y →
+                β y = α x →
+                  Smale.NativeTransversality.At I I' 𝓘(ℝ, Smale.RegularLevel.Model E) α β x y →
+                    (∀ᶠ u in 𝓝 x,
+                        Filter.Tendsto (fun t => S.flow t (α u).val) Filter.atBot (𝓝 p.val)) →
+                      (∀ᶠ u in 𝓝 y,
+                          Filter.Tendsto (fun t => S.flow t (P (β u)).val) Filter.atTop
+                            (𝓝 q.val)) →
+                        ∃ (V : (z : M) → TangentSpace 𝓘(ℝ, E) z) (G : Flow ℝ M),
+                          ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞
+                              (fun z => (⟨z, V z⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+                            (∀ z, IsMIntegralCurve (fun t => G t z) V) ∧
+                              (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, V z = 0) ∧
+                                (∀ z,
+                                    z ∉ Smale.ManifoldMorse.criticalPoints E f →
+                                      mvfderiv 𝓘(ℝ, E) f z (V z) < 0) ∧
+                                  (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+                                      ∀ᶠ w in 𝓝 z, V w = S.field w) ∧
+                                    Filter.Tendsto (fun t => G t (α x).val) Filter.atBot
+                                        (𝓝 p.val) ∧
+                                      Filter.Tendsto (fun t => G t (α x).val) Filter.atTop
+                                          (𝓝 q.val) ∧
+                                        (∀ z,
+                                            Filter.Tendsto (fun t => G t z) Filter.atBot
+                                                (𝓝 p.val) →
+                                              Filter.Tendsto (fun t => G t z) Filter.atTop
+                                                  (𝓝 q.val) →
+                                                ∃ t, G t (α x).val = z) ∧
+                                          (∀ (z : { w : M // f w = a }) w,
+                                              Filter.Tendsto (fun t => G t z.val) Filter.atBot
+                                                  (𝓝 w) ↔
+                                                Filter.Tendsto (fun t => S.flow t z.val)
+                                                  Filter.atBot (𝓝 w)) ∧
+                                            (∀ (z : { w : M // f w = a }) w,
+                                                Filter.Tendsto (fun t => G t z.val) Filter.atTop
+                                                    (𝓝 w) ↔
+                                                  Filter.Tendsto (fun t => S.flow t (P z).val)
+                                                    Filter.atTop (𝓝 w)) ∧
+                                              let C : X × ℝ → M := fun u => G u.2 (α u.1).val
+                                              let D : Y × ℝ → M := fun u => G u.2 (β u.1).val
+                                              MDifferentiableAt (I.prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) C
+                                                  (x, 0) ∧
+                                                MDifferentiableAt (I'.prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) D
+                                                    (y, 0) ∧
+                                                  C (x, 0) = (α x).val ∧
+                                                    D (y, 0) = (α x).val ∧
+                                                      (∀ᶠ u in 𝓝 (x, (0 : ℝ)),
+                                                          Filter.Tendsto (fun t => G t (C u))
+                                                            Filter.atBot (𝓝 p.val)) ∧
+                                                        (∀ᶠ u in 𝓝 (y, (0 : ℝ)),
+                                                            Filter.Tendsto (fun t => G t (D u))
+                                                              Filter.atTop (𝓝 q.val)) ∧
+                                                          Smale.NativeTransversality.At
+                                                            (I.prod 𝓘(ℝ, ℝ)) (I'.prod 𝓘(ℝ, ℝ))
+                                                            𝓘(ℝ, E) C D (x, 0) (y, 0) := by
+  let _ := Smale.RegularLevel.chartedSpace hf ha
+  let _ := Smale.RegularLevel.isManifold hf ha
+  change
+    ∀ P :
+      Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+        { y : M // f y = a } { y : M // f y = a } ∞,
+      Smale.SupportedDiffeomorph.IsotopicToIdentity P →
+        {x : { y : M // f y = a } |
+                Filter.Tendsto (fun t => S.flow t x.val) Filter.atBot (𝓝 p.val) ∧
+                  Filter.Tendsto (fun t => S.flow t (P x).val) Filter.atTop (𝓝 q.val)}.ncard =
+            1 →
+          _
+  intro P hP hcount α β x y hα hβ hcross htrans hαbasin hβbasin
+  obtain ⟨V, G, z, hV, hG, hzero, hdesc, hgerms, -, -, hunique, hback, hforward⟩ :=
+    S.realize_unit_level_isotopy hf p q hpa hqa ha P hP hcount
+  have hαG : ∀ᶠ u in 𝓝 x, Filter.Tendsto (fun t => G t (α u).val) Filter.atBot (𝓝 p.val) := by
+    filter_upwards [hαbasin] with u hu
+    exact (hback (α u) p.val).mpr hu
+  have hβG : ∀ᶠ u in 𝓝 y, Filter.Tendsto (fun t => G t (β u).val) Filter.atTop (𝓝 q.val) := by
+    filter_upwards [hβbasin] with u hu
+    exact (hforward (β u) q.val).mpr hu
+  have hxforward : Filter.Tendsto (fun t => G t (α x).val) Filter.atTop (𝓝 q.val) := by
+    have hh := hβG.self_of_nhds
+    rwa [hcross] at hh
+  obtain ⟨s, hs⟩ := hunique (α x).val hαG.self_of_nhds hxforward
+  have huniq (w : M) (hwb : Filter.Tendsto (fun t => G t w) Filter.atBot (𝓝 p.val))
+    (hwf : Filter.Tendsto (fun t => G t w) Filter.atTop (𝓝 q.val)) : ∃ t, G t (α x).val = w := by
+    obtain ⟨t, ht⟩ := hunique w hwb hwf
+    refine ⟨t - s, ?_⟩
+    rw [← hs, ← G.map_add, sub_add_cancel, ht]
+  refine
+    ⟨V, G, hV, hG, hzero, hdesc, hgerms, hαG.self_of_nhds, hxforward, huniq, hback, hforward, ?_⟩
+  exact
+    Degree.FlowSuspension.native_transverse_basin_tubes_of_level_maps hf ha hV G hG
+      (fun w hw => hdesc w (ha w hw)) α β x y hα hβ hcross htrans hαG hβG
+
+private theorem
+    MorseCancel.no_other_connections_of_two_level_endpoints {M : Type*} [TopologicalSpace M]
+    [T2Space M] (F : Flow ℝ M) {f : M → ℝ} (hf : Continuous f) {C : Set M} (hinj : Set.InjOn f C)
+    (p q r : C) {a : ℝ} (hpa : a < f p) (hgap : ∀ j : C, f j < f p → f j < a)
+    (hmono : ∀ x, Antitone (fun t : ℝ => f (F t x)))
+    (hends :
+      ∀ x : { y : M // f y = a },
+        Filter.Tendsto (fun t => F t x.val) Filter.atBot (𝓝 p.val) →
+          Filter.Tendsto (fun t => F t x.val) Filter.atTop (𝓝 q.val) ∨
+            Filter.Tendsto (fun t => F t x.val) Filter.atTop (𝓝 r.val)) :
+    ∀ j : C,
+      j ≠ p →
+        j ≠ q →
+          j ≠ r →
+            ∀ x,
+              ¬(Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p.val) ∧
+                  Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 j.val)) := by
+  intro j hjp hjq hjr x hx
+  have hforwardHeight := hf.continuousAt.tendsto.comp hx.2
+  have hbackwardHeight := hf.continuousAt.tendsto.comp hx.1
+  have hle : f j ≤ f p :=
+    (hmono x).le_of_tendsto hforwardHeight 0 |>.trans ((hmono x).ge_of_tendsto hbackwardHeight 0)
+  have hlt : f j < f p :=
+    lt_of_le_of_ne hle (fun h => hjp (Subtype.ext (hinj j.property p.property h)))
+  obtain ⟨t, ht⟩ :=
+    Degree.FlowCancellation.exists_level_crossing_of_endpoint_limits F hf hx.1 hx.2 hpa
+      (hgap j hlt)
+  let z : { y : M // f y = a } := ⟨F t x, ht⟩
+  have hzb : Filter.Tendsto (fun s => F s z.val) Filter.atBot (𝓝 p.val) :=
+    (flow_time_atBot_limit_iff F t x p.val).mpr hx.1
+  have hzf : Filter.Tendsto (fun s => F s z.val) Filter.atTop (𝓝 j.val) :=
+    (flow_time_atTop_limit_iff F t x j.val).mpr hx.2
+  rcases hends z hzb with hq | hr
+  · exact hjq (Subtype.ext (tendsto_nhds_unique hzf hq))
+  · exact hjr (Subtype.ext (tendsto_nhds_unique hzf hr))
+
+private theorem MorseCancel.cancel_transverse_pair_after_flow_preserving_descent {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PreconnectedSpace M]
+    {f : M → ℝ} {m : ℕ} {A B HA HB X Y : Type*} [NormedAddCommGroup A] [NormedSpace ℝ A]
+    [NormedAddCommGroup B] [NormedSpace ℝ B] [TopologicalSpace HA] [TopologicalSpace HB]
+    {I : ModelWithCorners ℝ A HA} {I' : ModelWithCorners ℝ B HB} [TopologicalSpace X]
+    [ChartedSpace HA X] [TopologicalSpace Y] [ChartedSpace HB Y]
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f))
+    (hdim : Module.finrank ℝ E = m + 1) {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0)
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hmodels :
+      ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+        ∃ c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x,
+          ∀ᶠ y in 𝓝 x, V y = c.descentField y)
+    (p r q : Smale.ManifoldMorse.criticalPoints E f) (hrp : f r < f p) (hpq : f p < f q)
+    (hindex : nativeMorseIndex E f q = nativeMorseIndex E f p + 1)
+    (hnoconnection :
+      ∀ j : Smale.ManifoldMorse.criticalPoints E f,
+        j ≠ q →
+          j ≠ p →
+            j ≠ r →
+              ∀ x,
+                ¬(Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 q.val) ∧
+                    Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 j.val)))
+    {z : M} (hzp : Filter.Tendsto (fun t => F t z) Filter.atTop (𝓝 p.val))
+    (hzq : Filter.Tendsto (fun t => F t z) Filter.atBot (𝓝 q.val))
+    (hunique :
+      ∀ x,
+        Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 q.val) →
+          Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p.val) → ∃ t, F t z = x)
+    {α : X → M} {β : Y → M} {x : X} {y : Y} (hα : MDifferentiableAt I 𝓘(ℝ, E) α x)
+    (hβ : MDifferentiableAt I' 𝓘(ℝ, E) β y) (hα0 : α x = z) (hβ0 : β y = z)
+    (hαbasin : ∀ᶠ u in 𝓝 x, Filter.Tendsto (fun t => F t (α u)) Filter.atBot (𝓝 q.val))
+    (hβbasin : ∀ᶠ u in 𝓝 y, Filter.Tendsto (fun t => F t (β u)) Filter.atTop (𝓝 p.val))
+    (htrans : Smale.NativeTransversality.At I I' 𝓘(ℝ, E) α β x y) :
+    ∃ g : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+        Smale.ManifoldMorse.IsMorse E g ∧
+          Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) ∧
+            (Smale.ManifoldMorse.criticalPoints E g).ncard + 2 =
+                (Smale.ManifoldMorse.criticalPoints E f).ncard ∧
+              (∀ w,
+                  w ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+                    w ∈ Smale.ManifoldMorse.criticalPoints E f ∧ w ≠ p.val ∧ w ≠ q.val) ∧
+                ∀ w ∈ Smale.ManifoldMorse.criticalPoints E g,
+                  nativeMorseIndex E g w = nativeMorseIndex E f w := by
+  obtain ⟨h, hh, hmh, hcrit, hinjh, -, -, hpqh, hconsecutive, hdesch, hmodelsh, hindices⟩ :=
+    exists_flow_preserving_consecutive_pair hf hm hinj hV F hF hzero hdesc hmodels p r q hrp hpq
+      hnoconnection
+  have hpcrit : p.val ∈ Smale.ManifoldMorse.criticalPoints E h := hcrit.symm ▸ p.property
+  have hqcrit : q.val ∈ Smale.ManifoldMorse.criticalPoints E h := hcrit.symm ▸ q.property
+  obtain ⟨cp, hcp⟩ := hmodelsh p.val hpcrit
+  obtain ⟨cq, hcq⟩ := hmodelsh q.val hqcrit
+  have hidx :
+    Module.finrank ℝ cq.NegativeCoordinates = Module.finrank ℝ cp.NegativeCoordinates + 1 := by
+    rw [← nativeMorseIndex_eq_chart cq, ← nativeMorseIndex_eq_chart cp, hindices q.val q.property,
+      hindices p.val p.property]
+    exact hindex
+  have hcard :
+    Fintype.card { i // cq.weights i = -1 } = Fintype.card { i // cp.weights i = -1 } + 1 := by
+    simpa only [Smale.ManifoldMorse.SignedMorseChart.NegativeCoordinates,
+      Smale.MorseHandle.NegativeSpace, finrank_euclideanSpace] using hidx
+  obtain ⟨W⟩ := Smale.ManifoldMorse.nonempty_surgeryWindows hh hmh hinjh
+  let ph : Smale.ManifoldMorse.criticalPoints E h := ⟨p.val, hpcrit⟩
+  let qh : Smale.ManifoldMorse.criticalPoints E h := ⟨q.val, hqcrit⟩
+  have hconsecutiveh : ∀ s : Smale.ManifoldMorse.criticalPoints E h, ¬(h ph < h s ∧ h s < h qh) :=
+    by
+    intro s hs
+    exact hconsecutive ⟨s.val, hcrit ▸ s.property⟩ hs
+  have hpair := surgery_pair_band_isolation W ph qh hconsecutiveh
+  obtain ⟨g, hg, hmg, hcount, hcritg, hexterior⟩ :=
+    cancel_unique_connection_of_transverse_basin_sheets cp cq hh hmh hdim hcard V hV
+      (fun w hw => hzero w (hcrit ▸ hw)) hdesch F hF hinjh hpcrit hqcrit hpqh
+      (W.lower_lt_value ph) (W.value_lt_upper qh) hpair hzp hzq hunique hcp hcq hα hβ hα0 hβ0
+      hαbasin hβbasin htrans
+  have hkeep := surviving_critical_germs_of_pair_band hpair hcritg hexterior
+  have hinjg :=
+    distinct_critical_values_of_surviving_germs hinjh (fun w hw => ((hcritg w).mp hw).1) hkeep
+  rw [hcrit] at hcount
+  refine ⟨g, hg, hmg, hinjg, hcount, ?_, ?_⟩
+  · intro w
+    rw [hcritg w, hcrit]
+  · intro w hw
+    exact
+      (nativeMorseIndex_congr_germ (hkeep w hw)).trans (hindices w (hcrit ▸ ((hcritg w).mp hw).1))
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.cancel_one_two_pair_at_preserved_middle_cut {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [PathConnectedSpace M] {f g : M → ℝ} (S : AdaptedWindows E f) (T : AdaptedWindows E g)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g)
+    (hmg : Smale.ManifoldMorse.IsMorse E g) (e : M ≃ₕ Smale.SixSphere)
+    (hdim : Module.finrank ℝ E = 6) {a : ℝ}
+    (hfr : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hgr : ∀ y, g y = a → y ∉ Smale.ManifoldMorse.criticalPoints E g)
+    (heq : ∀ y, g y = a ↔ f y = a)
+    (hhigh : ∀ z : Smale.ManifoldMorse.criticalPoints E f, a ≤ f z → 3 ≤ nativeMorseIndex E f z)
+    (hlow : ∀ z : Smale.ManifoldMorse.criticalPoints E f, f z ≤ a → nativeMorseIndex E f z ≤ 3)
+    (m q r : Smale.ManifoldMorse.criticalPoints E g) (hm : nativeMorseIndex E g m = 0)
+    (hq : nativeMorseIndex E g q = 1) (hr : nativeMorseIndex E g r = 2)
+    (u : Metric.sphere (0 : (T.data q).chart.NegativeCoordinates) 1)
+    (hbranches :
+      ∀ w : Metric.sphere (0 : (T.data q).chart.NegativeCoordinates) 1,
+        Filter.Tendsto (fun t => T.flow t ((T.data q).surgery.attachingSphere w).val) Filter.atTop
+          (𝓝 m.val))
+    (hqa : T.toSurgeryWindows.upper q ≤ a) (har : a < g r)
+    (hgap : ∀ z : Smale.ManifoldMorse.criticalPoints E g, g z < g r → g z < a)
+    (hnewlow :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E g, g z ≤ a → nativeMorseIndex E g z ≤ 2) :
+    ∃ h : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ h ∧
+        Smale.ManifoldMorse.IsMorse E h ∧
+          Set.InjOn h (Smale.ManifoldMorse.criticalPoints E h) ∧
+            (Smale.ManifoldMorse.criticalPoints E h).ncard + 2 =
+                (Smale.ManifoldMorse.criticalPoints E g).ncard ∧
+              (∀ w,
+                  w ∈ Smale.ManifoldMorse.criticalPoints E h ↔
+                    w ∈ Smale.ManifoldMorse.criticalPoints E g ∧ w ≠ q.val ∧ w ≠ r.val) ∧
+                ∀ w ∈ Smale.ManifoldMorse.criticalPoints E h,
+                  nativeMorseIndex E h w = nativeMorseIndex E g w := by
+  let _ := Smale.RegularLevel.chartedSpace hg hgr
+  let _ := Smale.RegularLevel.isManifold hg hgr
+  have hnegq : Module.finrank ℝ (T.data q).chart.NegativeCoordinates = 1 :=
+    (nativeMorseIndex_eq_chart (T.data q).chart).symm.trans hq
+  have hsplit := (T.data q).chart.finrank_negative_add_positive
+  let _ : Fact (Module.finrank ℝ (T.data q).chart.PositiveCoordinates = 4 + 1) := ⟨by omega⟩
+  obtain ⟨P, hP, hcount, α, z₀, β, v, hα, hβ, hcross, htrans, hαbasin, hβbasin, hends⟩ :=
+    exists_handle_trade_transverse_level_data S T hf hg e hdim hfr hgr heq hhigh hlow m q r hm hq
+      hr u hbranches hqa har hgap hnewlow
+  have hqcut : g q < a := (T.toSurgeryWindows.value_lt_upper q).trans_le hqa
+  obtain
+    ⟨V, G, hV, hG, hzero, hdesc, hgerms, hbackr, hforwardq, hunique, hback, hforward, htubes⟩ :=
+    T.realize_unit_transverse_level_isotopy hg r q har hqcut hgr P hP hcount α β z₀ v
+      (hα.mdifferentiableAt (by simp)) hβ hcross htrans (Filter.Eventually.of_forall hαbasin)
+      hβbasin
+  have hendsG (x : { y : M // g y = a })
+    (hx : Filter.Tendsto (fun t => G t x.val) Filter.atBot (𝓝 r.val)) :
+    Filter.Tendsto (fun t => G t x.val) Filter.atTop (𝓝 q.val) ∨
+      Filter.Tendsto (fun t => G t x.val) Filter.atTop (𝓝 m.val) := by
+    have hh := hends x ((hback x r.val).mp hx)
+    exact (hh.imp ((hforward x m.val).mpr) ((hforward x q.val).mpr)).symm
+  have hnoconnection :=
+    no_other_connections_of_two_level_endpoints G hg.continuous T.distinct r q m har hgap
+      (Smale.FlowConstruction.antitone_flow_height hg G hG hzero hdesc) hendsG
+  have hmodels :
+    ∀ x ∈ Smale.ManifoldMorse.criticalPoints E g,
+      ∃ c : Smale.ManifoldMorse.SignedMorseChart (E := E) g x,
+        ∀ᶠ y in 𝓝 x, V y = c.descentField y := by
+    intro x hx
+    refine ⟨(T.data ⟨x, hx⟩).chart, ?_⟩
+    filter_upwards [hgerms x hx, T.critical_model_germ ⟨x, hx⟩] with y hy hyt
+    exact hy.trans hyt
+  have hmq : g m < g q :=
+    (T.forward_limit_below_regular_level hg (T.data q).lower_regular
+          ((T.data q).surgery.attachingSphere u) (hbranches u)).trans
+      (T.toSurgeryWindows.lower_lt_value q)
+  obtain ⟨hC, hD, hC0, hD0, hCb, hDb, htransM⟩ := htubes
+  exact
+    cancel_transverse_pair_after_flow_preserving_descent hg hmg T.distinct (m := 5) (by omega) hV
+      G hG hzero hdesc hmodels q m r hmq (hqcut.trans har) (by omega) hnoconnection hforwardq
+      hbackr hunique hC hD hC0 hD0 hCb hDb htransM
+
+private theorem MorseCancel.exists_distinct_unitSphere_points_of_finrank_one {V : Type}
+    [NormedAddCommGroup V] [NormedSpace ℝ V] [FiniteDimensional ℝ V]
+    (hdim : Module.finrank ℝ V = 1) : ∃ u v : Metric.sphere (0 : V) 1, u ≠ v := by
+  obtain ⟨L⟩ :=
+    FiniteDimensional.nonempty_continuousLinearEquiv_of_finrank_eq
+      (show Module.finrank ℝ V = Module.finrank ℝ ℝ by simpa using hdim)
+  let e := Degree.UnitSphereEquiv.homeomorph L
+  let u : Metric.sphere (0 : ℝ) 1 := ⟨1, by simp⟩
+  let v : Metric.sphere (0 : ℝ) 1 := ⟨-1, by simp⟩
+  refine ⟨e.symm u, e.symm v, ?_⟩
+  intro heq
+  have hh : u = v := e.symm.injective heq
+  have hval : (1 : ℝ) = -1 := congrArg Subtype.val hh
+  norm_num at hval
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem AdaptedWindows.place_one_handle_in_unique_minimum_basin {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (p q : Smale.ManifoldMorse.criticalPoints E f) (hone : MorseCancel.nativeMorseIndex E f q = 1)
+    (hunique :
+      ∀ r : Smale.ManifoldMorse.criticalPoints E f,
+        MorseCancel.nativeMorseIndex E f r = 0 → r = p) :
+    let _ := Smale.RegularLevel.chartedSpace hf (S.data q).lower_regular
+    ∃ d :
+      Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+        (S.data q).LowerLevel (S.data q).LowerLevel ∞,
+      Smale.SupportedDiffeomorph.IsotopicToIdentity d ∧
+        f p < S.toSurgeryWindows.lower q ∧
+          ∀ w : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1,
+            Filter.Tendsto (fun t => S.flow t (d ((S.data q).surgery.attachingSphere w)).val)
+              Filter.atTop (𝓝 p.val) := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data q).lower_regular
+  let _ := Smale.RegularLevel.isManifold hf (S.data q).lower_regular
+  have hi : Module.finrank ℝ (S.data q).chart.NegativeCoordinates = 1 :=
+    (MorseCancel.nativeMorseIndex_eq_chart (S.data q).chart).symm.trans hone
+  obtain ⟨u, v, huv⟩ := MorseCancel.exists_distinct_unitSphere_points_of_finrank_one hi
+  let α := (S.data q).surgery.attachingSphere
+  have hxy : α u ≠ α v := fun h => huv ((S.data q).attaching_isClosedEmbedding.injective h)
+  obtain ⟨d, hd, ⟨r, hr, hru⟩, ⟨s, hs, hsv⟩⟩ :=
+    MorseCancel.exists_isotopic_two_points_in_dense (J := 𝓘(ℝ, Smale.RegularLevel.Model E))
+      (S.dense_regular_level_minimum_basins hf (S.data q).lower_regular) hxy
+  have hpu : Filter.Tendsto (fun t => S.flow t (d (α u)).val) Filter.atTop (𝓝 p.val) :=
+    hunique r hr ▸ hru
+  have hpv : Filter.Tendsto (fun t => S.flow t (d (α v)).val) Filter.atTop (𝓝 p.val) :=
+    hunique s hs ▸ hsv
+  refine
+    ⟨d, hd, S.forward_limit_below_regular_level hf (S.data q).lower_regular (d (α u)) hpu, ?_⟩
+  intro w
+  rcases MorseCancel.unitSphere_eq_two_points_of_finrank_one hi u v huv w with rfl | rfl
+  · exact hpu
+  · exact hpv
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem AdaptedWindows.realize_unique_minimum_one_handle_branches {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (p q : Smale.ManifoldMorse.criticalPoints E f)
+    (hone : MorseCancel.nativeMorseIndex E f q = 1)
+    (hunique :
+      ∀ r : Smale.ManifoldMorse.criticalPoints E f,
+        MorseCancel.nativeMorseIndex E f r = 0 → r = p) :
+    ∃ T : AdaptedWindows E f,
+      (∀ r : Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ x in 𝓝 r.val, T.field x = S.field x) ∧
+        (∀ r, (T.data r).chart = (S.data r).chart) ∧
+          (∀ w : Metric.sphere (0 : (T.data q).chart.NegativeCoordinates) 1,
+              Filter.Tendsto (fun t => T.flow t ((T.data q).surgery.attachingSphere w).val)
+                Filter.atTop (𝓝 p.val)) ∧
+            ∀ r : Smale.ManifoldMorse.criticalPoints E f,
+              r ≠ q →
+                r ≠ p →
+                  ∀ x,
+                    ¬(Filter.Tendsto (fun t => T.flow t x) Filter.atBot (𝓝 q.val) ∧
+                        Filter.Tendsto (fun t => T.flow t x) Filter.atTop (𝓝 r.val)) := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data q).lower_regular
+  obtain ⟨d, hd, hpq, hall⟩ := S.place_one_handle_in_unique_minimum_basin hf p q hone hunique
+  have hi : Module.finrank ℝ (S.data q).chart.NegativeCoordinates = 1 :=
+    (MorseCancel.nativeMorseIndex_eq_chart (S.data q).chart).symm.trans hone
+  obtain ⟨u, v, huv⟩ := MorseCancel.exists_distinct_unitSphere_points_of_finrank_one hi
+  obtain ⟨l, b, hl, hb, hband⟩ := S.regular_interval_around_level (S.data q).lower_regular
+  obtain
+    ⟨ρ, C, W, V, H, G, -, -, -, -, -, -, hgeometry, hV, hG, hzero, hdesc, hgerms, -, hend, -,
+      hleft, hright⟩ :=
+    Degree.FlowSuspension.exists_native_regular_level_isotopy_realization hf S.smooth S.descent
+      S.flow S.integral hl hb hband (S.data q).lower_regular
+      ((S.data q).surgery.attachingSphere u) d hd
+  have hVz : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0 := fun x hx =>
+    (hzero x).mpr (S.zero x hx)
+  obtain ⟨hback, hforward⟩ :=
+    Degree.FlowSuspension.whole_level_basins_of_holonomy S.flow H G Subtype.val d
+      (fun x z => (hgeometry x).2.1 z) (fun x z => (hgeometry x).2.2 z) hend hleft hright
+  have hbq (x : (S.data q).LowerLevel) :
+    Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 q.val) ↔
+      x ∈ Set.range (S.data q).surgery.attachingSphere :=
+    (hback x q.val).trans (S.attaching_basin_iff hf q x)
+  have hends (w : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1) :
+    Filter.Tendsto (fun t => G t ((S.data q).surgery.attachingSphere w).val) Filter.atTop
+      (𝓝 p.val) :=
+    (hforward _ p.val).mpr (hall w)
+  have hno (r : Smale.ManifoldMorse.criticalPoints E f) (hrq : r ≠ q) (hrp : r ≠ p) (x : M) :
+    ¬(Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 q.val) ∧
+        Filter.Tendsto (fun t => G t x) Filter.atTop (𝓝 r.val)) := by
+    intro hx
+    have hmono := Smale.FlowConstruction.antitone_flow_height hf G hG hVz hdesc x
+    have hle : f r ≤ f q :=
+      (hmono.le_of_tendsto (hf.continuous.continuousAt.tendsto.comp hx.2) 0).trans
+        (hmono.ge_of_tendsto (hf.continuous.continuousAt.tendsto.comp hx.1) 0)
+    have hrq' : f r < f q :=
+      lt_of_le_of_ne hle (fun h => hrq (Subtype.ext (S.distinct r.property q.property h)))
+    have hrlow : f r < S.toSurgeryWindows.lower q :=
+      (S.toSurgeryWindows.value_lt_upper r).trans (S.separated r q hrq')
+    obtain ⟨t, ht⟩ :=
+      Degree.FlowCancellation.exists_level_crossing_of_endpoint_limits G hf.continuous hx.1 hx.2
+        (S.toSurgeryWindows.lower_lt_value q) hrlow
+    let z : (S.data q).LowerLevel := ⟨G t x, ht⟩
+    have hzq : Filter.Tendsto (fun s => G s z) Filter.atBot (𝓝 q.val) :=
+      (MorseCancel.flow_time_atBot_limit_iff G t x q.val).mpr hx.1
+    have hzr : Filter.Tendsto (fun s => G s z) Filter.atTop (𝓝 r.val) :=
+      (MorseCancel.flow_time_atTop_limit_iff G t x r.val).mpr hx.2
+    obtain ⟨w, hw⟩ := (hbq z).mp hzq
+    have hpz := hends w
+    rw [hw] at hpz
+    exact hrp (Subtype.ext (tendsto_nhds_unique hzr hpz))
+  have hmodel (r : Smale.ManifoldMorse.criticalPoints E f) :
+    ∀ᶠ x in 𝓝 r.val, V x = (S.data r).chart.descentField x := by
+    filter_upwards [hgerms r r.property, S.critical_model_germ r] with x hx hxs
+    exact hx.trans hxs
+  obtain ⟨T, hfield, hflow, hchart⟩ :=
+    MorseCancel.exists_adapted_windows_with_prescribed_flow hf hm S.distinct hV G hG hVz hdesc
+      (fun r => (S.data r).chart) hmodel
+  refine ⟨T, ?_, hchart, ?_, ?_⟩
+  · intro r
+    rw [hfield]
+    exact hgerms r r.property
+  · intro w
+    let z := (T.data q).surgery.attachingSphere w
+    have hzq : Filter.Tendsto (fun t => T.flow t z.val) Filter.atBot (𝓝 q.val) :=
+      (T.attaching_basin_iff hf q z).mpr ⟨w, rfl⟩
+    obtain ⟨r₀, hr₀, r, hr, -, hrlim, hheight⟩ :=
+      Degree.FlowCancellation.exists_native_descent_endpoints hf T.smooth T.flow T.integral T.zero
+        T.descent T.distinct z.val
+    have hrq : (⟨r, hr⟩ : Smale.ManifoldMorse.criticalPoints E f) ≠ q := by
+      intro heq
+      have hlt := (hheight ((T.data q).lower_regular z.val z.property)).1
+      have hrval : r = q.val := congrArg Subtype.val heq
+      rw [hrval, z.property] at hlt
+      nlinarith [sq_nonneg (T.data q).radius]
+    have hrp : (⟨r, hr⟩ : Smale.ManifoldMorse.criticalPoints E f) = p := by
+      by_contra hne
+      apply hno ⟨r, hr⟩ hrq hne z.val
+      rw [hflow] at hzq hrlim
+      exact ⟨hzq, hrlim⟩
+    exact (congrArg Subtype.val hrp) ▸ hrlim
+  · intro r hrq hrp x
+    rw [hflow]
+    exact hno r hrq hrp x
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.cancel_one_two_pair_at_unchanged_cut_of_unique_minimum {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [PathConnectedSpace M] {f g : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g)
+    (hmg : Smale.ManifoldMorse.IsMorse E g)
+    (hinjg : Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g)) (e : M ≃ₕ Smale.SixSphere)
+    (hdim : Module.finrank ℝ E = 6) {a : ℝ}
+    (hfr : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hgr : ∀ y, g y = a → y ∉ Smale.ManifoldMorse.criticalPoints E g)
+    (heq : ∀ y, g y = a ↔ f y = a)
+    (hhigh : ∀ z : Smale.ManifoldMorse.criticalPoints E f, a ≤ f z → 3 ≤ nativeMorseIndex E f z)
+    (hlow : ∀ z : Smale.ManifoldMorse.criticalPoints E f, f z ≤ a → nativeMorseIndex E f z ≤ 3)
+    (m q r : Smale.ManifoldMorse.criticalPoints E g) (hm : nativeMorseIndex E g m = 0)
+    (hq : nativeMorseIndex E g q = 1) (hr : nativeMorseIndex E g r = 2)
+    (hminimum : ∀ z : Smale.ManifoldMorse.criticalPoints E g, nativeMorseIndex E g z = 0 → z = m)
+    (hqa : g q < a) (har : a < g r)
+    (hgap : ∀ z : Smale.ManifoldMorse.criticalPoints E g, g z < g r → g z < a)
+    (hnewlow :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E g, g z ≤ a → nativeMorseIndex E g z ≤ 2) :
+    ∃ h : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ h ∧
+        Smale.ManifoldMorse.IsMorse E h ∧
+          Set.InjOn h (Smale.ManifoldMorse.criticalPoints E h) ∧
+            (Smale.ManifoldMorse.criticalPoints E h).ncard + 2 =
+                (Smale.ManifoldMorse.criticalPoints E g).ncard ∧
+              (∀ w,
+                  w ∈ Smale.ManifoldMorse.criticalPoints E h ↔
+                    w ∈ Smale.ManifoldMorse.criticalPoints E g ∧ w ≠ q.val ∧ w ≠ r.val) ∧
+                ∀ w ∈ Smale.ManifoldMorse.criticalPoints E h,
+                  nativeMorseIndex E h w = nativeMorseIndex E g w := by
+  obtain ⟨T₀⟩ := nonempty_adaptedSurgeryWindows hg hmg hinjg
+  obtain ⟨U, -, -, hbranchesU, -⟩ :=
+    T₀.realize_unique_minimum_one_handle_branches hg hmg m q hq hminimum
+  obtain ⟨T, -, hflow, -, hbelow, -⟩ := U.exists_same_flow_windows_avoiding_level hg hmg hgr
+  have hbranches := U.attaching_branches_of_same_flow T hg m q hflow hbranchesU
+  have hneg : Module.finrank ℝ (T.data q).chart.NegativeCoordinates = 1 :=
+    (nativeMorseIndex_eq_chart (T.data q).chart).symm.trans hq
+  obtain ⟨u, v, huv⟩ := exists_distinct_unitSphere_points_of_finrank_one hneg
+  exact
+    cancel_one_two_pair_at_preserved_middle_cut S T hf hg hmg e hdim hfr hgr heq hhigh hlow m q r
+      hm hq hr u hbranches (hbelow q hqa).le har hgap hnewlow
+
+private theorem MorseCancel.birth_preserves_lower_index_bound {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ} {p q : M} {a : ℝ}
+    {k : ℕ}
+    (hcrit :
+      ∀ z ∈ Smale.ManifoldMorse.criticalPoints E g,
+        z ∈ Smale.ManifoldMorse.criticalPoints E f ∨ z = p ∨ z = q)
+    (hkeep : ∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, g =ᶠ[𝓝 z] f) (hp : a < g p)
+    (hq : a < g q)
+    (hlow : ∀ z : Smale.ManifoldMorse.criticalPoints E f, f z ≤ a → nativeMorseIndex E f z ≤ k) :
+    ∀ z : Smale.ManifoldMorse.criticalPoints E g, g z ≤ a → nativeMorseIndex E g z ≤ k := by
+  intro z hz
+  rcases hcrit z.val z.property with hold | hzp | hzq
+  · rw [nativeMorseIndex_congr_germ (hkeep z.val hold)]
+    apply hlow ⟨z.val, hold⟩
+    rwa [← (hkeep z.val hold).self_of_nhds]
+  · exact False.elim (hp.not_ge (hzp ▸ hz))
+  · exact False.elim (hq.not_ge (hzq ▸ hz))
+
+private theorem MorseCancel.birth_first_new_value_gap {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ} {p q : M} {a b : ℝ}
+    (hcrit :
+      ∀ z ∈ Smale.ManifoldMorse.criticalPoints E g,
+        z ∈ Smale.ManifoldMorse.criticalPoints E f ∨ z = p ∨ z = q)
+    (hkeep : ∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, g =ᶠ[𝓝 z] f)
+    (hreg : ∀ z, f z = a → z ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hband : ∀ z, f z ∈ Set.Ioo a b → z ∉ Smale.ManifoldMorse.criticalPoints E f) (hp : g p < b)
+    (hpq : g p < g q) : ∀ z : Smale.ManifoldMorse.criticalPoints E g, g z < g p → g z < a := by
+  intro z hz
+  rcases hcrit z.val z.property with hold | hzp | hzq
+  · have hzb : g z < b := hz.trans hp
+    have heq := (hkeep z.val hold).self_of_nhds
+    by_contra hnot
+    have haz : a ≤ f z := by rw [← heq]; exact le_of_not_gt hnot
+    have hne : a ≠ f z := fun h => hreg z.val h.symm hold
+    exact hband z.val ⟨lt_of_le_of_ne haz hne, by rwa [← heq]⟩ hold
+  · exact False.elim ((hzp ▸ hz : g p < g p).false)
+  · exact False.elim (hpq.not_gt (hzq ▸ hz))
+
+private theorem MorseCancel.birth_preserves_unique_index_zero {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ} {p q : M}
+    (m : Smale.ManifoldMorse.criticalPoints E f)
+    (hcrit :
+      ∀ z ∈ Smale.ManifoldMorse.criticalPoints E g,
+        z ∈ Smale.ManifoldMorse.criticalPoints E f ∨ z = p ∨ z = q)
+    (hkeep : ∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, g =ᶠ[𝓝 z] f)
+    (hp : nativeMorseIndex E g p ≠ 0) (hq : nativeMorseIndex E g q ≠ 0)
+    (hunique : ∀ z : Smale.ManifoldMorse.criticalPoints E f, nativeMorseIndex E f z = 0 → z = m) :
+    ∀ z ∈ Smale.ManifoldMorse.criticalPoints E g, nativeMorseIndex E g z = 0 → z = m.val := by
+  intro z hz hi
+  rcases hcrit z hz with hold | rfl | rfl
+  · have hiold : nativeMorseIndex E f z = 0 :=
+      (nativeMorseIndex_congr_germ (hkeep z hold)).symm.trans hi
+    exact congrArg Subtype.val (hunique ⟨z, hold⟩ hiold)
+  · exact False.elim (hp hi)
+  · exact False.elim (hq hi)
+
+private theorem MorseCancel.indexed_criticalPoints_removed_of_index_eq {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ}
+    {p q : M}
+    (hcrit :
+      ∀ z,
+        z ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+          z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ z ≠ p ∧ z ≠ q)
+    (hindex :
+      ∀ z ∈ Smale.ManifoldMorse.criticalPoints E g,
+        nativeMorseIndex E g z = nativeMorseIndex E f z)
+    (k : ℕ) :
+    {z : M | z ∈ Smale.ManifoldMorse.criticalPoints E g ∧ nativeMorseIndex E g z = k} =
+      {z : M | z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ nativeMorseIndex E f z = k} \
+        { p, q } := by
+  ext z
+  simp only [Set.mem_ofPred_eq, Set.mem_sdiff, Set.mem_insert_iff, Set.mem_singleton_iff, not_or]
+  constructor
+  · rintro ⟨hz, hi⟩
+    obtain ⟨hzf, hzp, hzq⟩ := (hcrit z).mp hz
+    exact ⟨⟨hzf, (hindex z hz).symm.trans hi⟩, hzp, hzq⟩
+  · rintro ⟨⟨hzf, hi⟩, hzp, hzq⟩
+    have hz := (hcrit z).mpr ⟨hzf, hzp, hzq⟩
+    exact ⟨hz, (hindex z hz).trans hi⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.nativeMorseCount_removed_of_index_eq {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ} {p q : M}
+    (hfinite : (Smale.ManifoldMorse.criticalPoints E f).Finite)
+    (hp : p ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hq : q ∈ Smale.ManifoldMorse.criticalPoints E f) (hpq : p ≠ q)
+    (hcrit :
+      ∀ z,
+        z ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+          z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ z ≠ p ∧ z ≠ q)
+    (hindex :
+      ∀ z ∈ Smale.ManifoldMorse.criticalPoints E g,
+        nativeMorseIndex E g z = nativeMorseIndex E f z)
+    (k : ℕ) :
+    nativeMorseCount E g k + (if nativeMorseIndex E f p = k then 1 else 0) +
+        (if nativeMorseIndex E f q = k then 1 else 0) =
+      nativeMorseCount E f k := by
+  let K := {z : M | z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ nativeMorseIndex E f z = k}
+  have hK : K.Finite := hfinite.subset (fun _ hz => hz.1)
+  have hdiff : K \ (K ∩ { p, q }) = K \ { p, q } := by
+    ext z
+    simp only [Set.mem_sdiff, Set.mem_inter_iff]
+    tauto
+  have hrem :
+    (K ∩ { p, q }).ncard =
+      (if nativeMorseIndex E f p = k then 1 else 0) +
+        (if nativeMorseIndex E f q = k then 1 else 0) := by
+    by_cases hip : nativeMorseIndex E f p = k
+    · have hpK : p ∈ K := ⟨hp, hip⟩
+      rw [Set.inter_insert_of_mem hpK, ite_eq_left hip]
+      by_cases hiq : nativeMorseIndex E f q = k
+      · rw [Set.inter_singleton_of_mem (show q ∈ K from ⟨hq, hiq⟩), ite_eq_left hiq,
+          Set.ncard_pair hpq]
+      · rw [Set.inter_singleton_of_notMem (show q ∉ K from fun h => hiq h.2), ite_eq_right hiq]
+        simp
+    · have hpK : p ∉ K := fun h => hip h.2
+      rw [Set.inter_insert_of_notMem hpK, ite_eq_right hip]
+      by_cases hiq : nativeMorseIndex E f q = k
+      · rw [Set.inter_singleton_of_mem (show q ∈ K from ⟨hq, hiq⟩), ite_eq_left hiq]
+        simp
+      · rw [Set.inter_singleton_of_notMem (show q ∉ K from fun h => hiq h.2), ite_eq_right hiq]
+        simp
+  have hc := Set.ncard_sdiff_add_ncard_of_subset (Set.inter_subset_left : K ∩ { p, q } ⊆ K) hK
+  rw [hdiff, hrem] at hc
+  unfold nativeMorseCount
+  rw [indexed_criticalPoints_removed_of_index_eq hcrit hindex k]
+  exact (Nat.add_assoc _ _ _).trans hc
+
+private theorem MorseCancel.nativeMorseCount_adjacent_removed_of_index_eq {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ}
+    {p q : M} (hfinite : (Smale.ManifoldMorse.criticalPoints E f).Finite)
+    (hp : p ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hq : q ∈ Smale.ManifoldMorse.criticalPoints E f) (hpq : p ≠ q)
+    (hcrit :
+      ∀ z,
+        z ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+          z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ z ≠ p ∧ z ≠ q)
+    (hindex :
+      ∀ z ∈ Smale.ManifoldMorse.criticalPoints E g,
+        nativeMorseIndex E g z = nativeMorseIndex E f z)
+    {k : ℕ} (hip : nativeMorseIndex E f p = k) (hiq : nativeMorseIndex E f q = k + 1) :
+    nativeMorseCount E g k + 1 = nativeMorseCount E f k ∧
+      nativeMorseCount E g (k + 1) + 1 = nativeMorseCount E f (k + 1) ∧
+        ∀ j, j ≠ k → j ≠ k + 1 → nativeMorseCount E g j = nativeMorseCount E f j := by
+  have hc := nativeMorseCount_removed_of_index_eq hfinite hp hq hpq hcrit hindex
+  refine ⟨?_, ?_, ?_⟩
+  · simpa [hip, hiq] using hc k
+  · simpa [hip, hiq, show k ≠ k + 1 by omega] using hc (k + 1)
+  · intro j hj hj'
+    simpa only [hip, hiq, ite_eq_right (Ne.symm hj), ite_eq_right (Ne.symm hj'),
+      Nat.add_zero] using hc j
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_one_to_three_handle_trade {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PathConnectedSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (e : M ≃ₕ Smale.SixSphere)
+    (hdim : Module.finrank ℝ E = 6) (m q : Smale.ManifoldMorse.criticalPoints E f)
+    (hm0 : nativeMorseIndex E f m = 0) (hq1 : nativeMorseIndex E f q = 1)
+    (hminimum : ∀ z : Smale.ManifoldMorse.criticalPoints E f, nativeMorseIndex E f z = 0 → z = m)
+    {a l u : ℝ} (hreg : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hhigh : ∀ z : Smale.ManifoldMorse.criticalPoints E f, a ≤ f z → 3 ≤ nativeMorseIndex E f z)
+    (hlow : ∀ z : Smale.ManifoldMorse.criticalPoints E f, f z ≤ a → nativeMorseIndex E f z ≤ 2)
+    (hqa : f q < a) (hal : a < l)
+    (hband : ∀ y, f y ∈ Set.Ioo a u → y ∉ Smale.ManifoldMorse.criticalPoints E f) {x : M}
+    (hx : f x ∈ Set.Ioo l u) :
+    ∃ h : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ h ∧
+        Smale.ManifoldMorse.IsMorse E h ∧
+          Set.InjOn h (Smale.ManifoldMorse.criticalPoints E h) ∧
+            (Smale.ManifoldMorse.criticalPoints E h).ncard =
+                (Smale.ManifoldMorse.criticalPoints E f).ncard ∧
+              nativeMorseCount E h 1 + 1 = nativeMorseCount E f 1 ∧
+                nativeMorseCount E h 3 = nativeMorseCount E f 3 + 1 ∧
+                  ∀ j, j ≠ 1 → j ≠ 3 → nativeMorseCount E h j = nativeMorseCount E f j := by
+  let U : Set M := f ⁻¹' Set.Ioo l u
+  have hU : IsOpen U := isOpen_Ioo.preimage hf.continuous
+  have hbirthband : ∀ y, f y ∈ Set.Ioo l u → y ∉ Smale.ManifoldMorse.criticalPoints E f :=
+    fun y hy => hband y ⟨hal.trans hy.1, hy.2⟩
+  obtain
+    ⟨g, b₂, b₃, hg, hmg, hinjg, -, -, hi₂, hi₃, h₂₃, hv₂, hv₃, hcountbirth, hcrit, hexterior,
+      hkeep, hcount₂, hcount₃, hcountOther⟩ :=
+    exists_excellent_indexed_morse_birth hf hm S.distinct hbirthband hx (k := 2) (by omega) hU hx
+  have hcrit' (z : M) (hz : z ∈ Smale.ManifoldMorse.criticalPoints E g) :
+    z ∈ Smale.ManifoldMorse.criticalPoints E f ∨ z = b₂ ∨ z = b₃ := (hcrit z).mp hz
+  have hab₂ : a < g b₂ := hal.trans hv₂.1
+  have hab₃ : a < g b₃ := hal.trans hv₃.1
+  obtain ⟨heq, -⟩ :=
+    birth_preserves_lower_levels hf.continuous hg
+      (show U ⊆ {y : M | l < f y} from fun _ hy => hy.1) hexterior hkeep hcrit' hv₂.1.le hv₃.1.le
+      hal
+  have hgr := regular_level_of_retained_critical_germs hreg hcrit' hkeep hab₂ hab₃
+  have hgap := birth_first_new_value_gap hcrit' hkeep hreg hband hv₂.2 h₂₃
+  have hnewlow := birth_preserves_lower_index_bound hcrit' hkeep hab₂ hab₃ hlow
+  let mg : Smale.ManifoldMorse.criticalPoints E g :=
+    ⟨m.val, (hcrit m.val).mpr (Or.inl m.property)⟩
+  let qg : Smale.ManifoldMorse.criticalPoints E g :=
+    ⟨q.val, (hcrit q.val).mpr (Or.inl q.property)⟩
+  let rg : Smale.ManifoldMorse.criticalPoints E g := ⟨b₂, (hcrit b₂).mpr (Or.inr (Or.inl rfl))⟩
+  have hmg0 : nativeMorseIndex E g mg = 0 :=
+    (nativeMorseIndex_congr_germ (hkeep m.val m.property)).trans hm0
+  have hqg1 : nativeMorseIndex E g qg = 1 :=
+    (nativeMorseIndex_congr_germ (hkeep q.val q.property)).trans hq1
+  have hminG :
+    ∀ z : Smale.ManifoldMorse.criticalPoints E g, nativeMorseIndex E g z = 0 → z = mg := by
+    intro z hz
+    apply Subtype.ext
+    exact
+      birth_preserves_unique_index_zero m hcrit' hkeep (by rw [hi₂]; omega) (by rw [hi₃]; omega)
+        hminimum z.val z.property hz
+  have hqga : g qg < a := by
+    change g q.val < a
+    rw [(hkeep q.val q.property).self_of_nhds]
+    exact hqa
+  obtain ⟨h, hh, hmh, hinjh, hcountcancel, hcritcancel, hindices⟩ :=
+    cancel_one_two_pair_at_unchanged_cut_of_unique_minimum S hf hg hmg hinjg e hdim hreg hgr heq
+      hhigh (fun z hz => (hlow z hz).trans (by omega)) mg qg rg hmg0 hqg1 hi₂ hminG hqga hab₂ hgap
+      hnewlow
+  have hq₂ : qg.val ≠ rg.val := fun he => (hqga.trans hab₂).ne (congrArg g he)
+  obtain ⟨hremove₁, hremove₂, hremoveOther⟩ :=
+    nativeMorseCount_adjacent_removed_of_index_eq
+      (Smale.ManifoldMorse.finite_criticalPoints hg hmg) qg.property rg.property hq₂ hcritcancel
+      hindices hqg1 hi₂
+  have htotal :
+    (Smale.ManifoldMorse.criticalPoints E h).ncard =
+      (Smale.ManifoldMorse.criticalPoints E f).ncard :=
+    Nat.add_right_cancel (hcountcancel.trans hcountbirth)
+  have hcount₁ : nativeMorseCount E g 1 = nativeMorseCount E f 1 :=
+    hcountOther 1 (by omega) (by omega)
+  have hcountₕ₂ : nativeMorseCount E h 2 = nativeMorseCount E f 2 :=
+    Nat.add_right_cancel (hremove₂.trans hcount₂)
+  refine
+    ⟨h, hh, hmh, hinjh, htotal, hremove₁.trans hcount₁,
+      (hremoveOther 3 (by omega) (by omega)).trans hcount₃, ?_⟩
+  intro j hj1 hj3
+  by_cases hj2 : j = 2
+  · subst j
+    exact hcountₕ₂
+  · exact (hremoveOther j hj1 hj2).trans (hcountOther j hj2 hj3)
+
+private theorem
+    MorseCancel.exists_one_to_three_handle_trade_at_cut {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PathConnectedSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (e : M ≃ₕ Smale.SixSphere)
+    (hdim : Module.finrank ℝ E = 6) (m q : Smale.ManifoldMorse.criticalPoints E f)
+    (hm0 : nativeMorseIndex E f m = 0) (hq1 : nativeMorseIndex E f q = 1)
+    (hminimum : ∀ z : Smale.ManifoldMorse.criticalPoints E f, nativeMorseIndex E f z = 0 → z = m)
+    {a : ℝ} (hreg : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hhigh : ∀ z : Smale.ManifoldMorse.criticalPoints E f, a ≤ f z → 3 ≤ nativeMorseIndex E f z)
+    (hlow : ∀ z : Smale.ManifoldMorse.criticalPoints E f, f z ≤ a → nativeMorseIndex E f z ≤ 2)
+    (hqa : f q < a) :
+    ∃ h : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ h ∧
+        Smale.ManifoldMorse.IsMorse E h ∧
+          Set.InjOn h (Smale.ManifoldMorse.criticalPoints E h) ∧
+            (Smale.ManifoldMorse.criticalPoints E h).ncard =
+                (Smale.ManifoldMorse.criticalPoints E f).ncard ∧
+              nativeMorseCount E h 1 + 1 = nativeMorseCount E f 1 ∧
+                nativeMorseCount E h 3 = nativeMorseCount E f 3 + 1 ∧
+                  ∀ j, j ≠ 1 → j ≠ 3 → nativeMorseCount E h j = nativeMorseCount E f j := by
+  have hneg : Module.finrank ℝ (S.data q).chart.NegativeCoordinates = 1 :=
+    (nativeMorseIndex_eq_chart (S.data q).chart).symm.trans hq1
+  have hsplit := (S.data q).chart.finrank_negative_add_positive
+  let _ : Fact (Module.finrank ℝ (S.data q).chart.PositiveCoordinates = 4 + 1) := ⟨by omega⟩
+  obtain ⟨v, t, ht⟩ := S.exists_belt_point_reaching_level hf q 4 hqa hlow (by omega)
+  let z := S.flow t ((S.data q).surgery.beltSphere v).val
+  have hz : f z = a := ht
+  obtain ⟨l₀, u, hl₀, hau, hband⟩ := S.regular_interval_around_level hreg
+  have hc : Continuous (fun s : ℝ => f (S.flow s z)) :=
+    hf.continuous.comp (S.flow.continuous continuous_id continuous_const)
+  have h0 : (fun s : ℝ => f (S.flow s z)) 0 ∈ Set.Iio u := by
+    simpa only [Flow.map_zero_apply, hz, Set.mem_Iio] using hau
+  obtain ⟨ε, hε, hεball⟩ :=
+    Metric.mem_nhds_iff.mp (hc.continuousAt.preimage_mem_nhds (isOpen_Iio.mem_nhds h0))
+  let x := S.flow (-ε / 2) z
+  have hxu : f x < u :=
+    hεball
+      (by
+        rw [Metric.mem_ball, Real.dist_eq, sub_zero, abs_lt]
+        constructor <;> linarith)
+  have hax : a < f x := by
+    have hh :=
+      Smale.FlowConstruction.strictAnti_flow_height hf (S.smooth.of_le (by simp)) S.flow
+        S.integral S.zero S.descent (hreg z hz) (show -ε / 2 < 0 by linarith)
+    simpa only [Flow.map_zero_apply, hz] using hh
+  exact
+    exists_one_to_three_handle_trade S hf hm e hdim m q hm0 hq1 hminimum hreg hhigh hlow hqa
+      (show a < (a + f x) / 2 by linarith) (fun y hy => hband y ⟨hl₀.le.trans hy.1.le, hy.2.le⟩)
+      (show f x ∈ Set.Ioo ((a + f x) / 2) u from ⟨by linarith, hxu⟩)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem AdaptedWindows.exists_ordered_index_cut {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (horder :
+      ∀ p q : Smale.ManifoldMorse.criticalPoints E f,
+        f p < f q → MorseCancel.nativeMorseIndex E f p ≤ MorseCancel.nativeMorseIndex E f q)
+    {k : ℕ} (q : Smale.ManifoldMorse.criticalPoints E f)
+    (hq : MorseCancel.nativeMorseIndex E f q ≤ k) :
+    ∃ a : ℝ,
+      (∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f) ∧
+        f q < a ∧
+          (∀ z : Smale.ManifoldMorse.criticalPoints E f,
+              a ≤ f z → k + 1 ≤ MorseCancel.nativeMorseIndex E f z) ∧
+            ∀ z : Smale.ManifoldMorse.criticalPoints E f,
+              f z ≤ a → MorseCancel.nativeMorseIndex E f z ≤ k := by
+  let _ := S.finite.fintype
+  let K :=
+    Finset.univ.filter
+      (fun z : Smale.ManifoldMorse.criticalPoints E f => MorseCancel.nativeMorseIndex E f z ≤ k)
+  have hqK : q ∈ K := Finset.mem_filter.mpr ⟨Finset.mem_univ _, hq⟩
+  obtain ⟨r, hr, hmax⟩ :=
+    K.exists_max_image (fun z : Smale.ManifoldMorse.criticalPoints E f => f z) ⟨q, hqK⟩
+  have hrk : MorseCancel.nativeMorseIndex E f r ≤ k := (Finset.mem_filter.mp hr).2
+  let a := S.toSurgeryWindows.upper r
+  have hra : f r < a := S.toSurgeryWindows.value_lt_upper r
+  refine ⟨a, (S.data r).upper_regular, (hmax q hqK).trans_lt hra, ?_, ?_⟩
+  · intro z haz
+    by_contra hnot
+    have hzK : z ∈ K := Finset.mem_filter.mpr ⟨Finset.mem_univ _, by omega⟩
+    exact (not_lt_of_ge (haz.trans (hmax z hzK))) hra
+  · intro z hza
+    rcases lt_trichotomy (f z) (f r) with hzr | hzr | hrz
+    · exact (horder z r hzr).trans hrk
+    · have he : z = r := Subtype.ext (S.distinct z.property r.property hzr)
+      simpa only [he] using hrk
+    · have he : z = r :=
+        Subtype.ext
+          (S.toSurgeryWindows.isolated r z.val z.property
+            ⟨(S.toSurgeryWindows.lower_lt_value r).le.trans hrz.le, hza⟩)
+      simpa only [he] using hrk
+
+private theorem MorseCancel.exists_one_to_three_handle_trade_of_ordered_indices {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    [PathConnectedSpace M] (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (e : M ≃ₕ Smale.SixSphere)
+    (hdim : Module.finrank ℝ E = 6)
+    (horder :
+      ∀ p q : Smale.ManifoldMorse.criticalPoints E f,
+        f p < f q → nativeMorseIndex E f p ≤ nativeMorseIndex E f q)
+    (m q : Smale.ManifoldMorse.criticalPoints E f) (hm0 : nativeMorseIndex E f m = 0)
+    (hq1 : nativeMorseIndex E f q = 1)
+    (hminimum :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E f, nativeMorseIndex E f z = 0 → z = m) :
+    ∃ h : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ h ∧
+        Smale.ManifoldMorse.IsMorse E h ∧
+          Set.InjOn h (Smale.ManifoldMorse.criticalPoints E h) ∧
+            (Smale.ManifoldMorse.criticalPoints E h).ncard =
+                (Smale.ManifoldMorse.criticalPoints E f).ncard ∧
+              nativeMorseCount E h 1 + 1 = nativeMorseCount E f 1 ∧
+                nativeMorseCount E h 3 = nativeMorseCount E f 3 + 1 ∧
+                  ∀ j, j ≠ 1 → j ≠ 3 → nativeMorseCount E h j = nativeMorseCount E f j := by
+  obtain ⟨a, hreg, hqa, hhigh, hlow⟩ :=
+    S.exists_ordered_index_cut horder q (show nativeMorseIndex E f q ≤ 2 by omega)
+  exact
+    exists_one_to_three_handle_trade_at_cut S hf hm e hdim m q hm0 hq1 hminimum hreg hhigh hlow
+      hqa
+
+private theorem MorseCancel.exists_outer_index_minimal_ordered_morse_system (E : Type) (M : Type)
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [PathConnectedSpace M] :
+    ∃ f : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f ∧
+        Smale.ManifoldMorse.IsMorse E f ∧
+          ∃ _ : AdaptedWindows E f,
+            (∀ p q : Smale.ManifoldMorse.criticalPoints E f,
+                f p < f q → nativeMorseIndex E f p ≤ nativeMorseIndex E f q) ∧
+              nativeMorseCount E f 0 = 1 ∧
+                nativeMorseCount E f (Module.finrank ℝ E) = 1 ∧
+                  (∀ g : M → ℝ,
+                      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g →
+                        Smale.ManifoldMorse.IsMorse E g →
+                          Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) →
+                            (Smale.ManifoldMorse.criticalPoints E f).ncard ≤
+                              (Smale.ManifoldMorse.criticalPoints E g).ncard) ∧
+                    ∀ g : M → ℝ,
+                      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g →
+                        Smale.ManifoldMorse.IsMorse E g →
+                          Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) →
+                            (Smale.ManifoldMorse.criticalPoints E g).ncard =
+                                (Smale.ManifoldMorse.criticalPoints E f).ncard →
+                              nativeMorseCount E f 1 + nativeMorseCount E f 5 ≤
+                                nativeMorseCount E g 1 + nativeMorseCount E g 5 := by
+  classical
+  obtain ⟨f₀, hf₀, hm₀, S₀, hminimal₀⟩ := exists_minimal_excellent_morse_system E M
+  let P : ℕ → Prop := fun n =>
+    ∃ f : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f ∧
+        Smale.ManifoldMorse.IsMorse E f ∧
+          Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f) ∧
+            (Smale.ManifoldMorse.criticalPoints E f).ncard =
+                (Smale.ManifoldMorse.criticalPoints E f₀).ncard ∧
+              nativeMorseCount E f 1 + nativeMorseCount E f 5 = n
+  have hex : ∃ n, P n := ⟨_, f₀, hf₀, hm₀, S₀.distinct, rfl, rfl⟩
+  obtain ⟨g, hg, hmg, hinjg, hcardg, hcostg⟩ := Nat.find_spec hex
+  obtain ⟨T⟩ := nonempty_adaptedSurgeryWindows hg hmg hinjg
+  obtain ⟨f, hf, hm, hcrit, -, S, horder, hcounts⟩ :=
+    exists_index_ordered_morse_system_preserving_critical_points T hg hmg
+  have hcardf :
+    (Smale.ManifoldMorse.criticalPoints E f).ncard =
+      (Smale.ManifoldMorse.criticalPoints E f₀).ncard := by rw [hcrit, hcardg]
+  have hminimal :
+    ∀ h : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ h →
+        Smale.ManifoldMorse.IsMorse E h →
+          Set.InjOn h (Smale.ManifoldMorse.criticalPoints E h) →
+            (Smale.ManifoldMorse.criticalPoints E f).ncard ≤
+              (Smale.ManifoldMorse.criticalPoints E h).ncard := by
+    intro h hh hmh hinjh
+    rw [hcardf]
+    exact hminimal₀ h hh hmh hinjh
+  obtain ⟨hmin, hmax⟩ := minimal_excellent_morse_extreme_counts_one S hf hm hminimal
+  refine ⟨f, hf, hm, S, horder, hmin, hmax, hminimal, ?_⟩
+  intro h hh hmh hinjh hcardh
+  rw [hcounts 1, hcounts 5, hcostg]
+  exact Nat.find_min' hex ⟨h, hh, hmh, hinjh, hcardh.trans hcardf, rfl⟩
+
+private theorem
+    MorseCancel.outer_index_minimal_index_one_count_zero {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PathConnectedSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (e : M ≃ₕ Smale.SixSphere)
+    (hdim : Module.finrank ℝ E = 6)
+    (horder :
+      ∀ p q : Smale.ManifoldMorse.criticalPoints E f,
+        f p < f q → nativeMorseIndex E f p ≤ nativeMorseIndex E f q)
+    (hzero : nativeMorseCount E f 0 = 1)
+    (hsecondary :
+      ∀ g : M → ℝ,
+        ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g →
+          Smale.ManifoldMorse.IsMorse E g →
+            Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) →
+              (Smale.ManifoldMorse.criticalPoints E g).ncard =
+                  (Smale.ManifoldMorse.criticalPoints E f).ncard →
+                nativeMorseCount E f 1 + nativeMorseCount E f 5 ≤
+                  nativeMorseCount E g 1 + nativeMorseCount E g 5) :
+    nativeMorseCount E f 1 = 0 := by
+  by_contra hnot
+  have hfinite :
+    {z : M | z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ nativeMorseIndex E f z = 1}.Finite :=
+    S.finite.subset (fun _ hz => hz.1)
+  obtain ⟨q, hqcrit, hq1⟩ := (Set.ncard_pos hfinite).mp (Nat.pos_of_ne_zero hnot)
+  change
+    {z : M | z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ nativeMorseIndex E f z = 0}.ncard =
+      1 at hzero
+  obtain ⟨m, hmset⟩ := Set.ncard_eq_one.mp hzero
+  have hmem :
+    m ∈ {z : M | z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ nativeMorseIndex E f z = 0} := by
+    rw [hmset]
+    exact Set.mem_singleton m
+  let mc : Smale.ManifoldMorse.criticalPoints E f := ⟨m, hmem.1⟩
+  have hminimum (z : Smale.ManifoldMorse.criticalPoints E f) (hz : nativeMorseIndex E f z = 0) :
+    z = mc := by
+    apply Subtype.ext
+    have hzmem :
+      z.val ∈ {x : M | x ∈ Smale.ManifoldMorse.criticalPoints E f ∧ nativeMorseIndex E f x = 0} :=
+      ⟨z.property, hz⟩
+    rwa [hmset, Set.mem_singleton_iff] at hzmem
+  obtain ⟨g, hg, hmg, hinjg, hcount, hcount1, -, hother⟩ :=
+    exists_one_to_three_handle_trade_of_ordered_indices S hf hm e hdim horder mc ⟨q, hqcrit⟩
+      hmem.2 hq1 hminimum
+  have hcost := hsecondary g hg hmg hinjg hcount
+  have hcount5 := hother 5 (by omega) (by omega)
+  omega
+
+private theorem MorseCancel.outer_index_minimality_neg {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+        {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f)
+    (hdim : Module.finrank ℝ E = 6)
+    (hsecondary :
+      ∀ g : M → ℝ,
+        ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g →
+          Smale.ManifoldMorse.IsMorse E g →
+            Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) →
+              (Smale.ManifoldMorse.criticalPoints E g).ncard =
+                  (Smale.ManifoldMorse.criticalPoints E f).ncard →
+                nativeMorseCount E f 1 + nativeMorseCount E f 5 ≤
+                  nativeMorseCount E g 1 + nativeMorseCount E g 5) :
+    ∀ g : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g →
+        Smale.ManifoldMorse.IsMorse E g →
+          Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) →
+            (Smale.ManifoldMorse.criticalPoints E g).ncard =
+                (Smale.ManifoldMorse.criticalPoints E (fun x => -f x)).ncard →
+              nativeMorseCount E (fun x => -f x) 1 + nativeMorseCount E (fun x => -f x) 5 ≤
+                nativeMorseCount E g 1 + nativeMorseCount E g 5 := by
+  intro g hg hmg hinjg hcard
+  have hh :=
+    hsecondary (fun x => -g x) hg.neg (isMorse_neg hmg) (distinct_critical_values_neg hinjg)
+      (by simpa only [Smale.ManifoldMorse.criticalPoints_neg] using hcard)
+  have hf1 := nativeMorseCount_neg hf hm (k := 1) (by omega)
+  have hf5 := nativeMorseCount_neg hf hm (k := 5) (by omega)
+  have hg1 := nativeMorseCount_neg hg hmg (k := 1) (by omega)
+  have hg5 := nativeMorseCount_neg hg hmg (k := 5) (by omega)
+  simp only [hdim, Nat.reduceSub] at hf1 hf5 hg1 hg5
+  omega
+
+private theorem
+    MorseCancel.outer_index_minimal_outer_counts_zero {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PathConnectedSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (e : M ≃ₕ Smale.SixSphere)
+    (hdim : Module.finrank ℝ E = 6)
+    (horder :
+      ∀ p q : Smale.ManifoldMorse.criticalPoints E f,
+        f p < f q → nativeMorseIndex E f p ≤ nativeMorseIndex E f q)
+    (hzero : nativeMorseCount E f 0 = 1) (hsix : nativeMorseCount E f 6 = 1)
+    (hsecondary :
+      ∀ g : M → ℝ,
+        ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g →
+          Smale.ManifoldMorse.IsMorse E g →
+            Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) →
+              (Smale.ManifoldMorse.criticalPoints E g).ncard =
+                  (Smale.ManifoldMorse.criticalPoints E f).ncard →
+                nativeMorseCount E f 1 + nativeMorseCount E f 5 ≤
+                  nativeMorseCount E g 1 + nativeMorseCount E g 5) :
+    nativeMorseCount E f 1 = 0 ∧ nativeMorseCount E f 5 = 0 := by
+  refine ⟨outer_index_minimal_index_one_count_zero S hf hm e hdim horder hzero hsecondary, ?_⟩
+  obtain ⟨T⟩ :=
+    nonempty_adaptedSurgeryWindows hf.neg (isMorse_neg hm)
+      (distinct_critical_values_neg S.distinct)
+  have horderN :
+    ∀ p q : Smale.ManifoldMorse.criticalPoints E (fun x => -f x),
+      -f p < -f q → nativeMorseIndex E (fun x => -f x) p ≤ nativeMorseIndex E (fun x => -f x) q :=
+    by
+    intro p q hpq
+    let pf : Smale.ManifoldMorse.criticalPoints E f :=
+      ⟨p.val, by simpa only [Smale.ManifoldMorse.criticalPoints_neg] using p.property⟩
+    let qf : Smale.ManifoldMorse.criticalPoints E f :=
+      ⟨q.val, by simpa only [Smale.ManifoldMorse.criticalPoints_neg] using q.property⟩
+    have hrev := horder qf pf (neg_lt_neg_iff.mp hpq)
+    have hp := nativeMorseIndex_neg_add (S.data pf).chart
+    have hq := nativeMorseIndex_neg_add (S.data qf).chart
+    change nativeMorseIndex E f q.val ≤ nativeMorseIndex E f p.val at hrev
+    change nativeMorseIndex E (fun x => -f x) p.val + nativeMorseIndex E f p.val = _ at hp
+    change nativeMorseIndex E (fun x => -f x) q.val + nativeMorseIndex E f q.val = _ at hq
+    omega
+  have hzeroN : nativeMorseCount E (fun x => -f x) 0 = 1 := by
+    have hc := nativeMorseCount_neg hf hm (k := 6) (by omega)
+    simpa only [hdim, Nat.sub_self, hsix] using hc
+  have honeN :=
+    outer_index_minimal_index_one_count_zero T hf.neg (isMorse_neg hm) e hdim horderN hzeroN
+      (outer_index_minimality_neg hf hm hdim hsecondary)
+  have hc := nativeMorseCount_neg hf hm (k := 5) (by omega)
+  simpa only [hdim, Nat.reduceSub, honeN] using hc.symm
+
+private theorem MorseCancel.exists_minimal_ordered_morse_system_without_outer_indices (E : Type)
+    (M : Type) [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [PathConnectedSpace M] (e : M ≃ₕ Smale.SixSphere) (hdim : Module.finrank ℝ E = 6) :
+    ∃ f : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f ∧
+        Smale.ManifoldMorse.IsMorse E f ∧
+          ∃ _ : AdaptedWindows E f,
+            (∀ p q : Smale.ManifoldMorse.criticalPoints E f,
+                f p < f q → nativeMorseIndex E f p ≤ nativeMorseIndex E f q) ∧
+              nativeMorseCount E f 0 = 1 ∧
+                nativeMorseCount E f 6 = 1 ∧
+                  nativeMorseCount E f 1 = 0 ∧
+                    nativeMorseCount E f 5 = 0 ∧
+                      ∀ g : M → ℝ,
+                        ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g →
+                          Smale.ManifoldMorse.IsMorse E g →
+                            Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) →
+                              (Smale.ManifoldMorse.criticalPoints E f).ncard ≤
+                                (Smale.ManifoldMorse.criticalPoints E g).ncard := by
+  obtain ⟨f, hf, hm, S, horder, hzero, hsix, hminimal, hsecondary⟩ :=
+    exists_outer_index_minimal_ordered_morse_system E M
+  rw [hdim] at hsix
+  obtain ⟨hone, hfive⟩ :=
+    outer_index_minimal_outer_counts_zero S hf hm e hdim horder hzero hsix hsecondary
+  exact ⟨f, hf, hm, S, horder, hzero, hsix, hone, hfive, hminimal⟩
+
+private def Smale.DiskOnePointCollapse.boundary {N : Type*} [NormedAddCommGroup N] :
+    Set (Smale.MorseHandle.UnitDisk N) :=
+  {z | ‖(z : N)‖ = 1}
+
+private theorem Smale.DiskOnePointCollapse.boundary_closed {N : Type*} [NormedAddCommGroup N] :
+    IsClosed (boundary (N := N)) :=
+  isClosed_eq continuous_subtype_val.norm continuous_const
+
+private theorem Smale.DiskOnePointCollapse.not_mem_boundary_iff {N : Type*} [NormedAddCommGroup N]
+    (z : Smale.MorseHandle.UnitDisk N) : z ∉ boundary ↔ ‖(z : N)‖ < 1 := by
+  change ‖(z : N)‖ ≠ 1 ↔ ‖(z : N)‖ < 1
+  constructor
+  · exact lt_of_le_of_ne (mem_closedBall_zero_iff.mp z.property)
+  · exact ne_of_lt
+
+private def Smale.DiskOnePointCollapse.interiorHomeomorph {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] : ↥(boundary (N := N))ᶜ ≃ₜ N :=
+  (Homeomorph.setCongr (by ext z; exact not_mem_boundary_iff z)).trans
+    (Smale.DiskAnnulus.openDiskHomeomorph.trans Homeomorph.unitBall.symm)
+
+private def
+    Smale.DiskOnePointCollapse.collapse {N : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N] :
+    C(Smale.MorseHandle.UnitDisk N, OnePoint N) :=
+  ⟨fun z => interiorHomeomorph.onePointCongr (SixSphereCube.collapse boundary z),
+    interiorHomeomorph.onePointCongr.continuous.comp
+      (SixSphereCube.continuous_collapse boundary boundary_closed)⟩
+
+private theorem Smale.DiskOnePointCollapse.collapse_boundary {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] (z : Smale.MorseHandle.UnitDisk N) (hz : ‖(z : N)‖ = 1) :
+    collapse z = (OnePoint.infty) := by
+  change interiorHomeomorph.onePointCongr (SixSphereCube.collapse boundary z) = (OnePoint.infty)
+  rw [SixSphereCube.collapse_of_mem boundary hz]
+  rfl
+
+private theorem Smale.DiskOnePointCollapse.collapse_interior {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] (z : Smale.MorseHandle.UnitDisk N) (hz : ‖(z : N)‖ < 1) :
+    collapse z = ((OpenPartialHomeomorph.univUnitBall.symm (z : N) : N) : OnePoint N) := by
+  change interiorHomeomorph.onePointCongr (SixSphereCube.collapse boundary z) = _
+  rw [SixSphereCube.collapse_of_not_mem boundary ((not_mem_boundary_iff z).mpr hz)]
+  rfl
+
+private theorem Smale.DiskOnePointCollapse.collapse_eq_iff {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] (z w : Smale.MorseHandle.UnitDisk N) :
+    collapse z = collapse w ↔ z = w ∨ ‖(z : N)‖ = 1 ∧ ‖(w : N)‖ = 1 := by
+  change
+    interiorHomeomorph.onePointCongr (SixSphereCube.collapse boundary z) =
+        interiorHomeomorph.onePointCongr (SixSphereCube.collapse boundary w) ↔
+      _
+  rw [interiorHomeomorph.onePointCongr.injective.eq_iff, SixSphereCube.collapse_eq_iff]
+  rfl
+
+private def Smale.DiskOnePointCollapse.compress {N : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    (x : N) : Smale.MorseHandle.UnitDisk N :=
+  ⟨Homeomorph.unitBall x, Metric.ball_subset_closedBall (Homeomorph.unitBall x).property⟩
+
+private theorem Smale.DiskOnePointCollapse.norm_compress_lt {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] (x : N) : ‖(compress x : N)‖ < 1 :=
+  mem_ball_zero_iff.mp (Homeomorph.unitBall x).property
+
+private theorem Smale.DiskOnePointCollapse.compress_zero {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] : (compress (0 : N) : N) = 0 :=
+  Homeomorph.coe_unitBall_apply_zero
+
+private theorem Smale.DiskOnePointCollapse.collapse_compress {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] (x : N) : collapse (compress x) = (x : OnePoint N) := by
+  rw [collapse_interior _ (norm_compress_lt x)]
+  exact
+    congrArg (fun y : N => (y : OnePoint N))
+      (OpenPartialHomeomorph.univUnitBall.left_inv (Set.mem_univ x))
+
+private theorem Smale.DiskOnePointCollapse.collapse_eq_coe_iff {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] (z : Smale.MorseHandle.UnitDisk N) (x : N) :
+    collapse z = (x : OnePoint N) ↔ z = compress x := by
+  rw [← collapse_compress x, collapse_eq_iff]
+  constructor
+  · rintro (h | h)
+    · exact h
+    · exact ((ne_of_lt (norm_compress_lt x)) h.2).elim
+  · exact Or.inl
+
+private theorem Smale.DiskOnePointCollapse.collapse_eq_zero_iff {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] (z : Smale.MorseHandle.UnitDisk N) :
+    collapse z = ((0 : N) : OnePoint N) ↔ (z : N) = 0 := by
+  rw [collapse_eq_coe_iff]
+  constructor
+  · intro hz
+    exact (congrArg Subtype.val hz).trans compress_zero
+  · intro hz
+    exact Subtype.ext (hz.trans compress_zero.symm)
+
+private theorem Smale.DiskOnePointCollapse.collapse_eq_infty_iff {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] (z : Smale.MorseHandle.UnitDisk N) :
+    collapse z = (OnePoint.infty) ↔ ‖(z : N)‖ = 1 := by
+  by_cases hz : ‖(z : N)‖ = 1
+  · rw [collapse_boundary z hz]
+    exact iff_of_true rfl hz
+  · rw [collapse_interior z ((not_mem_boundary_iff z).mp hz)]
+    exact iff_of_false (OnePoint.coe_ne_infty _) hz
+
+private theorem Smale.ClosedHandleCore.collapseMaps_agree {N P X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [TopologicalSpace X] (A : Set X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X))
+    (hface : ∀ z, h z ∈ A ↔ ‖(z.1 : N)‖ = 1) (a : A)
+    (z : Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P)
+    (haz : oldInclusion A h a = handleInclusion A h z) :
+    ((OnePoint.infty) : OnePoint N) = Smale.DiskOnePointCollapse.collapse z.1 := by
+  have heq : (a : X) = h z := congrArg Subtype.val haz
+  have hz := (hface z).mp (heq ▸ a.property)
+  exact (Smale.DiskOnePointCollapse.collapse_boundary z.1 hz).symm
+
+private def
+    Smale.ClosedHandleCore.collapseMap {N P X : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [TopologicalSpace X] (A : Set X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X)) (hA : IsClosed A)
+    (hh : Topology.IsClosedEmbedding h) (hface : ∀ z, h z ∈ A ↔ ‖(z.1 : N)‖ = 1) :
+    C(↥(A ∪ Set.range h), OnePoint N) :=
+  Smale.ClosedCover.mapOfClosedPieces (oldInclusion A h) (handleInclusion A h) (old_closed A h hA)
+    (handle_closed A h hh) (pieces_cover A h) (ContinuousMap.const A (OnePoint.infty))
+    (Smale.DiskOnePointCollapse.collapse.comp ContinuousMap.fst) (collapseMaps_agree A h hface)
+
+private theorem Smale.ClosedHandleCore.collapseMap_old {N P X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [TopologicalSpace X] (A : Set X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X)) (hA : IsClosed A)
+    (hh : Topology.IsClosedEmbedding h) (hface : ∀ z, h z ∈ A ↔ ‖(z.1 : N)‖ = 1) (a : A) :
+    collapseMap A h hA hh hface (oldInclusion A h a) = (OnePoint.infty) :=
+  Smale.ClosedCover.mapOfClosedPieces_left (oldInclusion A h) (handleInclusion A h)
+    (old_closed A h hA) (handle_closed A h hh) (pieces_cover A h)
+    (ContinuousMap.const A (OnePoint.infty))
+    (Smale.DiskOnePointCollapse.collapse.comp ContinuousMap.fst) (collapseMaps_agree A h hface) a
+
+private theorem Smale.ClosedHandleCore.collapseMap_handle {N P X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [TopologicalSpace X] (A : Set X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X)) (hA : IsClosed A)
+    (hh : Topology.IsClosedEmbedding h) (hface : ∀ z, h z ∈ A ↔ ‖(z.1 : N)‖ = 1)
+    (z : Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P) :
+    collapseMap A h hA hh hface (handleInclusion A h z) =
+      Smale.DiskOnePointCollapse.collapse z.1 :=
+  Smale.ClosedCover.mapOfClosedPieces_right (oldInclusion A h) (handleInclusion A h)
+    (old_closed A h hA) (handle_closed A h hh) (pieces_cover A h)
+    (ContinuousMap.const A (OnePoint.infty))
+    (Smale.DiskOnePointCollapse.collapse.comp ContinuousMap.fst) (collapseMaps_agree A h hface) z
+
+private theorem
+    Smale.EmbeddedCellAttachment.collapse_piece_cover {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    Set.range (Subtype.val : D.old → X) ∪ Set.range D.cell = Set.univ := by
+  simpa only [Subtype.range_coe_subtype, Set.ofPred_mem_eq] using D.cover
+
+private theorem Smale.EmbeddedCellAttachment.collapseMaps_agree {N X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) (a : D.old)
+    (z : Smale.MorseHandle.UnitDisk N) (haz : (a : X) = D.cell z) :
+    ((OnePoint.infty) : OnePoint N) = Smale.DiskOnePointCollapse.collapse z :=
+  (Smale.DiskOnePointCollapse.collapse_boundary z ((D.boundary z).mp (haz ▸ a.property))).symm
+
+private def Smale.EmbeddedCellAttachment.collapseMap {N X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    C(X, OnePoint N) :=
+  Smale.ClosedCover.mapOfClosedPieces Subtype.val D.cell D.old_closed.isClosedEmbedding_subtypeVal
+    D.cell_closed D.collapse_piece_cover (ContinuousMap.const D.old (OnePoint.infty))
+    Smale.DiskOnePointCollapse.collapse D.collapseMaps_agree
+
+private theorem Smale.EmbeddedCellAttachment.collapseMap_old {N X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) (a : D.old) :
+    D.collapseMap a = (OnePoint.infty) :=
+  Smale.ClosedCover.mapOfClosedPieces_left Subtype.val D.cell
+    D.old_closed.isClosedEmbedding_subtypeVal D.cell_closed D.collapse_piece_cover
+    (ContinuousMap.const D.old (OnePoint.infty)) Smale.DiskOnePointCollapse.collapse
+    D.collapseMaps_agree a
+
+private theorem Smale.EmbeddedCellAttachment.collapseMap_cell {N X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X)
+    (z : Smale.MorseHandle.UnitDisk N) :
+    D.collapseMap (D.cell z) = Smale.DiskOnePointCollapse.collapse z :=
+  Smale.ClosedCover.mapOfClosedPieces_right Subtype.val D.cell
+    D.old_closed.isClosedEmbedding_subtypeVal D.cell_closed D.collapse_piece_cover
+    (ContinuousMap.const D.old (OnePoint.infty)) Smale.DiskOnePointCollapse.collapse
+    D.collapseMaps_agree z
+
+private theorem
+    Smale.EmbeddedCellAttachment.collapseMap_infty_iff {N X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) (x : X) :
+    D.collapseMap x = (OnePoint.infty) ↔ x ∈ D.old := by
+  have hx : x ∈ D.old ∪ Set.range D.cell := by rw [D.cover]; trivial
+  rcases hx with hx | ⟨z, rfl⟩
+  · exact iff_of_true (D.collapseMap_old ⟨x, hx⟩) hx
+  · rw [D.collapseMap_cell, Smale.DiskOnePointCollapse.collapse_eq_infty_iff, D.boundary]
+
+private def Smale.OnePointCover.oldPatch {N : Type*} [NormedAddCommGroup N] : Set (OnePoint N) :=
+  {((0 : N) : OnePoint N)}ᶜ
+
+private def Smale.OnePointCover.finitePatch {N : Type*} : Set (OnePoint N) :=
+  { OnePoint.infty }ᶜ
+
+private theorem Smale.OnePointCover.cover {N : Type*} [NormedAddCommGroup N] :
+    oldPatch (N := N) ∪ finitePatch = Set.univ := by
+  apply Set.eq_univ_of_forall
+  intro x
+  by_cases hx : x = ((0 : N) : OnePoint N)
+  · right
+    subst x
+    exact OnePoint.coe_ne_infty 0
+  · exact Or.inl hx
+
+private theorem Smale.OnePointCover.oldPatch_open {N : Type*} [NormedAddCommGroup N] :
+    IsOpen (oldPatch (N := N)) :=
+  isClosed_singleton.isOpen_compl
+
+private theorem Smale.OnePointCover.finitePatch_open {N : Type*} [NormedAddCommGroup N] :
+    IsOpen (finitePatch (N := N)) :=
+  isClosed_singleton.isOpen_compl
+
+private theorem Smale.OnePointCover.instLocal1 (n : ℕ) :
+    Fact (Module.finrank ℝ (EuclideanSpace ℝ (Fin (n + 1))) = n + 1) :=
+  ⟨finrank_euclideanSpace_fin⟩
+
+attribute [local instance] Smale.OnePointCover.instLocal1 in
+private def Smale.OnePointCover.spherePunctureHomeomorph_mo1973_5327 (n : ℕ)
+    (a : Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1) :
+    ↥({ a }ᶜ : Set (Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1)) ≃ₜ
+      EuclideanSpace ℝ (Fin n) :=
+  (Homeomorph.setCongr (stereographic'_source (n := n) a).symm).trans
+    ((stereographic' n a).toHomeomorphSourceTarget.trans
+      ((Homeomorph.setCongr (stereographic'_target a)).trans (Homeomorph.Set.univ _)))
+
+attribute [local instance] Smale.OnePointCover.instLocal1 in
+private def
+    Smale.OnePointCover.punctureHomeomorph {N : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [FiniteDimensional ℝ N] (a : OnePoint N) :
+    ↥({ a }ᶜ : Set (OnePoint N)) ≃ₜ EuclideanSpace ℝ (Fin (Module.finrank ℝ N)) := by
+  let e : OnePoint N ≃ₜ Metric.sphere (0 : EuclideanSpace ℝ (Fin (Module.finrank ℝ N + 1))) 1 :=
+    onePointEquivSphereOfFinrankEq (by simp)
+  let es : ↥({ a }ᶜ : Set (OnePoint N)) ≃ₜ ↥({e a}ᶜ : Set _) :=
+    e.subtype
+      (fun x => by
+        change x ≠ a ↔ e x ≠ e a
+        exact e.injective.ne_iff.symm)
+  exact es.trans (spherePunctureHomeomorph_mo1973_5327 _ (e a))
+
+attribute [local instance] Smale.OnePointCover.instLocal1 in
+private theorem Smale.OnePointCover.oldPatch_contractible {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [FiniteDimensional ℝ N] : ContractibleSpace (oldPatch (N := N)) :=
+  (punctureHomeomorph ((0 : N) : OnePoint N)).contractibleSpace
+
+attribute [local instance] Smale.OnePointCover.instLocal1 in
+private theorem Smale.OnePointCover.finitePatch_contractible {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [FiniteDimensional ℝ N] : ContractibleSpace (finitePatch (N := N)) :=
+  (punctureHomeomorph (OnePoint.infty : OnePoint N)).contractibleSpace
+
+attribute [local instance] Smale.OnePointCover.instLocal1 in
+private theorem Smale.OnePointCover.overlap_subset_range {N : Type*} [NormedAddCommGroup N] :
+    oldPatch (N := N) ∩ finitePatch ⊆ Set.range (OnePoint.some : N → _) := by
+  intro x hx
+  induction x using OnePoint.rec with
+  | infty => exact (hx.2 rfl).elim
+  | coe x => exact ⟨x, rfl⟩
+
+attribute [local instance] Smale.OnePointCover.instLocal1 in
+private theorem Smale.OnePointCover.overlap_preimage {N : Type*} [NormedAddCommGroup N] :
+    (OnePoint.some : N → OnePoint N) ⁻¹' (oldPatch ∩ finitePatch) = {u : N | u ≠ 0} := by
+  ext x
+  change ((x : OnePoint N) ≠ ((0 : N) : OnePoint N) ∧ (x : OnePoint N) ≠ OnePoint.infty) ↔ x ≠ 0
+  constructor
+  · rintro ⟨h, -⟩ hx
+    exact h (congrArg (OnePoint.some : N → OnePoint N) hx)
+  · intro hx
+    exact ⟨fun h => hx (OnePoint.coe_injective h), OnePoint.coe_ne_infty x⟩
+
+attribute [local instance] Smale.OnePointCover.instLocal1 in
+private def Smale.OnePointCover.overlapHomeomorph {N : Type*} [NormedAddCommGroup N] :
+    Smale.PuncturedRadial.Space N ≃ₜ ↥(oldPatch (N := N) ∩ finitePatch) :=
+  (Homeomorph.setCongr overlap_preimage.symm).trans
+    (OnePoint.isOpenEmbedding_coe.isEmbedding.homeomorphOfSubsetRange overlap_subset_range)
+
+attribute [local instance] Smale.OnePointCover.instLocal1 in
+private theorem Smale.OnePointCover.overlapHomeomorph_apply {N : Type*} [NormedAddCommGroup N]
+    (u : Smale.PuncturedRadial.Space N) : (overlapHomeomorph u).val = (u.val : OnePoint N) :=
+  rfl
+
+attribute [local instance] Smale.OnePointCover.instLocal1 in
+private def
+    Smale.OnePointCover.overlapSphereEquiv {N : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    (r : ℝ) (hr : 0 < r) : Metric.sphere (0 : N) 1 ≃ₕ ↥(oldPatch (N := N) ∩ finitePatch) :=
+  (Smale.PuncturedRadial.sphereHomotopyEquiv r hr).trans overlapHomeomorph.toHomotopyEquiv
+
+private def Smale.CoverNaturality.mapOn {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (f : C(X, Y)) (A : Set X) (B : Set Y) (hf : Set.MapsTo f A B) : C(A, B) :=
+  ⟨fun x => ⟨f x.val, hf x.property⟩, (f.continuous.comp continuous_subtype_val).subtype_mk _⟩
+
+private theorem Smale.CoverNaturality.chainMap_comp {X Y Z : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] [TopologicalSpace Z] (f : C(X, Y)) (g : C(Y, Z)) :
+    FirstHurewicz.singularChainMap f ≫ FirstHurewicz.singularChainMap g =
+      FirstHurewicz.singularChainMap (g.comp f) :=
+  (((AlgebraicTopology.singularChainComplexFunctor (ModuleCat ℤ)).obj (ModuleCat.of ℤ ℤ)).map_comp
+      (TopCat.ofHom f) (TopCat.ofHom g)).symm
+
+public
+theorem Smale.CoverNaturality.map_intersection {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (U V : Set X) (U' V' : Set Y) (f : C(X, Y)) (hU : Set.MapsTo f U U')
+    (hV : Set.MapsTo f V V') : Set.MapsTo f (U ∩ V) (U' ∩ V') := fun _ hx => ⟨hU hx.1, hV hx.2⟩
+
+private theorem Smale.CoverNaturality.inducedChain_mem_small {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (U V : Set X) (U' V' : Set Y) (f : C(X, Y)) (hU : Set.MapsTo f U U')
+    (hV : Set.MapsTo f V V') (n : ℕ) (c : FirstHurewicz.Chains X n)
+    (hc : c ∈ SingularMayerVietoris.smallChainSubmodule U V n) :
+    FirstHurewicz.inducedChain f n c ∈ SingularMayerVietoris.smallChainSubmodule U' V' n := by
+  have hle :
+    SingularMayerVietoris.smallChainSubmodule U V n ≤
+      (SingularMayerVietoris.smallChainSubmodule U' V' n).comap
+        (FirstHurewicz.inducedChain f n) := by
+    rw [SingularMayerVietoris.smallChainSubmodule_eq_span]
+    apply Submodule.span_le.mpr
+    rintro _ ⟨σ, hσ, rfl⟩
+    change
+      FirstHurewicz.inducedChain f n (FirstHurewicz.simplexChain X n σ) ∈
+        SingularMayerVietoris.smallChainSubmodule U' V' n
+    rw [FirstHurewicz.inducedChain_simplex]
+    apply SingularMayerVietoris.simplexChain_mem_small
+    rcases hσ with hσ | hσ
+    · left
+      rintro _ ⟨t, rfl⟩
+      exact hU (hσ ⟨t, rfl⟩)
+    · right
+      rintro _ ⟨t, rfl⟩
+      exact hV (hσ ⟨t, rfl⟩)
+  exact hle hc
+
+private def Smale.CoverNaturality.smallMap {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (U V : Set X) (U' V' : Set Y) (f : C(X, Y)) (hU : Set.MapsTo f U U')
+    (hV : Set.MapsTo f V V') :
+    SingularMayerVietoris.smallComplex U V ⟶ SingularMayerVietoris.smallComplex U' V' :=
+  SingularMayerVietoris.liftToSmall U' V'
+    (SingularMayerVietoris.smallInclusion U V ≫ FirstHurewicz.singularChainMap f)
+    (fun n c => inducedChain_mem_small U V U' V' f hU hV n c.val c.property)
+
+private theorem Smale.CoverNaturality.smallMap_inclusion {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (U V : Set X) (U' V' : Set Y) (f : C(X, Y)) (hU : Set.MapsTo f U U')
+    (hV : Set.MapsTo f V V') :
+    smallMap U V U' V' f hU hV ≫ SingularMayerVietoris.smallInclusion U' V' =
+      SingularMayerVietoris.smallInclusion U V ≫ FirstHurewicz.singularChainMap f :=
+  SingularMayerVietoris.liftToSmall_inclusion U' V' _ _
+
+private theorem
+    Smale.CoverNaturality.smallMap_left {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (U V : Set X) (U' V' : Set Y) (f : C(X, Y)) (hU : Set.MapsTo f U U')
+    (hV : Set.MapsTo f V V') :
+    SingularMayerVietoris.toSmallLeft U V ≫ smallMap U V U' V' f hU hV =
+      FirstHurewicz.singularChainMap (mapOn f U U' hU) ≫
+        SingularMayerVietoris.toSmallLeft U' V' := by
+  apply (CategoryTheory.cancel_mono (SingularMayerVietoris.smallInclusion U' V')).mp
+  rw [CategoryTheory.Category.assoc, smallMap_inclusion, ← CategoryTheory.Category.assoc,
+    SingularMayerVietoris.toSmallLeft_inclusion, CategoryTheory.Category.assoc,
+    SingularMayerVietoris.toSmallLeft_inclusion, chainMap_comp, chainMap_comp]
+  rfl
+
+private theorem Smale.CoverNaturality.smallMap_right {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (U V : Set X) (U' V' : Set Y) (f : C(X, Y)) (hU : Set.MapsTo f U U')
+    (hV : Set.MapsTo f V V') :
+    SingularMayerVietoris.toSmallRight U V ≫ smallMap U V U' V' f hU hV =
+      FirstHurewicz.singularChainMap (mapOn f V V' hV) ≫
+        SingularMayerVietoris.toSmallRight U' V' := by
+  apply (CategoryTheory.cancel_mono (SingularMayerVietoris.smallInclusion U' V')).mp
+  rw [CategoryTheory.Category.assoc, smallMap_inclusion, ← CategoryTheory.Category.assoc,
+    SingularMayerVietoris.toSmallRight_inclusion, CategoryTheory.Category.assoc,
+    SingularMayerVietoris.toSmallRight_inclusion, chainMap_comp, chainMap_comp]
+  rfl
+
+private theorem Smale.CoverNaturality.intersection_left {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (U V : Set X) (U' V' : Set Y) (f : C(X, Y)) (hU : Set.MapsTo f U U')
+    (hV : Set.MapsTo f V V') :
+    FirstHurewicz.singularChainMap
+          (mapOn f (U ∩ V) (U' ∩ V') (map_intersection U V U' V' f hU hV)) ≫
+        SingularMayerVietoris.intersectionToLeft U' V' =
+      SingularMayerVietoris.intersectionToLeft U V ≫
+        FirstHurewicz.singularChainMap (mapOn f U U' hU) := by
+  unfold SingularMayerVietoris.intersectionToLeft
+  rw [chainMap_comp, chainMap_comp]
+  rfl
+
+private theorem Smale.CoverNaturality.intersection_right {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (U V : Set X) (U' V' : Set Y) (f : C(X, Y)) (hU : Set.MapsTo f U U')
+    (hV : Set.MapsTo f V V') :
+    FirstHurewicz.singularChainMap
+          (mapOn f (U ∩ V) (U' ∩ V') (map_intersection U V U' V' f hU hV)) ≫
+        SingularMayerVietoris.intersectionToRight U' V' =
+      SingularMayerVietoris.intersectionToRight U V ≫
+        FirstHurewicz.singularChainMap (mapOn f V V' hV) := by
+  unfold SingularMayerVietoris.intersectionToRight
+  rw [chainMap_comp, chainMap_comp]
+  rfl
+
+private def
+    Smale.CoverNaturality.chainSequenceMap {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    (U V : Set X) (U' V' : Set Y) (f : C(X, Y)) (hU : Set.MapsTo f U U')
+    (hV : Set.MapsTo f V V') :
+    SingularMayerVietoris.chainSequence U V ⟶ SingularMayerVietoris.chainSequence U' V'
+    where
+  τ₁ :=
+    FirstHurewicz.singularChainMap
+      (mapOn f (U ∩ V) (U' ∩ V') (map_intersection U V U' V' f hU hV))
+  τ₂ :=
+    CategoryTheory.Limits.biprod.map (FirstHurewicz.singularChainMap (mapOn f U U' hU))
+      (FirstHurewicz.singularChainMap (mapOn f V V' hV))
+  τ₃ := smallMap U V U' V' f hU hV
+  comm₁₂ := by
+    dsimp only [SingularMayerVietoris.chainSequence, SingularMayerVietoris.leftMap,
+      SingularMayerVietoris.middleComplex]
+    apply CategoryTheory.Limits.biprod.hom_ext
+    · simp only [CategoryTheory.Category.assoc, CategoryTheory.Limits.biprod.lift_fst,
+        CategoryTheory.Limits.biprod.map_fst, CategoryTheory.Limits.biprod.lift_fst_assoc]
+      exact intersection_left U V U' V' f hU hV
+    · simp only [CategoryTheory.Category.assoc, CategoryTheory.Limits.biprod.lift_snd,
+        CategoryTheory.Limits.biprod.map_snd, CategoryTheory.Limits.biprod.lift_snd_assoc,
+        CategoryTheory.Preadditive.comp_neg, CategoryTheory.Preadditive.neg_comp]
+      exact congrArg Neg.neg (intersection_right U V U' V' f hU hV)
+  comm₂₃ := by
+    dsimp only [SingularMayerVietoris.chainSequence, SingularMayerVietoris.rightMap,
+      SingularMayerVietoris.middleComplex]
+    apply CategoryTheory.Limits.biprod.hom_ext'
+    · simp only [CategoryTheory.Limits.biprod.inl_map_assoc,
+        CategoryTheory.Limits.biprod.inl_desc, CategoryTheory.Limits.biprod.inl_desc_assoc]
+      exact (smallMap_left U V U' V' f hU hV).symm
+    · simp only [CategoryTheory.Limits.biprod.inr_map_assoc,
+        CategoryTheory.Limits.biprod.inr_desc, CategoryTheory.Limits.biprod.inr_desc_assoc]
+      exact (smallMap_right U V U' V' f hU hV).symm
+
+private theorem Smale.CoverNaturality.smallConnecting_naturality {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (U V : Set X) (U' V' : Set Y) (f : C(X, Y)) (hU : Set.MapsTo f U U')
+    (hV : Set.MapsTo f V V') (n : ℕ) :
+    (SingularMayerVietoris.singularHomologyMap
+            (mapOn f (U ∩ V) (U' ∩ V') (map_intersection U V U' V' f hU hV)) n).comp
+        (SingularMayerVietoris.smallConnectingMap U V n) =
+      (SingularMayerVietoris.smallConnectingMap U' V' n).comp
+        (SingularMayerVietoris.homologyLinearMap (smallMap U V U' V' f hU hV) (n + 1)) :=
+  SingularMayerVietoris.connectingMap_naturality
+    (SingularMayerVietoris.chainSequence_shortExact U V) (chainSequenceMap U V U' V' f hU hV)
+    (SingularMayerVietoris.chainSequence_shortExact U' V') n
+
+private theorem Smale.CoverNaturality.comparison_naturality {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (U V : Set X) (U' V' : Set Y) (f : C(X, Y)) (hU : Set.MapsTo f U U')
+    (hV : Set.MapsTo f V V') (n : ℕ) :
+    (SingularMayerVietoris.smallHomologyComparison U' V' n).comp
+        (SingularMayerVietoris.homologyLinearMap (smallMap U V U' V' f hU hV) n) =
+      (SingularMayerVietoris.singularHomologyMap f n).comp
+        (SingularMayerVietoris.smallHomologyComparison U V n) := by
+  unfold SingularMayerVietoris.smallHomologyComparison
+  rw [← SingularMayerVietoris.homologyLinearMap_comp, smallMap_inclusion,
+    SingularMayerVietoris.homologyLinearMap_comp]
+
+private theorem Smale.CoverNaturality.connecting_naturality {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (U V : Set X) (U' V' : Set Y) (f : C(X, Y)) (hfU : Set.MapsTo f U U')
+    (hfV : Set.MapsTo f V V') (hU : IsOpen U) (hV : IsOpen V) (hc : U ∪ V = Set.univ)
+    (hU' : IsOpen U') (hV' : IsOpen V') (hc' : U' ∪ V' = Set.univ) (n : ℕ) :
+    (SingularMayerVietoris.singularHomologyMap
+            (mapOn f (U ∩ V) (U' ∩ V') (map_intersection U V U' V' f hfU hfV)) n).comp
+        (SingularMayerVietoris.connectingHomomorphism U V hU hV hc n) =
+      (SingularMayerVietoris.connectingHomomorphism U' V' hU' hV' hc' n).comp
+        (SingularMayerVietoris.singularHomologyMap f (n + 1)) := by
+  apply LinearMap.ext
+  intro a
+  obtain ⟨b, hb⟩ := (SingularMayerVietoris.smallHomologyEquiv U V hU hV hc (n + 1)).surjective a
+  have hb' : SingularMayerVietoris.smallHomologyComparison U V (n + 1) b = a := hb
+  rw [← hb']
+  change
+    SingularMayerVietoris.singularHomologyMap _ n
+        (SingularMayerVietoris.connectingHomomorphism U V hU hV hc n
+          (SingularMayerVietoris.smallHomologyComparison U V (n + 1) b)) =
+      SingularMayerVietoris.connectingHomomorphism U' V' hU' hV' hc' n
+        (SingularMayerVietoris.singularHomologyMap f (n + 1)
+          (SingularMayerVietoris.smallHomologyComparison U V (n + 1) b))
+  rw [SingularMayerVietoris.connectingHomomorphism_comparison]
+  have hcomp := LinearMap.congr_fun (comparison_naturality U V U' V' f hfU hfV (n + 1)) b
+  change
+    SingularMayerVietoris.smallHomologyComparison U' V' (n + 1)
+        (SingularMayerVietoris.homologyLinearMap (smallMap U V U' V' f hfU hfV) (n + 1) b) =
+      SingularMayerVietoris.singularHomologyMap f (n + 1)
+        (SingularMayerVietoris.smallHomologyComparison U V (n + 1) b) at hcomp
+  rw [← hcomp, SingularMayerVietoris.connectingHomomorphism_comparison]
+  exact LinearMap.congr_fun (smallConnecting_naturality U V U' V' f hfU hfV n) b
+
+private theorem Smale.CoverNaturality.connecting_naturality_apply {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (U V : Set X) (U' V' : Set Y) (f : C(X, Y)) (hfU : Set.MapsTo f U U')
+    (hfV : Set.MapsTo f V V') (hU : IsOpen U) (hV : IsOpen V) (hc : U ∪ V = Set.univ)
+    (hU' : IsOpen U') (hV' : IsOpen V') (hc' : U' ∪ V' = Set.univ) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology X (n + 1)) :
+    SingularMayerVietoris.singularHomologyMap
+        (mapOn f (U ∩ V) (U' ∩ V') (map_intersection U V U' V' f hfU hfV)) n
+        (SingularMayerVietoris.connectingHomomorphism U V hU hV hc n a) =
+      SingularMayerVietoris.connectingHomomorphism U' V' hU' hV' hc' n
+        (SingularMayerVietoris.singularHomologyMap f (n + 1) a) :=
+  LinearMap.congr_fun (connecting_naturality U V U' V' f hfU hfV hU hV hc hU' hV' hc' n) a
+
+private def Smale.OnePointCover.overlapRadius : ℝ :=
+  (Real.sqrt (1 - (3 / 4 : ℝ) ^ 2))⁻¹ * (3 / 4)
+
+private theorem Smale.OnePointCover.overlapRadius_pos : 0 < overlapRadius := by
+  have h : 0 < 1 - (3 / 4 : ℝ) ^ 2 := by norm_num
+  exact mul_pos (inv_pos.mpr (Real.sqrt_pos.mpr h)) (by norm_num)
+
+private theorem
+    Smale.EmbeddedCellAttachment.collapseMap_eq_zero_iff {N X : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) (x : X) :
+    D.collapseMap x = ((0 : N) : OnePoint N) ↔ D.cell ⟨0, by simp⟩ = x := by
+  have hx : x ∈ D.old ∪ Set.range D.cell := by rw [D.cover]; trivial
+  rcases hx with hx | ⟨z, rfl⟩
+  · rw [D.collapseMap_old ⟨x, hx⟩]
+    constructor
+    · intro h
+      exact (OnePoint.infty_ne_coe (0 : N) h).elim
+    · intro h
+      rw [← h, D.boundary] at hx
+      simp at hx
+  · rw [D.collapseMap_cell, Smale.DiskOnePointCollapse.collapse_eq_zero_iff]
+    constructor
+    · intro hz
+      exact congrArg D.cell (Subtype.ext hz.symm)
+    · intro hz
+      exact (congrArg Subtype.val (D.cell_closed.injective hz)).symm
+
+private theorem Smale.EmbeddedCellAttachment.collapseMaps_oldNeighborhood {N X : Type}
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [TopologicalSpace X]
+    (D : Smale.EmbeddedCellAttachment N X) :
+    Set.MapsTo D.collapseMap D.oldNeighborhood (Smale.OnePointCover.oldPatch (N := N)) := by
+  intro x hx
+  change D.collapseMap x ≠ ((0 : N) : OnePoint N)
+  intro h
+  have heq := (D.collapseMap_eq_zero_iff x).mp h
+  rw [← heq, D.cell_mem_oldNeighborhood_iff] at hx
+  norm_num at hx
+
+private theorem
+    Smale.EmbeddedCellAttachment.collapseMaps_diskPatch {N X : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    Set.MapsTo D.collapseMap D.diskPatch (Smale.OnePointCover.finitePatch (N := N)) := by
+  intro x hx
+  change D.collapseMap x ≠ OnePoint.infty
+  exact fun h => hx ((D.collapseMap_infty_iff x).mp h)
+
+private def Smale.EmbeddedCellAttachment.collapseOverlapMap {N X : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    C(↥(D.oldNeighborhood ∩ D.diskPatch),
+      ↥(Smale.OnePointCover.oldPatch (N := N) ∩ Smale.OnePointCover.finitePatch)) :=
+  Smale.CoverNaturality.mapOn D.collapseMap _ _
+    (Smale.CoverNaturality.map_intersection _ _ _ _ D.collapseMap D.collapseMaps_oldNeighborhood
+      D.collapseMaps_diskPatch)
+
+private theorem
+    Smale.EmbeddedCellAttachment.collapseOverlap_sphere {N X : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X)
+    (u : Metric.sphere (0 : N) 1) :
+    D.collapseOverlapMap (D.overlapSphereEquiv u) =
+      Smale.OnePointCover.overlapSphereEquiv Smale.OnePointCover.overlapRadius
+        Smale.OnePointCover.overlapRadius_pos u := by
+  apply Subtype.ext
+  change
+    D.collapseMap (D.cell (Smale.DiskAnnulus.middleDisk u)) =
+      ((Smale.OnePointCover.overlapRadius • (u : N) : N) : OnePoint N)
+  rw [D.collapseMap_cell,
+    Smale.DiskOnePointCollapse.collapse_interior _ (Smale.DiskAnnulus.middleDisk_mem u).2]
+  apply congrArg (OnePoint.some : N → OnePoint N)
+  change
+    (Real.sqrt (1 - ‖(3 / 4 : ℝ) • (u : N)‖ ^ 2))⁻¹ • ((3 / 4 : ℝ) • (u : N)) =
+      Smale.OnePointCover.overlapRadius • (u : N)
+  rw [Smale.DiskAnnulus.norm_middle, smul_smul]
+  rfl
+
+private theorem Smale.EmbeddedCellAttachment.collapseOverlap_comp_sphere {N X : Type}
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [TopologicalSpace X]
+    (D : Smale.EmbeddedCellAttachment N X) :
+    D.collapseOverlapMap.comp D.overlapSphereEquiv.toFun =
+      (Smale.OnePointCover.overlapSphereEquiv (N := N) Smale.OnePointCover.overlapRadius
+          Smale.OnePointCover.overlapRadius_pos).toFun :=
+  ContinuousMap.ext D.collapseOverlap_sphere
+
+private def
+    Smale.OnePointCover.overlapHomologyEquiv {N : Type} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    (r : ℝ) (hr : 0 < r) (k : ℕ) :
+    SingularMayerVietoris.SingularHomology (Metric.sphere (0 : N) 1) k ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (↥(oldPatch (N := N) ∩ finitePatch)) k :=
+  PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (overlapSphereEquiv r hr) k
+
+private def Smale.OnePointCover.sphereConnecting {N : Type} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    (r : ℝ) (hr : 0 < r) (k : ℕ) :
+    SingularMayerVietoris.SingularHomology (OnePoint N) (k + 1) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (Metric.sphere (0 : N) 1) k :=
+  (overlapHomologyEquiv r hr k).symm.toLinearMap.comp
+    (SingularMayerVietoris.connectingHomomorphism oldPatch finitePatch oldPatch_open
+      finitePatch_open cover k)
+
+private theorem Smale.OnePointCover.sphereConnecting_injective {N : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [FiniteDimensional ℝ N] (r : ℝ) (hr : 0 < r) (k : ℕ) :
+    Function.Injective (sphereConnecting (N := N) r hr k) := by
+  let : ContractibleSpace (oldPatch (N := N)) := oldPatch_contractible
+  let : ContractibleSpace (finitePatch (N := N)) := finitePatch_contractible
+  have hi :
+    Function.Injective
+      (SingularMayerVietoris.connectingHomomorphism (oldPatch (N := N)) finitePatch oldPatch_open
+        finitePatch_open cover k) :=
+    CuspCentralHomology.contractibleCoverConnecting_injective (oldPatch (N := N)) finitePatch
+      oldPatch_open finitePatch_open cover k
+  exact (overlapHomologyEquiv (N := N) r hr k).symm.injective.comp hi
+
+private def
+    Smale.OnePointCover.sphereHomologyEquiv {N : Type} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [FiniteDimensional ℝ N] (r : ℝ) (hr : 0 < r) (k : ℕ) :
+    SingularMayerVietoris.SingularHomology (OnePoint N) (k + 2) ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (Metric.sphere (0 : N) 1) (k + 1) := by
+  let : ContractibleSpace (oldPatch (N := N)) := oldPatch_contractible
+  let : ContractibleSpace (finitePatch (N := N)) := finitePatch_contractible
+  exact
+    (CuspCentralHomology.contractibleCoverHomologyHigherEquiv oldPatch finitePatch oldPatch_open
+          finitePatch_open cover k).trans
+      (overlapHomologyEquiv r hr (k + 1)).symm
+
+private theorem Smale.EmbeddedCellAttachment.collapse_overlapHomology_compare {N X : Type}
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [TopologicalSpace X]
+    (D : Smale.EmbeddedCellAttachment N X) (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (Metric.sphere (0 : N) 1) k) :
+    SingularMayerVietoris.singularHomologyMap D.collapseOverlapMap k
+        (D.overlapHomologyEquiv k a) =
+      Smale.OnePointCover.overlapHomologyEquiv Smale.OnePointCover.overlapRadius
+        Smale.OnePointCover.overlapRadius_pos k a := by
+  change
+    SingularMayerVietoris.singularHomologyMap D.collapseOverlapMap k
+        (SingularMayerVietoris.singularHomologyMap D.overlapSphereEquiv.toFun k a) =
+      SingularMayerVietoris.singularHomologyMap _ k a
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    D.collapseOverlap_comp_sphere]
+
+private theorem Smale.EmbeddedCellAttachment.collapse_connecting_compare {N X : Type}
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [TopologicalSpace X]
+    (D : Smale.EmbeddedCellAttachment N X) (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology X (k + 1)) :
+    Smale.OnePointCover.sphereConnecting Smale.OnePointCover.overlapRadius
+        Smale.OnePointCover.overlapRadius_pos k
+        (SingularMayerVietoris.singularHomologyMap D.collapseMap (k + 1) a) =
+      D.cellConnectingMap k a := by
+  apply
+    (Smale.OnePointCover.overlapHomologyEquiv (N := N) Smale.OnePointCover.overlapRadius
+        Smale.OnePointCover.overlapRadius_pos k).injective
+  change
+    Smale.OnePointCover.overlapHomologyEquiv _ _ k
+        ((Smale.OnePointCover.overlapHomologyEquiv _ _ k).symm _) =
+      Smale.OnePointCover.overlapHomologyEquiv _ _ k ((D.overlapHomologyEquiv k).symm _)
+  rw [LinearEquiv.apply_symm_apply, ← D.collapse_overlapHomology_compare,
+    LinearEquiv.apply_symm_apply]
+  exact
+    (Smale.CoverNaturality.connecting_naturality_apply D.oldNeighborhood D.diskPatch
+        Smale.OnePointCover.oldPatch Smale.OnePointCover.finitePatch D.collapseMap
+        D.collapseMaps_oldNeighborhood D.collapseMaps_diskPatch D.isOpen_oldNeighborhood
+        D.isOpen_diskPatch D.open_cover Smale.OnePointCover.oldPatch_open
+        Smale.OnePointCover.finitePatch_open Smale.OnePointCover.cover k a).symm
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.MorseSurgeryData.attachmentCollapseMap {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f) :
+    C(↥({y : M | f y ≤ f p - d.radius ^ 2} ∪ Set.range d.handleMap),
+      OnePoint d.chart.NegativeCoordinates) :=
+  Smale.ClosedHandleCore.collapseMap _ d.handleMap (isClosed_le hf continuous_const)
+    (d.chart.attachingHandleMap_isClosedEmbedding d.radius d.radius_pos d.block)
+    (d.chart.attachingHandleMap_lower_iff d.radius d.radius_pos d.block)
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    Smale.ManifoldMorse.MorseSurgeryData.upperCollapseMap {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f) :
+    C({ y : M // f y ≤ f p + d.radius ^ 2 }, OnePoint d.chart.NegativeCoordinates) :=
+  (d.attachmentCollapseMap hf).comp d.attachmentHomeomorph.symm.toHomotopyEquiv.toFun
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.upperCollapse_realization {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (x : ↥({y : M | f y ≤ f p - d.radius ^ 2} ∪ Set.range d.handleMap)) :
+    d.upperCollapseMap hf (d.attachmentHomeomorph x) = d.attachmentCollapseMap hf x := by
+  change d.attachmentCollapseMap hf (d.attachmentHomeomorph.symm (d.attachmentHomeomorph x)) = _
+  exact congrArg (d.attachmentCollapseMap hf) (d.attachmentHomeomorph.symm_apply_apply x)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.upperCollapse_old {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (x : { y : M // f y ≤ f p - d.radius ^ 2 }) :
+    d.upperCollapseMap hf (d.realizedLowerInclusion x) = (OnePoint.infty) := by
+  change
+    d.upperCollapseMap hf
+        (d.attachmentHomeomorph (Smale.ClosedHandleCore.oldInclusion _ d.handleMap x)) =
+      (OnePoint.infty)
+  rw [d.upperCollapse_realization]
+  exact Smale.ClosedHandleCore.collapseMap_old _ d.handleMap _ _ _ x
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.upperCollapse_handle {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (z : d.HandleDomain) :
+    d.upperCollapseMap hf (d.attachmentHomeomorph ⟨d.handleMap z, Or.inr ⟨z, rfl⟩⟩) =
+      Smale.DiskOnePointCollapse.collapse z.1 := by
+  exact
+    (d.upperCollapse_realization hf
+          (Smale.ClosedHandleCore.handleInclusion _ d.handleMap z)).trans
+      (Smale.ClosedHandleCore.collapseMap_handle _ d.handleMap _ _ _ z)
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    Smale.ManifoldMorse.MorseSurgeryData.levelCollapseMap {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f) :
+    C(d.UpperLevel, OnePoint d.chart.NegativeCoordinates) :=
+  (d.upperCollapseMap hf).comp ⟨Set.inclusion (fun _ hx => hx.le), continuous_inclusion _⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.levelCollapse_realized {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (y : d.UpperLevel) (x : ↥({z : M | f z ≤ f p - d.radius ^ 2} ∪ Set.range d.handleMap))
+    (hy : (y : M) = (d.attachmentHomeomorph x).val) :
+    d.levelCollapseMap hf y = d.attachmentCollapseMap hf x := by
+  change d.upperCollapseMap hf ⟨y.val, y.property.le⟩ = _
+  have heq :
+    (⟨y.val, y.property.le⟩ : { z : M // f z ≤ f p + d.radius ^ 2 }) = d.attachmentHomeomorph x :=
+    Subtype.ext hy
+  rw [heq, d.upperCollapse_realization]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.levelCollapse_newExterior {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f) (r) :
+    d.levelCollapseMap hf (d.surgery.newExterior r) = (OnePoint.infty) := by
+  rw [d.levelCollapse_realized hf _ _ (d.newExterior_eq r)]
+  exact Smale.ClosedHandleCore.collapseMap_old _ d.handleMap _ _ _ ⟨r.val, r.property.1.le⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.levelCollapse_newPiece {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (z :
+      Smale.PuncturedHandle.UnitBall d.chart.NegativeCoordinates ×
+        Smale.PuncturedHandle.UnitSphere d.chart.PositiveCoordinates) :
+    d.levelCollapseMap hf (d.surgery.newPiece z) =
+      Smale.DiskOnePointCollapse.collapse
+        (Smale.MorseHandle.unitBallHomeomorph d.chart.NegativeCoordinates z.1) := by
+  rw [d.levelCollapse_realized hf _ _ (d.newPiece_eq z)]
+  exact
+    Smale.ClosedHandleCore.collapseMap_handle _ d.handleMap _ _ _
+      (d.chart.handleBallCoordinates (z.1, Smale.PuncturedHandle.sphereToBall z.2))
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.levelCollapse_zero_iff {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (x : d.UpperLevel) :
+    d.levelCollapseMap hf x = ((0 : d.chart.NegativeCoordinates) : OnePoint _) ↔
+      x ∈ Set.range d.surgery.beltSphere := by
+  have hx : x ∈ Set.range d.surgery.newExterior ∪ Set.range d.surgery.newPiece := by
+    rw [d.surgery.new_cover]
+    trivial
+  rcases hx with ⟨r, rfl⟩ | ⟨z, rfl⟩
+  · rw [d.levelCollapse_newExterior]
+    exact iff_of_false (OnePoint.infty_ne_coe _) (d.surgery.newExterior_avoids r)
+  · rw [d.levelCollapse_newPiece, Smale.DiskOnePointCollapse.collapse_eq_zero_iff,
+      d.surgery.newPiece_mem_belt_iff]
+    rfl
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.upperCollapse_coreCell {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f) :
+    (d.upperCollapseMap hf).comp (d.coreUnionHomotopyEquiv hf).toFun =
+      (d.coreCellPresentation hf).collapseMap := by
+  apply ContinuousMap.ext
+  rintro ⟨x, hx | ⟨u, rfl⟩⟩
+  · exact
+      (d.upperCollapse_old hf ⟨x, hx⟩).trans
+        ((d.coreCellPresentation hf).collapseMap_old ⟨⟨x, Or.inl hx⟩, hx⟩).symm
+  · change
+      d.upperCollapseMap hf
+          (d.attachmentHomeomorph ⟨d.handleMap (u, ⟨0, by simp⟩), Or.inr ⟨_, rfl⟩⟩) =
+        (d.coreCellPresentation hf).collapseMap ((d.coreCellPresentation hf).cell u)
+    rw [d.upperCollapse_handle, (d.coreCellPresentation hf).collapseMap_cell]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.upperCollapseHomology_coreCell {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (k : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (↥({y : M | f y ≤ f p - d.radius ^ 2} ∪ Set.range d.coreMap)) k) :
+    SingularMayerVietoris.singularHomologyMap (d.upperCollapseMap hf) k
+        (d.cellTotalHomologyEquiv hf k a) =
+      SingularMayerVietoris.singularHomologyMap (d.coreCellPresentation hf).collapseMap k a := by
+  change
+    SingularMayerVietoris.singularHomologyMap (d.upperCollapseMap hf) k
+        (SingularMayerVietoris.singularHomologyMap (d.coreUnionHomotopyEquiv hf).toFun k a) =
+      _
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    d.upperCollapse_coreCell]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.upperCollapse_connecting_compare {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p + d.radius ^ 2 } (k + 1)) :
+    Smale.OnePointCover.sphereConnecting Smale.OnePointCover.overlapRadius
+        Smale.OnePointCover.overlapRadius_pos k
+        (SingularMayerVietoris.singularHomologyMap (d.upperCollapseMap hf) (k + 1) a) =
+      d.morseConnectingMap hf k a := by
+  obtain ⟨b, rfl⟩ := (d.cellTotalHomologyEquiv hf (k + 1)).surjective a
+  rw [d.upperCollapseHomology_coreCell, (d.coreCellPresentation hf).collapse_connecting_compare,
+    d.morseConnecting_compare]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.upperCollapse_homology_equiv_compare {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p + d.radius ^ 2 } (k + 2)) :
+    Smale.OnePointCover.sphereHomologyEquiv Smale.OnePointCover.overlapRadius
+        Smale.OnePointCover.overlapRadius_pos k
+        (SingularMayerVietoris.singularHomologyMap (d.upperCollapseMap hf) (k + 2) a) =
+      d.morseConnectingMap hf (k + 1) a :=
+  d.upperCollapse_connecting_compare hf (k + 1) a
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.upperCollapse_homology_kernel {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (k : ℕ) :
+    LinearMap.ker (SingularMayerVietoris.singularHomologyMap (d.upperCollapseMap hf) (k + 1)) =
+      LinearMap.range (d.lowerRealizationHomologyMap (k + 1)) := by
+  rw [d.morse_exact_at_upper hf k]
+  ext a
+  change
+    SingularMayerVietoris.singularHomologyMap (d.upperCollapseMap hf) (k + 1) a = 0 ↔
+      d.morseConnectingMap hf k a = 0
+  rw [← d.upperCollapse_connecting_compare]
+  constructor
+  · intro h
+    rw [h, map_zero]
+  · intro h
+    exact
+      (Smale.OnePointCover.sphereConnecting_injective Smale.OnePointCover.overlapRadius
+          Smale.OnePointCover.overlapRadius_pos k)
+        (h.trans (map_zero _).symm)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.morseConnecting_surjective_of_lower {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (k : ℕ) (hk : k ≠ 0)
+    [Subsingleton
+        (SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p - d.radius ^ 2 } k)] :
+    Function.Surjective (d.morseConnectingMap hf k) := by
+  intro a
+  have ha : a ∈ LinearMap.ker (d.coreBoundaryHomologyMap k) := Subsingleton.elim _ _
+  rw [← d.morse_exact_at_attachingSphere hf k hk] at ha
+  exact ha
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.upperCollapse_surjective_of_lower {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (k : ℕ)
+    [Subsingleton
+        (SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p - d.radius ^ 2 } (k + 1))] :
+    Function.Surjective
+      (SingularMayerVietoris.singularHomologyMap (d.upperCollapseMap hf) (k + 2)) := by
+  intro a
+  let C :=
+    Smale.OnePointCover.sphereHomologyEquiv (N := d.chart.NegativeCoordinates)
+      Smale.OnePointCover.overlapRadius Smale.OnePointCover.overlapRadius_pos k
+  obtain ⟨b, hb⟩ := d.morseConnecting_surjective_of_lower hf (k + 1) (by omega) (C a)
+  refine ⟨b, C.injective ?_⟩
+  exact (d.upperCollapse_homology_equiv_compare hf k b).trans hb
+
+private theorem Smale.LocalDegree.exists_native_boundaryData {E F M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → F} (x : M)
+    (hf : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, F) ∞ f x) (hzero : f x = 0)
+    (hA : (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, F) f x).IsInvertible) (W : Set M) (hW : W ∈ 𝓝 x) :
+    ∃ L : E ≃L[ℝ] F,
+      L.toContinuousLinearMap = fderiv ℝ (f ∘ Smale.NativeParametrization.centered (D := E) x) 0 ∧
+        Nonempty
+          (BoundaryData (f ∘ Smale.NativeParametrization.centered (D := E) x) L
+            ((Smale.NativeParametrization.centered (D := E) x).source ∩
+              Smale.NativeParametrization.centered (D := E) x ⁻¹' W)) := by
+  let c := Smale.NativeParametrization.centered (D := E) x
+  have hc0 : (0 : E) ∈ c.source := Smale.NativeParametrization.zero_mem_centered_source x
+  have hcx : c 0 = x := Smale.NativeParametrization.centered_zero x
+  have hcf : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, F) ∞ f (c 0) := hcx.symm ▸ hf
+  have hc : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, E) ∞ c 0 :=
+    c.contMDiffOn_toFun.contMDiffAt (c.open_source.mem_nhds hc0)
+  have hcomp : ContDiffAt ℝ ∞ (f ∘ c) 0 := (hcf.comp 0 hc).contDiffAt
+  let A : E →L[ℝ] F := mfderiv 𝓘(ℝ, E) 𝓘(ℝ, F) f (c 0)
+  let C : E →L[ℝ] E := mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) c 0
+  have hAi : A.IsInvertible := by
+    change (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, F) f (c 0)).IsInvertible
+    rw [hcx]
+    exact hA
+  have hCi : C.IsInvertible :=
+    ⟨(LinearEquiv.ofBijective C.toLinearMap
+          (Smale.PartialChart.bijective_mfderiv c hc0)).toContinuousLinearEquiv,
+      rfl⟩
+  have hder : HasFDerivAt (f ∘ c) (A.comp C) 0 :=
+    ((hcf.mdifferentiableAt (by simp)).hasMFDerivAt.comp 0
+        (hc.mdifferentiableAt (by simp)).hasMFDerivAt).hasFDerivAt
+  obtain ⟨L, hL⟩ := hAi.comp hCi
+  have hdL : HasFDerivAt (f ∘ c) L.toContinuousLinearMap 0 := hL.symm ▸ hder
+  have hs : c.source ∩ c ⁻¹' W ∈ 𝓝 (0 : E) :=
+    Filter.inter_mem (c.open_source.mem_nhds hc0) (hc.continuousAt (hcx.symm ▸ hW))
+  refine ⟨L, hdL.fderiv.symm, ?_⟩
+  apply nonempty_boundaryData_of_contDiffAt L hdL _ hs hcomp
+  change f (c 0) = 0
+  rw [hcx]
+  exact hzero
+
+private structure Smale.LocalDegree.NeighborhoodData {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] (f : E → F) (L : E ≃L[ℝ] F)
+    (s : Set E) where
+  radius : ℝ
+  radius_pos : 0 < radius
+  center_zero : f 0 = 0
+  ball_subset : Metric.closedBall 0 radius ⊆ s
+  continuous : ContinuousOn f (Metric.closedBall 0 radius)
+  remainder_bound : ∀ x ∈ Metric.closedBall 0 radius, ‖f x - L x‖ ≤ (1 / 2 : ℝ) * ‖L x‖
+
+private theorem Smale.LocalDegree.nonempty_neighborhoodData {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F} (L : E ≃L[ℝ] F)
+    {s : Set E} (hf : HasFDerivAt f L.toContinuousLinearMap 0) (hzero : f 0 = 0)
+    (hs : s ∈ 𝓝 (0 : E)) (hc : ContinuousOn f s) : Nonempty (NeighborhoodData f L s) := by
+  obtain ⟨ε, hε, hεb⟩ := exists_pos_remainder_bound L hf hzero
+  obtain ⟨b⟩ :=
+    nonempty_boundaryData L hf hzero (Filter.inter_mem hs (Metric.ball_mem_nhds 0 hε))
+      (hc.mono Set.inter_subset_left)
+  have hbs : Metric.closedBall (0 : E) b.radius ⊆ s := b.ball_subset.trans Set.inter_subset_left
+  exact
+    ⟨⟨b.radius, b.radius_pos, hzero, hbs, hc.mono hbs, fun x hx => hεb x (b.ball_subset hx).2⟩⟩
+
+private theorem Smale.LocalDegree.nonempty_neighborhoodData_of_contDiffAt {E F : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F}
+    (L : E ≃L[ℝ] F) {s : Set E} (hf : HasFDerivAt f L.toContinuousLinearMap 0) (hzero : f 0 = 0)
+    (hs : s ∈ 𝓝 (0 : E)) (hc : ContDiffAt ℝ ∞ f 0) : Nonempty (NeighborhoodData f L s) := by
+  obtain ⟨t, ht, htc⟩ := contDiffAt_zero.mp (hc.of_le (by simp))
+  obtain ⟨d⟩ :=
+    nonempty_neighborhoodData L hf hzero (Filter.inter_mem hs ht)
+      (htc.mono Set.inter_subset_right)
+  exact ⟨{ d with ball_subset := d.ball_subset.trans Set.inter_subset_left }⟩
+
+private theorem
+    Smale.LocalDegree.NeighborhoodData.image_ne_zero {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F} {L : E ≃L[ℝ] F}
+    {s : Set E} (d : Smale.LocalDegree.NeighborhoodData f L s) {x : E}
+    (hx : x ∈ Metric.closedBall 0 d.radius) (hx0 : x ≠ 0) : f x ≠ 0 :=
+  Smale.LocalDegree.image_ne_zero L hx0 (d.remainder_bound x hx)
+
+private def Smale.LocalDegree.NeighborhoodData.innerBoundary {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F} {L : E ≃L[ℝ] F}
+    {s : Set E} (d : Smale.LocalDegree.NeighborhoodData f L s) :
+    Smale.LocalDegree.BoundaryData f L s := by
+  have hr : 0 < d.radius / 2 := half_pos d.radius_pos
+  have hballs : Metric.closedBall (0 : E) (d.radius / 2) ⊆ Metric.closedBall 0 d.radius :=
+    Metric.closedBall_subset_closedBall (half_le_self d.radius_pos.le)
+  have hparam (u : Metric.sphere (0 : E) 1) :
+    (d.radius / 2) • (u : E) ∈ Metric.closedBall (0 : E) d.radius := by
+    rw [mem_closedBall_zero_iff, Smale.LocalDegree.norm_radius_smul (d.radius / 2) hr u]
+    exact half_le_self d.radius_pos.le
+  refine ⟨d.radius / 2, hr, hballs.trans d.ball_subset, ?_, ?_⟩
+  · exact d.continuous.comp_continuous (continuous_const.smul continuous_subtype_val) hparam
+  · exact fun u => d.remainder_bound _ (hparam u)
+
+private theorem Smale.LocalDegree.NeighborhoodData.innerBoundary_radius {E F : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F}
+    {L : E ≃L[ℝ] F} {s : Set E} (d : Smale.LocalDegree.NeighborhoodData f L s) :
+    d.innerBoundary.radius = d.radius / 2 :=
+  rfl
+
+private theorem Smale.LocalDegree.NeighborhoodData.innerBoundary_mem_ball {E F : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F}
+    {L : E ≃L[ℝ] F} {s : Set E} (d : Smale.LocalDegree.NeighborhoodData f L s)
+    (u : Metric.sphere (0 : E) 1) :
+    d.innerBoundary.radius • (u : E) ∈ Metric.ball (0 : E) d.radius := by
+  rw [mem_ball_zero_iff, Smale.LocalDegree.norm_radius_smul _ d.innerBoundary.radius_pos,
+    innerBoundary_radius]
+  exact half_lt_self d.radius_pos
+
+private theorem
+    Smale.LocalDegree.exists_native_neighborhoodData {E F M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → F} (x : M)
+    (hf : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, F) ∞ f x) (hzero : f x = 0)
+    (hA : (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, F) f x).IsInvertible) (W : Set M) (hW : W ∈ 𝓝 x) :
+    ∃ L : E ≃L[ℝ] F,
+      L.toContinuousLinearMap = fderiv ℝ (f ∘ Smale.NativeParametrization.centered (D := E) x) 0 ∧
+        Nonempty
+          (NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) x) L
+            ((Smale.NativeParametrization.centered (D := E) x).source ∩
+              Smale.NativeParametrization.centered (D := E) x ⁻¹' W)) := by
+  obtain ⟨L, hL, _⟩ := exists_native_boundaryData x hf hzero hA W hW
+  let c := Smale.NativeParametrization.centered (D := E) x
+  have hc0 : (0 : E) ∈ c.source := Smale.NativeParametrization.zero_mem_centered_source x
+  have hcx : c 0 = x := Smale.NativeParametrization.centered_zero x
+  have hc : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, E) ∞ c 0 :=
+    c.contMDiffOn_toFun.contMDiffAt (c.open_source.mem_nhds hc0)
+  have hcf : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, F) ∞ f (c 0) := hcx.symm ▸ hf
+  have hcomp : ContDiffAt ℝ ∞ (f ∘ c) 0 := (hcf.comp 0 hc).contDiffAt
+  have hd : HasFDerivAt (f ∘ c) L.toContinuousLinearMap 0 := by
+    rw [hL]
+    exact (hcomp.differentiableAt (by simp)).hasFDerivAt
+  have hs : c.source ∩ c ⁻¹' W ∈ 𝓝 (0 : E) :=
+    Filter.inter_mem (c.open_source.mem_nhds hc0) (hc.continuousAt (hcx.symm ▸ hW))
+  refine ⟨L, hL, nonempty_neighborhoodData_of_contDiffAt L hd ?_ hs hcomp⟩
+  change f (c 0) = 0
+  rw [hcx]
+  exact hzero
+
+private def
+    Smale.ChartPuncturedBall.openSet {E M : Type*} [NormedAddCommGroup E] [TopologicalSpace M]
+    (c : OpenPartialHomeomorph E M) (R : ℝ) : Set M :=
+  c '' Metric.ball (0 : E) R
+
+private def Smale.ChartPuncturedBall.puncturedSet {E M : Type*} [NormedAddCommGroup E]
+    [TopologicalSpace M] (c : OpenPartialHomeomorph E M) (R : ℝ) : Set M :=
+  {c 0}ᶜ ∩ openSet c R
+
+private theorem Smale.ChartPuncturedBall.zero_mem_source {E M : Type*} [NormedAddCommGroup E]
+    [TopologicalSpace M] (c : OpenPartialHomeomorph E M) (R : ℝ) (hR : 0 < R)
+    (hs : Metric.closedBall (0 : E) R ⊆ c.source) : (0 : E) ∈ c.source :=
+  hs (by simpa using hR.le)
+
+private theorem Smale.ChartPuncturedBall.ball_subset_source {E M : Type*} [NormedAddCommGroup E]
+    [TopologicalSpace M] (c : OpenPartialHomeomorph E M) (R : ℝ)
+    (hs : Metric.closedBall (0 : E) R ⊆ c.source) : Metric.ball (0 : E) R ⊆ c.source :=
+  Metric.ball_subset_closedBall.trans hs
+
+private theorem Smale.ChartPuncturedBall.isOpen_openSet {E M : Type*} [NormedAddCommGroup E]
+    [TopologicalSpace M] (c : OpenPartialHomeomorph E M) (R : ℝ)
+    (hs : Metric.closedBall (0 : E) R ⊆ c.source) : IsOpen (openSet c R) :=
+  c.isOpen_image_of_subset_source Metric.isOpen_ball (ball_subset_source c R hs)
+
+private theorem Smale.ChartPuncturedBall.center_mem_openSet {E M : Type*} [NormedAddCommGroup E]
+    [TopologicalSpace M] (c : OpenPartialHomeomorph E M) (R : ℝ) (hR : 0 < R) :
+    c 0 ∈ openSet c R :=
+  Set.mem_image_of_mem c (by simpa using hR)
+
+private def Smale.ChartPuncturedBall.ballHomeomorph {E M : Type*} [NormedAddCommGroup E]
+    [TopologicalSpace M] (c : OpenPartialHomeomorph E M) (R : ℝ)
+    (hs : Metric.closedBall (0 : E) R ⊆ c.source) : Metric.ball (0 : E) R ≃ₜ openSet c R :=
+  c.homeomorphOfImageSubsetSource (ball_subset_source c R hs) rfl
+
+private theorem Smale.ChartPuncturedBall.image_puncturedBall {E M : Type*} [NormedAddCommGroup E]
+    [TopologicalSpace M] (c : OpenPartialHomeomorph E M) (R : ℝ) (hR : 0 < R)
+    (hs : Metric.closedBall (0 : E) R ⊆ c.source) :
+    c '' {x : E | x ≠ 0 ∧ ‖x‖ < R} = puncturedSet c R := by
+  ext y
+  constructor
+  · rintro ⟨x, ⟨hx0, hxR⟩, rfl⟩
+    have hx : x ∈ Metric.ball (0 : E) R := mem_ball_zero_iff.mpr hxR
+    refine ⟨?_, ⟨x, hx, rfl⟩⟩
+    change c x ≠ c 0
+    exact fun h => hx0 (c.injOn (ball_subset_source c R hs hx) (zero_mem_source c R hR hs) h)
+  · rintro ⟨hy0, x, hxR, rfl⟩
+    refine ⟨x, ⟨?_, mem_ball_zero_iff.mp hxR⟩, rfl⟩
+    intro hx0
+    subst x
+    exact hy0 rfl
+
+private def Smale.ChartPuncturedBall.puncturedHomeomorph {E M : Type*} [NormedAddCommGroup E]
+    [TopologicalSpace M] (c : OpenPartialHomeomorph E M) (R : ℝ) (hR : 0 < R)
+    (hs : Metric.closedBall (0 : E) R ⊆ c.source) :
+    Smale.PuncturedBall.Space E R ≃ₜ puncturedSet c R :=
+  c.homeomorphOfImageSubsetSource
+    (fun _ hx => ball_subset_source c R hs (mem_ball_zero_iff.mpr hx.2))
+    (image_puncturedBall c R hR hs)
+
+private def Smale.LocalDegree.NativeNeighborhood.openSet {E F M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x : M) {f : M → F} {L : E ≃L[ℝ] F} {W : Set M}
+    (d :
+      Smale.LocalDegree.NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) x) L
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' W)) :
+    Set M :=
+  Smale.ChartPuncturedBall.openSet
+    (Smale.NativeParametrization.centered (D := E) x).toOpenPartialHomeomorph d.radius
+
+private theorem Smale.LocalDegree.NativeNeighborhood.closedBall_subset_source {E F M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x : M) {f : M → F}
+    {L : E ≃L[ℝ] F} {W : Set M}
+    (d :
+      Smale.LocalDegree.NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) x) L
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' W)) :
+    Metric.closedBall (0 : E) d.radius ⊆ (Smale.NativeParametrization.centered x).source :=
+  d.ball_subset.trans Set.inter_subset_left
+
+private theorem
+    Smale.LocalDegree.NativeNeighborhood.isOpen_openSet {E F M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x : M) {f : M → F} {L : E ≃L[ℝ] F} {W : Set M}
+    (d :
+      Smale.LocalDegree.NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) x) L
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' W)) :
+    IsOpen (openSet x d) :=
+  Smale.ChartPuncturedBall.isOpen_openSet
+    (Smale.NativeParametrization.centered x).toOpenPartialHomeomorph d.radius
+    (closedBall_subset_source x d)
+
+private theorem Smale.LocalDegree.NativeNeighborhood.center_mem_openSet {E F M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x : M) {f : M → F}
+    {L : E ≃L[ℝ] F} {W : Set M}
+    (d :
+      Smale.LocalDegree.NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) x) L
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' W)) :
+    x ∈ openSet x d := by
+  have h :=
+    Smale.ChartPuncturedBall.center_mem_openSet
+      (Smale.NativeParametrization.centered (D := E) x).toOpenPartialHomeomorph d.radius
+      d.radius_pos
+  change Smale.NativeParametrization.centered x (0 : E) ∈ openSet x d at h
+  rwa [Smale.NativeParametrization.centered_zero] at h
+
+private theorem
+    Smale.LocalDegree.NativeNeighborhood.openSet_subset {E F M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x : M) {f : M → F} {L : E ≃L[ℝ] F} {W : Set M}
+    (d :
+      Smale.LocalDegree.NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) x) L
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' W)) :
+    openSet x d ⊆ W := by
+  rintro y ⟨u, hu, rfl⟩
+  exact (d.ball_subset (Metric.ball_subset_closedBall hu)).2
+
+private def
+    Smale.LocalDegree.NativeNeighborhood.puncturedHomeomorph {E F M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x : M) {f : M → F} {L : E ≃L[ℝ] F} {W : Set M}
+    (d :
+      Smale.LocalDegree.NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) x) L
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' W)) :
+    Smale.PuncturedBall.Space E d.radius ≃ₜ ↥({ x }ᶜ ∩ openSet x d) :=
+  (Smale.ChartPuncturedBall.puncturedHomeomorph
+        (Smale.NativeParametrization.centered x).toOpenPartialHomeomorph d.radius d.radius_pos
+        (closedBall_subset_source x d)).trans
+    (Homeomorph.setCongr
+      (by
+        change {Smale.NativeParametrization.centered x (0 : E)}ᶜ ∩ openSet x d = _
+        rw [Smale.NativeParametrization.centered_zero]))
+
+private def
+    Smale.LocalDegree.NativeNeighborhood.overlapSphereEquiv {E F M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x : M) {f : M → F} {L : E ≃L[ℝ] F} {W : Set M}
+    (d :
+      Smale.LocalDegree.NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) x) L
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' W)) :
+    Metric.sphere (0 : E) 1 ≃ₕ ↥({ x }ᶜ ∩ openSet x d) :=
+  (Smale.PuncturedBall.sphereHomotopyEquiv d.radius d.innerBoundary.radius
+        d.innerBoundary.radius_pos
+        (by
+          rw [d.innerBoundary_radius]
+          exact half_lt_self d.radius_pos)).trans
+    (puncturedHomeomorph x d).toHomotopyEquiv
+
+private structure Smale.LocalDegree.SeparatedNeighborhoods (E : Type) [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {F M : Type} [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (P : Set M) (f : M → F) (W : Set M) where
+  linear : P → E ≃L[ℝ] F
+  derivative_eq :
+    ∀ x : P,
+      (linear x).toContinuousLinearMap =
+        fderiv ℝ (f ∘ Smale.NativeParametrization.centered (D := E) (x : M)) 0
+  data :
+    ∀ x : P,
+      NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) (x : M)) (linear x)
+        ((Smale.NativeParametrization.centered (D := E) (x : M)).source ∩
+          Smale.NativeParametrization.centered (D := E) (x : M) ⁻¹' W)
+  disjoint : Pairwise (Disjoint on (fun x : P => NativeNeighborhood.openSet (x : M) (data x)))
+
+private theorem Smale.LocalDegree.nonempty_separatedNeighborhoods (E : Type) [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {F M : Type} [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [FiniteDimensional ℝ E] [T2Space M] {P : Set M}
+    {f : M → F} {W : Set M} (hP : P.Finite) (hf : ∀ x ∈ P, ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, F) ∞ f x)
+    (hz : ∀ x ∈ P, f x = 0) (hA : ∀ x ∈ P, (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, F) f x).IsInvertible)
+    (hW : ∀ x ∈ P, W ∈ 𝓝 x) : Nonempty (SeparatedNeighborhoods E P f W) := by
+  classical
+  obtain ⟨U, hU, hdisj⟩ := hP.t2_separation
+  have hex (x : P) :
+    ∃ L : E ≃L[ℝ] F,
+      L.toContinuousLinearMap =
+          fderiv ℝ (f ∘ Smale.NativeParametrization.centered (D := E) (x : M)) 0 ∧
+        Nonempty
+          (NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) (x : M)) L
+            ((Smale.NativeParametrization.centered (D := E) (x : M)).source ∩
+              Smale.NativeParametrization.centered (D := E) (x : M) ⁻¹' (W ∩ U x))) :=
+    exists_native_neighborhoodData (x : M) (hf x x.property) (hz x x.property) (hA x x.property)
+      (W ∩ U x) (Filter.inter_mem (hW x x.property) ((hU x).2.mem_nhds (hU x).1))
+  choose L hL hD using hex
+  let D (x : P) :
+    NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) (x : M)) (L x)
+      ((Smale.NativeParametrization.centered (D := E) (x : M)).source ∩
+        Smale.NativeParametrization.centered (D := E) (x : M) ⁻¹' (W ∩ U x)) :=
+    Classical.choice (hD x)
+  let D' (x : P) :
+    NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) (x : M)) (L x)
+      ((Smale.NativeParametrization.centered (D := E) (x : M)).source ∩
+        Smale.NativeParametrization.centered (D := E) (x : M) ⁻¹' W) :=
+    { D x with ball_subset := fun u hu => ⟨((D x).ball_subset hu).1, ((D x).ball_subset hu).2.1⟩ }
+  refine ⟨⟨L, hL, D', ?_⟩⟩
+  intro x y hxy
+  change
+    Disjoint (NativeNeighborhood.openSet (x : M) (D x)) (NativeNeighborhood.openSet (y : M) (D y))
+  apply (hdisj x.property y.property (fun h => hxy (Subtype.ext h))).mono
+  · exact (NativeNeighborhood.openSet_subset (x : M) (D x)).trans Set.inter_subset_right
+  · exact (NativeNeighborhood.openSet_subset (y : M) (D y)).trans Set.inter_subset_right
+
+private def
+    Smale.LocalDegree.SeparatedNeighborhoods.neighborhood {E F M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {P : Set M} {f : M → F} {W : Set M}
+    (D : Smale.LocalDegree.SeparatedNeighborhoods E P f W) (x : P) : Set M :=
+  Smale.LocalDegree.NativeNeighborhood.openSet (x : M) (D.data x)
+
+private theorem Smale.LocalDegree.SeparatedNeighborhoods.isOpen_neighborhood {E F M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {P : Set M} {f : M → F}
+    {W : Set M} (D : Smale.LocalDegree.SeparatedNeighborhoods E P f W) (x : P) :
+    IsOpen (D.neighborhood x) :=
+  Smale.LocalDegree.NativeNeighborhood.isOpen_openSet (x : M) (D.data x)
+
+private theorem Smale.LocalDegree.SeparatedNeighborhoods.center_mem_neighborhood {E F M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {P : Set M} {f : M → F}
+    {W : Set M} (D : Smale.LocalDegree.SeparatedNeighborhoods E P f W) (x : P) :
+    (x : M) ∈ D.neighborhood x :=
+  Smale.LocalDegree.NativeNeighborhood.center_mem_openSet (x : M) (D.data x)
+
+private theorem Smale.LocalDegree.SeparatedNeighborhoods.neighborhood_subset {E F M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {P : Set M} {f : M → F}
+    {W : Set M} (D : Smale.LocalDegree.SeparatedNeighborhoods E P f W) (x : P) :
+    D.neighborhood x ⊆ W :=
+  Smale.LocalDegree.NativeNeighborhood.openSet_subset (x : M) (D.data x)
+
+private theorem Smale.LocalDegree.SeparatedNeighborhoods.pairwise_disjoint {E F M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {P : Set M} {f : M → F}
+    {W : Set M} (D : Smale.LocalDegree.SeparatedNeighborhoods E P f W) :
+    Pairwise (Disjoint on D.neighborhood) :=
+  D.disjoint
+
+private theorem Smale.LocalDegree.SeparatedNeighborhoods.points_inter_neighborhood {E F M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {P : Set M} {f : M → F}
+    {W : Set M} (D : Smale.LocalDegree.SeparatedNeighborhoods E P f W) (x : P) :
+    P ∩ D.neighborhood x = {(x : M)} := by
+  ext y
+  constructor
+  · rintro ⟨hyP, hy⟩
+    change y = (x : M)
+    by_contra hne
+    let z : P := ⟨y, hyP⟩
+    have hxz : x ≠ z := fun h => hne (congrArg Subtype.val h).symm
+    exact Set.disjoint_left.mp (D.pairwise_disjoint hxz) hy (D.center_mem_neighborhood z)
+  · rintro rfl
+    exact ⟨x.property, D.center_mem_neighborhood x⟩
+
+private theorem
+    Smale.LocalDegree.SeparatedNeighborhoods.overlap_eq {E F M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {P : Set M} {f : M → F} {W : Set M}
+    (D : Smale.LocalDegree.SeparatedNeighborhoods E P f W) (x : P) :
+    Pᶜ ∩ D.neighborhood x = {(x : M)}ᶜ ∩ D.neighborhood x := by
+  ext y
+  constructor
+  · rintro ⟨hyP, hy⟩
+    refine ⟨?_, hy⟩
+    rintro rfl
+    exact hyP x.property
+  · rintro ⟨hyx, hy⟩
+    refine ⟨?_, hy⟩
+    intro hyP
+    have h : y ∈ P ∩ D.neighborhood x := ⟨hyP, hy⟩
+    rw [D.points_inter_neighborhood x] at h
+    exact hyx h
+
+private theorem
+    Smale.LocalDegree.SeparatedNeighborhoods.open_cover {E F M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {P : Set M} {f : M → F} {W : Set M}
+    (D : Smale.LocalDegree.SeparatedNeighborhoods E P f W) :
+    Pᶜ ∪ (⋃ x : P, D.neighborhood x) = Set.univ := by
+  apply Set.eq_univ_of_forall
+  intro y
+  by_cases hy : y ∈ P
+  · exact Or.inr (Set.mem_iUnion.mpr ⟨⟨y, hy⟩, D.center_mem_neighborhood ⟨y, hy⟩⟩)
+  · exact Or.inl hy
+
+private def Smale.LocalDegree.SeparatedNeighborhoods.overlapSphereEquiv {E F M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {P : Set M} {f : M → F}
+    {W : Set M} (D : Smale.LocalDegree.SeparatedNeighborhoods E P f W) (x : P) :
+    Metric.sphere (0 : E) 1 ≃ₕ ↥(Pᶜ ∩ D.neighborhood x) :=
+  (Smale.LocalDegree.NativeNeighborhood.overlapSphereEquiv (x : M) (D.data x)).trans
+    (Homeomorph.setCongr (D.overlap_eq x).symm).toHomotopyEquiv
+
+private theorem Smale.LocalDegree.SeparatedNeighborhoods.overlapSphereEquiv_apply {E F M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {P : Set M} {f : M → F}
+    {W : Set M} (D : Smale.LocalDegree.SeparatedNeighborhoods E P f W) (x : P)
+    (u : Metric.sphere (0 : E) 1) :
+    (D.overlapSphereEquiv x u).val =
+      Smale.NativeParametrization.centered (x : M) ((D.data x).innerBoundary.radius • (u : E)) :=
+  rfl
+
+private def Smale.LocalDegree.NeighborhoodData.puncturedMap {E F : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F} {L : E ≃L[ℝ] F}
+    {s : Set E} (d : Smale.LocalDegree.NeighborhoodData f L s) :
+    C(Smale.PuncturedBall.Space E d.radius, Smale.PuncturedRadial.Space F) :=
+  ⟨fun x => ⟨f x.val, d.image_ne_zero (mem_closedBall_zero_iff.mpr x.property.2.le) x.property.1⟩,
+    (d.continuous.comp_continuous continuous_subtype_val
+          (fun x => mem_closedBall_zero_iff.mpr x.property.2.le)).subtype_mk
+      _⟩
+
+private def Smale.LocalDegree.NativeNeighborhood.overlapMap {E F : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {M : Type} [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x : M) {f : M → F} {L : E ≃L[ℝ] F} {W : Set M}
+    (d :
+      Smale.LocalDegree.NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) x) L
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' W)) :
+    C(↥({ x }ᶜ ∩ openSet x d), Smale.PuncturedRadial.Space F) :=
+  d.puncturedMap.comp (puncturedHomeomorph x d).symm.toHomotopyEquiv.toFun
+
+private theorem
+    Smale.LocalDegree.NativeNeighborhood.overlapMap_coe {E F : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {M : Type} [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x : M) {f : M → F} {L : E ≃L[ℝ] F} {W : Set M}
+    (d :
+      Smale.LocalDegree.NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) x) L
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' W))
+    (y : ↥({ x }ᶜ ∩ openSet x d)) : (overlapMap x d y).val = f y.val := by
+  have h := congrArg Subtype.val ((puncturedHomeomorph x d).apply_symm_apply y)
+  change
+    Smale.NativeParametrization.centered x ((puncturedHomeomorph x d).symm y).val = y.val at h
+  exact congrArg f h
+
+private def
+    Smale.LocalDegree.SeparatedNeighborhoods.overlapMap {E F M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {P : Set M} {f : M → F} {W : Set M}
+    (D : Smale.LocalDegree.SeparatedNeighborhoods E P f W) (x : P) :
+    C(↥(Pᶜ ∩ D.neighborhood x), Smale.PuncturedRadial.Space F) :=
+  (Smale.LocalDegree.NativeNeighborhood.overlapMap (x : M) (D.data x)).comp
+    (Homeomorph.setCongr (D.overlap_eq x)).toHomotopyEquiv.toFun
+
+private theorem Smale.LocalDegree.SeparatedNeighborhoods.overlapMap_coe {E F M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {P : Set M} {f : M → F}
+    {W : Set M} (D : Smale.LocalDegree.SeparatedNeighborhoods E P f W) (x : P)
+    (y : ↥(Pᶜ ∩ D.neighborhood x)) : (D.overlapMap x y).val = f y.val :=
+  Smale.LocalDegree.NativeNeighborhood.overlapMap_coe (x : M) (D.data x) _
+
+private theorem Smale.LocalDegree.SeparatedNeighborhoods.overlapMap_sphereEquiv {E F M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {P : Set M} {f : M → F}
+    {W : Set M} (D : Smale.LocalDegree.SeparatedNeighborhoods E P f W) (x : P) :
+    (D.overlapMap x).comp (D.overlapSphereEquiv x).toFun = (D.data x).innerBoundary.map := by
+  apply ContinuousMap.ext
+  intro u
+  apply Subtype.ext
+  rw [ContinuousMap.comp_apply, overlapMap_coe, overlapSphereEquiv_apply,
+    Smale.LocalDegree.BoundaryData.map_coe]
+  rfl
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    Smale.ManifoldMorse.MorseSurgeryData.beltFaceCoordinates {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) :
+    Smale.PuncturedHandle.UnitBall d.chart.NegativeCoordinates ≃ₜ
+      Smale.PuncturedHandle.UnitBall d.chart.NegativeCoordinates :=
+  (Smale.MorseHandle.unitBallHomeomorph d.chart.NegativeCoordinates).trans
+    (Smale.MorseHandle.beltFaceDiskHomeomorph.trans
+      (Smale.MorseHandle.unitBallHomeomorph d.chart.NegativeCoordinates).symm)
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    Smale.ManifoldMorse.MorseSurgeryData.beltClosedDiskPoint {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (z :
+      Smale.PuncturedHandle.UnitBall d.chart.NegativeCoordinates ×
+        Smale.PuncturedHandle.UnitSphere d.chart.PositiveCoordinates) :
+    d.chart.beltSource d.radius d.radius_pos :=
+  ⟨(z.2, z.1.val),
+    d.chart.enlarged_closed_belt_subset_source d.radius d.radius_pos d.block
+      ⟨Set.mem_univ _, mem_closedBall_zero_iff.mpr (z.1.property.trans (by norm_num))⟩⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    Smale.ManifoldMorse.MorseSurgeryData.beltClosedDiskMap {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) :
+    C(Smale.PuncturedHandle.UnitBall d.chart.NegativeCoordinates ×
+        Smale.PuncturedHandle.UnitSphere d.chart.PositiveCoordinates,
+      d.UpperLevel)
+    where
+  toFun
+    z := (d.chart.beltNeighborhoodHomeomorph d.radius d.radius_pos (d.beltClosedDiskPoint z)).val
+  continuous_toFun := by
+    have hc : Continuous d.beltClosedDiskPoint :=
+      (continuous_snd.prodMk (continuous_subtype_val.comp continuous_fst)).subtype_mk _
+    exact
+      continuous_subtype_val.comp
+        ((d.chart.beltNeighborhoodHomeomorph d.radius d.radius_pos).continuous.comp hc)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.newPiece_beltFaceCoordinates {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (u : Smale.PuncturedHandle.UnitBall d.chart.NegativeCoordinates)
+    (v : Smale.PuncturedHandle.UnitSphere d.chart.PositiveCoordinates) :
+    d.surgery.newPiece (d.beltFaceCoordinates u, v) = d.beltClosedDiskMap (u, v) := by
+  let ud := Smale.MorseHandle.unitBallHomeomorph d.chart.NegativeCoordinates u
+  let vd : Smale.MorseHandle.UnitDisk d.chart.PositiveCoordinates :=
+    ⟨v.val, mem_closedBall_zero_iff.mpr (mem_sphere_zero_iff_norm.mp v.property).le⟩
+  have hv : ‖vd.val‖ = 1 := mem_sphere_zero_iff_norm.mp v.property
+  let z := (Smale.MorseHandle.beltFaceDiskMap ud, vd)
+  let x :
+    ↥({x : M | f x ≤ f p - d.radius ^ 2} ∪
+        Set.range (d.chart.attachingHandleMap d.radius d.radius_pos d.block)) :=
+    ⟨d.chart.attachingHandleMap d.radius d.radius_pos d.block z, Or.inr ⟨z, rfl⟩⟩
+  have hnew :
+    (d.surgery.newPiece (d.beltFaceCoordinates u, v) : M) = (d.attachmentHomeomorph x).val :=
+    d.newPiece_eq _
+  have hfront :
+    x.val ∈
+      frontier
+        ({y | f y ≤ f p - d.radius ^ 2} ∪
+          Set.range (d.chart.attachingHandleMap d.radius d.radius_pos d.block)) := by
+    apply (d.attachment_frontier x).mp
+    rw [← hnew]
+    exact (d.surgery.newPiece (d.beltFaceCoordinates u, v)).property
+  have htgt := d.block (Smale.MorseHandle.modelMap_mem_product d.radius_pos z)
+  have hsource : x.val ∈ d.chart.splitChart.source := d.chart.splitChart.map_target' htgt
+  have hcoords : d.chart.splitChart x.val = Smale.MorseHandle.modelMap d.radius z :=
+    d.chart.splitChart.right_inv' htgt
+  have hend :
+    Smale.MorseHandle.descentFlow (-Smale.MorseHandle.beltFaceTime ‖ud.val‖)
+        (d.chart.splitChart x.val) =
+      Smale.MorseHandle.beltLevelModel d.radius ud.val vd.val := by
+    rw [hcoords]
+    exact Smale.MorseHandle.descentFlow_neg_beltFaceTime d.radius ud vd hv
+  have hpath :
+    ∀ s ∈ Set.uIcc 0 (-Smale.MorseHandle.beltFaceTime ‖ud.val‖),
+      Smale.MorseHandle.descentFlow s (d.chart.splitChart x.val) ∈
+        Metric.closedBall (0 : d.chart.NegativeCoordinates) (2 * d.radius) ×ˢ
+          Metric.closedBall (0 : d.chart.PositiveCoordinates) (2 * d.radius) := by
+    intro s hs
+    rw [hcoords]
+    exact Smale.MorseHandle.descentFlow_positiveFace_mem_block d.radius_pos ud vd hv hs
+  have hlevel :
+    f
+        (d.chart.splitChart.symm
+          (Smale.MorseHandle.descentFlow (-Smale.MorseHandle.beltFaceTime ‖ud.val‖)
+            (d.chart.splitChart x.val))) =
+      f p + d.radius ^ 2 := by
+    rw [d.chart.splitChart_inverse_equation (d.block (hpath _ Set.right_mem_uIcc)), hend]
+    have hh := Smale.MorseHandle.beltLevelModel_height d.radius_pos ud.val hv
+    change
+      -‖(Smale.MorseHandle.beltLevelModel d.radius ud.val vd.val).1‖ ^ 2 +
+          ‖(Smale.MorseHandle.beltLevelModel d.radius ud.val vd.val).2‖ ^ 2 =
+        d.radius ^ 2 at hh
+    linarith
+  have horbit :=
+    d.attachment_model_orbits x hfront hsource (-Smale.MorseHandle.beltFaceTime ‖ud.val‖)
+      (neg_nonpos.mpr (Smale.MorseHandle.beltFaceTime_nonneg _)) hpath hlevel
+  apply Subtype.ext
+  rw [hnew, horbit, hend]
+  rfl
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.range_newPiece_eq_range_beltClosedDiskMap
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) :
+    Set.range d.surgery.newPiece = Set.range d.beltClosedDiskMap := by
+  ext y
+  constructor
+  · rintro ⟨⟨u, v⟩, rfl⟩
+    refine ⟨(d.beltFaceCoordinates.symm u, v), ?_⟩
+    rw [← d.newPiece_beltFaceCoordinates, d.beltFaceCoordinates.apply_symm_apply]
+  · rintro ⟨⟨u, v⟩, rfl⟩
+    exact ⟨(d.beltFaceCoordinates u, v), d.newPiece_beltFaceCoordinates u v⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.beltClosedDiskMap_mem_newInterior_iff {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (z :
+      Smale.PuncturedHandle.UnitBall d.chart.NegativeCoordinates ×
+        Smale.PuncturedHandle.UnitSphere d.chart.PositiveCoordinates) :
+    d.beltClosedDiskMap z ∈ d.surgery.NewInterior ↔ ‖z.1.val‖ < 1 := by
+  rw [← d.newPiece_beltFaceCoordinates z.1 z.2, d.surgery.newPiece_mem_newInterior_iff]
+  exact Smale.MorseHandle.norm_beltFaceMap_lt_one_iff z.1.val
+
+private theorem Smale.MorseHandle.contDiff_beltFaceMap {N : Type*} [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] : ContDiff ℝ ∞ (beltFaceMap (N := N)) := by
+  have hs : ContDiff ℝ ∞ (fun u : N => Real.sqrt (1 + ‖u‖ ^ 2) / Real.sqrt 2) :=
+    ((contDiff_const.add (contDiff_norm_sq ℝ)).sqrt (fun u => by positivity)).div_const _
+  exact hs.smul contDiff_id
+
+private theorem Smale.MorseHandle.hasFDerivAt_beltFaceMap_zero {N : Type*} [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] :
+    HasFDerivAt (beltFaceMap (N := N)) ((Real.sqrt 2)⁻¹ • ContinuousLinearMap.id ℝ N) 0 := by
+  have hs : ContDiff ℝ ∞ (fun u : N => Real.sqrt (1 + ‖u‖ ^ 2) / Real.sqrt 2) :=
+    ((contDiff_const.add (contDiff_norm_sq ℝ)).sqrt (fun u => by positivity)).div_const _
+  have hd := (hs.differentiable (by simp) (0 : N)).hasFDerivAt.smul (hasFDerivAt_id (0 : N))
+  change HasFDerivAt (fun u : N => (Real.sqrt (1 + ‖u‖ ^ 2) / Real.sqrt 2) • u) _ 0
+  simpa [Pi.smul_def'] using hd
+
+private theorem
+    Smale.MorseHandle.hasFDerivAt_univUnitBall_symm_zero {N : Type*} [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] :
+    HasFDerivAt (OpenPartialHomeomorph.univUnitBall.symm : N → N) (ContinuousLinearMap.id ℝ N)
+      0 := by
+  have hs : ContDiffAt ℝ ∞ (fun u : N => (Real.sqrt (1 - ‖u‖ ^ 2))⁻¹) 0 := by
+    apply ContDiffAt.inv
+    · exact ((contDiff_const.sub (contDiff_norm_sq ℝ)).contDiffAt.sqrt (by simp))
+    · simp
+  have hd := (hs.differentiableAt (by simp)).hasFDerivAt.smul (hasFDerivAt_id (0 : N))
+  change HasFDerivAt (fun u : N => (Real.sqrt (1 - ‖u‖ ^ 2))⁻¹ • u) (ContinuousLinearMap.id ℝ N) 0
+  simpa [Pi.smul_def'] using hd
+
+private def Smale.MorseHandle.beltCollapseCoordinate {N : Type*} [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] (u : N) : N :=
+  OpenPartialHomeomorph.univUnitBall.symm (beltFaceMap u)
+
+private theorem Smale.MorseHandle.beltCollapseCoordinate_zero {N : Type*} [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] : beltCollapseCoordinate (0 : N) = 0 := by
+  rw [beltCollapseCoordinate, beltFaceMap_zero,
+    OpenPartialHomeomorph.univUnitBall_symm_apply_zero]
+
+private theorem
+    Smale.MorseHandle.contDiffOn_beltCollapseCoordinate {N : Type*} [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] :
+    ContDiffOn ℝ ∞ (beltCollapseCoordinate (N := N)) (Metric.ball 0 1) := by
+  apply OpenPartialHomeomorph.contDiffOn_univUnitBall_symm.comp contDiff_beltFaceMap.contDiffOn
+  intro u hu
+  exact mem_ball_zero_iff.mpr ((norm_beltFaceMap_lt_one_iff u).mpr (mem_ball_zero_iff.mp hu))
+
+private theorem Smale.MorseHandle.hasFDerivAt_beltCollapseCoordinate_zero {N : Type*}
+    [NormedAddCommGroup N] [InnerProductSpace ℝ N] :
+    HasFDerivAt (beltCollapseCoordinate (N := N)) ((Real.sqrt 2)⁻¹ • ContinuousLinearMap.id ℝ N)
+      0 := by
+  have hout :
+    HasFDerivAt (OpenPartialHomeomorph.univUnitBall.symm : N → N) (ContinuousLinearMap.id ℝ N)
+      (beltFaceMap 0) := by
+    rw [beltFaceMap_zero]
+    exact hasFDerivAt_univUnitBall_symm_zero
+  change HasFDerivAt ((OpenPartialHomeomorph.univUnitBall.symm : N → N) ∘ beltFaceMap) _ 0
+  simpa only [ContinuousLinearMap.id_comp] using hout.comp 0 hasFDerivAt_beltFaceMap_zero
+
+private theorem Smale.MorseHandle.hasFDerivAt_scaled_beltCollapseCoordinate_zero {N : Type*}
+    [NormedAddCommGroup N] [InnerProductSpace ℝ N] (ρ : ℝ) :
+    HasFDerivAt (fun u : N => beltCollapseCoordinate (ρ⁻¹ • u))
+      (((Real.sqrt 2)⁻¹ * ρ⁻¹) • ContinuousLinearMap.id ℝ N) 0 := by
+  have hout :
+    HasFDerivAt (beltCollapseCoordinate (N := N)) ((Real.sqrt 2)⁻¹ • ContinuousLinearMap.id ℝ N)
+      (ρ⁻¹ • (0 : N)) := by
+    simpa only [smul_zero] using hasFDerivAt_beltCollapseCoordinate_zero (N := N)
+  simpa only [Function.comp_def, ContinuousLinearMap.smul_comp, ContinuousLinearMap.comp_smul,
+    ContinuousLinearMap.id_comp, smul_smul, mul_comm] using
+    hout.comp 0 ((hasFDerivAt_id (0 : N)).const_smul ρ⁻¹)
+
+private theorem Smale.MorseHandle.scaled_beltCollapseCoordinate_factor_pos (ρ : ℝ) (hρ : 0 < ρ) :
+    0 < (Real.sqrt 2)⁻¹ * ρ⁻¹ := by positivity
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.beltNormal_beltClosedDiskMap {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (z :
+      Smale.PuncturedHandle.UnitBall d.chart.NegativeCoordinates ×
+        Smale.PuncturedHandle.UnitSphere d.chart.PositiveCoordinates) :
+    d.beltNormal (d.beltClosedDiskMap z) = d.radius • z.1.val :=
+  d.chart.beltNeighborhoodHomeomorph_normal d.radius d.radius_pos (d.beltClosedDiskPoint z)
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.MorseSurgeryData.collapseNormal {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (x : d.UpperLevel) :
+    d.chart.NegativeCoordinates :=
+  Smale.MorseHandle.beltCollapseCoordinate (d.radius⁻¹ • d.beltNormal x)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.collapseNormal_belt {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (v : Smale.PuncturedHandle.UnitSphere d.chart.PositiveCoordinates) :
+    d.collapseNormal (d.surgery.beltSphere v) = 0 := by
+  rw [collapseNormal, d.beltNormal_belt, smul_zero, Smale.MorseHandle.beltCollapseCoordinate_zero]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.levelCollapse_beltClosedDiskMap {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) [T2Space M] (hf : Continuous f)
+    (z :
+      Smale.PuncturedHandle.UnitBall d.chart.NegativeCoordinates ×
+        Smale.PuncturedHandle.UnitSphere d.chart.PositiveCoordinates) :
+    d.levelCollapseMap hf (d.beltClosedDiskMap z) =
+      Smale.DiskOnePointCollapse.collapse
+        (Smale.MorseHandle.beltFaceDiskMap
+          (Smale.MorseHandle.unitBallHomeomorph d.chart.NegativeCoordinates z.1)) := by
+  rw [← d.newPiece_beltFaceCoordinates z.1 z.2, d.levelCollapse_newPiece]
+  rfl
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.levelCollapse_eq_coe_collapseNormal {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) [T2Space M] (hf : Continuous f)
+    {x : d.UpperLevel} (hx : x ∈ d.surgery.NewInterior) :
+    d.levelCollapseMap hf x = (d.collapseNormal x : OnePoint d.chart.NegativeCoordinates) := by
+  have hr := d.surgery.newInterior_subset_range hx
+  rw [d.range_newPiece_eq_range_beltClosedDiskMap] at hr
+  obtain ⟨z, rfl⟩ := hr
+  have hz := (d.beltClosedDiskMap_mem_newInterior_iff z).mp hx
+  rw [d.levelCollapse_beltClosedDiskMap,
+    Smale.DiskOnePointCollapse.collapse_interior _
+      ((Smale.MorseHandle.norm_beltFaceMap_lt_one_iff z.1.val).mpr hz)]
+  unfold collapseNormal
+  rw [d.beltNormal_beltClosedDiskMap, smul_smul, inv_mul_cancel₀ d.radius_pos.ne', one_smul]
+  rfl
+
+private theorem Smale.SphereNormalCoordinates.normalDerivative_smul_isInvertible {N : Type*}
+    [NormedAddCommGroup N] [NormedSpace ℝ N] {n : ℕ} (A : EuclideanSpace ℝ (Fin n) →L[ℝ] N)
+    (hA : A.IsInvertible) (c : ℝ) (hc : c ≠ 0) : (c • A).IsInvertible := by
+  apply ContinuousLinearMap.IsInvertible.of_inverse (g := c⁻¹ • A.inverse)
+  · ext y
+    simp [ContinuousLinearMap.comp_apply, smul_smul, hA.self_apply_inverse, hc]
+  · ext y
+    simp [ContinuousLinearMap.comp_apply, smul_smul, hA.inverse_apply_self, hc]
+
+private theorem Smale.SphereNormalCoordinates.normalJacobian_smul_mul_pow {V N : Type*}
+    [NormedAddCommGroup V] [InnerProductSpace ℝ V] [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [FiniteDimensional ℝ N] {n : ℕ} [Fact (Module.finrank ℝ V = n + 1)] (j : (ℝ × N) ≃L[ℝ] V)
+    (x : Metric.sphere (0 : V) 1) (A : EuclideanSpace ℝ (Fin n) →L[ℝ] N) (hA : A.IsInvertible)
+    (c : ℝ) (hc : c ≠ 0) :
+    normalJacobian j x (c • A) * c ^ Module.finrank ℝ N = normalJacobian j x A := by
+  have hB := normalDerivative_smul_isInvertible A hA c hc
+  have hcomp : A.comp A.inverse = ContinuousLinearMap.id ℝ N := by
+    ext y
+    exact hA.self_apply_inverse y
+  have hdet : ((c • A).comp A.inverse).det = c ^ Module.finrank ℝ N := by
+    rw [ContinuousLinearMap.smul_comp, hcomp]
+    change (c • (LinearMap.id : N →ₗ[ℝ] N)).det = _
+    rw [LinearMap.det_smul, LinearMap.det_id, mul_one]
+  have hid : (A.comp A.inverse).det = 1 := by
+    rw [hcomp]
+    exact LinearMap.det_id
+  have h :=
+    (normalJacobian_mul_chartDet j x (c • A) hB A.inverse).trans
+      (normalJacobian_mul_chartDet j x A hA A.inverse).symm
+  simpa only [hdet, hid, mul_one] using h
+
+private theorem Smale.SphereNormalCoordinates.sign_normalJacobian_smul_pos {V N : Type*}
+    [NormedAddCommGroup V] [InnerProductSpace ℝ V] [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [FiniteDimensional ℝ N] {n : ℕ} [Fact (Module.finrank ℝ V = n + 1)] (j : (ℝ × N) ≃L[ℝ] V)
+    (x : Metric.sphere (0 : V) 1) (A : EuclideanSpace ℝ (Fin n) →L[ℝ] N) (hA : A.IsInvertible)
+    (c : ℝ) (hc : 0 < c) :
+    SignType.sign (normalJacobian j x (c • A)) = SignType.sign (normalJacobian j x A) := by
+  have h := congrArg SignType.sign (normalJacobian_smul_mul_pow j x A hA c hc.ne')
+  have hp : SignType.sign (c ^ Module.finrank ℝ N) = 1 := sign_eq_one_iff.mpr (pow_pos hc _)
+  simpa only [sign_mul, hp, mul_one] using h
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.mfderiv_collapseNormal_comp {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (m : ℕ)
+    (g : Smale.Hemisphere.Sphere m → d.UpperLevel) (x : Smale.Hemisphere.Sphere m)
+    (hg : MDifferentiableAt (𝓡 m) 𝓘(ℝ, d.chart.NegativeCoordinates) (d.beltNormal ∘ g) x)
+    (hx : g x ∈ Set.range d.surgery.beltSphere) :
+    mfderiv (𝓡 m) 𝓘(ℝ, d.chart.NegativeCoordinates) (d.collapseNormal ∘ g) x =
+      ((Real.sqrt 2)⁻¹ * d.radius⁻¹) •
+        mfderiv (𝓡 m) 𝓘(ℝ, d.chart.NegativeCoordinates) (d.beltNormal ∘ g) x := by
+  obtain ⟨v, hv⟩ := hx
+  have hzero : (d.beltNormal ∘ g) x = 0 := by
+    change d.beltNormal (g x) = 0
+    rw [← hv, d.beltNormal_belt]
+  have hout :
+    HasFDerivAt
+      (fun u : d.chart.NegativeCoordinates =>
+        Smale.MorseHandle.beltCollapseCoordinate (d.radius⁻¹ • u))
+      (((Real.sqrt 2)⁻¹ * d.radius⁻¹) • ContinuousLinearMap.id ℝ _) ((d.beltNormal ∘ g) x) := by
+    rw [hzero]
+    exact Smale.MorseHandle.hasFDerivAt_scaled_beltCollapseCoordinate_zero d.radius
+  have h := (hout.hasMFDerivAt.comp x hg.hasMFDerivAt).mfderiv
+  change mfderiv (𝓡 m) 𝓘(ℝ, d.chart.NegativeCoordinates) (d.collapseNormal ∘ g) x = _ at h
+  apply h.trans
+  apply ContinuousLinearMap.ext
+  intro u
+  rfl
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.collapseNormal_comp_sign {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (m : ℕ)
+    (j : (ℝ × d.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient (m + 1))
+    (g : Smale.Hemisphere.Sphere m → d.UpperLevel) (x : Smale.Hemisphere.Sphere m)
+    (hA : (mfderiv (𝓡 m) 𝓘(ℝ, d.chart.NegativeCoordinates) (d.beltNormal ∘ g) x).IsInvertible)
+    (hx : g x ∈ Set.range d.surgery.beltSphere) :
+    letI : Fact (Module.finrank ℝ (Smale.Hemisphere.Ambient (m + 1)) = m + 1) :=
+      ⟨finrank_euclideanSpace_fin⟩
+    SignType.sign
+        (Smale.SphereNormalCoordinates.normalJacobian j x
+          (mfderiv (𝓡 m) 𝓘(ℝ, d.chart.NegativeCoordinates) (d.collapseNormal ∘ g) x)) =
+      d.beltIntersectionSign m j g x := by
+  let _ : Fact (Module.finrank ℝ (Smale.Hemisphere.Ambient (m + 1)) = m + 1) :=
+    ⟨finrank_euclideanSpace_fin⟩
+  rw [d.mfderiv_collapseNormal_comp m g x (mdifferentiableAt_of_isInvertible_mfderiv hA) hx]
+  exact
+    Smale.SphereNormalCoordinates.sign_normalJacobian_smul_pos j x _ hA _
+      (Smale.MorseHandle.scaled_beltCollapseCoordinate_factor_pos d.radius d.radius_pos)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.collapseNormal_comp_sign_of_transverse {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (n m : ℕ)
+    [Fact (Module.finrank ℝ d.chart.PositiveCoordinates = n + 1)]
+    (hdim : Module.finrank ℝ d.chart.NegativeCoordinates = m)
+    (j : (ℝ × d.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient (m + 1))
+    (g : Smale.Hemisphere.Sphere m → d.UpperLevel) :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    letI : Fact (Module.finrank ℝ (Smale.Hemisphere.Ambient (m + 1)) = m + 1) :=
+      ⟨finrank_euclideanSpace_fin⟩
+    ∀ (_hg : ContMDiff (𝓡 m) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g)
+      (_ht :
+        ∀ x y,
+          Smale.NativeTransversality.At (𝓡 m) (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) g
+            d.surgery.beltSphere x y)
+      (x : Smale.Hemisphere.Sphere m),
+      x ∈ d.beltIntersectionPoints m g →
+        SignType.sign
+            (Smale.SphereNormalCoordinates.normalJacobian j x
+              (mfderiv (𝓡 m) 𝓘(ℝ, d.chart.NegativeCoordinates) (d.collapseNormal ∘ g) x)) =
+          d.beltIntersectionSign m j g x := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  let _ : Fact (Module.finrank ℝ (Smale.Hemisphere.Ambient (m + 1)) = m + 1) :=
+    ⟨finrank_euclideanSpace_fin⟩
+  intro hg ht x hx
+  obtain ⟨v, hv⟩ := hx
+  have hA := d.bijective_beltNormal_comp_of_transverse hf n m hdim g hg x v hv (ht x v hv)
+  let A : EuclideanSpace ℝ (Fin m) →L[ℝ] d.chart.NegativeCoordinates :=
+    mfderiv (𝓡 m) 𝓘(ℝ, d.chart.NegativeCoordinates) (d.beltNormal ∘ g) x
+  have hAi : A.IsInvertible :=
+    ⟨(LinearEquiv.ofBijective A.toLinearMap hA).toContinuousLinearEquiv, rfl⟩
+  exact d.collapseNormal_comp_sign m j g x hAi ⟨v, hv⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.contMDiffAt_collapseNormal_comp {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (m : ℕ)
+    (g : Smale.Hemisphere.Sphere m → d.UpperLevel) :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    ∀ (_hg : ContMDiff (𝓡 m) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g)
+      (x : Smale.Hemisphere.Sphere m),
+      g x ∈ Set.range d.surgery.beltSphere →
+        ContMDiffAt (𝓡 m) 𝓘(ℝ, d.chart.NegativeCoordinates) ∞ (d.collapseNormal ∘ g) x := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  intro hg x hx
+  obtain ⟨v, hv⟩ := hx
+  have hn : ContMDiffAt (𝓡 m) 𝓘(ℝ, d.chart.NegativeCoordinates) ∞ (d.beltNormal ∘ g) x := by
+    have hnormal :=
+      (d.contMDiffOn_beltNormal hf).contMDiffAt
+        (d.isOpen_beltNormalDomain.mem_nhds (d.belt_mem_normalDomain v))
+    rw [hv] at hnormal
+    exact hnormal.comp x hg.contMDiffAt
+  have hzero : (d.beltNormal ∘ g) x = 0 := by
+    change d.beltNormal (g x) = 0
+    rw [← hv, d.beltNormal_belt]
+  have hq :
+    ContDiffAt ℝ ∞ (Smale.MorseHandle.beltCollapseCoordinate (N := d.chart.NegativeCoordinates))
+      (d.radius⁻¹ • (d.beltNormal ∘ g) x) := by
+    rw [hzero, smul_zero]
+    exact
+      Smale.MorseHandle.contDiffOn_beltCollapseCoordinate.contDiffAt
+        (Metric.isOpen_ball.mem_nhds (by simp))
+  have hs :
+    ContDiffAt ℝ ∞
+      (fun u : d.chart.NegativeCoordinates =>
+        Smale.MorseHandle.beltCollapseCoordinate (d.radius⁻¹ • u))
+      ((d.beltNormal ∘ g) x) :=
+    hq.comp _ (contDiff_id.const_smul d.radius⁻¹).contDiffAt
+  exact hs.contMDiffAt.comp x hn
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.isInvertible_collapseNormal_comp_of_transverse
+    {E M : Type} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (n m : ℕ) [Fact (Module.finrank ℝ d.chart.PositiveCoordinates = n + 1)]
+    (hdim : Module.finrank ℝ d.chart.NegativeCoordinates = m)
+    (g : Smale.Hemisphere.Sphere m → d.UpperLevel) :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    ∀ (_hg : ContMDiff (𝓡 m) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g)
+      (_ht :
+        ∀ x y,
+          Smale.NativeTransversality.At (𝓡 m) (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) g
+            d.surgery.beltSphere x y)
+      (x : Smale.Hemisphere.Sphere m),
+      x ∈ d.beltIntersectionPoints m g →
+        (mfderiv (𝓡 m) 𝓘(ℝ, d.chart.NegativeCoordinates) (d.collapseNormal ∘ g) x).IsInvertible :=
+  by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  intro hg ht x hx
+  obtain ⟨v, hv⟩ := hx
+  have hA := d.bijective_beltNormal_comp_of_transverse hf n m hdim g hg x v hv (ht x v hv)
+  let A : EuclideanSpace ℝ (Fin m) →L[ℝ] d.chart.NegativeCoordinates :=
+    mfderiv (𝓡 m) 𝓘(ℝ, d.chart.NegativeCoordinates) (d.beltNormal ∘ g) x
+  have hAi : A.IsInvertible :=
+    ⟨(LinearEquiv.ofBijective A.toLinearMap hA).toContinuousLinearEquiv, rfl⟩
+  rw [d.mfderiv_collapseNormal_comp m g x (mdifferentiableAt_of_isInvertible_mfderiv hAi) ⟨v, hv⟩]
+  exact
+    Smale.SphereNormalCoordinates.normalDerivative_smul_isInvertible A hAi _
+      (Smale.MorseHandle.scaled_beltCollapseCoordinate_factor_pos d.radius d.radius_pos).ne'
+
+attribute [local instance 100] Classical.propDecidable in
+private abbrev Smale.ManifoldMorse.MorseSurgeryData.CollapseNeighborhoods {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (m : ℕ)
+    (g : Smale.Hemisphere.Sphere m → d.UpperLevel) :=
+  Smale.LocalDegree.SeparatedNeighborhoods (EuclideanSpace ℝ (Fin m))
+    (d.beltIntersectionPoints m g) (d.collapseNormal ∘ g) (g ⁻¹' d.surgery.NewInterior)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.nonempty_collapseNeighborhoods {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) [T2Space M] [CompactSpace M]
+    (n m : ℕ) [Fact (Module.finrank ℝ d.chart.PositiveCoordinates = n + 1)]
+    (hdim : Module.finrank ℝ d.chart.NegativeCoordinates = m)
+    (g : Smale.Hemisphere.Sphere m → d.UpperLevel) :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    ∀ (_hg : ContMDiff (𝓡 m) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g) (_hinj : Function.Injective g)
+      (_ht :
+        ∀ x y,
+          Smale.NativeTransversality.At (𝓡 m) (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) g
+            d.surgery.beltSphere x y),
+      Nonempty (d.CollapseNeighborhoods m g) := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  intro hg hinj ht
+  have hfin := d.finite_beltIntersectionPoints hf n m hdim g hg hinj ht
+  apply Smale.LocalDegree.nonempty_separatedNeighborhoods (EuclideanSpace ℝ (Fin m)) hfin
+  · exact fun x hx => d.contMDiffAt_collapseNormal_comp hf m g hg x hx
+  · intro x hx
+    obtain ⟨v, hv⟩ := hx
+    change d.collapseNormal (g x) = 0
+    rw [← hv, d.collapseNormal_belt]
+  · exact fun x hx => d.isInvertible_collapseNormal_comp_of_transverse hf n m hdim g hg ht x hx
+  · intro x hx
+    apply hg.continuous.continuousAt
+    apply d.surgery.isOpen_newInterior.mem_nhds
+    obtain ⟨v, hv⟩ := hx
+    rw [← hv]
+    exact d.surgery.beltSphere_mem_newInterior v
+
+private def Smale.DisjointOpenHomology.inclusion {X : Type} [TopologicalSpace X] {ι : Type}
+    (W : ι → Set X) (i : ι) : C(W i, ↥(⋃ j, W j)) :=
+  ⟨Set.inclusion (Set.subset_iUnion W i), continuous_subtype_val.subtype_mk _⟩
+
+private def Smale.DisjointOpenHomology.unionHomeomorph {X : Type} [TopologicalSpace X] {ι : Type}
+    (W : ι → Set X) (hW : ∀ i, IsOpen (W i)) (hd : Pairwise (Disjoint on W)) :
+    (Σ i, W i) ≃ₜ ↥(⋃ i, W i) :=
+  let e := Equiv.ofBijective (Set.sigmaToiUnion W) (Set.sigmaToiUnion_bijective W hd)
+  e.toHomeomorphOfContinuousOpen
+    (by
+      apply continuous_sigma
+      intro i
+      exact (Smale.DisjointOpenHomology.inclusion W i).continuous)
+    (by
+      apply isOpenMap_sigma.mpr
+      intro i
+      exact (hW i).isOpenMap_inclusion (Set.subset_iUnion W i))
+
+private def Smale.DisjointOpenHomology.homologyEquiv {X : Type} [TopologicalSpace X] {ι : Type}
+    (W : ι → Set X) (hW : ∀ i, IsOpen (W i)) (hd : Pairwise (Disjoint on W)) [Fintype ι] (k : ℕ) :
+    SingularMayerVietoris.SingularHomology (↥(⋃ i, W i)) k ≃ₗ[ℤ]
+      (∀ i, SingularMayerVietoris.SingularHomology (W i) k) :=
+  (PeriodTorusHigherHomology.homeomorphHomologyEquiv (unionHomeomorph W hW hd).symm k).trans
+    (ThreefoldHomologyStarCoproduct.sigmaHomologyEquiv (fun i => W i) k)
+
+private theorem Smale.DisjointOpenHomology.homologyEquiv_symm_apply {X : Type} [TopologicalSpace X]
+    {ι : Type} (W : ι → Set X) (hW : ∀ i, IsOpen (W i)) (hd : Pairwise (Disjoint on W))
+    [Fintype ι] (k : ℕ) (a : ∀ i, SingularMayerVietoris.SingularHomology (W i) k) :
+    (homologyEquiv W hW hd k).symm a =
+      ∑ i,
+        SingularMayerVietoris.singularHomologyMap (Smale.DisjointOpenHomology.inclusion W i) k
+          (a i) := by
+  change
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv (unionHomeomorph W hW hd).symm k).symm
+        ((ThreefoldHomologyStarCoproduct.sigmaHomologyEquiv (fun i => W i) k).symm a) =
+      _
+  rw [PeriodTorusHigherHomology.homeomorphHomologyEquiv_symm_apply, Homeomorph.symm_symm,
+    ThreefoldHomologyStarCoproduct.sigmaHomologyEquiv_symm_apply, map_sum]
+  apply Finset.sum_congr rfl
+  intro i _
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp]
+  rfl
+
+private def Smale.CoverOverlapHomology.componentInclusion {X : Type} [TopologicalSpace X] {ι : Type}
+    (U : Set X) (V : ι → Set X) (i : ι) : C(↥(U ∩ V i), ↥(U ∩ ⋃ j, V j)) :=
+  ⟨fun x => ⟨x.val, ⟨x.property.1, Set.mem_iUnion.mpr ⟨i, x.property.2⟩⟩⟩,
+    continuous_subtype_val.subtype_mk _⟩
+
+private def
+    Smale.CoverOverlapHomology.distributeHomeomorph {X : Type} [TopologicalSpace X] {ι : Type}
+    (U : Set X) (V : ι → Set X) : ↥(U ∩ ⋃ i, V i) ≃ₜ ↥(⋃ i, U ∩ V i) :=
+  Homeomorph.setCongr (by ext x; simp)
+
+private theorem Smale.CoverOverlapHomology.disjoint_intersections {X : Type} {ι : Type} (U : Set X)
+    (V : ι → Set X) (hd : Pairwise (Disjoint on V)) : Pairwise (Disjoint on (fun i => U ∩ V i)) :=
+  by
+  intro i j hij
+  exact (hd hij).mono Set.inter_subset_right Set.inter_subset_right
+
+private def Smale.CoverOverlapHomology.homologyEquiv {X : Type} [TopologicalSpace X] {ι : Type}
+    (U : Set X) (V : ι → Set X) (hU : IsOpen U) (hV : ∀ i, IsOpen (V i))
+    (hd : Pairwise (Disjoint on V)) [Fintype ι] (k : ℕ) :
+    SingularMayerVietoris.SingularHomology (↥(U ∩ ⋃ i, V i)) k ≃ₗ[ℤ]
+      (∀ i, SingularMayerVietoris.SingularHomology (↥(U ∩ V i)) k) :=
+  (PeriodTorusHigherHomology.homeomorphHomologyEquiv (distributeHomeomorph U V) k).trans
+    (Smale.DisjointOpenHomology.homologyEquiv (fun i => U ∩ V i) (fun i => hU.inter (hV i))
+      (disjoint_intersections U V hd) k)
+
+private theorem Smale.CoverOverlapHomology.homologyEquiv_symm_apply {X : Type} [TopologicalSpace X]
+    {ι : Type} (U : Set X) (V : ι → Set X) (hU : IsOpen U) (hV : ∀ i, IsOpen (V i))
+    (hd : Pairwise (Disjoint on V)) [Fintype ι] (k : ℕ)
+    (a : ∀ i, SingularMayerVietoris.SingularHomology (↥(U ∩ V i)) k) :
+    (homologyEquiv U V hU hV hd k).symm a =
+      ∑ i, SingularMayerVietoris.singularHomologyMap (componentInclusion U V i) k (a i) := by
+  change
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv (distributeHomeomorph U V) k).symm
+        ((Smale.DisjointOpenHomology.homologyEquiv (fun i => U ∩ V i) (fun i => hU.inter (hV i))
+              (disjoint_intersections U V hd) k).symm
+          a) =
+      _
+  rw [PeriodTorusHigherHomology.homeomorphHomologyEquiv_symm_apply,
+    Smale.DisjointOpenHomology.homologyEquiv_symm_apply, map_sum]
+  apply Finset.sum_congr rfl
+  intro i _
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp]
+  rfl
+
+private theorem Smale.CoverOverlapHomology.homology_decomposition {X : Type} [TopologicalSpace X]
+    {ι : Type} (U : Set X) (V : ι → Set X) (hU : IsOpen U) (hV : ∀ i, IsOpen (V i))
+    (hd : Pairwise (Disjoint on V)) [Fintype ι] (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (↥(U ∩ ⋃ i, V i)) k) :
+    a =
+      ∑ i,
+        SingularMayerVietoris.singularHomologyMap (componentInclusion U V i) k
+          (homologyEquiv U V hU hV hd k a i) := by
+  have h := homologyEquiv_symm_apply U V hU hV hd k (homologyEquiv U V hU hV hd k a)
+  rwa [LinearEquiv.symm_apply_apply] at h
+
+private theorem
+    Smale.CoverOverlapHomology.homology_map_out {X : Type} [TopologicalSpace X] {ι : Type}
+    (U : Set X) (V : ι → Set X) (hU : IsOpen U) (hV : ∀ i, IsOpen (V i))
+    (hd : Pairwise (Disjoint on V)) [Fintype ι] {Y : Type} [TopologicalSpace Y]
+    (f : C(↥(U ∩ ⋃ i, V i), Y)) (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (↥(U ∩ ⋃ i, V i)) k) :
+    SingularMayerVietoris.singularHomologyMap f k a =
+      ∑ i,
+        SingularMayerVietoris.singularHomologyMap (f.comp (componentInclusion U V i)) k
+          (homologyEquiv U V hU hV hd k a i) := by
+  calc
+    SingularMayerVietoris.singularHomologyMap f k a =
+        SingularMayerVietoris.singularHomologyMap f k
+          (∑ i,
+            SingularMayerVietoris.singularHomologyMap (componentInclusion U V i) k
+              (homologyEquiv U V hU hV hd k a i)) :=
+      congrArg (SingularMayerVietoris.singularHomologyMap f k)
+        (homology_decomposition U V hU hV hd k a)
+    _ = _ := by
+      rw [map_sum]
+      apply Finset.sum_congr rfl
+      intro i _
+      rw [PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply]
+
+private def
+    Smale.CoverLocalContributions.componentConnecting {X : Type} [TopologicalSpace X] {ι : Type}
+    [Fintype ι] (U : Set X) (V : ι → Set X) (hU : IsOpen U) (hV : ∀ i, IsOpen (V i))
+    (hd : Pairwise (Disjoint on V)) (hc : U ∪ (⋃ i, V i) = Set.univ) (k : ℕ) :
+    SingularMayerVietoris.SingularHomology X (k + 1) →ₗ[ℤ]
+      (∀ i, SingularMayerVietoris.SingularHomology (↥(U ∩ V i)) k) :=
+  (Smale.CoverOverlapHomology.homologyEquiv U V hU hV hd k).toLinearMap.comp
+    (SingularMayerVietoris.connectingHomomorphism U (⋃ i, V i) hU (isOpen_iUnion hV) hc k)
+
+private theorem Smale.CoverLocalContributions.map_union {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] {ι : Type} (V : ι → Set X) (V' : Set Y) (f : C(X, Y))
+    (hfV : ∀ i, Set.MapsTo f (V i) V') : Set.MapsTo f (⋃ i, V i) V' := by
+  intro x hx
+  obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hx
+  exact hfV i hi
+
+private def
+    Smale.CoverLocalContributions.localMap {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    {ι : Type} (U : Set X) (V : ι → Set X) (U' V' : Set Y) (f : C(X, Y)) (hfU : Set.MapsTo f U U')
+    (hfV : ∀ i, Set.MapsTo f (V i) V') (i : ι) : C(↥(U ∩ V i), ↥(U' ∩ V')) :=
+  Smale.CoverNaturality.mapOn f _ _ (fun _ hx => ⟨hfU hx.1, hfV i hx.2⟩)
+
+private theorem Smale.CoverLocalContributions.connecting_sum {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] {ι : Type} [Fintype ι] (U : Set X) (V : ι → Set X) (hU : IsOpen U)
+    (hV : ∀ i, IsOpen (V i)) (hd : Pairwise (Disjoint on V)) (hc : U ∪ (⋃ i, V i) = Set.univ)
+    (U' V' : Set Y) (f : C(X, Y)) (hfU : Set.MapsTo f U U') (hfV : ∀ i, Set.MapsTo f (V i) V')
+    (hU' : IsOpen U') (hV' : IsOpen V') (hc' : U' ∪ V' = Set.univ) (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology X (k + 1)) :
+    SingularMayerVietoris.connectingHomomorphism U' V' hU' hV' hc' k
+        (SingularMayerVietoris.singularHomologyMap f (k + 1) a) =
+      ∑ i,
+        SingularMayerVietoris.singularHomologyMap (localMap U V U' V' f hfU hfV i) k
+          (componentConnecting U V hU hV hd hc k a i) := by
+  rw [←
+    Smale.CoverNaturality.connecting_naturality_apply U (⋃ i, V i) U' V' f hfU
+      (map_union V V' f hfV) hU (isOpen_iUnion hV) hc hU' hV' hc' k a]
+  rw [Smale.CoverOverlapHomology.homology_map_out U V hU hV hd]
+  apply Finset.sum_congr rfl
+  intro i _
+  rfl
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    Smale.ManifoldMorse.MorseSurgeryData.attachingCollapse {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f) (m : ℕ)
+    (g : C(Smale.Hemisphere.Sphere m, d.UpperLevel)) :
+    C(Smale.Hemisphere.Sphere m, OnePoint d.chart.NegativeCoordinates) :=
+  (d.levelCollapseMap hf).comp g
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.attachingCollapse_zero_iff {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (m : ℕ) (g : C(Smale.Hemisphere.Sphere m, d.UpperLevel)) (x : Smale.Hemisphere.Sphere m) :
+    d.attachingCollapse hf m g x = ((0 : d.chart.NegativeCoordinates) : OnePoint _) ↔
+      x ∈ d.beltIntersectionPoints m g :=
+  d.levelCollapse_zero_iff hf (g x)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.attachingCollapse_maps_old {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (m : ℕ) (g : C(Smale.Hemisphere.Sphere m, d.UpperLevel)) :
+    Set.MapsTo (d.attachingCollapse hf m g) (d.beltIntersectionPoints m g)ᶜ
+      Smale.OnePointCover.oldPatch := by
+  intro x hx hzero
+  exact hx ((d.attachingCollapse_zero_iff hf m g x).mp hzero)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.attachingCollapse_maps_neighborhood {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (m : ℕ) (g : C(Smale.Hemisphere.Sphere m, d.UpperLevel)) (D : d.CollapseNeighborhoods m g)
+    (i : d.beltIntersectionPoints m g) :
+    Set.MapsTo (d.attachingCollapse hf m g) (D.neighborhood i) Smale.OnePointCover.finitePatch := by
+  intro x hx
+  have hnew : g x ∈ d.surgery.NewInterior := D.neighborhood_subset i hx
+  change d.levelCollapseMap hf (g x) ≠ OnePoint.infty
+  rw [d.levelCollapse_eq_coe_collapseNormal hf hnew]
+  exact OnePoint.coe_ne_infty _
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    Smale.ManifoldMorse.MorseSurgeryData.collapseOverlapMap {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f) (m : ℕ)
+    (g : C(Smale.Hemisphere.Sphere m, d.UpperLevel)) (D : d.CollapseNeighborhoods m g)
+    (i : d.beltIntersectionPoints m g) :
+    C(↥((d.beltIntersectionPoints m g)ᶜ ∩ D.neighborhood i),
+      ↥(Smale.OnePointCover.oldPatch (N := d.chart.NegativeCoordinates) ∩
+          Smale.OnePointCover.finitePatch)) :=
+  Smale.CoverNaturality.mapOn (d.attachingCollapse hf m g) _ _
+    (fun _ hx =>
+      ⟨d.attachingCollapse_maps_old hf m g hx.1,
+        d.attachingCollapse_maps_neighborhood hf m g D i hx.2⟩)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.collapseOverlapMap_eq {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (m : ℕ) (g : C(Smale.Hemisphere.Sphere m, d.UpperLevel)) (D : d.CollapseNeighborhoods m g)
+    (i : d.beltIntersectionPoints m g) :
+    d.collapseOverlapMap hf m g D i =
+      Smale.OnePointCover.overlapHomeomorph.toHomotopyEquiv.toFun.comp (D.overlapMap i) := by
+  apply ContinuousMap.ext
+  intro x
+  apply Subtype.ext
+  change
+    d.levelCollapseMap hf (g x.val) =
+      (Smale.OnePointCover.overlapHomeomorph (D.overlapMap i x)).val
+  rw [Smale.OnePointCover.overlapHomeomorph_apply,
+    Smale.LocalDegree.SeparatedNeighborhoods.overlapMap_coe]
+  exact d.levelCollapse_eq_coe_collapseNormal hf (D.neighborhood_subset i x.property.2)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.collapseOverlapMap_sphereEquiv {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (m : ℕ) (g : C(Smale.Hemisphere.Sphere m, d.UpperLevel)) (D : d.CollapseNeighborhoods m g)
+    (i : d.beltIntersectionPoints m g) :
+    (d.collapseOverlapMap hf m g D i).comp (D.overlapSphereEquiv i).toFun =
+      Smale.OnePointCover.overlapHomeomorph.toHomotopyEquiv.toFun.comp
+        (D.data i).innerBoundary.map := by
+  rw [d.collapseOverlapMap_eq hf m g D i, ContinuousMap.comp_assoc, D.overlapMap_sphereEquiv]
+
+private def
+    Smale.ManifoldMorse.MorseSurgeryData.upperLevelInclusion {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) :
+    C(d.UpperLevel, { y : M // f y ≤ f p + d.radius ^ 2 }) :=
+  ⟨Set.inclusion (fun _ hx => hx.le), continuous_inclusion _⟩
+
+private def Smale.ManifoldMorse.MorseSurgeryData.bandSublevelHomeomorph {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p q : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (d' : Smale.ManifoldMorse.MorseSurgeryData E f q) (T : M ≃ₜ M)
+    (hT : T '' {y : M | f y ≤ f p + d.radius ^ 2} = {y : M | f y ≤ f q - d'.radius ^ 2}) :
+    { y : M // f y ≤ f p + d.radius ^ 2 } ≃ₜ { y : M // f y ≤ f q - d'.radius ^ 2 } :=
+  (T.image {y : M | f y ≤ f p + d.radius ^ 2}).trans (Homeomorph.setCongr hT)
+
+private structure Smale.ManifoldMorse.SurgeryWindows.BandData {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (i j : Fin S.count) where
+  ambient : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞
+  level : (S.data (S.point i)).UpperLevel ≃ₜ (S.data (S.point j)).LowerLevel
+  sublevel_image :
+    ambient '' {x : M | f x ≤ S.upper (S.point i)} = {x : M | f x ≤ S.lower (S.point j)}
+  level_coe : ∀ x : (S.data (S.point i)).UpperLevel, (level x : M) = ambient x
+
+private theorem Smale.ManifoldMorse.SurgeryWindows.nonempty_consecutiveBandData {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (i j : Fin S.count) (hij : i.val + 1 = j.val) : Nonempty (S.BandData i j) := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data (S.point i)).upper_regular
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data (S.point j)).lower_regular
+  obtain ⟨D, b, hD, hb⟩ := S.exists_consecutiveBandBridge hf i j hij
+  exact ⟨⟨D, b.toHomeomorph, hD, hb⟩⟩
+
+private def
+    Smale.ManifoldMorse.SurgeryWindows.consecutiveBandData {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (i j : Fin S.count) (hij : i.val + 1 = j.val) : S.BandData i j :=
+  Classical.choice (S.nonempty_consecutiveBandData hf i j hij)
+
+private def Smale.ManifoldMorse.SurgeryWindows.BandData.sublevelHomeomorph {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {S : Smale.ManifoldMorse.SurgeryWindows E f} {i j : Fin S.count} (D : S.BandData i j) :
+    { x : M // f x ≤ S.upper (S.point i) } ≃ₜ { x : M // f x ≤ S.lower (S.point j) } :=
+  (S.data (S.point i)).bandSublevelHomeomorph (S.data (S.point j)) D.ambient.toHomeomorph
+    D.sublevel_image
+
+private def
+    Smale.ManifoldMorse.SurgeryWindows.BandData.homologyEquiv {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {S : Smale.ManifoldMorse.SurgeryWindows E f} {i j : Fin S.count} (D : S.BandData i j)
+    (k : ℕ) :
+    SingularMayerVietoris.SingularHomology { x : M // f x ≤ S.upper (S.point i) } k ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology { x : M // f x ≤ S.lower (S.point j) } k :=
+  PeriodTorusHigherHomology.homeomorphHomologyEquiv D.sublevelHomeomorph k
+
+private theorem
+    Smale.SublevelDisk.contractibleSpace {M : Type} [TopologicalSpace M] {f : M → ℝ} {a : ℝ}
+    {n : ℕ} (d : Smale.SublevelDisk n f a) : ContractibleSpace { x : M // f x ≤ a } := by
+  let : ContractibleSpace (Smale.Hemisphere.Ball n) :=
+    (convex_closedBall (0 : Smale.Hemisphere.Ambient n) 1).contractibleSpace ⟨0, by simp⟩
+  exact d.homeomorph.symm.contractibleSpace
+
+private theorem Smale.SublevelDisk.homology_subsingleton {M : Type} [TopologicalSpace M] {f : M → ℝ}
+    {a : ℝ} {n : ℕ} (d : Smale.SublevelDisk n f a) (k : ℕ) (hk : k ≠ 0) :
+    Subsingleton (SingularMayerVietoris.SingularHomology { x : M // f x ≤ a } k) := by
+  let := d.contractibleSpace
+  exact PeriodTorusHigherHomology.contractible_homology_subsingleton _ k hk
+
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.lower_homologyOne_subsingleton_of_indices {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (j : Fin S.count) (hj : 0 < j.val)
+    (hindex :
+      ∀ i : Fin S.count,
+        0 < i.val →
+          i.val < j.val → 2 ≤ Module.finrank ℝ (S.data (S.point i)).chart.NegativeCoordinates) :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology { x : M // f x ≤ S.lower (S.point j) } 1) := by
+  have hupper :
+    ∀ n : ℕ,
+      ∀ hn : n < S.count,
+        n < j.val →
+          Subsingleton
+            (SingularMayerVietoris.SingularHomology { x : M // f x ≤ S.upper (S.point ⟨n, hn⟩) }
+              1) := by
+    intro n
+    induction n with
+    | zero =>
+      intro hn _
+      obtain ⟨D⟩ := S.nonempty_firstSublevelDisk hf hn
+      exact D.homology_subsingleton 1 one_ne_zero
+    | succ n ih =>
+      intro hn hnj
+      have hn' : n < S.count := by omega
+      let :
+        Subsingleton
+          (SingularMayerVietoris.SingularHomology
+            { x : M // f x ≤ f (S.point ⟨n, hn'⟩) + (S.data (S.point ⟨n, hn'⟩)).radius ^ 2 } 1) :=
+        ih hn' (by omega)
+      obtain ⟨T, _, hT, _⟩ := S.exists_consecutiveBandBridge hf ⟨n, hn'⟩ ⟨n + 1, hn⟩ rfl
+      let H :=
+        (S.data (S.point ⟨n, hn'⟩)).bandSublevelHomeomorph (S.data (S.point ⟨n + 1, hn⟩))
+          T.toHomeomorph hT
+      let :
+        Subsingleton
+          (SingularMayerVietoris.SingularHomology
+            { x : M // f x ≤ f (S.point ⟨n + 1, hn⟩) - (S.data (S.point ⟨n + 1, hn⟩)).radius ^ 2 }
+            1) :=
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv H.symm 1).injective.subsingleton
+      exact
+        (S.data (S.point ⟨n + 1, hn⟩)).upperHomologyOne_subsingleton hf.continuous
+          (hindex ⟨n + 1, hn⟩ (Nat.succ_pos n) hnj)
+  have hp : j.val - 1 < S.count := by omega
+  let :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology
+        { x : M //
+          f x ≤ f (S.point ⟨j.val - 1, hp⟩) + (S.data (S.point ⟨j.val - 1, hp⟩)).radius ^ 2 }
+        1) :=
+    hupper (j.val - 1) hp (by omega)
+  obtain ⟨T, _, hT, _⟩ :=
+    S.exists_consecutiveBandBridge hf ⟨j.val - 1, hp⟩ j (by change j.val - 1 + 1 = j.val; omega)
+  let H :=
+    (S.data (S.point ⟨j.val - 1, hp⟩)).bandSublevelHomeomorph (S.data (S.point j)) T.toHomeomorph
+      hT
+  exact (PeriodTorusHigherHomology.homeomorphHomologyEquiv H.symm 1).injective.subsingleton
+
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.attachingHomology_subsingleton_of_index {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (k : ℕ) (hk : k ≠ 0)
+    (hindex : 2 ≤ Module.finrank ℝ d.chart.NegativeCoordinates)
+    (hne : Module.finrank ℝ d.chart.NegativeCoordinates ≠ k + 1) :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology (Metric.sphere (0 : d.chart.NegativeCoordinates) 1)
+        k) := by
+  let n := Module.finrank ℝ d.chart.NegativeCoordinates - 2
+  have hn : Module.finrank ℝ d.chart.NegativeCoordinates = (n + 1) + 1 := by
+    dsimp [n]
+    omega
+  let : Fact (Module.finrank ℝ d.chart.NegativeCoordinates = (n + 1) + 1) := ⟨hn⟩
+  let :
+    Subsingleton (SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 1)) k) :=
+    SphereHomology.unitSphere_homology_subsingleton n k hk (by omega)
+  exact
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+        (Smale.SphereCoordinates.standardParametrization d.chart.NegativeCoordinates
+            (n + 1)).symm.toHomeomorph
+        k).injective.subsingleton
+
+private theorem Smale.ManifoldMorse.MorseSurgeryData.lowerHomology_subsingleton_of_upper_and_index
+    {E M : Type} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [T2Space M] {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (hf : Continuous f) (k : ℕ) (hk : k ≠ 0)
+    (hindex : 2 ≤ Module.finrank ℝ d.chart.NegativeCoordinates)
+    (hne : Module.finrank ℝ d.chart.NegativeCoordinates ≠ k + 1)
+    [Subsingleton
+        (SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p + d.radius ^ 2 } k)] :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p - d.radius ^ 2 } k) := by
+  let := d.attachingHomology_subsingleton_of_index k hk hindex hne
+  exact d.lowerHomology_subsingleton_of_upper_and_sphere hf k hk
+
+private def
+    Smale.LinearSphereAction.puncturedMap {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (A : E →L[ℝ] F) (hi : Function.Injective A) :
+    C(Metric.sphere (0 : E) 1, Smale.PuncturedRadial.Space F) :=
+  ⟨fun x => ⟨A x.val, fun h => ne_zero_of_mem_unit_sphere x (hi (h.trans (map_zero A).symm))⟩,
+    (A.continuous.comp continuous_subtype_val).subtype_mk _⟩
+
+private def
+    Smale.LinearSphereAction.sphereMap {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (A : E →L[ℝ] F) (hi : Function.Injective A) :
+    C(Metric.sphere (0 : E) 1, Metric.sphere (0 : F) 1) :=
+  Smale.PuncturedRadial.toSphere.comp (puncturedMap A hi)
+
+private theorem Smale.LinearSphereAction.sphereMap_id {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] :
+    sphereMap (ContinuousLinearMap.id ℝ E) Function.injective_id =
+      ContinuousMap.id (Metric.sphere (0 : E) 1) := by
+  ext x
+  change ‖(x : E)‖⁻¹ • (x : E) = (x : E)
+  rw [mem_sphere_zero_iff_norm.mp x.property, inv_one, one_smul]
+
+private theorem Smale.LinearSphereAction.component_injective {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {signWeight : ℝ}
+    (A : Degree.LinearFramePaths.operatorComponent (D := E) signWeight) :
+    Function.Injective A.val := by
+  have hd : A.val.toLinearMap.det ≠ 0 := by
+    intro hz
+    have hp : 0 < signWeight * A.val.toLinearMap.det := A.property
+    rw [hz, MulZeroClass.mul_zero] at hp
+    exact lt_irrefl _ hp
+  apply LinearMap.ker_eq_bot.mp
+  by_contra hk
+  exact hd (LinearMap.det_eq_zero_iff_ker_ne_bot.mpr hk)
+
+private def Smale.LinearSphereAction.componentHomotopy {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {signWeight : ℝ}
+    {A B : Degree.LinearFramePaths.operatorComponent (D := E) signWeight} (γ : Path A B) :
+    (sphereMap A.val (component_injective A)).Homotopy (sphereMap B.val (component_injective B))
+    where
+  toFun q := sphereMap (γ q.1).val (component_injective (γ q.1)) q.2
+  continuous_toFun := by
+    have hA : Continuous (fun q : (unitInterval) × Metric.sphere (0 : E) 1 => (γ q.1).val) :=
+      continuous_subtype_val.comp (γ.continuous.comp continuous_fst)
+    have hx : Continuous (fun q : (unitInterval) × Metric.sphere (0 : E) 1 => q.2.val) :=
+      continuous_subtype_val.comp continuous_snd
+    exact Smale.PuncturedRadial.toSphere.continuous.comp ((hA.clm_apply hx).subtype_mk _)
+  map_zero_left
+    x := by
+    change sphereMap (γ 0).val (component_injective (γ 0)) x = _
+    rw [γ.source]
+  map_one_left
+    x := by
+    change sphereMap (γ 1).val (component_injective (γ 1)) x = _
+    rw [γ.target]
+
+private theorem Smale.LinearSphereAction.homotopic_of_det_mul_pos {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {ι : Type*} [Finite ι] [Nontrivial ι]
+    (b : Module.Basis ι ℝ E) (A B : E ≃L[ℝ] E)
+    (h : 0 < A.toLinearEquiv.toLinearMap.det * B.toLinearEquiv.toLinearMap.det) :
+    (sphereMap A.toContinuousLinearMap A.injective).Homotopic
+      (sphereMap B.toContinuousLinearMap B.injective) := by
+  have hd : A.toLinearEquiv.toLinearMap.det ≠ 0 := by
+    intro hz
+    rw [hz, MulZeroClass.zero_mul] at h
+    exact lt_irrefl _ h
+  let A' : Degree.LinearFramePaths.operatorComponent (D := E) A.toLinearEquiv.toLinearMap.det :=
+    ⟨A.toContinuousLinearMap, mul_self_pos.mpr hd⟩
+  let B' : Degree.LinearFramePaths.operatorComponent (D := E) A.toLinearEquiv.toLinearMap.det :=
+    ⟨B.toContinuousLinearMap, h⟩
+  exact ⟨componentHomotopy (Degree.LinearFramePaths.joined_operatorComponent b A' B').somePath⟩
+
+private theorem Smale.LinearSphereAction.sphereMap_comp {E F G : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] (A : E →L[ℝ] F) (B : F →L[ℝ] G) (hA : Function.Injective A)
+    (hB : Function.Injective B) :
+    (sphereMap B hB).comp (sphereMap A hA) = sphereMap (B.comp A) (hB.comp hA) := by
+  apply ContinuousMap.ext
+  intro x
+  apply Subtype.ext
+  change NormedSpace.normalize (B (‖A x.val‖⁻¹ • A x.val)) = NormedSpace.normalize (B (A x.val))
+  rw [map_smul]
+  exact
+    NormedSpace.normalize_smul_of_pos
+      (inv_pos.mpr (norm_pos_iff.mpr (puncturedMap A hA x).property)) _
+
+private theorem Smale.LinearSphereAction.sphereMap_trans {E F G : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] (A : E ≃L[ℝ] F) (B : F ≃L[ℝ] G) :
+    sphereMap (A.trans B).toContinuousLinearMap (A.trans B).injective =
+      (sphereMap B.toContinuousLinearMap B.injective).comp
+        (sphereMap A.toContinuousLinearMap A.injective) :=
+  (sphereMap_comp A.toContinuousLinearMap B.toContinuousLinearMap A.injective B.injective).symm
+
+private theorem
+    Smale.LinearSphereAction.normalized_linearSphereMap {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] (A : E ≃L[ℝ] F) (r : ℝ)
+    (hr : 0 < r) :
+    Smale.PuncturedRadial.toSphere.comp (Smale.LocalDegree.linearSphereMap A r hr) =
+      sphereMap A.toContinuousLinearMap A.injective := by
+  apply ContinuousMap.ext
+  intro x
+  apply Subtype.ext
+  change NormedSpace.normalize (A (r • x.val)) = NormedSpace.normalize (A x.val)
+  rw [map_smul, NormedSpace.normalize_smul_of_pos hr]
+
+private theorem Smale.LinearSphereAction.sphereMap_relative {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] (A B : E ≃L[ℝ] F) :
+    sphereMap A.toContinuousLinearMap A.injective =
+      (sphereMap B.toContinuousLinearMap B.injective).comp
+        (sphereMap (A.trans B.symm).toContinuousLinearMap (A.trans B.symm).injective) := by
+  rw [← sphereMap_trans]
+  have heq : (A.trans B.symm).trans B = A := by
+    ext x
+    exact B.apply_symm_apply (A x)
+  rw [heq]
+
+private def Smale.LinearSphereAction.sphereHomotopyEquiv {E F : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] (B : E ≃L[ℝ] F) :
+    Metric.sphere (0 : E) 1 ≃ₕ Metric.sphere (0 : F) 1 :=
+  (Smale.LocalDegree.linearSphereEquiv B 1 zero_lt_one).trans
+    (Smale.PuncturedRadial.sphereHomotopyEquiv 1 zero_lt_one).symm
+
+private theorem
+    Smale.LinearSphereAction.sphereHomotopyEquiv_toFun {E F : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] (B : E ≃L[ℝ] F) :
+    (sphereHomotopyEquiv B).toFun = sphereMap B.toContinuousLinearMap B.injective :=
+  normalized_linearSphereMap B 1 zero_lt_one
+
+private def
+    Smale.LinearSphereAction.homologyEquiv {E F : Type} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (B : E ≃L[ℝ] F) (k : ℕ) :
+    SingularMayerVietoris.SingularHomology (Metric.sphere (0 : E) 1) k ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (Metric.sphere (0 : F) 1) k :=
+  PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (sphereHomotopyEquiv B) k
+
+private theorem Smale.LinearSphereAction.homologyEquiv_apply {E F : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] (B : E ≃L[ℝ] F) (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (Metric.sphere (0 : E) 1) k) :
+    homologyEquiv B k a =
+      SingularMayerVietoris.singularHomologyMap (sphereMap B.toContinuousLinearMap B.injective) k
+        a := by
+  change SingularMayerVietoris.singularHomologyMap (sphereHomotopyEquiv B).toFun k a = _
+  rw [sphereHomotopyEquiv_toFun]
+
+private theorem Smale.SpherePoint.hyperplaneReflection_det {V : Type} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] [FiniteDimensional ℝ V] (u : V) (hu : u ≠ 0) :
+    ((ℝ ∙ u)ᗮ.reflection).toLinearMap.det = -1 := by
+  rw [Submodule.det_reflection, Submodule.orthogonal_orthogonal, finrank_span_singleton hu,
+    pow_one]
+
+private theorem Smale.SpherePoint.positive_transport_of_normal {V : Type} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] [FiniteDimensional ℝ V] (v w : Metric.sphere (0 : V) 1) (u : V)
+    (hu : u ≠ 0) (huw : Inner.inner ℝ u w.val = 0) (hvw : v ≠ w) :
+    ∃ R : V ≃ₗᵢ[ℝ] V, R v.val = w.val ∧ R.toLinearMap.det = 1 := by
+  have hvw' : (v : V) - (w : V) ≠ 0 := by
+    intro h
+    exact hvw (Subtype.ext (sub_eq_zero.mp h))
+  let R₁ := (ℝ ∙ ((v : V) - (w : V)))ᗮ.reflection
+  let R₂ := (ℝ ∙ u)ᗮ.reflection
+  have h₁ : R₁ v.val = w.val :=
+    Submodule.reflection_sub
+      ((mem_sphere_zero_iff_norm.mp v.property).trans
+        (mem_sphere_zero_iff_norm.mp w.property).symm)
+  have h₂ : R₂ w.val = w.val :=
+    Submodule.reflection_mem_subspace_eq_self
+      (Submodule.mem_orthogonal_singleton_iff_inner_right.mpr huw)
+  refine ⟨R₁.trans R₂, ?_, ?_⟩
+  · change R₂ (R₁ v.val) = w.val
+    rw [h₁, h₂]
+  · change (R₂.toLinearMap.comp R₁.toLinearMap).det = 1
+    rw [LinearMap.det_comp, hyperplaneReflection_det u hu,
+      hyperplaneReflection_det ((v : V) - (w : V)) hvw']
+    norm_num
+
+private theorem Smale.SpherePoint.exists_positive_transport (n : ℕ)
+    (v w : SphereHomology.UnitSphere (n + 1)) :
+    ∃ R : EuclideanSpace ℝ (Fin (n + 2)) ≃ₗᵢ[ℝ] EuclideanSpace ℝ (Fin (n + 2)),
+      R v.val = w.val ∧ R.toLinearMap.det = 1 := by
+  by_cases hvw : v = w
+  · refine ⟨LinearIsometryEquiv.refl ℝ _, ?_, ?_⟩
+    · exact congrArg Subtype.val hvw
+    · exact LinearMap.det_id
+  · let _ : Fact (Module.finrank ℝ (EuclideanSpace ℝ (Fin (n + 2))) = (n + 1) + 1) := ⟨by simp⟩
+    let b :=
+      OrthonormalBasis.fromOrthogonalSpanSingleton (𝕜 := ℝ) (n + 1) (ne_zero_of_mem_unit_sphere w)
+    let u : EuclideanSpace ℝ (Fin (n + 2)) :=
+      (b (0 : Fin (n + 1)) : EuclideanSpace ℝ (Fin (n + 2)))
+    have hun : ‖u‖ = 1 := b.norm_eq_one 0
+    have hu : u ≠ 0 := by
+      intro h
+      rw [h, norm_zero] at hun
+      exact zero_ne_one hun
+    have huw : Inner.inner ℝ u w.val = 0 := by
+      have h := (b (0 : Fin (n + 1))).property
+      exact Submodule.mem_orthogonal_singleton_iff_inner_left.mp h
+    exact positive_transport_of_normal v w u hu huw hvw
+
+private def Smale.SpherePoint.positiveTransport (n : ℕ) (v w : SphereHomology.UnitSphere (n + 1)) :
+    EuclideanSpace ℝ (Fin (n + 2)) ≃ₗᵢ[ℝ] EuclideanSpace ℝ (Fin (n + 2)) :=
+  Classical.choose (exists_positive_transport n v w)
+
+private theorem Smale.SpherePoint.positiveTransport_apply (n : ℕ)
+    (v w : SphereHomology.UnitSphere (n + 1)) : positiveTransport n v w v.val = w.val :=
+  (Classical.choose_spec (exists_positive_transport n v w)).1
+
+private theorem Smale.SpherePoint.positiveTransport_det (n : ℕ)
+    (v w : SphereHomology.UnitSphere (n + 1)) : (positiveTransport n v w).toLinearMap.det = 1 :=
+  (Classical.choose_spec (exists_positive_transport n v w)).2
+
+private def Smale.CoverNaturality.intersectionSwap {X : Type} [TopologicalSpace X] (U V : Set X) :
+    C(↥(U ∩ V), ↥(V ∩ U)) :=
+  ⟨fun x => ⟨x.val, x.property.symm⟩, continuous_subtype_val.subtype_mk _⟩
+
+private def Smale.CoverNaturality.smallSwap {X : Type} [TopologicalSpace X] (U V : Set X) :
+    SingularMayerVietoris.smallComplex U V ⟶ SingularMayerVietoris.smallComplex V U :=
+  SingularMayerVietoris.liftToSmall V U (SingularMayerVietoris.smallInclusion U V)
+    (fun n c => by
+      change c.val ∈ SingularMayerVietoris.smallChainSubmodule V U n
+      simpa only [SingularMayerVietoris.smallChainSubmodule, sup_comm] using c.property)
+
+private theorem
+    Smale.CoverNaturality.smallSwap_inclusion {X : Type} [TopologicalSpace X] (U V : Set X) :
+    smallSwap U V ≫ SingularMayerVietoris.smallInclusion V U =
+      SingularMayerVietoris.smallInclusion U V :=
+  SingularMayerVietoris.liftToSmall_inclusion V U _ _
+
+private theorem Smale.CoverNaturality.smallSwap_left {X : Type} [TopologicalSpace X] (U V : Set X) :
+    SingularMayerVietoris.toSmallLeft U V ≫ smallSwap U V =
+      SingularMayerVietoris.toSmallRight V U := by
+  apply (CategoryTheory.cancel_mono (SingularMayerVietoris.smallInclusion V U)).mp
+  rw [CategoryTheory.Category.assoc, smallSwap_inclusion,
+    SingularMayerVietoris.toSmallLeft_inclusion, SingularMayerVietoris.toSmallRight_inclusion]
+
+private theorem
+    Smale.CoverNaturality.smallSwap_right {X : Type} [TopologicalSpace X] (U V : Set X) :
+    SingularMayerVietoris.toSmallRight U V ≫ smallSwap U V =
+      SingularMayerVietoris.toSmallLeft V U := by
+  apply (CategoryTheory.cancel_mono (SingularMayerVietoris.smallInclusion V U)).mp
+  rw [CategoryTheory.Category.assoc, smallSwap_inclusion,
+    SingularMayerVietoris.toSmallRight_inclusion, SingularMayerVietoris.toSmallLeft_inclusion]
+
+private theorem Smale.CoverNaturality.intersectionSwap_left {X : Type} [TopologicalSpace X]
+    (U V : Set X) :
+    FirstHurewicz.singularChainMap (intersectionSwap U V) ≫
+        SingularMayerVietoris.intersectionToLeft V U =
+      SingularMayerVietoris.intersectionToRight U V := by
+  unfold SingularMayerVietoris.intersectionToLeft SingularMayerVietoris.intersectionToRight
+  rw [chainMap_comp]
+  rfl
+
+private theorem Smale.CoverNaturality.intersectionSwap_right {X : Type} [TopologicalSpace X]
+    (U V : Set X) :
+    FirstHurewicz.singularChainMap (intersectionSwap U V) ≫
+        SingularMayerVietoris.intersectionToRight V U =
+      SingularMayerVietoris.intersectionToLeft U V := by
+  unfold SingularMayerVietoris.intersectionToLeft SingularMayerVietoris.intersectionToRight
+  rw [chainMap_comp]
+  rfl
+
+private def Smale.CoverNaturality.chainSequenceSwap {X : Type} [TopologicalSpace X] (U V : Set X) :
+    SingularMayerVietoris.chainSequence U V ⟶ SingularMayerVietoris.chainSequence V U
+    where
+  τ₁ := -FirstHurewicz.singularChainMap (intersectionSwap U V)
+  τ₂ :=
+    CategoryTheory.Limits.biprod.lift CategoryTheory.Limits.biprod.snd
+      CategoryTheory.Limits.biprod.fst
+  τ₃ := smallSwap U V
+  comm₁₂ := by
+    dsimp only [SingularMayerVietoris.chainSequence, SingularMayerVietoris.leftMap,
+      SingularMayerVietoris.middleComplex]
+    apply CategoryTheory.Limits.biprod.hom_ext
+    · simp only [CategoryTheory.Category.assoc, CategoryTheory.Limits.biprod.lift_fst,
+        CategoryTheory.Limits.biprod.lift_snd, CategoryTheory.Preadditive.neg_comp]
+      exact congrArg Neg.neg (intersectionSwap_left U V)
+    · simp only [CategoryTheory.Category.assoc, CategoryTheory.Limits.biprod.lift_snd,
+        CategoryTheory.Limits.biprod.lift_fst, CategoryTheory.Preadditive.neg_comp,
+        CategoryTheory.Preadditive.comp_neg, neg_neg]
+      exact intersectionSwap_right U V
+  comm₂₃ := by
+    dsimp only [SingularMayerVietoris.chainSequence, SingularMayerVietoris.rightMap,
+      SingularMayerVietoris.middleComplex]
+    apply CategoryTheory.Limits.biprod.hom_ext'
+    · simp only [CategoryTheory.Limits.biprod.lift_desc, CategoryTheory.Preadditive.comp_add,
+        CategoryTheory.Limits.biprod.inl_snd_assoc, CategoryTheory.Limits.biprod.inl_fst_assoc,
+        CategoryTheory.Limits.zero_comp, zero_add, CategoryTheory.Limits.biprod.inl_desc_assoc]
+      exact (smallSwap_left U V).symm
+    · simp only [CategoryTheory.Limits.biprod.lift_desc, CategoryTheory.Preadditive.comp_add,
+        CategoryTheory.Limits.biprod.inr_snd_assoc, CategoryTheory.Limits.biprod.inr_fst_assoc,
+        CategoryTheory.Limits.zero_comp, add_zero, CategoryTheory.Limits.biprod.inr_desc_assoc]
+      exact (smallSwap_right U V).symm
+
+private theorem
+    Smale.CoverNaturality.smallConnecting_swap {X : Type} [TopologicalSpace X] (U V : Set X)
+    (n : ℕ) (a : SingularMayerVietoris.SmallHomology U V (n + 1)) :
+    SingularMayerVietoris.smallConnectingMap V U n
+        (SingularMayerVietoris.homologyLinearMap (smallSwap U V) (n + 1) a) =
+      -SingularMayerVietoris.singularHomologyMap (intersectionSwap U V) n
+          (SingularMayerVietoris.smallConnectingMap U V n a) := by
+  have h :=
+    LinearMap.congr_fun
+      (SingularMayerVietoris.connectingMap_naturality
+        (SingularMayerVietoris.chainSequence_shortExact U V) (chainSequenceSwap U V)
+        (SingularMayerVietoris.chainSequence_shortExact V U) n)
+      a
+  change
+    SingularMayerVietoris.homologyLinearMap
+        (-FirstHurewicz.singularChainMap (intersectionSwap U V)) n
+        (SingularMayerVietoris.smallConnectingMap U V n a) =
+      _ at h
+  rw [SingularMayerVietoris.homologyLinearMap_neg] at h
+  exact h.symm
+
+private theorem Smale.CoverNaturality.comparison_swap {X : Type} [TopologicalSpace X] (U V : Set X)
+    (n : ℕ) (a : SingularMayerVietoris.SmallHomology U V n) :
+    SingularMayerVietoris.smallHomologyComparison V U n
+        (SingularMayerVietoris.homologyLinearMap (smallSwap U V) n a) =
+      SingularMayerVietoris.smallHomologyComparison U V n a := by
+  change
+    SingularMayerVietoris.homologyLinearMap (SingularMayerVietoris.smallInclusion V U) n
+        (SingularMayerVietoris.homologyLinearMap (smallSwap U V) n a) =
+      _
+  rw [← LinearMap.comp_apply, ← SingularMayerVietoris.homologyLinearMap_comp, smallSwap_inclusion]
+  rfl
+
+private theorem Smale.CoverNaturality.connecting_swap {X : Type} [TopologicalSpace X] (U V : Set X)
+    (hU : IsOpen U) (hV : IsOpen V) (hc : U ∪ V = Set.univ) (hc' : V ∪ U = Set.univ) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology X (n + 1)) :
+    SingularMayerVietoris.connectingHomomorphism V U hV hU hc' n a =
+      -SingularMayerVietoris.singularHomologyMap (intersectionSwap U V) n
+          (SingularMayerVietoris.connectingHomomorphism U V hU hV hc n a) := by
+  obtain ⟨b, hb⟩ := (SingularMayerVietoris.smallHomologyEquiv U V hU hV hc (n + 1)).surjective a
+  have hb' : SingularMayerVietoris.smallHomologyComparison U V (n + 1) b = a := hb
+  rw [← hb', SingularMayerVietoris.connectingHomomorphism_comparison]
+  rw [← comparison_swap U V (n + 1) b, SingularMayerVietoris.connectingHomomorphism_comparison]
+  exact smallConnecting_swap U V n b
+
+private def Smale.CoverNaturality.reversingIntersectionMap {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (U V : Set X) (U' V' : Set Y) (f : C(X, Y)) (hU : Set.MapsTo f U V')
+    (hV : Set.MapsTo f V U') : C(↥(U ∩ V), ↥(U' ∩ V')) :=
+  mapOn f _ _ (fun _ hx => ⟨hV hx.2, hU hx.1⟩)
+
+private theorem
+    Smale.CoverNaturality.connecting_reversing_naturality {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (U V : Set X) (U' V' : Set Y) (f : C(X, Y)) (hfU : Set.MapsTo f U V')
+    (hfV : Set.MapsTo f V U') (hU : IsOpen U) (hV : IsOpen V) (hc : U ∪ V = Set.univ)
+    (hU' : IsOpen U') (hV' : IsOpen V') (hc' : U' ∪ V' = Set.univ) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology X (n + 1)) :
+    SingularMayerVietoris.connectingHomomorphism U' V' hU' hV' hc' n
+        (SingularMayerVietoris.singularHomologyMap f (n + 1) a) =
+      -SingularMayerVietoris.singularHomologyMap (reversingIntersectionMap U V U' V' f hfU hfV) n
+          (SingularMayerVietoris.connectingHomomorphism U V hU hV hc n a) := by
+  have hswap : V' ∪ U' = Set.univ := (Set.union_comm V' U').trans hc'
+  rw [connecting_swap V' U' hV' hU' hswap hc']
+  rw [← connecting_naturality_apply U V V' U' f hfU hfV hU hV hc hV' hU' hswap]
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp]
+  rfl
+
+private def Smale.SuspensionReflection.reflect {X : Type} [TopologicalSpace X] :
+    C(CuspCentralHomology.Suspension X, CuspCentralHomology.Suspension X)
+    where
+  toFun :=
+    Quotient.lift (fun q => CuspCentralHomology.Suspension.mk (unitInterval.symm q.1) q.2)
+      (by
+        rintro a b ⟨ht, h0 | h1 | hx⟩
+        · apply (CuspCentralHomology.Suspension.mk_eq_mk_iff _ _ _ _).mpr
+          refine ⟨congrArg unitInterval.symm ht, Or.inr (Or.inl ?_)⟩
+          simp [h0]
+        · apply (CuspCentralHomology.Suspension.mk_eq_mk_iff _ _ _ _).mpr
+          refine ⟨congrArg unitInterval.symm ht, Or.inl ?_⟩
+          simp [h1]
+        · exact
+            (CuspCentralHomology.Suspension.mk_eq_mk_iff _ _ _ _).mpr
+              ⟨congrArg unitInterval.symm ht, Or.inr (Or.inr hx)⟩)
+  continuous_toFun :=
+    CuspCentralHomology.Suspension.isQuotientMap_mk.continuous_iff.mpr
+      (CuspCentralHomology.Suspension.continuous_mk.comp
+        ((unitInterval.continuous_symm.comp continuous_fst).prodMk continuous_snd))
+
+private theorem
+    Smale.SuspensionReflection.reflect_mk {X : Type} [TopologicalSpace X] (t : (unitInterval))
+    (x : X) :
+    reflect (CuspCentralHomology.Suspension.mk t x) =
+      CuspCentralHomology.Suspension.mk (unitInterval.symm t) x :=
+  rfl
+
+private theorem Smale.SuspensionReflection.reflect_height {X : Type} [TopologicalSpace X]
+    (x : CuspCentralHomology.Suspension X) :
+    CuspCentralHomology.Suspension.height (reflect x) =
+      unitInterval.symm (CuspCentralHomology.Suspension.height x) := by
+  obtain ⟨⟨t, u⟩, rfl⟩ := CuspCentralHomology.Suspension.mk_surjective x
+  rfl
+
+private theorem Smale.SuspensionReflection.reflect_north {X : Type} [TopologicalSpace X] :
+    Set.MapsTo (reflect (X := X)) CuspCentralHomology.Suspension.northOpen
+      CuspCentralHomology.Suspension.southOpen := by
+  intro x hx
+  change (CuspCentralHomology.Suspension.height x : ℝ) < 3 / 4 at hx
+  change 1 / 4 < (CuspCentralHomology.Suspension.height (reflect x) : ℝ)
+  rw [reflect_height, unitInterval.coe_symm_eq]
+  linarith
+
+private theorem Smale.SuspensionReflection.reflect_south {X : Type} [TopologicalSpace X] :
+    Set.MapsTo (reflect (X := X)) CuspCentralHomology.Suspension.southOpen
+      CuspCentralHomology.Suspension.northOpen := by
+  intro x hx
+  change 1 / 4 < (CuspCentralHomology.Suspension.height x : ℝ) at hx
+  change (CuspCentralHomology.Suspension.height (reflect x) : ℝ) < 3 / 4
+  rw [reflect_height, unitInterval.coe_symm_eq]
+  linarith
+
+private def Smale.SuspensionReflection.middleMap {X : Type} [TopologicalSpace X] :
+    C(CuspCentralHomology.Suspension.middleBand X, CuspCentralHomology.Suspension.middleBand X) :=
+  Smale.CoverNaturality.reversingIntersectionMap _ _ _ _ reflect reflect_north reflect_south
+
+private theorem Smale.SuspensionReflection.middle_projection {X : Type} [TopologicalSpace X]
+    (x : CuspCentralHomology.Suspension.middleBand X) :
+    CuspCentralHomology.Suspension.middleBandHomotopyEquiv (middleMap x) =
+      CuspCentralHomology.Suspension.middleBandHomotopyEquiv x := by
+  obtain ⟨⟨t, u⟩, rfl⟩ := CuspCentralHomology.Suspension.middleBandHomeomorph.symm.surjective x
+  let q : Set.Ioo (1 / 4 : ℝ) (3 / 4) × X :=
+    (⟨1 - (t : ℝ), by constructor <;> linarith [t.property.1, t.property.2]⟩, u)
+  have hpoint :
+    middleMap (CuspCentralHomology.Suspension.middleBandHomeomorph.symm (t, u)) =
+      CuspCentralHomology.Suspension.middleBandHomeomorph.symm q := by
+    apply Subtype.ext
+    change reflect (CuspCentralHomology.Suspension.mk _ u) = CuspCentralHomology.Suspension.mk _ u
+    rw [reflect_mk]
+    congr 1
+  rw [hpoint, CuspCentralHomology.Suspension.middleBandHomotopyEquiv_apply,
+    CuspCentralHomology.Suspension.middleBandHomotopyEquiv_apply, Homeomorph.apply_symm_apply,
+    Homeomorph.apply_symm_apply]
+
+private theorem Smale.SuspensionReflection.middle_projection_comp {X : Type} [TopologicalSpace X] :
+    (CuspCentralHomology.Suspension.middleBandHomotopyEquiv (X := X)).toFun.comp middleMap =
+      (CuspCentralHomology.Suspension.middleBandHomotopyEquiv (X := X)).toFun :=
+  ContinuousMap.ext middle_projection
+
+private noncomputable def NoExotic.hyperplaneReflectionOperator {E : Type*} [NormedAddCommGroup E]
+    [InnerProductSpace ℝ E] (v : E) : E →L[ℝ] E :=
+  ((ℝ ∙ v)ᗮ.reflection).toContinuousLinearEquiv.toContinuousLinearMap
+
+private theorem NoExotic.hyperplaneReflectionOperator_apply {E : Type*} [NormedAddCommGroup E]
+    [InnerProductSpace ℝ E] (v w : E) :
+    hyperplaneReflectionOperator v w = w - (2 * (‖v‖ ^ 2)⁻¹ * Inner.inner ℝ v w) • v := by
+  change (ℝ ∙ v)ᗮ.reflection w = _
+  rw [Submodule.reflection_orthogonal_apply, Submodule.reflection_singleton_apply]
+  simp only [RCLike.ofReal_real_eq_id, id_eq, neg_sub, two_smul]
+  rw [← add_smul]
+  apply congrArg (fun r : ℝ ↦ w - r • v)
+  simp only [div_eq_mul_inv]
+  ring
+
+private def Smale.SphereReflection.linearReflection (n : ℕ) :
+    EuclideanSpace ℝ (Fin (n + 2)) ≃ₗᵢ[ℝ] EuclideanSpace ℝ (Fin (n + 2)) :=
+  (ℝ ∙ EuclideanSpace.single (0 : Fin (n + 2)) (1 : ℝ))ᗮ.reflection
+
+private theorem Smale.SphereReflection.linearReflection_apply (n : ℕ)
+    (y : EuclideanSpace ℝ (Fin (n + 2))) :
+    linearReflection n y = y - (2 * y 0) • EuclideanSpace.single 0 (1 : ℝ) := by
+  change NoExotic.hyperplaneReflectionOperator (EuclideanSpace.single 0 (1 : ℝ)) y = _
+  rw [NoExotic.hyperplaneReflectionOperator_apply]
+  simp only [PiLp.norm_single, NormOneClass.norm_one, one_pow, inv_one, mul_one,
+    EuclideanSpace.inner_single_left, map_one, one_mul]
+
+private theorem Smale.SphereReflection.linearReflection_zero (n : ℕ)
+    (y : EuclideanSpace ℝ (Fin (n + 2))) : linearReflection n y 0 = -y 0 := by
+  rw [linearReflection_apply]
+  change y 0 - (2 * y 0) * (EuclideanSpace.single 0 (1 : ℝ)) 0 = _
+  simp
+  ring
+
+private theorem
+    Smale.SphereReflection.linearReflection_succ (n : ℕ) (y : EuclideanSpace ℝ (Fin (n + 2)))
+    (i : Fin (n + 1)) : linearReflection n y i.succ = y i.succ := by
+  rw [linearReflection_apply]
+  change y i.succ - (2 * y 0) * (EuclideanSpace.single 0 (1 : ℝ)) i.succ = _
+  simp
+
+private theorem Smale.SphereReflection.linearReflection_det (n : ℕ) :
+    (linearReflection n).toLinearMap.det = -1 := by
+  have hv : (EuclideanSpace.single (0 : Fin (n + 2)) (1 : ℝ)) ≠ 0 := by simp
+  change
+    LinearMap.det
+        ((ℝ ∙ EuclideanSpace.single (0 : Fin (n + 2)) (1 : ℝ))ᗮ.reflection).toLinearMap =
+      _
+  rw [Submodule.det_reflection, Submodule.orthogonal_orthogonal, finrank_span_singleton hv,
+    pow_one]
+
+private def Smale.SphereReflection.sphereMap (n : ℕ) :
+    C(SphereHomology.UnitSphere (n + 1), SphereHomology.UnitSphere (n + 1))
+    where
+  toFun
+    x :=
+    ⟨linearReflection n x.val, by
+      rw [Metric.mem_sphere, dist_zero_right, LinearIsometryEquiv.norm_map,
+        SphereHomology.unitSphere_norm]⟩
+  continuous_toFun := ((linearReflection n).continuous.comp continuous_subtype_val).subtype_mk _
+
+private theorem Smale.SphereReflection.height_symm (t : (unitInterval)) :
+    SphereHomology.Latitude.height (unitInterval.symm t) = -SphereHomology.Latitude.height t := by
+  simp only [SphereHomology.Latitude.height, unitInterval.coe_symm_eq]
+  ring
+
+private theorem Smale.SphereReflection.radius_symm (t : (unitInterval)) :
+    SphereHomology.Latitude.radius (unitInterval.symm t) = SphereHomology.Latitude.radius t := by
+  simp only [SphereHomology.Latitude.radius, height_symm, neg_sq]
+
+private theorem Smale.SphereReflection.sphereMap_latitude (n : ℕ) (t : (unitInterval))
+    (x : SphereHomology.UnitSphere n) :
+    sphereMap n (SphereHomology.Latitude.point n t x) =
+      SphereHomology.Latitude.point n (unitInterval.symm t) x := by
+  apply Subtype.ext
+  apply PiLp.ext
+  intro i
+  refine Fin.cases ?_ (fun j => ?_) i
+  · change
+      linearReflection n (SphereHomology.Latitude.vector n t x) 0 =
+        SphereHomology.Latitude.vector n (unitInterval.symm t) x 0
+    rw [linearReflection_zero, SphereHomology.Latitude.vector_zero,
+      SphereHomology.Latitude.vector_zero, height_symm]
+  · change
+      linearReflection n (SphereHomology.Latitude.vector n t x) j.succ =
+        SphereHomology.Latitude.vector n (unitInterval.symm t) x j.succ
+    rw [linearReflection_succ, SphereHomology.Latitude.vector_succ,
+      SphereHomology.Latitude.vector_succ, radius_symm]
+
+private theorem Smale.SphereReflection.sphereMap_suspension (n : ℕ)
+    (x : CuspCentralHomology.Suspension (SphereHomology.UnitSphere n)) :
+    sphereMap n (SphereHomology.suspensionSphereHomeomorph n x) =
+      SphereHomology.suspensionSphereHomeomorph n (Smale.SuspensionReflection.reflect x) := by
+  obtain ⟨⟨t, u⟩, rfl⟩ := CuspCentralHomology.Suspension.mk_surjective x
+  rw [SphereHomology.suspensionSphereHomeomorph_mk, sphereMap_latitude,
+    Smale.SuspensionReflection.reflect_mk, SphereHomology.suspensionSphereHomeomorph_mk]
+
+private theorem Smale.SphereReflection.sphereMap_comp_suspension (n : ℕ) :
+    (sphereMap n).comp (SphereHomology.suspensionSphereHomeomorph n).toHomotopyEquiv.toFun =
+      (SphereHomology.suspensionSphereHomeomorph n).toHomotopyEquiv.toFun.comp
+        Smale.SuspensionReflection.reflect :=
+  ContinuousMap.ext (sphereMap_suspension n)
+
+private theorem Smale.SuspensionReflection.middle_homology {X : Type} [TopologicalSpace X] (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (CuspCentralHomology.Suspension.middleBand X) k) :
+    SingularMayerVietoris.singularHomologyMap middleMap k a = a := by
+  apply
+    (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+        CuspCentralHomology.Suspension.middleBandHomotopyEquiv k).injective
+  change
+    SingularMayerVietoris.singularHomologyMap
+        CuspCentralHomology.Suspension.middleBandHomotopyEquiv.toFun k
+        (SingularMayerVietoris.singularHomologyMap middleMap k a) =
+      SingularMayerVietoris.singularHomologyMap
+        CuspCentralHomology.Suspension.middleBandHomotopyEquiv.toFun k a
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    middle_projection_comp]
+
+private theorem
+    Smale.SuspensionReflection.reflect_homology {X : Type} [TopologicalSpace X] [Nonempty X]
+    (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (CuspCentralHomology.Suspension X) (n + 1)) :
+    SingularMayerVietoris.singularHomologyMap reflect (n + 1) a = -a := by
+  apply
+    CuspCentralHomology.contractibleCoverConnecting_injective
+      CuspCentralHomology.Suspension.northOpen CuspCentralHomology.Suspension.southOpen
+      CuspCentralHomology.Suspension.northOpen_isOpen
+      CuspCentralHomology.Suspension.southOpen_isOpen CuspCentralHomology.Suspension.open_cover n
+  rw [Smale.CoverNaturality.connecting_reversing_naturality
+      CuspCentralHomology.Suspension.northOpen CuspCentralHomology.Suspension.southOpen
+      CuspCentralHomology.Suspension.northOpen CuspCentralHomology.Suspension.southOpen reflect
+      reflect_north reflect_south CuspCentralHomology.Suspension.northOpen_isOpen
+      CuspCentralHomology.Suspension.southOpen_isOpen CuspCentralHomology.Suspension.open_cover
+      CuspCentralHomology.Suspension.northOpen_isOpen
+      CuspCentralHomology.Suspension.southOpen_isOpen CuspCentralHomology.Suspension.open_cover n
+      a]
+  change
+    -SingularMayerVietoris.singularHomologyMap middleMap n
+          (SingularMayerVietoris.connectingHomomorphism _ _ _ _ _ n a) =
+      _
+  rw [middle_homology, map_neg]
+
+private theorem Smale.SphereReflection.sphereMap_homology (n k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 1)) (k + 1)) :
+    SingularMayerVietoris.singularHomologyMap (sphereMap n) (k + 1) a = -a := by
+  obtain ⟨b, rfl⟩ :=
+    (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+          (SphereHomology.suspensionSphereHomeomorph n).toHomotopyEquiv (k + 1)).surjective
+      a
+  change
+    SingularMayerVietoris.singularHomologyMap (sphereMap n) (k + 1)
+        (SingularMayerVietoris.singularHomologyMap
+          (SphereHomology.suspensionSphereHomeomorph n).toHomotopyEquiv.toFun (k + 1) b) =
+      _
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    sphereMap_comp_suspension, PeriodTorusHigherHomology.singularHomologyMap_comp,
+    LinearMap.comp_apply, Smale.SuspensionReflection.reflect_homology, map_neg]
+  rfl
+
+private theorem Smale.LinearSphereAction.sphereMap_reflection (n : ℕ) :
+    sphereMap
+        (Smale.SphereReflection.linearReflection n).toContinuousLinearEquiv.toContinuousLinearMap
+        (Smale.SphereReflection.linearReflection n).injective =
+      Smale.SphereReflection.sphereMap n := by
+  apply ContinuousMap.ext
+  intro x
+  apply Subtype.ext
+  change
+    ‖Smale.SphereReflection.linearReflection n x.val‖⁻¹ •
+        Smale.SphereReflection.linearReflection n x.val =
+      Smale.SphereReflection.linearReflection n x.val
+  rw [LinearIsometryEquiv.norm_map, SphereHomology.unitSphere_norm, inv_one, one_smul]
+
+private theorem Smale.LinearSphereAction.homology_of_det_pos (n : ℕ)
+    (A : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] EuclideanSpace ℝ (Fin (n + 2)))
+    (h : 0 < A.toLinearEquiv.toLinearMap.det) (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 1)) k) :
+    SingularMayerVietoris.singularHomologyMap (sphereMap A.toContinuousLinearMap A.injective) k
+        a =
+      a := by
+  have hh :=
+    homotopic_of_det_mul_pos (EuclideanSpace.basisFun (Fin (n + 2)) ℝ).toBasis A
+      (ContinuousLinearEquiv.refl ℝ _)
+      (by
+        change 0 < A.toLinearEquiv.toLinearMap.det * (LinearMap.id : _ →ₗ[ℝ] _).det
+        rwa [LinearMap.det_id, mul_one])
+  rw [PeriodTorusHigherHomology.homotopic_homologyMap hh k]
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (sphereMap (ContinuousLinearMap.id ℝ _) Function.injective_id) k a =
+      a
+  rw [sphereMap_id, PeriodTorusHigherHomology.singularHomologyMap_id]
+  rfl
+
+private theorem Smale.LinearSphereAction.homology_of_det_neg (n : ℕ)
+    (A : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] EuclideanSpace ℝ (Fin (n + 2)))
+    (h : A.toLinearEquiv.toLinearMap.det < 0) (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 1)) (k + 1)) :
+    SingularMayerVietoris.singularHomologyMap (sphereMap A.toContinuousLinearMap A.injective)
+        (k + 1) a =
+      -a := by
+  have hh :=
+    homotopic_of_det_mul_pos (EuclideanSpace.basisFun (Fin (n + 2)) ℝ).toBasis A
+      (Smale.SphereReflection.linearReflection n).toContinuousLinearEquiv
+      (by
+        change
+          0 <
+            A.toLinearEquiv.toLinearMap.det *
+              (Smale.SphereReflection.linearReflection n).toLinearMap.det
+        rw [Smale.SphereReflection.linearReflection_det, mul_neg_one]
+        exact neg_pos.mpr h)
+  rw [PeriodTorusHigherHomology.homotopic_homologyMap hh (k + 1), sphereMap_reflection,
+    Smale.SphereReflection.sphereMap_homology]
+
+private theorem Smale.LinearSphereAction.homology_eq_sign_smul (n : ℕ)
+    (A : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] EuclideanSpace ℝ (Fin (n + 2))) (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 1)) (k + 1)) :
+    SingularMayerVietoris.singularHomologyMap (sphereMap A.toContinuousLinearMap A.injective)
+        (k + 1) a =
+      (SignType.sign A.toLinearEquiv.toLinearMap.det : ℤ) • a := by
+  have hd : A.toLinearEquiv.toLinearMap.det ≠ 0 := A.toLinearEquiv.isUnit_det'.ne_zero
+  obtain hn | hp := lt_or_gt_of_ne hd
+  · rw [homology_of_det_neg n A hn, sign_eq_neg_one_iff.mpr hn]
+    simp
+  · rw [homology_of_det_pos n A hp, sign_eq_one_iff.mpr hp]
+    simp
+
+private def
+    Smale.SpherePoint.sphereHomeomorph {V : Type} [NormedAddCommGroup V] [InnerProductSpace ℝ V]
+    (R : V ≃ₗᵢ[ℝ] V) : Metric.sphere (0 : V) 1 ≃ₜ Metric.sphere (0 : V) 1 :=
+  R.toContinuousLinearEquiv.toHomeomorph.subtype
+    (fun x => by
+      simp only [mem_sphere_zero_iff_norm]
+      change ‖x‖ = 1 ↔ ‖R x‖ = 1
+      rw [R.norm_map])
+
+private theorem Smale.SpherePoint.sphereHomeomorph_eq_normalized {V : Type} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] (R : V ≃ₗᵢ[ℝ] V) :
+    (sphereHomeomorph R).toHomotopyEquiv.toFun =
+      Smale.LinearSphereAction.sphereMap R.toContinuousLinearEquiv.toContinuousLinearMap
+        R.injective := by
+  apply ContinuousMap.ext
+  intro x
+  apply Subtype.ext
+  change R x.val = ‖R x.val‖⁻¹ • R x.val
+  rw [R.norm_map, mem_sphere_zero_iff_norm.mp x.property, inv_one, one_smul]
+
+private theorem Smale.SpherePoint.contMDiff_sphereHomeomorph {V : Type} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] {n : ℕ} [Fact (Module.finrank ℝ V = n + 1)] (R : V ≃ₗᵢ[ℝ] V) :
+    ContMDiff (𝓡 n) (𝓡 n) ∞ (sphereHomeomorph R) := by
+  have h : ContMDiff (𝓡 n) 𝓘(ℝ, V) ∞ (fun x : Metric.sphere (0 : V) 1 => R x.val) :=
+    R.toContinuousLinearEquiv.toContinuousLinearMap.contDiff.contMDiff.comp
+      (contMDiff_coe_sphere (m := ∞))
+  exact h.codRestrict_sphere (n := n) (fun x => (sphereHomeomorph R x).property)
+
+private def
+    Smale.SpherePoint.sphereDiffeomorph {V : Type} [NormedAddCommGroup V] [InnerProductSpace ℝ V]
+    {n : ℕ} [Fact (Module.finrank ℝ V = n + 1)] (R : V ≃ₗᵢ[ℝ] V) :
+    Diffeomorph (𝓡 n) (𝓡 n) (Metric.sphere (0 : V) 1) (Metric.sphere (0 : V) 1) ∞
+    where
+  toEquiv := (sphereHomeomorph R).toEquiv
+  contMDiff_toFun := contMDiff_sphereHomeomorph R
+  contMDiff_invFun := contMDiff_sphereHomeomorph R.symm
+
+private theorem Smale.SpherePoint.sphereHomeomorph_homology_of_det_pos (n : ℕ)
+    (R : EuclideanSpace ℝ (Fin (n + 2)) ≃ₗᵢ[ℝ] EuclideanSpace ℝ (Fin (n + 2)))
+    (hR : 0 < R.toLinearMap.det) (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 1)) k) :
+    SingularMayerVietoris.singularHomologyMap (sphereHomeomorph R).toHomotopyEquiv.toFun k a =
+      a := by
+  rw [sphereHomeomorph_eq_normalized]
+  exact Smale.LinearSphereAction.homology_of_det_pos n R.toContinuousLinearEquiv hR k a
+
+private theorem Smale.SpherePoint.positiveTransport_moves (n : ℕ)
+    (v w : SphereHomology.UnitSphere (n + 1)) :
+    sphereHomeomorph (positiveTransport n v w) v = w :=
+  Subtype.ext (positiveTransport_apply n v w)
+
+private theorem Smale.SpherePoint.positiveTransport_homology (n : ℕ)
+    (v w : SphereHomology.UnitSphere (n + 1)) (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 1)) k) :
+    SingularMayerVietoris.singularHomologyMap
+        (sphereHomeomorph (positiveTransport n v w)).toHomotopyEquiv.toFun k a =
+      a := by
+  apply sphereHomeomorph_homology_of_det_pos n _ _ k a
+  rw [positiveTransport_det]
+  norm_num
+
+private theorem Smale.LocalDegree.NativeNeighborhood.singlePoint_cover {E F M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x : M) {f : M → F}
+    {L : E ≃L[ℝ] F} {W : Set M}
+    (d :
+      Smale.LocalDegree.NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) x) L
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' W)) :
+    { x }ᶜ ∪ openSet x d = Set.univ := by
+  apply Set.eq_univ_of_forall
+  intro y
+  by_cases h : y = x
+  · subst y
+    exact Or.inr (center_mem_openSet x d)
+  · exact Or.inl h
+
+private theorem Smale.LocalDegree.NativeNeighborhood.openSet_contractible {E F M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x : M) {f : M → F}
+    {L : E ≃L[ℝ] F} {W : Set M}
+    (d :
+      Smale.LocalDegree.NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) x) L
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' W)) :
+    ContractibleSpace (openSet x d) := by
+  let : ContractibleSpace (Metric.ball (0 : E) d.radius) :=
+    (convex_ball (0 : E) d.radius).contractibleSpace ⟨0, by simpa using d.radius_pos⟩
+  exact
+    (Smale.ChartPuncturedBall.ballHomeomorph
+        (Smale.NativeParametrization.centered x).toOpenPartialHomeomorph d.radius
+        (closedBall_subset_source x d)).symm.contractibleSpace
+
+private def
+    Smale.LocalDegree.NativeNeighborhood.sphereConnecting {E F M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x : M) {f : M → F} {L : E ≃L[ℝ] F} {W : Set M}
+    (d :
+      Smale.LocalDegree.NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) x) L
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' W))
+    [T1Space M] (k : ℕ) :
+    SingularMayerVietoris.SingularHomology M (k + 1) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (Metric.sphere (0 : E) 1) k :=
+  (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (overlapSphereEquiv x d)
+        k).symm.toLinearMap.comp
+    (SingularMayerVietoris.connectingHomomorphism { x }ᶜ (openSet x d)
+      isClosed_singleton.isOpen_compl (isOpen_openSet x d) (singlePoint_cover x d) k)
+
+private def
+    Smale.LocalDegree.NativeNeighborhood.sphereHomologyEquiv {E F M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x : M) {f : M → F} {L : E ≃L[ℝ] F} {W : Set M}
+    (d :
+      Smale.LocalDegree.NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) x) L
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' W))
+    [T1Space M] [ContractibleSpace ({ x }ᶜ : Set M)] (k : ℕ) :
+    SingularMayerVietoris.SingularHomology M (k + 2) ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (Metric.sphere (0 : E) 1) (k + 1) := by
+  let : ContractibleSpace (openSet x d) := openSet_contractible x d
+  exact
+    (CuspCentralHomology.contractibleCoverHomologyHigherEquiv { x }ᶜ (openSet x d)
+          isClosed_singleton.isOpen_compl (isOpen_openSet x d) (singlePoint_cover x d) k).trans
+      (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (overlapSphereEquiv x d) (k + 1)).symm
+
+private theorem Smale.NativeParametrization.centered_symm_self {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x : M) :
+    (centered (D := E) x).symm x = 0 := by
+  have h := (centered (D := E) x).left_inv' (zero_mem_centered_source x)
+  rwa [centered_zero] at h
+
+private def Smale.NativeChartTransition.chart {E M : Type} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x y : M)
+    (e : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞) : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞ :=
+  ((Smale.NativeParametrization.centered (D := E) x).trans e.toPartialDiffeomorph).trans
+    (Smale.NativeParametrization.centered (D := E) y).symm
+
+private theorem Smale.NativeChartTransition.chart_apply {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x y : M)
+    (e : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞) (u : E) :
+    chart x y e u =
+      (Smale.NativeParametrization.centered (D := E) y).symm
+        (e (Smale.NativeParametrization.centered (D := E) x u)) :=
+  rfl
+
+private theorem Smale.NativeChartTransition.zero_mem_source {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x y : M)
+    (e : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞) (he : e x = y) : (0 : E) ∈ (chart x y e).source := by
+  change
+    (0 ∈ (Smale.NativeParametrization.centered (D := E) x).source ∧
+        Smale.NativeParametrization.centered (D := E) x 0 ∈ (Set.univ : Set M)) ∧
+      e (Smale.NativeParametrization.centered (D := E) x 0) ∈
+        (Smale.NativeParametrization.centered (D := E) y).target
+  refine ⟨⟨Smale.NativeParametrization.zero_mem_centered_source x, Set.mem_univ _⟩, ?_⟩
+  rw [Smale.NativeParametrization.centered_zero, he]
+  exact Smale.NativeParametrization.mem_centered_target y
+
+private theorem Smale.NativeChartTransition.chart_zero {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x y : M)
+    (e : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞) (he : e x = y) : chart x y e (0 : E) = 0 := by
+  rw [chart_apply, Smale.NativeParametrization.centered_zero, he,
+    Smale.NativeParametrization.centered_symm_self]
+
+private theorem Smale.NativeChartTransition.contDiffAt_chart {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x y : M)
+    (e : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞) (he : e x = y) :
+    ContDiffAt ℝ ∞ (chart x y e) (0 : E) :=
+  ((chart x y e).contMDiffOn_toFun.contMDiffAt
+      ((chart x y e).open_source.mem_nhds (zero_mem_source x y e he))).contDiffAt
+
+private theorem Smale.NativeChartTransition.bijective_derivative {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x y : M)
+    (e : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞) (he : e x = y) :
+    Function.Bijective (fderiv ℝ (chart x y e) (0 : E)) := by
+  have h := Smale.PartialChart.bijective_mfderiv (chart x y e) (zero_mem_source x y e he)
+  rwa [mfderiv_eq_fderiv] at h
+
+private def Smale.NativeChartTransition.linear {E M : Type} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x y : M)
+    (e : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞) (he : e x = y) [FiniteDimensional ℝ E] : E ≃L[ℝ] E :=
+  (LinearEquiv.ofBijective (fderiv ℝ (chart x y e) (0 : E)).toLinearMap
+      (bijective_derivative x y e he)).toContinuousLinearEquiv
+
+private theorem Smale.NativeChartTransition.linear_eq_derivative {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x y : M)
+    (e : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞) (he : e x = y) [FiniteDimensional ℝ E] :
+    (linear x y e he).toContinuousLinearMap = fderiv ℝ (chart x y e) (0 : E) :=
+  rfl
+
+private theorem Smale.NativeChartTransition.hasFDerivAt_chart {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x y : M)
+    (e : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞) (he : e x = y) [FiniteDimensional ℝ E] :
+    HasFDerivAt (chart x y e) (linear x y e he).toContinuousLinearMap 0 := by
+  rw [linear_eq_derivative]
+  exact ((contDiffAt_chart x y e he).differentiableAt (by simp)).hasFDerivAt
+
+private theorem
+    Smale.NativeChartTransition.nonempty_neighborhoodData {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x y : M)
+    (e : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞) (he : e x = y) [FiniteDimensional ℝ E] (W : Set M)
+    (hW : W ∈ 𝓝 x) :
+    Nonempty
+      (Smale.LocalDegree.NeighborhoodData
+        (((Smale.NativeParametrization.centered (D := E) y).symm ∘ e) ∘
+          Smale.NativeParametrization.centered (D := E) x)
+        (linear x y e he)
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' W)) := by
+  let c := Smale.NativeParametrization.centered (D := E) x
+  have hc0 : (0 : E) ∈ c.source := Smale.NativeParametrization.zero_mem_centered_source x
+  have hcx : c 0 = x := Smale.NativeParametrization.centered_zero x
+  have hc : ContinuousAt c (0 : E) :=
+    c.contMDiffOn_toFun.continuousOn.continuousAt (c.open_source.mem_nhds hc0)
+  have hs : c.source ∩ c ⁻¹' W ∈ 𝓝 (0 : E) :=
+    Filter.inter_mem (c.open_source.mem_nhds hc0) (hc (hcx.symm ▸ hW))
+  exact
+    Smale.LocalDegree.nonempty_neighborhoodData_of_contDiffAt (linear x y e he)
+      (hasFDerivAt_chart x y e he) (chart_zero x y e he) hs (contDiffAt_chart x y e he)
+
+private theorem Smale.SpherePoint.ambient_chart_hasFDerivAt {V : Type} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] {m : ℕ} [Fact (Module.finrank ℝ V = m + 1)]
+    (c :
+      PartialDiffeomorph 𝓘(ℝ, EuclideanSpace ℝ (Fin m)) (𝓡 m) (EuclideanSpace ℝ (Fin m))
+        (Metric.sphere (0 : V) 1) ∞)
+    {z : EuclideanSpace ℝ (Fin m)} (hz : z ∈ c.source) :
+    HasFDerivAt (fun u => (c u : V)) (fderiv ℝ (fun u => (c u : V)) z) z := by
+  have hc : ContDiffOn ℝ ∞ (fun u => (c u : V)) c.source :=
+    ((contMDiff_coe_sphere (m := (∞ : ℕ∞ω))).comp_contMDiffOn c.contMDiffOn_toFun).contDiffOn
+  exact ((hc.contDiffAt (c.open_source.mem_nhds hz)).differentiableAt (by simp)).hasFDerivAt
+
+private theorem Smale.SpherePoint.chart_transition_eventually_eq {V : Type} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] {m : ℕ} [Fact (Module.finrank ℝ V = m + 1)]
+    (x y : Metric.sphere (0 : V) 1) (R : V ≃ₗᵢ[ℝ] V) (he : sphereHomeomorph R x = y) :
+    (fun u : EuclideanSpace ℝ (Fin m) =>
+        (Smale.NativeParametrization.centered y
+            (Smale.NativeChartTransition.chart x y (sphereDiffeomorph (n := m) R) u) :
+          V)) =ᶠ[𝓝 0]
+      (fun u : EuclideanSpace ℝ (Fin m) => R (Smale.NativeParametrization.centered x u : V)) := by
+  let e := sphereDiffeomorph (n := m) R
+  let T := Smale.NativeChartTransition.chart x y e
+  have hS := T.open_source.mem_nhds (Smale.NativeChartTransition.zero_mem_source x y e he)
+  filter_upwards [hS] with u hu
+  have ht :
+    e (Smale.NativeParametrization.centered x u) ∈
+      (Smale.NativeParametrization.centered (D := EuclideanSpace ℝ (Fin m)) y).target :=
+    hu.2
+  have h := (Smale.NativeParametrization.centered y).right_inv' ht
+  exact congrArg Subtype.val h
+
+private theorem
+    Smale.SpherePoint.chart_transition_ambient_derivative {V : Type} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] {m : ℕ} [Fact (Module.finrank ℝ V = m + 1)]
+    (x y : Metric.sphere (0 : V) 1) (R : V ≃ₗᵢ[ℝ] V) (he : sphereHomeomorph R x = y) :
+    (fderiv ℝ (fun u => (Smale.NativeParametrization.centered y u : V)) 0).comp
+        (Smale.NativeChartTransition.linear x y (sphereDiffeomorph (n := m) R)
+            he).toContinuousLinearMap =
+      R.toContinuousLinearEquiv.toContinuousLinearMap.comp
+        (fderiv ℝ (fun u => (Smale.NativeParametrization.centered x u : V)) 0) := by
+  let e := sphereDiffeomorph (n := m) R
+  let T := Smale.NativeChartTransition.chart x y e
+  have hx :=
+    ambient_chart_hasFDerivAt (m := m) (Smale.NativeParametrization.centered x)
+      (Smale.NativeParametrization.zero_mem_centered_source x)
+  have hy :=
+    ambient_chart_hasFDerivAt (m := m) (Smale.NativeParametrization.centered y)
+      (Smale.NativeParametrization.zero_mem_centered_source y)
+  have hyT :
+    HasFDerivAt
+      (fun u : EuclideanSpace ℝ (Fin m) => (Smale.NativeParametrization.centered y u : V))
+      (fderiv ℝ (fun u => (Smale.NativeParametrization.centered y u : V)) 0) (T 0) :=
+    (Smale.NativeChartTransition.chart_zero x y e he).symm ▸ hy
+  have hchain := hyT.comp 0 (Smale.NativeChartTransition.hasFDerivAt_chart x y e he)
+  have hR := R.toContinuousLinearEquiv.toContinuousLinearMap.hasFDerivAt.comp 0 hx
+  exact hchain.unique (hR.congr_of_eventuallyEq (chart_transition_eventually_eq x y R he))
+
+private theorem Smale.SpherePoint.chart_radial_frame_comp {V : Type} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] {m : ℕ} [Fact (Module.finrank ℝ V = m + 1)]
+    (x y : Metric.sphere (0 : V) 1) (R : V ≃ₗᵢ[ℝ] V) (he : sphereHomeomorph R x = y) :
+    (Smale.SphereNormalCoordinates.chartRadialFrame (Smale.NativeParametrization.centered y)
+            0).comp
+        ((ContinuousLinearMap.id ℝ ℝ).prodMap
+          (Smale.NativeChartTransition.linear x y (sphereDiffeomorph (n := m) R)
+              he).toContinuousLinearMap) =
+      R.toContinuousLinearEquiv.toContinuousLinearMap.comp
+        (Smale.SphereNormalCoordinates.chartRadialFrame (Smale.NativeParametrization.centered x)
+          0) := by
+  apply ContinuousLinearMap.ext
+  intro z
+  have hD :=
+    congrArg (fun A : EuclideanSpace ℝ (Fin m) →L[ℝ] V => A z.2)
+      (chart_transition_ambient_derivative x y R he)
+  have hcenter :
+    R (Smale.NativeParametrization.centered x (0 : EuclideanSpace ℝ (Fin m)) : V) =
+      (Smale.NativeParametrization.centered y (0 : EuclideanSpace ℝ (Fin m)) : V) := by
+    rw [Smale.NativeParametrization.centered_zero, Smale.NativeParametrization.centered_zero]
+    exact congrArg Subtype.val he
+  change
+    z.1 • (Smale.NativeParametrization.centered y (0 : EuclideanSpace ℝ (Fin m)) : V) +
+        (fderiv ℝ (fun u => (Smale.NativeParametrization.centered y u : V)) 0)
+          (Smale.NativeChartTransition.linear x y (sphereDiffeomorph (n := m) R) he z.2) =
+      R
+        (z.1 • (Smale.NativeParametrization.centered x (0 : EuclideanSpace ℝ (Fin m)) : V) +
+          (fderiv ℝ (fun u => (Smale.NativeParametrization.centered x u : V)) 0) z.2)
+  rw [map_add, map_smul, hcenter]
+  exact
+    congrArg
+      (fun v : V =>
+        z.1 • (Smale.NativeParametrization.centered y (0 : EuclideanSpace ℝ (Fin m)) : V) + v)
+      hD
+
+private theorem Smale.LinearSphereAction.homology_relative_sign {F : Type} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (n : ℕ) (A B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] F) (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 1)) (k + 1)) :
+    SingularMayerVietoris.singularHomologyMap (sphereMap A.toContinuousLinearMap A.injective)
+        (k + 1) a =
+      (SignType.sign (A.trans B.symm).toLinearEquiv.toLinearMap.det : ℤ) •
+        SingularMayerVietoris.singularHomologyMap (sphereMap B.toContinuousLinearMap B.injective)
+          (k + 1) a := by
+  rw [sphereMap_relative A B, PeriodTorusHigherHomology.singularHomologyMap_comp,
+    LinearMap.comp_apply, homology_eq_sign_smul]
+  exact map_zsmul _ _ _
+
+private theorem Smale.LocalDegree.BoundaryData.normalized_homology_compare {E F : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F}
+    {L : E ≃L[ℝ] F} {s : Set E} (b : Smale.LocalDegree.BoundaryData f L s) (k : ℕ) :
+    SingularMayerVietoris.singularHomologyMap b.normalizedMap k =
+      SingularMayerVietoris.singularHomologyMap
+        (Smale.LinearSphereAction.sphereMap L.toContinuousLinearMap L.injective) k := by
+  change
+    SingularMayerVietoris.singularHomologyMap (Smale.PuncturedRadial.toSphere.comp b.map) k = _
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp, b.homology_compare, ←
+    PeriodTorusHigherHomology.singularHomologyMap_comp,
+    Smale.LinearSphereAction.normalized_linearSphereMap]
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Recognition/Smale12.lean b/LeanPool/HopfProblem/Recognition/Smale12.lean
new file mode 100644
index 000000000..247bb18d2
--- /dev/null
+++ b/LeanPool/HopfProblem/Recognition/Smale12.lean
@@ -0,0 +1,1921 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.CuspFibre.CuspBoundaryTopVanishing
+public import LeanPool.HopfProblem.MainTheorem.SixSphereCube2
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.Recognition.Smale1
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology1
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology2
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology3
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz2
+import all LeanPool.HopfProblem.Hurewicz.SecondHurewicz
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+import all LeanPool.HopfProblem.Recognition.Smale2
+import all LeanPool.HopfProblem.Recognition.Smale3
+import all LeanPool.HopfProblem.Recognition.Smale4
+import all LeanPool.HopfProblem.Recognition.Degree1
+import all LeanPool.HopfProblem.Recognition.Smale6
+import all LeanPool.HopfProblem.Recognition.Smale7
+import all LeanPool.HopfProblem.Recognition.Smale8
+import all LeanPool.HopfProblem.Recognition.Smale9
+import all LeanPool.HopfProblem.Recognition.Smale10
+import all LeanPool.HopfProblem.Recognition.Smale11
+import all LeanPool.HopfProblem.Hurewicz.HigherHurewicz1
+import all LeanPool.HopfProblem.Hurewicz.HigherHurewicz2
+import all LeanPool.HopfProblem.CuspFibre.CuspBoundaryTopVanishing
+import all LeanPool.HopfProblem.MainTheorem.SixSphereCube2
+
+/-!
+# Hopf problem: recognition · smale 12
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem Smale.LocalDegree.BoundaryData.normalized_homology_eq_sign_smul {F : Type}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (n : ℕ) {f : EuclideanSpace ℝ (Fin (n + 2)) → F}
+    {L : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] F} {s : Set (EuclideanSpace ℝ (Fin (n + 2)))}
+    (b : Smale.LocalDegree.BoundaryData f L s) (B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] F)
+    (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 1)) (k + 1)) :
+    SingularMayerVietoris.singularHomologyMap b.normalizedMap (k + 1) a =
+      (SignType.sign (L.trans B.symm).toLinearEquiv.toLinearMap.det : ℤ) •
+        SingularMayerVietoris.singularHomologyMap
+          (Smale.LinearSphereAction.sphereMap B.toContinuousLinearMap B.injective) (k + 1) a := by
+  rw [b.normalized_homology_compare]
+  exact Smale.LinearSphereAction.homology_relative_sign n L B k a
+
+private def Smale.SphereNormalCoordinates.chartJacobian {V F : Type} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] [NormedAddCommGroup F] [NormedSpace ℝ F] {m : ℕ}
+    [Fact (Module.finrank ℝ V = m + 1)]
+    (c :
+      PartialDiffeomorph 𝓘(ℝ, EuclideanSpace ℝ (Fin m)) (𝓡 m) (EuclideanSpace ℝ (Fin m))
+        (Metric.sphere (0 : V) 1) ∞)
+    (j : (ℝ × F) ≃L[ℝ] V) (B : EuclideanSpace ℝ (Fin m) ≃L[ℝ] F) (z : EuclideanSpace ℝ (Fin m)) :
+    ℝ :=
+  let j' := (ContinuousLinearEquiv.prodCongr (ContinuousLinearEquiv.refl ℝ ℝ) B).trans j
+  ((chartRadialFrame c z).comp j'.symm.toContinuousLinearMap).det
+
+private theorem
+    Smale.SphereNormalCoordinates.chartJacobian_ne_zero {V F : Type} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] [FiniteDimensional ℝ V] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    {m : ℕ} [Fact (Module.finrank ℝ V = m + 1)]
+    (c :
+      PartialDiffeomorph 𝓘(ℝ, EuclideanSpace ℝ (Fin m)) (𝓡 m) (EuclideanSpace ℝ (Fin m))
+        (Metric.sphere (0 : V) 1) ∞)
+    (j : (ℝ × F) ≃L[ℝ] V) (B : EuclideanSpace ℝ (Fin m) ≃L[ℝ] F) {z : EuclideanSpace ℝ (Fin m)}
+    (hz : z ∈ c.source) : chartJacobian c j B z ≠ 0 :=
+  (Smale.RegularValues.bijective_iff_det_ne_zero _).mp
+    ((bijective_chartRadialFrame c hz).comp
+      ((ContinuousLinearEquiv.prodCongr (ContinuousLinearEquiv.refl ℝ ℝ) B).trans
+          j).symm.bijective)
+
+private theorem
+    Smale.SphereNormalCoordinates.chartJacobian_factor {V F : Type} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] [NormedAddCommGroup F] [NormedSpace ℝ F] {m : ℕ}
+    [Fact (Module.finrank ℝ V = m + 1)]
+    (c :
+      PartialDiffeomorph 𝓘(ℝ, EuclideanSpace ℝ (Fin m)) (𝓡 m) (EuclideanSpace ℝ (Fin m))
+        (Metric.sphere (0 : V) 1) ∞)
+    (j : (ℝ × F) ≃L[ℝ] V) (B : EuclideanSpace ℝ (Fin m) ≃L[ℝ] F) {z : EuclideanSpace ℝ (Fin m)}
+    (hz : z ∈ c.source) (f : Metric.sphere (0 : V) 1 → F)
+    (hf : MDifferentiableAt (𝓡 m) 𝓘(ℝ, F) f (c z))
+    (hA : (mfderiv (𝓡 m) 𝓘(ℝ, F) f (c z)).IsInvertible) :
+    normalJacobian j (c z) (mfderiv (𝓡 m) 𝓘(ℝ, F) f (c z)) *
+        (B.symm.toContinuousLinearMap.comp (fderiv ℝ (f ∘ c) z)).det =
+      chartJacobian c j B z := by
+  let A : EuclideanSpace ℝ (Fin m) →L[ℝ] F := mfderiv (𝓡 m) 𝓘(ℝ, F) f (c z)
+  let C : EuclideanSpace ℝ (Fin m) →L[ℝ] EuclideanSpace ℝ (Fin m) :=
+    mfderiv 𝓘(ℝ, EuclideanSpace ℝ (Fin m)) (𝓡 m) c z
+  let j' := (ContinuousLinearEquiv.prodCongr (ContinuousLinearEquiv.refl ℝ ℝ) B).trans j
+  have hd : fderiv ℝ (f ∘ c) z = A.comp C := by
+    have h := mfderiv_comp z hf (c.mdifferentiableAt (by simp) hz)
+    rw [mfderiv_eq_fderiv] at h
+    exact h
+  have hB : (B.symm.toContinuousLinearMap.comp A).IsInvertible :=
+    (show B.symm.toContinuousLinearMap.IsInvertible from ⟨B.symm, rfl⟩).comp hA
+  have h := normalJacobian_mul_chartDet j' (c z) (B.symm.toContinuousLinearMap.comp A) hB C
+  rw [normalJacobian_change_normal_model j B (c z) A hA] at h
+  change normalJacobian j (c z) A * _ = _
+  rw [hd]
+  rw [← ContinuousLinearMap.comp_assoc]
+  apply h.trans
+  unfold chartJacobian
+  rw [chartRadialFrame_eq c hz]
+
+private theorem Smale.SphereNormalCoordinates.sign_factor_mo1973_5719 {a b c : ℝ} (hb : b ≠ 0)
+    (h : a * b = c) : SignType.sign c * SignType.sign b = SignType.sign a := by
+  have hsq : SignType.sign b * SignType.sign b = 1 := by
+    rw [← sign_mul]
+    exact sign_eq_one_iff.mpr (mul_self_pos.mpr hb)
+  rw [← h, sign_mul, mul_assoc, hsq, mul_one]
+
+private theorem Smale.SphereNormalCoordinates.chartJacobian_sign_factor {V F : Type}
+    [NormedAddCommGroup V] [InnerProductSpace ℝ V] [FiniteDimensional ℝ V] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {m : ℕ} [Fact (Module.finrank ℝ V = m + 1)]
+    (c :
+      PartialDiffeomorph 𝓘(ℝ, EuclideanSpace ℝ (Fin m)) (𝓡 m) (EuclideanSpace ℝ (Fin m))
+        (Metric.sphere (0 : V) 1) ∞)
+    (j : (ℝ × F) ≃L[ℝ] V) (B : EuclideanSpace ℝ (Fin m) ≃L[ℝ] F) {z : EuclideanSpace ℝ (Fin m)}
+    (hz : z ∈ c.source) (f : Metric.sphere (0 : V) 1 → F)
+    (hf : MDifferentiableAt (𝓡 m) 𝓘(ℝ, F) f (c z))
+    (hA : (mfderiv (𝓡 m) 𝓘(ℝ, F) f (c z)).IsInvertible) :
+    SignType.sign (chartJacobian c j B z) *
+        SignType.sign (B.symm.toContinuousLinearMap.comp (fderiv ℝ (f ∘ c) z)).det =
+      SignType.sign (normalJacobian j (c z) (mfderiv (𝓡 m) 𝓘(ℝ, F) f (c z))) := by
+  have h := chartJacobian_factor c j B hz f hf hA
+  apply sign_factor_mo1973_5719 _ h
+  intro hd
+  rw [hd, MulZeroClass.mul_zero] at h
+  exact chartJacobian_ne_zero c j B hz h.symm
+
+private theorem Smale.SpherePoint.chart_radial_frame_det {V : Type} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] {m : ℕ} [Fact (Module.finrank ℝ V = m + 1)]
+    (x y : Metric.sphere (0 : V) 1) (R : V ≃ₗᵢ[ℝ] V) (he : sphereHomeomorph R x = y)
+    (j : (ℝ × EuclideanSpace ℝ (Fin m)) ≃L[ℝ] V) :
+    ((Smale.SphereNormalCoordinates.chartRadialFrame (Smale.NativeParametrization.centered y)
+                0).comp
+            j.symm.toContinuousLinearMap).det *
+        (Smale.NativeChartTransition.linear x y (sphereDiffeomorph (n := m) R)
+            he).toLinearEquiv.toLinearMap.det =
+      R.toLinearEquiv.toLinearMap.det *
+        ((Smale.SphereNormalCoordinates.chartRadialFrame (Smale.NativeParametrization.centered x)
+                0).comp
+            j.symm.toContinuousLinearMap).det := by
+  let L := Smale.NativeChartTransition.linear x y (sphereDiffeomorph (n := m) R) he
+  let Q := (ContinuousLinearMap.id ℝ ℝ).prodMap L.toContinuousLinearMap
+  let T : V →L[ℝ] V := j.toContinuousLinearMap.comp (Q.comp j.symm.toContinuousLinearMap)
+  have hdetT : T.det = L.toLinearEquiv.toLinearMap.det := by
+    have hconj : T.det = Q.det := LinearMap.det_conj Q.toLinearMap j.toLinearEquiv
+    rw [hconj]
+    change (LinearMap.prodMap (LinearMap.id : ℝ →ₗ[ℝ] ℝ) L.toLinearEquiv.toLinearMap).det = _
+    rw [LinearMap.det_prodMap, LinearMap.det_id, one_mul]
+  have hfactor :
+    ((Smale.SphereNormalCoordinates.chartRadialFrame (Smale.NativeParametrization.centered y)
+                0).comp
+            j.symm.toContinuousLinearMap).comp
+        T =
+      R.toContinuousLinearEquiv.toContinuousLinearMap.comp
+        ((Smale.SphereNormalCoordinates.chartRadialFrame (Smale.NativeParametrization.centered x)
+              0).comp
+          j.symm.toContinuousLinearMap) := by
+    apply ContinuousLinearMap.ext
+    intro v
+    change
+      Smale.SphereNormalCoordinates.chartRadialFrame (Smale.NativeParametrization.centered y) 0
+          (j.symm (j (Q (j.symm v)))) =
+        R
+          (Smale.SphereNormalCoordinates.chartRadialFrame (Smale.NativeParametrization.centered x)
+            0 (j.symm v))
+    rw [j.symm_apply_apply]
+    exact
+      congrArg (fun A : (ℝ × EuclideanSpace ℝ (Fin m)) →L[ℝ] V => A (j.symm v))
+        (chart_radial_frame_comp x y R he)
+  calc
+    _ =
+        (((Smale.SphereNormalCoordinates.chartRadialFrame (Smale.NativeParametrization.centered y)
+                    0).comp
+                j.symm.toContinuousLinearMap).comp
+            T).det := by
+      rw [hdetT.symm]
+      exact (LinearMap.det_comp _ _).symm
+    _ = _ := (congrArg ContinuousLinearMap.det hfactor).trans (LinearMap.det_comp _ _)
+
+private theorem Smale.SpherePoint.chartJacobian_transport {V : Type} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] {m : ℕ} [Fact (Module.finrank ℝ V = m + 1)]
+    (x y : Metric.sphere (0 : V) 1) (R : V ≃ₗᵢ[ℝ] V) (he : sphereHomeomorph R x = y) {F : Type}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (j : (ℝ × F) ≃L[ℝ] V)
+    (B : EuclideanSpace ℝ (Fin m) ≃L[ℝ] F) :
+    Smale.SphereNormalCoordinates.chartJacobian (Smale.NativeParametrization.centered y) j B 0 *
+        (Smale.NativeChartTransition.linear x y (sphereDiffeomorph (n := m) R)
+            he).toLinearEquiv.toLinearMap.det =
+      R.toLinearEquiv.toLinearMap.det *
+        Smale.SphereNormalCoordinates.chartJacobian (Smale.NativeParametrization.centered x) j B
+          0 :=
+  chart_radial_frame_det x y R he
+    ((ContinuousLinearEquiv.prodCongr (ContinuousLinearEquiv.refl ℝ ℝ) B).trans j)
+
+private theorem Smale.SpherePoint.chartJacobian_transport_sign {V : Type} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] {m : ℕ} [Fact (Module.finrank ℝ V = m + 1)]
+    (x y : Metric.sphere (0 : V) 1) (R : V ≃ₗᵢ[ℝ] V) (he : sphereHomeomorph R x = y) {F : Type}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (hR : R.toLinearEquiv.toLinearMap.det = 1)
+    (j : (ℝ × F) ≃L[ℝ] V) (B : EuclideanSpace ℝ (Fin m) ≃L[ℝ] F) :
+    SignType.sign
+          (Smale.SphereNormalCoordinates.chartJacobian (Smale.NativeParametrization.centered y) j
+            B 0) *
+        SignType.sign
+          (Smale.NativeChartTransition.linear x y (sphereDiffeomorph (n := m) R)
+              he).toLinearEquiv.toLinearMap.det =
+      SignType.sign
+        (Smale.SphereNormalCoordinates.chartJacobian (Smale.NativeParametrization.centered x) j B
+          0) := by
+  have h := chartJacobian_transport x y R he j B
+  rw [hR, one_mul] at h
+  rw [← sign_mul, h]
+
+private def Smale.CoverNaturality.overlapCoordinateMap {X Y S T : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] [TopologicalSpace S] [TopologicalSpace T] (U V : Set X) (U' V' : Set Y)
+    (f : C(X, Y)) (hfU : Set.MapsTo f U U') (hfV : Set.MapsTo f V V') (eS : S ≃ₕ ↥(U ∩ V))
+    (eT : T ≃ₕ ↥(U' ∩ V')) : C(S, T) :=
+  eT.invFun.comp
+    ((mapOn f (U ∩ V) (U' ∩ V') (map_intersection U V U' V' f hfU hfV)).comp eS.toFun)
+
+private theorem Smale.CoverNaturality.normalized_connecting_naturality {X Y S T : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace S] [TopologicalSpace T]
+    (U V : Set X) (U' V' : Set Y) (f : C(X, Y)) (hfU : Set.MapsTo f U U')
+    (hfV : Set.MapsTo f V V') (eS : S ≃ₕ ↥(U ∩ V)) (eT : T ≃ₕ ↥(U' ∩ V')) (hU : IsOpen U)
+    (hV : IsOpen V) (hc : U ∪ V = Set.univ) (hU' : IsOpen U') (hV' : IsOpen V')
+    (hc' : U' ∪ V' = Set.univ) (k : ℕ) (a : SingularMayerVietoris.SingularHomology X (k + 1)) :
+    SingularMayerVietoris.singularHomologyMap (overlapCoordinateMap U V U' V' f hfU hfV eS eT) k
+        ((PeriodTorusHigherHomology.homotopyEquivHomologyEquiv eS k).symm
+          (SingularMayerVietoris.connectingHomomorphism U V hU hV hc k a)) =
+      (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv eT k).symm
+        (SingularMayerVietoris.connectingHomomorphism U' V' hU' hV' hc' k
+          (SingularMayerVietoris.singularHomologyMap f (k + 1) a)) := by
+  have hS :
+    SingularMayerVietoris.singularHomologyMap eS.toFun k
+        ((PeriodTorusHigherHomology.homotopyEquivHomologyEquiv eS k).symm
+          (SingularMayerVietoris.connectingHomomorphism U V hU hV hc k a)) =
+      SingularMayerVietoris.connectingHomomorphism U V hU hV hc k a :=
+    (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv eS k).apply_symm_apply _
+  unfold overlapCoordinateMap
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply,
+    PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply, hS,
+    connecting_naturality_apply U V U' V' f hfU hfV hU hV hc hU' hV' hc',
+    PeriodTorusHigherHomology.homotopyEquivHomologyEquiv_symm_apply]
+  rfl
+
+private theorem
+    Smale.LocalDegree.PointTransition.maps_point_complement {M : Type} [TopologicalSpace M]
+    (e : M ≃ₜ M) (x y : M) (he : e x = y) : Set.MapsTo e { x }ᶜ { y }ᶜ := by
+  intro z hz h
+  exact hz (e.injective (h.trans he.symm))
+
+private def Smale.LocalDegree.PointTransition.coordinateMap {E F G M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x y : M)
+    {fx : M → F} {fy : M → G} {Lx : E ≃L[ℝ] F} {Ly : E ≃L[ℝ] G} {Wx Wy : Set M}
+    (dx :
+      Smale.LocalDegree.NeighborhoodData (fx ∘ Smale.NativeParametrization.centered (D := E) x) Lx
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' Wx))
+    (dy :
+      Smale.LocalDegree.NeighborhoodData (fy ∘ Smale.NativeParametrization.centered (D := E) y) Ly
+        ((Smale.NativeParametrization.centered (D := E) y).source ∩
+          Smale.NativeParametrization.centered (D := E) y ⁻¹' Wy))
+    (e : M ≃ₜ M) (he : e x = y)
+    (hV :
+      Set.MapsTo e (Smale.LocalDegree.NativeNeighborhood.openSet x dx)
+        (Smale.LocalDegree.NativeNeighborhood.openSet y dy)) :
+    C(Metric.sphere (0 : E) 1, Metric.sphere (0 : E) 1) :=
+  Smale.CoverNaturality.overlapCoordinateMap { x }ᶜ
+    (Smale.LocalDegree.NativeNeighborhood.openSet x dx) { y }ᶜ
+    (Smale.LocalDegree.NativeNeighborhood.openSet y dy) e.toHomotopyEquiv.toFun
+    (maps_point_complement e x y he) hV
+    (Smale.LocalDegree.NativeNeighborhood.overlapSphereEquiv x dx)
+    (Smale.LocalDegree.NativeNeighborhood.overlapSphereEquiv y dy)
+
+private theorem Smale.LocalDegree.PointTransition.coordinateMap_coe {E F G M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (x y : M) {fx : M → F} {fy : M → G} {Lx : E ≃L[ℝ] F} {Ly : E ≃L[ℝ] G}
+    {Wx Wy : Set M}
+    (dx :
+      Smale.LocalDegree.NeighborhoodData (fx ∘ Smale.NativeParametrization.centered (D := E) x) Lx
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' Wx))
+    (dy :
+      Smale.LocalDegree.NeighborhoodData (fy ∘ Smale.NativeParametrization.centered (D := E) y) Ly
+        ((Smale.NativeParametrization.centered (D := E) y).source ∩
+          Smale.NativeParametrization.centered (D := E) y ⁻¹' Wy))
+    (e : M ≃ₜ M) (he : e x = y)
+    (hV :
+      Set.MapsTo e (Smale.LocalDegree.NativeNeighborhood.openSet x dx)
+        (Smale.LocalDegree.NativeNeighborhood.openSet y dy))
+    (u : Metric.sphere (0 : E) 1) :
+    (coordinateMap x y dx dy e he hV u).val =
+      ‖(Smale.NativeParametrization.centered (D := E) y).symm
+              (e
+                (Smale.NativeParametrization.centered (D := E) x
+                  (dx.innerBoundary.radius • (u : E))))‖⁻¹ •
+        (Smale.NativeParametrization.centered (D := E) y).symm
+          (e
+            (Smale.NativeParametrization.centered (D := E) x
+              (dx.innerBoundary.radius • (u : E)))) :=
+  rfl
+
+private theorem Smale.LocalDegree.PointTransition.connecting_naturality {E F G M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (x y : M) {fx : M → F} {fy : M → G} {Lx : E ≃L[ℝ] F} {Ly : E ≃L[ℝ] G}
+    {Wx Wy : Set M}
+    (dx :
+      Smale.LocalDegree.NeighborhoodData (fx ∘ Smale.NativeParametrization.centered (D := E) x) Lx
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' Wx))
+    (dy :
+      Smale.LocalDegree.NeighborhoodData (fy ∘ Smale.NativeParametrization.centered (D := E) y) Ly
+        ((Smale.NativeParametrization.centered (D := E) y).source ∩
+          Smale.NativeParametrization.centered (D := E) y ⁻¹' Wy))
+    (e : M ≃ₜ M) (he : e x = y)
+    (hV :
+      Set.MapsTo e (Smale.LocalDegree.NativeNeighborhood.openSet x dx)
+        (Smale.LocalDegree.NativeNeighborhood.openSet y dy))
+    [T1Space M] (k : ℕ) (a : SingularMayerVietoris.SingularHomology M (k + 1)) :
+    SingularMayerVietoris.singularHomologyMap (coordinateMap x y dx dy e he hV) k
+        (Smale.LocalDegree.NativeNeighborhood.sphereConnecting x dx k a) =
+      Smale.LocalDegree.NativeNeighborhood.sphereConnecting y dy k
+        (SingularMayerVietoris.singularHomologyMap e.toHomotopyEquiv.toFun (k + 1) a) :=
+  Smale.CoverNaturality.normalized_connecting_naturality { x }ᶜ
+    (Smale.LocalDegree.NativeNeighborhood.openSet x dx) { y }ᶜ
+    (Smale.LocalDegree.NativeNeighborhood.openSet y dy) e.toHomotopyEquiv.toFun
+    (maps_point_complement e x y he) hV
+    (Smale.LocalDegree.NativeNeighborhood.overlapSphereEquiv x dx)
+    (Smale.LocalDegree.NativeNeighborhood.overlapSphereEquiv y dy) isClosed_singleton.isOpen_compl
+    (Smale.LocalDegree.NativeNeighborhood.isOpen_openSet x dx)
+    (Smale.LocalDegree.NativeNeighborhood.singlePoint_cover x dx) isClosed_singleton.isOpen_compl
+    (Smale.LocalDegree.NativeNeighborhood.isOpen_openSet y dy)
+    (Smale.LocalDegree.NativeNeighborhood.singlePoint_cover y dy) k a
+
+private def Smale.LocalDegree.NeighborhoodData.restrictRadius {E F : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F} {L : E ≃L[ℝ] F}
+    {s : Set E} (d : Smale.LocalDegree.NeighborhoodData f L s) (r : ℝ) (hr : 0 < r)
+    (hrR : r ≤ d.radius) : Smale.LocalDegree.NeighborhoodData f L s
+    where
+  radius := r
+  radius_pos := hr
+  center_zero := d.center_zero
+  ball_subset := (Metric.closedBall_subset_closedBall hrR).trans d.ball_subset
+  continuous := d.continuous.mono (Metric.closedBall_subset_closedBall hrR)
+  remainder_bound x hx := d.remainder_bound x (Metric.closedBall_subset_closedBall hrR hx)
+
+private theorem Smale.LocalDegree.NativeNeighborhood.identity_center_mo1973_5731 {M : Type}
+    [TopologicalSpace M] (x : M) : (Homeomorph.refl M) x = x :=
+  rfl
+
+private theorem Smale.LocalDegree.NativeNeighborhood.openSet_restrictRadius_subset {E F : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {M : Type}
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x : M) {f : M → F}
+    {L : E ≃L[ℝ] F} {W : Set M}
+    (d :
+      Smale.LocalDegree.NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) x) L
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' W))
+    (r : ℝ) (hr : 0 < r) (hrR : r ≤ d.radius) :
+    openSet x (d.restrictRadius r hr hrR) ⊆ openSet x d := by
+  change
+    (Smale.NativeParametrization.centered (D := E) x).toOpenPartialHomeomorph '' Metric.ball 0 r ⊆
+      (Smale.NativeParametrization.centered (D := E) x).toOpenPartialHomeomorph ''
+        Metric.ball 0 d.radius
+  exact Set.image_mono (Metric.ball_subset_ball hrR)
+
+private theorem Smale.LocalDegree.NativeNeighborhood.mapsTo_restrictRadius {E F : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {M : Type}
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x : M) {f : M → F}
+    {L : E ≃L[ℝ] F} {W : Set M}
+    (d :
+      Smale.LocalDegree.NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) x) L
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' W))
+    (r : ℝ) (hr : 0 < r) (hrR : r ≤ d.radius) :
+    Set.MapsTo (Homeomorph.refl M) (openSet x (d.restrictRadius r hr hrR)) (openSet x d) :=
+  openSet_restrictRadius_subset x d r hr hrR
+
+private theorem Smale.LocalDegree.NativeNeighborhood.coordinateMap_restrictRadius {E F : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {M : Type}
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x : M) {f : M → F}
+    {L : E ≃L[ℝ] F} {W : Set M}
+    (d :
+      Smale.LocalDegree.NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) x) L
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' W))
+    (r : ℝ) (hr : 0 < r) (hrR : r ≤ d.radius) :
+    Smale.LocalDegree.PointTransition.coordinateMap x x (d.restrictRadius r hr hrR) d
+        (Homeomorph.refl M) (identity_center_mo1973_5731 x) (mapsTo_restrictRadius x d r hr hrR) =
+      ContinuousMap.id (Metric.sphere (0 : E) 1) := by
+  apply ContinuousMap.ext
+  intro u
+  apply Subtype.ext
+  rw [Smale.LocalDegree.PointTransition.coordinateMap_coe]
+  let ds := d.restrictRadius r hr hrR
+  change
+    ‖(Smale.NativeParametrization.centered (D := E) x).symm
+              (Smale.NativeParametrization.centered (D := E) x
+                (ds.innerBoundary.radius • (u : E)))‖⁻¹ •
+        (Smale.NativeParametrization.centered (D := E) x).symm
+          (Smale.NativeParametrization.centered (D := E) x (ds.innerBoundary.radius • (u : E))) =
+      (u : E)
+  have hu : ds.innerBoundary.radius • (u : E) ∈ (Smale.NativeParametrization.centered x).source :=
+    closedBall_subset_source x ds (Metric.ball_subset_closedBall (ds.innerBoundary_mem_ball u))
+  have hleft :
+    (Smale.NativeParametrization.centered (D := E) x).symm
+        (Smale.NativeParametrization.centered (D := E) x (ds.innerBoundary.radius • (u : E))) =
+      ds.innerBoundary.radius • (u : E) :=
+    (Smale.NativeParametrization.centered x).left_inv' hu
+  rw [hleft, Smale.LocalDegree.norm_radius_smul _ ds.innerBoundary.radius_pos,
+    inv_smul_smul₀ ds.innerBoundary.radius_pos.ne']
+
+private theorem Smale.LocalDegree.NativeNeighborhood.sphereConnecting_restrictRadius {E F : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {M : Type}
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x : M) {f : M → F}
+    {L : E ≃L[ℝ] F} {W : Set M}
+    (d :
+      Smale.LocalDegree.NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) x) L
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' W))
+    (r : ℝ) (hr : 0 < r) (hrR : r ≤ d.radius) [T1Space M] (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology M (k + 1)) :
+    sphereConnecting x (d.restrictRadius r hr hrR) k a = sphereConnecting x d k a := by
+  have h :=
+    Smale.LocalDegree.PointTransition.connecting_naturality x x (d.restrictRadius r hr hrR) d
+      (Homeomorph.refl M) (identity_center_mo1973_5731 x) (mapsTo_restrictRadius x d r hr hrR) k a
+  rw [coordinateMap_restrictRadius, PeriodTorusHigherHomology.singularHomologyMap_id,
+    LinearMap.id_apply] at h
+  change
+    sphereConnecting x (d.restrictRadius r hr hrR) k a =
+      sphereConnecting x d k
+        (SingularMayerVietoris.singularHomologyMap (ContinuousMap.id M) (k + 1) a) at h
+  rwa [PeriodTorusHigherHomology.singularHomologyMap_id, LinearMap.id_apply] at h
+
+private theorem Smale.LocalDegree.NativeNeighborhood.sphereConnecting_eq {E F : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {M : Type}
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x : M) {f : M → F}
+    {L : E ≃L[ℝ] F} {W : Set M}
+    (d :
+      Smale.LocalDegree.NeighborhoodData (f ∘ Smale.NativeParametrization.centered (D := E) x) L
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' W))
+    [T1Space M] {F' : Type} [NormedAddCommGroup F'] [NormedSpace ℝ F'] {f' : M → F'}
+    {L' : E ≃L[ℝ] F'} {W' : Set M}
+    (d' :
+      Smale.LocalDegree.NeighborhoodData (f' ∘ Smale.NativeParametrization.centered (D := E) x) L'
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' W'))
+    (k : ℕ) (a : SingularMayerVietoris.SingularHomology M (k + 1)) :
+    sphereConnecting x d k a = sphereConnecting x d' k a := by
+  let ρ := Min.min d.radius d'.radius
+  have hρ : 0 < ρ := lt_min d.radius_pos d'.radius_pos
+  rw [← sphereConnecting_restrictRadius x d ρ hρ (min_le_left _ _) k a, ←
+    sphereConnecting_restrictRadius x d' ρ hρ (min_le_right _ _) k a]
+  rfl
+
+private theorem Smale.LocalDegree.PointTransition.coordinateMap_eq_boundary {E G M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x y : M) (e : M ≃ₜ M)
+    (he : e x = y) {fy : M → G} {Ly : E ≃L[ℝ] G} {Wy : Set M}
+    (dy :
+      Smale.LocalDegree.NeighborhoodData (fy ∘ Smale.NativeParametrization.centered (D := E) y) Ly
+        ((Smale.NativeParametrization.centered (D := E) y).source ∩
+          Smale.NativeParametrization.centered (D := E) y ⁻¹' Wy))
+    {Lx : E ≃L[ℝ] E} {Wx : Set M}
+    (dx :
+      Smale.LocalDegree.NeighborhoodData
+        (((Smale.NativeParametrization.centered (D := E) y).symm ∘ e) ∘
+          Smale.NativeParametrization.centered (D := E) x)
+        Lx
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' Wx))
+    (hV :
+      Set.MapsTo e (Smale.LocalDegree.NativeNeighborhood.openSet x dx)
+        (Smale.LocalDegree.NativeNeighborhood.openSet y dy)) :
+    coordinateMap x y dx dy e he hV = dx.innerBoundary.normalizedMap :=
+  rfl
+
+private theorem Smale.LocalDegree.PointTransition.coordinateMap_homology {E G M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x y : M) (e : M ≃ₜ M)
+    (he : e x = y) {fy : M → G} {Ly : E ≃L[ℝ] G} {Wy : Set M}
+    (dy :
+      Smale.LocalDegree.NeighborhoodData (fy ∘ Smale.NativeParametrization.centered (D := E) y) Ly
+        ((Smale.NativeParametrization.centered (D := E) y).source ∩
+          Smale.NativeParametrization.centered (D := E) y ⁻¹' Wy))
+    {Lx : E ≃L[ℝ] E} {Wx : Set M}
+    (dx :
+      Smale.LocalDegree.NeighborhoodData
+        (((Smale.NativeParametrization.centered (D := E) y).symm ∘ e) ∘
+          Smale.NativeParametrization.centered (D := E) x)
+        Lx
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' Wx))
+    (hV :
+      Set.MapsTo e (Smale.LocalDegree.NativeNeighborhood.openSet x dx)
+        (Smale.LocalDegree.NativeNeighborhood.openSet y dy))
+    (k : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (coordinateMap x y dx dy e he hV) k =
+      SingularMayerVietoris.singularHomologyMap
+        (Smale.LinearSphereAction.sphereMap Lx.toContinuousLinearMap Lx.injective) k := by
+  rw [coordinateMap_eq_boundary]
+  exact dx.innerBoundary.normalized_homology_compare k
+
+private theorem Smale.LocalDegree.PointTransition.connecting_derivative_naturality {E G M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (x y : M) (e : M ≃ₜ M)
+    (he : e x = y) {fy : M → G} {Ly : E ≃L[ℝ] G} {Wy : Set M}
+    (dy :
+      Smale.LocalDegree.NeighborhoodData (fy ∘ Smale.NativeParametrization.centered (D := E) y) Ly
+        ((Smale.NativeParametrization.centered (D := E) y).source ∩
+          Smale.NativeParametrization.centered (D := E) y ⁻¹' Wy))
+    {Lx : E ≃L[ℝ] E} {Wx : Set M}
+    (dx :
+      Smale.LocalDegree.NeighborhoodData
+        (((Smale.NativeParametrization.centered (D := E) y).symm ∘ e) ∘
+          Smale.NativeParametrization.centered (D := E) x)
+        Lx
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' Wx))
+    (hV :
+      Set.MapsTo e (Smale.LocalDegree.NativeNeighborhood.openSet x dx)
+        (Smale.LocalDegree.NativeNeighborhood.openSet y dy))
+    [T1Space M] {F : Type} [NormedAddCommGroup F] [NormedSpace ℝ F] {f₀ : M → F} {L₀ : E ≃L[ℝ] F}
+    {W₀ : Set M}
+    (d₀ :
+      Smale.LocalDegree.NeighborhoodData (f₀ ∘ Smale.NativeParametrization.centered (D := E) x) L₀
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' W₀))
+    (k : ℕ) (a : SingularMayerVietoris.SingularHomology M (k + 1)) :
+    Smale.LocalDegree.NativeNeighborhood.sphereConnecting y dy k
+        (SingularMayerVietoris.singularHomologyMap e.toHomotopyEquiv.toFun (k + 1) a) =
+      SingularMayerVietoris.singularHomologyMap
+        (Smale.LinearSphereAction.sphereMap Lx.toContinuousLinearMap Lx.injective) k
+        (Smale.LocalDegree.NativeNeighborhood.sphereConnecting x d₀ k a) := by
+  have h := connecting_naturality x y dx dy e he hV k a
+  rw [coordinateMap_homology x y e he dy dx hV k,
+    Smale.LocalDegree.NativeNeighborhood.sphereConnecting_eq x dx d₀ k a] at h
+  exact h.symm
+
+private theorem
+    Smale.LocalDegree.pointConnecting_diffeomorph {E F G M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T1Space M] (x y : M) {fx : M → F} {fy : M → G} {Lx : E ≃L[ℝ] F}
+    {Ly : E ≃L[ℝ] G} {Wx Wy : Set M}
+    (dx :
+      NeighborhoodData (fx ∘ Smale.NativeParametrization.centered (D := E) x) Lx
+        ((Smale.NativeParametrization.centered (D := E) x).source ∩
+          Smale.NativeParametrization.centered (D := E) x ⁻¹' Wx))
+    (dy :
+      NeighborhoodData (fy ∘ Smale.NativeParametrization.centered (D := E) y) Ly
+        ((Smale.NativeParametrization.centered (D := E) y).source ∩
+          Smale.NativeParametrization.centered (D := E) y ⁻¹' Wy))
+    (e : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞) (he : e x = y) (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology M (k + 1)) :
+    NativeNeighborhood.sphereConnecting y dy k
+        (SingularMayerVietoris.singularHomologyMap e.toHomeomorph.toHomotopyEquiv.toFun (k + 1)
+          a) =
+      SingularMayerVietoris.singularHomologyMap
+        (Smale.LinearSphereAction.sphereMap
+          (Smale.NativeChartTransition.linear x y e he).toContinuousLinearMap
+          (Smale.NativeChartTransition.linear x y e he).injective)
+        k (NativeNeighborhood.sphereConnecting x dx k a) := by
+  let W := e.toHomeomorph ⁻¹' NativeNeighborhood.openSet y dy
+  have hW : W ∈ 𝓝 x := by
+    apply e.toHomeomorph.continuous.continuousAt
+    have hy :=
+      (NativeNeighborhood.isOpen_openSet y dy).mem_nhds
+        (NativeNeighborhood.center_mem_openSet y dy)
+    exact he.symm ▸ hy
+  obtain ⟨b⟩ := Smale.NativeChartTransition.nonempty_neighborhoodData x y e he W hW
+  have hV :
+    Set.MapsTo e.toHomeomorph (NativeNeighborhood.openSet x b)
+      (NativeNeighborhood.openSet y dy) :=
+    NativeNeighborhood.openSet_subset x b
+  exact PointTransition.connecting_derivative_naturality x y e.toHomeomorph he dy b hV dx k a
+
+private theorem Smale.SpherePoint.instLocal1 (n : ℕ) :
+    Fact (Module.finrank ℝ (EuclideanSpace ℝ (Fin (n + 3))) = (n + 2) + 1) :=
+  ⟨by simp⟩
+
+attribute [local instance] Smale.SpherePoint.instLocal1 in
+private def Smale.SpherePoint.pointDiffeomorph (n : ℕ) (x y : SphereHomology.UnitSphere (n + 2)) :
+    Diffeomorph (𝓡 (n + 2)) (𝓡 (n + 2)) (SphereHomology.UnitSphere (n + 2))
+      (SphereHomology.UnitSphere (n + 2)) ∞ :=
+  sphereDiffeomorph (positiveTransport (n + 1) x y)
+
+attribute [local instance] Smale.SpherePoint.instLocal1 in
+private theorem Smale.SpherePoint.pointDiffeomorph_apply (n : ℕ)
+    (x y : SphereHomology.UnitSphere (n + 2)) : pointDiffeomorph n x y x = y :=
+  positiveTransport_moves (n + 1) x y
+
+attribute [local instance] Smale.SpherePoint.instLocal1 in
+private def Smale.SpherePoint.pointChartLinear (n : ℕ) (x y : SphereHomology.UnitSphere (n + 2)) :
+    EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] EuclideanSpace ℝ (Fin (n + 2)) :=
+  Smale.NativeChartTransition.linear x y (pointDiffeomorph n x y) (pointDiffeomorph_apply n x y)
+
+attribute [local instance] Smale.SpherePoint.instLocal1 in
+private theorem
+    Smale.SpherePoint.pointClass_sign_compare (n : ℕ) {F G : Type} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    (x y : SphereHomology.UnitSphere (n + 2)) {fx : SphereHomology.UnitSphere (n + 2) → F}
+    {fy : SphereHomology.UnitSphere (n + 2) → G} {Lx : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] F}
+    {Ly : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] G}
+    {Wx Wy : Set (SphereHomology.UnitSphere (n + 2))}
+    (dx :
+      Smale.LocalDegree.NeighborhoodData (fx ∘ Smale.NativeParametrization.centered x) Lx
+        ((Smale.NativeParametrization.centered x).source ∩
+          Smale.NativeParametrization.centered x ⁻¹' Wx))
+    (dy :
+      Smale.LocalDegree.NeighborhoodData (fy ∘ Smale.NativeParametrization.centered y) Ly
+        ((Smale.NativeParametrization.centered y).source ∩
+          Smale.NativeParametrization.centered y ⁻¹' Wy))
+    (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 2)) (k + 2)) :
+    Smale.LocalDegree.NativeNeighborhood.sphereConnecting y dy (k + 1) a =
+      (SignType.sign (pointChartLinear n x y).toLinearEquiv.toLinearMap.det : ℤ) •
+        Smale.LocalDegree.NativeNeighborhood.sphereConnecting x dx (k + 1) a := by
+  have h :=
+    Smale.LocalDegree.pointConnecting_diffeomorph x y dx dy (pointDiffeomorph n x y)
+      (pointDiffeomorph_apply n x y) (k + 1) a
+  have hid :
+    SingularMayerVietoris.singularHomologyMap
+        (pointDiffeomorph n x y).toHomeomorph.toHomotopyEquiv.toFun (k + 2) a =
+      a :=
+    positiveTransport_homology (n + 1) x y (k + 2) a
+  rw [hid] at h
+  apply h.trans
+  exact Smale.LinearSphereAction.homology_eq_sign_smul n (pointChartLinear n x y) k _
+
+private def
+    Smale.SpherePoint.punctureHomeomorph {V : Type} [NormedAddCommGroup V] [InnerProductSpace ℝ V]
+    {n : ℕ} [hdim : Fact (Module.finrank ℝ V = n + 1)] (x : Metric.sphere (0 : V) 1) :
+    ↥({ x }ᶜ : Set (Metric.sphere (0 : V) 1)) ≃ₜ EuclideanSpace ℝ (Fin n) :=
+  (Homeomorph.setCongr (stereographic'_source (n := n) x).symm).trans
+    ((stereographic' n x).toHomeomorphSourceTarget.trans
+      ((Homeomorph.setCongr (stereographic'_target x)).trans (Homeomorph.Set.univ _)))
+
+private theorem Smale.SpherePoint.puncture_contractible {V : Type} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] {n : ℕ} [hdim : Fact (Module.finrank ℝ V = n + 1)]
+    (x : Metric.sphere (0 : V) 1) : ContractibleSpace ({ x }ᶜ : Set (Metric.sphere (0 : V) 1)) :=
+  (punctureHomeomorph (n := n) x).contractibleSpace
+
+private def Smale.SpherePoint.connectingHomologyEquiv {V : Type} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] {n : ℕ} [hdim : Fact (Module.finrank ℝ V = n + 1)] {F : Type}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (x : Metric.sphere (0 : V) 1)
+    {f : Metric.sphere (0 : V) 1 → F} {L : EuclideanSpace ℝ (Fin n) ≃L[ℝ] F}
+    {W : Set (Metric.sphere (0 : V) 1)}
+    (d :
+      Smale.LocalDegree.NeighborhoodData
+        (f ∘ Smale.NativeParametrization.centered (D := EuclideanSpace ℝ (Fin n)) x) L
+        ((Smale.NativeParametrization.centered (D := EuclideanSpace ℝ (Fin n)) x).source ∩
+          Smale.NativeParametrization.centered (D := EuclideanSpace ℝ (Fin n)) x ⁻¹' W))
+    (k : ℕ) :
+    SingularMayerVietoris.SingularHomology (Metric.sphere (0 : V) 1) (k + 2) ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (Metric.sphere (0 : EuclideanSpace ℝ (Fin n)) 1)
+        (k + 1) := by
+  let : ContractibleSpace ({ x }ᶜ : Set (Metric.sphere (0 : V) 1)) :=
+    puncture_contractible (n := n) x
+  exact Smale.LocalDegree.NativeNeighborhood.sphereHomologyEquiv x d k
+
+private theorem Smale.SpherePoint.instLocal2 (n : ℕ) :
+    Fact (Module.finrank ℝ (EuclideanSpace ℝ (Fin (n + 3))) = (n + 2) + 1) :=
+  ⟨by simp⟩
+
+attribute [local instance] Smale.SpherePoint.instLocal2 in
+private def Smale.SpherePoint.outwardPointClass (n : ℕ) {F H : Type} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [NormedAddCommGroup H] [NormedSpace ℝ H]
+    (j : (ℝ × H) ≃L[ℝ] EuclideanSpace ℝ (Fin (n + 3)))
+    (B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] H) (x : SphereHomology.UnitSphere (n + 2))
+    {fx : SphereHomology.UnitSphere (n + 2) → F} {Lx : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] F}
+    {Wx : Set (SphereHomology.UnitSphere (n + 2))}
+    (dx :
+      Smale.LocalDegree.NeighborhoodData (fx ∘ Smale.NativeParametrization.centered x) Lx
+        ((Smale.NativeParametrization.centered x).source ∩
+          Smale.NativeParametrization.centered x ⁻¹' Wx))
+    (k : ℕ) :
+    SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 2)) (k + 2) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 1)) (k + 1) :=
+  (SignType.sign
+        (Smale.SphereNormalCoordinates.chartJacobian (Smale.NativeParametrization.centered x) j B
+          0) :
+      ℤ) •
+    Smale.LocalDegree.NativeNeighborhood.sphereConnecting x dx (k + 1)
+
+attribute [local instance] Smale.SpherePoint.instLocal2 in
+private theorem Smale.SpherePoint.outwardPointClass_eq (n : ℕ) {F G H : Type} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup H]
+    [NormedSpace ℝ H] (j : (ℝ × H) ≃L[ℝ] EuclideanSpace ℝ (Fin (n + 3)))
+    (B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] H) (x y : SphereHomology.UnitSphere (n + 2))
+    {fx : SphereHomology.UnitSphere (n + 2) → F} {fy : SphereHomology.UnitSphere (n + 2) → G}
+    {Lx : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] F} {Ly : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] G}
+    {Wx Wy : Set (SphereHomology.UnitSphere (n + 2))}
+    (dx :
+      Smale.LocalDegree.NeighborhoodData (fx ∘ Smale.NativeParametrization.centered x) Lx
+        ((Smale.NativeParametrization.centered x).source ∩
+          Smale.NativeParametrization.centered x ⁻¹' Wx))
+    (dy :
+      Smale.LocalDegree.NeighborhoodData (fy ∘ Smale.NativeParametrization.centered y) Ly
+        ((Smale.NativeParametrization.centered y).source ∩
+          Smale.NativeParametrization.centered y ⁻¹' Wy))
+    (k : ℕ) : outwardPointClass n j B y dy k = outwardPointClass n j B x dx k := by
+  have hs :=
+    chartJacobian_transport_sign x y (positiveTransport (n + 1) x y)
+      (positiveTransport_moves (n + 1) x y) (positiveTransport_det (n + 1) x y) j B
+  have hs' :
+    SignType.sign
+          (Smale.SphereNormalCoordinates.chartJacobian (Smale.NativeParametrization.centered y) j
+            B 0) *
+        SignType.sign (pointChartLinear n x y).toLinearEquiv.toLinearMap.det =
+      SignType.sign
+        (Smale.SphereNormalCoordinates.chartJacobian (Smale.NativeParametrization.centered x) j B
+          0) :=
+    hs
+  apply LinearMap.ext
+  intro a
+  change
+    (SignType.sign
+            (Smale.SphereNormalCoordinates.chartJacobian (Smale.NativeParametrization.centered y)
+              j B 0) :
+          ℤ) •
+        Smale.LocalDegree.NativeNeighborhood.sphereConnecting y dy (k + 1) a =
+      _
+  rw [pointClass_sign_compare n x y dx dy k a, smul_smul, ← SignType.coe_mul, hs']
+  rfl
+
+attribute [local instance] Smale.SpherePoint.instLocal2 in
+private theorem Smale.SpherePoint.chartSign_mul_self (n : ℕ) {H : Type} [NormedAddCommGroup H]
+    [NormedSpace ℝ H] (j : (ℝ × H) ≃L[ℝ] EuclideanSpace ℝ (Fin (n + 3)))
+    (B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] H) (x : SphereHomology.UnitSphere (n + 2)) :
+    (SignType.sign
+            (Smale.SphereNormalCoordinates.chartJacobian (Smale.NativeParametrization.centered x)
+              j B 0) :
+          ℤ) *
+        (SignType.sign
+            (Smale.SphereNormalCoordinates.chartJacobian (Smale.NativeParametrization.centered x)
+              j B 0) :
+          ℤ) =
+      1 := by
+  have hn :=
+    Smale.SphereNormalCoordinates.chartJacobian_ne_zero (Smale.NativeParametrization.centered x) j
+      B (Smale.NativeParametrization.zero_mem_centered_source x)
+  have hs :
+    SignType.sign
+          (Smale.SphereNormalCoordinates.chartJacobian (Smale.NativeParametrization.centered x) j
+            B 0) *
+        SignType.sign
+          (Smale.SphereNormalCoordinates.chartJacobian (Smale.NativeParametrization.centered x) j
+            B 0) =
+      1 := by
+    rw [← sign_mul]
+    exact sign_eq_one_iff.mpr (mul_self_pos.mpr hn)
+  simpa only [SignType.coe_mul, SignType.coe_one] using congrArg (fun s : SignType => (s : ℤ)) hs
+
+attribute [local instance] Smale.SpherePoint.instLocal2 in
+private theorem
+    Smale.SpherePoint.connecting_eq_sign_outward (n : ℕ) {F H : Type} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [NormedAddCommGroup H] [NormedSpace ℝ H]
+    (j : (ℝ × H) ≃L[ℝ] EuclideanSpace ℝ (Fin (n + 3)))
+    (B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] H) (x : SphereHomology.UnitSphere (n + 2))
+    {fx : SphereHomology.UnitSphere (n + 2) → F} {Lx : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] F}
+    {Wx : Set (SphereHomology.UnitSphere (n + 2))}
+    (dx :
+      Smale.LocalDegree.NeighborhoodData (fx ∘ Smale.NativeParametrization.centered x) Lx
+        ((Smale.NativeParametrization.centered x).source ∩
+          Smale.NativeParametrization.centered x ⁻¹' Wx))
+    (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 2)) (k + 2)) :
+    Smale.LocalDegree.NativeNeighborhood.sphereConnecting x dx (k + 1) a =
+      (SignType.sign
+            (Smale.SphereNormalCoordinates.chartJacobian (Smale.NativeParametrization.centered x)
+              j B 0) :
+          ℤ) •
+        outwardPointClass n j B x dx k a := by
+  change
+    _ =
+      (SignType.sign
+            (Smale.SphereNormalCoordinates.chartJacobian (Smale.NativeParametrization.centered x)
+              j B 0) :
+          ℤ) •
+        ((SignType.sign
+              (Smale.SphereNormalCoordinates.chartJacobian
+                (Smale.NativeParametrization.centered x) j B 0) :
+            ℤ) •
+          Smale.LocalDegree.NativeNeighborhood.sphereConnecting x dx (k + 1) a)
+  rw [smul_smul, chartSign_mul_self n j B x, one_smul]
+
+attribute [local instance] Smale.SpherePoint.instLocal2 in
+private def Smale.SpherePoint.outwardPointClassEquiv (n : ℕ) {F H : Type} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [NormedAddCommGroup H] [NormedSpace ℝ H]
+    (j : (ℝ × H) ≃L[ℝ] EuclideanSpace ℝ (Fin (n + 3)))
+    (B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] H) (x : SphereHomology.UnitSphere (n + 2))
+    {fx : SphereHomology.UnitSphere (n + 2) → F} {Lx : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] F}
+    {Wx : Set (SphereHomology.UnitSphere (n + 2))}
+    (dx :
+      Smale.LocalDegree.NeighborhoodData (fx ∘ Smale.NativeParametrization.centered x) Lx
+        ((Smale.NativeParametrization.centered x).source ∩
+          Smale.NativeParametrization.centered x ⁻¹' Wx))
+    (k : ℕ) :
+    SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 2)) (k + 2) ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 1)) (k + 1) := by
+  let C := connectingHomologyEquiv x dx k
+  let s : ℤ :=
+    SignType.sign
+      (Smale.SphereNormalCoordinates.chartJacobian (Smale.NativeParametrization.centered x) j B 0)
+  have hs : s * s = 1 := chartSign_mul_self n j B x
+  refine LinearEquiv.ofBijective (outwardPointClass n j B x dx k) ⟨?_, ?_⟩
+  · intro a b hab
+    apply C.injective
+    have h := congrArg (fun z => s • z) hab
+    change s • (s • C a) = s • (s • C b) at h
+    simpa only [smul_smul, hs, one_smul] using h
+  · intro b
+    refine ⟨C.symm (s • b), ?_⟩
+    change s • C (C.symm (s • b)) = b
+    rw [C.apply_symm_apply, smul_smul, hs, one_smul]
+
+private theorem Smale.SpherePoint.instLocal3 (n : ℕ) :
+    Fact (Module.finrank ℝ (EuclideanSpace ℝ (Fin (n + 3))) = (n + 2) + 1) :=
+  ⟨by simp⟩
+
+attribute [local instance] Smale.SpherePoint.instLocal3 in
+private def Smale.SpherePoint.referencePoint (n : ℕ) : SphereHomology.UnitSphere (n + 2) :=
+  Classical.choice (NormedSpace.sphere_nonempty_rclike ℝ zero_le_one)
+
+attribute [local instance] Smale.SpherePoint.instLocal3 in
+private def
+    Smale.SpherePoint.referenceNeighborhood (n : ℕ) (x : SphereHomology.UnitSphere (n + 2)) :
+    Smale.LocalDegree.NeighborhoodData
+      (((Smale.NativeParametrization.centered (D := EuclideanSpace ℝ (Fin (n + 2))) x).symm ∘
+          Diffeomorph.refl (𝓡 (n + 2)) (SphereHomology.UnitSphere (n + 2)) ∞) ∘
+        Smale.NativeParametrization.centered x)
+      (Smale.NativeChartTransition.linear x x
+        (Diffeomorph.refl (𝓡 (n + 2)) (SphereHomology.UnitSphere (n + 2)) ∞) rfl)
+      ((Smale.NativeParametrization.centered x).source ∩
+        Smale.NativeParametrization.centered x ⁻¹'
+          (Set.univ : Set (SphereHomology.UnitSphere (n + 2)))) :=
+  Classical.choice
+    (Smale.NativeChartTransition.nonempty_neighborhoodData x x
+      (Diffeomorph.refl (𝓡 (n + 2)) (SphereHomology.UnitSphere (n + 2)) ∞) rfl Set.univ (by simp))
+
+attribute [local instance] Smale.SpherePoint.instLocal3 in
+private def
+    Smale.SpherePoint.outwardClass (n : ℕ) {H : Type} [NormedAddCommGroup H] [NormedSpace ℝ H]
+    (j : (ℝ × H) ≃L[ℝ] EuclideanSpace ℝ (Fin (n + 3)))
+    (B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] H) (k : ℕ) :
+    SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 2)) (k + 2) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 1)) (k + 1) :=
+  outwardPointClass n j B (referencePoint n) (referenceNeighborhood n (referencePoint n)) k
+
+attribute [local instance] Smale.SpherePoint.instLocal3 in
+private def Smale.SpherePoint.outwardClassEquiv (n : ℕ) {H : Type} [NormedAddCommGroup H]
+    [NormedSpace ℝ H] (j : (ℝ × H) ≃L[ℝ] EuclideanSpace ℝ (Fin (n + 3)))
+    (B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] H) (k : ℕ) :
+    SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 2)) (k + 2) ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 1)) (k + 1) :=
+  outwardPointClassEquiv n j B (referencePoint n) (referenceNeighborhood n (referencePoint n)) k
+
+attribute [local instance] Smale.SpherePoint.instLocal3 in
+private theorem
+    Smale.SpherePoint.outwardPointClass_eq_global (n : ℕ) {H : Type} [NormedAddCommGroup H]
+    [NormedSpace ℝ H] (j : (ℝ × H) ≃L[ℝ] EuclideanSpace ℝ (Fin (n + 3)))
+    (B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] H) {F : Type} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (x : SphereHomology.UnitSphere (n + 2))
+    {f : SphereHomology.UnitSphere (n + 2) → F} {L : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] F}
+    {W : Set (SphereHomology.UnitSphere (n + 2))}
+    (d :
+      Smale.LocalDegree.NeighborhoodData (f ∘ Smale.NativeParametrization.centered x) L
+        ((Smale.NativeParametrization.centered x).source ∩
+          Smale.NativeParametrization.centered x ⁻¹' W))
+    (k : ℕ) : outwardPointClass n j B x d k = outwardClass n j B k :=
+  outwardPointClass_eq n j B (referencePoint n) x (referenceNeighborhood n (referencePoint n)) d k
+
+attribute [local instance] Smale.SpherePoint.instLocal3 in
+private theorem
+    Smale.SpherePoint.pointConnecting_eq_outward (n : ℕ) {H : Type} [NormedAddCommGroup H]
+    [NormedSpace ℝ H] (j : (ℝ × H) ≃L[ℝ] EuclideanSpace ℝ (Fin (n + 3)))
+    (B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] H) {F : Type} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (x : SphereHomology.UnitSphere (n + 2))
+    {f : SphereHomology.UnitSphere (n + 2) → F} {L : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] F}
+    {W : Set (SphereHomology.UnitSphere (n + 2))}
+    (d :
+      Smale.LocalDegree.NeighborhoodData (f ∘ Smale.NativeParametrization.centered x) L
+        ((Smale.NativeParametrization.centered x).source ∩
+          Smale.NativeParametrization.centered x ⁻¹' W))
+    (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 2)) (k + 2)) :
+    Smale.LocalDegree.NativeNeighborhood.sphereConnecting x d (k + 1) a =
+      (SignType.sign
+            (Smale.SphereNormalCoordinates.chartJacobian (Smale.NativeParametrization.centered x)
+              j B 0) :
+          ℤ) •
+        outwardClass n j B k a := by
+  rw [connecting_eq_sign_outward n j B x d k a, outwardPointClass_eq_global]
+
+private def
+    Smale.SpherePoint.sourceCountMark (n : ℕ) {N : Type} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    (j : (ℝ × N) ≃L[ℝ] EuclideanSpace ℝ (Fin (n + 3)))
+    (B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] N) :
+    SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 2)) (n + 2) ≃ₗ[ℤ] ℤ :=
+  (outwardClassEquiv n j B n).trans (SphereHomology.unitSphereHomologyTopEquiv n)
+
+private def
+    Smale.SpherePoint.overlapCountMark (n : ℕ) {N : Type} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    (B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] N) :
+    SingularMayerVietoris.SingularHomology (Metric.sphere (0 : N) 1) (n + 1) ≃ₗ[ℤ] ℤ :=
+  (Smale.LinearSphereAction.homologyEquiv B (n + 1)).symm.trans
+    (SphereHomology.unitSphereHomologyTopEquiv n)
+
+private def
+    Smale.SpherePoint.targetCountMark (n : ℕ) {N : Type} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [FiniteDimensional ℝ N] (B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] N) :
+    SingularMayerVietoris.SingularHomology (OnePoint N) (n + 2) ≃ₗ[ℤ] ℤ :=
+  (Smale.OnePointCover.sphereHomologyEquiv 1 zero_lt_one n).trans (overlapCountMark n B)
+
+private theorem Smale.SpherePoint.overlapCountMark_linear (n : ℕ) {N : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] (B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] N)
+    (a : SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 1)) (n + 1)) :
+    overlapCountMark n B
+        (SingularMayerVietoris.singularHomologyMap
+          (Smale.LinearSphereAction.sphereMap B.toContinuousLinearMap B.injective) (n + 1) a) =
+      SphereHomology.unitSphereHomologyTopEquiv n a := by
+  rw [← Smale.LinearSphereAction.homologyEquiv_apply]
+  change
+    SphereHomology.unitSphereHomologyTopEquiv n
+        ((Smale.LinearSphereAction.homologyEquiv B (n + 1)).symm
+          (Smale.LinearSphereAction.homologyEquiv B (n + 1) a)) =
+      _
+  rw [LinearEquiv.symm_apply_apply]
+
+private theorem Smale.SpherePoint.countMark_of_connecting (n : ℕ) {N : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [FiniteDimensional ℝ N] (j : (ℝ × N) ≃L[ℝ] EuclideanSpace ℝ (Fin (n + 3)))
+    (B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] N)
+    (u : SingularMayerVietoris.SingularHomology (OnePoint N) (n + 2))
+    (a : SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 2)) (n + 2))
+    (c : ℤ)
+    (h :
+      Smale.OnePointCover.sphereConnecting 1 zero_lt_one (n + 1) u =
+        c •
+          SingularMayerVietoris.singularHomologyMap
+            (Smale.LinearSphereAction.sphereMap B.toContinuousLinearMap B.injective) (n + 1)
+            (outwardClass n j B n a)) :
+    targetCountMark n B u = c * sourceCountMark n j B a := by
+  have h' := congrArg (overlapCountMark n B) h
+  rw [map_zsmul, overlapCountMark_linear] at h'
+  exact h'
+
+private theorem Smale.HomologyTransport.exists_split_rank_one_extension {R : Type*} [CommRing R]
+    {A B : Type*} [AddCommGroup A] [AddCommGroup B] [Module R A] [Module R B] (i : A →ₗ[R] B)
+    (p : B →ₗ[R] R) (hi : Function.Injective i) (hp : Function.Surjective p)
+    (hk : LinearMap.ker p = LinearMap.range i) :
+    ∃ e : (A × R) ≃ₗ[R] B, (∀ a, e (a, 0) = i a) ∧ ∀ z, p (e z) = z.2 := by
+  obtain ⟨b, hb⟩ := hp 1
+  let s : R →ₗ[R] B := LinearMap.toSpanSingleton R B b
+  have hs (z : R) : p (s z) = z := by
+    change p (z • b) = z
+    rw [map_smul, hb, smul_eq_mul, mul_one]
+  have hz (a : A) : p (i a) = 0 := by
+    have h : i a ∈ LinearMap.range i := ⟨a, rfl⟩
+    rw [← hk] at h
+    exact h
+  let F : (A × R) →ₗ[R] B := i.coprod s
+  have hF (z : A × R) : p (F z) = z.2 := by
+    change p (i z.1 + s z.2) = z.2
+    rw [map_add, hz, hs, zero_add]
+  have hinj : Function.Injective F := by
+    intro x y h
+    have h₂ : x.2 = y.2 := (hF x).symm.trans ((congrArg p h).trans (hF y))
+    apply Prod.ext _ h₂
+    apply hi
+    change i x.1 + s x.2 = i y.1 + s y.2 at h
+    rw [h₂] at h
+    exact add_right_cancel h
+  have hsurj : Function.Surjective F := by
+    intro v
+    have hv : v - s (p v) ∈ LinearMap.ker p := by
+      change p (v - s (p v)) = 0
+      rw [map_sub, hs, sub_self]
+    rw [hk] at hv
+    obtain ⟨a, ha⟩ := hv
+    refine ⟨(a, p v), ?_⟩
+    change i a + s (p v) = v
+    rw [ha, sub_add_cancel]
+  refine ⟨LinearEquiv.ofBijective F ⟨hinj, hsurj⟩, ?_, hF⟩
+  intro a
+  change i a + s 0 = i a
+  rw [map_zero, add_zero]
+
+private theorem Smale.HomologyTransport.exists_add_split_rank_one_extension {R : Type*} [CommRing R]
+    {A B : Type*} [AddCommGroup A] [AddCommGroup B] [Module R A] [Module R B] (i : A →ₗ[R] B)
+    (p : B →ₗ[R] R) (hi : Function.Injective i) (hp : Function.Surjective p)
+    (hk : LinearMap.ker p = LinearMap.range i) :
+    ∃ e : (A × R) ≃+ B, (∀ a, e (a, 0) = i a) ∧ ∀ z, p (e z) = z.2 := by
+  obtain ⟨e, he, hp⟩ := exists_split_rank_one_extension i p hi hp hk
+  exact ⟨e.toAddEquiv, he, hp⟩
+
+private def
+    Smale.ManifoldMorse.MorseSurgeryData.indexTwoNormalModel {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 2) :
+    EuclideanSpace ℝ (Fin 2) ≃L[ℝ] d.chart.NegativeCoordinates :=
+  ContinuousLinearEquiv.ofFinrankEq (by simp [hindex])
+
+private def Smale.ManifoldMorse.MorseSurgeryData.indexTwoCollapseCoordinate {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 2) :
+    SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p + d.radius ^ 2 } 2 →ₗ[ℤ] ℤ :=
+  (Smale.SpherePoint.targetCountMark 0 (d.indexTwoNormalModel hindex)).toLinearMap.comp
+    (SingularMayerVietoris.singularHomologyMap (d.upperCollapseMap hf) 2)
+
+private theorem Smale.ManifoldMorse.MorseSurgeryData.indexTwoCoordinate_surjective {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 2)
+    [Subsingleton
+        (SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p - d.radius ^ 2 } 1)] :
+    Function.Surjective (d.indexTwoCollapseCoordinate hf hindex) :=
+  (Smale.SpherePoint.targetCountMark 0 (d.indexTwoNormalModel hindex)).surjective.comp
+    (d.upperCollapse_surjective_of_lower hf 0)
+
+private theorem Smale.ManifoldMorse.MorseSurgeryData.indexTwoCoordinate_kernel {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 2) :
+    LinearMap.ker (d.indexTwoCollapseCoordinate hf hindex) =
+      LinearMap.range (d.lowerRealizationHomologyMap 2) := by
+  rw [← d.upperCollapse_homology_kernel hf 1]
+  ext a
+  let C := Smale.SpherePoint.targetCountMark 0 (d.indexTwoNormalModel hindex)
+  change
+    C (SingularMayerVietoris.singularHomologyMap (d.upperCollapseMap hf) 2 a) = 0 ↔
+      SingularMayerVietoris.singularHomologyMap (d.upperCollapseMap hf) 2 a = 0
+  constructor
+  · intro h
+    exact C.injective (h.trans (map_zero C).symm)
+  · intro h
+    rw [h, map_zero]
+
+private theorem Smale.ManifoldMorse.MorseSurgeryData.lowerRealization_two_injective {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 2) :
+    Function.Injective (d.lowerRealizationHomologyMap 2) := by
+  let :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology (Metric.sphere (0 : d.chart.NegativeCoordinates) 1)
+        2) :=
+    d.attachingHomology_subsingleton_of_index 2 (by norm_num) (by omega) (by omega)
+  apply LinearMap.ker_eq_bot.mp
+  rw [← d.morse_exact_at_lower hf 2 (by norm_num)]
+  apply LinearMap.range_eq_bot.mpr
+  apply LinearMap.ext
+  intro a
+  change d.coreBoundaryHomologyMap 2 a = 0
+  rw [Subsingleton.elim a 0, map_zero]
+
+private theorem Smale.ManifoldMorse.MorseSurgeryData.exists_indexTwoHomology_split {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 2)
+    [Subsingleton
+        (SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p - d.radius ^ 2 } 1)] :
+    ∃ H :
+      (SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p - d.radius ^ 2 } 2 × ℤ) ≃ₗ[ℤ]
+        SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p + d.radius ^ 2 } 2,
+      (∀ a, H (a, 0) = d.lowerRealizationHomologyMap 2 a) ∧
+        ∀ z, d.indexTwoCollapseCoordinate hf hindex (H z) = z.2 := by
+  obtain ⟨H, hH, hcoord⟩ :=
+    Smale.HomologyTransport.exists_add_split_rank_one_extension (d.lowerRealizationHomologyMap 2)
+      (d.indexTwoCollapseCoordinate hf hindex) (d.lowerRealization_two_injective hf hindex)
+      (d.indexTwoCoordinate_surjective hf hindex) (d.indexTwoCoordinate_kernel hf hindex)
+  exact ⟨H.toIntLinearEquiv, hH, hcoord⟩
+
+private def Smale.HomologyTransport.integerCoordinateSplit (n : ℕ) :
+    (Fin (n + 1) → ℤ) ≃+ ((Fin n → ℤ) × ℤ)
+    where
+  toFun v := (fun i => v i.succ, v 0)
+  invFun v := Fin.cons v.2 v.1
+  left_inv
+    v := by
+    funext i
+    exact Fin.cases rfl (fun _ => rfl) i
+  right_inv v := rfl
+  map_add' _ _ := rfl
+
+private theorem Smale.ManifoldMorse.MorseSurgeryData.exists_indexTwoBasis_extension {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 2)
+    [Subsingleton
+        (SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p - d.radius ^ 2 } 1)]
+    (n : ℕ)
+    (e :
+      (Fin n → ℤ) ≃ₗ[ℤ]
+        SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p - d.radius ^ 2 } 2) :
+    ∃ H :
+      (Fin (n + 1) → ℤ) ≃ₗ[ℤ]
+        SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p + d.radius ^ 2 } 2,
+      (∀ v, H (Fin.cons 0 v) = d.lowerRealizationHomologyMap 2 (e v)) ∧
+        ∀ v, d.indexTwoCollapseCoordinate hf hindex (H v) = v 0 := by
+  obtain ⟨H, hH, hcoord⟩ := d.exists_indexTwoHomology_split hf hindex
+  let G :=
+    (Smale.HomologyTransport.integerCoordinateSplit n).trans
+      ((e.toAddEquiv.prodCongr (AddEquiv.refl ℤ)).trans H.toAddEquiv)
+  refine ⟨G.toIntLinearEquiv, ?_, ?_⟩
+  · intro v
+    exact hH (e v)
+  · intro v
+    exact hcoord (e (fun i => v i.succ), v 0)
+
+private def Smale.ManifoldMorse.SurgeryWindows.HasIndexTwoPrefix {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (n : ℕ) : Prop :=
+  ∀ i : Fin S.count,
+    0 < i.val → i.val ≤ n → Module.finrank ℝ (S.data (S.point i)).chart.NegativeCoordinates = 2
+
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.indexTwoPrefix_mono {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) {n m : ℕ} (hnm : n ≤ m)
+    (h : S.HasIndexTwoPrefix m) : S.HasIndexTwoPrefix n := fun i hi hin => h i hi (hin.trans hnm)
+
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.indexTwoBasis_step {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (n : ℕ)
+    (hn : n + 1 < S.count) (hpre : S.HasIndexTwoPrefix (n + 1))
+    (e :
+      (Fin n → ℤ) ≃ₗ[ℤ]
+        SingularMayerVietoris.SingularHomology
+          { x : M // f x ≤ S.upper (S.point ⟨n, Nat.lt_of_succ_lt hn⟩) } 2) :
+    let B := S.consecutiveBandData hf ⟨n, Nat.lt_of_succ_lt hn⟩ ⟨n + 1, hn⟩ rfl
+    ∃ H :
+      (Fin (n + 1) → ℤ) ≃ₗ[ℤ]
+        SingularMayerVietoris.SingularHomology { x : M // f x ≤ S.upper (S.point ⟨n + 1, hn⟩) } 2,
+      (∀ v,
+          H (Fin.cons 0 v) =
+            (S.data (S.point ⟨n + 1, hn⟩)).lowerRealizationHomologyMap 2
+              (B.homologyEquiv 2 (e v))) ∧
+        ∀ v,
+          (S.data (S.point ⟨n + 1, hn⟩)).indexTwoCollapseCoordinate hf.continuous
+              (hpre ⟨n + 1, hn⟩ (Nat.succ_pos n) le_rfl) (H v) =
+            v 0 := by
+  let :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology
+        { x : M // f x ≤ f (S.point ⟨n + 1, hn⟩) - (S.data (S.point ⟨n + 1, hn⟩)).radius ^ 2 }
+        1) :=
+    S.lower_homologyOne_subsingleton_of_indices hf ⟨n + 1, hn⟩ (Nat.succ_pos n)
+      (fun i hi hin => by
+        have h := hpre i hi (Nat.le_of_lt hin)
+        omega)
+  let B := S.consecutiveBandData hf ⟨n, Nat.lt_of_succ_lt hn⟩ ⟨n + 1, hn⟩ rfl
+  exact
+    (S.data (S.point ⟨n + 1, hn⟩)).exists_indexTwoBasis_extension hf.continuous
+      (hpre ⟨n + 1, hn⟩ (Nat.succ_pos n) le_rfl) n (e.trans (B.homologyEquiv 2))
+
+private def Smale.ManifoldMorse.SurgeryWindows.indexTwoBasis {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) :
+    (n : ℕ) →
+      (hn : n < S.count) →
+        S.HasIndexTwoPrefix n →
+          (Fin n → ℤ) ≃ₗ[ℤ]
+            SingularMayerVietoris.SingularHomology { x : M // f x ≤ S.upper (S.point ⟨n, hn⟩) } 2
+  | 0, hn, _ =>
+    by
+    let :
+      Subsingleton
+        (SingularMayerVietoris.SingularHomology { x : M // f x ≤ S.upper (S.point ⟨0, hn⟩) } 2) :=
+      by
+      obtain ⟨D⟩ := S.nonempty_firstSublevelDisk hf hn
+      exact D.homology_subsingleton 2 (by norm_num)
+    exact LinearEquiv.ofSubsingleton _ _
+  | n + 1, hn, hpre =>
+    Classical.choose
+      (S.indexTwoBasis_step hf n hn hpre
+        (indexTwoBasis (S := S) hf n (Nat.lt_of_succ_lt hn)
+          (S.indexTwoPrefix_mono (Nat.le_succ n) hpre)))
+
+private def Smale.ManifoldMorse.MorseSurgeryData.indexThreeBoundaryEquiv {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 3) :
+    SingularMayerVietoris.SingularHomology (Metric.sphere (0 : d.chart.NegativeCoordinates) 1)
+        2 ≃ₗ[ℤ]
+      ℤ := by
+  let : Fact (Module.finrank ℝ d.chart.NegativeCoordinates = 2 + 1) := ⟨hindex⟩
+  let H :=
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv
+      (Smale.SphereCoordinates.standardParametrization d.chart.NegativeCoordinates 2).toHomeomorph
+      2
+  exact H.symm.trans (SphereHomology.unitSphereHomologyTopEquiv 1)
+
+private theorem Smale.ManifoldMorse.MorseSurgeryData.indexThreeBoundary_scalar {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 3)
+    (a :
+      SingularMayerVietoris.SingularHomology (Metric.sphere (0 : d.chart.NegativeCoordinates) 1)
+        2) :
+    a = (d.indexThreeBoundaryEquiv hindex a) • (d.indexThreeBoundaryEquiv hindex).symm 1 := by
+  apply (d.indexThreeBoundaryEquiv hindex).injective
+  rw [map_zsmul, LinearEquiv.apply_symm_apply, zsmul_eq_mul, mul_one]
+  simp
+
+private def Smale.ManifoldMorse.MorseSurgeryData.indexThreeAttachingClass {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 3) :
+    SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p - d.radius ^ 2 } 2 :=
+  d.coreBoundaryHomologyMap 2 ((d.indexThreeBoundaryEquiv hindex).symm 1)
+
+private theorem Smale.ManifoldMorse.MorseSurgeryData.coreBoundary_two_eq_smul {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 3)
+    (a :
+      SingularMayerVietoris.SingularHomology (Metric.sphere (0 : d.chart.NegativeCoordinates) 1)
+        2) :
+    d.coreBoundaryHomologyMap 2 a =
+      (d.indexThreeBoundaryEquiv hindex a) • d.indexThreeAttachingClass hindex := by
+  conv_lhs => rw [d.indexThreeBoundary_scalar hindex a]
+  rw [map_zsmul]
+  rfl
+
+private theorem Smale.ManifoldMorse.MorseSurgeryData.coreBoundary_two_range {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 3) :
+    LinearMap.range (d.coreBoundaryHomologyMap 2) =
+      Submodule.span ℤ {d.indexThreeAttachingClass hindex} := by
+  ext a
+  constructor
+  · rintro ⟨b, rfl⟩
+    rw [d.coreBoundary_two_eq_smul hindex b]
+    exact
+      Submodule.mem_span_singleton.mpr
+        ⟨d.indexThreeBoundaryEquiv hindex b,
+          int_smul_eq_zsmul
+            (SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p - d.radius ^ 2 }
+                2).isModule
+            _ _⟩
+  · intro ha
+    obtain ⟨z, hz⟩ := Submodule.mem_span_singleton.mp ha
+    refine ⟨z • (d.indexThreeBoundaryEquiv hindex).symm 1, ?_⟩
+    rw [map_zsmul]
+    exact
+      (int_smul_eq_zsmul
+            (SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p - d.radius ^ 2 }
+                2).isModule
+            z (d.indexThreeAttachingClass hindex)).symm.trans
+        hz
+
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.indexThree_lowerRealization_surjective {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) [T2Space M] (hf : Continuous f)
+    (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 3) :
+    Function.Surjective (d.lowerRealizationHomologyMap 2) := by
+  let :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology (Metric.sphere (0 : d.chart.NegativeCoordinates) 1)
+        1) :=
+    d.attachingHomology_subsingleton_of_index 1 one_ne_zero (by omega) (by omega)
+  intro a
+  have ha : a ∈ LinearMap.ker (d.morseConnectingMap hf 1) := Subsingleton.elim _ _
+  rw [← d.morse_exact_at_upper hf 1] at ha
+  exact ha
+
+private theorem Smale.ManifoldMorse.MorseSurgeryData.indexThree_lowerRealization_kernel {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) [T2Space M] (hf : Continuous f)
+    (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 3) :
+    LinearMap.ker (d.lowerRealizationHomologyMap 2) =
+      Submodule.span ℤ {d.indexThreeAttachingClass hindex} := by
+  rw [← d.morse_exact_at_lower hf 2 (by norm_num), d.coreBoundary_two_range hindex]
+
+public
+theorem Smale.HomologyTransport.ker_comp_span_singleton {R A B C : Type*} [CommRing R]
+    [AddCommGroup A] [AddCommGroup B] [AddCommGroup C] [Module R A] [Module R B] [Module R C]
+    (p : A →ₗ[R] B) (q : B →ₗ[R] C) (v : A) (hq : LinearMap.ker q = Submodule.span R {p v}) :
+    LinearMap.ker (q.comp p) = LinearMap.ker p ⊔ Submodule.span R { v } := by
+  apply le_antisymm
+  · intro a ha
+    have hpa : p a ∈ Submodule.span R {p v} := by
+      rw [← hq]
+      exact ha
+    obtain ⟨r, hr⟩ := Submodule.mem_span_singleton.mp hpa
+    have hk : a - r • v ∈ LinearMap.ker p := by
+      change p (a - r • v) = 0
+      rw [map_sub, map_smul, hr, sub_self]
+    exact
+      Submodule.mem_sup.mpr
+        ⟨a - r • v, hk, r • v, Submodule.smul_mem _ _ (Submodule.subset_span (by simp)),
+          sub_add_cancel _ _⟩
+  · apply sup_le
+    · intro a ha
+      change q (p a) = 0
+      change p a = 0 at ha
+      rw [ha, map_zero]
+    · apply Submodule.span_le.mpr
+      intro a ha
+      have ha' : a = v := Set.mem_singleton_iff.mp ha
+      subst a
+      change p v ∈ LinearMap.ker q
+      rw [hq]
+      exact Submodule.subset_span (by simp)
+
+private structure
+    Smale.IntegerPresentation (B : Type*) [AddCommGroup B] [Module ℤ B] (r c : ℕ) where
+  map : (Fin r → ℤ) →ₗ[ℤ] B
+  columns : Fin c → (Fin r → ℤ)
+  surjective : Function.Surjective map
+  kernel_eq : LinearMap.ker map = Submodule.span ℤ (Set.range columns)
+
+private def Smale.IntegerPresentation.ofEquiv {B : Type*} [AddCommGroup B] [Module ℤ B] {r : ℕ}
+    (e : (Fin r → ℤ) ≃ₗ[ℤ] B) : Smale.IntegerPresentation B r 0
+    where
+  map := e.toLinearMap
+  columns := Fin.elim0
+  surjective := e.surjective
+  kernel_eq := by
+    rw [LinearMap.ker_eq_bot.mpr e.injective]
+    simp
+
+private def Smale.IntegerPresentation.transport {B C : Type*} [AddCommGroup B] [AddCommGroup C]
+    [Module ℤ B] [Module ℤ C] {r c : ℕ} (P : Smale.IntegerPresentation B r c) (e : B ≃ₗ[ℤ] C) :
+    Smale.IntegerPresentation C r c
+    where
+  map := e.toLinearMap.comp P.map
+  columns := P.columns
+  surjective := e.surjective.comp P.surjective
+  kernel_eq := by
+    have h : LinearMap.ker (e.toLinearMap.comp P.map) = LinearMap.ker P.map := by
+      ext v
+      change e (P.map v) = 0 ↔ P.map v = 0
+      constructor
+      · intro hv
+        exact e.injective (hv.trans (map_zero e).symm)
+      · intro hv
+        rw [hv, map_zero]
+    exact h.trans P.kernel_eq
+
+private def
+    Smale.IntegerPresentation.liftRelation {B : Type*} [AddCommGroup B] [Module ℤ B] {r c : ℕ}
+    (P : Smale.IntegerPresentation B r c) (b : B) : Fin r → ℤ :=
+  Classical.choose (P.surjective b)
+
+private theorem Smale.IntegerPresentation.map_liftRelation {B : Type*} [AddCommGroup B] [Module ℤ B]
+    {r c : ℕ} (P : Smale.IntegerPresentation B r c) (b : B) : P.map (P.liftRelation b) = b :=
+  Classical.choose_spec (P.surjective b)
+
+private def
+    Smale.IntegerPresentation.adjoin {B C : Type*} [AddCommGroup B] [AddCommGroup C] [Module ℤ B]
+    [Module ℤ C] {r c : ℕ} (P : Smale.IntegerPresentation B r c) (q : B →ₗ[ℤ] C)
+    (hq : Function.Surjective q) (b : B) (hker : LinearMap.ker q = Submodule.span ℤ { b }) :
+    Smale.IntegerPresentation C r (c + 1)
+    where
+  map := q.comp P.map
+  columns := Fin.cons (P.liftRelation b) P.columns
+  surjective := hq.comp P.surjective
+  kernel_eq := by
+    have hk : LinearMap.ker q = Submodule.span ℤ {P.map (P.liftRelation b)} := by
+      rw [P.map_liftRelation]
+      exact hker
+    rw [Smale.HomologyTransport.ker_comp_span_singleton P.map q (P.liftRelation b) hk,
+      P.kernel_eq, Fin.range_cons, Submodule.span_insert, sup_comm]
+
+private def Smale.ManifoldMorse.MorseSurgeryData.indexThreePresentation {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 3) {r c : ℕ}
+    (P :
+      Smale.IntegerPresentation
+        (SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p - d.radius ^ 2 } 2) r c) :
+    Smale.IntegerPresentation
+      (SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p + d.radius ^ 2 } 2) r
+      (c + 1) :=
+  P.adjoin (d.lowerRealizationHomologyMap 2) (d.indexThree_lowerRealization_surjective hf hindex)
+    (d.indexThreeAttachingClass hindex) (d.indexThree_lowerRealization_kernel hf hindex)
+
+private def
+    Smale.ManifoldMorse.SurgeryWindows.HasIndexThreeBlock {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (r c : ℕ) : Prop :=
+  ∀ i : Fin S.count,
+    r < i.val →
+      i.val ≤ r + c → Module.finrank ℝ (S.data (S.point i)).chart.NegativeCoordinates = 3
+
+private theorem Smale.ManifoldMorse.SurgeryWindows.indexThreeBlock_mono {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) {r c b : ℕ} (hcb : c ≤ b)
+    (h : S.HasIndexThreeBlock r b) : S.HasIndexThreeBlock r c := fun i hri hic =>
+  h i hri (hic.trans (Nat.add_le_add_left hcb r))
+
+private theorem Smale.ManifoldMorse.SurgeryWindows.indexThreeBlock_last {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (r c : ℕ) (hc : r + (c + 1) < S.count)
+    (h : S.HasIndexThreeBlock r (c + 1)) :
+    Module.finrank ℝ (S.data (S.point ⟨r + (c + 1), hc⟩)).chart.NegativeCoordinates = 3 :=
+  h ⟨r + (c + 1), hc⟩ (by change r < r + (c + 1); omega) le_rfl
+
+private def
+    Smale.ManifoldMorse.SurgeryWindows.middlePresentation {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (r : ℕ)
+    (htwo : S.HasIndexTwoPrefix r) :
+    (c : ℕ) →
+      (hc : r + c < S.count) →
+        S.HasIndexThreeBlock r c →
+          Smale.IntegerPresentation
+            (SingularMayerVietoris.SingularHomology
+              { x : M // f x ≤ S.upper (S.point ⟨r + c, hc⟩) } 2)
+            r c
+  | 0, hc, _ => Smale.IntegerPresentation.ofEquiv (S.indexTwoBasis hf r hc htwo)
+  | c + 1, hc, hthree =>
+    let P :=
+      middlePresentation (S := S) hf r htwo c (Nat.lt_of_succ_lt hc)
+        (S.indexThreeBlock_mono (Nat.le_succ c) hthree)
+    let B := S.consecutiveBandData hf ⟨r + c, Nat.lt_of_succ_lt hc⟩ ⟨r + (c + 1), hc⟩ rfl
+    (S.data (S.point ⟨r + (c + 1), hc⟩)).indexThreePresentation hf.continuous
+      (S.indexThreeBlock_last r c hc hthree) (P.transport (B.homologyEquiv 2))
+
+private def Smale.IntegerPresentation.matrix {B : Type*} [AddCommGroup B] [Module ℤ B] {r c : ℕ}
+    (P : Smale.IntegerPresentation B r c) : Matrix (Fin r) (Fin c) ℤ := fun i j => P.columns j i
+
+private theorem
+    Smale.IntegerPresentation.columns_sum_eq_mulVec {B : Type*} [AddCommGroup B] [Module ℤ B]
+    {r c : ℕ} (P : Smale.IntegerPresentation B r c) (z : Fin c → ℤ) :
+    (∑ j, z j • P.columns j) = P.matrix.mulVec z := by
+  funext i
+  simp [Smale.IntegerPresentation.matrix, Matrix.mulVec, dotProduct, mul_comm]
+
+private theorem
+    Smale.IntegerPresentation.mem_range_matrix_iff {B : Type*} [AddCommGroup B] [Module ℤ B]
+    {r c : ℕ} (P : Smale.IntegerPresentation B r c) (v : Fin r → ℤ) :
+    v ∈ Set.range P.matrix.mulVec ↔ v ∈ Submodule.span ℤ (Set.range P.columns) := by
+  rw [Submodule.mem_span_range_iff_exists_fun ℤ]
+  constructor
+  · rintro ⟨z, hz⟩
+    exact ⟨z, (P.columns_sum_eq_mulVec z).trans hz⟩
+  · rintro ⟨z, hz⟩
+    exact ⟨z, (P.columns_sum_eq_mulVec z).symm.trans hz⟩
+
+private theorem
+    Smale.IntegerPresentation.matrix_image_eq_kernel {B : Type*} [AddCommGroup B] [Module ℤ B]
+    {r c : ℕ} (P : Smale.IntegerPresentation B r c) :
+    Set.range P.matrix.mulVec = (LinearMap.ker P.map : Set (Fin r → ℤ)) := by
+  ext v
+  rw [P.mem_range_matrix_iff, P.kernel_eq]
+  rfl
+
+private theorem Smale.IntegerPresentation.matrix_relation {B : Type*} [AddCommGroup B] [Module ℤ B]
+    {r c : ℕ} (P : Smale.IntegerPresentation B r c) (z : Fin c → ℤ) :
+    P.map (P.matrix.mulVec z) = 0 := by
+  have h : P.matrix.mulVec z ∈ Set.range P.matrix.mulVec := ⟨z, rfl⟩
+  rw [P.matrix_image_eq_kernel] at h
+  exact h
+
+private theorem Smale.IntegerPresentation.columns_span_of_subsingleton {B : Type*} [AddCommGroup B]
+    [Module ℤ B] {r c : ℕ} (P : Smale.IntegerPresentation B r c) [Subsingleton B] :
+    Submodule.span ℤ (Set.range P.columns) = ⊤ := by
+  apply top_unique
+  intro v _
+  rw [← P.kernel_eq]
+  exact Subsingleton.elim _ _
+
+private theorem
+    Smale.IntegerPresentation.matrix_surjective_of_subsingleton {B : Type*} [AddCommGroup B]
+    [Module ℤ B] {r c : ℕ} (P : Smale.IntegerPresentation B r c) [Subsingleton B] :
+    Function.Surjective P.matrix.mulVec := by
+  intro v
+  apply (P.mem_range_matrix_iff v).mpr
+  rw [P.columns_span_of_subsingleton]
+  trivial
+
+private theorem Smale.homotopySixSphere_homology_subsingleton {M : Type} [TopologicalSpace M]
+    (h : M ≃ₕ Smale.SixSphere) (k : ℕ) (hk : k ≠ 0) (hktop : k ≠ 6) :
+    Subsingleton (SingularMayerVietoris.SingularHomology M k) := by
+  let : Subsingleton (SingularMayerVietoris.SingularHomology Smale.SixSphere k) :=
+    SphereHomology.unitSphere_homology_subsingleton 5 k hk hktop
+  exact (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv h k).injective.subsingleton
+
+private def
+    Smale.ManifoldMorse.SurgeryWindows.lastUpperHomeomorph {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [CompactSpace M] {f : M → ℝ} (S : Smale.ManifoldMorse.SurgeryWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (h : 0 < S.count) :
+    { x : M // f x ≤ S.upper (S.last h) } ≃ₜ M :=
+  (Homeomorph.setCongr (S.last_upper_univ hf h)).trans (Homeomorph.Set.univ M)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SurgeryWindows.lastLower_homology_subsingleton {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (hM : M ≃ₕ Smale.SixSphere) (h : 0 < S.count) (k : ℕ)
+    (hk : 0 < k) (hk5 : k < 5) :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology { x : M // f x ≤ S.lower (S.last h) } k) := by
+  let d := S.data (S.last h)
+  have hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 5 + 1 :=
+    (S.last_index_dimension hf h).trans hdim
+  let : Fact (Module.finrank ℝ d.chart.NegativeCoordinates = 5 + 1) := ⟨hindex⟩
+  let : Subsingleton (SingularMayerVietoris.SingularHomology M k) :=
+    Smale.homotopySixSphere_homology_subsingleton hM k hk.ne' (by omega)
+  let :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology { x : M // f x ≤ f (S.last h) + d.radius ^ 2 } k) :=
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv (S.lastUpperHomeomorph hf h)
+        k).injective.subsingleton
+  let : Subsingleton (SingularMayerVietoris.SingularHomology (Smale.Hemisphere.Sphere 5) k) :=
+    SphereHomology.unitSphere_homology_subsingleton 4 k hk.ne' (by omega)
+  let :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology (Metric.sphere (0 : d.chart.NegativeCoordinates) 1)
+        k) :=
+    (PeriodTorusHigherHomology.homeomorphHomologyEquiv
+        (Smale.SphereCoordinates.standardParametrization d.chart.NegativeCoordinates
+            5).symm.toHomeomorph
+        k).injective.subsingleton
+  exact d.lowerHomology_subsingleton_of_upper_and_sphere hf.continuous k hk.ne'
+
+private theorem Smale.ManifoldMorse.SurgeryWindows.upper_homology_subsingleton_of_later_indices
+    {E M : Type} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    {f : M → ℝ} (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (hM : M ≃ₕ Smale.SixSphere) (j : Fin S.count)
+    (hj : j.val + 1 < S.count) (k : ℕ) (hk : 0 < k) (hk5 : k < 5)
+    (hindex :
+      ∀ i : Fin S.count,
+        j.val < i.val →
+          i.val + 1 < S.count →
+            2 ≤ Module.finrank ℝ (S.data (S.point i)).chart.NegativeCoordinates ∧
+              Module.finrank ℝ (S.data (S.point i)).chart.NegativeCoordinates ≠ k + 1) :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology { x : M // f x ≤ S.upper (S.point j) } k) := by
+  have hcount : 0 < S.count := by omega
+  let P : ℕ → Prop := fun i =>
+    ∀ hi : i < S.count,
+      Subsingleton
+        (SingularMayerVietoris.SingularHomology { x : M // f x ≤ S.lower (S.point ⟨i, hi⟩) } k)
+  have hlow : P (j.val + 1) := by
+    apply Nat.decreasingInduction' (P := P) (m := j.val + 1) (n := S.count - 1)
+    · intro i hi hji ih hi'
+      have hs : i + 1 < S.count := by omega
+      let :
+        Subsingleton
+          (SingularMayerVietoris.SingularHomology
+            { x : M // f x ≤ f (S.point ⟨i + 1, hs⟩) - (S.data (S.point ⟨i + 1, hs⟩)).radius ^ 2 }
+            k) :=
+        ih hs
+      obtain ⟨T, _, hT, _⟩ := S.exists_consecutiveBandBridge hf ⟨i, hi'⟩ ⟨i + 1, hs⟩ rfl
+      let H :=
+        (S.data (S.point ⟨i, hi'⟩)).bandSublevelHomeomorph (S.data (S.point ⟨i + 1, hs⟩))
+          T.toHomeomorph hT
+      let :
+        Subsingleton
+          (SingularMayerVietoris.SingularHomology
+            { x : M // f x ≤ f (S.point ⟨i, hi'⟩) + (S.data (S.point ⟨i, hi'⟩)).radius ^ 2 } k) :=
+        (PeriodTorusHigherHomology.homeomorphHomologyEquiv H k).injective.subsingleton
+      obtain ⟨hlo, hne⟩ := hindex ⟨i, hi'⟩ (by change j.val < i; omega) hs
+      exact
+        (S.data (S.point ⟨i, hi'⟩)).lowerHomology_subsingleton_of_upper_and_index hf.continuous k
+          hk.ne' hlo hne
+    · omega
+    · intro hi
+      exact S.lastLower_homology_subsingleton hf hdim hM hcount k hk hk5
+  let :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology
+        { x : M //
+          f x ≤ f (S.point ⟨j.val + 1, hj⟩) - (S.data (S.point ⟨j.val + 1, hj⟩)).radius ^ 2 }
+        k) :=
+    hlow hj
+  obtain ⟨T, _, hT, _⟩ := S.exists_consecutiveBandBridge hf j ⟨j.val + 1, hj⟩ rfl
+  let H :=
+    (S.data (S.point j)).bandSublevelHomeomorph (S.data (S.point ⟨j.val + 1, hj⟩)) T.toHomeomorph
+      hT
+  exact (PeriodTorusHigherHomology.homeomorphHomologyEquiv H k).injective.subsingleton
+
+private def Smale.ManifoldMorse.SurgeryWindows.middleMatrix {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (r c : ℕ)
+    (htwo : S.HasIndexTwoPrefix r) (hc : r + c < S.count) (hthree : S.HasIndexThreeBlock r c) :
+    Matrix (Fin r) (Fin c) ℤ :=
+  (S.middlePresentation hf r htwo c hc hthree).matrix
+
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.middleMatrix_surjective_of_homotopySphere {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (hM : M ≃ₕ Smale.SixSphere) (r c : ℕ)
+    (htwo : S.HasIndexTwoPrefix r) (hc : r + c < S.count) (hthree : S.HasIndexThreeBlock r c)
+    (hj : r + c + 1 < S.count)
+    (hafter :
+      ∀ i : Fin S.count,
+        r + c < i.val →
+          i.val + 1 < S.count →
+            2 ≤ Module.finrank ℝ (S.data (S.point i)).chart.NegativeCoordinates ∧
+              Module.finrank ℝ (S.data (S.point i)).chart.NegativeCoordinates ≠ 3) :
+    Function.Surjective (S.middleMatrix hf r c htwo hc hthree).mulVec := by
+  let :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology { x : M // f x ≤ S.upper (S.point ⟨r + c, hc⟩) }
+        2) :=
+    S.upper_homology_subsingleton_of_later_indices hf hdim hM ⟨r + c, hc⟩ hj 2 (by norm_num)
+      (by norm_num) hafter
+  exact (S.middlePresentation hf r htwo c hc hthree).matrix_surjective_of_subsingleton
+
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.middleMatrix_surjective_of_complete_blocks {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (hM : M ≃ₕ Smale.SixSphere) (r c : ℕ)
+    (htwo : S.HasIndexTwoPrefix r) (hc : r + c < S.count) (hthree : S.HasIndexThreeBlock r c)
+    (hcount : r + c + 2 = S.count) :
+    Function.Surjective (S.middleMatrix hf r c htwo hc hthree).mulVec := by
+  apply S.middleMatrix_surjective_of_homotopySphere hf hdim hM r c htwo hc hthree (by omega)
+  intro i hi hi'
+  omega
+
+private theorem
+    MorseCancel.native_indices_monotone {E M : Type} [NormedAddCommGroup E] [NormedSpace ℝ E]
+     [TopologicalSpace M] [ChartedSpace E M]
+       {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f)
+    (horder :
+      ∀ p q : Smale.ManifoldMorse.criticalPoints E f,
+        f p < f q → nativeMorseIndex E f p ≤ nativeMorseIndex E f q) :
+    Monotone (fun i : Fin S.count => nativeMorseIndex E f (S.point i)) := by
+  intro i j hij
+  rcases lt_or_eq_of_le hij with hlt | rfl
+  · exact horder _ _ (S.point_strictMono hlt)
+  · exact le_rfl
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_middle_index_blocks {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] [Nonempty M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6)
+    (horder :
+      ∀ p q : Smale.ManifoldMorse.criticalPoints E f,
+        f p < f q → nativeMorseIndex E f p ≤ nativeMorseIndex E f q)
+    (hzero : nativeMorseCount E f 0 = 1) (hone : nativeMorseCount E f 1 = 0) :
+    ∃ r c : ℕ,
+      S.HasIndexTwoPrefix r ∧
+        ∃ _ : r + c < S.count,
+          S.HasIndexThreeBlock r c ∧
+            r + c + 1 < S.count ∧
+              ∀ i : Fin S.count,
+                r + c < i.val →
+                  4 ≤ Module.finrank ℝ (S.data (S.point i)).chart.NegativeCoordinates := by
+  have hn := S.count_pos hf
+  let index := fun i : Fin S.count => nativeMorseIndex E f (S.point i)
+  have hmono : Monotone index := native_indices_monotone S horder
+  have hfirst : index ⟨0, hn⟩ = 0 :=
+    (nativeMorseIndex_eq_chart (S.data (S.first hn)).chart).trans (S.first_index_zero hf hn)
+  have hlast : index ⟨S.count - 1, Nat.sub_lt hn zero_lt_one⟩ = 6 :=
+    (nativeMorseIndex_eq_chart (S.data (S.last hn)).chart).trans
+      ((S.last_index_dimension hf hn).trans hdim)
+  have hcut (k : ℕ) : ∃ j : Fin S.count, ∀ i : Fin S.count, i ≤ j ↔ index i ≤ k := by
+    let K := Finset.univ.filter (fun i : Fin S.count => index i ≤ k)
+    have hK : K.Nonempty :=
+      ⟨⟨0, hn⟩, Finset.mem_filter.mpr ⟨Finset.mem_univ _, by rw [hfirst]; exact Nat.zero_le k⟩⟩
+    let j := K.max' hK
+    have hj : index j ≤ k := (Finset.mem_filter.mp (K.max'_mem hK)).2
+    refine ⟨j, fun i => ⟨fun hij => (hmono hij).trans hj, ?_⟩⟩
+    intro hi
+    exact K.le_max' i (Finset.mem_filter.mpr ⟨Finset.mem_univ _, hi⟩)
+  obtain ⟨a, ha⟩ := hcut 2
+  obtain ⟨b, hb⟩ := hcut 3
+  have hab : a ≤ b := (hb a).mpr (((ha a).mp le_rfl).trans (by omega))
+  have hbLast : b.val + 1 < S.count := by
+    have hb3 := (hb b).mp le_rfl
+    have hne : b ≠ ⟨S.count - 1, Nat.sub_lt hn zero_lt_one⟩ := by
+      intro he
+      rw [he, hlast] at hb3
+      omega
+    have hvalne : b.val ≠ S.count - 1 := fun he => hne (Fin.ext he)
+    omega
+  have hnonzero (i : Fin S.count) (hi : 0 < i.val) : index i ≠ 0 := by
+    intro hz
+    have he : S.point i = S.first hn :=
+      Subtype.ext (native_index_zero_point_unique S hf hn hzero _ (S.point i).property hz)
+    have hi0 : i.val = 0 := congrArg Fin.val (S.point.injective he)
+    omega
+  have hnonone (i : Fin S.count) : index i ≠ 1 :=
+    native_index_one_excluded S hone _ (S.point i).property
+  refine ⟨a.val, b.val - a.val, ?_, by omega, ?_, by omega, ?_⟩
+  · intro i hi hia
+    have hi2 := (ha i).mp (show i ≤ a from hia)
+    have hi0 := hnonzero i hi
+    have hi1 := hnonone i
+    rw [← nativeMorseIndex_eq_chart (S.data (S.point i)).chart]
+    change index i = 2
+    omega
+  · intro i hai hib
+    have hi3 := (hb i).mp (show i ≤ b by change i.val ≤ b.val; omega)
+    have hi2 : ¬index i ≤ 2 := fun he => (not_le_of_gt hai) ((ha i).mpr he)
+    rw [← nativeMorseIndex_eq_chart (S.data (S.point i)).chart]
+    change index i = 3
+    omega
+  · intro i hbi
+    have hi3 : ¬index i ≤ 3 := fun he =>
+      (by
+        have hh : i.val ≤ b.val := (hb i).mpr he
+        omega)
+    rw [← nativeMorseIndex_eq_chart (S.data (S.point i)).chart]
+    change 4 ≤ index i
+    omega
+
+private def MorseCancel.nativeMiddleBlockPoint {E M : Type} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (r n : ℕ) (hn : r + n < S.toSurgeryWindows.count) (j : Fin n) :
+    Smale.ManifoldMorse.criticalPoints E f :=
+  S.toSurgeryWindows.point ⟨r + j.val + 1, by omega⟩
+
+private theorem AdaptedWindows.exists_ordered_middle_family {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f)
+    (hdim : Module.finrank ℝ E = 6) (r n : ℕ) (hn : r + n < S.toSurgeryWindows.count)
+    (hthree : S.toSurgeryWindows.HasIndexThreeBlock r n)
+    (ε : Smale.ManifoldMorse.criticalPoints E f → ℝ) (hε : ∀ q, 0 < ε q) :
+    let q := S.toSurgeryWindows.point ⟨r, by omega⟩
+    ∃ T : AdaptedWindows E f,
+      (∀ p, (T.data p).chart = (S.data p).chart) ∧
+        (∀ p, (T.data p).radius < ε p) ∧
+          (∀ p ∈ Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ y in 𝓝 p, T.field y = S.field y) ∧
+            ∃ α : Fin n → (Smale.Hemisphere.Sphere 2) → (S.data q).UpperLevel,
+              MorseCancel.IsNativeMiddleBasinFamily T hf (S.data q).upper_regular
+                (MorseCancel.nativeMiddleBlockPoint S r n hn) α := by
+  let W := S.toSurgeryWindows
+  have hnW : r + n < W.count := hn
+  let q := W.point ⟨r, by omega⟩
+  let p := MorseCancel.nativeMiddleBlockPoint S r n hn
+  have hp (j : Fin n) : MorseCancel.nativeMorseIndex E f (p j) = 3 :=
+    (MorseCancel.nativeMorseIndex_eq_chart (S.data (p j)).chart).trans
+      (hthree ⟨r + j.val + 1, by omega⟩ (by simp) (by dsimp; omega))
+  have horder : StrictMono (fun j => f (p j)) := by
+    intro i j hij
+    apply W.point_strictMono
+    change r + i.val + 1 < r + j.val + 1
+    omega
+  have habove (j : Fin n) : W.upper q < f (p j) := by
+    have hqj : f q < f (p j) := W.point_strictMono (by change r < r + j.val + 1; omega)
+    exact (W.separated q (p j) hqj).trans (W.lower_lt_value (p j))
+  have hblock (j : Fin n) (z : Smale.ManifoldMorse.criticalPoints E f) (hz : W.upper q < f z)
+    (hzj : f z ≤ f (p j)) : z ∈ Set.range p := by
+    obtain ⟨k, rfl⟩ := W.point.surjective z
+    have hrk : r < k.val := W.point_strictMono.lt_iff_lt.mp ((W.value_lt_upper q).trans hz)
+    have hkj : k.val ≤ r + j.val + 1 := W.point_strictMono.le_iff_le.mp hzj
+    let i : Fin n := ⟨k.val - (r + 1), by omega⟩
+    refine ⟨i, ?_⟩
+    apply congrArg W.point
+    apply Fin.ext
+    change r + (k.val - (r + 1)) + 1 = k.val
+    omega
+  exact
+    S.exists_middle_block_realization hf hm hdim n (S.data q).upper_regular p hp horder habove
+      hblock ε hε
+
+private def Degree.DiskCube.target {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V] {n : ℕ}
+    (L : V ≃L[ℝ] (Fin n → ℝ)) : Set V :=
+  L ⁻¹' HigherHurewicz.realCubeSet n
+
+private theorem Degree.DiskCube.target_compact {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    {n : ℕ} (L : V ≃L[ℝ] (Fin n → ℝ)) : IsCompact (target L) :=
+  L.toHomeomorph.isCompact_preimage.mpr (HigherHurewicz.isCompact_realCubeSet n)
+
+private theorem
+    Degree.DiskCube.target_convex {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V] {n : ℕ}
+    (L : V ≃L[ℝ] (Fin n → ℝ)) : Convex ℝ (target L) :=
+  (HigherHurewicz.convex_realCubeSet n).linear_preimage L.toLinearMap
+
+private theorem Degree.DiskCube.target_interior_nonempty {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] {n : ℕ} (L : V ≃L[ℝ] (Fin n → ℝ)) : (interior (target L)).Nonempty := by
+  obtain ⟨v, hv⟩ := HigherHurewicz.interior_realCubeSet_nonempty n
+  refine ⟨L.symm v, ?_⟩
+  change L.symm v ∈ interior (L.toHomeomorph ⁻¹' HigherHurewicz.realCubeSet n)
+  rw [← L.toHomeomorph.preimage_interior]
+  change L (L.symm v) ∈ interior (HigherHurewicz.realCubeSet n)
+  rwa [L.apply_symm_apply]
+
+private theorem Degree.DiskCube.exists_ambient {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    [FiniteDimensional ℝ V] {n : ℕ} (L : V ≃L[ℝ] (Fin n → ℝ)) :
+    ∃ e : V ≃ₜ V,
+      e '' Metric.closedBall (0 : V) 1 = target L ∧
+        e '' frontier (Metric.closedBall (0 : V) 1) = frontier (target L) := by
+  obtain ⟨e, _, he, hb⟩ :=
+    exists_homeomorph_image_eq (convex_closedBall (0 : V) 1)
+      (show (interior (Metric.closedBall (0 : V) 1)).Nonempty from
+        ⟨0, Metric.ball_subset_interior_closedBall (by simp)⟩)
+      ((ProperSpace.isCompact_closedBall (0 : V) 1).isVonNBounded ℝ) (target_convex L)
+      (target_interior_nonempty L) ((target_compact L).isVonNBounded ℝ)
+  exact
+    ⟨e, by
+      simpa only [Metric.isClosed_closedBall.closure_eq,
+        (target_compact L).isClosed.closure_eq] using he,
+      hb⟩
+
+private def Degree.DiskCube.ambient {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    [FiniteDimensional ℝ V] {n : ℕ} (L : V ≃L[ℝ] (Fin n → ℝ)) : V ≃ₜ V :=
+  Classical.choose (exists_ambient L)
+
+private theorem Degree.DiskCube.ambient_image {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    [FiniteDimensional ℝ V] {n : ℕ} (L : V ≃L[ℝ] (Fin n → ℝ)) :
+    ambient L '' Metric.closedBall (0 : V) 1 = target L :=
+  (Classical.choose_spec (exists_ambient L)).1
+
+private theorem
+    Degree.DiskCube.ambient_frontier {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    [FiniteDimensional ℝ V] {n : ℕ} (L : V ≃L[ℝ] (Fin n → ℝ)) :
+    ambient L '' frontier (Metric.closedBall (0 : V) 1) = frontier (target L) :=
+  (Classical.choose_spec (exists_ambient L)).2
+
+private theorem Degree.DiskCube.ambient_mem_iff {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    [FiniteDimensional ℝ V] {n : ℕ} (L : V ≃L[ℝ] (Fin n → ℝ)) (v : V) :
+    v ∈ Metric.closedBall (0 : V) 1 ↔ L (ambient L v) ∈ HigherHurewicz.realCubeSet n := by
+  change v ∈ Metric.closedBall (0 : V) 1 ↔ ambient L v ∈ target L
+  rw [← ambient_image]
+  exact ((ambient L).injective.mem_set_image).symm
+
+private def Degree.DiskCube.homeomorph {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    [FiniteDimensional ℝ V] {n : ℕ} (L : V ≃L[ℝ] (Fin n → ℝ)) :
+    Degree.DiskCylinder.Disk (E := V) ≃ₜ (Fin n → (unitInterval)) :=
+  (((ambient L).trans L.toHomeomorph).subtype (ambient_mem_iff L)).trans
+    (HigherHurewicz.realCubeHomeomorph n)
+
+private theorem Degree.DiskCube.boundary_iff {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    [FiniteDimensional ℝ V] {n : ℕ} (L : V ≃L[ℝ] (Fin n → ℝ))
+    (z : Degree.DiskCylinder.Disk (E := V)) :
+    homeomorph L z ∈ Cube.boundary (Fin n) ↔ ‖(z : V)‖ = 1 := by
+  change HigherHurewicz.realCubeHomeomorph n _ ∈ Cube.boundary (Fin n) ↔ _
+  rw [HigherHurewicz.realCubeHomeomorph_mem_boundary_iff]
+  change L (ambient L z.val) ∈ frontier (HigherHurewicz.realCubeSet n) ↔ _
+  have hpre :
+    L (ambient L z.val) ∈ frontier (HigherHurewicz.realCubeSet n) ↔
+      ambient L z.val ∈ frontier (target L) := by
+    change ambient L z.val ∈ L.toHomeomorph ⁻¹' frontier (HigherHurewicz.realCubeSet n) ↔ _
+    rw [L.toHomeomorph.preimage_frontier]
+    rfl
+  rw [hpre, ← ambient_frontier]
+  rw [(ambient L).injective.mem_set_image]
+  rw [frontier_closedBall (0 : V) (one_ne_zero), mem_sphere_zero_iff_norm]
+
+private theorem
+    Degree.DiskCube.symm_boundary_iff {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    [FiniteDimensional ℝ V] {n : ℕ} (L : V ≃L[ℝ] (Fin n → ℝ)) (z : Fin n → (unitInterval)) :
+    ‖((homeomorph L).symm z : V)‖ = 1 ↔ z ∈ Cube.boundary (Fin n) := by
+  rw [← boundary_iff, Homeomorph.apply_symm_apply]
+
+private theorem Degree.Sphere.piTwo_subsingleton (x : SixSphereCube.StandardSphere) :
+    Subsingleton (π_ 2 SixSphereCube.StandardSphere x) :=
+  SphereHomology.unitSphere_piTwo_subsingleton 3 x
+
+private theorem Degree.Sphere.piThree_subsingleton (x : SixSphereCube.StandardSphere) :
+    Subsingleton (π_ 3 SixSphereCube.StandardSphere x) := by
+  let := piTwo_subsingleton x
+  let := SphereHomology.unitSphere_homology_subsingleton 5 3 (by decide) (by decide)
+  exact (ThirdHurewicz.hurewiczPi3Equiv x).injective.subsingleton
+
+private theorem Degree.Sphere.piFour_subsingleton (x : SixSphereCube.StandardSphere) :
+    Subsingleton (π_ 4 SixSphereCube.StandardSphere x) := by
+  let := piTwo_subsingleton x
+  let := piThree_subsingleton x
+  let := SphereHomology.unitSphere_homology_subsingleton 5 4 (by decide) (by decide)
+  exact (FourthHurewicz.hurewiczPi4Equiv x).injective.subsingleton
+
+private theorem Degree.Sphere.piFive_subsingleton (x : SixSphereCube.StandardSphere) :
+    Subsingleton (π_ 5 SixSphereCube.StandardSphere x) := by
+  let := piTwo_subsingleton x
+  let := piThree_subsingleton x
+  let := piFour_subsingleton x
+  let := SphereHomology.unitSphere_homology_subsingleton 5 5 (by decide) (by decide)
+  exact (FifthHurewicz.hurewiczPi5Equiv x).injective.subsingleton
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Recognition/Smale13.lean b/LeanPool/HopfProblem/Recognition/Smale13.lean
new file mode 100644
index 000000000..8a3de97c3
--- /dev/null
+++ b/LeanPool/HopfProblem/Recognition/Smale13.lean
@@ -0,0 +1,3846 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Recognition.Degree3
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.Recognition.Smale1
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology1
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology2
+import all LeanPool.HopfProblem.Recognition.Smale2
+import all LeanPool.HopfProblem.Recognition.Smale3
+import all LeanPool.HopfProblem.Recognition.Smale4
+import all LeanPool.HopfProblem.Recognition.Degree1
+import all LeanPool.HopfProblem.Recognition.Smale6
+import all LeanPool.HopfProblem.Recognition.Smale7
+import all LeanPool.HopfProblem.Recognition.Smale8
+import all LeanPool.HopfProblem.Recognition.Smale9
+import all LeanPool.HopfProblem.Recognition.Smale10
+import all LeanPool.HopfProblem.Recognition.Smale11
+import all LeanPool.HopfProblem.Recognition.Smale12
+import all LeanPool.HopfProblem.MainTheorem.SixSphereCube3
+import all LeanPool.HopfProblem.Recognition.Degree3
+
+/-!
+# Hopf problem: recognition · smale 13
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem MorseCancel.exists_native_prescribed_centered_passage {E M Z : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} {p : M}
+    [TopologicalSpace Z] [ChartedSpace (EuclideanSpace ℝ (Fin 2)) Z] [IsManifold (𝓡 2) ∞ Z]
+    [SecondCountableTopology Z] (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hdim : Module.finrank ℝ E = 6)
+    [Fact (Module.finrank ℝ d.chart.PositiveCoordinates = 2 + 1)]
+    [Fact (Module.finrank ℝ d.chart.NegativeCoordinates = 2 + 1)]
+    (α : C((Smale.Hemisphere.Sphere 2), d.UpperLevel)) (hαe : Topology.IsEmbedding α)
+    (hdisj : Disjoint (Set.range α) (Set.range d.surgery.beltSphere)) (b : Z → d.UpperLevel)
+    (hbc : IsClosed (Set.range b)) (x : (Smale.Hemisphere.Sphere 2))
+    (v : Metric.sphere (0 : d.chart.PositiveCoordinates) 1) (hx : α x ∉ Set.range b)
+    (hv : d.surgery.beltSphere v ∉ Set.range b) (γ : Path (α x) (d.surgery.beltSphere v)) (k : ℤ)
+    (hk : k = 1 ∨ k = -1) :
+    let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ α →
+      (∀ z, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) α z)) →
+        ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ b →
+          ∃ A :
+            CenteredSheetPassage (Smale.RegularLevel.Model E) α d.surgery.beltSphere x v
+              (Set.range b),
+            ∃ L : (EuclideanSpace ℝ (Fin 3)) ≃L[ℝ] d.chart.NegativeCoordinates,
+              HasFDerivAt
+                  (fun z : (EuclideanSpace ℝ (Fin 3)) =>
+                    d.beltNormal
+                      (A.family
+                        ((radialParameterChart (1 / 2) x z).1,
+                          α (radialParameterChart (1 / 2) x z).2)))
+                  L.toContinuousLinearMap 0 ∧
+                SingularMayerVietoris.singularHomologyMap
+                    (Smale.LinearSphereAction.sphereMap L.toContinuousLinearMap L.injective) 2 =
+                  k •
+                    SingularMayerVietoris.singularHomologyMap
+                      ((Smale.SphereCoordinates.standardParametrization
+                            d.chart.NegativeCoordinates 2).toHomeomorph :
+                        C((Smale.Hemisphere.Sphere 2),
+                          Metric.sphere (0 : d.chart.NegativeCoordinates) 1))
+                      2 := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  dsimp only
+  intro hα hαi hb
+  obtain ⟨A₀, A₁, L₀, L₁, hL₀, hL₁, hdet⟩ :=
+    exists_native_opposite_centered_passages d hf hdim α hαe hdisj b hbc x v hx hv γ hα hαi hb
+  exact
+    choose_prescribed_normal_passage d.beltNormal
+      (Smale.SphereCoordinates.standardParametrization d.chart.NegativeCoordinates 2).toHomeomorph
+      A₀ A₁ L₀ L₁ hL₀ hL₁ hdet k hk
+
+private theorem MorseCancel.exists_native_prescribed_finite_family_passage {ι E M : Type} [Finite ι]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) [Fact (Module.finrank ℝ d.chart.PositiveCoordinates = 2 + 1)]
+    [Fact (Module.finrank ℝ d.chart.NegativeCoordinates = 2 + 1)]
+    (a : ι → C((Smale.Hemisphere.Sphere 2), d.UpperLevel))
+    (hpair : Pairwise (fun j k => Disjoint (Set.range (a j)) (Set.range (a k)))) (i : ι)
+    (hfe : Topology.IsEmbedding (a i))
+    (hdisj : Disjoint (Set.range (a i)) (Set.range d.surgery.beltSphere))
+    (x : (Smale.Hemisphere.Sphere 2)) (v : Metric.sphere (0 : d.chart.PositiveCoordinates) 1)
+    (hv : d.surgery.beltSphere v ∉ Degree.MorseRearrangement.otherSheetImages (fun j => a j) i)
+    (γ : Path (a i x) (d.surgery.beltSphere v)) (k : ℤ) (hk : k = 1 ∨ k = -1) :
+    let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    (∀ j, ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ (a j)) →
+      (∀ z, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) (a i) z)) →
+        ∃ A :
+          CenteredSheetPassage (Smale.RegularLevel.Model E) (a i) d.surgery.beltSphere x v
+            (Degree.MorseRearrangement.otherSheetImages (fun j => a j) i),
+          ∃ L : (EuclideanSpace ℝ (Fin 3)) ≃L[ℝ] d.chart.NegativeCoordinates,
+            HasFDerivAt
+                (fun z : (EuclideanSpace ℝ (Fin 3)) =>
+                  d.beltNormal
+                    (A.family
+                      ((radialParameterChart (1 / 2) x z).1,
+                        a i (radialParameterChart (1 / 2) x z).2)))
+                L.toContinuousLinearMap 0 ∧
+              SingularMayerVietoris.singularHomologyMap
+                  (Smale.LinearSphereAction.sphereMap L.toContinuousLinearMap L.injective) 2 =
+                k •
+                  SingularMayerVietoris.singularHomologyMap
+                    ((Smale.SphereCoordinates.standardParametrization d.chart.NegativeCoordinates
+                          2).toHomeomorph :
+                      C((Smale.Hemisphere.Sphere 2),
+                        Metric.sphere (0 : d.chart.NegativeCoordinates) 1))
+                    2 := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  dsimp only
+  intro ha hfi
+  obtain ⟨n, b, hb, hbrange⟩ :=
+    Degree.MorseRearrangement.exists_sheetSumMap_for_finite_family
+      (fun j : { j : ι // j ≠ i } => a j.val) (fun j => ha j.val)
+  have hrange : Set.range b = Degree.MorseRearrangement.otherSheetImages (fun j => a j) i :=
+    hbrange
+  have hbc : IsClosed (Set.range b) := (isCompact_range hb.continuous).isClosed
+  have hx : a i x ∉ Set.range b := by
+    rw [hrange]
+    intro hx
+    obtain ⟨j, hj⟩ := Set.mem_iUnion.mp hx
+    exact Set.disjoint_left.mp (hpair (Ne.symm j.property)) (Set.mem_range_self x) hj
+  have hvb : d.surgery.beltSphere v ∉ Set.range b := by rwa [hrange]
+  obtain ⟨A, L, hL, hunit⟩ :=
+    exists_native_prescribed_centered_passage d hf hdim (a i) hfe hdisj b hbc x v hx hvb γ k hk
+      (ha i) hfi hb
+  let A' :
+    CenteredSheetPassage (Smale.RegularLevel.Model E) (a i) d.surgery.beltSphere x v
+      (Degree.MorseRearrangement.otherSheetImages (fun j => a j) i) :=
+    { A with avoids := by rw [← hrange]; exact A.avoids }
+  exact ⟨A', L, hL, hunit⟩
+
+private theorem
+    AdaptedWindows.exists_higher_family_prescribed_passage {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PathConnectedSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hdim : Module.finrank ℝ E = 6)
+    (horder :
+      ∀ p q : Smale.ManifoldMorse.criticalPoints E f,
+        f p < f q → MorseCancel.nativeMorseIndex E f p ≤ MorseCancel.nativeMorseIndex E f q)
+    (q : Smale.ManifoldMorse.criticalPoints E f) (hq : MorseCancel.nativeMorseIndex E f q = 3)
+    {a : ℝ} (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f) (haq : a < f q)
+    {n : ℕ} (p : Fin n → Smale.ManifoldMorse.criticalPoints E f) (i : Fin n)
+    (hp : ∀ j, MorseCancel.nativeMorseIndex E f (p j) = 3)
+    (hhigh : ∀ j, S.toSurgeryWindows.upper q < f (p j))
+    (α : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (hα : MorseCancel.IsNativeMiddleBasinFamily S hf ha p (fun j => α j)) (k : ℤ)
+    (hk : k = 1 ∨ k = -1) :
+    let _ := Smale.RegularLevel.chartedSpace hf (S.data q).upper_regular
+    let _ : Fact (Module.finrank ℝ (S.data q).chart.PositiveCoordinates = 2 + 1) :=
+      ⟨by
+        have hsplit := (S.data q).chart.finrank_negative_add_positive
+        have hn := (MorseCancel.nativeMorseIndex_eq_chart (S.data q).chart).symm.trans hq
+        omega⟩
+    let _ : Fact (Module.finrank ℝ (S.data q).chart.NegativeCoordinates = 2 + 1) :=
+      ⟨(MorseCancel.nativeMorseIndex_eq_chart (S.data q).chart).symm.trans hq⟩
+    ∃ β : Fin n → C((Smale.Hemisphere.Sphere 2), (S.data q).UpperLevel),
+      MorseCancel.IsNativeMiddleBasinFamily S hf (S.data q).upper_regular p (fun j => β j) ∧
+        (∀ j x, ∃ t : ℝ, S.flow t (α j x).val = (β j x).val) ∧
+          (∀ j, Disjoint (Set.range (β j)) (Set.range (S.data q).surgery.beltSphere)) ∧
+            ∃ (x : (Smale.Hemisphere.Sphere 2)) (v :
+              Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1),
+              ∃ A :
+                MorseCancel.CenteredSheetPassage (Smale.RegularLevel.Model E) (β i)
+                  (S.data q).surgery.beltSphere x v
+                  (Degree.MorseRearrangement.otherSheetImages (fun j => β j) i),
+                ∃ L : (EuclideanSpace ℝ (Fin 3)) ≃L[ℝ] (S.data q).chart.NegativeCoordinates,
+                  HasFDerivAt
+                      (fun z : (EuclideanSpace ℝ (Fin 3)) =>
+                        (S.data q).beltNormal
+                          (A.family
+                            ((MorseCancel.radialParameterChart (1 / 2) x z).1,
+                              β i (MorseCancel.radialParameterChart (1 / 2) x z).2)))
+                      L.toContinuousLinearMap 0 ∧
+                    SingularMayerVietoris.singularHomologyMap
+                        (Smale.LinearSphereAction.sphereMap L.toContinuousLinearMap L.injective)
+                        2 =
+                      k •
+                        SingularMayerVietoris.singularHomologyMap
+                          ((Smale.SphereCoordinates.standardParametrization
+                                (S.data q).chart.NegativeCoordinates 2).toHomeomorph :
+                            C((Smale.Hemisphere.Sphere 2),
+                              Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1))
+                          2 := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data q).upper_regular
+  let _ := Smale.RegularLevel.isManifold hf (S.data q).upper_regular
+  let _ : CompactSpace (S.data q).UpperLevel :=
+    isCompact_iff_compactSpace.mp (isClosed_eq hf.continuous continuous_const).isCompact
+  let _ : Fact (Module.finrank ℝ (S.data q).chart.PositiveCoordinates = 2 + 1) :=
+    ⟨by
+      have hsplit := (S.data q).chart.finrank_negative_add_positive
+      have hn := (MorseCancel.nativeMorseIndex_eq_chart (S.data q).chart).symm.trans hq
+      omega⟩
+  let _ : Fact (Module.finrank ℝ (S.data q).chart.NegativeCoordinates = 2 + 1) :=
+    ⟨(MorseCancel.nativeMorseIndex_eq_chart (S.data q).chart).symm.trans hq⟩
+  obtain ⟨β₀, hβ₀, horbit₀⟩ :=
+    S.exists_higher_middle_family hf (haq.trans (S.toSurgeryWindows.value_lt_upper q)) ha
+      (S.data q).upper_regular p i hp hhigh α hα
+  let β : Fin n → C((Smale.Hemisphere.Sphere 2), (S.data q).UpperLevel) := β₀
+  have hβ :
+    MorseCancel.IsNativeMiddleBasinFamily S hf (S.data q).upper_regular p (fun j => β j) := hβ₀
+  have horbit : ∀ j x, ∃ t : ℝ, S.flow t (α j x).val = (β j x).val := horbit₀
+  have hdisj (j : Fin n) : Disjoint (Set.range (β j)) (Set.range (S.data q).surgery.beltSphere) :=
+    by
+    apply Set.disjoint_left.mpr
+    rintro y ⟨x, rfl⟩ hy
+    exact S.upper_point_not_on_belt_of_lower_orbit hf q haq (α j x) (β j x) (horbit j x) hy
+  let x : (Smale.Hemisphere.Sphere 2) := Smale.Hemisphere.point Bool.true ⟨0, by simp⟩
+  let v :=
+    Smale.SphereCoordinates.standardParametrization (S.data q).chart.PositiveCoordinates 2 x
+  have hv :
+    (S.data q).surgery.beltSphere v ∉
+      Degree.MorseRearrangement.otherSheetImages (fun j => β j) i := by
+    intro h
+    obtain ⟨j, hj⟩ := Set.mem_iUnion.mp h
+    exact Set.disjoint_left.mp (hdisj j.val) hj (Set.mem_range_self v)
+  let _ : PathConnectedSpace (S.data q).UpperLevel :=
+    S.pathConnectedSpace_index_three_upper_level hf hdim horder q hq (β i x)
+  obtain ⟨A, L, hL, hunit⟩ :=
+    MorseCancel.exists_native_prescribed_finite_family_passage (S.data q) hf hdim β hβ.2.2.2.1 i
+      (hβ.2.1 i).isEmbedding (hdisj i) x v hv
+      (PathConnectedSpace.somePath (β i x) ((S.data q).surgery.beltSphere v)) k hk hβ.1
+      (hβ.2.2.1 i)
+  exact ⟨β, hβ, horbit, hdisj, x, v, A, L, hL, hunit⟩
+
+private theorem AdaptedWindows.prescribed_passage_actual_endpoint_classes {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (q : Smale.ManifoldMorse.criticalPoints E f) (hq : MorseCancel.nativeMorseIndex E f q = 3)
+    [Fact (Module.finrank ℝ (S.data q).chart.NegativeCoordinates = 2 + 1)]
+    (H : C(ℝ × (Smale.Hemisphere.Sphere 2), (S.data q).UpperLevel)) {τ : ℝ}
+    (hτ : τ ∈ Set.Ioo (0 : ℝ) 1) (x₀ : (Smale.Hemisphere.Sphere 2))
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1)
+    (hpoint : (S.data q).surgery.beltSphere v = H (τ, x₀))
+    (hcross :
+      ∀ t ∈ Set.Icc (0 : ℝ) 1,
+        ∀ x : (Smale.Hemisphere.Sphere 2),
+          H (t, x) ∈ Set.range (S.data q).surgery.beltSphere ↔ t = τ ∧ x = x₀)
+    (β δ : C((Smale.Hemisphere.Sphere 2), (S.data q).LowerLevel))
+    (hβ : ∀ x, ∃ t : ℝ, S.flow t (H (0, x)).val = (β x).val)
+    (hδ : ∀ x, ∃ t : ℝ, S.flow t (H (1, x)).val = (δ x).val) (k : ℤ)
+    (L : (EuclideanSpace ℝ (Fin 3)) ≃L[ℝ] (S.data q).chart.NegativeCoordinates)
+    (hL :
+      HasFDerivAt
+        (fun z : (EuclideanSpace ℝ (Fin 3)) =>
+          (S.data q).beltNormal (H (MorseCancel.radialParameterChart τ x₀ z)))
+        L.toContinuousLinearMap 0)
+    (hunit :
+      SingularMayerVietoris.singularHomologyMap
+          (Smale.LinearSphereAction.sphereMap L.toContinuousLinearMap L.injective) 2 =
+        k •
+          SingularMayerVietoris.singularHomologyMap
+            ((Smale.SphereCoordinates.standardParametrization (S.data q).chart.NegativeCoordinates
+                  2).toHomeomorph :
+              C((Smale.Hemisphere.Sphere 2),
+                Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1))
+            2) :
+    let _ := Smale.RegularLevel.chartedSpace hf (S.data q).upper_regular
+    ContMDiffAt (𝓘(ℝ, ℝ).prod (𝓡 2)) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ H (τ, x₀) →
+      SingularMayerVietoris.singularHomologyMap δ 2 =
+        SingularMayerVietoris.singularHomologyMap β 2 +
+          k •
+            SingularMayerVietoris.singularHomologyMap
+              (MorseCancel.nativeIndexThreeAttachingSphere S q hq) 2 := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data q).upper_regular
+  dsimp only
+  intro hH
+  obtain ⟨D, _, hunique, hrelation⟩ :=
+    S.exists_passage_derivative_class_addition hf q H hτ x₀ v hpoint hcross L hL hH
+  let G :=
+    D.comp
+      (Degree.PassageHomology.puncturedPassageTrace H (Set.range (S.data q).surgery.beltSphere) hτ
+        x₀ hcross)
+  have hmap (s : ℝ) (hs : s ∈ Set.Icc (0 : ℝ) 1) (hsτ : s ≠ τ)
+    (σ : C((Smale.Hemisphere.Sphere 2), (S.data q).LowerLevel))
+    (hσ : ∀ x, ∃ t : ℝ, S.flow t (H (s, x)).val = (σ x).val) :
+    G.comp (Degree.PassageHomology.cylinderSlice τ x₀ s hsτ) = σ := by
+    apply ContinuousMap.ext
+    intro x
+    obtain ⟨t, ht⟩ := hσ x
+    apply hunique _ (σ x) t
+    have heq :=
+      Degree.PassageHomology.puncturedPassageTrace_on_interval H
+        (Set.range (S.data q).surgery.beltSphere) hτ x₀ hcross
+        (Degree.PassageHomology.cylinderSlice τ x₀ s hsτ x) hs
+    change
+      S.flow t
+          (Degree.PassageHomology.puncturedPassageTrace H
+              (Set.range (S.data q).surgery.beltSphere) hτ x₀ hcross
+              (Degree.PassageHomology.cylinderSlice τ x₀ s hsτ x)).val.val =
+        (σ x).val
+    rw [heq]
+    exact ht
+  have hzero := hmap 0 ⟨le_rfl, zero_le_one⟩ hτ.1.ne β hβ
+  have hone := hmap 1 ⟨zero_le_one, le_rfl⟩ hτ.2.ne' δ hδ
+  have hcoef :
+    SingularMayerVietoris.singularHomologyMap
+        ((S.data q).surgery.attachingSphere.comp
+          (Smale.LinearSphereAction.sphereMap L.toContinuousLinearMap L.injective))
+        2 =
+      k •
+        SingularMayerVietoris.singularHomologyMap
+          (MorseCancel.nativeIndexThreeAttachingSphere S q hq) 2 := by
+    change
+      SingularMayerVietoris.singularHomologyMap
+          ((S.data q).surgery.attachingSphere.comp
+            (Smale.LinearSphereAction.sphereMap L.toContinuousLinearMap L.injective))
+          2 =
+        k •
+          SingularMayerVietoris.singularHomologyMap
+            ((S.data q).surgery.attachingSphere.comp
+              ((Smale.SphereCoordinates.standardParametrization
+                    (S.data q).chart.NegativeCoordinates 2).toHomeomorph :
+                C((Smale.Hemisphere.Sphere 2),
+                  Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)))
+            2
+    rw [PeriodTorusHigherHomology.singularHomologyMap_comp,
+      PeriodTorusHigherHomology.singularHomologyMap_comp, hunit]
+    apply LinearMap.ext
+    intro a
+    exact
+      map_zsmul (SingularMayerVietoris.singularHomologyMap (S.data q).surgery.attachingSphere 2) k
+        _
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (G.comp (Degree.PassageHomology.cylinderSlice τ x₀ 1 hτ.2.ne')) 2 =
+      SingularMayerVietoris.singularHomologyMap
+          (G.comp (Degree.PassageHomology.cylinderSlice τ x₀ 0 hτ.1.ne)) 2 +
+        SingularMayerVietoris.singularHomologyMap
+          ((S.data q).surgery.attachingSphere.comp
+            (Smale.LinearSphereAction.sphereMap L.toContinuousLinearMap L.injective))
+          2 at hrelation
+  rw [hone, hzero, hcoef] at hrelation
+  exact hrelation
+
+private theorem AdaptedWindows.exists_prescribed_family_slide {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PathConnectedSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (hdim : Module.finrank ℝ E = 6)
+    (horder :
+      ∀ p q : Smale.ManifoldMorse.criticalPoints E f,
+        f p < f q → MorseCancel.nativeMorseIndex E f p ≤ MorseCancel.nativeMorseIndex E f q)
+    (q : Smale.ManifoldMorse.criticalPoints E f) (hq : MorseCancel.nativeMorseIndex E f q = 3)
+    {a : ℝ} (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f) (haq : a < f q)
+    {n : ℕ} (p : Fin n → Smale.ManifoldMorse.criticalPoints E f) (i : Fin n)
+    (hp : ∀ j, MorseCancel.nativeMorseIndex E f (p j) = 3)
+    (hhigh : ∀ j, S.toSurgeryWindows.upper q < f (p j))
+    (α : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (hα : MorseCancel.IsNativeMiddleBasinFamily S hf ha p (fun j => α j)) (k : ℤ)
+    (hk : k = 1 ∨ k = -1) (ε : Smale.ManifoldMorse.criticalPoints E f → ℝ) (hε : ∀ z, 0 < ε z) :
+    ∃ T : AdaptedWindows E f,
+      (∀ z, (T.data z).chart = (S.data z).chart) ∧
+        (∀ z, (T.data z).radius < ε z) ∧
+          (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ y in 𝓝 z, T.field y = S.field y) ∧
+            ∃ β δ : Fin n → C((Smale.Hemisphere.Sphere 2), (S.data q).LowerLevel),
+              MorseCancel.IsNativeMiddleBasinFamily S hf (S.data q).lower_regular p
+                  (fun j => β j) ∧
+                MorseCancel.IsNativeMiddleBasinFamily T hf (S.data q).lower_regular p
+                    (fun j => δ j) ∧
+                  (∀ j x, ∃ t : ℝ, S.flow t (α j x).val = (β j x).val) ∧
+                    (∀ j, j ≠ i → δ j = β j) ∧
+                      (∀ j, j ≠ i → ∀ x, ∃ t : ℝ, T.flow t (δ j x).val = (α j x).val) ∧
+                        (SingularMayerVietoris.singularHomologyMap (δ i) 2 =
+                            SingularMayerVietoris.singularHomologyMap (β i) 2 +
+                              k •
+                                SingularMayerVietoris.singularHomologyMap
+                                  (MorseCancel.nativeIndexThreeAttachingSphere S q hq) 2) ∧
+                          ∀ z : M,
+                            f z ≤ f q →
+                              (∀ x,
+                                  Filter.Tendsto (fun t => T.flow t x) Filter.atBot (𝓝 z) ↔
+                                    Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 z)) ∧
+                                (∀ x,
+                                    Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 z) →
+                                      Set.range (fun t => T.flow t x) =
+                                        Set.range (fun t => S.flow t x)) ∧
+                                  ∀ v,
+                                    Filter.Tendsto (fun t => T.flow t z) Filter.atTop (𝓝 v) ↔
+                                      Filter.Tendsto (fun t => S.flow t z) Filter.atTop (𝓝 v) := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data q).upper_regular
+  let _ : Fact (Module.finrank ℝ (S.data q).chart.PositiveCoordinates = 2 + 1) :=
+    ⟨by
+      have hsplit := (S.data q).chart.finrank_negative_add_positive
+      have hn := (MorseCancel.nativeMorseIndex_eq_chart (S.data q).chart).symm.trans hq
+      omega⟩
+  let _ : Fact (Module.finrank ℝ (S.data q).chart.NegativeCoordinates = 2 + 1) :=
+    ⟨(MorseCancel.nativeMorseIndex_eq_chart (S.data q).chart).symm.trans hq⟩
+  obtain ⟨γ, hγ, hαγ, havoid, x₀, v, A, L, hL, hunit⟩ :=
+    S.exists_higher_family_prescribed_passage hf hdim horder q hq ha haq p i hp hhigh α hα k hk
+  let τ : ℝ := 1 / 2
+  have hτ : τ ∈ Set.Ioo (0 : ℝ) 1 := by constructor <;> norm_num [τ]
+  let F := A.family
+  let K := A.support
+  have hK := A.compact_support
+  have hKU := A.avoids
+  have hF := A.smooth
+  have hF0 := A.zero
+  have hFd := A.slices
+  have hFfix := A.fixedOutside
+  have hcount := A.crossing
+  obtain ⟨D, hD⟩ := hFd 1
+  have I :
+    Smale.SupportedDiffeomorph.SupportedRelativeIsotopy D K
+      (Degree.MorseRearrangement.otherSheetImages (fun j => γ j) i) :=
+    { family := F
+      smooth := hF
+      zero := hF0
+      one := fun x => (hD x).symm
+      slices := hFd
+      fixedOutside := hFfix
+      fixedOn := fun t x hx => hFfix t x (fun h => hKU h hx) }
+  have hDavoid (j : Fin n) :
+    Disjoint (Set.range (D ∘ γ j)) (Set.range (S.data q).surgery.beltSphere) := by
+    apply Set.disjoint_left.mpr
+    rintro y ⟨x, rfl⟩ ⟨w, hw⟩
+    by_cases hji : j = i
+    · subst j
+      have heq : F (1, γ i x) = (S.data q).surgery.beltSphere w := (hD _).symm.trans hw.symm
+      exact hτ.2.ne' ((hcount 1 ⟨zero_le_one, le_rfl⟩ x w).mp heq).1
+    · have heq : D (γ j x) = γ j x :=
+        I.endpoint_fixed_on (γ j x)
+          (Degree.MorseRearrangement.mem_otherSheetImages (fun j => γ j) i j hji x)
+      exact Set.disjoint_left.mp (havoid j) (Set.mem_range_self x) ⟨w, hw.trans heq⟩
+  obtain
+    ⟨T, hcharts, hradii, hgerms, β, δ, hβ, hδ, hβflow, hδflow, hδold, hother, hprotected,
+      hkeep⟩ :=
+    S.exists_relative_family_lower_transport hf hm q hq p i hhigh γ hγ havoid ε hε D K hK I
+      hDavoid
+  let H : C(ℝ × (Smale.Hemisphere.Sphere 2), (S.data q).UpperLevel) :=
+    ⟨fun z => F (z.1, γ i z.2),
+      hF.continuous.comp (continuous_fst.prodMk ((γ i).continuous.comp continuous_snd))⟩
+  have hH : ContMDiff (𝓘(ℝ, ℝ).prod (𝓡 2)) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ H :=
+    hF.comp (contMDiff_fst.prodMk ((hγ.1 i).comp contMDiff_snd))
+  have hpoint : (S.data q).surgery.beltSphere v = H (τ, x₀) :=
+    ((hcount τ ⟨hτ.1.le, hτ.2.le⟩ x₀ v).mpr ⟨rfl, rfl, rfl⟩).symm
+  have hcross :
+    ∀ t ∈ Set.Icc (0 : ℝ) 1,
+      ∀ x : (Smale.Hemisphere.Sphere 2),
+        H (t, x) ∈ Set.range (S.data q).surgery.beltSphere ↔ t = τ ∧ x = x₀ := by
+    intro t ht x
+    constructor
+    · rintro ⟨w, hw⟩
+      have hh := (hcount t ht x w).mp hw.symm
+      exact ⟨hh.1, hh.2.1⟩
+    · rintro ⟨rfl, rfl⟩
+      exact ⟨v, hpoint⟩
+  have hstart (x : (Smale.Hemisphere.Sphere 2)) :
+    ∃ t : ℝ, S.flow t (H (0, x)).val = (β i x).val := by
+    change ∃ t : ℝ, S.flow t (A.family (0, γ i x)).val = (β i x).val
+    rw [hF0]
+    exact hβflow i x
+  have hend (x : (Smale.Hemisphere.Sphere 2)) : ∃ t : ℝ, S.flow t (H (1, x)).val = (δ i x).val := by
+    change ∃ t : ℝ, S.flow t (A.family (1, γ i x)).val = (δ i x).val
+    rw [← hD]
+    exact hδold i x
+  have hclasses :=
+    S.prescribed_passage_actual_endpoint_classes hf q hq H hτ x₀ v hpoint hcross (β i) (δ i)
+      hstart hend k L hL hunit hH.contMDiffAt
+  refine ⟨T, hcharts, hradii, hgerms, β, δ, hβ, hδ, ?_, hother, ?_, hclasses, hkeep⟩
+  · intro j x
+    obtain ⟨s, hs⟩ := hαγ j x
+    obtain ⟨t, ht⟩ := hβflow j x
+    exact ⟨t + s, by rw [S.flow.map_add, hs, ht]⟩
+  · intro j hji x
+    obtain ⟨s, hs⟩ := hαγ j x
+    have hm : (α j x).val ∈ Set.range (fun t => S.flow t (γ j x).val) := by
+      refine ⟨-s, ?_⟩
+      change S.flow (-s) (γ j x).val = (α j x).val
+      rw [← hs, ← S.flow.map_add, neg_add_cancel, S.flow.map_zero_apply]
+    rw [← hprotected j hji x] at hm
+    obtain ⟨t, ht⟩ := hm
+    change T.flow t (γ j x).val = (α j x).val at ht
+    obtain ⟨u, hu⟩ := hδflow j x
+    exact ⟨t - u, by rw [← hu, ← T.flow.map_add, sub_add_cancel, ht]⟩
+
+private theorem
+    AdaptedWindows.exists_common_cut_prescribed_slide {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PathConnectedSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (hdim : Module.finrank ℝ E = 6)
+    (horder :
+      ∀ p q : Smale.ManifoldMorse.criticalPoints E f,
+        f p < f q → MorseCancel.nativeMorseIndex E f p ≤ MorseCancel.nativeMorseIndex E f q)
+    (q : Smale.ManifoldMorse.criticalPoints E f) (hq : MorseCancel.nativeMorseIndex E f q = 3)
+    {a : ℝ} (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hal : a < S.toSurgeryWindows.lower q)
+    (hband :
+      ∀ y,
+        f y ∈ Set.Icc a (S.toSurgeryWindows.lower q) → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    {n : ℕ} (p : Fin n → Smale.ManifoldMorse.criticalPoints E f) (i : Fin n)
+    (hp : ∀ j, MorseCancel.nativeMorseIndex E f (p j) = 3)
+    (hhigh : ∀ j, S.toSurgeryWindows.upper q < f (p j))
+    (αq : C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (α : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (hfamily :
+      MorseCancel.IsNativeMiddleBasinFamily S hf ha (Fin.cases q p) (Fin.cases αq (fun j => α j)))
+    (hαq :
+      ∀ x,
+        ∃ t : ℝ, S.flow t (MorseCancel.nativeIndexThreeAttachingSphere S q hq x).val = (αq x).val)
+    (k : ℤ) (hk : k = 1 ∨ k = -1) (ε : Smale.ManifoldMorse.criticalPoints E f → ℝ)
+    (hε : ∀ z, 0 < ε z) :
+    ∃ T : AdaptedWindows E f,
+      (∀ z, (T.data z).chart = (S.data z).chart) ∧
+        (∀ z, (T.data z).radius < ε z) ∧
+          (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ y in 𝓝 z, T.field y = S.field y) ∧
+            ∃ Γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }),
+              MorseCancel.IsNativeMiddleBasinFamily T hf ha (Fin.cases q p)
+                  (Fin.cases αq (fun j => Γ j)) ∧
+                (∀ j, j ≠ i → Γ j = α j) ∧
+                  (MorseCancel.middleSectionClass (Γ i) =
+                      MorseCancel.middleSectionClass (α i) +
+                        k • MorseCancel.middleSectionClass αq) ∧
+                    ∀ z : M,
+                      f z ≤ f q →
+                        (∀ x,
+                            Filter.Tendsto (fun t => T.flow t x) Filter.atBot (𝓝 z) ↔
+                              Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 z)) ∧
+                          (∀ x,
+                              Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 z) →
+                                Set.range (fun t => T.flow t x) =
+                                  Set.range (fun t => S.flow t x)) ∧
+                            ∀ v,
+                              Filter.Tendsto (fun t => T.flow t z) Filter.atTop (𝓝 v) ↔
+                                Filter.Tendsto (fun t => S.flow t z) Filter.atTop (𝓝 v) := by
+  let _ := Smale.RegularLevel.chartedSpace hf ha
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data q).lower_regular
+  obtain ⟨hs, he, hi, hpair, hfull⟩ := hfamily
+  have hα : MorseCancel.IsNativeMiddleBasinFamily S hf ha p (fun j => α j) := by
+    refine ⟨fun j => hs j.succ, fun j => he j.succ, fun j => hi j.succ, ?_, fun j => hfull j.succ⟩
+    intro j k hjk
+    exact hpair (fun h => hjk (Fin.succ_inj.mp h))
+  obtain ⟨T, hcharts, hradii, hgerms, β, δ, hβ, hδ, hαβ, hother, hprotected, hmaps, hkeep⟩ :=
+    S.exists_prescribed_family_slide hf hm hdim horder q hq ha
+      (hal.trans (S.toSurgeryWindows.lower_lt_value q)) p i hp hhigh α hα k hk ε hε
+  have hgap :
+    ∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, f z ∉ Set.Icc a (S.toSurgeryWindows.lower q) :=
+    fun z hz h => hband z h hz
+  have hpabove (j : Fin n) : S.toSurgeryWindows.lower q < f (p j) :=
+    (S.toSurgeryWindows.lower_lt_value q).trans
+      ((S.toSurgeryWindows.value_lt_upper q).trans (hhigh j))
+  let x₀ : (Smale.Hemisphere.Sphere 2) := Smale.Hemisphere.point Bool.true ⟨0, by simp⟩
+  obtain ⟨Γ₀, hΓ₀, hδΓ⟩ :=
+    T.exists_regular_band_middle_basin_family hf hal (S.data q).lower_regular ha hgap (δ i x₀) p
+      hpabove (fun j => δ j) hδ
+  let Γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }) := fun j =>
+    ⟨Γ₀ j, (hΓ₀.1 j).continuous⟩
+  have hΓ : MorseCancel.IsNativeMiddleBasinFamily T hf ha p (fun j => Γ j) := hΓ₀
+  have hαqfull (y : { z : M // f z = a }) :
+    y ∈ Set.range αq ↔ Filter.Tendsto (fun t => T.flow t y.val) Filter.atBot (𝓝 q.val) :=
+    (hfull 0 y).trans ((hkeep q.val le_rfl).1 y.val).symm
+  have hdisj (j : Fin n) : Disjoint (Set.range αq) (Set.range (Γ j)) := by
+    apply Set.disjoint_left.mpr
+    intro y hyq hyj
+    have heq : q.val = (p j).val :=
+      tendsto_nhds_unique ((hαqfull y).mp hyq) ((hΓ.2.2.2.2 j y).mp hyj)
+    exact ((S.toSurgeryWindows.value_lt_upper q).trans (hhigh j)).ne (congrArg f heq)
+  have hΓpair :
+    Pairwise
+      (fun j k =>
+        Disjoint (Set.range (Fin.cases αq (fun j => Γ j) j))
+          (Set.range (Fin.cases αq (fun j => Γ j) k))) := by
+    intro j k hjk
+    cases j using Fin.cases with
+    | zero =>
+      cases k using Fin.cases with
+      | zero => exact (hjk rfl).elim
+      | succ k => exact hdisj k
+    | succ j =>
+      cases k using Fin.cases with
+      | zero => exact (hdisj j).symm
+      | succ k => exact hΓ.2.2.2.1 (fun h => hjk (congrArg Fin.succ h))
+  refine ⟨T, hcharts, hradii, hgerms, Γ, ?_, ?_, ?_, hkeep⟩
+  · refine ⟨?_, ?_, ?_, hΓpair, ?_⟩
+    · intro j
+      cases j using Fin.cases with
+      | zero => exact hs 0
+      | succ j => exact hΓ.1 j
+    · intro j
+      cases j using Fin.cases with
+      | zero => exact he 0
+      | succ j => exact hΓ.2.1 j
+    · intro j
+      cases j using Fin.cases with
+      | zero => exact hi 0
+      | succ j => exact hΓ.2.2.1 j
+    · intro j
+      cases j using Fin.cases with
+      | zero => exact hαqfull
+      | succ j => exact hΓ.2.2.2.2 j
+  · intro j hji
+    apply ContinuousMap.ext
+    intro x
+    obtain ⟨s, hs⟩ := hδΓ j x
+    change T.flow s (δ j x).val = (Γ j x).val at hs
+    obtain ⟨t, ht⟩ := hprotected j hji x
+    have hshared : T.flow 0 (Γ j x).val = T.flow (s - t) (α j x).val := by
+      rw [T.flow.map_zero_apply, ← hs, ← ht, ← T.flow.map_add, sub_add_cancel]
+    apply Subtype.ext
+    exact
+      MorseCancel.native_same_level_orbit_points hf T.smooth T.flow T.integral
+        (fun z hz => T.descent z (ha z hz)) (Γ j x).property (α j x).property hshared
+  · have hβα (x : (Smale.Hemisphere.Sphere 2)) : ∃ t : ℝ, S.flow t (β i x).val = (α i x).val := by
+      obtain ⟨t, ht⟩ := hαβ i x
+      exact ⟨-t, by rw [← ht, ← S.flow.map_add, neg_add_cancel, S.flow.map_zero_apply]⟩
+    exact
+      MorseCancel.signed_relation_of_regular_cut_transport S T hf hal ha hband (β i) (δ i)
+        (MorseCancel.nativeIndexThreeAttachingSphere S q hq) (α i) (Γ i) αq k hβα (hδΓ i) hαq
+        hmaps
+
+private theorem AdaptedWindows.exists_common_cut_prescribed_family_slide {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [PathConnectedSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f)
+    (hdim : Module.finrank ℝ E = 6)
+    (horder :
+      ∀ p q : Smale.ManifoldMorse.criticalPoints E f,
+        f p < f q → MorseCancel.nativeMorseIndex E f p ≤ MorseCancel.nativeMorseIndex E f q)
+    (q : Smale.ManifoldMorse.criticalPoints E f) (hq : MorseCancel.nativeMorseIndex E f q = 3)
+    {a : ℝ} (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hal : a < S.toSurgeryWindows.lower q)
+    (hband :
+      ∀ y,
+        f y ∈ Set.Icc a (S.toSurgeryWindows.lower q) → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    {n : ℕ} (p : Fin n → Smale.ManifoldMorse.criticalPoints E f) (i : Fin n)
+    (hp : ∀ j, MorseCancel.nativeMorseIndex E f (p j) = 3)
+    (hhigh : ∀ j, S.toSurgeryWindows.upper q < f (p j))
+    (αq : C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (α : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (hfamily :
+      MorseCancel.IsNativeMiddleBasinFamily S hf ha (Fin.cases q p) (Fin.cases αq (fun j => α j)))
+    (k : ℤ) (hk : k = 1 ∨ k = -1) (ε : Smale.ManifoldMorse.criticalPoints E f → ℝ)
+    (hε : ∀ z, 0 < ε z) :
+    ∃ T : AdaptedWindows E f,
+      (∀ z, (T.data z).chart = (S.data z).chart) ∧
+        (∀ z, (T.data z).radius < ε z) ∧
+          (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ y in 𝓝 z, T.field y = S.field y) ∧
+            ∃ Γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }),
+              MorseCancel.IsNativeMiddleBasinFamily T hf ha (Fin.cases q p)
+                  (Fin.cases αq (fun j => Γ j)) ∧
+                (∀ j, j ≠ i → Γ j = α j) ∧
+                  (MorseCancel.middleSectionClass (Γ i) =
+                      MorseCancel.middleSectionClass (α i) +
+                        k • MorseCancel.middleSectionClass αq) ∧
+                    ∀ z : M,
+                      f z ≤ f q →
+                        (∀ x,
+                            Filter.Tendsto (fun t => T.flow t x) Filter.atBot (𝓝 z) ↔
+                              Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 z)) ∧
+                          (∀ x,
+                              Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 z) →
+                                Set.range (fun t => T.flow t x) =
+                                  Set.range (fun t => S.flow t x)) ∧
+                            ∀ v,
+                              Filter.Tendsto (fun t => T.flow t z) Filter.atTop (𝓝 v) ↔
+                                Filter.Tendsto (fun t => S.flow t z) Filter.atTop (𝓝 v) := by
+  let _ := Smale.RegularLevel.chartedSpace hf ha
+  obtain ⟨βq, hβs, hβe, hβi, hrange, horbit, -⟩ :=
+    S.exists_canonical_basin_sphere hf q hq ha αq (Smale.Hemisphere.point Bool.true ⟨0, by simp⟩)
+      (hfamily.2.2.2.2 0)
+  have hβfamily :=
+    MorseCancel.nativeMiddleBasinFamily_replace_zero S hf ha q p αq βq α hfamily hrange hβs hβe
+      hβi
+  obtain ⟨u, hu, hunit⟩ :=
+    MorseCancel.same_image_section_classes_unit αq βq (hfamily.2.1 0).isEmbedding hβe.isEmbedding
+      hrange
+  have hku : k * u = 1 ∨ k * u = -1 := by
+    rcases hk with rfl | rfl <;> rcases hu with rfl | rfl <;> norm_num
+  obtain ⟨T, hcharts, hradii, hgerms, Γ, hΓ, hother, hclass, hkeep⟩ :=
+    S.exists_common_cut_prescribed_slide hf hm hdim horder q hq ha hal hband p i hp hhigh βq α
+      hβfamily horbit (k * u) hku ε hε
+  have hrestored :=
+    MorseCancel.nativeMiddleBasinFamily_replace_zero T hf ha q p βq αq Γ hΓ hrange.symm
+      (hfamily.1 0) (hfamily.2.1 0) (hfamily.2.2.1 0)
+  have hcancel : (k * u) * u = k := by rcases hu with rfl | rfl <;> ring
+  refine ⟨T, hcharts, hradii, hgerms, Γ, hrestored, hother, ?_, hkeep⟩
+  rw [hclass, hunit, ← SemigroupAction.mul_smul, hcancel]
+
+private theorem
+    MorseCancel.regular_below_pivot_of_regular_lower_band {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    {a : ℝ}
+    (hband : ∀ y, f y ∈ Set.Icc a (S.lower q) → y ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    ∀ y, f y ∈ Set.Ico a (f q) → y ∉ Smale.ManifoldMorse.criticalPoints E f := by
+  intro y hy hcrit
+  by_cases hlow : f y ≤ S.lower q
+  · exact hband y ⟨hy.1, hlow⟩ hcrit
+  · have heq : y = q.val :=
+      S.isolated q y hcrit ⟨(lt_of_not_ge hlow).le, hy.2.le.trans (S.value_lt_upper q).le⟩
+    exact hy.2.ne (congrArg f heq)
+
+private theorem MorseCancel.lower_window_le_of_radius_le {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S T : Smale.ManifoldMorse.SurgeryWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (hr : (T.data q).radius ≤ (S.data q).radius) : S.lower q ≤ T.lower q := by
+  have hs : (T.data q).radius ^ 2 ≤ (S.data q).radius ^ 2 :=
+    (sq_le_sq₀ (T.data q).radius_pos.le (S.data q).radius_pos.le).mpr hr
+  exact sub_le_sub_left hs (f q)
+
+private theorem MorseCancel.common_cut_band_of_smaller_radius {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S T : Smale.ManifoldMorse.SurgeryWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    {a : ℝ} (hal : a < S.lower q)
+    (hband : ∀ y, f y ∈ Set.Icc a (S.lower q) → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hr : (T.data q).radius ≤ (S.data q).radius) :
+    a < T.lower q ∧
+      ∀ y, f y ∈ Set.Icc a (T.lower q) → y ∉ Smale.ManifoldMorse.criticalPoints E f := by
+  refine ⟨hal.trans_le (lower_window_le_of_radius_le S T q hr), ?_⟩
+  intro y hy
+  exact
+    regular_below_pivot_of_regular_lower_band S q hband y
+      ⟨hy.1, hy.2.trans_lt (T.lower_lt_value q)⟩
+
+private theorem
+    MorseCancel.higher_window_separation_of_value_order {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S T : Smale.ManifoldMorse.SurgeryWindows E f) (q p : Smale.ManifoldMorse.criticalPoints E f)
+    (hhigh : S.upper q < f p) : T.upper q < f p :=
+  (T.upper_lt_lower q p ((S.value_lt_upper q).trans hhigh)).trans (T.lower_lt_value p)
+
+private theorem AdaptedWindows.exists_repeatable_column_slide {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PathConnectedSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (hdim : Module.finrank ℝ E = 6)
+    (horder :
+      ∀ p q : Smale.ManifoldMorse.criticalPoints E f,
+        f p < f q → MorseCancel.nativeMorseIndex E f p ≤ MorseCancel.nativeMorseIndex E f q)
+    (q : Smale.ManifoldMorse.criticalPoints E f) (hq : MorseCancel.nativeMorseIndex E f q = 3)
+    {a : ℝ} (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hal : a < S.toSurgeryWindows.lower q)
+    (hband :
+      ∀ y,
+        f y ∈ Set.Icc a (S.toSurgeryWindows.lower q) → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    {n : ℕ} (p : Fin n → Smale.ManifoldMorse.criticalPoints E f) (i : Fin n)
+    (hp : ∀ j, MorseCancel.nativeMorseIndex E f (p j) = 3)
+    (hhigh : ∀ j, S.toSurgeryWindows.upper q < f (p j))
+    (αq : C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (α : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (hfamily :
+      MorseCancel.IsNativeMiddleBasinFamily S hf ha (Fin.cases q p) (Fin.cases αq (fun j => α j)))
+    (k : ℤ) (hk : k = 1 ∨ k = -1) :
+    ∃ T : AdaptedWindows E f,
+      (∀ z, (T.data z).chart = (S.data z).chart) ∧
+        (∀ z, (T.data z).radius ≤ (S.data z).radius) ∧
+          (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ y in 𝓝 z, T.field y = S.field y) ∧
+            a < T.toSurgeryWindows.lower q ∧
+              (∀ y,
+                  f y ∈ Set.Icc a (T.toSurgeryWindows.lower q) →
+                    y ∉ Smale.ManifoldMorse.criticalPoints E f) ∧
+                (∀ j, T.toSurgeryWindows.upper q < f (p j)) ∧
+                  ∃ Γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }),
+                    MorseCancel.IsNativeMiddleBasinFamily T hf ha (Fin.cases q p)
+                        (Fin.cases αq (fun j => Γ j)) ∧
+                      (∀ j, j ≠ i → Γ j = α j) ∧
+                        (MorseCancel.middleSectionClass (Γ i) =
+                            MorseCancel.middleSectionClass (α i) +
+                              k • MorseCancel.middleSectionClass αq) ∧
+                          ∀ z : M,
+                            f z ≤ f q →
+                              (∀ x,
+                                  Filter.Tendsto (fun t => T.flow t x) Filter.atBot (𝓝 z) ↔
+                                    Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 z)) ∧
+                                (∀ x,
+                                    Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 z) →
+                                      Set.range (fun t => T.flow t x) =
+                                        Set.range (fun t => S.flow t x)) ∧
+                                  ∀ v,
+                                    Filter.Tendsto (fun t => T.flow t z) Filter.atTop (𝓝 v) ↔
+                                      Filter.Tendsto (fun t => S.flow t z) Filter.atTop (𝓝 v) := by
+  obtain ⟨T, hcharts, hradii, hgerms, Γ, hΓ, hother, hclass, hkeep⟩ :=
+    S.exists_common_cut_prescribed_family_slide hf hm hdim horder q hq ha hal hband p i hp hhigh
+      αq α hfamily k hk (fun z => (S.data z).radius) (fun z => (S.data z).radius_pos)
+  obtain ⟨hcut, hregular⟩ :=
+    MorseCancel.common_cut_band_of_smaller_radius S.toSurgeryWindows T.toSurgeryWindows q hal
+      hband (hradii q).le
+  have hseparated : ∀ j, T.toSurgeryWindows.upper q < f (p j) := fun j =>
+    MorseCancel.higher_window_separation_of_value_order S.toSurgeryWindows T.toSurgeryWindows q
+      (p j) (hhigh j)
+  exact
+    ⟨T, hcharts, fun z => (hradii z).le, hgerms, hcut, hregular, hseparated, Γ, hΓ, hother,
+      hclass, hkeep⟩
+
+private theorem AdaptedWindows.exists_iterated_column_slide {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PathConnectedSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (hdim : Module.finrank ℝ E = 6)
+    (horder :
+      ∀ p q : Smale.ManifoldMorse.criticalPoints E f,
+        f p < f q → MorseCancel.nativeMorseIndex E f p ≤ MorseCancel.nativeMorseIndex E f q)
+    (q : Smale.ManifoldMorse.criticalPoints E f) (hq : MorseCancel.nativeMorseIndex E f q = 3)
+    {a : ℝ} (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hal : a < S.toSurgeryWindows.lower q)
+    (hband :
+      ∀ y,
+        f y ∈ Set.Icc a (S.toSurgeryWindows.lower q) → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    {n : ℕ} (p : Fin n → Smale.ManifoldMorse.criticalPoints E f) (i : Fin n)
+    (hp : ∀ j, MorseCancel.nativeMorseIndex E f (p j) = 3)
+    (hhigh : ∀ j, S.toSurgeryWindows.upper q < f (p j))
+    (αq : C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (α : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (hfamily :
+      MorseCancel.IsNativeMiddleBasinFamily S hf ha (Fin.cases q p) (Fin.cases αq (fun j => α j)))
+    (k : ℤ) (hk : k = 1 ∨ k = -1) (m : ℕ) :
+    ∃ T : AdaptedWindows E f,
+      (∀ z, (T.data z).chart = (S.data z).chart) ∧
+        (∀ z, (T.data z).radius ≤ (S.data z).radius) ∧
+          (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ y in 𝓝 z, T.field y = S.field y) ∧
+            a < T.toSurgeryWindows.lower q ∧
+              (∀ y,
+                  f y ∈ Set.Icc a (T.toSurgeryWindows.lower q) →
+                    y ∉ Smale.ManifoldMorse.criticalPoints E f) ∧
+                (∀ j, T.toSurgeryWindows.upper q < f (p j)) ∧
+                  ∃ Γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }),
+                    MorseCancel.IsNativeMiddleBasinFamily T hf ha (Fin.cases q p)
+                        (Fin.cases αq (fun j => Γ j)) ∧
+                      (∀ j, j ≠ i → Γ j = α j) ∧
+                        (MorseCancel.middleSectionClass (Γ i) =
+                            MorseCancel.middleSectionClass (α i) +
+                              ((m : ℤ) * k) • MorseCancel.middleSectionClass αq) ∧
+                          ∀ z : M,
+                            f z ≤ f q →
+                              (∀ x,
+                                  Filter.Tendsto (fun t => T.flow t x) Filter.atBot (𝓝 z) ↔
+                                    Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 z)) ∧
+                                (∀ x,
+                                    Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 z) →
+                                      Set.range (fun t => T.flow t x) =
+                                        Set.range (fun t => S.flow t x)) ∧
+                                  ∀ v,
+                                    Filter.Tendsto (fun t => T.flow t z) Filter.atTop (𝓝 v) ↔
+                                      Filter.Tendsto (fun t => S.flow t z) Filter.atTop (𝓝 v) := by
+  induction m with
+  |
+    zero =>
+    refine
+      ⟨S, fun _ => rfl, fun _ => le_rfl, ?_, hal, hband, hhigh, α, hfamily, fun _ _ => rfl, ?_,
+        ?_⟩
+    · intro z hz
+      exact Filter.Eventually.of_forall (fun _ => rfl)
+    · simp only [Nat.cast_zero, MulZeroClass.zero_mul, zero_smul, add_zero]
+    · intro z hz
+      exact ⟨fun _ => Iff.rfl, fun _ _ => rfl, fun _ => Iff.rfl⟩
+  | succ m
+    ih =>
+    obtain
+      ⟨T, hcharts, hradii, hgerms, hcut, hregular, hseparated, Γ, hΓ, hother, hclass, hkeep⟩ := ih
+    obtain
+      ⟨U, ucharts, uradii, ugerms, ucut, uregular, useparated, Δ, hΔ, uother, uclass, ukeep⟩ :=
+      T.exists_repeatable_column_slide hf hm hdim horder q hq ha hcut hregular p i hp hseparated
+        αq Γ hΓ k hk
+    refine
+      ⟨U, fun z => (ucharts z).trans (hcharts z), fun z => (uradii z).trans (hradii z), ?_, ucut,
+        uregular, useparated, Δ, hΔ, fun j hji => (uother j hji).trans (hother j hji), ?_, ?_⟩
+    · intro z hz
+      filter_upwards [ugerms z hz, hgerms z hz] with y hy hy'
+      exact hy.trans hy'
+    · rw [uclass, hclass, add_assoc, ← add_zsmul]
+      have hcoef : (m : ℤ) * k + k = ((m + 1 : ℕ) : ℤ) * k := by
+        push_cast
+        ring
+      rw [hcoef]
+    · intro z hz
+      have hUT := ukeep z hz
+      have hTS := hkeep z hz
+      exact
+        ⟨fun x => (hUT.1 x).trans (hTS.1 x), fun x hx =>
+          (hUT.2.1 x ((hTS.1 x).mpr hx)).trans (hTS.2.1 x hx), fun v =>
+          (hUT.2.2 v).trans (hTS.2.2 v)⟩
+
+private theorem AdaptedWindows.exists_integer_column_slide {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PathConnectedSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (hdim : Module.finrank ℝ E = 6)
+    (horder :
+      ∀ p q : Smale.ManifoldMorse.criticalPoints E f,
+        f p < f q → MorseCancel.nativeMorseIndex E f p ≤ MorseCancel.nativeMorseIndex E f q)
+    (q : Smale.ManifoldMorse.criticalPoints E f) (hq : MorseCancel.nativeMorseIndex E f q = 3)
+    {a : ℝ} (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hal : a < S.toSurgeryWindows.lower q)
+    (hband :
+      ∀ y,
+        f y ∈ Set.Icc a (S.toSurgeryWindows.lower q) → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    {n : ℕ} (p : Fin n → Smale.ManifoldMorse.criticalPoints E f) (i : Fin n)
+    (hp : ∀ j, MorseCancel.nativeMorseIndex E f (p j) = 3)
+    (hhigh : ∀ j, S.toSurgeryWindows.upper q < f (p j))
+    (αq : C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (α : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (hfamily :
+      MorseCancel.IsNativeMiddleBasinFamily S hf ha (Fin.cases q p) (Fin.cases αq (fun j => α j)))
+    (k : ℤ) :
+    ∃ T : AdaptedWindows E f,
+      (∀ z, (T.data z).chart = (S.data z).chart) ∧
+        (∀ z, (T.data z).radius ≤ (S.data z).radius) ∧
+          (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ y in 𝓝 z, T.field y = S.field y) ∧
+            a < T.toSurgeryWindows.lower q ∧
+              (∀ y,
+                  f y ∈ Set.Icc a (T.toSurgeryWindows.lower q) →
+                    y ∉ Smale.ManifoldMorse.criticalPoints E f) ∧
+                (∀ j, T.toSurgeryWindows.upper q < f (p j)) ∧
+                  ∃ Γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }),
+                    MorseCancel.IsNativeMiddleBasinFamily T hf ha (Fin.cases q p)
+                        (Fin.cases αq (fun j => Γ j)) ∧
+                      (∀ j, j ≠ i → Γ j = α j) ∧
+                        (MorseCancel.middleSectionClass (Γ i) =
+                            MorseCancel.middleSectionClass (α i) +
+                              k • MorseCancel.middleSectionClass αq) ∧
+                          ∀ z : M,
+                            f z ≤ f q →
+                              (∀ x,
+                                  Filter.Tendsto (fun t => T.flow t x) Filter.atBot (𝓝 z) ↔
+                                    Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 z)) ∧
+                                (∀ x,
+                                    Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 z) →
+                                      Set.range (fun t => T.flow t x) =
+                                        Set.range (fun t => S.flow t x)) ∧
+                                  ∀ v,
+                                    Filter.Tendsto (fun t => T.flow t z) Filter.atTop (𝓝 v) ↔
+                                      Filter.Tendsto (fun t => S.flow t z) Filter.atTop (𝓝 v) := by
+  obtain ⟨m, rfl | rfl⟩ := Int.eq_nat_or_neg k
+  · simpa only [mul_one] using
+      S.exists_iterated_column_slide hf hm hdim horder q hq ha hal hband p i hp hhigh αq α hfamily
+        1 (Or.inl rfl) m
+  · simpa only [mul_neg_one] using
+      S.exists_iterated_column_slide hf hm hdim horder q hq ha hal hband p i hp hhigh αq α hfamily
+        (-1) (Or.inr rfl) m
+
+attribute [local irreducible] MorseCancel.canonicalMiddleMatrix in
+private theorem MorseCancel.nativeMiddleBasinFamily_reindex {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a : ℝ}
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f) {n m : ℕ}
+    (p : Fin n → Smale.ManifoldMorse.criticalPoints E f)
+    (γ : Fin n → (Smale.Hemisphere.Sphere 2) → { y : M // f y = a })
+    (hγ : IsNativeMiddleBasinFamily S hf ha p γ) (e : Fin m → Fin n) (he : Function.Injective e) :
+    IsNativeMiddleBasinFamily S hf ha (p ∘ e) (γ ∘ e) := by
+  obtain ⟨hs, hi, hd, hpair, hfull⟩ := hγ
+  exact
+    ⟨fun j => hs (e j), fun j => hi (e j), fun j => hd (e j), fun i j hij =>
+      hpair (fun h => hij (he h)), fun j => hfull (e j)⟩
+
+attribute [local irreducible] MorseCancel.canonicalMiddleMatrix in
+private theorem
+    MorseCancel.canonicalMiddleMatrix_single_class_addition {M : Type} [TopologicalSpace M]
+      {f : M → ℝ} {a : ℝ} {r n : ℕ}
+    (B : (Fin r → ℤ) ≃ₗ[ℤ] SingularMayerVietoris.SingularHomology { y : M // f y ≤ a } 2)
+    (α Γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a })) (q i : Fin n) (k : ℤ)
+    (hother : ∀ j, j ≠ i → Γ j = α j)
+    (hclass :
+      middleSectionClass (Γ i) = middleSectionClass (α i) + k • middleSectionClass (α q)) :
+    canonicalMiddleMatrix (M := M) (f := f) (a := a) (r := r) (n := n) B Γ =
+      canonicalMiddleMatrix (M := M) (f := f) (a := a) (r := r) (n := n) B α *
+        Matrix.transvection q i k := by
+  refine eq_mul_transvection_of_columns _ _ q i k ?_ ?_
+  · intro u
+    simp only [canonicalMiddleMatrix, classCoordinateMatrix]
+    rw [hclass, map_add, map_zsmul]
+    simp only [Pi.add_apply, Pi.smul_apply, smul_eq_mul]
+  · intro u j hji
+    simp only [canonicalMiddleMatrix, classCoordinateMatrix, hother j hji]
+
+attribute [local irreducible] MorseCancel.canonicalMiddleMatrix in
+private theorem MorseCancel.SurgeryWindows.regular_before_first_middle_pivot {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f)
+    (horder :
+      ∀ x y : Smale.ManifoldMorse.criticalPoints E f,
+        f x < f y → MorseCancel.nativeMorseIndex E f x ≤ MorseCancel.nativeMorseIndex E f y)
+    {a : ℝ}
+    (hcut :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E f,
+        MorseCancel.nativeMorseIndex E f z < 3 → f z < a)
+    {n : ℕ} (p : Fin n → Smale.ManifoldMorse.criticalPoints E f)
+    (hp : ∀ j, MorseCancel.nativeMorseIndex E f (p j) = 3)
+    (hcomplete :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E f,
+        MorseCancel.nativeMorseIndex E f z = 3 → ∃ j, p j = z)
+    (q : Fin n) (hfirst : ∀ j, j ≠ q → f (p q) < f (p j)) :
+    ∀ y, f y ∈ Set.Icc a (S.lower (p q)) → y ∉ Smale.ManifoldMorse.criticalPoints E f := by
+  intro y hy hcrit
+  let z : Smale.ManifoldMorse.criticalPoints E f := ⟨y, hcrit⟩
+  have hlt : f z < f (p q) := hy.2.trans_lt (S.lower_lt_value (p q))
+  have hle : MorseCancel.nativeMorseIndex E f z ≤ 3 := (horder z (p q) hlt).trans_eq (hp q)
+  have heq : MorseCancel.nativeMorseIndex E f z = 3 := by
+    apply Nat.le_antisymm hle
+    by_contra hnot
+    exact (hcut z (lt_of_not_ge hnot)).not_ge hy.1
+  obtain ⟨j, hj⟩ := hcomplete z heq
+  by_cases hjq : j = q
+  · exact (ne_of_lt hlt) (congrArg f (congrArg Subtype.val (hj.symm.trans (congrArg p hjq))))
+  · have hreverse : f (p q) < f z := by simpa only [hj] using hfirst j hjq
+    exact hlt.not_gt hreverse
+
+attribute [local irreducible] MorseCancel.canonicalMiddleMatrix in
+private theorem
+    MorseCancel.low_index_cut_of_preserved_other_values {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+       {f : M → ℝ} {g : M → ℝ} {a : ℝ}
+    (hcrit : Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f)
+    (hindices :
+      ∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+        nativeMorseIndex E g z = nativeMorseIndex E f z)
+    {n : ℕ} (p : Fin n → Smale.ManifoldMorse.criticalPoints E f)
+    (hp : ∀ j, nativeMorseIndex E f (p j) = 3)
+    (houtside : ∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, (∀ j, z ≠ (p j).val) → g z = f z)
+    (hcut : ∀ z : Smale.ManifoldMorse.criticalPoints E f, nativeMorseIndex E f z < 3 → f z < a) :
+    ∀ z : Smale.ManifoldMorse.criticalPoints E g, nativeMorseIndex E g z < 3 → g z < a := by
+  intro z hz
+  let zf : Smale.ManifoldMorse.criticalPoints E f := ⟨z.val, hcrit ▸ z.property⟩
+  have hidx : nativeMorseIndex E f zf < 3 := by
+    rw [← hindices z zf.property]
+    exact hz
+  have hother : ∀ j, z.val ≠ (p j).val := by
+    intro j hj
+    have heq : zf = p j := Subtype.ext hj
+    rw [heq, hp j] at hidx
+    exact (lt_irrefl _ hidx)
+  rw [houtside z zf.property hother]
+  exact hcut zf hidx
+
+attribute [local irreducible] MorseCancel.canonicalMiddleMatrix in
+private theorem AdaptedWindows.exists_labelled_integer_slide {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PathConnectedSpace M]
+    {f : M → ℝ} (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (hdim : Module.finrank ℝ E = 6)
+    (horder :
+      ∀ x y : Smale.ManifoldMorse.criticalPoints E f,
+        f x < f y → MorseCancel.nativeMorseIndex E f x ≤ MorseCancel.nativeMorseIndex E f y)
+    {a : ℝ} (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f) {r n : ℕ}
+    (p : Fin (n + 1) → Smale.ManifoldMorse.criticalPoints E f)
+    (hp : ∀ j, MorseCancel.nativeMorseIndex E f (p j) = 3)
+    (hlower : ∀ j, a < S.toSurgeryWindows.lower (p j))
+    (B : (Fin r → ℤ) ≃ₗ[ℤ] SingularMayerVietoris.SingularHomology { y : M // f y ≤ a } 2)
+    (γ : Fin (n + 1) → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (hγ : MorseCancel.IsNativeMiddleBasinFamily S hf ha p (fun j => γ j))
+    (hsurj : Function.Surjective (MorseCancel.canonicalMiddleMatrix B γ).mulVec)
+    (q i : Fin (n + 1)) (hqi : q ≠ i) (hfirst : ∀ j, j ≠ q → f (p q) < f (p j))
+    (hband :
+      ∀ y,
+        f y ∈ Set.Icc a (S.toSurgeryWindows.lower (p q)) →
+          y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (k : ℤ) :
+    ∃ T : AdaptedWindows E f,
+      (∀ z, (T.data z).chart = (S.data z).chart) ∧
+        (∀ z, (T.data z).radius ≤ (S.data z).radius) ∧
+          (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ y in 𝓝 z, T.field y = S.field y) ∧
+            (∀ j, a < T.toSurgeryWindows.lower (p j)) ∧
+              ∃ Γ : Fin (n + 1) → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }),
+                MorseCancel.IsNativeMiddleBasinFamily T hf ha p (fun j => Γ j) ∧
+                  (∀ j, j ≠ i → Γ j = γ j) ∧
+                    MorseCancel.middleSectionClass (Γ i) =
+                        MorseCancel.middleSectionClass (γ i) +
+                          k • MorseCancel.middleSectionClass (γ q) ∧
+                      MorseCancel.canonicalMiddleMatrix (M := M) (f := f) (a := a) (r := r) (n :=
+                            n + 1) B Γ =
+                          MorseCancel.canonicalMiddleMatrix (M := M) (f := f) (a := a) (r := r)
+                              (n := n + 1) B γ *
+                            Matrix.transvection q i k ∧
+                        Function.Surjective (MorseCancel.canonicalMiddleMatrix B Γ).mulVec ∧
+                          ∀ z : M,
+                            f z ≤ f (p q) →
+                              (∀ x,
+                                  Filter.Tendsto (fun t => T.flow t x) Filter.atBot (𝓝 z) ↔
+                                    Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 z)) ∧
+                                (∀ x,
+                                    Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 z) →
+                                      Set.range (fun t => T.flow t x) =
+                                        Set.range (fun t => S.flow t x)) ∧
+                                  ∀ v,
+                                    Filter.Tendsto (fun t => T.flow t z) Filter.atTop (𝓝 v) ↔
+                                      Filter.Tendsto (fun t => S.flow t z) Filter.atTop (𝓝 v) := by
+  classical
+  let e := Equiv.swap (0 : Fin (n + 1)) q
+  have he0 : e 0 = q := Equiv.swap_apply_left _ _
+  have heq : e q = 0 := Equiv.swap_apply_right _ _
+  have hee (j : Fin (n + 1)) : e (e j) = j := Equiv.swap_apply_self _ _ _
+  have hne : e i ≠ 0 := fun hi => hqi (e.injective (heq.trans hi.symm))
+  obtain ⟨l, hl⟩ := Fin.exists_succ_eq_of_ne_zero hne
+  have hel : e l.succ = i := by rw [hl, hee]
+  have hpcases : Fin.cases (p q) (fun j => p (e j.succ)) = p ∘ e := by
+    funext j
+    cases j using Fin.cases with
+    | zero => simp only [Fin.cases_zero, Function.comp_apply, he0]
+    | succ j => rfl
+  have hγcases : Fin.cases (γ q) (fun j => γ (e j.succ)) = γ ∘ e := by
+    funext j
+    cases j using Fin.cases with
+    | zero => simp only [Fin.cases_zero, Function.comp_apply, he0]
+    | succ j => rfl
+  have hfamily :
+    MorseCancel.IsNativeMiddleBasinFamily S hf ha (Fin.cases (p q) (fun j => p (e j.succ)))
+      (Fin.cases (fun x => γ q x) (fun j x => γ (e j.succ) x)) := by
+    have hmaps :
+      Fin.cases (fun x => γ q x) (fun j x => γ (e j.succ) x) = (fun j x => γ j x) ∘ e := by
+      funext j x
+      cases j using Fin.cases with
+      | zero => simp only [Fin.cases_zero, Function.comp_apply, he0]
+      | succ j => rfl
+    rw [hpcases, hmaps]
+    exact MorseCancel.nativeMiddleBasinFamily_reindex S hf ha p (fun j => γ j) hγ e e.injective
+  have hhigh (j : Fin n) : S.toSurgeryWindows.upper (p q) < f (p (e j.succ)) := by
+    have hjq : e j.succ ≠ q := by
+      intro hj
+      have hzero : j.succ = 0 := e.injective (hj.trans he0.symm)
+      exact Fin.succ_ne_zero j hzero
+    exact
+      (S.toSurgeryWindows.upper_lt_lower (p q) (p (e j.succ)) (hfirst _ hjq)).trans
+        (S.toSurgeryWindows.lower_lt_value _)
+  obtain ⟨T, hcharts, hradii, hgerms, -, -, -, Δ, hΔ, hother, hclass, hkeep⟩ :=
+    S.exists_integer_column_slide hf hm hdim horder (p q) (hp q) ha (hlower q) hband
+      (fun j => p (e j.succ)) l (fun j => hp (e j.succ)) hhigh (γ q) (fun j => γ (e j.succ))
+      hfamily k
+  let δ : Fin (n + 1) → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }) := Fin.cases (γ q) Δ
+  let Γ := δ ∘ e
+  have hΓ : MorseCancel.IsNativeMiddleBasinFamily T hf ha p (fun j => Γ j) := by
+    have hh :=
+      MorseCancel.nativeMiddleBasinFamily_reindex T hf ha
+        (Fin.cases (p q) (fun j => p (e j.succ))) (Fin.cases (fun x => γ q x) (fun j x => Δ j x))
+        hΔ e e.injective
+    have hlabels : (Fin.cases (p q) (fun j => p (e j.succ))) ∘ e = p := by
+      rw [hpcases]
+      funext j
+      exact congrArg p (hee j)
+    rw [hlabels] at hh
+    have hmaps : (Fin.cases (fun x => γ q x) (fun j x => Δ j x)) ∘ e = (fun j x => Γ j x) := by
+      funext j x
+      change
+        Fin.cases (motive := fun _ : Fin (n + 1) =>
+            (Smale.Hemisphere.Sphere 2) → { y : M // f y = a }) (fun x => γ q x)
+            (fun j x => Δ j x) (e j) x =
+          (Fin.cases (motive := fun _ : Fin (n + 1) =>
+              C((Smale.Hemisphere.Sphere 2), { y : M // f y = a })) (γ q) Δ (e j))
+            x
+      cases e j using Fin.cases <;> rfl
+    rw [hmaps] at hh
+    exact hh
+  have hΓother (j : Fin (n + 1)) (hji : j ≠ i) : Γ j = γ j := by
+    change Fin.cases (γ q) Δ (e j) = γ j
+    by_cases hjzero : e j = 0
+    · have hjq : j = q := e.injective (hjzero.trans heq.symm)
+      rw [hjzero, Fin.cases_zero, hjq]
+    · obtain ⟨v, hv⟩ := Fin.exists_succ_eq_of_ne_zero hjzero
+      have hvl : v ≠ l := by
+        intro hvl
+        apply hji
+        exact e.injective (hv.symm.trans ((congrArg Fin.succ hvl).trans hl))
+      rw [← hv, Fin.cases_succ, hother v hvl]
+      exact congrArg γ (by rw [hv, hee])
+  have hΓclass :
+    MorseCancel.middleSectionClass (Γ i) =
+      MorseCancel.middleSectionClass (γ i) + k • MorseCancel.middleSectionClass (γ q) := by
+    change MorseCancel.middleSectionClass (Fin.cases (γ q) Δ (e i)) = _
+    rw [← hl, Fin.cases_succ]
+    simpa only [hel] using hclass
+  have hmatrix :=
+    MorseCancel.canonicalMiddleMatrix_single_class_addition (f := f) (a := a) B γ Γ q i k hΓother
+      hΓclass
+  refine ⟨T, hcharts, hradii, hgerms, ?_, Γ, hΓ, hΓother, hΓclass, hmatrix, ?_, hkeep⟩
+  · intro j
+    exact
+      (hlower j).trans_le
+        (MorseCancel.lower_window_le_of_radius_le S.toSurgeryWindows T.toSurgeryWindows (p j)
+          (hradii _))
+  · rw [hmatrix]
+    exact MorseCancel.mul_transvection_surjective _ q i hqi k hsurj
+
+attribute [local irreducible] MorseCancel.canonicalMiddleMatrix in
+private theorem AdaptedWindows.exists_arbitrary_column_addition {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PathConnectedSpace M]
+    {f : M → ℝ} (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (hdim : Module.finrank ℝ E = 6)
+    (horder :
+      ∀ x y : Smale.ManifoldMorse.criticalPoints E f,
+        f x < f y → MorseCancel.nativeMorseIndex E f x ≤ MorseCancel.nativeMorseIndex E f y)
+    {a : ℝ} (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hcut :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E f,
+        MorseCancel.nativeMorseIndex E f z < 3 → f z < a)
+    {r n : ℕ} (p : Fin n → Smale.ManifoldMorse.criticalPoints E f)
+    (hp : ∀ j, MorseCancel.nativeMorseIndex E f (p j) = 3)
+    (hcomplete :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E f,
+        MorseCancel.nativeMorseIndex E f z = 3 → ∃ j, p j = z)
+    (hlower : ∀ j, a < S.toSurgeryWindows.lower (p j))
+    (B : (Fin r → ℤ) ≃ₗ[ℤ] SingularMayerVietoris.SingularHomology { y : M // f y ≤ a } 2)
+    (γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (hγ : MorseCancel.IsNativeMiddleBasinFamily S hf ha p (fun j => γ j))
+    (hsurj : Function.Surjective (MorseCancel.canonicalMiddleMatrix B γ).mulVec) (q i : Fin n)
+    (hqi : q ≠ i) (k : ℤ) :
+    ∃ g : M → ℝ,
+      ∃ hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g,
+        Smale.ManifoldMorse.IsMorse E g ∧
+          ∃ hcrit :
+            Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f,
+            (∀ x y : Smale.ManifoldMorse.criticalPoints E g,
+                g x < g y →
+                  MorseCancel.nativeMorseIndex E g x ≤ MorseCancel.nativeMorseIndex E g y) ∧
+              (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+                  MorseCancel.nativeMorseIndex E g z = MorseCancel.nativeMorseIndex E f z) ∧
+                (∀ d, MorseCancel.nativeMorseCount E g d = MorseCancel.nativeMorseCount E f d) ∧
+                  (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+                      (∀ j, z ≠ (p j).val) → g z = f z) ∧
+                    (∀ z : Smale.ManifoldMorse.criticalPoints E g,
+                        MorseCancel.nativeMorseIndex E g z < 3 → g z < a) ∧
+                      ∃ hsub : ∀ y, g y ≤ a ↔ f y ≤ a,
+                        ∃ hlevel : ∀ y, g y = a ↔ f y = a,
+                          ∃ hga : ∀ y, g y = a → y ∉ Smale.ManifoldMorse.criticalPoints E g,
+                            ∃ T : AdaptedWindows E g,
+                              (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+                                  ∀ᶠ y in 𝓝 z, T.field y = S.field y) ∧
+                                (∀ y, f y ≤ a → g =ᶠ[𝓝 y] f) ∧
+                                  let p' : Fin n → Smale.ManifoldMorse.criticalPoints E g :=
+                                    fun j => ⟨(p j).val, hcrit.symm ▸ (p j).property⟩
+                                  let B' := B.trans (MorseCancel.equalCutHomologyEquiv hsub)
+                                  (∀ j, MorseCancel.nativeMorseIndex E g (p' j) = 3) ∧
+                                    (∀ z : Smale.ManifoldMorse.criticalPoints E g,
+                                        MorseCancel.nativeMorseIndex E g z = 3 → ∃ j, p' j = z) ∧
+                                      (∀ j, a < T.toSurgeryWindows.lower (p' j)) ∧
+                                        ∃ Γ :
+                                          Fin n →
+                                            C((Smale.Hemisphere.Sphere 2), { y : M // g y = a }),
+                                          MorseCancel.IsNativeMiddleBasinFamily T hg hga p'
+                                              (fun j => Γ j) ∧
+                                            (∀ j,
+                                                j ≠ i →
+                                                  Γ j =
+                                                    MorseCancel.equalCutSection hlevel (γ j)) ∧
+                                              MorseCancel.canonicalMiddleMatrix (M := M) (f := g)
+                                                    (a := a) (r := r) (n := n) B' Γ =
+                                                  MorseCancel.canonicalMiddleMatrix (M := M) (f :=
+                                                      f) (a := a) (r := r) (n := n) B γ *
+                                                    Matrix.transvection q i k ∧
+                                                Function.Surjective
+                                                    (MorseCancel.canonicalMiddleMatrix B'
+                                                        Γ).mulVec ∧
+                                                  ∀ z : M,
+                                                    f z ≤ a →
+                                                      (∀ x,
+                                                          Filter.Tendsto (fun t => T.flow t x)
+                                                              Filter.atBot (𝓝 z) ↔
+                                                            Filter.Tendsto (fun t => S.flow t x)
+                                                              Filter.atBot (𝓝 z)) ∧
+                                                        (∀ x,
+                                                            Filter.Tendsto (fun t => S.flow t x)
+                                                                Filter.atBot (𝓝 z) →
+                                                              Set.range (fun t => T.flow t x) =
+                                                                Set.range (fun t => S.flow t x)) ∧
+                                                          ∀ v,
+                                                            Filter.Tendsto (fun t => T.flow t z)
+                                                                Filter.atTop (𝓝 v) ↔
+                                                              Filter.Tendsto (fun t => S.flow t z)
+                                                                Filter.atTop (𝓝 v) := by
+  cases n with
+  | zero => exact Fin.elim0 q
+  | succ
+    n =>
+    obtain
+      ⟨g, hg, hmg, hcrit, hgorder, hindices, hcounts, houtside, hfirst, hsub, hlevel, hga, T,
+        hfield, hflow, hgerm, hpg, hglower, hfamily, -, hmatrix, hgsurj⟩ :=
+      S.exists_first_middle_pivot hf hm ha horder p hp hcomplete hlower B γ hγ hsurj q
+    let pg : Fin (n + 1) → Smale.ManifoldMorse.criticalPoints E g := fun j =>
+      ⟨(p j).val, hcrit.symm ▸ (p j).property⟩
+    let Bg := B.trans (MorseCancel.equalCutHomologyEquiv hsub)
+    let γg := fun j => MorseCancel.equalCutSection hlevel (γ j)
+    have hgcut :=
+      MorseCancel.low_index_cut_of_preserved_other_values hcrit hindices p hp houtside hcut
+    have hgcomplete :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E g,
+        MorseCancel.nativeMorseIndex E g z = 3 → ∃ j, pg j = z := by
+      intro z hz
+      let zf : Smale.ManifoldMorse.criticalPoints E f := ⟨z.val, hcrit ▸ z.property⟩
+      have hzf : MorseCancel.nativeMorseIndex E f zf = 3 := (hindices z zf.property).symm.trans hz
+      obtain ⟨j, hj⟩ := hcomplete zf hzf
+      exact
+        ⟨j, Subtype.ext (congrArg (fun z : Smale.ManifoldMorse.criticalPoints E f => z.val) hj)⟩
+    have hband :=
+      MorseCancel.SurgeryWindows.regular_before_first_middle_pivot T.toSurgeryWindows hgorder
+        hgcut pg hpg hgcomplete q hfirst
+    obtain ⟨U, -, -, ugerms, ulower, Γ, hΓ, uother, -, umatrix, usurj, ukeep⟩ :=
+      T.exists_labelled_integer_slide hg hmg hdim hgorder hga pg hpg hglower Bg γg hfamily hgsurj
+        q i hqi hfirst hband k
+    refine
+      ⟨g, hg, hmg, hcrit, hgorder, hindices, hcounts, houtside, hgcut, hsub, hlevel, hga, U, ?_,
+        hgerm, hpg, hgcomplete, ulower, Γ, hΓ, uother, ?_, usurj, ?_⟩
+    · intro z hz
+      filter_upwards [ugerms z (hcrit.symm ▸ hz)] with y hy
+      exact hy.trans (congrFun hfield y)
+    · exact umatrix.trans (congrArg (fun A => A * Matrix.transvection q i k) hmatrix)
+    · intro z hz
+      have hheight : g z ≤ g (pg q) :=
+        ((hsub z).mpr hz).trans ((hglower q).trans (T.toSurgeryWindows.lower_lt_value (pg q))).le
+      simpa only [hflow] using ukeep z hheight
+
+private theorem
+    MorseCancel.equalCutSection_trans {M : Type} [TopologicalSpace M] {f g h : M → ℝ} {a : ℝ}
+    (hfg : ∀ y, g y = a ↔ f y = a) (hgh : ∀ y, h y = a ↔ g y = a)
+    (γ : C((Smale.Hemisphere.Sphere 2), { y : M // f y = a })) :
+    equalCutSection hgh (equalCutSection hfg γ) =
+      equalCutSection (fun y => (hgh y).trans (hfg y)) γ :=
+  rfl
+
+private theorem MorseCancel.equalCutHomologyEquiv_refl {M : Type} [TopologicalSpace M] {f : M → ℝ}
+    {a : ℝ} :
+    equalCutHomologyEquiv (f := f) (a := a) (fun _ => Iff.rfl) =
+      LinearEquiv.refl ℤ (SingularMayerVietoris.SingularHomology { y : M // f y ≤ a } 2) := by
+  apply LinearEquiv.ext
+  intro x
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (equalCutSublevelHomeomorph (f := f) (a := a) (fun _ => Iff.rfl)).toHomotopyEquiv.toFun 2
+        x =
+      x
+  have hmap :
+    (equalCutSublevelHomeomorph (f := f) (a := a) (fun _ => Iff.rfl)).toHomotopyEquiv.toFun =
+      ContinuousMap.id { y : M // f y ≤ a } :=
+    rfl
+  rw [hmap, PeriodTorusHigherHomology.singularHomologyMap_id]
+  rfl
+
+private theorem
+    MorseCancel.equalCutHomologyEquiv_trans {M : Type} [TopologicalSpace M] {f g h : M → ℝ}
+    {a : ℝ} (hfg : ∀ y, g y ≤ a ↔ f y ≤ a) (hgh : ∀ y, h y ≤ a ↔ g y ≤ a) :
+    (equalCutHomologyEquiv hfg).trans (equalCutHomologyEquiv hgh) =
+      equalCutHomologyEquiv (fun y => (hgh y).trans (hfg y)) := by
+  apply LinearEquiv.ext
+  intro x
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (equalCutSublevelHomeomorph hgh).toHomotopyEquiv.toFun 2
+        (SingularMayerVietoris.singularHomologyMap
+          (equalCutSublevelHomeomorph hfg).toHomotopyEquiv.toFun 2 x) =
+      SingularMayerVietoris.singularHomologyMap
+        (equalCutSublevelHomeomorph (fun y => (hgh y).trans (hfg y))).toHomotopyEquiv.toFun 2 x
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp]
+  rfl
+
+attribute [local irreducible] MorseCancel.canonicalMiddleMatrix in
+private theorem AdaptedWindows.exists_arbitrary_column_sequence {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PathConnectedSpace M]
+    {f : M → ℝ} (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (hdim : Module.finrank ℝ E = 6)
+    (horder :
+      ∀ x y : Smale.ManifoldMorse.criticalPoints E f,
+        f x < f y → MorseCancel.nativeMorseIndex E f x ≤ MorseCancel.nativeMorseIndex E f y)
+    {a : ℝ} (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hcut :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E f,
+        MorseCancel.nativeMorseIndex E f z < 3 → f z < a)
+    {r n : ℕ} (p : Fin n → Smale.ManifoldMorse.criticalPoints E f)
+    (hp : ∀ j, MorseCancel.nativeMorseIndex E f (p j) = 3)
+    (hcomplete :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E f,
+        MorseCancel.nativeMorseIndex E f z = 3 → ∃ j, p j = z)
+    (hlower : ∀ j, a < S.toSurgeryWindows.lower (p j))
+    (B : (Fin r → ℤ) ≃ₗ[ℤ] SingularMayerVietoris.SingularHomology { y : M // f y ≤ a } 2)
+    (γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (hγ : MorseCancel.IsNativeMiddleBasinFamily S hf ha p (fun j => γ j))
+    (hsurj : Function.Surjective (MorseCancel.canonicalMiddleMatrix B γ).mulVec)
+    (ops : List (Fin n × Fin n × ℤ)) (hvalid : ∀ op ∈ ops, op.1 ≠ op.2.1) :
+    ∃ g : M → ℝ,
+      ∃ hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g,
+        Smale.ManifoldMorse.IsMorse E g ∧
+          ∃ hcrit :
+            Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f,
+            (∀ x y : Smale.ManifoldMorse.criticalPoints E g,
+                g x < g y →
+                  MorseCancel.nativeMorseIndex E g x ≤ MorseCancel.nativeMorseIndex E g y) ∧
+              (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+                  MorseCancel.nativeMorseIndex E g z = MorseCancel.nativeMorseIndex E f z) ∧
+                (∀ d, MorseCancel.nativeMorseCount E g d = MorseCancel.nativeMorseCount E f d) ∧
+                  (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+                      (∀ j, z ≠ (p j).val) → g z = f z) ∧
+                    (∀ z : Smale.ManifoldMorse.criticalPoints E g,
+                        MorseCancel.nativeMorseIndex E g z < 3 → g z < a) ∧
+                      ∃ hsub : ∀ y, g y ≤ a ↔ f y ≤ a,
+                        ∃ hlevel : ∀ y, g y = a ↔ f y = a,
+                          ∃ hga : ∀ y, g y = a → y ∉ Smale.ManifoldMorse.criticalPoints E g,
+                            ∃ T : AdaptedWindows E g,
+                              (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+                                  ∀ᶠ y in 𝓝 z, T.field y = S.field y) ∧
+                                (∀ y, f y ≤ a → g =ᶠ[𝓝 y] f) ∧
+                                  let p' : Fin n → Smale.ManifoldMorse.criticalPoints E g :=
+                                    fun j => ⟨(p j).val, hcrit.symm ▸ (p j).property⟩
+                                  let B' := B.trans (MorseCancel.equalCutHomologyEquiv hsub)
+                                  (∀ j, MorseCancel.nativeMorseIndex E g (p' j) = 3) ∧
+                                    (∀ z : Smale.ManifoldMorse.criticalPoints E g,
+                                        MorseCancel.nativeMorseIndex E g z = 3 → ∃ j, p' j = z) ∧
+                                      (∀ j, a < T.toSurgeryWindows.lower (p' j)) ∧
+                                        ∃ Γ :
+                                          Fin n →
+                                            C((Smale.Hemisphere.Sphere 2), { y : M // g y = a }),
+                                          MorseCancel.IsNativeMiddleBasinFamily T hg hga p'
+                                              (fun j => Γ j) ∧
+                                            (∀ j,
+                                                (∀ op ∈ ops, op.2.1 ≠ j) →
+                                                  Γ j =
+                                                    MorseCancel.equalCutSection hlevel (γ j)) ∧
+                                              MorseCancel.canonicalMiddleMatrix (M := M) (f := g)
+                                                    (a := a) (r := r) (n := n) B' Γ =
+                                                  MorseCancel.canonicalMiddleMatrix (M := M) (f :=
+                                                      f) (a := a) (r := r) (n := n) B γ *
+                                                    (ops.map
+                                                        (fun op =>
+                                                          Matrix.transvection op.1 op.2.1
+                                                            op.2.2)).prod ∧
+                                                Function.Surjective
+                                                    (MorseCancel.canonicalMiddleMatrix B'
+                                                        Γ).mulVec ∧
+                                                  ∀ z : M,
+                                                    f z ≤ a →
+                                                      (∀ x,
+                                                          Filter.Tendsto (fun t => T.flow t x)
+                                                              Filter.atBot (𝓝 z) ↔
+                                                            Filter.Tendsto (fun t => S.flow t x)
+                                                              Filter.atBot (𝓝 z)) ∧
+                                                        (∀ x,
+                                                            Filter.Tendsto (fun t => S.flow t x)
+                                                                Filter.atBot (𝓝 z) →
+                                                              Set.range (fun t => T.flow t x) =
+                                                                Set.range (fun t => S.flow t x)) ∧
+                                                          ∀ v,
+                                                            Filter.Tendsto (fun t => T.flow t z)
+                                                                Filter.atTop (𝓝 v) ↔
+                                                              Filter.Tendsto (fun t => S.flow t z)
+                                                                Filter.atTop (𝓝 v) := by
+  revert hvalid
+  induction ops using List.reverseRecOn with
+  | nil =>
+    intro hvalid
+    have hB :
+      B.trans (MorseCancel.equalCutHomologyEquiv (f := f) (a := a) (fun _ => Iff.rfl)) = B := by
+      rw [MorseCancel.equalCutHomologyEquiv_refl, LinearEquiv.trans_refl]
+    refine
+      ⟨f, hf, hm, rfl, horder, fun _ _ => rfl, fun _ => rfl, fun _ _ _ => rfl, hcut, fun _ =>
+        Iff.rfl, fun _ => Iff.rfl, ha, S, ?_, fun _ _ => Filter.EventuallyEq.rfl, hp, hcomplete,
+        hlower, γ, hγ, fun _ _ => rfl, ?_, ?_, ?_⟩
+    · intro z hz
+      exact Filter.Eventually.of_forall (fun _ => rfl)
+    · rw [hB]
+      simp only [List.map_nil, List.prod_nil, Matrix.mul_one]
+    · rw [hB]
+      exact hsurj
+    · intro z hz
+      exact ⟨fun _ => Iff.rfl, fun _ _ => rfl, fun _ => Iff.rfl⟩
+  | append_singleton ops op ih =>
+    intro hvalid
+    have hprev : ∀ e ∈ ops, e.1 ≠ e.2.1 := fun e he => hvalid e (List.mem_append.mpr (Or.inl he))
+    have hop : op.1 ≠ op.2.1 :=
+      hvalid op (List.mem_append.mpr (Or.inr (List.mem_singleton_self op)))
+    obtain
+      ⟨g, hg, hmg, hcrit, hgorder, hindices, hcounts, houtside, hgcut, hsub, hlevel, hga, T,
+        hgerms, hfgerms, hpg, hgcomplete, hglower, Γ, hΓ, hother, hmatrix, hgsurj, hkeep⟩ :=
+      ih hprev
+    let pg : Fin n → Smale.ManifoldMorse.criticalPoints E g := fun j =>
+      ⟨(p j).val, hcrit.symm ▸ (p j).property⟩
+    let Bg := B.trans (MorseCancel.equalCutHomologyEquiv hsub)
+    obtain
+      ⟨u, hu, hmu, hcu, huorder, huindices, hucounts, huoutside, hucut, husub, hulevel, hua, U,
+        hugerms, hufgerms, hpu, hucomplete, hulower, Δ, hΔ, huother, humatrix, husurj, hukeep⟩ :=
+      T.exists_arbitrary_column_addition hg hmg hdim hgorder hga hgcut pg hpg hgcomplete hglower
+        Bg Γ hΓ hgsurj op.1 op.2.1 hop op.2.2
+    let hsub' : ∀ y, u y ≤ a ↔ f y ≤ a := fun y => (husub y).trans (hsub y)
+    let hlevel' : ∀ y, u y = a ↔ f y = a := fun y => (hulevel y).trans (hlevel y)
+    have hB :
+      Bg.trans (MorseCancel.equalCutHomologyEquiv husub) =
+        B.trans (MorseCancel.equalCutHomologyEquiv hsub') := by
+      change
+        (B.trans (MorseCancel.equalCutHomologyEquiv hsub)).trans
+            (MorseCancel.equalCutHomologyEquiv husub) =
+          _
+      rw [LinearEquiv.trans_assoc, MorseCancel.equalCutHomologyEquiv_trans]
+    refine
+      ⟨u, hu, hmu, hcu.trans hcrit, huorder,
+        (fun z hz => (huindices z (hcrit.symm ▸ hz)).trans (hindices z hz)),
+        (fun d => (hucounts d).trans (hcounts d)),
+        (fun z hz hzo => (huoutside z (hcrit.symm ▸ hz) hzo).trans (houtside z hz hzo)), hucut,
+        hsub', hlevel', hua, U, ?_, ?_, hpu, hucomplete, hulower, Δ, hΔ, ?_, ?_, ?_, ?_⟩
+    · intro z hz
+      filter_upwards [hugerms z (hcrit.symm ▸ hz), hgerms z hz] with y hy hy'
+      exact hy.trans hy'
+    · intro y hy
+      exact (hufgerms y ((hsub y).mpr hy)).trans (hfgerms y hy)
+    · intro j hj
+      have hlast : j ≠ op.2.1 := fun heq =>
+        hj op (List.mem_append.mpr (Or.inr (List.mem_singleton_self op))) heq.symm
+      have hbefore : ∀ e ∈ ops, e.2.1 ≠ j := fun e he => hj e (List.mem_append.mpr (Or.inl he))
+      rw [huother j hlast, hother j hbefore]
+      exact MorseCancel.equalCutSection_trans hlevel hulevel (γ j)
+    · rw [← hB, humatrix, hmatrix, Matrix.mul_assoc]
+      simp only [List.map_append, List.map_singleton, List.prod_append, List.prod_singleton]
+    · rw [← hB]
+      exact husurj
+    · intro z hz
+      have hUT := hukeep z ((hsub z).mpr hz)
+      have hTS := hkeep z hz
+      exact
+        ⟨fun x => (hUT.1 x).trans (hTS.1 x), fun x hx =>
+          (hUT.2.1 x ((hTS.1 x).mpr hx)).trans (hTS.2.1 x hx), fun v =>
+          (hUT.2.2 v).trans (hTS.2.2 v)⟩
+
+private theorem
+    MorseCancel.mul_transvection_list_surjective {r n : ℕ} (A : Matrix (Fin r) (Fin n) ℤ)
+    (hA : Function.Surjective A.mulVec) (ops : List (Fin n × Fin n × ℤ))
+    (hvalid : ∀ op ∈ ops, op.1 ≠ op.2.1) :
+    Function.Surjective
+      (A * (ops.map (fun op => Matrix.transvection op.1 op.2.1 op.2.2)).prod).mulVec := by
+  revert hvalid
+  induction ops using List.reverseRecOn with
+  | nil =>
+    intro hvalid
+    simpa only [List.map_nil, List.prod_nil, Matrix.mul_one] using hA
+  | append_singleton ops op ih =>
+    intro hvalid
+    have hprev : ∀ e ∈ ops, e.1 ≠ e.2.1 := fun e he => hvalid e (List.mem_append.mpr (Or.inl he))
+    have hop := hvalid op (List.mem_append.mpr (Or.inr (List.mem_singleton_self op)))
+    simpa only [List.map_append, List.map_singleton, List.prod_append, List.prod_singleton,
+      ← Matrix.mul_assoc] using mul_transvection_surjective _ op.1 op.2.1 hop op.2.2 (ih hprev)
+
+private theorem MorseCancel.primitive_row_has_unit_after_column_additions {n : ℕ}
+    (A : Matrix (Fin 1) (Fin n) ℤ) (hA : Function.Surjective A.mulVec) :
+    ∃ ops : List (Fin n × Fin n × ℤ),
+      (∀ op ∈ ops, op.1 ≠ op.2.1) ∧
+        ∃ i : Fin n,
+          (A * (ops.map (fun op => Matrix.transvection op.1 op.2.1 op.2.2)).prod) 0 i = 1 ∨
+            (A * (ops.map (fun op => Matrix.transvection op.1 op.2.1 op.2.2)).prod) 0 i = -1 := by
+  classical
+  have hnonzero : ∃ j, A 0 j ≠ 0 := by
+    by_contra hnot
+    push Not at hnot
+    obtain ⟨x, hx⟩ := hA 1
+    have hh := congrFun hx 0
+    change ∑ j, A 0 j * x j = 1 at hh
+    simp only [hnot, MulZeroClass.zero_mul, Finset.sum_const_zero] at hh
+    exact zero_ne_one hh
+  let P : ℕ → Prop := fun m =>
+    ∃ ops : List (Fin n × Fin n × ℤ),
+      (∀ op ∈ ops, op.1 ≠ op.2.1) ∧
+        ∃ i : Fin n,
+          (A * (ops.map (fun op => Matrix.transvection op.1 op.2.1 op.2.2)).prod) 0 i ≠ 0 ∧
+            ((A * (ops.map (fun op => Matrix.transvection op.1 op.2.1 op.2.2)).prod) 0 i).natAbs =
+              m
+  obtain ⟨j₀, hj₀⟩ := hnonzero
+  have hex : ∃ m, P m := by
+    refine ⟨(A 0 j₀).natAbs, [], ?_, j₀, ?_, ?_⟩
+    · intro op hop
+      simp only [List.not_mem_nil] at hop
+    · simpa only [List.map_nil, List.prod_nil, Matrix.mul_one] using hj₀
+    · simp only [List.map_nil, List.prod_nil, Matrix.mul_one]
+  obtain ⟨ops, hvalid, i, hi, hrank⟩ := Nat.find_spec hex
+  let C := A * (ops.map (fun op => Matrix.transvection op.1 op.2.1 op.2.2)).prod
+  have hC : Function.Surjective C.mulVec := mul_transvection_list_surjective A hA ops hvalid
+  have hdiv (j : Fin n) : C 0 i ∣ C 0 j := by
+    by_cases hij : i = j
+    · subst j
+      exact dvd_refl _
+    apply Int.dvd_of_emod_eq_zero
+    by_contra hrem
+    let op : Fin n × Fin n × ℤ := (i, j, -(C 0 j / C 0 i))
+    let ops' := ops ++ [op]
+    have hvalid' : ∀ e ∈ ops', e.1 ≠ e.2.1 := by
+      intro e he
+      rcases List.mem_append.mp he with he | he
+      · exact hvalid e he
+      · have heq : e = op := List.mem_singleton.mp he
+        subst e
+        exact hij
+    have hnew :
+      A * (ops'.map (fun e => Matrix.transvection e.1 e.2.1 e.2.2)).prod =
+        C * Matrix.transvection i j (-(C 0 j / C 0 i)) := by
+      simp only [ops', List.map_append, List.map_singleton, List.prod_append, List.prod_singleton,
+        ← Matrix.mul_assoc]
+      rfl
+    have hentry :
+      (A * (ops'.map (fun e => Matrix.transvection e.1 e.2.1 e.2.2)).prod) 0 j = C 0 j % C 0 i := by
+      rw [hnew, Matrix.mul_transvection_apply_same, Int.emod_def]
+      ring
+    have hsmall : (C 0 j % C 0 i).natAbs < (C 0 i).natAbs := by
+      have hh :=
+        Int.natAbs_lt_natAbs_of_nonneg_of_lt (Int.emod_nonneg (C 0 j) hi)
+          (Int.emod_lt_abs (C 0 j) hi)
+      simpa only [Int.natAbs_abs] using hh
+    have hminimal :=
+      Nat.find_min' hex
+        (show P (C 0 j % C 0 i).natAbs from
+          ⟨ops', hvalid', j, (by rw [hentry]; exact hrem), congrArg Int.natAbs hentry⟩)
+    rw [← hrank] at hminimal
+    exact (not_le_of_gt hsmall) hminimal
+  obtain ⟨x, hx⟩ := hC 1
+  have hsum := congrFun hx 0
+  change ∑ j, C 0 j * x j = 1 at hsum
+  have hdvd : C 0 i ∣ 1 := by
+    rw [← hsum]
+    exact Finset.dvd_sum (fun j _ => dvd_mul_of_dvd_left (hdiv j) (x j))
+  obtain ⟨v, hv⟩ := hdvd
+  exact ⟨ops, hvalid, i, Int.eq_one_or_neg_one_of_mul_eq_one hv.symm⟩
+
+private theorem MorseCancel.functional_class_row_surjective {H : Type} [AddCommGroup H] [Module ℤ H]
+    {r n : ℕ} (B : (Fin r → ℤ) ≃ₗ[ℤ] H) (v : Fin n → H)
+    (hA : Function.Surjective (classCoordinateMatrix B v).mulVec) (L : H →ₗ[ℤ] ℤ)
+    (hL : Function.Surjective L) :
+    Function.Surjective (Matrix.of (fun (_ : Fin 1) (j : Fin n) => L (v j))).mulVec := by
+  intro y
+  obtain ⟨h, hh⟩ := hL (y 0)
+  obtain ⟨x, hx⟩ := hA (B.symm h)
+  have hsum : (∑ j, x j • v j) = h := by
+    rw [← classCoordinateMatrix_mulVec B v x, hx, LinearEquiv.apply_symm_apply]
+  refine ⟨x, ?_⟩
+  funext i
+  have hi : i = 0 := Subsingleton.elim _ _
+  subst i
+  have heq := congrArg L hsum
+  rw [map_sum] at heq
+  simp only [map_zsmul, smul_eq_mul] at heq
+  change ∑ j, L (v j) * x j = y 0
+  rw [← hh, ← heq]
+  apply Finset.sum_congr rfl
+  intro j hj
+  exact mul_comm _ _
+
+private theorem MorseCancel.transported_classes_of_matrix_product {H K : Type} [AddCommGroup H]
+    [Module ℤ H] [AddCommGroup K] [Module ℤ K] {r n : ℕ} (B : (Fin r → ℤ) ≃ₗ[ℤ] H) (e : H ≃ₗ[ℤ] K)
+    (v : Fin n → H) (w : Fin n → K) (P : Matrix (Fin n) (Fin n) ℤ)
+    (hmatrix : classCoordinateMatrix (B.trans e) w = classCoordinateMatrix B v * P) (j : Fin n) :
+    e.symm (w j) = ∑ i, P i j • v i := by
+  have hvec : (classCoordinateMatrix B v).mulVec (fun i => P i j) = (B.trans e).symm (w j) := by
+    funext i
+    exact (congrFun (congrFun hmatrix i) j).symm
+  calc
+    e.symm (w j) = B ((classCoordinateMatrix B v).mulVec (fun i => P i j)) := by
+      rw [hvec]
+      exact (B.apply_symm_apply (e.symm (w j))).symm
+    _ = _ := classCoordinateMatrix_mulVec B v _
+
+private theorem
+    MorseCancel.functional_rows_of_matrix_product {H K : Type} [AddCommGroup H] [Module ℤ H]
+    [AddCommGroup K] [Module ℤ K] {r n : ℕ} (B : (Fin r → ℤ) ≃ₗ[ℤ] H) (e : H ≃ₗ[ℤ] K)
+    (v : Fin n → H) (w : Fin n → K) (P : Matrix (Fin n) (Fin n) ℤ)
+    (hmatrix : classCoordinateMatrix (B.trans e) w = classCoordinateMatrix B v * P)
+    (L : H →ₗ[ℤ] ℤ) :
+    Matrix.of (fun (_ : Fin 1) (j : Fin n) => L (e.symm (w j))) =
+      Matrix.of (fun (_ : Fin 1) (j : Fin n) => L (v j)) * P := by
+  funext u j
+  change L (e.symm (w j)) = ∑ i, L (v i) * P i j
+  rw [transported_classes_of_matrix_product B e v w P hmatrix j, map_sum]
+  simp only [map_zsmul, smul_eq_mul]
+  apply Finset.sum_congr rfl
+  intro i hi
+  exact mul_comm _ _
+
+attribute [local irreducible] MorseCancel.canonicalMiddleMatrix in
+private theorem AdaptedWindows.exists_primitive_functional_unit {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PathConnectedSpace M]
+    {f : M → ℝ} (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (hdim : Module.finrank ℝ E = 6)
+    (horder :
+      ∀ x y : Smale.ManifoldMorse.criticalPoints E f,
+        f x < f y → MorseCancel.nativeMorseIndex E f x ≤ MorseCancel.nativeMorseIndex E f y)
+    {a : ℝ} (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hcut :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E f,
+        MorseCancel.nativeMorseIndex E f z < 3 → f z < a)
+    {r n : ℕ} (p : Fin n → Smale.ManifoldMorse.criticalPoints E f)
+    (hp : ∀ j, MorseCancel.nativeMorseIndex E f (p j) = 3)
+    (hcomplete :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E f,
+        MorseCancel.nativeMorseIndex E f z = 3 → ∃ j, p j = z)
+    (hlower : ∀ j, a < S.toSurgeryWindows.lower (p j))
+    (B : (Fin r → ℤ) ≃ₗ[ℤ] SingularMayerVietoris.SingularHomology { y : M // f y ≤ a } 2)
+    (γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (hγ : MorseCancel.IsNativeMiddleBasinFamily S hf ha p (fun j => γ j))
+    (hsurj : Function.Surjective (MorseCancel.canonicalMiddleMatrix B γ).mulVec)
+    (L : SingularMayerVietoris.SingularHomology { y : M // f y ≤ a } 2 →ₗ[ℤ] ℤ)
+    (hL : Function.Surjective L) :
+    ∃ ops : List (Fin n × Fin n × ℤ),
+      (∀ op ∈ ops, op.1 ≠ op.2.1) ∧
+        ∃ g : M → ℝ,
+          ∃ hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g,
+            Smale.ManifoldMorse.IsMorse E g ∧
+              ∃ hcrit :
+                Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f,
+                (∀ x y : Smale.ManifoldMorse.criticalPoints E g,
+                    g x < g y →
+                      MorseCancel.nativeMorseIndex E g x ≤ MorseCancel.nativeMorseIndex E g y) ∧
+                  (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+                      MorseCancel.nativeMorseIndex E g z = MorseCancel.nativeMorseIndex E f z) ∧
+                    (∀ d,
+                        MorseCancel.nativeMorseCount E g d = MorseCancel.nativeMorseCount E f d) ∧
+                      (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+                          (∀ j, z ≠ (p j).val) → g z = f z) ∧
+                        (∀ z : Smale.ManifoldMorse.criticalPoints E g,
+                            MorseCancel.nativeMorseIndex E g z < 3 → g z < a) ∧
+                          ∃ hsub : ∀ y, g y ≤ a ↔ f y ≤ a,
+                            ∃ hlevel : ∀ y, g y = a ↔ f y = a,
+                              ∃ hga : ∀ y, g y = a → y ∉ Smale.ManifoldMorse.criticalPoints E g,
+                                ∃ T : AdaptedWindows E g,
+                                  (∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+                                      ∀ᶠ y in 𝓝 z, T.field y = S.field y) ∧
+                                    (∀ y, f y ≤ a → g =ᶠ[𝓝 y] f) ∧
+                                      let p' : Fin n → Smale.ManifoldMorse.criticalPoints E g :=
+                                        fun j => ⟨(p j).val, hcrit.symm ▸ (p j).property⟩
+                                      let B' := B.trans (MorseCancel.equalCutHomologyEquiv hsub)
+                                      (∀ j, MorseCancel.nativeMorseIndex E g (p' j) = 3) ∧
+                                        (∀ z : Smale.ManifoldMorse.criticalPoints E g,
+                                            MorseCancel.nativeMorseIndex E g z = 3 →
+                                              ∃ j, p' j = z) ∧
+                                          (∀ j, a < T.toSurgeryWindows.lower (p' j)) ∧
+                                            ∃ Γ :
+                                              Fin n →
+                                                C((Smale.Hemisphere.Sphere 2),
+                                                  { y : M // g y = a }),
+                                              MorseCancel.IsNativeMiddleBasinFamily T hg hga p'
+                                                  (fun j => Γ j) ∧
+                                                (∀ j,
+                                                    (∀ op ∈ ops, op.2.1 ≠ j) →
+                                                      Γ j =
+                                                        MorseCancel.equalCutSection hlevel
+                                                          (γ j)) ∧
+                                                  MorseCancel.canonicalMiddleMatrix (M := M) (f :=
+                                                        g) (a := a) (r := r) (n := n) B' Γ =
+                                                      MorseCancel.canonicalMiddleMatrix (M := M)
+                                                          (f := f) (a := a) (r := r) (n := n) B
+                                                          γ *
+                                                        (ops.map
+                                                            (fun op =>
+                                                              Matrix.transvection op.1 op.2.1
+                                                                op.2.2)).prod ∧
+                                                    Function.Surjective
+                                                        (MorseCancel.canonicalMiddleMatrix B'
+                                                            Γ).mulVec ∧
+                                                      (∃ i : Fin n,
+                                                          L
+                                                                ((MorseCancel.equalCutHomologyEquiv
+                                                                      hsub).symm
+                                                                  (MorseCancel.middleSectionClass
+                                                                    (Γ i))) =
+                                                              1 ∨
+                                                            L
+                                                                ((MorseCancel.equalCutHomologyEquiv
+                                                                      hsub).symm
+                                                                  (MorseCancel.middleSectionClass
+                                                                    (Γ i))) =
+                                                              -1) ∧
+                                                        ∀ z : M,
+                                                          f z ≤ a →
+                                                            (∀ x,
+                                                                Filter.Tendsto
+                                                                    (fun t => T.flow t x)
+                                                                    Filter.atBot (𝓝 z) ↔
+                                                                  Filter.Tendsto
+                                                                    (fun t => S.flow t x)
+                                                                    Filter.atBot (𝓝 z)) ∧
+                                                              (∀ x,
+                                                                  Filter.Tendsto
+                                                                      (fun t => S.flow t x)
+                                                                      Filter.atBot (𝓝 z) →
+                                                                    Set.range
+                                                                        (fun t => T.flow t x) =
+                                                                      Set.range
+                                                                        (fun t => S.flow t x)) ∧
+                                                                ∀ v,
+                                                                  Filter.Tendsto
+                                                                      (fun t => T.flow t z)
+                                                                      Filter.atTop (𝓝 v) ↔
+                                                                    Filter.Tendsto
+                                                                      (fun t => S.flow t z)
+                                                                      Filter.atTop (𝓝 v) := by
+  let A : Matrix (Fin 1) (Fin n) ℤ := fun _ j => L (MorseCancel.middleSectionClass (γ j))
+  have hsurj' :
+    Function.Surjective
+      (MorseCancel.classCoordinateMatrix B
+          (fun j => MorseCancel.middleSectionClass (γ j))).mulVec := by
+    simpa only [MorseCancel.canonicalMiddleMatrix] using hsurj
+  have hA : Function.Surjective A.mulVec :=
+    MorseCancel.functional_class_row_surjective B (fun j => MorseCancel.middleSectionClass (γ j))
+      hsurj' L hL
+  obtain ⟨ops, hvalid, i, hi⟩ := MorseCancel.primitive_row_has_unit_after_column_additions A hA
+  obtain
+    ⟨g, hg, hmg, hcrit, hgorder, hindices, hcounts, houtside, hgcut, hsub, hlevel, hga, T, hgerms,
+      hfgerms, hpg, hgcomplete, hglower, Γ, hΓ, hother, hmatrix, hgsurj, hkeep⟩ :=
+    S.exists_arbitrary_column_sequence hf hm hdim horder ha hcut p hp hcomplete hlower B γ hγ
+      hsurj ops hvalid
+  have hcoord :
+    MorseCancel.classCoordinateMatrix (B.trans (MorseCancel.equalCutHomologyEquiv hsub))
+        (fun j => MorseCancel.middleSectionClass (Γ j)) =
+      MorseCancel.classCoordinateMatrix B (fun j => MorseCancel.middleSectionClass (γ j)) *
+        (ops.map (fun op => Matrix.transvection op.1 op.2.1 op.2.2)).prod := by
+    simpa only [MorseCancel.canonicalMiddleMatrix] using hmatrix
+  have hrows :=
+    MorseCancel.functional_rows_of_matrix_product B (MorseCancel.equalCutHomologyEquiv hsub)
+      (fun j => MorseCancel.middleSectionClass (γ j))
+      (fun j => MorseCancel.middleSectionClass (Γ j)) _ hcoord L
+  have hentry := congrFun (congrFun hrows 0) i
+  refine
+    ⟨ops, hvalid, g, hg, hmg, hcrit, hgorder, hindices, hcounts, houtside, hgcut, hsub, hlevel,
+      hga, T, hgerms, hfgerms, hpg, hgcomplete, hglower, Γ, hΓ, hother, hmatrix, hgsurj, ⟨i, ?_⟩,
+      hkeep⟩
+  exact hi.elim (fun h => Or.inl (hentry.trans h)) (fun h => Or.inr (hentry.trans h))
+
+attribute [local irreducible] MorseCancel.canonicalMiddleMatrix in
+private def
+    MorseCancel.regularCutHomologyEquiv {E M : Type} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [T2Space M] [CompactSpace M] {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ}
+    (hab : a ≤ b) (hband : ∀ y, f y ∈ Set.Icc a b → y ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    SingularMayerVietoris.SingularHomology { y : M // f y ≤ a } 2 ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology { y : M // f y ≤ b } 2 :=
+  LinearEquiv.ofBijective (SingularMayerVietoris.singularHomologyMap (sublevelMap f hab) 2)
+    (regular_sublevel_inclusion_bijective hf hab hband 2)
+
+attribute [local irreducible] MorseCancel.canonicalMiddleMatrix in
+private theorem AdaptedWindows.exists_lower_cut_geometric_matrix {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ} (hba : b < a)
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hb : ∀ y, f y = b → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hband : ∀ y, f y ∈ Set.Icc b a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (za : { y : M // f y = a }) {r n : ℕ} (p : Fin n → Smale.ManifoldMorse.criticalPoints E f)
+    (hp : ∀ j, a < f (p j))
+    (B : (Fin r → ℤ) ≃ₗ[ℤ] SingularMayerVietoris.SingularHomology { y : M // f y ≤ a } 2)
+    (γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }))
+    (hγ : MorseCancel.IsNativeMiddleBasinFamily S hf ha p (fun j => γ j))
+    (hsurj : Function.Surjective (MorseCancel.canonicalMiddleMatrix B γ).mulVec) :
+    ∃ β : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = b }),
+      MorseCancel.IsNativeMiddleBasinFamily S hf hb p (fun j => β j) ∧
+        (∀ j x, ∃ t : ℝ, S.flow t (γ j x).val = (β j x).val) ∧
+          (∀ j,
+              MorseCancel.regularCutHomologyEquiv hf hba.le hband
+                  (MorseCancel.middleSectionClass (β j)) =
+                MorseCancel.middleSectionClass (γ j)) ∧
+            let B' := B.trans (MorseCancel.regularCutHomologyEquiv hf hba.le hband).symm
+            MorseCancel.canonicalMiddleMatrix B' β = MorseCancel.canonicalMiddleMatrix B γ ∧
+              Function.Surjective (MorseCancel.canonicalMiddleMatrix B' β).mulVec := by
+  let _ := Smale.RegularLevel.chartedSpace hf hb
+  obtain ⟨β₀, hβ, horbit⟩ :=
+    S.exists_regular_band_middle_basin_family hf hba ha hb (fun y hy h => hband y h hy) za p hp
+      (fun j => γ j) hγ
+  let β : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = b }) := fun j =>
+    ⟨β₀ j, (hβ.1 j).continuous⟩
+  have hclass (j : Fin n) :
+    MorseCancel.regularCutHomologyEquiv hf hba.le hband (MorseCancel.middleSectionClass (β j)) =
+      MorseCancel.middleSectionClass (γ j) :=
+    S.section_class_of_flow_transport hf hba hb (γ j) (β j) (horbit j)
+  let B' := B.trans (MorseCancel.regularCutHomologyEquiv hf hba.le hband).symm
+  have hmatrix : MorseCancel.canonicalMiddleMatrix B' β = MorseCancel.canonicalMiddleMatrix B γ :=
+    by
+    funext i j
+    simp only [MorseCancel.canonicalMiddleMatrix, MorseCancel.classCoordinateMatrix]
+    change
+      B.symm
+          (MorseCancel.regularCutHomologyEquiv hf hba.le hband
+            (MorseCancel.middleSectionClass (β j)))
+          i =
+        B.symm (MorseCancel.middleSectionClass (γ j)) i
+    rw [hclass j]
+  refine ⟨β, hβ, horbit, hclass, hmatrix, ?_⟩
+  rw [hmatrix]
+  exact hsurj
+
+private theorem MorseCancel.native_middle_block_complete_and_cut {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] [Nonempty M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hdim : Module.finrank ℝ E = 6)
+    (horder :
+      ∀ x y : Smale.ManifoldMorse.criticalPoints E f,
+        f x < f y → nativeMorseIndex E f x ≤ nativeMorseIndex E f y)
+    (hzero : nativeMorseCount E f 0 = 1) (hone : nativeMorseCount E f 1 = 0) (r n : ℕ)
+    (hr : nativeMorseCount E f 2 = r) (hn : nativeMorseCount E f 3 = n)
+    (hrc : r + n < S.toSurgeryWindows.count) :
+    (∀ z : Smale.ManifoldMorse.criticalPoints E f,
+        nativeMorseIndex E f z = 3 → ∃ j, nativeMiddleBlockPoint S r n hrc j = z) ∧
+      (∀ z : Smale.ManifoldMorse.criticalPoints E f,
+        nativeMorseIndex E f z < 3 → f z < nativeMiddleBaseCut S r n hrc) := by
+  obtain ⟨r', n', htwo, hrc', hthree, -, hafter⟩ :=
+    exists_middle_index_blocks S.toSurgeryWindows hf hdim horder hzero hone
+  obtain ⟨hr', hn'⟩ :=
+    native_middle_block_counts S.toSurgeryWindows hf r' n' htwo hrc' hthree hafter
+  have hrr : r' = r := hr'.symm.trans hr
+  have hnn : n' = n := hn'.symm.trans hn
+  rw [hrr] at htwo
+  rw [hrr, hnn] at hthree hafter
+  let W := S.toSurgeryWindows
+  have hrcW : r + n < W.count := hrc
+  have hpos := W.count_pos hf
+  have hi0 (i : Fin W.count) (hi : i.val = 0) : nativeMorseIndex E f (W.point i) = 0 := by
+    have he : i = ⟨0, hpos⟩ := Fin.ext hi
+    rw [he]
+    exact
+      (nativeMorseIndex_eq_chart (S.data (W.first hpos)).chart).trans (W.first_index_zero hf hpos)
+  have hi2 (i : Fin W.count) (hi : 0 < i.val) (hir : i.val ≤ r) :
+    nativeMorseIndex E f (W.point i) = 2 :=
+    (nativeMorseIndex_eq_chart (S.data (W.point i)).chart).trans (htwo i hi hir)
+  have hi3 (i : Fin W.count) (hri : r < i.val) (hin : i.val ≤ r + n) :
+    nativeMorseIndex E f (W.point i) = 3 :=
+    (nativeMorseIndex_eq_chart (S.data (W.point i)).chart).trans (hthree i hri hin)
+  have hi4 (i : Fin W.count) (hin : r + n < i.val) : 4 ≤ nativeMorseIndex E f (W.point i) := by
+    rw [nativeMorseIndex_eq_chart (S.data (W.point i)).chart]
+    exact hafter i hin
+  constructor
+  · intro z hz
+    obtain ⟨i, rfl⟩ := W.point.surjective z
+    have hiz : i.val ≠ 0 := by
+      intro hi
+      have hh := hi0 i hi
+      omega
+    have hri : r < i.val := by
+      by_contra hnot
+      have hh := hi2 i (by omega) (le_of_not_gt hnot)
+      omega
+    have hin : i.val ≤ r + n := by
+      by_contra hnot
+      have hh := hi4 i (lt_of_not_ge hnot)
+      omega
+    refine ⟨⟨i.val - (r + 1), by omega⟩, ?_⟩
+    apply congrArg W.point
+    apply Fin.ext
+    change r + (i.val - (r + 1)) + 1 = i.val
+    omega
+  · intro z hz
+    obtain ⟨i, rfl⟩ := W.point.surjective z
+    have hir : i.val ≤ r := by
+      by_contra hnot
+      by_cases hin : i.val ≤ r + n
+      · have hh := hi3 i (lt_of_not_ge hnot) hin
+        omega
+      · have hh := hi4 i (lt_of_not_ge hin)
+        omega
+    exact
+      (W.point_strictMono.monotone (show i ≤ ⟨r, by omega⟩ from hir)).trans_lt
+        (W.value_lt_upper _)
+
+private theorem
+    Smale.HomologyTransport.integerEquiv_one_natAbs (e : ℤ ≃ₗ[ℤ] ℤ) : (e 1).natAbs = 1 := by
+  have h : e.symm 1 * e 1 = 1 := by
+    calc
+      e.symm 1 * e 1 = e (e.symm 1 • (1 : ℤ)) := by
+        rw [map_zsmul, zsmul_eq_mul]
+        simp
+      _ = 1 := by simp
+  exact Int.isUnit_iff_natAbs_eq.mp (IsUnit.of_mul_eq_one_right _ h)
+
+private theorem Smale.SpherePoint.sourceCountMark_topClass_natAbs (n : ℕ) {N : Type}
+    [NormedAddCommGroup N] [NormedSpace ℝ N] (j : (ℝ × N) ≃L[ℝ] EuclideanSpace ℝ (Fin (n + 3)))
+    (B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] N) :
+    (sourceCountMark n j B (SphereHomology.unitSphereTopClass (n + 1))).natAbs = 1 :=
+  Smale.HomologyTransport.integerEquiv_one_natAbs
+    ((SphereHomology.unitSphereHomologyTopEquiv (n + 1)).symm.trans (sourceCountMark n j B))
+
+private theorem
+    Smale.OnePointCover.overlapHomologyEquiv_symm_include {N : Type} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] (r : ℝ) (hr : 0 < r) (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (Smale.PuncturedRadial.Space N) k) :
+    (overlapHomologyEquiv r hr k).symm
+        (SingularMayerVietoris.singularHomologyMap overlapHomeomorph.toHomotopyEquiv.toFun k a) =
+      SingularMayerVietoris.singularHomologyMap Smale.PuncturedRadial.toSphere k a := by
+  change
+    (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (overlapSphereEquiv r hr) k).symm _ = _
+  rw [PeriodTorusHigherHomology.homotopyEquivHomologyEquiv_symm_apply]
+  have heq :
+    (overlapSphereEquiv (N := N) r hr).symm.toFun.comp overlapHomeomorph.toHomotopyEquiv.toFun =
+      Smale.PuncturedRadial.toSphere := by
+    apply ContinuousMap.ext
+    intro x
+    change Smale.PuncturedRadial.toSphere (overlapHomeomorph.symm (overlapHomeomorph x)) = _
+    rw [Homeomorph.symm_apply_apply]
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp, heq]
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.MorseSurgeryData.collapseComponentConnecting {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (m : ℕ)
+    (g : C(Smale.Hemisphere.Sphere m, d.UpperLevel)) (D : d.CollapseNeighborhoods m g)
+    [Fintype (d.beltIntersectionPoints m g)] (k : ℕ) :
+    SingularMayerVietoris.SingularHomology (Smale.Hemisphere.Sphere m) (k + 1) →ₗ[ℤ]
+      (∀ i : d.beltIntersectionPoints m g,
+        SingularMayerVietoris.SingularHomology
+          (↥((d.beltIntersectionPoints m g)ᶜ ∩ D.neighborhood i)) k) :=
+  Smale.CoverLocalContributions.componentConnecting (d.beltIntersectionPoints m g)ᶜ D.neighborhood
+    (Set.toFinite _).isClosed.isOpen_compl D.isOpen_neighborhood D.pairwise_disjoint D.open_cover
+    k
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    Smale.ManifoldMorse.MorseSurgeryData.collapseLocalClass {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (m : ℕ)
+    (g : C(Smale.Hemisphere.Sphere m, d.UpperLevel)) (D : d.CollapseNeighborhoods m g)
+    [Fintype (d.beltIntersectionPoints m g)] (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (Smale.Hemisphere.Sphere m) (k + 1))
+    (i : d.beltIntersectionPoints m g) :
+    SingularMayerVietoris.SingularHomology (Metric.sphere (0 : EuclideanSpace ℝ (Fin m)) 1) k :=
+  (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (D.overlapSphereEquiv i) k).symm
+    (d.collapseComponentConnecting m g D k a i)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.collapseConnecting_sum_overlaps {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (m : ℕ) (g : C(Smale.Hemisphere.Sphere m, d.UpperLevel)) (D : d.CollapseNeighborhoods m g)
+    [Fintype (d.beltIntersectionPoints m g)] (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (Smale.Hemisphere.Sphere m) (k + 1)) :
+    SingularMayerVietoris.connectingHomomorphism Smale.OnePointCover.oldPatch
+        Smale.OnePointCover.finitePatch Smale.OnePointCover.oldPatch_open
+        Smale.OnePointCover.finitePatch_open Smale.OnePointCover.cover k
+        (SingularMayerVietoris.singularHomologyMap (d.attachingCollapse hf m g) (k + 1) a) =
+      ∑ i,
+        SingularMayerVietoris.singularHomologyMap (d.collapseOverlapMap hf m g D i) k
+          (d.collapseComponentConnecting m g D k a i) :=
+  Smale.CoverLocalContributions.connecting_sum (d.beltIntersectionPoints m g)ᶜ D.neighborhood
+    (Set.toFinite _).isClosed.isOpen_compl D.isOpen_neighborhood D.pairwise_disjoint D.open_cover
+    Smale.OnePointCover.oldPatch Smale.OnePointCover.finitePatch (d.attachingCollapse hf m g)
+    (d.attachingCollapse_maps_old hf m g) (d.attachingCollapse_maps_neighborhood hf m g D)
+    Smale.OnePointCover.oldPatch_open Smale.OnePointCover.finitePatch_open
+    Smale.OnePointCover.cover k a
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.collapseConnecting_sum_boundaries {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (m : ℕ) (g : C(Smale.Hemisphere.Sphere m, d.UpperLevel)) (D : d.CollapseNeighborhoods m g)
+    [Fintype (d.beltIntersectionPoints m g)] (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (Smale.Hemisphere.Sphere m) (k + 1)) :
+    SingularMayerVietoris.connectingHomomorphism Smale.OnePointCover.oldPatch
+        Smale.OnePointCover.finitePatch Smale.OnePointCover.oldPatch_open
+        Smale.OnePointCover.finitePatch_open Smale.OnePointCover.cover k
+        (SingularMayerVietoris.singularHomologyMap (d.attachingCollapse hf m g) (k + 1) a) =
+      ∑ i,
+        SingularMayerVietoris.singularHomologyMap
+          (Smale.OnePointCover.overlapHomeomorph.toHomotopyEquiv.toFun.comp
+            (D.data i).innerBoundary.map)
+          k (d.collapseLocalClass m g D k a i) := by
+  rw [d.collapseConnecting_sum_overlaps hf m g D k a]
+  apply Finset.sum_congr rfl
+  intro i _
+  have h :
+    SingularMayerVietoris.singularHomologyMap (D.overlapSphereEquiv i).toFun k
+        (d.collapseLocalClass m g D k a i) =
+      d.collapseComponentConnecting m g D k a i :=
+    (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (D.overlapSphereEquiv i)
+          k).apply_symm_apply
+      _
+  rw [← h, ← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp,
+    d.collapseOverlapMap_sphereEquiv hf m g D i]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.collapseSphereConnecting_sum {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (m : ℕ) (g : C(Smale.Hemisphere.Sphere m, d.UpperLevel)) (D : d.CollapseNeighborhoods m g)
+    [Fintype (d.beltIntersectionPoints m g)] (r : ℝ) (hr : 0 < r) (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (Smale.Hemisphere.Sphere m) (k + 1)) :
+    Smale.OnePointCover.sphereConnecting r hr k
+        (SingularMayerVietoris.singularHomologyMap (d.attachingCollapse hf m g) (k + 1) a) =
+      ∑ i,
+        SingularMayerVietoris.singularHomologyMap (D.data i).innerBoundary.normalizedMap k
+          (d.collapseLocalClass m g D k a i) := by
+  change
+    (Smale.OnePointCover.overlapHomologyEquiv (N := d.chart.NegativeCoordinates) r hr k).symm
+        (SingularMayerVietoris.connectingHomomorphism Smale.OnePointCover.oldPatch
+          Smale.OnePointCover.finitePatch Smale.OnePointCover.oldPatch_open
+          Smale.OnePointCover.finitePatch_open Smale.OnePointCover.cover k
+          (SingularMayerVietoris.singularHomologyMap (d.attachingCollapse hf m g) (k + 1) a)) =
+      _
+  rw [d.collapseConnecting_sum_boundaries hf m g D k a, map_sum]
+  apply Finset.sum_congr rfl
+  intro i _
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply,
+    Smale.OnePointCover.overlapHomologyEquiv_symm_include]
+  rw [← LinearMap.comp_apply, ← PeriodTorusHigherHomology.singularHomologyMap_comp]
+  rfl
+
+private theorem Smale.CoverOverlapHomology.homologyEquiv_symm_single {X : Type} [TopologicalSpace X]
+    {ι : Type} [Fintype ι] [DecidableEq ι] (U : Set X) (V : ι → Set X) (hU : IsOpen U)
+    (hV : ∀ i, IsOpen (V i)) (hd : Pairwise (Disjoint on V)) (k : ℕ) (i : ι)
+    (a : SingularMayerVietoris.SingularHomology (↥(U ∩ V i)) k) :
+    (homologyEquiv U V hU hV hd k).symm (Pi.single i a) =
+      SingularMayerVietoris.singularHomologyMap (componentInclusion U V i) k a := by
+  rw [homologyEquiv_symm_apply, Finset.sum_eq_single i]
+  · rw [Pi.single_eq_same]
+  · intro j _ hji
+    rw [Pi.single_eq_of_ne hji, map_zero]
+  · simp
+
+private theorem Smale.CoverOverlapHomology.homologyEquiv_inclusion {X : Type} [TopologicalSpace X]
+    {ι : Type} [Fintype ι] [DecidableEq ι] (U : Set X) (V : ι → Set X) (hU : IsOpen U)
+    (hV : ∀ i, IsOpen (V i)) (hd : Pairwise (Disjoint on V)) (k : ℕ) (i : ι)
+    (a : SingularMayerVietoris.SingularHomology (↥(U ∩ V i)) k) :
+    homologyEquiv U V hU hV hd k
+        (SingularMayerVietoris.singularHomologyMap (componentInclusion U V i) k a) =
+      Pi.single i a := by
+  apply (homologyEquiv U V hU hV hd k).symm.injective
+  rw [LinearEquiv.symm_apply_apply, homologyEquiv_symm_single]
+
+private def
+    Smale.CoverOverlapHomology.componentMap {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    {ι : Type} (U : Set X) (V : ι → Set X) (U' : Set Y) (V' : ι → Set Y) (f : C(X, Y))
+    (hfU : Set.MapsTo f U U') (hfV : ∀ i, Set.MapsTo f (V i) (V' i)) (i : ι) :
+    C(↥(U ∩ V i), ↥(U' ∩ V' i)) :=
+  Smale.CoverNaturality.mapOn f _ _ (fun _ hx => ⟨hfU hx.1, hfV i hx.2⟩)
+
+private def
+    Smale.CoverOverlapHomology.overlapMap {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    {ι : Type} (U : Set X) (V : ι → Set X) (U' : Set Y) (V' : ι → Set Y) (f : C(X, Y))
+    (hfU : Set.MapsTo f U U') (hfV : ∀ i, Set.MapsTo f (V i) (V' i)) :
+    C(↥(U ∩ ⋃ i, V i), ↥(U' ∩ ⋃ i, V' i)) :=
+  Smale.CoverNaturality.mapOn f _ _
+    (by
+      intro x hx
+      obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hx.2
+      exact ⟨hfU hx.1, Set.mem_iUnion.mpr ⟨i, hfV i hi⟩⟩)
+
+private theorem Smale.CoverOverlapHomology.overlapMap_component {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] {ι : Type} (U : Set X) (V : ι → Set X) (U' : Set Y) (V' : ι → Set Y)
+    (f : C(X, Y)) (hfU : Set.MapsTo f U U') (hfV : ∀ i, Set.MapsTo f (V i) (V' i)) (i : ι) :
+    (overlapMap U V U' V' f hfU hfV).comp (componentInclusion U V i) =
+      (componentInclusion U' V' i).comp (componentMap U V U' V' f hfU hfV i) :=
+  rfl
+
+private theorem Smale.CoverOverlapHomology.homologyEquiv_map {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] {ι : Type} (U : Set X) (V : ι → Set X) (U' : Set Y) (V' : ι → Set Y)
+    (f : C(X, Y)) (hfU : Set.MapsTo f U U') (hfV : ∀ i, Set.MapsTo f (V i) (V' i)) [Fintype ι]
+    (hU : IsOpen U) (hV : ∀ i, IsOpen (V i)) (hd : Pairwise (Disjoint on V)) (hU' : IsOpen U')
+    (hV' : ∀ i, IsOpen (V' i)) (hd' : Pairwise (Disjoint on V')) (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (↥(U ∩ ⋃ i, V i)) k) :
+    homologyEquiv U' V' hU' hV' hd' k
+        (SingularMayerVietoris.singularHomologyMap (overlapMap U V U' V' f hfU hfV) k a) =
+      fun i =>
+      SingularMayerVietoris.singularHomologyMap (componentMap U V U' V' f hfU hfV i) k
+        (homologyEquiv U V hU hV hd k a i) := by
+  apply (homologyEquiv U' V' hU' hV' hd' k).symm.injective
+  rw [LinearEquiv.symm_apply_apply, homologyEquiv_symm_apply, homology_map_out U V hU hV hd]
+  apply Finset.sum_congr rfl
+  intro i _
+  rw [overlapMap_component, PeriodTorusHigherHomology.singularHomologyMap_comp,
+    LinearMap.comp_apply]
+
+private theorem
+    Smale.CoverLocalContributions.componentConnecting_enlarge {X : Type} [TopologicalSpace X]
+    {ι : Type} [Fintype ι] (U U' : Set X) (V : ι → Set X) (hU : IsOpen U) (hU' : IsOpen U')
+    (hV : ∀ i, IsOpen (V i)) (hd : Pairwise (Disjoint on V)) (hc : U ∪ (⋃ i, V i) = Set.univ)
+    (hsub : U ⊆ U') (i : ι) (hci : U' ∪ V i = Set.univ) (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology X (k + 1)) :
+    SingularMayerVietoris.singularHomologyMap
+        (Smale.CoverOverlapHomology.componentMap U V U' V (ContinuousMap.id X) hsub
+          (fun _ _ hx => hx) i)
+        k (componentConnecting U V hU hV hd hc k a i) =
+      SingularMayerVietoris.connectingHomomorphism U' (V i) hU' (hV i) hci k a := by
+  classical
+  have hc' : U' ∪ (⋃ j, V j) = Set.univ := by
+    apply Set.eq_univ_of_forall
+    intro x
+    have hx : x ∈ U ∪ (⋃ j, V j) := hc.symm ▸ Set.mem_univ x
+    exact hx.elim (fun hu => Or.inl (hsub hu)) Or.inr
+  have hbig :=
+    Smale.CoverNaturality.connecting_naturality_apply U (⋃ j, V j) U' (⋃ j, V j)
+      (ContinuousMap.id X) hsub (fun _ hx => hx) hU (isOpen_iUnion hV) hc hU' (isOpen_iUnion hV)
+      hc' k a
+  rw [PeriodTorusHigherHomology.singularHomologyMap_id, LinearMap.id_apply] at hbig
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (Smale.CoverOverlapHomology.overlapMap U V U' V (ContinuousMap.id X) hsub
+          (fun _ _ hx => hx))
+        k
+        (SingularMayerVietoris.connectingHomomorphism U (⋃ j, V j) hU (isOpen_iUnion hV) hc k a) =
+      SingularMayerVietoris.connectingHomomorphism U' (⋃ j, V j) hU' (isOpen_iUnion hV) hc' k
+        a at hbig
+  have hcoord :=
+    congrArg (fun b => Smale.CoverOverlapHomology.homologyEquiv U' V hU' hV hd k b i) hbig
+  have hnat :=
+    congrFun
+      (Smale.CoverOverlapHomology.homologyEquiv_map U V U' V (ContinuousMap.id X) hsub
+        (fun _ _ hx => hx) hU hV hd hU' hV hd k
+        (SingularMayerVietoris.connectingHomomorphism U (⋃ j, V j) hU (isOpen_iUnion hV) hc k a))
+      i
+  rw [hnat] at hcoord
+  have hsmall :=
+    Smale.CoverNaturality.connecting_naturality_apply U' (V i) U' (⋃ j, V j) (ContinuousMap.id X)
+      (fun _ hx => hx) (Set.subset_iUnion V i) hU' (hV i) hci hU' (isOpen_iUnion hV) hc' k a
+  rw [PeriodTorusHigherHomology.singularHomologyMap_id, LinearMap.id_apply] at hsmall
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (Smale.CoverOverlapHomology.componentInclusion U' V i) k
+        (SingularMayerVietoris.connectingHomomorphism U' (V i) hU' (hV i) hci k a) =
+      SingularMayerVietoris.connectingHomomorphism U' (⋃ j, V j) hU' (isOpen_iUnion hV) hc' k
+        a at hsmall
+  have hsingle :=
+    congrArg (fun b => Smale.CoverOverlapHomology.homologyEquiv U' V hU' hV hd k b i) hsmall
+  rw [Smale.CoverOverlapHomology.homologyEquiv_inclusion, Pi.single_eq_same] at hsingle
+  exact hcoord.trans hsingle.symm
+
+private def Smale.LocalDegree.SeparatedNeighborhoods.pointComplementInclusion {E F M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {P : Set M} {f : M → F}
+    {W : Set M} (D : Smale.LocalDegree.SeparatedNeighborhoods E P f W) (x : P) :
+    C(↥(Pᶜ ∩ D.neighborhood x), ↥({(x : M)}ᶜ ∩ D.neighborhood x)) :=
+  (Homeomorph.setCongr (D.overlap_eq x)).toHomotopyEquiv.toFun
+
+private theorem Smale.LocalDegree.SeparatedNeighborhoods.pointComplementInclusion_sphereEquiv
+    {E F M : Type} [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {P : Set M}
+    {f : M → F} {W : Set M} (D : Smale.LocalDegree.SeparatedNeighborhoods E P f W) (x : P) :
+    (D.pointComplementInclusion x).comp (D.overlapSphereEquiv x).toFun =
+      (Smale.LocalDegree.NativeNeighborhood.overlapSphereEquiv (x : M) (D.data x)).toFun := by
+  apply ContinuousMap.ext
+  intro u
+  rfl
+
+private theorem
+    Smale.LocalDegree.SeparatedNeighborhoods.componentConnecting_singlePoint {E F M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T1Space M] {P : Set M}
+    {f : M → F} {W : Set M} (D : Smale.LocalDegree.SeparatedNeighborhoods E P f W) [Fintype P]
+    (k : ℕ) (a : SingularMayerVietoris.SingularHomology M (k + 1)) (x : P) :
+    SingularMayerVietoris.singularHomologyMap (D.pointComplementInclusion x) k
+        (Smale.CoverLocalContributions.componentConnecting Pᶜ D.neighborhood
+          (Set.toFinite P).isClosed.isOpen_compl D.isOpen_neighborhood D.pairwise_disjoint
+          D.open_cover k a x) =
+      SingularMayerVietoris.connectingHomomorphism {(x : M)}ᶜ (D.neighborhood x)
+        isClosed_singleton.isOpen_compl (D.isOpen_neighborhood x)
+        (Smale.LocalDegree.NativeNeighborhood.singlePoint_cover (x : M) (D.data x)) k a := by
+  have hsub : Pᶜ ⊆ {(x : M)}ᶜ := by
+    intro y hy hxy
+    exact hy (hxy ▸ x.property)
+  exact
+    Smale.CoverLocalContributions.componentConnecting_enlarge Pᶜ {(x : M)}ᶜ D.neighborhood
+      (Set.toFinite P).isClosed.isOpen_compl isClosed_singleton.isOpen_compl D.isOpen_neighborhood
+      D.pairwise_disjoint D.open_cover hsub x
+      (Smale.LocalDegree.NativeNeighborhood.singlePoint_cover (x : M) (D.data x)) k a
+
+private theorem Smale.LocalDegree.SeparatedNeighborhoods.sphereConnecting_component {E F M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T1Space M] {P : Set M}
+    {f : M → F} {W : Set M} (D : Smale.LocalDegree.SeparatedNeighborhoods E P f W) [Fintype P]
+    (k : ℕ) (a : SingularMayerVietoris.SingularHomology M (k + 1)) (x : P) :
+    (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (D.overlapSphereEquiv x) k).symm
+        (Smale.CoverLocalContributions.componentConnecting Pᶜ D.neighborhood
+          (Set.toFinite P).isClosed.isOpen_compl D.isOpen_neighborhood D.pairwise_disjoint
+          D.open_cover k a x) =
+      Smale.LocalDegree.NativeNeighborhood.sphereConnecting (x : M) (D.data x) k a := by
+  let c :=
+    Smale.CoverLocalContributions.componentConnecting Pᶜ D.neighborhood
+      (Set.toFinite P).isClosed.isOpen_compl D.isOpen_neighborhood D.pairwise_disjoint
+      D.open_cover k a x
+  apply
+    (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+        (Smale.LocalDegree.NativeNeighborhood.overlapSphereEquiv (x : M) (D.data x)) k).injective
+  change
+    SingularMayerVietoris.singularHomologyMap
+        (Smale.LocalDegree.NativeNeighborhood.overlapSphereEquiv (x : M) (D.data x)).toFun k
+        ((PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (D.overlapSphereEquiv x) k).symm
+          c) =
+      (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+          (Smale.LocalDegree.NativeNeighborhood.overlapSphereEquiv (x : M) (D.data x)) k)
+        ((PeriodTorusHigherHomology.homotopyEquivHomologyEquiv
+              (Smale.LocalDegree.NativeNeighborhood.overlapSphereEquiv (x : M) (D.data x)) k).symm
+          _)
+  rw [LinearEquiv.apply_symm_apply, ← D.pointComplementInclusion_sphereEquiv x]
+  change
+    SingularMayerVietoris.singularHomologyMap
+        ((D.pointComplementInclusion x).comp (D.overlapSphereEquiv x).toFun) k
+        ((PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (D.overlapSphereEquiv x) k).symm
+          c) =
+      SingularMayerVietoris.connectingHomomorphism {(x : M)}ᶜ (D.neighborhood x)
+        isClosed_singleton.isOpen_compl (D.isOpen_neighborhood x)
+        (Smale.LocalDegree.NativeNeighborhood.singlePoint_cover (x : M) (D.data x)) k a
+  rw [PeriodTorusHigherHomology.singularHomologyMap_comp, LinearMap.comp_apply]
+  have h :
+    SingularMayerVietoris.singularHomologyMap (D.overlapSphereEquiv x).toFun k
+        ((PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (D.overlapSphereEquiv x) k).symm
+          c) =
+      c :=
+    (PeriodTorusHigherHomology.homotopyEquivHomologyEquiv (D.overlapSphereEquiv x)
+          k).apply_symm_apply
+      c
+  rw [h]
+  exact D.componentConnecting_singlePoint k a x
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.collapseLocalClass_singlePoint {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (m : ℕ)
+    (g : C(Smale.Hemisphere.Sphere m, d.UpperLevel)) (D : d.CollapseNeighborhoods m g)
+    [Fintype (d.beltIntersectionPoints m g)] (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (Smale.Hemisphere.Sphere m) (k + 1))
+    (i : d.beltIntersectionPoints m g) :
+    d.collapseLocalClass m g D k a i =
+      Smale.LocalDegree.NativeNeighborhood.sphereConnecting i.val (D.data i) k a :=
+  D.sphereConnecting_component k a i
+
+private theorem Smale.SphereNormalCoordinates.localBoundary_homology_outward {V F : Type}
+    [NormedAddCommGroup V] [InnerProductSpace ℝ V] [FiniteDimensional ℝ V] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (n : ℕ) [Fact (Module.finrank ℝ V = (n + 2) + 1)]
+    (c :
+      PartialDiffeomorph 𝓘(ℝ, EuclideanSpace ℝ (Fin (n + 2))) (𝓡 (n + 2))
+        (EuclideanSpace ℝ (Fin (n + 2))) (Metric.sphere (0 : V) 1) ∞)
+    (j : (ℝ × F) ≃L[ℝ] V) (B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] F)
+    (hz : (0 : EuclideanSpace ℝ (Fin (n + 2))) ∈ c.source) (f : Metric.sphere (0 : V) 1 → F)
+    (hf : MDifferentiableAt (𝓡 (n + 2)) 𝓘(ℝ, F) f (c 0))
+    (hA : (mfderiv (𝓡 (n + 2)) 𝓘(ℝ, F) f (c 0)).IsInvertible)
+    (L : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] F)
+    (hL : L.toContinuousLinearMap = fderiv ℝ (f ∘ c) 0) {s : Set (EuclideanSpace ℝ (Fin (n + 2)))}
+    (b : Smale.LocalDegree.BoundaryData (f ∘ c) L s) (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 1)) (k + 1)) :
+    SingularMayerVietoris.singularHomologyMap b.normalizedMap (k + 1)
+        ((SignType.sign (chartJacobian c j B 0) : ℤ) • a) =
+      (SignType.sign (normalJacobian j (c 0) (mfderiv (𝓡 (n + 2)) 𝓘(ℝ, F) f (c 0))) : ℤ) •
+        SingularMayerVietoris.singularHomologyMap
+          (Smale.LinearSphereAction.sphereMap B.toContinuousLinearMap B.injective) (k + 1) a := by
+  have hs := chartJacobian_sign_factor c j B hz f hf hA
+  have hd :
+    (L.trans B.symm).toLinearEquiv.toLinearMap.det =
+      (B.symm.toContinuousLinearMap.comp (fderiv ℝ (f ∘ c) 0)).det := by
+    rw [← hL]
+    rfl
+  rw [← hd] at hs
+  have hi := congrArg (fun v : SignType => (v : ℤ)) hs
+  simp only [SignType.coe_mul] at hi
+  rw [map_zsmul, b.normalized_homology_eq_sign_smul n B k a, smul_smul, hi]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.collapseLocalBoundary_homology_sign_of_transverse
+    {E M : Type} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (q n : ℕ) [Fact (Module.finrank ℝ d.chart.PositiveCoordinates = q + 1)]
+    (hdim : Module.finrank ℝ d.chart.NegativeCoordinates = n + 2)
+    (j : (ℝ × d.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient ((n + 2) + 1))
+    (B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] d.chart.NegativeCoordinates)
+    (g : Smale.Hemisphere.Sphere (n + 2) → d.UpperLevel) :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    letI : Fact (Module.finrank ℝ (Smale.Hemisphere.Ambient ((n + 2) + 1)) = (n + 2) + 1) :=
+      ⟨finrank_euclideanSpace_fin⟩
+    ∀ (_hg : ContMDiff (𝓡 (n + 2)) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g)
+      (_ht :
+        ∀ x y,
+          Smale.NativeTransversality.At (𝓡 (n + 2)) (𝓡 q) 𝓘(ℝ, Smale.RegularLevel.Model E) g
+            d.surgery.beltSphere x y)
+      (x : Smale.Hemisphere.Sphere (n + 2)),
+      x ∈ d.beltIntersectionPoints (n + 2) g →
+        ∀ (L : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] d.chart.NegativeCoordinates),
+          L.toContinuousLinearMap =
+              fderiv ℝ ((d.collapseNormal ∘ g) ∘ Smale.NativeParametrization.centered x) 0 →
+            ∀ {s : Set (EuclideanSpace ℝ (Fin (n + 2)))}
+              (b :
+                Smale.LocalDegree.BoundaryData
+                  ((d.collapseNormal ∘ g) ∘ Smale.NativeParametrization.centered x) L s)
+              (k : ℕ)
+              (a :
+                SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 1))
+                  (k + 1)),
+              SingularMayerVietoris.singularHomologyMap b.normalizedMap (k + 1)
+                  ((SignType.sign
+                        (Smale.SphereNormalCoordinates.chartJacobian
+                          (Smale.NativeParametrization.centered x) j B 0) :
+                      ℤ) •
+                    a) =
+                (d.beltIntersectionSign (n + 2) j g x : ℤ) •
+                  SingularMayerVietoris.singularHomologyMap
+                    (Smale.LinearSphereAction.sphereMap B.toContinuousLinearMap B.injective)
+                    (k + 1) a := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  let _ : Fact (Module.finrank ℝ (Smale.Hemisphere.Ambient ((n + 2) + 1)) = (n + 2) + 1) :=
+    ⟨finrank_euclideanSpace_fin⟩
+  intro hg ht x hx L hL s b k a
+  have hs := d.contMDiffAt_collapseNormal_comp hf (n + 2) g hg x hx
+  have hA := d.isInvertible_collapseNormal_comp_of_transverse hf q (n + 2) hdim g hg ht x hx
+  have hc0 := Smale.NativeParametrization.centered_zero (D := EuclideanSpace ℝ (Fin (n + 2))) x
+  have h :=
+    Smale.SphereNormalCoordinates.localBoundary_homology_outward n
+      (Smale.NativeParametrization.centered x) j B
+      (Smale.NativeParametrization.zero_mem_centered_source x) (d.collapseNormal ∘ g)
+      (hc0.symm ▸ hs.mdifferentiableAt (by simp)) (hc0.symm ▸ hA) L hL b k a
+  rw [hc0, d.collapseNormal_comp_sign_of_transverse hf q (n + 2) hdim j g hg ht x hx] at h
+  exact h
+
+private theorem Smale.ManifoldMorse.MorseSurgeryData.instLocal1 (n : ℕ) :
+    Fact (Module.finrank ℝ (EuclideanSpace ℝ (Fin (n + 3))) = (n + 2) + 1) :=
+  ⟨by simp⟩
+
+attribute [local instance] Smale.ManifoldMorse.MorseSurgeryData.instLocal1 in
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.collapseLocalClass_eq_outward {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (n : ℕ)
+    (j : (ℝ × d.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient ((n + 2) + 1))
+    (B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] d.chart.NegativeCoordinates)
+    (g : C(Smale.Hemisphere.Sphere (n + 2), d.UpperLevel)) (D : d.CollapseNeighborhoods (n + 2) g)
+    [Fintype (d.beltIntersectionPoints (n + 2) g)] (k : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 2)) (k + 2))
+    (i : d.beltIntersectionPoints (n + 2) g) :
+    d.collapseLocalClass (n + 2) g D (k + 1) a i =
+      (SignType.sign
+            (Smale.SphereNormalCoordinates.chartJacobian
+              (Smale.NativeParametrization.centered i.val) j B 0) :
+          ℤ) •
+        Smale.SpherePoint.outwardClass n j B k a := by
+  rw [d.collapseLocalClass_singlePoint]
+  exact Smale.SpherePoint.pointConnecting_eq_outward n j B i.val (D.data i) k a
+
+attribute [local instance] Smale.ManifoldMorse.MorseSurgeryData.instLocal1 in
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.collapseLocalBoundary_outward {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (q n : ℕ)
+    [Fact (Module.finrank ℝ d.chart.PositiveCoordinates = q + 1)]
+    (hdim : Module.finrank ℝ d.chart.NegativeCoordinates = n + 2)
+    (j : (ℝ × d.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient ((n + 2) + 1))
+    (B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] d.chart.NegativeCoordinates)
+    (g : C(Smale.Hemisphere.Sphere (n + 2), d.UpperLevel)) (D : d.CollapseNeighborhoods (n + 2) g)
+    [Fintype (d.beltIntersectionPoints (n + 2) g)] :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    ∀ (_hg : ContMDiff (𝓡 (n + 2)) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g)
+      (_ht :
+        ∀ x y,
+          Smale.NativeTransversality.At (𝓡 (n + 2)) (𝓡 q) 𝓘(ℝ, Smale.RegularLevel.Model E) g
+            d.surgery.beltSphere x y)
+      (k : ℕ)
+      (a : SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 2)) (k + 2))
+      (i : d.beltIntersectionPoints (n + 2) g),
+      SingularMayerVietoris.singularHomologyMap (D.data i).innerBoundary.normalizedMap (k + 1)
+          (d.collapseLocalClass (n + 2) g D (k + 1) a i) =
+        (d.beltIntersectionSign (n + 2) j g i.val : ℤ) •
+          SingularMayerVietoris.singularHomologyMap
+            (Smale.LinearSphereAction.sphereMap B.toContinuousLinearMap B.injective) (k + 1)
+            (Smale.SpherePoint.outwardClass n j B k a) := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  intro hg ht k a i
+  rw [d.collapseLocalClass_eq_outward n j B g D k a i]
+  exact
+    d.collapseLocalBoundary_homology_sign_of_transverse hf q n hdim j B g hg ht i.val i.property
+      (D.linear i) (D.derivative_eq i) (D.data i).innerBoundary k _
+
+attribute [local instance] Smale.ManifoldMorse.MorseSurgeryData.instLocal1 in
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.beltIntersectionCount_smul {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (m : ℕ)
+    (j : (ℝ × d.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient (m + 1))
+    (g : Smale.Hemisphere.Sphere m → d.UpperLevel) [Fintype (d.beltIntersectionPoints m g)]
+    (hfin : (d.beltIntersectionPoints m g).Finite) {A : Type*} [AddCommGroup A] (a : A) :
+    (∑ i : d.beltIntersectionPoints m g, (d.beltIntersectionSign m j g i.val : ℤ) • a) =
+      d.beltIntersectionCount m j g hfin • a := by
+  have hcount :
+    (∑ i : d.beltIntersectionPoints m g, (d.beltIntersectionSign m j g i.val : ℤ)) =
+      d.beltIntersectionCount m j g hfin :=
+    (Finset.sum_subtype hfin.toFinset (fun _ => hfin.mem_toFinset)
+        (fun x => (d.beltIntersectionSign m j g x : ℤ))).symm
+  exact Finset.sum_smul.symm.trans (congrArg (fun z : ℤ => z • a) hcount)
+
+attribute [local instance] Smale.ManifoldMorse.MorseSurgeryData.instLocal1 in
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.collapseSphereConnecting_signed_count {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) [FiniteDimensional ℝ E] [T2Space M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (q n : ℕ)
+    [Fact (Module.finrank ℝ d.chart.PositiveCoordinates = q + 1)]
+    (hdim : Module.finrank ℝ d.chart.NegativeCoordinates = n + 2)
+    (j : (ℝ × d.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient ((n + 2) + 1))
+    (B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] d.chart.NegativeCoordinates)
+    (g : C(Smale.Hemisphere.Sphere (n + 2), d.UpperLevel)) (D : d.CollapseNeighborhoods (n + 2) g)
+    [Finite (d.beltIntersectionPoints (n + 2) g)] :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    ∀ (_hg : ContMDiff (𝓡 (n + 2)) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g)
+      (_ht :
+        ∀ x y,
+          Smale.NativeTransversality.At (𝓡 (n + 2)) (𝓡 q) 𝓘(ℝ, Smale.RegularLevel.Model E) g
+            d.surgery.beltSphere x y)
+      (r : ℝ) (hr : 0 < r) (k : ℕ)
+      (a : SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 2)) (k + 2)),
+      Smale.OnePointCover.sphereConnecting r hr (k + 1)
+          (SingularMayerVietoris.singularHomologyMap (d.attachingCollapse hf.continuous (n + 2) g)
+            (k + 2) a) =
+        d.beltIntersectionCount (n + 2) j g (Set.toFinite _) •
+          SingularMayerVietoris.singularHomologyMap
+            (Smale.LinearSphereAction.sphereMap B.toContinuousLinearMap B.injective) (k + 1)
+            (Smale.SpherePoint.outwardClass n j B k a) := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  let _ : Fintype (d.beltIntersectionPoints (n + 2) g) := Fintype.ofFinite _
+  intro hg ht r hr k a
+  apply (d.collapseSphereConnecting_sum hf.continuous (n + 2) g D r hr (k + 1) a).trans
+  apply
+    Eq.trans
+      (Finset.sum_congr rfl
+        (fun i _ => d.collapseLocalBoundary_outward hf q n hdim j B g D hg ht k a i))
+  exact d.beltIntersectionCount_smul (n + 2) j g (Set.toFinite _) _
+
+private theorem Smale.ManifoldMorse.MorseSurgeryData.collapse_homology_signed_count {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [T2Space M] [CompactSpace M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (q n : ℕ) [Fact (Module.finrank ℝ d.chart.PositiveCoordinates = q + 1)]
+    (hdim : Module.finrank ℝ d.chart.NegativeCoordinates = n + 2)
+    (j : (ℝ × d.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient ((n + 2) + 1))
+    (B : EuclideanSpace ℝ (Fin (n + 2)) ≃L[ℝ] d.chart.NegativeCoordinates)
+    (g : C(Smale.Hemisphere.Sphere (n + 2), d.UpperLevel)) :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    ∀ (hg : ContMDiff (𝓡 (n + 2)) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g)
+      (hinj : Function.Injective g)
+      (ht :
+        ∀ x y,
+          Smale.NativeTransversality.At (𝓡 (n + 2)) (𝓡 q) 𝓘(ℝ, Smale.RegularLevel.Model E) g
+            d.surgery.beltSphere x y)
+      (r : ℝ) (hr : 0 < r) (k : ℕ)
+      (a : SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere (n + 2)) (k + 2)),
+      Smale.OnePointCover.sphereConnecting r hr (k + 1)
+          (SingularMayerVietoris.singularHomologyMap (d.attachingCollapse hf.continuous (n + 2) g)
+            (k + 2) a) =
+        d.beltIntersectionCount (n + 2) j g
+            (d.finite_beltIntersectionPoints hf q (n + 2) hdim g hg hinj ht) •
+          SingularMayerVietoris.singularHomologyMap
+            (Smale.LinearSphereAction.sphereMap B.toContinuousLinearMap B.injective) (k + 1)
+            (Smale.SpherePoint.outwardClass n j B k a) := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  intro hg hinj ht r hr k a
+  let _ : Fintype (d.beltIntersectionPoints (n + 2) g) :=
+    (d.finite_beltIntersectionPoints hf q (n + 2) hdim g hg hinj ht).fintype
+  obtain ⟨D⟩ := d.nonempty_collapseNeighborhoods hf q (n + 2) hdim g hg hinj ht
+  exact d.collapseSphereConnecting_signed_count hf q n hdim j B g D hg ht r hr k a
+
+private theorem Smale.ManifoldMorse.MorseSurgeryData.indexTwoCoordinate_signed_count {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [T2Space M] [CompactSpace M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (q : ℕ)
+    [Fact (Module.finrank ℝ d.chart.PositiveCoordinates = q + 1)]
+    (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 2)
+    (j : (ℝ × d.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient 3)
+    (g : C(Smale.Hemisphere.Sphere 2, d.UpperLevel)) :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    ∀ (hg : ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g) (hinj : Function.Injective g)
+      (ht :
+        ∀ x y,
+          Smale.NativeTransversality.At (𝓡 2) (𝓡 q) 𝓘(ℝ, Smale.RegularLevel.Model E) g
+            d.surgery.beltSphere x y)
+      (a : SingularMayerVietoris.SingularHomology (SphereHomology.UnitSphere 2) 2),
+      d.indexTwoCollapseCoordinate hf.continuous hindex
+          (SingularMayerVietoris.singularHomologyMap (d.upperLevelInclusion.comp g) 2 a) =
+        d.beltIntersectionCount 2 j g
+            (d.finite_beltIntersectionPoints hf q 2 hindex g hg hinj ht) *
+          Smale.SpherePoint.sourceCountMark 0 j (d.indexTwoNormalModel hindex) a := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  intro hg hinj ht a
+  have h :=
+    Smale.SpherePoint.countMark_of_connecting 0 j (d.indexTwoNormalModel hindex) _ a _
+      (d.collapse_homology_signed_count hf q 0 hindex j (d.indexTwoNormalModel hindex) g hg hinj
+        ht 1 zero_lt_one 0 a)
+  have hc :
+    d.attachingCollapse hf.continuous 2 g =
+      (d.upperCollapseMap hf.continuous).comp (d.upperLevelInclusion.comp g) :=
+    rfl
+  rw [hc, PeriodTorusHigherHomology.singularHomologyMap_comp] at h
+  exact h
+
+private theorem Smale.ManifoldMorse.MorseSurgeryData.indexTwoCoordinate_topClass_natAbs {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [T2Space M] [CompactSpace M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (q : ℕ)
+    [Fact (Module.finrank ℝ d.chart.PositiveCoordinates = q + 1)]
+    (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 2)
+    (j : (ℝ × d.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient 3)
+    (g : C(Smale.Hemisphere.Sphere 2, d.UpperLevel)) :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    ∀ (hg : ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g) (hinj : Function.Injective g)
+      (ht :
+        ∀ x y,
+          Smale.NativeTransversality.At (𝓡 2) (𝓡 q) 𝓘(ℝ, Smale.RegularLevel.Model E) g
+            d.surgery.beltSphere x y),
+      (d.indexTwoCollapseCoordinate hf.continuous hindex
+            (SingularMayerVietoris.singularHomologyMap (d.upperLevelInclusion.comp g) 2
+              (SphereHomology.unitSphereTopClass 1))).natAbs =
+        (d.beltIntersectionCount 2 j g
+            (d.finite_beltIntersectionPoints hf q 2 hindex g hg hinj ht)).natAbs := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  intro hg hinj ht
+  rw [d.indexTwoCoordinate_signed_count hf q hindex j g hg hinj ht, Int.natAbs_mul,
+    Smale.SpherePoint.sourceCountMark_topClass_natAbs, mul_one]
+
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.indexTwoCoordinate_transverse_natAbs {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [T2Space M] [CompactSpace M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 2)
+    (j : (ℝ × d.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient 3)
+    (g : C(Smale.Hemisphere.Sphere 2, d.UpperLevel))
+    (hgood : d.IsTransverseBeltSphere hf hdim hindex g) :
+    (d.indexTwoCollapseCoordinate hf.continuous hindex
+          (SingularMayerVietoris.singularHomologyMap (d.upperLevelInclusion.comp g) 2
+            (SphereHomology.unitSphereTopClass 1))).natAbs =
+      (d.beltIntersectionCount 2 j g
+          (d.finite_points_of_isTransverseBeltSphere hf hdim hindex hgood)).natAbs := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  let _ : Fact (Module.finrank ℝ d.chart.PositiveCoordinates = 3 + 1) :=
+    ⟨by have h := d.chart.finrank_negative_add_positive; omega⟩
+  obtain ⟨hg, hinj, _, ht⟩ := hgood
+  exact d.indexTwoCoordinate_topClass_natAbs hf 3 hindex j g hg hinj ht
+
+private theorem MorseCancel.last_index_two_collapse_is_primitive {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [Nonempty M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hdim : Module.finrank ℝ E = 6)
+    (horder :
+      ∀ x y : Smale.ManifoldMorse.criticalPoints E f,
+        f x < f y → nativeMorseIndex E f x ≤ nativeMorseIndex E f y)
+    (hzero : nativeMorseCount E f 0 = 1) (hone : nativeMorseCount E f 1 = 0) (r n : ℕ)
+    (hr : nativeMorseCount E f 2 = r) (hrpos : 0 < r) (hrc : r + n < S.toSurgeryWindows.count) :
+    let q := S.toSurgeryWindows.point ⟨r, by omega⟩
+    ∃ hindex : Module.finrank ℝ (S.data q).chart.NegativeCoordinates = 2,
+      Function.Surjective ((S.data q).indexTwoCollapseCoordinate hf.continuous hindex) ∧
+        ∀ γ : C(Smale.Hemisphere.Sphere 1, (S.data q).LowerLevel),
+          ∃ z, γ.Homotopic (ContinuousMap.const _ z) := by
+  obtain ⟨r', n', htwo, hrc', hthree, -, hafter⟩ :=
+    exists_middle_index_blocks S.toSurgeryWindows hf hdim horder hzero hone
+  obtain ⟨hr', -⟩ :=
+    native_middle_block_counts S.toSurgeryWindows hf r' n' htwo hrc' hthree hafter
+  have hrr : r' = r := hr'.symm.trans hr
+  rw [hrr] at htwo
+  let q := S.toSurgeryWindows.point ⟨r, by omega⟩
+  have hindex : Module.finrank ℝ (S.data q).chart.NegativeCoordinates = 2 :=
+    htwo ⟨r, by omega⟩ hrpos le_rfl
+  let _ :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology { y : M // f y ≤ f q - (S.data q).radius ^ 2 } 1) :=
+    S.toSurgeryWindows.lower_homologyOne_subsingleton_of_indices hf ⟨r, by omega⟩ hrpos
+      (fun i hi hir => by have hh := htwo i hi hir.le; omega)
+  have hnidx : nativeMorseIndex E f q = 2 :=
+    (nativeMorseIndex_eq_chart (S.data q).chart).trans hindex
+  exact
+    ⟨hindex, (S.data q).indexTwoCoordinate_surjective hf.continuous hindex,
+      lower_circle_nullhomotopies_of_ordered_native_indices S.toSurgeryWindows hf hdim q hnidx
+        hzero hone (fun z hz => (horder z q hz).trans_eq hnidx)⟩
+
+attribute [local irreducible] MorseCancel.canonicalMiddleMatrix in
+private theorem MorseCancel.exists_native_belt_cut_family {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [Nonempty M] {f : M → ℝ}
+    (S T : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6)
+    (horder :
+      ∀ x y : Smale.ManifoldMorse.criticalPoints E f,
+        f x < f y → nativeMorseIndex E f x ≤ nativeMorseIndex E f y)
+    (hzero : nativeMorseCount E f 0 = 1) (hone : nativeMorseCount E f 1 = 0) (r n : ℕ)
+    (hr : nativeMorseCount E f 2 = r) (hn : nativeMorseCount E f 3 = n) (hrpos : 0 < r)
+    (hrc : r + n < S.toSurgeryWindows.count)
+    (hradii : ∀ z, (T.data z).radius < (S.data z).radius) :
+    let q := S.toSurgeryWindows.point ⟨r, by omega⟩
+    let a := nativeMiddleBaseCut S r n hrc
+    let p := nativeMiddleBlockPoint S r n hrc
+    ∀ (_ : ∀ j, a < T.toSurgeryWindows.lower (p j))
+      (B : (Fin r → ℤ) ≃ₗ[ℤ] SingularMayerVietoris.SingularHomology { y : M // f y ≤ a } 2)
+      (γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a })),
+      IsNativeMiddleBasinFamily T hf (S.data q).upper_regular p (fun j => γ j) →
+        Function.Surjective (canonicalMiddleMatrix B γ).mulVec →
+          ∃ hindex : Module.finrank ℝ (T.data q).chart.NegativeCoordinates = 2,
+            Function.Surjective ((T.data q).indexTwoCollapseCoordinate hf.continuous hindex) ∧
+              (∀ δ : C(Smale.Hemisphere.Sphere 1, (T.data q).LowerLevel),
+                  ∃ z, δ.Homotopic (ContinuousMap.const _ z)) ∧
+                (∀ z : Smale.ManifoldMorse.criticalPoints E f,
+                    nativeMorseIndex E f z < 3 → f z < T.toSurgeryWindows.upper q) ∧
+                  (∀ z : Smale.ManifoldMorse.criticalPoints E f,
+                      nativeMorseIndex E f z = 3 → ∃ j, p j = z) ∧
+                    (∀ j, T.toSurgeryWindows.upper q < T.toSurgeryWindows.lower (p j)) ∧
+                      ∃ β : Fin n → C((Smale.Hemisphere.Sphere 2), (T.data q).UpperLevel),
+                        IsNativeMiddleBasinFamily T hf (T.data q).upper_regular p (fun j => β j) ∧
+                          (∀ j x, ∃ t : ℝ, T.flow t (γ j x).val = (β j x).val) ∧
+                            ∃ B' :
+                              (Fin r → ℤ) ≃ₗ[ℤ]
+                                SingularMayerVietoris.SingularHomology
+                                  { y : M // f y ≤ T.toSurgeryWindows.upper q } 2,
+                              canonicalMiddleMatrix B' β = canonicalMiddleMatrix B γ ∧
+                                Function.Surjective (canonicalMiddleMatrix B' β).mulVec := by
+  let q := S.toSurgeryWindows.point ⟨r, by omega⟩
+  let a := nativeMiddleBaseCut S r n hrc
+  let p := nativeMiddleBlockPoint S r n hrc
+  dsimp only
+  intro hlower B γ hγ hsurj
+  have hrcT : r + n < T.toSurgeryWindows.count := hrc
+  obtain ⟨hindex, hprimitive, hnull⟩ :=
+    last_index_two_collapse_is_primitive T hf hdim horder hzero hone r n hr hrpos hrcT
+  obtain ⟨hcomplete, hcut⟩ :=
+    native_middle_block_complete_and_cut T hf hdim horder hzero hone r n hr hn hrcT
+  have hba : T.toSurgeryWindows.upper q < a := by
+    change f q + (T.data q).radius ^ 2 < f q + (S.data q).radius ^ 2
+    have hh := hradii q
+    nlinarith [(T.data q).radius_pos, (S.data q).radius_pos]
+  have hband :
+    ∀ y,
+      f y ∈ Set.Icc (T.toSurgeryWindows.upper q) a → y ∉ Smale.ManifoldMorse.criticalPoints E f :=
+    by
+    intro y hy hcrit
+    have hqy : f q < f y := (T.toSurgeryWindows.value_lt_upper q).trans_le hy.1
+    have heq : y = q.val :=
+      S.isolated q y hcrit ⟨((S.toSurgeryWindows.lower_lt_value q).trans hqy).le, hy.2⟩
+    exact hqy.ne (congrArg f heq).symm
+  have hnpos : 0 < n := by
+    by_contra hnot
+    have hnzero : n = 0 := Nat.eq_zero_of_not_pos hnot
+    obtain ⟨x, hx⟩ := hsurj 1
+    have hh := congrFun hx ⟨0, hrpos⟩
+    let _ : IsEmpty (Fin n) := ⟨fun j => by have hj := j.isLt; omega⟩
+    simp only [Matrix.mulVec, dotProduct, Finset.univ_eq_empty, Finset.sum_empty,
+      Pi.one_apply] at hh
+    exact zero_ne_one hh
+  let za := γ ⟨0, hnpos⟩ (Smale.Hemisphere.point Bool.true ⟨0, by simp⟩)
+  obtain ⟨β, hβ, horbit, -, hmatrix, hsurj'⟩ :=
+    T.exists_lower_cut_geometric_matrix hf hba (S.data q).upper_regular (T.data q).upper_regular
+      hband za p (fun j => (hlower j).trans (T.toSurgeryWindows.lower_lt_value (p j))) B γ hγ
+      hsurj
+  exact
+    ⟨hindex, hprimitive, hnull, hcut, hcomplete, fun j => hba.trans (hlower j), β, hβ, horbit,
+      B.trans (regularCutHomologyEquiv hf hba.le hband).symm, hmatrix, hsurj'⟩
+
+private theorem Smale.SupportedDiffeomorph.IsotopicToIdentity.homotopic {F H M : Type}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] {J : ModelWithCorners ℝ F H}
+    [TopologicalSpace M] [ChartedSpace H M] {e : Diffeomorph J J M M ∞}
+    (he : Smale.SupportedDiffeomorph.IsotopicToIdentity e) :
+    (ContinuousMap.id M).Homotopic e.toHomeomorph.toHomotopyEquiv.toFun := by
+  obtain ⟨A, hA, hA₀, hA₁, _⟩ := he
+  exact
+    ⟨{  toFun := fun p => A (p.1.val, p.2)
+        continuous_toFun :=
+          hA.continuous.comp ((continuous_subtype_val.comp continuous_fst).prodMk continuous_snd)
+        map_zero_left := hA₀
+        map_one_left := hA₁ }⟩
+
+private theorem Smale.SupportedDiffeomorph.IsotopicToIdentity.comp_homotopic {F H M : Type}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] {J : ModelWithCorners ℝ F H}
+    [TopologicalSpace M] [ChartedSpace H M] {e : Diffeomorph J J M M ∞} {X : Type*}
+    [TopologicalSpace X] (he : Smale.SupportedDiffeomorph.IsotopicToIdentity e) (g : C(X, M)) :
+    g.Homotopic (e.toHomeomorph.toHomotopyEquiv.toFun.comp g) := by
+  simpa using he.homotopic.comp (ContinuousMap.Homotopic.refl g)
+
+private theorem Smale.ManifoldMorse.MorseSurgeryData.exists_transverse_representative {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 2)
+    (g₀ : C(Smale.Hemisphere.Sphere 2, d.UpperLevel)) :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    ∀ (_hg₀ : ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g₀)
+      (_hinj : Function.Injective g₀)
+      (_himm : ∀ x, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) g₀ x)),
+      ∃ e :
+        Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E) d.UpperLevel
+          d.UpperLevel ∞,
+        ∃ g : C(Smale.Hemisphere.Sphere 2, d.UpperLevel),
+          Smale.SupportedDiffeomorph.IsotopicToIdentity e ∧
+            (∀ x, g x = e (g₀ x)) ∧ d.IsTransverseBeltSphere hf hdim hindex g ∧ g₀.Homotopic g := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  let _ := Smale.RegularLevel.isManifold hf d.upper_regular
+  let _ : CompactSpace d.UpperLevel :=
+    isCompact_iff_compactSpace.mp (isClosed_eq hf.continuous continuous_const).isCompact
+  let _ : Fact (Module.finrank ℝ d.chart.PositiveCoordinates = 3 + 1) :=
+    ⟨by have h := d.chart.finrank_negative_add_positive; omega⟩
+  intro hg₀ hinj himm
+  have hdim' :
+    Module.finrank ℝ (EuclideanSpace ℝ (Fin 2)) + Module.finrank ℝ (EuclideanSpace ℝ (Fin 3)) =
+      Module.finrank ℝ (Smale.RegularLevel.Model E) := by simp [Smale.RegularLevel.Model, hdim]
+  obtain ⟨e, hiso, ht⟩ :=
+    Smale.NativeTransversality.exists_ambient_transverse_diffeomorph hg₀ (d.belt_smooth hf 3)
+      hdim'
+  let g := e.toHomeomorph.toHomotopyEquiv.toFun.comp g₀
+  have hg : ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g := e.contMDiff.comp hg₀
+  have hi : ∀ x, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) g x) := by
+    intro x
+    change Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) (e ∘ g₀) x)
+    rw [mfderiv_comp x (e.mdifferentiable (by simp) _) (hg₀.mdifferentiable (by simp) x)]
+    exact
+      ((e.toOpenPartialHomeomorph_mdifferentiable (by simp)).mfderiv_injective (by trivial)).comp
+        (himm x)
+  exact ⟨e, g, hiso, fun _ => rfl, ⟨hg, e.injective.comp hinj, hi, ht⟩, hiso.comp_homotopic g₀⟩
+
+private theorem MorseCancel.exists_single_intersection_of_unit_coordinate {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 2)
+    (hnull :
+      ∀ δ : C(Smale.Hemisphere.Sphere 1, d.LowerLevel),
+        ∃ z, δ.Homotopic (ContinuousMap.const _ z))
+    (γ : C((Smale.Hemisphere.Sphere 2), d.UpperLevel)) :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    ∀ (_ : ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ γ) (_ : Function.Injective γ)
+      (_ : ∀ x, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) γ x)),
+      (d.indexTwoCollapseCoordinate hf.continuous hindex
+              (middleSectionClass (f := f) (a := f p + d.radius ^ 2) γ)).natAbs =
+          1 →
+        ∃ D :
+          Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+            d.UpperLevel d.UpperLevel ∞,
+          ∃ δ : C((Smale.Hemisphere.Sphere 2), d.UpperLevel),
+            Smale.SupportedDiffeomorph.IsotopicToIdentity D ∧
+              (∀ x, δ x = D (γ x)) ∧
+                d.IsTransverseBeltSphere hf hdim hindex δ ∧
+                  (Set.range δ ∩ Set.range d.surgery.beltSphere).ncard = 1 := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  intro hγ hinj himm hunit
+  obtain ⟨D₀, γ₀, hD₀, hγ₀, hgood₀, hhom⟩ :=
+    d.exists_transverse_representative hf hdim hindex γ hγ hinj himm
+  have hmaps := PeriodTorusHigherHomology.homotopic_homologyMap hhom 2
+  have hclass :
+    middleSectionClass (f := f) (a := f p + d.radius ^ 2) γ₀ =
+      middleSectionClass (f := f) (a := f p + d.radius ^ 2) γ := by
+    simp only [middleSectionClass, PeriodTorusHigherHomology.singularHomologyMap_comp,
+      LinearMap.comp_apply]
+    rw [← hmaps]
+  have hcount :
+    (d.beltIntersectionCount 2 (d.beltNormalReference 2 hindex) γ₀
+          (d.finite_points_of_isTransverseBeltSphere hf hdim hindex hgood₀)).natAbs =
+      1 := by
+    rw [←
+      d.indexTwoCoordinate_transverse_natAbs hf hdim hindex (d.beltNormalReference 2 hindex) γ₀
+        hgood₀]
+    change
+      (d.indexTwoCollapseCoordinate hf.continuous hindex
+            (middleSectionClass (f := f) (a := f p + d.radius ^ 2) γ₀)).natAbs =
+        1
+    rw [hclass]
+    exact hunit
+  obtain ⟨D₁, δ, x, hD₁, hδ, hgood, -, hinter⟩ :=
+    d.exists_single_belt_intersection_of_unit_count hf hdim hindex hnull
+      (d.beltNormalReference 2 hindex) γ₀ hgood₀ hcount
+  refine ⟨D₀.trans D₁, δ, hD₀.trans hD₁, (fun x => (hδ x).trans (congrArg D₁ (hγ₀ x))), hgood, ?_⟩
+  rw [hinter, Set.ncard_singleton]
+
+private theorem
+    AdaptedWindows.cancel_single_basin_section_isotopy {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} {Y : Type}
+    [TopologicalSpace Y] [ChartedSpace (EuclideanSpace ℝ (Fin 3)) Y] (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f)
+    (hdim : Module.finrank ℝ E = 6) (p q : Smale.ManifoldMorse.criticalPoints E f)
+    (hconsecutive : ∀ r : Smale.ManifoldMorse.criticalPoints E f, ¬(f p < f r ∧ f r < f q))
+    (hp : MorseCancel.nativeMorseIndex E f p = 2) (hq : MorseCancel.nativeMorseIndex E f q = 3)
+    {c : ℝ} (hpc : f p < c) (hcq : c < f q)
+    (hc : ∀ z, f z = c → z ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    letI := Smale.RegularLevel.chartedSpace hf hc
+    ∀ (α : Smale.Hemisphere.Sphere 2 → { z : M // f z = c }) (β : Y → { z : M // f z = c }),
+      ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ α →
+        ContMDiff (𝓡 3) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ β →
+          (∀ z,
+              z ∈ Set.range α ↔ Filter.Tendsto (fun t => S.flow t z.val) Filter.atBot (𝓝 q.val)) →
+            (∀ z,
+                z ∈ Set.range β ↔
+                  Filter.Tendsto (fun t => S.flow t z.val) Filter.atTop (𝓝 p.val)) →
+              ∀ D :
+                Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+                  { z : M // f z = c } { z : M // f z = c } ∞,
+                Smale.SupportedDiffeomorph.IsotopicToIdentity D →
+                  (∀ x y,
+                      Smale.NativeTransversality.At (𝓡 2) (𝓡 3) 𝓘(ℝ, Smale.RegularLevel.Model E)
+                        (D ∘ α) β x y) →
+                    (Set.range (D ∘ α) ∩ Set.range β).ncard = 1 →
+                      ∃ g : M → ℝ,
+                        ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+                          Smale.ManifoldMorse.IsMorse E g ∧
+                            (Smale.ManifoldMorse.criticalPoints E g).ncard + 2 =
+                                (Smale.ManifoldMorse.criticalPoints E f).ncard ∧
+                              (∀ z,
+                                  z ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+                                    z ∈ Smale.ManifoldMorse.criticalPoints E f ∧
+                                      z ≠ p.val ∧ z ≠ q.val) ∧
+                                ∀ z,
+                                  f z ∉
+                                      Set.Ioo (S.toSurgeryWindows.lower p)
+                                        (S.toSurgeryWindows.upper q) →
+                                    g =ᶠ[𝓝 z] f := by
+  let _ := Smale.RegularLevel.chartedSpace hf hc
+  intro α β hα hβ hback hforward D hD htrans hsingle
+  let δ := D.symm ∘ β
+  have hδ : ContMDiff (𝓡 3) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ δ := D.symm.contMDiff.comp hβ
+  have hDα : ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ (D ∘ α) := D.contMDiff.comp hα
+  have hαeq : D.symm ∘ (D ∘ α) = α := by
+    funext x
+    exact D.symm_apply_apply (α x)
+  have hrange (z : { w : M // f w = c }) : z ∈ Set.range α ↔ D z ∈ Set.range (D ∘ α) := by
+    constructor
+    · rintro ⟨x, rfl⟩
+      exact Set.mem_range_self x
+    · rintro ⟨x, hx⟩
+      exact ⟨x, D.injective hx⟩
+  obtain ⟨z, hz⟩ := Set.ncard_eq_one.mp hsingle
+  have hzmem : z ∈ Set.range (D ∘ α) ∩ Set.range β := by
+    rw [hz]
+    exact Set.mem_singleton z
+  obtain ⟨⟨x, hx⟩, ⟨y, hy⟩⟩ := hzmem
+  have hcross : β y = (D ∘ α) x := hy.trans hx.symm
+  have hcross' : δ y = α x := by exact (congrArg D.symm hcross).trans (D.symm_apply_apply (α x))
+  have ht : Smale.NativeTransversality.At (𝓡 2) (𝓡 3) 𝓘(ℝ, Smale.RegularLevel.Model E) α δ x y := by
+    have hh :=
+      (Degree.TransverseGerms.native_transversality_partial_diffeomorph_iff
+            D.symm.toPartialDiffeomorph (hDα.mdifferentiableAt (by simp))
+            (hβ.mdifferentiableAt (by simp)) hcross (Set.mem_univ _)).mp
+        (htrans x y)
+    change
+      Smale.NativeTransversality.At (𝓡 2) (𝓡 3) 𝓘(ℝ, Smale.RegularLevel.Model E)
+        (D.symm ∘ (D ∘ α)) δ x y at hh
+    rwa [hαeq] at hh
+  have hcount :
+    {w : { z : M // f z = c } |
+          Filter.Tendsto (fun t => S.flow t w.val) Filter.atBot (𝓝 q.val) ∧
+            Filter.Tendsto (fun t => S.flow t (D w).val) Filter.atTop (𝓝 p.val)}.ncard =
+      1 := by
+    have heq :
+      {w : { z : M // f z = c } |
+          Filter.Tendsto (fun t => S.flow t w.val) Filter.atBot (𝓝 q.val) ∧
+            Filter.Tendsto (fun t => S.flow t (D w).val) Filter.atTop (𝓝 p.val)} =
+        {D.symm z} := by
+      ext w
+      change (_ ∧ _) ↔ w = D.symm z
+      rw [← hback w, ← hforward (D w), hrange w]
+      change D w ∈ Set.range (D ∘ α) ∩ Set.range β ↔ w = D.symm z
+      rw [hz, Set.mem_singleton_iff]
+      exact
+        ⟨fun h => (D.symm_apply_apply w).symm.trans (congrArg D.symm h), fun h =>
+          (congrArg D h).trans (D.apply_symm_apply z)⟩
+    rw [heq, Set.ncard_singleton]
+  have hαbasin :
+    ∀ᶠ w in 𝓝 x, Filter.Tendsto (fun t => S.flow t (α w).val) Filter.atBot (𝓝 q.val) :=
+    Filter.Eventually.of_forall (fun w => (hback (α w)).mp (Set.mem_range_self w))
+  have hδbasin :
+    ∀ᶠ w in 𝓝 y, Filter.Tendsto (fun t => S.flow t (D (δ w)).val) Filter.atTop (𝓝 p.val) := by
+    apply Filter.Eventually.of_forall
+    intro w
+    change Filter.Tendsto (fun t => S.flow t (D (D.symm (β w))).val) Filter.atTop (𝓝 p.val)
+    rw [D.apply_symm_apply]
+    exact (hforward (β w)).mp (Set.mem_range_self w)
+  obtain ⟨a, hpa, hac⟩ := exists_between hpc
+  obtain ⟨b, hcb, hbq⟩ := exists_between hcq
+  have hweightp : Fintype.card { i // (S.data p).chart.weights i = -1 } = 2 := by
+    have hh := (MorseCancel.nativeMorseIndex_eq_chart (S.data p).chart).symm.trans hp
+    simpa only [Smale.ManifoldMorse.SignedMorseChart.NegativeCoordinates,
+      Smale.MorseHandle.NegativeSpace, finrank_euclideanSpace] using hh
+  have hweightq : Fintype.card { i // (S.data q).chart.weights i = -1 } = 3 := by
+    have hh := (MorseCancel.nativeMorseIndex_eq_chart (S.data q).chart).symm.trans hq
+    simpa only [Smale.ManifoldMorse.SignedMorseChart.NegativeCoordinates,
+      Smale.MorseHandle.NegativeSpace, finrank_euclideanSpace] using hh
+  exact
+    MorseCancel.cancel_of_transverse_level_isotopy (m := 5) (S.data p).chart (S.data q).chart hf
+      hm hdim (by omega) S.field S.smooth S.zero S.descent S.flow S.integral S.distinct p.property
+      q.property (S.toSurgeryWindows.lower_lt_value p) (S.toSurgeryWindows.value_lt_upper q)
+      (MorseCancel.surgery_pair_band_isolation S.toSurgeryWindows p q hconsecutive) hac hcb hpc
+      hcq (MorseCancel.surgery_pair_inner_band_regular p q hconsecutive hpa hbq) hc
+      (S.critical_model_germ p) (S.critical_model_germ q) D hD hcount α δ x y
+      (hα.mdifferentiableAt (by simp)) (hδ.mdifferentiableAt (by simp)) hcross' ht hαbasin hδbasin
+
+private theorem MorseCancel.conjugate_level_isotopy {V H X Y : Type} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [TopologicalSpace H] {J : ModelWithCorners ℝ V H} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H Y] (e : Diffeomorph J J X Y ∞)
+    (D : Diffeomorph J J X X ∞) (hD : Smale.SupportedDiffeomorph.IsotopicToIdentity D) :
+    Smale.SupportedDiffeomorph.IsotopicToIdentity (e.symm.trans (D.trans e)) := by
+  obtain ⟨A, hA, hzero, hone, hslices⟩ := hD
+  refine
+    ⟨fun z : ℝ × Y => e (A (z.1, e.symm z.2)),
+      e.contMDiff.comp (hA.comp (contMDiff_fst.prodMk (e.symm.contMDiff.comp contMDiff_snd))), ?_,
+      ?_, ?_⟩
+  · intro y
+    change e (A (0, e.symm y)) = y
+    rw [hzero, e.apply_symm_apply]
+  · intro y
+    change e (A (1, e.symm y)) = e (D (e.symm y))
+    rw [hone]
+  · intro t
+    obtain ⟨Dt, hDt⟩ := hslices t
+    refine ⟨e.symm.trans (Dt.trans e), ?_⟩
+    intro y
+    change e (A (t, e.symm y)) = e (Dt (e.symm y))
+    rw [hDt]
+
+private theorem MorseCancel.intersection_count_under_injective_map {A B X Y : Type*} (e : X → Y)
+    (he : Function.Injective e) (α : A → X) (β : B → X) :
+    (Set.range (e ∘ α) ∩ Set.range (e ∘ β)).ncard = (Set.range α ∩ Set.range β).ncard := by
+  have hset : Set.range (e ∘ α) ∩ Set.range (e ∘ β) = e '' (Set.range α ∩ Set.range β) := by
+    ext y
+    constructor
+    · rintro ⟨⟨a, ha⟩, ⟨b, hb⟩⟩
+      have hab : α a = β b := he (ha.trans hb.symm)
+      exact ⟨α a, ⟨Set.mem_range_self a, ⟨b, hab.symm⟩⟩, ha⟩
+    · rintro ⟨x, ⟨⟨a, ha⟩, ⟨b, hb⟩⟩, hx⟩
+      exact ⟨⟨a, (congrArg e ha).trans hx⟩, ⟨b, (congrArg e hb).trans hx⟩⟩
+  rw [hset]
+  exact Set.ncard_image_of_injective _ he
+
+private theorem MorseCancel.cancel_from_preserved_unit_belt_cut {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f g : M → ℝ} (S : AdaptedWindows E f)
+    (T : AdaptedWindows E g) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g) (hmg : Smale.ManifoldMorse.IsMorse E g)
+    (hdim : Module.finrank ℝ E = 6) (p : Smale.ManifoldMorse.criticalPoints E f)
+    (hindex : Module.finrank ℝ (S.data p).chart.NegativeCoordinates = 2)
+    (hnull :
+      ∀ δ : C(Smale.Hemisphere.Sphere 1, (S.data p).LowerLevel),
+        ∃ z, δ.Homotopic (ContinuousMap.const _ z))
+    (hpcg : p.val ∈ Smale.ManifoldMorse.criticalPoints E g) (hpg : nativeMorseIndex E g p = 2)
+    (q : Smale.ManifoldMorse.criticalPoints E g) (hq : nativeMorseIndex E g q = 3)
+    (hconsecutive : ∀ z : Smale.ManifoldMorse.criticalPoints E g, ¬(g p < g z ∧ g z < g q))
+    (hpc : g p < (f p + (S.data p).radius ^ 2)) (hcq : (f p + (S.data p).radius ^ 2) < g q)
+    (hsub : ∀ y, g y ≤ (f p + (S.data p).radius ^ 2) ↔ f y ≤ (f p + (S.data p).radius ^ 2))
+    (hlevel : ∀ y, g y = (f p + (S.data p).radius ^ 2) ↔ f y = (f p + (S.data p).radius ^ 2))
+    (hga : ∀ y, g y = (f p + (S.data p).radius ^ 2) → y ∉ Smale.ManifoldMorse.criticalPoints E g)
+    (hforward :
+      ∀ y : (S.data p).UpperLevel,
+        Filter.Tendsto (fun t => T.flow t y.val) Filter.atTop (𝓝 p.val) ↔
+          Filter.Tendsto (fun t => S.flow t y.val) Filter.atTop (𝓝 p.val))
+    (γ : C((Smale.Hemisphere.Sphere 2), { y : M // g y = (f p + (S.data p).radius ^ 2) })) :
+    letI := Smale.RegularLevel.chartedSpace hg hga
+    ∀ (_ : ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ γ) (_ : Function.Injective γ)
+      (_ : ∀ x, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) γ x)),
+      (∀ y, y ∈ Set.range γ ↔ Filter.Tendsto (fun t => T.flow t y.val) Filter.atBot (𝓝 q.val)) →
+        ((S.data p).indexTwoCollapseCoordinate hf.continuous hindex
+                ((equalCutHomologyEquiv hsub).symm (middleSectionClass γ))).natAbs =
+            1 →
+          ∃ v : M → ℝ,
+            ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ v ∧
+              Smale.ManifoldMorse.IsMorse E v ∧
+                (Smale.ManifoldMorse.criticalPoints E v).ncard + 2 =
+                    (Smale.ManifoldMorse.criticalPoints E g).ncard ∧
+                  (∀ z,
+                      z ∈ Smale.ManifoldMorse.criticalPoints E v ↔
+                        z ∈ Smale.ManifoldMorse.criticalPoints E g ∧ z ≠ p.val ∧ z ≠ q.val) ∧
+                    ∀ z,
+                      g z ∉
+                          Set.Ioo (T.toSurgeryWindows.lower ⟨p.val, hpcg⟩)
+                            (T.toSurgeryWindows.upper q) →
+                        v =ᶠ[𝓝 z] g := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data p).upper_regular
+  let _ := Smale.RegularLevel.chartedSpace hg hga
+  let _ : Fact (Module.finrank ℝ (S.data p).chart.PositiveCoordinates = 3 + 1) :=
+    ⟨by have hh := (S.data p).chart.finrank_negative_add_positive; omega⟩
+  intro hγ hinj himm hback hunit
+  let e := equalLevelDiffeomorph hf hg (S.data p).upper_regular hga hlevel
+  let α : C((Smale.Hemisphere.Sphere 2), (S.data p).UpperLevel) :=
+    equalCutSection (fun y => (hlevel y).symm) γ
+  have hα : ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ α := by
+    change ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ (e.symm ∘ γ)
+    exact e.symm.contMDiff.comp hγ
+  have hαinj : Function.Injective α := e.symm.injective.comp hinj
+  have hαimm (x : (Smale.Hemisphere.Sphere 2)) :
+    Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) α x) := by
+    change Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) (e.symm ∘ γ) x)
+    rw [mfderiv_comp x (e.symm.contMDiff.mdifferentiableAt (by simp))
+        (hγ.mdifferentiableAt (by simp))]
+    exact (e.symm.mfderivToContinuousLinearEquiv (by simp) (γ x)).injective.comp (himm x)
+  have hsection : equalCutSection hlevel α = γ := rfl
+  have hclass := equalCutSection_class hsub hlevel α
+  rw [hsection] at hclass
+  have hpull : (equalCutHomologyEquiv hsub).symm (middleSectionClass γ) = middleSectionClass α := by
+    rw [← hclass, LinearEquiv.symm_apply_apply]
+  have hαunit :
+    ((S.data p).indexTwoCollapseCoordinate hf.continuous hindex (middleSectionClass α)).natAbs =
+      1 := by rwa [hpull] at hunit
+  obtain ⟨D, δ, hD, hδ, hgood, hsingle⟩ :=
+    exists_single_intersection_of_unit_coordinate (S.data p) hf hdim hindex hnull α hα hαinj hαimm
+      hαunit
+  let β₀ := (S.data p).surgery.beltSphere
+  let β := e ∘ β₀
+  have hβ₀ : ContMDiff (𝓡 3) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ β₀ := (S.data p).belt_smooth hf 3
+  have hβ : ContMDiff (𝓡 3) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ β := e.contMDiff.comp hβ₀
+  let D' := e.symm.trans (D.trans e)
+  have hD' : Smale.SupportedDiffeomorph.IsotopicToIdentity D' := conjugate_level_isotopy e D hD
+  have hDγ : D' ∘ γ = e ∘ δ := by
+    funext x
+    change e (D (α x)) = e (δ x)
+    exact congrArg e (hδ x).symm
+  have hβfull (y : { z : M // g z = (f p + (S.data p).radius ^ 2) }) :
+    y ∈ Set.range β ↔ Filter.Tendsto (fun t => T.flow t y.val) Filter.atTop (𝓝 p.val) := by
+    have hmem : y ∈ Set.range β ↔ e.symm y ∈ Set.range β₀ := by
+      constructor
+      · rintro ⟨x, hx⟩
+        exact ⟨x, e.injective (hx.trans (e.apply_symm_apply y).symm)⟩
+      · rintro ⟨x, hx⟩
+        exact ⟨x, (congrArg e hx).trans (e.apply_symm_apply y)⟩
+    rw [hmem]
+    exact (S.belt_basin_iff hf p (e.symm y)).symm.trans (hforward (e.symm y)).symm
+  have ht :
+    ∀ x y,
+      Smale.NativeTransversality.At (𝓡 2) (𝓡 3) 𝓘(ℝ, Smale.RegularLevel.Model E) (D' ∘ γ) β x y :=
+    by
+    rw [hDγ]
+    intro x y hxy
+    have hold : β₀ y = δ x := e.injective hxy
+    have hh :=
+      (Degree.TransverseGerms.native_transversality_partial_diffeomorph_iff e.toPartialDiffeomorph
+            (hgood.1.mdifferentiableAt (by simp)) (hβ₀.mdifferentiableAt (by simp)) hold
+            (Set.mem_univ _)).mp
+        (hgood.2.2.2 x y)
+    exact hh hxy
+  have hcount : (Set.range (D' ∘ γ) ∩ Set.range β).ncard = 1 := by
+    rw [hDγ]
+    exact (intersection_count_under_injective_map e e.injective δ β₀).trans hsingle
+  exact
+    T.cancel_single_basin_section_isotopy hg hmg hdim ⟨p.val, hpcg⟩ q hconsecutive hpg hq hpc hcq
+      hga γ β hγ hβ hback hβfull D' hD' ht hcount
+
+private theorem MorseCancel.consecutive_last_two_first_three {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {f g : M → ℝ} (S : Smale.ManifoldMorse.SurgeryWindows E f)
+    (p : Smale.ManifoldMorse.criticalPoints E f) (hp : nativeMorseIndex E f p = 2)
+    (hcrit : Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f)
+    (hindices :
+      ∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+        nativeMorseIndex E g z = nativeMorseIndex E f z)
+    (hfixed :
+      ∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, nativeMorseIndex E f z ≠ 3 → g z = f z)
+    (hcut :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E f, nativeMorseIndex E f z < 3 → f z < S.upper p)
+    (horder :
+      ∀ x y : Smale.ManifoldMorse.criticalPoints E g,
+        g x < g y → nativeMorseIndex E g x ≤ nativeMorseIndex E g y)
+    (q : Smale.ManifoldMorse.criticalPoints E g) (hq : nativeMorseIndex E g q = 3)
+    (hfirst :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E g,
+        nativeMorseIndex E g z = 3 → z ≠ q → g q < g z) :
+    ∀ z : Smale.ManifoldMorse.criticalPoints E g, ¬(g p < g z ∧ g z < g q) := by
+  let pg : Smale.ManifoldMorse.criticalPoints E g := ⟨p.val, hcrit.symm ▸ p.property⟩
+  have hpg : nativeMorseIndex E g pg = 2 := (hindices p p.property).trans hp
+  have hgp : g p = f p := hfixed p p.property (by omega)
+  intro z hz
+  have hle : nativeMorseIndex E g z ≤ 3 := (horder z q hz.2).trans_eq hq
+  have hge : 2 ≤ nativeMorseIndex E g z := hpg.symm.trans_le (horder pg z hz.1)
+  have hcases : nativeMorseIndex E g z = 2 ∨ nativeMorseIndex E g z = 3 := by omega
+  rcases hcases with hi2 | hi3
+  · let zf : Smale.ManifoldMorse.criticalPoints E f := ⟨z.val, hcrit ▸ z.property⟩
+    have hfidx : nativeMorseIndex E f zf = 2 := (hindices z zf.property).symm.trans hi2
+    have hgz : g z = f z := hfixed z zf.property (by change nativeMorseIndex E f zf ≠ 3; omega)
+    have hvalue : f p < f z := by
+      have hh := hz.1
+      rwa [hgp, hgz] at hh
+    have hupper : f z < S.upper p := hcut zf (by omega)
+    have heq : z.val = p.val :=
+      S.isolated p z zf.property ⟨((S.lower_lt_value p).trans hvalue).le, hupper.le⟩
+    exact hvalue.ne (congrArg f heq).symm
+  · have hne : z ≠ q := fun heq =>
+      hz.2.ne (congrArg (fun x : Smale.ManifoldMorse.criticalPoints E g => g x) heq)
+    exact (hfirst z hi3 hne).not_gt hz.2
+
+attribute [local irreducible] MorseCancel.canonicalMiddleMatrix in
+private theorem MorseCancel.cancel_from_complete_middle_family {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [PathConnectedSpace M]
+    {f : M → ℝ} (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (hdim : Module.finrank ℝ E = 6)
+    (horder :
+      ∀ x y : Smale.ManifoldMorse.criticalPoints E f,
+        f x < f y → nativeMorseIndex E f x ≤ nativeMorseIndex E f y)
+    (p : Smale.ManifoldMorse.criticalPoints E f)
+    (hindex : Module.finrank ℝ (S.data p).chart.NegativeCoordinates = 2)
+    (hnull :
+      ∀ δ : C(Smale.Hemisphere.Sphere 1, (S.data p).LowerLevel),
+        ∃ z, δ.Homotopic (ContinuousMap.const _ z))
+    (hprimitive :
+      Function.Surjective ((S.data p).indexTwoCollapseCoordinate hf.continuous hindex))
+    (hcut :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E f,
+        nativeMorseIndex E f z < 3 → f z < f p + (S.data p).radius ^ 2)
+    {r n : ℕ} (labels : Fin n → Smale.ManifoldMorse.criticalPoints E f)
+    (hlabels : ∀ j, nativeMorseIndex E f (labels j) = 3)
+    (hcomplete :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E f,
+        nativeMorseIndex E f z = 3 → ∃ j, labels j = z)
+    (hlower : ∀ j, f p + (S.data p).radius ^ 2 < S.toSurgeryWindows.lower (labels j))
+    (B :
+      (Fin r → ℤ) ≃ₗ[ℤ]
+        SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p + (S.data p).radius ^ 2 } 2)
+    (γ : Fin n → C((Smale.Hemisphere.Sphere 2), (S.data p).UpperLevel))
+    (hγ : IsNativeMiddleBasinFamily S hf (S.data p).upper_regular labels (fun j => γ j))
+    (hsurj : Function.Surjective (canonicalMiddleMatrix B γ).mulVec) :
+    ∃ v : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ v ∧
+        Smale.ManifoldMorse.IsMorse E v ∧
+          Set.InjOn v (Smale.ManifoldMorse.criticalPoints E v) ∧
+            (Smale.ManifoldMorse.criticalPoints E v).ncard + 2 =
+              (Smale.ManifoldMorse.criticalPoints E f).ncard := by
+  let c := f p + (S.data p).radius ^ 2
+  let L := (S.data p).indexTwoCollapseCoordinate hf.continuous hindex
+  have hpold : nativeMorseIndex E f p = 2 :=
+    (nativeMorseIndex_eq_chart (S.data p).chart).trans hindex
+  obtain
+    ⟨ops, -, g, hg, hmg, hcrit, hgorder, hindices, -, houtside, hgcut, hsub, hlevel, hga, T, -, -,
+      hpg, hgcomplete, hglower, Γ, hΓ, -, -, hgsurj, ⟨i, hi⟩, hkeep⟩ :=
+    S.exists_primitive_functional_unit hf hm hdim horder (S.data p).upper_regular hcut labels
+      hlabels hcomplete hlower B γ hγ hsurj L hprimitive
+  let pg : Fin n → Smale.ManifoldMorse.criticalPoints E g := fun j =>
+    ⟨(labels j).val, hcrit.symm ▸ (labels j).property⟩
+  let Bg := B.trans (equalCutHomologyEquiv hsub)
+  obtain
+    ⟨u, hu, hmu, hcu, huorder, huindices, -, huoutside, hfirst, husub, hulevel, hua, U, -, huflow,
+      -, hpu, hulower, hfamily, -, -, -⟩ :=
+    T.exists_first_middle_pivot hg hmg hga hgorder pg hpg hgcomplete hglower Bg Γ hΓ hgsurj i
+  let hcrit' := hcu.trans hcrit
+  let hsub' : ∀ y, u y ≤ c ↔ f y ≤ c := fun y => (husub y).trans (hsub y)
+  let hlevel' : ∀ y, u y = c ↔ f y = c := fun y => (hulevel y).trans (hlevel y)
+  let q : Smale.ManifoldMorse.criticalPoints E u :=
+    ⟨(labels i).val, hcrit'.symm ▸ (labels i).property⟩
+  let Δ := fun j => equalCutSection hulevel (Γ j)
+  have hids (z : M) (hz : z ∈ Smale.ManifoldMorse.criticalPoints E f) :
+    nativeMorseIndex E u z = nativeMorseIndex E f z :=
+    (huindices z (hcrit.symm ▸ hz)).trans (hindices z hz)
+  have hfixed (z : M) (hz : z ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hidx : nativeMorseIndex E f z ≠ 3) : u z = f z := by
+    have hnotlabel (j : Fin n) : z ≠ (labels j).val := by
+      intro heq
+      apply hidx
+      rw [heq]
+      exact hlabels j
+    exact (huoutside z (hcrit.symm ▸ hz) hnotlabel).trans (houtside z hz hnotlabel)
+  have hpcrit : p.val ∈ Smale.ManifoldMorse.criticalPoints E u := hcrit'.symm ▸ p.property
+  have hpnew : nativeMorseIndex E u p = 2 := (hids p p.property).trans hpold
+  have hq : nativeMorseIndex E u q = 3 := (hids (labels i) (labels i).property).trans (hlabels i)
+  have hfirstcrit (z : Smale.ManifoldMorse.criticalPoints E u) (hz : nativeMorseIndex E u z = 3)
+    (hne : z ≠ q) : u q < u z := by
+    let zf : Smale.ManifoldMorse.criticalPoints E f := ⟨z.val, hcrit' ▸ z.property⟩
+    have hzidx : nativeMorseIndex E f zf = 3 := (hids z zf.property).symm.trans hz
+    obtain ⟨j, hj⟩ := hcomplete zf hzidx
+    have hji : j ≠ i := by
+      intro hji
+      apply hne
+      apply Subtype.ext
+      exact
+        (congrArg (fun z : Smale.ManifoldMorse.criticalPoints E f => z.val) hj).symm.trans
+          (congrArg (fun k => (labels k).val) hji)
+    have hh := hfirst j hji
+    change u (labels i) < u (labels j) at hh
+    simpa only [hj] using hh
+  have hconsecutive :=
+    consecutive_last_two_first_three S.toSurgeryWindows p hpold hcrit' hids hfixed hcut huorder q
+      hq hfirstcrit
+  have hpc : u p < c := by
+    rw [hfixed p p.property (by omega)]
+    exact S.toSurgeryWindows.value_lt_upper p
+  have hcq : c < u q := (hulower i).trans (U.toSurgeryWindows.lower_lt_value q)
+  have hclass := equalCutSection_class husub hulevel (Γ i)
+  have hpull :
+    (equalCutHomologyEquiv hsub').symm (middleSectionClass (Δ i)) =
+      (equalCutHomologyEquiv hsub).symm (middleSectionClass (Γ i)) := by
+    rw [← equalCutHomologyEquiv_trans hsub husub]
+    change
+      (equalCutHomologyEquiv hsub).symm
+          ((equalCutHomologyEquiv husub).symm (middleSectionClass (Δ i))) =
+        _
+    rw [← hclass, LinearEquiv.symm_apply_apply]
+  have hunit : (L ((equalCutHomologyEquiv hsub').symm (middleSectionClass (Δ i)))).natAbs = 1 := by
+    rw [hpull]
+    rcases hi with hi | hi <;> rw [hi] <;> norm_num
+  have hforward (y : (S.data p).UpperLevel) :
+    Filter.Tendsto (fun t => U.flow t y.val) Filter.atTop (𝓝 p.val) ↔
+      Filter.Tendsto (fun t => S.flow t y.val) Filter.atTop (𝓝 p.val) := by
+    rw [huflow]
+    exact (hkeep y.val y.property.le).2.2 p.val
+  let _ := Smale.RegularLevel.chartedSpace hu hua
+  obtain ⟨v, hv, hmv, hcard, hcv, hext⟩ :=
+    cancel_from_preserved_unit_belt_cut S U hf hu hmu hdim p hindex hnull hpcrit hpnew q hq
+      hconsecutive hpc hcq hsub' hlevel' hua hforward (Δ i) (hfamily.1 i)
+      (hfamily.2.1 i).injective (hfamily.2.2.1 i) (hfamily.2.2.2.2 i) hunit
+  obtain ⟨-, hinj, -⟩ :=
+    adapted_surgeries_after_pair_removal U.toSurgeryWindows ⟨p.val, hpcrit⟩ q hconsecutive hv hmv
+      hcv hext
+  refine ⟨v, hv, hmv, hinj, ?_⟩
+  rwa [hcrit'] at hcard
+
+private theorem MorseCancel.minimal_ordered_index_two_count_zero {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [Nonempty M] [PathConnectedSpace M]
+    {f : M → ℝ} (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (hdim : Module.finrank ℝ E = 6) (e : M ≃ₕ SixSphere)
+    (horder :
+      ∀ x y : Smale.ManifoldMorse.criticalPoints E f,
+        f x < f y → nativeMorseIndex E f x ≤ nativeMorseIndex E f y)
+    (hzero : nativeMorseCount E f 0 = 1) (hone : nativeMorseCount E f 1 = 0)
+    (hminimal :
+      ∀ v : M → ℝ,
+        ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ v →
+          Smale.ManifoldMorse.IsMorse E v →
+            Set.InjOn v (Smale.ManifoldMorse.criticalPoints E v) →
+              (Smale.ManifoldMorse.criticalPoints E f).ncard ≤
+                (Smale.ManifoldMorse.criticalPoints E v).ncard) :
+    nativeMorseCount E f 2 = 0 := by
+  obtain ⟨r, n, htwo, hrc, hthree, -, hafter⟩ :=
+    exists_middle_index_blocks S.toSurgeryWindows hf hdim horder hzero hone
+  obtain ⟨hr, hn⟩ := native_middle_block_counts S.toSurgeryWindows hf r n htwo hrc hthree hafter
+  rw [hr]
+  by_contra hnot
+  have hrpos : 0 < r := Nat.pos_of_ne_zero hnot
+  obtain ⟨T, -, hradii, -, α, hα⟩ :=
+    S.exists_ordered_middle_family hf hm hdim r n hrc hthree (fun p => (S.data p).radius)
+      (fun p => (S.data p).radius_pos)
+  let q := S.toSurgeryWindows.point ⟨r, by omega⟩
+  let a := S.toSurgeryWindows.upper q
+  let p := nativeMiddleBlockPoint S r n hrc
+  have hp (j : Fin n) : nativeMorseIndex E f (p j) = 3 :=
+    (nativeMorseIndex_eq_chart (S.data (p j)).chart).trans
+      (hthree ⟨r + j.val + 1, by omega⟩ (by simp) (by dsimp; omega))
+  have hlower (j : Fin n) : a < T.toSurgeryWindows.lower (p j) := by
+    have hqj : f q < f (p j) :=
+      S.toSurgeryWindows.point_strictMono (by change r < r + j.val + 1; omega)
+    have hsep := S.separated q (p j) hqj
+    have hh :=
+      mul_pos (sub_pos.mpr (hradii (p j)))
+        (add_pos (S.data (p j)).radius_pos (T.data (p j)).radius_pos)
+    change a < f (p j) - (T.data (p j)).radius ^ 2
+    change a < f (p j) - (S.data (p j)).radius ^ 2 at hsep
+    nlinarith
+  obtain ⟨β, hβ, -, hβflow⟩ :=
+    T.exists_canonical_middle_family hf (S.data q).upper_regular p hp α hα
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data q).upper_regular
+  let γ : Fin n → C((Smale.Hemisphere.Sphere 2), { y : M // f y = a }) := fun j =>
+    ⟨β j, (hβ.1 j).continuous⟩
+  let B := S.toSurgeryWindows.indexTwoBasis hf r (by omega) htwo
+  have hsurj :=
+    canonical_middle_matrix_surjective S T hf hdim e horder hzero hone r n hr hn hrc hp hlower B γ
+      hβflow
+  obtain ⟨hindex, hprimitive, hnull, hcut, hcomplete, hbelow, δ, hδ, -, B', -, hsurj'⟩ :=
+    exists_native_belt_cut_family S T hf hdim horder hzero hone r n hr hn hrpos hrc hradii hlower
+      B γ hβ hsurj
+  obtain ⟨v, hv, hmv, hinj, hcard⟩ :=
+    cancel_from_complete_middle_family T hf hm hdim horder q hindex hnull hprimitive hcut p hp
+      hcomplete hbelow B' δ hδ hsurj'
+  have hmin := hminimal v hv hmv hinj
+  omega
+
+private theorem
+    MorseCancel.minimal_ordered_index_four_count_zero {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [Nonempty M] [PathConnectedSpace M]
+    {f : M → ℝ} (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (hdim : Module.finrank ℝ E = 6) (e : M ≃ₕ SixSphere)
+    (horder :
+      ∀ x y : Smale.ManifoldMorse.criticalPoints E f,
+        f x < f y → nativeMorseIndex E f x ≤ nativeMorseIndex E f y)
+    (hsix : nativeMorseCount E f 6 = 1) (hfive : nativeMorseCount E f 5 = 0)
+    (hminimal :
+      ∀ v : M → ℝ,
+        ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ v →
+          Smale.ManifoldMorse.IsMorse E v →
+            Set.InjOn v (Smale.ManifoldMorse.criticalPoints E v) →
+              (Smale.ManifoldMorse.criticalPoints E f).ncard ≤
+                (Smale.ManifoldMorse.criticalPoints E v).ncard) :
+    nativeMorseCount E f 4 = 0 := by
+  obtain ⟨T⟩ :=
+    nonempty_adaptedSurgeryWindows hf.neg (isMorse_neg hm)
+      (distinct_critical_values_neg S.distinct)
+  have horderN :
+    ∀ p q : Smale.ManifoldMorse.criticalPoints E (fun x => -f x),
+      -f p < -f q → nativeMorseIndex E (fun x => -f x) p ≤ nativeMorseIndex E (fun x => -f x) q :=
+    by
+    intro p q hpq
+    let pf : Smale.ManifoldMorse.criticalPoints E f :=
+      ⟨p.val, by simpa only [Smale.ManifoldMorse.criticalPoints_neg] using p.property⟩
+    let qf : Smale.ManifoldMorse.criticalPoints E f :=
+      ⟨q.val, by simpa only [Smale.ManifoldMorse.criticalPoints_neg] using q.property⟩
+    have hrev := horder qf pf (neg_lt_neg_iff.mp hpq)
+    have hp := nativeMorseIndex_neg_add (S.data pf).chart
+    have hq := nativeMorseIndex_neg_add (S.data qf).chart
+    change nativeMorseIndex E f q.val ≤ nativeMorseIndex E f p.val at hrev
+    change nativeMorseIndex E (fun x => -f x) p.val + nativeMorseIndex E f p.val = _ at hp
+    change nativeMorseIndex E (fun x => -f x) q.val + nativeMorseIndex E f q.val = _ at hq
+    omega
+  have hn6 := nativeMorseCount_neg hf hm (k := 6) (by omega)
+  have hn5 := nativeMorseCount_neg hf hm (k := 5) (by omega)
+  have hn4 := nativeMorseCount_neg hf hm (k := 4) (by omega)
+  simp only [hdim, Nat.reduceSub] at hn6 hn5 hn4
+  have hh :=
+    minimal_ordered_index_two_count_zero T hf.neg (isMorse_neg hm) hdim e horderN (hn6.trans hsix)
+      (hn5.trans hfive) (minimal_excellent_morse_neg hminimal)
+  rwa [hn4] at hh
+
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.coreBoundary_two_injective_of_upper {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    [Subsingleton
+        (SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p + d.radius ^ 2 } 3)]
+    (hf : Continuous f) : Function.Injective (d.coreBoundaryHomologyMap 2) := by
+  apply LinearMap.ker_eq_bot.mp
+  rw [← d.morse_exact_at_attachingSphere hf 2 (by norm_num)]
+  apply LinearMap.range_eq_bot.mpr
+  apply LinearMap.ext
+  intro a
+  change d.morseConnectingMap hf 2 a = 0
+  rw [Subsingleton.elim a 0, map_zero]
+
+private theorem Smale.ManifoldMorse.MorseSurgeryData.indexThreeAttaching_zsmul_eq_zero {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    [Subsingleton
+        (SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p + d.radius ^ 2 } 3)]
+    (hf : Continuous f) (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 3) (z : ℤ)
+    (hz : z • d.indexThreeAttachingClass hindex = 0) : z = 0 := by
+  have hcore : d.coreBoundaryHomologyMap 2 (z • (d.indexThreeBoundaryEquiv hindex).symm 1) = 0 := by
+    rw [map_zsmul]
+    exact hz
+  have hs : z • (d.indexThreeBoundaryEquiv hindex).symm 1 = 0 :=
+    d.coreBoundary_two_injective_of_upper hf (hcore.trans (map_zero _).symm)
+  have h := congrArg (d.indexThreeBoundaryEquiv hindex) hs
+  rw [map_zsmul, LinearEquiv.apply_symm_apply, map_zero, zsmul_eq_mul, mul_one] at h
+  simpa using h
+
+private theorem Smale.IntegerPresentation.ofEquiv_matrix_injective {B : Type*} [AddCommGroup B]
+    [Module ℤ B] {r : ℕ} (e : (Fin r → ℤ) ≃ₗ[ℤ] B) :
+    Function.Injective (ofEquiv e).matrix.mulVec := fun _ _ _ => Subsingleton.elim _ _
+
+private theorem
+    Smale.IntegerPresentation.adjoin_mulVec {B C : Type*} [AddCommGroup B] [AddCommGroup C]
+    [Module ℤ B] [Module ℤ C] {r c : ℕ} (P : Smale.IntegerPresentation B r c) (q : B →ₗ[ℤ] C)
+    (hq : Function.Surjective q) (b : B) (hker : LinearMap.ker q = Submodule.span ℤ { b })
+    (z : Fin (c + 1) → ℤ) :
+    (P.adjoin q hq b hker).matrix.mulVec z =
+      z 0 • P.liftRelation b + P.matrix.mulVec (Fin.tail z) := by
+  rw [← (P.adjoin q hq b hker).columns_sum_eq_mulVec, Fin.sum_univ_succ]
+  change z 0 • P.liftRelation b + (∑ i, z i.succ • P.columns i) = _
+  rw [P.columns_sum_eq_mulVec]
+  rfl
+
+private theorem Smale.IntegerPresentation.adjoin_coefficient {B C : Type*} [AddCommGroup B]
+    [AddCommGroup C] [Module ℤ B] [Module ℤ C] {r c : ℕ} (P : Smale.IntegerPresentation B r c)
+    (q : B →ₗ[ℤ] C) (hq : Function.Surjective q) (b : B)
+    (hker : LinearMap.ker q = Submodule.span ℤ { b }) (z : Fin (c + 1) → ℤ) :
+    P.map ((P.adjoin q hq b hker).matrix.mulVec z) = z 0 • b := by
+  rw [P.adjoin_mulVec q hq b hker, map_add, map_zsmul, P.map_liftRelation, P.matrix_relation,
+    add_zero]
+
+private theorem Smale.IntegerPresentation.adjoin_matrix_injective {B C : Type*} [AddCommGroup B]
+    [AddCommGroup C] [Module ℤ B] [Module ℤ C] {r c : ℕ} (P : Smale.IntegerPresentation B r c)
+    (q : B →ₗ[ℤ] C) (hq : Function.Surjective q) (b : B)
+    (hker : LinearMap.ker q = Submodule.span ℤ { b }) (hP : Function.Injective P.matrix.mulVec)
+    (hb : ∀ z : ℤ, z • b = 0 → z = 0) : Function.Injective (P.adjoin q hq b hker).matrix.mulVec :=
+  by
+  have hzero (z : Fin (c + 1) → ℤ) (hz : (P.adjoin q hq b hker).matrix.mulVec z = 0) : z = 0 := by
+    have hcoeff : z 0 • b = 0 :=
+      (P.adjoin_coefficient q hq b hker z).symm.trans ((congrArg P.map hz).trans (map_zero P.map))
+    have hz0 := hb (z 0) hcoeff
+    have htail : P.matrix.mulVec (Fin.tail z) = 0 := by
+      rw [P.adjoin_mulVec q hq b hker, hz0, zero_smul, zero_add] at hz
+      exact hz
+    have hzero' : P.matrix.mulVec (0 : Fin c → ℤ) = 0 := by simp
+    have ht : Fin.tail z = 0 := hP (htail.trans hzero'.symm)
+    funext i
+    exact Fin.cases hz0 (fun j => congrFun ht j) i
+  intro x y hxy
+  apply sub_eq_zero.mp
+  apply hzero (x - y)
+  rw [Matrix.mulVec_sub, hxy, sub_self]
+
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.indexThreePresentation_matrix_injective {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f)
+    (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 3)
+    [Subsingleton
+        (SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p + d.radius ^ 2 } 3)]
+    {r c : ℕ}
+    (P :
+      Smale.IntegerPresentation
+        (SingularMayerVietoris.SingularHomology { y : M // f y ≤ f p - d.radius ^ 2 } 2) r c)
+    (hP : Function.Injective P.matrix.mulVec) :
+    Function.Injective (d.indexThreePresentation hf hindex P).matrix.mulVec :=
+  P.adjoin_matrix_injective _ _ _ _ hP (d.indexThreeAttaching_zsmul_eq_zero hf hindex)
+
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.middleMatrix_injective_of_upper_third {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (r : ℕ)
+    (htwo : S.HasIndexTwoPrefix r) :
+    ∀ (c : ℕ) (hc : r + c < S.count) (hthree : S.HasIndexThreeBlock r c),
+      (∀ i : Fin S.count,
+          r < i.val →
+            i.val ≤ r + c →
+              Subsingleton
+                (SingularMayerVietoris.SingularHomology { x : M // f x ≤ S.upper (S.point i) }
+                  3)) →
+        Function.Injective (S.middleMatrix hf r c htwo hc hthree).mulVec := by
+  intro c
+  induction c with
+  | zero =>
+    intro hc hthree _
+    exact Smale.IntegerPresentation.ofEquiv_matrix_injective (S.indexTwoBasis hf r hc htwo)
+  | succ c ih =>
+    intro hc hthree hvan
+    let P :=
+      S.middlePresentation hf r htwo c (Nat.lt_of_succ_lt hc)
+        (S.indexThreeBlock_mono (Nat.le_succ c) hthree)
+    let B := S.consecutiveBandData hf ⟨r + c, Nat.lt_of_succ_lt hc⟩ ⟨r + (c + 1), hc⟩ rfl
+    have hP : Function.Injective P.matrix.mulVec :=
+      ih (Nat.lt_of_succ_lt hc) (S.indexThreeBlock_mono (Nat.le_succ c) hthree)
+        (fun i hi him => hvan i hi (him.trans (Nat.le_succ (r + c))))
+    let :
+      Subsingleton
+        (SingularMayerVietoris.SingularHomology
+          { x : M //
+            f x ≤
+              f (S.point ⟨r + (c + 1), hc⟩) + (S.data (S.point ⟨r + (c + 1), hc⟩)).radius ^ 2 }
+          3) :=
+      hvan ⟨r + (c + 1), hc⟩ (by change r < r + (c + 1); omega) le_rfl
+    exact
+      (S.data (S.point ⟨r + (c + 1), hc⟩)).indexThreePresentation_matrix_injective hf.continuous
+        (S.indexThreeBlock_last r c hc hthree) (P.transport (B.homologyEquiv 2)) hP
+
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.middleMatrix_injective_of_complete_blocks {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (hM : M ≃ₕ Smale.SixSphere) (r c : ℕ)
+    (htwo : S.HasIndexTwoPrefix r) (hc : r + c < S.count) (hthree : S.HasIndexThreeBlock r c)
+    (hcount : r + c + 2 = S.count) :
+    Function.Injective (S.middleMatrix hf r c htwo hc hthree).mulVec := by
+  apply S.middleMatrix_injective_of_upper_third hf r htwo c hc hthree
+  intro i hri hic
+  have hi : i.val + 1 < S.count := by omega
+  apply
+    S.upper_homology_subsingleton_of_later_indices hf hdim hM i hi 3 (by norm_num) (by norm_num)
+  intro j hij hj
+  have h3 := hthree j (hri.trans hij) (by omega)
+  exact ⟨by omega, by omega⟩
+
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.middleMatrix_bijective_of_complete_blocks {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (hM : M ≃ₕ Smale.SixSphere) (r c : ℕ)
+    (htwo : S.HasIndexTwoPrefix r) (hc : r + c < S.count) (hthree : S.HasIndexThreeBlock r c)
+    (hcount : r + c + 2 = S.count) :
+    Function.Bijective (S.middleMatrix hf r c htwo hc hthree).mulVec :=
+  ⟨S.middleMatrix_injective_of_complete_blocks hf hdim hM r c htwo hc hthree hcount,
+    S.middleMatrix_surjective_of_complete_blocks hf hdim hM r c htwo hc hthree hcount⟩
+
+public
+theorem Smale.HomologyTransport.matrix_sizes_eq_of_bijective {R : Type*} [CommRing R]
+     [StrongRankCondition R] {r c : ℕ} (A : Matrix (Fin r) (Fin c) R)
+    (hA : Function.Bijective A.mulVec) : c = r := by
+  let e := LinearEquiv.ofBijective A.mulVecLin hA
+  simpa using e.finrank_eq
+
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.middle_counts_equal {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (hM : M ≃ₕ Smale.SixSphere) (r c : ℕ)
+    (htwo : S.HasIndexTwoPrefix r) (hc : r + c < S.count) (hthree : S.HasIndexThreeBlock r c)
+    (hcount : r + c + 2 = S.count) : r = c :=
+  (Smale.HomologyTransport.matrix_sizes_eq_of_bijective (S.middleMatrix hf r c htwo hc hthree)
+      (S.middleMatrix_bijective_of_complete_blocks hf hdim hM r c htwo hc hthree hcount)).symm
+
+private theorem MorseCancel.native_index_excluded_of_count_zero {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+        {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) {k : ℕ} (hcount : nativeMorseCount E f k = 0) :
+    ∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, nativeMorseIndex E f z ≠ k := by
+  have hfinite :
+    {z : M | z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ nativeMorseIndex E f z = k}.Finite :=
+    S.finite.subset (fun _ hz => hz.1)
+  have hempty :
+    {z : M | z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ nativeMorseIndex E f z = k} = ∅ :=
+    (Set.ncard_eq_zero hfinite).mp hcount
+  intro z hz hi
+  have hmem :
+    z ∈ {z : M | z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ nativeMorseIndex E f z = k} :=
+    ⟨hz, hi⟩
+  rw [hempty] at hmem
+  exact hmem
+
+private theorem
+    MorseCancel.middle_blocks_complete_of_no_four_five {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] [Nonempty M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (r n : ℕ) (htwo : S.HasIndexTwoPrefix r)
+    (hrc : r + n < S.count) (hthree : S.HasIndexThreeBlock r n)
+    (hafter :
+      ∀ i : Fin S.count,
+        r + n < i.val → 4 ≤ Module.finrank ℝ (S.data (S.point i)).chart.NegativeCoordinates)
+    (hsix : nativeMorseCount E f 6 = 1) (hfour : nativeMorseCount E f 4 = 0)
+    (hfive : nativeMorseCount E f 5 = 0) : r + n + 2 = S.count := by
+  have hpos := S.count_pos hf
+  have hidx (i : Fin S.count) :
+    nativeMorseIndex E f (S.point i) = 6 ↔ r + n + 1 ≤ i.val ∧ i.val < S.count := by
+    have hle : nativeMorseIndex E f (S.point i) ≤ 6 := by
+      simpa only [hdim] using (nativeMorseIndex_le (E := E) (f := f) (p := (S.point i).val))
+    have hne4 := native_index_excluded_of_count_zero S hfour _ (S.point i).property
+    have hne5 := native_index_excluded_of_count_zero S hfive _ (S.point i).property
+    by_cases ha : r + n < i.val
+    · have hh := hafter i ha
+      rw [← nativeMorseIndex_eq_chart (S.data (S.point i)).chart] at hh
+      have hi := i.isLt
+      omega
+    · have hh : nativeMorseIndex E f (S.point i) ≤ 3 := by
+        by_cases hz : i.val = 0
+        · have he : i = ⟨0, hpos⟩ := Fin.ext hz
+          have hzidx : nativeMorseIndex E f (S.point i) = 0 := by
+            rw [he]
+            exact
+              (nativeMorseIndex_eq_chart (S.data (S.first hpos)).chart).trans
+                (S.first_index_zero hf hpos)
+          omega
+        · by_cases hr : i.val ≤ r
+          · rw [nativeMorseIndex_eq_chart (S.data (S.point i)).chart, htwo i (by omega) hr]
+            omega
+          · rw [nativeMorseIndex_eq_chart (S.data (S.point i)).chart,
+              hthree i (by omega) (by omega)]
+      omega
+  have hcount :=
+    nativeMorseCount_eq_interval_length S 6 (r + n + 1) S.count (by omega) le_rfl hidx
+  omega
+
+private theorem MorseCancel.ordered_no_middle_indices_count_two {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [Nonempty M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (e : M ≃ₕ SixSphere)
+    (horder :
+      ∀ x y : Smale.ManifoldMorse.criticalPoints E f,
+        f x < f y → nativeMorseIndex E f x ≤ nativeMorseIndex E f y)
+    (hzero : nativeMorseCount E f 0 = 1) (hsix : nativeMorseCount E f 6 = 1)
+    (hone : nativeMorseCount E f 1 = 0) (htwo : nativeMorseCount E f 2 = 0)
+    (hfour : nativeMorseCount E f 4 = 0) (hfive : nativeMorseCount E f 5 = 0) :
+    nativeMorseCount E f 3 = 0 ∧ S.count = 2 := by
+  obtain ⟨r, n, hprefix, hrc, hblock, -, hafter⟩ :=
+    exists_middle_index_blocks S hf hdim horder hzero hone
+  obtain ⟨hr, hn⟩ := native_middle_block_counts S hf r n hprefix hrc hblock hafter
+  have hcount :=
+    middle_blocks_complete_of_no_four_five S hf hdim r n hprefix hrc hblock hafter hsix hfour
+      hfive
+  have heq := S.middle_counts_equal hf hdim e r n hprefix hrc hblock hcount
+  omega
+
+private def Smale.negLevelHomeomorph {M : Type*} [TopologicalSpace M] (f : M → ℝ) (a : ℝ) :
+    { x : M // -f x = -a } ≃ₜ { x : M // f x = a }
+    where
+  toFun x := ⟨x.1, neg_inj.mp x.2⟩
+  invFun x := ⟨x.1, congrArg Neg.neg x.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := continuous_subtype_val.subtype_mk _
+  continuous_invFun := continuous_subtype_val.subtype_mk _
+
+private def
+    Smale.twoDiskDecompositionOfSublevels {M : Type*} [TopologicalSpace M] [T2Space M] {n : ℕ}
+    {f : M → ℝ} {a : ℝ} (L : SublevelDisk n f a) (R : SublevelDisk n (fun x => -f x) (-a)) :
+    TwoDiskDecomposition n M := by
+  let B := L.boundaryHomeomorph
+  let C := R.boundaryHomeomorph.trans (negLevelHomeomorph f a)
+  let e := B.trans C.symm
+  refine
+    { boundaryEquiv := e
+      left := L.map
+      right := R.map
+      left_injective := L.map_injective
+      right_injective := R.map_injective
+      covers := ?_
+      overlap := ?_ }
+  · intro y
+    by_cases hy : f y ≤ a
+    · left
+      exact
+        ⟨L.homeomorph.symm ⟨y, hy⟩, congrArg Subtype.val (L.homeomorph.apply_symm_apply ⟨y, hy⟩)⟩
+    · right
+      have hy' : -f y ≤ -a := neg_le_neg (le_of_not_ge hy)
+      exact
+        ⟨R.homeomorph.symm ⟨y, hy'⟩,
+          congrArg Subtype.val (R.homeomorph.apply_symm_apply ⟨y, hy'⟩)⟩
+  · intro x y
+    constructor
+    · intro h
+      have hL : f (L.map x) ≤ a := (L.homeomorph x).2
+      have hR : -f (R.map y) ≤ -a := (R.homeomorph y).2
+      have hxlevel : f (L.map x) = a := by rw [← h] at hR; linarith
+      have hylevel : -f (R.map y) = -a := by rw [← h, hxlevel]
+      have hxnorm := (L.boundary_iff x).mp hxlevel
+      have hynorm := (R.boundary_iff y).mp hylevel
+      let z : DiskDouble.Boundary (Hemisphere.Ambient n) :=
+        ⟨x.1, mem_sphere_zero_iff_norm.mpr hxnorm⟩
+      let w : DiskDouble.Boundary (Hemisphere.Ambient n) :=
+        ⟨y.1, mem_sphere_zero_iff_norm.mpr hynorm⟩
+      have hbc : B z = C w := Subtype.ext h
+      have hew : e z = w := by
+        apply C.injective
+        change C (C.symm (B z)) = C w
+        rw [C.apply_symm_apply]
+        exact hbc
+      refine ⟨z, rfl, ?_⟩
+      rw [hew]
+      rfl
+    · rintro ⟨z, rfl, rfl⟩
+      have heq := congrArg Subtype.val (C.apply_symm_apply (B z))
+      exact heq.symm
+
+private def
+    Smale.homeomorphSphereOfSublevelDisks {M : Type*} [TopologicalSpace M] [T2Space M] {n : ℕ}
+    {f : M → ℝ} {a : ℝ} (L : SublevelDisk n f a) (R : SublevelDisk n (fun x => -f x) (-a)) :
+    M ≃ₜ Hemisphere.Sphere n :=
+  (twoDiskDecompositionOfSublevels L R).homeomorphSphere
+
+private theorem Smale.ManifoldMorse.nonempty_homeomorphSphere_of_two_critical_points {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : IsMorse E f) {p q : M} (hpq : f p < f q)
+    (hcrit : criticalPoints E f = { p, q }) :
+    Nonempty (M ≃ₜ Smale.Hemisphere.Sphere (Module.finrank ℝ E)) := by
+  have hcover : ∀ x ∈ criticalPoints E f, x = p ∨ x = q := by
+    intro x hx
+    rw [hcrit] at hx
+    simpa only [Set.mem_insert_iff, Set.mem_singleton_iff] using hx
+  have hp : p ∈ criticalPoints E f := by rw [hcrit]; simp
+  have hq : q ∈ criticalPoints E f := by rw [hcrit]; simp
+  obtain ⟨hmin, hmax⟩ := unique_extrema_of_two_critical_values hf hpq hcover
+  obtain ⟨cp⟩ := nonempty_signedMorseChart hf hm p hp
+  obtain ⟨cq⟩ := nonempty_signedMorseChart hf hm q hq
+  let a := (f p + f q) / 2
+  have hpa : f p < a := by dsimp [a]; linarith
+  have haq : a < f q := by dsimp [a]; linarith
+  have hregularL : ∀ x, f p < f x → f x ≤ a → x ∉ criticalPoints E f := by
+    intro x hxlo hxhi hxcrit
+    rcases hcover x hxcrit with h | h
+    · rw [h] at hxlo
+      exact lt_irrefl _ hxlo
+    · rw [h] at hxhi
+      exact not_le_of_gt haq hxhi
+  obtain ⟨L⟩ := cp.nonempty_sublevelDisk_before_next_critical hf hmin hpa hregularL
+  have hminNeg : ∀ x, -f x ≤ -f q → x = q := fun x hx => hmax x (neg_le_neg_iff.mp hx)
+  have hregularR : ∀ x, -f q < -f x → -f x ≤ -a → x ∉ criticalPoints E (fun y => -f y) := by
+    intro x hxlo hxhi hxcrit
+    have hxcrit' : x ∈ criticalPoints E f := by
+      rw [← criticalPoints_neg (E := E) f]
+      exact hxcrit
+    rcases hcover x hxcrit' with h | h
+    · rw [h] at hxhi
+      linarith
+    · rw [h] at hxlo
+      exact lt_irrefl _ hxlo
+  obtain ⟨R⟩ :=
+    cq.neg.nonempty_sublevelDisk_before_next_critical hf.neg hminNeg (neg_lt_neg haq) hregularR
+  exact ⟨Smale.homeomorphSphereOfSublevelDisks L R⟩
+
+private theorem MorseCancel.critical_pair_of_surgery_count_two {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+       {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hcount : S.count = 2) :
+    ∃ p q : M, f p < f q ∧ Smale.ManifoldMorse.criticalPoints E f = { p, q } := by
+  let p := S.point ⟨0, by omega⟩
+  let q := S.point ⟨1, by omega⟩
+  refine ⟨p.val, q.val, S.point_strictMono (by change (0 : ℕ) < 1; omega), ?_⟩
+  ext z
+  constructor
+  · intro hz
+    obtain ⟨i, hi⟩ := S.point.surjective ⟨z, hz⟩
+    have hib := i.isLt
+    have hcases : i.val = 0 ∨ i.val = 1 := by omega
+    rcases hcases with hzero | hone
+    · have he : i = ⟨0, by omega⟩ := Fin.ext hzero
+      have hv := congrArg (fun x : Smale.ManifoldMorse.criticalPoints E f => x.val) hi
+      rw [he] at hv
+      exact Set.mem_insert_iff.mpr (Or.inl hv.symm)
+    · have he : i = ⟨1, by omega⟩ := Fin.ext hone
+      have hv := congrArg (fun x : Smale.ManifoldMorse.criticalPoints E f => x.val) hi
+      rw [he] at hv
+      exact Set.mem_insert_iff.mpr (Or.inr (Set.mem_singleton_iff.mpr hv.symm))
+  · intro hz
+    rcases Set.mem_insert_iff.mp hz with hp | hq
+    · exact hp ▸ p.property
+    · exact (Set.mem_singleton_iff.mp hq) ▸ q.property
+
+private theorem
+    MorseCancel.exists_two_critical_point_morse_of_homotopySixSphere (E : Type) (M : Type)
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    (hdim : Module.finrank ℝ E = 6) (e : M ≃ₕ SixSphere) :
+    ∃ f : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f ∧
+        Smale.ManifoldMorse.IsMorse E f ∧
+          ∃ p q : M, f p < f q ∧ Smale.ManifoldMorse.criticalPoints E f = { p, q } := by
+  let _ := Smale.pathConnectedSpace_of_homotopySixSphere e
+  obtain ⟨f, hf, hm, S, horder, hzero, hsix, hone, hfive, hminimal⟩ :=
+    exists_minimal_ordered_morse_system_without_outer_indices E M e hdim
+  have htwo := minimal_ordered_index_two_count_zero S hf hm hdim e horder hzero hone hminimal
+  have hfour := minimal_ordered_index_four_count_zero S hf hm hdim e horder hsix hfive hminimal
+  obtain ⟨-, hcount⟩ :=
+    ordered_no_middle_indices_count_two S.toSurgeryWindows hf hdim e horder hzero hsix hone htwo
+      hfour hfive
+  exact ⟨f, hf, hm, critical_pair_of_surgery_count_two S.toSurgeryWindows hcount⟩
+
+private theorem MorseCancel.nonempty_homeomorph_of_homotopySixSphere (E : Type) (M : Type)
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    (hdim : Module.finrank ℝ E = 6) (e : M ≃ₕ SixSphere) : Nonempty (M ≃ₜ SixSphere) := by
+  obtain ⟨f, hf, hm, p, q, hpq, hcrit⟩ :=
+    exists_two_critical_point_morse_of_homotopySixSphere E M hdim e
+  have hh := Smale.ManifoldMorse.nonempty_homeomorphSphere_of_two_critical_points hf hm hpq hcrit
+  change Nonempty (M ≃ₜ Smale.Hemisphere.Sphere (Module.finrank ℝ E)) at hh
+  rw [hdim] at hh
+  exact hh
+
+private theorem Smale.homeomorphic_sixSphere_of_homotopySixSphere (E : Type) [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] (M : Type) [TopologicalSpace M] [T2Space M]
+     [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M]
+    (hdim : Module.finrank ℝ E = 6) (hM : M ≃ₕ Smale.SixSphere) :
+    Nonempty (M ≃ₜ Smale.SixSphere) :=
+  MorseCancel.nonempty_homeomorph_of_homotopySixSphere E M hdim hM
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Recognition/Smale2.lean b/LeanPool/HopfProblem/Recognition/Smale2.lean
new file mode 100644
index 000000000..46fe467d7
--- /dev/null
+++ b/LeanPool/HopfProblem/Recognition/Smale2.lean
@@ -0,0 +1,5678 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.CuspFibre.CuspPositiveRetraction
+import all LeanPool.HopfProblem.Foundations.LineBundleTransport
+import all LeanPool.HopfProblem.Recognition.Smale1
+import all LeanPool.HopfProblem.CuspFibre.CuspPositiveRetraction
+import all Mathlib.Analysis.InnerProductSpace.Adjoint
+import all Mathlib.Geometry.Manifold.SmoothApprox
+
+/-!
+# Hopf problem: recognition · smale 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem Smale.FlowConstruction.forwardInvariant_of_local {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {A : Set X} (hA : IsClosed A)
+    (hlocal : ∀ x ∈ A, ∃ ε > (0 : ℝ), ∀ t ∈ Set.Icc 0 ε, F t x ∈ A) :
+    ∀ x ∈ A, ∀ t : ℝ, 0 ≤ t → F t x ∈ A := by
+  intro x hx T hT
+  let S : Set ℝ := {t | F t x ∈ A}
+  have hS : IsClosed S := hA.preimage (F.continuous continuous_id continuous_const)
+  have hzero : (0 : ℝ) ∈ S := by simpa only [S, Set.mem_ofPred_eq, F.map_zero_apply] using hx
+  apply (hS.inter isClosed_Icc).mem_of_ge_of_forall_exists_gt hzero hT
+  intro s hs
+  obtain ⟨ε, hε, hstay⟩ := hlocal (F s x) hs.1
+  let δ := Min.min ε (T - s) / 2
+  have hδ : 0 < δ := half_pos (lt_min hε (sub_pos.mpr hs.2.2))
+  have hδε : δ ≤ ε :=
+    (half_le_self (le_of_lt (lt_min hε (sub_pos.mpr hs.2.2)))).trans (min_le_left _ _)
+  have hδT : δ ≤ T - s :=
+    (half_le_self (le_of_lt (lt_min hε (sub_pos.mpr hs.2.2)))).trans (min_le_right _ _)
+  refine ⟨s + δ, ?_, by linarith, by linarith⟩
+  change F (s + δ) x ∈ A
+  rw [add_comm s δ, F.map_add]
+  exact hstay δ ⟨hδ.le, hδε⟩
+
+private theorem Smale.FlowConstruction.forwardInvariant_interior {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {A : Set X} (hforward : ∀ x ∈ A, ∀ t : ℝ, 0 ≤ t → F t x ∈ A) {x : X}
+    (hx : x ∈ interior A) {t : ℝ} (ht : 0 ≤ t) : F t x ∈ interior A := by
+  apply mem_interior.mpr
+  refine ⟨F t '' interior A, ?_, (F.toHomeomorph t).isOpenMap _ isOpen_interior, ?_⟩
+  · rintro _ ⟨y, hy, rfl⟩
+    exact hforward y (interior_subset hy) t ht
+  · exact ⟨x, hx, rfl⟩
+
+private theorem Smale.FlowConstruction.interior_entry_of_local {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {A : Set X} (hforward : ∀ x ∈ A, ∀ t : ℝ, 0 ≤ t → F t x ∈ A)
+    (hlocal : ∀ x ∈ A, ∃ ε > (0 : ℝ), ∀ t ∈ Set.Ioc 0 ε, F t x ∈ interior A) :
+    ∀ x ∈ A, ∀ t : ℝ, 0 < t → F t x ∈ interior A := by
+  intro x hx t ht
+  obtain ⟨ε, hε, hentry⟩ := hlocal x hx
+  let δ := Min.min ε t / 2
+  have hδ : 0 < δ := half_pos (lt_min hε ht)
+  have hδε : δ ≤ ε := (half_le_self (le_of_lt (lt_min hε ht))).trans (min_le_left _ _)
+  have hδt : δ ≤ t := (half_le_self (le_of_lt (lt_min hε ht))).trans (min_le_right _ _)
+  have hi := forwardInvariant_interior F hforward (hentry δ ⟨hδ, hδε⟩) (sub_nonneg.mpr hδt)
+  rw [← F.map_add, sub_add_cancel] at hi
+  exact hi
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.exists_local_attachingUnion_entry {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    {x : M} (hx : x ∈ c.splitChart.source) (heq : ∀ᶠ y in 𝓝 x, V y = c.descentField y)
+    (hAx : x ∈ {y | f y ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock)) :
+    ∃ ε > (0 : ℝ),
+      ∀ t ∈ Set.Ioc 0 ε,
+        F t x ∈
+          interior ({y | f y ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock)) := by
+  let e := c.splitChart.toOpenPartialHomeomorph
+  have hmodel := (c.mem_attachingUnion_iff_model ρ hρ hblock hx).mp hAx
+  have hαc : Continuous (fun t : ℝ => Smale.MorseHandle.descentFlow t (c.splitChart x)) :=
+    Smale.MorseHandle.descentFlow.continuous continuous_id continuous_const
+  have hα₀ : Smale.MorseHandle.descentFlow 0 (c.splitChart x) = e x :=
+    Smale.MorseHandle.descentFlow.map_zero_apply _
+  have htarget : ∀ᶠ t in 𝓝 (0 : ℝ), Smale.MorseHandle.descentFlow t (c.splitChart x) ∈ e.target :=
+    hαc.continuousAt.preimage_mem_nhds (e.open_target.mem_nhds (hα₀ ▸ e.map_source hx))
+  have hFc : Continuous (fun t : ℝ => F t x) := F.continuous continuous_id continuous_const
+  have hsource : ∀ᶠ t in 𝓝 (0 : ℝ), F t x ∈ e.source :=
+    hFc.continuousAt.preimage_mem_nhds
+      (e.open_source.mem_nhds
+        (by
+          rw [F.map_zero_apply]
+          exact hx))
+  have heqF := c.eventually_flow_eq_descentModel hV F hcurve hx heq
+  obtain ⟨ε, hε, hεall⟩ := Metric.eventually_nhds_iff.mp ((heqF.and htarget).and hsource)
+  refine ⟨ε / 2, half_pos hε, ?_⟩
+  intro t ht
+  have hdist : Dist.dist t (0 : ℝ) < ε := by
+    rw [Real.dist_eq, sub_zero, abs_of_pos ht.1]
+    linarith [ht.2]
+  obtain ⟨⟨heqt, htar⟩, hsrc⟩ := hεall hdist
+  apply c.mem_interior_attachingUnion_of_model ρ hρ hblock hsrc
+  have hcoord : c.splitChart (F t x) = Smale.MorseHandle.descentFlow t (c.splitChart x) := by
+    rw [heqt]
+    exact e.right_inv htar
+  rw [hcoord]
+  exact Smale.MorseHandle.descentFlow_mem_interior_lower_union_handle hρ ht.1 hmodel
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.forwardInvariant_attachingUnion {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) [T2Space M] (hf : Continuous f)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hmono : ∀ x, Antitone (fun t => f (F t x))) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (hagreement :
+      ∀ x ∈ Set.range (c.attachingHandleMap ρ hρ hblock), ∀ᶠ y in 𝓝 x, V y = c.descentField y) :
+    ∀ x ∈ {y | f y ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock),
+      ∀ t : ℝ,
+        0 ≤ t → F t x ∈ {y | f y ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock) := by
+  apply
+    Smale.FlowConstruction.forwardInvariant_of_local F
+      ((isClosed_le hf continuous_const).union
+        (c.attachingHandleMap_isClosedEmbedding ρ hρ hblock).isClosed_range)
+  intro x hx
+  rcases hx with hx | hx
+  · refine ⟨1, zero_lt_one, ?_⟩
+    intro t ht
+    left
+    have hle : f (F t x) ≤ f x := by simpa only [F.map_zero_apply] using hmono x ht.1
+    exact hle.trans hx
+  · have hxsource : x ∈ c.splitChart.source := by
+      obtain ⟨z, rfl⟩ := hx
+      exact
+        c.splitChart.toOpenPartialHomeomorph.map_target
+          (hblock (Smale.MorseHandle.modelMap_mem_product hρ z))
+    obtain ⟨ε, hε, hentry⟩ :=
+      c.exists_local_attachingUnion_entry hV F hcurve ρ hρ hblock hxsource (hagreement x hx)
+        (Or.inr hx)
+    refine ⟨ε, hε, ?_⟩
+    intro t ht
+    rcases ht.1.eq_or_lt with hzero | hpos
+    · rw [← hzero, F.map_zero_apply]
+      exact Or.inr hx
+    · exact interior_subset (hentry t ⟨hpos, ht.2⟩)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.interior_entry_attachingUnion {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) [T2Space M] (hf : Continuous f)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hmono : ∀ x, Antitone (fun t => f (F t x))) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (hagreement :
+      ∀ x ∈ Set.range (c.attachingHandleMap ρ hρ hblock), ∀ᶠ y in 𝓝 x, V y = c.descentField y)
+    (hbottom : ∀ x, f x = f p - ρ ^ 2 → ∀ t : ℝ, 0 < t → f (F t x) < f x) :
+    ∀ x ∈ {y | f y ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock),
+      ∀ t : ℝ,
+        0 < t →
+          F t x ∈
+            interior ({y | f y ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock)) := by
+  apply
+    Smale.FlowConstruction.interior_entry_of_local F
+      (c.forwardInvariant_attachingUnion hf hV F hcurve hmono ρ hρ hblock hagreement)
+  intro x hx
+  rcases hx with hx | hx
+  · refine ⟨1, zero_lt_one, ?_⟩
+    intro t ht
+    have hlow : f (F t x) < f p - ρ ^ 2 := by
+      change f x ≤ f p - ρ ^ 2 at hx
+      rcases lt_or_eq_of_le hx with hlt | heq
+      · have hle : f (F t x) ≤ f x := by simpa only [F.map_zero_apply] using hmono x ht.1.le
+        exact hle.trans_lt hlt
+      · exact (hbottom x heq t ht.1).trans_le hx
+    apply mem_interior.mpr
+    exact
+      ⟨{y | f y < f p - ρ ^ 2}, fun y hy => Or.inl (show f y ≤ f p - ρ ^ 2 from le_of_lt hy),
+        isOpen_lt hf continuous_const, hlow⟩
+  · have hxsource : x ∈ c.splitChart.source := by
+      obtain ⟨z, rfl⟩ := hx
+      exact
+        c.splitChart.toOpenPartialHomeomorph.map_target
+          (hblock (Smale.MorseHandle.modelMap_mem_product hρ z))
+    exact
+      c.exists_local_attachingUnion_entry hV F hcurve ρ hρ hblock hxsource (hagreement x hx)
+        (Or.inr hx)
+
+private def
+    Smale.FlowConstruction.entryTime {X : Type*} [TopologicalSpace X] (F : Flow ℝ X) (A : Set X)
+    (x : X) : ℝ :=
+  InfSet.sInf {t : ℝ | 0 ≤ t ∧ F t x ∈ A}
+
+private theorem
+    Smale.FlowConstruction.entryTime_nonneg {X : Type*} [TopologicalSpace X] (F : Flow ℝ X)
+    {A : Set X} {x : X} (hx : ∃ t : ℝ, 0 ≤ t ∧ F t x ∈ A) : 0 ≤ entryTime F A x :=
+  le_csInf hx (fun _ ht => ht.1)
+
+private theorem
+    Smale.FlowConstruction.entryTime_le_of_mem {X : Type*} [TopologicalSpace X] (F : Flow ℝ X)
+    {A : Set X} {x : X} {t : ℝ} (ht : 0 ≤ t) (hx : F t x ∈ A) : entryTime F A x ≤ t :=
+  csInf_le ⟨0, fun _ hs => hs.1⟩ ⟨ht, hx⟩
+
+private theorem
+    Smale.FlowConstruction.flow_entryTime_mem {X : Type*} [TopologicalSpace X] (F : Flow ℝ X)
+    {A : Set X} (hA : IsClosed A) {x : X} (hx : ∃ t : ℝ, 0 ≤ t ∧ F t x ∈ A) :
+    F (entryTime F A x) x ∈ A := by
+  have hclosed : IsClosed {t : ℝ | 0 ≤ t ∧ F t x ∈ A} :=
+    isClosed_Ici.inter (hA.preimage (F.continuous continuous_id continuous_const))
+  exact (hclosed.csInf_mem hx ⟨0, fun _ hs => hs.1⟩).2
+
+private theorem
+    Smale.FlowConstruction.entryTime_eq_zero {X : Type*} [TopologicalSpace X] (F : Flow ℝ X)
+    {A : Set X} {x : X} (hx : x ∈ A) : entryTime F A x = 0 := by
+  have hhit : F 0 x ∈ A := by simpa only [F.map_zero_apply] using hx
+  exact le_antisymm (entryTime_le_of_mem F le_rfl hhit) (entryTime_nonneg F ⟨0, le_rfl, hhit⟩)
+
+private theorem
+    Smale.FlowConstruction.entryTime_le_iff {X : Type*} [TopologicalSpace X] (F : Flow ℝ X)
+    {A : Set X} (hA : IsClosed A) (hforward : ∀ x ∈ A, ∀ t : ℝ, 0 ≤ t → F t x ∈ A) {x : X}
+    (hx : ∃ t : ℝ, 0 ≤ t ∧ F t x ∈ A) {t : ℝ} (ht : 0 ≤ t) : entryTime F A x ≤ t ↔ F t x ∈ A := by
+  constructor
+  · intro h
+    have hh := hforward _ (flow_entryTime_mem F hA hx) (t - entryTime F A x) (sub_nonneg.mpr h)
+    rw [← F.map_add, sub_add_cancel] at hh
+    exact hh
+  · exact entryTime_le_of_mem F ht
+
+private theorem
+    Smale.FlowConstruction.flow_mem_interior_of_entryTime_lt {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {A : Set X} (hA : IsClosed A)
+    (hentry : ∀ x ∈ A, ∀ t : ℝ, 0 < t → F t x ∈ interior A) {x : X}
+    (hx : ∃ t : ℝ, 0 ≤ t ∧ F t x ∈ A) {t : ℝ} (ht : entryTime F A x < t) : F t x ∈ interior A := by
+  have hh := hentry _ (flow_entryTime_mem F hA hx) (t - entryTime F A x) (sub_pos.mpr ht)
+  rw [← F.map_add, sub_add_cancel] at hh
+  exact hh
+
+private theorem
+    Smale.FlowConstruction.entryTime_eq_of_flow_mem_frontier {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {A : Set X} (hA : IsClosed A)
+    (hentry : ∀ x ∈ A, ∀ t : ℝ, 0 < t → F t x ∈ interior A) {x : X} {t : ℝ} (ht : 0 ≤ t)
+    (hfront : F t x ∈ frontier A) : entryTime F A x = t := by
+  have hmem : F t x ∈ A := by simpa only [hA.closure_eq] using frontier_subset_closure hfront
+  apply le_antisymm (entryTime_le_of_mem F ht hmem)
+  apply le_of_not_gt
+  intro hlt
+  exact hfront.2 (flow_mem_interior_of_entryTime_lt F hA hentry ⟨t, ht, hmem⟩ hlt)
+
+private theorem Smale.FlowConstruction.continuousOn_entryTime {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {A : Set X} (hA : IsClosed A) (hforward : ∀ x ∈ A, ∀ t : ℝ, 0 ≤ t → F t x ∈ A)
+    (hentry : ∀ x ∈ A, ∀ t : ℝ, 0 < t → F t x ∈ interior A) {B : Set X}
+    (hhit : ∀ x ∈ B, ∃ t : ℝ, 0 ≤ t ∧ F t x ∈ A) : ContinuousOn (entryTime F A) B := by
+  intro x hx
+  apply tendsto_order.mpr
+  constructor
+  · intro a ha
+    by_cases hneg : a < 0
+    · filter_upwards [self_mem_nhdsWithin] with y hy
+      exact hneg.trans_le (entryTime_nonneg F (hhit y hy))
+    · have ha₀ : 0 ≤ a := le_of_not_gt hneg
+      have hnot : F a x ∉ A := fun h => not_le_of_gt ha (entryTime_le_of_mem F ha₀ h)
+      have hevent : ∀ᶠ y in 𝓝 x, F a y ∉ A :=
+        (F.continuous continuous_const continuous_id).continuousAt.preimage_mem_nhds
+          (hA.isOpen_compl.mem_nhds hnot)
+      filter_upwards [self_mem_nhdsWithin, eventually_nhdsWithin_of_eventually_nhds hevent] with y
+        hy hya
+      apply lt_of_not_ge
+      intro hle
+      exact hya ((entryTime_le_iff F hA hforward (hhit y hy) ha₀).mp hle)
+  · intro b hb
+    obtain ⟨t, hxt, htb⟩ := exists_between hb
+    have ht₀ : 0 ≤ t := (entryTime_nonneg F (hhit x hx)).trans hxt.le
+    have hi := flow_mem_interior_of_entryTime_lt F hA hentry (hhit x hx) hxt
+    have hevent : ∀ᶠ y in 𝓝 x, F t y ∈ interior A :=
+      (F.continuous continuous_const continuous_id).continuousAt.preimage_mem_nhds
+        (isOpen_interior.mem_nhds hi)
+    filter_upwards [eventually_nhdsWithin_of_eventually_nhds hevent] with y hy
+    exact (entryTime_le_of_mem F ht₀ (interior_subset hy)).trans_lt htb
+
+private def Smale.FlowConstruction.entryRetraction {X : Type*} [TopologicalSpace X] (F : Flow ℝ X)
+    {A B : Set X} (hA : IsClosed A) (hforward : ∀ x ∈ A, ∀ t : ℝ, 0 ≤ t → F t x ∈ A)
+    (hentry : ∀ x ∈ A, ∀ t : ℝ, 0 < t → F t x ∈ interior A)
+    (hhit : ∀ x ∈ B, ∃ t : ℝ, 0 ≤ t ∧ F t x ∈ A) : C(B, A)
+    where
+  toFun x := ⟨F (entryTime F A x.1) x.1, flow_entryTime_mem F hA (hhit x.1 x.2)⟩
+  continuous_toFun :=
+    (F.continuous
+          (continuousOn_iff_continuous_domRestrict.mp
+            (continuousOn_entryTime F hA hforward hentry hhit))
+          continuous_subtype_val).subtype_mk
+      _
+
+private theorem Smale.FlowConstruction.entryRetraction_inclusion {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {A B : Set X} (hA : IsClosed A)
+    (hforward : ∀ x ∈ A, ∀ t : ℝ, 0 ≤ t → F t x ∈ A)
+    (hentry : ∀ x ∈ A, ∀ t : ℝ, 0 < t → F t x ∈ interior A)
+    (hhit : ∀ x ∈ B, ∃ t : ℝ, 0 ≤ t ∧ F t x ∈ A) (hsub : A ⊆ B) (x : A) :
+    entryRetraction F hA hforward hentry hhit (ContinuousMap.inclusion hsub x) = x := by
+  apply Subtype.ext
+  change F (entryTime F A x.1) x.1 = x.1
+  rw [entryTime_eq_zero F x.2, F.map_zero_apply]
+
+private def Smale.FlowConstruction.entryDeformation {X : Type*} [TopologicalSpace X] (F : Flow ℝ X)
+    {A B : Set X} (hA : IsClosed A) (hforward : ∀ x ∈ A, ∀ t : ℝ, 0 ≤ t → F t x ∈ A)
+    (hentry : ∀ x ∈ A, ∀ t : ℝ, 0 < t → F t x ∈ interior A)
+    (hhit : ∀ x ∈ B, ∃ t : ℝ, 0 ≤ t ∧ F t x ∈ A) (hsub : A ⊆ B)
+    (hregion : ∀ x ∈ B, ∀ t : ℝ, 0 ≤ t → F t x ∈ B) :
+    (ContinuousMap.id B).HomotopyRel
+      ((ContinuousMap.inclusion hsub).comp (entryRetraction F hA hforward hentry hhit))
+      {x : B | x.1 ∈ A}
+    where
+  toFun
+    q :=
+    ⟨F (q.1.1 * entryTime F A q.2.1) q.2.1,
+      hregion q.2.1 q.2.2 _ (mul_nonneg q.1.2.1 (entryTime_nonneg F (hhit q.2.1 q.2.2)))⟩
+  continuous_toFun :=
+    (F.continuous
+          ((continuous_subtype_val.comp continuous_fst).mul
+            ((continuousOn_iff_continuous_domRestrict.mp
+                  (continuousOn_entryTime F hA hforward hentry hhit)).comp
+              continuous_snd))
+          (continuous_subtype_val.comp continuous_snd)).subtype_mk
+      _
+  map_zero_left
+    x := by
+    apply Subtype.ext
+    change F ((0 : ℝ) * entryTime F A x.1) x.1 = x.1
+    rw [MulZeroClass.zero_mul, F.map_zero_apply]
+  map_one_left
+    x := by
+    apply Subtype.ext
+    change F ((1 : ℝ) * entryTime F A x.1) x.1 = F (entryTime F A x.1) x.1
+    rw [one_mul]
+  prop' u x
+    hx := by
+    apply Subtype.ext
+    change F (u.1 * entryTime F A x.1) x.1 = x.1
+    rw [entryTime_eq_zero F (A := A) (show x.1 ∈ A from hx), MulZeroClass.mul_zero,
+      F.map_zero_apply]
+
+private def
+    Smale.FlowConstruction.entryHomotopyEquiv {X : Type*} [TopologicalSpace X] (F : Flow ℝ X)
+    {A B : Set X} (hA : IsClosed A) (hforward : ∀ x ∈ A, ∀ t : ℝ, 0 ≤ t → F t x ∈ A)
+    (hentry : ∀ x ∈ A, ∀ t : ℝ, 0 < t → F t x ∈ interior A)
+    (hhit : ∀ x ∈ B, ∃ t : ℝ, 0 ≤ t ∧ F t x ∈ A) (hsub : A ⊆ B)
+    (hregion : ∀ x ∈ B, ∀ t : ℝ, 0 ≤ t → F t x ∈ B) : A ≃ₕ B
+    where
+  toFun := ContinuousMap.inclusion hsub
+  invFun := entryRetraction F hA hforward hentry hhit
+  left_inv := by
+    have heq :
+      (entryRetraction F hA hforward hentry hhit).comp (ContinuousMap.inclusion hsub) =
+        ContinuousMap.id A := by
+      apply ContinuousMap.ext
+      intro x
+      exact entryRetraction_inclusion F hA hforward hentry hhit hsub x
+    rw [heq]
+  right_inv := ⟨(entryDeformation F hA hforward hentry hhit hsub hregion).toHomotopy.symm⟩
+
+private theorem
+    Smale.FlowConstruction.hasDerivAt_comp_integralCurve {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {v : (x : M) → TangentSpace 𝓘(ℝ, E) x} {γ : ℝ → M}
+    (hγ : IsMIntegralCurve γ v) (t : ℝ) :
+    HasDerivAt (f ∘ γ) (mvfderiv 𝓘(ℝ, E) f (γ t) (v (γ t))) t := by
+  have hc := (hf.mdifferentiableAt (by simp)).hasMFDerivAt.comp t (hγ t)
+  rw [hasDerivAt_iff_hasFDerivAt]
+  apply hasMFDerivAt_iff_hasFDerivAt.mp
+  apply hc.congr_mfderiv
+  apply ContinuousLinearMap.ext
+  intro r
+  change
+    (mvfderiv 𝓘(ℝ, E) f (γ t)) ((NormedSpace.fromTangentSpace t r) • v (γ t)) =
+      (NormedSpace.fromTangentSpace t r) • (mvfderiv 𝓘(ℝ, E) f (γ t)) (v (γ t))
+  exact map_smul _ _ _
+
+private theorem Smale.FlowConstruction.exists_regularBandField {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ}
+    (hband : ∀ x, f x ∈ Set.Icc a b → x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    ∃ (φ : ℝ → ℝ) (W : Set ℝ),
+      ContDiff ℝ ∞ φ ∧
+        IsOpen W ∧
+          Set.Icc a b ⊆ W ∧
+            Set.EqOn φ (fun _ => 1) W ∧
+              ∃ V : (x : M) → TangentSpace 𝓘(ℝ, E) x,
+                ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞
+                    (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+                  ∀ x, mvfderiv 𝓘(ℝ, E) f x (V x) = φ (f x) := by
+  let B := f '' Smale.ManifoldMorse.criticalPoints E f
+  have hB : IsClosed B :=
+    ((Smale.ManifoldMorse.criticalPoints_isClosed hf).isCompact.image hf.continuous).isClosed
+  have hAB : Set.Icc a b ⊆ Bᶜ := by
+    intro y hy
+    rintro ⟨x, hx, rfl⟩
+    exact hband x hy hx
+  obtain ⟨φ, hφ, hφB, W, hW, hAW, -, hφW⟩ :=
+    LineBundleTransport.exists_smooth_cutoff_near_closed isClosed_Icc hB.isOpen_compl hAB
+  have hχ : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ (φ ∘ f) := hφ.contMDiff.comp hf
+  have hsupp : tsupport (φ ∘ f) ⊆ (Smale.ManifoldMorse.criticalPoints E f)ᶜ := by
+    intro x hx hcrit
+    have hxφ := tsupport_comp_subset_preimage φ hf.continuous hx
+    exact hφB hxφ ⟨x, hcrit, rfl⟩
+  obtain ⟨V, hV, hVφ⟩ := exists_prescribedDerivativeField hf hχ hsupp
+  exact ⟨φ, W, hφ, hW, hAW, hφW, V, hV, hVφ⟩
+
+private theorem Smale.FlowConstruction.exists_regularBandFlow {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ}
+    (hband : ∀ x, f x ∈ Set.Icc a b → x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    ∃ (φ : ℝ → ℝ) (W : Set ℝ) (F : Flow ℝ M),
+      ContDiff ℝ ∞ φ ∧
+        IsOpen W ∧
+          Set.Icc a b ⊆ W ∧
+            Set.EqOn φ (fun _ => 1) W ∧
+              ∀ x t, HasDerivAt (fun s => f (F s x)) (φ (f (F t x))) t := by
+  obtain ⟨φ, W, hφ, hW, hAW, hφW, V, hV, hVφ⟩ := exists_regularBandField hf hband
+  have hV₁ :
+    ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)) :=
+    hV.of_le (by simp)
+  refine ⟨φ, W, compactFlow hV₁, hφ, hW, hAW, hφW, ?_⟩
+  intro x t
+  have hd := hasDerivAt_comp_integralCurve hf (isMIntegralCurve_compactFlow hV₁ x) t
+  rw [hVφ] at hd
+  exact hd
+
+private theorem Smale.FlowConstruction.flow_fixed_of_zero {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) {x : M} (hx : V x = 0)
+    (t : ℝ) : F t x = x := by
+  have heq :=
+    isMIntegralCurve_Ioo_eq_of_contMDiff_boundaryless hV (hcurve x) (isMIntegralCurve_const hx)
+      (t₀ := 0) (F.map_zero_apply x)
+  exact congrFun heq t
+
+private theorem Smale.FlowConstruction.flow_preserves_regular {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0) {x : M}
+    (hx : x ∉ Smale.ManifoldMorse.criticalPoints E f) (t : ℝ) :
+    F t x ∉ Smale.ManifoldMorse.criticalPoints E f := by
+  intro hy
+  have hfix := flow_fixed_of_zero hV F hcurve (hzero (F t x) hy) (-t)
+  have hinv : F (-t) (F t x) = x := by rw [← F.map_add, neg_add_cancel, F.map_zero_apply]
+  have hxy : x = F t x := hinv.symm.trans hfix
+  exact hx (hxy.symm ▸ hy)
+
+private theorem Smale.FlowConstruction.antitone_flow_height {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0)
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (x : M) : Antitone (fun t => f (F t x)) := by
+  apply antitone_of_hasDerivAt_nonpos (fun t => hasDerivAt_comp_integralCurve hf (hcurve x) t)
+  intro t
+  change mvfderiv 𝓘(ℝ, E) f (F t x) (V (F t x)) ≤ 0
+  by_cases ht : F t x ∈ Smale.ManifoldMorse.criticalPoints E f
+  · rw [hzero (F t x) ht, map_zero]
+  · exact (hdesc (F t x) ht).le
+
+private theorem Smale.FlowConstruction.strictAnti_flow_height {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0)
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    {x : M} (hx : x ∉ Smale.ManifoldMorse.criticalPoints E f) : StrictAnti (fun t => f (F t x)) :=
+  strictAnti_of_hasDerivAt_neg (fun t => hasDerivAt_comp_integralCurve hf (hcurve x) t)
+    (fun t => hdesc (F t x) (flow_preserves_regular hV F hcurve hzero hx t))
+
+private theorem
+    Smale.FlowConstruction.exists_adaptedDescentFlow {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    [FiniteDimensional ℝ E] [CompactSpace M] {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) :
+    ∃ (V : (x : M) → TangentSpace 𝓘(ℝ, E) x) (F : Flow ℝ M),
+      ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+        (∀ x, IsMIntegralCurve (fun t => F t x) V) ∧
+          (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0) ∧
+            (∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0) ∧
+              (∀ p ∈ Smale.ManifoldMorse.criticalPoints E f,
+                  ∃ c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p,
+                    ∀ᶠ x in 𝓝 p, V x = c.descentField x) ∧
+                (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, ∀ t, F t x = x) ∧
+                  (∀ x,
+                      x ∉ Smale.ManifoldMorse.criticalPoints E f →
+                        StrictAnti (fun t => f (F t x))) ∧
+                    ∀ x, Antitone (fun t => f (F t x)) := by
+  obtain ⟨V, hV, hzero, hdesc, hcharts⟩ := Smale.ManifoldMorse.exists_adaptedDescentField hf hm
+  have hV₁ :
+    ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)) :=
+    hV.of_le (by simp)
+  let F := compactFlow hV₁
+  have hcurve (x : M) : IsMIntegralCurve (fun t => F t x) V := isMIntegralCurve_compactFlow hV₁ x
+  exact
+    ⟨V, F, hV, hcurve, hzero, hdesc, hcharts, fun x hx t =>
+      flow_fixed_of_zero hV₁ F hcurve (hzero x hx) t, fun x hx =>
+      strictAnti_flow_height hf hV₁ F hcurve hzero hdesc hx, fun x =>
+      antitone_flow_height hf F hcurve hzero hdesc x⟩
+
+private theorem
+    Smale.FlowConstruction.continuous_mvfderiv_field {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M))) :
+    Continuous (fun x => mvfderiv 𝓘(ℝ, E) f x (V x)) := by
+  have ht := (hf.continuous_tangentMap (by simp)).comp hV.continuous
+  have hp := (tangentBundleModelSpaceHomeomorph 𝓘(ℝ, ℝ)).continuous.comp ht
+  convert hp.snd using 1
+  rfl
+
+private theorem
+    Smale.FlowConstruction.exists_uniform_negative_speed {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    {K : Set M} (hK : IsCompact K) (hreg : K ⊆ (Smale.ManifoldMorse.criticalPoints E f)ᶜ) :
+    ∃ δ > (0 : ℝ), ∀ x ∈ K, mvfderiv 𝓘(ℝ, E) f x (V x) ≤ -δ := by
+  by_cases hne : K.Nonempty
+  · obtain ⟨p, hp, hmax⟩ := hK.exists_isMaxOn hne (continuous_mvfderiv_field hf hV).continuousOn
+    refine ⟨-mvfderiv 𝓘(ℝ, E) f p (V p), neg_pos.mpr (hdesc p (hreg hp)), ?_⟩
+    intro x hx
+    have hle : mvfderiv 𝓘(ℝ, E) f x (V x) ≤ mvfderiv 𝓘(ℝ, E) f p (V p) := hmax hx
+    simpa only [neg_neg] using hle
+  · exact ⟨1, zero_lt_one, fun x hx => False.elim (hne ⟨x, hx⟩)⟩
+
+private theorem
+    Smale.FlowConstruction.exists_uniform_residence_bound {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    {K : Set M} (hK : IsCompact K) (hreg : K ⊆ (Smale.ManifoldMorse.criticalPoints E f)ᶜ) :
+    ∃ T > (0 : ℝ), ∀ γ : ℝ → M, IsMIntegralCurve γ V → ∃ t ∈ Set.Icc (0 : ℝ) T, γ t ∉ K := by
+  by_cases hne : K.Nonempty
+  · obtain ⟨δ, hδ, hspeed⟩ := exists_uniform_negative_speed hf hV hdesc hK hreg
+    obtain ⟨p, hp, hmin⟩ := hK.exists_isMinOn hne hf.continuous.continuousOn
+    obtain ⟨q, hq, hmax⟩ := hK.exists_isMaxOn hne hf.continuous.continuousOn
+    let T := (f q - f p + 1) / δ
+    have hpq : f p ≤ f q := hmax hp
+    have hgap : 0 < f q - f p + 1 := by linarith
+    have hT : 0 < T := div_pos hgap hδ
+    have hδT : δ * T = f q - f p + 1 := by
+      dsimp [T]
+      field_simp [hδ.ne']
+    refine ⟨T, hT, ?_⟩
+    intro γ hγ
+    by_contra! hstay
+    have hd (t : ℝ) : HasDerivAt (f ∘ γ) (mvfderiv 𝓘(ℝ, E) f (γ t) (V (γ t))) t :=
+      hasDerivAt_comp_integralCurve hf hγ t
+    have hdiff : Differentiable ℝ (f ∘ γ) := fun t => (hd t).differentiableAt
+    have hzero : (0 : ℝ) ∈ Set.Icc 0 T := ⟨le_rfl, hT.le⟩
+    have hlast : T ∈ Set.Icc 0 T := ⟨hT.le, le_rfl⟩
+    have hbound :=
+      (convex_Icc (0 : ℝ) T).image_sub_le_mul_sub_of_deriv_le hdiff.continuous.continuousOn
+        hdiff.differentiableOn
+        (fun t ht => by
+          rw [(hd t).deriv]
+          exact hspeed (γ t) (hstay t (interior_subset ht)))
+        0 hzero T hlast hT.le
+    simp only [Function.comp_apply, sub_zero, neg_mul] at hbound
+    rw [hδT] at hbound
+    have hlo : f p ≤ f (γ T) := hmin (hstay T hlast)
+    have hhi : f (γ 0) ≤ f q := hmax (hstay 0 hzero)
+    linarith
+  · refine ⟨1, zero_lt_one, ?_⟩
+    intro γ _
+    exact ⟨0, ⟨le_rfl, zero_le_one⟩, fun h => hne ⟨γ 0, h⟩⟩
+
+private theorem Smale.FlowConstruction.exists_uniform_criticalNeighborhood_entry {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} [CompactSpace M]
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hmono : ∀ x, Antitone (fun t => f (F t x))) {a b : ℝ} {U : Set M} (hU : IsOpen U)
+    (hcover : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, f x ∈ Set.Icc a b → x ∈ U) :
+    ∃ T > (0 : ℝ), ∀ x, f x ≤ b → ∃ t ∈ Set.Icc (0 : ℝ) T, f (F t x) < a ∨ F t x ∈ U := by
+  let K := f ⁻¹' Set.Icc a b ∩ Uᶜ
+  have hK : IsCompact K :=
+    ((isClosed_Icc.preimage hf.continuous).inter hU.isClosed_compl).isCompact
+  have hreg : K ⊆ (Smale.ManifoldMorse.criticalPoints E f)ᶜ := by
+    intro x hx hcrit
+    exact hx.2 (hcover x hcrit hx.1)
+  obtain ⟨T, hT, hexit⟩ := exists_uniform_residence_bound hf hV hdesc hK hreg
+  refine ⟨T, hT, ?_⟩
+  intro x hx
+  obtain ⟨t, ht, hout⟩ := hexit (fun s => F s x) (hcurve x)
+  have hupper : f (F t x) ≤ b := by
+    have hle : f (F t x) ≤ f x := by simpa only [F.map_zero_apply] using hmono x ht.1
+    exact hle.trans hx
+  refine ⟨t, ht, ?_⟩
+  by_cases hlow : f (F t x) < a
+  · exact Or.inl hlow
+  · right
+    by_contra hnot
+    exact hout ⟨⟨le_of_not_gt hlow, hupper⟩, hnot⟩
+
+private theorem
+    Smale.FlowConstruction.exists_uniform_absorbing_entry {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [CompactSpace M] {f : M → ℝ} {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hmono : ∀ x, Antitone (fun t => f (F t x))) {a b : ℝ} {A : Set M}
+    (hlower : {x | f x ≤ a} ⊆ A)
+    (hcover : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, f x ∈ Set.Icc a b → x ∈ interior A) :
+    ∃ T > (0 : ℝ), ∀ x, f x ≤ b → ∃ t ∈ Set.Icc 0 T, F t x ∈ A := by
+  obtain ⟨T, hT, hentry⟩ :=
+    exists_uniform_criticalNeighborhood_entry hf hV hdesc F hcurve hmono isOpen_interior hcover
+  refine ⟨T, hT, ?_⟩
+  intro x hx
+  obtain ⟨t, ht, hlow | hint⟩ := hentry x hx
+  · exact ⟨t, ht, hlower (show f (F t x) ≤ a from le_of_lt hlow)⟩
+  · exact ⟨t, ht, interior_subset hint⟩
+
+private theorem Smale.FlowConstruction.exists_absorbingSublevelHomotopyEquiv {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] {f : M → ℝ} {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hmono : ∀ x, Antitone (fun t => f (F t x))) {a b : ℝ} {A : Set M} (hA : IsClosed A)
+    (hlower : {x | f x ≤ a} ⊆ A) (hupper : A ⊆ {x | f x ≤ b})
+    (hcover : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, f x ∈ Set.Icc a b → x ∈ interior A)
+    (hforward : ∀ x ∈ A, ∀ t : ℝ, 0 ≤ t → F t x ∈ A)
+    (hentry : ∀ x ∈ A, ∀ t : ℝ, 0 < t → F t x ∈ interior A) :
+    ∃ e : A ≃ₕ { x : M // f x ≤ b }, ∀ x, (e x).1 = x.1 := by
+  obtain ⟨T, _, hhit⟩ := exists_uniform_absorbing_entry hf hV hdesc F hcurve hmono hlower hcover
+  have hfinite : ∀ x ∈ {x | f x ≤ b}, ∃ t : ℝ, 0 ≤ t ∧ F t x ∈ A := by
+    intro x hx
+    obtain ⟨t, ht, hm⟩ := hhit x hx
+    exact ⟨t, ht.1, hm⟩
+  have hregion : ∀ x ∈ {x | f x ≤ b}, ∀ t : ℝ, 0 ≤ t → f (F t x) ≤ b := by
+    intro x hx t ht
+    have hle : f (F t x) ≤ f x := by simpa only [F.map_zero_apply] using hmono x ht
+    exact hle.trans hx
+  exact ⟨entryHomotopyEquiv F hA hforward hentry hfinite hupper hregion, fun _ => rfl⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SignedMorseChart.exists_attachingUnionHomotopyEquiv {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0)
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (hagreement :
+      ∀ x ∈ Set.range (c.attachingHandleMap ρ hρ hblock), ∀ᶠ y in 𝓝 x, V y = c.descentField y)
+    (hband :
+      ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+        f x ∈ Set.Icc (f p - ρ ^ 2) (f p + ρ ^ 2) → x = p) :
+    ∃ e :
+      ↥({x | f x ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock)) ≃ₕ
+        { x : M // f x ≤ f p + ρ ^ 2 },
+      ∀ x, (e x).1 = x.1 := by
+  have hV₁ :
+    ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)) :=
+    hV.of_le (by simp)
+  have hmono := Smale.FlowConstruction.antitone_flow_height hf F hcurve hzero hdesc
+  have hbottom : ∀ x, f x = f p - ρ ^ 2 → ∀ t : ℝ, 0 < t → f (F t x) < f x := by
+    intro x hx t ht
+    have hreg : x ∉ Smale.ManifoldMorse.criticalPoints E f := by
+      intro hcrit
+      have hxp : x = p := hband x hcrit ⟨hx.ge, by rw [hx]; linarith [sq_nonneg ρ]⟩
+      rw [hxp] at hx
+      nlinarith [sq_pos_of_pos hρ]
+    simpa only [F.map_zero_apply] using
+      Smale.FlowConstruction.strictAnti_flow_height hf hV₁ F hcurve hzero hdesc hreg ht
+  apply
+    Smale.FlowConstruction.exists_absorbingSublevelHomotopyEquiv hf hV hdesc F hcurve hmono
+      ((isClosed_le hf.continuous continuous_const).union
+        (c.attachingHandleMap_isClosedEmbedding ρ hρ hblock).isClosed_range)
+      Set.subset_union_left (c.attachingHandleUnion_subset_upper ρ hρ hblock) (a := f p - ρ ^ 2)
+  · intro x hcrit hx
+    have hxp := hband x hcrit hx
+    subst x
+    exact
+      interior_mono Set.subset_union_right (c.mem_interior_range_attachingHandleMap ρ hρ hblock)
+  · exact
+      c.forwardInvariant_attachingUnion hf.continuous hV₁ F hcurve hmono ρ hρ hblock hagreement
+  · exact
+      c.interior_entry_attachingUnion hf.continuous hV₁ F hcurve hmono ρ hρ hblock hagreement
+        hbottom
+
+private theorem Smale.FlowConstruction.entryTime_flow_of_le {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {A : Set X} (hA : IsClosed A) {x : X} (hx : ∃ t : ℝ, 0 ≤ t ∧ F t x ∈ A) {t : ℝ}
+    (ht : 0 ≤ t) (hle : t ≤ entryTime F A x) : entryTime F A (F t x) = entryTime F A x - t := by
+  have hhit : F (entryTime F A x - t) (F t x) ∈ A := by
+    rw [← F.map_add, sub_add_cancel]
+    exact flow_entryTime_mem F hA hx
+  have hy : ∃ u : ℝ, 0 ≤ u ∧ F u (F t x) ∈ A := ⟨_, sub_nonneg.mpr hle, hhit⟩
+  apply le_antisymm (entryTime_le_of_mem F (sub_nonneg.mpr hle) hhit)
+  have hh := flow_entryTime_mem F hA hy
+  rw [← F.map_add] at hh
+  have hb := entryTime_le_of_mem F (add_nonneg (entryTime_nonneg F hy) ht) hh
+  linarith
+
+private theorem
+    Smale.FlowConstruction.entryTime_lt_of_flow_mem_interior {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {A : Set X} {x : X} {t : ℝ} (ht : 0 < t) (hx : F t x ∈ interior A) :
+    entryTime F A x < t := by
+  have he : ∀ᶠ s in 𝓝 t, 0 < s ∧ F s x ∈ interior A :=
+    (eventually_gt_nhds ht).and
+      ((F.continuous continuous_id continuous_const).continuousAt.preimage_mem_nhds
+        (isOpen_interior.mem_nhds hx))
+  obtain ⟨s, hst, hs⟩ := he.exists_lt
+  exact (entryTime_le_of_mem F hs.1.le (interior_subset hs.2)).trans_lt hst
+
+private theorem Smale.FlowConstruction.entryTime_eq_add_of_flow_pos {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {A : Set X} (hA : IsClosed A) (hforward : ∀ x ∈ A, ∀ t : ℝ, 0 ≤ t → F t x ∈ A)
+    {x : X} (hx : ∃ t : ℝ, 0 ≤ t ∧ F t x ∈ A) {t : ℝ} (ht : 0 ≤ t)
+    (hpos : 0 < entryTime F A (F t x)) : entryTime F A x = t + entryTime F A (F t x) := by
+  have hle : t ≤ entryTime F A x := by
+    by_contra h
+    have hh := (entryTime_le_iff F hA hforward hx ht).mp (le_of_not_ge h)
+    rw [entryTime_eq_zero F hh] at hpos
+    exact lt_irrefl _ hpos
+  rw [entryTime_flow_of_le F hA hx ht hle]
+  ring
+
+private structure
+    Smale.FlowConstruction.FlowCollarData {X : Type*} [TopologicalSpace X] (F : Flow ℝ X)
+    (A B : Set X) where
+  time : ℝ
+  time_pos : 0 < time
+  closed_outer : IsClosed B
+  closed_inner : IsClosed A
+  inner_subset : A ⊆ B
+  forward_outer : ∀ x ∈ B, ∀ t : ℝ, 0 ≤ t → F t x ∈ B
+  forward_inner : ∀ x ∈ A, ∀ t : ℝ, 0 ≤ t → F t x ∈ A
+  strict_outer : ∀ x ∈ B, ∀ t : ℝ, 0 < t → F t x ∈ interior B
+  strict_inner : ∀ x ∈ A, ∀ t : ℝ, 0 < t → F t x ∈ interior A
+  core_inside : ∀ x ∈ B, F time x ∈ interior A
+
+private def
+    Smale.FlowConstruction.FlowCollarData.core {X : Type*} [TopologicalSpace X] {F : Flow ℝ X}
+    {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) : Set X :=
+  (F (-d.time)) ⁻¹' B
+
+private theorem Smale.FlowConstruction.FlowCollarData.closed_core {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) :
+    IsClosed d.core :=
+  d.closed_outer.preimage (F.continuous continuous_const continuous_id)
+
+private theorem Smale.FlowConstruction.FlowCollarData.forward_core {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) :
+    ∀ x ∈ d.core, ∀ t : ℝ, 0 ≤ t → F t x ∈ d.core := by
+  intro x hx t ht
+  change F (-d.time) (F t x) ∈ B
+  rw [← F.map_add, add_comm, F.map_add]
+  exact d.forward_outer _ hx t ht
+
+private theorem Smale.FlowConstruction.FlowCollarData.strict_core {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) :
+    ∀ x ∈ d.core, ∀ t : ℝ, 0 < t → F t x ∈ interior d.core := by
+  intro x hx t ht
+  apply preimage_interior_subset_interior_preimage (F.continuous continuous_const continuous_id)
+  change F (-d.time) (F t x) ∈ interior B
+  rw [← F.map_add, add_comm, F.map_add]
+  exact d.strict_outer _ hx t ht
+
+private theorem
+    Smale.FlowConstruction.FlowCollarData.flow_time_mem_core {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) {x : X}
+    (hx : x ∈ B) : F d.time x ∈ d.core := by
+  change F (-d.time) (F d.time x) ∈ B
+  simpa only [← F.map_add, neg_add_cancel, F.map_zero_apply] using hx
+
+private theorem Smale.FlowConstruction.FlowCollarData.hits_core {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) {x : X}
+    (hx : x ∈ B) : ∃ t : ℝ, 0 ≤ t ∧ F t x ∈ d.core :=
+  ⟨d.time, d.time_pos.le, d.flow_time_mem_core hx⟩
+
+private theorem Smale.FlowConstruction.FlowCollarData.hits_inner {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) {x : X}
+    (hx : x ∈ B) : ∃ t : ℝ, 0 ≤ t ∧ F t x ∈ A :=
+  ⟨d.time, d.time_pos.le, interior_subset (d.core_inside x hx)⟩
+
+private def
+    Smale.FlowConstruction.FlowCollarData.duration {X : Type*} [TopologicalSpace X] {F : Flow ℝ X}
+    {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) : ℝ :=
+  Smale.FlowConstruction.entryTime F d.core x.1
+
+private theorem
+    Smale.FlowConstruction.FlowCollarData.duration_nonneg {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) :
+    0 ≤ d.duration x :=
+  Smale.FlowConstruction.entryTime_nonneg F (d.hits_core x.2)
+
+private theorem Smale.FlowConstruction.FlowCollarData.duration_le {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) :
+    d.duration x ≤ d.time :=
+  Smale.FlowConstruction.entryTime_le_of_mem F d.time_pos.le (d.flow_time_mem_core x.2)
+
+private theorem
+    Smale.FlowConstruction.FlowCollarData.continuous_duration {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) :
+    Continuous d.duration :=
+  continuousOn_iff_continuous_domRestrict.mp
+    (Smale.FlowConstruction.continuousOn_entryTime F d.closed_core d.forward_core d.strict_core
+      (fun _ hx => d.hits_core hx))
+
+private def
+    Smale.FlowConstruction.FlowCollarData.origin {X : Type*} [TopologicalSpace X] {F : Flow ℝ X}
+    {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) : B :=
+  ⟨F (d.duration x - d.time) x.1,
+    by
+    have h := Smale.FlowConstruction.flow_entryTime_mem F d.closed_core (d.hits_core x.2)
+    change F (-d.time) (F (d.duration x) x.1) ∈ B at h
+    simpa only [← F.map_add, sub_eq_add_neg, add_comm] using h⟩
+
+private theorem
+    Smale.FlowConstruction.FlowCollarData.continuous_origin {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) :
+    Continuous d.origin :=
+  (F.continuous (d.continuous_duration.sub continuous_const) continuous_subtype_val).subtype_mk _
+
+private theorem
+    Smale.FlowConstruction.FlowCollarData.origin_reconstruct {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) :
+    F (d.time - d.duration x) (d.origin x).1 = x.1 := by
+  change F (d.time - d.duration x) (F (d.duration x - d.time) x.1) = x.1
+  rw [← F.map_add, sub_add_sub_cancel, sub_self, F.map_zero_apply]
+
+private def
+    Smale.FlowConstruction.FlowCollarData.delay {X : Type*} [TopologicalSpace X] {F : Flow ℝ X}
+    {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) : ℝ :=
+  Smale.FlowConstruction.entryTime F A (d.origin x).1
+
+private theorem Smale.FlowConstruction.FlowCollarData.delay_nonneg {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) :
+    0 ≤ d.delay x :=
+  Smale.FlowConstruction.entryTime_nonneg F (d.hits_inner (d.origin x).2)
+
+private theorem Smale.FlowConstruction.FlowCollarData.delay_lt {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) :
+    d.delay x < d.time :=
+  Smale.FlowConstruction.entryTime_lt_of_flow_mem_interior F d.time_pos
+    (d.core_inside _ (d.origin x).2)
+
+private theorem
+    Smale.FlowConstruction.FlowCollarData.continuous_delay {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) :
+    Continuous d.delay :=
+  (continuousOn_iff_continuous_domRestrict.mp
+        (Smale.FlowConstruction.continuousOn_entryTime F d.closed_inner d.forward_inner
+          d.strict_inner (fun _ hx => d.hits_inner hx))).comp
+    d.continuous_origin
+
+private def
+    Smale.FlowConstruction.FlowCollarData.factor {X : Type*} [TopologicalSpace X] {F : Flow ℝ X}
+    {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) : ℝ :=
+  (d.time - d.delay x) / d.time
+
+private theorem Smale.FlowConstruction.FlowCollarData.factor_pos {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) :
+    0 < d.factor x :=
+  div_pos (sub_pos.mpr (d.delay_lt x)) d.time_pos
+
+private theorem Smale.FlowConstruction.FlowCollarData.factor_le_one {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) :
+    d.factor x ≤ 1 := by
+  apply (div_le_one d.time_pos).mpr
+  linarith [d.delay_nonneg x]
+
+private theorem
+    Smale.FlowConstruction.FlowCollarData.time_mul_factor {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) :
+    d.time * d.factor x = d.time - d.delay x := by
+  dsimp [factor]
+  field_simp [d.time_pos.ne']
+
+private theorem
+    Smale.FlowConstruction.FlowCollarData.continuous_factor {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) :
+    Continuous d.factor :=
+  (continuous_const.sub d.continuous_delay).div_const _
+
+private theorem Smale.FlowConstruction.FlowCollarData.duration_le_retained {X : Type*}
+    [TopologicalSpace X] {F : Flow ℝ X} {A B : Set X}
+    (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) (hx : x.1 ∈ A) :
+    d.duration x ≤ d.time * d.factor x := by
+  have hhit : F (d.time - d.duration x) (d.origin x).1 ∈ A := by rwa [d.origin_reconstruct]
+  have h := Smale.FlowConstruction.entryTime_le_of_mem F (sub_nonneg.mpr (d.duration_le x)) hhit
+  change d.delay x ≤ d.time - d.duration x at h
+  rw [d.time_mul_factor]
+  linarith
+
+private def
+    Smale.FlowConstruction.FlowCollarData.shift {X : Type*} [TopologicalSpace X] {F : Flow ℝ X}
+    {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) : ℝ :=
+  d.duration x * (1 - d.factor x)
+
+private theorem Smale.FlowConstruction.FlowCollarData.shift_nonneg {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) :
+    0 ≤ d.shift x :=
+  mul_nonneg (d.duration_nonneg x) (sub_nonneg.mpr (d.factor_le_one x))
+
+private theorem
+    Smale.FlowConstruction.FlowCollarData.shift_le_duration {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) :
+    d.shift x ≤ d.duration x := by
+  dsimp [shift]
+  nlinarith [mul_nonneg (d.duration_nonneg x) (d.factor_pos x).le]
+
+private theorem
+    Smale.FlowConstruction.FlowCollarData.continuous_shift {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) :
+    Continuous d.shift :=
+  d.continuous_duration.mul (continuous_const.sub d.continuous_factor)
+
+private def
+    Smale.FlowConstruction.FlowCollarData.rescale {X : Type*} [TopologicalSpace X] {F : Flow ℝ X}
+    {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) : C(B, B)
+    where
+  toFun x := ⟨F (d.shift x) x.1, d.forward_outer x.1 x.2 _ (d.shift_nonneg x)⟩
+  continuous_toFun := (F.continuous d.continuous_shift continuous_subtype_val).subtype_mk _
+
+private theorem
+    Smale.FlowConstruction.FlowCollarData.rescale_from_origin {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) :
+    (d.rescale x).1 = F (d.time - d.duration x * d.factor x) (d.origin x).1 := by
+  change F (d.shift x) x.1 = _
+  conv_lhs => rw [← d.origin_reconstruct x]
+  rw [← F.map_add]
+  congr 1
+  dsimp [shift]
+  ring
+
+private theorem
+    Smale.FlowConstruction.FlowCollarData.rescale_mem_inner {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) :
+    (d.rescale x).1 ∈ A := by
+  rw [d.rescale_from_origin]
+  have hh : d.delay x ≤ d.time - d.duration x * d.factor x := by
+    have h := mul_le_mul_of_nonneg_right (d.duration_le x) (d.factor_pos x).le
+    rw [d.time_mul_factor] at h
+    linarith
+  exact
+    (Smale.FlowConstruction.entryTime_le_iff F d.closed_inner d.forward_inner
+          (d.hits_inner (d.origin x).2) ((d.delay_nonneg x).trans hh)).mp
+      hh
+
+private theorem
+    Smale.FlowConstruction.FlowCollarData.duration_rescale {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) :
+    d.duration (d.rescale x) = d.duration x * d.factor x := by
+  change Smale.FlowConstruction.entryTime F d.core (F (d.shift x) x.1) = _
+  rw [Smale.FlowConstruction.entryTime_flow_of_le F d.closed_core (d.hits_core x.2)
+      (d.shift_nonneg x) (d.shift_le_duration x)]
+  change d.duration x - d.shift x = _
+  dsimp [shift]
+  ring
+
+private theorem
+    Smale.FlowConstruction.FlowCollarData.origin_rescale {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) :
+    d.origin (d.rescale x) = d.origin x := by
+  apply Subtype.ext
+  change F (d.duration (d.rescale x) - d.time) (F (d.shift x) x.1) = F (d.duration x - d.time) x.1
+  rw [d.duration_rescale, ← F.map_add]
+  congr 1
+  dsimp [shift]
+  ring
+
+private theorem
+    Smale.FlowConstruction.FlowCollarData.factor_rescale {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) :
+    d.factor (d.rescale x) = d.factor x := by
+  unfold factor delay
+  rw [d.origin_rescale]
+
+private theorem
+    Smale.FlowConstruction.FlowCollarData.rescale_injective {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) :
+    Function.Injective d.rescale := by
+  intro x y h
+  have hfactor : d.factor x = d.factor y := by rw [← d.factor_rescale x, ← d.factor_rescale y, h]
+  have hdur : d.duration x = d.duration y := by
+    have he := congrArg d.duration h
+    rw [d.duration_rescale, d.duration_rescale, hfactor] at he
+    exact mul_right_cancel₀ (d.factor_pos y).ne' he
+  have horigin : d.origin x = d.origin y := by rw [← d.origin_rescale x, ← d.origin_rescale y, h]
+  apply Subtype.ext
+  rw [← d.origin_reconstruct x, ← d.origin_reconstruct y, hdur, horigin]
+
+private theorem
+    Smale.FlowConstruction.FlowCollarData.rescale_eq_self_of_duration_eq_zero {X : Type*}
+    [TopologicalSpace X] {F : Flow ℝ X} {A B : Set X}
+    (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) (hx : d.duration x = 0) :
+    d.rescale x = x := by
+  apply Subtype.ext
+  change F (d.shift x) x.1 = x.1
+  simp only [shift, hx, MulZeroClass.zero_mul, F.map_zero_apply]
+
+private theorem
+    Smale.FlowConstruction.FlowCollarData.exists_rescale_eq {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) (y : B)
+    (hy : y.1 ∈ A) : ∃ x : B, d.rescale x = y := by
+  by_cases hs : d.duration y = 0
+  · exact ⟨y, d.rescale_eq_self_of_duration_eq_zero y hs⟩
+  have hspos : 0 < d.duration y := lt_of_le_of_ne (d.duration_nonneg y) (Ne.symm hs)
+  let r := d.duration y / d.factor y
+  have hr₀ : 0 ≤ r := (div_pos hspos (d.factor_pos y)).le
+  have hrT : r ≤ d.time := (div_le_iff₀ (d.factor_pos y)).mpr (d.duration_le_retained y hy)
+  have hr : r * d.factor y = d.duration y := div_mul_cancel₀ _ (d.factor_pos y).ne'
+  have hsr : d.duration y ≤ r := by
+    have hh := mul_le_mul_of_nonneg_left (d.factor_le_one y) hr₀
+    rwa [mul_one, hr] at hh
+  let x : B :=
+    ⟨F (d.time - r) (d.origin y).1, d.forward_outer _ (d.origin y).2 _ (sub_nonneg.mpr hrT)⟩
+  have hxy : F (r - d.duration y) x.1 = y.1 := by
+    change F (r - d.duration y) (F (d.time - r) (d.origin y).1) = y.1
+    rw [← F.map_add]
+    convert d.origin_reconstruct y using 2
+    ring
+  have hdx : d.duration x = r := by
+    have hh :=
+      Smale.FlowConstruction.entryTime_eq_add_of_flow_pos F d.closed_core d.forward_core
+        (d.hits_core x.2) (sub_nonneg.mpr hsr)
+        (show 0 < Smale.FlowConstruction.entryTime F d.core (F (r - d.duration y) x.1) by
+          rw [hxy]; exact hspos)
+    rw [hxy] at hh
+    change d.duration x = r - d.duration y + d.duration y at hh
+    linarith
+  have hox : d.origin x = d.origin y := by
+    apply Subtype.ext
+    change F (d.duration x - d.time) (F (d.time - r) (d.origin y).1) = _
+    rw [hdx, ← F.map_add, sub_add_sub_cancel, sub_self, F.map_zero_apply]
+  have hfx : d.factor x = d.factor y := by
+    unfold factor delay
+    rw [hox]
+  refine ⟨x, Subtype.ext ?_⟩
+  rw [d.rescale_from_origin, hdx, hfx, hox, hr, d.origin_reconstruct]
+
+private def
+    Smale.FlowConstruction.FlowCollarData.innerMap {X : Type*} [TopologicalSpace X] {F : Flow ℝ X}
+    {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) : C(B, A)
+    where
+  toFun x := ⟨(d.rescale x).1, d.rescale_mem_inner x⟩
+  continuous_toFun := (continuous_subtype_val.comp d.rescale.continuous).subtype_mk _
+
+private theorem
+    Smale.FlowConstruction.FlowCollarData.innerMap_bijective {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) :
+    Function.Bijective d.innerMap := by
+  constructor
+  · intro x y h
+    apply d.rescale_injective
+    exact Subtype.ext (congrArg (fun z : A => (z : X)) h)
+  · intro y
+    obtain ⟨x, hx⟩ := d.exists_rescale_eq ⟨y.1, d.inner_subset y.2⟩ y.2
+    exact ⟨x, Subtype.ext (congrArg (fun z : B => (z : X)) hx)⟩
+
+private def Smale.FlowConstruction.FlowCollarData.homeomorph {X : Type*} [TopologicalSpace X]
+    {F : Flow ℝ X} {A B : Set X} (d : Smale.FlowConstruction.FlowCollarData F A B) [T2Space X]
+    [CompactSpace B] : B ≃ₜ A :=
+  Continuous.homeoOfEquivCompactToT2 (f := Equiv.ofBijective d.innerMap d.innerMap_bijective)
+    d.innerMap.continuous
+
+private theorem Smale.FlowConstruction.FlowCollarData.duration_lt_time_iff_interior {X : Type*}
+    [TopologicalSpace X] {F : Flow ℝ X} {A B : Set X}
+    (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) :
+    d.duration x < d.time ↔ (x : X) ∈ interior B := by
+  constructor
+  · intro hlt
+    have hi :=
+      d.strict_outer (d.origin x).val (d.origin x).property (d.time - d.duration x)
+        (sub_pos.mpr hlt)
+    rwa [d.origin_reconstruct] at hi
+  · intro hi
+    have hcore : F d.time x.val ∈ interior d.core := by
+      apply
+        preimage_interior_subset_interior_preimage (F.continuous continuous_const continuous_id)
+      change F (-d.time) (F d.time x.val) ∈ interior B
+      simpa only [← F.map_add, neg_add_cancel, F.map_zero_apply] using hi
+    exact Smale.FlowConstruction.entryTime_lt_of_flow_mem_interior F d.time_pos hcore
+
+private theorem Smale.FlowConstruction.FlowCollarData.duration_eq_time_iff_frontier {X : Type*}
+    [TopologicalSpace X] {F : Flow ℝ X} {A B : Set X}
+    (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) :
+    d.duration x = d.time ↔ (x : X) ∈ frontier B := by
+  rw [frontier, d.closed_outer.closure_eq]
+  constructor
+  · intro heq
+    refine ⟨x.property, ?_⟩
+    intro hi
+    have hlt := (d.duration_lt_time_iff_interior x).mpr hi
+    exact (ne_of_lt hlt) heq
+  · intro hx
+    apply le_antisymm (d.duration_le x)
+    exact le_of_not_gt (fun hlt => hx.2 ((d.duration_lt_time_iff_interior x).mp hlt))
+
+private theorem Smale.FlowConstruction.FlowCollarData.rescale_mem_interior_iff {X : Type*}
+    [TopologicalSpace X] {F : Flow ℝ X} {A B : Set X}
+    (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) :
+    (d.rescale x).val ∈ interior A ↔ x.val ∈ interior B := by
+  suffices h : (d.rescale x).val ∈ interior A ↔ d.duration x < d.time from
+    h.trans (d.duration_lt_time_iff_interior x)
+  constructor
+  · intro hi
+    by_contra hnot
+    have heq : d.duration x = d.time := le_antisymm (d.duration_le x) (le_of_not_gt hnot)
+    have horigin : (d.origin x).val = x.val := by
+      change F (d.duration x - d.time) x.val = x.val
+      rw [heq, sub_self, F.map_zero_apply]
+    have hentry : F (d.delay x) (d.origin x).val ∈ interior A := by
+      rw [d.rescale_from_origin, heq, d.time_mul_factor, sub_sub_cancel] at hi
+      exact hi
+    by_cases hpos : 0 < d.delay x
+    · have hlt := Smale.FlowConstruction.entryTime_lt_of_flow_mem_interior F hpos hentry
+      exact (lt_irrefl (d.delay x)) hlt
+    · have hzero : d.delay x = 0 := le_antisymm (le_of_not_gt hpos) (d.delay_nonneg x)
+      rw [hzero, F.map_zero_apply, horigin] at hentry
+      have hB := interior_mono d.inner_subset hentry
+      exact hnot ((d.duration_lt_time_iff_interior x).mpr hB)
+  · intro hlt
+    rw [d.rescale_from_origin]
+    have hmul := mul_lt_mul_of_pos_right hlt (d.factor_pos x)
+    rw [d.time_mul_factor] at hmul
+    have hdelay : d.delay x < d.time - d.duration x * d.factor x := by linarith
+    exact
+      Smale.FlowConstruction.flow_mem_interior_of_entryTime_lt F d.closed_inner d.strict_inner
+        (d.hits_inner (d.origin x).property) hdelay
+
+private theorem Smale.FlowConstruction.FlowCollarData.innerMap_mem_frontier_iff {X : Type*}
+    [TopologicalSpace X] {F : Flow ℝ X} {A B : Set X}
+    (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) :
+    (d.innerMap x).val ∈ frontier A ↔ x.val ∈ frontier B := by
+  change (d.rescale x).val ∈ frontier A ↔ x.val ∈ frontier B
+  rw [frontier, frontier, d.closed_inner.closure_eq, d.closed_outer.closure_eq]
+  constructor
+  · intro hx
+    exact ⟨x.property, fun hi => hx.2 ((d.rescale_mem_interior_iff x).mpr hi)⟩
+  · intro hx
+    exact ⟨d.rescale_mem_inner x, fun hi => hx.2 ((d.rescale_mem_interior_iff x).mp hi)⟩
+
+private theorem Smale.FlowConstruction.FlowCollarData.homeomorph_mem_frontier_iff {X : Type*}
+    [TopologicalSpace X] {F : Flow ℝ X} {A B : Set X}
+    (d : Smale.FlowConstruction.FlowCollarData F A B) [T2Space X] [CompactSpace B] (x : B) :
+    (d.homeomorph x).val ∈ frontier A ↔ x.val ∈ frontier B :=
+  d.innerMap_mem_frontier_iff x
+
+private theorem Smale.FlowConstruction.FlowCollarData.homeomorph_eq_flow_entryTime {X : Type*}
+    [TopologicalSpace X] {F : Flow ℝ X} {A B : Set X}
+    (d : Smale.FlowConstruction.FlowCollarData F A B) [T2Space X] [CompactSpace B] (x : B)
+    (hx : x.val ∈ frontier B) :
+    (d.homeomorph x).val = F (Smale.FlowConstruction.entryTime F A x.val) x.val := by
+  have ht := (d.duration_eq_time_iff_frontier x).mpr hx
+  have ho : (d.origin x).val = x.val := by
+    change F (d.duration x - d.time) x.val = x.val
+    rw [ht, sub_self, F.map_zero_apply]
+  change (d.rescale x).val = _
+  rw [d.rescale_from_origin, ht, d.time_mul_factor, sub_sub_cancel]
+  change F (Smale.FlowConstruction.entryTime F A (d.origin x).val) (d.origin x).val = _
+  rw [ho]
+
+private theorem Smale.FlowConstruction.FlowCollarData.homeomorph_eq_flow_of_mem_frontier {X : Type*}
+    [TopologicalSpace X] {F : Flow ℝ X} {A B : Set X}
+    (d : Smale.FlowConstruction.FlowCollarData F A B) [T2Space X] [CompactSpace B] (x : B)
+    (hx : x.val ∈ frontier B) {t : ℝ} (ht : 0 ≤ t) (hfront : F t x.val ∈ frontier A) :
+    (d.homeomorph x).val = F t x.val := by
+  rw [d.homeomorph_eq_flow_entryTime x hx,
+    Smale.FlowConstruction.entryTime_eq_of_flow_mem_frontier F d.closed_inner d.strict_inner ht
+      hfront]
+
+private theorem
+    Smale.FlowConstruction.FlowCollarData.homeomorph_symm_eq_flow_of_mem_frontier {X : Type*}
+    [TopologicalSpace X] {F : Flow ℝ X} {A B : Set X}
+    (d : Smale.FlowConstruction.FlowCollarData F A B) [T2Space X] [CompactSpace B] (y : A)
+    (hy : y.val ∈ frontier A) {t : ℝ} (ht : t ≤ 0) (hfront : F t y.val ∈ frontier B) :
+    (d.homeomorph.symm y).val = F t y.val := by
+  have hmem : F t y.val ∈ B := by
+    simpa only [d.closed_outer.closure_eq] using frontier_subset_closure hfront
+  let x : B := ⟨F t y.val, hmem⟩
+  have hreturn : F (-t) x.val = y.val := by
+    change F (-t) (F t y.val) = y.val
+    rw [← F.map_add, neg_add_cancel, F.map_zero_apply]
+  have heq : d.homeomorph x = y := by
+    apply Subtype.ext
+    rw [d.homeomorph_eq_flow_of_mem_frontier x hfront (neg_nonneg.mpr ht) (hreturn ▸ hy), hreturn]
+  have hinv := congrArg d.homeomorph.symm heq
+  rw [d.homeomorph.symm_apply_apply] at hinv
+  exact congrArg (fun z : B => z.val) hinv.symm
+
+private theorem Smale.FlowConstruction.FlowCollarData.rescale_eq_self_of_mem_inner_frontier_outer
+    {X : Type*} [TopologicalSpace X] {F : Flow ℝ X} {A B : Set X}
+    (d : Smale.FlowConstruction.FlowCollarData F A B) (x : B) (hxA : x.val ∈ A)
+    (hxB : x.val ∈ frontier B) : d.rescale x = x := by
+  have ht := (d.duration_eq_time_iff_frontier x).mpr hxB
+  have hret := d.duration_le_retained x hxA
+  rw [ht] at hret
+  have hfac : d.factor x = 1 := by nlinarith [d.factor_le_one x, d.time_pos]
+  apply Subtype.ext
+  change F (d.shift x) x.val = x.val
+  simp only [shift, hfac, sub_self, MulZeroClass.mul_zero, F.map_zero_apply]
+
+private theorem
+    Smale.FlowConstruction.FlowCollarData.homeomorph_fixed_on_common_frontier {X : Type*}
+    [TopologicalSpace X] {F : Flow ℝ X} {A B : Set X}
+    (d : Smale.FlowConstruction.FlowCollarData F A B) [T2Space X] [CompactSpace B] (x : B)
+    (hxA : x.val ∈ A) (hxB : x.val ∈ frontier B) : (d.homeomorph x).val = x.val :=
+  congrArg (fun y : B => y.val) (d.rescale_eq_self_of_mem_inner_frontier_outer x hxA hxB)
+
+private theorem Smale.FlowConstruction.exists_absorbingSublevelHomeomorph_with_boundary_orbits
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] [T2Space M] {f : M → ℝ}
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hmono : ∀ x, Antitone (fun t => f (F t x))) {a b : ℝ} {A : Set M} (hA : IsClosed A)
+    (hlower : {x | f x ≤ a} ⊆ A) (hupper : A ⊆ {x | f x ≤ b})
+    (hcover : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, f x ∈ Set.Icc a b → x ∈ interior A)
+    (hforward : ∀ x ∈ A, ∀ t : ℝ, 0 ≤ t → F t x ∈ A)
+    (hentry : ∀ x ∈ A, ∀ t : ℝ, 0 < t → F t x ∈ interior A)
+    (htop : ∀ x, f x = b → ∀ t : ℝ, 0 < t → f (F t x) < b) :
+    ∃ e : { x : M // f x ≤ b } ≃ₜ A,
+      (∀ x, (e x).val ∈ frontier A ↔ x.val ∈ frontier {y : M | f y ≤ b}) ∧
+        (∀ x, x.val ∈ A → x.val ∈ frontier {y : M | f y ≤ b} → (e x).val = x.val) ∧
+          (∀ y,
+            y.val ∈ frontier A →
+              ∀ t : ℝ,
+                t ≤ 0 → F t y.val ∈ frontier {x : M | f x ≤ b} → (e.symm y).val = F t y.val) := by
+  obtain ⟨T, hT, hhit⟩ := exists_uniform_absorbing_entry hf hV hdesc F hcurve hmono hlower hcover
+  have hregion : ∀ x ∈ {x | f x ≤ b}, ∀ t : ℝ, 0 ≤ t → f (F t x) ≤ b := by
+    intro x hx t ht
+    have hh : f (F t x) ≤ f x := by simpa only [F.map_zero_apply] using hmono x ht
+    exact hh.trans hx
+  have hstrict : ∀ x ∈ {x | f x ≤ b}, ∀ t : ℝ, 0 < t → F t x ∈ interior {x | f x ≤ b} := by
+    intro x hx t ht
+    change f x ≤ b at hx
+    apply
+      interior_maximal
+        (show {x | f x < b} ⊆ {x | f x ≤ b} from fun x (hy : f x < b) =>
+          (show f x ≤ b from hy.le))
+        (isOpen_lt hf.continuous continuous_const)
+    rcases lt_or_eq_of_le hx with hlt | heq
+    · have hh : f (F t x) ≤ f x := by simpa only [F.map_zero_apply] using hmono x ht.le
+      exact hh.trans_lt hlt
+    · exact htop x heq t ht
+  let d : FlowCollarData F A {x | f x ≤ b} :=
+    { time := T + 1
+      time_pos := by linarith
+      closed_outer := isClosed_le hf.continuous continuous_const
+      closed_inner := hA
+      inner_subset := hupper
+      forward_outer := hregion
+      forward_inner := hforward
+      strict_outer := hstrict
+      strict_inner := hentry
+      core_inside := by
+        intro x hx
+        obtain ⟨t, ht, hmem⟩ := hhit x hx
+        have hh := hentry _ hmem (T + 1 - t) (by linarith [ht.2])
+        rwa [← F.map_add, sub_add_cancel] at hh }
+  have : CompactSpace ↥({x : M | f x ≤ b}) :=
+    isCompact_iff_compactSpace.mp (isClosed_le hf.continuous continuous_const).isCompact
+  exact
+    ⟨d.homeomorph, d.homeomorph_mem_frontier_iff, d.homeomorph_fixed_on_common_frontier,
+      fun y hy _ ht hfront => d.homeomorph_symm_eq_flow_of_mem_frontier y hy ht hfront⟩
+
+private theorem Smale.FlowConstruction.frontier_sublevel_eq_of_strict_flow {X : Type*}
+    [TopologicalSpace X] {f : X → ℝ} (hf : Continuous f) (F : Flow ℝ X)
+    (hmono : ∀ x, Antitone (fun t => f (F t x))) {b : ℝ}
+    (htop : ∀ x, f x = b → ∀ t : ℝ, 0 < t → f (F t x) < b) :
+    frontier {x | f x ≤ b} = {x | f x = b} := by
+  have hclosed : IsClosed {x | f x ≤ b} := isClosed_le hf continuous_const
+  ext x
+  rw [frontier, hclosed.closure_eq]
+  constructor
+  · rintro ⟨hx, hnot⟩
+    apply le_antisymm hx
+    by_contra hn
+    have hlt : f x < b := lt_of_not_ge hn
+    exact
+      hnot (interior_maximal (fun y (hy : f y < b) => hy.le) (isOpen_lt hf continuous_const) hlt)
+  · intro hx
+    refine ⟨(show f x ≤ b from hx.le), ?_⟩
+    intro hi
+    have he : ∀ᶠ t : ℝ in 𝓝 0, F t x ∈ interior {y | f y ≤ b} := by
+      have hcont : ContinuousAt (fun t : ℝ => F t x) 0 :=
+        (F.continuous continuous_id continuous_const).continuousAt
+      apply hcont.preimage_mem_nhds
+      simpa only [F.map_zero_apply] using isOpen_interior.mem_nhds hi
+    obtain ⟨s, hs, hsB⟩ := he.exists_lt
+    have hy : F s x ∈ {y | f y ≤ b} := interior_subset hsB
+    have hxy : f x ≤ f (F s x) := by
+      have hh := hmono (F s x) (show (0 : ℝ) ≤ -s by linarith)
+      simpa only [F.map_zero_apply, ← F.map_add, neg_add_cancel] using hh
+    have hyeq : f (F s x) = b := le_antisymm hy (hx ▸ hxy)
+    have hstrict := htop (F s x) hyeq (-s) (by linarith)
+    rw [← F.map_add, neg_add_cancel, F.map_zero_apply, hx] at hstrict
+    exact lt_irrefl b hstrict
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SignedMorseChart.exists_attachingUnionHomeomorph_with_level_and_orbits
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0)
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (hagreement :
+      ∀ x ∈ Set.range (c.attachingHandleMap ρ hρ hblock), ∀ᶠ y in 𝓝 x, V y = c.descentField y)
+    (hband :
+      ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+        f x ∈ Set.Icc (f p - ρ ^ 2) (f p + ρ ^ 2) → x = p) :
+    ∃ e :
+      ↥({x | f x ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock)) ≃ₜ
+        { x : M // f x ≤ f p + ρ ^ 2 },
+      (∀ x,
+          f (e x) = f p + ρ ^ 2 ↔
+            x.val ∈
+              frontier ({y | f y ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock))) ∧
+        (∀ x, f x.val = f p + ρ ^ 2 → (e x).val = x.val) ∧
+          (∀ x,
+            x.val ∈
+                frontier
+                  ({y | f y ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock)) →
+              ∀ t : ℝ, t ≤ 0 → f (F t x.val) = f p + ρ ^ 2 → (e x).val = F t x.val) := by
+  have hV₁ :
+    ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)) :=
+    hV.of_le (by simp)
+  have hmono := Smale.FlowConstruction.antitone_flow_height hf F hcurve hzero hdesc
+  have hboundary (b : ℝ) (hb : b ∈ Set.Icc (f p - ρ ^ 2) (f p + ρ ^ 2)) (hne : b ≠ f p) (x : M)
+    (hx : f x = b) (t : ℝ) (ht : 0 < t) : f (F t x) < f x := by
+    have hreg : x ∉ Smale.ManifoldMorse.criticalPoints E f := by
+      intro hcrit
+      have hxp := hband x hcrit (hx ▸ hb)
+      exact hne (hx.symm.trans (congrArg f hxp))
+    simpa only [F.map_zero_apply] using
+      Smale.FlowConstruction.strictAnti_flow_height hf hV₁ F hcurve hzero hdesc hreg ht
+  have hbottom : ∀ x, f x = f p - ρ ^ 2 → ∀ t : ℝ, 0 < t → f (F t x) < f x :=
+    hboundary _ ⟨le_rfl, by linarith [sq_nonneg ρ]⟩ (by nlinarith [sq_pos_of_pos hρ])
+  have htop : ∀ x, f x = f p + ρ ^ 2 → ∀ t : ℝ, 0 < t → f (F t x) < f p + ρ ^ 2 := by
+    intro x hx t ht
+    rw [← hx]
+    exact
+      hboundary _ ⟨by linarith [sq_nonneg ρ], le_rfl⟩ (by nlinarith [sq_pos_of_pos hρ]) x hx t ht
+  have hhome :=
+    Smale.FlowConstruction.exists_absorbingSublevelHomeomorph_with_boundary_orbits hf hV hdesc F
+      hcurve hmono
+      ((isClosed_le hf.continuous continuous_const).union
+        (c.attachingHandleMap_isClosedEmbedding ρ hρ hblock).isClosed_range)
+      Set.subset_union_left (c.attachingHandleUnion_subset_upper ρ hρ hblock) (a := f p - ρ ^ 2)
+      (fun x hcrit hx => by
+        have hxp := hband x hcrit hx
+        subst x
+        exact
+          interior_mono Set.subset_union_right
+            (c.mem_interior_range_attachingHandleMap ρ hρ hblock))
+      (c.forwardInvariant_attachingUnion hf.continuous hV₁ F hcurve hmono ρ hρ hblock hagreement)
+      (c.interior_entry_attachingUnion hf.continuous hV₁ F hcurve hmono ρ hρ hblock hagreement
+        hbottom)
+      htop
+  obtain ⟨e, hfront, hfixed, horbit⟩ := hhome
+  refine ⟨e.symm, ?_, ?_, ?_⟩
+  · intro x
+    have hx := hfront (e.symm x)
+    rw [e.apply_symm_apply,
+      Smale.FlowConstruction.frontier_sublevel_eq_of_strict_flow hf.continuous F hmono htop] at hx
+    exact hx.symm
+  · intro x hx
+    let y : { x : M // f x ≤ f p + ρ ^ 2 } := ⟨x.val, hx.le⟩
+    have hy : y.val ∈ frontier {z : M | f z ≤ f p + ρ ^ 2} := by
+      rw [Smale.FlowConstruction.frontier_sublevel_eq_of_strict_flow hf.continuous F hmono htop]
+      exact hx
+    have heq : e y = x := Subtype.ext (hfixed y x.property hy)
+    have hh := congrArg e.symm heq
+    rw [e.symm_apply_apply] at hh
+    exact congrArg (fun z : { z : M // f z ≤ f p + ρ ^ 2 } => z.val) hh.symm
+  · intro x hx t ht hlevel
+    apply horbit x hx t ht
+    rw [Smale.FlowConstruction.frontier_sublevel_eq_of_strict_flow hf.continuous F hmono htop]
+    exact hlevel
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.SignedMorseChart.FollowsModelBoundaryOrbits {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (e :
+      ↥({x | f x ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock)) ≃ₜ
+        { x : M // f x ≤ f p + ρ ^ 2 }) :
+    Prop :=
+  ∀ x,
+    x.val ∈ frontier ({y | f y ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock)) →
+      x.val ∈ c.splitChart.source →
+        ∀ t : ℝ,
+          t ≤ 0 →
+            (∀ s ∈ Set.uIcc 0 t,
+                Smale.MorseHandle.descentFlow s (c.splitChart x.val) ∈
+                  Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+                    Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ)) →
+              f (c.splitChart.symm (Smale.MorseHandle.descentFlow t (c.splitChart x.val))) =
+                  f p + ρ ^ 2 →
+                (e x).val =
+                  c.splitChart.symm (Smale.MorseHandle.descentFlow t (c.splitChart x.val))
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SignedMorseChart.followsModelBoundaryOrbits_of_flow {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) [IsManifold 𝓘(ℝ, E) ∞ M]
+    [T2Space M] {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (heq :
+      ∀
+        z ∈
+          Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+            Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ),
+        ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y)
+    (e :
+      ↥({x | f x ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock)) ≃ₜ
+        { x : M // f x ≤ f p + ρ ^ 2 })
+    (horbit :
+      ∀ x,
+        x.val ∈
+            frontier ({y | f y ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock)) →
+          ∀ t : ℝ, t ≤ 0 → f (F t x.val) = f p + ρ ^ 2 → (e x).val = F t x.val) :
+    c.FollowsModelBoundaryOrbits ρ hρ hblock e := by
+  intro x hx hsource t ht hpath hlevel
+  have hmodel :=
+    c.flow_eq_descentModel_of_mem_uIcc hV F hcurve hsource (fun s hs => hblock (hpath s hs))
+      (fun s hs => heq _ (hpath s hs))
+  exact (horbit x hx t ht (hmodel ▸ hlevel)).trans hmodel
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.exists_closed_productBlock_in {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) {W : Set M} (hW : IsOpen W)
+    (hpW : p ∈ W) :
+    ∃ r > (0 : ℝ),
+      Metric.closedBall (0 : c.NegativeCoordinates) r ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) r ⊆
+        c.splitChart.target ∩ c.splitChart.symm ⁻¹' W := by
+  let e := c.splitChart.toOpenPartialHomeomorph
+  have hzero : (0 : c.NegativeCoordinates × c.PositiveCoordinates) ∈ e.target := by
+    rw [← c.splitChart_center]
+    exact e.map_source c.splitChart_mem_source
+  have hinv : e.symm 0 = p := by
+    rw [← c.splitChart_center]
+    exact e.left_inv c.splitChart_mem_source
+  have hmem : (0 : c.NegativeCoordinates × c.PositiveCoordinates) ∈ e.target ∩ e.symm ⁻¹' W :=
+    ⟨hzero, by simpa only [Set.mem_preimage, hinv] using hpW⟩
+  obtain ⟨r, hr, hsub⟩ :=
+    Metric.nhds_basis_closedBall.mem_iff.mp ((e.isOpen_inter_preimage_symm hW).mem_nhds hmem)
+  refine ⟨r, hr, ?_⟩
+  rw [closedBall_prod_same]
+  exact hsub
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.exists_fieldCompatibleBlock {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x) (heq : ∀ᶠ x in 𝓝 p, V x = c.descentField x) :
+    ∃ ρ > (0 : ℝ),
+      ∃ W : Set M,
+        IsOpen W ∧
+          p ∈ W ∧
+            (∀ x ∈ W, V x = c.descentField x) ∧
+              Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+                  Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+                c.splitChart.target ∩ c.splitChart.symm ⁻¹' W := by
+  obtain ⟨W, hWeq, hW, hpW⟩ := mem_nhds_iff.mp heq
+  obtain ⟨r, hr, hblock⟩ := c.exists_closed_productBlock_in hW hpW
+  refine ⟨r / 2, half_pos hr, W, hW, hpW, hWeq, ?_⟩
+  rw [show 2 * (r / 2) = r by ring]
+  exact hblock
+
+private theorem Smale.ManifoldMorse.exists_isolating_radius {X : Type*} {f : X → ℝ} {K : Set X}
+    (hK : K.Finite) (p : X) (hunique : ∀ x ∈ K, f x = f p → x = p) {R : ℝ} (hR : 0 < R) :
+    ∃ ρ > (0 : ℝ), ρ < R ∧ ∀ x ∈ K, f x ∈ Set.Icc (f p - ρ ^ 2) (f p + ρ ^ 2) → x = p := by
+  have hfin : (f '' (K \ { p })).Finite := (hK.subset Set.sdiff_subset).image f
+  have hnot : f p ∉ f '' (K \ { p }) := by
+    rintro ⟨x, hx, heq⟩
+    exact hx.2 (Set.mem_singleton_iff.mpr (hunique x hx.1 heq))
+  obtain ⟨δ, hδ, hball⟩ := Metric.isOpen_iff.mp hfin.isClosed.isOpen_compl (f p) hnot
+  let ρ := Min.min (R / 2) (Min.min 1 (δ / 2))
+  have hρ : 0 < ρ := lt_min (half_pos hR) (lt_min zero_lt_one (half_pos hδ))
+  have hρR : ρ < R := (min_le_left _ _).trans_lt (half_lt_self hR)
+  have hρone : ρ ≤ 1 := (min_le_right _ _).trans (min_le_left _ _)
+  have hρδ : ρ ≤ δ / 2 := (min_le_right _ _).trans (min_le_right _ _)
+  have hρsq : ρ ^ 2 < δ := by nlinarith
+  refine ⟨ρ, hρ, hρR, ?_⟩
+  intro x hx hval
+  by_contra hxp
+  have hd : Dist.dist (f x) (f p) < δ := by
+    rw [Real.dist_eq]
+    have ha : |f x - f p| ≤ ρ ^ 2 := abs_le.mpr ⟨by linarith [hval.1], by linarith [hval.2]⟩
+    exact ha.trans_lt hρsq
+  exact hball hd ⟨x, ⟨hx, by simpa only [Set.mem_singleton_iff] using hxp⟩, rfl⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SignedMorseChart.exists_isolated_fieldCompatibleBlock_lt {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (hfinite : (Smale.ManifoldMorse.criticalPoints E f).Finite)
+    (hunique : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, f x = f p → x = p)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x) (heq : ∀ᶠ x in 𝓝 p, V x = c.descentField x) {ε : ℝ}
+    (hε : 0 < ε) :
+    ∃ ρ > (0 : ℝ),
+      ρ < ε ∧
+        ∃ W : Set M,
+          IsOpen W ∧
+            p ∈ W ∧
+              (∀ x ∈ W, V x = c.descentField x) ∧
+                (Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+                      Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+                    c.splitChart.target ∩ c.splitChart.symm ⁻¹' W) ∧
+                  ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+                    f x ∈ Set.Icc (f p - ρ ^ 2) (f p + ρ ^ 2) → x = p := by
+  obtain ⟨R, hR, W, hW, hpW, heqW, hblock⟩ := c.exists_fieldCompatibleBlock V heq
+  obtain ⟨ρ, hρ, hρbound, hband⟩ :=
+    Smale.ManifoldMorse.exists_isolating_radius hfinite p hunique (lt_min hR hε)
+  have hρR : ρ < R := hρbound.trans_le (min_le_left _ _)
+  have hρε : ρ < ε := hρbound.trans_le (min_le_right _ _)
+  refine ⟨ρ, hρ, hρε, W, hW, hpW, heqW, ?_, hband⟩
+  intro z hz
+  apply hblock
+  have hr : 2 * ρ ≤ 2 * R := mul_le_mul_of_nonneg_left hρR.le (by norm_num)
+  exact ⟨Metric.closedBall_subset_closedBall hr hz.1, Metric.closedBall_subset_closedBall hr hz.2⟩
+
+private theorem Smale.ManifoldMorse.isOpen_regularInChart {E P M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup P] [NormedSpace ℝ P] [TopologicalSpace M]
+    [ChartedSpace E M] {f : P → M → ℝ}
+    (hf : ContMDiff (𝓘(ℝ, P).prod 𝓘(ℝ, E)) 𝓘(ℝ, ℝ) ∞ (Function.uncurry f))
+    {e : OpenPartialHomeomorph M E} (he : e ∈ IsManifold.maximalAtlas 𝓘(ℝ, E) ∞ M) :
+    IsOpen {q : P × M | q.2 ∈ e.source ∧ fderiv ℝ (f q.1 ∘ e.symm) (e q.2) ≠ 0} := by
+  have hU : IsOpen {q : P × E | q.2 ∈ e.target} := e.open_target.preimage continuous_snd
+  have hd :=
+    Smale.MorsePerturbation.contDiffOn_spatialDerivative (f := fun a y => f a (e.symm y)) hU
+      (contDiffOn_inChart hf he)
+  have hg :=
+    hd.continuousOn.isOpen_inter_preimage hU
+      (isClosed_singleton (x := (0 : E →L[ℝ] ℝ))).isOpen_compl
+  let S : Set (P × M) := {q | q.2 ∈ e.source}
+  have hS : IsOpen S := e.open_source.preimage continuous_snd
+  have hm : ContinuousOn (fun q : P × M => (q.1, e q.2)) S :=
+    continuous_fst.continuousOn.prodMk
+      (e.continuousOn.comp continuous_snd.continuousOn (fun _ hq => hq))
+  convert hm.isOpen_inter_preimage hS hg using 1
+  ext q
+  simp only [Set.mem_ofPred_eq, Set.mem_inter_iff, Set.mem_preimage, Set.mem_compl_iff,
+    Set.mem_singleton_iff, S]
+  constructor
+  · rintro ⟨hq, hn⟩
+    exact ⟨hq, e.map_source hq, hn⟩
+  · rintro ⟨hq, -, hn⟩
+    exact ⟨hq, hn⟩
+
+private theorem Smale.ManifoldMorse.isOpen_regularPoint {E P M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup P] [NormedSpace ℝ P] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : P → M → ℝ}
+    (hf : ContMDiff (𝓘(ℝ, P).prod 𝓘(ℝ, E)) 𝓘(ℝ, ℝ) ∞ (Function.uncurry f)) :
+    IsOpen {q : P × M | q.2 ∉ criticalPoints E (f q.1)} := by
+  have hslice (a : P) : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ (f a) :=
+    hf.comp (contMDiff_const.prodMk contMDiff_id)
+  rw [isOpen_iff_mem_nhds]
+  intro q hq
+  let e := chartAt E q.2
+  have he : e ∈ IsManifold.maximalAtlas 𝓘(ℝ, E) ∞ M := IsManifold.chart_mem_maximalAtlas q.2
+  have hx : q.2 ∈ e.source := mem_chart_source E q.2
+  have hmem : q ∈ {r : P × M | r.2 ∈ e.source ∧ fderiv ℝ (f r.1 ∘ e.symm) (e r.2) ≠ 0} :=
+    ⟨hx, fun hz => hq ((mem_criticalPoints_iff (hslice q.1) he hx).mpr hz)⟩
+  apply Filter.mem_of_superset ((isOpen_regularInChart hf he).mem_nhds hmem)
+  intro r hr hcrit
+  exact hr.2 ((mem_criticalPoints_iff (hslice r.1) he hr.1).mp hcrit)
+
+private theorem Smale.ManifoldMorse.isOpen_regularOn {E P M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup P] [NormedSpace ℝ P] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : P → M → ℝ}
+    (hf : ContMDiff (𝓘(ℝ, P).prod 𝓘(ℝ, E)) 𝓘(ℝ, ℝ) ∞ (Function.uncurry f)) {K : Set M}
+    (hK : IsCompact K) : IsOpen {a : P | ∀ x ∈ K, x ∉ criticalPoints E (f a)} :=
+  Smale.MorsePerturbation.isOpen_forall_mem_compact hK (isOpen_regularPoint hf)
+
+private theorem
+    Smale.ManifoldMorse.eventually_criticalPoints_eq {E P M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup P] [NormedSpace ℝ P] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] {f : P → M → ℝ}
+    (hf : ContMDiff (𝓘(ℝ, P).prod 𝓘(ℝ, E)) 𝓘(ℝ, ℝ) ∞ (Function.uncurry f)) (a₀ : P) {U : Set M}
+    (hU : IsOpen U) (hcover : criticalPoints E (f a₀) ⊆ U)
+    (hfixed : ∀ a x, x ∈ U → (x ∈ criticalPoints E (f a) ↔ x ∈ criticalPoints E (f a₀))) :
+    ∀ᶠ a in 𝓝 a₀, criticalPoints E (f a) = criticalPoints E (f a₀) := by
+  have hreg : ∀ x ∈ Uᶜ, x ∉ criticalPoints E (f a₀) := fun x hx hc => hx (hcover hc)
+  have hn := (isOpen_regularOn hf hU.isClosed_compl.isCompact).mem_nhds hreg
+  filter_upwards [hn] with a ha
+  ext x
+  by_cases hx : x ∈ U
+  · exact hfixed a x hx
+  · exact iff_of_false (ha x hx) (hreg x hx)
+
+private def Smale.ManifoldMorse.constantPerturb {M : Type*} (f ψ : M → ℝ) (a : ℝ) (x : M) : ℝ :=
+  f x + a * ψ x
+
+private theorem Smale.ManifoldMorse.contMDiff_constantPerturb {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f ψ : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hψ : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ ψ) :
+    ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, E)) 𝓘(ℝ, ℝ) ∞ (Function.uncurry (constantPerturb f ψ)) :=
+  (hf.comp contMDiff_snd).add (contMDiff_fst.smul (hψ.comp contMDiff_snd))
+
+private theorem Smale.ManifoldMorse.mfderiv_constantPerturb_of_locally_constant {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f ψ : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {x : M} {b : ℝ} (hψ : ψ =ᶠ[𝓝 x] fun _ => b) (a : ℝ) :
+    mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) (constantPerturb f ψ a) x = mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f x := by
+  have heq : constantPerturb f ψ a =ᶠ[𝓝 x] (fun y => f y + a * b) := by
+    filter_upwards [hψ] with y hy
+    simp only [constantPerturb, hy]
+  rw [heq.mfderiv_eq]
+  change mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) (f + fun _ => a * b) x = _
+  rw [mfderiv_add (hf.mdifferentiableAt (by simp)) mdifferentiableAt_const, mfderiv_const]
+  exact add_zero _
+
+private theorem Smale.ManifoldMorse.eventually_constantPerturb_morse_criticalPoints {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [FiniteDimensional ℝ E] [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] {f ψ : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : IsMorse E f) (hψ : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ ψ)
+    (hconstant : ∀ p ∈ criticalPoints E f, ∃ b : ℝ, ψ =ᶠ[𝓝 p] fun _ => b) :
+    ∀ᶠ a in 𝓝 (0 : ℝ),
+      IsMorse E (constantPerturb f ψ a) ∧
+        criticalPoints E (constantPerturb f ψ a) = criticalPoints E f := by
+  have hfamily := contMDiff_constantPerturb hf hψ
+  have hzero : constantPerturb f ψ 0 = f := by funext x; simp [constantPerturb]
+  have hm₀ : IsMorseOn E (constantPerturb f ψ 0) Set.univ := by
+    rw [hzero]
+    exact fun x _ => hm x
+  have hmor := (isOpen_isMorseOn hfamily isCompact_univ).mem_nhds hm₀
+  let U := ⋃ b : ℝ, interior {x : M | ψ x = b}
+  have hU : IsOpen U := isOpen_iUnion (fun _ => isOpen_interior)
+  have hcover : criticalPoints E (constantPerturb f ψ 0) ⊆ U := by
+    rw [hzero]
+    intro p hp
+    obtain ⟨b, hb⟩ := hconstant p hp
+    exact Set.mem_iUnion.mpr ⟨b, mem_interior_iff_mem_nhds.mpr hb⟩
+  have hfixed :
+    ∀ a x,
+      x ∈ U →
+        (x ∈ criticalPoints E (constantPerturb f ψ a) ↔
+          x ∈ criticalPoints E (constantPerturb f ψ 0)) := by
+    intro a x hx
+    obtain ⟨b, hb⟩ := Set.mem_iUnion.mp hx
+    have hlocal : ψ =ᶠ[𝓝 x] fun _ => b := mem_interior_iff_mem_nhds.mp hb
+    rw [hzero]
+    change mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) (constantPerturb f ψ a) x = 0 ↔ mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f x = 0
+    rw [mfderiv_constantPerturb_of_locally_constant hf hlocal a]
+    rfl
+  have hcrit := eventually_criticalPoints_eq hfamily 0 hU hcover hfixed
+  rw [hzero] at hcrit
+  filter_upwards [hmor, hcrit] with a ha hc
+  exact ⟨fun x => ha x (Set.mem_univ x), hc⟩
+
+private theorem
+    Smale.ManifoldMorse.exists_separating_critical_value {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : IsMorse E f) (p : M) :
+    ∃ g : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+        IsMorse E g ∧
+          criticalPoints E g = criticalPoints E f ∧
+            (∀ x ∈ criticalPoints E f, x ≠ p → g x = f x) ∧
+              ∀ x ∈ criticalPoints E f, g x = g p → x = p := by
+  classical
+  let K := criticalPoints E f
+  have hK : K.Finite := finite_criticalPoints hf hm
+  have hclosed : IsClosed (K \ { p }) := (hK.subset Set.sdiff_subset).isClosed
+  have hp : p ∈ (K \ { p })ᶜ := by simp
+  obtain ⟨ψ, _, hψsub⟩ :=
+    (SmoothBumpFunction.nhds_basis_tsupport (I := 𝓘(ℝ, E)) p).mem_iff.mp
+      (hclosed.isOpen_compl.mem_nhds hp)
+  have hψone : (ψ : M → ℝ) =ᶠ[𝓝 p] fun _ => 1 := ψ.eventuallyEq_one
+  have hψzero (x : M) (hx : x ∈ K) (hxp : x ≠ p) : (ψ : M → ℝ) =ᶠ[𝓝 x] fun _ => 0 := by
+    apply notMem_tsupport_iff_eventuallyEq.mp
+    intro h
+    exact hψsub h ⟨hx, by simpa only [Set.mem_singleton_iff] using hxp⟩
+  have hconstant : ∀ x ∈ criticalPoints E f, ∃ b : ℝ, (ψ : M → ℝ) =ᶠ[𝓝 x] fun _ => b := by
+    intro x hx
+    by_cases hxp : x = p
+    · subst x
+      exact ⟨1, hψone⟩
+    · exact ⟨0, hψzero x hx hxp⟩
+  have hstable := eventually_constantPerturb_morse_criticalPoints hf hm ψ.contMDiff hconstant
+  let T : Set ℝ := (fun x => f x - f p) '' (K \ { p })
+  have hT : T.Finite := (hK.subset Set.sdiff_subset).image _
+  have hdense : Dense Tᶜ := by
+    have heq : (Set.univ : Set ℝ) \ T = Tᶜ := by
+      ext a
+      exact and_iff_right (Set.mem_univ a)
+    rw [← heq]
+    exact dense_univ.sdiff_finite hT
+  obtain ⟨U, hUstable, hU, hzeroU⟩ := _root_.mem_nhds_iff.mp hstable
+  obtain ⟨a, haT, haU⟩ := hdense.exists_mem_open hU ⟨0, hzeroU⟩
+  let g := constantPerturb f ψ a
+  have hvalues (x : M) (hx : x ∈ K) (hxp : x ≠ p) : g x = f x := by
+    have hxzero : ψ x = 0 := (hψzero x hx hxp).eq_of_nhds
+    simp only [g, constantPerturb, hxzero, MulZeroClass.mul_zero, add_zero]
+  have hpvalue : g p = f p + a := by
+    have hpone : ψ p = 1 := hψone.eq_of_nhds
+    simp only [g, constantPerturb, hpone, mul_one]
+  refine
+    ⟨g, (contMDiff_constantPerturb hf ψ.contMDiff).comp (contMDiff_const.prodMk contMDiff_id),
+      (hUstable haU).1, (hUstable haU).2, hvalues, ?_⟩
+  intro x hx heq
+  by_contra hxp
+  have hax : f x - f p = a := by rw [hvalues x hx hxp, hpvalue] at heq; linarith
+  exact haT ⟨x, ⟨hx, by simpa only [Set.mem_singleton_iff] using hxp⟩, hax⟩
+
+private theorem
+    Smale.ManifoldMorse.exists_distinct_critical_values {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : IsMorse E f) :
+    ∃ g : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+        IsMorse E g ∧
+          criticalPoints E g = criticalPoints E f ∧ Set.InjOn g (criticalPoints E g) := by
+  classical
+  let K := criticalPoints E f
+  have hK : K.Finite := finite_criticalPoints hf hm
+  have hfinite :
+    ∀ s : Finset M,
+      (s : Set M) ⊆ K →
+        ∃ g : M → ℝ,
+          ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+            IsMorse E g ∧ criticalPoints E g = K ∧ Set.InjOn g (s : Set M) := by
+    intro s
+    induction s using Finset.induction_on with
+    | empty =>
+      intro _
+      exact ⟨f, hf, hm, rfl, by simp⟩
+    | @insert p s hps ih =>
+      intro hsK
+      have hsK' : (s : Set M) ⊆ K := fun x hx => hsK (Finset.mem_insert_of_mem hx)
+      obtain ⟨g, hg, hmg, hcrit, hinj⟩ := ih hsK'
+      obtain ⟨g', hg', hmg', hcrit', hfixed, hunique⟩ := exists_separating_critical_value hg hmg p
+      have hK' : criticalPoints E g' = K := hcrit'.trans hcrit
+      refine ⟨g', hg', hmg', hK', ?_⟩
+      intro x hx y hy heq
+      have hxcrit : x ∈ criticalPoints E g := hcrit ▸ hsK hx
+      have hycrit : y ∈ criticalPoints E g := hcrit ▸ hsK hy
+      by_cases hxp : x = p
+      · subst x
+        exact (hunique y hycrit heq.symm).symm
+      by_cases hyp : y = p
+      · subst y
+        exact hunique x hxcrit heq
+      have hxs : x ∈ (s : Set M) := (Finset.mem_insert.mp hx).resolve_left hxp
+      have hys : y ∈ (s : Set M) := (Finset.mem_insert.mp hy).resolve_left hyp
+      apply hinj hxs hys
+      rw [← hfixed x hxcrit hxp, ← hfixed y hycrit hyp]
+      exact heq
+  obtain ⟨g, hg, hmg, hcrit, hinj⟩ := hfinite hK.toFinset (by simp)
+  refine ⟨g, hg, hmg, hcrit, ?_⟩
+  rw [hcrit]
+  simpa only [hK.coe_toFinset] using hinj
+
+private theorem Smale.ManifoldMorse.exists_morse_function_with_distinct_critical_values (E : Type*)
+    (M : Type*) [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    [CompactSpace M] :
+    ∃ f : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f ∧
+        IsMorse E f ∧ (criticalPoints E f).Finite ∧ Set.InjOn f (criticalPoints E f) := by
+  obtain ⟨f, hf, hm⟩ := exists_morse_function E M
+  obtain ⟨g, hg, hmg, _, hinj⟩ := exists_distinct_critical_values hf hm
+  exact ⟨g, hg, hmg, finite_criticalPoints hg hmg, hinj⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.exists_morse_boundary_attachment_with_model_orbits_lt {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : IsMorse E f) {p : M} (hp : p ∈ criticalPoints E f)
+    (hunique : ∀ x ∈ criticalPoints E f, f x = f p → x = p) {ε : ℝ} (hε : 0 < ε) :
+    ∃ (ρ : ℝ) (hρ : 0 < ρ),
+      ρ < ε ∧
+        ∃ c : SignedMorseChart (E := E) f p,
+          ∃ hblock :
+            Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+                Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+              c.splitChart.target,
+            ∃ e :
+              ↥({x | f x ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock)) ≃ₜ
+                { x : M // f x ≤ f p + ρ ^ 2 },
+              (∀ x,
+                  f (e x) = f p + ρ ^ 2 ↔
+                    x.val ∈
+                      frontier
+                        ({y | f y ≤ f p - ρ ^ 2} ∪
+                          Set.range (c.attachingHandleMap ρ hρ hblock))) ∧
+                (∀ x, f x.val = f p + ρ ^ 2 → (e x).val = x.val) ∧
+                  (frontier {x | f x ≤ f p - ρ ^ 2} = {x | f x = f p - ρ ^ 2}) ∧
+                    (∀ x, f x = f p - ρ ^ 2 → x ∉ criticalPoints E f) ∧
+                      (∀ x, f x = f p + ρ ^ 2 → x ∉ criticalPoints E f) ∧
+                        c.FollowsModelBoundaryOrbits ρ hρ hblock e ∧
+                          ∀ x ∈ criticalPoints E f,
+                            f x ∈ Set.Icc (f p - ρ ^ 2) (f p + ρ ^ 2) → x = p := by
+  obtain ⟨V, F, hV, hcurve, hzero, hdesc, hcharts, _, _, _⟩ :=
+    Smale.FlowConstruction.exists_adaptedDescentFlow hf hm
+  obtain ⟨c, heq⟩ := hcharts p hp
+  obtain ⟨ρ, hρ, hρε, W, hW, _, heqW, hblockW, hband⟩ :=
+    c.exists_isolated_fieldCompatibleBlock_lt (finite_criticalPoints hf hm) hunique V heq hε
+  have hblock :
+    Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+        Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+      c.splitChart.target :=
+    fun z hz => (hblockW hz).1
+  have hagreement :
+    ∀ x ∈ Set.range (c.attachingHandleMap ρ hρ hblock), ∀ᶠ y in 𝓝 x, V y = c.descentField y := by
+    rintro _ ⟨z, rfl⟩
+    have hxW : c.attachingHandleMap ρ hρ hblock z ∈ W :=
+      (hblockW (Smale.MorseHandle.modelMap_mem_product hρ z)).2
+    filter_upwards [hW.mem_nhds hxW] with y hy
+    exact heqW y hy
+  obtain ⟨e, hfront, hfixed, horbit⟩ :=
+    c.exists_attachingUnionHomeomorph_with_level_and_orbits hf hV hzero hdesc F hcurve ρ hρ hblock
+      hagreement hband
+  have hmono := Smale.FlowConstruction.antitone_flow_height hf F hcurve hzero hdesc
+  have hregular (b : ℝ) (hb : b ∈ Set.Icc (f p - ρ ^ 2) (f p + ρ ^ 2)) (hne : b ≠ f p) (x : M)
+    (hx : f x = b) : x ∉ criticalPoints E f := by
+    intro hcrit
+    have hxp := hband x hcrit (hx ▸ hb)
+    exact hne (hx.symm.trans (congrArg f hxp))
+  have hlower : ∀ x, f x = f p - ρ ^ 2 → x ∉ criticalPoints E f :=
+    hregular _ ⟨le_rfl, by linarith [sq_nonneg ρ]⟩ (by nlinarith [sq_pos_of_pos hρ])
+  have hupper : ∀ x, f x = f p + ρ ^ 2 → x ∉ criticalPoints E f :=
+    hregular _ ⟨by linarith [sq_nonneg ρ], le_rfl⟩ (by nlinarith [sq_pos_of_pos hρ])
+  have hbottom : ∀ x, f x = f p - ρ ^ 2 → ∀ t : ℝ, 0 < t → f (F t x) < f p - ρ ^ 2 := by
+    intro x hx t ht
+    have hstrict :=
+      Smale.FlowConstruction.strictAnti_flow_height hf (hV.of_le (by simp)) F hcurve hzero hdesc
+        (hlower x hx) ht
+    simpa only [F.map_zero_apply, hx] using hstrict
+  refine
+    ⟨ρ, hρ, hρε, c, hblock, e, hfront, hfixed,
+      Smale.FlowConstruction.frontier_sublevel_eq_of_strict_flow hf.continuous F hmono hbottom,
+      hlower, hupper, ?_, hband⟩
+  apply
+    c.followsModelBoundaryOrbits_of_flow (hV.of_le (by simp)) F hcurve ρ hρ hblock (e := e)
+      (horbit := horbit)
+  intro z hz
+  filter_upwards [hW.mem_nhds (hblockW hz).2] with y hy
+  exact heqW y hy
+
+private def Smale.SurgeryBoundaryPair.changeNewBoundary {N P R X Y Z : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    [TopologicalSpace Z] (d : Smale.SurgeryBoundaryPair N P R X Y) (e : Y ≃ₜ Z) :
+    Smale.SurgeryBoundaryPair N P R X Z
+    where
+  oldExterior := d.oldExterior
+  newExterior := e ∘ d.newExterior
+  oldPiece := d.oldPiece
+  newPiece := e ∘ d.newPiece
+  oldExterior_closed := d.oldExterior_closed
+  newExterior_closed := e.isClosedEmbedding.comp d.newExterior_closed
+  oldPiece_closed := d.oldPiece_closed
+  newPiece_closed := e.isClosedEmbedding.comp d.newPiece_closed
+  old_cover := d.old_cover
+  new_cover := by
+    apply Set.eq_univ_of_forall
+    intro z
+    have hz : e.symm z ∈ Set.range d.newExterior ∪ Set.range d.newPiece := by
+      rw [d.new_cover]
+      trivial
+    rcases hz with ⟨r, hr⟩ | ⟨p, hp⟩
+    · exact Or.inl ⟨r, (congrArg e hr).trans (e.apply_symm_apply z)⟩
+    · exact Or.inr ⟨p, (congrArg e hp).trans (e.apply_symm_apply z)⟩
+  boundary := d.boundary
+  old_overlap := d.old_overlap
+  new_overlap := fun r p => e.injective.eq_iff.trans (d.new_overlap r p)
+
+private def
+    Smale.ClosedCover.frontierLevelHomeomorph {M : Type*} [TopologicalSpace M] {f : M → ℝ} {b : ℝ}
+    {A : Set M} (hA : IsClosed A) (e : A ≃ₜ { x : M // f x ≤ b })
+    (he : ∀ x, f (e x) = b ↔ (x : M) ∈ frontier A) : frontier A ≃ₜ { x : M // f x = b } := by
+  have hsub : frontier A ⊆ A := by
+    intro x hx
+    have hc := frontier_subset_closure hx
+    rwa [hA.closure_eq] at hc
+  let toA : frontier A → A := Set.inclusion hsub
+  let toB : { x : M // f x = b } → { x : M // f x ≤ b } := fun x => ⟨x, x.property.le⟩
+  refine
+    { toFun := fun x => ⟨e (toA x), (he (toA x)).mpr x.property⟩
+      invFun := fun y => ⟨e.symm (toB y), ?_⟩
+      left_inv := ?_
+      right_inv := ?_
+      continuous_toFun := ?_
+      continuous_invFun := ?_ }
+  · apply (he (e.symm (toB y))).mp
+    rw [e.apply_symm_apply]
+    exact y.property
+  · intro x
+    apply Subtype.ext
+    exact congrArg (fun z : A => (z : M)) (e.symm_apply_apply (toA x))
+  · intro y
+    apply Subtype.ext
+    exact congrArg (fun z : { x : M // f x ≤ b } => (z : M)) (e.apply_symm_apply (toB y))
+  · exact
+      (continuous_subtype_val.comp
+            (e.continuous.comp (continuous_subtype_val.subtype_mk _))).subtype_mk
+        _
+  · exact
+      (continuous_subtype_val.comp
+            (e.symm.continuous.comp (continuous_subtype_val.subtype_mk _))).subtype_mk
+        _
+
+private theorem Smale.SurgeryBoundaryPair.exchange_preserves_incidence {E F R X Y : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair E F R X Y) (r : R)
+    (p : Smale.PuncturedHandle.UnitSphere E × Smale.PuncturedHandle.PuncturedBall F) :
+    d.oldExteriorMap r = d.oldPuncturedMap p ↔
+      d.newExteriorMap r = d.newPuncturedMap (Smale.PuncturedHandle.exchange E F p) := by
+  rw [d.oldPunctured_overlap, d.newPunctured_overlap]
+  constructor
+  · rintro ⟨q, hr, rfl⟩
+    exact ⟨q, hr, Smale.PuncturedHandle.exchange_boundary q.1 q.2⟩
+  · rintro ⟨q, hr, hq⟩
+    refine ⟨q, hr, (Smale.PuncturedHandle.exchange E F).injective ?_⟩
+    exact hq.trans (Smale.PuncturedHandle.exchange_boundary q.1 q.2).symm
+
+private def
+    Smale.SurgeryBoundaryPair.complementHomeomorph {E F R X Y : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace R]
+    [TopologicalSpace X] [TopologicalSpace Y] (d : Smale.SurgeryBoundaryPair E F R X Y) :
+    d.OldComplement ≃ₜ d.NewComplement :=
+  Smale.ClosedCover.homeomorphOfClosedPieces d.oldExteriorMap d.newExteriorMap d.oldPuncturedMap
+    d.newPuncturedMap d.isClosedEmbedding_oldExteriorMap d.isClosedEmbedding_newExteriorMap
+    d.isClosedEmbedding_oldPuncturedMap d.isClosedEmbedding_newPuncturedMap d.oldComplement_cover
+    d.newComplement_cover (Smale.PuncturedHandle.exchange E F) d.exchange_preserves_incidence
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.SignedMorseChart.boundaryLevelHomeomorph {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (hf : Continuous f) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (e :
+      ↥({x | f x ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock)) ≃ₜ
+        { x : M // f x ≤ f p + ρ ^ 2 })
+    (he :
+      ∀ x,
+        f (e x) = f p + ρ ^ 2 ↔
+          x.val ∈
+            frontier ({y | f y ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock))) :
+    frontier ({x | f x ≤ f p - ρ ^ 2} ∪ Set.range (c.normHandleMap ρ hρ hblock)) ≃ₜ
+      { x : M // f x = f p + ρ ^ 2 } :=
+  (Homeomorph.setCongr (by rw [c.range_normHandleMap ρ hρ hblock])).trans
+    (Smale.ClosedCover.frontierLevelHomeomorph
+      ((isClosed_le hf continuous_const).union
+        (c.attachingHandleMap_isClosedEmbedding ρ hρ hblock).isClosed_range)
+      e he)
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.SignedMorseChart.levelSurgeryBoundaryPair {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (hf : Continuous f) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (hlevel : frontier {x | f x ≤ f p - ρ ^ 2} = {x | f x = f p - ρ ^ 2})
+    (e :
+      ↥({x | f x ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock)) ≃ₜ
+        { x : M // f x ≤ f p + ρ ^ 2 })
+    (he :
+      ∀ x,
+        f (e x) = f p + ρ ^ 2 ↔
+          x.val ∈
+            frontier ({y | f y ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock))) :
+    Smale.SurgeryBoundaryPair c.NegativeCoordinates c.PositiveCoordinates
+      { x : M //
+        f x = f p - ρ ^ 2 ∧
+          x ∈ frontier ({y | f y ≤ f p - ρ ^ 2} ∪ Set.range (c.normHandleMap ρ hρ hblock)) }
+      { x : M // f x = f p - ρ ^ 2 } { x : M // f x = f p + ρ ^ 2 } :=
+  (c.attachmentBoundaryData hf ρ hρ hblock hlevel).surgeryBoundaryPair.changeNewBoundary
+    (c.boundaryLevelHomeomorph hf ρ hρ hblock e he)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.normHandleMap_belt_height {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (v : Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates) :
+    f
+        (c.normHandleMap ρ hρ hblock
+          (Smale.PuncturedHandle.ballZero, Smale.PuncturedHandle.sphereToBall v)) =
+      f p + ρ ^ 2 := by
+  change
+    f
+        (c.attachingHandleMap ρ hρ hblock
+          (⟨0, by simp⟩,
+            ⟨(v : c.PositiveCoordinates), Metric.sphere_subset_closedBall v.property⟩)) =
+      _
+  rw [c.attachingHandleMap_quadratic]
+  have hv : ‖(v : c.PositiveCoordinates)‖ = 1 := mem_sphere_zero_iff_norm.mp v.property
+  simp [Smale.MorseHandle.modelMap, norm_smul, Real.norm_eq_abs, abs_of_pos hρ, hv]
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.SignedMorseChart.beltCoreMap {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target) :
+    C(Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates, { y : M // f y = f p + ρ ^ 2 })
+    where
+  toFun
+    v :=
+    ⟨c.normHandleMap ρ hρ hblock
+        (Smale.PuncturedHandle.ballZero, Smale.PuncturedHandle.sphereToBall v),
+      c.normHandleMap_belt_height ρ hρ hblock v⟩
+  continuous_toFun :=
+    ((c.normHandleMap ρ hρ hblock).continuous.comp
+          (continuous_const.prodMk (continuous_subtype_val.subtype_mk _))).subtype_mk
+      _
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SignedMorseChart.beltCoreMap_coe {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (v : Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates) :
+    (c.beltCoreMap ρ hρ hblock v : M) = c.splitChart.symm (0, ρ • (v : c.PositiveCoordinates)) := by
+  change
+    c.splitChart.symm
+        ((ρ * Real.sqrt (1 + ‖(v : c.PositiveCoordinates)‖ ^ 2)) • (0 : c.NegativeCoordinates),
+          ρ • (v : c.PositiveCoordinates)) =
+      _
+  simp only [smul_zero]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.contMDiff_beltCoreMap_ambient {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (n : ℕ)
+    [Fact (Module.finrank ℝ c.PositiveCoordinates = n + 1)] (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target) :
+    ContMDiff (𝓡 n) 𝓘(ℝ, E) ∞ (Subtype.val ∘ c.beltCoreMap ρ hρ hblock) := by
+  have heq :
+    Subtype.val ∘ c.beltCoreMap ρ hρ hblock =
+      fun v : Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates =>
+      c.splitChart.symm (0, ρ • (v : c.PositiveCoordinates)) :=
+    funext (c.beltCoreMap_coe ρ hρ hblock)
+  rw [heq]
+  have hcoe :
+    ContMDiff (𝓡 n) 𝓘(ℝ, c.PositiveCoordinates) ∞
+      (Subtype.val :
+        Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates → c.PositiveCoordinates) :=
+    contMDiff_coe_sphere (E := c.PositiveCoordinates) (n := n)
+  have hscalar :
+    ContMDiff (𝓡 n) 𝓘(ℝ, ℝ) ∞
+      (fun _ : Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates => ρ) :=
+    contMDiff_const
+  have hpositive :
+    ContMDiff (𝓡 n) 𝓘(ℝ, c.PositiveCoordinates) ∞
+      (fun v : Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates =>
+        ρ • (v : c.PositiveCoordinates)) :=
+    hscalar.smul hcoe
+  have hcoords :
+    ContMDiff (𝓡 n) 𝓘(ℝ, c.NegativeCoordinates × c.PositiveCoordinates) ∞
+      (fun v : Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates =>
+        ((0 : c.NegativeCoordinates), ρ • (v : c.PositiveCoordinates))) :=
+    contMDiff_const.prodMk_space hpositive
+  apply c.splitChart.contMDiffOn_invFun.comp_contMDiff hcoords
+  intro v
+  have hh :=
+    hblock
+      (Smale.MorseHandle.modelMap_mem_product hρ
+        ((⟨0, by simp⟩ : Smale.MorseHandle.UnitDisk c.NegativeCoordinates),
+          ⟨(v : c.PositiveCoordinates), Metric.sphere_subset_closedBall v.property⟩))
+  simpa [Smale.MorseHandle.modelMap] using hh
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.beltSphere_eq_beltCoreMap {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) [T2Space M]
+    (hf : Continuous f) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (hlevel : frontier {x | f x ≤ f p - ρ ^ 2} = {x | f x = f p - ρ ^ 2})
+    (e :
+      ↥({x | f x ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock)) ≃ₜ
+        { x : M // f x ≤ f p + ρ ^ 2 })
+    (he :
+      ∀ x,
+        f (e x) = f p + ρ ^ 2 ↔
+          x.val ∈
+            frontier ({y | f y ≤ f p - ρ ^ 2} ∪ Set.range (c.attachingHandleMap ρ hρ hblock)))
+    (hfixed : ∀ x, f x.val = f p + ρ ^ 2 → (e x).val = x.val) :
+    (c.levelSurgeryBoundaryPair hf ρ hρ hblock hlevel e he).beltSphere =
+      c.beltCoreMap ρ hρ hblock := by
+  apply ContinuousMap.ext
+  intro v
+  apply Subtype.ext
+  exact hfixed _ (c.normHandleMap_belt_height ρ hρ hblock v)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.contMDiff_beltCoreMap {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (n : ℕ) [Fact (Module.finrank ℝ c.PositiveCoordinates = n + 1)]
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (hreg : ∀ x, f x = f p + ρ ^ 2 → x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    letI := Smale.RegularLevel.chartedSpace hf hreg
+    ContMDiff (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ (c.beltCoreMap ρ hρ hblock) := by
+  let _ := Smale.RegularLevel.chartedSpace hf hreg
+  exact
+    (Smale.RegularLevel.contMDiff_iff_inclusion hf hreg (𝓡 n) (c.beltCoreMap ρ hρ hblock)).mpr
+      (c.contMDiff_beltCoreMap_ambient n ρ hρ hblock)
+
+private def Smale.PartialChart.restrictSource {E F H H' M N : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H]
+    [TopologicalSpace H'] {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ F H'}
+    [TopologicalSpace M] [ChartedSpace H M] [TopologicalSpace N] [ChartedSpace H' N]
+    (Φ : PartialDiffeomorph I J M N ∞) {U : Set M} (hU : IsOpen U) : PartialDiffeomorph I J M N ∞
+    where
+  toPartialEquiv := (Φ.toOpenPartialHomeomorph.restrOpen U hU).toPartialEquiv
+  open_source := (Φ.toOpenPartialHomeomorph.restrOpen U hU).open_source
+  open_target := (Φ.toOpenPartialHomeomorph.restrOpen U hU).open_target
+  contMDiffOn_toFun := Φ.contMDiffOn_toFun.mono Set.inter_subset_left
+  contMDiffOn_invFun := Φ.contMDiffOn_invFun.mono Set.inter_subset_left
+
+private def Smale.PartialChart.restrictTarget {E F H H' M N : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H]
+    [TopologicalSpace H'] {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ F H'}
+    [TopologicalSpace M] [ChartedSpace H M] [TopologicalSpace N] [ChartedSpace H' N]
+    (Φ : PartialDiffeomorph I J M N ∞) {V : Set N} (hV : IsOpen V) :
+    PartialDiffeomorph I J M N ∞ :=
+  (restrictSource Φ.symm hV).symm
+
+public
+theorem Smale.PartialChart.bijective_mfderiv {E F H H' M N : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H]
+    [TopologicalSpace H'] {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ F H'}
+    [TopologicalSpace M] [ChartedSpace H M] [TopologicalSpace N] [ChartedSpace H' N]
+    (Φ : PartialDiffeomorph I J M N ∞) {x : M} (hx : x ∈ Φ.source) :
+    Function.Bijective (mfderiv I J Φ x) := by
+  have hdiff : Φ.toOpenPartialHomeomorph.MDifferentiable I J :=
+    ⟨Φ.mdifferentiableOn (by simp), Φ.symm.mdifferentiableOn (by simp)⟩
+  exact hdiff.mfderiv_bijective hx
+
+private theorem Smale.PartialChart.injective_mfderiv_linear_sphere {N F E H M : Type*}
+    [NormedAddCommGroup N] [InnerProductSpace ℝ N] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [TopologicalSpace M] [ChartedSpace H M] {n : ℕ} [Fact (Module.finrank ℝ N = n + 1)]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, F) I F M ∞) (L : N →L[ℝ] F) (hL : Function.Injective L)
+    (u : Metric.sphere (0 : N) 1) (hu : L (u : N) ∈ Φ.source) :
+    Function.Injective (mfderiv (𝓡 n) I (fun v : Metric.sphere (0 : N) 1 => Φ (L (v : N))) u) := by
+  have hcoesm : ContMDiff (𝓡 n) 𝓘(ℝ, N) ∞ (Subtype.val : Metric.sphere (0 : N) 1 → N) :=
+    contMDiff_coe_sphere (E := N) (n := n)
+  have hcoe := hcoesm.mdifferentiableAt (x := u) (by simp)
+  have hlinear : MDifferentiableAt 𝓘(ℝ, N) 𝓘(ℝ, F) L (u : N) :=
+    L.differentiableAt.mdifferentiableAt
+  have hinner := hlinear.comp u hcoe
+  have hsphere :
+    Function.Injective (mfderiv (𝓡 n) 𝓘(ℝ, N) (Subtype.val : Metric.sphere (0 : N) 1 → N) u) := by
+    convert! injective_mvfderiv_subtypeVal_sphere u
+  change Function.Injective (mfderiv (𝓡 n) I (Φ ∘ (L ∘ Subtype.val)) u)
+  rw [mfderiv_comp u (Φ.mdifferentiableAt (by simp) hu) hinner, mfderiv_comp u hlinear hcoe,
+    mfderiv_eq_fderiv, L.fderiv]
+  exact (bijective_mfderiv Φ hu).injective.comp (hL.comp hsphere)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.injective_attachingCoreMap {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target) :
+    Function.Injective (c.attachingCoreMap ρ hρ hblock) := by
+  intro u v huv
+  have hh :=
+    c.attachingHandleMap_injective ρ hρ hblock
+      (congrArg (fun y : { y : M // f y = f p - ρ ^ 2 } => (y : M)) huv)
+  exact Subtype.ext (congrArg (fun z => (z.1 : c.NegativeCoordinates)) hh)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.injective_beltCoreMap {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target) :
+    Function.Injective (c.beltCoreMap ρ hρ hblock) := by
+  intro u v huv
+  have hh :=
+    c.attachingHandleMap_injective ρ hρ hblock
+      (congrArg (fun y : { y : M // f y = f p + ρ ^ 2 } => (y : M)) huv)
+  exact Subtype.ext (congrArg (fun z => (z.2 : c.PositiveCoordinates)) hh)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SignedMorseChart.attachingCoreMap_isClosedEmbedding {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) [T2Space M] (ρ : ℝ)
+    (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target) :
+    Topology.IsClosedEmbedding (c.attachingCoreMap ρ hρ hblock) :=
+  (c.attachingCoreMap ρ hρ hblock).continuous.isClosedEmbedding
+    (c.injective_attachingCoreMap ρ hρ hblock)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.beltCoreMap_isClosedEmbedding {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) [T2Space M] (ρ : ℝ)
+    (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target) :
+    Topology.IsClosedEmbedding (c.beltCoreMap ρ hρ hblock) :=
+  (c.beltCoreMap ρ hρ hblock).continuous.isClosedEmbedding (c.injective_beltCoreMap ρ hρ hblock)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.injective_mfderiv_attachingCoreMap_ambient
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {f : M → ℝ} {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (n : ℕ)
+    [Fact (Module.finrank ℝ c.NegativeCoordinates = n + 1)] (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (u : Smale.PuncturedHandle.UnitSphere c.NegativeCoordinates) :
+    Function.Injective (mfderiv (𝓡 n) 𝓘(ℝ, E) (Subtype.val ∘ c.attachingCoreMap ρ hρ hblock) u) :=
+  by
+  let L : c.NegativeCoordinates →L[ℝ] c.NegativeCoordinates × c.PositiveCoordinates :=
+    ρ • ContinuousLinearMap.inl ℝ c.NegativeCoordinates c.PositiveCoordinates
+  have hL : Function.Injective L := by
+    intro x y hxy
+    apply smul_right_injective c.NegativeCoordinates hρ.ne'
+    exact congrArg Prod.fst hxy
+  have hu : L (u : c.NegativeCoordinates) ∈ c.splitChart.target := by
+    have hh :=
+      hblock
+        (Smale.MorseHandle.modelMap_mem_product hρ
+          (⟨(u : c.NegativeCoordinates), Metric.sphere_subset_closedBall u.property⟩,
+            (⟨0, by simp⟩ : Smale.MorseHandle.UnitDisk c.PositiveCoordinates)))
+    simpa [L, Smale.MorseHandle.modelMap] using hh
+  have heq :
+    Subtype.val ∘ c.attachingCoreMap ρ hρ hblock =
+      fun v : Smale.PuncturedHandle.UnitSphere c.NegativeCoordinates => c.splitChart.symm (L v) :=
+    by
+    funext v
+    rw [Function.comp_apply, c.attachingCoreMap_coe]
+    congr 1
+    simp [L]
+  rw [heq]
+  exact Smale.PartialChart.injective_mfderiv_linear_sphere c.splitChart.symm L hL u hu
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SignedMorseChart.injective_mfderiv_beltCoreMap_ambient {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (n : ℕ)
+    [Fact (Module.finrank ℝ c.PositiveCoordinates = n + 1)] (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (v : Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates) :
+    Function.Injective (mfderiv (𝓡 n) 𝓘(ℝ, E) (Subtype.val ∘ c.beltCoreMap ρ hρ hblock) v) := by
+  let L : c.PositiveCoordinates →L[ℝ] c.NegativeCoordinates × c.PositiveCoordinates :=
+    ρ • ContinuousLinearMap.inr ℝ c.NegativeCoordinates c.PositiveCoordinates
+  have hL : Function.Injective L := by
+    intro x y hxy
+    apply smul_right_injective c.PositiveCoordinates hρ.ne'
+    exact congrArg Prod.snd hxy
+  have hv : L (v : c.PositiveCoordinates) ∈ c.splitChart.target := by
+    have hh :=
+      hblock
+        (Smale.MorseHandle.modelMap_mem_product hρ
+          ((⟨0, by simp⟩ : Smale.MorseHandle.UnitDisk c.NegativeCoordinates),
+            ⟨(v : c.PositiveCoordinates), Metric.sphere_subset_closedBall v.property⟩))
+    simpa [L, Smale.MorseHandle.modelMap] using hh
+  have heq :
+    Subtype.val ∘ c.beltCoreMap ρ hρ hblock =
+      fun u : Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates => c.splitChart.symm (L u) :=
+    by
+    funext u
+    rw [Function.comp_apply, c.beltCoreMap_coe]
+    congr 1
+    simp [L]
+  rw [heq]
+  exact Smale.PartialChart.injective_mfderiv_linear_sphere c.splitChart.symm L hL v hv
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SignedMorseChart.injective_mfderiv_attachingCoreMap {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (n : ℕ) [Fact (Module.finrank ℝ c.NegativeCoordinates = n + 1)]
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (hreg : ∀ x, f x = f p - ρ ^ 2 → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (u : Smale.PuncturedHandle.UnitSphere c.NegativeCoordinates) :
+    letI := Smale.RegularLevel.chartedSpace hf hreg
+    Function.Injective
+      (mfderiv (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) (c.attachingCoreMap ρ hρ hblock) u) := by
+  exact
+    Smale.RegularLevel.injective_mfderiv_of_inclusion hf hreg (𝓡 n)
+      (c.attachingCoreMap ρ hρ hblock) u (c.contMDiff_attachingCoreMap_ambient n ρ hρ hblock u)
+      (c.injective_mfderiv_attachingCoreMap_ambient n ρ hρ hblock u)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.injective_mfderiv_beltCoreMap {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (n : ℕ) [Fact (Module.finrank ℝ c.PositiveCoordinates = n + 1)]
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (hreg : ∀ x, f x = f p + ρ ^ 2 → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (v : Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates) :
+    letI := Smale.RegularLevel.chartedSpace hf hreg
+    Function.Injective
+      (mfderiv (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) (c.beltCoreMap ρ hρ hblock) v) := by
+  exact
+    Smale.RegularLevel.injective_mfderiv_of_inclusion hf hreg (𝓡 n) (c.beltCoreMap ρ hρ hblock) v
+      (c.contMDiff_beltCoreMap_ambient n ρ hρ hblock v)
+      (c.injective_mfderiv_beltCoreMap_ambient n ρ hρ hblock v)
+
+private def Smale.ManifoldSmoothing.flattenTime (t : unitInterval) : unitInterval :=
+  ⟨Max.max 0 (Min.min 1 (3 * (t : ℝ) - 1)), le_max_left _ _, max_le zero_le_one (min_le_left _ _)⟩
+
+private theorem Smale.ManifoldSmoothing.continuous_flattenTime : Continuous flattenTime :=
+  (continuous_const.max
+      (continuous_const.min
+        ((continuous_const.mul continuous_subtype_val).sub continuous_const))) |>.subtype_mk
+    _
+
+private theorem
+    Smale.ManifoldSmoothing.flattenTime_eq_zero (t : unitInterval) (ht : (t : ℝ) ≤ 1 / 3) :
+    flattenTime t = 0 := by
+  apply Subtype.ext
+  change Max.max 0 (Min.min 1 (3 * (t : ℝ) - 1)) = 0
+  exact max_eq_left ((min_le_right _ _).trans (by linarith))
+
+private theorem
+    Smale.ManifoldSmoothing.flattenTime_eq_one (t : unitInterval) (ht : 2 / 3 ≤ (t : ℝ)) :
+    flattenTime t = 1 := by
+  apply Subtype.ext
+  change Max.max 0 (Min.min 1 (3 * (t : ℝ) - 1)) = 1
+  rw [min_eq_left (by linarith), max_eq_right zero_le_one]
+
+private def Smale.ManifoldSmoothing.flattenedHomotopyMap {X N : Type*} [TopologicalSpace X]
+    [TopologicalSpace N] {f g : C(X, N)} (H : f.Homotopy g) : C(unitInterval × X, N)
+    where
+  toFun q := H (flattenTime q.1, q.2)
+  continuous_toFun :=
+    H.continuous.comp ((continuous_flattenTime.comp continuous_fst).prodMk continuous_snd)
+
+private theorem
+    Smale.ManifoldSmoothing.flattenedHomotopyMap_lower {X N : Type*} [TopologicalSpace X]
+    [TopologicalSpace N] {f g : C(X, N)} (H : f.Homotopy g) (t : unitInterval) (x : X)
+    (ht : (t : ℝ) ≤ 1 / 3) : flattenedHomotopyMap H (t, x) = f x := by
+  change H (flattenTime t, x) = f x
+  rw [flattenTime_eq_zero t ht, H.apply_zero]
+
+private theorem
+    Smale.ManifoldSmoothing.flattenedHomotopyMap_upper {X N : Type*} [TopologicalSpace X]
+    [TopologicalSpace N] {f g : C(X, N)} (H : f.Homotopy g) (t : unitInterval) (x : X)
+    (ht : 2 / 3 ≤ (t : ℝ)) : flattenedHomotopyMap H (t, x) = g x := by
+  change H (flattenTime t, x) = g x
+  rw [flattenTime_eq_one t ht, H.apply_one]
+
+private def Smale.ManifoldSmoothing.homotopyCollars (X : Type*) : Set (unitInterval × X) :=
+  {q | (q.1 : ℝ) ≤ 1 / 4 ∨ 3 / 4 ≤ (q.1 : ℝ)}
+
+private def
+    Smale.ManifoldSmoothing.homotopyCollarNeighborhood (X : Type*) : Set (unitInterval × X) :=
+  {q | (q.1 : ℝ) < 1 / 3 ∨ 2 / 3 < (q.1 : ℝ)}
+
+private theorem Smale.ManifoldSmoothing.isClosed_homotopyCollars {X : Type*} [TopologicalSpace X] :
+    IsClosed (homotopyCollars X) :=
+  (isClosed_le (continuous_subtype_val.comp continuous_fst) continuous_const).union
+    (isClosed_le continuous_const (continuous_subtype_val.comp continuous_fst))
+
+private theorem Smale.ManifoldSmoothing.isOpen_homotopyCollarNeighborhood {X : Type*}
+    [TopologicalSpace X] : IsOpen (homotopyCollarNeighborhood X) :=
+  (isOpen_lt (continuous_subtype_val.comp continuous_fst) continuous_const).union
+    (isOpen_lt continuous_const (continuous_subtype_val.comp continuous_fst))
+
+private theorem Smale.ManifoldSmoothing.homotopyCollars_subset {X : Type*} :
+    homotopyCollars X ⊆ homotopyCollarNeighborhood X := by
+  rintro q (hl | hu)
+  · exact Or.inl (by linarith)
+  · exact Or.inr (by linarith)
+
+private def Smale.ChartMapPerturbation.coordinateFamily {G F K X N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace K]
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : X → N) (β : X → ℝ) (q : F × X) : F :=
+  c (f q.2) + β q.2 • q.1
+
+private def
+    Smale.ChartMapPerturbation.Valid {G F K X N : Type*} [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace K] {J : ModelWithCorners ℝ G K}
+    [TopologicalSpace X] [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : X → N) (β : X → ℝ) (a : F) : Prop :=
+  ∀ x ∈ tsupport β, coordinateFamily c f β (a, x) ∈ c.target
+
+private def Smale.ChartMapPerturbation.perturb {G F K X N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace K]
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : X → N) (β : X → ℝ) (a : F) (x : X) : N := by
+  classical exact if f x ∈ c.source then c.symm (coordinateFamily c f β (a, x)) else f x
+
+private theorem
+    Smale.ChartMapPerturbation.perturb_eq_of_zero {G F K X N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace K]
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : X → N) (β : X → ℝ) (a : F) {x : X}
+    (hx : β x = 0) : perturb c f β a x = f x := by
+  classical
+  by_cases hs : f x ∈ c.source
+  · simp only [perturb, hs, ite_eq_left, coordinateFamily, hx, zero_smul, add_zero]
+    exact c.left_inv' hs
+  · simp only [perturb, hs, ite_false]
+
+private theorem Smale.ChartMapPerturbation.perturb_zero {G F K X N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace K]
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : X → N) (β : X → ℝ) (x : X) :
+    perturb c f β 0 x = f x := by
+  classical
+  by_cases hs : f x ∈ c.source
+  · simp only [perturb, hs, ite_eq_left, coordinateFamily, smul_zero, add_zero]
+    exact c.left_inv' hs
+  · simp only [perturb, hs, ite_false]
+
+private theorem Smale.ChartMapPerturbation.valid_zero {G F K X N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace K]
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : X → N) (β : X → ℝ)
+    (hsupport : tsupport β ⊆ f ⁻¹' c.source) : Valid c f β (0 : F) := by
+  intro x hx
+  simpa only [coordinateFamily, smul_zero, add_zero] using c.map_source' (hsupport hx)
+
+private theorem Smale.ChartMapPerturbation.coordinate_mem_target {G F K X N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace K] {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [TopologicalSpace N]
+    [ChartedSpace K N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : X → N) (β : X → ℝ) {a : F}
+    (ha : Valid c f β a) {x : X} (hx : f x ∈ c.source) :
+    coordinateFamily c f β (a, x) ∈ c.target := by
+  by_cases hβx : β x = 0
+  · simpa only [coordinateFamily, hβx, zero_smul, add_zero] using c.map_source' hx
+  · exact ha x (subset_tsupport β hβx)
+
+private theorem
+    Smale.ChartMapPerturbation.perturb_mem_source {G F K X N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace K]
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : X → N) (β : X → ℝ) {a : F} (ha : Valid c f β a)
+    {x : X} (hx : f x ∈ c.source) : perturb c f β a x ∈ c.source := by
+  classical
+  simp only [perturb, hx, ite_eq_left]
+  exact c.map_target' (coordinate_mem_target c f β ha hx)
+
+private theorem Smale.ChartMapPerturbation.chart_perturb {G F K X N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace K]
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : X → N) (β : X → ℝ) {a : F} (ha : Valid c f β a)
+    {x : X} (hx : f x ∈ c.source) : c (perturb c f β a x) = coordinateFamily c f β (a, x) := by
+  classical
+  simp only [perturb, hx, ite_eq_left]
+  exact c.right_inv' (coordinate_mem_target c f β ha hx)
+
+private theorem Smale.ChartMapPerturbation.contMDiffAt_coordinateFamily {E G F H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ G K} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ} (hf : ContMDiff I J ∞ f)
+    (hβ : ContMDiff I 𝓘(ℝ, ℝ) ∞ β) (q : F × X) (hq : f q.2 ∈ c.source) :
+    ContMDiffAt (𝓘(ℝ, F).prod I) 𝓘(ℝ, F) ∞ (coordinateFamily c f β) q :=
+  ((c.contMDiffOn_toFun.contMDiffAt (c.open_source.mem_nhds hq)).comp q
+        (hf.comp contMDiff_snd).contMDiffAt).add
+    (((hβ.comp contMDiff_snd).contMDiffAt).smul contMDiffAt_fst)
+
+private theorem
+    Smale.ChartMapPerturbation.eventually_valid {E G F H K X N : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [TopologicalSpace H] [TopologicalSpace K] {I : ModelWithCorners ℝ E H}
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace N]
+    [ChartedSpace K N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ}
+    (hf : ContMDiff I J ∞ f) (hβ : ContMDiff I 𝓘(ℝ, ℝ) ∞ β) (hcompact : HasCompactSupport β)
+    (hsupport : tsupport β ⊆ f ⁻¹' c.source) : ∀ᶠ a in 𝓝 (0 : F), Valid c f β a := by
+  apply hcompact.isCompact.eventually_forall_of_forall_eventually
+  intro x hx
+  have hh := (contMDiffAt_coordinateFamily c hf hβ (0, x) (hsupport hx)).continuousAt
+  apply hh.preimage_mem_nhds
+  apply c.open_target.mem_nhds
+  simpa only [coordinateFamily, smul_zero, add_zero] using c.map_source' (hsupport hx)
+
+private theorem Smale.ChartMapPerturbation.exists_radius_valid {E G F H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ G K} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ} (hf : ContMDiff I J ∞ f)
+    (hβ : ContMDiff I 𝓘(ℝ, ℝ) ∞ β) (hcompact : HasCompactSupport β)
+    (hsupport : tsupport β ⊆ f ⁻¹' c.source) : ∃ ε > (0 : ℝ), ∀ a : F, ‖a‖ < ε → Valid c f β a := by
+  obtain ⟨ε, hε, hball⟩ := Metric.mem_nhds_iff.mp (eventually_valid c hf hβ hcompact hsupport)
+  exact ⟨ε, hε, fun a ha => hball (by simpa only [Metric.mem_ball, dist_zero_right] using ha)⟩
+
+private theorem Smale.ChartMapPerturbation.contMDiffAt_perturb {E G F H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ G K} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ} (hf : ContMDiff I J ∞ f)
+    (hβ : ContMDiff I 𝓘(ℝ, ℝ) ∞ β) (hsupport : tsupport β ⊆ f ⁻¹' c.source) (q : F × X)
+    (ha : Valid c f β q.1) :
+    ContMDiffAt (𝓘(ℝ, F).prod I) J ∞ (fun r : F × X => perturb c f β r.1 r.2) q := by
+  classical
+  by_cases hx : f q.2 ∈ c.source
+  · have hcoord := contMDiffAt_coordinateFamily c hf hβ q hx
+    have htarget := coordinate_mem_target c f β ha hx
+    have hh := (c.contMDiffOn_invFun.contMDiffAt (c.open_target.mem_nhds htarget)).comp q hcoord
+    apply hh.congr_of_eventuallyEq
+    have hs : ∀ᶠ r : F × X in 𝓝 q, f r.2 ∈ c.source :=
+      (hf.continuous.comp continuous_snd).continuousAt.preimage_mem_nhds
+        (c.open_source.mem_nhds hx)
+    filter_upwards [hs] with r hr
+    simp only [perturb, hr, ite_eq_left, Function.comp_apply]
+    rfl
+  · have hn : q.2 ∉ tsupport β := fun h => hx (hsupport h)
+    have hz : β =ᶠ[𝓝 q.2] 0 := notMem_tsupport_iff_eventuallyEq.mp hn
+    apply (hf.comp contMDiff_snd).contMDiffAt.congr_of_eventuallyEq
+    filter_upwards [continuous_snd.continuousAt.tendsto.eventually hz] with r hr
+    exact perturb_eq_of_zero c f β r.1 hr
+
+private theorem Smale.ChartMapPerturbation.contMDiff_perturb {E G F H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ G K} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ} (hf : ContMDiff I J ∞ f)
+    (hβ : ContMDiff I 𝓘(ℝ, ℝ) ∞ β) (hsupport : tsupport β ⊆ f ⁻¹' c.source) {a : F}
+    (ha : Valid c f β a) : ContMDiff I J ∞ (perturb c f β a) := by
+  intro x
+  exact
+    (contMDiffAt_perturb c hf hβ hsupport (a, x) ha).comp x
+      (contMDiffAt_const.prodMk contMDiffAt_id)
+
+private theorem Smale.ChartMapPerturbation.continuousAt_coordinateFamily {G F K X N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace K] {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [TopologicalSpace N]
+    [ChartedSpace K N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ}
+    (hf : Continuous f) (hβ : Continuous β) (q : F × X) (hq : f q.2 ∈ c.source) :
+    ContinuousAt (coordinateFamily c f β) q :=
+  ((c.contMDiffOn_toFun.continuousOn.continuousAt (c.open_source.mem_nhds hq)).comp (f :=
+        fun r : F × X => f r.2) (hf.comp continuous_snd).continuousAt).add
+    ((hβ.comp continuous_snd).continuousAt.smul continuousAt_fst)
+
+private theorem Smale.ChartMapPerturbation.eventually_valid_of_continuous {G F K X N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace K] {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [TopologicalSpace N]
+    [ChartedSpace K N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ}
+    (hf : Continuous f) (hβ : Continuous β) (hcompact : HasCompactSupport β)
+    (hsupport : tsupport β ⊆ f ⁻¹' c.source) : ∀ᶠ a in 𝓝 (0 : F), Valid c f β a := by
+  apply hcompact.isCompact.eventually_forall_of_forall_eventually
+  intro x hx
+  apply (continuousAt_coordinateFamily c hf hβ (0, x) (hsupport hx)).preimage_mem_nhds
+  apply c.open_target.mem_nhds
+  simpa only [coordinateFamily, smul_zero, add_zero] using c.map_source' (hsupport hx)
+
+private theorem Smale.ChartMapPerturbation.exists_radius_valid_of_continuous {G F K X N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace K] {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [TopologicalSpace N]
+    [ChartedSpace K N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ}
+    (hf : Continuous f) (hβ : Continuous β) (hcompact : HasCompactSupport β)
+    (hsupport : tsupport β ⊆ f ⁻¹' c.source) : ∃ ε > (0 : ℝ), ∀ a : F, ‖a‖ < ε → Valid c f β a := by
+  obtain ⟨ε, hε, hball⟩ :=
+    Metric.mem_nhds_iff.mp (eventually_valid_of_continuous c hf hβ hcompact hsupport)
+  exact ⟨ε, hε, fun a ha => hball (by simpa only [Metric.mem_ball, dist_zero_right] using ha)⟩
+
+private theorem
+    Smale.ChartMapPerturbation.continuousAt_perturb {G F K X N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace K]
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ} (hf : Continuous f)
+    (hβ : Continuous β) (hsupport : tsupport β ⊆ f ⁻¹' c.source) (q : F × X)
+    (ha : Valid c f β q.1) : ContinuousAt (fun r : F × X => perturb c f β r.1 r.2) q := by
+  classical
+  by_cases hx : f q.2 ∈ c.source
+  · have hcoord := continuousAt_coordinateFamily c hf hβ q hx
+    have htarget := coordinate_mem_target c f β ha hx
+    have hh :=
+      (c.contMDiffOn_invFun.continuousOn.continuousAt (c.open_target.mem_nhds htarget)).comp
+        hcoord
+    apply hh.congr
+    have hs : ∀ᶠ r : F × X in 𝓝 q, f r.2 ∈ c.source :=
+      (hf.comp continuous_snd).continuousAt.preimage_mem_nhds (c.open_source.mem_nhds hx)
+    filter_upwards [hs] with r hr
+    simp only [perturb, hr, ite_eq_left, Function.comp_apply]
+    rfl
+  · have hn : q.2 ∉ tsupport β := fun h => hx (hsupport h)
+    have hz : β =ᶠ[𝓝 q.2] 0 := notMem_tsupport_iff_eventuallyEq.mp hn
+    apply (hf.comp continuous_snd).continuousAt.congr
+    filter_upwards [continuous_snd.continuousAt.tendsto.eventually hz] with r hr
+    exact (perturb_eq_of_zero c f β r.1 hr).symm
+
+private theorem Smale.ChartMapPerturbation.eventually_maps_compact_into_open_of_continuous
+    {G F K X N : Type*} [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [TopologicalSpace K] {J : ModelWithCorners ℝ G K} [TopologicalSpace X]
+    [TopologicalSpace N] [ChartedSpace K N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N}
+    {β : X → ℝ} (hf : Continuous f) (hβ : Continuous β) (hsupport : tsupport β ⊆ f ⁻¹' c.source)
+    {L : Set X} (hL : IsCompact L) {U : Set N} (hU : IsOpen U) (hfL : Set.MapsTo f L U) :
+    ∀ᶠ a in 𝓝 (0 : F), Set.MapsTo (perturb c f β a) L U := by
+  apply hL.eventually_forall_of_forall_eventually
+  intro x hx
+  apply
+    (continuousAt_perturb c hf hβ hsupport (0, x) (valid_zero c f β hsupport)).preimage_mem_nhds
+  apply hU.mem_nhds
+  simpa only [perturb_zero] using hfL hx
+
+private theorem
+    Smale.ChartMapPerturbation.contMDiffAt_perturb_of_contMDiffAt {E G F H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ G K} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ}
+    (hsupport : tsupport β ⊆ f ⁻¹' c.source) (q : F × X) (hf : ContMDiffAt I J ∞ f q.2)
+    (hβ : ContMDiffAt I 𝓘(ℝ, ℝ) ∞ β q.2) (ha : Valid c f β q.1) :
+    ContMDiffAt (𝓘(ℝ, F).prod I) J ∞ (fun r : F × X => perturb c f β r.1 r.2) q := by
+  classical
+  by_cases hx : f q.2 ∈ c.source
+  · have hcoord : ContMDiffAt (𝓘(ℝ, F).prod I) 𝓘(ℝ, F) ∞ (coordinateFamily c f β) q :=
+      ((c.contMDiffOn_toFun.contMDiffAt (c.open_source.mem_nhds hx)).comp q
+            (hf.comp q contMDiffAt_snd)).add
+        ((hβ.comp q contMDiffAt_snd).smul contMDiffAt_fst)
+    have htarget := coordinate_mem_target c f β ha hx
+    have hh := (c.contMDiffOn_invFun.contMDiffAt (c.open_target.mem_nhds htarget)).comp q hcoord
+    apply hh.congr_of_eventuallyEq
+    have hs : ∀ᶠ r : F × X in 𝓝 q, f r.2 ∈ c.source :=
+      (hf.continuousAt.comp continuousAt_snd).preimage_mem_nhds (c.open_source.mem_nhds hx)
+    filter_upwards [hs] with r hr
+    simp only [perturb, hr, ite_eq_left, Function.comp_apply]
+    rfl
+  · have hn : q.2 ∉ tsupport β := fun h => hx (hsupport h)
+    have hz : β =ᶠ[𝓝 q.2] 0 := notMem_tsupport_iff_eventuallyEq.mp hn
+    apply (hf.comp q contMDiffAt_snd).congr_of_eventuallyEq
+    filter_upwards [continuous_snd.continuousAt.tendsto.eventually hz] with r hr
+    exact perturb_eq_of_zero c f β r.1 hr
+
+private theorem Smale.ChartMapPerturbation.eventually_maps_compact_into_open {E G F H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ G K} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ} (hf : ContMDiff I J ∞ f)
+    (hβ : ContMDiff I 𝓘(ℝ, ℝ) ∞ β) (hsupport : tsupport β ⊆ f ⁻¹' c.source) {L : Set X}
+    (hL : IsCompact L) {U : Set N} (hU : IsOpen U) (hfL : Set.MapsTo f L U) :
+    ∀ᶠ a in 𝓝 (0 : F), Set.MapsTo (perturb c f β a) L U := by
+  apply hL.eventually_forall_of_forall_eventually
+  intro x hx
+  have hc :=
+    (contMDiffAt_perturb c hf hβ hsupport (0, x) (valid_zero c f β hsupport)).continuousAt
+  apply hc.preimage_mem_nhds
+  apply hU.mem_nhds
+  simpa only [perturb_zero] using hfL hx
+
+private theorem Smale.ChartMapPerturbation.norm_interval_smul_lt {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {ε : ℝ} {a : F} (ha : ‖a‖ < ε) (t : unitInterval) : ‖(t : ℝ) • a‖ < ε := by
+  calc
+    ‖(t : ℝ) • a‖ = (t : ℝ) * ‖a‖ := by rw [norm_smul, Real.norm_eq_abs, abs_of_nonneg t.2.1]
+    _ ≤ ‖a‖ := by nlinarith [t.2.2, norm_nonneg a]
+    _ < ε := ha
+
+private def Smale.ChartMapPerturbation.homotopyRel {E G F H K X N : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [TopologicalSpace H] [TopologicalSpace K] {I : ModelWithCorners ℝ E H}
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace N]
+    [ChartedSpace K N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ}
+    (hf : ContMDiff I J ∞ f) (hβ : ContMDiff I 𝓘(ℝ, ℝ) ∞ β)
+    (hsupport : tsupport β ⊆ f ⁻¹' c.source) {ε : ℝ} (hvalid : ∀ a : F, ‖a‖ < ε → Valid c f β a)
+    {a : F} (ha : ‖a‖ < ε) :
+    (⟨f, hf.continuous⟩ : C(X, N)).HomotopyRel
+      ⟨perturb c f β a, (contMDiff_perturb c hf hβ hsupport (hvalid a ha)).continuous⟩
+      {x | β x = 0}
+    where
+  toFun q := perturb c f β ((q.1 : ℝ) • a) q.2
+  continuous_toFun := by
+    apply continuous_iff_continuousAt.mpr
+    intro q
+    have hv := hvalid _ (norm_interval_smul_lt ha q.1)
+    have hp : Continuous (fun r : unitInterval × X => ((r.1 : ℝ) • a, r.2)) :=
+      ((continuous_subtype_val.comp continuous_fst).smul continuous_const).prodMk continuous_snd
+    exact
+      ContinuousAt.comp (f := fun r : unitInterval × X => ((r.1 : ℝ) • a, r.2))
+        (contMDiffAt_perturb c hf hβ hsupport (((q.1 : ℝ) • a), q.2) hv).continuousAt
+        hp.continuousAt
+  map_zero_left
+    x := by
+    change perturb c f β ((0 : ℝ) • a) x = f x
+    rw [zero_smul, perturb_zero]
+  map_one_left
+    x := by
+    change perturb c f β ((1 : ℝ) • a) x = perturb c f β a x
+    rw [one_smul]
+  prop' _ x hx := perturb_eq_of_zero c f β _ hx
+
+private def Smale.ChartMapPerturbation.variablePerturb {G F K X N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace K]
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : X → N) (β : X → ℝ) (a : X → F) (x : X) : N :=
+  perturb c f β (a x) x
+
+private theorem Smale.ChartMapPerturbation.continuous_variablePerturb {G F K X N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace K] {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [TopologicalSpace N]
+    [ChartedSpace K N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ}
+    {a : X → F} (hf : Continuous f) (hβ : Continuous β) (hsupport : tsupport β ⊆ f ⁻¹' c.source)
+    (ha : Continuous a) (hvalid : ∀ x, Valid c f β (a x)) :
+    Continuous (variablePerturb c f β a) := by
+  apply continuous_iff_continuousAt.mpr
+  intro x
+  exact
+    (continuousAt_perturb c hf hβ hsupport (a x, x) (hvalid x)).comp (f := fun y : X => (a y, y))
+      (ha.prodMk continuous_id).continuousAt
+
+private theorem Smale.ChartMapPerturbation.contMDiffAt_variablePerturb {E G F H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ G K} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ} {a : X → F}
+    (hsupport : tsupport β ⊆ f ⁻¹' c.source) {x : X} (hf : ContMDiffAt I J ∞ f x)
+    (hβ : ContMDiffAt I 𝓘(ℝ, ℝ) ∞ β x) (ha : ContMDiffAt I 𝓘(ℝ, F) ∞ a x)
+    (hvalid : Valid c f β (a x)) : ContMDiffAt I J ∞ (variablePerturb c f β a) x :=
+  (contMDiffAt_perturb_of_contMDiffAt c hsupport (a x, x) hf hβ hvalid).comp x (f := fun y : X =>
+    (a y, y)) (ha.prodMk contMDiffAt_id)
+
+private def
+    Smale.ChartMapPerturbation.variableHomotopyRel {G F K X N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace K]
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ} {a : X → F}
+    (hf : Continuous f) (hβ : Continuous β) (hsupport : tsupport β ⊆ f ⁻¹' c.source)
+    (ha : Continuous a) {ε : ℝ} (hvalid : ∀ v : F, ‖v‖ < ε → Valid c f β v)
+    (hbound : ∀ x, ‖a x‖ < ε) {C : Set X} (hfixed : ∀ x ∈ C, β x = 0 ∨ a x = 0) :
+    (⟨f, hf⟩ : C(X, N)).HomotopyRel
+      ⟨variablePerturb c f β a,
+        continuous_variablePerturb c hf hβ hsupport ha (fun x => hvalid _ (hbound x))⟩
+      C
+    where
+  toFun q := perturb c f β ((q.1 : ℝ) • a q.2) q.2
+  continuous_toFun := by
+    apply continuous_iff_continuousAt.mpr
+    intro q
+    have hv := hvalid _ (norm_interval_smul_lt (hbound q.2) q.1)
+    have hp : Continuous (fun r : unitInterval × X => ((r.1 : ℝ) • a r.2, r.2)) :=
+      ((continuous_subtype_val.comp continuous_fst).smul (ha.comp continuous_snd)).prodMk
+        continuous_snd
+    exact
+      (continuousAt_perturb c hf hβ hsupport (((q.1 : ℝ) • a q.2), q.2) hv).comp (f :=
+        fun r : unitInterval × X => ((r.1 : ℝ) • a r.2, r.2)) hp.continuousAt
+  map_zero_left
+    x := by
+    change perturb c f β ((0 : ℝ) • a x) x = f x
+    rw [zero_smul, perturb_zero]
+  map_one_left
+    x := by
+    change perturb c f β ((1 : ℝ) • a x) x = perturb c f β (a x) x
+    rw [one_smul]
+  prop' t x
+    hx := by
+    rcases hfixed x hx with hb | ha₀
+    · exact perturb_eq_of_zero c f β _ hb
+    · change perturb c f β ((t : ℝ) • a x) x = f x
+      rw [ha₀, smul_zero, perturb_zero]
+
+private def Smale.ChartMapPerturbation.cutoffCoordinates {G F K X N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace K]
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : X → N) (χ : X → ℝ) (x : X) : F :=
+  χ x • c (f x)
+
+private theorem Smale.ChartMapPerturbation.cutoffCoordinates_eq_of_one {G F K X N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace K] {J : ModelWithCorners ℝ G K} [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : X → N) (χ : X → ℝ) {x : X} (hx : χ x = 1) :
+    cutoffCoordinates c f χ x = c (f x) := by simp only [cutoffCoordinates, hx, one_smul]
+
+private theorem Smale.ChartMapPerturbation.continuous_cutoffCoordinates {G F K X N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace K] {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [TopologicalSpace N]
+    [ChartedSpace K N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {χ : X → ℝ}
+    (hf : Continuous f) (hχ : Continuous χ) (hsupport : tsupport χ ⊆ f ⁻¹' c.source) :
+    Continuous (cutoffCoordinates c f χ) := by
+  apply continuous_iff_continuousAt.mpr
+  intro x
+  by_cases hx : x ∈ tsupport χ
+  · exact
+      hχ.continuousAt.smul
+        ((c.contMDiffOn_toFun.continuousOn.continuousAt
+              (c.open_source.mem_nhds (hsupport hx))).comp
+          hf.continuousAt)
+  · have hz : χ =ᶠ[𝓝 x] 0 := notMem_tsupport_iff_eventuallyEq.mp hx
+    apply (continuousAt_const (y := (0 : F))).congr
+    filter_upwards [hz] with y hy
+    simp only [cutoffCoordinates, hy, zero_smul, Pi.zero_apply]
+
+private theorem Smale.ChartMapPerturbation.contMDiffAt_cutoffCoordinates {E G F H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ G K} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {χ : X → ℝ}
+    (hsupport : tsupport χ ⊆ f ⁻¹' c.source) {x : X} (hf : ContMDiffAt I J ∞ f x)
+    (hχ : ContMDiffAt I 𝓘(ℝ, ℝ) ∞ χ x) : ContMDiffAt I 𝓘(ℝ, F) ∞ (cutoffCoordinates c f χ) x := by
+  by_cases hx : x ∈ tsupport χ
+  · exact
+      hχ.smul ((c.contMDiffOn_toFun.contMDiffAt (c.open_source.mem_nhds (hsupport hx))).comp x hf)
+  · have hz : χ =ᶠ[𝓝 x] 0 := notMem_tsupport_iff_eventuallyEq.mp hx
+    apply (contMDiffAt_const (c := (0 : F))).congr_of_eventuallyEq
+    filter_upwards [hz] with y hy
+    simp only [cutoffCoordinates, hy, zero_smul, Pi.zero_apply]
+
+private theorem
+    Smale.ChartMapPerturbation.exists_smooth_coordinate_approximation {E G F H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ G K} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {χ : X → ℝ} [FiniteDimensional ℝ E]
+    [IsManifold I ∞ X] [SigmaCompactSpace X] [T2Space X] (hf : Continuous f)
+    (hχ : ContMDiff I 𝓘(ℝ, ℝ) ∞ χ) (hsupport : tsupport χ ⊆ f ⁻¹' c.source) {C U : Set X}
+    (hC : IsClosed C) (hU : IsOpen U) (hCU : C ⊆ U) (hfU : ContMDiffOn I J ∞ f U) {ε : ℝ}
+    (hε : 0 < ε) :
+    ∃ g : X → F,
+      ContMDiff I 𝓘(ℝ, F) ∞ g ∧
+        (∀ x, Dist.dist (g x) (cutoffCoordinates c f χ x) < ε) ∧
+          Set.EqOn g (cutoffCoordinates c f χ) C := by
+  have hk := continuous_cutoffCoordinates c hf hχ.continuous hsupport
+  have hkU : ContMDiffOn I 𝓘(ℝ, F) ∞ (cutoffCoordinates c f χ) U := by
+    intro x hx
+    exact
+      (contMDiffAt_cutoffCoordinates c hsupport ((hfU x hx).contMDiffAt (hU.mem_nhds hx))
+          hχ.contMDiffAt).contMDiffWithinAt
+  have hUn : U ∈ 𝓝ˢ C := mem_nhdsSet_iff_forall.mpr (fun x hx => hU.mem_nhds (hCU hx))
+  obtain ⟨g, hg, hgeq, _⟩ :=
+    hk.exists_contMDiff_approx_and_eqOn I ⊤ (continuous_const (y := ε)) (fun _ => hε) hC hUn hkU
+  exact ⟨g, g.contMDiff, hg, hgeq⟩
+
+private def Smale.ChartMapPerturbation.smoothedMap {G F K X N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace K]
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : X → N) (β χ : X → ℝ) (g : X → F) : X → N :=
+  variablePerturb c f β (fun x => g x - cutoffCoordinates c f χ x)
+
+private theorem Smale.ChartMapPerturbation.coordinateFamily_eq_on_plateau {G F K X N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace K] {J : ModelWithCorners ℝ G K} [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : X → N) (β χ : X → ℝ) (g : X → F) {x : X}
+    (hβx : β x = 1) (hχx : χ x = 1) :
+    coordinateFamily c f β (g x - cutoffCoordinates c f χ x, x) = g x := by
+  simp only [coordinateFamily, cutoffCoordinates, hβx, hχx, one_smul]
+  abel
+
+private theorem Smale.ChartMapPerturbation.smoothedMap_eq_on_plateau {G F K X N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace K] {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [TopologicalSpace N]
+    [ChartedSpace K N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : X → N) (β χ : X → ℝ)
+    (g : X → F) (hsupport : tsupport β ⊆ f ⁻¹' c.source) (hnested : ∀ x ∈ tsupport β, χ x = 1)
+    {x : X} (hβx : β x = 1) : smoothedMap c f β χ g x = c.symm (g x) := by
+  classical
+  have hs : x ∈ tsupport β :=
+    subset_tsupport β
+      (by
+        change β x ≠ 0
+        rw [hβx]
+        exact one_ne_zero)
+  change perturb c f β (g x - cutoffCoordinates c f χ x) x = _
+  have hsource : f x ∈ c.source := hsupport hs
+  simp only [perturb, hsource, ite_eq_left]
+  rw [coordinateFamily_eq_on_plateau c f β χ g hβx (hnested x hs)]
+
+private theorem
+    Smale.ChartMapPerturbation.contMDiffAt_smoothedMap_on_plateau {E G F H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ G K} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ} {χ : X → ℝ} {g : X → F}
+    (hsupport : tsupport β ⊆ f ⁻¹' c.source) (hnested : ∀ x ∈ tsupport β, χ x = 1) {x : X}
+    (hplateau : β =ᶠ[𝓝 x] (fun _ => 1)) (hg : ContMDiffAt I 𝓘(ℝ, F) ∞ g x)
+    (hvalid : Valid c f β (g x - cutoffCoordinates c f χ x)) :
+    ContMDiffAt I J ∞ (smoothedMap c f β χ g) x := by
+  have hβx : β x = 1 := hplateau.eq_of_nhds
+  have hs : x ∈ tsupport β :=
+    subset_tsupport β
+      (by
+        change β x ≠ 0
+        rw [hβx]
+        exact one_ne_zero)
+  have htarget := coordinate_mem_target c f β hvalid (hsupport hs)
+  rw [coordinateFamily_eq_on_plateau c f β χ g hβx (hnested x hs)] at htarget
+  have hh := (c.contMDiffOn_invFun.contMDiffAt (c.open_target.mem_nhds htarget)).comp x hg
+  apply hh.congr_of_eventuallyEq
+  filter_upwards [hplateau] with y hy
+  exact smoothedMap_eq_on_plateau c f β χ g hsupport hnested hy
+
+private theorem Smale.ChartMapPerturbation.contMDiffAt_smoothedMap_of_old {E G F H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ G K} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ} {χ : X → ℝ} {g : X → F}
+    (hβsupport : tsupport β ⊆ f ⁻¹' c.source) (hχsupport : tsupport χ ⊆ f ⁻¹' c.source) {x : X}
+    (hf : ContMDiffAt I J ∞ f x) (hβ : ContMDiffAt I 𝓘(ℝ, ℝ) ∞ β x)
+    (hχ : ContMDiffAt I 𝓘(ℝ, ℝ) ∞ χ x) (hg : ContMDiffAt I 𝓘(ℝ, F) ∞ g x)
+    (hvalid : Valid c f β (g x - cutoffCoordinates c f χ x)) :
+    ContMDiffAt I J ∞ (smoothedMap c f β χ g) x :=
+  contMDiffAt_variablePerturb c hβsupport hf hβ
+    (hg.sub (contMDiffAt_cutoffCoordinates c hχsupport hf hχ)) hvalid
+
+private def Smale.HomotopicRelWithin {X Y : Type*} [TopologicalSpace X] [TopologicalSpace Y]
+    (f g : C(X, Y)) (C K : Set X) (O : Set Y) : Prop :=
+  ∃ F : f.HomotopyRel g C, ∀ t : unitInterval, Set.MapsTo (fun x => F (t, x)) K O
+
+private theorem
+    Smale.HomotopicRelWithin.refl {X Y : Type*} [TopologicalSpace X] [TopologicalSpace Y]
+    {K : Set X} {O : Set Y} (f : C(X, Y)) (C : Set X) (hmaps : Set.MapsTo f K O) :
+    Smale.HomotopicRelWithin f f C K O :=
+  ⟨ContinuousMap.HomotopyRel.refl f C, fun _ => hmaps⟩
+
+private theorem Smale.HomotopicRelWithin.homotopicRel {X Y : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] {f g : C(X, Y)} {C K : Set X} {O : Set Y}
+    (H : Smale.HomotopicRelWithin f g C K O) : f.HomotopicRel g C := by
+  obtain ⟨F, _⟩ := H
+  exact ⟨F⟩
+
+private theorem Smale.HomotopicRelWithin.mapsTo_right {X Y : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] {f g : C(X, Y)} {C K : Set X} {O : Set Y}
+    (H : Smale.HomotopicRelWithin f g C K O) : Set.MapsTo g K O := by
+  obtain ⟨F, hF⟩ := H
+  intro x hx
+  exact (congrArg (fun y => y ∈ O) (F.map_one_left x)).mp (hF 1 hx)
+
+private theorem
+    Smale.HomotopicRelWithin.trans {X Y : Type*} [TopologicalSpace X] [TopologicalSpace Y]
+    {f g h : C(X, Y)} {C K : Set X} {O : Set Y} (H : Smale.HomotopicRelWithin f g C K O)
+    (G : Smale.HomotopicRelWithin g h C K O) : Smale.HomotopicRelWithin f h C K O := by
+  obtain ⟨F, hF⟩ := H
+  obtain ⟨G, hG⟩ := G
+  refine ⟨ContinuousMap.HomotopyRel.trans F G, ?_⟩
+  intro t x hx
+  change (F.toHomotopy.trans G.toHomotopy) (t, x) ∈ O
+  rw [ContinuousMap.Homotopy.trans_apply]
+  split_ifs
+  · exact hF _ hx
+  · exact hG _ hx
+
+private theorem
+    Smale.HomotopicRelWithin.mono {X Y : Type*} [TopologicalSpace X] [TopologicalSpace Y]
+    {f g : C(X, Y)} {C K : Set X} {O : Set Y} (H : Smale.HomotopicRelWithin f g C K O)
+    {D L : Set X} {P : Set Y} (hDC : D ⊆ C) (hLK : L ⊆ K) (hOP : O ⊆ P) :
+    Smale.HomotopicRelWithin f g D L P := by
+  obtain ⟨F, hF⟩ := H
+  exact
+    ⟨{ toHomotopy := F.toHomotopy, prop' := fun t x hx => F.eq_fst t (hDC hx) }, fun t x hx =>
+      hOP (hF t (hLK hx))⟩
+
+private theorem Smale.ChartMapPerturbation.perturb_mem_of_source_subset {G F K X N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace K] {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [TopologicalSpace N]
+    [ChartedSpace K N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : X → N) (β : X → ℝ) {a : F}
+    (ha : Valid c f β a) {O : Set N} (hsource : c.source ⊆ O) {x : X} (hx : f x ∈ O) :
+    perturb c f β a x ∈ O := by
+  by_cases hxc : f x ∈ c.source
+  · exact hsource (perturb_mem_source c f β ha hxc)
+  · simpa only [perturb, ite_eq_right hxc] using hx
+
+private theorem
+    Smale.ChartMapPerturbation.homotopicRelWithin_of_source_subset {E G F H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ G K} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ} (hf : ContMDiff I J ∞ f)
+    (hβ : ContMDiff I 𝓘(ℝ, ℝ) ∞ β) (hsupport : tsupport β ⊆ f ⁻¹' c.source) {ε : ℝ}
+    (hvalid : ∀ a : F, ‖a‖ < ε → Valid c f β a) {a : F} (ha : ‖a‖ < ε) {D : Set X} {O : Set N}
+    (hsource : c.source ⊆ O) (hmaps : Set.MapsTo f D O) :
+    Smale.HomotopicRelWithin (⟨f, hf.continuous⟩ : C(X, N))
+      ⟨perturb c f β a, (contMDiff_perturb c hf hβ hsupport (hvalid a ha)).continuous⟩
+      {x | β x = 0} D O := by
+  refine ⟨homotopyRel c hf hβ hsupport hvalid ha, ?_⟩
+  intro t x hx
+  exact
+    perturb_mem_of_source_subset c f β (hvalid _ (norm_interval_smul_lt ha t)) hsource (hmaps hx)
+
+private theorem
+    Smale.ChartMapPerturbation.variableHomotopicRelWithin_of_source_subset {G F K X N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace K] {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [TopologicalSpace N]
+    [ChartedSpace K N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ}
+    (hf : Continuous f) (hβ : Continuous β) (hsupport : tsupport β ⊆ f ⁻¹' c.source) {a : X → F}
+    (ha : Continuous a) {ε : ℝ} (hvalid : ∀ v : F, ‖v‖ < ε → Valid c f β v)
+    (hbound : ∀ x, ‖a x‖ < ε) {C D : Set X} {O : Set N} (hfixed : ∀ x ∈ C, β x = 0 ∨ a x = 0)
+    (hsource : c.source ⊆ O) (hmaps : Set.MapsTo f D O) :
+    Smale.HomotopicRelWithin (⟨f, hf⟩ : C(X, N))
+      ⟨variablePerturb c f β a,
+        continuous_variablePerturb c hf hβ hsupport ha (fun x => hvalid _ (hbound x))⟩
+      C D O := by
+  refine ⟨variableHomotopyRel c hf hβ hsupport ha hvalid hbound hfixed, ?_⟩
+  intro t x hx
+  exact
+    perturb_mem_of_source_subset c f β (hvalid _ (norm_interval_smul_lt (hbound x) t)) hsource
+      (hmaps hx)
+
+private structure
+    Smale.ManifoldSmoothing.MapSmoothingPatch {E G H K X N : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H]
+    [TopologicalSpace K] (I : ModelWithCorners ℝ E H) (J : ModelWithCorners ℝ G K)
+    [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace N] [ChartedSpace K N] where
+  chart : PartialDiffeomorph J 𝓘(ℝ, G) N G ∞
+  cutoff : X → ℝ
+  outer : X → ℝ
+  smooth : ContMDiff I 𝓘(ℝ, ℝ) ∞ cutoff
+  outer_smooth : ContMDiff I 𝓘(ℝ, ℝ) ∞ outer
+  compact : HasCompactSupport cutoff
+  outer_compact : HasCompactSupport outer
+  nested : ∀ x ∈ tsupport cutoff, outer x = 1
+
+private def Smale.ManifoldSmoothing.MapSmoothingPatch.Compatible {E G H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [TopologicalSpace H] [TopologicalSpace K] {I : ModelWithCorners ℝ E H}
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace N]
+    [ChartedSpace K N] (p : Smale.ManifoldSmoothing.MapSmoothingPatch I J (X := X) (N := N))
+    (f : X → N) : Prop :=
+  Set.MapsTo f (tsupport p.outer) p.chart.source
+
+private def
+    Smale.ManifoldSmoothing.MapSmoothingPatch.plateau {E G H K X N : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H]
+    [TopologicalSpace K] {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ G K}
+    [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace N] [ChartedSpace K N]
+    (p : Smale.ManifoldSmoothing.MapSmoothingPatch I J (X := X) (N := N)) : Set X :=
+  interior {x | p.cutoff x = 1}
+
+private theorem
+    Smale.ManifoldSmoothing.MapSmoothingPatch.inner_support_subset_outer {E G H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [TopologicalSpace H] [TopologicalSpace K] {I : ModelWithCorners ℝ E H}
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace N]
+    [ChartedSpace K N] (p : Smale.ManifoldSmoothing.MapSmoothingPatch I J (X := X) (N := N)) :
+    tsupport p.cutoff ⊆ tsupport p.outer := by
+  intro x hx
+  apply subset_tsupport p.outer
+  change p.outer x ≠ 0
+  rw [p.nested x hx]
+  exact one_ne_zero
+
+private theorem Smale.ManifoldSmoothing.MapSmoothingPatch.inner_compatible {E G H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [TopologicalSpace H] [TopologicalSpace K] {I : ModelWithCorners ℝ E H}
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace N]
+    [ChartedSpace K N] (p : Smale.ManifoldSmoothing.MapSmoothingPatch I J (X := X) (N := N))
+    {f : X → N} (hf : p.Compatible f) : tsupport p.cutoff ⊆ f ⁻¹' p.chart.source := fun _ hx =>
+  hf (p.inner_support_subset_outer hx)
+
+private theorem
+    Smale.ManifoldSmoothing.MapSmoothingPatch.plateau_eventually_one {E G H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [TopologicalSpace H] [TopologicalSpace K] {I : ModelWithCorners ℝ E H}
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace N]
+    [ChartedSpace K N] (p : Smale.ManifoldSmoothing.MapSmoothingPatch I J (X := X) (N := N))
+    {x : X} (hx : x ∈ p.plateau) : p.cutoff =ᶠ[𝓝 x] (fun _ => 1) := by
+  filter_upwards [isOpen_interior.mem_nhds hx] with y hy
+  exact interior_subset (s := {y : X | p.cutoff y = 1}) hy
+
+private theorem
+    Smale.ManifoldSmoothing.exists_smoothing_patch_step_within_target {E G H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [TopologicalSpace H] [TopologicalSpace K] {I : ModelWithCorners ℝ E H}
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace N]
+    [ChartedSpace K N] [FiniteDimensional ℝ E] [IsManifold I ∞ X] [SigmaCompactSpace X]
+    [T2Space X] {ι : Type*} [Finite ι] (p : ι → MapSmoothingPatch I J (X := X) (N := N)) (i : ι)
+    (f : C(X, N)) (hcompatible : ∀ j, (p j).Compatible f) {C U : Set X} (hC : IsClosed C)
+    (hU : IsOpen U) (hCU : C ⊆ U) (hfU : ContMDiffOn I J ∞ f U) {D : Set X} {O : Set N}
+    (hsource : (p i).chart.source ⊆ O) (hmaps : Set.MapsTo f D O) :
+    ∃ f' : C(X, N),
+      (∀ j, (p j).Compatible f') ∧
+        Smale.HomotopicRelWithin f f' C D O ∧
+          ∀ x, ContMDiffAt I J ∞ f x ∨ x ∈ (p i).plateau → ContMDiffAt I J ∞ f' x := by
+  have hinner := (p i).inner_compatible (hcompatible i)
+  have hkeep :
+    ∀ᶠ a in 𝓝 (0 : G),
+      ∀ j, (p j).Compatible (Smale.ChartMapPerturbation.perturb (p i).chart f (p i).cutoff a) := by
+    apply Filter.eventually_all.mpr
+    intro j
+    exact
+      Smale.ChartMapPerturbation.eventually_maps_compact_into_open_of_continuous (p i).chart
+        f.continuous (p i).smooth.continuous hinner (p j).outer_compact.isCompact
+        (p j).chart.open_source (hcompatible j)
+  obtain ⟨δ, hδ, hδkeep⟩ := Metric.mem_nhds_iff.mp hkeep
+  obtain ⟨r, hr, hvalid⟩ :=
+    Smale.ChartMapPerturbation.exists_radius_valid_of_continuous (p i).chart f.continuous
+      (p i).smooth.continuous (p i).compact hinner
+  obtain ⟨g, hg, happrox, heq⟩ :=
+    Smale.ChartMapPerturbation.exists_smooth_coordinate_approximation (p i).chart f.continuous
+      (p i).outer_smooth (hcompatible i) hC hU hCU hfU (lt_min hδ hr)
+  let a : X → G := fun x =>
+    g x - Smale.ChartMapPerturbation.cutoffCoordinates (p i).chart f (p i).outer x
+  have ha : Continuous a :=
+    hg.continuous.sub
+      (Smale.ChartMapPerturbation.continuous_cutoffCoordinates (p i).chart f.continuous
+        (p i).outer_smooth.continuous (hcompatible i))
+  have hbound (x : X) : ‖a x‖ < Min.min δ r := by simpa only [a, dist_eq_norm] using happrox x
+  have haδ (x : X) : ‖a x‖ < δ := (lt_min_iff.mp (hbound x)).1
+  have har (x : X) : ‖a x‖ < r := (lt_min_iff.mp (hbound x)).2
+  let f' : C(X, N) :=
+    ⟨Smale.ChartMapPerturbation.variablePerturb (p i).chart f (p i).cutoff a,
+      Smale.ChartMapPerturbation.continuous_variablePerturb (p i).chart f.continuous
+        (p i).smooth.continuous hinner ha (fun x => hvalid _ (har x))⟩
+  refine ⟨f', ?_, ?_, ?_⟩
+  · intro j x hx
+    have hh :=
+      hδkeep
+        (show a x ∈ Metric.ball 0 δ by simpa only [Metric.mem_ball, dist_zero_right] using haδ x)
+    exact hh j hx
+  · exact
+      Smale.ChartMapPerturbation.variableHomotopicRelWithin_of_source_subset (p i).chart
+        f.continuous (p i).smooth.continuous hinner ha hvalid har
+        (fun x hx => Or.inr (sub_eq_zero.mpr (heq hx))) hsource hmaps
+  · intro x hx
+    rcases hx with hold | hplateau
+    · exact
+        Smale.ChartMapPerturbation.contMDiffAt_smoothedMap_of_old (p i).chart hinner
+          (hcompatible i) hold (p i).smooth.contMDiffAt (p i).outer_smooth.contMDiffAt
+          hg.contMDiffAt (hvalid _ (har x))
+    · exact
+        Smale.ChartMapPerturbation.contMDiffAt_smoothedMap_on_plateau (p i).chart hinner
+          (p i).nested ((p i).plateau_eventually_one hplateau) hg.contMDiffAt (hvalid _ (har x))
+
+private theorem
+    Smale.ManifoldSmoothing.exists_finite_patch_smoothing_within_target {E G H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] [TopologicalSpace K] {I : ModelWithCorners ℝ E H}
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X]
+    [T2Space X] [SigmaCompactSpace X] [TopologicalSpace N] [ChartedSpace K N] {ι : Type*}
+    [Finite ι] (p : ι → MapSmoothingPatch I J (X := X) (N := N)) (f : C(X, N))
+    (hcompatible : ∀ j, (p j).Compatible f) {C U : Set X} (hC : IsClosed C) (hU : IsOpen U)
+    (hCU : C ⊆ U) (hfU : ContMDiffOn I J ∞ f U) {D : Set X} {O : Set N}
+    (hsource : ∀ i, (p i).chart.source ⊆ O) (hmaps : Set.MapsTo f D O) (s : Finset ι) :
+    ∃ f' : C(X, N),
+      (∀ j, (p j).Compatible f') ∧
+        Smale.HomotopicRelWithin f f' C D O ∧
+          ∀ x, (ContMDiffAt I J ∞ f x ∨ ∃ i ∈ s, x ∈ (p i).plateau) → ContMDiffAt I J ∞ f' x := by
+  classical
+    induction s using Finset.induction_on with
+  | empty =>
+    refine ⟨f, hcompatible, Smale.HomotopicRelWithin.refl f C hmaps, ?_⟩
+    intro x hx
+    simpa using hx
+  | @insert i s _ ih =>
+    obtain ⟨f₁, hc₁, hhom₁, hsm₁⟩ := ih
+    have hf₁U : ContMDiffOn I J ∞ f₁ U := by
+      intro x hx
+      exact (hsm₁ x (Or.inl ((hfU x hx).contMDiffAt (hU.mem_nhds hx)))).contMDiffWithinAt
+    obtain ⟨f₂, hc₂, hhom₂, hsm₂⟩ :=
+      exists_smoothing_patch_step_within_target p i f₁ hc₁ hC hU hCU hf₁U (hsource i)
+        hhom₁.mapsTo_right
+    refine ⟨f₂, hc₂, hhom₁.trans hhom₂, ?_⟩
+    intro x hx
+    apply hsm₂ x
+    rcases hx with hold | ⟨j, hj, hplateau⟩
+    · exact Or.inl (hsm₁ x (Or.inl hold))
+    · rcases Finset.mem_insert.mp hj with rfl | hjs
+      · exact Or.inr hplateau
+      · exact Or.inl (hsm₁ x (Or.inr ⟨j, hjs, hplateau⟩))
+
+private theorem Smale.ManifoldSmoothing.exists_finite_patch_smoothing {E G H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] [TopologicalSpace K] {I : ModelWithCorners ℝ E H}
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X]
+    [T2Space X] [SigmaCompactSpace X] [TopologicalSpace N] [ChartedSpace K N] {ι : Type*}
+    [Finite ι] (p : ι → MapSmoothingPatch I J (X := X) (N := N)) (f : C(X, N))
+    (hcompatible : ∀ j, (p j).Compatible f) {C U : Set X} (hC : IsClosed C) (hU : IsOpen U)
+    (hCU : C ⊆ U) (hfU : ContMDiffOn I J ∞ f U) (s : Finset ι) :
+    ∃ f' : C(X, N),
+      (∀ j, (p j).Compatible f') ∧
+        f.HomotopicRel f' C ∧
+          ∀ x, (ContMDiffAt I J ∞ f x ∨ ∃ i ∈ s, x ∈ (p i).plateau) → ContMDiffAt I J ∞ f' x := by
+  obtain ⟨f', hc, hrel, hsm⟩ :=
+    exists_finite_patch_smoothing_within_target p f hcompatible hC hU hCU hfU
+      (fun _ => Set.subset_univ _) (Set.mapsTo_univ f Set.univ) s
+  exact ⟨f', hc, hrel.homotopicRel, hsm⟩
+
+private theorem Smale.ManifoldSmoothing.exists_smoothing_of_finite_patches {E G H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] [TopologicalSpace K] {I : ModelWithCorners ℝ E H}
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X]
+    [T2Space X] [SigmaCompactSpace X] [TopologicalSpace N] [ChartedSpace K N] {ι : Type*}
+    [Finite ι] (p : ι → MapSmoothingPatch I J (X := X) (N := N)) (f : C(X, N))
+    (hcompatible : ∀ j, (p j).Compatible f) {C U : Set X} (hC : IsClosed C) (hU : IsOpen U)
+    (hCU : C ⊆ U) (hfU : ContMDiffOn I J ∞ f U) (hcover : ∀ x, ∃ i, x ∈ (p i).plateau) :
+    ∃ f' : C(X, N), ContMDiff I J ∞ f' ∧ f.HomotopicRel f' C := by
+  classical
+  let := Fintype.ofFinite ι
+  obtain ⟨f', _, hhom, hsm⟩ :=
+    exists_finite_patch_smoothing p f hcompatible hC hU hCU hfU Finset.univ
+  refine ⟨f', ?_, hhom⟩
+  intro x
+  obtain ⟨i, hi⟩ := hcover x
+  exact hsm x (Or.inr ⟨i, Finset.mem_univ i, hi⟩)
+
+private theorem Smale.ManifoldSmoothing.exists_smoothing_patch_at_in_open {E G H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] [TopologicalSpace K] {I : ModelWithCorners ℝ E H}
+    {J : ModelWithCorners ℝ G K} [J.Boundaryless] [TopologicalSpace X] [ChartedSpace H X]
+    [IsManifold I ∞ X] [T2Space X] [TopologicalSpace N] [ChartedSpace K N] [IsManifold J ∞ N]
+    (f : C(X, N)) (x : X) {O : Set N} (hO : IsOpen O) (hxO : f x ∈ O) :
+    ∃ p : MapSmoothingPatch I J (X := X) (N := N),
+      p.Compatible f ∧ x ∈ p.plateau ∧ p.chart.source ⊆ O := by
+  classical
+  let c₀ := NoExotic.modelChartPartialDiffeomorph (I := J) (f x)
+  let c := Smale.PartialChart.restrictSource c₀ hO
+  have hsource : f x ∈ c.source := ⟨mem_extChartAt_source (I := J) (f x), hxO⟩
+  have hU : f ⁻¹' c.source ∈ 𝓝 x := (c.open_source.preimage f.continuous).mem_nhds hsource
+  obtain ⟨χ, _, hχ⟩ := (SmoothBumpFunction.nhds_basis_tsupport (I := I) x).mem_iff.mp hU
+  have hχone : {y : X | χ y = 1} ∈ 𝓝 x := χ.eventuallyEq_one
+  obtain ⟨β, _, hβ⟩ := (SmoothBumpFunction.nhds_basis_tsupport (I := I) x).mem_iff.mp hχone
+  let p : MapSmoothingPatch I J (X := X) (N := N) :=
+    { chart := c
+      cutoff := β
+      outer := χ
+      smooth := β.contMDiff
+      outer_smooth := χ.contMDiff
+      compact := β.hasCompactSupport
+      outer_compact := χ.hasCompactSupport
+      nested := fun y hy => hβ hy }
+  refine ⟨p, hχ, ?_, fun _ hx => hx.2⟩
+  change x ∈ interior {y : X | β y = 1}
+  exact mem_interior_iff_mem_nhds.mpr β.eventuallyEq_one
+
+private theorem Smale.ManifoldSmoothing.exists_smoothing_patch_at {E G H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] [TopologicalSpace K] {I : ModelWithCorners ℝ E H}
+    {J : ModelWithCorners ℝ G K} [J.Boundaryless] [TopologicalSpace X] [ChartedSpace H X]
+    [IsManifold I ∞ X] [T2Space X] [TopologicalSpace N] [ChartedSpace K N] [IsManifold J ∞ N]
+    (f : C(X, N)) (x : X) :
+    ∃ p : MapSmoothingPatch I J (X := X) (N := N), p.Compatible f ∧ x ∈ p.plateau := by
+  obtain ⟨p, hc, hp, _⟩ :=
+    exists_smoothing_patch_at_in_open (I := I) (J := J) f x isOpen_univ (Set.mem_univ _)
+  exact ⟨p, hc, hp⟩
+
+private theorem Smale.ManifoldSmoothing.exists_smooth_map_homotopicRel {E G H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] [TopologicalSpace K] {I : ModelWithCorners ℝ E H}
+    {J : ModelWithCorners ℝ G K} [J.Boundaryless] [TopologicalSpace X] [ChartedSpace H X]
+    [IsManifold I ∞ X] [T2Space X] [TopologicalSpace N] [ChartedSpace K N] [IsManifold J ∞ N]
+    [CompactSpace X] (f : C(X, N)) {C U : Set X} (hC : IsClosed C) (hU : IsOpen U) (hCU : C ⊆ U)
+    (hfU : ContMDiffOn I J ∞ f U) : ∃ f' : C(X, N), ContMDiff I J ∞ f' ∧ f.HomotopicRel f' C := by
+  classical
+  have hp (x : X) :
+    ∃ p : MapSmoothingPatch I J (X := X) (N := N), p.Compatible f ∧ x ∈ p.plateau :=
+    exists_smoothing_patch_at f x
+  choose p hpcompatible hpplateau using hp
+  have hopen (x : X) : IsOpen (p x).plateau := isOpen_interior
+  have hcover : (Set.univ : Set X) ⊆ ⋃ x, (p x).plateau := by
+    intro x _
+    exact Set.mem_iUnion.mpr ⟨x, hpplateau x⟩
+  obtain ⟨s, hs⟩ := isCompact_univ.elim_finite_subcover (fun x : X => (p x).plateau) hopen hcover
+  apply
+    exists_smoothing_of_finite_patches (fun i : s => p i.1) f (fun i => hpcompatible i.1) hC hU
+      hCU hfU
+  intro x
+  obtain ⟨i, hi, hix⟩ := Set.mem_iUnion₂.mp (hs (Set.mem_univ x))
+  exact ⟨⟨i, hi⟩, hix⟩
+
+private theorem Smale.ManifoldSmoothing.exists_smooth_map_homotopic {E G H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] [TopologicalSpace K] {I : ModelWithCorners ℝ E H}
+    {J : ModelWithCorners ℝ G K} [J.Boundaryless] [TopologicalSpace X] [ChartedSpace H X]
+    [IsManifold I ∞ X] [T2Space X] [TopologicalSpace N] [ChartedSpace K N] [IsManifold J ∞ N]
+    [CompactSpace X] (f : C(X, N)) : ∃ f' : C(X, N), ContMDiff I J ∞ f' ∧ f.Homotopic f' := by
+  obtain ⟨f', hf', ⟨H⟩⟩ :=
+    exists_smooth_map_homotopicRel (I := I) (J := J) f isClosed_empty isOpen_empty
+      (Set.Subset.refl ∅) contMDiffOn_empty
+  exact ⟨f', hf', ⟨H.toHomotopy⟩⟩
+
+private theorem Smale.ManifoldSmoothing.contMDiffOn_flattenedHomotopyMap {E G H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [TopologicalSpace H] [TopologicalSpace K] {I : ModelWithCorners ℝ E H}
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace N]
+    [ChartedSpace K N] {f g : C(X, N)} (hf : ContMDiff I J ∞ f) (hg : ContMDiff I J ∞ g)
+    (H : f.Homotopy g) :
+    ContMDiffOn ((𝓡∂ 1).prod I) J ∞ (flattenedHomotopyMap H) (homotopyCollarNeighborhood X) := by
+  rintro q (hl | hu)
+  · have hs : ContMDiff ((𝓡∂ 1).prod I) J ∞ (fun r : unitInterval × X => f r.2) :=
+      hf.comp contMDiff_snd
+    have heq : flattenedHomotopyMap H =ᶠ[𝓝 q] (fun r => f r.2) := by
+      have hn : {r : unitInterval × X | (r.1 : ℝ) < 1 / 3} ∈ 𝓝 q :=
+        (isOpen_lt (continuous_subtype_val.comp continuous_fst) continuous_const).mem_nhds hl
+      filter_upwards [hn] with r hr
+      exact flattenedHomotopyMap_lower H r.1 r.2 (le_of_lt hr)
+    exact (hs.contMDiffAt.congr_of_eventuallyEq heq).contMDiffWithinAt
+  · have hs : ContMDiff ((𝓡∂ 1).prod I) J ∞ (fun r : unitInterval × X => g r.2) :=
+      hg.comp contMDiff_snd
+    have heq : flattenedHomotopyMap H =ᶠ[𝓝 q] (fun r => g r.2) := by
+      have hn : {r : unitInterval × X | 2 / 3 < (r.1 : ℝ)} ∈ 𝓝 q :=
+        (isOpen_lt continuous_const (continuous_subtype_val.comp continuous_fst)).mem_nhds hu
+      filter_upwards [hn] with r hr
+      exact flattenedHomotopyMap_upper H r.1 r.2 (le_of_lt hr)
+    exact (hs.contMDiffAt.congr_of_eventuallyEq heq).contMDiffWithinAt
+
+private theorem Smale.ManifoldSmoothing.exists_smooth_homotopy_with_collars {E G H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] [TopologicalSpace K] {I : ModelWithCorners ℝ E H}
+    {J : ModelWithCorners ℝ G K} [J.Boundaryless] [TopologicalSpace X] [ChartedSpace H X]
+    [IsManifold I ∞ X] [T2Space X] [CompactSpace X] [TopologicalSpace N] [ChartedSpace K N]
+    [IsManifold J ∞ N] {f g : C(X, N)} (hf : ContMDiff I J ∞ f) (hg : ContMDiff I J ∞ g)
+    (H : f.Homotopy g) :
+    ∃ H' : f.Homotopy g,
+      ContMDiff ((𝓡∂ 1).prod I) J ∞ H' ∧
+        (∀ t : unitInterval, ∀ x, (t : ℝ) ≤ 1 / 4 → H' (t, x) = f x) ∧
+          (∀ t : unitInterval, ∀ x, 3 / 4 ≤ (t : ℝ) → H' (t, x) = g x) := by
+  obtain ⟨F, hF, ⟨K⟩⟩ :=
+    exists_smooth_map_homotopicRel (flattenedHomotopyMap H) isClosed_homotopyCollars
+      isOpen_homotopyCollarNeighborhood homotopyCollars_subset
+      (contMDiffOn_flattenedHomotopyMap hf hg H)
+  have hlo (t : unitInterval) (x : X) (ht : (t : ℝ) ≤ 1 / 4) : F (t, x) = f x := by
+    have heq := K.fst_eq_snd (show (t, x) ∈ homotopyCollars X from Or.inl ht)
+    rw [← heq]
+    exact flattenedHomotopyMap_lower H t x (by linarith)
+  have hhi (t : unitInterval) (x : X) (ht : 3 / 4 ≤ (t : ℝ)) : F (t, x) = g x := by
+    have heq := K.fst_eq_snd (show (t, x) ∈ homotopyCollars X from Or.inr ht)
+    rw [← heq]
+    exact flattenedHomotopyMap_upper H t x (by linarith)
+  let H' : f.Homotopy g :=
+    { toContinuousMap := F
+      map_zero_left := fun x => hlo 0 x (by norm_num)
+      map_one_left := fun x => hhi 1 x (by norm_num) }
+  exact ⟨H', hF, hlo, hhi⟩
+
+private theorem Smale.GeneralPosition.dimH_image_chart_le {E F H X : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [TopologicalSpace X] [ChartedSpace H X]
+    [IsManifold I ∞ X] {f : X → F} {s : Set X} (hs : IsOpen s) (hf : ContMDiffOn I 𝓘(ℝ, F) ∞ f s)
+    (x : X) : dimH (f '' ((extChartAt I x).source ∩ s)) ≤ Module.finrank ℝ E := by
+  let c := extChartAt I x
+  let V : Set E := c.target ∩ c.symm ⁻¹' s
+  have hfc : ContDiffOn ℝ ∞ (f ∘ c.symm) V :=
+    (hf.comp ((contMDiffOn_extChartAt_symm x).mono Set.inter_subset_left)
+        Set.inter_subset_right).contDiffOn
+  have hVsub : V ⊆ Set.range I := fun y hy => extChartAt_target_subset_range x hy.1
+  have hdim : dimH ((f ∘ c.symm) '' V) ≤ dimH V := by
+    apply dimH_image_le_of_locally_lipschitzOn
+    intro y hy
+    have ht : c.target ∈ 𝓝[Set.range I] y := extChartAt_target_mem_nhdsWithin_of_mem hy.1
+    have hp : c.symm ⁻¹' s ∈ 𝓝[Set.range I] y := by
+      rw [← nhdsWithin_extChartAt_target_eq_of_mem hy.1]
+      exact
+        (contMDiffOn_extChartAt_symm (n := (∞ : ℕ∞ω)) x).continuousOn y
+            hy.1 |>.preimage_mem_nhdsWithin
+          (hs.mem_nhds hy.2)
+    have hV : V ∈ 𝓝[Set.range I] y := Filter.inter_mem ht hp
+    have hd : ContDiffWithinAt ℝ 1 (f ∘ c.symm) (Set.range I) y :=
+      ((hfc y hy).of_le (by simp)).mono_of_mem_nhdsWithin hV
+    obtain ⟨L, U, hU, hLip⟩ := hd.exists_lipschitzOnWith I.convex_range
+    exact ⟨L, U, nhdsWithin_mono y hVsub hU, hLip⟩
+  have himage : f '' (c.source ∩ s) = (f ∘ c.symm) '' V := by
+    ext z
+    constructor
+    · rintro ⟨y, ⟨hyc, hys⟩, rfl⟩
+      refine ⟨c y, ⟨c.map_source hyc, ?_⟩, ?_⟩
+      · change c.symm (c y) ∈ s
+        rwa [c.left_inv hyc]
+      · exact congrArg f (c.left_inv hyc)
+    · rintro ⟨y, ⟨hyc, hys⟩, rfl⟩
+      exact ⟨c.symm y, ⟨c.map_target hyc, hys⟩, rfl⟩
+  change dimH (f '' (c.source ∩ s)) ≤ _
+  rw [himage]
+  exact hdim.trans ((dimH_mono (Set.subset_univ V)).trans_eq (Real.dimH_univ_eq_finrank E))
+
+private theorem
+    Smale.GeneralPosition.dimH_image_manifold_le {E F H X : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [TopologicalSpace X] [ChartedSpace H X]
+    [IsManifold I ∞ X] [LindelofSpace X] {f : X → F} {s : Set X} (hs : IsOpen s)
+    (hf : ContMDiffOn I 𝓘(ℝ, F) ∞ f s) : dimH (f '' s) ≤ Module.finrank ℝ E := by
+  let U : X → Set X := fun x => (extChartAt I x).source
+  have hU : ∀ x, IsOpen (U x) := fun x => isOpen_extChartAt_source x
+  have hcover : (Set.univ : Set X) ⊆ ⋃ x, U x := by
+    intro x _
+    exact Set.mem_iUnion.mpr ⟨x, mem_extChartAt_source x⟩
+  obtain ⟨t, htcount, ht⟩ := isLindelof_univ.elim_countable_subcover U hU hcover
+  have himage : f '' s ⊆ ⋃ x ∈ t, f '' (U x ∩ s) := by
+    rintro z ⟨y, hys, rfl⟩
+    obtain ⟨x, hxt, hyx⟩ := Set.mem_iUnion₂.mp (ht (Set.mem_univ y))
+    exact Set.mem_iUnion₂.mpr ⟨x, hxt, y, ⟨hyx, hys⟩, rfl⟩
+  apply (dimH_mono himage).trans
+  rw [dimH_bUnion htcount]
+  exact iSup_le (fun x => iSup_le (fun _ => dimH_image_chart_le hs hf x))
+
+private theorem
+    Smale.GeneralPosition.dense_compl_manifold_image {E F H X : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [TopologicalSpace X] [ChartedSpace H X]
+    [IsManifold I ∞ X] [LindelofSpace X] [FiniteDimensional ℝ F] {f : X → F} {s : Set X}
+    (hs : IsOpen s) (hf : ContMDiffOn I 𝓘(ℝ, F) ∞ f s)
+    (hd : Module.finrank ℝ E < Module.finrank ℝ F) : Dense (f '' s)ᶜ :=
+  dense_compl_of_dimH_lt_finrank ((dimH_image_manifold_le hs hf).trans_lt (Nat.cast_lt.mpr hd))
+
+private theorem Smale.exists_small_localized_image_avoidance {E E' F H H' X Y : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup E']
+    [NormedSpace ℝ E'] [FiniteDimensional ℝ E'] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [FiniteDimensional ℝ F] [TopologicalSpace H] [TopologicalSpace H']
+    {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ E' H'} [TopologicalSpace X]
+    [ChartedSpace H X] [IsManifold I ∞ X] [TopologicalSpace Y] [ChartedSpace H' Y]
+    [IsManifold J ∞ Y] [LindelofSpace (X × Y)] {f : X → F} {g : Y → F} {β : X → ℝ}
+    (hf : ContMDiff I 𝓘(ℝ, F) ∞ f) (hg : ContMDiff J 𝓘(ℝ, F) ∞ g) (hβ : ContMDiff I 𝓘(ℝ, ℝ) ∞ β)
+    (hdim : Module.finrank ℝ E + Module.finrank ℝ E' < Module.finrank ℝ F) {ε : ℝ} (hε : 0 < ε) :
+    ∃ a : F, ‖a‖ < ε ∧ ∀ x, β x ≠ 0 → ∀ y, f x + β x • a ≠ g y := by
+  let s : Set (X × Y) := {p | β p.1 ≠ 0}
+  let bad : X × Y → F := fun p => (β p.1)⁻¹ • (g p.2 - f p.1)
+  have hs : IsOpen s := isOpen_ne_fun (hβ.continuous.comp continuous_fst) continuous_const
+  have hb : ContMDiffOn (I.prod J) 𝓘(ℝ, F) ∞ bad s :=
+    ((hβ.comp contMDiff_fst).contMDiffOn.inv₀ (fun _ hp => hp)).smul
+      ((hg.comp contMDiff_snd).sub (hf.comp contMDiff_fst)).contMDiffOn
+  have hd : Module.finrank ℝ (E × E') < Module.finrank ℝ F := by
+    simpa only [Module.finrank_prod] using hdim
+  have hdense := GeneralPosition.dense_compl_manifold_image hs hb hd
+  obtain ⟨a, ha, haε⟩ := hdense.exists_dist_lt 0 hε
+  refine ⟨a, ?_, ?_⟩
+  · simpa only [dist_zero_left] using haε
+  · intro x hx y hxy
+    apply ha
+    refine ⟨(x, y), hx, ?_⟩
+    change (β x)⁻¹ • (g y - f x) = a
+    rw [← hxy, add_sub_cancel_left, smul_smul, inv_mul_cancel₀ hx, one_smul]
+
+private theorem
+    Smale.ChartMapPerturbation.exists_small_avoiding_parameter {E E' G F H H' K X Y N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup E']
+    [NormedSpace ℝ E'] [FiniteDimensional ℝ E'] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [FiniteDimensional ℝ F] [TopologicalSpace H]
+    [TopologicalSpace H'] [TopologicalSpace K] {I : ModelWithCorners ℝ E H}
+    {I' : ModelWithCorners ℝ E' H'} {J : ModelWithCorners ℝ G K} [TopologicalSpace X]
+    [ChartedSpace H X] [IsManifold I ∞ X] [TopologicalSpace Y] [ChartedSpace H' Y]
+    [IsManifold I' ∞ Y] [TopologicalSpace N] [ChartedSpace K N] [LindelofSpace (X × Y)]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {g : Y → N} {β : X → ℝ}
+    (hf : ContMDiff I J ∞ f) (hg : ContMDiff I' J ∞ g) (hβ : ContMDiff I 𝓘(ℝ, ℝ) ∞ β)
+    (hcompact : HasCompactSupport β) (hsupport : tsupport β ⊆ f ⁻¹' c.source)
+    (hdim : Module.finrank ℝ E + Module.finrank ℝ E' < Module.finrank ℝ F) {ε : ℝ} (hε : 0 < ε) :
+    ∃ a : F,
+      ‖a‖ < ε ∧
+        Valid c f β a ∧
+          ContMDiff I J ∞ (perturb c f β a) ∧ ∀ x, β x ≠ 0 → ∀ y, perturb c f β a x ≠ g y := by
+  let s : Set (X × Y) := {p | f p.1 ∈ c.source ∧ g p.2 ∈ c.source ∧ β p.1 ≠ 0}
+  let bad : X × Y → F := fun p => (β p.1)⁻¹ • (c (g p.2) - c (f p.1))
+  have hs : IsOpen s :=
+    (c.open_source.preimage (hf.continuous.comp continuous_fst)).inter
+      ((c.open_source.preimage (hg.continuous.comp continuous_snd)).inter
+        (isOpen_ne_fun (hβ.continuous.comp continuous_fst) continuous_const))
+  have hb : ContMDiffOn (I.prod I') 𝓘(ℝ, F) ∞ bad s := by
+    intro p hp
+    have hcf : ContMDiffAt (I.prod I') 𝓘(ℝ, F) ∞ (fun q : X × Y => c (f q.1)) p :=
+      (c.contMDiffOn_toFun.contMDiffAt (c.open_source.mem_nhds hp.1)).comp p
+        (hf.comp contMDiff_fst).contMDiffAt
+    have hcg : ContMDiffAt (I.prod I') 𝓘(ℝ, F) ∞ (fun q : X × Y => c (g q.2)) p :=
+      (c.contMDiffOn_toFun.contMDiffAt (c.open_source.mem_nhds hp.2.1)).comp p
+        (hg.comp contMDiff_snd).contMDiffAt
+    exact (((hβ.comp contMDiff_fst).contMDiffAt.inv₀ hp.2.2).smul (hcg.sub hcf)).contMDiffWithinAt
+  have hd : Module.finrank ℝ (E × E') < Module.finrank ℝ F := by
+    simpa only [Module.finrank_prod] using hdim
+  have hdense := Smale.GeneralPosition.dense_compl_manifold_image hs hb hd
+  obtain ⟨δ, hδ, hvalid⟩ := exists_radius_valid c hf hβ hcompact hsupport
+  obtain ⟨a, ha, har⟩ := hdense.exists_dist_lt 0 (lt_min hε hδ)
+  have haε : ‖a‖ < ε :=
+    (lt_min_iff.mp (show ‖a‖ < Min.min ε δ by simpa only [dist_zero_left] using har)).1
+  have haδ : ‖a‖ < δ :=
+    (lt_min_iff.mp (show ‖a‖ < Min.min ε δ by simpa only [dist_zero_left] using har)).2
+  have hva : Valid c f β a := hvalid a haδ
+  refine ⟨a, haε, hva, contMDiff_perturb c hf hβ hsupport hva, ?_⟩
+  intro x hx y hxy
+  have hfx : f x ∈ c.source := hsupport (subset_tsupport β hx)
+  have hgy : g y ∈ c.source := hxy ▸ perturb_mem_source c f β hva hfx
+  have heq : c (f x) + β x • a = c (g y) := by
+    rw [← hxy, chart_perturb c f β hva hfx]
+    rfl
+  apply ha
+  refine ⟨(x, y), ⟨hfx, hgy, hx⟩, ?_⟩
+  change (β x)⁻¹ • (c (g y) - c (f x)) = a
+  rw [← heq, add_sub_cancel_left, smul_smul, inv_mul_cancel₀ hx, one_smul]
+
+private structure
+    Smale.GeneralPosition.MapAvoidancePatch {E G H K X N : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H]
+    [TopologicalSpace K] (I : ModelWithCorners ℝ E H) (J : ModelWithCorners ℝ G K)
+    [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace N] [ChartedSpace K N]
+    (C : Set X) where
+  chart : PartialDiffeomorph J 𝓘(ℝ, G) N G ∞
+  cutoff : X → ℝ
+  smooth : ContMDiff I 𝓘(ℝ, ℝ) ∞ cutoff
+  compact : HasCompactSupport cutoff
+  fixed : ∀ x ∈ C, cutoff x = 0
+
+private def Smale.GeneralPosition.MapAvoidancePatch.Compatible {E G H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [TopologicalSpace H] [TopologicalSpace K] {I : ModelWithCorners ℝ E H}
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace N]
+    [ChartedSpace K N] {C : Set X} (p : Smale.GeneralPosition.MapAvoidancePatch I J (N := N) C)
+    (f : X → N) : Prop :=
+  Set.MapsTo f (tsupport p.cutoff) p.chart.source
+
+private theorem Smale.GeneralPosition.exists_patch_step {E G H K X N : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H]
+    [TopologicalSpace K] {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ G K}
+    [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace N] [ChartedSpace K N]
+    {E' H' Y : Type*} [NormedAddCommGroup E'] [NormedSpace ℝ E'] [FiniteDimensional ℝ E']
+    [FiniteDimensional ℝ E] [FiniteDimensional ℝ G] [TopologicalSpace H']
+    {I' : ModelWithCorners ℝ E' H'} [IsManifold I ∞ X] [TopologicalSpace Y] [ChartedSpace H' Y]
+    [IsManifold I' ∞ Y] [LindelofSpace (X × Y)] {ι : Type*} [Finite ι] {C : Set X}
+    (p : ι → MapAvoidancePatch I J (N := N) C) (i : ι) (f : C(X, N)) (g : C(Y, N))
+    (hf : ContMDiff I J ∞ f) (hg : ContMDiff I' J ∞ g) (hcompatible : ∀ j, (p j).Compatible f)
+    (hdim : Module.finrank ℝ E + Module.finrank ℝ E' < Module.finrank ℝ G) :
+    ∃ f' : C(X, N),
+      ContMDiff I J ∞ f' ∧
+        (∀ j, (p j).Compatible f') ∧
+          f.HomotopicRel f' C ∧
+            ∀ x, (f x ∉ Set.range g ∨ (p i).cutoff x ≠ 0) → f' x ∉ Set.range g := by
+  have hkeep :
+    ∀ᶠ a in 𝓝 (0 : G),
+      ∀ j, (p j).Compatible (Smale.ChartMapPerturbation.perturb (p i).chart f (p i).cutoff a) := by
+    apply Filter.eventually_all.mpr
+    intro j
+    exact
+      Smale.ChartMapPerturbation.eventually_maps_compact_into_open (p i).chart hf (p i).smooth
+        (hcompatible i) (p j).compact.isCompact (p j).chart.open_source (hcompatible j)
+  obtain ⟨δ, hδ, hδkeep⟩ := Metric.mem_nhds_iff.mp hkeep
+  obtain ⟨r, hr, hvalid⟩ :=
+    Smale.ChartMapPerturbation.exists_radius_valid (p i).chart hf (p i).smooth (p i).compact
+      (hcompatible i)
+  obtain ⟨a, ha, _, hsmooth, havoid⟩ :=
+    Smale.ChartMapPerturbation.exists_small_avoiding_parameter (p i).chart hf hg (p i).smooth
+      (p i).compact (hcompatible i) hdim (lt_min hδ hr)
+  have haδ : ‖a‖ < δ := (lt_min_iff.mp ha).1
+  have har : ‖a‖ < r := (lt_min_iff.mp ha).2
+  let f' : C(X, N) := ⟨_, hsmooth.continuous⟩
+  have H :=
+    Smale.ChartMapPerturbation.homotopyRel (p i).chart hf (p i).smooth (hcompatible i) hvalid har
+  refine ⟨f', hsmooth, ?_, ?_, ?_⟩
+  · exact hδkeep (by simpa only [Metric.mem_ball, dist_zero_right] using haδ)
+  · exact
+      ⟨{  toHomotopy := H.toHomotopy
+          prop' := fun t x hx => H.prop t x ((p i).fixed x hx) }⟩
+  · intro x hx
+    by_cases hzero : (p i).cutoff x = 0
+    · have hold : f x ∉ Set.range g := hx.resolve_right (Classical.not_not.mpr hzero)
+      change Smale.ChartMapPerturbation.perturb (p i).chart f (p i).cutoff a x ∉ Set.range g
+      rwa [Smale.ChartMapPerturbation.perturb_eq_of_zero _ _ _ _ hzero]
+    · rintro ⟨y, hy⟩
+      exact havoid x hzero y hy.symm
+
+private theorem Smale.GeneralPosition.exists_finite_patch_avoidance {E E' G H H' K X Y N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup E']
+    [NormedSpace ℝ E'] [FiniteDimensional ℝ E'] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H'] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ E H} {I' : ModelWithCorners ℝ E' H'} {J : ModelWithCorners ℝ G K}
+    [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X] [TopologicalSpace Y]
+    [ChartedSpace H' Y] [IsManifold I' ∞ Y] [TopologicalSpace N] [ChartedSpace K N]
+    [LindelofSpace (X × Y)] {ι : Type*} [Finite ι] {C : Set X}
+    (p : ι → MapAvoidancePatch I J (N := N) C) (f : C(X, N)) (g : C(Y, N))
+    (hf : ContMDiff I J ∞ f) (hg : ContMDiff I' J ∞ g) (hcompatible : ∀ j, (p j).Compatible f)
+    (hdim : Module.finrank ℝ E + Module.finrank ℝ E' < Module.finrank ℝ G) (s : Finset ι) :
+    ∃ f' : C(X, N),
+      ContMDiff I J ∞ f' ∧
+        (∀ j, (p j).Compatible f') ∧
+          f.HomotopicRel f' C ∧
+            ∀ x, (f x ∉ Set.range g ∨ ∃ i ∈ s, (p i).cutoff x ≠ 0) → f' x ∉ Set.range g := by
+  classical
+    induction s using Finset.induction_on with
+  | empty =>
+    refine ⟨f, hf, hcompatible, ContinuousMap.HomotopicRel.refl f, ?_⟩
+    intro x hx
+    simpa using hx
+  | @insert i s _ ih =>
+    obtain ⟨f₁, hf₁, hc₁, hhom₁, havoid₁⟩ := ih
+    obtain ⟨f₂, hf₂, hc₂, hhom₂, havoid₂⟩ := exists_patch_step p i f₁ g hf₁ hg hc₁ hdim
+    refine ⟨f₂, hf₂, hc₂, hhom₁.trans hhom₂, ?_⟩
+    intro x hx
+    apply havoid₂ x
+    rcases hx with hold | ⟨j, hj, hnonzero⟩
+    · exact Or.inl (havoid₁ x (Or.inl hold))
+    · rcases Finset.mem_insert.mp hj with rfl | hjs
+      · exact Or.inr hnonzero
+      · exact Or.inl (havoid₁ x (Or.inr ⟨j, hjs, hnonzero⟩))
+
+private theorem
+    Smale.GeneralPosition.exists_avoidance_of_finite_patches {E E' G H H' K X Y N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup E']
+    [NormedSpace ℝ E'] [FiniteDimensional ℝ E'] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H'] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ E H} {I' : ModelWithCorners ℝ E' H'} {J : ModelWithCorners ℝ G K}
+    [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X] [TopologicalSpace Y]
+    [ChartedSpace H' Y] [IsManifold I' ∞ Y] [TopologicalSpace N] [ChartedSpace K N]
+    [LindelofSpace (X × Y)] {ι : Type*} [Finite ι] {C : Set X}
+    (p : ι → MapAvoidancePatch I J (N := N) C) (f : C(X, N)) (g : C(Y, N))
+    (hf : ContMDiff I J ∞ f) (hg : ContMDiff I' J ∞ g) (hcompatible : ∀ j, (p j).Compatible f)
+    (hdim : Module.finrank ℝ E + Module.finrank ℝ E' < Module.finrank ℝ G)
+    (hcover : ∀ x, f x ∈ Set.range g → ∃ i, (p i).cutoff x ≠ 0) :
+    ∃ f' : C(X, N),
+      ContMDiff I J ∞ f' ∧ f.HomotopicRel f' C ∧ Disjoint (Set.range f') (Set.range g) := by
+  classical
+  let := Fintype.ofFinite ι
+  obtain ⟨f', hf', _, hhom, havoid⟩ :=
+    exists_finite_patch_avoidance p f g hf hg hcompatible hdim Finset.univ
+  refine ⟨f', hf', hhom, Set.disjoint_left.mpr ?_⟩
+  rintro z ⟨x, rfl⟩ hz
+  apply havoid x _ hz
+  by_cases hx : f x ∈ Set.range g
+  · obtain ⟨i, hi⟩ := hcover x hx
+    exact Or.inr ⟨i, Finset.mem_univ i, hi⟩
+  · exact Or.inl hx
+
+private theorem Smale.GeneralPosition.exists_avoidance_patch_at {E G H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] [TopologicalSpace K] {I : ModelWithCorners ℝ E H}
+    {J : ModelWithCorners ℝ G K} [J.Boundaryless] [TopologicalSpace X] [ChartedSpace H X]
+    [IsManifold I ∞ X] [T2Space X] [TopologicalSpace N] [ChartedSpace K N] [IsManifold J ∞ N]
+    (f : C(X, N)) {C : Set X} (hC : IsClosed C) {x : X} (hx : x ∉ C) :
+    ∃ p : MapAvoidancePatch I J (N := N) C, p.Compatible f ∧ p.cutoff x ≠ 0 := by
+  classical
+  let c := NoExotic.modelChartPartialDiffeomorph (I := J) (f x)
+  have hsource : f x ∈ c.source := mem_extChartAt_source (I := J) (f x)
+  have hU : f ⁻¹' c.source ∩ Cᶜ ∈ 𝓝 x :=
+    ((c.open_source.preimage f.continuous).inter hC.isOpen_compl).mem_nhds ⟨hsource, hx⟩
+  obtain ⟨φ, _, hφ⟩ := (SmoothBumpFunction.nhds_basis_tsupport (I := I) x).mem_iff.mp hU
+  let p : MapAvoidancePatch I J (N := N) C :=
+    { chart := c
+      cutoff := φ
+      smooth := φ.contMDiff
+      compact := φ.hasCompactSupport
+      fixed := by
+        intro y hy
+        exact image_eq_zero_of_notMem_tsupport (fun ht => (hφ ht).2 hy) }
+  refine ⟨p, ?_, ?_⟩
+  · exact fun y hy => (hφ hy).1
+  · change φ x ≠ 0
+    rw [φ.eq_one]
+    exact one_ne_zero
+
+private theorem Smale.GeneralPosition.exists_disjoint_smooth_map_homotopicRel_of_isClosed_range
+    {E G H K X N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H]
+    [TopologicalSpace K] {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ G K}
+    [J.Boundaryless] [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X] [T2Space X]
+    [TopologicalSpace N] [ChartedSpace K N] [IsManifold J ∞ N] {E' H' Y : Type*}
+    [NormedAddCommGroup E'] [NormedSpace ℝ E'] [FiniteDimensional ℝ E'] [TopologicalSpace H']
+    {I' : ModelWithCorners ℝ E' H'} [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y]
+    [CompactSpace X] [LindelofSpace (X × Y)] (f : C(X, N)) (g : C(Y, N)) (hf : ContMDiff I J ∞ f)
+    (hg : ContMDiff I' J ∞ g) (hclosed : IsClosed (Set.range g))
+    (hdim : Module.finrank ℝ E + Module.finrank ℝ E' < Module.finrank ℝ G) {C : Set X}
+    (hC : IsClosed C) (hfixed : ∀ x ∈ C, f x ∉ Set.range g) :
+    ∃ f' : C(X, N),
+      ContMDiff I J ∞ f' ∧ f.HomotopicRel f' C ∧ Disjoint (Set.range f') (Set.range g) := by
+  classical
+  let bad : Set X := f ⁻¹' Set.range g
+  have hbad : IsCompact bad := (hclosed.preimage f.continuous).isCompact
+  have hp (x : bad) : ∃ p : MapAvoidancePatch I J (N := N) C, p.Compatible f ∧ p.cutoff x.1 ≠ 0 :=
+    exists_avoidance_patch_at f hC (fun hx => hfixed x.1 hx x.2)
+  choose p hpcompatible hpactive using hp
+  have hopen (x : bad) : IsOpen (Function.support (p x).cutoff) :=
+    isOpen_ne_fun (p x).smooth.continuous continuous_const
+  have hcover : bad ⊆ ⋃ x : bad, Function.support (p x).cutoff := by
+    intro x hx
+    exact Set.mem_iUnion.mpr ⟨⟨x, hx⟩, hpactive ⟨x, hx⟩⟩
+  obtain ⟨s, hs⟩ :=
+    hbad.elim_finite_subcover (fun x : bad => Function.support (p x).cutoff) hopen hcover
+  apply
+    exists_avoidance_of_finite_patches (fun i : s => p i.1) f g hf hg (fun i => hpcompatible i.1)
+      hdim
+  intro x hx
+  obtain ⟨i, hi, hix⟩ := Set.mem_iUnion₂.mp (hs hx)
+  exact ⟨⟨i, hi⟩, hix⟩
+
+private theorem Smale.GeneralPosition.exists_disjoint_smooth_map_homotopicRel {E G H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ G K} [J.Boundaryless]
+    [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X] [T2Space X] [TopologicalSpace N]
+    [ChartedSpace K N] [IsManifold J ∞ N] {E' H' Y : Type*} [NormedAddCommGroup E']
+    [NormedSpace ℝ E'] [FiniteDimensional ℝ E'] [TopologicalSpace H']
+    {I' : ModelWithCorners ℝ E' H'} [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y]
+    [CompactSpace X] [CompactSpace Y] [T2Space N] (f : C(X, N)) (g : C(Y, N))
+    (hf : ContMDiff I J ∞ f) (hg : ContMDiff I' J ∞ g)
+    (hdim : Module.finrank ℝ E + Module.finrank ℝ E' < Module.finrank ℝ G) {C : Set X}
+    (hC : IsClosed C) (hfixed : ∀ x ∈ C, f x ∉ Set.range g) :
+    ∃ f' : C(X, N),
+      ContMDiff I J ∞ f' ∧ f.HomotopicRel f' C ∧ Disjoint (Set.range f') (Set.range g) :=
+  exists_disjoint_smooth_map_homotopicRel_of_isClosed_range f g hf hg
+    (isCompact_range g.continuous).isClosed hdim hC hfixed
+
+private def Smale.ImageComplement.domain {Y N : Type*} [TopologicalSpace Y] [CompactSpace Y]
+    [TopologicalSpace N] [T2Space N] (g : C(Y, N)) : TopologicalSpace.Opens N :=
+  ⟨(Set.range g)ᶜ, (isCompact_range g.continuous).isClosed.isOpen_compl⟩
+
+private def Smale.ImageComplement.inclusion {Y N : Type*} [TopologicalSpace Y] [CompactSpace Y]
+    [TopologicalSpace N] [T2Space N] (g : C(Y, N)) : C(domain g, N) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private theorem Smale.ImageComplement.exists_smooth_homotopy_of_ambient_homotopic {Y N : Type*}
+    [TopologicalSpace Y] [CompactSpace Y] [TopologicalSpace N] [T2Space N]
+    {E E' G H H' K X : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup E'] [NormedSpace ℝ E'] [FiniteDimensional ℝ E'] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    [TopologicalSpace K] {I : ModelWithCorners ℝ E H} {I' : ModelWithCorners ℝ E' H'}
+    {J : ModelWithCorners ℝ G K} [J.Boundaryless] [TopologicalSpace X] [ChartedSpace H X]
+    [IsManifold I ∞ X] [T2Space X] [CompactSpace X] [ChartedSpace H' Y] [IsManifold I' ∞ Y]
+    [ChartedSpace K N] [IsManifold J ∞ N] (g : C(Y, N)) (hg : ContMDiff I' J ∞ g)
+    (hdim : Module.finrank ℝ E + 1 + Module.finrank ℝ E' < Module.finrank ℝ G)
+    (f₀ f₁ : C(X, domain g)) (hf₀ : ContMDiff I J ∞ f₀) (hf₁ : ContMDiff I J ∞ f₁)
+    (hambient :
+      ((Smale.ImageComplement.inclusion g).comp f₀).Homotopic
+        ((Smale.ImageComplement.inclusion g).comp f₁)) :
+    ∃ H : f₀.Homotopy f₁,
+      ContMDiff ((𝓡∂ 1).prod I) J ∞ H ∧
+        (∀ t : unitInterval, ∀ x, (t : ℝ) ≤ 1 / 4 → H (t, x) = f₀ x) ∧
+          (∀ t : unitInterval, ∀ x, 3 / 4 ≤ (t : ℝ) → H (t, x) = f₁ x) := by
+  obtain ⟨H⟩ := hambient
+  have hval : ContMDiff J J ∞ (Smale.ImageComplement.inclusion g) := contMDiff_subtype_val
+  have hf₀val : ContMDiff I J ∞ ((Smale.ImageComplement.inclusion g).comp f₀) := hval.comp hf₀
+  have hf₁val : ContMDiff I J ∞ ((Smale.ImageComplement.inclusion g).comp f₁) := hval.comp hf₁
+  obtain ⟨H, hH, hlo, hhi⟩ :=
+    Smale.ManifoldSmoothing.exists_smooth_homotopy_with_collars hf₀val hf₁val H
+  have hd :
+    Module.finrank ℝ (EuclideanSpace ℝ (Fin 1) × E) + Module.finrank ℝ E' < Module.finrank ℝ G := by
+    simp only [Module.finrank_prod, finrank_euclideanSpace_fin]
+    omega
+  have hfixed : ∀ q ∈ Smale.ManifoldSmoothing.homotopyCollars X, H q ∉ Set.range g := by
+    rintro ⟨t, x⟩ (ht | ht)
+    · rw [hlo t x ht]
+      exact (f₀ x).property
+    · rw [hhi t x ht]
+      exact (f₁ x).property
+  obtain ⟨F, hF, hrel, hdisjoint⟩ :=
+    Smale.GeneralPosition.exists_disjoint_smooth_map_homotopicRel H.toContinuousMap g hH hg hd
+      Smale.ManifoldSmoothing.isClosed_homotopyCollars hfixed
+  have heq : Set.EqOn F H (Smale.ManifoldSmoothing.homotopyCollars X) := fun _ hq =>
+    (hrel.fst_eq_snd hq).symm
+  have havoid : ∀ q, F q ∈ domain g := by
+    intro q
+    change F q ∉ Set.range g
+    exact fun hq => Set.disjoint_left.mp hdisjoint ⟨q, rfl⟩ hq
+  let A : C(unitInterval × X, domain g) := ⟨fun q => ⟨F q, havoid q⟩, F.continuous.subtype_mk _⟩
+  have hA : ContMDiff ((𝓡∂ 1).prod I) J ∞ A := (ContMDiff.subtypeVal_comp_iff (domain g) A).mp hF
+  have hAlo (t : unitInterval) (x : X) (ht : (t : ℝ) ≤ 1 / 4) : A (t, x) = f₀ x := by
+    apply Subtype.ext
+    exact
+      (heq (show (t, x) ∈ Smale.ManifoldSmoothing.homotopyCollars X from Or.inl ht)).trans
+        (hlo t x ht)
+  have hAhi (t : unitInterval) (x : X) (ht : 3 / 4 ≤ (t : ℝ)) : A (t, x) = f₁ x := by
+    apply Subtype.ext
+    exact
+      (heq (show (t, x) ∈ Smale.ManifoldSmoothing.homotopyCollars X from Or.inr ht)).trans
+        (hhi t x ht)
+  exact
+    ⟨{  toContinuousMap := A
+        map_zero_left := fun x => hAlo 0 x (by norm_num)
+        map_one_left := fun x => hAhi 1 x (by norm_num) }, hA, hAlo, hAhi⟩
+
+private theorem
+    Smale.ImageComplement.homotopic_of_ambient_homotopic {Y N : Type*} [TopologicalSpace Y]
+    [CompactSpace Y] [TopologicalSpace N] [T2Space N] {E E' G H H' K X : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup E']
+    [NormedSpace ℝ E'] [FiniteDimensional ℝ E'] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H'] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ E H} {I' : ModelWithCorners ℝ E' H'} {J : ModelWithCorners ℝ G K}
+    [J.Boundaryless] [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X] [T2Space X]
+    [CompactSpace X] [ChartedSpace H' Y] [IsManifold I' ∞ Y] [ChartedSpace K N] [IsManifold J ∞ N]
+    (g : C(Y, N)) (hg : ContMDiff I' J ∞ g)
+    (hdim : Module.finrank ℝ E + 1 + Module.finrank ℝ E' < Module.finrank ℝ G)
+    (f₀ f₁ : C(X, domain g))
+    (hambient :
+      ((Smale.ImageComplement.inclusion g).comp f₀).Homotopic
+        ((Smale.ImageComplement.inclusion g).comp f₁)) :
+    f₀.Homotopic f₁ := by
+  obtain ⟨f₀', hf₀', h₀⟩ :=
+    Smale.ManifoldSmoothing.exists_smooth_map_homotopic (I := I) (J := J) f₀
+  obtain ⟨f₁', hf₁', h₁⟩ :=
+    Smale.ManifoldSmoothing.exists_smooth_map_homotopic (I := I) (J := J) f₁
+  have ha₀ := (ContinuousMap.Homotopic.refl (Smale.ImageComplement.inclusion g)).comp h₀
+  have ha₁ := (ContinuousMap.Homotopic.refl (Smale.ImageComplement.inclusion g)).comp h₁
+  obtain ⟨H, -⟩ :=
+    exists_smooth_homotopy_of_ambient_homotopic g hg hdim f₀' f₁' hf₀' hf₁'
+      (ha₀.symm.trans (hambient.trans ha₁))
+  exact h₀.trans ((show f₀'.Homotopic f₁' from ⟨H⟩).trans h₁.symm)
+
+private abbrev Smale.DiskDouble.Disk (E : Type*) [NormedAddCommGroup E] :=
+  Metric.closedBall (0 : E) 1
+
+private abbrev Smale.DiskDouble.Boundary (E : Type*) [NormedAddCommGroup E] :=
+  Metric.sphere (0 : E) 1
+
+private def
+    Smale.DiskDouble.boundary (E : Type*) [NormedAddCommGroup E] (x : Boundary E) : Disk E :=
+  ⟨x, Metric.sphere_subset_closedBall x.property⟩
+
+private def Smale.DiskDouble.Rel {E : Type*} [NormedAddCommGroup E] (e : Boundary E ≃ₜ Boundary E) :
+    Disk E ⊕ Disk E → Disk E ⊕ Disk E → Prop
+  | .inl x, .inr y => ∃ z : Boundary E, x = boundary E z ∧ y = boundary E (e z)
+  | _, _ => False
+
+private abbrev
+    Smale.DiskDouble.Space {E : Type*} [NormedAddCommGroup E] (e : Boundary E ≃ₜ Boundary E) :=
+  Quot (Smale.DiskDouble.Rel e)
+
+private def Smale.DiskDouble.untwist {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (e : Boundary E ≃ₜ Boundary E) : Disk E ⊕ Disk E ≃ₜ Disk E ⊕ Disk E :=
+  (Homeomorph.refl (Disk E)).sumCongr (Smale.RadialExtension.closedBallHomeomorph e.symm)
+
+private theorem
+    Smale.DiskDouble.rel_untwist_iff {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (e : Boundary E ≃ₜ Boundary E) (x y : Disk E ⊕ Disk E) :
+    Smale.DiskDouble.Rel e x y ↔
+      Smale.DiskDouble.Rel (Homeomorph.refl (Boundary E)) (untwist e x) (untwist e y) := by
+  cases x with
+  | inl x =>
+    cases y with
+    | inl y => rfl
+    | inr
+      y =>
+      change
+        (∃ z, x = boundary E z ∧ y = boundary E (e z)) ↔
+          ∃ z,
+            x = boundary E z ∧ Smale.RadialExtension.closedBallHomeomorph e.symm y = boundary E z
+      constructor
+      · rintro ⟨z, rfl, rfl⟩
+        refine ⟨z, rfl, ?_⟩
+        simp [boundary]
+      · rintro ⟨z, hx, hy⟩
+        refine ⟨z, hx, ?_⟩
+        apply (Smale.RadialExtension.closedBallHomeomorph e.symm).injective
+        rw [hy]
+        simp [boundary]
+  | inr x => cases y <;> rfl
+
+private def
+    Smale.DiskDouble.homeomorphUntwisted {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (e : Boundary E ≃ₜ Boundary E) : Space e ≃ₜ Space (Homeomorph.refl (Boundary E)) :=
+  Homeomorph.Quot.congr (untwist e) (rel_untwist_iff e)
+
+private abbrev Smale.Hemisphere.Ambient (n : ℕ) :=
+  EuclideanSpace ℝ (Fin n)
+
+private abbrev Smale.Hemisphere.Ball (n : ℕ) :=
+  Smale.DiskDouble.Disk (Ambient n)
+
+private abbrev Smale.Hemisphere.Sphere (n : ℕ) :=
+  Metric.sphere (0 : Ambient (n + 1)) 1
+
+private def Smale.Hemisphere.radius {n : ℕ} (x : Ball n) : ℝ :=
+  Real.sqrt (1 - ‖(x : Ambient n)‖ ^ 2)
+
+private theorem Smale.Hemisphere.radius_sq {n : ℕ} (x : Ball n) :
+    radius x ^ 2 = 1 - ‖(x : Ambient n)‖ ^ 2 := by
+  apply Real.sq_sqrt
+  have hx : ‖(x : Ambient n)‖ ≤ 1 := mem_closedBall_zero_iff.mp x.property
+  nlinarith [norm_nonneg (x : Ambient n)]
+
+private def Smale.Hemisphere.vector {n : ℕ} (b : Bool) (x : Ball n) : Ambient (n + 1) :=
+  WithLp.toLp 2 (Fin.cons (if b then radius x else -radius x) (x : Ambient n))
+
+@[simp]
+private theorem Smale.Hemisphere.vector_zero {n : ℕ} (b : Bool) (x : Ball n) :
+    vector b x 0 = if b then radius x else -radius x :=
+  rfl
+
+@[simp]
+private theorem Smale.Hemisphere.vector_succ {n : ℕ} (b : Bool) (x : Ball n) (i : Fin n) :
+    vector b x i.succ = (x : Ambient n) i :=
+  rfl
+
+private theorem
+    Smale.Hemisphere.vector_norm_sq {n : ℕ} (b : Bool) (x : Ball n) : ‖vector b x‖ ^ 2 = 1 := by
+  rw [EuclideanSpace.real_norm_sq_eq, Fin.sum_univ_succ]
+  simp only [vector_zero, vector_succ]
+  rw [← EuclideanSpace.real_norm_sq_eq]
+  cases b <;> simp only [Bool.false_eq_true, ↓reduceIte, neg_sq] <;> rw [radius_sq] <;> ring
+
+private def Smale.Hemisphere.point {n : ℕ} (b : Bool) (x : Ball n) : Sphere n :=
+  ⟨vector b x, by
+    rw [mem_sphere_zero_iff_norm]
+    have h := vector_norm_sq b x
+    nlinarith [norm_nonneg (vector b x)]⟩
+
+@[simp]
+private theorem Smale.Hemisphere.point_zero {n : ℕ} (b : Bool) (x : Ball n) :
+    (point b x : Ambient (n + 1)) 0 = if b then radius x else -radius x :=
+  rfl
+
+private theorem Smale.Hemisphere.continuous_radius {n : ℕ} : Continuous (radius (n := n)) := by
+  unfold radius
+  fun_prop
+
+private theorem
+    Smale.Hemisphere.continuous_vector {n : ℕ} (b : Bool) : Continuous (vector (n := n) b) := by
+  apply (PiLp.continuous_toLp 2 (fun _ : Fin (n + 1) => ℝ)).comp
+  apply continuous_pi
+  intro i
+  refine Fin.cases ?_ (fun j => ?_) i
+  · cases b
+    · exact continuous_radius.neg
+    · exact continuous_radius
+  · exact (PiLp.continuous_apply 2 (fun _ : Fin n => ℝ) j).comp continuous_subtype_val
+
+private theorem
+    Smale.Hemisphere.continuous_point {n : ℕ} (b : Bool) : Continuous (point (n := n) b) :=
+  (continuous_vector b).subtype_mk _
+
+private theorem Smale.Hemisphere.point_injective {n : ℕ} (b : Bool) :
+    Function.Injective (point (n := n) b) := by
+  intro x y h
+  apply Subtype.ext
+  ext i
+  exact congrArg (fun z : Sphere n => (z : Ambient (n + 1)) i.succ) h
+
+@[simp]
+private theorem
+    Smale.Hemisphere.radius_boundary {n : ℕ} (x : Smale.DiskDouble.Boundary (Ambient n)) :
+    radius (Smale.DiskDouble.boundary (Ambient n) x) = 0 := by
+  have hx : ‖(x : Ambient n)‖ = 1 := mem_sphere_zero_iff_norm.mp x.property
+  simp [radius, Smale.DiskDouble.boundary, hx]
+
+private theorem
+    Smale.Hemisphere.point_boundary {n : ℕ} (x : Smale.DiskDouble.Boundary (Ambient n)) :
+    point Bool.false (Smale.DiskDouble.boundary (Ambient n) x) =
+      point Bool.true (Smale.DiskDouble.boundary (Ambient n) x) := by
+  apply Subtype.ext
+  ext i
+  refine Fin.cases ?_ (fun j => ?_) i
+  · simp
+  · rfl
+
+private theorem Smale.Hemisphere.point_false_eq_true_iff {n : ℕ} (x y : Ball n) :
+    point Bool.false x = point Bool.true y ↔
+      ∃ z : Smale.DiskDouble.Boundary (Ambient n),
+        x = Smale.DiskDouble.boundary (Ambient n) z ∧
+          y = Smale.DiskDouble.boundary (Ambient n) z := by
+  constructor
+  · intro h
+    have hxy : x = y := by
+      apply Subtype.ext
+      ext i
+      exact congrArg (fun z : Sphere n => (z : Ambient (n + 1)) i.succ) h
+    subst y
+    have hr : radius x = 0 := by
+      have hh := congrArg (fun z : Sphere n => (z : Ambient (n + 1)) 0) h
+      simp only [point_zero, Bool.false_eq_true, ↓reduceIte] at hh
+      linarith
+    have hn : ‖(x : Ambient n)‖ = 1 := by
+      have hs := radius_sq x
+      rw [hr] at hs
+      nlinarith [norm_nonneg (x : Ambient n)]
+    exact ⟨⟨x, mem_sphere_zero_iff_norm.mpr hn⟩, rfl, rfl⟩
+  · rintro ⟨z, rfl, rfl⟩
+    exact point_boundary z
+
+private theorem
+    Smale.ImageComplement.nullhomotopic_of_ambient_nullhomotopic {E E' G H H' K X Y N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup E']
+    [NormedSpace ℝ E'] [FiniteDimensional ℝ E'] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H'] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ E H} {I' : ModelWithCorners ℝ E' H'} {J : ModelWithCorners ℝ G K}
+    [J.Boundaryless] [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X] [T2Space X]
+    [CompactSpace X] [Nonempty X] [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y]
+    [CompactSpace Y] [TopologicalSpace N] [ChartedSpace K N] [IsManifold J ∞ N] [T2Space N]
+    (g : C(Y, N)) (hg : ContMDiff I' J ∞ g)
+    (hdim : Module.finrank ℝ E + 1 + Module.finrank ℝ E' < Module.finrank ℝ G)
+    (f : C(X, domain g))
+    (hambient :
+      ∃ c, ((Smale.ImageComplement.inclusion g).comp f).Homotopic (ContinuousMap.const X c)) :
+    ∃ c, f.Homotopic (ContinuousMap.const X c) := by
+  classical
+  obtain ⟨c, hc⟩ := hambient
+  let x₀ : X := Classical.choice (inferInstance : Nonempty X)
+  have hconst :
+    (ContinuousMap.const X ((f x₀ : domain g) : N)).Homotopic (ContinuousMap.const X c) :=
+    hc.comp (ContinuousMap.Homotopic.refl (ContinuousMap.const X x₀))
+  refine
+    ⟨f x₀, homotopic_of_ambient_homotopic (I := I) g hg hdim f (ContinuousMap.const X (f x₀)) ?_⟩
+  exact hc.trans hconst.symm
+
+private theorem Smale.ImageComplement.circle_nullhomotopies {E' G H' K Y N : Type*}
+    [NormedAddCommGroup E'] [NormedSpace ℝ E'] [FiniteDimensional ℝ E'] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H'] [TopologicalSpace K]
+    {I' : ModelWithCorners ℝ E' H'} {J : ModelWithCorners ℝ G K} [J.Boundaryless]
+    [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y] [CompactSpace Y]
+    [TopologicalSpace N] [ChartedSpace K N] [IsManifold J ∞ N] [T2Space N] (g : C(Y, N))
+    (hg : ContMDiff I' J ∞ g) (hdim : 2 + Module.finrank ℝ E' < Module.finrank ℝ G)
+    (hnull : ∀ f : C(Smale.Hemisphere.Sphere 1, N), ∃ c, f.Homotopic (ContinuousMap.const _ c)) :
+    ∀ f : C(Smale.Hemisphere.Sphere 1, domain g), ∃ c, f.Homotopic (ContinuousMap.const _ c) := by
+  let : Nonempty (Smale.Hemisphere.Sphere 1) := NormedSpace.sphere_nonempty_rclike ℝ zero_le_one
+  intro f
+  apply nullhomotopic_of_ambient_nullhomotopic (I := 𝓡 1) g hg _ f (hnull _)
+  simpa only [finrank_euclideanSpace_fin] using hdim
+
+private theorem Smale.SurgeryBoundaryPair.beltComplement_circle_nullhomotopies_of_sphere_dimension
+    {F R X Y G H : Type*} [NormedAddCommGroup F] [NormedSpace ℝ F] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [J.Boundaryless] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    [ChartedSpace H X] [IsManifold J ∞ X] [T2Space X] {N : Type*} [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] [FiniteDimensional ℝ N] (n : ℕ) [Fact (Module.finrank ℝ N = n + 1)]
+    (d : Smale.SurgeryBoundaryPair N F R X Y) (hattach : ContMDiff (𝓡 n) J ∞ d.attachingSphere)
+    (hdim : 2 + n < Module.finrank ℝ G)
+    (hnull : ∀ f : C(Smale.Hemisphere.Sphere 1, X), ∃ c, f.Homotopic (ContinuousMap.const _ c)) :
+    ∀ f : C(Smale.Hemisphere.Sphere 1, d.NewComplement),
+      ∃ c, f.Homotopic (ContinuousMap.const _ c) := by
+  have hold :
+    ∀ f : C(Smale.Hemisphere.Sphere 1, d.OldComplement),
+      ∃ c, f.Homotopic (ContinuousMap.const _ c) := by
+    apply Smale.ImageComplement.circle_nullhomotopies d.attachingSphere hattach _ hnull
+    simpa only [finrank_euclideanSpace_fin] using hdim
+  intro f
+  let e := d.complementHomeomorph
+  let forward : C(d.OldComplement, d.NewComplement) := ⟨e, e.continuous⟩
+  let backward : C(d.NewComplement, d.OldComplement) := ⟨e.symm, e.symm.continuous⟩
+  let f₀ : C(Smale.Hemisphere.Sphere 1, d.OldComplement) := backward.comp f
+  obtain ⟨c, hc⟩ := hold f₀
+  have heq : forward.comp f₀ = f := by
+    apply ContinuousMap.ext
+    intro x
+    exact e.apply_symm_apply (f x)
+  have hout : (forward.comp f₀).Homotopic (ContinuousMap.const _ (e c)) :=
+    (ContinuousMap.Homotopic.refl forward).comp hc
+  exact ⟨e c, heq ▸ hout⟩
+
+private theorem Smale.SurgeryBoundaryPair.beltComplement_circle_nullhomotopies_of_finrank_two
+    {F R X Y G H : Type*} [NormedAddCommGroup F] [NormedSpace ℝ F] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [J.Boundaryless] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    [ChartedSpace H X] [IsManifold J ∞ X] [T2Space X] {N : Type*} [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] [FiniteDimensional ℝ N] [Fact (Module.finrank ℝ N = 1 + 1)]
+    (d : Smale.SurgeryBoundaryPair N F R X Y) (hattach : ContMDiff (𝓡 1) J ∞ d.attachingSphere)
+    (hdim : 3 < Module.finrank ℝ G)
+    (hnull : ∀ f : C(Smale.Hemisphere.Sphere 1, X), ∃ c, f.Homotopic (ContinuousMap.const _ c)) :
+    ∀ f : C(Smale.Hemisphere.Sphere 1, d.NewComplement),
+      ∃ c, f.Homotopic (ContinuousMap.const _ c) :=
+  d.beltComplement_circle_nullhomotopies_of_sphere_dimension 1 hattach hdim hnull
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SignedMorseChart.attachingSphere_eq_attachingCoreMap {E M R Y : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [TopologicalSpace R] [TopologicalSpace Y] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (d :
+      Smale.SurgeryBoundaryPair c.NegativeCoordinates c.PositiveCoordinates R
+        { x : M // f x = f p - ρ ^ 2 } Y)
+    (hpiece :
+      ∀ z,
+        (d.oldPiece z : M) =
+          c.normHandleMap ρ hρ hblock (Smale.PuncturedHandle.sphereToBall z.1, z.2)) :
+    d.attachingSphere = c.attachingCoreMap ρ hρ hblock := by
+  apply ContinuousMap.ext
+  intro u
+  apply Subtype.ext
+  change (d.oldPiece (u, Smale.PuncturedHandle.ballZero) : M) = _
+  rw [hpiece]
+  rfl
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SignedMorseChart.contMDiff_surgeryAttachingSphere {E M R Y : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [TopologicalSpace R] [TopologicalSpace Y] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (n : ℕ) [Fact (Module.finrank ℝ c.NegativeCoordinates = n + 1)]
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (hreg : ∀ x, f x = f p - ρ ^ 2 → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (d :
+      Smale.SurgeryBoundaryPair c.NegativeCoordinates c.PositiveCoordinates R
+        { x : M // f x = f p - ρ ^ 2 } Y)
+    (hpiece :
+      ∀ z,
+        (d.oldPiece z : M) =
+          c.normHandleMap ρ hρ hblock (Smale.PuncturedHandle.sphereToBall z.1, z.2)) :
+    letI := Smale.RegularLevel.chartedSpace hf hreg
+    ContMDiff (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ d.attachingSphere := by
+  let _ := Smale.RegularLevel.chartedSpace hf hreg
+  rw [c.attachingSphere_eq_attachingCoreMap ρ hρ hblock d hpiece]
+  exact c.contMDiff_attachingCoreMap n hf ρ hρ hblock hreg
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.surgery_beltComplement_circle_nullhomotopies
+    {E M R Y : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [TopologicalSpace R] [TopologicalSpace Y] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (hreg : ∀ x, f x = f p - ρ ^ 2 → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (d :
+      Smale.SurgeryBoundaryPair c.NegativeCoordinates c.PositiveCoordinates R
+        { x : M // f x = f p - ρ ^ 2 } Y)
+    (hpiece :
+      ∀ z,
+        (d.oldPiece z : M) =
+          c.normHandleMap ρ hρ hblock (Smale.PuncturedHandle.sphereToBall z.1, z.2))
+    (hindex : Module.finrank ℝ c.NegativeCoordinates = 2) (hdim : 4 < Module.finrank ℝ E)
+    (hnull :
+      ∀ g : C(Smale.Hemisphere.Sphere 1, { x : M // f x = f p - ρ ^ 2 }),
+        ∃ q, g.Homotopic (ContinuousMap.const _ q)) :
+    ∀ g : C(Smale.Hemisphere.Sphere 1, d.NewComplement),
+      ∃ q, g.Homotopic (ContinuousMap.const _ q) := by
+  let _ := Smale.RegularLevel.chartedSpace hf hreg
+  let _ := Smale.RegularLevel.isManifold hf hreg
+  let _ : Fact (Module.finrank ℝ c.NegativeCoordinates = 1 + 1) := ⟨hindex⟩
+  have hattach := c.contMDiff_surgeryAttachingSphere 1 hf ρ hρ hblock hreg d hpiece
+  apply d.beltComplement_circle_nullhomotopies_of_finrank_two hattach _ hnull
+  rw [finrank_euclideanSpace_fin]
+  omega
+
+private abbrev Smale.PuncturedHandle.OpenUnitBall (N : Type*) [NormedAddCommGroup N] :=
+  { x : N // ‖x‖ < 1 }
+
+private abbrev Smale.SurgeryBoundaryPair.NewInterior {N P R X Y : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair N P R X Y) : Set Y :=
+  (Set.range d.newExterior)ᶜ
+
+private theorem
+    Smale.SurgeryBoundaryPair.isOpen_newInterior {N P R X Y : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair N P R X Y) : IsOpen d.NewInterior :=
+  d.newExterior_closed.isClosed_range.isOpen_compl
+
+private theorem Smale.SurgeryBoundaryPair.newPiece_mem_exterior_iff {N P R X Y : Type*}
+    [NormedAddCommGroup N] [NormedAddCommGroup P] [TopologicalSpace R] [TopologicalSpace X]
+    [TopologicalSpace Y] (d : Smale.SurgeryBoundaryPair N P R X Y)
+    (p : Smale.PuncturedHandle.UnitBall N × Smale.PuncturedHandle.UnitSphere P) :
+    d.newPiece p ∈ Set.range d.newExterior ↔ ‖(p.1 : N)‖ = 1 := by
+  constructor
+  · rintro ⟨r, hr⟩
+    obtain ⟨q, -, rfl⟩ := (d.new_overlap r p).mp hr
+    exact mem_sphere_zero_iff_norm.mp q.1.property
+  · intro hp
+    let q : Smale.PuncturedHandle.UnitSphere N × Smale.PuncturedHandle.UnitSphere P :=
+      (⟨p.1, mem_sphere_zero_iff_norm.mpr hp⟩, p.2)
+    exact ⟨d.boundary q, (d.new_overlap _ _).mpr ⟨q, rfl, rfl⟩⟩
+
+private theorem Smale.SurgeryBoundaryPair.newPiece_mem_newInterior_iff {N P R X Y : Type*}
+    [NormedAddCommGroup N] [NormedAddCommGroup P] [TopologicalSpace R] [TopologicalSpace X]
+    [TopologicalSpace Y] (d : Smale.SurgeryBoundaryPair N P R X Y)
+    (p : Smale.PuncturedHandle.UnitBall N × Smale.PuncturedHandle.UnitSphere P) :
+    d.newPiece p ∈ d.NewInterior ↔ ‖(p.1 : N)‖ < 1 := by
+  change ¬d.newPiece p ∈ Set.range d.newExterior ↔ _
+  rw [d.newPiece_mem_exterior_iff]
+  constructor
+  · intro hp
+    rcases lt_or_eq_of_le p.1.property with h | h
+    · exact h
+    · exact (hp h).elim
+  · exact fun h => h.ne
+
+private theorem Smale.SurgeryBoundaryPair.newInterior_subset_range {N P R X Y : Type*}
+    [NormedAddCommGroup N] [NormedAddCommGroup P] [TopologicalSpace R] [TopologicalSpace X]
+    [TopologicalSpace Y] (d : Smale.SurgeryBoundaryPair N P R X Y) :
+    d.NewInterior ⊆ Set.range d.newPiece := by
+  intro y hy
+  have hc : y ∈ Set.range d.newExterior ∪ Set.range d.newPiece := by rw [d.new_cover]; trivial
+  exact hc.resolve_left hy
+
+private def
+    Smale.SurgeryBoundaryPair.newInteriorParameter {N P R X Y : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair N P R X Y) :
+    (Smale.PuncturedHandle.OpenUnitBall N × Smale.PuncturedHandle.UnitSphere P) ≃ₜ
+      (d.newPiece ⁻¹' d.NewInterior)
+    where
+  toFun p := ⟨(⟨p.1, p.1.property.le⟩, p.2), (d.newPiece_mem_newInterior_iff _).mpr p.1.property⟩
+  invFun p := (⟨p.val.1, (d.newPiece_mem_newInterior_iff _).mp p.property⟩, p.val.2)
+  left_inv := fun _ => rfl
+  right_inv := fun _ => rfl
+  continuous_toFun := by fun_prop
+  continuous_invFun := by fun_prop
+
+private def
+    Smale.SurgeryBoundaryPair.newInteriorHomeomorph {N P R X Y : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair N P R X Y) :
+    (Smale.PuncturedHandle.OpenUnitBall N × Smale.PuncturedHandle.UnitSphere P) ≃ₜ
+      d.NewInterior :=
+  d.newInteriorParameter.trans
+    (d.newPiece_closed.isEmbedding.homeomorphOfSubsetRange d.newInterior_subset_range)
+
+private theorem Smale.SurgeryBoundaryPair.beltSphere_mem_newInterior {N P R X Y : Type*}
+    [NormedAddCommGroup N] [NormedAddCommGroup P] [TopologicalSpace R] [TopologicalSpace X]
+    [TopologicalSpace Y] (d : Smale.SurgeryBoundaryPair N P R X Y)
+    (v : Smale.PuncturedHandle.UnitSphere P) : d.beltSphere v ∈ d.NewInterior := by
+  apply (d.newPiece_mem_newInterior_iff (Smale.PuncturedHandle.ballZero, v)).mpr
+  simp [Smale.PuncturedHandle.ballZero]
+
+private theorem Smale.SurgeryBoundaryPair.newInteriorHomeomorph_mem_belt_iff {N P R X Y : Type*}
+    [NormedAddCommGroup N] [NormedAddCommGroup P] [TopologicalSpace R] [TopologicalSpace X]
+    [TopologicalSpace Y] (d : Smale.SurgeryBoundaryPair N P R X Y)
+    (p : Smale.PuncturedHandle.OpenUnitBall N × Smale.PuncturedHandle.UnitSphere P) :
+    (d.newInteriorHomeomorph p : Y) ∈ Set.range d.beltSphere ↔ (p.1 : N) = 0 :=
+  d.newPiece_mem_belt_iff (⟨p.1, p.1.property.le⟩, p.2)
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.OpenHomotopyExtension.extendFunction {X Y : Type*} [TopologicalSpace X]
+    (U : TopologicalSpace.Opens X) (f : X → Y) (g : U → Y) : X → Y := fun x =>
+  if hx : x ∈ U then g ⟨x, hx⟩ else f x
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.OpenHomotopyExtension.extendFunction_of_mem {X Y : Type*} [TopologicalSpace X]
+    (U : TopologicalSpace.Opens X) (f : X → Y) (g : U → Y) (x : U) :
+    extendFunction U f g x = g x := by simp only [extendFunction, dite_eq_left x.property]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.OpenHomotopyExtension.extendFunction_of_not_mem {X Y : Type*} [TopologicalSpace X]
+    (U : TopologicalSpace.Opens X) (f : X → Y) (g : U → Y) {x : X} (hx : x ∉ U) :
+    extendFunction U f g x = f x := by simp only [extendFunction, dite_eq_right hx]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.OpenHomotopyExtension.continuous_extendFunction {X Y : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] (U : TopologicalSpace.Opens X) (f : X → Y) (g : U → Y)
+    (hf : Continuous f) (hg : Continuous g) {K : Set X} (hK : IsClosed K) (hKU : K ⊆ U)
+    (hfixed : ∀ x : U, (x : X) ∉ K → g x = f x) : Continuous (extendFunction U f g) := by
+  have hU : ContinuousOn (extendFunction U f g) U := by
+    rw [continuousOn_iff_continuous_domRestrict]
+    have heq : (U : Set X).domRestrict (extendFunction U f g) = g :=
+      funext (extendFunction_of_mem U f g)
+    rw [heq]
+    exact hg
+  have haway : ContinuousOn (extendFunction U f g) Kᶜ := by
+    apply hf.continuousOn.congr
+    intro x hx
+    by_cases hxU : x ∈ U
+    · rw [extendFunction, dite_eq_left hxU]
+      exact hfixed ⟨x, hxU⟩ hx
+    · exact extendFunction_of_not_mem U f g hxU
+  have hcover : (U : Set X) ∪ Kᶜ = Set.univ := by
+    apply Set.eq_univ_of_forall
+    intro x
+    by_cases hx : x ∈ K
+    · exact Or.inl (hKU hx)
+    · exact Or.inr hx
+  apply continuousOn_univ.mp
+  rw [← hcover]
+  exact hU.union_of_isOpen haway U.isOpen hK.isOpen_compl
+
+private theorem
+    Smale.OpenHomotopyExtension.exists_extended_homotopy {X Y : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] (U : TopologicalSpace.Opens X) (f : C(X, Y)) (H : C(unitInterval × U, Y))
+    {K : Set X} (hK : IsClosed K) (hKU : K ⊆ U) (hzero : ∀ x : U, H (0, x) = f x)
+    (hfixed : ∀ t (x : U), (x : X) ∉ K → H (t, x) = f x) :
+    ∃ g : C(X, Y),
+      ∃ G : f.Homotopy g, (∀ t (x : U), G (t, x) = H (t, x)) ∧ (∀ t x, x ∉ K → G (t, x) = f x) := by
+  let V : TopologicalSpace.Opens (unitInterval × X) :=
+    ⟨Prod.snd ⁻¹' U, U.isOpen.preimage continuous_snd⟩
+  let L : V → Y := fun z => H (z.val.1, ⟨z.val.2, z.property⟩)
+  have hL : Continuous L :=
+    H.continuous.comp
+      ((continuous_fst.comp continuous_subtype_val).prodMk
+        ((continuous_snd.comp continuous_subtype_val).subtype_mk _))
+  let T : C(unitInterval × X, Y) :=
+    ⟨extendFunction V (fun z => f z.2) L,
+      continuous_extendFunction V _ L (f.continuous.comp continuous_snd) hL
+        (hK.preimage continuous_snd) (fun _ hz => hKU hz)
+        (fun z hz => hfixed z.val.1 ⟨z.val.2, z.property⟩ hz)⟩
+  have hlocal (t) (x : U) : T (t, x) = H (t, x) :=
+    extendFunction_of_mem V (fun z : unitInterval × X => f z.2) L ⟨(t, x), x.property⟩
+  have houtside (t) (x : X) (hx : x ∉ K) : T (t, x) = f x := by
+    by_cases hxU : x ∈ U
+    · exact (hlocal t ⟨x, hxU⟩).trans (hfixed t ⟨x, hxU⟩ hx)
+    · exact extendFunction_of_not_mem V (fun z : unitInterval × X => f z.2) L (x := (t, x)) hxU
+  let g : C(X, Y) := T.comp ⟨fun x => (1, x), continuous_const.prodMk continuous_id⟩
+  refine
+    ⟨g, { toContinuousMap := T, map_zero_left := ?_, map_one_left := fun _ => rfl }, hlocal,
+      houtside⟩
+  intro x
+  by_cases hx : x ∈ U
+  · exact (hlocal 0 ⟨x, hx⟩).trans (hzero ⟨x, hx⟩)
+  · exact houtside 0 x (fun h => hx (hKU h))
+
+private theorem NoExotic.dimH_image_le_of_contDiffOn_isOpen {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F}
+    {s : Set E} (hs : IsOpen s) (hf : ContDiffOn ℝ 1 f s) : dimH (f '' s) ≤ dimH s := by
+  apply dimH_image_le_of_locally_lipschitzOn
+  intro x hx
+  obtain ⟨C, U, hU, hL⟩ := (hf.contDiffAt (hs.mem_nhds hx)).exists_lipschitzOnWith
+  exact ⟨C, U, mem_nhdsWithin_of_mem_nhds hU, hL⟩
+
+private theorem NoExotic.dimH_image_chart_le {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {H M : Type*}
+    [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [I.Boundaryless] [TopologicalSpace M]
+    [ChartedSpace H M] [IsManifold I ∞ M] {f : M → F} {s : Set M} (hs : IsOpen s)
+    (hf : ContMDiffOn I 𝓘(ℝ, F) ∞ f s) (x : M) :
+    dimH (f '' ((modelChartPartialDiffeomorph (I := I) x).source ∩ s)) ≤ Module.finrank ℝ E := by
+  let c := modelChartPartialDiffeomorph (I := I) x
+  let V : Set E := c.target ∩ c.symm ⁻¹' s
+  have hV : IsOpen V := c.contMDiffOn_invFun.continuousOn.isOpen_inter_preimage c.open_target hs
+  have hfc : ContDiffOn ℝ ∞ (f ∘ c.symm) V :=
+    (hf.comp (c.contMDiffOn_invFun.mono Set.inter_subset_left) Set.inter_subset_right).contDiffOn
+  have himage : f '' (c.source ∩ s) = (f ∘ c.symm) '' V := by
+    ext z
+    constructor
+    · rintro ⟨y, ⟨hyc, hys⟩, rfl⟩
+      refine ⟨c y, ⟨c.map_source' hyc, ?_⟩, ?_⟩
+      · change c.symm (c y) ∈ s
+        have hc : c.symm (c y) = y := c.left_inv' hyc
+        rwa [hc]
+      · exact congrArg f (c.left_inv' hyc)
+    · rintro ⟨y, ⟨hyc, hys⟩, rfl⟩
+      exact ⟨c.symm y, ⟨c.map_target' hyc, hys⟩, rfl⟩
+  change dimH (f '' (c.source ∩ s)) ≤ _
+  rw [himage]
+  exact
+    (dimH_image_le_of_contDiffOn_isOpen hV (hfc.of_le (by simp))).trans
+      ((dimH_mono (Set.subset_univ V)).trans_eq (Real.dimH_univ_eq_finrank E))
+
+private theorem
+    NoExotic.dimH_image_manifold_le {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {H M : Type*}
+    [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [I.Boundaryless] [TopologicalSpace M]
+    [ChartedSpace H M] [IsManifold I ∞ M] [LindelofSpace M] {f : M → F} {s : Set M}
+    (hs : IsOpen s) (hf : ContMDiffOn I 𝓘(ℝ, F) ∞ f s) : dimH (f '' s) ≤ Module.finrank ℝ E := by
+  let U : M → Set M := fun x ↦ (modelChartPartialDiffeomorph (I := I) x).source
+  have hU : ∀ x, IsOpen (U x) := fun x ↦ (modelChartPartialDiffeomorph (I := I) x).open_source
+  have hcover : (Set.univ : Set M) ⊆ ⋃ x, U x := by
+    intro x _
+    exact Set.mem_iUnion.mpr ⟨x, mem_extChartAt_source x⟩
+  obtain ⟨t, htcount, ht⟩ := isLindelof_univ.elim_countable_subcover U hU hcover
+  have himage : f '' s ⊆ ⋃ x ∈ t, f '' (U x ∩ s) := by
+    rintro z ⟨y, hys, rfl⟩
+    obtain ⟨x, hxt, hyx⟩ := Set.mem_iUnion₂.mp (ht (Set.mem_univ y))
+    exact Set.mem_iUnion₂.mpr ⟨x, hxt, y, ⟨hyx, hys⟩, rfl⟩
+  apply (dimH_mono himage).trans
+  rw [dimH_bUnion htcount]
+  exact iSup_le (fun x ↦ iSup_le (fun _ ↦ dimH_image_chart_le hs hf x))
+
+private theorem
+    NoExotic.dense_compl_manifold_image {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {H M : Type*}
+    [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [I.Boundaryless] [TopologicalSpace M]
+    [ChartedSpace H M] [IsManifold I ∞ M] [LindelofSpace M] [FiniteDimensional ℝ F] {f : M → F}
+    {s : Set M} (hs : IsOpen s) (hf : ContMDiffOn I 𝓘(ℝ, F) ∞ f s)
+    (hd : Module.finrank ℝ E < Module.finrank ℝ F) : Dense (f '' s)ᶜ :=
+  dense_compl_of_dimH_lt_finrank ((dimH_image_manifold_le hs hf).trans_lt (Nat.cast_lt.mpr hd))
+
+private theorem NoExotic.not_surjective_contMDiff_of_dim_lt {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    {H M : Type*} [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [I.Boundaryless]
+    [TopologicalSpace M] [ChartedSpace H M] [IsManifold I ∞ M] [LindelofSpace M]
+    [FiniteDimensional ℝ F] {G N : Type*} [TopologicalSpace G] {J : ModelWithCorners ℝ F G}
+    [J.Boundaryless] [TopologicalSpace N] [ChartedSpace G N] [IsManifold J ∞ N] [Nonempty N]
+    {f : M → N} (hf : ContMDiff I J ∞ f) (hd : Module.finrank ℝ E < Module.finrank ℝ F) :
+    ¬Function.Surjective f := by
+  intro hsurj
+  let y : N := Classical.choice inferInstance
+  let d := modelChartPartialDiffeomorph (I := J) y
+  let s : Set M := f ⁻¹' d.source
+  have hs : IsOpen s := d.open_source.preimage hf.continuous
+  have hdf : ContMDiffOn I 𝓘(ℝ, F) ∞ (d ∘ f) s :=
+    d.contMDiffOn_toFun.comp hf.contMDiffOn (fun _ h ↦ h)
+  have himage : (d ∘ f) '' s = d.target := by
+    ext z
+    constructor
+    · rintro ⟨x, hx, rfl⟩
+      exact d.map_source' hx
+    · intro hz
+      obtain ⟨x, hx⟩ := hsurj (d.symm z)
+      refine ⟨x, ?_, ?_⟩
+      · change f x ∈ d.source
+        rw [hx]
+        exact d.map_target' hz
+      · change d (f x) = z
+        rw [hx]
+        exact d.right_inv' hz
+  have hne : (interior d.target).Nonempty := by
+    rw [d.open_target.interior_eq]
+    exact ⟨d y, d.map_source' (mem_extChartAt_source y)⟩
+  have hdim := dimH_image_manifold_le hs hdf
+  rw [himage, Real.dimH_of_nonempty_interior hne] at hdim
+  exact
+    (not_le_of_gt (Nat.cast_lt.mpr hd : (Module.finrank ℝ E : ℝ≥0∞) < Module.finrank ℝ F)) hdim
+
+private theorem NoExotic.exists_smooth_nonzero_approx {B H M F : Type*} [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [FiniteDimensional ℝ B] [TopologicalSpace H] {I : ModelWithCorners ℝ B H}
+    [I.Boundaryless] [TopologicalSpace M] [ChartedSpace H M] [IsManifold I ∞ M]
+    [SigmaCompactSpace M] [T2Space M] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [FiniteDimensional ℝ F] (f : C(M, F)) (ε : ℝ) (hε : 0 < ε)
+    (hd : Module.finrank ℝ B < Module.finrank ℝ F) :
+    ∃ g : C(M, F), ContMDiff I 𝓘(ℝ, F) ∞ g ∧ (∀ x, g x ≠ 0) ∧ ∀ x, Dist.dist (g x) (f x) < ε := by
+  have hhalf : 0 < ε / 2 := by linarith
+  obtain ⟨h, hh, -⟩ :=
+    f.continuous.exists_contMDiff_approx I (⊤ : ℕ∞) (ε := fun _ ↦ ε / 2) continuous_const
+      (fun _ ↦ hhalf)
+  have hdense : Dense (Set.range h)ᶜ := by
+    simpa only [Set.image_univ] using
+      dense_compl_manifold_image isOpen_univ h.contMDiff.contMDiffOn hd
+  obtain ⟨a, ha, hdist⟩ := Metric.mem_closure_iff.mp (hdense (0 : F)) (ε / 2) hhalf
+  have haNorm : ‖a‖ < ε / 2 := by simpa only [dist_zero_left, dist_zero_right] using hdist
+  let g : C(M, F) := ⟨fun x ↦ h x - a, h.contMDiff.continuous.sub continuous_const⟩
+  refine ⟨g, h.contMDiff.sub contMDiff_const, ?_, ?_⟩
+  · intro x hx
+    have he : h x = a := sub_eq_zero.mp hx
+    exact ha ⟨x, he⟩
+  · intro x
+    have hnorm : ‖h x - a - f x‖ ≤ ‖h x - f x‖ + ‖a‖ := by
+      have he : h x - a - f x = (h x - f x) - a := by abel
+      rw [he]
+      exact norm_sub_le _ _
+    change Dist.dist (h x - a) (f x) < ε
+    rw [dist_eq_norm]
+    have hhx : ‖h x - f x‖ < ε / 2 := by simpa only [dist_eq_norm] using hh x
+    linarith
+
+private noncomputable def NoExotic.RealIntervalProgress.progress (l u t : ℝ) : ℝ :=
+  Set.projIcc (0 : ℝ) 1 zero_le_one ((t - l) / (u - l))
+
+private theorem
+    NoExotic.RealIntervalProgress.continuous_progress (l u : ℝ) : Continuous (progress l u) :=
+  continuous_subtype_val.comp
+    (continuous_projIcc.comp ((continuous_id.sub continuous_const).div_const _))
+
+private theorem
+    NoExotic.RealIntervalProgress.progress_before {l u t : ℝ} (hlu : l ≤ u) (ht : t ≤ l) :
+    progress l u t = 0 := by
+  have h :=
+    Set.projIcc_of_le_left (a := (0 : ℝ)) (b := 1) zero_le_one
+      (div_nonpos_of_nonpos_of_nonneg (sub_nonpos.mpr ht) (sub_nonneg.mpr hlu))
+  exact congrArg Subtype.val h
+
+private theorem
+    NoExotic.RealIntervalProgress.progress_after {l u t : ℝ} (hlu : l < u) (ht : u ≤ t) :
+    progress l u t = 1 := by
+  have hr : 1 ≤ (t - l) / (u - l) := by
+    apply (le_div_iff₀ (sub_pos.mpr hlu)).mpr
+    simpa only [one_mul] using sub_le_sub_right ht l
+  exact congrArg Subtype.val (Set.projIcc_of_right_le zero_le_one hr)
+
+private noncomputable def NoExotic.ZeroAvoidanceCutoff.weight {X F : Type*} [TopologicalSpace X]
+    [NormedAddCommGroup F] (f : C(X, F)) (ε : ℝ) : C(X, ℝ) :=
+  ⟨fun x ↦ 1 - NoExotic.RealIntervalProgress.progress ε (2 * ε) ‖f x‖,
+    continuous_const.sub
+      ((NoExotic.RealIntervalProgress.continuous_progress ε (2 * ε)).comp f.continuous.norm)⟩
+
+private theorem NoExotic.ZeroAvoidanceCutoff.weight_bounds {X F : Type*} [TopologicalSpace X]
+    [NormedAddCommGroup F] (f : C(X, F)) (ε : ℝ) (x : X) : 0 ≤ weight f ε x ∧ weight f ε x ≤ 1 := by
+  have hp : NoExotic.RealIntervalProgress.progress ε (2 * ε) ‖f x‖ ∈ Set.Icc (0 : ℝ) 1 :=
+    (Set.projIcc (0 : ℝ) 1 zero_le_one ((‖f x‖ - ε) / (2 * ε - ε))).property
+  change
+    0 ≤ 1 - NoExotic.RealIntervalProgress.progress ε (2 * ε) ‖f x‖ ∧
+      1 - NoExotic.RealIntervalProgress.progress ε (2 * ε) ‖f x‖ ≤ 1
+  constructor <;> linarith [hp.1, hp.2]
+
+private theorem NoExotic.ZeroAvoidanceCutoff.weight_small {X F : Type*} [TopologicalSpace X]
+    [NormedAddCommGroup F] (f : C(X, F)) (ε : ℝ) (hε : 0 < ε) {x : X} (hx : ‖f x‖ ≤ ε) :
+    weight f ε x = 1 := by
+  simp only [weight, ContinuousMap.coe_mk,
+    NoExotic.RealIntervalProgress.progress_before (by linarith : ε ≤ 2 * ε) hx, sub_zero]
+
+private theorem NoExotic.ZeroAvoidanceCutoff.weight_large {X F : Type*} [TopologicalSpace X]
+    [NormedAddCommGroup F] (f : C(X, F)) (ε : ℝ) (hε : 0 < ε) {x : X} (hx : 2 * ε ≤ ‖f x‖) :
+    weight f ε x = 0 := by
+  simp only [weight, ContinuousMap.coe_mk,
+    NoExotic.RealIntervalProgress.progress_after (by linarith : ε < 2 * ε) hx, sub_self]
+
+private noncomputable def NoExotic.ZeroAvoidanceCutoff.blend {X F : Type*} [TopologicalSpace X]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (f g : C(X, F)) (ε : ℝ) : C(X, F) :=
+  ⟨fun x ↦ f x + weight f ε x • (g x - f x),
+    f.continuous.add ((weight f ε).continuous.smul (g.continuous.sub f.continuous))⟩
+
+private theorem NoExotic.ZeroAvoidanceCutoff.blend_small {X F : Type*} [TopologicalSpace X]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (f g : C(X, F)) (ε : ℝ) (hε : 0 < ε) {x : X}
+    (hx : ‖f x‖ ≤ ε) : blend f g ε x = g x := by
+  change f x + weight f ε x • (g x - f x) = g x
+  rw [weight_small f ε hε hx, one_smul]
+  abel
+
+private theorem NoExotic.ZeroAvoidanceCutoff.blend_large {X F : Type*} [TopologicalSpace X]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (f g : C(X, F)) (ε : ℝ) (hε : 0 < ε) {x : X}
+    (hx : 2 * ε ≤ ‖f x‖) : blend f g ε x = f x := by
+  change f x + weight f ε x • (g x - f x) = f x
+  rw [weight_large f ε hε hx, zero_smul, add_zero]
+
+private theorem NoExotic.ZeroAvoidanceCutoff.dist_blend_le {X F : Type*} [TopologicalSpace X]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (f g : C(X, F)) (ε : ℝ) (x : X) :
+    Dist.dist (blend f g ε x) (f x) ≤ Dist.dist (g x) (f x) := by
+  simp only [dist_eq_norm]
+  change ‖f x + weight f ε x • (g x - f x) - f x‖ ≤ ‖g x - f x‖
+  rw [add_sub_cancel_left, norm_smul, Real.norm_eq_abs, abs_of_nonneg (weight_bounds f ε x).1]
+  exact mul_le_of_le_one_left (norm_nonneg _) (weight_bounds f ε x).2
+
+private theorem NoExotic.ZeroAvoidanceCutoff.blend_ne_zero {X F : Type*} [TopologicalSpace X]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (f g : C(X, F)) (ε : ℝ) (hε : 0 < ε)
+    (hg : ∀ x, g x ≠ 0) (hclose : ∀ x, Dist.dist (g x) (f x) < ε) (x : X) : blend f g ε x ≠ 0 := by
+  by_cases hx : ‖f x‖ ≤ ε
+  · rw [blend_small f g ε hε hx]
+    exact hg x
+  · intro hz
+    have hh := (dist_blend_le f g ε x).trans_lt (hclose x)
+    rw [hz, dist_zero_left] at hh
+    exact hx hh.le
+
+private noncomputable def NoExotic.ZeroAvoidanceCutoff.homotopy {X F : Type*} [TopologicalSpace X]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (f g : C(X, F)) (ε : ℝ) (hε : 0 < ε) :
+    ContinuousMap.HomotopyRel f (blend f g ε) {x | 2 * ε ≤ ‖f x‖}
+    where
+  toFun p := f p.2 + (p.1 : ℝ) • (blend f g ε p.2 - f p.2)
+  continuous_toFun :=
+    (f.continuous.comp continuous_snd).add
+      ((continuous_subtype_val.comp continuous_fst).smul
+        (((blend f g ε).continuous.comp continuous_snd).sub (f.continuous.comp continuous_snd)))
+  map_zero_left x := by simp
+  map_one_left
+    x := by
+    change f x + (1 : ℝ) • (blend f g ε x - f x) = blend f g ε x
+    rw [one_smul]
+    abel
+  prop' t x
+    hx := by
+    change f x + (t : ℝ) • (blend f g ε x - f x) = f x
+    rw [blend_large f g ε hε hx, sub_self, smul_zero, add_zero]
+
+private theorem NoExotic.ZeroAvoidanceCutoff.homotopy_dist_lt {X F : Type*} [TopologicalSpace X]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (f g : C(X, F)) (ε : ℝ) (hε : 0 < ε)
+    (hclose : ∀ x, Dist.dist (g x) (f x) < ε) (t : (unitInterval)) (x : X) :
+    Dist.dist (homotopy f g ε hε (t, x)) (f x) < ε := by
+  rw [dist_eq_norm]
+  change ‖f x + (t : ℝ) • (blend f g ε x - f x) - f x‖ < ε
+  rw [add_sub_cancel_left, norm_smul, Real.norm_eq_abs, abs_of_nonneg t.2.1]
+  calc
+    (t : ℝ) * ‖blend f g ε x - f x‖ ≤ ‖blend f g ε x - f x‖ :=
+      mul_le_of_le_one_left (norm_nonneg _) t.2.2
+    _ ≤ Dist.dist (g x) (f x) := by simpa only [dist_eq_norm] using dist_blend_le f g ε x
+    _ < ε := hclose x
+
+private theorem NoExotic.exists_nonzero_homotopy_small {B H M F : Type*} [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [FiniteDimensional ℝ B] [TopologicalSpace H] {I : ModelWithCorners ℝ B H}
+    [I.Boundaryless] [TopologicalSpace M] [ChartedSpace H M] [IsManifold I ∞ M]
+    [SigmaCompactSpace M] [T2Space M] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [FiniteDimensional ℝ F] (f : C(M, F)) (ε : ℝ) (hε : 0 < ε)
+    (hd : Module.finrank ℝ B < Module.finrank ℝ F) :
+    ∃ g : C(M, F),
+      (∀ x, g x ≠ 0) ∧
+        ∃ G : ContinuousMap.HomotopyRel f g {x | 2 * ε ≤ ‖f x‖},
+          ∀ t x, Dist.dist (G (t, x)) (f x) < ε := by
+  obtain ⟨h, -, hnonzero, hclose⟩ := exists_smooth_nonzero_approx (I := I) f ε hε hd
+  refine
+    ⟨ZeroAvoidanceCutoff.blend f h ε, ZeroAvoidanceCutoff.blend_ne_zero f h ε hε hnonzero hclose,
+      ZeroAvoidanceCutoff.homotopy f h ε hε, ?_⟩
+  exact ZeroAvoidanceCutoff.homotopy_dist_lt f h ε hε hclose
+
+private theorem Smale.SurgeryBoundaryPair.exists_belt_avoiding_circle {N P R X Y : Type*}
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [FiniteDimensional ℝ N] [NormedAddCommGroup P]
+    [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair N P R X Y) (hdim : 1 < Module.finrank ℝ N)
+    (g : C(Smale.Hemisphere.Sphere 1, Y)) :
+    ∃ g' : C(Smale.Hemisphere.Sphere 1, Y),
+      (∀ x, g' x ∉ Set.range d.beltSphere) ∧ g.Homotopic g' := by
+  let U : TopologicalSpace.Opens (Smale.Hemisphere.Sphere 1) :=
+    ⟨g ⁻¹' d.NewInterior, d.isOpen_newInterior.preimage g.continuous⟩
+  let _ : LocallyCompactSpace U := U.isOpen.locallyCompactSpace
+  let e := d.newInteriorHomeomorph
+  let coord : C(U, Smale.PuncturedHandle.OpenUnitBall N × Smale.PuncturedHandle.UnitSphere P) :=
+    ⟨fun x => e.symm ⟨g x, x.property⟩,
+      e.symm.continuous.comp ((g.continuous.comp continuous_subtype_val).subtype_mk _)⟩
+  let normal : C(U, N) := ⟨fun x => (coord x).1, continuous_subtype_val.comp coord.continuous.fst⟩
+  have hparam (x : U) : d.newPiece (⟨(coord x).1, (coord x).1.property.le⟩, (coord x).2) = g x :=
+    congrArg (fun y : d.NewInterior => (y : Y)) (e.apply_symm_apply ⟨g x, x.property⟩)
+  obtain ⟨q, hq, G, hclose⟩ :=
+    NoExotic.exists_nonzero_homotopy_small (I := 𝓡 1) normal (1 / 8) (by norm_num)
+      (by simpa only [finrank_euclideanSpace_fin] using hdim)
+  have hnorm (t) (x : U) : ‖G (t, x)‖ < 1 := by
+    by_cases hx : 1 / 4 ≤ ‖normal x‖
+    · rw [G.eq_fst t
+          (show x ∈ {x | 2 * (1 / 8 : ℝ) ≤ ‖normal x‖} from
+            by
+            change 2 * (1 / 8 : ℝ) ≤ ‖normal x‖
+            linarith)]
+      exact (coord x).1.property
+    · have hdist : ‖G (t, x) - normal x‖ < 1 / 8 := by simpa only [dist_eq_norm] using hclose t x
+      have hbound := norm_add_le (G (t, x) - normal x) (normal x)
+      rw [sub_add_cancel] at hbound
+      linarith
+  let H : C(unitInterval × U, Y) :=
+    ⟨fun z => (e (⟨G z, hnorm z.1 z.2⟩, (coord z.2).2) : Y),
+      continuous_subtype_val.comp
+        (e.continuous.comp
+          ((G.continuous.subtype_mk _).prodMk (coord.continuous.snd.comp continuous_snd)))⟩
+  have hreturn (t) (x : U) (hx : G (t, x) = normal x) : H (t, x) = g x := by
+    have hu : (⟨G (t, x), hnorm t x⟩ : Smale.PuncturedHandle.OpenUnitBall N) = (coord x).1 :=
+      Subtype.ext hx
+    change (e (⟨G (t, x), _⟩, (coord x).2) : Y) = _
+    rw [hu]
+    exact hparam x
+  have hzero (x : U) : H (0, x) = g x := hreturn 0 x (G.apply_zero x)
+  let K₀ : Set Y :=
+    d.newPiece ''
+      {p : Smale.PuncturedHandle.UnitBall N × Smale.PuncturedHandle.UnitSphere P |
+        ‖(p.1 : N)‖ ≤ 1 / 2}
+  have hK₀ : IsClosed K₀ :=
+    d.newPiece_closed.isClosedMap _
+      (isClosed_le (continuous_subtype_val.comp continuous_fst).norm continuous_const)
+  have hK₀U : K₀ ⊆ d.NewInterior := by
+    rintro _ ⟨p, hp, rfl⟩
+    apply (d.newPiece_mem_newInterior_iff p).mpr
+    exact hp.trans_lt (by norm_num)
+  let K : Set (Smale.Hemisphere.Sphere 1) := g ⁻¹' K₀
+  have hK : IsClosed K := hK₀.preimage g.continuous
+  have hKU : K ⊆ U := fun _ hx => hK₀U hx
+  have hfixed (t) (x : U) (hx : (x : Smale.Hemisphere.Sphere 1) ∉ K) : H (t, x) = g x := by
+    have hlarge : 1 / 2 < ‖normal x‖ := by
+      by_contra! hh
+      apply hx
+      exact ⟨(⟨(coord x).1, (coord x).1.property.le⟩, (coord x).2), hh, hparam x⟩
+    have hsafe : x ∈ {x | 2 * (1 / 8 : ℝ) ≤ ‖normal x‖} := by
+      change 2 * (1 / 8 : ℝ) ≤ ‖normal x‖
+      linarith
+    exact hreturn t x (G.eq_fst t hsafe)
+  obtain ⟨g', G', hlocal, houtside⟩ :=
+    Smale.OpenHomotopyExtension.exists_extended_homotopy U g H hK hKU hzero hfixed
+  refine ⟨g', ?_, ⟨G'⟩⟩
+  intro x hxB
+  by_cases hx : x ∈ U
+  · have heq : g' x = H (1, ⟨x, hx⟩) := (G'.apply_one x).symm.trans (hlocal 1 ⟨x, hx⟩)
+    rw [heq] at hxB
+    have hzero' : G (1, ⟨x, hx⟩) = 0 := (d.newInteriorHomeomorph_mem_belt_iff _).mp hxB
+    rw [G.apply_one] at hzero'
+    exact hq ⟨x, hx⟩ hzero'
+  · have heq : g' x = g x := (G'.apply_one x).symm.trans (houtside 1 x (fun h => hx (hKU h)))
+    rw [heq] at hxB
+    obtain ⟨v, hv⟩ := hxB
+    apply hx
+    change g x ∈ d.NewInterior
+    rw [← hv]
+    exact d.beltSphere_mem_newInterior v
+
+private theorem
+    Smale.SurgeryBoundaryPair.circle_nullhomotopies_of_beltComplement {N P R X Y : Type*}
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [FiniteDimensional ℝ N] [NormedAddCommGroup P]
+    [TopologicalSpace R] [TopologicalSpace X] [TopologicalSpace Y]
+    (d : Smale.SurgeryBoundaryPair N P R X Y) (hdim : 1 < Module.finrank ℝ N)
+    (hnull :
+      ∀ g : C(Smale.Hemisphere.Sphere 1, d.NewComplement),
+        ∃ q, g.Homotopic (ContinuousMap.const _ q)) :
+    ∀ g : C(Smale.Hemisphere.Sphere 1, Y), ∃ q, g.Homotopic (ContinuousMap.const _ q) := by
+  intro g
+  obtain ⟨g', havoid, hgg'⟩ := d.exists_belt_avoiding_circle hdim g
+  let g₀ : C(Smale.Hemisphere.Sphere 1, d.NewComplement) :=
+    ⟨fun x => ⟨g' x, havoid x⟩, g'.continuous.subtype_mk _⟩
+  let inc : C(d.NewComplement, Y) := ⟨Subtype.val, continuous_subtype_val⟩
+  obtain ⟨q, hq⟩ := hnull g₀
+  have hh : (inc.comp g₀).Homotopic (ContinuousMap.const _ (q : Y)) :=
+    (ContinuousMap.Homotopic.refl inc).comp hq
+  exact ⟨q, hgg'.trans hh⟩
+
+private theorem Smale.SurgeryBoundaryPair.newBoundary_circle_nullhomotopies {N F R X Y G H : Type*}
+    [NormedAddCommGroup N] [InnerProductSpace ℝ N] [FiniteDimensional ℝ N] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace R]
+    [TopologicalSpace X] [TopologicalSpace Y] [ChartedSpace H X] [IsManifold J ∞ X] [T2Space X]
+    (n : ℕ) [Fact (Module.finrank ℝ N = n + 1)] (hn : 0 < n)
+    (d : Smale.SurgeryBoundaryPair N F R X Y) (hattach : ContMDiff (𝓡 n) J ∞ d.attachingSphere)
+    (hdim : 2 + n < Module.finrank ℝ G)
+    (hnull : ∀ f : C(Smale.Hemisphere.Sphere 1, X), ∃ c, f.Homotopic (ContinuousMap.const _ c)) :
+    ∀ f : C(Smale.Hemisphere.Sphere 1, Y), ∃ c, f.Homotopic (ContinuousMap.const _ c) := by
+  have hnormal : 1 < Module.finrank ℝ N := by
+    rw [show Module.finrank ℝ N = n + 1 from Fact.out]
+    omega
+  exact
+    d.circle_nullhomotopies_of_beltComplement hnormal
+      (d.beltComplement_circle_nullhomotopies_of_sphere_dimension n hattach hdim hnull)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.surgery_newBoundary_circle_nullhomotopies
+    {E M R Y : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    [TopologicalSpace R] [TopologicalSpace Y] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (n : ℕ)
+    [Fact (Module.finrank ℝ c.NegativeCoordinates = n + 1)] (hn : 0 < n)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target)
+    (hreg : ∀ x, f x = f p - ρ ^ 2 → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (d :
+      Smale.SurgeryBoundaryPair c.NegativeCoordinates c.PositiveCoordinates R
+        { x : M // f x = f p - ρ ^ 2 } Y)
+    (hpiece :
+      ∀ z,
+        (d.oldPiece z : M) =
+          c.normHandleMap ρ hρ hblock (Smale.PuncturedHandle.sphereToBall z.1, z.2))
+    (hdim : 3 + n < Module.finrank ℝ E)
+    (hnull :
+      ∀ g : C(Smale.Hemisphere.Sphere 1, { x : M // f x = f p - ρ ^ 2 }),
+        ∃ q, g.Homotopic (ContinuousMap.const _ q)) :
+    ∀ g : C(Smale.Hemisphere.Sphere 1, Y), ∃ q, g.Homotopic (ContinuousMap.const _ q) := by
+  let _ := Smale.RegularLevel.chartedSpace hf hreg
+  let _ := Smale.RegularLevel.isManifold hf hreg
+  have hattach := c.contMDiff_surgeryAttachingSphere n hf ρ hρ hblock hreg d hpiece
+  apply d.newBoundary_circle_nullhomotopies n hn hattach _ hnull
+  rw [finrank_euclideanSpace_fin]
+  omega
+
+attribute [local instance 100] Classical.propDecidable in
+private structure Smale.ManifoldMorse.MorseSurgeryData (E : Type*) [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {M : Type*} [TopologicalSpace M] [ChartedSpace E M] (f : M → ℝ)
+    (p : M) where
+  radius : ℝ
+  radius_pos : 0 < radius
+  chart : SignedMorseChart (E := E) f p
+  block :
+    Metric.closedBall (0 : chart.NegativeCoordinates) (2 * radius) ×ˢ
+        Metric.closedBall (0 : chart.PositiveCoordinates) (2 * radius) ⊆
+      chart.splitChart.target
+  attachmentHomeomorph :
+    ↥({x : M | f x ≤ f p - radius ^ 2} ∪
+          Set.range (chart.attachingHandleMap radius radius_pos block)) ≃ₜ
+      { x : M // f x ≤ f p + radius ^ 2 }
+  attachment_frontier :
+    ∀ x,
+      f (attachmentHomeomorph x) = f p + radius ^ 2 ↔
+        x.val ∈
+          frontier
+            ({y : M | f y ≤ f p - radius ^ 2} ∪
+              Set.range (chart.attachingHandleMap radius radius_pos block))
+  attachment_fixed : ∀ x, f x.val = f p + radius ^ 2 → (attachmentHomeomorph x).val = x.val
+  attachment_model_orbits :
+    chart.FollowsModelBoundaryOrbits radius radius_pos block attachmentHomeomorph
+  surgery :
+    Smale.SurgeryBoundaryPair chart.NegativeCoordinates chart.PositiveCoordinates
+      { x : M //
+        f x = f p - radius ^ 2 ∧
+          x ∈
+            frontier
+              ({y | f y ≤ f p - radius ^ 2} ∪
+                Set.range (chart.normHandleMap radius radius_pos block)) }
+      { x : M // f x = f p - radius ^ 2 } { x : M // f x = f p + radius ^ 2 }
+  oldExterior_eq : ∀ r, (surgery.oldExterior r : M) = r.val
+  newExterior_eq :
+    ∀ r, (surgery.newExterior r : M) = (attachmentHomeomorph ⟨r.val, Or.inl r.property.1.le⟩).val
+  oldPiece_eq :
+    ∀ z,
+      (surgery.oldPiece z : M) =
+        chart.normHandleMap radius radius_pos block (Smale.PuncturedHandle.sphereToBall z.1, z.2)
+  newPiece_eq :
+    ∀ z,
+      (surgery.newPiece z : M) =
+        (attachmentHomeomorph
+            ⟨chart.normHandleMap radius radius_pos block
+                (z.1, Smale.PuncturedHandle.sphereToBall z.2),
+              Or.inr
+                ⟨chart.handleBallCoordinates (z.1, Smale.PuncturedHandle.sphereToBall z.2),
+                  rfl⟩⟩).val
+  belt_eq : surgery.beltSphere = chart.beltCoreMap radius radius_pos block
+  lower_regular : ∀ x, f x = f p - radius ^ 2 → x ∉ criticalPoints E f
+  upper_regular : ∀ x, f x = f p + radius ^ 2 → x ∉ criticalPoints E f
+
+private abbrev Smale.ManifoldMorse.MorseSurgeryData.LowerLevel {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) :=
+  { x : M // f x = f p - d.radius ^ 2 }
+
+private abbrev Smale.ManifoldMorse.MorseSurgeryData.UpperLevel {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) :=
+  { x : M // f x = f p + d.radius ^ 2 }
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.attaching_eq {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) :
+    d.surgery.attachingSphere = d.chart.attachingCoreMap d.radius d.radius_pos d.block :=
+  d.chart.attachingSphere_eq_attachingCoreMap d.radius d.radius_pos d.block d.surgery
+    d.oldPiece_eq
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.attaching_isClosedEmbedding {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) [T2Space M] :
+    Topology.IsClosedEmbedding d.surgery.attachingSphere := by
+  rw [d.attaching_eq]
+  exact d.chart.attachingCoreMap_isClosedEmbedding d.radius d.radius_pos d.block
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.belt_isClosedEmbedding {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) [T2Space M] :
+    Topology.IsClosedEmbedding d.surgery.beltSphere := by
+  rw [d.belt_eq]
+  exact d.chart.beltCoreMap_isClosedEmbedding d.radius d.radius_pos d.block
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.attaching_smooth {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (n : ℕ)
+    [Fact (Module.finrank ℝ d.chart.NegativeCoordinates = n + 1)] :
+    letI := Smale.RegularLevel.chartedSpace hf d.lower_regular
+    ContMDiff (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ d.surgery.attachingSphere := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.lower_regular
+  rw [d.attaching_eq]
+  exact d.chart.contMDiff_attachingCoreMap n hf d.radius d.radius_pos d.block d.lower_regular
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.belt_smooth {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (n : ℕ)
+    [Fact (Module.finrank ℝ d.chart.PositiveCoordinates = n + 1)] :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    ContMDiff (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ d.surgery.beltSphere := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  rw [d.belt_eq]
+  exact d.chart.contMDiff_beltCoreMap n hf d.radius d.radius_pos d.block d.upper_regular
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.attaching_derivative_injective {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (n : ℕ)
+    [Fact (Module.finrank ℝ d.chart.NegativeCoordinates = n + 1)]
+    (u : Smale.PuncturedHandle.UnitSphere d.chart.NegativeCoordinates) :
+    letI := Smale.RegularLevel.chartedSpace hf d.lower_regular
+    Function.Injective
+      (mfderiv (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) d.surgery.attachingSphere u) := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.lower_regular
+  rw [d.attaching_eq]
+  exact
+    d.chart.injective_mfderiv_attachingCoreMap n hf d.radius d.radius_pos d.block d.lower_regular
+      u
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.belt_derivative_injective {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (n : ℕ)
+    [Fact (Module.finrank ℝ d.chart.PositiveCoordinates = n + 1)]
+    (v : Smale.PuncturedHandle.UnitSphere d.chart.PositiveCoordinates) :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    Function.Injective (mfderiv (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) d.surgery.beltSphere v) := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  rw [d.belt_eq]
+  exact d.chart.injective_mfderiv_beltCoreMap n hf d.radius d.radius_pos d.block d.upper_regular v
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.upper_circle_nullhomotopies {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) [T2Space M] (n : ℕ)
+    [Fact (Module.finrank ℝ d.chart.NegativeCoordinates = n + 1)] (hn : 0 < n)
+    (hdim : 3 + n < Module.finrank ℝ E)
+    (hnull :
+      ∀ g : C(Smale.Hemisphere.Sphere 1, { x : M // f x = f p - d.radius ^ 2 }),
+        ∃ q, g.Homotopic (ContinuousMap.const _ q)) :
+    ∀ g : C(Smale.Hemisphere.Sphere 1, { x : M // f x = f p + d.radius ^ 2 }),
+      ∃ q, g.Homotopic (ContinuousMap.const _ q) :=
+  d.chart.surgery_newBoundary_circle_nullhomotopies n hn hf d.radius d.radius_pos d.block
+    d.lower_regular d.surgery d.oldPiece_eq hdim hnull
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.exists_morseSurgeryData_lt {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : IsMorse E f) {p : M} (hp : p ∈ criticalPoints E f)
+    (hunique : ∀ x ∈ criticalPoints E f, f x = f p → x = p) {ε : ℝ} (hε : 0 < ε) :
+    ∃ d : MorseSurgeryData E f p,
+      d.radius < ε ∧
+        ∀ x ∈ criticalPoints E f,
+          f x ∈ Set.Icc (f p - d.radius ^ 2) (f p + d.radius ^ 2) → x = p := by
+  obtain ⟨ρ, hρ, hρε, c, hblock, e, he, hfixed, hlevel, hlower, hupper, horbits, hband⟩ :=
+    exists_morse_boundary_attachment_with_model_orbits_lt hf hm hp hunique hε
+  exact
+    ⟨{  radius := ρ
+        radius_pos := hρ
+        chart := c
+        block := hblock
+        attachmentHomeomorph := e
+        attachment_frontier := he
+        attachment_fixed := hfixed
+        attachment_model_orbits := horbits
+        surgery := c.levelSurgeryBoundaryPair hf.continuous ρ hρ hblock hlevel e he
+        oldExterior_eq := fun _ => rfl
+        newExterior_eq := fun _ => rfl
+        oldPiece_eq := fun _ => rfl
+        newPiece_eq := fun _ => rfl
+        belt_eq := c.beltSphere_eq_beltCoreMap hf.continuous ρ hρ hblock hlevel e he hfixed
+        lower_regular := hlower
+        upper_regular := hupper }, hρε, hband⟩
+
+private theorem Smale.ManifoldMorse.exists_separated_value_radii {X : Type*} {f : X → ℝ} {K : Set X}
+    (hK : K.Finite) (hinj : Set.InjOn f K) :
+    ∃ r : K → ℝ, (∀ p, 0 < r p) ∧ ∀ p q : K, f p < f q → f p + (r p) ^ 2 < f q - (r q) ^ 2 := by
+  have hex :
+    ∀ p : K,
+      ∃ ρ > (0 : ℝ), ρ < 1 ∧ ∀ x ∈ K, f x ∈ Set.Icc (f p - ρ ^ 2) (f p + ρ ^ 2) → x = p.val := by
+    intro p
+    exact exists_isolating_radius hK p.val (fun x hx hfx => hinj hx p.property hfx) zero_lt_one
+  choose ρ hρ hρ₁ hisolated using hex
+  refine ⟨fun p => ρ p / 2, fun p => half_pos (hρ p), ?_⟩
+  intro p q hpq
+  have hupper : f p + (ρ p) ^ 2 < f q := by
+    apply lt_of_not_ge
+    intro h
+    have heq := hisolated p q.val q.property ⟨by nlinarith [sq_nonneg (ρ p)], h⟩
+    exact (ne_of_lt hpq) (congrArg f heq).symm
+  have hlower : f p < f q - (ρ q) ^ 2 := by
+    apply lt_of_not_ge
+    intro h
+    have heq := hisolated q p.val p.property ⟨h, by nlinarith [sq_nonneg (ρ q)]⟩
+    exact (ne_of_lt hpq) (congrArg f heq)
+  nlinarith
+
+private theorem Smale.exists_partialDiffeomorph_into_manifold {D E M : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [CompleteSpace D] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : D → M} {U : Set D}
+    {x : D} (hU : IsOpen U) (hx : x ∈ U) (hf : ContMDiffOn 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f U)
+    (hinv : (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x).IsInvertible) :
+    ∃ Φ : PartialDiffeomorph 𝓘(ℝ, D) 𝓘(ℝ, E) D M ∞,
+      x ∈ Φ.source ∧ Φ.source ⊆ U ∧ Set.EqOn f Φ Φ.source := by
+  let c := NoExotic.modelChartPartialDiffeomorph (I := 𝓘(ℝ, E)) (f x)
+  have hc : f x ∈ c.source := mem_extChartAt_source (f x)
+  let V : Set D := U ∩ f ⁻¹' c.source
+  have hV : IsOpen V := hf.continuousOn.isOpen_inter_preimage hU c.open_source
+  have hxV : x ∈ V := ⟨hx, hc⟩
+  have hcf : ContDiffOn ℝ ∞ (c ∘ f) V :=
+    (c.contMDiffOn_toFun.comp (hf.mono Set.inter_subset_left) (fun _ hy => hy.2)).contDiffOn
+  have hcinv : (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) c (f x)).IsInvertible :=
+    isInvertible_mfderiv_extChartAt (mem_extChartAt_source (f x))
+  have hderiv : (fderiv ℝ (c ∘ f) x).IsInvertible := by
+    rw [← mfderiv_eq_fderiv,
+      mfderiv_comp x (c.mdifferentiableAt (by simp) hc)
+        ((hf.contMDiffAt (hU.mem_nhds hx)).mdifferentiableAt (by simp))]
+    exact hcinv.comp hinv
+  obtain ⟨d, hd, hdV, hdf⟩ := NoExotic.exists_partialDiffeomorph_of_contDiffOn hV hxV hcf hderiv
+  have hdx : d x ∈ c.target := by
+    rw [hdf]
+    exact c.map_source' hc
+  refine ⟨d.trans c.symm, ⟨hd, hdx⟩, fun y hy => (hdV hy.1).1, ?_⟩
+  intro y hy
+  change f y = c.symm (d y)
+  rw [hdf]
+  exact (c.left_inv' (hdV hy.1).2).symm
+
+private theorem Smale.isLocalDiffeomorphAt_of_contMDiffOn {D E M : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [CompleteSpace D] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : D → M} {U : Set D}
+    {x : D} (hU : IsOpen U) (hx : x ∈ U) (hf : ContMDiffOn 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f U)
+    (hinv : (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x).IsInvertible) :
+    IsLocalDiffeomorphAt 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f x := by
+  obtain ⟨Φ, hxΦ, -, heq⟩ := exists_partialDiffeomorph_into_manifold hU hx hf hinv
+  exact ⟨Φ, hxΦ, heq⟩
+
+private theorem
+    Smale.exists_partialDiffeomorph_between_manifolds {D E M : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [CompleteSpace D] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {H X : Type*}
+    [TopologicalSpace H] {I : ModelWithCorners ℝ D H} [I.Boundaryless] [TopologicalSpace X]
+    [ChartedSpace H X] [IsManifold I ∞ X] {f : X → M} {U : Set X} {x : X} (hU : IsOpen U)
+    (hx : x ∈ U) (hf : ContMDiffOn I 𝓘(ℝ, E) ∞ f U)
+    (hinv : (mfderiv I 𝓘(ℝ, E) f x).IsInvertible) :
+    ∃ Φ : PartialDiffeomorph I 𝓘(ℝ, E) X M ∞,
+      x ∈ Φ.source ∧ Φ.source ⊆ U ∧ Set.EqOn f Φ Φ.source := by
+  let c := NoExotic.modelChartPartialDiffeomorph (I := I) x
+  have hxc : x ∈ c.source := mem_extChartAt_source x
+  have hcx : c x ∈ c.target := c.map_source' hxc
+  have hleft (y : X) (hy : y ∈ c.source) : c.symm (c y) = y := c.left_inv' hy
+  let V : Set D := c.target ∩ c.symm ⁻¹' U
+  have hV : IsOpen V := c.contMDiffOn_invFun.continuousOn.isOpen_inter_preimage c.open_target hU
+  have hcxV : c x ∈ V :=
+    ⟨hcx, by
+      change c.symm (c x) ∈ U
+      rwa [hleft x hxc]⟩
+  have hgf : ContMDiffOn 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ (f ∘ c.symm) V :=
+    hf.comp (c.contMDiffOn_invFun.mono Set.inter_subset_left) (fun _ hy => hy.2)
+  have hcDiff : c.toOpenPartialHomeomorph.MDifferentiable I 𝓘(ℝ, D) :=
+    ⟨c.mdifferentiableOn (by simp), c.symm.mdifferentiableOn (by simp)⟩
+  have hci : (mfderiv 𝓘(ℝ, D) I c.symm (c x)).IsInvertible := ⟨hcDiff.symm.mfderiv hcx, rfl⟩
+  have hderiv : (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) (f ∘ c.symm) (c x)).IsInvertible := by
+    have hfx := (hf.contMDiffAt (hU.mem_nhds hx)).mdifferentiableAt (by simp)
+    have hfc : MDifferentiableAt I 𝓘(ℝ, E) f (c.symm (c x)) := by
+      simpa only [hleft x hxc] using hfx
+    rw [mfderiv_comp (c x) hfc (c.symm.mdifferentiableAt (by simp) hcx), hleft x hxc]
+    exact hinv.comp hci
+  obtain ⟨d, hd, hdV, heq⟩ := exists_partialDiffeomorph_into_manifold hV hcxV hgf hderiv
+  refine ⟨c.trans d, ⟨hxc, hd⟩, ?_, ?_⟩
+  · intro y hy
+    have hh := (hdV hy.2).2
+    change c.symm (c y) ∈ U at hh
+    rwa [hleft y hy.1] at hh
+  · intro y hy
+    have hh := heq hy.2
+    change f (c.symm (c y)) = d (c y) at hh
+    change f y = d (c y)
+    simpa only [hleft y hy.1] using hh
+
+private theorem Smale.isLocalDiffeomorphAt_between_manifolds {D E M : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [CompleteSpace D] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {H X : Type*}
+    [TopologicalSpace H] {I : ModelWithCorners ℝ D H} [I.Boundaryless] [TopologicalSpace X]
+    [ChartedSpace H X] [IsManifold I ∞ X] {f : X → M} {U : Set X} {x : X} (hU : IsOpen U)
+    (hx : x ∈ U) (hf : ContMDiffOn I 𝓘(ℝ, E) ∞ f U)
+    (hinv : (mfderiv I 𝓘(ℝ, E) f x).IsInvertible) : IsLocalDiffeomorphAt I 𝓘(ℝ, E) ∞ f x := by
+  obtain ⟨Φ, hxΦ, -, heq⟩ := exists_partialDiffeomorph_between_manifolds hU hx hf hinv
+  exact ⟨Φ, hxΦ, heq⟩
+
+private theorem
+    Smale.exists_partialDiffeomorph_boundaryless {D E H H' X Y : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [CompleteSpace D] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace H] [TopologicalSpace H'] {I : ModelWithCorners ℝ D H}
+    {J : ModelWithCorners ℝ E H'} [I.Boundaryless] [J.Boundaryless] [TopologicalSpace X]
+    [ChartedSpace H X] [IsManifold I ∞ X] [TopologicalSpace Y] [ChartedSpace H' Y]
+    [IsManifold J ∞ Y] {f : X → Y} {U : Set X} {x : X} (hU : IsOpen U) (hx : x ∈ U)
+    (hf : ContMDiffOn I J ∞ f U) (hinv : (mfderiv I J f x).IsInvertible) :
+    ∃ Φ : PartialDiffeomorph I J X Y ∞, x ∈ Φ.source ∧ Φ.source ⊆ U ∧ Set.EqOn f Φ Φ.source := by
+  let c := NoExotic.modelChartPartialDiffeomorph (I := J) (f x)
+  have hc : f x ∈ c.source := mem_extChartAt_source (f x)
+  let V : Set X := U ∩ f ⁻¹' c.source
+  have hV : IsOpen V := hf.continuousOn.isOpen_inter_preimage hU c.open_source
+  have hxV : x ∈ V := ⟨hx, hc⟩
+  have hcf : ContMDiffOn I 𝓘(ℝ, E) ∞ (c ∘ f) V :=
+    c.contMDiffOn_toFun.comp (hf.mono Set.inter_subset_left) (fun _ hy => hy.2)
+  have hci : (mfderiv J 𝓘(ℝ, E) c (f x)).IsInvertible :=
+    isInvertible_mfderiv_extChartAt (mem_extChartAt_source (f x))
+  have hderiv : (mfderiv I 𝓘(ℝ, E) (c ∘ f) x).IsInvertible := by
+    rw [mfderiv_comp x (c.mdifferentiableAt (by simp) hc)
+        ((hf.contMDiffAt (hU.mem_nhds hx)).mdifferentiableAt (by simp))]
+    exact hci.comp hinv
+  obtain ⟨d, hd, hdV, hdf⟩ := exists_partialDiffeomorph_between_manifolds hV hxV hcf hderiv
+  have hdx : d x ∈ c.target := by
+    have heq : d x = c (f x) := (hdf hd).symm
+    rw [heq]
+    exact c.map_source' hc
+  refine ⟨d.trans c.symm, ⟨hd, hdx⟩, fun y hy => (hdV hy.1).1, ?_⟩
+  intro y hy
+  have heq : d y = c (f y) := (hdf hy.1).symm
+  change f y = c.symm (d y)
+  rw [heq]
+  exact (c.left_inv' (hdV hy.1).2).symm
+
+private theorem
+    Smale.isLocalDiffeomorphAt_boundaryless {D E H H' X Y : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [CompleteSpace D] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace H] [TopologicalSpace H'] {I : ModelWithCorners ℝ D H}
+    {J : ModelWithCorners ℝ E H'} [I.Boundaryless] [J.Boundaryless] [TopologicalSpace X]
+    [ChartedSpace H X] [IsManifold I ∞ X] [TopologicalSpace Y] [ChartedSpace H' Y]
+    [IsManifold J ∞ Y] {f : X → Y} {U : Set X} {x : X} (hU : IsOpen U) (hx : x ∈ U)
+    (hf : ContMDiffOn I J ∞ f U) (hinv : (mfderiv I J f x).IsInvertible) :
+    IsLocalDiffeomorphAt I J ∞ f x := by
+  obtain ⟨Φ, hxΦ, -, heq⟩ := exists_partialDiffeomorph_boundaryless hU hx hf hinv
+  exact ⟨Φ, hxΦ, heq⟩
+
+private def Smale.partialDiffeomorphOfInjectiveLocal {E F H H' X Y : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [TopologicalSpace H'] {J : ModelWithCorners ℝ F H'} [TopologicalSpace X]
+    [ChartedSpace H X] [Nonempty X] [TopologicalSpace Y] [ChartedSpace H' Y] {f : X → Y}
+    {U : Set X} (hU : IsOpen U) (hinj : Set.InjOn f U) (hloc : IsLocalDiffeomorphOn I J ∞ f U) :
+    PartialDiffeomorph I J X Y ∞ := by
+  let p := hinj.toPartialEquiv f U
+  have htarget : IsOpen p.target := by
+    change IsOpen (f '' U)
+    rw [isOpen_iff_mem_nhds]
+    rintro _ ⟨x, hx, rfl⟩
+    rw [← hloc.isLocalHomeomorphOn.map_nhds_eq hx]
+    exact Filter.image_mem_map (hU.mem_nhds hx)
+  have hinverse : ContMDiffOn J I ∞ p.symm p.target := by
+    intro y hy
+    have hx : p.symm y ∈ U := p.map_target hy
+    obtain ⟨φ, hφx, heq⟩ := hloc ⟨p.symm y, hx⟩
+    have hφxy : φ (p.symm y) = y := (heq hφx).symm.trans (p.right_inv hy)
+    have hφy : y ∈ φ.target := hφxy ▸ φ.map_source' hφx
+    have hφyx : φ.symm y = p.symm y := by
+      calc
+        φ.symm y = φ.symm (φ (p.symm y)) := congrArg φ.symm hφxy.symm
+        _ = p.symm y := φ.left_inv' hφx
+    have hg : ContMDiffAt J I ∞ φ.symm y :=
+      φ.contMDiffOn_invFun.contMDiffAt (φ.open_target.mem_nhds hφy)
+    have hNU : U ∈ 𝓝 (φ.symm y) := by
+      rw [hφyx]
+      exact hU.mem_nhds hx
+    have hfg : p.symm =ᶠ[𝓝 y] φ.symm := by
+      filter_upwards [φ.open_target.mem_nhds hφy, hg.continuousAt hNU] with z hz hzU
+      have hfz : f (φ.symm z) = z := (heq (φ.map_target' hz)).trans (φ.right_inv' hz)
+      exact (congrArg p.symm hfz.symm).trans (p.left_inv hzU)
+    exact (hfg.contMDiffAt_iff.mpr hg).contMDiffWithinAt
+  exact
+    { p with
+      open_source := hU
+      open_target := htarget
+      contMDiffOn_toFun := hloc.contMDiffOn
+      contMDiffOn_invFun := hinverse }
+
+private theorem
+    Smale.exists_partialDiffeomorph_near_compact {E F H H' X Y : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [TopologicalSpace H'] {J : ModelWithCorners ℝ F H'} [TopologicalSpace X]
+    [ChartedSpace H X] [Nonempty X] [TopologicalSpace Y] [ChartedSpace H' Y] [T2Space Y]
+    {f : X → Y} {K U : Set X} (hK : IsCompact K) (hinj : Set.InjOn f K)
+    (hloc : ∀ x ∈ K, IsLocalDiffeomorphAt I J ∞ f x) (hU : IsOpen U) (hKU : K ⊆ U) :
+    ∃ Φ : PartialDiffeomorph I J X Y ∞, K ⊆ Φ.source ∧ Φ.source ⊆ U ∧ (Φ : X → Y) = f := by
+  let R : Set X := {x | IsLocalDiffeomorphAt I J ∞ f x}
+  have hR : IsOpen R := by
+    rw [isOpen_iff_mem_nhds]
+    rintro x ⟨φ, hx, heq⟩
+    exact Filter.mem_of_superset (φ.open_source.mem_nhds hx) (fun y hy => ⟨φ, hy, heq⟩)
+  have hlocalinj : ∀ x ∈ K, ∃ V ∈ 𝓝 x, Set.InjOn f V := by
+    intro x hx
+    obtain ⟨φ, hφ, heq⟩ := hloc x hx
+    exact ⟨φ.source, φ.open_source.mem_nhds hφ, heq.injOn_iff.mpr φ.toPartialEquiv.injOn⟩
+  obtain ⟨V, hV, hKV, hVi⟩ :=
+    hinj.exists_isOpen_superset hK (fun x hx => (hloc x hx).contMDiffAt.continuousAt) hlocalinj
+  let W := (V ∩ R) ∩ U
+  have hW : IsOpen W := (hV.inter hR).inter hU
+  have hKW : K ⊆ W := fun x hx => ⟨⟨hKV hx, hloc x hx⟩, hKU hx⟩
+  have hWi : Set.InjOn f W := hVi.mono (Set.inter_subset_left.trans Set.inter_subset_left)
+  have hWloc : IsLocalDiffeomorphOn I J ∞ f W := fun x => x.property.1.2
+  exact ⟨partialDiffeomorphOfInjectiveLocal hW hWi hWloc, hKW, Set.inter_subset_right, rfl⟩
+
+private def Smale.CollarHeight.heightChange {X : Type*} (h : X × ℝ → ℝ) (z : X × ℝ) : X × ℝ :=
+  (z.1, h z)
+
+private theorem Smale.CollarHeight.heightChange_zero {X : Type*} {h : X × ℝ → ℝ}
+    (hzero : ∀ x, h (x, 0) = 0) (x : X) : heightChange h (x, 0) = (x, 0) :=
+  Prod.ext rfl (hzero x)
+
+private theorem Smale.CollarHeight.contMDiffOn_heightChange {D H X : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [TopologicalSpace H] {I : ModelWithCorners ℝ D H} [TopologicalSpace X]
+    [ChartedSpace H X] {h : X × ℝ → ℝ} {U : Set (X × ℝ)}
+    (hh : ContMDiffOn (I.prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, ℝ) ∞ h U) :
+    ContMDiffOn (I.prod 𝓘(ℝ, ℝ)) (I.prod 𝓘(ℝ, ℝ)) ∞ (heightChange h) U :=
+  contMDiff_fst.contMDiffOn.prodMk hh
+
+private theorem Smale.CollarHeight.mfderiv_height_zero {D H X : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [TopologicalSpace H] {I : ModelWithCorners ℝ D H} [TopologicalSpace X]
+    [ChartedSpace H X] {h : X × ℝ → ℝ} {U : Set (X × ℝ)} (hU : IsOpen U)
+    (hh : ContMDiffOn (I.prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, ℝ) ∞ h U) (hzero : ∀ x, h (x, 0) = 0) (x : X)
+    (hx : (x, 0) ∈ U) (htime : HasDerivAt (fun t : ℝ => h (x, t)) 1 0) :
+    mfderiv (I.prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, ℝ) h (x, 0) = ContinuousLinearMap.snd ℝ D ℝ := by
+  have hbase : (fun y : X => h (y, 0)) = fun _ => 0 := funext hzero
+  have ht : mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) (fun t : ℝ => h (x, t)) 0 = ContinuousLinearMap.id ℝ ℝ := by
+    rw [mfderiv_eq_fderiv, htime.hasFDerivAt.fderiv]
+    apply ContinuousLinearMap.ext
+    intro t
+    simp only [ContinuousLinearMap.toSpanSingleton_apply, ContinuousLinearMap.id_apply,
+      smul_eq_mul, mul_one]
+  apply ContinuousLinearMap.ext
+  intro v
+  rw [mfderiv_prod_eq_add_apply ((hh.contMDiffAt (hU.mem_nhds hx)).mdifferentiableAt (by simp)),
+    hbase, mfderiv_const, ht]
+  change (0 : ℝ) + v.2 = v.2
+  exact zero_add _
+
+private theorem Smale.CollarHeight.mfderiv_heightChange_zero {D H X : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [TopologicalSpace H] {I : ModelWithCorners ℝ D H} [TopologicalSpace X]
+    [ChartedSpace H X] {h : X × ℝ → ℝ} {U : Set (X × ℝ)} (hU : IsOpen U)
+    (hh : ContMDiffOn (I.prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, ℝ) ∞ h U) (hzero : ∀ x, h (x, 0) = 0) (x : X)
+    (hx : (x, 0) ∈ U) (htime : HasDerivAt (fun t : ℝ => h (x, t)) 1 0) :
+    mfderiv (I.prod 𝓘(ℝ, ℝ)) (I.prod 𝓘(ℝ, ℝ)) (heightChange h) (x, 0) =
+      ContinuousLinearMap.id ℝ (D × ℝ) := by
+  change mfderiv (I.prod 𝓘(ℝ, ℝ)) (I.prod 𝓘(ℝ, ℝ)) (fun z => (z.1, h z)) (x, 0) = _
+  rw [mfderiv_prodMk mdifferentiableAt_fst
+      ((hh.contMDiffAt (hU.mem_nhds hx)).mdifferentiableAt (by simp)),
+    mfderiv_fst, mfderiv_height_zero hU hh hzero x hx htime]
+  rfl
+
+private theorem Smale.CollarHeight.exists_heightChangeChart {D H X : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [TopologicalSpace H] {I : ModelWithCorners ℝ D H} [TopologicalSpace X]
+    [ChartedSpace H X] [CompleteSpace D] [I.Boundaryless] [IsManifold I ∞ X] [T2Space X]
+    [CompactSpace X] [Nonempty X] {h : X × ℝ → ℝ} {U : Set (X × ℝ)} (hU : IsOpen U)
+    (hh : ContMDiffOn (I.prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, ℝ) ∞ h U) (hzero : ∀ x, h (x, 0) = 0)
+    (hsource : ∀ x, (x, 0) ∈ U) (htime : ∀ x, HasDerivAt (fun t : ℝ => h (x, t)) 1 0) :
+    ∃ χ : PartialDiffeomorph (I.prod 𝓘(ℝ, ℝ)) (I.prod 𝓘(ℝ, ℝ)) (X × ℝ) (X × ℝ) ∞,
+      (Set.univ : Set X) ×ˢ {(0 : ℝ)} ⊆ χ.source ∧
+        χ.source ⊆ U ∧ (χ : X × ℝ → X × ℝ) = heightChange h := by
+  let K : Set (X × ℝ) := Set.univ ×ˢ {(0 : ℝ)}
+  have hK : IsCompact K := isCompact_univ.prod isCompact_singleton
+  have hinj : Set.InjOn (heightChange h) K := by
+    rintro ⟨x, s⟩ ⟨-, hs⟩ ⟨y, t⟩ ⟨-, ht⟩ hxy
+    have hs0 : s = 0 := hs
+    have ht0 : t = 0 := ht
+    subst s
+    subst t
+    rw [heightChange_zero hzero x, heightChange_zero hzero y] at hxy
+    exact hxy
+  have hloc :
+    ∀ z ∈ K, IsLocalDiffeomorphAt (I.prod 𝓘(ℝ, ℝ)) (I.prod 𝓘(ℝ, ℝ)) ∞ (heightChange h) z := by
+    rintro ⟨x, t⟩ ⟨-, ht⟩
+    have ht0 : t = 0 := ht
+    subst t
+    apply Smale.isLocalDiffeomorphAt_boundaryless hU (hsource x) (contMDiffOn_heightChange hh)
+    rw [mfderiv_heightChange_zero hU hh hzero x (hsource x) (htime x)]
+    exact ⟨ContinuousLinearEquiv.refl ℝ (D × ℝ), rfl⟩
+  exact
+    Smale.exists_partialDiffeomorph_near_compact hK hinj hloc hU
+      (fun ⟨x, t⟩ hx => by
+        have ht : t = 0 := hx.2
+        simpa only [ht] using hsource x)
+
+private theorem Smale.RegularLevel.injective_mfderiv_inclusion {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {b : ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (x : { x : M // f x = b }) :
+    letI := chartedSpace hf hreg
+    Function.Injective
+      (mfderiv 𝓘(ℝ, Model E) 𝓘(ℝ, E) (Subtype.val : { x : M // f x = b } → M) x) := by
+  let _ := chartedSpace hf hreg
+  let _ := isManifold hf hreg
+  let Φ := heightChart hf hreg x
+  have hΦ :=
+    Φ.contMDiffOn_toFun.contMDiffAt (Φ.open_source.mem_nhds (heightChart_mem_source hf hreg x))
+  have hprojection : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, Model E) ∞ (fun y : M => (Φ y).2) (x : M) :=
+    contDiff_snd.contMDiff.contMDiffAt.comp (x : M) hΦ
+  have hi :=
+    (mdifferentiable_chart (I := 𝓘(ℝ, Model E)) x).mfderiv_injective
+      (mem_chart_source (Model E) x)
+  change
+    Function.Injective
+      (mfderiv 𝓘(ℝ, Model E) 𝓘(ℝ, Model E) ((fun y : M => (Φ y).2) ∘ Subtype.val) x) at hi
+  rw [mfderiv_comp x (hprojection.mdifferentiableAt (by simp))
+      ((Smale.RegularLevel.contMDiff_inclusion hf hreg).mdifferentiableAt (by simp))] at hi
+  exact fun u v huv =>
+    hi (congrArg (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, Model E) (fun y : M => (Φ y).2) (x : M)) huv)
+
+private theorem
+    Smale.RegularLevel.height_derivative_comp_inclusion {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {b : ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (x : { x : M // f x = b }) :
+    letI := chartedSpace hf hreg
+    (mvfderiv 𝓘(ℝ, E) f (x : M)).comp
+        (mfderiv 𝓘(ℝ, Model E) 𝓘(ℝ, E) (Subtype.val : { x : M // f x = b } → M) x) =
+      0 := by
+  let _ := chartedSpace hf hreg
+  have heq : f ∘ (Subtype.val : { x : M // f x = b } → M) = fun _ => b :=
+    funext (fun y => y.property)
+  have hc :=
+    mfderiv_comp x (hf.mdifferentiableAt (by simp))
+      ((Smale.RegularLevel.contMDiff_inclusion hf hreg).mdifferentiableAt (by simp))
+  rw [heq, mfderiv_const] at hc
+  exact hc.symm
+
+private theorem Smale.RegularLevel.range_mfderiv_inclusion {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {b : ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (x : { x : M // f x = b }) :
+    letI := chartedSpace hf hreg
+    (mfderiv 𝓘(ℝ, Model E) 𝓘(ℝ, E) (Subtype.val : { x : M // f x = b } → M) x).range =
+      (mvfderiv 𝓘(ℝ, E) f (x : M)).ker := by
+  let _ := chartedSpace hf hreg
+  let A : Model E →L[ℝ] E :=
+    mfderiv 𝓘(ℝ, Model E) 𝓘(ℝ, E) (Subtype.val : { x : M // f x = b } → M) x
+  let L : E →L[ℝ] ℝ := mvfderiv 𝓘(ℝ, E) f (x : M)
+  change A.range = L.ker
+  have hsub : A.range ≤ L.ker := by
+    rintro _ ⟨v, rfl⟩
+    change L (A v) = 0
+    exact congrArg (fun T => T v) (height_derivative_comp_inclusion hf hreg x)
+  have hAi : Function.Injective A := injective_mfderiv_inclusion hf hreg x
+  have hL : L ≠ 0 := hreg x x.property
+  have hdim := finrank_kernel_add_one hL
+  have hAr : Module.finrank ℝ A.range = Module.finrank ℝ E - 1 := by
+    rw [LinearMap.finrank_range_of_inj hAi]
+    exact finrank_euclideanSpace_fin
+  apply Submodule.eq_of_le_of_finrank_eq hsub
+  rw [hAr]
+  omega
+
+private def
+    Smale.RegularLevel.transverseTangentMap {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    {f : M → ℝ} {b : ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f) (x : { x : M // f x = b })
+    (v : E) : Model E × ℝ →L[ℝ] E :=
+  letI := chartedSpace hf hreg
+  (mfderiv 𝓘(ℝ, Model E) 𝓘(ℝ, E) (Subtype.val : { x : M // f x = b } → M) x).coprod
+    ((ContinuousLinearMap.id ℝ ℝ).smulRight v)
+
+private theorem
+    Smale.RegularLevel.bijective_transverseTangentMap {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {b : ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f) (x : { x : M // f x = b })
+    (v : E) (hv : mvfderiv 𝓘(ℝ, E) f (x : M) v = 1) :
+    Function.Bijective (transverseTangentMap hf hreg x v) := by
+  let _ := chartedSpace hf hreg
+  let A : Model E →L[ℝ] E :=
+    mfderiv 𝓘(ℝ, Model E) 𝓘(ℝ, E) (Subtype.val : { x : M // f x = b } → M) x
+  let L : E →L[ℝ] ℝ := mvfderiv 𝓘(ℝ, E) f (x : M)
+  have hLA (u : Model E) : L (A u) = 0 :=
+    congrArg (fun T => T u) (height_derivative_comp_inclusion hf hreg x)
+  have hAi : Function.Injective A := injective_mfderiv_inclusion hf hreg x
+  change L v = 1 at hv
+  constructor
+  · intro z w hzw
+    change A z.1 + z.2 • v = A w.1 + w.2 • v at hzw
+    have ht : z.2 = w.2 := by
+      have h := congrArg L hzw
+      simpa only [map_add, map_smul, hLA, hv, smul_eq_mul, mul_one, zero_add] using h
+    rw [ht] at hzw
+    exact Prod.ext (hAi (add_right_cancel hzw)) ht
+  · intro w
+    have hrem : w - L w • v ∈ L.ker := by
+      change L (w - L w • v) = 0
+      simp only [map_sub, map_smul, hv, smul_eq_mul, mul_one, sub_self]
+    have hrange : A.range = L.ker := range_mfderiv_inclusion hf hreg x
+    rw [← hrange] at hrem
+    obtain ⟨u, hu⟩ := hrem
+    change A u = w - L w • v at hu
+    refine ⟨(u, L w), ?_⟩
+    change A u + L w • v = w
+    rw [hu, sub_add_cancel]
+
+private theorem Smale.RegularLevel.surjective_normal_derivative_of_tangent_lift {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {b : ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f) {N : Type*}
+    [NormedAddCommGroup N] [NormedSpace ℝ N] {n : M → N} (x : { x : M // f x = b })
+    (hn : MDifferentiableAt 𝓘(ℝ, E) 𝓘(ℝ, N) n (x : M)) (R : N →L[ℝ] E)
+    (hheight : (mvfderiv 𝓘(ℝ, E) f (x : M)).comp R = 0)
+    (hnormal :
+      (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, N) n (x : M) : E →L[ℝ] N).comp R = ContinuousLinearMap.id ℝ N) :
+    letI := chartedSpace hf hreg
+    Function.Surjective
+      (mfderiv 𝓘(ℝ, Model E) 𝓘(ℝ, N) (n ∘ (Subtype.val : { x : M // f x = b } → M)) x) := by
+  let _ := chartedSpace hf hreg
+  let A : Model E →L[ℝ] E :=
+    mfderiv 𝓘(ℝ, Model E) 𝓘(ℝ, E) (Subtype.val : { x : M // f x = b } → M) x
+  let L : E →L[ℝ] ℝ := mvfderiv 𝓘(ℝ, E) f (x : M)
+  let B : E →L[ℝ] N := mfderiv 𝓘(ℝ, E) 𝓘(ℝ, N) n (x : M)
+  change L.comp R = 0 at hheight
+  change B.comp R = ContinuousLinearMap.id ℝ N at hnormal
+  have hrange : A.range = L.ker := range_mfderiv_inclusion hf hreg x
+  rw [mfderiv_comp x hn
+      ((Smale.RegularLevel.contMDiff_inclusion hf hreg).mdifferentiableAt (by simp))]
+  change Function.Surjective (B.comp A)
+  intro z
+  have hker : R z ∈ L.ker := by
+    change L (R z) = 0
+    exact congrArg (fun T : N →L[ℝ] ℝ => T z) hheight
+  rw [← hrange] at hker
+  obtain ⟨v, hv⟩ := hker
+  change A v = R z at hv
+  refine ⟨v, ?_⟩
+  change B (A v) = z
+  rw [hv]
+  exact congrArg (fun T : N →L[ℝ] N => T z) hnormal
+
+private structure
+    Smale.NativeEuclideanEmbedding (E M : Type*) [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] where
+  ambientDimension : ℕ
+  toFun : M → EuclideanSpace ℝ (Fin ambientDimension)
+  smooth : ContMDiff 𝓘(ℝ, E) (𝓡 ambientDimension) ∞ toFun
+  closedEmbedding : Topology.IsClosedEmbedding toFun
+  injective_mfderiv : ∀ x, Function.Injective (mfderiv 𝓘(ℝ, E) (𝓡 ambientDimension) toFun x)
+
+private theorem
+    Smale.nonempty_nativeEuclideanEmbedding {E : Type*} {M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] :
+    Nonempty (NativeEuclideanEmbedding E M) := by
+  obtain ⟨n, f, hs, hc, hd⟩ := exists_embedding_euclidean_of_compact (I := 𝓘(ℝ, E)) (M := M)
+  exact ⟨⟨n, f, hs, hc, hd⟩⟩
+
+private theorem Smale.NativeEuclideanEmbedding.injective_mvfderiv {E : Type*} {M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) (x : M) :
+    Function.Injective (mvfderiv 𝓘(ℝ, E) e.toFun x) :=
+  (NormedSpace.fromTangentSpace (e.toFun x)).injective.comp (e.injective_mfderiv x)
+
+private def
+    Smale.NativeEuclideanEmbedding.tangentImage {E : Type*} {M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) (x : M) :
+    Submodule ℝ (EuclideanSpace ℝ (Fin e.ambientDimension)) :=
+  (mvfderiv 𝓘(ℝ, E) e.toFun x).range
+
+private theorem Smale.NativeEuclideanEmbedding.finrank_tangentImage {E : Type*} {M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) (x : M) :
+    Module.finrank ℝ (e.tangentImage x) = Module.finrank ℝ E := by
+  exact LinearMap.finrank_range_of_inj (e.injective_mvfderiv x)
+
+private noncomputable def NoExotic.realAdjoint {E F : Type*} [NormedAddCommGroup E]
+    [InnerProductSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F] [InnerProductSpace ℝ F]
+    [FiniteDimensional ℝ F] : (E →L[ℝ] F) →L[ℝ] (F →L[ℝ] E)
+    where
+  toFun A := A.adjoint
+  map_add' A B := map_add ContinuousLinearMap.adjoint A B
+  map_smul' r A := by simp
+  cont := ContinuousLinearMap.adjoint.continuous
+
+private noncomputable def NoExotic.gramOperator {E F : Type*} [NormedAddCommGroup E]
+    [InnerProductSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F] [InnerProductSpace ℝ F]
+    [FiniteDimensional ℝ F] (A : E →L[ℝ] F) : E →L[ℝ] E :=
+  A.adjoint.comp A
+
+private theorem NoExotic.gramOperator_isInvertible {E F : Type*} [NormedAddCommGroup E]
+    [InnerProductSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F] [InnerProductSpace ℝ F]
+    [FiniteDimensional ℝ F] (A : E →L[ℝ] F) (hA : Function.Injective A) :
+    (gramOperator A).IsInvertible := by
+  have hG : Function.Injective (gramOperator A) := A.adjoint_comp_self_injective_iff.mpr hA
+  let g := (LinearEquiv.ofInjectiveEndo (gramOperator A).toLinearMap hG).toContinuousLinearEquiv
+  exact ⟨g, by ext v; rfl⟩
+
+private noncomputable def NoExotic.gramProjection {E F : Type*} [NormedAddCommGroup E]
+    [InnerProductSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F] [InnerProductSpace ℝ F]
+    [FiniteDimensional ℝ F] (A : E →L[ℝ] F) : F →L[ℝ] F :=
+  A.comp ((gramOperator A).inverse.comp A.adjoint)
+
+private theorem NoExotic.gramProjection_eq_starProjection {E F : Type*} [NormedAddCommGroup E]
+    [InnerProductSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F] [InnerProductSpace ℝ F]
+    [FiniteDimensional ℝ F] (A : E →L[ℝ] F) (hA : Function.Injective A) :
+    gramProjection A = A.range.starProjection := by
+  ext v
+  symm
+  apply Submodule.eq_starProjection_of_mem_orthogonal
+  · exact ⟨(gramOperator A).inverse (A.adjoint v), rfl⟩
+  · rw [A.orthogonal_range]
+    change A.adjoint (v - A ((gramOperator A).inverse (A.adjoint v))) = 0
+    rw [map_sub]
+    change A.adjoint v - gramOperator A ((gramOperator A).inverse (A.adjoint v)) = 0
+    rw [(gramOperator_isInvertible A hA).self_apply_inverse, sub_self]
+
+private theorem NoExotic.contMDiffAt_gramProjection {E F : Type*} [NormedAddCommGroup E]
+    [InnerProductSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F] [InnerProductSpace ℝ F]
+    [FiniteDimensional ℝ F] {B H M : Type*} [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ B H} [TopologicalSpace M] [ChartedSpace H M]
+    {A : M → E →L[ℝ] F} {x : M} (hA : ContMDiffAt I 𝓘(ℝ, E →L[ℝ] F) ∞ A x)
+    (hinj : Function.Injective (A x)) :
+    ContMDiffAt I 𝓘(ℝ, F →L[ℝ] F) ∞ (fun y ↦ gramProjection (A y)) x := by
+  have hadj : ContMDiffAt I 𝓘(ℝ, F →L[ℝ] E) ∞ (fun y ↦ (A y).adjoint) x :=
+    (realAdjoint.contDiff.contMDiff.contMDiffAt).comp x hA
+  have hgram : ContMDiffAt I 𝓘(ℝ, E →L[ℝ] E) ∞ (fun y ↦ gramOperator (A y)) x := hadj.clm_comp hA
+  have hinverse : ContMDiffAt I 𝓘(ℝ, E →L[ℝ] E) ∞ (fun y ↦ (gramOperator (A y)).inverse) x :=
+    ContDiffAt.comp_contMDiffAt (f := fun y ↦ gramOperator (A y)) (x := x)
+      (gramOperator_isInvertible (A x) hinj).contDiffAt_map_inverse hgram
+  exact hA.clm_comp (hinverse.clm_comp hadj)
+
+private def Smale.NativeEuclideanEmbedding.localDifferential {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    (e : Smale.NativeEuclideanEmbedding E M) (x₀ : M) :
+    M → E →L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension) :=
+  inTangentCoordinates 𝓘(ℝ, E) (𝓡 e.ambientDimension) id e.toFun
+    (mfderiv 𝓘(ℝ, E) (𝓡 e.ambientDimension) e.toFun) x₀
+
+private theorem Smale.NativeEuclideanEmbedding.contMDiffAt_localDifferential {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M) (x₀ : M) :
+    ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, E →L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension)) ∞
+      (e.localDifferential x₀) x₀ :=
+  e.smooth.contMDiffAt.mfderiv_const (by simp)
+
+private theorem
+    Smale.NativeEuclideanEmbedding.localDifferential_eq {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    (e : Smale.NativeEuclideanEmbedding E M) (x₀ y : M) :
+    e.localDifferential x₀ y =
+      (mvfderiv 𝓘(ℝ, E) e.toFun y).comp
+        ((FiberBundle.trivializationAt E (TangentSpace 𝓘(ℝ, E)) x₀).symmL ℝ y) := by
+  simp only [localDifferential, inTangentCoordinates, ContinuousLinearMap.inCoordinates,
+    TangentBundle.continuousLinearMapAt_model_space]
+  rfl
+
+private theorem Smale.NativeEuclideanEmbedding.localFiberMap_bijective_mo1973_860 {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (x₀ y : M) (hy : y ∈ (chartAt E x₀).source) :
+    Function.Bijective ((FiberBundle.trivializationAt E (TangentSpace 𝓘(ℝ, E)) x₀).symmL ℝ y) := by
+  have hy' : y ∈ (FiberBundle.trivializationAt E (TangentSpace 𝓘(ℝ, E)) x₀).baseSet := by
+    simpa only [TangentBundle.trivializationAt_baseSet] using hy
+  rw [← Bundle.Trivialization.symm_continuousLinearEquivAt_eq _ hy']
+  exact ContinuousLinearEquiv.bijective _
+
+private theorem Smale.NativeEuclideanEmbedding.localDifferential_injective {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M) (x₀ y : M)
+    (hy : y ∈ (chartAt E x₀).source) : Function.Injective (e.localDifferential x₀ y) := by
+  rw [e.localDifferential_eq]
+  exact (e.injective_mvfderiv y).comp (localFiberMap_bijective_mo1973_860 x₀ y hy).1
+
+private theorem Smale.NativeEuclideanEmbedding.localDifferential_range {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M) (x₀ y : M)
+    (hy : y ∈ (chartAt E x₀).source) : (e.localDifferential x₀ y).range = e.tangentImage y := by
+  rw [e.localDifferential_eq]
+  apply LinearMap.range_comp_of_range_eq_top
+  exact LinearMap.range_eq_top.mpr (localFiberMap_bijective_mo1973_860 x₀ y hy).2
+
+private def Smale.NativeEuclideanEmbedding.tangentProjection {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) (x : M) :
+    EuclideanSpace ℝ (Fin e.ambientDimension) →L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension) :=
+  (e.tangentImage x).starProjection
+
+private theorem Smale.NativeEuclideanEmbedding.contMDiff_tangentProjection {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M) [FiniteDimensional ℝ E] :
+    ContMDiff 𝓘(ℝ, E)
+      𝓘(ℝ,
+        EuclideanSpace ℝ (Fin e.ambientDimension) →L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension))
+      ∞ e.tangentProjection := by
+  let φ : EuclideanSpace ℝ (Fin (Module.finrank ℝ E)) ≃L[ℝ] E :=
+    ContinuousLinearEquiv.ofFinrankEq finrank_euclideanSpace_fin
+  intro x
+  let A (y : M) := (e.localDifferential x y).comp φ.toContinuousLinearMap
+  have hs : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, _ →L[ℝ] _) ∞ A x :=
+    (e.contMDiffAt_localDifferential x).clm_comp contMDiffAt_const
+  have hi (y : M) (hy : y ∈ (chartAt E x).source) : Function.Injective (A y) :=
+    (e.localDifferential_injective x y hy).comp φ.injective
+  have hr (y : M) (hy : y ∈ (chartAt E x).source) : (A y).range = e.tangentImage y := by
+    calc
+      (A y).range = (e.localDifferential x y).range :=
+        LinearMap.range_comp_of_range_eq_top _ (LinearMap.range_eq_top.mpr φ.surjective)
+      _ = e.tangentImage y := e.localDifferential_range x y hy
+  have h := NoExotic.contMDiffAt_gramProjection hs (hi x (mem_chart_source _ _))
+  have heq : e.tangentProjection =ᶠ[𝓝 x] (fun y => NoExotic.gramProjection (A y)) := by
+    filter_upwards [chart_source_mem_nhds E x] with y hy
+    simpa only [tangentProjection, hr y hy] using
+      (NoExotic.gramProjection_eq_starProjection _ (hi y hy)).symm
+  exact heq.contMDiffAt_iff.mpr h
+
+private def Smale.NativeEuclideanEmbedding.normalFiber {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) (x : M) :
+    Submodule ℝ (EuclideanSpace ℝ (Fin e.ambientDimension)) :=
+  (e.tangentImage x)ᗮ
+
+private def Smale.NativeEuclideanEmbedding.normalProjection {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) (x : M) :
+    EuclideanSpace ℝ (Fin e.ambientDimension) →L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension) :=
+  (e.normalFiber x).starProjection
+
+private theorem
+    Smale.NativeEuclideanEmbedding.normalProjection_eq {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) (x : M) :
+    e.normalProjection x = 1 - e.tangentProjection x :=
+  Submodule.starProjection_orthogonal' (e.tangentImage x)
+
+private theorem
+    Smale.NativeEuclideanEmbedding.range_normalProjection {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) (x : M) :
+    (e.normalProjection x).range = e.normalFiber x :=
+  (e.normalFiber x).range_starProjection
+
+private theorem Smale.NativeEuclideanEmbedding.normalProjection_idempotent {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) (x : M) : IsIdempotentElem (e.normalProjection x) :=
+  (e.normalFiber x).isIdempotentElem_starProjection
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Recognition/Smale3.lean b/LeanPool/HopfProblem/Recognition/Smale3.lean
new file mode 100644
index 000000000..2d7c440bc
--- /dev/null
+++ b/LeanPool/HopfProblem/Recognition/Smale3.lean
@@ -0,0 +1,5662 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Recognition.Smale2
+public import LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Foundations.LineBundleTransport
+import all LeanPool.HopfProblem.Recognition.Smale1
+import all LeanPool.HopfProblem.Recognition.Smale2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+
+/-!
+# Hopf problem: recognition · smale 3
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem Smale.NativeEuclideanEmbedding.finrank_tangent_add_normal {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) (x : M) :
+    Module.finrank ℝ E + Module.finrank ℝ (e.normalFiber x) = e.ambientDimension := by
+  calc
+    Module.finrank ℝ E + Module.finrank ℝ (e.normalFiber x) =
+        Module.finrank ℝ (e.tangentImage x) + Module.finrank ℝ (e.tangentImage x)ᗮ :=
+      congrArg (fun n => n + Module.finrank ℝ (e.normalFiber x)) (e.finrank_tangentImage x).symm
+    _ = Module.finrank ℝ (EuclideanSpace ℝ (Fin e.ambientDimension)) :=
+      (e.tangentImage x).finrank_add_finrank_orthogonal
+    _ = e.ambientDimension := finrank_euclideanSpace_fin
+
+private theorem Smale.NativeEuclideanEmbedding.tangentSpaceT2 {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] (x : M) :
+    T2Space (TangentSpace 𝓘(ℝ, E) x) :=
+  inferInstanceAs (T2Space E)
+
+attribute [local instance] Smale.NativeEuclideanEmbedding.tangentSpaceT2 in
+private theorem Smale.NativeEuclideanEmbedding.tangentSpaceFiniteDimensional {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [FiniteDimensional ℝ E] (x : M) : FiniteDimensional ℝ (TangentSpace 𝓘(ℝ, E) x) :=
+  inferInstanceAs (FiniteDimensional ℝ E)
+
+attribute [local instance] Smale.NativeEuclideanEmbedding.tangentSpaceT2
+    Smale.NativeEuclideanEmbedding.tangentSpaceFiniteDimensional in
+private def Smale.NativeEuclideanEmbedding.tangentImageEquiv {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) [FiniteDimensional ℝ E] (x : M) :
+    TangentSpace 𝓘(ℝ, E) x ≃L[ℝ] e.tangentImage x :=
+  (LinearEquiv.ofInjective (mvfderiv 𝓘(ℝ, E) e.toFun x).toLinearMap
+      (e.injective_mvfderiv x)).toContinuousLinearEquiv
+
+attribute [local instance] Smale.NativeEuclideanEmbedding.tangentSpaceT2
+    Smale.NativeEuclideanEmbedding.tangentSpaceFiniteDimensional in
+private def Smale.NativeEuclideanEmbedding.tangentNormalEquiv {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) [FiniteDimensional ℝ E] (x : M) :
+    (TangentSpace 𝓘(ℝ, E) x × e.normalFiber x) ≃L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension) :=
+  ((LinearEquiv.prodCongr (e.tangentImageEquiv x).toLinearEquiv
+          (LinearEquiv.refl ℝ (e.normalFiber x))).trans
+      ((e.tangentImage x).prodEquivOfIsCompl (e.normalFiber x)
+        (e.tangentImage x).isCompl_orthogonal)).toContinuousLinearEquiv
+
+attribute [local instance] Smale.NativeEuclideanEmbedding.tangentSpaceT2
+    Smale.NativeEuclideanEmbedding.tangentSpaceFiniteDimensional in
+private theorem Smale.NativeEuclideanEmbedding.contMDiff_normalProjection {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) [FiniteDimensional ℝ E] [IsManifold 𝓘(ℝ, E) ∞ M] :
+    ContMDiff 𝓘(ℝ, E)
+      𝓘(ℝ,
+        EuclideanSpace ℝ (Fin e.ambientDimension) →L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension))
+      ∞ e.normalProjection := by
+  have heq : e.normalProjection = fun x => 1 - e.tangentProjection x :=
+    funext e.normalProjection_eq
+  rw [heq]
+  exact contMDiff_const.sub e.contMDiff_tangentProjection
+
+private def NoExotic.projectionIntertwiner {R : Type*} [Ring R] (P Q : R) : R :=
+  Q * P + (1 - Q) * (1 - P)
+
+private theorem NoExotic.projectionIntertwiner_self {R : Type*} [Ring R] (P : R)
+    (hP : IsIdempotentElem P) : projectionIntertwiner P P = 1 := by
+  unfold projectionIntertwiner
+  rw [hP, hP.one_sub]
+  simpa only [add_sub_assoc] using add_sub_cancel_left P 1
+
+private theorem NoExotic.projectionIntertwiner_intertwines {R : Type*} [Ring R] (P Q : R)
+    (hP : IsIdempotentElem P) (hQ : IsIdempotentElem Q) :
+    Q * projectionIntertwiner P Q = projectionIntertwiner P Q * P := by
+  calc
+    Q * projectionIntertwiner P Q = (Q * Q) * P + (Q * (1 - Q)) * (1 - P) := by
+      simp only [projectionIntertwiner, mul_add, mul_assoc]
+    _ = Q * P := by rw [hQ, hQ.mul_one_sub_self, MulZeroClass.zero_mul, add_zero]
+    _ = Q * (P * P) + (1 - Q) * ((1 - P) * P) := by
+      rw [hP, hP.one_sub_mul_self, MulZeroClass.mul_zero, add_zero]
+    _ = projectionIntertwiner P Q * P := by simp only [projectionIntertwiner, add_mul, mul_assoc]
+
+private theorem NoExotic.projectionIntertwiner_map_range {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (P Q : F →L[ℝ] F) (hP : IsIdempotentElem P) (hQ : IsIdempotentElem Q)
+    (hR : (projectionIntertwiner P Q).IsInvertible) :
+    Submodule.map (projectionIntertwiner P Q).toLinearMap P.range = Q.range := by
+  have hcomm := projectionIntertwiner_intertwines P Q hP hQ
+  have hsurj : Function.Surjective (projectionIntertwiner P Q : F →L[ℝ] F) := by
+    obtain ⟨r, hr⟩ := hR
+    simpa only [← hr, ContinuousLinearEquiv.coe_coe] using r.surjective
+  rw [← LinearMap.range_comp]
+  have hlin :
+    (projectionIntertwiner P Q).toLinearMap.comp P.toLinearMap =
+      Q.toLinearMap.comp (projectionIntertwiner P Q).toLinearMap :=
+    congrArg ContinuousLinearMap.toLinearMap hcomm.symm
+  rw [hlin]
+  exact LinearMap.range_comp_of_range_eq_top _ (LinearMap.range_eq_top.mpr hsurj)
+
+private noncomputable def NoExotic.invertibleOperatorEquiv {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (A : F →L[ℝ] F) (hA : A.IsInvertible) : F ≃L[ℝ] F
+    where
+  toLinearEquiv :=
+    { A.toLinearMap with
+      invFun := A.inverse
+      left_inv := hA.inverse_apply_self
+      right_inv := hA.self_apply_inverse }
+  continuous_toFun := A.continuous
+  continuous_invFun := A.inverse.continuous
+
+private noncomputable def NoExotic.projectionRangeEquiv {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (P Q : F →L[ℝ] F) (hP : IsIdempotentElem P) (hQ : IsIdempotentElem Q)
+    (hR : (projectionIntertwiner P Q).IsInvertible) : P.range ≃L[ℝ] Q.range :=
+  (invertibleOperatorEquiv (projectionIntertwiner P Q) hR).ofSubmodules P.range Q.range
+    (projectionIntertwiner_map_range P Q hP hQ hR)
+
+private theorem
+    NoExotic.projectionRangeEquiv_apply {F : Type*} [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (P Q : F →L[ℝ] F) (hP : IsIdempotentElem P) (hQ : IsIdempotentElem Q)
+    (hR : (projectionIntertwiner P Q).IsInvertible) (v : P.range) :
+    (projectionRangeEquiv P Q hP hQ hR v : F) = projectionIntertwiner P Q v :=
+  rfl
+
+private theorem NoExotic.projectionRangeEquiv_symm_apply {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (P Q : F →L[ℝ] F) (hP : IsIdempotentElem P) (hQ : IsIdempotentElem Q)
+    (hR : (projectionIntertwiner P Q).IsInvertible) (v : Q.range) :
+    ((projectionRangeEquiv P Q hP hQ hR).symm v : F) = (projectionIntertwiner P Q).inverse v :=
+  rfl
+
+private theorem NoExotic.projection_apply_range {F : Type*} [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (P : F →L[ℝ] F) (hP : IsIdempotentElem P) (v : P.range) : P v = v := by
+  obtain ⟨w, hw⟩ := v.property
+  rw [← hw]
+  exact congrArg (fun A : F →L[ℝ] F ↦ A w) hP
+
+private def NoExotic.projectionTransportDomain {F : Type*} [NormedAddCommGroup F] [NormedSpace ℝ F]
+    {M : Type*} (P : M → F →L[ℝ] F) (x₀ : M) : Set M :=
+  {x | (projectionIntertwiner (P x₀) (P x)).IsInvertible}
+
+private theorem NoExotic.contMDiff_projectionIntertwiner {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {B H M : Type*} [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ B H} [TopologicalSpace M] [ChartedSpace H M]
+    (P : M → F →L[ℝ] F) (hP : ContMDiff I 𝓘(ℝ, F →L[ℝ] F) ∞ P) (x₀ : M) :
+    ContMDiff I 𝓘(ℝ, F →L[ℝ] F) ∞ (fun x ↦ projectionIntertwiner (P x₀) (P x)) :=
+  (hP.clm_comp contMDiff_const).add ((contMDiff_const.sub hP).clm_comp contMDiff_const)
+
+private theorem NoExotic.isOpen_projectionTransportDomain {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [CompleteSpace F] {B H M : Type*} [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ B H} [TopologicalSpace M] [ChartedSpace H M]
+    (P : M → F →L[ℝ] F) (hP : ContMDiff I 𝓘(ℝ, F →L[ℝ] F) ∞ P) (x₀ : M) :
+    IsOpen (projectionTransportDomain P x₀) := by
+  have hi : IsOpen {A : F →L[ℝ] F | A.IsInvertible} := ContinuousLinearEquiv.isOpen
+  exact hi.preimage (contMDiff_projectionIntertwiner P hP x₀).continuous
+
+private theorem NoExotic.mem_projectionTransportDomain {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {M : Type*} (P : M → F →L[ℝ] F) (hP : ∀ x, IsIdempotentElem (P x))
+    (x₀ : M) : x₀ ∈ projectionTransportDomain P x₀ := by
+  change (projectionIntertwiner (P x₀) (P x₀)).IsInvertible
+  rw [projectionIntertwiner_self _ (hP x₀)]
+  exact ⟨ContinuousLinearEquiv.refl ℝ F, rfl⟩
+
+private theorem
+    NoExotic.contMDiffOn_projectionIntertwiner_inverse {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [CompleteSpace F] {B H M : Type*} [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ B H} [TopologicalSpace M] [ChartedSpace H M]
+    (P : M → F →L[ℝ] F) (hP : ContMDiff I 𝓘(ℝ, F →L[ℝ] F) ∞ P) (x₀ : M) :
+    ContMDiffOn I 𝓘(ℝ, F →L[ℝ] F) ∞ (fun x ↦ (projectionIntertwiner (P x₀) (P x)).inverse)
+      (projectionTransportDomain P x₀) := by
+  intro x hx
+  have hi := hx.contDiffAt_map_inverse (n := ∞)
+  exact
+    (ContDiffAt.comp_contMDiffAt (f := fun y ↦ projectionIntertwiner (P x₀) (P y)) (x := x) hi
+        (contMDiff_projectionIntertwiner P hP x₀).contMDiffAt).contMDiffWithinAt
+
+private noncomputable def
+    NoExotic.ProjectionBundle.toCoordinates {F K : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [NormedAddCommGroup K] [NormedSpace ℝ K] {M : Type*} (P : M → F →L[ℝ] F)
+    (q : ∀ x, (P x).range ≃L[ℝ] K) (x₀ x : M) : (P x).range →L[ℝ] K :=
+  (q x₀).toContinuousLinearMap.comp
+    ((P x₀).rangeRestrict.comp
+      ((NoExotic.projectionIntertwiner (P x₀) (P x)).inverse.comp (P x).range.subtypeL))
+
+private noncomputable def
+    NoExotic.ProjectionBundle.fromCoordinates {F K : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [NormedAddCommGroup K] [NormedSpace ℝ K] {M : Type*} (P : M → F →L[ℝ] F)
+    (q : ∀ x, (P x).range ≃L[ℝ] K) (x₀ x : M) : K →L[ℝ] (P x).range :=
+  (P x).rangeRestrict.comp
+    ((NoExotic.projectionIntertwiner (P x₀) (P x)).comp
+      ((P x₀).range.subtypeL.comp (q x₀).symm.toContinuousLinearMap))
+
+private noncomputable def
+    NoExotic.ProjectionBundle.coordinateEquiv {F K : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [NormedAddCommGroup K] [NormedSpace ℝ K] {M : Type*} (P : M → F →L[ℝ] F)
+    (hP : ∀ x, IsIdempotentElem (P x)) (q : ∀ x, (P x).range ≃L[ℝ] K) (x₀ x : M)
+    (hx : x ∈ NoExotic.projectionTransportDomain P x₀) : (P x).range ≃L[ℝ] K :=
+  (NoExotic.projectionRangeEquiv (P x₀) (P x) (hP x₀) (hP x) hx).symm.trans (q x₀)
+
+private theorem NoExotic.ProjectionBundle.toCoordinates_eq {F K : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [NormedAddCommGroup K] [NormedSpace ℝ K] {M : Type*} (P : M → F →L[ℝ] F)
+    (hP : ∀ x, IsIdempotentElem (P x)) (q : ∀ x, (P x).range ≃L[ℝ] K) (x₀ x : M)
+    (hx : x ∈ NoExotic.projectionTransportDomain P x₀) :
+    toCoordinates P q x₀ x = (coordinateEquiv P hP q x₀ x hx).toContinuousLinearMap := by
+  ext v
+  change
+    q x₀ ((P x₀).rangeRestrict ((NoExotic.projectionIntertwiner (P x₀) (P x)).inverse v)) =
+      q x₀ ((NoExotic.projectionRangeEquiv (P x₀) (P x) (hP x₀) (hP x) hx).symm v)
+  congr 1
+  apply Subtype.ext
+  change P x₀ ((NoExotic.projectionIntertwiner (P x₀) (P x)).inverse v) = _
+  rw [← NoExotic.projectionRangeEquiv_symm_apply (P x₀) (P x) (hP x₀) (hP x) hx v]
+  exact NoExotic.projection_apply_range (P x₀) (hP x₀) _
+
+private theorem NoExotic.ProjectionBundle.fromCoordinates_eq {F K : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [NormedAddCommGroup K] [NormedSpace ℝ K] {M : Type*} (P : M → F →L[ℝ] F)
+    (hP : ∀ x, IsIdempotentElem (P x)) (q : ∀ x, (P x).range ≃L[ℝ] K) (x₀ x : M)
+    (hx : x ∈ NoExotic.projectionTransportDomain P x₀) :
+    fromCoordinates P q x₀ x = (coordinateEquiv P hP q x₀ x hx).symm.toContinuousLinearMap := by
+  ext v
+  change
+    P x (NoExotic.projectionIntertwiner (P x₀) (P x) ((q x₀).symm v)) =
+      (NoExotic.projectionRangeEquiv (P x₀) (P x) (hP x₀) (hP x) hx ((q x₀).symm v) : F)
+  rw [← NoExotic.projectionRangeEquiv_apply (P x₀) (P x) (hP x₀) (hP x) hx ((q x₀).symm v)]
+  exact NoExotic.projection_apply_range (P x) (hP x) _
+
+private theorem NoExotic.ProjectionBundle.fromCoordinates_toCoordinates {F K : Type*}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [NormedAddCommGroup K] [NormedSpace ℝ K] {M : Type*}
+    (P : M → F →L[ℝ] F) (hP : ∀ x, IsIdempotentElem (P x)) (q : ∀ x, (P x).range ≃L[ℝ] K)
+    (x₀ x : M) (hx : x ∈ NoExotic.projectionTransportDomain P x₀) (v : (P x).range) :
+    fromCoordinates P q x₀ x (toCoordinates P q x₀ x v) = v := by
+  rw [toCoordinates_eq P hP q x₀ x hx, fromCoordinates_eq P hP q x₀ x hx]
+  exact (coordinateEquiv P hP q x₀ x hx).symm_apply_apply v
+
+private theorem NoExotic.ProjectionBundle.toCoordinates_fromCoordinates {F K : Type*}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [NormedAddCommGroup K] [NormedSpace ℝ K] {M : Type*}
+    (P : M → F →L[ℝ] F) (hP : ∀ x, IsIdempotentElem (P x)) (q : ∀ x, (P x).range ≃L[ℝ] K)
+    (x₀ x : M) (hx : x ∈ NoExotic.projectionTransportDomain P x₀) (v : K) :
+    toCoordinates P q x₀ x (fromCoordinates P q x₀ x v) = v := by
+  rw [toCoordinates_eq P hP q x₀ x hx, fromCoordinates_eq P hP q x₀ x hx]
+  exact (coordinateEquiv P hP q x₀ x hx).apply_symm_apply v
+
+private noncomputable def NoExotic.ProjectionBundle.ambientFromCoordinates {F K : Type*}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [NormedAddCommGroup K] [NormedSpace ℝ K] {M : Type*}
+    (P : M → F →L[ℝ] F) (q : ∀ x, (P x).range ≃L[ℝ] K) (x₀ x : M) : K →L[ℝ] F :=
+  (P x).comp
+    ((NoExotic.projectionIntertwiner (P x₀) (P x)).comp
+      ((P x₀).range.subtypeL.comp (q x₀).symm.toContinuousLinearMap))
+
+private theorem NoExotic.ProjectionBundle.contMDiff_ambientFromCoordinates {F K : Type*}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [NormedAddCommGroup K] [NormedSpace ℝ K]
+    {B H M : Type*} [NormedAddCommGroup B] [NormedSpace ℝ B] [TopologicalSpace H]
+    {I : ModelWithCorners ℝ B H} [TopologicalSpace M] [ChartedSpace H M] (P : M → F →L[ℝ] F)
+    (q : ∀ x, (P x).range ≃L[ℝ] K) (hs : ContMDiff I 𝓘(ℝ, F →L[ℝ] F) ∞ P) (x₀ : M) :
+    ContMDiff I 𝓘(ℝ, K →L[ℝ] F) ∞ (ambientFromCoordinates P q x₀) :=
+  hs.clm_comp ((NoExotic.contMDiff_projectionIntertwiner P hs x₀).clm_comp contMDiff_const)
+
+private noncomputable def
+    NoExotic.ProjectionBundle.pretrivialization {F K : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [CompleteSpace F] [NormedAddCommGroup K] [NormedSpace ℝ K] {B H M : Type*}
+    [NormedAddCommGroup B] [NormedSpace ℝ B] [TopologicalSpace H] {I : ModelWithCorners ℝ B H}
+    [TopologicalSpace M] [ChartedSpace H M] (P : M → F →L[ℝ] F) (hP : ∀ x, IsIdempotentElem (P x))
+    (q : ∀ x, (P x).range ≃L[ℝ] K) (hs : ContMDiff I 𝓘(ℝ, F →L[ℝ] F) ∞ P) (x₀ : M) :
+    Bundle.Pretrivialization K (Bundle.TotalSpace.proj (F := K) (E := fun x ↦ (P x).range))
+    where
+  toFun p := ⟨p.1, toCoordinates P q x₀ p.1 p.2⟩
+  invFun p := ⟨p.1, fromCoordinates P q x₀ p.1 p.2⟩
+  source := Bundle.TotalSpace.proj ⁻¹' NoExotic.projectionTransportDomain P x₀
+  target := NoExotic.projectionTransportDomain P x₀ ×ˢ Set.univ
+  map_source' := fun _ h ↦ ⟨h, Set.mem_univ _⟩
+  map_target' := fun _ h ↦ h.1
+  left_inv' := by
+    rintro ⟨x, v⟩ hx
+    simp only [Bundle.TotalSpace.mk_inj]
+    exact fromCoordinates_toCoordinates P hP q x₀ x hx v
+  right_inv' := by
+    rintro ⟨x, v⟩ ⟨hx, _⟩
+    simp only [Prod.mk_right_inj]
+    exact toCoordinates_fromCoordinates P hP q x₀ x hx v
+  open_target := (NoExotic.isOpen_projectionTransportDomain P hs x₀).prod isOpen_univ
+  baseSet := NoExotic.projectionTransportDomain P x₀
+  open_baseSet := NoExotic.isOpen_projectionTransportDomain P hs x₀
+  source_eq := rfl
+  target_eq := rfl
+  proj_toFun _ _ := rfl
+
+private instance
+    NoExotic.ProjectionBundle.pretrivialization_isLinear {F K : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [CompleteSpace F] [NormedAddCommGroup K] [NormedSpace ℝ K] {B H M : Type*}
+    [NormedAddCommGroup B] [NormedSpace ℝ B] [TopologicalSpace H] {I : ModelWithCorners ℝ B H}
+    [TopologicalSpace M] [ChartedSpace H M] (P : M → F →L[ℝ] F) (hP : ∀ x, IsIdempotentElem (P x))
+    (q : ∀ x, (P x).range ≃L[ℝ] K) (hs : ContMDiff I 𝓘(ℝ, F →L[ℝ] F) ∞ P) (x₀ : M) :
+    (pretrivialization P hP q hs x₀).IsLinear ℝ where
+  linear x _ := (toCoordinates P q x₀ x).toLinearMap.isLinear
+
+private theorem NoExotic.ProjectionBundle.pretrivialization_symm_apply {F K : Type*}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [CompleteSpace F] [NormedAddCommGroup K]
+    [NormedSpace ℝ K] {B H M : Type*} [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ B H} [TopologicalSpace M] [ChartedSpace H M]
+    (P : M → F →L[ℝ] F) (hP : ∀ x, IsIdempotentElem (P x)) (q : ∀ x, (P x).range ≃L[ℝ] K)
+    (hs : ContMDiff I 𝓘(ℝ, F →L[ℝ] F) ∞ P) (x₀ x : M)
+    (hx : x ∈ NoExotic.projectionTransportDomain P x₀) (v : K) :
+    (pretrivialization P hP q hs x₀).symm x v = fromCoordinates P q x₀ x v := by
+  rw [Bundle.Pretrivialization.symm_apply]
+  · rfl
+  · exact hx
+
+private noncomputable def
+    NoExotic.ProjectionBundle.coordinateChange {F K : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [NormedAddCommGroup K] [NormedSpace ℝ K] {M : Type*} (P : M → F →L[ℝ] F)
+    (q : ∀ x, (P x).range ≃L[ℝ] K) (x₀ x₁ x : M) : K →L[ℝ] K :=
+  (q x₁).toContinuousLinearMap.comp
+    ((P x₁).rangeRestrict.comp
+      ((NoExotic.projectionIntertwiner (P x₁) (P x)).inverse.comp
+        ((P x).comp
+          ((NoExotic.projectionIntertwiner (P x₀) (P x)).comp
+            ((P x₀).range.subtypeL.comp (q x₀).symm.toContinuousLinearMap)))))
+
+private theorem NoExotic.ProjectionBundle.contMDiffOn_coordinateChange {F K : Type*}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [CompleteSpace F] [NormedAddCommGroup K]
+    [NormedSpace ℝ K] {B H M : Type*} [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ B H} [TopologicalSpace M] [ChartedSpace H M]
+    (P : M → F →L[ℝ] F) (q : ∀ x, (P x).range ≃L[ℝ] K) (hs : ContMDiff I 𝓘(ℝ, F →L[ℝ] F) ∞ P)
+    (x₀ x₁ : M) :
+    ContMDiffOn I 𝓘(ℝ, K →L[ℝ] K) ∞ (coordinateChange P q x₀ x₁)
+      (NoExotic.projectionTransportDomain P x₀ ∩ NoExotic.projectionTransportDomain P x₁) := by
+  have hi :=
+    (NoExotic.contMDiffOn_projectionIntertwiner_inverse P hs x₁).mono
+      (Set.inter_subset_right (s := NoExotic.projectionTransportDomain P x₀))
+  exact
+    contMDiffOn_const.clm_comp
+      (contMDiffOn_const.clm_comp
+        (hi.clm_comp
+          (hs.contMDiffOn.clm_comp
+            ((NoExotic.contMDiff_projectionIntertwiner P hs x₀).contMDiffOn.clm_comp
+              contMDiffOn_const))))
+
+private theorem
+    NoExotic.ProjectionBundle.coordinateChange_apply {F K : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [CompleteSpace F] [NormedAddCommGroup K] [NormedSpace ℝ K] {B H M : Type*}
+    [NormedAddCommGroup B] [NormedSpace ℝ B] [TopologicalSpace H] {I : ModelWithCorners ℝ B H}
+    [TopologicalSpace M] [ChartedSpace H M] (P : M → F →L[ℝ] F) (hP : ∀ x, IsIdempotentElem (P x))
+    (q : ∀ x, (P x).range ≃L[ℝ] K) (hs : ContMDiff I 𝓘(ℝ, F →L[ℝ] F) ∞ P) (x₀ x₁ x : M)
+    (hx : x ∈ NoExotic.projectionTransportDomain P x₀ ∩ NoExotic.projectionTransportDomain P x₁)
+    (v : K) :
+    coordinateChange P q x₀ x₁ x v =
+      ((pretrivialization P hP q hs x₁) ⟨x, (pretrivialization P hP q hs x₀).symm x v⟩).2 := by
+  rw [pretrivialization_symm_apply P hP q hs x₀ x hx.1]
+  rfl
+
+private noncomputable def
+    NoExotic.ProjectionBundle.vectorPrebundle {F K : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [CompleteSpace F] [NormedAddCommGroup K] [NormedSpace ℝ K] {B H M : Type*}
+    [NormedAddCommGroup B] [NormedSpace ℝ B] [TopologicalSpace H] {I : ModelWithCorners ℝ B H}
+    [TopologicalSpace M] [ChartedSpace H M] (P : M → F →L[ℝ] F) (hP : ∀ x, IsIdempotentElem (P x))
+    (q : ∀ x, (P x).range ≃L[ℝ] K) (hs : ContMDiff I 𝓘(ℝ, F →L[ℝ] F) ∞ P) :
+    VectorPrebundle ℝ K (fun x ↦ (P x).range)
+    where
+  pretrivializationAtlas := Set.range (pretrivialization P hP q hs)
+  pretrivialization_linear' := by
+    rintro _ ⟨x₀, rfl⟩
+    infer_instance
+  pretrivializationAt := pretrivialization P hP q hs
+  mem_base_pretrivializationAt := NoExotic.mem_projectionTransportDomain P hP
+  pretrivialization_mem_atlas x := ⟨x, rfl⟩
+  exists_coordChange := by
+    rintro _ ⟨x₀, rfl⟩ _ ⟨x₁, rfl⟩
+    exact
+      ⟨coordinateChange P q x₀ x₁, (contMDiffOn_coordinateChange P q hs x₀ x₁).continuousOn,
+        coordinateChange_apply P hP q hs x₀ x₁⟩
+  totalSpaceMk_isInducing := by
+    intro x
+    change Topology.IsInducing (fun v : (P x).range ↦ (x, toCoordinates P q x x v))
+    have hx := NoExotic.mem_projectionTransportDomain P hP x
+    rw [toCoordinates_eq P hP q x x hx]
+    exact
+      Topology.isInducing_const_prod.mpr (coordinateEquiv P hP q x x hx).toHomeomorph.isInducing
+
+private instance NoExotic.ProjectionBundle.vectorPrebundle_isContMDiff {F K : Type*}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [CompleteSpace F] [NormedAddCommGroup K]
+    [NormedSpace ℝ K] {B H M : Type*} [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ B H} [TopologicalSpace M] [ChartedSpace H M]
+    (P : M → F →L[ℝ] F) (hP : ∀ x, IsIdempotentElem (P x)) (q : ∀ x, (P x).range ≃L[ℝ] K)
+    (hs : ContMDiff I 𝓘(ℝ, F →L[ℝ] F) ∞ P) : (vectorPrebundle P hP q hs).IsContMDiff I ∞ where
+  exists_contMDiffCoordChange := by
+    rintro _ ⟨x₀, rfl⟩ _ ⟨x₁, rfl⟩
+    exact
+      ⟨coordinateChange P q x₀ x₁, contMDiffOn_coordinateChange P q hs x₀ x₁,
+        coordinateChange_apply P hP q hs x₀ x₁⟩
+
+private abbrev Smale.NativeEuclideanEmbedding.NormalSpace {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) (x : M) :=
+  ↥(e.normalProjection x).range
+
+private abbrev Smale.NativeEuclideanEmbedding.NormalModel {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) :=
+  EuclideanSpace ℝ (Fin (e.ambientDimension - Module.finrank ℝ E))
+
+private noncomputable def Smale.NativeEuclideanEmbedding.normalSpaceEquiv {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) (x : M) : e.NormalSpace x ≃L[ℝ] e.normalFiber x :=
+  ContinuousLinearEquiv.ofEq _ _ (e.range_normalProjection x)
+
+private theorem
+    Smale.NativeEuclideanEmbedding.finrank_normalSpace {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) (x : M) :
+    Module.finrank ℝ (e.NormalSpace x) = e.ambientDimension - Module.finrank ℝ E := by
+  have h := e.finrank_tangent_add_normal x
+  rw [(e.normalSpaceEquiv x).toLinearEquiv.finrank_eq]
+  omega
+
+private noncomputable def Smale.NativeEuclideanEmbedding.normalModelEquiv {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) (x : M) : e.NormalSpace x ≃L[ℝ] e.NormalModel :=
+  (LinearEquiv.ofFinrankEq (e.NormalSpace x) e.NormalModel
+      (by
+        rw [e.finrank_normalSpace x]
+        exact finrank_euclideanSpace_fin.symm)).toContinuousLinearEquiv
+
+private noncomputable def Smale.NativeEuclideanEmbedding.normalPrebundle {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] (e : Smale.NativeEuclideanEmbedding E M) [IsManifold 𝓘(ℝ, E) ∞ M] :
+    VectorPrebundle ℝ e.NormalModel e.NormalSpace :=
+  NoExotic.ProjectionBundle.vectorPrebundle e.normalProjection e.normalProjection_idempotent
+    e.normalModelEquiv e.contMDiff_normalProjection
+
+private instance Smale.NativeEuclideanEmbedding.normalPrebundle_isContMDiff {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] (e : Smale.NativeEuclideanEmbedding E M) [IsManifold 𝓘(ℝ, E) ∞ M] :
+    e.normalPrebundle.IsContMDiff 𝓘(ℝ, E) ∞ :=
+  NoExotic.ProjectionBundle.vectorPrebundle_isContMDiff e.normalProjection
+    e.normalProjection_idempotent e.normalModelEquiv e.contMDiff_normalProjection
+
+private abbrev Smale.NativeEuclideanEmbedding.NormalBundle {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) :=
+  Bundle.TotalSpace e.NormalModel e.NormalSpace
+
+private noncomputable instance Smale.NativeEuclideanEmbedding.normalBundleTopology {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] (e : Smale.NativeEuclideanEmbedding E M) [IsManifold 𝓘(ℝ, E) ∞ M] :
+    TopologicalSpace e.NormalBundle :=
+  e.normalPrebundle.totalSpaceTopology
+
+private noncomputable instance Smale.NativeEuclideanEmbedding.normalFiberBundle {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] (e : Smale.NativeEuclideanEmbedding E M) [IsManifold 𝓘(ℝ, E) ∞ M] :
+    FiberBundle e.NormalModel e.NormalSpace :=
+  e.normalPrebundle.toFiberBundle
+
+private instance
+    Smale.NativeEuclideanEmbedding.normalVectorBundle {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) [IsManifold 𝓘(ℝ, E) ∞ M] :
+    VectorBundle ℝ e.NormalModel e.NormalSpace :=
+  e.normalPrebundle.toVectorBundle
+
+private instance Smale.NativeEuclideanEmbedding.normalContMDiffVectorBundle {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] (e : Smale.NativeEuclideanEmbedding E M) [IsManifold 𝓘(ℝ, E) ∞ M] :
+    ContMDiffVectorBundle ∞ e.NormalModel e.NormalSpace 𝓘(ℝ, E) :=
+  e.normalPrebundle.contMDiffVectorBundle 𝓘(ℝ, E)
+
+private def Smale.NativeEuclideanEmbedding.normalVector {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) (v : e.NormalBundle) :
+    EuclideanSpace ℝ (Fin e.ambientDimension) :=
+  v.2
+
+private theorem
+    Smale.NativeEuclideanEmbedding.contMDiff_normalVector {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M) :
+    ContMDiff ((𝓘(ℝ, E)).prod 𝓘(ℝ, e.NormalModel)) (𝓡 e.ambientDimension) ∞ e.normalVector := by
+  intro z
+  have hp :
+    ContMDiffAt ((𝓘(ℝ, E)).prod 𝓘(ℝ, e.NormalModel)) (𝓘(ℝ, E)) ∞ (fun v : e.NormalBundle ↦ v.proj)
+      z :=
+    Bundle.contMDiffAt_proj e.NormalSpace
+  have hc :
+    ContMDiffAt ((𝓘(ℝ, E)).prod 𝓘(ℝ, e.NormalModel)) 𝓘(ℝ, e.NormalModel) ∞
+      (fun v : e.NormalBundle ↦
+        NoExotic.ProjectionBundle.toCoordinates e.normalProjection e.normalModelEquiv z.1 v.1 v.2)
+      z := by
+    have h :=
+      (Bundle.contMDiffAt_totalSpace (IB := 𝓘(ℝ, E)) (IM := (𝓘(ℝ, E)).prod 𝓘(ℝ, e.NormalModel))
+            (n := ∞) (f := id) (x₀ := z)).mp
+        contMDiffAt_id
+    exact h.2
+  have hf :=
+    ((NoExotic.ProjectionBundle.contMDiff_ambientFromCoordinates e.normalProjection
+              e.normalModelEquiv e.contMDiff_normalProjection z.1).contMDiffAt.comp
+          z hp).clm_apply
+      hc
+  have heq :
+    e.normalVector =ᶠ[𝓝 z]
+      (fun v : e.NormalBundle ↦
+        NoExotic.ProjectionBundle.ambientFromCoordinates e.normalProjection e.normalModelEquiv z.1
+          v.1
+          (NoExotic.ProjectionBundle.toCoordinates e.normalProjection e.normalModelEquiv z.1 v.1
+            v.2)) := by
+    have ho :=
+      NoExotic.isOpen_projectionTransportDomain e.normalProjection e.contMDiff_normalProjection
+        z.1
+    have hn :=
+      hp.continuousAt
+        (ho.mem_nhds
+          (NoExotic.mem_projectionTransportDomain e.normalProjection e.normalProjection_idempotent
+            z.1))
+    filter_upwards [hn] with v hv
+    exact
+      (congrArg Subtype.val
+          (NoExotic.ProjectionBundle.fromCoordinates_toCoordinates e.normalProjection
+            e.normalProjection_idempotent e.normalModelEquiv z.1 v.1 hv v.2)).symm
+  exact heq.contMDiffAt_iff.mpr hf
+
+private def Smale.NativeEuclideanEmbedding.normalDisplacement {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) (v : e.NormalBundle) :
+    EuclideanSpace ℝ (Fin e.ambientDimension) :=
+  e.toFun v.proj + e.normalVector v
+
+private theorem Smale.NativeEuclideanEmbedding.contMDiff_normalDisplacement {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M) :
+    ContMDiff ((𝓘(ℝ, E)).prod 𝓘(ℝ, e.NormalModel)) (𝓡 e.ambientDimension) ∞
+      e.normalDisplacement :=
+  (e.smooth.comp (Bundle.contMDiff_proj e.NormalSpace)).add e.contMDiff_normalVector
+
+private theorem Smale.NativeEuclideanEmbedding.normalDisplacement_zero {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) (x : M) :
+    e.normalDisplacement (Bundle.zeroSection e.NormalModel e.NormalSpace x) = e.toFun x := by
+  simp [normalDisplacement, normalVector, Bundle.zeroSection]
+
+private noncomputable def Smale.NativeEuclideanEmbedding.localNormalDisplacement {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) (x₀ : M) (p : M × e.NormalModel) :
+    EuclideanSpace ℝ (Fin e.ambientDimension) :=
+  e.toFun p.1 +
+    NoExotic.ProjectionBundle.ambientFromCoordinates e.normalProjection e.normalModelEquiv x₀ p.1
+      p.2
+
+private theorem Smale.NativeEuclideanEmbedding.contMDiff_localNormalDisplacement {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M)
+    (x₀ : M) :
+    ContMDiff ((𝓘(ℝ, E)).prod 𝓘(ℝ, e.NormalModel)) (𝓡 e.ambientDimension) ∞
+      (e.localNormalDisplacement x₀) :=
+  (e.smooth.comp contMDiff_fst).add
+    (((NoExotic.ProjectionBundle.contMDiff_ambientFromCoordinates e.normalProjection
+              e.normalModelEquiv e.contMDiff_normalProjection x₀).comp
+          contMDiff_fst).clm_apply
+      contMDiff_snd)
+
+private theorem Smale.NativeEuclideanEmbedding.localNormalDisplacement_zero {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) (x₀ x : M) :
+    e.localNormalDisplacement x₀ (x, 0) = e.toFun x := by simp [localNormalDisplacement]
+
+private theorem Smale.NativeEuclideanEmbedding.ambientNormalCoordinates_self {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) (x : M) (v : e.NormalModel) :
+    NoExotic.ProjectionBundle.ambientFromCoordinates e.normalProjection e.normalModelEquiv x x v =
+      ((e.normalModelEquiv x).symm v : EuclideanSpace ℝ (Fin e.ambientDimension)) := by
+  change
+    e.normalProjection x
+        (NoExotic.projectionIntertwiner (e.normalProjection x) (e.normalProjection x)
+          ((e.normalModelEquiv x).symm v)) =
+      _
+  rw [NoExotic.projectionIntertwiner_self _ (e.normalProjection_idempotent x)]
+  exact NoExotic.projection_apply_range (e.normalProjection x) (e.normalProjection_idempotent x) _
+
+private noncomputable def Smale.NativeEuclideanEmbedding.normalLinearSplitting {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] (e : Smale.NativeEuclideanEmbedding E M) (x : M) :
+    (TangentSpace (𝓘(ℝ, E)) x × e.NormalModel) ≃L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension) :=
+  ((ContinuousLinearEquiv.refl ℝ (TangentSpace (𝓘(ℝ, E)) x)).prodCongr
+        ((e.normalModelEquiv x).symm.trans (e.normalSpaceEquiv x))).trans
+    (e.tangentNormalEquiv x)
+
+private theorem Smale.NativeEuclideanEmbedding.mvfderiv_localNormalDisplacement_zero {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M) (x : M) :
+    mvfderiv ((𝓘(ℝ, E)).prod 𝓘(ℝ, e.NormalModel)) (e.localNormalDisplacement x) (x, 0) =
+      (e.normalLinearSplitting x).toContinuousLinearMap := by
+  apply ContinuousLinearMap.ext
+  intro v
+  have hd := (e.contMDiff_localNormalDisplacement x).mdifferentiable (by simp) (x, 0)
+  have hprod :=
+    mfderiv_prod_eq_add_apply (I := 𝓘(ℝ, E)) (I' := 𝓘(ℝ, e.NormalModel)) (I'' :=
+      𝓡 e.ambientDimension) (v := v) hd
+  have hleft : (fun y : M ↦ e.localNormalDisplacement x (y, 0)) = e.toFun :=
+    funext (e.localNormalDisplacement_zero x)
+  let C : e.NormalModel →L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension) :=
+    (e.normalProjection x).range.subtypeL.comp (e.normalModelEquiv x).symm.toContinuousLinearMap
+  have hright :
+    (fun y : e.NormalModel ↦ e.localNormalDisplacement x (x, y)) = (fun y ↦ e.toFun x + C y) := by
+    funext y
+    exact congrArg (e.toFun x + ·) (e.ambientNormalCoordinates_self x y)
+  have hC :
+    mfderiv 𝓘(ℝ, e.NormalModel) (𝓡 e.ambientDimension) (fun y ↦ e.toFun x + C y)
+        (0 : e.NormalModel) =
+      C :=
+    (C.hasFDerivAt.const_add (e.toFun x)).hasMFDerivAt.mfderiv
+  change
+    mfderiv ((𝓘(ℝ, E)).prod 𝓘(ℝ, e.NormalModel)) (𝓡 e.ambientDimension)
+        (e.localNormalDisplacement x) (x, 0) v =
+      _
+  rw [hprod, hleft, hright, hC]
+  rfl
+
+private theorem Smale.NativeEuclideanEmbedding.localNormalDisplacement_derivative_isInvertible
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    (e : Smale.NativeEuclideanEmbedding E M) (x : M) :
+    (mvfderiv ((𝓘(ℝ, E)).prod 𝓘(ℝ, e.NormalModel)) (e.localNormalDisplacement x)
+        (x, 0)).IsInvertible :=
+  ⟨e.normalLinearSplitting x, (e.mvfderiv_localNormalDisplacement_zero x).symm⟩
+
+private theorem Smale.NativeEuclideanEmbedding.localNormalDisplacement_eq {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) (x₀ : M) (p : M × e.NormalModel) :
+    e.localNormalDisplacement x₀ p =
+      e.normalDisplacement
+        ⟨p.1,
+          NoExotic.ProjectionBundle.fromCoordinates e.normalProjection e.normalModelEquiv x₀ p.1
+            p.2⟩ :=
+  rfl
+
+private theorem
+    Smale.NativeEuclideanEmbedding.isLocalDiffeomorphAt_localNormalDisplacement {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M) (x : M) :
+    IsLocalDiffeomorphAt ((𝓘(ℝ, E)).prod 𝓘(ℝ, e.NormalModel)) (𝓡 e.ambientDimension) ∞
+      (e.localNormalDisplacement x) (x, 0) := by
+  exact
+    NoExotic.isLocalDiffeomorphAt_of_invertible_mvfderiv (e.contMDiff_localNormalDisplacement x)
+      (e.localNormalDisplacement_derivative_isInvertible x)
+
+private noncomputable def Smale.NativeEuclideanEmbedding.normalChartPartialDiffeomorph {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M) (x : M) :
+    PartialDiffeomorph ((𝓘(ℝ, E)).prod 𝓘(ℝ, e.NormalModel)) ((𝓘(ℝ, E)).prod 𝓘(ℝ, e.NormalModel))
+      e.NormalBundle (M × e.NormalModel) ∞
+    where
+  toPartialEquiv :=
+    (FiberBundle.trivializationAt e.NormalModel e.NormalSpace
+        x).toOpenPartialHomeomorph.toPartialEquiv
+  open_source := (FiberBundle.trivializationAt e.NormalModel e.NormalSpace x).open_source
+  open_target := (FiberBundle.trivializationAt e.NormalModel e.NormalSpace x).open_target
+  contMDiffOn_toFun := (FiberBundle.trivializationAt e.NormalModel e.NormalSpace x).contMDiffOn
+  contMDiffOn_invFun :=
+    (FiberBundle.trivializationAt e.NormalModel e.NormalSpace x).contMDiffOn_symm
+
+private theorem Smale.NativeEuclideanEmbedding.normalChartPartialDiffeomorph_zero {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M) (x : M) :
+    e.normalChartPartialDiffeomorph x (Bundle.zeroSection e.NormalModel e.NormalSpace x) =
+      (x, 0) := by
+  change
+    (x, NoExotic.ProjectionBundle.toCoordinates e.normalProjection e.normalModelEquiv x x 0) =
+      (x, 0)
+  rw [map_zero]
+
+private theorem Smale.NativeEuclideanEmbedding.normalChart_source_zero {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M) (x : M) :
+    Bundle.zeroSection e.NormalModel e.NormalSpace x ∈
+      (e.normalChartPartialDiffeomorph x).source := by
+  change x ∈ NoExotic.projectionTransportDomain e.normalProjection x
+  exact NoExotic.mem_projectionTransportDomain e.normalProjection e.normalProjection_idempotent x
+
+private theorem Smale.NativeEuclideanEmbedding.localNormalDisplacement_chart_apply {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M) (x : M)
+    (v : e.NormalBundle) (hv : v ∈ (e.normalChartPartialDiffeomorph x).source) :
+    e.localNormalDisplacement x (e.normalChartPartialDiffeomorph x v) = e.normalDisplacement v := by
+  have hbase : v.proj ∈ NoExotic.projectionTransportDomain e.normalProjection x := hv
+  have hback :=
+    NoExotic.ProjectionBundle.fromCoordinates_toCoordinates e.normalProjection
+      e.normalProjection_idempotent e.normalModelEquiv x v.proj hbase v.2
+  rw [e.localNormalDisplacement_eq]
+  change
+    e.normalDisplacement
+        ⟨v.proj,
+          NoExotic.ProjectionBundle.fromCoordinates e.normalProjection e.normalModelEquiv x v.proj
+            (NoExotic.ProjectionBundle.toCoordinates e.normalProjection e.normalModelEquiv x
+              v.proj v.2)⟩ =
+      _
+  rw [hback]
+
+private theorem
+    Smale.NativeEuclideanEmbedding.isLocalDiffeomorphAt_normalDisplacement_zero {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M) (x : M) :
+    IsLocalDiffeomorphAt ((𝓘(ℝ, E)).prod 𝓘(ℝ, e.NormalModel)) (𝓡 e.ambientDimension) ∞
+      e.normalDisplacement (Bundle.zeroSection e.NormalModel e.NormalSpace x) := by
+  obtain ⟨d, hd, heq⟩ := e.isLocalDiffeomorphAt_localNormalDisplacement x
+  let c := e.normalChartPartialDiffeomorph x
+  have hc : Bundle.zeroSection e.NormalModel e.NormalSpace x ∈ c.source :=
+    e.normalChart_source_zero x
+  have hcd : c (Bundle.zeroSection e.NormalModel e.NormalSpace x) ∈ d.source := by
+    rw [e.normalChartPartialDiffeomorph_zero]
+    exact hd
+  refine ⟨c.trans d, ⟨hc, hcd⟩, ?_⟩
+  intro v hv
+  exact (e.localNormalDisplacement_chart_apply x v hv.1).symm.trans (heq hv.2)
+
+private def Smale.NativeEuclideanEmbedding.regularNormalLocus {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M) : Set e.NormalBundle :=
+  {v |
+    IsLocalDiffeomorphAt ((𝓘(ℝ, E)).prod 𝓘(ℝ, e.NormalModel)) (𝓡 e.ambientDimension) ∞
+      e.normalDisplacement v}
+
+private theorem Smale.NativeEuclideanEmbedding.isOpen_regularNormalLocus {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M) :
+    IsOpen e.regularNormalLocus := by
+  rw [isOpen_iff_mem_nhds]
+  rintro v ⟨φ, hv, heq⟩
+  exact Filter.mem_of_superset (φ.open_source.mem_nhds hv) (fun w hw ↦ ⟨φ, hw, heq⟩)
+
+private theorem Smale.NativeEuclideanEmbedding.normalDisplacement_injOn_zeroSection {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) :
+    Set.InjOn e.normalDisplacement (Set.range (Bundle.zeroSection e.NormalModel e.NormalSpace)) :=
+  by
+  rintro _ ⟨x, rfl⟩ _ ⟨y, rfl⟩ h
+  have hxy : e.toFun x = e.toFun y := by simpa only [e.normalDisplacement_zero] using h
+  exact
+    congrArg (Bundle.zeroSection e.NormalModel e.NormalSpace) (e.closedEmbedding.injective hxy)
+
+private theorem
+    Smale.NativeEuclideanEmbedding.normalDisplacement_locally_injective_zero {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M) (x : M) :
+    ∃ U ∈ 𝓝 (Bundle.zeroSection e.NormalModel e.NormalSpace x),
+      Set.InjOn e.normalDisplacement U := by
+  obtain ⟨φ, hx, heq⟩ := e.isLocalDiffeomorphAt_normalDisplacement_zero x
+  exact ⟨φ.source, φ.open_source.mem_nhds hx, heq.injOn_iff.mpr φ.toPartialEquiv.injOn⟩
+
+private theorem Smale.NativeEuclideanEmbedding.exists_injective_normalNeighborhood {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M)
+    [CompactSpace M] :
+    ∃ U : Set e.NormalBundle,
+      IsOpen U ∧
+        Set.range (Bundle.zeroSection e.NormalModel e.NormalSpace) ⊆ U ∧
+          Set.InjOn e.normalDisplacement U ∧
+            IsLocalDiffeomorphOn ((𝓘(ℝ, E)).prod 𝓘(ℝ, e.NormalModel)) (𝓡 e.ambientDimension) ∞
+              e.normalDisplacement U := by
+  have hc : IsCompact (Set.range (Bundle.zeroSection e.NormalModel e.NormalSpace)) :=
+    isCompact_range (Bundle.Trivialization.continuous_zeroSection ℝ)
+  obtain ⟨V, hV, hsV, hInj⟩ :=
+    e.normalDisplacement_injOn_zeroSection.exists_isOpen_superset hc
+      (fun v _ ↦ e.contMDiff_normalDisplacement.continuous.continuousAt)
+      (by rintro _ ⟨x, rfl⟩; exact e.normalDisplacement_locally_injective_zero x)
+  refine
+    ⟨V ∩ e.regularNormalLocus, hV.inter e.isOpen_regularNormalLocus, ?_,
+      hInj.mono Set.inter_subset_left, ?_⟩
+  · intro v hv
+    refine ⟨hsV hv, ?_⟩
+    obtain ⟨x, rfl⟩ := hv
+    exact e.isLocalDiffeomorphAt_normalDisplacement_zero x
+  · intro v
+    exact v.property.2
+
+private theorem Smale.NativeEuclideanEmbedding.isOpen_normalNeighborhood_image {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M)
+    {U : Set e.NormalBundle} (hU : IsOpen U)
+    (hloc :
+      IsLocalDiffeomorphOn ((𝓘(ℝ, E)).prod 𝓘(ℝ, e.NormalModel)) (𝓡 e.ambientDimension) ∞
+        e.normalDisplacement U) :
+    IsOpen (e.normalDisplacement '' U) := by
+  rw [isOpen_iff_mem_nhds]
+  rintro _ ⟨v, hv, rfl⟩
+  rw [← hloc.isLocalHomeomorphOn.map_nhds_eq hv]
+  exact Filter.image_mem_map (hU.mem_nhds hv)
+
+private theorem
+    Smale.NativeEuclideanEmbedding.normalBundle_nonempty {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) [Nonempty M] : Nonempty e.NormalBundle :=
+  ⟨Bundle.zeroSection e.NormalModel e.NormalSpace (Classical.choice ‹Nonempty M›)⟩
+
+attribute [local instance] Smale.NativeEuclideanEmbedding.normalBundle_nonempty in
+private noncomputable def Smale.NativeEuclideanEmbedding.normalNeighborhoodEquiv {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) [Nonempty M] {U : Set e.NormalBundle}
+    (hinj : Set.InjOn e.normalDisplacement U) :
+    PartialEquiv e.NormalBundle (EuclideanSpace ℝ (Fin e.ambientDimension)) :=
+  hinj.toPartialEquiv e.normalDisplacement U
+
+attribute [local instance] Smale.NativeEuclideanEmbedding.normalBundle_nonempty in
+private theorem Smale.NativeEuclideanEmbedding.contMDiffAt_normalNeighborhood_inverse {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M)
+    [Nonempty M] {U : Set e.NormalBundle} (hU : IsOpen U)
+    (hinj : Set.InjOn e.normalDisplacement U)
+    (hloc :
+      IsLocalDiffeomorphOn ((𝓘(ℝ, E)).prod 𝓘(ℝ, e.NormalModel)) (𝓡 e.ambientDimension) ∞
+        e.normalDisplacement U)
+    {y : EuclideanSpace ℝ (Fin e.ambientDimension)}
+    (hy : y ∈ (e.normalNeighborhoodEquiv hinj).target) :
+    ContMDiffAt (𝓡 e.ambientDimension) ((𝓘(ℝ, E)).prod 𝓘(ℝ, e.NormalModel)) ∞
+      (e.normalNeighborhoodEquiv hinj).symm y := by
+  let p := e.normalNeighborhoodEquiv hinj
+  have hx : p.symm y ∈ U := p.map_target hy
+  obtain ⟨φ, hφx, heq⟩ := hloc ⟨p.symm y, hx⟩
+  have hφxy : φ (p.symm y) = y := (heq hφx).symm.trans (p.right_inv hy)
+  have hφy : y ∈ φ.target := hφxy ▸ φ.map_source' hφx
+  have hφyx : φ.symm y = p.symm y := by
+    calc
+      φ.symm y = φ.symm (φ (p.symm y)) := congrArg φ.symm hφxy.symm
+      _ = p.symm y := φ.left_inv' hφx
+  have hg : ContMDiffAt (𝓡 e.ambientDimension) ((𝓘(ℝ, E)).prod 𝓘(ℝ, e.NormalModel)) ∞ φ.symm y :=
+    φ.contMDiffOn_invFun.contMDiffAt (φ.open_target.mem_nhds hφy)
+  have hNU : U ∈ 𝓝 (φ.symm y) := by
+    rw [hφyx]
+    exact hU.mem_nhds hx
+  have hfg : p.symm =ᶠ[𝓝 y] φ.symm := by
+    filter_upwards [φ.open_target.mem_nhds hφy, hg.continuousAt hNU] with z hz hzU
+    have hfz : e.normalDisplacement (φ.symm z) = z :=
+      (heq (φ.map_target' hz)).trans (φ.right_inv' hz)
+    exact (congrArg p.symm hfz.symm).trans (p.left_inv hzU)
+  exact hfg.contMDiffAt_iff.mpr hg
+
+attribute [local instance] Smale.NativeEuclideanEmbedding.normalBundle_nonempty in
+private noncomputable def Smale.NativeEuclideanEmbedding.normalNeighborhoodPartialDiffeomorph
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    (e : Smale.NativeEuclideanEmbedding E M) [Nonempty M] {U : Set e.NormalBundle} (hU : IsOpen U)
+    (hinj : Set.InjOn e.normalDisplacement U)
+    (hloc :
+      IsLocalDiffeomorphOn ((𝓘(ℝ, E)).prod 𝓘(ℝ, e.NormalModel)) (𝓡 e.ambientDimension) ∞
+        e.normalDisplacement U) :
+    PartialDiffeomorph ((𝓘(ℝ, E)).prod 𝓘(ℝ, e.NormalModel)) (𝓡 e.ambientDimension) e.NormalBundle
+      (EuclideanSpace ℝ (Fin e.ambientDimension)) ∞
+    where
+  toPartialEquiv := e.normalNeighborhoodEquiv hinj
+  open_source := hU
+  open_target := e.isOpen_normalNeighborhood_image hU hloc
+  contMDiffOn_toFun := e.contMDiff_normalDisplacement.contMDiffOn
+  contMDiffOn_invFun := fun _ hy ↦
+    (e.contMDiffAt_normalNeighborhood_inverse hU hinj hloc hy).contMDiffWithinAt
+
+attribute [local instance] Smale.NativeEuclideanEmbedding.normalBundle_nonempty in
+private theorem Smale.NativeEuclideanEmbedding.exists_tubularNeighborhood {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M)
+    [Nonempty M] [CompactSpace M] :
+    ∃ Φ :
+      PartialDiffeomorph ((𝓘(ℝ, E)).prod 𝓘(ℝ, e.NormalModel)) (𝓡 e.ambientDimension)
+        e.NormalBundle (EuclideanSpace ℝ (Fin e.ambientDimension)) ∞,
+      Set.range (Bundle.zeroSection e.NormalModel e.NormalSpace) ⊆ Φ.source ∧
+        (Φ : e.NormalBundle → EuclideanSpace ℝ (Fin e.ambientDimension)) = e.normalDisplacement ∧
+          Set.range e.toFun ⊆ Φ.target := by
+  obtain ⟨U, hU, hzero, hinj, hloc⟩ := e.exists_injective_normalNeighborhood
+  let Φ := e.normalNeighborhoodPartialDiffeomorph hU hinj hloc
+  refine ⟨Φ, hzero, rfl, ?_⟩
+  rintro _ ⟨x, rfl⟩
+  have hx : Bundle.zeroSection e.NormalModel e.NormalSpace x ∈ Φ.source := hzero ⟨x, rfl⟩
+  have hy := Φ.map_source' hx
+  simpa only [Φ, normalNeighborhoodPartialDiffeomorph, normalNeighborhoodEquiv,
+    Set.InjOn.toPartialEquiv, Set.BijOn.toPartialEquiv, e.normalDisplacement_zero] using hy
+
+private structure
+    Smale.NativeEuclideanEmbedding.SmoothRetraction {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (e : Smale.NativeEuclideanEmbedding E M) where
+  domain : Set (EuclideanSpace ℝ (Fin e.ambientDimension))
+  open_domain : IsOpen domain
+  contains : Set.range e.toFun ⊆ domain
+  toFun : EuclideanSpace ℝ (Fin e.ambientDimension) → M
+  smooth : ContMDiffOn (𝓡 e.ambientDimension) 𝓘(ℝ, E) ∞ toFun domain
+  retract : ∀ x, toFun (e.toFun x) = x
+
+private theorem Smale.NativeEuclideanEmbedding.nonempty_smoothRetraction {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M)
+    [CompactSpace M] [Nonempty M] : Nonempty e.SmoothRetraction := by
+  obtain ⟨Φ, hzero, hΦ, hrange⟩ := e.exists_tubularNeighborhood
+  refine
+    ⟨⟨Φ.target, Φ.open_target, hrange, fun y => (Φ.symm y).proj,
+        (Bundle.contMDiff_proj e.NormalSpace).comp_contMDiffOn Φ.contMDiffOn_invFun, ?_⟩⟩
+  intro x
+  have hx : Bundle.zeroSection e.NormalModel e.NormalSpace x ∈ Φ.source := hzero ⟨x, rfl⟩
+  have heq : Φ (Bundle.zeroSection e.NormalModel e.NormalSpace x) = e.toFun x := by
+    rw [hΦ, e.normalDisplacement_zero]
+  have hinv := Φ.left_inv' hx
+  rw [heq] at hinv
+  exact congrArg Bundle.TotalSpace.proj hinv
+
+private theorem Smale.NativeEuclideanEmbedding.SmoothRetraction.mfderiv_retract_comp {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction) (x : M) :
+    (mfderiv (𝓡 e.ambientDimension) 𝓘(ℝ, E) r.toFun (e.toFun x)).comp
+        (mfderiv 𝓘(ℝ, E) (𝓡 e.ambientDimension) e.toFun x) =
+      ContinuousLinearMap.id ℝ (TangentSpace 𝓘(ℝ, E) x) := by
+  have hr : r.toFun ∘ e.toFun = id := funext r.retract
+  have hd :=
+    mfderiv_comp x
+      ((r.smooth.contMDiffAt (r.open_domain.mem_nhds (r.contains ⟨x, rfl⟩))).mdifferentiableAt
+        (by simp))
+      (e.smooth.mdifferentiableAt (by simp))
+  rw [hr, mfderiv_id] at hd
+  exact hd.symm
+
+private theorem
+    Smale.NativeEuclideanEmbedding.SmoothRetraction.embedding_derivative_retract {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction) {x : M}
+    {v : EuclideanSpace ℝ (Fin e.ambientDimension)} (hv : v ∈ e.tangentImage x) :
+    (mvfderiv 𝓘(ℝ, E) e.toFun x)
+        ((mfderiv (𝓡 e.ambientDimension) 𝓘(ℝ, E) r.toFun (e.toFun x)) v) =
+      v := by
+  obtain ⟨w, rfl⟩ := hv
+  have h := congrArg (fun A => A w) (r.mfderiv_retract_comp x)
+  exact congrArg (mvfderiv 𝓘(ℝ, E) e.toFun x) h
+
+private theorem Smale.NativeEuclideanEmbedding.contMDiff_embeddedField {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (e : Smale.NativeEuclideanEmbedding E M)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M))) :
+    ContMDiff 𝓘(ℝ, E) (𝓡 e.ambientDimension) ∞ (fun x => mvfderiv 𝓘(ℝ, E) e.toFun x (V x)) := by
+  have ht := (e.smooth.contMDiff_tangentMap (m := ∞) (by simp)).comp hV
+  have hp :=
+    (contMDiff_tangentBundleModelSpaceHomeomorph (I := 𝓡 e.ambientDimension) (n := ∞)).comp ht
+  rw [← modelWithCornersSelf_prod] at hp
+  convert contDiff_snd.contMDiff.comp hp using 1 <;> rfl
+
+private def
+    Smale.RegularLevel.levelDisplacement {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {b : ℝ}
+    {e : Smale.NativeEuclideanEmbedding E M} (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (z : { x : M // f x = b } × ℝ) : EuclideanSpace ℝ (Fin e.ambientDimension) :=
+  e.toFun z.1 + z.2 • mvfderiv 𝓘(ℝ, E) e.toFun z.1 (V z.1)
+
+private def Smale.RegularLevel.transverseCoordinateDomain {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {b : ℝ}
+    {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x) : Set ({ x : M // f x = b } × ℝ) :=
+  levelDisplacement V ⁻¹' r.domain
+
+private def Smale.RegularLevel.transverseCoordinates {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {b : ℝ}
+    {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x) : ({ x : M // f x = b } × ℝ) → M :=
+  r.toFun ∘ levelDisplacement V
+
+private theorem Smale.RegularLevel.transverseCoordinates_zero {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {b : ℝ}
+    {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x) (x : { x : M // f x = b }) :
+    transverseCoordinates r V (x, 0) = x := by
+  simp only [transverseCoordinates, Function.comp_apply, levelDisplacement, zero_smul, add_zero]
+  exact r.retract x
+
+private theorem Smale.RegularLevel.zero_mem_transverseCoordinateDomain {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {b : ℝ} {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x) (x : { x : M // f x = b }) :
+    (x, 0) ∈ transverseCoordinateDomain r V := by
+  change e.toFun x + (0 : ℝ) • _ ∈ r.domain
+  simp only [zero_smul, add_zero]
+  exact r.contains ⟨x, rfl⟩
+
+private theorem Smale.RegularLevel.contMDiff_levelDisplacement {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {b : ℝ} {e : Smale.NativeEuclideanEmbedding E M}
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M))) :
+    letI := chartedSpace hf hreg
+    ContMDiff (𝓘(ℝ, Model E).prod 𝓘(ℝ, ℝ)) (𝓡 e.ambientDimension) ∞
+      (levelDisplacement (e := e) (f := f) (b := b) V) := by
+  let _ := chartedSpace hf hreg
+  have hi :
+    ContMDiff (𝓘(ℝ, Model E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) ∞
+      (fun z : { x : M // f x = b } × ℝ => (z.1 : M)) :=
+    (Smale.RegularLevel.contMDiff_inclusion hf hreg).comp contMDiff_fst
+  have hfirst := e.smooth.comp hi
+  have hfield := (e.contMDiff_embeddedField hV).comp hi
+  have htime :
+    ContMDiff (𝓘(ℝ, Model E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, ℝ) ∞ (Prod.snd : { x : M // f x = b } × ℝ → ℝ) :=
+    contMDiff_snd
+  exact hfirst.add (htime.smul hfield)
+
+private theorem
+    Smale.RegularLevel.isOpen_transverseCoordinateDomain {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {b : ℝ} {e : Smale.NativeEuclideanEmbedding E M}
+    (r : e.SmoothRetraction) (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M))) :
+    IsOpen (transverseCoordinateDomain (f := f) (b := b) r V) := by
+  let _ := chartedSpace hf hreg
+  exact r.open_domain.preimage (contMDiff_levelDisplacement (e := e) V hf hreg hV).continuous
+
+private theorem
+    Smale.RegularLevel.contMDiffOn_transverseCoordinates {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {b : ℝ} {e : Smale.NativeEuclideanEmbedding E M}
+    (r : e.SmoothRetraction) (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M))) :
+    letI := chartedSpace hf hreg
+    ContMDiffOn (𝓘(ℝ, Model E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) ∞ (transverseCoordinates r V)
+      (transverseCoordinateDomain (f := f) (b := b) r V) := by
+  let _ := chartedSpace hf hreg
+  exact
+    r.smooth.comp (contMDiff_levelDisplacement (e := e) V hf hreg hV).contMDiffOn (fun _ hz => hz)
+
+private theorem Smale.RegularLevel.mfderiv_transverseCoordinates_time_zero {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {b : ℝ} {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x) (x : { x : M // f x = b }) :
+    mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, E) (fun t : ℝ => transverseCoordinates r V (x, t)) 0 =
+      (ContinuousLinearMap.id ℝ ℝ).smulRight (V x) := by
+  let A := mvfderiv 𝓘(ℝ, E) e.toFun (x : M) (V x)
+  let line : ℝ → EuclideanSpace ℝ (Fin e.ambientDimension) := fun t => e.toFun x + t • A
+  have hline : HasFDerivAt line ((ContinuousLinearMap.id ℝ ℝ).smulRight A) 0 :=
+    ((ContinuousLinearMap.id ℝ ℝ).smulRight A).hasFDerivAt.const_add (e.toFun x)
+  have hzero : line 0 = e.toFun x := by simp [line]
+  have hr : MDifferentiableAt (𝓡 e.ambientDimension) 𝓘(ℝ, E) r.toFun (line 0) := by
+    rw [hzero]
+    exact
+      (r.smooth.contMDiffAt (r.open_domain.mem_nhds (r.contains ⟨x, rfl⟩))).mdifferentiableAt
+        (by simp)
+  change mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, E) (r.toFun ∘ line) 0 = _
+  rw [mfderiv_comp 0 hr hline.differentiableAt.mdifferentiableAt, mfderiv_eq_fderiv, hline.fderiv,
+    hzero]
+  apply ContinuousLinearMap.ext
+  intro t
+  change ℝ at t
+  let R : EuclideanSpace ℝ (Fin e.ambientDimension) →L[ℝ] E :=
+    mfderiv (𝓡 e.ambientDimension) 𝓘(ℝ, E) r.toFun (e.toFun x)
+  change R (t • A) = t • (V x : E)
+  rw [map_smul]
+  congr 1
+  exact congrArg (fun L => L (V x)) (r.mfderiv_retract_comp (x : M))
+
+private theorem
+    Smale.RegularLevel.mfderiv_transverseCoordinates_zero {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {b : ℝ} {e : Smale.NativeEuclideanEmbedding E M}
+    (r : e.SmoothRetraction) (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (x : { x : M // f x = b }) :
+    letI := chartedSpace hf hreg
+    mfderiv (𝓘(ℝ, Model E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) (transverseCoordinates r V) (x, 0) =
+      transverseTangentMap hf hreg x (V x) := by
+  let _ := chartedSpace hf hreg
+  have hs :=
+    (contMDiffOn_transverseCoordinates r V hf hreg hV).contMDiffAt
+      ((isOpen_transverseCoordinateDomain r V hf hreg hV).mem_nhds
+        (zero_mem_transverseCoordinateDomain r V x))
+  have hbase : (fun y : { x : M // f x = b } => transverseCoordinates r V (y, 0)) = Subtype.val :=
+    funext (transverseCoordinates_zero r V)
+  apply ContinuousLinearMap.ext
+  intro w
+  rw [mfderiv_prod_eq_add_apply (hs.mdifferentiableAt (by simp)), hbase,
+    mfderiv_transverseCoordinates_time_zero r V x]
+  rfl
+
+private theorem Smale.RegularLevel.isLocalDiffeomorphAt_transverseCoordinates_zero {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {b : ℝ}
+    {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (x : { x : M // f x = b }) (hunit : mvfderiv 𝓘(ℝ, E) f (x : M) (V x) = 1) :
+    letI := chartedSpace hf hreg
+    IsLocalDiffeomorphAt (𝓘(ℝ, Model E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) ∞ (transverseCoordinates r V)
+      (x, 0) := by
+  let _ := chartedSpace hf hreg
+  let _ := isManifold hf hreg
+  have hs := contMDiffOn_transverseCoordinates r V hf hreg hV
+  have hi :
+    (mfderiv (𝓘(ℝ, Model E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) (transverseCoordinates r V)
+        (x, 0)).IsInvertible := by
+    rw [mfderiv_transverseCoordinates_zero r V hf hreg hV x]
+    let A := transverseTangentMap hf hreg x (V x)
+    exact
+      ⟨(LinearEquiv.ofBijective A.toLinearMap
+            (bijective_transverseTangentMap hf hreg x (V x) hunit)).toContinuousLinearEquiv,
+        rfl⟩
+  exact
+    Smale.isLocalDiffeomorphAt_between_manifolds
+      (isOpen_transverseCoordinateDomain r V hf hreg hV)
+      (zero_mem_transverseCoordinateDomain r V x) hs hi
+
+private theorem Smale.RegularLevel.hasDerivAt_height_transverseCoordinates_zero {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {b : ℝ}
+    {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (x : { x : M // f x = b }) (hunit : mvfderiv 𝓘(ℝ, E) f (x : M) (V x) = 1) :
+    HasDerivAt (fun t : ℝ => f (transverseCoordinates r V (x, t))) 1 0 := by
+  let _ := chartedSpace hf hreg
+  have hs :=
+    (contMDiffOn_transverseCoordinates r V hf hreg hV).contMDiffAt
+      ((isOpen_transverseCoordinateDomain r V hf hreg hV).mem_nhds
+        (zero_mem_transverseCoordinateDomain r V x))
+  have hpair : ContMDiffAt 𝓘(ℝ, ℝ) (𝓘(ℝ, Model E).prod 𝓘(ℝ, ℝ)) ∞ (fun t : ℝ => (x, t)) 0 :=
+    contMDiffAt_const.prodMk contMDiffAt_id
+  have hcurve := ((hs.comp 0 hpair).mdifferentiableAt (by simp)).hasMFDerivAt
+  change
+    HasMFDerivAt 𝓘(ℝ, ℝ) 𝓘(ℝ, E) (fun t : ℝ => transverseCoordinates r V (x, t)) 0
+      (mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, E) (fun t : ℝ => transverseCoordinates r V (x, t)) 0) at hcurve
+  rw [mfderiv_transverseCoordinates_time_zero r V x] at hcurve
+  have hc := (hf.mdifferentiableAt (by simp)).hasMFDerivAt.comp 0 hcurve
+  rw [hasDerivAt_iff_hasFDerivAt]
+  apply hasMFDerivAt_iff_hasFDerivAt.mp
+  apply hc.congr_mfderiv
+  apply ContinuousLinearMap.ext
+  intro t
+  change ℝ at t
+  let L : E →L[ℝ] ℝ := mvfderiv 𝓘(ℝ, E) f (x : M)
+  have hd : (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f (transverseCoordinates r V (x, 0)) : E →L[ℝ] ℝ) = L := by
+    rw [transverseCoordinates_zero r V x]
+    rfl
+  change
+    (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f (transverseCoordinates r V (x, 0)) : E →L[ℝ] ℝ) (t • (V x : E)) =
+      t • (1 : ℝ)
+  exact
+    (congrArg (fun T : E →L[ℝ] ℝ => T (t • (V x : E))) hd).trans
+      ((L.map_smul t (V x)).trans (congrArg (fun a : ℝ => t • a) hunit))
+
+private theorem
+    Smale.DiskFraming.starProjection_orthogonal_inf_eq_sub {F : Type*} [NormedAddCommGroup F]
+    [InnerProductSpace ℝ F] [FiniteDimensional ℝ F] {U V : Submodule ℝ F} (h : U ≤ V) :
+    (Uᗮ ⊓ V).starProjection = V.starProjection - U.starProjection := by
+  ext x
+  change (Uᗮ ⊓ V).starProjection x = V.starProjection x - U.starProjection x
+  apply Submodule.eq_starProjection_of_mem_orthogonal
+  · refine ⟨?_, V.sub_mem (V.starProjection_apply_mem x) (h (U.starProjection_apply_mem x))⟩
+    rw [← U.ker_starProjection]
+    change U.starProjection (V.starProjection x - U.starProjection x) = 0
+    rw [map_sub]
+    have hc : U.starProjection (V.starProjection x) = U.starProjection x :=
+      congrArg (fun A : F →L[ℝ] F => A x) (Submodule.starProjection_comp_starProjection_of_le h)
+    rw [hc, Submodule.starProjection_eq_self_iff.mpr (U.starProjection_apply_mem x), sub_self]
+  · have h₁ : x - V.starProjection x ∈ (Uᗮ ⊓ V)ᗮ :=
+      Submodule.orthogonal_le inf_le_right (V.sub_starProjection_mem_orthogonal x)
+    have h₂ : U.starProjection x ∈ (Uᗮ ⊓ V)ᗮ :=
+      Submodule.orthogonal_le inf_le_left
+        (U.le_orthogonal_orthogonal (U.starProjection_apply_mem x))
+    convert (Uᗮ ⊓ V)ᗮ.add_mem h₁ h₂ using 1
+    abel
+
+private def Smale.NativeEuclideanEmbedding.diskTangentImage {E M D : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [NormedAddCommGroup D]
+    [InnerProductSpace ℝ D] (e : Smale.NativeEuclideanEmbedding E M) (f : D → M) (x : D) :
+    Submodule ℝ (EuclideanSpace ℝ (Fin e.ambientDimension)) :=
+  (fderiv ℝ (e.toFun ∘ f) x).range
+
+private def Smale.NativeEuclideanEmbedding.diskNormalSpace {E M D : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [NormedAddCommGroup D]
+    [InnerProductSpace ℝ D] (e : Smale.NativeEuclideanEmbedding E M) (f : D → M) (x : D) :
+    Submodule ℝ (EuclideanSpace ℝ (Fin e.ambientDimension)) :=
+  (e.diskTangentImage f x)ᗮ ⊓ e.tangentImage (f x)
+
+private theorem Smale.NativeEuclideanEmbedding.fderiv_comp_eq {E M D : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [NormedAddCommGroup D]
+    [InnerProductSpace ℝ D] (e : Smale.NativeEuclideanEmbedding E M) {f : D → M}
+    (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f) (x : D) :
+    fderiv ℝ (e.toFun ∘ f) x =
+      (mvfderiv 𝓘(ℝ, E) e.toFun (f x)).comp (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x) := by
+  rw [← mfderiv_eq_fderiv,
+    mfderiv_comp x (e.smooth.mdifferentiableAt (by simp)) (hf.mdifferentiableAt (by simp))]
+  rfl
+
+private theorem
+    Smale.NativeEuclideanEmbedding.diskTangentImage_le {E M D : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [NormedAddCommGroup D]
+    [InnerProductSpace ℝ D] (e : Smale.NativeEuclideanEmbedding E M) {f : D → M}
+    (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f) (x : D) :
+    e.diskTangentImage f x ≤ e.tangentImage (f x) := by
+  rw [diskTangentImage, e.fderiv_comp_eq hf x]
+  exact LinearMap.range_comp_le_range _ _
+
+private theorem Smale.NativeEuclideanEmbedding.injective_fderiv_comp {E M D : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [NormedAddCommGroup D] [InnerProductSpace ℝ D] (e : Smale.NativeEuclideanEmbedding E M)
+    {f : D → M} (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f) {x : D}
+    (hi : Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x)) :
+    Function.Injective (fderiv ℝ (e.toFun ∘ f) x) := by
+  rw [e.fderiv_comp_eq hf x]
+  exact (e.injective_mvfderiv (f x)).comp hi
+
+private theorem Smale.NativeEuclideanEmbedding.finrank_diskTangent_add_normal {E M D : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [NormedAddCommGroup D] [InnerProductSpace ℝ D] (e : Smale.NativeEuclideanEmbedding E M)
+    {f : D → M} (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f) {x : D}
+    (hi : Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x)) :
+    Module.finrank ℝ D + Module.finrank ℝ (e.diskNormalSpace f x) = Module.finrank ℝ E := by
+  have hd : Module.finrank ℝ (e.diskTangentImage f x) = Module.finrank ℝ D :=
+    LinearMap.finrank_range_of_inj (e.injective_fderiv_comp hf hi)
+  calc
+    Module.finrank ℝ D + Module.finrank ℝ (e.diskNormalSpace f x) =
+        Module.finrank ℝ (e.diskTangentImage f x) + Module.finrank ℝ (e.diskNormalSpace f x) :=
+      congrArg (fun n => n + Module.finrank ℝ (e.diskNormalSpace f x)) hd.symm
+    _ = Module.finrank ℝ (e.tangentImage (f x)) :=
+      (Submodule.finrank_add_inf_finrank_orthogonal (e.diskTangentImage_le hf x))
+    _ = Module.finrank ℝ E := e.finrank_tangentImage (f x)
+
+private def
+    Smale.NativeEuclideanEmbedding.diskNormalProjection {E M D : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [NormedAddCommGroup D]
+    [InnerProductSpace ℝ D] [FiniteDimensional ℝ D] (e : Smale.NativeEuclideanEmbedding E M)
+    (f : D → M) (x : D) :
+    EuclideanSpace ℝ (Fin e.ambientDimension) →L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension) :=
+  e.tangentProjection (f x) - NoExotic.gramProjection (fderiv ℝ (e.toFun ∘ f) x)
+
+private theorem Smale.NativeEuclideanEmbedding.diskNormalProjection_eq {E M D : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [NormedAddCommGroup D] [InnerProductSpace ℝ D] [FiniteDimensional ℝ D]
+    (e : Smale.NativeEuclideanEmbedding E M) {f : D → M} (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f)
+    {x : D} (hi : Function.Injective (fderiv ℝ (e.toFun ∘ f) x)) :
+    e.diskNormalProjection f x = (e.diskNormalSpace f x).starProjection := by
+  rw [diskNormalProjection, NoExotic.gramProjection_eq_starProjection _ hi]
+  exact (Smale.DiskFraming.starProjection_orthogonal_inf_eq_sub (e.diskTangentImage_le hf x)).symm
+
+private theorem Smale.NativeEuclideanEmbedding.contDiffOn_diskNormalProjection {E M D : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [NormedAddCommGroup D] [InnerProductSpace ℝ D]
+    [FiniteDimensional ℝ D] (e : Smale.NativeEuclideanEmbedding E M) {f : D → M}
+    (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f) :
+    ContDiffOn ℝ ∞ (e.diskNormalProjection f)
+      {x | Function.Injective (fderiv ℝ (e.toFun ∘ f) x)} := by
+  have hs : ContDiff ℝ ∞ (e.toFun ∘ f) := (e.smooth.comp hf).contDiff
+  have hd : ContDiff ℝ ∞ (fderiv ℝ (e.toFun ∘ f)) := (contDiff_infty_iff_fderiv.mp hs).2
+  have hT : ContDiff ℝ ∞ (fun x => e.tangentProjection (f x)) :=
+    (e.contMDiff_tangentProjection.comp hf).contDiff
+  intro x hx
+  have hp : ContDiffAt ℝ ∞ (e.diskNormalProjection f) x :=
+    hT.contDiffAt.sub (NoExotic.contMDiffAt_gramProjection hd.contMDiff.contMDiffAt hx).contDiffAt
+  exact hp.contDiffWithinAt
+
+private theorem Smale.NativeEuclideanEmbedding.exists_open_diskNormalProjection {E M D : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [NormedAddCommGroup D] [InnerProductSpace ℝ D]
+    [FiniteDimensional ℝ D] (e : Smale.NativeEuclideanEmbedding E M) {f : D → M}
+    (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f) {K : Set D}
+    (hi : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x)) :
+    ∃ U : Set D,
+      IsOpen U ∧
+        K ⊆ U ∧
+          ContDiffOn ℝ ∞ (e.diskNormalProjection f) U ∧
+            ∀ x ∈ U, e.diskNormalProjection f x = (e.diskNormalSpace f x).starProjection := by
+  have hs : ContDiff ℝ ∞ (e.toFun ∘ f) := (e.smooth.comp hf).contDiff
+  have hd : ContDiff ℝ ∞ (fderiv ℝ (e.toFun ∘ f)) := (contDiff_infty_iff_fderiv.mp hs).2
+  refine
+    ⟨{x | Function.Injective (fderiv ℝ (e.toFun ∘ f) x)},
+      ContinuousLinearMap.isOpen_injective.preimage hd.continuous, fun x hx =>
+      e.injective_fderiv_comp hf (hi x hx), e.contDiffOn_diskNormalProjection hf, ?_⟩
+  exact fun _ hx => e.diskNormalProjection_eq hf hx
+
+private structure Smale.DiskFraming.SmoothRangeTransportOn {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] (K : Set E)
+    (P Q : E → F →L[ℝ] F) where
+  toFun : E → F →L[ℝ] F
+  neighborhood : Set E
+  open_neighborhood : IsOpen neighborhood
+  contains : K ⊆ neighborhood
+  smooth : ContDiffOn ℝ ∞ toFun neighborhood
+  invertible : ∀ x ∈ K, (toFun x).IsInvertible
+  intertwines : ∀ x ∈ K, Q x * toFun x = toFun x * P x
+
+private def Smale.DiskFraming.SmoothRangeTransportOn.refl {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] (K : Set E) (P : E → F →L[ℝ] F) :
+    Smale.DiskFraming.SmoothRangeTransportOn K P P
+    where
+  toFun _ := 1
+  neighborhood := Set.univ
+  open_neighborhood := isOpen_univ
+  contains := Set.subset_univ _
+  smooth := contDiffOn_const
+  invertible _ _ := ⟨ContinuousLinearEquiv.refl ℝ F, rfl⟩
+  intertwines _ _ := by rw [mul_one, one_mul]
+
+private def Smale.DiskFraming.SmoothRangeTransportOn.trans {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {K : Set E} {P Q R : E → F →L[ℝ] F}
+    (a : Smale.DiskFraming.SmoothRangeTransportOn K P Q)
+    (b : Smale.DiskFraming.SmoothRangeTransportOn K Q R) :
+    Smale.DiskFraming.SmoothRangeTransportOn K P R
+    where
+  toFun x := b.toFun x * a.toFun x
+  neighborhood := a.neighborhood ∩ b.neighborhood
+  open_neighborhood := a.open_neighborhood.inter b.open_neighborhood
+  contains := fun _ hx => ⟨a.contains hx, b.contains hx⟩
+  smooth := (b.smooth.mono Set.inter_subset_right).clm_comp (a.smooth.mono Set.inter_subset_left)
+  invertible x hx := (b.invertible x hx).comp (a.invertible x hx)
+  intertwines x
+    hx := by
+    calc
+      R x * (b.toFun x * a.toFun x) = (R x * b.toFun x) * a.toFun x := (mul_assoc _ _ _).symm
+      _ = (b.toFun x * Q x) * a.toFun x := by rw [b.intertwines x hx]
+      _ = b.toFun x * (Q x * a.toFun x) := (mul_assoc _ _ _)
+      _ = b.toFun x * (a.toFun x * P x) := by rw [a.intertwines x hx]
+      _ = (b.toFun x * a.toFun x) * P x := (mul_assoc _ _ _).symm
+
+private def Smale.DiskFraming.SmoothRangeTransportOn.symm {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {K : Set E} {P Q : E → F →L[ℝ] F}
+    [CompleteSpace F] (a : Smale.DiskFraming.SmoothRangeTransportOn K P Q) :
+    Smale.DiskFraming.SmoothRangeTransportOn K Q P
+    where
+  toFun x := (a.toFun x).inverse
+  neighborhood := a.neighborhood ∩ {x | (a.toFun x).IsInvertible}
+  open_neighborhood :=
+    a.smooth.continuousOn.isOpen_inter_preimage a.open_neighborhood ContinuousLinearEquiv.isOpen
+  contains := fun x hx => ⟨a.contains hx, a.invertible x hx⟩
+  smooth := by
+    intro x hx
+    exact
+      (hx.2.contDiffAt_map_inverse.comp x
+          (a.smooth.contDiffAt (a.open_neighborhood.mem_nhds hx.1))).contDiffWithinAt
+  invertible x hx := (a.invertible x hx).inverse
+  intertwines x
+    hx := by
+    apply ContinuousLinearMap.ext
+    intro v
+    change P x ((a.toFun x).inverse v) = (a.toFun x).inverse (Q x v)
+    apply (a.invertible x hx).injective
+    rw [(a.invertible x hx).self_apply_inverse]
+    have h := congrArg (fun L : F →L[ℝ] F => L ((a.toFun x).inverse v)) (a.intertwines x hx)
+    change Q x (a.toFun x ((a.toFun x).inverse v)) = a.toFun x (P x ((a.toFun x).inverse v)) at h
+    rw [(a.invertible x hx).self_apply_inverse] at h
+    exact h.symm
+
+private theorem
+    Smale.DiskFraming.SmoothRangeTransportOn.map_range {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {K : Set E} {P Q : E → F →L[ℝ] F}
+    (a : Smale.DiskFraming.SmoothRangeTransportOn K P Q) (x : E) (hx : x ∈ K) :
+    Submodule.map (a.toFun x).toLinearMap (P x).range = (Q x).range := by
+  rw [← LinearMap.range_comp]
+  have hlin :
+    (a.toFun x).toLinearMap.comp (P x).toLinearMap =
+      (Q x).toLinearMap.comp (a.toFun x).toLinearMap :=
+    congrArg ContinuousLinearMap.toLinearMap (a.intertwines x hx).symm
+  rw [hlin]
+  exact
+    LinearMap.range_comp_of_range_eq_top _
+      (LinearMap.range_eq_top.mpr (a.invertible x hx).surjective)
+
+private def
+    Smale.DiskFraming.SmoothRangeTransportOn.ofProjections {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {K : Set E} {P Q : E → F →L[ℝ] F}
+    (hP : ∀ x ∈ K, IsIdempotentElem (P x)) (hQ : ∀ x ∈ K, IsIdempotentElem (Q x)) {U V : Set E}
+    (hU : IsOpen U) (hV : IsOpen V) (hKU : K ⊆ U) (hKV : K ⊆ V) (hsP : ContDiffOn ℝ ∞ P U)
+    (hsQ : ContDiffOn ℝ ∞ Q V)
+    (hinv : ∀ x ∈ K, (NoExotic.projectionIntertwiner (P x) (Q x)).IsInvertible) :
+    Smale.DiskFraming.SmoothRangeTransportOn K P Q
+    where
+  toFun x := NoExotic.projectionIntertwiner (P x) (Q x)
+  neighborhood := U ∩ V
+  open_neighborhood := hU.inter hV
+  contains := fun _ hx => ⟨hKU hx, hKV hx⟩
+  smooth :=
+    ((hsQ.mono Set.inter_subset_right).clm_comp (hsP.mono Set.inter_subset_left)).add
+      ((contDiffOn_const.sub (hsQ.mono Set.inter_subset_right)).clm_comp
+        (contDiffOn_const.sub (hsP.mono Set.inter_subset_left)))
+  invertible := hinv
+  intertwines x hx := NoExotic.projectionIntertwiner_intertwines (P x) (Q x) (hP x hx) (hQ x hx)
+
+private theorem
+    NoExotic.isOpen_forall_compact {X Y : Type*} [TopologicalSpace X] [TopologicalSpace Y]
+    [CompactSpace Y] {R : X → Y → Prop} (ho : IsOpen {p : X × Y | R p.1 p.2}) :
+    IsOpen {x | ∀ y, R x y} := by
+  have hclosed := isClosedMap_fst_of_compactSpace _ ho.isClosed_compl
+  have heq : {x | ∀ y, R x y} = (Prod.fst '' {p : X × Y | ¬R p.1 p.2})ᶜ := by
+    ext x
+    constructor
+    · rintro h ⟨⟨x', y⟩, hn, he⟩
+      change x' = x at he
+      subst x'
+      exact hn (h y)
+    · intro h y
+      by_contra hn
+      exact h ⟨(x, y), hn, rfl⟩
+  rw [heq]
+  exact hclosed.isOpen_compl
+
+private def NoExotic.homotopyTransportDomain {F : Type*} [NormedAddCommGroup F] [NormedSpace ℝ F]
+    {M : Type*} {T : Type*} (P : T → M → F →L[ℝ] F) (s : T) : Set T :=
+  {t | ∀ x, (projectionIntertwiner (P s x) (P t x)).IsInvertible}
+
+private theorem
+    NoExotic.mem_homotopyTransportDomain {F : Type*} [NormedAddCommGroup F] [NormedSpace ℝ F]
+    {M : Type*} {T : Type*} (P : T → M → F →L[ℝ] F) (hP : ∀ t x, IsIdempotentElem (P t x))
+    (s : T) : s ∈ homotopyTransportDomain P s := by
+  intro x
+  rw [projectionIntertwiner_self _ (hP s x)]
+  exact ⟨ContinuousLinearEquiv.refl ℝ F, rfl⟩
+
+private theorem NoExotic.isOpen_continuousHomotopyTransportDomain {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [CompleteSpace F] {M T : Type*} [TopologicalSpace M] [CompactSpace M]
+    [TopologicalSpace T] (P : T → M → F →L[ℝ] F) (hc : Continuous (fun p : T × M ↦ P p.1 p.2))
+    (s : T) : IsOpen (homotopyTransportDomain P s) := by
+  have hp : Continuous (fun p : T × M ↦ P s p.2) :=
+    hc.comp (continuous_const.prodMk continuous_snd)
+  have hr : Continuous (fun p : T × M ↦ projectionIntertwiner (P s p.2) (P p.1 p.2)) :=
+    (hc.clm_comp hp).add ((continuous_const.sub hc).clm_comp (continuous_const.sub hp))
+  have hi : IsOpen {A : F →L[ℝ] F | A.IsInvertible} := ContinuousLinearEquiv.isOpen
+  exact isOpen_forall_compact (hi.preimage hr)
+
+private theorem Smale.DiskFraming.isOpen_transportOnClass {E F T : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [CompleteSpace F]
+    [TopologicalSpace T] {K : Set E} (hK : IsCompact K) (P : T → E → F →L[ℝ] F)
+    (hP : ∀ t x, x ∈ K → IsIdempotentElem (P t x))
+    (hc : Continuous (fun q : T × K => P q.1 q.2.1))
+    (hs : ∀ t, ∃ U : Set E, IsOpen U ∧ K ⊆ U ∧ ContDiffOn ℝ ∞ (P t) U) (s : T) :
+    IsOpen {t | Nonempty (SmoothRangeTransportOn K (P s) (P t))} := by
+  let : CompactSpace K := isCompact_iff_compactSpace.mp hK
+  let R (t : T) (x : K) := P t x.1
+  have hR (t : T) (x : K) : IsIdempotentElem (R t x) := hP t x.1 x.property
+  rw [isOpen_iff_mem_nhds]
+  rintro t ⟨a⟩
+  have hdom := NoExotic.isOpen_continuousHomotopyTransportDomain R hc t
+  have ht := NoExotic.mem_homotopyTransportDomain R hR t
+  apply Filter.mem_of_superset (hdom.mem_nhds ht)
+  intro u hu
+  obtain ⟨Ut, hUt, hKt, hst⟩ := hs t
+  obtain ⟨Uu, hUu, hKu, hsu⟩ := hs u
+  exact
+    ⟨a.trans
+        (SmoothRangeTransportOn.ofProjections (hP t) (hP u) hUt hUu hKt hKu hst hsu
+          (fun x hx => hu ⟨x, hx⟩))⟩
+
+private theorem
+    Smale.DiskFraming.isOpen_compl_transportOnClass {E F T : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [CompleteSpace F]
+    [TopologicalSpace T] {K : Set E} (hK : IsCompact K) (P : T → E → F →L[ℝ] F)
+    (hP : ∀ t x, x ∈ K → IsIdempotentElem (P t x))
+    (hc : Continuous (fun q : T × K => P q.1 q.2.1))
+    (hs : ∀ t, ∃ U : Set E, IsOpen U ∧ K ⊆ U ∧ ContDiffOn ℝ ∞ (P t) U) (s : T) :
+    IsOpen {t | ¬Nonempty (SmoothRangeTransportOn K (P s) (P t))} := by
+  let : CompactSpace K := isCompact_iff_compactSpace.mp hK
+  let R (t : T) (x : K) := P t x.1
+  have hR (t : T) (x : K) : IsIdempotentElem (R t x) := hP t x.1 x.property
+  rw [isOpen_iff_mem_nhds]
+  intro t ht
+  have hdom := NoExotic.isOpen_continuousHomotopyTransportDomain R hc t
+  have htmem := NoExotic.mem_homotopyTransportDomain R hR t
+  apply Filter.mem_of_superset (hdom.mem_nhds htmem)
+  rintro u hu ⟨a⟩
+  obtain ⟨Ut, hUt, hKt, hst⟩ := hs t
+  obtain ⟨Uu, hUu, hKu, hsu⟩ := hs u
+  exact
+    ht
+      ⟨a.trans
+          (SmoothRangeTransportOn.ofProjections (hP t) (hP u) hUt hUu hKt hKu hst hsu
+              (fun x hx => hu ⟨x, hx⟩)).symm⟩
+
+private theorem Smale.DiskFraming.nonempty_smoothRangeTransportOn_of_homotopy {E F T : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [CompleteSpace F] [TopologicalSpace T] {K : Set E} (hK : IsCompact K) (P : T → E → F →L[ℝ] F)
+    (hP : ∀ t x, x ∈ K → IsIdempotentElem (P t x))
+    (hc : Continuous (fun q : T × K => P q.1 q.2.1))
+    (hs : ∀ t, ∃ U : Set E, IsOpen U ∧ K ⊆ U ∧ ContDiffOn ℝ ∞ (P t) U) [PreconnectedSpace T]
+    (s t : T) : Nonempty (SmoothRangeTransportOn K (P s) (P t)) := by
+  let C : Set T := {u | Nonempty (SmoothRangeTransportOn K (P s) (P u))}
+  have hclosed : IsClosed C := by
+    simpa only [C, Set.compl_ofPred, Classical.not_not] using
+      (isOpen_compl_transportOnClass hK P hP hc hs s).isClosed_compl
+  have hclopen : IsClopen C := ⟨hclosed, isOpen_transportOnClass hK P hP hc hs s⟩
+  have hall : C = Set.univ := hclopen.eq_univ ⟨s, ⟨SmoothRangeTransportOn.refl K (P s)⟩⟩
+  have ht : t ∈ C := by rw [hall]; exact Set.mem_univ t
+  exact ht
+
+private theorem
+    Smale.DiskFraming.nonempty_transportOn_starConvex {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [CompleteSpace F] {K U : Set E}
+    (hK : IsCompact K) (hstar : StarConvex ℝ (0 : E) K) (hU : IsOpen U) (hKU : K ⊆ U)
+    (P : E → F →L[ℝ] F) (hP : ∀ x ∈ K, IsIdempotentElem (P x)) (hs : ContDiffOn ℝ ∞ P U) :
+    Nonempty (SmoothRangeTransportOn K (fun _ => P 0) P) := by
+  let Q (t : unitInterval) (x : E) := P ((t : ℝ) • x)
+  have hQ : ∀ t x, x ∈ K → IsIdempotentElem (Q t x) := fun t x hx =>
+    hP _ (hstar.smul_mem hx t.property.1 t.property.2)
+  have hmul : Continuous (fun q : unitInterval × K => (q.1 : ℝ) • (q.2 : E)) :=
+    (continuous_subtype_val.comp continuous_fst).smul (continuous_subtype_val.comp continuous_snd)
+  have hc : Continuous (fun q : unitInterval × K => Q q.1 q.2.1) :=
+    hs.continuousOn.comp_continuous hmul
+      (fun q => hKU (hstar.smul_mem q.2.property q.1.property.1 q.1.property.2))
+  have hslice : ∀ t, ∃ V : Set E, IsOpen V ∧ K ⊆ V ∧ ContDiffOn ℝ ∞ (Q t) V := by
+    intro t
+    let V : Set E := (fun x : E => (t : ℝ) • x) ⁻¹' U
+    have hV : IsOpen V := hU.preimage (continuous_const.smul continuous_id)
+    have hKV : K ⊆ V := fun x hx => hKU (hstar.smul_mem hx t.property.1 t.property.2)
+    exact ⟨V, hV, hKV, hs.comp (contDiff_const.smul contDiff_id).contDiffOn (fun _ hx => hx)⟩
+  have hstart : Q 0 = fun _ => P 0 := by
+    funext x
+    change P ((0 : ℝ) • x) = P 0
+    rw [zero_smul]
+  have hend : Q 1 = P := by
+    funext x
+    change P ((1 : ℝ) • x) = P x
+    rw [one_smul]
+  simpa only [hstart, hend] using
+    nonempty_smoothRangeTransportOn_of_homotopy hK Q hQ hc hslice 0 1
+
+private theorem
+    Smale.DiskFraming.exists_smooth_frame_near_starConvex {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [CompleteSpace F] {K U : Set E}
+    (hK : IsCompact K) (hstar : StarConvex ℝ (0 : E) K) (hU : IsOpen U) (hKU : K ⊆ U)
+    (P : E → F →L[ℝ] F) (hP : ∀ x ∈ K, IsIdempotentElem (P x)) (hs : ContDiffOn ℝ ∞ P U) :
+    ∃ V : Set E,
+      IsOpen V ∧
+        K ⊆ V ∧
+          ∃ A : E → (P 0).range →L[ℝ] F,
+            ContDiffOn ℝ ∞ A V ∧ ∀ x ∈ K, Function.Injective (A x) ∧ (A x).range = (P x).range := by
+  obtain ⟨a⟩ := nonempty_transportOn_starConvex hK hstar hU hKU P hP hs
+  let A (x : E) : (P 0).range →L[ℝ] F := (a.toFun x).comp (P 0).range.subtypeL
+  refine
+    ⟨a.neighborhood, a.open_neighborhood, a.contains, A, a.smooth.clm_comp contDiffOn_const, ?_⟩
+  intro x hx
+  refine ⟨(a.invertible x hx).injective.comp Subtype.val_injective, ?_⟩
+  change ((a.toFun x).toLinearMap.comp (P 0).range.subtype).range = (P x).range
+  rw [LinearMap.range_comp, Submodule.range_subtype]
+  exact a.map_range x hx
+
+private theorem Smale.DiskFraming.exists_smooth_frame_on_neighborhood_closedBall {E F : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [CompleteSpace F] {U : Set E} (hU : IsOpen U)
+    (hballU : Metric.closedBall (0 : E) 1 ⊆ U) (P : E → F →L[ℝ] F)
+    (hP : ∀ x ∈ U, IsIdempotentElem (P x)) (hs : ContDiffOn ℝ ∞ P U) :
+    ∃ V : Set E,
+      IsOpen V ∧
+        Metric.closedBall (0 : E) 1 ⊆ V ∧
+          V ⊆ U ∧
+            ∃ A : E → (P 0).range →L[ℝ] F,
+              ContDiffOn ℝ ∞ A V ∧
+                ∀ x ∈ V, Function.Injective (A x) ∧ (A x).range = (P x).range := by
+  obtain ⟨δ, hδ, hthick⟩ :=
+    (ProperSpace.isCompact_closedBall (0 : E) 1).exists_cthickening_subset_open hU hballU
+  have hbU : Metric.closedBall (0 : E) (δ + 1) ⊆ U := by
+    simpa only [cthickening_closedBall hδ.le zero_le_one] using hthick
+  have hr : 1 < δ + 1 := by linarith
+  obtain ⟨W, hW, hbW, A, hA, hArange⟩ :=
+    exists_smooth_frame_near_starConvex (ProperSpace.isCompact_closedBall (0 : E) (δ + 1))
+      ((convex_closedBall (0 : E) (δ + 1)).starConvex (Metric.mem_closedBall_self (by linarith)))
+      hU hbU P (fun x hx => hP x (hbU hx)) hs
+  refine
+    ⟨W ∩ Metric.ball 0 (δ + 1), hW.inter Metric.isOpen_ball, ?_, ?_, A,
+      hA.mono Set.inter_subset_left, ?_⟩
+  · intro x hx
+    exact
+      ⟨hbW (Metric.closedBall_subset_closedBall hr.le hx), Metric.closedBall_subset_ball hr hx⟩
+  · exact fun _ hx => hbU (Metric.ball_subset_closedBall hx.2)
+  · exact fun x hx => hArange x (Metric.ball_subset_closedBall hx.2)
+
+private theorem
+    Smale.NativeEuclideanEmbedding.exists_smooth_normalFrame_near_closedBall {E M D : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [NormedAddCommGroup D] [InnerProductSpace ℝ D]
+    [FiniteDimensional ℝ D] (e : Smale.NativeEuclideanEmbedding E M) {f : D → M}
+    (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f)
+    (hi : ∀ x ∈ Metric.closedBall (0 : D) 1, Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x))
+    (n : ℕ) (hcodim : Module.finrank ℝ D + n = Module.finrank ℝ E) :
+    ∃ V : Set D,
+      IsOpen V ∧
+        Metric.closedBall (0 : D) 1 ⊆ V ∧
+          ∃ A : D → EuclideanSpace ℝ (Fin n) →L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension),
+            ContDiffOn ℝ ∞ A V ∧
+              ∀ x ∈ V, Function.Injective (A x) ∧ (A x).range = e.diskNormalSpace f x := by
+  obtain ⟨U, hU, hKU, hsP, hP⟩ := e.exists_open_diskNormalProjection hf hi
+  have hidem : ∀ x ∈ U, IsIdempotentElem (e.diskNormalProjection f x) := by
+    intro x hx
+    rw [hP x hx]
+    exact (e.diskNormalSpace f x).isIdempotentElem_starProjection
+  obtain ⟨V, hV, hKV, hVU, A, hA, hAi⟩ :=
+    Smale.DiskFraming.exists_smooth_frame_on_neighborhood_closedBall hU hKU
+      (e.diskNormalProjection f) hidem hsP
+  have hz : (0 : D) ∈ Metric.closedBall (0 : D) 1 := Metric.mem_closedBall_self zero_le_one
+  have hr : (e.diskNormalProjection f 0).range = e.diskNormalSpace f 0 := by
+    rw [hP 0 (hKU hz), Submodule.range_starProjection]
+  have hdim : Module.finrank ℝ (e.diskNormalSpace f 0) = n := by
+    have h := e.finrank_diskTangent_add_normal hf (hi 0 hz)
+    omega
+  have hcenter : Module.finrank ℝ (e.diskNormalProjection f 0).range = n :=
+    (congrArg
+          (fun S : Submodule ℝ (EuclideanSpace ℝ (Fin e.ambientDimension)) => Module.finrank ℝ S)
+          hr).trans
+      hdim
+  let φ : EuclideanSpace ℝ (Fin n) ≃L[ℝ] (e.diskNormalProjection f 0).range :=
+    ContinuousLinearEquiv.ofFinrankEq (finrank_euclideanSpace_fin.trans hcenter.symm)
+  refine
+    ⟨V, hV, hKV, fun x => (A x).comp φ.toContinuousLinearMap, hA.clm_comp contDiffOn_const, ?_⟩
+  intro x hx
+  refine ⟨((hAi x hx).1).comp φ.injective, ?_⟩
+  calc
+    ((A x).comp φ.toContinuousLinearMap).range = (A x).range :=
+      LinearMap.range_comp_of_range_eq_top _ (LinearMap.range_eq_top.mpr φ.surjective)
+    _ = (e.diskNormalProjection f x).range := (hAi x hx).2
+    _ = e.diskNormalSpace f x := by rw [hP x (hVU hx), Submodule.range_starProjection]
+
+private def
+    Smale.DiskFraming.normalSplitEquiv {D Z F : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D]
+    [FiniteDimensional ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z]
+    [NormedAddCommGroup F] [InnerProductSpace ℝ F] (L : D →L[ℝ] F) (A : Z →L[ℝ] F)
+    {V : Submodule ℝ F} (hL : Function.Injective L) (hA : Function.Injective A)
+    (hLV : L.range ≤ V) (hAr : A.range = L.rangeᗮ ⊓ V) : (D × Z) ≃L[ℝ] V := by
+  let a : D × Z →ₗ[ℝ] F := L.toLinearMap.coprod A.toLinearMap
+  have har : a.range = V := by
+    rw [LinearMap.range_coprod, hAr]
+    exact Submodule.sup_orthogonal_inf_of_hasOrthogonalProjection hLV
+  have had : Disjoint L.range A.range := by
+    rw [hAr]
+    exact L.range.orthogonal_disjoint.mono_right inf_le_left
+  have hai : Function.Injective a := by
+    rw [← LinearMap.ker_eq_bot, LinearMap.ker_coprod_of_disjoint_range _ _ had,
+      LinearMap.ker_eq_bot.mpr hL, LinearMap.ker_eq_bot.mpr hA, Submodule.prod_bot]
+  let b : D × Z →ₗ[ℝ] V := a.codRestrict V (fun q => har ▸ LinearMap.mem_range_self a q)
+  have hbi : Function.Injective b := fun _ _ h => hai (congrArg Subtype.val h)
+  have hbs : Function.Surjective b := by
+    intro v
+    have hv : (v : F) ∈ a.range := har.symm ▸ v.property
+    obtain ⟨q, hq⟩ := hv
+    exact ⟨q, Subtype.ext hq⟩
+  exact (LinearEquiv.ofBijective b ⟨hbi, hbs⟩).toContinuousLinearEquiv
+
+private def
+    Smale.NativeEuclideanEmbedding.diskTangentNormalEquiv {E M D : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [NormedAddCommGroup D]
+    [InnerProductSpace ℝ D] [FiniteDimensional ℝ D] (e : Smale.NativeEuclideanEmbedding E M)
+    {f : D → M} (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f) {x : D}
+    (hi : Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x)) {n : ℕ}
+    (A : EuclideanSpace ℝ (Fin n) →L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension))
+    (hA : Function.Injective A) (hAr : A.range = e.diskNormalSpace f x) :
+    (D × EuclideanSpace ℝ (Fin n)) ≃L[ℝ] e.tangentImage (f x) :=
+  Smale.DiskFraming.normalSplitEquiv (fderiv ℝ (e.toFun ∘ f) x) A (e.injective_fderiv_comp hf hi)
+    hA (e.diskTangentImage_le hf x) hAr
+
+private def Smale.DiskFraming.displacement {D Z F : Type*} [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (H : D → F) (A : D → Z →L[ℝ] F) (p : D × Z) : F :=
+  H p.1 + A p.1 p.2
+
+private theorem Smale.DiskFraming.displacement_zero {D Z F : Type*} [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [NormedAddCommGroup F] [NormedSpace ℝ F] (H : D → F) (A : D → Z →L[ℝ] F)
+    (x : D) : displacement H A (x, 0) = H x := by simp [displacement]
+
+private theorem Smale.DiskFraming.contDiffOn_displacement {D Z F : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {H : D → F} {A : D → Z →L[ℝ] F} {V : Set D} (hH : ContDiff ℝ ∞ H)
+    (hA : ContDiffOn ℝ ∞ A V) : ContDiffOn ℝ ∞ (displacement H A) (V ×ˢ Set.univ) :=
+  (hH.comp contDiff_fst).contDiffOn.add
+    ((hA.comp contDiffOn_fst (fun _ hp => hp.1)).clm_apply contDiffOn_snd)
+
+private theorem
+    Smale.DiskFraming.hasFDerivAt_displacement_zero {D Z F : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {H : D → F} {A : D → Z →L[ℝ] F} {x : D} (hH : ContDiffAt ℝ ∞ H x)
+    (hA : ContDiffAt ℝ ∞ A x) :
+    HasFDerivAt (displacement H A) ((fderiv ℝ H x).coprod (A x)) (x, 0) := by
+  have hfst : HasFDerivAt (Prod.fst : D × Z → D) (ContinuousLinearMap.fst ℝ D Z) (x, 0) :=
+    hasFDerivAt_fst
+  have hsnd : HasFDerivAt (Prod.snd : D × Z → Z) (ContinuousLinearMap.snd ℝ D Z) (x, 0) :=
+    hasFDerivAt_snd
+  have h₁ :
+    HasFDerivAt (fun p : D × Z => H p.1) ((fderiv ℝ H x).comp (ContinuousLinearMap.fst ℝ D Z))
+      (x, 0) :=
+    (hH.differentiableAt (by simp)).hasFDerivAt.comp (x, 0) hfst
+  have h₂ :
+    HasFDerivAt (fun p : D × Z => A p.1) ((fderiv ℝ A x).comp (ContinuousLinearMap.fst ℝ D Z))
+      (x, 0) :=
+    (hA.differentiableAt (by simp)).hasFDerivAt.comp (x, 0) hfst
+  have h := h₁.add (h₂.clm_apply hsnd)
+  apply h.congr_fderiv
+  apply ContinuousLinearMap.ext
+  intro q
+  change fderiv ℝ H x q.1 + (A x q.2 + (fderiv ℝ A x q.1) 0) = fderiv ℝ H x q.1 + A x q.2
+  rw [map_zero, add_zero]
+
+private def Smale.NativeEuclideanEmbedding.SmoothRetraction.diskCoordinates {E M D : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction) {n : ℕ} (f : D → M)
+    (A : D → EuclideanSpace ℝ (Fin n) →L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension)) :
+    D × EuclideanSpace ℝ (Fin n) → M :=
+  r.toFun ∘ Smale.DiskFraming.displacement (e.toFun ∘ f) A
+
+private def Smale.NativeEuclideanEmbedding.SmoothRetraction.diskCoordinateDomain {E M D : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction) {n : ℕ} (f : D → M)
+    (A : D → EuclideanSpace ℝ (Fin n) →L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension))
+    (V : Set D) : Set (D × EuclideanSpace ℝ (Fin n)) :=
+  (V ×ˢ Set.univ) ∩ Smale.DiskFraming.displacement (e.toFun ∘ f) A ⁻¹' r.domain
+
+private theorem Smale.NativeEuclideanEmbedding.SmoothRetraction.diskCoordinates_zero {E M D : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction) {n : ℕ} (f : D → M)
+    (A : D → EuclideanSpace ℝ (Fin n) →L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension)) (x : D) :
+    r.diskCoordinates f A (x, 0) = f x := by
+  rw [diskCoordinates, Function.comp_apply, Smale.DiskFraming.displacement_zero]
+  exact r.retract (f x)
+
+private theorem Smale.NativeEuclideanEmbedding.SmoothRetraction.isOpen_diskCoordinateDomain
+    {E M D : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [NormedAddCommGroup D] [InnerProductSpace ℝ D]
+    {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction) {n : ℕ} {f : D → M}
+    (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f)
+    {A : D → EuclideanSpace ℝ (Fin n) →L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension)} {V : Set D}
+    (hV : IsOpen V) (hA : ContDiffOn ℝ ∞ A V) : IsOpen (r.diskCoordinateDomain f A V) := by
+  have hc :=
+    (Smale.DiskFraming.contDiffOn_displacement (e.smooth.comp hf).contDiff hA).continuousOn
+  exact hc.isOpen_inter_preimage (hV.prod isOpen_univ) r.open_domain
+
+private theorem Smale.NativeEuclideanEmbedding.SmoothRetraction.zero_mem_diskCoordinateDomain
+    {E M D : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction) {n : ℕ}
+    (f : D → M) (A : D → EuclideanSpace ℝ (Fin n) →L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension))
+    {V : Set D} {x : D} (hx : x ∈ V) : (x, 0) ∈ r.diskCoordinateDomain f A V := by
+  refine ⟨⟨hx, Set.mem_univ _⟩, ?_⟩
+  change Smale.DiskFraming.displacement (e.toFun ∘ f) A (x, 0) ∈ r.domain
+  rw [Smale.DiskFraming.displacement_zero]
+  exact r.contains ⟨f x, rfl⟩
+
+private theorem Smale.NativeEuclideanEmbedding.SmoothRetraction.contMDiffOn_diskCoordinates
+    {E M D : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [NormedAddCommGroup D] [InnerProductSpace ℝ D]
+    {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction) {n : ℕ} {f : D → M}
+    (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f)
+    {A : D → EuclideanSpace ℝ (Fin n) →L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension)} {V : Set D}
+    (hA : ContDiffOn ℝ ∞ A V) :
+    ContMDiffOn 𝓘(ℝ, D × EuclideanSpace ℝ (Fin n)) 𝓘(ℝ, E) ∞ (r.diskCoordinates f A)
+      (r.diskCoordinateDomain f A V) :=
+  r.smooth.comp
+    ((Smale.DiskFraming.contDiffOn_displacement (e.smooth.comp hf).contDiff hA).contMDiffOn.mono
+      Set.inter_subset_left)
+    (fun _ hp => hp.2)
+
+private theorem Smale.NativeEuclideanEmbedding.SmoothRetraction.mfderiv_diskCoordinates_zero
+    {E M D : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [NormedAddCommGroup D] [InnerProductSpace ℝ D]
+    {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction) {n : ℕ} {f : D → M}
+    (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f)
+    {A : D → EuclideanSpace ℝ (Fin n) →L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension)} {x : D}
+    (hA : ContDiffAt ℝ ∞ A x) :
+    mfderiv 𝓘(ℝ, D × EuclideanSpace ℝ (Fin n)) 𝓘(ℝ, E) (r.diskCoordinates f A) (x, 0) =
+      (mfderiv (𝓡 e.ambientDimension) 𝓘(ℝ, E) r.toFun (e.toFun (f x))).comp
+        ((fderiv ℝ (e.toFun ∘ f) x).coprod (A x)) := by
+  have hd :=
+    Smale.DiskFraming.hasFDerivAt_displacement_zero (e.smooth.comp hf).contDiff.contDiffAt hA
+  have hr :
+    MDifferentiableAt (𝓡 e.ambientDimension) 𝓘(ℝ, E) r.toFun
+      (Smale.DiskFraming.displacement (e.toFun ∘ f) A (x, 0)) := by
+    rw [Smale.DiskFraming.displacement_zero]
+    exact
+      (r.smooth.contMDiffAt (r.open_domain.mem_nhds (r.contains ⟨f x, rfl⟩))).mdifferentiableAt
+        (by simp)
+  rw [diskCoordinates, mfderiv_comp (x, 0) hr hd.differentiableAt.mdifferentiableAt,
+    mfderiv_eq_fderiv, hd.fderiv, Smale.DiskFraming.displacement_zero]
+  rfl
+
+private theorem
+    Smale.NativeEuclideanEmbedding.SmoothRetraction.isInvertible_mfderiv_diskCoordinates_zero
+    {E M D : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [NormedAddCommGroup D] [InnerProductSpace ℝ D]
+    [FiniteDimensional ℝ D] {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction)
+    {n : ℕ} {f : D → M} (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f)
+    {A : D → EuclideanSpace ℝ (Fin n) →L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension)} {x : D}
+    (hA : ContDiffAt ℝ ∞ A x) (hi : Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x))
+    (hAi : Function.Injective (A x)) (hAr : (A x).range = e.diskNormalSpace f x) :
+    (mfderiv 𝓘(ℝ, D × EuclideanSpace ℝ (Fin n)) 𝓘(ℝ, E) (r.diskCoordinates f A)
+        (x, 0)).IsInvertible := by
+  let L := e.diskTangentNormalEquiv hf hi (A x) hAi hAr
+  let T := L.trans (e.tangentImageEquiv (f x)).symm
+  refine ⟨T, ?_⟩
+  apply ContinuousLinearMap.ext
+  intro q
+  rw [r.mfderiv_diskCoordinates_zero hf hA]
+  apply e.injective_mvfderiv (f x)
+  have hleft := congrArg Subtype.val ((e.tangentImageEquiv (f x)).apply_symm_apply (L q))
+  exact hleft.trans (r.embedding_derivative_retract (L q).property).symm
+
+private theorem
+    Smale.NativeEuclideanEmbedding.SmoothRetraction.isLocalDiffeomorphAt_diskCoordinates_zero
+    {E M D : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [NormedAddCommGroup D]
+    [InnerProductSpace ℝ D] [FiniteDimensional ℝ D] {e : Smale.NativeEuclideanEmbedding E M}
+    (r : e.SmoothRetraction) {n : ℕ} {f : D → M} (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f)
+    {A : D → EuclideanSpace ℝ (Fin n) →L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension)} {V : Set D}
+    (hV : IsOpen V) (hA : ContDiffOn ℝ ∞ A V) {x : D} (hx : x ∈ V)
+    (hi : Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x)) (hAi : Function.Injective (A x))
+    (hAr : (A x).range = e.diskNormalSpace f x) :
+    IsLocalDiffeomorphAt 𝓘(ℝ, D × EuclideanSpace ℝ (Fin n)) 𝓘(ℝ, E) ∞ (r.diskCoordinates f A)
+      (x, 0) :=
+  Smale.isLocalDiffeomorphAt_of_contMDiffOn (r.isOpen_diskCoordinateDomain hf hV hA)
+    (r.zero_mem_diskCoordinateDomain f A hx) (r.contMDiffOn_diskCoordinates hf hA)
+    (r.isInvertible_mfderiv_diskCoordinates_zero hf (hA.contDiffAt (hV.mem_nhds hx)) hi hAi hAr)
+
+public
+theorem Smale.DiskFraming.exists_pos_prod_closedBall_subset {D Z : Type*} [TopologicalSpace D]
+    [NormedAddCommGroup Z] {K : Set D} {U : Set (D × Z)} (hK : IsCompact K) (hU : IsOpen U)
+    (hKU : K ×ˢ {(0 : Z)} ⊆ U) : ∃ ε : ℝ, 0 < ε ∧ K ×ˢ Metric.closedBall (0 : Z) ε ⊆ U := by
+  obtain ⟨A, B, -, hB, hKA, hzeroB, hAB⟩ :=
+    generalized_tube_lemma hK (isCompact_singleton (x := (0 : Z))) hU hKU
+  obtain ⟨ε, hε, hball⟩ :=
+    Metric.nhds_basis_closedBall.mem_iff.mp (hB.mem_nhds (hzeroB (Set.mem_singleton (0 : Z))))
+  refine ⟨ε, hε, ?_⟩
+  rintro ⟨x, z⟩ ⟨hx, hz⟩
+  exact hAB ⟨hKA hx, hball hz⟩
+
+private theorem Smale.NativeEuclideanEmbedding.SmoothRetraction.exists_diskTubularNeighborhood
+    {E M D : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    [NormedAddCommGroup D] [InnerProductSpace ℝ D] [FiniteDimensional ℝ D]
+    {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction) {n : ℕ} {f : D → M}
+    (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f) {K V : Set D} (hK : IsCompact K) (hV : IsOpen V)
+    (hKV : K ⊆ V) (hinj : Set.InjOn f K)
+    (hi : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x))
+    {A : D → EuclideanSpace ℝ (Fin n) →L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension)}
+    (hA : ContDiffOn ℝ ∞ A V) (hAi : ∀ x ∈ K, Function.Injective (A x))
+    (hAr : ∀ x ∈ K, (A x).range = e.diskNormalSpace f x) :
+    ∃ Φ :
+      PartialDiffeomorph 𝓘(ℝ, D × EuclideanSpace ℝ (Fin n)) 𝓘(ℝ, E) (D × EuclideanSpace ℝ (Fin n))
+        M ∞,
+      K ×ˢ {(0 : EuclideanSpace ℝ (Fin n))} ⊆ Φ.source ∧
+        Φ.source ⊆ r.diskCoordinateDomain f A V ∧
+          (Φ : D × EuclideanSpace ℝ (Fin n) → M) = r.diskCoordinates f A := by
+  have hzeroInj : Set.InjOn (r.diskCoordinates f A) (K ×ˢ {(0 : EuclideanSpace ℝ (Fin n))}) := by
+    rintro ⟨x, v⟩ ⟨hx, hv⟩ ⟨y, w⟩ ⟨hy, hw⟩ hxy
+    have hv0 : v = 0 := hv
+    have hw0 : w = 0 := hw
+    subst v
+    subst w
+    rw [r.diskCoordinates_zero, r.diskCoordinates_zero] at hxy
+    exact Prod.ext (hinj hx hy hxy) rfl
+  have hlocal :
+    ∀ p ∈ K ×ˢ {(0 : EuclideanSpace ℝ (Fin n))},
+      IsLocalDiffeomorphAt 𝓘(ℝ, D × EuclideanSpace ℝ (Fin n)) 𝓘(ℝ, E) ∞ (r.diskCoordinates f A)
+        p := by
+    rintro ⟨x, v⟩ ⟨hx, hv⟩
+    have hv0 : v = 0 := hv
+    subst v
+    exact
+      r.isLocalDiffeomorphAt_diskCoordinates_zero hf hV hA (hKV hx) (hi x hx) (hAi x hx)
+        (hAr x hx)
+  apply
+    Smale.exists_partialDiffeomorph_near_compact (hK.prod isCompact_singleton) hzeroInj hlocal
+      (r.isOpen_diskCoordinateDomain hf hV hA)
+  rintro ⟨x, v⟩ ⟨hx, hv⟩
+  have hv0 : v = 0 := hv
+  subst v
+  exact r.zero_mem_diskCoordinateDomain f A (hKV hx)
+
+private theorem Smale.exists_tubularNeighborhood_in_open_of_embedded_closedBall {E M D : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [NormedAddCommGroup D] [InnerProductSpace ℝ D] [FiniteDimensional ℝ D] {f : D → M}
+    (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f) (hinj : Set.InjOn f (Metric.closedBall (0 : D) 1))
+    (hi : ∀ x ∈ Metric.closedBall (0 : D) 1, Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x))
+    (n : ℕ) (hcodim : Module.finrank ℝ D + n = Module.finrank ℝ E) {O : Set M} (hO : IsOpen O)
+    (hfO : Set.MapsTo f (Metric.closedBall (0 : D) 1) O) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∃ Φ :
+          PartialDiffeomorph 𝓘(ℝ, D × EuclideanSpace ℝ (Fin n)) 𝓘(ℝ, E)
+            (D × EuclideanSpace ℝ (Fin n)) M ∞,
+          Metric.closedBall (0 : D) 1 ×ˢ Metric.closedBall 0 ε ⊆ Φ.source ∧
+            (∀ x ∈ Metric.closedBall (0 : D) 1, Φ (x, 0) = f x) ∧ Φ.target ⊆ O := by
+  let : Nonempty M := ⟨f 0⟩
+  obtain ⟨e⟩ := nonempty_nativeEuclideanEmbedding (E := E) (M := M)
+  obtain ⟨r⟩ := e.nonempty_smoothRetraction
+  obtain ⟨V, hV, hKV, A, hA, hframe⟩ := e.exists_smooth_normalFrame_near_closedBall hf hi n hcodim
+  obtain ⟨Φ, hzero, -, hΦ⟩ :=
+    r.exists_diskTubularNeighborhood hf (ProperSpace.isCompact_closedBall 0 1) hV hKV hinj hi hA
+      (fun x hx => (hframe x (hKV hx)).1) (fun x hx => (hframe x (hKV hx)).2)
+  let W := Φ.source ∩ Φ ⁻¹' O
+  have hW : IsOpen W := Φ.contMDiffOn_toFun.continuousOn.isOpen_inter_preimage Φ.open_source hO
+  have hWloc : IsLocalDiffeomorphOn 𝓘(ℝ, D × EuclideanSpace ℝ (Fin n)) 𝓘(ℝ, E) ∞ Φ W := fun p =>
+    ⟨Φ, p.property.1, fun _ _ => rfl⟩
+  let Ψ :=
+    partialDiffeomorphOfInjectiveLocal hW (Φ.toPartialEquiv.injOn.mono Set.inter_subset_left)
+      hWloc
+  have hzeroΨ : Metric.closedBall (0 : D) 1 ×ˢ {(0 : EuclideanSpace ℝ (Fin n))} ⊆ Ψ.source := by
+    rintro ⟨x, v⟩ ⟨hx, hv⟩
+    have hv0 : v = 0 := hv
+    subst v
+    refine ⟨hzero ⟨hx, rfl⟩, ?_⟩
+    change Φ (x, 0) ∈ O
+    rw [hΦ, r.diskCoordinates_zero]
+    exact hfO hx
+  obtain ⟨ε, hε, hprod⟩ :=
+    DiskFraming.exists_pos_prod_closedBall_subset (ProperSpace.isCompact_closedBall 0 1)
+      Ψ.open_source hzeroΨ
+  refine ⟨ε, hε, Ψ, hprod, ?_, ?_⟩
+  · intro x _
+    change Φ (x, 0) = f x
+    rw [hΦ, r.diskCoordinates_zero]
+  · change Φ '' W ⊆ O
+    rintro _ ⟨p, hp, rfl⟩
+    exact hp.2
+
+private theorem Smale.RegularLevel.exists_unitHeightField {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} {b : ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    ∃ V : (x : M) → TangentSpace 𝓘(ℝ, E) x,
+      ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+        ∀ x : { x : M // f x = b }, mvfderiv 𝓘(ℝ, E) f (x : M) (V x) = 1 := by
+  have hband : ∀ x, f x ∈ Set.Icc b b → x ∉ Smale.ManifoldMorse.criticalPoints E f := fun x hx =>
+    hreg x (le_antisymm hx.2 hx.1)
+  obtain ⟨φ, W, -, -, hW, hφ, V, hV, hheight⟩ :=
+    Smale.FlowConstruction.exists_regularBandField hf hband
+  refine ⟨V, hV, ?_⟩
+  intro x
+  exact (hheight x).trans (hφ (hW (by rw [x.property]; exact ⟨le_rfl, le_rfl⟩)))
+
+private theorem Smale.RegularLevel.exists_transverseCollar {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} {b : ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    [Nonempty { x : M // f x = b }] :
+    letI := chartedSpace hf hreg
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∃ Φ :
+          PartialDiffeomorph (𝓘(ℝ, Model E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) ({ x : M // f x = b } × ℝ) M ∞,
+          (Set.univ : Set { x : M // f x = b }) ×ˢ Metric.closedBall (0 : ℝ) ε ⊆ Φ.source ∧
+            (∀ x : { x : M // f x = b }, Φ (x, 0) = x) ∧
+              ∀ x : { x : M // f x = b }, HasDerivAt (fun t : ℝ => f (Φ (x, t))) 1 0 := by
+  let _ := chartedSpace hf hreg
+  let _ := isManifold hf hreg
+  let _ : CompactSpace { x : M // f x = b } :=
+    isCompact_iff_compactSpace.mp (isClosed_eq hf.continuous continuous_const).isCompact
+  let _ : Nonempty M := Nonempty.map (fun x : { x : M // f x = b } => (x : M)) inferInstance
+  obtain ⟨e⟩ := Smale.nonempty_nativeEuclideanEmbedding (E := E) (M := M)
+  obtain ⟨r⟩ := e.nonempty_smoothRetraction
+  obtain ⟨V, hV, hunit⟩ := exists_unitHeightField hf hreg
+  let K : Set ({ x : M // f x = b } × ℝ) := Set.univ ×ˢ {(0 : ℝ)}
+  have hK : IsCompact K := isCompact_univ.prod isCompact_singleton
+  have hinj : Set.InjOn (transverseCoordinates r V) K := by
+    rintro ⟨x, s⟩ ⟨-, hs⟩ ⟨y, t⟩ ⟨-, ht⟩ hxy
+    have hs0 : s = 0 := hs
+    have ht0 : t = 0 := ht
+    subst s
+    subst t
+    rw [transverseCoordinates_zero r V x, transverseCoordinates_zero r V y] at hxy
+    exact Prod.ext (Subtype.ext hxy) rfl
+  have hloc :
+    ∀ z ∈ K,
+      IsLocalDiffeomorphAt (𝓘(ℝ, Model E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) ∞ (transverseCoordinates r V) z :=
+    by
+    rintro ⟨x, t⟩ ⟨-, ht⟩
+    have ht0 : t = 0 := ht
+    subst t
+    exact isLocalDiffeomorphAt_transverseCoordinates_zero r V hf hreg hV x (hunit x)
+  have hKD : K ⊆ transverseCoordinateDomain r V := by
+    rintro ⟨x, t⟩ ⟨-, ht⟩
+    have ht0 : t = 0 := ht
+    subst t
+    exact zero_mem_transverseCoordinateDomain r V x
+  obtain ⟨Φ, hKΦ, -, heq⟩ :=
+    Smale.exists_partialDiffeomorph_near_compact hK hinj hloc
+      (isOpen_transverseCoordinateDomain r V hf hreg hV) hKD
+  obtain ⟨ε, hε, hsource⟩ :=
+    Smale.DiskFraming.exists_pos_prod_closedBall_subset isCompact_univ Φ.open_source hKΦ
+  refine ⟨ε, hε, Φ, hsource, ?_, ?_⟩
+  · intro x
+    exact (congrFun heq (x, 0)).trans (transverseCoordinates_zero r V x)
+  · intro x
+    have hh : (fun t : ℝ => f (Φ (x, t))) = fun t : ℝ => f (transverseCoordinates r V (x, t)) :=
+      funext (fun t => congrArg f (congrFun heq (x, t)))
+    rw [hh]
+    exact hasDerivAt_height_transverseCoordinates_zero r V hf hreg hV x (hunit x)
+
+private theorem Smale.RegularLevel.exists_heightBand_subset_open {X : Type*} [TopologicalSpace X]
+    [CompactSpace X] {g : X → ℝ} (hg : Continuous g) {a : ℝ} {U : Set X} (hU : IsOpen U)
+    (hlevel : ∀ x, g x = a → x ∈ U) : ∃ δ : ℝ, 0 < δ ∧ g ⁻¹' Metric.ball a δ ⊆ U := by
+  have hclosed : IsClosed (g '' Uᶜ) := (hU.isClosed_compl.isCompact.image hg).isClosed
+  have ha : a ∉ g '' Uᶜ := by
+    rintro ⟨x, hx, hxa⟩
+    exact hx (hlevel x hxa)
+  obtain ⟨δ, hδ, hball⟩ := Metric.isOpen_iff.mp hclosed.isOpen_compl a ha
+  refine ⟨δ, hδ, ?_⟩
+  intro x hx
+  by_contra hnot
+  exact hball hx ⟨x, hnot, rfl⟩
+
+private theorem Smale.RegularLevel.exists_heightCollar {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} {b : ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    [Nonempty { x : M // f x = b }] :
+    letI := chartedSpace hf hreg
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∃ Ψ :
+          PartialDiffeomorph (𝓘(ℝ, Model E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) ({ x : M // f x = b } × ℝ) M ∞,
+          (Set.univ : Set { x : M // f x = b }) ×ˢ Metric.closedBall (0 : ℝ) ε ⊆ Ψ.source ∧
+            (∀ x : { x : M // f x = b }, Ψ (x, 0) = x) ∧ ∀ z ∈ Ψ.source, f (Ψ z) = b + z.2 := by
+  let _ := chartedSpace hf hreg
+  let _ := isManifold hf hreg
+  let _ : CompactSpace { x : M // f x = b } :=
+    isCompact_iff_compactSpace.mp (isClosed_eq hf.continuous continuous_const).isCompact
+  obtain ⟨ε, hε, Φ, hsource, hzero, hderiv⟩ := exists_transverseCollar hf hreg
+  let H : { x : M // f x = b } × ℝ → ℝ := fun z => f (Φ z) - b
+  have hH : ContMDiffOn (𝓘(ℝ, Model E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, ℝ) ∞ H Φ.source :=
+    (hf.comp_contMDiffOn Φ.contMDiffOn_toFun).sub contMDiff_const.contMDiffOn
+  have hH0 (x : { x : M // f x = b }) : H (x, 0) = 0 := by
+    change f (Φ (x, 0)) - b = 0
+    rw [hzero x, x.property, sub_self]
+  have hzeroSource (x : { x : M // f x = b }) : (x, 0) ∈ Φ.source :=
+    hsource ⟨Set.mem_univ x, Metric.mem_closedBall_self hε.le⟩
+  have hHt (x : { x : M // f x = b }) : HasDerivAt (fun t : ℝ => H (x, t)) 1 0 :=
+    (hderiv x).sub_const b
+  obtain ⟨χ, hKχ, -, hχ⟩ :=
+    Smale.CollarHeight.exists_heightChangeChart Φ.open_source hH hH0 hzeroSource hHt
+  have hχzero (x : { x : M // f x = b }) : χ (x, 0) = (x, 0) :=
+    (congrFun hχ (x, 0)).trans (Smale.CollarHeight.heightChange_zero hH0 x)
+  have hχtarget (x : { x : M // f x = b }) : (x, 0) ∈ χ.target := by
+    rw [← hχzero x]
+    exact χ.map_source' (hKχ ⟨Set.mem_univ x, rfl⟩)
+  have hχinv (x : { x : M // f x = b }) : χ.symm (x, 0) = (x, 0) := by
+    have hh : χ.symm (χ (x, 0)) = (x, 0) := χ.left_inv' (hKχ ⟨Set.mem_univ x, rfl⟩)
+    rwa [hχzero x] at hh
+  let Ψ := χ.symm.trans Φ
+  have hzeroΨ : (Set.univ : Set { x : M // f x = b }) ×ˢ {(0 : ℝ)} ⊆ Ψ.source := by
+    rintro ⟨x, t⟩ ⟨-, ht⟩
+    have ht0 : t = 0 := ht
+    subst t
+    refine ⟨hχtarget x, ?_⟩
+    change χ.symm (x, 0) ∈ Φ.source
+    rw [hχinv x]
+    exact hzeroSource x
+  obtain ⟨δ, hδ, hproduct⟩ :=
+    Smale.DiskFraming.exists_pos_prod_closedBall_subset isCompact_univ Ψ.open_source hzeroΨ
+  refine ⟨δ, hδ, Ψ, hproduct, ?_, ?_⟩
+  · intro x
+    change Φ (χ.symm (x, 0)) = x
+    rw [hχinv x, hzero x]
+  · intro z hz
+    have hheight : H (χ.symm z) = z.2 := by
+      calc
+        H (χ.symm z) = (χ (χ.symm z)).2 := (congrArg Prod.snd (congrFun hχ (χ.symm z))).symm
+        _ = z.2 := congrArg Prod.snd (χ.right_inv' hz.1)
+    change f (Φ (χ.symm z)) = b + z.2
+    change f (Φ (χ.symm z)) - b = z.2 at hheight
+    linarith
+
+private theorem
+    Smale.RegularLevel.exists_heightCollar_with_band {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} {b : ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    [Nonempty { x : M // f x = b }] :
+    letI := chartedSpace hf hreg
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∃ Ψ :
+          PartialDiffeomorph (𝓘(ℝ, Model E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) ({ x : M // f x = b } × ℝ) M ∞,
+          (Set.univ : Set { x : M // f x = b }) ×ˢ Metric.closedBall (0 : ℝ) ε ⊆ Ψ.source ∧
+            (∀ x : { x : M // f x = b }, Ψ (x, 0) = x) ∧
+              (∀ z ∈ Ψ.source, f (Ψ z) = b + z.2) ∧ f ⁻¹' Metric.ball b ε ⊆ Ψ.target := by
+  let _ := chartedSpace hf hreg
+  obtain ⟨ε, hε, Ψ, hsource, hzero, hheight⟩ := exists_heightCollar hf hreg
+  have hlevel : ∀ x, f x = b → x ∈ Ψ.target := by
+    intro x hx
+    let y : { x : M // f x = b } := ⟨x, hx⟩
+    have hmem : Ψ (y, 0) ∈ Ψ.target :=
+      Ψ.map_source' (hsource ⟨Set.mem_univ y, Metric.mem_closedBall_self hε.le⟩)
+    have hy : Ψ (y, 0) = x := hzero y
+    exact hy ▸ hmem
+  obtain ⟨δ, hδ, hband⟩ := exists_heightBand_subset_open hf.continuous Ψ.open_target hlevel
+  refine ⟨Min.min ε δ, lt_min hε hδ, Ψ, ?_, hzero, hheight, ?_⟩
+  · exact fun z hz => hsource ⟨hz.1, Metric.closedBall_subset_closedBall (min_le_left ε δ) hz.2⟩
+  · exact fun x hx => hband (Metric.ball_subset_ball (min_le_right ε δ) hx)
+
+private theorem
+    Smale.SmallPerturbation.injective_id_add {E : Type*} [NormedAddCommGroup E] {u : E → E}
+    {k : ℝ≥0} (hu : LipschitzWith k u) (hk : k < 1) : Function.Injective (fun x => x + u x) :=
+  (AntilipschitzWith.id.add_lipschitzWith hu (by simpa only [inv_one] using hk)).injective
+
+private theorem Smale.SmallPerturbation.surjective_id_add {E : Type*} [NormedAddCommGroup E]
+    [CompleteSpace E] {u : E → E} {k : ℝ≥0} (hu : LipschitzWith k u) (hk : k < 1) :
+    Function.Surjective (fun x => x + u x) := by
+  intro y
+  have hlip : LipschitzWith k (fun x => y - u x) := by
+    simpa only [zero_add] using (LipschitzWith.const y).sub hu
+  have hc : ContractingWith k (fun x => y - u x) := ⟨hk, hlip⟩
+  let x := ContractingWith.fixedPoint (fun x => y - u x) hc
+  refine ⟨x, ?_⟩
+  have hx : y - u x = x := hc.fixedPoint_isFixedPt.eq
+  exact eq_sub_iff_add_eq.mp hx.symm
+
+private theorem Smale.SmallPerturbation.bijective_id_add {E : Type*} [NormedAddCommGroup E]
+    [CompleteSpace E] {u : E → E} {k : ℝ≥0} (hu : LipschitzWith k u) (hk : k < 1) :
+    Function.Bijective (fun x => x + u x) :=
+  ⟨injective_id_add hu hk, surjective_id_add hu hk⟩
+
+private theorem
+    Smale.SmallPerturbation.isInvertible_fderiv_id_add {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {u : E → E} {k : ℝ≥0} (hs : ContDiff ℝ ∞ u)
+    (hu : LipschitzWith k u) (hk : k < 1) (x : E) :
+    (fderiv ℝ (fun y => y + u y) x).IsInvertible := by
+  have hn : ‖fderiv ℝ u x‖ < 1 :=
+    (norm_fderiv_le_of_lipschitz ℝ hu).trans_lt (show (k : ℝ) < 1 from hk)
+  have hnn : ‖fderiv ℝ u x‖₊ < 1 := hn
+  have hi : Function.Injective (ContinuousLinearMap.id ℝ E + fderiv ℝ u x) :=
+    injective_id_add (fderiv ℝ u x).lipschitz hnn
+  have hd : fderiv ℝ (fun y => y + u y) x = ContinuousLinearMap.id ℝ E + fderiv ℝ u x :=
+    ((hasFDerivAt_id x).add (hs.contDiffAt.differentiableAt (by simp)).hasFDerivAt).fderiv
+  rw [hd]
+  let L :=
+    (LinearEquiv.ofInjectiveEndo (ContinuousLinearMap.id ℝ E + fderiv ℝ u x).toLinearMap
+        hi).toContinuousLinearEquiv
+  exact ⟨L, by ext v; rfl⟩
+
+private def
+    Smale.SmallPerturbation.diffeomorphIdAdd {E : Type*} [NormedAddCommGroup E] [CompleteSpace E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {u : E → E} {k : ℝ≥0} (hs : ContDiff ℝ ∞ u)
+    (hu : LipschitzWith k u) (hk : k < 1) : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞ := by
+  have hloc : IsLocalDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) ∞ (fun x => x + u x) := by
+    intro x
+    apply
+      Smale.isLocalDiffeomorphAt_of_contMDiffOn isOpen_univ (Set.mem_univ x)
+        (contDiff_id.add hs).contMDiff.contMDiffOn
+    rw [mfderiv_eq_fderiv]
+    exact isInvertible_fderiv_id_add hs hu hk x
+  exact hloc.diffeomorphOfBijective (bijective_id_add hu hk)
+
+private theorem Smale.SmallPerturbation.lipschitzWith_smul_const {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {β : E → ℝ} {k : ℝ≥0} (hβ : LipschitzWith k β) (a : E) :
+    LipschitzWith (k * ‖a‖₊) (fun x => β x • a) := by
+  apply LipschitzWith.of_dist_le_mul
+  intro x y
+  calc
+    Dist.dist (β x • a) (β y • a) = ‖β x - β y‖ * ‖a‖ := by
+      rw [dist_eq_norm, ← sub_smul, norm_smul]
+    _ ≤ ((k : ℝ) * Dist.dist x y) * ‖a‖ :=
+      (mul_le_mul_of_nonneg_right (hβ.dist_le_mul x y) (norm_nonneg a))
+    _ = (k * ‖a‖₊ : ℝ≥0) * Dist.dist x y := by
+      simp only [NNReal.coe_mul, coe_nnnorm]
+      ring
+
+private def
+    Smale.SmallPerturbation.bumpTranslation {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] {β : E → ℝ} {k : ℝ≥0} (hs : ContDiff ℝ ∞ β) (hβ : LipschitzWith k β)
+    (a : E) (ha : k * ‖a‖₊ < 1) : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞ :=
+  diffeomorphIdAdd (hs.smul contDiff_const) (lipschitzWith_smul_const hβ a) ha
+
+private theorem Smale.SmallPerturbation.bumpTranslation_apply {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {β : E → ℝ} {k : ℝ≥0} (hs : ContDiff ℝ ∞ β)
+    (hβ : LipschitzWith k β) (a : E) (ha : k * ‖a‖₊ < 1) (x : E) :
+    bumpTranslation hs hβ a ha x = x + β x • a :=
+  rfl
+
+private theorem
+    Smale.SmallPerturbation.bumpTranslation_eq_of_zero {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {β : E → ℝ} {k : ℝ≥0} (hs : ContDiff ℝ ∞ β)
+    (hβ : LipschitzWith k β) (a : E) (ha : k * ‖a‖₊ < 1) {x : E} (hx : β x = 0) :
+    bumpTranslation hs hβ a ha x = x := by rw [bumpTranslation_apply, hx, zero_smul, add_zero]
+
+private theorem
+    Smale.SmallPerturbation.exists_radius_bumpTranslation {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {β : E → ℝ} (hs : ContDiff ℝ ∞ β)
+    (hcompact : HasCompactSupport β) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∀ a : E,
+          ‖a‖ < ε →
+            ∃ d : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞,
+              (∀ x, d x = x + β x • a) ∧ ∀ x ∉ tsupport β, d x = x := by
+  obtain ⟨k, hk⟩ := ContDiff.lipschitzWith_of_hasCompactSupport hcompact hs (by simp)
+  have hkpos : 0 < (k : ℝ) + 1 := by positivity
+  refine ⟨((k : ℝ) + 1)⁻¹, inv_pos.mpr hkpos, ?_⟩
+  intro a ha
+  have hmul : ((k : ℝ) + 1) * ‖a‖ < 1 := by
+    calc
+      ((k : ℝ) + 1) * ‖a‖ < ((k : ℝ) + 1) * ((k : ℝ) + 1)⁻¹ := mul_lt_mul_of_pos_left ha hkpos
+      _ = 1 := mul_inv_cancel₀ hkpos.ne'
+  have hsmall : k * ‖a‖₊ < 1 := by
+    have hreal : (k : ℝ) * ‖a‖ < 1 := by nlinarith [norm_nonneg a]
+    exact hreal
+  refine ⟨bumpTranslation hs hk a hsmall, fun _ => rfl, ?_⟩
+  intro x hx
+  apply bumpTranslation_eq_of_zero
+  by_contra hne
+  exact hx (subset_tsupport β hne)
+
+private theorem
+    Smale.SupportedDiffeomorph.mapsTo_of_fixed_outside {X : Type*} (d : X ≃ X) {S : Set X}
+    (hfix : ∀ x ∉ S, d x = x) : Set.MapsTo d S S := by
+  intro x hx
+  by_contra hdx
+  have heq : d x = x := d.injective (hfix (d x) hdx)
+  exact hdx (heq.symm ▸ hx)
+
+private theorem Smale.SupportedDiffeomorph.inverse_fixed_outside {X : Type*} (d : X ≃ X) {S : Set X}
+    (hfix : ∀ x ∉ S, d x = x) : ∀ x ∉ S, d.symm x = x := by
+  intro x hx
+  apply d.injective
+  rw [d.apply_symm_apply, hfix x hx]
+
+private def Smale.SupportedDiffeomorph.extendMap {E F H H' X Y : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [TopologicalSpace H'] {J : ModelWithCorners ℝ F H'} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y] (Φ : PartialDiffeomorph I J X Y ∞)
+    (f : X → X) (y : Y) : Y := by classical exact if y ∈ Φ.target then Φ (f (Φ.symm y)) else y
+
+private theorem
+    Smale.SupportedDiffeomorph.extendMap_of_mem {E F H H' X Y : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [TopologicalSpace H'] {J : ModelWithCorners ℝ F H'} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y] (Φ : PartialDiffeomorph I J X Y ∞)
+    (f : X → X) {y : Y} (hy : y ∈ Φ.target) : extendMap Φ f y = Φ (f (Φ.symm y)) := by
+  simp only [extendMap, hy, ite_eq_left]
+
+private theorem Smale.SupportedDiffeomorph.extendMap_of_notMem {E F H H' X Y : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H'] {J : ModelWithCorners ℝ F H'}
+    [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y]
+    (Φ : PartialDiffeomorph I J X Y ∞) (f : X → X) {y : Y} (hy : y ∉ Φ.target) :
+    extendMap Φ f y = y := by simp only [extendMap, hy, ite_false]
+
+private theorem
+    Smale.SupportedDiffeomorph.extendMap_id {E F H H' X Y : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [TopologicalSpace H'] {J : ModelWithCorners ℝ F H'} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y] (Φ : PartialDiffeomorph I J X Y ∞)
+    (y : Y) : extendMap Φ id y = y := by
+  by_cases hy : y ∈ Φ.target
+  · rw [extendMap_of_mem Φ id hy]
+    exact Φ.right_inv' hy
+  · exact extendMap_of_notMem Φ id hy
+
+private theorem
+    Smale.SupportedDiffeomorph.extendMap_chart {E F H H' X Y : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [TopologicalSpace H'] {J : ModelWithCorners ℝ F H'} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y] (Φ : PartialDiffeomorph I J X Y ∞)
+    (f : X → X) {x : X} (hx : x ∈ Φ.source) : extendMap Φ f (Φ x) = Φ (f x) := by
+  rw [extendMap_of_mem Φ f (Φ.map_source' hx)]
+  exact congrArg (fun z => Φ (f z)) (Φ.left_inv' hx)
+
+private theorem Smale.SupportedDiffeomorph.extendMap_mem_target {E F H H' X Y : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H'] {J : ModelWithCorners ℝ F H'}
+    [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y]
+    (Φ : PartialDiffeomorph I J X Y ∞) {f : X → X} (hf : Set.MapsTo f Φ.source Φ.source) {y : Y}
+    (hy : y ∈ Φ.target) : extendMap Φ f y ∈ Φ.target := by
+  rw [extendMap_of_mem Φ f hy]
+  exact Φ.map_source' (hf (Φ.map_target' hy))
+
+private theorem Smale.SupportedDiffeomorph.extendMap_leftInverse {E F H H' X Y : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H'] {J : ModelWithCorners ℝ F H'}
+    [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y]
+    (Φ : PartialDiffeomorph I J X Y ∞) (d : X ≃ X) (hd : Set.MapsTo d Φ.source Φ.source) :
+    Function.LeftInverse (extendMap Φ d.symm) (extendMap Φ d) := by
+  intro y
+  by_cases hy : y ∈ Φ.target
+  · rw [extendMap_of_mem Φ d.symm (extendMap_mem_target Φ hd hy), extendMap_of_mem Φ d hy]
+    change Φ (d.symm (Φ.invFun (Φ (d (Φ.invFun y))))) = y
+    rw [Φ.left_inv' (hd (Φ.map_target' hy)), d.symm_apply_apply]
+    exact Φ.right_inv' hy
+  · rw [extendMap_of_notMem Φ d hy, extendMap_of_notMem Φ d.symm hy]
+
+private theorem Smale.SupportedDiffeomorph.extendMap_eq_of_notMem_image {E F H H' X Y : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H'] {J : ModelWithCorners ℝ F H'}
+    [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y]
+    (Φ : PartialDiffeomorph I J X Y ∞) {f : X → X} {K : Set X} (hfix : ∀ x ∉ K, f x = x) {y : Y}
+    (hy : y ∉ Φ '' K) : extendMap Φ f y = y := by
+  by_cases hyt : y ∈ Φ.target
+  · have hback : Φ.symm y ∉ K := fun h => hy ⟨Φ.symm y, h, Φ.right_inv' hyt⟩
+    rw [extendMap_of_mem Φ f hyt, hfix _ hback]
+    exact Φ.right_inv' hyt
+  · exact extendMap_of_notMem Φ f hyt
+
+private theorem
+    Smale.SupportedDiffeomorph.mapsTo_source {E F H H' X Y : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [TopologicalSpace H'] {J : ModelWithCorners ℝ F H'} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y] (Φ : PartialDiffeomorph I J X Y ∞)
+    (d : X ≃ X) {K : Set X} (hKΦ : K ⊆ Φ.source) (hfix : ∀ x ∉ K, d x = x) :
+    Set.MapsTo d Φ.source Φ.source :=
+  mapsTo_of_fixed_outside d (fun x hx => hfix x (fun hk => hx (hKΦ hk)))
+
+private theorem Smale.SupportedDiffeomorph.contMDiff_extendMap {E F H H' X Y : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H'] {J : ModelWithCorners ℝ F H'}
+    [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y]
+    (Φ : PartialDiffeomorph I J X Y ∞) [T2Space Y] {f : X → X} (hf : ContMDiff I I ∞ f)
+    {K : Set X} (hK : IsCompact K) (hKΦ : K ⊆ Φ.source) (hfix : ∀ x ∉ K, f x = x)
+    (hsource : Set.MapsTo f Φ.source Φ.source) : ContMDiff J J ∞ (extendMap Φ f) := by
+  intro y
+  by_cases hy : y ∈ Φ.target
+  · have hback := Φ.contMDiffOn_invFun.contMDiffAt (Φ.open_target.mem_nhds hy)
+    have hforward :=
+      Φ.contMDiffOn_toFun.contMDiffAt (Φ.open_source.mem_nhds (hsource (Φ.map_target' hy)))
+    have hs := hforward.comp y (hf.contMDiffAt.comp y hback)
+    apply hs.congr_of_eventuallyEq
+    filter_upwards [Φ.open_target.mem_nhds hy] with z hz
+    exact extendMap_of_mem Φ f hz
+  · have hc : IsClosed (Φ '' K) :=
+      (hK.image_of_continuousOn (Φ.contMDiffOn_toFun.continuousOn.mono hKΦ)).isClosed
+    have hnot : y ∉ Φ '' K := by
+      rintro ⟨x, hx, rfl⟩
+      exact hy (Φ.map_source' (hKΦ hx))
+    apply (contMDiffAt_id : ContMDiffAt J J ∞ id y).congr_of_eventuallyEq
+    filter_upwards [hc.isOpen_compl.mem_nhds hnot] with z hz
+    exact extendMap_eq_of_notMem_image Φ hfix hz
+
+private def Smale.SupportedDiffeomorph.extension {E F H H' X Y : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [TopologicalSpace H'] {J : ModelWithCorners ℝ F H'} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y] (Φ : PartialDiffeomorph I J X Y ∞)
+    [T2Space Y] (d : Diffeomorph I I X X ∞) {K : Set X} (hK : IsCompact K) (hKΦ : K ⊆ Φ.source)
+    (hfix : ∀ x ∉ K, d x = x) : Diffeomorph J J Y Y ∞ := by
+  have hdi : ∀ x ∉ K, d.symm x = x := inverse_fixed_outside d.toEquiv hfix
+  have hdS : Set.MapsTo d Φ.source Φ.source := mapsTo_source Φ d.toEquiv hKΦ hfix
+  have hdiS : Set.MapsTo d.symm Φ.source Φ.source := mapsTo_source Φ d.symm.toEquiv hKΦ hdi
+  exact
+    { toFun := extendMap Φ d
+      invFun := extendMap Φ d.symm
+      left_inv := extendMap_leftInverse Φ d.toEquiv hdS
+      right_inv := extendMap_leftInverse Φ d.symm.toEquiv hdiS
+      contMDiff_toFun := contMDiff_extendMap Φ d.contMDiff hK hKΦ hfix hdS
+      contMDiff_invFun := contMDiff_extendMap Φ d.symm.contMDiff hK hKΦ hdi hdiS }
+
+private theorem
+    Smale.SupportedDiffeomorph.extension_chart {E F H H' X Y : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [TopologicalSpace H'] {J : ModelWithCorners ℝ F H'} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y] (Φ : PartialDiffeomorph I J X Y ∞)
+    [T2Space Y] (d : Diffeomorph I I X X ∞) {K : Set X} (hK : IsCompact K) (hKΦ : K ⊆ Φ.source)
+    (hfix : ∀ x ∉ K, d x = x) {x : X} (hx : x ∈ Φ.source) :
+    extension Φ d hK hKΦ hfix (Φ x) = Φ (d x) :=
+  extendMap_chart Φ d hx
+
+private theorem Smale.SupportedDiffeomorph.extension_eq_of_notMem_image {E F H H' X Y : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H'] {J : ModelWithCorners ℝ F H'}
+    [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y]
+    (Φ : PartialDiffeomorph I J X Y ∞) [T2Space Y] (d : Diffeomorph I I X X ∞) {K : Set X}
+    (hK : IsCompact K) (hKΦ : K ⊆ Φ.source) (hfix : ∀ x ∉ K, d x = x) {y : Y} (hy : y ∉ Φ '' K) :
+    extension Φ d hK hKΦ hfix y = y :=
+  extendMap_eq_of_notMem_image Φ hfix hy
+
+private theorem Smale.SupportedDiffeomorph.extension_eq_of_notMem_target {E F H H' X Y : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H'] {J : ModelWithCorners ℝ F H'}
+    [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y]
+    (Φ : PartialDiffeomorph I J X Y ∞) [T2Space Y] (d : Diffeomorph I I X X ∞) {K : Set X}
+    (hK : IsCompact K) (hKΦ : K ⊆ Φ.source) (hfix : ∀ x ∉ K, d x = x) {y : Y}
+    (hy : y ∉ Φ.target) : extension Φ d hK hKΦ hfix y = y :=
+  extendMap_of_notMem Φ d hy
+
+private theorem Smale.RegularLevel.le_shift_iff_of_abs_sub_ge {u b t ε : ℝ} (ht : |t| < ε)
+    (hu : ε ≤ |u - b|) : u ≤ b + t ↔ u ≤ b := by
+  by_cases hbelow : u ≤ b
+  · rw [abs_of_nonpos (sub_nonpos.mpr hbelow)] at hu
+    exact ⟨fun _ => hbelow, fun _ => by linarith [(abs_lt.mp ht).1]⟩
+  · have habove : b ≤ u := le_of_not_ge hbelow
+    rw [abs_of_nonneg (sub_nonneg.mpr habove)] at hu
+    constructor <;> intro hh <;> exfalso <;> linarith [(abs_lt.mp ht).2]
+
+private theorem Smale.RegularLevel.exists_ambientTransport_of_heightCollar {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} {b : ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f) (ε : ℝ) (hε : 0 < ε) :
+    letI := chartedSpace hf hreg
+    ∀ Ψ : PartialDiffeomorph (𝓘(ℝ, Model E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) ({ x : M // f x = b } × ℝ) M ∞,
+      ((Set.univ : Set { x : M // f x = b }) ×ˢ Metric.closedBall (0 : ℝ) ε ⊆ Ψ.source) →
+        (∀ x : { x : M // f x = b }, Ψ (x, 0) = x) →
+          (∀ z ∈ Ψ.source, f (Ψ z) = b + z.2) →
+            (f ⁻¹' Metric.ball b ε ⊆ Ψ.target) →
+              ∃ δ : ℝ,
+                0 < δ ∧
+                  δ ≤ ε ∧
+                    ∃ K : Set M,
+                      IsCompact K ∧
+                        K ⊆ Ψ.target ∧
+                          ∀ t : ℝ,
+                            |t| < δ →
+                              ∃ D : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞,
+                                (∀ y, y ∉ K → D y = y) ∧
+                                  (∀ x : { x : M // f x = b }, D x = Ψ (x, t)) ∧
+                                    D '' {x : M | f x = b} = {x : M | f x = b + t} ∧
+                                      D '' {x : M | f x ≤ b} = {x : M | f x ≤ b + t} := by
+  let _ := chartedSpace hf hreg
+  let _ : CompactSpace { x : M // f x = b } :=
+    isCompact_iff_compactSpace.mp (isClosed_eq hf.continuous continuous_const).isCompact
+  intro Ψ hsource hzero hheight hband
+  obtain ⟨β, hβ, hsupp, W, -, hW, -, hβW⟩ :=
+    LineBundleTransport.exists_smooth_cutoff_near_closed (K := {(0 : ℝ)}) (U :=
+      Metric.ball (0 : ℝ) ε) isClosed_singleton Metric.isOpen_ball
+      (by
+        simpa only [Set.singleton_subset_iff] using
+          (Metric.mem_ball_self hε : (0 : ℝ) ∈ Metric.ball 0 ε))
+  have hβ0 : β 0 = 1 := hβW (hW (Set.mem_singleton 0))
+  have hcompact : HasCompactSupport β :=
+    (ProperSpace.isCompact_closedBall (0 : ℝ) ε).of_isClosed_subset (isClosed_tsupport β)
+      (hsupp.trans Metric.ball_subset_closedBall)
+  obtain ⟨η, hη, htranslations⟩ :=
+    Smale.SmallPerturbation.exists_radius_bumpTranslation hβ hcompact
+  let C : Set ({ x : M // f x = b } × ℝ) := Set.univ ×ˢ tsupport β
+  have hC : IsCompact C := isCompact_univ.prod hcompact
+  have hCsource : C ⊆ Ψ.source := fun z hz =>
+    hsource ⟨hz.1, Metric.ball_subset_closedBall (hsupp hz.2)⟩
+  let K : Set M := Ψ '' C
+  have hK : IsCompact K :=
+    hC.image_of_continuousOn (Ψ.contMDiffOn_toFun.continuousOn.mono hCsource)
+  have hKtarget : K ⊆ Ψ.target := by
+    rintro _ ⟨z, hz, rfl⟩
+    exact Ψ.map_source' (hCsource hz)
+  refine ⟨Min.min ε η, lt_min hε hη, min_le_left ε η, K, hK, hKtarget, ?_⟩
+  intro t ht
+  have htε : |t| < ε := lt_of_lt_of_le ht (min_le_left ε η)
+  have htη : ‖t‖ < η := by
+    simpa only [Real.norm_eq_abs] using lt_of_lt_of_le ht (min_le_right ε η)
+  obtain ⟨d, hd, hdfix⟩ := htranslations t htη
+  have hd0 : d 0 = t := by
+    rw [hd 0, hβ0]
+    simp
+  have hdfar (s : ℝ) (hs : ε ≤ s) : d s = s := by
+    apply hdfix
+    intro hsupps
+    have hball : |s| < ε := by
+      simpa only [Metric.mem_ball, Real.dist_eq, sub_zero] using hsupp hsupps
+    rw [abs_of_nonneg (hε.le.trans hs)] at hball
+    exact (not_lt_of_ge hs) hball
+  have hdmono : StrictMono d := by
+    rcases d.contMDiff.continuous.strictMono_of_inj d.injective with hm | ha
+    · exact hm
+    · have hh := ha (show ε < ε + 1 by linarith)
+      rw [hdfar ε le_rfl, hdfar (ε + 1) (by linarith)] at hh
+      linarith
+  let P := (Diffeomorph.refl 𝓘(ℝ, Model E) { x : M // f x = b } ∞).prodCongr d
+  have hPfix : ∀ z, z ∉ C → P z = z := by
+    intro z hz
+    have hzβ : z.2 ∉ tsupport β := fun hh => hz ⟨Set.mem_univ z.1, hh⟩
+    exact Prod.ext rfl (hdfix z.2 hzβ)
+  let D := Smale.SupportedDiffeomorph.extension Ψ P hC hCsource hPfix
+  have hpoint (x : { x : M // f x = b }) : D x = Ψ (x, t) := by
+    have hx0 : (x, 0) ∈ Ψ.source := hsource ⟨Set.mem_univ x, Metric.mem_closedBall_self hε.le⟩
+    have hP0 : P (x, 0) = (x, t) := by exact Prod.ext rfl hd0
+    have hh := Smale.SupportedDiffeomorph.extension_chart Ψ P hC hCsource hPfix hx0
+    change D (Ψ (x, 0)) = Ψ (P (x, 0)) at hh
+    rwa [hzero x, hP0] at hh
+  refine ⟨D, ?_, hpoint, ?_, ?_⟩
+  · intro y hy
+    exact Smale.SupportedDiffeomorph.extension_eq_of_notMem_image Ψ P hC hCsource hPfix hy
+  · ext y
+    constructor
+    · rintro ⟨x, hx, rfl⟩
+      let z : { x : M // f x = b } := ⟨x, hx⟩
+      have hDx : D x = Ψ (z, t) := hpoint z
+      change f (D x) = b + t
+      rw [hDx]
+      exact
+        hheight (z, t)
+          (hsource
+            ⟨Set.mem_univ z, by
+              simpa only [mem_closedBall_zero_iff, Real.norm_eq_abs] using htε.le⟩)
+    · intro hy
+      have hy' : f y = b + t := hy
+      have hyTarget : y ∈ Ψ.target := by
+        apply hband
+        change Dist.dist (f y) b < ε
+        simpa only [hy', Real.dist_eq, add_sub_cancel_left] using htε
+      have hback := Ψ.map_target' hyTarget
+      have hright : Ψ (Ψ.symm y) = y := Ψ.right_inv' hyTarget
+      have htime : (Ψ.symm y).2 = t := by
+        have hh := hheight (Ψ.symm y) hback
+        rw [hright, hy'] at hh
+        linarith
+      refine ⟨((Ψ.symm y).1 : M), (Ψ.symm y).1.property, ?_⟩
+      have hpair : ((Ψ.symm y).1, t) = Ψ.symm y := Prod.ext rfl htime.symm
+      exact (hpoint (Ψ.symm y).1).trans ((congrArg Ψ hpair).trans hright)
+  · have hsublevel (y : M) : f (D y) ≤ b + t ↔ f y ≤ b := by
+      by_cases hy : y ∈ Ψ.target
+      · let z := Ψ.symm y
+        have hz : z ∈ Ψ.source := Ψ.map_target' hy
+        have hPz : P z ∈ Ψ.source :=
+          Smale.SupportedDiffeomorph.mapsTo_source Ψ P.toEquiv hCsource hPfix hz
+        have hDy : D y = Ψ (P z) := Smale.SupportedDiffeomorph.extendMap_of_mem Ψ P hy
+        have hfy : f y = b + z.2 := by
+          have hh := hheight z hz
+          have hzy : Ψ z = y := Ψ.right_inv' hy
+          rwa [hzy] at hh
+        have hfd : f (D y) = b + d z.2 := by
+          rw [hDy]
+          exact hheight (P z) hPz
+        have horder : d z.2 ≤ t ↔ z.2 ≤ 0 := by
+          rw [← hd0]
+          exact hdmono.le_iff_le
+        rw [hfd, hfy]
+        constructor
+        · intro hh
+          have hz0 := horder.mp (by linarith)
+          linarith
+        · intro hh
+          have hdz := horder.mpr (by linarith)
+          linarith
+      · have hDy : D y = y :=
+          Smale.SupportedDiffeomorph.extension_eq_of_notMem_target Ψ P hC hCsource hPfix hy
+        rw [hDy]
+        have hfar : ε ≤ |f y - b| := by
+          apply le_of_not_gt
+          intro hh
+          apply hy
+          apply hband
+          change Dist.dist (f y) b < ε
+          simpa only [Metric.mem_ball, Real.dist_eq] using hh
+        exact le_shift_iff_of_abs_sub_ge htε hfar
+    ext y
+    constructor
+    · rintro ⟨x, hx, rfl⟩
+      exact (hsublevel x).mpr hx
+    · intro hy
+      obtain ⟨x, rfl⟩ := D.surjective y
+      exact ⟨x, (hsublevel x).mp hy, rfl⟩
+
+private theorem
+    Smale.RegularLevel.exists_nearby_ambient_level_diffeomorphs_of_nonempty {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} {b : ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    [Nonempty { x : M // f x = b }] :
+    ∃ δ : ℝ,
+      0 < δ ∧
+        ∃ K : Set M,
+          IsCompact K ∧
+            ∀ t : ℝ,
+              |t| < δ →
+                ∃ D : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞,
+                  (∀ y, y ∉ K → D y = y) ∧
+                    D '' {x : M | f x = b} = {x : M | f x = b + t} ∧
+                      D '' {x : M | f x ≤ b} = {x : M | f x ≤ b + t} := by
+  let _ := chartedSpace hf hreg
+  obtain ⟨ε, hε, Ψ, hsource, hzero, hheight, hband⟩ := exists_heightCollar_with_band hf hreg
+  obtain ⟨δ, hδ, -, K, hK, -, htransport⟩ :=
+    exists_ambientTransport_of_heightCollar hf hreg ε hε Ψ hsource hzero hheight hband
+  refine ⟨δ, hδ, K, hK, ?_⟩
+  intro t ht
+  obtain ⟨D, hfix, -, hlevel, hsublevel⟩ := htransport t ht
+  exact ⟨D, hfix, hlevel, hsublevel⟩
+
+private theorem Smale.RegularLevel.exists_nearby_ambient_level_diffeomorphs {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} {b : ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    ∃ δ : ℝ,
+      0 < δ ∧
+        ∃ K : Set M,
+          IsCompact K ∧
+            ∀ t : ℝ,
+              |t| < δ →
+                ∃ D : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞,
+                  (∀ y, y ∉ K → D y = y) ∧
+                    D '' {x : M | f x = b} = {x : M | f x = b + t} ∧
+                      D '' {x : M | f x ≤ b} = {x : M | f x ≤ b + t} := by
+  classical
+  by_cases hb : Nonempty { x : M // f x = b }
+  · let _ := hb
+    exact exists_nearby_ambient_level_diffeomorphs_of_nonempty hf hreg
+  · have hlevel : ∀ x, f x = b → x ∈ (∅ : Set M) := fun x hx => (hb ⟨⟨x, hx⟩⟩).elim
+    obtain ⟨δ, hδ, hband⟩ := exists_heightBand_subset_open hf.continuous isOpen_empty hlevel
+    refine ⟨δ, hδ, ∅, isCompact_empty, ?_⟩
+    intro t ht
+    refine ⟨Diffeomorph.refl 𝓘(ℝ, E) M ∞, fun _ _ => rfl, ?_, ?_⟩
+    · change id '' {x : M | f x = b} = {x : M | f x = b + t}
+      rw [Set.image_id]
+      ext x
+      constructor
+      · intro hx
+        exact (hb ⟨⟨x, hx⟩⟩).elim
+      · intro hx
+        have hball : x ∈ f ⁻¹' Metric.ball b δ := by
+          change Dist.dist (f x) b < δ
+          simpa only [show f x = b + t from hx, Real.dist_eq, add_sub_cancel_left] using ht
+        exact (hband hball).elim
+    · change id '' {x : M | f x ≤ b} = {x : M | f x ≤ b + t}
+      rw [Set.image_id]
+      ext x
+      have hfar : δ ≤ |f x - b| := by
+        apply le_of_not_gt
+        intro hh
+        apply hband
+        change Dist.dist (f x) b < δ
+        simpa only [Real.dist_eq] using hh
+      exact (le_shift_iff_of_abs_sub_ge ht hfar).symm
+
+private def
+    Smale.RegularLevel.AmbientEquivalent {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] (f : M → ℝ) (a b : ℝ) : Prop :=
+  ∃ D : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞,
+    D '' {x : M | f x = a} = {x : M | f x = b} ∧ D '' {x : M | f x ≤ a} = {x : M | f x ≤ b}
+
+private theorem Smale.RegularLevel.ambientEquivalent_refl {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] (f : M → ℝ) (a : ℝ) :
+    AmbientEquivalent (E := E) f a a := by
+  refine ⟨Diffeomorph.refl 𝓘(ℝ, E) M ∞, ?_, ?_⟩ <;> exact Set.image_id _
+
+private theorem Smale.RegularLevel.ambientEquivalent_symm {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {a b : ℝ}
+    (h : AmbientEquivalent (E := E) f a b) : AmbientEquivalent (E := E) f b a := by
+  obtain ⟨D, hlevel, hsublevel⟩ := h
+  have hreverse (S T : Set M) (hST : D '' S = T) : D.symm '' T = S := by
+    rw [← hST, Set.image_image]
+    have heq : (fun x : M => D.symm (D x)) = id := funext D.symm_apply_apply
+    rw [heq, Set.image_id]
+  exact ⟨D.symm, hreverse _ _ hlevel, hreverse _ _ hsublevel⟩
+
+private theorem Smale.RegularLevel.ambientEquivalent_trans {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {a b c : ℝ}
+    (hab : AmbientEquivalent (E := E) f a b) (hbc : AmbientEquivalent (E := E) f b c) :
+    AmbientEquivalent (E := E) f a c := by
+  obtain ⟨e, he, he'⟩ := hab
+  obtain ⟨d, hd, hd'⟩ := hbc
+  refine ⟨e.trans d, ?_, ?_⟩
+  · change (fun x => d (e x)) '' {x : M | f x = a} = {x : M | f x = c}
+    rw [← Set.image_image, he, hd]
+  · change (fun x => d (e x)) '' {x : M | f x ≤ a} = {x : M | f x ≤ c}
+    rw [← Set.image_image, he', hd']
+
+private theorem Smale.RegularLevel.exists_ambient_regularBand_transport {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [FiniteDimensional ℝ E] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ} (hab : a ≤ b)
+    (hband : ∀ x, f x ∈ Set.Icc a b → x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    ∃ D : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞,
+      D '' {x : M | f x = a} = {x : M | f x = b} ∧ D '' {x : M | f x ≤ a} = {x : M | f x ≤ b} := by
+  classical
+  let B := Set.Icc a b
+  let left : B := ⟨a, ⟨le_rfl, hab⟩⟩
+  let right : B := ⟨b, ⟨hab, le_rfl⟩⟩
+  let reg (t : B) : ∀ x, f x = (t : ℝ) → x ∉ Smale.ManifoldMorse.criticalPoints E f := fun x hx =>
+    hband x (hx ▸ t.property)
+  let P : B → Prop := fun t => AmbientEquivalent (E := E) f a (t : ℝ)
+  have hlocal : IsLocallyConstant P := by
+    apply (IsLocallyConstant.iff_eventually_eq P).mpr
+    intro t
+    obtain ⟨δ, hδ, K, -, htransport⟩ := exists_nearby_ambient_level_diffeomorphs hf (reg t)
+    filter_upwards [Metric.ball_mem_nhds t hδ] with s hs
+    have hdist : |(s : ℝ) - (t : ℝ)| < δ := by
+      change Dist.dist (s : ℝ) (t : ℝ) < δ at hs
+      simpa only [Real.dist_eq] using hs
+    obtain ⟨D, -, hlevel, hsublevel⟩ := htransport ((s : ℝ) - (t : ℝ)) hdist
+    have hts : AmbientEquivalent (E := E) f (t : ℝ) (s : ℝ) := by
+      have heq : (t : ℝ) + ((s : ℝ) - (t : ℝ)) = (s : ℝ) := by ring
+      refine ⟨D, ?_, ?_⟩
+      · simpa only [heq] using hlevel
+      · simpa only [heq] using hsublevel
+    apply propext
+    constructor
+    · intro hs
+      exact ambientEquivalent_trans hs (ambientEquivalent_symm hts)
+    · intro ht
+      exact ambientEquivalent_trans ht hts
+  let _ : PreconnectedSpace B := isPreconnected_iff_preconnectedSpace.mp isPreconnected_Icc
+  have hconstant : P left = P right := hlocal.apply_eq_of_preconnectedSpace left right
+  have hleft : P left := ambientEquivalent_refl f a
+  have hright : P right := hconstant ▸ hleft
+  exact hright
+
+private theorem
+    Smale.RegularLevel.exists_levelDiffeomorph_of_ambient {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ}
+    (ha : ∀ x, f x = a → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hb : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (D : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞)
+    (hlevel : D '' {x : M | f x = a} = {x : M | f x = b}) :
+    letI := chartedSpace hf ha
+    letI := chartedSpace hf hb
+    ∃ e : Diffeomorph 𝓘(ℝ, Model E) 𝓘(ℝ, Model E) { x : M // f x = a } { x : M // f x = b } ∞,
+      ∀ x, (e x : M) = D x := by
+  let _ := chartedSpace hf ha
+  let _ := chartedSpace hf hb
+  have hiff (x : M) : f x = a ↔ f (D x) = b := by
+    constructor
+    · intro hx
+      have hh : D x ∈ D '' {x : M | f x = a} := ⟨x, hx, rfl⟩
+      rwa [hlevel] at hh
+    · intro hx
+      have hh : D x ∈ D '' {x : M | f x = a} := by rw [hlevel]; exact hx
+      obtain ⟨z, hz, hzx⟩ := hh
+      exact D.injective hzx ▸ hz
+  let e := D.toHomeomorph.subtype (p := fun x => f x = a) (q := fun x => f x = b) hiff
+  have he : ContMDiff 𝓘(ℝ, Model E) 𝓘(ℝ, Model E) ∞ e :=
+    (contMDiff_iff_inclusion hf hb 𝓘(ℝ, Model E) e).mpr
+      (D.contMDiff.comp (Smale.RegularLevel.contMDiff_inclusion hf ha))
+  have hei : ContMDiff 𝓘(ℝ, Model E) 𝓘(ℝ, Model E) ∞ e.symm :=
+    (contMDiff_iff_inclusion hf ha 𝓘(ℝ, Model E) e.symm).mpr
+      (D.symm.contMDiff.comp (Smale.RegularLevel.contMDiff_inclusion hf hb))
+  let F : Diffeomorph 𝓘(ℝ, Model E) 𝓘(ℝ, Model E) { x : M // f x = a } { x : M // f x = b } ∞ :=
+    { e.toEquiv with
+      contMDiff_toFun := he
+      contMDiff_invFun := hei }
+  exact ⟨F, fun _ => rfl⟩
+
+private def Smale.SphereCoordinates.ofLinearIsometry {N P : Type*} [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] [NormedAddCommGroup P] [InnerProductSpace ℝ P] {n : ℕ}
+    [Fact (Module.finrank ℝ N = n + 1)] [Fact (Module.finrank ℝ P = n + 1)] (L : N ≃ₗᵢ[ℝ] P) :
+    Diffeomorph (𝓡 n) (𝓡 n) (Metric.sphere (0 : N) 1) (Metric.sphere (0 : P) 1) ∞ := by
+  have hforward (x : Metric.sphere (0 : N) 1) : L (x : N) ∈ Metric.sphere (0 : P) 1 := by
+    simpa only [mem_sphere_zero_iff_norm, L.norm_map] using x.property
+  have hinverse (y : Metric.sphere (0 : P) 1) : L.symm (y : P) ∈ Metric.sphere (0 : N) 1 := by
+    simpa only [mem_sphere_zero_iff_norm, L.symm.norm_map] using y.property
+  have hs : ContMDiff (𝓡 n) 𝓘(ℝ, P) ∞ (fun x : Metric.sphere (0 : N) 1 => L (x : N)) :=
+    L.contDiff.contMDiff.comp (contMDiff_coe_sphere (n := n))
+  have hi : ContMDiff (𝓡 n) 𝓘(ℝ, N) ∞ (fun y : Metric.sphere (0 : P) 1 => L.symm (y : P)) :=
+    L.symm.contDiff.contMDiff.comp (contMDiff_coe_sphere (n := n))
+  exact
+    { toFun := fun x => ⟨L x, hforward x⟩
+      invFun := fun y => ⟨L.symm y, hinverse y⟩
+      left_inv := fun x => Subtype.ext (L.symm_apply_apply x)
+      right_inv := fun y => Subtype.ext (L.apply_symm_apply y)
+      contMDiff_toFun := hs.codRestrict_sphere hforward
+      contMDiff_invFun := hi.codRestrict_sphere hinverse }
+
+private def Smale.SphereCoordinates.standardParametrization (N : Type*) [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] (n : ℕ) [Fact (Module.finrank ℝ N = n + 1)] [FiniteDimensional ℝ N] :
+    Diffeomorph (𝓡 n) (𝓡 n) (Smale.Hemisphere.Sphere n) (Metric.sphere (0 : N) 1) ∞ := by
+  let _ : Fact (Module.finrank ℝ (Smale.Hemisphere.Ambient (n + 1)) = n + 1) :=
+    ⟨finrank_euclideanSpace_fin⟩
+  let b := (stdOrthonormalBasis ℝ N).reindex (finCongr (Fact.out : Module.finrank ℝ N = n + 1))
+  exact ofLinearIsometry b.repr.symm
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.MorseSurgeryData.transportedAttachingSphere {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p q : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (d' : Smale.ManifoldMorse.MorseSurgeryData E f q) (n : ℕ)
+    [Fact (Module.finrank ℝ d'.chart.NegativeCoordinates = n + 1)]
+    (e : d.UpperLevel ≃ₜ d'.LowerLevel) : C(Smale.Hemisphere.Sphere n, d.UpperLevel) :=
+  ⟨fun x =>
+    e.symm
+      (d'.surgery.attachingSphere
+        (Smale.SphereCoordinates.standardParametrization d'.chart.NegativeCoordinates n x)),
+    e.symm.continuous.comp
+      (d'.surgery.attachingSphere.continuous.comp
+        (Smale.SphereCoordinates.standardParametrization d'.chart.NegativeCoordinates
+            n).continuous)⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.transportedAttachingSphere_apply {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p q : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (d' : Smale.ManifoldMorse.MorseSurgeryData E f q) (n : ℕ)
+    [Fact (Module.finrank ℝ d'.chart.NegativeCoordinates = n + 1)]
+    (e : d.UpperLevel ≃ₜ d'.LowerLevel) (x : Smale.Hemisphere.Sphere n) :
+    e (d.transportedAttachingSphere d' n e x) =
+      d'.surgery.attachingSphere
+        (Smale.SphereCoordinates.standardParametrization d'.chart.NegativeCoordinates n x) :=
+  e.apply_symm_apply _
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.range_transportedAttachingSphere {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p q : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (d' : Smale.ManifoldMorse.MorseSurgeryData E f q) (n : ℕ)
+    [Fact (Module.finrank ℝ d'.chart.NegativeCoordinates = n + 1)]
+    (e : d.UpperLevel ≃ₜ d'.LowerLevel) :
+    Set.range (d.transportedAttachingSphere d' n e) =
+      e ⁻¹' Set.range d'.surgery.attachingSphere := by
+  let s := Smale.SphereCoordinates.standardParametrization d'.chart.NegativeCoordinates n
+  ext y
+  constructor
+  · rintro ⟨x, rfl⟩
+    exact ⟨s x, (d.transportedAttachingSphere_apply d' n e x).symm⟩
+  · rintro ⟨z, hz⟩
+    obtain ⟨x, hx⟩ := s.surjective z
+    refine ⟨x, e.injective ?_⟩
+    rw [d.transportedAttachingSphere_apply d' n e]
+    exact (congrArg d'.surgery.attachingSphere hx).trans hz
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.transportedAttachingSphere_smooth {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p q : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (d' : Smale.ManifoldMorse.MorseSurgeryData E f q) [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (n : ℕ)
+    [Fact (Module.finrank ℝ d'.chart.NegativeCoordinates = n + 1)] :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    letI := Smale.RegularLevel.chartedSpace hf d'.lower_regular
+    ∀ e :
+      Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E) d.UpperLevel
+        d'.LowerLevel ∞,
+      ContMDiff (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞
+        (d.transportedAttachingSphere d' n e.toHomeomorph) := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  let _ := Smale.RegularLevel.chartedSpace hf d'.lower_regular
+  intro e
+  exact
+    e.symm.contMDiff.comp
+      ((d'.attaching_smooth hf n).comp
+        (Smale.SphereCoordinates.standardParametrization d'.chart.NegativeCoordinates
+            n).contMDiff)
+
+private theorem Smale.ManifoldMorse.MorseSurgeryData.exists_smoothBandBridge {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p q : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (d' : Smale.ManifoldMorse.MorseSurgeryData E f q) [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) [T2Space M] [CompactSpace M]
+    (hgap : f p + d.radius ^ 2 ≤ f q - d'.radius ^ 2)
+    (hband :
+      ∀ x,
+        f x ∈ Set.Icc (f p + d.radius ^ 2) (f q - d'.radius ^ 2) →
+          x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    letI := Smale.RegularLevel.chartedSpace hf d'.lower_regular
+    ∃ D : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞,
+      ∃ e :
+        Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E) d.UpperLevel
+          d'.LowerLevel ∞,
+        D '' {x : M | f x ≤ f p + d.radius ^ 2} = {x : M | f x ≤ f q - d'.radius ^ 2} ∧
+          ∀ x : d.UpperLevel, (e x : M) = D x := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  let _ := Smale.RegularLevel.chartedSpace hf d'.lower_regular
+  obtain ⟨D, hlevel, hsublevel⟩ :=
+    Smale.RegularLevel.exists_ambient_regularBand_transport hf hgap hband
+  obtain ⟨e, he⟩ :=
+    Smale.RegularLevel.exists_levelDiffeomorph_of_ambient hf d.upper_regular d'.lower_regular D
+      hlevel
+  exact ⟨D, e, hsublevel, he⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private structure
+    Smale.ManifoldMorse.SurgeryWindows (E : Type*) [NormedAddCommGroup E] [NormedSpace ℝ E]
+    {M : Type*} [TopologicalSpace M] [ChartedSpace E M] (f : M → ℝ) where
+  finite : (criticalPoints E f).Finite
+  distinct : Set.InjOn f (criticalPoints E f)
+  data : ∀ p : criticalPoints E f, MorseSurgeryData E f p.val
+  isolated :
+    ∀ (p : criticalPoints E f) (x : M),
+      x ∈ criticalPoints E f →
+        f x ∈ Set.Icc (f p - (data p).radius ^ 2) (f p + (data p).radius ^ 2) → x = p.val
+  separated :
+    ∀ p q : criticalPoints E f, f p < f q → f p + (data p).radius ^ 2 < f q - (data q).radius ^ 2
+
+private def Smale.ManifoldMorse.SurgeryWindows.lower {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (p : Smale.ManifoldMorse.criticalPoints E f) :
+    ℝ :=
+  f p - (S.data p).radius ^ 2
+
+private def Smale.ManifoldMorse.SurgeryWindows.upper {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (p : Smale.ManifoldMorse.criticalPoints E f) :
+    ℝ :=
+  f p + (S.data p).radius ^ 2
+
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.lower_lt_value {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (p : Smale.ManifoldMorse.criticalPoints E f) :
+    S.lower p < f p := by
+  dsimp [Smale.ManifoldMorse.SurgeryWindows.lower]
+  nlinarith [(S.data p).radius_pos]
+
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.value_lt_upper {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (p : Smale.ManifoldMorse.criticalPoints E f) :
+    f p < S.upper p := by
+  dsimp [Smale.ManifoldMorse.SurgeryWindows.upper]
+  nlinarith [(S.data p).radius_pos]
+
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.upper_lt_lower {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (p q : Smale.ManifoldMorse.criticalPoints E f)
+    (hpq : f p < f q) : S.upper p < S.lower q :=
+  S.separated p q hpq
+
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.regular_between {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (p q : Smale.ManifoldMorse.criticalPoints E f)
+    (hconsecutive : ∀ r : Smale.ManifoldMorse.criticalPoints E f, ¬(f p < f r ∧ f r < f q)) :
+    ∀ x, f x ∈ Set.Icc (S.upper p) (S.lower q) → x ∉ Smale.ManifoldMorse.criticalPoints E f := by
+  intro x hx hcrit
+  exact
+    hconsecutive ⟨x, hcrit⟩
+      ⟨(S.value_lt_upper p).trans_le hx.1, hx.2.trans_lt (S.lower_lt_value q)⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SurgeryWindows.exists_bandBridge {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) [FiniteDimensional ℝ E] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [T2Space M] [CompactSpace M] (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (p q : Smale.ManifoldMorse.criticalPoints E f) (hpq : f p < f q)
+    (hconsecutive : ∀ r : Smale.ManifoldMorse.criticalPoints E f, ¬(f p < f r ∧ f r < f q)) :
+    letI := Smale.RegularLevel.chartedSpace hf (S.data p).upper_regular
+    letI := Smale.RegularLevel.chartedSpace hf (S.data q).lower_regular
+    ∃ D : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞,
+      ∃ b :
+        Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+          (S.data p).UpperLevel (S.data q).LowerLevel ∞,
+        D '' {x : M | f x ≤ S.upper p} = {x : M | f x ≤ S.lower q} ∧
+          ∀ x : (S.data p).UpperLevel, (b x : M) = D x :=
+  (S.data p).exists_smoothBandBridge (S.data q) hf (S.upper_lt_lower p q hpq).le
+    (S.regular_between p q hconsecutive)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.nonempty_surgeryWindows {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : IsMorse E f) (hinj : Set.InjOn f (criticalPoints E f)) :
+    Nonempty (SurgeryWindows E f) := by
+  obtain ⟨r, hr, hgap⟩ := exists_separated_value_radii (finite_criticalPoints hf hm) hinj
+  have hex :
+    ∀ p : criticalPoints E f,
+      ∃ d : MorseSurgeryData E f p.val,
+        d.radius < r p ∧
+          ∀ x ∈ criticalPoints E f,
+            f x ∈ Set.Icc (f p - d.radius ^ 2) (f p + d.radius ^ 2) → x = p.val := by
+    intro p
+    exact
+      exists_morseSurgeryData_lt hf hm p.property (fun x hx hfx => hinj hx p.property hfx) (hr p)
+  choose d hd hisolated using hex
+  refine
+    ⟨{  finite := finite_criticalPoints hf hm
+        distinct := hinj
+        data := d
+        isolated := hisolated
+        separated := ?_ }⟩
+  intro p q hpq
+  have hp : (d p).radius ^ 2 < (r p) ^ 2 := by
+    have h := mul_pos (sub_pos.mpr (hd p)) (add_pos (hr p) (d p).radius_pos)
+    nlinarith
+  have hq : (d q).radius ^ 2 < (r q) ^ 2 := by
+    have h := mul_pos (sub_pos.mpr (hd q)) (add_pos (hr q) (d q).radius_pos)
+    nlinarith
+  linarith [hgap p q hpq]
+
+attribute [local instance 100] Classical.propDecidable in
+private structure AdaptedWindows (E : Type*) [NormedAddCommGroup E] [NormedSpace ℝ E] {M : Type*}
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (f : M → ℝ) extends
+    Smale.ManifoldMorse.SurgeryWindows E f where
+  field : (x : M) → TangentSpace 𝓘(ℝ, E) x
+  flow : Flow ℝ M
+  smooth :
+    ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, field x⟩ : TangentBundle 𝓘(ℝ, E) M))
+  integral : ∀ x, IsMIntegralCurve (fun t => flow t x) field
+  zero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, field x = 0
+  descent : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (field x) < 0
+  model_germ :
+    ∀ (p : Smale.ManifoldMorse.criticalPoints E f) z,
+      z ∈
+          Metric.closedBall (0 : (data p).chart.NegativeCoordinates) (2 * (data p).radius) ×ˢ
+            Metric.closedBall (0 : (data p).chart.PositiveCoordinates) (2 * (data p).radius) →
+        ∀ᶠ y in 𝓝 ((data p).chart.splitChart.symm z), field y = (data p).chart.descentField y
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.nonempty_adaptedSurgeryWindows {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f)) :
+    Nonempty (AdaptedWindows E f) := by
+  have hfinite := Smale.ManifoldMorse.finite_criticalPoints hf hm
+  let : Finite (Smale.ManifoldMorse.criticalPoints E f) := hfinite.to_subtype
+  obtain ⟨r, hr, hgap⟩ := Smale.ManifoldMorse.exists_separated_value_radii hfinite hinj
+  have hex :
+    ∀ p : Smale.ManifoldMorse.criticalPoints E f,
+      ∃ d : Smale.ManifoldMorse.MorseSurgeryData E f p.val,
+        d.radius < r p / 3 ∧
+          ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+            f x ∈ Set.Icc (f p - d.radius ^ 2) (f p + d.radius ^ 2) → x = p.val := by
+    intro p
+    exact
+      Smale.ManifoldMorse.exists_morseSurgeryData_lt hf hm p.property
+        (fun x hx hfx => hinj hx p.property hfx) (div_pos (hr p) (by norm_num))
+  choose d hd hisolated using hex
+  have hsq (p : Smale.ManifoldMorse.criticalPoints E f) : 9 * (d p).radius ^ 2 < (r p) ^ 2 := by
+    have hsmall : 3 * (d p).radius < r p := by linarith [hd p]
+    have hsum : 0 < r p + 3 * (d p).radius :=
+      add_pos (hr p) (mul_pos (by norm_num) (d p).radius_pos)
+    nlinarith [mul_pos (sub_pos.mpr hsmall) hsum]
+  have hwide (p q : Smale.ManifoldMorse.criticalPoints E f) (hpq : f p < f q) :
+    f p + 9 * (d p).radius ^ 2 < f q - 9 * (d q).radius ^ 2 := by
+    linarith [hgap p q hpq, hsq p, hsq q]
+  have hintervals :
+    Pairwise
+      (fun p q : Smale.ManifoldMorse.criticalPoints E f =>
+        Disjoint (Set.Icc (f p - 9 * (d p).radius ^ 2) (f p + 9 * (d p).radius ^ 2))
+          (Set.Icc (f q - 9 * (d q).radius ^ 2) (f q + 9 * (d q).radius ^ 2))) := by
+    intro p q hpq
+    have hne : f p ≠ f q := fun h => hpq (Subtype.ext (hinj p.property q.property h))
+    apply Set.disjoint_left.mpr
+    intro x hx hy
+    rcases lt_or_gt_of_ne hne with hlt | hgt
+    · linarith [hwide p q hlt, hx.2, hy.1]
+    · linarith [hwide q p hgt, hy.2, hx.1]
+  obtain ⟨V, F, hV, hF, hzero, hdesc, hmodel⟩ :=
+    exists_disjoint_surgery_block_field hf hm
+      (fun p : Smale.ManifoldMorse.criticalPoints E f => p.val) (fun p => p.property)
+      (fun p => (d p).chart) (fun p => (d p).radius) (fun p => (d p).radius_pos)
+      (fun p => (d p).block) hintervals
+  refine
+    ⟨{  finite := hfinite
+        distinct := hinj
+        data := d
+        isolated := hisolated
+        separated := ?_
+        field := V
+        flow := F
+        smooth := hV
+        integral := hF
+        zero := hzero
+        descent := hdesc
+        model_germ := hmodel }⟩
+  intro p q hpq
+  nlinarith [hwide p q hpq, sq_nonneg (d p).radius, sq_nonneg (d q).radius]
+
+private theorem MorseCancel.exists_forward_morse_model_exit {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {r : ℝ} (hr : 0 < r) {z : N × P}
+    (hzn : ‖z.1‖ < r) (hzp : ‖z.2‖ < r) (hne : z.1 ≠ 0) :
+    ∃ T : ℝ,
+      0 < T ∧
+        (∀ t ∈ Set.Icc (0 : ℝ) T,
+            Smale.MorseHandle.descentFlow t z ∈
+              Metric.closedBall (0 : N) r ×ˢ Metric.closedBall (0 : P) r) ∧
+          Smale.MorseHandle.quadratic (Smale.MorseHandle.descentFlow T z) < 0 := by
+  let T := Real.log (r / ‖z.1‖)
+  have hn : 0 < ‖z.1‖ := norm_pos_iff.mpr hne
+  have hratio : 1 < r / ‖z.1‖ := (one_lt_div hn).mpr hzn
+  have hT : 0 < T := Real.log_pos hratio
+  have hexp : Real.exp T = r / ‖z.1‖ := Real.exp_log (div_pos hr hn)
+  have hnorm : ‖(Smale.MorseHandle.descentFlow T z).1‖ = r := by
+    rw [Smale.MorseHandle.norm_descentFlow_fst, hexp]
+    exact div_mul_cancel₀ r hn.ne'
+  have hsmall : ‖(Smale.MorseHandle.descentFlow T z).2‖ < r :=
+    (Smale.MorseHandle.norm_snd_descentFlow_le hT.le z).trans_lt hzp
+  refine ⟨T, hT, ?_, ?_⟩
+  · intro t ht
+    constructor
+    · rw [mem_closedBall_zero_iff, Smale.MorseHandle.norm_descentFlow_fst]
+      calc
+        Real.exp t * ‖z.1‖ ≤ Real.exp T * ‖z.1‖ :=
+          mul_le_mul_of_nonneg_right (Real.exp_le_exp.mpr ht.2) (norm_nonneg _)
+        _ = r := by rw [hexp, div_mul_cancel₀ r hn.ne']
+    · exact
+        mem_closedBall_zero_iff.mpr
+          ((Smale.MorseHandle.norm_snd_descentFlow_le ht.1 z).trans hzp.le)
+  · change
+      -‖(Smale.MorseHandle.descentFlow T z).1‖ ^ 2 + ‖(Smale.MorseHandle.descentFlow T z).2‖ ^ 2 <
+        0
+    rw [hnorm]
+    have hs := (sq_lt_sq₀ (norm_nonneg _) hr.le).mpr hsmall
+    linarith
+
+private theorem MorseCancel.exists_backward_morse_model_exit {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {r : ℝ} (hr : 0 < r) {z : N × P}
+    (hzn : ‖z.1‖ < r) (hzp : ‖z.2‖ < r) (hne : z.2 ≠ 0) :
+    ∃ T : ℝ,
+      T < 0 ∧
+        (∀ t ∈ Set.Icc T (0 : ℝ),
+            Smale.MorseHandle.descentFlow t z ∈
+              Metric.closedBall (0 : N) r ×ˢ Metric.closedBall (0 : P) r) ∧
+          0 < Smale.MorseHandle.quadratic (Smale.MorseHandle.descentFlow T z) := by
+  let T := -Real.log (r / ‖z.2‖)
+  have hn : 0 < ‖z.2‖ := norm_pos_iff.mpr hne
+  have hratio : 1 < r / ‖z.2‖ := (one_lt_div hn).mpr hzp
+  have hT : T < 0 := neg_neg_of_pos (Real.log_pos hratio)
+  have hexp : Real.exp (-T) = r / ‖z.2‖ := by
+    dsimp [T]
+    rw [neg_neg, Real.exp_log (div_pos hr hn)]
+  have hnorm : ‖(Smale.MorseHandle.descentFlow T z).2‖ = r := by
+    rw [Smale.MorseHandle.norm_descentFlow_snd, hexp]
+    exact div_mul_cancel₀ r hn.ne'
+  have hsmall (t : ℝ) (ht : t ≤ 0) : ‖(Smale.MorseHandle.descentFlow t z).1‖ < r := by
+    rw [Smale.MorseHandle.norm_descentFlow_fst]
+    exact (mul_le_of_le_one_left (norm_nonneg _) (Real.exp_le_one_iff.mpr ht)).trans_lt hzn
+  refine ⟨T, hT, ?_, ?_⟩
+  · intro t ht
+    constructor
+    · exact mem_closedBall_zero_iff.mpr (hsmall t ht.2).le
+    · rw [mem_closedBall_zero_iff, Smale.MorseHandle.norm_descentFlow_snd]
+      calc
+        Real.exp (-t) * ‖z.2‖ ≤ Real.exp (-T) * ‖z.2‖ :=
+          mul_le_mul_of_nonneg_right (Real.exp_le_exp.mpr (neg_le_neg ht.1)) (norm_nonneg _)
+        _ = r := by rw [hexp, div_mul_cancel₀ r hn.ne']
+  · change
+      0 <
+        -‖(Smale.MorseHandle.descentFlow T z).1‖ ^ 2 + ‖(Smale.MorseHandle.descentFlow T z).2‖ ^ 2
+    rw [hnorm]
+    have hs := (sq_lt_sq₀ (norm_nonneg _) hr.le).mpr (hsmall T hT.le)
+    linarith
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_native_morse_field_block {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (heq : ∀ᶠ y in 𝓝 p, V y = c.descentField y) :
+    ∃ r : ℝ,
+      0 < r ∧
+        Metric.closedBall (0 : c.NegativeCoordinates) r ×ˢ
+              Metric.closedBall (0 : c.PositiveCoordinates) r ⊆
+            c.splitChart.target ∧
+          ∀
+            z ∈
+              Metric.closedBall (0 : c.NegativeCoordinates) r ×ˢ
+                Metric.closedBall (0 : c.PositiveCoordinates) r,
+            ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y := by
+  have h0 : (0 : c.NegativeCoordinates × c.PositiveCoordinates) ∈ c.splitChart.target := by
+    rw [← c.splitChart_center]
+    exact c.splitChart.map_source' c.splitChart_mem_source
+  have hcenter : c.splitChart.symm 0 = p := by
+    rw [← c.splitChart_center]
+    exact c.splitChart.left_inv' c.splitChart_mem_source
+  have hcont :
+    Filter.Tendsto c.splitChart.symm (𝓝 (0 : c.NegativeCoordinates × c.PositiveCoordinates))
+      (𝓝 p) := by
+    have hh :
+      Filter.Tendsto c.splitChart.symm (𝓝 (0 : c.NegativeCoordinates × c.PositiveCoordinates))
+        (𝓝 (c.splitChart.symm 0)) :=
+      c.splitChart.toOpenPartialHomeomorph.symm.continuousAt h0
+    rwa [hcenter] at hh
+  have htarget :
+    ∀ᶠ z in 𝓝 (0 : c.NegativeCoordinates × c.PositiveCoordinates), z ∈ c.splitChart.target :=
+    c.splitChart.open_target.mem_nhds h0
+  have hgerm : ∀ᶠ y in 𝓝 p, ∀ᶠ x in 𝓝 y, V x = c.descentField x :=
+    eventually_eventually_nhds.mpr heq
+  obtain ⟨r, hr, hsub⟩ :=
+    Metric.nhds_basis_closedBall.mem_iff.mp (htarget.and (hcont.eventually hgerm))
+  have hblock (z)
+    (hz :
+      z ∈
+        Metric.closedBall (0 : c.NegativeCoordinates) r ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) r) :=
+    hsub
+      (by
+        rw [closedBall_prod_same] at hz
+        convert! hz using 1)
+  exact ⟨r, hr, fun z hz => (hblock z hz).1, fun z hz => (hblock z hz).2⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_native_forward_morse_exit {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {r : ℝ} (hr : 0 < r)
+    (hbox :
+      Metric.closedBall (0 : c.NegativeCoordinates) r ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) r ⊆
+        c.splitChart.target)
+    (heq :
+      ∀
+        z ∈
+          Metric.closedBall (0 : c.NegativeCoordinates) r ×ˢ
+            Metric.closedBall (0 : c.PositiveCoordinates) r,
+        ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y)
+    {x : M} (hx : x ∈ c.splitChart.source) (hn : ‖(c.splitChart x).1‖ < r)
+    (hp : ‖(c.splitChart x).2‖ < r) (hne : (c.splitChart x).1 ≠ 0) :
+    ∃ T : ℝ, 0 < T ∧ f (F T x) < f p := by
+  obtain ⟨T, hT, hstay, hheight⟩ := exists_forward_morse_model_exit hr hn hp hne
+  have hdomain (s : ℝ) (hs : s ∈ Set.uIcc (0 : ℝ) T) :
+    Smale.MorseHandle.descentFlow s (c.splitChart x) ∈
+      Metric.closedBall (0 : c.NegativeCoordinates) r ×ˢ
+        Metric.closedBall (0 : c.PositiveCoordinates) r :=
+    hstay s (by simpa only [Set.uIcc_of_le hT.le] using hs)
+  have hflow :=
+    c.flow_eq_descentModel_of_mem_uIcc hV F hF hx (fun s hs => hbox (hdomain s hs))
+      (fun s hs => heq _ (hdomain s hs))
+  refine ⟨T, hT, ?_⟩
+  rw [hflow, c.splitChart_inverse_equation (hbox (hstay T ⟨hT.le, le_rfl⟩))]
+  change
+    -‖(Smale.MorseHandle.descentFlow T (c.splitChart x)).1‖ ^ 2 +
+        ‖(Smale.MorseHandle.descentFlow T (c.splitChart x)).2‖ ^ 2 <
+      0 at hheight
+  linarith
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_native_backward_morse_exit {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {r : ℝ} (hr : 0 < r)
+    (hbox :
+      Metric.closedBall (0 : c.NegativeCoordinates) r ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) r ⊆
+        c.splitChart.target)
+    (heq :
+      ∀
+        z ∈
+          Metric.closedBall (0 : c.NegativeCoordinates) r ×ˢ
+            Metric.closedBall (0 : c.PositiveCoordinates) r,
+        ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y)
+    {x : M} (hx : x ∈ c.splitChart.source) (hn : ‖(c.splitChart x).1‖ < r)
+    (hp : ‖(c.splitChart x).2‖ < r) (hne : (c.splitChart x).2 ≠ 0) :
+    ∃ T : ℝ, T < 0 ∧ f p < f (F T x) := by
+  obtain ⟨T, hT, hstay, hheight⟩ := exists_backward_morse_model_exit hr hn hp hne
+  have hdomain (s : ℝ) (hs : s ∈ Set.uIcc (0 : ℝ) T) :
+    Smale.MorseHandle.descentFlow s (c.splitChart x) ∈
+      Metric.closedBall (0 : c.NegativeCoordinates) r ×ˢ
+        Metric.closedBall (0 : c.PositiveCoordinates) r :=
+    hstay s (by simpa only [Set.uIcc_of_ge hT.le] using hs)
+  have hflow :=
+    c.flow_eq_descentModel_of_mem_uIcc hV F hF hx (fun s hs => hbox (hdomain s hs))
+      (fun s hs => heq _ (hdomain s hs))
+  refine ⟨T, hT, ?_⟩
+  rw [hflow, c.splitChart_inverse_equation (hbox (hstay T ⟨le_rfl, hT.le⟩))]
+  change
+    0 <
+      -‖(Smale.MorseHandle.descentFlow T (c.splitChart x)).1‖ ^ 2 +
+        ‖(Smale.MorseHandle.descentFlow T (c.splitChart x)).2‖ ^ 2 at hheight
+  linarith
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.native_morse_positive_plane_limit {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {r : ℝ} (hr : 0 < r)
+    (hbox :
+      Metric.closedBall (0 : c.NegativeCoordinates) r ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) r ⊆
+        c.splitChart.target)
+    (heq :
+      ∀
+        z ∈
+          Metric.closedBall (0 : c.NegativeCoordinates) r ×ˢ
+            Metric.closedBall (0 : c.PositiveCoordinates) r,
+        ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y)
+    {x : M} (hx : x ∈ c.splitChart.source) (hp : ‖(c.splitChart x).2‖ < r)
+    (hzero : (c.splitChart x).1 = 0) : Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p) := by
+  have hstay (t : ℝ) (ht : t ∈ Set.Ici (0 : ℝ)) :
+    Smale.MorseHandle.descentFlow t (c.splitChart x) ∈
+      Metric.closedBall (0 : c.NegativeCoordinates) r ×ˢ
+        Metric.closedBall (0 : c.PositiveCoordinates) r := by
+    constructor
+    · rw [mem_closedBall_zero_iff, Smale.MorseHandle.norm_descentFlow_fst, hzero, norm_zero,
+        MulZeroClass.mul_zero]
+      exact hr.le
+    · exact
+        mem_closedBall_zero_iff.mpr
+          ((Smale.MorseHandle.norm_snd_descentFlow_le ht (c.splitChart x)).trans hp.le)
+  have hflow :=
+    c.flow_eqOn_descentModel hV F hF hx isPreconnected_Ici (le_refl (0 : ℝ))
+      (fun t ht => hbox (hstay t ht)) (fun t ht => heq _ (hstay t ht))
+  have hfirst :
+    Filter.Tendsto (fun t : ℝ => Real.exp t • (c.splitChart x).1) Filter.atTop
+      (𝓝 (0 : c.NegativeCoordinates)) := by
+    simp only [hzero, smul_zero]
+    exact tendsto_const_nhds
+  have hsecond :
+    Filter.Tendsto (fun t : ℝ => Real.exp (-t) • (c.splitChart x).2) Filter.atTop
+      (𝓝 (0 : c.PositiveCoordinates)) := by
+    simpa only [Function.comp_def, zero_smul] using
+      (Real.tendsto_exp_atBot.comp Filter.tendsto_neg_atTop_atBot).smul_const (c.splitChart x).2
+  have hlim :
+    Filter.Tendsto (fun t => Smale.MorseHandle.descentFlow t (c.splitChart x)) Filter.atTop
+      (𝓝 (0 : c.NegativeCoordinates × c.PositiveCoordinates)) :=
+    hfirst.prodMk_nhds hsecond
+  have h0 : (0 : c.NegativeCoordinates × c.PositiveCoordinates) ∈ c.splitChart.target :=
+    hbox ⟨Metric.mem_closedBall_self hr.le, Metric.mem_closedBall_self hr.le⟩
+  have hcenter : c.splitChart.symm 0 = p := by
+    rw [← c.splitChart_center]
+    exact c.splitChart.left_inv' c.splitChart_mem_source
+  have hn :
+    Filter.Tendsto (fun t => c.splitChart.symm (Smale.MorseHandle.descentFlow t (c.splitChart x)))
+      Filter.atTop (𝓝 (c.splitChart.symm 0)) :=
+    c.splitChart.toOpenPartialHomeomorph.symm.continuousAt h0 |>.tendsto.comp hlim
+  rw [hcenter] at hn
+  apply hn.congr'
+  filter_upwards [Filter.eventually_ge_atTop (0 : ℝ)] with t ht
+  exact (hflow ht).symm
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.native_morse_negative_plane_limit {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {r : ℝ} (hr : 0 < r)
+    (hbox :
+      Metric.closedBall (0 : c.NegativeCoordinates) r ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) r ⊆
+        c.splitChart.target)
+    (heq :
+      ∀
+        z ∈
+          Metric.closedBall (0 : c.NegativeCoordinates) r ×ˢ
+            Metric.closedBall (0 : c.PositiveCoordinates) r,
+        ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y)
+    {x : M} (hx : x ∈ c.splitChart.source) (hn : ‖(c.splitChart x).1‖ < r)
+    (hzero : (c.splitChart x).2 = 0) : Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p) := by
+  have hstay (t : ℝ) (ht : t ∈ Set.Iic (0 : ℝ)) :
+    Smale.MorseHandle.descentFlow t (c.splitChart x) ∈
+      Metric.closedBall (0 : c.NegativeCoordinates) r ×ˢ
+        Metric.closedBall (0 : c.PositiveCoordinates) r := by
+    constructor
+    · rw [mem_closedBall_zero_iff, Smale.MorseHandle.norm_descentFlow_fst]
+      exact (mul_le_of_le_one_left (norm_nonneg _) (Real.exp_le_one_iff.mpr ht)).trans hn.le
+    · rw [mem_closedBall_zero_iff, Smale.MorseHandle.norm_descentFlow_snd, hzero, norm_zero,
+        MulZeroClass.mul_zero]
+      exact hr.le
+  have hflow :=
+    c.flow_eqOn_descentModel hV F hF hx isPreconnected_Iic (le_refl (0 : ℝ))
+      (fun t ht => hbox (hstay t ht)) (fun t ht => heq _ (hstay t ht))
+  have hfirst :
+    Filter.Tendsto (fun t : ℝ => Real.exp t • (c.splitChart x).1) Filter.atBot
+      (𝓝 (0 : c.NegativeCoordinates)) := by
+    simpa only [zero_smul] using Real.tendsto_exp_atBot.smul_const (c.splitChart x).1
+  have hsecond :
+    Filter.Tendsto (fun t : ℝ => Real.exp (-t) • (c.splitChart x).2) Filter.atBot
+      (𝓝 (0 : c.PositiveCoordinates)) := by
+    simp only [hzero, smul_zero]
+    exact tendsto_const_nhds
+  have hlim :
+    Filter.Tendsto (fun t => Smale.MorseHandle.descentFlow t (c.splitChart x)) Filter.atBot
+      (𝓝 (0 : c.NegativeCoordinates × c.PositiveCoordinates)) :=
+    hfirst.prodMk_nhds hsecond
+  have h0 : (0 : c.NegativeCoordinates × c.PositiveCoordinates) ∈ c.splitChart.target :=
+    hbox ⟨Metric.mem_closedBall_self hr.le, Metric.mem_closedBall_self hr.le⟩
+  have hcenter : c.splitChart.symm 0 = p := by
+    rw [← c.splitChart_center]
+    exact c.splitChart.left_inv' c.splitChart_mem_source
+  have hh :
+    Filter.Tendsto (fun t => c.splitChart.symm (Smale.MorseHandle.descentFlow t (c.splitChart x)))
+      Filter.atBot (𝓝 (c.splitChart.symm 0)) :=
+    c.splitChart.toOpenPartialHomeomorph.symm.continuousAt h0 |>.tendsto.comp hlim
+  rw [hcenter] at hh
+  apply hh.congr'
+  filter_upwards [Filter.eventually_le_atBot (0 : ℝ)] with t ht
+  exact (hflow ht).symm
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_native_morse_basin_block {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (hf : Continuous f) {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hmono : ∀ x, Antitone (fun t => f (F t x))) (heq : ∀ᶠ y in 𝓝 p, V y = c.descentField y) :
+    ∃ r : ℝ,
+      0 < r ∧
+        Metric.closedBall (0 : c.NegativeCoordinates) r ×ˢ
+              Metric.closedBall (0 : c.PositiveCoordinates) r ⊆
+            c.splitChart.target ∧
+          ∀ x ∈ c.splitChart.source,
+            ‖(c.splitChart x).1‖ < r →
+              ‖(c.splitChart x).2‖ < r →
+                (Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p) ↔ (c.splitChart x).1 = 0) ∧
+                  (Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p) ↔ (c.splitChart x).2 = 0) :=
+  by
+  obtain ⟨r, hr, hbox, hfield⟩ := exists_native_morse_field_block c heq
+  refine ⟨r, hr, hbox, ?_⟩
+  intro x hx hn hp
+  constructor
+  · constructor
+    · intro hlim
+      by_contra hne
+      obtain ⟨T, hT, hexit⟩ :=
+        exists_native_forward_morse_exit c hV F hF hr hbox hfield hx hn hp hne
+      have hheight : Filter.Tendsto (fun t => f (F t x)) Filter.atTop (𝓝 (f p)) :=
+        hf.continuousAt.tendsto.comp hlim
+      exact (not_lt_of_ge ((hmono x).le_of_tendsto hheight T)) hexit
+    · exact native_morse_positive_plane_limit c hV F hF hr hbox hfield hx hp
+  · constructor
+    · intro hlim
+      by_contra hne
+      obtain ⟨T, hT, hexit⟩ :=
+        exists_native_backward_morse_exit c hV F hF hr hbox hfield hx hn hp hne
+      have hheight : Filter.Tendsto (fun t => f (F t x)) Filter.atBot (𝓝 (f p)) :=
+        hf.continuousAt.tendsto.comp hlim
+      exact (not_lt_of_ge ((hmono x).ge_of_tendsto hheight T)) hexit
+    · exact native_morse_negative_plane_limit c hV F hF hr hbox hfield hx hn
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_descending_morse_basin_block {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0)
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (heq : ∀ᶠ y in 𝓝 p, V y = c.descentField y) :
+    ∃ r : ℝ,
+      0 < r ∧
+        Metric.closedBall (0 : c.NegativeCoordinates) r ×ˢ
+              Metric.closedBall (0 : c.PositiveCoordinates) r ⊆
+            c.splitChart.target ∧
+          ∀ x ∈ c.splitChart.source,
+            ‖(c.splitChart x).1‖ < r →
+              ‖(c.splitChart x).2‖ < r →
+                (Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p) ↔ (c.splitChart x).1 = 0) ∧
+                  (Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p) ↔ (c.splitChart x).2 = 0) :=
+  exists_native_morse_basin_block c hf.continuous hV F hF
+    (Smale.FlowConstruction.antitone_flow_height hf F hF hzero hdesc) heq
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.native_attaching_core_backward_limit {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} {p : M} {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) (r : ℝ) (hr : 0 < r)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) ⊆
+        c.splitChart.target)
+    (hfield :
+      ∀
+        z ∈
+          Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+            Metric.closedBall (0 : c.PositiveCoordinates) (2 * r),
+        ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y)
+    (u : Smale.PuncturedHandle.UnitSphere c.NegativeCoordinates) :
+    Filter.Tendsto (fun t => F t (c.attachingCoreMap r hr hblock u)) Filter.atBot (𝓝 p) := by
+  have hu : ‖(u : c.NegativeCoordinates)‖ = 1 := mem_sphere_zero_iff_norm.mp u.property
+  have hn : ‖r • (u : c.NegativeCoordinates)‖ = r := by
+    rw [norm_smul, Real.norm_eq_abs, abs_of_pos hr, hu, mul_one]
+  have hcoords :
+    (r • (u : c.NegativeCoordinates), (0 : c.PositiveCoordinates)) ∈ c.splitChart.target := by
+    apply hblock
+    constructor
+    · rw [mem_closedBall_zero_iff, hn]
+      linarith
+    · rw [mem_closedBall_zero_iff, norm_zero]
+      positivity
+  have hcoord :
+    c.splitChart
+        (c.splitChart.symm (r • (u : c.NegativeCoordinates), (0 : c.PositiveCoordinates))) =
+      (r • (u : c.NegativeCoordinates), 0) :=
+    c.splitChart.right_inv' hcoords
+  have hh :=
+    native_morse_negative_plane_limit c hV F hF (x :=
+      c.splitChart.symm (r • (u : c.NegativeCoordinates), (0 : c.PositiveCoordinates)))
+      (show 0 < 2 * r by positivity) hblock hfield (c.splitChart.map_target' hcoords)
+      (by rw [hcoord]; change ‖r • (u : c.NegativeCoordinates)‖ < 2 * r; rw [hn]; linarith)
+      (by rw [hcoord])
+  simpa only [c.attachingCoreMap_coe] using hh
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.native_belt_core_forward_limit {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} {p : M} {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) (r : ℝ) (hr : 0 < r)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) ⊆
+        c.splitChart.target)
+    (hfield :
+      ∀
+        z ∈
+          Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+            Metric.closedBall (0 : c.PositiveCoordinates) (2 * r),
+        ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y)
+    (v : Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates) :
+    Filter.Tendsto (fun t => F t (c.beltCoreMap r hr hblock v)) Filter.atTop (𝓝 p) := by
+  have hv : ‖(v : c.PositiveCoordinates)‖ = 1 := mem_sphere_zero_iff_norm.mp v.property
+  have hn : ‖r • (v : c.PositiveCoordinates)‖ = r := by
+    rw [norm_smul, Real.norm_eq_abs, abs_of_pos hr, hv, mul_one]
+  have hcoords :
+    ((0 : c.NegativeCoordinates), r • (v : c.PositiveCoordinates)) ∈ c.splitChart.target := by
+    apply hblock
+    constructor
+    · rw [mem_closedBall_zero_iff, norm_zero]
+      positivity
+    · rw [mem_closedBall_zero_iff, hn]
+      linarith
+  have hcoord :
+    c.splitChart
+        (c.splitChart.symm ((0 : c.NegativeCoordinates), r • (v : c.PositiveCoordinates))) =
+      (0, r • (v : c.PositiveCoordinates)) :=
+    c.splitChart.right_inv' hcoords
+  have hh :=
+    native_morse_positive_plane_limit c hV F hF (x :=
+      c.splitChart.symm ((0 : c.NegativeCoordinates), r • (v : c.PositiveCoordinates)))
+      (show 0 < 2 * r by positivity) hblock hfield (c.splitChart.map_target' hcoords)
+      (by rw [hcoord]; change ‖r • (v : c.PositiveCoordinates)‖ < 2 * r; rw [hn]; linarith)
+      (by rw [hcoord])
+  simpa only [c.beltCoreMap_coe] using hh
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.native_attaching_core_flow {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} {p : M} {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) (r : ℝ) (hr : 0 < r)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) ⊆
+        c.splitChart.target)
+    (hfield :
+      ∀
+        z ∈
+          Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+            Metric.closedBall (0 : c.PositiveCoordinates) (2 * r),
+        ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y)
+    (u : Smale.PuncturedHandle.UnitSphere c.NegativeCoordinates) {t : ℝ} (ht : t ≤ 0) :
+    F t (c.attachingCoreMap r hr hblock u) =
+      c.splitChart.symm (Smale.MorseHandle.descentFlow t (r • (u : c.NegativeCoordinates), 0)) := by
+  let z : c.NegativeCoordinates × c.PositiveCoordinates := (r • (u : c.NegativeCoordinates), 0)
+  have hn : ‖z.1‖ = r := by
+    change ‖r • (u : c.NegativeCoordinates)‖ = r
+    rw [norm_smul, Real.norm_eq_abs, abs_of_pos hr, mem_sphere_zero_iff_norm.mp u.property,
+      mul_one]
+  have hstay (s : ℝ) (hs : s ≤ 0) :
+    Smale.MorseHandle.descentFlow s z ∈
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+        Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) := by
+    constructor
+    · rw [mem_closedBall_zero_iff, Smale.MorseHandle.norm_descentFlow_fst, hn]
+      have hh := mul_le_mul_of_nonneg_right (Real.exp_le_one_iff.mpr hs) hr.le
+      nlinarith
+    · rw [mem_closedBall_zero_iff, Smale.MorseHandle.norm_descentFlow_snd]
+      change Real.exp (-s) * ‖(0 : c.PositiveCoordinates)‖ ≤ 2 * r
+      simp only [norm_zero, MulZeroClass.mul_zero]
+      positivity
+  have hz : z ∈ c.splitChart.target := by
+    have hh := hblock (hstay 0 le_rfl)
+    simpa only [Flow.map_zero_apply] using hh
+  have hcoord : c.splitChart (c.splitChart.symm z) = z := c.splitChart.right_inv' hz
+  have hflow :=
+    c.flow_eqOn_descentModel hV F hF (x := c.splitChart.symm z) (c.splitChart.map_target' hz)
+      isPreconnected_Iic (le_refl (0 : ℝ)) (fun s hs => by rw [hcoord]; exact hblock (hstay s hs))
+      (fun s hs => by rw [hcoord]; exact hfield _ (hstay s hs))
+  have hh := hflow ht
+  rw [hcoord] at hh
+  simpa only [c.attachingCoreMap_coe] using hh
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.native_belt_core_flow {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ}
+    {p : M} {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) (r : ℝ) (hr : 0 < r)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) ⊆
+        c.splitChart.target)
+    (hfield :
+      ∀
+        z ∈
+          Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+            Metric.closedBall (0 : c.PositiveCoordinates) (2 * r),
+        ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y)
+    (v : Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates) {t : ℝ} (ht : 0 ≤ t) :
+    F t (c.beltCoreMap r hr hblock v) =
+      c.splitChart.symm (Smale.MorseHandle.descentFlow t (0, r • (v : c.PositiveCoordinates))) := by
+  let z : c.NegativeCoordinates × c.PositiveCoordinates := (0, r • (v : c.PositiveCoordinates))
+  have hn : ‖z.2‖ = r := by
+    change ‖r • (v : c.PositiveCoordinates)‖ = r
+    rw [norm_smul, Real.norm_eq_abs, abs_of_pos hr, mem_sphere_zero_iff_norm.mp v.property,
+      mul_one]
+  have hstay (s : ℝ) (hs : 0 ≤ s) :
+    Smale.MorseHandle.descentFlow s z ∈
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+        Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) := by
+    constructor
+    · rw [mem_closedBall_zero_iff, Smale.MorseHandle.norm_descentFlow_fst]
+      change Real.exp s * ‖(0 : c.NegativeCoordinates)‖ ≤ 2 * r
+      simp only [norm_zero, MulZeroClass.mul_zero]
+      positivity
+    · rw [mem_closedBall_zero_iff, Smale.MorseHandle.norm_descentFlow_snd, hn]
+      have hh := mul_le_mul_of_nonneg_right (Real.exp_le_one_iff.mpr (neg_nonpos.mpr hs)) hr.le
+      nlinarith
+  have hz : z ∈ c.splitChart.target := by
+    have hh := hblock (hstay 0 le_rfl)
+    simpa only [Flow.map_zero_apply] using hh
+  have hcoord : c.splitChart (c.splitChart.symm z) = z := c.splitChart.right_inv' hz
+  have hflow :=
+    c.flow_eqOn_descentModel hV F hF (x := c.splitChart.symm z) (c.splitChart.map_target' hz)
+      isPreconnected_Ici (le_refl (0 : ℝ)) (fun s hs => by rw [hcoord]; exact hblock (hstay s hs))
+      (fun s hs => by rw [hcoord]; exact hfield _ (hstay s hs))
+  have hh := hflow ht
+  rw [hcoord] at hh
+  simpa only [c.beltCoreMap_coe] using hh
+
+private theorem MorseCancel.exists_negative_core_ray_parameter {A : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] {r : ℝ} (hr : 0 < r) {z : A} (hz : z ≠ 0) (hzr : ‖z‖ < r) :
+    ∃ (u : Smale.PuncturedHandle.UnitSphere A) (t : ℝ), t < 0 ∧ Real.exp t • (r • (u : A)) = z := by
+  have hn : 0 < ‖z‖ := norm_pos_iff.mpr hz
+  let u : Smale.PuncturedHandle.UnitSphere A :=
+    ⟨‖z‖⁻¹ • z, mem_sphere_zero_iff_norm.mpr (norm_smul_inv_norm hz)⟩
+  have hratio : 0 < ‖z‖ / r := div_pos hn hr
+  have hratio1 : ‖z‖ / r < 1 := (div_lt_one hr).mpr hzr
+  have hcoef : Real.exp (Real.log (‖z‖ / r)) * r * ‖z‖⁻¹ = 1 := by
+    rw [Real.exp_log hratio]
+    field_simp
+  refine ⟨u, Real.log (‖z‖ / r), Real.log_neg hratio hratio1, ?_⟩
+  change Real.exp (Real.log (‖z‖ / r)) • (r • (‖z‖⁻¹ • z)) = z
+  rw [smul_smul, smul_smul, hcoef, one_smul]
+
+private theorem MorseCancel.exists_positive_core_ray_parameter {A : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] {r : ℝ} (hr : 0 < r) {z : A} (hz : z ≠ 0) (hzr : ‖z‖ < r) :
+    ∃ (u : Smale.PuncturedHandle.UnitSphere A) (t : ℝ),
+      0 < t ∧ Real.exp (-t) • (r • (u : A)) = z := by
+  obtain ⟨u, t, ht, heq⟩ := exists_negative_core_ray_parameter hr hz hzr
+  exact ⟨u, -t, neg_pos.mpr ht, by simpa only [neg_neg] using heq⟩
+
+private theorem
+    Degree.FlowCancellation.exists_local_strict_flow_descent {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f D : X → ℝ} (hf : Continuous f) (hD : Continuous D)
+    (hder : ∀ x t, HasDerivAt (fun s : ℝ => f (F s x)) (D (F t x)) t) {x : X} (hx : D x < 0) :
+    ∃ ε : ℝ, 0 < ε ∧ StrictAntiOn (fun t : ℝ => f (F t x)) (Set.Icc (-ε) ε) := by
+  have hcont : Continuous (fun t : ℝ => D (F t x)) :=
+    hD.comp (F.continuous continuous_id continuous_const)
+  have he : ∀ᶠ t : ℝ in 𝓝 0, D (F t x) < 0 := by
+    have hx0 : D (F 0 x) < 0 := by simpa only [F.map_zero_apply] using hx
+    exact hcont.continuousAt (eventually_lt_nhds hx0)
+  obtain ⟨r, hr, hball⟩ := Metric.eventually_nhds_iff.mp he
+  refine ⟨r / 2, half_pos hr, ?_⟩
+  have hfc : Continuous (fun t : ℝ => f (F t x)) :=
+    hf.comp (F.continuous continuous_id continuous_const)
+  apply strictAntiOn_of_deriv_neg (convex_Icc _ _) hfc.continuousOn
+  intro t ht
+  rw [(hder x t).deriv]
+  apply hball
+  rw [Real.dist_eq, sub_zero, abs_lt]
+  have ht' := interior_subset ht
+  constructor <;> linarith [ht'.1, ht'.2]
+
+private theorem Degree.FlowCancellation.exists_local_strict_sublevel_entry {X : Type*}
+    [TopologicalSpace X] (F : Flow ℝ X) {f D : X → ℝ} (hf : Continuous f) (hD : Continuous D)
+    (hder : ∀ x t, HasDerivAt (fun s : ℝ => f (F s x)) (D (F t x)) t) {c : ℝ}
+    (hboundary : ∀ x, f x = c → D x < 0) {x : X} (hx : f x ≤ c) :
+    ∃ ε : ℝ, 0 < ε ∧ ∀ t ∈ Set.Ioc (0 : ℝ) ε, f (F t x) < c := by
+  rcases hx.lt_or_eq with hx | hx
+  · have he : ∀ᶠ t : ℝ in 𝓝 0, f (F t x) < c := by
+      have hfc : Continuous (fun t : ℝ => f (F t x)) :=
+        hf.comp (F.continuous continuous_id continuous_const)
+      have hx0 : f (F 0 x) < c := by simpa only [F.map_zero_apply] using hx
+      exact hfc.continuousAt (eventually_lt_nhds hx0)
+    obtain ⟨r, hr, hball⟩ := Metric.eventually_nhds_iff.mp he
+    refine ⟨r / 2, half_pos hr, ?_⟩
+    intro t ht
+    apply hball
+    rw [Real.dist_eq, sub_zero, abs_of_pos ht.1]
+    linarith [ht.2]
+  · obtain ⟨ε, hε, hanti⟩ := exists_local_strict_flow_descent F hf hD hder (hboundary x hx)
+    refine ⟨ε, hε, ?_⟩
+    intro t ht
+    have hh :=
+      hanti (show (0 : ℝ) ∈ Set.Icc (-ε) ε from ⟨by linarith, hε.le⟩)
+        (show t ∈ Set.Icc (-ε) ε from ⟨by linarith [ht.1], ht.2⟩) ht.1
+    simpa only [F.map_zero_apply, hx] using hh
+
+private theorem Degree.FlowCancellation.forwardInvariant_sublevel_of_boundary {X : Type*}
+    [TopologicalSpace X] (F : Flow ℝ X) {f D : X → ℝ} (hf : Continuous f) (hD : Continuous D)
+    (hder : ∀ x t, HasDerivAt (fun s : ℝ => f (F s x)) (D (F t x)) t) {c : ℝ}
+    (hboundary : ∀ x, f x = c → D x < 0) : ∀ x, f x ≤ c → ∀ t : ℝ, 0 ≤ t → f (F t x) ≤ c := by
+  apply Smale.FlowConstruction.forwardInvariant_of_local F (isClosed_le hf continuous_const)
+  intro x hx
+  obtain ⟨ε, hε, hentry⟩ := exists_local_strict_sublevel_entry F hf hD hder hboundary hx
+  refine ⟨ε, hε, ?_⟩
+  intro t ht
+  rcases ht.1.eq_or_lt with ht0 | htpos
+  · simpa only [← ht0, F.map_zero_apply] using hx
+  · exact (hentry t ⟨htpos, ht.2⟩).le
+
+private theorem
+    Degree.FlowCancellation.interior_sublevel_eq_of_boundary {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f D : X → ℝ} (hf : Continuous f)
+    (hder : ∀ x t, HasDerivAt (fun s : ℝ => f (F s x)) (D (F t x)) t) {c : ℝ}
+    (hboundary : ∀ x, f x = c → D x < 0) : interior {x | f x ≤ c} = {x | f x < c} := by
+  apply Set.Subset.antisymm
+  · intro x hx
+    have hle : f x ≤ c := (interior_subset : interior {y | f y ≤ c} ⊆ {y | f y ≤ c}) hx
+    apply lt_of_le_of_ne hle
+    intro heq
+    have hnhds : ∀ᶠ t : ℝ in 𝓝 0, F t x ∈ interior {y | f y ≤ c} := by
+      have hfc : Continuous (fun t : ℝ => F t x) := F.continuous continuous_id continuous_const
+      have hx0 : F 0 x ∈ interior {y | f y ≤ c} := by simpa only [F.map_zero_apply] using hx
+      exact hfc.continuousAt (isOpen_interior.mem_nhds hx0)
+    have hmax : IsLocalMax (fun t : ℝ => f (F t x)) 0 := by
+      filter_upwards [hnhds] with t ht
+      change f (F t x) ≤ f (F 0 x)
+      rw [F.map_zero_apply, heq]
+      exact (interior_subset : interior {y | f y ≤ c} ⊆ {y | f y ≤ c}) ht
+    have hz := hmax.hasDerivAt_eq_zero (hder x 0)
+    rw [F.map_zero_apply] at hz
+    exact (hboundary x heq).ne hz
+  · exact interior_maximal (fun _ (hx : f _ < c) => hx.le) (isOpen_lt hf continuous_const)
+
+private theorem
+    Degree.FlowCancellation.strict_sublevel_entry_of_boundary {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f D : X → ℝ} (hf : Continuous f) (hD : Continuous D)
+    (hder : ∀ x t, HasDerivAt (fun s : ℝ => f (F s x)) (D (F t x)) t) {c : ℝ}
+    (hboundary : ∀ x, f x = c → D x < 0) : ∀ x, f x ≤ c → ∀ t : ℝ, 0 < t → f (F t x) < c := by
+  have hforward := forwardInvariant_sublevel_of_boundary F hf hD hder hboundary
+  have hlocal :
+    ∀ x ∈ {y | f y ≤ c}, ∃ ε > (0 : ℝ), ∀ t ∈ Set.Ioc 0 ε, F t x ∈ interior {y | f y ≤ c} := by
+    intro x hx
+    obtain ⟨ε, hε, hentry⟩ := exists_local_strict_sublevel_entry F hf hD hder hboundary hx
+    refine ⟨ε, hε, ?_⟩
+    intro t ht
+    rw [interior_sublevel_eq_of_boundary F hf hder hboundary]
+    exact hentry t ht
+  intro x hx t ht
+  have hi := Smale.FlowConstruction.interior_entry_of_local F hforward hlocal x hx t ht
+  have hi' : F t x ∈ interior {y | f y ≤ c} := hi
+  exact
+    Eq.mp
+      (congrArg (fun S : Set X => F t x ∈ S)
+        (interior_sublevel_eq_of_boundary F hf hder hboundary))
+      hi'
+
+private def
+    Degree.FlowCancellation.levelBasin {X : Type*} [TopologicalSpace X] (F : Flow ℝ X) (f : X → ℝ)
+    (c : ℝ) : Set X :=
+  {x | ∃ t : ℝ, f (F t x) = c}
+
+private def Degree.FlowCancellation.signedLevelTime {X : Type*} [TopologicalSpace X] (F : Flow ℝ X)
+    (f : X → ℝ) (c : ℝ) (x : X) : ℝ := by
+  classical exact if h : x ∈ levelBasin F f c then h.choose else 0
+
+private theorem Degree.FlowCancellation.signedLevelTime_hits {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) (f : X → ℝ) (c : ℝ) {x : X} (hx : x ∈ levelBasin F f c) :
+    f (F (signedLevelTime F f c x) x) = c := by
+  rw [signedLevelTime, dite_eq_left hx]
+  exact hx.choose_spec
+
+private theorem Degree.FlowCancellation.levelBasin_flow_iff {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) (f : X → ℝ) (c s : ℝ) (x : X) :
+    F s x ∈ levelBasin F f c ↔ x ∈ levelBasin F f c := by
+  constructor
+  · rintro ⟨t, ht⟩
+    exact ⟨t + s, by simpa only [F.map_add] using ht⟩
+  · rintro ⟨t, ht⟩
+    refine ⟨t - s, ?_⟩
+    simpa only [← F.map_add, sub_add_cancel] using ht
+
+private theorem Degree.FlowCancellation.flow_level_time_unique {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f D : X → ℝ} (hf : Continuous f) (hD : Continuous D)
+    (hder : ∀ x t, HasDerivAt (fun s : ℝ => f (F s x)) (D (F t x)) t) {c : ℝ}
+    (hboundary : ∀ x, f x = c → D x < 0) (x : X) {s t : ℝ} (hs : f (F s x) = c)
+    (ht : f (F t x) = c) : s = t := by
+  have hnot {a b : ℝ} (ha : f (F a x) = c) (hb : f (F b x) = c) : ¬a < b := by
+    intro hab
+    have hh :=
+      strict_sublevel_entry_of_boundary F hf hD hder hboundary (F a x) ha.le (b - a)
+        (sub_pos.mpr hab)
+    rw [← F.map_add, sub_add_cancel, hb] at hh
+    exact lt_irrefl _ hh
+  exact le_antisymm (le_of_not_gt (hnot ht hs)) (le_of_not_gt (hnot hs ht))
+
+private theorem Degree.FlowCancellation.signedLevelTime_eq_of_level {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f D : X → ℝ} (hf : Continuous f) (hD : Continuous D)
+    (hder : ∀ x t, HasDerivAt (fun s : ℝ => f (F s x)) (D (F t x)) t) {c : ℝ}
+    (hboundary : ∀ x, f x = c → D x < 0) {x : X} {t : ℝ} (ht : f (F t x) = c) :
+    signedLevelTime F f c x = t :=
+  flow_level_time_unique F hf hD hder hboundary x (signedLevelTime_hits F f c ⟨t, ht⟩) ht
+
+private theorem Degree.FlowCancellation.signedLevelTime_eq_zero {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f D : X → ℝ} (hf : Continuous f) (hD : Continuous D)
+    (hder : ∀ x t, HasDerivAt (fun s : ℝ => f (F s x)) (D (F t x)) t) {c : ℝ}
+    (hboundary : ∀ x, f x = c → D x < 0) {x : X} (hx : f x = c) : signedLevelTime F f c x = 0 :=
+  signedLevelTime_eq_of_level F hf hD hder hboundary (by simpa only [F.map_zero_apply] using hx)
+
+private theorem Degree.FlowCancellation.signedLevelTime_flow {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f D : X → ℝ} (hf : Continuous f) (hD : Continuous D)
+    (hder : ∀ x t, HasDerivAt (fun s : ℝ => f (F s x)) (D (F t x)) t) {c : ℝ}
+    (hboundary : ∀ x, f x = c → D x < 0) {x : X} (hx : x ∈ levelBasin F f c) (s : ℝ) :
+    signedLevelTime F f c (F s x) = signedLevelTime F f c x - s := by
+  apply signedLevelTime_eq_of_level F hf hD hder hboundary
+  rw [← F.map_add, sub_add_cancel]
+  exact signedLevelTime_hits F f c hx
+
+private theorem Smale.FlowConstruction.exists_enlarged_interval {a b : ℝ} (hab : a ≤ b) {W : Set ℝ}
+    (hW : IsOpen W) (hIW : Set.Icc a b ⊆ W) : ∃ l u : ℝ, l < a ∧ b < u ∧ Set.Ioo l u ⊆ W := by
+  obtain ⟨l, r, hla, hL⟩ := mem_nhds_iff_exists_Ioo_subset.mp (hW.mem_nhds (hIW ⟨le_rfl, hab⟩))
+  obtain ⟨s, u, hbu, hR⟩ := mem_nhds_iff_exists_Ioo_subset.mp (hW.mem_nhds (hIW ⟨hab, le_rfl⟩))
+  refine ⟨l, u, hla.1, hbu.2, ?_⟩
+  intro y hy
+  by_cases hya : y < a
+  · exact hL ⟨hy.1, hya.trans hla.2⟩
+  by_cases hby : b < y
+  · exact hR ⟨hbu.1.trans hby, hy.2⟩
+  exact hIW ⟨le_of_not_gt hya, le_of_not_gt hby⟩
+
+private theorem Smale.FlowConstruction.scalar_height_translation {φ γ : ℝ → ℝ} (hφ : ContDiff ℝ ∞ φ)
+    {W : Set ℝ} (hW : IsOpen W) {a b c t : ℝ} (hIW : Set.Icc a b ⊆ W)
+    (hφW : Set.EqOn φ (fun _ => 1) W) (hγ : ∀ s, HasDerivAt γ (φ (γ s)) s) (hγ₀ : γ 0 = c)
+    (hc : c ∈ Set.Icc a b) (ht : c + t ∈ Set.Icc a b) : γ t = c + t := by
+  obtain ⟨l, u, hl, hu, hlu⟩ := exists_enlarged_interval (hc.1.trans hc.2) hW hIW
+  let V : (x : ℝ) → TangentSpace 𝓘(ℝ, ℝ) x := fun x => (NormedSpace.fromTangentSpace x).symm (φ x)
+  have hV :
+    ContMDiff 𝓘(ℝ, ℝ) (𝓘(ℝ, ℝ).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, ℝ) ℝ)) :=
+    contMDiff_vectorSpace_iff_contDiff.mpr (hφ.of_le (by simp))
+  have hactual : IsMIntegralCurveOn γ V (Set.Ioo (l - c) (u - c)) := by
+    intro s hs
+    exact (hγ s).hasFDerivAt.hasMFDerivAt.hasMFDerivWithinAt
+  have hlinear : IsMIntegralCurveOn (fun s => c + s) V (Set.Ioo (l - c) (u - c)) := by
+    intro s hs
+    have hcs : c + s ∈ W := hlu ⟨by linarith [hs.1], by linarith [hs.2]⟩
+    have hd : HasDerivAt (fun r => c + r) (φ (c + s)) s := by
+      rw [hφW hcs]
+      exact (hasDerivAt_id s).const_add c
+    exact hd.hasFDerivAt.hasMFDerivAt.hasMFDerivWithinAt
+  have hzero : (0 : ℝ) ∈ Set.Ioo (l - c) (u - c) := ⟨by linarith [hc.1], by linarith [hc.2]⟩
+  have htime : t ∈ Set.Ioo (l - c) (u - c) := ⟨by linarith [ht.1], by linarith [ht.2]⟩
+  exact
+    isMIntegralCurveOn_Ioo_eqOn_of_contMDiff_boundaryless hzero hV hactual hlinear
+      (by simpa only [add_zero] using hγ₀) htime
+
+private theorem
+    Smale.FlowConstruction.exists_heightTranslatingFlow {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ}
+    (hband : ∀ x, f x ∈ Set.Icc a b → x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    ∃ F : Flow ℝ M, ∀ x t, f x ∈ Set.Icc a b → f x + t ∈ Set.Icc a b → f (F t x) = f x + t := by
+  obtain ⟨φ, W, F, hφ, hW, hIW, hφW, hF⟩ := exists_regularBandFlow hf hband
+  refine ⟨F, ?_⟩
+  intro x t hx ht
+  exact scalar_height_translation hφ hW hIW hφW (hF x) (by simp only [Flow.map_zero_apply]) hx ht
+
+private theorem MorseCancel.contMDiff_directionalDerivative {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M))) :
+    ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ (fun x => mvfderiv 𝓘(ℝ, E) f x (V x)) := by
+  have ht := (hf.contMDiff_tangentMap (m := ∞) (by simp)).comp hV
+  exact (contMDiff_snd_tangentBundle_modelSpace ℝ 𝓘(ℝ, ℝ)).comp ht
+
+private theorem MorseCancel.contMDiff_supported_division {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {χ D : M → ℝ}
+    (hχ : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ χ) (hD : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ D)
+    (hsupp : ∀ x ∈ tsupport χ, D x ≠ 0) : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ (fun x => χ x / D x) := by
+  intro x
+  by_cases hx : x ∈ tsupport χ
+  · exact (hχ x).div₀ (hD x) (hsupp x hx)
+  · apply (contMDiffAt_const (c := (0 : ℝ))).congr_of_eventuallyEq
+    filter_upwards [(isClosed_tsupport χ).isOpen_compl.mem_nhds hx] with y hy
+    simp only [image_eq_zero_of_notMem_tsupport hy, zero_div]
+
+private theorem MorseCancel.native_same_level_orbit_points {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {c : ℝ}
+    (hboundary : ∀ x, f x = c → mvfderiv 𝓘(ℝ, E) f x (V x) < 0) {x y : M} {s t : ℝ} (hx : f x = c)
+    (hy : f y = c) (hxy : F s x = F t y) : x = y := by
+  have hmove : F (s - t) x = y := by
+    calc
+      F (s - t) x = F (-t) (F s x) := by
+        rw [← F.map_add]
+        congr 1
+        ring
+      _ = F (-t) (F t y) := (congrArg (F (-t)) hxy)
+      _ = y := by rw [← F.map_add, neg_add_cancel, F.map_zero_apply]
+  have htime :=
+    Degree.FlowCancellation.flow_level_time_unique F hf.continuous
+      (contMDiff_directionalDerivative hf hV).continuous
+      (fun z u => Smale.FlowConstruction.hasDerivAt_comp_integralCurve hf (hF z) u) hboundary x
+      (hmove ▸ hy) (show f (F 0 x) = c by rw [F.map_zero_apply]; exact hx)
+  simpa only [htime, F.map_zero_apply] using hmove
+
+private abbrev MorseCancel.Model (m : ℕ) :=
+  ℝ × (Fin m → ℝ)
+
+private def MorseCancel.cubic {m : ℕ} (σ : Fin m → ℝ) (t : ℝ) (p : Model m) : ℝ :=
+  p.1 ^ 3 / 3 + t * p.1 + ∑ i, σ i * (p.2 i) ^ 2
+
+private def
+    MorseCancel.differential {m : ℕ} (σ : Fin m → ℝ) (t : ℝ) (p : Model m) : Model m →L[ℝ] ℝ :=
+  (p.1 ^ 2 + t) • ContinuousLinearMap.fst ℝ ℝ (Fin m → ℝ) +
+    ∑ i,
+      (2 * σ i * p.2 i) •
+        ((ContinuousLinearMap.proj i).comp (ContinuousLinearMap.snd ℝ ℝ (Fin m → ℝ)))
+
+private theorem MorseCancel.differential_apply {m : ℕ} (σ : Fin m → ℝ) (t : ℝ) (p v : Model m) :
+    differential σ t p v = (p.1 ^ 2 + t) * v.1 + ∑ i, 2 * σ i * p.2 i * v.2 i := by
+  simp [differential]
+
+private theorem MorseCancel.contDiff_cubic_family {m : ℕ} (σ : Fin m → ℝ) :
+    ContDiff ℝ ∞ (fun p : ℝ × Model m => cubic σ p.1 p.2) := by
+  unfold cubic
+  fun_prop
+
+private theorem
+    MorseCancel.contDiff_cubic {m : ℕ} (σ : Fin m → ℝ) (t : ℝ) : ContDiff ℝ ∞ (cubic σ t) :=
+  (contDiff_cubic_family σ).comp (contDiff_const.prodMk contDiff_id)
+
+private theorem MorseCancel.hasFDerivAt_cubic {m : ℕ} (σ : Fin m → ℝ) (t : ℝ) (p : Model m) :
+    HasFDerivAt (cubic σ t) (differential σ t p) p := by
+  have hx := (ContinuousLinearMap.fst ℝ ℝ (Fin m → ℝ)).hasFDerivAt (x := p)
+  have hy (i : Fin m) :=
+    ((ContinuousLinearMap.proj i).comp (ContinuousLinearMap.snd ℝ ℝ (Fin m → ℝ))).hasFDerivAt
+      (x := p)
+  have hq := HasFDerivAt.fun_sum (u := Finset.univ) (fun i _ => ((hy i).pow 2).const_mul (σ i))
+  convert! (((hx.pow 3).mul_const (1 / 3)).add (hx.const_mul t)).add hq using 1
+  · funext q
+    simp [cubic, div_eq_mul_inv]
+  · apply ContinuousLinearMap.ext
+    intro v
+    simp [differential]
+    ring_nf
+
+private theorem MorseCancel.fderiv_cubic {m : ℕ} (σ : Fin m → ℝ) (t : ℝ) (p : Model m) :
+    fderiv ℝ (cubic σ t) p = differential σ t p :=
+  (hasFDerivAt_cubic σ t p).fderiv
+
+private theorem MorseCancel.critical_iff {m : ℕ} (σ : Fin m → ℝ) (hσ : ∀ i, σ i ≠ 0) (t : ℝ)
+    (p : Model m) : fderiv ℝ (cubic σ t) p = 0 ↔ p.1 ^ 2 + t = 0 ∧ p.2 = 0 := by
+  rw [fderiv_cubic]
+  constructor
+  · intro h
+    have hx := congrArg (fun L : Model m →L[ℝ] ℝ => L (1, 0)) h
+    have hx' : p.1 ^ 2 + t = 0 := by simpa [differential_apply] using hx
+    refine ⟨hx', ?_⟩
+    funext i
+    have hy := congrArg (fun L : Model m →L[ℝ] ℝ => L (0, Pi.single i 1)) h
+    have hy' : 2 * σ i * p.2 i = 0 := by simpa [differential_apply, Pi.single_apply] using hy
+    exact (mul_eq_zero.mp hy').resolve_left (mul_ne_zero (by norm_num) (hσ i))
+  · rintro ⟨hx, hy⟩
+    apply ContinuousLinearMap.ext
+    intro v
+    simp [differential_apply, hx, hy]
+
+private theorem MorseCancel.cubic_zero_unique_critical {m : ℕ} (σ : Fin m → ℝ) (hσ : ∀ i, σ i ≠ 0)
+    (p : Model m) : fderiv ℝ (cubic σ 0) p = 0 ↔ p = 0 := by
+  rw [critical_iff σ hσ]
+  constructor
+  · rintro ⟨hx, hy⟩
+    have hx' : p.1 = 0 := by nlinarith [sq_nonneg p.1]
+    exact Prod.ext hx' hy
+  · rintro rfl
+    simp
+
+private theorem
+    MorseCancel.positive_parameter_no_critical {m : ℕ} (σ : Fin m → ℝ) (hσ : ∀ i, σ i ≠ 0)
+    {t : ℝ} (ht : 0 < t) (p : Model m) : fderiv ℝ (cubic σ t) p ≠ 0 := by
+  intro h
+  have hx := ((critical_iff σ hσ t p).mp h).1
+  nlinarith [sq_nonneg p.1]
+
+private theorem
+    MorseCancel.negative_parameter_critical_iff {m : ℕ} (σ : Fin m → ℝ) (hσ : ∀ i, σ i ≠ 0)
+    (a : ℝ) (p : Model m) : fderiv ℝ (cubic σ (-(a ^ 2))) p = 0 ↔ p = (a, 0) ∨ p = (-a, 0) := by
+  rw [critical_iff σ hσ]
+  constructor
+  · rintro ⟨hx, hy⟩
+    have hs : p.1 = a ∨ p.1 = -a := by
+      have he : (p.1 - a) * (p.1 + a) = 0 := by nlinarith
+      rcases mul_eq_zero.mp he with h | h
+      · exact Or.inl (by linarith)
+      · exact Or.inr (by linarith)
+    exact hs.elim (fun h => Or.inl (Prod.ext h hy)) (fun h => Or.inr (Prod.ext h hy))
+  · rintro (rfl | rfl) <;> simp
+
+private theorem MorseCancel.cubic_critical_values {m : ℕ} (σ : Fin m → ℝ) (a : ℝ) :
+    cubic σ (-(a ^ 2)) (a, 0) = -(2 * a ^ 3 / 3) ∧ cubic σ (-(a ^ 2)) (-a, 0) = 2 * a ^ 3 / 3 := by
+  constructor <;> simp [cubic] <;> ring
+
+private def MorseCancel.endpointCoordinate (a e s : ℝ) : ℝ :=
+  (s - e * a) * Real.sqrt (a + e * (s - e * a) / 3)
+
+private def MorseCancel.endpointDomain (a e : ℝ) : Set ℝ :=
+  {s | 0 < a + e * (s - e * a) / 3}
+
+private theorem MorseCancel.endpointDomain_open (a e : ℝ) : IsOpen (endpointDomain a e) := by
+  apply isOpen_lt continuous_const
+  fun_prop
+
+private theorem MorseCancel.endpoint_mem_domain {a : ℝ} (ha : 0 < a) (e : ℝ) :
+    e * a ∈ endpointDomain a e := by simpa [endpointDomain] using ha
+
+private theorem
+    MorseCancel.endpointCoordinate_center (a e : ℝ) : endpointCoordinate a e (e * a) = 0 := by
+  simp [endpointCoordinate]
+
+private theorem MorseCancel.contDiffOn_endpointCoordinate (a e : ℝ) :
+    ContDiffOn ℝ ∞ (endpointCoordinate a e) (endpointDomain a e) := by
+  intro s hs
+  have hlin : ContDiffAt ℝ ∞ (fun t : ℝ => t - e * a) s := contDiffAt_id.sub contDiffAt_const
+  exact
+    (hlin.mul
+        ((contDiffAt_const.add ((contDiffAt_const.mul hlin).div_const 3)).sqrt
+          (ne_of_gt hs))).contDiffWithinAt
+
+private theorem MorseCancel.hasDerivAt_endpointCoordinate {a : ℝ} (ha : 0 < a) (e : ℝ) :
+    HasDerivAt (endpointCoordinate a e) (Real.sqrt a) (e * a) := by
+  have hd :=
+    ((hasDerivAt_id (e * a)).sub_const (e * a)).mul
+      ((((hasDerivAt_id (e * a)).sub_const (e * a)).const_mul e).div_const 3 |>.const_add
+          a |>.sqrt
+        (by simpa using ha.ne'))
+  convert! hd using 1; simp []
+
+private theorem MorseCancel.cubic_endpoint_square {m : ℕ} (σ : Fin m → ℝ) (a e : ℝ) (he : e ^ 2 = 1)
+    {p : Model m} (hp : p.1 ∈ endpointDomain a e) :
+    cubic σ (-(a ^ 2)) p =
+      cubic σ (-(a ^ 2)) (e * a, 0) + e * endpointCoordinate a e p.1 ^ 2 + ∑ i, σ i * p.2 i ^ 2 :=
+  by
+  simp only [cubic, endpointCoordinate, Pi.zero_apply, zero_pow (by decide : 2 ≠ 0),
+    MulZeroClass.mul_zero, Finset.sum_const_zero, add_zero, mul_pow, Real.sq_sqrt (le_of_lt hp)]
+  rcases sq_eq_one_iff.mp he with h | h <;> rw [h] <;> ring
+
+private theorem MorseCancel.exists_endpoint_scalar_chart {a : ℝ} (ha : 0 < a) (e : ℝ) :
+    ∃ Φ : PartialDiffeomorph 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) ℝ ℝ ∞,
+      e * a ∈ Φ.source ∧
+        Φ.source ⊆ endpointDomain a e ∧ (Φ : ℝ → ℝ) = endpointCoordinate a e ∧ Φ (e * a) = 0 := by
+  have hd := (hasDerivAt_endpointCoordinate ha e).hasFDerivAt
+  have hi : Function.Injective (fderiv ℝ (endpointCoordinate a e) (e * a)) := by
+    rw [hd.fderiv]
+    intro x y hxy
+    change x * Real.sqrt a = y * Real.sqrt a at hxy
+    exact mul_right_cancel₀ (Real.sqrt_pos.mpr ha).ne' hxy
+  let A : ℝ ≃L[ℝ] ℝ :=
+    (LinearEquiv.ofInjectiveEndo (fderiv ℝ (endpointCoordinate a e) (e * a)).toLinearMap
+        hi).toContinuousLinearEquiv
+  obtain ⟨Φ, hp, hsub, hΦ⟩ :=
+    NoExotic.exists_partialDiffeomorph_of_contDiffOn (endpointDomain_open a e)
+      (endpoint_mem_domain ha e) (contDiffOn_endpointCoordinate a e) ⟨A, rfl⟩
+  exact ⟨Φ, hp, hsub, hΦ, by rw [hΦ, endpointCoordinate_center]⟩
+
+private def MorseCancel.scalarProductChart {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) ℝ ℝ ∞) :
+    PartialDiffeomorph 𝓘(ℝ, ℝ × V) 𝓘(ℝ, ℝ × V) (ℝ × V) (ℝ × V) ∞
+    where
+  toPartialEquiv := (Φ.toOpenPartialHomeomorph.prod (OpenPartialHomeomorph.refl V)).toPartialEquiv
+  open_source := Φ.open_source.prod isOpen_univ
+  open_target := Φ.open_target.prod isOpen_univ
+  contMDiffOn_toFun := by
+    have h : ContDiffOn ℝ ∞ (fun p : ℝ × V => (Φ p.1, p.2)) (Φ.source ×ˢ Set.univ) :=
+      (Φ.contMDiffOn_toFun.contDiffOn.comp contDiff_fst.contDiffOn (fun _ hp => hp.1)).prodMk
+        contDiff_snd.contDiffOn
+    exact h.contMDiffOn
+  contMDiffOn_invFun := by
+    have h : ContDiffOn ℝ ∞ (fun p : ℝ × V => (Φ.symm p.1, p.2)) (Φ.target ×ˢ Set.univ) :=
+      (Φ.contMDiffOn_invFun.contDiffOn.comp contDiff_fst.contDiffOn (fun _ hp => hp.1)).prodMk
+        contDiff_snd.contDiffOn
+    exact h.contMDiffOn
+
+private theorem
+    MorseCancel.exists_endpoint_product_chart {m : ℕ} (σ : Fin m → ℝ) {a : ℝ} (ha : 0 < a)
+    (e : ℝ) (he : e ^ 2 = 1) :
+    ∃ P : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, Model m) (Model m) (Model m) ∞,
+      (e * a, (0 : Fin m → ℝ)) ∈ P.source ∧
+        P (e * a, 0) = 0 ∧
+          (∀ p, (P p).2 = p.2) ∧
+            (∀ p ∈ P.source,
+              cubic σ (-(a ^ 2)) p =
+                cubic σ (-(a ^ 2)) (e * a, 0) + e * (P p).1 ^ 2 + ∑ i, σ i * (P p).2 i ^ 2) := by
+  obtain ⟨Φ, hp, hsource, hΦ, hcenter⟩ := exists_endpoint_scalar_chart ha e
+  let P := scalarProductChart (V := Fin m → ℝ) Φ
+  have hP (p : Model m) : P p = (endpointCoordinate a e p.1, p.2) :=
+    Prod.ext (congrFun hΦ p.1) rfl
+  refine ⟨P, ⟨hp, Set.mem_univ _⟩, ?_, fun _ => rfl, ?_⟩
+  · rw [hP, endpointCoordinate_center]
+    rfl
+  · intro p hp
+    rw [hP]
+    exact cubic_endpoint_square σ a e he (hsource hp.1)
+
+private def Degree.LocalFunctionReplacement.replace {E B H M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup B] [NormedSpace ℝ B] [TopologicalSpace H]
+    {I : ModelWithCorners ℝ B H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) I E M ∞) (f : M → ℝ) (b : E → ℝ) (y : M) : ℝ := by
+  classical exact if y ∈ Φ.target then b (Φ.symm y) else f y
+
+private theorem
+    Degree.LocalFunctionReplacement.replace_of_mem {E B H M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup B] [NormedSpace ℝ B] [TopologicalSpace H]
+    {I : ModelWithCorners ℝ B H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) I E M ∞) (f : M → ℝ) (b : E → ℝ) {y : M} (hy : y ∈ Φ.target) :
+    replace Φ f b y = b (Φ.symm y) := by simp [replace, hy]
+
+private theorem
+    Degree.LocalFunctionReplacement.replace_of_notMem {E B H M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup B] [NormedSpace ℝ B] [TopologicalSpace H]
+    {I : ModelWithCorners ℝ B H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) I E M ∞) (f : M → ℝ) (b : E → ℝ) {y : M} (hy : y ∉ Φ.target) :
+    replace Φ f b y = f y := by simp [replace, hy]
+
+private theorem
+    Degree.LocalFunctionReplacement.replace_chart {E B H M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup B] [NormedSpace ℝ B] [TopologicalSpace H]
+    {I : ModelWithCorners ℝ B H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) I E M ∞) (f : M → ℝ) (b : E → ℝ) {x : E} (hx : x ∈ Φ.source) :
+    replace Φ f b (Φ x) = b x := by
+  rw [replace_of_mem Φ f b (Φ.map_source' hx)]
+  exact congrArg b (Φ.left_inv' hx)
+
+private theorem Degree.LocalFunctionReplacement.replace_germ_chart {E B H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ B H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) I E M ∞) (f : M → ℝ) (b : E → ℝ) {y : M} (hy : y ∈ Φ.target) :
+    replace Φ f b =ᶠ[𝓝 y] b ∘ Φ.symm := by
+  filter_upwards [Φ.open_target.mem_nhds hy] with z hz
+  exact replace_of_mem Φ f b hz
+
+private theorem
+    Degree.LocalFunctionReplacement.replace_self {E B H M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup B] [NormedSpace ℝ B] [TopologicalSpace H]
+    {I : ModelWithCorners ℝ B H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) I E M ∞) {f : M → ℝ} {b : E → ℝ}
+    (hmodel : ∀ x ∈ Φ.source, f (Φ x) = b x) : replace Φ f b = f := by
+  funext y
+  by_cases hy : y ∈ Φ.target
+  · rw [replace_of_mem Φ f b hy]
+    exact (hmodel (Φ.symm y) (Φ.map_target' hy)).symm.trans (congrArg f (Φ.right_inv' hy))
+  · exact replace_of_notMem Φ f b hy
+
+private theorem Degree.LocalFunctionReplacement.replace_eq_off_support {E B H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ B H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) I E M ∞) {f : M → ℝ} {b₀ b₁ : E → ℝ} {K : Set E}
+    (hmodel : ∀ x ∈ Φ.source, f (Φ x) = b₀ x) (hfix : ∀ x ∉ K, b₁ x = b₀ x) {y : M}
+    (hy : y ∉ Φ '' K) : replace Φ f b₁ y = f y := by
+  by_cases hyt : y ∈ Φ.target
+  · have hx : Φ.symm y ∉ K := fun h => hy ⟨Φ.symm y, h, Φ.right_inv' hyt⟩
+    rw [replace_of_mem Φ f b₁ hyt, hfix _ hx]
+    exact (hmodel (Φ.symm y) (Φ.map_target' hyt)).symm.trans (congrArg f (Φ.right_inv' hyt))
+  · exact replace_of_notMem Φ f b₁ hyt
+
+private theorem Degree.LocalFunctionReplacement.replace_germ_off_support {E B H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ B H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) I E M ∞) [T2Space M] {f : M → ℝ} {b₀ b₁ : E → ℝ} {K : Set E}
+    (hK : IsCompact K) (hKΦ : K ⊆ Φ.source) (hmodel : ∀ x ∈ Φ.source, f (Φ x) = b₀ x)
+    (hfix : ∀ x ∉ K, b₁ x = b₀ x) {y : M} (hy : y ∉ Φ '' K) : replace Φ f b₁ =ᶠ[𝓝 y] f := by
+  have hc : IsClosed (Φ '' K) :=
+    (hK.image_of_continuousOn (Φ.contMDiffOn_toFun.continuousOn.mono hKΦ)).isClosed
+  filter_upwards [hc.isOpen_compl.mem_nhds hy] with z hz
+  exact replace_eq_off_support Φ hmodel hfix hz
+
+private theorem
+    Degree.LocalFunctionReplacement.contMDiff_replace {E B H M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup B] [NormedSpace ℝ B] [TopologicalSpace H]
+    {I : ModelWithCorners ℝ B H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) I E M ∞) [T2Space M] {f : M → ℝ} {b₀ b₁ : E → ℝ} {K : Set E}
+    (hf : ContMDiff I 𝓘(ℝ, ℝ) ∞ f) (hb : ContDiff ℝ ∞ b₁) (hK : IsCompact K) (hKΦ : K ⊆ Φ.source)
+    (hmodel : ∀ x ∈ Φ.source, f (Φ x) = b₀ x) (hfix : ∀ x ∉ K, b₁ x = b₀ x) :
+    ContMDiff I 𝓘(ℝ, ℝ) ∞ (replace Φ f b₁) := by
+  intro y
+  by_cases hy : y ∈ Φ.target
+  · have hs :=
+      hb.contMDiff.contMDiffAt.comp y
+        (Φ.contMDiffOn_invFun.contMDiffAt (Φ.open_target.mem_nhds hy))
+    exact hs.congr_of_eventuallyEq (replace_germ_chart Φ f b₁ hy)
+  · have hnot : y ∉ Φ '' K := by
+      rintro ⟨x, hx, rfl⟩
+      exact hy (Φ.map_source' (hKΦ hx))
+    exact
+      hf.contMDiffAt.congr_of_eventuallyEq (replace_germ_off_support Φ hK hKΦ hmodel hfix hnot)
+
+private theorem Degree.LocalFunctionReplacement.replace_critical_iff {E B H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ B H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) I E M ∞) (f : M → ℝ) {b : E → ℝ} (hb : ContDiff ℝ ∞ b) {y : M}
+    (hy : y ∈ Φ.target) : mfderiv I 𝓘(ℝ, ℝ) (replace Φ f b) y = 0 ↔ fderiv ℝ b (Φ.symm y) = 0 := by
+  have hΦ : IsLocalDiffeomorphAt I 𝓘(ℝ, E) ∞ Φ.symm y := ⟨Φ.symm, hy, fun _ _ => rfl⟩
+  have hsurj := (hΦ.mfderivToContinuousLinearEquiv (by simp)).surjective
+  rw [(replace_germ_chart Φ f b hy).mfderiv_eq,
+    mfderiv_comp y (hb.contMDiff.mdifferentiableAt (by simp))
+      (Φ.symm.mdifferentiableAt (by simp) hy),
+    mfderiv_eq_fderiv]
+  constructor
+  · intro h
+    apply ContinuousLinearMap.ext
+    intro v
+    obtain ⟨w, hw⟩ := hsurj v
+    have he := congrArg (fun L : TangentSpace I y →L[ℝ] ℝ => L w) h
+    change fderiv ℝ b (Φ.symm y) (mfderiv I 𝓘(ℝ, E) Φ.symm y w) = 0 at he
+    change mfderiv I 𝓘(ℝ, E) Φ.symm y w = v at hw
+    simpa only [hw, zero_apply] using he
+  · intro h
+    rw [h]
+    rfl
+
+private def MorseCancel.cubicDescent {m : ℕ} (σ : Fin m → ℝ) (t : ℝ) (p : Model m) : Model m :=
+  (-(p.1 ^ 2 + t), fun i => -σ i * p.2 i)
+
+private theorem
+    MorseCancel.differential_cubicDescent {m : ℕ} (σ : Fin m → ℝ) (t : ℝ) (p : Model m) :
+    differential σ t p (cubicDescent σ t p) = -(p.1 ^ 2 + t) ^ 2 - 2 * ∑ i, (σ i * p.2 i) ^ 2 := by
+  rw [differential_apply]
+  simp only [cubicDescent]
+  have hs : (∑ i, 2 * σ i * p.2 i * (-σ i * p.2 i)) = -2 * ∑ i, (σ i * p.2 i) ^ 2 := by
+    rw [Finset.mul_sum]
+    apply Finset.sum_congr rfl
+    intro i _
+    ring
+  rw [hs]
+  ring
+
+private theorem MorseCancel.cubicDescent_strict {m : ℕ} (σ : Fin m → ℝ) {t : ℝ} {p : Model m}
+    (hp : fderiv ℝ (cubic σ t) p ≠ 0) : fderiv ℝ (cubic σ t) p (cubicDescent σ t p) < 0 := by
+  rw [fderiv_cubic, differential_cubicDescent]
+  by_contra hh
+  have hsum : 0 ≤ ∑ i, (σ i * p.2 i) ^ 2 := Finset.sum_nonneg (fun _ _ => sq_nonneg _)
+  have hx : p.1 ^ 2 + t = 0 := by nlinarith [sq_nonneg (p.1 ^ 2 + t)]
+  have hz : (∑ i, (σ i * p.2 i) ^ 2) = 0 := by
+    have hle := le_of_not_gt hh
+    rw [hx] at hle
+    linarith
+  have hy (i : Fin m) : σ i * p.2 i = 0 := by
+    have hi :=
+      (Finset.sum_eq_zero_iff_of_nonneg (fun i _ => sq_nonneg (σ i * p.2 i))).mp hz i
+        (Finset.mem_univ i)
+    exact sq_eq_zero_iff.mp hi
+  apply hp
+  rw [fderiv_cubic]
+  apply ContinuousLinearMap.ext
+  intro v
+  rw [differential_apply, hx]
+  simp only [MulZeroClass.zero_mul, zero_add, zero_apply]
+  apply Finset.sum_eq_zero
+  intro i _
+  calc
+    2 * σ i * p.2 i * v.2 i = 2 * (σ i * p.2 i) * v.2 i := by ring
+    _ = 0 := by rw [hy, MulZeroClass.mul_zero, MulZeroClass.zero_mul]
+
+private theorem
+    MorseCancel.cubicDescent_zero_of_critical {m : ℕ} (σ : Fin m → ℝ) {t : ℝ} {p : Model m}
+    (hp : fderiv ℝ (cubic σ t) p = 0) : cubicDescent σ t p = 0 := by
+  rw [fderiv_cubic] at hp
+  have hx := congrArg (fun L : Model m →L[ℝ] ℝ => L (1, 0)) hp
+  have hx' : p.1 ^ 2 + t = 0 := by simpa [differential_apply] using hx
+  apply Prod.ext
+  · simpa only [cubicDescent, Prod.fst_zero, neg_eq_zero] using hx'
+  · funext i
+    have hi := congrArg (fun L : Model m →L[ℝ] ℝ => L (0, Pi.single i 1)) hp
+    have hi' : 2 * σ i * p.2 i = 0 := by simpa [differential_apply, Pi.single_apply] using hi
+    change -σ i * p.2 i = 0
+    nlinarith
+
+private def
+    MorseCancel.nativeCubicDescent {m : ℕ} (σ : Fin m → ℝ) {B M : Type*} [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [TopologicalSpace M] [ChartedSpace B M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, B) (Model m) M ∞) (t : ℝ) :
+    (x : M) → TangentSpace 𝓘(ℝ, B) x :=
+  Smale.FlowConstruction.partialChartField Φ.symm (cubicDescent σ t)
+
+private def MorseCancel.endpointFieldCoordinate (a e s : ℝ) : ℝ :=
+  (s - e * a) / (a + e * s)
+
+private def MorseCancel.endpointFieldDomain (a e : ℝ) : Set ℝ :=
+  {s | 0 < a + e * s}
+
+private theorem
+    MorseCancel.endpointFieldDomain_open (a e : ℝ) : IsOpen (endpointFieldDomain a e) := by
+  apply isOpen_lt continuous_const
+  fun_prop
+
+private theorem MorseCancel.endpointField_mem_domain {a : ℝ} (ha : 0 < a) {e : ℝ} (he : e ^ 2 = 1) :
+    e * a ∈ endpointFieldDomain a e := by
+  change 0 < a + e * (e * a)
+  have h : e * (e * a) = a := by rw [← mul_assoc, ← pow_two, he, one_mul]
+  rw [h]
+  linarith
+
+private theorem MorseCancel.endpointFieldCoordinate_center (a e : ℝ) :
+    endpointFieldCoordinate a e (e * a) = 0 := by simp [endpointFieldCoordinate]
+
+private theorem MorseCancel.contDiffOn_endpointFieldCoordinate (a e : ℝ) :
+    ContDiffOn ℝ ∞ (endpointFieldCoordinate a e) (endpointFieldDomain a e) := by
+  intro s hs
+  exact
+    ((contDiffAt_id.sub contDiffAt_const).div
+        (contDiffAt_const.add (contDiffAt_const.mul contDiffAt_id))
+        (ne_of_gt hs)).contDiffWithinAt
+
+private theorem
+    MorseCancel.hasDerivAt_endpointFieldCoordinate (a : ℝ) {e : ℝ} (he : e ^ 2 = 1) {s : ℝ}
+    (hs : s ∈ endpointFieldDomain a e) :
+    HasDerivAt (endpointFieldCoordinate a e) (2 * a / (a + e * s) ^ 2) s := by
+  have hd :=
+    ((hasDerivAt_id s).sub_const (e * a)).div (((hasDerivAt_id s).const_mul e).const_add a)
+      (ne_of_gt hs)
+  convert! hd using 1
+  congr 1
+  rcases sq_eq_one_iff.mp he with h | h <;> rw [h] <;> ring
+
+private theorem
+    MorseCancel.endpointFieldCoordinate_pushforward (a : ℝ) {e : ℝ} (he : e ^ 2 = 1) {s : ℝ}
+    (hs : s ∈ endpointFieldDomain a e) :
+    deriv (endpointFieldCoordinate a e) s * (a ^ 2 - s ^ 2) =
+      (-2 * e * a) * endpointFieldCoordinate a e s := by
+  rw [(hasDerivAt_endpointFieldCoordinate a he hs).deriv]
+  unfold endpointFieldCoordinate
+  have hn : a + e * s ≠ 0 := ne_of_gt hs
+  field_simp
+  rcases sq_eq_one_iff.mp he with h | h <;> rw [h] <;> ring
+
+private theorem MorseCancel.exists_endpoint_field_scalar_chart {a : ℝ} (ha : 0 < a) {e : ℝ}
+    (he : e ^ 2 = 1) :
+    ∃ P : PartialDiffeomorph 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) ℝ ℝ ∞,
+      e * a ∈ P.source ∧
+        P.source ⊆ endpointFieldDomain a e ∧
+          (P : ℝ → ℝ) = endpointFieldCoordinate a e ∧ P (e * a) = 0 := by
+  have hm := endpointField_mem_domain ha he
+  have hd := (hasDerivAt_endpointFieldCoordinate a he hm).hasFDerivAt
+  have hn : 2 * a / (a + e * (e * a)) ^ 2 ≠ 0 :=
+    div_ne_zero (mul_ne_zero (by norm_num) ha.ne') (pow_ne_zero _ (ne_of_gt hm))
+  have hi : Function.Injective (fderiv ℝ (endpointFieldCoordinate a e) (e * a)) := by
+    rw [hd.fderiv]
+    intro x y hxy
+    change x * (2 * a / (a + e * (e * a)) ^ 2) = y * (2 * a / (a + e * (e * a)) ^ 2) at hxy
+    exact mul_right_cancel₀ hn hxy
+  let A : ℝ ≃L[ℝ] ℝ :=
+    (LinearEquiv.ofInjectiveEndo (fderiv ℝ (endpointFieldCoordinate a e) (e * a)).toLinearMap
+        hi).toContinuousLinearEquiv
+  obtain ⟨P, hp, hsub, hP⟩ :=
+    NoExotic.exists_partialDiffeomorph_of_contDiffOn (endpointFieldDomain_open a e) hm
+      (contDiffOn_endpointFieldCoordinate a e) ⟨A, rfl⟩
+  exact ⟨P, hp, hsub, hP, by rw [hP, endpointFieldCoordinate_center]⟩
+
+private def
+    MorseCancel.endpointLinearField {m : ℕ} (σ : Fin m → ℝ) (a e : ℝ) (p : Model m) : Model m :=
+  ((-2 * e * a) * p.1, fun i => -σ i * p.2 i)
+
+private def MorseCancel.endpointFieldProduct {m : ℕ} (a e : ℝ) (p : Model m) : Model m :=
+  (endpointFieldCoordinate a e p.1, p.2)
+
+private theorem
+    MorseCancel.fderiv_endpointFieldProduct_cubic {m : ℕ} (σ : Fin m → ℝ) (a : ℝ) {e : ℝ}
+    (he : e ^ 2 = 1) {p : Model m} (hp : p.1 ∈ endpointFieldDomain a e) :
+    fderiv ℝ (endpointFieldProduct a e) p (cubicDescent σ (-(a ^ 2)) p) =
+      endpointLinearField σ a e (endpointFieldProduct a e p) := by
+  have hd :=
+    ((hasDerivAt_endpointFieldCoordinate a he hp).comp_hasFDerivAt p
+          (hasFDerivAt_fst (𝕜 := ℝ) (p := p))).prodMk
+      (hasFDerivAt_snd (𝕜 := ℝ) (p := p))
+  change HasFDerivAt (endpointFieldProduct a e) _ p at hd
+  rw [hd.fderiv]
+  apply Prod.ext
+  · change
+      (2 * a / (a + e * p.1) ^ 2) * (-(p.1 ^ 2 + -(a ^ 2))) =
+        (-2 * e * a) * endpointFieldCoordinate a e p.1
+    have hh := endpointFieldCoordinate_pushforward a he hp
+    rw [(hasDerivAt_endpointFieldCoordinate a he hp).deriv] at hh
+    convert! hh using 1; ring
+  · rfl
+
+private theorem MorseCancel.exists_endpoint_field_product_chart {m : ℕ} (σ : Fin m → ℝ) {a : ℝ}
+    (ha : 0 < a) {e : ℝ} (he : e ^ 2 = 1) :
+    ∃ P : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, Model m) (Model m) (Model m) ∞,
+      (e * a, (0 : Fin m → ℝ)) ∈ P.source ∧
+        P (e * a, 0) = 0 ∧
+          (P : Model m → Model m) = endpointFieldProduct a e ∧
+            ∀ p ∈ P.source,
+              fderiv ℝ P p (cubicDescent σ (-(a ^ 2)) p) = endpointLinearField σ a e (P p) := by
+  obtain ⟨Q, hq, hsub, hQ, hzero⟩ := exists_endpoint_field_scalar_chart ha he
+  let P := scalarProductChart (V := Fin m → ℝ) Q
+  have hP : (P : Model m → Model m) = endpointFieldProduct a e := by
+    funext p
+    exact Prod.ext (congrFun hQ p.1) rfl
+  refine ⟨P, ⟨hq, Set.mem_univ _⟩, ?_, hP, ?_⟩
+  · rw [hP]
+    simp [endpointFieldProduct, endpointFieldCoordinate_center]
+  · intro p hp
+    rw [hP]
+    exact fderiv_endpointFieldProduct_cubic σ a he (hsub hp.1)
+
+private theorem
+    MorseCancel.partialChartField_of_model_conjugacy {D F E M : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup F] [NormedSpace ℝ F] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (P : PartialDiffeomorph 𝓘(ℝ, D) 𝓘(ℝ, F) D F ∞) (Q : PartialDiffeomorph 𝓘(ℝ, F) 𝓘(ℝ, E) F M ∞)
+    (W : D → D) (U : F → F) (hpush : ∀ p ∈ P.source, fderiv ℝ P p (W p) = U (P p)) {x : M}
+    (hx : x ∈ (P.trans Q).target) :
+    Smale.FlowConstruction.partialChartField (P.trans Q).symm W x =
+      Smale.FlowConstruction.partialChartField Q.symm U x := by
+  have hxQ : x ∈ Q.target := hx.1
+  have hxP : Q.symm x ∈ P.target := hx.2
+  have hdiff : P.symm.toOpenPartialHomeomorph.MDifferentiable 𝓘(ℝ, F) 𝓘(ℝ, D) :=
+    ⟨P.symm.mdifferentiableOn (by simp), P.mdifferentiableOn (by simp)⟩
+  have hinv : (mfderivWithin 𝓘(ℝ, F) 𝓘(ℝ, D) P.symm Set.univ (Q.symm x)).IsInvertible := by
+    rw [mfderivWithin_univ]
+    exact ⟨hdiff.mfderiv hxP, rfl⟩
+  have hh :=
+    VectorField.mpullbackWithin_comp_of_left (I := 𝓘(ℝ, E)) (I' := 𝓘(ℝ, F)) (I'' := 𝓘(ℝ, D)) (f :=
+      (Q.symm : M → F)) (g := (P.symm : F → D)) (V := fun y =>
+      (NormedSpace.fromTangentSpace y).symm (W y)) (s := Set.univ) (t := Set.univ)
+      (Q.symm.mdifferentiableAt (by simp) hxQ).mdifferentiableWithinAt (Set.mapsTo_univ _ _)
+      (uniqueMDiffWithinAt_univ 𝓘(ℝ, E)) hinv
+  simp only [VectorField.mpullbackWithin_univ] at hh
+  have hv :
+    VectorField.mpullback 𝓘(ℝ, F) 𝓘(ℝ, D) P.symm
+        (fun y => (NormedSpace.fromTangentSpace y).symm (W y)) (Q.symm x) =
+      (NormedSpace.fromTangentSpace (Q.symm x)).symm (U (Q.symm x)) := by
+    change Smale.FlowConstruction.partialChartField P.symm W (Q.symm x) = _
+    rw [Smale.FlowConstruction.partialChartField_eq_mfderiv_symm P.symm W hxP]
+    rw [mfderiv_eq_fderiv]
+    change fderiv ℝ P (P.symm (Q.symm x)) (W (P.symm (Q.symm x))) = U (Q.symm x)
+    have hp : P.symm (Q.symm x) ∈ P.source := P.map_target' hxP
+    rw [hpush (P.symm (Q.symm x)) hp]
+    exact congrArg U (P.right_inv' hxP)
+  change
+    VectorField.mpullback 𝓘(ℝ, E) 𝓘(ℝ, D) (P.symm ∘ Q.symm)
+        (fun y => (NormedSpace.fromTangentSpace y).symm (W y)) x =
+      _
+  rw [hh, VectorField.mpullback_apply, hv]
+  rfl
+
+private theorem MorseCancel.exists_native_cubic_field_endpoint {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {m : ℕ} (σ : Fin m → ℝ) {a : ℝ}
+    (ha : 0 < a) {e : ℝ} (he : e ^ 2 = 1)
+    (Q : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞) (h0 : (0 : Model m) ∈ Q.source)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hmodel :
+      ∀ x ∈ Q.target,
+        V x = Smale.FlowConstruction.partialChartField Q.symm (endpointLinearField σ a e) x) :
+    ∃ Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞,
+      (e * a, (0 : Fin m → ℝ)) ∈ Φ.source ∧
+        Φ (e * a, 0) = Q 0 ∧
+          Φ.target ⊆ Q.target ∧
+            (∀ x ∈ Φ.target, V x = nativeCubicDescent σ Φ (-(a ^ 2)) x) ∧
+              (Φ : Model m → M) = Q ∘ endpointFieldProduct a e := by
+  obtain ⟨P, hp, hcenter, hP, hpush⟩ := exists_endpoint_field_product_chart σ ha he
+  let Φ := P.trans Q
+  have hsource : (e * a, (0 : Fin m → ℝ)) ∈ Φ.source := by
+    change (e * a, (0 : Fin m → ℝ)) ∈ P.source ∧ P (e * a, 0) ∈ Q.source
+    exact ⟨hp, hcenter.symm ▸ h0⟩
+  refine ⟨Φ, hsource, ?_, fun _ hx => hx.1, ?_, ?_⟩
+  · change Q (P (e * a, 0)) = Q 0
+    rw [hcenter]
+  · intro x hx
+    rw [hmodel x hx.1]
+    exact
+      (partialChartField_of_model_conjugacy P Q (cubicDescent σ (-(a ^ 2)))
+          (endpointLinearField σ a e) hpush hx).symm
+  · change Q ∘ P = Q ∘ endpointFieldProduct a e
+    rw [hP]
+
+private def
+    MorseCancel.splitLinear {m n : ℕ} (ρ : Option (Fin m) ≃ Fin n) : Model m ≃ₗ[ℝ] (Fin n → ℝ)
+    where
+  toFun p j := (ρ.symm j).elim p.1 p.2
+  invFun f := (f (ρ Option.none), fun i => f (ρ (Option.some i)))
+  left_inv
+    p := by
+    apply Prod.ext
+    · simp
+    · funext i
+      simp
+  right_inv
+    f := by
+    funext j
+    have hj := ρ.apply_symm_apply j
+    cases h : ρ.symm j with
+    | none => simpa only [h, Option.elim_none] using congrArg f hj
+    | some i => simpa only [h, Option.elim_some] using congrArg f hj
+  map_add' p
+    q := by
+    funext j
+    cases h : ρ.symm j <;> simp [h]
+  map_smul' t
+    p := by
+    funext j
+    cases h : ρ.symm j <;> simp [h]
+
+private def
+    MorseCancel.splitEquiv {m n : ℕ} (ρ : Option (Fin m) ≃ Fin n) : Model m ≃L[ℝ] (Fin n → ℝ) :=
+  (splitLinear ρ).toContinuousLinearEquiv
+
+private theorem
+    MorseCancel.splitEquiv_apply_none {m n : ℕ} (ρ : Option (Fin m) ≃ Fin n) (p : Model m) :
+    splitEquiv ρ p (ρ Option.none) = p.1 := by
+  change (ρ.symm (ρ Option.none)).elim p.1 p.2 = p.1
+  simp
+
+private theorem
+    MorseCancel.splitEquiv_apply_some {m n : ℕ} (ρ : Option (Fin m) ≃ Fin n) (p : Model m)
+    (i : Fin m) : splitEquiv ρ p (ρ (Option.some i)) = p.2 i := by
+  change (ρ.symm (ρ (Option.some i))).elim p.1 p.2 = p.2 i
+  simp
+
+private theorem MorseCancel.split_signed_sum {m n : ℕ} (ρ : Option (Fin m) ≃ Fin n) (w : Fin n → ℝ)
+    (p : Model m) :
+    (∑ j, w j * splitEquiv ρ p j ^ 2) =
+      w (ρ Option.none) * p.1 ^ 2 + ∑ i, w (ρ (Option.some i)) * p.2 i ^ 2 := by
+  rw [← ρ.sum_comp]
+  simp only [Fintype.sum_option, splitEquiv_apply_none, splitEquiv_apply_some]
+
+private theorem MorseCancel.splitEquiv_endpoint_field {m n : ℕ} (ρ : Option (Fin m) ≃ Fin n)
+    (w : Fin n → ℝ) (p : Model m) :
+    splitEquiv ρ
+        (endpointLinearField (fun i => w (ρ (Option.some i))) (1 / 2) (w (ρ Option.none)) p) =
+      fun j => -w j * splitEquiv ρ p j := by
+  funext j
+  obtain ⟨k, rfl⟩ := ρ.surjective j
+  cases k with
+  | none =>
+    rw [splitEquiv_apply_none, splitEquiv_apply_none]
+    change (-2 * w (ρ Option.none) * (1 / 2)) * p.1 = -w (ρ Option.none) * p.1
+    ring
+  | some i =>
+    rw [splitEquiv_apply_some, splitEquiv_apply_some]
+    rfl
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.splitCoordinates_signed_descent {ι : Type*} [Fintype ι] (w : ι → ℝ)
+    (hw : ∀ i, w i = -1 ∨ w i = 1) (z : ι → ℝ) :
+    Smale.MorseHandle.splitCoordinates w (fun i => -w i * z i) =
+      Smale.MorseHandle.descent (Smale.MorseHandle.splitCoordinates w z) := by
+  apply Prod.ext
+  · ext i
+    change -w i.1 * z i.1 = z i.1
+    rw [i.2]
+    ring
+  · ext i
+    change -w i.1 * z i.1 = -z i.1
+    rw [(hw i.1).resolve_left i.2]
+    ring
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    MorseCancel.selectedMorseFieldEquiv {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {x : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) {m : ℕ}
+    (ρ : Option (Fin m) ≃ Fin (Module.finrank ℝ E)) :
+    Model m ≃L[ℝ] (c.NegativeCoordinates × c.PositiveCoordinates) :=
+  (splitEquiv ρ).trans (Smale.MorseHandle.splitCoordinates c.weights)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.selectedMorseFieldEquiv_descent {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {x : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) {m : ℕ}
+    (ρ : Option (Fin m) ≃ Fin (Module.finrank ℝ E)) (p : Model m) :
+    selectedMorseFieldEquiv c ρ
+        (endpointLinearField (fun i => c.weights (ρ (Option.some i))) (1 / 2)
+          (c.weights (ρ Option.none)) p) =
+      Smale.MorseHandle.descent (selectedMorseFieldEquiv c ρ p) := by
+  change
+    Smale.MorseHandle.splitCoordinates c.weights (splitEquiv ρ _) =
+      Smale.MorseHandle.descent (Smale.MorseHandle.splitCoordinates c.weights (splitEquiv ρ p))
+  rw [splitEquiv_endpoint_field]
+  exact splitCoordinates_signed_descent c.weights c.signs (splitEquiv ρ p)
+
+private def MorseCancel.transverseFieldChange {m : ℕ} (T : (Fin m → ℝ) ≃L[ℝ] (Fin m → ℝ)) :
+    Model m ≃L[ℝ] Model m :=
+  (ContinuousLinearEquiv.refl ℝ ℝ).prodCongr T
+
+private theorem MorseCancel.transverseFieldChange_cubicDescent {m : ℕ} (σ : Fin m → ℝ)
+    (T : (Fin m → ℝ) ≃L[ℝ] (Fin m → ℝ))
+    (hcomm : ∀ z, T (fun i => σ i * z i) = fun i => σ i * T z i) (t : ℝ) (p : Model m) :
+    transverseFieldChange T (cubicDescent σ t p) = cubicDescent σ t (transverseFieldChange T p) :=
+  by
+  apply Prod.ext
+  · rfl
+  · change T (fun i => -σ i * p.2 i) = fun i => -σ i * T p.2 i
+    have hleft : (fun i => -σ i * p.2 i) = -(fun i => σ i * p.2 i) := by
+      funext i
+      simp only [Pi.neg_apply, neg_mul]
+    rw [hleft, map_neg, hcomm]
+    funext i
+    simp only [Pi.neg_apply, neg_mul]
+
+private def MorseCancel.splitTransverseChange {m : ℕ} {A B : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] (e : (Fin m → ℝ) ≃L[ℝ] (A × B))
+    (P : A ≃L[ℝ] A) (S : B ≃L[ℝ] B) : (Fin m → ℝ) ≃L[ℝ] (Fin m → ℝ) :=
+  (e.trans (P.prodCongr S)).trans e.symm
+
+private theorem
+    MorseCancel.splitTransverseChange_commutes {m : ℕ} {A B : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] (σ : Fin m → ℝ)
+    (e : (Fin m → ℝ) ≃L[ℝ] (A × B)) (α β : ℝ)
+    (he : ∀ z, e (fun i => σ i * z i) = (α • (e z).1, β • (e z).2)) (P : A ≃L[ℝ] A)
+    (S : B ≃L[ℝ] B) (z : Fin m → ℝ) :
+    splitTransverseChange e P S (fun i => σ i * z i) = fun i =>
+      σ i * splitTransverseChange e P S z i := by
+  apply e.injective
+  simp only [splitTransverseChange, ContinuousLinearEquiv.trans_apply, e.apply_symm_apply, he,
+    ContinuousLinearEquiv.prodCongr_apply, map_smul]
+
+private theorem MorseCancel.morse_block_change_descent {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] (A : N ≃L[ℝ] N) (B : P ≃L[ℝ] P)
+    (z : N × P) :
+    (A.prodCongr B) (Smale.MorseHandle.descent z) =
+      Smale.MorseHandle.descent ((A.prodCongr B) z) := by
+  apply Prod.ext
+  · rfl
+  · change B (-z.2) = -B z.2
+    exact B.map_neg _
+
+private theorem MorseCancel.exists_positive_ray_alignment {D : Type*} [NormedAddCommGroup D]
+    [InnerProductSpace ℝ D] {u v : D} (hu : u ≠ 0) (hv : v ≠ 0) :
+    ∃ (r : ℝ) (A : D ≃ₗᵢ[ℝ] D), 0 < r ∧ A (r • u) = v ∧ ∀ s : ℝ, A ((s * r) • u) = s • v := by
+  let r := ‖v‖ / ‖u‖
+  have hr : 0 < r := div_pos (norm_pos_iff.mpr hv) (norm_pos_iff.mpr hu)
+  have hnorm : ‖r • u‖ = ‖v‖ := by
+    rw [norm_smul, Real.norm_eq_abs, abs_of_pos hr]
+    exact div_mul_cancel₀ ‖v‖ (norm_ne_zero_iff.mpr hu)
+  let A : D ≃ₗᵢ[ℝ] D := (ℝ ∙ (r • u - v))ᗮ.reflection
+  have hA : A (r • u) = v := Submodule.reflection_sub hnorm
+  refine ⟨r, A, hr, hA, ?_⟩
+  intro s
+  rw [← smul_smul, A.map_smul, hA]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.selectedMorseFieldEquiv_axis_ne_zero {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {x : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) {m : ℕ}
+    (ρ : Option (Fin m) ≃ Fin (Module.finrank ℝ E)) :
+    selectedMorseFieldEquiv c ρ (1, (0 : Fin m → ℝ)) ≠ 0 := by
+  intro h
+  have hh :=
+    (selectedMorseFieldEquiv c ρ).injective
+      (h.trans (map_zero (selectedMorseFieldEquiv c ρ)).symm)
+  have h1 := congrArg Prod.fst hh
+  norm_num at h1
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.selectedMorseFieldEquiv_negative_axis {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {x : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) {m : ℕ}
+    (ρ : Option (Fin m) ≃ Fin (Module.finrank ℝ E)) (he : c.weights (ρ Option.none) = -1) :
+    (selectedMorseFieldEquiv c ρ (1, (0 : Fin m → ℝ))).2 = 0 ∧
+      (selectedMorseFieldEquiv c ρ (1, (0 : Fin m → ℝ))).1 ≠ 0 := by
+  let z := selectedMorseFieldEquiv c ρ (1, (0 : Fin m → ℝ))
+  have hw :
+    endpointLinearField (fun i => c.weights (ρ (Option.some i))) (1 / 2)
+        (c.weights (ρ Option.none)) (1, (0 : Fin m → ℝ)) =
+      (1, 0) := by ext i <;> simp [endpointLinearField, he]
+  have hh := selectedMorseFieldEquiv_descent c ρ (1, (0 : Fin m → ℝ))
+  rw [hw] at hh
+  have h2 : z.2 = -z.2 := congrArg Prod.snd hh
+  have hs : (2 : ℝ) • z.2 = 0 := by
+    rw [two_smul]
+    exact (congrArg (fun v => v + z.2) h2).trans (neg_add_cancel z.2)
+  have hz : z.2 = 0 := (smul_eq_zero.mp hs).resolve_left (by norm_num)
+  refine ⟨hz, ?_⟩
+  intro h1
+  exact selectedMorseFieldEquiv_axis_ne_zero c ρ (Prod.ext h1 hz)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.selectedMorseFieldEquiv_positive_axis {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {x : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) {m : ℕ}
+    (ρ : Option (Fin m) ≃ Fin (Module.finrank ℝ E)) (he : c.weights (ρ Option.none) = 1) :
+    (selectedMorseFieldEquiv c ρ (1, (0 : Fin m → ℝ))).1 = 0 ∧
+      (selectedMorseFieldEquiv c ρ (1, (0 : Fin m → ℝ))).2 ≠ 0 := by
+  let z := selectedMorseFieldEquiv c ρ (1, (0 : Fin m → ℝ))
+  have hw :
+    endpointLinearField (fun i => c.weights (ρ (Option.some i))) (1 / 2)
+        (c.weights (ρ Option.none)) (1, (0 : Fin m → ℝ)) =
+      -(1, 0) := by ext i <;> simp [endpointLinearField, he]
+  have hh := selectedMorseFieldEquiv_descent c ρ (1, (0 : Fin m → ℝ))
+  rw [hw, map_neg] at hh
+  have h1 : z.1 = -z.1 := (congrArg Prod.fst hh).symm
+  have hs : (2 : ℝ) • z.1 = 0 := by
+    rw [two_smul]
+    exact (congrArg (fun v => v + z.1) h1).trans (neg_add_cancel z.1)
+  have hz : z.1 = 0 := (smul_eq_zero.mp hs).resolve_left (by norm_num)
+  refine ⟨hz, ?_⟩
+  intro h2
+  exact selectedMorseFieldEquiv_axis_ne_zero c ρ (Prod.ext hz h2)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_selected_outgoing_axis {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {x : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) {m : ℕ}
+    (ρ : Option (Fin m) ≃ Fin (Module.finrank ℝ E)) (he : c.weights (ρ Option.none) = -1)
+    {v : c.NegativeCoordinates} (hv : v ≠ 0) :
+    ∃ (r : ℝ) (L : Model m ≃L[ℝ] (c.NegativeCoordinates × c.PositiveCoordinates)),
+      0 < r ∧
+        L (r, 0) = (v, 0) ∧
+          ∀ p,
+            L
+                (endpointLinearField (fun i => c.weights (ρ (Option.some i))) (1 / 2)
+                  (c.weights (ρ Option.none)) p) =
+              Smale.MorseHandle.descent (L p) := by
+  let L₀ := selectedMorseFieldEquiv c ρ
+  obtain ⟨hz, hn⟩ := selectedMorseFieldEquiv_negative_axis c ρ he
+  obtain ⟨r, A, hr, hA, _⟩ := exists_positive_ray_alignment hn hv
+  let B :=
+    A.toContinuousLinearEquiv.prodCongr (ContinuousLinearEquiv.refl ℝ c.PositiveCoordinates)
+  let L := L₀.trans B
+  refine ⟨r, L, hr, ?_, ?_⟩
+  · have hp : (r, (0 : Fin m → ℝ)) = r • (1, 0) := by simp
+    rw [hp, L.map_smul]
+    apply Prod.ext
+    · change r • A ((L₀ (1, 0)).1) = v
+      rw [← A.map_smul]
+      exact hA
+    · change r • (L₀ (1, 0)).2 = 0
+      rw [hz, smul_zero]
+  · intro p
+    change B (L₀ _) = Smale.MorseHandle.descent (B (L₀ p))
+    rw [selectedMorseFieldEquiv_descent]
+    exact morse_block_change_descent _ _ _
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_selected_incoming_axis {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {x : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) {m : ℕ}
+    (ρ : Option (Fin m) ≃ Fin (Module.finrank ℝ E)) (he : c.weights (ρ Option.none) = 1)
+    {v : c.PositiveCoordinates} (hv : v ≠ 0) :
+    ∃ (r : ℝ) (L : Model m ≃L[ℝ] (c.NegativeCoordinates × c.PositiveCoordinates)),
+      0 < r ∧
+        L (-r, 0) = (0, v) ∧
+          ∀ p,
+            L
+                (endpointLinearField (fun i => c.weights (ρ (Option.some i))) (1 / 2)
+                  (c.weights (ρ Option.none)) p) =
+              Smale.MorseHandle.descent (L p) := by
+  let L₀ := selectedMorseFieldEquiv c ρ
+  obtain ⟨hz, hn⟩ := selectedMorseFieldEquiv_positive_axis c ρ he
+  obtain ⟨r, A, hr, hA, _⟩ := exists_positive_ray_alignment hn (neg_ne_zero.mpr hv)
+  let B :=
+    (ContinuousLinearEquiv.refl ℝ c.NegativeCoordinates).prodCongr A.toContinuousLinearEquiv
+  let L := L₀.trans B
+  refine ⟨r, L, hr, ?_, ?_⟩
+  · have hp : (-r, (0 : Fin m → ℝ)) = (-r) • (1, 0) := by simp
+    rw [hp, L.map_smul]
+    apply Prod.ext
+    · change (-r) • (L₀ (1, 0)).1 = 0
+      rw [hz, smul_zero]
+    · change (-r) • A ((L₀ (1, 0)).2) = v
+      rw [neg_smul, ← A.map_smul, hA, neg_neg]
+  · intro p
+    change B (L₀ _) = Smale.MorseHandle.descent (B (L₀ p))
+    rw [selectedMorseFieldEquiv_descent]
+    exact morse_block_change_descent _ _ _
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_cubic_field_endpoint_with_alignment {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {x : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) {m : ℕ} (σ : Fin m → ℝ)
+    {e : ℝ} (he : e ^ 2 = 1) (L : Model m ≃L[ℝ] (c.NegativeCoordinates × c.PositiveCoordinates))
+    (hL : ∀ p, L (endpointLinearField σ (1 / 2) e p) = Smale.MorseHandle.descent (L p)) :
+    ∃ Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞,
+      (e / 2, (0 : Fin m → ℝ)) ∈ Φ.source ∧
+        Φ (e / 2, 0) = x ∧
+          Φ.target ⊆ c.splitChart.source ∧
+            (∀ y ∈ Φ.target, c.descentField y = nativeCubicDescent σ Φ (-(1 / 2 : ℝ) ^ 2) y) ∧
+              (Φ : Model m → M) = c.splitChart.symm ∘ L ∘ endpointFieldProduct (1 / 2) e := by
+  let P := L.toDiffeomorph.toPartialDiffeomorph
+  let Q := P.trans c.splitChart.symm
+  have h0 : (0 : Model m) ∈ Q.source := by
+    change (0 : Model m) ∈ Set.univ ∧ L 0 ∈ c.splitChart.target
+    rw [map_zero, ← c.splitChart_center]
+    exact ⟨Set.mem_univ _, c.splitChart.map_source' c.splitChart_mem_source⟩
+  have hQzero : Q 0 = x := by
+    change c.splitChart.symm (L 0) = x
+    rw [map_zero, ← c.splitChart_center]
+    exact c.splitChart.left_inv' c.splitChart_mem_source
+  have hmodel :
+    ∀ y ∈ Q.target,
+      c.descentField y =
+        Smale.FlowConstruction.partialChartField Q.symm (endpointLinearField σ (1 / 2) e) y := by
+    intro y hy
+    have hpush (p : Model m) (_ : p ∈ P.source) :
+      fderiv ℝ P p (endpointLinearField σ (1 / 2) e p) = Smale.MorseHandle.descent (P p) := by
+      change fderiv ℝ L p (endpointLinearField σ (1 / 2) e p) = Smale.MorseHandle.descent (L p)
+      rw [L.fderiv]
+      exact hL p
+    exact
+      (partialChartField_of_model_conjugacy P c.splitChart.symm (endpointLinearField σ (1 / 2) e)
+          Smale.MorseHandle.descent hpush hy).symm
+  obtain ⟨Φ, hp, hc, hsub, hf, hmap⟩ :=
+    exists_native_cubic_field_endpoint σ (by norm_num : 0 < (1 / 2 : ℝ)) he Q h0 c.descentField
+      hmodel
+  refine ⟨Φ, ?_, ?_, fun y hy => (hsub hy).1, hf, hmap⟩
+  · simpa only [mul_one_div] using hp
+  · simpa only [mul_one_div, hQzero] using hc
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_original_field_endpoint_with_alignment {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {x : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) {m : ℕ} (σ : Fin m → ℝ)
+    {e : ℝ} (he : e ^ 2 = 1) (L : Model m ≃L[ℝ] (c.NegativeCoordinates × c.PositiveCoordinates))
+    (hL : ∀ p, L (endpointLinearField σ (1 / 2) e p) = Smale.MorseHandle.descent (L p))
+    (V : (y : M) → TangentSpace 𝓘(ℝ, E) y) (heq : ∀ᶠ y in 𝓝 x, V y = c.descentField y) :
+    ∃ Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞,
+      (e / 2, (0 : Fin m → ℝ)) ∈ Φ.source ∧
+        Φ (e / 2, 0) = x ∧
+          Φ.target ⊆ c.splitChart.source ∧
+            (∀ y ∈ Φ.target, V y = nativeCubicDescent σ Φ (-(1 / 2 : ℝ) ^ 2) y) ∧
+              (Φ : Model m → M) = c.splitChart.symm ∘ L ∘ endpointFieldProduct (1 / 2) e := by
+  obtain ⟨Φ, hp, hc, hsub, hf, hmap⟩ := exists_cubic_field_endpoint_with_alignment c σ he L hL
+  obtain ⟨U, hUsub, hU, hxU⟩ := mem_nhds_iff.mp heq
+  let Ψ := Smale.PartialChart.restrictTarget Φ hU
+  have hpΨ : (e / 2, (0 : Fin m → ℝ)) ∈ Ψ.source := by
+    change (e / 2, (0 : Fin m → ℝ)) ∈ Φ.source ∧ Φ (e / 2, 0) ∈ U
+    exact ⟨hp, hc.symm ▸ hxU⟩
+  refine ⟨Ψ, hpΨ, hc, fun y hy => hsub hy.1, ?_, hmap⟩
+  intro y hy
+  exact (hUsub hy.2).trans (hf y hy.1)
+
+private theorem
+    MorseCancel.endpointFieldCoordinate_mem_open_axis {a : ℝ} {e : ℝ} (he : e ^ 2 = 1) {s : ℝ}
+    (hs : s ∈ endpointFieldDomain a e) (hdir : 0 < -e * endpointFieldCoordinate a e s) :
+    s ∈ Set.Ioo (-a) a := by
+  rcases sq_eq_one_iff.mp he with h | h
+  · subst e
+    have hd : 0 < a + s := by simpa [endpointFieldDomain] using hs
+    have hy : (s - a) / (a + s) < 0 := by simpa [endpointFieldCoordinate] using hdir
+    have hn : s - a < 0 := by simpa using (div_lt_iff₀ hd).mp hy
+    exact ⟨by linarith, by linarith⟩
+  · subst e
+    have hd : 0 < a - s := by simpa [endpointFieldDomain] using hs
+    have hy : 0 < (s + a) / (a - s) := by
+      simpa [endpointFieldCoordinate, sub_eq_add_neg] using hdir
+    have hn : 0 < s + a := by simpa using (lt_div_iff₀ hd).mp hy
+    exact ⟨by linarith, by linarith⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.exists_controlled_morse_field_endpoint {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {x : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f x) {m : ℕ} (σ : Fin m → ℝ) {e : ℝ}
+    (he : e ^ 2 = 1) (L : Model m ≃L[ℝ] (c.NegativeCoordinates × c.PositiveCoordinates))
+    (hL : ∀ p, L (endpointLinearField σ (1 / 2) e p) = Smale.MorseHandle.descent (L p))
+    (V : (y : M) → TangentSpace 𝓘(ℝ, E) y) (heq : ∀ᶠ y in 𝓝 x, V y = c.descentField y) :
+    ∃ Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞,
+      (e / 2, (0 : Fin m → ℝ)) ∈ Φ.source ∧
+        Φ (e / 2, 0) = x ∧
+          Φ.target ⊆ c.splitChart.source ∧
+            (∀ y ∈ Φ.target, V y = nativeCubicDescent σ Φ (-(1 / 2 : ℝ) ^ 2) y) ∧
+              ∀ p ∈ Φ.source,
+                p.1 ∈ endpointFieldDomain (1 / 2) e ∧
+                  c.splitChart (Φ p) = L (endpointFieldProduct (1 / 2) e p) := by
+  obtain ⟨Φ, hp, hc, hsub, hf, hmap⟩ :=
+    exists_original_field_endpoint_with_alignment c σ he L hL V heq
+  let q : Model m := (e / 2, 0)
+  have hq : q.1 ∈ endpointFieldDomain (1 / 2) e := by
+    simpa only [q, mul_one_div] using endpointField_mem_domain (by norm_num : 0 < (1 / 2 : ℝ)) he
+  have hd : ContinuousAt (endpointFieldCoordinate (1 / 2) e) q.1 :=
+    ((contDiffOn_endpointFieldCoordinate (1 / 2) e).contDiffAt
+        ((endpointFieldDomain_open (1 / 2) e).mem_nhds hq)).continuousAt
+  have hprod : ContinuousAt (endpointFieldProduct (m := m) (1 / 2) e) q :=
+    (hd.comp continuousAt_fst).prodMk continuousAt_snd
+  have hzero : L (endpointFieldProduct (1 / 2) e q) = 0 := by
+    have hq' : q = (e * (1 / 2), (0 : Fin m → ℝ)) := by
+      apply Prod.ext
+      · dsimp [q]
+        ring
+      · rfl
+    rw [hq']
+    simp [endpointFieldProduct, endpointFieldCoordinate_center]
+  have hct : ContinuousAt (fun p : Model m => L (endpointFieldProduct (1 / 2) e p)) q :=
+    L.continuous.continuousAt.comp hprod
+  have htarget0 : (0 : c.NegativeCoordinates × c.PositiveCoordinates) ∈ c.splitChart.target := by
+    rw [← c.splitChart_center]
+    exact c.splitChart.map_source' c.splitChart_mem_source
+  have htarget : ∀ᶠ p in 𝓝 q, L (endpointFieldProduct (1 / 2) e p) ∈ c.splitChart.target := by
+    have hn : ∀ᶠ z in 𝓝 (L (endpointFieldProduct (1 / 2) e q)), z ∈ c.splitChart.target :=
+      c.splitChart.open_target.mem_nhds (hzero.symm ▸ htarget0)
+    exact hct.eventually hn
+  have hdomain : ∀ᶠ p in 𝓝 q, p.1 ∈ endpointFieldDomain (1 / 2) e :=
+    continuousAt_fst.eventually ((endpointFieldDomain_open (1 / 2) e).mem_nhds hq)
+  obtain ⟨U, hUsub, hU, hqU⟩ := mem_nhds_iff.mp (hdomain.and htarget)
+  let Ψ := Smale.PartialChart.restrictSource Φ hU
+  have hpΨ : q ∈ Ψ.source := ⟨hp, hqU⟩
+  refine ⟨Ψ, hpΨ, hc, fun y hy => hsub hy.1, ?_, ?_⟩
+  · intro y hy
+    exact hf y hy.1
+  · intro p hp
+    obtain ⟨hpd, hpt⟩ := hUsub hp.2
+    refine ⟨hpd, ?_⟩
+    change c.splitChart (Φ p) = L (endpointFieldProduct (1 / 2) e p)
+    rw [hmap]
+    exact c.splitChart.right_inv' hpt
+
+private theorem
+    MorseCancel.descentFlow_outgoing_aligned_ray {m : ℕ} {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] (L : Model m ≃L[ℝ] (N × P)) {r : ℝ}
+    {v : N} (hL : L (r, 0) = (v, 0)) (t : ℝ) :
+    Smale.MorseHandle.descentFlow t (L (r, 0)) = L (r * Real.exp t, 0) := by
+  have he : (r * Real.exp t, (0 : Fin m → ℝ)) = Real.exp t • (r, 0) := by
+    apply Prod.ext
+    · change r * Real.exp t = Real.exp t * r
+      ring
+    · simp
+  rw [he, L.map_smul, hL]
+  change (Real.exp t • v, Real.exp (-t) • (0 : P)) = (Real.exp t • v, Real.exp t • (0 : P))
+  simp
+
+private theorem
+    MorseCancel.descentFlow_incoming_aligned_ray {m : ℕ} {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] (L : Model m ≃L[ℝ] (N × P)) {r : ℝ}
+    {v : P} (hL : L (-r, 0) = (0, v)) (t : ℝ) :
+    Smale.MorseHandle.descentFlow t (L (-r, 0)) = L (-r * Real.exp (-t), 0) := by
+  have he : (-r * Real.exp (-t), (0 : Fin m → ℝ)) = Real.exp (-t) • (-r, 0) := by
+    apply Prod.ext
+    · change -r * Real.exp (-t) = Real.exp (-t) * -r
+      ring
+    · simp
+  rw [he, L.map_smul, hL]
+  change (Real.exp t • (0 : N), Real.exp (-t) • v) = (Real.exp (-t) • (0 : N), Real.exp (-t) • v)
+  simp
+
+private theorem
+    MorseCancel.cubic_axis_of_aligned_morse_ray {m : ℕ} {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞) (C : M → N × P)
+    (L : Model m ≃L[ℝ] (N × P)) {a : ℝ} {e : ℝ} (he : e ^ 2 = 1)
+    (hcoord :
+      ∀ p ∈ Φ.source, p.1 ∈ endpointFieldDomain a e ∧ C (Φ p) = L (endpointFieldProduct a e p))
+    {x : M} (hx : x ∈ Φ.target) {r : ℝ} (hr : 0 < -e * r) (hCx : C x = L (r, 0)) :
+    ∃ s ∈ Set.Ioo (-a) a,
+      (s, (0 : Fin m → ℝ)) ∈ Φ.source ∧ Φ (s, 0) = x ∧ endpointFieldCoordinate a e s = r := by
+  let p := Φ.symm x
+  have hp : p ∈ Φ.source := Φ.map_target' hx
+  have hpx : Φ p = x := Φ.right_inv' hx
+  obtain ⟨hdom, hCp⟩ := hcoord p hp
+  rw [hpx, hCx] at hCp
+  have hlin : endpointFieldProduct a e p = (r, 0) := L.injective hCp.symm
+  have hscalar : endpointFieldCoordinate a e p.1 = r := congrArg Prod.fst hlin
+  have hzero : p.2 = 0 := congrArg Prod.snd hlin
+  have haxis : p = (p.1, 0) := Prod.ext rfl hzero
+  have hdir : 0 < -e * endpointFieldCoordinate a e p.1 := hscalar.symm ▸ hr
+  refine ⟨p.1, endpointFieldCoordinate_mem_open_axis he hdom hdir, ?_, ?_, hscalar⟩
+  · exact haxis ▸ hp
+  · exact (congrArg Φ haxis).symm.trans hpx
+
+private theorem
+    MorseCancel.flow_formula_of_local_shifts {X : Type*} [TopologicalSpace X] (F : Flow ℝ X)
+    (γ : ℝ → X) {S : Set ℝ} (hS : IsPreconnected S)
+    (hlocal : ∀ t ∈ S, ∀ᶠ s in 𝓝 t, γ s = F (s - t) (γ t)) {t₀ t : ℝ} (h₀ : t₀ ∈ S) (ht : t ∈ S) :
+    γ t = F (t - t₀) (γ t₀) := by
+  let β : S → X := fun u => F (-u.1) (γ u.1)
+  have hc : IsLocallyConstant β := by
+    apply (IsLocallyConstant.iff_eventually_eq β).mpr
+    intro u
+    filter_upwards [continuousAt_subtype_val.eventually (hlocal u.1 u.2)] with v hv
+    change F (-v.1) (γ v.1) = F (-u.1) (γ u.1)
+    rw [hv, ← F.map_add]
+    congr 1
+    ring
+  let : PreconnectedSpace S := Subtype.preconnectedSpace hS
+  have hb : β ⟨t, ht⟩ = β ⟨t₀, h₀⟩ :=
+    hc.apply_eq_of_isPreconnected PreconnectedSpace.isPreconnected_univ (Set.mem_univ _)
+      (Set.mem_univ _)
+  have hh := congrArg (F t) hb
+  change F t (F (-t) (γ t)) = F t (F (-t₀) (γ t₀)) at hh
+  simpa only [← F.map_add, add_neg_cancel, F.map_zero_apply, ← sub_eq_add_neg] using hh
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.eventually_morse_coordinate_flow {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) (x : M) (t : ℝ)
+    (ht : F t x ∈ c.splitChart.source) (heq : ∀ᶠ y in 𝓝 (F t x), V y = c.descentField y) :
+    ∀ᶠ s in 𝓝 t,
+      c.splitChart (F s x) = Smale.MorseHandle.descentFlow (s - t) (c.splitChart (F t x)) := by
+  have hlocal :
+    ∀ᶠ u in 𝓝 (0 : ℝ),
+      F u (F t x) = c.splitChart.symm (Smale.MorseHandle.descentFlow u (c.splitChart (F t x))) :=
+    c.eventually_flow_eq_descentModel hV F hF ht heq
+  have htime : Filter.Tendsto (fun s : ℝ => s - t) (𝓝 t) (𝓝 0) := by
+    have hc : Continuous (fun s : ℝ => s - t) := continuous_id.sub continuous_const
+    simpa only [sub_self] using hc.tendsto t
+  have hmodel :
+    Continuous (fun u : ℝ => Smale.MorseHandle.descentFlow u (c.splitChart (F t x))) :=
+    Smale.MorseHandle.descentFlow.continuous continuous_id continuous_const
+  have htarget :
+    ∀ᶠ u in 𝓝 (0 : ℝ),
+      Smale.MorseHandle.descentFlow u (c.splitChart (F t x)) ∈ c.splitChart.target := by
+    have hnhds : ∀ᶠ y in 𝓝 (c.splitChart (F t x)), y ∈ c.splitChart.target :=
+      c.splitChart.open_target.mem_nhds (c.splitChart.map_source' ht)
+    have hm0 :
+      Filter.Tendsto (fun u : ℝ => Smale.MorseHandle.descentFlow u (c.splitChart (F t x))) (𝓝 0)
+        (𝓝 (c.splitChart (F t x))) := by simpa only [Flow.map_zero_apply] using hmodel.tendsto 0
+    exact hm0.eventually hnhds
+  filter_upwards [htime.eventually hlocal, htime.eventually htarget] with s hs hst
+  rw [← F.map_add, sub_add_cancel] at hs
+  have hh := congrArg c.splitChart hs
+  exact hh.trans (c.splitChart.right_inv' hst)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.morse_coordinates_of_actual_trajectory {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) (x : M) {S : Set ℝ}
+    (hS : IsPreconnected S) (htarget : ∀ t ∈ S, F t x ∈ c.splitChart.source)
+    (heq : ∀ t ∈ S, ∀ᶠ y in 𝓝 (F t x), V y = c.descentField y) {t₀ t : ℝ} (h₀ : t₀ ∈ S)
+    (ht : t ∈ S) :
+    c.splitChart (F t x) = Smale.MorseHandle.descentFlow (t - t₀) (c.splitChart (F t₀ x)) :=
+  flow_formula_of_local_shifts Smale.MorseHandle.descentFlow (fun s => c.splitChart (F s x)) hS
+    (fun s hs => eventually_morse_coordinate_flow c hV F hF x s (htarget s hs) (heq s hs)) h₀ ht
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.morse_endpoint_tail_data {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (F : Flow ℝ M) (x : M) {l : Filter ℝ}
+    (hlim : Filter.Tendsto (fun t => F t x) l (𝓝 p)) (heq : ∀ᶠ y in 𝓝 p, V y = c.descentField y) :
+    Filter.Tendsto (fun t => c.splitChart (F t x)) l (𝓝 0) ∧
+      ∀ᶠ t in l, F t x ∈ c.splitChart.source ∧ ∀ᶠ y in 𝓝 (F t x), V y = c.descentField y := by
+  have hc := c.splitChart.toOpenPartialHomeomorph.continuousAt c.splitChart_mem_source
+  have hcoord : Filter.Tendsto (fun t => c.splitChart (F t x)) l (𝓝 0) := by
+    have hh : Filter.Tendsto (fun t => c.splitChart (F t x)) l (𝓝 (c.splitChart p)) :=
+      hc.tendsto.comp hlim
+    simpa only [c.splitChart_center] using hh
+  have hsource : ∀ᶠ y in 𝓝 p, y ∈ c.splitChart.source :=
+    c.splitChart.open_source.mem_nhds c.splitChart_mem_source
+  have hgerm : ∀ᶠ y in 𝓝 p, ∀ᶠ z in 𝓝 y, V z = c.descentField z :=
+    eventually_eventually_nhds.mpr heq
+  exact ⟨hcoord, hlim.eventually (hsource.and hgerm)⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_incoming_morse_tail {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) (x : M)
+    (hlim : Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p))
+    (heq : ∀ᶠ y in 𝓝 p, V y = c.descentField y) :
+    ∃ T : ℝ,
+      (∀ t ≥ T, F t x ∈ c.splitChart.source) ∧
+        (∀ t ≥ T, (c.splitChart (F t x)).1 = 0) ∧
+          ∀ t ≥ T,
+            ∀ s ≥ T,
+              c.splitChart (F s x) =
+                Smale.MorseHandle.descentFlow (s - t) (c.splitChart (F t x)) := by
+  obtain ⟨hcoord, htail⟩ := morse_endpoint_tail_data c F x hlim heq
+  obtain ⟨T, hT⟩ := Filter.eventually_atTop.mp htail
+  have hformula (t : ℝ) (ht : T ≤ t) (s : ℝ) (hs : T ≤ s) :
+    c.splitChart (F s x) = Smale.MorseHandle.descentFlow (s - t) (c.splitChart (F t x)) :=
+    morse_coordinates_of_actual_trajectory c hV F hF x isPreconnected_Ici
+      (fun u hu => (hT u hu).1) (fun u hu => (hT u hu).2) ht hs
+  refine ⟨T, fun t ht => (hT t ht).1, ?_, hformula⟩
+  intro t ht
+  have hnorm : Filter.Tendsto (fun s => ‖(c.splitChart (F s x)).1‖) Filter.atTop (𝓝 0) := by
+    simpa only [Function.comp_def, Prod.fst_zero, norm_zero] using
+      (continuous_fst.norm.tendsto (0 : c.NegativeCoordinates × c.PositiveCoordinates)).comp
+        hcoord
+  have hbound : ∀ᶠ s in Filter.atTop, ‖(c.splitChart (F t x)).1‖ ≤ ‖(c.splitChart (F s x)).1‖ := by
+    filter_upwards [Filter.eventually_ge_atTop T, Filter.eventually_ge_atTop t] with s hs hst
+    rw [hformula t ht s hs]
+    exact Smale.MorseHandle.norm_fst_le_descentFlow (sub_nonneg.mpr hst) _
+  exact norm_eq_zero.mp (le_antisymm (ge_of_tendsto hnorm hbound) (norm_nonneg _))
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_outgoing_morse_tail {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) (x : M)
+    (hlim : Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p))
+    (heq : ∀ᶠ y in 𝓝 p, V y = c.descentField y) :
+    ∃ T : ℝ,
+      (∀ t ≤ T, F t x ∈ c.splitChart.source) ∧
+        (∀ t ≤ T, (c.splitChart (F t x)).2 = 0) ∧
+          ∀ t ≤ T,
+            ∀ s ≤ T,
+              c.splitChart (F s x) =
+                Smale.MorseHandle.descentFlow (s - t) (c.splitChart (F t x)) := by
+  obtain ⟨hcoord, htail⟩ := morse_endpoint_tail_data c F x hlim heq
+  obtain ⟨T, hT⟩ := Filter.eventually_atBot.mp htail
+  have hformula (t : ℝ) (ht : t ≤ T) (s : ℝ) (hs : s ≤ T) :
+    c.splitChart (F s x) = Smale.MorseHandle.descentFlow (s - t) (c.splitChart (F t x)) :=
+    morse_coordinates_of_actual_trajectory c hV F hF x isPreconnected_Iic
+      (fun u hu => (hT u hu).1) (fun u hu => (hT u hu).2) ht hs
+  refine ⟨T, fun t ht => (hT t ht).1, ?_, hformula⟩
+  intro t ht
+  have hnorm : Filter.Tendsto (fun s => ‖(c.splitChart (F s x)).2‖) Filter.atBot (𝓝 0) := by
+    simpa only [Function.comp_def, Prod.snd_zero, norm_zero] using
+      (continuous_snd.norm.tendsto (0 : c.NegativeCoordinates × c.PositiveCoordinates)).comp
+        hcoord
+  have hbound : ∀ᶠ s in Filter.atBot, ‖(c.splitChart (F t x)).2‖ ≤ ‖(c.splitChart (F s x)).2‖ := by
+    filter_upwards [Filter.eventually_le_atBot T, Filter.eventually_le_atBot t] with s hs hst
+    rw [hformula t ht s hs, Smale.MorseHandle.norm_descentFlow_snd]
+    exact le_mul_of_one_le_left (norm_nonneg _) (Real.one_le_exp_iff.mpr (by linarith))
+  exact norm_eq_zero.mp (le_antisymm (ge_of_tendsto hnorm hbound) (norm_nonneg _))
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.incoming_tail_on_cubic_axis {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) {m : ℕ}
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (L : Model m ≃L[ℝ] (c.NegativeCoordinates × c.PositiveCoordinates))
+    (hcenter : (1 / 2, (0 : Fin m → ℝ)) ∈ Φ.source) (hvalue : Φ (1 / 2, 0) = p)
+    (hcoord :
+      ∀ q ∈ Φ.source,
+        q.1 ∈ endpointFieldDomain (1 / 2) 1 ∧
+          c.splitChart (Φ q) = L (endpointFieldProduct (1 / 2) 1 q))
+    (F : Flow ℝ M) (x : M) (hlim : Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p)) {T r : ℝ}
+    (hr : 0 < r) {v : c.PositiveCoordinates} (hL : L (-r, 0) = (0, v))
+    (hbase : c.splitChart (F T x) = (0, v))
+    (hmodel :
+      ∀ t ≥ T,
+        c.splitChart (F t x) = Smale.MorseHandle.descentFlow (t - T) (c.splitChart (F T x))) :
+    ∀ᶠ t in Filter.atTop,
+      ∃ s ∈ Set.Ioo (-(1 / 2 : ℝ)) (1 / 2), (s, (0 : Fin m → ℝ)) ∈ Φ.source ∧ Φ (s, 0) = F t x := by
+  have hp : p ∈ Φ.target := hvalue ▸ Φ.map_source' hcenter
+  have htarget : ∀ᶠ t in Filter.atTop, F t x ∈ Φ.target :=
+    hlim.eventually (Φ.open_target.mem_nhds hp)
+  filter_upwards [htarget, Filter.eventually_ge_atTop T] with t ht hT
+  have hline : c.splitChart (F t x) = L (-r * Real.exp (-(t - T)), 0) := by
+    rw [hmodel t hT, hbase, ← hL]
+    exact descentFlow_incoming_aligned_ray L hL (t - T)
+  have hdir : 0 < -(1 : ℝ) * (-r * Real.exp (-(t - T))) := by nlinarith [Real.exp_pos (-(t - T))]
+  obtain ⟨s, hs, hsource, hpoint, _⟩ :=
+    cubic_axis_of_aligned_morse_ray Φ c.splitChart L (by norm_num : (1 : ℝ) ^ 2 = 1) hcoord ht
+      hdir hline
+  exact ⟨s, hs, hsource, hpoint⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.outgoing_tail_on_cubic_axis {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) {m : ℕ}
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (L : Model m ≃L[ℝ] (c.NegativeCoordinates × c.PositiveCoordinates))
+    (hcenter : (-(1 / 2 : ℝ), (0 : Fin m → ℝ)) ∈ Φ.source) (hvalue : Φ (-(1 / 2 : ℝ), 0) = p)
+    (hcoord :
+      ∀ q ∈ Φ.source,
+        q.1 ∈ endpointFieldDomain (1 / 2) (-1) ∧
+          c.splitChart (Φ q) = L (endpointFieldProduct (1 / 2) (-1) q))
+    (F : Flow ℝ M) (x : M) (hlim : Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p)) {T r : ℝ}
+    (hr : 0 < r) {v : c.NegativeCoordinates} (hL : L (r, 0) = (v, 0))
+    (hbase : c.splitChart (F T x) = (v, 0))
+    (hmodel :
+      ∀ t ≤ T,
+        c.splitChart (F t x) = Smale.MorseHandle.descentFlow (t - T) (c.splitChart (F T x))) :
+    ∀ᶠ t in Filter.atBot,
+      ∃ s ∈ Set.Ioo (-(1 / 2 : ℝ)) (1 / 2), (s, (0 : Fin m → ℝ)) ∈ Φ.source ∧ Φ (s, 0) = F t x := by
+  have hp : p ∈ Φ.target := hvalue ▸ Φ.map_source' hcenter
+  have htarget : ∀ᶠ t in Filter.atBot, F t x ∈ Φ.target :=
+    hlim.eventually (Φ.open_target.mem_nhds hp)
+  filter_upwards [htarget, Filter.eventually_le_atBot T] with t ht hT
+  have hline : c.splitChart (F t x) = L (r * Real.exp (t - T), 0) := by
+    rw [hmodel t hT, hbase, ← hL]
+    exact descentFlow_outgoing_aligned_ray L hL (t - T)
+  have hdir : 0 < -(-1 : ℝ) * (r * Real.exp (t - T)) := by
+    simpa using mul_pos hr (Real.exp_pos (t - T))
+  obtain ⟨s, hs, hsource, hpoint, _⟩ :=
+    cubic_axis_of_aligned_morse_ray Φ c.splitChart L (by norm_num : (-1 : ℝ) ^ 2 = 1) hcoord ht
+      hdir hline
+  exact ⟨s, hs, hsource, hpoint⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.morse_coordinates_nonzero_on_nonstationary_orbit {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {x : M} (hxp : x ≠ p)
+    (heq : ∀ᶠ y in 𝓝 p, V y = c.descentField y) {t : ℝ} (ht : F t x ∈ c.splitChart.source) :
+    c.splitChart (F t x) ≠ 0 := by
+  have heqp : V p = c.descentField p :=
+    mem_of_mem_nhds (x := p) (s := {y : M | V y = c.descentField y}) heq
+  have hVp : V p = 0 := heqp.trans c.descentField_center
+  have hfixed := Smale.FlowConstruction.flow_fixed_of_zero hV F hF hVp
+  intro hz
+  have hpoint : F t x = p :=
+    c.splitChart.toOpenPartialHomeomorph.injOn ht c.splitChart_mem_source
+      (hz.trans c.splitChart_center.symm)
+  have hh := congrArg (F (-t)) hpoint
+  rw [← F.map_add, neg_add_cancel, F.map_zero_apply, hfixed] at hh
+  exact hxp hh
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.exists_actual_incoming_cubic_endpoint {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) {m : ℕ}
+    (ρ : Option (Fin m) ≃ Fin (Module.finrank ℝ E)) (he : c.weights (ρ Option.none) = 1)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {x : M} (hxp : x ≠ p)
+    (hlim : Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p))
+    (heq : ∀ᶠ y in 𝓝 p, V y = c.descentField y) :
+    let σ := fun i : Fin m => c.weights (ρ (Option.some i))
+    ∃ Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞,
+      (1 / 2, (0 : Fin m → ℝ)) ∈ Φ.source ∧
+        Φ (1 / 2, 0) = p ∧
+          Φ.target ⊆ c.splitChart.source ∧
+            (∀ y ∈ Φ.target, V y = nativeCubicDescent σ Φ (-(1 / 2 : ℝ) ^ 2) y) ∧
+              (∀ᶠ t in Filter.atTop,
+                  ∃ s ∈ Set.Ioo (-(1 / 2 : ℝ)) (1 / 2),
+                    (s, (0 : Fin m → ℝ)) ∈ Φ.source ∧ Φ (s, 0) = F t x) ∧
+                ∃ L : Model m ≃L[ℝ] (c.NegativeCoordinates × c.PositiveCoordinates),
+                  (∀ z, L (endpointLinearField σ (1 / 2) 1 z) = Smale.MorseHandle.descent (L z)) ∧
+                    ∀ z ∈ Φ.source, c.splitChart (Φ z) = L (endpointFieldProduct (1 / 2) 1 z) := by
+  let σ := fun i : Fin m => c.weights (ρ (Option.some i))
+  obtain ⟨T, hsource, hzero, hformula⟩ := exists_incoming_morse_tail c hV F hF x hlim heq
+  let v := (c.splitChart (F T x)).2
+  have hbase : c.splitChart (F T x) = (0, v) := Prod.ext (hzero T le_rfl) rfl
+  have hv : v ≠ 0 := by
+    intro hv
+    exact
+      morse_coordinates_nonzero_on_nonstationary_orbit c hV F hF hxp heq (hsource T le_rfl)
+        (hbase.trans (Prod.ext rfl hv))
+  obtain ⟨r, L, hr, hLray, hL⟩ := exists_selected_incoming_axis c ρ he hv
+  have hL' : ∀ q, L (endpointLinearField σ (1 / 2) 1 q) = Smale.MorseHandle.descent (L q) := by
+    simpa only [he] using hL
+  obtain ⟨Φ, hc, hval, hsub, hfield, hcoord⟩ :=
+    exists_controlled_morse_field_endpoint c σ (by norm_num : (1 : ℝ) ^ 2 = 1) L hL' V heq
+  refine ⟨Φ, hc, hval, hsub, hfield, ?_, L, hL', ?_⟩
+  · exact
+      incoming_tail_on_cubic_axis c Φ L hc hval hcoord F x hlim hr hLray hbase (hformula T le_rfl)
+  · exact fun z hz => (hcoord z hz).2
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.exists_actual_outgoing_cubic_endpoint {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) {m : ℕ}
+    (ρ : Option (Fin m) ≃ Fin (Module.finrank ℝ E)) (he : c.weights (ρ Option.none) = -1)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {x : M} (hxp : x ≠ p)
+    (hlim : Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p))
+    (heq : ∀ᶠ y in 𝓝 p, V y = c.descentField y) :
+    let σ := fun i : Fin m => c.weights (ρ (Option.some i))
+    ∃ Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞,
+      (-(1 / 2 : ℝ), (0 : Fin m → ℝ)) ∈ Φ.source ∧
+        Φ (-(1 / 2 : ℝ), 0) = p ∧
+          Φ.target ⊆ c.splitChart.source ∧
+            (∀ y ∈ Φ.target, V y = nativeCubicDescent σ Φ (-(1 / 2 : ℝ) ^ 2) y) ∧
+              (∀ᶠ t in Filter.atBot,
+                  ∃ s ∈ Set.Ioo (-(1 / 2 : ℝ)) (1 / 2),
+                    (s, (0 : Fin m → ℝ)) ∈ Φ.source ∧ Φ (s, 0) = F t x) ∧
+                ∃ L : Model m ≃L[ℝ] (c.NegativeCoordinates × c.PositiveCoordinates),
+                  (∀ z,
+                      L (endpointLinearField σ (1 / 2) (-1) z) =
+                        Smale.MorseHandle.descent (L z)) ∧
+                    ∀ z ∈ Φ.source,
+                      c.splitChart (Φ z) = L (endpointFieldProduct (1 / 2) (-1) z) := by
+  let σ := fun i : Fin m => c.weights (ρ (Option.some i))
+  obtain ⟨T, hsource, hzero, hformula⟩ := exists_outgoing_morse_tail c hV F hF x hlim heq
+  let v := (c.splitChart (F T x)).1
+  have hbase : c.splitChart (F T x) = (v, 0) := Prod.ext rfl (hzero T le_rfl)
+  have hv : v ≠ 0 := by
+    intro hv
+    exact
+      morse_coordinates_nonzero_on_nonstationary_orbit c hV F hF hxp heq (hsource T le_rfl)
+        (hbase.trans (Prod.ext hv rfl))
+  obtain ⟨r, L, hr, hLray, hL⟩ := exists_selected_outgoing_axis c ρ he hv
+  have hL' : ∀ q, L (endpointLinearField σ (1 / 2) (-1) q) = Smale.MorseHandle.descent (L q) := by
+    simpa only [he] using hL
+  obtain ⟨Φ, hc, hval, hsub, hfield, hcoord⟩ :=
+    exists_controlled_morse_field_endpoint c σ (by norm_num : (-1 : ℝ) ^ 2 = 1) L hL' V heq
+  have hc' : (-(1 / 2 : ℝ), (0 : Fin m → ℝ)) ∈ Φ.source := by convert! hc using 1; norm_num
+  have hval' : Φ (-(1 / 2 : ℝ), 0) = p := by convert! hval using 1; norm_num
+  refine ⟨Φ, hc', hval', hsub, hfield, ?_, L, hL', ?_⟩
+  · exact
+      outgoing_tail_on_cubic_axis c Φ L hc' hval' hcoord F x hlim hr hLray hbase
+        (hformula T le_rfl)
+  · exact fun z hz => (hcoord z hz).2
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.native_backward_basin_mem_attaching_core {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} {p : M} {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) (r : ℝ) (hr : 0 < r)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) ⊆
+        c.splitChart.target)
+    (hfield :
+      ∀
+        z ∈
+          Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+            Metric.closedBall (0 : c.PositiveCoordinates) (2 * r),
+        ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y)
+    (hboundary : ∀ x, f x = f p - r ^ 2 → mvfderiv 𝓘(ℝ, E) f x (V x) < 0) {x : M}
+    (hlevel : f x = f p - r ^ 2) (hlim : Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p)) :
+    ∃ u : Smale.PuncturedHandle.UnitSphere c.NegativeCoordinates,
+      (c.attachingCoreMap r hr hblock u : M) = x := by
+  have hV₁ := hV.of_le (show (1 : WithTop ℕ∞) ≤ (↑(⊤ : ℕ∞) : ℕ∞ω) by simp)
+  have hcenter : c.splitChart.symm (0 : c.NegativeCoordinates × c.PositiveCoordinates) = p := by
+    rw [← c.splitChart_center]
+    exact c.splitChart.left_inv' c.splitChart_mem_source
+  have heq :=
+    hfield (0 : c.NegativeCoordinates × c.PositiveCoordinates)
+      ⟨Metric.mem_closedBall_self (by positivity), Metric.mem_closedBall_self (by positivity)⟩
+  rw [hcenter] at heq
+  obtain ⟨T, hsource, hplane, -⟩ := exists_outgoing_morse_tail c hV₁ F hF x hlim heq
+  obtain ⟨hcoord, -⟩ := morse_endpoint_tail_data c F x hlim heq
+  have hnorm : Filter.Tendsto (fun t => ‖(c.splitChart (F t x)).1‖) Filter.atBot (𝓝 (0 : ℝ)) := by
+    simpa only [Function.comp_def, Prod.fst_zero, norm_zero] using
+      (continuous_fst.norm.tendsto (0 : c.NegativeCoordinates × c.PositiveCoordinates)).comp
+        hcoord
+  obtain ⟨s, hsmall, hs⟩ :=
+    ((hnorm.eventually (eventually_lt_nhds hr)).and (Filter.eventually_le_atBot T)).exists
+  have hxp : x ≠ p := by
+    intro hh
+    rw [hh] at hlevel
+    nlinarith [sq_pos_of_pos hr]
+  have hnonzero :=
+    morse_coordinates_nonzero_on_nonstationary_orbit c hV₁ F hF hxp heq (hsource s hs)
+  have hn : (c.splitChart (F s x)).1 ≠ 0 := fun hz => hnonzero (Prod.ext hz (hplane s hs))
+  obtain ⟨u, t, ht, hu⟩ := exists_negative_core_ray_parameter hr hn hsmall
+  have hmodel :
+    Smale.MorseHandle.descentFlow t
+        (r • (u : c.NegativeCoordinates), (0 : c.PositiveCoordinates)) =
+      c.splitChart (F s x) := by
+    apply Prod.ext
+    · exact hu
+    · change Real.exp (-t) • (0 : c.PositiveCoordinates) = (c.splitChart (F s x)).2
+      rw [smul_zero, hplane s hs]
+  have hcore := native_attaching_core_flow c hV₁ F hF r hr hblock hfield u ht.le
+  rw [hmodel] at hcore
+  have hsame : F t (c.attachingCoreMap r hr hblock u) = F s x :=
+    hcore.trans (c.splitChart.left_inv' (hsource s hs))
+  exact
+    ⟨u,
+      native_same_level_orbit_points hf hV F hF hboundary
+        (c.attachingCoreMap r hr hblock u).property hlevel hsame⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.native_attaching_core_basin_iff {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} {p : M} {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) (r : ℝ) (hr : 0 < r)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) ⊆
+        c.splitChart.target)
+    (hfield :
+      ∀
+        z ∈
+          Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+            Metric.closedBall (0 : c.PositiveCoordinates) (2 * r),
+        ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y)
+    (hboundary : ∀ x, f x = f p - r ^ 2 → mvfderiv 𝓘(ℝ, E) f x (V x) < 0) {x : M}
+    (hlevel : f x = f p - r ^ 2) :
+    Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p) ↔
+      ∃ u : Smale.PuncturedHandle.UnitSphere c.NegativeCoordinates,
+        (c.attachingCoreMap r hr hblock u : M) = x := by
+  constructor
+  · exact
+      native_backward_basin_mem_attaching_core c hf hV F hF r hr hblock hfield hboundary hlevel
+  · rintro ⟨u, rfl⟩
+    exact native_attaching_core_backward_limit c (hV.of_le (by simp)) F hF r hr hblock hfield u
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.native_forward_basin_mem_belt_core {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} {p : M} {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) (r : ℝ) (hr : 0 < r)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) ⊆
+        c.splitChart.target)
+    (hfield :
+      ∀
+        z ∈
+          Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+            Metric.closedBall (0 : c.PositiveCoordinates) (2 * r),
+        ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y)
+    (hboundary : ∀ x, f x = f p + r ^ 2 → mvfderiv 𝓘(ℝ, E) f x (V x) < 0) {x : M}
+    (hlevel : f x = f p + r ^ 2) (hlim : Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p)) :
+    ∃ u : Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates,
+      (c.beltCoreMap r hr hblock u : M) = x := by
+  have hV₁ := hV.of_le (show (1 : WithTop ℕ∞) ≤ (↑(⊤ : ℕ∞) : ℕ∞ω) by simp)
+  have hcenter : c.splitChart.symm (0 : c.NegativeCoordinates × c.PositiveCoordinates) = p := by
+    rw [← c.splitChart_center]
+    exact c.splitChart.left_inv' c.splitChart_mem_source
+  have heq :=
+    hfield (0 : c.NegativeCoordinates × c.PositiveCoordinates)
+      ⟨Metric.mem_closedBall_self (by positivity), Metric.mem_closedBall_self (by positivity)⟩
+  rw [hcenter] at heq
+  obtain ⟨T, hsource, hplane, -⟩ := exists_incoming_morse_tail c hV₁ F hF x hlim heq
+  obtain ⟨hcoord, -⟩ := morse_endpoint_tail_data c F x hlim heq
+  have hnorm : Filter.Tendsto (fun t => ‖(c.splitChart (F t x)).2‖) Filter.atTop (𝓝 (0 : ℝ)) := by
+    simpa only [Function.comp_def, Prod.snd_zero, norm_zero] using
+      (continuous_snd.norm.tendsto (0 : c.NegativeCoordinates × c.PositiveCoordinates)).comp
+        hcoord
+  obtain ⟨s, hsmall, hs⟩ :=
+    ((hnorm.eventually (eventually_lt_nhds hr)).and (Filter.eventually_ge_atTop T)).exists
+  have hxp : x ≠ p := by
+    intro hh
+    rw [hh] at hlevel
+    nlinarith [sq_pos_of_pos hr]
+  have hnonzero :=
+    morse_coordinates_nonzero_on_nonstationary_orbit c hV₁ F hF hxp heq (hsource s hs)
+  have hn : (c.splitChart (F s x)).2 ≠ 0 := fun hz => hnonzero (Prod.ext (hplane s hs) hz)
+  obtain ⟨u, t, ht, hu⟩ := exists_positive_core_ray_parameter hr hn hsmall
+  have hmodel :
+    Smale.MorseHandle.descentFlow t
+        ((0 : c.NegativeCoordinates), r • (u : c.PositiveCoordinates)) =
+      c.splitChart (F s x) := by
+    apply Prod.ext
+    · change Real.exp t • (0 : c.NegativeCoordinates) = (c.splitChart (F s x)).1
+      rw [smul_zero, hplane s hs]
+    · exact hu
+  have hcore := native_belt_core_flow c hV₁ F hF r hr hblock hfield u ht.le
+  rw [hmodel] at hcore
+  have hsame : F t (c.beltCoreMap r hr hblock u) = F s x :=
+    hcore.trans (c.splitChart.left_inv' (hsource s hs))
+  exact
+    ⟨u,
+      native_same_level_orbit_points hf hV F hF hboundary (c.beltCoreMap r hr hblock u).property
+        hlevel hsame⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.native_belt_core_basin_iff {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} {p : M} {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) (r : ℝ) (hr : 0 < r)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) ⊆
+        c.splitChart.target)
+    (hfield :
+      ∀
+        z ∈
+          Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+            Metric.closedBall (0 : c.PositiveCoordinates) (2 * r),
+        ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y)
+    (hboundary : ∀ x, f x = f p + r ^ 2 → mvfderiv 𝓘(ℝ, E) f x (V x) < 0) {x : M}
+    (hlevel : f x = f p + r ^ 2) :
+    Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p) ↔
+      ∃ u : Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates,
+        (c.beltCoreMap r hr hblock u : M) = x := by
+  constructor
+  · exact native_forward_basin_mem_belt_core c hf hV F hF r hr hblock hfield hboundary hlevel
+  · rintro ⟨u, rfl⟩
+    exact native_belt_core_forward_limit c (hV.of_le (by simp)) F hF r hr hblock hfield u
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    AdaptedWindows.attaching_basin_iff {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (p : Smale.ManifoldMorse.criticalPoints E f) (x : (S.data p).LowerLevel) :
+    Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 p.val) ↔
+      x ∈ Set.range (S.data p).surgery.attachingSphere := by
+  let d := S.data p
+  have hh :=
+    MorseCancel.native_attaching_core_basin_iff d.chart hf S.smooth S.flow S.integral d.radius
+      d.radius_pos d.block (S.model_germ p) (fun y hy => S.descent y (d.lower_regular y hy))
+      x.property
+  rw [d.attaching_eq]
+  exact hh.trans ⟨fun ⟨u, hu⟩ => ⟨u, Subtype.ext hu⟩, fun ⟨u, hu⟩ => ⟨u, congrArg Subtype.val hu⟩⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem AdaptedWindows.belt_basin_iff {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (p : Smale.ManifoldMorse.criticalPoints E f) (x : (S.data p).UpperLevel) :
+    Filter.Tendsto (fun t => S.flow t x) Filter.atTop (𝓝 p.val) ↔
+      x ∈ Set.range (S.data p).surgery.beltSphere := by
+  let d := S.data p
+  have hh :=
+    MorseCancel.native_belt_core_basin_iff d.chart hf S.smooth S.flow S.integral d.radius
+      d.radius_pos d.block (S.model_germ p) (fun y hy => S.descent y (d.upper_regular y hy))
+      x.property
+  rw [d.belt_eq]
+  exact hh.trans ⟨fun ⟨u, hu⟩ => ⟨u, Subtype.ext hu⟩, fun ⟨u, hu⟩ => ⟨u, congrArg Subtype.val hu⟩⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    AdaptedWindows.critical_model_germ {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (p : Smale.ManifoldMorse.criticalPoints E f) :
+    ∀ᶠ y in 𝓝 p.val, S.field y = (S.data p).chart.descentField y := by
+  let d := S.data p
+  have hcenter :
+    d.chart.splitChart.symm (0 : d.chart.NegativeCoordinates × d.chart.PositiveCoordinates) =
+      p.val := by
+    rw [← d.chart.splitChart_center]
+    exact d.chart.splitChart.left_inv' d.chart.splitChart_mem_source
+  have hg :=
+    S.model_germ p (0 : d.chart.NegativeCoordinates × d.chart.PositiveCoordinates)
+      ⟨Metric.mem_closedBall_self (le_of_lt (mul_pos (by norm_num) d.radius_pos)),
+        Metric.mem_closedBall_self (le_of_lt (mul_pos (by norm_num) d.radius_pos))⟩
+  rw [hcenter] at hg
+  exact hg
+
+private theorem
+    MorseCancel.hasDerivAt_tanh (t : ℝ) : HasDerivAt Real.tanh (1 - Real.tanh t ^ 2) t := by
+  have h := (Real.hasDerivAt_sinh t).div (Real.hasDerivAt_cosh t) (Real.cosh_pos t).ne'
+  have hf : (fun x => Real.sinh x / Real.cosh x) = Real.tanh :=
+    funext (fun x => (Real.tanh_eq_sinh_div_cosh x).symm)
+  change HasDerivAt (fun x => Real.sinh x / Real.cosh x) _ t at h
+  rw [hf] at h
+  convert h using 1
+  rw [Real.tanh_eq_sinh_div_cosh]
+  field_simp
+
+private theorem MorseCancel.strictMono_tanh : StrictMono Real.tanh :=
+  strictMono_of_hasDerivAt_pos hasDerivAt_tanh (fun t => sub_pos.mpr (Real.tanh_sq_lt_one t))
+
+private theorem MorseCancel.range_tanh : Set.range Real.tanh = Set.Ioo (-1 : ℝ) 1 := by
+  ext s
+  constructor
+  · rintro ⟨t, rfl⟩
+    exact ⟨Real.neg_one_lt_tanh t, Real.tanh_lt_one t⟩
+  · intro hs
+    obtain ⟨t, -, ht⟩ := Real.tanh_surjOn hs
+    exact ⟨t, ht⟩
+
+private theorem
+    MorseCancel.tendsto_tanh_atTop : Filter.Tendsto Real.tanh Filter.atTop (𝓝 (1 : ℝ)) := by
+  apply tendsto_atTop_isLUB strictMono_tanh.monotone
+  rw [range_tanh]
+  exact isLUB_Ioo (by norm_num)
+
+private theorem
+    MorseCancel.tendsto_tanh_atBot : Filter.Tendsto Real.tanh Filter.atBot (𝓝 (-1 : ℝ)) := by
+  apply tendsto_atBot_isGLB strictMono_tanh.monotone
+  rw [range_tanh]
+  exact isGLB_Ioo (by norm_num)
+
+private def MorseCancel.cubicAxisParameter (a t : ℝ) : ℝ :=
+  a * Real.tanh (a * t)
+
+private theorem MorseCancel.hasDerivAt_cubicAxisParameter (a t : ℝ) :
+    HasDerivAt (cubicAxisParameter a) (a ^ 2 - cubicAxisParameter a t ^ 2) t := by
+  have h := ((hasDerivAt_tanh (a * t)).comp t ((hasDerivAt_id t).const_mul a)).const_mul a
+  change HasDerivAt (cubicAxisParameter a) (a * ((1 - Real.tanh (a * t) ^ 2) * (a * 1))) t at h
+  convert h using 1
+  dsimp [cubicAxisParameter]
+  ring
+
+private theorem MorseCancel.cubicAxisParameter_mem {a : ℝ} (ha : 0 < a) (t : ℝ) :
+    cubicAxisParameter a t ∈ Set.Ioo (-a) a := by
+  have hlo := mul_lt_mul_of_pos_left (Real.neg_one_lt_tanh (a * t)) ha
+  have hhi := mul_lt_mul_of_pos_left (Real.tanh_lt_one (a * t)) ha
+  constructor
+  · simpa only [cubicAxisParameter, mul_neg, mul_one] using hlo
+  · simpa only [cubicAxisParameter, mul_one] using hhi
+
+private theorem MorseCancel.range_cubicAxisParameter {a : ℝ} (ha : 0 < a) :
+    Set.range (cubicAxisParameter a) = Set.Ioo (-a) a := by
+  ext s
+  constructor
+  · rintro ⟨t, rfl⟩
+    exact cubicAxisParameter_mem ha t
+  · intro hs
+    have hs' : s / a ∈ Set.Ioo (-1 : ℝ) 1 := by
+      constructor
+      · apply (lt_div_iff₀ ha).mpr
+        simpa only [neg_one_mul] using hs.1
+      · apply (div_lt_iff₀ ha).mpr
+        simpa only [one_mul] using hs.2
+    refine ⟨Real.artanh (s / a) / a, ?_⟩
+    simp only [cubicAxisParameter, mul_div_cancel₀ _ ha.ne', Real.tanh_artanh hs']
+
+private theorem MorseCancel.tendsto_cubicAxisParameter_atTop {a : ℝ} (ha : 0 < a) :
+    Filter.Tendsto (cubicAxisParameter a) Filter.atTop (𝓝 a) := by
+  have h := (tendsto_tanh_atTop.comp (Filter.tendsto_id.const_mul_atTop ha)).const_mul a
+  change Filter.Tendsto (cubicAxisParameter a) Filter.atTop (𝓝 (a * 1)) at h
+  simpa only [mul_one] using h
+
+private theorem MorseCancel.tendsto_cubicAxisParameter_atBot {a : ℝ} (ha : 0 < a) :
+    Filter.Tendsto (cubicAxisParameter a) Filter.atBot (𝓝 (-a)) := by
+  have h := (tendsto_tanh_atBot.comp (Filter.tendsto_id.const_mul_atBot ha)).const_mul a
+  change Filter.Tendsto (cubicAxisParameter a) Filter.atBot (𝓝 (a * -1)) at h
+  simpa only [mul_neg, mul_one] using h
+
+private def MorseCancel.cubicModelOrbit {m : ℕ} (a t : ℝ) : Model m :=
+  (cubicAxisParameter a t, 0)
+
+private theorem
+    MorseCancel.cubicModelOrbit_zero {m : ℕ} (a : ℝ) : cubicModelOrbit (m := m) a 0 = 0 := by
+  simp [cubicModelOrbit, cubicAxisParameter, Real.tanh_zero]
+
+private theorem MorseCancel.hasDerivAt_cubicModelOrbit {m : ℕ} (σ : Fin m → ℝ) (a t : ℝ) :
+    HasDerivAt (cubicModelOrbit a) (cubicDescent σ (-(a ^ 2)) (cubicModelOrbit a t)) t := by
+  have h := (hasDerivAt_cubicAxisParameter a t).prodMk (hasDerivAt_const t (0 : Fin m → ℝ))
+  change HasDerivAt (cubicModelOrbit a) (a ^ 2 - cubicAxisParameter a t ^ 2, 0) t at h
+  convert h using 1
+  apply Prod.ext
+  · change -(cubicAxisParameter a t ^ 2 + -(a ^ 2)) = a ^ 2 - cubicAxisParameter a t ^ 2
+    ring
+  · funext i
+    simp only [cubicDescent, cubicModelOrbit, Pi.zero_apply, MulZeroClass.mul_zero]
+
+private theorem MorseCancel.range_cubicModelOrbit {m : ℕ} {a : ℝ} (ha : 0 < a) :
+    Set.range (cubicModelOrbit (m := m) a) = Set.Ioo (-a) a ×ˢ {(0 : Fin m → ℝ)} := by
+  ext p
+  constructor
+  · rintro ⟨t, rfl⟩
+    exact ⟨cubicAxisParameter_mem ha t, rfl⟩
+  · rintro ⟨hs, hz⟩
+    obtain ⟨t, ht⟩ := (range_cubicAxisParameter ha).symm ▸ hs
+    refine ⟨t, ?_⟩
+    exact Prod.ext ht (show (0 : Fin m → ℝ) = p.2 from hz.symm)
+
+private theorem MorseCancel.tendsto_cubicModelOrbit_atTop {m : ℕ} {a : ℝ} (ha : 0 < a) :
+    Filter.Tendsto (cubicModelOrbit (m := m) a) Filter.atTop (𝓝 (a, 0)) :=
+  (tendsto_cubicAxisParameter_atTop ha).prodMk_nhds tendsto_const_nhds
+
+private theorem MorseCancel.tendsto_cubicModelOrbit_atBot {m : ℕ} {a : ℝ} (ha : 0 < a) :
+    Filter.Tendsto (cubicModelOrbit (m := m) a) Filter.atBot (𝓝 (-a, 0)) :=
+  (tendsto_cubicAxisParameter_atBot ha).prodMk_nhds tendsto_const_nhds
+
+private theorem MorseCancel.contDiffAt_artanh {x : ℝ} (hx : x ∈ Set.Ioo (-1 : ℝ) 1) :
+    ContDiffAt ℝ ∞ Real.artanh x := by
+  have hp : 0 < (1 + x) / (1 - x) := div_pos (by linarith [hx.1]) (by linarith [hx.2])
+  have hr : ContDiffAt ℝ ∞ (fun y : ℝ => (1 + y) / (1 - y)) x :=
+    (contDiffAt_const.add contDiffAt_id).div (contDiffAt_const.sub contDiffAt_id)
+      (by linarith [hx.2])
+  exact (hr.sqrt hp.ne').log (Real.sqrt_pos.mpr hp).ne'
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Recognition/Smale4.lean b/LeanPool/HopfProblem/Recognition/Smale4.lean
new file mode 100644
index 000000000..b13a1ac3f
--- /dev/null
+++ b/LeanPool/HopfProblem/Recognition/Smale4.lean
@@ -0,0 +1,5656 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Foundations.TwoAffineCharts
+import all LeanPool.HopfProblem.Recognition.Smale1
+import all LeanPool.HopfProblem.Recognition.Smale2
+import all LeanPool.HopfProblem.Recognition.Smale3
+import all LeanPool.HopfProblem.Foundations.TwoAffineCharts
+
+/-!
+# Hopf problem: recognition · smale 4
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem
+    MorseCancel.contDiff_cubicAxisParameter (a : ℝ) : ContDiff ℝ ∞ (cubicAxisParameter a) := by
+  have ht : ContDiff ℝ ∞ Real.tanh := by
+    have hh : ContDiff ℝ ∞ (fun t => Real.sinh t / Real.cosh t) :=
+      Real.contDiff_sinh.div Real.contDiff_cosh (fun t => (Real.cosh_pos t).ne')
+    have he : (fun t => Real.sinh t / Real.cosh t) = Real.tanh :=
+      funext (fun t => (Real.tanh_eq_sinh_div_cosh t).symm)
+    rw [he] at hh
+    exact hh
+  change ContDiff ℝ ∞ (fun t => a * Real.tanh (a * t))
+  exact contDiff_const.mul (ht.comp (contDiff_const.mul contDiff_id))
+
+private def MorseCancel.cubicAxisClock (a s : ℝ) : ℝ :=
+  Real.artanh (s / a) / a
+
+private theorem MorseCancel.cubicAxisClock_parameter {a : ℝ} (ha : 0 < a) (t : ℝ) :
+    cubicAxisClock a (cubicAxisParameter a t) = t := by
+  simp only [cubicAxisClock, cubicAxisParameter, mul_div_cancel_left₀ _ ha.ne', Real.artanh_tanh]
+
+private theorem
+    MorseCancel.cubicAxisParameter_clock {a s : ℝ} (ha : 0 < a) (hs : s ∈ Set.Ioo (-a) a) :
+    cubicAxisParameter a (cubicAxisClock a s) = s := by
+  have hs' : s / a ∈ Set.Ioo (-1 : ℝ) 1 := by
+    constructor
+    · exact (lt_div_iff₀ ha).mpr (by simpa only [neg_one_mul] using hs.1)
+    · exact (div_lt_iff₀ ha).mpr (by simpa only [one_mul] using hs.2)
+  simp only [cubicAxisClock, cubicAxisParameter, mul_div_cancel₀ _ ha.ne', Real.tanh_artanh hs']
+
+private theorem MorseCancel.contDiffOn_cubicAxisClock {a : ℝ} (ha : 0 < a) :
+    ContDiffOn ℝ ∞ (cubicAxisClock a) (Set.Ioo (-a) a) := by
+  intro s hs
+  have hs' : s / a ∈ Set.Ioo (-1 : ℝ) 1 := by
+    constructor
+    · exact (lt_div_iff₀ ha).mpr (by simpa only [neg_one_mul] using hs.1)
+    · exact (div_lt_iff₀ ha).mpr (by simpa only [one_mul] using hs.2)
+  exact
+    (((contDiffAt_artanh hs').comp s (contDiffAt_id.div_const a)).div_const a).contDiffWithinAt
+
+private def MorseCancel.cubicFlowCylinder {m : ℕ} (σ : Fin m → ℝ) (a : ℝ) (p : (Fin m → ℝ) × ℝ) :
+    Model m :=
+  (cubicAxisParameter a p.2, fun i => Real.exp (-σ i * p.2) * p.1 i)
+
+private def MorseCancel.cubicFlowCylinderInverse {m : ℕ} (σ : Fin m → ℝ) (a : ℝ) (p : Model m) :
+    (Fin m → ℝ) × ℝ :=
+  (fun i => Real.exp (σ i * cubicAxisClock a p.1) * p.2 i, cubicAxisClock a p.1)
+
+private theorem MorseCancel.cubicFlowCylinder_left_inv {m : ℕ} (σ : Fin m → ℝ) {a : ℝ} (ha : 0 < a)
+    (p : (Fin m → ℝ) × ℝ) : cubicFlowCylinderInverse σ a (cubicFlowCylinder σ a p) = p := by
+  apply Prod.ext
+  · funext i
+    change
+      Real.exp (σ i * cubicAxisClock a (cubicAxisParameter a p.2)) *
+          (Real.exp (-σ i * p.2) * p.1 i) =
+        p.1 i
+    rw [cubicAxisClock_parameter ha, ← mul_assoc, ← Real.exp_add, neg_mul, add_neg_cancel,
+      Real.exp_zero, one_mul]
+  · exact cubicAxisClock_parameter ha p.2
+
+private theorem MorseCancel.cubicFlowCylinder_right_inv {m : ℕ} (σ : Fin m → ℝ) {a : ℝ} (ha : 0 < a)
+    {p : Model m} (hp : p.1 ∈ Set.Ioo (-a) a) :
+    cubicFlowCylinder σ a (cubicFlowCylinderInverse σ a p) = p := by
+  apply Prod.ext
+  · exact cubicAxisParameter_clock ha hp
+  · funext i
+    change
+      Real.exp (-σ i * cubicAxisClock a p.1) * (Real.exp (σ i * cubicAxisClock a p.1) * p.2 i) =
+        p.2 i
+    rw [← mul_assoc, ← Real.exp_add, neg_mul, neg_add_cancel, Real.exp_zero, one_mul]
+
+private theorem MorseCancel.contDiff_cubicFlowCylinder {m : ℕ} (σ : Fin m → ℝ) (a : ℝ) :
+    ContDiff ℝ ∞ (cubicFlowCylinder σ a) := by
+  apply ((contDiff_cubicAxisParameter a).comp contDiff_snd).prodMk
+  apply contDiff_pi.mpr
+  intro i
+  fun_prop
+
+private theorem MorseCancel.contDiffOn_cubicFlowCylinderInverse {m : ℕ} (σ : Fin m → ℝ) {a : ℝ}
+    (ha : 0 < a) : ContDiffOn ℝ ∞ (cubicFlowCylinderInverse σ a) (Set.Ioo (-a) a ×ˢ Set.univ) := by
+  have ht :
+    ContDiffOn ℝ ∞ (fun p : Model m => cubicAxisClock a p.1) (Set.Ioo (-a) a ×ˢ Set.univ) :=
+    (contDiffOn_cubicAxisClock ha).comp contDiffOn_fst (fun _ hp => hp.1)
+  apply ContDiffOn.prodMk ?_ ht
+  apply contDiffOn_pi.mpr
+  intro i
+  exact
+    (Real.contDiff_exp.comp_contDiffOn (contDiffOn_const.mul ht)).mul
+      (((contDiff_apply ℝ ℝ i).comp contDiff_snd).contDiffOn)
+
+private def MorseCancel.cubicFlowCylinderChart {m : ℕ} (σ : Fin m → ℝ) {a : ℝ} (ha : 0 < a) :
+    PartialDiffeomorph 𝓘(ℝ, (Fin m → ℝ) × ℝ) 𝓘(ℝ, Model m) ((Fin m → ℝ) × ℝ) (Model m) ∞
+    where
+  toFun := cubicFlowCylinder σ a
+  invFun := cubicFlowCylinderInverse σ a
+  source := Set.univ
+  target := Set.Ioo (-a) a ×ˢ Set.univ
+  map_source' p _ := ⟨cubicAxisParameter_mem ha p.2, Set.mem_univ _⟩
+  map_target' _ _ := Set.mem_univ _
+  left_inv' p _ := cubicFlowCylinder_left_inv σ ha p
+  right_inv' _ hp := cubicFlowCylinder_right_inv σ ha hp.1
+  open_source := isOpen_univ
+  open_target := isOpen_Ioo.prod isOpen_univ
+  contMDiffOn_toFun := (contDiff_cubicFlowCylinder σ a).contMDiff.contMDiffOn
+  contMDiffOn_invFun := (contDiffOn_cubicFlowCylinderInverse σ ha).contMDiffOn
+
+private theorem
+    MorseCancel.hasDerivAt_cubicFlowCylinder {m : ℕ} (σ : Fin m → ℝ) (a : ℝ) (z : Fin m → ℝ)
+    (t : ℝ) :
+    HasDerivAt (fun s => cubicFlowCylinder σ a (z, s))
+      (cubicDescent σ (-(a ^ 2)) (cubicFlowCylinder σ a (z, t))) t := by
+  have hz :
+    HasDerivAt (fun s => fun i => Real.exp (-σ i * s) * z i)
+      (fun i => -σ i * (Real.exp (-σ i * t) * z i)) t := by
+    apply hasDerivAt_pi.mpr
+    intro i
+    have hd :=
+      ((Real.hasDerivAt_exp (-σ i * t)).comp t ((hasDerivAt_id t).const_mul (-σ i))).mul_const
+        (z i)
+    convert! hd using 1
+    first
+    | rfl
+    | ring
+  have hd := (hasDerivAt_cubicAxisParameter a t).prodMk hz
+  have he :
+    cubicDescent σ (-(a ^ 2)) (cubicFlowCylinder σ a (z, t)) =
+      (a ^ 2 - cubicAxisParameter a t ^ 2, fun i => -σ i * (Real.exp (-σ i * t) * z i)) := by
+    apply Prod.ext
+    · change -(cubicAxisParameter a t ^ 2 + -(a ^ 2)) = a ^ 2 - cubicAxisParameter a t ^ 2
+      ring
+    · rfl
+  rw [he]
+  exact hd
+
+private theorem MorseCancel.cubicFlowCylinder_axis {m : ℕ} (σ : Fin m → ℝ) (a t : ℝ) :
+    cubicFlowCylinder σ a (0, t) = cubicModelOrbit a t := by
+  simp only [cubicFlowCylinder, cubicModelOrbit, Pi.zero_apply, MulZeroClass.mul_zero]
+  rfl
+
+private theorem
+    MorseCancel.cubicFlowCylinder_zero_time {m : ℕ} (σ : Fin m → ℝ) (a : ℝ) (z : Fin m → ℝ) :
+    cubicFlowCylinder σ a (z, 0) = (0, z) := by
+  simp only [cubicFlowCylinder, cubicAxisParameter, MulZeroClass.mul_zero, Real.tanh_zero,
+    Real.exp_zero, one_mul]
+
+private theorem MorseCancel.monotone_cubicAxisParameter {a : ℝ} (ha : 0 < a) :
+    Monotone (cubicAxisParameter a) := by
+  intro s t hst
+  exact
+    mul_le_mul_of_nonneg_left (strictMono_tanh.monotone (mul_le_mul_of_nonneg_left hst ha.le))
+      ha.le
+
+private theorem MorseCancel.cubicFlowCylinder_transverse_norm_le_max {m : ℕ} (σ : Fin m → ℝ) (a : ℝ)
+    (z : Fin m → ℝ) {s t u : ℝ} (ht : t ∈ Set.Icc s u) :
+    ‖(cubicFlowCylinder σ a (z, t)).2‖ ≤
+      Max.max ‖(cubicFlowCylinder σ a (z, s)).2‖ ‖(cubicFlowCylinder σ a (z, u)).2‖ := by
+  let Z (r : ℝ) : Fin m → ℝ := (cubicFlowCylinder σ a (z, r)).2
+  have hcoord (r : ℝ) (i : Fin m) : ‖Z r i‖ = Real.exp (-σ i * r) * ‖z i‖ := by
+    change ‖Real.exp (-σ i * r) * z i‖ = _
+    rw [norm_mul, Real.norm_of_nonneg (Real.exp_pos _).le]
+  apply (pi_norm_le_iff_of_nonneg (le_max_of_le_left (norm_nonneg (Z s)))).mpr
+  intro i
+  change ‖Z t i‖ ≤ Max.max ‖Z s‖ ‖Z u‖
+  by_cases hi : 0 ≤ σ i
+  · calc
+      ‖Z t i‖ = Real.exp (-σ i * t) * ‖z i‖ := hcoord t i
+      _ ≤ Real.exp (-σ i * s) * ‖z i‖ :=
+        (mul_le_mul_of_nonneg_right
+          (Real.exp_le_exp.mpr (mul_le_mul_of_nonpos_left ht.1 (neg_nonpos.mpr hi)))
+          (norm_nonneg _))
+      _ = ‖Z s i‖ := (hcoord s i).symm
+      _ ≤ ‖Z s‖ := (norm_le_pi_norm (Z s) i)
+      _ ≤ Max.max ‖Z s‖ ‖Z u‖ := le_max_left _ _
+  · calc
+      ‖Z t i‖ = Real.exp (-σ i * t) * ‖z i‖ := hcoord t i
+      _ ≤ Real.exp (-σ i * u) * ‖z i‖ :=
+        (mul_le_mul_of_nonneg_right
+          (Real.exp_le_exp.mpr
+            (mul_le_mul_of_nonneg_left ht.2 (neg_nonneg.mpr (le_of_not_ge hi))))
+          (norm_nonneg _))
+      _ = ‖Z u i‖ := (hcoord u i).symm
+      _ ≤ ‖Z u‖ := (norm_le_pi_norm (Z u) i)
+      _ ≤ Max.max ‖Z s‖ ‖Z u‖ := le_max_right _ _
+
+private theorem
+    MorseCancel.cubicFlowCylinder_stays_axis_ball {m : ℕ} (σ : Fin m → ℝ) {a : ℝ} (ha : 0 < a)
+    (z : Fin m → ℝ) {s t u c r : ℝ} (ht : t ∈ Set.Icc s u)
+    (hs : cubicFlowCylinder σ a (z, s) ∈ Metric.closedBall (c, (0 : Fin m → ℝ)) r)
+    (hu : cubicFlowCylinder σ a (z, u) ∈ Metric.closedBall (c, (0 : Fin m → ℝ)) r) :
+    cubicFlowCylinder σ a (z, t) ∈ Metric.closedBall (c, (0 : Fin m → ℝ)) r := by
+  have hs' : |cubicAxisParameter a s - c| ≤ r ∧ ‖(cubicFlowCylinder σ a (z, s)).2‖ ≤ r := by
+    simpa only [Metric.mem_closedBall, Prod.dist_eq, max_le_iff, Real.dist_eq, dist_zero_right,
+      cubicFlowCylinder] using hs
+  have hu' : |cubicAxisParameter a u - c| ≤ r ∧ ‖(cubicFlowCylinder σ a (z, u)).2‖ ≤ r := by
+    simpa only [Metric.mem_closedBall, Prod.dist_eq, max_le_iff, Real.dist_eq, dist_zero_right,
+      cubicFlowCylinder] using hu
+  rw [Metric.mem_closedBall, Prod.dist_eq, max_le_iff, Real.dist_eq, dist_zero_right]
+  constructor
+  · change |cubicAxisParameter a t - c| ≤ r
+    apply abs_le.mpr
+    have hst := monotone_cubicAxisParameter ha ht.1
+    have htu := monotone_cubicAxisParameter ha ht.2
+    constructor <;> linarith [(abs_le.mp hs'.1).1, (abs_le.mp hu'.1).2]
+  · exact (cubicFlowCylinder_transverse_norm_le_max σ a z ht).trans (max_le hs'.2 hu'.2)
+
+private def Smale.FiberwiseDiffeomorph.retainParameter {X P : Type*} (F : X × P → X) (p : X × P) :
+    X × P :=
+  (F p, p.2)
+
+private theorem Smale.FiberwiseDiffeomorph.contMDiff_retainParameter {D H X P : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup P] [NormedSpace ℝ P]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ D H} [TopologicalSpace X] [ChartedSpace H X]
+    {F : X × P → X} (hF : ContMDiff (I.prod 𝓘(ℝ, P)) I ∞ F) :
+    ContMDiff (I.prod 𝓘(ℝ, P)) (I.prod 𝓘(ℝ, P)) ∞ (retainParameter F) :=
+  hF.prodMk contMDiff_snd
+
+private theorem Smale.FiberwiseDiffeomorph.bijective_retainParameter {X P : Type*} {F : X × P → X}
+    (hF : ∀ s, Function.Bijective (fun x => F (x, s))) : Function.Bijective (retainParameter F) :=
+  by
+  constructor
+  · rintro ⟨x, s⟩ ⟨y, t⟩ heq
+    have hst : s = t := congrArg Prod.snd heq
+    subst t
+    exact Prod.ext ((hF s).1 (congrArg Prod.fst heq)) rfl
+  · rintro ⟨y, s⟩
+    obtain ⟨x, hx⟩ := (hF s).2 y
+    exact ⟨(x, s), Prod.ext hx rfl⟩
+
+private theorem Smale.FiberwiseDiffeomorph.mfderiv_retainParameter_apply {D H X P : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup P] [NormedSpace ℝ P]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ D H} [TopologicalSpace X] [ChartedSpace H X]
+    {F : X × P → X} (hF : ContMDiff (I.prod 𝓘(ℝ, P)) I ∞ F) (p : X × P) (v : D × P) :
+    mfderiv (I.prod 𝓘(ℝ, P)) (I.prod 𝓘(ℝ, P)) (retainParameter F) p v =
+      (mfderiv I I (fun x => F (x, p.2)) p.1 v.1 +
+          mfderiv 𝓘(ℝ, P) I (fun s => F (p.1, s)) p.2 v.2,
+        v.2) := by
+  change mfderiv (I.prod 𝓘(ℝ, P)) (I.prod 𝓘(ℝ, P)) (fun z => (F z, z.2)) p v = _
+  rw [mfderiv_prodMk (hF.mdifferentiable (by simp) p) mdifferentiableAt_snd, mfderiv_snd]
+  change ((mfderiv (I.prod 𝓘(ℝ, P)) I F p) v, v.2) = _
+  exact Prod.ext (mfderiv_prod_eq_add_apply (v := v) (hF.mdifferentiable (by simp) p)) rfl
+
+private theorem Smale.FiberwiseDiffeomorph.isInvertible_mfderiv_retainParameter {D H X P : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup P] [NormedSpace ℝ P]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ D H} [TopologicalSpace X] [ChartedSpace H X]
+    [FiniteDimensional ℝ D] [FiniteDimensional ℝ P] {F : X × P → X}
+    (hF : ContMDiff (I.prod 𝓘(ℝ, P)) I ∞ F)
+    (hslice : ∀ s, ∃ d : Diffeomorph I I X X ∞, ∀ x, d x = F (x, s)) (p : X × P) :
+    (mfderiv (I.prod 𝓘(ℝ, P)) (I.prod 𝓘(ℝ, P)) (retainParameter F) p).IsInvertible := by
+  let A : D →L[ℝ] D := mfderiv I I (fun x => F (x, p.2)) p.1
+  let B : P →L[ℝ] D := mfderiv 𝓘(ℝ, P) I (fun s => F (p.1, s)) p.2
+  have hA : Function.Bijective A := by
+    obtain ⟨d, hd⟩ := hslice p.2
+    have heq : (fun x => F (x, p.2)) = d := funext (fun x => (hd x).symm)
+    change Function.Bijective (mfderiv I I (fun x => F (x, p.2)) p.1)
+    rw [heq]
+    exact (d.mfderivToContinuousLinearEquiv (by simp) p.1).bijective
+  let L : (D × P) →L[ℝ] (D × P) := mfderiv (I.prod 𝓘(ℝ, P)) (I.prod 𝓘(ℝ, P)) (retainParameter F) p
+  have hL (v : D × P) : L v = (A v.1 + B v.2, v.2) := mfderiv_retainParameter_apply hF p v
+  have hbij : Function.Bijective L := by
+    constructor
+    · intro u v huv
+      have hs : u.2 = v.2 := by simpa only [hL] using congrArg Prod.snd huv
+      have hx : A u.1 + B u.2 = A v.1 + B v.2 := by simpa only [hL] using congrArg Prod.fst huv
+      rw [hs] at hx
+      exact Prod.ext (hA.1 (add_right_cancel hx)) hs
+    · intro v
+      obtain ⟨x, hx⟩ := hA.2 (v.1 - B v.2)
+      refine ⟨(x, v.2), ?_⟩
+      rw [hL, hx, sub_add_cancel]
+  exact ⟨(LinearEquiv.ofBijective L.toLinearMap hbij).toContinuousLinearEquiv, rfl⟩
+
+private def Smale.FiberwiseDiffeomorph.diffeomorph {D H X P : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup P] [NormedSpace ℝ P] [TopologicalSpace H]
+    {I : ModelWithCorners ℝ D H} [TopologicalSpace X] [ChartedSpace H X] [FiniteDimensional ℝ D]
+    [FiniteDimensional ℝ P] [I.Boundaryless] [IsManifold I ∞ X] {F : X × P → X}
+    (hF : ContMDiff (I.prod 𝓘(ℝ, P)) I ∞ F)
+    (hslice : ∀ s, ∃ d : Diffeomorph I I X X ∞, ∀ x, d x = F (x, s)) :
+    Diffeomorph (I.prod 𝓘(ℝ, P)) (I.prod 𝓘(ℝ, P)) (X × P) (X × P) ∞ := by
+  have hlocal : IsLocalDiffeomorph (I.prod 𝓘(ℝ, P)) (I.prod 𝓘(ℝ, P)) ∞ (retainParameter F) := by
+    intro p
+    exact
+      Smale.isLocalDiffeomorphAt_boundaryless isOpen_univ (Set.mem_univ p)
+        (contMDiff_retainParameter hF).contMDiffOn
+        (isInvertible_mfderiv_retainParameter hF hslice p)
+  apply hlocal.diffeomorphOfBijective
+  apply bijective_retainParameter
+  intro s
+  obtain ⟨d, hd⟩ := hslice s
+  have heq : (fun x => F (x, s)) = d := funext (fun x => (hd x).symm)
+  rw [heq]
+  exact d.bijective
+
+private def Smale.PartialChart.vectorProduct (E F : Type*) [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] :
+    Diffeomorph 𝓘(ℝ, E × F) (𝓘(ℝ, E).prod 𝓘(ℝ, F)) (E × F) (E × F) ∞
+    where
+  toEquiv := Equiv.refl (E × F)
+  contMDiff_toFun := contDiff_fst.contMDiff.prodMk contDiff_snd.contMDiff
+  contMDiff_invFun := contMDiff_fst.prodMk_space contMDiff_snd
+
+private def
+    Smale.PartialChart.prod {E₁ E₂ F₁ F₂ H₁ H₂ G₁ G₂ X₁ X₂ Y₁ Y₂ : Type*} [NormedAddCommGroup E₁]
+    [NormedSpace ℝ E₁] [NormedAddCommGroup E₂] [NormedSpace ℝ E₂] [NormedAddCommGroup F₁]
+    [NormedSpace ℝ F₁] [NormedAddCommGroup F₂] [NormedSpace ℝ F₂] [TopologicalSpace H₁]
+    [TopologicalSpace H₂] [TopologicalSpace G₁] [TopologicalSpace G₂]
+    {I₁ : ModelWithCorners ℝ E₁ H₁} {I₂ : ModelWithCorners ℝ E₂ H₂}
+    {J₁ : ModelWithCorners ℝ F₁ G₁} {J₂ : ModelWithCorners ℝ F₂ G₂} [TopologicalSpace X₁]
+    [ChartedSpace H₁ X₁] [TopologicalSpace X₂] [ChartedSpace H₂ X₂] [TopologicalSpace Y₁]
+    [ChartedSpace G₁ Y₁] [TopologicalSpace Y₂] [ChartedSpace G₂ Y₂]
+    (Φ : PartialDiffeomorph I₁ J₁ X₁ Y₁ ∞) (Ψ : PartialDiffeomorph I₂ J₂ X₂ Y₂ ∞) :
+    PartialDiffeomorph (I₁.prod I₂) (J₁.prod J₂) (X₁ × X₂) (Y₁ × Y₂) ∞
+    where
+  __ := Φ.toOpenPartialHomeomorph.prod Ψ.toOpenPartialHomeomorph
+  contMDiffOn_toFun := Φ.contMDiffOn_toFun.prodMap Ψ.contMDiffOn_toFun
+  contMDiffOn_invFun := Φ.contMDiffOn_invFun.prodMap Ψ.contMDiffOn_invFun
+
+private theorem Degree.FlowSuspension.exists_isotopy_suspension_diffeomorph {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] {A : ℝ × E → E}
+    (hA : ContDiff ℝ ∞ A)
+    (hslice : ∀ t, ∃ d : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞, ∀ x, d x = A (t, x)) :
+    ∃ Ψ : Diffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, E × ℝ) (E × ℝ) (E × ℝ) ∞, ∀ p, Ψ p = (A (p.2, p.1), p.2) :=
+  by
+  have hF : ContMDiff (𝓘(ℝ, E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) ∞ (fun p : E × ℝ => A (p.2, p.1)) :=
+    hA.contMDiff.comp (contMDiff_snd.prodMk_space contMDiff_fst)
+  let D := Smale.FiberwiseDiffeomorph.diffeomorph hF hslice
+  let V := Smale.PartialChart.vectorProduct E ℝ
+  exact ⟨(V.trans D).trans V.symm, fun p => rfl⟩
+
+private def
+    Degree.FlowSuspension.suspensionFlow {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (Ψ : Diffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, E × ℝ) (E × ℝ) (E × ℝ) ∞) : Flow ℝ (E × ℝ)
+    where
+  toFun t p := Ψ ((Ψ.symm p).1, (Ψ.symm p).2 + t)
+  cont' := by
+    apply Ψ.continuous.comp
+    exact
+      (Ψ.symm.continuous.comp continuous_snd).fst.prodMk
+        ((Ψ.symm.continuous.comp continuous_snd).snd.add continuous_fst)
+  map_zero' p := by simp only [add_zero, Prod.mk.eta, Ψ.apply_symm_apply]
+  map_add' s t
+    p := by
+    simp only [Ψ.symm_apply_apply]
+    congr 1
+    apply Prod.ext
+    · rfl
+    · ring
+
+private theorem Degree.FlowSuspension.suspensionFlow_chart {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (Ψ : Diffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, E × ℝ) (E × ℝ) (E × ℝ) ∞) (t : ℝ)
+    (p : E × ℝ) : suspensionFlow Ψ t (Ψ p) = Ψ (p.1, p.2 + t) := by
+  change Ψ ((Ψ.symm (Ψ p)).1, (Ψ.symm (Ψ p)).2 + t) = _
+  rw [Ψ.symm_apply_apply]
+
+private theorem Degree.FlowSuspension.suspensionFlow_height {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (Ψ : Diffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, E × ℝ) (E × ℝ) (E × ℝ) ∞)
+    (hheight : ∀ p, (Ψ p).2 = p.2) (t : ℝ) (p : E × ℝ) : (suspensionFlow Ψ t p).2 = p.2 + t := by
+  have hinv : (Ψ.symm p).2 = p.2 := by
+    have hh := hheight (Ψ.symm p)
+    rw [Ψ.apply_symm_apply] at hh
+    exact hh.symm
+  change (Ψ ((Ψ.symm p).1, (Ψ.symm p).2 + t)).2 = _
+  rw [hheight, hinv]
+
+private theorem Degree.FlowSuspension.suspensionFlow_endpoint {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {A : ℝ × E → E} (Ψ : Diffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, E × ℝ) (E × ℝ) (E × ℝ) ∞)
+    (hΨ : ∀ p, Ψ p = (A (p.2, p.1), p.2)) (hA0 : ∀ x, A (0, x) = x) (x : E) :
+    suspensionFlow Ψ 1 (x, 0) = (A (1, x), 1) := by
+  have hstart : Ψ (x, (0 : ℝ)) = (x, 0) := by rw [hΨ, hA0]
+  rw [← hstart, suspensionFlow_chart, zero_add, hΨ]
+
+private def
+    Degree.FlowSuspension.suspensionField {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (Ψ : Diffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, E × ℝ) (E × ℝ) (E × ℝ) ∞) (p : E × ℝ) : E × ℝ :=
+  fderiv ℝ Ψ (Ψ.symm p) (0, 1)
+
+private theorem Degree.FlowSuspension.contDiff_suspensionField {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (Ψ : Diffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, E × ℝ) (E × ℝ) (E × ℝ) ∞) :
+    ContDiff ℝ ∞ (suspensionField Ψ) := by
+  have hΨ : ContDiff ℝ ∞ (Ψ : (E × ℝ) → E × ℝ) := Ψ.contMDiff.contDiff
+  have hΨinv : ContDiff ℝ ∞ (Ψ.symm : (E × ℝ) → E × ℝ) := Ψ.symm.contMDiff.contDiff
+  exact ((hΨ.fderiv_right (by simp)).comp hΨinv).clm_apply contDiff_const
+
+private theorem Degree.FlowSuspension.hasDerivAt_suspensionFlow {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (Ψ : Diffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, E × ℝ) (E × ℝ) (E × ℝ) ∞) (p : E × ℝ)
+    (t : ℝ) :
+    HasDerivAt (fun s => suspensionFlow Ψ s p) (suspensionField Ψ (suspensionFlow Ψ t p)) t := by
+  have hb : HasDerivAt (fun s : ℝ => ((Ψ.symm p).1, (Ψ.symm p).2 + s)) (0, 1) t :=
+    (hasDerivAt_const t (Ψ.symm p).1).prodMk ((hasDerivAt_id t).const_add (Ψ.symm p).2)
+  have hd :=
+    (Ψ.contMDiff.contDiff.differentiable (by simp)
+          ((Ψ.symm p).1, (Ψ.symm p).2 + t)).hasFDerivAt.comp_hasDerivAt
+      t hb
+  change
+    HasDerivAt (fun s => Ψ ((Ψ.symm p).1, (Ψ.symm p).2 + s))
+      (fderiv ℝ Ψ (Ψ.symm (Ψ ((Ψ.symm p).1, (Ψ.symm p).2 + t))) (0, 1)) t
+  rw [Ψ.symm_apply_apply]
+  exact hd
+
+private theorem
+    Degree.FlowSuspension.hasDerivAt_suspensionFlow_zero {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (Ψ : Diffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, E × ℝ) (E × ℝ) (E × ℝ) ∞) (p : E × ℝ) :
+    HasDerivAt (fun s => suspensionFlow Ψ s p) (suspensionField Ψ p) 0 := by
+  simpa only [(suspensionFlow Ψ).map_zero_apply] using hasDerivAt_suspensionFlow Ψ p 0
+
+private theorem Degree.FlowSuspension.suspensionField_height {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (Ψ : Diffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, E × ℝ) (E × ℝ) (E × ℝ) ∞)
+    (hheight : ∀ p, (Ψ p).2 = p.2) (p : E × ℝ) : (suspensionField Ψ p).2 = 1 := by
+  have hd : HasDerivAt (fun t => (suspensionFlow Ψ t p).2) (suspensionField Ψ p).2 0 :=
+    (hasDerivAt_suspensionFlow_zero Ψ p).snd
+  have heq : (fun t => (suspensionFlow Ψ t p).2) = fun t => p.2 + t :=
+    funext (fun t => suspensionFlow_height Ψ hheight t p)
+  rw [heq] at hd
+  exact hd.unique ((hasDerivAt_id (0 : ℝ)).const_add p.2)
+
+private theorem Degree.FlowSuspension.suspensionField_eq_vertical_of_stationary {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] {A : ℝ × E → E}
+    (Ψ : Diffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, E × ℝ) (E × ℝ) (E × ℝ) ∞)
+    (hΨ : ∀ p, Ψ p = (A (p.2, p.1), p.2)) (p : E × ℝ)
+    (hstationary : ∀ᶠ s in 𝓝 p.2, ∀ x, A (s, x) = A (p.2, x)) : suspensionField Ψ p = (0, 1) := by
+  let q := Ψ.symm p
+  have hq : Ψ q = p := Ψ.apply_symm_apply p
+  have hqheight : q.2 = p.2 := by
+    have hh := congrArg Prod.snd hq
+    rw [hΨ] at hh
+    exact hh
+  have hqfirst : A (p.2, q.1) = p.1 := by
+    have hh := congrArg Prod.fst hq
+    rw [hΨ] at hh
+    change A (q.2, q.1) = p.1 at hh
+    rwa [hqheight] at hh
+  have ht : Filter.Tendsto (fun t : ℝ => p.2 + t) (𝓝 0) (𝓝 p.2) := by
+    have hc : Continuous (fun t : ℝ => p.2 + t) := continuous_const.add continuous_id
+    simpa only [add_zero] using hc.tendsto (0 : ℝ)
+  have heq : (fun t => suspensionFlow Ψ t p) =ᶠ[𝓝 0] (fun t => (p.1, p.2 + t)) := by
+    filter_upwards [ht.eventually hstationary] with t hts
+    change Ψ (q.1, q.2 + t) = (p.1, p.2 + t)
+    rw [hΨ, hqheight, hts q.1, hqfirst]
+  have hv : HasDerivAt (fun t : ℝ => (p.1, p.2 + t)) (0, 1) 0 :=
+    (hasDerivAt_const 0 p.1).prodMk ((hasDerivAt_id (0 : ℝ)).const_add p.2)
+  exact ((hasDerivAt_suspensionFlow_zero Ψ p).congr_of_eventuallyEq heq.symm).unique hv
+
+private theorem Degree.FlowSuspension.suspensionFlow_vertical_off_support {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] {A : ℝ × E → E}
+    (Ψ : Diffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, E × ℝ) (E × ℝ) (E × ℝ) ∞)
+    (hΨ : ∀ p, Ψ p = (A (p.2, p.1), p.2)) {K : Set E} (hfix : ∀ t x, x ∉ K → A (t, x) = x)
+    {p : E × ℝ} (hp : p.1 ∉ K) (t : ℝ) : suspensionFlow Ψ t p = (p.1, p.2 + t) := by
+  have hΨp : Ψ p = p := by rw [hΨ, hfix _ _ hp]
+  have hinv : Ψ.symm p = p := by
+    have hh := Ψ.symm_apply_apply p
+    rwa [hΨp] at hh
+  change Ψ ((Ψ.symm p).1, (Ψ.symm p).2 + t) = _
+  rw [hinv, hΨ, hfix _ _ hp]
+
+private theorem Degree.FlowSuspension.suspensionField_eq_vertical_off_support {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] {A : ℝ × E → E}
+    (Ψ : Diffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, E × ℝ) (E × ℝ) (E × ℝ) ∞)
+    (hΨ : ∀ p, Ψ p = (A (p.2, p.1), p.2)) {K : Set E} (hfix : ∀ t x, x ∉ K → A (t, x) = x)
+    {p : E × ℝ} (hp : p.1 ∉ K) : suspensionField Ψ p = (0, 1) := by
+  have heq : (fun t => suspensionFlow Ψ t p) = fun t => (p.1, p.2 + t) :=
+    funext (fun t => suspensionFlow_vertical_off_support Ψ hΨ hfix hp t)
+  have hd := hasDerivAt_suspensionFlow_zero Ψ p
+  rw [heq] at hd
+  exact hd.unique ((hasDerivAt_const 0 p.1).prodMk ((hasDerivAt_id (0 : ℝ)).const_add p.2))
+
+private theorem Degree.FlowSuspension.hasCompactSupport_suspensionField_sub_vertical {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] {A : ℝ × E → E}
+    (Ψ : Diffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, E × ℝ) (E × ℝ) (E × ℝ) ∞)
+    (hΨ : ∀ p, Ψ p = (A (p.2, p.1), p.2)) {K : Set E} (hK : IsCompact K)
+    (hfix : ∀ t x, x ∉ K → A (t, x) = x) {a b : ℝ}
+    (hstationary : ∀ s ∉ Set.Icc a b, ∀ᶠ r in 𝓝 s, ∀ x, A (r, x) = A (s, x)) :
+    HasCompactSupport (fun p => suspensionField Ψ p - (0, 1)) := by
+  apply
+    HasCompactSupport.intro (hK.prod (CompactIccSpace.isCompact_Icc : IsCompact (Set.Icc a b)))
+  intro p hp
+  have hv : suspensionField Ψ p = (0, 1) := by
+    by_cases hx : p.1 ∈ K
+    · have ht : p.2 ∉ Set.Icc a b := fun h => hp ⟨hx, h⟩
+      exact suspensionField_eq_vertical_of_stationary Ψ hΨ p (hstationary _ ht)
+    · exact suspensionField_eq_vertical_off_support Ψ hΨ hfix hx
+  rw [hv, sub_self]
+
+private theorem Smale.SupportedDiffeomorph.contMDiff_extendFamily {E F H H' X Y : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H'] {J : ModelWithCorners ℝ F H'}
+    [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y] [T2Space Y]
+    (Φ : PartialDiffeomorph I J X Y ∞) {A : ℝ × X → X} (hA : ContMDiff (𝓘(ℝ, ℝ).prod I) I ∞ A)
+    {K : Set X} (hK : IsCompact K) (hKΦ : K ⊆ Φ.source) (hfix : ∀ t x, x ∉ K → A (t, x) = x)
+    (hsource : ∀ t, Set.MapsTo (fun x => A (t, x)) Φ.source Φ.source) :
+    ContMDiff (𝓘(ℝ, ℝ).prod J) J ∞ (fun p : ℝ × Y => extendMap Φ (fun x => A (p.1, x)) p.2) := by
+  intro p
+  by_cases hp : p.2 ∈ Φ.target
+  · have hback :=
+      (Φ.contMDiffOn_invFun.contMDiffAt (Φ.open_target.mem_nhds hp)).comp p
+        (contMDiffAt_snd : ContMDiffAt (𝓘(ℝ, ℝ).prod J) J ∞ Prod.snd p)
+    have hpair := contMDiffAt_fst.prodMk hback
+    have hchange := hA.contMDiffAt.comp p hpair
+    have hforward :=
+      Φ.contMDiffOn_toFun.contMDiffAt (Φ.open_source.mem_nhds (hsource p.1 (Φ.map_target' hp)))
+    apply (hforward.comp p hchange).congr_of_eventuallyEq
+    have hn : ∀ᶠ q : ℝ × Y in 𝓝 p, q.2 ∈ Φ.target :=
+      continuous_snd.continuousAt.preimage_mem_nhds (Φ.open_target.mem_nhds hp)
+    filter_upwards [hn] with q hq
+    exact extendMap_of_mem Φ (fun x => A (q.1, x)) hq
+  · have hc : IsClosed (Φ '' K) :=
+      (hK.image_of_continuousOn (Φ.contMDiffOn_toFun.continuousOn.mono hKΦ)).isClosed
+    have hnot : p.2 ∉ Φ '' K := by
+      rintro ⟨x, hx, hxp⟩
+      exact hp (hxp ▸ Φ.map_source' (hKΦ hx))
+    have hsnd : ContMDiffAt (𝓘(ℝ, ℝ).prod J) J ∞ Prod.snd p := contMDiffAt_snd
+    apply hsnd.congr_of_eventuallyEq
+    have hn : ∀ᶠ q : ℝ × Y in 𝓝 p, q.2 ∉ Φ '' K :=
+      continuous_snd.continuousAt.preimage_mem_nhds (hc.isOpen_compl.mem_nhds hnot)
+    filter_upwards [hn] with q hq
+    exact extendMap_eq_of_notMem_image Φ (hfix q.1) hq
+
+private theorem Smale.SupportedDiffeomorph.contMDiffAt_extendFamily {E F H H' X Y : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H'] {J : ModelWithCorners ℝ F H'}
+    [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y] [T2Space Y]
+    (Φ : PartialDiffeomorph I J X Y ∞) {P : Type*} [NormedAddCommGroup P] [NormedSpace ℝ P]
+    {A : P × X → X} (hA : ContMDiff (𝓘(ℝ, P).prod I) I ∞ A) {K : Set X} (hK : IsCompact K)
+    (hKΦ : K ⊆ Φ.source) (hfix : ∀ t x, x ∉ K → A (t, x) = x) {p : P × Y}
+    (hsource : Set.MapsTo (fun x => A (p.1, x)) Φ.source Φ.source) :
+    ContMDiffAt (𝓘(ℝ, P).prod J) J ∞ (fun q : P × Y => extendMap Φ (fun x => A (q.1, x)) q.2) p :=
+  by
+  by_cases hp : p.2 ∈ Φ.target
+  · have hback :=
+      (Φ.contMDiffOn_invFun.contMDiffAt (Φ.open_target.mem_nhds hp)).comp p
+        (contMDiffAt_snd : ContMDiffAt (𝓘(ℝ, P).prod J) J ∞ Prod.snd p)
+    have hpair := contMDiffAt_fst.prodMk hback
+    have hchange := hA.contMDiffAt.comp p hpair
+    have hforward :=
+      Φ.contMDiffOn_toFun.contMDiffAt (Φ.open_source.mem_nhds (hsource (Φ.map_target' hp)))
+    apply (hforward.comp p hchange).congr_of_eventuallyEq
+    have hn : ∀ᶠ q : P × Y in 𝓝 p, q.2 ∈ Φ.target :=
+      continuous_snd.continuousAt.preimage_mem_nhds (Φ.open_target.mem_nhds hp)
+    filter_upwards [hn] with q hq
+    exact extendMap_of_mem Φ (fun x => A (q.1, x)) hq
+  · have hc : IsClosed (Φ '' K) :=
+      (hK.image_of_continuousOn (Φ.contMDiffOn_toFun.continuousOn.mono hKΦ)).isClosed
+    have hnot : p.2 ∉ Φ '' K := by
+      rintro ⟨x, hx, hxp⟩
+      exact hp (hxp ▸ Φ.map_source' (hKΦ hx))
+    have hsnd : ContMDiffAt (𝓘(ℝ, P).prod J) J ∞ Prod.snd p := contMDiffAt_snd
+    apply hsnd.congr_of_eventuallyEq
+    have hn : ∀ᶠ q : P × Y in 𝓝 p, q.2 ∉ Φ '' K :=
+      continuous_snd.continuousAt.preimage_mem_nhds (hc.isOpen_compl.mem_nhds hnot)
+    filter_upwards [hn] with q hq
+    exact extendMap_eq_of_notMem_image Φ (hfix q.1) hq
+
+private def Smale.SupportedDiffeomorph.bumpFamily {E F H M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ F H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) J E M ∞) (β : E → ℝ) (p : E × M) : M :=
+  extendMap Φ (fun x => x + β x • p.1) p.2
+
+private theorem Smale.SupportedDiffeomorph.bumpFamily_zero {E F H M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ F H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) J E M ∞) (β : E → ℝ) (y : M) : bumpFamily Φ β (0, y) = y := by
+  have heq : (fun x : E => x + β x • (0 : E)) = id := by funext x; simp
+  change extendMap Φ (fun x => x + β x • (0 : E)) y = y
+  rw [heq]
+  exact extendMap_id Φ y
+
+private theorem Smale.SupportedDiffeomorph.bumpFamily_chart {E F H M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ F H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) J E M ∞) (β : E → ℝ) (a : E) {x : E} (hx : x ∈ Φ.source) :
+    bumpFamily Φ β (a, Φ x) = Φ (x + β x • a) :=
+  extendMap_chart Φ _ hx
+
+private theorem
+    Smale.SupportedDiffeomorph.bumpFamily_mem_target {E F H M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ F H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) J E M ∞) (β : E → ℝ) (a : E)
+    (hsource : Set.MapsTo (fun x => x + β x • a) Φ.source Φ.source) {y : M} (hy : y ∈ Φ.target) :
+    bumpFamily Φ β (a, y) ∈ Φ.target :=
+  extendMap_mem_target Φ hsource hy
+
+private theorem
+    Smale.SupportedDiffeomorph.bumpFamily_coordinates {E F H M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ F H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) J E M ∞) (β : E → ℝ) (a : E)
+    (hsource : Set.MapsTo (fun x => x + β x • a) Φ.source Φ.source) {y : M} (hy : y ∈ Φ.target) :
+    Φ.symm (bumpFamily Φ β (a, y)) = Φ.symm y + β (Φ.symm y) • a := by
+  change Φ.symm (extendMap Φ (fun x => x + β x • a) y) = _
+  rw [extendMap_of_mem Φ _ hy]
+  exact Φ.left_inv' (hsource (Φ.map_target' hy))
+
+private theorem Smale.SupportedDiffeomorph.bumpFamily_fixed_outside {E F H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ F H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) J E M ∞) (β : E → ℝ) (a : E) {y : M}
+    (hy : y ∉ Φ '' tsupport β) : bumpFamily Φ β (a, y) = y := by
+  apply extendMap_eq_of_notMem_image Φ (K := tsupport β) _ hy
+  intro x hx
+  have hzero : β x = 0 := by
+    by_contra hn
+    exact hx (subset_tsupport β hn)
+  simp only [hzero, zero_smul, add_zero]
+
+private theorem Smale.SupportedDiffeomorph.exists_radius_ambient_bumpFamily {E F H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ F H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) J E M ∞) [FiniteDimensional ℝ E] [T2Space M] {β : E → ℝ}
+    (hβ : ContDiff ℝ ∞ β) (hcompact : HasCompactSupport β) (hsupport : tsupport β ⊆ Φ.source) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        (∀ a : E, ‖a‖ < ε → ∃ D : Diffeomorph J J M M ∞, ∀ y, D y = bumpFamily Φ β (a, y)) ∧
+          (∀ p : E × M, ‖p.1‖ < ε → ContMDiffAt (𝓘(ℝ, E).prod J) J ∞ (bumpFamily Φ β) p) ∧
+            ∀ a : E, ‖a‖ < ε → Set.MapsTo (fun x => x + β x • a) Φ.source Φ.source := by
+  obtain ⟨ε, hε, hsmall⟩ := Smale.SmallPerturbation.exists_radius_bumpTranslation hβ hcompact
+  let A : E × E → E := fun p => p.2 + β p.2 • p.1
+  have hA : ContMDiff (𝓘(ℝ, E).prod 𝓘(ℝ, E)) 𝓘(ℝ, E) ∞ A :=
+    contMDiff_snd.add ((hβ.contMDiff.comp contMDiff_snd).smul contMDiff_fst)
+  have hfix : ∀ a x, x ∉ tsupport β → A (a, x) = x := by
+    intro a x hx
+    have hzero : β x = 0 := by
+      by_contra hn
+      exact hx (subset_tsupport β hn)
+    simp only [A, hzero, zero_smul, add_zero]
+  have hsource (a : E) (ha : ‖a‖ < ε) : Set.MapsTo (fun x => A (a, x)) Φ.source Φ.source := by
+    obtain ⟨d, hd, hdfix⟩ := hsmall a ha
+    have heq : (fun x => A (a, x)) = d := funext (fun x => (hd x).symm)
+    rw [heq]
+    exact mapsTo_source Φ d.toEquiv hsupport hdfix
+  refine ⟨ε, hε, ?_, ?_, hsource⟩
+  · intro a ha
+    obtain ⟨d, hd, hdfix⟩ := hsmall a ha
+    refine ⟨extension Φ d hcompact.isCompact hsupport hdfix, ?_⟩
+    intro y
+    change extendMap Φ d y = extendMap Φ (fun x => x + β x • a) y
+    exact congrArg (fun f : E → E => extendMap Φ f y) (funext hd)
+  · intro p hp
+    exact contMDiffAt_extendFamily Φ hA hcompact.isCompact hsupport hfix (hsource p.1 hp)
+
+private theorem
+    Smale.SupportedDiffeomorph.eventually_bumpFamily_maps_compact_into_open {E F H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ F H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) J E M ∞) [FiniteDimensional ℝ E] [T2Space M] {X : Type*}
+    [TopologicalSpace X] {β : E → ℝ} (hβ : ContDiff ℝ ∞ β) (hcompact : HasCompactSupport β)
+    (hsupport : tsupport β ⊆ Φ.source) {f : X → M} (hf : Continuous f) {C : Set X}
+    (hC : IsCompact C) {O : Set M} (hO : IsOpen O) (hmap : Set.MapsTo f C O) :
+    ∀ᶠ a in 𝓝 (0 : E), Set.MapsTo (fun x => bumpFamily Φ β (a, f x)) C O := by
+  obtain ⟨δ, hδ, -, hsmooth, -⟩ := exists_radius_ambient_bumpFamily Φ hβ hcompact hsupport
+  apply hC.eventually_forall_of_forall_eventually
+  intro x hx
+  have hpair : ContinuousAt (fun p : E × X => (p.1, f p.2)) (0, x) :=
+    (continuous_fst.prodMk (hf.comp continuous_snd)).continuousAt
+  have hbase : ContinuousAt (bumpFamily Φ β) (0, f x) :=
+    (hsmooth (0, f x) (by simpa only [norm_zero] using hδ)).continuousAt
+  have hfamily : ContinuousAt (fun p : E × X => bumpFamily Φ β (p.1, f p.2)) (0, x) :=
+    ContinuousAt.comp (g := bumpFamily Φ β) (f := fun p : E × X => (p.1, f p.2)) hbase hpair
+  apply hfamily.preimage_mem_nhds
+  apply hO.mem_nhds
+  rw [bumpFamily_zero]
+  exact hmap hx
+
+private theorem Smale.SupportedDiffeomorph.exists_small_supported_bump_isotopy {E F H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [TopologicalSpace H] {J : ModelWithCorners ℝ F H} [TopologicalSpace M]
+    [ChartedSpace H M] [T2Space M] (Φ : PartialDiffeomorph 𝓘(ℝ, E) J E M ∞) {β : E → ℝ}
+    (hs : ContDiff ℝ ∞ β) (hcompact : HasCompactSupport β) (hsupport : tsupport β ⊆ Φ.source) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∀ a : E,
+          ‖a‖ < ε →
+            ∃ A : ℝ × M → M,
+              ContMDiff (𝓘(ℝ, ℝ).prod J) J ∞ A ∧
+                (∀ y, A (0, y) = y) ∧
+                  (∀ t, ∃ d : Diffeomorph J J M M ∞, ∀ y, A (t, y) = d y) ∧
+                    (∀ t y, y ∉ Φ '' tsupport β → A (t, y) = y) ∧
+                      ∀ x ∈ Φ.source, A (1, Φ x) = Φ (x + β x • a) := by
+  obtain ⟨ε, hε, hsmall⟩ := Smale.SmallPerturbation.exists_radius_bumpTranslation hs hcompact
+  refine ⟨ε, hε, ?_⟩
+  intro a ha
+  let B : ℝ × E → E := fun p => p.2 + β p.2 • (Real.smoothTransition p.1 • a)
+  have hθ : ContMDiff 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) ∞ Real.smoothTransition :=
+    (Real.smoothTransition.contDiff (n := ⊤)).contMDiff
+  have hB : ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, E)) 𝓘(ℝ, E) ∞ B :=
+    contMDiff_snd.add
+      ((hs.contMDiff.comp contMDiff_snd).smul ((hθ.comp contMDiff_fst).smul contMDiff_const))
+  have hmodel :
+    ∀ t : ℝ,
+      ∃ d : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞,
+        (∀ x, d x = B (t, x)) ∧ ∀ x ∉ tsupport β, d x = x := by
+    intro t
+    have hnorm : ‖Real.smoothTransition t • a‖ ≤ ‖a‖ := by
+      rw [norm_smul, Real.norm_eq_abs, abs_of_nonneg (Real.smoothTransition.nonneg t)]
+      exact mul_le_of_le_one_left (norm_nonneg a) (Real.smoothTransition.le_one t)
+    exact hsmall (Real.smoothTransition t • a) (hnorm.trans_lt ha)
+  have hfix : ∀ t x, x ∉ tsupport β → B (t, x) = x := by
+    intro t x hx
+    obtain ⟨d, hd, hdfix⟩ := hmodel t
+    exact (hd x).symm.trans (hdfix x hx)
+  have hsource : ∀ t, Set.MapsTo (fun x => B (t, x)) Φ.source Φ.source := by
+    intro t
+    obtain ⟨d, hd, hdfix⟩ := hmodel t
+    have heq : (fun x => B (t, x)) = d := funext (fun x => (hd x).symm)
+    rw [heq]
+    exact mapsTo_source Φ d.toEquiv hsupport hdfix
+  let A : ℝ × M → M := fun p => extendMap Φ (fun x => B (p.1, x)) p.2
+  refine ⟨A, contMDiff_extendFamily Φ hB hcompact.isCompact hsupport hfix hsource, ?_, ?_, ?_, ?_⟩
+  · intro y
+    have hzero : (fun x => B (0, x)) = id := by
+      funext x
+      simp only [B, Real.smoothTransition.zero, zero_smul, smul_zero, add_zero, id_eq]
+    change extendMap Φ (fun x => B (0, x)) y = y
+    rw [hzero]
+    exact extendMap_id Φ y
+  · intro t
+    obtain ⟨d, hd, hdfix⟩ := hmodel t
+    refine ⟨extension Φ d hcompact.isCompact hsupport hdfix, ?_⟩
+    intro y
+    change extendMap Φ (fun x => B (t, x)) y = extendMap Φ d y
+    exact congrArg (fun f : E → E => extendMap Φ f y) (funext (fun x => (hd x).symm))
+  · intro t y hy
+    exact extendMap_eq_of_notMem_image Φ (hfix t) hy
+  · intro x hx
+    change extendMap Φ (fun y => B (1, y)) (Φ x) = _
+    rw [extendMap_chart Φ (fun y => B (1, y)) hx]
+    simp only [B, Real.smoothTransition.one, one_smul]
+
+private def Smale.SupportedDiffeomorph.IsotopicToIdentity {F H M : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [TopologicalSpace H] {J : ModelWithCorners ℝ F H} [TopologicalSpace M]
+    [ChartedSpace H M] (e : Diffeomorph J J M M ∞) : Prop :=
+  ∃ A : ℝ × M → M,
+    ContMDiff (𝓘(ℝ, ℝ).prod J) J ∞ A ∧
+      (∀ y, A (0, y) = y) ∧
+        (∀ y, A (1, y) = e y) ∧ ∀ t, ∃ d : Diffeomorph J J M M ∞, ∀ y, A (t, y) = d y
+
+private theorem
+    Smale.SupportedDiffeomorph.isotopicToIdentity_refl {F H M : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [TopologicalSpace H] {J : ModelWithCorners ℝ F H} [TopologicalSpace M]
+    [ChartedSpace H M] : IsotopicToIdentity (Diffeomorph.refl J M ∞) := by
+  refine ⟨Prod.snd, contMDiff_snd, fun _ => rfl, fun _ => rfl, ?_⟩
+  exact fun _ => ⟨Diffeomorph.refl J M ∞, fun _ => rfl⟩
+
+private theorem
+    Smale.SupportedDiffeomorph.IsotopicToIdentity.trans {F H M : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [TopologicalSpace H] {J : ModelWithCorners ℝ F H} [TopologicalSpace M]
+    [ChartedSpace H M] {e d : Diffeomorph J J M M ∞}
+    (he : Smale.SupportedDiffeomorph.IsotopicToIdentity e)
+    (hd : Smale.SupportedDiffeomorph.IsotopicToIdentity d) :
+    Smale.SupportedDiffeomorph.IsotopicToIdentity (e.trans d) := by
+  obtain ⟨A, hA, hA₀, hA₁, hAd⟩ := he
+  obtain ⟨B, hB, hB₀, hB₁, hBd⟩ := hd
+  refine ⟨fun p => B (p.1, A p), hB.comp (contMDiff_fst.prodMk hA), ?_, ?_, ?_⟩
+  · intro y
+    change B (0, A (0, y)) = y
+    rw [hA₀, hB₀]
+  · intro y
+    change B (1, A (1, y)) = d (e y)
+    rw [hA₁, hB₁]
+  · intro t
+    obtain ⟨e', he'⟩ := hAd t
+    obtain ⟨d', hd'⟩ := hBd t
+    refine ⟨e'.trans d', ?_⟩
+    intro y
+    change B (t, A (t, y)) = d' (e' y)
+    rw [he', hd']
+
+private theorem Smale.SupportedDiffeomorph.exists_radius_bumpFamily_isotopy {F H M : Type*}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] {J : ModelWithCorners ℝ F H}
+    [TopologicalSpace M] [ChartedSpace H M] {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] [T2Space M] (Φ : PartialDiffeomorph 𝓘(ℝ, E) J E M ∞) {β : E → ℝ}
+    (hβ : ContDiff ℝ ∞ β) (hcompact : HasCompactSupport β) (hsupport : tsupport β ⊆ Φ.source) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∀ a : E,
+          ‖a‖ < ε →
+            ∀ e : Diffeomorph J J M M ∞,
+              (∀ y, e y = bumpFamily Φ β (a, y)) → IsotopicToIdentity e := by
+  obtain ⟨ε, hε, hsmall⟩ := exists_small_supported_bump_isotopy Φ hβ hcompact hsupport
+  refine ⟨ε, hε, ?_⟩
+  intro a ha e he
+  obtain ⟨A, hA, hzero, hdiff, hfix, hterminal⟩ := hsmall a ha
+  refine ⟨A, hA, hzero, ?_, hdiff⟩
+  intro y
+  rw [he]
+  by_cases hy : y ∈ Φ.target
+  · have hh := hterminal (Φ.symm y) (Φ.map_target' hy)
+    have hpoint : Φ (Φ.symm y) = y := Φ.right_inv' hy
+    rw [hpoint] at hh
+    change A (1, y) = extendMap Φ (fun x => x + β x • a) y
+    rw [extendMap_of_mem Φ _ hy]
+    exact hh
+  · have hnot : y ∉ Φ '' tsupport β := by
+      rintro ⟨x, hx, rfl⟩
+      exact hy (Φ.map_source' (hsupport hx))
+    rw [hfix 1 y hnot, bumpFamily_fixed_outside Φ β a hnot]
+
+private structure Smale.SupportedDiffeomorph.SupportedRelativeIsotopy {E H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {J : ModelWithCorners ℝ E H}
+    [TopologicalSpace M] [ChartedSpace H M] (e : Diffeomorph J J M M ∞) (K S : Set M) where
+  family : ℝ × M → M
+  smooth : ContMDiff (𝓘(ℝ, ℝ).prod J) J ∞ family
+  zero : ∀ x, family (0, x) = x
+  one : ∀ x, family (1, x) = e x
+  slices : ∀ t, ∃ d : Diffeomorph J J M M ∞, ∀ x, d x = family (t, x)
+  fixedOutside : ∀ t x, x ∉ K → family (t, x) = x
+  fixedOn : ∀ t x, x ∈ S → family (t, x) = x
+
+private theorem
+    Smale.SupportedDiffeomorph.SupportedRelativeIsotopy.isotopicToIdentity {E H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {J : ModelWithCorners ℝ E H}
+    [TopologicalSpace M] [ChartedSpace H M] {e : Diffeomorph J J M M ∞} {K S : Set M}
+    (A : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy e K S) :
+    Smale.SupportedDiffeomorph.IsotopicToIdentity e := by
+  refine ⟨A.family, A.smooth, A.zero, A.one, ?_⟩
+  intro t
+  obtain ⟨d, hd⟩ := A.slices t
+  exact ⟨d, fun x => (hd x).symm⟩
+
+private theorem
+    Smale.SupportedDiffeomorph.SupportedRelativeIsotopy.endpoint_fixed_outside {E H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {J : ModelWithCorners ℝ E H}
+    [TopologicalSpace M] [ChartedSpace H M] {e : Diffeomorph J J M M ∞} {K S : Set M}
+    (A : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy e K S) (x : M) (hx : x ∉ K) :
+    e x = x :=
+  (A.one x).symm.trans (A.fixedOutside 1 x hx)
+
+private theorem
+    Smale.SupportedDiffeomorph.SupportedRelativeIsotopy.endpoint_fixed_on {E H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {J : ModelWithCorners ℝ E H}
+    [TopologicalSpace M] [ChartedSpace H M] {e : Diffeomorph J J M M ∞} {K S : Set M}
+    (A : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy e K S) (x : M) (hx : x ∈ S) :
+    e x = x :=
+  (A.one x).symm.trans (A.fixedOn 1 x hx)
+
+private structure Degree.FlowSuspension.SuspensionCoordinates {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (D : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞) (K : Set E) (W : (E × ℝ) → E × ℝ)
+    (F : Flow ℝ (E × ℝ)) where
+  chart : Diffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, E × ℝ) (E × ℝ) (E × ℝ) ∞
+  field_eq : W = suspensionField chart
+  flow_eq : F = suspensionFlow chart
+  height : ∀ p, (chart p).2 = p.2
+  base_iff : ∀ U : Set E, K ⊆ U → ∀ p, (chart p).1 ∈ U ↔ p.1 ∈ U
+  lower : ∀ p, p.2 ≤ 0 → chart p = p
+  upper : ∀ p, 1 ≤ p.2 → chart p = (D p.1, p.2)
+
+private theorem
+    Degree.FlowSuspension.exists_compact_isotopy_suspension {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] (D : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞)
+    {K S : Set E} (hK : IsCompact K)
+    (I : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy D K S) :
+    ∃ (W : (E × ℝ) → E × ℝ) (F : Flow ℝ (E × ℝ)),
+      ContDiff ℝ ∞ W ∧
+        (∀ p, (W p).2 = 1) ∧
+          HasCompactSupport (fun p => W p - (0, 1)) ∧
+            tsupport (fun p => W p - (0, 1)) ⊆ K ×ˢ Set.Icc (1 / 3 : ℝ) (2 / 3) ∧
+              (∀ p t, HasDerivAt (fun s => F s p) (W (F t p)) t) ∧
+                (∀ x, F 1 (x, 0) = (D x, 1)) ∧
+                  (∀ t p, (F t p).2 = p.2 + t) ∧
+                    (∀ x ∉ K, ∀ s t : ℝ, F t (x, s) = (x, s + t)) ∧
+                      (∀ x ∈ S, ∀ s t : ℝ, F t (x, s) = (x, s + t)) ∧
+                        Nonempty (SuspensionCoordinates D K W F) := by
+  let τ : ℝ → ℝ := fun s => Real.smoothTransition (3 * s - 1)
+  have hτ : ContDiff ℝ ∞ τ :=
+    Real.smoothTransition.contDiff.comp ((contDiff_const.mul contDiff_id).sub contDiff_const)
+  have hτlower (s : ℝ) (hs : s ≤ 1 / 3) : τ s = 0 :=
+    Real.smoothTransition.zero_of_nonpos (by linarith)
+  have hτupper (s : ℝ) (hs : 2 / 3 ≤ s) : τ s = 1 :=
+    Real.smoothTransition.one_of_one_le (by linarith)
+  let A : ℝ × E → E := fun p => I.family (τ p.1, p.2)
+  have hInorm : ContDiff ℝ ∞ I.family :=
+    (I.smooth.comp (Smale.PartialChart.vectorProduct ℝ E).contMDiff).contDiff
+  have hA : ContDiff ℝ ∞ A := hInorm.comp ((hτ.comp contDiff_fst).prodMk contDiff_snd)
+  have hslice (s : ℝ) : ∃ d : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞, ∀ x, d x = A (s, x) :=
+    I.slices (τ s)
+  have hA0 (x : E) : A (0, x) = x := by
+    change I.family (τ 0, x) = x
+    rw [hτlower 0 (by norm_num)]
+    exact I.zero x
+  have hA1 (x : E) : A (1, x) = D x := by
+    change I.family (τ 1, x) = D x
+    rw [hτupper 1 (by norm_num)]
+    exact I.one x
+  have hfix (s : ℝ) (x : E) (hx : x ∉ K) : A (s, x) = x := I.fixedOutside (τ s) x hx
+  have hstationary (s : ℝ) (hs : s ∉ Set.Icc (1 / 3 : ℝ) (2 / 3)) :
+    ∀ᶠ r in 𝓝 s, ∀ x, A (r, x) = A (s, x) := by
+    by_cases hlo : s < 1 / 3
+    · filter_upwards [eventually_lt_nhds hlo] with r hr
+      intro x
+      change I.family (τ r, x) = I.family (τ s, x)
+      rw [hτlower r hr.le, hτlower s hlo.le]
+    · have hhi : 2 / 3 < s := lt_of_not_ge (fun h => hs ⟨le_of_not_gt hlo, h⟩)
+      filter_upwards [eventually_gt_nhds hhi] with r hr
+      intro x
+      change I.family (τ r, x) = I.family (τ s, x)
+      rw [hτupper r hr.le, hτupper s hhi.le]
+  obtain ⟨Ψ, hΨ⟩ := exists_isotopy_suspension_diffeomorph hA hslice
+  let W := suspensionField Ψ
+  let F := suspensionFlow Ψ
+  have hvertical (p : E × ℝ) (hp : p ∉ K ×ˢ Set.Icc (1 / 3 : ℝ) (2 / 3)) : W p = (0, 1) := by
+    by_cases hx : p.1 ∈ K
+    · exact
+        suspensionField_eq_vertical_of_stationary Ψ hΨ p (hstationary p.2 (fun h => hp ⟨hx, h⟩))
+    · exact suspensionField_eq_vertical_off_support Ψ hΨ hfix hx
+  have hsupp : tsupport (fun p => W p - (0, 1)) ⊆ K ×ˢ Set.Icc (1 / 3 : ℝ) (2 / 3) := by
+    apply closure_minimal _ (hK.isClosed.prod isClosed_Icc)
+    intro p hp
+    by_contra hout
+    apply hp
+    change W p - (0, 1) = 0
+    rw [hvertical p hout, sub_self]
+  have hcoords : SuspensionCoordinates D K W F := by
+    refine ⟨Ψ, rfl, rfl, fun p => by rw [hΨ], ?_, ?_, ?_⟩
+    · intro U hKU p
+      have hfixU (z : E × ℝ) (hz : z ∉ U ×ˢ Set.univ) : Ψ z = z := by
+        have hn : z.1 ∉ K := fun h => hz ⟨hKU h, Set.mem_univ _⟩
+        rw [hΨ, hfix z.2 z.1 hn]
+      have hmaps := Smale.SupportedDiffeomorph.mapsTo_of_fixed_outside Ψ.toEquiv hfixU
+      have hmapsInv :=
+        Smale.SupportedDiffeomorph.mapsTo_of_fixed_outside Ψ.symm.toEquiv
+          (Smale.SupportedDiffeomorph.inverse_fixed_outside Ψ.toEquiv hfixU)
+      constructor
+      · intro hp
+        have hh := hmapsInv ⟨hp, Set.mem_univ (Ψ p).2⟩
+        have hh' : (Ψ.symm (Ψ p)).1 ∈ U := hh.1
+        simpa only [Ψ.symm_apply_apply] using hh'
+      · intro hp
+        exact (hmaps ⟨hp, Set.mem_univ p.2⟩).1
+    · intro p hp
+      rw [hΨ]
+      change (I.family (τ p.2, p.1), p.2) = p
+      rw [hτlower p.2 (by linarith), I.zero]
+    · intro p hp
+      rw [hΨ]
+      change (I.family (τ p.2, p.1), p.2) = (D p.1, p.2)
+      rw [hτupper p.2 (by linarith), I.one]
+  refine
+    ⟨W, F, contDiff_suspensionField Ψ, suspensionField_height Ψ (fun p => by rw [hΨ]),
+      hasCompactSupport_suspensionField_sub_vertical Ψ hΨ hK hfix hstationary, hsupp,
+      hasDerivAt_suspensionFlow Ψ, ?_, suspensionFlow_height Ψ (fun p => by rw [hΨ]), ?_, ?_,
+      ⟨hcoords⟩⟩
+  · intro x
+    exact
+      (suspensionFlow_endpoint Ψ hΨ hA0 x).trans (congrArg (fun y : E => (y, (1 : ℝ))) (hA1 x))
+  · intro x hx s t
+    exact suspensionFlow_vertical_off_support Ψ hΨ hfix (p := (x, s)) hx t
+  · intro x hx s t
+    have hΨfix (r : ℝ) : Ψ (x, r) = (x, r) := by
+      rw [hΨ]
+      change (I.family (τ r, x), r) = (x, r)
+      rw [I.fixedOn (τ r) x hx]
+    change suspensionFlow Ψ t (x, s) = (x, s + t)
+    rw [← hΨfix s, suspensionFlow_chart, hΨfix]
+
+private def Degree.LocalFieldReplacement.replace {D E H X M : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H]
+    [TopologicalSpace X] [ChartedSpace H X] {I : ModelWithCorners ℝ D H} [TopologicalSpace M]
+    [ChartedSpace E M] (Φ : PartialDiffeomorph I 𝓘(ℝ, E) X M ∞)
+    (V W : (x : M) → TangentSpace 𝓘(ℝ, E) x) (x : M) : TangentSpace 𝓘(ℝ, E) x := by
+  classical exact if x ∈ Φ.target then W x else V x
+
+private theorem
+    Degree.LocalFieldReplacement.replace_of_mem {D E H X M : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H]
+    [TopologicalSpace X] [ChartedSpace H X] {I : ModelWithCorners ℝ D H} [TopologicalSpace M]
+    [ChartedSpace E M] (Φ : PartialDiffeomorph I 𝓘(ℝ, E) X M ∞)
+    (V W : (x : M) → TangentSpace 𝓘(ℝ, E) x) {x : M} (hx : x ∈ Φ.target) :
+    replace Φ V W x = W x := by simp [replace, hx]
+
+private theorem
+    Degree.LocalFieldReplacement.replace_of_notMem {D E H X M : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H]
+    [TopologicalSpace X] [ChartedSpace H X] {I : ModelWithCorners ℝ D H} [TopologicalSpace M]
+    [ChartedSpace E M] (Φ : PartialDiffeomorph I 𝓘(ℝ, E) X M ∞)
+    (V W : (x : M) → TangentSpace 𝓘(ℝ, E) x) {x : M} (hx : x ∉ Φ.target) :
+    replace Φ V W x = V x := by simp [replace, hx]
+
+private theorem Degree.LocalFieldReplacement.exists_smooth_field_replacement {D E H X M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace H] [TopologicalSpace X] [ChartedSpace H X] {I : ModelWithCorners ℝ D H}
+    [TopologicalSpace M] [ChartedSpace E M] (Φ : PartialDiffeomorph I 𝓘(ℝ, E) X M ∞) [T2Space M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (V W : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hW :
+      ContMDiffOn 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, W x⟩ : TangentBundle 𝓘(ℝ, E) M))
+        Φ.target)
+    {K : Set X} (hK : IsCompact K) (hKΦ : K ⊆ Φ.source)
+    (hfix : ∀ x ∈ Φ.target, x ∉ Φ '' K → W x = V x) (hreg : ∀ x ∈ Φ.target, W x ≠ 0) :
+    ∃ V' : (x : M) → TangentSpace 𝓘(ℝ, E) x,
+      ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V' x⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+        (∀ x ∈ Φ.target, V' x = W x) ∧
+          (∀ x, V' x = 0 ↔ V x = 0 ∧ x ∉ Φ.target) ∧ ∀ x ∉ Φ '' K, ∀ᶠ y in 𝓝 x, V' y = V y := by
+  let V' := replace Φ V W
+  have hclosed : IsClosed (Φ '' K) :=
+    (hK.image_of_continuousOn (Φ.contMDiffOn_toFun.continuousOn.mono hKΦ)).isClosed
+  have hoff (x : M) (hx : x ∉ Φ '' K) : ∀ᶠ y in 𝓝 x, V' y = V y := by
+    filter_upwards [hclosed.isOpen_compl.mem_nhds hx] with y hy
+    by_cases hyt : y ∈ Φ.target
+    · exact (replace_of_mem Φ V W hyt).trans (hfix y hyt hy)
+    · exact replace_of_notMem Φ V W hyt
+  have hsmooth :
+    ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V' x⟩ : TangentBundle 𝓘(ℝ, E) M)) := by
+    intro x
+    by_cases hx : x ∈ Φ.target
+    · apply (hW.contMDiffAt (Φ.open_target.mem_nhds hx)).congr_of_eventuallyEq
+      filter_upwards [Φ.open_target.mem_nhds hx] with y hy
+      exact congrArg (fun v => (⟨y, v⟩ : TangentBundle 𝓘(ℝ, E) M)) (replace_of_mem Φ V W hy)
+    · have hnot : x ∉ Φ '' K := by
+        rintro ⟨p, hp, rfl⟩
+        exact hx (Φ.map_source' (hKΦ hp))
+      apply hV.contMDiffAt.congr_of_eventuallyEq
+      filter_upwards [hoff x hnot] with y hy
+      exact congrArg (fun v => (⟨y, v⟩ : TangentBundle 𝓘(ℝ, E) M)) hy
+  refine ⟨V', hsmooth, fun x hx => replace_of_mem Φ V W hx, ?_, hoff⟩
+  intro x
+  by_cases hx : x ∈ Φ.target
+  · rw [show V' x = W x from replace_of_mem Φ V W hx]
+    simp only [hreg x hx, hx, not_true_eq_false, and_false]
+  · rw [show V' x = V x from replace_of_notMem Φ V W hx]
+    simp only [hx, not_false_eq_true, and_true]
+
+private theorem
+    Smale.exists_compact_smooth_cutoff {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] {K U : Set E} (hK : IsCompact K) (hU : IsOpen U) (hKU : K ⊆ U) :
+    ∃ η : E → ℝ,
+      ContDiff ℝ ∞ η ∧
+        HasCompactSupport η ∧
+          tsupport η ⊆ U ∧ (∀ᶠ x in 𝓝ˢ K, η x = 1) ∧ ∀ x, η x ∈ Set.Icc (0 : ℝ) 1 := by
+  obtain ⟨L, hL, hKL, hLU⟩ := exists_compact_between hK hU hKU
+  obtain ⟨η, hηone, hηzero, hηrange⟩ :=
+    exists_contMDiffMap_one_nhds_of_subset_interior 𝓘(ℝ, E) hK.isClosed hKL (n := ⊤)
+  have hsupp : tsupport (η : E → ℝ) ⊆ L := by
+    apply closure_minimal _ hL.isClosed
+    intro x hx
+    by_contra hxL
+    exact hx (hηzero x hxL)
+  exact
+    ⟨η, η.contMDiff.contDiff, HasCompactSupport.intro hL hηzero, hsupp.trans hLU, hηone, hηrange⟩
+
+private def
+    MorseCancel.cancelledDescent {m : ℕ} (σ : Fin m → ℝ) (a : ℝ) (φ : Model m → ℝ) (p : Model m) :
+    Model m :=
+  (a ^ 2 - p.1 ^ 2 - 2 * a ^ 2 * φ p, fun i => -σ i * p.2 i)
+
+private theorem
+    MorseCancel.contDiff_cancelledDescent {m : ℕ} (σ : Fin m → ℝ) (a : ℝ) {φ : Model m → ℝ}
+    (hφ : ContDiff ℝ ∞ φ) : ContDiff ℝ ∞ (cancelledDescent σ a φ) := by
+  unfold cancelledDescent
+  fun_prop
+
+private theorem
+    MorseCancel.cancelledDescent_axis_negative {m : ℕ} (σ : Fin m → ℝ) {a : ℝ} (ha : 0 < a)
+    {φ : Model m → ℝ} (hφ : ∀ p, 0 ≤ φ p) (hone : ∀ s ∈ Set.Icc (-a) a, φ (s, 0) = 1) (s : ℝ) :
+    (cancelledDescent σ a φ (s, 0)).1 < 0 := by
+  change a ^ 2 - s ^ 2 - 2 * a ^ 2 * φ (s, 0) < 0
+  by_cases hs : s ∈ Set.Icc (-a) a
+  · rw [hone s hs]
+    nlinarith [sq_pos_of_pos ha, sq_nonneg s]
+  · have hsq : a ^ 2 < s ^ 2 := by
+      by_cases hl : -a ≤ s
+      · have hr : a < s := lt_of_not_ge (fun h => hs ⟨hl, h⟩)
+        nlinarith
+      · have hh : s < -a := lt_of_not_ge hl
+        nlinarith
+    have hnonneg : 0 ≤ 2 * a ^ 2 * φ (s, 0) :=
+      mul_nonneg (mul_nonneg (by norm_num) (sq_nonneg a)) (hφ (s, 0))
+    linarith
+
+private theorem
+    MorseCancel.cancelledDescent_ne_zero {m : ℕ} (σ : Fin m → ℝ) (hσ : ∀ i, σ i ≠ 0) {a : ℝ}
+    (ha : 0 < a) {φ : Model m → ℝ} (hφ : ∀ p, 0 ≤ φ p) (hone : ∀ s ∈ Set.Icc (-a) a, φ (s, 0) = 1)
+    (p : Model m) : cancelledDescent σ a φ p ≠ 0 := by
+  intro hp
+  have hz : p.2 = 0 := by
+    funext i
+    have hi := congrArg (fun q : Model m => q.2 i) hp
+    change -σ i * p.2 i = 0 at hi
+    exact (mul_eq_zero.mp hi).resolve_left (neg_ne_zero.mpr (hσ i))
+  have he : p = (p.1, (0 : Fin m → ℝ)) := Prod.ext rfl hz
+  have hx := congrArg Prod.fst hp
+  rw [he] at hx
+  exact (cancelledDescent_axis_negative σ ha hφ hone p.1).ne hx
+
+private theorem MorseCancel.cancelledDescent_germ_off_support {m : ℕ} (σ : Fin m → ℝ) (a : ℝ)
+    {φ : Model m → ℝ} {p : Model m} (hp : p ∉ tsupport φ) :
+    cancelledDescent σ a φ =ᶠ[𝓝 p] cubicDescent σ (-(a ^ 2)) := by
+  filter_upwards [notMem_tsupport_iff_eventuallyEq.mp hp] with q hq
+  apply Prod.ext
+  · simp only [cancelledDescent, cubicDescent, hq, Pi.zero_apply, MulZeroClass.mul_zero, sub_zero]
+    ring
+  · rfl
+
+private theorem
+    MorseCancel.exists_cubic_field_cancellation {m : ℕ} (σ : Fin m → ℝ) (hσ : ∀ i, σ i ≠ 0)
+    {a : ℝ} (ha : 0 < a) {U : Set (Model m)} (hU : IsOpen U)
+    (haxis : Set.Icc (-a) a ×ˢ {(0 : Fin m → ℝ)} ⊆ U) :
+    ∃ φ : Model m → ℝ,
+      ContDiff ℝ ∞ φ ∧
+        HasCompactSupport φ ∧
+          tsupport φ ⊆ U ∧
+            (∀ p, φ p ∈ Set.Icc (0 : ℝ) 1) ∧
+              (∀ s ∈ Set.Icc (-a) a, φ (s, 0) = 1) ∧
+                ContDiff ℝ ∞ (cancelledDescent σ a φ) ∧
+                  (∀ p, cancelledDescent σ a φ p ≠ 0) ∧
+                    ∀ p ∉ tsupport φ, cancelledDescent σ a φ =ᶠ[𝓝 p] cubicDescent σ (-(a ^ 2)) := by
+  obtain ⟨φ, hφ, hc, hsupp, hone, hrange⟩ :=
+    Smale.exists_compact_smooth_cutoff (CompactIccSpace.isCompact_Icc.prod isCompact_singleton) hU
+      haxis
+  have hone' (s : ℝ) (hs : s ∈ Set.Icc (-a) a) : φ (s, (0 : Fin m → ℝ)) = 1 := by
+    have hn : ∀ᶠ p in 𝓝 (s, (0 : Fin m → ℝ)), φ p = 1 :=
+      (nhds_le_nhdsSet (show (s, (0 : Fin m → ℝ)) ∈ Set.Icc (-a) a ×ˢ {0} from ⟨hs, rfl⟩)) hone
+    exact hn.self_of_nhds
+  exact
+    ⟨φ, hφ, hc, hsupp, hrange, hone', contDiff_cancelledDescent σ a hφ,
+      cancelledDescent_ne_zero σ hσ ha (fun p => (hrange p).1) hone', fun p hp =>
+      cancelledDescent_germ_off_support σ a hp⟩
+
+private theorem MorseCancel.partialChartField_zero_iff {D E M : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] (Φ : PartialDiffeomorph 𝓘(ℝ, D) 𝓘(ℝ, E) D M ∞) (W : D → D) {x : M}
+    (hx : x ∈ Φ.target) :
+    Smale.FlowConstruction.partialChartField Φ.symm W x = 0 ↔ W (Φ.symm x) = 0 := by
+  rw [Smale.FlowConstruction.partialChartField_eq_mfderiv_symm Φ.symm W hx]
+  have hl : IsLocalDiffeomorphAt 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ Φ (Φ.symm x) :=
+    ⟨Φ, Φ.map_target' hx, fun _ _ => rfl⟩
+  let A := hl.mfderivToContinuousLinearEquiv (by simp)
+  let B : D ≃L[ℝ] TangentSpace 𝓘(ℝ, D) (Φ.symm x) :=
+    (NormedSpace.fromTangentSpace (Φ.symm x)).symm
+  change A (B (W (Φ.symm x))) = 0 ↔ W (Φ.symm x) = 0
+  constructor
+  · intro h
+    have hb : B (W (Φ.symm x)) = 0 := A.injective (h.trans (map_zero A).symm)
+    exact B.injective (hb.trans (map_zero B).symm)
+  · intro h
+    rw [h, map_zero, map_zero]
+
+private theorem
+    MorseCancel.cubicDescent_zero_iff {m : ℕ} (σ : Fin m → ℝ) (hσ : ∀ i, σ i ≠ 0) (a : ℝ)
+    (p : Model m) : cubicDescent σ (-(a ^ 2)) p = 0 ↔ p = (a, 0) ∨ p = (-a, 0) := by
+  rw [← negative_parameter_critical_iff σ hσ a p]
+  constructor
+  · intro hp
+    by_contra hn
+    have hh := cubicDescent_strict σ hn
+    rw [hp, map_zero] at hh
+    exact lt_irrefl _ hh
+  · exact cubicDescent_zero_of_critical σ
+
+private theorem
+    MorseCancel.exists_native_cubic_field_cancellation_in {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {m : ℕ} (σ : Fin m → ℝ)
+    [FiniteDimensional ℝ E] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] (hσ : ∀ i, σ i ≠ 0) {a : ℝ}
+    (ha : 0 < a) (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (haxis : Set.Icc (-a) a ×ˢ {(0 : Fin m → ℝ)} ⊆ Φ.source)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hmodel : ∀ x ∈ Φ.target, V x = nativeCubicDescent σ Φ (-(a ^ 2)) x) {N : Set M}
+    (hN : IsOpen N) (haxisN : ∀ s ∈ Set.Icc (-a) a, Φ (s, 0) ∈ N) :
+    ∃ φ : Model m → ℝ,
+      ContDiff ℝ ∞ φ ∧
+        HasCompactSupport φ ∧
+          tsupport φ ⊆ Φ.source ∧
+            Φ '' tsupport φ ⊆ N ∧
+              (∀ p, φ p ∈ Set.Icc (0 : ℝ) 1) ∧
+                (∀ s ∈ Set.Icc (-a) a, φ (s, 0) = 1) ∧
+                  ∃ V' : (x : M) → TangentSpace 𝓘(ℝ, E) x,
+                    ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞
+                        (fun x => (⟨x, V' x⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+                      (∀ x ∈ Φ.target,
+                          V' x =
+                            Smale.FlowConstruction.partialChartField Φ.symm
+                              (cancelledDescent σ a φ) x) ∧
+                        (∀ x, V' x = 0 ↔ V x = 0 ∧ x ≠ Φ (a, 0) ∧ x ≠ Φ (-a, 0)) ∧
+                          ∀ x ∉ Φ '' tsupport φ, ∀ᶠ y in 𝓝 x, V' y = V y := by
+  have hopen : IsOpen (Φ.source ∩ Φ ⁻¹' N) := Φ.toOpenPartialHomeomorph.isOpen_inter_preimage hN
+  have haxis' : Set.Icc (-a) a ×ˢ {(0 : Fin m → ℝ)} ⊆ Φ.source ∩ Φ ⁻¹' N := by
+    rintro ⟨s, z⟩ ⟨hs, hz⟩
+    have hz0 : z = 0 := hz
+    subst z
+    exact ⟨haxis ⟨hs, rfl⟩, haxisN s hs⟩
+  obtain ⟨φ, hφ, hc, hsupp', hrange, hone, hD, hnonzero, hoff⟩ :=
+    exists_cubic_field_cancellation σ hσ ha hopen haxis'
+  have hsupp : tsupport φ ⊆ Φ.source := fun _ hx => (hsupp' hx).1
+  have hsuppN : Φ '' tsupport φ ⊆ N := by
+    rintro x ⟨z, hz, rfl⟩
+    exact (hsupp' hz).2
+  let W := Smale.FlowConstruction.partialChartField Φ.symm (cancelledDescent σ a φ)
+  have hW :
+    ContMDiffOn 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, W x⟩ : TangentBundle 𝓘(ℝ, E) M))
+      Φ.target :=
+    Smale.FlowConstruction.contMDiffOn_partialChartField Φ.symm hD
+  have hfix (x : M) (hx : x ∈ Φ.target) (hnot : x ∉ Φ '' tsupport φ) : W x = V x := by
+    have hinv : Φ.symm x ∉ tsupport φ := fun h => hnot ⟨Φ.symm x, h, Φ.right_inv' hx⟩
+    have he := (hoff (Φ.symm x) hinv).eq_of_nhds
+    rw [hmodel x hx]
+    unfold W nativeCubicDescent Smale.FlowConstruction.partialChartField
+    simp only [VectorField.mpullback_apply, he]
+  have hreg (x : M) (hx : x ∈ Φ.target) : W x ≠ 0 := by
+    intro hz
+    exact hnonzero _ ((partialChartField_zero_iff Φ (cancelledDescent σ a φ) hx).mp hz)
+  obtain ⟨V', hV', heq, hzero, hkeep⟩ :=
+    Degree.LocalFieldReplacement.exists_smooth_field_replacement Φ V W hV hW hc hsupp hfix hreg
+  have hp : (a, (0 : Fin m → ℝ)) ∈ Φ.source := haxis ⟨⟨by linarith, le_rfl⟩, rfl⟩
+  have hq : (-a, (0 : Fin m → ℝ)) ∈ Φ.source := haxis ⟨⟨le_rfl, by linarith⟩, rfl⟩
+  refine ⟨φ, hφ, hc, hsupp, hsuppN, hrange, hone, V', hV', heq, ?_, hkeep⟩
+  intro x
+  rw [hzero x]
+  constructor
+  · rintro ⟨hx, hout⟩
+    exact ⟨hx, fun he => hout (he ▸ Φ.map_source' hp), fun he => hout (he ▸ Φ.map_source' hq)⟩
+  · rintro ⟨hx, hxp, hxq⟩
+    refine ⟨hx, ?_⟩
+    intro hxt
+    have hz : Smale.FlowConstruction.partialChartField Φ.symm (cubicDescent σ (-(a ^ 2))) x = 0 :=
+      (hmodel x hxt).symm.trans hx
+    have hd := (partialChartField_zero_iff Φ (cubicDescent σ (-(a ^ 2))) hxt).mp hz
+    rcases (cubicDescent_zero_iff σ hσ a (Φ.symm x)).mp hd with hh | hh
+    · exact hxp ((Φ.right_inv' hxt).symm.trans (congrArg Φ hh))
+    · exact hxq ((Φ.right_inv' hxt).symm.trans (congrArg Φ hh))
+
+private theorem Degree.FlowSuspension.exists_native_vertical_field_replacement {E B M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [FiniteDimensional ℝ B] [TopologicalSpace M] [ChartedSpace B M] [T2Space M]
+    [IsManifold 𝓘(ℝ, B) ∞ M] (Φ : PartialDiffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, B) (E × ℝ) M ∞)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, B) x)
+    (hV : ContMDiff 𝓘(ℝ, B) (𝓘(ℝ, B).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, B) M)))
+    (hmodel :
+      ∀ x ∈ Φ.target,
+        V x = Smale.FlowConstruction.partialChartField Φ.symm (fun _ : E × ℝ => (0, 1)) x)
+    {W : (E × ℝ) → E × ℝ} (hW : ContDiff ℝ ∞ W) (hWheight : ∀ p, (W p).2 = 1) {K : Set (E × ℝ)}
+    (hK : IsCompact K) (hKΦ : K ⊆ Φ.source) (hfix : ∀ p ∉ K, W p = (0, 1)) :
+    ∃ V' : (x : M) → TangentSpace 𝓘(ℝ, B) x,
+      ContMDiff 𝓘(ℝ, B) (𝓘(ℝ, B).tangent) ∞ (fun x => (⟨x, V' x⟩ : TangentBundle 𝓘(ℝ, B) M)) ∧
+        (∀ x ∈ Φ.target, V' x = Smale.FlowConstruction.partialChartField Φ.symm W x) ∧
+          (∀ x, V' x = 0 ↔ V x = 0) ∧ ∀ x ∉ Φ '' K, ∀ᶠ y in 𝓝 x, V' y = V y := by
+  let Wn := Smale.FlowConstruction.partialChartField Φ.symm W
+  have hWn :
+    ContMDiffOn 𝓘(ℝ, B) (𝓘(ℝ, B).tangent) ∞ (fun x => (⟨x, Wn x⟩ : TangentBundle 𝓘(ℝ, B) M))
+      Φ.target :=
+    Smale.FlowConstruction.contMDiffOn_partialChartField Φ.symm hW
+  have hreg (x : M) (hx : x ∈ Φ.target) : Wn x ≠ 0 := by
+    intro hz
+    have hWzero := (MorseCancel.partialChartField_zero_iff Φ W hx).mp hz
+    have hh := congrArg Prod.snd hWzero
+    rw [hWheight] at hh
+    exact one_ne_zero hh
+  have hregV (x : M) (hx : x ∈ Φ.target) : V x ≠ 0 := by
+    rw [hmodel x hx]
+    intro hz
+    have hh := (MorseCancel.partialChartField_zero_iff Φ (fun _ : E × ℝ => (0, 1)) hx).mp hz
+    exact one_ne_zero (congrArg Prod.snd hh)
+  have hkeep (x : M) (hx : x ∈ Φ.target) (hnot : x ∉ Φ '' K) : Wn x = V x := by
+    have hz : Φ.symm x ∉ K := fun h => hnot ⟨Φ.symm x, h, Φ.right_inv' hx⟩
+    rw [hmodel x hx]
+    change Smale.FlowConstruction.partialChartField Φ.symm W x = _
+    unfold Smale.FlowConstruction.partialChartField
+    rw [VectorField.mpullback_apply, VectorField.mpullback_apply, hfix _ hz]
+  obtain ⟨V', hV', hnew, hzeros, hgerm⟩ :=
+    Degree.LocalFieldReplacement.exists_smooth_field_replacement Φ V Wn hV hWn hK hKΦ hkeep hreg
+  refine ⟨V', hV', hnew, ?_, hgerm⟩
+  intro x
+  exact (hzeros x).trans ⟨And.left, fun hx => ⟨hx, fun ht => hregV x ht hx⟩⟩
+
+private theorem
+    Degree.FlowSuspension.mvfderiv_native_height_field {E B M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup B] [NormedSpace ℝ B] [TopologicalSpace M]
+    [ChartedSpace B M] (Φ : PartialDiffeomorph 𝓘(ℝ, E × ℝ) 𝓘(ℝ, B) (E × ℝ) M ∞) {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, B) 𝓘(ℝ, ℝ) ∞ f) {b : ℝ} (hheight : ∀ p ∈ Φ.source, f (Φ p) = b - p.2)
+    (W : (E × ℝ) → E × ℝ) {x : M} (hx : x ∈ Φ.target) :
+    mvfderiv 𝓘(ℝ, B) f x (Smale.FlowConstruction.partialChartField Φ.symm W x) =
+      -(W (Φ.symm x)).2 := by
+  let q := Φ.symm x
+  have hq : q ∈ Φ.source := Φ.map_target' hx
+  have heq : (f ∘ Φ) =ᶠ[𝓝 q] (fun p : E × ℝ => b - p.2) := by
+    filter_upwards [Φ.open_source.mem_nhds hq] with p hp
+    exact hheight p hp
+  have hd : fderiv ℝ (f ∘ Φ) q = fderiv ℝ (fun p : E × ℝ => b - p.2) q := heq.fderiv_eq
+  rw [Smale.FlowConstruction.mvfderiv_partialChartField hf Φ.symm W hx]
+  change fderiv ℝ (f ∘ Φ) q (W q) = -(W q).2
+  rw [hd]
+  have hh := (hasFDerivAt_const (𝕜 := ℝ) b q).sub (ContinuousLinearMap.snd ℝ E ℝ).hasFDerivAt
+  have hh' :
+    fderiv ℝ (fun p : E × ℝ => b - p.2) q =
+      (0 : (E × ℝ) →L[ℝ] ℝ) - ContinuousLinearMap.snd ℝ E ℝ :=
+    hh.fderiv
+  rw [hh']
+  simp
+
+private theorem Degree.FlowCancellation.exists_excursion_interval {X : Type*} [TopologicalSpace X]
+    {γ : ℝ → X} (hγ : Continuous γ) {K N : Set X} (hK : IsClosed K) (hKN : K ⊆ N) {a b t : ℝ}
+    (ht : t ∈ Set.Icc a b) (ha : γ a ∈ N) (hb : γ b ∈ N) (hout : γ t ∉ N) :
+    ∃ s u : ℝ, a ≤ s ∧ s < t ∧ t < u ∧ u ≤ b ∧ γ s ∈ N ∧ γ u ∈ N ∧ ∀ r ∈ Set.Ioo s u, γ r ∉ K := by
+  let A := Insert.insert a (Set.Icc a t ∩ γ ⁻¹' K)
+  let B := Insert.insert b (Set.Icc t b ∩ γ ⁻¹' K)
+  have hA : IsCompact A := (CompactIccSpace.isCompact_Icc.inter_right (hK.preimage hγ)).insert a
+  have hB : IsCompact B := (CompactIccSpace.isCompact_Icc.inter_right (hK.preimage hγ)).insert b
+  obtain ⟨s, hs⟩ := hA.exists_isGreatest (Set.insert_nonempty _ _)
+  obtain ⟨u, hu⟩ := hB.exists_isLeast (Set.insert_nonempty _ _)
+  have has : a ≤ s := hs.2 (Set.mem_insert _ _)
+  have hub : u ≤ b := hu.2 (Set.mem_insert _ _)
+  have hst : s ≤ t := by
+    rcases hs.1 with he | hh
+    · exact he ▸ ht.1
+    · exact hh.1.2
+  have htu : t ≤ u := by
+    rcases hu.1 with he | hh
+    · exact he ▸ ht.2
+    · exact hh.1.1
+  have hsN : γ s ∈ N := by
+    rcases hs.1 with he | hh
+    · exact he ▸ ha
+    · exact hKN hh.2
+  have huN : γ u ∈ N := by
+    rcases hu.1 with he | hh
+    · exact he ▸ hb
+    · exact hKN hh.2
+  have hst' : s < t := lt_of_le_of_ne hst (fun he => hout (he ▸ hsN))
+  have htu' : t < u := lt_of_le_of_ne htu (fun he => hout (he ▸ huN))
+  refine ⟨s, u, has, hst', htu', hub, hsN, huN, ?_⟩
+  intro r hr hrK
+  by_cases hrt : r ≤ t
+  · have hrA : r ∈ A := Or.inr ⟨⟨le_trans has hr.1.le, hrt⟩, hrK⟩
+    exact (not_le_of_gt hr.1) (hs.2 hrA)
+  · have hrB : r ∈ B := Or.inr ⟨⟨(lt_of_not_ge hrt).le, le_trans hr.2.le hub⟩, hrK⟩
+    exact (not_le_of_gt hr.2) (hu.2 hrB)
+
+private theorem Degree.FlowCancellation.native_curve_eq_flow_on_closed_interval {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M] {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) {γ : ℝ → M}
+    (hγcont : Continuous γ) {a b c : ℝ} (hc : c ∈ Set.Ioo a b)
+    (hγ : IsMIntegralCurveOn γ V (Set.Ioo a b)) : ∀ t ∈ Set.Icc a b, γ t = F (t - c) (γ c) := by
+  have hF : IsMIntegralCurve (fun t => F (t - c) (γ c)) V := by
+    have he : (fun t => F (t - c) (γ c)) = ((fun t => F t (γ c)) ∘ (· + -c)) := by
+      funext t
+      simp only [Function.comp_apply, sub_eq_add_neg]
+    rw [he]
+    exact (hcurve (γ c)).comp_add (-c)
+  have heq : Set.EqOn γ (fun t => F (t - c) (γ c)) (Set.Ioo a b) :=
+    isMIntegralCurveOn_Ioo_eqOn_of_contMDiff_boundaryless hc hV hγ (hF.isMIntegralCurveOn _)
+      (by simp)
+  have heqclosed := heq.closure hγcont hF.continuous
+  rw [closure_Ioo (lt_trans hc.1 hc.2).ne] at heqclosed
+  exact heqclosed
+
+private theorem Degree.FlowCancellation.native_no_return_of_supported_perturbation {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M] {V V' : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) {K N U : Set M}
+    (hK : IsClosed K) (hKN : K ⊆ N) (hNU : N ⊆ U) (hoff : ∀ x ∉ K, V' x = V x)
+    (hnoreturn : ∀ x ∈ N, ∀ t : ℝ, 0 ≤ t → F t x ∈ N → ∀ s ∈ Set.Icc (0 : ℝ) t, F s x ∈ U)
+    {γ : ℝ → M} (hγ : IsMIntegralCurve γ V') {a b : ℝ} (ha : γ a ∈ N) (hb : γ b ∈ N) :
+    ∀ t ∈ Set.Icc a b, γ t ∈ U := by
+  intro t ht
+  by_contra hout
+  obtain ⟨s, u, -, hst, htu, -, hsN, huN, havoid⟩ :=
+    exists_excursion_interval hγ.continuous hK hKN ht ha hb (fun hh => hout (hNU hh))
+  have hold : IsMIntegralCurveOn γ V (Set.Ioo s u) := by
+    intro r hr
+    have hd := (hγ r).hasMFDerivWithinAt (s := Set.Ioo s u)
+    rw [hoff (γ r) (havoid r hr)] at hd
+    exact hd
+  have heq :=
+    native_curve_eq_flow_on_closed_interval hV F hcurve hγ.continuous
+      (show t ∈ Set.Ioo s u from ⟨hst, htu⟩) hold
+  have hs : γ s = F (s - t) (γ t) := heq s ⟨le_rfl, (lt_trans hst htu).le⟩
+  have hu : γ u = F (u - t) (γ t) := heq u ⟨(lt_trans hst htu).le, le_rfl⟩
+  have hend : F (u - s) (γ s) = γ u := by
+    rw [hs, ← F.map_add, show u - s + (s - t) = u - t by ring, ← hu]
+  have hmid : F (t - s) (γ s) = γ t := by
+    rw [hs, ← F.map_add, show t - s + (s - t) = 0 by ring, F.map_zero_apply]
+  have hh :=
+    hnoreturn (γ s) hsN (u - s) (sub_nonneg.mpr (lt_trans hst htu).le) (hend ▸ huN) (t - s)
+      ⟨sub_nonneg.mpr hst.le, sub_le_sub_right htu.le s⟩
+  exact hout (hmid ▸ hh)
+
+private theorem
+    Degree.FlowSuspension.native_flow_segment_endpoints {B M : Type*} [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [TopologicalSpace M] [ChartedSpace B M] [IsManifold 𝓘(ℝ, B) 1 M] [T2Space M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, B) x}
+    (hV : ContMDiff 𝓘(ℝ, B) (𝓘(ℝ, B).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, B) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) {γ : ℝ → M} {a b : ℝ}
+    (hab : a < b) (hγcont : ContinuousOn γ (Set.Icc a b))
+    (hγ : IsMIntegralCurveOn γ V (Set.Ioo a b)) : F (b - a) (γ a) = γ b := by
+  let c := (a + b) / 2
+  have hc : c ∈ Set.Ioo a b := by constructor <;> dsimp [c] <;> linarith
+  have hη : IsMIntegralCurve (fun t => F (t - c) (γ c)) V := by
+    have hh := (hcurve (γ c)).comp_add (-c)
+    simpa only [sub_eq_add_neg, Function.comp_def] using hh
+  have heq : Set.EqOn γ (fun t => F (t - c) (γ c)) (Set.Ioo a b) :=
+    isMIntegralCurveOn_Ioo_eqOn_of_contMDiff_boundaryless hc hV hγ (hη.isMIntegralCurveOn _)
+      (by simp)
+  have heqclosed : Set.EqOn γ (fun t => F (t - c) (γ c)) (Set.Icc a b) :=
+    heq.of_subset_closure hγcont hη.continuous.continuousOn Set.Ioo_subset_Icc_self
+      (by rw [closure_Ioo hab.ne])
+  have ha := heqclosed (show a ∈ Set.Icc a b from ⟨le_rfl, hab.le⟩)
+  have hb := heqclosed (show b ∈ Set.Icc a b from ⟨hab.le, le_rfl⟩)
+  change γ a = F (a - c) (γ c) at ha
+  change γ b = F (b - c) (γ c) at hb
+  rw [ha, ← F.map_add, show b - a + (a - c) = b - c by ring, ← hb]
+
+private theorem
+    MorseCancel.native_cubic_flow_between_box_points {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M]
+    {m : ℕ} {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (σ : Fin m → ℝ) {a : ℝ} (ha : 0 < a)
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hmodel : ∀ x ∈ Φ.target, V x = nativeCubicDescent σ Φ (-(a ^ 2)) x) (F : Flow ℝ M)
+    (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {c r : ℝ}
+    (hbox : Metric.closedBall (c, (0 : Fin m → ℝ)) r ⊆ Φ.source) (z : Fin m → ℝ) {s t : ℝ}
+    (hs : cubicFlowCylinder σ a (z, s) ∈ Metric.closedBall (c, (0 : Fin m → ℝ)) r)
+    (ht : cubicFlowCylinder σ a (z, t) ∈ Metric.closedBall (c, (0 : Fin m → ℝ)) r) :
+    F (t - s) (Φ (cubicFlowCylinder σ a (z, s))) = Φ (cubicFlowCylinder σ a (z, t)) := by
+  let γ : ℝ → M := fun u => Φ (cubicFlowCylinder σ a (z, u))
+  have hforward {u v : ℝ} (huv : u < v)
+    (hu : cubicFlowCylinder σ a (z, u) ∈ Metric.closedBall (c, (0 : Fin m → ℝ)) r)
+    (hv : cubicFlowCylinder σ a (z, v) ∈ Metric.closedBall (c, (0 : Fin m → ℝ)) r) :
+    F (v - u) (γ u) = γ v := by
+    have hstay (w : ℝ) (hw : w ∈ Set.Icc u v) : cubicFlowCylinder σ a (z, w) ∈ Φ.source :=
+      hbox (cubicFlowCylinder_stays_axis_ball σ ha z hw hu hv)
+    have hcont : ContinuousOn γ (Set.Icc u v) :=
+      Φ.contMDiffOn_toFun.continuousOn.comp
+        (((contDiff_cubicFlowCylinder σ a).continuous.comp
+            (continuous_const.prodMk continuous_id)).continuousOn)
+        hstay
+    have hcurve : IsMIntegralCurveOn γ V (Set.Ioo u v) := by
+      intro w hw
+      have hp := hstay w ⟨hw.1.le, hw.2.le⟩
+      have hd :=
+        Smale.FlowConstruction.hasMFDerivAt_lift_partialChartCurve Φ.symm
+          (cubicDescent σ (-(a ^ 2))) (hasDerivAt_cubicFlowCylinder σ a z w) hp
+      have hd' :
+        HasMFDerivAt 𝓘(ℝ, ℝ) 𝓘(ℝ, E) γ w
+          ((1 : ℝ →L[ℝ] ℝ).smulRight (nativeCubicDescent σ Φ (-(a ^ 2)) (γ w))) :=
+        hd
+      rw [← hmodel (γ w) (Φ.map_source' hp)] at hd'
+      exact hd'.hasMFDerivWithinAt
+    exact Degree.FlowSuspension.native_flow_segment_endpoints hV F hF huv hcont hcurve
+  rcases lt_trichotomy s t with hst | hst | hts
+  · exact hforward hst hs ht
+  · subst t
+    rw [sub_self, F.map_zero_apply]
+  · have hh := congrArg (F (t - s)) (hforward hts ht hs)
+    rw [← F.map_add, show t - s + (s - t) = 0 by ring, F.map_zero_apply] at hh
+    exact hh.symm
+
+private theorem
+    MorseCancel.exists_cubic_slice_in_axis_ball {m : ℕ} (σ : Fin m → ℝ) {a : ℝ} (ha : 0 < a)
+    {c r : ℝ} (hc : c ∈ Set.Icc (-a) a) (hr : 0 < r) :
+    ∃ (T δ : ℝ),
+      0 < δ ∧
+        ∀ z : Fin m → ℝ,
+          ‖z‖ ≤ δ → cubicFlowCylinder σ a (z, T) ∈ Metric.ball (c, (0 : Fin m → ℝ)) r := by
+  have hcl : c ∈ closure (Set.Ioo (-a) a) := by
+    rw [closure_Ioo (by linarith : -a ≠ a)]
+    exact hc
+  obtain ⟨s, hs, hdist⟩ := Metric.mem_closure_iff.mp hcl r hr
+  let T := cubicAxisClock a s
+  have hpoint : cubicFlowCylinder σ a (0, T) = (s, (0 : Fin m → ℝ)) := by
+    rw [cubicFlowCylinder_axis]
+    change (cubicAxisParameter a (cubicAxisClock a s), 0) = (s, 0)
+    rw [cubicAxisParameter_clock ha hs]
+  have hnear : cubicFlowCylinder σ a (0, T) ∈ Metric.ball (c, (0 : Fin m → ℝ)) r := by
+    rw [hpoint, Metric.mem_ball, Prod.dist_eq, dist_self,
+      max_eq_left (dist_nonneg : 0 ≤ Dist.dist s c)]
+    simpa only [dist_comm] using hdist
+  have hcont : Continuous (fun z : Fin m → ℝ => cubicFlowCylinder σ a (z, T)) :=
+    (contDiff_cubicFlowCylinder σ a).continuous.comp (continuous_id.prodMk continuous_const)
+  obtain ⟨δ, hδ, hδsub⟩ :=
+    Metric.nhds_basis_closedBall.mem_iff.mp
+      (hcont.continuousAt (Metric.isOpen_ball.mem_nhds hnear))
+  refine ⟨T, δ, hδ, ?_⟩
+  intro z hz
+  exact hδsub (mem_closedBall_zero_iff.mpr hz)
+
+private theorem MorseCancel.exists_native_cubic_endpoint_flow_coordinates {m : ℕ} {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M] {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (σ : Fin m → ℝ)
+    {a : ℝ} (ha : 0 < a) (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hmodel : ∀ x ∈ Φ.target, V x = nativeCubicDescent σ Φ (-(a ^ 2)) x) (F : Flow ℝ M)
+    (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {c : ℝ} (hc : c ∈ Set.Icc (-a) a)
+    (hcΦ : (c, (0 : Fin m → ℝ)) ∈ Φ.source) :
+    ∃ (r δ T : ℝ),
+      0 < r ∧
+        0 < δ ∧
+          Metric.closedBall (c, (0 : Fin m → ℝ)) r ⊆ Φ.source ∧
+            (∀ z : Fin m → ℝ,
+                ‖z‖ ≤ δ → cubicFlowCylinder σ a (z, T) ∈ Metric.ball (c, (0 : Fin m → ℝ)) r) ∧
+              ∀ p ∈ Metric.closedBall (c, (0 : Fin m → ℝ)) r,
+                p.1 ∈ Set.Ioo (-a) a →
+                  ‖(cubicFlowCylinderInverse σ a p).1‖ ≤ δ →
+                    Φ p =
+                      F (cubicAxisClock a p.1 - T)
+                        (Φ (cubicFlowCylinder σ a ((cubicFlowCylinderInverse σ a p).1, T))) := by
+  obtain ⟨r, hr, hbox⟩ := Metric.nhds_basis_closedBall.mem_iff.mp (Φ.open_source.mem_nhds hcΦ)
+  obtain ⟨T, δ, hδ, hslice⟩ := exists_cubic_slice_in_axis_ball σ ha hc hr
+  refine ⟨r, δ, T, hr, hδ, hbox, hslice, ?_⟩
+  intro p hp hpa hpδ
+  let z := (cubicFlowCylinderInverse σ a p).1
+  have hinit := Metric.ball_subset_closedBall (hslice z hpδ)
+  have hpoint : cubicFlowCylinder σ a (z, cubicAxisClock a p.1) = p :=
+    cubicFlowCylinder_right_inv σ ha hpa
+  have hfinish :
+    cubicFlowCylinder σ a (z, cubicAxisClock a p.1) ∈ Metric.closedBall (c, (0 : Fin m → ℝ)) r :=
+    hpoint.symm ▸ hp
+  have hh := native_cubic_flow_between_box_points σ ha Φ hV hmodel F hF hbox z hinit hfinish
+  rw [hpoint] at hh
+  exact hh.symm
+
+private theorem
+    MorseCancel.exists_endpoint_slice_on_actual_orbit {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M]
+    {m : ℕ} {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (σ : Fin m → ℝ) {a : ℝ} (ha : 0 < a)
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hmodel : ∀ y ∈ Φ.target, V y = nativeCubicDescent σ Φ (-(a ^ 2)) y) (F : Flow ℝ M)
+    (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {c : ℝ} (hc : c ∈ Set.Icc (-a) a)
+    (hcΦ : (c, (0 : Fin m → ℝ)) ∈ Φ.source) (x : M) {l : Filter ℝ} [Filter.NeBot l]
+    (hlim : Filter.Tendsto (fun t => F t x) l (𝓝 (Φ (c, 0))))
+    (htail :
+      ∀ᶠ t in l, ∃ s ∈ Set.Ioo (-a) a, (s, (0 : Fin m → ℝ)) ∈ Φ.source ∧ Φ (s, 0) = F t x) :
+    ∃ (r δ T τ : ℝ),
+      0 < r ∧
+        0 < δ ∧
+          Metric.closedBall (c, (0 : Fin m → ℝ)) r ⊆ Φ.source ∧
+            (∀ z : Fin m → ℝ,
+                ‖z‖ ≤ δ → cubicFlowCylinder σ a (z, T) ∈ Metric.ball (c, (0 : Fin m → ℝ)) r) ∧
+              Φ (cubicFlowCylinder σ a (0, T)) = F τ x := by
+  obtain ⟨r, δ, T, hr, hδ, hbox, hslice, _⟩ :=
+    exists_native_cubic_endpoint_flow_coordinates σ ha Φ hV hmodel F hF hc hcΦ
+  have hcont := Φ.toOpenPartialHomeomorph.symm.continuousAt (Φ.map_source' hcΦ)
+  have hcoord : Filter.Tendsto (fun t => Φ.symm (F t x)) l (𝓝 (c, (0 : Fin m → ℝ))) := by
+    have hh : Filter.Tendsto (fun t => Φ.symm (F t x)) l (𝓝 (Φ.symm (Φ (c, 0)))) :=
+      hcont.tendsto.comp hlim
+    have hinv : Φ.symm (Φ (c, (0 : Fin m → ℝ))) = (c, 0) := Φ.left_inv' hcΦ
+    rwa [hinv] at hh
+  have hnear : ∀ᶠ t in l, Φ.symm (F t x) ∈ Metric.ball (c, (0 : Fin m → ℝ)) r :=
+    hcoord.eventually (Metric.ball_mem_nhds _ hr)
+  obtain ⟨t, htnear, s, hs, hsΦ, hsorbit⟩ := (hnear.and htail).exists
+  have hinv : Φ.symm (F t x) = (s, (0 : Fin m → ℝ)) := by
+    rw [← hsorbit]
+    exact Φ.left_inv' hsΦ
+  rw [hinv] at htnear
+  have hpoint : cubicFlowCylinder σ a (0, cubicAxisClock a s) = (s, (0 : Fin m → ℝ)) := by
+    rw [cubicFlowCylinder_axis]
+    change (cubicAxisParameter a (cubicAxisClock a s), 0) = (s, 0)
+    rw [cubicAxisParameter_clock ha hs]
+  have hstart :
+    cubicFlowCylinder σ a (0, cubicAxisClock a s) ∈ Metric.closedBall (c, (0 : Fin m → ℝ)) r :=
+    hpoint.symm ▸ Metric.ball_subset_closedBall htnear
+  have hfinish : cubicFlowCylinder σ a (0, T) ∈ Metric.closedBall (c, (0 : Fin m → ℝ)) r :=
+    Metric.ball_subset_closedBall (hslice 0 (by simpa using hδ.le))
+  have hflow := native_cubic_flow_between_box_points σ ha Φ hV hmodel F hF hbox 0 hstart hfinish
+  rw [hpoint, hsorbit, ← F.map_add] at hflow
+  exact ⟨r, δ, T, T - cubicAxisClock a s + t, hr, hδ, hbox, hslice, hflow.symm⟩
+
+private theorem Degree.SmoothODE.exists_smooth_fixedPoint_germ {P E : Type*} [NormedAddCommGroup P]
+    [NormedSpace ℝ P] [CompleteSpace P] [NormedAddCommGroup E] [NormedSpace ℝ E] [CompleteSpace E]
+    {F : P × E → E} {p : P} {x : E} (hF : ContDiffAt ℝ ∞ F (p, x)) (hfix : F (p, x) = x)
+    (hsmall : ‖(fderiv ℝ F (p, x)).comp (ContinuousLinearMap.inr ℝ P E)‖ < 1) :
+    ∃ g : P → E,
+      g p = x ∧
+        ContDiffAt ℝ ∞ g p ∧
+          (∀ᶠ q in 𝓝 p, F (q, g q) = g q) ∧ ∀ᶠ v in 𝓝 (p, x), F v = v.2 ↔ g v.1 = v.2 := by
+  let G : P × E → E := fun v => v.2 - F v
+  have hG : ContDiffAt ℝ ∞ G (p, x) := contDiffAt_snd.sub hF
+  have hdG : HasFDerivAt G (ContinuousLinearMap.snd ℝ P E - fderiv ℝ F (p, x)) (p, x) :=
+    (ContinuousLinearMap.snd ℝ P E).hasFDerivAt.sub (hF.differentiableAt (by simp)).hasFDerivAt
+  have hpartial :
+    (fderiv ℝ G (p, x)).comp (ContinuousLinearMap.inr ℝ P E) =
+      1 - (fderiv ℝ F (p, x)).comp (ContinuousLinearMap.inr ℝ P E) := by
+    rw [hdG.fderiv]
+    ext z
+    rfl
+  have hinv : ((fderiv ℝ G (p, x)).comp (ContinuousLinearMap.inr ℝ P E)).IsInvertible := by
+    rw [hpartial]
+    obtain ⟨u, hu⟩ := isUnit_one_sub_of_norm_lt_one hsmall
+    exact ⟨ContinuousLinearEquiv.ofUnit u, hu⟩
+  let g := hG.implicitFunction (by simp) hinv
+  have hgp : g p = x := hG.implicitFunction_apply_self (by simp) hinv
+  have hg : ContDiffAt ℝ ∞ g p := hG.contDiffAt_implicitFunction (by simp) hinv
+  refine ⟨g, hgp, hg, ?_, ?_⟩
+  · filter_upwards [hG.eventually_apply_implicitFunction (by simp) hinv] with q hq
+    change g q - F (q, g q) = x - F (p, x) at hq
+    rw [hfix, sub_self] at hq
+    exact (sub_eq_zero.mp hq).symm
+  · filter_upwards [hG.eventually_apply_eq_iff_implicitFunction (by simp) hinv] with v hv
+    change (v.2 - F v = x - F (p, x) ↔ g v.1 = v.2) at hv
+    rw [hfix, sub_self, sub_eq_zero] at hv
+    exact eq_comm.trans hv
+
+private theorem
+    Degree.SmoothODE.contDiffAt_of_continuous_fixedPoint {P E : Type*} [NormedAddCommGroup P]
+    [NormedSpace ℝ P] [CompleteSpace P] [NormedAddCommGroup E] [NormedSpace ℝ E] [CompleteSpace E]
+    {F : P × E → E} {p : P} {x : E} (hF : ContDiffAt ℝ ∞ F (p, x)) (hfix : F (p, x) = x)
+    (hsmall : ‖(fderiv ℝ F (p, x)).comp (ContinuousLinearMap.inr ℝ P E)‖ < 1) {g : P → E}
+    (hg : ContinuousAt g p) (hgp : g p = x) (heq : ∀ᶠ q in 𝓝 p, F (q, g q) = g q) :
+    ContDiffAt ℝ ∞ g p := by
+  obtain ⟨ψ, -, hψ, -, huniq⟩ := exists_smooth_fixedPoint_germ hF hfix hsmall
+  have hgraph : Filter.Tendsto (fun q => (q, g q)) (𝓝 p) (𝓝 (p, x)) := by
+    have hh : Filter.Tendsto (fun q => (q, g q)) (𝓝 p) (𝓝 (p, g p)) := continuousAt_id.prodMk hg
+    rwa [hgp] at hh
+  apply hψ.congr_of_eventuallyEq
+  filter_upwards [hgraph huniq, heq] with q hq hfixq
+  exact ((hq.mp hfixq).symm)
+
+private theorem Degree.SmoothODE.exists_smooth_fixedPoint_neighborhood {P E : Type*}
+    [NormedAddCommGroup P] [NormedSpace ℝ P] [CompleteSpace P] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [CompleteSpace E] {F : P × E → E} {p : P} {x : E} (hF : ContDiff ℝ ∞ F)
+    (hfix : F (p, x) = x)
+    (hsmall : ‖(fderiv ℝ F (p, x)).comp (ContinuousLinearMap.inr ℝ P E)‖ < 1) :
+    ∃ (U : Set P) (g : P → E),
+      IsOpen U ∧ p ∈ U ∧ g p = x ∧ ContDiffOn ℝ ∞ g U ∧ ∀ q ∈ U, F (q, g q) = g q := by
+  obtain ⟨g, hgp, hg, heq, -⟩ := exists_smooth_fixedPoint_germ hF.contDiffAt hfix hsmall
+  let A (v : P × E) := (fderiv ℝ F v).comp (ContinuousLinearMap.inr ℝ P E)
+  have hA : Continuous A := (hF.continuous_fderiv (by simp)).clm_comp continuous_const
+  have hgraph : ContinuousAt (fun q => (q, g q)) p := continuousAt_id.prodMk hg.continuousAt
+  have hn : ContinuousAt (fun q => ‖A (q, g q)‖) p := (hA.continuousAt.comp hgraph).norm
+  have hbase : ‖A (p, g p)‖ < 1 := by simpa only [hgp, A] using hsmall
+  have hsmall' : ∀ᶠ q in 𝓝 p, ‖A (q, g q)‖ < 1 := hn (eventually_lt_nhds hbase)
+  have hg₁ : ContDiffAt ℝ 1 g p := hg.of_le (by simp)
+  have hcont : ∀ᶠ q in 𝓝 p, ContinuousAt g q :=
+    (hg₁.eventually (by simp)).mono (fun _ h => h.continuousAt)
+  obtain ⟨U, hUsub, hU, hpU⟩ := mem_nhds_iff.mp ((heq.and hsmall').and hcont)
+  refine ⟨U, g, hU, hpU, hgp, ?_, fun q hq => (hUsub hq).1.1⟩
+  intro q hq
+  apply
+    (contDiffAt_of_continuous_fixedPoint hF.contDiffAt (hUsub hq).1.1 (hUsub hq).1.2 (hUsub hq).2
+        rfl ?_).contDiffWithinAt
+  filter_upwards [hU.mem_nhds hq] with r hr
+  exact (hUsub hr).1.1
+
+private def Degree.SmoothODE.pathOperator {K E F : Type*} [TopologicalSpace K] [CompactSpace K]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (A : C(K, E →L[ℝ] F)) : C(K, E) →L[ℝ] C(K, F) :=
+  LinearMap.mkContinuous
+    { toFun := fun u => ⟨fun t => A t (u t), A.continuous.clm_apply u.continuous⟩
+      map_add' := by intro u v; ext t; exact map_add (A t) (u t) (v t)
+      map_smul' := by intro r u; ext t; exact map_smul (A t) r (u t) } ‖A‖
+    (by
+      intro u
+      apply (ContinuousMap.norm_le _ (mul_nonneg (norm_nonneg A) (norm_nonneg u))).mpr
+      intro t
+      exact
+        ((A t).le_opNorm (u t)).trans
+          (mul_le_mul (A.norm_coe_le_norm t) (u.norm_coe_le_norm t) (norm_nonneg _)
+            (norm_nonneg _)))
+
+private theorem Degree.SmoothODE.norm_pathOperator_le {K E F : Type*} [TopologicalSpace K]
+    [CompactSpace K] [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (A : C(K, E →L[ℝ] F)) : ‖pathOperator A‖ ≤ ‖A‖ := by
+  apply ContinuousLinearMap.opNorm_le_bound _ (norm_nonneg A)
+  intro u
+  apply (ContinuousMap.norm_le _ (mul_nonneg (norm_nonneg A) (norm_nonneg u))).mpr
+  intro t
+  exact
+    ((A t).le_opNorm (u t)).trans
+      (mul_le_mul (A.norm_coe_le_norm t) (u.norm_coe_le_norm t) (norm_nonneg _) (norm_nonneg _))
+
+private def Degree.SmoothODE.pathOperatorCLM {K E F : Type*} [TopologicalSpace K] [CompactSpace K]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] :
+    C(K, E →L[ℝ] F) →L[ℝ] (C(K, E) →L[ℝ] C(K, F)) :=
+  LinearMap.mkContinuous
+    { toFun := pathOperator
+      map_add' := by intro A B; ext u t; rfl
+      map_smul' := by intro r A; ext u t; rfl } 1
+    (by
+      intro A
+      change ‖pathOperator A‖ ≤ 1 * ‖A‖
+      rw [one_mul]
+      exact norm_pathOperator_le A)
+
+private theorem
+    Degree.SmoothODE.exists_quadratic_remainder_bound {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F}
+    (hf : ContDiff ℝ ∞ f) (R : ℝ) :
+    ∃ C : ℝ,
+      0 < C ∧
+        ∀ x y : E, ‖x‖ ≤ R → ‖y‖ ≤ R → ‖f y - f x - fderiv ℝ f x (y - x)‖ ≤ C * ‖y - x‖ ^ 2 := by
+  have hdf : ContDiff ℝ ∞ (fderiv ℝ f) := hf.fderiv_right (by simp)
+  have hdcont : Continuous (fderiv ℝ (fderiv ℝ f)) := hdf.continuous_fderiv (by simp)
+  obtain ⟨C₀, hC₀⟩ :=
+    (ProperSpace.isCompact_closedBall (0 : E) R).exists_bound_of_continuousOn hdcont.continuousOn
+  let C := Max.max C₀ 0 + 1
+  have hC : 0 < C := by dsimp [C]; positivity
+  have hbound (z : E) (hz : z ∈ Metric.closedBall (0 : E) R) : ‖fderiv ℝ (fderiv ℝ f) z‖ ≤ C := by
+    exact (hC₀ z hz).trans (by dsimp [C]; linarith [le_max_left C₀ 0])
+  have hlip {x z : E} (hx : x ∈ Metric.closedBall (0 : E) R)
+    (hz : z ∈ Metric.closedBall (0 : E) R) : ‖fderiv ℝ f z - fderiv ℝ f x‖ ≤ C * ‖z - x‖ :=
+    (convex_closedBall (0 : E) R).norm_image_sub_le_of_norm_fderiv_le
+      (fun z _ => hdf.differentiable (by simp) z) hbound hx hz
+  refine ⟨C, hC, ?_⟩
+  intro x y hx hy
+  have hxR : x ∈ Metric.closedBall (0 : E) R := by
+    simpa only [Metric.mem_closedBall, dist_zero_right] using hx
+  have hyR : y ∈ Metric.closedBall (0 : E) R := by
+    simpa only [Metric.mem_closedBall, dist_zero_right] using hy
+  have hseg : segment ℝ x y ⊆ Metric.closedBall (0 : E) R :=
+    (convex_closedBall _ _).segment_subset hxR hyR
+  have hdist : segment ℝ x y ⊆ Metric.closedBall x ‖y - x‖ := by
+    apply (convex_closedBall x ‖y - x‖).segment_subset
+    · exact Metric.mem_closedBall_self (norm_nonneg _)
+    · simp only [Metric.mem_closedBall, dist_eq_norm, le_refl]
+  have hh :=
+    (convex_segment x y).norm_image_sub_le_of_norm_fderiv_le'
+      (fun z _ => hf.differentiable (by simp) z)
+      (fun z hz =>
+        (hlip hxR (hseg hz)).trans
+          (mul_le_mul_of_nonneg_left
+            (show ‖z - x‖ ≤ ‖y - x‖ from by
+              simpa only [Metric.mem_closedBall, dist_eq_norm] using hdist hz)
+            hC.le))
+      (left_mem_segment ℝ x y) (right_mem_segment ℝ x y)
+  simpa only [pow_two, mul_assoc] using hh
+
+private def
+    Degree.SmoothODE.pathDerivative {K E F : Type*} [TopologicalSpace K] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] (f : C(E, F)) (hf : ContDiff ℝ ∞ f)
+    (u : C(K, E)) : C(K, E →L[ℝ] F) :=
+  ⟨fun t => fderiv ℝ f (u t), (hf.continuous_fderiv (by simp)).comp u.continuous⟩
+
+private theorem
+    Degree.SmoothODE.hasFDerivAt_pathPostcomposition {K E F : Type*} [TopologicalSpace K]
+    [CompactSpace K] [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (f : C(E, F)) (hf : ContDiff ℝ ∞ f) (u : C(K, E)) :
+    HasFDerivAt (fun v : C(K, E) => f.comp v) (pathOperator (pathDerivative f hf u)) u := by
+  obtain ⟨C, hC, hrem⟩ := exists_quadratic_remainder_bound hf (‖u‖ + 1)
+  rw [hasFDerivAt_iff_isLittleO_nhds_zero, Asymptotics.isLittleO_iff]
+  intro ε hε
+  let δ := Min.min 1 (ε / C)
+  have hδ : 0 < δ := lt_min zero_lt_one (div_pos hε hC)
+  filter_upwards [Metric.ball_mem_nhds (0 : C(K, E)) hδ] with h hh
+  have hhnorm : ‖h‖ < δ := by simpa only [Metric.mem_ball, dist_zero_right] using hh
+  have hh1 : ‖h‖ < 1 := lt_of_lt_of_le hhnorm (min_le_left _ _)
+  have hhε : C * ‖h‖ ≤ ε := by
+    have hhdiv : ‖h‖ < ε / C := lt_of_lt_of_le hhnorm (min_le_right _ _)
+    have hh' := (lt_div_iff₀ hC).mp hhdiv
+    nlinarith
+  apply (ContinuousMap.norm_le _ (mul_nonneg hε.le (norm_nonneg h))).mpr
+  intro t
+  change ‖f (u t + h t) - f (u t) - fderiv ℝ f (u t) (h t)‖ ≤ ε * ‖h‖
+  have hxu : ‖u t‖ ≤ ‖u‖ + 1 := (u.norm_coe_le_norm t).trans (by linarith)
+  have hyu : ‖u t + h t‖ ≤ ‖u‖ + 1 :=
+    (norm_add_le _ _).trans (by linarith [u.norm_coe_le_norm t, h.norm_coe_le_norm t])
+  have hr := hrem (u t) (u t + h t) hxu hyu
+  simp only [add_sub_cancel_left] at hr
+  calc
+    _ ≤ C * ‖h t‖ ^ 2 := hr
+    _ ≤ C * ‖h‖ ^ 2 :=
+      (mul_le_mul_of_nonneg_left
+        ((sq_le_sq₀ (norm_nonneg _) (norm_nonneg _)).mpr (h.norm_coe_le_norm t)) hC.le)
+    _ ≤ ε * ‖h‖ := by
+      have hh' := mul_le_mul_of_nonneg_right hhε (norm_nonneg h)
+      simpa only [pow_two, mul_assoc] using hh'
+
+private theorem Degree.SmoothODE.fderiv_pathPostcomposition {K E F : Type*} [TopologicalSpace K]
+    [CompactSpace K] [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (f : C(E, F)) (hf : ContDiff ℝ ∞ f) (u : C(K, E)) :
+    fderiv ℝ (fun v : C(K, E) => f.comp v) u = pathOperator (pathDerivative f hf u) :=
+  (hasFDerivAt_pathPostcomposition f hf u).fderiv
+
+private theorem Degree.SmoothODE.contDiff_pathPostcomposition_nat {K : Type v} [TopologicalSpace K]
+    [CompactSpace K] {E : Type u} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    (n : ℕ) :
+    ∀ {F : Type u} [NormedAddCommGroup F] [NormedSpace ℝ F],
+      ∀ (f : C(E, F)), ContDiff ℝ ∞ f → ContDiff ℝ n (fun w : C(K, E) => f.comp w) := by
+  induction n with
+  | zero =>
+    intro F _ _ f _
+    exact contDiff_zero.mpr f.continuous_postcomp
+  | succ n ih =>
+    intro F _ _ f hf
+    rw [Nat.cast_add, Nat.cast_one, contDiff_succ_iff_fderiv]
+    refine ⟨fun w => (hasFDerivAt_pathPostcomposition f hf w).differentiableAt, by simp, ?_⟩
+    let df : C(E, E →L[ℝ] F) := ⟨fderiv ℝ f, hf.continuous_fderiv (by simp)⟩
+    have hdf : ContDiff ℝ ∞ df := hf.fderiv_right (by simp)
+    have hi := ih df hdf
+    have heq : fderiv ℝ (fun w : C(K, E) => f.comp w) = fun w => pathOperator (df.comp w) := by
+      funext w
+      rw [fderiv_pathPostcomposition f hf w]
+      rfl
+    rw [heq]
+    exact (pathOperatorCLM (K := K) (E := E) (F := F)).contDiff.comp hi
+
+private theorem Degree.SmoothODE.contDiff_pathPostcomposition {K : Type v} [TopologicalSpace K]
+    [CompactSpace K] {E : Type u} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    {F : Type u} [NormedAddCommGroup F] [NormedSpace ℝ F] (f : C(E, F)) (hf : ContDiff ℝ ∞ f) :
+    ContDiff ℝ ∞ (fun w : C(K, E) => f.comp w) :=
+  contDiff_infty.mpr (fun n => contDiff_pathPostcomposition_nat n f hf)
+
+private abbrev Degree.SmoothODE.PathTime :=
+  Set.Icc (-2 : ℝ) 2
+
+private def Degree.SmoothODE.pathClamp : ℝ → PathTime :=
+  Set.projIcc (-2) 2 (by norm_num)
+
+private theorem Degree.SmoothODE.continuous_pathClamp : Continuous pathClamp :=
+  continuous_projIcc
+
+private def
+    Degree.SmoothODE.pathExtend {E : Type*} [NormedAddCommGroup E] (u : C(PathTime, E)) : ℝ → E :=
+  u ∘ pathClamp
+
+private theorem Degree.SmoothODE.continuous_pathExtend {E : Type*} [NormedAddCommGroup E]
+    (u : C(PathTime, E)) : Continuous (pathExtend u) :=
+  u.continuous.comp continuous_pathClamp
+
+private def Degree.SmoothODE.pathPrimitive {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [CompleteSpace E] (u : C(PathTime, E)) : C(PathTime, E) :=
+  ⟨fun t => ∫ s in (0 : ℝ)..(t : ℝ), pathExtend u s,
+    (intervalIntegral.differentiable_integral_of_continuous
+          (continuous_pathExtend u)).continuous.comp
+      continuous_subtype_val⟩
+
+private theorem Degree.SmoothODE.norm_pathPrimitive_le {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [CompleteSpace E] (u : C(PathTime, E)) : ‖pathPrimitive u‖ ≤ 2 * ‖u‖ := by
+  apply (ContinuousMap.norm_le _ (mul_nonneg (by norm_num) (norm_nonneg u))).mpr
+  intro t
+  have hh :=
+    intervalIntegral.norm_integral_le_of_norm_le_const (a := (0 : ℝ)) (b := (t : ℝ)) (f :=
+      pathExtend u) (fun s _ => u.norm_coe_le_norm (pathClamp s))
+  have ht : |(t : ℝ)| ≤ 2 := abs_le.mpr t.property
+  simp only [sub_zero] at hh
+  change ‖∫ s in (0 : ℝ)..(t : ℝ), pathExtend u s‖ ≤ 2 * ‖u‖
+  simpa only [sub_zero, mul_comm] using hh.trans (mul_le_mul_of_nonneg_left ht (norm_nonneg u))
+
+private def Degree.SmoothODE.pathPrimitiveCLM {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [CompleteSpace E] : C(PathTime, E) →L[ℝ] C(PathTime, E) :=
+  LinearMap.mkContinuous
+    { toFun := pathPrimitive
+      map_add' := by
+        intro u v
+        ext t
+        change
+          (∫ s in (0 : ℝ)..(t : ℝ), pathExtend u s + pathExtend v s) =
+            (∫ s in (0 : ℝ)..(t : ℝ), pathExtend u s) + (∫ s in (0 : ℝ)..(t : ℝ), pathExtend v s)
+        exact
+          intervalIntegral.integral_add ((continuous_pathExtend u).intervalIntegrable _ _)
+            ((continuous_pathExtend v).intervalIntegrable _ _)
+      map_smul' := by
+        intro r u
+        ext t
+        change
+          (∫ s in (0 : ℝ)..(t : ℝ), r • pathExtend u s) =
+            r • (∫ s in (0 : ℝ)..(t : ℝ), pathExtend u s)
+        exact intervalIntegral.integral_smul r (pathExtend u) }
+    2 (fun u => norm_pathPrimitive_le u)
+
+private theorem Degree.SmoothODE.hasDerivAt_pathPrimitive {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [CompleteSpace E] (u : C(PathTime, E)) (t : ℝ) :
+    HasDerivAt (fun r : ℝ => ∫ s in (0 : ℝ)..r, pathExtend u s) (pathExtend u t) t :=
+  intervalIntegral.integral_hasDerivAt_right ((continuous_pathExtend u).intervalIntegrable _ _)
+    (continuous_pathExtend u).aestronglyMeasurable.stronglyMeasurableAtFilter
+    (continuous_pathExtend u).continuousAt
+
+private def Degree.SmoothODE.picardPathMap {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] (v : C(E, E)) (q : (E × ℝ) × C(PathTime, E)) : C(PathTime, E) :=
+  ContinuousMap.const PathTime q.1.1 + q.1.2 • pathPrimitiveCLM (v.comp q.2)
+
+private theorem Degree.SmoothODE.contDiff_picardPathMap {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] (v : C(E, E)) (hv : ContDiff ℝ ∞ v) :
+    ContDiff ℝ ∞ (picardPathMap v) := by
+  exact
+    ((ContinuousLinearMap.const ℝ PathTime : E →L[ℝ] C(PathTime, E)).contDiff.comp
+          contDiff_fst.fst).add
+      (contDiff_fst.snd.smul
+        ((pathPrimitiveCLM (E := E)).contDiff.comp
+          ((contDiff_pathPostcomposition v hv).comp contDiff_snd)))
+
+private theorem
+    Degree.SmoothODE.picardPathMap_zero {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] (v : C(E, E)) (x : E) (u : C(PathTime, E)) :
+    picardPathMap v ((x, 0), u) = ContinuousMap.const PathTime x := by
+  simp only [picardPathMap, zero_smul, add_zero]
+
+private theorem Degree.SmoothODE.picardPathMap_partial_zero {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] (v : C(E, E)) (hv : ContDiff ℝ ∞ v) (x : E)
+    (u : C(PathTime, E)) :
+    (fderiv ℝ (picardPathMap v) ((x, 0), u)).comp
+        (ContinuousLinearMap.inr ℝ (E × ℝ) C(PathTime, E)) =
+      0 := by
+  have hQ := contDiff_picardPathMap v hv
+  have hd :=
+    (hQ.differentiable (by simp) ((x, 0), u)).hasFDerivAt.comp u
+      ((hasFDerivAt_const (x, (0 : ℝ)) u).prodMk (hasFDerivAt_id u))
+  change
+    HasFDerivAt (fun w => picardPathMap v ((x, 0), w))
+      ((fderiv ℝ (picardPathMap v) ((x, 0), u)).comp
+        (ContinuousLinearMap.inr ℝ (E × ℝ) C(PathTime, E)))
+      u at hd
+  have he : (fun w => picardPathMap v ((x, 0), w)) = fun _ => ContinuousMap.const PathTime x :=
+    funext (picardPathMap_zero v x)
+  rw [he] at hd
+  exact hd.unique (hasFDerivAt_const (ContinuousMap.const PathTime x) u)
+
+private theorem Degree.SmoothODE.exists_smooth_picard_paths {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] (v : C(E, E)) (hv : ContDiff ℝ ∞ v) (x : E) :
+    ∃ (U : Set (E × ℝ)) (u : E × ℝ → C(PathTime, E)),
+      IsOpen U ∧
+        (x, 0) ∈ U ∧
+          u (x, 0) = ContinuousMap.const PathTime x ∧
+            ContDiffOn ℝ ∞ u U ∧
+              ∀ q ∈ U,
+                ∀ t : PathTime,
+                  u q t = q.1 + q.2 • (∫ s in (0 : ℝ)..(t : ℝ), v (u q (pathClamp s))) := by
+  have hsmall :
+    ‖(fderiv ℝ (picardPathMap v) ((x, 0), ContinuousMap.const PathTime x)).comp
+          (ContinuousLinearMap.inr ℝ (E × ℝ) C(PathTime, E))‖ <
+      1 := by
+    rw [picardPathMap_partial_zero v hv x, norm_zero]
+    exact zero_lt_one
+  obtain ⟨U, u, hU, hx, hu, hcont, hfix⟩ :=
+    exists_smooth_fixedPoint_neighborhood (contDiff_picardPathMap v hv)
+      (picardPathMap_zero v x (ContinuousMap.const PathTime x)) hsmall
+  refine ⟨U, u, hU, hx, hu, hcont, ?_⟩
+  intro q hq t
+  have hh := congrArg (fun w : C(PathTime, E) => w t) (hfix q hq)
+  exact hh.symm
+
+private def Degree.SmoothODE.picardCurve {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (v : C(E, E)) (p : E) (τ : ℝ) (u : C(PathTime, E)) (t : ℝ) : E :=
+  p + τ • (∫ s in (0 : ℝ)..t, v (u (pathClamp s)))
+
+private theorem
+    Degree.SmoothODE.picardCurve_zero {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (v : C(E, E)) (p : E) (τ : ℝ) (u : C(PathTime, E)) : picardCurve v p τ u 0 = p := by
+  simp only [picardCurve, intervalIntegral.integral_same, smul_zero, add_zero]
+
+private theorem Degree.SmoothODE.hasDerivAt_picardCurve {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] (v : C(E, E)) (p : E) (τ : ℝ) (u : C(PathTime, E))
+    (t : ℝ) : HasDerivAt (picardCurve v p τ u) (τ • v (u (pathClamp t))) t :=
+  ((hasDerivAt_pathPrimitive (v.comp u) t).const_smul τ).const_add p
+
+private theorem
+    Degree.SmoothODE.picardCurve_eq_path {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (v : C(E, E)) {p : E} {τ : ℝ} {u : C(PathTime, E)}
+    (heq : ∀ t : PathTime, u t = p + τ • (∫ s in (0 : ℝ)..(t : ℝ), v (u (pathClamp s)))) {t : ℝ}
+    (ht : t ∈ Set.Icc (-2 : ℝ) 2) : picardCurve v p τ u t = u (pathClamp t) := by
+  have hc : pathClamp t = ⟨t, ht⟩ := Set.projIcc_of_mem _ ht
+  rw [hc]
+  exact (heq ⟨t, ht⟩).symm
+
+private theorem
+    Degree.SmoothODE.hasDerivAt_picardCurve_of_fixedPoint {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] (v : C(E, E)) {p : E} {τ : ℝ} {u : C(PathTime, E)}
+    (heq : ∀ t : PathTime, u t = p + τ • (∫ s in (0 : ℝ)..(t : ℝ), v (u (pathClamp s)))) {t : ℝ}
+    (ht : t ∈ Set.Icc (-2 : ℝ) 2) :
+    HasDerivAt (picardCurve v p τ u) (τ • v (picardCurve v p τ u t)) t := by
+  rw [picardCurve_eq_path v heq ht]
+  exact hasDerivAt_picardCurve v p τ u t
+
+private theorem Degree.SmoothODE.exists_smooth_picard_endpoints {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] (v : C(E, E)) (hv : ContDiff ℝ ∞ v) (x : E) :
+    ∃ (U : Set (E × ℝ)) (u : E × ℝ → C(PathTime, E)) (g : E × ℝ → E),
+      IsOpen U ∧
+        (x, 0) ∈ U ∧
+          u (x, 0) = ContinuousMap.const PathTime x ∧
+            ContDiffOn ℝ ∞ u U ∧
+              ContDiffOn ℝ ∞ g U ∧
+                (∀ q, g q = u q ⟨1, by norm_num⟩) ∧
+                  ∀ q ∈ U,
+                    (picardCurve v q.1 q.2 (u q) 0 = q.1) ∧
+                      (picardCurve v q.1 q.2 (u q) 1 = g q) ∧
+                        (∀ t ∈ Set.Icc (-2 : ℝ) 2,
+                            picardCurve v q.1 q.2 (u q) t = u q (pathClamp t)) ∧
+                          ∀ t ∈ Set.Icc (-2 : ℝ) 2,
+                            HasDerivAt (picardCurve v q.1 q.2 (u q))
+                              (q.2 • v (picardCurve v q.1 q.2 (u q) t)) t := by
+  obtain ⟨U, u, hU, hx, hux, hu, heq⟩ := exists_smooth_picard_paths v hv x
+  let g (q : E × ℝ) := u q ⟨1, by norm_num⟩
+  let L : C(PathTime, E) →L[ℝ] E := ContinuousMap.evalCLM ℝ (⟨1, by norm_num⟩ : PathTime)
+  have hg : ContDiffOn ℝ ∞ g U := L.contDiff.comp_contDiffOn hu
+  refine ⟨U, u, g, hU, hx, hux, hu, hg, fun _ => rfl, ?_⟩
+  intro q hq
+  refine
+    ⟨picardCurve_zero v _ _ _, ?_, fun t ht => picardCurve_eq_path v (heq q hq) ht, fun t ht =>
+      hasDerivAt_picardCurve_of_fixedPoint v (heq q hq) ht⟩
+  have hh := picardCurve_eq_path v (heq q hq) (t := 1) (by norm_num)
+  have hc : pathClamp 1 = (⟨1, by norm_num⟩ : PathTime) := Set.projIcc_of_mem _ (by norm_num)
+  exact hh.trans (congrArg (u q) hc)
+
+private theorem Degree.SmoothODE.ordinary_curve_eqOn_of_contDiff {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {v : E → E} (hv : ContDiff ℝ 1 v) {γ η : ℝ → E} {a b t₀ : ℝ}
+    (ht₀ : t₀ ∈ Set.Ioo a b) (hγ : ∀ t ∈ Set.Ioo a b, HasDerivAt γ (v (γ t)) t)
+    (hη : ∀ t ∈ Set.Ioo a b, HasDerivAt η (v (η t)) t) (heq : γ t₀ = η t₀) :
+    Set.EqOn γ η (Set.Ioo a b) := by
+  let V : (x : E) → TangentSpace 𝓘(ℝ, E) x := fun x => v x
+  have hV :
+    ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) E)) :=
+    (tangentBundleModelSpaceDiffeomorph 𝓘(ℝ, E) 1).symm.contMDiff.comp
+      (contDiff_id.prodMk hv).contMDiff
+  have hγM : IsMIntegralCurveOn γ V (Set.Ioo a b) := by
+    intro t ht
+    exact (hγ t ht).hasFDerivAt.hasMFDerivAt.hasMFDerivWithinAt
+  have hηM : IsMIntegralCurveOn η V (Set.Ioo a b) := by
+    intro t ht
+    exact (hη t ht).hasFDerivAt.hasMFDerivAt.hasMFDerivWithinAt
+  exact isMIntegralCurveOn_Ioo_eqOn_of_contMDiff_boundaryless ht₀ hV hγM hηM heq
+
+private theorem
+    Degree.SmoothODE.picard_endpoint_eq_local_solution {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (v : C(E, E)) (hv : ContDiff ℝ ∞ v) {p : E} {τ ε : ℝ} (hτ : |τ| < ε / 2)
+    {u : C(PathTime, E)} {g : E} (hzero : picardCurve v p τ u 0 = p)
+    (hend : picardCurve v p τ u 1 = g)
+    (hcurve :
+      ∀ t ∈ Set.Icc (-2 : ℝ) 2,
+        HasDerivAt (picardCurve v p τ u) (τ • v (picardCurve v p τ u t)) t)
+    {α : ℝ → E} (hαzero : α 0 = p) (hα : ∀ t ∈ Set.Ioo (-ε) ε, HasDerivAt α (v (α t)) t) :
+    g = α τ := by
+  have hscaled : ContDiff ℝ 1 (fun y : E => τ • v y) := contDiff_const.smul (hv.of_le (by simp))
+  have hη (r : ℝ) (hr : r ∈ Set.Ioo (-2 : ℝ) 2) :
+    HasDerivAt (fun s : ℝ => α (s * τ)) (τ • v (α (r * τ))) r := by
+    have hrt : r * τ ∈ Set.Ioo (-ε) ε := by
+      apply abs_lt.mp
+      rw [abs_mul]
+      have hrabs : |r| ≤ 2 := (abs_lt.mpr hr).le
+      have hh := mul_le_mul_of_nonneg_right hrabs (abs_nonneg τ)
+      linarith
+    have hd := (hα (r * τ) hrt).scomp r ((hasDerivAt_id r).mul_const τ)
+    change HasDerivAt (fun s : ℝ => α (s * τ)) ((1 * τ) • v (α (r * τ))) r at hd
+    simpa only [one_mul] using hd
+  have heq :=
+    ordinary_curve_eqOn_of_contDiff hscaled (show (0 : ℝ) ∈ Set.Ioo (-2) 2 by norm_num)
+      (fun t ht => hcurve t ⟨ht.1.le, ht.2.le⟩) hη
+      (by simpa only [MulZeroClass.zero_mul] using hzero.trans hαzero.symm)
+  have hh := heq (x := 1) (by norm_num)
+  simpa only [hend, one_mul] using hh
+
+private theorem Degree.SmoothODE.contDiffAt_ordinary_localFlow {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] (v : C(E, E)) (hv : ContDiff ℝ ∞ v) {P : Set E}
+    (hP : IsOpen P) {x : E} (hx : x ∈ P) {ε : ℝ} (hε : 0 < ε) {H : E × ℝ → E}
+    (hinit : ∀ p ∈ P, H (p, 0) = p)
+    (hH : ∀ p ∈ P, ∀ t ∈ Set.Ioo (-ε) ε, HasDerivAt (fun s : ℝ => H (p, s)) (v (H (p, t))) t) :
+    ContDiffAt ℝ ∞ H (x, 0) := by
+  obtain ⟨U, u, g, hU, hxU, -, -, hg, -, hpaths⟩ := exists_smooth_picard_endpoints v hv x
+  apply (hg.contDiffAt (hU.mem_nhds hxU)).congr_of_eventuallyEq
+  have hsmall : Set.Ioo (-(ε / 2)) (ε / 2) ∈ 𝓝 (0 : ℝ) :=
+    Ioo_mem_nhds (neg_lt_zero.mpr (half_pos hε)) (half_pos hε)
+  filter_upwards [hU.mem_nhds hxU, prod_mem_nhds (hP.mem_nhds hx) hsmall] with q hq hqsmall
+  obtain ⟨hzero, hend, -, hcurve⟩ := hpaths q hq
+  exact
+    (picard_endpoint_eq_local_solution v hv (abs_lt.mpr hqsmall.2) hzero hend hcurve
+        (hinit q.1 hqsmall.1) (hH q.1 hqsmall.1)).symm
+
+private theorem Smale.DiskFraming.starConvex_thickening_zero {D : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] {K : Set D} (hK : StarConvex ℝ (0 : D) K) (δ : ℝ) :
+    StarConvex ℝ (0 : D) (Metric.thickening δ K) := by
+  rw [starConvex_zero_iff]
+  intro x hx a ha₀ ha₁
+  obtain ⟨z, hz, hxz⟩ := Metric.mem_thickening_iff.mp hx
+  apply Metric.mem_thickening_iff.mpr
+  refine ⟨a • z, hK.smul_mem hz ha₀ ha₁, ?_⟩
+  calc
+    Dist.dist (a • x) (a • z) = a * Dist.dist x z := by
+      simp only [dist_eq_norm, ← smul_sub, norm_smul, Real.norm_eq_abs, abs_of_nonneg ha₀]
+    _ ≤ Dist.dist x z := (mul_le_of_le_one_left dist_nonneg ha₁)
+    _ < δ := hxz
+
+private theorem
+    Smale.DiskFraming.exists_smooth_map_into_neighborhood {D : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [FiniteDimensional ℝ D] {K U : Set D} (hK : IsCompact K) (hz : (0 : D) ∈ K)
+    (hstar : StarConvex ℝ (0 : D) K) (hU : IsOpen U) (hKU : K ⊆ U) :
+    ∃ ρ : D → D,
+      ContDiff ℝ ∞ ρ ∧
+        Set.MapsTo ρ Set.univ U ∧ ∃ V : Set D, IsOpen V ∧ K ⊆ V ∧ V ⊆ U ∧ Set.EqOn ρ id V := by
+  obtain ⟨δ, hδ, hδU⟩ := hK.exists_thickening_subset_open hU hKU
+  let W := Metric.thickening δ K
+  have hW : IsOpen W := Metric.isOpen_thickening
+  have hKW : K ⊆ W := Metric.self_subset_thickening hδ K
+  have hstarW : StarConvex ℝ (0 : D) W := starConvex_thickening_zero hstar δ
+  obtain ⟨L, hL, hKL, hLW⟩ := exists_compact_between hK hW hKW
+  obtain ⟨β, hβ, hβrange, hβsupport, hβone⟩ :=
+    exists_contMDiff_support_eq_eq_one_iff (𝓘(ℝ, D)) (n := (⊤ : ℕ∞)) hW hL.isClosed hLW
+  let ρ : D → D := fun x => β x • x
+  refine
+    ⟨ρ, hβ.contDiff.smul contDiff_id, ?_, interior L, isOpen_interior, hKL, fun x hx =>
+      hδU (hLW (interior_subset hx)), ?_⟩
+  · intro x _
+    have hb := hβrange (Set.mem_range_self x)
+    by_cases hx : x ∈ W
+    · exact hδU (hstarW.smul_mem hx hb.1 hb.2)
+    · have hb0 : β x = 0 := by
+        by_contra hn
+        have hxs : x ∈ Function.support β := hn
+        rw [hβsupport] at hxs
+        exact hx hxs
+      change β x • x ∈ U
+      rw [hb0, zero_smul]
+      exact hKU hz
+  · intro x hx
+    change β x • x = x
+    rw [(hβone x).mp (interior_subset hx), one_smul]
+
+private theorem
+    Smale.exists_smooth_extension_near_starConvex {D G H N : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [FiniteDimensional ℝ D] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [TopologicalSpace N] [ChartedSpace H N]
+    {f : D → N} {K U : Set D} (hK : IsCompact K) (hz : (0 : D) ∈ K)
+    (hstar : StarConvex ℝ (0 : D) K) (hU : IsOpen U) (hKU : K ⊆ U)
+    (hf : ContMDiffOn 𝓘(ℝ, D) J ∞ f U) :
+    ∃ g : D → N,
+      ContMDiff 𝓘(ℝ, D) J ∞ g ∧ ∃ V : Set D, IsOpen V ∧ K ⊆ V ∧ V ⊆ U ∧ Set.EqOn g f V := by
+  obtain ⟨ρ, hρ, hρU, V, hV, hKV, hVU, hρid⟩ :=
+    DiskFraming.exists_smooth_map_into_neighborhood hK hz hstar hU hKU
+  refine ⟨f ∘ ρ, contMDiffOn_univ.mp (hf.comp hρ.contMDiff.contMDiffOn hρU), V, hV, hKV, hVU, ?_⟩
+  intro x hx
+  exact congrArg f (hρid hx)
+
+private theorem Smale.exists_smooth_extension_near_point {D G H N : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [FiniteDimensional ℝ D] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [TopologicalSpace N] [ChartedSpace H N]
+    {f : D → N} {U : Set D} {x₀ : D} (hf : ContMDiffOn 𝓘(ℝ, D) J ∞ f U) (hU : IsOpen U)
+    (hx₀ : x₀ ∈ U) : ∃ g : D → N, ContMDiff 𝓘(ℝ, D) J ∞ g ∧ g =ᶠ[𝓝 x₀] f := by
+  let shift : D → D := fun x => x + x₀
+  have hshift : ContDiff ℝ ∞ shift := contDiff_id.add contDiff_const
+  have hf' : ContMDiffOn 𝓘(ℝ, D) J ∞ (f ∘ shift) (shift ⁻¹' U) :=
+    hf.comp hshift.contMDiff.contMDiffOn (fun _ hx => hx)
+  have hzero : ({0} : Set D) ⊆ shift ⁻¹' U := by
+    intro x hx
+    have hx0 : x = 0 := hx
+    subst x
+    simpa only [shift, Set.mem_preimage, zero_add] using hx₀
+  obtain ⟨g, hg, V, hV, h0V, _, heq⟩ :=
+    exists_smooth_extension_near_starConvex isCompact_singleton (Set.mem_singleton 0)
+      (starConvex_singleton (0 : D)) (hU.preimage hshift.continuous) hzero hf'
+  let g' : D → N := fun x => g (x - x₀)
+  have hg' : ContMDiff 𝓘(ℝ, D) J ∞ g' := hg.comp (contDiff_id.sub contDiff_const).contMDiff
+  have htime : Filter.Tendsto (fun x : D => x - x₀) (𝓝 x₀) (𝓝 0) := by
+    have htime' : Filter.Tendsto (fun x : D => x - x₀) (𝓝 x₀) (𝓝 (x₀ - x₀)) :=
+      (continuous_id.sub continuous_const : Continuous (fun x : D => x - x₀)).continuousAt.tendsto
+    rwa [sub_self] at htime'
+  refine ⟨g', hg', ?_⟩
+  filter_upwards [htime (hV.mem_nhds (h0V (Set.mem_singleton 0)))] with x hx
+  change g (x - x₀) = f x
+  simpa only [Function.comp_apply, shift, sub_add_cancel] using heq hx
+
+private theorem Degree.SmoothODE.contDiffAt_local_field_flow {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {v : E → E} {O P : Set E} (hv : ContDiffOn ℝ ∞ v O)
+    (hO : IsOpen O) {x : E} (hxO : x ∈ O) (hP : IsOpen P) (hxP : x ∈ P) {ε : ℝ} (hε : 0 < ε)
+    {H : E × ℝ → E} (hc : ContinuousAt H (x, 0)) (hinit : ∀ p ∈ P, H (p, 0) = p)
+    (hH : ∀ p ∈ P, ∀ t ∈ Set.Ioo (-ε) ε, HasDerivAt (fun s : ℝ => H (p, s)) (v (H (p, t))) t) :
+    ContDiffAt ℝ ∞ H (x, 0) := by
+  obtain ⟨w, hwM, heq⟩ := Smale.exists_smooth_extension_near_point hv.contMDiffOn hO hxO
+  have hw : ContDiff ℝ ∞ w := contMDiff_iff_contDiff.mp hwM
+  have hevent : ∀ᶠ q in 𝓝 (x, (0 : ℝ)), w (H q) = v (H q) := by
+    have heq' : w =ᶠ[𝓝 (H (x, 0))] v := by rwa [hinit x hxP]
+    exact hc heq'
+  have hdom : P ×ˢ Set.Ioo (-ε) ε ∈ 𝓝 (x, (0 : ℝ)) :=
+    prod_mem_nhds (hP.mem_nhds hxP) (Ioo_mem_nhds (neg_lt_zero.mpr hε) hε)
+  have hdom' : ∀ᶠ q in 𝓝 (x, (0 : ℝ)), q ∈ P ×ˢ Set.Ioo (-ε) ε := hdom
+  obtain ⟨δ, hδ, hsub⟩ := Metric.eventually_nhds_iff.mp (hdom'.and hevent)
+  have hrect (p : E) (hp : p ∈ Metric.ball x δ) (t : ℝ) (ht : t ∈ Set.Ioo (-δ) δ) :
+    (p, t) ∈ P ×ˢ Set.Ioo (-ε) ε ∧ w (H (p, t)) = v (H (p, t)) := by
+    apply hsub
+    rw [Prod.dist_eq, max_lt_iff]
+    exact ⟨hp, by simpa only [dist_zero_right, Real.norm_eq_abs] using abs_lt.mpr ht⟩
+  let W : C(E, E) := ⟨w, hw.continuous⟩
+  apply contDiffAt_ordinary_localFlow W hw Metric.isOpen_ball (Metric.mem_ball_self hδ) hδ
+  · intro p hp
+    exact hinit p (hrect p hp 0 ⟨neg_lt_zero.mpr hδ, hδ⟩).1.1
+  · intro p hp t ht
+    have hh := hrect p hp t ht
+    have hd := hH p hh.1.1 t hh.1.2
+    change HasDerivAt (fun s => H (p, s)) (w (H (p, t))) t
+    rw [hh.2]
+    exact hd
+
+private def MorseCancel.coordinateField {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (e : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M E ∞) (z : E) : E :=
+  VectorField.mpullback 𝓘(ℝ, E) 𝓘(ℝ, E) e.symm V z
+
+private theorem
+    MorseCancel.coordinateField_chart {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (e : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M E ∞) {x : M} (hx : x ∈ e.source) :
+    coordinateField (V := V) e (e x) = mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) e x (V x) := by
+  let e' := e.toOpenPartialHomeomorph
+  have he : e'.MDifferentiable 𝓘(ℝ, E) 𝓘(ℝ, E) :=
+    ⟨e.contMDiffOn.mdifferentiableOn (by simp), e.symm.contMDiffOn.mdifferentiableOn (by simp)⟩
+  have h₂ := he.comp_symm_deriv (e'.map_source hx)
+  rw [e'.left_inv hx] at h₂
+  have hi := ContinuousLinearMap.inverse_eq (he.symm_comp_deriv hx) h₂
+  let A : E →L[ℝ] E := mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) e'.symm (e' x)
+  let B : E →L[ℝ] E := mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) e' x
+  have hAB : A.inverse = B := hi
+  have hvx : (show E from V (e'.symm (e' x))) = V x :=
+    congrArg (fun y : M => (show E from V y)) (e'.left_inv hx)
+  change A.inverse (V (e'.symm (e' x))) = B (V x)
+  rw [hAB]
+  exact congrArg B hvx
+
+private theorem MorseCancel.contDiffOn_coordinateField {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} [CompleteSpace E] [IsManifold 𝓘(ℝ, E) ∞ M]
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (e : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M E ∞) :
+    ContDiffOn ℝ ∞ (coordinateField (V := V) e) e.target := by
+  apply contMDiffOn_vectorSpace_iff_contDiffOn.mp
+  let e' := e.toOpenPartialHomeomorph
+  have he : e'.MDifferentiable 𝓘(ℝ, E) 𝓘(ℝ, E) :=
+    ⟨e.contMDiffOn.mdifferentiableOn (by simp), e.symm.contMDiffOn.mdifferentiableOn (by simp)⟩
+  intro z hz
+  have hinv : (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) e.symm z).IsInvertible := ⟨he.symm.mfderiv hz, rfl⟩
+  exact
+    ((hV (e.symm z)).mpullback_vectorField_preimage
+        ((e.symm.contMDiffOn z hz).contMDiffAt (e.open_target.mem_nhds hz)) hinv
+        (by simp)).contMDiffWithinAt
+
+private theorem MorseCancel.hasDerivAt_coordinate_integralCurve {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (e : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M E ∞)
+    {γ : ℝ → M} (hγ : IsMIntegralCurve γ V) {t : ℝ} (ht : γ t ∈ e.source) :
+    HasDerivAt (e ∘ γ) (coordinateField (V := V) e (e (γ t))) t := by
+  have he :=
+    ((e.contMDiffOn (γ t) ht).contMDiffAt (e.open_source.mem_nhds ht)).mdifferentiableAt (by simp)
+  have hd := he.hasMFDerivAt.comp t (hγ t)
+  rw [hasDerivAt_iff_hasFDerivAt]
+  apply hasMFDerivAt_iff_hasFDerivAt.mp
+  apply hd.congr_mfderiv
+  apply ContinuousLinearMap.ext
+  intro r
+  change
+    mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) e (γ t) ((NormedSpace.fromTangentSpace t r) • V (γ t)) =
+      (NormedSpace.fromTangentSpace t r) • coordinateField (V := V) e (e (γ t))
+  rw [map_smul, coordinateField_chart e ht]
+  rfl
+
+private theorem Degree.SmoothODE.contMDiffAt_native_flow_zero {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) (p : M) :
+    ContMDiffAt (𝓘(ℝ, E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) ∞ (fun q : M × ℝ => F q.2 q.1) (p, 0) := by
+  let e := NoExotic.modelChartPartialDiffeomorph (I := 𝓘(ℝ, E)) p
+  have hp : p ∈ e.source := mem_extChartAt_source p
+  have hz : e p ∈ e.target := e.map_source' hp
+  have he : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, E) ∞ e p :=
+    (e.contMDiffOn p hp).contMDiffAt (e.open_source.mem_nhds hp)
+  have hi : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, E) ∞ e.symm (e p) :=
+    (e.symm.contMDiffOn (e p) hz).contMDiffAt (e.open_target.mem_nhds hz)
+  let C (q : E × ℝ) : M := F q.2 (e.symm q.1)
+  let H (q : E × ℝ) : E := e (C q)
+  have hC0 : C (e p, 0) = p := by
+    change F 0 (e.symm (e p)) = p
+    rw [F.map_zero_apply]
+    exact e.left_inv' hp
+  have hFC : Continuous (fun q : ℝ × M => F q.1 q.2) := F.continuous continuous_fst continuous_snd
+  have hic : ContinuousAt (fun q : E × ℝ => e.symm q.1) (e p, 0) :=
+    hi.continuousAt.comp_of_eq
+      (show ContinuousAt (Prod.fst : E × ℝ → E) (e p, 0) from continuousAt_fst) rfl
+  have hC : ContinuousAt C (e p, 0) := hFC.continuousAt.comp (continuousAt_snd.prodMk hic)
+  have hHC : ContinuousAt H (e p, 0) := by
+    have heC : ContinuousAt e (C (e p, 0)) := by rw [hC0]; exact he.continuousAt
+    exact heC.comp hC
+  have htarget : ∀ᶠ q : E × ℝ in 𝓝 (e p, 0), q.1 ∈ e.target :=
+    continuousAt_fst (e.open_target.mem_nhds hz)
+  have hstay : ∀ᶠ q : E × ℝ in 𝓝 (e p, 0), C q ∈ e.source := by
+    apply hC
+    rw [hC0]
+    exact e.open_source.mem_nhds hp
+  obtain ⟨δ, hδ, hδsub⟩ := Metric.eventually_nhds_iff.mp (htarget.and hstay)
+  have hrect (z : E) (hz' : z ∈ Metric.ball (e p) δ) (t : ℝ) (ht : t ∈ Set.Ioo (-δ) δ) :
+    z ∈ e.target ∧ C (z, t) ∈ e.source := by
+    apply hδsub (y := (z, t))
+    rw [Prod.dist_eq, max_lt_iff]
+    exact ⟨hz', by simpa only [dist_zero_right, Real.norm_eq_abs] using abs_lt.mpr ht⟩
+  have hinit (z : E) (hz' : z ∈ Metric.ball (e p) δ) : H (z, 0) = z := by
+    change e (F 0 (e.symm z)) = z
+    rw [F.map_zero_apply]
+    exact e.right_inv' (hrect z hz' 0 ⟨neg_lt_zero.mpr hδ, hδ⟩).1
+  have hODE (z : E) (hz' : z ∈ Metric.ball (e p) δ) (t : ℝ) (ht : t ∈ Set.Ioo (-δ) δ) :
+    HasDerivAt (fun s => H (z, s)) (MorseCancel.coordinateField (V := V) e (H (z, t))) t :=
+    MorseCancel.hasDerivAt_coordinate_integralCurve e (hcurve (e.symm z)) (hrect z hz' t ht).2
+  have hH : ContDiffAt ℝ ∞ H (e p, 0) :=
+    contDiffAt_local_field_flow (MorseCancel.contDiffOn_coordinateField hV e) e.open_target hz
+      Metric.isOpen_ball (Metric.mem_ball_self hδ) hδ hHC hinit hODE
+  let A (q : M × ℝ) : E × ℝ := (e q.1, q.2)
+  have hA : ContMDiffAt (𝓘(ℝ, E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E × ℝ) ∞ A (p, 0) := by
+    apply (contMDiffAt_prod_module_iff A).mpr
+    have hefst :
+      ContMDiffAt (𝓘(ℝ, E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) ∞ (e ∘ (Prod.fst : M × ℝ → M)) (p, 0) :=
+      he.comp (p, 0) contMDiffAt_fst
+    exact ⟨hefst, contMDiffAt_snd⟩
+  have hHA : ContMDiffAt (𝓘(ℝ, E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) ∞ (H ∘ A) (p, 0) :=
+    hH.contMDiffAt.comp (p, 0) hA
+  have hHA0 : (H ∘ A) (p, 0) = e p := congrArg e hC0
+  have hi' : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, E) ∞ e.symm ((H ∘ A) (p, 0)) := by
+    rw [hHA0]
+    exact hi
+  apply (hi'.comp (p, 0) hHA).congr_of_eventuallyEq
+  have hstart : ∀ᶠ q : M × ℝ in 𝓝 (p, 0), q.1 ∈ e.source :=
+    continuousAt_fst (e.open_source.mem_nhds hp)
+  have hfinish : ∀ᶠ q : M × ℝ in 𝓝 (p, 0), F q.2 q.1 ∈ e.source := by
+    have hc : Continuous (fun q : M × ℝ => F q.2 q.1) :=
+      F.continuous continuous_snd continuous_fst
+    apply hc.continuousAt
+    simpa only [F.map_zero_apply] using e.open_source.mem_nhds hp
+  filter_upwards [hstart, hfinish] with q hq hFq
+  have heq : e.symm (e q.1) = q.1 := e.left_inv' hq
+  change F q.2 q.1 = e.symm (e (F q.2 (e.symm (e q.1))))
+  rw [heq]
+  exact (e.left_inv' hFq).symm
+
+private theorem
+    Degree.SmoothODE.exists_uniform_smalltime_contMDiff {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [CompactSpace M] (F : Flow ℝ M) (n : ℕ)
+    (hzero :
+      ∀ p : M, ContMDiffAt (𝓘(ℝ, E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) n (fun q : M × ℝ => F q.2 q.1) (p, 0)) :
+    ∃ ε : ℝ, 0 < ε ∧ ∀ t ∈ Set.Ioo (-ε) ε, ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, E) n (F t) := by
+  let U : Set (M × ℝ) :=
+    {q | ContMDiffAt (𝓘(ℝ, E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) n (fun r : M × ℝ => F r.2 r.1) q}
+  have hU : IsOpen U := by
+    apply isOpen_iff_mem_nhds.mpr
+    intro q hq
+    exact (contMDiffAt_iff_contMDiffAt_nhds (by simp)).mp hq
+  let T : Set ℝ := {t | ∀ p ∈ (Set.univ : Set M), (t, p) ∈ Prod.swap ⁻¹' U}
+  have hT : IsOpen T :=
+    Smale.MorsePerturbation.isOpen_forall_mem_compact isCompact_univ (hU.preimage continuous_swap)
+  have h0 : (0 : ℝ) ∈ T := fun p _ => hzero p
+  obtain ⟨ε, hε, hεsub⟩ := Metric.mem_nhds_iff.mp (hT.mem_nhds h0)
+  refine ⟨ε, hε, ?_⟩
+  intro t ht p
+  have htT : t ∈ T :=
+    hεsub (by simpa only [Metric.mem_ball, dist_zero_right, Real.norm_eq_abs] using abs_lt.mpr ht)
+  have hj : ContMDiffAt (𝓘(ℝ, E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) n (fun q : M × ℝ => F q.2 q.1) (p, t) :=
+    htT p (Set.mem_univ p)
+  have hι : ContMDiffAt 𝓘(ℝ, E) (𝓘(ℝ, E).prod 𝓘(ℝ, ℝ)) n (fun x : M => (x, t)) p :=
+    contMDiffAt_id.prodMk contMDiffAt_const
+  have hh := hj.comp p hι
+  exact hh
+
+private theorem Degree.SmoothODE.contMDiff_flow_time_of_zero {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [CompactSpace M] (F : Flow ℝ M) (n : ℕ)
+    (hzero :
+      ∀ p : M, ContMDiffAt (𝓘(ℝ, E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) n (fun q : M × ℝ => F q.2 q.1) (p, 0))
+    (t : ℝ) : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, E) n (F t) := by
+  obtain ⟨ε, hε, hsmall⟩ := exists_uniform_smalltime_contMDiff F n hzero
+  let S : Set ℝ := {s | ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, E) n (F s)}
+  have hstep {s u : ℝ} (hs : s ∈ S) (hu : Dist.dist u s < ε) : u ∈ S := by
+    have hus : u - s ∈ Set.Ioo (-ε) ε := abs_lt.mp (by simpa only [Real.dist_eq] using hu)
+    have hc := (hsmall (u - s) hus).comp hs
+    have heq : (fun x => F (u - s) (F s x)) = F u := by
+      funext x
+      rw [← F.map_add, sub_add_cancel]
+    change ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, E) n (F u)
+    rw [← heq]
+    exact hc
+  have hS : IsOpen S :=
+    isOpen_iff_mem_nhds.mpr fun s hs =>
+      Filter.mem_of_superset (Metric.ball_mem_nhds s hε) (fun u hu => hstep hs hu)
+  have hSc : IsOpen Sᶜ :=
+    isOpen_iff_mem_nhds.mpr fun s hs =>
+      Filter.mem_of_superset (Metric.ball_mem_nhds s hε)
+        (fun u hu h =>
+          hs
+            (hstep h
+              (by
+                change Dist.dist u s < ε at hu
+                rwa [dist_comm])))
+  have h0 : (0 : ℝ) ∈ S := by
+    have heq : F 0 = id := funext F.map_zero_apply
+    change ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, E) n (F 0)
+    rw [heq]
+    exact contMDiff_id
+  have hSuniv : S = Set.univ :=
+    (show IsClopen S from ⟨isOpen_compl_iff.mp hSc, hS⟩).eq_univ ⟨0, h0⟩
+  have ht : t ∈ S := by rw [hSuniv]; exact Set.mem_univ t
+  exact ht
+
+private theorem Degree.SmoothODE.contMDiff_joint_flow_of_zero {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [CompactSpace M] (F : Flow ℝ M) (n : ℕ)
+    (hzero :
+      ∀ p : M, ContMDiffAt (𝓘(ℝ, E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) n (fun q : M × ℝ => F q.2 q.1) (p, 0)) :
+    ContMDiff (𝓘(ℝ, E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) n (fun q : M × ℝ => F q.2 q.1) := by
+  intro q
+  let A (r : M × ℝ) := (F q.2 r.1, r.2 - q.2)
+  have hA : ContMDiffAt (𝓘(ℝ, E).prod 𝓘(ℝ, ℝ)) (𝓘(ℝ, E).prod 𝓘(ℝ, ℝ)) n A q :=
+    ((contMDiff_flow_time_of_zero F n hzero q.2).contMDiffAt.comp q contMDiffAt_fst).prodMk
+      (contMDiffAt_snd.sub contMDiffAt_const)
+  have hG : ContMDiffAt (𝓘(ℝ, E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) n (fun r : M × ℝ => F r.2 r.1) (A q) := by
+    simpa only [A, sub_self] using hzero (F q.2 q.1)
+  have hc := hG.comp q hA
+  have heq : ((fun r : M × ℝ => F r.2 r.1) ∘ A) = (fun r : M × ℝ => F r.2 r.1) := by
+    funext r
+    change F (r.2 - q.2) (F q.2 r.1) = F r.2 r.1
+    rw [← F.map_add, sub_add_cancel]
+  exact heq ▸ hc
+
+private theorem Degree.SmoothODE.contMDiff_native_flow {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [CompactSpace M] [FiniteDimensional ℝ E] {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) :
+    ContMDiff (𝓘(ℝ, E).prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) ∞ (fun q : M × ℝ => F q.2 q.1) :=
+  contMDiff_infty.mpr
+    (fun n =>
+      contMDiff_joint_flow_of_zero F n
+        (fun p => contMDiffAt_infty.mp (contMDiffAt_native_flow_zero hV F hcurve p) n))
+
+private def Degree.SmoothODE.nativeFlowTimeDiffeomorph {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] (F : Flow ℝ M)
+    (hs : ∀ t, ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, E) ∞ (F t)) (t : ℝ) : M ≃ₘ⟮𝓘(ℝ, E), 𝓘(ℝ, E)⟯ M
+    where
+  toFun := F t
+  invFun := F (-t)
+  left_inv x := by rw [← F.map_add, neg_add_cancel, F.map_zero_apply]
+  right_inv x := by rw [← F.map_add, add_neg_cancel, F.map_zero_apply]
+  contMDiff_toFun := hs t
+  contMDiff_invFun := hs (-t)
+
+private theorem Degree.SmoothODE.mfderiv_flow_time_field {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] (F : Flow ℝ M)
+    (hs : ∀ t, ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, E) ∞ (F t)) {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) (t : ℝ) (x : M) :
+    mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) (F t) x (V x) = V (F t x) := by
+  have hd := ((hs t).mdifferentiableAt (by simp) (x := F 0 x)).hasMFDerivAt.comp 0 (hF x 0)
+  change
+    HasMFDerivAt 𝓘(ℝ, ℝ) 𝓘(ℝ, E) (F t ∘ fun s => F s x) 0
+      ((mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) (F t) (F 0 x)).comp ((1 : ℝ →L[ℝ] ℝ).smulRight (V (F 0 x)))) at hd
+  rw [F.map_zero_apply] at hd
+  have hcomm : (F t ∘ fun s => F s x) = (fun s => F s (F t x)) := by
+    funext s
+    change F t (F s x) = F s (F t x)
+    rw [← F.map_add, ← F.map_add, add_comm]
+  rw [hcomm] at hd
+  have hd' := hF (F t x) 0
+  change
+    HasMFDerivAt 𝓘(ℝ, ℝ) 𝓘(ℝ, E) (fun s => F s (F t x)) 0
+      ((1 : ℝ →L[ℝ] ℝ).smulRight (V (F 0 (F t x)))) at hd'
+  rw [F.map_zero_apply] at hd'
+  have hh := hd.mfderiv.symm.trans hd'.mfderiv
+  have hv := congrArg (fun A : ℝ →L[ℝ] TangentSpace 𝓘(ℝ, E) (F t x) => A 1) hh
+  change mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) (F t) x ((1 : ℝ) • V x) = (1 : ℝ) • V (F t x) at hv
+  simpa only [one_smul] using hv
+
+private def Degree.SmoothODE.nativeFlowTimeDiffeomorph_of_field {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) (t : ℝ) :
+    M ≃ₘ⟮𝓘(ℝ, E), 𝓘(ℝ, E)⟯ M :=
+  nativeFlowTimeDiffeomorph F
+    (fun _ => (contMDiff_native_flow hV F hF).comp (contMDiff_id.prodMk contMDiff_const)) t
+
+private theorem Degree.SmoothODE.mpullback_flow_time {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] (F : Flow ℝ M)
+    (hs : ∀ t, ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, E) ∞ (F t)) {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) (t : ℝ) (x : M) :
+    VectorField.mpullback 𝓘(ℝ, E) 𝓘(ℝ, E) (F t) V x = V x := by
+  let D := nativeFlowTimeDiffeomorph F hs t
+  let e := D.toPartialDiffeomorph
+  have hdiff : e.toOpenPartialHomeomorph.MDifferentiable 𝓘(ℝ, E) 𝓘(ℝ, E) :=
+    ⟨e.mdifferentiableOn (by simp), e.symm.mdifferentiableOn (by simp)⟩
+  have hi : (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) (F t) x).IsInvertible :=
+    ⟨hdiff.mfderiv (Set.mem_univ x), rfl⟩
+  rw [VectorField.mpullback_apply, ← mfderiv_flow_time_field F hs hF t x]
+  exact hi.inverse_apply_self (V x)
+
+private theorem Degree.SmoothODE.partialChartField_flow_shift {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {B : Type*} [NormedAddCommGroup B]
+    [NormedSpace ℝ B] (Φ : PartialDiffeomorph 𝓘(ℝ, B) 𝓘(ℝ, E) B M ∞) (F : Flow ℝ M)
+    (hs : ∀ t, ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, E) ∞ (F t)) {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) (W : B → B)
+    (hmodel : ∀ x ∈ Φ.target, V x = Smale.FlowConstruction.partialChartField Φ.symm W x) (t : ℝ)
+    {x : M} (hx : x ∈ (Φ.trans (nativeFlowTimeDiffeomorph F hs t).toPartialDiffeomorph).target) :
+    V x =
+      Smale.FlowConstruction.partialChartField
+        (Φ.trans (nativeFlowTimeDiffeomorph F hs t).toPartialDiffeomorph).symm W x := by
+  have hxΦ : F (-t) x ∈ Φ.target := hx.2
+  have hdiff : Φ.symm.toOpenPartialHomeomorph.MDifferentiable 𝓘(ℝ, E) 𝓘(ℝ, B) :=
+    ⟨Φ.symm.mdifferentiableOn (by simp), Φ.mdifferentiableOn (by simp)⟩
+  have hinv : (mfderivWithin 𝓘(ℝ, E) 𝓘(ℝ, B) Φ.symm Set.univ (F (-t) x)).IsInvertible := by
+    rw [mfderivWithin_univ]
+    exact ⟨hdiff.mfderiv hxΦ, rfl⟩
+  have hh :=
+    VectorField.mpullbackWithin_comp_of_left (I := 𝓘(ℝ, E)) (I' := 𝓘(ℝ, E)) (I'' := 𝓘(ℝ, B)) (f :=
+      F (-t)) (g := (Φ.symm : M → B)) (V := fun y => (NormedSpace.fromTangentSpace y).symm (W y))
+      (s := Set.univ) (t := Set.univ)
+      ((hs (-t)).mdifferentiableAt (by simp)).mdifferentiableWithinAt (Set.mapsTo_univ _ _)
+      (uniqueMDiffWithinAt_univ 𝓘(ℝ, E)) hinv
+  simp only [VectorField.mpullbackWithin_univ] at hh
+  change
+    V x =
+      VectorField.mpullback 𝓘(ℝ, E) 𝓘(ℝ, B) (Φ.symm ∘ F (-t))
+        (fun y => (NormedSpace.fromTangentSpace y).symm (W y)) x
+  rw [hh, VectorField.mpullback_apply]
+  change
+    V x =
+      (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) (F (-t)) x).inverse
+        (Smale.FlowConstruction.partialChartField Φ.symm W (F (-t) x))
+  rw [← hmodel _ hxΦ]
+  exact (mpullback_flow_time F hs hF (-t) x).symm
+
+private theorem Degree.SmoothODE.flow_shifted_chart_source {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {B : Type*} [NormedAddCommGroup B]
+    [NormedSpace ℝ B] (Φ : PartialDiffeomorph 𝓘(ℝ, B) 𝓘(ℝ, E) B M ∞) (F : Flow ℝ M)
+    (hs : ∀ t, ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, E) ∞ (F t)) (t : ℝ) :
+    (Φ.trans (nativeFlowTimeDiffeomorph F hs t).toPartialDiffeomorph).source = Φ.source := by
+  ext p
+  change p ∈ Φ.source ∧ Φ p ∈ Set.univ ↔ p ∈ Φ.source
+  simp
+
+private theorem
+    MorseCancel.exists_clock_normalized_cubic_endpoint {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {m : ℕ}
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (σ : Fin m → ℝ) {a : ℝ} (ha : 0 < a)
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hmodel : ∀ y ∈ Φ.target, V y = nativeCubicDescent σ Φ (-(a ^ 2)) y) (F : Flow ℝ M)
+    (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {c : ℝ} (hc : c ∈ Set.Icc (-a) a)
+    (hcrit : c ^ 2 = a ^ 2) (hcΦ : (c, (0 : Fin m → ℝ)) ∈ Φ.source) (x : M) {l : Filter ℝ}
+    [Filter.NeBot l] (hlim : Filter.Tendsto (fun t => F t x) l (𝓝 (Φ (c, 0))))
+    (htail :
+      ∀ᶠ t in l, ∃ s ∈ Set.Ioo (-a) a, (s, (0 : Fin m → ℝ)) ∈ Φ.source ∧ Φ (s, 0) = F t x) :
+    ∃ (Ψ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞) (r δ T : ℝ),
+      Ψ.source = Φ.source ∧
+        Ψ (c, 0) = Φ (c, 0) ∧
+          0 < r ∧
+            0 < δ ∧
+              Metric.closedBall (c, (0 : Fin m → ℝ)) r ⊆ Ψ.source ∧
+                (∀ z : Fin m → ℝ,
+                    ‖z‖ ≤ δ → cubicFlowCylinder σ a (z, T) ∈ Metric.ball (c, (0 : Fin m → ℝ)) r) ∧
+                  (∀ y ∈ Ψ.target, V y = nativeCubicDescent σ Ψ (-(a ^ 2)) y) ∧
+                    (∀ t : ℝ,
+                        cubicFlowCylinder σ a (0, t) ∈ Metric.closedBall (c, (0 : Fin m → ℝ)) r →
+                          Ψ (cubicFlowCylinder σ a (0, t)) = F t x) ∧
+                      ∃ d : ℝ, ∀ z : Model m, Ψ z = F d (Φ z) := by
+  have hV₁ := hV.of_le (by simp : (1 : WithTop ℕ∞) ≤ (↑(⊤ : ℕ∞) : ℕ∞ω))
+  obtain ⟨r, δ, T, τ, hr, hδ, hbox, hslice, hcenter⟩ :=
+    exists_endpoint_slice_on_actual_orbit σ ha Φ hV₁ hmodel F hF hc hcΦ x hlim htail
+  have hs : ∀ t, ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, E) ∞ (F t) := fun t =>
+    (Degree.SmoothODE.contMDiff_native_flow hV F hF).comp (contMDiff_id.prodMk contMDiff_const)
+  let Ψ := Φ.trans (Degree.SmoothODE.nativeFlowTimeDiffeomorph F hs (T - τ)).toPartialDiffeomorph
+  have hsource : Ψ.source = Φ.source := Degree.SmoothODE.flow_shifted_chart_source Φ F hs (T - τ)
+  have hΨmodel : ∀ y ∈ Ψ.target, V y = nativeCubicDescent σ Ψ (-(a ^ 2)) y := by
+    intro y hy
+    exact
+      Degree.SmoothODE.partialChartField_flow_shift Φ F hs hF (cubicDescent σ (-(a ^ 2))) hmodel
+        (T - τ) hy
+  have hzero : V (Φ (c, 0)) = 0 := by
+    rw [hmodel _ (Φ.map_source' hcΦ)]
+    have hinv : Φ.symm (Φ (c, (0 : Fin m → ℝ))) = (c, 0) := Φ.left_inv' hcΦ
+    have hw : cubicDescent σ (-(a ^ 2)) (Φ.symm (Φ (c, 0))) = 0 := by
+      rw [hinv]
+      ext i <;> simp [cubicDescent, hcrit]
+    unfold nativeCubicDescent Smale.FlowConstruction.partialChartField
+    rw [VectorField.mpullback_apply, hw, map_zero, map_zero]
+  have hvalue : Ψ (c, 0) = Φ (c, 0) :=
+    Smale.FlowConstruction.flow_fixed_of_zero hV₁ F hF hzero (T - τ)
+  have hΨbox : Metric.closedBall (c, (0 : Fin m → ℝ)) r ⊆ Ψ.source := hsource.symm ▸ hbox
+  have hbase : Ψ (cubicFlowCylinder σ a (0, T)) = F T x := by
+    change F (T - τ) (Φ (cubicFlowCylinder σ a (0, T))) = F T x
+    rw [hcenter, ← F.map_add, sub_add_cancel]
+  refine ⟨Ψ, r, δ, T, hsource, hvalue, hr, hδ, hΨbox, hslice, hΨmodel, ?_, T - τ, fun _ => rfl⟩
+  intro t ht
+  have hstart : cubicFlowCylinder σ a (0, T) ∈ Metric.closedBall (c, (0 : Fin m → ℝ)) r :=
+    Metric.ball_subset_closedBall (hslice 0 (by simpa using hδ.le))
+  have hh := native_cubic_flow_between_box_points σ ha Ψ hV₁ hΨmodel F hF hΨbox 0 hstart ht
+  rw [hbase, ← F.map_add, sub_add_cancel] at hh
+  exact hh.symm
+
+public
+theorem MorseCancel.flow_time_atTop_limit_iff {M : Type*} [TopologicalSpace M] (F : Flow ℝ M)
+    (d : ℝ) (x p : M) :
+    Filter.Tendsto (fun t => F t (F d x)) Filter.atTop (𝓝 p) ↔
+      Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p) := by
+  have hshift {x p : M} (d : ℝ) (h : Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p)) :
+    Filter.Tendsto (fun t => F t (F d x)) Filter.atTop (𝓝 p) := by
+    simpa only [Function.comp_def, id_eq, F.map_add] using
+      h.comp (Filter.tendsto_atTop_add_const_right Filter.atTop d Filter.tendsto_id)
+  constructor
+  · intro h
+    simpa only [← F.map_add, neg_add_cancel, F.map_zero_apply] using hshift (-d) h
+  · exact hshift d
+
+private theorem
+    MorseCancel.flow_time_atBot_limit_iff {M : Type*} [TopologicalSpace M] (F : Flow ℝ M)
+    (d : ℝ) (x p : M) :
+    Filter.Tendsto (fun t => F t (F d x)) Filter.atBot (𝓝 p) ↔
+      Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p) := by
+  have hshift {x p : M} (d : ℝ) (h : Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p)) :
+    Filter.Tendsto (fun t => F t (F d x)) Filter.atBot (𝓝 p) := by
+    simpa only [Function.comp_def, id_eq, F.map_add] using
+      h.comp (Filter.tendsto_atBot_add_const_right Filter.atBot d Filter.tendsto_id)
+  constructor
+  · intro h
+    simpa only [← F.map_add, neg_add_cancel, F.map_zero_apply] using hshift (-d) h
+  · exact hshift d
+
+private theorem MorseCancel.exists_basin_preserving_endpoint_clock {M : Type*} [TopologicalSpace M]
+    {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {m : ℕ}
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (σ : Fin m → ℝ) {a : ℝ} (ha : 0 < a)
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hmodel : ∀ y ∈ Φ.target, V y = nativeCubicDescent σ Φ (-(a ^ 2)) y) (F : Flow ℝ M)
+    (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {c : ℝ} (hc : c ∈ Set.Icc (-a) a)
+    (hcrit : c ^ 2 = a ^ 2) (hcΦ : (c, (0 : Fin m → ℝ)) ∈ Φ.source) (x : M) {l : Filter ℝ}
+    [Filter.NeBot l] (hlim : Filter.Tendsto (fun t => F t x) l (𝓝 (Φ (c, 0))))
+    (htail :
+      ∀ᶠ t in l, ∃ s ∈ Set.Ioo (-a) a, (s, (0 : Fin m → ℝ)) ∈ Φ.source ∧ Φ (s, 0) = F t x) :
+    ∃ (Ψ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞) (r δ T : ℝ),
+      Ψ.source = Φ.source ∧
+        Ψ (c, 0) = Φ (c, 0) ∧
+          0 < r ∧
+            0 < δ ∧
+              Metric.closedBall (c, (0 : Fin m → ℝ)) r ⊆ Ψ.source ∧
+                (∀ z : Fin m → ℝ,
+                    ‖z‖ ≤ δ → cubicFlowCylinder σ a (z, T) ∈ Metric.ball (c, (0 : Fin m → ℝ)) r) ∧
+                  (∀ y ∈ Ψ.target, V y = nativeCubicDescent σ Ψ (-(a ^ 2)) y) ∧
+                    (∀ t : ℝ,
+                        cubicFlowCylinder σ a (0, t) ∈ Metric.closedBall (c, (0 : Fin m → ℝ)) r →
+                          Ψ (cubicFlowCylinder σ a (0, t)) = F t x) ∧
+                      ∀ z : Model m,
+                        ∀ p : M,
+                          (Filter.Tendsto (fun t => F t (Ψ z)) Filter.atTop (𝓝 p) ↔
+                              Filter.Tendsto (fun t => F t (Φ z)) Filter.atTop (𝓝 p)) ∧
+                            (Filter.Tendsto (fun t => F t (Ψ z)) Filter.atBot (𝓝 p) ↔
+                              Filter.Tendsto (fun t => F t (Φ z)) Filter.atBot (𝓝 p)) := by
+  obtain ⟨Ψ, r, δ, T, hsource, hcenter, hr, hδ, hbox, hslice, hfield, haxis, d, hmap⟩ :=
+    exists_clock_normalized_cubic_endpoint σ ha Φ hV hmodel F hF hc hcrit hcΦ x hlim htail
+  refine ⟨Ψ, r, δ, T, hsource, hcenter, hr, hδ, hbox, hslice, hfield, haxis, ?_⟩
+  intro z p
+  rw [hmap]
+  exact ⟨flow_time_atTop_limit_iff F d (Φ z) p, flow_time_atBot_limit_iff F d (Φ z) p⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    AdaptedWindows.flow_belt_passage {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f) {s : ℝ} (hs : 0 < s)
+    (hs₁ : s ≤ 1) (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) :
+    S.flow (Degree.BeltPassage.time s)
+        ((S.data q).chart.splitChart.symm
+          (Degree.BeltPassage.upper (S.data q).radius s u.val v.val)) =
+      (S.data q).chart.splitChart.symm
+        (Degree.BeltPassage.lower (S.data q).radius s u.val v.val) := by
+  let d := S.data q
+  let z := Degree.BeltPassage.upper d.radius s u.val v.val
+  have htime := Degree.BeltPassage.time_nonneg hs
+  have hstay (t : ℝ) (ht : t ∈ Set.uIcc 0 (Degree.BeltPassage.time s)) :
+    Smale.MorseHandle.descentFlow t z ∈
+      Metric.closedBall (0 : d.chart.NegativeCoordinates) (2 * d.radius) ×ˢ
+        Metric.closedBall (0 : d.chart.PositiveCoordinates) (2 * d.radius) := by
+    rw [Set.uIcc_of_le htime] at ht
+    exact
+      Degree.BeltPassage.descentFlow_mem_block d.radius_pos hs hs₁
+        (mem_sphere_zero_iff_norm.mp u.property) (mem_sphere_zero_iff_norm.mp v.property) ht
+  have hz : z ∈ d.chart.splitChart.target := by
+    have hh := d.block (hstay 0 Set.left_mem_uIcc)
+    simpa only [Smale.MorseHandle.descentFlow.map_zero_apply] using hh
+  have hcoords : d.chart.splitChart (d.chart.splitChart.symm z) = z :=
+    d.chart.splitChart.right_inv' hz
+  have hflow :=
+    d.chart.flow_eq_descentModel_of_mem_uIcc (S.smooth.of_le (by simp)) S.flow S.integral (x :=
+      d.chart.splitChart.symm z) (d.chart.splitChart.map_target' hz) (t :=
+      Degree.BeltPassage.time s) (fun t ht => by rw [hcoords]; exact d.block (hstay t ht))
+      (fun t ht => by rw [hcoords]; exact S.model_germ q _ (hstay t ht))
+  change
+    S.flow (Degree.BeltPassage.time s) (d.chart.splitChart.symm z) =
+      d.chart.splitChart.symm
+        (Smale.MorseHandle.descentFlow (Degree.BeltPassage.time s)
+          (d.chart.splitChart (d.chart.splitChart.symm z))) at hflow
+  rw [hcoords, Degree.BeltPassage.descentFlow_time d.radius hs u.val v.val] at hflow
+  exact hflow
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem AdaptedWindows.belt_passage_forward_limit_iff {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} (S : AdaptedWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f) {s : ℝ}
+    (hs : 0 < s) (hs₁ : s ≤ 1) (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) (p : M) :
+    Filter.Tendsto
+        (fun t =>
+          S.flow t
+            ((S.data q).chart.splitChart.symm
+              (Degree.BeltPassage.upper (S.data q).radius s u.val v.val)))
+        Filter.atTop (𝓝 p) ↔
+      Filter.Tendsto
+        (fun t =>
+          S.flow t
+            ((S.data q).chart.splitChart.symm
+              (Degree.BeltPassage.lower (S.data q).radius s u.val v.val)))
+        Filter.atTop (𝓝 p) := by
+  rw [← S.flow_belt_passage q hs hs₁ u v]
+  exact (MorseCancel.flow_time_atTop_limit_iff S.flow (Degree.BeltPassage.time s) _ p).symm
+
+private theorem
+    MorseCancel.compact_partial_chart_image_nowhereDense {A X : Type*} [TopologicalSpace A]
+    [TopologicalSpace X] [T2Space X] (e : OpenPartialHomeomorph X A) {K : Set A}
+    (hK : IsCompact K) (hKt : K ⊆ e.target) (hKi : interior K = ∅) :
+    IsNowhereDense (e.symm '' K) := by
+  have hclosed : IsClosed (e.symm '' K) :=
+    (hK.image_of_continuousOn (e.symm.continuousOn.mono hKt)).isClosed
+  apply hclosed.isNowhereDense_iff.mpr
+  have hsource : e.symm '' K ⊆ e.source := by
+    rintro x ⟨z, hz, rfl⟩
+    exact e.map_target (hKt hz)
+  have hopen : IsOpen (e '' interior (e.symm '' K)) :=
+    e.isOpen_image_of_subset_source isOpen_interior (interior_subset.trans hsource)
+  have hsub : e '' interior (e.symm '' K) ⊆ K := by
+    rintro y ⟨x, hx, rfl⟩
+    obtain ⟨z, hz, hzx⟩ := interior_subset hx
+    rw [← hzx, e.right_inv (hKt hz)]
+    exact hz
+  have hinto : e '' interior (e.symm '' K) ⊆ interior K := hopen.subset_interior_iff.mpr hsub
+  apply Set.eq_empty_iff_forall_notMem.mpr
+  intro x hx
+  have hh := hinto (Set.mem_image_of_mem e hx)
+  exact (Set.eq_empty_iff_forall_notMem.mp hKi) _ hh
+
+private theorem MorseCancel.interior_zero_product_empty {A B : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [Nontrivial A] [TopologicalSpace B] (s : Set B) :
+    interior (({0} : Set A) ×ˢ s) = ∅ := by
+  rw [interior_prod_eq, interior_singleton, Set.empty_prod]
+
+private theorem
+    MorseCancel.native_positive_plane_piece_nowhereDense {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (hindex : 0 < Module.finrank ℝ c.NegativeCoordinates) {r : ℝ}
+    (hblock :
+      ({0} : Set c.NegativeCoordinates) ×ˢ Metric.closedBall (0 : c.PositiveCoordinates) r ⊆
+        c.splitChart.target) :
+    IsNowhereDense
+      (c.splitChart.symm ''
+        (({0} : Set c.NegativeCoordinates) ×ˢ Metric.closedBall (0 : c.PositiveCoordinates) r)) :=
+  by
+  let : Nontrivial c.NegativeCoordinates := Module.nontrivial_of_finrank_pos hindex
+  exact
+    compact_partial_chart_image_nowhereDense c.splitChart.toOpenPartialHomeomorph
+      (isCompact_singleton.prod (ProperSpace.isCompact_closedBall _ _)) hblock
+      (interior_zero_product_empty _)
+
+private theorem MorseCancel.exists_backward_morse_quadratic_level_exit {N P : Type*}
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {r : ℝ}
+    (hr : 0 < r) {z : N × P} (hzn : ‖z.1‖ < r) (hzp : ‖z.2‖ < r) (hne : z.2 ≠ 0) :
+    ∃ s : ℝ,
+      s < 0 ∧
+        Smale.MorseHandle.quadratic (Smale.MorseHandle.descentFlow s z) = r ^ 2 ∧
+          (∀ t ∈ Set.Icc s (0 : ℝ),
+              Smale.MorseHandle.descentFlow t z ∈
+                Metric.closedBall (0 : N) (2 * r) ×ˢ Metric.closedBall (0 : P) (2 * r)) ∧
+            ‖(Smale.MorseHandle.descentFlow s z).1‖ ≤ ‖z.1‖ := by
+  let R := 3 * r / 2
+  have hrR : r < R := by dsimp [R]; linarith
+  have hR : 0 < R := hr.trans hrR
+  let T := -Real.log (R / ‖z.2‖)
+  have hn : 0 < ‖z.2‖ := norm_pos_iff.mpr hne
+  have hratio : 1 < R / ‖z.2‖ := (one_lt_div hn).mpr (hzp.trans hrR)
+  have hT : T < 0 := neg_neg_of_pos (Real.log_pos hratio)
+  have hexp : Real.exp (-T) = R / ‖z.2‖ := by
+    dsimp [T]
+    rw [neg_neg, Real.exp_log (div_pos hR hn)]
+  have hnorm : ‖(Smale.MorseHandle.descentFlow T z).2‖ = R := by
+    rw [Smale.MorseHandle.norm_descentFlow_snd, hexp]
+    exact div_mul_cancel₀ R hn.ne'
+  have hsmall (t : ℝ) (ht : t ≤ 0) : ‖(Smale.MorseHandle.descentFlow t z).1‖ ≤ ‖z.1‖ := by
+    rw [Smale.MorseHandle.norm_descentFlow_fst]
+    exact mul_le_of_le_one_left (norm_nonneg _) (Real.exp_le_one_iff.mpr ht)
+  have hstay (t : ℝ) (ht : t ∈ Set.Icc T (0 : ℝ)) :
+    Smale.MorseHandle.descentFlow t z ∈
+      Metric.closedBall (0 : N) (2 * r) ×ˢ Metric.closedBall (0 : P) (2 * r) := by
+    constructor
+    · exact mem_closedBall_zero_iff.mpr ((hsmall t ht.2).trans (by linarith))
+    · rw [mem_closedBall_zero_iff, Smale.MorseHandle.norm_descentFlow_snd]
+      calc
+        Real.exp (-t) * ‖z.2‖ ≤ Real.exp (-T) * ‖z.2‖ :=
+          mul_le_mul_of_nonneg_right (Real.exp_le_exp.mpr (neg_le_neg ht.1)) (norm_nonneg _)
+        _ = R := by rw [hexp, div_mul_cancel₀ R hn.ne']
+        _ ≤ 2 * r := by dsimp [R]; linarith
+  have hheightT : r ^ 2 < Smale.MorseHandle.quadratic (Smale.MorseHandle.descentFlow T z) := by
+    change
+      r ^ 2 <
+        -‖(Smale.MorseHandle.descentFlow T z).1‖ ^ 2 + ‖(Smale.MorseHandle.descentFlow T z).2‖ ^ 2
+    rw [hnorm]
+    have hs := (sq_lt_sq₀ (norm_nonneg _) hr.le).mpr ((hsmall T hT.le).trans_lt hzn)
+    dsimp [R]
+    nlinarith [sq_pos_of_pos hr]
+  have hheight0 : Smale.MorseHandle.quadratic (Smale.MorseHandle.descentFlow 0 z) < r ^ 2 := by
+    rw [Flow.map_zero_apply]
+    change -‖z.1‖ ^ 2 + ‖z.2‖ ^ 2 < r ^ 2
+    have hs := (sq_lt_sq₀ (norm_nonneg _) hr.le).mpr hzp
+    nlinarith [sq_nonneg ‖z.1‖]
+  have hc :
+    Continuous (fun t : ℝ => Smale.MorseHandle.quadratic (Smale.MorseHandle.descentFlow t z)) := by
+    change
+      Continuous
+        (fun t : ℝ =>
+          -‖(Smale.MorseHandle.descentFlow t z).1‖ ^ 2 +
+            ‖(Smale.MorseHandle.descentFlow t z).2‖ ^ 2)
+    exact
+      (((Smale.MorseHandle.descentFlow.continuous continuous_id continuous_const).fst.norm.pow
+              2).neg).add
+        ((Smale.MorseHandle.descentFlow.continuous continuous_id continuous_const).snd.norm.pow 2)
+  obtain ⟨s, hs, hlevel⟩ :=
+    intermediate_value_Icc' hT.le hc.continuousOn
+      (show
+        r ^ 2 ∈
+          Set.Icc (Smale.MorseHandle.quadratic (Smale.MorseHandle.descentFlow 0 z))
+            (Smale.MorseHandle.quadratic (Smale.MorseHandle.descentFlow T z))
+        from ⟨hheight0.le, hheightT.le⟩)
+  have hs0 : s < 0 :=
+    lt_of_le_of_ne hs.2
+      (by
+        intro heq
+        rw [heq] at hlevel
+        linarith)
+  exact ⟨s, hs0, hlevel, fun t ht => hstay t ⟨hs.1.trans ht.1, ht.2⟩, hsmall s hs0.le⟩
+
+private theorem
+    MorseCancel.morse_descentFlow_swap {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (t : ℝ) (z : N × P) :
+    Smale.MorseHandle.descentFlow t z.swap = (Smale.MorseHandle.descentFlow (-t) z).swap := by
+  simp only [Smale.MorseHandle.descentFlow, neg_neg, Prod.swap]
+
+private theorem
+    MorseCancel.morse_quadratic_swap {N P : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] (z : N × P) :
+    Smale.MorseHandle.quadratic z.swap = -Smale.MorseHandle.quadratic z := by
+  change -‖z.2‖ ^ 2 + ‖z.1‖ ^ 2 = -(-‖z.1‖ ^ 2 + ‖z.2‖ ^ 2)
+  ring
+
+private theorem
+    MorseCancel.exists_forward_morse_quadratic_level_exit {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {r : ℝ} (hr : 0 < r) {z : N × P}
+    (hzn : ‖z.1‖ < r) (hzp : ‖z.2‖ < r) (hne : z.1 ≠ 0) :
+    ∃ s : ℝ,
+      0 < s ∧
+        Smale.MorseHandle.quadratic (Smale.MorseHandle.descentFlow s z) = -(r ^ 2) ∧
+          (∀ t ∈ Set.Icc (0 : ℝ) s,
+              Smale.MorseHandle.descentFlow t z ∈
+                Metric.closedBall (0 : N) (2 * r) ×ˢ Metric.closedBall (0 : P) (2 * r)) ∧
+            ‖(Smale.MorseHandle.descentFlow s z).2‖ ≤ ‖z.2‖ := by
+  obtain ⟨s, hs, hlevel, hstay, hsmall⟩ :=
+    exists_backward_morse_quadratic_level_exit (z := z.swap) hr hzp hzn hne
+  rw [morse_descentFlow_swap, morse_quadratic_swap] at hlevel
+  rw [morse_descentFlow_swap] at hsmall
+  refine ⟨-s, neg_pos.mpr hs, by linarith, ?_, hsmall⟩
+  intro t ht
+  have hh :=
+    hstay (-t) (show -t ∈ Set.Icc s (0 : ℝ) from ⟨by linarith [ht.2], neg_nonpos.mpr ht.1⟩)
+  rw [morse_descentFlow_swap, neg_neg] at hh
+  exact ⟨hh.2, hh.1⟩
+
+private theorem MorseCancel.exists_uniform_small_of_zero_set {X : Type*} [TopologicalSpace X]
+    [CompactSpace X] {g : X → ℝ} (hg : Continuous g) (hnonneg : ∀ x, 0 ≤ g x) {U : Set X}
+    (hU : IsOpen U) (hzero : ∀ x, g x = 0 → x ∈ U) : ∃ δ : ℝ, 0 < δ ∧ ∀ x, g x < δ → x ∈ U := by
+  have hpos : ∀ x ∈ Uᶜ, 0 < g x := by
+    intro x hx
+    exact lt_of_le_of_ne (hnonneg x) (fun hh => hx (hzero x hh.symm))
+  obtain ⟨δ, hδ, hbound⟩ := hU.isClosed_compl.isCompact.exists_forall_le' hg.continuousOn hpos
+  refine ⟨δ, hδ, fun x hx => ?_⟩
+  by_contra hnot
+  exact (not_lt_of_ge (hbound x hnot)) hx
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.exists_upper_morse_section_neighborhood {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) {r : ℝ} (hr : 0 < r)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) ⊆
+        c.splitChart.target)
+    {U : Set M} (hU : IsOpen U)
+    (hcore :
+      ∀ v : Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates,
+        (c.beltCoreMap r hr hblock v : M) ∈ U) :
+    ∃ δ : ℝ,
+      0 < δ ∧
+        ∀
+          z ∈
+            Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+              Metric.closedBall (0 : c.PositiveCoordinates) (2 * r),
+          Smale.MorseHandle.quadratic z = r ^ 2 → ‖z.1‖ < δ → c.splitChart.symm z ∈ U := by
+  let K : Set (c.NegativeCoordinates × c.PositiveCoordinates) :=
+    (Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+        Metric.closedBall (0 : c.PositiveCoordinates) (2 * r)) ∩
+      {z | Smale.MorseHandle.quadratic z = r ^ 2}
+  have hK : IsCompact K :=
+    ((ProperSpace.isCompact_closedBall _ _).prod
+          (ProperSpace.isCompact_closedBall _ _)).inter_right
+      (isClosed_eq Smale.MorseHandle.continuous_quadratic continuous_const)
+  let : CompactSpace K := isCompact_iff_compactSpace.mp hK
+  let ψ : K → M := fun z => c.splitChart.symm z
+  have hψ : Continuous ψ := by
+    exact
+      (c.splitChart.symm.contMDiffOn_toFun.continuousOn.mono
+          (fun z hz => hblock hz.1)).domRestrict
+  have hg : Continuous (fun z : K => ‖(z : c.NegativeCoordinates × c.PositiveCoordinates).1‖) :=
+    continuous_subtype_val.fst.norm
+  have hzero :
+    ∀ z : K, ‖(z : c.NegativeCoordinates × c.PositiveCoordinates).1‖ = 0 → z ∈ ψ ⁻¹' U := by
+    intro z hz
+    have hn : (z : c.NegativeCoordinates × c.PositiveCoordinates).1 = 0 := norm_eq_zero.mp hz
+    have hq := z.property.2
+    change
+      -‖(z : c.NegativeCoordinates × c.PositiveCoordinates).1‖ ^ 2 +
+          ‖(z : c.NegativeCoordinates × c.PositiveCoordinates).2‖ ^ 2 =
+        r ^ 2 at hq
+    rw [hn, norm_zero] at hq
+    have hp : ‖(z : c.NegativeCoordinates × c.PositiveCoordinates).2‖ = r := by
+      nlinarith [norm_nonneg (z : c.NegativeCoordinates × c.PositiveCoordinates).2]
+    let v : Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates :=
+      ⟨r⁻¹ • (z : c.NegativeCoordinates × c.PositiveCoordinates).2,
+        by
+        rw [mem_sphere_zero_iff_norm, norm_smul, Real.norm_eq_abs, abs_of_pos (inv_pos.mpr hr),
+          hp]
+        exact inv_mul_cancel₀ hr.ne'⟩
+    have hv :
+      r • (v : c.PositiveCoordinates) = (z : c.NegativeCoordinates × c.PositiveCoordinates).2 := by
+      change r • (r⁻¹ • _) = _
+      rw [smul_smul, mul_inv_cancel₀ hr.ne', one_smul]
+    have hh := hcore v
+    rw [c.beltCoreMap_coe, hv] at hh
+    change c.splitChart.symm (z : c.NegativeCoordinates × c.PositiveCoordinates) ∈ U
+    convert! hh using 1
+    exact congrArg c.splitChart.symm (Prod.ext hn rfl)
+  obtain ⟨δ, hδ, hsmall⟩ :=
+    exists_uniform_small_of_zero_set hg (fun _ => norm_nonneg _) (hU.preimage hψ) hzero
+  exact ⟨δ, hδ, fun z hz hlevel hs => hsmall ⟨z, hz, hlevel⟩ hs⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.exists_lower_morse_section_neighborhood {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) {r : ℝ} (hr : 0 < r)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) ⊆
+        c.splitChart.target)
+    {U : Set M} (hU : IsOpen U)
+    (hcore :
+      ∀ v : Smale.PuncturedHandle.UnitSphere c.NegativeCoordinates,
+        (c.attachingCoreMap r hr hblock v : M) ∈ U) :
+    ∃ δ : ℝ,
+      0 < δ ∧
+        ∀
+          z ∈
+            Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+              Metric.closedBall (0 : c.PositiveCoordinates) (2 * r),
+          Smale.MorseHandle.quadratic z = -(r ^ 2) → ‖z.2‖ < δ → c.splitChart.symm z ∈ U := by
+  let K : Set (c.NegativeCoordinates × c.PositiveCoordinates) :=
+    (Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+        Metric.closedBall (0 : c.PositiveCoordinates) (2 * r)) ∩
+      {z | Smale.MorseHandle.quadratic z = -(r ^ 2)}
+  have hK : IsCompact K :=
+    ((ProperSpace.isCompact_closedBall _ _).prod
+          (ProperSpace.isCompact_closedBall _ _)).inter_right
+      (isClosed_eq Smale.MorseHandle.continuous_quadratic continuous_const)
+  let : CompactSpace K := isCompact_iff_compactSpace.mp hK
+  let ψ : K → M := fun z => c.splitChart.symm z
+  have hψ : Continuous ψ := by
+    exact
+      (c.splitChart.symm.contMDiffOn_toFun.continuousOn.mono
+          (fun z hz => hblock hz.1)).domRestrict
+  have hg : Continuous (fun z : K => ‖(z : c.NegativeCoordinates × c.PositiveCoordinates).2‖) :=
+    continuous_subtype_val.snd.norm
+  have hzero :
+    ∀ z : K, ‖(z : c.NegativeCoordinates × c.PositiveCoordinates).2‖ = 0 → z ∈ ψ ⁻¹' U := by
+    intro z hz
+    have hp : (z : c.NegativeCoordinates × c.PositiveCoordinates).2 = 0 := norm_eq_zero.mp hz
+    have hq := z.property.2
+    change
+      -‖(z : c.NegativeCoordinates × c.PositiveCoordinates).1‖ ^ 2 +
+          ‖(z : c.NegativeCoordinates × c.PositiveCoordinates).2‖ ^ 2 =
+        -(r ^ 2) at hq
+    rw [hp, norm_zero] at hq
+    have hn : ‖(z : c.NegativeCoordinates × c.PositiveCoordinates).1‖ = r := by
+      nlinarith [norm_nonneg (z : c.NegativeCoordinates × c.PositiveCoordinates).1]
+    let v : Smale.PuncturedHandle.UnitSphere c.NegativeCoordinates :=
+      ⟨r⁻¹ • (z : c.NegativeCoordinates × c.PositiveCoordinates).1,
+        by
+        rw [mem_sphere_zero_iff_norm, norm_smul, Real.norm_eq_abs, abs_of_pos (inv_pos.mpr hr),
+          hn]
+        exact inv_mul_cancel₀ hr.ne'⟩
+    have hv :
+      r • (v : c.NegativeCoordinates) = (z : c.NegativeCoordinates × c.PositiveCoordinates).1 := by
+      change r • (r⁻¹ • _) = _
+      rw [smul_smul, mul_inv_cancel₀ hr.ne', one_smul]
+    have hh := hcore v
+    rw [c.attachingCoreMap_coe, hv] at hh
+    change c.splitChart.symm (z : c.NegativeCoordinates × c.PositiveCoordinates) ∈ U
+    convert! hh using 1
+    exact congrArg c.splitChart.symm (Prod.ext rfl hp)
+  obtain ⟨δ, hδ, hsmall⟩ :=
+    exists_uniform_small_of_zero_set hg (fun _ => norm_nonneg _) (hU.preimage hψ) hzero
+  exact ⟨δ, hδ, fun z hz hlevel hs => hsmall ⟨z, hz, hlevel⟩ hs⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.exists_native_backward_morse_level_exit {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {r : ℝ} (hr : 0 < r)
+    (hbox :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) ⊆
+        c.splitChart.target)
+    (heq :
+      ∀
+        z ∈
+          Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+            Metric.closedBall (0 : c.PositiveCoordinates) (2 * r),
+        ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y)
+    {x : M} (hx : x ∈ c.splitChart.source) (hn : ‖(c.splitChart x).1‖ < r)
+    (hp : ‖(c.splitChart x).2‖ < r) (hne : (c.splitChart x).2 ≠ 0) :
+    ∃ T : ℝ,
+      T < 0 ∧
+        f (F T x) = f p + r ^ 2 ∧
+          F T x ∈ c.splitChart.source ∧
+            ‖(c.splitChart (F T x)).1‖ ≤ ‖(c.splitChart x).1‖ ∧
+              c.splitChart (F T x) ∈
+                Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+                  Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) := by
+  obtain ⟨T, hT, hlevel, hstay, hsmall⟩ := exists_backward_morse_quadratic_level_exit hr hn hp hne
+  have hdomain (s : ℝ) (hs : s ∈ Set.uIcc (0 : ℝ) T) :=
+    hstay s (by simpa only [Set.uIcc_of_ge hT.le] using hs)
+  have hflow :=
+    c.flow_eq_descentModel_of_mem_uIcc hV F hF hx (fun s hs => hbox (hdomain s hs))
+      (fun s hs => heq _ (hdomain s hs))
+  have htarget := hbox (hstay T ⟨le_rfl, hT.le⟩)
+  have hsource : F T x ∈ c.splitChart.source := by
+    rw [hflow]
+    exact c.splitChart.map_target' htarget
+  have hcoord : c.splitChart (F T x) = Smale.MorseHandle.descentFlow T (c.splitChart x) := by
+    rw [hflow]
+    exact c.splitChart.right_inv' htarget
+  refine ⟨T, hT, ?_, hsource, ?_, ?_⟩
+  · rw [hflow, c.splitChart_inverse_equation htarget]
+    change
+      -‖(Smale.MorseHandle.descentFlow T (c.splitChart x)).1‖ ^ 2 +
+          ‖(Smale.MorseHandle.descentFlow T (c.splitChart x)).2‖ ^ 2 =
+        r ^ 2 at hlevel
+    linarith
+  · simpa only [hcoord] using hsmall
+  · rw [hcoord]
+    exact hstay T ⟨le_rfl, hT.le⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.exists_native_forward_morse_level_exit {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {r : ℝ} (hr : 0 < r)
+    (hbox :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) ⊆
+        c.splitChart.target)
+    (heq :
+      ∀
+        z ∈
+          Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+            Metric.closedBall (0 : c.PositiveCoordinates) (2 * r),
+        ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y)
+    {x : M} (hx : x ∈ c.splitChart.source) (hn : ‖(c.splitChart x).1‖ < r)
+    (hp : ‖(c.splitChart x).2‖ < r) (hne : (c.splitChart x).1 ≠ 0) :
+    ∃ T : ℝ,
+      0 < T ∧
+        f (F T x) = f p - r ^ 2 ∧
+          F T x ∈ c.splitChart.source ∧
+            ‖(c.splitChart (F T x)).2‖ ≤ ‖(c.splitChart x).2‖ ∧
+              c.splitChart (F T x) ∈
+                Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+                  Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) := by
+  obtain ⟨T, hT, hlevel, hstay, hsmall⟩ := exists_forward_morse_quadratic_level_exit hr hn hp hne
+  have hdomain (s : ℝ) (hs : s ∈ Set.uIcc (0 : ℝ) T) :=
+    hstay s (by simpa only [Set.uIcc_of_le hT.le] using hs)
+  have hflow :=
+    c.flow_eq_descentModel_of_mem_uIcc hV F hF hx (fun s hs => hbox (hdomain s hs))
+      (fun s hs => heq _ (hdomain s hs))
+  have htarget := hbox (hstay T ⟨hT.le, le_rfl⟩)
+  have hsource : F T x ∈ c.splitChart.source := by
+    rw [hflow]
+    exact c.splitChart.map_target' htarget
+  have hcoord : c.splitChart (F T x) = Smale.MorseHandle.descentFlow T (c.splitChart x) := by
+    rw [hflow]
+    exact c.splitChart.right_inv' htarget
+  refine ⟨T, hT, ?_, hsource, ?_, ?_⟩
+  · rw [hflow, c.splitChart_inverse_equation htarget]
+    change
+      -‖(Smale.MorseHandle.descentFlow T (c.splitChart x)).1‖ ^ 2 +
+          ‖(Smale.MorseHandle.descentFlow T (c.splitChart x)).2‖ ^ 2 =
+        -(r ^ 2) at hlevel
+    linarith
+  · simpa only [hcoord] using hsmall
+  · rw [hcoord]
+    exact hstay T ⟨hT.le, le_rfl⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.morse_coordinate_neighborhood {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) {a b : ℝ} (ha : 0 < a) (hb : 0 < b) :
+    ∀ᶠ x in 𝓝 p, x ∈ c.splitChart.source ∧ ‖(c.splitChart x).1‖ < a ∧ ‖(c.splitChart x).2‖ < b := by
+  have hc := c.splitChart.toOpenPartialHomeomorph.continuousAt c.splitChart_mem_source
+  have hn : ‖(c.splitChart p).1‖ < a := by
+    simpa only [c.splitChart_center, Prod.fst_zero, norm_zero] using ha
+  have hp : ‖(c.splitChart p).2‖ < b := by
+    simpa only [c.splitChart_center, Prod.snd_zero, norm_zero] using hb
+  have hs : ∀ᶠ x in 𝓝 p, x ∈ c.splitChart.source :=
+    c.splitChart.open_source.mem_nhds c.splitChart_mem_source
+  have hna : ∀ᶠ x in 𝓝 p, ‖(c.splitChart x).1‖ < a := hc.fst.norm (eventually_lt_nhds hn)
+  have hpb : ∀ᶠ x in 𝓝 p, ‖(c.splitChart x).2‖ < b := hc.snd.norm (eventually_lt_nhds hp)
+  exact hs.and (hna.and hpb)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.eventually_backward_exit_in_belt_neighborhood {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {r : ℝ} (hr : 0 < r)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) ⊆
+        c.splitChart.target)
+    (hfield :
+      ∀
+        z ∈
+          Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+            Metric.closedBall (0 : c.PositiveCoordinates) (2 * r),
+        ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y)
+    {U : Set M} (hU : IsOpen U)
+    (hcore :
+      ∀ v : Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates,
+        (c.beltCoreMap r hr hblock v : M) ∈ U) :
+    ∀ᶠ x in 𝓝 p, (c.splitChart x).2 ≠ 0 → ∃ T : ℝ, T < 0 ∧ f (F T x) = f p + r ^ 2 ∧ F T x ∈ U := by
+  obtain ⟨δ, hδ, hsection⟩ := exists_upper_morse_section_neighborhood c hr hblock hU hcore
+  filter_upwards [morse_coordinate_neighborhood c (lt_min hr hδ) hr] with x hx
+  intro hne
+  obtain ⟨T, hT, hlevel, hsource, hsmall, hbox⟩ :=
+    exists_native_backward_morse_level_exit c hV F hF hr hblock hfield hx.1
+      (hx.2.1.trans_le (min_le_left _ _)) hx.2.2 hne
+  have hq : Smale.MorseHandle.quadratic (c.splitChart (F T x)) = r ^ 2 := by
+    have heq := c.splitChart_equation hsource
+    change -‖(c.splitChart (F T x)).1‖ ^ 2 + ‖(c.splitChart (F T x)).2‖ ^ 2 = r ^ 2
+    linarith
+  have hh :=
+    hsection (c.splitChart (F T x)) hbox hq (hsmall.trans_lt (hx.2.1.trans_le (min_le_right _ _)))
+  have hinv : c.splitChart.symm (c.splitChart (F T x)) = F T x := c.splitChart.left_inv' hsource
+  rw [hinv] at hh
+  exact ⟨T, hT, hlevel, hh⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.eventually_forward_exit_in_attaching_neighborhood {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {r : ℝ} (hr : 0 < r)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) ⊆
+        c.splitChart.target)
+    (hfield :
+      ∀
+        z ∈
+          Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+            Metric.closedBall (0 : c.PositiveCoordinates) (2 * r),
+        ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y)
+    {U : Set M} (hU : IsOpen U)
+    (hcore :
+      ∀ v : Smale.PuncturedHandle.UnitSphere c.NegativeCoordinates,
+        (c.attachingCoreMap r hr hblock v : M) ∈ U) :
+    ∀ᶠ x in 𝓝 p, (c.splitChart x).1 ≠ 0 → ∃ T : ℝ, 0 < T ∧ f (F T x) = f p - r ^ 2 ∧ F T x ∈ U := by
+  obtain ⟨δ, hδ, hsection⟩ := exists_lower_morse_section_neighborhood c hr hblock hU hcore
+  filter_upwards [morse_coordinate_neighborhood c hr (lt_min hr hδ)] with x hx
+  intro hne
+  obtain ⟨T, hT, hlevel, hsource, hsmall, hbox⟩ :=
+    exists_native_forward_morse_level_exit c hV F hF hr hblock hfield hx.1 hx.2.1
+      (hx.2.2.trans_le (min_le_left _ _)) hne
+  have hq : Smale.MorseHandle.quadratic (c.splitChart (F T x)) = -(r ^ 2) := by
+    have heq := c.splitChart_equation hsource
+    change -‖(c.splitChart (F T x)).1‖ ^ 2 + ‖(c.splitChart (F T x)).2‖ ^ 2 = -(r ^ 2)
+    linarith
+  have hh :=
+    hsection (c.splitChart (F T x)) hbox hq (hsmall.trans_lt (hx.2.2.trans_le (min_le_right _ _)))
+  have hinv : c.splitChart.symm (c.splitChart (F T x)) = F T x := c.splitChart.left_inv' hsource
+  rw [hinv] at hh
+  exact ⟨T, hT, hlevel, hh⟩
+
+private theorem MorseCancel.quadratic_germ_derivative {A B : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] (Q : QuadraticForm ℝ A)
+    (R : QuadraticForm ℝ B) (hR : Continuous R) {F : A → B} {L : A →L[ℝ] B}
+    (hF : HasFDerivAt F L 0) (hF0 : F 0 = 0) (hquad : (fun x => R (F x)) =ᶠ[𝓝 0] Q) (v : A) :
+    R (L v) = Q v := by
+  have hline : HasDerivAt (fun t : ℝ => t • v) v 0 := by
+    simpa only [id_eq, one_smul] using (hasDerivAt_id (0 : ℝ)).smul_const v
+  have hcurve : HasDerivAt (fun t : ℝ => F (t • v)) (L v) 0 :=
+    hF.comp_hasDerivAt_of_eq 0 hline (by simp)
+  have hslope : Filter.Tendsto (fun t : ℝ => t⁻¹ • F (t • v)) (𝓝[≠] 0) (𝓝 (L v)) := by
+    simpa only [zero_add, zero_smul, hF0, sub_zero] using hcurve.tendsto_slope_zero
+  have hpath : Filter.Tendsto (fun t : ℝ => t • v) (𝓝[≠] 0) (𝓝 (0 : A)) := by
+    have hc : Continuous (fun t : ℝ => t • v) := continuous_id.smul continuous_const
+    simpa only [zero_smul] using (hc.tendsto (0 : ℝ)).mono_left nhdsWithin_le_nhds
+  have heq : (fun t : ℝ => R (t⁻¹ • F (t • v))) =ᶠ[𝓝[≠] 0] fun _ => Q v := by
+    filter_upwards [hquad.comp_tendsto hpath, self_mem_nhdsWithin] with t ht hne
+    have ht0 : t ≠ 0 := hne
+    change R (F (t • v)) = Q (t • v) at ht
+    rw [R.map_smul, ht, Q.map_smul]
+    simp only [smul_eq_mul]
+    field_simp
+  exact
+    tendsto_nhds_unique (hR.continuousAt.tendsto.comp hslope)
+      ((Filter.tendsto_congr' heq).mpr tendsto_const_nhds)
+
+private theorem MorseCancel.equivalent_quadratic_germs_of_bijective_derivative {A B : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    (Q : QuadraticForm ℝ A) (R : QuadraticForm ℝ B) (hR : Continuous R) {F : A → B}
+    {L : A →L[ℝ] B} (hF : HasFDerivAt F L 0) (hF0 : F 0 = 0) (hL : Function.Bijective L)
+    (hquad : (fun x => R (F x)) =ᶠ[𝓝 0] Q) : Q.Equivalent R := by
+  let e := LinearEquiv.ofBijective L.toLinearMap hL
+  exact ⟨{ e with map_app' := quadratic_germ_derivative Q R hR hF hF0 hquad }⟩
+
+private theorem MorseCancel.surgery_pair_band_isolation {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (p q : Smale.ManifoldMorse.criticalPoints E f)
+    (hconsecutive : ∀ r : Smale.ManifoldMorse.criticalPoints E f, ¬(f p < f r ∧ f r < f q)) :
+    ∀ z ∈ Smale.ManifoldMorse.criticalPoints E f,
+      f z ∈ Set.Icc (S.lower p) (S.upper q) → z = p.val ∨ z = q.val := by
+  intro z hz hband
+  by_cases hzp : f z ≤ f p
+  · exact Or.inl (S.isolated p z hz ⟨hband.1, hzp.trans (S.value_lt_upper p).le⟩)
+  by_cases hqz : f q ≤ f z
+  · exact Or.inr (S.isolated q z hz ⟨(S.lower_lt_value q).le.trans hqz, hband.2⟩)
+  exact (hconsecutive ⟨z, hz⟩ ⟨lt_of_not_ge hzp, lt_of_not_ge hqz⟩).elim
+
+private theorem MorseCancel.surgery_pair_inner_band_regular {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    (p q : Smale.ManifoldMorse.criticalPoints E f)
+    (hconsecutive : ∀ r : Smale.ManifoldMorse.criticalPoints E f, ¬(f p < f r ∧ f r < f q))
+    {a b : ℝ} (ha : f p < a) (hb : b < f q) :
+    ∀ z, f z ∈ Set.Icc a b → z ∉ Smale.ManifoldMorse.criticalPoints E f := by
+  intro z hz hcrit
+  exact hconsecutive ⟨z, hcrit⟩ ⟨ha.trans_le hz.1, hz.2.trans_lt hb⟩
+
+private theorem
+    MorseCancel.surviving_critical_germs_of_pair_band {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ} {p q : M} {l u : ℝ}
+    (hpair : ∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, f z ∈ Set.Icc l u → z = p ∨ z = q)
+    (hcrit :
+      ∀ z,
+        z ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+          z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ z ≠ p ∧ z ≠ q)
+    (hexterior : ∀ z, f z ∉ Set.Ioo l u → g =ᶠ[𝓝 z] f) :
+    ∀ z ∈ Smale.ManifoldMorse.criticalPoints E g, g =ᶠ[𝓝 z] f := by
+  intro z hz
+  obtain ⟨hzf, hzp, hzq⟩ := (hcrit z).mp hz
+  apply hexterior z
+  intro hband
+  exact (hpair z hzf ⟨hband.1.le, hband.2.le⟩).elim hzp hzq
+
+private theorem MorseCancel.distinct_critical_values_of_surviving_germs {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ}
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f))
+    (hsub : Smale.ManifoldMorse.criticalPoints E g ⊆ Smale.ManifoldMorse.criticalPoints E f)
+    (hgerms : ∀ z ∈ Smale.ManifoldMorse.criticalPoints E g, g =ᶠ[𝓝 z] f) :
+    Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) := by
+  intro x hx y hy hxy
+  apply hinj (hsub hx) (hsub hy)
+  rw [← (hgerms x hx).self_of_nhds, ← (hgerms y hy).self_of_nhds]
+  exact hxy
+
+private theorem MorseCancel.exists_signed_morse_chart_of_germ {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hgerm : g =ᶠ[𝓝 p] f) :
+    ∃ d : Smale.ManifoldMorse.SignedMorseChart (E := E) g p,
+      d.weights = c.weights ∧
+        d.chart.source ⊆ c.chart.source ∧
+          (∀ x, d.chart x = c.chart x) ∧ ∀ z, d.chart.symm z = c.chart.symm z := by
+  obtain ⟨U, hUsub, hU, hpU⟩ := mem_nhds_iff.mp hgerm
+  let P := Smale.PartialChart.restrictSource c.chart hU
+  let d : Smale.ManifoldMorse.SignedMorseChart (E := E) g p :=
+    { weights := c.weights
+      signs := c.signs
+      chart := P
+      mem_source := ⟨c.mem_source, hpU⟩
+      center := c.center
+      equation := by
+        intro x hx
+        have hxs : x ∈ c.chart.source ∩ U := hx
+        have hxeq : g x = f x := hUsub hxs.2
+        change g x = g p + ∑ i, c.weights i * (c.chart x i) ^ 2
+        rw [hxeq, hgerm.self_of_nhds]
+        exact c.equation x hxs.1
+      inverse_equation := by
+        intro z hz
+        have hzs : z ∈ c.chart.target ∩ c.chart.symm ⁻¹' U := hz
+        have hzeq : g (c.chart.symm z) = f (c.chart.symm z) := hUsub hzs.2
+        change g (c.chart.symm z) = g p + ∑ i, c.weights i * z i ^ 2
+        rw [hzeq, hgerm.self_of_nhds]
+        exact c.inverse_equation z hzs.1 }
+  exact ⟨d, rfl, Set.inter_subset_left, fun _ => rfl, fun _ => rfl⟩
+
+private theorem
+    MorseCancel.adapted_surgeries_after_pair_removal {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ}
+    [FiniteDimensional ℝ E] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (p q : Smale.ManifoldMorse.criticalPoints E f)
+    (hconsecutive : ∀ r : Smale.ManifoldMorse.criticalPoints E f, ¬(f p < f r ∧ f r < f q))
+    (hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g) (hmg : Smale.ManifoldMorse.IsMorse E g)
+    (hcrit :
+      ∀ z,
+        z ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+          z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ z ≠ p.val ∧ z ≠ q.val)
+    (hexterior : ∀ z, f z ∉ Set.Ioo (S.lower p) (S.upper q) → g =ᶠ[𝓝 z] f) :
+    (∀ z ∈ Smale.ManifoldMorse.criticalPoints E g, g =ᶠ[𝓝 z] f) ∧
+      Set.InjOn g (Smale.ManifoldMorse.criticalPoints E g) ∧ Nonempty (AdaptedWindows E g) := by
+  have hkeep :=
+    surviving_critical_germs_of_pair_band (surgery_pair_band_isolation S p q hconsecutive) hcrit
+      hexterior
+  have hinj :=
+    distinct_critical_values_of_surviving_germs S.distinct (fun z hz => ((hcrit z).mp hz).1) hkeep
+  exact ⟨hkeep, hinj, nonempty_adaptedSurgeryWindows hg hmg hinj⟩
+
+private theorem
+    MorseCancel.signed_morse_chart_quadratic_equivalent {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c d : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) :
+    (QuadraticMap.weightedSumSquares ℝ c.weights).Equivalent
+      (QuadraticMap.weightedSumSquares ℝ d.weights) := by
+  let Z := Fin (Module.finrank ℝ E) → ℝ
+  let Q : QuadraticForm ℝ Z := QuadraticMap.weightedSumSquares ℝ c.weights
+  let R : QuadraticForm ℝ Z := QuadraticMap.weightedSumSquares ℝ d.weights
+  have hQ (z : Z) : Q z = ∑ i, c.weights i * (z i) ^ 2 := by
+    simpa only [smul_eq_mul, pow_two] using
+      (QuadraticMap.weightedSumSquares_apply (R := ℝ) c.weights z)
+  have hR (z : Z) : R z = ∑ i, d.weights i * (z i) ^ 2 := by
+    simpa only [smul_eq_mul, pow_two] using
+      (QuadraticMap.weightedSumSquares_apply (R := ℝ) d.weights z)
+  have hRcont : Continuous R := by
+    change Continuous (fun z : Z => R z)
+    simp_rw [hR]
+    fun_prop
+  let P := c.chart.symm.trans d.chart
+  have hc0 : c.chart.symm (0 : Z) = p := by
+    rw [← c.center]
+    exact c.chart.left_inv' c.mem_source
+  have h0 : (0 : Z) ∈ P.source := by
+    refine ⟨?_, ?_⟩
+    · rw [← c.center]
+      exact c.chart.map_source' c.mem_source
+    · change c.chart.symm (0 : Z) ∈ d.chart.source
+      rw [hc0]
+      exact d.mem_source
+  have hP0 : P (0 : Z) = 0 := by
+    change d.chart (c.chart.symm (0 : Z)) = 0
+    rw [hc0, d.center]
+  have hdiff := (P.mdifferentiableAt (by simp) h0).differentiableAt
+  have hbij : Function.Bijective (fderiv ℝ P (0 : Z)) := by
+    have hh := Smale.PartialChart.bijective_mfderiv P h0
+    rw [mfderiv_eq_fderiv] at hh
+    exact hh
+  have hquad : (fun z => R (P z)) =ᶠ[𝓝 (0 : Z)] Q := by
+    filter_upwards [P.open_source.mem_nhds h0] with z hz
+    have hzs : z ∈ c.chart.target ∧ c.chart.symm z ∈ d.chart.source := hz
+    rw [hR, hQ]
+    change (∑ i, d.weights i * (d.chart (c.chart.symm z) i) ^ 2) = ∑ i, c.weights i * (z i) ^ 2
+    linarith [c.inverse_equation z hzs.1, d.equation (c.chart.symm z) hzs.2]
+  exact
+    equivalent_quadratic_germs_of_bijective_derivative Q R hRcont hdiff.hasFDerivAt hP0 hbij hquad
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.signed_morse_chart_negative_card_eq {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c d : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) :
+    Fintype.card { i // c.weights i = -1 } = Fintype.card { i // d.weights i = -1 } := by
+  have hs := (signed_morse_chart_quadratic_equivalent c d).sigNeg_eq
+  rw [QuadraticForm.sigNeg_weightedSumSquares, QuadraticForm.sigNeg_weightedSumSquares] at hs
+  have hc : {i | c.weights i < 0} = {i | c.weights i = -1} := by
+    ext i
+    rcases c.signs i with h | h <;> norm_num [h]
+  have hd : {i | d.weights i < 0} = {i | d.weights i = -1} := by
+    ext i
+    rcases d.signs i with h | h <;> norm_num [h]
+  rw [hc, hd] at hs
+  calc
+    Fintype.card { i // c.weights i = -1 } = {i | c.weights i = -1}.ncard :=
+      Set.fintypeCard_eq_ncard _
+    _ = {i | d.weights i = -1}.ncard := hs
+    _ = Fintype.card { i // d.weights i = -1 } := (Set.fintypeCard_eq_ncard _).symm
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.signed_morse_chart_negative_finrank_eq {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c d : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) :
+    Module.finrank ℝ c.NegativeCoordinates = Module.finrank ℝ d.NegativeCoordinates := by
+  simpa only [Smale.ManifoldMorse.SignedMorseChart.NegativeCoordinates,
+    Smale.MorseHandle.NegativeSpace, finrank_euclideanSpace] using
+    signed_morse_chart_negative_card_eq c d
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.signed_morse_chart_negative_finrank_eq_of_germ {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (d : Smale.ManifoldMorse.SignedMorseChart (E := E) g p) (hgerm : g =ᶠ[𝓝 p] f) :
+    Module.finrank ℝ c.NegativeCoordinates = Module.finrank ℝ d.NegativeCoordinates := by
+  obtain ⟨c', hw, -, -, -⟩ := exists_signed_morse_chart_of_germ c hgerm
+  have heq := signed_morse_chart_negative_card_eq c' d
+  rw [hw] at heq
+  simpa only [Smale.ManifoldMorse.SignedMorseChart.NegativeCoordinates,
+    Smale.MorseHandle.NegativeSpace, finrank_euclideanSpace] using heq
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    MorseCancel.nativeMorseIndex (E : Type*) [NormedAddCommGroup E] [NormedSpace ℝ E] {M : Type*}
+    [TopologicalSpace M] [ChartedSpace E M] (f : M → ℝ) (p : M) : ℕ :=
+  if h : Nonempty (Smale.ManifoldMorse.SignedMorseChart (E := E) f p) then
+    Module.finrank ℝ (Classical.choice h).NegativeCoordinates
+  else 0
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.nativeMorseIndex_eq_chart {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) :
+    nativeMorseIndex E f p = Module.finrank ℝ c.NegativeCoordinates := by
+  unfold nativeMorseIndex
+  rw [dite_eq_left ⟨c⟩]
+  exact signed_morse_chart_negative_finrank_eq _ c
+
+private theorem MorseCancel.nativeMorseIndex_congr_germ {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ} {p : M}
+    (hgerm : g =ᶠ[𝓝 p] f) : nativeMorseIndex E g p = nativeMorseIndex E f p := by
+  classical
+  by_cases h : Nonempty (Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+  · obtain ⟨c⟩ := h
+    obtain ⟨d, -, -, -, -⟩ := exists_signed_morse_chart_of_germ c hgerm
+    rw [nativeMorseIndex_eq_chart c, nativeMorseIndex_eq_chart d]
+    exact (signed_morse_chart_negative_finrank_eq_of_germ c d hgerm).symm
+  · have hg : ¬Nonempty (Smale.ManifoldMorse.SignedMorseChart (E := E) g p) := by
+      rintro ⟨d⟩
+      obtain ⟨c, -, -, -, -⟩ := exists_signed_morse_chart_of_germ d hgerm.symm
+      exact h ⟨c⟩
+    simp only [nativeMorseIndex, dite_eq_right h, dite_eq_right hg]
+
+private theorem
+    MorseCancel.nativeMorseIndex_le {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M} :
+    nativeMorseIndex E f p ≤ Module.finrank ℝ E := by
+  classical
+  by_cases h : Nonempty (Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+  · obtain ⟨c⟩ := h
+    rw [nativeMorseIndex_eq_chart c]
+    have hc := c.finrank_negative_add_positive
+    omega
+  · simp only [nativeMorseIndex, dite_eq_right h, Nat.zero_le]
+
+private theorem AdaptedWindows.nonminimum_forward_basin_meagre {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f)
+    (hindex : 0 < MorseCancel.nativeMorseIndex E f p) :
+    IsMeagre {x : M | Filter.Tendsto (fun t => S.flow t x) Filter.atTop (𝓝 p.val)} := by
+  let c := (S.data p).chart
+  obtain ⟨r, hr, hblock, hbasin⟩ :=
+    MorseCancel.exists_descending_morse_basin_block c hf (S.smooth.of_le (by simp)) S.flow
+      S.integral S.zero S.descent (S.critical_model_germ p)
+  let K :=
+    c.splitChart.symm ''
+      (({0} : Set c.NegativeCoordinates) ×ˢ Metric.closedBall (0 : c.PositiveCoordinates) (r / 2))
+  have hKt :
+    ({0} : Set c.NegativeCoordinates) ×ˢ Metric.closedBall (0 : c.PositiveCoordinates) (r / 2) ⊆
+      c.splitChart.target := by
+    rintro ⟨a, b⟩ ⟨ha, hb⟩
+    have ha0 : a = 0 := ha
+    subst a
+    exact
+      hblock
+        ⟨Metric.mem_closedBall_self hr.le,
+          Metric.closedBall_subset_closedBall (by linarith : r / 2 ≤ r) hb⟩
+  have hi : 0 < Module.finrank ℝ c.NegativeCoordinates := by
+    rwa [MorseCancel.nativeMorseIndex_eq_chart c] at hindex
+  have hK : IsNowhereDense K := MorseCancel.native_positive_plane_piece_nowhereDense c hi hKt
+  have hcover :
+    {x : M | Filter.Tendsto (fun t => S.flow t x) Filter.atTop (𝓝 p.val)} ⊆
+      ⋃ n : ℕ, S.flow (-(n : ℝ)) '' K := by
+    intro x hx
+    have hlim : Filter.Tendsto (fun n : ℕ => S.flow (n : ℝ) x) Filter.atTop (𝓝 p.val) :=
+      hx.comp tendsto_natCast_atTop_atTop
+    obtain ⟨n, hs, hn, hp⟩ :=
+      (hlim.eventually
+          (MorseCancel.morse_coordinate_neighborhood c (half_pos hr) (half_pos hr))).exists
+    have hnew : Filter.Tendsto (fun t => S.flow t (S.flow (n : ℝ) x)) Filter.atTop (𝓝 p.val) :=
+      (MorseCancel.flow_time_atTop_limit_iff S.flow (n : ℝ) x p.val).mpr hx
+    have hz : (c.splitChart (S.flow (n : ℝ) x)).1 = 0 :=
+      ((hbasin _ hs (hn.trans (half_lt_self hr)) (hp.trans (half_lt_self hr))).1).mp hnew
+    have hmem : S.flow (n : ℝ) x ∈ K := by
+      refine ⟨c.splitChart (S.flow (n : ℝ) x), ?_, c.splitChart.left_inv' hs⟩
+      exact ⟨Set.mem_singleton_iff.mpr hz, mem_closedBall_zero_iff.mpr hp.le⟩
+    exact
+      Set.mem_iUnion.mpr
+        ⟨n, S.flow (n : ℝ) x, hmem, (S.flow.toHomeomorph (n : ℝ)).symm_apply_apply x⟩
+  apply IsMeagre.mono hcover
+  apply isMeagre_iUnion
+  intro n
+  exact ((S.flow.toHomeomorph (-(n : ℝ))).isInducing.isNowhereDense_image hK).isMeagre
+
+private theorem Degree.FlowCancellation.height_eq_of_mem_omegaLimit {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f : X → ℝ} (hf : Continuous f) {κ : Filter ℝ} {x : X} {l : ℝ}
+    (hlim : Filter.Tendsto (fun t : ℝ => f (F t x)) κ (𝓝 l)) {y : X}
+    (hy : y ∈ omegaLimit κ F { x }) : f y = l := by
+  have hc : MapClusterPt y κ (fun t => F t x) :=
+    (mem_omegaLimit_singleton_iff_mapClusterPt κ F x y).mp hy
+  have hh := hc.continuousAt_comp hf.continuousAt
+  have hl : Filter.map (f ∘ (fun t => F t x)) κ ≤ 𝓝 l := hlim
+  exact eq_of_nhds_neBot (hh.clusterPt.mono hl)
+
+private theorem Degree.FlowCancellation.omegaLimit_subset_of_strict_height {X : Type*}
+    [TopologicalSpace X] (F : Flow ℝ X) {f : X → ℝ} (hf : Continuous f) {κ : Filter ℝ}
+    (hshift : ∀ t : ℝ, Filter.Tendsto (t + ·) κ κ) {S : Set X}
+    (hstrict : ∀ y ∉ S, f (F 1 y) < f y) {x : X} {l : ℝ}
+    (hlim : Filter.Tendsto (fun t : ℝ => f (F t x)) κ (𝓝 l)) : omegaLimit κ F { x } ⊆ S := by
+  intro y hy
+  by_contra hnot
+  have hy' : F 1 y ∈ omegaLimit κ F { x } := (F.isInvariant_omegaLimit κ { x } hshift) 1 hy
+  have h0 := height_eq_of_mem_omegaLimit F hf hlim hy
+  have h1 := height_eq_of_mem_omegaLimit F hf hlim hy'
+  have hs := hstrict y hnot
+  rw [h0, h1] at hs
+  exact lt_irrefl _ hs
+
+private theorem
+    Degree.FlowCancellation.exists_flow_limit_of_injective_exceptional_height {X : Type*}
+    [TopologicalSpace X] [CompactSpace X] (F : Flow ℝ X) {f : X → ℝ} (hf : Continuous f)
+    {κ : Filter ℝ} [Filter.NeBot κ] (hshift : ∀ t : ℝ, Filter.Tendsto (t + ·) κ κ) {S : Set X}
+    (hstrict : ∀ y ∉ S, f (F 1 y) < f y) (hinj : Set.InjOn f S) {x : X} {l : ℝ}
+    (hlim : Filter.Tendsto (fun t : ℝ => f (F t x)) κ (𝓝 l)) :
+    ∃ p ∈ S, f p = l ∧ Filter.Tendsto (fun t : ℝ => F t x) κ (𝓝 p) := by
+  have hsub := omegaLimit_subset_of_strict_height F hf hshift hstrict hlim
+  obtain ⟨p, hp⟩ := nonempty_omegaLimit κ F { x } (Set.singleton_nonempty x)
+  have hpl := height_eq_of_mem_omegaLimit F hf hlim hp
+  have hsingle : omegaLimit κ F { x } ⊆ { p } := by
+    intro y hy
+    exact hinj (hsub hy) (hsub hp) ((height_eq_of_mem_omegaLimit F hf hlim hy).trans hpl.symm)
+  refine ⟨p, hsub hp, hpl, ?_⟩
+  rw [Filter.tendsto_def]
+  intro U hU
+  obtain ⟨V, hVU, hV, hpV⟩ := mem_nhds_iff.mp hU
+  have hωV : omegaLimit κ F { x } ⊆ V := hsingle.trans (Set.singleton_subset_iff.mpr hpV)
+  have hEv := eventually_mapsTo_of_isOpen_of_omegaLimit_subset κ F { x } hV hωV
+  filter_upwards [hEv] with t ht
+  exact hVU (ht (Set.mem_singleton x))
+
+private theorem Degree.FlowCancellation.exists_strict_descent_flow_endpoints {X : Type*}
+    [TopologicalSpace X] [CompactSpace X] (F : Flow ℝ X) {f : X → ℝ} (hf : Continuous f)
+    {S : Set X} (hinj : Set.InjOn f S) (hmono : ∀ x, Antitone (fun t : ℝ => f (F t x)))
+    (hstrict : ∀ x ∉ S, StrictAnti (fun t : ℝ => f (F t x))) (x : X) :
+    ∃ p ∈ S,
+      ∃ q ∈ S,
+        Filter.Tendsto (fun t : ℝ => F t x) Filter.atBot (𝓝 p) ∧
+          Filter.Tendsto (fun t : ℝ => F t x) Filter.atTop (𝓝 q) ∧
+            (x ∉ S → f q < f x ∧ f x < f p) := by
+  have hrange : Set.range (fun t : ℝ => f (F t x)) ⊆ Set.range f := by
+    rintro y ⟨t, rfl⟩
+    exact ⟨F t x, rfl⟩
+  have hbelow : BddBelow (Set.range (fun t : ℝ => f (F t x))) :=
+    (isCompact_range hf).bddBelow.mono hrange
+  have habove : BddAbove (Set.range (fun t : ℝ => f (F t x))) :=
+    (isCompact_range hf).bddAbove.mono hrange
+  have htop := tendsto_atTop_ciInf (hmono x) hbelow
+  have hbot := tendsto_atBot_ciSup (hmono x) habove
+  have hshiftTop (t : ℝ) : Filter.Tendsto (t + ·) Filter.atTop Filter.atTop := by
+    apply Filter.tendsto_atTop.mpr
+    intro b
+    filter_upwards [Filter.eventually_ge_atTop (b - t)] with s hs
+    linarith
+  have hshiftBot (t : ℝ) : Filter.Tendsto (t + ·) Filter.atBot Filter.atBot := by
+    apply Filter.tendsto_atBot.mpr
+    intro b
+    filter_upwards [Filter.eventually_le_atBot (b - t)] with s hs
+    linarith
+  have hstep (y : X) (hy : y ∉ S) : f (F 1 y) < f y := by
+    have hh := hstrict y hy (show (0 : ℝ) < 1 by norm_num)
+    simpa only [F.map_zero_apply] using hh
+  obtain ⟨p, hp, hfp, hplim⟩ :=
+    exists_flow_limit_of_injective_exceptional_height F hf hshiftBot hstep hinj hbot
+  obtain ⟨q, hq, hfq, hqlim⟩ :=
+    exists_flow_limit_of_injective_exceptional_height F hf hshiftTop hstep hinj htop
+  refine ⟨p, hp, q, hq, hplim, hqlim, ?_⟩
+  intro hx
+  have hlow : f q ≤ f (F 1 x) := by
+    rw [hfq]
+    exact ciInf_le hbelow 1
+  have hhigh : f (F (-1) x) ≤ f p := by
+    rw [hfp]
+    exact le_ciSup habove (-1)
+  have hdec : f (F 1 x) < f x := hstep x hx
+  have hinc : f x < f (F (-1) x) := by
+    have hh := hstrict x hx (show (-1 : ℝ) < 0 by norm_num)
+    simpa only [F.map_zero_apply] using hh
+  exact ⟨hlow.trans_lt hdec, hinc.trans_le hhigh⟩
+
+private theorem Degree.FlowCancellation.exists_uniform_flow_escape {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f : X → ℝ} (hf : Continuous f) {C : Set X} (hC : IsCompact C) {c d : ℝ}
+    (hescape : ∀ x ∈ C, ∃ t : ℝ, f (F t x) ∉ Set.Icc c d) :
+    ∃ T : ℝ,
+      0 < T ∧
+        ∃ δ : ℝ, 0 < δ ∧ ∀ x ∈ C, ∃ t ∈ Set.Icc (-T) T, f (F t x) < c - δ ∨ d + δ < f (F t x) := by
+  classical
+  by_cases hne : C.Nonempty
+  swap
+  · exact ⟨1, by norm_num, 1, by norm_num, fun x hx => False.elim (hne ⟨x, hx⟩)⟩
+  let J := { p : ℝ × ℝ // 0 < p.2 }
+  let O : J → Set X := fun p =>
+    {x | f (F p.val.1 x) < c - p.val.2 ∨ d + p.val.2 < f (F p.val.1 x)}
+  have hO (p : J) : IsOpen (O p) :=
+    (isOpen_lt (hf.comp (F.continuous_toFun p.val.1)) continuous_const).union
+      (isOpen_lt continuous_const (hf.comp (F.continuous_toFun p.val.1)))
+  have hcover : C ⊆ ⋃ p, O p := by
+    intro x hx
+    obtain ⟨t, ht⟩ := hescape x hx
+    by_cases hl : c ≤ f (F t x)
+    · have hr : d < f (F t x) := lt_of_not_ge (fun h => ht ⟨hl, h⟩)
+      have hδ : 0 < (f (F t x) - d) / 2 := by linarith
+      apply Set.mem_iUnion.mpr
+      refine ⟨⟨(t, (f (F t x) - d) / 2), hδ⟩, Or.inr ?_⟩
+      change d + (f (F t x) - d) / 2 < f (F t x)
+      linarith
+    · have hl' : f (F t x) < c := lt_of_not_ge hl
+      have hδ : 0 < (c - f (F t x)) / 2 := by linarith
+      apply Set.mem_iUnion.mpr
+      refine ⟨⟨(t, (c - f (F t x)) / 2), hδ⟩, Or.inl ?_⟩
+      change f (F t x) < c - (c - f (F t x)) / 2
+      linarith
+  obtain ⟨S, hScover⟩ := hC.elim_finite_subcover O hO hcover
+  have hS : S.Nonempty := by
+    obtain ⟨x, hx⟩ := hne
+    obtain ⟨p, hp, -⟩ := Set.mem_iUnion₂.mp (hScover hx)
+    exact ⟨p, hp⟩
+  let T := S.sup' hS (fun p => |p.val.1|) + 1
+  let δ := S.inf' hS (fun p => p.val.2) / 2
+  have hmin : 0 < S.inf' hS (fun p => p.val.2) :=
+    (Finset.lt_inf'_iff hS).mpr (fun p _ => p.property)
+  have hT : 0 < T := by
+    obtain ⟨p, hp⟩ := hS
+    have hh := Finset.le_sup' (fun p : J => |p.val.1|) hp
+    have habs := abs_nonneg p.val.1
+    dsimp [T]
+    linarith
+  have hδ : 0 < δ := div_pos hmin (by norm_num)
+  refine ⟨T, hT, δ, hδ, ?_⟩
+  intro x hx
+  obtain ⟨p, hp, hpx⟩ := Set.mem_iUnion₂.mp (hScover hx)
+  have ht : |p.val.1| ≤ T := by
+    have hh := Finset.le_sup' (fun p : J => |p.val.1|) hp
+    dsimp [T]
+    linarith
+  have hd : δ ≤ p.val.2 := by
+    have hh := Finset.inf'_le (fun p : J => p.val.2) hp
+    dsimp [δ]
+    linarith
+  refine ⟨p.val.1, abs_le.mp ht, ?_⟩
+  rcases hpx with h | h
+  · exact Or.inl (by linarith)
+  · exact Or.inr (by linarith)
+
+private theorem Degree.FlowCancellation.exists_flow_no_return_neighborhood {X : Type*}
+    [TopologicalSpace X] [CompactSpace X] (F : Flow ℝ X) {f : X → ℝ} (hf : Continuous f)
+    (hmono : ∀ x, Antitone (fun t : ℝ => f (F t x))) {c d : ℝ} {K U : Set X} (hU : IsOpen U)
+    (hKU : K ⊆ U) (hband : ∀ x ∈ K, f x ∈ Set.Icc c d) (hinvariant : ∀ t x, x ∈ K → F t x ∈ K)
+    (hmaximal : ∀ x, (∀ t : ℝ, f (F t x) ∈ Set.Icc c d) → x ∈ K) :
+    ∃ N : Set X,
+      IsOpen N ∧
+        K ⊆ N ∧
+          N ⊆ U ∧ ∀ x ∈ N, ∀ t : ℝ, 0 ≤ t → F t x ∈ N → ∀ s ∈ Set.Icc (0 : ℝ) t, F s x ∈ U := by
+  have hescape : ∀ x ∈ Uᶜ, ∃ t : ℝ, f (F t x) ∉ Set.Icc c d := by
+    intro x hx
+    by_contra hh
+    apply hx
+    apply hKU
+    apply hmaximal x
+    intro t
+    by_contra ht
+    exact hh ⟨t, ht⟩
+  obtain ⟨T, hT, δ, hδ, hEsc⟩ :=
+    exists_uniform_flow_escape F hf hU.isClosed_compl.isCompact hescape
+  let N : Set X := {x | ∀ s ∈ Set.Icc (-T) T, F s x ∈ U} ∩ f ⁻¹' Set.Ioo (c - δ) (d + δ)
+  have hN : IsOpen N :=
+    (Smale.MorsePerturbation.isOpen_forall_mem_compact CompactIccSpace.isCompact_Icc
+          (hU.preimage (F.continuous continuous_snd continuous_fst))).inter
+      (isOpen_Ioo.preimage hf)
+  have hKN : K ⊆ N := by
+    intro x hx
+    refine ⟨fun s _ => hKU (hinvariant s x hx), ?_⟩
+    have hh := hband x hx
+    constructor <;> linarith [hh.1, hh.2]
+  have hNU : N ⊆ U := by
+    intro x hx
+    have hh := hx.1 0 (show (0 : ℝ) ∈ Set.Icc (-T) T from ⟨by linarith, hT.le⟩)
+    simpa only [F.map_zero_apply] using hh
+  refine ⟨N, hN, hKN, hNU, ?_⟩
+  intro x hx t ht htx s hs
+  by_cases hshort : s ≤ T
+  · exact hx.1 s ⟨by linarith [hs.1], hshort⟩
+  have hTs : T < s := lt_of_not_ge hshort
+  by_cases hshort' : t - s ≤ T
+  · have hh := htx.1 (s - t) (show s - t ∈ Set.Icc (-T) T from ⟨by linarith, by linarith [hs.2]⟩)
+    rw [← F.map_add, sub_add_cancel] at hh
+    exact hh
+  have hTs' : T < t - s := lt_of_not_ge hshort'
+  by_contra hout
+  obtain ⟨v, hv, hleave⟩ := hEsc (F s x) hout
+  have htime : s + v ∈ Set.Icc (0 : ℝ) t := ⟨by linarith [hv.1], by linarith [hv.2]⟩
+  have hlo := hmono x htime.1
+  have hhi := hmono x htime.2
+  change f (F (s + v) x) ≤ f (F 0 x) at hlo
+  change f (F t x) ≤ f (F (s + v) x) at hhi
+  rw [F.map_zero_apply] at hlo
+  rw [← F.map_add, add_comm v s] at hleave
+  have hxheight : f x ∈ Set.Ioo (c - δ) (d + δ) := hx.2
+  have htheight : f (F t x) ∈ Set.Ioo (c - δ) (d + δ) := htx.2
+  rcases hleave with h | h
+  · linarith [htheight.1]
+  · linarith [hxheight.2]
+
+private theorem
+    Degree.FlowCancellation.invariant_band_subset_connection {X : Type*} [TopologicalSpace X]
+    [CompactSpace X] (F : Flow ℝ X) {f : X → ℝ} (hf : Continuous f) {S : Set X}
+    (hinj : Set.InjOn f S) (hmono : ∀ x, Antitone (fun t : ℝ => f (F t x)))
+    (hstrict : ∀ x ∉ S, StrictAnti (fun t : ℝ => f (F t x))) {p q z : X}
+    (hpair : ∀ x ∈ S, f x ∈ Set.Icc (f p) (f q) → x = p ∨ x = q)
+    (hunique :
+      ∀ x ∉ S,
+        Filter.Tendsto (fun t : ℝ => F t x) Filter.atBot (𝓝 q) →
+          Filter.Tendsto (fun t : ℝ => F t x) Filter.atTop (𝓝 p) → ∃ t : ℝ, F t z = x)
+    {x : X} (hstay : ∀ t : ℝ, f (F t x) ∈ Set.Icc (f p) (f q)) :
+    x ∈ ({ p, q } : Set X) ∪ Set.range (fun t : ℝ => F t z) := by
+  have hxband : f x ∈ Set.Icc (f p) (f q) := by simpa only [F.map_zero_apply] using hstay 0
+  by_cases hxS : x ∈ S
+  · rcases hpair x hxS hxband with rfl | rfl <;> exact Or.inl (by simp)
+  obtain ⟨r, hr, s, hs, hrlim, hslim, hsep⟩ :=
+    exists_strict_descent_flow_endpoints F hf hinj hmono hstrict x
+  have hrband : f r ∈ Set.Icc (f p) (f q) :=
+    isClosed_Icc.mem_of_tendsto (hf.continuousAt.tendsto.comp hrlim)
+      (Filter.Eventually.of_forall hstay)
+  have hsband : f s ∈ Set.Icc (f p) (f q) :=
+    isClosed_Icc.mem_of_tendsto (hf.continuousAt.tendsto.comp hslim)
+      (Filter.Eventually.of_forall hstay)
+  have hsep' := hsep hxS
+  have hrq : r = q :=
+    (hpair r hr hrband).resolve_left
+      (by
+        intro he
+        rw [he] at hsep'
+        linarith [hxband.1])
+  have hsp : s = p :=
+    (hpair s hs hsband).resolve_right
+      (by
+        intro he
+        rw [he] at hsep'
+        linarith [hxband.2])
+  obtain ⟨t, ht⟩ :=
+    hunique x hxS (by simpa only [hrq] using hrlim) (by simpa only [hsp] using hslim)
+  exact Or.inr ⟨t, ht⟩
+
+private theorem Degree.FlowCancellation.exists_isolated_connection_no_return {X : Type*}
+    [TopologicalSpace X] [CompactSpace X] (F : Flow ℝ X) {f : X → ℝ} (hf : Continuous f)
+    {S : Set X} (hinj : Set.InjOn f S) (hmono : ∀ x, Antitone (fun t : ℝ => f (F t x)))
+    (hstrict : ∀ x ∉ S, StrictAnti (fun t : ℝ => f (F t x)))
+    (hfixed : ∀ x ∈ S, ∀ t : ℝ, F t x = x) {p q z : X} (hp : p ∈ S) (hq : q ∈ S) (hpq : f p < f q)
+    (hpair : ∀ x ∈ S, f x ∈ Set.Icc (f p) (f q) → x = p ∨ x = q)
+    (hzband : ∀ t : ℝ, f (F t z) ∈ Set.Icc (f p) (f q))
+    (hunique :
+      ∀ x ∉ S,
+        Filter.Tendsto (fun t : ℝ => F t x) Filter.atBot (𝓝 q) →
+          Filter.Tendsto (fun t : ℝ => F t x) Filter.atTop (𝓝 p) → ∃ t : ℝ, F t z = x)
+    {U : Set X} (hU : IsOpen U) (hpU : p ∈ U) (hqU : q ∈ U) (hzU : ∀ t : ℝ, F t z ∈ U) :
+    ∃ N : Set X,
+      IsOpen N ∧
+        N ⊆ U ∧
+          p ∈ N ∧
+            q ∈ N ∧
+              (∀ t : ℝ, F t z ∈ N) ∧
+                ∀ x ∈ N, ∀ t : ℝ, 0 ≤ t → F t x ∈ N → ∀ s ∈ Set.Icc (0 : ℝ) t, F s x ∈ U := by
+  let K : Set X := {x | ∀ t : ℝ, f (F t x) ∈ Set.Icc (f p) (f q)}
+  have hKU : K ⊆ U := by
+    intro x hx
+    rcases invariant_band_subset_connection F hf hinj hmono hstrict hpair hunique hx with h |
+      ⟨t, rfl⟩
+    · rcases h with h | h
+      · exact h ▸ hpU
+      · exact (show x = q from h) ▸ hqU
+    · exact hzU t
+  have hKband (x : X) (hx : x ∈ K) : f x ∈ Set.Icc (f p) (f q) := by
+    simpa only [F.map_zero_apply] using hx 0
+  have hKi (t : ℝ) (x : X) (hx : x ∈ K) : F t x ∈ K := by
+    intro s
+    rw [← F.map_add]
+    exact hx (s + t)
+  obtain ⟨N, hN, hKN, hNU, hreturn⟩ :=
+    exists_flow_no_return_neighborhood F hf hmono hU hKU hKband hKi (fun _ h => h)
+  have hpK : p ∈ K := by
+    intro t
+    rw [hfixed p hp t]
+    exact ⟨le_rfl, hpq.le⟩
+  have hqK : q ∈ K := by
+    intro t
+    rw [hfixed q hq t]
+    exact ⟨hpq.le, le_rfl⟩
+  exact ⟨N, hN, hNU, hKN hpK, hKN hqK, fun t => hKN (hKi t z hzband), hreturn⟩
+
+private theorem Degree.FlowCancellation.exists_native_descent_endpoints {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0)
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f)) (x : M) :
+    ∃ p ∈ Smale.ManifoldMorse.criticalPoints E f,
+      ∃ q ∈ Smale.ManifoldMorse.criticalPoints E f,
+        Filter.Tendsto (fun t : ℝ => F t x) Filter.atBot (𝓝 p) ∧
+          Filter.Tendsto (fun t : ℝ => F t x) Filter.atTop (𝓝 q) ∧
+            (x ∉ Smale.ManifoldMorse.criticalPoints E f → f q < f x ∧ f x < f p) := by
+  exact
+    exists_strict_descent_flow_endpoints F hf.continuous hinj
+      (Smale.FlowConstruction.antitone_flow_height hf F hcurve hzero hdesc)
+      (fun x hx =>
+        Smale.FlowConstruction.strictAnti_flow_height hf (hV.of_le (by simp)) F hcurve hzero hdesc
+          hx)
+      x
+
+private theorem Degree.FlowCancellation.exists_native_connection_no_return {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0)
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f)) {p q z : M}
+    (hp : p ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hq : q ∈ Smale.ManifoldMorse.criticalPoints E f) (hpq : f p < f q)
+    (hpair :
+      ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, f x ∈ Set.Icc (f p) (f q) → x = p ∨ x = q)
+    (hzband : ∀ t : ℝ, f (F t z) ∈ Set.Icc (f p) (f q))
+    (hunique :
+      ∀ x ∉ Smale.ManifoldMorse.criticalPoints E f,
+        Filter.Tendsto (fun t : ℝ => F t x) Filter.atBot (𝓝 q) →
+          Filter.Tendsto (fun t : ℝ => F t x) Filter.atTop (𝓝 p) → ∃ t : ℝ, F t z = x)
+    {U : Set M} (hU : IsOpen U) (hpU : p ∈ U) (hqU : q ∈ U) (hzU : ∀ t : ℝ, F t z ∈ U) :
+    ∃ N : Set M,
+      IsOpen N ∧
+        N ⊆ U ∧
+          p ∈ N ∧
+            q ∈ N ∧
+              (∀ t : ℝ, F t z ∈ N) ∧
+                ∀ x ∈ N, ∀ t : ℝ, 0 ≤ t → F t x ∈ N → ∀ s ∈ Set.Icc (0 : ℝ) t, F s x ∈ U := by
+  have hV₁ :
+    ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)) :=
+    hV.of_le (by simp)
+  exact
+    exists_isolated_connection_no_return F hf.continuous hinj
+      (Smale.FlowConstruction.antitone_flow_height hf F hcurve hzero hdesc)
+      (fun x hx => Smale.FlowConstruction.strictAnti_flow_height hf hV₁ F hcurve hzero hdesc hx)
+      (fun x hx t => Smale.FlowConstruction.flow_fixed_of_zero hV₁ F hcurve (hzero x hx) t) hp hq
+      hpq hpair hzband hunique hU hpU hqU hzU
+
+private theorem AdaptedWindows.isOpen_minimum_forward_basin {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f)
+    (hindex : MorseCancel.nativeMorseIndex E f p = 0) :
+    IsOpen {x : M | Filter.Tendsto (fun t => S.flow t x) Filter.atTop (𝓝 p.val)} := by
+  let c := (S.data p).chart
+  have hi : Module.finrank ℝ c.NegativeCoordinates = 0 :=
+    (MorseCancel.nativeMorseIndex_eq_chart c).symm.trans hindex
+  let : Subsingleton c.NegativeCoordinates :=
+    (Module.finrank_eq_zero_iff_of_free ℝ c.NegativeCoordinates).mp hi
+  obtain ⟨r, hr, -, hbasin⟩ :=
+    MorseCancel.exists_descending_morse_basin_block c hf (S.smooth.of_le (by simp)) S.flow
+      S.integral S.zero S.descent (S.critical_model_germ p)
+  have hnear : ∀ᶠ y in 𝓝 p.val, Filter.Tendsto (fun t => S.flow t y) Filter.atTop (𝓝 p.val) := by
+    filter_upwards [MorseCancel.morse_coordinate_neighborhood c hr hr] with y hy
+    exact ((hbasin y hy.1 hy.2.1 hy.2.2).1).mpr (Subsingleton.elim _ _)
+  apply isOpen_iff_mem_nhds.mpr
+  intro x hx
+  obtain ⟨t, ht⟩ := (hx.eventually (eventually_eventually_nhds.mpr hnear)).exists
+  have hc : Continuous (fun y => S.flow t y) := S.flow.continuous continuous_const continuous_id
+  filter_upwards [hc.continuousAt.tendsto.eventually ht] with y hy
+  exact (MorseCancel.flow_time_atTop_limit_iff S.flow t y p.val).mp hy
+
+private theorem AdaptedWindows.dense_minimum_forward_basins {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) :
+    Dense
+      {x : M |
+        ∃ p : Smale.ManifoldMorse.criticalPoints E f,
+          MorseCancel.nativeMorseIndex E f p = 0 ∧
+            Filter.Tendsto (fun t => S.flow t x) Filter.atTop (𝓝 p.val)} := by
+  let : Finite (Smale.ManifoldMorse.criticalPoints E f) := S.finite.to_subtype
+  let I :=
+    { p : Smale.ManifoldMorse.criticalPoints E f // 0 < MorseCancel.nativeMorseIndex E f p }
+  let B := ⋃ p : I, {x : M | Filter.Tendsto (fun t => S.flow t x) Filter.atTop (𝓝 p.val.val)}
+  have hm : IsMeagre B :=
+    isMeagre_iUnion (fun p : I => S.nonminimum_forward_basin_meagre hf p.val p.property)
+  have hd : Dense Bᶜ := dense_of_mem_residual hm
+  apply hd.mono
+  intro x hx
+  obtain ⟨r, hr, p, hp, -, hlim, -⟩ :=
+    Degree.FlowCancellation.exists_native_descent_endpoints hf S.smooth S.flow S.integral S.zero
+      S.descent S.distinct x
+  have hi : MorseCancel.nativeMorseIndex E f p = 0 := by
+    by_contra hi
+    apply hx
+    exact Set.mem_iUnion.mpr ⟨(⟨⟨p, hp⟩, Nat.pos_of_ne_zero hi⟩ : I), hlim⟩
+  exact ⟨⟨p, hp⟩, hi, hlim⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem AdaptedWindows.exists_positive_belt_branch_in_minimum_basin {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (p q : Smale.ManifoldMorse.criticalPoints E f) (hp : MorseCancel.nativeMorseIndex E f p = 0)
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1)
+    (hbranch :
+      Filter.Tendsto (fun t => S.flow t ((S.data q).surgery.attachingSphere u).val) Filter.atTop
+        (𝓝 p.val)) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ε ≤ 1 ∧
+          ∀ s : ℝ,
+            0 < s →
+              s < ε →
+                Filter.Tendsto
+                  (fun t =>
+                    S.flow t
+                      ((S.data q).chart.splitChart.symm
+                        (Degree.BeltPassage.upper (S.data q).radius s u.val v.val)))
+                  Filter.atTop (𝓝 p.val) := by
+  let d := S.data q
+  have h0target : Degree.BeltPassage.lower d.radius 0 u.val v.val ∈ d.chart.splitChart.target := by
+    rw [Degree.BeltPassage.lower_zero]
+    apply d.block
+    constructor
+    · rw [mem_closedBall_zero_iff, norm_smul, Real.norm_eq_abs, abs_of_pos d.radius_pos,
+        mem_sphere_zero_iff_norm.mp u.property, mul_one]
+      linarith [d.radius_pos]
+    · exact Metric.mem_closedBall_self (by linarith [d.radius_pos])
+  have h0value :
+    d.chart.splitChart.symm (Degree.BeltPassage.lower d.radius 0 u.val v.val) =
+      (d.surgery.attachingSphere u).val := by
+    rw [Degree.BeltPassage.lower_zero, d.attaching_eq, d.chart.attachingCoreMap_coe]
+  have hc :
+    ContinuousAt
+      (fun s : ℝ => d.chart.splitChart.symm (Degree.BeltPassage.lower d.radius s u.val v.val))
+      0 :=
+    (d.chart.splitChart.contMDiffOn_invFun.continuousOn.continuousAt
+          (d.chart.splitChart.open_target.mem_nhds h0target)).comp
+      (f := fun s : ℝ => Degree.BeltPassage.lower d.radius s u.val v.val)
+      (Degree.BeltPassage.contDiff_lower d.radius u.val v.val).continuous.continuousAt
+  have hbasin :
+    d.chart.splitChart.symm (Degree.BeltPassage.lower d.radius 0 u.val v.val) ∈
+      {x : M | Filter.Tendsto (fun t => S.flow t x) Filter.atTop (𝓝 p.val)} := by
+    rw [h0value]
+    exact hbranch
+  have hnear := hc.tendsto.eventually ((S.isOpen_minimum_forward_basin hf p hp).mem_nhds hbasin)
+  obtain ⟨δ, hδ, hδsub⟩ := Metric.mem_nhds_iff.mp hnear
+  refine ⟨Min.min δ 1, lt_min hδ zero_lt_one, min_le_right _ _, ?_⟩
+  intro s hs hsε
+  have hs₁ : s ≤ 1 := (hsε.trans_le (min_le_right _ _)).le
+  apply (S.belt_passage_forward_limit_iff q hs hs₁ u v p.val).mpr
+  apply hδsub
+  rw [Metric.mem_ball, Real.dist_eq, sub_zero, abs_of_pos hs]
+  exact hsε.trans_le (min_le_left _ _)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem AdaptedWindows.exists_two_sided_belt_branch_in_minimum_basin {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (p q : Smale.ManifoldMorse.criticalPoints E f) (hp : MorseCancel.nativeMorseIndex E f p = 0)
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1)
+    (hbranches :
+      ∀ w : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1,
+        Filter.Tendsto (fun t => S.flow t ((S.data q).surgery.attachingSphere w).val) Filter.atTop
+          (𝓝 p.val)) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ε ≤ 1 ∧
+          ∀ s : ℝ,
+            0 < |s| →
+              |s| < ε →
+                Filter.Tendsto
+                  (fun t =>
+                    S.flow t
+                      ((S.data q).chart.splitChart.symm
+                        (Degree.BeltPassage.upper (S.data q).radius s u.val v.val)))
+                  Filter.atTop (𝓝 p.val) := by
+  let u' : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1 :=
+    ⟨-u.val,
+      mem_sphere_zero_iff_norm.mpr
+        (by rw [norm_neg]; exact mem_sphere_zero_iff_norm.mp u.property)⟩
+  obtain ⟨εp, hεp, hεp1, hplus⟩ :=
+    S.exists_positive_belt_branch_in_minimum_basin hf p q hp u v (hbranches u)
+  obtain ⟨εn, hεn, -, hminus⟩ :=
+    S.exists_positive_belt_branch_in_minimum_basin hf p q hp u' v (hbranches u')
+  refine ⟨Min.min εp εn, lt_min hεp hεn, (min_le_left _ _).trans hεp1, ?_⟩
+  intro s hs hsmall
+  by_cases hpos : 0 < s
+  · apply hplus s hpos
+    rw [abs_of_pos hpos] at hsmall
+    exact hsmall.trans_le (min_le_left _ _)
+  · have hneg : s < 0 := lt_of_le_of_ne (le_of_not_gt hpos) (abs_pos.mp hs)
+    have heq :
+      Degree.BeltPassage.upper (S.data q).radius s u.val v.val =
+        Degree.BeltPassage.upper (S.data q).radius (-s) u'.val v.val := by
+      simpa only [neg_neg] using Degree.BeltPassage.upper_neg (S.data q).radius (-s) u.val v.val
+    rw [heq]
+    apply hminus (-s) (neg_pos.mpr hneg)
+    rw [abs_of_neg hneg] at hsmall
+    exact hsmall.trans_le (min_le_right _ _)
+
+attribute [local instance 100] Classical.propDecidable in
+private def MorseCancel.nativeBeltArc {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) (s : ℝ) : M :=
+  (S.data q).chart.splitChart.symm (Degree.BeltPassage.upper (S.data q).radius s u.val v.val)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.nativeBeltArc_coordinates_mem_target {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    {f : M → ℝ} (S : AdaptedWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) {s : ℝ} (hs : |s| ≤ 1) :
+    Degree.BeltPassage.upper (S.data q).radius s u.val v.val ∈
+      (S.data q).chart.splitChart.target :=
+  (S.data q).block
+    (Degree.BeltPassage.upper_mem_block (S.data q).radius_pos hs
+      (mem_sphere_zero_iff_norm.mp u.property) (mem_sphere_zero_iff_norm.mp v.property))
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.nativeBeltArc_height {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) {s : ℝ} (hs : |s| ≤ 1) :
+    f (nativeBeltArc S q u v s) = S.toSurgeryWindows.upper q := by
+  rw [nativeBeltArc,
+    (S.data q).chart.splitChart_inverse_equation
+      (nativeBeltArc_coordinates_mem_target S q u v hs)]
+  have hh :=
+    Degree.BeltPassage.upper_height (S.data q).radius s (mem_sphere_zero_iff_norm.mp u.property)
+      (mem_sphere_zero_iff_norm.mp v.property)
+  change
+    -‖(Degree.BeltPassage.upper (S.data q).radius s u.val v.val).1‖ ^ 2 +
+        ‖(Degree.BeltPassage.upper (S.data q).radius s u.val v.val).2‖ ^ 2 =
+      (S.data q).radius ^ 2 at hh
+  dsimp only [Smale.ManifoldMorse.SurgeryWindows.upper]
+  linarith
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.nativeBeltArc_zero {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) :
+    nativeBeltArc S q u v 0 = ((S.data q).surgery.beltSphere v).val := by
+  rw [nativeBeltArc, Degree.BeltPassage.upper_zero, (S.data q).belt_eq,
+    (S.data q).chart.beltCoreMap_coe]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.nativeBeltArc_belt_eq_iff {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    {f : M → ℝ} (S : AdaptedWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v w : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) {s : ℝ} (hs : |s| ≤ 1) :
+    nativeBeltArc S q u v s = ((S.data q).surgery.beltSphere w).val ↔ s = 0 ∧ v = w := by
+  constructor
+  · intro heq
+    have hzero := nativeBeltArc_coordinates_mem_target S q u w (s := 0) (by simp)
+    rw [Degree.BeltPassage.upper_zero] at hzero
+    rw [nativeBeltArc, (S.data q).belt_eq, (S.data q).chart.beltCoreMap_coe] at heq
+    have hcoords :=
+      (S.data q).chart.splitChart.symm.toPartialEquiv.injOn
+        (nativeBeltArc_coordinates_mem_target S q u v hs) hzero heq
+    have hu : u.val ≠ 0 := by
+      intro h
+      have hn := mem_sphere_zero_iff_norm.mp u.property
+      rw [h, norm_zero] at hn
+      exact zero_ne_one hn
+    have hs0 : s = 0 := by
+      have hfst : ((S.data q).radius * s) • u.val = 0 := congrArg Prod.fst hcoords
+      have hz : (S.data q).radius * s = 0 := (smul_eq_zero.mp hfst).resolve_right hu
+      exact (mul_eq_zero.mp hz).resolve_left (S.data q).radius_pos.ne'
+    refine ⟨hs0, ?_⟩
+    rw [hs0, Degree.BeltPassage.upper_zero] at hcoords
+    exact
+      Subtype.ext (smul_right_injective _ (S.data q).radius_pos.ne' (congrArg Prod.snd hcoords))
+  · rintro ⟨rfl, rfl⟩
+    exact nativeBeltArc_zero S q u v
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.nativeBeltArc_injOn {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) :
+    Set.InjOn (nativeBeltArc S q u v) (Set.Icc (-1 : ℝ) 1) := by
+  intro s hs t ht hst
+  have hcoords :=
+    (S.data q).chart.splitChart.symm.toPartialEquiv.injOn
+      (nativeBeltArc_coordinates_mem_target S q u v (abs_le.mpr hs))
+      (nativeBeltArc_coordinates_mem_target S q u v (abs_le.mpr ht)) hst
+  have hu : u.val ≠ 0 := by
+    intro h
+    have hn := mem_sphere_zero_iff_norm.mp u.property
+    rw [h, norm_zero] at hn
+    exact zero_ne_one hn
+  have hfst : ((S.data q).radius * s) • u.val = ((S.data q).radius * t) • u.val :=
+    congrArg Prod.fst hcoords
+  exact mul_left_cancel₀ (S.data q).radius_pos.ne' (smul_left_injective ℝ hu hfst)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.nativeBeltArc_contMDiffOn {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    {f : M → ℝ} (S : AdaptedWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) :
+    ContMDiffOn 𝓘(ℝ, ℝ) 𝓘(ℝ, E) ∞ (nativeBeltArc S q u v) (Set.Ioo (-1 : ℝ) 1) := by
+  apply
+    (S.data q).chart.splitChart.contMDiffOn_invFun.comp
+      (Degree.BeltPassage.contDiff_upper (S.data q).radius u.val v.val).contMDiff.contMDiffOn
+  intro s hs
+  exact nativeBeltArc_coordinates_mem_target S q u v (abs_le.mpr ⟨hs.1.le, hs.2.le⟩)
+
+private theorem MorseCancel.nativeLowerMeridian_coordinates_mem_target {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (q : Smale.ManifoldMorse.criticalPoints E f)
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) (s : unitInterval) :
+    Degree.BeltPassage.lower (S.data q).radius s u.val v.val ∈
+      (S.data q).chart.splitChart.target := by
+  have hh :=
+    Degree.BeltPassage.upper_mem_block (S.data q).radius_pos
+      (show |(s : ℝ)| ≤ 1 by rw [abs_of_nonneg s.property.1]; exact s.property.2)
+      (mem_sphere_zero_iff_norm.mp v.property) (mem_sphere_zero_iff_norm.mp u.property)
+  exact (S.data q).block ⟨hh.2, hh.1⟩
+
+private theorem MorseCancel.nativeLowerMeridian_height {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    {f : M → ℝ} (S : AdaptedWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) (s : unitInterval) :
+    f
+        ((S.data q).chart.splitChart.symm
+          (Degree.BeltPassage.lower (S.data q).radius s u.val v.val)) =
+      S.toSurgeryWindows.lower q := by
+  rw [(S.data q).chart.splitChart_inverse_equation
+      (nativeLowerMeridian_coordinates_mem_target S q u v s)]
+  have hh :=
+    Degree.BeltPassage.upper_height (S.data q).radius (s : ℝ)
+      (mem_sphere_zero_iff_norm.mp v.property) (mem_sphere_zero_iff_norm.mp u.property)
+  change
+    -‖(Degree.BeltPassage.lower (S.data q).radius s u.val v.val).2‖ ^ 2 +
+        ‖(Degree.BeltPassage.lower (S.data q).radius s u.val v.val).1‖ ^ 2 =
+      (S.data q).radius ^ 2 at hh
+  dsimp only [Smale.ManifoldMorse.SurgeryWindows.lower]
+  linarith
+
+private def
+    MorseCancel.nativeLowerMeridianFamily {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) :
+    C(unitInterval × Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1,
+      (S.data q).LowerLevel)
+    where
+  toFun
+    z :=
+    ⟨(S.data q).chart.splitChart.symm
+        (Degree.BeltPassage.lower (S.data q).radius z.1 z.2.val v.val),
+      nativeLowerMeridian_height S q z.2 v z.1⟩
+  continuous_toFun := by
+    have hsize :
+      Continuous
+        (fun z : unitInterval × Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1 =>
+          (z.1 : ℝ)) :=
+      continuous_subtype_val.comp continuous_fst
+    have hdir :
+      Continuous
+        (fun z : unitInterval × Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1 =>
+          z.2.val) :=
+      continuous_subtype_val.comp continuous_snd
+    have hcoords :
+      Continuous
+        (fun z : unitInterval × Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1 =>
+          Degree.BeltPassage.lower (S.data q).radius (z.1 : ℝ) z.2.val v.val) := by
+      unfold Degree.BeltPassage.lower
+      exact
+        ((continuous_const.mul
+                  (Real.continuous_sqrt.comp (continuous_const.add (hsize.pow 2)))).smul
+              hdir).prodMk
+          ((continuous_const.mul hsize).smul continuous_const)
+    exact
+      ((S.data q).chart.splitChart.contMDiffOn_invFun.continuousOn.comp_continuous hcoords
+            (fun z => nativeLowerMeridian_coordinates_mem_target S q z.2 v z.1)).subtype_mk
+        _
+
+private def MorseCancel.nativeLowerMeridian {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) (s : unitInterval) :
+    C(Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1, (S.data q).LowerLevel) :=
+  (nativeLowerMeridianFamily S q v).comp ((ContinuousMap.const _ s).prodMk (ContinuousMap.id _))
+
+private def MorseCancel.nativeUpperMeridian {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) (s : unitInterval) :
+    C(Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1, (S.data q).UpperLevel)
+    where
+  toFun
+    u :=
+    ⟨nativeBeltArc S q u v s,
+      nativeBeltArc_height S q u v (by rw [abs_of_nonneg s.property.1]; exact s.property.2)⟩
+  continuous_toFun := by
+    have hcoords :
+      Continuous
+        (fun u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1 =>
+          Degree.BeltPassage.upper (S.data q).radius (s : ℝ) u.val v.val) := by
+      unfold Degree.BeltPassage.upper
+      have hneg :
+        Continuous
+          (fun u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1 =>
+            ((S.data q).radius * (s : ℝ)) • u.val) :=
+        (continuous_subtype_val :
+              Continuous
+                (fun u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1 =>
+                  u.val)).const_smul
+          ((S.data q).radius * (s : ℝ))
+      have hpos :
+        Continuous
+          (fun _ : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1 =>
+            ((S.data q).radius * Real.sqrt (1 + (s : ℝ) ^ 2)) • v.val) :=
+        continuous_const
+      exact hneg.prodMk hpos
+    exact
+      ((S.data q).chart.splitChart.contMDiffOn_invFun.continuousOn.comp_continuous hcoords
+            (fun u =>
+              nativeBeltArc_coordinates_mem_target S q u v
+                (by rw [abs_of_nonneg s.property.1]; exact s.property.2))).subtype_mk
+        _
+
+private theorem MorseCancel.nativeLowerMeridian_zero {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    {f : M → ℝ} (S : AdaptedWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) :
+    nativeLowerMeridian S q v 0 = (S.data q).surgery.attachingSphere := by
+  apply ContinuousMap.ext
+  intro u
+  apply Subtype.ext
+  change
+    (S.data q).chart.splitChart.symm (Degree.BeltPassage.lower (S.data q).radius 0 u.val v.val) =
+      _
+  rw [Degree.BeltPassage.lower_zero, (S.data q).attaching_eq,
+    (S.data q).chart.attachingCoreMap_coe]
+
+private theorem MorseCancel.nativeUpperMeridian_flow {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} (S : AdaptedWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) (s : unitInterval)
+    (hs : 0 < (s : ℝ)) (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1) :
+    S.flow (Degree.BeltPassage.time s) ((nativeUpperMeridian S q v s) u).val =
+      ((nativeLowerMeridian S q v s) u).val :=
+  S.flow_belt_passage q hs s.property.2 u v
+
+private theorem
+    MorseCancel.nativeLowerMeridian_homotopic_attaching {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    {f : M → ℝ} (S : AdaptedWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) (s : unitInterval) :
+    (nativeLowerMeridian S q v s).Homotopic (S.data q).surgery.attachingSphere := by
+  let shrink : C(unitInterval, unitInterval) :=
+    ⟨fun t => unitInterval.symm t * s, unitInterval.continuous_symm.mul continuous_const⟩
+  have h0 : shrink 0 = s := by simp [shrink]
+  have h1 : shrink 1 = 0 := by simp [shrink]
+  let H : (nativeLowerMeridian S q v s).Homotopy (S.data q).surgery.attachingSphere :=
+    { toFun := fun z => nativeLowerMeridianFamily S q v (shrink z.1, z.2)
+      continuous_toFun :=
+        (nativeLowerMeridianFamily S q v).continuous.comp
+          ((shrink.continuous.comp continuous_fst).prodMk continuous_snd)
+      map_zero_left := by
+        intro u
+        rw [h0]
+        rfl
+      map_one_left := by
+        intro u
+        rw [h1]
+        exact
+          congrArg
+            (fun g :
+                C(Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1,
+                  (S.data q).LowerLevel) =>
+              g u)
+            (nativeLowerMeridian_zero S q v) }
+  exact ⟨H⟩
+
+private theorem MorseCancel.nativeUpperMeridian_avoids_belt {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    {f : M → ℝ} (S : AdaptedWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) (s : unitInterval)
+    (hs : 0 < (s : ℝ)) (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1) :
+    nativeUpperMeridian S q v s u ∉ Set.range (S.data q).surgery.beltSphere := by
+  rintro ⟨w, hw⟩
+  have he :=
+    (nativeBeltArc_belt_eq_iff S q u v w
+          (show |(s : ℝ)| ≤ 1 by rw [abs_of_nonneg s.property.1]; exact s.property.2)).mp
+      (congrArg Subtype.val hw.symm)
+  exact hs.ne' he.1
+
+private theorem Smale.NativeSubmersion.surjective_fderiv_sourceChart_iff {E F H X : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [TopologicalSpace X] [ChartedSpace H X]
+    (c : PartialDiffeomorph I 𝓘(ℝ, E) X E ∞) {f : X → F} {z : E} (hz : z ∈ c.target)
+    (hf : MDifferentiableAt I 𝓘(ℝ, F) f (c.symm z)) :
+    Function.Surjective (fderiv ℝ (f ∘ c.symm) z) ↔
+      Function.Surjective (mfderiv I 𝓘(ℝ, F) f (c.symm z)) := by
+  let A : E →L[ℝ] F := mfderiv I 𝓘(ℝ, F) f (c.symm z)
+  let B : E →L[ℝ] E := mfderiv 𝓘(ℝ, E) I c.symm z
+  have hd : fderiv ℝ (f ∘ c.symm) z = A.comp B := by
+    rw [← mfderiv_eq_fderiv]
+    exact mfderiv_comp z hf (c.symm.mdifferentiableAt (by simp) hz)
+  have hB : Function.Surjective B := (Smale.PartialChart.bijective_mfderiv c.symm hz).surjective
+  rw [hd]
+  change Function.Surjective (A.comp B) ↔ Function.Surjective A
+  constructor
+  · intro h w
+    obtain ⟨v, hv⟩ := h w
+    exact ⟨B v, hv⟩
+  · intro h
+    exact h.comp hB
+
+private theorem Smale.NativeSubmersion.isOpen_surjective_nativeDerivative {E F H X : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [TopologicalSpace X] [ChartedSpace H X]
+    {P : Type*} [NormedAddCommGroup P] [NormedSpace ℝ P] [FiniteDimensional ℝ E]
+    [FiniteDimensional ℝ F] [I.Boundaryless] [IsManifold I ∞ X] {f : P → X → F} {W : Set (P × X)}
+    (hW : IsOpen W) (hf : ContMDiffOn (𝓘(ℝ, P).prod I) 𝓘(ℝ, F) ∞ (Function.uncurry f) W)
+    (hdim : Module.finrank ℝ E = Module.finrank ℝ F) :
+    IsOpen {q : P × X | q ∈ W ∧ Function.Surjective (mfderiv I 𝓘(ℝ, F) (f q.1) q.2)} := by
+  rw [isOpen_iff_mem_nhds]
+  rintro q ⟨hq, hqsurj⟩
+  let c := NoExotic.modelChartPartialDiffeomorph (I := I) q.2
+  have hqc : q.2 ∈ c.source := mem_extChartAt_source q.2
+  let Q : Set (P × E) := Set.univ ×ˢ c.target
+  let C : P × E → P × X := fun r => (r.1, c.symm r.2)
+  have hQ : IsOpen Q := isOpen_univ.prod c.open_target
+  have hC : ContMDiffOn 𝓘(ℝ, P × E) (𝓘(ℝ, P).prod I) ∞ C Q :=
+    contDiff_fst.contMDiff.contMDiffOn.prodMk
+      (c.contMDiffOn_invFun.comp contDiff_snd.contMDiff.contMDiffOn (fun _ hr => hr.2))
+  let U : Set (P × E) := Q ∩ C ⁻¹' W
+  have hU : IsOpen U := hC.continuousOn.isOpen_inter_preimage hQ hW
+  have hcoord : ContDiffOn ℝ ∞ (fun r : P × E => f r.1 (c.symm r.2)) U :=
+    (hf.comp (hC.mono Set.inter_subset_left) (fun _ hr => hr.2)).contDiffOn
+  have hspatial :=
+    Smale.MorsePerturbation.contDiffOn_spatialDerivative (f := fun a z => f a (c.symm z)) hU
+      hcoord
+  have hopen : IsOpen {A : E →L[ℝ] F | Function.Surjective A} := by
+    have heq : {A : E →L[ℝ] F | Function.Surjective A} = {A : E →L[ℝ] F | Function.Injective A} :=
+      by
+      ext A
+      exact (LinearMap.injective_iff_surjective_of_finrank_eq_finrank hdim).symm
+    rw [heq]
+    exact ContinuousLinearMap.isOpen_injective
+  let V : Set (P × E) :=
+    U ∩
+      (fun r => fderiv ℝ (fun z => f r.1 (c.symm z)) r.2) ⁻¹'
+        {A : E →L[ℝ] F | Function.Surjective A}
+  have hV : IsOpen V := hspatial.continuousOn.isOpen_inter_preimage hU hopen
+  have hiff (r : P × E) (hr : r ∈ U) :
+    Function.Surjective (fderiv ℝ (fun z => f r.1 (c.symm z)) r.2) ↔
+      Function.Surjective (mfderiv I 𝓘(ℝ, F) (f r.1) (c.symm r.2)) := by
+    have hfr : ContMDiffAt I 𝓘(ℝ, F) ∞ (f r.1) (c.symm r.2) :=
+      (hf.contMDiffAt (hW.mem_nhds hr.2)).comp (c.symm r.2)
+        (contMDiffAt_const.prodMk contMDiffAt_id)
+    exact surjective_fderiv_sourceChart_iff c hr.1.2 (hfr.mdifferentiableAt (by simp))
+  have hleft : c.symm (c q.2) = q.2 := c.left_inv' hqc
+  have hqU : (q.1, c q.2) ∈ U := by
+    refine ⟨⟨Set.mem_univ _, c.map_source' hqc⟩, ?_⟩
+    change (q.1, c.symm (c q.2)) ∈ W
+    rw [hleft]
+    exact hq
+  have hqV : (q.1, c q.2) ∈ V := by
+    refine ⟨hqU, (hiff _ hqU).mpr ?_⟩
+    exact hleft.symm ▸ hqsurj
+  have hforward : ContinuousAt (fun r : P × X => (r.1, c r.2)) q :=
+    continuousAt_fst.prodMk
+      ((c.contMDiffOn_toFun.contMDiffAt (c.open_source.mem_nhds hqc)).continuousAt.comp
+        continuousAt_snd)
+  have hn := hforward.preimage_mem_nhds (hV.mem_nhds hqV)
+  have hnc : ∀ᶠ r : P × X in 𝓝 q, r.2 ∈ c.source :=
+    continuous_snd.continuousAt.preimage_mem_nhds (c.open_source.mem_nhds hqc)
+  apply Filter.mem_of_superset (Filter.inter_mem hn hnc)
+  intro r hr
+  have hleft' : c.symm (c r.2) = r.2 := c.left_inv' hr.2
+  have hmem : (r.1, c.symm (c r.2)) ∈ W := hr.1.1.2
+  have hsurj := (hiff (r.1, c r.2) hr.1.1).mp hr.1.2
+  refine ⟨?_, hleft' ▸ hsurj⟩
+  rwa [hleft'] at hmem
+
+private theorem
+    Smale.RegularValues.exists_null_exceptional_values_on {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [MeasurableSpace E] [BorelSpace E]
+    (μ : MeasureTheory.Measure E) [MeasureTheory.Measure.IsAddHaarMeasure μ] {f : E → E}
+    {s : Set E} (hf : ∀ x ∈ s, DifferentiableAt ℝ f x) :
+    ∃ T : Set E, μ T = 0 ∧ ∀ x ∈ s, f x ∉ T → Function.Bijective (fderiv ℝ f x) := by
+  let B : Set E := {x | x ∈ s ∧ (fderiv ℝ f x).det = 0}
+  have hzero : μ (f '' B) = 0 :=
+    MeasureTheory.addHaar_image_eq_zero_of_det_fderivWithin_eq_zero μ
+      (fun x hx => (hf x hx.1).hasFDerivAt.hasFDerivWithinAt) (fun _ hx => hx.2)
+  refine ⟨f '' B, hzero, ?_⟩
+  intro x hx hfx
+  apply (bijective_iff_det_ne_zero _).mpr
+  intro hdet
+  exact hfx ⟨x, ⟨hx, hdet⟩, rfl⟩
+
+private theorem Smale.RegularValues.exists_null_exceptional_values_in_chart {E F H X : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [FiniteDimensional ℝ F] [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [TopologicalSpace X] [ChartedSpace H X] [MeasurableSpace F] [BorelSpace F]
+    (μ : MeasureTheory.Measure F) [MeasureTheory.Measure.IsAddHaarMeasure μ]
+    (c : PartialDiffeomorph I 𝓘(ℝ, E) X E ∞) {f : X → F} {s : Set X} (hs : IsOpen s)
+    (hf : ContMDiffOn I 𝓘(ℝ, F) ∞ f s) (hdim : Module.finrank ℝ E = Module.finrank ℝ F) :
+    ∃ T : Set F,
+      μ T = 0 ∧ ∀ x ∈ c.source ∩ s, f x ∉ T → Function.Surjective (mfderiv I 𝓘(ℝ, F) f x) := by
+  let L : E ≃L[ℝ] F := ContinuousLinearEquiv.ofFinrankEq hdim
+  let W : Set F := L '' (c.target ∩ c.symm ⁻¹' s)
+  let G : F → F := fun z => f (c.symm (L.symm z))
+  have hcoord (z : F) (hz : z ∈ W) : L.symm z ∈ c.target ∧ c.symm (L.symm z) ∈ s := by
+    obtain ⟨w, hw, rfl⟩ := hz
+    rw [L.symm_apply_apply]
+    exact hw
+  have hsmooth (z : F) (hz : z ∈ W) : ContMDiffAt 𝓘(ℝ, F) 𝓘(ℝ, F) ∞ G z := by
+    have hh := hcoord z hz
+    exact
+      (hf.contMDiffAt (hs.mem_nhds hh.2)).comp z
+        ((c.contMDiffOn_invFun.contMDiffAt (c.open_target.mem_nhds hh.1)).comp z
+          L.symm.contDiff.contMDiff.contMDiffAt)
+  obtain ⟨T, hT, hgood⟩ :=
+    exists_null_exceptional_values_on μ
+      (fun z hz => (hsmooth z hz).mdifferentiableAt (by simp) |>.differentiableAt)
+  refine ⟨T, hT, ?_⟩
+  intro x hx hfx
+  let z := L (c x)
+  have hz : z ∈ W := by
+    refine ⟨c x, ⟨c.map_source' hx.1, ?_⟩, rfl⟩
+    change c.symm (c x) ∈ s
+    have heq : c.symm (c x) = x := c.left_inv' hx.1
+    rw [heq]
+    exact hx.2
+  have hpoint : c.symm (L.symm z) = x := by
+    change c.symm (L.symm (L (c x))) = x
+    rw [L.symm_apply_apply]
+    exact c.left_inv' hx.1
+  have hvalue : G z = f x := congrArg f hpoint
+  have hbij := hgood z hz (by rwa [hvalue])
+  have hfx' : MDifferentiableAt I 𝓘(ℝ, F) f (c.symm (L.symm z)) :=
+    (hf.contMDiffAt (hs.mem_nhds (hcoord z hz).2)).mdifferentiableAt (by simp)
+  have hinner : MDifferentiableAt 𝓘(ℝ, F) I (c.symm ∘ L.symm) z :=
+    (c.symm.mdifferentiableAt (by simp) (hcoord z hz).1).comp z
+      L.symm.toContinuousLinearMap.differentiableAt.mdifferentiableAt
+  rw [← mfderiv_eq_fderiv] at hbij
+  change Function.Bijective (mfderiv 𝓘(ℝ, F) 𝓘(ℝ, F) (f ∘ (c.symm ∘ L.symm)) z) at hbij
+  rw [mfderiv_comp z hfx' hinner] at hbij
+  have hsurj : Function.Surjective (mfderiv I 𝓘(ℝ, F) f (c.symm (L.symm z))) := by
+    intro w
+    obtain ⟨v, hv⟩ := hbij.surjective w
+    exact ⟨mfderiv 𝓘(ℝ, F) I (c.symm ∘ L.symm) z v, hv⟩
+  exact hpoint ▸ hsurj
+
+private theorem Smale.RegularValues.exists_null_exceptional_values_manifold {E F H X : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [FiniteDimensional ℝ F] [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [I.Boundaryless] [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X]
+    [MeasurableSpace F] [BorelSpace F] (μ : MeasureTheory.Measure F)
+    [MeasureTheory.Measure.IsAddHaarMeasure μ] [LindelofSpace X] {f : X → F} {s : Set X}
+    (hs : IsOpen s) (hf : ContMDiffOn I 𝓘(ℝ, F) ∞ f s)
+    (hdim : Module.finrank ℝ E = Module.finrank ℝ F) :
+    ∃ T : Set F, μ T = 0 ∧ ∀ x ∈ s, f x ∉ T → Function.Surjective (mfderiv I 𝓘(ℝ, F) f x) := by
+  classical
+  let c (x : X) := NoExotic.modelChartPartialDiffeomorph (I := I) x
+  let U : X → Set X := fun x => (c x).source
+  have hU : ∀ x, IsOpen (U x) := fun x => (c x).open_source
+  have hcover : (Set.univ : Set X) ⊆ ⋃ x, U x := by
+    intro x _
+    exact Set.mem_iUnion.mpr ⟨x, mem_extChartAt_source x⟩
+  obtain ⟨t, htcount, ht⟩ := isLindelof_univ.elim_countable_subcover U hU hcover
+  let _ := htcount.to_subtype
+  choose T hT hgood using fun i : t => exists_null_exceptional_values_in_chart μ (c i) hs hf hdim
+  refine ⟨⋃ i : t, T i, MeasureTheory.measure_iUnion_null hT, ?_⟩
+  intro x hx hfx
+  obtain ⟨i, hit, hxi⟩ := Set.mem_iUnion₂.mp (ht (Set.mem_univ x))
+  apply hgood ⟨i, hit⟩ x ⟨hxi, hx⟩
+  intro hi
+  exact hfx (Set.mem_iUnion.mpr ⟨⟨i, hit⟩, hi⟩)
+
+private theorem Smale.TransverseCoordinates.mfderiv_sheetDifference {D Z F H K X Y : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ D H} {J : ModelWithCorners ℝ Z K} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace K Y] {f : X → F} {g : Y → F} {x : X}
+    {y : Y} (hf : MDifferentiableAt I 𝓘(ℝ, F) f x) (hg : MDifferentiableAt J 𝓘(ℝ, F) g y) :
+    (mfderiv (I.prod J) 𝓘(ℝ, F) (fun z : X × Y => g z.2 - f z.1) (x, y) : D × Z →L[ℝ] F) =
+      (-(mfderiv I 𝓘(ℝ, F) f x : D →L[ℝ] F)).coprod (mfderiv J 𝓘(ℝ, F) g y : Z →L[ℝ] F) := by
+  let A : D →L[ℝ] F := mfderiv I 𝓘(ℝ, F) f x
+  let B : Z →L[ℝ] F := mfderiv J 𝓘(ℝ, F) g y
+  change
+    (mfderiv (I.prod J) 𝓘(ℝ, F) (g ∘ Prod.snd - f ∘ Prod.fst) (x, y) : D × Z →L[ℝ] F) =
+      (-A).coprod B
+  have hf' : MDifferentiableAt (I.prod J) 𝓘(ℝ, F) (f ∘ Prod.fst) (x, y) :=
+    hf.comp (x, y) mdifferentiableAt_fst
+  have hg' : MDifferentiableAt (I.prod J) 𝓘(ℝ, F) (g ∘ Prod.snd) (x, y) :=
+    hg.comp (x, y) mdifferentiableAt_snd
+  rw [mfderiv_sub hg' hf', mfderiv_comp (x, y) hg mdifferentiableAt_snd,
+    mfderiv_comp (x, y) hf mdifferentiableAt_fst, mfderiv_fst, mfderiv_snd]
+  apply ContinuousLinearMap.ext
+  intro v
+  change B v.2 - A v.1 = -(A v.1) + B v.2
+  abel
+
+private theorem Smale.TransverseCoordinates.surjective_sheetDifference_iff {D Z F H K X Y : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ D H} {J : ModelWithCorners ℝ Z K} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace K Y] {f : X → F} {g : Y → F} {x : X}
+    {y : Y} (hf : MDifferentiableAt I 𝓘(ℝ, F) f x) (hg : MDifferentiableAt J 𝓘(ℝ, F) g y) :
+    Function.Surjective (mfderiv (I.prod J) 𝓘(ℝ, F) (fun z : X × Y => g z.2 - f z.1) (x, y)) ↔
+      Function.Surjective
+        ((mfderiv I 𝓘(ℝ, F) f x : D →L[ℝ] F).coprod (mfderiv J 𝓘(ℝ, F) g y : Z →L[ℝ] F)) := by
+  rw [mfderiv_sheetDifference hf hg]
+  let A : D →L[ℝ] F := mfderiv I 𝓘(ℝ, F) f x
+  let B : Z →L[ℝ] F := mfderiv J 𝓘(ℝ, F) g y
+  change Function.Surjective ((-A).coprod B) ↔ Function.Surjective (A.coprod B)
+  constructor
+  · intro h w
+    obtain ⟨v, hv⟩ := h w
+    refine ⟨(-v.1, v.2), ?_⟩
+    change A (-v.1) + B v.2 = w
+    change -(A v.1) + B v.2 = w at hv
+    simpa only [map_neg] using hv
+  · intro h w
+    obtain ⟨v, hv⟩ := h w
+    refine ⟨(-v.1, v.2), ?_⟩
+    change -(A (-v.1)) + B v.2 = w
+    change A v.1 + B v.2 = w at hv
+    simpa only [map_neg, neg_neg] using hv
+
+private theorem Smale.TransverseCoordinates.exists_null_exceptional_native_translations
+    {D Z F H K X Y : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [FiniteDimensional ℝ F] [TopologicalSpace H] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ D H} {J : ModelWithCorners ℝ Z K} [I.Boundaryless] [J.Boundaryless]
+    [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X] [TopologicalSpace Y]
+    [ChartedSpace K Y] [IsManifold J ∞ Y] [LindelofSpace (X × Y)] [MeasurableSpace F]
+    [BorelSpace F] (μ : MeasureTheory.Measure F) [MeasureTheory.Measure.IsAddHaarMeasure μ]
+    {f : X → F} {g : Y → F} {U : Set X} {V : Set Y} (hU : IsOpen U) (hV : IsOpen V)
+    (hf : ContMDiffOn I 𝓘(ℝ, F) ∞ f U) (hg : ContMDiffOn J 𝓘(ℝ, F) ∞ g V)
+    (hdim : Module.finrank ℝ D + Module.finrank ℝ Z = Module.finrank ℝ F) :
+    ∃ T : Set F,
+      μ T = 0 ∧
+        ∀ a ∉ T,
+          ∀ x ∈ U,
+            ∀ y ∈ V,
+              g y = f x + a →
+                Function.Surjective ((mfderiv I 𝓘(ℝ, F) f x).coprod (mfderiv J 𝓘(ℝ, F) g y)) := by
+  let B : X × Y → F := fun z => g z.2 - f z.1
+  have hB : ContMDiffOn (I.prod J) 𝓘(ℝ, F) ∞ B (U ×ˢ V) := by
+    intro z hz
+    have hfx : ContMDiffAt (I.prod J) 𝓘(ℝ, F) ∞ (fun w : X × Y => f w.1) z :=
+      (hf.contMDiffAt (hU.mem_nhds hz.1)).comp z contMDiffAt_fst
+    have hgy : ContMDiffAt (I.prod J) 𝓘(ℝ, F) ∞ (fun w : X × Y => g w.2) z :=
+      (hg.contMDiffAt (hV.mem_nhds hz.2)).comp z contMDiffAt_snd
+    exact (hgy.sub hfx).contMDiffWithinAt
+  obtain ⟨T, hT, hgood⟩ :=
+    Smale.RegularValues.exists_null_exceptional_values_manifold μ (hU.prod hV) hB
+      (by simpa only [Module.finrank_prod] using hdim)
+  refine ⟨T, hT, ?_⟩
+  intro a ha x hx y hy hxy
+  have hvalue : B (x, y) = a := by
+    change g y - f x = a
+    rw [hxy, add_sub_cancel_left]
+  have hs := hgood (x, y) ⟨hx, hy⟩ (by rwa [hvalue])
+  change
+    Function.Surjective (mfderiv (I.prod J) 𝓘(ℝ, F) (fun z : X × Y => g z.2 - f z.1) (x, y)) at hs
+  rw [mfderiv_sheetDifference ((hf.contMDiffAt (hU.mem_nhds hx)).mdifferentiableAt (by simp))
+      ((hg.contMDiffAt (hV.mem_nhds hy)).mdifferentiableAt (by simp))] at hs
+  let A : D →L[ℝ] F := mfderiv I 𝓘(ℝ, F) f x
+  let B' : Z →L[ℝ] F := mfderiv J 𝓘(ℝ, F) g y
+  change Function.Surjective ((-A).coprod B') at hs
+  change Function.Surjective (A.coprod B')
+  intro w
+  obtain ⟨v, hv⟩ := hs w
+  refine ⟨(-v.1, v.2), ?_⟩
+  change A (-v.1) + B' v.2 = w
+  change -(A v.1) + B' v.2 = w at hv
+  simpa only [map_neg] using hv
+
+private theorem Smale.TransverseCoordinates.dense_native_translations {D Z F H K X Y : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [FiniteDimensional ℝ F] [TopologicalSpace H] [TopologicalSpace K] {I : ModelWithCorners ℝ D H}
+    {J : ModelWithCorners ℝ Z K} [I.Boundaryless] [J.Boundaryless] [TopologicalSpace X]
+    [ChartedSpace H X] [IsManifold I ∞ X] [TopologicalSpace Y] [ChartedSpace K Y]
+    [IsManifold J ∞ Y] [LindelofSpace (X × Y)] {f : X → F} {g : Y → F} {U : Set X} {V : Set Y}
+    (hU : IsOpen U) (hV : IsOpen V) (hf : ContMDiffOn I 𝓘(ℝ, F) ∞ f U)
+    (hg : ContMDiffOn J 𝓘(ℝ, F) ∞ g V)
+    (hdim : Module.finrank ℝ D + Module.finrank ℝ Z = Module.finrank ℝ F) :
+    Dense
+      {a : F |
+        ∀ x ∈ U,
+          ∀ y ∈ V,
+            g y = f x + a →
+              Function.Surjective ((mfderiv I 𝓘(ℝ, F) f x).coprod (mfderiv J 𝓘(ℝ, F) g y))} := by
+  let _ : MeasurableSpace F := borel F
+  let _ : BorelSpace F := ⟨rfl⟩
+  let μ : MeasureTheory.Measure F := MeasureTheory.Measure.addHaar
+  obtain ⟨T, hT, hgood⟩ := exists_null_exceptional_native_translations μ hU hV hf hg hdim
+  have hdense : Dense Tᶜ := by
+    apply μ.dense_of_ae
+    rw [MeasureTheory.ae_iff]
+    simpa only [Set.mem_compl_iff, Classical.not_not, Set.ofPred_mem_eq] using hT
+  exact hdense.mono hgood
+
+private theorem Smale.ChartMapPerturbation.mfderiv_eq_of_translation_germ {D F H X : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ D H} [TopologicalSpace X] [ChartedSpace H X]
+    {u v : X → F} {a : F} {x : X} (hu : MDifferentiableAt I 𝓘(ℝ, F) u x)
+    (hevent : v =ᶠ[𝓝 x] fun z => u z + a) :
+    (mfderiv I 𝓘(ℝ, F) v x : D →L[ℝ] F) = mfderiv I 𝓘(ℝ, F) u x := by
+  let A : D →L[ℝ] F := mfderiv I 𝓘(ℝ, F) u x
+  let C : D →L[ℝ] F := mfderiv I 𝓘(ℝ, F) (fun _ : X => a) x
+  have hC : C = 0 := mfderiv_const
+  have hh :=
+    mfderiv_add hu
+      (show MDifferentiableAt I 𝓘(ℝ, F) (fun _ : X => a) x from mdifferentiableAt_const)
+  change (mfderiv I 𝓘(ℝ, F) (fun z => u z + a) x : D →L[ℝ] F) = A + C at hh
+  rw [hC] at hh
+  exact hevent.mfderiv_eq.trans (hh.trans (add_zero A))
+
+private theorem Smale.ChartMapPerturbation.transverse_of_chart {D Z G F H H' K X Y N : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] [TopologicalSpace H'] [TopologicalSpace K] {I : ModelWithCorners ℝ D H}
+    {I' : ModelWithCorners ℝ Z H'} {J : ModelWithCorners ℝ G K} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y] [TopologicalSpace N]
+    [ChartedSpace K N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {g : Y → N} {x : X}
+    {y : Y} (hf : MDifferentiableAt I J f x) (hg : MDifferentiableAt I' J g y) (hxy : g y = f x)
+    (hx : f x ∈ c.source)
+    (ht :
+      Function.Surjective
+        ((mfderiv I 𝓘(ℝ, F) (c ∘ f) x : D →L[ℝ] F).coprod
+          (mfderiv I' 𝓘(ℝ, F) (c ∘ g) y : Z →L[ℝ] F))) :
+    Function.Surjective ((mfderiv I J f x : D →L[ℝ] G).coprod (mfderiv I' J g y : Z →L[ℝ] G)) := by
+  let A : D →L[ℝ] G := mfderiv I J f x
+  let B : Z →L[ℝ] G := mfderiv I' J g y
+  let C : G →L[ℝ] F := mfderiv J 𝓘(ℝ, F) c (f x)
+  have hy : g y ∈ c.source := hxy ▸ hx
+  have hA : (mfderiv I 𝓘(ℝ, F) (c ∘ f) x : D →L[ℝ] F) = C.comp A :=
+    mfderiv_comp x (c.mdifferentiableAt (by simp) hx) hf
+  have hB : (mfderiv I' 𝓘(ℝ, F) (c ∘ g) y : Z →L[ℝ] F) = C.comp B := by
+    rw [mfderiv_comp y (c.mdifferentiableAt (by simp) hy) hg, hxy]
+    rfl
+  have heq : (C.comp A).coprod (C.comp B) = C.comp (A.coprod B) := by
+    apply ContinuousLinearMap.ext
+    intro v
+    change C (A v.1) + C (B v.2) = C (A v.1 + B v.2)
+    exact (C.map_add _ _).symm
+  rw [hA, hB] at ht
+  change Function.Surjective ((C.comp A).coprod (C.comp B)) at ht
+  rw [heq] at ht
+  have hC : Function.Injective C := (Smale.PartialChart.bijective_mfderiv c hx).injective
+  change Function.Surjective (A.coprod B)
+  intro w
+  obtain ⟨v, hv⟩ := ht (C w)
+  exact ⟨v, hC hv⟩
+
+private theorem Smale.ChartMapPerturbation.transverse_in_chart {D Z G F H H' K X Y N : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] [TopologicalSpace H'] [TopologicalSpace K] {I : ModelWithCorners ℝ D H}
+    {I' : ModelWithCorners ℝ Z H'} {J : ModelWithCorners ℝ G K} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y] [TopologicalSpace N]
+    [ChartedSpace K N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {g : Y → N} {x : X}
+    {y : Y} (hf : MDifferentiableAt I J f x) (hg : MDifferentiableAt I' J g y) (hxy : g y = f x)
+    (hx : f x ∈ c.source)
+    (ht :
+      Function.Surjective ((mfderiv I J f x : D →L[ℝ] G).coprod (mfderiv I' J g y : Z →L[ℝ] G))) :
+    Function.Surjective
+      ((mfderiv I 𝓘(ℝ, F) (c ∘ f) x : D →L[ℝ] F).coprod
+        (mfderiv I' 𝓘(ℝ, F) (c ∘ g) y : Z →L[ℝ] F)) := by
+  let A : D →L[ℝ] G := mfderiv I J f x
+  let B : Z →L[ℝ] G := mfderiv I' J g y
+  let C : G →L[ℝ] F := mfderiv J 𝓘(ℝ, F) c (f x)
+  have hy : g y ∈ c.source := hxy ▸ hx
+  have hA : (mfderiv I 𝓘(ℝ, F) (c ∘ f) x : D →L[ℝ] F) = C.comp A :=
+    mfderiv_comp x (c.mdifferentiableAt (by simp) hx) hf
+  have hB : (mfderiv I' 𝓘(ℝ, F) (c ∘ g) y : Z →L[ℝ] F) = C.comp B := by
+    rw [mfderiv_comp y (c.mdifferentiableAt (by simp) hy) hg, hxy]
+    rfl
+  rw [hA, hB]
+  change Function.Surjective ((C.comp A).coprod (C.comp B))
+  have hC : Function.Surjective C := (Smale.PartialChart.bijective_mfderiv c hx).surjective
+  change Function.Surjective (A.coprod B) at ht
+  intro w
+  obtain ⟨z, hz⟩ := hC w
+  obtain ⟨v, hv⟩ := ht z
+  refine ⟨v, ?_⟩
+  change C (A v.1) + C (B v.2) = w
+  rw [← C.map_add]
+  exact (congrArg C hv).trans hz
+
+private def Smale.NativeTransversality.At {D Z G H H' K X Y N : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] [TopologicalSpace H'] [TopologicalSpace K]
+    (I : ModelWithCorners ℝ D H) (I' : ModelWithCorners ℝ Z H') (J : ModelWithCorners ℝ G K)
+    [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y]
+    [TopologicalSpace N] [ChartedSpace K N] (f : X → N) (g : Y → N) (x : X) (y : Y) : Prop :=
+  g y = f x →
+    Function.Surjective ((mfderiv I J f x : D →L[ℝ] G).coprod (mfderiv I' J g y : Z →L[ℝ] G))
+
+private theorem Smale.NativeTransversality.at_iff_chart_difference {D Z G H H' K X Y N : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    [TopologicalSpace K] {I : ModelWithCorners ℝ D H} {I' : ModelWithCorners ℝ Z H'}
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace Y]
+    [ChartedSpace H' Y] [TopologicalSpace N] [ChartedSpace K N] {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {g : Y → N} {x : X}
+    {y : Y} (hf : MDifferentiableAt I J f x) (hg : MDifferentiableAt I' J g y) (hxy : g y = f x)
+    (hx : f x ∈ c.source) :
+    At I I' J f g x y ↔
+      Function.Surjective
+        (mfderiv (I.prod I') 𝓘(ℝ, F) (fun z : X × Y => c (g z.2) - c (f z.1)) (x, y)) := by
+  have hy : g y ∈ c.source := hxy ▸ hx
+  have hcf := (c.mdifferentiableAt (by simp) hx).comp x hf
+  have hcg := (c.mdifferentiableAt (by simp) hy).comp y hg
+  have hdiff := Smale.TransverseCoordinates.surjective_sheetDifference_iff hcf hcg
+  constructor
+  · intro ht
+    apply hdiff.mpr
+    exact Smale.ChartMapPerturbation.transverse_in_chart c hf hg hxy hx (ht hxy)
+  · intro h _
+    exact Smale.ChartMapPerturbation.transverse_of_chart c hf hg hxy hx (hdiff.mp h)
+
+private theorem Smale.NativeTransversality.isOpen_at_family {D Z G H H' K X Y N : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    [TopologicalSpace K] {I : ModelWithCorners ℝ D H} {I' : ModelWithCorners ℝ Z H'}
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace Y]
+    [ChartedSpace H' Y] [TopologicalSpace N] [ChartedSpace K N] {P : Type*} [NormedAddCommGroup P]
+    [NormedSpace ℝ P] [FiniteDimensional ℝ D] [FiniteDimensional ℝ Z] [FiniteDimensional ℝ G]
+    [I.Boundaryless] [I'.Boundaryless] [J.Boundaryless] [IsManifold I ∞ X] [IsManifold I' ∞ Y]
+    [IsManifold J ∞ N] [T2Space N] {f : P → X → N} {g : Y → N} {U : Set P} (hU : IsOpen U)
+    (hf : ContMDiffOn (𝓘(ℝ, P).prod I) J ∞ (Function.uncurry f) (U ×ˢ Set.univ))
+    (hg : ContMDiff I' J ∞ g)
+    (hdim : Module.finrank ℝ D + Module.finrank ℝ Z = Module.finrank ℝ G) :
+    IsOpen {r : P × (X × Y) | r.1 ∈ U ∧ At I I' J (f r.1) g r.2.1 r.2.2} := by
+  let W₀ : Set (P × (X × Y)) := U ×ˢ Set.univ
+  have hW₀ : IsOpen W₀ := hU.prod isOpen_univ
+  let F : P × (X × Y) → N := fun r => f r.1 r.2.1
+  let G' : P × (X × Y) → N := fun r => g r.2.2
+  have hF : ContMDiffOn (𝓘(ℝ, P).prod (I.prod I')) J ∞ F W₀ :=
+    hf.comp (contMDiff_fst.prodMk (contMDiff_fst.comp contMDiff_snd)).contMDiffOn
+      (fun _ hr => ⟨hr.1, Set.mem_univ _⟩)
+  have hG : ContMDiff (𝓘(ℝ, P).prod (I.prod I')) J ∞ G' :=
+    hg.comp (contMDiff_snd.comp contMDiff_snd)
+  have hslice (a : P) (x : X) (ha : a ∈ U) : ContMDiffAt I J ∞ (f a) x :=
+    (hf.contMDiffAt ((hU.prod isOpen_univ).mem_nhds ⟨ha, Set.mem_univ x⟩)).comp x
+      (contMDiffAt_const.prodMk contMDiffAt_id)
+  rw [isOpen_iff_mem_nhds]
+  rintro q ⟨hq, hqt⟩
+  have hq₀ : q ∈ W₀ := ⟨hq, Set.mem_univ _⟩
+  by_cases hcross : g q.2.2 = f q.1 q.2.1
+  · let c := NoExotic.modelChartPartialDiffeomorph (I := J) (f q.1 q.2.1)
+    have hqc : f q.1 q.2.1 ∈ c.source := mem_extChartAt_source _
+    have hqgc : g q.2.2 ∈ c.source := hcross ▸ hqc
+    let W : Set (P × (X × Y)) := (W₀ ∩ F ⁻¹' c.source) ∩ G' ⁻¹' c.source
+    have hW : IsOpen W :=
+      (hF.continuousOn.isOpen_inter_preimage hW₀ c.open_source).inter
+        (c.open_source.preimage hG.continuous)
+    let B : P → X × Y → G := fun a z => c (g z.2) - c (f a z.1)
+    have hB : ContMDiffOn (𝓘(ℝ, P).prod (I.prod I')) 𝓘(ℝ, G) ∞ (Function.uncurry B) W := by
+      intro r hr
+      have hfirst :
+        ContMDiffAt (𝓘(ℝ, P).prod (I.prod I')) 𝓘(ℝ, G) ∞ (fun s : P × (X × Y) => c (f s.1 s.2.1))
+          r :=
+        (c.contMDiffOn_toFun.contMDiffAt (c.open_source.mem_nhds hr.1.2)).comp r
+          (hF.contMDiffAt (hW₀.mem_nhds hr.1.1))
+      have hsecond :
+        ContMDiffAt (𝓘(ℝ, P).prod (I.prod I')) 𝓘(ℝ, G) ∞ (fun s : P × (X × Y) => c (g s.2.2)) r :=
+        (c.contMDiffOn_toFun.contMDiffAt (c.open_source.mem_nhds hr.2)).comp r hG.contMDiffAt
+      exact (hsecond.sub hfirst).contMDiffWithinAt
+    have hopen :=
+      Smale.NativeSubmersion.isOpen_surjective_nativeDerivative hW hB
+        (by simpa only [Module.finrank_prod] using hdim)
+    have hqB : Function.Surjective (mfderiv (I.prod I') 𝓘(ℝ, G) (B q.1) q.2) :=
+      (at_iff_chart_difference c ((hslice q.1 q.2.1 hq).mdifferentiableAt (by simp))
+            (hg.mdifferentiableAt (by simp)) hcross hqc).mp
+        hqt
+    have hn :=
+      hopen.mem_nhds
+        (show q ∈ {r | r ∈ W ∧ Function.Surjective (mfderiv (I.prod I') 𝓘(ℝ, G) (B r.1) r.2)} from
+          ⟨⟨⟨hq₀, hqc⟩, hqgc⟩, hqB⟩)
+    apply Filter.mem_of_superset hn
+    intro r hr
+    refine ⟨hr.1.1.1.1, ?_⟩
+    intro hxy
+    have ht :=
+      (at_iff_chart_difference c ((hslice r.1 r.2.1 hr.1.1.1.1).mdifferentiableAt (by simp))
+            (hg.mdifferentiableAt (by simp)) hxy hr.1.1.2).mpr
+        hr.2
+    exact ht hxy
+  · have hpair : ContinuousAt (fun r : P × (X × Y) => (G' r, F r)) q :=
+      hG.continuous.continuousAt.prodMk (hF.contMDiffAt (hW₀.mem_nhds hq₀)).continuousAt
+    have hne : IsOpen {z : N × N | z.1 ≠ z.2} := isOpen_ne_fun continuous_fst continuous_snd
+    have hn := hpair.preimage_mem_nhds (hne.mem_nhds hcross)
+    have hparam : ∀ᶠ r : P × (X × Y) in 𝓝 q, r.1 ∈ U :=
+      continuous_fst.continuousAt.preimage_mem_nhds (hU.mem_nhds hq)
+    apply Filter.mem_of_superset (Filter.inter_mem hparam hn)
+    intro r hr
+    refine ⟨hr.1, ?_⟩
+    intro hxy
+    exact False.elim (hr.2 hxy)
+
+private theorem Smale.NativeTransversality.eventually_on_compact {D Z G H H' K X Y N : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    [TopologicalSpace K] {I : ModelWithCorners ℝ D H} {I' : ModelWithCorners ℝ Z H'}
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace Y]
+    [ChartedSpace H' Y] [TopologicalSpace N] [ChartedSpace K N] {P : Type*} [NormedAddCommGroup P]
+    [NormedSpace ℝ P] [FiniteDimensional ℝ D] [FiniteDimensional ℝ Z] [FiniteDimensional ℝ G]
+    [I.Boundaryless] [I'.Boundaryless] [J.Boundaryless] [IsManifold I ∞ X] [IsManifold I' ∞ Y]
+    [IsManifold J ∞ N] [T2Space N] {f : P → X → N} {g : Y → N} {U : Set P} (hU : IsOpen U)
+    (hf : ContMDiffOn (𝓘(ℝ, P).prod I) J ∞ (Function.uncurry f) (U ×ˢ Set.univ))
+    (hg : ContMDiff I' J ∞ g)
+    (hdim : Module.finrank ℝ D + Module.finrank ℝ Z = Module.finrank ℝ G) {C : Set (X × Y)}
+    (hC : IsCompact C) {a : P} (ha : a ∈ U) (htrans : ∀ z ∈ C, At I I' J (f a) g z.1 z.2) :
+    ∀ᶠ b in 𝓝 a, ∀ z ∈ C, At I I' J (f b) g z.1 z.2 := by
+  have hopen :=
+    Smale.MorsePerturbation.isOpen_forall_mem_compact hC (isOpen_at_family hU hf hg hdim)
+  have hn := hopen.mem_nhds (fun z hz => ⟨ha, htrans z hz⟩)
+  filter_upwards [hn] with b hb z hz
+  exact (hb z hz).2
+
+private theorem Degree.TransverseGerms.native_transversality_partial_diffeomorph_iff
+    {A B Z E HA HB HZ HE X Y N M : Type*} [NormedAddCommGroup A] [NormedSpace ℝ A]
+    [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace HA] [TopologicalSpace HB]
+    [TopologicalSpace HZ] [TopologicalSpace HE] {I : ModelWithCorners ℝ A HA}
+    {I' : ModelWithCorners ℝ B HB} {J : ModelWithCorners ℝ Z HZ} {J' : ModelWithCorners ℝ E HE}
+    [TopologicalSpace X] [ChartedSpace HA X] [TopologicalSpace Y] [ChartedSpace HB Y]
+    [TopologicalSpace N] [ChartedSpace HZ N] [TopologicalSpace M] [ChartedSpace HE M]
+    (P : PartialDiffeomorph J J' N M ∞) {f : X → N} {g : Y → N} {x : X} {y : Y}
+    (hf : MDifferentiableAt I J f x) (hg : MDifferentiableAt I' J g y) (hxy : g y = f x)
+    (hx : f x ∈ P.source) :
+    Smale.NativeTransversality.At I I' J f g x y ↔
+      Smale.NativeTransversality.At I I' J' (P ∘ f) (P ∘ g) x y := by
+  let L : A →L[ℝ] Z := mfderiv I J f x
+  let R : B →L[ℝ] Z := mfderiv I' J g y
+  let C : Z →L[ℝ] E := mfderiv J J' P (f x)
+  have hy : g y ∈ P.source := hxy ▸ hx
+  have hL : (mfderiv I J' (P ∘ f) x : A →L[ℝ] E) = C.comp L :=
+    mfderiv_comp x (P.mdifferentiableAt (by simp) hx) hf
+  have hR : (mfderiv I' J' (P ∘ g) y : B →L[ℝ] E) = C.comp R := by
+    rw [mfderiv_comp y (P.mdifferentiableAt (by simp) hy) hg, hxy]
+    rfl
+  have hC : Function.Bijective C := Smale.PartialChart.bijective_mfderiv P hx
+  constructor
+  · intro ht _
+    have hsum : Function.Surjective (L.coprod R) := ht hxy
+    rw [hL, hR]
+    intro w
+    obtain ⟨z, hz⟩ := hC.surjective w
+    obtain ⟨v, hv⟩ := hsum z
+    refine ⟨v, ?_⟩
+    change C (L v.1) + C (R v.2) = w
+    rw [← C.map_add]
+    exact (congrArg C hv).trans hz
+  · intro ht _
+    have hsum := ht (show (P ∘ g) y = (P ∘ f) x from congrArg P hxy)
+    rw [hL, hR] at hsum
+    intro w
+    obtain ⟨v, hv⟩ := hsum (C w)
+    refine ⟨v, hC.injective ?_⟩
+    change C (L v.1 + R v.2) = C w
+    rw [C.map_add]
+    exact hv
+
+private theorem Smale.MorseHandle.ambientMap_lower_sphere {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ : ℝ} (hρ : 0 < ρ)
+    (u : Metric.sphere (0 : N) 1) (v : P) :
+    -‖(ambientMap ρ ((u : N), v)).1‖ ^ 2 + ‖(ambientMap ρ ((u : N), v)).2‖ ^ 2 = -(ρ ^ 2) := by
+  have hA : 0 < ρ * Real.sqrt (1 + ‖v‖ ^ 2) := mul_pos hρ (Real.sqrt_pos.mpr (by positivity))
+  simp only [ambientMap, norm_smul, Real.norm_eq_abs, abs_of_pos hA, abs_of_pos hρ,
+    mem_sphere_zero_iff_norm.mp u.property, mul_one, mul_pow,
+    Real.sq_sqrt (show 0 ≤ 1 + ‖v‖ ^ 2 by positivity)]
+  ring
+
+private theorem Smale.MorseHandle.ambientMap_sphere_mem_product {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ : ℝ} (hρ : 0 < ρ)
+    (u : Metric.sphere (0 : N) 1) (v : P) (hv : ‖v‖ ≤ (3 / 2 : ℝ)) :
+    ambientMap ρ ((u : N), v) ∈
+      Metric.closedBall (0 : N) (2 * ρ) ×ˢ Metric.closedBall (0 : P) (2 * ρ) := by
+  have hA : 0 < ρ * Real.sqrt (1 + ‖v‖ ^ 2) := mul_pos hρ (Real.sqrt_pos.mpr (by positivity))
+  have hs : Real.sqrt (1 + ‖v‖ ^ 2) ≤ 2 :=
+    Real.sqrt_le_iff.mpr ⟨by norm_num, by nlinarith [norm_nonneg v]⟩
+  constructor
+  · rw [mem_closedBall_zero_iff]
+    change ‖(ρ * Real.sqrt (1 + ‖v‖ ^ 2)) • (u : N)‖ ≤ 2 * ρ
+    rw [norm_smul, Real.norm_eq_abs, abs_of_pos hA, mem_sphere_zero_iff_norm.mp u.property,
+      mul_one]
+    calc
+      _ ≤ ρ * 2 := mul_le_mul_of_nonneg_left hs hρ.le
+      _ = _ := mul_comm _ _
+  · rw [mem_closedBall_zero_iff]
+    change ‖ρ • v‖ ≤ 2 * ρ
+    rw [norm_smul, Real.norm_eq_abs, abs_of_pos hρ]
+    have hm := mul_le_mul_of_nonneg_left hv hρ.le
+    linarith
+
+private theorem
+    Smale.MorseHandle.norm_ambientInverse_fst_of_lower {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ : ℝ} (hρ : 0 < ρ) (z : N × P)
+    (hz : -‖z.1‖ ^ 2 + ‖z.2‖ ^ 2 = -(ρ ^ 2)) : ‖(ambientInverse ρ z).1‖ = 1 := by
+  let A : ℝ := ρ * Real.sqrt (1 + ‖ρ⁻¹ • z.2‖ ^ 2)
+  have hA : 0 < A := mul_pos hρ (Real.sqrt_pos.mpr (by positivity))
+  have hA₂ : A ^ 2 = ρ ^ 2 + ‖z.2‖ ^ 2 := inverse_scale_sq hρ z.2
+  have hn : ‖z.1‖ = A := by nlinarith [norm_nonneg z.1]
+  change ‖A⁻¹ • z.1‖ = 1
+  rw [norm_smul, Real.norm_eq_abs, abs_of_pos (inv_pos.mpr hA), hn, inv_mul_cancel₀ hA.ne']
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    Smale.ManifoldMorse.SignedMorseChart.beltRawCoordinates {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ)
+    (z : Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates × c.NegativeCoordinates) :
+    c.NegativeCoordinates × c.PositiveCoordinates :=
+  (Smale.MorseHandle.ambientMap ρ ((z.1 : c.PositiveCoordinates), z.2)).swap
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.continuous_beltRawCoordinates {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ) :
+    Continuous (c.beltRawCoordinates ρ) :=
+  continuous_swap.comp
+    ((Smale.MorseHandle.ambientHomeomorph ρ hρ).continuous.comp
+      ((continuous_subtype_val.comp continuous_fst).prodMk continuous_snd))
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.SignedMorseChart.beltSource {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ) :
+    TopologicalSpace.Opens
+      (Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates × c.NegativeCoordinates) :=
+  ⟨c.beltRawCoordinates ρ ⁻¹' c.splitChart.target,
+    c.splitChart.open_target.preimage (c.continuous_beltRawCoordinates ρ hρ)⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.SignedMorseChart.beltTarget {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) :
+    TopologicalSpace.Opens { y : M // f y = f p + ρ ^ 2 } :=
+  ⟨Subtype.val ⁻¹' c.splitChart.source, c.splitChart.open_source.preimage continuous_subtype_val⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    Smale.ManifoldMorse.SignedMorseChart.beltNeighborhoodMap {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (z : c.beltSource ρ hρ) : c.beltTarget ρ :=
+  ⟨⟨c.splitChart.symm (c.beltRawCoordinates ρ z.val),
+      by
+      rw [c.splitChart_inverse_equation z.property]
+      have hh := Smale.MorseHandle.ambientMap_lower_sphere hρ z.val.1 z.val.2
+      change
+        -‖(c.beltRawCoordinates ρ z.val).2‖ ^ 2 + ‖(c.beltRawCoordinates ρ z.val).1‖ ^ 2 =
+          -(ρ ^ 2) at hh
+      linarith⟩,
+    c.splitChart.map_target' z.property⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.continuous_beltNeighborhoodMap {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ) :
+    Continuous (c.beltNeighborhoodMap ρ hρ) := by
+  have hc :
+    Continuous (fun z : c.beltSource ρ hρ => c.splitChart.symm (c.beltRawCoordinates ρ z.val)) :=
+    c.splitChart.contMDiffOn_invFun.continuousOn.comp_continuous
+      ((c.continuous_beltRawCoordinates ρ hρ).comp continuous_subtype_val) (fun z => z.property)
+  exact (hc.subtype_mk _).subtype_mk _
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.SignedMorseChart.beltInverseCoordinates {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (y : M) :
+    c.PositiveCoordinates × c.NegativeCoordinates :=
+  Smale.MorseHandle.ambientInverse ρ (c.splitChart y).swap
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SignedMorseChart.continuousOn_beltInverseCoordinates {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ) :
+    ContinuousOn (c.beltInverseCoordinates ρ) c.splitChart.source :=
+  (Smale.MorseHandle.ambientHomeomorph ρ hρ).symm.continuous.comp_continuousOn
+    (continuous_swap.comp_continuousOn c.splitChart.contMDiffOn_toFun.continuousOn)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SignedMorseChart.beltInverseCoordinates_neighborhoodMap {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (z : c.beltSource ρ hρ) :
+    c.beltInverseCoordinates ρ ((c.beltNeighborhoodMap ρ hρ z).val : M) =
+      ((z.val.1 : c.PositiveCoordinates), z.val.2) := by
+  have hr :
+    c.splitChart (c.splitChart.symm (c.beltRawCoordinates ρ z.val)) =
+      c.beltRawCoordinates ρ z.val :=
+    c.splitChart.right_inv' z.property
+  change
+    Smale.MorseHandle.ambientInverse ρ
+        (c.splitChart (c.splitChart.symm (c.beltRawCoordinates ρ z.val))).swap =
+      _
+  rw [hr]
+  exact Smale.MorseHandle.ambientInverse_ambientMap hρ _
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.norm_beltInverseCoordinates_fst {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (y : { y : M // f y = f p + ρ ^ 2 }) (hy : (y : M) ∈ c.splitChart.source) :
+    ‖(c.beltInverseCoordinates ρ y).1‖ = 1 := by
+  apply Smale.MorseHandle.norm_ambientInverse_fst_of_lower hρ
+  have hh := c.splitChart_equation hy
+  rw [y.property] at hh
+  change -‖(c.splitChart (y : M)).2‖ ^ 2 + ‖(c.splitChart (y : M)).1‖ ^ 2 = -(ρ ^ 2)
+  linarith
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.SignedMorseChart.beltNeighborhoodInverse {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (y : c.beltTarget ρ) : c.beltSource ρ hρ := by
+  let v : Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates :=
+    ⟨(c.beltInverseCoordinates ρ (y.val : M)).1,
+      mem_sphere_zero_iff_norm.mpr (c.norm_beltInverseCoordinates_fst ρ hρ y.val y.property)⟩
+  refine ⟨(v, (c.beltInverseCoordinates ρ (y.val : M)).2), ?_⟩
+  change
+    (Smale.MorseHandle.ambientMap ρ
+          (Smale.MorseHandle.ambientInverse ρ (c.splitChart (y.val : M)).swap)).swap ∈
+      c.splitChart.target
+  rw [Smale.MorseHandle.ambientMap_ambientInverse hρ, Prod.swap_swap]
+  exact c.splitChart.map_source' y.property
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SignedMorseChart.continuous_beltNeighborhoodInverse {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ) :
+    Continuous (c.beltNeighborhoodInverse ρ hρ) := by
+  have hc : Continuous (fun y : c.beltTarget ρ => c.beltInverseCoordinates ρ (y.val : M)) :=
+    (c.continuousOn_beltInverseCoordinates ρ hρ).comp_continuous
+      (continuous_subtype_val.comp continuous_subtype_val) (fun y => y.property)
+  exact ((hc.fst.subtype_mk _).prodMk hc.snd).subtype_mk _
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.SignedMorseChart.beltNeighborhoodHomeomorph {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ) :
+    c.beltSource ρ hρ ≃ₜ c.beltTarget ρ
+    where
+  toFun := c.beltNeighborhoodMap ρ hρ
+  invFun := c.beltNeighborhoodInverse ρ hρ
+  left_inv
+    z := by
+    apply Subtype.ext
+    apply Prod.ext
+    · exact Subtype.ext (congrArg Prod.fst (c.beltInverseCoordinates_neighborhoodMap ρ hρ z))
+    · exact
+        congrArg (fun w : c.PositiveCoordinates × c.NegativeCoordinates => w.2)
+          (c.beltInverseCoordinates_neighborhoodMap ρ hρ z)
+  right_inv
+    y := by
+    apply Subtype.ext
+    apply Subtype.ext
+    change
+      c.splitChart.symm
+          (Smale.MorseHandle.ambientMap ρ
+              (Smale.MorseHandle.ambientInverse ρ (c.splitChart (y.val : M)).swap)).swap =
+        (y.val : M)
+    rw [Smale.MorseHandle.ambientMap_ambientInverse hρ, Prod.swap_swap]
+    exact c.splitChart.left_inv' y.property
+  continuous_toFun := c.continuous_beltNeighborhoodMap ρ hρ
+  continuous_invFun := c.continuous_beltNeighborhoodInverse ρ hρ
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.SignedMorseChart.enlarged_closed_belt_subset_source {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+        c.splitChart.target) :
+    (Set.univ : Set (Smale.PuncturedHandle.UnitSphere c.PositiveCoordinates)) ×ˢ
+        Metric.closedBall (0 : c.NegativeCoordinates) (3 / 2 : ℝ) ⊆
+      c.beltSource ρ hρ := by
+  rintro ⟨v, u⟩ ⟨_, hu⟩
+  have hh :=
+    Smale.MorseHandle.ambientMap_sphere_mem_product hρ v u (mem_closedBall_zero_iff.mp hu)
+  exact hblock ⟨hh.2, hh.1⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.SignedMorseChart.beltNeighborhoodHomeomorph_normal {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (ρ : ℝ) (hρ : 0 < ρ)
+    (z : c.beltSource ρ hρ) :
+    (c.splitChart ((c.beltNeighborhoodHomeomorph ρ hρ z).val : M)).1 = ρ • z.val.2 := by
+  have hr :
+    c.splitChart (c.splitChart.symm (c.beltRawCoordinates ρ z.val)) =
+      c.beltRawCoordinates ρ z.val :=
+    c.splitChart.right_inv' z.property
+  change (c.splitChart (c.splitChart.symm (c.beltRawCoordinates ρ z.val))).1 = _
+  rw [hr]
+  rfl
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    Smale.ManifoldMorse.MorseSurgeryData.beltNormalDomain {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) : Set d.UpperLevel :=
+  (Subtype.val : d.UpperLevel → M) ⁻¹' d.chart.splitChart.source
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.MorseSurgeryData.beltNormal {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) :
+    d.UpperLevel → d.chart.NegativeCoordinates := fun x => (d.chart.splitChart (x : M)).1
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.isOpen_beltNormalDomain {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) : IsOpen d.beltNormalDomain :=
+  d.chart.splitChart.open_source.preimage continuous_subtype_val
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.belt_model_mem_target {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (v : Smale.PuncturedHandle.UnitSphere d.chart.PositiveCoordinates) :
+    (0, d.radius • (v : d.chart.PositiveCoordinates)) ∈ d.chart.splitChart.target := by
+  apply d.block
+  constructor
+  · simpa only [Metric.mem_closedBall, dist_self] using
+      (mul_nonneg (by norm_num : (0 : ℝ) ≤ 2) d.radius_pos.le)
+  · have hv : ‖(v : d.chart.PositiveCoordinates)‖ = 1 := mem_sphere_zero_iff_norm.mp v.property
+    simp only [Metric.mem_closedBall, dist_zero_right, norm_smul, Real.norm_eq_abs,
+      abs_of_pos d.radius_pos, hv, mul_one]
+    linarith [d.radius_pos]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.belt_mem_normalDomain {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (v : Smale.PuncturedHandle.UnitSphere d.chart.PositiveCoordinates) :
+    d.surgery.beltSphere v ∈ d.beltNormalDomain := by
+  change (d.surgery.beltSphere v : M) ∈ d.chart.splitChart.source
+  rw [d.belt_eq, d.chart.beltCoreMap_coe]
+  exact d.chart.splitChart.map_target' (d.belt_model_mem_target v)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.belt_split_coordinates {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (v : Smale.PuncturedHandle.UnitSphere d.chart.PositiveCoordinates) :
+    d.chart.splitChart (d.surgery.beltSphere v : M) =
+      (0, d.radius • (v : d.chart.PositiveCoordinates)) := by
+  rw [d.belt_eq, d.chart.beltCoreMap_coe]
+  exact d.chart.splitChart.right_inv' (d.belt_model_mem_target v)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.beltNormal_belt {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (v : Smale.PuncturedHandle.UnitSphere d.chart.PositiveCoordinates) :
+    d.beltNormal (d.surgery.beltSphere v) = 0 := by
+  change (d.chart.splitChart (d.surgery.beltSphere v : M)).1 = 0
+  rw [d.belt_split_coordinates]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.beltNormal_eq_zero_iff {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) {x : d.UpperLevel}
+    (hx : x ∈ d.beltNormalDomain) : d.beltNormal x = 0 ↔ x ∈ Set.range d.surgery.beltSphere := by
+  constructor
+  · intro hzero
+    let z := d.chart.splitChart (x : M)
+    have hz₁ : z.1 = 0 := hzero
+    have heq := d.chart.splitChart_equation hx
+    change f (x : M) = f p - ‖z.1‖ ^ 2 + ‖z.2‖ ^ 2 at heq
+    rw [hz₁, norm_zero, zero_pow (by decide : 2 ≠ 0), sub_zero, x.property] at heq
+    have hnorm : ‖z.2‖ = d.radius := by nlinarith [norm_nonneg z.2, d.radius_pos]
+    let v : Smale.PuncturedHandle.UnitSphere d.chart.PositiveCoordinates :=
+      ⟨d.radius⁻¹ • z.2, by
+        rw [mem_sphere_zero_iff_norm, norm_smul, Real.norm_eq_abs,
+          abs_of_pos (inv_pos.mpr d.radius_pos), hnorm, inv_mul_cancel₀ d.radius_pos.ne']⟩
+    refine ⟨v, Subtype.ext ?_⟩
+    rw [d.belt_eq, d.chart.beltCoreMap_coe]
+    change d.chart.splitChart.symm (0, d.radius • (d.radius⁻¹ • z.2)) = (x : M)
+    rw [smul_smul, mul_inv_cancel₀ d.radius_pos.ne', one_smul]
+    have hz : (0, z.2) = z := Prod.ext hz₁.symm rfl
+    rw [hz]
+    exact d.chart.splitChart.left_inv' hx
+  · rintro ⟨v, rfl⟩
+    exact d.beltNormal_belt v
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.contMDiffOn_beltNormal {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    ContMDiffOn 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, d.chart.NegativeCoordinates) ∞ d.beltNormal
+      d.beltNormalDomain := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  have hcoords :
+    ContMDiffOn 𝓘(ℝ, Smale.RegularLevel.Model E)
+      𝓘(ℝ, d.chart.NegativeCoordinates × d.chart.PositiveCoordinates) ∞
+      (d.chart.splitChart ∘ (Subtype.val : d.UpperLevel → M)) d.beltNormalDomain :=
+    d.chart.splitChart.contMDiffOn_toFun.comp
+      (Smale.RegularLevel.contMDiff_inclusion hf d.upper_regular).contMDiffOn (fun _ hx => hx)
+  exact contDiff_fst.contMDiff.comp_contMDiffOn hcoords
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.beltNormal_derivative_comp_belt {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (n : ℕ)
+    [Fact (Module.finrank ℝ d.chart.PositiveCoordinates = n + 1)]
+    (v : Smale.PuncturedHandle.UnitSphere d.chart.PositiveCoordinates) :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    (mfderiv 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, d.chart.NegativeCoordinates) d.beltNormal
+            (d.surgery.beltSphere v)).comp
+        (mfderiv (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) d.surgery.beltSphere v) =
+      0 := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  have hnormal :=
+    (d.contMDiffOn_beltNormal hf).contMDiffAt
+      (d.isOpen_beltNormalDomain.mem_nhds (d.belt_mem_normalDomain v))
+  have heq : d.beltNormal ∘ d.surgery.beltSphere = fun _ => 0 := funext d.beltNormal_belt
+  have hzero :
+    mfderiv (𝓡 n) 𝓘(ℝ, d.chart.NegativeCoordinates) (d.beltNormal ∘ d.surgery.beltSphere) v = 0 :=
+    by rw [heq, mfderiv_const]
+  have hchain :=
+    mfderiv_comp v (hnormal.mdifferentiableAt (by simp))
+      ((d.belt_smooth hf n).mdifferentiableAt (by simp))
+  exact hchain.symm.trans hzero
+
+private def
+    Smale.NativeParametrization.translation {D : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D]
+    (a : D) : Diffeomorph 𝓘(ℝ, D) 𝓘(ℝ, D) D D ∞
+    where
+  toEquiv :=
+    { toFun := fun x => x + a
+      invFun := fun x => x - a
+      left_inv := fun _ => add_sub_cancel_right _ _
+      right_inv := fun _ => sub_add_cancel _ _ }
+  contMDiff_toFun := (contDiff_id.add contDiff_const).contMDiff
+  contMDiff_invFun := (contDiff_id.sub contDiff_const).contMDiff
+
+private def
+    Smale.NativeParametrization.centered {D : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D]
+    {N : Type*} [TopologicalSpace N] [ChartedSpace D N] [IsManifold 𝓘(ℝ, D) ∞ N] (x : N) :
+    PartialDiffeomorph 𝓘(ℝ, D) 𝓘(ℝ, D) D N ∞ :=
+  let c := NoExotic.modelChartPartialDiffeomorph (I := 𝓘(ℝ, D)) x
+  (translation (c x)).toPartialDiffeomorph.trans c.symm
+
+private theorem
+    Smale.NativeParametrization.zero_mem_centered_source {D : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] {N : Type*} [TopologicalSpace N] [ChartedSpace D N] [IsManifold 𝓘(ℝ, D) ∞ N]
+    (x : N) : (0 : D) ∈ (centered (D := D) x).source := by
+  let c := NoExotic.modelChartPartialDiffeomorph (I := 𝓘(ℝ, D)) x
+  refine ⟨Set.mem_univ _, ?_⟩
+  change 0 + c x ∈ c.target
+  rw [zero_add]
+  exact c.map_source' (mem_extChartAt_source x)
+
+private theorem Smale.NativeParametrization.centered_zero {D : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] {N : Type*} [TopologicalSpace N] [ChartedSpace D N] [IsManifold 𝓘(ℝ, D) ∞ N]
+    (x : N) : centered (D := D) x (0 : D) = x := by
+  let c := NoExotic.modelChartPartialDiffeomorph (I := 𝓘(ℝ, D)) x
+  change c.symm (0 + c x) = x
+  rw [zero_add]
+  exact c.left_inv' (mem_extChartAt_source x)
+
+private theorem Smale.NativeParametrization.mem_centered_target {D : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] {N : Type*} [TopologicalSpace N] [ChartedSpace D N] [IsManifold 𝓘(ℝ, D) ∞ N]
+    (x : N) : x ∈ (centered (D := D) x).target := by
+  have hx := (centered (D := D) x).map_source' (zero_mem_centered_source (D := D) x)
+  rwa [centered_zero] at hx
+
+private theorem Smale.SupportedDiffeomorph.SupportedRelativeIsotopy.mapsTo_superset {E H X : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [TopologicalSpace X] [ChartedSpace H X] {e : Diffeomorph I I X X ∞} {K S : Set X}
+    (A : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy e K S) {U : Set X} (hKU : K ⊆ U)
+    (t : ℝ) : Set.MapsTo (fun x => A.family (t, x)) U U := by
+  obtain ⟨d, hd⟩ := A.slices t
+  have hfix : ∀ x ∉ U, d x = x := by
+    intro x hx
+    exact (hd x).trans (A.fixedOutside t x (fun h => hx (hKU h)))
+  intro x hx
+  change A.family (t, x) ∈ U
+  rw [← hd]
+  exact Smale.SupportedDiffeomorph.mapsTo_of_fixed_outside d.toEquiv hfix hx
+
+private def Smale.SupportedDiffeomorph.SupportedRelativeIsotopy.extension {E F H H' X Y : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H'] {J : ModelWithCorners ℝ F H'}
+    [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y] [T2Space Y]
+    {e : Diffeomorph I I X X ∞} {K S : Set X}
+    (A : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy e K S)
+    (Φ : PartialDiffeomorph I J X Y ∞) (hK : IsCompact K) (hKsource : K ⊆ Φ.source) {T : Set Y}
+    (hfixed : ∀ x ∈ Φ.source, Φ x ∈ T → x ∈ S) :
+    Smale.SupportedDiffeomorph.SupportedRelativeIsotopy
+      (Smale.SupportedDiffeomorph.extension Φ e hK hKsource A.endpoint_fixed_outside) (Φ '' K) T
+    where
+  family := fun p => Smale.SupportedDiffeomorph.extendMap Φ (fun x => A.family (p.1, x)) p.2
+  smooth :=
+    Smale.SupportedDiffeomorph.contMDiff_extendFamily Φ A.smooth hK hKsource A.fixedOutside
+      (A.mapsTo_superset hKsource)
+  zero := by
+    intro y
+    have heq : (fun x => A.family (0, x)) = id := funext A.zero
+    rw [heq]
+    exact Smale.SupportedDiffeomorph.extendMap_id Φ y
+  one := by
+    intro y
+    exact congrArg (fun f : X → X => Smale.SupportedDiffeomorph.extendMap Φ f y) (funext A.one)
+  slices := by
+    intro t
+    obtain ⟨d, hd⟩ := A.slices t
+    have hfix : ∀ x ∉ K, d x = x := fun x hx => (hd x).trans (A.fixedOutside t x hx)
+    exact
+      ⟨Smale.SupportedDiffeomorph.extension Φ d hK hKsource hfix, fun y =>
+        congrArg (fun f : X → X => Smale.SupportedDiffeomorph.extendMap Φ f y) (funext hd)⟩
+  fixedOutside := fun t y hy =>
+    Smale.SupportedDiffeomorph.extendMap_eq_of_notMem_image Φ (A.fixedOutside t) hy
+  fixedOn := by
+    intro t y hy
+    by_cases hyt : y ∈ Φ.target
+    · rw [Smale.SupportedDiffeomorph.extendMap_of_mem Φ _ hyt]
+      have hsource : Φ.symm y ∈ Φ.source := Φ.map_target' hyt
+      have hi : Φ (Φ.symm y) = y := Φ.right_inv' hyt
+      have hs : Φ.symm y ∈ S := hfixed (Φ.symm y) hsource (hi.symm ▸ hy)
+      rw [A.fixedOn t (Φ.symm y) hs]
+      exact hi
+    · exact Smale.SupportedDiffeomorph.extendMap_of_notMem Φ _ hyt
+
+private def Smale.SupportedDiffeomorph.normalBumpFamily {E F H M P : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ F H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) J E M ∞) (β : E → ℝ) (b : P → E) (p : ℝ × (M × P)) : M × P :=
+  (bumpFamily Φ β (-(Real.smoothTransition p.1 • b p.2.2), p.2.1), p.2.2)
+
+private theorem Smale.SupportedDiffeomorph.normalBumpFamily_normal {E F H M P : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ F H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) J E M ∞) (β : E → ℝ) (b : P → E) (t : ℝ) (z : M × P) :
+    (normalBumpFamily Φ β b (t, z)).2 = z.2 :=
+  rfl
+
+private theorem Smale.SupportedDiffeomorph.normalBumpFamily_zero {E F H M P : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ F H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) J E M ∞) (β : E → ℝ) (b : P → E) (z : M × P) :
+    normalBumpFamily Φ β b (0, z) = z := by
+  apply Prod.ext
+  · change bumpFamily Φ β (-(Real.smoothTransition 0 • b z.2), z.1) = z.1
+    rw [Real.smoothTransition.zero, zero_smul, neg_zero, bumpFamily_zero]
+  · rfl
+
+private theorem Smale.SupportedDiffeomorph.normalBumpFamily_fixed_fiber {E F H M P : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ F H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) J E M ∞) (β : E → ℝ) (b : P → E) {u : P} (hu : b u = 0)
+    (t : ℝ) (x : M) : normalBumpFamily Φ β b (t, (x, u)) = (x, u) := by
+  apply Prod.ext
+  · change bumpFamily Φ β (-(Real.smoothTransition t • b u), x) = x
+    rw [hu, smul_zero, neg_zero, bumpFamily_zero]
+  · rfl
+
+private theorem Smale.SupportedDiffeomorph.normalBumpFamily_fixed_outside {E F H M P : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ F H} [TopologicalSpace M] [ChartedSpace H M]
+    [NormedAddCommGroup P] (Φ : PartialDiffeomorph 𝓘(ℝ, E) J E M ∞) (β : E → ℝ) (b : P → E)
+    (t : ℝ) (z : M × P) (hz : z ∉ (Φ '' tsupport β) ×ˢ tsupport b) :
+    normalBumpFamily Φ β b (t, z) = z := by
+  by_cases hu : z.2 ∈ tsupport b
+  · have hx : z.1 ∉ Φ '' tsupport β := fun hx => hz ⟨hx, hu⟩
+    exact Prod.ext (bumpFamily_fixed_outside Φ β _ hx) rfl
+  · have hb : b z.2 = 0 := by
+      by_contra hb
+      exact hu (subset_tsupport b hb)
+    exact normalBumpFamily_fixed_fiber Φ β b hb t z.1
+
+private theorem Smale.SupportedDiffeomorph.normalBumpFamily_chart {E F H M P : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ F H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, E) J E M ∞) (β : E → ℝ) (b : P → E) {x : E} (hx : x ∈ Φ.source)
+    (u : P) : normalBumpFamily Φ β b (1, (Φ x, u)) = (Φ (x - β x • b u), u) := by
+  apply Prod.ext
+  · change bumpFamily Φ β (-(Real.smoothTransition 1 • b u), Φ x) = _
+    rw [Real.smoothTransition.one, one_smul, bumpFamily_chart Φ β _ hx, smul_neg, ←
+      sub_eq_add_neg]
+  · rfl
+
+private theorem Smale.SupportedDiffeomorph.exists_radius_normalBumpFamily {E F H M P : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ F H} [TopologicalSpace M] [ChartedSpace H M]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] (Φ : PartialDiffeomorph 𝓘(ℝ, E) J E M ∞)
+    [FiniteDimensional ℝ E] [FiniteDimensional ℝ F] [FiniteDimensional ℝ P] [J.Boundaryless]
+    [IsManifold J ∞ M] [T2Space M] {β : E → ℝ} (hβ : ContDiff ℝ ∞ β)
+    (hcompact : HasCompactSupport β) (hsupport : tsupport β ⊆ Φ.source) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∀ b : P → E,
+          ContDiff ℝ ∞ b →
+            HasCompactSupport b →
+              (∀ u, ‖b u‖ < ε) →
+                ContMDiff (𝓘(ℝ, ℝ).prod (J.prod 𝓘(ℝ, P))) (J.prod 𝓘(ℝ, P)) ∞
+                    (normalBumpFamily Φ β b) ∧
+                  (∀ t,
+                      ∃ D : Diffeomorph (J.prod 𝓘(ℝ, P)) (J.prod 𝓘(ℝ, P)) (M × P) (M × P) ∞,
+                        ∀ z, D z = normalBumpFamily Φ β b (t, z)) ∧
+                    IsCompact ((Φ '' tsupport β) ×ˢ tsupport b) := by
+  obtain ⟨ε, hε, hdiff, hsmooth, -⟩ := exists_radius_ambient_bumpFamily Φ hβ hcompact hsupport
+  refine ⟨ε, hε, ?_⟩
+  intro b hb hbcompact hbound
+  have hsmall (t : ℝ) (u : P) : ‖-(Real.smoothTransition t • b u)‖ < ε := by
+    rw [norm_neg, norm_smul, Real.norm_eq_abs, abs_of_nonneg (Real.smoothTransition.nonneg t)]
+    exact
+      (mul_le_of_le_one_left (norm_nonneg (b u)) (Real.smoothTransition.le_one t)).trans_lt
+        (hbound u)
+  have hθ : ContMDiff 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) ∞ Real.smoothTransition :=
+    (Real.smoothTransition.contDiff (n := ⊤)).contMDiff
+  have hvec :
+    ContMDiff (𝓘(ℝ, ℝ).prod (J.prod 𝓘(ℝ, P))) 𝓘(ℝ, E) ∞
+      (fun p : ℝ × (M × P) => Real.smoothTransition p.1 • b p.2.2) :=
+    (hθ.comp contMDiff_fst).smul (hb.contMDiff.comp (contMDiff_snd.comp contMDiff_snd))
+  have hneg :
+    ContMDiff (𝓘(ℝ, ℝ).prod (J.prod 𝓘(ℝ, P))) 𝓘(ℝ, E) ∞
+      (fun p : ℝ × (M × P) => -(Real.smoothTransition p.1 • b p.2.2)) :=
+    (show ContDiff ℝ ∞ (fun x : E => -x) from contDiff_neg).contMDiff.comp hvec
+  have hparam :
+    ContMDiff (𝓘(ℝ, ℝ).prod (J.prod 𝓘(ℝ, P))) (𝓘(ℝ, E).prod J) ∞
+      (fun p : ℝ × (M × P) => (-(Real.smoothTransition p.1 • b p.2.2), p.2.1)) :=
+    hneg.prodMk (contMDiff_fst.comp contMDiff_snd)
+  have hfirst :
+    ContMDiff (𝓘(ℝ, ℝ).prod (J.prod 𝓘(ℝ, P))) J ∞
+      (fun p : ℝ × (M × P) => bumpFamily Φ β (-(Real.smoothTransition p.1 • b p.2.2), p.2.1)) := by
+    intro p
+    exact (hsmooth _ (hsmall p.1 p.2.2)).comp p hparam.contMDiffAt
+  refine ⟨hfirst.prodMk (contMDiff_snd.comp contMDiff_snd), ?_, ?_⟩
+  · intro t
+    have ht :
+      ContMDiff (J.prod 𝓘(ℝ, P)) J ∞
+        (fun z : M × P => bumpFamily Φ β (-(Real.smoothTransition t • b z.2), z.1)) :=
+      hfirst.comp (contMDiff_const.prodMk contMDiff_id)
+    have hslices :
+      ∀ u : P,
+        ∃ D : Diffeomorph J J M M ∞,
+          ∀ x, D x = bumpFamily Φ β (-(Real.smoothTransition t • b u), x) :=
+      fun u => hdiff _ (hsmall t u)
+    exact ⟨Smale.FiberwiseDiffeomorph.diffeomorph ht hslices, fun _ => rfl⟩
+  · exact
+      (hcompact.isCompact.image_of_continuousOn
+            (Φ.contMDiffOn_toFun.continuousOn.mono hsupport)).prod
+        hbcompact.isCompact
+
+private theorem
+    Smale.exists_small_supported_germ {P E : Type*} [NormedAddCommGroup P] [NormedSpace ℝ P]
+    [FiniteDimensional ℝ P] [NormedAddCommGroup E] [NormedSpace ℝ E] {L : P → E} {U : Set P}
+    (hU : IsOpen U) (hzero : (0 : P) ∈ U) (hL : ContDiffOn ℝ ∞ L U) (hLzero : L 0 = 0) {ε : ℝ}
+    (hε : 0 < ε) :
+    ∃ b : P → E,
+      ContDiff ℝ ∞ b ∧
+        HasCompactSupport b ∧ tsupport b ⊆ U ∧ (∀ u, ‖b u‖ < ε) ∧ b =ᶠ[𝓝 (0 : P)] L ∧ b 0 = 0 := by
+  let V : Set P := U ∩ L ⁻¹' Metric.ball (0 : E) ε
+  have hV : IsOpen V := hL.continuousOn.isOpen_inter_preimage hU Metric.isOpen_ball
+  have hzeroV : (0 : P) ∈ V := ⟨hzero, by simpa [hLzero] using hε⟩
+  obtain ⟨β, hβ, hβcompact, hβsupport, hβone, hβrange⟩ :=
+    exists_compact_smooth_cutoff isCompact_singleton hV (Set.singleton_subset_iff.mpr hzeroV)
+  let b : P → E := fun u => β u • L u
+  have hfix (u : P) (hu : u ∉ tsupport β) : β u = 0 := by
+    by_contra hne
+    exact hu (subset_tsupport β hne)
+  have hsmooth : ContDiff ℝ ∞ b := by
+    apply contDiff_iff_contDiffAt.mpr
+    intro u
+    by_cases hu : u ∈ U
+    · exact hβ.contDiffAt.smul (hL.contDiffAt (hU.mem_nhds hu))
+    · have hnot : u ∉ tsupport β := fun h => hu (hβsupport h).1
+      have hc : ContDiffAt ℝ ∞ (fun _ : P => (0 : E)) u := contDiffAt_const
+      apply hc.congr_of_eventuallyEq
+      filter_upwards [(isClosed_tsupport β).isOpen_compl.mem_nhds hnot] with v hv
+      change β v • L v = 0
+      rw [hfix v hv, zero_smul]
+  have hsupport : tsupport b ⊆ tsupport β := by
+    apply closure_mono
+    intro u hu hβu
+    apply hu
+    change β u • L u = 0
+    rw [hβu, zero_smul]
+  have hcompact : HasCompactSupport b :=
+    HasCompactSupport.intro hβcompact.isCompact
+      (fun u hu => by change β u • L u = 0; rw [hfix u hu, zero_smul])
+  have hsmall (u : P) : ‖b u‖ < ε := by
+    by_cases hu : u ∈ tsupport β
+    · have hLu : ‖L u‖ < ε := mem_ball_zero_iff.mp (hβsupport hu).2
+      change ‖β u • L u‖ < ε
+      rw [norm_smul, Real.norm_eq_abs, abs_of_nonneg (hβrange u).1]
+      exact (mul_le_of_le_one_left (norm_nonneg (L u)) (hβrange u).2).trans_lt hLu
+    · change ‖β u • L u‖ < ε
+      rw [hfix u hu, zero_smul, norm_zero]
+      exact hε
+  have hgerm : b =ᶠ[𝓝 (0 : P)] L := by
+    filter_upwards [hβone.filter_mono (nhds_le_nhdsSet (Set.mem_singleton (0 : P)))] with u hu
+    change β u • L u = L u
+    rw [hu, one_smul]
+  exact
+    ⟨b, hsmooth, hcompact, hsupport.trans (hβsupport.trans Set.inter_subset_left), hsmall, hgerm,
+      hgerm.eq_of_nhds.trans hLzero⟩
+
+private theorem Smale.SupportedDiffeomorph.exists_supported_shear_isotopy {E F : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [FiniteDimensional ℝ F] (L : F →L[ℝ] E) {U : Set (E × F)} (hU : IsOpen U)
+    (hzero : (0 : E × F) ∈ U) :
+    ∃ (A : ℝ × (E × F) → E × F) (K : Set (E × F)),
+      IsCompact K ∧
+        K ⊆ U ∧
+          ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, E × F)) 𝓘(ℝ, E × F) ∞ A ∧
+            (∀ p, A (0, p) = p) ∧
+              (∀ t,
+                  ∃ D : Diffeomorph 𝓘(ℝ, E × F) 𝓘(ℝ, E × F) (E × F) (E × F) ∞,
+                    ∀ p, D p = A (t, p)) ∧
+                (∀ t p, p ∉ K → A (t, p) = p) ∧
+                  (∀ t p, (A (t, p)).2 = p.2) ∧
+                    (∀ t x, A (t, (x, (0 : F))) = (x, 0)) ∧
+                      (fun p => A (1, p)) =ᶠ[𝓝 (0 : E × F)] (fun p => (p.1 + L p.2, p.2)) := by
+  obtain ⟨ρ, hρ, hρU⟩ := Metric.mem_nhds_iff.mp (hU.mem_nhds hzero)
+  obtain ⟨β, hβ, hβcompact, hβsupport, hβone, -⟩ :=
+    Smale.exists_compact_smooth_cutoff (K := {(0 : E)}) isCompact_singleton Metric.isOpen_ball
+      (Set.singleton_subset_iff.mpr (Metric.mem_ball_self hρ))
+  let Φ := (Diffeomorph.refl 𝓘(ℝ, E) E ∞).toPartialDiffeomorph
+  obtain ⟨ε, hε, hfamily⟩ :=
+    exists_radius_normalBumpFamily (P := F) Φ hβ hβcompact
+      (show tsupport β ⊆ Φ.source from Set.subset_univ _)
+  obtain ⟨b, hb, hbcompact, hbsupport, hbsmall, hbeq, hbzero⟩ :=
+    Smale.exists_small_supported_germ Metric.isOpen_ball (Metric.mem_ball_self hρ)
+      (show ContDiffOn ℝ ∞ (fun y : F => -(L y)) (Metric.ball 0 ρ) from L.contDiff.neg.contDiffOn)
+      (show -(L (0 : F)) = 0 by simp) hε
+  obtain ⟨hAprod, hdiffprod, hK⟩ := hfamily b hb hbcompact hbsmall
+  let A := normalBumpFamily Φ β b
+  let K : Set (E × F) := (Φ '' tsupport β) ×ˢ tsupport b
+  let V := Smale.PartialChart.vectorProduct E F
+  have hA : ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, E × F)) 𝓘(ℝ, E × F) ∞ A :=
+    V.symm.contMDiff.comp (hAprod.comp (contMDiff_fst.prodMk (V.contMDiff.comp contMDiff_snd)))
+  have hdiff (t : ℝ) :
+    ∃ D : Diffeomorph 𝓘(ℝ, E × F) 𝓘(ℝ, E × F) (E × F) (E × F) ∞, ∀ p, D p = A (t, p) := by
+    obtain ⟨D, hD⟩ := hdiffprod t
+    exact ⟨(V.trans D).trans V.symm, hD⟩
+  have hKU : K ⊆ U := by
+    rintro ⟨x, y⟩ ⟨⟨w, hw, rfl⟩, hy⟩
+    apply hρU
+    change (w, y) ∈ Metric.ball (0 : E × F) ρ
+    rw [mem_ball_zero_iff, Prod.norm_def, max_lt_iff]
+    exact ⟨mem_ball_zero_iff.mp (hβsupport hw), mem_ball_zero_iff.mp (hbsupport hy)⟩
+  have hplateau : ∀ᶠ x in 𝓝 (0 : E), β x = 1 :=
+    hβone.filter_mono (nhds_le_nhdsSet (Set.mem_singleton (0 : E)))
+  have hfirst : ∀ᶠ p in 𝓝 (0 : E × F), β p.1 = 1 := (continuous_fst.tendsto (0 : E × F)) hplateau
+  have hsecond : ∀ᶠ p in 𝓝 (0 : E × F), b p.2 = -(L p.2) :=
+    (continuous_snd.tendsto (0 : E × F)) hbeq
+  refine
+    ⟨A, K, hK, hKU, hA, normalBumpFamily_zero Φ β b, hdiff, normalBumpFamily_fixed_outside Φ β b,
+      normalBumpFamily_normal Φ β b, fun t x => normalBumpFamily_fixed_fiber Φ β b hbzero t x, ?_⟩
+  filter_upwards [hfirst, hsecond] with p hp₁ hp₂
+  have hh := normalBumpFamily_chart Φ β b (show p.1 ∈ Φ.source from Set.mem_univ _) p.2
+  change A (1, p) = (p.1 - β p.1 • b p.2, p.2) at hh
+  rwa [hp₁, one_smul, hp₂, sub_neg_eq_add] at hh
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Recognition/Smale5.lean b/LeanPool/HopfProblem/Recognition/Smale5.lean
new file mode 100644
index 000000000..cc76f7dac
--- /dev/null
+++ b/LeanPool/HopfProblem/Recognition/Smale5.lean
@@ -0,0 +1,5627 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import all LeanPool.HopfProblem.Recognition.Smale1
+import all LeanPool.HopfProblem.Recognition.Smale2
+import all LeanPool.HopfProblem.Recognition.Smale3
+import all LeanPool.HopfProblem.Recognition.Smale4
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+
+/-!
+# Hopf problem: recognition · smale 5
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def Degree.SupportedGerms.Realizes {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (U : Set E) (f : E → E) : Prop :=
+  ∃ (d : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞) (K : Set E),
+    IsCompact K ∧
+      K ⊆ U ∧
+        Nonempty (Smale.SupportedDiffeomorph.SupportedRelativeIsotopy d K {0}) ∧
+          (d : E → E) =ᶠ[𝓝 (0 : E)] f
+
+private theorem
+    Degree.SupportedGerms.Realizes.comp {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    {U : Set E} {f g : E → E} (hf : Degree.SupportedGerms.Realizes U f)
+    (hg : Degree.SupportedGerms.Realizes U g) : Degree.SupportedGerms.Realizes U (f ∘ g) := by
+  obtain ⟨d, K, hK, hKU, ⟨A⟩, hd⟩ := hf
+  obtain ⟨e, L, hL, hLU, ⟨B⟩, he⟩ := hg
+  have he0 : e (0 : E) = 0 := B.endpoint_fixed_on 0 rfl
+  have het : Filter.Tendsto e (𝓝 (0 : E)) (𝓝 0) := by
+    simpa only [he0] using e.continuous.tendsto (0 : E)
+  have C : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy (e.trans d) (K ∪ L) {0} := by
+    refine
+      ⟨(fun p => A.family (p.1, B.family p)), A.smooth.comp (contMDiff_fst.prodMk B.smooth), ?_,
+        ?_, ?_, ?_, ?_⟩
+    · intro x
+      rw [B.zero, A.zero]
+    · intro x
+      change A.family (1, B.family (1, x)) = d (e x)
+      rw [B.one, A.one]
+    · intro t
+      obtain ⟨dₜ, hdₜ⟩ := A.slices t
+      obtain ⟨eₜ, heₜ⟩ := B.slices t
+      refine ⟨eₜ.trans dₜ, ?_⟩
+      intro x
+      change dₜ (eₜ x) = A.family (t, B.family (t, x))
+      rw [heₜ, hdₜ]
+    · intro t x hx
+      rw [B.fixedOutside t x (fun h => hx (Or.inr h)),
+        A.fixedOutside t x (fun h => hx (Or.inl h))]
+    · intro t x hx
+      rw [B.fixedOn t x hx, A.fixedOn t x hx]
+  refine ⟨e.trans d, K ∪ L, hK.union hL, Set.union_subset hKU hLU, ⟨C⟩, ?_⟩
+  filter_upwards [hd.comp_tendsto het, he] with x hx hy
+  change d (e x) = f (g x)
+  exact hx.trans (congrArg f hy)
+
+private theorem
+    Degree.SupportedGerms.Realizes.conj {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (c : E ≃L[ℝ] F) {U : Set E} {f : E → E}
+    (hf : Degree.SupportedGerms.Realizes U f) :
+    Degree.SupportedGerms.Realizes (c '' U) (fun y => c (f (c.symm y))) := by
+  obtain ⟨d, K, hK, hKU, ⟨A⟩, hd⟩ := hf
+  let D := (c.symm.toDiffeomorph.trans d).trans c.toDiffeomorph
+  have B : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy D (c '' K) {0} := by
+    refine
+      ⟨(fun p => c (A.family (p.1, c.symm p.2))),
+        c.toDiffeomorph.contMDiff.comp
+          (A.smooth.comp
+            (contMDiff_fst.prodMk (c.symm.toDiffeomorph.contMDiff.comp contMDiff_snd))),
+        ?_, ?_, ?_, ?_, ?_⟩
+    · intro y
+      rw [A.zero, c.apply_symm_apply]
+    · intro y
+      change c (A.family (1, c.symm y)) = c (d (c.symm y))
+      rw [A.one]
+    · intro t
+      obtain ⟨e, he⟩ := A.slices t
+      refine ⟨(c.symm.toDiffeomorph.trans e).trans c.toDiffeomorph, ?_⟩
+      intro y
+      change c (e (c.symm y)) = c (A.family (t, c.symm y))
+      rw [he]
+    · intro t y hy
+      have hnot : c.symm y ∉ K := fun h => hy ⟨c.symm y, h, c.apply_symm_apply y⟩
+      rw [A.fixedOutside t (c.symm y) hnot, c.apply_symm_apply]
+    · intro t y hy
+      have hy0 : y = 0 := Set.mem_singleton_iff.mp hy
+      subst y
+      rw [map_zero, A.fixedOn t 0 rfl, map_zero]
+  refine ⟨D, c '' K, hK.image c.continuous, Set.image_mono hKU, ⟨B⟩, ?_⟩
+  have ht : Filter.Tendsto c.symm (𝓝 (0 : F)) (𝓝 0) := by
+    simpa only [map_zero] using c.symm.continuous.tendsto (0 : F)
+  filter_upwards [hd.comp_tendsto ht] with y hy
+  exact congrArg c hy
+
+private theorem Degree.SupportedGerms.realizes_shear {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] [FiniteDimensional ℝ E]
+    [FiniteDimensional ℝ F] (L : F →L[ℝ] E) {U : Set (E × F)} (hU : IsOpen U)
+    (h0 : (0 : E × F) ∈ U) : Realizes U (fun p => (p.1 + L p.2, p.2)) := by
+  obtain ⟨A, K, hK, hKU, hA, hA0, hdiff, hfix, -, hcore, hgerm⟩ :=
+    Smale.SupportedDiffeomorph.exists_supported_shear_isotopy L hU h0
+  obtain ⟨d, hd⟩ := hdiff 1
+  have H : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy d K {0} := by
+    refine ⟨A, hA, hA0, fun x => (hd x).symm, hdiff, hfix, ?_⟩
+    intro t x hx
+    have hx0 : x = 0 := Set.mem_singleton_iff.mp hx
+    subst x
+    exact hcore t 0
+  refine ⟨d, K, hK, hKU, ⟨H⟩, ?_⟩
+  filter_upwards [hgerm] with x hx
+  exact (hd x).trans hx
+
+private theorem
+    Degree.LinearFramePaths.diag2n_decompose {ι : Type*} [Fintype ι] [DecidableEq ι] {i j : ι}
+    (hij : i ≠ j) (a : ℝ) (ha : a ≠ 0) :
+    Matrix.SpecialLinearGroup.diag2n hij a ha =
+      Matrix.SpecialLinearGroup.transvection hij a *
+                Matrix.SpecialLinearGroup.transvection hij.symm (-a⁻¹) *
+              Matrix.SpecialLinearGroup.transvection hij a *
+            Matrix.SpecialLinearGroup.transvection hij (-1) *
+          Matrix.SpecialLinearGroup.transvection hij.symm 1 *
+        Matrix.SpecialLinearGroup.transvection hij (-1) := by
+  apply Subtype.ext
+  change
+    Matrix.diagonal (fun k => if k = i then a else if k = j then a⁻¹ else 1) =
+      (1 + Matrix.single i j a) * (1 + Matrix.single j i (-a⁻¹)) * (1 + Matrix.single i j a) *
+            (1 + Matrix.single i j (-1)) *
+          (1 + Matrix.single j i 1) *
+        (1 + Matrix.single i j (-1))
+  simp only [mul_add, add_mul, one_mul, mul_one, Matrix.single_mul_single_same,
+    Matrix.single_mul_single_of_ne _ _ _ _ hij, Matrix.single_mul_single_of_ne _ _ _ _ hij.symm]
+  ext k l
+  by_cases hki : k = i <;> by_cases hkj : k = j <;> by_cases hli : l = i <;>
+      by_cases hlj : l = j <;>
+    simp_all [Matrix.diagonal_apply, Matrix.one_apply, Matrix.single_apply, eq_comm]
+
+private theorem
+    Degree.LinearFramePaths.joined_one_transvection {ι : Type*} [Fintype ι] [DecidableEq ι]
+    {i j : ι} (hij : i ≠ j) (a : ℝ) :
+    Joined (1 : Matrix.SpecialLinearGroup ι ℝ) (Matrix.SpecialLinearGroup.transvection hij a) := by
+  refine
+    ⟨{  toFun := fun t => Matrix.SpecialLinearGroup.transvection hij ((t : ℝ) * a)
+        continuous_toFun := ?_
+        source' := by simp
+        target' := by simp }⟩
+  apply Continuous.subtype_mk
+  change Continuous (fun t : unitInterval => (1 : Matrix ι ι ℝ) + Matrix.single i j ((t : ℝ) * a))
+  apply continuous_pi
+  intro k
+  apply continuous_pi
+  intro l
+  simp only [Matrix.add_apply, Matrix.single_apply]
+  by_cases h : i = k ∧ j = l
+  · simp only [h, and_self, ite_true]
+    fun_prop
+  · simp only [h, ite_false]
+    fun_prop
+
+private theorem
+    Degree.LinearFramePaths.joined_one_specialLinear {ι : Type*} [Fintype ι] [DecidableEq ι]
+    [Nontrivial ι] (A : Matrix.SpecialLinearGroup ι ℝ) :
+    Joined (1 : Matrix.SpecialLinearGroup ι ℝ) A := by
+  apply
+    Matrix.SpecialLinearGroup.diagonal_transvection_induction'
+      (fun A => Joined (1 : Matrix.SpecialLinearGroup ι ℝ) A) A
+  · intro i j hij a ha
+    rw [diag2n_decompose hij a ha]
+    have hmul {A B : Matrix.SpecialLinearGroup ι ℝ} (hA : Joined 1 A) (hB : Joined 1 B) :
+      Joined 1 (A * B) := by simpa only [one_mul] using hA.mul hB
+    exact
+      hmul
+        (hmul
+          (hmul
+            (hmul (hmul (joined_one_transvection hij a) (joined_one_transvection hij.symm (-a⁻¹)))
+              (joined_one_transvection hij a))
+            (joined_one_transvection hij (-1)))
+          (joined_one_transvection hij.symm 1))
+        (joined_one_transvection hij (-1))
+  · exact fun i j hij a => joined_one_transvection hij a
+  · intro A B hA hB
+    simpa only [one_mul] using hA.mul hB
+
+private def Degree.SupportedGerms.coordinateSplit {ι : Type*} [Fintype ι] [DecidableEq ι] (i : ι) :
+    (ι → ℝ) ≃L[ℝ] ℝ × ({ j : ι // j ≠ i } → ℝ) :=
+  LinearEquiv.toContinuousLinearEquiv
+    { toFun := fun x => (x i, fun j => x j)
+      invFun := fun p j => if h : j = i then p.1 else p.2 ⟨j, h⟩
+      left_inv := by
+        intro x
+        funext j
+        by_cases h : j = i <;> simp [h]
+      right_inv := by
+        rintro ⟨a, x⟩
+        apply Prod.ext
+        · simp
+        · funext j
+          simp [j.property]
+      map_add' := fun _ _ => rfl
+      map_smul' := fun _ _ => rfl }
+
+private theorem Degree.SupportedGerms.realizes_transvection {ι : Type*} [Fintype ι] [DecidableEq ι]
+    {U : Set (ι → ℝ)} (hU : IsOpen U) (h0 : (0 : ι → ℝ) ∈ U) {i j : ι} (hij : i ≠ j) (a : ℝ) :
+    Realizes U
+      (Matrix.SpecialLinearGroup.toLin' (Matrix.SpecialLinearGroup.transvection hij a)) := by
+  let c := coordinateSplit i
+  let L : ({ k : ι // k ≠ i } → ℝ) →L[ℝ] ℝ := a • ContinuousLinearMap.proj ⟨j, Ne.symm hij⟩
+  have h :=
+    (realizes_shear L (c.toHomeomorph.isOpenMap _ hU)
+          (show (0 : ℝ × ({ k : ι // k ≠ i } → ℝ)) ∈ c '' U from ⟨0, h0, map_zero c⟩)).conj
+      c.symm
+  have hset : c.symm '' (c '' U) = U := by
+    rw [← Set.image_comp]
+    simp only [ContinuousLinearEquiv.symm_comp_self, Set.image_id]
+  change Realizes (c.symm '' (c '' U)) (fun y => c.symm ((c y).1 + L (c y).2, (c y).2)) at h
+  rw [hset] at h
+  convert h using 1
+  funext x k
+  change
+    ((Matrix.SpecialLinearGroup.transvection hij a : Matrix ι ι ℝ) *ᵥ x) k =
+      (c.symm ((c x).1 + L (c x).2, (c x).2)) k
+  rw [Matrix.SpecialLinearGroup.transvection_coe, Matrix.add_mulVec, Matrix.one_mulVec,
+    Matrix.single_mulVec_eq]
+  by_cases hk : k = i
+  · subst k
+    simp [c, coordinateSplit, L]
+  · simp [c, coordinateSplit, L, hk]
+
+private theorem Degree.SupportedGerms.realizes_specialLinear {ι : Type*} [Fintype ι] [DecidableEq ι]
+    [Nontrivial ι] {U : Set (ι → ℝ)} (hU : IsOpen U) (h0 : (0 : ι → ℝ) ∈ U)
+    (A : Matrix.SpecialLinearGroup ι ℝ) : Realizes U (Matrix.SpecialLinearGroup.toLin' A) := by
+  have hmul (A B : Matrix.SpecialLinearGroup ι ℝ)
+    (hA : Realizes U (Matrix.SpecialLinearGroup.toLin' A))
+    (hB : Realizes U (Matrix.SpecialLinearGroup.toLin' B)) :
+    Realizes U (Matrix.SpecialLinearGroup.toLin' (A * B)) := by
+    convert hA.comp hB using 1
+    funext x
+    rw [map_mul]
+    rfl
+  apply
+    Matrix.SpecialLinearGroup.diagonal_transvection_induction'
+      (fun A => Realizes U (Matrix.SpecialLinearGroup.toLin' A)) A
+  · intro i j hij a ha
+    rw [Degree.LinearFramePaths.diag2n_decompose hij a ha]
+    exact
+      hmul _ _
+        (hmul _ _
+          (hmul _ _
+            (hmul _ _
+              (hmul _ _ (realizes_transvection hU h0 hij a)
+                (realizes_transvection hU h0 hij.symm (-a⁻¹)))
+              (realizes_transvection hU h0 hij a))
+            (realizes_transvection hU h0 hij (-1)))
+          (realizes_transvection hU h0 hij.symm 1))
+        (realizes_transvection hU h0 hij (-1))
+  · exact fun i j hij a => realizes_transvection hU h0 hij a
+  · exact hmul
+
+private theorem
+    Degree.SupportedGerms.realizes_det_one {ι : Type*} [Finite ι] [Nontrivial ι] {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] (b : Module.Basis ι ℝ E)
+    (C : E ≃L[ℝ] E) (hdet : C.toLinearMap.det = 1) {U : Set E} (hU : IsOpen U)
+    (h0 : (0 : E) ∈ U) : Realizes U C := by
+  classical
+  let := Fintype.ofFinite ι
+  let A : Matrix.SpecialLinearGroup ι ℝ :=
+    ⟨LinearMap.toMatrix b b C.toLinearMap, (LinearMap.det_toMatrix b C.toLinearMap).trans hdet⟩
+  let c : (ι → ℝ) ≃L[ℝ] E := b.equivFun.symm.toContinuousLinearEquiv
+  have h :=
+    (realizes_specialLinear (c.symm.toHomeomorph.isOpenMap _ hU)
+          (show (0 : ι → ℝ) ∈ c.symm '' U from ⟨0, h0, map_zero c.symm⟩) A).conj
+      c
+  change Realizes (c '' (c.symm '' U)) (fun y => c (A.toLin' (c.symm y))) at h
+  have hset : c '' (c.symm '' U) = U := by
+    rw [← Set.image_comp]
+    simp only [ContinuousLinearEquiv.self_comp_symm, Set.image_id]
+  rw [hset] at h
+  convert h using 1
+  funext x
+  apply c.symm.injective
+  rw [c.symm_apply_apply]
+  exact (LinearMap.toMatrix_mulVec_repr b b C.toLinearMap x).symm
+
+private theorem
+    Smale.SmallPerturbation.lipschitzWith_cutoff_smul {P E : Type*} [PseudoMetricSpace P]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] {u : P → E} {β : P → ℝ} {S : Set P} {a b R : ℝ≥0}
+    (hu : LipschitzOnWith a u S) (hbound : ∀ x ∈ S, ‖u x‖ ≤ R) (hβ : LipschitzWith b β)
+    (hβbound : ∀ x, |β x| ≤ 1) (hzero : ∀ x ∉ S, β x = 0) :
+    LipschitzWith (a + b * R) (fun x => β x • u x) := by
+  have hcross (x y : P) (hx : x ∈ S) (hy : y ∉ S) :
+    Dist.dist (β x • u x) (β y • u y) ≤ ((a + b * R : ℝ≥0) : ℝ) * Dist.dist x y := by
+    have hβx : |β x| ≤ (b : ℝ) * Dist.dist x y := by
+      have h := hβ.dist_le_mul x y
+      simpa only [hzero y hy, Real.dist_eq, sub_zero] using h
+    rw [hzero y hy, zero_smul, dist_zero_right, norm_smul, Real.norm_eq_abs]
+    calc
+      |β x| * ‖u x‖ ≤ ((b : ℝ) * Dist.dist x y) * R :=
+        mul_le_mul hβx (hbound x hx) (norm_nonneg _) (by positivity)
+      _ ≤ ((a + b * R : ℝ≥0) : ℝ) * Dist.dist x y := by
+        simp only [NNReal.coe_add, NNReal.coe_mul]
+        nlinarith [mul_nonneg a.coe_nonneg (dist_nonneg (x := x) (y := y))]
+  apply LipschitzWith.of_dist_le_mul
+  intro x y
+  by_cases hx : x ∈ S
+  · by_cases hy : y ∈ S
+    · have hu' : ‖u x - u y‖ ≤ (a : ℝ) * Dist.dist x y := by
+        simpa only [dist_eq_norm] using hu.dist_le_mul x hx y hy
+      have hβ' : |β x - β y| ≤ (b : ℝ) * Dist.dist x y := by
+        simpa only [Real.dist_eq] using hβ.dist_le_mul x y
+      have hsplit : β x • u x - β y • u y = β x • (u x - u y) + (β x - β y) • u y := by
+        rw [smul_sub, sub_smul]
+        abel
+      rw [dist_eq_norm, hsplit]
+      calc
+        ‖β x • (u x - u y) + (β x - β y) • u y‖ ≤ ‖β x • (u x - u y)‖ + ‖(β x - β y) • u y‖ :=
+          norm_add_le _ _
+        _ = |β x| * ‖u x - u y‖ + |β x - β y| * ‖u y‖ := by
+          rw [norm_smul, norm_smul, Real.norm_eq_abs, Real.norm_eq_abs]
+        _ ≤ 1 * ((a : ℝ) * Dist.dist x y) + ((b : ℝ) * Dist.dist x y) * R := by
+          exact
+            add_le_add (mul_le_mul (hβbound x) hu' (norm_nonneg _) (by norm_num))
+              (mul_le_mul hβ' (hbound y hy) (norm_nonneg _) (by positivity))
+        _ = ((a + b * R : ℝ≥0) : ℝ) * Dist.dist x y := by
+          simp only [NNReal.coe_add, NNReal.coe_mul]
+          ring
+    · exact hcross x y hx hy
+  · by_cases hy : y ∈ S
+    · simpa only [dist_comm] using hcross y x hy hx
+    · rw [hzero x hx, hzero y hy, zero_smul, zero_smul, dist_self]
+      positivity
+
+private theorem
+    Smale.SmallPerturbation.exists_closedBall_small_lipschitz_of_fderiv_zero {P E : Type*}
+    [NormedAddCommGroup P] [NormedSpace ℝ P] [NormedAddCommGroup E] [NormedSpace ℝ E] {u : P → E}
+    {U : Set P} (hU : IsOpen U) (hzero : (0 : P) ∈ U) (hu : ContDiffOn ℝ ∞ u U)
+    (hdu : fderiv ℝ u 0 = 0) {a : ℝ≥0} (ha : 0 < a) :
+    ∃ ρ : ℝ,
+      0 < ρ ∧
+        Metric.closedBall (0 : P) ρ ⊆ U ∧ LipschitzOnWith a u (Metric.closedBall (0 : P) ρ) := by
+  have hd : ContinuousAt (fderiv ℝ u) 0 :=
+    (hu.continuousOn_fderiv_of_isOpen hU (by simp)).continuousAt (hU.mem_nhds hzero)
+  have hsmall : ∀ᶠ x in 𝓝 (0 : P), ‖fderiv ℝ u x‖ < (a : ℝ) := by
+    have h : ∀ᶠ x in 𝓝 (0 : P), fderiv ℝ u x ∈ Metric.ball (fderiv ℝ u 0) (a : ℝ) :=
+      hd.preimage_mem_nhds (Metric.ball_mem_nhds (fderiv ℝ u 0) (show (0 : ℝ) < a from ha))
+    simpa only [hdu, mem_ball_zero_iff] using h
+  have hnear : ∀ᶠ x in 𝓝 (0 : P), x ∈ U := hU.mem_nhds hzero
+  obtain ⟨ρ, hρ, hball⟩ := Metric.nhds_basis_closedBall.mem_iff.mp (hnear.and hsmall)
+  refine ⟨ρ, hρ, fun x hx => (hball hx).1, ?_⟩
+  apply (convex_closedBall (0 : P) ρ).lipschitzOnWith_of_nnnorm_fderiv_le (𝕜 := ℝ)
+  · intro x hx
+    exact (hu.contDiffAt (hU.mem_nhds (hball hx).1)).differentiableAt (by simp)
+  · intro x hx
+    exact (hball hx).2.le
+
+private theorem Smale.SmallPerturbation.exists_lipschitz_supported_germ {P E : Type*}
+    [NormedAddCommGroup P] [NormedSpace ℝ P] [FiniteDimensional ℝ P] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {u : P → E} {U : Set P} (hU : IsOpen U) (hzero : (0 : P) ∈ U)
+    (hu : ContDiffOn ℝ ∞ u U) (hu₀ : u 0 = 0) (hdu : fderiv ℝ u 0 = 0) {κ : ℝ≥0} (hκ : 0 < κ) :
+    ∃ w : P → E,
+      ContDiff ℝ ∞ w ∧
+        HasCompactSupport w ∧
+          tsupport w ⊆ U ∧
+            LipschitzWith κ w ∧ w =ᶠ[𝓝 (0 : P)] u ∧ ∀ x, ∃ c ∈ Set.Icc (0 : ℝ) 1, w x = c • u x :=
+  by
+  obtain ⟨β, hβ, hβcompact, hβsupport, hβone, hβrange⟩ :=
+    Smale.exists_compact_smooth_cutoff (K := {(0 : P)}) (U := Metric.ball (0 : P) 1)
+      isCompact_singleton Metric.isOpen_ball (by simp)
+  obtain ⟨k, hk⟩ := ContDiff.lipschitzWith_of_hasCompactSupport hβcompact hβ (by simp)
+  let a : ℝ≥0 := κ / (1 + k)
+  have hden : (0 : ℝ≥0) < 1 + k := by positivity
+  have ha : 0 < a := div_pos hκ hden
+  obtain ⟨ρ, hρ, hρU, hlocal⟩ :=
+    exists_closedBall_small_lipschitz_of_fderiv_zero hU hzero hu hdu ha
+  let r : ℝ≥0 := ⟨ρ, hρ.le⟩
+  have hr : 0 < r := hρ
+  let βρ : P → ℝ := fun x => β (ρ⁻¹ • x)
+  have hβρ : ContDiff ℝ ∞ βρ := hβ.comp (ρ⁻¹ • ContinuousLinearMap.id ℝ P).contDiff
+  have hβρlip : LipschitzWith (k * ‖ρ⁻¹‖₊) βρ := hk.comp (lipschitzWith_smul ρ⁻¹)
+  have hβρbound (x : P) : |βρ x| ≤ 1 := by
+    change |β (ρ⁻¹ • x)| ≤ 1
+    rw [abs_of_nonneg (hβrange _).1]
+    exact (hβrange _).2
+  have hβρzero (x : P) (hx : x ∉ Metric.closedBall (0 : P) ρ) : βρ x = 0 := by
+    by_contra hne
+    have hm : ρ⁻¹ • x ∈ Metric.ball (0 : P) 1 := hβsupport (subset_tsupport β hne)
+    have hn : ‖ρ⁻¹ • x‖ < 1 := mem_ball_zero_iff.mp hm
+    rw [norm_smul, Real.norm_eq_abs, abs_of_pos (inv_pos.mpr hρ), inv_mul_lt_one₀ hρ] at hn
+    exact hx (mem_closedBall_zero_iff.mpr hn.le)
+  have hbound : ∀ x ∈ Metric.closedBall (0 : P) ρ, ‖u x‖ ≤ (a * r : ℝ≥0) := by
+    intro x hx
+    have h0 : (0 : P) ∈ Metric.closedBall (0 : P) ρ := by simpa using hρ.le
+    have hn := hlocal.dist_le_mul x hx 0 h0
+    rw [hu₀, dist_zero_right, dist_zero_right] at hn
+    change ‖u x‖ ≤ (a : ℝ) * ρ
+    exact hn.trans (mul_le_mul_of_nonneg_left (mem_closedBall_zero_iff.mp hx) a.coe_nonneg)
+  let w : P → E := fun x => βρ x • u x
+  have hwzero (x : P) (hx : x ∉ Metric.closedBall (0 : P) ρ) : w x = 0 := by
+    change βρ x • u x = 0
+    rw [hβρzero x hx, zero_smul]
+  have hsmooth : ContDiff ℝ ∞ w := by
+    apply contDiff_iff_contDiffAt.mpr
+    intro x
+    by_cases hx : x ∈ U
+    · exact hβρ.contDiffAt.smul (hu.contDiffAt (hU.mem_nhds hx))
+    · have hnot : x ∉ Metric.closedBall (0 : P) ρ := fun h => hx (hρU h)
+      have hc : ContDiffAt ℝ ∞ (fun _ : P => (0 : E)) x := contDiffAt_const
+      apply hc.congr_of_eventuallyEq
+      filter_upwards [Metric.isClosed_closedBall.isOpen_compl.mem_nhds hnot] with y hy
+      exact hwzero y hy
+  have hcompact : HasCompactSupport w :=
+    HasCompactSupport.intro (ProperSpace.isCompact_closedBall (0 : P) ρ) hwzero
+  have hsupport : tsupport w ⊆ Metric.closedBall (0 : P) ρ := by
+    apply closure_minimal _ Metric.isClosed_closedBall
+    intro x hx
+    by_contra hnot
+    exact hx (hwzero x hnot)
+  have hwlip : LipschitzWith (a + (k * ‖ρ⁻¹‖₊) * (a * r)) w :=
+    lipschitzWith_cutoff_smul hlocal hbound hβρlip hβρbound hβρzero
+  have hnn : ‖ρ‖₊ = r := Real.nnnorm_of_nonneg hρ.le
+  have hcoeff : a + (k * ‖ρ⁻¹‖₊) * (a * r) = κ := by
+    rw [nnnorm_inv, hnn]
+    calc
+      a + (k * r⁻¹) * (a * r) = a + (k * a) * (r⁻¹ * r) := by ring
+      _ = a + k * a := by rw [inv_mul_cancel₀ hr.ne', mul_one]
+      _ = (1 + k) * a := by ring
+      _ = κ := by
+        dsimp [a]
+        rw [div_eq_mul_inv, ← mul_assoc, mul_comm (1 + k) κ, mul_assoc, mul_inv_cancel₀ hden.ne',
+          mul_one]
+  rw [hcoeff] at hwlip
+  have hβ₀ : ∀ᶠ x in 𝓝 (0 : P), β x = 1 :=
+    hβone.filter_mono (nhds_le_nhdsSet (Set.mem_singleton (0 : P)))
+  have hscale : Filter.Tendsto (fun x : P => ρ⁻¹ • x) (𝓝 0) (𝓝 0) := by
+    have hs : Continuous (fun x : P => ρ⁻¹ • x) := (ρ⁻¹ • ContinuousLinearMap.id ℝ P).continuous
+    simpa only [smul_zero] using (hs.continuousAt (x := (0 : P))).tendsto
+  have hgerm : w =ᶠ[𝓝 (0 : P)] u := by
+    have hscaled : ∀ᶠ x in 𝓝 (0 : P), β (ρ⁻¹ • x) = 1 := hscale hβ₀
+    filter_upwards [hscaled] with x hx
+    change β (ρ⁻¹ • x) • u x = u x
+    rw [hx, one_smul]
+  refine ⟨w, hsmooth, hcompact, hsupport.trans hρU, hwlip, hgerm, ?_⟩
+  intro x
+  exact ⟨βρ x, hβrange _, rfl⟩
+
+private theorem Smale.SmallPerturbation.exists_supported_tangent_identity_isotopy {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] {f : E → E} {U : Set E}
+    (hU : IsOpen U) (hzero : (0 : E) ∈ U) (hf : ContDiffOn ℝ ∞ f U) (hf₀ : f 0 = 0)
+    (hdf : fderiv ℝ f 0 = ContinuousLinearMap.id ℝ E) :
+    ∃ (A : ℝ × E → E) (K : Set E),
+      IsCompact K ∧
+        K ⊆ U ∧
+          ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, E)) 𝓘(ℝ, E) ∞ A ∧
+            (∀ x, A (0, x) = x) ∧
+              (∀ t, ∃ D : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞, ∀ x, D x = A (t, x)) ∧
+                (∀ t x, x ∉ K → A (t, x) = x) ∧
+                  (∀ t x, ∃ c ∈ Set.Icc (0 : ℝ) 1, A (t, x) = x + c • (f x - x)) ∧
+                    (fun x => A (1, x)) =ᶠ[𝓝 (0 : E)] f := by
+  let u : E → E := fun x => f x - x
+  have hu : ContDiffOn ℝ ∞ u U := hf.sub contDiffOn_id
+  have hu₀ : u 0 = 0 := by simp [u, hf₀]
+  have hdu : fderiv ℝ u 0 = 0 := by
+    have hdiff : DifferentiableAt ℝ f 0 :=
+      (hf.contDiffAt (hU.mem_nhds hzero)).differentiableAt (by simp)
+    change fderiv ℝ (f - id) 0 = 0
+    rw [fderiv_sub hdiff differentiableAt_id, hdf, fderiv_id, sub_self]
+  obtain ⟨w, hw, hwcompact, hwsupport, hwlip, hweq, hwscalar⟩ :=
+    exists_lipschitz_supported_germ hU hzero hu hu₀ hdu (show (0 : ℝ≥0) < 1 / 2 by norm_num)
+  let A : ℝ × E → E := fun p => p.2 + Real.smoothTransition p.1 • w p.2
+  have hθ : ContMDiff 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) ∞ Real.smoothTransition :=
+    (Real.smoothTransition.contDiff (n := ⊤)).contMDiff
+  have hA : ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, E)) 𝓘(ℝ, E) ∞ A :=
+    contMDiff_snd.add ((hθ.comp contMDiff_fst).smul (hw.contMDiff.comp contMDiff_snd))
+  refine ⟨A, tsupport w, hwcompact.isCompact, hwsupport, hA, ?_, ?_, ?_, ?_, ?_⟩
+  · intro x
+    simp [A, Real.smoothTransition.zero]
+  · intro t
+    have hs : ContDiff ℝ ∞ (fun x => Real.smoothTransition t • w x) := contDiff_const.smul hw
+    have hlip :
+      LipschitzWith (‖Real.smoothTransition t‖₊ * (1 / 2))
+        (fun x => Real.smoothTransition t • w x) :=
+      (lipschitzWith_smul (Real.smoothTransition t)).comp hwlip
+    have hθnorm : ‖Real.smoothTransition t‖₊ ≤ 1 := by
+      change ‖Real.smoothTransition t‖ ≤ (1 : ℝ)
+      rw [Real.norm_eq_abs, abs_of_nonneg (Real.smoothTransition.nonneg t)]
+      exact Real.smoothTransition.le_one t
+    have hsmall : ‖Real.smoothTransition t‖₊ * (1 / 2 : ℝ≥0) < 1 := by
+      calc
+        _ ≤ 1 * (1 / 2 : ℝ≥0) := mul_le_mul_of_nonneg_right hθnorm (by positivity)
+        _ < 1 := by norm_num
+    exact ⟨diffeomorphIdAdd hs hlip hsmall, fun _ => rfl⟩
+  · intro t x hx
+    have hz : w x = 0 := by
+      by_contra hne
+      exact hx (subset_tsupport w hne)
+    simp only [A, hz, smul_zero, add_zero]
+  · intro t x
+    obtain ⟨c, hc, hwc⟩ := hwscalar x
+    refine
+      ⟨Real.smoothTransition t * c,
+        ⟨mul_nonneg (Real.smoothTransition.nonneg t) hc.1,
+          (mul_le_mul_of_nonneg_right (Real.smoothTransition.le_one t) hc.1).trans
+            (by simpa only [one_mul] using hc.2)⟩,
+        ?_⟩
+    change x + Real.smoothTransition t • w x = x + _
+    rw [hwc, smul_smul]
+  · filter_upwards [hweq] with x hx
+    change x + Real.smoothTransition 1 • w x = f x
+    rw [Real.smoothTransition.one, one_smul, hx]
+    change x + (f x - x) = f x
+    abel
+
+private theorem Smale.SmallPerturbation.exists_relative_tangent_identity_isotopy {E F : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {f : E → E} {U S : Set E} (hU : IsOpen U) (hzero : (0 : E) ∈ U)
+    (hf : ContDiffOn ℝ ∞ f U) (hf₀ : f 0 = 0) (hdf : fderiv ℝ f 0 = ContinuousLinearMap.id ℝ E)
+    (Q : E →L[ℝ] F) (hQ : ∀ x ∈ U, Q (f x) = Q x) (hS : ∀ x ∈ U ∩ S, f x = x) :
+    ∃ (A : ℝ × E → E) (K : Set E),
+      IsCompact K ∧
+        K ⊆ U ∧
+          ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, E)) 𝓘(ℝ, E) ∞ A ∧
+            (∀ x, A (0, x) = x) ∧
+              (∀ t, ∃ D : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞, ∀ x, D x = A (t, x)) ∧
+                (∀ t x, x ∉ K → A (t, x) = x) ∧
+                  (∀ t x, Q (A (t, x)) = Q x) ∧
+                    (∀ t x, x ∈ S → A (t, x) = x) ∧ (fun x => A (1, x)) =ᶠ[𝓝 (0 : E)] f := by
+  obtain ⟨A, K, hK, hKU, hA, hA₀, hdiff, hfix, hscalar, hgerm⟩ :=
+    exists_supported_tangent_identity_isotopy hU hzero hf hf₀ hdf
+  refine ⟨A, K, hK, hKU, hA, hA₀, hdiff, hfix, ?_, ?_, hgerm⟩
+  · intro t x
+    by_cases hx : x ∈ U
+    · obtain ⟨c, _, heq⟩ := hscalar t x
+      rw [heq, map_add, map_smul, map_sub, hQ x hx, sub_self, smul_zero, add_zero]
+    · rw [hfix t x (fun h => hx (hKU h))]
+  · intro t x hxS
+    by_cases hx : x ∈ U
+    · obtain ⟨c, _, heq⟩ := hscalar t x
+      rw [heq, hS x ⟨hx, hxS⟩, sub_self, smul_zero, add_zero]
+    · exact hfix t x (fun h => hx (hKU h))
+
+private theorem
+    Smale.SmallPerturbation.fderiv_preserves_projection {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → E} {U : Set E}
+    (hU : IsOpen U) (hzero : (0 : E) ∈ U) (hf : DifferentiableAt ℝ f 0) (Q : E →L[ℝ] F)
+    (hQ : ∀ x ∈ U, Q (f x) = Q x) : Q.comp (fderiv ℝ f 0) = Q := by
+  have heq : Q ∘ f =ᶠ[𝓝 (0 : E)] Q := by
+    filter_upwards [hU.mem_nhds hzero] with x hx
+    exact hQ x hx
+  have hc : fderiv ℝ (Q ∘ f) 0 = Q.comp (fderiv ℝ f 0) :=
+    (Q.hasFDerivAt.comp 0 hf.hasFDerivAt).fderiv
+  exact hc.symm.trans (heq.fderiv_eq.trans Q.fderiv)
+
+private theorem Smale.SmallPerturbation.fderiv_fixes_subspace {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {f : E → E} {U : Set E} (hU : IsOpen U) (hzero : (0 : E) ∈ U)
+    (hf : DifferentiableAt ℝ f 0) (S : Submodule ℝ E) (hS : ∀ x ∈ U ∩ (S : Set E), f x = x) :
+    ∀ x ∈ S, fderiv ℝ f 0 x = x := by
+  have heq : f ∘ (S.subtypeL : S → E) =ᶠ[𝓝 (0 : S)] (S.subtypeL : S → E) := by
+    have hn : ∀ᶠ x : S in 𝓝 (0 : S), (x : E) ∈ U :=
+      S.subtypeL.continuous.continuousAt.preimage_mem_nhds (hU.mem_nhds hzero)
+    filter_upwards [hn] with x hx
+    exact hS x ⟨hx, x.property⟩
+  have hc : fderiv ℝ (f ∘ (S.subtypeL : S → E)) (0 : S) = (fderiv ℝ f 0).comp S.subtypeL :=
+    (hf.hasFDerivAt.comp (0 : S) S.subtypeL.hasFDerivAt).fderiv
+  have hlinear : (fderiv ℝ f 0).comp S.subtypeL = S.subtypeL :=
+    hc.symm.trans (heq.fderiv_eq.trans S.subtypeL.fderiv)
+  intro x hx
+  exact congrArg (fun A : S →L[ℝ] E => A ⟨x, hx⟩) hlinear
+
+private theorem Smale.SmallPerturbation.exists_relative_germ_linearization_isotopy {E F : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {f : E → E} {U : Set E} (hU : IsOpen U) (hzero : (0 : E) ∈ U)
+    (hf : ContDiffOn ℝ ∞ f U) (hf₀ : f 0 = 0) (hdf : Function.Bijective (fderiv ℝ f 0))
+    (Q : E →L[ℝ] F) (hQ : ∀ x ∈ U, Q (f x) = Q x) (S : Submodule ℝ E)
+    (hS : ∀ x ∈ U ∩ (S : Set E), f x = x) :
+    ∃ (C : E ≃L[ℝ] E) (A : ℝ × E → E) (K : Set E),
+      C.toContinuousLinearMap = fderiv ℝ f 0 ∧
+        (∀ x, Q (C x) = Q x) ∧
+          (∀ x ∈ S, C x = x) ∧
+            IsCompact K ∧
+              K ⊆ U ∧
+                ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, E)) 𝓘(ℝ, E) ∞ A ∧
+                  (∀ x, A (0, x) = x) ∧
+                    (∀ t, ∃ D : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞, ∀ x, D x = A (t, x)) ∧
+                      (∀ t x, x ∉ K → A (t, x) = x) ∧
+                        (∀ t x, Q (A (t, x)) = Q x) ∧
+                          (∀ t x, x ∈ S → A (t, x) = x) ∧
+                            f =ᶠ[𝓝 (0 : E)] (fun x => C (A (1, x))) := by
+  have hfd : DifferentiableAt ℝ f 0 :=
+    (hf.contDiffAt (hU.mem_nhds hzero)).differentiableAt (by simp)
+  let C := (LinearEquiv.ofBijective (fderiv ℝ f 0).toLinearMap hdf).toContinuousLinearEquiv
+  have hC : C.toContinuousLinearMap = fderiv ℝ f 0 := rfl
+  have hQC : ∀ x, Q (C x) = Q x := by
+    intro x
+    exact congrArg (fun A : E →L[ℝ] F => A x) (fderiv_preserves_projection hU hzero hfd Q hQ)
+  have hCS : ∀ x ∈ S, C x = x := fderiv_fixes_subspace hU hzero hfd S hS
+  have hQCinv (y : E) : Q (C.symm y) = Q y := by
+    have h := (hQC (C.symm y)).symm
+    simpa only [C.apply_symm_apply] using h
+  have hCSinv (x : E) (hx : x ∈ S) : C.symm x = x := by
+    have h := C.symm_apply_apply x
+    rwa [hCS x hx] at h
+  let G : E → E := C.symm ∘ f
+  have hG : ContDiffOn ℝ ∞ G U := C.symm.contDiff.comp_contDiffOn hf
+  have hG₀ : G 0 = 0 := by simp [G, hf₀]
+  have hGder : fderiv ℝ G 0 = C.symm.toContinuousLinearMap.comp (fderiv ℝ f 0) :=
+    (C.symm.toContinuousLinearMap.hasFDerivAt.comp 0 hfd.hasFDerivAt).fderiv
+  have hdG : fderiv ℝ G 0 = ContinuousLinearMap.id ℝ E := by
+    rw [hGder, ← hC]
+    ext x
+    exact C.symm_apply_apply x
+  have hQG : ∀ x ∈ U, Q (G x) = Q x := by
+    intro x hx
+    change Q (C.symm (f x)) = Q x
+    rw [hQCinv, hQ x hx]
+  have hSG : ∀ x ∈ U ∩ (S : Set E), G x = x := by
+    intro x hx
+    change C.symm (f x) = x
+    rw [hS x hx, hCSinv x hx.2]
+  obtain ⟨A, K, hK, hKU, hA, hA₀, hdiff, hfix, hprojection, hfixed, hgerm⟩ :=
+    exists_relative_tangent_identity_isotopy hU hzero hG hG₀ hdG Q hQG hSG
+  refine ⟨C, A, K, hC, hQC, hCS, hK, hKU, hA, hA₀, hdiff, hfix, hprojection, hfixed, ?_⟩
+  filter_upwards [hgerm] with x hx
+  change A (1, x) = C.symm (f x) at hx
+  rw [hx, C.apply_symm_apply]
+
+private theorem Degree.SupportedGerms.realizes_local_germ {E ι : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [Finite ι] [Nontrivial ι] (b : Module.Basis ι ℝ E)
+    {f : E → E} {U : Set E} (hU : IsOpen U) (h0 : (0 : E) ∈ U) (hf : ContDiffOn ℝ ∞ f U)
+    (hf0 : f 0 = 0) (hbij : Function.Bijective (fderiv ℝ f 0))
+    (hdet : (fderiv ℝ f 0).toLinearMap.det = 1) : Realizes U f := by
+  classical
+  let := Fintype.ofFinite ι
+  obtain ⟨C, A, K, hC, -, -, hK, hKU, hA, hA0, hdiff, hfix, -, hfixed, hgerm⟩ :=
+    Smale.SmallPerturbation.exists_relative_germ_linearization_isotopy hU h0 hf hf0 hbij
+      (0 : E →L[ℝ] ℝ) (fun _ _ => rfl) (⊥ : Submodule ℝ E)
+      (by
+        intro x hx
+        have hx0 : x = 0 := hx.2
+        subst x
+        exact hf0)
+  have hCdet : C.toLinearMap.det = 1 := by
+    change C.toContinuousLinearMap.toLinearMap.det = 1
+    rw [hC]
+    exact hdet
+  obtain ⟨d, hd⟩ := hdiff 1
+  have H : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy d K {0} := by
+    refine ⟨A, hA, hA0, fun x => (hd x).symm, hdiff, hfix, ?_⟩
+    intro t x hx
+    exact hfixed t x (Set.mem_singleton_iff.mp hx)
+  have hdreal : Realizes U (fun x => A (1, x)) :=
+    ⟨d, K, hK, hKU, ⟨H⟩, Filter.Eventually.of_forall hd⟩
+  obtain ⟨D, L, hL, hLU, hH, hDgerm⟩ := (realizes_det_one b C hCdet hU h0).comp hdreal
+  exact ⟨D, L, hL, hLU, hH, hDgerm.trans hgerm.symm⟩
+
+private def Degree.LinearFramePaths.scalarDiagonal {ι : Type*} [DecidableEq ι] (i : ι) (a : ℝ) :
+    Matrix ι ι ℝ :=
+  Matrix.diagonal (fun k => if k = i then a else 1)
+
+private theorem
+    Degree.LinearFramePaths.det_scalarDiagonal {ι : Type*} [Fintype ι] [DecidableEq ι] (i : ι)
+    (a : ℝ) : Matrix.det (scalarDiagonal i a) = a := by simp [scalarDiagonal, Matrix.det_diagonal]
+
+private theorem
+    Degree.LinearFramePaths.scalarDiagonal_mul {ι : Type*} [Fintype ι] [DecidableEq ι] (i : ι)
+    (a b : ℝ) : scalarDiagonal i a * scalarDiagonal i b = scalarDiagonal i (a * b) := by
+  rw [scalarDiagonal, scalarDiagonal, Matrix.diagonal_mul_diagonal]
+  congr 1
+  funext k
+  by_cases h : k = i <;> simp [h]
+
+private theorem Degree.LinearFramePaths.scalarDiagonal_one {ι : Type*} [DecidableEq ι] (i : ι) :
+    scalarDiagonal i 1 = 1 := by simp [scalarDiagonal]
+
+private theorem
+    Degree.LinearFramePaths.continuous_scalarDiagonal {ι : Type*} [DecidableEq ι] (i : ι) :
+    Continuous (scalarDiagonal i) := by
+  apply continuous_pi
+  intro k
+  apply continuous_pi
+  intro l
+  simp only [scalarDiagonal, Matrix.diagonal_apply]
+  by_cases hkl : k = l
+  · simp only [hkl, ite_true]
+    by_cases hli : l = i
+    · simp only [hli, ite_true]
+      fun_prop
+    · simp only [hli, ite_false]
+      fun_prop
+  · simp only [hkl, ite_false]
+    fun_prop
+
+private def
+    Degree.LinearFramePaths.determinantComponent {ι : Type*} [Fintype ι] [DecidableEq ι] (σ : ℝ) :
+    TopologicalSpace.Opens (Matrix ι ι ℝ) :=
+  ⟨{A | 0 < σ * Matrix.det A},
+    isOpen_lt continuous_const (continuous_const.mul continuous_id.matrix_det)⟩
+
+private def
+    Degree.LinearFramePaths.diagonalPoint {ι : Type*} [Fintype ι] [DecidableEq ι] (i : ι) {σ : ℝ}
+    (A : determinantComponent (ι := ι) σ) : determinantComponent (ι := ι) σ :=
+  ⟨scalarDiagonal i (Matrix.det (A : Matrix ι ι ℝ)),
+    by
+    change 0 < σ * Matrix.det (scalarDiagonal i (Matrix.det (A : Matrix ι ι ℝ)))
+    rw [det_scalarDiagonal]
+    exact A.property⟩
+
+private theorem
+    Degree.LinearFramePaths.joined_diagonal_to_matrix {ι : Type*} [Fintype ι] [DecidableEq ι]
+    [Nontrivial ι] (i : ι) {σ : ℝ} (A : determinantComponent (ι := ι) σ) :
+    Joined (diagonalPoint i A) A := by
+  have ha : Matrix.det (A : Matrix ι ι ℝ) ≠ 0 := by
+    intro hz
+    have hh : 0 < σ * Matrix.det (A : Matrix ι ι ℝ) := A.property
+    rw [hz, MulZeroClass.mul_zero] at hh
+    exact lt_irrefl _ hh
+  let N : Matrix.SpecialLinearGroup ι ℝ :=
+    ⟨scalarDiagonal i (Matrix.det (A : Matrix ι ι ℝ))⁻¹ * (A : Matrix ι ι ℝ), by
+      rw [Matrix.det_mul, det_scalarDiagonal, inv_mul_cancel₀ ha]⟩
+  let ψ : Matrix.SpecialLinearGroup ι ℝ → determinantComponent (ι := ι) σ := fun L =>
+    ⟨scalarDiagonal i (Matrix.det (A : Matrix ι ι ℝ)) * (L : Matrix ι ι ℝ),
+      by
+      change 0 < σ * Matrix.det (scalarDiagonal i (Matrix.det (A : Matrix ι ι ℝ)) * L.val)
+      rw [Matrix.det_mul, det_scalarDiagonal, L.property, mul_one]
+      exact A.property⟩
+  have hψ : Continuous ψ := (continuous_const.mul continuous_subtype_val).subtype_mk _
+  have h0 : ψ 1 = diagonalPoint i A := by
+    apply Subtype.ext
+    change scalarDiagonal i (Matrix.det (A : Matrix ι ι ℝ)) * 1 = _
+    rw [mul_one]
+    rfl
+  have h1 : ψ N = A := by
+    apply Subtype.ext
+    change
+      scalarDiagonal i (Matrix.det (A : Matrix ι ι ℝ)) *
+          (scalarDiagonal i (Matrix.det (A : Matrix ι ι ℝ))⁻¹ * (A : Matrix ι ι ℝ)) =
+        _
+    rw [← mul_assoc, scalarDiagonal_mul, mul_inv_cancel₀ ha, scalarDiagonal_one, one_mul]
+  have h := (joined_one_specialLinear N).map hψ
+  rwa [h0, h1] at h
+
+private theorem
+    Degree.LinearFramePaths.joined_diagonal_points {ι : Type*} [Fintype ι] [DecidableEq ι]
+    (i : ι) {σ : ℝ} (A B : determinantComponent (ι := ι) σ) :
+    Joined (diagonalPoint i A) (diagonalPoint i B) := by
+  let g := fun t : unitInterval =>
+    (1 - (t : ℝ)) * Matrix.det (A : Matrix ι ι ℝ) + (t : ℝ) * Matrix.det (B : Matrix ι ι ℝ)
+  have hg : Continuous g := by fun_prop
+  have hpos (t : unitInterval) : 0 < σ * g t := by
+    have hh :=
+      (convex_Ioi (0 : ℝ)) A.property B.property (sub_nonneg.mpr t.property.2) t.property.1
+        (show 1 - (t : ℝ) + (t : ℝ) = 1 by ring)
+    change
+      0 <
+        (1 - (t : ℝ)) * (σ * Matrix.det (A : Matrix ι ι ℝ)) +
+          (t : ℝ) * (σ * Matrix.det (B : Matrix ι ι ℝ)) at hh
+    convert hh using 1
+    dsimp only [g]
+    ring
+  refine
+    ⟨{  toFun := fun t =>
+          ⟨scalarDiagonal i (g t),
+            by
+            change 0 < σ * Matrix.det (scalarDiagonal i (g t))
+            rw [det_scalarDiagonal]
+            exact hpos t⟩
+        continuous_toFun :=
+          ((continuous_scalarDiagonal i).comp hg).subtype_mk
+            (fun t => by
+              change 0 < σ * Matrix.det (scalarDiagonal i (g t))
+              rw [det_scalarDiagonal]
+              exact hpos t)
+        source' := ?_
+        target' := ?_ }⟩
+  · apply Subtype.ext
+    simp [g, diagonalPoint]
+  · apply Subtype.ext
+    simp [g, diagonalPoint]
+
+private theorem Degree.LinearFramePaths.joined_determinantComponent {ι : Type*} [Fintype ι]
+    [DecidableEq ι] [Nontrivial ι] {σ : ℝ} (A B : determinantComponent (ι := ι) σ) : Joined A B :=
+  by
+  let i := Classical.choice (inferInstance : Nonempty ι)
+  exact
+    (joined_diagonal_to_matrix i A).symm.trans
+      ((joined_diagonal_points i A B).trans (joined_diagonal_to_matrix i B))
+
+private theorem
+    Degree.SupportedGerms.exists_linearEquiv_with_det {B ι : Type*} [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [FiniteDimensional ℝ B] [Finite ι] (b : Module.Basis ι ℝ B) (i : ι) {r : ℝ}
+    (hr : r ≠ 0) : ∃ R : B ≃L[ℝ] B, R.toLinearMap.det = r := by
+  classical
+  let := Fintype.ofFinite ι
+  let L : B →ₗ[ℝ] B := Matrix.toLin b b (Degree.LinearFramePaths.scalarDiagonal i r)
+  have hdet : L.det = r := by
+    rw [← LinearMap.det_toMatrix b L]
+    change
+      Matrix.det
+          (LinearMap.toMatrix b b
+            (Matrix.toLin b b (Degree.LinearFramePaths.scalarDiagonal i r))) =
+        r
+    rw [LinearMap.toMatrix_toLin]
+    exact Degree.LinearFramePaths.det_scalarDiagonal i r
+  have hker : L.ker = ⊥ := by
+    by_contra hk
+    exact hr (hdet.symm.trans (LinearMap.det_eq_zero_iff_ker_ne_bot.mpr hk))
+  have hi : Function.Injective L := LinearMap.ker_eq_bot.mp hker
+  have hbij : Function.Bijective L :=
+    ⟨hi, (LinearMap.injective_iff_surjective_of_finrank_eq_finrank rfl).mp hi⟩
+  exact ⟨(LinearEquiv.ofBijective L hbij).toContinuousLinearEquiv, hdet⟩
+
+private theorem
+    Degree.SupportedGerms.exists_normal_det_correction {A B ι : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [FiniteDimensional ℝ B] [Finite ι] (b : Module.Basis ι ℝ B) (i : ι)
+    (C : (A × B) ≃L[ℝ] (A × B)) :
+    ∃ R : B ≃L[ℝ] B,
+      (((ContinuousLinearEquiv.refl ℝ A).prodCongr R).toContinuousLinearMap.comp
+            C.toContinuousLinearMap).toLinearMap.det =
+        1 := by
+  classical
+  let := Fintype.ofFinite ι
+  have hne : C.toLinearMap.det ≠ 0 := C.toLinearEquiv.isUnit_det'.ne_zero
+  obtain ⟨R, hR⟩ := exists_linearEquiv_with_det b i (inv_ne_zero hne)
+  refine ⟨R, ?_⟩
+  change LinearMap.det ((LinearMap.id.prodMap R.toLinearMap).comp C.toLinearMap) = 1
+  rw [LinearMap.det_comp, LinearMap.det_prodMap, LinearMap.det_id, one_mul, hR,
+    inv_mul_cancel₀ hne]
+
+private theorem Degree.SupportedGerms.exists_supported_disk_germ_alignment {A B ι κ : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [FiniteDimensional ℝ B] [Finite ι] [Finite κ] [Nontrivial κ]
+    (b : Module.Basis ι ℝ B) (i : ι) (basis : Module.Basis κ ℝ (A × B))
+    (Φ : PartialDiffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, A × B) (A × B) (A × B) ∞)
+    (h0 : (0 : A × B) ∈ Φ.source) (hΦ0 : Φ 0 = 0) {U : Set (A × B)} (hU : IsOpen U)
+    (h0U : (0 : A × B) ∈ U) :
+    ∃ (d : Diffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, A × B) (A × B) (A × B) ∞) (K : Set (A × B)),
+      IsCompact K ∧
+        K ⊆ U ∧
+          Nonempty (Smale.SupportedDiffeomorph.SupportedRelativeIsotopy d K {0}) ∧
+            (fun x : A => d (Φ (x, 0))) =ᶠ[𝓝 (0 : A)] (fun x => (x, (0 : B))) := by
+  classical
+  let := Fintype.ofFinite ι
+  let := Fintype.ofFinite κ
+  have ht0 : (0 : A × B) ∈ Φ.target := hΦ0 ▸ Φ.map_source' h0
+  have hi0 : Φ.symm 0 = 0 := by
+    have hh := Φ.left_inv' h0
+    rwa [hΦ0] at hh
+  have hi : ContDiffOn ℝ ∞ (Φ.symm : (A × B) → A × B) Φ.target := Φ.contMDiffOn_invFun.contDiffOn
+  have hib : Function.Bijective (fderiv ℝ Φ.symm 0) := by
+    have hh := Smale.PartialChart.bijective_mfderiv Φ.symm ht0
+    change
+      Function.Bijective (mfderiv 𝓘(ℝ, A × B) 𝓘(ℝ, A × B) Φ.symm 0 : (A × B) →L[ℝ] (A × B)) at hh
+    rwa [mfderiv_eq_fderiv] at hh
+  let C := (LinearEquiv.ofBijective (fderiv ℝ Φ.symm 0).toLinearMap hib).toContinuousLinearEquiv
+  obtain ⟨R, hR⟩ := exists_normal_det_correction b i C
+  let T := (ContinuousLinearEquiv.refl ℝ A).prodCongr R
+  let f : (A × B) → A × B := T ∘ Φ.symm
+  have hf : ContDiffOn ℝ ∞ f (U ∩ Φ.target) :=
+    T.contDiff.comp_contDiffOn (hi.mono Set.inter_subset_right)
+  have hf0 : f 0 = 0 := by simp only [f, Function.comp_apply, hi0, map_zero]
+  have hfi :=
+    ((hi.contDiffAt (Φ.open_target.mem_nhds ht0)).differentiableAt (by simp)).hasFDerivAt
+  have hdf : fderiv ℝ f 0 = T.toContinuousLinearMap.comp C.toContinuousLinearMap :=
+    (T.toContinuousLinearMap.hasFDerivAt.comp 0 hfi).fderiv
+  have hfb : Function.Bijective (fderiv ℝ f 0) := by
+    rw [hdf]
+    exact T.bijective.comp C.bijective
+  have hdet : (fderiv ℝ f 0).toLinearMap.det = 1 := by
+    rw [hdf]
+    exact hR
+  obtain ⟨d, K, hK, hKU, hH, hgerm⟩ :=
+    realizes_local_germ basis (hU.inter Φ.open_target) ⟨h0U, ht0⟩ hf hf0 hfb hdet
+  refine ⟨d, K, hK, hKU.trans Set.inter_subset_left, hH, ?_⟩
+  have hΦt : Filter.Tendsto Φ (𝓝 (0 : A × B)) (𝓝 0) := by
+    have hh := Φ.toOpenPartialHomeomorph.continuousAt h0
+    change Filter.Tendsto Φ (𝓝 (0 : A × B)) (𝓝 (Φ 0)) at hh
+    rwa [hΦ0] at hh
+  have hcore : Filter.Tendsto (fun x : A => (x, (0 : B))) (𝓝 0) (𝓝 (0 : A × B)) :=
+    (continuous_id.prodMk continuous_const).tendsto 0
+  filter_upwards [(hgerm.comp_tendsto hΦt).comp_tendsto hcore,
+    hcore (Φ.open_source.mem_nhds h0)] with x hx hxsource
+  change d (Φ (x, 0)) = f (Φ (x, 0)) at hx
+  rw [hx]
+  change T (Φ.symm (Φ (x, 0))) = (x, 0)
+  have hinv : Φ.symm (Φ (x, 0)) = (x, 0) := Φ.left_inv' hxsource
+  rw [hinv]
+  simp [T]
+
+private theorem Degree.SupportedGerms.exists_native_disk_germ_alignment {A B E H M ι κ : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [FiniteDimensional ℝ B] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ E H} [TopologicalSpace M] [ChartedSpace H M]
+    [T2Space M] [Finite ι] [Finite κ] [Nontrivial κ] (b : Module.Basis ι ℝ B) (i : ι)
+    (basis : Module.Basis κ ℝ (A × B)) (Φ Ψ : PartialDiffeomorph 𝓘(ℝ, A × B) J (A × B) M ∞)
+    (hΦ0 : (0 : A × B) ∈ Φ.source) (hΨ0 : (0 : A × B) ∈ Ψ.source) (hcenter : Φ 0 = Ψ 0) :
+    ∃ (D : Diffeomorph J J M M ∞) (K : Set M),
+      IsCompact K ∧
+        K ⊆ Ψ.target ∧
+          Nonempty (Smale.SupportedDiffeomorph.SupportedRelativeIsotopy D K {Ψ 0}) ∧
+            (fun x : A => D (Φ (x, 0))) =ᶠ[𝓝 (0 : A)] (fun x => Ψ (x, (0 : B))) := by
+  classical
+  let := Fintype.ofFinite ι
+  let := Fintype.ofFinite κ
+  let Θ := Φ.trans Ψ.symm
+  have hΘ0 : (0 : A × B) ∈ Θ.source := by
+    refine ⟨hΦ0, ?_⟩
+    change Φ 0 ∈ Ψ.target
+    rw [hcenter]
+    exact Ψ.map_source' hΨ0
+  have hΘzero : Θ 0 = 0 := by
+    change Ψ.symm (Φ 0) = 0
+    rw [hcenter]
+    exact Ψ.left_inv' hΨ0
+  obtain ⟨d, L, hL, hLsource, ⟨Hiso⟩, hgerm⟩ :=
+    exists_supported_disk_germ_alignment b i basis Θ hΘ0 hΘzero Ψ.open_source hΨ0
+  let D := Smale.SupportedDiffeomorph.extension Ψ d hL hLsource Hiso.endpoint_fixed_outside
+  have hfixed : ∀ x ∈ Ψ.source, Ψ x ∈ ({Ψ 0} : Set M) → x ∈ ({0} : Set (A × B)) := by
+    intro x hx hh
+    exact
+      Set.mem_singleton_iff.mpr
+        (Ψ.toOpenPartialHomeomorph.injOn hx hΨ0 (Set.mem_singleton_iff.mp hh))
+  have HD := Hiso.extension Ψ hL hLsource hfixed
+  refine
+    ⟨D, Ψ '' L, hL.image_of_continuousOn (Ψ.contMDiffOn_toFun.continuousOn.mono hLsource), ?_,
+      ⟨HD⟩, ?_⟩
+  · rintro y ⟨x, hx, rfl⟩
+    exact Ψ.map_source' (hLsource hx)
+  · have hcore : Filter.Tendsto (fun x : A => (x, (0 : B))) (𝓝 0) (𝓝 (0 : A × B)) :=
+      (continuous_id.prodMk continuous_const).tendsto 0
+    filter_upwards [hgerm, hcore (Θ.open_source.mem_nhds hΘ0)] with x hx hxsource
+    have ht : Φ (x, 0) ∈ Ψ.target := hxsource.2
+    have hback : Ψ (Θ (x, 0)) = Φ (x, 0) := Ψ.right_inv' ht
+    calc
+      D (Φ (x, 0)) = D (Ψ (Θ (x, 0))) := congrArg D hback.symm
+      _ = Ψ (d (Θ (x, 0))) :=
+        (Smale.SupportedDiffeomorph.extension_chart Ψ d hL hLsource Hiso.endpoint_fixed_outside
+          (Ψ.map_target' ht))
+      _ = Ψ (x, 0) := congrArg Ψ hx
+
+private def
+    Smale.SmoothRadial.radialMap {N : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N] (φ : ℝ → ℝ)
+    (x : N) : N :=
+  φ (‖x‖ ^ 2) • x
+
+private theorem
+    Smale.SmoothRadial.norm_radialMap {N : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    {φ : ℝ → ℝ} (hpos : ∀ s, 0 < φ s) (x : N) : ‖radialMap φ x‖ = φ (‖x‖ ^ 2) * ‖x‖ := by
+  rw [radialMap, norm_smul, Real.norm_eq_abs, abs_of_pos (hpos _)]
+
+private theorem Smale.SmoothRadial.radius_strictMono {φ : ℝ → ℝ} (hpos : ∀ s, 0 < φ s)
+    (hmono : Monotone φ) : StrictMonoOn (fun r => φ (r ^ 2) * r) (Set.Ici 0) := by
+  intro r hr s hs hrs
+  have hsq : r ^ 2 ≤ s ^ 2 := (sq_le_sq₀ hr hs).mpr hrs.le
+  exact (mul_lt_mul_of_pos_left hrs (hpos _)).trans_le (mul_le_mul_of_nonneg_right (hmono hsq) hs)
+
+private theorem Smale.SmoothRadial.radialMap_injective {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] {φ : ℝ → ℝ} (hpos : ∀ s, 0 < φ s) (hmono : Monotone φ) :
+    Function.Injective (radialMap (N := N) φ) := by
+  intro x y hxy
+  have hn : ‖x‖ = ‖y‖ := by
+    apply (radius_strictMono hpos hmono).injOn (norm_nonneg x) (norm_nonneg y)
+    simpa only [norm_radialMap hpos] using congrArg Norm.norm hxy
+  change φ (‖x‖ ^ 2) • x = φ (‖y‖ ^ 2) • y at hxy
+  rw [hn] at hxy
+  exact smul_right_injective N (hpos _).ne' hxy
+
+private theorem Smale.SmoothRadial.radialMap_surjective {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] {φ : ℝ → ℝ} (hc : Continuous φ) {R : ℝ} (hR : 0 < R)
+    (hout : ∀ s, R ^ 2 ≤ s → φ s = 1) : Function.Surjective (radialMap (N := N) φ) := by
+  intro y
+  by_cases hy : R ≤ ‖y‖
+  · refine ⟨y, ?_⟩
+    rw [radialMap, hout _ ((sq_le_sq₀ hR.le (norm_nonneg y)).mpr hy), one_smul]
+  by_cases hyzero : y = 0
+  · subst y
+    exact ⟨0, by simp only [radialMap, smul_zero]⟩
+  have hypos : 0 < ‖y‖ := norm_pos_iff.mpr hyzero
+  have htarget : ‖y‖ ∈ Set.Icc (φ (0 ^ 2) * 0) (φ (R ^ 2) * R) := by
+    simpa only [MulZeroClass.mul_zero, hout _ le_rfl, one_mul, Set.mem_Icc] using
+      And.intro hypos.le (le_of_not_ge hy)
+  have hcont : Continuous (fun r : ℝ => φ (r ^ 2) * r) :=
+    (hc.comp (continuous_id.pow 2)).mul continuous_id
+  obtain ⟨r, hr, hradius⟩ := intermediate_value_Icc hR.le hcont.continuousOn htarget
+  change φ (r ^ 2) * r = ‖y‖ at hradius
+  let x : N := (r / ‖y‖) • y
+  have hnorm : ‖x‖ = r := by
+    change ‖(r / ‖y‖) • y‖ = r
+    rw [norm_smul, Real.norm_eq_abs, abs_of_nonneg (div_nonneg hr.1 hypos.le),
+      div_mul_cancel₀ _ hypos.ne']
+  refine ⟨x, ?_⟩
+  change φ (‖x‖ ^ 2) • ((r / ‖y‖) • y) = y
+  rw [hnorm, smul_smul, ← mul_div_assoc, hradius, div_self hypos.ne', one_smul]
+
+private theorem Smale.SmoothRadial.contDiff_radialMap {N : Type*} [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] {φ : ℝ → ℝ} (hφ : ContDiff ℝ ∞ φ) :
+    ContDiff ℝ ∞ (radialMap (N := N) φ) :=
+  (hφ.comp (contDiff_id.norm_sq ℝ)).smul contDiff_id
+
+private theorem Smale.SmoothRadial.fderiv_radialMap_apply {N : Type*} [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] {φ : ℝ → ℝ} (hφ : ContDiff ℝ ∞ φ) (x v : N) :
+    fderiv ℝ (radialMap φ) x v =
+      φ (‖x‖ ^ 2) • v + (2 * deriv φ (‖x‖ ^ 2) * Inner.inner ℝ x v) • x := by
+  have hscale :=
+    ((hφ.differentiable (by simp) (‖x‖ ^ 2)).hasDerivAt).comp_hasFDerivAt x
+      (hasStrictFDerivAt_norm_sq x).hasFDerivAt
+  have hd := hscale.smul (hasFDerivAt_id x)
+  rw [show fderiv ℝ (radialMap φ) x = _ from hd.fderiv]
+  simp only [add_apply, smul_apply, ContinuousLinearMap.id_apply,
+    ContinuousLinearMap.smulRight_apply, innerSL_apply_apply, smul_eq_mul, Function.comp_apply,
+    id_eq]
+  congr 1
+  ring_nf
+
+private theorem Smale.SmoothRadial.fderiv_radialMap_injective {N : Type*} [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] {φ : ℝ → ℝ} (hφ : ContDiff ℝ ∞ φ) (hpos : ∀ s, 0 < φ s)
+    (hmono : Monotone φ) (x : N) : Function.Injective (fderiv ℝ (radialMap φ) x) := by
+  have hzero : ∀ v : N, fderiv ℝ (radialMap φ) x v = 0 → v = 0 := by
+    intro v hv
+    have heq := congrArg (fun w : N => Inner.inner ℝ v w) hv
+    rw [fderiv_radialMap_apply hφ, inner_add_right, inner_smul_right, inner_smul_right,
+      real_inner_self_eq_norm_sq, real_inner_comm v x, inner_zero_right] at heq
+    have hd : 0 ≤ deriv φ (‖x‖ ^ 2) := hmono.deriv_nonneg
+    have hnonneg : 0 ≤ 2 * deriv φ (‖x‖ ^ 2) * (Inner.inner ℝ v x) ^ 2 := by positivity
+    have hterm : φ (‖x‖ ^ 2) * ‖v‖ ^ 2 ≤ 0 := by nlinarith
+    have hsq : ‖v‖ ^ 2 ≤ 0 := by
+      by_contra hn
+      exact (not_lt_of_ge hterm) (mul_pos (hpos _) (lt_of_not_ge hn))
+    exact norm_eq_zero.mp (by nlinarith [norm_nonneg v])
+  intro v w hvw
+  have hsub : fderiv ℝ (radialMap φ) x (v - w) = 0 := by rw [map_sub, hvw, sub_self]
+  exact sub_eq_zero.mp (hzero (v - w) hsub)
+
+private theorem Smale.SmoothRadial.isInvertible_fderiv_radialMap {N : Type*} [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] [FiniteDimensional ℝ N] {φ : ℝ → ℝ} (hφ : ContDiff ℝ ∞ φ)
+    (hpos : ∀ s, 0 < φ s) (hmono : Monotone φ) (x : N) :
+    (fderiv ℝ (radialMap (N := N) φ) x).IsInvertible := by
+  let L :=
+    (LinearEquiv.ofInjectiveEndo (fderiv ℝ (radialMap φ) x).toLinearMap
+        (fderiv_radialMap_injective hφ hpos hmono x)).toContinuousLinearEquiv
+  exact ⟨L, by ext v; rfl⟩
+
+private def
+    Smale.SmoothRadial.diffeomorph {N : Type*} [NormedAddCommGroup N] [InnerProductSpace ℝ N]
+    [FiniteDimensional ℝ N] {φ : ℝ → ℝ} (hφ : ContDiff ℝ ∞ φ) (hpos : ∀ s, 0 < φ s)
+    (hmono : Monotone φ) {R : ℝ} (hR : 0 < R) (hout : ∀ s, R ^ 2 ≤ s → φ s = 1) :
+    Diffeomorph 𝓘(ℝ, N) 𝓘(ℝ, N) N N ∞ := by
+  have hlocal : IsLocalDiffeomorph 𝓘(ℝ, N) 𝓘(ℝ, N) ∞ (radialMap (N := N) φ) := by
+    intro x
+    apply
+      Smale.isLocalDiffeomorphAt_of_contMDiffOn isOpen_univ (Set.mem_univ x)
+        (contDiff_radialMap hφ).contMDiff.contMDiffOn
+    rw [mfderiv_eq_fderiv]
+    exact isInvertible_fderiv_radialMap hφ hpos hmono x
+  exact
+    hlocal.diffeomorphOfBijective
+      ⟨radialMap_injective hpos hmono, radialMap_surjective hφ.continuous hR hout⟩
+
+private def Smale.SmoothRadial.shrinkTimeFactor (a t : ℝ) : ℝ :=
+  1 + (a - 1) * Real.smoothTransition t
+
+private theorem Smale.SmoothRadial.shrinkTimeFactor_bounds {a : ℝ} (ha₁ : a ≤ 1) (t : ℝ) :
+    a ≤ shrinkTimeFactor a t ∧ shrinkTimeFactor a t ≤ 1 := by
+  have ht₀ := Real.smoothTransition.nonneg t
+  have ht₁ := Real.smoothTransition.le_one t
+  unfold shrinkTimeFactor
+  constructor <;> nlinarith
+
+private theorem Smale.SmoothRadial.shrinkTimeFactor_zero (a : ℝ) : shrinkTimeFactor a 0 = 1 := by
+  simp only [shrinkTimeFactor, Real.smoothTransition.zero, MulZeroClass.mul_zero, add_zero]
+
+private theorem Smale.SmoothRadial.shrinkTimeFactor_one (a : ℝ) : shrinkTimeFactor a 1 = a := by
+  simp only [shrinkTimeFactor, Real.smoothTransition.one, mul_one]
+  ring
+
+private theorem Smale.SmoothRadial.contDiff_shrinkTimeFactor (a : ℝ) :
+    ContDiff ℝ ∞ (shrinkTimeFactor a) :=
+  contDiff_const.add (contDiff_const.mul (Real.smoothTransition.contDiff (n := ⊤)))
+
+private def Degree.DiskShrinking.scale (R a s : ℝ) : ℝ :=
+  a + (1 - a) * Real.smoothTransition ((s - 1) / (R ^ 2 - 1))
+
+private theorem Degree.DiskShrinking.contDiff_scale (R a : ℝ) : ContDiff ℝ ∞ (scale R a) :=
+  contDiff_const.add
+    (contDiff_const.mul
+      ((Real.smoothTransition.contDiff (n := ⊤)).comp
+        ((contDiff_id.sub contDiff_const).div_const _)))
+
+private theorem Degree.DiskShrinking.scale_pos {a : ℝ} (ha : 0 < a) (ha₁ : a ≤ 1) (R s : ℝ) :
+    0 < scale R a s :=
+  add_pos_of_pos_of_nonneg ha (mul_nonneg (sub_nonneg.mpr ha₁) (Real.smoothTransition.nonneg _))
+
+private theorem Degree.DiskShrinking.scale_monotone {R a : ℝ} (hR : 1 < R) (ha₁ : a ≤ 1) :
+    Monotone (scale R a) := by
+  have hden : 0 < R ^ 2 - 1 := by nlinarith
+  intro s t hst
+  exact
+    add_le_add_right
+      (mul_le_mul_of_nonneg_left
+        (Real.smoothTransition.monotone
+          (div_le_div_of_nonneg_right (sub_le_sub_right hst 1) hden.le))
+        (sub_nonneg.mpr ha₁))
+      a
+
+private theorem Degree.DiskShrinking.scale_inner {R : ℝ} (hR : 1 < R) (a : ℝ) {s : ℝ} (hs : s ≤ 1) :
+    scale R a s = a := by
+  have hden : 0 < R ^ 2 - 1 := by nlinarith
+  rw [scale,
+    Real.smoothTransition.zero_of_nonpos
+      (div_nonpos_of_nonpos_of_nonneg (sub_nonpos.mpr hs) hden.le)]
+  simp only [MulZeroClass.mul_zero, add_zero]
+
+private theorem
+    Degree.DiskShrinking.scale_outer {R : ℝ} (hR : 1 < R) (a : ℝ) {s : ℝ} (hs : R ^ 2 ≤ s) :
+    scale R a s = 1 := by
+  have hden : 0 < R ^ 2 - 1 := by nlinarith
+  rw [scale, Real.smoothTransition.one_of_one_le ((le_div_iff₀ hden).mpr (by linarith))]
+  ring
+
+private theorem Degree.DiskShrinking.scale_one (R s : ℝ) : scale R 1 s = 1 := by
+  simp only [scale, sub_self, MulZeroClass.zero_mul, add_zero]
+
+private def Degree.DiskShrinking.family {N : Type*} [NormedAddCommGroup N] [InnerProductSpace ℝ N]
+    (R a : ℝ) (p : ℝ × N) : N :=
+  Smale.SmoothRadial.radialMap (scale R (Smale.SmoothRadial.shrinkTimeFactor a p.1)) p.2
+
+private theorem Degree.DiskShrinking.contMDiff_family {N : Type*} [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] (R a : ℝ) :
+    ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, N)) 𝓘(ℝ, N) ∞ (family (N := N) R a) := by
+  have ht :
+    ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, N)) 𝓘(ℝ, ℝ) ∞
+      (fun p : ℝ × N => Smale.SmoothRadial.shrinkTimeFactor a p.1) :=
+    (Smale.SmoothRadial.contDiff_shrinkTimeFactor a).contMDiff.comp contMDiff_fst
+  have hn : ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, N)) 𝓘(ℝ, ℝ) ∞ (fun p : ℝ × N => ‖p.2‖ ^ 2) :=
+    (show ContDiff ℝ ∞ (fun x : N => ‖x‖ ^ 2) from contDiff_id.norm_sq ℝ).contMDiff.comp
+      contMDiff_snd
+  have hz :
+    ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, N)) 𝓘(ℝ, ℝ) ∞ (fun p : ℝ × N => (‖p.2‖ ^ 2 - 1) / (R ^ 2 - 1)) :=
+    by
+    simpa only [div_eq_mul_inv, Pi.mul_def, Pi.sub_def] using
+      (hn.sub contMDiff_const).mul (contMDiff_const (c := (R ^ 2 - 1)⁻¹))
+  exact
+    (ht.add
+          ((contMDiff_const.sub ht).mul
+            ((Real.smoothTransition.contDiff (n := ⊤)).contMDiff.comp hz))).smul
+      contMDiff_snd
+
+private theorem Degree.DiskShrinking.family_zero {N : Type*} [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] (R a : ℝ) (x : N) : family R a (0, x) = x := by
+  simp only [family, Smale.SmoothRadial.shrinkTimeFactor_zero, Smale.SmoothRadial.radialMap,
+    scale_one, one_smul]
+
+private theorem Degree.DiskShrinking.family_slices {N : Type*} [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] [FiniteDimensional ℝ N] {R a : ℝ} (hR : 1 < R) (ha : 0 < a)
+    (ha₁ : a ≤ 1) (t : ℝ) :
+    ∃ D : Diffeomorph 𝓘(ℝ, N) 𝓘(ℝ, N) N N ∞, ∀ x, D x = family R a (t, x) := by
+  have ht := Smale.SmoothRadial.shrinkTimeFactor_bounds ha₁ t
+  exact
+    ⟨Smale.SmoothRadial.diffeomorph (contDiff_scale R _) (scale_pos (ha.trans_le ht.1) ht.2 R)
+        (scale_monotone hR ht.2) (zero_lt_one.trans hR) (fun _ hs => scale_outer hR _ hs),
+      fun _ => rfl⟩
+
+private theorem Degree.DiskShrinking.family_outer {N : Type*} [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] {R : ℝ} (hR : 1 < R) (a t : ℝ) {x : N}
+    (hx : R ≤ ‖x‖) : family R a (t, x) = x := by
+  rw [family, Smale.SmoothRadial.radialMap,
+    scale_outer hR _ ((sq_le_sq₀ (zero_lt_one.trans hR).le (norm_nonneg x)).mpr hx), one_smul]
+
+private theorem Degree.DiskShrinking.family_one_inner {N : Type*} [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] {R : ℝ} (hR : 1 < R) (a : ℝ) {x : N}
+    (hx : ‖x‖ ≤ 1) : family R a (1, x) = a • x := by
+  rw [family, Smale.SmoothRadial.radialMap, Smale.SmoothRadial.shrinkTimeFactor_one,
+    scale_inner hR a (by nlinarith [norm_nonneg x])]
+
+private theorem Degree.DiskShrinking.family_origin {N : Type*} [NormedAddCommGroup N]
+    [InnerProductSpace ℝ N] (R a t : ℝ) : family R a (t, (0 : N)) = 0 := by
+  simp only [family, Smale.SmoothRadial.radialMap, smul_zero]
+
+private theorem
+    Degree.DiskShrinking.exists_larger_closedBall_subset {D : Type*} [NormedAddCommGroup D]
+    [InnerProductSpace ℝ D] [FiniteDimensional ℝ D] {U : Set D} (hU : IsOpen U)
+    (hunit : Metric.closedBall (0 : D) 1 ⊆ U) :
+    ∃ R : ℝ, 1 < R ∧ Metric.closedBall (0 : D) R ⊆ U := by
+  let T : Set ℝ := {r | ∀ x ∈ Metric.closedBall (0 : D) 1, r • x ∈ U}
+  have hT : IsOpen T :=
+    Smale.MorsePerturbation.isOpen_forall_mem_compact (ProperSpace.isCompact_closedBall (0 : D) 1)
+      (hU.preimage (continuous_fst.smul continuous_snd))
+  have h1 : (1 : ℝ) ∈ T := by
+    intro x hx
+    simpa only [one_smul] using hunit hx
+  obtain ⟨δ, hδ, hδT⟩ := Metric.mem_nhds_iff.mp (hT.mem_nhds h1)
+  let R : ℝ := 1 + δ / 2
+  have hR : 1 < R := by dsimp [R]; linarith
+  have hRpos : 0 < R := zero_lt_one.trans hR
+  have hRT : R ∈ T :=
+    hδT
+      (by
+        rw [Metric.mem_ball, Real.dist_eq, abs_of_nonneg (by dsimp [R]; linarith)]
+        dsimp [R]
+        linarith)
+  refine ⟨R, hR, ?_⟩
+  intro x hx
+  have hnorm : ‖R⁻¹ • x‖ ≤ 1 := by
+    rw [norm_smul, Real.norm_eq_abs, abs_of_pos (inv_pos.mpr hRpos)]
+    exact
+      (inv_mul_le_iff₀ hRpos).mpr (by simpa only [mul_one] using mem_closedBall_zero_iff.mp hx)
+  have hh := hRT (R⁻¹ • x) (mem_closedBall_zero_iff.mpr hnorm)
+  simpa only [smul_inv_smul₀ hRpos.ne'] using hh
+
+private theorem
+    Degree.DiskShrinking.exists_disk_ellipsoid_in_open {D Z : Type*} [NormedAddCommGroup D]
+    [InnerProductSpace ℝ D] [FiniteDimensional ℝ D] [NormedAddCommGroup Z] [InnerProductSpace ℝ Z]
+    [FiniteDimensional ℝ Z] {U : Set (D × Z)} (hU : IsOpen U)
+    (hzero : Metric.closedBall (0 : D) 1 ×ˢ {(0 : Z)} ⊆ U) :
+    ∃ R : ℝ,
+      1 < R ∧
+        ∃ L : WithLp 2 (D × Z) ≃L[ℝ] D × Z,
+          (∀ x : D, L (WithLp.toLp 2 (x, (0 : Z))) = (x, 0)) ∧
+            Set.MapsTo L (Metric.closedBall 0 R) U := by
+  obtain ⟨A, B, hA, hB, hKA, h0B, hAB⟩ :=
+    generalized_tube_lemma (ProperSpace.isCompact_closedBall (0 : D) 1)
+      (isCompact_singleton (x := (0 : Z))) hU hzero
+  obtain ⟨R, hR, hRA⟩ := exists_larger_closedBall_subset hA hKA
+  obtain ⟨ε, hε, hεB⟩ :=
+    Metric.nhds_basis_closedBall.mem_iff.mp (hB.mem_nhds (h0B (Set.mem_singleton (0 : Z))))
+  have hRpos : 0 < R := zero_lt_one.trans hR
+  let δ : ℝ := ε / R
+  have hδ : 0 < δ := div_pos hε hRpos
+  let T : Z ≃L[ℝ] Z := (LinearEquiv.smulOfNeZero ℝ Z δ hδ.ne').toContinuousLinearEquiv
+  let L : WithLp 2 (D × Z) ≃L[ℝ] D × Z :=
+    (WithLp.prodContinuousLinearEquiv 2 ℝ D Z).trans
+      ((ContinuousLinearEquiv.refl ℝ D).prodCongr T)
+  have hL (p : WithLp 2 (D × Z)) : L p = (p.fst, δ • p.snd) := rfl
+  refine ⟨R, hR, L, ?_, ?_⟩
+  · intro x
+    rw [hL]
+    change (x, δ • (0 : Z)) = (x, 0)
+    rw [smul_zero]
+  · intro p hp
+    rw [hL]
+    apply hAB
+    refine
+      ⟨hRA
+          (mem_closedBall_zero_iff.mpr
+            ((WithLp.norm_fst_le D p).trans (mem_closedBall_zero_iff.mp hp))),
+        hεB ?_⟩
+    rw [mem_closedBall_zero_iff, norm_smul, Real.norm_eq_abs, abs_of_pos hδ]
+    calc
+      δ * ‖p.snd‖ ≤ δ * R :=
+        mul_le_mul_of_nonneg_left ((WithLp.norm_snd_le D p).trans (mem_closedBall_zero_iff.mp hp))
+          hδ.le
+      _ = ε := div_mul_cancel₀ ε hRpos.ne'
+
+private theorem Smale.SupportedDiffeomorph.exists_supported_isotopy_extension {E F H H' X Y : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H'] {J : ModelWithCorners ℝ F H'}
+    [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y] [T2Space Y]
+    (Φ : PartialDiffeomorph I J X Y ∞) {A : ℝ × X → X} (hA : ContMDiff (𝓘(ℝ, ℝ).prod I) I ∞ A)
+    (hA₀ : ∀ x, A (0, x) = x) (hdiff : ∀ t, ∃ D : Diffeomorph I I X X ∞, ∀ x, D x = A (t, x))
+    {K : Set X} (hK : IsCompact K) (hKsource : K ⊆ Φ.source)
+    (hfix : ∀ t x, x ∉ K → A (t, x) = x) :
+    ∃ (B : ℝ × Y → Y) (L : Set Y),
+      IsCompact L ∧
+        L ⊆ Φ.target ∧
+          ContMDiff (𝓘(ℝ, ℝ).prod J) J ∞ B ∧
+            (∀ y, B (0, y) = y) ∧
+              (∀ t, ∃ D : Diffeomorph J J Y Y ∞, ∀ y, D y = B (t, y)) ∧
+                (∀ t y, y ∉ L → B (t, y) = y) ∧
+                  (∀ t, Set.MapsTo (fun x => A (t, x)) Φ.source Φ.source) ∧
+                    ∀ t x, x ∈ Φ.source → B (t, Φ x) = Φ (A (t, x)) := by
+  have hsource : ∀ t, Set.MapsTo (fun x => A (t, x)) Φ.source Φ.source := by
+    intro t
+    obtain ⟨D, hD⟩ := hdiff t
+    have hDfix : ∀ x ∉ K, D x = x := fun x hx => (hD x).trans (hfix t x hx)
+    have heq : (fun x => A (t, x)) = D := funext (fun x => (hD x).symm)
+    rw [heq]
+    exact mapsTo_source Φ D.toEquiv hKsource hDfix
+  let B : ℝ × Y → Y := fun q => extendMap Φ (fun x => A (q.1, x)) q.2
+  refine
+    ⟨B, Φ '' K, hK.image_of_continuousOn (Φ.contMDiffOn_toFun.continuousOn.mono hKsource), ?_,
+      contMDiff_extendFamily Φ hA hK hKsource hfix hsource, ?_, ?_, ?_, hsource, ?_⟩
+  · rintro y ⟨x, hx, rfl⟩
+    exact Φ.map_source' (hKsource hx)
+  · intro y
+    have heq : (fun x => A (0, x)) = id := funext hA₀
+    change extendMap Φ (fun x => A (0, x)) y = y
+    rw [heq]
+    exact extendMap_id Φ y
+  · intro t
+    obtain ⟨D, hD⟩ := hdiff t
+    have hDfix : ∀ x ∉ K, D x = x := fun x hx => (hD x).trans (hfix t x hx)
+    refine ⟨extension Φ D hK hKsource hDfix, ?_⟩
+    intro y
+    exact congrArg (fun f : X → X => extendMap Φ f y) (funext hD)
+  · intro t y hy
+    exact extendMap_eq_of_notMem_image Φ (hfix t) hy
+  · intro t x hx
+    exact extendMap_chart Φ (fun z => A (t, z)) hx
+
+private theorem Degree.DiskShrinking.exists_chart_disk_shrinking {D Z E H M : Type*}
+    [NormedAddCommGroup D] [InnerProductSpace ℝ D] [FiniteDimensional ℝ D] [NormedAddCommGroup Z]
+    [InnerProductSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [TopologicalSpace M] [ChartedSpace H M]
+    [T2Space M] (Φ : PartialDiffeomorph 𝓘(ℝ, D × Z) I (D × Z) M ∞)
+    (hzero : Metric.closedBall (0 : D) 1 ×ˢ {(0 : Z)} ⊆ Φ.source) {a : ℝ} (ha : 0 < a)
+    (ha₁ : a ≤ 1) :
+    ∃ K : Set M,
+      IsCompact K ∧
+        K ⊆ Φ.target ∧
+          ∃ P : Diffeomorph I I M M ∞,
+            Nonempty (Smale.SupportedDiffeomorph.SupportedRelativeIsotopy P K {Φ (0, 0)}) ∧
+              ∀ x : D, ‖x‖ ≤ 1 → P (Φ (x, 0)) = Φ (a • x, 0) := by
+  obtain ⟨R, hR, L, hLzero, hLsource⟩ := exists_disk_ellipsoid_in_open Φ.open_source hzero
+  let Ψ := L.toDiffeomorph.toPartialDiffeomorph.trans Φ
+  have hsource : Metric.closedBall (0 : WithLp 2 (D × Z)) R ⊆ Ψ.source := by
+    intro z hz
+    exact ⟨Set.mem_univ z, hLsource hz⟩
+  have htarget : Ψ.target ⊆ Φ.target := fun _ hy => hy.1
+  have hΨ (x : D) : Ψ (WithLp.toLp 2 (x, (0 : Z))) = Φ (x, 0) := by
+    change Φ (L (WithLp.toLp 2 (x, (0 : Z)))) = _
+    rw [hLzero]
+  have hΨ0 : Ψ (0 : WithLp 2 (D × Z)) = Φ (0, 0) := hΨ 0
+  have h0source : (0 : WithLp 2 (D × Z)) ∈ Ψ.source :=
+    hsource (Metric.mem_closedBall_self (zero_le_one.trans hR.le))
+  have hfix : ∀ t (z : WithLp 2 (D × Z)), z ∉ Metric.closedBall 0 R → family R a (t, z) = z := by
+    intro t z hz
+    exact family_outer hR a t (le_of_not_ge (fun hn => hz (mem_closedBall_zero_iff.mpr hn)))
+  obtain ⟨B, K, hK, hKt, hB, hB0, hBt, hBfix, -, hchart⟩ :=
+    Smale.SupportedDiffeomorph.exists_supported_isotopy_extension Ψ (contMDiff_family R a)
+      (family_zero R a) (family_slices hR ha ha₁) (ProperSpace.isCompact_closedBall 0 R) hsource
+      hfix
+  obtain ⟨P, hP⟩ := hBt 1
+  refine
+    ⟨K, hK, hKt.trans htarget, P,
+      ⟨{  family := B
+          smooth := hB
+          zero := hB0
+          one := fun y => (hP y).symm
+          slices := hBt
+          fixedOutside := hBfix
+          fixedOn := ?_ }⟩, ?_⟩
+  · intro t y hy
+    rcases Set.mem_singleton_iff.mp hy with rfl
+    rw [← hΨ0, hchart t 0 h0source, family_origin]
+  · intro x hx
+    have hn : ‖WithLp.toLp 2 (x, (0 : Z))‖ ≤ 1 := by simpa only [WithLp.norm_toLp_fst] using hx
+    have hs : WithLp.toLp 2 (x, (0 : Z)) ∈ Ψ.source :=
+      hsource (mem_closedBall_zero_iff.mpr (hn.trans hR.le))
+    have hsmul : a • WithLp.toLp 2 (x, (0 : Z)) = WithLp.toLp 2 (a • x, (0 : Z)) := by
+      change WithLp.toLp 2 (a • x, a • (0 : Z)) = _
+      rw [smul_zero]
+    rw [← hΨ x, hP, hchart 1 _ hs, family_one_inner hR a hn, hsmul, hΨ]
+
+private theorem
+    Smale.SupportedDiffeomorph.IsotopicToIdentity.symm {F H M : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [TopologicalSpace H] {J : ModelWithCorners ℝ F H} [TopologicalSpace M]
+    [ChartedSpace H M] {e : Diffeomorph J J M M ∞}
+    (he : Smale.SupportedDiffeomorph.IsotopicToIdentity e) :
+    Smale.SupportedDiffeomorph.IsotopicToIdentity e.symm := by
+  obtain ⟨A, hA, hA₀, hA₁, hdiff⟩ := he
+  let B : ℝ × M → M := fun p => e.symm (A (1 - p.1, p.2))
+  have hrev : ContMDiff 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) ∞ (fun t : ℝ => 1 - t) :=
+    (contDiff_const.sub contDiff_id).contMDiff
+  have hB : ContMDiff (𝓘(ℝ, ℝ).prod J) J ∞ B :=
+    e.symm.contMDiff.comp (hA.comp ((hrev.comp contMDiff_fst).prodMk contMDiff_snd))
+  refine ⟨B, hB, ?_, ?_, ?_⟩
+  · intro x
+    change e.symm (A (1 - 0, x)) = x
+    rw [sub_zero, hA₁, e.symm_apply_apply]
+  · intro x
+    change e.symm (A (1 - 1, x)) = e.symm x
+    rw [sub_self, hA₀]
+  · intro t
+    obtain ⟨d, hd⟩ := hdiff (1 - t)
+    refine ⟨d.trans e.symm, ?_⟩
+    intro x
+    change e.symm (A (1 - t, x)) = e.symm (d x)
+    rw [hd]
+
+private theorem Degree.SupportedGerms.exists_disk_chart_isotopy {A B E H M ι κ : Type*}
+    [NormedAddCommGroup A] [InnerProductSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup B]
+    [InnerProductSpace ℝ B] [FiniteDimensional ℝ B] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ E H} [TopologicalSpace M] [ChartedSpace H M]
+    [T2Space M] [Finite ι] [Finite κ] [Nontrivial κ] (b : Module.Basis ι ℝ B) (i : ι)
+    (basis : Module.Basis κ ℝ (A × B)) (Φ Ψ : PartialDiffeomorph 𝓘(ℝ, A × B) J (A × B) M ∞)
+    (hΦ : Metric.closedBall (0 : A) 1 ×ˢ {(0 : B)} ⊆ Φ.source)
+    (hΨ : Metric.closedBall (0 : A) 1 ×ˢ {(0 : B)} ⊆ Ψ.source) (hcenter : Φ 0 = Ψ 0) :
+    ∃ D : Diffeomorph J J M M ∞,
+      Smale.SupportedDiffeomorph.IsotopicToIdentity D ∧
+        ∀ x ∈ Metric.closedBall (0 : A) 1, D (Φ (x, 0)) = Ψ (x, 0) := by
+  classical
+  let := Fintype.ofFinite ι
+  let := Fintype.ofFinite κ
+  have hz : (0 : A × B) ∈ Metric.closedBall (0 : A) 1 ×ˢ {(0 : B)} :=
+    ⟨Metric.mem_closedBall_self zero_le_one, rfl⟩
+  obtain ⟨D, K, -, -, ⟨HD⟩, hgerm⟩ :=
+    exists_native_disk_germ_alignment b i basis Φ Ψ (hΦ hz) (hΨ hz) hcenter
+  obtain ⟨ε, hε, hεeq⟩ := Metric.nhds_basis_closedBall.mem_iff.mp hgerm
+  let a : ℝ := Min.min 1 ε
+  have ha : 0 < a := lt_min zero_lt_one hε
+  have ha1 : a ≤ 1 := min_le_left _ _
+  obtain ⟨KΦ, -, -, P, ⟨HP⟩, hP⟩ := Degree.DiskShrinking.exists_chart_disk_shrinking Φ hΦ ha ha1
+  obtain ⟨KΨ, -, -, Q, ⟨HQ⟩, hQ⟩ := Degree.DiskShrinking.exists_chart_disk_shrinking Ψ hΨ ha ha1
+  refine
+    ⟨(P.trans D).trans Q.symm,
+      (HP.isotopicToIdentity.trans HD.isotopicToIdentity).trans HQ.isotopicToIdentity.symm, ?_⟩
+  intro x hx
+  have hn : ‖x‖ ≤ 1 := mem_closedBall_zero_iff.mp hx
+  have hsmall : a • x ∈ Metric.closedBall (0 : A) ε := by
+    rw [mem_closedBall_zero_iff, norm_smul, Real.norm_eq_abs, abs_of_pos ha]
+    exact (mul_le_of_le_one_right ha.le hn).trans (min_le_right _ _)
+  have heq : D (Φ (a • x, 0)) = Ψ (a • x, 0) := hεeq hsmall
+  change Q.symm (D (P (Φ (x, 0)))) = Ψ (x, 0)
+  rw [hP x hn, heq, ← hQ x hn, Q.symm_apply_apply]
+
+private theorem Degree.DiskShrinking.exists_embedded_disk_isotopy_of_same_center {D E M : Type*}
+    [NormedAddCommGroup D] [InnerProductSpace ℝ D] [FiniteDimensional ℝ D] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f g : D → M}
+    (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f) (hg : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ g)
+    (hfi : Set.InjOn f (Metric.closedBall (0 : D) 1))
+    (hgi : Set.InjOn g (Metric.closedBall (0 : D) 1))
+    (hfd : ∀ x ∈ Metric.closedBall (0 : D) 1, Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x))
+    (hgd : ∀ x ∈ Metric.closedBall (0 : D) 1, Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) g x))
+    (n : ℕ) (hn : 0 < n) (hdim : Module.finrank ℝ D + n = Module.finrank ℝ E)
+    (hE : 2 ≤ Module.finrank ℝ E) (hcenter : f 0 = g 0) :
+    ∃ P : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞,
+      Smale.SupportedDiffeomorph.IsotopicToIdentity P ∧
+        ∀ x ∈ Metric.closedBall (0 : D) 1, P (f x) = g x := by
+  classical
+  let B := EuclideanSpace ℝ (Fin n)
+  obtain ⟨ε, hε, Φ, hΦprod, hΦzero, -⟩ :=
+    Smale.exists_tubularNeighborhood_in_open_of_embedded_closedBall hf hfi hfd n hdim isOpen_univ
+      (Set.mapsTo_univ _ _)
+  obtain ⟨δ, hδ, Ψ, hΨprod, hΨzero, -⟩ :=
+    Smale.exists_tubularNeighborhood_in_open_of_embedded_closedBall hg hgi hgd n hdim isOpen_univ
+      (Set.mapsTo_univ _ _)
+  have hΦ : Metric.closedBall (0 : D) 1 ×ˢ {(0 : B)} ⊆ Φ.source := by
+    rintro ⟨x, z⟩ ⟨hx, hz⟩
+    rcases Set.mem_singleton_iff.mp hz with rfl
+    exact hΦprod ⟨hx, Metric.mem_closedBall_self hε.le⟩
+  have hΨ : Metric.closedBall (0 : D) 1 ×ˢ {(0 : B)} ⊆ Ψ.source := by
+    rintro ⟨x, z⟩ ⟨hx, hz⟩
+    rcases Set.mem_singleton_iff.mp hz with rfl
+    exact hΨprod ⟨hx, Metric.mem_closedBall_self hδ.le⟩
+  have hcenter' : Φ 0 = Ψ 0 := by
+    change Φ (0, 0) = Ψ (0, 0)
+    rw [hΦzero 0 (Metric.mem_closedBall_self zero_le_one),
+      hΨzero 0 (Metric.mem_closedBall_self zero_le_one), hcenter]
+  have hB : 0 < Module.finrank ℝ B := by simpa only [B, finrank_euclideanSpace_fin] using hn
+  have hDB : 2 ≤ Module.finrank ℝ (D × B) := by
+    simpa only [Module.finrank_prod, B, finrank_euclideanSpace_fin, hdim] using hE
+  let _ : Nontrivial (Fin (Module.finrank ℝ (D × B))) := Fin.nontrivial_iff_two_le.mpr hDB
+  obtain ⟨P, hP, hformula⟩ :=
+    Degree.SupportedGerms.exists_disk_chart_isotopy (Module.finBasis ℝ B) ⟨0, hB⟩
+      (Module.finBasis ℝ (D × B)) Φ Ψ hΦ hΨ hcenter'
+  refine ⟨P, hP, ?_⟩
+  intro x hx
+  rw [← hΦzero x hx, hformula x hx, hΨzero x hx]
+
+private theorem Smale.SupportedDiffeomorph.exists_supported_pointMoving {E F H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [TopologicalSpace H] {J : ModelWithCorners ℝ F H} [TopologicalSpace M]
+    [ChartedSpace H M] [T2Space M] (Φ : PartialDiffeomorph 𝓘(ℝ, E) J E M ∞) {x : E}
+    (hx : x ∈ Φ.source) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        Metric.ball x ε ⊆ Φ.source ∧
+          ∀ y ∈ Metric.ball x ε,
+            ∃ A : ℝ × M → M,
+              ContMDiff (𝓘(ℝ, ℝ).prod J) J ∞ A ∧
+                (∀ z, A (0, z) = z) ∧
+                  (∀ t, ∃ d : Diffeomorph J J M M ∞, ∀ z, A (t, z) = d z) ∧
+                    (∀ t z, z ∉ Φ.target → A (t, z) = z) ∧ A (1, Φ x) = Φ y := by
+  obtain ⟨β, hβsupport, hβcompact, hβsmooth, -, hβx⟩ :=
+    exists_contDiff_tsupport_subset (n := ⊤) (Φ.open_source.mem_nhds hx)
+  obtain ⟨δ, hδ, hmove⟩ := exists_small_supported_bump_isotopy Φ hβsmooth hβcompact hβsupport
+  obtain ⟨ρ, hρ, hρsource⟩ := Metric.mem_nhds_iff.mp (Φ.open_source.mem_nhds hx)
+  refine ⟨Min.min δ ρ, lt_min hδ hρ, ?_, ?_⟩
+  · exact (Metric.ball_subset_ball (min_le_right _ _)).trans hρsource
+  · intro y hy
+    have hnear : ‖y - x‖ < δ := by
+      simpa only [dist_eq_norm] using
+        (show Dist.dist y x < Min.min δ ρ from hy).trans_le (min_le_left _ _)
+    obtain ⟨A, hA, hzero, hdiff, hfix, hend⟩ := hmove (y - x) hnear
+    refine ⟨A, hA, hzero, hdiff, ?_, ?_⟩
+    · intro t z hz
+      apply hfix t z
+      rintro ⟨q, hq, rfl⟩
+      exact hz (Φ.map_source' (hβsupport hq))
+    · have hterminal := hend x hx
+      rw [hβx, one_smul] at hterminal
+      have hxy : x + (y - x) = y := by abel
+      exact hterminal.trans (congrArg Φ hxy)
+
+private theorem
+    Smale.SupportedDiffeomorph.exists_open_pointMoving {E H M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace H] {J : ModelWithCorners ℝ E H}
+    [J.Boundaryless] [TopologicalSpace M] [ChartedSpace H M] [IsManifold J ∞ M] [T2Space M]
+    {U : Set M} (hU : IsOpen U) {x : M} (hx : x ∈ U) :
+    ∃ V : Set M,
+      IsOpen V ∧
+        x ∈ V ∧ V ⊆ U ∧ ∀ y ∈ V, ∃ d : Diffeomorph J J M M ∞, d x = y ∧ ∀ z ∉ U, d z = z := by
+  let c := NoExotic.modelChartPartialDiffeomorph (I := J) x
+  let Φ := Smale.PartialChart.restrictTarget c.symm hU
+  have hxc : x ∈ c.source := mem_extChartAt_source x
+  have hcx : c.symm (c x) = x := c.left_inv' hxc
+  have hxΦ : c x ∈ Φ.source := by
+    refine ⟨c.map_source' hxc, ?_⟩
+    change c.symm (c x) ∈ U
+    rw [hcx]
+    exact hx
+  have hΦx : Φ (c x) = x := hcx
+  obtain ⟨ε, hε, hball, hmove⟩ := exists_supported_pointMoving Φ hxΦ
+  refine
+    ⟨Φ '' Metric.ball (c x) ε,
+      Φ.toOpenPartialHomeomorph.isOpen_image_of_subset_source Metric.isOpen_ball hball,
+      ⟨c x, Metric.mem_ball_self hε, hΦx⟩, ?_, ?_⟩
+  · rintro _ ⟨v, hv, rfl⟩
+    exact (Φ.map_source' (hball hv)).2
+  · rintro _ ⟨v, hv, rfl⟩
+    obtain ⟨A, _, _, hdiff, hfix, hend⟩ := hmove v hv
+    obtain ⟨d, hd⟩ := hdiff 1
+    refine ⟨d, ?_, ?_⟩
+    · rw [hΦx] at hend
+      exact (hd x).symm.trans hend
+    · intro z hz
+      exact (hd z).symm.trans (hfix 1 z (fun h => hz h.2))
+
+private theorem MorseCancel.exists_open_isotopic_pointMoving {E H M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace H] {J : ModelWithCorners ℝ E H}
+    [J.Boundaryless] [TopologicalSpace M] [ChartedSpace H M] [IsManifold J ∞ M] [T2Space M]
+    {U : Set M} (hU : IsOpen U) {x : M} (hx : x ∈ U) :
+    ∃ V : Set M,
+      IsOpen V ∧
+        x ∈ V ∧
+          V ⊆ U ∧
+            ∀ y ∈ V,
+              ∃ d : Diffeomorph J J M M ∞,
+                Smale.SupportedDiffeomorph.IsotopicToIdentity d ∧ d x = y ∧ ∀ z ∉ U, d z = z := by
+  let c := NoExotic.modelChartPartialDiffeomorph (I := J) x
+  let Φ := Smale.PartialChart.restrictTarget c.symm hU
+  have hxc : x ∈ c.source := mem_extChartAt_source x
+  have hcx : c.symm (c x) = x := c.left_inv' hxc
+  have hxΦ : c x ∈ Φ.source := by
+    refine ⟨c.map_source' hxc, ?_⟩
+    change c.symm (c x) ∈ U
+    rw [hcx]
+    exact hx
+  have hΦx : Φ (c x) = x := hcx
+  obtain ⟨ε, hε, hball, hmove⟩ := Smale.SupportedDiffeomorph.exists_supported_pointMoving Φ hxΦ
+  refine
+    ⟨Φ '' Metric.ball (c x) ε,
+      Φ.toOpenPartialHomeomorph.isOpen_image_of_subset_source Metric.isOpen_ball hball,
+      ⟨c x, Metric.mem_ball_self hε, hΦx⟩, ?_, ?_⟩
+  · rintro _ ⟨v, hv, rfl⟩
+    exact (Φ.map_source' (hball hv)).2
+  · rintro _ ⟨v, hv, rfl⟩
+    obtain ⟨A, hA, hzero, hdiff, hfix, hend⟩ := hmove v hv
+    obtain ⟨d, hd⟩ := hdiff 1
+    refine ⟨d, ⟨A, hA, hzero, hd, hdiff⟩, ?_, ?_⟩
+    · rw [hΦx] at hend
+      exact (hd x).symm.trans hend
+    · intro z hz
+      exact (hd z).symm.trans (hfix 1 z (fun h => hz h.2))
+
+private theorem
+    MorseCancel.exists_isotopic_two_points_in_dense {E H M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace H] {J : ModelWithCorners ℝ E H}
+    [J.Boundaryless] [TopologicalSpace M] [ChartedSpace H M] [IsManifold J ∞ M] [T2Space M]
+    {B : Set M} (hB : Dense B) {x y : M} (hxy : x ≠ y) :
+    ∃ d : Diffeomorph J J M M ∞,
+      Smale.SupportedDiffeomorph.IsotopicToIdentity d ∧ d x ∈ B ∧ d y ∈ B := by
+  obtain ⟨U, V, hU, hV, hx, hy, hdisj⟩ := t2_separation hxy
+  obtain ⟨U', hU', hx', hU'U, hmoveU⟩ := exists_open_isotopic_pointMoving (J := J) hU hx
+  obtain ⟨V', hV', hy', hV'V, hmoveV⟩ := exists_open_isotopic_pointMoving (J := J) hV hy
+  obtain ⟨x', hx'B, hx'U⟩ := hB.exists_mem_open hU' ⟨x, hx'⟩
+  obtain ⟨y', hy'B, hy'V⟩ := hB.exists_mem_open hV' ⟨y, hy'⟩
+  obtain ⟨d, hd, hdx, hdfix⟩ := hmoveU x' hx'U
+  obtain ⟨e, he, hey, hefix⟩ := hmoveV y' hy'V
+  have hyU : y ∉ U := fun h => Set.disjoint_left.mp hdisj h hy
+  have hxV : x' ∉ V := fun h => Set.disjoint_left.mp hdisj (hU'U hx'U) h
+  refine ⟨d.trans e, hd.trans he, ?_, ?_⟩
+  · change e (d x) ∈ B
+    rw [hdx, hefix x' hxV]
+    exact hx'B
+  · change e (d y) ∈ B
+    rw [hdfix y hyU, hey]
+    exact hy'B
+
+private theorem MorseCancel.isotopicToIdentity_joined {E H M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace H] {J : ModelWithCorners ℝ E H}
+     [TopologicalSpace M] [ChartedSpace H M]
+    {d : Diffeomorph J J M M ∞} (hd : Smale.SupportedDiffeomorph.IsotopicToIdentity d) (x : M) :
+    Joined x (d x) := by
+  obtain ⟨A, hA, hzero, hone, -⟩ := hd
+  exact
+    ⟨{  toFun := fun t => A ((t : ℝ), x)
+        continuous_toFun := hA.continuous.comp (continuous_subtype_val.prodMk continuous_const)
+        source' := hzero x
+        target' := hone x }⟩
+
+private def MorseCancel.isotopicPointOrbit {E H M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace H] [TopologicalSpace M] [ChartedSpace H M] (J : ModelWithCorners ℝ E H)
+    (U : Set M) (x : M) : Set M :=
+  {y |
+    y ∈ U ∧
+      ∃ d : Diffeomorph J J M M ∞,
+        Smale.SupportedDiffeomorph.IsotopicToIdentity d ∧ d x = y ∧ ∀ z ∉ U, d z = z}
+
+private theorem MorseCancel.isOpen_isotopicPointOrbit {E H M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace H] {J : ModelWithCorners ℝ E H}
+    [J.Boundaryless] [TopologicalSpace M] [ChartedSpace H M] [IsManifold J ∞ M] [T2Space M]
+    {U : Set M} (hU : IsOpen U) (x : M) : IsOpen (isotopicPointOrbit J U x) := by
+  rw [isOpen_iff_mem_nhds]
+  rintro y ⟨hyU, d, hd, hdx, hdfix⟩
+  obtain ⟨V, hV, hyV, hVU, hmove⟩ := exists_open_isotopic_pointMoving (J := J) hU hyU
+  apply Filter.mem_of_superset (hV.mem_nhds hyV)
+  intro z hz
+  obtain ⟨e, he, hey, hefix⟩ := hmove z hz
+  refine ⟨hVU hz, d.trans e, hd.trans he, ?_, ?_⟩
+  · change e (d x) = z
+    rw [hdx, hey]
+  · intro w hw
+    change e (d w) = w
+    rw [hdfix w hw, hefix w hw]
+
+private theorem MorseCancel.isOpen_sdiff_isotopicPointOrbit {E H M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace H] {J : ModelWithCorners ℝ E H}
+    [J.Boundaryless] [TopologicalSpace M] [ChartedSpace H M] [IsManifold J ∞ M] [T2Space M]
+    {U : Set M} (hU : IsOpen U) (x : M) : IsOpen (U \ isotopicPointOrbit J U x) := by
+  rw [isOpen_iff_mem_nhds]
+  rintro y ⟨hyU, hyOrbit⟩
+  obtain ⟨V, hV, hyV, hVU, hmove⟩ := exists_open_isotopic_pointMoving (J := J) hU hyU
+  apply Filter.mem_of_superset (hV.mem_nhds hyV)
+  intro z hz
+  refine ⟨hVU hz, ?_⟩
+  rintro ⟨_, d, hd, hdx, hdfix⟩
+  obtain ⟨e, he, hey, hefix⟩ := hmove z hz
+  apply hyOrbit
+  refine ⟨hyU, d.trans e.symm, hd.trans he.symm, ?_, ?_⟩
+  · change e.symm (d x) = y
+    rw [hdx, ← hey, e.symm_apply_apply]
+  · intro w hw
+    change e.symm (d w) = w
+    rw [hdfix w hw]
+    exact Smale.SupportedDiffeomorph.inverse_fixed_outside e.toEquiv hefix w hw
+
+private theorem MorseCancel.exists_isotopic_pointMoving_of_preconnected {E H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ E H} [J.Boundaryless] [TopologicalSpace M] [ChartedSpace H M]
+    [IsManifold J ∞ M] [T2Space M] {U A : Set M} (hU : IsOpen U) (hA : IsPreconnected A)
+    (hAU : A ⊆ U) {x y : M} (hx : x ∈ A) (hy : y ∈ A) :
+    ∃ d : Diffeomorph J J M M ∞,
+      Smale.SupportedDiffeomorph.IsotopicToIdentity d ∧ d x = y ∧ ∀ z ∉ U, d z = z := by
+  have hxOrbit : x ∈ isotopicPointOrbit J U x :=
+    ⟨hAU hx, Diffeomorph.refl J M ∞, Smale.SupportedDiffeomorph.isotopicToIdentity_refl, rfl,
+      fun _ _ => rfl⟩
+  have hcover : A ⊆ isotopicPointOrbit J U x ∪ (U \ isotopicPointOrbit J U x) := by
+    intro z hz
+    by_cases hh : z ∈ isotopicPointOrbit J U x
+    · exact Or.inl hh
+    · exact Or.inr ⟨hAU hz, hh⟩
+  have hdisjoint : Disjoint (isotopicPointOrbit J U x) (U \ isotopicPointOrbit J U x) := by
+    rw [Set.disjoint_left]
+    exact fun _ hz hw => hw.2 hz
+  have hsub :=
+    hA.subset_left_of_subset_union (isOpen_isotopicPointOrbit hU x)
+      (isOpen_sdiff_isotopicPointOrbit hU x) hdisjoint hcover ⟨x, hx, hxOrbit⟩
+  exact (hsub hy).2
+
+private theorem
+    MorseCancel.exists_isotopic_pointMoving_of_path {E H M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace H] {J : ModelWithCorners ℝ E H}
+    [J.Boundaryless] [TopologicalSpace M] [ChartedSpace H M] [IsManifold J ∞ M] [T2Space M]
+    {U : Set M} (hU : IsOpen U) {x y : M} (γ : Path x y) (hγ : ∀ t, γ t ∈ U) :
+    ∃ d : Diffeomorph J J M M ∞,
+      Smale.SupportedDiffeomorph.IsotopicToIdentity d ∧ d x = y ∧ ∀ z ∉ U, d z = z := by
+  apply
+    exists_isotopic_pointMoving_of_preconnected (J := J) hU
+      (isConnected_range γ.continuous).isPreconnected
+      (show Set.range γ ⊆ U from by rintro _ ⟨t, rfl⟩; exact hγ t)
+  · exact ⟨0, γ.source⟩
+  · exact ⟨1, γ.target⟩
+
+private def Smale.CurveImmersion.smoothTime (t : ℝ) : unitInterval :=
+  Set.projIcc 0 1 zero_le_one (Real.smoothTransition t)
+
+private theorem
+    Smale.CurveImmersion.contMDiff_smoothTime : ContMDiff 𝓘(ℝ, ℝ) (𝓡∂ 1) ∞ smoothTime := by
+  let : Fact ((0 : ℝ) < 1) := ⟨zero_lt_one⟩
+  have hp : ContMDiffOn 𝓘(ℝ, ℝ) (𝓡∂ 1) ∞ (Set.projIcc (0 : ℝ) 1 zero_le_one) (Set.Icc 0 1) :=
+    contMDiffOn_projIcc
+  have ht : ContDiff ℝ ∞ Real.smoothTransition := Real.smoothTransition.contDiff
+  apply contMDiffOn_univ.mp
+  exact
+    hp.comp ht.contMDiff.contMDiffOn
+      (fun t _ => ⟨Real.smoothTransition.nonneg t, Real.smoothTransition.le_one t⟩)
+
+private theorem Smale.CurveImmersion.smoothTime_zero : smoothTime 0 = 0 := by
+  apply Subtype.ext
+  simp [smoothTime]
+
+private theorem Smale.CurveImmersion.smoothTime_one : smoothTime 1 = 1 := by
+  apply Subtype.ext
+  simp [smoothTime]
+
+private theorem Smale.exists_smooth_connecting_curve {G H N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [J.Boundaryless]
+    [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] {x y : N} (γ : Path x y) :
+    ∃ f : C(ℝ, N), ContMDiff 𝓘(ℝ, ℝ) J ∞ f ∧ f 0 = x ∧ f 1 = y := by
+  let Z := EuclideanSpace ℝ (Fin 0)
+  let f₀ : C(Z, N) := ContinuousMap.const Z x
+  let f₁ : C(Z, N) := ContinuousMap.const Z y
+  let H : f₀.Homotopy f₁ :=
+    { toFun := fun q => γ q.1
+      continuous_toFun := γ.continuous.comp continuous_fst
+      map_zero_left := fun _ => γ.source
+      map_one_left := fun _ => γ.target }
+  obtain ⟨H', hH', -, -⟩ :=
+    ManifoldSmoothing.exists_smooth_homotopy_with_collars (I := 𝓘(ℝ, Z)) (J := J) contMDiff_const
+      contMDiff_const H
+  let f : ℝ → N := fun t => H' (CurveImmersion.smoothTime t, (0 : Z))
+  have hf : ContMDiff 𝓘(ℝ, ℝ) J ∞ f :=
+    hH'.comp (CurveImmersion.contMDiff_smoothTime.prodMk contMDiff_const)
+  refine ⟨⟨f, hf.continuous⟩, hf, ?_, ?_⟩
+  · change H' (CurveImmersion.smoothTime 0, (0 : Z)) = x
+    rw [CurveImmersion.smoothTime_zero, H'.apply_zero]
+    rfl
+  · change H' (CurveImmersion.smoothTime 1, (0 : Z)) = y
+    rw [CurveImmersion.smoothTime_one, H'.apply_one]
+    rfl
+
+private def
+    Smale.SupportedDiffeomorph.pointOrbit {E H M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace H] [TopologicalSpace M] [ChartedSpace H M] (J : ModelWithCorners ℝ E H)
+    (U : Set M) (x : M) : Set M :=
+  {y | y ∈ U ∧ ∃ d : Diffeomorph J J M M ∞, d x = y ∧ ∀ z ∉ U, d z = z}
+
+private theorem Smale.SupportedDiffeomorph.isOpen_pointOrbit {E H M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace H] {J : ModelWithCorners ℝ E H}
+    [J.Boundaryless] [TopologicalSpace M] [ChartedSpace H M] [IsManifold J ∞ M] [T2Space M]
+    {U : Set M} (hU : IsOpen U) (x : M) : IsOpen (pointOrbit J U x) := by
+  rw [isOpen_iff_mem_nhds]
+  rintro y ⟨hyU, d, hd, hdfix⟩
+  obtain ⟨V, hV, hyV, hVU, hmove⟩ := exists_open_pointMoving (J := J) hU hyU
+  apply Filter.mem_of_superset (hV.mem_nhds hyV)
+  intro z hz
+  obtain ⟨e, he, hefix⟩ := hmove z hz
+  refine ⟨hVU hz, d.trans e, ?_, ?_⟩
+  · change e (d x) = z
+    rw [hd, he]
+  · intro w hw
+    change e (d w) = w
+    rw [hdfix w hw, hefix w hw]
+
+private theorem
+    Smale.SupportedDiffeomorph.isOpen_sdiff_pointOrbit {E H M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace H] {J : ModelWithCorners ℝ E H}
+    [J.Boundaryless] [TopologicalSpace M] [ChartedSpace H M] [IsManifold J ∞ M] [T2Space M]
+    {U : Set M} (hU : IsOpen U) (x : M) : IsOpen (U \ pointOrbit J U x) := by
+  rw [isOpen_iff_mem_nhds]
+  rintro y ⟨hyU, hyOrbit⟩
+  obtain ⟨V, hV, hyV, hVU, hmove⟩ := exists_open_pointMoving (J := J) hU hyU
+  apply Filter.mem_of_superset (hV.mem_nhds hyV)
+  intro z hz
+  refine ⟨hVU hz, ?_⟩
+  rintro ⟨_, d, hd, hdfix⟩
+  obtain ⟨e, he, hefix⟩ := hmove z hz
+  apply hyOrbit
+  refine ⟨hyU, d.trans e.symm, ?_, ?_⟩
+  · change e.symm (d x) = y
+    rw [hd, ← he]
+    exact e.toEquiv.symm_apply_apply y
+  · intro w hw
+    change e.symm (d w) = w
+    rw [hdfix w hw]
+    exact inverse_fixed_outside e.toEquiv hefix w hw
+
+private theorem Smale.SupportedDiffeomorph.exists_pointMoving_of_preconnected {E H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ E H} [J.Boundaryless] [TopologicalSpace M] [ChartedSpace H M]
+    [IsManifold J ∞ M] [T2Space M] {U S : Set M} (hU : IsOpen U) (hS : IsPreconnected S)
+    (hSU : S ⊆ U) {x y : M} (hx : x ∈ S) (hy : y ∈ S) :
+    ∃ d : Diffeomorph J J M M ∞, d x = y ∧ ∀ z ∉ U, d z = z := by
+  have hxOrbit : x ∈ pointOrbit J U x := ⟨hSU hx, Diffeomorph.refl J M ∞, rfl, fun _ _ => rfl⟩
+  have hcover : S ⊆ pointOrbit J U x ∪ (U \ pointOrbit J U x) := by
+    intro z hz
+    by_cases h : z ∈ pointOrbit J U x
+    · exact Or.inl h
+    · exact Or.inr ⟨hSU hz, h⟩
+  have hdisjoint : Disjoint (pointOrbit J U x) (U \ pointOrbit J U x) := by
+    rw [Set.disjoint_left]
+    exact fun _ hz hw => hw.2 hz
+  have hsub :=
+    hS.subset_left_of_subset_union (isOpen_pointOrbit hU x) (isOpen_sdiff_pointOrbit hU x)
+      hdisjoint hcover ⟨x, hx, hxOrbit⟩
+  exact (hsub hy).2
+
+private theorem Smale.SupportedDiffeomorph.exists_pointMoving_of_path {E H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ E H} [J.Boundaryless] [TopologicalSpace M] [ChartedSpace H M]
+    [IsManifold J ∞ M] [T2Space M] {U : Set M} (hU : IsOpen U) {x y : M} (γ : Path x y)
+    (hγ : ∀ t, γ t ∈ U) : ∃ d : Diffeomorph J J M M ∞, d x = y ∧ ∀ z ∉ U, d z = z := by
+  apply
+    exists_pointMoving_of_preconnected (J := J) hU (isConnected_range γ.continuous).isPreconnected
+      (show Set.range γ ⊆ U from by rintro _ ⟨t, rfl⟩; exact hγ t)
+  · exact ⟨0, γ.source⟩
+  · exact ⟨1, γ.target⟩
+
+private theorem Smale.exists_smooth_path_avoiding_finite {G H N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N]
+    {x y : N} (γ : Path x y) (hdim : 2 ≤ Module.finrank ℝ G) {S : Set N} (hS : S.Finite)
+    (hx : x ∉ S) (hy : y ∉ S) : ∃ η : Path x y, ContMDiff (𝓡∂ 1) J ∞ η ∧ ∀ t, η t ∉ S := by
+  let : Fintype S := hS.fintype
+  let Z := EuclideanSpace ℝ (Fin 0)
+  let : ChartedSpace Z S := ChartedSpace.ofDiscreteTopology
+  let : IsManifold 𝓘(ℝ, Z) ∞ S := IsManifold.of_discreteTopology _
+  let g : C(S, N) := ⟨Subtype.val, continuous_subtype_val⟩
+  have hg : ContMDiff 𝓘(ℝ, Z) J ∞ g := contMDiff_of_discreteTopology
+  have hrange : Set.range g = S := by ext z; simp [g]
+  obtain ⟨f, hf, hf0, hf1⟩ := exists_smooth_connecting_curve (J := J) γ
+  let fI : C(unitInterval, N) := ⟨fun t => f t, f.continuous.comp continuous_subtype_val⟩
+  have hfI : ContMDiff (𝓡∂ 1) J ∞ fI := hf.comp contMDiff_subtypeVal_Icc
+  have hdim' :
+    Module.finrank ℝ (EuclideanSpace ℝ (Fin 1)) + Module.finrank ℝ Z < Module.finrank ℝ G := by
+    simp only [Z, finrank_euclideanSpace_fin]
+    omega
+  have hfixed : ∀ t ∈ ({0, 1} : Set unitInterval), fI t ∉ Set.range g := by
+    intro t ht
+    rw [hrange]
+    rcases ht with rfl | ht
+    · change f 0 ∉ S
+      rw [hf0]
+      exact hx
+    · have ht1 : t = 1 := ht
+      subst t
+      change f 1 ∉ S
+      rw [hf1]
+      exact hy
+  obtain ⟨f', hf', hrel, hdisjoint⟩ :=
+    GeneralPosition.exists_disjoint_smooth_map_homotopicRel fI g hfI hg hdim'
+      ((Set.finite_singleton (1 : unitInterval)).insert 0).isClosed hfixed
+  have hf'0 : f' 0 = x := (hrel.fst_eq_snd (by simp)).symm.trans hf0
+  have hf'1 : f' 1 = y := (hrel.fst_eq_snd (by simp)).symm.trans hf1
+  let η : Path x y := { toContinuousMap := f', source' := hf'0, target' := hf'1 }
+  refine ⟨η, hf', ?_⟩
+  intro t ht
+  rw [hrange] at hdisjoint
+  exact Set.disjoint_left.mp hdisjoint ⟨t, rfl⟩ ht
+
+private theorem Smale.exists_pointMoving_fixing_finite {G H N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N]
+    {x y : N} (γ : Path x y) (hdim : 2 ≤ Module.finrank ℝ G) {S : Set N} (hS : S.Finite)
+    (hx : x ∉ S) (hy : y ∉ S) : ∃ d : Diffeomorph J J N N ∞, d x = y ∧ ∀ z ∈ S, d z = z := by
+  obtain ⟨η, _, hη⟩ := exists_smooth_path_avoiding_finite (J := J) γ hdim hS hx hy
+  obtain ⟨d, hd, hfix⟩ :=
+    SupportedDiffeomorph.exists_pointMoving_of_path (J := J) hS.isClosed.isOpen_compl η hη
+  exact ⟨d, hd, fun z hz => hfix z (fun hn => hn hz)⟩
+
+private def Smale.ChartMapPerturbation.collisionDomain {G F K X N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace K]
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : X → N) (β : X → ℝ) : Set (X × X) :=
+  {q | f q.1 ∈ c.source ∧ f q.2 ∈ c.source ∧ β q.1 - β q.2 ≠ 0}
+
+private def Smale.ChartMapPerturbation.collisionParameter {G F K X N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace K]
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : X → N) (β : X → ℝ) (q : X × X) : F :=
+  (β q.1 - β q.2)⁻¹ • (c (f q.2) - c (f q.1))
+
+private theorem Smale.ChartMapPerturbation.isOpen_collisionDomain {G F K X N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace K] {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [TopologicalSpace N]
+    [ChartedSpace K N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ}
+    (hf : Continuous f) (hβ : Continuous β) : IsOpen (collisionDomain c f β) :=
+  (c.open_source.preimage (hf.comp continuous_fst)).inter
+    ((c.open_source.preimage (hf.comp continuous_snd)).inter
+      (isOpen_ne_fun ((hβ.comp continuous_fst).sub (hβ.comp continuous_snd)) continuous_const))
+
+private theorem Smale.ChartMapPerturbation.contMDiffOn_collisionParameter {E G F H K X N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ G K} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ} (hf : ContMDiff I J ∞ f)
+    (hβ : ContMDiff I 𝓘(ℝ, ℝ) ∞ β) :
+    ContMDiffOn (I.prod I) 𝓘(ℝ, F) ∞ (collisionParameter c f β) (collisionDomain c f β) := by
+  intro q hq
+  have hcf : ContMDiffAt (I.prod I) 𝓘(ℝ, F) ∞ (fun r : X × X => c (f r.1)) q :=
+    (c.contMDiffOn_toFun.contMDiffAt (c.open_source.mem_nhds hq.1)).comp q
+      (hf.comp contMDiff_fst).contMDiffAt
+  have hcg : ContMDiffAt (I.prod I) 𝓘(ℝ, F) ∞ (fun r : X × X => c (f r.2)) q :=
+    (c.contMDiffOn_toFun.contMDiffAt (c.open_source.mem_nhds hq.2.1)).comp q
+      (hf.comp contMDiff_snd).contMDiffAt
+  have hb : ContMDiffAt (I.prod I) 𝓘(ℝ, ℝ) ∞ (fun r : X × X => β r.1 - β r.2) q :=
+    (hβ.comp contMDiff_fst).contMDiffAt.sub (hβ.comp contMDiff_snd).contMDiffAt
+  exact ((hb.inv₀ hq.2.2).smul (hcg.sub hcf)).contMDiffWithinAt
+
+private theorem Smale.ChartMapPerturbation.collision_imp_old_and_equal_cutoff {G F K X N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace K] {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [TopologicalSpace N]
+    [ChartedSpace K N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ}
+    (hsupport : tsupport β ⊆ f ⁻¹' c.source) {a : F} (hvalid : Valid c f β a)
+    (hgood : a ∉ collisionParameter c f β '' collisionDomain c f β) {x y : X}
+    (heq : perturb c f β a x = perturb c f β a y) : f x = f y ∧ β x = β y := by
+  classical
+  by_cases hx : f x ∈ c.source
+  · have hpy : perturb c f β a y ∈ c.source := heq ▸ perturb_mem_source c f β hvalid hx
+    have hy : f y ∈ c.source := by
+      by_contra hn
+      simp only [perturb, hn, ite_false] at hpy
+    have hcoord : c (f x) + β x • a = c (f y) + β y • a := by
+      have hh := congrArg c heq
+      simpa only [chart_perturb c f β hvalid hx, chart_perturb c f β hvalid hy,
+        coordinateFamily] using hh
+    by_cases hb : β x = β y
+    · refine ⟨c.toPartialEquiv.injOn hx hy ?_, hb⟩
+      rw [hb] at hcoord
+      exact add_right_cancel hcoord
+    · have hd : β x - β y ≠ 0 := sub_ne_zero.mpr hb
+      have hs : (β x - β y) • a = c (f y) - c (f x) := by
+        rw [sub_smul]
+        exact sub_eq_sub_iff_add_eq_add.mpr (by simpa only [add_comm] using hcoord)
+      exfalso
+      apply hgood
+      refine ⟨(x, y), ⟨hx, hy, hd⟩, ?_⟩
+      change (β x - β y)⁻¹ • (c (f y) - c (f x)) = a
+      rw [← hs, inv_smul_smul₀ hd]
+  · have hpx : perturb c f β a x = f x := by simp only [perturb, hx, ite_false]
+    have hy : f y ∉ c.source := by
+      intro hy
+      have hpy := perturb_mem_source c f β hvalid hy
+      rw [← heq, hpx] at hpy
+      exact hx hpy
+    have hpy : perturb c f β a y = f y := by simp only [perturb, hy, ite_false]
+    have hβx : β x = 0 := by
+      by_contra hn
+      exact hx (hsupport (subset_tsupport β hn))
+    have hβy : β y = 0 := by
+      by_contra hn
+      exact hy (hsupport (subset_tsupport β hn))
+    exact ⟨hpx.symm.trans (heq.trans hpy), hβx.trans hβy.symm⟩
+
+private theorem Smale.ChartMapPerturbation.exists_small_collision_removing_parameter
+    {E G F H K X N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H]
+    [TopologicalSpace K] {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ G K}
+    [TopologicalSpace X] [ChartedSpace H X] [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {β : X → ℝ} [FiniteDimensional ℝ E]
+    [FiniteDimensional ℝ F] [IsManifold I ∞ X] [LindelofSpace (X × X)] (hf : ContMDiff I J ∞ f)
+    (hβ : ContMDiff I 𝓘(ℝ, ℝ) ∞ β) (hcompact : HasCompactSupport β)
+    (hsupport : tsupport β ⊆ f ⁻¹' c.source) (hdim : 2 * Module.finrank ℝ E < Module.finrank ℝ F)
+    {ε : ℝ} (hε : 0 < ε) :
+    ∃ a : F,
+      ‖a‖ < ε ∧
+        Valid c f β a ∧
+          ContMDiff I J ∞ (perturb c f β a) ∧
+            ∀ x y, perturb c f β a x = perturb c f β a y → f x = f y ∧ β x = β y := by
+  have hd : Module.finrank ℝ (E × E) < Module.finrank ℝ F := by
+    simpa only [Module.finrank_prod, two_mul] using hdim
+  have hdense :=
+    Smale.GeneralPosition.dense_compl_manifold_image
+      (isOpen_collisionDomain c hf.continuous hβ.continuous)
+      (contMDiffOn_collisionParameter c hf hβ) hd
+  obtain ⟨δ, hδ, hvalid⟩ := exists_radius_valid c hf hβ hcompact hsupport
+  obtain ⟨a, hgood, har⟩ := hdense.exists_dist_lt 0 (lt_min hε hδ)
+  have ha : ‖a‖ < Min.min ε δ := by simpa only [dist_zero_left] using har
+  have hv := hvalid a (lt_of_lt_of_le ha (min_le_right _ _))
+  exact
+    ⟨a, lt_of_lt_of_le ha (min_le_left _ _), hv, contMDiff_perturb c hf hβ hsupport hv,
+      fun _ _ heq => collision_imp_old_and_equal_cutoff c hsupport hv hgood heq⟩
+
+private def Smale.ChartMapPerturbation.obstacleDomain {G F K X Y N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace K]
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : X → N) (g : Y → N) (β : X → ℝ) : Set (X × Y) :=
+  {q | f q.1 ∈ c.source ∧ g q.2 ∈ c.source ∧ β q.1 ≠ 0}
+
+private def
+    Smale.ChartMapPerturbation.obstacleParameter {G F K X Y N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace K]
+    {J : ModelWithCorners ℝ G K} [TopologicalSpace N] [ChartedSpace K N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : X → N) (g : Y → N) (β : X → ℝ) (q : X × Y) :
+    F :=
+  (β q.1)⁻¹ • (c (g q.2) - c (f q.1))
+
+private theorem Smale.ChartMapPerturbation.isOpen_obstacleDomain {G F K X Y N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace K] {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [TopologicalSpace Y]
+    [TopologicalSpace N] [ChartedSpace K N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N}
+    {g : Y → N} {β : X → ℝ} (hf : Continuous f) (hg : Continuous g) (hβ : Continuous β) :
+    IsOpen (obstacleDomain c f g β) :=
+  (c.open_source.preimage (hf.comp continuous_fst)).inter
+    ((c.open_source.preimage (hg.comp continuous_snd)).inter
+      (isOpen_ne_fun (hβ.comp continuous_fst) continuous_const))
+
+private theorem
+    Smale.ChartMapPerturbation.contMDiffOn_obstacleParameter {E E' G F H H' K X Y N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup E'] [NormedSpace ℝ E']
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] [TopologicalSpace H'] [TopologicalSpace K] {I : ModelWithCorners ℝ E H}
+    {I' : ModelWithCorners ℝ E' H'} {J : ModelWithCorners ℝ G K} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y] [TopologicalSpace N]
+    [ChartedSpace K N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {g : Y → N}
+    {β : X → ℝ} (hf : ContMDiff I J ∞ f) (hg : ContMDiff I' J ∞ g)
+    (hβ : ContMDiff I 𝓘(ℝ, ℝ) ∞ β) :
+    ContMDiffOn (I.prod I') 𝓘(ℝ, F) ∞ (obstacleParameter c f g β) (obstacleDomain c f g β) := by
+  intro q hq
+  have hcf : ContMDiffAt (I.prod I') 𝓘(ℝ, F) ∞ (fun r : X × Y => c (f r.1)) q :=
+    (c.contMDiffOn_toFun.contMDiffAt (c.open_source.mem_nhds hq.1)).comp q
+      (hf.comp contMDiff_fst).contMDiffAt
+  have hcg : ContMDiffAt (I.prod I') 𝓘(ℝ, F) ∞ (fun r : X × Y => c (g r.2)) q :=
+    (c.contMDiffOn_toFun.contMDiffAt (c.open_source.mem_nhds hq.2.1)).comp q
+      (hg.comp contMDiff_snd).contMDiffAt
+  exact (((hβ.comp contMDiff_fst).contMDiffAt.inv₀ hq.2.2).smul (hcg.sub hcf)).contMDiffWithinAt
+
+private theorem Smale.ChartMapPerturbation.avoids_of_not_obstacle_parameter {G F K X Y N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace K] {J : ModelWithCorners ℝ G K} [TopologicalSpace X] [TopologicalSpace N]
+    [ChartedSpace K N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : X → N} {g : Y → N}
+    {β : X → ℝ} (hsupport : tsupport β ⊆ f ⁻¹' c.source) {a : F} (ha : Valid c f β a)
+    (hgood : a ∉ obstacleParameter c f g β '' obstacleDomain c f g β) (x : X) (hx : β x ≠ 0)
+    (y : Y) : perturb c f β a x ≠ g y := by
+  intro heq
+  have hfx : f x ∈ c.source := hsupport (subset_tsupport β hx)
+  have hgy : g y ∈ c.source := heq ▸ perturb_mem_source c f β ha hfx
+  have hcoord : c (f x) + β x • a = c (g y) := by
+    rw [← heq, chart_perturb c f β ha hfx]
+    rfl
+  apply hgood
+  refine ⟨(x, y), ⟨hfx, hgy, hx⟩, ?_⟩
+  change (β x)⁻¹ • (c (g y) - c (f x)) = a
+  rw [← hcoord, add_sub_cancel_left, smul_smul, inv_mul_cancel₀ hx, one_smul]
+
+private theorem Smale.ChartMapPerturbation.exists_small_embedding_avoiding_parameter
+    {E E' G F H H' K X Y N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] [NormedAddCommGroup E'] [NormedSpace ℝ E'] [FiniteDimensional ℝ E']
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [FiniteDimensional ℝ F] [TopologicalSpace H] [TopologicalSpace H'] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ E H} {I' : ModelWithCorners ℝ E' H'} {J : ModelWithCorners ℝ G K}
+    [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X] [TopologicalSpace Y]
+    [ChartedSpace H' Y] [IsManifold I' ∞ Y] [TopologicalSpace N] [ChartedSpace K N]
+    [LindelofSpace (X × X)] [LindelofSpace (X × Y)] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞)
+    {f : X → N} {g : Y → N} {β : X → ℝ} (hf : ContMDiff I J ∞ f) (hg : ContMDiff I' J ∞ g)
+    (hβ : ContMDiff I 𝓘(ℝ, ℝ) ∞ β) (hcompact : HasCompactSupport β)
+    (hsupport : tsupport β ⊆ f ⁻¹' c.source) (hself : 2 * Module.finrank ℝ E < Module.finrank ℝ F)
+    (hobstacle : Module.finrank ℝ E + Module.finrank ℝ E' < Module.finrank ℝ F) {ε : ℝ}
+    (hε : 0 < ε) :
+    ∃ a : F,
+      ‖a‖ < ε ∧
+        Valid c f β a ∧
+          ContMDiff I J ∞ (perturb c f β a) ∧
+            (∀ x y, perturb c f β a x = perturb c f β a y → f x = f y) ∧
+              ∀ x, β x ≠ 0 → ∀ y, perturb c f β a x ≠ g y := by
+  have hdself : Module.finrank ℝ (E × E) < Module.finrank ℝ F := by
+    simpa only [Module.finrank_prod, two_mul] using hself
+  have hdobstacle : Module.finrank ℝ (E × E') < Module.finrank ℝ F := by
+    simpa only [Module.finrank_prod] using hobstacle
+  have hs :=
+    Smale.GeneralPosition.dimH_image_manifold_le
+      (isOpen_collisionDomain c hf.continuous hβ.continuous)
+      (contMDiffOn_collisionParameter c hf hβ)
+  have ho :=
+    Smale.GeneralPosition.dimH_image_manifold_le
+      (isOpen_obstacleDomain c hf.continuous hg.continuous hβ.continuous)
+      (contMDiffOn_obstacleParameter c hf hg hβ)
+  have hdense :
+    Dense
+      ((collisionParameter c f β '' collisionDomain c f β) ∪
+          (obstacleParameter c f g β '' obstacleDomain c f g β))ᶜ := by
+    apply dense_compl_of_dimH_lt_finrank
+    rw [dimH_union]
+    exact max_lt (hs.trans_lt (Nat.cast_lt.mpr hdself)) (ho.trans_lt (Nat.cast_lt.mpr hdobstacle))
+  obtain ⟨δ, hδ, hvalid⟩ := exists_radius_valid c hf hβ hcompact hsupport
+  obtain ⟨a, hgood, hnorm⟩ := hdense.exists_dist_lt 0 (lt_min hε hδ)
+  have ha : ‖a‖ < Min.min ε δ := by simpa only [dist_zero_left] using hnorm
+  have hv := hvalid a (lt_min_iff.mp ha).2
+  refine ⟨a, (lt_min_iff.mp ha).1, hv, contMDiff_perturb c hf hβ hsupport hv, ?_, ?_⟩
+  · intro x y hxy
+    exact (collision_imp_old_and_equal_cutoff c hsupport hv (fun h => hgood (Or.inl h)) hxy).1
+  · exact avoids_of_not_obstacle_parameter c hsupport hv (fun h => hgood (Or.inr h))
+
+private theorem Smale.ManifoldImmersion.injective_fderiv_chart_iff {E G F H N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [TopologicalSpace N] [ChartedSpace H N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : E → N}
+    {x : E} (hf : MDifferentiableAt 𝓘(ℝ, E) J f x) (hx : f x ∈ c.source) :
+    Function.Injective (fderiv ℝ (c ∘ f) x) ↔ Function.Injective (mfderiv 𝓘(ℝ, E) J f x) := by
+  have hderiv : fderiv ℝ (c ∘ f) x = (mfderiv J 𝓘(ℝ, F) c (f x)).comp (mfderiv 𝓘(ℝ, E) J f x) := by
+    rw [← mfderiv_eq_fderiv, mfderiv_comp x (c.mdifferentiableAt (by simp) hx) hf]
+  have hc : Function.Injective (mfderiv J 𝓘(ℝ, F) c (f x)) :=
+    ((c.isLocalDiffeomorphAt J 𝓘(ℝ, F) ∞ hx).mfderivToContinuousLinearEquiv (by simp)).injective
+  rw [hderiv]
+  constructor
+  · intro h v w hvw
+    exact h (congrArg (mfderiv J 𝓘(ℝ, F) c (f x)) hvw)
+  · exact fun h => hc.comp h
+
+private theorem Smale.ManifoldImmersion.fderiv_chart_eq_zero_iff {E G F H N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [TopologicalSpace N] [ChartedSpace H N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : E → N}
+    {x : E} (hf : MDifferentiableAt 𝓘(ℝ, E) J f x) (hx : f x ∈ c.source) (v : E) :
+    fderiv ℝ (c ∘ f) x v = 0 ↔ mfderiv 𝓘(ℝ, E) J f x v = 0 := by
+  have hderiv : fderiv ℝ (c ∘ f) x = (mfderiv J 𝓘(ℝ, F) c (f x)).comp (mfderiv 𝓘(ℝ, E) J f x) := by
+    rw [← mfderiv_eq_fderiv, mfderiv_comp x (c.mdifferentiableAt (by simp) hx) hf]
+  have hc : Function.Injective (mfderiv J 𝓘(ℝ, F) c (f x)) :=
+    ((c.isLocalDiffeomorphAt J 𝓘(ℝ, F) ∞ hx).mfderivToContinuousLinearEquiv (by simp)).injective
+  rw [hderiv]
+  change (mfderiv J 𝓘(ℝ, F) c (f x)) (mfderiv 𝓘(ℝ, E) J f x v) = 0 ↔ _
+  constructor
+  · intro h
+    apply hc
+    simpa only [map_zero] using h
+  · intro h
+    rw [h, map_zero]
+
+private theorem Smale.ManifoldImmersion.isOpen_injective_nativeDerivative {P E G H N : Type*}
+    [NormedAddCommGroup P] [NormedSpace ℝ P] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] {f : P → E → N} {W : Set (P × E)} (hW : IsOpen W)
+    (hf : ContMDiffOn (𝓘(ℝ, P).prod 𝓘(ℝ, E)) J ∞ (Function.uncurry f) W) :
+    IsOpen {q : P × E | q ∈ W ∧ Function.Injective (mfderiv 𝓘(ℝ, E) J (f q.1) q.2)} := by
+  rw [isOpen_iff_mem_nhds]
+  rintro q ⟨hq, hqinj⟩
+  let c := NoExotic.modelChartPartialDiffeomorph (I := J) (f q.1 q.2)
+  let U := W ∩ (Function.uncurry f) ⁻¹' c.source
+  have hU : IsOpen U := hf.continuousOn.isOpen_inter_preimage hW c.open_source
+  have hqU : q ∈ U := ⟨hq, mem_extChartAt_source (f q.1 q.2)⟩
+  have hc : ContDiffOn ℝ ∞ (fun r : P × E => c (f r.1 r.2)) U := by
+    intro r hr
+    have hmap :
+      ContMDiffAt 𝓘(ℝ, P × E) (𝓘(ℝ, P).prod 𝓘(ℝ, E)) ∞ (fun s : P × E => (s.1, s.2)) r :=
+      contDiffAt_fst.contMDiffAt.prodMk contDiffAt_snd.contMDiffAt
+    have hfr := (hf.contMDiffAt (hW.mem_nhds hr.1)).comp r hmap
+    exact
+      ((c.contMDiffOn_toFun.contMDiffAt (c.open_source.mem_nhds hr.2)).comp r
+          hfr) |>.contDiffAt.contDiffWithinAt
+  have hd :=
+    Smale.MorsePerturbation.contDiffOn_spatialDerivative (f := fun a x => c (f a x)) hU hc
+  have hgood :
+    IsOpen
+      (U ∩
+        (fun r : P × E => fderiv ℝ (c ∘ f r.1) r.2) ⁻¹' {L : E →L[ℝ] G | Function.Injective L}) :=
+    hd.continuousOn.isOpen_inter_preimage hU ContinuousLinearMap.isOpen_injective
+  have hiff (r : P × E) (hr : r ∈ U) :
+    Function.Injective (fderiv ℝ (c ∘ f r.1) r.2) ↔
+      Function.Injective (mfderiv 𝓘(ℝ, E) J (f r.1) r.2) := by
+    have hs : ContMDiffAt 𝓘(ℝ, E) J ∞ (f r.1) r.2 :=
+      (hf.contMDiffAt (hW.mem_nhds hr.1)).comp r.2 (f := fun x : E => (r.1, x))
+        (contMDiffAt_const.prodMk contMDiffAt_id)
+    exact injective_fderiv_chart_iff c (hs.mdifferentiableAt (by simp)) hr.2
+  have hn := hgood.mem_nhds ⟨hqU, (hiff q hqU).mpr hqinj⟩
+  apply Filter.mem_of_superset hn
+  intro r hr
+  exact ⟨hr.1.1, (hiff r hr.1).mp hr.2⟩
+
+private theorem Smale.ManifoldImmersion.isOpen_injective_derivative_on {E G H N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [J.Boundaryless]
+    [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] {f : E → N} {W : Set E}
+    (hW : IsOpen W) (hf : ContMDiffOn 𝓘(ℝ, E) J ∞ f W) :
+    IsOpen {x : E | x ∈ W ∧ Function.Injective (mfderiv 𝓘(ℝ, E) J f x)} := by
+  have hfamily :
+    ContMDiffOn (𝓘(ℝ, ℝ).prod 𝓘(ℝ, E)) J ∞ (fun q : ℝ × E => f q.2) (Prod.snd ⁻¹' W) :=
+    hf.comp contMDiff_snd.contMDiffOn (fun _ hp => hp)
+  have hopen :=
+    (isOpen_injective_nativeDerivative (f := fun (_ : ℝ) => f) (hW.preimage continuous_snd)
+          hfamily).preimage
+      ((continuous_const (y := (0 : ℝ))).prodMk (continuous_id : Continuous (id : E → E)))
+  exact hopen
+
+private theorem Smale.ManifoldImmersion.isOpen_injective_derivative {E G H N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [J.Boundaryless]
+    [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] {f : E → N}
+    (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) :
+    IsOpen {x : E | Function.Injective (mfderiv 𝓘(ℝ, E) J f x)} := by
+  have hfamily : ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, E)) J ∞ (fun q : ℝ × E => f q.2) :=
+    hf.comp contMDiff_snd
+  have hopen :=
+    (isOpen_injective_nativeDerivative (f := fun (_ : ℝ) => f) isOpen_univ
+          hfamily.contMDiffOn).preimage
+      ((continuous_const (y := (0 : ℝ))).prodMk (continuous_id : Continuous (id : E → E)))
+  change IsOpen {x : E | True ∧ Function.Injective (mfderiv 𝓘(ℝ, E) J f x)} at hopen
+  simpa only [true_and] using hopen
+
+private theorem Smale.ManifoldImmersion.eventually_injective_nativeDerivative {P E G H N : Type*}
+    [NormedAddCommGroup P] [NormedSpace ℝ P] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] {f : P → E → N} {W : Set (P × E)} (hW : IsOpen W)
+    (hf : ContMDiffOn (𝓘(ℝ, P).prod 𝓘(ℝ, E)) J ∞ (Function.uncurry f) W) {K : Set E}
+    (hK : IsCompact K) {a₀ : P} (hmem : ∀ x ∈ K, (a₀, x) ∈ W)
+    (hinj : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J (f a₀) x)) :
+    ∀ᶠ a in 𝓝 a₀, ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J (f a) x) := by
+  have hopen :=
+    Smale.MorsePerturbation.isOpen_forall_mem_compact hK (isOpen_injective_nativeDerivative hW hf)
+  have hn := hopen.mem_nhds (fun x hx => ⟨hmem x hx, hinj x hx⟩)
+  filter_upwards [hn] with a ha x hx
+  exact (ha x hx).2
+
+private theorem
+    Smale.ChartMapPerturbation.eventually_perturb_injective_derivative {E G F H N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : E → N} {β : E → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) (hβ : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ β)
+    (hcompact : HasCompactSupport β) (hsupport : tsupport β ⊆ f ⁻¹' c.source) {K : Set E}
+    (hK : IsCompact K) (hinj : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f x)) :
+    ∀ᶠ a : F in 𝓝 0, ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J (perturb c f β a) x) := by
+  obtain ⟨δ, hδ, hvalid⟩ := exists_radius_valid c hf hβ hcompact hsupport
+  let W : Set (F × E) := {q | ‖q.1‖ < δ}
+  have hW : IsOpen W := isOpen_lt continuous_fst.norm continuous_const
+  have hfamily :
+    ContMDiffOn (𝓘(ℝ, F).prod 𝓘(ℝ, E)) J ∞ (fun q : F × E => perturb c f β q.1 q.2) W := by
+    intro q hq
+    exact (contMDiffAt_perturb c hf hβ hsupport q (hvalid q.1 hq)).contMDiffWithinAt
+  apply Smale.ManifoldImmersion.eventually_injective_nativeDerivative hW hfamily hK
+  · intro x _
+    change ‖(0 : F)‖ < δ
+    simpa only [norm_zero] using hδ
+  · intro x hx
+    have heq : perturb c f β (0 : F) = f := funext (perturb_zero c f β)
+    change Function.Injective (mfderiv 𝓘(ℝ, E) J (perturb c f β (0 : F)) x)
+    rw [heq]
+    exact hinj x hx
+
+private theorem Smale.ManifoldImmersion.exists_embedded_image_avoidance_step_controlled
+    {E E' G H H' Y N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup E'] [NormedSpace ℝ E'] [FiniteDimensional ℝ E'] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    {J : ModelWithCorners ℝ G H} {I' : ModelWithCorners ℝ E' H'} [J.Boundaryless]
+    [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y] [LindelofSpace (E × Y)]
+    [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] {ι : Type*} [Finite ι]
+    {C K : Set E} (p : ι → Smale.GeneralPosition.MapAvoidancePatch 𝓘(ℝ, E) J (N := N) C) (i : ι)
+    (f : C(E, N)) (g : C(Y, N)) (A : Set Y) (hf : ContMDiff 𝓘(ℝ, E) J ∞ f)
+    (hg : ContMDiff I' J ∞ g) (hcompatible : ∀ j, (p j).Compatible f)
+    (hself : 2 * Module.finrank ℝ E < Module.finrank ℝ G)
+    (hobstacle : Module.finrank ℝ E + Module.finrank ℝ E' < Module.finrank ℝ G) (hK : IsCompact K)
+    (hderiv : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f x)) {O : Set N} (hO : IsOpen O)
+    (hmaps : Set.MapsTo f K O) :
+    ∃ f' : C(E, N),
+      ContMDiff 𝓘(ℝ, E) J ∞ f' ∧
+        (∀ j, (p j).Compatible f') ∧
+          Smale.HomotopicRelWithin f f' C K O ∧
+            (∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f' x)) ∧
+              (∀ x y, f' x = f' y → f x = f y) ∧
+                Set.MapsTo f' K O ∧ ∀ x, (f x ∉ g '' A ∨ (p i).cutoff x ≠ 0) → f' x ∉ g '' A := by
+  have hkeep :
+    ∀ᶠ a in 𝓝 (0 : G),
+      ∀ j, (p j).Compatible (Smale.ChartMapPerturbation.perturb (p i).chart f (p i).cutoff a) := by
+    apply Filter.eventually_all.mpr
+    intro j
+    exact
+      Smale.ChartMapPerturbation.eventually_maps_compact_into_open (p i).chart hf (p i).smooth
+        (hcompatible i) (p j).compact.isCompact (p j).chart.open_source (hcompatible j)
+  have hold :=
+    Smale.ChartMapPerturbation.eventually_perturb_injective_derivative (p i).chart hf (p i).smooth
+      (p i).compact (hcompatible i) hK hderiv
+  have hstay :=
+    Smale.ChartMapPerturbation.eventually_maps_compact_into_open (p i).chart hf (p i).smooth
+      (hcompatible i) hK hO hmaps
+  obtain ⟨δ, hδ, hδkeep⟩ := Metric.mem_nhds_iff.mp (hkeep.and (hold.and hstay))
+  obtain ⟨r, hr, hvalid⟩ :=
+    Smale.ChartMapPerturbation.exists_radius_valid (p i).chart hf (p i).smooth (p i).compact
+      (hcompatible i)
+  obtain ⟨a, ha, -, hsmooth, hnoNew, havoid⟩ :=
+    Smale.ChartMapPerturbation.exists_small_embedding_avoiding_parameter (p i).chart hf hg
+      (p i).smooth (p i).compact (hcompatible i) hself hobstacle (lt_min hδ hr)
+  have haδ : ‖a‖ < δ := (lt_min_iff.mp ha).1
+  have har : ‖a‖ < r := (lt_min_iff.mp ha).2
+  let f' : C(E, N) := ⟨_, hsmooth.continuous⟩
+  have hretained :=
+    hδkeep (show a ∈ Metric.ball 0 δ by simpa only [Metric.mem_ball, dist_zero_right] using haδ)
+  let Hrel :=
+    Smale.ChartMapPerturbation.homotopyRel (p i).chart hf (p i).smooth (hcompatible i) hvalid har
+  refine ⟨f', hsmooth, hretained.1, ?_, hretained.2.1, hnoNew, hretained.2.2, ?_⟩
+  · refine ⟨{ Hrel.toHomotopy with prop' := fun t x hx => Hrel.eq_fst t ((p i).fixed x hx) }, ?_⟩
+    intro t x hx
+    change Smale.ChartMapPerturbation.perturb (p i).chart f (p i).cutoff ((t : ℝ) • a) x ∈ O
+    have hsmall : (t : ℝ) • a ∈ Metric.ball (0 : G) δ := by
+      simpa only [Metric.mem_ball, dist_zero_right] using
+        Smale.ChartMapPerturbation.norm_interval_smul_lt haδ t
+    exact (hδkeep hsmall).2.2 hx
+  · intro x hx
+    by_cases hzero : (p i).cutoff x = 0
+    · have hold : f x ∉ g '' A := hx.resolve_right (Classical.not_not.mpr hzero)
+      change Smale.ChartMapPerturbation.perturb (p i).chart f (p i).cutoff a x ∉ g '' A
+      rwa [Smale.ChartMapPerturbation.perturb_eq_of_zero _ _ _ _ hzero]
+    · rintro ⟨y, _, hy⟩
+      exact havoid x hzero y hy.symm
+
+private theorem Smale.ManifoldImmersion.exists_finite_embedded_image_avoidance_controlled
+    {E E' G H H' Y N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup E'] [NormedSpace ℝ E'] [FiniteDimensional ℝ E'] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    {J : ModelWithCorners ℝ G H} {I' : ModelWithCorners ℝ E' H'} [J.Boundaryless]
+    [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y] [LindelofSpace (E × Y)]
+    [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] {ι : Type*} [Finite ι]
+    {C K : Set E} (p : ι → Smale.GeneralPosition.MapAvoidancePatch 𝓘(ℝ, E) J (N := N) C)
+    (f : C(E, N)) (g : C(Y, N)) (A : Set Y) (hf : ContMDiff 𝓘(ℝ, E) J ∞ f)
+    (hg : ContMDiff I' J ∞ g) (hcompatible : ∀ j, (p j).Compatible f)
+    (hself : 2 * Module.finrank ℝ E < Module.finrank ℝ G)
+    (hobstacle : Module.finrank ℝ E + Module.finrank ℝ E' < Module.finrank ℝ G) (hK : IsCompact K)
+    (hderiv : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f x)) {O : Set N} (hO : IsOpen O)
+    (hmaps : Set.MapsTo f K O) (s : Finset ι) :
+    ∃ f' : C(E, N),
+      ContMDiff 𝓘(ℝ, E) J ∞ f' ∧
+        (∀ j, (p j).Compatible f') ∧
+          Smale.HomotopicRelWithin f f' C K O ∧
+            (∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f' x)) ∧
+              (∀ x y, f' x = f' y → f x = f y) ∧
+                Set.MapsTo f' K O ∧
+                  ∀ x, (f x ∉ g '' A ∨ ∃ i ∈ s, (p i).cutoff x ≠ 0) → f' x ∉ g '' A := by
+  classical
+    induction s using Finset.induction_on with
+  |
+    empty =>
+    refine
+      ⟨f, hf, hcompatible, Smale.HomotopicRelWithin.refl f C hmaps, hderiv, (fun _ _ hxy => hxy),
+        hmaps, ?_⟩
+    intro x hx
+    simpa only [Finset.notMem_empty, false_and, exists_false, or_false] using hx
+  | @insert i s _
+    ih =>
+    obtain ⟨f₁, hf₁, hc₁, hhom₁, hd₁, hnoNew₁, hmaps₁, havoid₁⟩ := ih
+    obtain ⟨f₂, hf₂, hc₂, hhom₂, hd₂, hnoNew₂, hmaps₂, havoid₂⟩ :=
+      exists_embedded_image_avoidance_step_controlled p i f₁ g A hf₁ hg hc₁ hself hobstacle hK hd₁
+        hO hmaps₁
+    refine
+      ⟨f₂, hf₂, hc₂, hhom₁.trans hhom₂, hd₂, (fun x y hxy => hnoNew₁ x y (hnoNew₂ x y hxy)),
+        hmaps₂, ?_⟩
+    intro x hx
+    apply havoid₂ x
+    rcases hx with hold | ⟨j, hj, hactive⟩
+    · exact Or.inl (havoid₁ x (Or.inl hold))
+    · rcases Finset.mem_insert.mp hj with rfl | hjs
+      · exact Or.inr hactive
+      · exact Or.inl (havoid₁ x (Or.inr ⟨j, hjs, hactive⟩))
+
+private theorem
+    Smale.ManifoldImmersion.exists_embedded_avoidance_on_compact_of_isClosed_image_controlled
+    {E E' G H H' Y N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup E'] [NormedSpace ℝ E'] [FiniteDimensional ℝ E'] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    {J : ModelWithCorners ℝ G H} {I' : ModelWithCorners ℝ E' H'} [J.Boundaryless]
+    [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y] [LindelofSpace (E × Y)]
+    [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N] (f : C(E, N))
+    (g : C(Y, N)) (A : Set Y) (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) (hg : ContMDiff I' J ∞ g)
+    (hclosed : IsClosed (g '' A)) (hself : 2 * Module.finrank ℝ E < Module.finrank ℝ G)
+    (hobstacle : Module.finrank ℝ E + Module.finrank ℝ E' < Module.finrank ℝ G) {K L C : Set E}
+    (hK : IsCompact K) (hL : IsCompact L) (hC : IsClosed C) (hinj : Set.InjOn f K)
+    (hderiv : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f x))
+    (hfixed : ∀ x ∈ L ∩ C, f x ∉ g '' A) {O : Set N} (hO : IsOpen O) (hmaps : Set.MapsTo f K O) :
+    ∃ f' : C(E, N),
+      ContMDiff 𝓘(ℝ, E) J ∞ f' ∧
+        Smale.HomotopicRelWithin f f' C K O ∧
+          Topology.IsClosedEmbedding (fun x : K => f' x) ∧
+            (∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f' x)) ∧
+              (∀ x y, f' x = f' y → f x = f y) ∧
+                Set.MapsTo f' K O ∧ ∀ x, (f x ∉ g '' A ∨ x ∈ L) → f' x ∉ g '' A := by
+  classical
+  let bad : Set E := L ∩ f ⁻¹' g '' A
+  have hbad : IsCompact bad := hL.inter_right (hclosed.preimage f.continuous)
+  have hp (x : bad) :
+    ∃ p : Smale.GeneralPosition.MapAvoidancePatch 𝓘(ℝ, E) J (N := N) C,
+      p.Compatible f ∧ p.cutoff x.1 ≠ 0 :=
+    Smale.GeneralPosition.exists_avoidance_patch_at (I := 𝓘(ℝ, E)) (J := J) f hC
+      (fun hx => hfixed x.1 ⟨x.property.1, hx⟩ x.property.2)
+  choose p hpcompatible hpactive using hp
+  have hopen (x : bad) : IsOpen (Function.support (p x).cutoff) :=
+    isOpen_ne_fun (p x).smooth.continuous continuous_const
+  have hcover : bad ⊆ ⋃ x : bad, Function.support (p x).cutoff := by
+    intro x hx
+    exact Set.mem_iUnion.mpr ⟨⟨x, hx⟩, hpactive ⟨x, hx⟩⟩
+  obtain ⟨s, hs⟩ :=
+    hbad.elim_finite_subcover (fun x : bad => Function.support (p x).cutoff) hopen hcover
+  obtain ⟨f', hf', -, hhom, hderiv', hnoNew, hmaps', havoid⟩ :=
+    exists_finite_embedded_image_avoidance_controlled (fun i : s => p i.1) f g A hf hg
+      (fun i => hpcompatible i.1) hself hobstacle hK hderiv hO hmaps Finset.univ
+  refine ⟨f', hf', hhom, ?_, hderiv', hnoNew, hmaps', ?_⟩
+  · let : CompactSpace K := isCompact_iff_compactSpace.mp hK
+    apply (f'.continuous.comp continuous_subtype_val).isClosedEmbedding
+    intro x y hxy
+    exact Subtype.ext (hinj x.property y.property (hnoNew x y hxy))
+  · intro x hx
+    apply havoid x
+    rcases hx with hold | hxL
+    · exact Or.inl hold
+    · by_cases hxg : f x ∈ g '' A
+      · have hx : x ∈ bad := ⟨hxL, hxg⟩
+        obtain ⟨i, hi, hix⟩ := Set.mem_iUnion₂.mp (hs hx)
+        exact Or.inr ⟨⟨i, hi⟩, Finset.mem_univ _, hix⟩
+      · exact Or.inl hxg
+
+private theorem Smale.ManifoldImmersion.exists_embedded_avoidance_on_compact_of_isClosed_image
+    {E E' G H H' Y N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup E'] [NormedSpace ℝ E'] [FiniteDimensional ℝ E'] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    {J : ModelWithCorners ℝ G H} {I' : ModelWithCorners ℝ E' H'} [J.Boundaryless]
+    [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y] [LindelofSpace (E × Y)]
+    [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N] (f : C(E, N))
+    (g : C(Y, N)) (A : Set Y) (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) (hg : ContMDiff I' J ∞ g)
+    (hclosed : IsClosed (g '' A)) (hself : 2 * Module.finrank ℝ E < Module.finrank ℝ G)
+    (hobstacle : Module.finrank ℝ E + Module.finrank ℝ E' < Module.finrank ℝ G) {K L C : Set E}
+    (hK : IsCompact K) (hL : IsCompact L) (hC : IsClosed C) (hinj : Set.InjOn f K)
+    (hderiv : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f x))
+    (hfixed : ∀ x ∈ L ∩ C, f x ∉ g '' A) {O : Set N} (hO : IsOpen O) (hmaps : Set.MapsTo f K O) :
+    ∃ f' : C(E, N),
+      ContMDiff 𝓘(ℝ, E) J ∞ f' ∧
+        f.HomotopicRel f' C ∧
+          Topology.IsClosedEmbedding (fun x : K => f' x) ∧
+            (∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f' x)) ∧
+              (∀ x y, f' x = f' y → f x = f y) ∧
+                Set.MapsTo f' K O ∧ ∀ x, (f x ∉ g '' A ∨ x ∈ L) → f' x ∉ g '' A := by
+  obtain ⟨f', hf', hhom, hemb, hd, hnoNew, hmaps', havoid⟩ :=
+    exists_embedded_avoidance_on_compact_of_isClosed_image_controlled f g A hf hg hclosed hself
+      hobstacle hK hL hC hinj hderiv hfixed hO hmaps
+  exact ⟨f', hf', hhom.homotopicRel, hemb, hd, hnoNew, hmaps', havoid⟩
+
+private theorem Smale.ManifoldImmersion.exists_embedded_avoidance_on_compact_of_isClosed_range
+    {E E' G H H' Y N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup E'] [NormedSpace ℝ E'] [FiniteDimensional ℝ E'] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    {J : ModelWithCorners ℝ G H} {I' : ModelWithCorners ℝ E' H'} [J.Boundaryless]
+    [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y] [LindelofSpace (E × Y)]
+    [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N] (f : C(E, N))
+    (g : C(Y, N)) (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) (hg : ContMDiff I' J ∞ g)
+    (hclosed : IsClosed (Set.range g)) (hself : 2 * Module.finrank ℝ E < Module.finrank ℝ G)
+    (hobstacle : Module.finrank ℝ E + Module.finrank ℝ E' < Module.finrank ℝ G) {K L C : Set E}
+    (hK : IsCompact K) (hL : IsCompact L) (hC : IsClosed C) (hinj : Set.InjOn f K)
+    (hderiv : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f x))
+    (hfixed : ∀ x ∈ L ∩ C, f x ∉ Set.range g) :
+    ∃ f' : C(E, N),
+      ContMDiff 𝓘(ℝ, E) J ∞ f' ∧
+        f.HomotopicRel f' C ∧
+          Topology.IsClosedEmbedding (fun x : K => f' x) ∧
+            (∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f' x)) ∧
+              (∀ x y, f' x = f' y → f x = f y) ∧
+                ∀ x, (f x ∉ Set.range g ∨ x ∈ L) → f' x ∉ Set.range g := by
+  obtain ⟨f', hf', hhom, hemb, hd, hnoNew, -, havoid⟩ :=
+    exists_embedded_avoidance_on_compact_of_isClosed_image f g Set.univ hf hg
+      (by simpa only [Set.image_univ] using hclosed) hself hobstacle hK hL hC hinj hderiv
+      (by simpa only [Set.image_univ] using hfixed) isOpen_univ (fun _ _ => Set.mem_univ _)
+  refine ⟨f', hf', hhom, hemb, hd, hnoNew, ?_⟩
+  simpa only [Set.image_univ] using havoid
+
+private abbrev Smale.PlaneImmersion.Plane :=
+  ℝ × ℝ
+
+private def Smale.PlaneImmersion.linearMap {F : Type*} [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (A : F × F) : Plane →L[ℝ] F :=
+  (ContinuousLinearMap.fst ℝ ℝ ℝ).smulRight A.1 + (ContinuousLinearMap.snd ℝ ℝ ℝ).smulRight A.2
+
+private theorem
+    Smale.PlaneImmersion.linearMap_apply {F : Type*} [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (A : F × F) (v : Plane) : linearMap A v = v.1 • A.1 + v.2 • A.2 :=
+  rfl
+
+private def Smale.PlaneImmersion.perturb {F : Type*} [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (f : Plane → F) (A : F × F) (x : Plane) : F :=
+  f x + linearMap A x
+
+private theorem Smale.PlaneImmersion.contDiff_perturb_family {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {f : Plane → F} (hf : ContDiff ℝ ∞ f) :
+    ContDiff ℝ ∞ (fun q : (F × F) × Plane => perturb f q.1 q.2) :=
+  (hf.comp contDiff_snd).add
+    (((contDiff_fst.comp contDiff_snd).smul (contDiff_fst.comp contDiff_fst)).add
+      ((contDiff_snd.comp contDiff_snd).smul (contDiff_snd.comp contDiff_fst)))
+
+private theorem
+    Smale.PlaneImmersion.fderiv_perturb {F : Type*} [NormedAddCommGroup F] [NormedSpace ℝ F]
+    {f : Plane → F} (hf : ContDiff ℝ ∞ f) (A : F × F) (x : Plane) :
+    fderiv ℝ (perturb f A) x = fderiv ℝ f x + linearMap A :=
+  ((hf.differentiable (by simp) x).hasFDerivAt.add (linearMap A).hasFDerivAt).fderiv
+
+private def Smale.PlaneImmersion.firstCollisionDomain {F : Type*} : Set (Plane × (Plane × F)) :=
+  {q | q.1.1 - q.2.1.1 ≠ 0}
+
+private def Smale.PlaneImmersion.secondCollisionDomain {F : Type*} : Set (Plane × (Plane × F)) :=
+  {q | q.1.2 - q.2.1.2 ≠ 0}
+
+private def Smale.PlaneImmersion.firstCollision {F : Type*} [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (f : Plane → F) (q : Plane × (Plane × F)) : F × F :=
+  ((q.1.1 - q.2.1.1)⁻¹ • (f q.2.1 - f q.1 - (q.1.2 - q.2.1.2) • q.2.2), q.2.2)
+
+private def
+    Smale.PlaneImmersion.secondCollision {F : Type*} [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (f : Plane → F) (q : Plane × (Plane × F)) : F × F :=
+  (q.2.2, (q.1.2 - q.2.1.2)⁻¹ • (f q.2.1 - f q.1 - (q.1.1 - q.2.1.1) • q.2.2))
+
+private theorem
+    Smale.PlaneImmersion.isOpen_firstCollisionDomain {F : Type*} [NormedAddCommGroup F] :
+    IsOpen (firstCollisionDomain (F := F)) :=
+  isOpen_ne.preimage (continuous_fst.fst.sub continuous_snd.fst.fst)
+
+private theorem
+    Smale.PlaneImmersion.isOpen_secondCollisionDomain {F : Type*} [NormedAddCommGroup F] :
+    IsOpen (secondCollisionDomain (F := F)) :=
+  isOpen_ne.preimage (continuous_fst.snd.sub continuous_snd.fst.snd)
+
+private theorem Smale.PlaneImmersion.contDiffOn_firstCollision {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {f : Plane → F} (hf : ContDiff ℝ ∞ f) :
+    ContDiffOn ℝ ∞ (firstCollision f) firstCollisionDomain := by
+  have h₁ : ContDiff ℝ ∞ (fun q : Plane × (Plane × F) => q.1.1 - q.2.1.1) :=
+    contDiff_fst.fst.sub contDiff_snd.fst.fst
+  have h₂ : ContDiff ℝ ∞ (fun q : Plane × (Plane × F) => q.1.2 - q.2.1.2) :=
+    contDiff_fst.snd.sub contDiff_snd.fst.snd
+  exact
+    ((h₁.contDiffOn.inv (fun _ h => h)).smul
+          (((hf.comp contDiff_snd.fst).sub (hf.comp contDiff_fst)).sub
+              (h₂.smul contDiff_snd.snd)).contDiffOn).prodMk
+      contDiff_snd.snd.contDiffOn
+
+private theorem Smale.PlaneImmersion.contDiffOn_secondCollision {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {f : Plane → F} (hf : ContDiff ℝ ∞ f) :
+    ContDiffOn ℝ ∞ (secondCollision f) secondCollisionDomain := by
+  have h₁ : ContDiff ℝ ∞ (fun q : Plane × (Plane × F) => q.1.1 - q.2.1.1) :=
+    contDiff_fst.fst.sub contDiff_snd.fst.fst
+  have h₂ : ContDiff ℝ ∞ (fun q : Plane × (Plane × F) => q.1.2 - q.2.1.2) :=
+    contDiff_fst.snd.sub contDiff_snd.fst.snd
+  exact
+    contDiff_snd.snd.contDiffOn.prodMk
+      ((h₂.contDiffOn.inv (fun _ h => h)).smul
+        (((hf.comp contDiff_snd.fst).sub (hf.comp contDiff_fst)).sub
+            (h₁.smul contDiff_snd.snd)).contDiffOn)
+
+private theorem Smale.PlaneImmersion.mem_collision_of_eq {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (f : Plane → F) (A : F × F) {x y : Plane} (hxy : x ≠ y)
+    (heq : perturb f A x = perturb f A y) :
+    A ∈ firstCollision f '' firstCollisionDomain ∪ secondCollision f '' secondCollisionDomain := by
+  have hlinear : linearMap A (x - y) = f y - f x := by
+    rw [map_sub]
+    change f x + linearMap A x = f y + linearMap A y at heq
+    exact (sub_eq_sub_iff_add_eq_add).mpr (by simpa only [add_comm] using heq)
+  change (x.1 - y.1) • A.1 + (x.2 - y.2) • A.2 = f y - f x at hlinear
+  by_cases hfirst : x.1 - y.1 = 0
+  · have hsecond : x.2 - y.2 ≠ 0 := by
+      intro h
+      exact hxy (Prod.ext (sub_eq_zero.mp hfirst) (sub_eq_zero.mp h))
+    apply Or.inr
+    refine ⟨(x, (y, A.1)), hsecond, Prod.ext rfl ?_⟩
+    change (x.2 - y.2)⁻¹ • (f y - f x - (x.1 - y.1) • A.1) = A.2
+    rw [← eq_sub_of_add_eq' hlinear, inv_smul_smul₀ hsecond]
+  · apply Or.inl
+    refine ⟨(x, (y, A.2)), hfirst, Prod.ext ?_ rfl⟩
+    change (x.1 - y.1)⁻¹ • (f y - f x - (x.2 - y.2) • A.2) = A.1
+    rw [← eq_sub_of_add_eq hlinear, inv_smul_smul₀ hfirst]
+
+private theorem
+    Smale.PlaneImmersion.injective_perturb_of_not_collision {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (f : Plane → F) {A : F × F}
+    (hA :
+      A ∉ firstCollision f '' firstCollisionDomain ∪ secondCollision f '' secondCollisionDomain) :
+    Function.Injective (perturb f A) := by
+  intro x y heq
+  by_contra hxy
+  exact hA (mem_collision_of_eq f A hxy heq)
+
+private def Smale.PlaneImmersion.badFirst {F : Type*} [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (f : Plane → F) (q : Plane × (ℝ × F)) : F × F :=
+  (-fderiv ℝ f q.1 (1, q.2.1) - q.2.1 • q.2.2, q.2.2)
+
+private def Smale.PlaneImmersion.badSecond {F : Type*} [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (f : Plane → F) (q : Plane × (ℝ × F)) : F × F :=
+  (q.2.2, -fderiv ℝ f q.1 (q.2.1, 1) - q.2.1 • q.2.2)
+
+private theorem Smale.PlaneImmersion.contDiff_badFirst {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {f : Plane → F} (hf : ContDiff ℝ ∞ f) : ContDiff ℝ ∞ (badFirst f) := by
+  have hd : ContDiff ℝ ∞ (fderiv ℝ f) := hf.fderiv_right (by simp)
+  have he : ContDiff ℝ ∞ (fun q : Plane × (ℝ × F) => fderiv ℝ f q.1 (1, q.2.1)) :=
+    (hd.comp contDiff_fst).clm_apply (contDiff_const.prodMk (contDiff_fst.comp contDiff_snd))
+  exact
+    (he.neg.sub ((contDiff_fst.comp contDiff_snd).smul (contDiff_snd.comp contDiff_snd))).prodMk
+      (contDiff_snd.comp contDiff_snd)
+
+private theorem Smale.PlaneImmersion.contDiff_badSecond {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {f : Plane → F} (hf : ContDiff ℝ ∞ f) : ContDiff ℝ ∞ (badSecond f) := by
+  have hd : ContDiff ℝ ∞ (fderiv ℝ f) := hf.fderiv_right (by simp)
+  have he : ContDiff ℝ ∞ (fun q : Plane × (ℝ × F) => fderiv ℝ f q.1 (q.2.1, 1)) :=
+    (hd.comp contDiff_fst).clm_apply ((contDiff_fst.comp contDiff_snd).prodMk contDiff_const)
+  exact
+    (contDiff_snd.comp contDiff_snd).prodMk
+      (he.neg.sub ((contDiff_fst.comp contDiff_snd).smul (contDiff_snd.comp contDiff_snd)))
+
+private theorem Smale.PlaneImmersion.mem_bad_of_nonzero_kernel {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (f : Plane → F) (A : F × F) (x v : Plane) (hv : v ≠ 0)
+    (hker : (fderiv ℝ f x + linearMap A) v = 0) :
+    A ∈ Set.range (badFirst f) ∪ Set.range (badSecond f) := by
+  by_cases hfirst : v.1 = 0
+  · have hsecond : v.2 ≠ 0 := by
+      intro h
+      exact hv (Prod.ext hfirst h)
+    let r := v.1 / v.2
+    have hvec : (r, (1 : ℝ)) = v.2⁻¹ • v := by
+      apply Prod.ext
+      · change v.1 / v.2 = v.2⁻¹ * v.1
+        rw [div_eq_mul_inv, mul_comm]
+      · change (1 : ℝ) = v.2⁻¹ * v.2
+        rw [inv_mul_cancel₀ hsecond]
+    have hz : (fderiv ℝ f x + linearMap A) (r, 1) = 0 := by rw [hvec, map_smul, hker, smul_zero]
+    change fderiv ℝ f x (r, 1) + (r • A.1 + (1 : ℝ) • A.2) = 0 at hz
+    rw [one_smul, ← add_assoc] at hz
+    have hsolve : A.2 = -(fderiv ℝ f x (r, 1) + r • A.1) := eq_neg_of_add_eq_zero_right hz
+    apply Or.inr
+    refine ⟨(x, (r, A.1)), Prod.ext rfl ?_⟩
+    change -fderiv ℝ f x (r, 1) - r • A.1 = A.2
+    simpa only [neg_add, sub_eq_add_neg] using hsolve.symm
+  · let r := v.2 / v.1
+    have hvec : ((1 : ℝ), r) = v.1⁻¹ • v := by
+      apply Prod.ext
+      · change (1 : ℝ) = v.1⁻¹ * v.1
+        rw [inv_mul_cancel₀ hfirst]
+      · change v.2 / v.1 = v.1⁻¹ * v.2
+        rw [div_eq_mul_inv, mul_comm]
+    have hz : (fderiv ℝ f x + linearMap A) (1, r) = 0 := by rw [hvec, map_smul, hker, smul_zero]
+    change fderiv ℝ f x (1, r) + ((1 : ℝ) • A.1 + r • A.2) = 0 at hz
+    rw [one_smul, ← add_assoc] at hz
+    have hsolve : fderiv ℝ f x (1, r) + A.1 = -(r • A.2) := eq_neg_of_add_eq_zero_left hz
+    apply Or.inl
+    refine ⟨(x, (r, A.2)), Prod.ext ?_ rfl⟩
+    change -fderiv ℝ f x (1, r) - r • A.2 = A.1
+    rw [sub_eq_add_neg, ← hsolve, neg_add_cancel_left]
+
+private theorem
+    Smale.PlaneImmersion.injective_add_linearMap_of_not_bad {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (f : Plane → F) {A : F × F}
+    (hA : A ∉ Set.range (badFirst f) ∪ Set.range (badSecond f)) (x : Plane) :
+    Function.Injective (fderiv ℝ f x + linearMap A) := by
+  intro v w hvw
+  have hz : (fderiv ℝ f x + linearMap A) (v - w) = 0 := by rw [map_sub, hvw, sub_self]
+  have heq : v - w = 0 := by
+    by_contra hne
+    exact hA (mem_bad_of_nonzero_kernel f A x (v - w) hne hz)
+  exact sub_eq_zero.mp heq
+
+private theorem Smale.PlaneImmersion.dimH_bad_parameters_le {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [FiniteDimensional ℝ F] {f : Plane → F} (hf : ContDiff ℝ ∞ f) :
+    dimH (Set.range (badFirst f) ∪ Set.range (badSecond f)) ≤
+      (Module.finrank ℝ (Plane × (ℝ × F)) : ℝ≥0∞) := by
+  have hfirst : dimH (Set.range (badFirst f)) ≤ (Module.finrank ℝ (Plane × (ℝ × F)) : ℝ≥0∞) := by
+    rw [← Set.image_univ]
+    exact
+      Smale.GeneralPosition.dimH_image_manifold_le isOpen_univ
+        (contDiff_badFirst hf).contMDiff.contMDiffOn
+  have hsecond : dimH (Set.range (badSecond f)) ≤ (Module.finrank ℝ (Plane × (ℝ × F)) : ℝ≥0∞) := by
+    rw [← Set.image_univ]
+    exact
+      Smale.GeneralPosition.dimH_image_manifold_le isOpen_univ
+        (contDiff_badSecond hf).contMDiff.contMDiffOn
+  rw [dimH_union]
+  exact max_le hfirst hsecond
+
+private theorem Smale.PlaneImmersion.dimH_collision_parameters_le {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [FiniteDimensional ℝ F] {f : Plane → F} (hf : ContDiff ℝ ∞ f) :
+    dimH (firstCollision f '' firstCollisionDomain ∪ secondCollision f '' secondCollisionDomain) ≤
+      (Module.finrank ℝ (Plane × (Plane × F)) : ℝ≥0∞) := by
+  have hfirst :=
+    Smale.GeneralPosition.dimH_image_manifold_le (isOpen_firstCollisionDomain (F := F))
+      (contDiffOn_firstCollision hf).contMDiffOn
+  have hsecond :=
+    Smale.GeneralPosition.dimH_image_manifold_le (isOpen_secondCollisionDomain (F := F))
+      (contDiffOn_secondCollision hf).contMDiffOn
+  rw [dimH_union]
+  exact max_le hfirst hsecond
+
+private theorem Smale.PlaneImmersion.dense_injective_immersive_parameters {F : Type*}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [FiniteDimensional ℝ F] {f : Plane → F}
+    (hf : ContDiff ℝ ∞ f) (hdim : 5 ≤ Module.finrank ℝ F) :
+    Dense
+      ((Set.range (badFirst f) ∪ Set.range (badSecond f)) ∪
+          (firstCollision f '' firstCollisionDomain ∪
+            secondCollision f '' secondCollisionDomain))ᶜ := by
+  have hd₁ : Module.finrank ℝ (Plane × (ℝ × F)) < Module.finrank ℝ (F × F) := by
+    change Module.finrank ℝ ((ℝ × ℝ) × (ℝ × F)) < Module.finrank ℝ (F × F)
+    simp only [Module.finrank_prod, Module.finrank_self]
+    omega
+  have hd₂ : Module.finrank ℝ (Plane × (Plane × F)) < Module.finrank ℝ (F × F) := by
+    change Module.finrank ℝ ((ℝ × ℝ) × ((ℝ × ℝ) × F)) < Module.finrank ℝ (F × F)
+    simp only [Module.finrank_prod, Module.finrank_self]
+    omega
+  apply dense_compl_of_dimH_lt_finrank
+  rw [dimH_union]
+  exact
+    max_lt ((dimH_bad_parameters_le hf).trans_lt (Nat.cast_lt.mpr hd₁))
+      ((dimH_collision_parameters_le hf).trans_lt (Nat.cast_lt.mpr hd₂))
+
+private theorem Smale.PlaneImmersion.exists_small_affine_injective_immersion {F : Type*}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [FiniteDimensional ℝ F] {f : Plane → F}
+    (hf : ContDiff ℝ ∞ f) (hdim : 5 ≤ Module.finrank ℝ F) {ε : ℝ} (hε : 0 < ε) :
+    ∃ A : F × F,
+      ‖A‖ < ε ∧
+        ContDiff ℝ ∞ (perturb f A) ∧
+          Function.Injective (perturb f A) ∧ ∀ x, Function.Injective (fderiv ℝ (perturb f A) x) :=
+  by
+  obtain ⟨A, hA, hnorm⟩ := (dense_injective_immersive_parameters hf hdim).exists_dist_lt 0 hε
+  refine ⟨A, ?_, ?_, ?_, ?_⟩
+  · simpa only [dist_zero_left] using hnorm
+  · exact (contDiff_perturb_family hf).comp (contDiff_const.prodMk contDiff_id)
+  · exact injective_perturb_of_not_collision f (fun h => hA (Or.inr h))
+  · intro x
+    rw [fderiv_perturb hf]
+    exact injective_add_linearMap_of_not_bad f (fun h => hA (Or.inl h)) x
+
+private def Smale.PlaneImmersion.displacement {F : Type*} [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (β : Plane → ℝ) (A : F × F) (x : Plane) : F :=
+  β x • linearMap A x
+
+private theorem Smale.PlaneImmersion.contDiff_displacement_family {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {β : Plane → ℝ} (hβ : ContDiff ℝ ∞ β) :
+    ContDiff ℝ ∞ (fun q : (F × F) × Plane => displacement β q.1 q.2) :=
+  (hβ.comp contDiff_snd).smul
+    ((contDiff_snd.fst.smul contDiff_fst.fst).add (contDiff_snd.snd.smul contDiff_fst.snd))
+
+private theorem Smale.PlaneImmersion.displacement_zero {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (β : Plane → ℝ) (x : Plane) : displacement β (0 : F × F) x = 0 := by
+  simp only [displacement, linearMap_apply, Prod.fst_zero, Prod.snd_zero, smul_zero, add_zero]
+
+private theorem Smale.PlaneImmersion.displacement_of_zero {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {β : Plane → ℝ} (A : F × F) {x : Plane} (hx : β x = 0) :
+    displacement β A x = 0 := by simp only [displacement, hx, zero_smul]
+
+private theorem Smale.PlaneImmersion.eventually_displacement_lt {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {β : Plane → ℝ} (hβ : ContDiff ℝ ∞ β) (hcompact : HasCompactSupport β)
+    {ε : ℝ} (hε : 0 < ε) : ∀ᶠ A : F × F in 𝓝 0, ∀ x, ‖displacement β A x‖ < ε := by
+  have hsupport : ∀ᶠ A : F × F in 𝓝 0, ∀ x ∈ tsupport β, ‖displacement β A x‖ < ε := by
+    apply hcompact.isCompact.eventually_forall_of_forall_eventually
+    intro x _
+    have hc :=
+      (contDiff_displacement_family (F := F) hβ).continuous.norm.continuousAt (x :=
+        ((0 : F × F), x))
+    have hval : ‖displacement β (0 : F × F) x‖ < ε := by
+      simpa only [displacement_zero, norm_zero] using hε
+    exact hc.preimage_mem_nhds (isOpen_Iio.mem_nhds hval)
+  filter_upwards [hsupport] with A hA x
+  by_cases hx : x ∈ tsupport β
+  · exact hA x hx
+  · have hzero : β x = 0 := by
+      by_contra hne
+      exact hx (subset_tsupport β hne)
+    simpa only [displacement_of_zero A hzero, norm_zero] using hε
+
+private theorem
+    Smale.PlaneImmersion.exists_radius_displacement_lt {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {β : Plane → ℝ} (hβ : ContDiff ℝ ∞ β) (hcompact : HasCompactSupport β)
+    {ε : ℝ} (hε : 0 < ε) : ∃ δ > (0 : ℝ), ∀ A : F × F, ‖A‖ < δ → ∀ x, ‖displacement β A x‖ < ε := by
+  have hn : {A : F × F | ∀ x, ‖displacement β A x‖ < ε} ∈ 𝓝 0 :=
+    eventually_displacement_lt hβ hcompact hε
+  obtain ⟨δ, hδ, hball⟩ := Metric.mem_nhds_iff.mp hn
+  exact ⟨δ, hδ, fun A hA => hball (by simpa only [Metric.mem_ball, dist_zero_right] using hA)⟩
+
+private def
+    Smale.ManifoldImmersion.affinePatch {G F H N : Type*} [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [TopologicalSpace N] [ChartedSpace H N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞)
+    (f : Smale.PlaneImmersion.Plane → N) (β : Smale.PlaneImmersion.Plane → ℝ) (A : F × F) :
+    Smale.PlaneImmersion.Plane → N :=
+  Smale.ChartMapPerturbation.variablePerturb c f β (Smale.PlaneImmersion.displacement β A)
+
+private theorem Smale.ManifoldImmersion.chart_affinePatch_on_plateau {G F H N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [TopologicalSpace N] [ChartedSpace H N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : Smale.PlaneImmersion.Plane → N}
+    {β χ : Smale.PlaneImmersion.Plane → ℝ} {A : F × F} (hsupport : tsupport β ⊆ f ⁻¹' c.source)
+    (hχ : ∀ x ∈ tsupport β, χ x = 1)
+    (hvalid :
+      ∀ x, Smale.ChartMapPerturbation.Valid c f β (Smale.PlaneImmersion.displacement β A x))
+    {x : Smale.PlaneImmersion.Plane} (hx : β x = 1) :
+    c (affinePatch c f β A x) =
+      Smale.PlaneImmersion.perturb (Smale.ChartMapPerturbation.cutoffCoordinates c f χ) A x := by
+  have hxs : x ∈ tsupport β := subset_tsupport β (by change β x ≠ 0; rw [hx]; norm_num)
+  change
+    c (Smale.ChartMapPerturbation.perturb c f β (Smale.PlaneImmersion.displacement β A x) x) = _
+  rw [Smale.ChartMapPerturbation.chart_perturb c f β (hvalid x) (hsupport hxs)]
+  simp only [Smale.ChartMapPerturbation.coordinateFamily, Smale.PlaneImmersion.perturb,
+    Smale.ChartMapPerturbation.cutoffCoordinates, Smale.PlaneImmersion.displacement, hx, hχ x hxs,
+    one_smul]
+
+private theorem
+    Smale.ManifoldImmersion.contMDiff_affinePatch {G F H N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [TopologicalSpace N] [ChartedSpace H N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : Smale.PlaneImmersion.Plane → N}
+    {β : Smale.PlaneImmersion.Plane → ℝ} {A : F × F}
+    (hf : ContMDiff 𝓘(ℝ, Smale.PlaneImmersion.Plane) J ∞ f) (hβ : ContDiff ℝ ∞ β)
+    (hsupport : tsupport β ⊆ f ⁻¹' c.source)
+    (hvalid :
+      ∀ x, Smale.ChartMapPerturbation.Valid c f β (Smale.PlaneImmersion.displacement β A x)) :
+    ContMDiff 𝓘(ℝ, Smale.PlaneImmersion.Plane) J ∞ (affinePatch c f β A) := by
+  have hd :=
+    (Smale.PlaneImmersion.contDiff_displacement_family (F := F) hβ).comp
+      (contDiff_const (c := A) |>.prodMk contDiff_id)
+  intro x
+  exact
+    Smale.ChartMapPerturbation.contMDiffAt_variablePerturb c hsupport hf.contMDiffAt
+      hβ.contMDiff.contMDiffAt hd.contMDiff.contMDiffAt (hvalid x)
+
+private theorem
+    Smale.ManifoldImmersion.exists_affine_embedding_patch_with_property {G F H N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [TopologicalSpace N] [ChartedSpace H N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) [FiniteDimensional ℝ F] [T2Space N]
+    (f : C(Smale.PlaneImmersion.Plane, N)) (hf : ContMDiff 𝓘(ℝ, Smale.PlaneImmersion.Plane) J ∞ f)
+    {β χ : Smale.PlaneImmersion.Plane → ℝ} (hβ : ContDiff ℝ ∞ β) (hχ : ContDiff ℝ ∞ χ)
+    (hcompact : HasCompactSupport β) (hχsupport : tsupport χ ⊆ f ⁻¹' c.source)
+    (hχone : ∀ x ∈ tsupport β, χ x = 1) (hdim : 5 ≤ Module.finrank ℝ F)
+    (Q : (Smale.PlaneImmersion.Plane → N) → Prop)
+    (hQ : ∀ᶠ A : F × F in 𝓝 0, Q (affinePatch c f β A)) {K : Set Smale.PlaneImmersion.Plane}
+    (hK : IsCompact K) (hKsub : K ⊆ interior {x | β x = 1}) :
+    ∃ g : C(Smale.PlaneImmersion.Plane, N),
+      ContMDiff 𝓘(ℝ, Smale.PlaneImmersion.Plane) J ∞ g ∧
+        Q g ∧
+          Nonempty (f.HomotopyRel g {x | β x = 0}) ∧
+            Topology.IsClosedEmbedding (fun x : K => g x) ∧
+              ∀ x ∈ interior {x | β x = 1},
+                Function.Injective (mfderiv 𝓘(ℝ, Smale.PlaneImmersion.Plane) J g x) := by
+  have hsupport : tsupport β ⊆ f ⁻¹' c.source := by
+    intro x hx
+    exact hχsupport (subset_tsupport χ (by change χ x ≠ 0; rw [hχone x hx]; norm_num))
+  let k := Smale.ChartMapPerturbation.cutoffCoordinates c f χ
+  have hk : ContDiff ℝ ∞ k := by
+    have hm : ContMDiff 𝓘(ℝ, Smale.PlaneImmersion.Plane) 𝓘(ℝ, F) ∞ k := fun x =>
+      Smale.ChartMapPerturbation.contMDiffAt_cutoffCoordinates c hχsupport hf.contMDiffAt
+        hχ.contMDiff.contMDiffAt
+    exact hm.contDiff
+  obtain ⟨ε, hε, hvalid⟩ :=
+    Smale.ChartMapPerturbation.exists_radius_valid c hf hβ.contMDiff hcompact hsupport
+  obtain ⟨δ, hδ, hδbound⟩ :=
+    Smale.PlaneImmersion.exists_radius_displacement_lt (F := F) hβ hcompact hε
+  have hQmem : {A : F × F | Q (affinePatch c f β A)} ∈ 𝓝 0 := hQ
+  obtain ⟨η, hη, hηkeep⟩ := Metric.mem_nhds_iff.mp hQmem
+  obtain ⟨A, hA, -, hinj, hderiv⟩ :=
+    Smale.PlaneImmersion.exists_small_affine_injective_immersion hk hdim (lt_min hδ hη)
+  have hbound : ∀ x, ‖Smale.PlaneImmersion.displacement β A x‖ < ε :=
+    hδbound A (lt_of_lt_of_le hA (min_le_left _ _))
+  have hv :
+    ∀ x, Smale.ChartMapPerturbation.Valid c f β (Smale.PlaneImmersion.displacement β A x) :=
+    fun x => hvalid _ (hbound x)
+  have hsmooth := contMDiff_affinePatch c hf hβ hsupport hv
+  let g : C(Smale.PlaneImmersion.Plane, N) := ⟨affinePatch c f β A, hsmooth.continuous⟩
+  have hcoord (x : Smale.PlaneImmersion.Plane) (hx : β x = 1) :
+    c (g x) = Smale.PlaneImmersion.perturb k A x :=
+    chart_affinePatch_on_plateau c hsupport hχone hv hx
+  have hQg : Q g :=
+    hηkeep
+      (show A ∈ Metric.ball 0 η by
+        simpa only [Metric.mem_ball, dist_zero_right] using
+          (lt_of_lt_of_le hA (min_le_right δ η)))
+  refine ⟨g, hsmooth, hQg, ?_, ?_, ?_⟩
+  · have hd :=
+      (Smale.PlaneImmersion.contDiff_displacement_family (F := F) hβ).comp
+        (contDiff_const (c := A) |>.prodMk contDiff_id)
+    exact
+      ⟨Smale.ChartMapPerturbation.variableHomotopyRel c f.continuous hβ.continuous hsupport
+          hd.continuous hvalid hbound (fun _ hx => Or.inl hx)⟩
+  · let : CompactSpace K := isCompact_iff_compactSpace.mp hK
+    apply (g.continuous.comp continuous_subtype_val).isClosedEmbedding
+    intro x y hxy
+    change g x = g y at hxy
+    apply Subtype.ext
+    apply hinj
+    rw [← hcoord x (interior_subset (s := {z | β z = 1}) (hKsub x.property)), ←
+      hcoord y (interior_subset (s := {z | β z = 1}) (hKsub y.property)), hxy]
+  · intro x hx
+    have hβx : β x = 1 := interior_subset (s := {z | β z = 1}) hx
+    have hxs : f x ∈ c.source :=
+      hsupport (subset_tsupport β (by change β x ≠ 0; rw [hβx]; norm_num))
+    have hgs : g x ∈ c.source := Smale.ChartMapPerturbation.perturb_mem_source c f β (hv x) hxs
+    apply (injective_fderiv_chart_iff c (hsmooth.mdifferentiableAt (by simp)) hgs).mp
+    have heq : (c ∘ g) =ᶠ[𝓝 x] Smale.PlaneImmersion.perturb k A := by
+      filter_upwards [isOpen_interior.mem_nhds hx] with y hy
+      exact hcoord y (interior_subset (s := {z | β z = 1}) hy)
+    change Function.Injective (fderiv ℝ (c ∘ g) x)
+    rw [heq.fderiv_eq]
+    exact hderiv x
+
+private theorem Smale.ManifoldImmersion.affinePatch_zero {G F H N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [TopologicalSpace N] [ChartedSpace H N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : Smale.PlaneImmersion.Plane → N)
+    (β : Smale.PlaneImmersion.Plane → ℝ) : affinePatch c f β (0 : F × F) = f := by
+  funext x
+  change
+    Smale.ChartMapPerturbation.perturb c f β (Smale.PlaneImmersion.displacement β 0 x) x = f x
+  rw [Smale.PlaneImmersion.displacement_zero, Smale.ChartMapPerturbation.perturb_zero]
+
+private theorem Smale.ManifoldImmersion.contMDiffAt_affinePatch_family {G F H N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [TopologicalSpace N] [ChartedSpace H N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : Smale.PlaneImmersion.Plane → N}
+    {β : Smale.PlaneImmersion.Plane → ℝ} (hf : ContMDiff 𝓘(ℝ, Smale.PlaneImmersion.Plane) J ∞ f)
+    (hβ : ContDiff ℝ ∞ β) (hsupport : tsupport β ⊆ f ⁻¹' c.source)
+    (q : (F × F) × Smale.PlaneImmersion.Plane)
+    (hvalid :
+      Smale.ChartMapPerturbation.Valid c f β (Smale.PlaneImmersion.displacement β q.1 q.2)) :
+    ContMDiffAt (𝓘(ℝ, F × F).prod 𝓘(ℝ, Smale.PlaneImmersion.Plane)) J ∞
+      (fun r : (F × F) × Smale.PlaneImmersion.Plane => affinePatch c f β r.1 r.2) q := by
+  have hid :
+    ContMDiffAt (𝓘(ℝ, F × F).prod 𝓘(ℝ, Smale.PlaneImmersion.Plane))
+      𝓘(ℝ, (F × F) × Smale.PlaneImmersion.Plane) ∞
+      (fun r : (F × F) × Smale.PlaneImmersion.Plane => r) q :=
+    (contMDiffAt_prod_module_iff _).mpr ⟨contMDiffAt_fst, contMDiffAt_snd⟩
+  have hd :=
+    (Smale.PlaneImmersion.contDiff_displacement_family (F := F) hβ).contMDiff.contMDiffAt |>.comp
+      q hid
+  exact
+    (Smale.ChartMapPerturbation.contMDiffAt_perturb c hf hβ.contMDiff hsupport
+          (Smale.PlaneImmersion.displacement β q.1 q.2, q.2) hvalid).comp
+      q (f := fun r : (F × F) × Smale.PlaneImmersion.Plane =>
+      (Smale.PlaneImmersion.displacement β r.1 r.2, r.2)) (hd.prodMk contMDiffAt_snd)
+
+private theorem
+    Smale.ManifoldImmersion.eventually_affinePatch_maps_compact_into_open {G F H N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [TopologicalSpace N] [ChartedSpace H N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : Smale.PlaneImmersion.Plane → N}
+    {β : Smale.PlaneImmersion.Plane → ℝ} (hf : ContMDiff 𝓘(ℝ, Smale.PlaneImmersion.Plane) J ∞ f)
+    (hβ : ContDiff ℝ ∞ β) (hsupport : tsupport β ⊆ f ⁻¹' c.source)
+    {K : Set Smale.PlaneImmersion.Plane} (hK : IsCompact K) {U : Set N} (hU : IsOpen U)
+    (hmap : Set.MapsTo f K U) : ∀ᶠ A : F × F in 𝓝 0, Set.MapsTo (affinePatch c f β A) K U := by
+  apply hK.eventually_forall_of_forall_eventually
+  intro x hx
+  have hvalid :
+    Smale.ChartMapPerturbation.Valid c f β (Smale.PlaneImmersion.displacement β (0 : F × F) x) := by
+    rw [Smale.PlaneImmersion.displacement_zero]
+    exact Smale.ChartMapPerturbation.valid_zero c f β hsupport
+  have hc := (contMDiffAt_affinePatch_family c hf hβ hsupport (0, x) hvalid).continuousAt
+  apply hc.preimage_mem_nhds
+  apply hU.mem_nhds
+  rw [affinePatch_zero]
+  exact hmap hx
+
+private theorem
+    Smale.ManifoldImmersion.eventually_affinePatch_injective_derivative {G F H N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [TopologicalSpace N] [ChartedSpace H N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) [J.Boundaryless] [IsManifold J ∞ N]
+    {f : Smale.PlaneImmersion.Plane → N} {β : Smale.PlaneImmersion.Plane → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, Smale.PlaneImmersion.Plane) J ∞ f) (hβ : ContDiff ℝ ∞ β)
+    (hcompact : HasCompactSupport β) (hsupport : tsupport β ⊆ f ⁻¹' c.source)
+    {K : Set Smale.PlaneImmersion.Plane} (hK : IsCompact K)
+    (hinj : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, Smale.PlaneImmersion.Plane) J f x)) :
+    ∀ᶠ A : F × F in 𝓝 0,
+      ∀ x ∈ K,
+        Function.Injective (mfderiv 𝓘(ℝ, Smale.PlaneImmersion.Plane) J (affinePatch c f β A) x) :=
+  by
+  obtain ⟨ε, hε, hvalid⟩ :=
+    Smale.ChartMapPerturbation.exists_radius_valid c hf hβ.contMDiff hcompact hsupport
+  obtain ⟨δ, hδ, hδbound⟩ :=
+    Smale.PlaneImmersion.exists_radius_displacement_lt (F := F) hβ hcompact hε
+  let W : Set ((F × F) × Smale.PlaneImmersion.Plane) := {q | ‖q.1‖ < δ}
+  have hW : IsOpen W := isOpen_lt continuous_fst.norm continuous_const
+  have hfamily :
+    ContMDiffOn (𝓘(ℝ, F × F).prod 𝓘(ℝ, Smale.PlaneImmersion.Plane)) J ∞
+      (fun q : (F × F) × Smale.PlaneImmersion.Plane => affinePatch c f β q.1 q.2) W := by
+    intro q hq
+    exact
+      (contMDiffAt_affinePatch_family c hf hβ hsupport q
+          (hvalid _ (hδbound q.1 hq q.2))).contMDiffWithinAt
+  apply eventually_injective_nativeDerivative hW hfamily hK
+  · intro x _
+    change ‖(0 : F × F)‖ < δ
+    simpa only [norm_zero] using hδ
+  · intro x hx
+    change
+      Function.Injective
+        (mfderiv 𝓘(ℝ, Smale.PlaneImmersion.Plane) J (affinePatch c f β (0 : F × F)) x)
+    rw [affinePatch_zero]
+    exact hinj x hx
+
+private theorem
+    Smale.ManifoldImmersion.exists_immersion_patch_step {G H N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N]
+    {ι : Type*} [Finite ι]
+    (p :
+      ι →
+        Smale.ManifoldSmoothing.MapSmoothingPatch 𝓘(ℝ, Smale.PlaneImmersion.Plane) J (X :=
+          Smale.PlaneImmersion.Plane) (N := N))
+    (i : ι) (f : C(Smale.PlaneImmersion.Plane, N))
+    (hf : ContMDiff 𝓘(ℝ, Smale.PlaneImmersion.Plane) J ∞ f)
+    (hcompatible : ∀ j, (p j).Compatible f) (hdim : 5 ≤ Module.finrank ℝ G)
+    {K L C : Set Smale.PlaneImmersion.Plane} (hK : IsCompact K) (hL : IsCompact L)
+    (hinj : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, Smale.PlaneImmersion.Plane) J f x))
+    (hLsub : L ⊆ (p i).plateau) (hfixed : ∀ x ∈ C, (p i).cutoff x = 0) :
+    ∃ g : C(Smale.PlaneImmersion.Plane, N),
+      ContMDiff 𝓘(ℝ, Smale.PlaneImmersion.Plane) J ∞ g ∧
+        (∀ j, (p j).Compatible g) ∧
+          f.HomotopicRel g C ∧
+            Topology.IsClosedEmbedding (fun x : L => g x) ∧
+              ∀ x ∈ K ∪ L, Function.Injective (mfderiv 𝓘(ℝ, Smale.PlaneImmersion.Plane) J g x) := by
+  have hinner := (p i).inner_compatible (hcompatible i)
+  have hkeep :
+    ∀ᶠ A : G × G in 𝓝 0, ∀ j, (p j).Compatible (affinePatch (p i).chart f (p i).cutoff A) := by
+    apply Filter.eventually_all.mpr
+    intro j
+    exact
+      eventually_affinePatch_maps_compact_into_open (p i).chart hf (p i).smooth.contDiff hinner
+        (p j).outer_compact.isCompact (p j).chart.open_source (hcompatible j)
+  have hold :=
+    eventually_affinePatch_injective_derivative (p i).chart hf (p i).smooth.contDiff (p i).compact
+      hinner hK hinj
+  let Q : (Smale.PlaneImmersion.Plane → N) → Prop := fun g =>
+    (∀ j, (p j).Compatible g) ∧
+      ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, Smale.PlaneImmersion.Plane) J g x)
+  have hQ : ∀ᶠ A : G × G in 𝓝 0, Q (affinePatch (p i).chart f (p i).cutoff A) := hkeep.and hold
+  obtain ⟨g, hg, ⟨hc, hKnew⟩, ⟨Hrel⟩, hemb, hplateau⟩ :=
+    exists_affine_embedding_patch_with_property (p i).chart f hf (p i).smooth.contDiff
+      (p i).outer_smooth.contDiff (p i).compact (hcompatible i) (p i).nested hdim Q hQ hL hLsub
+  refine ⟨g, hg, hc, ?_, hemb, ?_⟩
+  · exact ⟨{ Hrel.toHomotopy with prop' := fun t x hx => Hrel.eq_fst t (hfixed x hx) }⟩
+  · intro x hx
+    rcases hx with hx | hx
+    · exact hKnew x hx
+    · exact hplateau x (hLsub hx)
+
+private theorem Smale.ManifoldImmersion.exists_finite_patch_immersion {G H N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] [T2Space N] {ι : Type*} [Finite ι]
+    (p :
+      ι →
+        Smale.ManifoldSmoothing.MapSmoothingPatch 𝓘(ℝ, Smale.PlaneImmersion.Plane) J (X :=
+          Smale.PlaneImmersion.Plane) (N := N))
+    (L : ι → Set Smale.PlaneImmersion.Plane) (hL : ∀ i, IsCompact (L i))
+    (hLsub : ∀ i, L i ⊆ (p i).plateau) (f : C(Smale.PlaneImmersion.Plane, N))
+    (hf : ContMDiff 𝓘(ℝ, Smale.PlaneImmersion.Plane) J ∞ f)
+    (hcompatible : ∀ i, (p i).Compatible f) (hdim : 5 ≤ Module.finrank ℝ G)
+    {K C : Set Smale.PlaneImmersion.Plane} (hK : IsCompact K)
+    (hinj : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, Smale.PlaneImmersion.Plane) J f x))
+    (hfixed : ∀ i x, x ∈ C → (p i).cutoff x = 0) (s : Finset ι) :
+    ∃ g : C(Smale.PlaneImmersion.Plane, N),
+      ContMDiff 𝓘(ℝ, Smale.PlaneImmersion.Plane) J ∞ g ∧
+        (∀ i, (p i).Compatible g) ∧
+          f.HomotopicRel g C ∧
+            ∀ x ∈ K ∪ ⋃ i ∈ s, L i,
+              Function.Injective (mfderiv 𝓘(ℝ, Smale.PlaneImmersion.Plane) J g x) := by
+  classical
+    induction s using Finset.induction_on with
+  | empty =>
+    refine ⟨f, hf, hcompatible, ContinuousMap.HomotopicRel.refl f, ?_⟩
+    simpa only [Finset.notMem_empty, Set.iUnion_of_empty, Set.iUnion_empty, Set.union_empty] using
+      hinj
+  | @insert i s _ ih =>
+    obtain ⟨g₁, hg₁, hc₁, hhom₁, hinj₁⟩ := ih
+    have hKold : IsCompact (K ∪ ⋃ j ∈ s, L j) := hK.union (s.isCompact_biUnion (fun j _ => hL j))
+    obtain ⟨g₂, hg₂, hc₂, hhom₂, -, hinj₂⟩ :=
+      exists_immersion_patch_step p i g₁ hg₁ hc₁ hdim hKold (hL i) hinj₁ (hLsub i) (hfixed i)
+    refine ⟨g₂, hg₂, hc₂, hhom₁.trans hhom₂, ?_⟩
+    intro x hx
+    apply hinj₂ x
+    rcases hx with hx | hx
+    · exact Or.inl (Or.inl hx)
+    · obtain ⟨j, hj, hxj⟩ := Set.mem_iUnion₂.mp hx
+      rcases Finset.mem_insert.mp hj with rfl | hjs
+      · exact Or.inr hxj
+      · exact Or.inl (Or.inr (Set.mem_iUnion₂.mpr ⟨j, hjs, hxj⟩))
+
+private theorem Smale.ManifoldImmersion.exists_relative_immersion_patch_at_in_open {E G H N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [J.Boundaryless]
+    [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] (f : C(E, N)) {C : Set E}
+    (hC : IsClosed C) {x : E} (hx : x ∉ C) {O : Set N} (hO : IsOpen O) (hxO : f x ∈ O) :
+    ∃ p : Smale.ManifoldSmoothing.MapSmoothingPatch 𝓘(ℝ, E) J (X := E) (N := N),
+      ∃ L : Set E,
+        p.Compatible f ∧
+          IsCompact L ∧
+            L ∈ 𝓝 x ∧ L ⊆ p.plateau ∧ (∀ y ∈ C, p.cutoff y = 0) ∧ p.chart.source ⊆ O := by
+  classical
+  let c₀ := NoExotic.modelChartPartialDiffeomorph (I := J) (f x)
+  let c := Smale.PartialChart.restrictSource c₀ hO
+  have hsource : f x ∈ c.source := ⟨mem_extChartAt_source (I := J) (f x), hxO⟩
+  have hU : f ⁻¹' c.source ∩ Cᶜ ∈ 𝓝 x :=
+    ((c.open_source.preimage f.continuous).inter hC.isOpen_compl).mem_nhds ⟨hsource, hx⟩
+  obtain ⟨χ, _, hχ⟩ := (SmoothBumpFunction.nhds_basis_tsupport (I := 𝓘(ℝ, E)) x).mem_iff.mp hU
+  have hχone : {y : E | χ y = 1} ∈ 𝓝 x := χ.eventuallyEq_one
+  obtain ⟨β, _, hβ⟩ := (SmoothBumpFunction.nhds_basis_tsupport (I := 𝓘(ℝ, E)) x).mem_iff.mp hχone
+  let p : Smale.ManifoldSmoothing.MapSmoothingPatch 𝓘(ℝ, E) J (X := E) (N := N) :=
+    { chart := c
+      cutoff := β
+      outer := χ
+      smooth := β.contMDiff
+      outer_smooth := χ.contMDiff
+      compact := β.hasCompactSupport
+      outer_compact := χ.hasCompactSupport
+      nested := fun y hy => hβ hy }
+  have hxp : x ∈ p.plateau := mem_interior_iff_mem_nhds.mpr β.eventuallyEq_one
+  obtain ⟨L, hxL, hLp, hL⟩ := local_compact_nhds (isOpen_interior.mem_nhds hxp)
+  refine ⟨p, L, (fun _ hy => (hχ hy).1), hL, hxL, hLp, ?_, fun _ hz => hz.2⟩
+  intro y hy
+  change β y = 0
+  by_contra hne
+  have hi : y ∈ tsupport β := subset_tsupport β hne
+  have ho : y ∈ tsupport χ :=
+    subset_tsupport χ
+      (by
+        change χ y ≠ 0
+        rw [hβ hi]
+        exact one_ne_zero)
+  exact (hχ ho).2 hy
+
+private theorem Smale.ManifoldImmersion.exists_relative_immersion_patch_at {E G H N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [J.Boundaryless]
+    [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] (f : C(E, N)) {C : Set E}
+    (hC : IsClosed C) {x : E} (hx : x ∉ C) :
+    ∃ p : Smale.ManifoldSmoothing.MapSmoothingPatch 𝓘(ℝ, E) J (X := E) (N := N),
+      ∃ L : Set E,
+        p.Compatible f ∧ IsCompact L ∧ L ∈ 𝓝 x ∧ L ⊆ p.plateau ∧ ∀ y ∈ C, p.cutoff y = 0 := by
+  obtain ⟨p, L, hc, hL, hn, hp, hfix, _⟩ :=
+    exists_relative_immersion_patch_at_in_open (J := J) f hC hx isOpen_univ (Set.mem_univ _)
+  exact ⟨p, L, hc, hL, hn, hp, hfix⟩
+
+private theorem Smale.ManifoldImmersion.exists_immersion_on_compact_rel {G H N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] [T2Space N] (f : C(Smale.PlaneImmersion.Plane, N))
+    (hf : ContMDiff 𝓘(ℝ, Smale.PlaneImmersion.Plane) J ∞ f) (hdim : 5 ≤ Module.finrank ℝ G)
+    {K L C : Set Smale.PlaneImmersion.Plane} (hK : IsCompact K) (hL : IsCompact L)
+    (hinj : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, Smale.PlaneImmersion.Plane) J f x))
+    (hC : IsClosed C) (hdis : Disjoint L C) :
+    ∃ g : C(Smale.PlaneImmersion.Plane, N),
+      ContMDiff 𝓘(ℝ, Smale.PlaneImmersion.Plane) J ∞ g ∧
+        f.HomotopicRel g C ∧
+          ∀ x ∈ K ∪ L, Function.Injective (mfderiv 𝓘(ℝ, Smale.PlaneImmersion.Plane) J g x) := by
+  classical
+  have hp (x : L) :=
+    exists_relative_immersion_patch_at (J := J) f hC
+      (show (x : Smale.PlaneImmersion.Plane) ∉ C from fun hx =>
+        Set.disjoint_left.mp hdis x.property hx)
+  choose p T hcompatible hT hn hsub hfixed using hp
+  have hcover : L ⊆ ⋃ x : L, interior (T x) := by
+    intro x hx
+    exact Set.mem_iUnion.mpr ⟨⟨x, hx⟩, mem_interior_iff_mem_nhds.mpr (hn ⟨x, hx⟩)⟩
+  obtain ⟨s, hs⟩ :=
+    hL.elim_finite_subcover (fun x : L => interior (T x)) (fun _ => isOpen_interior) hcover
+  obtain ⟨g, hg, -, hhom, hderiv⟩ :=
+    exists_finite_patch_immersion (fun i : s => p i.1) (fun i : s => T i.1) (fun i => hT i.1)
+      (fun i => hsub i.1) f hf (fun i => hcompatible i.1) hdim hK hinj (fun i => hfixed i.1)
+      Finset.univ
+  refine ⟨g, hg, hhom, ?_⟩
+  intro x hx
+  apply hderiv x
+  rcases hx with hx | hx
+  · exact Or.inl hx
+  · obtain ⟨i, his, hxi⟩ := Set.mem_iUnion₂.mp (hs hx)
+    exact Or.inr (Set.mem_iUnion₂.mpr ⟨⟨i, his⟩, Finset.mem_univ _, interior_subset hxi⟩)
+
+private theorem Smale.ManifoldImmersion.exists_selfIntersection_removal_step_within_target
+    {E G H N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] {ι : Type*} [Finite ι] {C K : Set E}
+    (p : ι → Smale.GeneralPosition.MapAvoidancePatch 𝓘(ℝ, E) J (N := N) C) (i : ι) (f : C(E, N))
+    (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) (hcompatible : ∀ j, (p j).Compatible f)
+    (hdim : 2 * Module.finrank ℝ E < Module.finrank ℝ G) (hK : IsCompact K)
+    (hinj : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f x)) {D : Set E} {O : Set N}
+    (hsource : (p i).chart.source ⊆ O) (hmaps : Set.MapsTo f D O) :
+    ∃ g : C(E, N),
+      ContMDiff 𝓘(ℝ, E) J ∞ g ∧
+        (∀ j, (p j).Compatible g) ∧
+          Smale.HomotopicRelWithin f g C D O ∧
+            (∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J g x)) ∧
+              ∀ x y, g x = g y → f x = f y ∧ (p i).cutoff x = (p i).cutoff y := by
+  have hkeep :
+    ∀ᶠ a in 𝓝 (0 : G),
+      ∀ j, (p j).Compatible (Smale.ChartMapPerturbation.perturb (p i).chart f (p i).cutoff a) := by
+    apply Filter.eventually_all.mpr
+    intro j
+    exact
+      Smale.ChartMapPerturbation.eventually_maps_compact_into_open (p i).chart hf (p i).smooth
+        (hcompatible i) (p j).compact.isCompact (p j).chart.open_source (hcompatible j)
+  have hold :=
+    Smale.ChartMapPerturbation.eventually_perturb_injective_derivative (p i).chart hf (p i).smooth
+      (p i).compact (hcompatible i) hK hinj
+  obtain ⟨δ, hδ, hδkeep⟩ := Metric.mem_nhds_iff.mp (hkeep.and hold)
+  obtain ⟨r, hr, hvalid⟩ :=
+    Smale.ChartMapPerturbation.exists_radius_valid (p i).chart hf (p i).smooth (p i).compact
+      (hcompatible i)
+  obtain ⟨a, ha, -, hsmooth, hremove⟩ :=
+    Smale.ChartMapPerturbation.exists_small_collision_removing_parameter (p i).chart hf
+      (p i).smooth (p i).compact (hcompatible i) hdim (lt_min hδ hr)
+  have haδ : ‖a‖ < δ := (lt_min_iff.mp ha).1
+  have har : ‖a‖ < r := (lt_min_iff.mp ha).2
+  let g : C(E, N) := ⟨_, hsmooth.continuous⟩
+  have hretained :=
+    hδkeep (show a ∈ Metric.ball 0 δ by simpa only [Metric.mem_ball, dist_zero_right] using haδ)
+  refine ⟨g, hsmooth, hretained.1, ?_, hretained.2, hremove⟩
+  have hrel :=
+    Smale.ChartMapPerturbation.homotopicRelWithin_of_source_subset (p i).chart hf (p i).smooth
+      (hcompatible i) hvalid har hsource hmaps
+  exact hrel.mono (fun x hx => (p i).fixed x hx) (Set.Subset.refl D) (Set.Subset.refl O)
+
+private theorem Smale.ManifoldImmersion.exists_finite_selfIntersection_removal_within_target
+    {E G H N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] {ι : Type*} [Finite ι] {C K : Set E}
+    (p : ι → Smale.GeneralPosition.MapAvoidancePatch 𝓘(ℝ, E) J (N := N) C) (f : C(E, N))
+    (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) (hcompatible : ∀ j, (p j).Compatible f)
+    (hdim : 2 * Module.finrank ℝ E < Module.finrank ℝ G) (hK : IsCompact K)
+    (hinj : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f x)) {D : Set E} {O : Set N}
+    (hsource : ∀ i, (p i).chart.source ⊆ O) (hmaps : Set.MapsTo f D O) (s : Finset ι) :
+    ∃ g : C(E, N),
+      ContMDiff 𝓘(ℝ, E) J ∞ g ∧
+        (∀ j, (p j).Compatible g) ∧
+          Smale.HomotopicRelWithin f g C D O ∧
+            (∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J g x)) ∧
+              ∀ x y, g x = g y → f x = f y ∧ ∀ i ∈ s, (p i).cutoff x = (p i).cutoff y := by
+  classical
+    induction s using Finset.induction_on with
+  | empty =>
+    exact
+      ⟨f, hf, hcompatible, Smale.HomotopicRelWithin.refl f C hmaps, hinj, fun _ _ hxy =>
+        ⟨hxy, fun _ hi => False.elim (Finset.notMem_empty _ hi)⟩⟩
+  | @insert i s _ ih =>
+    obtain ⟨g₁, hg₁, hc₁, hhom₁, hinj₁, hpair₁⟩ := ih
+    obtain ⟨g₂, hg₂, hc₂, hhom₂, hinj₂, hpair₂⟩ :=
+      exists_selfIntersection_removal_step_within_target p i g₁ hg₁ hc₁ hdim hK hinj₁ (hsource i)
+        hhom₁.mapsTo_right
+    refine ⟨g₂, hg₂, hc₂, hhom₁.trans hhom₂, hinj₂, ?_⟩
+    intro x y hxy
+    have hnew := hpair₂ x y hxy
+    have hold := hpair₁ x y hnew.1
+    refine ⟨hold.1, ?_⟩
+    intro j hj
+    rcases Finset.mem_insert.mp hj with rfl | hjs
+    · exact hnew.2
+    · exact hold.2 j hjs
+
+private theorem Smale.ManifoldImmersion.exists_embedding_of_finite_separating_patches_within_target
+    {E G H N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] [T2Space N] {ι : Type*} [Finite ι] {C K : Set E}
+    (p : ι → Smale.GeneralPosition.MapAvoidancePatch 𝓘(ℝ, E) J (N := N) C) (f : C(E, N))
+    (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) (hcompatible : ∀ j, (p j).Compatible f)
+    (hdim : 2 * Module.finrank ℝ E < Module.finrank ℝ G) (hK : IsCompact K)
+    (hinj : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f x))
+    (hseparate : ∀ x ∈ K, ∀ y ∈ K, x ≠ y → f x = f y → ∃ i, (p i).cutoff x ≠ (p i).cutoff y)
+    {D : Set E} {O : Set N} (hsource : ∀ i, (p i).chart.source ⊆ O) (hmaps : Set.MapsTo f D O) :
+    ∃ g : C(E, N),
+      ContMDiff 𝓘(ℝ, E) J ∞ g ∧
+        Smale.HomotopicRelWithin f g C D O ∧
+          Topology.IsClosedEmbedding (fun x : K => g x) ∧
+            ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J g x) := by
+  classical
+  let := Fintype.ofFinite ι
+  obtain ⟨g, hg, -, hhom, hinjg, hpairs⟩ :=
+    exists_finite_selfIntersection_removal_within_target p f hf hcompatible hdim hK hinj hsource
+      hmaps Finset.univ
+  refine ⟨g, hg, hhom, ?_, hinjg⟩
+  let : CompactSpace K := isCompact_iff_compactSpace.mp hK
+  apply (g.continuous.comp continuous_subtype_val).isClosedEmbedding
+  intro x y hxy
+  apply Subtype.ext
+  by_contra hne
+  obtain ⟨hold, hcutoffs⟩ := hpairs x y hxy
+  obtain ⟨i, hi⟩ := hseparate x x.property y y.property hne hold
+  exact hi (hcutoffs i (Finset.mem_univ i))
+
+private theorem Smale.ManifoldImmersion.exists_separating_patch_in_open {E G H N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [J.Boundaryless]
+    [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] (f : C(E, N)) {C : Set E}
+    (hC : IsClosed C) {x y : E} (hx : x ∉ C) (hxy : x ≠ y) {O : Set N} (hO : IsOpen O)
+    (hxO : f x ∈ O) :
+    ∃ p : Smale.GeneralPosition.MapAvoidancePatch 𝓘(ℝ, E) J (N := N) C,
+      p.Compatible f ∧ p.cutoff x = 1 ∧ p.cutoff y = 0 ∧ p.chart.source ⊆ O := by
+  classical
+  let c₀ := NoExotic.modelChartPartialDiffeomorph (I := J) (f x)
+  let c := Smale.PartialChart.restrictSource c₀ hO
+  have hsource : f x ∈ c.source := ⟨mem_extChartAt_source (I := J) (f x), hxO⟩
+  have hU : f ⁻¹' c.source ∩ (C ∪ { y })ᶜ ∈ 𝓝 x := by
+    apply
+      ((c.open_source.preimage f.continuous).inter
+          ((hC.union isClosed_singleton).isOpen_compl)).mem_nhds
+    exact ⟨hsource, fun h => h.elim hx (fun h => hxy h)⟩
+  obtain ⟨β, -, hβ⟩ := (SmoothBumpFunction.nhds_basis_tsupport (I := 𝓘(ℝ, E)) x).mem_iff.mp hU
+  let p : Smale.GeneralPosition.MapAvoidancePatch 𝓘(ℝ, E) J (N := N) C :=
+    { chart := c
+      cutoff := β
+      smooth := β.contMDiff
+      compact := β.hasCompactSupport
+      fixed := fun z hz => image_eq_zero_of_notMem_tsupport (fun ht => (hβ ht).2 (Or.inl hz)) }
+  refine ⟨p, (fun _ ht => (hβ ht).1), β.eq_one, ?_, fun _ hz => hz.2⟩
+  exact image_eq_zero_of_notMem_tsupport (fun ht => (hβ ht).2 (Or.inr rfl))
+
+private theorem Smale.ManifoldImmersion.exists_separating_patch_of_not_both_fixed_in_open
+    {E G H N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] (f : C(E, N))
+    {C : Set E} (hC : IsClosed C) {x y : E} (hxy : x ≠ y) (hfixed : ¬(x ∈ C ∧ y ∈ C)) {O : Set N}
+    (hO : IsOpen O) (hxO : x ∉ C → f x ∈ O) (hyO : y ∉ C → f y ∈ O) :
+    ∃ p : Smale.GeneralPosition.MapAvoidancePatch 𝓘(ℝ, E) J (N := N) C,
+      p.Compatible f ∧ p.cutoff x ≠ p.cutoff y ∧ p.chart.source ⊆ O := by
+  by_cases hx : x ∈ C
+  · have hy : y ∉ C := fun hy => hfixed ⟨hx, hy⟩
+    obtain ⟨p, hp, hpy, hpx, hs⟩ :=
+      exists_separating_patch_in_open (J := J) f hC hy hxy.symm hO (hyO hy)
+    exact ⟨p, hp, by rw [hpx, hpy]; exact zero_ne_one, hs⟩
+  · obtain ⟨p, hp, hpx, hpy, hs⟩ :=
+      exists_separating_patch_in_open (J := J) f hC hx hxy hO (hxO hx)
+    exact ⟨p, hp, by rw [hpx, hpy]; exact one_ne_zero, hs⟩
+
+private theorem Smale.ManifoldImmersion.exists_open_injOn_of_injective_fderiv {E F : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [FiniteDimensional ℝ F] {f : E → F} {U : Set E} {x : E} (hU : IsOpen U)
+    (hx : x ∈ U) (hf : ContDiffOn ℝ ∞ f U) (hinj : Function.Injective (fderiv ℝ f x)) :
+    ∃ V : Set E, IsOpen V ∧ x ∈ V ∧ V ⊆ U ∧ Set.InjOn f V := by
+  obtain ⟨L, hL⟩ := ContinuousLinearMap.HasLeftInverse.of_injective_of_finiteDimensional hinj
+  have hdf := (hf.contDiffAt (hU.mem_nhds hx)).differentiableAt (by simp)
+  have hderiv : HasFDerivAt (L ∘ f) (ContinuousLinearMap.id ℝ E) x := by
+    convert L.hasFDerivAt.comp x hdf.hasFDerivAt using 1
+    ext v
+    exact (hL v).symm
+  have hcomp : ContDiffOn ℝ ∞ (L ∘ f) U := L.contDiff.comp_contDiffOn hf
+  have hinv : (fderiv ℝ (L ∘ f) x).IsInvertible := by
+    rw [hderiv.fderiv]
+    exact ⟨ContinuousLinearEquiv.refl ℝ E, rfl⟩
+  obtain ⟨φ, hxφ, hφU, hφeq⟩ := NoExotic.exists_partialDiffeomorph_of_contDiffOn hU hx hcomp hinv
+  refine ⟨φ.source, φ.open_source, hxφ, hφU, ?_⟩
+  intro y hy z hz hyz
+  apply φ.toPartialEquiv.injOn hy hz
+  rw [hφeq]
+  exact congrArg L hyz
+
+private theorem
+    Smale.ManifoldImmersion.exists_open_injOn_of_injective_nativeDerivative_on {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] {G H N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] {f : E → N} {W : Set E} (hW : IsOpen W) (hf : ContMDiffOn 𝓘(ℝ, E) J ∞ f W)
+    {x : E} (hxW : x ∈ W) (hinj : Function.Injective (mfderiv 𝓘(ℝ, E) J f x)) :
+    ∃ V : Set E, IsOpen V ∧ x ∈ V ∧ V ⊆ W ∧ Set.InjOn f V := by
+  let c := NoExotic.modelChartPartialDiffeomorph (I := J) (f x)
+  have hx : f x ∈ c.source := mem_extChartAt_source (f x)
+  let U := W ∩ f ⁻¹' c.source
+  have hU : IsOpen U := hf.continuousOn.isOpen_inter_preimage hW c.open_source
+  have hc : ContDiffOn ℝ ∞ (c ∘ f) U :=
+    (c.contMDiffOn_toFun.comp (hf.mono Set.inter_subset_left) (fun _ h => h.2)).contDiffOn
+  have hfx := hf.contMDiffAt (hW.mem_nhds hxW)
+  have hi := (injective_fderiv_chart_iff c (hfx.mdifferentiableAt (by simp)) hx).mpr hinj
+  obtain ⟨V, hV, hxV, hVU, hinjV⟩ := exists_open_injOn_of_injective_fderiv hU ⟨hxW, hx⟩ hc hi
+  exact
+    ⟨V, hV, hxV, hVU.trans Set.inter_subset_left, fun _ hy _ hz heq =>
+      hinjV hy hz (congrArg c heq)⟩
+
+private theorem Smale.ManifoldImmersion.exists_open_injOn_of_injective_nativeDerivative {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] {G H N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] {f : E → N} (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) {x : E}
+    (hinj : Function.Injective (mfderiv 𝓘(ℝ, E) J f x)) :
+    ∃ V : Set E, IsOpen V ∧ x ∈ V ∧ Set.InjOn f V := by
+  obtain ⟨V, hV, hxV, _, hinjV⟩ :=
+    exists_open_injOn_of_injective_nativeDerivative_on isOpen_univ hf.contMDiffOn (Set.mem_univ x)
+      hinj
+  exact ⟨V, hV, hxV, hinjV⟩
+
+private theorem Smale.ManifoldImmersion.exists_open_injOn_near_compact_on {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] {G H N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] [T2Space N] {f : E → N} {W : Set E} (hW : IsOpen W)
+    (hf : ContMDiffOn 𝓘(ℝ, E) J ∞ f W) {K : Set E} (hK : IsCompact K) (hKW : K ⊆ W)
+    (hinj : Set.InjOn f K) (hi : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f x)) :
+    ∃ V : Set E, IsOpen V ∧ K ⊆ V ∧ V ⊆ W ∧ Set.InjOn f V := by
+  have hc : ∀ x ∈ K, ContinuousAt f x := fun x hx =>
+    hf.continuousOn.continuousAt (hW.mem_nhds (hKW hx))
+  have hlocal : ∀ x ∈ K, ∃ V ∈ nhds x, Set.InjOn f V := by
+    intro x hx
+    obtain ⟨V, hV, hxV, _, hinjV⟩ :=
+      exists_open_injOn_of_injective_nativeDerivative_on hW hf (hKW hx) (hi x hx)
+    exact ⟨V, hV.mem_nhds hxV, hinjV⟩
+  obtain ⟨V, hV, hKV, hinjV⟩ := hinj.exists_isOpen_superset hK hc hlocal
+  exact
+    ⟨V ∩ W, hV.inter hW, fun _ hx => ⟨hKV hx, hKW hx⟩, Set.inter_subset_right,
+      hinjV.mono Set.inter_subset_left⟩
+
+private theorem Smale.ManifoldImmersion.exists_open_embedded_immersive_neighborhood {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] {G H N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] [T2Space N] {f : E → N} {W : Set E} (hW : IsOpen W)
+    (hf : ContMDiffOn 𝓘(ℝ, E) J ∞ f W) {K : Set E} (hK : IsCompact K) (hKW : K ⊆ W)
+    (hinj : Set.InjOn f K) (hi : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f x)) :
+    ∃ V : Set E,
+      IsOpen V ∧
+        K ⊆ V ∧ V ⊆ W ∧ Set.InjOn f V ∧ ∀ x ∈ V, Function.Injective (mfderiv 𝓘(ℝ, E) J f x) := by
+  let O := {x : E | x ∈ W ∧ Function.Injective (mfderiv 𝓘(ℝ, E) J f x)}
+  have hO : IsOpen O := isOpen_injective_derivative_on hW hf
+  have hOW : O ⊆ W := fun _ hx => hx.1
+  obtain ⟨V, hV, hKV, hVO, hinjV⟩ :=
+    exists_open_injOn_near_compact_on hO (hf.mono hOW) hK (fun x hx => ⟨hKW hx, hi x hx⟩) hinj hi
+  exact ⟨V, hV, hKV, hVO.trans hOW, hinjV, fun x hx => (hVO hx).2⟩
+
+private theorem
+    Smale.ManifoldImmersion.exists_open_injOn_near_compact {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {G H N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N]
+    {f : E → N} (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) {K : Set E} (hK : IsCompact K)
+    (hinj : Set.InjOn f K) (hi : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f x)) :
+    ∃ V : Set E, IsOpen V ∧ K ⊆ V ∧ Set.InjOn f V := by
+  apply hinj.exists_isOpen_superset hK (fun _ _ => hf.continuous.continuousAt)
+  intro x hx
+  obtain ⟨V, hV, hxV, hinjV⟩ := exists_open_injOn_of_injective_nativeDerivative hf (hi x hx)
+  exact ⟨V, hV.mem_nhds hxV, hinjV⟩
+
+private def
+    Smale.ManifoldImmersion.doublePoints {X N : Type*} (f : X → N) (K : Set X) : Set (X × X) :=
+  {q | q.1 ∈ K ∧ q.2 ∈ K ∧ q.1 ≠ q.2 ∧ f q.1 = f q.2}
+
+private theorem Smale.ManifoldImmersion.isCompact_doublePoints_of_locally_injective {X N : Type*}
+    [TopologicalSpace X] [TopologicalSpace N] [T2Space N] {f : X → N} (hf : Continuous f)
+    {K : Set X} (hK : IsCompact K)
+    (hlocal : ∀ x ∈ K, ∃ U : Set X, IsOpen U ∧ x ∈ U ∧ Set.InjOn f U) :
+    IsCompact (doublePoints f K) := by
+  classical
+  choose U hU hmem hinj using (fun x : K => hlocal x x.property)
+  let V : Set (X × X) := ⋃ x : K, (U x) ×ˢ (U x)
+  have hV : IsOpen V := isOpen_iUnion (fun x => (hU x).prod (hU x))
+  have hclosed : IsClosed {q : X × X | f q.1 = f q.2} :=
+    isClosed_eq (hf.comp continuous_fst) (hf.comp continuous_snd)
+  have heq : doublePoints f K = ((K ×ˢ K) ∩ {q : X × X | f q.1 = f q.2}) ∩ Vᶜ := by
+    ext q
+    constructor
+    · rintro ⟨hx, hy, hne, hcoll⟩
+      refine ⟨⟨⟨hx, hy⟩, hcoll⟩, ?_⟩
+      intro hv
+      obtain ⟨x, hxU, hyU⟩ := Set.mem_iUnion.mp hv
+      exact hne (hinj x hxU hyU hcoll)
+    · rintro ⟨⟨⟨hx, hy⟩, hcoll⟩, hv⟩
+      refine ⟨hx, hy, ?_, hcoll⟩
+      intro hxy
+      apply hv
+      apply Set.mem_iUnion.mpr
+      refine ⟨⟨q.1, hx⟩, hmem ⟨q.1, hx⟩, ?_⟩
+      rw [← hxy]
+      exact hmem ⟨q.1, hx⟩
+  rw [heq]
+  exact ((hK.prod hK).inter_right hclosed).inter_right hV.isClosed_compl
+
+private theorem Smale.ManifoldImmersion.isCompact_doublePoints_of_injective_nativeDerivative
+    {E G H N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] [T2Space N] {f : E → N} (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) {K : Set E}
+    (hK : IsCompact K) (hinj : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f x)) :
+    IsCompact (doublePoints f K) :=
+  isCompact_doublePoints_of_locally_injective hf.continuous hK
+    (fun _ hx => exists_open_injOn_of_injective_nativeDerivative hf (hinj _ hx))
+
+private theorem Smale.ManifoldImmersion.exists_compact_embedding_of_immersion_within_target
+    {E G H N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] [T2Space N] (f : C(E, N)) (hf : ContMDiff 𝓘(ℝ, E) J ∞ f)
+    (hdim : 2 * Module.finrank ℝ E < Module.finrank ℝ G) {K C : Set E} (hK : IsCompact K)
+    (hinj : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f x)) (hC : IsClosed C)
+    (hfixed : Set.InjOn f (K ∩ C)) {O : Set N} (hO : IsOpen O) (hmaps : Set.MapsTo f (K \ C) O) :
+    ∃ g : C(E, N),
+      ContMDiff 𝓘(ℝ, E) J ∞ g ∧
+        Smale.HomotopicRelWithin f g C (K \ C) O ∧
+          Topology.IsClosedEmbedding (fun x : K => g x) ∧
+            ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J g x) := by
+  classical
+  let bad := doublePoints f K
+  have hbad : IsCompact bad := isCompact_doublePoints_of_injective_nativeDerivative hf hK hinj
+  have hp (q : bad) :
+    ∃ p : Smale.GeneralPosition.MapAvoidancePatch 𝓘(ℝ, E) J (N := N) C,
+      p.Compatible f ∧ p.cutoff q.1.1 ≠ p.cutoff q.1.2 ∧ p.chart.source ⊆ O := by
+    have hq := q.property
+    rcases hq with ⟨hx, hy, hne, heq⟩
+    have hnot : ¬(q.1.1 ∈ C ∧ q.1.2 ∈ C) := by
+      rintro ⟨hxC, hyC⟩
+      exact hne (hfixed ⟨hx, hxC⟩ ⟨hy, hyC⟩ heq)
+    exact
+      exists_separating_patch_of_not_both_fixed_in_open f hC hne hnot hO
+        (fun hxC => hmaps ⟨hx, hxC⟩) (fun hyC => hmaps ⟨hy, hyC⟩)
+  choose p hpcompatible hpactive hpsource using hp
+  let U (q : bad) : Set (E × E) := {r | (p q).cutoff r.1 ≠ (p q).cutoff r.2}
+  have hU (q : bad) : IsOpen (U q) :=
+    isOpen_ne_fun ((p q).smooth.continuous.comp continuous_fst)
+      ((p q).smooth.continuous.comp continuous_snd)
+  have hcover : bad ⊆ ⋃ q : bad, U q := by
+    intro q hq
+    exact Set.mem_iUnion.mpr ⟨⟨q, hq⟩, hpactive ⟨q, hq⟩⟩
+  obtain ⟨s, hs⟩ := hbad.elim_finite_subcover U hU hcover
+  refine
+    exists_embedding_of_finite_separating_patches_within_target (fun i : s => p i.1) f hf
+      (fun i => hpcompatible i.1) hdim hK hinj ?_ (fun i => hpsource i.1) hmaps
+  intro x hx y hy hne heq
+  have hxy : (x, y) ∈ bad := ⟨hx, hy, hne, heq⟩
+  obtain ⟨i, hi, hsep⟩ := Set.mem_iUnion₂.mp (hs hxy)
+  exact ⟨⟨i, hi⟩, hsep⟩
+
+private theorem Smale.ManifoldImmersion.exists_compact_embedding_of_immersion {E G H N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N]
+    (f : C(E, N)) (hf : ContMDiff 𝓘(ℝ, E) J ∞ f)
+    (hdim : 2 * Module.finrank ℝ E < Module.finrank ℝ G) {K C : Set E} (hK : IsCompact K)
+    (hinj : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f x)) (hC : IsClosed C)
+    (hfixed : Set.InjOn f (K ∩ C)) :
+    ∃ g : C(E, N),
+      ContMDiff 𝓘(ℝ, E) J ∞ g ∧
+        f.HomotopicRel g C ∧
+          Topology.IsClosedEmbedding (fun x : K => g x) ∧
+            ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J g x) := by
+  obtain ⟨g, hg, hrel, he, hi⟩ :=
+    exists_compact_embedding_of_immersion_within_target f hf hdim hK hinj hC hfixed isOpen_univ
+      (Set.mapsTo_univ f (K \ C))
+  exact ⟨g, hg, hrel.homotopicRel, he, hi⟩
+
+private theorem Smale.ManifoldImmersion.exists_relative_compact_embedding {G H N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] [T2Space N] (f : C(Smale.PlaneImmersion.Plane, N))
+    (hf : ContMDiff 𝓘(ℝ, Smale.PlaneImmersion.Plane) J ∞ f) (hdim : 5 ≤ Module.finrank ℝ G)
+    {K C : Set Smale.PlaneImmersion.Plane} (hK : IsCompact K) (hC : IsClosed C)
+    (hfixed : Set.InjOn f (K ∩ C))
+    (hderiv : ∀ x ∈ K ∩ C, Function.Injective (mfderiv 𝓘(ℝ, Smale.PlaneImmersion.Plane) J f x)) :
+    ∃ g : C(Smale.PlaneImmersion.Plane, N),
+      ContMDiff 𝓘(ℝ, Smale.PlaneImmersion.Plane) J ∞ g ∧
+        f.HomotopicRel g C ∧
+          Topology.IsClosedEmbedding (fun x : K => g x) ∧
+            ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, Smale.PlaneImmersion.Plane) J g x) := by
+  let U : Set Smale.PlaneImmersion.Plane :=
+    {x | Function.Injective (mfderiv 𝓘(ℝ, Smale.PlaneImmersion.Plane) J f x)}
+  have hU : IsOpen U := isOpen_injective_derivative hf
+  have hCU : K ∩ C ⊆ U := fun x hx => hderiv x hx
+  obtain ⟨D, hD, hCD, hDU⟩ := exists_compact_between (hK.inter_right hC) hU hCU
+  let L := K \ interior D
+  have hL : IsCompact L := hK.inter_right isOpen_interior.isClosed_compl
+  have hdis : Disjoint L C := Set.disjoint_left.mpr (fun _ hx hxC => hx.2 (hCD ⟨hx.1, hxC⟩))
+  obtain ⟨g₁, hg₁, hhom₁, hinj₁⟩ :=
+    exists_immersion_on_compact_rel f hf hdim hD hL (fun x hx => hDU hx) hC hdis
+  have hKinj : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, Smale.PlaneImmersion.Plane) J g₁ x) := by
+    intro x hx
+    apply hinj₁ x
+    by_cases hxD : x ∈ D
+    · exact Or.inl hxD
+    · exact Or.inr ⟨hx, fun hi => hxD (interior_subset hi)⟩
+  have hfixed₁ : Set.InjOn g₁ (K ∩ C) := by
+    intro x hx y hy hxy
+    apply hfixed hx hy
+    rw [hhom₁.fst_eq_snd hx.2, hhom₁.fst_eq_snd hy.2]
+    exact hxy
+  have hd : 2 * Module.finrank ℝ Smale.PlaneImmersion.Plane < Module.finrank ℝ G := by
+    simp only [Smale.PlaneImmersion.Plane, Module.finrank_prod, Module.finrank_self]
+    omega
+  obtain ⟨g₂, hg₂, hhom₂, hemb, hinj₂⟩ :=
+    exists_compact_embedding_of_immersion g₁ hg₁ hd hK hKinj hC hfixed₁
+  exact ⟨g₂, hg₂, hhom₁.trans hhom₂, hemb, hinj₂⟩
+
+private theorem Smale.ManifoldImmersion.injective_mfderiv_comp_linearEquiv_iff {E E' G H N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup E'] [NormedSpace ℝ E']
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [TopologicalSpace N] [ChartedSpace H N] (e : E' ≃L[ℝ] E) {f : E → N} {x : E'}
+    (hf : MDifferentiableAt 𝓘(ℝ, E) J f (e x)) :
+    Function.Injective (mfderiv 𝓘(ℝ, E') J (f ∘ e) x) ↔
+      Function.Injective (mfderiv 𝓘(ℝ, E) J f (e x)) := by
+  have he : mfderiv 𝓘(ℝ, E') 𝓘(ℝ, E) e x = e.toContinuousLinearMap := by
+    rw [mfderiv_eq_fderiv]
+    exact e.toContinuousLinearMap.fderiv
+  have hesmooth : ContMDiff 𝓘(ℝ, E') 𝓘(ℝ, E) ∞ e := e.contDiff.contMDiff
+  rw [mfderiv_comp x hf (hesmooth.mdifferentiableAt (by simp)), he]
+  constructor
+  · intro h v w hvw
+    apply e.symm.injective
+    apply h
+    change (mfderiv 𝓘(ℝ, E) J f (e x)) (e (e.symm v)) = (mfderiv 𝓘(ℝ, E) J f (e x)) (e (e.symm w))
+    exact
+      (congrArg (mfderiv 𝓘(ℝ, E) J f (e x)) (e.apply_symm_apply (v : E))).trans
+        (hvw.trans (congrArg (mfderiv 𝓘(ℝ, E) J f (e x)) (e.apply_symm_apply (w : E))).symm)
+  · exact fun h => h.comp e.injective
+
+private theorem
+    Smale.ManifoldImmersion.exists_relative_compact_embedding_twoDimensional {E G H N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [TopologicalSpace N] [ChartedSpace H N]
+    [FiniteDimensional ℝ E] [FiniteDimensional ℝ G] [J.Boundaryless] [IsManifold J ∞ N]
+    [T2Space N] (f : C(E, N)) (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) (hsourceDim : Module.finrank ℝ E = 2)
+    (hdim : 5 ≤ Module.finrank ℝ G) {K C : Set E} (hK : IsCompact K) (hC : IsClosed C)
+    (hfixed : Set.InjOn f (K ∩ C))
+    (hderiv : ∀ x ∈ K ∩ C, Function.Injective (mfderiv 𝓘(ℝ, E) J f x)) :
+    ∃ g : C(E, N),
+      ContMDiff 𝓘(ℝ, E) J ∞ g ∧
+        f.HomotopicRel g C ∧
+          Topology.IsClosedEmbedding (fun x : K => g x) ∧
+            ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J g x) := by
+  let e : Smale.PlaneImmersion.Plane ≃L[ℝ] E :=
+    ContinuousLinearEquiv.ofFinrankEq
+      (by
+        simp only [Smale.PlaneImmersion.Plane, Module.finrank_prod, Module.finrank_self]
+        omega)
+  let fp : C(Smale.PlaneImmersion.Plane, N) := ⟨f ∘ e, f.continuous.comp e.continuous⟩
+  have hfp : ContMDiff 𝓘(ℝ, Smale.PlaneImmersion.Plane) J ∞ fp := hf.comp e.contDiff.contMDiff
+  have hKp : IsCompact (e ⁻¹' K) := e.toHomeomorph.isCompact_preimage.mpr hK
+  have hCp : IsClosed (e ⁻¹' C) := hC.preimage e.continuous
+  have hfixedp : Set.InjOn fp ((e ⁻¹' K) ∩ (e ⁻¹' C)) := by
+    intro x hx y hy hxy
+    exact e.injective (hfixed ⟨hx.1, hx.2⟩ ⟨hy.1, hy.2⟩ hxy)
+  have hderivp :
+    ∀ x ∈ (e ⁻¹' K) ∩ (e ⁻¹' C),
+      Function.Injective (mfderiv 𝓘(ℝ, Smale.PlaneImmersion.Plane) J fp x) := by
+    intro x hx
+    exact
+      (injective_mfderiv_comp_linearEquiv_iff e (hf.mdifferentiableAt (by simp))).mpr
+        (hderiv (e x) ⟨hx.1, hx.2⟩)
+  obtain ⟨gp, hgp, ⟨Hrel⟩, hembp, hgpderiv⟩ :=
+    exists_relative_compact_embedding fp hfp hdim hKp hCp hfixedp hderivp
+  let g : C(E, N) := ⟨gp ∘ e.symm, gp.continuous.comp e.symm.continuous⟩
+  have hg : ContMDiff 𝓘(ℝ, E) J ∞ g := hgp.comp e.symm.contDiff.contMDiff
+  have hpreK (x : E) (hx : x ∈ K) : e.symm x ∈ e ⁻¹' K := by
+    change e (e.symm x) ∈ K
+    simpa only [e.apply_symm_apply] using hx
+  refine ⟨g, hg, ?_, ?_, ?_⟩
+  · refine
+      ⟨{  toFun := fun q => Hrel (q.1, e.symm q.2)
+          continuous_toFun :=
+            Hrel.continuous.comp (continuous_fst.prodMk (e.symm.continuous.comp continuous_snd))
+          map_zero_left := ?_
+          map_one_left := ?_
+          prop' := ?_ }⟩
+    · intro x
+      rw [Hrel.apply_zero]
+      exact congrArg f (e.apply_symm_apply x)
+    · intro x
+      exact Hrel.apply_one (e.symm x)
+    · intro t x hx
+      change Hrel (t, e.symm x) = f x
+      have hpreC : e.symm x ∈ e ⁻¹' C := by
+        change e (e.symm x) ∈ C
+        simpa only [e.apply_symm_apply] using hx
+      rw [Hrel.eq_fst t hpreC]
+      exact congrArg f (e.apply_symm_apply x)
+  · let : CompactSpace K := isCompact_iff_compactSpace.mp hK
+    apply (g.continuous.comp continuous_subtype_val).isClosedEmbedding
+    intro x y hxy
+    apply Subtype.ext
+    apply e.symm.injective
+    have hpeq : gp (e.symm x) = gp (e.symm y) := hxy
+    exact
+      congrArg Subtype.val
+        (hembp.injective (a₁ := ⟨e.symm x, hpreK x x.property⟩) (a₂ :=
+          ⟨e.symm y, hpreK y y.property⟩) hpeq)
+  · intro x hx
+    exact
+      (injective_mfderiv_comp_linearEquiv_iff e.symm (hgp.mdifferentiableAt (by simp))).mpr
+        (hgpderiv (e.symm x) (hpreK x hx))
+
+private theorem Smale.ManifoldImmersion.exists_embedded_image_avoidance_relative_neighborhood
+    {E E' G H H' Y N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup E'] [NormedSpace ℝ E'] [FiniteDimensional ℝ E'] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    {J : ModelWithCorners ℝ G H} {I' : ModelWithCorners ℝ E' H'} [J.Boundaryless]
+    [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y] [LindelofSpace (E × Y)]
+    [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N] (f : C(E, N))
+    (g : C(Y, N)) (A : Set Y) (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) (hg : ContMDiff I' J ∞ g)
+    (hclosed : IsClosed (g '' A)) (hself : 2 * Module.finrank ℝ E < Module.finrank ℝ G)
+    (hobstacle : Module.finrank ℝ E + Module.finrank ℝ E' < Module.finrank ℝ G) {K C B : Set E}
+    (hK : IsCompact K) (hC : IsClosed C) (hBC : B ⊆ interior C) (hinj : Set.InjOn f K)
+    (hderiv : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f x))
+    (hclean : ∀ x ∈ K ∩ C, x ∉ B → f x ∉ g '' A) {O : Set N} (hO : IsOpen O)
+    (hmaps : Set.MapsTo f K O) :
+    ∃ f' : C(E, N),
+      ContMDiff 𝓘(ℝ, E) J ∞ f' ∧
+        f.HomotopicRel f' C ∧
+          Topology.IsClosedEmbedding (fun x : K => f' x) ∧
+            (∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f' x)) ∧
+              Set.MapsTo f' K O ∧ ∀ x ∈ K \ B, f' x ∉ g '' A := by
+  let L : Set E := K \ interior C
+  have hL : IsCompact L := hK.inter_right isOpen_interior.isClosed_compl
+  have hfixed : ∀ x ∈ L ∩ C, f x ∉ g '' A := by
+    intro x hx
+    exact hclean x ⟨hx.1.1, hx.2⟩ (fun hxB => hx.1.2 (hBC hxB))
+  obtain ⟨f', hf', hhom, hemb, hderiv', -, hmaps', havoid⟩ :=
+    exists_embedded_avoidance_on_compact_of_isClosed_image f g A hf hg hclosed hself hobstacle hK
+      hL hC hinj hderiv hfixed hO hmaps
+  refine ⟨f', hf', hhom, hemb, hderiv', hmaps', ?_⟩
+  intro x hx
+  by_cases hxC : x ∈ C
+  · exact havoid x (Or.inl (hclean x ⟨hx.1, hxC⟩ hx.2))
+  · exact havoid x (Or.inr ⟨hx.1, fun hi => hxC (interior_subset hi)⟩)
+
+private theorem
+    Smale.ManifoldImmersion.exists_embedded_avoidance_relative_neighborhood_of_isClosed_range
+    {E E' G H H' Y N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup E'] [NormedSpace ℝ E'] [FiniteDimensional ℝ E'] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    {J : ModelWithCorners ℝ G H} {I' : ModelWithCorners ℝ E' H'} [J.Boundaryless]
+    [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y] [LindelofSpace (E × Y)]
+    [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N] (f : C(E, N))
+    (g : C(Y, N)) (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) (hg : ContMDiff I' J ∞ g)
+    (hclosed : IsClosed (Set.range g)) (hself : 2 * Module.finrank ℝ E < Module.finrank ℝ G)
+    (hobstacle : Module.finrank ℝ E + Module.finrank ℝ E' < Module.finrank ℝ G) {K C B : Set E}
+    (hK : IsCompact K) (hC : IsClosed C) (hBC : B ⊆ interior C) (hinj : Set.InjOn f K)
+    (hderiv : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f x))
+    (hclean : ∀ x ∈ K ∩ C, x ∉ B → f x ∉ Set.range g) :
+    ∃ f' : C(E, N),
+      ContMDiff 𝓘(ℝ, E) J ∞ f' ∧
+        f.HomotopicRel f' C ∧
+          Topology.IsClosedEmbedding (fun x : K => f' x) ∧
+            (∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f' x)) ∧
+              ∀ x ∈ K \ B, f' x ∉ Set.range g := by
+  obtain ⟨f', hf', hhom, hemb, hd, -, havoid⟩ :=
+    exists_embedded_image_avoidance_relative_neighborhood f g Set.univ hf hg
+      (by simpa only [Set.image_univ] using hclosed) hself hobstacle hK hC hBC hinj hderiv
+      (by simpa only [Set.image_univ] using hclean) isOpen_univ (fun _ _ => Set.mem_univ _)
+  refine ⟨f', hf', hhom, hemb, hd, ?_⟩
+  simpa only [Set.image_univ] using havoid
+
+private theorem
+  Smale.ManifoldImmersion.exists_relative_embedded_avoidance_of_clean_neighborhood_of_isClosed_range
+    {E E' G H H' Y N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup E'] [NormedSpace ℝ E'] [FiniteDimensional ℝ E'] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    {J : ModelWithCorners ℝ G H} {I' : ModelWithCorners ℝ E' H'} [J.Boundaryless]
+    [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y] [LindelofSpace (E × Y)]
+    [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N] (f : C(E, N))
+    (g : C(Y, N)) (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) (hg : ContMDiff I' J ∞ g)
+    (hclosed : IsClosed (Set.range g)) (hsourceDim : Module.finrank ℝ E = 2)
+    (hdim : 5 ≤ Module.finrank ℝ G)
+    (hobstacle : Module.finrank ℝ E + Module.finrank ℝ E' < Module.finrank ℝ G) {K C B : Set E}
+    (hK : IsCompact K) (hC : IsClosed C) (hBC : B ⊆ interior C) (hinj : Set.InjOn f (K ∩ C))
+    (hderiv : ∀ x ∈ K ∩ C, Function.Injective (mfderiv 𝓘(ℝ, E) J f x))
+    (hclean : ∀ x ∈ K ∩ C, x ∉ B → f x ∉ Set.range g) :
+    ∃ f' : C(E, N),
+      ContMDiff 𝓘(ℝ, E) J ∞ f' ∧
+        f.HomotopicRel f' C ∧
+          Topology.IsClosedEmbedding (fun x : K => f' x) ∧
+            (∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f' x)) ∧
+              ∀ x ∈ K \ B, f' x ∉ Set.range g := by
+  obtain ⟨f₁, hf₁, hhom₁, hemb₁, hderiv₁⟩ :=
+    exists_relative_compact_embedding_twoDimensional f hf hsourceDim hdim hK hC hinj hderiv
+  have hinj₁ : Set.InjOn f₁ K := by
+    intro x hx y hy hxy
+    exact congrArg Subtype.val (hemb₁.injective (a₁ := ⟨x, hx⟩) (a₂ := ⟨y, hy⟩) hxy)
+  have hclean₁ : ∀ x ∈ K ∩ C, x ∉ B → f₁ x ∉ Set.range g := by
+    intro x hx hxB
+    rw [← hhom₁.fst_eq_snd hx.2]
+    exact hclean x hx hxB
+  have hself : 2 * Module.finrank ℝ E < Module.finrank ℝ G := by omega
+  obtain ⟨f₂, hf₂, hhom₂, hemb₂, hderiv₂, havoid₂⟩ :=
+    exists_embedded_avoidance_relative_neighborhood_of_isClosed_range f₁ g hf₁ hg hclosed hself
+      hobstacle hK hC hBC hinj₁ hderiv₁ hclean₁
+  exact ⟨f₂, hf₂, hhom₁.trans hhom₂, hemb₂, hderiv₂, havoid₂⟩
+
+private theorem Smale.ManifoldImmersion.exists_embedded_avoidance_relative_neighborhood
+    {E E' G H H' Y N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup E'] [NormedSpace ℝ E'] [FiniteDimensional ℝ E'] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    {J : ModelWithCorners ℝ G H} {I' : ModelWithCorners ℝ E' H'} [J.Boundaryless]
+    [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y] [LindelofSpace (E × Y)]
+    [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N] [CompactSpace Y]
+    (f : C(E, N)) (g : C(Y, N)) (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) (hg : ContMDiff I' J ∞ g)
+    (hself : 2 * Module.finrank ℝ E < Module.finrank ℝ G)
+    (hobstacle : Module.finrank ℝ E + Module.finrank ℝ E' < Module.finrank ℝ G) {K C B : Set E}
+    (hK : IsCompact K) (hC : IsClosed C) (hBC : B ⊆ interior C) (hinj : Set.InjOn f K)
+    (hderiv : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f x))
+    (hclean : ∀ x ∈ K ∩ C, x ∉ B → f x ∉ Set.range g) :
+    ∃ f' : C(E, N),
+      ContMDiff 𝓘(ℝ, E) J ∞ f' ∧
+        f.HomotopicRel f' C ∧
+          Topology.IsClosedEmbedding (fun x : K => f' x) ∧
+            (∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f' x)) ∧
+              ∀ x ∈ K \ B, f' x ∉ Set.range g :=
+  exists_embedded_avoidance_relative_neighborhood_of_isClosed_range f g hf hg
+    (isCompact_range g.continuous).isClosed hself hobstacle hK hC hBC hinj hderiv hclean
+
+private def Smale.OpenObstacle.source {Y N : Type*} [TopologicalSpace Y] [TopologicalSpace N]
+    (g : C(Y, N)) (U : TopologicalSpace.Opens N) : TopologicalSpace.Opens Y :=
+  ⟨g ⁻¹' (U : Set N), U.isOpen.preimage g.continuous⟩
+
+private def Smale.OpenObstacle.restrict {Y N : Type*} [TopologicalSpace Y] [TopologicalSpace N]
+    (g : C(Y, N)) (U : TopologicalSpace.Opens N) : C(source g U, U)
+    where
+  toFun y := ⟨g y, y.property⟩
+  continuous_toFun := (g.continuous.comp continuous_subtype_val).subtype_mk _
+
+private theorem Smale.OpenObstacle.mem_range_restrict_iff {Y N : Type*} [TopologicalSpace Y]
+    [TopologicalSpace N] (g : C(Y, N)) (U : TopologicalSpace.Opens N) (x : U) :
+    x ∈ Set.range (Smale.OpenObstacle.restrict g U) ↔ (x : N) ∈ Set.range g := by
+  constructor
+  · rintro ⟨y, hy⟩
+    exact ⟨y, congrArg Subtype.val hy⟩
+  · rintro ⟨y, hy⟩
+    have hyU : y ∈ source g U := by
+      change g y ∈ U
+      exact hy.symm ▸ x.property
+    exact ⟨⟨y, hyU⟩, Subtype.ext hy⟩
+
+private theorem
+    Smale.OpenObstacle.range_restrict {Y N : Type*} [TopologicalSpace Y] [TopologicalSpace N]
+    (g : C(Y, N)) (U : TopologicalSpace.Opens N) :
+    Set.range (Smale.OpenObstacle.restrict g U) = (Subtype.val : U → N) ⁻¹' Set.range g := by
+  ext x
+  exact mem_range_restrict_iff g U x
+
+private theorem Smale.OpenObstacle.isClosed_range_restrict {Y N : Type*} [TopologicalSpace Y]
+    [TopologicalSpace N] (g : C(Y, N)) (U : TopologicalSpace.Opens N)
+    (hclosed : IsClosed (Set.range g)) : IsClosed (Set.range (Smale.OpenObstacle.restrict g U)) :=
+  by
+  rw [Smale.OpenObstacle.range_restrict]
+  exact hclosed.preimage continuous_subtype_val
+
+private theorem
+    Smale.OpenObstacle.image_restrict {Y N : Type*} [TopologicalSpace Y] [TopologicalSpace N]
+    (g : C(Y, N)) (U : TopologicalSpace.Opens N) (A : Set Y) :
+    Smale.OpenObstacle.restrict g U '' ((Subtype.val : source g U → Y) ⁻¹' A) =
+      (Subtype.val : U → N) ⁻¹' (g '' A) := by
+  ext x
+  constructor
+  · rintro ⟨y, hy, heq⟩
+    exact ⟨y, hy, congrArg Subtype.val heq⟩
+  · rintro ⟨y, hy, heq⟩
+    have hyU : y ∈ source g U := by
+      change g y ∈ U
+      exact heq.symm ▸ x.property
+    exact ⟨⟨y, hyU⟩, hy, Subtype.ext heq⟩
+
+private theorem Smale.OpenObstacle.isClosed_image_restrict {Y N : Type*} [TopologicalSpace Y]
+    [TopologicalSpace N] (g : C(Y, N)) (U : TopologicalSpace.Opens N) (A : Set Y)
+    (hclosed : IsClosed (g '' A)) :
+    IsClosed (Smale.OpenObstacle.restrict g U '' ((Subtype.val : source g U → Y) ⁻¹' A)) := by
+  rw [Smale.OpenObstacle.image_restrict]
+  exact hclosed.preimage continuous_subtype_val
+
+private theorem
+    Smale.OpenObstacle.contMDiff_restrict {E' G H H' Y N : Type*} [NormedAddCommGroup E']
+    [NormedSpace ℝ E'] [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H]
+    [TopologicalSpace H'] {J : ModelWithCorners ℝ G H} {I' : ModelWithCorners ℝ E' H'}
+    [TopologicalSpace Y] [ChartedSpace H' Y] [TopologicalSpace N] [ChartedSpace H N] (g : C(Y, N))
+    (U : TopologicalSpace.Opens N) (hg : ContMDiff I' J ∞ g) :
+    ContMDiff I' J ∞ (Smale.OpenObstacle.restrict g U) := by
+  apply (ContMDiff.subtypeVal_comp_iff U (Smale.OpenObstacle.restrict g U)).mp
+  exact hg.comp contMDiff_subtype_val
+
+private theorem MorseCancel.exists_smooth_path_avoiding_closed_image {E G H H' N Y : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ G H'} [J.Boundaryless]
+    [TopologicalSpace Y] [ChartedSpace H Y] [IsManifold I ∞ Y] [SecondCountableTopology Y]
+    [TopologicalSpace N] [ChartedSpace H' N] [IsManifold J ∞ N] {x y : N}
+    (γ : Path x y) (g : C(Y, N)) (hg : ContMDiff I J ∞ g) (hclosed : IsClosed (Set.range g))
+    (hdim : 1 + Module.finrank ℝ E < Module.finrank ℝ G) (hx : x ∉ Set.range g)
+    (hy : y ∉ Set.range g) : ∃ η : Path x y, ContMDiff (𝓡∂ 1) J ∞ η ∧ ∀ t, η t ∉ Set.range g := by
+  obtain ⟨f, hf, hf0, hf1⟩ := Smale.exists_smooth_connecting_curve (J := J) γ
+  let fI : C(unitInterval, N) := ⟨fun t => f t, f.continuous.comp continuous_subtype_val⟩
+  have hfI : ContMDiff (𝓡∂ 1) J ∞ fI := hf.comp contMDiff_subtypeVal_Icc
+  have hdim' :
+    Module.finrank ℝ (EuclideanSpace ℝ (Fin 1)) + Module.finrank ℝ E < Module.finrank ℝ G := by
+    simpa only [finrank_euclideanSpace_fin] using hdim
+  have hfixed : ∀ t ∈ ({0, 1} : Set unitInterval), fI t ∉ Set.range g := by
+    intro t ht
+    rcases ht with rfl | ht
+    · change f 0 ∉ Set.range g
+      rwa [hf0]
+    · have ht1 : t = 1 := ht
+      subst t
+      change f 1 ∉ Set.range g
+      rwa [hf1]
+  obtain ⟨f', hf', hrel, hdisjoint⟩ :=
+    Smale.GeneralPosition.exists_disjoint_smooth_map_homotopicRel_of_isClosed_range fI g hfI hg
+      hclosed hdim' ((Set.finite_singleton (1 : unitInterval)).insert 0).isClosed hfixed
+  have h0 : f' 0 = x := (hrel.fst_eq_snd (by simp)).symm.trans hf0
+  have h1 : f' 1 = y := (hrel.fst_eq_snd (by simp)).symm.trans hf1
+  let η : Path x y := { toContinuousMap := f', source' := h0, target' := h1 }
+  exact ⟨η, hf', fun t ht => Set.disjoint_left.mp hdisjoint ⟨t, rfl⟩ ht⟩
+
+private theorem MorseCancel.exists_smooth_path_avoiding_closed_image_in_open {E G H H' N Y : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ G H'} [J.Boundaryless]
+    [TopologicalSpace Y] [ChartedSpace H Y] [IsManifold I ∞ Y] [SecondCountableTopology Y]
+    [TopologicalSpace N] [ChartedSpace H' N] [IsManifold J ∞ N]
+    (U : TopologicalSpace.Opens N) {x y : U} (γ : Path x y) (g : C(Y, N)) (hg : ContMDiff I J ∞ g)
+    (hclosed : IsClosed (Set.range g)) (hdim : 1 + Module.finrank ℝ E < Module.finrank ℝ G)
+    (hx : x.val ∉ Set.range g) (hy : y.val ∉ Set.range g) :
+    ∃ η : Path x y, ContMDiff (𝓡∂ 1) J ∞ η ∧ ∀ t, (η t).val ∉ Set.range g := by
+  obtain ⟨η, hη, havoid⟩ :=
+    exists_smooth_path_avoiding_closed_image γ (Smale.OpenObstacle.restrict g U)
+      (Smale.OpenObstacle.contMDiff_restrict g U hg)
+      (Smale.OpenObstacle.isClosed_range_restrict g U hclosed) hdim
+      (fun h => hx ((Smale.OpenObstacle.mem_range_restrict_iff g U x).mp h))
+      (fun h => hy ((Smale.OpenObstacle.mem_range_restrict_iff g U y).mp h))
+  exact
+    ⟨η, hη, fun t ht => havoid t ((Smale.OpenObstacle.mem_range_restrict_iff g U (η t)).mpr ht)⟩
+
+private theorem
+    Smale.ManifoldSmoothing.exists_smooth_map_homotopicRel_of_smooth_off_compact_within_target
+    {E G H H' X N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ G H'} [J.Boundaryless]
+    [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X] [T2Space X] [SigmaCompactSpace X]
+    [TopologicalSpace N] [ChartedSpace H' N] [IsManifold J ∞ N] (f : C(X, N)) {K C U : Set X}
+    (hK : IsCompact K) (hC : IsClosed C) (hU : IsOpen U) (hCU : C ⊆ U)
+    (hfU : ContMDiffOn I J ∞ f U) (hfK : ContMDiffOn I J ∞ f Kᶜ) {D : Set X} {O : Set N}
+    (hO : IsOpen O) (hKO : Set.MapsTo f K O) (hmaps : Set.MapsTo f D O) :
+    ∃ f' : C(X, N), ContMDiff I J ∞ f' ∧ Smale.HomotopicRelWithin f f' C D O := by
+  classical
+  have hp (x : K) :=
+    exists_smoothing_patch_at_in_open (I := I) (J := J) f (x : X) hO (hKO x.property)
+  choose p hcompatible hplateau hsource using hp
+  have hcover : K ⊆ ⋃ x : K, (p x).plateau := by
+    intro x hx
+    exact Set.mem_iUnion.mpr ⟨⟨x, hx⟩, hplateau ⟨x, hx⟩⟩
+  obtain ⟨s, hs⟩ :=
+    hK.elim_finite_subcover (fun x : K => (p x).plateau) (fun _ => isOpen_interior) hcover
+  obtain ⟨f', _, hhom, hsm⟩ :=
+    exists_finite_patch_smoothing_within_target (fun i : s => p i.1) f (fun i => hcompatible i.1)
+      hC hU hCU hfU (fun i => hsource i.1) hmaps Finset.univ
+  refine ⟨f', ?_, hhom⟩
+  intro x
+  apply hsm x
+  by_cases hx : x ∈ K
+  · obtain ⟨i, his, hxi⟩ := Set.mem_iUnion₂.mp (hs hx)
+    exact Or.inr ⟨⟨i, his⟩, Finset.mem_univ _, hxi⟩
+  · exact Or.inl ((hfK x hx).contMDiffAt (hK.isClosed.isOpen_compl.mem_nhds hx))
+
+private theorem Smale.ManifoldSmoothing.exists_smooth_map_homotopicRel_of_smooth_off_compact
+    {E G H H' X N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    {I : ModelWithCorners ℝ E H} {J : ModelWithCorners ℝ G H'} [J.Boundaryless]
+    [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X] [T2Space X] [SigmaCompactSpace X]
+    [TopologicalSpace N] [ChartedSpace H' N] [IsManifold J ∞ N] (f : C(X, N)) {K C U : Set X}
+    (hK : IsCompact K) (hC : IsClosed C) (hU : IsOpen U) (hCU : C ⊆ U)
+    (hfU : ContMDiffOn I J ∞ f U) (hfK : ContMDiffOn I J ∞ f Kᶜ) :
+    ∃ f' : C(X, N), ContMDiff I J ∞ f' ∧ f.HomotopicRel f' C := by
+  obtain ⟨f', hf', hrel⟩ :=
+    exists_smooth_map_homotopicRel_of_smooth_off_compact_within_target f hK hC hU hCU hfU hfK
+      isOpen_univ (Set.mapsTo_univ f K) (Set.mapsTo_univ f Set.univ)
+  exact ⟨f', hf', hrel.homotopicRel⟩
+
+private theorem Smale.CurveImmersion.exists_continuous_curve_with_endpoint_germs {N : Type*}
+    [TopologicalSpace N] (a b : C(ℝ, N)) (γ : Path (a 0) (b 1)) :
+    ∃ f : C(ℝ, N), Set.EqOn f a (Set.Iic (1 / 4 : ℝ)) ∧ Set.EqOn f b (Set.Ici (3 / 4 : ℝ)) := by
+  classical
+  let α : Path (a (1 / 4)) (a 0) :=
+    Path.ofLine (f := fun t : ℝ => a ((1 - t) / 4))
+      ((a.continuous.comp ((continuous_const.sub continuous_id).div_const 4)).continuousOn)
+      (by norm_num) (by norm_num)
+  let β : Path (b 1) (b (3 / 4)) :=
+    Path.ofLine (f := fun t : ℝ => b (1 - t / 4))
+      ((b.continuous.comp (continuous_const.sub (continuous_id.div_const 4))).continuousOn)
+      (by norm_num) (by norm_num)
+  let η := α.trans (γ.trans β)
+  let mid : ℝ → N := fun t => η.extend (2 * t - 1 / 2)
+  have hmid : Continuous mid :=
+    η.continuous_extend.comp ((continuous_const.mul continuous_id).sub continuous_const)
+  have hm₀ : mid (1 / 4) = a (1 / 4) := by
+    change η.extend (2 * (1 / 4) - 1 / 2) = _
+    norm_num
+  have hm₁ : mid (3 / 4) = b (3 / 4) := by
+    change η.extend (2 * (3 / 4) - 1 / 2) = _
+    norm_num
+  let right : ℝ → N := fun t => if t ≤ 3 / 4 then mid t else b t
+  have hr : Continuous right :=
+    hmid.if_le b.continuous continuous_id continuous_const (fun t ht => ht ▸ hm₁)
+  let f : ℝ → N := fun t => if t ≤ 1 / 4 then a t else right t
+  have hf : Continuous f :=
+    a.continuous.if_le hr continuous_id continuous_const
+      (by
+        intro t ht
+        subst t
+        simpa only [right, ite_eq_left (show (1 / 4 : ℝ) ≤ 3 / 4 by norm_num)] using hm₀.symm)
+  refine ⟨⟨f, hf⟩, ?_, ?_⟩
+  · intro t ht
+    exact ite_eq_left ht
+  · intro t ht
+    change 3 / 4 ≤ t at ht
+    change (if t ≤ 1 / 4 then a t else if t ≤ 3 / 4 then mid t else b t) = b t
+    rw [ite_eq_right (show ¬t ≤ 1 / 4 by linarith)]
+    by_cases hte : t = 3 / 4
+    · subst t
+      simpa only [ite_eq_left le_rfl] using hm₁
+    · exact ite_eq_right (by intro h; exact hte (le_antisymm h ht))
+
+private theorem Smale.exists_smooth_curve_with_endpoint_germs {G H N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [J.Boundaryless]
+    [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] (a b : C(ℝ, N))
+    (ha : ContMDiff 𝓘(ℝ, ℝ) J ∞ a) (hb : ContMDiff 𝓘(ℝ, ℝ) J ∞ b) (γ : Path (a 0) (b 1)) :
+    ∃ f : C(ℝ, N),
+      ContMDiff 𝓘(ℝ, ℝ) J ∞ f ∧
+        Set.EqOn f a (Set.Iic (1 / 8 : ℝ)) ∧ Set.EqOn f b (Set.Ici (7 / 8 : ℝ)) := by
+  obtain ⟨g, hgleft, hgright⟩ := CurveImmersion.exists_continuous_curve_with_endpoint_germs a b γ
+  let K := Set.Icc (1 / 4 : ℝ) (3 / 4)
+  let U := Set.Iio (1 / 4 : ℝ) ∪ Set.Ioi (3 / 4)
+  let C := Set.Iic (1 / 8 : ℝ) ∪ Set.Ici (7 / 8)
+  have hU : IsOpen U := isOpen_Iio.union isOpen_Ioi
+  have hC : IsClosed C := isClosed_Iic.union isClosed_Ici
+  have hCU : C ⊆ U := by
+    intro t ht
+    rcases ht with ht | ht
+    · change t ≤ 1 / 8 at ht
+      exact Or.inl (show t < 1 / 4 by linarith)
+    · change 7 / 8 ≤ t at ht
+      exact Or.inr (show 3 / 4 < t by linarith)
+  have hgU : ContMDiffOn 𝓘(ℝ, ℝ) J ∞ g U := by
+    intro t ht
+    apply ContMDiffAt.contMDiffWithinAt
+    rcases ht with ht | ht
+    · have heq : g =ᶠ[𝓝 t] a := by
+        filter_upwards [isOpen_Iio.mem_nhds (show t ∈ Set.Iio (1 / 4 : ℝ) from ht)] with s hs
+        exact hgleft (show s ≤ 1 / 4 from hs.le)
+      exact ha.contMDiffAt.congr_of_eventuallyEq heq
+    · have heq : g =ᶠ[𝓝 t] b := by
+        filter_upwards [isOpen_Ioi.mem_nhds (show t ∈ Set.Ioi (3 / 4 : ℝ) from ht)] with s hs
+        exact hgright (show 3 / 4 ≤ s from hs.le)
+      exact hb.contMDiffAt.congr_of_eventuallyEq heq
+  have hKU : Kᶜ ⊆ U := by
+    intro t ht
+    change ¬(1 / 4 ≤ t ∧ t ≤ 3 / 4) at ht
+    change t < 1 / 4 ∨ 3 / 4 < t
+    exact not_and_or.mp ht |>.imp lt_of_not_ge lt_of_not_ge
+  obtain ⟨f, hf, hrel⟩ :=
+    ManifoldSmoothing.exists_smooth_map_homotopicRel_of_smooth_off_compact g
+      CompactIccSpace.isCompact_Icc hC hU hCU hgU (hgU.mono hKU)
+  refine ⟨f, hf, ?_, ?_⟩
+  · intro t ht
+    change t ≤ 1 / 8 at ht
+    exact
+      (hrel.fst_eq_snd (Or.inl ht)).symm.trans
+        (hgleft (show t ∈ Set.Iic (1 / 4 : ℝ) from by change t ≤ 1 / 4; linarith))
+  · intro t ht
+    change 7 / 8 ≤ t at ht
+    exact
+      (hrel.fst_eq_snd (Or.inr ht)).symm.trans
+        (hgright (show t ∈ Set.Ici (3 / 4 : ℝ) from by change 3 / 4 ≤ t; linarith))
+
+private theorem Smale.ManifoldImmersion.exists_clean_curve_endpoint_neighborhood {G H N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] [T2Space N] {f : ℝ → N} (hf : ContMDiff 𝓘(ℝ, ℝ) J ∞ f) (hxy : f 0 ≠ f 1)
+    (hi0 : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J f 0))
+    (hi1 : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J f 1)) {S : Set N} (hS : S.Finite) :
+    ∃ C : Set ℝ,
+      IsCompact C ∧
+        {(0 : ℝ), 1} ⊆ interior C ∧
+          Set.InjOn f C ∧
+            (∀ t ∈ C, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J f t)) ∧
+              (∀ t ∈ C, t ∉ ({0, 1} : Set ℝ) → f t ∉ S) := by
+  let B : Set ℝ := {0, 1}
+  have hB : IsCompact B := ((Set.finite_singleton (1 : ℝ)).insert 0).isCompact
+  have h0B : (0 : ℝ) ∈ B := by simp [B]
+  have h1B : (1 : ℝ) ∈ B := by simp [B]
+  have hinjB : Set.InjOn f B := by
+    intro s hs t ht heq
+    simp only [B, Set.mem_insert_iff, Set.mem_singleton_iff] at hs ht
+    rcases hs with rfl | rfl <;> rcases ht with rfl | rfl
+    · rfl
+    · exact (hxy heq).elim
+    · exact (hxy heq.symm).elim
+    · rfl
+  have hiB : ∀ t ∈ B, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J f t) := by
+    intro t ht
+    simp only [B, Set.mem_insert_iff, Set.mem_singleton_iff] at ht
+    rcases ht with rfl | rfl
+    · exact hi0
+    · exact hi1
+  obtain ⟨V, hV, hBV, hinjV⟩ := exists_open_injOn_near_compact hf hB hinjB hiB
+  let R := S \ {f 0, f 1}
+  have hR : IsClosed R := (hS.subset Set.sdiff_subset).isClosed
+  let U := (V ∩ {t | Function.Injective (mfderiv 𝓘(ℝ, ℝ) J f t)}) ∩ f ⁻¹' Rᶜ
+  have hU : IsOpen U :=
+    (hV.inter (isOpen_injective_derivative hf)).inter (hR.isOpen_compl.preimage hf.continuous)
+  have hBU : B ⊆ U := by
+    intro t ht
+    refine ⟨⟨hBV ht, hiB t ht⟩, ?_⟩
+    simp only [B, Set.mem_insert_iff, Set.mem_singleton_iff] at ht
+    rcases ht with rfl | rfl <;> simp [R]
+  obtain ⟨C, hC, hBC, hCU⟩ := exists_compact_between hB hU hBU
+  refine ⟨C, hC, hBC, hinjV.mono (fun t ht => (hCU ht).1.1), fun t ht => (hCU ht).1.2, ?_⟩
+  intro t ht htB htS
+  apply (hCU ht).2
+  refine ⟨htS, ?_⟩
+  intro hends
+  simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hends
+  rcases hends with h0 | h1
+  · have ht0 : t = 0 := hinjV (hCU ht).1.1 (hBV h0B) h0
+    exact htB (by simp [ht0])
+  · have ht1 : t = 1 := hinjV (hCU ht).1.1 (hBV h1B) h1
+    exact htB (by simp [ht1])
+
+private def
+    Smale.WeightedPerturbation.perturb {E F : Type*} [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (f : E → F) (β : E → ℝ) (a : F) (x : E) : F :=
+  f x + β x • a
+
+private theorem Smale.WeightedPerturbation.contDiff_perturb {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F} {β : E → ℝ}
+    (hf : ContDiff ℝ ∞ f) (hβ : ContDiff ℝ ∞ β) (a : F) : ContDiff ℝ ∞ (perturb f β a) :=
+  hf.add (hβ.smul contDiff_const)
+
+private theorem Smale.WeightedPerturbation.fderiv_perturb {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F} {β : E → ℝ}
+    (hf : ContDiff ℝ ∞ f) (hβ : ContDiff ℝ ∞ β) (a : F) (x : E) :
+    fderiv ℝ (perturb f β a) x = fderiv ℝ f x + (fderiv ℝ β x).smulRight a :=
+  ((hf.differentiable (by simp) x).hasFDerivAt.add
+      ((hβ.differentiable (by simp) x).hasFDerivAt.smul_const a)).fderiv
+
+private def
+    Smale.WeightedPerturbation.badDomain {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    {X : Type*} (b : X → E) (β : E → ℝ) : Set (X × E) :=
+  {q | fderiv ℝ β (b q.1) q.2 ≠ 0}
+
+private def
+    Smale.WeightedPerturbation.badParameter {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] {X : Type*} (b : X → E) (f : E → F) (β : E → ℝ)
+    (q : X × E) : F :=
+  (fderiv ℝ β (b q.1) q.2)⁻¹ • (-(fderiv ℝ f (b q.1) q.2))
+
+private theorem
+    Smale.WeightedPerturbation.contMDiff_scalarDerivative {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {B H X : Type*} [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ B H} [TopologicalSpace X] [ChartedSpace H X]
+    {b : X → E} {β : E → ℝ} (hb : ContMDiff I 𝓘(ℝ, E) ∞ b) (hβ : ContDiff ℝ ∞ β) :
+    ContMDiff (I.prod 𝓘(ℝ, E)) 𝓘(ℝ, ℝ) ∞ (fun q : X × E => fderiv ℝ β (b q.1) q.2) :=
+  ((hβ.fderiv_right (by simp)).contMDiff.comp (hb.comp contMDiff_fst)).clm_apply contMDiff_snd
+
+private theorem Smale.WeightedPerturbation.isOpen_badDomain {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {B H X : Type*} [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ B H} [TopologicalSpace X] [ChartedSpace H X]
+    {b : X → E} {β : E → ℝ} (hb : ContMDiff I 𝓘(ℝ, E) ∞ b) (hβ : ContDiff ℝ ∞ β) :
+    IsOpen (badDomain b β) :=
+  isOpen_ne_fun (contMDiff_scalarDerivative hb hβ).continuous continuous_const
+
+private theorem
+    Smale.WeightedPerturbation.contMDiffOn_badParameter {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {B H X : Type*}
+    [NormedAddCommGroup B] [NormedSpace ℝ B] [TopologicalSpace H] {I : ModelWithCorners ℝ B H}
+    [TopologicalSpace X] [ChartedSpace H X] {b : X → E} {f : E → F} {β : E → ℝ}
+    (hb : ContMDiff I 𝓘(ℝ, E) ∞ b) (hf : ContDiff ℝ ∞ f) (hβ : ContDiff ℝ ∞ β) :
+    ContMDiffOn (I.prod 𝓘(ℝ, E)) 𝓘(ℝ, F) ∞ (badParameter b f β) (badDomain b β) := by
+  have hdf : ContMDiff (I.prod 𝓘(ℝ, E)) 𝓘(ℝ, F) ∞ (fun q : X × E => fderiv ℝ f (b q.1) q.2) :=
+    ((hf.fderiv_right (by simp)).contMDiff.comp (hb.comp contMDiff_fst)).clm_apply contMDiff_snd
+  intro q hq
+  exact
+    (((contMDiff_scalarDerivative hb hβ).contMDiffAt.inv₀ hq).smul
+        hdf.contMDiffAt.neg).contMDiffWithinAt
+
+private theorem
+    Smale.WeightedPerturbation.kernel_iff_of_not_bad {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {X : Type*} {b : X → E} {f : E → F}
+    {β : E → ℝ} (hf : ContDiff ℝ ∞ f) (hβ : ContDiff ℝ ∞ β) {a : F}
+    (hgood : a ∉ badParameter b f β '' badDomain b β) (x : X) (v : E) :
+    fderiv ℝ (perturb f β a) (b x) v = 0 ↔ fderiv ℝ f (b x) v = 0 ∧ fderiv ℝ β (b x) v = 0 := by
+  rw [fderiv_perturb hf hβ]
+  change fderiv ℝ f (b x) v + fderiv ℝ β (b x) v • a = 0 ↔ _
+  constructor
+  · intro hker
+    have hbzero : fderiv ℝ β (b x) v = 0 := by
+      by_contra hn
+      apply hgood
+      refine ⟨(x, v), hn, ?_⟩
+      have heq : fderiv ℝ β (b x) v • a = -(fderiv ℝ f (b x) v) :=
+        eq_neg_of_add_eq_zero_right hker
+      change (fderiv ℝ β (b x) v)⁻¹ • (-(fderiv ℝ f (b x) v)) = a
+      rw [← heq, inv_smul_smul₀ hn]
+    exact ⟨by simpa only [hbzero, zero_smul, add_zero] using hker, hbzero⟩
+  · rintro ⟨hfzero, hbzero⟩
+    simp only [hfzero, hbzero, zero_smul, add_zero]
+
+private theorem Smale.WeightedPerturbation.exists_small_parameter_with_common_kernel {E F : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    {B H X : Type*} [NormedAddCommGroup B] [NormedSpace ℝ B] [TopologicalSpace H]
+    {I : ModelWithCorners ℝ B H} [TopologicalSpace X] [ChartedSpace H X] [FiniteDimensional ℝ B]
+    [FiniteDimensional ℝ E] [FiniteDimensional ℝ F] [IsManifold I ∞ X] [LindelofSpace (X × E)]
+    {b : X → E} {f : E → F} {β : E → ℝ} (hb : ContMDiff I 𝓘(ℝ, E) ∞ b) (hf : ContDiff ℝ ∞ f)
+    (hβ : ContDiff ℝ ∞ β) (hdim : Module.finrank ℝ B + Module.finrank ℝ E < Module.finrank ℝ F)
+    {ε : ℝ} (hε : 0 < ε) :
+    ∃ a : F,
+      ‖a‖ < ε ∧
+        ContDiff ℝ ∞ (perturb f β a) ∧
+          ∀ x v,
+            fderiv ℝ (perturb f β a) (b x) v = 0 ↔
+              fderiv ℝ f (b x) v = 0 ∧ fderiv ℝ β (b x) v = 0 := by
+  have hd : Module.finrank ℝ (B × E) < Module.finrank ℝ F := by
+    simpa only [Module.finrank_prod] using hdim
+  have hdense :=
+    Smale.GeneralPosition.dense_compl_manifold_image (isOpen_badDomain hb hβ)
+      (contMDiffOn_badParameter hb hf hβ) hd
+  obtain ⟨a, hgood, hnorm⟩ := hdense.exists_dist_lt 0 hε
+  exact
+    ⟨a, by simpa only [dist_zero_left] using hnorm, contDiff_perturb hf hβ a,
+      kernel_iff_of_not_bad hf hβ hgood⟩
+
+private def
+    Smale.CurveImmersion.perturb {F : Type*} [NormedAddCommGroup F] [NormedSpace ℝ F] (f : ℝ → F)
+    (a : F) : ℝ → F :=
+  Smale.WeightedPerturbation.perturb f id a
+
+private theorem
+    Smale.CurveImmersion.exists_small_affine_immersion {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [FiniteDimensional ℝ F] {f : ℝ → F} (hf : ContDiff ℝ ∞ f)
+    (hdim : 3 ≤ Module.finrank ℝ F) {ε : ℝ} (hε : 0 < ε) :
+    ∃ a : F,
+      ‖a‖ < ε ∧ ContDiff ℝ ∞ (perturb f a) ∧ ∀ t, Function.Injective (fderiv ℝ (perturb f a) t) :=
+  by
+  have hd : Module.finrank ℝ ℝ + Module.finrank ℝ ℝ < Module.finrank ℝ F := by
+    simp only [Module.finrank_self]
+    omega
+  obtain ⟨a, ha, hs, hker⟩ :=
+    Smale.WeightedPerturbation.exists_small_parameter_with_common_kernel (I := 𝓘(ℝ, ℝ)) (b := id)
+      (β := id) contMDiff_id hf contDiff_id hd hε
+  refine ⟨a, ha, hs, ?_⟩
+  intro t u v huv
+  have hz : fderiv ℝ (perturb f a) t (u - v) = 0 := by rw [map_sub, huv, sub_self]
+  have hzero := ((hker t (u - v)).mp hz).2
+  have huv0 : u - v = 0 := by simpa only [fderiv_id, ContinuousLinearMap.id_apply] using hzero
+  exact sub_eq_zero.mp huv0
+
+private def Smale.CurveImmersion.weight (β : ℝ → ℝ) (t : ℝ) : ℝ :=
+  β t * t
+
+private theorem Smale.CurveImmersion.contDiff_weight {β : ℝ → ℝ} (hβ : ContDiff ℝ ∞ β) :
+    ContDiff ℝ ∞ (weight β) :=
+  hβ.mul contDiff_id
+
+private theorem
+    Smale.CurveImmersion.hasCompactSupport_weight {β : ℝ → ℝ} (hβ : HasCompactSupport β) :
+    HasCompactSupport (weight β) :=
+  hβ.mul_right (f' := id)
+
+private theorem Smale.CurveImmersion.tsupport_weight_subset (β : ℝ → ℝ) :
+    tsupport (weight β) ⊆ tsupport β :=
+  tsupport_mul_subset_left (f := β) (g := id)
+
+private theorem
+    Smale.CurveImmersion.weight_eq_zero {β : ℝ → ℝ} {t : ℝ} (ht : β t = 0) : weight β t = 0 :=
+  by simp only [weight, ht, MulZeroClass.zero_mul]
+
+private theorem Smale.ManifoldImmersion.exists_curve_immersion_patch_with_property_within_target
+    {G F H N : Type*} [NormedAddCommGroup G] [NormedSpace ℝ G] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [FiniteDimensional ℝ F] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [TopologicalSpace N] [ChartedSpace H N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : C(ℝ, N))
+    (hf : ContMDiff 𝓘(ℝ, ℝ) J ∞ f) {β χ : ℝ → ℝ} (hβ : ContDiff ℝ ∞ β) (hχ : ContDiff ℝ ∞ χ)
+    (hcompact : HasCompactSupport β) (hχsupport : tsupport χ ⊆ f ⁻¹' c.source)
+    (hχone : ∀ t ∈ tsupport β, χ t = 1) (hdim : 3 ≤ Module.finrank ℝ F) (Q : (ℝ → N) → Prop)
+    (hQ :
+      ∀ᶠ a : F in 𝓝 0,
+        Q (Smale.ChartMapPerturbation.perturb c f (Smale.CurveImmersion.weight β) a))
+    {D : Set ℝ} {O : Set N} (hsource : c.source ⊆ O) (hmaps : Set.MapsTo f D O) :
+    ∃ g : C(ℝ, N),
+      ContMDiff 𝓘(ℝ, ℝ) J ∞ g ∧
+        Q g ∧
+          Smale.HomotopicRelWithin f g {t | β t = 0} D O ∧
+            ∀ t ∈ interior {t | β t = 1}, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J g t) := by
+  have hsupport : tsupport β ⊆ f ⁻¹' c.source := by
+    intro t ht
+    exact hχsupport (subset_tsupport χ (by change χ t ≠ 0; rw [hχone t ht]; norm_num))
+  have hw := Smale.CurveImmersion.contDiff_weight hβ
+  have hwsupport : tsupport (Smale.CurveImmersion.weight β) ⊆ f ⁻¹' c.source :=
+    (Smale.CurveImmersion.tsupport_weight_subset β).trans hsupport
+  let k := Smale.ChartMapPerturbation.cutoffCoordinates c f χ
+  have hk : ContDiff ℝ ∞ k := by
+    have hm : ContMDiff 𝓘(ℝ, ℝ) 𝓘(ℝ, F) ∞ k := fun t =>
+      Smale.ChartMapPerturbation.contMDiffAt_cutoffCoordinates c hχsupport hf.contMDiffAt
+        hχ.contMDiff.contMDiffAt
+    exact hm.contDiff
+  obtain ⟨ε, hε, hvalid⟩ :=
+    Smale.ChartMapPerturbation.exists_radius_valid c hf hw.contMDiff
+      (Smale.CurveImmersion.hasCompactSupport_weight hcompact) hwsupport
+  obtain ⟨δ, hδ, hδkeep⟩ := Metric.mem_nhds_iff.mp hQ
+  obtain ⟨a, ha, -, hderiv⟩ :=
+    Smale.CurveImmersion.exists_small_affine_immersion hk hdim (lt_min hε hδ)
+  have haε : ‖a‖ < ε := ha.trans_le (min_le_left _ _)
+  have hv := hvalid a haε
+  have hsmooth := Smale.ChartMapPerturbation.contMDiff_perturb c hf hw.contMDiff hwsupport hv
+  let g : C(ℝ, N) :=
+    ⟨Smale.ChartMapPerturbation.perturb c f (Smale.CurveImmersion.weight β) a, hsmooth.continuous⟩
+  have hcoord (t : ℝ) (ht : β t = 1) : c (g t) = Smale.CurveImmersion.perturb k a t := by
+    have hts : t ∈ tsupport β := subset_tsupport β (by change β t ≠ 0; rw [ht]; norm_num)
+    change c (Smale.ChartMapPerturbation.perturb c f (Smale.CurveImmersion.weight β) a t) = _
+    rw [Smale.ChartMapPerturbation.chart_perturb c f (Smale.CurveImmersion.weight β) hv
+        (hsupport hts)]
+    simp only [Smale.ChartMapPerturbation.coordinateFamily, Smale.CurveImmersion.perturb,
+      Smale.WeightedPerturbation.perturb, k, Smale.ChartMapPerturbation.cutoffCoordinates,
+      Smale.CurveImmersion.weight, ht, hχone t hts, one_mul, one_smul, id_eq]
+  have hQg : Q g :=
+    hδkeep
+      (show a ∈ Metric.ball 0 δ by
+        simpa only [Metric.mem_ball, dist_zero_right] using ha.trans_le (min_le_right ε δ))
+  refine ⟨g, hsmooth, hQg, ?_, ?_⟩
+  · have hrel :=
+      Smale.ChartMapPerturbation.homotopicRelWithin_of_source_subset c hf hw.contMDiff hwsupport
+        hvalid haε hsource hmaps
+    exact
+      hrel.mono (fun _ hx => Smale.CurveImmersion.weight_eq_zero hx) (Set.Subset.refl D)
+        (Set.Subset.refl O)
+  · intro t ht
+    have hβt : β t = 1 := interior_subset (s := {t | β t = 1}) ht
+    have hfs : f t ∈ c.source :=
+      hsupport (subset_tsupport β (by change β t ≠ 0; rw [hβt]; norm_num))
+    have hgs : g t ∈ c.source :=
+      Smale.ChartMapPerturbation.perturb_mem_source c f (Smale.CurveImmersion.weight β) hv hfs
+    apply (injective_fderiv_chart_iff c (hsmooth.mdifferentiableAt (by simp)) hgs).mp
+    have heq : (c ∘ g) =ᶠ[𝓝 t] Smale.CurveImmersion.perturb k a := by
+      filter_upwards [isOpen_interior.mem_nhds ht] with s hs
+      exact hcoord s (interior_subset (s := {t | β t = 1}) hs)
+    change Function.Injective (fderiv ℝ (c ∘ g) t)
+    rw [heq.fderiv_eq]
+    exact hderiv t
+
+private theorem
+    Smale.ManifoldImmersion.exists_curve_immersion_patch_step_within_target {G H N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] {ι : Type*} [Finite ι]
+    (p : ι → Smale.ManifoldSmoothing.MapSmoothingPatch 𝓘(ℝ, ℝ) J (X := ℝ) (N := N)) (i : ι)
+    (f : C(ℝ, N)) (hf : ContMDiff 𝓘(ℝ, ℝ) J ∞ f) (hcompatible : ∀ j, (p j).Compatible f)
+    (hdim : 3 ≤ Module.finrank ℝ G) {K L C : Set ℝ} (hK : IsCompact K)
+    (hinj : ∀ t ∈ K, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J f t)) (hLsub : L ⊆ (p i).plateau)
+    (hfixed : ∀ t ∈ C, (p i).cutoff t = 0) {D : Set ℝ} {O : Set N}
+    (hsource : (p i).chart.source ⊆ O) (hmaps : Set.MapsTo f D O) :
+    ∃ g : C(ℝ, N),
+      ContMDiff 𝓘(ℝ, ℝ) J ∞ g ∧
+        (∀ j, (p j).Compatible g) ∧
+          Smale.HomotopicRelWithin f g C D O ∧
+            ∀ t ∈ K ∪ L, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J g t) := by
+  let w := Smale.CurveImmersion.weight (p i).cutoff
+  have hw : ContMDiff 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) ∞ w :=
+    (Smale.CurveImmersion.contDiff_weight (p i).smooth.contDiff).contMDiff
+  have hinner := (p i).inner_compatible (hcompatible i)
+  have hwsupport : tsupport w ⊆ f ⁻¹' (p i).chart.source :=
+    (Smale.CurveImmersion.tsupport_weight_subset (p i).cutoff).trans hinner
+  have hkeep :
+    ∀ᶠ a : G in 𝓝 0,
+      ∀ j, (p j).Compatible (Smale.ChartMapPerturbation.perturb (p i).chart f w a) := by
+    apply Filter.eventually_all.mpr
+    intro j
+    exact
+      Smale.ChartMapPerturbation.eventually_maps_compact_into_open (p i).chart hf hw hwsupport
+        (p j).outer_compact.isCompact (p j).chart.open_source (hcompatible j)
+  have hold :=
+    Smale.ChartMapPerturbation.eventually_perturb_injective_derivative (p i).chart hf hw
+      (Smale.CurveImmersion.hasCompactSupport_weight (p i).compact) hwsupport hK hinj
+  let Q : (ℝ → N) → Prop := fun g =>
+    (∀ j, (p j).Compatible g) ∧ ∀ t ∈ K, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J g t)
+  have hQ : ∀ᶠ a : G in 𝓝 0, Q (Smale.ChartMapPerturbation.perturb (p i).chart f w a) :=
+    hkeep.and hold
+  obtain ⟨g, hg, ⟨hc, hKnew⟩, hrel, hplateau⟩ :=
+    exists_curve_immersion_patch_with_property_within_target (p i).chart f hf
+      (p i).smooth.contDiff (p i).outer_smooth.contDiff (p i).compact (hcompatible i) (p i).nested
+      hdim Q hQ hsource hmaps
+  refine ⟨g, hg, hc, ?_, ?_⟩
+  · exact hrel.mono hfixed (Set.Subset.refl D) (Set.Subset.refl O)
+  · intro t ht
+    rcases ht with ht | ht
+    · exact hKnew t ht
+    · exact hplateau t (hLsub ht)
+
+private theorem
+    Smale.ManifoldImmersion.exists_finite_curve_patch_immersion_within_target {G H N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] {ι : Type*} [Finite ι]
+    (p : ι → Smale.ManifoldSmoothing.MapSmoothingPatch 𝓘(ℝ, ℝ) J (X := ℝ) (N := N))
+    (L : ι → Set ℝ) (hL : ∀ i, IsCompact (L i)) (hLsub : ∀ i, L i ⊆ (p i).plateau) (f : C(ℝ, N))
+    (hf : ContMDiff 𝓘(ℝ, ℝ) J ∞ f) (hcompatible : ∀ i, (p i).Compatible f)
+    (hdim : 3 ≤ Module.finrank ℝ G) {K C : Set ℝ} (hK : IsCompact K)
+    (hinj : ∀ t ∈ K, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J f t))
+    (hfixed : ∀ i t, t ∈ C → (p i).cutoff t = 0) {D : Set ℝ} {O : Set N}
+    (hsource : ∀ i, (p i).chart.source ⊆ O) (hmaps : Set.MapsTo f D O) (s : Finset ι) :
+    ∃ g : C(ℝ, N),
+      ContMDiff 𝓘(ℝ, ℝ) J ∞ g ∧
+        (∀ i, (p i).Compatible g) ∧
+          Smale.HomotopicRelWithin f g C D O ∧
+            ∀ t ∈ K ∪ ⋃ i ∈ s, L i, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J g t) := by
+  classical
+    induction s using Finset.induction_on with
+  | empty =>
+    refine ⟨f, hf, hcompatible, Smale.HomotopicRelWithin.refl f C hmaps, ?_⟩
+    simpa only [Finset.notMem_empty, Set.iUnion_of_empty, Set.iUnion_empty, Set.union_empty] using
+      hinj
+  | @insert i s _ ih =>
+    obtain ⟨g₁, hg₁, hc₁, hhom₁, hinj₁⟩ := ih
+    have hKold : IsCompact (K ∪ ⋃ j ∈ s, L j) := hK.union (s.isCompact_biUnion (fun j _ => hL j))
+    obtain ⟨g₂, hg₂, hc₂, hhom₂, hinj₂⟩ :=
+      exists_curve_immersion_patch_step_within_target p i g₁ hg₁ hc₁ hdim hKold hinj₁ (hLsub i)
+        (hfixed i) (hsource i) hhom₁.mapsTo_right
+    refine ⟨g₂, hg₂, hc₂, hhom₁.trans hhom₂, ?_⟩
+    intro t ht
+    apply hinj₂ t
+    rcases ht with ht | ht
+    · exact Or.inl (Or.inl ht)
+    · obtain ⟨j, hj, htj⟩ := Set.mem_iUnion₂.mp ht
+      rcases Finset.mem_insert.mp hj with rfl | hjs
+      · exact Or.inr htj
+      · exact Or.inl (Or.inr (Set.mem_iUnion₂.mpr ⟨j, hjs, htj⟩))
+
+private theorem Smale.ManifoldImmersion.exists_curve_immersion_on_compact_rel_within_target
+    {G H N : Type*} [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N]
+    [ChartedSpace H N] [IsManifold J ∞ N] (f : C(ℝ, N)) (hf : ContMDiff 𝓘(ℝ, ℝ) J ∞ f)
+    (hdim : 3 ≤ Module.finrank ℝ G) {K L C : Set ℝ} (hK : IsCompact K) (hL : IsCompact L)
+    (hinj : ∀ t ∈ K, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J f t)) (hC : IsClosed C)
+    (hdis : Disjoint L C) {D : Set ℝ} {O : Set N} (hO : IsOpen O) (hLO : Set.MapsTo f L O)
+    (hmaps : Set.MapsTo f D O) :
+    ∃ g : C(ℝ, N),
+      ContMDiff 𝓘(ℝ, ℝ) J ∞ g ∧
+        Smale.HomotopicRelWithin f g C D O ∧
+          ∀ t ∈ K ∪ L, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J g t) := by
+  classical
+  have hp (t : L) :=
+    exists_relative_immersion_patch_at_in_open (J := J) f hC
+      (show (t : ℝ) ∉ C from fun ht => Set.disjoint_left.mp hdis t.property ht) hO
+      (hLO t.property)
+  choose p T hcompatible hT hn hsub hfixed hsource using hp
+  have hcover : L ⊆ ⋃ t : L, interior (T t) := by
+    intro t ht
+    exact Set.mem_iUnion.mpr ⟨⟨t, ht⟩, mem_interior_iff_mem_nhds.mpr (hn ⟨t, ht⟩)⟩
+  obtain ⟨s, hs⟩ :=
+    hL.elim_finite_subcover (fun t : L => interior (T t)) (fun _ => isOpen_interior) hcover
+  obtain ⟨g, hg, -, hhom, hderiv⟩ :=
+    exists_finite_curve_patch_immersion_within_target (fun i : s => p i.1) (fun i : s => T i.1)
+      (fun i => hT i.1) (fun i => hsub i.1) f hf (fun i => hcompatible i.1) hdim hK hinj
+      (fun i => hfixed i.1) (fun i => hsource i.1) hmaps Finset.univ
+  refine ⟨g, hg, hhom, ?_⟩
+  intro t ht
+  apply hderiv t
+  rcases ht with ht | ht
+  · exact Or.inl ht
+  · obtain ⟨i, his, hti⟩ := Set.mem_iUnion₂.mp (hs ht)
+    exact Or.inr (Set.mem_iUnion₂.mpr ⟨⟨i, his⟩, Finset.mem_univ _, interior_subset hti⟩)
+
+private theorem Smale.ManifoldImmersion.exists_relative_compact_curve_embedding_within_target
+    {G H N : Type*} [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N]
+    [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N] (f : C(ℝ, N)) (hf : ContMDiff 𝓘(ℝ, ℝ) J ∞ f)
+    (hdim : 3 ≤ Module.finrank ℝ G) {K C : Set ℝ} (hK : IsCompact K) (hC : IsClosed C)
+    (hfixed : Set.InjOn f (K ∩ C))
+    (hderiv : ∀ t ∈ K ∩ C, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J f t)) {O : Set N} (hO : IsOpen O)
+    (hmaps : Set.MapsTo f (K \ C) O) :
+    ∃ g : C(ℝ, N),
+      ContMDiff 𝓘(ℝ, ℝ) J ∞ g ∧
+        Smale.HomotopicRelWithin f g C (K \ C) O ∧
+          Topology.IsClosedEmbedding (fun t : K => g t) ∧
+            ∀ t ∈ K, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J g t) := by
+  let U : Set ℝ := {t | Function.Injective (mfderiv 𝓘(ℝ, ℝ) J f t)}
+  have hU : IsOpen U := isOpen_injective_derivative hf
+  have hCU : K ∩ C ⊆ U := fun t ht => hderiv t ht
+  obtain ⟨D, hD, hCD, hDU⟩ := exists_compact_between (hK.inter_right hC) hU hCU
+  let L := K \ interior D
+  have hL : IsCompact L := hK.inter_right isOpen_interior.isClosed_compl
+  have hdis : Disjoint L C := Set.disjoint_left.mpr (fun _ ht htC => ht.2 (hCD ⟨ht.1, htC⟩))
+  have hLO : Set.MapsTo f L O := fun t ht => hmaps ⟨ht.1, fun htC => ht.2 (hCD ⟨ht.1, htC⟩)⟩
+  obtain ⟨g₁, hg₁, hhom₁, hinj₁⟩ :=
+    exists_curve_immersion_on_compact_rel_within_target f hf hdim hD hL (fun t ht => hDU ht) hC
+      hdis hO hLO hmaps
+  have hKinj : ∀ t ∈ K, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J g₁ t) := by
+    intro t ht
+    apply hinj₁ t
+    by_cases htD : t ∈ D
+    · exact Or.inl htD
+    · exact Or.inr ⟨ht, fun hi => htD (interior_subset hi)⟩
+  have hfixed₁ : Set.InjOn g₁ (K ∩ C) := by
+    intro t ht s hs hts
+    apply hfixed ht hs
+    rw [hhom₁.homotopicRel.fst_eq_snd ht.2, hhom₁.homotopicRel.fst_eq_snd hs.2]
+    exact hts
+  have hd : 2 * Module.finrank ℝ ℝ < Module.finrank ℝ G := by
+    simp only [Module.finrank_self]
+    omega
+  obtain ⟨g₂, hg₂, hhom₂, hemb, hinj₂⟩ :=
+    exists_compact_embedding_of_immersion_within_target g₁ hg₁ hd hK hKinj hC hfixed₁ hO
+      hhom₁.mapsTo_right
+  exact ⟨g₂, hg₂, hhom₁.trans hhom₂, hemb, hinj₂⟩
+
+private theorem Smale.ManifoldImmersion.exists_relative_compact_curve_embedding {G H N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] [T2Space N] (f : C(ℝ, N)) (hf : ContMDiff 𝓘(ℝ, ℝ) J ∞ f)
+    (hdim : 3 ≤ Module.finrank ℝ G) {K C : Set ℝ} (hK : IsCompact K) (hC : IsClosed C)
+    (hfixed : Set.InjOn f (K ∩ C))
+    (hderiv : ∀ t ∈ K ∩ C, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J f t)) :
+    ∃ g : C(ℝ, N),
+      ContMDiff 𝓘(ℝ, ℝ) J ∞ g ∧
+        f.HomotopicRel g C ∧
+          Topology.IsClosedEmbedding (fun t : K => g t) ∧
+            ∀ t ∈ K, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J g t) := by
+  obtain ⟨g, hg, hrel, he, hi⟩ :=
+    exists_relative_compact_curve_embedding_within_target f hf hdim hK hC hfixed hderiv
+      isOpen_univ (Set.mapsTo_univ f (K \ C))
+  exact ⟨g, hg, hrel.homotopicRel, he, hi⟩
+
+private theorem Smale.ManifoldImmersion.exists_relative_curve_avoidance_of_clean_neighborhood
+    {G H N : Type*} [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G]
+    [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N]
+    [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N] {F H' Y : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [FiniteDimensional ℝ F] [TopologicalSpace H'] {I' : ModelWithCorners ℝ F H'}
+    [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y] [CompactSpace Y]
+    [LindelofSpace (ℝ × Y)] (f : C(ℝ, N)) (g : C(Y, N)) (hf : ContMDiff 𝓘(ℝ, ℝ) J ∞ f)
+    (hg : ContMDiff I' J ∞ g) (hdim : 3 ≤ Module.finrank ℝ G)
+    (hobstacle : 1 + Module.finrank ℝ F < Module.finrank ℝ G) {K C B : Set ℝ} (hK : IsCompact K)
+    (hC : IsClosed C) (hBC : B ⊆ interior C) (hfixed : Set.InjOn f (K ∩ C))
+    (hderiv : ∀ t ∈ K ∩ C, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J f t))
+    (hclean : ∀ t ∈ K ∩ C, t ∉ B → f t ∉ Set.range g) :
+    ∃ f' : C(ℝ, N),
+      ContMDiff 𝓘(ℝ, ℝ) J ∞ f' ∧
+        f.HomotopicRel f' C ∧
+          Topology.IsClosedEmbedding (fun t : K => f' t) ∧
+            (∀ t ∈ K, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J f' t)) ∧
+              ∀ t ∈ K \ B, f' t ∉ Set.range g := by
+  obtain ⟨f₁, hf₁, hhom₁, hemb₁, hderiv₁⟩ :=
+    exists_relative_compact_curve_embedding f hf hdim hK hC hfixed hderiv
+  have hinj₁ : Set.InjOn f₁ K := by
+    intro t ht s hs hts
+    exact congrArg Subtype.val (hemb₁.injective (a₁ := ⟨t, ht⟩) (a₂ := ⟨s, hs⟩) hts)
+  have hclean₁ : ∀ t ∈ K ∩ C, t ∉ B → f₁ t ∉ Set.range g := by
+    intro t ht htB
+    rw [← hhom₁.fst_eq_snd ht.2]
+    exact hclean t ht htB
+  have hself : 2 * Module.finrank ℝ ℝ < Module.finrank ℝ G := by
+    simp only [Module.finrank_self]
+    omega
+  have hobs : Module.finrank ℝ ℝ + Module.finrank ℝ F < Module.finrank ℝ G := by
+    simpa only [Module.finrank_self] using hobstacle
+  obtain ⟨f₂, hf₂, hhom₂, hemb₂, hderiv₂, havoid⟩ :=
+    exists_embedded_avoidance_relative_neighborhood f₁ g hf₁ hg hself hobs hK hC hBC hinj₁ hderiv₁
+      hclean₁
+  exact ⟨f₂, hf₂, hhom₁.trans hhom₂, hemb₂, hderiv₂, havoid⟩
+
+private theorem Smale.ManifoldImmersion.exists_relative_curve_avoiding_finite {G H N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] [T2Space N] (f : C(ℝ, N)) (hf : ContMDiff 𝓘(ℝ, ℝ) J ∞ f)
+    (hdim : 3 ≤ Module.finrank ℝ G) {S : Set N} (hS : S.Finite) {K C B : Set ℝ} (hK : IsCompact K)
+    (hC : IsClosed C) (hBC : B ⊆ interior C) (hfixed : Set.InjOn f (K ∩ C))
+    (hderiv : ∀ t ∈ K ∩ C, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J f t))
+    (hclean : ∀ t ∈ K ∩ C, t ∉ B → f t ∉ S) :
+    ∃ f' : C(ℝ, N),
+      ContMDiff 𝓘(ℝ, ℝ) J ∞ f' ∧
+        f.HomotopicRel f' C ∧
+          Topology.IsClosedEmbedding (fun t : K => f' t) ∧
+            (∀ t ∈ K, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J f' t)) ∧ ∀ t ∈ K \ B, f' t ∉ S := by
+  let : Fintype S := hS.fintype
+  let Z := EuclideanSpace ℝ (Fin 0)
+  let : ChartedSpace Z S := ChartedSpace.ofDiscreteTopology
+  let : IsManifold 𝓘(ℝ, Z) ∞ S := IsManifold.of_discreteTopology _
+  let g : C(S, N) := ⟨Subtype.val, continuous_subtype_val⟩
+  have hg : ContMDiff 𝓘(ℝ, Z) J ∞ g := contMDiff_of_discreteTopology
+  have hrange : Set.range g = S := by ext y; simp [g]
+  have hobs : 1 + Module.finrank ℝ Z < Module.finrank ℝ G := by
+    simp only [Z, finrank_euclideanSpace_fin]
+    omega
+  have hclean' : ∀ t ∈ K ∩ C, t ∉ B → f t ∉ Set.range g := by simpa only [hrange] using hclean
+  obtain ⟨f', hf', hrel, hemb, hi, havoid⟩ :=
+    exists_relative_curve_avoidance_of_clean_neighborhood f g hf hg hdim hobs hK hC hBC hfixed
+      hderiv hclean'
+  refine ⟨f', hf', hrel, hemb, hi, ?_⟩
+  simpa only [hrange] using havoid
+
+private theorem Smale.exists_embedded_arc_with_endpoint_germs {G H N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N]
+    (a b : C(ℝ, N)) (ha : ContMDiff 𝓘(ℝ, ℝ) J ∞ a) (hb : ContMDiff 𝓘(ℝ, ℝ) J ∞ b)
+    (hia : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J a 0))
+    (hib : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J b 1)) (γ : Path (a 0) (b 1)) (hxy : a 0 ≠ b 1)
+    (hdim : 3 ≤ Module.finrank ℝ G) {S : Set N} (hS : S.Finite) :
+    ∃ f : C(ℝ, N),
+      ContMDiff 𝓘(ℝ, ℝ) J ∞ f ∧
+        (f =ᶠ[𝓝 (0 : ℝ)] a) ∧
+          (f =ᶠ[𝓝 (1 : ℝ)] b) ∧
+            Topology.IsClosedEmbedding (fun t : unitInterval => f t) ∧
+              (∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J f t)) ∧
+                (∀ t ∈ Set.Ioo (0 : ℝ) 1, f t ∉ S) := by
+  obtain ⟨g, hg, hga, hgb⟩ := exists_smooth_curve_with_endpoint_germs a b ha hb γ
+  have hga0 : g =ᶠ[𝓝 (0 : ℝ)] a := by
+    filter_upwards [Iio_mem_nhds (show (0 : ℝ) < 1 / 8 by norm_num)] with t ht
+    change t < 1 / 8 at ht
+    exact hga ht.le
+  have hgb1 : g =ᶠ[𝓝 (1 : ℝ)] b := by
+    filter_upwards [Ioi_mem_nhds (show (7 / 8 : ℝ) < 1 by norm_num)] with t ht
+    change 7 / 8 < t at ht
+    exact hgb ht.le
+  have hgxy : g 0 ≠ g 1 := by
+    rw [hga0.eq_of_nhds, hgb1.eq_of_nhds]
+    exact hxy
+  have hig0 : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J g 0) := by
+    rw [hga0.mfderiv_eq]
+    exact hia
+  have hig1 : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J g 1) := by
+    rw [hgb1.mfderiv_eq]
+    exact hib
+  obtain ⟨C, hC, hBC, hinjC, hiC, hclean⟩ :=
+    ManifoldImmersion.exists_clean_curve_endpoint_neighborhood hg hgxy hig0 hig1 hS
+  obtain ⟨f, hf, hrel, hemb, hi, havoid⟩ :=
+    ManifoldImmersion.exists_relative_curve_avoiding_finite g hg hdim hS
+      (CompactIccSpace.isCompact_Icc (a := (0 : ℝ)) (b := 1)) hC.isClosed hBC
+      (hinjC.mono Set.inter_subset_right) (fun t ht => hiC t ht.2) (fun t ht => hclean t ht.2)
+  have hfg (t : ℝ) (ht : t ∈ ({0, 1} : Set ℝ)) : f =ᶠ[𝓝 t] g := by
+    filter_upwards [isOpen_interior.mem_nhds (hBC ht)] with s hs
+    exact (hrel.fst_eq_snd (interior_subset hs)).symm
+  refine ⟨f, hf, (hfg 0 (by simp)).trans hga0, (hfg 1 (by simp)).trans hgb1, hemb, hi, ?_⟩
+  intro t ht
+  apply havoid t ⟨⟨ht.1.le, ht.2.le⟩, ?_⟩
+  intro htB
+  rcases htB with ht0 | ht1
+  · exact ht.1.ne' ht0
+  · exact ht.2.ne ht1
+
+private theorem Smale.exists_smooth_curve_with_germ_at {G H N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [TopologicalSpace N]
+    [ChartedSpace H N] {a : ℝ → N} {U : Set ℝ} {t₀ : ℝ} (ha : ContMDiffOn 𝓘(ℝ, ℝ) J ∞ a U)
+    (hU : IsOpen U) (ht₀ : t₀ ∈ U) : ∃ f : C(ℝ, N), ContMDiff 𝓘(ℝ, ℝ) J ∞ f ∧ (f =ᶠ[𝓝 t₀] a) := by
+  obtain ⟨f, hf, heq⟩ := exists_smooth_extension_near_point ha hU ht₀
+  exact ⟨⟨f, hf.continuous⟩, hf, heq⟩
+
+private theorem
+    Smale.exists_embedded_arc_with_local_endpoint_germs {G H N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N]
+    {a b : ℝ → N} {U V : Set ℝ} (ha : ContMDiffOn 𝓘(ℝ, ℝ) J ∞ a U)
+    (hb : ContMDiffOn 𝓘(ℝ, ℝ) J ∞ b V) (hU : IsOpen U) (hV : IsOpen V) (h0U : (0 : ℝ) ∈ U)
+    (h1V : (1 : ℝ) ∈ V) (hia : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J a 0))
+    (hib : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J b 1)) (γ : Path (a 0) (b 1)) (hxy : a 0 ≠ b 1)
+    (hdim : 3 ≤ Module.finrank ℝ G) {S : Set N} (hS : S.Finite) :
+    ∃ f : C(ℝ, N),
+      ContMDiff 𝓘(ℝ, ℝ) J ∞ f ∧
+        (f =ᶠ[𝓝 (0 : ℝ)] a) ∧
+          (f =ᶠ[𝓝 (1 : ℝ)] b) ∧
+            Topology.IsClosedEmbedding (fun t : unitInterval => f t) ∧
+              (∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J f t)) ∧
+                (∀ t ∈ Set.Ioo (0 : ℝ) 1, f t ∉ S) := by
+  obtain ⟨a', ha', heqa⟩ := exists_smooth_curve_with_germ_at ha hU h0U
+  obtain ⟨b', hb', heqb⟩ := exists_smooth_curve_with_germ_at hb hV h1V
+  have hia' : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J a' 0) := by
+    rw [heqa.mfderiv_eq]
+    exact hia
+  have hib' : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J b' 1) := by
+    rw [heqb.mfderiv_eq]
+    exact hib
+  have hxy' : a' 0 ≠ b' 1 := by
+    rw [heqa.eq_of_nhds, heqb.eq_of_nhds]
+    exact hxy
+  obtain ⟨f, hf, hfa, hfb, hemb, hi, havoid⟩ :=
+    exists_embedded_arc_with_endpoint_germs a' b' ha' hb' hia' hib'
+      (γ.cast heqa.eq_of_nhds heqb.eq_of_nhds) hxy' hdim hS
+  exact ⟨f, hf, hfa.trans heqa, hfb.trans heqb, hemb, hi, havoid⟩
+
+private theorem MorseCancel.exists_clean_arc_with_local_endpoint_germs {G V H H' N Y : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [FiniteDimensional ℝ V] [TopologicalSpace H] [TopologicalSpace H']
+    {J : ModelWithCorners ℝ G H} {I : ModelWithCorners ℝ V H'} [J.Boundaryless]
+    [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N] [TopologicalSpace Y]
+    [ChartedSpace H' Y] [IsManifold I ∞ Y] [SecondCountableTopology Y] {a b : ℝ → N} {U W : Set ℝ}
+    (ha : ContMDiffOn 𝓘(ℝ, ℝ) J ∞ a U) (hb : ContMDiffOn 𝓘(ℝ, ℝ) J ∞ b W) (hU : IsOpen U)
+    (hW : IsOpen W) (h0U : (0 : ℝ) ∈ U) (h1W : (1 : ℝ) ∈ W)
+    (hia : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J a 0))
+    (hib : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J b 1)) (γ : Path (a 0) (b 1)) (hxy : a 0 ≠ b 1)
+    (hdim : 3 ≤ Module.finrank ℝ G) (o : C(Y, N)) (ho : ContMDiff I J ∞ o)
+    (hclosed : IsClosed (Set.range o)) (hobdim : 1 + Module.finrank ℝ V < Module.finrank ℝ G)
+    (hclean0 : ∀ᶠ t in 𝓝 (0 : ℝ), a t ∈ Set.range o → t = 0)
+    (hclean1 : ∀ᶠ t in 𝓝 (1 : ℝ), b t ∈ Set.range o → t = 1) :
+    ∃ f : C(ℝ, N),
+      ContMDiff 𝓘(ℝ, ℝ) J ∞ f ∧
+        (f =ᶠ[𝓝 (0 : ℝ)] a) ∧
+          (f =ᶠ[𝓝 (1 : ℝ)] b) ∧
+            Topology.IsClosedEmbedding (fun t : unitInterval => f t) ∧
+              (∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J f t)) ∧
+                ∀ t ∈ Set.Ioo (0 : ℝ) 1, f t ∉ Set.range o := by
+  obtain ⟨f, hf, hfa, hfb, hemb, hfd, -⟩ :=
+    Smale.exists_embedded_arc_with_local_endpoint_germs ha hb hU hW h0U h1W hia hib γ hxy hdim
+      (S := ∅) Set.finite_empty
+  have hnear0 : ∀ᶠ t in 𝓝 (0 : ℝ), f t ∈ Set.range o → t = 0 := by
+    filter_upwards [hfa, hclean0] with t he hc
+    rw [he]
+    exact hc
+  have hnear1 : ∀ᶠ t in 𝓝 (1 : ℝ), f t ∈ Set.range o → t = 1 := by
+    filter_upwards [hfb, hclean1] with t he hc
+    rw [he]
+    exact hc
+  obtain ⟨r, hr, hball0⟩ := Metric.nhds_basis_closedBall.mem_iff.mp hnear0
+  obtain ⟨s, hs, hball1⟩ := Metric.nhds_basis_closedBall.mem_iff.mp hnear1
+  let C : Set ℝ := Metric.closedBall 0 r ∪ Metric.closedBall 1 s
+  have h0C : C ∈ 𝓝 (0 : ℝ) :=
+    Filter.mem_of_superset (Metric.ball_mem_nhds 0 hr)
+      (fun _ ht => Or.inl (Metric.ball_subset_closedBall ht))
+  have h1C : C ∈ 𝓝 (1 : ℝ) :=
+    Filter.mem_of_superset (Metric.ball_mem_nhds 1 hs)
+      (fun _ ht => Or.inr (Metric.ball_subset_closedBall ht))
+  have hBC : ({0, 1} : Set ℝ) ⊆ interior C := by
+    intro t ht
+    rcases ht with rfl | ht
+    · exact mem_interior_iff_mem_nhds.mpr h0C
+    · have ht1 : t = 1 := ht
+      subst t
+      exact mem_interior_iff_mem_nhds.mpr h1C
+  have hclean : ∀ t ∈ Set.Icc (0 : ℝ) 1 ∩ C, t ∉ ({0, 1} : Set ℝ) → f t ∉ Set.range o := by
+    intro t ht htB hto
+    rcases ht.2 with ht0 | ht1
+    · exact htB (Or.inl (hball0 ht0 hto))
+    · exact htB (Or.inr (hball1 ht1 hto))
+  have hfi : Set.InjOn f (Set.Icc (0 : ℝ) 1) := by
+    intro x hx y hy he
+    exact congrArg Subtype.val (hemb.injective (a₁ := ⟨x, hx⟩) (a₂ := ⟨y, hy⟩) he)
+  have hself : 2 * Module.finrank ℝ ℝ < Module.finrank ℝ G := by
+    simp only [Module.finrank_self]
+    omega
+  have hobs : Module.finrank ℝ ℝ + Module.finrank ℝ V < Module.finrank ℝ G := by
+    simpa only [Module.finrank_self] using hobdim
+  obtain ⟨g, hg, hrel, hge, hgd, havoid⟩ :=
+    Smale.ManifoldImmersion.exists_embedded_avoidance_relative_neighborhood_of_isClosed_range f o
+      hf ho hclosed hself hobs CompactIccSpace.isCompact_Icc
+      (show IsClosed C from Metric.isClosed_closedBall.union Metric.isClosed_closedBall) hBC hfi
+      hfd hclean
+  refine ⟨g, hg, ?_, ?_, hge, hgd, ?_⟩
+  · filter_upwards [h0C, hfa] with t ht he
+    exact (hrel.fst_eq_snd ht).symm.trans he
+  · filter_upwards [h1C, hfb] with t ht he
+    exact (hrel.fst_eq_snd ht).symm.trans he
+  · intro t ht hto
+    have htB : t ∉ ({0, 1} : Set ℝ) := by
+      simp only [Set.mem_insert_iff, Set.mem_singleton_iff, not_or]
+      exact ⟨ne_of_gt ht.1, ne_of_lt ht.2⟩
+    exact havoid t ⟨⟨ht.1.le, ht.2.le⟩, htB⟩ hto
+
+private theorem
+    Smale.NativeEuclideanEmbedding.exists_smooth_normalFrame_near_starConvex {E M D : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [NormedAddCommGroup D] [InnerProductSpace ℝ D]
+    [FiniteDimensional ℝ D] (e : Smale.NativeEuclideanEmbedding E M) {f : D → M}
+    (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f) {K : Set D} (hK : IsCompact K) (hz : (0 : D) ∈ K)
+    (hstar : StarConvex ℝ (0 : D) K)
+    (hi : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x)) (n : ℕ)
+    (hcodim : Module.finrank ℝ D + n = Module.finrank ℝ E) :
+    ∃ V : Set D,
+      IsOpen V ∧
+        K ⊆ V ∧
+          ∃ A : D → EuclideanSpace ℝ (Fin n) →L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension),
+            ContDiffOn ℝ ∞ A V ∧
+              ∀ x ∈ K, Function.Injective (A x) ∧ (A x).range = e.diskNormalSpace f x := by
+  obtain ⟨U, hU, hKU, hsP, hP⟩ := e.exists_open_diskNormalProjection hf hi
+  have hidem : ∀ x ∈ K, IsIdempotentElem (e.diskNormalProjection f x) := by
+    intro x hx
+    rw [hP x (hKU hx)]
+    exact (e.diskNormalSpace f x).isIdempotentElem_starProjection
+  obtain ⟨V, hV, hKV, A, hA, hAi⟩ :=
+    Smale.DiskFraming.exists_smooth_frame_near_starConvex hK hstar hU hKU
+      (e.diskNormalProjection f) hidem hsP
+  have hr : (e.diskNormalProjection f 0).range = e.diskNormalSpace f 0 := by
+    rw [hP 0 (hKU hz), Submodule.range_starProjection]
+  have hdim : Module.finrank ℝ (e.diskNormalSpace f 0) = n := by
+    have h := e.finrank_diskTangent_add_normal hf (hi 0 hz)
+    omega
+  have hcenter : Module.finrank ℝ (e.diskNormalProjection f 0).range = n :=
+    (congrArg
+          (fun S : Submodule ℝ (EuclideanSpace ℝ (Fin e.ambientDimension)) => Module.finrank ℝ S)
+          hr).trans
+      hdim
+  let φ : EuclideanSpace ℝ (Fin n) ≃L[ℝ] (e.diskNormalProjection f 0).range :=
+    ContinuousLinearEquiv.ofFinrankEq (finrank_euclideanSpace_fin.trans hcenter.symm)
+  refine
+    ⟨V, hV, hKV, fun x => (A x).comp φ.toContinuousLinearMap, hA.clm_comp contDiffOn_const, ?_⟩
+  intro x hx
+  refine ⟨((hAi x hx).1).comp φ.injective, ?_⟩
+  calc
+    ((A x).comp φ.toContinuousLinearMap).range = (A x).range :=
+      LinearMap.range_comp_of_range_eq_top _ (LinearMap.range_eq_top.mpr φ.surjective)
+    _ = (e.diskNormalProjection f x).range := (hAi x hx).2
+    _ = e.diskNormalSpace f x := by rw [hP x (hKU hx), Submodule.range_starProjection]
+
+private theorem Smale.exists_tubularNeighborhood_in_open_of_embedded_starConvex_with_global_zero
+    {E M D : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [NormedAddCommGroup D] [InnerProductSpace ℝ D] [FiniteDimensional ℝ D] {f : D → M}
+    (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f) {K : Set D} (hK : IsCompact K) (hz : (0 : D) ∈ K)
+    (hstar : StarConvex ℝ (0 : D) K) (hinj : Set.InjOn f K)
+    (hi : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x)) (n : ℕ)
+    (hcodim : Module.finrank ℝ D + n = Module.finrank ℝ E) {O : Set M} (hO : IsOpen O)
+    (hfO : Set.MapsTo f K O) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∃ Φ :
+          PartialDiffeomorph 𝓘(ℝ, D × EuclideanSpace ℝ (Fin n)) 𝓘(ℝ, E)
+            (D × EuclideanSpace ℝ (Fin n)) M ∞,
+          K ×ˢ Metric.closedBall 0 ε ⊆ Φ.source ∧ (∀ x, Φ (x, 0) = f x) ∧ Φ.target ⊆ O := by
+  let : Nonempty M := ⟨f 0⟩
+  obtain ⟨e⟩ := nonempty_nativeEuclideanEmbedding (E := E) (M := M)
+  obtain ⟨r⟩ := e.nonempty_smoothRetraction
+  obtain ⟨V, hV, hKV, A, hA, hframe⟩ :=
+    e.exists_smooth_normalFrame_near_starConvex hf hK hz hstar hi n hcodim
+  obtain ⟨Φ, hzero, -, hΦ⟩ :=
+    r.exists_diskTubularNeighborhood hf hK hV hKV hinj hi hA (fun x hx => (hframe x hx).1)
+      (fun x hx => (hframe x hx).2)
+  let W := Φ.source ∩ Φ ⁻¹' O
+  have hW : IsOpen W := Φ.contMDiffOn_toFun.continuousOn.isOpen_inter_preimage Φ.open_source hO
+  have hWloc : IsLocalDiffeomorphOn 𝓘(ℝ, D × EuclideanSpace ℝ (Fin n)) 𝓘(ℝ, E) ∞ Φ W := fun p =>
+    ⟨Φ, p.property.1, fun _ _ => rfl⟩
+  let Ψ :=
+    partialDiffeomorphOfInjectiveLocal hW (Φ.toPartialEquiv.injOn.mono Set.inter_subset_left)
+      hWloc
+  have hzeroΨ : K ×ˢ {(0 : EuclideanSpace ℝ (Fin n))} ⊆ Ψ.source := by
+    rintro ⟨x, v⟩ ⟨hx, hv⟩
+    have hv0 : v = 0 := hv
+    subst v
+    refine ⟨hzero ⟨hx, rfl⟩, ?_⟩
+    change Φ (x, 0) ∈ O
+    rw [hΦ, r.diskCoordinates_zero]
+    exact hfO hx
+  obtain ⟨ε, hε, hprod⟩ := DiskFraming.exists_pos_prod_closedBall_subset hK Ψ.open_source hzeroΨ
+  refine ⟨ε, hε, Ψ, hprod, ?_, ?_⟩
+  · intro x
+    change Φ (x, 0) = f x
+    rw [hΦ, r.diskCoordinates_zero]
+  · change Φ '' W ⊆ O
+    rintro _ ⟨p, hp, rfl⟩
+    exact hp.2
+
+private theorem
+    Smale.exists_normed_tubularNeighborhood_in_open_of_embedded_starConvex_with_global_zero
+    {E M D : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D] {f : D → M}
+    (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f) {K : Set D} (hK : IsCompact K) (hz : (0 : D) ∈ K)
+    (hstar : StarConvex ℝ (0 : D) K) (hinj : Set.InjOn f K)
+    (hi : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x)) (n : ℕ)
+    (hcodim : Module.finrank ℝ D + n = Module.finrank ℝ E) {O : Set M} (hO : IsOpen O)
+    (hfO : Set.MapsTo f K O) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∃ Φ :
+          PartialDiffeomorph 𝓘(ℝ, D × EuclideanSpace ℝ (Fin n)) 𝓘(ℝ, E)
+            (D × EuclideanSpace ℝ (Fin n)) M ∞,
+          K ×ˢ Metric.closedBall 0 ε ⊆ Φ.source ∧ (∀ x, Φ (x, 0) = f x) ∧ Φ.target ⊆ O := by
+  let D₀ := EuclideanSpace ℝ (Fin (Module.finrank ℝ D))
+  let e : D₀ ≃L[ℝ] D := ContinuousLinearEquiv.ofFinrankEq finrank_euclideanSpace_fin
+  let f₀ := f ∘ e
+  let K₀ := e ⁻¹' K
+  have hf₀ : ContMDiff 𝓘(ℝ, D₀) 𝓘(ℝ, E) ∞ f₀ := hf.comp e.contDiff.contMDiff
+  have hK₀ : IsCompact K₀ := e.toHomeomorph.isCompact_preimage.mpr hK
+  have hz₀ : (0 : D₀) ∈ K₀ := by
+    change e 0 ∈ K
+    simpa only [map_zero] using hz
+  have hstar₀ : StarConvex ℝ (0 : D₀) K₀ := by
+    apply StarConvex.linear_preimage e.toLinearMap
+    simpa only [ContinuousLinearEquiv.coe_coe, map_zero] using hstar
+  have hinj₀ : Set.InjOn f₀ K₀ := fun _ hx _ hy hxy => e.injective (hinj hx hy hxy)
+  have hi₀ : ∀ x ∈ K₀, Function.Injective (mfderiv 𝓘(ℝ, D₀) 𝓘(ℝ, E) f₀ x) := by
+    intro x hx
+    exact
+      (ManifoldImmersion.injective_mfderiv_comp_linearEquiv_iff e
+            (hf.mdifferentiableAt (by simp))).mpr
+        (hi (e x) hx)
+  have hcodim₀ : Module.finrank ℝ D₀ + n = Module.finrank ℝ E := by
+    simpa only [D₀, finrank_euclideanSpace_fin] using hcodim
+  obtain ⟨ε, hε, Φ, hsource, hzero, htarget⟩ :=
+    exists_tubularNeighborhood_in_open_of_embedded_starConvex_with_global_zero hf₀ hK₀ hz₀ hstar₀
+      hinj₀ hi₀ n hcodim₀ hO (fun _ hx => hfO hx)
+  let eprod := e.symm.prodCongr (ContinuousLinearEquiv.refl ℝ (EuclideanSpace ℝ (Fin n)))
+  let c := eprod.toDiffeomorph
+  let Ψ := c.toPartialDiffeomorph.trans Φ
+  have hpre (x : D) (hx : x ∈ K) : e.symm x ∈ K₀ := by
+    change e (e.symm x) ∈ K
+    simpa only [e.apply_symm_apply] using hx
+  refine ⟨ε, hε, Ψ, ?_, ?_, ?_⟩
+  · rintro ⟨x, v⟩ ⟨hx, hv⟩
+    exact ⟨Set.mem_univ _, hsource ⟨hpre x hx, hv⟩⟩
+  · intro x
+    change Φ (e.symm x, 0) = f x
+    rw [hzero (e.symm x)]
+    exact congrArg f (e.apply_symm_apply x)
+  · intro y hy
+    exact htarget hy.1
+
+private theorem Smale.exists_local_tubularNeighborhood_of_embedded_starConvex {E M D : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D] {f : D → M} {K U : Set D}
+    (hf : ContMDiffOn 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f U) (hK : IsCompact K) (hz : (0 : D) ∈ K)
+    (hstar : StarConvex ℝ (0 : D) K) (hU : IsOpen U) (hKU : K ⊆ U) (hinj : Set.InjOn f K)
+    (hi : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x)) (n : ℕ)
+    (hcodim : Module.finrank ℝ D + n = Module.finrank ℝ E) {O : Set M} (hO : IsOpen O)
+    (hfO : Set.MapsTo f K O) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∃ Φ :
+          PartialDiffeomorph 𝓘(ℝ, D × EuclideanSpace ℝ (Fin n)) 𝓘(ℝ, E)
+            (D × EuclideanSpace ℝ (Fin n)) M ∞,
+          K ×ˢ Metric.closedBall 0 ε ⊆ Φ.source ∧
+            Φ.source ⊆ U ×ˢ Set.univ ∧ (∀ x, (x, 0) ∈ Φ.source → Φ (x, 0) = f x) ∧ Φ.target ⊆ O :=
+  by
+  obtain ⟨g, hg, V, hV, hKV, hVU, heq⟩ :=
+    exists_smooth_extension_near_starConvex hK hz hstar hU hKU hf
+  have hinjg : Set.InjOn g K := by
+    intro x hx y hy hxy
+    apply hinj hx hy
+    simpa only [heq (hKV hx), heq (hKV hy)] using hxy
+  have hig : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) g x) := by
+    intro x hx
+    have hnear : g =ᶠ[𝓝 x] f := Filter.Eventually.mono (hV.mem_nhds (hKV hx)) heq
+    rw [hnear.mfderiv_eq]
+    exact hi x hx
+  have hgO : Set.MapsTo g K O := by
+    intro x hx
+    rw [heq (hKV hx)]
+    exact hfO hx
+  obtain ⟨ε, hε, Φ, hsource, hzero, htarget⟩ :=
+    exists_normed_tubularNeighborhood_in_open_of_embedded_starConvex_with_global_zero hg hK hz
+      hstar hinjg hig n hcodim hO hgO
+  let Ψ :=
+    PartialChart.restrictSource Φ
+      (hV.preimage (continuous_fst : Continuous (Prod.fst : D × EuclideanSpace ℝ (Fin n) → D)))
+  refine ⟨ε, hε, Ψ, ?_, ?_, ?_, ?_⟩
+  · intro p hp
+    exact ⟨hsource hp, hKV hp.1⟩
+  · intro p hp
+    exact ⟨hVU hp.2, Set.mem_univ _⟩
+  · intro x hx
+    change Φ (x, 0) = f x
+    exact (hzero x).trans (heq hx.2)
+  · intro y hy
+    exact htarget hy.1
+
+private theorem Smale.exists_clean_tubularNeighborhood_of_embedded_starConvex {E M D : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D] {f : D → M} {K U : Set D}
+    (hf : ContMDiffOn 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f U) (hK : IsCompact K) (hz : (0 : D) ∈ K)
+    (hstar : StarConvex ℝ (0 : D) K) (hU : IsOpen U) (hKU : K ⊆ U)
+    (hemb : Topology.IsEmbedding (fun x : U => f x))
+    (hi : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x)) (n : ℕ)
+    (hcodim : Module.finrank ℝ D + n = Module.finrank ℝ E) {O : Set M} (hO : IsOpen O)
+    (hfO : Set.MapsTo f K O) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∃ Φ :
+          PartialDiffeomorph 𝓘(ℝ, D × EuclideanSpace ℝ (Fin n)) 𝓘(ℝ, E)
+            (D × EuclideanSpace ℝ (Fin n)) M ∞,
+          K ×ˢ Metric.closedBall 0 ε ⊆ Φ.source ∧
+            Φ.source ⊆ U ×ˢ Set.univ ∧
+              Φ.target ⊆ O ∧
+                (∀ x, (x, 0) ∈ Φ.source → Φ (x, 0) = f x) ∧
+                  (∀ q ∈ Φ.source, Φ q ∈ f '' U ↔ q.2 = 0) := by
+  have hinj : Set.InjOn f K := by
+    intro x hx y hy hxy
+    exact
+      congrArg Subtype.val
+        (hemb.injective
+          (show (fun u : U => f u) ⟨x, hKU hx⟩ = (fun u : U => f u) ⟨y, hKU hy⟩ from hxy))
+  obtain ⟨a, ha, Φ, hprod, hsource, hzero, htarget⟩ :=
+    exists_local_tubularNeighborhood_of_embedded_starConvex hf hK hz hstar hU hKU hinj hi n hcodim
+      hO hfO
+  have hbase : IsOpen {x : U | ((x : D), (0 : EuclideanSpace ℝ (Fin n))) ∈ Φ.source} :=
+    Φ.open_source.preimage (continuous_subtype_val.prodMk continuous_const)
+  obtain ⟨A, hA, hpreA⟩ := hemb.isInducing.isOpen_iff.mp hbase
+  have haxis {x : D} (hx : x ∈ U) (hxA : f x ∈ A) : (x, 0) ∈ Φ.source := by
+    have hx' : (⟨x, hx⟩ : U) ∈ (fun u : U => f u) ⁻¹' A := hxA
+    rw [hpreA] at hx'
+    exact hx'
+  have hKA : Set.MapsTo f K A := by
+    intro x hx
+    have hx' :
+      (⟨x, hKU hx⟩ : U) ∈ {u : U | ((u : D), (0 : EuclideanSpace ℝ (Fin n))) ∈ Φ.source} :=
+      hprod ⟨hx, Metric.mem_closedBall_self ha.le⟩
+    rw [← hpreA] at hx'
+    exact hx'
+  let Ψ := PartialChart.restrictTarget Φ hA
+  have hKzero : K ×ˢ {(0 : EuclideanSpace ℝ (Fin n))} ⊆ Ψ.source := by
+    rintro ⟨x, v⟩ ⟨hx, hv⟩
+    have hv0 : v = 0 := hv
+    subst v
+    have hxΦ := hprod ⟨hx, Metric.mem_closedBall_self ha.le⟩
+    refine ⟨hxΦ, ?_⟩
+    change Φ (x, 0) ∈ A
+    rw [hzero x hxΦ]
+    exact hKA hx
+  obtain ⟨ε, hε, hεprod⟩ := DiskFraming.exists_pos_prod_closedBall_subset hK Ψ.open_source hKzero
+  refine
+    ⟨ε, hε, Ψ, hεprod, fun _ hq => hsource hq.1, fun _ hy => htarget hy.1, fun x hx =>
+      hzero x hx.1, ?_⟩
+  rintro ⟨x, z⟩ hq
+  constructor
+  · rintro ⟨u, hu, heq⟩
+    have huA : f u ∈ A := heq ▸ hq.2
+    have huΦ := haxis hu huA
+    have hpair : (x, z) = (u, 0) :=
+      Φ.toPartialEquiv.injOn hq.1 huΦ (heq.symm.trans (hzero u huΦ).symm)
+    exact congrArg Prod.snd hpair
+  · intro hz
+    change z = 0 at hz
+    subst z
+    exact ⟨x, (hsource hq.1).1, (hzero x hq.1).symm⟩
+
+private theorem
+    Smale.exists_clean_embedded_sheet_neighborhood {E M D G N : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [NormedAddCommGroup D] [NormedSpace ℝ D]
+    [FiniteDimensional ℝ D] [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace N]
+    [ChartedSpace G N] {F : N → M} (hF : ContMDiff 𝓘(ℝ, G) 𝓘(ℝ, E) ∞ F)
+    (hembF : Topology.IsEmbedding F) (c : PartialDiffeomorph 𝓘(ℝ, D) 𝓘(ℝ, G) D N ∞) {K : Set D}
+    (hK : IsCompact K) (hz : (0 : D) ∈ K) (hstar : StarConvex ℝ (0 : D) K) (hKc : K ⊆ c.source)
+    (hiF : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, G) 𝓘(ℝ, E) F (c x))) (n : ℕ)
+    (hcodim : Module.finrank ℝ D + n = Module.finrank ℝ E) {O : Set M} (hO : IsOpen O)
+    (hFO : Set.MapsTo (F ∘ c) K O) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∃ Φ :
+          PartialDiffeomorph 𝓘(ℝ, D × EuclideanSpace ℝ (Fin n)) 𝓘(ℝ, E)
+            (D × EuclideanSpace ℝ (Fin n)) M ∞,
+          K ×ˢ Metric.closedBall 0 ε ⊆ Φ.source ∧
+            Φ.source ⊆ c.source ×ˢ Set.univ ∧
+              Φ.target ⊆ O ∧
+                (∀ x, (x, 0) ∈ Φ.source → Φ (x, 0) = F (c x)) ∧
+                  (∀ q ∈ Φ.source, Φ q ∈ Set.range F ↔ q.2 = 0) := by
+  let f := F ∘ c
+  have hf : ContMDiffOn 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f c.source := hF.comp_contMDiffOn c.contMDiffOn_toFun
+  have hembf : Topology.IsEmbedding (fun x : c.source => f x) :=
+    hembF.comp c.toOpenPartialHomeomorph.isEmbedding_restrict
+  have hi : ∀ x ∈ K, Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x) := by
+    intro x hx
+    rw [mfderiv_comp x (hF.mdifferentiableAt (by simp)) (c.mdifferentiableAt (by simp) (hKc hx))]
+    exact (hiF x hx).comp (PartialChart.bijective_mfderiv c (hKc hx)).1
+  obtain ⟨A, hA, hpreA⟩ := hembF.isInducing.isOpen_iff.mp c.open_target
+  have hfA : Set.MapsTo f K A := by
+    intro x hx
+    change c x ∈ F ⁻¹' A
+    rw [hpreA]
+    exact c.map_source' (hKc hx)
+  obtain ⟨ε, hε, Φ, hprod, hsource, htarget, hzero, himage⟩ :=
+    exists_clean_tubularNeighborhood_of_embedded_starConvex hf hK hz hstar c.open_source hKc hembf
+      hi n hcodim (hO.inter hA) (fun x hx => ⟨hFO hx, hfA hx⟩)
+  refine ⟨ε, hε, Φ, hprod, hsource, fun _ hy => (htarget hy).1, hzero, ?_⟩
+  intro q hq
+  have hqA := (htarget (Φ.map_source' hq)).2
+  have hrange : Φ q ∈ Set.range F ↔ Φ q ∈ f '' c.source := by
+    constructor
+    · rintro ⟨y, hy⟩
+      have hyA : F y ∈ A := hy ▸ hqA
+      have hyT : y ∈ c.target := by
+        change y ∈ F ⁻¹' A at hyA
+        rwa [hpreA] at hyA
+      exact ⟨c.invFun y, c.map_target' hyT, (congrArg F (c.right_inv' hyT)).trans hy⟩
+    · rintro ⟨u, _, hu⟩
+      exact ⟨c u, hu⟩
+  exact hrange.trans (himage q hq)
+
+private def MorseCancel.sheetAxisShuffle {D B : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D]
+    [NormedAddCommGroup B] [NormedSpace ℝ B] : (ℝ × (D × B)) ≃L[ℝ] (D × (ℝ × B))
+    where
+  toLinearEquiv :=
+    { toFun := fun p => (p.2.1, (p.1, p.2.2))
+      invFun := fun p => (p.2.1, (p.1, p.2.2))
+      left_inv := fun _ => rfl
+      right_inv := fun _ => rfl
+      map_add' := fun _ _ => rfl
+      map_smul' := fun _ _ => rfl }
+  continuous_toFun := continuous_snd.fst.prodMk (continuous_fst.prodMk continuous_snd.snd)
+  continuous_invFun := continuous_snd.fst.prodMk (continuous_fst.prodMk continuous_snd.snd)
+
+private theorem MorseCancel.exists_clean_sheet_axis_chart {D : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] {E M X : Type*} [FiniteDimensional ℝ D] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [TopologicalSpace X] [ChartedSpace D X]
+    [IsManifold 𝓘(ℝ, D) ∞ X] {f : X → M} (hf : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f)
+    (hemb : Topology.IsEmbedding f) (hi : ∀ x, Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x))
+    (n : ℕ) (hdim : Module.finrank ℝ D + (1 + n) = Module.finrank ℝ E) (x : X) {U : Set M}
+    (hU : IsOpen U) (hxU : f x ∈ U) :
+    ∃ Φ :
+      PartialDiffeomorph 𝓘(ℝ, ℝ × (D × EuclideanSpace ℝ (Fin n))) 𝓘(ℝ, E)
+        (ℝ × (D × EuclideanSpace ℝ (Fin n))) M ∞,
+      (0 : ℝ × (D × EuclideanSpace ℝ (Fin n))) ∈ Φ.source ∧
+        Φ 0 = f x ∧ Φ.target ⊆ U ∧ ∀ z ∈ Φ.source, Φ z ∈ Set.range f ↔ z.1 = 0 ∧ z.2.2 = 0 := by
+  let c := Smale.NativeParametrization.centered (D := D) x
+  have hc0 : (0 : D) ∈ c.source := Smale.NativeParametrization.zero_mem_centered_source x
+  have hcx : c 0 = x := Smale.NativeParametrization.centered_zero x
+  obtain ⟨ε, hε, Q, hprod, -, hQU, hzero, hrecognition⟩ :=
+    Smale.exists_clean_embedded_sheet_neighborhood hf hemb c isCompact_singleton
+      (Set.mem_singleton (0 : D)) (starConvex_singleton (0 : D))
+      (Set.singleton_subset_iff.mpr hc0) (fun z _ => hi (c z)) (1 + n) hdim hU
+      (show Set.MapsTo (f ∘ c) {0} U by
+        intro z hz
+        rcases Set.mem_singleton_iff.mp hz with rfl
+        change f (c 0) ∈ U
+        rw [hcx]
+        exact hxU)
+  let B := EuclideanSpace ℝ (Fin n)
+  let N := EuclideanSpace ℝ (Fin (1 + n))
+  let L : (ℝ × B) ≃L[ℝ] N :=
+    ContinuousLinearEquiv.ofFinrankEq
+      (by simp only [B, N, Module.finrank_prod, Module.finrank_self, finrank_euclideanSpace_fin])
+  let P : (ℝ × (D × B)) ≃L[ℝ] (D × N) :=
+    (sheetAxisShuffle (D := D) (B := B)).trans ((ContinuousLinearEquiv.refl ℝ D).prodCongr L)
+  let Φ := P.toDiffeomorph.toPartialDiffeomorph.trans Q
+  have hQ0 : (0 : D × N) ∈ Q.source :=
+    hprod ⟨Set.mem_singleton 0, Metric.mem_closedBall_self hε.le⟩
+  have hΦ0 : (0 : ℝ × (D × B)) ∈ Φ.source := by
+    refine ⟨Set.mem_univ _, ?_⟩
+    change P 0 ∈ Q.source
+    rw [map_zero]
+    exact hQ0
+  refine ⟨Φ, hΦ0, ?_, fun z hz => hQU hz.1, ?_⟩
+  · change Q (P 0) = f x
+    rw [map_zero]
+    exact (hzero 0 hQ0).trans (congrArg f hcx)
+  · intro z hz
+    change Q (P z) ∈ Set.range f ↔ _
+    rw [hrecognition (P z) hz.2]
+    change L (z.1, z.2.2) = 0 ↔ z.1 = 0 ∧ z.2.2 = 0
+    constructor
+    · intro h
+      have he : (z.1, z.2.2) = (0, (0 : B)) := L.injective (h.trans L.map_zero.symm)
+      exact ⟨congrArg Prod.fst he, congrArg Prod.snd he⟩
+    · rintro ⟨h1, h2⟩
+      rw [h1, h2]
+      exact L.map_zero
+
+private theorem MorseCancel.chart_axis_curve_properties {V E H M : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ E H} [TopologicalSpace M] [ChartedSpace H M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × V) J (ℝ × V) M ∞) (p : ℝ) (hp : (p, (0 : V)) ∈ Φ.source) :
+    ∃ U : Set ℝ,
+      IsOpen U ∧
+        p ∈ U ∧
+          (∀ t ∈ U, (t, (0 : V)) ∈ Φ.source) ∧
+            ContMDiffOn 𝓘(ℝ, ℝ) J ∞ (fun t => Φ (t, (0 : V))) U ∧
+              Function.Injective (mfderiv 𝓘(ℝ, ℝ) J (fun t => Φ (t, (0 : V))) p) := by
+  let L := ContinuousLinearMap.inl ℝ ℝ V
+  have hL : ContDiff ℝ ∞ L := L.contDiff
+  let U : Set ℝ := L ⁻¹' Φ.source
+  have hU : IsOpen U := Φ.open_source.preimage L.continuous
+  have hcurve : ContMDiffOn 𝓘(ℝ, ℝ) J ∞ (Φ ∘ L) U :=
+    Φ.contMDiffOn_toFun.comp hL.contMDiff.contMDiffOn (fun _ ht => ht)
+  refine ⟨U, hU, hp, fun _ ht => ht, hcurve, ?_⟩
+  change Function.Injective (mfderiv 𝓘(ℝ, ℝ) J (Φ ∘ L) p)
+  rw [mfderiv_comp p (Φ.mdifferentiableAt (by simp) hp)
+      (hL.contMDiff.mdifferentiableAt (by simp)),
+    mfderiv_eq_fderiv, L.fderiv]
+  exact
+    (Smale.PartialChart.bijective_mfderiv Φ hp).injective.comp (fun _ _ h => congrArg Prod.fst h)
+
+private def
+    MorseCancel.terminalSheetCoordinates {D : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D] :
+    Diffeomorph 𝓘(ℝ, ℝ × (D × D)) 𝓘(ℝ, ℝ × (D × D)) (ℝ × (D × D)) (ℝ × (D × D)) ∞
+    where
+  toEquiv :=
+    { toFun := fun z => (z.1 - 1, (z.2.2, z.2.1))
+      invFun := fun z => (z.1 + 1, (z.2.2, z.2.1))
+      left_inv := by intro z; ext <;> simp
+      right_inv := by intro z; ext <;> simp }
+  contMDiff_toFun :=
+    ((contDiff_fst.sub contDiff_const).prodMk
+        (contDiff_snd.snd.prodMk contDiff_snd.fst)).contMDiff
+  contMDiff_invFun :=
+    ((contDiff_fst.add contDiff_const).prodMk
+        (contDiff_snd.snd.prodMk contDiff_snd.fst)).contMDiff
+
+private theorem MorseCancel.exists_clean_two_sheet_arc {E M X Y : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [TopologicalSpace X]
+    [ChartedSpace (EuclideanSpace ℝ (Fin 2)) X] [IsManifold (𝓡 2) ∞ X] [CompactSpace X]
+    [SecondCountableTopology X] [TopologicalSpace Y] [ChartedSpace (EuclideanSpace ℝ (Fin 2)) Y]
+    [IsManifold (𝓡 2) ∞ Y] [CompactSpace Y] [SecondCountableTopology Y] {f : X → M} {g : Y → M}
+    (hf : ContMDiff (𝓡 2) 𝓘(ℝ, E) ∞ f) (hg : ContMDiff (𝓡 2) 𝓘(ℝ, E) ∞ g)
+    (hfe : Topology.IsEmbedding f) (hge : Topology.IsEmbedding g)
+    (hfi : ∀ x, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, E) f x))
+    (hgi : ∀ y, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, E) g y)) (hdim : Module.finrank ℝ E = 5)
+    (x : X) (y : Y) (hx : f x ∉ Set.range g) (hy : g y ∉ Set.range f) (γ : Path (f x) (g y)) :
+    ∃ Φ Ψ :
+      PartialDiffeomorph 𝓘(ℝ, (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))))
+        𝓘(ℝ, E) (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) M ∞,
+      (0 : (ℝ × ((EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2))))) ∈ Φ.source ∧
+        ((1 : ℝ), (0 : (EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) ∈ Ψ.source ∧
+          Φ 0 = f x ∧
+            Ψ (1, 0) = g y ∧
+              Φ.target ⊆ (Set.range g)ᶜ ∧
+                Ψ.target ⊆ (Set.range f)ᶜ ∧
+                  (∀ z ∈ Φ.source, Φ z ∈ Set.range f ↔ z.1 = 0 ∧ z.2.2 = 0) ∧
+                    (∀ z ∈ Ψ.source, Ψ z ∈ Set.range g ↔ z.1 = 1 ∧ z.2.1 = 0) ∧
+                      ∃ a : C(ℝ, M),
+                        ContMDiff 𝓘(ℝ, ℝ) 𝓘(ℝ, E) ∞ a ∧
+                          (a =ᶠ[𝓝 (0 : ℝ)] fun t => Φ (t, 0)) ∧
+                            (a =ᶠ[𝓝 (1 : ℝ)] fun t => Ψ (t, 0)) ∧
+                              Topology.IsClosedEmbedding (fun t : unitInterval => a t) ∧
+                                (∀ t ∈ Set.Icc (0 : ℝ) 1,
+                                    Function.Injective (mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, E) a t)) ∧
+                                  (∀ t ∈ Set.Icc (0 : ℝ) 1, a t ∈ Set.range f ↔ t = 0) ∧
+                                    (∀ t ∈ Set.Icc (0 : ℝ) 1, a t ∈ Set.range g ↔ t = 1) := by
+  have hclosedf : IsClosed (Set.range f) := (isCompact_range hf.continuous).isClosed
+  have hclosedg : IsClosed (Set.range g) := (isCompact_range hg.continuous).isClosed
+  have hcodim : Module.finrank ℝ (EuclideanSpace ℝ (Fin 2)) + (1 + 2) = Module.finrank ℝ E := by
+    rw [finrank_euclideanSpace_fin, hdim]
+  obtain ⟨Φ, hΦ0, hΦx, hΦavoid, hΦrec⟩ :=
+    exists_clean_sheet_axis_chart hf hfe hfi 2 hcodim x hclosedg.isOpen_compl hx
+  obtain ⟨Q, hQ0, hQy, hQavoid, hQrec⟩ :=
+    exists_clean_sheet_axis_chart hg hge hgi 2 hcodim y hclosedf.isOpen_compl hy
+  let T := terminalSheetCoordinates (D := (EuclideanSpace ℝ (Fin 2)))
+  let Ψ := T.toPartialDiffeomorph.trans Q
+  have hT1 : T ((1 : ℝ), (0 : (EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) = 0 := by
+    change ((1 : ℝ) - 1, ((0 : (EuclideanSpace ℝ (Fin 2))), (0 : (EuclideanSpace ℝ (Fin 2))))) = 0
+    rw [sub_self]
+    rfl
+  have hΨ1 :
+    ((1 : ℝ), (0 : (EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) ∈ Ψ.source := by
+    refine ⟨Set.mem_univ _, ?_⟩
+    change T (1, 0) ∈ Q.source
+    rw [hT1]
+    exact hQ0
+  have hΨy : Ψ (1, 0) = g y := by
+    change Q (T (1, 0)) = g y
+    rw [hT1]
+    exact hQy
+  have hΨavoid : Ψ.target ⊆ (Set.range f)ᶜ := fun z hz => hQavoid hz.1
+  have hΨrec : ∀ z ∈ Ψ.source, Ψ z ∈ Set.range g ↔ z.1 = 1 ∧ z.2.1 = 0 := by
+    intro z hz
+    change Q (T z) ∈ Set.range g ↔ _
+    rw [hQrec (T z) hz.2]
+    change z.1 - 1 = 0 ∧ z.2.1 = 0 ↔ _
+    rw [sub_eq_zero]
+  let o : C(X ⊕ Y, M) := ⟨Sum.elim f g, hf.continuous.sumElim hg.continuous⟩
+  have ho : ContMDiff (𝓡 2) 𝓘(ℝ, E) ∞ o := hf.sumElim hg
+  have horange : Set.range o = Set.range f ∪ Set.range g := by
+    ext z
+    constructor
+    · rintro ⟨a | b, he⟩
+      · exact Or.inl ⟨a, he⟩
+      · exact Or.inr ⟨b, he⟩
+    · rintro (⟨a, he⟩ | ⟨b, he⟩)
+      · exact ⟨Sum.inl a, he⟩
+      · exact ⟨Sum.inr b, he⟩
+  have hoclosed : IsClosed (Set.range o) := by rw [horange]; exact hclosedf.union hclosedg
+  obtain ⟨U, hU, h0U, hUΦ, ha, hia⟩ := chart_axis_curve_properties Φ 0 hΦ0
+  obtain ⟨W, hW, h1W, hWΨ, hb, hib⟩ := chart_axis_curve_properties Ψ 1 hΨ1
+  have hclean0 :
+    ∀ᶠ t in 𝓝 (0 : ℝ),
+      Φ (t, (0 : (EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) ∈ Set.range o →
+        t = 0 := by
+    filter_upwards [hU.mem_nhds h0U] with t ht
+    rw [horange]
+    rintro (h | h)
+    · exact ((hΦrec (t, 0) (hUΦ t ht)).mp h).1
+    · exact (hΦavoid (Φ.map_source' (hUΦ t ht)) h).elim
+  have hclean1 :
+    ∀ᶠ t in 𝓝 (1 : ℝ),
+      Ψ (t, (0 : (EuclideanSpace ℝ (Fin 2)) × (EuclideanSpace ℝ (Fin 2)))) ∈ Set.range o →
+        t = 1 := by
+    filter_upwards [hW.mem_nhds h1W] with t ht
+    rw [horange]
+    rintro (h | h)
+    · exact (hΨavoid (Ψ.map_source' (hWΨ t ht)) h).elim
+    · exact ((hΨrec (t, 0) (hWΨ t ht)).mp h).1
+  have hxy : f x ≠ g y := fun h => hx ⟨y, h.symm⟩
+  have hends : Φ (0, 0) ≠ Ψ (1, 0) := by
+    change Φ 0 ≠ Ψ (1, 0)
+    rw [hΦx, hΨy]
+    exact hxy
+  obtain ⟨a, ha', hleft, hright, hemb, hi, havoid⟩ :=
+    exists_clean_arc_with_local_endpoint_germs ha hb hU hW h0U h1W hia hib (γ.cast hΦx hΨy) hends
+      (by omega) o ho hoclosed (by rw [finrank_euclideanSpace_fin, hdim]; norm_num) hclean0
+      hclean1
+  have ha0 : a 0 = f x := hleft.eq_of_nhds.trans hΦx
+  have ha1 : a 1 = g y := hright.eq_of_nhds.trans hΨy
+  refine
+    ⟨Φ, Ψ, hΦ0, hΨ1, hΦx, hΨy, hΦavoid, hΨavoid, hΦrec, hΨrec, a, ha', hleft, hright, hemb, hi,
+      ?_, ?_⟩
+  · intro t ht
+    constructor
+    · intro h
+      by_contra ht0
+      have ht1 : t ≠ 1 := by intro he; subst t; rw [ha1] at h; exact hy h
+      exact
+        havoid t ⟨lt_of_le_of_ne ht.1 (Ne.symm ht0), lt_of_le_of_ne ht.2 ht1⟩
+          (horange.symm ▸ Or.inl h)
+    · intro he
+      subst t
+      rw [ha0]
+      exact Set.mem_range_self x
+  · intro t ht
+    constructor
+    · intro h
+      by_contra ht1
+      have ht0 : t ≠ 0 := by intro he; subst t; rw [ha0] at h; exact hx h
+      exact
+        havoid t ⟨lt_of_le_of_ne ht.1 (Ne.symm ht0), lt_of_le_of_ne ht.2 ht1⟩
+          (horange.symm ▸ Or.inr h)
+    · intro he
+      subst t
+      rw [ha1]
+      exact Set.mem_range_self y
+
+private theorem
+    Smale.TransverseCoordinates.surjective_coprod_swap {D Z E : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (A : D →L[ℝ] E) (C : Z →L[ℝ] E) (h : Function.Surjective (A.coprod C)) :
+    Function.Surjective (C.coprod A) := by
+  intro w
+  obtain ⟨⟨u, v⟩, huv⟩ := h w
+  refine ⟨(v, u), ?_⟩
+  change C v + A u = w
+  rw [add_comm]
+  exact huv
+
+private theorem Smale.TransverseCoordinates.surjective_normal_comp {D Z E B : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    (Q : E →L[ℝ] B) (A : D →L[ℝ] E) (C : Z →L[ℝ] E) (hQ : Function.Surjective Q)
+    (hAC : Function.Surjective (A.coprod C)) (hQA : Q.comp A = 0) :
+    Function.Surjective (Q.comp C) := by
+  intro w
+  obtain ⟨z, hz⟩ := hQ w
+  obtain ⟨⟨u, v⟩, huv⟩ := hAC z
+  have hAu : Q (A u) = 0 := congrArg (fun T : D →L[ℝ] B => T u) hQA
+  refine ⟨v, ?_⟩
+  change Q (C v) = w
+  have hsum : Q (A u + C v) = w := (congrArg Q huv).trans hz
+  simpa only [map_add, hAu, zero_add] using hsum
+
+private theorem
+    Smale.TransverseCoordinates.bijective_normal_comp {D Z E B : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup B] [NormedSpace ℝ B] [FiniteDimensional ℝ Z]
+    [FiniteDimensional ℝ B] (Q : E →L[ℝ] B) (A : D →L[ℝ] E) (C : Z →L[ℝ] E)
+    (hQ : Function.Surjective Q) (hAC : Function.Surjective (A.coprod C)) (hQA : Q.comp A = 0)
+    (hdim : Module.finrank ℝ Z = Module.finrank ℝ B) : Function.Bijective (Q.comp C) := by
+  have hs := surjective_normal_comp Q A C hQ hAC hQA
+  exact ⟨(LinearMap.injective_iff_surjective_of_finrank_eq_finrank hdim).mpr hs, hs⟩
+
+private def
+    Smale.FrameField.complementQuotient {D Z F : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (G : D →L[ℝ] F) (C : Z →L[ℝ] F) : F →L[ℝ] Z :=
+  (ContinuousLinearMap.snd ℝ D Z).comp (G.coprod C).inverse
+
+private theorem Smale.FrameField.complementQuotient_left {D Z F : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (G : D →L[ℝ] F) (C : Z →L[ℝ] F) (h : (G.coprod C).IsInvertible) (u : D) :
+    complementQuotient G C (G u) = 0 := by
+  have hi := h.inverse_apply_self (u, 0)
+  change (G.coprod C).inverse (G u + C 0) = (u, 0) at hi
+  rw [map_zero, add_zero] at hi
+  exact congrArg Prod.snd hi
+
+private theorem Smale.FrameField.complementQuotient_right {D Z F : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (G : D →L[ℝ] F) (C : Z →L[ℝ] F) (h : (G.coprod C).IsInvertible) (v : Z) :
+    complementQuotient G C (C v) = v := by
+  have hi := h.inverse_apply_self (0, v)
+  change (G.coprod C).inverse (G 0 + C v) = (0, v) at hi
+  rw [map_zero, zero_add] at hi
+  exact congrArg Prod.snd hi
+
+private theorem Smale.FrameField.ker_complementQuotient {D Z F : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (G : D →L[ℝ] F) (C : Z →L[ℝ] F) (h : (G.coprod C).IsInvertible) :
+    (complementQuotient G C).ker = G.range := by
+  ext w
+  constructor
+  · intro hw
+    let p := (G.coprod C).inverse w
+    have hp : p.2 = 0 := hw
+    have hi := h.self_apply_inverse w
+    change G p.1 + C p.2 = w at hi
+    rw [hp, map_zero, add_zero] at hi
+    exact ⟨p.1, hi⟩
+  · rintro ⟨u, rfl⟩
+    exact complementQuotient_left G C h u
+
+private theorem Smale.FrameField.bijective_coprod_of_quotient {D Z F : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (G : D →L[ℝ] F) (C H : Z →L[ℝ] F) (h : (G.coprod C).IsInvertible)
+    (hH : Function.Bijective ((complementQuotient G C).comp H)) :
+    Function.Bijective (G.coprod H) := by
+  have hG : Function.Injective G := by
+    intro u v huv
+    have hpair : (G.coprod C) (u, 0) = (G.coprod C) (v, 0) := by
+      change G u + C 0 = G v + C 0
+      rw [huv]
+    exact congrArg Prod.fst (h.injective hpair)
+  constructor
+  · intro p q hpq
+    have hq := congrArg (complementQuotient G C) hpq
+    change complementQuotient G C (G p.1 + H p.2) = complementQuotient G C (G q.1 + H q.2) at hq
+    rw [map_add, map_add, complementQuotient_left G C h, complementQuotient_left G C h, zero_add,
+      zero_add] at hq
+    have hp₂ : p.2 = q.2 := hH.1 hq
+    have hp₁ : p.1 = q.1 := by
+      change G p.1 + H p.2 = G q.1 + H q.2 at hpq
+      rw [hp₂] at hpq
+      exact hG (add_right_cancel hpq)
+    exact Prod.ext hp₁ hp₂
+  · intro w
+    obtain ⟨v, hv⟩ := hH.2 (complementQuotient G C w)
+    have hmem : w - H v ∈ G.range := by
+      rw [← ker_complementQuotient G C h]
+      change complementQuotient G C (w - H v) = 0
+      rw [map_sub]
+      change complementQuotient G C w - ((complementQuotient G C).comp H) v = 0
+      rw [hv, sub_self]
+    obtain ⟨u, hu⟩ := hmem
+    refine ⟨(u, v), ?_⟩
+    change G u + H v = w
+    change G u = w - H v at hu
+    rw [hu, sub_add_cancel]
+
+private def
+    Smale.FrameField.correctedComplement {D Z F : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (G : D →L[ℝ] F) (C L : Z →L[ℝ] F) (K : Z →L[ℝ] Z) : Z →L[ℝ] F :=
+  L + C.comp (K - (complementQuotient G C).comp L)
+
+private theorem Smale.FrameField.quotient_correctedComplement {D Z F : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (G : D →L[ℝ] F) (C L : Z →L[ℝ] F) (K : Z →L[ℝ] Z)
+    (h : (G.coprod C).IsInvertible) :
+    (complementQuotient G C).comp (correctedComplement G C L K) = K := by
+  apply ContinuousLinearMap.ext
+  intro v
+  change complementQuotient G C (L v + C ((K - (complementQuotient G C).comp L) v)) = K v
+  rw [map_add, complementQuotient_right G C h]
+  change complementQuotient G C (L v) + (K v - complementQuotient G C (L v)) = K v
+  rw [← add_sub_assoc, add_sub_cancel_left]
+
+private theorem Smale.FrameField.correctedComplement_self {D Z F : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (G : D →L[ℝ] F) (C L : Z →L[ℝ] F) :
+    correctedComplement G C L ((complementQuotient G C).comp L) = L := by
+  simp only [correctedComplement, sub_self, ContinuousLinearMap.comp_zero, add_zero]
+
+private theorem Smale.FrameField.bijective_coprod_correctedComplement {D Z F : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (G : D →L[ℝ] F) (C L : Z →L[ℝ] F) (K : Z →L[ℝ] Z)
+    (h : (G.coprod C).IsInvertible) (hK : Function.Bijective K) :
+    Function.Bijective (G.coprod (correctedComplement G C L K)) := by
+  apply bijective_coprod_of_quotient G C _ h
+  rw [quotient_correctedComplement G C L K h]
+  exact hK
+
+private theorem Smale.FrameField.contDiffOn_coprod {X D Z F : Type*} [NormedAddCommGroup X]
+    [NormedSpace ℝ X] [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [NormedAddCommGroup F] [NormedSpace ℝ F] {G : X → (D →L[ℝ] F)}
+    {C : X → (Z →L[ℝ] F)} {U : Set X} (hG : ContDiffOn ℝ ∞ G U) (hC : ContDiffOn ℝ ∞ C U) :
+    ContDiffOn ℝ ∞ (fun x => (G x).coprod (C x)) U :=
+  (hG.clm_comp (contDiffOn_const (c := ContinuousLinearMap.fst ℝ D Z))).add
+    (hC.clm_comp (contDiffOn_const (c := ContinuousLinearMap.snd ℝ D Z)))
+
+public
+theorem Smale.FrameField.isInvertible_coprod_of_bijective {D Z F : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [FiniteDimensional ℝ D] [FiniteDimensional ℝ Z] (G : D →L[ℝ] F)
+    (C : Z →L[ℝ] F) (h : Function.Bijective (G.coprod C)) : (G.coprod C).IsInvertible := by
+  let e := (LinearEquiv.ofBijective (G.coprod C).toLinearMap h).toContinuousLinearEquiv
+  exact ⟨e, rfl⟩
+
+private theorem
+    Smale.FrameField.contDiffOn_complementQuotient {X D Z F : Type*} [NormedAddCommGroup X]
+    [NormedSpace ℝ X] [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [NormedAddCommGroup F] [NormedSpace ℝ F] [FiniteDimensional ℝ D]
+    [FiniteDimensional ℝ Z] {G : X → (D →L[ℝ] F)} {C : X → (Z →L[ℝ] F)} {U : Set X}
+    (hU : IsOpen U) (hG : ContDiffOn ℝ ∞ G U) (hC : ContDiffOn ℝ ∞ C U)
+    (hi : ∀ x ∈ U, ((G x).coprod (C x)).IsInvertible) :
+    ContDiffOn ℝ ∞ (fun x => complementQuotient (G x) (C x)) U := by
+  have hT := contDiffOn_coprod hG hC
+  have hInv : ContDiffOn ℝ ∞ (fun x => ((G x).coprod (C x)).inverse) U := by
+    intro x hx
+    exact
+      ((hi x hx).contDiffAt_map_inverse.comp x (hT.contDiffAt (hU.mem_nhds hx))).contDiffWithinAt
+  exact contDiffOn_const.clm_comp hInv
+
+private theorem
+    Smale.FrameField.contDiffOn_correctedComplement {X D Z F : Type*} [NormedAddCommGroup X]
+    [NormedSpace ℝ X] [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [NormedAddCommGroup F] [NormedSpace ℝ F] [FiniteDimensional ℝ D]
+    [FiniteDimensional ℝ Z] {G : X → (D →L[ℝ] F)} {C L : X → (Z →L[ℝ] F)} {K : X → (Z →L[ℝ] Z)}
+    {U : Set X} (hU : IsOpen U) (hG : ContDiffOn ℝ ∞ G U) (hC : ContDiffOn ℝ ∞ C U)
+    (hL : ContDiffOn ℝ ∞ L U) (hK : ContDiffOn ℝ ∞ K U)
+    (hi : ∀ x ∈ U, ((G x).coprod (C x)).IsInvertible) :
+    ContDiffOn ℝ ∞ (fun x => correctedComplement (G x) (C x) (L x) (K x)) U :=
+  hL.add (hC.clm_comp (hK.sub ((contDiffOn_complementQuotient hU hG hC hi).clm_comp hL)))
+
+private def Smale.FrameField.shearedBlock {X Z F : Type*} [NormedAddCommGroup X] [NormedSpace ℝ X]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (A : Z →L[ℝ] X) (T : Z →L[ℝ] F) : (X × Z) →L[ℝ] (X × F) :=
+  (ContinuousLinearMap.inl ℝ X F).coprod (A.prod T)
+
+private theorem Smale.FrameField.shearedBlock_apply {X Z F : Type*} [NormedAddCommGroup X]
+    [NormedSpace ℝ X] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (A : Z →L[ℝ] X) (T : Z →L[ℝ] F) (p : X × Z) :
+    shearedBlock A T p = (p.1 + A p.2, T p.2) := by
+  simp [shearedBlock, ContinuousLinearMap.coprod_apply]
+
+private theorem Smale.FrameField.shearedBlock_horizontal {X Z F : Type*} [NormedAddCommGroup X]
+    [NormedSpace ℝ X] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (A : Z →L[ℝ] X) (T : Z →L[ℝ] F) (x : X) :
+    shearedBlock A T (x, 0) = (x, 0) := by simp only [shearedBlock_apply, map_zero, add_zero]
+
+private theorem Smale.FrameField.bijective_shearedBlock {X Z F : Type*} [NormedAddCommGroup X]
+    [NormedSpace ℝ X] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (A : Z →L[ℝ] X) (T : Z →L[ℝ] F) (hi : Function.Bijective T) :
+    Function.Bijective (shearedBlock A T) := by
+  constructor
+  · intro p q hpq
+    have hz : p.2 = q.2 := hi.1 (by simpa only [shearedBlock_apply] using congrArg Prod.snd hpq)
+    have hx : p.1 + A p.2 = q.1 + A q.2 := by
+      simpa only [shearedBlock_apply] using congrArg Prod.fst hpq
+    rw [hz] at hx
+    exact Prod.ext (add_right_cancel hx) hz
+  · intro q
+    obtain ⟨z, hz⟩ := hi.2 q.2
+    refine ⟨(q.1 - A z, z), ?_⟩
+    rw [shearedBlock_apply]
+    simp only [sub_add_cancel, hz]
+
+private def Smale.FrameField.shearedMap {X Z F : Type*} [NormedAddCommGroup X] [NormedSpace ℝ X]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (A : X → (Z →L[ℝ] X)) (T : X → (Z →L[ℝ] F)) (p : X × Z) : X × F :=
+  (p.1 + A p.1 p.2, T p.1 p.2)
+
+private theorem
+    Smale.FrameField.shearedMap_zero {X Z F : Type*} [NormedAddCommGroup X] [NormedSpace ℝ X]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (A : X → (Z →L[ℝ] X)) (T : X → (Z →L[ℝ] F)) (x : X) : shearedMap A T (x, 0) = (x, 0) := by
+  simp only [shearedMap, map_zero, add_zero]
+
+private theorem Smale.FrameField.contDiffOn_shearedMap {X Z F : Type*} [NormedAddCommGroup X]
+    [NormedSpace ℝ X] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {A : X → (Z →L[ℝ] X)} {T : X → (Z →L[ℝ] F)} {U : Set X}
+    (hA : ContDiffOn ℝ ∞ A U) (hT : ContDiffOn ℝ ∞ T U) :
+    ContDiffOn ℝ ∞ (shearedMap A T) (Prod.fst ⁻¹' U) :=
+  (contDiffOn_fst.add ((hA.comp contDiffOn_fst (fun _ hp => hp)).clm_apply contDiffOn_snd)).prodMk
+    ((hT.comp contDiffOn_fst (fun _ hp => hp)).clm_apply contDiffOn_snd)
+
+private theorem Smale.FrameField.hasFDerivAt_shearedMap_zero {X Z F : Type*} [NormedAddCommGroup X]
+    [NormedSpace ℝ X] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {A : X → (Z →L[ℝ] X)} {T : X → (Z →L[ℝ] F)} {x : X}
+    (hA : DifferentiableAt ℝ A x) (hT : DifferentiableAt ℝ T x) :
+    HasFDerivAt (shearedMap A T) (shearedBlock (A x) (T x)) (x, 0) := by
+  have hAa :
+    HasFDerivAt (fun p : X × Z => A p.1) ((fderiv ℝ A x).comp (ContinuousLinearMap.fst ℝ X Z))
+      (x, 0) :=
+    hA.hasFDerivAt.comp (x, 0) hasFDerivAt_fst
+  have hTt :
+    HasFDerivAt (fun p : X × Z => T p.1) ((fderiv ℝ T x).comp (ContinuousLinearMap.fst ℝ X Z))
+      (x, 0) :=
+    hT.hasFDerivAt.comp (x, 0) hasFDerivAt_fst
+  have hs : HasFDerivAt (fun p : X × Z => p.2) (ContinuousLinearMap.snd ℝ X Z) (x, 0) :=
+    hasFDerivAt_snd
+  have hf : HasFDerivAt (fun p : X × Z => p.1) (ContinuousLinearMap.fst ℝ X Z) (x, 0) :=
+    hasFDerivAt_fst
+  have hd := (hf.add (hAa.clm_apply hs)).prodMk (hTt.clm_apply hs)
+  convert hd using 1 <;>
+    first
+    | rfl
+    | (apply ContinuousLinearMap.ext; intro p; simp [shearedBlock_apply])
+
+private theorem Smale.FrameField.isInvertible_shearedBlock {X Z F : Type*} [NormedAddCommGroup X]
+    [NormedSpace ℝ X] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [FiniteDimensional ℝ X] [FiniteDimensional ℝ Z] (A : Z →L[ℝ] X)
+    (T : Z →L[ℝ] F) (hi : T.IsInvertible) : (shearedBlock A T).IsInvertible := by
+  let e :=
+    (LinearEquiv.ofBijective (shearedBlock A T).toLinearMap
+        (bijective_shearedBlock A T hi.bijective)).toContinuousLinearEquiv
+  exact ⟨e, rfl⟩
+
+private theorem Smale.FrameField.exists_sheared_frame_chart {X Z F : Type*} [NormedAddCommGroup X]
+    [NormedSpace ℝ X] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [FiniteDimensional ℝ X] [FiniteDimensional ℝ Z] {A : X → (Z →L[ℝ] X)}
+    {T : X → (Z →L[ℝ] F)} {K U : Set X} (hK : IsCompact K) (hU : IsOpen U) (hKU : K ⊆ U)
+    (hA : ContDiffOn ℝ ∞ A U) (hT : ContDiffOn ℝ ∞ T U) (hi : ∀ x ∈ K, (T x).IsInvertible) :
+    ∃ Φ : PartialDiffeomorph 𝓘(ℝ, X × Z) 𝓘(ℝ, X × F) (X × Z) (X × F) ∞,
+      K ×ˢ {(0 : Z)} ⊆ Φ.source ∧
+        Φ.source ⊆ Prod.fst ⁻¹' U ∧ (Φ : X × Z → X × F) = shearedMap A T := by
+  have hzeroInj : Set.InjOn (shearedMap A T) (K ×ˢ {(0 : Z)}) := by
+    rintro ⟨x, z⟩ ⟨hx, hz⟩ ⟨y, w⟩ ⟨hy, hw⟩ heq
+    have hz0 : z = 0 := hz
+    have hw0 : w = 0 := hw
+    subst z
+    subst w
+    rw [shearedMap_zero, shearedMap_zero] at heq
+    exact Prod.ext (congrArg (fun q : X × F => q.1) heq) rfl
+  have hlocal :
+    ∀ p ∈ K ×ˢ {(0 : Z)}, IsLocalDiffeomorphAt 𝓘(ℝ, X × Z) 𝓘(ℝ, X × F) ∞ (shearedMap A T) p := by
+    rintro ⟨x, z⟩ ⟨hx, hz⟩
+    have hz0 : z = 0 := hz
+    subst z
+    apply
+      Smale.isLocalDiffeomorphAt_of_contMDiffOn (D := X × Z) (E := X × F) (M := X × F)
+        (hU.preimage continuous_fst) (show (x, (0 : Z)) ∈ Prod.fst ⁻¹' U from hKU hx)
+        (contDiffOn_shearedMap hA hT).contMDiffOn
+    rw [mfderiv_eq_fderiv,
+      (hasFDerivAt_shearedMap_zero
+          ((hA.contDiffAt (hU.mem_nhds (hKU hx))).differentiableAt (by simp))
+          ((hT.contDiffAt (hU.mem_nhds (hKU hx))).differentiableAt (by simp))).fderiv]
+    exact isInvertible_shearedBlock (A x) (T x) (hi x hx)
+  exact
+    Smale.exists_partialDiffeomorph_near_compact (hK.prod isCompact_singleton) hzeroInj hlocal
+      (hU.preimage continuous_fst) (fun _ hp => hKU hp.1)
+
+private def Degree.AxisCoordinates.tangentShear {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    (L : (ℝ × V) →L[ℝ] (ℝ × V)) : V →L[ℝ] ℝ :=
+  (ContinuousLinearMap.fst ℝ ℝ V).comp (L.comp (ContinuousLinearMap.inr ℝ ℝ V))
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Recognition/Smale6.lean b/LeanPool/HopfProblem/Recognition/Smale6.lean
new file mode 100644
index 000000000..beff5b6bf
--- /dev/null
+++ b/LeanPool/HopfProblem/Recognition/Smale6.lean
@@ -0,0 +1,5637 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Recognition.Degree2
+public import LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap2
+import all LeanPool.HopfProblem.Recognition.Smale1
+import all LeanPool.HopfProblem.Recognition.Smale2
+import all LeanPool.HopfProblem.Recognition.Smale3
+import all LeanPool.HopfProblem.Recognition.Smale4
+import all LeanPool.HopfProblem.Recognition.Smale5
+import all LeanPool.HopfProblem.Recognition.Degree1
+import all LeanPool.HopfProblem.Recognition.Degree2
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap2
+
+/-!
+# Hopf problem: recognition · smale 6
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem MorseCancel.exists_regular_cubic_chart_of_native_vertical_field {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {m : ℕ}
+    [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M] (σ : Fin m → ℝ) {a : ℝ} (ha : 0 < a)
+    (Φ : PartialDiffeomorph 𝓘(ℝ, (Fin m → ℝ) × ℝ) 𝓘(ℝ, E) ((Fin m → ℝ) × ℝ) M ∞)
+    {U : Set (Fin m → ℝ)} (hsource : Φ.source = U ×ˢ Set.univ) (h0 : (0 : Fin m → ℝ) ∈ U)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hmodel :
+      ∀ y ∈ Φ.target,
+        V y =
+          Smale.FlowConstruction.partialChartField Φ.symm (fun _ : (Fin m → ℝ) × ℝ => (0, 1)) y)
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) :
+    ∃ Ψ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞,
+      Ψ.target = Φ.target ∧
+        Set.Ioo (-a) a ×ˢ {(0 : Fin m → ℝ)} ⊆ Ψ.source ∧
+          (∀ s, Ψ (s, 0) = F (cubicAxisClock a s) (Φ (0, 0))) ∧
+            (∀ x ∈ Ψ.target, V x = nativeCubicDescent σ Ψ (-(a ^ 2)) x) ∧
+              Ψ.source ⊆ Set.Ioo (-a) a ×ˢ Set.univ ∧ ∀ p, Ψ (cubicFlowCylinder σ a p) = Φ p := by
+  apply exists_native_regular_cubic_field_chart σ ha Φ hsource h0 V F hF (fun z => Φ (z, 0))
+  intro p hp
+  have hz : p.1 ∈ U := by rw [hsource] at hp; exact hp.1
+  simpa only [zero_add] using
+    (Degree.FlowSuspension.native_vertical_cylinder_flow Φ hsource hV hmodel F hF p.1 hz 0
+        p.2).symm
+
+private def Degree.FieldChartGluing.threeChartMap {Z M : Type*} (f₀ fₘ f₁ : (ℝ × Z) → M) (a b : ℝ)
+    (p : ℝ × Z) : M :=
+  if p.1 ≤ a then f₀ p else if b ≤ p.1 then f₁ p else fₘ p
+
+private theorem Degree.FieldChartGluing.threeChartMap_left_germ {Z M : Type*} [TopologicalSpace Z]
+     (f₀ fₘ f₁ : (ℝ × Z) → M) {a b : ℝ} {p : ℝ × Z} (hp : p.1 < a) :
+    threeChartMap f₀ fₘ f₁ a b =ᶠ[𝓝 p] f₀ := by
+  filter_upwards [continuousAt_fst.eventually (eventually_lt_nhds hp)] with q hq
+  simp only [threeChartMap, ite_eq_left hq.le]
+
+private theorem Degree.FieldChartGluing.threeChartMap_middle_germ {Z M : Type*} [TopologicalSpace Z]
+     (f₀ fₘ f₁ : (ℝ × Z) → M) {a b : ℝ} {p : ℝ × Z} (ha : a < p.1) (hb : p.1 < b) :
+    threeChartMap f₀ fₘ f₁ a b =ᶠ[𝓝 p] fₘ := by
+  filter_upwards [continuousAt_fst.eventually (eventually_gt_nhds ha),
+    continuousAt_fst.eventually (eventually_lt_nhds hb)] with q hqa hqb
+  simp only [threeChartMap, ite_eq_right (not_le_of_gt hqa), ite_eq_right (not_le_of_gt hqb)]
+
+private theorem Degree.FieldChartGluing.threeChartMap_right_germ {Z M : Type*} [TopologicalSpace Z]
+     (f₀ fₘ f₁ : (ℝ × Z) → M) {a b : ℝ} (hab : a < b) {p : ℝ × Z} (hp : b < p.1) :
+    threeChartMap f₀ fₘ f₁ a b =ᶠ[𝓝 p] f₁ := by
+  filter_upwards [continuousAt_fst.eventually (eventually_gt_nhds hp)] with q hq
+  simp only [threeChartMap, ite_eq_right (not_le_of_gt (hab.trans hq)), ite_eq_left hq.le]
+
+private theorem
+    Degree.FieldChartGluing.threeChartMap_left_closed_germ {Z M : Type*} [TopologicalSpace Z]
+    [Zero Z] (f₀ fₘ f₁ : (ℝ × Z) → M) {a b : ℝ} (hab : a < b) (heq : f₀ =ᶠ[𝓝 (a, (0 : Z))] fₘ)
+    {s : ℝ} (hs : s ≤ a) : threeChartMap f₀ fₘ f₁ a b =ᶠ[𝓝 (s, (0 : Z))] f₀ := by
+  rcases hs.lt_or_eq with hs | hs
+  · exact threeChartMap_left_germ f₀ fₘ f₁ hs
+  · subst s
+    filter_upwards [heq, continuousAt_fst.eventually (eventually_lt_nhds hab)] with p hp hpb
+    by_cases hpa : p.1 ≤ a
+    · simp only [threeChartMap, ite_eq_left hpa]
+    · simp only [threeChartMap, ite_eq_right hpa, ite_eq_right (not_le_of_gt hpb)]
+      exact hp.symm
+
+private theorem
+    Degree.FieldChartGluing.threeChartMap_right_closed_germ {Z M : Type*} [TopologicalSpace Z]
+    [Zero Z] (f₀ fₘ f₁ : (ℝ × Z) → M) {a b : ℝ} (hab : a < b) (heq : f₁ =ᶠ[𝓝 (b, (0 : Z))] fₘ)
+    {s : ℝ} (hs : b ≤ s) : threeChartMap f₀ fₘ f₁ a b =ᶠ[𝓝 (s, (0 : Z))] f₁ := by
+  rcases hs.eq_or_lt with hs | hs
+  · subst s
+    filter_upwards [heq, continuousAt_fst.eventually (eventually_gt_nhds hab)] with p hp hpa
+    by_cases hpb : b ≤ p.1
+    · simp only [threeChartMap, ite_eq_right (not_le_of_gt hpa), ite_eq_left hpb]
+    · simp only [threeChartMap, ite_eq_right (not_le_of_gt hpa), ite_eq_right hpb]
+      exact hp.symm
+  · exact threeChartMap_right_germ f₀ fₘ f₁ hab hs
+
+private theorem Degree.FieldChartGluing.exists_glued_three_native_field_charts {Z E M : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    (Φ₀ Φₘ Φ₁ : PartialDiffeomorph 𝓘(ℝ, ℝ × Z) 𝓘(ℝ, E) (ℝ × Z) M ∞) (W : (ℝ × Z) → ℝ × Z)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hfield₀ : ∀ y ∈ Φ₀.target, V y = Smale.FlowConstruction.partialChartField Φ₀.symm W y)
+    (hfieldₘ : ∀ y ∈ Φₘ.target, V y = Smale.FlowConstruction.partialChartField Φₘ.symm W y)
+    (hfield₁ : ∀ y ∈ Φ₁.target, V y = Smale.FlowConstruction.partialChartField Φ₁.symm W y)
+    {l a b r : ℝ} (hla : l ≤ a) (hab : a < b) (hbr : b ≤ r)
+    (hsource₀ : ∀ s ∈ Set.Icc l a, (s, (0 : Z)) ∈ Φ₀.source)
+    (hsourceₘ : ∀ s ∈ Set.Ioo a b, (s, (0 : Z)) ∈ Φₘ.source)
+    (hsource₁ : ∀ s ∈ Set.Icc b r, (s, (0 : Z)) ∈ Φ₁.source)
+    (hgerm₀ : (Φ₀ : (ℝ × Z) → M) =ᶠ[𝓝 (a, (0 : Z))] Φₘ)
+    (hgerm₁ : (Φ₁ : (ℝ × Z) → M) =ᶠ[𝓝 (b, (0 : Z))] Φₘ) (γ : ℝ → M)
+    (hinj : Set.InjOn γ (Set.Icc l r)) (haxis₀ : ∀ s ∈ Set.Icc l a, Φ₀ (s, 0) = γ s)
+    (haxisₘ : ∀ s ∈ Set.Ioo a b, Φₘ (s, 0) = γ s) (haxis₁ : ∀ s ∈ Set.Icc b r, Φ₁ (s, 0) = γ s) :
+    ∃ Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × Z) 𝓘(ℝ, E) (ℝ × Z) M ∞,
+      Set.Icc l r ×ˢ {(0 : Z)} ⊆ Φ.source ∧
+        (∀ s ∈ Set.Icc l r, Φ (s, 0) = γ s) ∧
+          (∀ y ∈ Φ.target, V y = Smale.FlowConstruction.partialChartField Φ.symm W y) ∧
+            ((Φ : (ℝ × Z) → M) =ᶠ[𝓝 (l, (0 : Z))] Φ₀) ∧
+              ((Φ : (ℝ × Z) → M) =ᶠ[𝓝 (r, (0 : Z))] Φ₁) := by
+  let f := threeChartMap Φ₀ Φₘ Φ₁ a b
+  have haxis (s : ℝ) (hs : s ∈ Set.Icc l r) : f (s, 0) = γ s := by
+    by_cases hsa : s ≤ a
+    · exact
+        (threeChartMap_left_closed_germ Φ₀ Φₘ Φ₁ hab hgerm₀ hsa).eq_of_nhds.trans
+          (haxis₀ s ⟨hs.1, hsa⟩)
+    · by_cases hbs : b ≤ s
+      · exact
+          (threeChartMap_right_closed_germ Φ₀ Φₘ Φ₁ hab hgerm₁ hbs).eq_of_nhds.trans
+            (haxis₁ s ⟨hbs, hs.2⟩)
+      · exact
+          (threeChartMap_middle_germ Φ₀ Φₘ Φ₁ (lt_of_not_ge hsa)
+                (lt_of_not_ge hbs)).eq_of_nhds.trans
+            (haxisₘ s ⟨lt_of_not_ge hsa, lt_of_not_ge hbs⟩)
+  have hfinj : Set.InjOn f (Set.Icc l r ×ˢ {(0 : Z)}) := by
+    rintro ⟨s, z⟩ ⟨hs, hz⟩ ⟨t, w⟩ ⟨ht, hw⟩ heq
+    have hz0 : z = 0 := hz
+    have hw0 : w = 0 := hw
+    subst z
+    subst w
+    rw [haxis s hs, haxis t ht] at heq
+    exact congrArg (fun s : ℝ => (s, (0 : Z))) (hinj hs ht heq)
+  have hlocal :
+    ∀ p ∈ Set.Icc l r ×ˢ {(0 : Z)},
+      ∃ Ψ : PartialDiffeomorph 𝓘(ℝ, ℝ × Z) 𝓘(ℝ, E) (ℝ × Z) M ∞,
+        p ∈ Ψ.source ∧
+          f =ᶠ[𝓝 p] Ψ ∧
+            ∀ y ∈ Ψ.target, V y = Smale.FlowConstruction.partialChartField Ψ.symm W y := by
+    rintro ⟨s, z⟩ ⟨hs, hz⟩
+    have hz0 : z = 0 := hz
+    subst z
+    by_cases hsa : s ≤ a
+    · exact
+        ⟨Φ₀, hsource₀ s ⟨hs.1, hsa⟩, threeChartMap_left_closed_germ Φ₀ Φₘ Φ₁ hab hgerm₀ hsa,
+          hfield₀⟩
+    · by_cases hbs : b ≤ s
+      · exact
+          ⟨Φ₁, hsource₁ s ⟨hbs, hs.2⟩, threeChartMap_right_closed_germ Φ₀ Φₘ Φ₁ hab hgerm₁ hbs,
+            hfield₁⟩
+      · exact
+          ⟨Φₘ, hsourceₘ s ⟨lt_of_not_ge hsa, lt_of_not_ge hbs⟩,
+            threeChartMap_middle_germ Φ₀ Φₘ Φ₁ (lt_of_not_ge hsa) (lt_of_not_ge hbs), hfieldₘ⟩
+  obtain ⟨Φ, hsource, hmap, hfield⟩ :=
+    exists_native_field_chart_near_compact f W V
+      (CompactIccSpace.isCompact_Icc.prod isCompact_singleton) hfinj hlocal
+  refine ⟨Φ, hsource, fun s hs => (hmap (s, 0)).trans (haxis s hs), hfield, ?_, ?_⟩
+  · filter_upwards [threeChartMap_left_closed_germ Φ₀ Φₘ Φ₁ hab hgerm₀ hla] with p hp
+    exact (hmap p).trans hp
+  · filter_upwards [threeChartMap_right_closed_germ Φ₀ Φₘ Φ₁ hab hgerm₁ hbr] with p hp
+    exact (hmap p).trans hp
+
+private theorem Degree.FieldChartGluing.injective_closed_axis_of_regular_chart {Z E M : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × Z) 𝓘(ℝ, E) (ℝ × Z) M ∞) {l r : ℝ} (γ : ℝ → M)
+    (hsource : ∀ s ∈ Set.Ioo l r, (s, (0 : Z)) ∈ Φ.source)
+    (hregular : ∀ s ∈ Set.Ioo l r, γ s = Φ (s, 0)) (hleft : γ l ∉ Φ.target)
+    (hright : γ r ∉ Φ.target) (hne : γ l ≠ γ r) : Set.InjOn γ (Set.Icc l r) := by
+  have htarget (s : ℝ) (hs : s ∈ Set.Ioo l r) : γ s ∈ Φ.target := by
+    rw [hregular s hs]
+    exact Φ.map_source' (hsource s hs)
+  have hleftOnly (s : ℝ) (hs : s ∈ Set.Icc l r) (heq : γ s = γ l) : s = l := by
+    by_cases hsl : s = l
+    · exact hsl
+    by_cases hsr : s = r
+    · subst s
+      exact (hne heq.symm).elim
+    have hi : s ∈ Set.Ioo l r := ⟨lt_of_le_of_ne hs.1 (Ne.symm hsl), lt_of_le_of_ne hs.2 hsr⟩
+    exact (hleft (heq ▸ htarget s hi)).elim
+  have hrightOnly (s : ℝ) (hs : s ∈ Set.Icc l r) (heq : γ s = γ r) : s = r := by
+    by_cases hsr : s = r
+    · exact hsr
+    by_cases hsl : s = l
+    · subst s
+      exact (hne heq).elim
+    have hi : s ∈ Set.Ioo l r := ⟨lt_of_le_of_ne hs.1 (Ne.symm hsl), lt_of_le_of_ne hs.2 hsr⟩
+    exact (hright (heq ▸ htarget s hi)).elim
+  intro s hs t ht heq
+  by_cases hsl : s = l
+  · subst s
+    exact (hleftOnly t ht heq.symm).symm
+  by_cases hsr : s = r
+  · subst s
+    exact (hrightOnly t ht heq.symm).symm
+  by_cases htl : t = l
+  · subst t
+    exact hleftOnly s hs heq
+  by_cases htr : t = r
+  · subst t
+    exact hrightOnly s hs heq
+  have hs' : s ∈ Set.Ioo l r := ⟨lt_of_le_of_ne hs.1 (Ne.symm hsl), lt_of_le_of_ne hs.2 hsr⟩
+  have ht' : t ∈ Set.Ioo l r := ⟨lt_of_le_of_ne ht.1 (Ne.symm htl), lt_of_le_of_ne ht.2 htr⟩
+  rw [hregular s hs', hregular t ht'] at heq
+  exact congrArg Prod.fst (Φ.toOpenPartialHomeomorph.injOn (hsource s hs') (hsource t ht') heq)
+
+private theorem Degree.FieldChartGluing.exists_closed_axis_native_field_chart {Z E M : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    (Φ₀ Φₘ Φ₁ : PartialDiffeomorph 𝓘(ℝ, ℝ × Z) 𝓘(ℝ, E) (ℝ × Z) M ∞) (W : (ℝ × Z) → ℝ × Z)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hfield₀ : ∀ y ∈ Φ₀.target, V y = Smale.FlowConstruction.partialChartField Φ₀.symm W y)
+    (hfieldₘ : ∀ y ∈ Φₘ.target, V y = Smale.FlowConstruction.partialChartField Φₘ.symm W y)
+    (hfield₁ : ∀ y ∈ Φ₁.target, V y = Smale.FlowConstruction.partialChartField Φ₁.symm W y)
+    {l a b r : ℝ} (hla : l < a) (hab : a < b) (hbr : b < r)
+    (hsource₀ : ∀ s ∈ Set.Icc l a, (s, (0 : Z)) ∈ Φ₀.source)
+    (hsourceₘ : ∀ s ∈ Set.Ioo l r, (s, (0 : Z)) ∈ Φₘ.source)
+    (hsource₁ : ∀ s ∈ Set.Icc b r, (s, (0 : Z)) ∈ Φ₁.source)
+    (hgerm₀ : (Φ₀ : (ℝ × Z) → M) =ᶠ[𝓝 (a, (0 : Z))] Φₘ)
+    (hgerm₁ : (Φ₁ : (ℝ × Z) → M) =ᶠ[𝓝 (b, (0 : Z))] Φₘ)
+    (haxis₀ : ∀ s ∈ Set.Ioc l a, Φ₀ (s, 0) = Φₘ (s, 0))
+    (haxis₁ : ∀ s ∈ Set.Ico b r, Φ₁ (s, 0) = Φₘ (s, 0)) (hleft : Φ₀ (l, 0) ∉ Φₘ.target)
+    (hright : Φ₁ (r, 0) ∉ Φₘ.target) (hne : Φ₀ (l, 0) ≠ Φ₁ (r, 0)) :
+    ∃ Φ : PartialDiffeomorph 𝓘(ℝ, ℝ × Z) 𝓘(ℝ, E) (ℝ × Z) M ∞,
+      Set.Icc l r ×ˢ {(0 : Z)} ⊆ Φ.source ∧
+        (∀ y ∈ Φ.target, V y = Smale.FlowConstruction.partialChartField Φ.symm W y) ∧
+          Φ (l, 0) = Φ₀ (l, 0) ∧
+            Φ (r, 0) = Φ₁ (r, 0) ∧
+              (∀ s ∈ Set.Ioo l r, Φ (s, 0) = Φₘ (s, 0)) ∧
+                ((Φ : (ℝ × Z) → M) =ᶠ[𝓝 (l, (0 : Z))] Φ₀) ∧
+                  ((Φ : (ℝ × Z) → M) =ᶠ[𝓝 (r, (0 : Z))] Φ₁) := by
+  let γ : ℝ → M := fun s => threeChartMap Φ₀ Φₘ Φ₁ a b (s, 0)
+  have hγ₀ (s : ℝ) (hs : s ≤ a) : γ s = Φ₀ (s, 0) :=
+    (threeChartMap_left_closed_germ Φ₀ Φₘ Φ₁ hab hgerm₀ hs).eq_of_nhds
+  have hγ₁ (s : ℝ) (hs : b ≤ s) : γ s = Φ₁ (s, 0) :=
+    (threeChartMap_right_closed_germ Φ₀ Φₘ Φ₁ hab hgerm₁ hs).eq_of_nhds
+  have hγₘ (s : ℝ) (hs : s ∈ Set.Ioo a b) : γ s = Φₘ (s, 0) :=
+    (threeChartMap_middle_germ Φ₀ Φₘ Φ₁ hs.1 hs.2).eq_of_nhds
+  have hregular (s : ℝ) (hs : s ∈ Set.Ioo l r) : γ s = Φₘ (s, 0) := by
+    by_cases hsa : s ≤ a
+    · exact (hγ₀ s hsa).trans (haxis₀ s ⟨hs.1, hsa⟩)
+    by_cases hbs : b ≤ s
+    · exact (hγ₁ s hbs).trans (haxis₁ s ⟨hbs, hs.2⟩)
+    exact hγₘ s ⟨lt_of_not_ge hsa, lt_of_not_ge hbs⟩
+  have hinj : Set.InjOn γ (Set.Icc l r) :=
+    injective_closed_axis_of_regular_chart Φₘ γ hsourceₘ hregular
+      (by rw [hγ₀ l hla.le]; exact hleft) (by rw [hγ₁ r hbr.le]; exact hright)
+      (by rw [hγ₀ l hla.le, hγ₁ r hbr.le]; exact hne)
+  obtain ⟨Φ, hsource, haxis, hfield, hg₀, hg₁⟩ :=
+    exists_glued_three_native_field_charts Φ₀ Φₘ Φ₁ W V hfield₀ hfieldₘ hfield₁ hla.le hab hbr.le
+      hsource₀ (fun s hs => hsourceₘ s ⟨hla.trans hs.1, hs.2.trans hbr⟩) hsource₁ hgerm₀ hgerm₁ γ
+      hinj (fun s hs => (hγ₀ s hs.2).symm) (fun s hs => (hγₘ s hs).symm)
+      (fun s hs => (hγ₁ s hs.1).symm)
+  have hlr : l ≤ r := (hla.trans (hab.trans hbr)).le
+  refine
+    ⟨Φ, hsource, hfield, (haxis l ⟨le_rfl, hlr⟩).trans (hγ₀ l hla.le),
+      (haxis r ⟨hlr, le_rfl⟩).trans (hγ₁ r hbr.le), ?_, hg₀, hg₁⟩
+  exact fun s hs => (haxis s ⟨hs.1.le, hs.2.le⟩).trans (hregular s hs)
+
+private theorem
+    MorseCancel.exists_cubic_spatial_overlap_germ {m : ℕ} {M : Type*} (σ : Fin m → ℝ) {a : ℝ}
+    (ha : 0 < a) (Φ Ψ : Model m → M) {c r : ℝ} (hr : 0 < r) {l : Filter ℝ} [Filter.NeBot l]
+    (hlim : Filter.Tendsto (fun t => cubicFlowCylinder σ a (0, t)) l (𝓝 (c, (0 : Fin m → ℝ))))
+    {J : Set ℝ} (hJ : IsOpen J) (hJl : J ∈ l)
+    (hmatch :
+      ∀ᶠ z : Fin m → ℝ in 𝓝 0,
+        ∀ t ∈ J,
+          cubicFlowCylinder σ a (z, t) ∈ Metric.closedBall (c, (0 : Fin m → ℝ)) r →
+            Φ (cubicFlowCylinder σ a (z, t)) = Ψ (cubicFlowCylinder σ a (z, t))) :
+    ∃ T ∈ J,
+      cubicFlowCylinder σ a (0, T) ∈ Metric.ball (c, (0 : Fin m → ℝ)) r ∧
+        Φ =ᶠ[𝓝 (cubicFlowCylinder σ a (0, T))] Ψ := by
+  have hnear : ∀ᶠ t in l, cubicFlowCylinder σ a (0, t) ∈ Metric.ball (c, (0 : Fin m → ℝ)) r :=
+    hlim.eventually (Metric.ball_mem_nhds _ hr)
+  have hJevent : ∀ᶠ t in l, t ∈ J := hJl
+  obtain ⟨T, hTJ, hTball⟩ := (hJevent.and hnear).exists
+  let C := cubicFlowCylinderChart σ ha
+  let p₀ : (Fin m → ℝ) × ℝ := (0, T)
+  have htime : (fun p => Φ (C p)) =ᶠ[𝓝 p₀] (fun p => Ψ (C p)) := by
+    have hball : ∀ᶠ p in 𝓝 p₀, C p ∈ Metric.ball (c, (0 : Fin m → ℝ)) r :=
+      (contDiff_cubicFlowCylinder σ a).continuous.continuousAt.eventually
+        (Metric.isOpen_ball.mem_nhds hTball)
+    filter_upwards [continuousAt_fst.eventually hmatch,
+      continuousAt_snd.eventually (hJ.mem_nhds hTJ), hball] with p hp hpt hpball
+    exact hp p.2 hpt (Metric.ball_subset_closedBall hpball)
+  have hCt : C p₀ ∈ C.target := C.map_source' (Set.mem_univ p₀)
+  have hi : C.symm (C p₀) = p₀ := C.left_inv' (Set.mem_univ p₀)
+  have hInv : Filter.Tendsto C.symm (𝓝 (C p₀)) (𝓝 p₀) := by
+    have hh : Filter.Tendsto C.symm (𝓝 (C p₀)) (𝓝 (C.symm (C p₀))) :=
+      C.toOpenPartialHomeomorph.symm.continuousAt hCt |>.tendsto
+    rwa [hi] at hh
+  refine ⟨T, hTJ, hTball, ?_⟩
+  filter_upwards [hInv.eventually htime, C.open_target.mem_nhds hCt] with p hp hpt
+  have hright : C (C.symm p) = p := C.right_inv' hpt
+  change Φ (C (C.symm p)) = Ψ (C (C.symm p)) at hp
+  rwa [hright] at hp
+
+private theorem MorseCancel.cubicFlowCylinder_forward_stays_box {m : ℕ} (σ : Fin m → ℝ) {a : ℝ}
+    (ha : 0 < a) (z : Fin m → ℝ) {c r T : ℝ} (hr : 0 < r)
+    (hlim :
+      Filter.Tendsto (fun t => cubicFlowCylinder σ a (z, t)) Filter.atTop
+        (𝓝 (c, (0 : Fin m → ℝ))))
+    (hT : cubicFlowCylinder σ a (z, T) ∈ Metric.closedBall (c, (0 : Fin m → ℝ)) r) {t : ℝ}
+    (ht : T ≤ t) : cubicFlowCylinder σ a (z, t) ∈ Metric.closedBall (c, (0 : Fin m → ℝ)) r := by
+  have hnear :
+    ∀ᶠ u in Filter.atTop, cubicFlowCylinder σ a (z, u) ∈ Metric.ball (c, (0 : Fin m → ℝ)) r :=
+    hlim.eventually (Metric.ball_mem_nhds _ hr)
+  obtain ⟨u, hu, hut⟩ := (hnear.and (Filter.eventually_ge_atTop t)).exists
+  exact cubicFlowCylinder_stays_axis_ball σ ha z ⟨ht, hut⟩ hT (Metric.ball_subset_closedBall hu)
+
+private theorem MorseCancel.cubicFlowCylinder_backward_stays_box {m : ℕ} (σ : Fin m → ℝ) {a : ℝ}
+    (ha : 0 < a) (z : Fin m → ℝ) {c r T : ℝ} (hr : 0 < r)
+    (hlim :
+      Filter.Tendsto (fun t => cubicFlowCylinder σ a (z, t)) Filter.atBot
+        (𝓝 (c, (0 : Fin m → ℝ))))
+    (hT : cubicFlowCylinder σ a (z, T) ∈ Metric.closedBall (c, (0 : Fin m → ℝ)) r) {t : ℝ}
+    (ht : t ≤ T) : cubicFlowCylinder σ a (z, t) ∈ Metric.closedBall (c, (0 : Fin m → ℝ)) r := by
+  have hnear :
+    ∀ᶠ u in Filter.atBot, cubicFlowCylinder σ a (z, u) ∈ Metric.ball (c, (0 : Fin m → ℝ)) r :=
+    hlim.eventually (Metric.ball_mem_nhds _ hr)
+  obtain ⟨u, hu, hut⟩ := (hnear.and (Filter.eventually_le_atBot t)).exists
+  exact cubicFlowCylinder_stays_axis_ball σ ha z ⟨hut, ht⟩ (Metric.ball_subset_closedBall hu) hT
+
+private theorem MorseCancel.strictMono_cubicAxisParameter {a : ℝ} (ha : 0 < a) :
+    StrictMono (cubicAxisParameter a) := by
+  intro s t hst
+  exact mul_lt_mul_of_pos_left (strictMono_tanh (mul_lt_mul_of_pos_left hst ha)) ha
+
+private theorem MorseCancel.tendsto_cubicFlowCylinder_axis_atTop {m : ℕ} (σ : Fin m → ℝ) {a : ℝ}
+    (ha : 0 < a) :
+    Filter.Tendsto (fun t => cubicFlowCylinder σ a (0, t)) Filter.atTop
+      (𝓝 (a, (0 : Fin m → ℝ))) := by
+  simpa only [cubicFlowCylinder_axis] using tendsto_cubicModelOrbit_atTop (m := m) ha
+
+private theorem MorseCancel.tendsto_cubicFlowCylinder_axis_atBot {m : ℕ} (σ : Fin m → ℝ) {a : ℝ}
+    (ha : 0 < a) :
+    Filter.Tendsto (fun t => cubicFlowCylinder σ a (0, t)) Filter.atBot
+      (𝓝 (-a, (0 : Fin m → ℝ))) := by
+  simpa only [cubicFlowCylinder_axis] using tendsto_cubicModelOrbit_atBot (m := m) ha
+
+private theorem
+    MorseCancel.cubicFlowCylinder_zero_clock {m : ℕ} (σ : Fin m → ℝ) {a s : ℝ} (ha : 0 < a)
+    (hs : s ∈ Set.Ioo (-a) a) :
+    cubicFlowCylinder σ a (0, cubicAxisClock a s) = (s, (0 : Fin m → ℝ)) := by
+  rw [cubicFlowCylinder_axis]
+  change (cubicAxisParameter a (cubicAxisClock a s), 0) = (s, 0)
+  rw [cubicAxisParameter_clock ha hs]
+
+private theorem
+    MorseCancel.incoming_axis_segment_in_box {m : ℕ} (σ : Fin m → ℝ) {a r T : ℝ} (ha : 0 < a)
+    (hr : 0 < r)
+    (hstart : cubicFlowCylinder σ a (0, T) ∈ Metric.closedBall (a, (0 : Fin m → ℝ)) r) :
+    ∀ s ∈ Set.Icc (cubicAxisParameter a T) a,
+      (s, (0 : Fin m → ℝ)) ∈ Metric.closedBall (a, (0 : Fin m → ℝ)) r ∧
+        (s < a → T ≤ cubicAxisClock a s) := by
+  intro s hs
+  rcases hs.2.lt_or_eq with hsa | hsa
+  · have hs' : s ∈ Set.Ioo (-a) a := ⟨(cubicAxisParameter_mem ha T).1.trans_le hs.1, hsa⟩
+    have ht : T ≤ cubicAxisClock a s := by
+      apply (strictMono_cubicAxisParameter ha).le_iff_le.mp
+      rw [cubicAxisParameter_clock ha hs']
+      exact hs.1
+    have hb :=
+      cubicFlowCylinder_forward_stays_box σ ha 0 hr (tendsto_cubicFlowCylinder_axis_atTop σ ha)
+        hstart ht
+    rw [cubicFlowCylinder_zero_clock σ ha hs'] at hb
+    exact ⟨hb, fun _ => ht⟩
+  · subst s
+    exact ⟨Metric.mem_closedBall_self hr.le, fun h => (lt_irrefl _ h).elim⟩
+
+private theorem
+    MorseCancel.outgoing_axis_segment_in_box {m : ℕ} (σ : Fin m → ℝ) {a r T : ℝ} (ha : 0 < a)
+    (hr : 0 < r)
+    (hstart : cubicFlowCylinder σ a (0, T) ∈ Metric.closedBall (-a, (0 : Fin m → ℝ)) r) :
+    ∀ s ∈ Set.Icc (-a) (cubicAxisParameter a T),
+      (s, (0 : Fin m → ℝ)) ∈ Metric.closedBall (-a, (0 : Fin m → ℝ)) r ∧
+        (-a < s → cubicAxisClock a s ≤ T) := by
+  intro s hs
+  rcases hs.1.eq_or_lt with has | has
+  · subst s
+    exact ⟨Metric.mem_closedBall_self hr.le, fun h => (lt_irrefl _ h).elim⟩
+  · have hs' : s ∈ Set.Ioo (-a) a := ⟨has, hs.2.trans_lt (cubicAxisParameter_mem ha T).2⟩
+    have ht : cubicAxisClock a s ≤ T := by
+      apply (strictMono_cubicAxisParameter ha).le_iff_le.mp
+      rw [cubicAxisParameter_clock ha hs']
+      exact hs.2
+    have hb :=
+      cubicFlowCylinder_backward_stays_box σ ha 0 hr (tendsto_cubicFlowCylinder_axis_atBot σ ha)
+        hstart ht
+    rw [cubicFlowCylinder_zero_clock σ ha hs'] at hb
+    exact ⟨hb, fun _ => ht⟩
+
+private theorem
+    MorseCancel.exists_matched_full_cubic_field_chart {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M] {m : ℕ} (σ : Fin m → ℝ)
+    {a : ℝ} (ha : 0 < a) (Φq Φm Φp : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hqfield : ∀ y ∈ Φq.target, V y = nativeCubicDescent σ Φq (-(a ^ 2)) y)
+    (hmfield : ∀ y ∈ Φm.target, V y = nativeCubicDescent σ Φm (-(a ^ 2)) y)
+    (hpfield : ∀ y ∈ Φp.target, V y = nativeCubicDescent σ Φp (-(a ^ 2)) y) {rq rp : ℝ}
+    (hrq : 0 < rq) (hrp : 0 < rp) (hboxq : Metric.closedBall (-a, (0 : Fin m → ℝ)) rq ⊆ Φq.source)
+    (hboxp : Metric.closedBall (a, (0 : Fin m → ℝ)) rp ⊆ Φp.source)
+    (hmiddle : ∀ s ∈ Set.Ioo (-a) a, (s, (0 : Fin m → ℝ)) ∈ Φm.source)
+    (hleft : Φq (-a, 0) ∉ Φm.target) (hright : Φp (a, 0) ∉ Φm.target)
+    (hne : Φq (-a, 0) ≠ Φp (a, 0))
+    (hmatchq :
+      ∀ᶠ z : Fin m → ℝ in 𝓝 0,
+        ∀ t : ℝ,
+          t ≤ -1 →
+            cubicFlowCylinder σ a (z, t) ∈ Metric.closedBall (-a, (0 : Fin m → ℝ)) rq →
+              Φq (cubicFlowCylinder σ a (z, t)) = Φm (cubicFlowCylinder σ a (z, t)))
+    (hmatchp :
+      ∀ᶠ z : Fin m → ℝ in 𝓝 0,
+        ∀ t : ℝ,
+          2 ≤ t →
+            cubicFlowCylinder σ a (z, t) ∈ Metric.closedBall (a, (0 : Fin m → ℝ)) rp →
+              Φp (cubicFlowCylinder σ a (z, t)) = Φm (cubicFlowCylinder σ a (z, t))) :
+    ∃ Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞,
+      Set.Icc (-a) a ×ˢ {(0 : Fin m → ℝ)} ⊆ Φ.source ∧
+        (∀ y ∈ Φ.target, V y = nativeCubicDescent σ Φ (-(a ^ 2)) y) ∧
+          Φ (-a, 0) = Φq (-a, 0) ∧
+            Φ (a, 0) = Φp (a, 0) ∧
+              (∀ s ∈ Set.Ioo (-a) a, Φ (s, 0) = Φm (s, 0)) ∧
+                ((Φ : Model m → M) =ᶠ[𝓝 (-a, (0 : Fin m → ℝ))] Φq) ∧
+                  ((Φ : Model m → M) =ᶠ[𝓝 (a, (0 : Fin m → ℝ))] Φp) := by
+  have hqmatch :
+    ∀ᶠ z : Fin m → ℝ in 𝓝 0,
+      ∀ t ∈ Set.Iio (-1 : ℝ),
+        cubicFlowCylinder σ a (z, t) ∈ Metric.closedBall (-a, (0 : Fin m → ℝ)) rq →
+          Φq (cubicFlowCylinder σ a (z, t)) = Φm (cubicFlowCylinder σ a (z, t)) := by
+    filter_upwards [hmatchq] with z hz
+    exact fun t ht => hz t ht.le
+  have hpmatch :
+    ∀ᶠ z : Fin m → ℝ in 𝓝 0,
+      ∀ t ∈ Set.Ioi (2 : ℝ),
+        cubicFlowCylinder σ a (z, t) ∈ Metric.closedBall (a, (0 : Fin m → ℝ)) rp →
+          Φp (cubicFlowCylinder σ a (z, t)) = Φm (cubicFlowCylinder σ a (z, t)) := by
+    filter_upwards [hmatchp] with z hz
+    exact fun t ht => hz t ht.le
+  obtain ⟨Tq, hTq, hqball, hgq⟩ :=
+    exists_cubic_spatial_overlap_germ σ ha Φq Φm hrq (tendsto_cubicFlowCylinder_axis_atBot σ ha)
+      isOpen_Iio (Filter.Iio_mem_atBot (-1 : ℝ)) hqmatch
+  obtain ⟨Tp, hTp, hpball, hgp⟩ :=
+    exists_cubic_spatial_overlap_germ σ ha Φp Φm hrp (tendsto_cubicFlowCylinder_axis_atTop σ ha)
+      isOpen_Ioi (Filter.Ioi_mem_atTop (2 : ℝ)) hpmatch
+  have hcutq := cubicAxisParameter_mem ha Tq
+  have hcutp := cubicAxisParameter_mem ha Tp
+  have horder : cubicAxisParameter a Tq < cubicAxisParameter a Tp :=
+    strictMono_cubicAxisParameter ha (by change Tq < -1 at hTq; change 2 < Tp at hTp; linarith)
+  have hgq' : (Φq : Model m → M) =ᶠ[𝓝 (cubicAxisParameter a Tq, 0)] Φm := by
+    simpa only [cubicFlowCylinder_axis, cubicModelOrbit] using hgq
+  have hgp' : (Φp : Model m → M) =ᶠ[𝓝 (cubicAxisParameter a Tp, 0)] Φm := by
+    simpa only [cubicFlowCylinder_axis, cubicModelOrbit] using hgp
+  have hqsegment := outgoing_axis_segment_in_box σ ha hrq (Metric.ball_subset_closedBall hqball)
+  have hpsegment := incoming_axis_segment_in_box σ ha hrp (Metric.ball_subset_closedBall hpball)
+  have hqaxis (s : ℝ) (hs : s ∈ Set.Ioc (-a) (cubicAxisParameter a Tq)) : Φq (s, 0) = Φm (s, 0) :=
+    by
+    have hs' : s ∈ Set.Ioo (-a) a := ⟨hs.1, hs.2.trans_lt hcutq.2⟩
+    obtain ⟨hb, ht⟩ := hqsegment s ⟨hs.1.le, hs.2⟩
+    have hball :
+      cubicFlowCylinder σ a (0, cubicAxisClock a s) ∈
+        Metric.closedBall (-a, (0 : Fin m → ℝ)) rq := by
+      rw [cubicFlowCylinder_zero_clock σ ha hs']; exact hb
+    have hh := hmatchq.self_of_nhds (cubicAxisClock a s) ((ht hs.1).trans hTq.le) hball
+    simpa only [cubicFlowCylinder_zero_clock σ ha hs'] using hh
+  have hpaxis (s : ℝ) (hs : s ∈ Set.Ico (cubicAxisParameter a Tp) a) : Φp (s, 0) = Φm (s, 0) := by
+    have hs' : s ∈ Set.Ioo (-a) a := ⟨hcutp.1.trans_le hs.1, hs.2⟩
+    obtain ⟨hb, ht⟩ := hpsegment s ⟨hs.1, hs.2.le⟩
+    have hball :
+      cubicFlowCylinder σ a (0, cubicAxisClock a s) ∈ Metric.closedBall (a, (0 : Fin m → ℝ)) rp :=
+      by rw [cubicFlowCylinder_zero_clock σ ha hs']; exact hb
+    have hh := hmatchp.self_of_nhds (cubicAxisClock a s) (hTp.le.trans (ht hs.2)) hball
+    simpa only [cubicFlowCylinder_zero_clock σ ha hs'] using hh
+  exact
+    Degree.FieldChartGluing.exists_closed_axis_native_field_chart Φq Φm Φp
+      (cubicDescent σ (-(a ^ 2))) V hqfield hmfield hpfield hcutq.1 horder hcutp.2
+      (fun s hs => hboxq (hqsegment s hs).1) hmiddle (fun s hs => hboxp (hpsegment s hs).1) hgq'
+      hgp' hqaxis hpaxis hleft hright hne
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_full_cubic_chart_from_corrected_cylinder {Z E M : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) 1 M] [T2Space M] {m : ℕ}
+    {V W : (x : M) → TangentSpace 𝓘(ℝ, E) x} (σ : Fin m → ℝ) (hσ : ∀ i, σ i = -1 ∨ σ i = 1)
+    {a : ℝ} (ha : 0 < a) (Φq Φp : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (A : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, E) (Z × ℝ) M ∞) {U : Set Z}
+    (hAsource : A.source = U ×ˢ Set.univ)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hqfield : ∀ y ∈ Φq.target, V y = nativeCubicDescent σ Φq (-(a ^ 2)) y)
+    (hpfield : ∀ y ∈ Φp.target, V y = nativeCubicDescent σ Φp (-(a ^ 2)) y)
+    (hAfield :
+      ∀ y ∈ A.target,
+        V y = Smale.FlowConstruction.partialChartField A.symm (fun _ : Z × ℝ => (0, 1)) y)
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (L₁ : Smale.MorseHandle.NegativeSpace σ ≃L[ℝ] Smale.MorseHandle.NegativeSpace σ)
+    (L₂ : Smale.MorseHandle.PositiveSpace σ ≃L[ℝ] Smale.MorseHandle.PositiveSpace σ)
+    (Q P : (Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ) → Z)
+    (v₀ v₁ : (Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ) → ℝ)
+    {Oq Op : Set (Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ)}
+    (hOq : IsOpen Oq) (hOp : IsOpen Op) (h0q : 0 ∈ Oq) (h0p : 0 ∈ Op) (hQU : ∀ u ∈ Oq, Q u ∈ U)
+    (hPU : ∀ u ∈ Op, P u ∈ U) {Rq Rp Tq Tp : ℝ} (hRq : 0 < Rq) (hRp : 0 < Rp)
+    (hboxq : Metric.closedBall (-a, (0 : Fin m → ℝ)) Rq ⊆ Φq.source)
+    (hboxp : Metric.closedBall (a, (0 : Fin m → ℝ)) Rp ⊆ Φp.source)
+    (hsliceq :
+      ∀ u ∈ Oq,
+        cubicFlowCylinder σ a ((Smale.MorseHandle.splitCoordinates σ).symm u, Tq) ∈
+          Metric.closedBall (-a, (0 : Fin m → ℝ)) Rq)
+    (hslicep :
+      ∀ u ∈ Op,
+        cubicFlowCylinder σ a ((Smale.MorseHandle.splitCoordinates σ).symm u, Tp) ∈
+          Metric.closedBall (a, (0 : Fin m → ℝ)) Rp)
+    (hphaseq :
+      ∀ u ∈ Oq,
+        Φq (cubicFlowCylinder σ a ((Smale.MorseHandle.splitCoordinates σ).symm u, Tq)) =
+          A (Q u, Tq + v₀ u))
+    (hphasep :
+      ∀ u ∈ Op,
+        Φp (cubicFlowCylinder σ a ((Smale.MorseHandle.splitCoordinates σ).symm u, Tp)) =
+          A (P u, Tp + v₁ u))
+    (Ξ :
+      PartialDiffeomorph
+        𝓘(ℝ, (Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ) × ℝ) 𝓘(ℝ, E)
+        ((Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ) × ℝ) M ∞)
+    {O : Set (Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ)}
+    (hO : IsOpen O) (h0O : 0 ∈ O) (hΞsource : Ξ.source = O ×ˢ Set.univ)
+    (hΞtarget : Ξ.target = A.target)
+    (hW : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, W x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hΞfield :
+      ∀ y ∈ Ξ.target,
+        W y =
+          Smale.FlowConstruction.partialChartField Ξ.symm
+            (fun _ :
+                (Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ) × ℝ =>
+              (0, 1))
+            y)
+    (G : Flow ℝ M) (hG : ∀ x, IsMIntegralCurve (fun t => G t x) W)
+    (hWq : ∀ᶠ y in 𝓝 (Φq (-a, 0)), W y = V y) (hWp : ∀ᶠ y in 𝓝 (Φp (a, 0)), W y = V y)
+    (hne : Φq (-a, 0) ≠ Φp (a, 0))
+    (hleft :
+      ∀ᶠ u in 𝓝 (0 : Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ),
+        ∀ t : ℝ, t ≤ -1 → Ξ (u, t) = A (Q u, t + v₀ u))
+    (hright :
+      ∀ᶠ u in 𝓝 (0 : Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ),
+        ∀ t : ℝ, 2 ≤ t → Ξ (u, t) = A (P (L₁ u.1, L₂ u.2), t + v₁ (L₁ u.1, L₂ u.2))) :
+    ∃ Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞,
+      Set.Icc (-a) a ×ˢ {(0 : Fin m → ℝ)} ⊆ Φ.source ∧
+        (∀ y ∈ Φ.target, W y = nativeCubicDescent σ Φ (-(a ^ 2)) y) ∧
+          Φ (-a, 0) = Φq (-a, 0) ∧ Φ (a, 0) = Φp (a, 0) ∧ Φ (0, 0) = Ξ (0, 0) := by
+  let e := Smale.MorseHandle.splitCoordinates σ
+  let L := L₁.prodCongr L₂
+  let T := splitTransverseChange e L₁ L₂
+  let D := transverseFieldChange T
+  have hqsrc : (-a, (0 : Fin m → ℝ)) ∈ Φq.source := hboxq (Metric.mem_closedBall_self hRq.le)
+  have hpsrc : (a, (0 : Fin m → ℝ)) ∈ Φp.source := hboxp (Metric.mem_closedBall_self hRp.le)
+  obtain ⟨Ψq, rq, hrq, hΨqbox, hΨqsub, _, hΨqmap, hΨqfield⟩ :=
+    Degree.FieldChartGluing.exists_controlled_field_germ_chart Φq (cubicDescent σ (-(a ^ 2))) V W
+      hqfield hqsrc hWq Metric.isOpen_ball (Metric.mem_ball_self hRq)
+  have hcontrolq :
+    Metric.closedBall (-a, (0 : Fin m → ℝ)) rq ⊆ Metric.closedBall (-a, (0 : Fin m → ℝ)) Rq :=
+    fun p hp => Metric.ball_subset_closedBall (hΨqsub (hΨqbox hp)).2
+  obtain ⟨ΦpB, _, hpBsource, hpBaxis, hpBfield, hpBflow⟩ :=
+    exists_signed_block_changed_cubic_chart σ hσ L₁ L₂ Φp V (-(a ^ 2)) hpfield
+  have hDcenter : D (a, 0) = (a, 0) := by change (a, T 0) = (a, 0); rw [map_zero]
+  have hOpcoord : IsOpen (D ⁻¹' Metric.ball (a, (0 : Fin m → ℝ)) Rp) :=
+    Metric.isOpen_ball.preimage D.continuous
+  have hpO : (a, (0 : Fin m → ℝ)) ∈ D ⁻¹' Metric.ball (a, (0 : Fin m → ℝ)) Rp := by
+    change D (a, 0) ∈ Metric.ball (a, (0 : Fin m → ℝ)) Rp
+    rw [hDcenter]
+    exact Metric.mem_ball_self hRp
+  have hWpB : ∀ᶠ y in 𝓝 (ΦpB (a, 0)), W y = V y := by rw [hpBaxis]; exact hWp
+  obtain ⟨Ψp, rp, hrp, hΨpbox, hΨpsub, _, hΨpmap, hΨpfield⟩ :=
+    Degree.FieldChartGluing.exists_controlled_field_germ_chart ΦpB (cubicDescent σ (-(a ^ 2))) V W
+      hpBfield ((hpBsource a).mpr hpsrc) hWpB hOpcoord hpO
+  have hnewp (z : Fin m → ℝ) (t : ℝ) :
+    Ψp (cubicFlowCylinder σ a (z, t)) = Φp (cubicFlowCylinder σ a (e.symm (L (e z)), t)) := by
+    have hh := hpBflow a t (e z)
+    change
+      ΦpB (cubicFlowCylinder σ a (e.symm (e z), t)) =
+        Φp (cubicFlowCylinder σ a (e.symm (L (e z)), t)) at hh
+    rw [e.symm_apply_apply] at hh
+    exact (hΨpmap _).trans hh
+  have hcontrolp (z : Fin m → ℝ) (t : ℝ)
+    (hp : cubicFlowCylinder σ a (z, t) ∈ Metric.closedBall (a, (0 : Fin m → ℝ)) rp) :
+    cubicFlowCylinder σ a (e.symm (L (e z)), t) ∈ Metric.closedBall (a, (0 : Fin m → ℝ)) Rp := by
+    have hb : D (cubicFlowCylinder σ a (z, t)) ∈ Metric.ball (a, (0 : Fin m → ℝ)) Rp :=
+      (hΨpsub (hΨpbox hp)).2
+    have hc : D (cubicFlowCylinder σ a (z, t)) = cubicFlowCylinder σ a (e.symm (L (e z)), t) :=
+      signed_block_change_cubic_cylinder σ hσ L₁ L₂ a t z
+    rw [hc] at hb
+    exact Metric.ball_subset_closedBall hb
+  let R := Smale.PartialChart.restrictTarget e.toDiffeomorph.toPartialDiffeomorph hO
+  have hRtarget : R.target = O := by
+    ext u
+    change
+      (u ∈
+            (Set.univ :
+              Set (Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ)) ∧
+          u ∈ O) ↔
+        u ∈ O
+    simp only [Set.mem_univ, true_and]
+  have hR0 : (0 : Fin m → ℝ) ∈ R.source := by
+    change (0 : Fin m → ℝ) ∈ Set.univ ∧ e 0 ∈ O
+    rw [map_zero]
+    exact ⟨Set.mem_univ _, h0O⟩
+  obtain ⟨B₀, hBsource, hBtarget, hBmap, hBfield⟩ :=
+    Degree.FlowSuspension.exists_native_phase_cylinder Ξ hΞsource R hRtarget (fun _ => (0 : ℝ))
+      contDiff_const W hΞfield
+  obtain ⟨Φm, hmTarget, hmidAxis, _, hmField, _, hcompose⟩ :=
+    exists_regular_cubic_chart_of_native_vertical_field σ ha B₀ hBsource hR0 W hW hBfield G hG
+  have hmid (z : Fin m → ℝ) (t : ℝ) : Φm (cubicFlowCylinder σ a (z, t)) = Ξ (e z, t) := by
+    rw [hcompose, hBmap]
+    change Ξ (e z, t + 0) = Ξ (e z, t)
+    rw [add_zero]
+  have hmTargetA : Φm.target = A.target := hmTarget.trans (hBtarget.trans hΞtarget)
+  have hzeroAt (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞) {c : ℝ}
+    (hc : (c, (0 : Fin m → ℝ)) ∈ Φ.source) (hcrit : c ^ 2 = a ^ 2)
+    (hf : ∀ y ∈ Φ.target, V y = nativeCubicDescent σ Φ (-(a ^ 2)) y) : V (Φ (c, 0)) = 0 := by
+    rw [hf _ (Φ.map_source' hc)]
+    apply (partialChartField_zero_iff Φ (cubicDescent σ (-(a ^ 2))) (Φ.map_source' hc)).mpr
+    have hi : Φ.symm (Φ (c, (0 : Fin m → ℝ))) = (c, 0) := Φ.left_inv' hc
+    rw [hi]
+    ext i <;> simp [cubicDescent, hcrit]
+  have hzeroq : V (Φq (-a, 0)) = 0 := hzeroAt Φq hqsrc (by ring) hqfield
+  have hzerop : V (Φp (a, 0)) = 0 := hzeroAt Φp hpsrc rfl hpfield
+  have hAregular (y : M) (hy : y ∈ A.target) : V y ≠ 0 := by
+    intro hz
+    rw [hAfield y hy] at hz
+    have hh := (partialChartField_zero_iff A (fun _ : Z × ℝ => (0, 1)) hy).mp hz
+    exact one_ne_zero (congrArg Prod.snd hh)
+  have hqval : Ψq (-a, 0) = Φq (-a, 0) := hΨqmap _
+  have hpval : Ψp (a, 0) = Φp (a, 0) := (hΨpmap _).trans (hpBaxis a)
+  have hqnot : Ψq (-a, 0) ∉ Φm.target := by
+    rw [hqval, hmTargetA]
+    exact fun h => hAregular _ h hzeroq
+  have hpnot : Ψp (a, 0) ∉ Φm.target := by
+    rw [hpval, hmTargetA]
+    exact fun h => hAregular _ h hzerop
+  obtain ⟨hmatchq, hmatchp⟩ :=
+    matched_cubic_time_formulas σ ha Φq Φp A hAsource hV hqfield hpfield hAfield F hF e L Q P v₀
+      v₁ hOq hOp h0q h0p hQU hPU hboxq hboxp hsliceq hslicep hphaseq hphasep Ψq Ψp Φm Ξ hΨqmap
+      hnewp hmid hcontrolq hcontrolp hleft hright
+  obtain ⟨Φ, haxis, hfield, hΦq, hΦp, hΦmid, _, _⟩ :=
+    exists_matched_full_cubic_field_chart σ ha Ψq Φm Ψp W hΨqfield hmField hΨpfield hrq hrp hΨqbox
+      hΨpbox (fun s hs => hmidAxis ⟨hs, rfl⟩) hqnot hpnot (by rw [hqval, hpval]; exact hne)
+      hmatchq hmatchp
+  have hmid0 : Φm (0, 0) = Ξ (0, 0) := by
+    have hh := hmid 0 0
+    simpa only [cubicFlowCylinder_zero_time, map_zero] using hh
+  exact
+    ⟨Φ, haxis, hfield, hΦq.trans hqval, hΦp.trans hpval, (hΦmid 0 ⟨by linarith, ha⟩).trans hmid0⟩
+
+private theorem Degree.FlowSuspension.cylinder_phase_basin_coordinates {E Z M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [TopologicalSpace M] (F : Flow ℝ M) (Φ : Z × ℝ → M)
+    (Q : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, Z) E Z ∞)
+    (hflow : ∀ z ∈ Q.target, ∀ t : ℝ, Φ (z, t) = F t (Φ (z, 0))) (Ξ : E → M) (v : E → ℝ)
+    (hphase : ∀ u ∈ Q.source, Ξ u = Φ (Q u, v u)) (Basin : M → Prop)
+    (hshift : ∀ t x, Basin (F t x) ↔ Basin x) (R : E → Prop)
+    (hbasin : ∀ u ∈ Q.source, Basin (Ξ u) ↔ R u) :
+    ∀ z ∈ Q.target, ∀ b : ℝ, Basin (Φ (z, b)) ↔ R (Q.symm z) := by
+  intro z hz b
+  have hu := Q.map_target' hz
+  have hi : Q (Q.symm z) = z := Q.right_inv' hz
+  have hphase' : Ξ (Q.symm z) = F (v (Q.symm z)) (Φ (z, 0)) := by
+    rw [hphase (Q.symm z) hu, hi, hflow z hz]
+  have hend : Basin (Ξ (Q.symm z)) ↔ Basin (Φ (z, 0)) := by
+    rw [hphase']
+    exact hshift _ _
+  have hslice : Basin (Φ (z, b)) ↔ Basin (Φ (z, 0)) := by
+    rw [hflow z hz b]
+    exact hshift _ _
+  exact hslice.trans (hend.symm.trans (hbasin _ hu))
+
+private theorem
+    Degree.FlowSuspension.cylinder_outgoing_basin_labels {Z M : Type*} [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [TopologicalSpace M] {A B : Type*} [NormedAddCommGroup A] [NormedSpace ℝ A]
+    [NormedAddCommGroup B] [NormedSpace ℝ B] (F : Flow ℝ M) (Φ : Z × ℝ → M)
+    (Q : PartialDiffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, Z) (A × B) Z ∞)
+    (hflow : ∀ z ∈ Q.target, ∀ t : ℝ, Φ (z, t) = F t (Φ (z, 0))) (Ξ : (A × B) → M)
+    (v : (A × B) → ℝ) (hphase : ∀ u ∈ Q.source, Ξ u = Φ (Q u, v u)) {q : M}
+    (hbasin : ∀ u ∈ Q.source, Filter.Tendsto (fun t => F t (Ξ u)) Filter.atBot (𝓝 q) ↔ u.2 = 0) :
+    ∀ z ∈ Q.target,
+      ∀ b : ℝ,
+        Filter.Tendsto (fun t => F t (Φ (z, b))) Filter.atBot (𝓝 q) ↔
+          ∃ x : A, (x, (0 : B)) ∈ Q.source ∧ Q (x, 0) = z := by
+  have hcoord :=
+    cylinder_phase_basin_coordinates F Φ Q hflow Ξ v hphase
+      (fun x => Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 q))
+      (fun t x => MorseCancel.flow_time_atBot_limit_iff F t x q) (fun u : A × B => u.2 = 0) hbasin
+  intro z hz b
+  rw [hcoord z hz b]
+  constructor
+  · intro hu
+    have hpair : Q.symm z = ((Q.symm z).1, (0 : B)) := Prod.ext rfl hu
+    refine ⟨(Q.symm z).1, hpair ▸ Q.map_target' hz, ?_⟩
+    rw [← hpair]
+    exact Q.right_inv' hz
+  · rintro ⟨x, hx, hQx⟩
+    have hi : Q.symm (Q (x, (0 : B))) = (x, 0) := Q.left_inv' hx
+    rw [← hQx, hi]
+
+private theorem
+    Degree.FlowSuspension.cylinder_incoming_basin_labels {Z M : Type*} [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [TopologicalSpace M] {A B : Type*} [NormedAddCommGroup A] [NormedSpace ℝ A]
+    [NormedAddCommGroup B] [NormedSpace ℝ B] (F : Flow ℝ M) (Φ : Z × ℝ → M)
+    (P : PartialDiffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, Z) (A × B) Z ∞)
+    (hflow : ∀ z ∈ P.target, ∀ t : ℝ, Φ (z, t) = F t (Φ (z, 0))) (Ξ : (A × B) → M)
+    (v : (A × B) → ℝ) (hphase : ∀ u ∈ P.source, Ξ u = Φ (P u, v u)) {p : M}
+    (hbasin : ∀ u ∈ P.source, Filter.Tendsto (fun t => F t (Ξ u)) Filter.atTop (𝓝 p) ↔ u.1 = 0) :
+    ∀ z ∈ P.target,
+      ∀ b : ℝ,
+        Filter.Tendsto (fun t => F t (Φ (z, b))) Filter.atTop (𝓝 p) ↔
+          ∃ y ∈ P.source, y.1 = 0 ∧ P y = z := by
+  have hcoord :=
+    cylinder_phase_basin_coordinates F Φ P hflow Ξ v hphase
+      (fun x => Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p))
+      (fun t x => MorseCancel.flow_time_atTop_limit_iff F t x p) (fun u : A × B => u.1 = 0) hbasin
+  intro z hz b
+  rw [hcoord z hz b]
+  constructor
+  · intro hu
+    exact ⟨P.symm z, P.map_target' hz, hu, P.right_inv' hz⟩
+  · rintro ⟨y, hy, hy0, hPy⟩
+    have hi : P.symm (P y) = y := P.left_inv' hy
+    rw [← hPy, hi]
+    exact hy0
+
+private theorem MorseCancel.cubicFlowCylinder_transverse_zero_iff {m : ℕ} (σ : Fin m → ℝ) (a T : ℝ)
+    (z : Fin m → ℝ) (i : Fin m) : (cubicFlowCylinder σ a (z, T)).2 i = 0 ↔ z i = 0 := by
+  simp [cubicFlowCylinder, Real.exp_ne_zero]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.incoming_cubic_slice_basin {m : ℕ} {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] (σ : Fin m → ℝ) (a T : ℝ)
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞) (F : Flow ℝ M) {p : M}
+    (hbasin :
+      ∀ z ∈ Φ.source,
+        Filter.Tendsto (fun t => F t (Φ z)) Filter.atTop (𝓝 p) ↔ ∀ i, σ i = -1 → z.2 i = 0)
+    (u : Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ)
+    (hu : cubicFlowCylinder σ a ((Smale.MorseHandle.splitCoordinates σ).symm u, T) ∈ Φ.source) :
+    Filter.Tendsto
+        (fun t =>
+          F t (Φ (cubicFlowCylinder σ a ((Smale.MorseHandle.splitCoordinates σ).symm u, T))))
+        Filter.atTop (𝓝 p) ↔
+      u.1 = 0 := by
+  rw [hbasin _ hu]
+  have he :
+    (∀ i,
+        σ i = -1 →
+          (cubicFlowCylinder σ a ((Smale.MorseHandle.splitCoordinates σ).symm u, T)).2 i = 0) ↔
+      ∀ i, σ i = -1 → (Smale.MorseHandle.splitCoordinates σ).symm u i = 0 := by
+    simp only [cubicFlowCylinder_transverse_zero_iff]
+  rw [he, ← Degree.TransverseGerms.splitCoordinates_negative_zero_iff]
+  rw [(Smale.MorseHandle.splitCoordinates σ).apply_symm_apply]
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.outgoing_cubic_slice_basin {m : ℕ} {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] (σ : Fin m → ℝ)
+    (hσ : ∀ i, σ i = -1 ∨ σ i = 1) (a T : ℝ)
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞) (F : Flow ℝ M) {q : M}
+    (hbasin :
+      ∀ z ∈ Φ.source,
+        Filter.Tendsto (fun t => F t (Φ z)) Filter.atBot (𝓝 q) ↔ ∀ i, σ i = 1 → z.2 i = 0)
+    (u : Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ)
+    (hu : cubicFlowCylinder σ a ((Smale.MorseHandle.splitCoordinates σ).symm u, T) ∈ Φ.source) :
+    Filter.Tendsto
+        (fun t =>
+          F t (Φ (cubicFlowCylinder σ a ((Smale.MorseHandle.splitCoordinates σ).symm u, T))))
+        Filter.atBot (𝓝 q) ↔
+      u.2 = 0 := by
+  rw [hbasin _ hu]
+  have he :
+    (∀ i,
+        σ i = 1 →
+          (cubicFlowCylinder σ a ((Smale.MorseHandle.splitCoordinates σ).symm u, T)).2 i = 0) ↔
+      ∀ i, σ i = 1 → (Smale.MorseHandle.splitCoordinates σ).symm u i = 0 := by
+    simp only [cubicFlowCylinder_transverse_zero_iff]
+  rw [he, ← Degree.TransverseGerms.splitCoordinates_positive_zero_iff σ hσ]
+  rw [(Smale.MorseHandle.splitCoordinates σ).apply_symm_apply]
+
+private theorem Degree.FlowCancellation.exists_native_lyapunov_residence {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    {C : Set M} (hC : IsCompact C) (hneg : ∀ x ∈ C, mvfderiv 𝓘(ℝ, E) f x (V x) < 0) :
+    ∃ T : ℝ, 0 < T ∧ ∀ γ : ℝ → M, IsMIntegralCurve γ V → ∃ t ∈ Set.Icc (0 : ℝ) T, γ t ∉ C := by
+  by_cases hne : C.Nonempty
+  swap
+  · exact ⟨1, zero_lt_one, fun γ _ => ⟨0, ⟨le_rfl, zero_le_one⟩, fun h => hne ⟨γ 0, h⟩⟩⟩
+  have hspeed := (MorseCancel.contMDiff_directionalDerivative hf hV).continuous
+  obtain ⟨v, hv, hmaxspeed⟩ := hC.exists_isMaxOn hne hspeed.continuousOn
+  let δ := -mvfderiv 𝓘(ℝ, E) f v (V v)
+  have hδ : 0 < δ := neg_pos.mpr (hneg v hv)
+  have hbound (x : M) (hx : x ∈ C) : mvfderiv 𝓘(ℝ, E) f x (V x) ≤ -δ := by
+    have hh : mvfderiv 𝓘(ℝ, E) f x (V x) ≤ mvfderiv 𝓘(ℝ, E) f v (V v) := hmaxspeed hx
+    simpa only [δ, neg_neg] using hh
+  obtain ⟨p, hp, hmin⟩ := hC.exists_isMinOn hne hf.continuous.continuousOn
+  obtain ⟨q, hq, hmax⟩ := hC.exists_isMaxOn hne hf.continuous.continuousOn
+  let T := (f q - f p + 1) / δ
+  have hpq : f p ≤ f q := hmax hp
+  have hT : 0 < T := div_pos (by linarith) hδ
+  have hδT : δ * T = f q - f p + 1 := by
+    dsimp [T]
+    field_simp [hδ.ne']
+  refine ⟨T, hT, ?_⟩
+  intro γ hγ
+  by_contra! hstay
+  have hd (t : ℝ) : HasDerivAt (f ∘ γ) (mvfderiv 𝓘(ℝ, E) f (γ t) (V (γ t))) t :=
+    Smale.FlowConstruction.hasDerivAt_comp_integralCurve hf hγ t
+  have hdiff : Differentiable ℝ (f ∘ γ) := fun t => (hd t).differentiableAt
+  have h0 : (0 : ℝ) ∈ Set.Icc 0 T := ⟨le_rfl, hT.le⟩
+  have hlast : T ∈ Set.Icc (0 : ℝ) T := ⟨hT.le, le_rfl⟩
+  have hdrop :=
+    (convex_Icc (0 : ℝ) T).image_sub_le_mul_sub_of_deriv_le hdiff.continuous.continuousOn
+      hdiff.differentiableOn
+      (fun t ht => by
+        rw [(hd t).deriv]
+        exact hbound (γ t) (hstay t (interior_subset ht)))
+      0 h0 T hlast hT.le
+  simp only [Function.comp_apply, sub_zero, neg_mul] at hdrop
+  rw [hδT] at hdrop
+  have hlo : f p ≤ f (γ T) := hmin (hstay T hlast)
+  have hhi : f (γ 0) ≤ f q := hmax (hstay 0 h0)
+  linarith
+
+private theorem Degree.FlowCancellation.combine_native_residence_bounds {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {B N U : Set M}
+    (houter :
+      ∃ T : ℝ, 0 < T ∧ ∀ γ : ℝ → M, IsMIntegralCurve γ V → ∃ t ∈ Set.Icc (0 : ℝ) T, γ t ∉ B \ N)
+    (hinner :
+      ∃ T : ℝ, 0 < T ∧ ∀ γ : ℝ → M, IsMIntegralCurve γ V → ∃ t ∈ Set.Icc (0 : ℝ) T, γ t ∉ U)
+    (hnoreturn :
+      ∀ γ : ℝ → M,
+        IsMIntegralCurve γ V → ∀ a b : ℝ, γ a ∈ N → γ b ∈ N → ∀ t ∈ Set.Icc a b, γ t ∈ U) :
+    ∃ T : ℝ, 0 < T ∧ ∀ γ : ℝ → M, IsMIntegralCurve γ V → ∃ t ∈ Set.Icc (0 : ℝ) T, γ t ∉ B := by
+  obtain ⟨T₀, hT₀, hout⟩ := houter
+  obtain ⟨T₁, hT₁, hin⟩ := hinner
+  refine ⟨2 * T₀ + T₁, by linarith, ?_⟩
+  intro γ hγ
+  by_contra! hstay
+  obtain ⟨a, ha, haout⟩ := hout γ hγ
+  have haN : γ a ∈ N := by
+    by_contra haN
+    exact haout ⟨hstay a ⟨ha.1, by linarith [ha.2]⟩, haN⟩
+  obtain ⟨b, hb, hbout⟩ := hout (γ ∘ (· + (T₀ + T₁))) (hγ.comp_add (T₀ + T₁))
+  have hbN : γ (b + (T₀ + T₁)) ∈ N := by
+    by_contra hbN
+    exact hbout ⟨hstay (b + (T₀ + T₁)) ⟨by linarith [hb.1], by linarith [hb.2]⟩, hbN⟩
+  obtain ⟨t, ht, htout⟩ := hin (γ ∘ (· + T₀)) (hγ.comp_add T₀)
+  exact
+    htout
+      (hnoreturn γ hγ a (b + (T₀ + T₁)) haN hbN (t + T₀)
+        ⟨by linarith [ha.2, ht.1], by linarith [hb.1, ht.2]⟩)
+
+private theorem Degree.FlowCancellation.exists_perturbed_band_residence {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] [T2Space M]
+    {V' : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hV' : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V' x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) {c d : ℝ} {K N U : Set M}
+    (hK : IsClosed K) (hN : IsOpen N) (hKN : K ⊆ N) (hNU : N ⊆ U) (hoff : ∀ x ∉ K, V' x = V x)
+    (hneg : ∀ x, f x ∈ Set.Icc c d → x ∉ N → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hnoreturn : ∀ x ∈ N, ∀ t : ℝ, 0 ≤ t → F t x ∈ N → ∀ s ∈ Set.Icc (0 : ℝ) t, F s x ∈ U)
+    (hinner :
+      ∃ T : ℝ, 0 < T ∧ ∀ γ : ℝ → M, IsMIntegralCurve γ V' → ∃ t ∈ Set.Icc (0 : ℝ) T, γ t ∉ U) :
+    ∃ T : ℝ,
+      0 < T ∧
+        ∀ γ : ℝ → M, IsMIntegralCurve γ V' → ∃ t ∈ Set.Icc (0 : ℝ) T, f (γ t) ∉ Set.Icc c d := by
+  have hcompact : IsCompact (f ⁻¹' Set.Icc c d \ N) :=
+    ((isClosed_Icc.preimage hf.continuous).inter hN.isClosed_compl).isCompact
+  have houter :=
+    exists_native_lyapunov_residence hf hV' hcompact
+      (by
+        intro x hx
+        rw [hoff x (fun h => hx.2 (hKN h))]
+        exact hneg x hx.1 hx.2)
+  exact
+    combine_native_residence_bounds houter hinner
+      (fun γ hγ a b ha hb =>
+        native_no_return_of_supported_perturbation (hV.of_le (by simp)) F hcurve hK hKN hNU hoff
+          hnoreturn hγ ha hb)
+
+private def MorseCancel.transverseEnergy {m : ℕ} (σ : Fin m → ℝ) (p : Model m) : ℝ :=
+  ∑ i, (σ i * p.2 i) ^ 2
+
+private theorem MorseCancel.transverseEnergy_nonneg {m : ℕ} (σ : Fin m → ℝ) (p : Model m) :
+    0 ≤ transverseEnergy σ p :=
+  Finset.sum_nonneg (fun _ _ => sq_nonneg _)
+
+private theorem MorseCancel.transverseEnergy_zero_iff {m : ℕ} (σ : Fin m → ℝ) (hσ : ∀ i, σ i ≠ 0)
+    (p : Model m) : transverseEnergy σ p = 0 ↔ p.2 = 0 := by
+  constructor
+  · intro h
+    funext i
+    have hh :=
+      (Finset.sum_eq_zero_iff_of_nonneg (fun i _ => sq_nonneg (σ i * p.2 i))).mp h i
+        (Finset.mem_univ i)
+    exact (mul_eq_zero.mp (sq_eq_zero_iff.mp hh)).resolve_left (hσ i)
+  · intro h
+    simp [transverseEnergy, h]
+
+private def MorseCancel.fieldLyapunov {m : ℕ} (σ : Fin m → ℝ) (k : ℝ) (p : Model m) : ℝ :=
+  p.1 + k * ∑ i, σ i * p.2 i ^ 2
+
+private theorem MorseCancel.contDiff_fieldLyapunov {m : ℕ} (σ : Fin m → ℝ) (k : ℝ) :
+    ContDiff ℝ ∞ (fieldLyapunov σ k) := by
+  unfold fieldLyapunov
+  fun_prop
+
+private theorem
+    MorseCancel.hasFDerivAt_fieldLyapunov {m : ℕ} (σ : Fin m → ℝ) (k : ℝ) (p : Model m) :
+    HasFDerivAt (fieldLyapunov σ k)
+      (ContinuousLinearMap.fst ℝ ℝ (Fin m → ℝ) +
+        k •
+          ∑ i,
+            (2 * σ i * p.2 i) •
+              ((ContinuousLinearMap.proj i).comp (ContinuousLinearMap.snd ℝ ℝ (Fin m → ℝ))))
+      p := by
+  have hx := (ContinuousLinearMap.fst ℝ ℝ (Fin m → ℝ)).hasFDerivAt (x := p)
+  have hy (i : Fin m) :=
+    ((ContinuousLinearMap.proj i).comp (ContinuousLinearMap.snd ℝ ℝ (Fin m → ℝ))).hasFDerivAt
+      (x := p)
+  have hq := HasFDerivAt.fun_sum (u := Finset.univ) (fun i _ => ((hy i).pow 2).const_mul (σ i))
+  convert! hx.add (hq.const_mul k) using 1
+  apply ContinuousLinearMap.ext
+  intro v
+  simp [mul_assoc, mul_comm]
+
+private theorem MorseCancel.fieldLyapunov_speed {m : ℕ} (σ : Fin m → ℝ) (k a : ℝ) (φ : Model m → ℝ)
+    (p : Model m) :
+    fderiv ℝ (fieldLyapunov σ k) p (cancelledDescent σ a φ p) =
+      (cancelledDescent σ a φ p).1 - 2 * k * transverseEnergy σ p := by
+  rw [(hasFDerivAt_fieldLyapunov σ k p).fderiv]
+  simp only [add_apply, smul_apply, smul_eq_mul, sum_apply, ContinuousLinearMap.comp_apply,
+    ContinuousLinearMap.proj_apply]
+  change
+    (cancelledDescent σ a φ p).1 + k * (∑ i, 2 * σ i * p.2 i * (cancelledDescent σ a φ p).2 i) = _
+  have hsum :
+    (∑ i, 2 * σ i * p.2 i * (cancelledDescent σ a φ p).2 i) = -2 * transverseEnergy σ p := by
+    rw [transverseEnergy, Finset.mul_sum]
+    apply Finset.sum_congr rfl
+    intro i _
+    change 2 * σ i * p.2 i * (-σ i * p.2 i) = _
+    ring
+  rw [hsum]
+  ring
+
+private theorem MorseCancel.exists_compact_fieldLyapunov {m : ℕ} (σ : Fin m → ℝ) (hσ : ∀ i, σ i ≠ 0)
+    {a : ℝ} (ha : 0 < a) {φ : Model m → ℝ} (hφ : ContDiff ℝ ∞ φ) (hφnonneg : ∀ p, 0 ≤ φ p)
+    (hone : ∀ s ∈ Set.Icc (-a) a, φ (s, 0) = 1) {C : Set (Model m)} (hC : IsCompact C) :
+    ∃ k : ℝ,
+      0 ≤ k ∧
+        ContDiff ℝ ∞ (fieldLyapunov σ k) ∧
+          ∀ p ∈ C, fderiv ℝ (fieldLyapunov σ k) p (cancelledDescent σ a φ p) < 0 := by
+  let O : ℕ → Set (Model m) := fun n =>
+    {p | (cancelledDescent σ a φ p).1 - 2 * (n : ℝ) * transverseEnergy σ p < 0}
+  have henergy : Continuous (transverseEnergy σ) := by
+    unfold transverseEnergy
+    fun_prop
+  have hO (n : ℕ) : IsOpen (O n) :=
+    isOpen_lt
+      ((contDiff_cancelledDescent σ a hφ).continuous.fst.sub (continuous_const.mul henergy))
+      continuous_const
+  have hcover : C ⊆ ⋃ n, O n := by
+    intro p hp
+    by_cases hz : p.2 = 0
+    · apply Set.mem_iUnion.mpr
+      refine ⟨0, ?_⟩
+      have he : p = (p.1, (0 : Fin m → ℝ)) := Prod.ext rfl hz
+      have hh := cancelledDescent_axis_negative σ ha hφnonneg hone p.1
+      have hneg : (cancelledDescent σ a φ p).1 < 0 :=
+        (congrArg (fun q : Model m => (cancelledDescent σ a φ q).1) he).trans_lt hh
+      simpa only [O, Set.mem_ofPred_eq, Nat.cast_zero, MulZeroClass.mul_zero,
+        MulZeroClass.zero_mul, sub_zero] using hneg
+    · have hpos : 0 < transverseEnergy σ p :=
+        lt_of_le_of_ne (transverseEnergy_nonneg σ p)
+          (Ne.symm (fun he => hz ((transverseEnergy_zero_iff σ hσ p).mp he)))
+      obtain ⟨n, hn⟩ := exists_nat_gt ((cancelledDescent σ a φ p).1 / (2 * transverseEnergy σ p))
+      have hh := (div_lt_iff₀ (mul_pos (by norm_num) hpos)).mp hn
+      apply Set.mem_iUnion.mpr
+      refine ⟨n, ?_⟩
+      change (cancelledDescent σ a φ p).1 - 2 * (n : ℝ) * transverseEnergy σ p < 0
+      nlinarith
+  have hmono : Monotone O := by
+    intro i j hij p hp
+    have hij' : (i : ℝ) ≤ (j : ℝ) := by exact_mod_cast hij
+    have he := transverseEnergy_nonneg σ p
+    change (cancelledDescent σ a φ p).1 - 2 * (i : ℝ) * transverseEnergy σ p < 0 at hp
+    change (cancelledDescent σ a φ p).1 - 2 * (j : ℝ) * transverseEnergy σ p < 0
+    nlinarith
+  obtain ⟨n, hn⟩ :=
+    hC.elim_directed_cover O hO hcover
+      (fun i j => ⟨Max.max i j, hmono (le_max_left i j), hmono (le_max_right i j)⟩)
+  refine ⟨n, by positivity, contDiff_fieldLyapunov σ n, ?_⟩
+  intro p hp
+  rw [fieldLyapunov_speed]
+  exact hn hp
+
+private theorem MorseCancel.exists_compact_lyapunov_residence {D : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] {L : D → ℝ} {W : D → D} (hL : ContDiff ℝ ∞ L) (hW : Continuous W)
+    {C : Set D} (hC : IsCompact C) (hneg : ∀ x ∈ C, fderiv ℝ L x (W x) < 0) :
+    ∃ T : ℝ,
+      0 < T ∧
+        ∀ γ : ℝ → D,
+          (∀ t ∈ Set.Icc (0 : ℝ) T, γ t ∈ C → HasDerivAt γ (W (γ t)) t) →
+            ∃ t ∈ Set.Icc (0 : ℝ) T, γ t ∉ C := by
+  by_cases hne : C.Nonempty
+  swap
+  · exact ⟨1, zero_lt_one, fun γ _ => ⟨0, ⟨le_rfl, zero_le_one⟩, fun h => hne ⟨γ 0, h⟩⟩⟩
+  have hspeed : Continuous (fun x => fderiv ℝ L x (W x)) :=
+    (hL.continuous_fderiv_apply (by simp)).comp (continuous_id.prodMk hW)
+  obtain ⟨v, hv, hmaxspeed⟩ := hC.exists_isMaxOn hne hspeed.continuousOn
+  let δ := -fderiv ℝ L v (W v)
+  have hδ : 0 < δ := neg_pos.mpr (hneg v hv)
+  have hbound (x : D) (hx : x ∈ C) : fderiv ℝ L x (W x) ≤ -δ := by
+    have hh : fderiv ℝ L x (W x) ≤ fderiv ℝ L v (W v) := hmaxspeed hx
+    simpa only [δ, neg_neg] using hh
+  obtain ⟨p, hp, hmin⟩ := hC.exists_isMinOn hne hL.continuous.continuousOn
+  obtain ⟨q, hq, hmax⟩ := hC.exists_isMaxOn hne hL.continuous.continuousOn
+  let T := (L q - L p + 1) / δ
+  have hpq : L p ≤ L q := hmax hp
+  have hT : 0 < T := div_pos (by linarith) hδ
+  have hδT : δ * T = L q - L p + 1 := by
+    dsimp [T]
+    field_simp [hδ.ne']
+  refine ⟨T, hT, ?_⟩
+  intro γ hγ
+  by_contra! hstay
+  have hd (t : ℝ) (ht : t ∈ Set.Icc (0 : ℝ) T) :
+    HasDerivAt (fun u => L (γ u)) (fderiv ℝ L (γ t) (W (γ t))) t :=
+    (hL.differentiable (by simp) (γ t)).hasFDerivAt.comp_hasDerivAt t (hγ t ht (hstay t ht))
+  have hcont : ContinuousOn (fun t => L (γ t)) (Set.Icc (0 : ℝ) T) := fun t ht =>
+    (hd t ht).continuousAt.continuousWithinAt
+  have hdiff : DifferentiableOn ℝ (fun t => L (γ t)) (Set.Icc (0 : ℝ) T) := fun t ht =>
+    (hd t ht).differentiableAt.differentiableWithinAt
+  have h0 : (0 : ℝ) ∈ Set.Icc 0 T := ⟨le_rfl, hT.le⟩
+  have hlast : T ∈ Set.Icc (0 : ℝ) T := ⟨hT.le, le_rfl⟩
+  have hdrop :=
+    (convex_Icc (0 : ℝ) T).image_sub_le_mul_sub_of_deriv_le hcont (hdiff.mono interior_subset)
+      (fun t ht => by
+        rw [(hd t (interior_subset ht)).deriv]
+        exact hbound (γ t) (hstay t (interior_subset ht)))
+      0 h0 T hlast hT.le
+  simp only [sub_zero, neg_mul] at hdrop
+  rw [hδT] at hdrop
+  have hlo : L p ≤ L (γ T) := hmin (hstay T hlast)
+  have hhi : L (γ 0) ≤ L q := hmax (hstay 0 h0)
+  linarith
+
+private theorem
+    MorseCancel.hasDerivAt_partialChart_integralCurve {D E M : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] (e : PartialDiffeomorph 𝓘(ℝ, E) 𝓘(ℝ, D) M D ∞) (W : D → D)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {γ : ℝ → M} (hγ : IsMIntegralCurve γ V) {t : ℝ}
+    (ht : γ t ∈ e.source) (hV : V (γ t) = Smale.FlowConstruction.partialChartField e W (γ t)) :
+    HasDerivAt (e ∘ γ) (W (e (γ t))) t := by
+  let e' := e.toOpenPartialHomeomorph
+  have he : e'.MDifferentiable 𝓘(ℝ, E) 𝓘(ℝ, D) :=
+    ⟨e.contMDiffOn.mdifferentiableOn (by simp), e.symm.contMDiffOn.mdifferentiableOn (by simp)⟩
+  have hinv := he.comp_symm_deriv (e'.map_source ht)
+  rw [e'.left_inv ht] at hinv
+  have hd := (he.mdifferentiableAt ht).hasMFDerivAt.comp t (hγ t)
+  rw [hasDerivAt_iff_hasFDerivAt]
+  apply hasMFDerivAt_iff_hasFDerivAt.mp
+  apply hd.congr_mfderiv
+  apply ContinuousLinearMap.ext
+  intro r
+  change
+    mfderiv 𝓘(ℝ, E) 𝓘(ℝ, D) e (γ t) ((NormedSpace.fromTangentSpace t r) • V (γ t)) =
+      (NormedSpace.fromTangentSpace t r) •
+        (NormedSpace.fromTangentSpace (e (γ t))).symm (W (e (γ t)))
+  rw [map_smul, hV, Smale.FlowConstruction.partialChartField_eq_mfderiv_symm e W ht]
+  have hv := congrArg (fun A : D →L[ℝ] D => A (W (e (γ t)))) hinv
+  exact congrArg (fun v => (NormedSpace.fromTangentSpace t r) • v) hv
+
+private theorem MorseCancel.exists_native_compact_lyapunov_residence {D E M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] (Φ : PartialDiffeomorph 𝓘(ℝ, D) 𝓘(ℝ, E) D M ∞)
+    {L : D → ℝ} {W : D → D} (hL : ContDiff ℝ ∞ L) (hW : Continuous W) {C : Set D}
+    (hC : IsCompact C) (hsource : C ⊆ Φ.source) (hneg : ∀ x ∈ C, fderiv ℝ L x (W x) < 0)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ∀ x ∈ Φ '' C, V x = Smale.FlowConstruction.partialChartField Φ.symm W x) :
+    ∃ T : ℝ, 0 < T ∧ ∀ γ : ℝ → M, IsMIntegralCurve γ V → ∃ t ∈ Set.Icc (0 : ℝ) T, γ t ∉ Φ '' C := by
+  obtain ⟨T, hT, hTbound⟩ := exists_compact_lyapunov_residence hL hW hC hneg
+  refine ⟨T, hT, ?_⟩
+  intro γ hγ
+  by_contra! hstay
+  have hcoords (t : ℝ) (ht : t ∈ Set.Icc (0 : ℝ) T) : Φ.symm (γ t) ∈ C := by
+    obtain ⟨z, hz, he⟩ := hstay t ht
+    have hh : Φ.symm (Φ z) = z := Φ.left_inv' (hsource hz)
+    rw [← he, hh]
+    exact hz
+  obtain ⟨t, ht, hout⟩ :=
+    hTbound (Φ.symm ∘ γ)
+      (fun t ht _ =>
+        hasDerivAt_partialChart_integralCurve Φ.symm W hγ
+          (by
+            obtain ⟨z, hz, he⟩ := hstay t ht
+            exact he ▸ Φ.map_source' (hsource hz))
+          (hV (γ t) (hstay t ht)))
+  exact hout (hcoords t ht)
+
+private theorem MorseCancel.exists_native_cancelledDescent_residence_bound {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {m : ℕ}
+    (σ : Fin m → ℝ) (hσ : ∀ i, σ i ≠ 0) {a : ℝ} (ha : 0 < a)
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞) {φ : Model m → ℝ}
+    (hφ : ContDiff ℝ ∞ φ) (hφnonneg : ∀ p, 0 ≤ φ p) (hone : ∀ s ∈ Set.Icc (-a) a, φ (s, 0) = 1)
+    {C : Set (Model m)} (hC : IsCompact C) (hsource : C ⊆ Φ.source)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV :
+      ∀ x ∈ Φ '' C,
+        V x = Smale.FlowConstruction.partialChartField Φ.symm (cancelledDescent σ a φ) x) :
+    ∃ T : ℝ, 0 < T ∧ ∀ γ : ℝ → M, IsMIntegralCurve γ V → ∃ t ∈ Set.Icc (0 : ℝ) T, γ t ∉ Φ '' C := by
+  obtain ⟨k, -, hL, hneg⟩ := exists_compact_fieldLyapunov σ hσ ha hφ hφnonneg hone hC
+  exact
+    exists_native_compact_lyapunov_residence Φ hL (contDiff_cancelledDescent σ a hφ).continuous hC
+      hsource hneg hV
+
+private theorem
+    MorseCancel.exists_native_cubic_field_finite_passage {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {m : ℕ} (σ : Fin m → ℝ)
+    (hσ : ∀ i, σ i ≠ 0) {a : ℝ} (ha : 0 < a)
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (haxis : Set.Icc (-a) a ×ˢ {(0 : Fin m → ℝ)} ⊆ Φ.source) {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hmodel : ∀ x ∈ Φ.target, V x = nativeCubicDescent σ Φ (-(a ^ 2)) x) (F : Flow ℝ M)
+    (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) {c d : ℝ} {N U : Set M} (hN : IsOpen N)
+    (hNU : N ⊆ U) (haxisN : ∀ s ∈ Set.Icc (-a) a, Φ (s, 0) ∈ N) {C : Set (Model m)}
+    (hC : IsCompact C) (hCΦ : C ⊆ Φ.source) (hUC : U ⊆ Φ '' C)
+    (hneg : ∀ x, f x ∈ Set.Icc c d → x ∉ N → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hnoreturn : ∀ x ∈ N, ∀ t : ℝ, 0 ≤ t → F t x ∈ N → ∀ s ∈ Set.Icc (0 : ℝ) t, F s x ∈ U) :
+    ∃ (K : Set M) (V' : (x : M) → TangentSpace 𝓘(ℝ, E) x),
+      IsCompact K ∧
+        K ⊆ N ∧
+          ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V' x⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+            (∀ x, V' x = 0 ↔ V x = 0 ∧ x ≠ Φ (a, 0) ∧ x ≠ Φ (-a, 0)) ∧
+              (∀ x ∉ K, ∀ᶠ y in 𝓝 x, V' y = V y) ∧
+                ∃ T : ℝ,
+                  0 < T ∧
+                    ∀ γ : ℝ → M,
+                      IsMIntegralCurve γ V' → ∃ t ∈ Set.Icc (0 : ℝ) T, f (γ t) ∉ Set.Icc c d := by
+  obtain ⟨φ, hφ, hc, hsupp, hsuppN, hrange, hone, V', hV', heq, hzero, hkeep⟩ :=
+    exists_native_cubic_field_cancellation_in σ hσ ha Φ haxis V hV hmodel hN haxisN
+  have hK : IsCompact (Φ '' tsupport φ) :=
+    hc.image_of_continuousOn (Φ.contMDiffOn_toFun.continuousOn.mono hsupp)
+  obtain ⟨T₀, hT₀, hres⟩ :=
+    exists_native_cancelledDescent_residence_bound σ hσ ha Φ hφ (fun p => (hrange p).1) hone hC
+      hCΦ
+      (fun x hx =>
+        heq x
+          (by
+            obtain ⟨z, hz, rfl⟩ := hx
+            exact Φ.map_source' (hCΦ hz)))
+  have hinner :
+    ∃ T : ℝ, 0 < T ∧ ∀ γ : ℝ → M, IsMIntegralCurve γ V' → ∃ t ∈ Set.Icc (0 : ℝ) T, γ t ∉ U := by
+    refine ⟨T₀, hT₀, ?_⟩
+    intro γ hγ
+    obtain ⟨t, ht, hout⟩ := hres γ hγ
+    exact ⟨t, ht, fun h => hout (hUC h)⟩
+  refine ⟨Φ '' tsupport φ, V', hK, hsuppN, hV', hzero, hkeep, ?_⟩
+  exact
+    Degree.FlowCancellation.exists_perturbed_band_residence hf hV hV' F hcurve hK.isClosed hN
+      hsuppN hNU (fun x hx => (hkeep x hx).self_of_nhds) hneg hnoreturn hinner
+
+private theorem MorseCancel.native_cubic_axis_flow {m : ℕ} {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    (σ : Fin m → ℝ) {a : ℝ} (ha : 0 < a)
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (haxis : Set.Icc (-a) a ×ˢ {(0 : Fin m → ℝ)} ⊆ Φ.source)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hmodel : ∀ x ∈ Φ.target, V x = nativeCubicDescent σ Φ (-(a ^ 2)) x) (F : Flow ℝ M)
+    (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) (t : ℝ) :
+    F t (Φ (0, 0)) = Φ (cubicModelOrbit a t) := by
+  have hmem (s : ℝ) : cubicModelOrbit a s ∈ Φ.source := by
+    have hs := cubicAxisParameter_mem ha s
+    exact haxis ⟨⟨hs.1.le, hs.2.le⟩, rfl⟩
+  have hΓ : IsMIntegralCurve (Φ ∘ cubicModelOrbit a) V := by
+    intro s
+    have hd :=
+      Smale.FlowConstruction.hasMFDerivAt_lift_partialChartCurve Φ.symm
+        (cubicDescent σ (-(a ^ 2))) (hasDerivAt_cubicModelOrbit σ a s) (hmem s)
+    have he := hmodel (Φ (cubicModelOrbit a s)) (Φ.map_source' (hmem s))
+    change
+      HasMFDerivAt 𝓘(ℝ, ℝ) 𝓘(ℝ, E) (Φ ∘ cubicModelOrbit a) s
+        ((1 : ℝ →L[ℝ] ℝ).smulRight
+          (nativeCubicDescent σ Φ (-(a ^ 2)) (Φ (cubicModelOrbit a s)))) at hd
+    rw [← he] at hd
+    exact hd
+  have hinit : F 0 (Φ (0, 0)) = (Φ ∘ cubicModelOrbit a) 0 := by
+    simp only [F.map_zero_apply, Function.comp_apply, cubicModelOrbit_zero]
+    rfl
+  have heq := isMIntegralCurve_Ioo_eq_of_contMDiff_boundaryless hV (hcurve (Φ (0, 0))) hΓ hinit
+  exact congrFun heq t
+
+private theorem MorseCancel.native_cubic_axis_orbit {m : ℕ} {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    (σ : Fin m → ℝ) {a : ℝ} (ha : 0 < a)
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (haxis : Set.Icc (-a) a ×ˢ {(0 : Fin m → ℝ)} ⊆ Φ.source)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hmodel : ∀ x ∈ Φ.target, V x = nativeCubicDescent σ Φ (-(a ^ 2)) x) (F : Flow ℝ M)
+    (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) :
+    Set.range (fun t : ℝ => F t (Φ (0, 0))) = Φ '' (Set.Ioo (-a) a ×ˢ {(0 : Fin m → ℝ)}) ∧
+      Filter.Tendsto (fun t : ℝ => F t (Φ (0, 0))) Filter.atTop (𝓝 (Φ (a, 0))) ∧
+        Filter.Tendsto (fun t : ℝ => F t (Φ (0, 0))) Filter.atBot (𝓝 (Φ (-a, 0))) := by
+  have heq : (fun t : ℝ => F t (Φ (0, 0))) = Φ ∘ cubicModelOrbit a :=
+    funext (native_cubic_axis_flow σ ha Φ haxis hV hmodel F hcurve)
+  have hp : (a, (0 : Fin m → ℝ)) ∈ Φ.source := haxis ⟨⟨by linarith, le_rfl⟩, rfl⟩
+  have hq : (-a, (0 : Fin m → ℝ)) ∈ Φ.source := haxis ⟨⟨le_rfl, by linarith⟩, rfl⟩
+  rw [heq]
+  refine ⟨?_, ?_, ?_⟩
+  · rw [Set.range_comp, range_cubicModelOrbit ha]
+  · exact
+      (Φ.mdifferentiableAt (by simp) hp).continuousAt.tendsto.comp
+        (tendsto_cubicModelOrbit_atTop ha)
+  · exact
+      (Φ.mdifferentiableAt (by simp) hq).continuousAt.tendsto.comp
+        (tendsto_cubicModelOrbit_atBot ha)
+
+private theorem MorseCancel.native_cubic_closed_axis {m : ℕ} {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    (σ : Fin m → ℝ) {a : ℝ} (ha : 0 < a)
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (haxis : Set.Icc (-a) a ×ˢ {(0 : Fin m → ℝ)} ⊆ Φ.source)
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) 1 (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hmodel : ∀ x ∈ Φ.target, V x = nativeCubicDescent σ Φ (-(a ^ 2)) x) (F : Flow ℝ M)
+    (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) :
+    Φ '' (Set.Icc (-a) a ×ˢ {(0 : Fin m → ℝ)}) =
+      Insert.insert (Φ (a, 0))
+        (Insert.insert (Φ (-a, 0)) (Set.range (fun t : ℝ => F t (Φ (0, 0))))) := by
+  rw [(native_cubic_axis_orbit σ ha Φ haxis hV hmodel F hcurve).1]
+  ext x
+  constructor
+  · rintro ⟨⟨s, z⟩, ⟨hs, hz⟩, rfl⟩
+    have hz0 : z = 0 := hz
+    subst z
+    by_cases hsright : s = a
+    · exact Or.inl (congrArg (fun r => Φ (r, 0)) hsright)
+    by_cases hsleft : s = -a
+    · exact Or.inr (Or.inl (congrArg (fun r => Φ (r, 0)) hsleft))
+    · exact
+        Or.inr
+          (Or.inr
+            ⟨(s, 0), ⟨⟨lt_of_le_of_ne hs.1 (Ne.symm hsleft), lt_of_le_of_ne hs.2 hsright⟩, rfl⟩,
+              rfl⟩)
+  · rintro (hx | hx | hx)
+    · exact ⟨(a, 0), ⟨⟨by linarith, le_rfl⟩, rfl⟩, hx.symm⟩
+    · exact ⟨(-a, 0), ⟨⟨le_rfl, by linarith⟩, rfl⟩, hx.symm⟩
+    · obtain ⟨⟨s, z⟩, ⟨hs, hz⟩, he⟩ := hx
+      exact ⟨(s, z), ⟨⟨hs.1.le, hs.2.le⟩, hz⟩, he⟩
+
+private theorem Degree.FlowCancellation.exists_uniform_directed_band_crossing {X : Type*}
+    [TopologicalSpace X] (F : Flow ℝ X) {f D : X → ℝ} (hf : Continuous f) (hD : Continuous D)
+    (hder : ∀ x t, HasDerivAt (fun s : ℝ => f (F s x)) (D (F t x)) t) {c d : ℝ}
+    (hlower : ∀ x, f x = c → D x < 0) (hupper : ∀ x, f x = d → D x < 0)
+    (hres : ∃ T : ℝ, 0 < T ∧ ∀ x, ∃ t ∈ Set.Icc (0 : ℝ) T, f (F t x) ∉ Set.Icc c d) :
+    ∃ T : ℝ, 0 < T ∧ (∀ x, f x ≤ d → f (F T x) < c) ∧ ∀ x, c ≤ f x → d < f (F (-T) x) := by
+  obtain ⟨T, hT, hexit⟩ := hres
+  have hforward : ∀ x, f x ≤ d → f (F T x) < c := by
+    intro x hx
+    obtain ⟨t, ht, hout⟩ := hexit x
+    have hhi := forwardInvariant_sublevel_of_boundary F hf hD hder hupper x hx t ht.1
+    have hlo : f (F t x) < c := lt_of_not_ge (fun h => hout ⟨h, hhi⟩)
+    rcases ht.2.eq_or_lt with he | he
+    · simpa only [he] using hlo
+    · have hh :=
+        strict_sublevel_entry_of_boundary F hf hD hder hlower (F t x) hlo.le (T - t)
+          (sub_pos.mpr he)
+      simpa only [← F.map_add, sub_add_cancel] using hh
+  refine ⟨T, hT, hforward, ?_⟩
+  intro x hx
+  apply lt_of_not_ge
+  intro hback
+  have hh := hforward (F (-T) x) hback
+  rw [← F.map_add, add_neg_cancel, F.map_zero_apply] at hh
+  exact (not_lt_of_ge hx) hh
+
+private theorem Degree.FlowCancellation.continuousOn_band_entryTime {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f D : X → ℝ} (hf : Continuous f) (hD : Continuous D)
+    (hder : ∀ x t, HasDerivAt (fun s : ℝ => f (F s x)) (D (F t x)) t) {c d : ℝ}
+    (hlower : ∀ x, f x = c → D x < 0) (hupper : ∀ x, f x = d → D x < 0)
+    (hres : ∃ T : ℝ, 0 < T ∧ ∀ x, ∃ t ∈ Set.Icc (0 : ℝ) T, f (F t x) ∉ Set.Icc c d) :
+    ContinuousOn (Smale.FlowConstruction.entryTime F {x | f x ≤ c}) {x | f x ≤ d} := by
+  obtain ⟨T, hT, hforward, -⟩ :=
+    exists_uniform_directed_band_crossing F hf hD hder hlower hupper hres
+  have hclosed : IsClosed {x | f x ≤ c} := isClosed_le hf continuous_const
+  have hentry : ∀ x ∈ {y | f y ≤ c}, ∀ t : ℝ, 0 < t → F t x ∈ interior {y | f y ≤ c} := by
+    intro x hx t ht
+    have hh := strict_sublevel_entry_of_boundary F hf hD hder hlower x hx t ht
+    exact
+      Eq.mpr
+        (congrArg (fun S : Set X => F t x ∈ S)
+          (interior_sublevel_eq_of_boundary F hf hder hlower))
+        hh
+  exact
+    Smale.FlowConstruction.continuousOn_entryTime F hclosed
+      (forwardInvariant_sublevel_of_boundary F hf hD hder hlower) hentry
+      (fun x hx => ⟨T, hT.le, (hforward x hx).le⟩)
+
+private theorem Degree.FlowCancellation.exists_native_flow_band_crossing {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    {c d : ℝ} (hlower : ∀ x, f x = c → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hupper : ∀ x, f x = d → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hres :
+      ∃ T : ℝ,
+        0 < T ∧
+          ∀ γ : ℝ → M, IsMIntegralCurve γ V → ∃ t ∈ Set.Icc (0 : ℝ) T, f (γ t) ∉ Set.Icc c d) :
+    ∃ F : Flow ℝ M,
+      (∀ x, IsMIntegralCurve (fun t => F t x) V) ∧
+        (∃ T : ℝ, 0 < T ∧ (∀ x, f x ≤ d → f (F T x) < c) ∧ ∀ x, c ≤ f x → d < f (F (-T) x)) ∧
+          ContinuousOn (Smale.FlowConstruction.entryTime F {x | f x ≤ c}) {x | f x ≤ d} := by
+  have hV₁ := hV.of_le (show (1 : WithTop ℕ∞) ≤ (↑(⊤ : ℕ∞) : ℕ∞ω) by simp)
+  let F := Smale.FlowConstruction.compactFlow hV₁
+  have hcurve (x : M) : IsMIntegralCurve (fun t => F t x) V :=
+    Smale.FlowConstruction.isMIntegralCurve_compactFlow hV₁ x
+  let D (x : M) := mvfderiv 𝓘(ℝ, E) f x (V x)
+  have hD : Continuous D := (MorseCancel.contMDiff_directionalDerivative hf hV).continuous
+  have hder (x : M) (t : ℝ) : HasDerivAt (fun s : ℝ => f (F s x)) (D (F t x)) t :=
+    Smale.FlowConstruction.hasDerivAt_comp_integralCurve hf (hcurve x) t
+  have hres' : ∃ T : ℝ, 0 < T ∧ ∀ x, ∃ t ∈ Set.Icc (0 : ℝ) T, f (F t x) ∉ Set.Icc c d := by
+    obtain ⟨T, hT, hbound⟩ := hres
+    exact ⟨T, hT, fun x => hbound (fun t => F t x) (hcurve x)⟩
+  exact
+    ⟨F, hcurve, exists_uniform_directed_band_crossing F hf.continuous hD hder hlower hupper hres',
+      continuousOn_band_entryTime F hf.continuous hD hder hlower hupper hres'⟩
+
+private theorem
+    MorseCancel.exists_cubic_connection_finite_passage {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {m : ℕ} (σ : Fin m → ℝ)
+    (hσ : ∀ i, σ i ≠ 0) {a : ℝ} (ha : 0 < a)
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (haxis : Set.Icc (-a) a ×ˢ {(0 : Fin m → ℝ)} ⊆ Φ.source) {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hmodel : ∀ x ∈ Φ.target, V x = nativeCubicDescent σ Φ (-(a ^ 2)) x) (F : Flow ℝ M)
+    (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0)
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f))
+    (hp : Φ (a, 0) ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hq : Φ (-a, 0) ∈ Smale.ManifoldMorse.criticalPoints E f) (hpq : f (Φ (a, 0)) < f (Φ (-a, 0)))
+    {c d : ℝ} (hc : c < f (Φ (a, 0))) (hd : f (Φ (-a, 0)) < d)
+    (hpair :
+      ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+        f x ∈ Set.Icc c d → x = Φ (a, 0) ∨ x = Φ (-a, 0))
+    (hunique :
+      ∀ x ∉ Smale.ManifoldMorse.criticalPoints E f,
+        Filter.Tendsto (fun t : ℝ => F t x) Filter.atBot (𝓝 (Φ (-a, 0))) →
+          Filter.Tendsto (fun t : ℝ => F t x) Filter.atTop (𝓝 (Φ (a, 0))) →
+            ∃ t : ℝ, F t (Φ (0, 0)) = x) :
+    ∃ (K : Set M) (V' : (x : M) → TangentSpace 𝓘(ℝ, E) x),
+      IsCompact K ∧
+        K ⊆ Φ.target ∩ f ⁻¹' Set.Ioo c d ∧
+          ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V' x⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+            (∀ x, V' x = 0 ↔ V x = 0 ∧ x ≠ Φ (a, 0) ∧ x ≠ Φ (-a, 0)) ∧
+              (∀ x ∉ K, ∀ᶠ y in 𝓝 x, V' y = V y) ∧
+                (∃ T : ℝ,
+                    0 < T ∧
+                      ∀ γ : ℝ → M,
+                        IsMIntegralCurve γ V' → ∃ t ∈ Set.Icc (0 : ℝ) T, f (γ t) ∉ Set.Icc c d) ∧
+                  ∃ G : Flow ℝ M,
+                    (∀ x, IsMIntegralCurve (fun t => G t x) V') ∧
+                      (∃ T : ℝ,
+                          0 < T ∧
+                            (∀ x, f x ≤ d → f (G T x) < c) ∧ ∀ x, c ≤ f x → d < f (G (-T) x)) ∧
+                        ContinuousOn (Smale.FlowConstruction.entryTime G {x | f x ≤ c})
+                          {x | f x ≤ d} := by
+  have hV₁ := hV.of_le (show (1 : WithTop ℕ∞) ≤ (↑(⊤ : ℕ∞) : ℕ∞ω) by simp)
+  obtain ⟨hrange, htop, hbot⟩ := native_cubic_axis_orbit σ ha Φ haxis hV₁ hmodel F hcurve
+  have hclosed := native_cubic_closed_axis σ ha Φ haxis hV₁ hmodel F hcurve
+  have hmono := Smale.FlowConstruction.antitone_flow_height hf F hcurve hzero hdesc (Φ (0, 0))
+  have hztop := hf.continuous.continuousAt.tendsto.comp htop
+  have hzbot := hf.continuous.continuousAt.tendsto.comp hbot
+  have hzband (t : ℝ) : f (F t (Φ (0, 0))) ∈ Set.Icc (f (Φ (a, 0))) (f (Φ (-a, 0))) :=
+    ⟨hmono.le_of_tendsto hztop t, hmono.ge_of_tendsto hzbot t⟩
+  let A := Set.Icc (-a) a ×ˢ {(0 : Fin m → ℝ)}
+  have hAband : Φ '' A ⊆ f ⁻¹' Set.Ioo c d := by
+    intro x hx
+    rw [hclosed] at hx
+    rcases hx with hx | hx | ⟨t, ht⟩
+    · rw [hx]
+      exact ⟨hc, lt_trans hpq hd⟩
+    · rw [hx]
+      exact ⟨lt_trans hc hpq, hd⟩
+    · rw [← ht]
+      exact ⟨lt_of_lt_of_le hc (hzband t).1, lt_of_le_of_lt (hzband t).2 hd⟩
+  have hopen : IsOpen (Φ.source ∩ Φ ⁻¹' (f ⁻¹' Set.Ioo c d)) :=
+    Φ.toOpenPartialHomeomorph.isOpen_inter_preimage (isOpen_Ioo.preimage hf.continuous)
+  have hAsub : A ⊆ Φ.source ∩ Φ ⁻¹' (f ⁻¹' Set.Ioo c d) := fun x hx =>
+    ⟨haxis hx, hAband ⟨x, hx, rfl⟩⟩
+  obtain ⟨C, hC, hAC, hCsub⟩ :=
+    exists_compact_between
+      (show IsCompact A from CompactIccSpace.isCompact_Icc.prod isCompact_singleton) hopen hAsub
+  have hCΦ : C ⊆ Φ.source := fun x hx => (hCsub hx).1
+  let U := Φ '' interior C
+  have hU : IsOpen U :=
+    Φ.toOpenPartialHomeomorph.isOpen_image_of_subset_source isOpen_interior
+      (fun x hx => hCΦ (interior_subset hx))
+  have hAU : Φ '' A ⊆ U := Set.image_mono hAC
+  have hpU : Φ (a, (0 : Fin m → ℝ)) ∈ U := hAU ⟨(a, 0), ⟨⟨by linarith, le_rfl⟩, rfl⟩, rfl⟩
+  have hqU : Φ (-a, (0 : Fin m → ℝ)) ∈ U := hAU ⟨(-a, 0), ⟨⟨le_rfl, by linarith⟩, rfl⟩, rfl⟩
+  have hzU (t : ℝ) : F t (Φ (0, 0)) ∈ U := by
+    apply hAU
+    rw [hclosed]
+    exact Or.inr (Or.inr ⟨t, rfl⟩)
+  obtain ⟨N, hN, hNU, hpN, hqN, hzN, hnoreturn⟩ :=
+    Degree.FlowCancellation.exists_native_connection_no_return hf hV F hcurve hzero hdesc hinj hp
+      hq hpq (fun x hx hh => hpair x hx ⟨le_trans hc.le hh.1, le_trans hh.2 hd.le⟩) hzband hunique
+      hU hpU hqU hzU
+  have haxisN (s : ℝ) (hs : s ∈ Set.Icc (-a) a) : Φ (s, (0 : Fin m → ℝ)) ∈ N := by
+    have hh : Φ (s, (0 : Fin m → ℝ)) ∈ Φ '' A := ⟨(s, 0), ⟨hs, rfl⟩, rfl⟩
+    rw [hclosed] at hh
+    rcases hh with hh | hh | ⟨t, ht⟩
+    · exact hh ▸ hpN
+    · exact hh ▸ hqN
+    · exact ht ▸ hzN t
+  have hneg (x : M) (hx : f x ∈ Set.Icc c d) (hout : x ∉ N) : mvfderiv 𝓘(ℝ, E) f x (V x) < 0 := by
+    apply hdesc x
+    intro hcrit
+    rcases hpair x hcrit hx with he | he
+    · exact hout (he ▸ hpN)
+    · exact hout (he ▸ hqN)
+  obtain ⟨K, V', hK, hKN, hV', hzeros, hkeep, hpass⟩ :=
+    exists_native_cubic_field_finite_passage σ hσ ha Φ haxis hf V hV hmodel F hcurve hN hNU haxisN
+      hC hCΦ (Set.image_mono interior_subset) hneg hnoreturn
+  have hKsub : K ⊆ Φ.target ∩ f ⁻¹' Set.Ioo c d := by
+    intro x hx
+    obtain ⟨z, hz, rfl⟩ := hNU (hKN hx)
+    exact ⟨Φ.map_source' (hCΦ (interior_subset hz)), (hCsub (interior_subset hz)).2⟩
+  have hcd : c ≤ d := by linarith
+  have hboundary (x : M) (hx : f x = c ∨ f x = d) : mvfderiv 𝓘(ℝ, E) f x (V' x) < 0 := by
+    have hxK : x ∉ K := by
+      intro hxK
+      have hh : f x ∈ Set.Ioo c d := (hKsub hxK).2
+      rcases hx with hx | hx <;> rw [hx] at hh
+      · exact (lt_irrefl c) hh.1
+      · exact (lt_irrefl d) hh.2
+    have hreg : x ∉ Smale.ManifoldMorse.criticalPoints E f := by
+      intro hcrit
+      have hxb : f x ∈ Set.Icc c d := by
+        rcases hx with hx | hx <;> rw [hx]
+        · exact ⟨le_rfl, hcd⟩
+        · exact ⟨hcd, le_rfl⟩
+      rcases hpair x hcrit hxb with he | he
+      · rw [he] at hx
+        rcases hx with hx | hx <;> linarith
+      · rw [he] at hx
+        rcases hx with hx | hx <;> linarith
+    rw [(hkeep x hxK).self_of_nhds]
+    exact hdesc x hreg
+  refine ⟨K, V', hK, hKsub, hV', hzeros, hkeep, hpass, ?_⟩
+  exact
+    Degree.FlowCancellation.exists_native_flow_band_crossing hf hV'
+      (fun x hx => hboundary x (Or.inl hx)) (fun x hx => hboundary x (Or.inr hx)) hpass
+
+private theorem Degree.FlowCancellation.hasDerivAt_comp_native_integralCurve_at {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {γ : ℝ → M} {t : ℝ}
+    (hf : MDifferentiableAt 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f (γ t)) (hγ : IsMIntegralCurve γ V) :
+    HasDerivAt (f ∘ γ) (mvfderiv 𝓘(ℝ, E) f (γ t) (V (γ t))) t := by
+  have hd := hf.hasMFDerivAt.comp t (hγ t)
+  rw [hasDerivAt_iff_hasFDerivAt]
+  apply hasMFDerivAt_iff_hasFDerivAt.mp
+  apply hd.congr_mfderiv
+  apply ContinuousLinearMap.ext
+  intro r
+  change
+    (mvfderiv 𝓘(ℝ, E) f (γ t)) ((NormedSpace.fromTangentSpace t r) • V (γ t)) =
+      (NormedSpace.fromTangentSpace t r) • (mvfderiv 𝓘(ℝ, E) f (γ t)) (V (γ t))
+  exact map_smul _ _ _
+
+private theorem
+    Degree.FlowCancellation.mvfderiv_signedLevelTime {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) {c : ℝ}
+    (hboundary : ∀ x, f x = c → mvfderiv 𝓘(ℝ, E) f x (V x) < 0) {x : M}
+    (hx : x ∈ levelBasin F f c) : mvfderiv 𝓘(ℝ, E) (signedLevelTime F f c) x (V x) = -1 := by
+  obtain ⟨hB, hsmooth, hshift⟩ := smooth_signed_level_time hf hV F hcurve hboundary
+  have hlocal := (hsmooth x hx).contMDiffAt (hB.mem_nhds hx)
+  have hlocal0 : MDifferentiableAt 𝓘(ℝ, E) 𝓘(ℝ, ℝ) (signedLevelTime F f c) (F 0 x) := by
+    rw [F.map_zero_apply]
+    exact hlocal.mdifferentiableAt (by simp)
+  have hd := hasDerivAt_comp_native_integralCurve_at hlocal0 (hcurve x)
+  have heq :
+    (signedLevelTime F f c ∘ (fun t => F t x)) = fun t : ℝ => signedLevelTime F f c x - t :=
+    funext (hshift x hx)
+  rw [heq] at hd
+  have hh := hd.unique ((hasDerivAt_id (0 : ℝ)).const_sub (signedLevelTime F f c x))
+  have he :=
+    congrArg (fun y : M => mvfderiv 𝓘(ℝ, E) (signedLevelTime F f c) y (V y)) (F.map_zero_apply x)
+  exact he.symm.trans hh
+
+private def Degree.FlowCancellation.crossingBasin {X : Type*} [TopologicalSpace X] (F : Flow ℝ X)
+    (f : X → ℝ) (c d : ℝ) : Set X :=
+  levelBasin F f c ∩ levelBasin F f d
+
+private def Degree.FlowCancellation.crossingDuration {X : Type*} [TopologicalSpace X] (F : Flow ℝ X)
+    (f : X → ℝ) (c d : ℝ) (x : X) : ℝ :=
+  signedLevelTime F f c x - signedLevelTime F f d x
+
+private def Degree.FlowCancellation.flowBandHeight {X : Type*} [TopologicalSpace X] (F : Flow ℝ X)
+    (f : X → ℝ) (c d : ℝ) (x : X) : ℝ :=
+  c + (d - c) * signedLevelTime F f c x / crossingDuration F f c d x
+
+private theorem Degree.FlowCancellation.crossingDuration_pos {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f D : X → ℝ} (hf : Continuous f) (hD : Continuous D)
+    (hder : ∀ x t, HasDerivAt (fun s : ℝ => f (F s x)) (D (F t x)) t) {c d : ℝ}
+    (hc : ∀ x, f x = c → D x < 0) (hcd : c < d) {x : X} (hx : x ∈ crossingBasin F f c d) :
+    0 < crossingDuration F f c d x := by
+  apply sub_pos.mpr
+  by_contra h
+  have hle := le_of_not_gt h
+  have hh :=
+    forwardInvariant_sublevel_of_boundary F hf hD hder hc (F (signedLevelTime F f c x) x)
+      (signedLevelTime_hits F f c hx.1).le (signedLevelTime F f d x - signedLevelTime F f c x)
+      (sub_nonneg.mpr hle)
+  rw [← F.map_add, sub_add_cancel, signedLevelTime_hits F f d hx.2] at hh
+  exact (not_le_of_gt hcd) hh
+
+private theorem Degree.FlowCancellation.crossingDuration_flow {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f D : X → ℝ} (hf : Continuous f) (hD : Continuous D)
+    (hder : ∀ x t, HasDerivAt (fun s : ℝ => f (F s x)) (D (F t x)) t) {c d : ℝ}
+    (hc : ∀ x, f x = c → D x < 0) (hd : ∀ x, f x = d → D x < 0) {x : X}
+    (hx : x ∈ crossingBasin F f c d) (s : ℝ) :
+    crossingDuration F f c d (F s x) = crossingDuration F f c d x := by
+  simp only [crossingDuration, signedLevelTime_flow F hf hD hder hc hx.1 s,
+    signedLevelTime_flow F hf hD hder hd hx.2 s]
+  ring
+
+private theorem Degree.FlowCancellation.flowBandHeight_flow {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f D : X → ℝ} (hf : Continuous f) (hD : Continuous D)
+    (hder : ∀ x t, HasDerivAt (fun s : ℝ => f (F s x)) (D (F t x)) t) {c d : ℝ}
+    (hc : ∀ x, f x = c → D x < 0) (hd : ∀ x, f x = d → D x < 0) {x : X}
+    (hx : x ∈ crossingBasin F f c d) (s : ℝ) :
+    flowBandHeight F f c d (F s x) =
+      flowBandHeight F f c d x - ((d - c) / crossingDuration F f c d x) * s := by
+  simp only [flowBandHeight, crossingDuration_flow F hf hD hder hc hd hx s,
+    signedLevelTime_flow F hf hD hder hc hx.1 s]
+  ring
+
+private theorem Degree.FlowCancellation.flowBandHeight_lower {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f D : X → ℝ} (hf : Continuous f) (hD : Continuous D)
+    (hder : ∀ x t, HasDerivAt (fun s : ℝ => f (F s x)) (D (F t x)) t) {c d : ℝ}
+    (hc : ∀ x, f x = c → D x < 0) {x : X} (hx : f x = c) : flowBandHeight F f c d x = c := by
+  simp only [flowBandHeight, signedLevelTime_eq_zero F hf hD hder hc hx, MulZeroClass.mul_zero,
+    zero_div, add_zero]
+
+private theorem Degree.FlowCancellation.flowBandHeight_upper {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f D : X → ℝ} (hf : Continuous f) (hD : Continuous D)
+    (hder : ∀ x t, HasDerivAt (fun s : ℝ => f (F s x)) (D (F t x)) t) {c d : ℝ}
+    (hc : ∀ x, f x = c → D x < 0) (hd : ∀ x, f x = d → D x < 0) (hcd : c < d) {x : X}
+    (hx : x ∈ crossingBasin F f c d) (hfx : f x = d) : flowBandHeight F f c d x = d := by
+  have hz := signedLevelTime_eq_zero F hf hD hder hd hfx
+  have hpos := crossingDuration_pos F hf hD hder hc hcd hx
+  have heq : signedLevelTime F f c x = crossingDuration F f c d x := by
+    simp only [crossingDuration, hz, sub_zero]
+  rw [flowBandHeight, heq, mul_div_cancel_right₀ _ hpos.ne']
+  ring
+
+private theorem Degree.FlowCancellation.smooth_flowBandHeight {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) {c d : ℝ} (hcd : c < d)
+    (hc : ∀ x, f x = c → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hd : ∀ x, f x = d → mvfderiv 𝓘(ℝ, E) f x (V x) < 0) :
+    IsOpen (crossingBasin F f c d) ∧
+      ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ (flowBandHeight F f c d) (crossingBasin F f c d) ∧
+        ∀ x ∈ crossingBasin F f c d,
+          mvfderiv 𝓘(ℝ, E) (flowBandHeight F f c d) x (V x) =
+              -((d - c) / crossingDuration F f c d x) ∧
+            mvfderiv 𝓘(ℝ, E) (flowBandHeight F f c d) x (V x) < 0 := by
+  obtain ⟨hBc, htc, -⟩ := smooth_signed_level_time hf hV F hcurve hc
+  obtain ⟨hBd, htd, -⟩ := smooth_signed_level_time hf hV F hcurve hd
+  let D (x : M) := mvfderiv 𝓘(ℝ, E) f x (V x)
+  have hD : Continuous D := (MorseCancel.contMDiff_directionalDerivative hf hV).continuous
+  have hder (x : M) (t : ℝ) : HasDerivAt (fun s => f (F s x)) (D (F t x)) t :=
+    Smale.FlowConstruction.hasDerivAt_comp_integralCurve hf (hcurve x) t
+  have hB : IsOpen (crossingBasin F f c d) := hBc.inter hBd
+  have hpos (x : M) (hx : x ∈ crossingBasin F f c d) : 0 < crossingDuration F f c d x :=
+    crossingDuration_pos F hf.continuous hD hder hc hcd hx
+  have hsc := htc.mono (Set.inter_subset_left : crossingBasin F f c d ⊆ levelBasin F f c)
+  have hsd := htd.mono (Set.inter_subset_right : crossingBasin F f c d ⊆ levelBasin F f d)
+  have hA : ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ (crossingDuration F f c d) (crossingBasin F f c d) :=
+    hsc.sub hsd
+  have hg : ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ (flowBandHeight F f c d) (crossingBasin F f c d) :=
+    contMDiffOn_const.add ((contMDiffOn_const.mul hsc).div₀ hA (fun x hx => (hpos x hx).ne'))
+  refine ⟨hB, hg, ?_⟩
+  intro x hx
+  have hlocal : MDifferentiableAt 𝓘(ℝ, E) 𝓘(ℝ, ℝ) (flowBandHeight F f c d) (F 0 x) := by
+    rw [F.map_zero_apply]
+    exact ((hg x hx).contMDiffAt (hB.mem_nhds hx)).mdifferentiableAt (by simp)
+  have hchain := hasDerivAt_comp_native_integralCurve_at hlocal (hcurve x)
+  have heq :
+    (flowBandHeight F f c d ∘ (fun t => F t x)) = fun t =>
+      flowBandHeight F f c d x - ((d - c) / crossingDuration F f c d x) * t :=
+    funext (fun t => flowBandHeight_flow F hf.continuous hD hder hc hd hx t)
+  rw [heq] at hchain
+  have hline :=
+    ((hasDerivAt_id (0 : ℝ)).const_mul ((d - c) / crossingDuration F f c d x)).const_sub
+      (flowBandHeight F f c d x)
+  have hnative :
+    mvfderiv 𝓘(ℝ, E) (flowBandHeight F f c d) x (V x) = -((d - c) / crossingDuration F f c d x) :=
+    by
+    have he :=
+      congrArg (fun y : M => mvfderiv 𝓘(ℝ, E) (flowBandHeight F f c d) y (V y))
+        (F.map_zero_apply x)
+    exact he.symm.trans (by simpa using hchain.unique hline)
+  exact ⟨hnative, hnative ▸ neg_neg_of_pos (div_pos (sub_pos.mpr hcd) (hpos x hx))⟩
+
+private def Degree.FlowCancellation.logarithmicCoordinate (η L t : ℝ) : ℝ :=
+  Real.log (1 + (t / η) ^ 2) / L
+
+private theorem Degree.FlowCancellation.contDiff_logarithmicCoordinate (η L : ℝ) :
+    ContDiff ℝ ∞ (logarithmicCoordinate η L) := by
+  apply ContDiff.div_const
+  apply ContDiff.log
+  · exact contDiff_const.add ((contDiff_id.div_const η).pow 2)
+  · intro t
+    positivity
+
+private theorem Degree.FlowCancellation.hasDerivAt_logarithmicCoordinate {η L : ℝ} (hη : 0 < η)
+    (hL : 0 < L) (t : ℝ) :
+    HasDerivAt (logarithmicCoordinate η L) (2 * t / (L * (η ^ 2 + t ^ 2))) t := by
+  have hp : 1 + (t / η) ^ 2 ≠ 0 := by positivity
+  have hh := (((((hasDerivAt_id t).div_const η).pow 2).const_add 1).log hp).div_const L
+  convert hh using 1 <;> try rfl
+  simp only [Pi.pow_apply, id_eq, Nat.cast_ofNat, Nat.reduceSub, pow_one]
+  field_simp
+
+private theorem
+    Degree.FlowCancellation.logarithmicCoordinate_weighted_deriv_bound {η L : ℝ} (hη : 0 < η)
+    (hL : 0 < L) (t : ℝ) : |t * deriv (logarithmicCoordinate η L) t| ≤ 2 / L := by
+  rw [(hasDerivAt_logarithmicCoordinate hη hL t).deriv]
+  have hden : 0 < η ^ 2 + t ^ 2 := add_pos_of_pos_of_nonneg (sq_pos_of_pos hη) (sq_nonneg t)
+  have heq : t * (2 * t / (L * (η ^ 2 + t ^ 2))) = (2 / L) * (t ^ 2 / (η ^ 2 + t ^ 2)) := by
+    field_simp
+  rw [heq, abs_of_nonneg (by positivity)]
+  exact mul_le_of_le_one_right (by positivity) ((div_le_one hden).mpr (by nlinarith))
+
+private theorem
+    Degree.FlowCancellation.exists_logarithmic_cutoff {ε δ : ℝ} (hε : 0 < ε) (hδ : 0 < δ) :
+    ∃ χ : ℝ → ℝ,
+      ContDiff ℝ ∞ χ ∧
+        HasCompactSupport χ ∧
+          (∀ᶠ t in 𝓝 0, χ t = 1) ∧
+            (∀ t, ε ≤ |t| → χ t = 0) ∧
+              (∀ t, χ t ∈ Set.Icc (0 : ℝ) 1) ∧ ∀ t, |t * deriv χ t| < δ := by
+  obtain ⟨β, hβ, hcompact, hsupp, hone, hrange⟩ :=
+    Smale.exists_compact_smooth_cutoff (K := {(0 : ℝ)}) (U := Metric.ball 0 1) isCompact_singleton
+      Metric.isOpen_ball (by simp)
+  obtain ⟨C, hC⟩ := hcompact.deriv.exists_bound_of_continuous (hβ.continuous_deriv (by simp))
+  let B : ℝ := Max.max C 0 + 1
+  have hB : 0 < B := by dsimp [B]; positivity
+  have hbound (t : ℝ) : |deriv β t| ≤ B := by
+    have hh := hC t
+    rw [Real.norm_eq_abs] at hh
+    exact hh.trans (by dsimp [B]; linarith [le_max_left C 0])
+  let L : ℝ := 2 * B / δ + 1
+  have hL : 0 < L := by dsimp [L]; positivity
+  have hsmall : B * (2 / L) < δ := by
+    rw [← mul_div_assoc]
+    apply (div_lt_iff₀ hL).mpr
+    dsimp [L]
+    have hd : δ * (2 * B / δ) = 2 * B := by field_simp
+    nlinarith
+  let η : ℝ := ε / Real.exp L
+  have hη : 0 < η := div_pos hε (Real.exp_pos L)
+  let q := logarithmicCoordinate η L
+  have hq : ContDiff ℝ ∞ q := contDiff_logarithmicCoordinate η L
+  have hqzero : q 0 = 0 := by simp [q, logarithmicCoordinate]
+  let χ : ℝ → ℝ := β ∘ q
+  have hχ : ContDiff ℝ ∞ χ := hβ.comp hq
+  have hout (t : ℝ) (ht : ε ≤ |t|) : χ t = 0 := by
+    have hratio : Real.exp L ≤ |t / η| := by
+      rw [abs_div, abs_of_pos hη, le_div_iff₀ hη]
+      have he : Real.exp L * η = ε := by dsimp [η]; field_simp
+      simpa only [he] using ht
+    have heone : 1 ≤ Real.exp L := Real.one_le_exp_iff.mpr hL.le
+    have hlower : L ≤ Real.log (1 + (t / η) ^ 2) := by
+      apply (Real.le_log_iff_exp_le (by positivity)).mpr
+      nlinarith [sq_abs (t / η)]
+    have honeq : 1 ≤ q t := (le_div_iff₀ hL).mpr (by simpa using hlower)
+    have hnotsupp : q t ∉ tsupport β := by
+      intro hh
+      have hball := hsupp hh
+      rw [Metric.mem_ball, Real.dist_eq, sub_zero, abs_lt] at hball
+      linarith [hball.2]
+    change β (q t) = 0
+    exact image_eq_zero_of_notMem_tsupport hnotsupp
+  have hcompactχ : HasCompactSupport χ := by
+    apply HasCompactSupport.intro (CompactIccSpace.isCompact_Icc : IsCompact (Set.Icc (-ε) ε))
+    intro t ht
+    apply hout
+    by_contra h
+    have hh := abs_lt.mp (lt_of_not_ge h)
+    exact ht ⟨hh.1.le, hh.2.le⟩
+  have hnear : ∀ᶠ t in 𝓝 0, χ t = 1 := by
+    have hb : ∀ᶠ r in 𝓝 (0 : ℝ), β r = 1 := by simpa only [nhdsSet_singleton] using hone
+    have ht : Filter.Tendsto q (𝓝 0) (𝓝 0) := by
+      have hh : Filter.Tendsto q (𝓝 0) (𝓝 (q 0)) := hq.continuous.continuousAt
+      simpa only [hqzero] using hh
+    exact ht.eventually hb
+  refine ⟨χ, hχ, hcompactχ, hnear, hout, fun t => hrange (q t), ?_⟩
+  intro t
+  have hder : deriv χ t = deriv β (q t) * deriv q t :=
+    ((hβ.differentiable (by simp)).differentiableAt.hasDerivAt.comp t
+        (hq.differentiable (by simp)).differentiableAt.hasDerivAt).deriv
+  rw [hder]
+  have he : |t * (deriv β (q t) * deriv q t)| = |deriv β (q t)| * |t * deriv q t| := by
+    rw [← abs_mul]; congr 1; ring
+  rw [he]
+  exact
+    lt_of_le_of_lt
+      (mul_le_mul (hbound _) (logarithmicCoordinate_weighted_deriv_bound hη hL t) (abs_nonneg _)
+        hB.le)
+      hsmall
+
+private theorem
+    Degree.FlowCancellation.deriv_eq_zero_of_nonneg_zero {χ : ℝ → ℝ} (hχ : Differentiable ℝ χ)
+    (hnonneg : ∀ t, 0 ≤ χ t) {t : ℝ} (ht : χ t = 0) : deriv χ t = 0 := by
+  have hm : IsLocalMin χ t :=
+    Filter.Eventually.of_forall
+      (fun s => by
+        change χ t ≤ χ s
+        rw [ht]
+        exact hnonneg s)
+  exact hm.hasDerivAt_eq_zero (hχ t).hasDerivAt
+
+private theorem Degree.FlowCancellation.weighted_blend_neg {α a b r s z μ C δ : ℝ}
+    (hα : α ∈ Set.Icc (0 : ℝ) 1) (ha : a ≤ -μ) (hb : b ≤ -μ) (hC : 0 ≤ C) (hr : |r| ≤ C * |s|)
+    (hz : |s * z| ≤ δ) (hsmall : C * δ < μ) : b + α * (a - b) - z * r < 0 := by
+  have hbase : b + α * (a - b) ≤ -μ := by
+    nlinarith [mul_nonneg hα.1 (sub_nonneg.mpr ha),
+      mul_nonneg (sub_nonneg.mpr hα.2) (sub_nonneg.mpr hb)]
+  have herr : |z * r| ≤ C * δ :=
+    calc
+      |z * r| = |z| * |r| := abs_mul _ _
+      _ ≤ |z| * (C * |s|) := (mul_le_mul_of_nonneg_left hr (abs_nonneg _))
+      _ = C * |s * z| := by rw [abs_mul]; ring
+      _ ≤ C * δ := mul_le_mul_of_nonneg_left hz hC
+  linarith [neg_abs_le (z * r)]
+
+private theorem
+    Degree.FlowCancellation.hasDerivAt_flow_height_zero {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ} {x : M}
+    (hf : MDifferentiableAt 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f x) (F : Flow ℝ M)
+    (hcurve : IsMIntegralCurve (fun t => F t x) V) :
+    HasDerivAt (fun t => f (F t x)) (mvfderiv 𝓘(ℝ, E) f x (V x)) 0 := by
+  have hf0 : MDifferentiableAt 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f (F 0 x) := by
+    rw [F.map_zero_apply]
+    exact hf
+  have hh := hasDerivAt_comp_native_integralCurve_at hf0 hcurve
+  have he := congrArg (fun y : M => mvfderiv 𝓘(ℝ, E) f y (V y)) (F.map_zero_apply x)
+  exact he ▸ hh
+
+private def
+    Degree.FlowCancellation.descentBlend {M : Type*} (χ : ℝ → ℝ) (θ f g : M → ℝ) (x : M) : ℝ :=
+  g x + χ (θ x) * (f x - g x)
+
+private theorem Degree.FlowCancellation.mvfderiv_descentBlend {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {χ : ℝ → ℝ} {θ f g : M → ℝ} {x : M}
+    (hχ : ContDiff ℝ ∞ χ) (hθ : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ θ x)
+    (hf : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f x) (hg : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g x)
+    (F : Flow ℝ M) (hcurve : IsMIntegralCurve (fun t => F t x) V)
+    (htime : mvfderiv 𝓘(ℝ, E) θ x (V x) = -1) :
+    mvfderiv 𝓘(ℝ, E) (descentBlend χ θ f g) x (V x) =
+      mvfderiv 𝓘(ℝ, E) g x (V x) +
+          χ (θ x) * (mvfderiv 𝓘(ℝ, E) f x (V x) - mvfderiv 𝓘(ℝ, E) g x (V x)) -
+        deriv χ (θ x) * (f x - g x) := by
+  have dθ := hasDerivAt_flow_height_zero (hθ.mdifferentiableAt (by simp)) F hcurve
+  have df := hasDerivAt_flow_height_zero (hf.mdifferentiableAt (by simp)) F hcurve
+  have dg := hasDerivAt_flow_height_zero (hg.mdifferentiableAt (by simp)) F hcurve
+  rw [htime] at dθ
+  have dχ := ((hχ.differentiable (by simp)) (θ (F 0 x))).hasDerivAt.comp 0 dθ
+  have db := dg.add (dχ.mul (df.sub dg))
+  have hb : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ (descentBlend χ θ f g) x :=
+    hg.add ((hχ.contMDiff.contMDiffAt.comp x hθ).mul (hf.sub hg))
+  have dn := hasDerivAt_flow_height_zero (hb.mdifferentiableAt (by simp)) F hcurve
+  have he := dn.unique db
+  simp only [Pi.sub_apply, Function.comp_apply, F.map_zero_apply] at he
+  exact he.trans (by ring)
+
+private theorem
+    Degree.FlowCancellation.exists_native_descent_blend {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {U : Set M} (hU : IsOpen U) {θ f g : M → ℝ}
+    (hθ : ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ θ U) (hf : ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f U)
+    (hg : ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g U) (F : Flow ℝ M)
+    (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (htime : ∀ x ∈ U, mvfderiv 𝓘(ℝ, E) θ x (V x) = -1)
+    (hgneg : ∀ x ∈ U, mvfderiv 𝓘(ℝ, E) g x (V x) < 0) {ε μ C : ℝ} (hε : 0 < ε) (hμ : 0 < μ)
+    (hC : 0 ≤ C)
+    (hcollar :
+      ∀ x ∈ U,
+        |θ x| < ε →
+          mvfderiv 𝓘(ℝ, E) f x (V x) ≤ -μ ∧
+            mvfderiv 𝓘(ℝ, E) g x (V x) ≤ -μ ∧ |f x - g x| ≤ C * |θ x|) :
+    ∃ b : M → ℝ,
+      ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ b U ∧
+        (∀ x ∈ U, mvfderiv 𝓘(ℝ, E) b x (V x) < 0) ∧
+          (∀ x ∈ U, θ x = 0 → b =ᶠ[𝓝 x] f) ∧
+            (∀ x, ε ≤ |θ x| → b x = g x) ∧ ∀ x ∈ U, ε < |θ x| → b =ᶠ[𝓝 x] g := by
+  let δ := μ / (C + 1)
+  have hδ : 0 < δ := div_pos hμ (by positivity)
+  have hsmall : C * δ < μ := by
+    dsimp [δ]
+    rw [← mul_div_assoc, div_lt_iff₀ (by positivity : 0 < C + 1)]
+    nlinarith
+  obtain ⟨χ, hχ, -, hone, hzero, hrange, hweight⟩ := exists_logarithmic_cutoff hε hδ
+  let b := descentBlend χ θ f g
+  have hb : ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ b U :=
+    hg.add ((hχ.contMDiff.comp_contMDiffOn hθ).mul (hf.sub hg))
+  have hout (x : M) (hx : ε ≤ |θ x|) : b x = g x := by
+    simp only [b, descentBlend, hzero _ hx, MulZeroClass.zero_mul, add_zero]
+  refine ⟨b, hb, ?_, ?_, hout, ?_⟩
+  · intro x hx
+    have hder :=
+      mvfderiv_descentBlend hχ ((hθ x hx).contMDiffAt (hU.mem_nhds hx))
+        ((hf x hx).contMDiffAt (hU.mem_nhds hx)) ((hg x hx).contMDiffAt (hU.mem_nhds hx)) F
+        (hcurve x) (htime x hx)
+    change mvfderiv 𝓘(ℝ, E) (descentBlend χ θ f g) x (V x) < 0
+    rw [hder]
+    by_cases hnear : |θ x| < ε
+    · obtain ⟨hdf, hdg, hdiff⟩ := hcollar x hx hnear
+      exact weighted_blend_neg (hrange _) hdf hdg hC hdiff (hweight _).le hsmall
+    · have hz := hzero (θ x) (le_of_not_gt hnear)
+      have hdχ :=
+        deriv_eq_zero_of_nonneg_zero (hχ.differentiable (by simp)) (fun t => (hrange t).1) hz
+      simpa only [hz, hdχ, MulZeroClass.zero_mul, add_zero, sub_zero] using hgneg x hx
+  · intro x hx hxzero
+    have ht : ContinuousAt θ x := (hθ x hx).continuousWithinAt.continuousAt (hU.mem_nhds hx)
+    have hone' : ∀ᶠ t in 𝓝 (θ x), χ t = 1 := by simpa only [hxzero] using hone
+    filter_upwards [ht.eventually hone'] with y hy
+    change g y + χ (θ y) * (f y - g y) = f y
+    rw [hy]
+    ring
+  · intro x hx hxout
+    have ht : ContinuousAt (fun y => |θ y|) x :=
+      ((hθ x hx).continuousWithinAt.continuousAt (hU.mem_nhds hx)).abs
+    filter_upwards [ht (eventually_gt_nhds hxout)] with y hy
+    exact hout y hy.le
+
+private def
+    Degree.FlowCancellation.flowTube {X : Type*} [TopologicalSpace X] (F : Flow ℝ X) (S : Set X)
+    (ε : ℝ) : Set X :=
+  (fun q : ℝ × X => F q.1 q.2) '' (Set.Icc (-ε) ε ×ˢ S)
+
+private theorem
+    Degree.FlowCancellation.isCompact_flowTube {X : Type*} [TopologicalSpace X] (F : Flow ℝ X)
+    {S : Set X} (hS : IsCompact S) (ε : ℝ) : IsCompact (flowTube F S ε) :=
+  (CompactIccSpace.isCompact_Icc.prod hS).image (F.continuous continuous_fst continuous_snd)
+
+private theorem Degree.FlowCancellation.exists_flowTube_subset {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {S N : Set X} (hS : IsCompact S) (hN : IsOpen N) (hSN : S ⊆ N) :
+    ∃ ε : ℝ, 0 < ε ∧ flowTube F S ε ⊆ N := by
+  have hopen : IsOpen {t : ℝ | ∀ x ∈ S, F t x ∈ N} :=
+    Smale.MorsePerturbation.isOpen_forall_mem_compact hS
+      (hN.preimage (F.continuous continuous_fst continuous_snd))
+  have hzero : (0 : ℝ) ∈ {t : ℝ | ∀ x ∈ S, F t x ∈ N} := by
+    intro x hx
+    simpa only [F.map_zero_apply] using hSN hx
+  obtain ⟨r, hr, hball⟩ := Metric.mem_nhds_iff.mp (hopen.mem_nhds hzero)
+  refine ⟨r / 2, half_pos hr, ?_⟩
+  rintro y ⟨⟨t, x⟩, ⟨ht, hx⟩, rfl⟩
+  apply hball ?_ x hx
+  rw [Metric.mem_ball, Real.dist_eq, sub_zero, abs_lt]
+  constructor <;> linarith [ht.1, ht.2]
+
+private theorem Degree.FlowCancellation.mem_flowTube_of_signedTime {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) (f : X → ℝ) (c : ℝ) {ε : ℝ} {x : X} (hx : x ∈ levelBasin F f c)
+    (ht : |signedLevelTime F f c x| ≤ ε) : x ∈ flowTube F {y | f y = c} ε := by
+  refine
+    ⟨(-signedLevelTime F f c x, F (signedLevelTime F f c x) x),
+      ⟨?_, signedLevelTime_hits F f c hx⟩, ?_⟩
+  · constructor <;> linarith [(abs_le.mp ht).1, (abs_le.mp ht).2]
+  · simp only [← F.map_add, neg_add_cancel, F.map_zero_apply]
+
+private theorem
+    Degree.FlowCancellation.exists_compact_negative_margin {X : Type*} [TopologicalSpace X]
+    {S : Set X} (hS : IsCompact S) {D : X → ℝ} (hD : ContinuousOn D S) (hneg : ∀ x ∈ S, D x < 0) :
+    ∃ μ : ℝ, 0 < μ ∧ ∀ x ∈ S, D x < -μ := by
+  by_cases hne : S.Nonempty
+  · obtain ⟨p, hp, hmax⟩ := hS.exists_isMaxOn hne hD
+    refine ⟨-D p / 2, by linarith [hneg p hp], ?_⟩
+    intro x hx
+    have hle : D x ≤ D p := hmax hx
+    linarith [hneg p hp]
+  · exact ⟨1, zero_lt_one, fun x hx => (hne ⟨x, hx⟩).elim⟩
+
+private theorem Degree.FlowCancellation.contMDiffOn_directionalDerivative {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {U : Set M} (hU : IsOpen U)
+    {g : M → ℝ} (hg : ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g U)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M))) :
+    ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ (fun x => mvfderiv 𝓘(ℝ, E) g x (V x)) U := by
+  have ht :=
+    (hg.contMDiffOn_tangentMapWithin (m := ∞) (by simp) hU.uniqueMDiffOn).comp hV.contMDiffOn
+      (fun x hx => hx)
+  have hh := (contMDiff_snd_tangentBundle_modelSpace ℝ 𝓘(ℝ, ℝ)).comp_contMDiffOn ht
+  apply hh.congr
+  intro x hx
+  change
+    (NormedSpace.fromTangentSpace (g x)) (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) g x (V x)) =
+      (NormedSpace.fromTangentSpace (g x)) (mfderivWithin 𝓘(ℝ, E) 𝓘(ℝ, ℝ) g U x (V x))
+  rw [mfderivWithin_of_isOpen hU hx]
+
+private theorem Degree.FlowCancellation.exists_native_time_collar_bounds {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} [CompactSpace M] {U : Set M}
+    (hU : IsOpen U) {f g : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hg : ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g U)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) {c : ℝ}
+    (hlevel : {x | f x = c} ⊆ U) (hbasin : U ⊆ levelBasin F f c) (heq : ∀ x, f x = c → g x = f x)
+    (hfc : ∀ x, f x = c → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hgc : ∀ x, f x = c → mvfderiv 𝓘(ℝ, E) g x (V x) < 0) :
+    ∃ ε μ C : ℝ,
+      0 < ε ∧
+        0 < μ ∧
+          0 ≤ C ∧
+            ∀ x ∈ U,
+              |signedLevelTime F f c x| < ε →
+                mvfderiv 𝓘(ℝ, E) f x (V x) ≤ -μ ∧
+                  mvfderiv 𝓘(ℝ, E) g x (V x) ≤ -μ ∧ |f x - g x| ≤ C * |signedLevelTime F f c x| :=
+  by
+  let S : Set M := {x | f x = c}
+  have hS : IsCompact S := (isClosed_eq hf.continuous continuous_const).isCompact
+  let Df (x : M) := mvfderiv 𝓘(ℝ, E) f x (V x)
+  let Dg (x : M) := mvfderiv 𝓘(ℝ, E) g x (V x)
+  have hDf : Continuous Df := (MorseCancel.contMDiff_directionalDerivative hf hV).continuous
+  have hDg : ContinuousOn Dg U := (contMDiffOn_directionalDerivative hU hg hV).continuousOn
+  have hmax : ContinuousOn (fun x => Max.max (Df x) (Dg x)) U :=
+    continuous_max.comp_continuousOn (hDf.continuousOn.prodMk hDg)
+  obtain ⟨μ, hμ, hmargin⟩ :=
+    exists_compact_negative_margin hS (hmax.mono hlevel)
+      (fun x hx => max_lt (hfc x hx) (hgc x hx))
+  let N : Set M := U ∩ (fun x => Max.max (Df x) (Dg x)) ⁻¹' Set.Iio (-μ)
+  have hN : IsOpen N := hmax.isOpen_inter_preimage hU isOpen_Iio
+  have hSN : S ⊆ N := fun x hx => ⟨hlevel hx, hmargin x hx⟩
+  obtain ⟨ε, hε, htube⟩ := exists_flowTube_subset F hS hN hSN
+  let K := flowTube F S ε
+  have hK : IsCompact K := isCompact_flowTube F hS ε
+  have hKU : K ⊆ U := fun x hx => (htube hx).1
+  obtain ⟨C₀, hC₀⟩ := hK.exists_bound_of_continuousOn (hDf.continuousOn.sub (hDg.mono hKU))
+  let C : ℝ := Max.max C₀ 0
+  have hC : 0 ≤ C := le_max_right _ _
+  have hbound (x : M) (hx : x ∈ K) : ‖Df x - Dg x‖ ≤ C := (hC₀ x hx).trans (le_max_left _ _)
+  refine ⟨ε, μ, C, hε, hμ, hC, ?_⟩
+  intro x hx hxε
+  have hxK : x ∈ K := mem_flowTube_of_signedTime F f c (hbasin hx) hxε.le
+  have hxN := htube hxK
+  have hneg : Max.max (Df x) (Dg x) < -μ := hxN.2
+  refine
+    ⟨(lt_of_le_of_lt (le_max_left _ _) hneg).le, (lt_of_le_of_lt (le_max_right _ _) hneg).le, ?_⟩
+  let θ := signedLevelTime F f c x
+  let y := F θ x
+  have hy : f y = c := signedLevelTime_hits F f c (hbasin hx)
+  have hpoint (t : ℝ) (ht : t ∈ Set.Icc (-ε) ε) : F t y ∈ K := ⟨(t, y), ⟨ht, hy⟩, rfl⟩
+  let ℓ (t : ℝ) := f (F t y) - g (F t y)
+  have hd (t : ℝ) (ht : t ∈ Set.Icc (-ε) ε) : HasDerivAt ℓ (Df (F t y) - Dg (F t y)) t := by
+    have hgpoint :=
+      ((hg (F t y) (hKU (hpoint t ht))).contMDiffAt
+            (hU.mem_nhds (hKU (hpoint t ht)))).mdifferentiableAt
+        (by simp)
+    exact
+      (hasDerivAt_comp_native_integralCurve_at (hf.mdifferentiableAt (by simp)) (hcurve y)).sub
+        (hasDerivAt_comp_native_integralCurve_at hgpoint (hcurve y))
+  have h0 : (0 : ℝ) ∈ Set.Icc (-ε) ε := ⟨by linarith, hε.le⟩
+  have hθ : -θ ∈ Set.Icc (-ε) ε := by
+    constructor <;> linarith [(abs_lt.mp hxε).1, (abs_lt.mp hxε).2]
+  have hmvt :=
+    (convex_Icc (-ε) ε).norm_image_sub_le_of_norm_deriv_le
+      (fun t ht => (hd t ht).differentiableAt)
+      (fun t ht => by rw [(hd t ht).deriv]; exact hbound _ (hpoint t ht)) h0 hθ
+  have hreturn : F (-θ) y = x := by
+    dsimp [y]
+    rw [← F.map_add, neg_add_cancel, F.map_zero_apply]
+  simpa only [ℓ, F.map_zero_apply, hreturn, heq y hy, sub_self, sub_zero, Real.norm_eq_abs,
+    abs_neg] using hmvt
+
+private theorem Degree.FlowCancellation.exists_boundary_germ_correction {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {U : Set M} (hU : IsOpen U) {f g : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hg : ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g U)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) {c : ℝ}
+    (hlevel : {x | f x = c} ⊆ U) (hbasin : U ⊆ levelBasin F f c) (heq : ∀ x, f x = c → g x = f x)
+    (hfc : ∀ x, f x = c → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hgneg : ∀ x ∈ U, mvfderiv 𝓘(ℝ, E) g x (V x) < 0) {r : ℝ} (hr : 0 < r) :
+    ∃ b : M → ℝ,
+      ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ b U ∧
+        (∀ x ∈ U, mvfderiv 𝓘(ℝ, E) b x (V x) < 0) ∧
+          (∀ x, f x = c → b =ᶠ[𝓝 x] f) ∧ ∀ x ∈ U, r ≤ |signedLevelTime F f c x| → b =ᶠ[𝓝 x] g := by
+  obtain ⟨ε₀, μ, C, hε₀, hμ, hC, hbounds⟩ :=
+    exists_native_time_collar_bounds hU hf hg hV F hcurve hlevel hbasin heq hfc
+      (fun x hx => hgneg x (hlevel hx))
+  let ε := Min.min ε₀ (r / 2)
+  have hε : 0 < ε := lt_min hε₀ (half_pos hr)
+  have hεr : ε < r := lt_of_le_of_lt (min_le_right _ _) (by linarith)
+  obtain ⟨-, hθ, -⟩ := smooth_signed_level_time hf hV F hcurve hfc
+  have htime (x : M) (hx : x ∈ U) : mvfderiv 𝓘(ℝ, E) (signedLevelTime F f c) x (V x) = -1 :=
+    mvfderiv_signedLevelTime hf hV F hcurve hfc (hbasin hx)
+  obtain ⟨b, hb, hbneg, hbone, -, hboff⟩ :=
+    exists_native_descent_blend hU (hθ.mono hbasin) hf.contMDiffOn hg F hcurve htime hgneg hε hμ
+      hC (fun x hx ht => hbounds x hx (lt_of_lt_of_le ht (min_le_left _ _)))
+  refine ⟨b, hb, hbneg, ?_, fun x hx ht => hboff x hx (hεr.trans_le ht)⟩
+  intro x hx
+  apply hbone x (hlevel hx)
+  let D (y : M) := mvfderiv 𝓘(ℝ, E) f y (V y)
+  have hD : Continuous D := (MorseCancel.contMDiff_directionalDerivative hf hV).continuous
+  exact
+    signedLevelTime_eq_zero F hf.continuous hD
+      (fun y t => Smale.FlowConstruction.hasDerivAt_comp_integralCurve hf (hcurve y) t) hfc hx
+
+private theorem Degree.FlowCancellation.exists_signedTime_level_separation {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) {c d : ℝ} (hcd : c ≠ d)
+    (hc : ∀ x, f x = c → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hlevel : {x | f x = d} ⊆ levelBasin F f c) :
+    ∃ r : ℝ, 0 < r ∧ ∀ x, f x = d → r < |signedLevelTime F f c x| := by
+  obtain ⟨-, hθ, -⟩ := smooth_signed_level_time hf hV F hcurve hc
+  have hS : IsCompact {x | f x = d} := (isClosed_eq hf.continuous continuous_const).isCompact
+  obtain ⟨r, hr, hmargin⟩ :=
+    exists_compact_negative_margin hS ((hθ.continuousOn.mono hlevel).abs.neg)
+      (fun x hx => by
+        apply neg_neg_of_pos
+        apply abs_pos.mpr
+        intro hz
+        have hhit := signedLevelTime_hits F f c (hlevel hx)
+        rw [hz, F.map_zero_apply] at hhit
+        exact hcd (hhit.symm.trans hx))
+  refine ⟨r, hr, fun x hx => ?_⟩
+  have hh : -|signedLevelTime F f c x| < -r := hmargin x hx
+  linarith
+
+private theorem Degree.FlowCancellation.exists_boundary_correction_preserving_level {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {U : Set M} (hU : IsOpen U) {f g : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hg : ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g U)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) {c d : ℝ} (hcd : c ≠ d)
+    (hcU : {x | f x = c} ⊆ U) (hdU : {x | f x = d} ⊆ U) (hbasin : U ⊆ levelBasin F f c)
+    (heq : ∀ x, f x = c → g x = f x) (hfc : ∀ x, f x = c → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hgneg : ∀ x ∈ U, mvfderiv 𝓘(ℝ, E) g x (V x) < 0) :
+    ∃ b : M → ℝ,
+      ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ b U ∧
+        (∀ x ∈ U, mvfderiv 𝓘(ℝ, E) b x (V x) < 0) ∧
+          (∀ x, f x = c → b =ᶠ[𝓝 x] f) ∧ ∀ x, f x = d → b =ᶠ[𝓝 x] g := by
+  obtain ⟨r, hr, hsep⟩ :=
+    exists_signedTime_level_separation hf hV F hcurve hcd hfc (hdU.trans hbasin)
+  obtain ⟨b, hb, hbneg, hbc, hboff⟩ :=
+    exists_boundary_germ_correction hU hf hg hV F hcurve hcU hbasin heq hfc hgneg hr
+  exact ⟨b, hb, hbneg, hbc, fun x hx => hboff x (hdU hx) (hsep x hx).le⟩
+
+private theorem Degree.FlowCancellation.band_subset_crossingBasin {X : Type*} [TopologicalSpace X]
+    (F : Flow ℝ X) {f : X → ℝ} (hf : Continuous f) {c d T : ℝ} (hT : 0 < T)
+    (hforward : ∀ x, f x ≤ d → f (F T x) < c) (hbackward : ∀ x, c ≤ f x → d < f (F (-T) x)) :
+    f ⁻¹' Set.Icc c d ⊆ crossingBasin F f c d := by
+  intro x hx
+  have hcont : Continuous (fun t : ℝ => f (F t x)) :=
+    hf.comp (F.continuous continuous_id continuous_const)
+  constructor
+  · obtain ⟨t, -, ht⟩ :=
+      intermediate_value_Icc' hT.le hcont.continuousOn
+        (show c ∈ Set.Icc (f (F T x)) (f (F 0 x)) from
+          ⟨(hforward x hx.2).le, by simpa only [F.map_zero_apply] using hx.1⟩)
+    exact ⟨t, ht⟩
+  · obtain ⟨t, -, ht⟩ :=
+      intermediate_value_Icc' (show -T ≤ (0 : ℝ) by linarith) hcont.continuousOn
+        (show d ∈ Set.Icc (f (F 0 x)) (f (F (-T) x)) from
+          ⟨by simpa only [F.map_zero_apply] using hx.2, (hbackward x hx.1).le⟩)
+    exact ⟨t, ht⟩
+
+private theorem Degree.FlowCancellation.exists_smooth_band_height_germs {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) {c d : ℝ} (hcd : c < d)
+    (hc : ∀ x, f x = c → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hd : ∀ x, f x = d → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hcross : ∃ T : ℝ, 0 < T ∧ (∀ x, f x ≤ d → f (F T x) < c) ∧ ∀ x, c ≤ f x → d < f (F (-T) x)) :
+    ∃ (U : Set M) (g : M → ℝ),
+      IsOpen U ∧
+        f ⁻¹' Set.Icc c d ⊆ U ∧
+          ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g U ∧
+            (∀ x ∈ U, mvfderiv 𝓘(ℝ, E) g x (V x) < 0) ∧ ∀ x, f x = c ∨ f x = d → g =ᶠ[𝓝 x] f := by
+  let U := crossingBasin F f c d
+  let g := flowBandHeight F f c d
+  obtain ⟨hU, hg, hgder⟩ := smooth_flowBandHeight hf hV F hcurve hcd hc hd
+  obtain ⟨T, hT, hforward, hbackward⟩ := hcross
+  have hband : f ⁻¹' Set.Icc c d ⊆ U :=
+    band_subset_crossingBasin F hf.continuous hT hforward hbackward
+  have hcU : {x | f x = c} ⊆ U := fun x hx =>
+    hband (show f x ∈ Set.Icc c d from ⟨by rw [hx], by rw [hx]; exact hcd.le⟩)
+  have hdU : {x | f x = d} ⊆ U := fun x hx =>
+    hband (show f x ∈ Set.Icc c d from ⟨by rw [hx]; exact hcd.le, by rw [hx]⟩)
+  let D (x : M) := mvfderiv 𝓘(ℝ, E) f x (V x)
+  have hD : Continuous D := (MorseCancel.contMDiff_directionalDerivative hf hV).continuous
+  have hder (x : M) (t : ℝ) : HasDerivAt (fun s => f (F s x)) (D (F t x)) t :=
+    Smale.FlowConstruction.hasDerivAt_comp_integralCurve hf (hcurve x) t
+  have hgc (x : M) (hx : f x = c) : g x = f x :=
+    (flowBandHeight_lower F hf.continuous hD hder hc hx).trans hx.symm
+  have hgd (x : M) (hx : f x = d) : g x = f x :=
+    (flowBandHeight_upper F hf.continuous hD hder hc hd hcd (hdU hx) hx).trans hx.symm
+  obtain ⟨b, hb, hbneg, hbc, hbd⟩ :=
+    exists_boundary_correction_preserving_level hU hf hg hV F hcurve hcd.ne hcU hdU
+      Set.inter_subset_left hgc hc (fun x hx => (hgder x hx).2)
+  have hbdval (x : M) (hx : f x = d) : b x = f x := (hbd x hx).eq_of_nhds.trans (hgd x hx)
+  obtain ⟨k, hk, hkneg, hkd, hkc⟩ :=
+    exists_boundary_correction_preserving_level hU hf hb hV F hcurve hcd.ne' hdU hcU
+      Set.inter_subset_right hbdval hd hbneg
+  refine ⟨U, k, hU, hband, hk, hkneg, ?_⟩
+  intro x hx
+  rcases hx with hx | hx
+  · exact (hkc x hx).trans (hbc x hx)
+  · exact hkd x hx
+
+private def
+    Degree.FlowCancellation.bandReplacement {X : Type*} (f g : X → ℝ) (c d : ℝ) (x : X) : ℝ := by
+  classical exact if f x ∈ Set.Ioo c d then g x else f x
+
+private theorem
+    Degree.FlowCancellation.bandReplacement_germ_boundary {X : Type*} [TopologicalSpace X]
+    {f g : X → ℝ} {c d : ℝ} {x : X} (heq : g =ᶠ[𝓝 x] f) :
+    bandReplacement f g c d =ᶠ[𝓝 x] f ∧ bandReplacement f g c d =ᶠ[𝓝 x] g := by
+  have hh : bandReplacement f g c d =ᶠ[𝓝 x] f := by
+    filter_upwards [heq] with y hy
+    simp only [bandReplacement, hy, ite_self]
+  exact ⟨hh, hh.trans heq.symm⟩
+
+private theorem
+    Degree.FlowCancellation.bandReplacement_germ_interior {X : Type*} [TopologicalSpace X]
+    {f g : X → ℝ} {c d : ℝ} (hf : Continuous f) {x : X} (hx : f x ∈ Set.Ioo c d) :
+    bandReplacement f g c d =ᶠ[𝓝 x] g := by
+  filter_upwards [(isOpen_Ioo.preimage hf).mem_nhds hx] with y hy
+  exact ite_eq_left hy
+
+private theorem
+    Degree.FlowCancellation.bandReplacement_germ_exterior {X : Type*} [TopologicalSpace X]
+    {f g : X → ℝ} {c d : ℝ} (hf : Continuous f) {x : X} (hx : f x ∉ Set.Icc c d) :
+    bandReplacement f g c d =ᶠ[𝓝 x] f := by
+  filter_upwards [((isClosed_Icc.preimage hf).isOpen_compl).mem_nhds hx] with y hy
+  exact ite_eq_right (fun h => hy ⟨h.1.le, h.2.le⟩)
+
+private theorem
+    Degree.FlowCancellation.bandReplacement_germ_on_closed {X : Type*} [TopologicalSpace X]
+    {f g : X → ℝ} {c d : ℝ} (hf : Continuous f) (hboundary : ∀ x, f x = c ∨ f x = d → g =ᶠ[𝓝 x] f)
+    {x : X} (hx : f x ∈ Set.Icc c d) : bandReplacement f g c d =ᶠ[𝓝 x] g := by
+  by_cases hc : f x = c
+  · exact (bandReplacement_germ_boundary (hboundary x (Or.inl hc))).2
+  by_cases hd : f x = d
+  · exact (bandReplacement_germ_boundary (hboundary x (Or.inr hd))).2
+  exact
+    bandReplacement_germ_interior hf ⟨lt_of_le_of_ne hx.1 (Ne.symm hc), lt_of_le_of_ne hx.2 hd⟩
+
+private theorem
+    Degree.FlowCancellation.bandReplacement_germ_off_open {X : Type*} [TopologicalSpace X]
+    {f g : X → ℝ} {c d : ℝ} (hf : Continuous f) (hboundary : ∀ x, f x = c ∨ f x = d → g =ᶠ[𝓝 x] f)
+    {x : X} (hx : f x ∉ Set.Ioo c d) : bandReplacement f g c d =ᶠ[𝓝 x] f := by
+  by_cases hc : f x = c
+  · exact (bandReplacement_germ_boundary (hboundary x (Or.inl hc))).1
+  by_cases hd : f x = d
+  · exact (bandReplacement_germ_boundary (hboundary x (Or.inr hd))).1
+  apply bandReplacement_germ_exterior hf
+  intro h
+  exact hx ⟨lt_of_le_of_ne h.1 (Ne.symm hc), lt_of_le_of_ne h.2 hd⟩
+
+private theorem
+    Degree.FlowCancellation.contMDiff_bandReplacement {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ} {c d : ℝ} {U : Set M}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hg : ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g U) (hU : IsOpen U)
+    (hband : f ⁻¹' Set.Icc c d ⊆ U) (hboundary : ∀ x, f x = c ∨ f x = d → g =ᶠ[𝓝 x] f) :
+    ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ (bandReplacement f g c d) := by
+  intro x
+  by_cases hx : f x ∈ Set.Icc c d
+  · exact
+      ((hg x (hband hx)).contMDiffAt (hU.mem_nhds (hband hx))).congr_of_eventuallyEq
+        (bandReplacement_germ_on_closed hf.continuous hboundary hx)
+  · exact hf.contMDiffAt.congr_of_eventuallyEq (bandReplacement_germ_exterior hf.continuous hx)
+
+private theorem Degree.FlowCancellation.mvfderiv_eq_of_germ {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f g : M → ℝ} {x : M} (heq : f =ᶠ[𝓝 x] g) :
+    mvfderiv 𝓘(ℝ, E) f x (V x) = mvfderiv 𝓘(ℝ, E) g x (V x) := by
+  unfold mvfderiv
+  rw [heq.mfderiv_eq, heq.eq_of_nhds]
+
+private theorem
+    Degree.FlowCancellation.exists_global_band_lyapunov {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} [FiniteDimensional ℝ E] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [CompactSpace M] {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) {c d : ℝ} (hcd : c < d)
+    (hc : ∀ x, f x = c → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hd : ∀ x, f x = d → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hcross : ∃ T : ℝ, 0 < T ∧ (∀ x, f x ≤ d → f (F T x) < c) ∧ ∀ x, c ≤ f x → d < f (F (-T) x)) :
+    ∃ b : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ b ∧
+        (∀ x, f x ∈ Set.Icc c d → mvfderiv 𝓘(ℝ, E) b x (V x) < 0) ∧
+          ∀ x, f x ∉ Set.Ioo c d → b =ᶠ[𝓝 x] f := by
+  obtain ⟨U, g, hU, hband, hg, hgneg, hgerm⟩ :=
+    exists_smooth_band_height_germs hf hV F hcurve hcd hc hd hcross
+  refine ⟨bandReplacement f g c d, contMDiff_bandReplacement hf hg hU hband hgerm, ?_, ?_⟩
+  · intro x hx
+    rw [mvfderiv_eq_of_germ (V := V) (bandReplacement_germ_on_closed hf.continuous hgerm hx)]
+    exact hgneg x (hband hx)
+  · intro x hx
+    exact bandReplacement_germ_off_open hf.continuous hgerm hx
+
+private def
+    MorseCancel.hessian {m : ℕ} (σ : Fin m → ℝ) (p : Model m) : Model m →L[ℝ] Model m →L[ℝ] ℝ :=
+  (2 * p.1) •
+      (ContinuousLinearMap.fst ℝ ℝ (Fin m → ℝ)).smulRight
+        (ContinuousLinearMap.fst ℝ ℝ (Fin m → ℝ)) +
+    ∑ i,
+      (2 * σ i) •
+        (((ContinuousLinearMap.proj i).comp (ContinuousLinearMap.snd ℝ ℝ (Fin m → ℝ))).smulRight
+          ((ContinuousLinearMap.proj i).comp (ContinuousLinearMap.snd ℝ ℝ (Fin m → ℝ))))
+
+private theorem MorseCancel.hessian_apply {m : ℕ} (σ : Fin m → ℝ) (p v w : Model m) :
+    hessian σ p v w = 2 * p.1 * v.1 * w.1 + ∑ i, 2 * σ i * v.2 i * w.2 i := by
+  simp [hessian, mul_assoc]
+
+private theorem MorseCancel.hasFDerivAt_differential {m : ℕ} (σ : Fin m → ℝ) (t : ℝ) (p : Model m) :
+    HasFDerivAt (differential σ t) (hessian σ p) p := by
+  have hx := (ContinuousLinearMap.fst ℝ ℝ (Fin m → ℝ)).hasFDerivAt (x := p)
+  let L (i : Fin m) : Model m →L[ℝ] ℝ :=
+    (ContinuousLinearMap.proj i).comp (ContinuousLinearMap.snd ℝ ℝ (Fin m → ℝ))
+  have hq :=
+    HasFDerivAt.fun_sum (u := Finset.univ)
+      (fun i _ => (((L i).hasFDerivAt (x := p)).const_mul (2 * σ i)).smul_const (L i))
+  convert
+      (((hx.pow 2).add_const t).smul_const (ContinuousLinearMap.fst ℝ ℝ (Fin m → ℝ))).add hq using
+      1 <;>
+    first
+    | rfl
+    | ( apply ContinuousLinearMap.ext; intro v
+        apply ContinuousLinearMap.ext; intro w
+        simp [hessian, L, mul_assoc])
+
+private theorem MorseCancel.fderiv_cubic_hessian {m : ℕ} (σ : Fin m → ℝ) (t : ℝ) (p : Model m) :
+    fderiv ℝ (fderiv ℝ (cubic σ t)) p = hessian σ p := by
+  rw [show fderiv ℝ (cubic σ t) = differential σ t from funext (fderiv_cubic σ t)]
+  exact (hasFDerivAt_differential σ t p).fderiv
+
+private theorem
+    MorseCancel.hessian_bijective {m : ℕ} (σ : Fin m → ℝ) (hσ : ∀ i, σ i ≠ 0) {p : Model m}
+    (hp : p.1 ≠ 0) : Function.Bijective (hessian σ p) := by
+  have hi : Function.Injective (hessian σ p) := by
+    apply (injective_iff_map_eq_zero (hessian σ p)).mpr
+    intro v hv
+    have hx := congrArg (fun L : Model m →L[ℝ] ℝ => L (1, 0)) hv
+    have hx' : 2 * p.1 * v.1 = 0 := by simpa [hessian_apply] using hx
+    have hvx : v.1 = 0 := (mul_eq_zero.mp hx').resolve_left (mul_ne_zero (by norm_num) hp)
+    apply Prod.ext hvx
+    funext i
+    have hy := congrArg (fun L : Model m →L[ℝ] ℝ => L (0, Pi.single i 1)) hv
+    have hy' : 2 * σ i * v.2 i = 0 := by simpa [hessian_apply, Pi.single_apply] using hy
+    exact (mul_eq_zero.mp hy').resolve_left (mul_ne_zero (by norm_num) (hσ i))
+  have hd : Module.finrank ℝ (Model m) = Module.finrank ℝ (Model m →L[ℝ] ℝ) := by
+    calc
+      _ = Module.finrank ℝ (Model m →ₗ[ℝ] ℝ) := Subspace.dual_finrank_eq.symm
+      _ = _ :=
+        (LinearMap.toContinuousLinearMap : (Model m →ₗ[ℝ] ℝ) ≃ₗ[ℝ] (Model m →L[ℝ] ℝ)).finrank_eq
+  exact
+    ⟨hi,
+      (LinearMap.injective_iff_surjective_of_finrank_eq_finrank (f := (hessian σ p).toLinearMap)
+            hd).mp
+        hi⟩
+
+private theorem MorseCancel.cubic_isMorse {m : ℕ} (σ : Fin m → ℝ) (hσ : ∀ i, σ i ≠ 0) {t : ℝ}
+    (ht : t ≠ 0) : Smale.MorsePerturbation.IsMorse (cubic σ t) := by
+  intro p hcrit
+  rw [fderiv_cubic_hessian]
+  apply hessian_bijective σ hσ
+  intro hp
+  have h := ((critical_iff σ hσ t p).mp hcrit).1
+  exact ht (by simpa [hp] using h)
+
+private theorem Degree.NativeCubicCancellation.exists_cutoff {m : ℕ} {V : Set (MorseCancel.Model m)}
+    (hV : IsOpen V) (h0 : (0 : MorseCancel.Model m) ∈ V) :
+    ∃ φ : MorseCancel.Model m → ℝ,
+      ContDiff ℝ ∞ φ ∧
+        HasCompactSupport φ ∧
+          tsupport φ ⊆ V ∧
+            ∃ U : Set (MorseCancel.Model m),
+              IsOpen U ∧ (0 : MorseCancel.Model m) ∈ U ∧ Set.EqOn φ (fun _ => 1) U := by
+  obtain ⟨r, hr, hball⟩ := Metric.mem_nhds_iff.mp (hV.mem_nhds h0)
+  let φ : ContDiffBump (0 : MorseCancel.Model m) := ⟨r / 4, r / 2, by positivity, by linarith⟩
+  refine
+    ⟨φ, φ.contDiff, φ.hasCompactSupport, ?_, Metric.ball 0 (r / 4), Metric.isOpen_ball,
+      Metric.mem_ball_self (by positivity), ?_⟩
+  · rw [φ.tsupport_eq]
+    intro p hp
+    apply hball
+    exact lt_of_le_of_lt hp (by change r / 2 < r; linarith)
+  · intro p hp
+    exact φ.one_of_mem_closedBall (Metric.ball_subset_closedBall hp)
+
+private theorem Degree.MorseCancellationPreservation.isMorseAt_of_same_germ {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ}
+    {x : M} (hf : Smale.ManifoldMorse.IsMorseAt E f x) (heq : g =ᶠ[𝓝 x] f) :
+    Smale.ManifoldMorse.IsMorseAt E g x := by
+  obtain ⟨e, he, hx, hgood⟩ := hf
+  refine ⟨e, he, hx, ?_⟩
+  have ht : Filter.Tendsto e.symm (𝓝 (e x)) (𝓝 x) := by
+    have h := e.symm.continuousAt (e.map_source hx)
+    rw [ContinuousAt, e.left_inv hx] at h
+    exact h
+  have hc : g ∘ e.symm =ᶠ[𝓝 (e x)] f ∘ e.symm := heq.comp_tendsto ht
+  rw [hc.fderiv_eq, (hc.fderiv (𝕜 := ℝ)).fderiv_eq]
+  exact hgood
+
+private theorem Degree.MorseCancellationPreservation.isMorseAt_of_regular {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {g : M → ℝ} (hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g) {x : M}
+    (hreg : mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) g x ≠ 0) : Smale.ManifoldMorse.IsMorseAt E g x := by
+  let e := chartAt E x
+  have he : e ∈ IsManifold.maximalAtlas 𝓘(ℝ, E) ∞ M := IsManifold.chart_mem_maximalAtlas x
+  have hx : x ∈ e.source := mem_chart_source E x
+  refine ⟨e, he, hx, Or.inl ?_⟩
+  intro hc
+  exact hreg ((Smale.ManifoldMorse.mem_criticalPoints_iff hg he hx).mpr hc)
+
+private theorem Degree.MorseCancellationPreservation.isMorse_of_critical_germs {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f g : M → ℝ} (hf : Smale.ManifoldMorse.IsMorse E f)
+    (hg : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g)
+    (hkeep : ∀ x, mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) g x = 0 → g =ᶠ[𝓝 x] f) :
+    Smale.ManifoldMorse.IsMorse E g := by
+  intro x
+  by_cases hx : mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) g x = 0
+  · exact isMorseAt_of_same_germ (hf x) (hkeep x hx)
+  · exact isMorseAt_of_regular hg hx
+
+private theorem Degree.FlowCancellation.not_critical_of_directional_neg {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {g : M → ℝ} {x : M}
+    (hneg : mvfderiv 𝓘(ℝ, E) g x (V x) < 0) : x ∉ Smale.ManifoldMorse.criticalPoints E g := by
+  intro hx
+  change mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) g x = 0 at hx
+  unfold mvfderiv at hneg
+  rw [hx] at hneg
+  simp at hneg
+
+private theorem Degree.FlowCancellation.remove_morse_band_pair {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V) {c d : ℝ} (hcd : c < d)
+    (hc : ∀ x, f x = c → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hd : ∀ x, f x = d → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hcross : ∃ T : ℝ, 0 < T ∧ (∀ x, f x ≤ d → f (F T x) < c) ∧ ∀ x, c ≤ f x → d < f (F (-T) x))
+    {p q : M} (hpq : p ≠ q) (hp : p ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hq : q ∈ Smale.ManifoldMorse.criticalPoints E f) (hpc : f p ∈ Set.Icc c d)
+    (hqc : f q ∈ Set.Icc c d)
+    (hpair : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, f x ∈ Set.Icc c d → x = p ∨ x = q) :
+    ∃ g : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+        Smale.ManifoldMorse.IsMorse E g ∧
+          (Smale.ManifoldMorse.criticalPoints E g).ncard + 2 =
+              (Smale.ManifoldMorse.criticalPoints E f).ncard ∧
+            (∀ x,
+                x ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+                  x ∈ Smale.ManifoldMorse.criticalPoints E f ∧ x ≠ p ∧ x ≠ q) ∧
+              ∀ x, f x ∉ Set.Ioo c d → g =ᶠ[𝓝 x] f := by
+  obtain ⟨g, hg, hneg, hgerm⟩ := exists_global_band_lyapunov hf hV F hcurve hcd hc hd hcross
+  have hreg (x : M) (hx : f x ∈ Set.Icc c d) : x ∉ Smale.ManifoldMorse.criticalPoints E g :=
+    not_critical_of_directional_neg (hneg x hx)
+  have hnew (x : M) :
+    x ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+      x ∈ Smale.ManifoldMorse.criticalPoints E f ∧ x ≠ p ∧ x ≠ q := by
+    constructor
+    · intro hx
+      have hout : f x ∉ Set.Icc c d := fun h => hreg x h hx
+      have he := hgerm x (fun h => hout ⟨h.1.le, h.2.le⟩)
+      have hcrit : x ∈ Smale.ManifoldMorse.criticalPoints E f := by
+        change mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f x = 0
+        rw [← he.mfderiv_eq]
+        exact hx
+      exact ⟨hcrit, fun h => hout (h ▸ hpc), fun h => hout (h ▸ hqc)⟩
+    · rintro ⟨hx, hxp, hxq⟩
+      have hout : f x ∉ Set.Icc c d := fun h => (hpair x hx h).elim hxp hxq
+      change mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) g x = 0
+      rw [(hgerm x (fun h => hout ⟨h.1.le, h.2.le⟩)).mfderiv_eq]
+      exact hx
+  have hmg : Smale.ManifoldMorse.IsMorse E g := by
+    apply Degree.MorseCancellationPreservation.isMorse_of_critical_germs hm hg
+    intro x hx
+    apply hgerm x
+    intro h
+    exact hreg x ⟨h.1.le, h.2.le⟩ hx
+  have heq :
+    Smale.ManifoldMorse.criticalPoints E g = Smale.ManifoldMorse.criticalPoints E f \ { p, q } := by
+    ext x
+    simpa only [Set.mem_sdiff, Set.mem_insert_iff, Set.mem_singleton_iff, not_or] using hnew x
+  have hsub : { p, q } ⊆ Smale.ManifoldMorse.criticalPoints E f := by
+    intro x hx
+    rcases hx with rfl | hx
+    · exact hp
+    · exact Set.mem_singleton_iff.mp hx ▸ hq
+  refine ⟨g, hg, hmg, ?_, hnew, hgerm⟩
+  rw [heq, ← Set.ncard_pair hpq]
+  exact Set.ncard_sdiff_add_ncard_of_subset hsub (Smale.ManifoldMorse.finite_criticalPoints hf hm)
+
+private theorem
+    MorseCancel.cancel_unique_native_cubic_connection {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {m : ℕ} (σ : Fin m → ℝ)
+    (hσ : ∀ i, σ i ≠ 0) {a : ℝ} (ha : 0 < a)
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (haxis : Set.Icc (-a) a ×ˢ {(0 : Fin m → ℝ)} ⊆ Φ.source) {f : M → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hmodel : ∀ x ∈ Φ.target, V x = nativeCubicDescent σ Φ (-(a ^ 2)) x) (F : Flow ℝ M)
+    (hcurve : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0)
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f))
+    (hp : Φ (a, 0) ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hq : Φ (-a, 0) ∈ Smale.ManifoldMorse.criticalPoints E f) (hpq : f (Φ (a, 0)) < f (Φ (-a, 0)))
+    {c d : ℝ} (hc : c < f (Φ (a, 0))) (hd : f (Φ (-a, 0)) < d)
+    (hpair :
+      ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+        f x ∈ Set.Icc c d → x = Φ (a, 0) ∨ x = Φ (-a, 0))
+    (hunique :
+      ∀ x ∉ Smale.ManifoldMorse.criticalPoints E f,
+        Filter.Tendsto (fun t : ℝ => F t x) Filter.atBot (𝓝 (Φ (-a, 0))) →
+          Filter.Tendsto (fun t : ℝ => F t x) Filter.atTop (𝓝 (Φ (a, 0))) →
+            ∃ t : ℝ, F t (Φ (0, 0)) = x) :
+    ∃ g : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+        Smale.ManifoldMorse.IsMorse E g ∧
+          (Smale.ManifoldMorse.criticalPoints E g).ncard + 2 =
+              (Smale.ManifoldMorse.criticalPoints E f).ncard ∧
+            (∀ x,
+                x ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+                  x ∈ Smale.ManifoldMorse.criticalPoints E f ∧ x ≠ Φ (a, 0) ∧ x ≠ Φ (-a, 0)) ∧
+              ∀ x, f x ∉ Set.Ioo c d → g =ᶠ[𝓝 x] f := by
+  obtain ⟨K, V', -, hKsub, hV', -, hkeep, -, G, hGcurve, hcross, -⟩ :=
+    exists_cubic_connection_finite_passage σ hσ ha Φ haxis hf V hV hmodel F hcurve hzero hdesc
+      hinj hp hq hpq hc hd hpair hunique
+  have hcd : c < d := lt_trans hc (lt_trans hpq hd)
+  have hboundary (x : M) (hx : f x = c ∨ f x = d) : mvfderiv 𝓘(ℝ, E) f x (V' x) < 0 := by
+    have hxK : x ∉ K := by
+      intro hxK
+      have hh : f x ∈ Set.Ioo c d := (hKsub hxK).2
+      rcases hx with hx | hx <;> rw [hx] at hh
+      · exact (lt_irrefl c) hh.1
+      · exact (lt_irrefl d) hh.2
+    have hreg : x ∉ Smale.ManifoldMorse.criticalPoints E f := by
+      intro hcrit
+      have hxb : f x ∈ Set.Icc c d := by
+        rcases hx with hx | hx <;> rw [hx]
+        · exact ⟨le_rfl, hcd.le⟩
+        · exact ⟨hcd.le, le_rfl⟩
+      rcases hpair x hcrit hxb with he | he
+      · rw [he] at hx
+        rcases hx with hx | hx <;> linarith
+      · rw [he] at hx
+        rcases hx with hx | hx <;> linarith
+    rw [(hkeep x hxK).self_of_nhds]
+    exact hdesc x hreg
+  have hneq : Φ (a, (0 : Fin m → ℝ)) ≠ Φ (-a, 0) := by
+    intro h
+    exact hpq.ne (congrArg f h)
+  exact
+    Degree.FlowCancellation.remove_morse_band_pair hf hm hV' G hGcurve hcd
+      (fun x hx => hboundary x (Or.inl hx)) (fun x hx => hboundary x (Or.inr hx)) hcross hneq hp
+      hq ⟨hc.le, (hpq.trans hd).le⟩ ⟨(hc.trans hpq).le, hd.le⟩ hpair
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.cancel_unique_native_transverse_connection {Z E M : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {m : ℕ} (σ : Fin m → ℝ)
+    (hσ : ∀ i, σ i = -1 ∨ σ i = 1) {a : ℝ} (ha : 0 < a)
+    (Φq Φp : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (A : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, E) (Z × ℝ) M ∞) {U : Set Z}
+    (hAsource : A.source = U ×ˢ Set.univ) {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) {b s : ℝ} (hs : 0 < s)
+    (hheight : ∀ z ∈ A.source, z.2 ∈ Set.Ioo (0 : ℝ) 1 → f (A z) = b - s * z.2)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hqfield : ∀ y ∈ Φq.target, V y = nativeCubicDescent σ Φq (-(a ^ 2)) y)
+    (hpfield : ∀ y ∈ Φp.target, V y = nativeCubicDescent σ Φp (-(a ^ 2)) y)
+    (hAfield :
+      ∀ y ∈ A.target,
+        V y = Smale.FlowConstruction.partialChartField A.symm (fun _ : Z × ℝ => (0, 1)) y)
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0)
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f))
+    (Q P :
+      PartialDiffeomorph
+        𝓘(ℝ, Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ) 𝓘(ℝ, Z)
+        (Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ) Z ∞)
+    (H :
+      PartialDiffeomorph
+        𝓘(ℝ, Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ)
+        𝓘(ℝ, Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ)
+        (Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ)
+        (Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ) ∞)
+    (h0 : 0 ∈ H.source) (hH0 : H 0 = 0) (hQ0 : Q 0 = 0) (hP0 : P 0 = 0)
+    (hQsource : Q.source = H.source) (hPsource : P.source = H.target) (hQtarget : Q.target = U)
+    (hPtarget : P.target = U) (hdiagram : ∀ u ∈ H.source, P (H u) = Q u)
+    (htrans :
+      Smale.NativeTransversality.At 𝓘(ℝ, Smale.MorseHandle.NegativeSpace σ)
+        𝓘(ℝ, Smale.MorseHandle.PositiveSpace σ)
+        𝓘(ℝ, Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ)
+        (fun x => H (x, 0)) (fun y => (0, y)) 0 0)
+    (v₀ v₁ : (Smale.MorseHandle.NegativeSpace σ × Smale.MorseHandle.PositiveSpace σ) → ℝ)
+    (hv₀ : ContDiff ℝ ∞ v₀) (hv₁ : ContDiff ℝ ∞ v₁) (hv₀zero : v₀ 0 = 0) (hv₁zero : v₁ 0 = 0)
+    {Rq Rp Tq Tp : ℝ} (hRq : 0 < Rq) (hRp : 0 < Rp)
+    (hboxq : Metric.closedBall (-a, (0 : Fin m → ℝ)) Rq ⊆ Φq.source)
+    (hboxp : Metric.closedBall (a, (0 : Fin m → ℝ)) Rp ⊆ Φp.source)
+    (hsliceq :
+      ∀ u ∈ Q.source,
+        cubicFlowCylinder σ a ((Smale.MorseHandle.splitCoordinates σ).symm u, Tq) ∈
+          Metric.closedBall (-a, (0 : Fin m → ℝ)) Rq)
+    (hslicep :
+      ∀ u ∈ P.source,
+        cubicFlowCylinder σ a ((Smale.MorseHandle.splitCoordinates σ).symm u, Tp) ∈
+          Metric.closedBall (a, (0 : Fin m → ℝ)) Rp)
+    (hphaseq :
+      ∀ u ∈ Q.source,
+        Φq (cubicFlowCylinder σ a ((Smale.MorseHandle.splitCoordinates σ).symm u, Tq)) =
+          A (Q u, Tq + v₀ u))
+    (hphasep :
+      ∀ u ∈ P.source,
+        Φp (cubicFlowCylinder σ a ((Smale.MorseHandle.splitCoordinates σ).symm u, Tp)) =
+          A (P u, Tp + v₁ u))
+    (hqbasin :
+      ∀ z ∈ Φq.source,
+        Filter.Tendsto (fun t => F t (Φq z)) Filter.atBot (𝓝 (Φq (-a, 0))) ↔
+          ∀ i, σ i = 1 → z.2 i = 0)
+    (hpbasin :
+      ∀ z ∈ Φp.source,
+        Filter.Tendsto (fun t => F t (Φp z)) Filter.atTop (𝓝 (Φp (a, 0))) ↔
+          ∀ i, σ i = -1 → z.2 i = 0)
+    (hold :
+      ∀ x,
+        Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 (Φq (-a, 0))) →
+          Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 (Φp (a, 0))) → ∃ t, F t (A (0, 0)) = x)
+    (hp : Φp (a, 0) ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hq : Φq (-a, 0) ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hpq : f (Φp (a, 0)) < f (Φq (-a, 0))) {c d : ℝ} (hc : c < f (Φp (a, 0)))
+    (hd : f (Φq (-a, 0)) < d)
+    (hpair :
+      ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+        f x ∈ Set.Icc c d → x = Φp (a, 0) ∨ x = Φq (-a, 0)) :
+    ∃ g : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+        Smale.ManifoldMorse.IsMorse E g ∧
+          (Smale.ManifoldMorse.criticalPoints E g).ncard + 2 =
+              (Smale.ManifoldMorse.criticalPoints E f).ncard ∧
+            (∀ x,
+                x ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+                  x ∈ Smale.ManifoldMorse.criticalPoints E f ∧ x ≠ Φp (a, 0) ∧ x ≠ Φq (-a, 0)) ∧
+              ∀ x, f x ∉ Set.Ioo c d → g =ᶠ[𝓝 x] f := by
+  have hV1 := hV.of_le (show (1 : WithTop ℕ∞) ≤ (↑(⊤ : ℕ∞) : ℕ∞ω) by simp)
+  have hQU : Q.target ⊆ U := fun _ hz => hQtarget ▸ hz
+  have hPU : P.target ⊆ U := fun _ hz => hPtarget ▸ hz
+  have hflow (z : Z) (hz : z ∈ U) (t : ℝ) : A (z, t) = F t (A (z, 0)) := by
+    simpa only [zero_add] using
+      (Degree.FlowSuspension.native_vertical_cylinder_flow A hAsource hV1 hAfield F hF z hz 0
+          t).symm
+  have hleft :=
+    Degree.FlowSuspension.cylinder_outgoing_basin_labels F A Q (fun z hz => hflow z (hQU hz))
+      (fun u => Φq (cubicFlowCylinder σ a ((Smale.MorseHandle.splitCoordinates σ).symm u, Tq)))
+      (fun u => Tq + v₀ u) hphaseq
+      (fun u hu => outgoing_cubic_slice_basin σ hσ a Tq Φq F hqbasin u (hboxq (hsliceq u hu)))
+  have hright :=
+    Degree.FlowSuspension.cylinder_incoming_basin_labels F A P (fun z hz => hflow z (hPU hz))
+      (fun u => Φp (cubicFlowCylinder σ a ((Smale.MorseHandle.splitCoordinates σ).symm u, Tp)))
+      (fun u => Tp + v₁ u) hphasep
+      (fun u hu => incoming_cubic_slice_basin σ a Tp Φp F hpbasin u (hboxp (hslicep u hu)))
+  rw [hQtarget, hQsource] at hleft
+  rw [hPtarget, hPsource] at hright
+  have hheightAux : ∀ z ∈ A.source, z.2 ∈ Set.Ioo (0 : ℝ) 1 → f (A z) / s = b / s - z.2 := by
+    intro z hz ht
+    rw [hheight z hz ht]
+    field_simp
+  obtain
+    ⟨L₁, L₂, N, W, G, Ξ, _, hNsub, hW, hG, hzeroW, hdescW, hgerm, hΞsource, hΞtarget, hΞfield,
+      hΞaxis, hunique, hmatch⟩ :=
+    Degree.FlowSuspension.exists_unique_phase_corrected_cylinder A hAsource (hf.div_const s)
+      hheightAux V hV hAfield F hF Q P H h0 hH0 hQ0 hP0 (fun _ hz => hQsource ▸ hz)
+      (fun _ hz => hPsource ▸ hz) hQtarget hPtarget hdiagram htrans (fun z hz => hleft z hz 0)
+      (fun z hz => hright z hz 1) hold hv₀ hv₁ hv₀zero hv₁zero
+  have hdescWf (x : M) (hx : x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    mvfderiv 𝓘(ℝ, E) f x (W x) < 0 :=
+    (Degree.FlowTimeChange.descending_height_div_const_iff (hf.mdifferentiableAt (by simp)) hs
+          (W x)).mp
+      (hdescW x
+        ((Degree.FlowTimeChange.descending_height_div_const_iff (hf.mdifferentiableAt (by simp))
+              hs (V x)).mpr
+          (hdesc x hx)))
+  have hAregular (x : M) (hx : x ∈ A.target) : V x ≠ 0 := by
+    intro hz
+    rw [hAfield x hx] at hz
+    have hh := (partialChartField_zero_iff A (fun _ : Z × ℝ => (0, 1)) hx).mp hz
+    exact one_ne_zero (congrArg Prod.snd hh)
+  have hqN : Φq (-a, 0) ∉ N := fun hx => hAregular _ (hNsub hx) (hzero _ hq)
+  have hpN : Φp (a, 0) ∉ N := fun hx => hAregular _ (hNsub hx) (hzero _ hp)
+  have hQ0source : 0 ∈ Q.source := hQsource ▸ h0
+  have hP0source : 0 ∈ P.source := by
+    rw [hPsource, ← hH0]
+    exact H.map_source' h0
+  have hne : Φq (-a, 0) ≠ Φp (a, 0) := by
+    intro h
+    exact hpq.ne (congrArg f h.symm)
+  obtain ⟨Γ, hΓaxis, hΓfield, hΓq, hΓp, hΓcenter⟩ :=
+    exists_full_cubic_chart_from_corrected_cylinder σ hσ ha Φq Φp A hAsource hV1 hqfield hpfield
+      hAfield F hF L₁ L₂ Q P v₀ v₁ Q.open_source P.open_source hQ0source hP0source
+      (fun u hu => hQU (Q.map_source' hu)) (fun u hu => hPU (P.map_source' hu)) hRq hRp hboxq
+      hboxp hsliceq hslicep hphaseq hphasep Ξ Q.open_source hQ0source hΞsource hΞtarget
+      (hW.of_le (by simp)) hΞfield G hG (hgerm _ hqN) (hgerm _ hpN) hne
+      (hmatch.mono fun _ h => h.1) (hmatch.mono fun _ h => h.2)
+  have hΓ0 : Γ (0, 0) = A (0, 0) := hΓcenter.trans (hΞaxis 0)
+  have hσne : ∀ i, σ i ≠ 0 := by
+    intro i
+    rcases hσ i with hi | hi <;> rw [hi] <;> norm_num
+  have hcancel :=
+    cancel_unique_native_cubic_connection σ hσne ha Γ hΓaxis hf hm W hW hΓfield G hG
+      (fun x hx => (hzeroW x).mpr (hzero x hx)) hdescWf hinj (by rw [hΓp]; exact hp)
+      (by rw [hΓq]; exact hq) (by rw [hΓp, hΓq]; exact hpq) (by rw [hΓp]; exact hc)
+      (by rw [hΓq]; exact hd) (by simpa only [hΓp, hΓq] using hpair)
+      (by
+        intro x _ hbot htop
+        rw [hΓq] at hbot
+        rw [hΓp] at htop
+        rw [hΓ0]
+        exact hunique x hbot htop)
+  simpa only [hΓp, hΓq] using hcancel
+
+private theorem MorseCancel.cancel_native_endpoint_slice_data {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {m : ℕ} (σ : Fin m → ℝ)
+    (hσ : ∀ i, σ i = -1 ∨ σ i = 1) {a : ℝ} (ha : 0 < a)
+    (Φq Φp : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞)
+    (A : PartialDiffeomorph 𝓘(ℝ, (Fin m → ℝ) × ℝ) 𝓘(ℝ, E) ((Fin m → ℝ) × ℝ) M ∞) {Rq Rp Tq Tp : ℝ}
+    (D : NativeEndpointSliceData σ a Φq Φp A Rq Rp Tq Tp)
+    (htrans :
+      Smale.NativeTransversality.At 𝓘(ℝ, Smale.MorseHandle.NegativeSpace σ)
+        𝓘(ℝ, Smale.MorseHandle.PositiveSpace σ) 𝓘(ℝ, Fin m → ℝ) (fun x => D.Q (x, 0))
+        (fun y => D.P (0, y)) 0 0)
+    {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f)
+    {b s : ℝ} (hs : 0 < s)
+    (hheight : ∀ z ∈ A.source, z.2 ∈ Set.Ioo (0 : ℝ) 1 → f (A z) = b - s * z.2)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hqfield : ∀ y ∈ Φq.target, V y = nativeCubicDescent σ Φq (-(a ^ 2)) y)
+    (hpfield : ∀ y ∈ Φp.target, V y = nativeCubicDescent σ Φp (-(a ^ 2)) y)
+    (hAfield :
+      ∀ y ∈ A.target,
+        V y =
+          Smale.FlowConstruction.partialChartField A.symm (fun _ : (Fin m → ℝ) × ℝ => (0, 1)) y)
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0)
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f)) (hRq : 0 < Rq) (hRp : 0 < Rp)
+    (hboxq : Metric.closedBall (-a, (0 : Fin m → ℝ)) Rq ⊆ Φq.source)
+    (hboxp : Metric.closedBall (a, (0 : Fin m → ℝ)) Rp ⊆ Φp.source)
+    (hqbasin :
+      ∀ z ∈ Φq.source,
+        Filter.Tendsto (fun t => F t (Φq z)) Filter.atBot (𝓝 (Φq (-a, 0))) ↔
+          ∀ i, σ i = 1 → z.2 i = 0)
+    (hpbasin :
+      ∀ z ∈ Φp.source,
+        Filter.Tendsto (fun t => F t (Φp z)) Filter.atTop (𝓝 (Φp (a, 0))) ↔
+          ∀ i, σ i = -1 → z.2 i = 0)
+    (hold :
+      ∀ x,
+        Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 (Φq (-a, 0))) →
+          Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 (Φp (a, 0))) → ∃ t, F t (A (0, 0)) = x)
+    (hp : Φp (a, 0) ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hq : Φq (-a, 0) ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hpq : f (Φp (a, 0)) < f (Φq (-a, 0))) {c d : ℝ} (hc : c < f (Φp (a, 0)))
+    (hd : f (Φq (-a, 0)) < d)
+    (hpair :
+      ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+        f x ∈ Set.Icc c d → x = Φp (a, 0) ∨ x = Φq (-a, 0)) :
+    ∃ g : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+        Smale.ManifoldMorse.IsMorse E g ∧
+          (Smale.ManifoldMorse.criticalPoints E g).ncard + 2 =
+              (Smale.ManifoldMorse.criticalPoints E f).ncard ∧
+            (∀ x,
+                x ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+                  x ∈ Smale.ManifoldMorse.criticalPoints E f ∧ x ≠ Φp (a, 0) ∧ x ≠ Φq (-a, 0)) ∧
+              ∀ x, f x ∉ Set.Ioo c d → g =ᶠ[𝓝 x] f := by
+  have hrelative :=
+    Degree.TransverseGerms.relative_transverse_of_label_sheets D.Q D.P D.H D.zero_source D.H_zero
+      D.Q_zero D.P_zero (fun _ hz => D.Q_source ▸ hz) (fun _ hz => D.P_source ▸ hz) D.diagram
+      htrans
+  exact
+    cancel_unique_native_transverse_connection σ hσ ha Φq Φp A D.source hf hm hs hheight V hV
+      hqfield hpfield hAfield F hF hzero hdesc hinj D.Q D.P D.H D.zero_source D.H_zero D.Q_zero
+      D.P_zero D.Q_source D.P_source D.Q_target D.P_target D.diagram hrelative D.phaseQ D.phaseP
+      D.smooth_phaseQ D.smooth_phaseP D.zero_phaseQ D.zero_phaseP hRq hRp hboxq hboxp D.sliceQ
+      D.sliceP D.formulaQ D.formulaP hqbasin hpbasin hold hp hq hpq hc hd hpair
+
+private structure MorseCancel.NativeConnectionCancellationData {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] (f : M → ℝ)
+    (p q : M) (m : ℕ) where
+  σ : Fin m → ℝ
+  signs : ∀ i, σ i = -1 ∨ σ i = 1
+  field : (y : M) → TangentSpace 𝓘(ℝ, E) y
+  smooth_field :
+    ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun y => (⟨y, field y⟩ : TangentBundle 𝓘(ℝ, E) M))
+  flow : Flow ℝ M
+  integral : ∀ y, IsMIntegralCurve (fun t => flow t y) field
+  zero : ∀ y ∈ Smale.ManifoldMorse.criticalPoints E f, field y = 0
+  descent : ∀ y, y ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f y (field y) < 0
+  Φq : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞
+  Φp : PartialDiffeomorph 𝓘(ℝ, Model m) 𝓘(ℝ, E) (Model m) M ∞
+  endpointQ : Φq (-(1 / 2 : ℝ), 0) = q
+  endpointP : Φp (1 / 2, 0) = p
+  fieldQ : ∀ y ∈ Φq.target, field y = nativeCubicDescent σ Φq (-(1 / 2 : ℝ) ^ 2) y
+  fieldP : ∀ y ∈ Φp.target, field y = nativeCubicDescent σ Φp (-(1 / 2 : ℝ) ^ 2) y
+  A : PartialDiffeomorph 𝓘(ℝ, (Fin m → ℝ) × ℝ) 𝓘(ℝ, E) ((Fin m → ℝ) × ℝ) M ∞
+  vertical :
+    ∀ y ∈ A.target,
+      field y =
+        Smale.FlowConstruction.partialChartField A.symm (fun _ : (Fin m → ℝ) × ℝ => (0, 1)) y
+  speed : ℝ
+  positive_speed : 0 < speed
+  height : ℝ
+  height_formula : ∀ z ∈ A.source, z.2 ∈ Set.Ioo (0 : ℝ) 1 → f (A z) = height - speed * z.2
+  Rq : ℝ
+  Rp : ℝ
+  Tq : ℝ
+  Tp : ℝ
+  positive_Rq : 0 < Rq
+  positive_Rp : 0 < Rp
+  boxQ : Metric.closedBall (-(1 / 2 : ℝ), (0 : Fin m → ℝ)) Rq ⊆ Φq.source
+  boxP : Metric.closedBall (1 / 2, (0 : Fin m → ℝ)) Rp ⊆ Φp.source
+  basinQ :
+    ∀ z ∈ Φq.source,
+      Filter.Tendsto (fun t => flow t (Φq z)) Filter.atBot (𝓝 q) ↔ ∀ i, σ i = 1 → z.2 i = 0
+  basinP :
+    ∀ z ∈ Φp.source,
+      Filter.Tendsto (fun t => flow t (Φp z)) Filter.atTop (𝓝 p) ↔ ∀ i, σ i = -1 → z.2 i = 0
+  unique :
+    ∀ y,
+      Filter.Tendsto (fun t => flow t y) Filter.atBot (𝓝 q) →
+        Filter.Tendsto (fun t => flow t y) Filter.atTop (𝓝 p) → ∃ t, flow t (A (0, 0)) = y
+  slices : NativeEndpointSliceData σ (1 / 2) Φq Φp A Rq Rp Tq Tp
+
+private def
+    MorseCancel.NativeConnectionCancellationData.Transverse {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {m : ℕ}
+    {f : M → ℝ} {p q : M} (D : MorseCancel.NativeConnectionCancellationData (E := E) f p q m) :
+    Prop :=
+  Smale.NativeTransversality.At 𝓘(ℝ, Smale.MorseHandle.NegativeSpace D.σ)
+    𝓘(ℝ, Smale.MorseHandle.PositiveSpace D.σ) 𝓘(ℝ, Fin m → ℝ) (fun x => D.slices.Q (x, 0))
+    (fun y => D.slices.P (0, y)) 0 0
+
+private theorem
+    MorseCancel.NativeConnectionCancellationData.cancel {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {m : ℕ} {f : M → ℝ} {p q : M}
+    (D : MorseCancel.NativeConnectionCancellationData (E := E) f p q m) (htrans : D.Transverse)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f))
+    (hp : p ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hq : q ∈ Smale.ManifoldMorse.criticalPoints E f) (hpq : f p < f q) {c d : ℝ} (hc : c < f p)
+    (hd : f q < d)
+    (hpair : ∀ y ∈ Smale.ManifoldMorse.criticalPoints E f, f y ∈ Set.Icc c d → y = p ∨ y = q) :
+    ∃ g : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+        Smale.ManifoldMorse.IsMorse E g ∧
+          (Smale.ManifoldMorse.criticalPoints E g).ncard + 2 =
+              (Smale.ManifoldMorse.criticalPoints E f).ncard ∧
+            (∀ y,
+                y ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+                  y ∈ Smale.ManifoldMorse.criticalPoints E f ∧ y ≠ p ∧ y ≠ q) ∧
+              ∀ y, f y ∉ Set.Ioo c d → g =ᶠ[𝓝 y] f := by
+  have hh :=
+    MorseCancel.cancel_native_endpoint_slice_data D.σ D.signs (by norm_num) D.Φq D.Φp D.A D.slices
+      htrans hf hm D.positive_speed D.height_formula D.field D.smooth_field D.fieldQ D.fieldP
+      D.vertical D.flow D.integral D.zero D.descent hinj D.positive_Rq D.positive_Rp D.boxQ D.boxP
+      (by simpa only [D.endpointQ] using D.basinQ) (by simpa only [D.endpointP] using D.basinP)
+      (by simpa only [D.endpointQ, D.endpointP] using D.unique) (by rw [D.endpointP]; exact hp)
+      (by rw [D.endpointQ]; exact hq) (by rw [D.endpointP, D.endpointQ]; exact hpq)
+      (by rw [D.endpointP]; exact hc) (by rw [D.endpointQ]; exact hd)
+      (by simpa only [D.endpointP, D.endpointQ] using hpair)
+  simpa only [D.endpointP, D.endpointQ] using hh
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_native_connection_cancellation_data {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {m : ℕ} {f : M → ℝ}
+    {p q x : M} (cp : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (cq : Smale.ManifoldMorse.SignedMorseChart (E := E) f q) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = m + 1)
+    (hindex :
+      Fintype.card { i // cq.weights i = -1 } = Fintype.card { i // cp.weights i = -1 } + 1)
+    (V : (y : M) → TangentSpace 𝓘(ℝ, E) y)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun y => (⟨y, V y⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hzero : ∀ y ∈ Smale.ManifoldMorse.criticalPoints E f, V y = 0)
+    (hdesc : ∀ y, y ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f y (V y) < 0)
+    (F : Flow ℝ M) (hF : ∀ y, IsMIntegralCurve (fun t => F t y) V)
+    (hpc : p ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hqc : q ∈ Smale.ManifoldMorse.criticalPoints E f) (hpq : f p < f q) {c d : ℝ} (hc : c < f p)
+    (hd : f q < d)
+    (hpair : ∀ y ∈ Smale.ManifoldMorse.criticalPoints E f, f y ∈ Set.Icc c d → y = p ∨ y = q)
+    (hp : Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p))
+    (hq : Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 q))
+    (hunique :
+      ∀ y,
+        Filter.Tendsto (fun t => F t y) Filter.atBot (𝓝 q) →
+          Filter.Tendsto (fun t => F t y) Filter.atTop (𝓝 p) → ∃ t, F t x = y)
+    (heqp : ∀ᶠ y in 𝓝 p, V y = cp.descentField y) (heqq : ∀ᶠ y in 𝓝 q, V y = cq.descentField y) :
+    ∃ D : NativeConnectionCancellationData (E := E) f p q m,
+      (∀ y ∈ Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ z in 𝓝 y, D.field z = V z) ∧
+        (∀ y,
+            Set.range (fun t => D.flow t y) = Set.range (fun t => F t y) ∧
+              (∀ z,
+                  Filter.Tendsto (fun t => D.flow t y) Filter.atTop (𝓝 z) ↔
+                    Filter.Tendsto (fun t => F t y) Filter.atTop (𝓝 z)) ∧
+                ∀ z,
+                  Filter.Tendsto (fun t => D.flow t y) Filter.atBot (𝓝 z) ↔
+                    Filter.Tendsto (fun t => F t y) Filter.atBot (𝓝 z)) ∧
+          ∃ t, F t x = D.A 0 := by
+  obtain
+    ⟨x₀, r, b, W, G, U, A, hxp, hxq, hr, hW, hG, hzeros, hneg, hgerms, hmono, hp₀, hq₀, hunique₀,
+      _, h0U, hAsource, hAaxis, hheight, hAfield, hgeometry, hreference⟩ :=
+    Degree.FlowTimeChange.exists_normalized_connection_cylinder hf hdim V hV hzero hdesc F hF hpq
+      hc hd hpair hp hq hunique
+  have hgp : ∀ᶠ y in 𝓝 p, W y = cp.descentField y := by
+    filter_upwards [hgerms p hpc, heqp] with y h₁ h₂
+    exact h₁.trans h₂
+  have hgq : ∀ᶠ y in 𝓝 q, W y = cq.descentField y := by
+    filter_upwards [hgerms q hqc, heqq] with y h₁ h₂
+    exact h₁.trans h₂
+  obtain
+    ⟨σ, Ψq, Ψp, B, Rq, Rp, Tq, Tp, hσ, hRq, hRp, hqval, hpval, hqbox, hpbox, hqfield, hpfield,
+      hqbasin, hpbasin, hBsub, _, hBmap, hBfield, ⟨D⟩⟩ :=
+    exists_actual_connection_slice_data cp cq hf.continuous hdim hindex hW G hG hmono hxp hxq hp₀
+      hq₀ hgp hgq A hAsource h0U hAfield hAaxis
+  have hB0 : B (0, 0) = x₀ := by rw [hBmap, hAaxis, G.map_zero_apply]
+  refine
+    ⟨{  σ := σ
+        signs := hσ
+        field := W
+        smooth_field := hW
+        flow := G
+        integral := hG
+        zero := hzeros
+        descent := hneg
+        Φq := Ψq
+        Φp := Ψp
+        endpointQ := hqval
+        endpointP := hpval
+        fieldQ := hqfield
+        fieldP := hpfield
+        A := B
+        vertical := hBfield
+        speed := r
+        positive_speed := hr
+        height := b
+        height_formula := ?_
+        Rq := Rq
+        Rp := Rp
+        Tq := Tq
+        Tp := Tp
+        positive_Rq := hRq
+        positive_Rp := hRp
+        boxQ := hqbox
+        boxP := hpbox
+        basinQ := hqbasin
+        basinP := hpbasin
+        unique := ?_
+        slices := D }, hgerms, hgeometry, ?_⟩
+  · intro z hz ht
+    rw [hBmap]
+    exact hheight z (hBsub hz) ⟨ht.1.le, ht.2.le⟩
+  · intro y hyq hyp
+    rw [hB0]
+    exact hunique₀ y hyq hyp
+  · change ∃ t, F t x = B (0, 0)
+    rw [hB0]
+    exact hreference
+
+private theorem Degree.TransverseGerms.derivative_first_of_time_independent_label {A Z : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    {F : ℝ × A → Z × ℝ} {f : A → Z} (hF : DifferentiableAt ℝ F 0) (hf : DifferentiableAt ℝ f 0)
+    (hlabel : (fun u : ℝ × A => (F u).1) =ᶠ[𝓝 0] (fun u : ℝ × A => f u.2)) :
+    ∀ u : ℝ × A, (fderiv ℝ F 0 u).1 = fderiv ℝ f 0 u.2 := by
+  have hsnd : HasFDerivAt (fun u : ℝ × A => u.2) (ContinuousLinearMap.snd ℝ ℝ A) 0 :=
+    (ContinuousLinearMap.snd ℝ ℝ A).hasFDerivAt
+  have hd :
+    HasFDerivAt (fun u : ℝ × A => f u.2) ((fderiv ℝ f 0).comp (ContinuousLinearMap.snd ℝ ℝ A))
+      0 :=
+    hf.hasFDerivAt.comp (f := fun u : ℝ × A => u.2) 0 hsnd
+  have heq : fderiv ℝ (fun u : ℝ × A => (F u).1) 0 = fderiv ℝ (fun u : ℝ × A => f u.2) 0 :=
+    hlabel.fderiv_eq
+  rw [hF.hasFDerivAt.fst.fderiv, hd.fderiv] at heq
+  intro u
+  exact congrArg (fun L : (ℝ × A) →L[ℝ] Z => L u) heq
+
+private theorem
+    Degree.TransverseGerms.transverse_labels_of_time_independent_flow_sheets {A B Z : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] {F : ℝ × A → Z × ℝ} {G : ℝ × B → Z × ℝ} {f : A → Z}
+    {g : B → Z} (hF : DifferentiableAt ℝ F 0) (hG : DifferentiableAt ℝ G 0)
+    (hf : DifferentiableAt ℝ f 0) (hg : DifferentiableAt ℝ g 0)
+    (hlabelF : (fun u : ℝ × A => (F u).1) =ᶠ[𝓝 0] (fun u : ℝ × A => f u.2))
+    (hlabelG : (fun u : ℝ × B => (G u).1) =ᶠ[𝓝 0] (fun u : ℝ × B => g u.2))
+    (htrans : Function.Surjective ((fderiv ℝ F 0).coprod (fderiv ℝ G 0))) :
+    Function.Surjective ((fderiv ℝ f 0).coprod (fderiv ℝ g 0)) := by
+  have hfirstF := derivative_first_of_time_independent_label hF hf hlabelF
+  have hfirstG := derivative_first_of_time_independent_label hG hg hlabelG
+  intro z
+  obtain ⟨⟨u, v⟩, huv⟩ := htrans (z, 0)
+  refine ⟨(u.2, v.2), ?_⟩
+  change fderiv ℝ f 0 u.2 + fderiv ℝ g 0 v.2 = z
+  rw [← hfirstF u, ← hfirstG v]
+  exact congrArg Prod.fst huv
+
+private theorem Degree.TransverseGerms.transverse_labels_of_native_flow_sheets {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M]
+    (C : PartialDiffeomorph 𝓘(ℝ, Z × ℝ) 𝓘(ℝ, E) (Z × ℝ) M ∞) (hC0 : (0 : Z × ℝ) ∈ C.source)
+    (F : ℝ × A → M) (G : ℝ × B → M) (hF : MDifferentiableAt 𝓘(ℝ, ℝ × A) 𝓘(ℝ, E) F 0)
+    (hG : MDifferentiableAt 𝓘(ℝ, ℝ × B) 𝓘(ℝ, E) G 0) (hF0 : F 0 = C 0) (hG0 : G 0 = C 0)
+    {f : A → Z} {g : B → Z} (hf : DifferentiableAt ℝ f 0) (hg : DifferentiableAt ℝ g 0)
+    (hlabelF : (fun u : ℝ × A => (C.symm (F u)).1) =ᶠ[𝓝 0] (fun u : ℝ × A => f u.2))
+    (hlabelG : (fun u : ℝ × B => (C.symm (G u)).1) =ᶠ[𝓝 0] (fun u : ℝ × B => g u.2))
+    (htrans : Smale.NativeTransversality.At 𝓘(ℝ, ℝ × A) 𝓘(ℝ, ℝ × B) 𝓘(ℝ, E) F G 0 0) :
+    Smale.NativeTransversality.At 𝓘(ℝ, A) 𝓘(ℝ, B) 𝓘(ℝ, Z) f g 0 0 := by
+  have hFt : F 0 ∈ C.target := hF0.symm ▸ C.map_source' hC0
+  have hGt : G 0 ∈ C.target := hG0.symm ▸ C.map_source' hC0
+  have hFb : MDifferentiableAt 𝓘(ℝ, ℝ × A) 𝓘(ℝ, Z × ℝ) (C.symm ∘ F) 0 :=
+    (C.symm.mdifferentiableAt (by simp) hFt).comp (f := F) 0 hF
+  have hGb : MDifferentiableAt 𝓘(ℝ, ℝ × B) 𝓘(ℝ, Z × ℝ) (C.symm ∘ G) 0 :=
+    (C.symm.mdifferentiableAt (by simp) hGt).comp (f := G) 0 hG
+  have hcross : G 0 = F 0 := hG0.trans hF0.symm
+  have ht :=
+    Smale.ChartMapPerturbation.transverse_in_chart C.symm hF hG hcross hFt (htrans hcross)
+  rw [mfderiv_eq_fderiv, mfderiv_eq_fderiv] at ht
+  have hl :=
+    transverse_labels_of_time_independent_flow_sheets hFb.differentiableAt hGb.differentiableAt hf
+      hg hlabelF hlabelG ht
+  intro _
+  rw [mfderiv_eq_fderiv, mfderiv_eq_fderiv]
+  exact hl
+
+private def MorseCancel.NativeConnectionCancellationData.outgoingSheet {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {m : ℕ} {f : M → ℝ} {p q : M}
+    (D : MorseCancel.NativeConnectionCancellationData (E := E) f p q m)
+    (w : ℝ × Smale.MorseHandle.NegativeSpace D.σ) : M :=
+  D.flow (w.1 - D.Tq)
+    (D.Φq
+      (MorseCancel.cubicFlowCylinder D.σ (1 / 2)
+        ((Smale.MorseHandle.splitCoordinates D.σ).symm (w.2, 0), D.Tq)))
+
+private def MorseCancel.NativeConnectionCancellationData.incomingSheet {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {m : ℕ} {f : M → ℝ} {p q : M}
+    (D : MorseCancel.NativeConnectionCancellationData (E := E) f p q m)
+    (w : ℝ × Smale.MorseHandle.PositiveSpace D.σ) : M :=
+  D.flow (w.1 - D.Tp)
+    (D.Φp
+      (MorseCancel.cubicFlowCylinder D.σ (1 / 2)
+        ((Smale.MorseHandle.splitCoordinates D.σ).symm (0, w.2), D.Tp)))
+
+private theorem MorseCancel.NativeConnectionCancellationData.outgoingSheet_properties {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {m : ℕ} {f : M → ℝ}
+    {p q : M} (D : MorseCancel.NativeConnectionCancellationData (E := E) f p q m) :
+    ContMDiffAt 𝓘(ℝ, ℝ × Smale.MorseHandle.NegativeSpace D.σ) 𝓘(ℝ, E) ∞ D.outgoingSheet 0 ∧
+      D.outgoingSheet 0 = D.A 0 ∧
+        (fun w : ℝ × Smale.MorseHandle.NegativeSpace D.σ =>
+            (D.A.symm (D.outgoingSheet w)).1) =ᶠ[𝓝 0]
+          (fun w : ℝ × Smale.MorseHandle.NegativeSpace D.σ => D.slices.Q (w.2, 0)) := by
+  have hflow :=
+    Degree.FlowSuspension.native_vertical_cylinder_flow D.A D.slices.source
+      (D.smooth_field.of_le (by simp)) D.vertical D.flow D.integral
+  have hQU : D.slices.Q.target ⊆ D.slices.labelDomain := fun _ hz => D.slices.Q_target ▸ hz
+  have hQ0 : 0 ∈ D.slices.Q.source := D.slices.Q_source ▸ D.slices.zero_source
+  have hh :=
+    Degree.FlowSuspension.phase_flow_subsheet_properties D.A D.slices.source D.flow hflow
+      D.slices.Q hQU hQ0 D.slices.Q_zero
+      (fun u =>
+        D.Φq
+          (MorseCancel.cubicFlowCylinder D.σ (1 / 2)
+            ((Smale.MorseHandle.splitCoordinates D.σ).symm u, D.Tq)))
+      D.slices.phaseQ D.Tq D.slices.smooth_phaseQ D.slices.zero_phaseQ D.slices.formulaQ
+      (ContinuousLinearMap.inl ℝ (Smale.MorseHandle.NegativeSpace D.σ)
+        (Smale.MorseHandle.PositiveSpace D.σ))
+  unfold outgoingSheet
+  simpa only [ContinuousLinearMap.inl_apply, Prod.fst_zero, Prod.snd_zero, zero_sub] using hh
+
+private theorem MorseCancel.NativeConnectionCancellationData.incomingSheet_properties {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {m : ℕ} {f : M → ℝ}
+    {p q : M} (D : MorseCancel.NativeConnectionCancellationData (E := E) f p q m) :
+    ContMDiffAt 𝓘(ℝ, ℝ × Smale.MorseHandle.PositiveSpace D.σ) 𝓘(ℝ, E) ∞ D.incomingSheet 0 ∧
+      D.incomingSheet 0 = D.A 0 ∧
+        (fun w : ℝ × Smale.MorseHandle.PositiveSpace D.σ =>
+            (D.A.symm (D.incomingSheet w)).1) =ᶠ[𝓝 0]
+          (fun w : ℝ × Smale.MorseHandle.PositiveSpace D.σ => D.slices.P (0, w.2)) := by
+  have hflow :=
+    Degree.FlowSuspension.native_vertical_cylinder_flow D.A D.slices.source
+      (D.smooth_field.of_le (by simp)) D.vertical D.flow D.integral
+  have hPU : D.slices.P.target ⊆ D.slices.labelDomain := fun _ hz => D.slices.P_target ▸ hz
+  have hP0 : 0 ∈ D.slices.P.source := by
+    rw [D.slices.P_source, ← D.slices.H_zero]
+    exact D.slices.H.map_source' D.slices.zero_source
+  have hh :=
+    Degree.FlowSuspension.phase_flow_subsheet_properties D.A D.slices.source D.flow hflow
+      D.slices.P hPU hP0 D.slices.P_zero
+      (fun u =>
+        D.Φp
+          (MorseCancel.cubicFlowCylinder D.σ (1 / 2)
+            ((Smale.MorseHandle.splitCoordinates D.σ).symm u, D.Tp)))
+      D.slices.phaseP D.Tp D.slices.smooth_phaseP D.slices.zero_phaseP D.slices.formulaP
+      (ContinuousLinearMap.inr ℝ (Smale.MorseHandle.NegativeSpace D.σ)
+        (Smale.MorseHandle.PositiveSpace D.σ))
+  unfold incomingSheet
+  simpa only [ContinuousLinearMap.inr_apply, Prod.fst_zero, Prod.snd_zero, zero_sub] using hh
+
+private theorem
+    MorseCancel.NativeConnectionCancellationData.transverse_of_native_sheets {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {m : ℕ} {f : M → ℝ}
+    {p q : M} (D : MorseCancel.NativeConnectionCancellationData (E := E) f p q m)
+    (htrans :
+      Smale.NativeTransversality.At 𝓘(ℝ, ℝ × Smale.MorseHandle.NegativeSpace D.σ)
+        𝓘(ℝ, ℝ × Smale.MorseHandle.PositiveSpace D.σ) 𝓘(ℝ, E) D.outgoingSheet D.incomingSheet 0
+        0) :
+    D.Transverse := by
+  obtain ⟨hout, hout0, houtlabel⟩ := D.outgoingSheet_properties
+  obtain ⟨hin, hin0, hinlabel⟩ := D.incomingSheet_properties
+  have hQ0 : 0 ∈ D.slices.Q.source := D.slices.Q_source ▸ D.slices.zero_source
+  have hP0 : 0 ∈ D.slices.P.source := by
+    rw [D.slices.P_source, ← D.slices.H_zero]
+    exact D.slices.H.map_source' D.slices.zero_source
+  have hQdiff :=
+    (D.slices.Q.contMDiffOn_toFun.contDiffOn.contDiffAt
+          (D.slices.Q.open_source.mem_nhds hQ0)).differentiableAt
+      (by simp)
+  have hPdiff :=
+    (D.slices.P.contMDiffOn_toFun.contDiffOn.contDiffAt
+          (D.slices.P.open_source.mem_nhds hP0)).differentiableAt
+      (by simp)
+  have hq :
+    DifferentiableAt ℝ (fun x : Smale.MorseHandle.NegativeSpace D.σ => D.slices.Q (x, 0)) 0 :=
+    hQdiff.comp (f := fun x : Smale.MorseHandle.NegativeSpace D.σ => (x, 0)) 0
+      (ContinuousLinearMap.inl ℝ (Smale.MorseHandle.NegativeSpace D.σ)
+          (Smale.MorseHandle.PositiveSpace D.σ)).differentiableAt
+  have hp :
+    DifferentiableAt ℝ (fun y : Smale.MorseHandle.PositiveSpace D.σ => D.slices.P (0, y)) 0 :=
+    hPdiff.comp (f := fun y : Smale.MorseHandle.PositiveSpace D.σ => (0, y)) 0
+      (ContinuousLinearMap.inr ℝ (Smale.MorseHandle.NegativeSpace D.σ)
+          (Smale.MorseHandle.PositiveSpace D.σ)).differentiableAt
+  have hA0 : (0 : (Fin m → ℝ) × ℝ) ∈ D.A.source := by
+    rw [D.slices.source]
+    exact ⟨D.slices.zero_domain, Set.mem_univ _⟩
+  exact
+    Degree.TransverseGerms.transverse_labels_of_native_flow_sheets D.A hA0 D.outgoingSheet
+      D.incomingSheet (hout.mdifferentiableAt (by simp)) (hin.mdifferentiableAt (by simp)) hout0
+      hin0 hq hp houtlabel hinlabel htrans
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.NativeConnectionCancellationData.outgoing_basin_chart {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {m : ℕ} {f : M → ℝ}
+    {p q : M} (D : MorseCancel.NativeConnectionCancellationData (E := E) f p q m) :
+    ∃ P :
+      PartialDiffeomorph
+        𝓘(ℝ, (Smale.MorseHandle.NegativeSpace D.σ × Smale.MorseHandle.PositiveSpace D.σ) × ℝ)
+        𝓘(ℝ, E) ((Smale.MorseHandle.NegativeSpace D.σ × Smale.MorseHandle.PositiveSpace D.σ) × ℝ)
+        M ∞,
+      (0 : (Smale.MorseHandle.NegativeSpace D.σ × Smale.MorseHandle.PositiveSpace D.σ) × ℝ) ∈
+          P.source ∧
+        P 0 = D.A 0 ∧
+          D.outgoingSheet =ᶠ[𝓝 0]
+              (fun w : ℝ × Smale.MorseHandle.NegativeSpace D.σ => P ((w.2, 0), w.1)) ∧
+            ∀ w ∈ P.source,
+              Filter.Tendsto (fun t => D.flow t (P w)) Filter.atBot (𝓝 q) ↔ w.1.2 = 0 := by
+  have hflow :=
+    Degree.FlowSuspension.native_vertical_cylinder_flow D.A D.slices.source
+      (D.smooth_field.of_le (by simp)) D.vertical D.flow D.integral
+  have hQU : D.slices.Q.target ⊆ D.slices.labelDomain := fun _ hz => D.slices.Q_target ▸ hz
+  have hQ0 : 0 ∈ D.slices.Q.source := D.slices.Q_source ▸ D.slices.zero_source
+  let S := fun u =>
+    D.Φq
+      (MorseCancel.cubicFlowCylinder D.σ (1 / 2)
+        ((Smale.MorseHandle.splitCoordinates D.σ).symm u, D.Tq))
+  have hbasin (u) (hu : u ∈ D.slices.Q.source) :
+    Filter.Tendsto (fun t => D.flow t (S u)) Filter.atBot (𝓝 q) ↔ u.2 = 0 :=
+    MorseCancel.outgoing_cubic_slice_basin D.σ D.signs (1 / 2) D.Tq D.Φq D.flow D.basinQ u
+      (D.boxQ (D.slices.sliceQ u hu))
+  obtain ⟨P, -, h0P, hP0, hformula, hplane⟩ :=
+    Degree.FlowSuspension.exists_phase_flow_basin_chart D.A D.slices.source D.flow hflow
+      D.slices.Q hQU hQ0 D.slices.Q_zero S D.slices.phaseQ D.Tq D.slices.smooth_phaseQ
+      D.slices.zero_phaseQ D.slices.formulaQ
+      (fun y => Filter.Tendsto (fun t => D.flow t y) Filter.atBot (𝓝 q))
+      (fun t y => MorseCancel.flow_time_atBot_limit_iff D.flow t y q) (fun u => u.2 = 0) hbasin
+  have heq :=
+    Degree.FlowSuspension.phase_flow_chart_subsheet_germ P D.slices.Q.open_source hQ0 D.flow S
+      D.Tq hformula
+      (ContinuousLinearMap.inl ℝ (Smale.MorseHandle.NegativeSpace D.σ)
+        (Smale.MorseHandle.PositiveSpace D.σ))
+  refine ⟨P, h0P, hP0, ?_, hplane⟩
+  unfold outgoingSheet
+  simpa only [ContinuousLinearMap.inl_apply] using heq
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.NativeConnectionCancellationData.incoming_basin_chart {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {m : ℕ} {f : M → ℝ}
+    {p q : M} (D : MorseCancel.NativeConnectionCancellationData (E := E) f p q m) :
+    ∃ P :
+      PartialDiffeomorph
+        𝓘(ℝ, (Smale.MorseHandle.NegativeSpace D.σ × Smale.MorseHandle.PositiveSpace D.σ) × ℝ)
+        𝓘(ℝ, E) ((Smale.MorseHandle.NegativeSpace D.σ × Smale.MorseHandle.PositiveSpace D.σ) × ℝ)
+        M ∞,
+      (0 : (Smale.MorseHandle.NegativeSpace D.σ × Smale.MorseHandle.PositiveSpace D.σ) × ℝ) ∈
+          P.source ∧
+        P 0 = D.A 0 ∧
+          D.incomingSheet =ᶠ[𝓝 0]
+              (fun w : ℝ × Smale.MorseHandle.PositiveSpace D.σ => P ((0, w.2), w.1)) ∧
+            ∀ w ∈ P.source,
+              Filter.Tendsto (fun t => D.flow t (P w)) Filter.atTop (𝓝 p) ↔ w.1.1 = 0 := by
+  have hflow :=
+    Degree.FlowSuspension.native_vertical_cylinder_flow D.A D.slices.source
+      (D.smooth_field.of_le (by simp)) D.vertical D.flow D.integral
+  have hPU : D.slices.P.target ⊆ D.slices.labelDomain := fun _ hz => D.slices.P_target ▸ hz
+  have hP0 : 0 ∈ D.slices.P.source := by
+    rw [D.slices.P_source, ← D.slices.H_zero]
+    exact D.slices.H.map_source' D.slices.zero_source
+  let S := fun u =>
+    D.Φp
+      (MorseCancel.cubicFlowCylinder D.σ (1 / 2)
+        ((Smale.MorseHandle.splitCoordinates D.σ).symm u, D.Tp))
+  have hbasin (u) (hu : u ∈ D.slices.P.source) :
+    Filter.Tendsto (fun t => D.flow t (S u)) Filter.atTop (𝓝 p) ↔ u.1 = 0 :=
+    MorseCancel.incoming_cubic_slice_basin D.σ (1 / 2) D.Tp D.Φp D.flow D.basinP u
+      (D.boxP (D.slices.sliceP u hu))
+  obtain ⟨P, -, h0P, hPzero, hformula, hplane⟩ :=
+    Degree.FlowSuspension.exists_phase_flow_basin_chart D.A D.slices.source D.flow hflow
+      D.slices.P hPU hP0 D.slices.P_zero S D.slices.phaseP D.Tp D.slices.smooth_phaseP
+      D.slices.zero_phaseP D.slices.formulaP
+      (fun y => Filter.Tendsto (fun t => D.flow t y) Filter.atTop (𝓝 p))
+      (fun t y => MorseCancel.flow_time_atTop_limit_iff D.flow t y p) (fun u => u.1 = 0) hbasin
+  have heq :=
+    Degree.FlowSuspension.phase_flow_chart_subsheet_germ P D.slices.P.open_source hP0 D.flow S
+      D.Tp hformula
+      (ContinuousLinearMap.inr ℝ (Smale.MorseHandle.NegativeSpace D.σ)
+        (Smale.MorseHandle.PositiveSpace D.σ))
+  refine ⟨P, h0P, hPzero, ?_, hplane⟩
+  unfold incomingSheet
+  simpa only [ContinuousLinearMap.inr_apply] using heq
+
+private theorem Degree.TransverseGerms.native_transversality_of_sheet_factorizations
+    {A B U V E HU HV HE X Y M : Type*} [NormedAddCommGroup A] [NormedSpace ℝ A]
+    [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup U] [NormedSpace ℝ U]
+    [NormedAddCommGroup V] [NormedSpace ℝ V] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace HU] [TopologicalSpace HV] [TopologicalSpace HE]
+    {I : ModelWithCorners ℝ U HU} {I' : ModelWithCorners ℝ V HV} {J : ModelWithCorners ℝ E HE}
+    [TopologicalSpace X] [ChartedSpace HU X] [TopologicalSpace Y] [ChartedSpace HV Y]
+    [TopologicalSpace M] [ChartedSpace HE M] {F : X → M} {G : Y → M} {f : A → M} {g : B → M}
+    {u : X → A} {v : Y → B} {x : X} {y : Y} (hf : MDifferentiableAt 𝓘(ℝ, A) J f 0)
+    (hg : MDifferentiableAt 𝓘(ℝ, B) J g 0) (hu : MDifferentiableAt I 𝓘(ℝ, A) u x)
+    (hv : MDifferentiableAt I' 𝓘(ℝ, B) v y) (hu0 : u x = 0) (hv0 : v y = 0)
+    (hF : F =ᶠ[𝓝 x] (f ∘ u)) (hG : G =ᶠ[𝓝 y] (g ∘ v)) (hcross : G y = F x)
+    (htrans : Smale.NativeTransversality.At I I' J F G x y) :
+    Smale.NativeTransversality.At 𝓘(ℝ, A) 𝓘(ℝ, B) J f g 0 0 := by
+  have hfx : MDifferentiableAt 𝓘(ℝ, A) J f (u x) := hu0 ▸ hf
+  have hgy : MDifferentiableAt 𝓘(ℝ, B) J g (v y) := hv0 ▸ hg
+  have hFd :
+    (mfderiv I J F x : U →L[ℝ] E) =
+      (mfderiv 𝓘(ℝ, A) J f 0 : A →L[ℝ] E).comp (mfderiv I 𝓘(ℝ, A) u x) := by
+    have heq : (mfderiv I J F x : U →L[ℝ] E) = mfderiv I J (f ∘ u) x := hF.mfderiv_eq
+    rw [heq, mfderiv_comp x hfx hu, hu0]
+  have hGd :
+    (mfderiv I' J G y : V →L[ℝ] E) =
+      (mfderiv 𝓘(ℝ, B) J g 0 : B →L[ℝ] E).comp (mfderiv I' 𝓘(ℝ, B) v y) := by
+    have heq : (mfderiv I' J G y : V →L[ℝ] E) = mfderiv I' J (g ∘ v) y := hG.mfderiv_eq
+    rw [heq, mfderiv_comp y hgy hv, hv0]
+  intro _ z
+  obtain ⟨⟨a, b⟩, hab⟩ := htrans hcross z
+  refine ⟨(mfderiv I 𝓘(ℝ, A) u x a, mfderiv I' 𝓘(ℝ, B) v y b), ?_⟩
+  rw [hFd, hGd] at hab
+  exact hab
+
+private theorem Degree.TransverseGerms.exists_native_plane_factorization {A Z U E HU HE X M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup U] [NormedSpace ℝ U] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace HU] [TopologicalSpace HE] {I : ModelWithCorners ℝ U HU}
+    {J : ModelWithCorners ℝ E HE} [TopologicalSpace X] [ChartedSpace HU X] [TopologicalSpace M]
+    [ChartedSpace HE M] (P : PartialDiffeomorph 𝓘(ℝ, Z) J Z M ∞) (hP0 : (0 : Z) ∈ P.source)
+    (L : A →L[ℝ] Z) (R : Z →L[ℝ] A) (hRL : ∀ a, R (L a) = a) {F : X → M} {x : X}
+    (hF : MDifferentiableAt I J F x) (hx : F x = P 0)
+    (hplane : ∀ᶠ y in 𝓝 x, ∃ a, P.symm (F y) = L a) :
+    ∃ u : X → A, MDifferentiableAt I 𝓘(ℝ, A) u x ∧ u x = 0 ∧ F =ᶠ[𝓝 x] (fun y => P (L (u y))) := by
+  let u : X → A := fun y => R (P.symm (F y))
+  have hxt : F x ∈ P.target := hx.symm ▸ P.map_source' hP0
+  have hi := (P.symm.mdifferentiableAt (by simp) hxt).comp x hF
+  have hu : MDifferentiableAt I 𝓘(ℝ, A) u x := R.differentiableAt.mdifferentiableAt.comp x hi
+  have hu0 : u x = 0 := by
+    change R (P.symm (F x)) = 0
+    have hi0 : P.symm (P 0) = 0 := P.left_inv' hP0
+    rw [hx, hi0, map_zero]
+  refine ⟨u, hu, hu0, ?_⟩
+  filter_upwards [hF.continuousAt (P.open_target.mem_nhds hxt), hplane] with y hy hplaneY
+  obtain ⟨a, ha⟩ := hplaneY
+  change F y = P (L (R (P.symm (F y))))
+  rw [ha, hRL]
+  exact (P.right_inv' hy).symm.trans (congrArg P ha)
+
+private theorem
+    Degree.TransverseGerms.exists_native_plane_sheet_factorization {A Z U E HU HE X M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup U] [NormedSpace ℝ U] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace HU] [TopologicalSpace HE] {I : ModelWithCorners ℝ U HU}
+    {J : ModelWithCorners ℝ E HE} [TopologicalSpace X] [ChartedSpace HU X] [TopologicalSpace M]
+    [ChartedSpace HE M] (P : PartialDiffeomorph 𝓘(ℝ, Z) J Z M ∞) (hP0 : (0 : Z) ∈ P.source)
+    (L : A →L[ℝ] Z) (R : Z →L[ℝ] A) (hRL : ∀ a, R (L a) = a) {F : X → M} {x : X}
+    (hF : MDifferentiableAt I J F x) (hx : F x = P 0)
+    (hplane : ∀ᶠ y in 𝓝 x, ∃ a, P.symm (F y) = L a) {f : A → M}
+    (hmodel : f =ᶠ[𝓝 0] (fun a => P (L a))) :
+    ∃ u : X → A, MDifferentiableAt I 𝓘(ℝ, A) u x ∧ u x = 0 ∧ F =ᶠ[𝓝 x] (f ∘ u) := by
+  obtain ⟨u, hu, hu0, hfactor⟩ := exists_native_plane_factorization P hP0 L R hRL hF hx hplane
+  have hut : Filter.Tendsto u (𝓝 x) (𝓝 (0 : A)) := hu0 ▸ hu.continuousAt
+  have hcomp := hmodel.comp_tendsto hut
+  exact ⟨u, hu, hu0, hfactor.trans hcomp.symm⟩
+
+private theorem
+    Degree.TransverseGerms.exists_native_basin_sheet_factorization {A Z U E HU HE X M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup U] [NormedSpace ℝ U] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace HU] [TopologicalSpace HE] {I : ModelWithCorners ℝ U HU}
+    {J : ModelWithCorners ℝ E HE} [TopologicalSpace X] [ChartedSpace HU X] [TopologicalSpace M]
+    [ChartedSpace HE M] (P : PartialDiffeomorph 𝓘(ℝ, Z) J Z M ∞) (hP0 : (0 : Z) ∈ P.source)
+    (L : A →L[ℝ] Z) (R : Z →L[ℝ] A) (hRL : ∀ a, R (L a) = a) {F : X → M} {x : X}
+    (hF : MDifferentiableAt I J F x) (hx : F x = P 0) (Basin : M → Prop)
+    (hbasin : ∀ z ∈ P.source, Basin (P z) → ∃ a, z = L a) (hFbasin : ∀ᶠ y in 𝓝 x, Basin (F y))
+    {f : A → M} (hmodel : f =ᶠ[𝓝 0] (fun a => P (L a))) :
+    ∃ u : X → A, MDifferentiableAt I 𝓘(ℝ, A) u x ∧ u x = 0 ∧ F =ᶠ[𝓝 x] (f ∘ u) := by
+  have hxt : F x ∈ P.target := hx.symm ▸ P.map_source' hP0
+  have hplane : ∀ᶠ y in 𝓝 x, ∃ a, P.symm (F y) = L a := by
+    filter_upwards [hF.continuousAt (P.open_target.mem_nhds hxt), hFbasin] with y hy hby
+    have hb : Basin (P (P.symm (F y))) := (P.right_inv' hy).symm ▸ hby
+    exact hbasin (P.symm (F y)) (P.map_target' hy) hb
+  exact exists_native_plane_sheet_factorization P hP0 L R hRL hF hx hplane hmodel
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.NativeConnectionCancellationData.outgoing_basin_factorization {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {m : ℕ} {f : M → ℝ}
+    {p q : M} {U H X : Type*} [NormedAddCommGroup U] [NormedSpace ℝ U] [TopologicalSpace H]
+    {I : ModelWithCorners ℝ U H} [TopologicalSpace X] [ChartedSpace H X]
+    (D : MorseCancel.NativeConnectionCancellationData (E := E) f p q m) {F : X → M} {x : X}
+    (hF : MDifferentiableAt I 𝓘(ℝ, E) F x) (hx : F x = D.A 0)
+    (hbasin : ∀ᶠ y in 𝓝 x, Filter.Tendsto (fun t => D.flow t (F y)) Filter.atBot (𝓝 q)) :
+    ∃ u : X → ℝ × Smale.MorseHandle.NegativeSpace D.σ,
+      MDifferentiableAt I 𝓘(ℝ, ℝ × Smale.MorseHandle.NegativeSpace D.σ) u x ∧
+        u x = 0 ∧ F =ᶠ[𝓝 x] (D.outgoingSheet ∘ u) := by
+  obtain ⟨P, hP0, hzero, hmodel, hplane⟩ := D.outgoing_basin_chart
+  let A := Smale.MorseHandle.NegativeSpace D.σ
+  let B := Smale.MorseHandle.PositiveSpace D.σ
+  let L : (ℝ × A) →L[ℝ] ((A × B) × ℝ) :=
+    ((ContinuousLinearMap.inl ℝ A B).comp (ContinuousLinearMap.snd ℝ ℝ A)).prod
+      (ContinuousLinearMap.fst ℝ ℝ A)
+  let R : ((A × B) × ℝ) →L[ℝ] (ℝ × A) :=
+    (ContinuousLinearMap.snd ℝ (A × B) ℝ).prod
+      ((ContinuousLinearMap.fst ℝ A B).comp (ContinuousLinearMap.fst ℝ (A × B) ℝ))
+  have hRL (a : ℝ × A) : R (L a) = a := rfl
+  have hp (w) (hw : w ∈ P.source)
+    (hb : Filter.Tendsto (fun t => D.flow t (P w)) Filter.atBot (𝓝 q)) : ∃ a, w = L a := by
+    have hz := (hplane w hw).mp hb
+    refine ⟨(w.2, w.1.1), ?_⟩
+    exact Prod.ext (Prod.ext rfl hz) rfl
+  exact
+    Degree.TransverseGerms.exists_native_basin_sheet_factorization P hP0 L R hRL hF
+      (hx.trans hzero.symm) (fun y => Filter.Tendsto (fun t => D.flow t y) Filter.atBot (𝓝 q)) hp
+      hbasin hmodel
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.NativeConnectionCancellationData.incoming_basin_factorization {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {m : ℕ} {f : M → ℝ}
+    {p q : M} {U H X : Type*} [NormedAddCommGroup U] [NormedSpace ℝ U] [TopologicalSpace H]
+    {I : ModelWithCorners ℝ U H} [TopologicalSpace X] [ChartedSpace H X]
+    (D : MorseCancel.NativeConnectionCancellationData (E := E) f p q m) {F : X → M} {x : X}
+    (hF : MDifferentiableAt I 𝓘(ℝ, E) F x) (hx : F x = D.A 0)
+    (hbasin : ∀ᶠ y in 𝓝 x, Filter.Tendsto (fun t => D.flow t (F y)) Filter.atTop (𝓝 p)) :
+    ∃ u : X → ℝ × Smale.MorseHandle.PositiveSpace D.σ,
+      MDifferentiableAt I 𝓘(ℝ, ℝ × Smale.MorseHandle.PositiveSpace D.σ) u x ∧
+        u x = 0 ∧ F =ᶠ[𝓝 x] (D.incomingSheet ∘ u) := by
+  obtain ⟨P, hP0, hzero, hmodel, hplane⟩ := D.incoming_basin_chart
+  let A := Smale.MorseHandle.NegativeSpace D.σ
+  let B := Smale.MorseHandle.PositiveSpace D.σ
+  let L : (ℝ × B) →L[ℝ] ((A × B) × ℝ) :=
+    ((ContinuousLinearMap.inr ℝ A B).comp (ContinuousLinearMap.snd ℝ ℝ B)).prod
+      (ContinuousLinearMap.fst ℝ ℝ B)
+  let R : ((A × B) × ℝ) →L[ℝ] (ℝ × B) :=
+    (ContinuousLinearMap.snd ℝ (A × B) ℝ).prod
+      ((ContinuousLinearMap.snd ℝ A B).comp (ContinuousLinearMap.fst ℝ (A × B) ℝ))
+  have hRL (a : ℝ × B) : R (L a) = a := rfl
+  have hp (w) (hw : w ∈ P.source)
+    (hb : Filter.Tendsto (fun t => D.flow t (P w)) Filter.atTop (𝓝 p)) : ∃ a, w = L a := by
+    have hz := (hplane w hw).mp hb
+    refine ⟨(w.2, w.1.2), ?_⟩
+    exact Prod.ext (Prod.ext hz rfl) rfl
+  exact
+    Degree.TransverseGerms.exists_native_basin_sheet_factorization P hP0 L R hRL hF
+      (hx.trans hzero.symm) (fun y => Filter.Tendsto (fun t => D.flow t y) Filter.atTop (𝓝 p)) hp
+      hbasin hmodel
+
+private theorem MorseCancel.NativeConnectionCancellationData.transverse_of_native_basin_sheets
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {m : ℕ} {f : M → ℝ} {p q : M} {U V H H' X Y : Type*} [NormedAddCommGroup U] [NormedSpace ℝ U]
+    [NormedAddCommGroup V] [NormedSpace ℝ V] [TopologicalSpace H] [TopologicalSpace H']
+    {I : ModelWithCorners ℝ U H} {I' : ModelWithCorners ℝ V H'} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y]
+    (D : MorseCancel.NativeConnectionCancellationData (E := E) f p q m) {F : X → M} {G : Y → M}
+    {x : X} {y : Y} (hF : MDifferentiableAt I 𝓘(ℝ, E) F x) (hG : MDifferentiableAt I' 𝓘(ℝ, E) G y)
+    (hx : F x = D.A 0) (hy : G y = D.A 0)
+    (hFbasin : ∀ᶠ z in 𝓝 x, Filter.Tendsto (fun t => D.flow t (F z)) Filter.atBot (𝓝 q))
+    (hGbasin : ∀ᶠ z in 𝓝 y, Filter.Tendsto (fun t => D.flow t (G z)) Filter.atTop (𝓝 p))
+    (htrans : Smale.NativeTransversality.At I I' 𝓘(ℝ, E) F G x y) : D.Transverse := by
+  obtain ⟨u, hu, hu0, hFu⟩ := D.outgoing_basin_factorization hF hx hFbasin
+  obtain ⟨v, hv, hv0, hGv⟩ := D.incoming_basin_factorization hG hy hGbasin
+  apply D.transverse_of_native_sheets
+  exact
+    Degree.TransverseGerms.native_transversality_of_sheet_factorizations
+      (D.outgoingSheet_properties.1.mdifferentiableAt (by simp))
+      (D.incomingSheet_properties.1.mdifferentiableAt (by simp)) hu hv hu0 hv0 hFu hGv
+      (hy.trans hx.symm) htrans
+
+private theorem MorseCancel.NativeConnectionCancellationData.cancel_of_transverse_basin_sheets
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    {m : ℕ} {f : M → ℝ} {p q : M} {U V H H' X Y : Type*} [NormedAddCommGroup U] [NormedSpace ℝ U]
+    [NormedAddCommGroup V] [NormedSpace ℝ V] [TopologicalSpace H] [TopologicalSpace H']
+    {I : ModelWithCorners ℝ U H} {I' : ModelWithCorners ℝ V H'} [TopologicalSpace X]
+    [ChartedSpace H X] [TopologicalSpace Y] [ChartedSpace H' Y]
+    (D : MorseCancel.NativeConnectionCancellationData (E := E) f p q m) {F : X → M} {G : Y → M}
+    {x : X} {y : Y} (hF : MDifferentiableAt I 𝓘(ℝ, E) F x) (hG : MDifferentiableAt I' 𝓘(ℝ, E) G y)
+    (hx : F x = D.A 0) (hy : G y = D.A 0)
+    (hFbasin : ∀ᶠ z in 𝓝 x, Filter.Tendsto (fun t => D.flow t (F z)) Filter.atBot (𝓝 q))
+    (hGbasin : ∀ᶠ z in 𝓝 y, Filter.Tendsto (fun t => D.flow t (G z)) Filter.atTop (𝓝 p))
+    (htrans : Smale.NativeTransversality.At I I' 𝓘(ℝ, E) F G x y)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f))
+    (hp : p ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hq : q ∈ Smale.ManifoldMorse.criticalPoints E f) (hpq : f p < f q) {c d : ℝ} (hc : c < f p)
+    (hd : f q < d)
+    (hpair : ∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, f z ∈ Set.Icc c d → z = p ∨ z = q) :
+    ∃ g : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+        Smale.ManifoldMorse.IsMorse E g ∧
+          (Smale.ManifoldMorse.criticalPoints E g).ncard + 2 =
+              (Smale.ManifoldMorse.criticalPoints E f).ncard ∧
+            (∀ z,
+                z ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+                  z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ z ≠ p ∧ z ≠ q) ∧
+              ∀ z, f z ∉ Set.Ioo c d → g =ᶠ[𝓝 z] f :=
+  D.cancel (D.transverse_of_native_basin_sheets hF hG hx hy hFbasin hGbasin htrans) hf hm hinj hp
+    hq hpq hc hd hpair
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.cancel_unique_connection_of_transverse_basin_sheets {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {m : ℕ}
+    {A B HA HB X Y : Type*} [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [TopologicalSpace HA] [TopologicalSpace HB] {I : ModelWithCorners ℝ A HA}
+    {I' : ModelWithCorners ℝ B HB} [TopologicalSpace X] [ChartedSpace HA X] [TopologicalSpace Y]
+    [ChartedSpace HB Y] {f : M → ℝ} {p q z : M}
+    (cp : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (cq : Smale.ManifoldMorse.SignedMorseChart (E := E) f q) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (hdim : Module.finrank ℝ E = m + 1)
+    (hindex :
+      Fintype.card { i // cq.weights i = -1 } = Fintype.card { i // cp.weights i = -1 } + 1)
+    (V : (x : M) → TangentSpace 𝓘(ℝ, E) x)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0)
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f))
+    (hpc : p ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hqc : q ∈ Smale.ManifoldMorse.criticalPoints E f) (hpq : f p < f q) {c d : ℝ} (hc : c < f p)
+    (hd : f q < d)
+    (hpair : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, f x ∈ Set.Icc c d → x = p ∨ x = q)
+    (hp : Filter.Tendsto (fun t => F t z) Filter.atTop (𝓝 p))
+    (hq : Filter.Tendsto (fun t => F t z) Filter.atBot (𝓝 q))
+    (hunique :
+      ∀ x,
+        Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 q) →
+          Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p) → ∃ t, F t z = x)
+    (heqp : ∀ᶠ x in 𝓝 p, V x = cp.descentField x) (heqq : ∀ᶠ x in 𝓝 q, V x = cq.descentField x)
+    {S : X → M} {T : Y → M} {x : X} {y : Y} (hS : MDifferentiableAt I 𝓘(ℝ, E) S x)
+    (hT : MDifferentiableAt I' 𝓘(ℝ, E) T y) (hS0 : S x = z) (hT0 : T y = z)
+    (hSbasin : ∀ᶠ u in 𝓝 x, Filter.Tendsto (fun t => F t (S u)) Filter.atBot (𝓝 q))
+    (hTbasin : ∀ᶠ u in 𝓝 y, Filter.Tendsto (fun t => F t (T u)) Filter.atTop (𝓝 p))
+    (htrans : Smale.NativeTransversality.At I I' 𝓘(ℝ, E) S T x y) :
+    ∃ g : M → ℝ,
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+        Smale.ManifoldMorse.IsMorse E g ∧
+          (Smale.ManifoldMorse.criticalPoints E g).ncard + 2 =
+              (Smale.ManifoldMorse.criticalPoints E f).ncard ∧
+            (∀ x,
+                x ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+                  x ∈ Smale.ManifoldMorse.criticalPoints E f ∧ x ≠ p ∧ x ≠ q) ∧
+              ∀ x, f x ∉ Set.Ioo c d → g =ᶠ[𝓝 x] f := by
+  obtain ⟨D, -, hgeometry, t₀, ht₀⟩ :=
+    exists_native_connection_cancellation_data cp cq hf hdim hindex V hV hzero hdesc F hF hpc hqc
+      hpq hc hd hpair hp hq hunique heqp heqq
+  let τ := Degree.SmoothODE.nativeFlowTimeDiffeomorph_of_field hV F hF t₀
+  have hτ (u : M) : τ u = F t₀ u := rfl
+  have hS' : MDifferentiableAt I 𝓘(ℝ, E) (τ ∘ S) x :=
+    (τ.contMDiff.mdifferentiableAt (by simp)).comp x hS
+  have hT' : MDifferentiableAt I' 𝓘(ℝ, E) (τ ∘ T) y :=
+    (τ.contMDiff.mdifferentiableAt (by simp)).comp y hT
+  have hS0' : (τ ∘ S) x = D.A 0 := by rw [Function.comp_apply, hτ, hS0, ht₀]
+  have hT0' : (τ ∘ T) y = D.A 0 := by rw [Function.comp_apply, hτ, hT0, ht₀]
+  have hSb : ∀ᶠ u in 𝓝 x, Filter.Tendsto (fun t => D.flow t ((τ ∘ S) u)) Filter.atBot (𝓝 q) := by
+    filter_upwards [hSbasin] with u hu
+    apply ((hgeometry ((τ ∘ S) u)).2.2 q).mpr
+    exact (flow_time_atBot_limit_iff F t₀ (S u) q).mpr hu
+  have hTb : ∀ᶠ u in 𝓝 y, Filter.Tendsto (fun t => D.flow t ((τ ∘ T) u)) Filter.atTop (𝓝 p) := by
+    filter_upwards [hTbasin] with u hu
+    apply ((hgeometry ((τ ∘ T) u)).2.1 p).mpr
+    exact (flow_time_atTop_limit_iff F t₀ (T u) p).mpr hu
+  have ht : Smale.NativeTransversality.At I I' 𝓘(ℝ, E) (τ ∘ S) (τ ∘ T) x y :=
+    (Degree.TransverseGerms.native_transversality_partial_diffeomorph_iff τ.toPartialDiffeomorph
+          hS hT (hT0.trans hS0.symm) (Set.mem_univ _)).mp
+      htrans
+  exact
+    D.cancel_of_transverse_basin_sheets hS' hT' hS0' hT0' hSb hTb ht hf hm hinj hpc hqc hpq hc hd
+      hpair
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.cancel_of_transverse_level_isotopy {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {m : ℕ} {A B HA HB X Y : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [TopologicalSpace HA] [TopologicalSpace HB] {I : ModelWithCorners ℝ A HA}
+    {I' : ModelWithCorners ℝ B HB} [TopologicalSpace X] [ChartedSpace HA X] [TopologicalSpace Y]
+    [ChartedSpace HB Y] {f : M → ℝ} {p q : M}
+    (cp : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (cq : Smale.ManifoldMorse.SignedMorseChart (E := E) f q) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (hdim : Module.finrank ℝ E = m + 1)
+    (hindex :
+      Fintype.card { i // cq.weights i = -1 } = Fintype.card { i // cp.weights i = -1 } + 1)
+    (V : (z : M) → TangentSpace 𝓘(ℝ, E) z)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun z => (⟨z, V z⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hzero : ∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, V z = 0)
+    (hdesc : ∀ z, z ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f z (V z) < 0)
+    (F : Flow ℝ M) (hF : ∀ z, IsMIntegralCurve (fun t => F t z) V)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f))
+    (hpc : p ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hqc : q ∈ Smale.ManifoldMorse.criticalPoints E f) {l u a b c : ℝ} (hl : l < f p)
+    (hu : f q < u)
+    (hpair : ∀ z ∈ Smale.ManifoldMorse.criticalPoints E f, f z ∈ Set.Icc l u → z = p ∨ z = q)
+    (ha : a < c) (hb : c < b) (hpc' : f p < c) (hqc' : c < f q)
+    (hband : ∀ z, f z ∈ Set.Icc a b → z ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hreg : ∀ z, f z = c → z ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (heqp : ∀ᶠ z in 𝓝 p, V z = cp.descentField z) (heqq : ∀ᶠ z in 𝓝 q, V z = cq.descentField z) :
+    letI := Smale.RegularLevel.chartedSpace hf hreg
+    ∀ D :
+      Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+        { z : M // f z = c } { z : M // f z = c } ∞,
+      Smale.SupportedDiffeomorph.IsotopicToIdentity D →
+        {z : { w : M // f w = c } |
+                Filter.Tendsto (fun t => F t z) Filter.atBot (𝓝 q) ∧
+                  Filter.Tendsto (fun t => F t (D z)) Filter.atTop (𝓝 p)}.ncard =
+            1 →
+          ∀ (α : X → { z : M // f z = c }) (β : Y → { z : M // f z = c }) (x : X) (y : Y),
+            MDifferentiableAt I 𝓘(ℝ, Smale.RegularLevel.Model E) α x →
+              MDifferentiableAt I' 𝓘(ℝ, Smale.RegularLevel.Model E) β y →
+                β y = α x →
+                  Smale.NativeTransversality.At I I' 𝓘(ℝ, Smale.RegularLevel.Model E) α β x y →
+                    (∀ᶠ z in 𝓝 x, Filter.Tendsto (fun t => F t (α z)) Filter.atBot (𝓝 q)) →
+                      (∀ᶠ z in 𝓝 y, Filter.Tendsto (fun t => F t (D (β z))) Filter.atTop (𝓝 p)) →
+                        ∃ g : M → ℝ,
+                          ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ g ∧
+                            Smale.ManifoldMorse.IsMorse E g ∧
+                              (Smale.ManifoldMorse.criticalPoints E g).ncard + 2 =
+                                  (Smale.ManifoldMorse.criticalPoints E f).ncard ∧
+                                (∀ z,
+                                    z ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+                                      z ∈ Smale.ManifoldMorse.criticalPoints E f ∧
+                                        z ≠ p ∧ z ≠ q) ∧
+                                  ∀ z, f z ∉ Set.Ioo l u → g =ᶠ[𝓝 z] f := by
+  let _ := Smale.RegularLevel.chartedSpace hf hreg
+  let _ := Smale.RegularLevel.isManifold hf hreg
+  intro D hD hcount α β x y hα hβ hcross htrans hαbasin hβbasin
+  obtain
+    ⟨r, C, W, V', H, G, -, -, -, -, -, -, hgeometry, hV', hG, hzeros, hneg, hgerms, -, hend, -,
+      hleft, hright⟩ :=
+    Degree.FlowSuspension.exists_native_regular_level_isotopy_realization hf hV hdesc F hF ha hb
+      hband hreg (α x) D hD
+  obtain ⟨hback, hforward⟩ :=
+    Degree.FlowSuspension.whole_level_basins_of_holonomy F H G Subtype.val D
+      (fun z => (hgeometry z).2.1) (fun z => (hgeometry z).2.2) hend hleft hright
+  have hαb : ∀ᶠ z in 𝓝 x, Filter.Tendsto (fun t => G t (α z)) Filter.atBot (𝓝 q) := by
+    filter_upwards [hαbasin] with z hz
+    exact (hback (α z) q).mpr hz
+  have hβb : ∀ᶠ z in 𝓝 y, Filter.Tendsto (fun t => G t (β z)) Filter.atTop (𝓝 p) := by
+    filter_upwards [hβbasin] with z hz
+    exact (hforward (β z) p).mpr hz
+  obtain ⟨z₀, hz₀⟩ := Set.ncard_eq_one.mp hcount
+  have hαq : Filter.Tendsto (fun t => F t (α x)) Filter.atBot (𝓝 q) := hαbasin.self_of_nhds
+  have hαp : Filter.Tendsto (fun t => F t (D (α x))) Filter.atTop (𝓝 p) := by
+    rw [← hcross]
+    exact hβbasin.self_of_nhds
+  have hαeq : α x = z₀ := by
+    have hh :
+      α x ∈
+        {z : { w : M // f w = c } |
+          Filter.Tendsto (fun t => F t z) Filter.atBot (𝓝 q) ∧
+            Filter.Tendsto (fun t => F t (D z)) Filter.atTop (𝓝 p)} :=
+      ⟨hαq, hαp⟩
+    rw [hz₀] at hh
+    exact Set.mem_singleton_iff.mp hh
+  have huniq (z : { w : M // f w = c }) (hzq : Filter.Tendsto (fun t => F t z) Filter.atBot (𝓝 q))
+    (hzp : Filter.Tendsto (fun t => F t (D z)) Filter.atTop (𝓝 p)) : z = α x := by
+    have hh :
+      z ∈
+        {z : { w : M // f w = c } |
+          Filter.Tendsto (fun t => F t z) Filter.atBot (𝓝 q) ∧
+            Filter.Tendsto (fun t => F t (D z)) Filter.atTop (𝓝 p)} :=
+      ⟨hzq, hzp⟩
+    rw [hz₀] at hh
+    exact (Set.mem_singleton_iff.mp hh).trans hαeq.symm
+  obtain ⟨hqG, hpG, huniqueG⟩ :=
+    Degree.FlowSuspension.unique_connection_of_level_basin_intersection F G hf.continuous hqc'
+      hpc' D (fun z => hback z q) (fun z => hforward z p) (α x) hαq hαp huniq
+  obtain ⟨hS, hT, hS0, hT0, hSb, hTb, ht⟩ :=
+    Degree.FlowSuspension.native_transverse_basin_tubes_of_level_maps hf hreg hV' G hG
+      (fun z hz => hneg z (hreg z hz)) α β x y hα hβ hcross htrans hαb hβb
+  have hgermp : ∀ᶠ z in 𝓝 p, V' z = cp.descentField z := by
+    filter_upwards [hgerms p hpc, heqp] with z hz hz'
+    exact hz.trans hz'
+  have hgermq : ∀ᶠ z in 𝓝 q, V' z = cq.descentField z := by
+    filter_upwards [hgerms q hqc, heqq] with z hz hz'
+    exact hz.trans hz'
+  exact
+    cancel_unique_connection_of_transverse_basin_sheets cp cq hf hm hdim hindex V' hV'
+      (fun z hz => (hzeros z).mpr (hzero z hz)) hneg G hG hinj hpc hqc (hpc'.trans hqc') hl hu
+      hpair hpG hqG huniqueG hgermp hgermq hS hT hS0 hT0 hSb hTb ht
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.surjective_beltNormal_derivative {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (v : Smale.PuncturedHandle.UnitSphere d.chart.PositiveCoordinates) :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    Function.Surjective
+      (mfderiv 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, d.chart.NegativeCoordinates) d.beltNormal
+        (d.surgery.beltSphere v)) := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  let w : d.chart.PositiveCoordinates := d.radius • (v : d.chart.PositiveCoordinates)
+  let γ : d.chart.NegativeCoordinates → M := fun u => d.chart.splitChart.symm (u, w)
+  let n : M → d.chart.NegativeCoordinates := fun x => (d.chart.splitChart x).1
+  have hmodel : (0, w) ∈ d.chart.splitChart.target := d.belt_model_mem_target v
+  have hγ : ContMDiffAt 𝓘(ℝ, d.chart.NegativeCoordinates) 𝓘(ℝ, E) ∞ γ 0 :=
+    (d.chart.splitChart.contMDiffOn_invFun.contMDiffAt
+          (d.chart.splitChart.open_target.mem_nhds hmodel)).comp
+      0 (contDiffAt_id.prodMk contDiffAt_const).contMDiffAt
+  have hpoint : γ 0 = (d.surgery.beltSphere v : M) := by rw [d.belt_eq, d.chart.beltCoreMap_coe]
+  have hn :
+    ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, d.chart.NegativeCoordinates) ∞ n (d.surgery.beltSphere v : M) :=
+    contDiff_fst.contMDiff.contMDiffAt.comp _
+      (d.chart.splitChart.contMDiffOn_toFun.contMDiffAt
+        (d.chart.splitChart.open_source.mem_nhds (d.belt_mem_normalDomain v)))
+  have hnear : ∀ᶠ u : d.chart.NegativeCoordinates in 𝓝 0, (u, w) ∈ d.chart.splitChart.target :=
+    (continuous_id.prodMk continuous_const).continuousAt.preimage_mem_nhds
+      (d.chart.splitChart.open_target.mem_nhds hmodel)
+  have hheight :
+    f ∘ γ =ᶠ[𝓝 (0 : d.chart.NegativeCoordinates)] (fun u => f p - ‖u‖ ^ 2 + ‖w‖ ^ 2) := by
+    filter_upwards [hnear] with u hu
+    exact d.chart.splitChart_inverse_equation hu
+  have hheight₀ : mfderiv 𝓘(ℝ, d.chart.NegativeCoordinates) 𝓘(ℝ, ℝ) (f ∘ γ) 0 = 0 := by
+    rw [hheight.mfderiv_eq, mfderiv_eq_fderiv, fderiv_add_const, fderiv_const_sub,
+      fderiv_norm_sq_apply]
+    simp
+    rfl
+  have hnormal : n ∘ γ =ᶠ[𝓝 (0 : d.chart.NegativeCoordinates)] id := by
+    filter_upwards [hnear] with u hu
+    exact congrArg Prod.fst (d.chart.splitChart.right_inv' hu)
+  have hnormal₀ :
+    mfderiv 𝓘(ℝ, d.chart.NegativeCoordinates) 𝓘(ℝ, d.chart.NegativeCoordinates) (n ∘ γ) 0 =
+      ContinuousLinearMap.id ℝ d.chart.NegativeCoordinates := by
+    rw [hnormal.mfderiv_eq, mfderiv_id]
+    rfl
+  let R : d.chart.NegativeCoordinates →L[ℝ] E :=
+    mfderiv 𝓘(ℝ, d.chart.NegativeCoordinates) 𝓘(ℝ, E) γ 0
+  let L : E →L[ℝ] ℝ := mvfderiv 𝓘(ℝ, E) f (d.surgery.beltSphere v : M)
+  let B : E →L[ℝ] d.chart.NegativeCoordinates :=
+    mfderiv 𝓘(ℝ, E) 𝓘(ℝ, d.chart.NegativeCoordinates) n (d.surgery.beltSphere v : M)
+  have hLpoint : (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f (γ 0) : E →L[ℝ] ℝ) = L := by
+    rw [hpoint]
+    rfl
+  have hLR₀ : (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f (γ 0) : E →L[ℝ] ℝ).comp R = 0 :=
+    (mfderiv_comp 0 (hf.mdifferentiableAt (by simp)) (hγ.mdifferentiableAt (by simp))).symm.trans
+      hheight₀
+  have hLR : L.comp R = 0 := (congrArg (fun T : E →L[ℝ] ℝ => T.comp R) hLpoint).symm.trans hLR₀
+  have hnγ : MDifferentiableAt 𝓘(ℝ, E) 𝓘(ℝ, d.chart.NegativeCoordinates) n (γ 0) := by
+    rw [hpoint]
+    exact hn.mdifferentiableAt (by simp)
+  have hBpoint :
+    (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, d.chart.NegativeCoordinates) n (γ 0) :
+        E →L[ℝ] d.chart.NegativeCoordinates) =
+      B := by rw [hpoint]
+  have hBR₀ :
+    (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, d.chart.NegativeCoordinates) n (γ 0) :
+            E →L[ℝ] d.chart.NegativeCoordinates).comp
+        R =
+      ContinuousLinearMap.id ℝ d.chart.NegativeCoordinates :=
+    (mfderiv_comp 0 hnγ (hγ.mdifferentiableAt (by simp))).symm.trans hnormal₀
+  have hBR : B.comp R = ContinuousLinearMap.id ℝ d.chart.NegativeCoordinates :=
+    (congrArg (fun T : E →L[ℝ] d.chart.NegativeCoordinates => T.comp R) hBpoint).symm.trans hBR₀
+  exact
+    Smale.RegularLevel.surjective_normal_derivative_of_tangent_lift hf d.upper_regular
+      (d.surgery.beltSphere v) (hn.mdifferentiableAt (by simp)) R hLR hBR
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.range_belt_derivative_eq_normal_kernel {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (n : ℕ)
+    [Fact (Module.finrank ℝ d.chart.PositiveCoordinates = n + 1)]
+    (v : Smale.PuncturedHandle.UnitSphere d.chart.PositiveCoordinates) :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    (mfderiv (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) d.surgery.beltSphere v).range =
+      (mfderiv 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, d.chart.NegativeCoordinates) d.beltNormal
+          (d.surgery.beltSphere v)).ker := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  let A : EuclideanSpace ℝ (Fin n) →L[ℝ] Smale.RegularLevel.Model E :=
+    mfderiv (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) d.surgery.beltSphere v
+  let Q : Smale.RegularLevel.Model E →L[ℝ] d.chart.NegativeCoordinates :=
+    mfderiv 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, d.chart.NegativeCoordinates) d.beltNormal
+      (d.surgery.beltSphere v)
+  change A.range = Q.ker
+  have hQA : Q.comp A = 0 := d.beltNormal_derivative_comp_belt hf n v
+  have hsub : A.range ≤ Q.ker := by
+    rintro _ ⟨u, rfl⟩
+    change Q (A u) = 0
+    exact congrArg (fun T : EuclideanSpace ℝ (Fin n) →L[ℝ] d.chart.NegativeCoordinates => T u) hQA
+  have hAi : Function.Injective A := d.belt_derivative_injective hf n v
+  have hArank : Module.finrank ℝ A.range = n := by
+    rw [LinearMap.finrank_range_of_inj hAi]
+    exact finrank_euclideanSpace_fin
+  have hQ : Function.Surjective Q := d.surjective_beltNormal_derivative hf v
+  have hQrank : Module.finrank ℝ Q.range = Module.finrank ℝ d.chart.NegativeCoordinates := by
+    rw [LinearMap.range_eq_top.mpr hQ, finrank_top]
+  have hdimQ := Q.toLinearMap.finrank_range_add_finrank_ker
+  have hsplit := d.chart.finrank_negative_add_positive
+  have hpos : Module.finrank ℝ d.chart.PositiveCoordinates = n + 1 := Fact.out
+  have hmodel : Module.finrank ℝ (Smale.RegularLevel.Model E) = Module.finrank ℝ E - 1 :=
+    finrank_euclideanSpace_fin
+  apply Submodule.eq_of_le_of_finrank_eq hsub
+  rw [hArank]
+  omega
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.bijective_beltNormal_comp_of_transverse {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (n m : ℕ) [Fact (Module.finrank ℝ d.chart.PositiveCoordinates = n + 1)]
+    (hdim : Module.finrank ℝ d.chart.NegativeCoordinates = m)
+    (g : Smale.Hemisphere.Sphere m → d.UpperLevel) :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    ∀ (_hg : ContMDiff (𝓡 m) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g) (x : Smale.Hemisphere.Sphere m)
+      (v : Smale.PuncturedHandle.UnitSphere d.chart.PositiveCoordinates),
+      d.surgery.beltSphere v = g x →
+        Function.Surjective
+            ((mfderiv (𝓡 m) 𝓘(ℝ, Smale.RegularLevel.Model E) g x :
+                  EuclideanSpace ℝ (Fin m) →L[ℝ] Smale.RegularLevel.Model E).coprod
+              (mfderiv (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) d.surgery.beltSphere v :
+                EuclideanSpace ℝ (Fin n) →L[ℝ] Smale.RegularLevel.Model E)) →
+          Function.Bijective
+            (mfderiv (𝓡 m) 𝓘(ℝ, d.chart.NegativeCoordinates) (d.beltNormal ∘ g) x) := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  intro hg x v hxy ht
+  let Q : Smale.RegularLevel.Model E →L[ℝ] d.chart.NegativeCoordinates :=
+    mfderiv 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, d.chart.NegativeCoordinates) d.beltNormal
+      (d.surgery.beltSphere v)
+  let B : EuclideanSpace ℝ (Fin n) →L[ℝ] Smale.RegularLevel.Model E :=
+    mfderiv (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) d.surgery.beltSphere v
+  let A : EuclideanSpace ℝ (Fin m) →L[ℝ] Smale.RegularLevel.Model E :=
+    mfderiv (𝓡 m) 𝓘(ℝ, Smale.RegularLevel.Model E) g x
+  have hQ : Function.Surjective Q := d.surjective_beltNormal_derivative hf v
+  have hQB : Q.comp B = 0 := d.beltNormal_derivative_comp_belt hf n v
+  have hBA : Function.Surjective (B.coprod A) :=
+    Smale.TransverseCoordinates.surjective_coprod_swap A B ht
+  have hi : Function.Bijective (Q.comp A) :=
+    Smale.TransverseCoordinates.bijective_normal_comp Q B A hQ hBA hQB
+      (by simpa only [finrank_euclideanSpace_fin] using hdim.symm)
+  have hx : g x ∈ d.beltNormalDomain := hxy ▸ d.belt_mem_normalDomain v
+  have hnormal :=
+    (d.contMDiffOn_beltNormal hf).contMDiffAt (d.isOpen_beltNormalDomain.mem_nhds hx)
+  have heq : mfderiv (𝓡 m) 𝓘(ℝ, d.chart.NegativeCoordinates) (d.beltNormal ∘ g) x = Q.comp A := by
+    rw [mfderiv_comp x (hnormal.mdifferentiableAt (by simp)) (hg.mdifferentiableAt (by simp)), ←
+      hxy]
+    rfl
+  rw [heq]
+  exact hi
+
+private def Smale.TransverseCoordinates.sumMap {D Z A : Type*} [NormedAddCommGroup D]
+    [NormedAddCommGroup A] (f : D → A) (g : Z → A) (q : D × Z) : A :=
+  f q.1 + g q.2 - f 0
+
+private theorem Smale.TransverseCoordinates.sumMap_left {D Z A : Type*} [NormedAddCommGroup D]
+    [NormedAddCommGroup Z] [NormedAddCommGroup A] (f : D → A) (g : Z → A) (hzero : g 0 = f 0)
+    (x : D) : sumMap f g (x, 0) = f x := by simp [sumMap, hzero]
+
+private theorem Smale.TransverseCoordinates.sumMap_right {D Z A : Type*} [NormedAddCommGroup D]
+    [NormedAddCommGroup A] (f : D → A) (g : Z → A) (z : Z) : sumMap f g (0, z) = g z := by
+  simp [sumMap, add_sub_cancel_left]
+
+private theorem Smale.TransverseCoordinates.contDiffOn_sumMap {D Z A : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup A]
+    [NormedSpace ℝ A] {f : D → A} {g : Z → A} {U : Set D} {V : Set Z} (hf : ContDiffOn ℝ ∞ f U)
+    (hg : ContDiffOn ℝ ∞ g V) : ContDiffOn ℝ ∞ (sumMap f g) (U ×ˢ V) :=
+  ((hf.comp contDiff_fst.contDiffOn (fun _ hx => hx.1)).add
+        (hg.comp contDiff_snd.contDiffOn (fun _ hx => hx.2))).sub
+    contDiffOn_const
+
+private theorem
+    Smale.TransverseCoordinates.hasFDerivAt_sumMap_zero {D Z A : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup A]
+    [NormedSpace ℝ A] {f : D → A} {g : Z → A} (hf : DifferentiableAt ℝ f 0)
+    (hg : DifferentiableAt ℝ g 0) :
+    HasFDerivAt (sumMap f g) ((fderiv ℝ f 0).coprod (fderiv ℝ g 0)) (0, 0) := by
+  have hfst := (ContinuousLinearMap.fst ℝ D Z).hasFDerivAt (x := (0, 0))
+  have hsnd := (ContinuousLinearMap.snd ℝ D Z).hasFDerivAt (x := (0, 0))
+  have hd :=
+    ((hf.hasFDerivAt.comp (0, 0) hfst).add (hg.hasFDerivAt.comp (0, 0) hsnd)).sub
+      (hasFDerivAt_const (f 0) (0, 0))
+  apply hd.congr_fderiv
+  apply ContinuousLinearMap.ext
+  intro q
+  simp [ContinuousLinearMap.coprod_apply]
+
+private def Smale.NativeEuclideanEmbedding.SmoothRetraction.sheetCoordinates {E M D Z : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [NormedAddCommGroup D] {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction)
+    (f : D → M) (g : Z → M) : D × Z → M :=
+  r.toFun ∘ Smale.TransverseCoordinates.sumMap (e.toFun ∘ f) (e.toFun ∘ g)
+
+private def Smale.NativeEuclideanEmbedding.SmoothRetraction.sheetCoordinateDomain {E M D Z : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [NormedAddCommGroup D] {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction)
+    (f : D → M) (g : Z → M) (U : Set D) (V : Set Z) : Set (D × Z) :=
+  (U ×ˢ V) ∩ Smale.TransverseCoordinates.sumMap (e.toFun ∘ f) (e.toFun ∘ g) ⁻¹' r.domain
+
+private theorem
+    Smale.NativeEuclideanEmbedding.SmoothRetraction.sheetCoordinates_left {E M D Z : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [NormedAddCommGroup D] [NormedAddCommGroup Z] {e : Smale.NativeEuclideanEmbedding E M}
+    (r : e.SmoothRetraction) (f : D → M) (g : Z → M) (hzero : g 0 = f 0) (x : D) :
+    r.sheetCoordinates f g (x, 0) = f x := by
+  have hsum :=
+    Smale.TransverseCoordinates.sumMap_left (e.toFun ∘ f) (e.toFun ∘ g) (congrArg e.toFun hzero) x
+  change r.toFun (Smale.TransverseCoordinates.sumMap (e.toFun ∘ f) (e.toFun ∘ g) (x, 0)) = f x
+  rw [hsum]
+  exact r.retract (f x)
+
+private theorem
+    Smale.NativeEuclideanEmbedding.SmoothRetraction.sheetCoordinates_right {E M D Z : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [NormedAddCommGroup D] {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction)
+    (f : D → M) (g : Z → M) (z : Z) : r.sheetCoordinates f g (0, z) = g z := by
+  rw [sheetCoordinates, Function.comp_apply, Smale.TransverseCoordinates.sumMap_right]
+  exact r.retract (g z)
+
+private theorem Smale.NativeEuclideanEmbedding.SmoothRetraction.zero_mem_sheetCoordinateDomain
+    {E M D Z : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [NormedAddCommGroup D] [NormedAddCommGroup Z]
+    {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction) (f : D → M) (g : Z → M)
+    {U : Set D} {V : Set Z} (hU : (0 : D) ∈ U) (hV : (0 : Z) ∈ V) :
+    (0, 0) ∈ r.sheetCoordinateDomain f g U V := by
+  refine ⟨⟨hU, hV⟩, ?_⟩
+  change Smale.TransverseCoordinates.sumMap (e.toFun ∘ f) (e.toFun ∘ g) (0, 0) ∈ r.domain
+  rw [Smale.TransverseCoordinates.sumMap_right]
+  exact r.contains ⟨g 0, rfl⟩
+
+private theorem Smale.NativeEuclideanEmbedding.SmoothRetraction.isOpen_sheetCoordinateDomain
+    {E M D Z : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction)
+    {f : D → M} {g : Z → M} {U : Set D} {V : Set Z} (hU : IsOpen U) (hV : IsOpen V)
+    (hf : ContMDiffOn 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f U) (hg : ContMDiffOn 𝓘(ℝ, Z) 𝓘(ℝ, E) ∞ g V) :
+    IsOpen (r.sheetCoordinateDomain f g U V) :=
+  (Smale.TransverseCoordinates.contDiffOn_sumMap (e.smooth.comp_contMDiffOn hf).contDiffOn
+        (e.smooth.comp_contMDiffOn hg).contDiffOn).continuousOn.isOpen_inter_preimage
+    (hU.prod hV) r.open_domain
+
+private theorem Smale.NativeEuclideanEmbedding.SmoothRetraction.contMDiffOn_sheetCoordinates
+    {E M D Z : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction)
+    {f : D → M} {g : Z → M} {U : Set D} {V : Set Z} (hf : ContMDiffOn 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f U)
+    (hg : ContMDiffOn 𝓘(ℝ, Z) 𝓘(ℝ, E) ∞ g V) :
+    ContMDiffOn 𝓘(ℝ, D × Z) 𝓘(ℝ, E) ∞ (r.sheetCoordinates f g)
+      (r.sheetCoordinateDomain f g U V) :=
+  r.smooth.comp
+    ((Smale.TransverseCoordinates.contDiffOn_sumMap (e.smooth.comp_contMDiffOn hf).contDiffOn
+          (e.smooth.comp_contMDiffOn hg).contDiffOn).contMDiffOn.mono
+      Set.inter_subset_left)
+    (fun _ hx => hx.2)
+
+private theorem Smale.NativeEuclideanEmbedding.SmoothRetraction.mfderiv_sheetCoordinates_zero
+    {E M D Z : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] {e : Smale.NativeEuclideanEmbedding E M} (r : e.SmoothRetraction)
+    {f : D → M} {g : Z → M} (hzero : g 0 = f 0) (hf : ContMDiffAt 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f 0)
+    (hg : ContMDiffAt 𝓘(ℝ, Z) 𝓘(ℝ, E) ∞ g 0) :
+    mfderiv 𝓘(ℝ, D × Z) 𝓘(ℝ, E) (r.sheetCoordinates f g) (0, 0) =
+      (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f 0).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) g 0) := by
+  have heF := (e.smooth.contMDiffAt.comp 0 hf).contDiffAt
+  have heG := (e.smooth.contMDiffAt.comp 0 hg).contDiffAt
+  have hsum :=
+    Smale.TransverseCoordinates.hasFDerivAt_sumMap_zero (heF.differentiableAt (by simp))
+      (heG.differentiableAt (by simp))
+  have hbase :
+    Smale.TransverseCoordinates.sumMap (e.toFun ∘ f) (e.toFun ∘ g) (0, 0) = e.toFun (f 0) := by
+    rw [Smale.TransverseCoordinates.sumMap_right]
+    exact congrArg e.toFun hzero
+  have hr :
+    MDifferentiableAt (𝓡 e.ambientDimension) 𝓘(ℝ, E) r.toFun
+      (Smale.TransverseCoordinates.sumMap (e.toFun ∘ f) (e.toFun ∘ g) (0, 0)) := by
+    rw [hbase]
+    exact
+      (r.smooth.contMDiffAt (r.open_domain.mem_nhds (r.contains ⟨f 0, rfl⟩))).mdifferentiableAt
+        (by simp)
+  have hdf :
+    fderiv ℝ (e.toFun ∘ f) 0 =
+      (mfderiv 𝓘(ℝ, E) (𝓡 e.ambientDimension) e.toFun (f 0)).comp (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f 0) :=
+    by
+    rw [← mfderiv_eq_fderiv,
+      mfderiv_comp 0 (e.smooth.mdifferentiableAt (by simp)) (hf.mdifferentiableAt (by simp))]
+  have hdg :
+    fderiv ℝ (e.toFun ∘ g) 0 =
+      (mfderiv 𝓘(ℝ, E) (𝓡 e.ambientDimension) e.toFun (f 0)).comp (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) g 0) :=
+    by
+    rw [← mfderiv_eq_fderiv,
+      mfderiv_comp 0 (e.smooth.mdifferentiableAt (by simp)) (hg.mdifferentiableAt (by simp))]
+    rw [hzero]
+  rw [sheetCoordinates, mfderiv_comp (0, 0) hr hsum.differentiableAt.mdifferentiableAt,
+    mfderiv_eq_fderiv, hsum.fderiv, hbase, hdf, hdg]
+  apply ContinuousLinearMap.ext
+  intro q
+  have hleft :=
+    congrArg (fun L => L ((mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f 0) q.1)) (r.mfderiv_retract_comp (f 0))
+  have hright :=
+    congrArg (fun L => L ((mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) g 0) q.2)) (r.mfderiv_retract_comp (f 0))
+  let R : EuclideanSpace ℝ (Fin e.ambientDimension) →L[ℝ] E :=
+    mfderiv (𝓡 e.ambientDimension) 𝓘(ℝ, E) r.toFun (e.toFun (f 0))
+  let T : E →L[ℝ] EuclideanSpace ℝ (Fin e.ambientDimension) :=
+    mfderiv 𝓘(ℝ, E) (𝓡 e.ambientDimension) e.toFun (f 0)
+  let F : D →L[ℝ] E := mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f 0
+  let G : Z →L[ℝ] E := mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) g 0
+  change R (T (F q.1) + T (G q.2)) = F q.1 + G q.2
+  change R (T (F q.1)) = F q.1 at hleft
+  change R (T (G q.2)) = G q.2 at hright
+  rw [map_add, hleft, hright]
+
+private theorem Smale.TransverseCoordinates.isInvertible_coprod_of_surjective {D Z E : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ D] [FiniteDimensional ℝ Z]
+    [FiniteDimensional ℝ E] (F : D →L[ℝ] E) (G : Z →L[ℝ] E)
+    (hdim : Module.finrank ℝ D + Module.finrank ℝ Z = Module.finrank ℝ E)
+    (ht : Function.Surjective (F.coprod G)) : (F.coprod G).IsInvertible := by
+  have hd : Module.finrank ℝ (D × Z) = Module.finrank ℝ E := by
+    simpa only [Module.finrank_prod] using hdim
+  have hi : Function.Injective (F.coprod G) :=
+    (LinearMap.injective_iff_surjective_of_finrank_eq_finrank hd).mpr ht
+  let L := (LinearEquiv.ofBijective (F.coprod G).toLinearMap ⟨hi, ht⟩).toContinuousLinearEquiv
+  exact ⟨L, rfl⟩
+
+private theorem Smale.exists_simultaneous_sheetChart {E M D Z : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [NormedAddCommGroup D] [NormedSpace ℝ D]
+    [FiniteDimensional ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z]
+    {f : D → M} {g : Z → M} {U : Set D} {V : Set Z} (hU : IsOpen U) (hV : IsOpen V)
+    (h0U : (0 : D) ∈ U) (h0V : (0 : Z) ∈ V) (hf : ContMDiffOn 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f U)
+    (hg : ContMDiffOn 𝓘(ℝ, Z) 𝓘(ℝ, E) ∞ g V) (hzero : g 0 = f 0)
+    (hdim : Module.finrank ℝ D + Module.finrank ℝ Z = Module.finrank ℝ E)
+    (ht :
+      Function.Surjective ((mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f 0).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) g 0)))
+    {O : Set M} (hO : IsOpen O) (h0O : f 0 ∈ O) :
+    ∃ a : ℝ,
+      0 < a ∧
+        ∃ Φ : PartialDiffeomorph 𝓘(ℝ, D × Z) 𝓘(ℝ, E) (D × Z) M ∞,
+          Metric.closedBall (0 : D) a ×ˢ Metric.closedBall (0 : Z) a ⊆ Φ.source ∧
+            Φ.source ⊆ U ×ˢ V ∧
+              Φ.target ⊆ O ∧
+                (∀ x, (x, 0) ∈ Φ.source → Φ (x, 0) = f x) ∧
+                  (∀ z, (0, z) ∈ Φ.source → Φ (0, z) = g z) := by
+  let : Nonempty M := ⟨f 0⟩
+  obtain ⟨e⟩ := nonempty_nativeEuclideanEmbedding (E := E) (M := M)
+  obtain ⟨r⟩ := e.nonempty_smoothRetraction
+  let W₀ := r.sheetCoordinateDomain f g U V
+  have hW₀ : IsOpen W₀ := r.isOpen_sheetCoordinateDomain hU hV hf hg
+  have hs : ContMDiffOn 𝓘(ℝ, D × Z) 𝓘(ℝ, E) ∞ (r.sheetCoordinates f g) W₀ :=
+    r.contMDiffOn_sheetCoordinates hf hg
+  let W := W₀ ∩ r.sheetCoordinates f g ⁻¹' O
+  have hW : IsOpen W := hs.continuousOn.isOpen_inter_preimage hW₀ hO
+  have h0W : (0, 0) ∈ W := by
+    refine ⟨r.zero_mem_sheetCoordinateDomain f g h0U h0V, ?_⟩
+    change r.sheetCoordinates f g (0, 0) ∈ O
+    rw [r.sheetCoordinates_left f g hzero]
+    exact h0O
+  have hinv : (mfderiv 𝓘(ℝ, D × Z) 𝓘(ℝ, E) (r.sheetCoordinates f g) (0, 0)).IsInvertible := by
+    rw [r.mfderiv_sheetCoordinates_zero hzero (hf.contMDiffAt (hU.mem_nhds h0U))
+        (hg.contMDiffAt (hV.mem_nhds h0V))]
+    exact
+      TransverseCoordinates.isInvertible_coprod_of_surjective (D := D) (Z := Z) (E := E) _ _ hdim
+        ht
+  obtain ⟨Φ, h0Φ, hΦW, heq⟩ :=
+    exists_partialDiffeomorph_into_manifold hW h0W (hs.mono Set.inter_subset_left) hinv
+  obtain ⟨a, ha, hball⟩ := Metric.nhds_basis_closedBall.mem_iff.mp (Φ.open_source.mem_nhds h0Φ)
+  refine ⟨a, ha, Φ, ?_, ?_, ?_, ?_, ?_⟩
+  · rw [closedBall_prod_same]
+    exact hball
+  · intro q hq
+    exact (hΦW hq).1.1
+  · intro y hy
+    have hq := Φ.map_target' hy
+    have hmem := (hΦW hq).2
+    change r.sheetCoordinates f g (Φ.invFun y) ∈ O at hmem
+    rw [heq hq] at hmem
+    exact (Φ.right_inv' hy) ▸ hmem
+  · intro x hx
+    exact (heq hx).symm.trans (r.sheetCoordinates_left f g hzero x)
+  · intro z hz
+    exact (heq hz).symm.trans (r.sheetCoordinates_right f g z)
+
+private theorem Smale.exists_clean_simultaneous_sheetChart {E M D Z : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [NormedAddCommGroup D] [NormedSpace ℝ D]
+    [FiniteDimensional ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z]
+    {f : D → M} {g : Z → M} {U : Set D} {V : Set Z} (hU : IsOpen U) (hV : IsOpen V)
+    (h0U : (0 : D) ∈ U) (h0V : (0 : Z) ∈ V) (hf : ContMDiffOn 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ f U)
+    (hg : ContMDiffOn 𝓘(ℝ, Z) 𝓘(ℝ, E) ∞ g V) (hzero : g 0 = f 0)
+    (hembf : Topology.IsEmbedding (fun x : U => f x))
+    (hembg : Topology.IsEmbedding (fun z : V => g z))
+    (hdim : Module.finrank ℝ D + Module.finrank ℝ Z = Module.finrank ℝ E)
+    (ht :
+      Function.Surjective ((mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f 0).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) g 0)))
+    {O : Set M} (hO : IsOpen O) (h0O : f 0 ∈ O) :
+    ∃ b : ℝ,
+      0 < b ∧
+        ∃ Φ : PartialDiffeomorph 𝓘(ℝ, D × Z) 𝓘(ℝ, E) (D × Z) M ∞,
+          Metric.closedBall (0 : D) b ×ˢ Metric.closedBall (0 : Z) b ⊆ Φ.source ∧
+            Φ.source ⊆ U ×ˢ V ∧
+              Φ.target ⊆ O ∧
+                (∀ x, (x, 0) ∈ Φ.source → Φ (x, 0) = f x) ∧
+                  (∀ z, (0, z) ∈ Φ.source → Φ (0, z) = g z) ∧
+                    (∀ q ∈ Φ.source, (Φ q ∈ f '' U ↔ q.2 = 0) ∧ (Φ q ∈ g '' V ↔ q.1 = 0)) := by
+  obtain ⟨a, ha, Φ, hprod, hsource, htarget, hleft, hright⟩ :=
+    exists_simultaneous_sheetChart hU hV h0U h0V hf hg hzero hdim ht hO h0O
+  have hballU : IsOpen {x : U | (x : D) ∈ Metric.ball 0 a} :=
+    Metric.isOpen_ball.preimage continuous_subtype_val
+  have hballV : IsOpen {z : V | (z : Z) ∈ Metric.ball 0 a} :=
+    Metric.isOpen_ball.preimage continuous_subtype_val
+  obtain ⟨A, hA, hpreA⟩ := hembf.isInducing.isOpen_iff.mp hballU
+  obtain ⟨B, hB, hpreB⟩ := hembg.isInducing.isOpen_iff.mp hballV
+  have h0A : f 0 ∈ A := by
+    have hz : (⟨0, h0U⟩ : U) ∈ {x : U | (x : D) ∈ Metric.ball 0 a} := Metric.mem_ball_self ha
+    rw [← hpreA] at hz
+    exact hz
+  have h0B : g 0 ∈ B := by
+    have hz : (⟨0, h0V⟩ : V) ∈ {z : V | (z : Z) ∈ Metric.ball 0 a} := Metric.mem_ball_self ha
+    rw [← hpreB] at hz
+    exact hz
+  have hsmallF {x : D} (hx : x ∈ U) (hxA : f x ∈ A) : x ∈ Metric.closedBall 0 a := by
+    have hx' : (⟨x, hx⟩ : U) ∈ (fun x : U => f x) ⁻¹' A := hxA
+    rw [hpreA] at hx'
+    exact Metric.ball_subset_closedBall hx'
+  have hsmallG {z : Z} (hz : z ∈ V) (hzB : g z ∈ B) : z ∈ Metric.closedBall 0 a := by
+    have hz' : (⟨z, hz⟩ : V) ∈ (fun z : V => g z) ⁻¹' B := hzB
+    rw [hpreB] at hz'
+    exact Metric.ball_subset_closedBall hz'
+  let Ψ := PartialChart.restrictTarget Φ (hA.inter hB)
+  have h0Φ : (0, 0) ∈ Φ.source :=
+    hprod ⟨Metric.mem_closedBall_self ha.le, Metric.mem_closedBall_self ha.le⟩
+  have hcenter : Φ (0, 0) = f 0 := hleft 0 h0Φ
+  have h0Ψ : (0, 0) ∈ Ψ.source := by
+    refine ⟨h0Φ, ?_⟩
+    change Φ (0, 0) ∈ A ∩ B
+    rw [hcenter]
+    exact ⟨h0A, hzero ▸ h0B⟩
+  obtain ⟨b, hb, hball⟩ := Metric.nhds_basis_closedBall.mem_iff.mp (Ψ.open_source.mem_nhds h0Ψ)
+  refine
+    ⟨b, hb, Ψ, ?_, fun _ hq => hsource hq.1, fun _ hy => htarget hy.1, (fun x hx => hleft x hx.1),
+      (fun z hz => hright z hz.1), ?_⟩
+  · rw [closedBall_prod_same]
+    exact hball
+  · rintro ⟨x, z⟩ hq
+    have hAq : Φ (x, z) ∈ A := hq.2.1
+    have hBq : Φ (x, z) ∈ B := hq.2.2
+    constructor
+    · constructor
+      · rintro ⟨u, hu, heq⟩
+        have huA : f u ∈ A := heq ▸ hAq
+        have haxis : (u, 0) ∈ Φ.source := hprod ⟨hsmallF hu huA, Metric.mem_closedBall_self ha.le⟩
+        have hpair : (x, z) = (u, 0) :=
+          Φ.toPartialEquiv.injOn hq.1 haxis (heq.symm.trans (hleft u haxis).symm)
+        exact congrArg Prod.snd hpair
+      · intro hz
+        change z = 0 at hz
+        subst z
+        exact ⟨x, (hsource hq.1).1, (hleft x hq.1).symm⟩
+    · constructor
+      · rintro ⟨v, hv, heq⟩
+        have hvB : g v ∈ B := heq ▸ hBq
+        have haxis : (0, v) ∈ Φ.source := hprod ⟨Metric.mem_closedBall_self ha.le, hsmallG hv hvB⟩
+        have hpair : (x, z) = (0, v) :=
+          Φ.toPartialEquiv.injOn hq.1 haxis (heq.symm.trans (hright v haxis).symm)
+        exact congrArg Prod.fst hpair
+      · intro hx
+        change x = 0 at hx
+        subst x
+        exact ⟨z, (hsource hq.1).2, (hright z hq.1).symm⟩
+
+private theorem Smale.exists_clean_crossingChart_of_parametrizations {E M D Z N P A B : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [FiniteDimensional ℝ B] [TopologicalSpace N] [ChartedSpace D N]
+    [TopologicalSpace P] [ChartedSpace Z P] {F : N → M} {G : P → M}
+    (hF : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ F) (hG : ContMDiff 𝓘(ℝ, Z) 𝓘(ℝ, E) ∞ G)
+    (hembF : Topology.IsEmbedding F) (hembG : Topology.IsEmbedding G)
+    (c : PartialDiffeomorph 𝓘(ℝ, A) 𝓘(ℝ, D) A N ∞) (d : PartialDiffeomorph 𝓘(ℝ, B) 𝓘(ℝ, Z) B P ∞)
+    (hc0 : (0 : A) ∈ c.source) (hd0 : (0 : B) ∈ d.source) (hxy : G (d 0) = F (c 0))
+    (hdim : Module.finrank ℝ A + Module.finrank ℝ B = Module.finrank ℝ E)
+    (ht :
+      Function.Surjective
+        ((mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F (c 0)).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G (d 0))))
+    {O : Set M} (hO : IsOpen O) (hxO : F (c 0) ∈ O) :
+    ∃ a : ℝ,
+      0 < a ∧
+        ∃ Φ : PartialDiffeomorph 𝓘(ℝ, A × B) 𝓘(ℝ, E) (A × B) M ∞,
+          Metric.closedBall (0 : A) a ×ˢ Metric.closedBall (0 : B) a ⊆ Φ.source ∧
+            Φ.source ⊆ c.source ×ˢ d.source ∧
+              Φ.target ⊆ O ∧
+                Φ (0, 0) = F (c 0) ∧
+                  (∀ u, (u, 0) ∈ Φ.source → Φ (u, 0) = F (c u)) ∧
+                    (∀ v, (0, v) ∈ Φ.source → Φ (0, v) = G (d v)) ∧
+                      (∀ q ∈ Φ.source,
+                        (Φ q ∈ Set.range F ↔ q.2 = 0) ∧ (Φ q ∈ Set.range G ↔ q.1 = 0)) := by
+  let f := F ∘ c
+  let g := G ∘ d
+  have hf : ContMDiffOn 𝓘(ℝ, A) 𝓘(ℝ, E) ∞ f c.source := hF.comp_contMDiffOn c.contMDiffOn_toFun
+  have hg : ContMDiffOn 𝓘(ℝ, B) 𝓘(ℝ, E) ∞ g d.source := hG.comp_contMDiffOn d.contMDiffOn_toFun
+  have hembf : Topology.IsEmbedding (fun u : c.source => f u) :=
+    hembF.comp c.toOpenPartialHomeomorph.isOpenEmbedding_restrict.isEmbedding
+  have hembg : Topology.IsEmbedding (fun v : d.source => g v) :=
+    hembG.comp d.toOpenPartialHomeomorph.isOpenEmbedding_restrict.isEmbedding
+  have hdf :
+    mfderiv 𝓘(ℝ, A) 𝓘(ℝ, E) f 0 =
+      (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F (c 0)).comp (mfderiv 𝓘(ℝ, A) 𝓘(ℝ, D) c 0) :=
+    mfderiv_comp 0 (hF.mdifferentiableAt (by simp)) (c.mdifferentiableAt (by simp) hc0)
+  have hdg :
+    mfderiv 𝓘(ℝ, B) 𝓘(ℝ, E) g 0 =
+      (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G (d 0)).comp (mfderiv 𝓘(ℝ, B) 𝓘(ℝ, Z) d 0) :=
+    mfderiv_comp 0 (hG.mdifferentiableAt (by simp)) (d.mdifferentiableAt (by simp) hd0)
+  have ht' :
+    Function.Surjective ((mfderiv 𝓘(ℝ, A) 𝓘(ℝ, E) f 0).coprod (mfderiv 𝓘(ℝ, B) 𝓘(ℝ, E) g 0)) := by
+    rw [hdf, hdg]
+    intro w
+    obtain ⟨⟨u, v⟩, huv⟩ := ht w
+    obtain ⟨a, ha⟩ := (PartialChart.bijective_mfderiv c hc0).2 u
+    obtain ⟨b, hb⟩ := (PartialChart.bijective_mfderiv d hd0).2 v
+    refine ⟨(a, b), ?_⟩
+    let DF : D →L[ℝ] E := mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F (c 0)
+    let DG : Z →L[ℝ] E := mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G (d 0)
+    let C : A →L[ℝ] D := mfderiv 𝓘(ℝ, A) 𝓘(ℝ, D) c 0
+    let Q : B →L[ℝ] Z := mfderiv 𝓘(ℝ, B) 𝓘(ℝ, Z) d 0
+    change DF (C a) + DG (Q b) = w
+    change C a = u at ha
+    change Q b = v at hb
+    rw [ha, hb]
+    exact huv
+  obtain ⟨U, hU, hpreU⟩ := hembF.isInducing.isOpen_iff.mp c.open_target
+  obtain ⟨V, hV, hpreV⟩ := hembG.isInducing.isOpen_iff.mp d.open_target
+  have hxU : F (c 0) ∈ U := by
+    change c 0 ∈ F ⁻¹' U
+    rw [hpreU]
+    exact c.map_source' hc0
+  have hyV : G (d 0) ∈ V := by
+    change d 0 ∈ G ⁻¹' V
+    rw [hpreV]
+    exact d.map_source' hd0
+  have hxV : F (c 0) ∈ V := hxy ▸ hyV
+  obtain ⟨a, ha, Φ, hprod, hsource, htarget, hleft, hright, himages⟩ :=
+    exists_clean_simultaneous_sheetChart c.open_source d.open_source hc0 hd0 hf hg hxy hembf hembg
+      hdim ht' (hO.inter (hU.inter hV)) ⟨hxO, hxU, hxV⟩
+  refine
+    ⟨a, ha, Φ, hprod, hsource, fun _ hq => (htarget hq).1,
+      hleft 0 (hprod ⟨Metric.mem_closedBall_self ha.le, Metric.mem_closedBall_self ha.le⟩), hleft,
+      hright, ?_⟩
+  intro q hq
+  have hqUV := (htarget (Φ.map_source' hq)).2
+  have hrangeF : Φ q ∈ Set.range F ↔ Φ q ∈ f '' c.source := by
+    constructor
+    · rintro ⟨n, hn⟩
+      have hnU : F n ∈ U := hn ▸ hqUV.1
+      have hnT : n ∈ c.target := by
+        change n ∈ F ⁻¹' U at hnU
+        rwa [hpreU] at hnU
+      refine ⟨c.invFun n, c.map_target' hnT, ?_⟩
+      exact (congrArg F (c.right_inv' hnT)).trans hn
+    · rintro ⟨u, _, hu⟩
+      exact ⟨c u, hu⟩
+  have hrangeG : Φ q ∈ Set.range G ↔ Φ q ∈ g '' d.source := by
+    constructor
+    · rintro ⟨p, hp⟩
+      have hpV : G p ∈ V := hp ▸ hqUV.2
+      have hpT : p ∈ d.target := by
+        change p ∈ G ⁻¹' V at hpV
+        rwa [hpreV] at hpV
+      refine ⟨d.invFun p, d.map_target' hpT, ?_⟩
+      exact (congrArg G (d.right_inv' hpT)).trans hp
+    · rintro ⟨v, _, hv⟩
+      exact ⟨d v, hv⟩
+  exact ⟨hrangeF.trans (himages q hq).1, hrangeG.trans (himages q hq).2⟩
+
+private theorem Smale.exists_clean_crossingChart {E M D Z N P : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [NormedAddCommGroup D] [NormedSpace ℝ D]
+    [FiniteDimensional ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z]
+    [TopologicalSpace N] [ChartedSpace D N] [IsManifold 𝓘(ℝ, D) ∞ N] [TopologicalSpace P]
+    [ChartedSpace Z P] [IsManifold 𝓘(ℝ, Z) ∞ P] {F : N → M} {G : P → M}
+    (hF : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ F) (hG : ContMDiff 𝓘(ℝ, Z) 𝓘(ℝ, E) ∞ G)
+    (hembF : Topology.IsEmbedding F) (hembG : Topology.IsEmbedding G) (x : N) (y : P)
+    (hxy : G y = F x) (hdim : Module.finrank ℝ D + Module.finrank ℝ Z = Module.finrank ℝ E)
+    (ht :
+      Function.Surjective ((mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F x).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G y)))
+    {O : Set M} (hO : IsOpen O) (hxO : F x ∈ O) :
+    ∃ a : ℝ,
+      0 < a ∧
+        ∃ Φ : PartialDiffeomorph 𝓘(ℝ, D × Z) 𝓘(ℝ, E) (D × Z) M ∞,
+          Metric.closedBall (0 : D) a ×ˢ Metric.closedBall (0 : Z) a ⊆ Φ.source ∧
+            Φ.source ⊆
+                (NativeParametrization.centered (D := D) x).source ×ˢ
+                  (NativeParametrization.centered (D := Z) y).source ∧
+              Φ.target ⊆ O ∧
+                Φ (0, 0) = F x ∧
+                  (∀ u,
+                      (u, 0) ∈ Φ.source →
+                        Φ (u, 0) = F (NativeParametrization.centered (D := D) x u)) ∧
+                    (∀ v,
+                        (0, v) ∈ Φ.source →
+                          Φ (0, v) = G (NativeParametrization.centered (D := Z) y v)) ∧
+                      (∀ q ∈ Φ.source,
+                        (Φ q ∈ Set.range F ↔ q.2 = 0) ∧ (Φ q ∈ Set.range G ↔ q.1 = 0)) := by
+  let c := NativeParametrization.centered (D := D) x
+  let d := NativeParametrization.centered (D := Z) y
+  have hc0 : (0 : D) ∈ c.source := NativeParametrization.zero_mem_centered_source x
+  have hd0 : (0 : Z) ∈ d.source := NativeParametrization.zero_mem_centered_source y
+  have hcx : c 0 = x := NativeParametrization.centered_zero x
+  have hdy : d 0 = y := NativeParametrization.centered_zero y
+  have hxy' : G (d 0) = F (c 0) := by rw [hcx, hdy]; exact hxy
+  have ht' :
+    Function.Surjective
+      ((mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F (c 0)).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G (d 0))) := by
+    rw [hcx, hdy]
+    exact ht
+  have hxO' : F (c 0) ∈ O := by rw [hcx]; exact hxO
+  obtain ⟨a, ha, Φ, hprod, hsource, htarget, hcenter, hleft, hright, himages⟩ :=
+    exists_clean_crossingChart_of_parametrizations hF hG hembF hembG c d hc0 hd0 hxy' hdim ht' hO
+      hxO'
+  exact
+    ⟨a, ha, Φ, hprod, hsource, htarget, hcenter.trans (congrArg F hcx), hleft, hright, himages⟩
+
+private theorem
+    Smale.exists_isolating_crossing_neighborhood {E M D Z N P : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [NormedAddCommGroup D] [NormedSpace ℝ D]
+    [FiniteDimensional ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z]
+    [TopologicalSpace N] [ChartedSpace D N] [IsManifold 𝓘(ℝ, D) ∞ N] [TopologicalSpace P]
+    [ChartedSpace Z P] [IsManifold 𝓘(ℝ, Z) ∞ P] {F : N → M} {G : P → M}
+    (hF : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ F) (hG : ContMDiff 𝓘(ℝ, Z) 𝓘(ℝ, E) ∞ G)
+    (hembF : Topology.IsEmbedding F) (hembG : Topology.IsEmbedding G) (x : N) (y : P)
+    (hxy : G y = F x) (hdim : Module.finrank ℝ D + Module.finrank ℝ Z = Module.finrank ℝ E)
+    (ht :
+      Function.Surjective ((mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F x).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G y))) :
+    ∃ O : Set M, IsOpen O ∧ F x ∈ O ∧ O ∩ (Set.range F ∩ Set.range G) = {F x} := by
+  obtain ⟨a, ha, Φ, hprod, -, -, hcenter, -, -, himages⟩ :=
+    exists_clean_crossingChart hF hG hembF hembG x y hxy hdim ht isOpen_univ (Set.mem_univ _)
+  have h0Φ : (0, 0) ∈ Φ.source :=
+    hprod ⟨Metric.mem_closedBall_self ha.le, Metric.mem_closedBall_self ha.le⟩
+  have hFx : F x ∈ Φ.target := hcenter ▸ Φ.map_source' h0Φ
+  refine ⟨Φ.target, Φ.open_target, hFx, ?_⟩
+  ext w
+  constructor
+  · rintro ⟨hw, hwF, hwG⟩
+    let q := Φ.invFun w
+    have hq : q ∈ Φ.source := Φ.map_target' hw
+    have heq : Φ q = w := Φ.right_inv' hw
+    have hqF : Φ q ∈ Set.range F := heq.symm ▸ hwF
+    have hqG : Φ q ∈ Set.range G := heq.symm ▸ hwG
+    have hq0 : q = (0, 0) := Prod.ext ((himages q hq).2.mp hqG) ((himages q hq).1.mp hqF)
+    exact Set.mem_singleton_iff.mpr (heq.symm.trans ((congrArg Φ hq0).trans hcenter))
+  · intro hw
+    rcases Set.mem_singleton_iff.mp hw with rfl
+    exact ⟨hFx, ⟨x, rfl⟩, ⟨y, hxy⟩⟩
+
+private theorem
+    Smale.isDiscrete_transverse_intersections {E M D Z N P : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [NormedAddCommGroup D] [NormedSpace ℝ D]
+    [FiniteDimensional ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z]
+    [TopologicalSpace N] [ChartedSpace D N] [IsManifold 𝓘(ℝ, D) ∞ N] [TopologicalSpace P]
+    [ChartedSpace Z P] [IsManifold 𝓘(ℝ, Z) ∞ P] {F : N → M} {G : P → M}
+    (hF : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ F) (hG : ContMDiff 𝓘(ℝ, Z) 𝓘(ℝ, E) ∞ G)
+    (hembF : Topology.IsEmbedding F) (hembG : Topology.IsEmbedding G)
+    (hdim : Module.finrank ℝ D + Module.finrank ℝ Z = Module.finrank ℝ E)
+    (ht :
+      ∀ x y,
+        G y = F x →
+          Function.Surjective
+            ((mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F x).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G y))) :
+    IsDiscrete (Set.range F ∩ Set.range G) := by
+  rw [isDiscrete_iff_forall_mem_exists_isOpen]
+  rintro z ⟨⟨x, rfl⟩, ⟨y, hxy⟩⟩
+  obtain ⟨O, hO, -, heq⟩ :=
+    exists_isolating_crossing_neighborhood hF hG hembF hembG x y hxy hdim (ht x y hxy)
+  exact ⟨O, hO, heq⟩
+
+private theorem Smale.finite_transverse_intersections {E M D Z N P : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [NormedAddCommGroup D] [NormedSpace ℝ D]
+    [FiniteDimensional ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z]
+    [TopologicalSpace N] [ChartedSpace D N] [IsManifold 𝓘(ℝ, D) ∞ N] [TopologicalSpace P]
+    [ChartedSpace Z P] [IsManifold 𝓘(ℝ, Z) ∞ P] [CompactSpace N] [CompactSpace P] {F : N → M}
+    {G : P → M} (hF : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ F) (hG : ContMDiff 𝓘(ℝ, Z) 𝓘(ℝ, E) ∞ G)
+    (hinjF : Function.Injective F) (hinjG : Function.Injective G)
+    (hdim : Module.finrank ℝ D + Module.finrank ℝ Z = Module.finrank ℝ E)
+    (ht :
+      ∀ x y,
+        G y = F x →
+          Function.Surjective
+            ((mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F x).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G y))) :
+    (Set.range F ∩ Set.range G).Finite := by
+  have hembF := (hF.continuous.isClosedEmbedding hinjF).isEmbedding
+  have hembG := (hG.continuous.isClosedEmbedding hinjG).isEmbedding
+  exact
+    ((isCompact_range hF.continuous).inter_right (isCompact_range hG.continuous).isClosed).finite
+      (isDiscrete_transverse_intersections hF hG hembF hembG hdim ht)
+
+private def Smale.SphereBoundary.definingFunction {E : Type*} [NormedAddCommGroup E] (x : E) : ℝ :=
+  ‖x‖ ^ 2 - 1
+
+private theorem Smale.SphereBoundary.contDiff_definingFunction {E : Type*} [NormedAddCommGroup E]
+    [InnerProductSpace ℝ E] : ContDiff ℝ ∞ (definingFunction (E := E)) :=
+  (contDiff_id.norm_sq (𝕜 := ℝ)).sub contDiff_const
+
+private theorem Smale.SphereBoundary.definingFunction_eq_zero_iff {E : Type*} [NormedAddCommGroup E]
+    (x : E) : definingFunction x = 0 ↔ x ∈ Metric.sphere (0 : E) 1 := by
+  simp only [definingFunction, Metric.mem_sphere, dist_zero_right]
+  constructor
+  · intro h
+    nlinarith [norm_nonneg x]
+  · intro h
+    rw [h]
+    norm_num
+
+private theorem Smale.SphereBoundary.fderiv_definingFunction {E : Type*} [NormedAddCommGroup E]
+    [InnerProductSpace ℝ E] (x : E) : fderiv ℝ (definingFunction (E := E)) x = 2 • innerSL ℝ x :=
+  ((hasStrictFDerivAt_norm_sq x).hasFDerivAt.sub_const 1).fderiv
+
+private theorem Smale.SphereBoundary.fderiv_definingFunction_eq_zero_iff {E : Type*}
+    [NormedAddCommGroup E] [InnerProductSpace ℝ E] (x v : E) :
+    fderiv ℝ (definingFunction (E := E)) x v = 0 ↔ Inner.inner ℝ x v = 0 := by
+  rw [fderiv_definingFunction]
+  rw [two_smul, add_apply]
+  change Inner.inner ℝ x v + Inner.inner ℝ x v = 0 ↔ Inner.inner ℝ x v = 0
+  constructor
+  · intro h
+    linarith
+  · intro h
+    rw [h, add_zero]
+
+private theorem Smale.SphereBoundary.common_kernel_of_immersive_sphere_extension {E : Type*}
+    [NormedAddCommGroup E] [InnerProductSpace ℝ E] {n : ℕ} [Fact (Module.finrank ℝ E = n + 1)]
+    {G H N : Type*} [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [TopologicalSpace N] [ChartedSpace H N] {f : E → N}
+    (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) {γ : Metric.sphere (0 : E) 1 → N}
+    (hext : ∀ x : Metric.sphere (0 : E) 1, f x.1 = γ x)
+    (hγ : ∀ x, Function.Injective (mfderiv (𝓡 n) J γ x)) :
+    ∀ y,
+      definingFunction y = 0 →
+        ∀ v : E,
+          mfderiv 𝓘(ℝ, E) J f y v = 0 → fderiv ℝ (definingFunction (E := E)) y v = 0 → v = 0 := by
+  intro y hy v hfv hρv
+  let x : Metric.sphere (0 : E) 1 := ⟨y, (definingFunction_eq_zero_iff y).mp hy⟩
+  have hinner : Inner.inner ℝ y v = 0 := (fderiv_definingFunction_eq_zero_iff y v).mp hρv
+  have hrange : v ∈ (mvfderiv (𝓡 n) (Subtype.val : Metric.sphere (0 : E) 1 → E) x).range := by
+    rw [range_mvfderiv_subtypeVal]
+    exact Submodule.mem_orthogonal_singleton_iff_inner_right.mpr hinner
+  obtain ⟨w, hw⟩ := hrange
+  change (mfderiv (𝓡 n) 𝓘(ℝ, E) (Subtype.val : Metric.sphere (0 : E) 1 → E) x) w = v at hw
+  have hextfun : (f ∘ (Subtype.val : Metric.sphere (0 : E) 1 → E)) = γ := funext hext
+  have hchain :
+    mfderiv (𝓡 n) J γ x =
+      (mfderiv 𝓘(ℝ, E) J f y).comp
+        (mfderiv (𝓡 n) 𝓘(ℝ, E) (Subtype.val : Metric.sphere (0 : E) 1 → E) x) := by
+    rw [← hextfun,
+      mfderiv_comp x (hf.mdifferentiableAt (by simp))
+        ((contMDiff_coe_sphere (m := (∞ : ℕ∞ω))).mdifferentiableAt (by simp))]
+  have hγzero : mfderiv (𝓡 n) J γ x w = 0 := by
+    rw [hchain]
+    change
+      (mfderiv 𝓘(ℝ, E) J f y)
+          ((mfderiv (𝓡 n) 𝓘(ℝ, E) (Subtype.val : Metric.sphere (0 : E) 1 → E) x) w) =
+        0
+    rw [hw]
+    exact hfv
+  have hwzero : w = 0 := (hγ x) (by simpa only [map_zero] using hγzero)
+  rw [hwzero, map_zero] at hw
+  exact hw.symm
+
+private def Smale.SphereNormalCoordinates.inclusionDerivative {V : Type*} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] {n : ℕ} [Fact (Module.finrank ℝ V = n + 1)]
+    (x : Metric.sphere (0 : V) 1) : EuclideanSpace ℝ (Fin n) →L[ℝ] V :=
+  mvfderiv (𝓡 n) (Subtype.val : Metric.sphere (0 : V) 1 → V) x
+
+private theorem Smale.SphereNormalCoordinates.inner_inclusionDerivative_zero {V : Type*}
+    [NormedAddCommGroup V] [InnerProductSpace ℝ V] {n : ℕ} [Fact (Module.finrank ℝ V = n + 1)]
+    (x : Metric.sphere (0 : V) 1) (u : EuclideanSpace ℝ (Fin n)) :
+    Inner.inner ℝ (x : V) (inclusionDerivative x u) = 0 := by
+  apply Submodule.mem_orthogonal_singleton_iff_inner_right.mp
+  rw [← range_mvfderiv_subtypeVal (n := n) x]
+  exact ⟨u, rfl⟩
+
+private theorem Smale.SphereNormalCoordinates.inner_self_eq_one {V : Type*} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] (x : Metric.sphere (0 : V) 1) : Inner.inner ℝ (x : V) x = 1 := by
+  have hx : ‖(x : V)‖ = 1 := by simpa only [Metric.mem_sphere, dist_zero_right] using x.property
+  rw [real_inner_self_eq_norm_sq, hx, one_pow]
+
+private def Smale.SphereNormalCoordinates.normalFrame {V N : Type*} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] [NormedAddCommGroup N] [NormedSpace ℝ N] {n : ℕ}
+    [Fact (Module.finrank ℝ V = n + 1)] (x : Metric.sphere (0 : V) 1)
+    (A : EuclideanSpace ℝ (Fin n) →L[ℝ] N) : (ℝ × N) →L[ℝ] V :=
+  ((ContinuousLinearMap.id ℝ ℝ).smulRight (x : V)).coprod ((inclusionDerivative x).comp A.inverse)
+
+private theorem Smale.SphereNormalCoordinates.normalFrame_apply {V N : Type*} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] [NormedAddCommGroup N] [NormedSpace ℝ N] {n : ℕ}
+    [Fact (Module.finrank ℝ V = n + 1)] (x : Metric.sphere (0 : V) 1)
+    (A : EuclideanSpace ℝ (Fin n) →L[ℝ] N) (z : ℝ × N) :
+    normalFrame x A z = z.1 • (x : V) + inclusionDerivative x (A.inverse z.2) :=
+  rfl
+
+private theorem Smale.SphereNormalCoordinates.inner_normalFrame {V N : Type*} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] [NormedAddCommGroup N] [NormedSpace ℝ N] {n : ℕ}
+    [Fact (Module.finrank ℝ V = n + 1)] (x : Metric.sphere (0 : V) 1)
+    (A : EuclideanSpace ℝ (Fin n) →L[ℝ] N) (z : ℝ × N) :
+    Inner.inner ℝ (x : V) (normalFrame x A z) = z.1 := by
+  rw [normalFrame_apply, inner_add_right, inner_smul_right, inner_self_eq_one,
+    inner_inclusionDerivative_zero, mul_one, add_zero]
+
+private theorem
+    Smale.SphereNormalCoordinates.bijective_normalFrame {V N : Type*} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] [NormedAddCommGroup N] [NormedSpace ℝ N] {n : ℕ}
+    [Fact (Module.finrank ℝ V = n + 1)] (x : Metric.sphere (0 : V) 1)
+    (A : EuclideanSpace ℝ (Fin n) →L[ℝ] N) (hA : A.IsInvertible) :
+    Function.Bijective (normalFrame x A) := by
+  constructor
+  · intro z w hzw
+    have hfst : z.1 = w.1 := by
+      simpa only [inner_normalFrame] using congrArg (fun v : V => Inner.inner ℝ (x : V) v) hzw
+    have ht : inclusionDerivative x (A.inverse z.2) = inclusionDerivative x (A.inverse w.2) := by
+      rw [normalFrame_apply, normalFrame_apply, hfst] at hzw
+      exact add_left_cancel hzw
+    have hJ : Function.Injective (inclusionDerivative (n := n) x) :=
+      injective_mvfderiv_subtypeVal_sphere x
+    exact Prod.ext hfst (hA.inverse.injective (hJ ht))
+  · intro v
+    have ht : v - Inner.inner ℝ (x : V) v • (x : V) ∈ (inclusionDerivative (n := n) x).range := by
+      change
+        v - Inner.inner ℝ (x : V) v • (x : V) ∈
+          (mvfderiv (𝓡 n) (Subtype.val : Metric.sphere (0 : V) 1 → V) x).range
+      rw [range_mvfderiv_subtypeVal]
+      apply Submodule.mem_orthogonal_singleton_iff_inner_right.mpr
+      rw [inner_sub_right, inner_smul_right, inner_self_eq_one, mul_one, sub_self]
+    obtain ⟨u, hu⟩ := ht
+    change inclusionDerivative x u = v - Inner.inner ℝ (x : V) v • (x : V) at hu
+    refine ⟨(Inner.inner ℝ (x : V) v, A u), ?_⟩
+    rw [normalFrame_apply, hA.inverse_apply_self, hu]
+    abel
+
+private def Smale.SphereNormalCoordinates.normalJacobian {V N : Type*} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] [NormedAddCommGroup N] [NormedSpace ℝ N] {n : ℕ}
+    [Fact (Module.finrank ℝ V = n + 1)] (j : (ℝ × N) ≃L[ℝ] V) (x : Metric.sphere (0 : V) 1)
+    (A : EuclideanSpace ℝ (Fin n) →L[ℝ] N) : ℝ :=
+  ((normalFrame x A).comp j.symm.toContinuousLinearMap).det
+
+private theorem
+    Smale.SphereNormalCoordinates.normalJacobian_ne_zero {V N : Type*} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] [NormedAddCommGroup N] [NormedSpace ℝ N] {n : ℕ}
+    [Fact (Module.finrank ℝ V = n + 1)] [FiniteDimensional ℝ V] (j : (ℝ × N) ≃L[ℝ] V)
+    (x : Metric.sphere (0 : V) 1) (A : EuclideanSpace ℝ (Fin n) →L[ℝ] N) (hA : A.IsInvertible) :
+    normalJacobian j x A ≠ 0 := by
+  apply (Smale.RegularValues.bijective_iff_det_ne_zero _).mp
+  exact (bijective_normalFrame x A hA).comp j.symm.bijective
+
+private theorem Smale.SphereNormalCoordinates.normalJacobian_change_normal_model {V N : Type*}
+    [NormedAddCommGroup V] [InnerProductSpace ℝ V] [NormedAddCommGroup N] [NormedSpace ℝ N]
+    {n : ℕ} [Fact (Module.finrank ℝ V = n + 1)] {N' : Type*} [NormedAddCommGroup N']
+    [NormedSpace ℝ N'] (r : (ℝ × N) ≃L[ℝ] V) (j : N' ≃L[ℝ] N) (x : Metric.sphere (0 : V) 1)
+    (A : EuclideanSpace ℝ (Fin n) →L[ℝ] N) (hA : A.IsInvertible) :
+    normalJacobian ((ContinuousLinearEquiv.prodCongr (ContinuousLinearEquiv.refl ℝ ℝ) j).trans r)
+        x (j.symm.toContinuousLinearMap.comp A) =
+      normalJacobian r x A := by
+  let B : EuclideanSpace ℝ (Fin n) →L[ℝ] N' := j.symm.toContinuousLinearMap.comp A
+  have hj : j.symm.toContinuousLinearMap.IsInvertible := ⟨j.symm, rfl⟩
+  have hB : B.IsInvertible := hj.comp hA
+  have hinv (z : N) : B.inverse (j.symm z) = A.inverse z := by
+    apply hB.injective
+    rw [hB.self_apply_inverse]
+    change j.symm z = j.symm (A (A.inverse z))
+    rw [hA.self_apply_inverse]
+  unfold normalJacobian
+  apply congrArg ContinuousLinearMap.det
+  apply ContinuousLinearMap.ext
+  intro v
+  change
+    (r.symm v).1 • (x : V) + inclusionDerivative x (B.inverse (j.symm (r.symm v).2)) =
+      (r.symm v).1 • (x : V) + inclusionDerivative x (A.inverse (r.symm v).2)
+  rw [hinv]
+
+private def
+    Smale.ManifoldMorse.MorseSurgeryData.beltNormalReference {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (m : ℕ)
+    (hdim : Module.finrank ℝ d.chart.NegativeCoordinates = m) :
+    (ℝ × d.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient (m + 1) :=
+  ContinuousLinearEquiv.ofFinrankEq (by simp [Module.finrank_prod, hdim, Nat.add_comm])
+
+private def Smale.ManifoldMorse.MorseSurgeryData.beltIntersectionJacobian {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (m : ℕ)
+    (j : (ℝ × d.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient (m + 1))
+    (g : Smale.Hemisphere.Sphere m → d.UpperLevel) (x : Smale.Hemisphere.Sphere m) : ℝ :=
+  letI : Fact (Module.finrank ℝ (Smale.Hemisphere.Ambient (m + 1)) = m + 1) :=
+    ⟨finrank_euclideanSpace_fin⟩
+  Smale.SphereNormalCoordinates.normalJacobian j x
+    (mfderiv (𝓡 m) 𝓘(ℝ, d.chart.NegativeCoordinates) (d.beltNormal ∘ g) x)
+
+private def
+    Smale.ManifoldMorse.MorseSurgeryData.beltIntersectionSign {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (m : ℕ)
+    (j : (ℝ × d.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient (m + 1))
+    (g : Smale.Hemisphere.Sphere m → d.UpperLevel) (x : Smale.Hemisphere.Sphere m) : SignType :=
+  SignType.sign (d.beltIntersectionJacobian m j g x)
+
+private def Smale.ManifoldMorse.MorseSurgeryData.beltIntersectionPoints {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (m : ℕ)
+    (g : Smale.Hemisphere.Sphere m → d.UpperLevel) : Set (Smale.Hemisphere.Sphere m) :=
+  g ⁻¹' Set.range d.surgery.beltSphere
+
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.beltIntersectionSigns_opposite_iff {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (m : ℕ)
+    (j : (ℝ × d.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient (m + 1))
+    (g : Smale.Hemisphere.Sphere m → d.UpperLevel) (x y : Smale.Hemisphere.Sphere m) :
+    d.beltIntersectionSign m j g x * d.beltIntersectionSign m j g y = -1 ↔
+      d.beltIntersectionJacobian m j g x * d.beltIntersectionJacobian m j g y < 0 := by
+  unfold beltIntersectionSign
+  rw [← sign_mul, sign_eq_neg_one_iff]
+
+private def Smale.ManifoldMorse.MorseSurgeryData.beltIntersectionCount {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (m : ℕ)
+    (j : (ℝ × d.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient (m + 1))
+    (g : Smale.Hemisphere.Sphere m → d.UpperLevel)
+    (hfin : (d.beltIntersectionPoints m g).Finite) : ℤ :=
+  ∑ x ∈ hfin.toFinset, (d.beltIntersectionSign m j g x : ℤ)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.beltIntersectionJacobian_ne_zero {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (n m : ℕ) [Fact (Module.finrank ℝ d.chart.PositiveCoordinates = n + 1)]
+    (hdim : Module.finrank ℝ d.chart.NegativeCoordinates = m)
+    (j : (ℝ × d.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient (m + 1))
+    (g : Smale.Hemisphere.Sphere m → d.UpperLevel) :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    ∀ (_hg : ContMDiff (𝓡 m) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g)
+      (_ht :
+        ∀ x y,
+          Smale.NativeTransversality.At (𝓡 m) (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) g
+            d.surgery.beltSphere x y)
+      (x : Smale.Hemisphere.Sphere m),
+      x ∈ d.beltIntersectionPoints m g → d.beltIntersectionJacobian m j g x ≠ 0 := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  let _ : Fact (Module.finrank ℝ (Smale.Hemisphere.Ambient (m + 1)) = m + 1) :=
+    ⟨finrank_euclideanSpace_fin⟩
+  intro hg ht x hx
+  obtain ⟨v, hv⟩ := hx
+  have hA := d.bijective_beltNormal_comp_of_transverse hf n m hdim g hg x v hv (ht x v hv)
+  let A : EuclideanSpace ℝ (Fin m) →L[ℝ] d.chart.NegativeCoordinates :=
+    mfderiv (𝓡 m) 𝓘(ℝ, d.chart.NegativeCoordinates) (d.beltNormal ∘ g) x
+  have hAi : A.IsInvertible :=
+    ⟨(LinearEquiv.ofBijective A.toLinearMap hA).toContinuousLinearEquiv, rfl⟩
+  exact Smale.SphereNormalCoordinates.normalJacobian_ne_zero j x A hAi
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.beltIntersectionSign_unit {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (n m : ℕ) [Fact (Module.finrank ℝ d.chart.PositiveCoordinates = n + 1)]
+    (hdim : Module.finrank ℝ d.chart.NegativeCoordinates = m)
+    (j : (ℝ × d.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient (m + 1))
+    (g : Smale.Hemisphere.Sphere m → d.UpperLevel) :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    ∀ (_hg : ContMDiff (𝓡 m) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g)
+      (_ht :
+        ∀ x y,
+          Smale.NativeTransversality.At (𝓡 m) (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) g
+            d.surgery.beltSphere x y)
+      (x : Smale.Hemisphere.Sphere m),
+      x ∈ d.beltIntersectionPoints m g →
+        d.beltIntersectionSign m j g x = 1 ∨ d.beltIntersectionSign m j g x = -1 := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  intro hg ht x hx
+  have hn : d.beltIntersectionSign m j g x ≠ 0 :=
+    sign_ne_zero.mpr (d.beltIntersectionJacobian_ne_zero hf n m hdim j g hg ht x hx)
+  rcases SignType.trichotomy (d.beltIntersectionSign m j g x) with h | h | h
+  · exact Or.inr h
+  · exact (hn h).elim
+  · exact Or.inl h
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.finite_beltIntersectionPoints {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    [T2Space M] [CompactSpace M] (n m : ℕ)
+    [Fact (Module.finrank ℝ d.chart.PositiveCoordinates = n + 1)]
+    (hdim : Module.finrank ℝ d.chart.NegativeCoordinates = m)
+    (g : Smale.Hemisphere.Sphere m → d.UpperLevel) :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    ∀ (_hg : ContMDiff (𝓡 m) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g) (_hinj : Function.Injective g)
+      (_ht :
+        ∀ x y,
+          Smale.NativeTransversality.At (𝓡 m) (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) g
+            d.surgery.beltSphere x y),
+      (d.beltIntersectionPoints m g).Finite := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  let _ := Smale.RegularLevel.isManifold hf d.upper_regular
+  let _ : CompactSpace d.UpperLevel :=
+    isCompact_iff_compactSpace.mp (isClosed_eq hf.continuous continuous_const).isCompact
+  intro hg hinj ht
+  have hdim' :
+    Module.finrank ℝ (EuclideanSpace ℝ (Fin m)) + Module.finrank ℝ (EuclideanSpace ℝ (Fin n)) =
+      Module.finrank ℝ (Smale.RegularLevel.Model E) := by
+    simp only [Smale.RegularLevel.Model, finrank_euclideanSpace_fin]
+    have hp : Module.finrank ℝ d.chart.PositiveCoordinates = n + 1 := Fact.out
+    have hs := d.chart.finrank_negative_add_positive
+    omega
+  have hfin :=
+    Smale.finite_transverse_intersections hg (d.belt_smooth hf n) hinj
+      d.belt_isClosedEmbedding.injective hdim' (fun x y hxy => ht x y hxy)
+  have hpre : (g ⁻¹' (Set.range g ∩ Set.range d.surgery.beltSphere)).Finite :=
+    hfin.preimage hinj.injOn
+  exact hpre.subset (fun x hx => ⟨⟨x, rfl⟩, hx⟩)
+
+private def Smale.TransverseCoordinates.normalCoordinate {D B E M : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, D × B) 𝓘(ℝ, E) (D × B) M ∞) : M → B :=
+  Prod.snd ∘ Φ.symm
+
+private theorem Smale.TransverseCoordinates.contMDiffOn_normalCoordinate {D B E M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, D × B) 𝓘(ℝ, E) (D × B) M ∞) :
+    ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, B) ∞ (normalCoordinate Φ) Φ.target := by
+  have hs : ContMDiff 𝓘(ℝ, D × B) 𝓘(ℝ, B) ∞ (Prod.snd : D × B → B) := contDiff_snd.contMDiff
+  exact hs.comp_contMDiffOn Φ.contMDiffOn_invFun
+
+private theorem Smale.TransverseCoordinates.mfderiv_normalCoordinate {D B E M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, D × B) 𝓘(ℝ, E) (D × B) M ∞) {p : M} (hp : p ∈ Φ.target) :
+    mfderiv 𝓘(ℝ, E) 𝓘(ℝ, B) (normalCoordinate Φ) p =
+      (ContinuousLinearMap.snd ℝ D B).comp (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, D × B) Φ.symm p) := by
+  have hs : ContMDiff 𝓘(ℝ, D × B) 𝓘(ℝ, B) ∞ (Prod.snd : D × B → B) := contDiff_snd.contMDiff
+  have hd :
+    mfderiv 𝓘(ℝ, D × B) 𝓘(ℝ, B) (Prod.snd : D × B → B) (Φ.symm p) =
+      ContinuousLinearMap.snd ℝ D B := by
+    rw [mfderiv_eq_fderiv]
+    exact (ContinuousLinearMap.snd ℝ D B).fderiv
+  rw [normalCoordinate,
+    mfderiv_comp p (hs.mdifferentiableAt (by simp)) (Φ.symm.mdifferentiableAt (by simp) hp), hd]
+  rfl
+
+private theorem Smale.TransverseCoordinates.surjective_mfderiv_normalCoordinate {D B E M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, D × B) 𝓘(ℝ, E) (D × B) M ∞) {p : M} (hp : p ∈ Φ.target) :
+    Function.Surjective (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, B) (normalCoordinate Φ) p) := by
+  rw [mfderiv_normalCoordinate Φ hp]
+  exact
+    (show Function.Surjective (ContinuousLinearMap.snd ℝ D B) from fun w => ⟨(0, w), rfl⟩).comp
+      (Smale.PartialChart.bijective_mfderiv Φ.symm hp).2
+
+private theorem Smale.TransverseCoordinates.normalCoordinate_sheet_eventually_zero {D B E M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, D × B) 𝓘(ℝ, E) (D × B) M ∞) {N : Type*} [TopologicalSpace N]
+    {F : N → M} (hF : Continuous F) (hclean : ∀ q ∈ Φ.source, Φ q ∈ Set.range F ↔ q.2 = 0) {x : N}
+    (hx : F x ∈ Φ.target) : (normalCoordinate Φ ∘ F) =ᶠ[𝓝 x] (fun _ => 0) := by
+  filter_upwards [hF.continuousAt.preimage_mem_nhds (Φ.open_target.mem_nhds hx)] with y hy
+  have hq : Φ.invFun (F y) ∈ Φ.source := Φ.map_target' hy
+  exact (hclean _ hq).mp ⟨y, (Φ.right_inv' hy).symm⟩
+
+private theorem Smale.TransverseCoordinates.normalDerivative_comp_sheet_eq_zero {D B E M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, D × B) 𝓘(ℝ, E) (D × B) M ∞) {G N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace N] [ChartedSpace G N] {F : N → M}
+    (hF : ContMDiff 𝓘(ℝ, G) 𝓘(ℝ, E) ∞ F) (hclean : ∀ q ∈ Φ.source, Φ q ∈ Set.range F ↔ q.2 = 0)
+    {x : N} (hx : F x ∈ Φ.target) :
+    (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, B) (normalCoordinate Φ) (F x)).comp (mfderiv 𝓘(ℝ, G) 𝓘(ℝ, E) F x) = 0 :=
+  by
+  have heq := normalCoordinate_sheet_eventually_zero Φ hF.continuous hclean hx
+  have hzero : mfderiv 𝓘(ℝ, G) 𝓘(ℝ, B) (normalCoordinate Φ ∘ F) x = 0 := by
+    rw [heq.mfderiv_eq]
+    simp only [mfderiv_const]
+    rfl
+  have hnormal := (contMDiffOn_normalCoordinate Φ).contMDiffAt (Φ.open_target.mem_nhds hx)
+  rw [mfderiv_comp x (hnormal.mdifferentiableAt (by simp))
+      (hF.mdifferentiableAt (by simp))] at hzero
+  exact hzero
+
+public
+theorem Smale.StripCoordinates.hasDerivAt_verticalSlice {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {F : (ℝ × ℝ) → E} {t s : ℝ} (hF : DifferentiableAt ℝ F (t, s)) :
+    HasDerivAt (fun u : ℝ => F (t, u)) (fderiv ℝ F (t, s) (0, 1)) s := by
+  have hi : HasDerivAt (fun u : ℝ => (t, u)) (0, 1) s :=
+    (hasDerivAt_const s t).prodMk (hasDerivAt_id s)
+  exact hF.hasFDerivAt.comp_hasDerivAt s hi
+
+private theorem Smale.StripCoordinates.hasDerivAt_horizontalSlice {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {F : (ℝ × ℝ) → E} {t s : ℝ} (hF : DifferentiableAt ℝ F (t, s)) :
+    HasDerivAt (fun u : ℝ => F (u, s)) (fderiv ℝ F (t, s) (1, 0)) t := by
+  have hi : HasDerivAt (fun u : ℝ => (u, s)) (1, 0) t :=
+    (hasDerivAt_id t).prodMk (hasDerivAt_const t s)
+  exact hF.hasFDerivAt.comp_hasDerivAt t hi
+
+private abbrev Smale.StripCoordinates.Space (A B : Type*) :=
+  (ℝ × A) × B
+
+private def
+    Smale.StripCoordinates.center {A B : Type*} [NormedAddCommGroup A] [NormedAddCommGroup B]
+    (t : ℝ) : Space A B :=
+  ((t, 0), 0)
+
+private def Smale.StripCoordinates.model {A B : Type*} [NormedAddCommGroup A] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] (v : ℝ → B) (p : ℝ × ℝ) : Space A B :=
+  ((p.1, 0), p.2 • v p.1)
+
+private def
+    Smale.StripCoordinates.normalDerivative {A B : Type*} [NormedAddCommGroup B] [NormedSpace ℝ B]
+    (F : (ℝ × ℝ) → Space A B) (t : ℝ) : B :=
+  fderiv ℝ (fun p => (F p).2) (t, 0) (0, 1)
+
+private def Smale.StripCoordinates.blend {A B : Type*} [NormedAddCommGroup A] [NormedSpace ℝ A]
+    [NormedAddCommGroup B] [NormedSpace ℝ B] (v : ℝ → B) (F₀ F₁ : (ℝ × ℝ) → Space A B)
+    (β₀ β₁ : ℝ → ℝ) (p : ℝ × ℝ) : Space A B :=
+  model v p + β₀ p.1 • (F₀ p - model v p) + β₁ p.1 • (F₁ p - model v p)
+
+private theorem Smale.StripCoordinates.contDiff_model {A B : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] {v : ℝ → B} (hv : ContDiff ℝ ∞ v) :
+    ContDiff ℝ ∞ (model (A := A) v) :=
+  (contDiff_fst.prodMk contDiff_const).prodMk (contDiff_snd.smul (hv.comp contDiff_fst))
+
+private theorem Smale.StripCoordinates.contDiff_blend {A B : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] {v : ℝ → B}
+    {F₀ F₁ : (ℝ × ℝ) → Space A B} {β₀ β₁ : ℝ → ℝ} (hv : ContDiff ℝ ∞ v) (hF₀ : ContDiff ℝ ∞ F₀)
+    (hF₁ : ContDiff ℝ ∞ F₁) (hβ₀ : ContDiff ℝ ∞ β₀) (hβ₁ : ContDiff ℝ ∞ β₁) :
+    ContDiff ℝ ∞ (blend v F₀ F₁ β₀ β₁) :=
+  ((contDiff_model hv).add ((hβ₀.comp contDiff_fst).smul (hF₀.sub (contDiff_model hv)))).add
+    ((hβ₁.comp contDiff_fst).smul (hF₁.sub (contDiff_model hv)))
+
+private theorem Smale.StripCoordinates.model_zero {A B : Type*} [NormedAddCommGroup A]
+    [NormedAddCommGroup B] [NormedSpace ℝ B] (v : ℝ → B) (t : ℝ) :
+    model (A := A) v (t, 0) = Smale.StripCoordinates.center t := by
+  simp only [model, Smale.StripCoordinates.center, zero_smul]
+
+private theorem
+    Smale.StripCoordinates.blend_zero {A B : Type*} [NormedAddCommGroup A] [NormedSpace ℝ A]
+    [NormedAddCommGroup B] [NormedSpace ℝ B] {v : ℝ → B} {F₀ F₁ : (ℝ × ℝ) → Space A B}
+    {β₀ β₁ : ℝ → ℝ} (h₀ : ∀ t, β₀ t ≠ 0 → F₀ (t, 0) = Smale.StripCoordinates.center t)
+    (h₁ : ∀ t, β₁ t ≠ 0 → F₁ (t, 0) = Smale.StripCoordinates.center t) (t : ℝ) :
+    blend v F₀ F₁ β₀ β₁ (t, 0) = Smale.StripCoordinates.center t := by
+  have hterm₀ : β₀ t • (F₀ (t, 0) - model v (t, 0)) = 0 := by
+    by_cases h : β₀ t = 0
+    · rw [h, zero_smul]
+    · rw [h₀ t h, model_zero, sub_self, smul_zero]
+  have hterm₁ : β₁ t • (F₁ (t, 0) - model v (t, 0)) = 0 := by
+    by_cases h : β₁ t = 0
+    · rw [h, zero_smul]
+    · rw [h₁ t h, model_zero, sub_self, smul_zero]
+  change
+    model v (t, 0) + β₀ t • (F₀ (t, 0) - model v (t, 0)) + β₁ t • (F₁ (t, 0) - model v (t, 0)) =
+      Smale.StripCoordinates.center t
+  rw [hterm₀, hterm₁, add_zero, add_zero, model_zero]
+
+private theorem Smale.StripCoordinates.blend_eq_left {A B : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] {v : ℝ → B}
+    {F₀ F₁ : (ℝ × ℝ) → Space A B} {β₀ β₁ : ℝ → ℝ} {p : ℝ × ℝ} (h₀ : β₀ p.1 = 1)
+    (h₁ : β₁ p.1 = 0) : blend v F₀ F₁ β₀ β₁ p = F₀ p := by
+  simp only [blend, h₀, h₁, one_smul, zero_smul, add_zero]
+  rw [← add_sub_assoc, add_sub_cancel_left]
+
+private theorem Smale.StripCoordinates.blend_eq_right {A B : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] {v : ℝ → B}
+    {F₀ F₁ : (ℝ × ℝ) → Space A B} {β₀ β₁ : ℝ → ℝ} {p : ℝ × ℝ} (h₀ : β₀ p.1 = 0)
+    (h₁ : β₁ p.1 = 1) : blend v F₀ F₁ β₀ β₁ p = F₁ p := by
+  simp only [blend, h₀, h₁, one_smul, zero_smul, add_zero]
+  rw [← add_sub_assoc, add_sub_cancel_left]
+
+private theorem Smale.StripCoordinates.normalDerivative_blend {A B : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] {v : ℝ → B}
+    {F₀ F₁ : (ℝ × ℝ) → Space A B} {β₀ β₁ : ℝ → ℝ} (hv : ContDiff ℝ ∞ v) (hF₀ : ContDiff ℝ ∞ F₀)
+    (hF₁ : ContDiff ℝ ∞ F₁) (hβ₀ : ContDiff ℝ ∞ β₀) (hβ₁ : ContDiff ℝ ∞ β₁)
+    (h₀ : ∀ t, β₀ t ≠ 0 → normalDerivative F₀ t = v t)
+    (h₁ : ∀ t, β₁ t ≠ 0 → normalDerivative F₁ t = v t) (t : ℝ) :
+    normalDerivative (blend v F₀ F₁ β₀ β₁) t = v t := by
+  have hm : HasDerivAt (fun s : ℝ => s • v t) (v t) 0 := by
+    simpa only [one_smul, id_eq] using (hasDerivAt_id (0 : ℝ)).smul_const (v t)
+  have hd₀ :=
+    hasDerivAt_verticalSlice (t := t) (s := 0) (hF₀.snd.contDiffAt.differentiableAt (by simp))
+  have hd₁ :=
+    hasDerivAt_verticalSlice (t := t) (s := 0) (hF₁.snd.contDiffAt.differentiableAt (by simp))
+  have hterm₀ : β₀ t • (normalDerivative F₀ t - v t) = 0 := by
+    by_cases h : β₀ t = 0
+    · rw [h, zero_smul]
+    · rw [h₀ t h, sub_self, smul_zero]
+  have hterm₁ : β₁ t • (normalDerivative F₁ t - v t) = 0 := by
+    by_cases h : β₁ t = 0
+    · rw [h, zero_smul]
+    · rw [h₁ t h, sub_self, smul_zero]
+  have hblend :
+    HasDerivAt (fun s : ℝ => (blend v F₀ F₁ β₀ β₁ (t, s)).2)
+      (v t + β₀ t • (normalDerivative F₀ t - v t) + β₁ t • (normalDerivative F₁ t - v t)) 0 :=
+    HasDerivAt.add (HasDerivAt.add hm (HasDerivAt.const_smul (β₀ t) (HasDerivAt.sub hd₀ hm)))
+      (HasDerivAt.const_smul (β₁ t) (HasDerivAt.sub hd₁ hm))
+  have hblend' : HasDerivAt (fun s : ℝ => (blend v F₀ F₁ β₀ β₁ (t, s)).2) (v t) 0 := by
+    simpa only [hterm₀, hterm₁, add_zero] using hblend
+  exact
+    (hasDerivAt_verticalSlice
+          ((contDiff_blend hv hF₀ hF₁ hβ₀ hβ₁).snd.contDiffAt.differentiableAt (by simp))).unique
+      hblend'
+
+private structure Smale.StripNormalData (A B : Type*) [NormedAddCommGroup A] [NormedSpace ℝ A]
+    [NormedAddCommGroup B] [NormedSpace ℝ B] {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] (S : Set M) (k : (ℝ × ℝ) → M) where
+  chart :
+    PartialDiffeomorph 𝓘(ℝ, StripCoordinates.Space A B) 𝓘(ℝ, E) (StripCoordinates.Space A B) M ∞
+  line : Set.MapsTo StripCoordinates.center (Set.Icc (0 : ℝ) 1) chart.source
+  sheet : ∀ q ∈ chart.source, chart q ∈ S ↔ q.2 = 0
+  center : ∀ t, k (t, 0) = chart (StripCoordinates.center t)
+  normal_nonzero :
+    ∀ t ∈ Set.Icc (0 : ℝ) 1,
+      fderiv ℝ (TransverseCoordinates.normalCoordinate chart ∘ k) (t, 0) (0, 1) ≠ 0
+
+private theorem Smale.StripCoordinates.horizontal_derivative_of_center {A B : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    {F : (ℝ × ℝ) → Space A B} {t : ℝ} (hF : DifferentiableAt ℝ F (t, 0))
+    (hc : ∀ s, F (s, 0) = Smale.StripCoordinates.center s) :
+    fderiv ℝ F (t, 0) (1, 0) = Smale.StripCoordinates.center 1 := by
+  have hd := hasDerivAt_horizontalSlice hF
+  have heq : (fun s : ℝ => F (s, 0)) = Smale.StripCoordinates.center := funext hc
+  rw [heq] at hd
+  have hcenter :
+    HasDerivAt (Smale.StripCoordinates.center : ℝ → Space A B) (Smale.StripCoordinates.center 1)
+      t :=
+    ((hasDerivAt_id t).prodMk (hasDerivAt_const t (0 : A))).prodMk (hasDerivAt_const t (0 : B))
+  exact hd.unique hcenter
+
+private theorem Smale.StripCoordinates.horizontal_derivative_of_center_germ {A B : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    {F : (ℝ × ℝ) → Space A B} {t : ℝ} (hF : DifferentiableAt ℝ F (t, 0))
+    (hc : (fun s : ℝ => F (s, 0)) =ᶠ[𝓝 t] Smale.StripCoordinates.center) :
+    fderiv ℝ F (t, 0) (1, 0) = Smale.StripCoordinates.center 1 := by
+  have hd := hasDerivAt_horizontalSlice hF
+  have hcenter :
+    HasDerivAt (Smale.StripCoordinates.center : ℝ → Space A B) (Smale.StripCoordinates.center 1)
+      t :=
+    ((hasDerivAt_id t).prodMk (hasDerivAt_const t (0 : A))).prodMk (hasDerivAt_const t (0 : B))
+  exact hd.unique (hcenter.congr_of_eventuallyEq hc)
+
+private theorem
+    Smale.StripCoordinates.normalDerivative_eq_snd_fderiv {A B : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] {F : (ℝ × ℝ) → Space A B} {t : ℝ}
+    (hF : DifferentiableAt ℝ F (t, 0)) : normalDerivative F t = (fderiv ℝ F (t, 0) (0, 1)).2 := by
+  have hd := hF.hasFDerivAt.snd
+  rw [normalDerivative, hd.fderiv]
+  rfl
+
+private theorem Smale.StripCoordinates.injective_of_horizontal_and_normal {A B : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    (L : (ℝ × ℝ) →L[ℝ] Space A B) (hh : L (1, 0) = Smale.StripCoordinates.center 1)
+    (hn : (L (0, 1)).2 ≠ 0) : Function.Injective L := by
+  have hker : ∀ p : ℝ × ℝ, L p = 0 → p = 0 := by
+    rintro ⟨a, b⟩ hp
+    have hsplit : (a, b) = a • ((1 : ℝ), 0) + b • (0, 1) := by ext <;> simp
+    rw [hsplit, map_add, map_smul, map_smul, hh] at hp
+    have hb0 : b • (L (0, 1)).2 = 0 := by
+      simpa [Smale.StripCoordinates.center] using congrArg Prod.snd hp
+    have hb : b = 0 := (smul_eq_zero.mp hb0).resolve_right hn
+    subst b
+    have ha : a = 0 := by
+      simpa [Smale.StripCoordinates.center] using congrArg (fun q : Space A B => q.1.1) hp
+    subst a
+    rfl
+  intro p q hpq
+  apply sub_eq_zero.mp
+  apply hker
+  rw [map_sub, hpq, sub_self]
+
+private theorem
+    Smale.StripCoordinates.injective_fderiv_at_center {A B : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] {F : (ℝ × ℝ) → Space A B} {t : ℝ}
+    (hF : DifferentiableAt ℝ F (t, 0)) (hc : ∀ s, F (s, 0) = Smale.StripCoordinates.center s)
+    (hn : normalDerivative F t ≠ 0) : Function.Injective (fderiv ℝ F (t, 0)) := by
+  apply
+    injective_of_horizontal_and_normal (fderiv ℝ F (t, 0)) (horizontal_derivative_of_center hF hc)
+  rwa [← normalDerivative_eq_snd_fderiv hF]
+
+private def Smale.StripCoordinates.sheetTransverseInclusion {A B : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] : A →L[ℝ] Space A B :=
+  (ContinuousLinearMap.inl ℝ (ℝ × A) B).comp (ContinuousLinearMap.inr ℝ ℝ A)
+
+private theorem
+    Smale.StripCoordinates.sheetTransverseInclusion_apply {A B : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] (a : A) :
+    (sheetTransverseInclusion : A →L[ℝ] Space A B) a = ((0, a), 0) :=
+  rfl
+
+private theorem
+    Smale.StripCoordinates.sheetTransverse_eq_strip_iff {A B : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] (L : (ℝ × ℝ) →L[ℝ] Space A B)
+    (hh : L (1, 0) = Smale.StripCoordinates.center 1) (hn : (L (0, 1)).2 ≠ 0) (a : A)
+    (p : ℝ × ℝ) : sheetTransverseInclusion a = L p ↔ a = 0 ∧ p = 0 := by
+  constructor
+  · intro heq
+    have hsplit : p = p.1 • ((1 : ℝ), 0) + p.2 • (0, 1) := by ext <;> simp
+    have hexp : L p = p.1 • Smale.StripCoordinates.center 1 + p.2 • L (0, 1) := by
+      conv_lhs => rw [hsplit]
+      rw [map_add, map_smul, map_smul, hh]
+    rw [hexp] at heq
+    have hp2zero : p.2 • (L (0, 1)).2 = 0 := by
+      simpa [sheetTransverseInclusion_apply, Smale.StripCoordinates.center] using
+        (congrArg Prod.snd heq).symm
+    have hp2 : p.2 = 0 := (smul_eq_zero.mp hp2zero).resolve_right hn
+    rw [hp2, zero_smul, add_zero] at heq
+    have hp1 : p.1 = 0 := by
+      simpa [sheetTransverseInclusion_apply, Smale.StripCoordinates.center] using
+        (congrArg (fun q : Space A B => q.1.1) heq).symm
+    have ha : a = 0 := by
+      simpa [sheetTransverseInclusion_apply, Smale.StripCoordinates.center] using
+        congrArg (fun q : Space A B => q.1.2) heq
+    exact ⟨ha, Prod.ext hp1 hp2⟩
+  · rintro ⟨rfl, rfl⟩
+    rw [map_zero, map_zero]
+
+private theorem Smale.StripCoordinates.injective_sheetTransverse_normalQuotient {A B Z : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] (L : (ℝ × ℝ) →L[ℝ] Space A B) (Q : Space A B →L[ℝ] Z)
+    (hh : L (1, 0) = Smale.StripCoordinates.center 1) (hn : (L (0, 1)).2 ≠ 0)
+    (hker : Q.ker = L.range) : Function.Injective (Q.comp sheetTransverseInclusion) := by
+  have hz : ∀ a : A, Q (sheetTransverseInclusion a) = 0 → a = 0 := by
+    intro a ha
+    have hmem : sheetTransverseInclusion a ∈ L.range := by
+      rw [← hker]
+      exact ha
+    obtain ⟨p, hp⟩ := hmem
+    exact ((sheetTransverse_eq_strip_iff L hh hn a p).mp hp.symm).1
+  intro a b hab
+  apply sub_eq_zero.mp
+  apply hz
+  change (Q.comp sheetTransverseInclusion) (a - b) = 0
+  rw [map_sub, hab, sub_self]
+
+private theorem Smale.StripCoordinates.ker_comp_eq_range_of_injective {A B Z : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    (T : Space A B →L[ℝ] V) (L : (ℝ × ℝ) →L[ℝ] Space A B) (Q : V →L[ℝ] Z)
+    (hT : Function.Injective T) (hker : Q.ker = (T.comp L).range) : (Q.comp T).ker = L.range := by
+  ext v
+  constructor
+  · intro hv
+    have hmem : T v ∈ (T.comp L).range := by
+      rw [← hker]
+      exact hv
+    obtain ⟨p, hp⟩ := hmem
+    exact ⟨p, hT hp⟩
+  · rintro ⟨p, rfl⟩
+    have hmem : T (L p) ∈ Q.ker := by
+      rw [hker]
+      exact ⟨p, rfl⟩
+    exact hmem
+
+private def
+    Smale.StripNormalData.coordinateMap {A B E M : Type*} [NormedAddCommGroup A] [NormedSpace ℝ A]
+    [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k) : (ℝ × ℝ) → Smale.StripCoordinates.Space A B :=
+  d.chart.symm ∘ k
+
+private theorem Smale.StripNormalData.center_mem_target {A B E M : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k) {t : ℝ} (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    k (t, 0) ∈ d.chart.target := by
+  rw [d.center t]
+  exact d.chart.map_source' (d.line ht)
+
+private theorem
+    Smale.StripNormalData.coordinate_center_germ {A B E M : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k) {t : ℝ} (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    (fun s : ℝ => d.coordinateMap (s, 0)) =ᶠ[𝓝 t] Smale.StripCoordinates.center := by
+  have hc : Continuous (Smale.StripCoordinates.center : ℝ → Smale.StripCoordinates.Space A B) :=
+    (continuous_id.prodMk continuous_const).prodMk continuous_const
+  filter_upwards [hc.continuousAt.preimage_mem_nhds
+      (d.chart.open_source.mem_nhds (d.line ht))] with
+    s hs
+  change d.chart.invFun (k (s, 0)) = Smale.StripCoordinates.center s
+  rw [d.center s, d.chart.left_inv' hs]
+
+private theorem Smale.StripNormalData.coordinate_center {A B E M : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k) {t : ℝ} (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    d.coordinateMap (t, 0) = Smale.StripCoordinates.center t :=
+  (d.coordinate_center_germ ht).eq_of_nhds
+
+private theorem
+    Smale.StripNormalData.contDiffAt_coordinateMap {A B E M : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k) {t : ℝ} (ht : t ∈ Set.Icc (0 : ℝ) 1)
+    (hk : ContMDiffAt 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ k (t, 0)) : ContDiffAt ℝ ∞ d.coordinateMap (t, 0) :=
+  ((d.chart.contMDiffOn_invFun.contMDiffAt
+          (d.chart.open_target.mem_nhds (d.center_mem_target ht))).comp
+      (t, 0) hk).contDiffAt
+
+private theorem Smale.StripNormalData.horizontal_coordinateDerivative {A B E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S : Set M}
+    {k : (ℝ × ℝ) → M} (d : Smale.StripNormalData A B (E := E) S k) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1) (hk : ContMDiffAt 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ k (t, 0)) :
+    fderiv ℝ d.coordinateMap (t, 0) (1, 0) = Smale.StripCoordinates.center 1 :=
+  Smale.StripCoordinates.horizontal_derivative_of_center_germ
+    ((d.contDiffAt_coordinateMap ht hk).differentiableAt (by simp)) (d.coordinate_center_germ ht)
+
+private theorem Smale.StripNormalData.normal_coordinateDerivative_nonzero {A B E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S : Set M}
+    {k : (ℝ × ℝ) → M} (d : Smale.StripNormalData A B (E := E) S k) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1) (hk : ContMDiffAt 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ k (t, 0)) :
+    (fderiv ℝ d.coordinateMap (t, 0) (0, 1)).2 ≠ 0 := by
+  rw [←
+    Smale.StripCoordinates.normalDerivative_eq_snd_fderiv
+      ((d.contDiffAt_coordinateMap ht hk).differentiableAt (by simp))]
+  exact d.normal_nonzero t ht
+
+private theorem
+    Smale.StripNormalData.native_derivative_factor {A B E M : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k) {t : ℝ} (ht : t ∈ Set.Icc (0 : ℝ) 1)
+    (hk : ContMDiffAt 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ k (t, 0)) :
+    mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) k (t, 0) =
+      (mfderiv 𝓘(ℝ, Smale.StripCoordinates.Space A B) 𝓘(ℝ, E) d.chart
+            (Smale.StripCoordinates.center t)).comp
+        (fderiv ℝ d.coordinateMap (t, 0)) := by
+  have hcoords := d.contDiffAt_coordinateMap ht hk
+  have heq : (d.chart ∘ d.coordinateMap) =ᶠ[𝓝 (t, 0)] k := by
+    filter_upwards [hk.continuousAt.preimage_mem_nhds
+        (d.chart.open_target.mem_nhds (d.center_mem_target ht))] with
+      p hp
+    change d.chart (d.chart.invFun (k p)) = k p
+    exact d.chart.right_inv' hp
+  have hcsource : d.coordinateMap (t, 0) ∈ d.chart.source := by
+    rw [d.coordinate_center ht]
+    exact d.line ht
+  rw [← heq.mfderiv_eq,
+    mfderiv_comp (t, 0) (d.chart.mdifferentiableAt (by simp) hcsource)
+      (hcoords.contMDiffAt.mdifferentiableAt (by simp)),
+    d.coordinate_center ht, mfderiv_eq_fderiv]
+  rfl
+
+private theorem
+    Smale.TransverseCoordinates.mfderiv_zero_section {D B E M : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, D × B) 𝓘(ℝ, E) (D × B) M ∞) {f : D → M}
+    (hzero : ∀ x, Φ (x, 0) = f x) {x : D} (hx : (x, 0) ∈ Φ.source) :
+    mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x =
+      (mfderiv 𝓘(ℝ, D × B) 𝓘(ℝ, E) Φ (x, 0)).comp (ContinuousLinearMap.inl ℝ D B) := by
+  have heq : f = Φ ∘ (ContinuousLinearMap.inl ℝ D B) := funext (fun y => (hzero y).symm)
+  have hinl : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, D × B) ∞ (ContinuousLinearMap.inl ℝ D B) :=
+    (ContinuousLinearMap.inl ℝ D B).contDiff.contMDiff
+  rw [heq, mfderiv_comp x (Φ.mdifferentiableAt (by simp) hx) (hinl.mdifferentiableAt (by simp)),
+    mfderiv_eq_fderiv, (ContinuousLinearMap.inl ℝ D B).fderiv]
+  rfl
+
+private theorem
+    Smale.TransverseCoordinates.ker_normalDerivative_eq_range_zero_section {D B E M : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, D × B) 𝓘(ℝ, E) (D × B) M ∞) {f : D → M}
+    (hzero : ∀ x, Φ (x, 0) = f x) {x : D} (hx : (x, 0) ∈ Φ.source) :
+    (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, B) (normalCoordinate Φ) (f x)).ker =
+      (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) f x).range := by
+  let L : (D × B) →L[ℝ] E := mfderiv 𝓘(ℝ, D × B) 𝓘(ℝ, E) Φ (x, 0)
+  let R : E →L[ℝ] (D × B) := mfderiv 𝓘(ℝ, E) 𝓘(ℝ, D × B) Φ.symm (Φ (x, 0))
+  have hdiff : Φ.toOpenPartialHomeomorph.MDifferentiable 𝓘(ℝ, D × B) 𝓘(ℝ, E) :=
+    ⟨Φ.mdifferentiableOn (by simp), Φ.symm.mdifferentiableOn (by simp)⟩
+  have hRL : R.comp L = ContinuousLinearMap.id ℝ (D × B) := hdiff.symm_comp_deriv hx
+  have hRL_apply (q : D × B) : R (L q) = q := by
+    change (R.comp L) q = q
+    rw [hRL]
+    rfl
+  have hsurj : Function.Surjective L := (Smale.PartialChart.bijective_mfderiv Φ hx).2
+  have hnormal :
+    mfderiv 𝓘(ℝ, E) 𝓘(ℝ, B) (normalCoordinate Φ) (f x) = (ContinuousLinearMap.snd ℝ D B).comp R :=
+    by
+    rw [← hzero x, mfderiv_normalCoordinate Φ (Φ.map_source' hx)]
+    rfl
+  rw [hnormal, mfderiv_zero_section Φ hzero hx]
+  ext v
+  constructor
+  · intro hv
+    obtain ⟨⟨a, b⟩, hab⟩ := hsurj v
+    have hb : b = 0 := by
+      change (R v).2 = 0 at hv
+      rw [← hab, hRL_apply] at hv
+      exact hv
+    subst b
+    exact ⟨a, hab⟩
+  · rintro ⟨a, rfl⟩
+    change (R (L (a, 0))).2 = 0
+    rw [hRL_apply]
+
+private def
+    Smale.StripNormalData.normalFrame {A B Z E M : Type*} [NormedAddCommGroup A] [NormedSpace ℝ A]
+    [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S : Set M}
+    {k : (ℝ × ℝ) → M} (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) (t : ℝ) : A →L[ℝ] Z :=
+  (fderiv ℝ (Smale.TransverseCoordinates.normalCoordinate Ψ ∘ d.chart)
+        (Smale.StripCoordinates.center t)).comp
+    Smale.StripCoordinates.sheetTransverseInclusion
+
+private theorem
+    Smale.StripNormalData.contDiffOn_normalFrame {A B Z E M : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M} (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) :
+    ContDiffOn ℝ ∞ (d.normalFrame Ψ)
+      {t |
+        Smale.StripCoordinates.center t ∈ d.chart.source ∧
+          d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target} := by
+  intro t ht
+  have hnormal :=
+    (Smale.TransverseCoordinates.contMDiffOn_normalCoordinate Ψ).contMDiffAt
+      (Ψ.open_target.mem_nhds ht.2)
+  have hchart := d.chart.contMDiffOn_toFun.contMDiffAt (d.chart.open_source.mem_nhds ht.1)
+  have htransition :
+    ContDiffAt ℝ ∞ (Smale.TransverseCoordinates.normalCoordinate Ψ ∘ d.chart)
+      (Smale.StripCoordinates.center t) :=
+    (hnormal.comp (Smale.StripCoordinates.center t) hchart).contDiffAt
+  have hcenter :
+    ContDiff ℝ ∞ (Smale.StripCoordinates.center : ℝ → Smale.StripCoordinates.Space A B) :=
+    (contDiff_id.prodMk contDiff_const).prodMk contDiff_const
+  exact
+    (((htransition.fderiv_right (by simp)).comp t hcenter.contDiffAt).clm_comp
+        contDiffAt_const).contDiffWithinAt
+
+private theorem Smale.StripNormalData.exists_open_normalFrame_domain {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞)
+    (htarget : ∀ t ∈ Set.Icc (0 : ℝ) 1, d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target) :
+    ∃ U : Set ℝ, IsOpen U ∧ Set.Icc (0 : ℝ) 1 ⊆ U ∧ ContDiffOn ℝ ∞ (d.normalFrame Ψ) U := by
+  have hcenter :
+    Continuous (Smale.StripCoordinates.center : ℝ → Smale.StripCoordinates.Space A B) :=
+    (continuous_id.prodMk continuous_const).prodMk continuous_const
+  have hW : IsOpen (d.chart.source ∩ d.chart ⁻¹' Ψ.target) :=
+    d.chart.contMDiffOn_toFun.continuousOn.isOpen_inter_preimage d.chart.open_source Ψ.open_target
+  refine
+    ⟨Smale.StripCoordinates.center ⁻¹' (d.chart.source ∩ d.chart ⁻¹' Ψ.target),
+      hW.preimage hcenter, fun t ht => ⟨d.line ht, htarget t ht⟩, ?_⟩
+  exact d.contDiffOn_normalFrame Ψ
+
+private theorem Smale.StripNormalData.injective_normalFrame_of_strip_germ {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1) (hk : ContMDiffAt 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ k (t, 0))
+    {f : (ℝ × ℝ) → M} (hzero : ∀ x, Ψ (x, 0) = f x) {p : ℝ × ℝ} (hp : (p, 0) ∈ Ψ.source)
+    {c : (ℝ × ℝ) → (ℝ × ℝ)} (hc : ContDiffAt ℝ ∞ c p) (hcp : c p = (t, 0))
+    (hcs : Function.Surjective (fderiv ℝ c p)) (hgerm : f =ᶠ[𝓝 p] k ∘ c) :
+    Function.Injective (d.normalFrame Ψ t) := by
+  let T : Smale.StripCoordinates.Space A B →L[ℝ] E :=
+    mfderiv 𝓘(ℝ, Smale.StripCoordinates.Space A B) 𝓘(ℝ, E) d.chart
+      (Smale.StripCoordinates.center t)
+  let L : (ℝ × ℝ) →L[ℝ] Smale.StripCoordinates.Space A B := fderiv ℝ d.coordinateMap (t, 0)
+  let Q : E →L[ℝ] Z :=
+    mfderiv 𝓘(ℝ, E) 𝓘(ℝ, Z) (Smale.TransverseCoordinates.normalCoordinate Ψ) (f p)
+  let J : (ℝ × ℝ) →L[ℝ] E := mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) f p
+  let K : (ℝ × ℝ) →L[ℝ] E := mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) k (t, 0)
+  have hfp : f p = d.chart (Smale.StripCoordinates.center t) := by
+    have heq := hgerm.eq_of_nhds
+    dsimp only [Function.comp_apply] at heq
+    rw [hcp, d.center t] at heq
+    exact heq
+  have htarget : f p ∈ Ψ.target := by
+    have h := Ψ.map_source' hp
+    rwa [hzero p] at h
+  have hk' : ContMDiffAt 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ k (c p) := by
+    rw [hcp]
+    exact hk
+  have hdf :
+    mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) f p =
+      (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) k (t, 0)).comp (fderiv ℝ c p) := by
+    rw [hgerm.mfderiv_eq,
+      mfderiv_comp p (hk'.mdifferentiableAt (by simp))
+        (hc.contMDiffAt.mdifferentiableAt (by simp)),
+      hcp, mfderiv_eq_fderiv]
+    rfl
+  have hker : Q.ker = (T.comp L).range := by
+    have h1 : Q.ker = J.range :=
+      Smale.TransverseCoordinates.ker_normalDerivative_eq_range_zero_section Ψ hzero hp
+    have h2 : J.range = K.range := by
+      change (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) f p).range = K.range
+      rw [hdf]
+      exact LinearMap.range_comp_of_range_eq_top _ (LinearMap.range_eq_top.mpr hcs)
+    have h3 : K.range = (T.comp L).range := by
+      change (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) k (t, 0)).range = (T.comp L).range
+      rw [d.native_derivative_factor ht hk]
+      rfl
+    exact h1.trans (h2.trans h3)
+  have hT : Function.Injective T := (Smale.PartialChart.bijective_mfderiv d.chart (d.line ht)).1
+  have hinj :
+    Function.Injective ((Q.comp T).comp Smale.StripCoordinates.sheetTransverseInclusion) :=
+    Smale.StripCoordinates.injective_sheetTransverse_normalQuotient L (Q.comp T)
+      (d.horizontal_coordinateDerivative ht hk) (d.normal_coordinateDerivative_nonzero ht hk)
+      (Smale.StripCoordinates.ker_comp_eq_range_of_injective T L Q hT hker)
+  have hnormal :=
+    (Smale.TransverseCoordinates.contMDiffOn_normalCoordinate Ψ).contMDiffAt
+      (Ψ.open_target.mem_nhds htarget)
+  have hnormal' :
+    ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, Z) ∞ (Smale.TransverseCoordinates.normalCoordinate Ψ)
+      (d.chart (Smale.StripCoordinates.center t)) := by
+    rw [← hfp]
+    exact hnormal
+  have htransition :
+    fderiv ℝ (Smale.TransverseCoordinates.normalCoordinate Ψ ∘ d.chart)
+        (Smale.StripCoordinates.center t) =
+      Q.comp T := by
+    rw [← mfderiv_eq_fderiv,
+      mfderiv_comp (Smale.StripCoordinates.center t) (hnormal'.mdifferentiableAt (by simp))
+        (d.chart.mdifferentiableAt (by simp) (d.line ht))]
+    rw [← hfp]
+    rfl
+  change
+    Function.Injective
+      ((fderiv ℝ (Smale.TransverseCoordinates.normalCoordinate Ψ ∘ d.chart)
+            (Smale.StripCoordinates.center t)).comp
+        Smale.StripCoordinates.sheetTransverseInclusion)
+  rw [htransition]
+  exact hinj
+
+private def Smale.StripNormalData.sheetTransition {A B Z E M : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M} (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) :
+    (ℝ × A) → ((ℝ × ℝ) × Z) :=
+  (Ψ.symm ∘ d.chart) ∘ (ContinuousLinearMap.inl ℝ (ℝ × A) B)
+
+private def Smale.StripNormalData.sheetDifferential {A B Z E M : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M} (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) (t : ℝ) :
+    (ℝ × A) →L[ℝ] ((ℝ × ℝ) × Z) :=
+  fderiv ℝ (d.sheetTransition Ψ) (t, 0)
+
+private theorem Smale.StripNormalData.contDiffAt_tubularTransition {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1)
+    (htarget : d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target) :
+    ContDiffAt ℝ ∞ (Ψ.symm ∘ d.chart) (Smale.StripCoordinates.center t) :=
+  ((Ψ.contMDiffOn_invFun.contMDiffAt (Ψ.open_target.mem_nhds htarget)).comp
+      (Smale.StripCoordinates.center t)
+      (d.chart.contMDiffOn_toFun.contMDiffAt
+        (d.chart.open_source.mem_nhds (d.line ht)))).contDiffAt
+
+private theorem Smale.StripNormalData.contDiffAt_sheetTransition {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1)
+    (htarget : d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target) :
+    ContDiffAt ℝ ∞ (d.sheetTransition Ψ) (t, 0) :=
+  (d.contDiffAt_tubularTransition Ψ ht htarget).comp (t, 0)
+    (ContinuousLinearMap.inl ℝ (ℝ × A) B).contDiff.contDiffAt
+
+private theorem
+    Smale.StripNormalData.sheetDifferential_eq {A B Z E M : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M} (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1)
+    (htarget : d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target) :
+    d.sheetDifferential Ψ t =
+      (fderiv ℝ (Ψ.symm ∘ d.chart) (Smale.StripCoordinates.center t)).comp
+        (ContinuousLinearMap.inl ℝ (ℝ × A) B) := by
+  rw [sheetDifferential, sheetTransition,
+    fderiv_comp (t, 0) ((d.contDiffAt_tubularTransition Ψ ht htarget).differentiableAt (by simp))
+      (ContinuousLinearMap.inl ℝ (ℝ × A) B).differentiableAt,
+    (ContinuousLinearMap.inl ℝ (ℝ × A) B).fderiv]
+  rfl
+
+private theorem
+    Smale.StripNormalData.normal_sheetDifferential {A B Z E M : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M} (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1)
+    (htarget : d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target) :
+    (ContinuousLinearMap.snd ℝ (ℝ × ℝ) Z).comp
+        ((d.sheetDifferential Ψ t).comp (ContinuousLinearMap.inr ℝ ℝ A)) =
+      d.normalFrame Ψ t := by
+  have hn :
+    fderiv ℝ (Smale.TransverseCoordinates.normalCoordinate Ψ ∘ d.chart)
+        (Smale.StripCoordinates.center t) =
+      (ContinuousLinearMap.snd ℝ (ℝ × ℝ) Z).comp
+        (fderiv ℝ (Ψ.symm ∘ d.chart) (Smale.StripCoordinates.center t)) := by
+    change
+      fderiv ℝ ((ContinuousLinearMap.snd ℝ (ℝ × ℝ) Z) ∘ (Ψ.symm ∘ d.chart))
+          (Smale.StripCoordinates.center t) =
+        _
+    rw [fderiv_comp _ (ContinuousLinearMap.snd ℝ (ℝ × ℝ) Z).differentiableAt
+        ((d.contDiffAt_tubularTransition Ψ ht htarget).differentiableAt (by simp)),
+      (ContinuousLinearMap.snd ℝ (ℝ × ℝ) Z).fderiv]
+  rw [d.sheetDifferential_eq Ψ ht htarget, normalFrame, hn]
+  rfl
+
+private theorem Smale.StripNormalData.sheetTransition_center_germ {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) {f : (ℝ × ℝ) → M}
+    (hzero : ∀ p, Ψ (p, 0) = f p) {q : ℝ → (ℝ × ℝ)} {t : ℝ} (hq : ContinuousAt q t)
+    (hp : (q t, 0) ∈ Ψ.source) {c : (ℝ × ℝ) → (ℝ × ℝ)} (hcq : ∀ s, c (q s) = (s, 0))
+    (hgerm : f =ᶠ[𝓝 (q t)] k ∘ c) :
+    (fun s : ℝ => d.sheetTransition Ψ (s, 0)) =ᶠ[𝓝 t] fun s => (q s, 0) := by
+  have hs := (hq.prodMk continuousAt_const).preimage_mem_nhds (Ψ.open_source.mem_nhds hp)
+  filter_upwards [hs, hgerm.comp_tendsto hq.tendsto] with s hsource heq
+  dsimp only [Function.comp_apply] at heq
+  rw [hcq s] at heq
+  change Ψ.invFun (d.chart (Smale.StripCoordinates.center s)) = (q s, 0)
+  rw [← d.center s, ← heq, ← hzero (q s)]
+  exact Ψ.left_inv' hsource
+
+private theorem Smale.StripNormalData.sheetDifferential_arc_of_germ {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1) (htarget : d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target)
+    {q : ℝ → (ℝ × ℝ)} {v : ℝ × ℝ} (hq : HasDerivAt q v t)
+    (hgerm : (fun s : ℝ => d.sheetTransition Ψ (s, 0)) =ᶠ[𝓝 t] fun s => (q s, 0)) :
+    d.sheetDifferential Ψ t (1, 0) = (v, 0) := by
+  have hF := (d.contDiffAt_sheetTransition Ψ ht htarget).differentiableAt (by simp)
+  have hi : HasDerivAt (fun s : ℝ => (s, (0 : A))) (1, 0) t :=
+    (hasDerivAt_id t).prodMk (hasDerivAt_const t (0 : A))
+  have hd := hF.hasFDerivAt.comp_hasDerivAt t hi
+  have hq' : HasDerivAt (fun s => (q s, (0 : Z))) (v, 0) t :=
+    hq.prodMk (hasDerivAt_const t (0 : Z))
+  exact hd.unique (hq'.congr_of_eventuallyEq hgerm)
+
+private abbrev Smale.WhitneyPairModel.Plane :=
+  EuclideanSpace ℝ (Fin 2)
+
+private abbrev Smale.WhitneyPairModel.Space :=
+  (ℝ × ℝ) × (Plane × Plane)
+
+private abbrev Smale.WhitneyPairModel.Sheet :=
+  ℝ × Plane
+
+private def Smale.WhitneyPairModel.firstSheet (p : Sheet) : Space :=
+  ((p.1, 0), (p.2, 0))
+
+private def Smale.WhitneyPairModel.secondSheet (h : ℝ) (p : Sheet) : Space :=
+  ((p.1, h * (1 - p.1 ^ 2)), (0, p.2))
+
+private def Smale.WhitneyPairModel.bigon (h : ℝ) : Set (ℝ × ℝ) :=
+  {p | 0 ≤ p.2 ∧ h * p.1 ^ 2 + p.2 ≤ h}
+
+private def Smale.WhitneyPairModel.bigonEmbedding : (ℝ × ℝ) → Space := fun p => (p, (0, 0))
+
+private theorem Smale.WhitneyPairModel.isClosed_bigon (h : ℝ) : IsClosed (bigon h) :=
+  (isClosed_le continuous_const continuous_snd).inter
+    (isClosed_le (show Continuous (fun p : ℝ × ℝ => h * p.1 ^ 2 + p.2) by fun_prop)
+      continuous_const)
+
+private theorem
+    Smale.WhitneyPairModel.zero_mem_bigon {h : ℝ} (hh : 0 ≤ h) : (0 : ℝ × ℝ) ∈ bigon h := by
+  exact ⟨le_rfl, by simpa using hh⟩
+
+private theorem Smale.WhitneyPairModel.bigon_subset_rectangle {h : ℝ} (hh : 0 < h) :
+    bigon h ⊆ Set.Icc (-1 : ℝ) 1 ×ˢ Set.Icc (0 : ℝ) h := by
+  intro p hp
+  rcases hp with ⟨ht, hupper⟩
+  have hsq : p.1 ^ 2 ≤ 1 := by nlinarith
+  have hheight : p.2 ≤ h := by nlinarith [sq_nonneg p.1]
+  exact ⟨⟨by nlinarith, by nlinarith⟩, ht, hheight⟩
+
+private theorem Smale.WhitneyPairModel.isCompact_bigon {h : ℝ} (hh : 0 < h) : IsCompact (bigon h) :=
+  (CompactIccSpace.isCompact_Icc.prod CompactIccSpace.isCompact_Icc).of_isClosed_subset
+    (isClosed_bigon h) (bigon_subset_rectangle hh)
+
+private theorem Smale.WhitneyPairModel.mem_interior_bigon_iff (h : ℝ) (p : ℝ × ℝ) :
+    p ∈ interior (bigon h) ↔ 0 < p.2 ∧ p.2 < h * (1 - p.1 ^ 2) := by
+  constructor
+  · intro hp
+    obtain ⟨ε, hε, hball⟩ := Metric.mem_nhds_iff.mp (mem_interior_iff_mem_nhds.mp hp)
+    have hd (a : ℝ) : Dist.dist (p.1, p.2 + a) p = |a| := by simp [Prod.dist_eq]
+    have hm : (p.1, p.2 + (-ε / 2)) ∈ Metric.ball p ε := by
+      change Dist.dist (p.1, p.2 + (-ε / 2)) p < ε
+      rw [hd, abs_of_neg (by linarith)]
+      linarith
+    have hp' : (p.1, p.2 + ε / 2) ∈ Metric.ball p ε := by
+      change Dist.dist (p.1, p.2 + ε / 2) p < ε
+      rw [hd, abs_of_pos (by linarith)]
+      linarith
+    have hlo := (hball hm).1
+    have hhi := (hball hp').2
+    change 0 ≤ p.2 + (-ε / 2) at hlo
+    change h * p.1 ^ 2 + (p.2 + ε / 2) ≤ h at hhi
+    constructor <;> nlinarith
+  · rintro ⟨hlo, hhi⟩
+    let U : Set (ℝ × ℝ) := {q | 0 < q.2 ∧ h * q.1 ^ 2 + q.2 < h}
+    have hU : IsOpen U :=
+      (isOpen_lt continuous_const continuous_snd).inter
+        (isOpen_lt (show Continuous (fun q : ℝ × ℝ => h * q.1 ^ 2 + q.2) by fun_prop)
+          continuous_const)
+    have hpU : p ∈ U := ⟨hlo, by nlinarith⟩
+    exact
+      mem_interior_iff_mem_nhds.mpr
+        (Filter.mem_of_superset (hU.mem_nhds hpU) (fun _ hq => ⟨hq.1.le, hq.2.le⟩))
+
+private theorem Smale.WhitneyPairModel.mem_frontier_bigon_iff (h : ℝ) (p : ℝ × ℝ) :
+    p ∈ frontier (bigon h) ↔ p ∈ bigon h ∧ (p.2 = 0 ∨ p.2 = h * (1 - p.1 ^ 2)) := by
+  rw [frontier, (isClosed_bigon h).closure_eq, Set.mem_sdiff, mem_interior_bigon_iff]
+  constructor
+  · rintro ⟨hp, hnot⟩
+    refine ⟨hp, ?_⟩
+    by_cases ht : p.2 = 0
+    · exact Or.inl ht
+    · right
+      have hlo : 0 < p.2 := lt_of_le_of_ne hp.1 (Ne.symm ht)
+      have hhi : ¬p.2 < h * (1 - p.1 ^ 2) := fun hlt => hnot ⟨hlo, hlt⟩
+      have hupper := hp.2
+      change h * p.1 ^ 2 + p.2 ≤ h at hupper
+      nlinarith
+  · rintro ⟨hp, ht | ht⟩
+    · exact ⟨hp, fun hstrict => hstrict.1.ne' ht⟩
+    · exact ⟨hp, fun hstrict => hstrict.2.ne ht⟩
+
+private theorem Smale.WhitneyPairModel.starConvex_bigon {h : ℝ} (hh : 0 ≤ h) :
+    StarConvex ℝ (0 : ℝ × ℝ) (bigon h) := by
+  rw [starConvex_zero_iff]
+  intro p hp a ha₀ ha₁
+  rcases hp with ⟨ht, hupper⟩
+  change 0 ≤ a * p.2 ∧ h * (a * p.1) ^ 2 + a * p.2 ≤ h
+  refine ⟨mul_nonneg ha₀ ht, ?_⟩
+  calc
+    h * (a * p.1) ^ 2 + a * p.2 = a * (h * p.1 ^ 2 + p.2) - (a * (1 - a)) * (h * p.1 ^ 2) := by
+      ring
+    _ ≤ a * (h * p.1 ^ 2 + p.2) :=
+      (sub_le_self _
+        (mul_nonneg (mul_nonneg ha₀ (sub_nonneg.mpr ha₁)) (mul_nonneg hh (sq_nonneg _))))
+    _ ≤ a * h := (mul_le_mul_of_nonneg_left hupper ha₀)
+    _ ≤ h := by nlinarith
+
+private theorem Smale.WhitneyPairModel.lowerArc_mem_bigon {h s : ℝ} (hh : 0 ≤ h) (hs : |s| ≤ 1) :
+    (s, 0) ∈ bigon h := by
+  have habs := abs_le.mp hs
+  refine ⟨le_rfl, ?_⟩
+  change h * s ^ 2 + 0 ≤ h
+  have hsq : s ^ 2 ≤ 1 := by nlinarith
+  simpa only [mul_one, add_zero] using mul_le_mul_of_nonneg_left hsq hh
+
+private theorem Smale.WhitneyPairModel.upperArc_mem_bigon {h s : ℝ} (hh : 0 ≤ h) (hs : |s| ≤ 1) :
+    (s, h * (1 - s ^ 2)) ∈ bigon h := by
+  have habs := abs_le.mp hs
+  refine ⟨mul_nonneg hh (by nlinarith), ?_⟩
+  change h * s ^ 2 + h * (1 - s ^ 2) ≤ h
+  nlinarith
+
+private theorem Smale.WhitneyPairModel.exists_bigon_boundary_cover {h : ℝ} (hh : 0 < h)
+    {D E O : Set (ℝ × ℝ)} (hD : IsOpen D) (hE : IsOpen E) (hO : IsOpen O) (hleft : (-1, 0) ∈ O)
+    (hright : (1, 0) ∈ O) (hlower : Set.MapsTo (fun t : ℝ => (2 * t - 1, 0)) (Set.Icc 0 1) D)
+    (hupper : Set.MapsTo (fun t : ℝ => (2 * t - 1, h * (1 - (2 * t - 1) ^ 2))) (Set.Icc 0 1) E) :
+    ∃ U : Set (ℝ × ℝ),
+      ∃ V : Set (ℝ × ℝ),
+        IsOpen U ∧
+          IsOpen V ∧
+            U ⊆ D ∧
+              V ⊆ E ∧
+                U ∩ V ⊆ O ∧
+                  Set.MapsTo (fun t : ℝ => (2 * t - 1, 0)) (Set.Icc 0 1) U ∧
+                    Set.MapsTo (fun t : ℝ => (2 * t - 1, h * (1 - (2 * t - 1) ^ 2))) (Set.Icc 0 1)
+                        V ∧
+                      frontier (bigon h) ⊆ U ∪ V := by
+  let B : Set (ℝ × ℝ) := {p | p.2 < h * (1 - p.1 ^ 2) / 2}
+  let T : Set (ℝ × ℝ) := {p | h * (1 - p.1 ^ 2) / 2 < p.2}
+  have hB : IsOpen B := isOpen_lt continuous_snd (by fun_prop)
+  have hT : IsOpen T := isOpen_lt (by fun_prop) continuous_snd
+  let U := D ∩ (O ∪ B)
+  let V := E ∩ (O ∪ T)
+  have hU : IsOpen U := hD.inter (hO.union hB)
+  have hV : IsOpen V := hE.inter (hO.union hT)
+  have hheight {t : ℝ} (ht : t ∈ Set.Ioo (0 : ℝ) 1) : 0 < h * (1 - (2 * t - 1) ^ 2) := by
+    calc
+      0 < 4 * h * t * (1 - t) :=
+        mul_pos (mul_pos (mul_pos (by norm_num) hh) ht.1) (sub_pos.mpr ht.2)
+      _ = h * (1 - (2 * t - 1) ^ 2) := by ring
+  have hlowU : Set.MapsTo (fun t : ℝ => (2 * t - 1, 0)) (Set.Icc 0 1) U := by
+    intro t ht
+    refine ⟨hlower ht, ?_⟩
+    by_cases ht0 : t = 0
+    · subst t
+      exact Or.inl (by simpa using hleft)
+    by_cases ht1 : t = 1
+    · subst t
+      exact Or.inl (by convert hright using 1; norm_num)
+    right
+    have hh' := hheight ⟨lt_of_le_of_ne ht.1 (Ne.symm ht0), lt_of_le_of_ne ht.2 ht1⟩
+    change (0 : ℝ) < h * (1 - (2 * t - 1) ^ 2) / 2
+    linarith
+  have huppV : Set.MapsTo (fun t : ℝ => (2 * t - 1, h * (1 - (2 * t - 1) ^ 2))) (Set.Icc 0 1) V :=
+    by
+    intro t ht
+    refine ⟨hupper ht, ?_⟩
+    by_cases ht0 : t = 0
+    · subst t
+      exact Or.inl (by simpa using hleft)
+    by_cases ht1 : t = 1
+    · subst t
+      exact Or.inl (by convert hright using 1; norm_num)
+    right
+    have hh' := hheight ⟨lt_of_le_of_ne ht.1 (Ne.symm ht0), lt_of_le_of_ne ht.2 ht1⟩
+    change h * (1 - (2 * t - 1) ^ 2) / 2 < h * (1 - (2 * t - 1) ^ 2)
+    linarith
+  refine ⟨U, V, hU, hV, Set.inter_subset_left, Set.inter_subset_left, ?_, hlowU, huppV, ?_⟩
+  · intro p hp
+    rcases hp.1.2 with hpO | hpB
+    · exact hpO
+    rcases hp.2.2 with hpO | hpT
+    · exact hpO
+    have hpB' : p.2 < h * (1 - p.1 ^ 2) / 2 := hpB
+    have hpT' : h * (1 - p.1 ^ 2) / 2 < p.2 := hpT
+    exact (lt_asymm hpB' hpT').elim
+  · intro p hp
+    obtain ⟨hpK, hpedge⟩ := (mem_frontier_bigon_iff h p).mp hp
+    have hpr := bigon_subset_rectangle hh hpK
+    let t := (p.1 + 1) / 2
+    have ht : t ∈ Set.Icc (0 : ℝ) 1 := by
+      dsimp [t]
+      constructor <;> linarith [hpr.1.1, hpr.1.2]
+    have hbase : p.1 = 2 * t - 1 := by dsimp [t]; ring
+    rcases hpedge with hpzero | hpupper
+    · left
+      have heq : p = (2 * t - 1, 0) := Prod.ext hbase hpzero
+      rw [heq]
+      exact hlowU ht
+    · right
+      have heq : p = (2 * t - 1, h * (1 - (2 * t - 1) ^ 2)) := by
+        apply Prod.ext hbase
+        rw [← hbase]
+        exact hpupper
+      rw [heq]
+      exact huppV ht
+
+private def Smale.WhitneyPairModel.arcTime (p : ℝ × ℝ) : ℝ :=
+  (p.1 + 1) / 2
+
+private def Smale.WhitneyPairModel.leftCornerCoordinates (h : ℝ) (p : ℝ × ℝ) : ℝ × ℝ :=
+  (arcTime p - p.2 / (4 * h * (1 - arcTime p)), p.2 / (4 * h * (1 - arcTime p)))
+
+private theorem Smale.WhitneyPairModel.contDiff_arcTime : ContDiff ℝ ∞ arcTime := by
+  unfold arcTime
+  fun_prop
+
+private def Smale.WhitneyPairModel.bigonReflection : (ℝ × ℝ) ≃L[ℝ] (ℝ × ℝ) :=
+  (ContinuousLinearEquiv.neg ℝ : ℝ ≃L[ℝ] ℝ).prodCongr (ContinuousLinearEquiv.refl ℝ ℝ)
+
+private theorem Smale.WhitneyPairModel.bigonReflection_apply (p : ℝ × ℝ) :
+    bigonReflection p = (-p.1, p.2) :=
+  rfl
+
+private theorem Smale.WhitneyPairModel.arcTime_bigonReflection (p : ℝ × ℝ) :
+    arcTime (bigonReflection p) = 1 - arcTime p := by
+  dsimp [arcTime, bigonReflection]
+  ring
+
+private def Smale.WhitneyPairModel.rightCornerCoordinates (h : ℝ) : (ℝ × ℝ) → ℝ × ℝ :=
+  leftCornerCoordinates h ∘ bigonReflection
+
+private theorem
+    Smale.WhitneyPairModel.leftCornerCoordinates_exchange {h : ℝ} (hh : h ≠ 0) {p : ℝ × ℝ}
+    (hp : arcTime p ≠ 1) :
+    leftCornerCoordinates h (p.1, h * (1 - p.1 ^ 2) - p.2) = (leftCornerCoordinates h p).swap := by
+  have hd : 4 * h * (1 - arcTime p) ≠ 0 :=
+    mul_ne_zero (mul_ne_zero (by norm_num) hh) (sub_ne_zero.mpr (Ne.symm hp))
+  have hheight : h * (1 - p.1 ^ 2) = arcTime p * (4 * h * (1 - arcTime p)) := by
+    dsimp [arcTime]
+    ring
+  have hv :
+    (h * (1 - p.1 ^ 2) - p.2) / (4 * h * (1 - arcTime p)) =
+      arcTime p - p.2 / (4 * h * (1 - arcTime p)) := by
+    rw [sub_div, hheight, mul_div_cancel_right₀ _ hd]
+  apply Prod.ext
+  · change arcTime p - (h * (1 - p.1 ^ 2) - p.2) / (4 * h * (1 - arcTime p)) = _
+    rw [hv]
+    dsimp [leftCornerCoordinates]
+    ring
+  · exact hv
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Recognition/Smale7.lean b/LeanPool/HopfProblem/Recognition/Smale7.lean
new file mode 100644
index 000000000..b4943608e
--- /dev/null
+++ b/LeanPool/HopfProblem/Recognition/Smale7.lean
@@ -0,0 +1,5640 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Foundations.EuclideanSphere
+public import LeanPool.HopfProblem.Foundations.TwoOpenTransition
+import all LeanPool.HopfProblem.Recognition.Smale1
+import all LeanPool.HopfProblem.Recognition.Smale2
+import all LeanPool.HopfProblem.Recognition.Smale3
+import all LeanPool.HopfProblem.Recognition.Smale4
+import all LeanPool.HopfProblem.Recognition.Smale5
+import all LeanPool.HopfProblem.Recognition.Degree1
+import all LeanPool.HopfProblem.Recognition.Smale6
+import all LeanPool.HopfProblem.Foundations.EuclideanSphere
+import all LeanPool.HopfProblem.Foundations.TwoOpenTransition
+
+/-!
+# Hopf problem: recognition · smale 7
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def Smale.StripCoordinates.reverse (p : ℝ × ℝ) : ℝ × ℝ :=
+  (1 - p.1, p.2)
+
+private theorem Smale.StripCoordinates.contDiff_reverse : ContDiff ℝ ∞ reverse :=
+  (contDiff_const.sub contDiff_fst).prodMk contDiff_snd
+
+private theorem Smale.StripCoordinates.reverse_one_zero : reverse (1, 0) = (0, 0) := by
+  simp only [reverse, sub_self]
+
+private theorem
+    Smale.StripCoordinates.vertical_derivative_reverse {B : Type*} [NormedAddCommGroup B]
+    [NormedSpace ℝ B] {H : (ℝ × ℝ) → B} (hH : DifferentiableAt ℝ H (0, 0)) :
+    fderiv ℝ (H ∘ reverse) (1, 0) (0, 1) = fderiv ℝ H (0, 0) (0, 1) := by
+  have houter : DifferentiableAt ℝ H (reverse (1, 0)) := by
+    rw [reverse_one_zero]
+    exact hH
+  have hcomp : DifferentiableAt ℝ (H ∘ reverse) (1, 0) :=
+    houter.comp (1, 0) (contDiff_reverse.contDiffAt.differentiableAt (by simp))
+  have hleft := hasDerivAt_verticalSlice hcomp
+  have hright := hasDerivAt_verticalSlice hH
+  have heq : (fun s : ℝ => (H ∘ reverse) (1, s)) = fun s => H (0, s) := by
+    funext s
+    simp only [Function.comp_apply, reverse, sub_self]
+  rw [heq] at hleft
+  exact hleft.unique hright
+
+private def Smale.WhitneyPairModel.cornerTransition (t : ℝ) : ℝ :=
+  Real.smoothTransition (3 * t - 1)
+
+private def Smale.WhitneyPairModel.cornerScale (t : ℝ) : ℝ :=
+  (1 - cornerTransition t) * (1 - t) + cornerTransition t * t
+
+private def Smale.WhitneyPairModel.cornerSign (t : ℝ) : ℝ :=
+  2 * cornerTransition t - 1
+
+private theorem
+    Smale.WhitneyPairModel.contDiff_cornerTransition : ContDiff ℝ ∞ cornerTransition := by
+  unfold cornerTransition
+  exact Real.smoothTransition.contDiff.comp (by fun_prop)
+
+private theorem Smale.WhitneyPairModel.cornerTransition_zero {t : ℝ} (ht : t ≤ 1 / 3) :
+    cornerTransition t = 0 :=
+  Real.smoothTransition.zero_of_nonpos (by linarith)
+
+private theorem Smale.WhitneyPairModel.cornerTransition_one {t : ℝ} (ht : 2 / 3 ≤ t) :
+    cornerTransition t = 1 :=
+  Real.smoothTransition.one_of_one_le (by linarith)
+
+private theorem Smale.WhitneyPairModel.cornerScale_pos (t : ℝ) : 0 < cornerScale t := by
+  by_cases hlo : t ≤ 1 / 3
+  · simp only [cornerScale, cornerTransition_zero hlo, sub_zero, one_mul, MulZeroClass.zero_mul,
+      add_zero]
+    linarith
+  by_cases hhi : 2 / 3 ≤ t
+  · simp only [cornerScale, cornerTransition_one hhi, sub_self, MulZeroClass.zero_mul, one_mul,
+      zero_add]
+    linarith
+  have h0 : 0 ≤ cornerTransition t := Real.smoothTransition.nonneg _
+  have h1 : cornerTransition t ≤ 1 := Real.smoothTransition.le_one _
+  have ht0 : 0 < t := by linarith
+  have ht1 : 0 < 1 - t := by linarith
+  by_cases hβ : cornerTransition t = 0
+  · simp only [cornerScale, hβ, sub_zero, one_mul, MulZeroClass.zero_mul, add_zero]
+    exact ht1
+  · exact
+      add_pos_of_nonneg_of_pos (mul_nonneg (sub_nonneg.mpr h1) ht1.le)
+        (mul_pos (lt_of_le_of_ne h0 (Ne.symm hβ)) ht0)
+
+private theorem Smale.WhitneyPairModel.contDiff_cornerScale : ContDiff ℝ ∞ cornerScale := by
+  exact
+    ((contDiff_const.sub contDiff_cornerTransition).mul (contDiff_const.sub contDiff_id)).add
+      (contDiff_cornerTransition.mul contDiff_id)
+
+private theorem Smale.WhitneyPairModel.contDiff_cornerSign : ContDiff ℝ ∞ cornerSign :=
+  (contDiff_const.mul contDiff_cornerTransition).sub contDiff_const
+
+private def Smale.WhitneyPairModel.exchangeEdges (h : ℝ) (p : ℝ × ℝ) : ℝ × ℝ :=
+  (p.1, h * (1 - p.1 ^ 2) - p.2)
+
+private theorem
+    Smale.WhitneyPairModel.contDiff_exchangeEdges (h : ℝ) : ContDiff ℝ ∞ (exchangeEdges h) := by
+  unfold exchangeEdges
+  fun_prop
+
+private theorem Smale.WhitneyPairModel.exchangeEdges_involutive (h : ℝ) :
+    Function.Involutive (exchangeEdges h) := by
+  intro p
+  apply Prod.ext <;> dsimp [exchangeEdges]
+  ring
+
+private def Smale.WhitneyPairModel.lowerStripCoordinates (h : ℝ) (p : ℝ × ℝ) : ℝ × ℝ :=
+  (arcTime p + cornerSign (arcTime p) * (p.2 / (4 * h * cornerScale (arcTime p))),
+    p.2 / (4 * h * cornerScale (arcTime p)))
+
+private def Smale.WhitneyPairModel.upperStripCoordinates (h : ℝ) : (ℝ × ℝ) → ℝ × ℝ :=
+  lowerStripCoordinates h ∘ exchangeEdges h
+
+private theorem Smale.WhitneyPairModel.contDiff_lowerStripCoordinates {h : ℝ} (hh : h ≠ 0) :
+    ContDiff ℝ ∞ (lowerStripCoordinates h) := by
+  have hd : ContDiff ℝ ∞ (fun p : ℝ × ℝ => p.2 / (4 * h * cornerScale (arcTime p))) :=
+    contDiff_snd.div (contDiff_const.mul (contDiff_cornerScale.comp contDiff_arcTime))
+      (fun p => mul_ne_zero (mul_ne_zero (by norm_num) hh) (cornerScale_pos _).ne')
+  exact (contDiff_arcTime.add ((contDiff_cornerSign.comp contDiff_arcTime).mul hd)).prodMk hd
+
+private theorem Smale.WhitneyPairModel.contDiff_upperStripCoordinates {h : ℝ} (hh : h ≠ 0) :
+    ContDiff ℝ ∞ (upperStripCoordinates h) :=
+  (contDiff_lowerStripCoordinates hh).comp (contDiff_exchangeEdges h)
+
+private theorem Smale.WhitneyPairModel.lowerStripCoordinates_lower (h t : ℝ) :
+    lowerStripCoordinates h (2 * t - 1, 0) = (t, 0) := by
+  simp only [lowerStripCoordinates, arcTime, zero_div, MulZeroClass.mul_zero, add_zero]
+  congr 1
+  ring
+
+private theorem Smale.WhitneyPairModel.upperStripCoordinates_upper (h t : ℝ) :
+    upperStripCoordinates h (2 * t - 1, h * (1 - (2 * t - 1) ^ 2)) = (t, 0) := by
+  simp only [upperStripCoordinates, Function.comp_apply, exchangeEdges, sub_self]
+  exact lowerStripCoordinates_lower h t
+
+private theorem Smale.WhitneyPairModel.lowerStripCoordinates_left (h : ℝ) {p : ℝ × ℝ}
+    (hp : arcTime p ≤ 1 / 3) : lowerStripCoordinates h p = leftCornerCoordinates h p := by
+  simp [lowerStripCoordinates, cornerSign, cornerScale, cornerTransition_zero hp,
+    leftCornerCoordinates, sub_eq_add_neg]
+
+private theorem Smale.WhitneyPairModel.upperStripCoordinates_left {h : ℝ} (hh : h ≠ 0) {p : ℝ × ℝ}
+    (hp : arcTime p ≤ 1 / 3) : upperStripCoordinates h p = (leftCornerCoordinates h p).swap := by
+  have htime : arcTime (exchangeEdges h p) = arcTime p := rfl
+  have hp' : arcTime p ≠ 1 := by linarith
+  change lowerStripCoordinates h (exchangeEdges h p) = _
+  rw [lowerStripCoordinates_left h (htime ▸ hp)]
+  exact leftCornerCoordinates_exchange hh hp'
+
+private theorem Smale.WhitneyPairModel.lowerStripCoordinates_right (h : ℝ) {p : ℝ × ℝ}
+    (hp : 2 / 3 ≤ arcTime p) :
+    Smale.StripCoordinates.reverse (lowerStripCoordinates h p) = rightCornerCoordinates h p := by
+  have hden : 1 - arcTime (bigonReflection p) = arcTime p := by
+    rw [arcTime_bigonReflection]
+    ring
+  simp only [lowerStripCoordinates, cornerSign, cornerScale, cornerTransition_one hp, sub_self,
+    MulZeroClass.zero_mul, one_mul, zero_add]
+  norm_num only [mul_one, sub_self, sub_zero]
+  change
+    (1 - (arcTime p + 1 * (p.2 / (4 * h * arcTime p))), p.2 / (4 * h * arcTime p)) =
+      leftCornerCoordinates h (bigonReflection p)
+  simp only [leftCornerCoordinates]
+  rw [hden, arcTime_bigonReflection]
+  simp only [bigonReflection_apply]
+  apply Prod.ext
+  · dsimp
+    ring
+  · rfl
+
+private theorem Smale.WhitneyPairModel.upperStripCoordinates_right {h : ℝ} (hh : h ≠ 0) {p : ℝ × ℝ}
+    (hp : 2 / 3 ≤ arcTime p) :
+    Smale.StripCoordinates.reverse (upperStripCoordinates h p) =
+      (rightCornerCoordinates h p).swap := by
+  have htime : arcTime (exchangeEdges h p) = arcTime p := rfl
+  change Smale.StripCoordinates.reverse (lowerStripCoordinates h (exchangeEdges h p)) = _
+  rw [lowerStripCoordinates_right h (htime ▸ hp)]
+  have heq :
+    bigonReflection (exchangeEdges h p) =
+      ((bigonReflection p).1, h * (1 - (bigonReflection p).1 ^ 2) - (bigonReflection p).2) := by
+    simp only [bigonReflection_apply, exchangeEdges, neg_sq]
+  change leftCornerCoordinates h (bigonReflection (exchangeEdges h p)) = _
+  rw [heq]
+  apply leftCornerCoordinates_exchange hh
+  rw [arcTime_bigonReflection]
+  linarith
+
+private def Smale.TransverseCoordinates.cornerLinear {D Z : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] (u : D) (v : Z) :
+    (ℝ × ℝ) →L[ℝ] (D × Z) :=
+  ((ContinuousLinearMap.fst ℝ ℝ ℝ).smulRight u).prod ((ContinuousLinearMap.snd ℝ ℝ ℝ).smulRight v)
+
+private theorem Smale.TransverseCoordinates.cornerLinear_apply {D Z : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] (u : D) (v : Z) (p : ℝ × ℝ) :
+    cornerLinear u v p = (p.1 • u, p.2 • v) :=
+  rfl
+
+private theorem
+    Smale.TransverseCoordinates.injective_cornerLinear {D Z : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] {u : D} {v : Z} (hu : u ≠ 0)
+    (hv : v ≠ 0) : Function.Injective (cornerLinear u v) := by
+  intro p q hpq
+  exact
+    Prod.ext ((smul_left_injective ℝ hu) (congrArg Prod.fst hpq))
+      ((smul_left_injective ℝ hv) (congrArg Prod.snd hpq))
+
+private def
+    Smale.TransverseCoordinates.cornerMap {D Z : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, D × Z) 𝓘(ℝ, E) (D × Z) M ∞) (u : D) (v : Z) : (ℝ × ℝ) → M :=
+  Φ ∘ cornerLinear u v
+
+private theorem
+    Smale.TransverseCoordinates.contMDiffOn_cornerMap {D Z : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, D × Z) 𝓘(ℝ, E) (D × Z) M ∞) (u : D) (v : Z) :
+    ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ (cornerMap Φ u v) (cornerLinear u v ⁻¹' Φ.source) :=
+  Φ.contMDiffOn_toFun.comp (cornerLinear u v).contDiff.contMDiff.contMDiffOn (fun _ hx => hx)
+
+private theorem Smale.TransverseCoordinates.injOn_cornerMap {D Z : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, D × Z) 𝓘(ℝ, E) (D × Z) M ∞) {u : D} {v : Z} (hu : u ≠ 0)
+    (hv : v ≠ 0) : Set.InjOn (cornerMap Φ u v) (cornerLinear u v ⁻¹' Φ.source) := by
+  intro p hp q hq heq
+  exact injective_cornerLinear hu hv (Φ.toPartialEquiv.injOn hp hq heq)
+
+private theorem Smale.TransverseCoordinates.injective_mfderiv_cornerMap {D Z : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, D × Z) 𝓘(ℝ, E) (D × Z) M ∞) {u : D} {v : Z} (hu : u ≠ 0)
+    (hv : v ≠ 0) {p : ℝ × ℝ} (hp : p ∈ cornerLinear u v ⁻¹' Φ.source) :
+    Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) (cornerMap Φ u v) p) := by
+  have hL : ContMDiff 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, D × Z) ∞ (cornerLinear u v) :=
+    (cornerLinear u v).contDiff.contMDiff
+  rw [cornerMap,
+    mfderiv_comp p (Φ.mdifferentiableAt (by simp) hp) (hL.mdifferentiableAt (by simp)),
+    mfderiv_eq_fderiv, (cornerLinear u v).fderiv]
+  exact (Smale.PartialChart.bijective_mfderiv Φ hp).1.comp (injective_cornerLinear hu hv)
+
+private theorem Smale.exists_native_clean_corner_of_parametrizations {E M D Z N P A B : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [FiniteDimensional ℝ B] [TopologicalSpace N] [ChartedSpace D N]
+    [TopologicalSpace P] [ChartedSpace Z P] {F : N → M} {G : P → M}
+    (hF : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ F) (hG : ContMDiff 𝓘(ℝ, Z) 𝓘(ℝ, E) ∞ G)
+    (hembF : Topology.IsEmbedding F) (hembG : Topology.IsEmbedding G)
+    (c : PartialDiffeomorph 𝓘(ℝ, A) 𝓘(ℝ, D) A N ∞) (d : PartialDiffeomorph 𝓘(ℝ, B) 𝓘(ℝ, Z) B P ∞)
+    (hc0 : (0 : A) ∈ c.source) (hd0 : (0 : B) ∈ d.source) (hxy : G (d 0) = F (c 0))
+    (hdim : Module.finrank ℝ A + Module.finrank ℝ B = Module.finrank ℝ E)
+    (ht :
+      Function.Surjective
+        ((mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F (c 0)).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G (d 0))))
+    {u : A} {v : B} (hu : u ≠ 0) (hv : v ≠ 0) {O : Set M} (hO : IsOpen O) (hxO : F (c 0) ∈ O) :
+    ∃ W : Set (ℝ × ℝ),
+      IsOpen W ∧
+        (0 : ℝ × ℝ) ∈ W ∧
+          ∃ k : (ℝ × ℝ) → M,
+            ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ k W ∧
+              Set.InjOn k W ∧
+                Set.MapsTo k W O ∧
+                  k 0 = F (c 0) ∧
+                    (∀ p ∈ W, Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) k p)) ∧
+                      (∀ p ∈ W, (k p ∈ Set.range F ↔ p.2 = 0) ∧ (k p ∈ Set.range G ↔ p.1 = 0)) ∧
+                        (∀ s, (s, 0) ∈ W → k (s, 0) = F (c (s • u))) ∧
+                          (∀ t, (0, t) ∈ W → k (0, t) = G (d (t • v))) := by
+  obtain ⟨a, ha, Φ, hprod, _, htarget, hcenter, hleft, hright, himages⟩ :=
+    exists_clean_crossingChart_of_parametrizations hF hG hembF hembG c d hc0 hd0 hxy hdim ht hO
+      hxO
+  let L := TransverseCoordinates.cornerLinear u v
+  let W := L ⁻¹' Φ.source
+  let k := TransverseCoordinates.cornerMap Φ u v
+  have h0W : (0 : ℝ × ℝ) ∈ W := by
+    change L 0 ∈ Φ.source
+    rw [map_zero]
+    exact hprod ⟨Metric.mem_closedBall_self ha.le, Metric.mem_closedBall_self ha.le⟩
+  refine
+    ⟨W, Φ.open_source.preimage L.continuous, h0W, k,
+      TransverseCoordinates.contMDiffOn_cornerMap Φ u v,
+      TransverseCoordinates.injOn_cornerMap Φ hu hv, ?_, ?_, ?_, ?_, ?_, ?_⟩
+  · intro p hp
+    exact htarget (Φ.map_source' hp)
+  · change Φ (L 0) = F (c 0)
+    rw [map_zero]
+    exact hcenter
+  · intro p hp
+    exact TransverseCoordinates.injective_mfderiv_cornerMap Φ hu hv hp
+  · intro p hp
+    have him := himages (L p) hp
+    simpa only [L, k, TransverseCoordinates.cornerMap, Function.comp_apply,
+      TransverseCoordinates.cornerLinear_apply, smul_eq_zero, hu, hv, or_false] using him
+  · intro s hs
+    have haxis : (s • u, 0) ∈ Φ.source := by
+      change L (s, 0) ∈ Φ.source at hs
+      simpa only [L, TransverseCoordinates.cornerLinear_apply, zero_smul] using hs
+    simpa only [k, TransverseCoordinates.cornerMap, Function.comp_apply,
+      TransverseCoordinates.cornerLinear_apply, zero_smul] using hleft (s • u) haxis
+  · intro t ht
+    have haxis : (0, t • v) ∈ Φ.source := by
+      change L (0, t) ∈ Φ.source at ht
+      simpa only [L, TransverseCoordinates.cornerLinear_apply, zero_smul] using ht
+    simpa only [k, TransverseCoordinates.cornerMap, Function.comp_apply,
+      TransverseCoordinates.cornerLinear_apply, zero_smul] using hright (t • v) haxis
+
+private structure Smale.CleanCornerPatch {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] (S T : Set M) (a b : ℝ → M) where
+  domain : Set (ℝ × ℝ)
+  open_domain : IsOpen domain
+  contains_zero : (0 : ℝ × ℝ) ∈ domain
+  map : (ℝ × ℝ) → M
+  smooth : ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ map domain
+  injective : Set.InjOn map domain
+  derivative_injective : ∀ p ∈ domain, Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) map p)
+  sheets : ∀ p ∈ domain, (map p ∈ S ↔ p.2 = 0) ∧ (map p ∈ T ↔ p.1 = 0)
+  axis_first : ∀ t, (t, 0) ∈ domain → map (t, 0) = a t
+  axis_second : ∀ t, (0, t) ∈ domain → map (0, t) = b t
+
+private def Smale.CleanCornerPatch.swap {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S T : Set M} {a b : ℝ → M}
+    (c : Smale.CleanCornerPatch (E := E) S T a b) : Smale.CleanCornerPatch (E := E) T S b a := by
+  let e := ContinuousLinearEquiv.prodComm ℝ ℝ ℝ
+  have he : ContMDiff 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, ℝ × ℝ) ∞ (e : (ℝ × ℝ) → ℝ × ℝ) := e.contDiff.contMDiff
+  refine
+    { domain := e ⁻¹' c.domain
+      open_domain := c.open_domain.preimage e.continuous
+      contains_zero := ?_
+      map := c.map ∘ e
+      smooth := c.smooth.comp he.contMDiffOn (fun _ hp => hp)
+      injective := ?_
+      derivative_injective := ?_
+      sheets := fun p hp => ⟨(c.sheets (e p) hp).2, (c.sheets (e p) hp).1⟩
+      axis_first := fun t ht => c.axis_second t ht
+      axis_second := fun t ht => c.axis_first t ht }
+  · change e 0 ∈ c.domain
+    rw [map_zero]
+    exact c.contains_zero
+  · intro p hp q hq hpq
+    exact e.injective (c.injective hp hq hpq)
+  · intro p hp
+    have hc := c.smooth.contMDiffAt (c.open_domain.mem_nhds hp)
+    rw [mfderiv_comp p (hc.mdifferentiableAt (by simp)) (he.mdifferentiableAt (by simp))]
+    exact
+      (c.derivative_injective (e p) hp).comp
+        (Smale.PartialChart.bijective_mfderiv e.toDiffeomorph.toPartialDiffeomorph
+            (Set.mem_univ p)).1
+
+private structure Smale.CleanStripPatch {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] (S T : Set M) (a : ℝ → M) (k₀ k₁ : (ℝ × ℝ) → M) where
+  width : ℝ
+  width_pos : 0 < width
+  domain : Set (ℝ × ℝ)
+  open_domain : IsOpen domain
+  contains_strip : Set.Icc (0 : ℝ) 1 ×ˢ Set.Icc (-width) width ⊆ domain
+  map : (ℝ × ℝ) → M
+  smooth : ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ map domain
+  injective : Set.InjOn map domain
+  closed_embedding :
+    Topology.IsClosedEmbedding (fun p : Set.Icc (0 : ℝ) 1 ×ˢ Set.Icc (-width) width => map p)
+  derivative_injective : ∀ p ∈ domain, Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) map p)
+  first_sheet : ∀ p ∈ domain, map p ∈ S ↔ p.2 = 0
+  second_sheet : ∀ p ∈ domain, map p ∈ T ↔ p.1 = 0 ∨ p.1 = 1
+  center : ∀ t ∈ Set.Icc (0 : ℝ) 1, map (t, 0) = a t
+  left_germ : map =ᶠ[𝓝 (0, 0)] k₀
+  right_germ : map =ᶠ[𝓝 (1, 0)] k₁ ∘ StripCoordinates.reverse
+
+private theorem
+    Smale.bigon_strip_maps_left_germ {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {h : ℝ} (hh : h ≠ 0) {S T : Set M}
+    {a b a₀ b₀ a₁ b₁ : ℝ → M} (c₀ : CleanCornerPatch (E := E) S T a₀ b₀)
+    (c₁ : CleanCornerPatch (E := E) S T a₁ b₁) (k : CleanStripPatch (E := E) S T a c₀.map c₁.map)
+    (l : CleanStripPatch (E := E) T S b c₀.swap.map c₁.swap.map) :
+    k.map ∘ WhitneyPairModel.lowerStripCoordinates h =ᶠ[𝓝 (-1, 0)]
+      l.map ∘ WhitneyPairModel.upperStripCoordinates h := by
+  have hx : WhitneyPairModel.lowerStripCoordinates h (-1, 0) = (0, 0) := by
+    convert WhitneyPairModel.lowerStripCoordinates_lower h 0 using 1
+    norm_num
+  have hy : WhitneyPairModel.upperStripCoordinates h (-1, 0) = (0, 0) := by
+    convert WhitneyPairModel.upperStripCoordinates_upper h 0 using 1
+    norm_num
+  have hk :=
+    k.left_germ.comp_tendsto
+      (show Filter.Tendsto (WhitneyPairModel.lowerStripCoordinates h) (𝓝 (-1, 0)) (𝓝 (0, 0))
+        by
+        rw [← hx]
+        exact (WhitneyPairModel.contDiff_lowerStripCoordinates hh).continuous.continuousAt)
+  have hl :=
+    l.left_germ.comp_tendsto
+      (show Filter.Tendsto (WhitneyPairModel.upperStripCoordinates h) (𝓝 (-1, 0)) (𝓝 (0, 0))
+        by
+        rw [← hy]
+        exact (WhitneyPairModel.contDiff_upperStripCoordinates hh).continuous.continuousAt)
+  have hnear : ∀ᶠ p in 𝓝 ((-1 : ℝ), (0 : ℝ)), WhitneyPairModel.arcTime p ≤ 1 / 3 := by
+    have ht : WhitneyPairModel.arcTime (-1, 0) < 1 / 3 := by norm_num [WhitneyPairModel.arcTime]
+    exact
+      ((WhitneyPairModel.contDiff_arcTime.continuous.continuousAt).eventually_lt_const ht).mono
+        (fun _ hp => hp.le)
+  filter_upwards [hk, hl, hnear] with p hkp hlp hp
+  dsimp only [Function.comp_apply] at hkp hlp
+  change
+    k.map (WhitneyPairModel.lowerStripCoordinates h p) =
+      l.map (WhitneyPairModel.upperStripCoordinates h p)
+  rw [hkp, hlp, WhitneyPairModel.lowerStripCoordinates_left h hp,
+    WhitneyPairModel.upperStripCoordinates_left hh hp]
+  change
+    c₀.map (WhitneyPairModel.leftCornerCoordinates h p) =
+      c₀.map ((WhitneyPairModel.leftCornerCoordinates h p).swap.swap)
+  rw [Prod.swap_swap]
+
+private theorem
+    Smale.bigon_strip_maps_right_germ {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {h : ℝ} (hh : h ≠ 0) {S T : Set M}
+    {a b a₀ b₀ a₁ b₁ : ℝ → M} (c₀ : CleanCornerPatch (E := E) S T a₀ b₀)
+    (c₁ : CleanCornerPatch (E := E) S T a₁ b₁) (k : CleanStripPatch (E := E) S T a c₀.map c₁.map)
+    (l : CleanStripPatch (E := E) T S b c₀.swap.map c₁.swap.map) :
+    k.map ∘ WhitneyPairModel.lowerStripCoordinates h =ᶠ[𝓝 (1, 0)]
+      l.map ∘ WhitneyPairModel.upperStripCoordinates h := by
+  have hx : WhitneyPairModel.lowerStripCoordinates h (1, 0) = (1, 0) := by
+    convert WhitneyPairModel.lowerStripCoordinates_lower h 1 using 1
+    norm_num
+  have hy : WhitneyPairModel.upperStripCoordinates h (1, 0) = (1, 0) := by
+    convert WhitneyPairModel.upperStripCoordinates_upper h 1 using 1
+    norm_num
+  have hk :=
+    k.right_germ.comp_tendsto
+      (show Filter.Tendsto (WhitneyPairModel.lowerStripCoordinates h) (𝓝 (1, 0)) (𝓝 (1, 0))
+        by
+        have ht :=
+          (WhitneyPairModel.contDiff_lowerStripCoordinates hh).continuous.continuousAt (x :=
+            (1, 0))
+        rw [ContinuousAt, hx] at ht
+        exact ht)
+  have hl :=
+    l.right_germ.comp_tendsto
+      (show Filter.Tendsto (WhitneyPairModel.upperStripCoordinates h) (𝓝 (1, 0)) (𝓝 (1, 0))
+        by
+        have ht :=
+          (WhitneyPairModel.contDiff_upperStripCoordinates hh).continuous.continuousAt (x :=
+            (1, 0))
+        rw [ContinuousAt, hy] at ht
+        exact ht)
+  have hnear : ∀ᶠ p in 𝓝 ((1 : ℝ), (0 : ℝ)), 2 / 3 ≤ WhitneyPairModel.arcTime p := by
+    have ht : 2 / 3 < WhitneyPairModel.arcTime (1, 0) := by norm_num [WhitneyPairModel.arcTime]
+    exact
+      ((WhitneyPairModel.contDiff_arcTime.continuous.continuousAt).eventually_const_lt ht).mono
+        (fun _ hp => hp.le)
+  filter_upwards [hk, hl, hnear] with p hkp hlp hp
+  dsimp only [Function.comp_apply] at hkp hlp
+  change
+    k.map (WhitneyPairModel.lowerStripCoordinates h p) =
+      l.map (WhitneyPairModel.upperStripCoordinates h p)
+  rw [hkp, hlp]
+  change
+    c₁.map (StripCoordinates.reverse (WhitneyPairModel.lowerStripCoordinates h p)) =
+      c₁.map ((StripCoordinates.reverse (WhitneyPairModel.upperStripCoordinates h p)).swap)
+  rw [WhitneyPairModel.lowerStripCoordinates_right h hp,
+    WhitneyPairModel.upperStripCoordinates_right hh hp, Prod.swap_swap]
+
+private theorem
+    Smale.exists_smooth_open_gluing {E F X Y : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace X] [ChartedSpace E X] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [TopologicalSpace Y] [ChartedSpace F Y] {f g : X → Y} {U V : Set X} (hU : IsOpen U)
+    (hV : IsOpen V) (hf : ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, F) ∞ f U)
+    (hg : ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, F) ∞ g V) (hfg : Set.EqOn f g (U ∩ V)) :
+    ∃ k : X → Y, ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, F) ∞ k (U ∪ V) ∧ Set.EqOn k f U ∧ Set.EqOn k g V := by
+  classical
+  let k := U.piecewise f g
+  have hkf : Set.EqOn k f U := fun x hx => Set.piecewise_eq_of_mem U f g hx
+  have hkg : Set.EqOn k g V := by
+    intro x hx
+    by_cases hxU : x ∈ U
+    · exact (hkf hxU).trans (hfg ⟨hxU, hx⟩)
+    · exact Set.piecewise_eq_of_notMem U f g hxU
+  exact
+    ⟨k, (hf.congr (fun _ hx => hkf hx)).union_of_isOpen (hg.congr (fun _ hx => hkg hx)) hU hV,
+      hkf, hkg⟩
+
+private theorem Smale.exists_smooth_bigon_boundary_neighborhood {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {h : ℝ} (hh : 0 < h) {S T : Set M}
+    {a b a₀ b₀ a₁ b₁ : ℝ → M} (c₀ : CleanCornerPatch (E := E) S T a₀ b₀)
+    (c₁ : CleanCornerPatch (E := E) S T a₁ b₁) (k : CleanStripPatch (E := E) S T a c₀.map c₁.map)
+    (l : CleanStripPatch (E := E) T S b c₀.swap.map c₁.swap.map) :
+    ∃ U : Set (ℝ × ℝ),
+      ∃ V : Set (ℝ × ℝ),
+        IsOpen U ∧
+          IsOpen V ∧
+            frontier (WhitneyPairModel.bigon h) ⊆ U ∪ V ∧
+              Set.MapsTo (fun t : ℝ => (2 * t - 1, 0)) (Set.Icc 0 1) U ∧
+                Set.MapsTo (fun t : ℝ => (2 * t - 1, h * (1 - (2 * t - 1) ^ 2))) (Set.Icc 0 1) V ∧
+                  Set.MapsTo (WhitneyPairModel.lowerStripCoordinates h) U k.domain ∧
+                    Set.MapsTo (WhitneyPairModel.upperStripCoordinates h) V l.domain ∧
+                      ∃ f : (ℝ × ℝ) → M,
+                        ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ f (U ∪ V) ∧
+                          Set.EqOn f (k.map ∘ WhitneyPairModel.lowerStripCoordinates h) U ∧
+                            Set.EqOn f (l.map ∘ WhitneyPairModel.upperStripCoordinates h) V ∧
+                              (∀ t ∈ Set.Icc (0 : ℝ) 1, f (2 * t - 1, 0) = a t) ∧
+                                (∀ t ∈ Set.Icc (0 : ℝ) 1,
+                                  f (2 * t - 1, h * (1 - (2 * t - 1) ^ 2)) = b t) := by
+  let Dlo := WhitneyPairModel.lowerStripCoordinates h ⁻¹' k.domain
+  let Dhi := WhitneyPairModel.upperStripCoordinates h ⁻¹' l.domain
+  have hDlo : IsOpen Dlo :=
+    k.open_domain.preimage (WhitneyPairModel.contDiff_lowerStripCoordinates hh.ne').continuous
+  have hDhi : IsOpen Dhi :=
+    l.open_domain.preimage (WhitneyPairModel.contDiff_upperStripCoordinates hh.ne').continuous
+  have hkl :
+    ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ (k.map ∘ WhitneyPairModel.lowerStripCoordinates h) Dlo :=
+    k.smooth.comp (WhitneyPairModel.contDiff_lowerStripCoordinates hh.ne').contMDiff.contMDiffOn
+      (fun _ hp => hp)
+  have hlu :
+    ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ (l.map ∘ WhitneyPairModel.upperStripCoordinates h) Dhi :=
+    l.smooth.comp (WhitneyPairModel.contDiff_upperStripCoordinates hh.ne').contMDiff.contMDiffOn
+      (fun _ hp => hp)
+  obtain ⟨O₀, hO₀sub, hO₀, hleft⟩ := mem_nhds_iff.mp (bigon_strip_maps_left_germ hh.ne' c₀ c₁ k l)
+  obtain ⟨O₁, hO₁sub, hO₁, hright⟩ :=
+    mem_nhds_iff.mp (bigon_strip_maps_right_germ hh.ne' c₀ c₁ k l)
+  have hlowD : Set.MapsTo (fun t : ℝ => (2 * t - 1, 0)) (Set.Icc 0 1) Dlo := by
+    intro t ht
+    change WhitneyPairModel.lowerStripCoordinates h (2 * t - 1, 0) ∈ k.domain
+    rw [WhitneyPairModel.lowerStripCoordinates_lower]
+    exact k.contains_strip ⟨ht, neg_nonpos.mpr k.width_pos.le, k.width_pos.le⟩
+  have huppD :
+    Set.MapsTo (fun t : ℝ => (2 * t - 1, h * (1 - (2 * t - 1) ^ 2))) (Set.Icc 0 1) Dhi := by
+    intro t ht
+    change
+      WhitneyPairModel.upperStripCoordinates h (2 * t - 1, h * (1 - (2 * t - 1) ^ 2)) ∈ l.domain
+    rw [WhitneyPairModel.upperStripCoordinates_upper]
+    exact l.contains_strip ⟨ht, neg_nonpos.mpr l.width_pos.le, l.width_pos.le⟩
+  obtain ⟨U, V, hU, hV, hUD, hVD, hover, hlowU, huppV, hfront⟩ :=
+    WhitneyPairModel.exists_bigon_boundary_cover hh hDlo hDhi (hO₀.union hO₁) (Or.inl hleft)
+      (Or.inr hright) hlowD huppD
+  have hfg :
+    Set.EqOn (k.map ∘ WhitneyPairModel.lowerStripCoordinates h)
+      (l.map ∘ WhitneyPairModel.upperStripCoordinates h) (U ∩ V) := by
+    intro p hp
+    rcases hover hp with hp0 | hp1
+    · exact hO₀sub hp0
+    · exact hO₁sub hp1
+  obtain ⟨f, hf, hflo, hfhi⟩ := exists_smooth_open_gluing hU hV (hkl.mono hUD) (hlu.mono hVD) hfg
+  refine
+    ⟨U, V, hU, hV, hfront, hlowU, huppV, fun _ hp => hUD hp, fun _ hp => hVD hp, f, hf, hflo,
+      hfhi, ?_, ?_⟩
+  · intro t ht
+    rw [hflo (hlowU ht)]
+    change k.map (WhitneyPairModel.lowerStripCoordinates h (2 * t - 1, 0)) = a t
+    rw [WhitneyPairModel.lowerStripCoordinates_lower]
+    exact k.center t ht
+  · intro t ht
+    rw [hfhi (huppV ht)]
+    change
+      l.map (WhitneyPairModel.upperStripCoordinates h (2 * t - 1, h * (1 - (2 * t - 1) ^ 2))) =
+        b t
+    rw [WhitneyPairModel.upperStripCoordinates_upper]
+    exact l.center t ht
+
+private theorem Smale.StripCoordinates.injective_plane_of_horizontal_and_normal
+    (L : (ℝ × ℝ) →L[ℝ] (ℝ × ℝ)) (hh : L (1, 0) = (1, 0)) (hn : (L (0, 1)).2 ≠ 0) :
+    Function.Injective L := by
+  let i : (ℝ × ℝ) →L[ℝ] Space ℝ ℝ :=
+    ((ContinuousLinearMap.fst ℝ ℝ ℝ).prod 0).prod (ContinuousLinearMap.snd ℝ ℝ ℝ)
+  have hh' : (i.comp L) (1, 0) = Smale.StripCoordinates.center 1 := by
+    change i (L (1, 0)) = Smale.StripCoordinates.center 1
+    rw [hh]
+    rfl
+  have hi := injective_of_horizontal_and_normal (i.comp L) hh' hn
+  intro p q hpq
+  exact hi (congrArg i hpq)
+
+private def
+    Smale.StripCoordinates.detector {A B : Type*} [NormedAddCommGroup B] [InnerProductSpace ℝ B]
+    (v : ℝ → B) (F : (ℝ × ℝ) → Space A B) (p : ℝ × ℝ) : ℝ × ℝ :=
+  (p.1, ⟪v p.1, (F p).2⟫_ℝ)
+
+private theorem Smale.StripCoordinates.contDiff_detector {A B : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [InnerProductSpace ℝ B] {v : ℝ → B}
+    {F : (ℝ × ℝ) → Space A B} (hv : ContDiff ℝ ∞ v) (hF : ContDiff ℝ ∞ F) :
+    ContDiff ℝ ∞ (detector v F) :=
+  contDiff_fst.prodMk ((hv.comp contDiff_fst).inner ℝ hF.snd)
+
+private theorem Smale.StripCoordinates.detector_zero {A B : Type*} [NormedAddCommGroup A]
+    [NormedAddCommGroup B] [InnerProductSpace ℝ B] {v : ℝ → B} {F : (ℝ × ℝ) → Space A B}
+    (hc : ∀ t, F (t, 0) = Smale.StripCoordinates.center t) (t : ℝ) :
+    detector v F (t, 0) = (t, 0) := by
+  simp only [detector, hc, Smale.StripCoordinates.center, inner_zero_right]
+
+private theorem
+    Smale.StripCoordinates.detector_vertical_derivative {A B : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [InnerProductSpace ℝ B] {v : ℝ → B}
+    {F : (ℝ × ℝ) → Space A B} (hv : ContDiff ℝ ∞ v) (hF : ContDiff ℝ ∞ F)
+    (hn : ∀ t, normalDerivative F t = v t) (t : ℝ) :
+    fderiv ℝ (detector v F) (t, 0) (0, 1) = (0, ⟪v t, v t⟫_ℝ) := by
+  have hd : HasDerivAt (fun s : ℝ => (F (t, s)).2) (v t) 0 := by
+    have h :=
+      hasDerivAt_verticalSlice (t := t) (s := 0) (hF.snd.contDiffAt.differentiableAt (by simp))
+    change HasDerivAt _ (normalDerivative F t) 0 at h
+    rwa [hn t] at h
+  have hinner : HasDerivAt (fun s : ℝ => ⟪v t, (F (t, s)).2⟫_ℝ) (⟪v t, v t⟫_ℝ) 0 := by
+    simpa only [inner_zero_left, add_zero] using (hasDerivAt_const (0 : ℝ) (v t)).inner ℝ hd
+  have hslice : HasDerivAt (fun s : ℝ => detector v F (t, s)) (0, ⟪v t, v t⟫_ℝ) 0 :=
+    (hasDerivAt_const (0 : ℝ) t).prodMk hinner
+  exact
+    (hasDerivAt_verticalSlice
+          ((contDiff_detector hv hF).contDiffAt.differentiableAt (by simp))).unique
+      hslice
+
+private theorem Smale.StripCoordinates.injective_fderiv_detector_at_center {A B : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [InnerProductSpace ℝ B]
+    {v : ℝ → B} {F : (ℝ × ℝ) → Space A B} (hv : ContDiff ℝ ∞ v) (hF : ContDiff ℝ ∞ F)
+    (hc : ∀ t, F (t, 0) = Smale.StripCoordinates.center t) (hn : ∀ t, normalDerivative F t = v t)
+    {t : ℝ} (ht : v t ≠ 0) : Function.Injective (fderiv ℝ (detector v F) (t, 0)) := by
+  have hQ : DifferentiableAt ℝ (detector v F) (t, 0) :=
+    (contDiff_detector hv hF).contDiffAt.differentiableAt (by simp)
+  have hh : fderiv ℝ (detector v F) (t, 0) (1, 0) = (1, 0) := by
+    have hd := hasDerivAt_horizontalSlice hQ
+    have heq : (fun s : ℝ => detector v F (s, 0)) = fun s => (s, 0) := funext (detector_zero hc)
+    rw [heq] at hd
+    exact hd.unique ((hasDerivAt_id t).prodMk (hasDerivAt_const t (0 : ℝ)))
+  apply injective_plane_of_horizontal_and_normal _ hh
+  rw [detector_vertical_derivative hv hF hn t]
+  exact inner_self_ne_zero.mpr ht
+
+private theorem
+    Smale.WhitneyPairModel.lowerStripCoordinates_horizontal_derivative {h : ℝ} (hh : h ≠ 0)
+    (s : ℝ) : fderiv ℝ (lowerStripCoordinates h) (s, 0) (1, 0) = (1 / 2, 0) := by
+  have hf : DifferentiableAt ℝ (lowerStripCoordinates h) (s, 0) :=
+    (contDiff_lowerStripCoordinates hh).contDiffAt.differentiableAt (by simp)
+  have hd := Smale.StripCoordinates.hasDerivAt_horizontalSlice hf
+  have heq : (fun x : ℝ => lowerStripCoordinates h (x, 0)) = fun x => ((x + 1) / 2, 0) := by
+    funext x
+    simp [lowerStripCoordinates, arcTime]
+  rw [heq] at hd
+  exact
+    hd.unique (((hasDerivAt_id s).add_const 1).div_const 2 |>.prodMk (hasDerivAt_const s (0 : ℝ)))
+
+private theorem
+    Smale.WhitneyPairModel.lowerStripCoordinates_vertical_derivative {h : ℝ} (hh : h ≠ 0)
+    (s : ℝ) :
+    fderiv ℝ (lowerStripCoordinates h) (s, 0) (0, 1) =
+      (cornerSign ((s + 1) / 2) * (1 / (4 * h * cornerScale ((s + 1) / 2))),
+        1 / (4 * h * cornerScale ((s + 1) / 2))) := by
+  have hf : DifferentiableAt ℝ (lowerStripCoordinates h) (s, 0) :=
+    (contDiff_lowerStripCoordinates hh).contDiffAt.differentiableAt (by simp)
+  have hd := Smale.StripCoordinates.hasDerivAt_verticalSlice hf
+  have hdiv :
+    HasDerivAt (fun u : ℝ => u / (4 * h * cornerScale ((s + 1) / 2)))
+      (1 / (4 * h * cornerScale ((s + 1) / 2))) 0 :=
+    (hasDerivAt_id 0).div_const _
+  have hfirst := (HasDerivAt.const_mul (cornerSign ((s + 1) / 2)) hdiv).const_add ((s + 1) / 2)
+  exact hd.unique (hfirst.prodMk hdiv)
+
+private theorem Smale.WhitneyPairModel.injective_fderiv_lowerStripCoordinates {h : ℝ} (hh : h ≠ 0)
+    (s : ℝ) : Function.Injective (fderiv ℝ (lowerStripCoordinates h) (s, 0)) := by
+  let L := fderiv ℝ (lowerStripCoordinates h) (s, 0)
+  have hhor : ((2 : ℝ) • L) (1, 0) = (1, 0) := by
+    change (2 : ℝ) • (fderiv ℝ (lowerStripCoordinates h) (s, 0) (1, 0)) = (1, 0)
+    rw [lowerStripCoordinates_horizontal_derivative hh]
+    norm_num
+  have hnorm : (((2 : ℝ) • L) (0, 1)).2 ≠ 0 := by
+    change ((2 : ℝ) • (fderiv ℝ (lowerStripCoordinates h) (s, 0) (0, 1))).2 ≠ 0
+    rw [lowerStripCoordinates_vertical_derivative hh]
+    change (2 : ℝ) * (1 / (4 * h * cornerScale ((s + 1) / 2))) ≠ 0
+    exact
+      mul_ne_zero (by norm_num)
+        (one_div_ne_zero (mul_ne_zero (mul_ne_zero (by norm_num) hh) (cornerScale_pos _).ne'))
+  have hi :=
+    Smale.StripCoordinates.injective_plane_of_horizontal_and_normal ((2 : ℝ) • L) hhor hnorm
+  intro x y hxy
+  exact hi (congrArg (fun z : ℝ × ℝ => (2 : ℝ) • z) hxy)
+
+private theorem Smale.WhitneyPairModel.injective_fderiv_exchangeEdges (h : ℝ) (p : ℝ × ℝ) :
+    Function.Injective (fderiv ℝ (exchangeEdges h) p) := by
+  have heq : exchangeEdges h ∘ exchangeEdges h = id := funext (exchangeEdges_involutive h)
+  have hd :
+    (fderiv ℝ (exchangeEdges h) (exchangeEdges h p)).comp (fderiv ℝ (exchangeEdges h) p) =
+      ContinuousLinearMap.id ℝ (ℝ × ℝ) := by
+    rw [←
+      fderiv_comp p ((contDiff_exchangeEdges h).contDiffAt.differentiableAt (by simp))
+        ((contDiff_exchangeEdges h).contDiffAt.differentiableAt (by simp)),
+      heq, fderiv_id]
+  intro x y hxy
+  have he := congrArg (fderiv ℝ (exchangeEdges h) (exchangeEdges h p)) hxy
+  change
+    ((fderiv ℝ (exchangeEdges h) (exchangeEdges h p)).comp (fderiv ℝ (exchangeEdges h) p)) x =
+      ((fderiv ℝ (exchangeEdges h) (exchangeEdges h p)).comp (fderiv ℝ (exchangeEdges h) p))
+        y at he
+  rw [hd] at he
+  exact he
+
+private theorem Smale.WhitneyPairModel.injective_fderiv_upperStripCoordinates {h : ℝ} (hh : h ≠ 0)
+    (s : ℝ) : Function.Injective (fderiv ℝ (upperStripCoordinates h) (s, h * (1 - s ^ 2))) := by
+  rw [upperStripCoordinates,
+    fderiv_comp _ ((contDiff_lowerStripCoordinates hh).contDiffAt.differentiableAt (by simp))
+      ((contDiff_exchangeEdges h).contDiffAt.differentiableAt (by simp))]
+  have heq : exchangeEdges h (s, h * (1 - s ^ 2)) = (s, 0) := by
+    simp only [exchangeEdges, sub_self]
+  rw [heq]
+  exact (injective_fderiv_lowerStripCoordinates hh s).comp (injective_fderiv_exchangeEdges h _)
+
+private theorem Smale.WhitneyPairModel.mem_frontier_bigon_iff_exists_time {h : ℝ} (hh : 0 < h)
+    (p : ℝ × ℝ) :
+    p ∈ frontier (bigon h) ↔
+      ∃ t ∈ Set.Icc (0 : ℝ) 1, p = (2 * t - 1, 0) ∨ p = (2 * t - 1, h * (1 - (2 * t - 1) ^ 2)) := by
+  constructor
+  · intro hp
+    obtain ⟨hpK, hpedge⟩ := (mem_frontier_bigon_iff h p).mp hp
+    have hpr := bigon_subset_rectangle hh hpK
+    let t := (p.1 + 1) / 2
+    have ht : t ∈ Set.Icc (0 : ℝ) 1 := by
+      dsimp [t]
+      constructor <;> linarith [hpr.1.1, hpr.1.2]
+    have hbase : p.1 = 2 * t - 1 := by dsimp [t]; ring
+    refine ⟨t, ht, ?_⟩
+    rcases hpedge with hpzero | hpupper
+    · exact Or.inl (Prod.ext hbase hpzero)
+    · right
+      apply Prod.ext hbase
+      rw [← hbase]
+      exact hpupper
+  · rintro ⟨t, ht, rfl | rfl⟩
+    · apply (mem_frontier_bigon_iff h _).mpr
+      refine ⟨lowerArc_mem_bigon hh.le ?_, Or.inl rfl⟩
+      rw [abs_le]
+      constructor <;> linarith [ht.1, ht.2]
+    · apply (mem_frontier_bigon_iff h _).mpr
+      refine ⟨upperArc_mem_bigon hh.le ?_, Or.inr rfl⟩
+      rw [abs_le]
+      constructor <;> linarith [ht.1, ht.2]
+
+private theorem Smale.WhitneyPairModel.injOn_frontier_bigon_of_arcs {M : Type*} {h : ℝ} (hh : 0 < h)
+    {f : (ℝ × ℝ) → M} {a b : ℝ → M} (ha : Set.InjOn a (Set.Icc (0 : ℝ) 1))
+    (hb : Set.InjOn b (Set.Icc (0 : ℝ) 1))
+    (hlower : ∀ t ∈ Set.Icc (0 : ℝ) 1, f (2 * t - 1, 0) = a t)
+    (hupper : ∀ t ∈ Set.Icc (0 : ℝ) 1, f (2 * t - 1, h * (1 - (2 * t - 1) ^ 2)) = b t)
+    (hcoinc :
+      ∀ t ∈ Set.Icc (0 : ℝ) 1,
+        ∀ s ∈ Set.Icc (0 : ℝ) 1, a t = b s → (t = 0 ∧ s = 0) ∨ (t = 1 ∧ s = 1)) :
+    Set.InjOn f (frontier (bigon h)) := by
+  have hcross {t s : ℝ} (ht : t ∈ Set.Icc (0 : ℝ) 1) (hs : s ∈ Set.Icc (0 : ℝ) 1)
+    (heq : a t = b s) : (2 * t - 1, (0 : ℝ)) = (2 * s - 1, h * (1 - (2 * s - 1) ^ 2)) := by
+    rcases hcoinc t ht s hs heq with ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ <;> norm_num
+  intro p hp q hq heq
+  obtain ⟨t, ht, hp'⟩ := (mem_frontier_bigon_iff_exists_time hh p).mp hp
+  obtain ⟨s, hs, hq'⟩ := (mem_frontier_bigon_iff_exists_time hh q).mp hq
+  rcases hp' with rfl | rfl <;> rcases hq' with rfl | rfl
+  · rw [hlower t ht, hlower s hs] at heq
+    rw [ha ht hs heq]
+  · rw [hlower t ht, hupper s hs] at heq
+    exact hcross ht hs heq
+  · rw [hupper t ht, hlower s hs] at heq
+    exact (hcross hs ht heq.symm).symm
+  · rw [hupper t ht, hupper s hs] at heq
+    rw [hb ht hs heq]
+
+private theorem
+    Smale.CleanStripPatch.center_injOn {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S T : Set M} {a : ℝ → M} {k₀ k₁ : (ℝ × ℝ) → M}
+    (k : Smale.CleanStripPatch (E := E) S T a k₀ k₁) : Set.InjOn a (Set.Icc (0 : ℝ) 1) := by
+  intro t ht s hs heq
+  have h0 : (0 : ℝ) ∈ Set.Icc (-k.width) k.width :=
+    ⟨neg_nonpos.mpr k.width_pos.le, k.width_pos.le⟩
+  have htK : (t, 0) ∈ k.domain := k.contains_strip ⟨ht, h0⟩
+  have hsK : (s, 0) ∈ k.domain := k.contains_strip ⟨hs, h0⟩
+  have hmaps : k.map (t, 0) = k.map (s, 0) := by
+    rw [k.center t ht, k.center s hs]
+    exact heq
+  exact congrArg Prod.fst (k.injective htK hsK hmaps)
+
+private theorem
+    Smale.strip_center_coincidences_of_corner_overlap {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M} {a b : ℝ → M}
+    {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} (k : CleanStripPatch (E := E) S T a k₀ k₁)
+    (l : CleanStripPatch (E := E) T S b l₀ l₁)
+    (hover :
+      ∀ p ∈ k.domain,
+        ∀ q ∈ l.domain,
+          k.map p = l.map q →
+            p = q.swap ∨ StripCoordinates.reverse p = (StripCoordinates.reverse q).swap) :
+    ∀ t ∈ Set.Icc (0 : ℝ) 1,
+      ∀ s ∈ Set.Icc (0 : ℝ) 1, a t = b s → (t = 0 ∧ s = 0) ∨ (t = 1 ∧ s = 1) := by
+  intro t ht s hs heq
+  have hk0 : (0 : ℝ) ∈ Set.Icc (-k.width) k.width :=
+    ⟨neg_nonpos.mpr k.width_pos.le, k.width_pos.le⟩
+  have hl0 : (0 : ℝ) ∈ Set.Icc (-l.width) l.width :=
+    ⟨neg_nonpos.mpr l.width_pos.le, l.width_pos.le⟩
+  have hmaps : k.map (t, 0) = l.map (s, 0) := by rw [k.center t ht, l.center s hs]; exact heq
+  rcases hover (t, 0) (k.contains_strip ⟨ht, hk0⟩) (s, 0) (l.contains_strip ⟨hs, hl0⟩) hmaps with
+    hleft | hright
+  · exact Or.inl ⟨congrArg Prod.fst hleft, (congrArg Prod.snd hleft).symm⟩
+  · right
+    have ht' : 1 - t = 0 := congrArg Prod.fst hright
+    have hs' : 0 = 1 - s := congrArg Prod.snd hright
+    constructor <;> linarith
+
+private theorem Smale.injective_nativeDerivative_of_strip_germ {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M} {a : ℝ → M}
+    {k₀ k₁ : (ℝ × ℝ) → M} (k : CleanStripPatch (E := E) S T a k₀ k₁) {r : (ℝ × ℝ) → ℝ × ℝ}
+    (hr : ContDiff ℝ ∞ r) {f : (ℝ × ℝ) → M} {U : Set (ℝ × ℝ)} (hU : IsOpen U)
+    (heq : Set.EqOn f (k.map ∘ r) U) (hmap : Set.MapsTo r U k.domain) {p : ℝ × ℝ} (hp : p ∈ U)
+    (hi : Function.Injective (fderiv ℝ r p)) :
+    Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) f p) := by
+  have hgerm : f =ᶠ[𝓝 p] k.map ∘ r := Filter.mem_of_superset (hU.mem_nhds hp) (fun _ hx => heq hx)
+  rw [hgerm.mfderiv_eq]
+  have hk := k.smooth.contMDiffAt (k.open_domain.mem_nhds (hmap hp))
+  rw [mfderiv_comp p (hk.mdifferentiableAt (by simp)) (hr.contMDiff.mdifferentiableAt (by simp))]
+  have hri : Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, ℝ × ℝ) r p) := by
+    rw [mfderiv_eq_fderiv]
+    exact hi
+  exact (k.derivative_injective (r p) (hmap hp)).comp hri
+
+private theorem Smale.injective_nativeDerivative_bigon_boundary {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {h : ℝ} (hh : 0 < h) {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} (k : CleanStripPatch (E := E) S T a k₀ k₁)
+    (l : CleanStripPatch (E := E) T S b l₀ l₁) {f : (ℝ × ℝ) → M} {U V : Set (ℝ × ℝ)}
+    (hU : IsOpen U) (hV : IsOpen V)
+    (hlowU : Set.MapsTo (fun t : ℝ => (2 * t - 1, 0)) (Set.Icc 0 1) U)
+    (huppV : Set.MapsTo (fun t : ℝ => (2 * t - 1, h * (1 - (2 * t - 1) ^ 2))) (Set.Icc 0 1) V)
+    (hmapU : Set.MapsTo (WhitneyPairModel.lowerStripCoordinates h) U k.domain)
+    (hmapV : Set.MapsTo (WhitneyPairModel.upperStripCoordinates h) V l.domain)
+    (hflo : Set.EqOn f (k.map ∘ WhitneyPairModel.lowerStripCoordinates h) U)
+    (hfhi : Set.EqOn f (l.map ∘ WhitneyPairModel.upperStripCoordinates h) V) :
+    ∀ p ∈ frontier (WhitneyPairModel.bigon h),
+      Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) f p) := by
+  intro p hp
+  obtain ⟨t, ht, rfl | rfl⟩ := (WhitneyPairModel.mem_frontier_bigon_iff_exists_time hh p).mp hp
+  · exact
+      injective_nativeDerivative_of_strip_germ k
+        (WhitneyPairModel.contDiff_lowerStripCoordinates hh.ne') hU hflo hmapU (hlowU ht)
+        (WhitneyPairModel.injective_fderiv_lowerStripCoordinates hh.ne' _)
+  · exact
+      injective_nativeDerivative_of_strip_germ l
+        (WhitneyPairModel.contDiff_upperStripCoordinates hh.ne') hV hfhi hmapV (huppV ht)
+        (WhitneyPairModel.injective_fderiv_upperStripCoordinates hh.ne' _)
+
+private theorem
+    Smale.exists_embedded_bigon_boundary_neighborhood {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [FiniteDimensional ℝ E]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {h : ℝ} (hh : 0 < h) {S T : Set M} {a b : ℝ → M}
+    {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} (k : CleanStripPatch (E := E) S T a k₀ k₁)
+    (l : CleanStripPatch (E := E) T S b l₀ l₁)
+    (hover :
+      ∀ p ∈ k.domain,
+        ∀ q ∈ l.domain,
+          k.map p = l.map q →
+            p = q.swap ∨ StripCoordinates.reverse p = (StripCoordinates.reverse q).swap)
+    {f : (ℝ × ℝ) → M} {U V : Set (ℝ × ℝ)} (hU : IsOpen U) (hV : IsOpen V)
+    (hfront : frontier (WhitneyPairModel.bigon h) ⊆ U ∪ V)
+    (hlowU : Set.MapsTo (fun t : ℝ => (2 * t - 1, 0)) (Set.Icc 0 1) U)
+    (huppV : Set.MapsTo (fun t : ℝ => (2 * t - 1, h * (1 - (2 * t - 1) ^ 2))) (Set.Icc 0 1) V)
+    (hmapU : Set.MapsTo (WhitneyPairModel.lowerStripCoordinates h) U k.domain)
+    (hmapV : Set.MapsTo (WhitneyPairModel.upperStripCoordinates h) V l.domain)
+    (hf : ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ f (U ∪ V))
+    (hflo : Set.EqOn f (k.map ∘ WhitneyPairModel.lowerStripCoordinates h) U)
+    (hfhi : Set.EqOn f (l.map ∘ WhitneyPairModel.upperStripCoordinates h) V) :
+    ∃ W : Set (ℝ × ℝ),
+      IsOpen W ∧
+        frontier (WhitneyPairModel.bigon h) ⊆ W ∧
+          W ⊆ U ∪ V ∧
+            Set.InjOn f W ∧ ∀ p ∈ W, Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) f p) := by
+  have hlow : ∀ t ∈ Set.Icc (0 : ℝ) 1, f (2 * t - 1, 0) = a t := by
+    intro t ht
+    rw [hflo (hlowU ht)]
+    change k.map (WhitneyPairModel.lowerStripCoordinates h (2 * t - 1, 0)) = a t
+    rw [WhitneyPairModel.lowerStripCoordinates_lower]
+    exact k.center t ht
+  have hupp : ∀ t ∈ Set.Icc (0 : ℝ) 1, f (2 * t - 1, h * (1 - (2 * t - 1) ^ 2)) = b t := by
+    intro t ht
+    rw [hfhi (huppV ht)]
+    change
+      l.map (WhitneyPairModel.upperStripCoordinates h (2 * t - 1, h * (1 - (2 * t - 1) ^ 2))) =
+        b t
+    rw [WhitneyPairModel.upperStripCoordinates_upper]
+    exact l.center t ht
+  have hinj :=
+    WhitneyPairModel.injOn_frontier_bigon_of_arcs hh k.center_injOn l.center_injOn hlow hupp
+      (strip_center_coincidences_of_corner_overlap k l hover)
+  have hi :=
+    injective_nativeDerivative_bigon_boundary hh k l hU hV hlowU huppV hmapU hmapV hflo hfhi
+  have hcompact : IsCompact (frontier (WhitneyPairModel.bigon h)) :=
+    (WhitneyPairModel.isCompact_bigon hh).of_isClosed_subset isClosed_frontier
+      (fun p hp => ((WhitneyPairModel.mem_frontier_bigon_iff h p).mp hp).1)
+  exact
+    ManifoldImmersion.exists_open_embedded_immersive_neighborhood (hU.union hV) hf hcompact hfront
+      hinj hi
+
+private theorem Smale.WhitneyPairModel.interpolated_strip_time_mem_Ioo {h t β z J : ℝ} (hh : 0 < h)
+    (ht : t ∈ Set.Ioo (0 : ℝ) 1) (hβ : β ∈ Set.Icc (0 : ℝ) 1) (hJ : 0 < J)
+    (hJdef : J = (1 - β) * (1 - t) + β * t) (hz : 0 < z) (hzupper : z < 4 * h * t * (1 - t)) :
+    t + (2 * β - 1) * (z / (4 * h * J)) ∈ Set.Ioo (0 : ℝ) 1 := by
+  let H := 4 * h * t * (1 - t)
+  have hH : 0 < H := mul_pos (mul_pos (mul_pos (by norm_num) hh) ht.1) (sub_pos.mpr ht.2)
+  let θ := z / H
+  let e := t * β / J
+  have hθ0 : 0 < θ := div_pos hz hH
+  have hθ1 : θ < 1 := (div_lt_one hH).mpr hzupper
+  have he0 : 0 ≤ e := div_nonneg (mul_nonneg ht.1.le hβ.1) hJ.le
+  have he1 : e ≤ 1 := by
+    apply (div_le_one hJ).mpr
+    rw [hJdef]
+    have hr := mul_nonneg (sub_nonneg.mpr hβ.2) (sub_nonneg.mpr ht.2.le)
+    nlinarith
+  have hid : t + (2 * β - 1) * (z / (4 * h * J)) = (1 - θ) * t + θ * e := by
+    dsimp [θ, e, H]
+    field_simp [hh.ne', ht.1.ne', (sub_pos.mpr ht.2).ne', hJ.ne']
+    rw [hJdef]
+    ring
+  rw [hid]
+  constructor
+  · exact add_pos_of_pos_of_nonneg (mul_pos (sub_pos.mpr hθ1) ht.1) (mul_nonneg hθ0.le he0)
+  · have hpos : 0 < (1 - θ) * (1 - t) + θ * (1 - e) :=
+      add_pos_of_pos_of_nonneg (mul_pos (sub_pos.mpr hθ1) (sub_pos.mpr ht.2))
+        (mul_nonneg hθ0.le (sub_nonneg.mpr he1))
+    nlinarith
+
+private theorem
+    Smale.WhitneyPairModel.lowerStripCoordinates_interior {h : ℝ} (hh : 0 < h) {p : ℝ × ℝ}
+    (hp : p ∈ interior (bigon h)) :
+    (lowerStripCoordinates h p).1 ∈ Set.Ioo (0 : ℝ) 1 ∧ 0 < (lowerStripCoordinates h p).2 := by
+  obtain ⟨hp0, hphi⟩ := (mem_interior_bigon_iff h p).mp hp
+  have hheight : 0 < h * (1 - p.1 ^ 2) := hp0.trans hphi
+  have hsq : p.1 ^ 2 < 1 := by
+    have hpos : 0 < 1 - p.1 ^ 2 := (mul_pos_iff_of_pos_left hh).mp hheight
+    linarith
+  have ht : arcTime p ∈ Set.Ioo (0 : ℝ) 1 := by
+    dsimp [arcTime]
+    constructor <;> nlinarith [sq_nonneg (p.1 - 1), sq_nonneg (p.1 + 1)]
+  have hβ : cornerTransition (arcTime p) ∈ Set.Icc (0 : ℝ) 1 :=
+    ⟨Real.smoothTransition.nonneg _, Real.smoothTransition.le_one _⟩
+  have hheight_eq : h * (1 - p.1 ^ 2) = 4 * h * arcTime p * (1 - arcTime p) := by
+    dsimp [arcTime]
+    ring
+  have hzupper : p.2 < 4 * h * arcTime p * (1 - arcTime p) := hheight_eq ▸ hphi
+  refine ⟨?_, ?_⟩
+  · exact interpolated_strip_time_mem_Ioo hh ht hβ (cornerScale_pos _) rfl hp0 hzupper
+  · exact div_pos hp0 (mul_pos (mul_pos (by norm_num) hh) (cornerScale_pos _))
+
+private theorem Smale.WhitneyPairModel.exchangeEdges_mem_interior {h : ℝ} {p : ℝ × ℝ}
+    (hp : p ∈ interior (bigon h)) : exchangeEdges h p ∈ interior (bigon h) := by
+  obtain ⟨hp0, hphi⟩ := (mem_interior_bigon_iff h p).mp hp
+  apply (mem_interior_bigon_iff h _).mpr
+  change 0 < h * (1 - p.1 ^ 2) - p.2 ∧ h * (1 - p.1 ^ 2) - p.2 < h * (1 - p.1 ^ 2)
+  constructor <;> linarith
+
+private theorem
+    Smale.WhitneyPairModel.upperStripCoordinates_interior {h : ℝ} (hh : 0 < h) {p : ℝ × ℝ}
+    (hp : p ∈ interior (bigon h)) :
+    (upperStripCoordinates h p).1 ∈ Set.Ioo (0 : ℝ) 1 ∧ 0 < (upperStripCoordinates h p).2 :=
+  lowerStripCoordinates_interior hh (exchangeEdges_mem_interior hp)
+
+private theorem
+    Smale.CleanStripPatch.avoids_sheets {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S T : Set M} {a : ℝ → M} {k₀ k₁ : (ℝ × ℝ) → M}
+    (k : Smale.CleanStripPatch (E := E) S T a k₀ k₁) {p : ℝ × ℝ} (hp : p ∈ k.domain)
+    (ht : p.1 ∈ Set.Ioo (0 : ℝ) 1) (hn : p.2 ≠ 0) : k.map p ∉ S ∪ T := by
+  rintro (hS | hT)
+  · exact hn ((k.first_sheet p hp).mp hS)
+  · rcases (k.second_sheet p hp).mp hT with h0 | h1
+    · exact ht.1.ne' h0
+    · exact ht.2.ne h1
+
+private theorem Smale.bigon_boundary_map_avoids_sheets {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {h : ℝ} (hh : 0 < h) {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} (k : CleanStripPatch (E := E) S T a k₀ k₁)
+    (l : CleanStripPatch (E := E) T S b l₀ l₁) {f : (ℝ × ℝ) → M} {U V : Set (ℝ × ℝ)}
+    (hmapU : Set.MapsTo (WhitneyPairModel.lowerStripCoordinates h) U k.domain)
+    (hmapV : Set.MapsTo (WhitneyPairModel.upperStripCoordinates h) V l.domain)
+    (hflo : Set.EqOn f (k.map ∘ WhitneyPairModel.lowerStripCoordinates h) U)
+    (hfhi : Set.EqOn f (l.map ∘ WhitneyPairModel.upperStripCoordinates h) V) {p : ℝ × ℝ}
+    (hp : p ∈ U ∪ V) (hpi : p ∈ interior (WhitneyPairModel.bigon h)) : f p ∉ S ∪ T := by
+  rcases hp with hpU | hpV
+  · rw [hflo hpU]
+    have hc := WhitneyPairModel.lowerStripCoordinates_interior hh hpi
+    exact k.avoids_sheets (hmapU hpU) hc.1 hc.2.ne'
+  · rw [hfhi hpV]
+    have hc := WhitneyPairModel.upperStripCoordinates_interior hh hpi
+    change l.map (WhitneyPairModel.upperStripCoordinates h p) ∉ S ∪ T
+    rw [Set.union_comm]
+    exact l.avoids_sheets (hmapV hpV) hc.1 hc.2.ne'
+
+private structure Smale.CleanBigonBoundary {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] (S T : Set M) (a b : ℝ → M) (k l : (ℝ × ℝ) → M)
+    (h : ℝ) where
+  height_pos : 0 < h
+  map : (ℝ × ℝ) → M
+  domain : Set (ℝ × ℝ)
+  open_domain : IsOpen domain
+  smooth : ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ map domain
+  injective : Set.InjOn map domain
+  derivative_injective : ∀ p ∈ domain, Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) map p)
+  interior_avoids : ∀ p ∈ domain ∩ interior (WhitneyPairModel.bigon h), map p ∉ S ∪ T
+  closed_neighborhood : Set (ℝ × ℝ)
+  compact_neighborhood : IsCompact closed_neighborhood
+  closed_closed_neighborhood : IsClosed closed_neighborhood
+  boundary_covered : frontier (WhitneyPairModel.bigon h) ⊆ interior closed_neighborhood
+  neighborhood_subset : closed_neighborhood ⊆ domain
+  closed_embedding : Topology.IsClosedEmbedding (fun p : closed_neighborhood => map p)
+  clean :
+    ∀ p ∈ WhitneyPairModel.bigon h ∩ closed_neighborhood,
+      p ∉ frontier (WhitneyPairModel.bigon h) → map p ∉ S ∪ T
+  lower : ∀ t ∈ Set.Icc (0 : ℝ) 1, map (2 * t - 1, 0) = a t
+  upper : ∀ t ∈ Set.Icc (0 : ℝ) 1, map (2 * t - 1, h * (1 - (2 * t - 1) ^ 2)) = b t
+  lower_germ :
+    ∀ t ∈ Set.Icc (0 : ℝ) 1, map =ᶠ[𝓝 (2 * t - 1, 0)] k ∘ WhitneyPairModel.lowerStripCoordinates h
+  upper_germ :
+    ∀ t ∈ Set.Icc (0 : ℝ) 1,
+      map =ᶠ[𝓝 (2 * t - 1, h * (1 - (2 * t - 1) ^ 2))]
+        l ∘ WhitneyPairModel.upperStripCoordinates h
+
+private theorem Smale.exists_clean_bigon_boundary_neighborhood {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {h : ℝ} (hh : 0 < h) {S T : Set M}
+    {a b a₀ b₀ a₁ b₁ : ℝ → M} (c₀ : CleanCornerPatch (E := E) S T a₀ b₀)
+    (c₁ : CleanCornerPatch (E := E) S T a₁ b₁) (k : CleanStripPatch (E := E) S T a c₀.map c₁.map)
+    (l : CleanStripPatch (E := E) T S b c₀.swap.map c₁.swap.map)
+    (hover :
+      ∀ p ∈ k.domain,
+        ∀ q ∈ l.domain,
+          k.map p = l.map q →
+            p = q.swap ∨ StripCoordinates.reverse p = (StripCoordinates.reverse q).swap) :
+    ∃ f : (ℝ × ℝ) → M,
+      ∃ W : Set (ℝ × ℝ),
+        IsOpen W ∧
+          ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ f W ∧
+            Set.InjOn f W ∧
+              (∀ p ∈ W, Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) f p)) ∧
+                (∀ p ∈ W ∩ interior (WhitneyPairModel.bigon h), f p ∉ S ∪ T) ∧
+                  ∃ C : Set (ℝ × ℝ),
+                    IsCompact C ∧
+                      IsClosed C ∧
+                        frontier (WhitneyPairModel.bigon h) ⊆ interior C ∧
+                          C ⊆ W ∧
+                            Topology.IsClosedEmbedding (fun p : C => f p) ∧
+                              (∀ p ∈ WhitneyPairModel.bigon h ∩ C,
+                                  p ∉ frontier (WhitneyPairModel.bigon h) → f p ∉ S ∪ T) ∧
+                                (∀ t ∈ Set.Icc (0 : ℝ) 1, f (2 * t - 1, 0) = a t) ∧
+                                  (∀ t ∈ Set.Icc (0 : ℝ) 1,
+                                      f (2 * t - 1, h * (1 - (2 * t - 1) ^ 2)) = b t) ∧
+                                    (∀ t ∈ Set.Icc (0 : ℝ) 1,
+                                        f =ᶠ[𝓝 (2 * t - 1, 0)]
+                                          k.map ∘ WhitneyPairModel.lowerStripCoordinates h) ∧
+                                      (∀ t ∈ Set.Icc (0 : ℝ) 1,
+                                        f =ᶠ[𝓝 (2 * t - 1, h * (1 - (2 * t - 1) ^ 2))]
+                                          l.map ∘ WhitneyPairModel.upperStripCoordinates h) := by
+  obtain ⟨U, V, hU, hV, hfront, hlowU, huppV, hmapU, hmapV, f, hf, hflo, hfhi, hlow, hupp⟩ :=
+    exists_smooth_bigon_boundary_neighborhood hh c₀ c₁ k l
+  obtain ⟨W, hW, hfrontW, hWUV, hinj, hi⟩ :=
+    exists_embedded_bigon_boundary_neighborhood hh k l hover hU hV hfront hlowU huppV hmapU hmapV
+      hf hflo hfhi
+  have hclean : ∀ p ∈ W ∩ interior (WhitneyPairModel.bigon h), f p ∉ S ∪ T := fun p hp =>
+    bigon_boundary_map_avoids_sheets hh k l hmapU hmapV hflo hfhi (hWUV hp.1) hp.2
+  have hcompact : IsCompact (frontier (WhitneyPairModel.bigon h)) :=
+    (WhitneyPairModel.isCompact_bigon hh).of_isClosed_subset isClosed_frontier
+      (fun p hp => ((WhitneyPairModel.mem_frontier_bigon_iff h p).mp hp).1)
+  obtain ⟨C, hC, hCclosed, hfrontC, hCW⟩ := exists_compact_closed_between hcompact hW hfrontW
+  have hemb : Topology.IsClosedEmbedding (fun p : C => f p) := by
+    let : CompactSpace C := isCompact_iff_compactSpace.mp hC
+    have hc : Continuous (fun p : C => f p) :=
+      continuousOn_iff_continuous_domRestrict.mp (hf.continuousOn.mono (hCW.trans hWUV))
+    apply hc.isClosedEmbedding
+    intro p q hpq
+    exact Subtype.ext (hinj (hCW p.property) (hCW q.property) hpq)
+  refine
+    ⟨f, W, hW, hf.mono hWUV, hinj, hi, hclean, C, hC, hCclosed, hfrontC, hCW, hemb, ?_, hlow,
+      hupp, ?_, ?_⟩
+  · intro p hp hnot
+    apply hclean p ⟨hCW hp.2, ?_⟩
+    by_contra hni
+    apply hnot
+    rw [frontier, (WhitneyPairModel.isClosed_bigon h).closure_eq]
+    exact ⟨hp.1, hni⟩
+  · intro t ht
+    exact Filter.mem_of_superset (hU.mem_nhds (hlowU ht)) (fun _ hp => hflo hp)
+  · intro t ht
+    exact Filter.mem_of_superset (hV.mem_nhds (huppV ht)) (fun _ hp => hfhi hp)
+
+private theorem
+    Smale.nonempty_cleanBigonBoundary {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    [T2Space M] {h : ℝ} (hh : 0 < h) {S T : Set M} {a b a₀ b₀ a₁ b₁ : ℝ → M}
+    (c₀ : CleanCornerPatch (E := E) S T a₀ b₀) (c₁ : CleanCornerPatch (E := E) S T a₁ b₁)
+    (k : CleanStripPatch (E := E) S T a c₀.map c₁.map)
+    (l : CleanStripPatch (E := E) T S b c₀.swap.map c₁.swap.map)
+    (hover :
+      ∀ p ∈ k.domain,
+        ∀ q ∈ l.domain,
+          k.map p = l.map q →
+            p = q.swap ∨ StripCoordinates.reverse p = (StripCoordinates.reverse q).swap) :
+    Nonempty (CleanBigonBoundary (E := E) S T a b k.map l.map h) := by
+  obtain
+    ⟨f, W, hW, hf, hinj, hi, havoid, C, hC, hCc, hfront, hCW, hemb, hclean, hlow, hupp, hlowg,
+      huppg⟩ :=
+    exists_clean_bigon_boundary_neighborhood hh c₀ c₁ k l hover
+  exact
+    ⟨{  height_pos := hh
+        map := f
+        domain := W
+        open_domain := hW
+        smooth := hf
+        injective := hinj
+        derivative_injective := hi
+        interior_avoids := havoid
+        closed_neighborhood := C
+        compact_neighborhood := hC
+        closed_closed_neighborhood := hCc
+        boundary_covered := hfront
+        neighborhood_subset := hCW
+        closed_embedding := hemb
+        clean := hclean
+        lower := hlow
+        upper := hupp
+        lower_germ := hlowg
+        upper_germ := huppg }⟩
+
+private def Smale.DiskCone.point {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (p : unitInterval × Metric.sphere (0 : E) 1) : Metric.closedBall (0 : E) 1 :=
+  ⟨(1 - (p.1 : ℝ)) • (p.2 : E),
+    by
+    rw [mem_closedBall_zero_iff, norm_smul, Real.norm_eq_abs,
+      abs_of_nonneg (sub_nonneg.mpr p.1.2.2), mem_sphere_zero_iff_norm.mp p.2.property, mul_one]
+    linarith [p.1.2.1]⟩
+
+private theorem Smale.DiskCone.norm_point {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (p : unitInterval × Metric.sphere (0 : E) 1) : ‖(point p : E)‖ = 1 - (p.1 : ℝ) := by
+  change ‖(1 - (p.1 : ℝ)) • (p.2 : E)‖ = _
+  rw [norm_smul, Real.norm_eq_abs, abs_of_nonneg (sub_nonneg.mpr p.1.2.2),
+    mem_sphere_zero_iff_norm.mp p.2.property, mul_one]
+
+private theorem
+    Smale.DiskCone.continuous_point {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] :
+    Continuous (point (E := E)) := by
+  apply Continuous.subtype_mk
+  exact
+    (continuous_const.sub (continuous_subtype_val.comp continuous_fst)).smul
+      (continuous_subtype_val.comp continuous_snd)
+
+private theorem Smale.DiskCone.point_fibers {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    {p q : unitInterval × Metric.sphere (0 : E) 1} (hpq : point p = point q) :
+    p = q ∨ (p.1 = 1 ∧ q.1 = 1) := by
+  have hnorm := congrArg (fun x : Metric.closedBall (0 : E) 1 => ‖(x : E)‖) hpq
+  rw [norm_point, norm_point] at hnorm
+  have ht : p.1 = q.1 := Subtype.ext (by linarith)
+  rcases p with ⟨t, x⟩
+  rcases q with ⟨s, y⟩
+  dsimp only at ht
+  subst s
+  by_cases htop : t = 1
+  · exact Or.inr ⟨htop, htop⟩
+  · have htval : (t : ℝ) ≠ 1 := fun heq => htop (Subtype.ext heq)
+    have hnonzero : 1 - (t : ℝ) ≠ 0 := sub_ne_zero.mpr (Ne.symm htval)
+    have hvec : (1 - (t : ℝ)) • (x : E) = (1 - (t : ℝ)) • (y : E) := congrArg Subtype.val hpq
+    have hxy : x = y := Subtype.ext ((smul_right_injective E hnonzero) hvec)
+    exact Or.inl (congrArg (fun z => (t, z)) hxy)
+
+private theorem Smale.DiskCone.surjective_point {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [Nonempty (Metric.sphere (0 : E) 1)] : Function.Surjective (point (E := E)) := by
+  intro x
+  by_cases hx : (x : E) = 0
+  · refine ⟨(1, Classical.choice inferInstance), ?_⟩
+    apply Subtype.ext
+    change (1 - (1 : ℝ)) • _ = (x : E)
+    rw [sub_self, zero_smul, hx]
+  · have hxnorm : ‖(x : E)‖ ≤ 1 := mem_closedBall_zero_iff.mp x.property
+    let t : unitInterval :=
+      ⟨1 - ‖(x : E)‖, sub_nonneg.mpr hxnorm, by linarith [norm_nonneg (x : E)]⟩
+    refine ⟨(t, Smale.RadialExtension.direction (x : E) hx), ?_⟩
+    apply Subtype.ext
+    change (1 - (1 - ‖(x : E)‖)) • (‖(x : E)‖⁻¹ • (x : E)) = (x : E)
+    rw [sub_sub_cancel, smul_inv_smul₀ (norm_ne_zero_iff.mpr hx)]
+
+private theorem
+    Smale.DiskCone.isQuotientMap_point {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [Nonempty (Metric.sphere (0 : E) 1)] [FiniteDimensional ℝ E] :
+    Topology.IsQuotientMap (point (E := E)) := by
+  let : CompactSpace (Metric.sphere (0 : E) 1) :=
+    isCompact_iff_compactSpace.mp (isCompact_sphere _ _)
+  exact .of_surjective_continuous surjective_point continuous_point
+
+private theorem Smale.DiskCone.homotopy_eq_of_point_eq {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] (f : C(Metric.sphere (0 : E) 1, M)) (c : M)
+    (H : f.Homotopy (ContinuousMap.const _ c)) {p q : unitInterval × Metric.sphere (0 : E) 1}
+    (hpq : point p = point q) : H p = H q := by
+  rcases point_fibers hpq with h | ⟨hp, hq⟩
+  · exact congrArg H h
+  · have hp' : p = (1, p.2) := Prod.ext hp rfl
+    have hq' : q = (1, q.2) := Prod.ext hq rfl
+    rw [hp', hq', H.apply_one, H.apply_one]
+    rfl
+
+private def Smale.DiskCone.extensionFun {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [Nonempty (Metric.sphere (0 : E) 1)] (f : C(Metric.sphere (0 : E) 1, M))
+    (c : M) (H : f.Homotopy (ContinuousMap.const _ c)) (x : Metric.closedBall (0 : E) 1) : M :=
+  H (Function.surjInv surjective_point x)
+
+private theorem
+    Smale.DiskCone.extensionFun_point {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [Nonempty (Metric.sphere (0 : E) 1)] (f : C(Metric.sphere (0 : E) 1, M))
+    (c : M) (H : f.Homotopy (ContinuousMap.const _ c))
+    (p : unitInterval × Metric.sphere (0 : E) 1) : extensionFun f c H (point p) = H p :=
+  homotopy_eq_of_point_eq f c H (Function.surjInv_eq surjective_point (point p))
+
+private def Smale.DiskCone.extension {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [Nonempty (Metric.sphere (0 : E) 1)] (f : C(Metric.sphere (0 : E) 1, M))
+    (c : M) (H : f.Homotopy (ContinuousMap.const _ c)) [FiniteDimensional ℝ E] :
+    C(Metric.closedBall (0 : E) 1, M)
+    where
+  toFun := extensionFun f c H
+  continuous_toFun := by
+    apply isQuotientMap_point.continuous_iff.mpr
+    have heq : extensionFun f c H ∘ point = H := funext (extensionFun_point f c H)
+    rw [heq]
+    exact H.continuous
+
+private theorem
+    Smale.DiskCone.extension_boundary {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [Nonempty (Metric.sphere (0 : E) 1)] (f : C(Metric.sphere (0 : E) 1, M))
+    (c : M) (H : f.Homotopy (ContinuousMap.const _ c)) [FiniteDimensional ℝ E]
+    (x : Metric.sphere (0 : E) 1) :
+    extension f c H ⟨x, Metric.sphere_subset_closedBall x.property⟩ = f x := by
+  have heq :
+    (⟨(x : E), Metric.sphere_subset_closedBall x.property⟩ : Metric.closedBall (0 : E) 1) =
+      point (0, x) := by
+    apply Subtype.ext
+    change (x : E) = (1 - (0 : ℝ)) • (x : E)
+    rw [sub_zero, one_smul]
+  change extensionFun f c H _ = f x
+  rw [heq, extensionFun_point, H.apply_zero]
+
+private theorem Smale.DiskCone.extension_zero {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [Nonempty (Metric.sphere (0 : E) 1)] (f : C(Metric.sphere (0 : E) 1, M))
+    (c : M) (H : f.Homotopy (ContinuousMap.const _ c)) [FiniteDimensional ℝ E] :
+    extension f c H ⟨0, Metric.mem_closedBall_self zero_le_one⟩ = c := by
+  let x : Metric.sphere (0 : E) 1 := Classical.choice inferInstance
+  have heq :
+    (⟨0, Metric.mem_closedBall_self zero_le_one⟩ : Metric.closedBall (0 : E) 1) = point (1, x) := by
+    apply Subtype.ext
+    change (0 : E) = (1 - (1 : ℝ)) • (x : E)
+    rw [sub_self, zero_smul]
+  change extensionFun f c H _ = c
+  rw [heq, extensionFun_point, H.apply_one]
+  rfl
+
+private def
+    Smale.AnnularExtension.unitClamp {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] (a : ℝ)
+    (x : E) : E :=
+  (Max.max a ‖x‖)⁻¹ • x
+
+private theorem Smale.AnnularExtension.max_radius_pos {E : Type*} [NormedAddCommGroup E] {a : ℝ}
+    (ha : 0 < a) (x : E) : 0 < Max.max a ‖x‖ :=
+  ha.trans_le (le_max_left _ _)
+
+private theorem Smale.AnnularExtension.continuous_unitClamp {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {a : ℝ} (ha : 0 < a) : Continuous (unitClamp (E := E) a) :=
+  ((continuous_const.max continuous_norm).inv₀ (fun x => (max_radius_pos ha x).ne')).smul
+    continuous_id
+
+private theorem
+    Smale.AnnularExtension.norm_unitClamp {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    {a : ℝ} (ha : 0 < a) (x : E) : ‖unitClamp a x‖ = ‖x‖ / Max.max a ‖x‖ := by
+  rw [unitClamp, norm_smul, Real.norm_eq_abs, abs_of_pos (inv_pos.mpr (max_radius_pos ha x)),
+    div_eq_mul_inv, mul_comm]
+
+private theorem Smale.AnnularExtension.norm_unitClamp_le {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {a : ℝ} (ha : 0 < a) (x : E) : ‖unitClamp a x‖ ≤ 1 := by
+  rw [norm_unitClamp ha]
+  exact (div_le_one (max_radius_pos ha x)).mpr (le_max_right _ _)
+
+private def
+    Smale.AnnularExtension.innerDisk {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] {a : ℝ}
+    (ha : 0 < a) : C(E, Metric.closedBall (0 : E) 1)
+    where
+  toFun x := ⟨unitClamp a x, mem_closedBall_zero_iff.mpr (norm_unitClamp_le ha x)⟩
+  continuous_toFun := (continuous_unitClamp ha).subtype_mk _
+
+private theorem Smale.AnnularExtension.unitClamp_of_norm_le {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {a : ℝ} {x : E} (hx : ‖x‖ ≤ a) : unitClamp a x = a⁻¹ • x := by
+  rw [unitClamp, max_eq_left hx]
+
+private def
+    Smale.AnnularExtension.clamp {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] (a : ℝ)
+    (x : E) : E :=
+  a • unitClamp a x
+
+private theorem Smale.AnnularExtension.continuous_clamp {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {a : ℝ} (ha : 0 < a) : Continuous (clamp (E := E) a) :=
+  continuous_const.smul (continuous_unitClamp ha)
+
+private theorem Smale.AnnularExtension.clamp_of_norm_le {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {a : ℝ} (ha : 0 < a) {x : E} (hx : ‖x‖ ≤ a) : clamp a x = x := by
+  rw [clamp, unitClamp_of_norm_le hx, smul_inv_smul₀ ha.ne']
+
+private theorem
+    Smale.AnnularExtension.norm_clamp {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    {a : ℝ} (ha : 0 < a) (x : E) : ‖clamp a x‖ = Min.min a ‖x‖ := by
+  by_cases hx : ‖x‖ ≤ a
+  · rw [clamp_of_norm_le ha hx, min_eq_right hx]
+  · have hx' : a ≤ ‖x‖ := le_of_not_ge hx
+    have hnorm : ‖x‖ ≠ 0 := (ha.trans_le hx').ne'
+    rw [clamp, norm_smul, Real.norm_eq_abs, abs_of_pos ha, norm_unitClamp ha, max_eq_right hx',
+      div_self hnorm, mul_one, min_eq_left hx']
+
+private theorem Smale.AnnularExtension.clamp_mem_annulus {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {a b : ℝ} (hb : 0 < b) (hab : a ≤ b) {x : E} (hx : a ≤ ‖x‖) :
+    a ≤ ‖clamp b x‖ ∧ ‖clamp b x‖ ≤ b := by
+  rw [norm_clamp hb]
+  exact ⟨le_min hab hx, min_le_left _ _⟩
+
+private def
+    Smale.AnnularExtension.exteriorFactor {E : Type*} [NormedAddCommGroup E] (a : ℝ) (x : E) :
+    ℝ :=
+  Min.min 1 (Max.max 0 (2 - ‖x‖ / a))
+
+private theorem
+    Smale.AnnularExtension.exteriorFactor_nonneg {E : Type*} [NormedAddCommGroup E] (a : ℝ)
+    (x : E) : 0 ≤ exteriorFactor a x :=
+  le_min zero_le_one (le_max_left _ _)
+
+private theorem
+    Smale.AnnularExtension.exteriorFactor_le_one {E : Type*} [NormedAddCommGroup E] (a : ℝ)
+    (x : E) : exteriorFactor a x ≤ 1 :=
+  min_le_left _ _
+
+private def
+    Smale.AnnularExtension.exteriorVector {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (a : ℝ) (x : E) : E :=
+  exteriorFactor a x • unitClamp a x
+
+private theorem Smale.AnnularExtension.continuous_exteriorVector {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {a : ℝ} (ha : 0 < a) : Continuous (exteriorVector (E := E) a) := by
+  have hf : Continuous (exteriorFactor (E := E) a) := by unfold exteriorFactor; fun_prop
+  exact hf.smul (continuous_unitClamp ha)
+
+private theorem Smale.AnnularExtension.norm_exteriorVector_le {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {a : ℝ} (ha : 0 < a) (x : E) : ‖exteriorVector a x‖ ≤ 1 := by
+  rw [exteriorVector, norm_smul, Real.norm_eq_abs, abs_of_nonneg (exteriorFactor_nonneg a x)]
+  calc
+    _ ≤ 1 * 1 :=
+      mul_le_mul (exteriorFactor_le_one a x) (norm_unitClamp_le ha x) (norm_nonneg _) zero_le_one
+    _ = 1 := one_mul _
+
+private def Smale.AnnularExtension.exteriorDisk {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    {a : ℝ} (ha : 0 < a) : C(E, Metric.closedBall (0 : E) 1)
+    where
+  toFun x := ⟨exteriorVector a x, mem_closedBall_zero_iff.mpr (norm_exteriorVector_le ha x)⟩
+  continuous_toFun := (continuous_exteriorVector ha).subtype_mk _
+
+private theorem Smale.AnnularExtension.exteriorVector_on_sphere {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {a : ℝ} (ha : 0 < a) {x : E} (hx : ‖x‖ = a) :
+    exteriorVector a x = unitClamp a x := by
+  have hf : exteriorFactor a x = 1 := by
+    unfold exteriorFactor
+    rw [hx, div_self ha.ne']
+    norm_num
+  rw [exteriorVector, hf, one_smul]
+
+private theorem Smale.AnnularExtension.exteriorVector_eq_zero {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {a : ℝ} (ha : 0 < a) {x : E} (hx : 2 * a ≤ ‖x‖) : exteriorVector a x = 0 := by
+  have hdiv : 2 ≤ ‖x‖ / a := (le_div_iff₀ ha).mpr hx
+  have hf : exteriorFactor a x = 0 := by
+    unfold exteriorFactor
+    rw [max_eq_left (by linarith : 2 - ‖x‖ / a ≤ 0), min_eq_right zero_le_one]
+  rw [exteriorVector, hf, zero_smul]
+
+private theorem Smale.AnnularExtension.disk_extension_on_radius {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] {a : ℝ} (ha : 0 < a) {g : E → M}
+    (F : C(Metric.closedBall (0 : E) 1, M))
+    (hF :
+      ∀ v : Metric.sphere (0 : E) 1,
+        F ⟨v, Metric.sphere_subset_closedBall v.property⟩ = g (a • (v : E)))
+    {x : E} (hx : ‖x‖ = a) : F (innerDisk ha x) = g x := by
+  let v : Metric.sphere (0 : E) 1 :=
+    ⟨unitClamp a x, by
+      rw [mem_sphere_zero_iff_norm, norm_unitClamp ha, hx, max_self, div_self ha.ne']⟩
+  have heq : innerDisk ha x = ⟨(v : E), Metric.sphere_subset_closedBall v.property⟩ := rfl
+  rw [heq, hF]
+  change g (clamp a x) = g x
+  rw [clamp_of_norm_le ha hx.le]
+
+private theorem
+    Smale.AnnularExtension.exterior_extension_on_radius {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] {a : ℝ} (ha : 0 < a) {g : E → M}
+    (F : C(Metric.closedBall (0 : E) 1, M))
+    (hF :
+      ∀ v : Metric.sphere (0 : E) 1,
+        F ⟨v, Metric.sphere_subset_closedBall v.property⟩ = g (a • (v : E)))
+    {x : E} (hx : ‖x‖ = a) : F (exteriorDisk ha x) = g x := by
+  have heq : exteriorDisk ha x = innerDisk ha x := Subtype.ext (exteriorVector_on_sphere ha hx)
+  rw [heq]
+  exact disk_extension_on_radius ha F hF hx
+
+private theorem Smale.AnnularExtension.exists_continuous_annular_extension {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] {a b : ℝ} (ha : 0 < a)
+    (hab : a < b) {g : E → M} (hg : ContinuousOn g {x : E | a ≤ ‖x‖ ∧ ‖x‖ ≤ b})
+    (F₀ F₁ : C(Metric.closedBall (0 : E) 1, M))
+    (hF₀ :
+      ∀ v : Metric.sphere (0 : E) 1,
+        F₀ ⟨v, Metric.sphere_subset_closedBall v.property⟩ = g (a • (v : E)))
+    (hF₁ :
+      ∀ v : Metric.sphere (0 : E) 1,
+        F₁ ⟨v, Metric.sphere_subset_closedBall v.property⟩ = g (b • (v : E))) :
+    ∃ G : C(E, M),
+      Set.EqOn G g {x : E | a ≤ ‖x‖ ∧ ‖x‖ ≤ b} ∧
+        ∀ x, 2 * b ≤ ‖x‖ → G x = F₁ ⟨0, Metric.mem_closedBall_self zero_le_one⟩ := by
+  classical
+  have hb : 0 < b := ha.trans hab
+  let inner : C(E, M) := F₀.comp (innerDisk ha)
+  let outer : C(E, M) := F₁.comp (exteriorDisk hb)
+  let middle : E → M := g ∘ clamp b
+  have houtside : closure (Metric.closedBall (0 : E) a)ᶜ ⊆ {x : E | a ≤ ‖x‖} := by
+    apply closure_minimal
+    · intro x hx
+      have hn : ¬‖x‖ ≤ a := by simpa only [Set.mem_compl_iff, mem_closedBall_zero_iff] using hx
+      exact le_of_lt (lt_of_not_ge hn)
+    · exact isClosed_le continuous_const continuous_norm
+  have hmiddle : ContinuousOn middle (closure (Metric.closedBall (0 : E) a)ᶜ) :=
+    hg.comp (continuous_clamp hb).continuousOn
+      (fun _ hx => clamp_mem_annulus hb hab.le (houtside hx))
+  have hjoin₀ : ∀ x ∈ frontier (Metric.closedBall (0 : E) a), inner x = middle x := by
+    intro x hx
+    rw [frontier_closedBall _ ha.ne'] at hx
+    have hnorm : ‖x‖ = a := mem_sphere_zero_iff_norm.mp hx
+    change F₀ (innerDisk ha x) = g (clamp b x)
+    rw [disk_extension_on_radius ha F₀ hF₀ hnorm, clamp_of_norm_le hb (hnorm.le.trans hab.le)]
+  let G₀ : E → M := (Metric.closedBall (0 : E) a).piecewise inner middle
+  have hG₀ : Continuous G₀ := continuous_piecewise hjoin₀ inner.continuous.continuousOn hmiddle
+  have hG₀eq : Set.EqOn G₀ g {x : E | a ≤ ‖x‖ ∧ ‖x‖ ≤ b} := by
+    intro x hx
+    by_cases hxa : x ∈ Metric.closedBall (0 : E) a
+    · have hnorm : ‖x‖ = a := le_antisymm (mem_closedBall_zero_iff.mp hxa) hx.1
+      change ((Metric.closedBall (0 : E) a).piecewise inner middle) x = g x
+      rw [Set.piecewise_eq_of_mem _ _ _ hxa]
+      exact disk_extension_on_radius ha F₀ hF₀ hnorm
+    · change ((Metric.closedBall (0 : E) a).piecewise inner middle) x = g x
+      rw [Set.piecewise_eq_of_notMem _ _ _ hxa]
+      change g (clamp b x) = g x
+      rw [clamp_of_norm_le hb hx.2]
+  have hjoin₁ : ∀ x ∈ frontier (Metric.closedBall (0 : E) b), G₀ x = outer x := by
+    intro x hx
+    rw [frontier_closedBall _ hb.ne'] at hx
+    have hnorm : ‖x‖ = b := mem_sphere_zero_iff_norm.mp hx
+    rw [hG₀eq (show a ≤ ‖x‖ ∧ ‖x‖ ≤ b by rw [hnorm]; exact ⟨hab.le, le_rfl⟩)]
+    exact (exterior_extension_on_radius hb F₁ hF₁ hnorm).symm
+  let G : C(E, M) :=
+    ⟨(Metric.closedBall (0 : E) b).piecewise G₀ outer, hG₀.piecewise hjoin₁ outer.continuous⟩
+  refine ⟨G, ?_, ?_⟩
+  · intro x hx
+    change ((Metric.closedBall (0 : E) b).piecewise G₀ outer) x = g x
+    rw [Set.piecewise_eq_of_mem _ _ _ (mem_closedBall_zero_iff.mpr hx.2)]
+    exact hG₀eq hx
+  · intro x hx
+    have hxb : x ∉ Metric.closedBall (0 : E) b := by
+      rw [mem_closedBall_zero_iff]
+      linarith
+    change ((Metric.closedBall (0 : E) b).piecewise G₀ outer) x = _
+    rw [Set.piecewise_eq_of_notMem _ _ _ hxb]
+    change F₁ (exteriorDisk hb x) = F₁ ⟨0, Metric.mem_closedBall_self zero_le_one⟩
+    apply congrArg F₁
+    exact Subtype.ext (exteriorVector_eq_zero hb hx)
+
+private theorem
+    Smale.AnnularExtension.dist_direction {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    {x : E} (hx : x ≠ 0) : Dist.dist x (Smale.RadialExtension.direction x hx : E) = |‖x‖ - 1| := by
+  let v := Smale.RadialExtension.direction x hx
+  have hvec : ‖x‖ • (v : E) = x := smul_inv_smul₀ (norm_ne_zero_iff.mpr hx) x
+  have hn : ‖(v : E)‖ = 1 := mem_sphere_zero_iff_norm.mp v.property
+  change Dist.dist x (v : E) = _
+  calc
+    _ = ‖(‖x‖ - 1) • (v : E)‖ := by rw [dist_eq_norm, sub_smul, one_smul, hvec]
+    _ = |‖x‖ - 1| := by rw [norm_smul, Real.norm_eq_abs, hn, mul_one]
+
+private theorem
+    Smale.AnnularExtension.exists_closed_annulus_subset {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {W : Set E} (hW : IsOpen W)
+    (hSW : Metric.sphere (0 : E) 1 ⊆ W) :
+    ∃ a b : ℝ, 0 < a ∧ a < 1 ∧ 1 < b ∧ {x : E | a ≤ ‖x‖ ∧ ‖x‖ ≤ b} ⊆ W := by
+  obtain ⟨δ, hδ, hδW⟩ := (isCompact_sphere (0 : E) 1).exists_cthickening_subset_open hW hSW
+  let ε := Min.min (δ / 2) (1 / 2)
+  have hε : 0 < ε := lt_min (by linarith) (by norm_num)
+  have hεsmall : ε ≤ 1 / 2 := min_le_right _ _
+  have hεδ : ε ≤ δ := (min_le_left _ _).trans (by linarith)
+  refine ⟨1 - ε, 1 + ε, by linarith, by linarith, by linarith, ?_⟩
+  intro x hx
+  have hx0 : x ≠ 0 := by
+    intro heq
+    have hxlo := hx.1
+    rw [heq, norm_zero] at hxlo
+    linarith
+  have hdist : Dist.dist x (Smale.RadialExtension.direction x hx0 : E) ≤ δ := by
+    rw [dist_direction]
+    apply le_trans (abs_le.mpr ?_) hεδ
+    constructor <;> linarith [hx.1, hx.2]
+  exact
+    hδW
+      (Metric.mem_cthickening_of_dist_le x (Smale.RadialExtension.direction x hx0) δ
+        (Metric.sphere (0 : E) 1) (Smale.RadialExtension.direction x hx0).property hdist)
+
+private abbrev Smale.SixSphere :=
+  Metric.sphere (0 : EuclideanSpace ℝ (Fin 7)) 1
+
+private theorem Smale.simplyConnectedSpace_of_homotopySixSphere {M : Type*} [TopologicalSpace M]
+    (e : M ≃ₕ Smale.SixSphere) : SimplyConnectedSpace M := by
+  let : SimplyConnectedSpace Smale.SixSphere := EuclideanSphere.simplyConnectedSpace 4
+  exact e.simplyConnectedSpace
+
+private theorem Smale.pathConnectedSpace_of_homotopySixSphere {M : Type*} [TopologicalSpace M]
+    (e : M ≃ₕ Smale.SixSphere) : PathConnectedSpace M := by
+  let : SimplyConnectedSpace M := simplyConnectedSpace_of_homotopySixSphere e
+  infer_instance
+
+private abbrev NoExotic.UnitSphere (E : Type*) [NormedAddCommGroup E] :=
+  Metric.sphere (0 : E) 1
+
+private theorem NoExotic.ClosedHemisphere.unit_norm {E : Type*} [NormedAddCommGroup E]
+    (x : NoExotic.UnitSphere E) : ‖(x : E)‖ = 1 := by
+  simpa only [Metric.mem_sphere, dist_zero_right] using x.property
+
+private abbrev NoExotic.Sphere (n : ℕ) :=
+  Metric.sphere (0 : EuclideanSpace ℝ (Fin (n + 1))) 1
+
+private noncomputable def NoExotic.normalizedSphereMap {X E : Type*} [TopologicalSpace X]
+    [NormedAddCommGroup E] [InnerProductSpace ℝ E] (g : C(X, E)) (hg : ∀ x, g x ≠ 0) :
+    C(X, UnitSphere E) := by
+  let gN : X → E := fun x ↦ NormedSpace.normalize (g x)
+  have hm : ∀ x, gN x ∈ UnitSphere E := by
+    intro x
+    simpa only [Metric.mem_sphere, dist_zero_right] using NormedSpace.norm_normalize (hg x)
+  have hc : Continuous gN :=
+    (g.continuous.norm.inv₀ (fun x ↦ norm_ne_zero_iff.mpr (hg x))).smul g.continuous
+  exact ⟨fun x ↦ ⟨gN x, hm x⟩, hc.subtype_mk hm⟩
+
+private theorem
+    NoExotic.nearby_unit_ne_zero {E : Type*} [NormedAddCommGroup E] (a : UnitSphere E) (b : E)
+    (h : Dist.dist b (a : E) < 1) : b ≠ 0 := by
+  intro hb
+  rw [hb, dist_zero_left, ClosedHemisphere.unit_norm] at h
+  exact (lt_irrefl 1) h
+
+private theorem
+    NoExotic.nearby_segment_dist_lt {E : Type*} [NormedAddCommGroup E] [InnerProductSpace ℝ E]
+    (a : UnitSphere E) (b : E) (h : Dist.dist b (a : E) < 1) (t : (unitInterval)) :
+    Dist.dist ((a : E) + (t : ℝ) • (b - (a : E))) (a : E) < 1 := by
+  rw [dist_eq_norm, add_sub_cancel_left, norm_smul, Real.norm_eq_abs, abs_of_nonneg t.2.1]
+  calc
+    (t : ℝ) * ‖b - (a : E)‖ ≤ ‖b - (a : E)‖ := mul_le_of_le_one_left (norm_nonneg _) t.2.2
+    _ < 1 := by simpa only [dist_eq_norm] using h
+
+private theorem
+    NoExotic.nearby_segment_ne_zero {E : Type*} [NormedAddCommGroup E] [InnerProductSpace ℝ E]
+    (a : UnitSphere E) (b : E) (h : Dist.dist b (a : E) < 1) (t : (unitInterval)) :
+    (a : E) + (t : ℝ) • (b - (a : E)) ≠ 0 :=
+  nearby_unit_ne_zero a _ (nearby_segment_dist_lt a b h t)
+
+private noncomputable def NoExotic.nearbyNormalizationHomotopy {X E : Type*} [TopologicalSpace X]
+    [NormedAddCommGroup E] [InnerProductSpace ℝ E] (f : C(X, UnitSphere E)) (g : C(X, E))
+    (h : ∀ x, Dist.dist (g x) (f x : E) < 1) :
+    f.Homotopy (normalizedSphereMap g (fun x ↦ nearby_unit_ne_zero (f x) (g x) (h x)))
+    where
+  toFun
+    p :=
+    ⟨NormedSpace.normalize ((f p.2 : E) + (p.1 : ℝ) • (g p.2 - (f p.2 : E))), by
+      simpa only [Metric.mem_sphere, dist_zero_right] using
+        NormedSpace.norm_normalize (nearby_segment_ne_zero (f p.2) (g p.2) (h p.2) p.1)⟩
+  continuous_toFun := by
+    have hf : Continuous (fun p : (unitInterval) × X ↦ (f p.2 : E)) :=
+      continuous_subtype_val.comp (f.continuous.comp continuous_snd)
+    have hg := g.continuous.comp (continuous_snd : Continuous (Prod.snd : (unitInterval) × X → X))
+    have ht : Continuous (fun p : (unitInterval) × X ↦ (p.1 : ℝ)) :=
+      continuous_subtype_val.comp continuous_fst
+    have hb := hf.add (ht.smul (hg.sub hf))
+    exact
+      ((hb.norm.inv₀
+                (fun p ↦
+                  norm_ne_zero_iff.mpr (nearby_segment_ne_zero (f p.2) (g p.2) (h p.2) p.1))).smul
+            hb).subtype_mk
+        _
+  map_zero_left
+    x := by
+    apply Subtype.ext
+    change NormedSpace.normalize ((f x : E) + (0 : ℝ) • (g x - (f x : E))) = (f x : E)
+    simpa only [zero_smul, add_zero] using
+      NormedSpace.normalize_eq_self_of_norm_eq_one (ClosedHemisphere.unit_norm (f x))
+  map_one_left
+    x := by
+    apply Subtype.ext
+    change
+      NormedSpace.normalize ((f x : E) + (1 : ℝ) • (g x - (f x : E))) =
+        NormedSpace.normalize (g x)
+    rw [one_smul, ← add_sub_assoc, add_sub_cancel_left]
+
+private theorem
+    NoExotic.contMDiff_normalize {E : Type*} [NormedAddCommGroup E] [InnerProductSpace ℝ E]
+    {B H M : Type*} [NormedAddCommGroup B] [NormedSpace ℝ B] [TopologicalSpace H]
+    {I : ModelWithCorners ℝ B H} [TopologicalSpace M] [ChartedSpace H M] {g : M → E}
+    (hg : ContMDiff I 𝓘(ℝ, E) ∞ g) (hn : ∀ x, g x ≠ 0) :
+    ContMDiff I 𝓘(ℝ, E) ∞ (fun x ↦ NormedSpace.normalize (g x)) := by
+  intro x
+  have hN : ContDiffAt ℝ ∞ (NormedSpace.normalize : E → E) (g x) :=
+    ((contDiffAt_norm ℝ (hn x)).inv (norm_ne_zero_iff.mpr (hn x))).smul contDiffAt_id
+  exact hN.comp_contMDiffAt (f := g) (x := x) (hg x)
+
+private theorem NoExotic.exists_smoothSphereRepresentative {B H M : Type*} [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [TopologicalSpace H] {I : ModelWithCorners ℝ B H} [TopologicalSpace M]
+    [ChartedSpace H M] [FiniteDimensional ℝ B] [IsManifold I ∞ M] [SigmaCompactSpace M]
+    [T2Space M] (n : ℕ) (f : C(M, Sphere n)) :
+    ∃ g : C(M, Sphere n), ContMDiff I (𝓡 n) ∞ g ∧ f.Homotopic g := by
+  let : Fact (Module.finrank ℝ (EuclideanSpace ℝ (Fin (n + 1))) = n + 1) :=
+    ⟨finrank_euclideanSpace_fin⟩
+  have hf : Continuous (fun x ↦ (f x : EuclideanSpace ℝ (Fin (n + 1)))) :=
+    continuous_subtype_val.comp f.continuous
+  obtain ⟨g, hg, _⟩ :=
+    hf.exists_contMDiff_approx I (⊤ : ℕ∞) (ε := fun _ ↦ 1) continuous_const (fun _ ↦ zero_lt_one)
+  let gC : C(M, EuclideanSpace ℝ (Fin (n + 1))) := ⟨g, g.contMDiff.continuous⟩
+  have hn : ∀ x, gC x ≠ 0 := fun x ↦ nearby_unit_ne_zero (f x) (gC x) (hg x)
+  refine ⟨normalizedSphereMap gC hn, ?_, ⟨nearbyNormalizationHomotopy f gC hg⟩⟩
+  exact
+    (contMDiff_normalize g.contMDiff hn).codRestrict_sphere (n := n)
+      (fun x ↦ (normalizedSphereMap gC hn x).2)
+
+private noncomputable def NoExotic.chartContractionHomotopy {X Y E : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] [NormedAddCommGroup E] [NormedSpace ℝ E] (f : C(X, Y))
+    (c : OpenPartialHomeomorph Y E) (ht : c.target = Set.univ) (hf : ∀ x, f x ∈ c.source) :
+    f.Homotopy (ContinuousMap.const _ (c.symm 0))
+    where
+  toFun p := c.symm ((1 - (p.1 : ℝ)) • c (f p.2))
+  continuous_toFun := by
+    have hc : Continuous (fun x ↦ c (f x)) := c.continuousOn.comp_continuous f.continuous hf
+    have hci : Continuous c.symm := by
+      apply continuousOn_univ.mp
+      rw [← ht]
+      exact c.symm.continuousOn
+    exact
+      hci.comp
+        ((continuous_const.sub (continuous_subtype_val.comp continuous_fst)).smul
+          (hc.comp continuous_snd))
+  map_zero_left
+    x := by
+    change c.symm ((1 - (0 : ℝ)) • c (f x)) = f x
+    rw [sub_zero, one_smul]
+    exact c.left_inv (hf x)
+  map_one_left
+    x := by
+    change c.symm ((1 - (1 : ℝ)) • c (f x)) = c.symm 0
+    rw [sub_self, zero_smul]
+
+private theorem
+    NoExotic.sphereMap_nullhomotopic_of_omitted_point {X : Type*} [TopologicalSpace X] (n : ℕ)
+    (f : C(X, Sphere n)) (p : Sphere n) (hp : ∀ x, f x ≠ p) :
+    ∃ c, f.Homotopic (ContinuousMap.const _ c) := by
+  let : Fact (Module.finrank ℝ (EuclideanSpace ℝ (Fin (n + 1))) = n + 1) :=
+    ⟨finrank_euclideanSpace_fin⟩
+  let c := stereographic' n p
+  have hf : ∀ x, f x ∈ c.source := by
+    intro x
+    simpa only [c, stereographic'_source, Set.mem_compl_iff, Set.mem_singleton_iff] using hp x
+  exact ⟨c.symm 0, ⟨chartContractionHomotopy f c (stereographic'_target (n := n) p) hf⟩⟩
+
+private theorem NoExotic.sphereMap_nullhomotopic_of_dim_lt {B H M : Type*} [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [FiniteDimensional ℝ B] [TopologicalSpace H] {I : ModelWithCorners ℝ B H}
+    [I.Boundaryless] [TopologicalSpace M] [ChartedSpace H M] [IsManifold I ∞ M] [CompactSpace M]
+    [T2Space M] (n : ℕ) (f : C(M, Sphere n)) (hd : Module.finrank ℝ B < n) :
+    ∃ c, f.Homotopic (ContinuousMap.const _ c) := by
+  classical
+  obtain ⟨g, hg, hfg⟩ := exists_smoothSphereRepresentative (I := I) n f
+  let : Nonempty (Sphere n) := NormedSpace.sphere_nonempty_rclike ℝ zero_le_one
+  have hn : ¬Function.Surjective g :=
+    not_surjective_contMDiff_of_dim_lt hg (by simpa only [finrank_euclideanSpace_fin] using hd)
+  obtain ⟨p, hp⟩ : ∃ p, ∀ x, g x ≠ p := by
+    simpa only [Function.Surjective, Classical.not_forall, not_exists] using hn
+  obtain ⟨c, hgc⟩ := sphereMap_nullhomotopic_of_omitted_point n g p hp
+  exact ⟨c, hfg.trans hgc⟩
+
+private theorem
+    NoExotic.sphere_sphere_nullhomotopic {m n : ℕ} (hmn : m < n) (f : C(Sphere m, Sphere n)) :
+    ∃ c, f.Homotopic (ContinuousMap.const _ c) :=
+  sphereMap_nullhomotopic_of_dim_lt (I := 𝓡 m) n f
+    (by simpa only [finrank_euclideanSpace_fin] using hmn)
+
+private theorem Smale.nullhomotopic_of_homotopySixSphere_comp {X M : Type*} [TopologicalSpace X]
+    [TopologicalSpace M] (e : M ≃ₕ Smale.SixSphere) (g : C(X, M))
+    (h : ∃ c, (e.toFun.comp g).Homotopic (ContinuousMap.const X c)) :
+    ∃ c, g.Homotopic (ContinuousMap.const X c) := by
+  obtain ⟨c, hnull⟩ := h
+  have h₀ : (e.invFun.comp (e.toFun.comp g)).Homotopic g :=
+    e.left_inv.comp (ContinuousMap.Homotopic.refl g)
+  have h₁ : (e.invFun.comp (e.toFun.comp g)).Homotopic (ContinuousMap.const X (e.invFun c)) :=
+    (ContinuousMap.Homotopic.refl e.invFun).comp hnull
+  exact ⟨e.invFun c, h₀.symm.trans h₁⟩
+
+private theorem
+    Smale.manifoldMap_nullhomotopic_of_homotopySixSphere {X M : Type*} [TopologicalSpace X]
+    [TopologicalSpace M] {B H : Type*} [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [FiniteDimensional ℝ B] [TopologicalSpace H] (I : ModelWithCorners ℝ B H) [I.Boundaryless]
+    [ChartedSpace H X] [IsManifold I ∞ X] [CompactSpace X] [T2Space X] (e : M ≃ₕ Smale.SixSphere)
+    (hdim : Module.finrank ℝ B < 6) (g : C(X, M)) : ∃ c, g.Homotopic (ContinuousMap.const _ c) :=
+  nullhomotopic_of_homotopySixSphere_comp e g
+    (NoExotic.sphereMap_nullhomotopic_of_dim_lt (I := I) 6 (e.toFun.comp g) hdim)
+
+private theorem Smale.exists_circle_neighborhood_extension_of_circle_nullhomotopies {M : Type*}
+    [TopologicalSpace M]
+    (hnull : ∀ f : C(Hemisphere.Sphere 1, M), ∃ c, f.Homotopic (ContinuousMap.const _ c))
+    {g : Hemisphere.Ambient 2 → M} {W : Set (Hemisphere.Ambient 2)} (hW : IsOpen W)
+    (hg : ContinuousOn g W) (hSW : Metric.sphere (0 : Hemisphere.Ambient 2) 1 ⊆ W) :
+    ∃ G : C(Hemisphere.Ambient 2, M),
+      ∃ c : M,
+        ∃ K : Set (Hemisphere.Ambient 2),
+          IsCompact K ∧
+            (∀ x ∉ K, G x = c) ∧
+              ∃ U : Set (Hemisphere.Ambient 2),
+                IsOpen U ∧
+                  Metric.sphere (0 : Hemisphere.Ambient 2) 1 ⊆ U ∧ U ⊆ W ∧ Set.EqOn G g U := by
+  obtain ⟨a, b, ha, ha1, h1b, hAW⟩ := AnnularExtension.exists_closed_annulus_subset hW hSW
+  have hab : a < b := ha1.trans h1b
+  have hb : 0 < b := ha.trans hab
+  let A : Set (Hemisphere.Ambient 2) := {x | a ≤ ‖x‖ ∧ ‖x‖ ≤ b}
+  have hgA : ContinuousOn g A := hg.mono hAW
+  have hscale (r : ℝ) (hr : r ∈ Set.Icc a b) (v : Hemisphere.Sphere 1) :
+    r • (v : Hemisphere.Ambient 2) ∈ A := by
+    have hr0 : 0 < r := ha.trans_le hr.1
+    have hnorm : ‖r • (v : Hemisphere.Ambient 2)‖ = r := by
+      rw [norm_smul, Real.norm_eq_abs, abs_of_pos hr0, mem_sphere_zero_iff_norm.mp v.property,
+        mul_one]
+    change a ≤ ‖r • (v : Hemisphere.Ambient 2)‖ ∧ ‖r • (v : Hemisphere.Ambient 2)‖ ≤ b
+    rw [hnorm]
+    exact hr
+  have hcontinuous (r : ℝ) :
+    Continuous (fun v : Hemisphere.Sphere 1 => r • (v : Hemisphere.Ambient 2)) := by fun_prop
+  let f₀ : C(Hemisphere.Sphere 1, M) :=
+    ⟨fun v => g (a • (v : Hemisphere.Ambient 2)),
+      hgA.comp_continuous (hcontinuous a) (hscale a ⟨le_rfl, hab.le⟩)⟩
+  let f₁ : C(Hemisphere.Sphere 1, M) :=
+    ⟨fun v => g (b • (v : Hemisphere.Ambient 2)),
+      hgA.comp_continuous (hcontinuous b) (hscale b ⟨hab.le, le_rfl⟩)⟩
+  obtain ⟨c₀, ⟨H₀⟩⟩ := hnull f₀
+  obtain ⟨c₁, ⟨H₁⟩⟩ := hnull f₁
+  obtain ⟨v, hv⟩ : (Metric.sphere (0 : Hemisphere.Ambient 2) 1).Nonempty :=
+    NormedSpace.sphere_nonempty.mpr zero_le_one
+  let : Nonempty (Metric.sphere (0 : Hemisphere.Ambient 2) 1) := ⟨⟨v, hv⟩⟩
+  let F₀ := DiskCone.extension f₀ c₀ H₀
+  let F₁ := DiskCone.extension f₁ c₁ H₁
+  obtain ⟨G, hGeq, hGconst⟩ :=
+    AnnularExtension.exists_continuous_annular_extension ha hab hgA F₀ F₁
+      (DiskCone.extension_boundary f₀ c₀ H₀) (DiskCone.extension_boundary f₁ c₁ H₁)
+  let U : Set (Hemisphere.Ambient 2) := {x | a < ‖x‖ ∧ ‖x‖ < b}
+  have hU : IsOpen U :=
+    (isOpen_lt continuous_const continuous_norm).inter
+      (isOpen_lt continuous_norm continuous_const)
+  have hUA : U ⊆ A := fun _ hx => ⟨hx.1.le, hx.2.le⟩
+  refine
+    ⟨G, c₁, Metric.closedBall 0 (2 * b), ProperSpace.isCompact_closedBall _ _, ?_, U, hU, ?_,
+      hUA.trans hAW, hGeq.mono hUA⟩
+  · intro x hx
+    have hn : 2 * b < ‖x‖ := by simpa only [mem_closedBall_zero_iff, not_le] using hx
+    rw [hGconst x hn.le]
+    exact DiskCone.extension_zero f₁ c₁ H₁
+  · intro x hx
+    have hn : ‖x‖ = 1 := mem_sphere_zero_iff_norm.mp hx
+    change a < ‖x‖ ∧ ‖x‖ < b
+    rw [hn]
+    exact ⟨ha1, h1b⟩
+
+private theorem Smale.WhitneyPairModel.convex_bigon {h : ℝ} (hh : 0 ≤ h) : Convex ℝ (bigon h) := by
+  intro x hx y hy a b ha hb hab
+  change 0 ≤ a * x.2 + b * y.2 ∧ h * (a * x.1 + b * y.1) ^ 2 + (a * x.2 + b * y.2) ≤ h
+  refine ⟨add_nonneg (mul_nonneg ha hx.1) (mul_nonneg hb hy.1), ?_⟩
+  have hsq : (a * x.1 + b * y.1) ^ 2 = a * x.1 ^ 2 + b * y.1 ^ 2 - a * b * (x.1 - y.1) ^ 2 := by
+    calc
+      _ = (a + b) * (a * x.1 ^ 2 + b * y.1 ^ 2) - a * b * (x.1 - y.1) ^ 2 := by ring
+      _ = _ := by rw [hab, one_mul]
+  calc
+    _ = a * (h * x.1 ^ 2 + x.2) + b * (h * y.1 ^ 2 + y.2) - h * a * b * (x.1 - y.1) ^ 2 := by
+      rw [hsq]; ring
+    _ ≤ a * (h * x.1 ^ 2 + x.2) + b * (h * y.1 ^ 2 + y.2) :=
+      (sub_le_self _ (mul_nonneg (mul_nonneg (mul_nonneg hh ha) hb) (sq_nonneg _)))
+    _ ≤ a * h + b * h :=
+      (add_le_add (mul_le_mul_of_nonneg_left hx.2 ha) (mul_le_mul_of_nonneg_left hy.2 hb))
+    _ = h := by rw [← add_mul, hab, one_mul]
+
+private theorem Smale.WhitneyPairModel.bigon_center_mem_interior {h : ℝ} (hh : 0 < h) :
+    (0, h / 2) ∈ interior (bigon h) := by
+  apply (mem_interior_bigon_iff h _).mpr
+  change 0 < h / 2 ∧ h / 2 < h * (1 - 0 ^ 2)
+  norm_num only [zero_pow (by decide : 2 ≠ 0), sub_zero, mul_one]
+  constructor <;> linarith
+
+private theorem Smale.WhitneyPairModel.interior_bigon_nonempty {h : ℝ} (hh : 0 < h) :
+    (interior (bigon h)).Nonempty :=
+  ⟨(0, h / 2), bigon_center_mem_interior hh⟩
+
+private theorem Smale.WhitneyPairModel.exists_bigon_disk_homeomorph {h : ℝ} (hh : 0 < h) :
+    ∃ e : (ℝ × ℝ) ≃ₜ Smale.Hemisphere.Ambient 2,
+      e '' bigon h = Metric.closedBall 0 1 ∧
+        e '' interior (bigon h) = Metric.ball 0 1 ∧ e '' frontier (bigon h) = Metric.sphere 0 1 :=
+  by
+  let L : (ℝ × ℝ) ≃L[ℝ] Smale.Hemisphere.Ambient 2 :=
+    ContinuousLinearEquiv.ofFinrankEq (by simp [Smale.Hemisphere.Ambient, Module.finrank_prod])
+  let K : Set (Smale.Hemisphere.Ambient 2) := L '' bigon h
+  have hK : IsCompact K := (isCompact_bigon hh).image L.continuous
+  have hc : Convex ℝ K := (convex_bigon hh.le).linear_image L.toLinearEquiv.toLinearMap
+  have hLint : L '' interior (bigon h) = interior K := L.toHomeomorph.image_interior (bigon h)
+  have hLfront : L '' frontier (bigon h) = frontier K := L.toHomeomorph.image_frontier (bigon h)
+  have hne : (interior K).Nonempty := by
+    rw [← hLint]
+    exact (interior_bigon_nonempty hh).image L
+  obtain ⟨e, heint, heclosed, hefront⟩ :=
+    exists_homeomorph_image_interior_closure_frontier_eq_unitBall hc hne hK.isBounded
+  refine ⟨L.toHomeomorph.trans e, ?_, ?_, ?_⟩
+  · calc
+      _ = e '' (L '' bigon h) := (Set.image_image e L (bigon h)).symm
+      _ = Metric.closedBall 0 1 := by
+        change e '' K = _
+        rwa [hK.isClosed.closure_eq] at heclosed
+  · calc
+      _ = e '' (L '' interior (bigon h)) := (Set.image_image e L (interior (bigon h))).symm
+      _ = Metric.ball 0 1 := by rw [hLint]; exact heint
+  · calc
+      _ = e '' (L '' frontier (bigon h)) := (Set.image_image e L (frontier (bigon h))).symm
+      _ = Metric.sphere 0 1 := by rw [hLfront]; exact hefront
+
+private theorem Smale.exists_bigon_neighborhood_extension_of_circle_nullhomotopies {M : Type*}
+    [TopologicalSpace M]
+    (hnull : ∀ f : C(Hemisphere.Sphere 1, M), ∃ c, f.Homotopic (ContinuousMap.const _ c)) {h : ℝ}
+    (hh : 0 < h) {f : (ℝ × ℝ) → M} {W : Set (ℝ × ℝ)} (hW : IsOpen W) (hf : ContinuousOn f W)
+    (hfrontW : frontier (WhitneyPairModel.bigon h) ⊆ W) :
+    ∃ F : C(ℝ × ℝ, M),
+      ∃ c : M,
+        ∃ K : Set (ℝ × ℝ),
+          IsCompact K ∧
+            (∀ x ∉ K, F x = c) ∧
+              ∃ U : Set (ℝ × ℝ),
+                IsOpen U ∧ frontier (WhitneyPairModel.bigon h) ⊆ U ∧ U ⊆ W ∧ Set.EqOn F f U := by
+  obtain ⟨φ, _, _, hφfront⟩ := WhitneyPairModel.exists_bigon_disk_homeomorph hh
+  let W' : Set (Hemisphere.Ambient 2) := φ.symm ⁻¹' W
+  let g : Hemisphere.Ambient 2 → M := f ∘ φ.symm
+  have hW' : IsOpen W' := hW.preimage φ.symm.continuous
+  have hg : ContinuousOn g W' := hf.comp φ.symm.continuous.continuousOn (fun _ hx => hx)
+  have hSW : Metric.sphere (0 : Hemisphere.Ambient 2) 1 ⊆ W' := by
+    intro y hy
+    have hy' : y ∈ φ '' frontier (WhitneyPairModel.bigon h) := by rw [hφfront]; exact hy
+    obtain ⟨x, hx, rfl⟩ := hy'
+    change φ.symm (φ x) ∈ W
+    rw [φ.symm_apply_apply]
+    exact hfrontW hx
+  obtain ⟨G, c, K', hK', hconst, U', hU', hSU', hU'W', heq⟩ :=
+    exists_circle_neighborhood_extension_of_circle_nullhomotopies hnull hW' hg hSW
+  let F : C(ℝ × ℝ, M) := G.comp ⟨φ, φ.continuous⟩
+  let K := φ.symm '' K'
+  let U := φ ⁻¹' U'
+  refine ⟨F, c, K, hK'.image φ.symm.continuous, ?_, U, hU'.preimage φ.continuous, ?_, ?_, ?_⟩
+  · intro x hx
+    have hx' : φ x ∉ K' := fun hmem => hx ⟨φ x, hmem, φ.symm_apply_apply x⟩
+    exact hconst (φ x) hx'
+  · intro x hx
+    apply hSU'
+    rw [← hφfront]
+    exact Set.mem_image_of_mem φ hx
+  · intro x hx
+    have hx' : φ.symm (φ x) ∈ W := hU'W' hx
+    rwa [φ.symm_apply_apply] at hx'
+  · intro x hx
+    change G (φ x) = f x
+    rw [heq hx]
+    change f (φ.symm (φ x)) = f x
+    rw [φ.symm_apply_apply]
+
+private theorem
+    Smale.exists_smooth_bigon_neighborhood_extension_of_circle_nullhomotopies {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M]
+    (hnull : ∀ f : C(Hemisphere.Sphere 1, M), ∃ c, f.Homotopic (ContinuousMap.const _ c)) {h : ℝ}
+    (hh : 0 < h) {f : (ℝ × ℝ) → M} {W : Set (ℝ × ℝ)} (hW : IsOpen W)
+    (hf : ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ f W)
+    (hfrontW : frontier (WhitneyPairModel.bigon h) ⊆ W) :
+    ∃ F : C(ℝ × ℝ, M),
+      ContMDiff 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ F ∧
+        ∃ U : Set (ℝ × ℝ),
+          IsOpen U ∧ frontier (WhitneyPairModel.bigon h) ⊆ U ∧ U ⊆ W ∧ Set.EqOn F f U := by
+  obtain ⟨G, c, K, hK, hconst, V, hV, hfrontV, hVW, hGeq⟩ :=
+    exists_bigon_neighborhood_extension_of_circle_nullhomotopies hnull hh hW hf.continuousOn
+      hfrontW
+  have hfrontCompact : IsCompact (frontier (WhitneyPairModel.bigon h)) :=
+    (WhitneyPairModel.isCompact_bigon hh).of_isClosed_subset isClosed_frontier
+      (fun p hp => ((WhitneyPairModel.mem_frontier_bigon_iff h p).mp hp).1)
+  obtain ⟨C, _, hC, hfrontC, hCV⟩ := exists_compact_closed_between hfrontCompact hV hfrontV
+  have hGV : ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ G V := (hf.mono hVW).congr (fun _ hx => hGeq hx)
+  have hGK : ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ G Kᶜ :=
+    (contMDiff_const (c := c)).contMDiffOn.congr (fun x hx => hconst x hx)
+  obtain ⟨F, hF, hrel⟩ :=
+    ManifoldSmoothing.exists_smooth_map_homotopicRel_of_smooth_off_compact G hK hC hV hCV hGV hGK
+  refine ⟨F, hF, interior C, isOpen_interior, hfrontC, interior_subset.trans (hCV.trans hVW), ?_⟩
+  intro x hx
+  exact (hrel.fst_eq_snd (interior_subset hx)).symm.trans (hGeq (hCV (interior_subset hx)))
+
+private structure Smale.TubularBigon {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] (S T : Set M) (a b : ℝ → M) (k l : (ℝ × ℝ) → M)
+    (h : ℝ) (n : ℕ := 4) where
+  height_pos : 0 < h
+  map : C(ℝ × ℝ, M)
+  smooth : ContMDiff 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ map
+  closed_embedding : Topology.IsClosedEmbedding (fun p : WhitneyPairModel.bigon h => map p)
+  derivative_injective :
+    ∀ p ∈ WhitneyPairModel.bigon h, Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) map p)
+  interior_avoids : ∀ p ∈ interior (WhitneyPairModel.bigon h), map p ∉ S ∪ T
+  lower : ∀ t ∈ Set.Icc (0 : ℝ) 1, map (2 * t - 1, 0) = a t
+  upper : ∀ t ∈ Set.Icc (0 : ℝ) 1, map (2 * t - 1, h * (1 - (2 * t - 1) ^ 2)) = b t
+  lower_germ :
+    ∀ t ∈ Set.Icc (0 : ℝ) 1, map =ᶠ[𝓝 (2 * t - 1, 0)] k ∘ WhitneyPairModel.lowerStripCoordinates h
+  upper_germ :
+    ∀ t ∈ Set.Icc (0 : ℝ) 1,
+      map =ᶠ[𝓝 (2 * t - 1, h * (1 - (2 * t - 1) ^ 2))]
+        l ∘ WhitneyPairModel.upperStripCoordinates h
+  radius : ℝ
+  radius_pos : 0 < radius
+  chart :
+    PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × EuclideanSpace ℝ (Fin n)) 𝓘(ℝ, E)
+      ((ℝ × ℝ) × EuclideanSpace ℝ (Fin n)) M ∞
+  source_contains : WhitneyPairModel.bigon h ×ˢ Metric.closedBall 0 radius ⊆ chart.source
+  zero_section : ∀ p, chart (p, 0) = map p
+
+private def Smale.WhitneyPairModel.lowerBoundaryArc (t : ℝ) : ℝ × ℝ :=
+  (2 * t - 1, 0)
+
+private def Smale.WhitneyPairModel.upperBoundaryArc (h t : ℝ) : ℝ × ℝ :=
+  (2 * t - 1, h * (1 - (2 * t - 1) ^ 2))
+
+private theorem Smale.WhitneyPairModel.hasDerivAt_lowerBoundaryArc (t : ℝ) :
+    HasDerivAt lowerBoundaryArc (2, 0) t := by
+  have hs : HasDerivAt (fun s : ℝ => 2 * s - 1) 2 t := by
+    simpa using ((hasDerivAt_id t).const_mul 2).sub_const 1
+  exact hs.prodMk (hasDerivAt_const t (0 : ℝ))
+
+private theorem Smale.WhitneyPairModel.hasDerivAt_upperBoundaryArc (h t : ℝ) :
+    HasDerivAt (upperBoundaryArc h) (2, -4 * h * (2 * t - 1)) t := by
+  have hs : HasDerivAt (fun s : ℝ => 2 * s - 1) 2 t := by
+    simpa using ((hasDerivAt_id t).const_mul 2).sub_const 1
+  have hy : HasDerivAt (fun s : ℝ => h * (1 - (2 * s - 1) ^ 2)) (-4 * h * (2 * t - 1)) t := by
+    convert HasDerivAt.const_mul h ((hasDerivAt_const t (1 : ℝ)).sub (hs.pow 2)) using 1 <;>
+      first
+      | rfl
+      | ring
+  exact hs.prodMk hy
+
+private theorem Smale.TubularBigon.lowerBoundaryArc_mem_bigon {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M} {a b : ℝ → M}
+    {k l : (ℝ × ℝ) → M} {h : ℝ} {n : ℕ} (tube : Smale.TubularBigon (E := E) S T a b k l h n)
+    {t : ℝ} (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    Smale.WhitneyPairModel.lowerBoundaryArc t ∈ Smale.WhitneyPairModel.bigon h := by
+  have hf :
+    Smale.WhitneyPairModel.lowerBoundaryArc t ∈ frontier (Smale.WhitneyPairModel.bigon h) :=
+    (Smale.WhitneyPairModel.mem_frontier_bigon_iff_exists_time tube.height_pos _).mpr
+      ⟨t, ht, Or.inl rfl⟩
+  exact ((Smale.WhitneyPairModel.mem_frontier_bigon_iff h _).mp hf).1
+
+private theorem Smale.TubularBigon.upperBoundaryArc_mem_bigon {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M} {a b : ℝ → M}
+    {k l : (ℝ × ℝ) → M} {h : ℝ} {n : ℕ} (tube : Smale.TubularBigon (E := E) S T a b k l h n)
+    {t : ℝ} (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    Smale.WhitneyPairModel.upperBoundaryArc h t ∈ Smale.WhitneyPairModel.bigon h := by
+  have hf :
+    Smale.WhitneyPairModel.upperBoundaryArc h t ∈ frontier (Smale.WhitneyPairModel.bigon h) :=
+    (Smale.WhitneyPairModel.mem_frontier_bigon_iff_exists_time tube.height_pos _).mpr
+      ⟨t, ht, Or.inr rfl⟩
+  exact ((Smale.WhitneyPairModel.mem_frontier_bigon_iff h _).mp hf).1
+
+private theorem
+    Smale.TubularBigon.lowerBoundaryArc_zero_mem_source {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M} {a b : ℝ → M}
+    {k l : (ℝ × ℝ) → M} {h : ℝ} {n : ℕ} (tube : Smale.TubularBigon (E := E) S T a b k l h n)
+    {t : ℝ} (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    (Smale.WhitneyPairModel.lowerBoundaryArc t, 0) ∈ tube.chart.source :=
+  tube.source_contains
+    ⟨tube.lowerBoundaryArc_mem_bigon ht, Metric.mem_closedBall_self tube.radius_pos.le⟩
+
+private theorem
+    Smale.TubularBigon.upperBoundaryArc_zero_mem_source {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M} {a b : ℝ → M}
+    {k l : (ℝ × ℝ) → M} {h : ℝ} {n : ℕ} (tube : Smale.TubularBigon (E := E) S T a b k l h n)
+    {t : ℝ} (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    (Smale.WhitneyPairModel.upperBoundaryArc h t, 0) ∈ tube.chart.source :=
+  tube.source_contains
+    ⟨tube.upperBoundaryArc_mem_bigon ht, Metric.mem_closedBall_self tube.radius_pos.le⟩
+
+private theorem
+    Smale.TubularBigon.lower_chart_center_mem_target {E M A B : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] {S T : Set M} {a b : ℝ → M}
+    {k l : (ℝ × ℝ) → M} {h : ℝ} {n : ℕ} (tube : Smale.TubularBigon (E := E) S T a b k l h n)
+    (d : Smale.StripNormalData A B (E := E) S k) {t : ℝ} (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    d.chart (Smale.StripCoordinates.center t) ∈ tube.chart.target := by
+  have hg := (tube.lower_germ t ht).eq_of_nhds
+  dsimp only [Function.comp_apply] at hg
+  rw [Smale.WhitneyPairModel.lowerStripCoordinates_lower, d.center t] at hg
+  have hp := tube.chart.map_source' (tube.lowerBoundaryArc_zero_mem_source ht)
+  rw [tube.zero_section, Smale.WhitneyPairModel.lowerBoundaryArc, hg] at hp
+  exact hp
+
+private theorem
+    Smale.TubularBigon.upper_chart_center_mem_target {E M A B : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] {S T : Set M} {a b : ℝ → M}
+    {k l : (ℝ × ℝ) → M} {h : ℝ} {n : ℕ} (tube : Smale.TubularBigon (E := E) S T a b k l h n)
+    (d : Smale.StripNormalData A B (E := E) T l) {t : ℝ} (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    d.chart (Smale.StripCoordinates.center t) ∈ tube.chart.target := by
+  have hg := (tube.upper_germ t ht).eq_of_nhds
+  dsimp only [Function.comp_apply] at hg
+  rw [Smale.WhitneyPairModel.upperStripCoordinates_upper, d.center t] at hg
+  have hp := tube.chart.map_source' (tube.upperBoundaryArc_zero_mem_source ht)
+  rw [tube.zero_section, Smale.WhitneyPairModel.upperBoundaryArc, hg] at hp
+  exact hp
+
+private theorem Smale.TubularBigon.lower_sheetTransition_center_germ {E M A B : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    {S T : Set M} {a b : ℝ → M} {k l : (ℝ × ℝ) → M} {h : ℝ} {n : ℕ}
+    (tube : Smale.TubularBigon (E := E) S T a b k l h n)
+    (d : Smale.StripNormalData A B (E := E) S k) {t : ℝ} (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    (fun s : ℝ => d.sheetTransition tube.chart (s, 0)) =ᶠ[𝓝 t] fun s =>
+      (Smale.WhitneyPairModel.lowerBoundaryArc s, 0) :=
+  d.sheetTransition_center_germ tube.chart tube.zero_section
+    (Smale.WhitneyPairModel.hasDerivAt_lowerBoundaryArc t).continuousAt
+    (tube.lowerBoundaryArc_zero_mem_source ht)
+    (Smale.WhitneyPairModel.lowerStripCoordinates_lower h) (tube.lower_germ t ht)
+
+private theorem Smale.TubularBigon.upper_sheetTransition_center_germ {E M A B : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    {S T : Set M} {a b : ℝ → M} {k l : (ℝ × ℝ) → M} {h : ℝ} {n : ℕ}
+    (tube : Smale.TubularBigon (E := E) S T a b k l h n)
+    (d : Smale.StripNormalData A B (E := E) T l) {t : ℝ} (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    (fun s : ℝ => d.sheetTransition tube.chart (s, 0)) =ᶠ[𝓝 t] fun s =>
+      (Smale.WhitneyPairModel.upperBoundaryArc h s, 0) :=
+  d.sheetTransition_center_germ tube.chart tube.zero_section
+    (Smale.WhitneyPairModel.hasDerivAt_upperBoundaryArc h t).continuousAt
+    (tube.upperBoundaryArc_zero_mem_source ht)
+    (Smale.WhitneyPairModel.upperStripCoordinates_upper h) (tube.upper_germ t ht)
+
+private theorem
+    Smale.TubularBigon.lower_sheetDifferential_arc {E M A B : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] {S T : Set M} {a b : ℝ → M}
+    {k l : (ℝ × ℝ) → M} {h : ℝ} {n : ℕ} (tube : Smale.TubularBigon (E := E) S T a b k l h n)
+    (d : Smale.StripNormalData A B (E := E) S k) {t : ℝ} (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    d.sheetDifferential tube.chart t (1, 0) = ((2, 0), 0) :=
+  d.sheetDifferential_arc_of_germ tube.chart ht (tube.lower_chart_center_mem_target d ht)
+    (Smale.WhitneyPairModel.hasDerivAt_lowerBoundaryArc t)
+    (tube.lower_sheetTransition_center_germ d ht)
+
+private theorem
+    Smale.TubularBigon.upper_sheetDifferential_arc {E M A B : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] {S T : Set M} {a b : ℝ → M}
+    {k l : (ℝ × ℝ) → M} {h : ℝ} {n : ℕ} (tube : Smale.TubularBigon (E := E) S T a b k l h n)
+    (d : Smale.StripNormalData A B (E := E) T l) {t : ℝ} (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    d.sheetDifferential tube.chart t (1, 0) = ((2, -4 * h * (2 * t - 1)), 0) :=
+  d.sheetDifferential_arc_of_germ tube.chart ht (tube.upper_chart_center_mem_target d ht)
+    (Smale.WhitneyPairModel.hasDerivAt_upperBoundaryArc h t)
+    (tube.upper_sheetTransition_center_germ d ht)
+
+private theorem Smale.FrameField.det_of_zero_lower_left {D Z : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [FiniteDimensional ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [FiniteDimensional ℝ Z] (T : (D × Z) →L[ℝ] (D × Z)) (hT : ∀ u : D, (T (u, 0)).2 = 0) :
+    T.toLinearMap.det =
+      ((ContinuousLinearMap.fst ℝ D Z).comp
+            (T.comp (ContinuousLinearMap.inl ℝ D Z))).toLinearMap.det *
+        ((ContinuousLinearMap.snd ℝ D Z).comp
+            (T.comp (ContinuousLinearMap.inr ℝ D Z))).toLinearMap.det := by
+  classical
+  let bD := Module.finBasis ℝ D
+  let bZ := Module.finBasis ℝ Z
+  let A := (ContinuousLinearMap.fst ℝ D Z).comp (T.comp (ContinuousLinearMap.inl ℝ D Z))
+  let B := (ContinuousLinearMap.fst ℝ D Z).comp (T.comp (ContinuousLinearMap.inr ℝ D Z))
+  let K := (ContinuousLinearMap.snd ℝ D Z).comp (T.comp (ContinuousLinearMap.inr ℝ D Z))
+  have hmat :
+    LinearMap.toMatrix (bD.prod bZ) (bD.prod bZ) T.toLinearMap =
+      Matrix.fromBlocks (LinearMap.toMatrix bD bD A.toLinearMap)
+        (LinearMap.toMatrix bZ bD B.toLinearMap) 0 (LinearMap.toMatrix bZ bZ K.toLinearMap) := by
+    ext (i | i) (j | j) <;> simp [LinearMap.toMatrix_apply, hT, A, B, K]
+  rw [← LinearMap.det_toMatrix (bD.prod bZ), hmat, Matrix.det_fromBlocks_zero₂₁,
+    LinearMap.det_toMatrix, LinearMap.det_toMatrix]
+
+private theorem Smale.FrameField.det_of_fixed_first_factor {D Z : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [FiniteDimensional ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [FiniteDimensional ℝ Z] (T : (D × Z) →L[ℝ] (D × Z)) (hT : ∀ u : D, T (u, 0) = (u, 0)) :
+    T.toLinearMap.det =
+      ((ContinuousLinearMap.snd ℝ D Z).comp
+          (T.comp (ContinuousLinearMap.inr ℝ D Z))).toLinearMap.det := by
+  classical
+  let bD := Module.finBasis ℝ D
+  let bZ := Module.finBasis ℝ Z
+  let B := (ContinuousLinearMap.fst ℝ D Z).comp (T.comp (ContinuousLinearMap.inr ℝ D Z))
+  let K := (ContinuousLinearMap.snd ℝ D Z).comp (T.comp (ContinuousLinearMap.inr ℝ D Z))
+  have hmat :
+    LinearMap.toMatrix (bD.prod bZ) (bD.prod bZ) T.toLinearMap =
+      Matrix.fromBlocks 1 (LinearMap.toMatrix bZ bD B.toLinearMap) 0
+        (LinearMap.toMatrix bZ bZ K.toLinearMap) := by
+    ext (i | i) (j | j) <;>
+      simp [LinearMap.toMatrix_apply, hT, B, K, Matrix.one_apply, Finsupp.single_apply, eq_comm]
+  rw [← LinearMap.det_toMatrix (bD.prod bZ), hmat, Matrix.det_fromBlocks_zero₂₁, Matrix.det_one,
+    one_mul, LinearMap.det_toMatrix]
+
+private theorem Smale.FrameField.det_frame_eq_det_split_mul_det_coefficient {D Z F : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (j : (D × Z) ≃L[ℝ] F) (G : D →L[ℝ] F) (C L : Z →L[ℝ] F) (h : (G.coprod C).IsInvertible) :
+    (j.symm.toContinuousLinearMap.comp (G.coprod L)).toLinearMap.det =
+      (j.symm.toContinuousLinearMap.comp (G.coprod C)).toLinearMap.det *
+        ((complementQuotient G C).comp L).toLinearMap.det := by
+  let T := G.coprod C
+  let R := G.coprod L
+  let A := T.inverse.comp R
+  have hA : ∀ u : D, A (u, 0) = (u, 0) := by
+    intro u
+    change T.inverse (G u + L 0) = (u, 0)
+    rw [map_zero, add_zero]
+    have hi := h.inverse_apply_self (u, 0)
+    change T.inverse (G u + C 0) = (u, 0) at hi
+    simpa only [map_zero, add_zero] using hi
+  have hblock :
+    (ContinuousLinearMap.snd ℝ D Z).comp (A.comp (ContinuousLinearMap.inr ℝ D Z)) =
+      (complementQuotient G C).comp L := by
+    apply ContinuousLinearMap.ext
+    intro v
+    change (T.inverse (G 0 + L v)).2 = (T.inverse (L v)).2
+    rw [map_zero, zero_add]
+  have hdetA : A.toLinearMap.det = ((complementQuotient G C).comp L).toLinearMap.det := by
+    rw [det_of_fixed_first_factor A hA, hblock]
+  have hfactor :
+    j.symm.toContinuousLinearMap.comp R = (j.symm.toContinuousLinearMap.comp T).comp A := by
+    apply ContinuousLinearMap.ext
+    intro v
+    change j.symm (R v) = j.symm (T (T.inverse (R v)))
+    rw [h.self_apply_inverse]
+  change (j.symm.toContinuousLinearMap.comp R).toLinearMap.det = _
+  rw [hfactor]
+  have hmul :
+    ((j.symm.toContinuousLinearMap.comp T).comp A).toLinearMap.det =
+      (j.symm.toContinuousLinearMap.comp T).toLinearMap.det * A.toLinearMap.det :=
+    map_mul LinearMap.det _ _
+  rw [hmul, hdetA]
+
+private def Smale.PlanarFrame.area (u v : Smale.PlaneImmersion.Plane) : ℝ :=
+  u.1 * v.2 - u.2 * v.1
+
+private def Smale.PlanarFrame.squareLength (u : Smale.PlaneImmersion.Plane) : ℝ :=
+  u.1 ^ 2 + u.2 ^ 2
+
+private def
+    Smale.PlanarFrame.quarterTurn (u : Smale.PlaneImmersion.Plane) : Smale.PlaneImmersion.Plane :=
+  (-u.2, u.1)
+
+private def Smale.PlanarFrame.parallelCoeff (u v : Smale.PlaneImmersion.Plane) : ℝ :=
+  (u.1 * v.1 + u.2 * v.2) / squareLength u
+
+private def Smale.PlanarFrame.transverseCoeff (u v : Smale.PlaneImmersion.Plane) : ℝ :=
+  area u v / squareLength u
+
+private def Smale.PlanarFrame.determinant
+    (L : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) : ℝ :=
+  area (L (1, 0)) (L (0, 1))
+
+private theorem Smale.PlanarFrame.squareLength_pos {u : Smale.PlaneImmersion.Plane} (hu : u ≠ 0) :
+    0 < squareLength u := by
+  have hsq₁ := sq_nonneg u.1
+  have hsq₂ := sq_nonneg u.2
+  by_contra h
+  have hz : u.1 ^ 2 + u.2 ^ 2 ≤ 0 := le_of_not_gt h
+  have hu₁ : u.1 = 0 := by nlinarith
+  have hu₂ : u.2 = 0 := by nlinarith
+  exact hu (Prod.ext hu₁ hu₂)
+
+private theorem
+    Smale.PlanarFrame.decompose_second_column {u : Smale.PlaneImmersion.Plane} (hu : u ≠ 0)
+    (v : Smale.PlaneImmersion.Plane) :
+    parallelCoeff u v • u + transverseCoeff u v • quarterTurn u = v := by
+  have hnorm := (squareLength_pos hu).ne'
+  ext <;> dsimp [parallelCoeff, transverseCoeff, area, quarterTurn]
+  · field_simp
+    simp only [squareLength]
+    ring
+  · field_simp
+    simp only [squareLength]
+    ring
+
+private theorem Smale.PlanarFrame.area_transverse (u : Smale.PlaneImmersion.Plane) (a b : ℝ) :
+    area u (a • u + b • quarterTurn u) = b * squareLength u := by
+  dsimp [area, quarterTurn, squareLength]
+  ring
+
+private theorem Smale.PlanarFrame.linearMap_first (u v : Smale.PlaneImmersion.Plane) :
+    Smale.PlaneImmersion.linearMap (u, v) (1, 0) = u := by
+  simp [Smale.PlaneImmersion.linearMap_apply]
+
+private theorem Smale.PlanarFrame.linearMap_second (u v : Smale.PlaneImmersion.Plane) :
+    Smale.PlaneImmersion.linearMap (u, v) (0, 1) = v := by
+  simp [Smale.PlaneImmersion.linearMap_apply]
+
+private theorem Smale.PlanarFrame.linearMap_columns
+    (L : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) :
+    Smale.PlaneImmersion.linearMap (L (1, 0), L (0, 1)) = L := by
+  apply ContinuousLinearMap.ext
+  intro p
+  have hp : p = p.1 • ((1 : ℝ), 0) + p.2 • (0, 1) := by ext <;> simp
+  rw [Smale.PlaneImmersion.linearMap_apply, ← map_smul, ← map_smul, ← map_add, ← hp]
+
+private theorem Smale.PlanarFrame.determinant_linearMap (u v : Smale.PlaneImmersion.Plane) :
+    determinant (Smale.PlaneImmersion.linearMap (u, v)) = area u v := by
+  rw [determinant, linearMap_first, linearMap_second]
+
+private theorem Smale.PlanarFrame.determinant_eq_det
+    (L : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) :
+    determinant L = L.toLinearMap.det := by
+  rw [← LinearMap.det_toMatrix (Module.Basis.finTwoProd ℝ), Matrix.det_fin_two]
+  simp [LinearMap.toMatrix_apply, Module.Basis.coe_finTwoProd_repr, determinant, area, mul_comm]
+
+private theorem Smale.PlanarFrame.bijective_of_determinant_ne_zero
+    (L : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) (hL : determinant L ≠ 0) :
+    Function.Bijective L := by
+  have hdet : L.toLinearMap.det ≠ 0 := by rwa [determinant_eq_det] at hL
+  have hker : L.toLinearMap.ker = ⊥ := by
+    by_contra h
+    exact hdet (LinearMap.det_eq_zero_iff_ker_ne_bot.mpr h)
+  have hi : Function.Injective L := LinearMap.ker_eq_bot.mp hker
+  exact ⟨hi, (LinearMap.injective_iff_surjective_of_finrank_eq_finrank rfl).mp hi⟩
+
+private theorem Smale.PlanarFrame.continuous_determinant : Continuous determinant := by
+  have h₁ :
+    Continuous
+      (fun L : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane => L (1, 0)) :=
+    continuous_id.clm_apply continuous_const
+  have h₂ :
+    Continuous
+      (fun L : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane => L (0, 1)) :=
+    continuous_id.clm_apply continuous_const
+  exact (h₁.fst.mul h₂.snd).sub (h₁.snd.mul h₂.fst)
+
+private theorem Smale.PlanarFrame.continuous_quarterTurn : Continuous quarterTurn :=
+  continuous_snd.neg.prodMk continuous_fst
+
+private theorem Smale.PlanarFrame.continuous_linearMap :
+    Continuous
+      (Smale.PlaneImmersion.linearMap :
+        (Smale.PlaneImmersion.Plane × Smale.PlaneImmersion.Plane) →
+          (Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane)) := by
+  exact
+    ((ContinuousLinearMap.smulRightL ℝ Smale.PlaneImmersion.Plane Smale.PlaneImmersion.Plane
+              (ContinuousLinearMap.fst ℝ ℝ ℝ)).continuous.comp
+          continuous_fst).add
+      ((ContinuousLinearMap.smulRightL ℝ Smale.PlaneImmersion.Plane Smale.PlaneImmersion.Plane
+            (ContinuousLinearMap.snd ℝ ℝ ℝ)).continuous.comp
+        continuous_snd)
+
+private def Smale.IntersectionCoordinates.jointBlock {A B F : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (j : (A × B) ≃L[ℝ] F) (P : (ℝ × A) →L[ℝ] (Smale.PlaneImmersion.Plane × F))
+    (Q : (ℝ × B) →L[ℝ] (Smale.PlaneImmersion.Plane × F)) :
+    (Smale.PlaneImmersion.Plane × (A × B)) →L[ℝ] (Smale.PlaneImmersion.Plane × (A × B)) :=
+  (ContinuousLinearEquiv.prodCongr (ContinuousLinearEquiv.refl ℝ Smale.PlaneImmersion.Plane)
+        j.symm).toContinuousLinearMap.comp
+    ((P.coprod Q).comp
+      (ContinuousLinearEquiv.prodProdProdComm ℝ ℝ A ℝ B).symm.toContinuousLinearMap)
+
+private theorem
+    Smale.IntersectionCoordinates.jointBlock_apply {A B F : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (j : (A × B) ≃L[ℝ] F) (P : (ℝ × A) →L[ℝ] (Smale.PlaneImmersion.Plane × F))
+    (Q : (ℝ × B) →L[ℝ] (Smale.PlaneImmersion.Plane × F))
+    (p : Smale.PlaneImmersion.Plane × (A × B)) :
+    jointBlock j P Q p =
+      ((P (p.1.1, p.2.1) + Q (p.1.2, p.2.2)).1,
+        j.symm ((P (p.1.1, p.2.1) + Q (p.1.2, p.2.2)).2)) :=
+  rfl
+
+private theorem Smale.IntersectionCoordinates.map_first_axis {A F : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (P : (ℝ × A) →L[ℝ] (Smale.PlaneImmersion.Plane × F)) (s : ℝ) : P (s, 0) = s • P (1, 0) := by
+  have hs : (s, (0 : A)) = s • ((1 : ℝ), 0) := by ext <;> simp
+  rw [hs, map_smul]
+
+private theorem Smale.IntersectionCoordinates.det_jointBlock {A B F : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [FiniteDimensional ℝ A] [FiniteDimensional ℝ B] (j : (A × B) ≃L[ℝ] F)
+    (P : (ℝ × A) →L[ℝ] (Smale.PlaneImmersion.Plane × F))
+    (Q : (ℝ × B) →L[ℝ] (Smale.PlaneImmersion.Plane × F)) {u v : Smale.PlaneImmersion.Plane}
+    (hP : P (1, 0) = (u, 0)) (hQ : Q (1, 0) = (v, 0)) :
+    (jointBlock j P Q).toLinearMap.det =
+      (Smale.PlaneImmersion.linearMap (u, v)).toLinearMap.det *
+        (j.symm.toContinuousLinearMap.comp
+            (((ContinuousLinearMap.snd ℝ Smale.PlaneImmersion.Plane F).comp
+                  (P.comp (ContinuousLinearMap.inr ℝ ℝ A))).coprod
+              ((ContinuousLinearMap.snd ℝ Smale.PlaneImmersion.Plane F).comp
+                (Q.comp (ContinuousLinearMap.inr ℝ ℝ B))))).toLinearMap.det := by
+  have hzero : ∀ w : Smale.PlaneImmersion.Plane, (jointBlock j P Q (w, 0)).2 = 0 := by
+    intro w
+    rw [jointBlock_apply]
+    change j.symm ((P (w.1, 0) + Q (w.2, 0)).2) = 0
+    rw [map_first_axis P w.1, map_first_axis Q w.2, hP, hQ]
+    simp
+  have hfirst :
+    (ContinuousLinearMap.fst ℝ Smale.PlaneImmersion.Plane (A × B)).comp
+        ((jointBlock j P Q).comp (ContinuousLinearMap.inl ℝ Smale.PlaneImmersion.Plane (A × B))) =
+      Smale.PlaneImmersion.linearMap (u, v) := by
+    apply ContinuousLinearMap.ext
+    intro w
+    change (jointBlock j P Q (w, 0)).1 = w.1 • u + w.2 • v
+    rw [jointBlock_apply]
+    change (P (w.1, 0) + Q (w.2, 0)).1 = w.1 • u + w.2 • v
+    rw [map_first_axis P w.1, map_first_axis Q w.2, hP, hQ]
+    rfl
+  have hsecond :
+    (ContinuousLinearMap.snd ℝ Smale.PlaneImmersion.Plane (A × B)).comp
+        ((jointBlock j P Q).comp (ContinuousLinearMap.inr ℝ Smale.PlaneImmersion.Plane (A × B))) =
+      j.symm.toContinuousLinearMap.comp
+        (((ContinuousLinearMap.snd ℝ Smale.PlaneImmersion.Plane F).comp
+              (P.comp (ContinuousLinearMap.inr ℝ ℝ A))).coprod
+          ((ContinuousLinearMap.snd ℝ Smale.PlaneImmersion.Plane F).comp
+            (Q.comp (ContinuousLinearMap.inr ℝ ℝ B)))) := by
+    apply ContinuousLinearMap.ext
+    intro w
+    rfl
+  rw [Smale.FrameField.det_of_zero_lower_left _ hzero, hfirst, hsecond]
+
+private theorem Smale.FrameField.bijective_coprod_of_orthogonal_range {D Z F : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [NormedAddCommGroup F] [InnerProductSpace ℝ F] (L : D →L[ℝ] F)
+    (B : Z →L[ℝ] F) (hL : Function.Injective L) (hB : Function.Injective B)
+    (hr : B.range = L.rangeᗮ) : Function.Bijective (L.coprod B) := by
+  have hd : Disjoint L.range B.range := by
+    rw [hr]
+    exact L.range.orthogonal_disjoint
+  constructor
+  · change Function.Injective (L.toLinearMap.coprod B.toLinearMap)
+    rw [← LinearMap.ker_eq_bot, LinearMap.ker_coprod_of_disjoint_range _ _ hd,
+      LinearMap.ker_eq_bot.mpr hL, LinearMap.ker_eq_bot.mpr hB, Submodule.prod_bot]
+  · change Function.Surjective (L.toLinearMap.coprod B.toLinearMap)
+    rw [← LinearMap.range_eq_top, LinearMap.range_coprod, hr]
+    exact L.range.isCompl_orthogonal.sup_eq_top
+
+private theorem Smale.FrameField.exists_smooth_complement_near_starConvex_on {E D F : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup D] [NormedSpace ℝ D]
+    [FiniteDimensional ℝ D] [NormedAddCommGroup F] [InnerProductSpace ℝ F] [FiniteDimensional ℝ F]
+    {L : E → (D →L[ℝ] F)} {O : Set E} (hO : IsOpen O) (hL : ContDiffOn ℝ ∞ L O) {K : Set E}
+    (hK : IsCompact K) (hstar : StarConvex ℝ (0 : E) K) (h0 : (0 : E) ∈ K) (hKO : K ⊆ O)
+    (hi : ∀ x ∈ K, Function.Injective (L x)) (n : ℕ)
+    (hdim : Module.finrank ℝ D + n = Module.finrank ℝ F) :
+    ∃ V : Set E,
+      IsOpen V ∧
+        K ⊆ V ∧
+          ∃ B : E → (EuclideanSpace ℝ (Fin n) →L[ℝ] F),
+            ContDiffOn ℝ ∞ B V ∧
+              (∀ x ∈ K, (B x).range = (L x).rangeᗮ) ∧
+                ∀ x ∈ V, Function.Bijective ((L x).coprod (B x)) := by
+  let φ : EuclideanSpace ℝ (Fin (Module.finrank ℝ D)) ≃L[ℝ] D :=
+    ContinuousLinearEquiv.ofFinrankEq finrank_euclideanSpace_fin
+  let A (x : E) := (L x).comp φ.toContinuousLinearMap
+  have hA : ContDiffOn ℝ ∞ A O := hL.clm_comp contDiffOn_const
+  have hAr (x : E) : (A x).range = (L x).range :=
+    LinearMap.range_comp_of_range_eq_top _ (LinearMap.range_eq_top.mpr φ.surjective)
+  let U : Set E := O ∩ {x | Function.Injective (L x)}
+  have hU : IsOpen U :=
+    hL.continuousOn.isOpen_inter_preimage hO ContinuousLinearMap.isOpen_injective
+  have hKU : K ⊆ U := fun x hx => ⟨hKO hx, hi x hx⟩
+  let P (x : E) : F →L[ℝ] F := 1 - NoExotic.gramProjection (A x)
+  have hP (x : E) (hx : x ∈ U) : P x = ((L x).rangeᗮ).starProjection := by
+    dsimp only [P]
+    rw [NoExotic.gramProjection_eq_starProjection _ (hx.2.comp φ.injective)]
+    simp only [hAr]
+    exact (Submodule.starProjection_orthogonal' (L x).range).symm
+  have hsP : ContDiffOn ℝ ∞ P U := by
+    intro x hx
+    have hg : ContDiffAt ℝ ∞ (fun y => NoExotic.gramProjection (A y)) x :=
+      (NoExotic.contMDiffAt_gramProjection (hA.contDiffAt (hO.mem_nhds hx.1)).contMDiffAt
+          (hx.2.comp φ.injective)).contDiffAt
+    exact (contDiffAt_const.sub hg).contDiffWithinAt
+  have hidem : ∀ x ∈ K, IsIdempotentElem (P x) := by
+    intro x hx
+    rw [hP x (hKU hx)]
+    exact ((L x).rangeᗮ).isIdempotentElem_starProjection
+  obtain ⟨W, hW, hKW, B₀, hB₀, hB₀i⟩ :=
+    Smale.DiskFraming.exists_smooth_frame_near_starConvex hK hstar hU hKU P hidem hsP
+  have hr (x : E) (hx : x ∈ K) : (P x).range = (L x).rangeᗮ := by
+    rw [hP x (hKU hx), Submodule.range_starProjection]
+  have hcenter : Module.finrank ℝ (P 0).range = n := by
+    have hrank : Module.finrank ℝ (L 0).range = Module.finrank ℝ D :=
+      LinearMap.finrank_range_of_inj (hi 0 h0)
+    have hs := (L 0).range.finrank_add_finrank_orthogonal
+    rw [hrank] at hs
+    rw [hr 0 h0]
+    omega
+  let ψ : EuclideanSpace ℝ (Fin n) ≃L[ℝ] (P 0).range :=
+    ContinuousLinearEquiv.ofFinrankEq (finrank_euclideanSpace_fin.trans hcenter.symm)
+  let B (x : E) := (B₀ x).comp ψ.toContinuousLinearMap
+  have hB : ContDiffOn ℝ ∞ B (W ∩ O) := (hB₀.clm_comp contDiffOn_const).mono Set.inter_subset_left
+  have hBr : ∀ x ∈ K, (B x).range = (L x).rangeᗮ := by
+    intro x hx
+    calc
+      (B x).range = (B₀ x).range :=
+        LinearMap.range_comp_of_range_eq_top _ (LinearMap.range_eq_top.mpr ψ.surjective)
+      _ = (P x).range := (hB₀i x hx).2
+      _ = (L x).rangeᗮ := hr x hx
+  have hBi : ∀ x ∈ K, Function.Injective (B x) := fun x hx => (hB₀i x hx).1.comp ψ.injective
+  let T (x : E) := (L x).coprod (B x)
+  have hT : ContDiffOn ℝ ∞ T (W ∩ O) := by
+    have hs :=
+      ((hL.mono Set.inter_subset_right).clm_comp
+            (contDiffOn_const (c := ContinuousLinearMap.fst ℝ D (EuclideanSpace ℝ (Fin n))))).add
+        (hB.clm_comp
+          (contDiffOn_const (c := ContinuousLinearMap.snd ℝ D (EuclideanSpace ℝ (Fin n)))))
+    exact hs
+  have hTi : ∀ x ∈ K, Function.Bijective (T x) := fun x hx =>
+    bijective_coprod_of_orthogonal_range (L x) (B x) (hi x hx) (hBi x hx) (hBr x hx)
+  let V : Set E := (W ∩ O) ∩ {x | Function.Injective (T x)}
+  have hV : IsOpen V :=
+    hT.continuousOn.isOpen_inter_preimage (hW.inter hO) ContinuousLinearMap.isOpen_injective
+  refine
+    ⟨V, hV, fun x hx => ⟨⟨hKW hx, hKO hx⟩, (hTi x hx).1⟩, B, hB.mono Set.inter_subset_left, hBr,
+      ?_⟩
+  intro x hx
+  have hdim' : Module.finrank ℝ (D × EuclideanSpace ℝ (Fin n)) = Module.finrank ℝ F := by
+    rw [Module.finrank_prod, finrank_euclideanSpace_fin]
+    exact hdim
+  exact ⟨hx.2, (LinearMap.injective_iff_surjective_of_finrank_eq_finrank hdim').mp hx.2⟩
+
+private theorem Smale.FrameField.exists_smooth_complement_near_starConvex {E D F : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup D] [NormedSpace ℝ D]
+    [FiniteDimensional ℝ D] [NormedAddCommGroup F] [InnerProductSpace ℝ F] [FiniteDimensional ℝ F]
+    {L : E → (D →L[ℝ] F)} (hL : ContDiff ℝ ∞ L) {K : Set E} (hK : IsCompact K)
+    (hstar : StarConvex ℝ (0 : E) K) (h0 : (0 : E) ∈ K) (hi : ∀ x ∈ K, Function.Injective (L x))
+    (n : ℕ) (hdim : Module.finrank ℝ D + n = Module.finrank ℝ F) :
+    ∃ V : Set E,
+      IsOpen V ∧
+        K ⊆ V ∧
+          ∃ B : E → (EuclideanSpace ℝ (Fin n) →L[ℝ] F),
+            ContDiffOn ℝ ∞ B V ∧
+              (∀ x ∈ K, (B x).range = (L x).rangeᗮ) ∧
+                ∀ x ∈ V, Function.Bijective ((L x).coprod (B x)) :=
+  exists_smooth_complement_near_starConvex_on isOpen_univ hL.contDiffOn hK hstar h0
+    (Set.subset_univ K) hi n hdim
+
+private theorem Smale.TubularBigon.lower_sheetFrame {E M A B : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] {S T : Set M} {a b : ℝ → M}
+    {k₀ k₁ : (ℝ × ℝ) → M} {h : ℝ} {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : (ℝ × ℝ) → M} {n : ℕ} (tube : Smale.TubularBigon (E := E) S T a b k.map l h n)
+    (d : Smale.StripNormalData A B (E := E) S k.map) :
+    (∃ U : Set ℝ,
+        IsOpen U ∧ Set.Icc (0 : ℝ) 1 ⊆ U ∧ ContDiffOn ℝ ∞ (d.normalFrame tube.chart) U) ∧
+      ∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Injective (d.normalFrame tube.chart t) := by
+  have hpoint : ∀ t ∈ Set.Icc (0 : ℝ) 1, (2 * t - 1, 0) ∈ Smale.WhitneyPairModel.bigon h := by
+    intro t ht
+    have hf : (2 * t - 1, 0) ∈ frontier (Smale.WhitneyPairModel.bigon h) :=
+      (Smale.WhitneyPairModel.mem_frontier_bigon_iff_exists_time tube.height_pos _).mpr
+        ⟨t, ht, Or.inl rfl⟩
+    exact ((Smale.WhitneyPairModel.mem_frontier_bigon_iff h _).mp hf).1
+  have hsource : ∀ t ∈ Set.Icc (0 : ℝ) 1, ((2 * t - 1, 0), 0) ∈ tube.chart.source := fun t ht =>
+    tube.source_contains ⟨hpoint t ht, Metric.mem_closedBall_self tube.radius_pos.le⟩
+  constructor
+  · apply d.exists_open_normalFrame_domain tube.chart
+    intro t ht
+    have hp := tube.chart.map_source' (hsource t ht)
+    rw [tube.zero_section, tube.lower t ht] at hp
+    rw [← d.center t, k.center t ht]
+    exact hp
+  · intro t ht
+    have hkt : (t, (0 : ℝ)) ∈ k.domain :=
+      k.contains_strip ⟨ht, ⟨neg_nonpos.mpr k.width_pos.le, k.width_pos.le⟩⟩
+    have hcs :
+      Function.Surjective
+        (fderiv ℝ (Smale.WhitneyPairModel.lowerStripCoordinates h) (2 * t - 1, 0)) :=
+      (LinearMap.injective_iff_surjective_of_finrank_eq_finrank rfl).mp
+        (Smale.WhitneyPairModel.injective_fderiv_lowerStripCoordinates tube.height_pos.ne'
+          (2 * t - 1))
+    exact
+      d.injective_normalFrame_of_strip_germ tube.chart ht
+        (k.smooth.contMDiffAt (k.open_domain.mem_nhds hkt)) tube.zero_section (hsource t ht)
+        (Smale.WhitneyPairModel.contDiff_lowerStripCoordinates tube.height_pos.ne').contDiffAt
+        (Smale.WhitneyPairModel.lowerStripCoordinates_lower h t) hcs (tube.lower_germ t ht)
+
+private theorem Smale.TubularBigon.upper_sheetFrame {E M A B : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] {S T : Set M} {a b : ℝ → M}
+    {k₀ k₁ : (ℝ × ℝ) → M} {h : ℝ} {l : Smale.CleanStripPatch (E := E) T S b k₀ k₁}
+    {k : (ℝ × ℝ) → M} {n : ℕ} (tube : Smale.TubularBigon (E := E) S T a b k l.map h n)
+    (d : Smale.StripNormalData A B (E := E) T l.map) :
+    (∃ U : Set ℝ,
+        IsOpen U ∧ Set.Icc (0 : ℝ) 1 ⊆ U ∧ ContDiffOn ℝ ∞ (d.normalFrame tube.chart) U) ∧
+      ∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Injective (d.normalFrame tube.chart t) := by
+  have hpoint :
+    ∀ t ∈ Set.Icc (0 : ℝ) 1,
+      (2 * t - 1, h * (1 - (2 * t - 1) ^ 2)) ∈ Smale.WhitneyPairModel.bigon h := by
+    intro t ht
+    have hf :
+      (2 * t - 1, h * (1 - (2 * t - 1) ^ 2)) ∈ frontier (Smale.WhitneyPairModel.bigon h) :=
+      (Smale.WhitneyPairModel.mem_frontier_bigon_iff_exists_time tube.height_pos _).mpr
+        ⟨t, ht, Or.inr rfl⟩
+    exact ((Smale.WhitneyPairModel.mem_frontier_bigon_iff h _).mp hf).1
+  have hsource :
+    ∀ t ∈ Set.Icc (0 : ℝ) 1, ((2 * t - 1, h * (1 - (2 * t - 1) ^ 2)), 0) ∈ tube.chart.source :=
+    fun t ht => tube.source_contains ⟨hpoint t ht, Metric.mem_closedBall_self tube.radius_pos.le⟩
+  constructor
+  · apply d.exists_open_normalFrame_domain tube.chart
+    intro t ht
+    have hp := tube.chart.map_source' (hsource t ht)
+    rw [tube.zero_section, tube.upper t ht] at hp
+    rw [← d.center t, l.center t ht]
+    exact hp
+  · intro t ht
+    have hlt : (t, (0 : ℝ)) ∈ l.domain :=
+      l.contains_strip ⟨ht, ⟨neg_nonpos.mpr l.width_pos.le, l.width_pos.le⟩⟩
+    have hcs :
+      Function.Surjective
+        (fderiv ℝ (Smale.WhitneyPairModel.upperStripCoordinates h)
+          (2 * t - 1, h * (1 - (2 * t - 1) ^ 2))) :=
+      (LinearMap.injective_iff_surjective_of_finrank_eq_finrank rfl).mp
+        (Smale.WhitneyPairModel.injective_fderiv_upperStripCoordinates tube.height_pos.ne'
+          (2 * t - 1))
+    exact
+      d.injective_normalFrame_of_strip_germ tube.chart ht
+        (l.smooth.contMDiffAt (l.open_domain.mem_nhds hlt)) tube.zero_section (hsource t ht)
+        (Smale.WhitneyPairModel.contDiff_upperStripCoordinates tube.height_pos.ne').contDiffAt
+        (Smale.WhitneyPairModel.upperStripCoordinates_upper h t) hcs (tube.upper_germ t ht)
+
+private theorem Smale.TubularBigon.upper_sheetFrame_complement_of_finrank {E M A B : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    {S T : Set M} {a b : ℝ → M} {k₀ k₁ : (ℝ × ℝ) → M} {h : ℝ} [FiniteDimensional ℝ A]
+    {l : Smale.CleanStripPatch (E := E) T S b k₀ k₁} {k : (ℝ × ℝ) → M} {n : ℕ}
+    (tube : Smale.TubularBigon (E := E) S T a b k l.map h n)
+    (d : Smale.StripNormalData A B (E := E) T l.map) (m : ℕ) (hdim : Module.finrank ℝ A + m = n) :
+    ∃ V : Set ℝ,
+      IsOpen V ∧
+        Set.Icc (0 : ℝ) 1 ⊆ V ∧
+          ContDiffOn ℝ ∞ (d.normalFrame tube.chart) V ∧
+            ∃ C : ℝ → (EuclideanSpace ℝ (Fin m) →L[ℝ] EuclideanSpace ℝ (Fin n)),
+              ContDiffOn ℝ ∞ C V ∧
+                (∀ t ∈ Set.Icc (0 : ℝ) 1, (C t).range = (d.normalFrame tube.chart t).rangeᗮ) ∧
+                  ∀ t ∈ V, Function.Bijective ((d.normalFrame tube.chart t).coprod (C t)) := by
+  obtain ⟨⟨U, hU, hIU, hs⟩, hi⟩ := tube.upper_sheetFrame d
+  have hstar : StarConvex ℝ (0 : ℝ) (Set.Icc (0 : ℝ) 1) :=
+    (convex_Icc (0 : ℝ) 1).starConvex (by simp)
+  have hdim' : Module.finrank ℝ A + m = Module.finrank ℝ (EuclideanSpace ℝ (Fin n)) := by
+    simpa only [finrank_euclideanSpace_fin] using hdim
+  obtain ⟨W, hW, hIW, C, hC, hr, hc⟩ :=
+    Smale.FrameField.exists_smooth_complement_near_starConvex_on hU hs
+      CompactIccSpace.isCompact_Icc hstar (by simp) hIU hi m hdim'
+  exact
+    ⟨W ∩ U, hW.inter hU, fun t ht => ⟨hIW ht, hIU ht⟩, hs.mono Set.inter_subset_right, C,
+      hC.mono Set.inter_subset_left, hr, fun t ht => hc t ht.1⟩
+
+private def Smale.DiskFraming.puncturedModel (B : Type*) [NormedAddCommGroup B] :
+    TopologicalSpace.Opens B :=
+  ⟨{0}ᶜ, isClosed_singleton.isOpen_compl⟩
+
+private theorem Smale.DiskFraming.exists_smooth_punctured_curve_with_germ {B : Type*}
+    [NormedAddCommGroup B] [NormedSpace ℝ B] {a : ℝ → B} {U : Set ℝ} {t₀ : ℝ}
+    (ha : ContDiffOn ℝ ∞ a U) (hU : IsOpen U) (ht₀ : t₀ ∈ U) (ha0 : a t₀ ≠ 0) :
+    ∃ f : C(ℝ, puncturedModel B),
+      ContMDiff 𝓘(ℝ, ℝ) 𝓘(ℝ, B) ∞ f ∧ (fun t => (f t : B)) =ᶠ[𝓝 t₀] a := by
+  classical
+  let A : ℝ → puncturedModel B := fun t => if h : a t = 0 then ⟨a t₀, ha0⟩ else ⟨a t, h⟩
+  let V := U ∩ a ⁻¹' ({0}ᶜ : Set B)
+  have hV : IsOpen V := ha.continuousOn.isOpen_inter_preimage hU isClosed_singleton.isOpen_compl
+  have htV : t₀ ∈ V := ⟨ht₀, ha0⟩
+  have hval {t : ℝ} (ht : t ∈ V) : (Subtype.val ∘ A) =ᶠ[𝓝 t] a := by
+    filter_upwards [hV.mem_nhds ht] with s hs
+    have hs0 : a s ≠ 0 := hs.2
+    simp only [Function.comp_apply, A, dite_eq_right hs0]
+  have hA : ContMDiffOn 𝓘(ℝ, ℝ) 𝓘(ℝ, B) ∞ A V := by
+    intro t ht
+    have haAt : ContMDiffAt 𝓘(ℝ, ℝ) 𝓘(ℝ, B) ∞ a t :=
+      (ha.contDiffAt (hU.mem_nhds ht.1)).contMDiffAt
+    have hvalAt := haAt.congr_of_eventuallyEq (hval ht)
+    exact ((ContMDiffAt.subtypeVal_comp_iff (puncturedModel B) A t).mp hvalAt).contMDiffWithinAt
+  obtain ⟨f, hf, hfgerm⟩ := Smale.exists_smooth_curve_with_germ_at hA hV htV
+  refine ⟨f, hf, ?_⟩
+  filter_upwards [hfgerm, hval htV] with t ht htval
+  exact (congrArg Subtype.val ht).trans htval
+
+public
+theorem Smale.DiskFraming.exists_nonzero_smooth_curve_with_endpoint_germs {B : Type*}
+    [NormedAddCommGroup B] [NormedSpace ℝ B] [FiniteDimensional ℝ B] {a b : ℝ → B} {U V : Set ℝ}
+    (ha : ContDiffOn ℝ ∞ a U) (hb : ContDiffOn ℝ ∞ b V) (hU : IsOpen U) (hV : IsOpen V)
+    (h0U : (0 : ℝ) ∈ U) (h1V : (1 : ℝ) ∈ V) (ha0 : a 0 ≠ 0) (hb1 : b 1 ≠ 0)
+    (hdim : 2 ≤ Module.finrank ℝ B) :
+    ∃ v : ℝ → B, ContDiff ℝ ∞ v ∧ (∀ t, v t ≠ 0) ∧ (v =ᶠ[𝓝 (0 : ℝ)] a) ∧ (v =ᶠ[𝓝 (1 : ℝ)] b) := by
+  obtain ⟨a', ha', heqa⟩ := exists_smooth_punctured_curve_with_germ ha hU h0U ha0
+  obtain ⟨b', hb', heqb⟩ := exists_smooth_punctured_curve_with_germ hb hV h1V hb1
+  have hrank : 1 < Module.rank ℝ B := by
+    rw [← Module.finrank_eq_rank]
+    exact_mod_cast (show 1 < Module.finrank ℝ B by omega)
+  let : PathConnectedSpace (puncturedModel B) :=
+    isPathConnected_iff_pathConnectedSpace.mp
+      (isPathConnected_compl_singleton_of_one_lt_rank hrank (0 : B))
+  let γ := PathConnectedSpace.somePath (a' 0) (b' 1)
+  obtain ⟨f, hf, hfa, hfb⟩ := Smale.exists_smooth_curve_with_endpoint_germs a' b' ha' hb' γ
+  let v : ℝ → B := fun t => (f t : B)
+  have hv : ContDiff ℝ ∞ v :=
+    ((contMDiff_subtype_val (I := 𝓘(ℝ, B)) (U := puncturedModel B)).comp hf).contDiff
+  refine ⟨v, hv, fun t => (f t).property, ?_, ?_⟩
+  · filter_upwards [Iio_mem_nhds (show (0 : ℝ) < 1 / 8 by norm_num), heqa] with t ht hta
+    change t < 1 / 8 at ht
+    exact (congrArg Subtype.val (hfa ht.le)).trans hta
+  · filter_upwards [Ioi_mem_nhds (show (7 / 8 : ℝ) < 1 by norm_num), heqb] with t ht htb
+    change 7 / 8 < t at ht
+    exact (congrArg Subtype.val (hfb ht.le)).trans htb
+
+private def Smale.PlanarFrame.determinantComponent (σ : ℝ) :
+    TopologicalSpace.Opens (Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) :=
+  ⟨{L | 0 < σ * determinant L},
+    isOpen_lt continuous_const (continuous_const.mul continuous_determinant)⟩
+
+private theorem Smale.PlanarFrame.first_column_ne_zero {σ : ℝ} (L : determinantComponent σ) :
+    (L : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) (1, 0) ≠ 0 := by
+  intro hz
+  have h := L.property
+  change
+    0 <
+      σ *
+        area ((L : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) (1, 0))
+          ((L : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) (0, 1)) at h
+  rw [hz] at h
+  simp [area] at h
+
+private theorem Smale.PlanarFrame.signed_transverseCoeff_pos {σ : ℝ} (L : determinantComponent σ) :
+    0 <
+      σ *
+        transverseCoeff ((L : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) (1, 0))
+          ((L : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) (0, 1)) := by
+  rw [transverseCoeff, ← mul_div_assoc]
+  exact div_pos L.property (squareLength_pos (first_column_ne_zero L))
+
+private theorem Smale.PlanarFrame.nonempty_path_determinantComponent {σ : ℝ}
+    (a b : determinantComponent σ) : Nonempty (Path a b) := by
+  have hrank : 1 < Module.rank ℝ Smale.PlaneImmersion.Plane := by
+    rw [← Module.finrank_eq_rank]
+    norm_num [Smale.PlaneImmersion.Plane, Module.finrank_prod, Module.finrank_self]
+  let : PathConnectedSpace (Smale.DiskFraming.puncturedModel Smale.PlaneImmersion.Plane) :=
+    isPathConnected_iff_pathConnectedSpace.mp
+      (isPathConnected_compl_singleton_of_one_lt_rank hrank (0 : Smale.PlaneImmersion.Plane))
+  let a₁ : Smale.DiskFraming.puncturedModel Smale.PlaneImmersion.Plane :=
+    ⟨(a : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) (1, 0),
+      first_column_ne_zero a⟩
+  let b₁ : Smale.DiskFraming.puncturedModel Smale.PlaneImmersion.Plane :=
+    ⟨(b : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) (1, 0),
+      first_column_ne_zero b⟩
+  let γ := PathConnectedSpace.somePath a₁ b₁
+  let v : unitInterval → Smale.PlaneImmersion.Plane := fun t => (γ t : Smale.PlaneImmersion.Plane)
+  have hv : Continuous v := continuous_subtype_val.comp γ.continuous
+  have hvne (t : unitInterval) : v t ≠ 0 := (γ t).property
+  let α₀ :=
+    parallelCoeff ((a : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) (1, 0))
+      ((a : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) (0, 1))
+  let α₁ :=
+    parallelCoeff ((b : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) (1, 0))
+      ((b : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) (0, 1))
+  let β₀ :=
+    transverseCoeff ((a : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) (1, 0))
+      ((a : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) (0, 1))
+  let β₁ :=
+    transverseCoeff ((b : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) (1, 0))
+      ((b : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) (0, 1))
+  let α (t : unitInterval) : ℝ := (1 - (t : ℝ)) * α₀ + (t : ℝ) * α₁
+  let β (t : unitInterval) : ℝ := (1 - (t : ℝ)) * β₀ + (t : ℝ) * β₁
+  have hα : Continuous α :=
+    ((continuous_const.sub continuous_subtype_val).mul continuous_const).add
+      (continuous_subtype_val.mul continuous_const)
+  have hβ : Continuous β :=
+    ((continuous_const.sub continuous_subtype_val).mul continuous_const).add
+      (continuous_subtype_val.mul continuous_const)
+  have hβpos (t : unitInterval) : 0 < σ * β t := by
+    have hpos : 0 < (1 - (t : ℝ)) * (σ * β₀) + (t : ℝ) * (σ * β₁) :=
+      (convex_Ioi (0 : ℝ)) (signed_transverseCoeff_pos a) (signed_transverseCoeff_pos b)
+        (sub_nonneg.mpr t.property.2) t.property.1 (by ring)
+    have heq : σ * β t = (1 - (t : ℝ)) * (σ * β₀) + (t : ℝ) * (σ * β₁) := by
+      dsimp only [β]
+      ring
+    rwa [heq]
+  let F (t : unitInterval) : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane :=
+    Smale.PlaneImmersion.linearMap (v t, α t • v t + β t • quarterTurn (v t))
+  have hF : Continuous F :=
+    continuous_linearMap.comp
+      (hv.prodMk ((hα.smul hv).add (hβ.smul (continuous_quarterTurn.comp hv))))
+  have hcomponent (t : unitInterval) : F t ∈ determinantComponent σ := by
+    change
+      0 <
+        σ *
+          determinant (Smale.PlaneImmersion.linearMap (v t, α t • v t + β t • quarterTurn (v t)))
+    rw [determinant_linearMap, area_transverse, ← mul_assoc]
+    exact mul_pos (hβpos t) (squareLength_pos (hvne t))
+  have hv0 : v 0 = (a : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) (1, 0) :=
+    congrArg Subtype.val γ.source
+  have hv1 : v 1 = (b : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) (1, 0) :=
+    congrArg Subtype.val γ.target
+  have hF0 : F 0 = (a : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) := by
+    change Smale.PlaneImmersion.linearMap (v 0, α 0 • v 0 + β 0 • quarterTurn (v 0)) = _
+    have hα0 : α 0 = α₀ := by simp [α]
+    have hβ0 : β 0 = β₀ := by simp [β]
+    rw [hv0, hα0, hβ0, decompose_second_column (first_column_ne_zero a)]
+    exact linearMap_columns a
+  have hF1 : F 1 = (b : Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane) := by
+    change Smale.PlaneImmersion.linearMap (v 1, α 1 • v 1 + β 1 • quarterTurn (v 1)) = _
+    have hα1 : α 1 = α₁ := by simp [α]
+    have hβ1 : β 1 = β₁ := by simp [β]
+    rw [hv1, hα1, hβ1, decompose_second_column (first_column_ne_zero b)]
+    exact linearMap_columns b
+  exact
+    ⟨{  toFun := fun t => ⟨F t, hcomponent t⟩
+        continuous_toFun := hF.subtype_mk hcomponent
+        source' := Subtype.ext hF0
+        target' := Subtype.ext hF1 }⟩
+
+private theorem Smale.PlanarFrame.exists_smooth_join_of_same_determinant_sign
+    {a b : ℝ → (Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane)} {U V : Set ℝ}
+    (ha : ContDiffOn ℝ ∞ a U) (hb : ContDiffOn ℝ ∞ b V) (hU : IsOpen U) (hV : IsOpen V)
+    (h0U : (0 : ℝ) ∈ U) (h1V : (1 : ℝ) ∈ V)
+    (hsign : 0 < (a 0).toLinearMap.det * (b 1).toLinearMap.det) :
+    ∃ L : ℝ → (Smale.PlaneImmersion.Plane →L[ℝ] Smale.PlaneImmersion.Plane),
+      ContDiff ℝ ∞ L ∧
+        (∀ t, Function.Bijective (L t)) ∧
+          (∀ t, 0 < (a 0).toLinearMap.det * (L t).toLinearMap.det) ∧
+            (L =ᶠ[𝓝 (0 : ℝ)] a) ∧ (L =ᶠ[𝓝 (1 : ℝ)] b) := by
+  let σ := (a 0).toLinearMap.det
+  have ha0ne : (a 0).toLinearMap.det ≠ 0 := by
+    intro hz
+    rw [hz, MulZeroClass.zero_mul] at hsign
+    exact lt_irrefl _ hsign
+  have ha0 : a 0 ∈ determinantComponent σ := by
+    change 0 < (a 0).toLinearMap.det * determinant (a 0)
+    rw [determinant_eq_det]
+    exact mul_self_pos.mpr ha0ne
+  have hb1 : b 1 ∈ determinantComponent σ := by
+    change 0 < (a 0).toLinearMap.det * determinant (b 1)
+    rw [determinant_eq_det]
+    exact hsign
+  obtain ⟨γ⟩ :=
+    nonempty_path_determinantComponent (⟨a 0, ha0⟩ : determinantComponent σ)
+      (⟨b 1, hb1⟩ : determinantComponent σ)
+  obtain ⟨L, hL, hmem, hleft, hright⟩ :=
+    Smale.exists_smooth_open_curve_with_endpoint_germs (determinantComponent σ) ha hb hU hV h0U
+      h1V ha0 hb1 γ
+  have hpositive (t : ℝ) : 0 < (a 0).toLinearMap.det * (L t).toLinearMap.det := by
+    have h := hmem t
+    change 0 < (a 0).toLinearMap.det * determinant (L t) at h
+    rwa [determinant_eq_det] at h
+  refine ⟨L, hL, ?_, hpositive, hleft, hright⟩
+  intro t
+  apply bijective_of_determinant_ne_zero (L t)
+  intro hz
+  rw [determinant_eq_det] at hz
+  have h := hpositive t
+  rw [hz, MulZeroClass.mul_zero] at h
+  exact lt_irrefl _ h
+
+private theorem Smale.FrameField.exists_smooth_invertible_join_of_finrank_two {D : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D]
+    (hdim : Module.finrank ℝ D = 2) {a b : ℝ → (D →L[ℝ] D)} {U V : Set ℝ}
+    (ha : ContDiffOn ℝ ∞ a U) (hb : ContDiffOn ℝ ∞ b V) (hU : IsOpen U) (hV : IsOpen V)
+    (h0U : (0 : ℝ) ∈ U) (h1V : (1 : ℝ) ∈ V)
+    (hsign : 0 < (a 0).toLinearMap.det * (b 1).toLinearMap.det) :
+    ∃ L : ℝ → (D →L[ℝ] D),
+      ContDiff ℝ ∞ L ∧
+        (∀ t, Function.Bijective (L t)) ∧
+          (∀ t, 0 < (a 0).toLinearMap.det * (L t).toLinearMap.det) ∧
+            (L =ᶠ[𝓝 (0 : ℝ)] a) ∧ (L =ᶠ[𝓝 (1 : ℝ)] b) := by
+  have hdim' : Module.finrank ℝ Smale.PlaneImmersion.Plane = Module.finrank ℝ D := by
+    simp [Smale.PlaneImmersion.Plane, Module.finrank_prod, Module.finrank_self, hdim]
+  let e : Smale.PlaneImmersion.Plane ≃L[ℝ] D := ContinuousLinearEquiv.ofFinrankEq hdim'
+  let a' (t : ℝ) := e.symm.toContinuousLinearMap.comp ((a t).comp e.toContinuousLinearMap)
+  let b' (t : ℝ) := e.symm.toContinuousLinearMap.comp ((b t).comp e.toContinuousLinearMap)
+  have ha' : ContDiffOn ℝ ∞ a' U := contDiffOn_const.clm_comp (ha.clm_comp contDiffOn_const)
+  have hb' : ContDiffOn ℝ ∞ b' V := contDiffOn_const.clm_comp (hb.clm_comp contDiffOn_const)
+  have hadet (t : ℝ) : (a' t).toLinearMap.det = (a t).toLinearMap.det :=
+    LinearMap.det_conj (a t).toLinearMap e.symm.toLinearEquiv
+  have hbdet (t : ℝ) : (b' t).toLinearMap.det = (b t).toLinearMap.det :=
+    LinearMap.det_conj (b t).toLinearMap e.symm.toLinearEquiv
+  have hsign' : 0 < (a' 0).toLinearMap.det * (b' 1).toLinearMap.det := by
+    rw [hadet, hbdet]
+    exact hsign
+  obtain ⟨L', hL', hi', hdet', hleft, hright⟩ :=
+    Smale.PlanarFrame.exists_smooth_join_of_same_determinant_sign ha' hb' hU hV h0U h1V hsign'
+  let L (t : ℝ) := e.toContinuousLinearMap.comp ((L' t).comp e.symm.toContinuousLinearMap)
+  have hL : ContDiff ℝ ∞ L := contDiff_const.clm_comp (hL'.clm_comp contDiff_const)
+  have hi (t : ℝ) : Function.Bijective (L t) := e.bijective.comp ((hi' t).comp e.symm.bijective)
+  have hdet (t : ℝ) : 0 < (a 0).toLinearMap.det * (L t).toLinearMap.det := by
+    have heq : (L t).toLinearMap.det = (L' t).toLinearMap.det :=
+      LinearMap.det_conj (L' t).toLinearMap e.toLinearEquiv
+    rw [heq, ← hadet 0]
+    exact hdet' t
+  refine ⟨L, hL, hi, hdet, ?_, ?_⟩
+  · filter_upwards [hleft] with t ht
+    change e.toContinuousLinearMap.comp ((L' t).comp e.symm.toContinuousLinearMap) = a t
+    rw [ht]
+    apply ContinuousLinearMap.ext
+    intro v
+    change e (e.symm (a t (e (e.symm v)))) = a t v
+    simp only [e.apply_symm_apply]
+  · filter_upwards [hright] with t ht
+    change e.toContinuousLinearMap.comp ((L' t).comp e.symm.toContinuousLinearMap) = b t
+    rw [ht]
+    apply ContinuousLinearMap.ext
+    intro v
+    change e (e.symm (b t (e (e.symm v)))) = b t v
+    simp only [e.apply_symm_apply]
+
+private theorem
+    Smale.FrameField.exists_global_field_with_closed_germ {F : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {L : Smale.PlaneImmersion.Plane → F} {U C : Set Smale.PlaneImmersion.Plane}
+    (hU : IsOpen U) (hL : ContDiffOn ℝ ∞ L U) (hC : IsClosed C) (hCU : C ⊆ U) :
+    ∃ L₀ : Smale.PlaneImmersion.Plane → F, ContDiff ℝ ∞ L₀ ∧ L₀ =ᶠ[𝓝ˢ C] L := by
+  have hdisj : Disjoint Uᶜ C := Set.disjoint_left.mpr (fun _ hxU hxC => hxU (hCU hxC))
+  obtain ⟨β, hβ0, hβ1, _⟩ :=
+    exists_contMDiffMap_zero_one_nhds_of_isClosed 𝓘(ℝ, Smale.PlaneImmersion.Plane)
+      hU.isClosed_compl hC hdisj (n := ⊤)
+  let L₀ : Smale.PlaneImmersion.Plane → F := fun x => β x • L x
+  have hβ : ContDiff ℝ ∞ (β : Smale.PlaneImmersion.Plane → ℝ) := β.contMDiff.contDiff
+  have hL₀ : ContDiff ℝ ∞ L₀ := by
+    apply contDiff_iff_contDiffAt.mpr
+    intro x
+    by_cases hx : x ∈ U
+    · exact hβ.contDiffAt.smul (hL.contDiffAt (hU.mem_nhds hx))
+    · apply
+        (contDiffAt_const :
+            ContDiffAt ℝ ∞ (fun _ : Smale.PlaneImmersion.Plane => (0 : F))
+              x).congr_of_eventuallyEq
+      have hβx : ∀ᶠ y in 𝓝 x, β y = 0 := hβ0.filter_mono (nhds_le_nhdsSet hx)
+      filter_upwards [hβx] with y hy
+      change β y • L y = 0
+      rw [hy, zero_smul]
+  refine ⟨L₀, hL₀, ?_⟩
+  filter_upwards [hβ1] with x hx
+  change β x • L x = L x
+  rw [hx, one_smul]
+
+private theorem
+    Smale.FrameField.exists_nonzero_field_rel_closed {P F : Type*} [NormedAddCommGroup P]
+    [NormedSpace ℝ P] [FiniteDimensional ℝ P] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [FiniteDimensional ℝ F] {v : P → F} (hv : ContDiff ℝ ∞ v)
+    (hdim : Module.finrank ℝ P < Module.finrank ℝ F) {K C : Set P} (hK : IsCompact K)
+    (hC : IsClosed C) (hne : ∀ x ∈ K ∩ C, v x ≠ 0) :
+    ∃ v' : P → F, ContDiff ℝ ∞ v' ∧ v' =ᶠ[𝓝ˢ C] v ∧ ∀ x ∈ K, v' x ≠ 0 := by
+  let B : Set P := K ∩ v ⁻¹' {0}
+  have hB : IsCompact B := hK.inter_right (isClosed_singleton.preimage hv.continuous)
+  have hdisj : Disjoint C B := Set.disjoint_left.mpr (fun x hxC hxB => hne x ⟨hxB.1, hxC⟩ hxB.2)
+  obtain ⟨β, hβ0, hβ1, -⟩ :=
+    exists_contMDiffMap_zero_one_nhds_of_isClosed 𝓘(ℝ, P) hC hB.isClosed hdisj (n := ⊤)
+  have hfixed : ∀ x ∈ K, β x = 0 → v x ≠ 0 := by
+    intro x hx hβx hvx
+    have heq : β x = 1 := hβ1.self_of_nhdsSet x ⟨hx, hvx⟩
+    exact zero_ne_one (hβx.symm.trans heq)
+  let Z := EuclideanSpace ℝ (Fin 0)
+  let g : Z → F := fun _ => 0
+  have hg : ContMDiff 𝓘(ℝ, Z) 𝓘(ℝ, F) ∞ g := contMDiff_const
+  have hdim' : Module.finrank ℝ P + Module.finrank ℝ Z < Module.finrank ℝ F := by
+    simpa only [Z, finrank_euclideanSpace_fin, add_zero] using hdim
+  obtain ⟨a, -, ha⟩ :=
+    Smale.exists_small_localized_image_avoidance hv.contMDiff hg β.contMDiff hdim'
+      (show (0 : ℝ) < 1 by norm_num)
+  refine ⟨fun x => v x + β x • a, hv.add (β.contMDiff.contDiff.smul contDiff_const), ?_, ?_⟩
+  · filter_upwards [hβ0] with x hx
+    rw [hx, zero_smul, add_zero]
+  · intro x hx
+    by_cases hβx : β x = 0
+    · simpa only [hβx, zero_smul, add_zero] using hfixed x hx hβx
+    · exact ha x hβx (0 : Z)
+
+private theorem Smale.FrameField.exists_nonzero_extension_of_local_field {F : Type*}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [FiniteDimensional ℝ F]
+    {v : Smale.PlaneImmersion.Plane → F} {U C K : Set Smale.PlaneImmersion.Plane} (hU : IsOpen U)
+    (hv : ContDiffOn ℝ ∞ v U) (hC : IsClosed C) (hCU : C ⊆ U) (hK : IsCompact K)
+    (hne : ∀ x ∈ K ∩ C, v x ≠ 0) (hdim : 3 ≤ Module.finrank ℝ F) :
+    ∃ v' : Smale.PlaneImmersion.Plane → F, ContDiff ℝ ∞ v' ∧ v' =ᶠ[𝓝ˢ C] v ∧ ∀ x ∈ K, v' x ≠ 0 := by
+  obtain ⟨v₀, hv₀, heq⟩ := exists_global_field_with_closed_germ hU hv hC hCU
+  have hne₀ : ∀ x ∈ K ∩ C, v₀ x ≠ 0 := by
+    intro x hx
+    rw [heq.self_of_nhdsSet hx.2]
+    exact hne x hx
+  have hdim' : Module.finrank ℝ Smale.PlaneImmersion.Plane < Module.finrank ℝ F := by
+    change Module.finrank ℝ (ℝ × ℝ) < Module.finrank ℝ F
+    simp only [Module.finrank_prod, Module.finrank_self]
+    omega
+  obtain ⟨v', hv', hgerm, hne'⟩ := exists_nonzero_field_rel_closed hv₀ hdim' hK hC hne₀
+  exact ⟨v', hv', hgerm.trans heq, hne'⟩
+
+private theorem
+    Smale.FrameField.injective_iff_ne_zero_of_finrank_one {A F : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (hA : Module.finrank ℝ A = 1) (L : A →L[ℝ] F) : Function.Injective L ↔ L ≠ 0 := by
+  constructor
+  · intro hi hzero
+    let : Nontrivial A := Module.nontrivial_of_finrank_pos (by rw [hA]; norm_num)
+    obtain ⟨v, hv⟩ := exists_ne (0 : A)
+    apply hv
+    apply hi
+    rw [hzero]
+    rfl
+  · intro hne
+    have hr : L.range ≠ ⊥ := by
+      intro hbot
+      have hz : L.toLinearMap = 0 := LinearMap.range_eq_bot.mp hbot
+      apply hne
+      ext x
+      exact congrArg (fun f : A →ₗ[ℝ] F => f x) hz
+    have hrank := L.toLinearMap.finrank_range_add_finrank_ker
+    have hpos : 1 ≤ Module.finrank ℝ L.range := Submodule.one_le_finrank_iff.mpr hr
+    have hk : Module.finrank ℝ L.ker = 0 := by
+      rw [hA] at hrank
+      omega
+    exact LinearMap.ker_eq_bot.mp (Submodule.finrank_eq_zero.mp hk)
+
+private theorem
+    Smale.FrameField.finrank_one_column {A F : Type*} [NormedAddCommGroup A] [NormedSpace ℝ A]
+    [FiniteDimensional ℝ A] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (hA : Module.finrank ℝ A = 1) : Module.finrank ℝ (A →L[ℝ] F) = Module.finrank ℝ F := by
+  rw [← (LinearMap.toContinuousLinearMap : (A →ₗ[ℝ] F) ≃ₗ[ℝ] (A →L[ℝ] F)).finrank_eq,
+    Module.finrank_linearMap, hA, one_mul]
+
+private theorem Smale.FrameField.exists_one_column_extension_of_local_field {A F : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [FiniteDimensional ℝ F] (hA : Module.finrank ℝ A = 1)
+    {L : Smale.PlaneImmersion.Plane → (A →L[ℝ] F)} {U C K : Set Smale.PlaneImmersion.Plane}
+    (hU : IsOpen U) (hL : ContDiffOn ℝ ∞ L U) (hC : IsClosed C) (hCU : C ⊆ U) (hK : IsCompact K)
+    (hi : ∀ x ∈ K ∩ C, Function.Injective (L x)) (hdim : 3 ≤ Module.finrank ℝ F) :
+    ∃ L' : Smale.PlaneImmersion.Plane → (A →L[ℝ] F),
+      ContDiff ℝ ∞ L' ∧ L' =ᶠ[𝓝ˢ C] L ∧ ∀ x ∈ K, Function.Injective (L' x) := by
+  have hne : ∀ x ∈ K ∩ C, L x ≠ 0 := fun x hx =>
+    (injective_iff_ne_zero_of_finrank_one hA (L x)).mp (hi x hx)
+  have hdim' : 3 ≤ Module.finrank ℝ (A →L[ℝ] F) := by rwa [finrank_one_column hA]
+  obtain ⟨L', hL', heq, hne'⟩ := exists_nonzero_extension_of_local_field hU hL hC hCU hK hne hdim'
+  exact
+    ⟨L', hL', heq, fun x hx => (injective_iff_ne_zero_of_finrank_one hA (L' x)).mpr (hne' x hx)⟩
+
+private theorem
+    Smale.FrameField.exists_completed_one_column_frame {A F : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup F] [InnerProductSpace ℝ F]
+    [FiniteDimensional ℝ F] (hA : Module.finrank ℝ A = 1)
+    {L : Smale.PlaneImmersion.Plane → (A →L[ℝ] F)} {U C K : Set Smale.PlaneImmersion.Plane}
+    (hU : IsOpen U) (hL : ContDiffOn ℝ ∞ L U) (hC : IsClosed C) (hCU : C ⊆ U) (hK : IsCompact K)
+    (hstar : StarConvex ℝ (0 : Smale.PlaneImmersion.Plane) K)
+    (h0 : (0 : Smale.PlaneImmersion.Plane) ∈ K) (hi : ∀ x ∈ K ∩ C, Function.Injective (L x))
+    (hdim : Module.finrank ℝ F = 3) :
+    ∃ L' : Smale.PlaneImmersion.Plane → (A →L[ℝ] F),
+      ContDiff ℝ ∞ L' ∧
+        L' =ᶠ[𝓝ˢ C] L ∧
+          ∃ V : Set Smale.PlaneImmersion.Plane,
+            IsOpen V ∧
+              K ⊆ V ∧
+                ∃ B : Smale.PlaneImmersion.Plane → (EuclideanSpace ℝ (Fin 2) →L[ℝ] F),
+                  ContDiffOn ℝ ∞ B V ∧
+                    (∀ x ∈ K, (B x).range = (L' x).rangeᗮ) ∧
+                      ∀ x ∈ V, Function.Bijective ((L' x).coprod (B x)) := by
+  obtain ⟨L', hL', heq, hi'⟩ :=
+    exists_one_column_extension_of_local_field hA hU hL hC hCU hK hi hdim.ge
+  have hcodim : Module.finrank ℝ A + 2 = Module.finrank ℝ F := by rw [hA, hdim]
+  obtain ⟨V, hV, hKV, B, hB, hr, hb⟩ :=
+    exists_smooth_complement_near_starConvex hL' hK hstar h0 hi' 2 hcodim
+  exact ⟨L', hL', heq, V, hV, hKV, B, hB, hr, hb⟩
+
+private theorem Smale.FrameField.eq_det_smul_id_of_finrank_one {D : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] (hdim : Module.finrank ℝ D = 1) (A : D →L[ℝ] D) :
+    A.toLinearMap = A.toLinearMap.det • LinearMap.id := by
+  obtain ⟨a, ha, -⟩ := A.toLinearMap.existsUnique_eq_smul_id_of_finrank_eq_one hdim
+  have hdet : A.toLinearMap.det = a := by
+    rw [ha, LinearMap.det_smul, hdim, pow_one, LinearMap.det_id, mul_one]
+  rw [hdet]
+  exact ha
+
+private theorem Smale.FrameField.det_smul_add_of_finrank_one {D : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] (hdim : Module.finrank ℝ D = 1) (A B : D →L[ℝ] D) (a b : ℝ) :
+    (a • A + b • B).toLinearMap.det = a * A.toLinearMap.det + b * B.toLinearMap.det := by
+  have hlin :
+    (a • A + b • B).toLinearMap =
+      (a * A.toLinearMap.det + b * B.toLinearMap.det) • LinearMap.id := by
+    calc
+      _ = a • (A.toLinearMap.det • LinearMap.id) + b • (B.toLinearMap.det • LinearMap.id) :=
+        congrArg₂ (fun L K : D →ₗ[ℝ] D => a • L + b • K) (eq_det_smul_id_of_finrank_one hdim A)
+          (eq_det_smul_id_of_finrank_one hdim B)
+      _ = _ := by rw [smul_smul, smul_smul, ← add_smul]
+  rw [hlin, LinearMap.det_smul, hdim, pow_one, LinearMap.det_id, mul_one]
+
+private theorem Smale.FrameField.exists_smooth_invertible_join_of_finrank_one {D : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D]
+    (hdim : Module.finrank ℝ D = 1) {a b : ℝ → (D →L[ℝ] D)} {U V : Set ℝ}
+    (ha : ContDiffOn ℝ ∞ a U) (hb : ContDiffOn ℝ ∞ b V) (hU : IsOpen U) (hV : IsOpen V)
+    (h0U : (0 : ℝ) ∈ U) (h1V : (1 : ℝ) ∈ V)
+    (hsign : 0 < (a 0).toLinearMap.det * (b 1).toLinearMap.det) :
+    ∃ L : ℝ → (D →L[ℝ] D),
+      ContDiff ℝ ∞ L ∧
+        (∀ t, Function.Bijective (L t)) ∧
+          (∀ t, 0 < (a 0).toLinearMap.det * (L t).toLinearMap.det) ∧
+            (L =ᶠ[𝓝 (0 : ℝ)] a) ∧ (L =ᶠ[𝓝 (1 : ℝ)] b) := by
+  let σ := (a 0).toLinearMap.det
+  let S : TopologicalSpace.Opens (D →L[ℝ] D) :=
+    ⟨{L | 0 < σ * L.toLinearMap.det},
+      isOpen_lt continuous_const (continuous_const.mul ContinuousLinearMap.continuous_det)⟩
+  have ha0ne : (a 0).toLinearMap.det ≠ 0 := by
+    intro hz
+    rw [hz, MulZeroClass.zero_mul] at hsign
+    exact lt_irrefl _ hsign
+  have hpos : 0 < σ * (a 0).toLinearMap.det := mul_self_pos.mpr ha0ne
+  have ha0 : a 0 ∈ S := hpos
+  have hb1 : b 1 ∈ S := hsign
+  let γ : Path (⟨a 0, ha0⟩ : S) (⟨b 1, hb1⟩ : S) :=
+    { toFun := fun t =>
+        ⟨(1 - (t : ℝ)) • a 0 + (t : ℝ) • b 1,
+          by
+          change 0 < σ * ((1 - (t : ℝ)) • a 0 + (t : ℝ) • b 1).toLinearMap.det
+          rw [det_smul_add_of_finrank_one hdim]
+          have heq :
+            σ * ((1 - (t : ℝ)) * (a 0).toLinearMap.det + (t : ℝ) * (b 1).toLinearMap.det) =
+              (1 - (t : ℝ)) * (σ * (a 0).toLinearMap.det) +
+                (t : ℝ) * (σ * (b 1).toLinearMap.det) := by ring
+          rw [heq]
+          by_cases ht : (t : ℝ) = 0
+          · simpa only [ht, sub_zero, one_mul, MulZeroClass.zero_mul, add_zero] using hpos
+          · have htpos : 0 < (t : ℝ) := lt_of_le_of_ne t.property.1 (Ne.symm ht)
+            exact
+              add_pos_of_nonneg_of_pos (mul_nonneg (sub_nonneg.mpr t.property.2) hpos.le)
+                (mul_pos htpos hsign)⟩
+      continuous_toFun := by
+        apply Continuous.subtype_mk
+        fun_prop
+      source' := by
+        apply Subtype.ext
+        simp
+      target' := by
+        apply Subtype.ext
+        simp }
+  obtain ⟨L, hL, hmem, hleft, hright⟩ :=
+    Smale.exists_smooth_open_curve_with_endpoint_germs S ha hb hU hV h0U h1V ha0 hb1 γ
+  have hpositive (t : ℝ) : 0 < (a 0).toLinearMap.det * (L t).toLinearMap.det := hmem t
+  refine ⟨L, hL, ?_, hpositive, hleft, hright⟩
+  intro t
+  have hdet : (L t).toLinearMap.det ≠ 0 := by
+    intro hz
+    have hp := hpositive t
+    rw [hz, MulZeroClass.mul_zero] at hp
+    exact lt_irrefl _ hp
+  have hker : (L t).toLinearMap.ker = ⊥ := by
+    by_contra hk
+    exact hdet (LinearMap.det_eq_zero_iff_ker_ne_bot.mpr hk)
+  have hi : Function.Injective (L t) := LinearMap.ker_eq_bot.mp hker
+  exact ⟨hi, (LinearMap.injective_iff_surjective_of_finrank_eq_finrank rfl).mp hi⟩
+
+private theorem Smale.FrameField.mul_endpoints_pos_of_continuous_nonzero {f : ℝ → ℝ}
+    (hf : ContinuousOn f (Set.Icc (0 : ℝ) 1)) (hne : ∀ t ∈ Set.Icc (0 : ℝ) 1, f t ≠ 0) :
+    0 < f 0 * f 1 := by
+  by_contra h
+  rcases mul_nonpos_iff.mp (le_of_not_gt h) with h | h
+  · obtain ⟨t, ht, hft⟩ := intermediate_value_Icc' (show (0 : ℝ) ≤ 1 by norm_num) hf ⟨h.2, h.1⟩
+    exact hne t ht hft
+  · obtain ⟨t, ht, hft⟩ := intermediate_value_Icc (show (0 : ℝ) ≤ 1 by norm_num) hf h
+    exact hne t ht hft
+
+private theorem Smale.FrameField.det_mul_endpoints_pos {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] {T : ℝ → (E →L[ℝ] E)}
+    (hT : ContinuousOn T (Set.Icc (0 : ℝ) 1))
+    (hi : ∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Bijective (T t)) :
+    0 < (T 0).toLinearMap.det * (T 1).toLinearMap.det := by
+  apply
+    mul_endpoints_pos_of_continuous_nonzero
+      (ContinuousLinearMap.continuous_det.comp_continuousOn hT)
+  intro t ht hz
+  have hker : (T t).toLinearMap.ker ≠ ⊥ := LinearMap.det_eq_zero_iff_ker_ne_bot.mp hz
+  exact hker (LinearMap.ker_eq_bot.mpr (hi t ht).1)
+
+private theorem
+    Smale.FrameField.same_sign_frames_iff_coefficients {D Z F : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [FiniteDimensional ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [FiniteDimensional ℝ Z] [NormedAddCommGroup F] [NormedSpace ℝ F] (j : (D × Z) ≃L[ℝ] F)
+    {G : ℝ → (D →L[ℝ] F)} {C L : ℝ → (Z →L[ℝ] F)} (hG : ContDiffOn ℝ ∞ G (Set.Icc (0 : ℝ) 1))
+    (hC : ContDiffOn ℝ ∞ C (Set.Icc (0 : ℝ) 1))
+    (hi : ∀ t ∈ Set.Icc (0 : ℝ) 1, ((G t).coprod (C t)).IsInvertible) :
+    (0 <
+        (j.symm.toContinuousLinearMap.comp ((G 0).coprod (L 0))).toLinearMap.det *
+          (j.symm.toContinuousLinearMap.comp ((G 1).coprod (L 1))).toLinearMap.det) ↔
+      (0 <
+        ((complementQuotient (G 0) (C 0)).comp (L 0)).toLinearMap.det *
+          ((complementQuotient (G 1) (C 1)).comp (L 1)).toLinearMap.det) := by
+  let T (t : ℝ) := j.symm.toContinuousLinearMap.comp ((G t).coprod (C t))
+  have hs : ContDiffOn ℝ ∞ T (Set.Icc (0 : ℝ) 1) :=
+    contDiffOn_const.clm_comp (contDiffOn_coprod hG hC)
+  have hT : ∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Bijective (T t) := fun t ht =>
+    j.symm.bijective.comp (hi t ht).bijective
+  have hpositive := det_mul_endpoints_pos hs.continuousOn hT
+  have h0 := det_frame_eq_det_split_mul_det_coefficient j (G 0) (C 0) (L 0) (hi 0 (by simp))
+  have h1 := det_frame_eq_det_split_mul_det_coefficient j (G 1) (C 1) (L 1) (hi 1 (by simp))
+  rw [h0, h1]
+  have heq :
+    ((T 0).toLinearMap.det * ((complementQuotient (G 0) (C 0)).comp (L 0)).toLinearMap.det) *
+        ((T 1).toLinearMap.det * ((complementQuotient (G 1) (C 1)).comp (L 1)).toLinearMap.det) =
+      ((T 0).toLinearMap.det * (T 1).toLinearMap.det) *
+        (((complementQuotient (G 0) (C 0)).comp (L 0)).toLinearMap.det *
+          ((complementQuotient (G 1) (C 1)).comp (L 1)).toLinearMap.det) := by ring
+  change (0 < ((T 0).toLinearMap.det * _) * ((T 1).toLinearMap.det * _)) ↔ _
+  rw [heq]
+  exact mul_pos_iff_of_pos_left hpositive
+
+private theorem Smale.FrameField.exists_smooth_complement_with_endpoint_germs_of_finrank_one_or_two
+    {D Z F : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (hdim : Module.finrank ℝ Z = 1 ∨ Module.finrank ℝ Z = 2)
+    {G : ℝ → (D →L[ℝ] F)} {C L : ℝ → (Z →L[ℝ] F)} {U : Set ℝ} (hU : IsOpen U) (h0U : (0 : ℝ) ∈ U)
+    (h1U : (1 : ℝ) ∈ U) (hG : ContDiffOn ℝ ∞ G U) (hC : ContDiffOn ℝ ∞ C U)
+    (hL : ContDiffOn ℝ ∞ L U) (hi : ∀ t ∈ U, Function.Bijective ((G t).coprod (C t)))
+    (hsign :
+      0 <
+        ((complementQuotient (G 0) (C 0)).comp (L 0)).toLinearMap.det *
+          ((complementQuotient (G 1) (C 1)).comp (L 1)).toLinearMap.det) :
+    ∃ H : ℝ → (Z →L[ℝ] F),
+      ContDiffOn ℝ ∞ H U ∧
+        (∀ t ∈ U, Function.Bijective ((G t).coprod (H t))) ∧
+          (H =ᶠ[𝓝 (0 : ℝ)] L) ∧ (H =ᶠ[𝓝 (1 : ℝ)] L) := by
+  have hinv : ∀ t ∈ U, ((G t).coprod (C t)).IsInvertible := fun t ht =>
+    isInvertible_coprod_of_bijective (G t) (C t) (hi t ht)
+  let K (t : ℝ) := (complementQuotient (G t) (C t)).comp (L t)
+  have hK : ContDiffOn ℝ ∞ K U := (contDiffOn_complementQuotient hU hG hC hinv).clm_comp hL
+  have hjoin :=
+    hdim.elim
+      (fun hd => exists_smooth_invertible_join_of_finrank_one hd hK hK hU hU h0U h1U hsign)
+      (fun hd => exists_smooth_invertible_join_of_finrank_two hd hK hK hU hU h0U h1U hsign)
+  obtain ⟨K', hK', hiK', _, hleft, hright⟩ := hjoin
+  let H (t : ℝ) := correctedComplement (G t) (C t) (L t) (K' t)
+  have hH : ContDiffOn ℝ ∞ H U := contDiffOn_correctedComplement hU hG hC hL hK'.contDiffOn hinv
+  refine
+    ⟨H, hH, fun t ht =>
+      bijective_coprod_correctedComplement (G t) (C t) (L t) (K' t) (hinv t ht) (hiK' t), ?_, ?_⟩
+  · filter_upwards [hleft] with t ht
+    change correctedComplement (G t) (C t) (L t) (K' t) = L t
+    rw [ht]
+    exact correctedComplement_self (G t) (C t) (L t)
+  · filter_upwards [hright] with t ht
+    change correctedComplement (G t) (C t) (L t) (K' t) = L t
+    rw [ht]
+    exact correctedComplement_self (G t) (C t) (L t)
+
+private theorem
+    Smale.FrameField.exists_smooth_complement_with_germs_of_frame_sign_of_finrank_one_or_two
+    {D Z F : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (hdim : Module.finrank ℝ Z = 1 ∨ Module.finrank ℝ Z = 2)
+    (j : (D × Z) ≃L[ℝ] F) {G : ℝ → (D →L[ℝ] F)} {C L : ℝ → (Z →L[ℝ] F)} {U : Set ℝ}
+    (hU : IsOpen U) (hIU : Set.Icc (0 : ℝ) 1 ⊆ U) (hG : ContDiffOn ℝ ∞ G U)
+    (hC : ContDiffOn ℝ ∞ C U) (hL : ContDiffOn ℝ ∞ L U)
+    (hi : ∀ t ∈ U, Function.Bijective ((G t).coprod (C t)))
+    (hsign :
+      0 <
+        (j.symm.toContinuousLinearMap.comp ((G 0).coprod (L 0))).toLinearMap.det *
+          (j.symm.toContinuousLinearMap.comp ((G 1).coprod (L 1))).toLinearMap.det) :
+    ∃ H : ℝ → (Z →L[ℝ] F),
+      ContDiffOn ℝ ∞ H U ∧
+        (∀ t ∈ U, Function.Bijective ((G t).coprod (H t))) ∧
+          (H =ᶠ[𝓝 (0 : ℝ)] L) ∧ (H =ᶠ[𝓝 (1 : ℝ)] L) := by
+  have hinv : ∀ t ∈ Set.Icc (0 : ℝ) 1, ((G t).coprod (C t)).IsInvertible := fun t ht =>
+    isInvertible_coprod_of_bijective _ _ (hi t (hIU ht))
+  have hcoeff := (same_sign_frames_iff_coefficients j (hG.mono hIU) (hC.mono hIU) hinv).mp hsign
+  exact
+    exists_smooth_complement_with_endpoint_germs_of_finrank_one_or_two hdim hU (hIU (by simp))
+      (hIU (by simp)) hG hC hL hi hcoeff
+
+private theorem Smale.WhitneyPairModel.exists_smooth_bigon_boundary_field {F : Type*}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] {h : ℝ} (hh : 0 < h) {L H : ℝ → F} {D : Set ℝ}
+    (hD : IsOpen D) (hID : Set.Icc (0 : ℝ) 1 ⊆ D) (hL : ContDiffOn ℝ ∞ L D)
+    (hH : ContDiffOn ℝ ∞ H D) (h0 : H =ᶠ[𝓝 (0 : ℝ)] L) (h1 : H =ᶠ[𝓝 (1 : ℝ)] L) :
+    ∃ U V : Set (ℝ × ℝ),
+      IsOpen U ∧
+        IsOpen V ∧
+          frontier (bigon h) ⊆ U ∪ V ∧
+            Set.MapsTo (fun t : ℝ => (2 * t - 1, 0)) (Set.Icc 0 1) U ∧
+              Set.MapsTo (fun t : ℝ => (2 * t - 1, h * (1 - (2 * t - 1) ^ 2))) (Set.Icc 0 1) V ∧
+                ∃ W : (ℝ × ℝ) → F,
+                  ContDiffOn ℝ ∞ W (U ∪ V) ∧
+                    Set.EqOn W (L ∘ arcTime) U ∧ Set.EqOn W (H ∘ arcTime) V := by
+  let P := arcTime ⁻¹' D
+  have hP : IsOpen P := hD.preimage contDiff_arcTime.continuous
+  have hLP : ContDiffOn ℝ ∞ (L ∘ arcTime) P :=
+    hL.comp contDiff_arcTime.contDiffOn (fun _ hp => hp)
+  have hHP : ContDiffOn ℝ ∞ (H ∘ arcTime) P :=
+    hH.comp contDiff_arcTime.contDiffOn (fun _ hp => hp)
+  have htime0 : Filter.Tendsto arcTime (𝓝 ((-1 : ℝ), (0 : ℝ))) (𝓝 (0 : ℝ)) := by
+    simpa [ContinuousAt, arcTime] using
+      (contDiff_arcTime.continuous.continuousAt (x := ((-1 : ℝ), (0 : ℝ))))
+  have htime1 : Filter.Tendsto arcTime (𝓝 ((1 : ℝ), (0 : ℝ))) (𝓝 (1 : ℝ)) := by
+    simpa [ContinuousAt, arcTime] using
+      (contDiff_arcTime.continuous.continuousAt (x := ((1 : ℝ), (0 : ℝ))))
+  have hg0 : (L ∘ arcTime) =ᶠ[𝓝 ((-1 : ℝ), (0 : ℝ))] (H ∘ arcTime) := h0.symm.comp_tendsto htime0
+  have hg1 : (L ∘ arcTime) =ᶠ[𝓝 ((1 : ℝ), (0 : ℝ))] (H ∘ arcTime) := h1.symm.comp_tendsto htime1
+  obtain ⟨O₀, hO₀sub, hO₀, hleft⟩ := mem_nhds_iff.mp hg0
+  obtain ⟨O₁, hO₁sub, hO₁, hright⟩ := mem_nhds_iff.mp hg1
+  have htime (t y : ℝ) : arcTime (2 * t - 1, y) = t := by dsimp [arcTime]; ring
+  have hlowP : Set.MapsTo (fun t : ℝ => (2 * t - 1, 0)) (Set.Icc 0 1) P := by
+    intro t ht
+    change arcTime (2 * t - 1, 0) ∈ D
+    rw [htime]
+    exact hID ht
+  have huppP : Set.MapsTo (fun t : ℝ => (2 * t - 1, h * (1 - (2 * t - 1) ^ 2))) (Set.Icc 0 1) P :=
+    by
+    intro t ht
+    change arcTime (2 * t - 1, h * (1 - (2 * t - 1) ^ 2)) ∈ D
+    rw [htime]
+    exact hID ht
+  obtain ⟨U, V, hU, hV, hUP, hVP, hover, hlowU, huppV, hfront⟩ :=
+    exists_bigon_boundary_cover hh hP hP (hO₀.union hO₁) (Or.inl hleft) (Or.inr hright) hlowP
+      huppP
+  have hLH : Set.EqOn (L ∘ arcTime) (H ∘ arcTime) (U ∩ V) := by
+    intro p hp
+    rcases hover hp with hp0 | hp1
+    · exact hO₀sub hp0
+    · exact hO₁sub hp1
+  obtain ⟨W, hW, hWL, hWH⟩ :=
+    Smale.exists_smooth_open_gluing hU hV (hLP.mono hUP).contMDiffOn (hHP.mono hVP).contMDiffOn
+      hLH
+  exact ⟨U, V, hU, hV, hfront, hlowU, huppV, W, hW.contDiffOn, hWL, hWH⟩
+
+private theorem Smale.WhitneyPairModel.exists_injective_bigon_boundary_field {F : Type*}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] {A : Type*} [NormedAddCommGroup A] [NormedSpace ℝ A]
+    {h : ℝ} (hh : 0 < h) {L H : ℝ → (A →L[ℝ] F)} {D : Set ℝ} (hD : IsOpen D)
+    (hID : Set.Icc (0 : ℝ) 1 ⊆ D) (hL : ContDiffOn ℝ ∞ L D) (hH : ContDiffOn ℝ ∞ H D)
+    (h0 : H =ᶠ[𝓝 (0 : ℝ)] L) (h1 : H =ᶠ[𝓝 (1 : ℝ)] L)
+    (hiL : ∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Injective (L t))
+    (hiH : ∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Injective (H t)) :
+    ∃ O : Set (ℝ × ℝ),
+      IsOpen O ∧
+        frontier (bigon h) ⊆ O ∧
+          ∃ W : (ℝ × ℝ) → (A →L[ℝ] F),
+            ContDiffOn ℝ ∞ W O ∧
+              (∀ t ∈ Set.Icc (0 : ℝ) 1, W =ᶠ[𝓝 (2 * t - 1, 0)] (L ∘ arcTime)) ∧
+                (∀ t ∈ Set.Icc (0 : ℝ) 1,
+                    W =ᶠ[𝓝 (2 * t - 1, h * (1 - (2 * t - 1) ^ 2))] (H ∘ arcTime)) ∧
+                  ∀ p ∈ frontier (bigon h), Function.Injective (W p) := by
+  obtain ⟨U, V, hU, hV, hfront, hlow, hupp, W, hW, hWL, hWH⟩ :=
+    exists_smooth_bigon_boundary_field hh hD hID hL hH h0 h1
+  have htime (t y : ℝ) : arcTime (2 * t - 1, y) = t := by dsimp [arcTime]; ring
+  refine ⟨U ∪ V, hU.union hV, hfront, W, hW, ?_, ?_, ?_⟩
+  · intro t ht
+    exact Filter.mem_of_superset (hU.mem_nhds (hlow ht)) (fun _ hp => hWL hp)
+  · intro t ht
+    exact Filter.mem_of_superset (hV.mem_nhds (hupp ht)) (fun _ hp => hWH hp)
+  · intro p hp
+    obtain ⟨t, ht, rfl | rfl⟩ := (mem_frontier_bigon_iff_exists_time hh p).mp hp
+    · rw [hWL (hlow ht)]
+      dsimp only [Function.comp_apply]
+      rw [htime]
+      exact hiL t ht
+    · rw [hWH (hupp ht)]
+      dsimp only [Function.comp_apply]
+      rw [htime]
+      exact hiH t ht
+
+private def Smale.FrameField.rankThreePairCoordinates :
+    (EuclideanSpace ℝ (Fin 2) × EuclideanSpace ℝ (Fin 1)) ≃L[ℝ] EuclideanSpace ℝ (Fin 3) :=
+  ContinuousLinearEquiv.ofFinrankEq
+    (by simp only [Module.finrank_prod, finrank_euclideanSpace_fin])
+
+private def Smale.FrameField.rankThreePairDet
+    (A : EuclideanSpace ℝ (Fin 2) →L[ℝ] EuclideanSpace ℝ (Fin 3))
+    (B : EuclideanSpace ℝ (Fin 1) →L[ℝ] EuclideanSpace ℝ (Fin 3)) : ℝ :=
+  (rankThreePairCoordinates.symm.toContinuousLinearMap.comp (A.coprod B)).toLinearMap.det
+
+private theorem Smale.TubularBigon.exists_rankThree_boundary_complement_of_normal_sign {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    (tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3)
+    (d :
+      Smale.StripNormalData (EuclideanSpace ℝ (Fin 1)) (EuclideanSpace ℝ (Fin 3)) (E := E) S
+        k.map)
+    (e :
+      Smale.StripNormalData (EuclideanSpace ℝ (Fin 2)) (EuclideanSpace ℝ (Fin 2)) (E := E) T
+        l.map)
+    (hsign :
+      0 <
+        Smale.FrameField.rankThreePairDet (e.normalFrame tube.chart 0)
+            (d.normalFrame tube.chart 0) *
+          Smale.FrameField.rankThreePairDet (e.normalFrame tube.chart 1)
+            (d.normalFrame tube.chart 1)) :
+    ∃ U : Set ℝ,
+      IsOpen U ∧
+        Set.Icc (0 : ℝ) 1 ⊆ U ∧
+          ContDiffOn ℝ ∞ (d.normalFrame tube.chart) U ∧
+            ∃ H : ℝ → (EuclideanSpace ℝ (Fin 1) →L[ℝ] EuclideanSpace ℝ (Fin 3)),
+              ContDiffOn ℝ ∞ H U ∧
+                (∀ t ∈ U, Function.Bijective ((e.normalFrame tube.chart t).coprod (H t))) ∧
+                  (H =ᶠ[𝓝 (0 : ℝ)] d.normalFrame tube.chart) ∧
+                    (H =ᶠ[𝓝 (1 : ℝ)] d.normalFrame tube.chart) := by
+  obtain ⟨⟨V, hV, hIV, hL⟩, -⟩ := tube.lower_sheetFrame d
+  obtain ⟨W, hW, hIW, hR, C, hC, -, hRC⟩ :=
+    tube.upper_sheetFrame_complement_of_finrank e 1 (by simp only [finrank_euclideanSpace_fin])
+  let U := V ∩ W
+  have hU : IsOpen U := hV.inter hW
+  have hIU : Set.Icc (0 : ℝ) 1 ⊆ U := fun _ ht => ⟨hIV ht, hIW ht⟩
+  have hLU := hL.mono (show U ⊆ V from Set.inter_subset_left)
+  have hRU := hR.mono (show U ⊆ W from Set.inter_subset_right)
+  have hCU := hC.mono (show U ⊆ W from Set.inter_subset_right)
+  have hsplit : ∀ t ∈ U, Function.Bijective ((e.normalFrame tube.chart t).coprod (C t)) :=
+    fun t ht => hRC t ht.2
+  obtain ⟨H, hH, hiH, hleft, hright⟩ :=
+    Smale.FrameField.exists_smooth_complement_with_germs_of_frame_sign_of_finrank_one_or_two
+      (Or.inl finrank_euclideanSpace_fin) Smale.FrameField.rankThreePairCoordinates hU hIU hRU hCU
+      hLU hsplit hsign
+  exact ⟨U, hU, hIU, hLU, H, hH, hiH, hleft, hright⟩
+
+private theorem
+    Smale.TubularBigon.exists_rankThree_planar_boundary_frame_of_normal_sign {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    (tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3)
+    (d :
+      Smale.StripNormalData (EuclideanSpace ℝ (Fin 1)) (EuclideanSpace ℝ (Fin 3)) (E := E) S
+        k.map)
+    (e :
+      Smale.StripNormalData (EuclideanSpace ℝ (Fin 2)) (EuclideanSpace ℝ (Fin 2)) (E := E) T
+        l.map)
+    (hsign :
+      0 <
+        Smale.FrameField.rankThreePairDet (e.normalFrame tube.chart 0)
+            (d.normalFrame tube.chart 0) *
+          Smale.FrameField.rankThreePairDet (e.normalFrame tube.chart 1)
+            (d.normalFrame tube.chart 1)) :
+    ∃ O : Set (ℝ × ℝ),
+      IsOpen O ∧
+        frontier (Smale.WhitneyPairModel.bigon h) ⊆ O ∧
+          ∃ W : (ℝ × ℝ) → (EuclideanSpace ℝ (Fin 1) →L[ℝ] EuclideanSpace ℝ (Fin 3)),
+            ContDiffOn ℝ ∞ W O ∧
+              (∀ t ∈ Set.Icc (0 : ℝ) 1,
+                  W =ᶠ[𝓝 (2 * t - 1, 0)]
+                    (d.normalFrame tube.chart ∘ Smale.WhitneyPairModel.arcTime)) ∧
+                (∀ t ∈ Set.Icc (0 : ℝ) 1,
+                    Function.Bijective
+                      ((e.normalFrame tube.chart t).coprod
+                        (W (2 * t - 1, h * (1 - (2 * t - 1) ^ 2))))) ∧
+                  ∀ p ∈ frontier (Smale.WhitneyPairModel.bigon h), Function.Injective (W p) := by
+  obtain ⟨D, hD, hID, hL, H, hH, hcomp, h0, h1⟩ :=
+    tube.exists_rankThree_boundary_complement_of_normal_sign d e hsign
+  have hHi : ∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Injective (H t) := by
+    intro t ht u v huv
+    have heq :
+      ((e.normalFrame tube.chart t).coprod (H t)) (0, u) =
+        ((e.normalFrame tube.chart t).coprod (H t)) (0, v) := by
+      simpa only [ContinuousLinearMap.coprod_apply, map_zero, zero_add] using huv
+    exact congrArg Prod.snd ((hcomp t (hID ht)).1 heq)
+  obtain ⟨O, hO, hfront, W, hW, hlo, hhi, hinj⟩ :=
+    Smale.WhitneyPairModel.exists_injective_bigon_boundary_field tube.height_pos hD hID hL hH h0
+      h1 (tube.lower_sheetFrame d).2 hHi
+  refine ⟨O, hO, hfront, W, hW, hlo, ?_, hinj⟩
+  intro t ht
+  rw [(hhi t ht).eq_of_nhds]
+  have htime : Smale.WhitneyPairModel.arcTime (2 * t - 1, h * (1 - (2 * t - 1) ^ 2)) = t := by
+    dsimp [Smale.WhitneyPairModel.arcTime]
+    ring
+  change
+    Function.Bijective
+      ((e.normalFrame tube.chart t).coprod
+        (H (Smale.WhitneyPairModel.arcTime (2 * t - 1, h * (1 - (2 * t - 1) ^ 2)))))
+  rw [htime]
+  exact hcomp t (hID ht)
+
+private theorem Smale.TubularBigon.exists_rankThree_planar_frame_of_normal_sign {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    (tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3)
+    (d :
+      Smale.StripNormalData (EuclideanSpace ℝ (Fin 1)) (EuclideanSpace ℝ (Fin 3)) (E := E) S
+        k.map)
+    (e :
+      Smale.StripNormalData (EuclideanSpace ℝ (Fin 2)) (EuclideanSpace ℝ (Fin 2)) (E := E) T
+        l.map)
+    (hsign :
+      0 <
+        Smale.FrameField.rankThreePairDet (e.normalFrame tube.chart 0)
+            (d.normalFrame tube.chart 0) *
+          Smale.FrameField.rankThreePairDet (e.normalFrame tube.chart 1)
+            (d.normalFrame tube.chart 1)) :
+    ∃ W : (ℝ × ℝ) → (EuclideanSpace ℝ (Fin 1) →L[ℝ] EuclideanSpace ℝ (Fin 3)),
+      ContDiff ℝ ∞ W ∧
+        (∀ t ∈ Set.Icc (0 : ℝ) 1,
+            W =ᶠ[𝓝 (2 * t - 1, 0)] (d.normalFrame tube.chart ∘ Smale.WhitneyPairModel.arcTime)) ∧
+          (∀ t ∈ Set.Icc (0 : ℝ) 1,
+              Function.Bijective
+                ((e.normalFrame tube.chart t).coprod
+                  (W (2 * t - 1, h * (1 - (2 * t - 1) ^ 2))))) ∧
+            ∃ V : Set (ℝ × ℝ),
+              IsOpen V ∧
+                Smale.WhitneyPairModel.bigon h ⊆ V ∧
+                  ∃ B : (ℝ × ℝ) → (EuclideanSpace ℝ (Fin 2) →L[ℝ] EuclideanSpace ℝ (Fin 3)),
+                    ContDiffOn ℝ ∞ B V ∧
+                      (∀ p ∈ Smale.WhitneyPairModel.bigon h, (B p).range = (W p).rangeᗮ) ∧
+                        ∀ p ∈ V, Function.Bijective ((W p).coprod (B p)) := by
+  obtain ⟨O, hO, hfront, W₀, hW₀, hlo, hhi, hinj⟩ :=
+    tube.exists_rankThree_planar_boundary_frame_of_normal_sign d e hsign
+  obtain ⟨W, hW, heq, V, hV, hKV, B, hB, hr, hb⟩ :=
+    Smale.FrameField.exists_completed_one_column_frame finrank_euclideanSpace_fin hO hW₀
+      isClosed_frontier hfront (Smale.WhitneyPairModel.isCompact_bigon tube.height_pos)
+      (Smale.WhitneyPairModel.starConvex_bigon tube.height_pos.le)
+      (Smale.WhitneyPairModel.zero_mem_bigon tube.height_pos.le) (fun p hp => hinj p hp.2)
+      finrank_euclideanSpace_fin
+  refine ⟨W, hW, ?_, ?_, V, hV, hKV, B, hB, hr, hb⟩
+  · intro t ht
+    have hp : (2 * t - 1, 0) ∈ frontier (Smale.WhitneyPairModel.bigon h) :=
+      (Smale.WhitneyPairModel.mem_frontier_bigon_iff_exists_time tube.height_pos _).mpr
+        ⟨t, ht, Or.inl rfl⟩
+    exact (heq.filter_mono (nhds_le_nhdsSet hp)).trans (hlo t ht)
+  · intro t ht
+    have hp :
+      (2 * t - 1, h * (1 - (2 * t - 1) ^ 2)) ∈ frontier (Smale.WhitneyPairModel.bigon h) :=
+      (Smale.WhitneyPairModel.mem_frontier_bigon_iff_exists_time tube.height_pos _).mpr
+        ⟨t, ht, Or.inr rfl⟩
+    rw [heq.self_of_nhdsSet hp]
+    exact hhi t ht
+
+private theorem Smale.FrameField.bijective_coprod_comm {D Z F : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (W : D →L[ℝ] F) (H : Z →L[ℝ] F) (hi : Function.Bijective (H.coprod W)) :
+    Function.Bijective (W.coprod H) := by
+  have heq :
+    W.coprod H = (H.coprod W).comp (ContinuousLinearEquiv.prodComm ℝ D Z).toContinuousLinearMap :=
+    by
+    apply ContinuousLinearMap.ext
+    intro p
+    change W p.1 + H p.2 = H p.2 + W p.1
+    exact add_comm _ _
+  rw [heq]
+  exact hi.comp (ContinuousLinearEquiv.prodComm ℝ D Z).bijective
+
+private def
+    Smale.FrameField.transportComplement {D Z F : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (W : D →L[ℝ] F) (B : Z →L[ℝ] F) (W₀ : D →L[ℝ] F) (B₀ H : Z →L[ℝ] F) : Z →L[ℝ] F :=
+  (W.coprod B).comp ((W₀.coprod B₀).inverse.comp H)
+
+private theorem Smale.FrameField.transportComplement_self {D Z F : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (W : D →L[ℝ] F) (B H : Z →L[ℝ] F) (h : (W.coprod B).IsInvertible) :
+    transportComplement W B W B H = H := by
+  apply ContinuousLinearMap.ext
+  intro z
+  exact h.self_apply_inverse (H z)
+
+private theorem Smale.FrameField.coprod_transportComplement {D Z F : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (W : D →L[ℝ] F) (B : Z →L[ℝ] F) (W₀ : D →L[ℝ] F) (B₀ H : Z →L[ℝ] F)
+    (h₀ : (W₀.coprod B₀).IsInvertible) :
+    W.coprod (transportComplement W B W₀ B₀ H) =
+      ((W.coprod B).comp (W₀.coprod B₀).inverse).comp (W₀.coprod H) := by
+  have hfirst (u : D) : (W₀.coprod B₀).inverse (W₀ u) = (u, 0) := by
+    simpa only [ContinuousLinearMap.coprod_apply, map_zero, add_zero] using
+      h₀.inverse_apply_self (u, 0)
+  apply ContinuousLinearMap.ext
+  intro p
+  simp only [transportComplement, ContinuousLinearMap.comp_apply,
+    ContinuousLinearMap.coprod_apply, map_add, hfirst, map_zero, add_zero]
+
+private theorem
+    Smale.FrameField.bijective_transportComplement {D Z F : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (W : D →L[ℝ] F) (B : Z →L[ℝ] F) (W₀ : D →L[ℝ] F) (B₀ H : Z →L[ℝ] F)
+    (h : (W.coprod B).IsInvertible) (h₀ : (W₀.coprod B₀).IsInvertible)
+    (hH : Function.Bijective (W₀.coprod H)) :
+    Function.Bijective (W.coprod (transportComplement W B W₀ B₀ H)) := by
+  rw [coprod_transportComplement W B W₀ B₀ H h₀]
+  exact (h.bijective.comp h₀.inverse.bijective).comp hH
+
+private theorem
+    Smale.FrameField.contDiffOn_transportComplement {D Z F : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] {X : Type*} [NormedAddCommGroup X] [NormedSpace ℝ X] [FiniteDimensional ℝ D]
+    [FiniteDimensional ℝ Z] {W W₀ : X → (D →L[ℝ] F)} {B B₀ H : X → (Z →L[ℝ] F)} {U : Set X}
+    (hU : IsOpen U) (hW : ContDiffOn ℝ ∞ W U) (hB : ContDiffOn ℝ ∞ B U)
+    (hW₀ : ContDiffOn ℝ ∞ W₀ U) (hB₀ : ContDiffOn ℝ ∞ B₀ U) (hH : ContDiffOn ℝ ∞ H U)
+    (hi : ∀ x ∈ U, ((W₀ x).coprod (B₀ x)).IsInvertible) :
+    ContDiffOn ℝ ∞ (fun x => transportComplement (W x) (B x) (W₀ x) (B₀ x) (H x)) U := by
+  have hT₀ := contDiffOn_coprod hW₀ hB₀
+  have hInv : ContDiffOn ℝ ∞ (fun x => ((W₀ x).coprod (B₀ x)).inverse) U := by
+    intro x hx
+    exact
+      ((hi x hx).contDiffAt_map_inverse.comp x (hT₀.contDiffAt (hU.mem_nhds hx))).contDiffWithinAt
+  exact (contDiffOn_coprod hW hB).clm_comp (hInv.clm_comp hH)
+
+private theorem Smale.TubularBigon.exists_rankThree_adapted_frame_of_normal_sign {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    (tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3)
+    (d :
+      Smale.StripNormalData (EuclideanSpace ℝ (Fin 1)) (EuclideanSpace ℝ (Fin 3)) (E := E) S
+        k.map)
+    (e :
+      Smale.StripNormalData (EuclideanSpace ℝ (Fin 2)) (EuclideanSpace ℝ (Fin 2)) (E := E) T
+        l.map)
+    (hsign :
+      0 <
+        Smale.FrameField.rankThreePairDet (e.normalFrame tube.chart 0)
+            (d.normalFrame tube.chart 0) *
+          Smale.FrameField.rankThreePairDet (e.normalFrame tube.chart 1)
+            (d.normalFrame tube.chart 1)) :
+    ∃ W : (ℝ × ℝ) → (EuclideanSpace ℝ (Fin 1) →L[ℝ] EuclideanSpace ℝ (Fin 3)),
+      ContDiff ℝ ∞ W ∧
+        (∀ t ∈ Set.Icc (0 : ℝ) 1,
+            W =ᶠ[𝓝 (2 * t - 1, 0)] (d.normalFrame tube.chart ∘ Smale.WhitneyPairModel.arcTime)) ∧
+          ∃ O : Set (ℝ × ℝ),
+            IsOpen O ∧
+              Smale.WhitneyPairModel.bigon h ⊆ O ∧
+                ∃ C : (ℝ × ℝ) → (EuclideanSpace ℝ (Fin 2) →L[ℝ] EuclideanSpace ℝ (Fin 3)),
+                  ContDiffOn ℝ ∞ C O ∧
+                    (∀ t ∈ Set.Icc (0 : ℝ) 1,
+                        C (Smale.WhitneyPairModel.upperBoundaryArc h t) =
+                          e.normalFrame tube.chart t) ∧
+                      ∀ p ∈ O, Function.Bijective ((W p).coprod (C p)) := by
+  obtain ⟨W, hW, hlo, hhi, V, hV, hKV, B, hB, -, hb⟩ :=
+    tube.exists_rankThree_planar_frame_of_normal_sign d e hsign
+  obtain ⟨⟨D, hD, hID, hG⟩, -⟩ := tube.upper_sheetFrame e
+  let r : (ℝ × ℝ) → (ℝ × ℝ) :=
+    Smale.WhitneyPairModel.upperBoundaryArc h ∘ Smale.WhitneyPairModel.arcTime
+  have hq : ContDiff ℝ ∞ (Smale.WhitneyPairModel.upperBoundaryArc h) := by
+    unfold Smale.WhitneyPairModel.upperBoundaryArc; fun_prop
+  have hr : ContDiff ℝ ∞ r := hq.comp Smale.WhitneyPairModel.contDiff_arcTime
+  have htime (t y : ℝ) : Smale.WhitneyPairModel.arcTime (2 * t - 1, y) = t := by
+    dsimp [Smale.WhitneyPairModel.arcTime]; ring
+  have htq (t : ℝ) :
+    Smale.WhitneyPairModel.arcTime (Smale.WhitneyPairModel.upperBoundaryArc h t) = t := htime t _
+  have hrq (t : ℝ) :
+    r (Smale.WhitneyPairModel.upperBoundaryArc h t) =
+      Smale.WhitneyPairModel.upperBoundaryArc h t := by
+    dsimp only [r, Function.comp_apply]
+    rw [htq]
+  have htimeK :
+    Set.MapsTo Smale.WhitneyPairModel.arcTime (Smale.WhitneyPairModel.bigon h)
+      (Set.Icc (0 : ℝ) 1) := by
+    intro p hp
+    have hpr := Smale.WhitneyPairModel.bigon_subset_rectangle tube.height_pos hp
+    change 0 ≤ (p.1 + 1) / 2 ∧ (p.1 + 1) / 2 ≤ 1
+    constructor <;> linarith [hpr.1.1, hpr.1.2]
+  have hrK : Set.MapsTo r (Smale.WhitneyPairModel.bigon h) (Smale.WhitneyPairModel.bigon h) :=
+    fun _ hp => tube.upperBoundaryArc_mem_bigon (htimeK hp)
+  let O₀ := V ∩ (r ⁻¹' V ∩ Smale.WhitneyPairModel.arcTime ⁻¹' D)
+  have hO₀ : IsOpen O₀ :=
+    hV.inter
+      ((hV.preimage hr.continuous).inter
+        (hD.preimage Smale.WhitneyPairModel.contDiff_arcTime.continuous))
+  have hKO₀ : Smale.WhitneyPairModel.bigon h ⊆ O₀ := fun p hp =>
+    ⟨hKV hp, hKV (hrK hp), hID (htimeK hp)⟩
+  let C : (ℝ × ℝ) → (EuclideanSpace ℝ (Fin 2) →L[ℝ] EuclideanSpace ℝ (Fin 3)) := fun p =>
+    Smale.FrameField.transportComplement (W p) (B p) (W (r p)) (B (r p))
+      (e.normalFrame tube.chart (Smale.WhitneyPairModel.arcTime p))
+  have hC : ContDiffOn ℝ ∞ C O₀ := by
+    apply
+      Smale.FrameField.contDiffOn_transportComplement hO₀ hW.contDiffOn
+        (hB.mono Set.inter_subset_left) (hW.comp hr).contDiffOn
+        (hB.comp hr.contDiffOn (fun _ hp => hp.2.1))
+        (hG.comp Smale.WhitneyPairModel.contDiff_arcTime.contDiffOn (fun _ hp => hp.2.2))
+    intro p hp
+    exact Smale.FrameField.isInvertible_coprod_of_bijective (W (r p)) (B (r p)) (hb _ hp.2.1)
+  have hcompK : ∀ p ∈ Smale.WhitneyPairModel.bigon h, Function.Bijective ((W p).coprod (C p)) := by
+    intro p hp
+    have ht := htimeK hp
+    have hupper :
+      Function.Bijective
+        ((W (r p)).coprod (e.normalFrame tube.chart (Smale.WhitneyPairModel.arcTime p))) :=
+      Smale.FrameField.bijective_coprod_comm _ _ (hhi (Smale.WhitneyPairModel.arcTime p) ht)
+    exact
+      Smale.FrameField.bijective_transportComplement (W p) (B p) (W (r p)) (B (r p)) _
+        (Smale.FrameField.isInvertible_coprod_of_bijective _ _ (hb p (hKV hp)))
+        (Smale.FrameField.isInvertible_coprod_of_bijective _ _ (hb _ (hKV (hrK hp)))) hupper
+  have hTC : ContDiffOn ℝ ∞ (fun p => (W p).coprod (C p)) O₀ :=
+    Smale.FrameField.contDiffOn_coprod hW.contDiffOn hC
+  let O := O₀ ∩ {p | Function.Injective ((W p).coprod (C p))}
+  have hO : IsOpen O :=
+    hTC.continuousOn.isOpen_inter_preimage hO₀ ContinuousLinearMap.isOpen_injective
+  have hKO : Smale.WhitneyPairModel.bigon h ⊆ O := fun p hp => ⟨hKO₀ hp, (hcompK p hp).1⟩
+  refine ⟨W, hW, hlo, O, hO, hKO, C, hC.mono Set.inter_subset_left, ?_, ?_⟩
+  · intro t ht
+    dsimp only [C]
+    rw [hrq, htq]
+    exact
+      Smale.FrameField.transportComplement_self _ _ _
+        (Smale.FrameField.isInvertible_coprod_of_bijective _ _
+          (hb _ (hKV (tube.upperBoundaryArc_mem_bigon ht))))
+  · intro p hp
+    have hdim :
+      Module.finrank ℝ (EuclideanSpace ℝ (Fin 1) × EuclideanSpace ℝ (Fin 2)) =
+        Module.finrank ℝ (EuclideanSpace ℝ (Fin 3)) := by
+      simp only [Module.finrank_prod, finrank_euclideanSpace_fin]
+    exact ⟨hp.2, (LinearMap.injective_iff_surjective_of_finrank_eq_finrank hdim).mp hp.2⟩
+
+private def Smale.TubularBigon.rankThreeSheetPairJacobian {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M} {a b : ℝ → M}
+    {k l : (ℝ × ℝ) → M} {h : ℝ} (tube : Smale.TubularBigon (E := E) S T a b k l h 3)
+    (d : Smale.StripNormalData (EuclideanSpace ℝ (Fin 1)) (EuclideanSpace ℝ (Fin 3)) (E := E) S k)
+    (e : Smale.StripNormalData (EuclideanSpace ℝ (Fin 2)) (EuclideanSpace ℝ (Fin 2)) (E := E) T l)
+    (t : ℝ) :
+    ((ℝ × ℝ) × (EuclideanSpace ℝ (Fin 2) × EuclideanSpace ℝ (Fin 1))) →L[ℝ]
+      ((ℝ × ℝ) × (EuclideanSpace ℝ (Fin 2) × EuclideanSpace ℝ (Fin 1))) :=
+  Smale.IntersectionCoordinates.jointBlock Smale.FrameField.rankThreePairCoordinates
+    (e.sheetDifferential tube.chart t) (d.sheetDifferential tube.chart t)
+
+private def Smale.TubularBigon.rankThreeSheetPairDet {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M} {a b : ℝ → M}
+    {k l : (ℝ × ℝ) → M} {h : ℝ} (tube : Smale.TubularBigon (E := E) S T a b k l h 3)
+    (d : Smale.StripNormalData (EuclideanSpace ℝ (Fin 1)) (EuclideanSpace ℝ (Fin 3)) (E := E) S k)
+    (e : Smale.StripNormalData (EuclideanSpace ℝ (Fin 2)) (EuclideanSpace ℝ (Fin 2)) (E := E) T l)
+    (t : ℝ) : ℝ :=
+  (tube.rankThreeSheetPairJacobian d e t).toLinearMap.det
+
+private theorem Smale.TubularBigon.rankThree_corner_sheet_charts_coincide {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k l : (ℝ × ℝ) → M} {h : ℝ} (tube : Smale.TubularBigon (E := E) S T a b k l h 3)
+    (d : Smale.StripNormalData (EuclideanSpace ℝ (Fin 1)) (EuclideanSpace ℝ (Fin 3)) (E := E) S k)
+    (e : Smale.StripNormalData (EuclideanSpace ℝ (Fin 2)) (EuclideanSpace ℝ (Fin 2)) (E := E) T l)
+    {t : ℝ} (ht : t = 0 ∨ t = 1) :
+    d.chart (Smale.StripCoordinates.center t) = e.chart (Smale.StripCoordinates.center t) := by
+  have htI : t ∈ Set.Icc (0 : ℝ) 1 := by rcases ht with rfl | rfl <;> simp
+  have hheight : h * (1 - (2 * t - 1) ^ 2) = 0 := by rcases ht with rfl | rfl <;> ring
+  have hd := (tube.lower_germ t htI).eq_of_nhds
+  have he := (tube.upper_germ t htI).eq_of_nhds
+  dsimp only [Function.comp_apply] at hd he
+  rw [Smale.WhitneyPairModel.lowerStripCoordinates_lower, d.center t] at hd
+  rw [Smale.WhitneyPairModel.upperStripCoordinates_upper, e.center t, hheight] at he
+  exact hd.symm.trans he
+
+private theorem Smale.TubularBigon.rankThreeSheetPairDet_eq {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M} {a b : ℝ → M}
+    {k l : (ℝ × ℝ) → M} {h : ℝ} (tube : Smale.TubularBigon (E := E) S T a b k l h 3)
+    (d : Smale.StripNormalData (EuclideanSpace ℝ (Fin 1)) (EuclideanSpace ℝ (Fin 3)) (E := E) S k)
+    (e : Smale.StripNormalData (EuclideanSpace ℝ (Fin 2)) (EuclideanSpace ℝ (Fin 2)) (E := E) T l)
+    {t : ℝ} (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    tube.rankThreeSheetPairDet d e t =
+      (8 * h * (2 * t - 1)) *
+        Smale.FrameField.rankThreePairDet (e.normalFrame tube.chart t)
+          (d.normalFrame tube.chart t) := by
+  rw [rankThreeSheetPairDet, rankThreeSheetPairJacobian,
+    Smale.IntersectionCoordinates.det_jointBlock Smale.FrameField.rankThreePairCoordinates
+      (e.sheetDifferential tube.chart t) (d.sheetDifferential tube.chart t)
+      (tube.upper_sheetDifferential_arc e ht) (tube.lower_sheetDifferential_arc d ht),
+    e.normal_sheetDifferential tube.chart ht (tube.upper_chart_center_mem_target e ht),
+    d.normal_sheetDifferential tube.chart ht (tube.lower_chart_center_mem_target d ht)]
+  have hplane :
+    (Smale.PlaneImmersion.linearMap ((2, -4 * h * (2 * t - 1)), (2, 0))).toLinearMap.det =
+      8 * h * (2 * t - 1) := by
+    rw [← Smale.PlanarFrame.determinant_eq_det, Smale.PlanarFrame.determinant_linearMap]
+    dsimp [Smale.PlanarFrame.area]
+    ring
+  rw [hplane]
+  rfl
+
+private theorem
+    Smale.TubularBigon.opposite_rankThree_corner_determinants_iff_normal_sign {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k l : (ℝ × ℝ) → M} {h : ℝ} (tube : Smale.TubularBigon (E := E) S T a b k l h 3)
+    (d : Smale.StripNormalData (EuclideanSpace ℝ (Fin 1)) (EuclideanSpace ℝ (Fin 3)) (E := E) S k)
+    (e :
+      Smale.StripNormalData (EuclideanSpace ℝ (Fin 2)) (EuclideanSpace ℝ (Fin 2)) (E := E) T l) :
+    (tube.rankThreeSheetPairDet d e 0 * tube.rankThreeSheetPairDet d e 1 < 0) ↔
+      (0 <
+        Smale.FrameField.rankThreePairDet (e.normalFrame tube.chart 0)
+            (d.normalFrame tube.chart 0) *
+          Smale.FrameField.rankThreePairDet (e.normalFrame tube.chart 1)
+            (d.normalFrame tube.chart 1)) := by
+  let n :=
+    Smale.FrameField.rankThreePairDet (e.normalFrame tube.chart 0) (d.normalFrame tube.chart 0) *
+      Smale.FrameField.rankThreePairDet (e.normalFrame tube.chart 1) (d.normalFrame tube.chart 1)
+  have hprod :
+    tube.rankThreeSheetPairDet d e 0 * tube.rankThreeSheetPairDet d e 1 = -((8 * h) ^ 2 * n) := by
+    rw [tube.rankThreeSheetPairDet_eq d e (t := 0) (by simp),
+      tube.rankThreeSheetPairDet_eq d e (t := 1) (by simp)]
+    dsimp only [n]
+    ring
+  have hscale : 0 < (8 * h) ^ 2 := sq_pos_of_pos (mul_pos (by norm_num) tube.height_pos)
+  change (tube.rankThreeSheetPairDet d e 0 * tube.rankThreeSheetPairDet d e 1 < 0) ↔ 0 < n
+  rw [hprod]
+  constructor
+  · intro hn
+    have hp : 0 < (8 * h) ^ 2 * n := by linarith
+    exact (mul_pos_iff_of_pos_left hscale).mp hp
+  · intro hn
+    have hp : 0 < (8 * h) ^ 2 * n := mul_pos hscale hn
+    linarith
+
+private theorem
+    Smale.TubularBigon.exists_rankThree_adapted_frame_of_opposite_corner_signs {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    (tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3)
+    (d :
+      Smale.StripNormalData (EuclideanSpace ℝ (Fin 1)) (EuclideanSpace ℝ (Fin 3)) (E := E) S
+        k.map)
+    (e :
+      Smale.StripNormalData (EuclideanSpace ℝ (Fin 2)) (EuclideanSpace ℝ (Fin 2)) (E := E) T
+        l.map)
+    (hsign : tube.rankThreeSheetPairDet d e 0 * tube.rankThreeSheetPairDet d e 1 < 0) :
+    ∃ W : (ℝ × ℝ) → (EuclideanSpace ℝ (Fin 1) →L[ℝ] EuclideanSpace ℝ (Fin 3)),
+      ContDiff ℝ ∞ W ∧
+        (∀ t ∈ Set.Icc (0 : ℝ) 1,
+            W =ᶠ[𝓝 (2 * t - 1, 0)] (d.normalFrame tube.chart ∘ Smale.WhitneyPairModel.arcTime)) ∧
+          ∃ O : Set (ℝ × ℝ),
+            IsOpen O ∧
+              Smale.WhitneyPairModel.bigon h ⊆ O ∧
+                ∃ C : (ℝ × ℝ) → (EuclideanSpace ℝ (Fin 2) →L[ℝ] EuclideanSpace ℝ (Fin 3)),
+                  ContDiffOn ℝ ∞ C O ∧
+                    (∀ t ∈ Set.Icc (0 : ℝ) 1,
+                        C (Smale.WhitneyPairModel.upperBoundaryArc h t) =
+                          e.normalFrame tube.chart t) ∧
+                      ∀ p ∈ O, Function.Bijective ((W p).coprod (C p)) :=
+  tube.exists_rankThree_adapted_frame_of_normal_sign d e
+    ((tube.opposite_rankThree_corner_determinants_iff_normal_sign d e).mp hsign)
+
+private def Smale.IntersectionCoordinates.pairCoordinates {A B F : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (j : (A × B) ≃L[ℝ] F) :
+    ((ℝ × A) × (ℝ × B)) ≃L[ℝ] (Smale.PlaneImmersion.Plane × F) :=
+  (ContinuousLinearEquiv.prodProdProdComm ℝ ℝ A ℝ B).trans
+    (ContinuousLinearEquiv.prodCongr (ContinuousLinearEquiv.refl ℝ Smale.PlaneImmersion.Plane) j)
+
+private theorem Smale.IntersectionCoordinates.det_jointBlock_eq_tangentSum {A B F : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (j : (A × B) ≃L[ℝ] F)
+    (P : (ℝ × A) →L[ℝ] (Smale.PlaneImmersion.Plane × F))
+    (Q : (ℝ × B) →L[ℝ] (Smale.PlaneImmersion.Plane × F)) :
+    (jointBlock j P Q).det =
+      ((pairCoordinates j).symm.toContinuousLinearMap.comp (P.coprod Q)).det := by
+  let k := ContinuousLinearEquiv.prodProdProdComm ℝ ℝ A ℝ B
+  let T := (pairCoordinates j).symm.toContinuousLinearMap.comp (P.coprod Q)
+  have heq :
+    (jointBlock j P Q).toLinearMap =
+      k.toLinearEquiv.toLinearMap.comp (T.toLinearMap.comp k.symm.toLinearEquiv.toLinearMap) := by
+    apply LinearMap.ext
+    intro z
+    rfl
+  change (jointBlock j P Q).toLinearMap.det = T.toLinearMap.det
+  rw [heq]
+  exact LinearMap.det_conj T.toLinearMap k.toLinearEquiv
+
+private theorem
+    Smale.FrameField.normalDetector_eq_comp_quotient {D Z F : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] (G : D →L[ℝ] F) (C : Z →L[ℝ] F) (Q : F →L[ℝ] Z)
+    (hi : (G.coprod C).IsInvertible) (hQG : Q.comp G = 0) :
+    Q = (Q.comp C).comp (complementQuotient G C) := by
+  apply ContinuousLinearMap.ext
+  intro v
+  let w := (G.coprod C).inverse v
+  have hv : G w.1 + C w.2 = v := hi.self_apply_inverse v
+  have hzero : Q (G w.1) = 0 := congrArg (fun L : D →L[ℝ] Z => L w.1) hQG
+  change Q v = Q (C w.2)
+  rw [← hv, map_add, hzero, zero_add]
+
+private theorem Smale.FrameField.det_intersection_mul_normalComplement {D Z F : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [FiniteDimensional ℝ D] [FiniteDimensional ℝ Z]
+    (j : (D × Z) ≃L[ℝ] F) (G : D →L[ℝ] F) (C L : Z →L[ℝ] F) (Q : F →L[ℝ] Z)
+    (hi : (G.coprod C).IsInvertible) (hQG : Q.comp G = 0) :
+    (j.symm.toContinuousLinearMap.comp (G.coprod L)).det * (Q.comp C).det =
+      (j.symm.toContinuousLinearMap.comp (G.coprod C)).det * (Q.comp L).det := by
+  have hnormal : Q.comp L = (Q.comp C).comp ((complementQuotient G C).comp L) := by
+    have h := normalDetector_eq_comp_quotient G C Q hi hQG
+    exact congrArg (fun R : F →L[ℝ] Z => R.comp L) h
+  have hdet : (Q.comp L).det = (Q.comp C).det * ((complementQuotient G C).comp L).det := by
+    rw [hnormal]
+    exact LinearMap.det_comp _ _
+  have hframe :
+    (j.symm.toContinuousLinearMap.comp (G.coprod L)).det =
+      (j.symm.toContinuousLinearMap.comp (G.coprod C)).det *
+        ((complementQuotient G C).comp L).det :=
+    det_frame_eq_det_split_mul_det_coefficient j G C L hi
+  rw [hframe, hdet]
+  ring
+
+private theorem Smale.FrameField.opposite_intersectionDet_iff_normalDet {D Z F : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [FiniteDimensional ℝ D] [FiniteDimensional ℝ Z]
+    (j : (D × Z) ≃L[ℝ] F) (G : ℝ → (D →L[ℝ] F)) (C L : ℝ → (Z →L[ℝ] F)) (Q : ℝ → (F →L[ℝ] Z))
+    (hG : ContDiffOn ℝ ∞ G (Set.Icc (0 : ℝ) 1)) (hC : ContDiffOn ℝ ∞ C (Set.Icc (0 : ℝ) 1))
+    (hQ : ContDiffOn ℝ ∞ Q (Set.Icc (0 : ℝ) 1))
+    (hi : ∀ t ∈ Set.Icc (0 : ℝ) 1, ((G t).coprod (C t)).IsInvertible)
+    (hQs : ∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Surjective (Q t))
+    (hQG : ∀ t ∈ Set.Icc (0 : ℝ) 1, (Q t).comp (G t) = 0) :
+    ((j.symm.toContinuousLinearMap.comp ((G 0).coprod (L 0))).det *
+          (j.symm.toContinuousLinearMap.comp ((G 1).coprod (L 1))).det <
+        0) ↔
+      ((Q 0).comp (L 0)).det * ((Q 1).comp (L 1)).det < 0 := by
+  let T (t : ℝ) := j.symm.toContinuousLinearMap.comp ((G t).coprod (C t))
+  let K (t : ℝ) := (Q t).comp (C t)
+  have hT : ContDiffOn ℝ ∞ T (Set.Icc (0 : ℝ) 1) :=
+    contDiffOn_const.clm_comp (contDiffOn_coprod hG hC)
+  have hK : ContDiffOn ℝ ∞ K (Set.Icc (0 : ℝ) 1) := hQ.clm_comp hC
+  have hTpos :=
+    det_mul_endpoints_pos hT.continuousOn (fun t ht => j.symm.bijective.comp (hi t ht).bijective)
+  have hKpos :=
+    det_mul_endpoints_pos hK.continuousOn
+      (fun t ht =>
+        Smale.TransverseCoordinates.bijective_normal_comp (Q t) (G t) (C t) (hQs t ht)
+          (hi t ht).surjective (hQG t ht) rfl)
+  have h₀ :=
+    det_intersection_mul_normalComplement j (G 0) (C 0) (L 0) (Q 0) (hi 0 (by simp))
+      (hQG 0 (by simp))
+  have h₁ :=
+    det_intersection_mul_normalComplement j (G 1) (C 1) (L 1) (Q 1) (hi 1 (by simp))
+      (hQG 1 (by simp))
+  let a :=
+    (j.symm.toContinuousLinearMap.comp ((G 0).coprod (L 0))).det *
+      (j.symm.toContinuousLinearMap.comp ((G 1).coprod (L 1))).det
+  let b := ((Q 0).comp (L 0)).det * ((Q 1).comp (L 1)).det
+  have heq : a * ((K 0).det * (K 1).det) = ((T 0).det * (T 1).det) * b := by
+    dsimp [a, b, T, K]
+    calc
+      _ =
+          ((j.symm.toContinuousLinearMap.comp ((G 0).coprod (L 0))).det *
+              ((Q 0).comp (C 0)).det) *
+            ((j.symm.toContinuousLinearMap.comp ((G 1).coprod (L 1))).det *
+              ((Q 1).comp (C 1)).det) := by ring
+      _ = _ := by rw [h₀, h₁]; ring
+  change a < 0 ↔ b < 0
+  constructor
+  · intro ha
+    have hn : ((T 0).det * (T 1).det) * b < 0 := heq ▸ mul_neg_of_neg_of_pos ha hKpos
+    rcases mul_neg_iff.mp hn with ⟨_, hb⟩ | ⟨ht, _⟩
+    · exact hb
+    · exact (not_lt_of_gt hTpos ht).elim
+  · intro hb
+    have hn : a * ((K 0).det * (K 1).det) < 0 := heq.symm ▸ mul_neg_of_pos_of_neg hTpos hb
+    rcases mul_neg_iff.mp hn with ⟨_, hk⟩ | ⟨ha, _⟩
+    · exact (not_lt_of_gt hKpos hk).elim
+    · exact ha
+
+private def Smale.StripNormalData.sheetBaseFrame {A B Z E M : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M} (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) (t : ℝ) :
+    A →L[ℝ] (ℝ × ℝ) :=
+  (ContinuousLinearMap.fst ℝ (ℝ × ℝ) Z).comp
+    ((d.sheetDifferential Ψ t).comp (ContinuousLinearMap.inr ℝ ℝ A))
+
+private theorem Smale.StripNormalData.contDiffOn_sheetDifferential {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) :
+    ContDiffOn ℝ ∞ (d.sheetDifferential Ψ)
+      {t |
+        Smale.StripCoordinates.center t ∈ d.chart.source ∧
+          d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target} := by
+  intro t ht
+  have htransition : ContDiffAt ℝ ∞ (Ψ.symm ∘ d.chart) (Smale.StripCoordinates.center t) :=
+    ((Ψ.contMDiffOn_invFun.contMDiffAt (Ψ.open_target.mem_nhds ht.2)).comp
+        (Smale.StripCoordinates.center t)
+        (d.chart.contMDiffOn_toFun.contMDiffAt (d.chart.open_source.mem_nhds ht.1))).contDiffAt
+  have hs : ContDiffAt ℝ ∞ (d.sheetTransition Ψ) (t, 0) :=
+    htransition.comp (t, 0) (ContinuousLinearMap.inl ℝ (ℝ × A) B).contDiff.contDiffAt
+  have hc : ContDiff ℝ ∞ (fun s : ℝ => (s, (0 : A))) := contDiff_id.prodMk contDiff_const
+  exact ((hs.fderiv_right (by simp)).comp t hc.contDiffAt).contDiffWithinAt
+
+private theorem
+    Smale.StripNormalData.contDiffOn_sheetBaseFrame {A B Z E M : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M} (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) :
+    ContDiffOn ℝ ∞ (d.sheetBaseFrame Ψ)
+      {t |
+        Smale.StripCoordinates.center t ∈ d.chart.source ∧
+          d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target} :=
+  contDiffOn_const.clm_comp ((d.contDiffOn_sheetDifferential Ψ).clm_comp contDiffOn_const)
+
+private theorem Smale.StripNormalData.exists_open_sheetBaseFrame_domain {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞)
+    (htarget : ∀ t ∈ Set.Icc (0 : ℝ) 1, d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target) :
+    ∃ U : Set ℝ, IsOpen U ∧ Set.Icc (0 : ℝ) 1 ⊆ U ∧ ContDiffOn ℝ ∞ (d.sheetBaseFrame Ψ) U := by
+  have hc : Continuous (Smale.StripCoordinates.center : ℝ → Smale.StripCoordinates.Space A B) :=
+    (continuous_id.prodMk continuous_const).prodMk continuous_const
+  have hO : IsOpen (d.chart.source ∩ d.chart ⁻¹' Ψ.target) :=
+    d.chart.contMDiffOn_toFun.continuousOn.isOpen_inter_preimage d.chart.open_source Ψ.open_target
+  exact
+    ⟨Smale.StripCoordinates.center ⁻¹' (d.chart.source ∩ d.chart ⁻¹' Ψ.target), hO.preimage hc,
+      fun t ht => ⟨d.line ht, htarget t ht⟩, d.contDiffOn_sheetBaseFrame Ψ⟩
+
+private theorem Smale.StripNormalData.sheetDifferential_transverse_eq {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1) (htarget : d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target)
+    (u : A) : d.sheetDifferential Ψ t (0, u) = (d.sheetBaseFrame Ψ t u, d.normalFrame Ψ t u) := by
+  apply Prod.ext
+  · rfl
+  · exact congrArg (fun L : A →L[ℝ] Z => L u) (d.normal_sheetDifferential Ψ ht htarget)
+
+private def
+    Smale.StripNormalData.tubularTransitionDerivative {A B Z E M : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M} (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) (t : ℝ) :
+    Smale.StripCoordinates.Space A B →L[ℝ] ((ℝ × ℝ) × Z) :=
+  fderiv ℝ (Ψ.symm ∘ d.chart) (Smale.StripCoordinates.center t)
+
+private def Smale.StripNormalData.sheetComplement {A B Z E M : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M} (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) (t : ℝ) :
+    B →L[ℝ] ((ℝ × ℝ) × Z) :=
+  (d.tubularTransitionDerivative Ψ t).comp (ContinuousLinearMap.inr ℝ (ℝ × A) B)
+
+private theorem Smale.StripNormalData.contDiffOn_tubularTransitionDerivative {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) :
+    ContDiffOn ℝ ∞ (d.tubularTransitionDerivative Ψ)
+      {t |
+        Smale.StripCoordinates.center t ∈ d.chart.source ∧
+          d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target} := by
+  intro t ht
+  have htransition : ContDiffAt ℝ ∞ (Ψ.symm ∘ d.chart) (Smale.StripCoordinates.center t) :=
+    ((Ψ.contMDiffOn_invFun.contMDiffAt (Ψ.open_target.mem_nhds ht.2)).comp
+        (Smale.StripCoordinates.center t)
+        (d.chart.contMDiffOn_toFun.contMDiffAt (d.chart.open_source.mem_nhds ht.1))).contDiffAt
+  have hc : ContDiff ℝ ∞ (Smale.StripCoordinates.center : ℝ → Smale.StripCoordinates.Space A B) :=
+    (contDiff_id.prodMk contDiff_const).prodMk contDiff_const
+  exact ((htransition.fderiv_right (by simp)).comp t hc.contDiffAt).contDiffWithinAt
+
+private theorem Smale.StripNormalData.contDiffOn_sheetComplement {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) :
+    ContDiffOn ℝ ∞ (d.sheetComplement Ψ)
+      {t |
+        Smale.StripCoordinates.center t ∈ d.chart.source ∧
+          d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target} :=
+  (d.contDiffOn_tubularTransitionDerivative Ψ).clm_comp contDiffOn_const
+
+private theorem Smale.StripNormalData.bijective_tubularTransitionDerivative {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1)
+    (htarget : d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target) :
+    Function.Bijective (d.tubularTransitionDerivative Ψ t) := by
+  unfold tubularTransitionDerivative
+  rw [← mfderiv_eq_fderiv,
+    mfderiv_comp (Smale.StripCoordinates.center t) (Ψ.symm.mdifferentiableAt (by simp) htarget)
+      (d.chart.mdifferentiableAt (by simp) (d.line ht))]
+  exact
+    (Smale.PartialChart.bijective_mfderiv Ψ.symm htarget).comp
+      (Smale.PartialChart.bijective_mfderiv d.chart (d.line ht))
+
+private theorem Smale.StripNormalData.sheet_coprod_complement_eq {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1)
+    (htarget : d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target) :
+    (d.sheetDifferential Ψ t).coprod (d.sheetComplement Ψ t) =
+      d.tubularTransitionDerivative Ψ t := by
+  rw [d.sheetDifferential_eq Ψ ht htarget]
+  apply ContinuousLinearMap.ext
+  intro z
+  change
+    d.tubularTransitionDerivative Ψ t (z.1, 0) + d.tubularTransitionDerivative Ψ t (0, z.2) =
+      d.tubularTransitionDerivative Ψ t z
+  rw [← map_add]
+  simp
+
+private theorem Smale.StripNormalData.isInvertible_sheet_coprod_complement {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) [FiniteDimensional ℝ A]
+    [FiniteDimensional ℝ B] {t : ℝ} (ht : t ∈ Set.Icc (0 : ℝ) 1)
+    (htarget : d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target) :
+    ((d.sheetDifferential Ψ t).coprod (d.sheetComplement Ψ t)).IsInvertible := by
+  apply Smale.FrameField.isInvertible_coprod_of_bijective
+  rw [d.sheet_coprod_complement_eq Ψ ht htarget]
+  exact d.bijective_tubularTransitionDerivative Ψ ht htarget
+
+private def Smale.StripNormalData.normalDetector {A B Z E M N : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) (q : M → N) (t : ℝ) :
+    ((ℝ × ℝ) × Z) →L[ℝ] N :=
+  fderiv ℝ (q ∘ Ψ) (Ψ.symm (d.chart (Smale.StripCoordinates.center t)))
+
+private theorem Smale.StripNormalData.contDiffAt_normalMap_in_tube {A B Z E M N : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [TopologicalSpace M] [ChartedSpace E M] {S : Set M}
+    {k : (ℝ × ℝ) → M} (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) (q : M → N) {t : ℝ}
+    (htarget : d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target)
+    (hq : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, N) ∞ q (d.chart (Smale.StripCoordinates.center t))) :
+    ContDiffAt ℝ ∞ (q ∘ Ψ) (Ψ.symm (d.chart (Smale.StripCoordinates.center t))) := by
+  have hinv :
+    Ψ (Ψ.symm (d.chart (Smale.StripCoordinates.center t))) =
+      d.chart (Smale.StripCoordinates.center t) :=
+    Ψ.right_inv' htarget
+  have hq' :
+    ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, N) ∞ q (Ψ (Ψ.symm (d.chart (Smale.StripCoordinates.center t)))) :=
+    hinv.symm ▸ hq
+  exact
+    (hq'.comp _
+        (Ψ.contMDiffOn_toFun.contMDiffAt
+          (Ψ.open_source.mem_nhds (Ψ.map_target' htarget)))).contDiffAt
+
+private theorem Smale.StripNormalData.contDiffOn_normalDetector {A B Z E M N : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [TopologicalSpace M] [ChartedSpace E M] {S : Set M}
+    {k : (ℝ × ℝ) → M} (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) (q : M → N) {O : Set M}
+    (hO : IsOpen O) (hq : ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, N) ∞ q O)
+    (htarget : ∀ t ∈ Set.Icc (0 : ℝ) 1, d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target)
+    (hcenter : ∀ t ∈ Set.Icc (0 : ℝ) 1, d.chart (Smale.StripCoordinates.center t) ∈ O) :
+    ContDiffOn ℝ ∞ (d.normalDetector Ψ q) (Set.Icc (0 : ℝ) 1) := by
+  intro t ht
+  have hqΨ :=
+    d.contDiffAt_normalMap_in_tube Ψ q (htarget t ht)
+      (hq.contMDiffAt (hO.mem_nhds (hcenter t ht)))
+  have hc : ContDiff ℝ ∞ (Smale.StripCoordinates.center : ℝ → Smale.StripCoordinates.Space A B) :=
+    (contDiff_id.prodMk contDiff_const).prodMk contDiff_const
+  have hx : ContDiffAt ℝ ∞ (fun s => Ψ.symm (d.chart (Smale.StripCoordinates.center s))) t :=
+    (d.contDiffAt_tubularTransition Ψ ht (htarget t ht)).comp t hc.contDiffAt
+  exact ((hqΨ.fderiv_right (by simp)).comp t hx).contDiffWithinAt
+
+private theorem Smale.StripNormalData.normalDetector_eq_native {A B Z E M N : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [TopologicalSpace M] [ChartedSpace E M] {S : Set M}
+    {k : (ℝ × ℝ) → M} (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) (q : M → N) {t : ℝ}
+    (htarget : d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target)
+    (hq : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, N) ∞ q (d.chart (Smale.StripCoordinates.center t))) :
+    d.normalDetector Ψ q t =
+      (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, N) q (d.chart (Smale.StripCoordinates.center t)) : E →L[ℝ] N).comp
+        (mfderiv 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) Ψ
+            (Ψ.symm (d.chart (Smale.StripCoordinates.center t))) :
+          ((ℝ × ℝ) × Z) →L[ℝ] E) := by
+  have hinv :
+    Ψ (Ψ.symm (d.chart (Smale.StripCoordinates.center t))) =
+      d.chart (Smale.StripCoordinates.center t) :=
+    Ψ.right_inv' htarget
+  have hq' :
+    MDifferentiableAt 𝓘(ℝ, E) 𝓘(ℝ, N) q
+      (Ψ (Ψ.symm (d.chart (Smale.StripCoordinates.center t)))) :=
+    hinv.symm ▸ hq.mdifferentiableAt (by simp)
+  unfold normalDetector
+  rw [← mfderiv_eq_fderiv,
+    mfderiv_comp _ hq' (Ψ.mdifferentiableAt (by simp) (Ψ.map_target' htarget)), hinv]
+
+private theorem Smale.StripNormalData.surjective_normalDetector {A B Z E M N : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [TopologicalSpace M] [ChartedSpace E M] {S : Set M}
+    {k : (ℝ × ℝ) → M} (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) (q : M → N) {t : ℝ}
+    (htarget : d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target)
+    (hq : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, N) ∞ q (d.chart (Smale.StripCoordinates.center t)))
+    (hqs :
+      Function.Surjective
+        (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, N) q (d.chart (Smale.StripCoordinates.center t)))) :
+    Function.Surjective (d.normalDetector Ψ q t) := by
+  rw [d.normalDetector_eq_native Ψ q htarget hq]
+  exact hqs.comp (Smale.PartialChart.bijective_mfderiv Ψ (Ψ.map_target' htarget)).surjective
+
+private theorem Smale.StripNormalData.normalDetector_comp_sheet_eq_zero {A B Z E M N : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [TopologicalSpace M] [ChartedSpace E M] {S : Set M}
+    {k : (ℝ × ℝ) → M} (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) (q : M → N) {O : Set M}
+    (hO : IsOpen O) (hq : ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, N) ∞ q O) (hzero : ∀ y ∈ S ∩ O, q y = 0)
+    {t : ℝ} (ht : t ∈ Set.Icc (0 : ℝ) 1)
+    (htarget : d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target)
+    (hcenter : d.chart (Smale.StripCoordinates.center t) ∈ O) :
+    (d.normalDetector Ψ q t).comp (d.sheetDifferential Ψ t) = 0 := by
+  let i := ContinuousLinearMap.inl ℝ (ℝ × A) B
+  have hi : ContinuousAt i (t, 0) := i.continuous.continuousAt
+  have hdc : ContinuousAt d.chart (i (t, 0)) :=
+    d.chart.contMDiffOn_toFun.continuousOn.continuousAt (d.chart.open_source.mem_nhds (d.line ht))
+  have hd : ContinuousAt (d.chart ∘ i) (t, 0) := ContinuousAt.comp (g := d.chart) (f := i) hdc hi
+  have hnearS : ∀ᶠ w : ℝ × A in 𝓝 (t, 0), i w ∈ d.chart.source :=
+    hi.preimage_mem_nhds (d.chart.open_source.mem_nhds (d.line ht))
+  have hnear : ∀ᶠ w : ℝ × A in 𝓝 (t, 0), d.chart (i w) ∈ Ψ.target ∩ O :=
+    hd.preimage_mem_nhds ((Ψ.open_target.inter hO).mem_nhds ⟨htarget, hcenter⟩)
+  have hvanish : ((q ∘ Ψ) ∘ d.sheetTransition Ψ) =ᶠ[𝓝 (t, (0 : A))] (fun _ => 0) := by
+    filter_upwards [hnearS, hnear] with w hw hwo
+    change q (Ψ (Ψ.symm (d.chart (i w)))) = 0
+    have hinv : Ψ (Ψ.symm (d.chart (i w))) = d.chart (i w) := Ψ.right_inv' hwo.1
+    rw [hinv]
+    exact hzero _ ⟨(d.sheet _ hw).mpr rfl, hwo.2⟩
+  have hqΨ := d.contDiffAt_normalMap_in_tube Ψ q htarget (hq.contMDiffAt (hO.mem_nhds hcenter))
+  have hsheet := d.contDiffAt_sheetTransition Ψ ht htarget
+  have hchain :=
+    fderiv_comp (t, (0 : A)) (hqΨ.differentiableAt (by simp)) (hsheet.differentiableAt (by simp))
+  have hder : fderiv ℝ ((q ∘ Ψ) ∘ d.sheetTransition Ψ) (t, (0 : A)) = 0 := by
+    rw [hvanish.fderiv_eq]
+    exact (hasFDerivAt_const (𝕜 := ℝ) (0 : N) (t, (0 : A))).fderiv
+  exact hchain.symm.trans hder
+
+private theorem Smale.StripNormalData.normalDetector_comp_sheet {A B Z E M N : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [TopologicalSpace M] [ChartedSpace E M] {S : Set M}
+    {k : (ℝ × ℝ) → M} (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) (q : M → N) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1) (htarget : d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target)
+    (hq : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, N) ∞ q (d.chart (Smale.StripCoordinates.center t))) :
+    (d.normalDetector Ψ q t).comp (d.sheetDifferential Ψ t) =
+      fderiv ℝ (fun w : ℝ × A => q (d.chart (w, 0))) (t, 0) := by
+  let i := ContinuousLinearMap.inl ℝ (ℝ × A) B
+  have hi : ContinuousAt i (t, 0) := i.continuous.continuousAt
+  have hdc : ContinuousAt d.chart (i (t, 0)) :=
+    d.chart.contMDiffOn_toFun.continuousOn.continuousAt (d.chart.open_source.mem_nhds (d.line ht))
+  have hd : ContinuousAt (d.chart ∘ i) (t, 0) := ContinuousAt.comp (g := d.chart) (f := i) hdc hi
+  have hnear : ∀ᶠ w : ℝ × A in 𝓝 (t, 0), d.chart (i w) ∈ Ψ.target :=
+    hd.preimage_mem_nhds (Ψ.open_target.mem_nhds htarget)
+  have heq :
+    ((q ∘ Ψ) ∘ d.sheetTransition Ψ) =ᶠ[𝓝 (t, (0 : A))] (fun w : ℝ × A => q (d.chart (w, 0))) := by
+    filter_upwards [hnear] with w hw
+    exact congrArg q (Ψ.right_inv' hw)
+  have hqΨ := d.contDiffAt_normalMap_in_tube Ψ q htarget hq
+  have hsheet := d.contDiffAt_sheetTransition Ψ ht htarget
+  have hchain :=
+    fderiv_comp (t, (0 : A)) (hqΨ.differentiableAt (by simp)) (hsheet.differentiableAt (by simp))
+  exact hchain.symm.trans heq.fderiv_eq
+
+private theorem
+    Smale.TubularBigon.opposite_rankThree_corners_iff_normal_sheet_determinants {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k l : (ℝ × ℝ) → M} {h : ℝ} (tube : Smale.TubularBigon (E := E) S T a b k l h 3)
+    (d : Smale.StripNormalData (EuclideanSpace ℝ (Fin 1)) (EuclideanSpace ℝ (Fin 3)) (E := E) S k)
+    (e : Smale.StripNormalData (EuclideanSpace ℝ (Fin 2)) (EuclideanSpace ℝ (Fin 2)) (E := E) T l)
+    (q : M → (ℝ × EuclideanSpace ℝ (Fin 1))) {O : Set M} (hO : IsOpen O)
+    (hq : ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ × EuclideanSpace ℝ (Fin 1)) ∞ q O)
+    (hzero : ∀ y ∈ T ∩ O, q y = 0)
+    (hcenter : ∀ t ∈ Set.Icc (0 : ℝ) 1, e.chart (Smale.StripCoordinates.center t) ∈ O)
+    (hqs :
+      ∀ t ∈ Set.Icc (0 : ℝ) 1,
+        Function.Surjective
+          (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ × EuclideanSpace ℝ (Fin 1)) q
+            (e.chart (Smale.StripCoordinates.center t)))) :
+    (tube.rankThreeSheetPairDet d e 0 * tube.rankThreeSheetPairDet d e 1 < 0) ↔
+      (fderiv ℝ (fun w : ℝ × EuclideanSpace ℝ (Fin 1) => q (d.chart (w, 0))) (0, 0)).det *
+          (fderiv ℝ (fun w : ℝ × EuclideanSpace ℝ (Fin 1) => q (d.chart (w, 0))) (1, 0)).det <
+        0 := by
+  let i : (ℝ × EuclideanSpace ℝ (Fin 1)) ≃L[ℝ] EuclideanSpace ℝ (Fin 2) :=
+    ContinuousLinearEquiv.ofFinrankEq (by simp [Module.finrank_prod])
+  let j := Smale.IntersectionCoordinates.pairCoordinates Smale.FrameField.rankThreePairCoordinates
+  let G := e.sheetDifferential tube.chart
+  let L := d.sheetDifferential tube.chart
+  let C (t : ℝ) := (e.sheetComplement tube.chart t).comp i.toContinuousLinearMap
+  let Q := e.normalDetector tube.chart q
+  have htarget :
+    ∀ t ∈ Set.Icc (0 : ℝ) 1, e.chart (Smale.StripCoordinates.center t) ∈ tube.chart.target :=
+    fun _ ht => tube.upper_chart_center_mem_target e ht
+  have hG : ContDiffOn ℝ ∞ G (Set.Icc (0 : ℝ) 1) :=
+    (e.contDiffOn_sheetDifferential tube.chart).mono (fun t ht => ⟨e.line ht, htarget t ht⟩)
+  have hC : ContDiffOn ℝ ∞ C (Set.Icc (0 : ℝ) 1) :=
+    ((e.contDiffOn_sheetComplement tube.chart).mono
+          (fun t ht => ⟨e.line ht, htarget t ht⟩)).clm_comp
+      contDiffOn_const
+  have hQ : ContDiffOn ℝ ∞ Q (Set.Icc (0 : ℝ) 1) :=
+    e.contDiffOn_normalDetector tube.chart q hO hq htarget hcenter
+  have hi : ∀ t ∈ Set.Icc (0 : ℝ) 1, ((G t).coprod (C t)).IsInvertible := by
+    intro t ht
+    let p :=
+      ContinuousLinearEquiv.prodCongr
+        (ContinuousLinearEquiv.refl ℝ (ℝ × EuclideanSpace ℝ (Fin 2))) i
+    have heq :
+      (G t).coprod (C t) =
+        ((e.sheetDifferential tube.chart t).coprod (e.sheetComplement tube.chart t)).comp
+          p.toContinuousLinearMap := by
+      apply ContinuousLinearMap.ext
+      intro z
+      rfl
+    apply Smale.FrameField.isInvertible_coprod_of_bijective
+    rw [heq]
+    exact
+      (e.isInvertible_sheet_coprod_complement tube.chart ht (htarget t ht)).bijective.comp
+        p.bijective
+  have hQs : ∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Surjective (Q t) := fun t ht =>
+    e.surjective_normalDetector tube.chart q (htarget t ht)
+      (hq.contMDiffAt (hO.mem_nhds (hcenter t ht))) (hqs t ht)
+  have hQG : ∀ t ∈ Set.Icc (0 : ℝ) 1, (Q t).comp (G t) = 0 := fun t ht =>
+    e.normalDetector_comp_sheet_eq_zero tube.chart q hO hq hzero ht (htarget t ht) (hcenter t ht)
+  have hsign :=
+    Smale.FrameField.opposite_intersectionDet_iff_normalDet j G C L Q hG hC hQ hi hQs hQG
+  have hdet (t : ℝ) :
+    tube.rankThreeSheetPairDet d e t =
+      (j.symm.toContinuousLinearMap.comp ((G t).coprod (L t))).det :=
+    Smale.IntersectionCoordinates.det_jointBlock_eq_tangentSum
+      Smale.FrameField.rankThreePairCoordinates (G t) (L t)
+  have hcoeff (t : ℝ) (ht : t = 0 ∨ t = 1) :
+    (Q t).comp (L t) =
+      fderiv ℝ (fun w : ℝ × EuclideanSpace ℝ (Fin 1) => q (d.chart (w, 0))) (t, 0) := by
+    have htI : t ∈ Set.Icc (0 : ℝ) 1 := by rcases ht with rfl | rfl <;> simp
+    have hpoint := tube.rankThree_corner_sheet_charts_coincide d e ht
+    have hqD :
+      ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, ℝ × EuclideanSpace ℝ (Fin 1)) ∞ q
+        (d.chart (Smale.StripCoordinates.center t)) :=
+      hpoint.symm ▸ hq.contMDiffAt (hO.mem_nhds (hcenter t htI))
+    have hQeq : Q t = d.normalDetector tube.chart q t := by
+      change e.normalDetector tube.chart q t = d.normalDetector tube.chart q t
+      unfold Smale.StripNormalData.normalDetector
+      rw [hpoint]
+    rw [hQeq]
+    exact
+      d.normalDetector_comp_sheet tube.chart q htI (tube.lower_chart_center_mem_target d htI) hqD
+  rw [hdet 0, hdet 1]
+  exact hsign.trans (by rw [hcoeff 0 (Or.inl rfl), hcoeff 1 (Or.inr rfl)])
+
+private def
+    Smale.ManifoldMorse.MorseSurgeryData.beltSheetNormal {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (D : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (j : (ℝ × EuclideanSpace ℝ (Fin 1)) ≃L[ℝ] D.chart.NegativeCoordinates) :
+    D.UpperLevel → (ℝ × EuclideanSpace ℝ (Fin 1)) :=
+  j.symm ∘ D.beltNormal
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.opposite_belt_corners_iff_normal_sheet_determinants
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (D : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (j : (ℝ × EuclideanSpace ℝ (Fin 1)) ≃L[ℝ] D.chart.NegativeCoordinates) {S : Set D.UpperLevel}
+    {a b : ℝ → D.UpperLevel} {k l : (ℝ × ℝ) → D.UpperLevel} {h : ℝ} :
+    letI := Smale.RegularLevel.chartedSpace hf D.upper_regular
+    ∀
+      (tube :
+        Smale.TubularBigon (E := Smale.RegularLevel.Model E) S (Set.range D.surgery.beltSphere) a
+          b k l h 3)
+      (d :
+        Smale.StripNormalData (EuclideanSpace ℝ (Fin 1)) (EuclideanSpace ℝ (Fin 3)) (E :=
+          Smale.RegularLevel.Model E) S k)
+      (e :
+        Smale.StripNormalData (EuclideanSpace ℝ (Fin 2)) (EuclideanSpace ℝ (Fin 2)) (E :=
+          Smale.RegularLevel.Model E) (Set.range D.surgery.beltSphere) l),
+      (tube.rankThreeSheetPairDet d e 0 * tube.rankThreeSheetPairDet d e 1 < 0) ↔
+        (fderiv ℝ (fun w : ℝ × EuclideanSpace ℝ (Fin 1) => D.beltSheetNormal j (d.chart (w, 0)))
+                (0, 0)).det *
+            (fderiv ℝ
+                (fun w : ℝ × EuclideanSpace ℝ (Fin 1) => D.beltSheetNormal j (d.chart (w, 0)))
+                (1, 0)).det <
+          0 := by
+  let _ := Smale.RegularLevel.chartedSpace hf D.upper_regular
+  intro tube d e
+  have hq :
+    ContMDiffOn 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, ℝ × EuclideanSpace ℝ (Fin 1)) ∞
+      (D.beltSheetNormal j) D.beltNormalDomain :=
+    j.symm.contDiff.contMDiff.comp_contMDiffOn (D.contMDiffOn_beltNormal hf)
+  have hcenter (t : ℝ) (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    e.chart (Smale.StripCoordinates.center t) ∈ Set.range D.surgery.beltSphere :=
+    (e.sheet _ (e.line ht)).mpr rfl
+  have hcenterO (t : ℝ) (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    e.chart (Smale.StripCoordinates.center t) ∈ D.beltNormalDomain := by
+    obtain ⟨v, hv⟩ := hcenter t ht
+    exact hv ▸ D.belt_mem_normalDomain v
+  apply
+    tube.opposite_rankThree_corners_iff_normal_sheet_determinants d e (D.beltSheetNormal j)
+      D.isOpen_beltNormalDomain hq
+  · rintro y ⟨⟨v, rfl⟩, _⟩
+    change j.symm (D.beltNormal (D.surgery.beltSphere v)) = 0
+    rw [D.beltNormal_belt, map_zero]
+  · exact hcenterO
+  · intro t ht
+    obtain ⟨v, hv⟩ := hcenter t ht
+    rw [← hv]
+    have hnormal :=
+      (D.contMDiffOn_beltNormal hf).contMDiffAt
+        (D.isOpen_beltNormalDomain.mem_nhds (D.belt_mem_normalDomain v))
+    have hJ :
+      mfderiv 𝓘(ℝ, D.chart.NegativeCoordinates) 𝓘(ℝ, ℝ × EuclideanSpace ℝ (Fin 1)) j.symm
+          (D.beltNormal (D.surgery.beltSphere v)) =
+        j.symm.toContinuousLinearMap := by
+      rw [mfderiv_eq_fderiv]
+      exact j.symm.toContinuousLinearMap.fderiv
+    have hjSmooth :
+      ContMDiff 𝓘(ℝ, D.chart.NegativeCoordinates) 𝓘(ℝ, ℝ × EuclideanSpace ℝ (Fin 1)) ∞ j.symm :=
+      j.symm.contDiff.contMDiff
+    rw [beltSheetNormal,
+      mfderiv_comp _ (hjSmooth.mdifferentiableAt (by simp)) (hnormal.mdifferentiableAt (by simp)),
+      hJ]
+    exact j.symm.surjective.comp (D.surjective_beltNormal_derivative hf v)
+
+private def Smale.NativeSheetCoordinates.projection {D B E M N : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, D × B) 𝓘(ℝ, E) (D × B) M ∞) (F : N → M) (x : N) : D :=
+  (Φ.symm (F x)).1
+
+private theorem Smale.NativeSheetCoordinates.contMDiffOn_projection {D B E G H M N : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ G H} [TopologicalSpace M] [ChartedSpace E M]
+    [TopologicalSpace N] [ChartedSpace H N]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, D × B) 𝓘(ℝ, E) (D × B) M ∞) (F : N → M)
+    (hF : ContMDiff I 𝓘(ℝ, E) ∞ F) : ContMDiffOn I 𝓘(ℝ, D) ∞ (projection Φ F) (F ⁻¹' Φ.target) := by
+  have hcoord : ContMDiffOn I 𝓘(ℝ, D × B) ∞ (Φ.symm ∘ F) (F ⁻¹' Φ.target) :=
+    Φ.contMDiffOn_invFun.comp hF.contMDiffOn (fun _ hx => hx)
+  exact contDiff_fst.contMDiff.comp_contMDiffOn hcoord
+
+private theorem Smale.NativeSheetCoordinates.injective_mfderiv_projection {D B E G H M N : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ G H} [TopologicalSpace M] [ChartedSpace E M]
+    [TopologicalSpace N] [ChartedSpace H N]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, D × B) 𝓘(ℝ, E) (D × B) M ∞) (F : N → M)
+    (hF : ContMDiff I 𝓘(ℝ, E) ∞ F) (hclean : ∀ z ∈ Φ.source, Φ z ∈ Set.range F ↔ z.2 = 0) {x : N}
+    (hx : F x ∈ Φ.target) (hiF : Function.Injective (mfderiv I 𝓘(ℝ, E) F x)) :
+    Function.Injective (mfderiv I 𝓘(ℝ, D) (projection Φ F) x) := by
+  let C : N → (D × B) := Φ.symm ∘ F
+  let T : G →L[ℝ] (D × B) := mfderiv I 𝓘(ℝ, D × B) C x
+  have hC : ContMDiffAt I 𝓘(ℝ, D × B) ∞ C x :=
+    (Φ.contMDiffOn_invFun.contMDiffAt (Φ.open_target.mem_nhds hx)).comp x hF.contMDiffAt
+  have hTi : Function.Injective T := by
+    change Function.Injective (mfderiv I 𝓘(ℝ, D × B) (Φ.symm ∘ F) x)
+    rw [mfderiv_comp x (Φ.symm.mdifferentiableAt (by simp) hx) (hF.mdifferentiableAt (by simp))]
+    exact (Smale.PartialChart.bijective_mfderiv Φ.symm hx).injective.comp hiF
+  have hfst :
+    (mfderiv I 𝓘(ℝ, D) (projection Φ F) x : G →L[ℝ] D) = (ContinuousLinearMap.fst ℝ D B).comp T :=
+    by
+    have hp : ContMDiff 𝓘(ℝ, D × B) 𝓘(ℝ, D) ∞ (Prod.fst : D × B → D) := contDiff_fst.contMDiff
+    have hd :
+      mfderiv 𝓘(ℝ, D × B) 𝓘(ℝ, D) (Prod.fst : D × B → D) (C x) = ContinuousLinearMap.fst ℝ D B := by
+      rw [mfderiv_eq_fderiv]
+      exact (ContinuousLinearMap.fst ℝ D B).fderiv
+    change mfderiv I 𝓘(ℝ, D) (Prod.fst ∘ C) x = _
+    rw [mfderiv_comp x (hp.mdifferentiableAt (by simp)) (hC.mdifferentiableAt (by simp)), hd]
+    rfl
+  have hzero : (Prod.snd ∘ C) =ᶠ[𝓝 x] (fun _ => (0 : B)) := by
+    filter_upwards [hF.continuous.continuousAt.preimage_mem_nhds (Φ.open_target.mem_nhds hx)] with
+      y hy
+    exact (hclean _ (Φ.map_target' hy)).mp ⟨y, (Φ.right_inv' hy).symm⟩
+  have hsnd : (ContinuousLinearMap.snd ℝ D B).comp T = 0 := by
+    have hp : ContMDiff 𝓘(ℝ, D × B) 𝓘(ℝ, B) ∞ (Prod.snd : D × B → B) := contDiff_snd.contMDiff
+    have hd :
+      mfderiv 𝓘(ℝ, D × B) 𝓘(ℝ, B) (Prod.snd : D × B → B) (C x) = ContinuousLinearMap.snd ℝ D B := by
+      rw [mfderiv_eq_fderiv]
+      exact (ContinuousLinearMap.snd ℝ D B).fderiv
+    have hz : (mfderiv I 𝓘(ℝ, B) (Prod.snd ∘ C) x : G →L[ℝ] B) = 0 := by
+      rw [hzero.mfderiv_eq, mfderiv_const]
+      rfl
+    rw [mfderiv_comp x (hp.mdifferentiableAt (by simp)) (hC.mdifferentiableAt (by simp)),
+      hd] at hz
+    exact hz
+  intro u v huv
+  apply hTi
+  apply Prod.ext
+  · exact
+      (congrArg (fun L : G →L[ℝ] D => L u) hfst).symm.trans
+        (huv.trans (congrArg (fun L : G →L[ℝ] D => L v) hfst))
+  · have hz (w : G) : (T w).2 = 0 := congrArg (fun L : G →L[ℝ] B => L w) hsnd
+    rw [hz u, hz v]
+
+private theorem Smale.NativeSheetCoordinates.isLocalDiffeomorphOn_projection {D B E G H M N : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ G H} [TopologicalSpace M] [ChartedSpace E M]
+    [TopologicalSpace N] [ChartedSpace H N]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, D × B) 𝓘(ℝ, E) (D × B) M ∞) (F : N → M) [FiniteDimensional ℝ D]
+    [FiniteDimensional ℝ G] [I.Boundaryless] [IsManifold I ∞ N] (hF : ContMDiff I 𝓘(ℝ, E) ∞ F)
+    (hclean : ∀ z ∈ Φ.source, Φ z ∈ Set.range F ↔ z.2 = 0)
+    (hdim : Module.finrank ℝ G = Module.finrank ℝ D)
+    (hiF : ∀ x, Function.Injective (mfderiv I 𝓘(ℝ, E) F x)) :
+    IsLocalDiffeomorphOn I 𝓘(ℝ, D) ∞ (projection Φ F) (F ⁻¹' Φ.target) := by
+  have hU : IsOpen (F ⁻¹' Φ.target) := Φ.open_target.preimage hF.continuous
+  intro x
+  let A : G →L[ℝ] D := mfderiv I 𝓘(ℝ, D) (projection Φ F) x.1
+  have hi : Function.Injective A := injective_mfderiv_projection Φ F hF hclean x.2 (hiF x.1)
+  have hb : Function.Bijective A :=
+    ⟨hi, (LinearMap.injective_iff_surjective_of_finrank_eq_finrank hdim).mp hi⟩
+  have hA : A.IsInvertible :=
+    ⟨(LinearEquiv.ofBijective A.toLinearMap hb).toContinuousLinearEquiv, rfl⟩
+  exact Smale.isLocalDiffeomorphAt_boundaryless hU x.2 (contMDiffOn_projection Φ F hF) hA
+
+private theorem Smale.NativeSheetCoordinates.exists_induced_sheet_chart {D B E G H M N : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] {I : ModelWithCorners ℝ G H}
+    [I.Boundaryless] [TopologicalSpace M] [ChartedSpace E M] [TopologicalSpace N]
+    [ChartedSpace H N] [IsManifold I ∞ N] [Nonempty N]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, D × B) 𝓘(ℝ, E) (D × B) M ∞) (F : N → M)
+    (hF : ContMDiff I 𝓘(ℝ, E) ∞ F) (hinjF : Function.Injective F)
+    (hclean : ∀ z ∈ Φ.source, Φ z ∈ Set.range F ↔ z.2 = 0)
+    (hdim : Module.finrank ℝ G = Module.finrank ℝ D)
+    (hiF : ∀ x, Function.Injective (mfderiv I 𝓘(ℝ, E) F x)) :
+    ∃ c : PartialDiffeomorph 𝓘(ℝ, D) I D N ∞,
+      c.source = {u | (u, (0 : B)) ∈ Φ.source} ∧
+        c.target = F ⁻¹' Φ.target ∧
+          (∀ u ∈ c.source, F (c u) = Φ (u, 0)) ∧ ∀ x, c.symm x = projection Φ F x := by
+  let U := F ⁻¹' Φ.target
+  have hU : IsOpen U := Φ.open_target.preimage hF.continuous
+  have hzero (x : N) (hx : x ∈ U) : (Φ.symm (F x)).2 = 0 :=
+    (hclean _ (Φ.map_target' hx)).mp ⟨x, (Φ.right_inv' hx).symm⟩
+  have hinj : Set.InjOn (projection Φ F) U := by
+    intro x hx y hy heq
+    have hc : Φ.symm (F x) = Φ.symm (F y) := Prod.ext heq ((hzero x hx).trans (hzero y hy).symm)
+    apply hinjF
+    exact (Φ.right_inv' hx).symm.trans ((congrArg Φ hc).trans (Φ.right_inv' hy))
+  let p :=
+    Smale.partialDiffeomorphOfInjectiveLocal hU hinj
+      (isLocalDiffeomorphOn_projection Φ F hF hclean hdim hiF)
+  have htarget : p.target = {u | (u, (0 : B)) ∈ Φ.source} := by
+    change projection Φ F '' U = _
+    ext u
+    constructor
+    · rintro ⟨x, hx, rfl⟩
+      have heq : (projection Φ F x, (0 : B)) = Φ.symm (F x) := Prod.ext rfl (hzero x hx).symm
+      change (projection Φ F x, (0 : B)) ∈ Φ.source
+      rw [heq]
+      exact Φ.map_target' hx
+    · intro hu
+      obtain ⟨x, hx⟩ := (hclean (u, 0) hu).mpr rfl
+      have hxU : x ∈ U := by
+        change F x ∈ Φ.target
+        rw [hx]
+        exact Φ.map_source' hu
+      refine ⟨x, hxU, ?_⟩
+      change (Φ.symm (F x)).1 = u
+      rw [hx]
+      exact congrArg Prod.fst (Φ.left_inv' hu)
+  refine ⟨p.symm, htarget, rfl, ?_, fun _ => rfl⟩
+  intro u hu
+  have hx : p.symm u ∈ U := p.map_target' hu
+  have hp : projection Φ F (p.symm u) = u := p.right_inv' hu
+  have heq : Φ.symm (F (p.symm u)) = (u, (0 : B)) := Prod.ext hp (hzero (p.symm u) hx)
+  exact (Φ.right_inv' hx).symm.trans (congrArg Φ heq)
+
+private def Smale.SphereNormalCoordinates.radialFrame {V N : Type*} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] [NormedAddCommGroup N] [NormedSpace ℝ N] {n : ℕ}
+    [Fact (Module.finrank ℝ V = n + 1)] (x : Metric.sphere (0 : V) 1)
+    (C : N →L[ℝ] EuclideanSpace ℝ (Fin n)) : (ℝ × N) →L[ℝ] V :=
+  ((ContinuousLinearMap.id ℝ ℝ).smulRight (x : V)).coprod ((inclusionDerivative x).comp C)
+
+private theorem Smale.SphereNormalCoordinates.normalFrame_comp_normalDerivative {V N : Type*}
+    [NormedAddCommGroup V] [InnerProductSpace ℝ V] [NormedAddCommGroup N] [NormedSpace ℝ N]
+    {n : ℕ} [Fact (Module.finrank ℝ V = n + 1)] (x : Metric.sphere (0 : V) 1)
+    (A : EuclideanSpace ℝ (Fin n) →L[ℝ] N) (hA : A.IsInvertible)
+    (C : N →L[ℝ] EuclideanSpace ℝ (Fin n)) :
+    (normalFrame x A).comp ((ContinuousLinearMap.id ℝ ℝ).prodMap (A.comp C)) = radialFrame x C := by
+  apply ContinuousLinearMap.ext
+  intro z
+  change
+    z.1 • (x : V) + inclusionDerivative x (A.inverse (A (C z.2))) =
+      z.1 • (x : V) + inclusionDerivative x (C z.2)
+  rw [hA.inverse_apply_self]
+
+private theorem
+    Smale.SphereNormalCoordinates.bijective_radialFrame {V N : Type*} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] [NormedAddCommGroup N] [NormedSpace ℝ N] {n : ℕ}
+    [Fact (Module.finrank ℝ V = n + 1)] (x : Metric.sphere (0 : V) 1)
+    (C : N →L[ℝ] EuclideanSpace ℝ (Fin n)) (hC : C.IsInvertible) :
+    Function.Bijective (radialFrame x C) := by
+  have heq : radialFrame x C = normalFrame x C.inverse := by
+    apply ContinuousLinearMap.ext
+    intro z
+    change
+      z.1 • (x : V) + inclusionDerivative x (C z.2) =
+        z.1 • (x : V) + inclusionDerivative x (C.inverse.inverse z.2)
+    rw [hC.inverse_inverse]
+  rw [heq]
+  exact bijective_normalFrame x C.inverse hC.inverse
+
+private theorem Smale.SphereNormalCoordinates.normalJacobian_mul_chartDet {V N : Type*}
+    [NormedAddCommGroup V] [InnerProductSpace ℝ V] [NormedAddCommGroup N] [NormedSpace ℝ N]
+    {n : ℕ} [Fact (Module.finrank ℝ V = n + 1)] [FiniteDimensional ℝ N] (j : (ℝ × N) ≃L[ℝ] V)
+    (x : Metric.sphere (0 : V) 1) (A : EuclideanSpace ℝ (Fin n) →L[ℝ] N) (hA : A.IsInvertible)
+    (C : N →L[ℝ] EuclideanSpace ℝ (Fin n)) :
+    normalJacobian j x A * (A.comp C).det =
+      ((radialFrame x C).comp j.symm.toContinuousLinearMap).det := by
+  let R : (ℝ × N) →L[ℝ] (ℝ × N) := (ContinuousLinearMap.id ℝ ℝ).prodMap (A.comp C)
+  let T : V →L[ℝ] V := j.toContinuousLinearMap.comp (R.comp j.symm.toContinuousLinearMap)
+  have hdetT : T.det = (A.comp C).det := by
+    have hconj : T.det = R.det := LinearMap.det_conj R.toLinearMap j.toLinearEquiv
+    rw [hconj]
+    change (LinearMap.prodMap (LinearMap.id : ℝ →ₗ[ℝ] ℝ) (A.comp C).toLinearMap).det = _
+    rw [LinearMap.det_prodMap, LinearMap.det_id, one_mul]
+  have hfactor :
+    ((normalFrame x A).comp j.symm.toContinuousLinearMap).comp T =
+      (radialFrame x C).comp j.symm.toContinuousLinearMap := by
+    have h := normalFrame_comp_normalDerivative x A hA C
+    ext v
+    change normalFrame x A (j.symm (j (R (j.symm v)))) = radialFrame x C (j.symm v)
+    rw [j.symm_apply_apply]
+    exact congrArg (fun L : (ℝ × N) →L[ℝ] V => L (j.symm v)) h
+  calc
+    normalJacobian j x A * (A.comp C).det =
+        (((normalFrame x A).comp j.symm.toContinuousLinearMap).comp T).det := by
+      rw [← hdetT]
+      exact (LinearMap.det_comp _ _).symm
+    _ = _ := congrArg ContinuousLinearMap.det hfactor
+
+private def Smale.SphereNormalCoordinates.chartRadialFrame {V N : Type*} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] [NormedAddCommGroup N] [NormedSpace ℝ N] {n : ℕ}
+    [Fact (Module.finrank ℝ V = n + 1)]
+    (c : PartialDiffeomorph 𝓘(ℝ, N) (𝓡 n) N (Metric.sphere (0 : V) 1) ∞) (z : N) :
+    (ℝ × N) →L[ℝ] V :=
+  ((ContinuousLinearMap.id ℝ ℝ).smulRight (c z : V)).coprod (fderiv ℝ (fun w => (c w : V)) z)
+
+private theorem
+    Smale.SphereNormalCoordinates.chartRadialFrame_eq {V N : Type*} [NormedAddCommGroup V]
+    [InnerProductSpace ℝ V] [NormedAddCommGroup N] [NormedSpace ℝ N] {n : ℕ}
+    [Fact (Module.finrank ℝ V = n + 1)]
+    (c : PartialDiffeomorph 𝓘(ℝ, N) (𝓡 n) N (Metric.sphere (0 : V) 1) ∞) {z : N}
+    (hz : z ∈ c.source) :
+    chartRadialFrame c z =
+      radialFrame (N := N) (c z) (mfderiv 𝓘(ℝ, N) (𝓡 n) c z : N →L[ℝ] EuclideanSpace ℝ (Fin n)) :=
+  by
+  have hchain :
+    fderiv ℝ (fun w => (c w : V)) z =
+      (inclusionDerivative (c z)).comp
+        (mfderiv 𝓘(ℝ, N) (𝓡 n) c z : N →L[ℝ] EuclideanSpace ℝ (Fin n)) := by
+    have h :=
+      mfderiv_comp z ((contMDiff_coe_sphere (m := (∞ : ℕ∞ω))).mdifferentiableAt (by simp))
+        (c.mdifferentiableAt (by simp) hz)
+    rw [mfderiv_eq_fderiv] at h
+    exact h
+  unfold chartRadialFrame radialFrame
+  rw [hchain]
+  rfl
+
+private theorem Smale.SphereNormalCoordinates.contDiffOn_chartRadialFrame {V N : Type*}
+    [NormedAddCommGroup V] [InnerProductSpace ℝ V] [NormedAddCommGroup N] [NormedSpace ℝ N]
+    {n : ℕ} [Fact (Module.finrank ℝ V = n + 1)]
+    (c : PartialDiffeomorph 𝓘(ℝ, N) (𝓡 n) N (Metric.sphere (0 : V) 1) ∞) :
+    ContDiffOn ℝ ∞ (chartRadialFrame c) c.source := by
+  have hc : ContDiffOn ℝ ∞ (fun w => (c w : V)) c.source :=
+    ((contMDiff_coe_sphere (m := (∞ : ℕ∞ω))).comp_contMDiffOn c.contMDiffOn_toFun).contDiffOn
+  exact
+    Smale.FrameField.contDiffOn_coprod (contDiffOn_const.smulRight hc)
+      (hc.fderiv_of_isOpen c.open_source (m := ∞) (by simp))
+
+private theorem Smale.SphereNormalCoordinates.bijective_chartRadialFrame {V N : Type*}
+    [NormedAddCommGroup V] [InnerProductSpace ℝ V] [NormedAddCommGroup N] [NormedSpace ℝ N]
+    {n : ℕ} [Fact (Module.finrank ℝ V = n + 1)]
+    (c : PartialDiffeomorph 𝓘(ℝ, N) (𝓡 n) N (Metric.sphere (0 : V) 1) ∞) [FiniteDimensional ℝ N]
+    {z : N} (hz : z ∈ c.source) : Function.Bijective (chartRadialFrame c z) := by
+  rw [chartRadialFrame_eq c hz]
+  let C : N →L[ℝ] EuclideanSpace ℝ (Fin n) := mfderiv 𝓘(ℝ, N) (𝓡 n) c z
+  have hC : C.IsInvertible :=
+    ⟨(LinearEquiv.ofBijective C.toLinearMap
+          (Smale.PartialChart.bijective_mfderiv c hz)).toContinuousLinearEquiv,
+      rfl⟩
+  exact bijective_radialFrame (c z) C hC
+
+private theorem Smale.SphereNormalCoordinates.chartRadialFrame_det_mul_endpoints_pos {V N : Type*}
+    [NormedAddCommGroup V] [InnerProductSpace ℝ V] [NormedAddCommGroup N] [NormedSpace ℝ N]
+    {n : ℕ} [Fact (Module.finrank ℝ V = n + 1)]
+    (c : PartialDiffeomorph 𝓘(ℝ, N) (𝓡 n) N (Metric.sphere (0 : V) 1) ∞) [FiniteDimensional ℝ N]
+    [FiniteDimensional ℝ V] (j : (ℝ × N) ≃L[ℝ] V) (a : ℝ → N)
+    (ha : ContinuousOn a (Set.Icc (0 : ℝ) 1)) (haS : Set.MapsTo a (Set.Icc (0 : ℝ) 1) c.source) :
+    0 <
+      ((chartRadialFrame c (a 0)).comp j.symm.toContinuousLinearMap).det *
+        ((chartRadialFrame c (a 1)).comp j.symm.toContinuousLinearMap).det := by
+  have hF := (contDiffOn_chartRadialFrame c).continuousOn.comp ha haS
+  exact
+    Smale.FrameField.det_mul_endpoints_pos (hF.clm_comp continuousOn_const)
+      (fun t ht => (bijective_chartRadialFrame c (haS ht)).comp j.symm.bijective)
+
+private theorem Smale.SphereNormalCoordinates.opposite_normalJacobians_iff_chartDet {V N : Type*}
+    [NormedAddCommGroup V] [InnerProductSpace ℝ V] [NormedAddCommGroup N] [NormedSpace ℝ N]
+    {n : ℕ} [Fact (Module.finrank ℝ V = n + 1)]
+    (c : PartialDiffeomorph 𝓘(ℝ, N) (𝓡 n) N (Metric.sphere (0 : V) 1) ∞) [FiniteDimensional ℝ N]
+    [FiniteDimensional ℝ V] (j : (ℝ × N) ≃L[ℝ] V) (a : ℝ → N)
+    (ha : ContinuousOn a (Set.Icc (0 : ℝ) 1)) (haS : Set.MapsTo a (Set.Icc (0 : ℝ) 1) c.source)
+    (A B : EuclideanSpace ℝ (Fin n) →L[ℝ] N) (hA : A.IsInvertible) (hB : B.IsInvertible) :
+    normalJacobian j (c (a 0)) A * normalJacobian j (c (a 1)) B < 0 ↔
+      (A.comp (mfderiv 𝓘(ℝ, N) (𝓡 n) c (a 0) : N →L[ℝ] EuclideanSpace ℝ (Fin n))).det *
+          (B.comp (mfderiv 𝓘(ℝ, N) (𝓡 n) c (a 1) : N →L[ℝ] EuclideanSpace ℝ (Fin n))).det <
+        0 := by
+  let C₀ : N →L[ℝ] EuclideanSpace ℝ (Fin n) := mfderiv 𝓘(ℝ, N) (𝓡 n) c (a 0)
+  let C₁ : N →L[ℝ] EuclideanSpace ℝ (Fin n) := mfderiv 𝓘(ℝ, N) (𝓡 n) c (a 1)
+  have h₀ :
+    normalJacobian j (c (a 0)) A * (A.comp C₀).det =
+      ((chartRadialFrame c (a 0)).comp j.symm.toContinuousLinearMap).det := by
+    rw [chartRadialFrame_eq c (haS (by simp))]
+    exact normalJacobian_mul_chartDet j (c (a 0)) A hA C₀
+  have h₁ :
+    normalJacobian j (c (a 1)) B * (B.comp C₁).det =
+      ((chartRadialFrame c (a 1)).comp j.symm.toContinuousLinearMap).det := by
+    rw [chartRadialFrame_eq c (haS (by simp))]
+    exact normalJacobian_mul_chartDet j (c (a 1)) B hB C₁
+  have hp :
+    0 <
+      (normalJacobian j (c (a 0)) A * normalJacobian j (c (a 1)) B) *
+        ((A.comp C₀).det * (B.comp C₁).det) := by
+    have heq :
+      (normalJacobian j (c (a 0)) A * normalJacobian j (c (a 1)) B) *
+          ((A.comp C₀).det * (B.comp C₁).det) =
+        (normalJacobian j (c (a 0)) A * (A.comp C₀).det) *
+          (normalJacobian j (c (a 1)) B * (B.comp C₁).det) := by ring
+    rw [heq, h₀, h₁]
+    exact chartRadialFrame_det_mul_endpoints_pos c j a ha haS
+  change _ ↔ (A.comp C₀).det * (B.comp C₁).det < 0
+  rcases mul_pos_iff.mp hp with ⟨hp, hq⟩ | ⟨hp, hq⟩
+  · exact iff_of_false (not_lt_of_gt hp) (not_lt_of_gt hq)
+  · exact iff_of_true hp hq
+
+private theorem Smale.SphereNormalCoordinates.opposite_normalJacobians_iff_retained_sheet
+    {V A B E M : Type*} [NormedAddCommGroup V] [InnerProductSpace ℝ V] [FiniteDimensional ℝ V]
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] {n : ℕ} [Fact (Module.finrank ℝ V = n + 1)]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, (ℝ × A) × B) 𝓘(ℝ, E) ((ℝ × A) × B) M ∞)
+    (F : Metric.sphere (0 : V) 1 → M) (hF : ContMDiff (𝓡 n) 𝓘(ℝ, E) ∞ F)
+    (hinjF : Function.Injective F) (hiF : ∀ x, Function.Injective (mfderiv (𝓡 n) 𝓘(ℝ, E) F x))
+    (hclean : ∀ z ∈ Φ.source, Φ z ∈ Set.range F ↔ z.2 = 0)
+    (hline : ∀ t ∈ Set.Icc (0 : ℝ) 1, ((t, (0 : A)), (0 : B)) ∈ Φ.source)
+    (hdim : Module.finrank ℝ (ℝ × A) = n) (q : M → (ℝ × A)) (r : (ℝ × (ℝ × A)) ≃L[ℝ] V)
+    (x₀ x₁ : Metric.sphere (0 : V) 1) (hx₀ : F x₀ = Φ ((0, 0), 0)) (hx₁ : F x₁ = Φ ((1, 0), 0))
+    (hq₀ : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, ℝ × A) ∞ q (F x₀))
+    (hq₁ : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, ℝ × A) ∞ q (F x₁))
+    (hi₀ : (mfderiv (𝓡 n) 𝓘(ℝ, ℝ × A) (q ∘ F) x₀).IsInvertible)
+    (hi₁ : (mfderiv (𝓡 n) 𝓘(ℝ, ℝ × A) (q ∘ F) x₁).IsInvertible) :
+    normalJacobian r x₀ (mfderiv (𝓡 n) 𝓘(ℝ, ℝ × A) (q ∘ F) x₀) *
+          normalJacobian r x₁ (mfderiv (𝓡 n) 𝓘(ℝ, ℝ × A) (q ∘ F) x₁) <
+        0 ↔
+      (fderiv ℝ (fun w : ℝ × A => q (Φ (w, 0))) (0, 0)).det *
+          (fderiv ℝ (fun w : ℝ × A => q (Φ (w, 0))) (1, 0)).det <
+        0 := by
+  let _ : Nonempty (Metric.sphere (0 : V) 1) := ⟨x₀⟩
+  obtain ⟨c, hcS, _, hFc, _⟩ :=
+    Smale.NativeSheetCoordinates.exists_induced_sheet_chart Φ F hF hinjF hclean
+      (by simpa only [finrank_euclideanSpace_fin] using hdim.symm) hiF
+  let a : ℝ → (ℝ × A) := fun t => (t, 0)
+  have ha : ContinuousOn a (Set.Icc (0 : ℝ) 1) :=
+    (continuous_id.prodMk continuous_const).continuousOn
+  have haS : Set.MapsTo a (Set.Icc (0 : ℝ) 1) c.source := by
+    intro t ht
+    rw [hcS]
+    exact hline t ht
+  have h₀ : c (a 0) = x₀ := hinjF ((hFc _ (haS (by simp))).trans hx₀.symm)
+  have h₁ : c (a 1) = x₁ := hinjF ((hFc _ (haS (by simp))).trans hx₁.symm)
+  let A₀ : EuclideanSpace ℝ (Fin n) →L[ℝ] (ℝ × A) := mfderiv (𝓡 n) 𝓘(ℝ, ℝ × A) (q ∘ F) x₀
+  let A₁ : EuclideanSpace ℝ (Fin n) →L[ℝ] (ℝ × A) := mfderiv (𝓡 n) 𝓘(ℝ, ℝ × A) (q ∘ F) x₁
+  have hsign := opposite_normalJacobians_iff_chartDet c r a ha haS A₀ A₁ hi₀ hi₁
+  have hcoeff (t : ℝ) (x : Metric.sphere (0 : V) 1) (ht : t ∈ Set.Icc (0 : ℝ) 1)
+    (hx : c (a t) = x) (hq : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, ℝ × A) ∞ q (F x)) :
+    (mfderiv (𝓡 n) 𝓘(ℝ, ℝ × A) (q ∘ F) x : EuclideanSpace ℝ (Fin n) →L[ℝ] (ℝ × A)).comp
+        (mfderiv 𝓘(ℝ, ℝ × A) (𝓡 n) c (a t) : (ℝ × A) →L[ℝ] EuclideanSpace ℝ (Fin n)) =
+      fderiv ℝ (fun w : ℝ × A => q (Φ (w, 0))) (t, 0) := by
+    have hqF : ContMDiffAt (𝓡 n) 𝓘(ℝ, ℝ × A) ∞ (q ∘ F) (c (a t)) := by
+      rw [hx]
+      exact hq.comp x hF.contMDiffAt
+    have hchain :=
+      mfderiv_comp (a t) (hqF.mdifferentiableAt (by simp))
+        (c.mdifferentiableAt (by simp) (haS ht))
+    have heq : ((q ∘ F) ∘ c) =ᶠ[𝓝 (a t)] (fun w => q (Φ (w, 0))) := by
+      filter_upwards [c.open_source.mem_nhds (haS ht)] with w hw
+      exact congrArg q (hFc w hw)
+    have hpoint :
+      (mfderiv (𝓡 n) 𝓘(ℝ, ℝ × A) (q ∘ F) (c (a t)) : EuclideanSpace ℝ (Fin n) →L[ℝ] (ℝ × A)) =
+        mfderiv (𝓡 n) 𝓘(ℝ, ℝ × A) (q ∘ F) x := by rw [hx]
+    rw [mfderiv_eq_fderiv] at hchain
+    have h := hchain.symm.trans heq.fderiv_eq
+    exact
+      (congrArg
+            (fun L : EuclideanSpace ℝ (Fin n) →L[ℝ] (ℝ × A) =>
+              L.comp (mfderiv 𝓘(ℝ, ℝ × A) (𝓡 n) c (a t) : (ℝ × A) →L[ℝ] EuclideanSpace ℝ (Fin n)))
+            hpoint).symm.trans
+        h
+  rw [h₀, h₁] at hsign
+  let C₀ : (ℝ × A) →L[ℝ] EuclideanSpace ℝ (Fin n) := mfderiv 𝓘(ℝ, ℝ × A) (𝓡 n) c (a 0)
+  let C₁ : (ℝ × A) →L[ℝ] EuclideanSpace ℝ (Fin n) := mfderiv 𝓘(ℝ, ℝ × A) (𝓡 n) c (a 1)
+  have hc₀ : A₀.comp C₀ = fderiv ℝ (fun w : ℝ × A => q (Φ (w, 0))) (0, 0) :=
+    hcoeff 0 x₀ (by simp) h₀ hq₀
+  have hc₁ : A₁.comp C₁ = fderiv ℝ (fun w : ℝ × A => q (Φ (w, 0))) (1, 0) :=
+    hcoeff 1 x₁ (by simp) h₁ hq₁
+  change
+    normalJacobian r x₀ A₀ * normalJacobian r x₁ A₁ < 0 ↔
+      (A₀.comp C₀).det * (A₁.comp C₁).det < 0 at hsign
+  rw [hc₀, hc₁] at hsign
+  exact hsign
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.opposite_beltIntersectionSigns_iff_Whitney_corners
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (D : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (hindex : Module.finrank ℝ D.chart.NegativeCoordinates = 2)
+    (r : (ℝ × D.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient 3)
+    (g : Smale.Hemisphere.Sphere 2 → D.UpperLevel) {a b : ℝ → D.UpperLevel}
+    {k l : (ℝ × ℝ) → D.UpperLevel} {h : ℝ} :
+    letI := Smale.RegularLevel.chartedSpace hf D.upper_regular
+    letI : Fact (Module.finrank ℝ D.chart.PositiveCoordinates = 3 + 1) :=
+      ⟨by have hh := D.chart.finrank_negative_add_positive; omega⟩
+    ∀ (_hg : ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g) (_hinj : Function.Injective g)
+      (_hi : ∀ x, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) g x))
+      (_ht :
+        ∀ x y,
+          Smale.NativeTransversality.At (𝓡 2) (𝓡 3) 𝓘(ℝ, Smale.RegularLevel.Model E) g
+            D.surgery.beltSphere x y)
+      (tube :
+        Smale.TubularBigon (E := Smale.RegularLevel.Model E) (Set.range g)
+          (Set.range D.surgery.beltSphere) a b k l h 3)
+      (d :
+        Smale.StripNormalData (EuclideanSpace ℝ (Fin 1)) (EuclideanSpace ℝ (Fin 3)) (E :=
+          Smale.RegularLevel.Model E) (Set.range g) k)
+      (e :
+        Smale.StripNormalData (EuclideanSpace ℝ (Fin 2)) (EuclideanSpace ℝ (Fin 2)) (E :=
+          Smale.RegularLevel.Model E) (Set.range D.surgery.beltSphere) l)
+      (x₀ x₁ : Smale.Hemisphere.Sphere 2),
+      g x₀ = d.chart (Smale.StripCoordinates.center 0) →
+        g x₁ = d.chart (Smale.StripCoordinates.center 1) →
+          ((D.beltIntersectionSign 2 r g x₀ * D.beltIntersectionSign 2 r g x₁ = -1) ↔
+            tube.rankThreeSheetPairDet d e 0 * tube.rankThreeSheetPairDet d e 1 < 0) := by
+  let _ := Smale.RegularLevel.chartedSpace hf D.upper_regular
+  let _ : Fact (Module.finrank ℝ D.chart.PositiveCoordinates = 3 + 1) :=
+    ⟨by have hh := D.chart.finrank_negative_add_positive; omega⟩
+  let _ : Fact (Module.finrank ℝ (Smale.Hemisphere.Ambient 3) = 2 + 1) :=
+    ⟨finrank_euclideanSpace_fin⟩
+  intro hg hinj hi ht tube d e x₀ x₁ hx₀ hx₁
+  let j : (ℝ × EuclideanSpace ℝ (Fin 1)) ≃L[ℝ] D.chart.NegativeCoordinates :=
+    ContinuousLinearEquiv.ofFinrankEq (by simp [Module.finrank_prod, hindex])
+  let q := D.beltSheetNormal j
+  let r' := (ContinuousLinearEquiv.prodCongr (ContinuousLinearEquiv.refl ℝ ℝ) j).trans r
+  have hjSmooth :
+    ContMDiff 𝓘(ℝ, D.chart.NegativeCoordinates) 𝓘(ℝ, ℝ × EuclideanSpace ℝ (Fin 1)) ∞ j.symm :=
+    j.symm.contDiff.contMDiff
+  have hdata (x : Smale.Hemisphere.Sphere 2) (hx : g x ∈ Set.range D.surgery.beltSphere) :
+    ContMDiffAt 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, ℝ × EuclideanSpace ℝ (Fin 1)) ∞ q (g x) ∧
+      (mfderiv (𝓡 2) 𝓘(ℝ, ℝ × EuclideanSpace ℝ (Fin 1)) (q ∘ g) x).IsInvertible ∧
+        Smale.SphereNormalCoordinates.normalJacobian r' x
+            (mfderiv (𝓡 2) 𝓘(ℝ, ℝ × EuclideanSpace ℝ (Fin 1)) (q ∘ g) x) =
+          D.beltIntersectionJacobian 2 r g x := by
+    obtain ⟨v, hv⟩ := hx
+    have hxO : g x ∈ D.beltNormalDomain := hv ▸ D.belt_mem_normalDomain v
+    have hnormal :=
+      (D.contMDiffOn_beltNormal hf).contMDiffAt (D.isOpen_beltNormalDomain.mem_nhds hxO)
+    have hq :
+      ContMDiffAt 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, ℝ × EuclideanSpace ℝ (Fin 1)) ∞ q (g x) :=
+      hjSmooth.contMDiffAt.comp _ hnormal
+    let A : EuclideanSpace ℝ (Fin 2) →L[ℝ] D.chart.NegativeCoordinates :=
+      mfderiv (𝓡 2) 𝓘(ℝ, D.chart.NegativeCoordinates) (D.beltNormal ∘ g) x
+    let B : EuclideanSpace ℝ (Fin 2) →L[ℝ] (ℝ × EuclideanSpace ℝ (Fin 1)) :=
+      mfderiv (𝓡 2) 𝓘(ℝ, ℝ × EuclideanSpace ℝ (Fin 1)) (q ∘ g) x
+    have hAb : Function.Bijective A :=
+      D.bijective_beltNormal_comp_of_transverse hf 3 2 hindex g hg x v hv (ht x v hv)
+    have hA : A.IsInvertible :=
+      ⟨(LinearEquiv.ofBijective A.toLinearMap hAb).toContinuousLinearEquiv, rfl⟩
+    have hJ :
+      mfderiv 𝓘(ℝ, D.chart.NegativeCoordinates) 𝓘(ℝ, ℝ × EuclideanSpace ℝ (Fin 1)) j.symm
+          (D.beltNormal (g x)) =
+        j.symm.toContinuousLinearMap := by
+      rw [mfderiv_eq_fderiv]
+      exact j.symm.toContinuousLinearMap.fderiv
+    have hBA : B = j.symm.toContinuousLinearMap.comp A := by
+      change mfderiv (𝓡 2) 𝓘(ℝ, ℝ × EuclideanSpace ℝ (Fin 1)) (j.symm ∘ (D.beltNormal ∘ g)) x = _
+      rw [mfderiv_comp x (hjSmooth.mdifferentiableAt (by simp))
+          ((hnormal.comp x hg.contMDiffAt).mdifferentiableAt (by simp))]
+      change
+        (mfderiv 𝓘(ℝ, D.chart.NegativeCoordinates) 𝓘(ℝ, ℝ × EuclideanSpace ℝ (Fin 1)) j.symm
+                  (D.beltNormal (g x)) :
+                D.chart.NegativeCoordinates →L[ℝ] (ℝ × EuclideanSpace ℝ (Fin 1))).comp
+            A =
+          _
+      exact
+        congrArg
+          (fun L : D.chart.NegativeCoordinates →L[ℝ] (ℝ × EuclideanSpace ℝ (Fin 1)) => L.comp A)
+          hJ
+    refine ⟨hq, ?_, ?_⟩
+    · change B.IsInvertible
+      rw [hBA]
+      exact (show j.symm.toContinuousLinearMap.IsInvertible from ⟨j.symm, rfl⟩).comp hA
+    · change
+        Smale.SphereNormalCoordinates.normalJacobian r' x B =
+          Smale.SphereNormalCoordinates.normalJacobian r x A
+      rw [hBA]
+      exact Smale.SphereNormalCoordinates.normalJacobian_change_normal_model r j x A hA
+  have hcross (t : ℝ) (ht' : t = 0 ∨ t = 1) (x : Smale.Hemisphere.Sphere 2)
+    (hx : g x = d.chart (Smale.StripCoordinates.center t)) :
+    g x ∈ Set.range D.surgery.beltSphere := by
+    have htI : t ∈ Set.Icc (0 : ℝ) 1 := by rcases ht' with rfl | rfl <;> simp
+    rw [hx, tube.rankThree_corner_sheet_charts_coincide d e ht']
+    exact (e.sheet _ (e.line htI)).mpr rfl
+  obtain ⟨hq₀, hi₀, hJ₀⟩ := hdata x₀ (hcross 0 (Or.inl rfl) x₀ hx₀)
+  obtain ⟨hq₁, hi₁, hJ₁⟩ := hdata x₁ (hcross 1 (Or.inr rfl) x₁ hx₁)
+  have hsign :=
+    Smale.SphereNormalCoordinates.opposite_normalJacobians_iff_retained_sheet d.chart g hg hinj hi
+      d.sheet d.line (by simp [Module.finrank_prod]) q r' x₀ x₁ hx₀ hx₁ hq₀ hq₁ hi₀ hi₁
+  rw [hJ₀, hJ₁] at hsign
+  exact
+    (D.beltIntersectionSigns_opposite_iff 2 r g x₀ x₁).trans
+      (hsign.trans (D.opposite_belt_corners_iff_normal_sheet_determinants hf j tube d e).symm)
+
+private def Smale.WhitneyPairModel.innerBigonMap (h r : ℝ) (p : ℝ × ℝ) : ℝ × ℝ :=
+  (1 - r) • (0, h / 2) + r • p
+
+private theorem
+    Smale.WhitneyPairModel.innerBigonMap_one (h : ℝ) (p : ℝ × ℝ) : innerBigonMap h 1 p = p := by
+  simp only [innerBigonMap, sub_self, zero_smul, one_smul, zero_add]
+
+private theorem Smale.WhitneyPairModel.contDiff_innerBigonMap (h : ℝ) :
+    ContDiff ℝ ∞ (fun z : ℝ × (ℝ × ℝ) => innerBigonMap h z.1 z.2) := by
+  unfold innerBigonMap
+  fun_prop
+
+private def Smale.WhitneyPairModel.innerBigonDiffeomorph (h r : ℝ) (hr : r ≠ 0) :
+    Diffeomorph 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, ℝ × ℝ) (ℝ × ℝ) (ℝ × ℝ) ∞
+    where
+  toEquiv :=
+    { toFun := innerBigonMap h r
+      invFun := fun p => r⁻¹ • (p - (1 - r) • (0, h / 2))
+      left_inv := by
+        intro p
+        simp only [innerBigonMap, add_sub_cancel_left, smul_smul, inv_mul_cancel₀ hr, one_smul]
+      right_inv := by
+        intro p
+        simp only [innerBigonMap, smul_smul, mul_inv_cancel₀ hr, one_smul]
+        abel }
+  contMDiff_toFun := by
+    change ContMDiff 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, ℝ × ℝ) ∞ (innerBigonMap h r)
+    apply ContDiff.contMDiff
+    unfold innerBigonMap
+    fun_prop
+  contMDiff_invFun := by
+    change ContMDiff 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, ℝ × ℝ) ∞ (fun p : ℝ × ℝ => r⁻¹ • (p - (1 - r) • (0, h / 2)))
+    apply ContDiff.contMDiff
+    fun_prop
+
+private theorem Smale.WhitneyPairModel.bijective_mfderiv_innerBigonMap (h r : ℝ) (hr : r ≠ 0)
+    (p : ℝ × ℝ) : Function.Bijective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, ℝ × ℝ) (innerBigonMap h r) p) :=
+  Smale.PartialChart.bijective_mfderiv (innerBigonDiffeomorph h r hr).toPartialDiffeomorph
+    (Set.mem_univ p)
+
+private theorem Smale.WhitneyPairModel.innerBigonMap_mem_interior {h r : ℝ} (hh : 0 < h)
+    (hr : r ∈ Set.Ioo (0 : ℝ) 1) {p : ℝ × ℝ} (hp : p ∈ bigon h) :
+    innerBigonMap h r p ∈ interior (bigon h) :=
+  (convex_bigon hh.le).combo_interior_self_mem_interior (bigon_center_mem_interior hh) hp
+    (sub_pos.mpr hr.2) hr.1.le (by ring)
+
+private def Smale.WhitneyPairModel.innerBigonCollar (h r : ℝ) : Set (ℝ × ℝ) :=
+  bigon h \ innerBigonMap h r '' interior (bigon h)
+
+private def Smale.WhitneyPairModel.inverseInnerBigonMap (h r : ℝ) (p : ℝ × ℝ) : ℝ × ℝ :=
+  r⁻¹ • (p - (1 - r) • (0, h / 2))
+
+private theorem Smale.WhitneyPairModel.inverseInnerBigonMap_one (h : ℝ) (p : ℝ × ℝ) :
+    inverseInnerBigonMap h 1 p = p := by
+  simp only [inverseInnerBigonMap, inv_one, sub_self, zero_smul, sub_zero, one_smul]
+
+private theorem
+    Smale.WhitneyPairModel.inner_inverseInnerBigonMap (h r : ℝ) (hr : r ≠ 0) (p : ℝ × ℝ) :
+    innerBigonMap h r (inverseInnerBigonMap h r p) = p :=
+  (innerBigonDiffeomorph h r hr).apply_symm_apply p
+
+private theorem Smale.WhitneyPairModel.continuousAt_inverseInnerBigonMap (h : ℝ) (p : ℝ × ℝ) :
+    ContinuousAt (fun z : ℝ × (ℝ × ℝ) => inverseInnerBigonMap h z.1 z.2) (1, p) := by
+  unfold inverseInnerBigonMap
+  fun_prop (disch := norm_num)
+
+private theorem
+    Smale.WhitneyPairModel.isCompact_innerBigonCollar {h r : ℝ} (hh : 0 < h) (hr : r ≠ 0) :
+    IsCompact (innerBigonCollar h r) := by
+  have ho : IsOpen (innerBigonMap h r '' interior (bigon h)) :=
+    (innerBigonDiffeomorph h r hr).toHomeomorph.isOpenMap _ isOpen_interior
+  exact (isCompact_bigon hh).inter_right ho.isClosed_compl
+
+private theorem Smale.WhitneyPairModel.innerBigonMap_mem_collar_iff {h r : ℝ} (hh : 0 < h)
+    (hr : r ∈ Set.Ioo (0 : ℝ) 1) {p : ℝ × ℝ} (hp : p ∈ bigon h) :
+    innerBigonMap h r p ∈ innerBigonCollar h r ↔ p ∈ frontier (bigon h) := by
+  rw [frontier, (isClosed_bigon h).closure_eq]
+  constructor
+  · intro hx
+    exact ⟨hp, fun hi => hx.2 (Set.mem_image_of_mem _ hi)⟩
+  · intro hx
+    refine ⟨interior_subset (innerBigonMap_mem_interior hh hr hp), ?_⟩
+    rintro ⟨q, hq, heq⟩
+    have hqp : q = p := (innerBigonDiffeomorph h r hr.1.ne').injective heq
+    exact hx.2 (hqp ▸ hq)
+
+private theorem Smale.WhitneyPairModel.exists_inner_bigon_collar_in_open {h : ℝ} (hh : 0 < h)
+    {U : Set (ℝ × ℝ)} (hU : IsOpen U) (hfrontU : frontier (bigon h) ⊆ U) :
+    ∃ r : ℝ,
+      r ∈ Set.Ioo (0 : ℝ) 1 ∧
+        innerBigonCollar h r ⊆ U ∧
+          Set.MapsTo (innerBigonMap h r) (frontier (bigon h)) (U ∩ interior (bigon h)) := by
+  let bad : Set (ℝ × ℝ) := bigon h \ U
+  have hbad : IsCompact bad := (isCompact_bigon hh).inter_right hU.isClosed_compl
+  have hbadInterior : bad ⊆ interior (bigon h) := by
+    intro p hp
+    by_contra hi
+    apply hp.2
+    apply hfrontU
+    rw [frontier, (isClosed_bigon h).closure_eq]
+    exact ⟨hp.1, hi⟩
+  have hnearInv : ∀ᶠ r in 𝓝 (1 : ℝ), ∀ p ∈ bad, inverseInnerBigonMap h r p ∈ interior (bigon h) :=
+    by
+    apply hbad.eventually_forall_of_forall_eventually
+    intro p hp
+    apply (continuousAt_inverseInnerBigonMap h p).preimage_mem_nhds
+    apply isOpen_interior.mem_nhds
+    simpa only [inverseInnerBigonMap_one] using hbadInterior hp
+  have hcompact : IsCompact (frontier (bigon h)) :=
+    (isCompact_bigon hh).of_isClosed_subset isClosed_frontier
+      (fun p hp => ((mem_frontier_bigon_iff h p).mp hp).1)
+  have hnearFront : ∀ᶠ r in 𝓝 (1 : ℝ), ∀ p ∈ frontier (bigon h), innerBigonMap h r p ∈ U := by
+    apply hcompact.eventually_forall_of_forall_eventually
+    intro p hp
+    apply ((contDiff_innerBigonMap h).continuous.continuousAt (x := (1, p))).preimage_mem_nhds
+    apply hU.mem_nhds
+    simpa only [innerBigonMap_one] using hfrontU hp
+  obtain ⟨ε, hε, hball⟩ := Metric.mem_nhds_iff.mp (hnearInv.and hnearFront)
+  let δ : ℝ := Min.min ε 1 / 2
+  have hδpos : 0 < δ := half_pos (lt_min hε zero_lt_one)
+  have hδε : δ < ε := by
+    dsimp [δ]
+    have hm := min_le_left ε 1
+    linarith
+  have hδ1 : δ < 1 := by
+    dsimp [δ]
+    have hm := min_le_right ε 1
+    linarith
+  have hr : 1 - δ ∈ Set.Ioo (0 : ℝ) 1 := ⟨by linarith, by linarith⟩
+  have hrball : 1 - δ ∈ Metric.ball (1 : ℝ) ε := by
+    rw [Metric.mem_ball, Real.dist_eq]
+    have heq : 1 - δ - 1 = -δ := by ring
+    rw [heq, abs_neg, abs_of_pos hδpos]
+    exact hδε
+  have hretained := hball hrball
+  refine ⟨1 - δ, hr, ?_, fun p hp => ⟨hretained.2 p hp, ?_⟩⟩
+  · intro p hp
+    by_contra hpU
+    exact
+      hp.2
+        ⟨inverseInnerBigonMap h (1 - δ) p, hretained.1 p ⟨hp.1, hpU⟩,
+          inner_inverseInnerBigonMap h (1 - δ) hr.1.ne' p⟩
+  · exact innerBigonMap_mem_interior hh hr ((mem_frontier_bigon_iff h p).mp hp).1
+
+private theorem Smale.CleanBigonBoundary.exists_inner_clean_neighborhood {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k l : (ℝ × ℝ) → M} {h : ℝ}
+    (d : Smale.CleanBigonBoundary (E := E) S T a b k l h) :
+    ∃ r : ℝ,
+      r ∈ Set.Ioo (0 : ℝ) 1 ∧
+        Smale.WhitneyPairModel.innerBigonCollar h r ⊆ d.domain ∧
+          ∃ V : Set (ℝ × ℝ),
+            IsOpen V ∧
+              frontier (Smale.WhitneyPairModel.bigon h) ⊆ V ∧
+                ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞
+                    (d.map ∘ Smale.WhitneyPairModel.innerBigonMap h r) V ∧
+                  Set.InjOn (d.map ∘ Smale.WhitneyPairModel.innerBigonMap h r) V ∧
+                    (∀ p ∈ V,
+                        Function.Injective
+                          (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E)
+                            (d.map ∘ Smale.WhitneyPairModel.innerBigonMap h r) p)) ∧
+                      Set.MapsTo (Smale.WhitneyPairModel.innerBigonMap h r) V
+                          (d.domain ∩ interior (Smale.WhitneyPairModel.bigon h)) ∧
+                        ∀ p ∈ V, d.map (Smale.WhitneyPairModel.innerBigonMap h r p) ∉ S ∪ T := by
+  have hfrontD : frontier (Smale.WhitneyPairModel.bigon h) ⊆ d.domain :=
+    d.boundary_covered.trans (interior_subset.trans d.neighborhood_subset)
+  obtain ⟨r, hr, hcollar, hfront⟩ :=
+    Smale.WhitneyPairModel.exists_inner_bigon_collar_in_open d.height_pos d.open_domain hfrontD
+  let c := Smale.WhitneyPairModel.innerBigonDiffeomorph h r hr.1.ne'
+  let V : Set (ℝ × ℝ) :=
+    Smale.WhitneyPairModel.innerBigonMap h r ⁻¹'
+      (d.domain ∩ interior (Smale.WhitneyPairModel.bigon h))
+  have hc : ContMDiff 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, ℝ × ℝ) ∞ (Smale.WhitneyPairModel.innerBigonMap h r) :=
+    c.contMDiff
+  have hV : IsOpen V := (d.open_domain.inter isOpen_interior).preimage hc.continuous
+  have hsmooth :
+    ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ (d.map ∘ Smale.WhitneyPairModel.innerBigonMap h r) V :=
+    d.smooth.comp hc.contMDiffOn (fun _ hp => hp.1)
+  have hinj : Set.InjOn (d.map ∘ Smale.WhitneyPairModel.innerBigonMap h r) V := by
+    intro p hp q hq hpq
+    exact c.injective (d.injective hp.1 hq.1 hpq)
+  refine ⟨r, hr, hcollar, V, hV, hfront, hsmooth, hinj, ?_, fun _ hp => hp, ?_⟩
+  · intro p hp
+    have hdf := (d.smooth.contMDiffAt (d.open_domain.mem_nhds hp.1)).mdifferentiableAt (by simp)
+    rw [mfderiv_comp p hdf (hc.mdifferentiableAt (by simp))]
+    exact
+      (d.derivative_injective _ hp.1).comp
+        (Smale.WhitneyPairModel.bijective_mfderiv_innerBigonMap h r hr.1.ne' p).injective
+  · intro p hp
+    exact d.interior_avoids _ hp
+
+private theorem Smale.CleanBigonBoundary.exists_smooth_inner_extension_in_open {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {S T : Set M} {a b : ℝ → M} {k l : (ℝ × ℝ) → M} {h : ℝ}
+    (d : Smale.CleanBigonBoundary (E := E) S T a b k l h) (U : TopologicalSpace.Opens M)
+    (hU : (S ∪ T)ᶜ ⊆ U)
+    (hnull : ∀ f : C(Smale.Hemisphere.Sphere 1, U), ∃ c, f.Homotopic (ContinuousMap.const _ c)) :
+    ∃ r : ℝ,
+      r ∈ Set.Ioo (0 : ℝ) 1 ∧
+        Smale.WhitneyPairModel.innerBigonCollar h r ⊆ d.domain ∧
+          ∃ F : C(ℝ × ℝ, U),
+            ContMDiff 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ F ∧
+              ∃ W : Set (ℝ × ℝ),
+                IsOpen W ∧
+                  frontier (Smale.WhitneyPairModel.bigon h) ⊆ W ∧
+                    Set.EqOn (Subtype.val ∘ F) (d.map ∘ Smale.WhitneyPairModel.innerBigonMap h r)
+                        W ∧
+                      Set.InjOn F W ∧
+                        (∀ p ∈ W, Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) F p)) ∧
+                          ∀ p ∈ W, (F p : M) ∉ S ∪ T := by
+  classical
+  obtain ⟨r, hr, hcollar, V, hV, hfrontV, hsmooth, hinj, hderiv, -, havoid⟩ :=
+    d.exists_inner_clean_neighborhood
+  have hzero : (0 : ℝ × ℝ) ∈ frontier (Smale.WhitneyPairModel.bigon h) := by
+    rw [Smale.WhitneyPairModel.mem_frontier_bigon_iff]
+    refine ⟨?_, Or.inl rfl⟩
+    change 0 ≤ (0 : ℝ) ∧ h * 0 ^ 2 + 0 ≤ h
+    simpa only [zero_pow (by decide : 2 ≠ 0), MulZeroClass.mul_zero, add_zero] using
+      And.intro le_rfl d.height_pos.le
+  let c : U := ⟨d.map (Smale.WhitneyPairModel.innerBigonMap h r 0), hU (havoid 0 (hfrontV hzero))⟩
+  let f : (ℝ × ℝ) → U := fun p =>
+    if hp : p ∈ V then ⟨d.map (Smale.WhitneyPairModel.innerBigonMap h r p), hU (havoid p hp)⟩
+    else c
+  have hval (p : ℝ × ℝ) (hp : p ∈ V) :
+    (f p : M) = d.map (Smale.WhitneyPairModel.innerBigonMap h r p) := by
+    dsimp [f]
+    rw [dite_eq_left hp]
+  have hfval : ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ (Subtype.val ∘ f) V :=
+    hsmooth.congr (fun p hp => hval p hp)
+  have hf : ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ f V := by
+    intro p hp
+    exact (ContMDiffWithinAt.subtypeVal_comp_iff U f V p).mp (hfval p hp)
+  obtain ⟨F, hF, W, hW, hfrontW, hWV, hEq⟩ :=
+    Smale.exists_smooth_bigon_neighborhood_extension_of_circle_nullhomotopies hnull d.height_pos
+      hV hf hfrontV
+  have hEqval : Set.EqOn (Subtype.val ∘ F) (d.map ∘ Smale.WhitneyPairModel.innerBigonMap h r) W :=
+    by
+    intro p hp
+    exact (congrArg Subtype.val (hEq hp)).trans (hval p (hWV hp))
+  have hinjF : Set.InjOn F W := by
+    intro p hp q hq hpq
+    apply hinj (hWV hp) (hWV hq)
+    exact (hEqval hp).symm.trans ((congrArg Subtype.val hpq).trans (hEqval hq))
+  refine ⟨r, hr, hcollar, F, hF, W, hW, hfrontW, hEqval, hinjF, ?_, ?_⟩
+  · intro p hp
+    have heq : (Subtype.val ∘ F) =ᶠ[𝓝 p] (d.map ∘ Smale.WhitneyPairModel.innerBigonMap h r) :=
+      Filter.mem_of_superset (hW.mem_nhds hp) (fun _ hq => hEqval hq)
+    have hi : Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) (Subtype.val ∘ F) p) := by
+      rw [heq.mfderiv_eq]
+      exact hderiv p (hWV hp)
+    have hc : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, E) ∞ (Subtype.val : U → M) := contMDiff_subtype_val
+    rw [mfderiv_comp p (hc.mdifferentiableAt (by simp)) (hF.mdifferentiableAt (by simp))] at hi
+    intro v w hvw
+    apply hi
+    exact congrArg (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, E) (Subtype.val : U → M) (F p)) hvw
+  · intro p hp
+    change (Subtype.val ∘ F) p ∉ S ∪ T
+    rw [hEqval hp]
+    exact havoid p (hWV hp)
+
+private theorem Smale.CleanBigonBoundary.exists_embedded_inner_extension_in_open {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [FiniteDimensional ℝ E] [T2Space M] {D Y : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D] [TopologicalSpace Y]
+    [ChartedSpace D Y] [IsManifold 𝓘(ℝ, D) ∞ Y] [CompactSpace Y] (g : C(Y, M))
+    (hg : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ g) {T : Set M} {a b : ℝ → M} {k l : (ℝ × ℝ) → M} {h : ℝ}
+    (d : Smale.CleanBigonBoundary (E := E) (Set.range g) T a b k l h)
+    (U : TopologicalSpace.Opens M) (hU : (Set.range g ∪ T)ᶜ ⊆ U)
+    (hnull : ∀ f : C(Smale.Hemisphere.Sphere 1, U), ∃ c, f.Homotopic (ContinuousMap.const _ c))
+    (hdim : 5 ≤ Module.finrank ℝ E) (hobstacle : 2 + Module.finrank ℝ D < Module.finrank ℝ E) :
+    ∃ r : ℝ,
+      r ∈ Set.Ioo (0 : ℝ) 1 ∧
+        Smale.WhitneyPairModel.innerBigonCollar h r ⊆ d.domain ∧
+          ∃ F : C(ℝ × ℝ, U),
+            ContMDiff 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ F ∧
+              Topology.IsClosedEmbedding (fun p : Smale.WhitneyPairModel.bigon h => F p) ∧
+                (∀ p ∈ Smale.WhitneyPairModel.bigon h,
+                    Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) F p)) ∧
+                  (∀ p ∈ Smale.WhitneyPairModel.bigon h, (F p : M) ∉ Set.range g) ∧
+                    ∃ W : Set (ℝ × ℝ),
+                      IsOpen W ∧
+                        frontier (Smale.WhitneyPairModel.bigon h) ⊆ W ∧
+                          Set.EqOn (Subtype.val ∘ F)
+                            (d.map ∘ Smale.WhitneyPairModel.innerBigonMap h r) W := by
+  obtain ⟨r, hr, hcollar, F, hF, V, hV, hfrontV, hEq, hinj, hderiv, havoid⟩ :=
+    d.exists_smooth_inner_extension_in_open U hU hnull
+  have hcompact : IsCompact (frontier (Smale.WhitneyPairModel.bigon h)) :=
+    (Smale.WhitneyPairModel.isCompact_bigon d.height_pos).of_isClosed_subset isClosed_frontier
+      (fun p hp => ((Smale.WhitneyPairModel.mem_frontier_bigon_iff h p).mp hp).1)
+  obtain ⟨C, -, hC, hfrontC, hCV⟩ := exists_compact_closed_between hcompact hV hfrontV
+  have hinjC : Set.InjOn F (Smale.WhitneyPairModel.bigon h ∩ C) :=
+    hinj.mono (Set.inter_subset_right.trans hCV)
+  have hiC :
+    ∀ p ∈ Smale.WhitneyPairModel.bigon h ∩ C,
+      Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) F p) :=
+    fun p hp => hderiv p (hCV hp.2)
+  have hclean :
+    ∀ p ∈ Smale.WhitneyPairModel.bigon h ∩ C, p ∉ (∅ : Set (ℝ × ℝ)) → (F p : M) ∉ Set.range g := by
+    intro p hp _ hmem
+    exact havoid p (hCV hp.2) (Or.inl hmem)
+  obtain ⟨G, hG, hhom, hemb, hiG, havoidG⟩ :=
+    Smale.ManifoldImmersion.exists_relative_embedded_avoidance_in_open U F g hF hg
+      (by simp [Module.finrank_prod]) hdim (by simpa [Module.finrank_prod] using hobstacle)
+      (Smale.WhitneyPairModel.isCompact_bigon d.height_pos) hC (Set.empty_subset _) hinjC hiC
+      hclean
+  refine ⟨r, hr, hcollar, G, hG, hemb, hiG, ?_, interior C, isOpen_interior, hfrontC, ?_⟩
+  · intro p hp
+    exact havoidG p ⟨hp, Set.notMem_empty p⟩
+  · intro p hp
+    have hpC : p ∈ C := interior_subset hp
+    exact (congrArg Subtype.val (hhom.fst_eq_snd hpC)).symm.trans (hEq (hCV hpC))
+
+private theorem
+    Smale.CleanBigonBoundary.exists_collar_disjoint_inner_extension_in_open {E M D Y : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [FiniteDimensional ℝ D] [TopologicalSpace Y] [ChartedSpace D Y]
+    [IsManifold 𝓘(ℝ, D) ∞ Y] [CompactSpace Y] (g : C(Y, M)) (hg : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ g)
+    {T : Set M} {a b : ℝ → M} {k l : (ℝ × ℝ) → M} {h : ℝ}
+    (d : Smale.CleanBigonBoundary (E := E) (Set.range g) T a b k l h)
+    (U : TopologicalSpace.Opens M) (hU : (Set.range g ∪ T)ᶜ ⊆ U)
+    (hnull : ∀ f : C(Smale.Hemisphere.Sphere 1, U), ∃ c, f.Homotopic (ContinuousMap.const _ c))
+    (hdim : 5 ≤ Module.finrank ℝ E) (hobstacle : 2 + Module.finrank ℝ D < Module.finrank ℝ E) :
+    ∃ r : ℝ,
+      r ∈ Set.Ioo (0 : ℝ) 1 ∧
+        Smale.WhitneyPairModel.innerBigonCollar h r ⊆ d.domain ∧
+          ∃ F : C(ℝ × ℝ, U),
+            ContMDiff 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ F ∧
+              Topology.IsClosedEmbedding (fun p : Smale.WhitneyPairModel.bigon h => F p) ∧
+                (∀ p ∈ Smale.WhitneyPairModel.bigon h,
+                    Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) F p)) ∧
+                  (∀ p ∈ Smale.WhitneyPairModel.bigon h, (F p : M) ∉ Set.range g) ∧
+                    (∀ p ∈ interior (Smale.WhitneyPairModel.bigon h),
+                        (F p : M) ∉ d.map '' Smale.WhitneyPairModel.innerBigonCollar h r) ∧
+                      ∃ W : Set (ℝ × ℝ),
+                        IsOpen W ∧
+                          frontier (Smale.WhitneyPairModel.bigon h) ⊆ W ∧
+                            Set.EqOn (Subtype.val ∘ F)
+                              (d.map ∘ Smale.WhitneyPairModel.innerBigonMap h r) W := by
+  obtain ⟨r, hr, hcollar, F, hF, hemb, hi, havoid, V, hV, hfrontV, hEq⟩ :=
+    d.exists_embedded_inner_extension_in_open g hg U hU hnull hdim hobstacle
+  let Q : TopologicalSpace.Opens (ℝ × ℝ) := ⟨d.domain, d.open_domain⟩
+  let q : C(Q, M) :=
+    ⟨fun p => d.map p, continuousOn_iff_continuous_domRestrict.mp d.smooth.continuousOn⟩
+  have hq : ContMDiff 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ q := by
+    intro p
+    apply contMDiffAt_subtype_iff.mpr
+    exact d.smooth.contMDiffAt (d.open_domain.mem_nhds p.property)
+  let A : Set Q := Subtype.val ⁻¹' Smale.WhitneyPairModel.innerBigonCollar h r
+  have himage : q '' A = d.map '' Smale.WhitneyPairModel.innerBigonCollar h r := by
+    ext z
+    constructor
+    · rintro ⟨p, hp, rfl⟩
+      exact ⟨p, hp, rfl⟩
+    · rintro ⟨p, hp, rfl⟩
+      exact ⟨⟨p, hcollar hp⟩, hp, rfl⟩
+  have hclosed : IsClosed (q '' A) := by
+    rw [himage]
+    exact
+      ((Smale.WhitneyPairModel.isCompact_innerBigonCollar d.height_pos
+              hr.1.ne').image_of_continuousOn
+          (d.smooth.continuousOn.mono hcollar)).isClosed
+  have hs : ContMDiff 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, ℝ × ℝ) ∞ (Smale.WhitneyPairModel.innerBigonMap h r) :=
+    (Smale.WhitneyPairModel.innerBigonDiffeomorph h r hr.1.ne').contMDiff
+  let V' : Set (ℝ × ℝ) := V ∩ Smale.WhitneyPairModel.innerBigonMap h r ⁻¹' d.domain
+  have hV' : IsOpen V' := hV.inter (d.open_domain.preimage hs.continuous)
+  have hfrontV' : frontier (Smale.WhitneyPairModel.bigon h) ⊆ V' := by
+    intro p hp
+    refine ⟨hfrontV hp, hcollar ?_⟩
+    exact
+      (Smale.WhitneyPairModel.innerBigonMap_mem_collar_iff d.height_pos hr
+            ((Smale.WhitneyPairModel.mem_frontier_bigon_iff h p).mp hp).1).mpr
+        hp
+  have hfrontCompact : IsCompact (frontier (Smale.WhitneyPairModel.bigon h)) :=
+    (Smale.WhitneyPairModel.isCompact_bigon d.height_pos).of_isClosed_subset isClosed_frontier
+      (fun p hp => ((Smale.WhitneyPairModel.mem_frontier_bigon_iff h p).mp hp).1)
+  obtain ⟨C, -, hC, hfrontC, hCV⟩ := exists_compact_closed_between hfrontCompact hV' hfrontV'
+  have hinj : Set.InjOn F (Smale.WhitneyPairModel.bigon h) := by
+    intro p hp z hz heq
+    exact congrArg Subtype.val (hemb.injective (a₁ := ⟨p, hp⟩) (a₂ := ⟨z, hz⟩) heq)
+  have hclean :
+    ∀ p ∈ Smale.WhitneyPairModel.bigon h ∩ C,
+      p ∉ frontier (Smale.WhitneyPairModel.bigon h) → (F p : M) ∉ q '' A := by
+    intro p hp hpB hmem
+    rw [himage] at hmem
+    obtain ⟨z, hz, heq⟩ := hmem
+    have hzp : z = Smale.WhitneyPairModel.innerBigonMap h r p :=
+      d.injective (hcollar hz) (hCV hp.2).2 (heq.trans (hEq (hCV hp.2).1))
+    exact
+      hpB
+        ((Smale.WhitneyPairModel.innerBigonMap_mem_collar_iff d.height_pos hr hp.1).mp (hzp ▸ hz))
+  let O : Set U := (Subtype.val : U → M) ⁻¹' (Set.range g)ᶜ
+  have hO : IsOpen O :=
+    (isCompact_range g.continuous).isClosed.isOpen_compl.preimage continuous_subtype_val
+  have hmaps : Set.MapsTo F (Smale.WhitneyPairModel.bigon h) O := fun p hp => havoid p hp
+  have hdim' : 2 * Module.finrank ℝ (ℝ × ℝ) < Module.finrank ℝ E := by
+    simp only [Module.finrank_prod, Module.finrank_self]
+    omega
+  have hobstacle' : Module.finrank ℝ (ℝ × ℝ) + Module.finrank ℝ (ℝ × ℝ) < Module.finrank ℝ E := by
+    simp only [Module.finrank_prod, Module.finrank_self]
+    omega
+  obtain ⟨G, hG, hhom, hembG, hiG, hmapsG, havoidG⟩ :=
+    Smale.ManifoldImmersion.exists_embedded_image_avoidance_relative_neighborhood_in_open U F q A
+      hF hq hclosed hdim' hobstacle' (Smale.WhitneyPairModel.isCompact_bigon d.height_pos) hC
+      hfrontC hinj hi hclean hO hmaps
+  refine ⟨r, hr, hcollar, G, hG, hembG, hiG, hmapsG, ?_, interior C, isOpen_interior, hfrontC, ?_⟩
+  · intro p hp hmem
+    have hpB : p ∉ frontier (Smale.WhitneyPairModel.bigon h) := by
+      intro hfront
+      rw [frontier] at hfront
+      exact hfront.2 hp
+    exact havoidG p ⟨interior_subset hp, hpB⟩ (by rwa [himage])
+  · intro p hp
+    have hpC : p ∈ C := interior_subset hp
+    exact (congrArg Subtype.val (hhom.fst_eq_snd hpC)).symm.trans (hEq (hCV hpC).1)
+
+private theorem Smale.exists_filled_clean_bigon_of_collar_disjoint_inner {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {S T : Set M} {a b : ℝ → M} {k l : (ℝ × ℝ) → M} {h : ℝ}
+    (d : CleanBigonBoundary (E := E) S T a b k l h) {r : ℝ} (hr : r ∈ Set.Ioo (0 : ℝ) 1)
+    (hcollar : WhitneyPairModel.innerBigonCollar h r ⊆ d.domain) (F : C(ℝ × ℝ, M))
+    (hF : ContMDiff 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ F) (hinjF : Set.InjOn F (WhitneyPairModel.bigon h))
+    (hiF : ∀ p ∈ WhitneyPairModel.bigon h, Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) F p))
+    (havoidF : ∀ p ∈ WhitneyPairModel.bigon h, F p ∉ S ∪ T)
+    (hcollarF :
+      ∀ p ∈ interior (WhitneyPairModel.bigon h),
+        F p ∉ d.map '' WhitneyPairModel.innerBigonCollar h r)
+    {W : Set (ℝ × ℝ)} (hW : IsOpen W) (hfrontW : frontier (WhitneyPairModel.bigon h) ⊆ W)
+    (hEq : Set.EqOn F (d.map ∘ WhitneyPairModel.innerBigonMap h r) W) :
+    ∃ f : C(ℝ × ℝ, M),
+      ContMDiff 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ f ∧
+        Topology.IsClosedEmbedding (fun p : WhitneyPairModel.bigon h => f p) ∧
+          (∀ p ∈ WhitneyPairModel.bigon h, Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) f p)) ∧
+            (∀ p ∈ interior (WhitneyPairModel.bigon h), f p ∉ S ∪ T) ∧
+              ∃ V : Set (ℝ × ℝ),
+                IsOpen V ∧ frontier (WhitneyPairModel.bigon h) ⊆ V ∧ Set.EqOn f d.map V := by
+  let c := WhitneyPairModel.innerBigonDiffeomorph h r hr.1.ne'
+  let core : Set (ℝ × ℝ) := c '' WhitneyPairModel.bigon h
+  let P : Set (ℝ × ℝ) := c '' (interior (WhitneyPairModel.bigon h) ∪ W)
+  let Q : Set (ℝ × ℝ) := d.domain \ c '' (WhitneyPairModel.bigon h \ W)
+  let G : (ℝ × ℝ) → M := F ∘ c.symm
+  have hG : ContMDiff 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ G := hF.comp c.symm.contMDiff
+  have hP : IsOpen P := c.toHomeomorph.isOpenMap _ (isOpen_interior.union hW)
+  have hQ : IsOpen Q :=
+    d.open_domain.inter
+      (((WhitneyPairModel.isCompact_bigon d.height_pos).inter_right hW.isClosed_compl).image
+          c.continuous).isClosed.isOpen_compl
+  have hfront (p : ℝ × ℝ) (hp : p ∈ WhitneyPairModel.bigon h)
+    (hi : p ∉ interior (WhitneyPairModel.bigon h)) : p ∈ frontier (WhitneyPairModel.bigon h) := by
+    rw [frontier, (WhitneyPairModel.isClosed_bigon h).closure_eq]
+    exact ⟨hp, hi⟩
+  have hcoreP : core ⊆ P := by
+    rintro _ ⟨p, hp, rfl⟩
+    refine ⟨p, ?_, rfl⟩
+    by_cases hi : p ∈ interior (WhitneyPairModel.bigon h)
+    · exact Or.inl hi
+    · exact Or.inr (hfrontW (hfront p hp hi))
+  have hcollarQ : WhitneyPairModel.innerBigonCollar h r ⊆ Q := by
+    intro p hp
+    refine ⟨hcollar hp, ?_⟩
+    rintro ⟨z, hz, rfl⟩
+    exact
+      hz.2 (hfrontW ((WhitneyPairModel.innerBigonMap_mem_collar_iff d.height_pos hr hz.1).mp hp))
+  have hnotCore (p : ℝ × ℝ) (hp : p ∈ WhitneyPairModel.bigon h) (hn : p ∉ core) :
+    p ∈ WhitneyPairModel.innerBigonCollar h r :=
+    ⟨hp, fun hi => hn (Set.image_mono interior_subset hi)⟩
+  have hcover : WhitneyPairModel.bigon h ⊆ P ∪ Q := by
+    intro p hp
+    by_cases hc : p ∈ core
+    · exact Or.inl (hcoreP hc)
+    · exact Or.inr (hcollarQ (hnotCore p hp hc))
+  have hfrontQ : frontier (WhitneyPairModel.bigon h) ⊆ Q := by
+    intro p hp
+    apply hcollarQ
+    refine ⟨((WhitneyPairModel.mem_frontier_bigon_iff h p).mp hp).1, ?_⟩
+    rintro ⟨z, hz, heq⟩
+    have hi : p ∈ interior (WhitneyPairModel.bigon h) :=
+      heq ▸ WhitneyPairModel.innerBigonMap_mem_interior d.height_pos hr (interior_subset hz)
+    rw [frontier] at hp
+    exact hp.2 hi
+  have hmatch : Set.EqOn G d.map (P ∩ Q) := by
+    rintro p ⟨hp, hq⟩
+    obtain ⟨z, hz, rfl⟩ := hp
+    have hzW : z ∈ W := by
+      rcases hz with hz | hz
+      · by_contra hn
+        exact hq.2 ⟨z, ⟨interior_subset hz, hn⟩, rfl⟩
+      · exact hz
+    change F (c.symm (c z)) = d.map (c z)
+    rw [c.symm_apply_apply]
+    exact hEq hzW
+  obtain ⟨j, hj, hjG, hjd⟩ :=
+    exists_smooth_open_gluing hP hQ hG.contMDiffOn (d.smooth.mono Set.inter_subset_left) hmatch
+  have hjInner (p : ℝ × ℝ) (hp : p ∈ WhitneyPairModel.bigon h) : j (c p) = F p :=
+    (hjG (hcoreP ⟨p, hp, rfl⟩)).trans (congrArg F (c.symm_apply_apply p))
+  have hjCollar (p : ℝ × ℝ) (hp : p ∈ WhitneyPairModel.innerBigonCollar h r) : j p = d.map p :=
+    hjd (hcollarQ hp)
+  have hcross (p : ℝ × ℝ) (hp : p ∈ WhitneyPairModel.bigon h) (z : ℝ × ℝ)
+    (hz : z ∈ WhitneyPairModel.innerBigonCollar h r) (heq : F p = d.map z) : c p = z := by
+    by_cases hi : p ∈ interior (WhitneyPairModel.bigon h)
+    · exact False.elim (hcollarF p hi ⟨z, hz, heq.symm⟩)
+    · have hpf := hfront p hp hi
+      apply
+        d.injective
+          (hcollar ((WhitneyPairModel.innerBigonMap_mem_collar_iff d.height_pos hr hp).mpr hpf))
+          (hcollar hz)
+      exact (hEq (hfrontW hpf)).symm.trans heq
+  have hinj : Set.InjOn j (WhitneyPairModel.bigon h) := by
+    intro p hp z hz heq
+    by_cases hpCore : p ∈ core
+    · obtain ⟨p', hp', rfl⟩ := hpCore
+      rw [hjInner p' hp'] at heq
+      by_cases hzCore : z ∈ core
+      · obtain ⟨z', hz', rfl⟩ := hzCore
+        rw [hjInner z' hz'] at heq
+        exact congrArg c (hinjF hp' hz' heq)
+      · have hzC := hnotCore z hz hzCore
+        rw [hjCollar z hzC] at heq
+        exact hcross p' hp' z hzC heq
+    · have hpC := hnotCore p hp hpCore
+      rw [hjCollar p hpC] at heq
+      by_cases hzCore : z ∈ core
+      · obtain ⟨z', hz', rfl⟩ := hzCore
+        rw [hjInner z' hz'] at heq
+        exact (hcross z' hz' p hpC heq.symm).symm
+      · have hzC := hnotCore z hz hzCore
+        rw [hjCollar z hzC] at heq
+        exact d.injective (hcollar hpC) (hcollar hzC) heq
+  have hi :
+    ∀ p ∈ WhitneyPairModel.bigon h, Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) j p) := by
+    intro p hp
+    by_cases hpCore : p ∈ core
+    · have heq : j =ᶠ[𝓝 p] G :=
+        Filter.mem_of_superset (hP.mem_nhds (hcoreP hpCore)) (fun _ hx => hjG hx)
+      rw [heq.mfderiv_eq]
+      change Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) (F ∘ c.symm) p)
+      rw [mfderiv_comp p (hF.mdifferentiableAt (by simp))
+          (c.symm.contMDiff.mdifferentiableAt (by simp))]
+      have hpin : c.symm p ∈ WhitneyPairModel.bigon h := by
+        obtain ⟨z, hz, rfl⟩ := hpCore
+        rwa [c.symm_apply_apply]
+      exact
+        (hiF _ hpin).comp
+          (PartialChart.bijective_mfderiv c.symm.toPartialDiffeomorph (Set.mem_univ p)).injective
+    · have hpC := hnotCore p hp hpCore
+      have heq : j =ᶠ[𝓝 p] d.map :=
+        Filter.mem_of_superset (hQ.mem_nhds (hcollarQ hpC)) (fun _ hx => hjd hx)
+      rw [heq.mfderiv_eq]
+      exact d.derivative_injective p (hcollar hpC)
+  have havoid : ∀ p ∈ interior (WhitneyPairModel.bigon h), j p ∉ S ∪ T := by
+    intro p hp
+    by_cases hpCore : p ∈ core
+    · obtain ⟨z, hz, rfl⟩ := hpCore
+      rw [hjInner z hz]
+      exact havoidF z hz
+    · have hpC := hnotCore p (interior_subset hp) hpCore
+      rw [hjCollar p hpC]
+      exact d.interior_avoids p ⟨hcollar hpC, hp⟩
+  obtain ⟨f, hf, V, hV, hKV, -, hfj⟩ :=
+    exists_smooth_extension_near_starConvex (WhitneyPairModel.isCompact_bigon d.height_pos)
+      (WhitneyPairModel.zero_mem_bigon d.height_pos.le)
+      (WhitneyPairModel.starConvex_bigon d.height_pos.le) (hP.union hQ) hcover hj
+  have hinjf : Set.InjOn f (WhitneyPairModel.bigon h) := by
+    intro p hp z hz heq
+    apply hinj hp hz
+    exact (hfj (hKV hp)).symm.trans (heq.trans (hfj (hKV hz)))
+  have hembf : Topology.IsClosedEmbedding (fun p : WhitneyPairModel.bigon h => f p) := by
+    let : CompactSpace (WhitneyPairModel.bigon h) :=
+      isCompact_iff_compactSpace.mp (WhitneyPairModel.isCompact_bigon d.height_pos)
+    apply (hf.continuous.comp continuous_subtype_val).isClosedEmbedding
+    intro p z heq
+    exact Subtype.ext (hinjf p.property z.property heq)
+  refine ⟨⟨f, hf.continuous⟩, hf, hembf, ?_, ?_, V ∩ Q, hV.inter hQ, ?_, ?_⟩
+  · intro p hp
+    have heq : f =ᶠ[𝓝 p] j := Filter.mem_of_superset (hV.mem_nhds (hKV hp)) (fun _ hx => hfj hx)
+    change Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) f p)
+    rw [heq.mfderiv_eq]
+    exact hi p hp
+  · intro p hp
+    change f p ∉ S ∪ T
+    rw [hfj (hKV (interior_subset hp))]
+    exact havoid p hp
+  · intro p hp
+    exact ⟨hKV ((WhitneyPairModel.mem_frontier_bigon_iff h p).mp hp).1, hfrontQ hp⟩
+  · intro p hp
+    exact (hfj hp.1).trans (hjd hp.2)
+
+private theorem
+    Smale.CleanBigonBoundary.exists_filled_bigon_of_complement_contractions {E M D Y : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [FiniteDimensional ℝ D] [TopologicalSpace Y] [ChartedSpace D Y]
+    [IsManifold 𝓘(ℝ, D) ∞ Y] [CompactSpace Y] (g : C(Y, M)) (hg : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ g)
+    {T : Set M} {a b : ℝ → M} {k l : (ℝ × ℝ) → M} {h : ℝ}
+    (d : Smale.CleanBigonBoundary (E := E) (Set.range g) T a b k l h) (hT : IsClosed T)
+    (hnull :
+      ∀ f : C(Smale.Hemisphere.Sphere 1, (⟨Tᶜ, hT.isOpen_compl⟩ : TopologicalSpace.Opens M)),
+        ∃ c, f.Homotopic (ContinuousMap.const _ c))
+    (hdim : 5 ≤ Module.finrank ℝ E) (hobstacle : 2 + Module.finrank ℝ D < Module.finrank ℝ E) :
+    ∃ f : C(ℝ × ℝ, M),
+      ContMDiff 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ f ∧
+        Topology.IsClosedEmbedding (fun p : Smale.WhitneyPairModel.bigon h => f p) ∧
+          (∀ p ∈ Smale.WhitneyPairModel.bigon h,
+              Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) f p)) ∧
+            (∀ p ∈ interior (Smale.WhitneyPairModel.bigon h), f p ∉ Set.range g ∪ T) ∧
+              ∃ V : Set (ℝ × ℝ),
+                IsOpen V ∧ frontier (Smale.WhitneyPairModel.bigon h) ⊆ V ∧ Set.EqOn f d.map V := by
+  let U : TopologicalSpace.Opens M := ⟨Tᶜ, hT.isOpen_compl⟩
+  have hU : (Set.range g ∪ T)ᶜ ⊆ U := fun _ hp ht => hp (Or.inr ht)
+  obtain ⟨r, hr, hcollar, F, hF, hemb, hi, havoid, havoidCollar, W, hW, hfrontW, hEq⟩ :=
+    d.exists_collar_disjoint_inner_extension_in_open g hg U hU hnull hdim hobstacle
+  let F' : C(ℝ × ℝ, M) := ⟨Subtype.val ∘ F, continuous_subtype_val.comp F.continuous⟩
+  have hv : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, E) ∞ (Subtype.val : U → M) := contMDiff_subtype_val
+  have hF' : ContMDiff 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ F' := hv.comp hF
+  have hinjF' : Set.InjOn F' (Smale.WhitneyPairModel.bigon h) := by
+    intro p hp z hz heq
+    have hFval : F p = F z := Subtype.ext heq
+    exact congrArg Subtype.val (hemb.injective (a₁ := ⟨p, hp⟩) (a₂ := ⟨z, hz⟩) hFval)
+  have hiF' :
+    ∀ p ∈ Smale.WhitneyPairModel.bigon h, Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) F' p) :=
+    by
+    intro p hp
+    change Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) (Subtype.val ∘ F) p)
+    rw [mfderiv_comp p (hv.mdifferentiableAt (by simp)) (hF.mdifferentiableAt (by simp))]
+    exact (Smale.NativeOpenSubmanifold.injective_mfderiv_subtype_val U (F p)).comp (hi p hp)
+  have havoidF' : ∀ p ∈ Smale.WhitneyPairModel.bigon h, F' p ∉ Set.range g ∪ T := by
+    intro p hp hmem
+    rcases hmem with hmem | hmem
+    · exact havoid p hp hmem
+    · exact (F p).property hmem
+  exact
+    Smale.exists_filled_clean_bigon_of_collar_disjoint_inner d hr hcollar F' hF' hinjF' hiF'
+      havoidF' havoidCollar hW hfrontW hEq
+
+private theorem Smale.CleanBigonBoundary.nonempty_tubularBigon_of_complement_contractions
+    {E M D Y : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D] [TopologicalSpace Y]
+    [ChartedSpace D Y] [IsManifold 𝓘(ℝ, D) ∞ Y] [CompactSpace Y] (g : C(Y, M))
+    (hg : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ g) {T : Set M} {a b : ℝ → M} {k l : (ℝ × ℝ) → M} {h : ℝ}
+    (d : Smale.CleanBigonBoundary (E := E) (Set.range g) T a b k l h) (hT : IsClosed T)
+    (hnull :
+      ∀ f : C(Smale.Hemisphere.Sphere 1, (⟨Tᶜ, hT.isOpen_compl⟩ : TopologicalSpace.Opens M)),
+        ∃ c, f.Homotopic (ContinuousMap.const _ c))
+    (hdim : 5 ≤ Module.finrank ℝ E) (hobstacle : 2 + Module.finrank ℝ D < Module.finrank ℝ E)
+    (n : ℕ) (hcodim : 2 + n = Module.finrank ℝ E) :
+    Nonempty (Smale.TubularBigon (E := E) (Set.range g) T a b k l h n) := by
+  obtain ⟨f, hf, hemb, hi, havoid, V, hV, hfrontV, hEq⟩ :=
+    d.exists_filled_bigon_of_complement_contractions g hg hT hnull hdim hobstacle
+  have hinj : Set.InjOn f (Smale.WhitneyPairModel.bigon h) := by
+    intro p hp z hz heq
+    exact congrArg Subtype.val (hemb.injective (a₁ := ⟨p, hp⟩) (a₂ := ⟨z, hz⟩) heq)
+  obtain ⟨ε, hε, Φ, hsource, hzero, -⟩ :=
+    Smale.exists_normed_tubularNeighborhood_in_open_of_embedded_starConvex_with_global_zero hf
+      (Smale.WhitneyPairModel.isCompact_bigon d.height_pos)
+      (Smale.WhitneyPairModel.zero_mem_bigon d.height_pos.le)
+      (Smale.WhitneyPairModel.starConvex_bigon d.height_pos.le) hinj hi n
+      (by simpa only [Module.finrank_prod, Module.finrank_self] using hcodim) isOpen_univ
+      (Set.mapsTo_univ _ _)
+  have hgerm : ∀ p ∈ frontier (Smale.WhitneyPairModel.bigon h), (f : (ℝ × ℝ) → M) =ᶠ[𝓝 p] d.map :=
+    fun _ hp => Filter.mem_of_superset (hV.mem_nhds (hfrontV hp)) (fun _ hx => hEq hx)
+  have hlow :
+    ∀ t ∈ Set.Icc (0 : ℝ) 1, (2 * t - 1, 0) ∈ frontier (Smale.WhitneyPairModel.bigon h) :=
+    fun t ht =>
+    (Smale.WhitneyPairModel.mem_frontier_bigon_iff_exists_time d.height_pos _).mpr
+      ⟨t, ht, Or.inl rfl⟩
+  have hupp :
+    ∀ t ∈ Set.Icc (0 : ℝ) 1,
+      (2 * t - 1, h * (1 - (2 * t - 1) ^ 2)) ∈ frontier (Smale.WhitneyPairModel.bigon h) :=
+    fun t ht =>
+    (Smale.WhitneyPairModel.mem_frontier_bigon_iff_exists_time d.height_pos _).mpr
+      ⟨t, ht, Or.inr rfl⟩
+  exact
+    ⟨{  height_pos := d.height_pos
+        map := f
+        smooth := hf
+        closed_embedding := hemb
+        derivative_injective := hi
+        interior_avoids := havoid
+        lower := fun t ht => (hEq (hfrontV (hlow t ht))).trans (d.lower t ht)
+        upper := fun t ht => (hEq (hfrontV (hupp t ht))).trans (d.upper t ht)
+        lower_germ := fun t ht => (hgerm _ (hlow t ht)).trans (d.lower_germ t ht)
+        upper_germ := fun t ht => (hgerm _ (hupp t ht)).trans (d.upper_germ t ht)
+        radius := ε
+        radius_pos := hε
+        chart := Φ
+        source_contains := hsource
+        zero_section := hzero }⟩
+
+private theorem Smale.ManifoldImmersion.exists_weighted_immersive_patch_with_property
+    {B E G F H H' X N : Type*} [NormedAddCommGroup B] [NormedSpace ℝ B] [FiniteDimensional ℝ B]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F] [FiniteDimensional ℝ F]
+    [TopologicalSpace H] [TopologicalSpace H'] {I : ModelWithCorners ℝ B H}
+    {J : ModelWithCorners ℝ G H'} [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X]
+    [LindelofSpace (X × E)] [TopologicalSpace N] [ChartedSpace H' N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) (f : C(E, N)) (hf : ContMDiff 𝓘(ℝ, E) J ∞ f)
+    {b : X → E} (hb : ContMDiff I 𝓘(ℝ, E) ∞ b) {β χ : E → ℝ} (hβ : ContDiff ℝ ∞ β)
+    (hχ : ContDiff ℝ ∞ χ) (hcompact : HasCompactSupport β)
+    (hsupport : tsupport β ⊆ f ⁻¹' c.source) (hχsupport : tsupport χ ⊆ f ⁻¹' c.source) {S : Set X}
+    (hplateau : ∀ x ∈ S, b x ∈ interior {y | χ y = 1})
+    (hcommon : ∀ x ∈ S, ∀ v, mfderiv 𝓘(ℝ, E) J f (b x) v = 0 → fderiv ℝ β (b x) v = 0 → v = 0)
+    (hdim : Module.finrank ℝ B + Module.finrank ℝ E < Module.finrank ℝ F) (Q : (E → N) → Prop)
+    (hQ : ∀ᶠ a : F in 𝓝 0, Q (Smale.ChartMapPerturbation.perturb c f β a)) :
+    ∃ g : C(E, N),
+      ContMDiff 𝓘(ℝ, E) J ∞ g ∧
+        Q g ∧
+          f.HomotopicRel g {y | β y = 0} ∧
+            ∀ x ∈ S, Function.Injective (mfderiv 𝓘(ℝ, E) J g (b x)) := by
+  let k := Smale.ChartMapPerturbation.cutoffCoordinates c f χ
+  have hk : ContDiff ℝ ∞ k := by
+    have hm : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, F) ∞ k := fun _ =>
+      Smale.ChartMapPerturbation.contMDiffAt_cutoffCoordinates c hχsupport hf.contMDiffAt
+        hχ.contMDiff.contMDiffAt
+    exact hm.contDiff
+  obtain ⟨ε, hε, hvalid⟩ :=
+    Smale.ChartMapPerturbation.exists_radius_valid c hf hβ.contMDiff hcompact hsupport
+  have hQmem : {a : F | Q (Smale.ChartMapPerturbation.perturb c f β a)} ∈ 𝓝 0 := hQ
+  obtain ⟨δ, hδ, hδkeep⟩ := Metric.mem_nhds_iff.mp hQmem
+  obtain ⟨a, ha, -, hkernel⟩ :=
+    Smale.WeightedPerturbation.exists_small_parameter_with_common_kernel hb hk hβ hdim
+      (lt_min hε hδ)
+  have haε : ‖a‖ < ε := (lt_min_iff.mp ha).1
+  have haδ : ‖a‖ < δ := (lt_min_iff.mp ha).2
+  have hv := hvalid a haε
+  have hsmooth := Smale.ChartMapPerturbation.contMDiff_perturb c hf hβ.contMDiff hsupport hv
+  let g : C(E, N) := ⟨Smale.ChartMapPerturbation.perturb c f β a, hsmooth.continuous⟩
+  have hQg : Q g :=
+    hδkeep (show a ∈ Metric.ball 0 δ by simpa only [Metric.mem_ball, dist_zero_right] using haδ)
+  refine
+    ⟨g, hsmooth, hQg,
+      ⟨Smale.ChartMapPerturbation.homotopyRel c hf hβ.contMDiff hsupport hvalid haε⟩, ?_⟩
+  intro x hx
+  have hxplateau := hplateau x hx
+  have hsource (y : E) (hy : χ y = 1) : f y ∈ c.source :=
+    hχsupport (subset_tsupport χ (by change χ y ≠ 0; rw [hy]; exact one_ne_zero))
+  have hxone : χ (b x) = 1 := interior_subset (s := {y | χ y = 1}) hxplateau
+  have hfx := hsource (b x) hxone
+  have hgx : g (b x) ∈ c.source := Smale.ChartMapPerturbation.perturb_mem_source c f β hv hfx
+  have heqold : k =ᶠ[𝓝 (b x)] (c ∘ f) := by
+    filter_upwards [isOpen_interior.mem_nhds hxplateau] with y hy
+    exact
+      Smale.ChartMapPerturbation.cutoffCoordinates_eq_of_one c f χ
+        (interior_subset (s := {y | χ y = 1}) hy)
+  have heqnew : (c ∘ g) =ᶠ[𝓝 (b x)] Smale.WeightedPerturbation.perturb k β a := by
+    filter_upwards [isOpen_interior.mem_nhds hxplateau] with y hy
+    have hyone : χ y = 1 := interior_subset (s := {y | χ y = 1}) hy
+    change c (Smale.ChartMapPerturbation.perturb c f β a y) = _
+    rw [Smale.ChartMapPerturbation.chart_perturb c f β hv (hsource y hyone)]
+    simp only [Smale.ChartMapPerturbation.coordinateFamily, Smale.WeightedPerturbation.perturb, k,
+      Smale.ChartMapPerturbation.cutoffCoordinates, hyone, one_smul]
+  apply (injective_fderiv_chart_iff c (hsmooth.mdifferentiableAt (by simp)) hgx).mp
+  change Function.Injective (fderiv ℝ (c ∘ g) (b x))
+  rw [heqnew.fderiv_eq]
+  intro v w hvw
+  have hzero : fderiv ℝ (Smale.WeightedPerturbation.perturb k β a) (b x) (v - w) = 0 := by
+    rw [map_sub, hvw, sub_self]
+  obtain ⟨hkzero, hβzero⟩ := (hkernel x (v - w)).mp hzero
+  have hnative : mfderiv 𝓘(ℝ, E) J f (b x) (v - w) = 0 := by
+    apply (fderiv_chart_eq_zero_iff c (hf.mdifferentiableAt (by simp)) hfx (v - w)).mp
+    rw [← heqold.fderiv_eq]
+    exact hkzero
+  exact sub_eq_zero.mp (hcommon x hx (v - w) hnative hβzero)
+
+private theorem Smale.ChartMapPerturbation.derivative_eq_zero_iff_of_weight_derivative_eq_zero
+    {E G F H N : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [TopologicalSpace N] [ChartedSpace H N]
+    (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : E → N} {β : E → ℝ}
+    (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) (hβ : ContDiff ℝ ∞ β) (hsupport : tsupport β ⊆ f ⁻¹' c.source)
+    {a : F} (ha : Valid c f β a) {x v : E} (hweight : fderiv ℝ β x v = 0) :
+    mfderiv 𝓘(ℝ, E) J (perturb c f β a) x v = 0 ↔ mfderiv 𝓘(ℝ, E) J f x v = 0 := by
+  by_cases hx : f x ∈ c.source
+  · have hsmooth := contMDiff_perturb c hf hβ.contMDiff hsupport ha
+    have hgx := perturb_mem_source c f β ha hx
+    have hcf : ContDiffAt ℝ ∞ (c ∘ f) x :=
+      ((c.contMDiffOn_toFun.contMDiffAt (c.open_source.mem_nhds hx)).comp x
+          hf.contMDiffAt) |>.contDiffAt
+    have hcd :
+      HasFDerivAt (fun y => c (f y) + β y • a) (fderiv ℝ (c ∘ f) x + (fderiv ℝ β x).smulRight a)
+        x :=
+      (hcf.differentiableAt (by simp)).hasFDerivAt.add
+        ((hβ.differentiable (by simp) x).hasFDerivAt.smul_const a)
+    have heq : (c ∘ perturb c f β a) =ᶠ[𝓝 x] (fun y => c (f y) + β y • a) := by
+      filter_upwards [(c.open_source.preimage hf.continuous).mem_nhds hx] with y hy
+      exact chart_perturb c f β ha hy
+    have hderiv :
+      fderiv ℝ (c ∘ perturb c f β a) x = fderiv ℝ (c ∘ f) x + (fderiv ℝ β x).smulRight a :=
+      heq.fderiv_eq.trans hcd.fderiv
+    rw [←
+      Smale.ManifoldImmersion.fderiv_chart_eq_zero_iff c (hsmooth.mdifferentiableAt (by simp)) hgx
+        v,
+      ← Smale.ManifoldImmersion.fderiv_chart_eq_zero_iff c (hf.mdifferentiableAt (by simp)) hx v,
+      hderiv]
+    change fderiv ℝ (c ∘ f) x v + fderiv ℝ β x v • a = 0 ↔ fderiv ℝ (c ∘ f) x v = 0
+    rw [hweight, zero_smul, add_zero]
+  · have hn : x ∉ tsupport β := fun ht => hx (hsupport ht)
+    have hzero := notMem_tsupport_iff_eventuallyEq.mp hn
+    have heq : perturb c f β a =ᶠ[𝓝 x] f := by
+      filter_upwards [hzero] with y hy
+      exact perturb_eq_of_zero c f β a hy
+    rw [heq.mfderiv_eq]
+    rfl
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Recognition/Smale8.lean b/LeanPool/HopfProblem/Recognition/Smale8.lean
new file mode 100644
index 000000000..71e68cae1
--- /dev/null
+++ b/LeanPool/HopfProblem/Recognition/Smale8.lean
@@ -0,0 +1,5528 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Pi1.ThreefoldOverlapMappingTorus2
+import all LeanPool.HopfProblem.Recognition.Smale1
+import all LeanPool.HopfProblem.Recognition.Smale2
+import all LeanPool.HopfProblem.Recognition.Smale3
+import all LeanPool.HopfProblem.Recognition.Smale4
+import all LeanPool.HopfProblem.Recognition.Smale5
+import all LeanPool.HopfProblem.Recognition.Degree1
+import all LeanPool.HopfProblem.Recognition.Smale6
+import all LeanPool.HopfProblem.Recognition.Smale7
+import all LeanPool.HopfProblem.Pi1.ThreefoldOverlapMappingTorus2
+
+/-!
+# Hopf problem: recognition · smale 8
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem
+    Smale.ChartMapPerturbation.fderiv_cutoff_mul_eq_zero {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {ψ ρ : E → ℝ} (hψ : ContDiff ℝ ∞ ψ) (hρ : ContDiff ℝ ∞ ρ) {x v : E}
+    (hx : ρ x = 0) (hv : fderiv ℝ ρ x v = 0) : fderiv ℝ (fun y => ψ y * ρ y) x v = 0 := by
+  rw [fderiv_fun_mul (hψ.differentiable (by simp) x) (hρ.differentiable (by simp) x)]
+  simp only [add_apply, smul_apply, smul_eq_mul, hx, hv, MulZeroClass.mul_zero,
+    MulZeroClass.zero_mul, add_zero]
+
+private theorem Smale.ChartMapPerturbation.common_kernel_preserved_on_zero_set {E G F H N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [TopologicalSpace N] [ChartedSpace H N] (c : PartialDiffeomorph J 𝓘(ℝ, F) N F ∞) {f : E → N}
+    {ψ ρ : E → ℝ} (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) (hψ : ContDiff ℝ ∞ ψ) (hρ : ContDiff ℝ ∞ ρ)
+    (hsupport : tsupport (fun y => ψ y * ρ y) ⊆ f ⁻¹' c.source) {a : F}
+    (ha : Valid c f (fun y => ψ y * ρ y) a)
+    (hcommon : ∀ x, ρ x = 0 → ∀ v, mfderiv 𝓘(ℝ, E) J f x v = 0 → fderiv ℝ ρ x v = 0 → v = 0) :
+    ∀ x,
+      ρ x = 0 →
+        ∀ v,
+          mfderiv 𝓘(ℝ, E) J (perturb c f (fun y => ψ y * ρ y) a) x v = 0 →
+            fderiv ℝ ρ x v = 0 → v = 0 := by
+  intro x hx v hzero hv
+  have hweight := fderiv_cutoff_mul_eq_zero hψ hρ hx hv
+  have hold :=
+    (derivative_eq_zero_iff_of_weight_derivative_eq_zero c hf (hψ.mul hρ) hsupport ha hweight).mp
+      hzero
+  exact hcommon x hx v hold hv
+
+private theorem
+    Smale.ManifoldImmersion.exists_boundary_derivative_repair_step {B E G H H' X N : Type*}
+    [NormedAddCommGroup B] [NormedSpace ℝ B] [FiniteDimensional ℝ B] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    {I : ModelWithCorners ℝ B H} {J : ModelWithCorners ℝ G H'} [J.Boundaryless]
+    [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X] [LindelofSpace (X × E)]
+    [TopologicalSpace N] [ChartedSpace H' N] [IsManifold J ∞ N] {ι : Type*} [Finite ι]
+    (p : ι → Smale.ManifoldSmoothing.MapSmoothingPatch 𝓘(ℝ, E) J (X := E) (N := N)) (i : ι)
+    (f : C(E, N)) (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) (hcompatible : ∀ j, (p j).Compatible f)
+    {b : X → E} (hb : ContMDiff I 𝓘(ℝ, E) ∞ b) {ρ : E → ℝ} (hρ : ContDiff ℝ ∞ ρ)
+    (hzero : ∀ x, ρ (b x) = 0)
+    (hdim : Module.finrank ℝ B + Module.finrank ℝ E < Module.finrank ℝ G) {K L : Set E}
+    (hK : IsCompact K) (hinj : ∀ y ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f y))
+    (hLsub : L ⊆ (p i).plateau) (hLrange : L ⊆ Set.range b)
+    (hcommon : ∀ y, ρ y = 0 → ∀ v, mfderiv 𝓘(ℝ, E) J f y v = 0 → fderiv ℝ ρ y v = 0 → v = 0) :
+    ∃ g : C(E, N),
+      ContMDiff 𝓘(ℝ, E) J ∞ g ∧
+        (∀ j, (p j).Compatible g) ∧
+          f.HomotopicRel g {y | ρ y = 0} ∧
+            (∀ y, ρ y = 0 → ∀ v, mfderiv 𝓘(ℝ, E) J g y v = 0 → fderiv ℝ ρ y v = 0 → v = 0) ∧
+              ∀ y ∈ K ∪ L, Function.Injective (mfderiv 𝓘(ℝ, E) J g y) := by
+  let β : E → ℝ := fun y => (p i).cutoff y * ρ y
+  have hβ : ContDiff ℝ ∞ β := (p i).smooth.contDiff.mul hρ
+  have hcompact : HasCompactSupport β := (p i).compact.mul_right
+  have hsupport : tsupport β ⊆ f ⁻¹' (p i).chart.source :=
+    tsupport_mul_subset_left.trans ((p i).inner_compatible (hcompatible i))
+  have hkeep :
+    ∀ᶠ a in 𝓝 (0 : G),
+      ∀ j, (p j).Compatible (Smale.ChartMapPerturbation.perturb (p i).chart f β a) := by
+    apply Filter.eventually_all.mpr
+    intro j
+    exact
+      Smale.ChartMapPerturbation.eventually_maps_compact_into_open (p i).chart hf hβ.contMDiff
+        hsupport (p j).outer_compact.isCompact (p j).chart.open_source (hcompatible j)
+  have hold :=
+    Smale.ChartMapPerturbation.eventually_perturb_injective_derivative (p i).chart hf hβ.contMDiff
+      hcompact hsupport hK hinj
+  let Common (g : E → N) : Prop :=
+    ∀ y, ρ y = 0 → ∀ v, mfderiv 𝓘(ℝ, E) J g y v = 0 → fderiv ℝ ρ y v = 0 → v = 0
+  have hretain :
+    ∀ᶠ a in 𝓝 (0 : G), Common (Smale.ChartMapPerturbation.perturb (p i).chart f β a) := by
+    filter_upwards [Smale.ChartMapPerturbation.eventually_valid (p i).chart hf hβ.contMDiff
+        hcompact hsupport] with
+      a ha
+    exact
+      Smale.ChartMapPerturbation.common_kernel_preserved_on_zero_set (p i).chart hf
+        (p i).smooth.contDiff hρ hsupport ha hcommon
+  let Q : (E → N) → Prop := fun g =>
+    (∀ j, (p j).Compatible g) ∧ (∀ y ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J g y)) ∧ Common g
+  have hQ : ∀ᶠ a in 𝓝 (0 : G), Q (Smale.ChartMapPerturbation.perturb (p i).chart f β a) :=
+    hkeep.and (hold.and hretain)
+  have houter : (p i).plateau ⊆ interior {y | (p i).outer y = 1} := by
+    apply isOpen_interior.subset_interior_iff.mpr
+    intro y hy
+    apply (p i).nested y
+    apply subset_tsupport (p i).cutoff
+    change (p i).cutoff y ≠ 0
+    rw [interior_subset (s := {y | (p i).cutoff y = 1}) hy]
+    exact one_ne_zero
+  have hplateau : ∀ x ∈ b ⁻¹' L, b x ∈ interior {y | (p i).outer y = 1} := fun _ hx =>
+    houter (hLsub hx)
+  have hcommonβ :
+    ∀ x ∈ b ⁻¹' L, ∀ v, mfderiv 𝓘(ℝ, E) J f (b x) v = 0 → fderiv ℝ β (b x) v = 0 → v = 0 := by
+    intro x hx v hfv hβv
+    have heq : β =ᶠ[𝓝 (b x)] ρ := by
+      filter_upwards [(p i).plateau_eventually_one (hLsub hx)] with y hy
+      simp only [β, hy, one_mul]
+    apply hcommon (b x) (hzero x) v hfv
+    rw [← heq.fderiv_eq]
+    exact hβv
+  obtain ⟨g, hg, ⟨hc, hinjg, hcommong⟩, ⟨Hrel⟩, hnew⟩ :=
+    exists_weighted_immersive_patch_with_property (p i).chart f hf hb hβ
+      (p i).outer_smooth.contDiff hcompact hsupport (hcompatible i) hplateau hcommonβ hdim Q hQ
+  refine ⟨g, hg, hc, ?_, hcommong, ?_⟩
+  · refine ⟨{ Hrel.toHomotopy with prop' := ?_ }⟩
+    intro t y hy
+    apply Hrel.eq_fst t
+    change (p i).cutoff y * ρ y = 0
+    rw [hy, MulZeroClass.mul_zero]
+  · intro y hy
+    rcases hy with hy | hy
+    · exact hinjg y hy
+    · obtain ⟨x, rfl⟩ := hLrange hy
+      exact hnew x hy
+
+private theorem
+    Smale.ManifoldImmersion.exists_finite_boundary_derivative_repair {B E G H H' X N : Type*}
+    [NormedAddCommGroup B] [NormedSpace ℝ B] [FiniteDimensional ℝ B] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    {I : ModelWithCorners ℝ B H} {J : ModelWithCorners ℝ G H'} [J.Boundaryless]
+    [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X] [LindelofSpace (X × E)]
+    [TopologicalSpace N] [ChartedSpace H' N] [IsManifold J ∞ N] {ι : Type*} [Finite ι]
+    (p : ι → Smale.ManifoldSmoothing.MapSmoothingPatch 𝓘(ℝ, E) J (X := E) (N := N))
+    (L : ι → Set E) (hL : ∀ i, IsCompact (L i)) (hLsub : ∀ i, L i ⊆ (p i).plateau) (f : C(E, N))
+    (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) (hcompatible : ∀ i, (p i).Compatible f) {b : X → E}
+    (hb : ContMDiff I 𝓘(ℝ, E) ∞ b) (hLrange : ∀ i, L i ⊆ Set.range b) {ρ : E → ℝ}
+    (hρ : ContDiff ℝ ∞ ρ) (hzero : ∀ x, ρ (b x) = 0)
+    (hdim : Module.finrank ℝ B + Module.finrank ℝ E < Module.finrank ℝ G) {K : Set E}
+    (hK : IsCompact K) (hinj : ∀ y ∈ K, Function.Injective (mfderiv 𝓘(ℝ, E) J f y))
+    (hcommon : ∀ y, ρ y = 0 → ∀ v, mfderiv 𝓘(ℝ, E) J f y v = 0 → fderiv ℝ ρ y v = 0 → v = 0)
+    (s : Finset ι) :
+    ∃ g : C(E, N),
+      ContMDiff 𝓘(ℝ, E) J ∞ g ∧
+        (∀ i, (p i).Compatible g) ∧
+          f.HomotopicRel g {y | ρ y = 0} ∧
+            (∀ y, ρ y = 0 → ∀ v, mfderiv 𝓘(ℝ, E) J g y v = 0 → fderiv ℝ ρ y v = 0 → v = 0) ∧
+              ∀ y ∈ K ∪ ⋃ i ∈ s, L i, Function.Injective (mfderiv 𝓘(ℝ, E) J g y) := by
+  classical
+    induction s using Finset.induction_on with
+  | empty =>
+    refine ⟨f, hf, hcompatible, ContinuousMap.HomotopicRel.refl f, hcommon, ?_⟩
+    simpa only [Finset.notMem_empty, Set.iUnion_of_empty, Set.iUnion_empty, Set.union_empty] using
+      hinj
+  | @insert i s _ ih =>
+    obtain ⟨g₁, hg₁, hc₁, hhom₁, hcommon₁, hinj₁⟩ := ih
+    have hKold : IsCompact (K ∪ ⋃ j ∈ s, L j) := hK.union (s.isCompact_biUnion (fun j _ => hL j))
+    obtain ⟨g₂, hg₂, hc₂, hhom₂, hcommon₂, hinj₂⟩ :=
+      exists_boundary_derivative_repair_step p i g₁ hg₁ hc₁ hb hρ hzero hdim hKold hinj₁ (hLsub i)
+        (hLrange i) hcommon₁
+    refine ⟨g₂, hg₂, hc₂, hhom₁.trans hhom₂, hcommon₂, ?_⟩
+    intro y hy
+    apply hinj₂ y
+    rcases hy with hy | hy
+    · exact Or.inl (Or.inl hy)
+    · obtain ⟨j, hj, hyj⟩ := Set.mem_iUnion₂.mp hy
+      rcases Finset.mem_insert.mp hj with rfl | hjs
+      · exact Or.inr hyj
+      · exact Or.inl (Or.inr (Set.mem_iUnion₂.mpr ⟨j, hjs, hyj⟩))
+
+public
+theorem Smale.ManifoldImmersion.exists_compact_boundary_derivative_repair {B E G H H' X N : Type*}
+    [NormedAddCommGroup B] [NormedSpace ℝ B] [FiniteDimensional ℝ B] [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    {I : ModelWithCorners ℝ B H} {J : ModelWithCorners ℝ G H'} [J.Boundaryless]
+    [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X] [CompactSpace X]
+    [LindelofSpace (X × E)] [TopologicalSpace N] [ChartedSpace H' N] [IsManifold J ∞ N]
+    (f : C(E, N)) (hf : ContMDiff 𝓘(ℝ, E) J ∞ f) {b : X → E} (hb : ContMDiff I 𝓘(ℝ, E) ∞ b)
+    {ρ : E → ℝ} (hρ : ContDiff ℝ ∞ ρ) (hzero : ∀ x, ρ (b x) = 0)
+    (hdim : Module.finrank ℝ B + Module.finrank ℝ E < Module.finrank ℝ G)
+    (hcommon : ∀ y, ρ y = 0 → ∀ v, mfderiv 𝓘(ℝ, E) J f y v = 0 → fderiv ℝ ρ y v = 0 → v = 0) :
+    ∃ g : C(E, N),
+      ContMDiff 𝓘(ℝ, E) J ∞ g ∧
+        f.HomotopicRel g {y | ρ y = 0} ∧
+          ∀ y ∈ Set.range b, Function.Injective (mfderiv 𝓘(ℝ, E) J g y) := by
+  classical
+  have hboundary : IsCompact (Set.range b) := isCompact_range hb.continuous
+  have hp (x : Set.range b) :
+    ∃ p : Smale.ManifoldSmoothing.MapSmoothingPatch 𝓘(ℝ, E) J (X := E) (N := N),
+      ∃ D : Set E, p.Compatible f ∧ IsCompact D ∧ D ∈ 𝓝 x.1 ∧ D ⊆ p.plateau := by
+    obtain ⟨p, hcompatible, hplateau⟩ :=
+      Smale.ManifoldSmoothing.exists_smoothing_patch_at (I := 𝓘(ℝ, E)) (J := J) f x.1
+    obtain ⟨D, hDx, hDsub, hD⟩ := local_compact_nhds (isOpen_interior.mem_nhds hplateau)
+    exact ⟨p, D, hcompatible, hD, hDx, hDsub⟩
+  choose p D hcompatible hD hn hsub using hp
+  have hcover : Set.range b ⊆ ⋃ x : Set.range b, interior (D x) := by
+    intro x hx
+    exact Set.mem_iUnion.mpr ⟨⟨x, hx⟩, mem_interior_iff_mem_nhds.mpr (hn ⟨x, hx⟩)⟩
+  obtain ⟨s, hs⟩ :=
+    hboundary.elim_finite_subcover (fun x : Set.range b => interior (D x))
+      (fun _ => isOpen_interior) hcover
+  let L (i : s) := Set.range b ∩ D i.1
+  have hL (i : s) : IsCompact (L i) := hboundary.inter_right (hD i.1).isClosed
+  have hLsub (i : s) : L i ⊆ (p i.1).plateau := fun _ hx => hsub i.1 hx.2
+  have hLrange (i : s) : L i ⊆ Set.range b := Set.inter_subset_left
+  obtain ⟨g, hg, -, hhom, -, hinj⟩ :=
+    exists_finite_boundary_derivative_repair (fun i : s => p i.1) L hL hLsub f hf
+      (fun i => hcompatible i.1) hb hLrange hρ hzero hdim isCompact_empty
+      (fun _ hx => False.elim hx) hcommon Finset.univ
+  refine ⟨g, hg, hhom, ?_⟩
+  intro y hy
+  obtain ⟨i, hi, hyD⟩ := Set.mem_iUnion₂.mp (hs hy)
+  apply hinj y
+  exact Or.inr (Set.mem_iUnion₂.mpr ⟨⟨i, hi⟩, Finset.mem_univ _, hy, interior_subset hyD⟩)
+
+private def Smale.CurveImmersion.endpointFunction (t : ℝ) : ℝ :=
+  t * (1 - t)
+
+private theorem Smale.CurveImmersion.contDiff_endpointFunction : ContDiff ℝ ∞ endpointFunction := by
+  unfold endpointFunction
+  fun_prop
+
+private theorem Smale.CurveImmersion.endpointFunction_eq_zero_iff (t : ℝ) :
+    endpointFunction t = 0 ↔ t = 0 ∨ t = 1 := by
+  rw [endpointFunction, mul_eq_zero, sub_eq_zero]
+  exact or_congr Iff.rfl eq_comm
+
+private theorem Smale.CurveImmersion.fderiv_endpointFunction (t v : ℝ) :
+    fderiv ℝ endpointFunction t v = v * (1 - 2 * t) := by
+  have hd : HasDerivAt endpointFunction (1 * (1 - t) + t * (0 - 1)) t :=
+    (hasDerivAt_id t).mul ((hasDerivAt_const t (1 : ℝ)).sub (hasDerivAt_id t))
+  have heq : 1 * (1 - t) + t * (0 - 1) = 1 - 2 * t := by ring
+  rw [heq] at hd
+  rw [hd.hasFDerivAt.fderiv]
+  rfl
+
+private theorem Smale.CurveImmersion.injective_endpointFunction_derivative {t : ℝ}
+    (ht : endpointFunction t = 0) {v : ℝ} (hv : fderiv ℝ endpointFunction t v = 0) : v = 0 := by
+  rw [fderiv_endpointFunction] at hv
+  rcases (endpointFunction_eq_zero_iff t).mp ht with rfl | rfl
+  · simpa using hv
+  · norm_num at hv
+    exact hv
+
+private theorem Smale.ManifoldImmersion.exists_curve_endpoint_derivative_repair {G H N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] (f : C(ℝ, N)) (hf : ContMDiff 𝓘(ℝ, ℝ) J ∞ f)
+    (hdim : 2 ≤ Module.finrank ℝ G) :
+    ∃ g : C(ℝ, N),
+      ContMDiff 𝓘(ℝ, ℝ) J ∞ g ∧
+        f.HomotopicRel g ({0, 1} : Set ℝ) ∧
+          ∀ t ∈ ({0, 1} : Set ℝ), Function.Injective (mfderiv 𝓘(ℝ, ℝ) J g t) := by
+  let X := ({0, 1} : Set ℝ)
+  let : Fintype X := ((Set.finite_singleton (1 : ℝ)).insert 0).fintype
+  let Z := EuclideanSpace ℝ (Fin 0)
+  let : ChartedSpace Z X := ChartedSpace.ofDiscreteTopology
+  let : IsManifold 𝓘(ℝ, Z) ∞ X := IsManifold.of_discreteTopology _
+  let b : X → ℝ := Subtype.val
+  have hb : ContMDiff 𝓘(ℝ, Z) 𝓘(ℝ, ℝ) ∞ b := contMDiff_of_discreteTopology
+  have hrange : Set.range b = ({0, 1} : Set ℝ) := by ext t; simp [b, X]
+  have hzero : ∀ x, Smale.CurveImmersion.endpointFunction (b x) = 0 := by
+    intro x
+    apply (Smale.CurveImmersion.endpointFunction_eq_zero_iff _).mpr
+    exact x.property
+  have hzset : {t | Smale.CurveImmersion.endpointFunction t = 0} = ({0, 1} : Set ℝ) := by
+    ext t
+    simp only [Set.mem_ofPred_eq, Smale.CurveImmersion.endpointFunction_eq_zero_iff,
+      Set.mem_insert_iff, Set.mem_singleton_iff]
+  have hd : Module.finrank ℝ Z + Module.finrank ℝ ℝ < Module.finrank ℝ G := by
+    simp only [Z, finrank_euclideanSpace_fin, Module.finrank_self]
+    omega
+  obtain ⟨g, hg, hrel, hi⟩ :=
+    exists_compact_boundary_derivative_repair f hf hb
+      Smale.CurveImmersion.contDiff_endpointFunction hzero hd
+      (fun _ ht _ _ hv => Smale.CurveImmersion.injective_endpointFunction_derivative ht hv)
+  refine ⟨g, hg, ?_, ?_⟩
+  · simpa only [hzset] using hrel
+  · simpa only [hrange] using hi
+
+private theorem
+    Smale.exists_short_embedded_arc {G H N : Type*} [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [FiniteDimensional ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [J.Boundaryless]
+    [TopologicalSpace N] [ChartedSpace H N] [IsManifold J ∞ N] [T2Space N] {U : Set N}
+    (hU : IsOpen U) {x : N} (hx : x ∈ U) (hdim : 2 ≤ Module.finrank ℝ G) :
+    ∃ f : C(ℝ, N),
+      ContMDiff 𝓘(ℝ, ℝ) J ∞ f ∧
+        f 0 = x ∧
+          f 1 ≠ x ∧
+            Topology.IsClosedEmbedding (fun t : unitInterval => f t) ∧
+              (∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J f t)) ∧
+                ∀ t ∈ Set.Icc (0 : ℝ) 1, f t ∈ U := by
+  let c : C(ℝ, N) := ContinuousMap.const ℝ x
+  obtain ⟨g, hg, hrel, hi⟩ :=
+    ManifoldImmersion.exists_curve_endpoint_derivative_repair (J := J) c contMDiff_const hdim
+  have hg0 : g 0 = x := (hrel.fst_eq_snd (by simp)).symm
+  have hi0 : Function.Injective (mfderiv 𝓘(ℝ, ℝ) J g 0) := hi 0 (by simp)
+  obtain ⟨V, hV, h0V, hinj⟩ :=
+    ManifoldImmersion.exists_open_injOn_of_injective_nativeDerivative hg hi0
+  let W := V ∩ ({t : ℝ | Function.Injective (mfderiv 𝓘(ℝ, ℝ) J g t)} ∩ g ⁻¹' U)
+  have hW : IsOpen W :=
+    hV.inter ((ManifoldImmersion.isOpen_injective_derivative hg).inter (hU.preimage g.continuous))
+  have h0W : (0 : ℝ) ∈ W := ⟨h0V, hi0, (show g 0 ∈ U from hg0.symm ▸ hx)⟩
+  obtain ⟨r, hr, hball⟩ := Metric.mem_nhds_iff.mp (hW.mem_nhds h0W)
+  let L : ℝ →L[ℝ] ℝ := (r / 2) • ContinuousLinearMap.id ℝ ℝ
+  have hLs : ContMDiff 𝓘(ℝ, ℝ) 𝓘(ℝ, ℝ) ∞ L := L.contDiff.contMDiff
+  have hL (t : ℝ) : L t = (r / 2) * t := rfl
+  have hscale : 0 < r / 2 := by positivity
+  have hLinj : Function.Injective L := by
+    intro s t hst
+    exact mul_left_cancel₀ hscale.ne' hst
+  have hLW : ∀ t ∈ Set.Icc (0 : ℝ) 1, L t ∈ W := by
+    intro t ht
+    apply hball
+    change Dist.dist (L t) 0 < r
+    rw [dist_zero_right, Real.norm_eq_abs, hL, abs_of_nonneg (mul_nonneg hscale.le ht.1)]
+    have hbound := mul_le_mul_of_nonneg_left ht.2 hscale.le
+    linarith
+  let f : C(ℝ, N) := ⟨g ∘ L, g.continuous.comp L.continuous⟩
+  have hf : ContMDiff 𝓘(ℝ, ℝ) J ∞ f := hg.comp hLs
+  have hfinj : Set.InjOn f (Set.Icc (0 : ℝ) 1) := by
+    intro s hs t ht hst
+    exact hLinj (hinj (hLW s hs).1 (hLW t ht).1 hst)
+  have hf0 : f 0 = x := by
+    change g (L 0) = x
+    rw [map_zero, hg0]
+  have hemb : Topology.IsClosedEmbedding (fun t : unitInterval => f t) := by
+    apply (f.continuous.comp continuous_subtype_val).isClosedEmbedding
+    intro s t hst
+    exact Subtype.ext (hfinj s.property t.property hst)
+  refine ⟨f, hf, hf0, ?_, hemb, ?_, ?_⟩
+  · intro hfx
+    have h10 : (1 : ℝ) = 0 := hfinj (by simp) (by simp) (hfx.trans hf0.symm)
+    exact one_ne_zero h10
+  · intro t ht
+    change Function.Injective (mfderiv 𝓘(ℝ, ℝ) J (g ∘ L) t)
+    rw [mfderiv_comp t (hg.mdifferentiableAt (by simp)) (hLs.mdifferentiableAt (by simp)),
+      mfderiv_eq_fderiv, L.fderiv]
+    exact (hLW t ht).2.1.comp hLinj
+  · intro t ht
+    exact (hLW t ht).2.2
+
+private theorem Smale.exists_embedded_connecting_arc_avoiding_finite_dim_two {G H N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [J.Boundaryless] [TopologicalSpace N] [ChartedSpace H N]
+    [IsManifold J ∞ N] [T2Space N] {x y : N} (γ : Path x y) (hxy : x ≠ y)
+    (hdim : 2 ≤ Module.finrank ℝ G) {S : Set N} (hS : S.Finite) :
+    ∃ f : C(ℝ, N),
+      ContMDiff 𝓘(ℝ, ℝ) J ∞ f ∧
+        f 0 = x ∧
+          f 1 = y ∧
+            Topology.IsClosedEmbedding (fun t : unitInterval => f t) ∧
+              (∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Injective (mfderiv 𝓘(ℝ, ℝ) J f t)) ∧
+                ∀ t ∈ Set.Ioo (0 : ℝ) 1, f t ∉ S := by
+  have hSx : (S \ { x }).Finite := hS.subset Set.sdiff_subset
+  obtain ⟨g, hg, hg0, hg1, hemb, hi, havoid⟩ :=
+    exists_short_embedded_arc (J := J) hSx.isClosed.isOpen_compl
+      (show x ∈ (S \ { x })ᶜ from by simp) hdim
+  have hginj : Set.InjOn g (Set.Icc (0 : ℝ) 1) := by
+    intro s hs t ht hst
+    exact congrArg Subtype.val (hemb.injective (a₁ := ⟨s, hs⟩) (a₂ := ⟨t, ht⟩) hst)
+  have hg1S : g 1 ∉ S := by
+    intro hs
+    exact havoid 1 (by simp) ⟨hs, hg1⟩
+  let C : Set N := (Insert.insert x S) \ { y }
+  have hC : C.Finite := (hS.insert x).subset Set.sdiff_subset
+  have hxC : x ∈ C := ⟨Set.mem_insert x S, hxy⟩
+  have hg1C : g 1 ∉ C := by
+    rintro ⟨hr, _⟩
+    rcases hr with hr | hr
+    · exact hg1 hr
+    · exact hg1S hr
+  have hyC : y ∉ C := fun hy => hy.2 rfl
+  let α : Path x (g 1) :=
+    { toFun := fun t => g t
+      continuous_toFun := g.continuous.comp continuous_subtype_val
+      source' := hg0
+      target' := rfl }
+  obtain ⟨d, hd, hfix⟩ :=
+    exists_pointMoving_fixing_finite (J := J) (α.symm.trans γ) hdim hC hg1C hyC
+  let f : C(ℝ, N) := ⟨d ∘ g, d.continuous.comp g.continuous⟩
+  have hf : ContMDiff 𝓘(ℝ, ℝ) J ∞ f := d.contMDiff.comp hg
+  refine ⟨f, hf, ?_, hd, ?_, ?_, ?_⟩
+  · change d (g 0) = x
+    rw [hg0]
+    exact hfix x hxC
+  · apply (f.continuous.comp continuous_subtype_val).isClosedEmbedding
+    intro s t hst
+    exact hemb.injective (d.injective hst)
+  · intro t ht
+    change Function.Injective (mfderiv 𝓘(ℝ, ℝ) J (d ∘ g) t)
+    rw [mfderiv_comp t (d.contMDiff.mdifferentiableAt (by simp)) (hg.mdifferentiableAt (by simp))]
+    exact
+      (PartialChart.bijective_mfderiv d.toPartialDiffeomorph (Set.mem_univ (g t))).1.comp
+        (hi t ht)
+  · intro t ht hftS
+    have htI : t ∈ Set.Icc (0 : ℝ) 1 := ⟨ht.1.le, ht.2.le⟩
+    by_cases hfty : f t = y
+    · have hgt : g t = g 1 := d.injective (hfty.trans hd.symm)
+      exact ht.2.ne (hginj htI (by simp) hgt)
+    · have hftC : f t ∈ C := ⟨Or.inr hftS, hfty⟩
+      have hgt : g t = f t := d.injective (hfix (f t) hftC).symm
+      have hgtS : g t ∈ S := hgt.symm ▸ hftS
+      have hgtx : g t ≠ x := by
+        intro he
+        exact ht.1.ne' (hginj htI (by simp) (he.trans hg0.symm))
+      exact havoid t htI ⟨hgtS, hgtx⟩
+
+private theorem Smale.exists_tubular_connecting_arc_avoiding_finite_with_global_zero {G N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace N]
+    [ChartedSpace G N] [IsManifold 𝓘(ℝ, G) ∞ N] [T2Space N] [CompactSpace N] {x y : N}
+    (γ : Path x y) (hxy : x ≠ y) (hdim : 2 ≤ Module.finrank ℝ G) (n : ℕ)
+    (hcodim : 1 + n = Module.finrank ℝ G) {S : Set N} (hS : S.Finite) :
+    ∃ f : C(ℝ, N),
+      ContMDiff 𝓘(ℝ, ℝ) 𝓘(ℝ, G) ∞ f ∧
+        f 0 = x ∧
+          f 1 = y ∧
+            Topology.IsClosedEmbedding (fun t : unitInterval => f t) ∧
+              (∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Injective (mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, G) f t)) ∧
+                (∀ t ∈ Set.Ioo (0 : ℝ) 1, f t ∉ S) ∧
+                  ∃ ε : ℝ,
+                    0 < ε ∧
+                      ∃ Φ :
+                        PartialDiffeomorph 𝓘(ℝ, ℝ × EuclideanSpace ℝ (Fin n)) 𝓘(ℝ, G)
+                          (ℝ × EuclideanSpace ℝ (Fin n)) N ∞,
+                        Set.Icc (0 : ℝ) 1 ×ˢ Metric.closedBall 0 ε ⊆ Φ.source ∧
+                          (∀ t, Φ (t, 0) = f t) ∧ Φ.target ⊆ (S \ { x, y })ᶜ := by
+  obtain ⟨f, hf, hf0, hf1, hemb, hi, havoid⟩ :=
+    exists_embedded_connecting_arc_avoiding_finite_dim_two (J := 𝓘(ℝ, G)) γ hxy hdim hS
+  have hinj : Set.InjOn f (Set.Icc (0 : ℝ) 1) := by
+    intro t ht s hs hts
+    exact congrArg Subtype.val (hemb.injective (a₁ := ⟨t, ht⟩) (a₂ := ⟨s, hs⟩) hts)
+  have hO : IsOpen (S \ { x, y })ᶜ := (hS.subset Set.sdiff_subset).isClosed.isOpen_compl
+  have hfO : Set.MapsTo f (Set.Icc (0 : ℝ) 1) (S \ { x, y })ᶜ := by
+    intro t ht
+    change f t ∉ S \ { x, y }
+    by_cases ht0 : t = 0
+    · rw [ht0, hf0]
+      exact fun hx => hx.2 (by simp)
+    by_cases ht1 : t = 1
+    · rw [ht1, hf1]
+      exact fun hy => hy.2 (by simp)
+    have hti : t ∈ Set.Ioo (0 : ℝ) 1 :=
+      ⟨lt_of_le_of_ne ht.1 (Ne.symm ht0), lt_of_le_of_ne ht.2 ht1⟩
+    exact fun hs => havoid t hti hs.1
+  have hstar : StarConvex ℝ (0 : ℝ) (Set.Icc (0 : ℝ) 1) :=
+    (convex_Icc (0 : ℝ) 1).starConvex (by simp)
+  obtain ⟨ε, hε, Φ, hsource, hzero, htarget⟩ :=
+    exists_normed_tubularNeighborhood_in_open_of_embedded_starConvex_with_global_zero hf
+      CompactIccSpace.isCompact_Icc (by simp) hstar hinj hi n
+      (by simpa only [Module.finrank_self] using hcodim) hO hfO
+  exact ⟨f, hf, hf0, hf1, hemb, hi, havoid, ε, hε, Φ, hsource, hzero, htarget⟩
+
+private theorem
+    Smale.exists_clean_corner_of_tubular_arcs {E M D Z N P A B : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] [NormedAddCommGroup D] [NormedSpace ℝ D]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup A] [NormedSpace ℝ A]
+    [FiniteDimensional ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [FiniteDimensional ℝ B]
+    [TopologicalSpace N] [ChartedSpace D N] [TopologicalSpace P] [ChartedSpace Z P] {F : N → M}
+    {G : P → M} (hF : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ F) (hG : ContMDiff 𝓘(ℝ, Z) 𝓘(ℝ, E) ∞ G)
+    (hembF : Topology.IsEmbedding F) (hembG : Topology.IsEmbedding G)
+    (c : PartialDiffeomorph 𝓘(ℝ, ℝ × A) 𝓘(ℝ, D) (ℝ × A) N ∞)
+    (d : PartialDiffeomorph 𝓘(ℝ, ℝ × B) 𝓘(ℝ, Z) (ℝ × B) P ∞) {f : ℝ → N} {g : ℝ → P}
+    (hc : ∀ t, c (t, 0) = f t) (hd : ∀ t, d (t, 0) = g t) {t₀ : ℝ}
+    (htc : (t₀, (0 : A)) ∈ c.source) (htd : (t₀, (0 : B)) ∈ d.source) (hxy : G (g t₀) = F (f t₀))
+    (hdim : Module.finrank ℝ (ℝ × A) + Module.finrank ℝ (ℝ × B) = Module.finrank ℝ E)
+    (ht :
+      Function.Surjective
+        ((mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F (f t₀)).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G (g t₀))))
+    {σ τ : ℝ} (hσ : σ ≠ 0) (hτ : τ ≠ 0) {O : Set M} (hO : IsOpen O) (hxO : F (f t₀) ∈ O) :
+    ∃ W : Set (ℝ × ℝ),
+      IsOpen W ∧
+        (0 : ℝ × ℝ) ∈ W ∧
+          ∃ k : (ℝ × ℝ) → M,
+            ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ k W ∧
+              Set.InjOn k W ∧
+                Set.MapsTo k W O ∧
+                  k 0 = F (f t₀) ∧
+                    (∀ p ∈ W, Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) k p)) ∧
+                      (∀ p ∈ W, (k p ∈ Set.range F ↔ p.2 = 0) ∧ (k p ∈ Set.range G ↔ p.1 = 0)) ∧
+                        (∀ s, (s, 0) ∈ W → k (s, 0) = F (f (t₀ + s * σ))) ∧
+                          (∀ t, (0, t) ∈ W → k (0, t) = G (g (t₀ + t * τ))) := by
+  let c' := (NativeParametrization.translation (t₀, (0 : A))).toPartialDiffeomorph.trans c
+  let d' := (NativeParametrization.translation (t₀, (0 : B))).toPartialDiffeomorph.trans d
+  have hc0 : (0 : ℝ × A) ∈ c'.source := by
+    refine ⟨Set.mem_univ _, ?_⟩
+    change 0 + (t₀, (0 : A)) ∈ c.source
+    rw [zero_add]
+    exact htc
+  have hd0 : (0 : ℝ × B) ∈ d'.source := by
+    refine ⟨Set.mem_univ _, ?_⟩
+    change 0 + (t₀, (0 : B)) ∈ d.source
+    rw [zero_add]
+    exact htd
+  have hcx : c' 0 = f t₀ := by
+    change c (0 + (t₀, (0 : A))) = f t₀
+    rw [zero_add, hc]
+  have hdy : d' 0 = g t₀ := by
+    change d (0 + (t₀, (0 : B))) = g t₀
+    rw [zero_add, hd]
+  have hxy' : G (d' 0) = F (c' 0) := by rw [hcx, hdy]; exact hxy
+  have ht' :
+    Function.Surjective
+      ((mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F (c' 0)).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G (d' 0))) := by
+    rw [hcx, hdy]
+    exact ht
+  have hxO' : F (c' 0) ∈ O := by rw [hcx]; exact hxO
+  have hu : (σ, (0 : A)) ≠ 0 := fun he => hσ (congrArg Prod.fst he)
+  have hv : (τ, (0 : B)) ≠ 0 := fun he => hτ (congrArg Prod.fst he)
+  obtain ⟨W, hW, h0W, k, hk, hinj, hWO, hcenter, hi, hclean, hlo, hhi⟩ :=
+    exists_native_clean_corner_of_parametrizations hF hG hembF hembG c' d' hc0 hd0 hxy' hdim ht'
+      hu hv hO hxO'
+  refine ⟨W, hW, h0W, k, hk, hinj, hWO, hcenter.trans (congrArg F hcx), hi, hclean, ?_, ?_⟩
+  · intro s hs
+    rw [hlo s hs]
+    apply congrArg F
+    change c (s • (σ, (0 : A)) + (t₀, 0)) = f (t₀ + s * σ)
+    have he : s • (σ, (0 : A)) + (t₀, 0) = (t₀ + s * σ, 0) := by simp [smul_eq_mul, add_comm]
+    rw [he, hc]
+  · intro t ht
+    rw [hhi t ht]
+    apply congrArg G
+    change d (t • (τ, (0 : B)) + (t₀, 0)) = g (t₀ + t * τ)
+    have he : t • (τ, (0 : B)) + (t₀, 0) = (t₀ + t * τ, 0) := by simp [smul_eq_mul, add_comm]
+    rw [he, hd]
+
+private theorem Smale.nonempty_cleanCornerPatch_of_tubular_arcs {E M D Z N P A B : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup Z] [NormedSpace ℝ Z]
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [FiniteDimensional ℝ B] [TopologicalSpace N] [ChartedSpace D N]
+    [TopologicalSpace P] [ChartedSpace Z P] {F : N → M} {G : P → M}
+    (hF : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ F) (hG : ContMDiff 𝓘(ℝ, Z) 𝓘(ℝ, E) ∞ G)
+    (hembF : Topology.IsEmbedding F) (hembG : Topology.IsEmbedding G)
+    (c : PartialDiffeomorph 𝓘(ℝ, ℝ × A) 𝓘(ℝ, D) (ℝ × A) N ∞)
+    (d : PartialDiffeomorph 𝓘(ℝ, ℝ × B) 𝓘(ℝ, Z) (ℝ × B) P ∞) {f : ℝ → N} {g : ℝ → P}
+    (hc : ∀ t, c (t, 0) = f t) (hd : ∀ t, d (t, 0) = g t) {t₀ : ℝ}
+    (htc : (t₀, (0 : A)) ∈ c.source) (htd : (t₀, (0 : B)) ∈ d.source) (hxy : G (g t₀) = F (f t₀))
+    (hdim : Module.finrank ℝ (ℝ × A) + Module.finrank ℝ (ℝ × B) = Module.finrank ℝ E)
+    (ht :
+      Function.Surjective
+        ((mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F (f t₀)).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G (g t₀))))
+    {σ τ : ℝ} (hσ : σ ≠ 0) (hτ : τ ≠ 0) :
+    Nonempty
+      (CleanCornerPatch (E := E) (Set.range F) (Set.range G) (fun s => F (f (t₀ + s * σ)))
+        (fun t => G (g (t₀ + t * τ)))) := by
+  obtain ⟨W, hW, h0W, k, hk, hinj, _, _, hi, hsheets, hlo, hhi⟩ :=
+    exists_clean_corner_of_tubular_arcs hF hG hembF hembG c d hc hd htc htd hxy hdim ht hσ hτ
+      isOpen_univ (Set.mem_univ _)
+  exact
+    ⟨{ domain := W, open_domain := hW, contains_zero := h0W, map := k, smooth := hk,
+        injective := hinj, derivative_injective := hi, sheets := hsheets, axis_first := hlo,
+        axis_second := hhi }⟩
+
+private theorem Smale.exists_clean_ambient_chart_along_embedded_arc {E M G N : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace N]
+    [ChartedSpace G N] [IsManifold 𝓘(ℝ, G) ∞ N] [T2Space N] [CompactSpace N] {F : N → M}
+    {f : ℝ → N} (hF : ContMDiff 𝓘(ℝ, G) 𝓘(ℝ, E) ∞ F) (hembF : Topology.IsEmbedding F)
+    (hiF : ∀ x, Function.Injective (mfderiv 𝓘(ℝ, G) 𝓘(ℝ, E) F x))
+    (hf : ContMDiff 𝓘(ℝ, ℝ) 𝓘(ℝ, G) ∞ f) (hinjf : Set.InjOn f (Set.Icc (0 : ℝ) 1))
+    (hif : ∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Injective (mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, G) f t)) (n m : ℕ)
+    (hsheet : 1 + n = Module.finrank ℝ G) (hcodim : Module.finrank ℝ G + m = Module.finrank ℝ E)
+    {O : Set M} (hO : IsOpen O) (hfO : Set.MapsTo (F ∘ f) (Set.Icc (0 : ℝ) 1) O) :
+    ∃ Φ :
+      PartialDiffeomorph
+        𝓘(ℝ, StripCoordinates.Space (EuclideanSpace ℝ (Fin n)) (EuclideanSpace ℝ (Fin m))) 𝓘(ℝ, E)
+        (StripCoordinates.Space (EuclideanSpace ℝ (Fin n)) (EuclideanSpace ℝ (Fin m))) M ∞,
+      Set.MapsTo StripCoordinates.center (Set.Icc (0 : ℝ) 1) Φ.source ∧
+        Φ.target ⊆ O ∧
+          (∀ t, StripCoordinates.center t ∈ Φ.source → Φ (StripCoordinates.center t) = F (f t)) ∧
+            (∀ q ∈ Φ.source, Φ q ∈ Set.range F ↔ q.2 = 0) := by
+  have hstar : StarConvex ℝ (0 : ℝ) (Set.Icc (0 : ℝ) 1) :=
+    (convex_Icc (0 : ℝ) 1).starConvex (by simp)
+  obtain ⟨a, ha, c, hprod, hzero, _⟩ :=
+    exists_normed_tubularNeighborhood_in_open_of_embedded_starConvex_with_global_zero hf
+      CompactIccSpace.isCompact_Icc (by simp) hstar hinjf hif n
+      (by simpa only [Module.finrank_self] using hsheet) isOpen_univ (fun _ _ => Set.mem_univ _)
+  let K := Set.Icc (0 : ℝ) 1 ×ˢ {(0 : EuclideanSpace ℝ (Fin n))}
+  have hK : IsCompact K := CompactIccSpace.isCompact_Icc.prod isCompact_singleton
+  have h0K : (0 : ℝ × EuclideanSpace ℝ (Fin n)) ∈ K := by simp [K]
+  have hstarK : StarConvex ℝ (0 : ℝ × EuclideanSpace ℝ (Fin n)) K :=
+    hstar.prod (starConvex_singleton _)
+  have hKc : K ⊆ c.source := by
+    rintro ⟨t, z⟩ ⟨ht, hz⟩
+    have hz0 : z = 0 := hz
+    subst z
+    exact hprod ⟨ht, Metric.mem_closedBall_self ha.le⟩
+  have hFO : Set.MapsTo (F ∘ c) K O := by
+    rintro ⟨t, z⟩ ⟨ht, hz⟩
+    have hz0 : z = 0 := hz
+    subst z
+    change F (c (t, 0)) ∈ O
+    rw [hzero]
+    exact hfO ht
+  have hdim : Module.finrank ℝ (ℝ × EuclideanSpace ℝ (Fin n)) + m = Module.finrank ℝ E := by
+    simpa only [Module.finrank_prod, Module.finrank_self, finrank_euclideanSpace_fin,
+      hsheet] using hcodim
+  obtain ⟨b, hb, Φ, hΦprod, _, htarget, hΦzero, hclean⟩ :=
+    exists_clean_embedded_sheet_neighborhood hF hembF c hK h0K hstarK hKc (fun x _ => hiF (c x)) m
+      hdim hO hFO
+  refine ⟨Φ, ?_, htarget, ?_, hclean⟩
+  · intro t ht
+    exact hΦprod ⟨⟨ht, rfl⟩, Metric.mem_closedBall_self hb.le⟩
+  · intro t ht
+    exact (hΦzero (t, 0) ht).trans (congrArg F (hzero t))
+
+private theorem Smale.TransverseCoordinates.bijective_normalDerivative_transverse_sheet
+    {D B E M A Z N P : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [FiniteDimensional ℝ B] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [NormedAddCommGroup A] [NormedSpace ℝ A]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [TopologicalSpace N]
+    [ChartedSpace A N] [TopologicalSpace P] [ChartedSpace Z P]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, D × B) 𝓘(ℝ, E) (D × B) M ∞) {F : N → M} {G : P → M}
+    (hF : ContMDiff 𝓘(ℝ, A) 𝓘(ℝ, E) ∞ F) (hG : ContMDiff 𝓘(ℝ, Z) 𝓘(ℝ, E) ∞ G)
+    (hclean : ∀ q ∈ Φ.source, Φ q ∈ Set.range F ↔ q.2 = 0) {x : N} {y : P} (hx : F x ∈ Φ.target)
+    (hxy : G y = F x)
+    (ht :
+      Function.Surjective ((mfderiv 𝓘(ℝ, A) 𝓘(ℝ, E) F x).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G y)))
+    (hdim : Module.finrank ℝ Z = Module.finrank ℝ B) :
+    Function.Bijective (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, B) (normalCoordinate Φ ∘ G) y) := by
+  let Q : E →L[ℝ] B := mfderiv 𝓘(ℝ, E) 𝓘(ℝ, B) (normalCoordinate Φ) (F x)
+  let DF : A →L[ℝ] E := mfderiv 𝓘(ℝ, A) 𝓘(ℝ, E) F x
+  let DG : Z →L[ℝ] E := mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G y
+  have hQ : Function.Surjective Q := surjective_mfderiv_normalCoordinate Φ hx
+  have hQA : Q.comp DF = 0 := normalDerivative_comp_sheet_eq_zero Φ hF hclean hx
+  have hb : Function.Bijective (Q.comp DG) := bijective_normal_comp Q DF DG hQ ht hQA hdim
+  have hy : G y ∈ Φ.target := hxy.symm ▸ hx
+  have hnormal := (contMDiffOn_normalCoordinate Φ).contMDiffAt (Φ.open_target.mem_nhds hy)
+  have hderiv : mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, B) (normalCoordinate Φ ∘ G) y = Q.comp DG := by
+    rw [mfderiv_comp y (hnormal.mdifferentiableAt (by simp)) (hG.mdifferentiableAt (by simp)),
+      hxy]
+    rfl
+  rw [hderiv]
+  exact hb
+
+private theorem Smale.TransverseCoordinates.bijective_normalDerivative_transverse_parametrization
+    {D B E M A Z N P : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [FiniteDimensional ℝ B] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [NormedAddCommGroup A] [NormedSpace ℝ A]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [TopologicalSpace N]
+    [ChartedSpace A N] [TopologicalSpace P] [ChartedSpace Z P]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, D × B) 𝓘(ℝ, E) (D × B) M ∞) {Z' : Type*} [NormedAddCommGroup Z']
+    [NormedSpace ℝ Z'] {F : N → M} {G : P → M} (hF : ContMDiff 𝓘(ℝ, A) 𝓘(ℝ, E) ∞ F)
+    (hG : ContMDiff 𝓘(ℝ, Z) 𝓘(ℝ, E) ∞ G) (hclean : ∀ q ∈ Φ.source, Φ q ∈ Set.range F ↔ q.2 = 0)
+    (c : PartialDiffeomorph 𝓘(ℝ, Z') 𝓘(ℝ, Z) Z' P ∞) {z : Z'} (hz : z ∈ c.source) {x : N}
+    (hx : F x ∈ Φ.target) (hxy : G (c z) = F x)
+    (ht :
+      Function.Surjective
+        ((mfderiv 𝓘(ℝ, A) 𝓘(ℝ, E) F x).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G (c z))))
+    (hdim : Module.finrank ℝ Z = Module.finrank ℝ B) :
+    Function.Bijective (fderiv ℝ ((normalCoordinate Φ ∘ G) ∘ c) z) := by
+  have hb := bijective_normalDerivative_transverse_sheet Φ hF hG hclean hx hxy ht hdim
+  have hy : G (c z) ∈ Φ.target := hxy.symm ▸ hx
+  have hnormal := (contMDiffOn_normalCoordinate Φ).contMDiffAt (Φ.open_target.mem_nhds hy)
+  have hg : ContMDiffAt 𝓘(ℝ, Z) 𝓘(ℝ, B) ∞ (normalCoordinate Φ ∘ G) (c z) :=
+    hnormal.comp (c z) hG.contMDiffAt
+  rw [← mfderiv_eq_fderiv,
+    mfderiv_comp z (hg.mdifferentiableAt (by simp)) (c.mdifferentiableAt (by simp) hz)]
+  exact hb.comp (Smale.PartialChart.bijective_mfderiv c hz)
+
+private def Smale.NativeParametrization.line {D : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D]
+    (u : D) : ℝ →L[ℝ] D :=
+  (ContinuousLinearMap.id ℝ ℝ).smulRight u
+
+private theorem Smale.NativeParametrization.line_apply {D : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] (u : D) (t : ℝ) : line u t = t • u :=
+  rfl
+
+private theorem Smale.TransverseCoordinates.vertical_derivative_of_axis_germ {Z B : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    {H : (ℝ × ℝ) → B} {a : Z → B} (v : Z) (hH : DifferentiableAt ℝ H 0)
+    (ha : DifferentiableAt ℝ a 0) (heq : (fun t : ℝ => H (0, t)) =ᶠ[𝓝 0] (fun t => a (t • v))) :
+    fderiv ℝ H (0, 0) (0, 1) = fderiv ℝ a 0 v := by
+  let S : ℝ →L[ℝ] (ℝ × ℝ) := ContinuousLinearMap.inr ℝ ℝ ℝ
+  let L : ℝ →L[ℝ] Z := Smale.NativeParametrization.line v
+  have hHS : fderiv ℝ (H ∘ S) 0 = (fderiv ℝ H 0).comp S := by
+    rw [fderiv_comp 0 (by simpa only [map_zero] using hH) S.differentiableAt, map_zero, S.fderiv]
+  have haL : fderiv ℝ (a ∘ L) 0 = (fderiv ℝ a 0).comp L := by
+    rw [fderiv_comp 0 (by simpa only [map_zero] using ha) L.differentiableAt, map_zero, L.fderiv]
+  have heq' : (H ∘ S) =ᶠ[𝓝 (0 : ℝ)] (a ∘ L) := heq
+  have hd : fderiv ℝ (H ∘ S) 0 = fderiv ℝ (a ∘ L) 0 := heq'.fderiv_eq
+  rw [hHS, haL] at hd
+  have hval := congrArg (fun T : ℝ →L[ℝ] B => T 1) hd
+  change fderiv ℝ H (0 : ℝ × ℝ) (0, 1) = fderiv ℝ a 0 v
+  simpa only [ContinuousLinearMap.comp_apply, S, L, Smale.NativeParametrization.line_apply,
+    one_smul, ContinuousLinearMap.inr_apply] using hval
+
+private theorem Smale.TransverseCoordinates.eventually_vertical_derivative_ne_zero {B : Type*}
+    [NormedAddCommGroup B] [NormedSpace ℝ B] {H : (ℝ × ℝ) → B} {p : ℝ × ℝ}
+    (hH : ContDiffAt ℝ ∞ H p) (hn : fderiv ℝ H p (0, 1) ≠ 0) :
+    ∀ᶠ q in 𝓝 p, fderiv ℝ H q (0, 1) ≠ 0 := by
+  have hd : ContinuousAt (fderiv ℝ H) p := hH.continuousAt_fderiv (by simp)
+  have hv : ContinuousAt (fun q => fderiv ℝ H q (0, 1)) p := hd.clm_apply continuousAt_const
+  exact hv.preimage_mem_nhds (isClosed_singleton.isOpen_compl.mem_nhds hn)
+
+private theorem
+    Smale.TransverseCoordinates.corner_normalDerivative_ne_zero {D B E M A Z Z' N P : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [FiniteDimensional ℝ B] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup Z'] [NormedSpace ℝ Z']
+    [TopologicalSpace N] [ChartedSpace A N] [TopologicalSpace P] [ChartedSpace Z P]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, D × B) 𝓘(ℝ, E) (D × B) M ∞) {F : N → M} {G : P → M}
+    (hF : ContMDiff 𝓘(ℝ, A) 𝓘(ℝ, E) ∞ F) (hG : ContMDiff 𝓘(ℝ, Z) 𝓘(ℝ, E) ∞ G)
+    (hclean : ∀ q ∈ Φ.source, Φ q ∈ Set.range F ↔ q.2 = 0)
+    (c : PartialDiffeomorph 𝓘(ℝ, Z') 𝓘(ℝ, Z) Z' P ∞) (hc : (0 : Z') ∈ c.source) {x : N}
+    (hx : F x ∈ Φ.target) (hxy : G (c 0) = F x)
+    (ht :
+      Function.Surjective
+        ((mfderiv 𝓘(ℝ, A) 𝓘(ℝ, E) F x).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G (c 0))))
+    (hdim : Module.finrank ℝ Z = Module.finrank ℝ B) {k : (ℝ × ℝ) → M} {W : Set (ℝ × ℝ)}
+    (hk : ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ k W) (hW : IsOpen W) (h0W : (0 : ℝ × ℝ) ∈ W) {v : Z'}
+    (hv : v ≠ 0) (haxis : ∀ t, (0, t) ∈ W → k (0, t) = G (c (t • v))) :
+    fderiv ℝ (normalCoordinate Φ ∘ k) (0, 0) (0, 1) ≠ 0 ∧
+      ∀ᶠ q in 𝓝 (0 : ℝ × ℝ), fderiv ℝ (normalCoordinate Φ ∘ k) q (0, 1) ≠ 0 := by
+  let H := normalCoordinate Φ ∘ k
+  let a := (normalCoordinate Φ ∘ G) ∘ c
+  have hk0 : k (0 : ℝ × ℝ) = F x := by
+    have h := haxis 0 h0W
+    rw [zero_smul] at h
+    exact h.trans hxy
+  have hkΦ : k (0 : ℝ × ℝ) ∈ Φ.target := hk0.symm ▸ hx
+  have hnormal := (contMDiffOn_normalCoordinate Φ).contMDiffAt (Φ.open_target.mem_nhds hkΦ)
+  have hH : ContDiffAt ℝ ∞ H 0 := (hnormal.comp 0 (hk.contMDiffAt (hW.mem_nhds h0W))).contDiffAt
+  have hy : G (c 0) ∈ Φ.target := hxy.symm ▸ hx
+  have hnormalG := (contMDiffOn_normalCoordinate Φ).contMDiffAt (Φ.open_target.mem_nhds hy)
+  have ha : ContDiffAt ℝ ∞ a 0 :=
+    ((hnormalG.comp (c 0) hG.contMDiffAt).comp 0
+        (c.contMDiffOn_toFun.contMDiffAt (c.open_source.mem_nhds hc))).contDiffAt
+  have haxisW : ∀ᶠ t : ℝ in 𝓝 0, (0, t) ∈ W :=
+    (continuous_const.prodMk continuous_id).continuousAt.preimage_mem_nhds (hW.mem_nhds h0W)
+  have heq : (fun t : ℝ => H (0, t)) =ᶠ[𝓝 0] (fun t => a (t • v)) := by
+    filter_upwards [haxisW] with t htW
+    exact congrArg (normalCoordinate Φ) (haxis t htW)
+  have hderiv :=
+    vertical_derivative_of_axis_germ v (hH.differentiableAt (by simp))
+      (ha.differentiableAt (by simp)) heq
+  have hbij : Function.Bijective (fderiv ℝ a 0) :=
+    bijective_normalDerivative_transverse_parametrization Φ hF hG hclean c hc hx hxy ht hdim
+  have hn : fderiv ℝ H (0, 0) (0, 1) ≠ 0 := by
+    rw [hderiv]
+    intro hz
+    exact hv (hbij.1 (hz.trans (map_zero (fderiv ℝ a 0)).symm))
+  exact ⟨hn, eventually_vertical_derivative_ne_zero hH hn⟩
+
+private theorem Smale.StripCoordinates.exists_smooth_strip_matching_germs {A B : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] {v : ℝ → B}
+    {F₀ F₁ : (ℝ × ℝ) → Space A B} (hv : ContDiff ℝ ∞ v) (hF₀ : ContDiff ℝ ∞ F₀)
+    (hF₁ : ContDiff ℝ ∞ F₁) (hc₀ : (fun t : ℝ => F₀ (t, 0)) =ᶠ[𝓝 0] Smale.StripCoordinates.center)
+    (hc₁ : (fun t : ℝ => F₁ (t, 0)) =ᶠ[𝓝 1] Smale.StripCoordinates.center)
+    (hn₀ : normalDerivative F₀ =ᶠ[𝓝 (0 : ℝ)] v) (hn₁ : normalDerivative F₁ =ᶠ[𝓝 (1 : ℝ)] v) :
+    ∃ F : (ℝ × ℝ) → Space A B,
+      ContDiff ℝ ∞ F ∧
+        (∀ t, F (t, 0) = Smale.StripCoordinates.center t) ∧
+          (∀ t, normalDerivative F t = v t) ∧ (F =ᶠ[𝓝 (0, 0)] F₀) ∧ (F =ᶠ[𝓝 (1, 0)] F₁) := by
+  have hgood₀ :
+    {t : ℝ |
+        F₀ (t, 0) = Smale.StripCoordinates.center t ∧ normalDerivative F₀ t = v t ∧ t < 1 / 3} ∈
+      𝓝 (0 : ℝ) := by
+    filter_upwards [hc₀, hn₀, Iio_mem_nhds (show (0 : ℝ) < 1 / 3 by norm_num)] with t hc hn ht
+    exact ⟨hc, hn, ht⟩
+  have hgood₁ :
+    {t : ℝ |
+        F₁ (t, 0) = Smale.StripCoordinates.center t ∧ normalDerivative F₁ t = v t ∧ 2 / 3 < t} ∈
+      𝓝 (1 : ℝ) := by
+    filter_upwards [hc₁, hn₁, Ioi_mem_nhds (show (2 / 3 : ℝ) < 1 by norm_num)] with t hc hn ht
+    exact ⟨hc, hn, ht⟩
+  obtain ⟨β₀, _, hβ₀⟩ :=
+    (SmoothBumpFunction.nhds_basis_tsupport (I := 𝓘(ℝ, ℝ)) (0 : ℝ)).mem_iff.mp hgood₀
+  obtain ⟨β₁, _, hβ₁⟩ :=
+    (SmoothBumpFunction.nhds_basis_tsupport (I := 𝓘(ℝ, ℝ)) (1 : ℝ)).mem_iff.mp hgood₁
+  have hcβ₀ (t : ℝ) (ht : β₀ t ≠ 0) : F₀ (t, 0) = Smale.StripCoordinates.center t :=
+    (hβ₀ (subset_tsupport β₀ ht)).1
+  have hcβ₁ (t : ℝ) (ht : β₁ t ≠ 0) : F₁ (t, 0) = Smale.StripCoordinates.center t :=
+    (hβ₁ (subset_tsupport β₁ ht)).1
+  have hnβ₀ (t : ℝ) (ht : β₀ t ≠ 0) : normalDerivative F₀ t = v t :=
+    (hβ₀ (subset_tsupport β₀ ht)).2.1
+  have hnβ₁ (t : ℝ) (ht : β₁ t ≠ 0) : normalDerivative F₁ t = v t :=
+    (hβ₁ (subset_tsupport β₁ ht)).2.1
+  have hβ₀zero : (β₀ : ℝ → ℝ) =ᶠ[𝓝 (1 : ℝ)] 0 := by
+    apply notMem_tsupport_iff_eventuallyEq.mp
+    intro ht
+    have hbad : (1 : ℝ) < 1 / 3 := (hβ₀ ht).2.2
+    norm_num at hbad
+  have hβ₁zero : (β₁ : ℝ → ℝ) =ᶠ[𝓝 (0 : ℝ)] 0 := by
+    apply notMem_tsupport_iff_eventuallyEq.mp
+    intro ht
+    have hbad : (2 / 3 : ℝ) < 0 := (hβ₁ ht).2.2
+    norm_num at hbad
+  let F := blend v F₀ F₁ β₀ β₁
+  have hF : ContDiff ℝ ∞ F :=
+    contDiff_blend hv hF₀ hF₁ β₀.contMDiff.contDiff β₁.contMDiff.contDiff
+  refine
+    ⟨F, hF, blend_zero hcβ₀ hcβ₁,
+      normalDerivative_blend hv hF₀ hF₁ β₀.contMDiff.contDiff β₁.contMDiff.contDiff hnβ₀ hnβ₁, ?_,
+      ?_⟩
+  · have hp : Filter.Tendsto (Prod.fst : ℝ × ℝ → ℝ) (𝓝 (0, 0)) (𝓝 0) :=
+      continuous_fst.continuousAt.tendsto
+    filter_upwards [hp β₀.eventuallyEq_one, hp hβ₁zero] with p hp₀ hp₁
+    exact blend_eq_left hp₀ hp₁
+  · have hp : Filter.Tendsto (Prod.fst : ℝ × ℝ → ℝ) (𝓝 (1, 0)) (𝓝 1) :=
+      continuous_fst.continuousAt.tendsto
+    filter_upwards [hp hβ₀zero, hp β₁.eventuallyEq_one] with p hp₀ hp₁
+    exact blend_eq_right hp₀ hp₁
+
+private theorem Smale.StripCoordinates.exists_clean_strip_neighborhood {A B : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup B]
+    [InnerProductSpace ℝ B] [FiniteDimensional ℝ B] {v : ℝ → B} {F : (ℝ × ℝ) → Space A B}
+    (hv : ContDiff ℝ ∞ v) (hF : ContDiff ℝ ∞ F)
+    (hc : ∀ t, F (t, 0) = Smale.StripCoordinates.center t) (hD : ∀ t, normalDerivative F t = v t)
+    (hn : ∀ t ∈ Set.Icc (0 : ℝ) 1, v t ≠ 0) {O : Set (Space A B)} (hO : IsOpen O)
+    (hcenterO : Set.MapsTo Smale.StripCoordinates.center (Set.Icc (0 : ℝ) 1) O) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∃ W : Set (ℝ × ℝ),
+          IsOpen W ∧
+            Set.Icc (0 : ℝ) 1 ×ˢ Set.Icc (-ε) ε ⊆ W ∧
+              Set.InjOn F W ∧
+                Set.MapsTo F W O ∧
+                  (∀ p ∈ W, Function.Injective (fderiv ℝ F p)) ∧
+                    (∀ p ∈ W, (F p).2 = 0 ↔ p.2 = 0) ∧
+                      Topology.IsClosedEmbedding
+                        (fun p : Set.Icc (0 : ℝ) 1 ×ˢ Set.Icc (-ε) ε => F p) := by
+  let K := Set.Icc (0 : ℝ) 1 ×ˢ {(0 : ℝ)}
+  have hK : IsCompact K := CompactIccSpace.isCompact_Icc.prod isCompact_singleton
+  have hFK : Set.InjOn F K := by
+    rintro ⟨t, s⟩ ⟨ht, hs⟩ ⟨u, r⟩ ⟨hu, hr⟩ heq
+    have hs0 : s = 0 := hs
+    have hr0 : r = 0 := hr
+    subst s
+    subst r
+    have htu : t = u := by
+      simpa only [hc, Smale.StripCoordinates.center] using
+        congrArg (fun q : Space A B => q.1.1) heq
+    exact Prod.ext htu rfl
+  have hiF : ∀ p ∈ K, Function.Injective (fderiv ℝ F p) := by
+    rintro ⟨t, s⟩ ⟨ht, hs⟩
+    have hs0 : s = 0 := hs
+    subst s
+    apply injective_fderiv_at_center (hF.contDiffAt.differentiableAt (by simp)) hc
+    rw [hD t]
+    exact hn t ht
+  have hiFM : ∀ p ∈ K, Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, Space A B) F p) := by
+    intro p hp
+    rw [mfderiv_eq_fderiv]
+    exact hiF p hp
+  obtain ⟨V, hV, hKV, hinjV⟩ :=
+    Smale.ManifoldImmersion.exists_open_injOn_near_compact hF.contMDiff hK hFK hiFM
+  let Q := detector v F
+  have hQ : ContDiff ℝ ∞ Q := contDiff_detector hv hF
+  have hQK : Set.InjOn Q K := by
+    rintro ⟨t, s⟩ ⟨ht, hs⟩ ⟨u, r⟩ ⟨hu, hr⟩ heq
+    have hs0 : s = 0 := hs
+    have hr0 : r = 0 := hr
+    subst s
+    subst r
+    have htu : t = u := congrArg Prod.fst heq
+    exact Prod.ext htu rfl
+  have hiQ : ∀ p ∈ K, Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, ℝ × ℝ) Q p) := by
+    rintro ⟨t, s⟩ ⟨ht, hs⟩
+    have hs0 : s = 0 := hs
+    subst s
+    rw [mfderiv_eq_fderiv]
+    exact injective_fderiv_detector_at_center hv hF hc hD (hn t ht)
+  obtain ⟨T, hT, hKT, hinjT⟩ :=
+    Smale.ManifoldImmersion.exists_open_injOn_near_compact hQ.contMDiff hK hQK hiQ
+  let I := {p : ℝ × ℝ | Function.Injective (fderiv ℝ F p)}
+  have hI : IsOpen I :=
+    ContinuousLinearMap.isOpen_injective.preimage (hF.continuous_fderiv (by simp))
+  let W := ((V ∩ T) ∩ I) ∩ (F ⁻¹' O ∩ (fun p : ℝ × ℝ => (p.1, 0)) ⁻¹' T)
+  have hW : IsOpen W :=
+    ((hV.inter hT).inter hI).inter
+      ((hO.preimage hF.continuous).inter (hT.preimage (continuous_fst.prodMk continuous_const)))
+  have hKW : K ⊆ W := by
+    rintro ⟨t, s⟩ ⟨ht, hs⟩
+    have hs0 : s = 0 := hs
+    subst s
+    have hpK : (t, (0 : ℝ)) ∈ K := ⟨ht, rfl⟩
+    refine ⟨⟨⟨hKV hpK, hKT hpK⟩, hiF _ hpK⟩, ⟨?_, hKT hpK⟩⟩
+    change F (t, 0) ∈ O
+    rw [hc]
+    exact hcenterO ht
+  obtain ⟨ε, hε, hprod⟩ :=
+    Smale.DiskFraming.exists_pos_prod_closedBall_subset CompactIccSpace.isCompact_Icc hW hKW
+  have hrect : Set.Icc (0 : ℝ) 1 ×ˢ Set.Icc (-ε) ε ⊆ W := by
+    rintro ⟨t, s⟩ ⟨ht, hs⟩
+    apply hprod
+    refine ⟨ht, ?_⟩
+    simpa only [Metric.mem_closedBall, dist_zero_right, Real.norm_eq_abs] using abs_le.mpr hs
+  have hinjW : Set.InjOn F W := hinjV.mono (fun _ hp => hp.1.1.1)
+  refine ⟨ε, hε, W, hW, hrect, hinjW, fun _ hp => hp.2.1, fun _ hp => hp.1.2, ?_, ?_⟩
+  · rintro ⟨t, s⟩ hp
+    constructor
+    · intro hz
+      have heq : Q (t, s) = Q (t, 0) := by
+        change detector v F (t, s) = detector v F (t, 0)
+        rw [detector_zero hc]
+        change (t, ⟪v t, (F (t, s)).2⟫_ℝ) = (t, 0)
+        rw [hz, inner_zero_right]
+      exact congrArg Prod.snd (hinjT hp.1.1.2 hp.2.2 heq)
+    · intro hs
+      change s = 0 at hs
+      subst s
+      rw [hc]
+      rfl
+  · let R := Set.Icc (0 : ℝ) 1 ×ˢ Set.Icc (-ε) ε
+    let : CompactSpace R :=
+      isCompact_iff_compactSpace.mp
+        (CompactIccSpace.isCompact_Icc.prod CompactIccSpace.isCompact_Icc)
+    apply (hF.continuous.comp continuous_subtype_val).isClosedEmbedding
+    intro p q hpq
+    exact Subtype.ext (hinjW (hrect p.property) (hrect q.property) hpq)
+
+private theorem
+    Smale.StripCoordinates.contDiff_normalDerivative {A B : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] {F : (ℝ × ℝ) → Space A B}
+    (hF : ContDiff ℝ ∞ F) : ContDiff ℝ ∞ (normalDerivative F) :=
+  ((hF.snd.fderiv_right (by simp)).clm_apply contDiff_const).comp
+    (contDiff_id.prodMk contDiff_const)
+
+private theorem
+    Smale.StripCoordinates.normalDerivative_congr_germ {A B : Type*} [NormedAddCommGroup B]
+    [NormedSpace ℝ B] {F G : (ℝ × ℝ) → Space A B} {t : ℝ} (heq : F =ᶠ[𝓝 (t, 0)] G) :
+    normalDerivative F t = normalDerivative G t := by
+  have heq' : (fun p => (F p).2) =ᶠ[𝓝 (t, (0 : ℝ))] (fun p => (G p).2) := by
+    filter_upwards [heq] with p hp
+    exact congrArg Prod.snd hp
+  have hd : fderiv ℝ (fun p => (F p).2) (t, 0) = fderiv ℝ (fun p => (G p).2) (t, 0) :=
+    heq'.fderiv_eq
+  exact congrArg (fun L : (ℝ × ℝ) →L[ℝ] B => L (0, 1)) hd
+
+private theorem Smale.StripCoordinates.exists_clean_strip_matching_local_germs {A B : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup B]
+    [InnerProductSpace ℝ B] [FiniteDimensional ℝ B] {F₀ F₁ : (ℝ × ℝ) → Space A B}
+    {U₀ U₁ : Set (ℝ × ℝ)} (hF₀ : ContDiffOn ℝ ∞ F₀ U₀) (hF₁ : ContDiffOn ℝ ∞ F₁ U₁)
+    (hU₀ : IsOpen U₀) (hU₁ : IsOpen U₁) (h0U₀ : (0, 0) ∈ U₀) (h1U₁ : (1, 0) ∈ U₁)
+    (hc₀ : (fun t : ℝ => F₀ (t, 0)) =ᶠ[𝓝 0] Smale.StripCoordinates.center)
+    (hc₁ : (fun t : ℝ => F₁ (t, 0)) =ᶠ[𝓝 1] Smale.StripCoordinates.center)
+    (hn₀ : normalDerivative F₀ 0 ≠ 0) (hn₁ : normalDerivative F₁ 1 ≠ 0)
+    (hdim : 2 ≤ Module.finrank ℝ B) {O : Set (Space A B)} (hO : IsOpen O)
+    (hcenterO : Set.MapsTo Smale.StripCoordinates.center (Set.Icc (0 : ℝ) 1) O) :
+    ∃ F : (ℝ × ℝ) → Space A B,
+      ContDiff ℝ ∞ F ∧
+        (∀ t, F (t, 0) = Smale.StripCoordinates.center t) ∧
+          (F =ᶠ[𝓝 (0, 0)] F₀) ∧
+            (F =ᶠ[𝓝 (1, 0)] F₁) ∧
+              ∃ ε : ℝ,
+                0 < ε ∧
+                  ∃ W : Set (ℝ × ℝ),
+                    IsOpen W ∧
+                      Set.Icc (0 : ℝ) 1 ×ˢ Set.Icc (-ε) ε ⊆ W ∧
+                        Set.InjOn F W ∧
+                          Set.MapsTo F W O ∧
+                            (∀ p ∈ W, Function.Injective (fderiv ℝ F p)) ∧
+                              (∀ p ∈ W, (F p).2 = 0 ↔ p.2 = 0) ∧
+                                Topology.IsClosedEmbedding
+                                    (fun p : Set.Icc (0 : ℝ) 1 ×ˢ Set.Icc (-ε) ε => F p) ∧
+                                  (∀ t, normalDerivative F t ≠ 0) := by
+  obtain ⟨G₀, hG₀, heq₀⟩ := Smale.exists_smooth_extension_near_point hF₀.contMDiffOn hU₀ h0U₀
+  obtain ⟨G₁, hG₁, heq₁⟩ := Smale.exists_smooth_extension_near_point hF₁.contMDiffOn hU₁ h1U₁
+  have hnG₀ : normalDerivative G₀ 0 ≠ 0 := by rwa [normalDerivative_congr_germ heq₀]
+  have hnG₁ : normalDerivative G₁ 1 ≠ 0 := by rwa [normalDerivative_congr_germ heq₁]
+  obtain ⟨v, hv, hvne, hv₀, hv₁⟩ :=
+    Smale.DiskFraming.exists_nonzero_smooth_curve_with_endpoint_germs
+      (contDiff_normalDerivative hG₀.contDiff).contDiffOn
+      (contDiff_normalDerivative hG₁.contDiff).contDiffOn isOpen_univ isOpen_univ (Set.mem_univ _)
+      (Set.mem_univ _) hnG₀ hnG₁ hdim
+  have hcG₀ : (fun t : ℝ => G₀ (t, 0)) =ᶠ[𝓝 0] Smale.StripCoordinates.center := by
+    have hi : Filter.Tendsto (fun t : ℝ => (t, (0 : ℝ))) (𝓝 0) (𝓝 (0, 0)) :=
+      (continuous_id.prodMk continuous_const).continuousAt.tendsto
+    exact (heq₀.comp_tendsto hi).trans hc₀
+  have hcG₁ : (fun t : ℝ => G₁ (t, 0)) =ᶠ[𝓝 1] Smale.StripCoordinates.center := by
+    have hi : Filter.Tendsto (fun t : ℝ => (t, (0 : ℝ))) (𝓝 1) (𝓝 (1, 0)) :=
+      (continuous_id.prodMk continuous_const).continuousAt.tendsto
+    exact (heq₁.comp_tendsto hi).trans hc₁
+  obtain ⟨F, hF, hc, hD, hFG₀, hFG₁⟩ :=
+    exists_smooth_strip_matching_germs hv hG₀.contDiff hG₁.contDiff hcG₀ hcG₁ hv₀.symm hv₁.symm
+  obtain ⟨ε, hε, W, hW, hrect, hinj, hmap, hi, hclean, hemb⟩ :=
+    exists_clean_strip_neighborhood hv hF hc hD (fun t _ => hvne t) hO hcenterO
+  exact
+    ⟨F, hF, hc, hFG₀.trans heq₀, hFG₁.trans heq₁, ε, hε, W, hW, hrect, hinj, hmap, hi, hclean,
+      hemb, fun t => by rw [hD t]; exact hvne t⟩
+
+private theorem
+    Smale.exists_native_clean_strip_matching_germs {A B E M : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [FiniteDimensional ℝ A] [NormedAddCommGroup B] [InnerProductSpace ℝ B]
+    [FiniteDimensional ℝ B] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [T2Space M]
+    (Φ :
+      PartialDiffeomorph 𝓘(ℝ, StripCoordinates.Space A B) 𝓘(ℝ, E) (StripCoordinates.Space A B) M
+        ∞)
+    (hline : Set.MapsTo StripCoordinates.center (Set.Icc (0 : ℝ) 1) Φ.source) {S : Set M}
+    (hclean : ∀ q ∈ Φ.source, Φ q ∈ S ↔ q.2 = 0) {k₀ k₁ : (ℝ × ℝ) → M} {U₀ U₁ : Set (ℝ × ℝ)}
+    (hk₀ : ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ k₀ U₀)
+    (hk₁ : ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ k₁ U₁) (hU₀ : IsOpen U₀) (hU₁ : IsOpen U₁)
+    (h0U₀ : (0, 0) ∈ U₀) (h1U₁ : (1, 0) ∈ U₁)
+    (hc₀ : (fun t : ℝ => k₀ (t, 0)) =ᶠ[𝓝 0] fun t => Φ (StripCoordinates.center t))
+    (hc₁ : (fun t : ℝ => k₁ (t, 0)) =ᶠ[𝓝 1] fun t => Φ (StripCoordinates.center t))
+    (hn₀ : fderiv ℝ (TransverseCoordinates.normalCoordinate Φ ∘ k₀) (0, 0) (0, 1) ≠ 0)
+    (hn₁ : fderiv ℝ (TransverseCoordinates.normalCoordinate Φ ∘ k₁) (1, 0) (0, 1) ≠ 0)
+    (hdim : 2 ≤ Module.finrank ℝ B) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∃ W : Set (ℝ × ℝ),
+          IsOpen W ∧
+            Set.Icc (0 : ℝ) 1 ×ˢ Set.Icc (-ε) ε ⊆ W ∧
+              ∃ k : (ℝ × ℝ) → M,
+                ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ k W ∧
+                  Set.InjOn k W ∧
+                    Set.MapsTo k W Φ.target ∧
+                      Topology.IsClosedEmbedding
+                          (fun p : Set.Icc (0 : ℝ) 1 ×ˢ Set.Icc (-ε) ε => k p) ∧
+                        (∀ p ∈ W, Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) k p)) ∧
+                          (∀ p ∈ W, k p ∈ S ↔ p.2 = 0) ∧
+                            (∀ t, k (t, 0) = Φ (StripCoordinates.center t)) ∧
+                              (k =ᶠ[𝓝 (0, 0)] k₀) ∧
+                                (k =ᶠ[𝓝 (1, 0)] k₁) ∧
+                                  (∀ t ∈ Set.Icc (0 : ℝ) 1,
+                                    fderiv ℝ (TransverseCoordinates.normalCoordinate Φ ∘ k) (t, 0)
+                                        (0, 1) ≠
+                                      0) := by
+  let C₀ := U₀ ∩ k₀ ⁻¹' Φ.target
+  let C₁ := U₁ ∩ k₁ ⁻¹' Φ.target
+  have hC₀ : IsOpen C₀ := hk₀.continuousOn.isOpen_inter_preimage hU₀ Φ.open_target
+  have hC₁ : IsOpen C₁ := hk₁.continuousOn.isOpen_inter_preimage hU₁ Φ.open_target
+  have hline₀ : StripCoordinates.center (0 : ℝ) ∈ Φ.source := hline (by simp)
+  have hline₁ : StripCoordinates.center (1 : ℝ) ∈ Φ.source := hline (by simp)
+  have h0C₀ : (0, 0) ∈ C₀ := by
+    refine ⟨h0U₀, ?_⟩
+    change k₀ (0, 0) ∈ Φ.target
+    rw [hc₀.eq_of_nhds]
+    exact Φ.map_source' hline₀
+  have h1C₁ : (1, 0) ∈ C₁ := by
+    refine ⟨h1U₁, ?_⟩
+    change k₁ (1, 0) ∈ Φ.target
+    rw [hc₁.eq_of_nhds]
+    exact Φ.map_source' hline₁
+  let G₀ : (ℝ × ℝ) → StripCoordinates.Space A B := Φ.invFun ∘ k₀
+  let G₁ : (ℝ × ℝ) → StripCoordinates.Space A B := Φ.invFun ∘ k₁
+  have hG₀ : ContDiffOn ℝ ∞ G₀ C₀ :=
+    (Φ.contMDiffOn_invFun.comp (hk₀.mono Set.inter_subset_left) (fun _ hp => hp.2)).contDiffOn
+  have hG₁ : ContDiffOn ℝ ∞ G₁ C₁ :=
+    (Φ.contMDiffOn_invFun.comp (hk₁.mono Set.inter_subset_left) (fun _ hp => hp.2)).contDiffOn
+  have hc : Continuous (StripCoordinates.center : ℝ → StripCoordinates.Space A B) :=
+    (continuous_id.prodMk continuous_const).prodMk continuous_const
+  have hcG₀ : (fun t : ℝ => G₀ (t, 0)) =ᶠ[𝓝 0] StripCoordinates.center := by
+    have hsource := hc.continuousAt.preimage_mem_nhds (Φ.open_source.mem_nhds hline₀)
+    filter_upwards [hc₀, hsource] with t hkt ht
+    change Φ.invFun (k₀ (t, 0)) = StripCoordinates.center t
+    rw [hkt]
+    exact Φ.left_inv' ht
+  have hcG₁ : (fun t : ℝ => G₁ (t, 0)) =ᶠ[𝓝 1] StripCoordinates.center := by
+    have hsource := hc.continuousAt.preimage_mem_nhds (Φ.open_source.mem_nhds hline₁)
+    filter_upwards [hc₁, hsource] with t hkt ht
+    change Φ.invFun (k₁ (t, 0)) = StripCoordinates.center t
+    rw [hkt]
+    exact Φ.left_inv' ht
+  obtain
+    ⟨F, hF, hFc, hFG₀, hFG₁, ε, hε, W, hW, hrect, hinjF, hsource, hiF, hcleanF, _, hnormalF⟩ :=
+    StripCoordinates.exists_clean_strip_matching_local_germs hG₀ hG₁ hC₀ hC₁ h0C₀ h1C₁ hcG₀ hcG₁
+      hn₀ hn₁ hdim Φ.open_source hline
+  let k := Φ ∘ F
+  have hk : ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ k W :=
+    Φ.contMDiffOn_toFun.comp hF.contMDiff.contMDiffOn hsource
+  have hinjk : Set.InjOn k W := by
+    intro p hp q hq heq
+    exact hinjF hp hq (Φ.toPartialEquiv.injOn (hsource hp) (hsource hq) heq)
+  have hemb : Topology.IsClosedEmbedding (fun p : Set.Icc (0 : ℝ) 1 ×ˢ Set.Icc (-ε) ε => k p) := by
+    let R := Set.Icc (0 : ℝ) 1 ×ˢ Set.Icc (-ε) ε
+    let : CompactSpace R :=
+      isCompact_iff_compactSpace.mp
+        (CompactIccSpace.isCompact_Icc.prod CompactIccSpace.isCompact_Icc)
+    apply
+      (continuousOn_iff_continuous_domRestrict.mp (hk.continuousOn.mono hrect)).isClosedEmbedding
+    intro p q hpq
+    exact Subtype.ext (hinjk (hrect p.property) (hrect q.property) hpq)
+  refine
+    ⟨ε, hε, W, hW, hrect, k, hk, hinjk, fun _ hp => Φ.map_source' (hsource hp), hemb, ?_, ?_, ?_,
+      ?_, ?_, ?_⟩
+  · intro p hp
+    have hiFM : Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, StripCoordinates.Space A B) F p) := by
+      rw [mfderiv_eq_fderiv]
+      exact hiF p hp
+    change Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) (Φ ∘ F) p)
+    rw [mfderiv_comp p (Φ.mdifferentiableAt (by simp) (hsource hp))
+        (hF.contMDiff.mdifferentiableAt (by simp))]
+    exact (PartialChart.bijective_mfderiv Φ (hsource hp)).1.comp hiFM
+  · intro p hp
+    exact (hclean (F p) (hsource hp)).trans (hcleanF p hp)
+  · intro t
+    exact congrArg Φ (hFc t)
+  · filter_upwards [hFG₀, hC₀.mem_nhds h0C₀] with p hFp hp
+    change Φ (F p) = k₀ p
+    rw [hFp]
+    exact Φ.right_inv' hp.2
+  · filter_upwards [hFG₁, hC₁.mem_nhds h1C₁] with p hFp hp
+    change Φ (F p) = k₁ p
+    rw [hFp]
+    exact Φ.right_inv' hp.2
+  · intro t ht
+    have hp : (t, (0 : ℝ)) ∈ W := hrect ⟨ht, ⟨neg_nonpos.mpr hε.le, hε.le⟩⟩
+    have heq : (TransverseCoordinates.normalCoordinate Φ ∘ k) =ᶠ[𝓝 (t, 0)] (fun p => (F p).2) := by
+      filter_upwards [hW.mem_nhds hp] with p hpW
+      change (Φ.invFun (Φ (F p))).2 = (F p).2
+      rw [Φ.left_inv' (hsource hpW)]
+    rw [heq.fderiv_eq]
+    exact hnormalF t
+
+private theorem Smale.exists_strip_neighborhood_with_exact_endpoint_contacts {E H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [TopologicalSpace M] [ChartedSpace H M] {k : (ℝ × ℝ) → M} {W : Set (ℝ × ℝ)}
+    (hk : ContMDiffOn 𝓘(ℝ, ℝ × ℝ) I ∞ k W) (hW : IsOpen W)
+    (hKW : Set.Icc (0 : ℝ) 1 ×ˢ {(0 : ℝ)} ⊆ W) {B : Set M} (hB : IsClosed B)
+    (havoid : ∀ t ∈ Set.Ioo (0 : ℝ) 1, k (t, 0) ∉ B)
+    (hc₀ : ∀ᶠ p in 𝓝 ((0 : ℝ), (0 : ℝ)), k p ∈ B ↔ p.1 = 0)
+    (hc₁ : ∀ᶠ p in 𝓝 ((1 : ℝ), (0 : ℝ)), k p ∈ B ↔ p.1 = 1) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∃ U : Set (ℝ × ℝ),
+          IsOpen U ∧
+            Set.Icc (0 : ℝ) 1 ×ˢ Set.Icc (-ε) ε ⊆ U ∧
+              U ⊆ W ∧ ∀ p ∈ U, k p ∈ B ↔ p.1 = 0 ∨ p.1 = 1 := by
+  obtain ⟨V₀, hV₀sub, hV₀, h0V₀⟩ := _root_.mem_nhds_iff.mp hc₀
+  obtain ⟨V₁, hV₁sub, hV₁, h1V₁⟩ := _root_.mem_nhds_iff.mp hc₁
+  let L := V₀ ∩ (Prod.fst : ℝ × ℝ → ℝ) ⁻¹' Set.Iio (1 / 3)
+  let R := V₁ ∩ (Prod.fst : ℝ × ℝ → ℝ) ⁻¹' Set.Ioi (2 / 3)
+  let C := (W ∩ k ⁻¹' Bᶜ) ∩ (Prod.fst : ℝ × ℝ → ℝ) ⁻¹' Set.Ioo 0 1
+  have hL : IsOpen L := hV₀.inter (isOpen_Iio.preimage continuous_fst)
+  have hR : IsOpen R := hV₁.inter (isOpen_Ioi.preimage continuous_fst)
+  have hC : IsOpen C :=
+    (hk.continuousOn.isOpen_inter_preimage hW hB.isOpen_compl).inter
+      (isOpen_Ioo.preimage continuous_fst)
+  let U := W ∩ ((L ∪ R) ∪ C)
+  have hU : IsOpen U := hW.inter ((hL.union hR).union hC)
+  have hKU : Set.Icc (0 : ℝ) 1 ×ˢ {(0 : ℝ)} ⊆ U := by
+    rintro ⟨t, s⟩ ⟨ht, hs⟩
+    have hs0 : s = 0 := hs
+    subst s
+    have htW := hKW ⟨ht, rfl⟩
+    refine ⟨htW, ?_⟩
+    by_cases ht0 : t = 0
+    · subst t
+      exact Or.inl (Or.inl ⟨h0V₀, by change (0 : ℝ) < 1 / 3; norm_num⟩)
+    by_cases ht1 : t = 1
+    · subst t
+      exact Or.inl (Or.inr ⟨h1V₁, by change (2 / 3 : ℝ) < 1; norm_num⟩)
+    have hti : t ∈ Set.Ioo (0 : ℝ) 1 :=
+      ⟨lt_of_le_of_ne ht.1 (Ne.symm ht0), lt_of_le_of_ne ht.2 ht1⟩
+    exact Or.inr ⟨⟨htW, havoid t hti⟩, hti⟩
+  obtain ⟨ε, hε, hprod⟩ :=
+    DiskFraming.exists_pos_prod_closedBall_subset CompactIccSpace.isCompact_Icc hU hKU
+  refine ⟨ε, hε, U, hU, ?_, Set.inter_subset_left, ?_⟩
+  · rintro ⟨t, s⟩ ⟨ht, hs⟩
+    apply hprod
+    refine ⟨ht, ?_⟩
+    simpa only [Metric.mem_closedBall, dist_zero_right, Real.norm_eq_abs] using abs_le.mpr hs
+  · intro p hp
+    rcases hp.2 with (hpL | hpR) | hpC
+    · have hcontact : k p ∈ B ↔ p.1 = 0 := hV₀sub hpL.1
+      have hlt : p.1 < 1 / 3 := hpL.2
+      constructor
+      · exact fun h => Or.inl (hcontact.mp h)
+      · intro h
+        rcases h with h0 | h1
+        · exact hcontact.mpr h0
+        · rw [h1] at hlt
+          norm_num at hlt
+    · have hcontact : k p ∈ B ↔ p.1 = 1 := hV₁sub hpR.1
+      have hgt : 2 / 3 < p.1 := hpR.2
+      constructor
+      · exact fun h => Or.inr (hcontact.mp h)
+      · intro h
+        rcases h with h0 | h1
+        · rw [h0] at hgt
+          norm_num at hgt
+        · exact hcontact.mpr h1
+    · have hnot : k p ∉ B := hpC.1.2
+      have hti : p.1 ∈ Set.Ioo (0 : ℝ) 1 := hpC.2
+      constructor
+      · exact fun h => (hnot h).elim
+      · intro h
+        rcases h with h0 | h1
+        · exact (hti.1.ne' h0).elim
+        · exact (hti.2.ne h1).elim
+
+private theorem
+    Smale.exists_strip_along_arc_matching_parametrized_corners {E M D Z Z₀ Z₁ N P : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup Z₀] [NormedSpace ℝ Z₀]
+    [NormedAddCommGroup Z₁] [NormedSpace ℝ Z₁] [TopologicalSpace N] [ChartedSpace D N]
+    [IsManifold 𝓘(ℝ, D) ∞ N] [TopologicalSpace P] [ChartedSpace Z P] [T2Space N] [CompactSpace N]
+    [CompactSpace P] {F : N → M} {G : P → M} {f : ℝ → N} (hF : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ F)
+    (hG : ContMDiff 𝓘(ℝ, Z) 𝓘(ℝ, E) ∞ G) (hembF : Topology.IsEmbedding F)
+    (hiF : ∀ x, Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F x))
+    (hf : ContMDiff 𝓘(ℝ, ℝ) 𝓘(ℝ, D) ∞ f) (hinjf : Set.InjOn f (Set.Icc (0 : ℝ) 1))
+    (hif : ∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Injective (mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, D) f t))
+    (c₀ : PartialDiffeomorph 𝓘(ℝ, Z₀) 𝓘(ℝ, Z) Z₀ P ∞)
+    (c₁ : PartialDiffeomorph 𝓘(ℝ, Z₁) 𝓘(ℝ, Z) Z₁ P ∞) (hc₀ : (0 : Z₀) ∈ c₀.source)
+    (hc₁ : (0 : Z₁) ∈ c₁.source) (hcross₀ : G (c₀ 0) = F (f 0)) (hcross₁ : G (c₁ 0) = F (f 1))
+    (ht₀ :
+      Function.Surjective
+        ((mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F (f 0)).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G (c₀ 0))))
+    (ht₁ :
+      Function.Surjective
+        ((mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F (f 1)).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G (c₁ 0))))
+    (n : ℕ) (hsheet : 1 + n = Module.finrank ℝ D)
+    (hcodim : Module.finrank ℝ D + Module.finrank ℝ Z = Module.finrank ℝ E)
+    (hdimZ : 2 ≤ Module.finrank ℝ Z) {v₀ : Z₀} {v₁ : Z₁} (hv₀ : v₀ ≠ 0) (hv₁ : v₁ ≠ 0)
+    (havoid : ∀ t ∈ Set.Ioo (0 : ℝ) 1, F (f t) ∉ Set.range G) {k₀ k₁ : (ℝ × ℝ) → M}
+    {U₀ U₁ : Set (ℝ × ℝ)} (hk₀ : ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ k₀ U₀)
+    (hk₁ : ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ k₁ U₁) (hU₀ : IsOpen U₀) (hU₁ : IsOpen U₁)
+    (h0U₀ : (0 : ℝ × ℝ) ∈ U₀) (h0U₁ : (0 : ℝ × ℝ) ∈ U₁)
+    (hl₀ : (fun t : ℝ => k₀ (t, 0)) =ᶠ[𝓝 0] (F ∘ f))
+    (hl₁ : (fun t : ℝ => k₁ (t, 0)) =ᶠ[𝓝 0] fun t => F (f (1 - t)))
+    (hr₀ : ∀ s, (0, s) ∈ U₀ → k₀ (0, s) = G (c₀ (s • v₀)))
+    (hr₁ : ∀ s, (0, s) ∈ U₁ → k₁ (0, s) = G (c₁ (s • v₁)))
+    (hcG₀ : ∀ p ∈ U₀, k₀ p ∈ Set.range G ↔ p.1 = 0)
+    (hcG₁ : ∀ p ∈ U₁, k₁ p ∈ Set.range G ↔ p.1 = 0) {O : Set M} (hO : IsOpen O)
+    (hfO : Set.MapsTo (F ∘ f) (Set.Icc (0 : ℝ) 1) O) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∃ W : Set (ℝ × ℝ),
+          IsOpen W ∧
+            Set.Icc (0 : ℝ) 1 ×ˢ Set.Icc (-ε) ε ⊆ W ∧
+              ∃ k : (ℝ × ℝ) → M,
+                ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ k W ∧
+                  Set.InjOn k W ∧
+                    Set.MapsTo k W O ∧
+                      Topology.IsClosedEmbedding
+                          (fun p : Set.Icc (0 : ℝ) 1 ×ˢ Set.Icc (-ε) ε => k p) ∧
+                        (∀ p ∈ W, Function.Injective (mfderiv 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) k p)) ∧
+                          (∀ p ∈ W, k p ∈ Set.range F ↔ p.2 = 0) ∧
+                            (∀ p ∈ W, k p ∈ Set.range G ↔ p.1 = 0 ∨ p.1 = 1) ∧
+                              (∀ t ∈ Set.Icc (0 : ℝ) 1, k (t, 0) = F (f t)) ∧
+                                (k =ᶠ[𝓝 (0, 0)] k₀) ∧
+                                  (k =ᶠ[𝓝 (1, 0)] k₁ ∘ StripCoordinates.reverse) ∧
+                                    Nonempty
+                                      (StripNormalData (EuclideanSpace ℝ (Fin n))
+                                        (EuclideanSpace ℝ (Fin (Module.finrank ℝ Z))) (E := E)
+                                        (Set.range F) k) := by
+  obtain ⟨Φ, hline, htarget, hzero, hclean⟩ :=
+    exists_clean_ambient_chart_along_embedded_arc hF hembF hiF hf hinjf hif n (Module.finrank ℝ Z)
+      hsheet hcodim hO hfO
+  have hline₀ := hline (show (0 : ℝ) ∈ Set.Icc (0 : ℝ) 1 by simp)
+  have hline₁ := hline (show (1 : ℝ) ∈ Set.Icc (0 : ℝ) 1 by simp)
+  have hx₀ : F (f 0) ∈ Φ.target := by
+    have h := Φ.map_source' hline₀
+    rwa [hzero 0 hline₀] at h
+  have hx₁ : F (f 1) ∈ Φ.target := by
+    have h := Φ.map_source' hline₁
+    rwa [hzero 1 hline₁] at h
+  have hdim :
+    Module.finrank ℝ Z = Module.finrank ℝ (EuclideanSpace ℝ (Fin (Module.finrank ℝ Z))) :=
+    finrank_euclideanSpace_fin.symm
+  have hn₀ :=
+    (TransverseCoordinates.corner_normalDerivative_ne_zero Φ hF hG hclean c₀ hc₀ hx₀ hcross₀ ht₀
+        hdim hk₀ hU₀ h0U₀ hv₀ hr₀).1
+  have hn₁ :=
+    (TransverseCoordinates.corner_normalDerivative_ne_zero Φ hF hG hclean c₁ hc₁ hx₁ hcross₁ ht₁
+        hdim hk₁ hU₁ h0U₁ hv₁ hr₁).1
+  let k₁' := k₁ ∘ StripCoordinates.reverse
+  let U₁' := StripCoordinates.reverse ⁻¹' U₁
+  have hU₁' : IsOpen U₁' := hU₁.preimage StripCoordinates.contDiff_reverse.continuous
+  have h1U₁' : (1, 0) ∈ U₁' := by
+    change StripCoordinates.reverse (1, 0) ∈ U₁
+    rw [StripCoordinates.reverse_one_zero]
+    exact h0U₁
+  have hk₁' : ContMDiffOn 𝓘(ℝ, ℝ × ℝ) 𝓘(ℝ, E) ∞ k₁' U₁' :=
+    hk₁.comp StripCoordinates.contDiff_reverse.contMDiff.contMDiffOn (fun _ hp => hp)
+  have hk₁zero : k₁ (0, 0) = F (f 1) := by simpa only [sub_zero] using hl₁.eq_of_nhds
+  have hk₁Phi : k₁ (0, 0) ∈ Φ.target := hk₁zero.symm ▸ hx₁
+  have hnormal :=
+    (TransverseCoordinates.contMDiffOn_normalCoordinate Φ).contMDiffAt
+      (Φ.open_target.mem_nhds hk₁Phi)
+  have hH₁ : DifferentiableAt ℝ (TransverseCoordinates.normalCoordinate Φ ∘ k₁) (0, 0) :=
+    (hnormal.comp (0, 0) (hk₁.contMDiffAt (hU₁.mem_nhds h0U₁))).contDiffAt.differentiableAt
+      (by simp)
+  have hn₁' : fderiv ℝ (TransverseCoordinates.normalCoordinate Φ ∘ k₁') (1, 0) (0, 1) ≠ 0 := by
+    change
+      fderiv ℝ ((TransverseCoordinates.normalCoordinate Φ ∘ k₁) ∘ StripCoordinates.reverse) (1, 0)
+          (0, 1) ≠
+        0
+    rw [StripCoordinates.vertical_derivative_reverse hH₁]
+    exact hn₁
+  have hcenter :
+    Continuous
+      (StripCoordinates.center :
+        ℝ →
+          StripCoordinates.Space (EuclideanSpace ℝ (Fin n))
+            (EuclideanSpace ℝ (Fin (Module.finrank ℝ Z)))) :=
+    (continuous_id.prodMk continuous_const).prodMk continuous_const
+  have hmatch₀ : (fun t : ℝ => k₀ (t, 0)) =ᶠ[𝓝 0] fun t => Φ (StripCoordinates.center t) := by
+    have hsource := hcenter.continuousAt.preimage_mem_nhds (Φ.open_source.mem_nhds hline₀)
+    filter_upwards [hsource, hl₀] with t hs heq
+    exact heq.trans (hzero t hs).symm
+  have hrev : Filter.Tendsto (fun t : ℝ => 1 - t) (𝓝 1) (𝓝 0) := by
+    have he : Filter.Tendsto (fun t : ℝ => 1 - t) (𝓝 1) (𝓝 (1 - 1)) :=
+      (show Continuous (fun t : ℝ => 1 - t) by fun_prop).continuousAt
+    simpa only [sub_self] using he
+  have hmatch₁ : (fun t : ℝ => k₁' (t, 0)) =ᶠ[𝓝 1] fun t => Φ (StripCoordinates.center t) := by
+    have hsource := hcenter.continuousAt.preimage_mem_nhds (Φ.open_source.mem_nhds hline₁)
+    have hleft := hl₁.comp_tendsto hrev
+    filter_upwards [hsource, hleft] with t hs heq
+    change k₁ (1 - t, 0) = Φ (StripCoordinates.center t)
+    change k₁ (1 - t, 0) = F (f (1 - (1 - t))) at heq
+    rw [heq, hzero t hs]
+    congr 2
+    ring
+  obtain ⟨a, ha, V, hV, hrectV, k, hk, hinjk, hmap, _, hik, hcF, hkc, hkk₀, hkk₁, hnormal⟩ :=
+    exists_native_clean_strip_matching_germs Φ hline hclean hk₀ hk₁' hU₀ hU₁' h0U₀ h1U₁' hmatch₀
+      hmatch₁ hn₀ hn₁' (by simpa only [finrank_euclideanSpace_fin] using hdimZ)
+  have hkc' : ∀ t ∈ Set.Icc (0 : ℝ) 1, k (t, 0) = F (f t) := by
+    intro t ht
+    exact (hkc t).trans (hzero t (hline ht))
+  have hKV : Set.Icc (0 : ℝ) 1 ×ˢ {(0 : ℝ)} ⊆ V := by
+    rintro ⟨t, s⟩ ⟨ht, hs⟩
+    have hs0 : s = 0 := hs
+    subst s
+    exact hrectV ⟨ht, ⟨neg_nonpos.mpr ha.le, ha.le⟩⟩
+  have havoidk : ∀ t ∈ Set.Ioo (0 : ℝ) 1, k (t, 0) ∉ Set.range G := by
+    intro t ht
+    rw [hkc' t ⟨ht.1.le, ht.2.le⟩]
+    exact havoid t ht
+  have hcontact₀ : ∀ᶠ p in 𝓝 ((0 : ℝ), (0 : ℝ)), k p ∈ Set.range G ↔ p.1 = 0 := by
+    filter_upwards [hkk₀, hU₀.mem_nhds h0U₀] with p heq hp
+    rw [heq]
+    exact hcG₀ p hp
+  have hcontact₁ : ∀ᶠ p in 𝓝 ((1 : ℝ), (0 : ℝ)), k p ∈ Set.range G ↔ p.1 = 1 := by
+    filter_upwards [hkk₁, hU₁'.mem_nhds h1U₁'] with p heq hp
+    have h : k p ∈ Set.range G ↔ (StripCoordinates.reverse p).1 = 0 := by
+      rw [heq]
+      exact hcG₁ (StripCoordinates.reverse p) hp
+    change (k p ∈ Set.range G ↔ 1 - p.1 = 0) at h
+    rw [sub_eq_zero] at h
+    exact h.trans eq_comm
+  obtain ⟨ε, hε, W, hW, hrectW, hWV, hcG⟩ :=
+    exists_strip_neighborhood_with_exact_endpoint_contacts hk hV hKV
+      (isCompact_range hG.continuous).isClosed havoidk hcontact₀ hcontact₁
+  have hemb : Topology.IsClosedEmbedding (fun p : Set.Icc (0 : ℝ) 1 ×ˢ Set.Icc (-ε) ε => k p) := by
+    let R := Set.Icc (0 : ℝ) 1 ×ˢ Set.Icc (-ε) ε
+    let : CompactSpace R :=
+      isCompact_iff_compactSpace.mp
+        (CompactIccSpace.isCompact_Icc.prod CompactIccSpace.isCompact_Icc)
+    apply
+      (continuousOn_iff_continuous_domRestrict.mp
+          (hk.continuousOn.mono (hrectW.trans hWV))).isClosedEmbedding
+    intro p q hpq
+    exact Subtype.ext (hinjk (hWV (hrectW p.property)) (hWV (hrectW q.property)) hpq)
+  exact
+    ⟨ε, hε, W, hW, hrectW, k, hk.mono hWV, hinjk.mono hWV, fun _ hp => htarget (hmap (hWV hp)),
+      hemb, fun p hp => hik p (hWV hp), fun p hp => hcF p (hWV hp), hcG, hkc', hkk₀, hkk₁,
+      ⟨{  chart := Φ
+          line := hline
+          sheet := hclean
+          center := hkc
+          normal_nonzero := hnormal }⟩⟩
+
+private theorem Smale.exists_cleanStripPatch_of_tubular_arc_corners {E M D Z B N P : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [TopologicalSpace N] [ChartedSpace D N] [IsManifold 𝓘(ℝ, D) ∞ N] [TopologicalSpace P]
+    [ChartedSpace Z P] [T2Space N] [CompactSpace N] [CompactSpace P] {F : N → M} {G : P → M}
+    {f : ℝ → N} {g : ℝ → P} (hF : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ F)
+    (hG : ContMDiff 𝓘(ℝ, Z) 𝓘(ℝ, E) ∞ G) (hembF : Topology.IsEmbedding F)
+    (hiF : ∀ x, Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F x))
+    (hf : ContMDiff 𝓘(ℝ, ℝ) 𝓘(ℝ, D) ∞ f) (hinjf : Set.InjOn f (Set.Icc (0 : ℝ) 1))
+    (hif : ∀ t ∈ Set.Icc (0 : ℝ) 1, Function.Injective (mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, D) f t))
+    (d : PartialDiffeomorph 𝓘(ℝ, ℝ × B) 𝓘(ℝ, Z) (ℝ × B) P ∞) (hd : ∀ t, d (t, 0) = g t)
+    (hd₀ : ((0 : ℝ), (0 : B)) ∈ d.source) (hd₁ : ((1 : ℝ), (0 : B)) ∈ d.source)
+    (hcross₀ : G (g 0) = F (f 0)) (hcross₁ : G (g 1) = F (f 1))
+    (ht₀ :
+      Function.Surjective
+        ((mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F (f 0)).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G (g 0))))
+    (ht₁ :
+      Function.Surjective
+        ((mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F (f 1)).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G (g 1))))
+    (n : ℕ) (hsheet : 1 + n = Module.finrank ℝ D)
+    (hcodim : Module.finrank ℝ D + Module.finrank ℝ Z = Module.finrank ℝ E)
+    (hdimZ : 2 ≤ Module.finrank ℝ Z) (havoid : ∀ t ∈ Set.Ioo (0 : ℝ) 1, F (f t) ∉ Set.range G)
+    (c₀ : CleanCornerPatch (E := E) (Set.range F) (Set.range G) (F ∘ f) (G ∘ g))
+    (c₁ :
+      CleanCornerPatch (E := E) (Set.range F) (Set.range G) (fun t => F (f (1 - t)))
+        (fun t => G (g (1 - t))))
+    {O : Set M} (hO : IsOpen O) (hfO : Set.MapsTo (F ∘ f) (Set.Icc (0 : ℝ) 1) O) :
+    ∃ k : CleanStripPatch (E := E) (Set.range F) (Set.range G) (F ∘ f) c₀.map c₁.map,
+      Nonempty
+          (StripNormalData (EuclideanSpace ℝ (Fin n))
+            (EuclideanSpace ℝ (Fin (Module.finrank ℝ Z))) (E := E) (Set.range F) k.map) ∧
+        Set.MapsTo k.map k.domain O := by
+  let d' := (NativeParametrization.translation ((1 : ℝ), (0 : B))).toPartialDiffeomorph.trans d
+  have hd'₀ : (0 : ℝ × B) ∈ d'.source := by
+    refine ⟨Set.mem_univ _, ?_⟩
+    change 0 + ((1 : ℝ), (0 : B)) ∈ d.source
+    rw [zero_add]
+    exact hd₁
+  have hd0 : d (0 : ℝ × B) = g 0 := hd 0
+  have hd1 : d' (0 : ℝ × B) = g 1 := by
+    change d (0 + ((1 : ℝ), (0 : B))) = g 1
+    rw [zero_add, hd]
+  have hcross₀' : G (d 0) = F (f 0) := by rw [hd0]; exact hcross₀
+  have hcross₁' : G (d' 0) = F (f 1) := by rw [hd1]; exact hcross₁
+  have ht₀' :
+    Function.Surjective
+      ((mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F (f 0)).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G (d 0))) := by
+    rw [hd0]; exact ht₀
+  have ht₁' :
+    Function.Surjective
+      ((mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F (f 1)).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G (d' 0))) := by
+    rw [hd1]; exact ht₁
+  have hv₀ : ((1 : ℝ), (0 : B)) ≠ 0 := fun he => one_ne_zero (congrArg Prod.fst he)
+  have hv₁ : ((-1 : ℝ), (0 : B)) ≠ 0 := by
+    intro he
+    have he' : (-1 : ℝ) = 0 := congrArg Prod.fst he
+    norm_num at he'
+  have hleft₀ : (fun t : ℝ => c₀.map (t, 0)) =ᶠ[𝓝 0] (F ∘ f) := by
+    have haxis :=
+      (continuous_id.prodMk continuous_const).continuousAt.preimage_mem_nhds
+        (c₀.open_domain.mem_nhds c₀.contains_zero)
+    filter_upwards [haxis] with t ht
+    exact c₀.axis_first t ht
+  have hleft₁ : (fun t : ℝ => c₁.map (t, 0)) =ᶠ[𝓝 0] fun t => F (f (1 - t)) := by
+    have haxis :=
+      (continuous_id.prodMk continuous_const).continuousAt.preimage_mem_nhds
+        (c₁.open_domain.mem_nhds c₁.contains_zero)
+    filter_upwards [haxis] with t ht
+    exact c₁.axis_first t ht
+  have hcurve₀ (s : ℝ) : d (s • ((1 : ℝ), (0 : B))) = g s := by
+    simpa only [Prod.smul_mk, smul_eq_mul, mul_one, smul_zero] using hd s
+  have hcurve₁ (s : ℝ) : d' (s • ((-1 : ℝ), (0 : B))) = g (1 - s) := by
+    change d (s • ((-1 : ℝ), (0 : B)) + (1, 0)) = g (1 - s)
+    have he : s • ((-1 : ℝ), (0 : B)) + (1, 0) = (1 - s, 0) := by
+      simp [smul_eq_mul, sub_eq_add_neg, add_comm]
+    rw [he, hd]
+  obtain
+    ⟨ε, hε, W, hW, hrect, k, hk, hinj, hmap, hemb, hi, hfirst, hsecond, hcenter, hleft, hright,
+      hnormal⟩ :=
+    exists_strip_along_arc_matching_parametrized_corners hF hG hembF hiF hf hinjf hif d d' hd₀
+      hd'₀ hcross₀' hcross₁' ht₀' ht₁' n hsheet hcodim hdimZ hv₀ hv₁ havoid c₀.smooth c₁.smooth
+      c₀.open_domain c₁.open_domain c₀.contains_zero c₁.contains_zero hleft₀ hleft₁
+      (fun s hs => (c₀.axis_second s hs).trans (congrArg G (hcurve₀ s).symm))
+      (fun s hs => (c₁.axis_second s hs).trans (congrArg G (hcurve₁ s).symm))
+      (fun p hp => (c₀.sheets p hp).2) (fun p hp => (c₁.sheets p hp).2) hO hfO
+  let strip : CleanStripPatch (E := E) (Set.range F) (Set.range G) (F ∘ f) c₀.map c₁.map :=
+    { width := ε, width_pos := hε, domain := W, open_domain := hW, contains_strip := hrect,
+      map := k, smooth := hk, injective := hinj, closed_embedding := hemb,
+      derivative_injective := hi, first_sheet := hfirst, second_sheet := hsecond,
+      center := hcenter, left_germ := hleft, right_germ := hright }
+  exact ⟨strip, hnormal, hmap⟩
+
+private theorem
+    Smale.exists_open_neighborhoods_with_coincidences_in {X Y M : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] [TopologicalSpace M] [T2Space M] {K : Set X} {L : Set Y}
+    (hK : IsCompact K) (hL : IsCompact L) {f : X → M} {g : Y → M} (hf : ∀ x ∈ K, ContinuousAt f x)
+    (hg : ∀ y ∈ L, ContinuousAt g y) {O : Set (X × Y)} (hO : IsOpen O)
+    (hcoinc : ∀ x ∈ K, ∀ y ∈ L, f x = g y → (x, y) ∈ O) :
+    ∃ U : Set X,
+      ∃ V : Set Y,
+        IsOpen U ∧ IsOpen V ∧ K ⊆ U ∧ L ⊆ V ∧ ∀ x ∈ U, ∀ y ∈ V, f x = g y → (x, y) ∈ O := by
+  let R : Set (X × Y) := {p | f p.1 ≠ g p.2} ∪ O
+  have hKR : K ×ˢ L ⊆ interior R := by
+    rintro ⟨x, y⟩ ⟨hx, hy⟩
+    apply mem_interior_iff_mem_nhds.mpr
+    by_cases hxy : f x = g y
+    · exact Filter.mem_of_superset (hO.mem_nhds (hcoinc x hx y hy hxy)) (fun _ hp => Or.inr hp)
+    · have hfc : ContinuousAt (fun p : X × Y => f p.1) (x, y) := (hf x hx).comp continuousAt_fst
+      have hgc : ContinuousAt (fun p : X × Y => g p.2) (x, y) := (hg y hy).comp continuousAt_snd
+      have hne : ∀ᶠ p : X × Y in 𝓝 (x, y), f p.1 ≠ g p.2 := (hfc.ne_iff_eventually_ne hgc).mp hxy
+      exact Filter.mem_of_superset hne (fun _ hp => Or.inl hp)
+  obtain ⟨U, V, hU, hV, hKU, hLV, hUV⟩ := generalized_tube_lemma hK hL isOpen_interior hKR
+  refine ⟨U, V, hU, hV, hKU, hLV, ?_⟩
+  intro x hx y hy hxy
+  exact (interior_subset (hUV ⟨hx, hy⟩)).resolve_left (fun hne => hne hxy)
+
+private theorem Smale.exists_open_corner_overlap {X Y D M : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] [TopologicalSpace D] {k : X → M} {l : Y → M} {c : D → M} {a : X → D}
+    {b : Y → D} {x₀ : X} {y₀ : Y} {W : Set D} (hW : IsOpen W) (hc : Set.InjOn c W)
+    (ha : ContinuousAt a x₀) (hb : ContinuousAt b y₀) (haW : a x₀ ∈ W) (hbW : b y₀ ∈ W)
+    (hk : k =ᶠ[𝓝 x₀] c ∘ a) (hl : l =ᶠ[𝓝 y₀] c ∘ b) :
+    ∃ U : Set X,
+      ∃ V : Set Y,
+        IsOpen U ∧ IsOpen V ∧ x₀ ∈ U ∧ y₀ ∈ V ∧ ∀ x ∈ U, ∀ y ∈ V, k x = l y ↔ a x = b y := by
+  obtain ⟨U, hUsub, hU, hxU⟩ := mem_nhds_iff.mp (hk.and (ha.preimage_mem_nhds (hW.mem_nhds haW)))
+  obtain ⟨V, hVsub, hV, hyV⟩ := mem_nhds_iff.mp (hl.and (hb.preimage_mem_nhds (hW.mem_nhds hbW)))
+  refine ⟨U, V, hU, hV, hxU, hyV, ?_⟩
+  intro x hx y hy
+  obtain ⟨hkx, hax⟩ := hUsub hx
+  obtain ⟨hly, hby⟩ := hVsub hy
+  rw [hkx, hly]
+  exact ⟨hc hax hby, congrArg c⟩
+
+private theorem Smale.exists_clean_strip_pair_neighborhoods {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M] {S T : Set M}
+    {a b a₀ b₀ a₁ b₁ : ℝ → M} (c₀ : CleanCornerPatch (E := E) S T a₀ b₀)
+    (c₁ : CleanCornerPatch (E := E) S T a₁ b₁) (k : CleanStripPatch (E := E) S T a c₀.map c₁.map)
+    (l : CleanStripPatch (E := E) T S b c₀.swap.map c₁.swap.map)
+    (hcoinc :
+      ∀ t ∈ Set.Icc (0 : ℝ) 1,
+        ∀ s ∈ Set.Icc (0 : ℝ) 1, a t = b s → (t = 0 ∧ s = 0) ∨ (t = 1 ∧ s = 1)) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∃ δ : ℝ,
+          0 < δ ∧
+            ∃ U : Set (ℝ × ℝ),
+              ∃ V : Set (ℝ × ℝ),
+                IsOpen U ∧
+                  IsOpen V ∧
+                    Set.Icc (0 : ℝ) 1 ×ˢ Set.Icc (-ε) ε ⊆ U ∧
+                      Set.Icc (0 : ℝ) 1 ×ˢ Set.Icc (-δ) δ ⊆ V ∧
+                        U ⊆ k.domain ∧
+                          V ⊆ l.domain ∧
+                            ∀ p ∈ U,
+                              ∀ q ∈ V,
+                                k.map p = l.map q →
+                                  p = q.swap ∨
+                                    StripCoordinates.reverse p =
+                                      (StripCoordinates.reverse q).swap := by
+  have hswap : Continuous (Prod.swap : (ℝ × ℝ) → ℝ × ℝ) := by fun_prop
+  have hrev := StripCoordinates.contDiff_reverse.continuous
+  obtain ⟨U₀, V₀, hU₀, hV₀, h0U₀, h0V₀, hover₀⟩ :=
+    exists_open_corner_overlap c₀.open_domain c₀.injective
+      (continuousAt_id : ContinuousAt (id : (ℝ × ℝ) → ℝ × ℝ) (0, 0))
+      (hswap.continuousAt (x := (0, 0))) c₀.contains_zero c₀.contains_zero k.left_germ l.left_germ
+  obtain ⟨U₁, V₁, hU₁, hV₁, h1U₁, h1V₁, hover₁⟩ :=
+    exists_open_corner_overlap c₁.open_domain c₁.injective (hrev.continuousAt (x := (1, 0)))
+      ((hswap.comp hrev).continuousAt (x := (1, 0)))
+      (by rw [StripCoordinates.reverse_one_zero]; exact c₁.contains_zero)
+      (by
+        change (StripCoordinates.reverse (1, 0)).swap ∈ c₁.domain
+        rw [StripCoordinates.reverse_one_zero]; exact c₁.contains_zero)
+      k.right_germ l.right_germ
+  let K : Set (ℝ × ℝ) := Set.Icc (0 : ℝ) 1 ×ˢ {(0 : ℝ)}
+  have hK : IsCompact K := CompactIccSpace.isCompact_Icc.prod isCompact_singleton
+  have hKk : K ⊆ k.domain := by
+    rintro ⟨t, s⟩ ⟨ht, hs⟩
+    have hs0 : s = 0 := hs
+    subst s
+    exact k.contains_strip ⟨ht, neg_nonpos.mpr k.width_pos.le, k.width_pos.le⟩
+  have hKl : K ⊆ l.domain := by
+    rintro ⟨t, s⟩ ⟨ht, hs⟩
+    have hs0 : s = 0 := hs
+    subst s
+    exact l.contains_strip ⟨ht, neg_nonpos.mpr l.width_pos.le, l.width_pos.le⟩
+  have hk : ∀ p ∈ K, ContinuousAt k.map p := fun p hp =>
+    k.smooth.continuousOn.continuousAt (k.open_domain.mem_nhds (hKk hp))
+  have hl : ∀ p ∈ K, ContinuousAt l.map p := fun p hp =>
+    l.smooth.continuousOn.continuousAt (l.open_domain.mem_nhds (hKl hp))
+  let O := (U₀ ×ˢ V₀) ∪ (U₁ ×ˢ V₁)
+  have hO : IsOpen O := (hU₀.prod hV₀).union (hU₁.prod hV₁)
+  have hcenter : ∀ p ∈ K, ∀ q ∈ K, k.map p = l.map q → (p, q) ∈ O := by
+    rintro ⟨t, r⟩ ⟨ht, hr⟩ ⟨s, v⟩ ⟨hs, hv⟩ heq
+    have hr0 : r = 0 := hr
+    have hv0 : v = 0 := hv
+    subst r
+    subst v
+    rw [k.center t ht, l.center s hs] at heq
+    rcases hcoinc t ht s hs heq with ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩
+    · exact Or.inl ⟨h0U₀, h0V₀⟩
+    · exact Or.inr ⟨h1U₁, h1V₁⟩
+  obtain ⟨U', V', hU', hV', hKU', hKV', hcoinc'⟩ :=
+    exists_open_neighborhoods_with_coincidences_in hK hK hk hl hO hcenter
+  let U := U' ∩ k.domain
+  let V := V' ∩ l.domain
+  have hU : IsOpen U := hU'.inter k.open_domain
+  have hV : IsOpen V := hV'.inter l.open_domain
+  have hKU : K ⊆ U := fun p hp => ⟨hKU' hp, hKk hp⟩
+  have hKV : K ⊆ V := fun p hp => ⟨hKV' hp, hKl hp⟩
+  obtain ⟨ε, hε, hεU⟩ :=
+    DiskFraming.exists_pos_prod_closedBall_subset CompactIccSpace.isCompact_Icc hU hKU
+  obtain ⟨δ, hδ, hδV⟩ :=
+    DiskFraming.exists_pos_prod_closedBall_subset CompactIccSpace.isCompact_Icc hV hKV
+  have hrect {r : ℝ} {W : Set (ℝ × ℝ)} (h : Set.Icc (0 : ℝ) 1 ×ˢ Metric.closedBall 0 r ⊆ W) :
+    Set.Icc (0 : ℝ) 1 ×ˢ Set.Icc (-r) r ⊆ W := by
+    rintro ⟨t, s⟩ ⟨ht, hs⟩
+    apply h
+    refine ⟨ht, ?_⟩
+    simpa only [Metric.mem_closedBall, dist_zero_right, Real.norm_eq_abs] using abs_le.mpr hs
+  refine
+    ⟨ε, hε, δ, hδ, U, V, hU, hV, hrect hεU, hrect hδV, Set.inter_subset_right,
+      Set.inter_subset_right, ?_⟩
+  intro p hp q hq heq
+  rcases hcoinc' p hp.1 q hq.1 heq with hleft | hright
+  · exact Or.inl ((hover₀ p hleft.1 q hleft.2).mp heq)
+  · exact Or.inr ((hover₁ p hright.1 q hright.2).mp heq)
+
+private def Smale.CleanStripPatch.restrict {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [T2Space M] {S T : Set M} {a : ℝ → M}
+    {k₀ k₁ : (ℝ × ℝ) → M} (k : Smale.CleanStripPatch (E := E) S T a k₀ k₁) {ε : ℝ} (hε : 0 < ε)
+    {U : Set (ℝ × ℝ)} (hU : IsOpen U) (hrect : Set.Icc (0 : ℝ) 1 ×ˢ Set.Icc (-ε) ε ⊆ U)
+    (hUk : U ⊆ k.domain) : Smale.CleanStripPatch (E := E) S T a k₀ k₁ := by
+  refine
+    { width := ε
+      width_pos := hε
+      domain := U
+      open_domain := hU
+      contains_strip := hrect
+      map := k.map
+      smooth := k.smooth.mono hUk
+      injective := k.injective.mono hUk
+      closed_embedding := ?_
+      derivative_injective := fun p hp => k.derivative_injective p (hUk hp)
+      first_sheet := fun p hp => k.first_sheet p (hUk hp)
+      second_sheet := fun p hp => k.second_sheet p (hUk hp)
+      center := k.center
+      left_germ := k.left_germ
+      right_germ := k.right_germ }
+  let R := Set.Icc (0 : ℝ) 1 ×ˢ Set.Icc (-ε) ε
+  let : CompactSpace R :=
+    isCompact_iff_compactSpace.mp
+      (CompactIccSpace.isCompact_Icc.prod CompactIccSpace.isCompact_Icc)
+  have hc : Continuous (fun p : R => k.map p) :=
+    continuousOn_iff_continuous_domRestrict.mp (k.smooth.continuousOn.mono (hrect.trans hUk))
+  apply hc.isClosedEmbedding
+  intro p q hpq
+  exact Subtype.ext (k.injective (hUk (hrect p.property)) (hUk (hrect q.property)) hpq)
+
+private theorem Smale.exists_native_shared_corner_strip_pair_dim_two {E M D Z N P : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [TopologicalSpace N] [ChartedSpace D N]
+    [IsManifold 𝓘(ℝ, D) ∞ N] [TopologicalSpace P] [ChartedSpace Z P] [IsManifold 𝓘(ℝ, Z) ∞ P]
+    [T2Space N] [CompactSpace N] [T2Space P] [CompactSpace P] {F : N → M} {G : P → M}
+    (hF : ContMDiff 𝓘(ℝ, D) 𝓘(ℝ, E) ∞ F) (hG : ContMDiff 𝓘(ℝ, Z) 𝓘(ℝ, E) ∞ G)
+    (hinjF : Function.Injective F) (hinjG : Function.Injective G)
+    (hiF : ∀ x, Function.Injective (mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F x))
+    (hiG : ∀ y, Function.Injective (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G y)) (hdimD : 2 ≤ Module.finrank ℝ D)
+    (hdimZ : 2 ≤ Module.finrank ℝ Z)
+    (hcodim : Module.finrank ℝ D + Module.finrank ℝ Z = Module.finrank ℝ E)
+    (ht :
+      ∀ x y,
+        G y = F x →
+          Function.Surjective
+            ((mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F x).coprod (mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G y)))
+    {x₀ x₁ : N} {y₀ y₁ : P} (hcross₀ : G y₀ = F x₀) (hcross₁ : G y₁ = F x₁) (hxy : x₀ ≠ x₁)
+    (γ : Path x₀ x₁) (η : Path y₀ y₁) :
+    ∃ f : C(ℝ, N),
+      ∃ g : C(ℝ, P),
+        ContMDiff 𝓘(ℝ, ℝ) 𝓘(ℝ, D) ∞ f ∧
+          ContMDiff 𝓘(ℝ, ℝ) 𝓘(ℝ, Z) ∞ g ∧
+            f 0 = x₀ ∧
+              f 1 = x₁ ∧
+                g 0 = y₀ ∧
+                  g 1 = y₁ ∧
+                    Topology.IsClosedEmbedding (fun t : unitInterval => f t) ∧
+                      Topology.IsClosedEmbedding (fun t : unitInterval => g t) ∧
+                        (∀ t ∈ Set.Icc (0 : ℝ) 1,
+                            Function.Injective (mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, D) f t)) ∧
+                          (∀ t ∈ Set.Icc (0 : ℝ) 1,
+                              Function.Injective (mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, Z) g t)) ∧
+                            (∀ t ∈ Set.Ioo (0 : ℝ) 1, F (f t) ∉ Set.range G) ∧
+                              (∀ t ∈ Set.Ioo (0 : ℝ) 1, G (g t) ∉ Set.range F) ∧
+                                Set.range (fun t : unitInterval => F (f t)) ∩
+                                      Set.range (fun t : unitInterval => G (g t)) =
+                                    {F x₀, F x₁} ∧
+                                  ∃ c₀ :
+                                    CleanCornerPatch (E := E) (Set.range F) (Set.range G) (F ∘ f)
+                                      (G ∘ g),
+                                    ∃ c₁ :
+                                      CleanCornerPatch (E := E) (Set.range F) (Set.range G)
+                                        (fun t => F (f (1 - t))) (fun t => G (g (1 - t))),
+                                      ∃ k :
+                                        CleanStripPatch (E := E) (Set.range F) (Set.range G)
+                                          (F ∘ f) c₀.map c₁.map,
+                                        ∃ l :
+                                          CleanStripPatch (E := E) (Set.range G) (Set.range F)
+                                            (G ∘ g) c₀.swap.map c₁.swap.map,
+                                          Nonempty
+                                              (StripNormalData
+                                                (EuclideanSpace ℝ (Fin (Module.finrank ℝ D - 1)))
+                                                (EuclideanSpace ℝ (Fin (Module.finrank ℝ Z)))
+                                                (E := E) (Set.range F) k.map) ∧
+                                            Nonempty
+                                                (StripNormalData
+                                                  (EuclideanSpace ℝ
+                                                    (Fin (Module.finrank ℝ Z - 1)))
+                                                  (EuclideanSpace ℝ (Fin (Module.finrank ℝ D)))
+                                                  (E := E) (Set.range G) l.map) ∧
+                                              (∀ p ∈ k.domain,
+                                                  ∀ q ∈ l.domain,
+                                                    k.map p = l.map q →
+                                                      p = q.swap ∨
+                                                        StripCoordinates.reverse p =
+                                                          (StripCoordinates.reverse q).swap) ∧
+                                                ∀ h : ℝ,
+                                                  0 < h →
+                                                    Nonempty
+                                                      (CleanBigonBoundary (E := E) (Set.range F)
+                                                        (Set.range G) (F ∘ f) (G ∘ g) k.map l.map
+                                                        h) := by
+  have hfinite : (Set.range F ∩ Set.range G).Finite :=
+    finite_transverse_intersections hF hG hinjF hinjG hcodim ht
+  have hSF : (F ⁻¹' Set.range G).Finite := by
+    have hpre : F ⁻¹' (Set.range F ∩ Set.range G) = F ⁻¹' Set.range G := by
+      ext z
+      simp only [Set.mem_preimage, Set.mem_inter_iff]
+      exact and_iff_right (Set.mem_range_self z)
+    rw [← hpre]
+    exact hfinite.preimage hinjF.injOn
+  have hSG : (G ⁻¹' Set.range F).Finite := by
+    have hpre : G ⁻¹' (Set.range F ∩ Set.range G) = G ⁻¹' Set.range F := by
+      ext z
+      simp only [Set.mem_preimage, Set.mem_inter_iff]
+      exact and_iff_left (Set.mem_range_self z)
+    rw [← hpre]
+    exact hfinite.preimage hinjG.injOn
+  have hy : y₀ ≠ y₁ := by
+    intro heq
+    apply hxy
+    exact hinjF (hcross₀.symm.trans ((congrArg G heq).trans hcross₁))
+  obtain ⟨f, hf, hf0, hf1, hembf, hif, havoidf, ρ, hρ, c, hsourceC, hzeroC, _⟩ :=
+    exists_tubular_connecting_arc_avoiding_finite_with_global_zero γ hxy hdimD
+      (Module.finrank ℝ D - 1) (by omega) hSF
+  obtain ⟨g, hg, hg0, hg1, hembg, hig, havoidg, σ, hσ, d, hsourceD, hzeroD, _⟩ :=
+    exists_tubular_connecting_arc_avoiding_finite_with_global_zero η hy hdimZ
+      (Module.finrank ℝ Z - 1) (by omega) hSG
+  have hinjf : Set.InjOn f (Set.Icc (0 : ℝ) 1) := by
+    intro t ht s hs heq
+    exact congrArg Subtype.val (hembf.injective (a₁ := ⟨t, ht⟩) (a₂ := ⟨s, hs⟩) heq)
+  have hinjg : Set.InjOn g (Set.Icc (0 : ℝ) 1) := by
+    intro t ht s hs heq
+    exact congrArg Subtype.val (hembg.injective (a₁ := ⟨t, ht⟩) (a₂ := ⟨s, hs⟩) heq)
+  have hinter :
+    Set.range (fun t : unitInterval => F (f t)) ∩ Set.range (fun t : unitInterval => G (g t)) =
+      {F x₀, F x₁} := by
+    ext w
+    constructor
+    · rintro ⟨⟨t, rfl⟩, ⟨s, hs⟩⟩
+      by_cases ht0 : (t : ℝ) = 0
+      · simp only [ht0, hf0]
+        exact Set.mem_insert _ _
+      by_cases ht1 : (t : ℝ) = 1
+      · simp only [ht1, hf1]
+        exact Set.mem_insert_of_mem _ (Set.mem_singleton _)
+      have hti : (t : ℝ) ∈ Set.Ioo (0 : ℝ) 1 :=
+        ⟨lt_of_le_of_ne t.property.1 (Ne.symm ht0), lt_of_le_of_ne t.property.2 ht1⟩
+      exact (havoidf t hti ⟨g s, hs⟩).elim
+    · intro hw
+      simp only [Set.mem_insert_iff, Set.mem_singleton_iff] at hw
+      rcases hw with rfl | rfl
+      · exact ⟨⟨0, congrArg F hf0⟩, ⟨0, (congrArg G hg0).trans hcross₀⟩⟩
+      · exact ⟨⟨1, congrArg F hf1⟩, ⟨1, (congrArg G hg1).trans hcross₁⟩⟩
+  have hembF := (hF.continuous.isClosedEmbedding hinjF).isEmbedding
+  have hembG := (hG.continuous.isClosedEmbedding hinjG).isEmbedding
+  have hc₀ : ((0 : ℝ), (0 : EuclideanSpace ℝ (Fin (Module.finrank ℝ D - 1)))) ∈ c.source :=
+    hsourceC ⟨by simp, Metric.mem_closedBall_self hρ.le⟩
+  have hc₁ : ((1 : ℝ), (0 : EuclideanSpace ℝ (Fin (Module.finrank ℝ D - 1)))) ∈ c.source :=
+    hsourceC ⟨by simp, Metric.mem_closedBall_self hρ.le⟩
+  have hd₀ : ((0 : ℝ), (0 : EuclideanSpace ℝ (Fin (Module.finrank ℝ Z - 1)))) ∈ d.source :=
+    hsourceD ⟨by simp, Metric.mem_closedBall_self hσ.le⟩
+  have hd₁ : ((1 : ℝ), (0 : EuclideanSpace ℝ (Fin (Module.finrank ℝ Z - 1)))) ∈ d.source :=
+    hsourceD ⟨by simp, Metric.mem_closedBall_self hσ.le⟩
+  have hcross₀' : G (g 0) = F (f 0) := by rw [hf0, hg0]; exact hcross₀
+  have hcross₁' : G (g 1) = F (f 1) := by rw [hf1, hg1]; exact hcross₁
+  have ht₀ := ht (f 0) (g 0) hcross₀'
+  have ht₁ := ht (f 1) (g 1) hcross₁'
+  have hcoord :
+    Module.finrank ℝ (ℝ × EuclideanSpace ℝ (Fin (Module.finrank ℝ D - 1))) +
+        Module.finrank ℝ (ℝ × EuclideanSpace ℝ (Fin (Module.finrank ℝ Z - 1))) =
+      Module.finrank ℝ E := by
+    simp only [Module.finrank_prod, Module.finrank_self, finrank_euclideanSpace_fin]
+    omega
+  have hcorner₀ :
+    Nonempty (CleanCornerPatch (E := E) (Set.range F) (Set.range G) (F ∘ f) (G ∘ g)) := by
+    simpa only [zero_add, mul_one, Function.comp_def] using
+      nonempty_cleanCornerPatch_of_tubular_arcs hF hG hembF hembG c d hzeroC hzeroD hc₀ hd₀
+        hcross₀' hcoord ht₀ (σ := 1) (τ := 1) one_ne_zero one_ne_zero
+  have hcorner₁ :
+    Nonempty
+      (CleanCornerPatch (E := E) (Set.range F) (Set.range G) (fun t => F (f (1 - t)))
+        (fun t => G (g (1 - t)))) := by
+    simpa only [mul_neg_one, ← sub_eq_add_neg] using
+      nonempty_cleanCornerPatch_of_tubular_arcs hF hG hembF hembG c d hzeroC hzeroD hc₁ hd₁
+        hcross₁' hcoord ht₁ (σ := -1) (τ := -1) (by norm_num) (by norm_num)
+  obtain ⟨c₀⟩ := hcorner₀
+  obtain ⟨c₁⟩ := hcorner₁
+  obtain ⟨stripF, hnormalF, _⟩ :=
+    exists_cleanStripPatch_of_tubular_arc_corners hF hG hembF hiF hf hinjf hif d hzeroD hd₀ hd₁
+      hcross₀' hcross₁' ht₀ ht₁ (Module.finrank ℝ D - 1) (by omega) hcodim hdimZ havoidf c₀ c₁
+      isOpen_univ (fun _ _ => Set.mem_univ _)
+  let DF₀ : D →L[ℝ] E := mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F (f 0)
+  let DF₁ : D →L[ℝ] E := mfderiv 𝓘(ℝ, D) 𝓘(ℝ, E) F (f 1)
+  let DG₀ : Z →L[ℝ] E := mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G (g 0)
+  let DG₁ : Z →L[ℝ] E := mfderiv 𝓘(ℝ, Z) 𝓘(ℝ, E) G (g 1)
+  have ht₀' : Function.Surjective (DG₀.coprod DF₀) :=
+    TransverseCoordinates.surjective_coprod_swap DF₀ DG₀ ht₀
+  have ht₁' : Function.Surjective (DG₁.coprod DF₁) :=
+    TransverseCoordinates.surjective_coprod_swap DF₁ DG₁ ht₁
+  have hcodim' : Module.finrank ℝ Z + Module.finrank ℝ D = Module.finrank ℝ E := by omega
+  obtain ⟨stripG, hnormalG, _⟩ :=
+    exists_cleanStripPatch_of_tubular_arc_corners hG hF hembG hiG hg hinjg hig c hzeroC hc₀ hc₁
+      hcross₀'.symm hcross₁'.symm ht₀' ht₁' (Module.finrank ℝ Z - 1) (by omega) hcodim' hdimD
+      havoidg c₀.swap c₁.swap isOpen_univ (fun _ _ => Set.mem_univ _)
+  have hcoinc :
+    ∀ t ∈ Set.Icc (0 : ℝ) 1,
+      ∀ s ∈ Set.Icc (0 : ℝ) 1, (F ∘ f) t = (G ∘ g) s → (t = 0 ∧ s = 0) ∨ (t = 1 ∧ s = 1) := by
+    intro t ht s hs heq
+    have hmem : F (f t) ∈ ({F x₀, F x₁} : Set M) := by
+      rw [← hinter]
+      exact ⟨⟨⟨t, ht⟩, rfl⟩, ⟨⟨s, hs⟩, heq.symm⟩⟩
+    change F (f t) = F x₀ ∨ F (f t) = F x₁ at hmem
+    have h0 : (0 : ℝ) ∈ Set.Icc 0 1 := ⟨le_rfl, zero_le_one⟩
+    have h1 : (1 : ℝ) ∈ Set.Icc 0 1 := ⟨zero_le_one, le_rfl⟩
+    rcases hmem with hleft | hright
+    · left
+      constructor
+      · exact hinjf ht h0 (hinjF (hleft.trans (congrArg F hf0).symm))
+      · apply hinjg hs h0
+        apply hinjG
+        exact heq.symm.trans (hleft.trans ((congrArg G hg0).trans hcross₀).symm)
+    · right
+      constructor
+      · exact hinjf ht h1 (hinjF (hright.trans (congrArg F hf1).symm))
+      · apply hinjg hs h1
+        apply hinjG
+        exact heq.symm.trans (hright.trans ((congrArg G hg1).trans hcross₁).symm)
+  obtain ⟨ε', hε', δ', hδ', U', V', hU', hV', hrectU', hrectV', hU'sub, hV'sub, hoverlap⟩ :=
+    exists_clean_strip_pair_neighborhoods c₀ c₁ stripF stripG hcoinc
+  let k' := stripF.restrict hε' hU' hrectU' hU'sub
+  let l' := stripG.restrict hδ' hV' hrectV' hV'sub
+  have hoverlap' :
+    ∀ p ∈ k'.domain,
+      ∀ q ∈ l'.domain,
+        k'.map p = l'.map q →
+          p = q.swap ∨ StripCoordinates.reverse p = (StripCoordinates.reverse q).swap :=
+    hoverlap
+  refine
+    ⟨f, g, hf, hg, hf0, hf1, hg0, hg1, hembf, hembg, hif, hig, havoidf, havoidg, hinter, c₀, c₁,
+      k', l', hnormalF, hnormalG, hoverlap', ?_⟩
+  intro h hh
+  exact nonempty_cleanBigonBoundary hh c₀ c₁ k' l' hoverlap'
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.nonempty_belt_tubularBigon {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 2)
+    (hnull :
+      ∀ g : C(Smale.Hemisphere.Sphere 1, d.LowerLevel),
+        ∃ q, g.Homotopic (ContinuousMap.const _ q))
+    (g : C(Smale.Hemisphere.Sphere 2, d.UpperLevel)) :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    ∀ (_hg : ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g) {a b : ℝ → d.UpperLevel}
+      {k l : (ℝ × ℝ) → d.UpperLevel} {h : ℝ},
+      Smale.CleanBigonBoundary (E := Smale.RegularLevel.Model E) (Set.range g)
+          (Set.range d.surgery.beltSphere) a b k l h →
+        Nonempty
+          (Smale.TubularBigon (E := Smale.RegularLevel.Model E) (Set.range g)
+            (Set.range d.surgery.beltSphere) a b k l h 3) := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  let _ := Smale.RegularLevel.isManifold hf d.upper_regular
+  let _ : CompactSpace d.UpperLevel :=
+    isCompact_iff_compactSpace.mp (isClosed_eq hf.continuous continuous_const).isCompact
+  intro hg a b k l h B
+  have hT : IsClosed (Set.range d.surgery.beltSphere) := d.belt_isClosedEmbedding.isClosed_range
+  have hnullbelt :=
+    d.chart.surgery_beltComplement_circle_nullhomotopies hf d.radius d.radius_pos d.block
+      d.lower_regular d.surgery d.oldPiece_eq hindex (by omega) hnull
+  exact
+    B.nonempty_tubularBigon_of_complement_contractions g hg hT hnullbelt
+      (by simp [Smale.RegularLevel.Model, hdim]) (by simp [Smale.RegularLevel.Model, hdim]) 3
+      (by simp [Smale.RegularLevel.Model, hdim])
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.exists_belt_tubular_strip_pair {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (hindex : Module.finrank ℝ d.chart.NegativeCoordinates = 2)
+    (hnull :
+      ∀ g : C(Smale.Hemisphere.Sphere 1, d.LowerLevel),
+        ∃ q, g.Homotopic (ContinuousMap.const _ q))
+    (g : C(Smale.Hemisphere.Sphere 2, d.UpperLevel)) :
+    letI := Smale.RegularLevel.chartedSpace hf d.upper_regular
+    letI : Fact (Module.finrank ℝ d.chart.PositiveCoordinates = 3 + 1) :=
+      ⟨by have hh := d.chart.finrank_negative_add_positive; omega⟩
+    ∀ (_hg : ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g) (_hinj : Function.Injective g)
+      (_hi : ∀ x, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) g x))
+      (_ht :
+        ∀ x y,
+          d.surgery.beltSphere y = g x →
+            Function.Surjective
+              ((mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) g x).coprod
+                (mfderiv (𝓡 3) 𝓘(ℝ, Smale.RegularLevel.Model E) d.surgery.beltSphere y)))
+      (x₀ x₁ : Smale.Hemisphere.Sphere 2)
+      (y₀ y₁ : Smale.PuncturedHandle.UnitSphere d.chart.PositiveCoordinates),
+      d.surgery.beltSphere y₀ = g x₀ →
+        d.surgery.beltSphere y₁ = g x₁ →
+          x₀ ≠ x₁ →
+            ∃ a b : ℝ → d.UpperLevel,
+              a 0 = g x₀ ∧
+                a 1 = g x₁ ∧
+                  b 0 = g x₀ ∧
+                    b 1 = g x₁ ∧
+                      ∃ k₀ k₁ l₀ l₁ : (ℝ × ℝ) → d.UpperLevel,
+                        ∃ k :
+                          Smale.CleanStripPatch (E := Smale.RegularLevel.Model E) (Set.range g)
+                            (Set.range d.surgery.beltSphere) a k₀ k₁,
+                          ∃ l :
+                            Smale.CleanStripPatch (E := Smale.RegularLevel.Model E)
+                              (Set.range d.surgery.beltSphere) (Set.range g) b l₀ l₁,
+                            Nonempty
+                                (Smale.StripNormalData (EuclideanSpace ℝ (Fin 1))
+                                  (EuclideanSpace ℝ (Fin 3)) (E := Smale.RegularLevel.Model E)
+                                  (Set.range g) k.map) ∧
+                              Nonempty
+                                  (Smale.StripNormalData (EuclideanSpace ℝ (Fin 2))
+                                    (EuclideanSpace ℝ (Fin 2)) (E := Smale.RegularLevel.Model E)
+                                    (Set.range d.surgery.beltSphere) l.map) ∧
+                                ∀ h : ℝ,
+                                  0 < h →
+                                    Nonempty
+                                      (Smale.TubularBigon (E := Smale.RegularLevel.Model E)
+                                        (Set.range g) (Set.range d.surgery.beltSphere) a b k.map
+                                        l.map h 3) := by
+  let _ := Smale.RegularLevel.chartedSpace hf d.upper_regular
+  let _ := Smale.RegularLevel.isManifold hf d.upper_regular
+  let _ : CompactSpace d.UpperLevel :=
+    isCompact_iff_compactSpace.mp (isClosed_eq hf.continuous continuous_const).isCompact
+  have hpos : Module.finrank ℝ d.chart.PositiveCoordinates = 3 + 1 := by
+    have hh := d.chart.finrank_negative_add_positive
+    omega
+  let _ : Fact (Module.finrank ℝ d.chart.PositiveCoordinates = 3 + 1) := ⟨hpos⟩
+  intro hg hinj hi ht x₀ x₁ y₀ y₁ hcross₀ hcross₁ hxy
+  have hpath₂ : IsPathConnected (Metric.sphere (0 : EuclideanSpace ℝ (Fin 3)) 1) :=
+    isPathConnected_sphere (by simp [← Module.finrank_eq_rank]) 0 (by norm_num)
+  have hpath₃ : IsPathConnected (Metric.sphere (0 : d.chart.PositiveCoordinates) 1) :=
+    isPathConnected_sphere (by rw [← Module.finrank_eq_rank, hpos]; norm_num) 0 (by norm_num)
+  let γ : Path x₀ x₁ := (hpath₂.joinedIn x₀ x₀.property x₁ x₁.property).joined_subtype.somePath
+  let η : Path y₀ y₁ := (hpath₃.joinedIn y₀ y₀.property y₁ y₁.property).joined_subtype.somePath
+  have hG := d.belt_smooth hf 3
+  have hiG := d.belt_derivative_injective hf 3
+  obtain
+    ⟨α, β, -, -, hα₀, hα₁, hβ₀, hβ₁, -, -, -, -, -, -, -, c₀, c₁, k, l, hnK, hnL, -, hboundary⟩ :=
+    Smale.exists_native_shared_corner_strip_pair_dim_two hg hG hinj
+      d.belt_isClosedEmbedding.injective hi hiG (by simp) (by simp)
+      (by simp [Smale.RegularLevel.Model, hdim]) ht hcross₀ hcross₁ hxy γ η
+  refine
+    ⟨g ∘ α, d.surgery.beltSphere ∘ β, ?_, ?_, ?_, ?_, c₀.map, c₁.map, c₀.swap.map, c₁.swap.map, k,
+      l, ?_, ?_, ?_⟩
+  · change g (α 0) = g x₀
+    rw [hα₀]
+  · change g (α 1) = g x₁
+    rw [hα₁]
+  · change d.surgery.beltSphere (β 0) = g x₀
+    rw [hβ₀, hcross₀]
+  · change d.surgery.beltSphere (β 1) = g x₁
+    rw [hβ₁, hcross₁]
+  · have transport (m n : ℕ) (hm : Module.finrank ℝ (EuclideanSpace ℝ (Fin 2)) - 1 = m)
+      (hn : Module.finrank ℝ (EuclideanSpace ℝ (Fin 3)) = n) :
+      Nonempty
+        (Smale.StripNormalData (EuclideanSpace ℝ (Fin m)) (EuclideanSpace ℝ (Fin n)) (E :=
+          Smale.RegularLevel.Model E) (Set.range g) k.map) := by
+      subst m
+      subst n
+      exact hnK
+    exact transport 1 3 (by simp) (by simp)
+  · have transport (m n : ℕ) (hm : Module.finrank ℝ (EuclideanSpace ℝ (Fin 3)) - 1 = m)
+      (hn : Module.finrank ℝ (EuclideanSpace ℝ (Fin 2)) = n) :
+      Nonempty
+        (Smale.StripNormalData (EuclideanSpace ℝ (Fin m)) (EuclideanSpace ℝ (Fin n)) (E :=
+          Smale.RegularLevel.Model E) (Set.range d.surgery.beltSphere) l.map) := by
+      subst m
+      subst n
+      exact hnL
+    exact transport 2 2 (by simp) (by simp)
+  · intro h hh
+    obtain ⟨B⟩ := hboundary h hh
+    exact d.nonempty_belt_tubularBigon hf hdim hindex hnull g hg B
+
+private def Smale.FiberRestriction.embed {X U V : Type*} [NormedAddCommGroup X] [NormedSpace ℝ X]
+    [NormedAddCommGroup U] [NormedSpace ℝ U] [NormedAddCommGroup V] [NormedSpace ℝ V]
+    (i : U →L[ℝ] V) : (X × U) →L[ℝ] (X × V) :=
+  (ContinuousLinearMap.id ℝ X).prodMap i
+
+private def Smale.FiberRestriction.project {X U V : Type*} [NormedAddCommGroup X] [NormedSpace ℝ X]
+    [NormedAddCommGroup U] [NormedSpace ℝ U] [NormedAddCommGroup V] [NormedSpace ℝ V]
+    (r : V →L[ℝ] U) : (X × V) →L[ℝ] (X × U) :=
+  (ContinuousLinearMap.id ℝ X).prodMap r
+
+private theorem Smale.FiberRestriction.project_embed {X U V : Type*} [NormedAddCommGroup X]
+    [NormedSpace ℝ X] [NormedAddCommGroup U] [NormedSpace ℝ U] [NormedAddCommGroup V]
+    [NormedSpace ℝ V] (i : U →L[ℝ] V) (r : V →L[ℝ] U) (hi : Function.LeftInverse r i)
+    (z : X × U) : project r (embed i z) = z :=
+  Prod.ext rfl (hi z.2)
+
+private theorem
+    Smale.FiberRestriction.embed_project_of_normal {X U V : Type*} [NormedAddCommGroup X]
+    [NormedSpace ℝ X] [NormedAddCommGroup U] [NormedSpace ℝ U] [NormedAddCommGroup V]
+    [NormedSpace ℝ V] (i : U →L[ℝ] V) (r : V →L[ℝ] U) (hi : Function.LeftInverse r i) {z : X × V}
+    {w : X × U} (hz : z.2 = i w.2) : embed i (project r z) = z := by
+  apply Prod.ext
+  · rfl
+  · change i (r z.2) = z.2
+    rw [hz, hi]
+
+private def Smale.FiberRestriction.restrict {X U V : Type*} [NormedAddCommGroup X] [NormedSpace ℝ X]
+    [NormedAddCommGroup U] [NormedSpace ℝ U] [NormedAddCommGroup V] [NormedSpace ℝ V]
+    (i : U →L[ℝ] V) (r : V →L[ℝ] U) (hi : Function.LeftInverse r i)
+    (d : Diffeomorph 𝓘(ℝ, X × V) 𝓘(ℝ, X × V) (X × V) (X × V) ∞) (hnormal : ∀ z, (d z).2 = z.2) :
+    Diffeomorph 𝓘(ℝ, X × U) 𝓘(ℝ, X × U) (X × U) (X × U) ∞
+    where
+  toEquiv :=
+    { toFun := fun z => project r (d (embed i z))
+      invFun := fun z => project r (d.symm (embed i z))
+      left_inv := by
+        intro z
+        have hfix := embed_project_of_normal i r hi (w := z) (hnormal (embed i z))
+        change project r (d.symm (embed i (project r (d (embed i z))))) = z
+        rw [hfix, d.symm_apply_apply, project_embed i r hi]
+      right_inv := by
+        intro z
+        have hnormalInv : (d.symm (embed i z)).2 = i z.2 := by
+          have he := hnormal (d.symm (embed i z))
+          rw [d.apply_symm_apply] at he
+          exact he.symm
+        have hfix := embed_project_of_normal i r hi (w := z) hnormalInv
+        change project r (d (embed i (project r (d.symm (embed i z))))) = z
+        rw [hfix, d.apply_symm_apply, project_embed i r hi] }
+  contMDiff_toFun := by
+    change ContMDiff 𝓘(ℝ, X × U) 𝓘(ℝ, X × U) ∞ (fun z => project r (d (embed i z)))
+    exact (project r).contDiff.contMDiff.comp (d.contMDiff.comp (embed i).contDiff.contMDiff)
+  contMDiff_invFun := by
+    change ContMDiff 𝓘(ℝ, X × U) 𝓘(ℝ, X × U) ∞ (fun z => project r (d.symm (embed i z)))
+    exact (project r).contDiff.contMDiff.comp (d.symm.contMDiff.comp (embed i).contDiff.contMDiff)
+
+private theorem Smale.SmallPerturbation.lipschitzWith_slice {E : Type*} [NormedAddCommGroup E]
+    {β : ℝ × E → ℝ} {k : ℝ≥0} (hβ : LipschitzWith k β) (t : ℝ) :
+    LipschitzWith k (fun x : E => β (t, x)) := by
+  apply LipschitzWith.of_dist_le_mul
+  intro x y
+  calc
+    Dist.dist (β (t, x)) (β (t, y)) ≤ (k : ℝ) * Dist.dist (t, x) (t, y) := hβ.dist_le_mul _ _
+    _ = (k : ℝ) * Dist.dist x y := by
+      rw [Prod.dist_eq, dist_self, max_eq_right (dist_nonneg : 0 ≤ Dist.dist x y)]
+
+private theorem Smale.SmallPerturbation.exists_uniform_radius_bumpTranslation {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] {β : ℝ × E → ℝ}
+    (hs : ContDiff ℝ ∞ β) (hcompact : HasCompactSupport β) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∀ t : ℝ,
+          ∀ a : E,
+            ‖a‖ < ε →
+              ∃ d : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞,
+                (∀ x, d x = x + β (t, x) • a) ∧ ∀ x ∉ tsupport (fun y : E => β (t, y)), d x = x :=
+  by
+  obtain ⟨k, hk⟩ := ContDiff.lipschitzWith_of_hasCompactSupport hcompact hs (by simp)
+  have hkpos : 0 < (k : ℝ) + 1 := by positivity
+  refine ⟨((k : ℝ) + 1)⁻¹, inv_pos.mpr hkpos, ?_⟩
+  intro t a ha
+  have hmul : ((k : ℝ) + 1) * ‖a‖ < 1 := by
+    calc
+      ((k : ℝ) + 1) * ‖a‖ < ((k : ℝ) + 1) * ((k : ℝ) + 1)⁻¹ := mul_lt_mul_of_pos_left ha hkpos
+      _ = 1 := mul_inv_cancel₀ hkpos.ne'
+  have hsmall : k * ‖a‖₊ < 1 := by
+    have hr : (k : ℝ) * ‖a‖ < 1 := by nlinarith [norm_nonneg a]
+    exact hr
+  have hslice : ContDiff ℝ ∞ (fun x : E => β (t, x)) :=
+    hs.comp (contDiff_const.prodMk contDiff_id)
+  refine ⟨bumpTranslation hslice (lipschitzWith_slice hk t) a hsmall, fun _ => rfl, ?_⟩
+  intro x hx
+  apply bumpTranslation_eq_of_zero
+  by_contra hne
+  exact hx (subset_tsupport (fun y : E => β (t, y)) hne)
+
+private def Smale.SmallPerturbation.composeFamily {E : Type*} (B : ℕ → ℝ × E → E) : ℕ → ℝ × E → E
+  | 0, p => p.2
+  | n + 1, p => B n (p.1, composeFamily B n p)
+
+private theorem Smale.SmallPerturbation.contDiff_composeFamily {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {B : ℕ → ℝ × E → E} (hB : ∀ i, ContDiff ℝ ∞ (B i)) (n : ℕ) :
+    ContDiff ℝ ∞ (composeFamily B n) := by
+  induction n with
+  | zero => exact contDiff_snd
+  | succ n ih => exact (hB n).comp (contDiff_fst.prodMk ih)
+
+private theorem Smale.SmallPerturbation.composeFamily_zero {E : Type*} {B : ℕ → ℝ × E → E}
+    (hB : ∀ i x, B i (0, x) = x) (n : ℕ) (x : E) : composeFamily B n (0, x) = x := by
+  induction n with
+  | zero => rfl
+  | succ n ih => exact (hB n _).trans ih
+
+private theorem
+    Smale.SmallPerturbation.composeFamily_fixed {E : Type*} {B : ℕ → ℝ × E → E} {C : Set E}
+    (hB : ∀ i t x, x ∉ C → B i (t, x) = x) (n : ℕ) (t : ℝ) {x : E} (hx : x ∉ C) :
+    composeFamily B n (t, x) = x := by
+  induction n with
+  | zero => rfl
+  | succ n ih =>
+    change B n (t, composeFamily B n (t, x)) = x
+    rw [ih]
+    exact hB n t x hx
+
+private theorem Smale.SmallPerturbation.composeFamily_preserves {E : Type*} {F : Type*}
+    {B : ℕ → ℝ × E → E} {f : E → F} (hB : ∀ i t x, f (B i (t, x)) = f x) (n : ℕ) (t : ℝ) (x : E) :
+    f (composeFamily B n (t, x)) = f x := by
+  induction n with
+  | zero => rfl
+  | succ n ih => exact (hB n t _).trans ih
+
+private theorem Smale.SmallPerturbation.exists_diffeomorph_composeFamily {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] {B : ℕ → ℝ × E → E}
+    (hB : ∀ i t, ∃ d : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞, ∀ x, d x = B i (t, x)) (n : ℕ) (t : ℝ) :
+    ∃ d : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) E E ∞, ∀ x, d x = composeFamily B n (t, x) := by
+  induction n with
+  | zero => exact ⟨Diffeomorph.refl 𝓘(ℝ, E) E ∞, fun _ => rfl⟩
+  | succ n ih =>
+    obtain ⟨d, hd⟩ := ih
+    obtain ⟨e, he⟩ := hB n t
+    refine ⟨d.trans e, ?_⟩
+    intro x
+    change e (d x) = B n (t, composeFamily B n (t, x))
+    rw [he, hd]
+
+private def Smale.WhitneyPairModel.scaledBigonEmbedding (r : ℝ) (p : ℝ × ℝ) : Space :=
+  bigonEmbedding (r * p.1, r ^ 2 * p.2)
+
+private theorem Smale.WhitneyPairModel.scaledBigonEmbedding_one (p : ℝ × ℝ) :
+    scaledBigonEmbedding 1 p = bigonEmbedding p := by
+  simp only [scaledBigonEmbedding, one_mul, one_pow, Prod.eta]
+
+private theorem Smale.WhitneyPairModel.continuous_scaledBigonEmbedding :
+    Continuous (fun z : ℝ × (ℝ × ℝ) => scaledBigonEmbedding z.1 z.2) := by
+  unfold scaledBigonEmbedding bigonEmbedding
+  fun_prop
+
+private theorem
+    Smale.WhitneyPairModel.exists_scaled_bigon_in_open {h : ℝ} (hh : 0 < h) {U : Set Space}
+    (hU : IsOpen U) (hKU : Set.MapsTo bigonEmbedding (bigon h) U) :
+    ∃ r : ℝ, 1 < r ∧ Set.MapsTo (scaledBigonEmbedding r) (bigon h) U := by
+  have hnear : ∀ᶠ r in 𝓝 (1 : ℝ), ∀ p ∈ bigon h, scaledBigonEmbedding r p ∈ U := by
+    apply (isCompact_bigon hh).eventually_forall_of_forall_eventually
+    intro p hp
+    apply (continuous_scaledBigonEmbedding.continuousAt (x := (1, p))).preimage_mem_nhds
+    apply hU.mem_nhds
+    simpa only [scaledBigonEmbedding_one] using hKU hp
+  obtain ⟨ε, hε, hball⟩ := Metric.mem_nhds_iff.mp hnear
+  have hrball : (1 + ε / 2 : ℝ) ∈ Metric.ball 1 ε := by
+    change Dist.dist (1 + ε / 2) 1 < ε
+    rw [Real.dist_eq]
+    have heq : 1 + ε / 2 - 1 = ε / 2 := by ring
+    rw [heq, abs_of_pos (half_pos hε)]
+    exact half_lt_self hε
+  exact ⟨1 + ε / 2, by linarith, fun p hp => hball hrball p hp⟩
+
+private theorem
+    Smale.WhitneyPairModel.enlarged_cap_parametrization {h r : ℝ} (hr : 0 < r) {p : ℝ × ℝ}
+    (hp : 0 ≤ p.2 ∧ h * p.1 ^ 2 + p.2 ≤ h * r ^ 2) :
+    ∃ q ∈ bigon h, scaledBigonEmbedding r q = bigonEmbedding p := by
+  let q : ℝ × ℝ := (p.1 / r, p.2 / r ^ 2)
+  have hr2 : 0 < r ^ 2 := sq_pos_of_pos hr
+  have hcalc : h * (p.1 / r) ^ 2 + p.2 / r ^ 2 = (h * p.1 ^ 2 + p.2) / r ^ 2 := by field_simp
+  have hq : q ∈ bigon h := by
+    refine ⟨div_nonneg hp.1 hr2.le, ?_⟩
+    change h * (p.1 / r) ^ 2 + p.2 / r ^ 2 ≤ h
+    rw [hcalc]
+    exact (div_le_iff₀ hr2).mpr hp.2
+  refine ⟨q, hq, ?_⟩
+  apply congrArg bigonEmbedding
+  apply Prod.ext
+  · change r * (p.1 / r) = p.1
+    field_simp
+  · change r ^ 2 * (p.2 / r ^ 2) = p.2
+    field_simp
+
+private def Smale.WhitneyPairModel.verticalGraph (B : ℝ → ℝ) (t s : ℝ) : Space :=
+  ((s, t * B s), 0)
+
+private theorem
+    Smale.WhitneyPairModel.exists_supported_graph_height {h : ℝ} (hh : 0 < h) {U : Set Space}
+    (hU : IsOpen U) (hKU : Set.MapsTo bigonEmbedding (bigon h) U) :
+    ∃ B : ℝ → ℝ,
+      ContDiff ℝ ∞ B ∧
+        HasCompactSupport B ∧
+          (∀ s, 0 ≤ B s) ∧
+            (∀ s, |s| ≤ 1 → h * (1 - s ^ 2) < B s) ∧
+              ∀ t ∈ Set.Icc (0 : ℝ) 1, ∀ s ∈ tsupport B, verticalGraph B t s ∈ U := by
+  obtain ⟨r, hr, hscaled⟩ := exists_scaled_bigon_in_open hh hU hKU
+  have hrpos : 0 < r := lt_trans zero_lt_one hr
+  let α : ContDiffBump (0 : ℝ) :=
+    { rIn := 1
+      rOut := r
+      rIn_pos := zero_lt_one
+      rIn_lt_rOut := hr }
+  let B : ℝ → ℝ := fun s => α s * (h * (r ^ 2 - s ^ 2))
+  have hB : ContDiff ℝ ∞ B := α.contDiff.mul (by fun_prop)
+  have hcompact : HasCompactSupport B := α.hasCompactSupport.mul_right
+  have hsupp : tsupport B ⊆ tsupport (α : ℝ → ℝ) := by
+    apply closure_mono
+    intro s hs hα
+    apply hs
+    change α s * (h * (r ^ 2 - s ^ 2)) = 0
+    rw [hα, MulZeroClass.zero_mul]
+  have hbound : ∀ s ∈ tsupport B, |s| ≤ r := by
+    intro s hs
+    have hx := hsupp hs
+    rw [α.tsupport_eq] at hx
+    change Dist.dist s 0 ≤ r at hx
+    simpa only [Real.dist_eq, sub_zero] using hx
+  have hheight {s : ℝ} (hs : |s| ≤ r) : 0 ≤ h * (r ^ 2 - s ^ 2) := by
+    have hsq : s ^ 2 ≤ r ^ 2 := by
+      simpa only [sq_abs] using (sq_le_sq₀ (abs_nonneg s) hrpos.le).mpr hs
+    exact mul_nonneg hh.le (sub_nonneg.mpr hsq)
+  have hnonneg : ∀ s, 0 ≤ B s := by
+    intro s
+    by_cases hs : α s = 0
+    · simp only [B, hs, MulZeroClass.zero_mul, le_refl]
+    have hmem : s ∈ Function.support α := hs
+    rw [α.support_eq] at hmem
+    have hsr : |s| ≤ r := by
+      have hl : |s| < r := by simpa only [Metric.mem_ball, Real.dist_eq, sub_zero] using hmem
+      exact hl.le
+    exact mul_nonneg α.nonneg (hheight hsr)
+  refine ⟨B, hB, hcompact, hnonneg, ?_, ?_⟩
+  · intro s hs
+    have hα : α s = 1 :=
+      α.one_of_mem_closedBall
+        (by
+          change Dist.dist s 0 ≤ 1
+          simpa only [Real.dist_eq, sub_zero] using hs)
+    change h * (1 - s ^ 2) < α s * (h * (r ^ 2 - s ^ 2))
+    rw [hα, one_mul]
+    have hgap : 0 < h * (r ^ 2 - 1) := mul_pos hh (by nlinarith [sq_nonneg (r - 1)])
+    nlinarith
+  · intro t ht s hs
+    have hts : t * α s ≤ 1 := by
+      calc
+        t * α s ≤ 1 * α s := mul_le_mul_of_nonneg_right ht.2 α.nonneg
+        _ ≤ 1 := by simpa only [one_mul] using (α.le_one (x := s))
+    have hy : t * B s ≤ h * (r ^ 2 - s ^ 2) := by
+      calc
+        t * B s = (t * α s) * (h * (r ^ 2 - s ^ 2)) := by dsimp [B]; ring
+        _ ≤ h * (r ^ 2 - s ^ 2) := mul_le_of_le_one_left (hheight (hbound s hs)) hts
+    have hcap : 0 ≤ t * B s ∧ h * s ^ 2 + t * B s ≤ h * r ^ 2 :=
+      ⟨mul_nonneg ht.1 (hnonneg s), by nlinarith⟩
+    obtain ⟨q, hq, heq⟩ := enlarged_cap_parametrization (h := h) (p := (s, t * B s)) hrpos hcap
+    have hmem := hscaled hq
+    rw [heq] at hmem
+    exact hmem
+
+private def Smale.WhitneyPairModel.graphTrace (B : ℝ → ℝ) : Set (ℝ × Space) :=
+  (fun p : ℝ × ℝ => (p.1, verticalGraph B p.1 p.2)) '' (Set.Icc (0 : ℝ) 1 ×ˢ tsupport B)
+
+private theorem Smale.WhitneyPairModel.isCompact_graphTrace {B : ℝ → ℝ} (hB : Continuous B)
+    (hcompact : HasCompactSupport B) : IsCompact (graphTrace B) := by
+  apply (CompactIccSpace.isCompact_Icc.prod hcompact.isCompact).image
+  unfold verticalGraph
+  fun_prop
+
+private theorem Smale.WhitneyPairModel.exists_graph_motion_cutoff {B : ℝ → ℝ} (hB : ContDiff ℝ ∞ B)
+    (hcompact : HasCompactSupport B) (hnonneg : ∀ s, 0 ≤ B s) {U : Set Space} (hU : IsOpen U)
+    (htrace : ∀ t ∈ Set.Icc (0 : ℝ) 1, ∀ s ∈ tsupport B, verticalGraph B t s ∈ U) :
+    ∃ β : ℝ × Space → ℝ,
+      ContDiff ℝ ∞ β ∧
+        HasCompactSupport β ∧
+          tsupport β ⊆ Prod.snd ⁻¹' U ∧
+            (∀ p, 0 ≤ β p) ∧ ∀ t ∈ Set.Icc (0 : ℝ) 1, ∀ s : ℝ, β (t, verticalGraph B t s) = B s :=
+  by
+  have hCU : graphTrace B ⊆ Prod.snd ⁻¹' U := by
+    rintro _ ⟨p, hp, rfl⟩
+    exact htrace p.1 hp.1 p.2 hp.2
+  obtain ⟨η, hη, hηcompact, hηsupport, hηone, hηrange⟩ :=
+    Smale.exists_compact_smooth_cutoff (isCompact_graphTrace hB.continuous hcompact)
+      (hU.preimage continuous_snd) hCU
+  let β : ℝ × Space → ℝ := fun p => η p * B p.2.1.1
+  have hβ : ContDiff ℝ ∞ β := hη.mul (hB.comp (by fun_prop))
+  have hβcompact : HasCompactSupport β := hηcompact.mul_right
+  have hsupp : tsupport β ⊆ tsupport η := by
+    apply closure_mono
+    intro p hp hηp
+    apply hp
+    change η p * B p.2.1.1 = 0
+    rw [hηp, MulZeroClass.zero_mul]
+  refine
+    ⟨β, hβ, hβcompact, hsupp.trans hηsupport, fun p => mul_nonneg (hηrange p).1 (hnonneg _), ?_⟩
+  intro t ht s
+  by_cases hs : B s = 0
+  · change η (t, verticalGraph B t s) * B s = B s
+    rw [hs, MulZeroClass.mul_zero]
+  have hpoint : (t, verticalGraph B t s) ∈ graphTrace B :=
+    ⟨(t, s), ⟨ht, subset_tsupport B hs⟩, rfl⟩
+  have hηpoint : η (t, verticalGraph B t s) = 1 := hηone.self_of_nhdsSet _ hpoint
+  change η (t, verticalGraph B t s) * B s = B s
+  rw [hηpoint, one_mul]
+
+private structure Smale.WhitneyPairModel.GraphMotionData (h : ℝ) (U : Set Space) where
+  height : ℝ → ℝ
+  smooth_height : ContDiff ℝ ∞ height
+  compact_height : HasCompactSupport height
+  nonneg_height : ∀ s, 0 ≤ height s
+  above : ∀ s, |s| ≤ 1 → h * (1 - s ^ 2) < height s
+  trace_source : ∀ t ∈ Set.Icc (0 : ℝ) 1, ∀ s ∈ tsupport height, verticalGraph height t s ∈ U
+  cutoff : ℝ × Space → ℝ
+  smooth_cutoff : ContDiff ℝ ∞ cutoff
+  compact_cutoff : HasCompactSupport cutoff
+  support_cutoff : tsupport cutoff ⊆ Prod.snd ⁻¹' U
+  nonneg_cutoff : ∀ p, 0 ≤ cutoff p
+  tracking : ∀ t ∈ Set.Icc (0 : ℝ) 1, ∀ s, cutoff (t, verticalGraph height t s) = height s
+
+private theorem Smale.WhitneyPairModel.nonempty_graphMotionData {h : ℝ} (hh : 0 < h) {U : Set Space}
+    (hU : IsOpen U) (hKU : Set.MapsTo bigonEmbedding (bigon h) U) :
+    Nonempty (GraphMotionData h U) := by
+  obtain ⟨B, hB, hcompact, hnonneg, habove, htrace⟩ := exists_supported_graph_height hh hU hKU
+  obtain ⟨β, hβ, hβcompact, hβsupport, hβnonneg, hβtrack⟩ :=
+    exists_graph_motion_cutoff hB hcompact hnonneg hU htrace
+  exact
+    ⟨{  height := B
+        smooth_height := hB
+        compact_height := hcompact
+        nonneg_height := hnonneg
+        above := habove
+        trace_source := htrace
+        cutoff := β
+        smooth_cutoff := hβ
+        compact_cutoff := hβcompact
+        support_cutoff := hβsupport
+        nonneg_cutoff := hβnonneg
+        tracking := hβtrack }⟩
+
+private def Smale.WhitneyPairModel.verticalVector (δ : ℝ) : Space :=
+  ((0, δ), 0)
+
+private theorem Smale.WhitneyPairModel.norm_verticalVector {δ : ℝ} (hδ : 0 ≤ δ) :
+    ‖verticalVector δ‖ = δ := by
+  simp [verticalVector, Prod.norm_def, Real.norm_eq_abs, abs_of_nonneg hδ, hδ]
+
+private def Smale.WhitneyPairModel.graphStep (β : ℝ × Space → ℝ) (δ : ℝ) (i : ℕ) (p : ℝ × Space) :
+    Space :=
+  p.2 + β ((i : ℝ) * δ, p.2) • (Real.smoothTransition p.1 • verticalVector δ)
+
+private theorem Smale.WhitneyPairModel.contDiff_graphStep {β : ℝ × Space → ℝ} (hβ : ContDiff ℝ ∞ β)
+    (δ : ℝ) (i : ℕ) : ContDiff ℝ ∞ (graphStep β δ i) := by
+  have hθ : ContDiff ℝ ∞ Real.smoothTransition := Real.smoothTransition.contDiff
+  exact
+    contDiff_snd.add
+      ((hβ.comp (contDiff_const.prodMk contDiff_snd)).smul
+        ((hθ.comp contDiff_fst).smul contDiff_const))
+
+private theorem
+    Smale.WhitneyPairModel.graphStep_zero (β : ℝ × Space → ℝ) (δ : ℝ) (i : ℕ) (z : Space) :
+    graphStep β δ i (0, z) = z := by
+  simp only [graphStep, Real.smoothTransition.zero, zero_smul, smul_zero, add_zero]
+
+private theorem
+    Smale.WhitneyPairModel.graphStep_horizontal (β : ℝ × Space → ℝ) (δ : ℝ) (i : ℕ) (t : ℝ)
+    (z : Space) : (graphStep β δ i (t, z)).1.1 = z.1.1 := by simp [graphStep, verticalVector]
+
+private theorem Smale.WhitneyPairModel.graphStep_normal (β : ℝ × Space → ℝ) (δ : ℝ) (i : ℕ) (t : ℝ)
+    (z : Space) : (graphStep β δ i (t, z)).2 = z.2 := by simp [graphStep, verticalVector]
+
+private theorem Smale.WhitneyPairModel.graphStep_fixed (β : ℝ × Space → ℝ) (δ : ℝ) (i : ℕ) (t : ℝ)
+    {z : Space} (hz : z ∉ Prod.snd '' tsupport β) : graphStep β δ i (t, z) = z := by
+  have hzero : β ((i : ℝ) * δ, z) = 0 := by
+    by_contra hne
+    exact hz ⟨((i : ℝ) * δ, z), subset_tsupport β hne, rfl⟩
+  simp only [graphStep, hzero, zero_smul, add_zero]
+
+private theorem
+    Smale.WhitneyPairModel.exists_radius_graphStep {β : ℝ × Space → ℝ} (hβ : ContDiff ℝ ∞ β)
+    (hcompact : HasCompactSupport β) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∀ δ : ℝ,
+          0 ≤ δ →
+            δ < ε →
+              ∀ i : ℕ,
+                ∀ t : ℝ,
+                  ∃ d : Diffeomorph 𝓘(ℝ, Space) 𝓘(ℝ, Space) Space Space ∞,
+                    ∀ z, d z = graphStep β δ i (t, z) := by
+  obtain ⟨ε, hε, hsmall⟩ :=
+    Smale.SmallPerturbation.exists_uniform_radius_bumpTranslation hβ hcompact
+  refine ⟨ε, hε, ?_⟩
+  intro δ hδ hδε i t
+  have hnorm : ‖Real.smoothTransition t • verticalVector δ‖ ≤ δ := by
+    rw [norm_smul, norm_verticalVector hδ, Real.norm_eq_abs,
+      abs_of_nonneg (Real.smoothTransition.nonneg t)]
+    exact mul_le_of_le_one_left hδ (Real.smoothTransition.le_one t)
+  obtain ⟨d, hd, _⟩ :=
+    hsmall ((i : ℝ) * δ) (Real.smoothTransition t • verticalVector δ) (hnorm.trans_lt hδε)
+  exact ⟨d, hd⟩
+
+private theorem Smale.WhitneyPairModel.graphStep_tracking {h : ℝ} {U : Set Space}
+    (g : GraphMotionData h U) {δ : ℝ} {i : ℕ} (hi : (i : ℝ) * δ ∈ Set.Icc (0 : ℝ) 1) (s : ℝ) :
+    graphStep g.cutoff δ i (1, verticalGraph g.height ((i : ℝ) * δ) s) =
+      verticalGraph g.height (((i : ℝ) + 1) * δ) s := by
+  rw [graphStep, g.tracking _ hi, Real.smoothTransition.one, one_smul]
+  ext <;> simp [verticalGraph, verticalVector, smul_eq_mul]
+  ring
+
+private structure Smale.WhitneyPairModel.GraphMotion {h : ℝ} {U : Set Space}
+    (g : GraphMotionData h U) where
+  support : Set Space
+  compact_support : IsCompact support
+  support_subset : support ⊆ U
+  family : ℝ × Space → Space
+  smooth : ContDiff ℝ ∞ family
+  initial : ∀ z, family (0, z) = z
+  diffeomorph :
+    ∀ t, ∃ d : Diffeomorph 𝓘(ℝ, Space) 𝓘(ℝ, Space) Space Space ∞, ∀ z, d z = family (t, z)
+  fixed : ∀ t z, z ∉ support → family (t, z) = z
+  horizontal : ∀ t z, (family (t, z)).1.1 = z.1.1
+  normal : ∀ t z, (family (t, z)).2 = z.2
+  tracking : ∀ s, family (1, firstSheet (s, 0)) = verticalGraph g.height 1 s
+
+private theorem Smale.WhitneyPairModel.GraphMotionData.nonempty_graphMotion {h : ℝ}
+    {U : Set Smale.WhitneyPairModel.Space} (g : Smale.WhitneyPairModel.GraphMotionData h U) :
+    Nonempty (Smale.WhitneyPairModel.GraphMotion g) := by
+  obtain ⟨ε, hε, hsmall⟩ :=
+    Smale.WhitneyPairModel.exists_radius_graphStep g.smooth_cutoff g.compact_cutoff
+  obtain ⟨N, hN, hNsmall⟩ := Real.exists_nat_pos_inv_lt hε
+  let δ : ℝ := (N : ℝ)⁻¹
+  have hNreal : 0 < (N : ℝ) := Nat.cast_pos.mpr hN
+  have hδ : 0 ≤ δ := (inv_pos.mpr hNreal).le
+  have htotal : (N : ℝ) * δ = 1 := mul_inv_cancel₀ hNreal.ne'
+  let B : ℕ → ℝ × Smale.WhitneyPairModel.Space → Smale.WhitneyPairModel.Space :=
+    Smale.WhitneyPairModel.graphStep g.cutoff δ
+  let A : ℝ × Smale.WhitneyPairModel.Space → Smale.WhitneyPairModel.Space :=
+    Smale.SmallPerturbation.composeFamily B N
+  have htrack :
+    ∀ j ≤ N,
+      ∀ s,
+        Smale.SmallPerturbation.composeFamily B j (1, Smale.WhitneyPairModel.firstSheet (s, 0)) =
+          Smale.WhitneyPairModel.verticalGraph g.height ((j : ℝ) * δ) s := by
+    intro j
+    induction j with
+    | zero =>
+      intro _ s
+      simp [Smale.SmallPerturbation.composeFamily, Smale.WhitneyPairModel.firstSheet,
+        Smale.WhitneyPairModel.verticalGraph]
+    | succ j ih =>
+      intro hj s
+      have hjN : j ≤ N := Nat.le_of_succ_le hj
+      have htime : (j : ℝ) * δ ∈ Set.Icc (0 : ℝ) 1 := by
+        refine ⟨mul_nonneg (Nat.cast_nonneg j) hδ, ?_⟩
+        calc
+          (j : ℝ) * δ ≤ (N : ℝ) * δ := mul_le_mul_of_nonneg_right (Nat.cast_le.mpr hjN) hδ
+          _ = 1 := htotal
+      change
+        Smale.WhitneyPairModel.graphStep g.cutoff δ j
+            (1,
+              Smale.SmallPerturbation.composeFamily B j
+                (1, Smale.WhitneyPairModel.firstSheet (s, 0))) =
+          _
+      rw [ih hjN s, Smale.WhitneyPairModel.graphStep_tracking g htime s, Nat.cast_add,
+        Nat.cast_one]
+  refine
+    ⟨{  support := Prod.snd '' tsupport g.cutoff
+        compact_support := g.compact_cutoff.isCompact.image continuous_snd
+        support_subset := ?_
+        family := A
+        smooth :=
+          Smale.SmallPerturbation.contDiff_composeFamily
+            (fun i => Smale.WhitneyPairModel.contDiff_graphStep g.smooth_cutoff δ i) N
+        initial :=
+          Smale.SmallPerturbation.composeFamily_zero
+            (Smale.WhitneyPairModel.graphStep_zero g.cutoff δ) N
+        diffeomorph :=
+          Smale.SmallPerturbation.exists_diffeomorph_composeFamily (hsmall δ hδ hNsmall) N
+        fixed := fun t z hz =>
+          Smale.SmallPerturbation.composeFamily_fixed
+            (fun i t _ hz => Smale.WhitneyPairModel.graphStep_fixed g.cutoff δ i t hz) N t hz
+        horizontal := fun t z =>
+          Smale.SmallPerturbation.composeFamily_preserves (B := B) (f :=
+            fun z : Smale.WhitneyPairModel.Space => z.1.1)
+            (Smale.WhitneyPairModel.graphStep_horizontal g.cutoff δ) N t z
+        normal := fun t z =>
+          Smale.SmallPerturbation.composeFamily_preserves (B := B) (f :=
+            fun z : Smale.WhitneyPairModel.Space => z.2)
+            (Smale.WhitneyPairModel.graphStep_normal g.cutoff δ) N t z
+        tracking := ?_ }⟩
+  · rintro _ ⟨p, hp, rfl⟩
+    exact g.support_cutoff hp
+  · intro s
+    change
+      Smale.SmallPerturbation.composeFamily B N (1, Smale.WhitneyPairModel.firstSheet (s, 0)) = _
+    rw [htrack N le_rfl s, htotal]
+
+
+private abbrev Smale.RankThreeWhitneyModel.Lower :=
+  EuclideanSpace ℝ (Fin 1)
+
+private abbrev Smale.RankThreeWhitneyModel.Upper :=
+  EuclideanSpace ℝ (Fin 2)
+
+private abbrev Smale.RankThreeWhitneyModel.Space :=
+  (ℝ × ℝ) × (Lower × Upper)
+
+private abbrev Smale.RankThreeWhitneyModel.LowerSheet :=
+  ℝ × Lower
+
+private abbrev Smale.RankThreeWhitneyModel.UpperSheet :=
+  ℝ × Upper
+
+private def Smale.RankThreeWhitneyModel.firstSheet (p : LowerSheet) : Space :=
+  ((p.1, 0), (p.2, 0))
+
+private def Smale.RankThreeWhitneyModel.secondSheet (h : ℝ) (p : UpperSheet) : Space :=
+  ((p.1, h * (1 - p.1 ^ 2)), (0, p.2))
+
+private theorem Smale.RankThreeWhitneyModel.contDiff_firstSheet : ContDiff ℝ ∞ firstSheet := by
+  unfold firstSheet
+  fun_prop
+
+private theorem
+    Smale.RankThreeWhitneyModel.contDiff_secondSheet (h : ℝ) : ContDiff ℝ ∞ (secondSheet h) :=
+  by
+  unfold secondSheet
+  fun_prop
+
+private def Smale.RankThreeWhitneyModel.firstSheetDerivative : LowerSheet →L[ℝ] Space :=
+  ((ContinuousLinearMap.fst ℝ ℝ Lower).prod 0).prod ((ContinuousLinearMap.snd ℝ ℝ Lower).prod 0)
+
+private def Smale.RankThreeWhitneyModel.secondSheetDerivative (h s : ℝ) : UpperSheet →L[ℝ] Space :=
+  ((ContinuousLinearMap.fst ℝ ℝ Upper).prod
+        ((-2 * h * s) • ContinuousLinearMap.fst ℝ ℝ Upper)).prod
+    ((0 : UpperSheet →L[ℝ] Lower).prod (ContinuousLinearMap.snd ℝ ℝ Upper))
+
+private theorem Smale.RankThreeWhitneyModel.firstSheetDerivative_apply (p : LowerSheet) :
+    firstSheetDerivative p = ((p.1, 0), (p.2, 0)) :=
+  rfl
+
+private theorem Smale.RankThreeWhitneyModel.secondSheetDerivative_apply (h s : ℝ) (p : UpperSheet) :
+    secondSheetDerivative h s p = ((p.1, (-2 * h * s) * p.1), (0, p.2)) :=
+  rfl
+
+private theorem Smale.RankThreeWhitneyModel.hasFDerivAt_firstSheet (p : LowerSheet) :
+    HasFDerivAt firstSheet firstSheetDerivative p :=
+  firstSheetDerivative.hasFDerivAt
+
+private theorem Smale.RankThreeWhitneyModel.hasFDerivAt_secondSheet (h : ℝ) (p : UpperSheet) :
+    HasFDerivAt (secondSheet h) (secondSheetDerivative h p.1) p := by
+  have hs := (ContinuousLinearMap.fst ℝ ℝ Upper).hasFDerivAt (x := p)
+  have hu := (ContinuousLinearMap.snd ℝ ℝ Upper).hasFDerivAt (x := p)
+  have ht := ((hasFDerivAt_const (1 : ℝ) p).sub (hs.pow 2)).const_mul h
+  have hd := (hs.prodMk ht).prodMk ((hasFDerivAt_const (0 : Lower) p).prodMk hu)
+  apply hd.congr_fderiv
+  apply ContinuousLinearMap.ext
+  intro v
+  simp only [secondSheetDerivative, ContinuousLinearMap.prod_apply, ContinuousLinearMap.coe_fst',
+    ContinuousLinearMap.coe_snd', zero_apply, sub_apply, smul_apply, smul_eq_mul]
+  congr 2
+  norm_num [two_smul]
+  ring
+
+private def
+    Smale.RankThreeWhitneyModel.lowerSplit : (Lower × ℝ) ≃L[ℝ] Smale.WhitneyPairModel.Plane :=
+  ContinuousLinearEquiv.ofFinrankEq
+    (by simp [Lower, Smale.WhitneyPairModel.Plane, Module.finrank_prod])
+
+private def Smale.RankThreeWhitneyModel.lowerInclude : Lower →L[ℝ] Smale.WhitneyPairModel.Plane :=
+  lowerSplit.toContinuousLinearMap.comp (ContinuousLinearMap.inl ℝ Lower ℝ)
+
+private def Smale.RankThreeWhitneyModel.lowerProject : Smale.WhitneyPairModel.Plane →L[ℝ] Lower :=
+  (ContinuousLinearMap.fst ℝ Lower ℝ).comp lowerSplit.symm.toContinuousLinearMap
+
+private theorem Smale.RankThreeWhitneyModel.lowerProject_include (u : Lower) :
+    lowerProject (lowerInclude u) = u := by
+  change (lowerSplit.symm (lowerSplit (u, 0))).1 = u
+  rw [lowerSplit.symm_apply_apply]
+
+private def Smale.RankThreeWhitneyModel.normalInclude :
+    (Lower × Upper) →L[ℝ] (Smale.WhitneyPairModel.Plane × Smale.WhitneyPairModel.Plane) :=
+  lowerInclude.prodMap (ContinuousLinearMap.id ℝ Upper)
+
+private def Smale.RankThreeWhitneyModel.normalProject :
+    (Smale.WhitneyPairModel.Plane × Smale.WhitneyPairModel.Plane) →L[ℝ] (Lower × Upper) :=
+  lowerProject.prodMap (ContinuousLinearMap.id ℝ Upper)
+
+private theorem Smale.RankThreeWhitneyModel.normalProject_include :
+    Function.LeftInverse normalProject normalInclude := fun z =>
+  Prod.ext (lowerProject_include z.1) rfl
+
+private def Smale.RankThreeWhitneyModel.expand : Space →L[ℝ] Smale.WhitneyPairModel.Space :=
+  Smale.FiberRestriction.embed normalInclude
+
+private def Smale.RankThreeWhitneyModel.collapse : Smale.WhitneyPairModel.Space →L[ℝ] Space :=
+  Smale.FiberRestriction.project normalProject
+
+private theorem Smale.RankThreeWhitneyModel.collapse_expand (z : Space) : collapse (expand z) = z :=
+  Smale.FiberRestriction.project_embed normalInclude normalProject normalProject_include z
+
+private theorem Smale.RankThreeWhitneyModel.expand_zero (p : ℝ × ℝ) : expand (p, 0) = (p, 0) :=
+  Prod.ext rfl normalInclude.map_zero
+
+private theorem Smale.RankThreeWhitneyModel.collapse_zero (p : ℝ × ℝ) : collapse (p, 0) = (p, 0) :=
+  Prod.ext rfl normalProject.map_zero
+
+private def Smale.RankThreeWhitneyModel.verticalGraph (B : ℝ → ℝ) (t s : ℝ) : Space :=
+  ((s, t * B s), 0)
+
+private theorem Smale.RankThreeWhitneyModel.collapse_verticalGraph (B : ℝ → ℝ) (t s : ℝ) :
+    collapse (Smale.WhitneyPairModel.verticalGraph B t s) = verticalGraph B t s :=
+  collapse_zero _
+
+private structure Smale.RankThreeWhitneyModel.GraphMotion (h : ℝ) (U : Set Space) where
+  height : ℝ → ℝ
+  nonneg_height : ∀ s, 0 ≤ height s
+  above : ∀ s, |s| ≤ 1 → h * (1 - s ^ 2) < height s
+  support : Set Space
+  compact_support : IsCompact support
+  support_subset : support ⊆ U
+  family : ℝ × Space → Space
+  smooth : ContDiff ℝ ∞ family
+  initial : ∀ z, family (0, z) = z
+  diffeomorph :
+    ∀ t, ∃ d : Diffeomorph 𝓘(ℝ, Space) 𝓘(ℝ, Space) Space Space ∞, ∀ z, d z = family (t, z)
+  fixed : ∀ t z, z ∉ support → family (t, z) = z
+  horizontal : ∀ t z, (family (t, z)).1.1 = z.1.1
+  normal : ∀ t z, (family (t, z)).2 = z.2
+  tracking : ∀ s, family (1, firstSheet (s, 0)) = verticalGraph height 1 s
+
+private theorem
+    Smale.RankThreeWhitneyModel.nonempty_graphMotion {h : ℝ} (hh : 0 < h) {U : Set Space}
+    (hU : IsOpen U) (hKU : ∀ p ∈ Smale.WhitneyPairModel.bigon h, (p, (0 : Lower × Upper)) ∈ U) :
+    Nonempty (GraphMotion h U) := by
+  let V : Set Smale.WhitneyPairModel.Space := collapse ⁻¹' U
+  have hV : IsOpen V := hU.preimage collapse.continuous
+  have hKV :
+    Set.MapsTo Smale.WhitneyPairModel.bigonEmbedding (Smale.WhitneyPairModel.bigon h) V := by
+    intro p hp
+    change collapse (p, 0) ∈ U
+    rw [collapse_zero]
+    exact hKU p hp
+  obtain ⟨g⟩ := Smale.WhitneyPairModel.nonempty_graphMotionData hh hV hKV
+  obtain ⟨a⟩ := g.nonempty_graphMotion
+  let A : ℝ × Space → Space := fun p => collapse (a.family (p.1, expand p.2))
+  have hA : ContDiff ℝ ∞ A :=
+    collapse.contDiff.comp
+      (a.smooth.comp (contDiff_fst.prodMk (expand.contDiff.comp contDiff_snd)))
+  refine
+    ⟨{  height := g.height
+        nonneg_height := g.nonneg_height
+        above := g.above
+        support := collapse '' a.support
+        compact_support := a.compact_support.image collapse.continuous
+        support_subset := ?_
+        family := A
+        smooth := hA
+        initial := ?_
+        diffeomorph := ?_
+        fixed := ?_
+        horizontal := ?_
+        normal := ?_
+        tracking := ?_ }⟩
+  · rintro _ ⟨z, hz, rfl⟩
+    exact a.support_subset hz
+  · intro z
+    change collapse (a.family (0, expand z)) = z
+    rw [a.initial, collapse_expand]
+  · intro t
+    obtain ⟨d, hd⟩ := a.diffeomorph t
+    have hn : ∀ z, (d z).2 = z.2 := by
+      intro z
+      rw [hd]
+      exact a.normal t z
+    refine
+      ⟨Smale.FiberRestriction.restrict normalInclude normalProject normalProject_include d hn, ?_⟩
+    intro z
+    change collapse (d (expand z)) = collapse (a.family (t, expand z))
+    rw [hd]
+  · intro t z hz
+    have hz' : expand z ∉ a.support := fun hs => hz ⟨expand z, hs, collapse_expand z⟩
+    change collapse (a.family (t, expand z)) = z
+    rw [a.fixed t _ hz', collapse_expand]
+  · intro t z
+    change (a.family (t, expand z)).1.1 = z.1.1
+    rw [a.horizontal]
+    rfl
+  · intro t z
+    change normalProject (a.family (t, expand z)).2 = z.2
+    rw [a.normal]
+    exact normalProject_include z.2
+  · intro s
+    have he : expand (firstSheet (s, 0)) = Smale.WhitneyPairModel.firstSheet (s, 0) :=
+      expand_zero (s, 0)
+    change collapse (a.family (1, expand (firstSheet (s, 0)))) = verticalGraph g.height 1 s
+    rw [he, a.tracking, collapse_verticalGraph]
+
+private theorem Smale.RankThreeWhitneyModel.GraphMotion.firstSheet_ne_secondSheet {h : ℝ}
+    {U : Set Smale.RankThreeWhitneyModel.Space} (a : Smale.RankThreeWhitneyModel.GraphMotion h U)
+    (hh : 0 < h) (p : Smale.RankThreeWhitneyModel.LowerSheet)
+    (q : Smale.RankThreeWhitneyModel.UpperSheet) :
+    a.family (1, Smale.RankThreeWhitneyModel.firstSheet p) ≠
+      Smale.RankThreeWhitneyModel.secondSheet h q := by
+  intro heq
+  have hst : p.1 = q.1 := by
+    have he := congrArg (fun z : Smale.RankThreeWhitneyModel.Space => z.1.1) heq
+    rw [a.horizontal] at he
+    exact he
+  have hu : p.2 = 0 := by
+    have he := congrArg (fun z : Smale.RankThreeWhitneyModel.Space => z.2) heq
+    rw [a.normal] at he
+    exact congrArg Prod.fst he
+  have hp : p = (q.1, 0) := Prod.ext hst hu
+  rw [hp, a.tracking] at heq
+  have ht : a.height q.1 = h * (1 - q.1 ^ 2) := by
+    simpa only [Smale.RankThreeWhitneyModel.verticalGraph,
+      Smale.RankThreeWhitneyModel.secondSheet, one_mul] using
+      congrArg (fun z : Smale.RankThreeWhitneyModel.Space => z.1.2) heq
+  have hheight : 0 ≤ h * (1 - q.1 ^ 2) := ht ▸ a.nonneg_height q.1
+  have hlevel : 0 ≤ 1 - q.1 ^ 2 := nonneg_of_mul_nonneg_right hheight hh
+  have habs : |q.1| ≤ 1 :=
+    abs_le.mpr ⟨by nlinarith [sq_nonneg (q.1 + 1)], by nlinarith [sq_nonneg (q.1 - 1)]⟩
+  exact (a.above q.1 habs).ne ht.symm
+
+private structure
+    Smale.TubularBigon.RankThreeTangentAdaptedChart {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M} {a b : ℝ → M}
+    {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ} {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    (tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3)
+    (d :
+      Smale.StripNormalData (EuclideanSpace ℝ (Fin 1)) (EuclideanSpace ℝ (Fin 3)) (E := E) S
+        k.map)
+    (e :
+      Smale.StripNormalData (EuclideanSpace ℝ (Fin 2)) (EuclideanSpace ℝ (Fin 2)) (E := E) T
+        l.map) where
+  base : (ℝ × ℝ) → ((EuclideanSpace ℝ (Fin 1) × EuclideanSpace ℝ (Fin 2)) →L[ℝ] (ℝ × ℝ))
+  normal :
+    (ℝ × ℝ) →
+      ((EuclideanSpace ℝ (Fin 1) × EuclideanSpace ℝ (Fin 2)) →L[ℝ] EuclideanSpace ℝ (Fin 3))
+  domain : Set (ℝ × ℝ)
+  open_domain : IsOpen domain
+  contains : Smale.WhitneyPairModel.bigon h ⊆ domain
+  smooth_base : ContDiffOn ℝ ∞ base domain
+  smooth_normal : ContDiffOn ℝ ∞ normal domain
+  normal_invertible : ∀ p ∈ domain, (normal p).IsInvertible
+  lower_transverse :
+    ∀ t ∈ Set.Icc (0 : ℝ) 1,
+      ∀ u : EuclideanSpace ℝ (Fin 1),
+        Smale.FrameField.shearedBlock (base (2 * t - 1, 0)) (normal (2 * t - 1, 0)) (0, (u, 0)) =
+          d.sheetDifferential tube.chart t (0, u)
+  upper_transverse :
+    ∀ t ∈ Set.Icc (0 : ℝ) 1,
+      ∀ v : EuclideanSpace ℝ (Fin 2),
+        Smale.FrameField.shearedBlock (base (Smale.WhitneyPairModel.upperBoundaryArc h t))
+            (normal (Smale.WhitneyPairModel.upperBoundaryArc h t)) (0, (0, v)) =
+          e.sheetDifferential tube.chart t (0, v)
+  radius : ℝ
+  radius_pos : 0 < radius
+  chart :
+    PartialDiffeomorph 𝓘(ℝ, Smale.RankThreeWhitneyModel.Space) 𝓘(ℝ, E)
+      Smale.RankThreeWhitneyModel.Space M ∞
+  source_contains : Smale.WhitneyPairModel.bigon h ×ˢ Metric.closedBall 0 radius ⊆ chart.source
+  zero_section : ∀ p, chart (p, 0) = tube.map p
+  coordinates : ∀ p, chart p = tube.chart (Smale.FrameField.shearedMap base normal p)
+  target_subset : chart.target ⊆ tube.chart.target
+  transition_derivative :
+    ∀ p ∈ Smale.WhitneyPairModel.bigon h,
+      HasFDerivAt (tube.chart.symm ∘ chart) (Smale.FrameField.shearedBlock (base p) (normal p))
+        (p, 0)
+
+private theorem Smale.TubularBigon.nonempty_rankThreeTangentAdaptedChart_of_opposite_corner_signs
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {S T : Set M} {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    (tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3)
+    (d :
+      Smale.StripNormalData (EuclideanSpace ℝ (Fin 1)) (EuclideanSpace ℝ (Fin 3)) (E := E) S
+        k.map)
+    (e :
+      Smale.StripNormalData (EuclideanSpace ℝ (Fin 2)) (EuclideanSpace ℝ (Fin 2)) (E := E) T
+        l.map)
+    (hsign : tube.rankThreeSheetPairDet d e 0 * tube.rankThreeSheetPairDet d e 1 < 0) :
+    Nonempty (RankThreeTangentAdaptedChart tube d e) := by
+  obtain ⟨W, hW, hlo, O, hO, hKO, C, hC, hhi, hframe⟩ :=
+    tube.exists_rankThree_adapted_frame_of_opposite_corner_signs d e hsign
+  obtain ⟨Dlo, hDlo, hIDlo, hBlo⟩ :=
+    d.exists_open_sheetBaseFrame_domain tube.chart
+      (fun t ht => tube.lower_chart_center_mem_target d ht)
+  obtain ⟨Dhi, hDhi, hIDhi, hBhi⟩ :=
+    e.exists_open_sheetBaseFrame_domain tube.chart
+      (fun t ht => tube.upper_chart_center_mem_target e ht)
+  have htime (t y : ℝ) : Smale.WhitneyPairModel.arcTime (2 * t - 1, y) = t := by
+    dsimp [Smale.WhitneyPairModel.arcTime]; ring
+  have htq (t : ℝ) :
+    Smale.WhitneyPairModel.arcTime (Smale.WhitneyPairModel.upperBoundaryArc h t) = t := htime t _
+  have htimeK :
+    Set.MapsTo Smale.WhitneyPairModel.arcTime (Smale.WhitneyPairModel.bigon h)
+      (Set.Icc (0 : ℝ) 1) := by
+    intro p hp
+    have hpr := Smale.WhitneyPairModel.bigon_subset_rectangle tube.height_pos hp
+    change 0 ≤ (p.1 + 1) / 2 ∧ (p.1 + 1) / 2 ≤ 1
+    constructor <;> linarith [hpr.1.1, hpr.1.2]
+  let U := O ∩ Smale.WhitneyPairModel.arcTime ⁻¹' (Dlo ∩ Dhi)
+  have hU : IsOpen U :=
+    hO.inter ((hDlo.inter hDhi).preimage Smale.WhitneyPairModel.contDiff_arcTime.continuous)
+  have hKU : Smale.WhitneyPairModel.bigon h ⊆ U := fun p hp =>
+    ⟨hKO hp, hIDlo (htimeK hp), hIDhi (htimeK hp)⟩
+  let A : (ℝ × ℝ) → ((EuclideanSpace ℝ (Fin 1) × EuclideanSpace ℝ (Fin 2)) →L[ℝ] (ℝ × ℝ)) :=
+    fun p =>
+    (d.sheetBaseFrame tube.chart (Smale.WhitneyPairModel.arcTime p)).coprod
+      (e.sheetBaseFrame tube.chart (Smale.WhitneyPairModel.arcTime p))
+  let N :
+    (ℝ × ℝ) →
+      ((EuclideanSpace ℝ (Fin 1) × EuclideanSpace ℝ (Fin 2)) →L[ℝ] EuclideanSpace ℝ (Fin 3)) :=
+    fun p => (W p).coprod (C p)
+  have hA : ContDiffOn ℝ ∞ A U :=
+    Smale.FrameField.contDiffOn_coprod
+      (hBlo.comp Smale.WhitneyPairModel.contDiff_arcTime.contDiffOn (fun _ hp => hp.2.1))
+      (hBhi.comp Smale.WhitneyPairModel.contDiff_arcTime.contDiffOn (fun _ hp => hp.2.2))
+  have hN : ContDiffOn ℝ ∞ N U :=
+    Smale.FrameField.contDiffOn_coprod hW.contDiffOn (hC.mono Set.inter_subset_left)
+  have hiN : ∀ p ∈ U, (N p).IsInvertible := fun p hp =>
+    Smale.FrameField.isInvertible_coprod_of_bijective _ _ (hframe p hp.1)
+  have hlow :
+    ∀ t ∈ Set.Icc (0 : ℝ) 1,
+      ∀ u : EuclideanSpace ℝ (Fin 1),
+        Smale.FrameField.shearedBlock (A (2 * t - 1, 0)) (N (2 * t - 1, 0)) (0, (u, 0)) =
+          d.sheetDifferential tube.chart t (0, u) := by
+    intro t ht u
+    have hWt : W (2 * t - 1, 0) = d.normalFrame tube.chart t := by
+      have hg := (hlo t ht).eq_of_nhds
+      dsimp only [Function.comp_apply] at hg
+      rwa [htime] at hg
+    rw [d.sheetDifferential_transverse_eq tube.chart ht (tube.lower_chart_center_mem_target d ht),
+      Smale.FrameField.shearedBlock_apply]
+    simp only [A, N, ContinuousLinearMap.coprod_apply, map_zero, add_zero, zero_add, htime, hWt]
+  have hupp :
+    ∀ t ∈ Set.Icc (0 : ℝ) 1,
+      ∀ v : EuclideanSpace ℝ (Fin 2),
+        Smale.FrameField.shearedBlock (A (Smale.WhitneyPairModel.upperBoundaryArc h t))
+            (N (Smale.WhitneyPairModel.upperBoundaryArc h t)) (0, (0, v)) =
+          e.sheetDifferential tube.chart t (0, v) := by
+    intro t ht v
+    rw [e.sheetDifferential_transverse_eq tube.chart ht (tube.upper_chart_center_mem_target e ht),
+      Smale.FrameField.shearedBlock_apply]
+    simp only [A, N, ContinuousLinearMap.coprod_apply, map_zero, zero_add, htq, hhi t ht]
+  have hz :
+    Smale.WhitneyPairModel.bigon h ×ˢ {(0 : EuclideanSpace ℝ (Fin 3))} ⊆ tube.chart.source := by
+    rintro ⟨p, z⟩ ⟨hp, hz⟩
+    have hz0 : z = 0 := hz
+    subst z
+    exact tube.source_contains ⟨hp, Metric.mem_closedBall_self tube.radius_pos.le⟩
+  obtain ⟨ε, hε, Φ, hsource, hformula, htarget, -, hderiv⟩ :=
+    Smale.FrameField.exists_sheared_tubular_chart tube.chart
+      (Smale.WhitneyPairModel.isCompact_bigon tube.height_pos) hU hKU hz hA hN
+      (fun p hp => hiN p (hKU hp))
+  refine
+    ⟨{  base := A
+        normal := N
+        domain := U
+        open_domain := hU
+        contains := hKU
+        smooth_base := hA
+        smooth_normal := hN
+        normal_invertible := hiN
+        lower_transverse := hlow
+        upper_transverse := hupp
+        radius := ε
+        radius_pos := hε
+        chart := Φ
+        source_contains := hsource
+        zero_section := ?_
+        coordinates := hformula
+        target_subset := htarget
+        transition_derivative := hderiv }⟩
+  intro p
+  rw [hformula, Smale.FrameField.shearedMap_zero, tube.zero_section]
+
+
+private def Smale.WhitneyPairModel.halfTimeDerivative {A : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] : (ℝ × A) →L[ℝ] (ℝ × A) :=
+  (((1 / 2 : ℝ) • ContinuousLinearMap.fst ℝ ℝ A)).prod (ContinuousLinearMap.snd ℝ ℝ A)
+
+private theorem Smale.WhitneyPairModel.halfTimeDerivative_apply {A : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] (v : (ℝ × A)) : halfTimeDerivative v = (v.1 / 2, v.2) := by
+  apply Prod.ext
+  · change (1 / 2 : ℝ) * v.1 = v.1 / 2
+    ring
+  · rfl
+
+private def Smale.WhitneyPairModel.sheetTimeCoordinates {A : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] (p : (ℝ × A)) : (ℝ × A) :=
+  halfTimeDerivative p + ((1 / 2 : ℝ), 0)
+
+private theorem Smale.WhitneyPairModel.sheetTimeCoordinates_apply {A : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] (p : (ℝ × A)) : sheetTimeCoordinates p = ((p.1 + 1) / 2, p.2) := by
+  rw [sheetTimeCoordinates, halfTimeDerivative_apply]
+  apply Prod.ext
+  · change p.1 / 2 + 1 / 2 = (p.1 + 1) / 2
+    ring
+  · exact add_zero _
+
+private theorem
+    Smale.WhitneyPairModel.sheetTimeCoordinates_center {A : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] (t : ℝ) : sheetTimeCoordinates (2 * t - 1, (0 : A)) = (t, 0) := by
+  rw [sheetTimeCoordinates_apply]
+  apply Prod.ext
+  · dsimp
+    ring
+  · rfl
+
+private theorem
+    Smale.WhitneyPairModel.contDiff_sheetTimeCoordinates {A : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] : ContDiff ℝ ∞ (sheetTimeCoordinates (A := A)) :=
+  (halfTimeDerivative (A := A)).contDiff.add contDiff_const
+
+private theorem
+    Smale.WhitneyPairModel.hasFDerivAt_sheetTimeCoordinates {A : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] (p : (ℝ × A)) : HasFDerivAt sheetTimeCoordinates halfTimeDerivative p :=
+  halfTimeDerivative.hasFDerivAt.add_const ((1 / 2 : ℝ), (0 : A))
+
+private def Smale.StripNormalData.sheetTransitionDomain {A B Z E M : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M} (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) : Set (ℝ × A) :=
+  (ContinuousLinearMap.inl ℝ (ℝ × A) B) ⁻¹' (d.chart.source ∩ d.chart ⁻¹' Ψ.target)
+
+private theorem Smale.StripNormalData.isOpen_sheetTransitionDomain {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) :
+    IsOpen (d.sheetTransitionDomain Ψ) := by
+  have hO : IsOpen (d.chart.source ∩ d.chart ⁻¹' Ψ.target) :=
+    d.chart.contMDiffOn_toFun.continuousOn.isOpen_inter_preimage d.chart.open_source Ψ.open_target
+  exact hO.preimage (ContinuousLinearMap.inl ℝ (ℝ × A) B).continuous
+
+private theorem Smale.StripNormalData.contDiffOn_sheetTransition {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) :
+    ContDiffOn ℝ ∞ (d.sheetTransition Ψ) (d.sheetTransitionDomain Ψ) := by
+  have hfull : ContDiffOn ℝ ∞ (Ψ.symm ∘ d.chart) (d.chart.source ∩ d.chart ⁻¹' Ψ.target) :=
+    (Ψ.contMDiffOn_invFun.comp (d.chart.contMDiffOn_toFun.mono Set.inter_subset_left)
+        (fun _ hp => hp.2)).contDiffOn
+  exact hfull.comp (ContinuousLinearMap.inl ℝ (ℝ × A) B).contDiff.contDiffOn (fun _ hp => hp)
+
+private def Smale.StripNormalData.retimedSheetTransition {A B Z E M : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M} (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) :
+    (ℝ × A) → ((ℝ × ℝ) × Z) :=
+  d.sheetTransition Ψ ∘ Smale.WhitneyPairModel.sheetTimeCoordinates
+
+private def Smale.StripNormalData.retimedDomain {A B Z E M : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M} (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) : Set (ℝ × A) :=
+  Smale.WhitneyPairModel.sheetTimeCoordinates ⁻¹' d.sheetTransitionDomain Ψ
+
+private theorem
+    Smale.StripNormalData.isOpen_retimedDomain {A B Z E M : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M} (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) :
+    IsOpen (d.retimedDomain Ψ) :=
+  (d.isOpen_sheetTransitionDomain Ψ).preimage
+    Smale.WhitneyPairModel.contDiff_sheetTimeCoordinates.continuous
+
+private theorem Smale.StripNormalData.contDiffOn_retimedSheetTransition {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) :
+    ContDiffOn ℝ ∞ (d.retimedSheetTransition Ψ) (d.retimedDomain Ψ) :=
+  (d.contDiffOn_sheetTransition Ψ).comp
+    Smale.WhitneyPairModel.contDiff_sheetTimeCoordinates.contDiffOn (fun _ hp => hp)
+
+private theorem Smale.StripNormalData.retimedDomain_contains_center {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1)
+    (htarget : d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target) :
+    (2 * t - 1, (0 : A)) ∈ d.retimedDomain Ψ := by
+  change Smale.WhitneyPairModel.sheetTimeCoordinates (2 * t - 1, 0) ∈ d.sheetTransitionDomain Ψ
+  rw [Smale.WhitneyPairModel.sheetTimeCoordinates_center]
+  exact ⟨d.line ht, htarget⟩
+
+private theorem Smale.StripNormalData.hasFDerivAt_retimedSheetTransition {A B Z E M : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup B] [NormedSpace ℝ B]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {S : Set M} {k : (ℝ × ℝ) → M}
+    (d : Smale.StripNormalData A B (E := E) S k)
+    (Ψ : PartialDiffeomorph 𝓘(ℝ, (ℝ × ℝ) × Z) 𝓘(ℝ, E) ((ℝ × ℝ) × Z) M ∞) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1)
+    (htarget : d.chart (Smale.StripCoordinates.center t) ∈ Ψ.target) :
+    HasFDerivAt (d.retimedSheetTransition Ψ)
+      ((d.sheetDifferential Ψ t).comp Smale.WhitneyPairModel.halfTimeDerivative) (2 * t - 1, 0) :=
+  by
+  have hd :
+    HasFDerivAt (d.sheetTransition Ψ) (d.sheetDifferential Ψ t)
+      (Smale.WhitneyPairModel.sheetTimeCoordinates (2 * t - 1, 0)) := by
+    rw [Smale.WhitneyPairModel.sheetTimeCoordinates_center]
+    exact ((d.contDiffAt_sheetTransition Ψ ht htarget).differentiableAt (by simp)).hasFDerivAt
+  exact hd.comp (2 * t - 1, (0 : A)) (Smale.WhitneyPairModel.hasFDerivAt_sheetTimeCoordinates _)
+
+private theorem Smale.TubularBigon.RankThreeTangentAdaptedChart.lower_model_tangent {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    (Smale.FrameField.shearedBlock (c.base (2 * t - 1, 0)) (c.normal (2 * t - 1, 0))).comp
+        Smale.RankThreeWhitneyModel.firstSheetDerivative =
+      (d.sheetDifferential tube.chart t).comp Smale.WhitneyPairModel.halfTimeDerivative := by
+  apply ContinuousLinearMap.ext
+  intro v
+  have harc : d.sheetDifferential tube.chart t (v.1 / 2, 0) = ((v.1, 0), 0) := by
+    rw [Smale.IntersectionCoordinates.map_first_axis _ (v.1 / 2),
+      tube.lower_sheetDifferential_arc d ht]
+    ext <;> simp [smul_eq_mul]
+  change
+    Smale.FrameField.shearedBlock _ _ (Smale.RankThreeWhitneyModel.firstSheetDerivative v) =
+      d.sheetDifferential tube.chart t (Smale.WhitneyPairModel.halfTimeDerivative v)
+  rw [Smale.WhitneyPairModel.halfTimeDerivative_apply]
+  calc
+    Smale.FrameField.shearedBlock _ _ (Smale.RankThreeWhitneyModel.firstSheetDerivative v) =
+        Smale.FrameField.shearedBlock (c.base (2 * t - 1, 0)) (c.normal (2 * t - 1, 0))
+            ((v.1, 0), 0) +
+          Smale.FrameField.shearedBlock (c.base (2 * t - 1, 0)) (c.normal (2 * t - 1, 0))
+            (0, (v.2, 0)) := by
+      rw [← map_add]
+      congr 1
+      simp only [Smale.RankThreeWhitneyModel.firstSheetDerivative_apply, Prod.mk_add_mk, add_zero,
+        zero_add]
+    _ =
+        d.sheetDifferential tube.chart t (v.1 / 2, 0) +
+          d.sheetDifferential tube.chart t (0, v.2) := by
+      rw [Smale.FrameField.shearedBlock_horizontal, c.lower_transverse t ht, harc]
+    _ = d.sheetDifferential tube.chart t (v.1 / 2, v.2) := by
+      rw [← map_add]
+      congr 1
+      simp
+
+private theorem Smale.TubularBigon.RankThreeTangentAdaptedChart.upper_model_tangent {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    (Smale.FrameField.shearedBlock (c.base (Smale.WhitneyPairModel.upperBoundaryArc h t))
+            (c.normal (Smale.WhitneyPairModel.upperBoundaryArc h t))).comp
+        (Smale.RankThreeWhitneyModel.secondSheetDerivative h (2 * t - 1)) =
+      (e.sheetDifferential tube.chart t).comp Smale.WhitneyPairModel.halfTimeDerivative := by
+  apply ContinuousLinearMap.ext
+  intro v
+  have harc :
+    e.sheetDifferential tube.chart t (v.1 / 2, 0) = ((v.1, (-2 * h * (2 * t - 1)) * v.1), 0) := by
+    rw [Smale.IntersectionCoordinates.map_first_axis _ (v.1 / 2),
+      tube.upper_sheetDifferential_arc e ht]
+    ext <;> simp [smul_eq_mul]
+    ring
+  change
+    Smale.FrameField.shearedBlock _ _
+        (Smale.RankThreeWhitneyModel.secondSheetDerivative h (2 * t - 1) v) =
+      e.sheetDifferential tube.chart t (Smale.WhitneyPairModel.halfTimeDerivative v)
+  rw [Smale.WhitneyPairModel.halfTimeDerivative_apply]
+  calc
+    Smale.FrameField.shearedBlock _ _
+          (Smale.RankThreeWhitneyModel.secondSheetDerivative h (2 * t - 1) v) =
+        Smale.FrameField.shearedBlock (c.base (Smale.WhitneyPairModel.upperBoundaryArc h t))
+            (c.normal (Smale.WhitneyPairModel.upperBoundaryArc h t))
+            ((v.1, (-2 * h * (2 * t - 1)) * v.1), 0) +
+          Smale.FrameField.shearedBlock (c.base (Smale.WhitneyPairModel.upperBoundaryArc h t))
+            (c.normal (Smale.WhitneyPairModel.upperBoundaryArc h t)) (0, (0, v.2)) := by
+      rw [← map_add]
+      congr 1
+      simp only [Smale.RankThreeWhitneyModel.secondSheetDerivative_apply, Prod.mk_add_mk,
+        add_zero, zero_add]
+    _ =
+        e.sheetDifferential tube.chart t (v.1 / 2, 0) +
+          e.sheetDifferential tube.chart t (0, v.2) := by
+      rw [Smale.FrameField.shearedBlock_horizontal, c.upper_transverse t ht, harc]
+    _ = e.sheetDifferential tube.chart t (v.1 / 2, v.2) := by
+      rw [← map_add]
+      congr 1
+      simp
+
+private def
+    Smale.SheetCorrection.centerProjection {A : Type*} [NormedAddCommGroup A] [NormedSpace ℝ A] :
+    (ℝ × A) →L[ℝ] (ℝ × A) :=
+  (ContinuousLinearMap.fst ℝ ℝ A).prod (0 : (ℝ × A) →L[ℝ] A)
+
+private theorem Smale.SheetCorrection.centerProjection_apply {A : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] (p : ℝ × A) : centerProjection p = (p.1, 0) :=
+  rfl
+
+private def Smale.SheetCorrection.centeredCorrection {A F : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup F] (R G : (ℝ × A) → F) (p : ℝ × A) : F :=
+  (R p - G p) - (R (centerProjection p) - G (centerProjection p))
+
+private theorem Smale.SheetCorrection.centeredCorrection_zero {A F : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup F] (R G : (ℝ × A) → F) (s : ℝ) :
+    centeredCorrection R G (s, 0) = 0 := by
+  simp only [centeredCorrection, centerProjection_apply, sub_self]
+
+private theorem Smale.SheetCorrection.centeredCorrection_eq_sub {A F : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup F] {R G : (ℝ × A) → F} {p : ℝ × A}
+    (hcenter : R (p.1, 0) = G (p.1, 0)) : centeredCorrection R G p = R p - G p := by
+  simp only [centeredCorrection, centerProjection_apply, hcenter, sub_self, sub_zero]
+
+private theorem
+    Smale.SheetCorrection.contDiffOn_centeredCorrection {A F : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup F] [NormedSpace ℝ F] {R G : (ℝ × A) → F}
+    {D : Set (ℝ × A)} (hR : ContDiffOn ℝ ∞ R D) (hG : ContDiffOn ℝ ∞ G D) :
+    ContDiffOn ℝ ∞ (centeredCorrection R G) (D ∩ centerProjection ⁻¹' D) :=
+  ((hR.sub hG).mono Set.inter_subset_left).sub
+    ((hR.sub hG).comp (centerProjection (A := A)).contDiff.contDiffOn (fun _ hp => hp.2))
+
+private theorem Smale.SheetCorrection.hasFDerivAt_centeredCorrection_zero {A F : Type*}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    {R G : (ℝ × A) → F} {L : (ℝ × A) →L[ℝ] F} {s : ℝ} (hR : HasFDerivAt R L (s, 0))
+    (hG : HasFDerivAt G L (s, 0)) :
+    HasFDerivAt (centeredCorrection R G) (0 : (ℝ × A) →L[ℝ] F) (s, 0) := by
+  have hdiff : HasFDerivAt (fun p => R p - G p) (0 : (ℝ × A) →L[ℝ] F) (s, (0 : A)) := by
+    convert hR.sub hG using 1 <;>
+      first
+      | rfl
+      | simp only [sub_self]
+  have hcenter := hdiff.comp (s, (0 : A)) (centerProjection (A := A)).hasFDerivAt
+  convert hdiff.sub hcenter using 1 <;>
+    first
+    | rfl
+    | simp only [ContinuousLinearMap.zero_comp, sub_self]
+
+private def Smale.RankThreeWhitneyModel.lowerSheetCoordinates : Space →L[ℝ] LowerSheet :=
+  ((ContinuousLinearMap.fst ℝ ℝ ℝ).comp (ContinuousLinearMap.fst ℝ (ℝ × ℝ) (Lower × Upper))).prod
+    ((ContinuousLinearMap.fst ℝ Lower Upper).comp
+      (ContinuousLinearMap.snd ℝ (ℝ × ℝ) (Lower × Upper)))
+
+private def Smale.RankThreeWhitneyModel.upperSheetCoordinates : Space →L[ℝ] UpperSheet :=
+  ((ContinuousLinearMap.fst ℝ ℝ ℝ).comp (ContinuousLinearMap.fst ℝ (ℝ × ℝ) (Lower × Upper))).prod
+    ((ContinuousLinearMap.snd ℝ Lower Upper).comp
+      (ContinuousLinearMap.snd ℝ (ℝ × ℝ) (Lower × Upper)))
+
+private def Smale.RankThreeWhitneyModel.correctedSheetMap {F : Type*} [NormedAddCommGroup F]
+    (G : Space → F) (Rlo : LowerSheet → F) (Rhi : UpperSheet → F) (h : ℝ) (p : Space) : F :=
+  G p + Smale.SheetCorrection.centeredCorrection Rlo (G ∘ firstSheet) (lowerSheetCoordinates p) +
+    Smale.SheetCorrection.centeredCorrection Rhi (G ∘ secondSheet h) (upperSheetCoordinates p)
+
+private theorem
+    Smale.RankThreeWhitneyModel.correctedSheetMap_zero {F : Type*} [NormedAddCommGroup F]
+    (G : Space → F) (Rlo : LowerSheet → F) (Rhi : UpperSheet → F) (h : ℝ) (p : ℝ × ℝ) :
+    correctedSheetMap G Rlo Rhi h (p, 0) = G (p, 0) := by
+  change
+    G (p, 0) + Smale.SheetCorrection.centeredCorrection Rlo (G ∘ firstSheet) (p.1, 0) +
+        Smale.SheetCorrection.centeredCorrection Rhi (G ∘ secondSheet h) (p.1, 0) =
+      G (p, 0)
+  rw [Smale.SheetCorrection.centeredCorrection_zero,
+    Smale.SheetCorrection.centeredCorrection_zero, add_zero, add_zero]
+
+private theorem
+    Smale.RankThreeWhitneyModel.correctedSheetMap_lower {F : Type*} [NormedAddCommGroup F]
+    {G : Space → F} {Rlo : LowerSheet → F} {Rhi : UpperSheet → F} {h : ℝ} (q : LowerSheet)
+    (hcenter : Rlo (q.1, 0) = G (firstSheet (q.1, 0))) :
+    correctedSheetMap G Rlo Rhi h (firstSheet q) = Rlo q := by
+  have hlo : lowerSheetCoordinates (firstSheet q) = q := rfl
+  have hhi : upperSheetCoordinates (firstSheet q) = (q.1, 0) := rfl
+  rw [correctedSheetMap, hlo, hhi, Smale.SheetCorrection.centeredCorrection_zero, add_zero,
+    Smale.SheetCorrection.centeredCorrection_eq_sub hcenter]
+  dsimp only [Function.comp_apply]
+  abel
+
+private theorem
+    Smale.RankThreeWhitneyModel.correctedSheetMap_upper {F : Type*} [NormedAddCommGroup F]
+    {G : Space → F} {Rlo : LowerSheet → F} {Rhi : UpperSheet → F} {h : ℝ} (q : UpperSheet)
+    (hcenter : Rhi (q.1, 0) = G (secondSheet h (q.1, 0))) :
+    correctedSheetMap G Rlo Rhi h (secondSheet h q) = Rhi q := by
+  have hlo : lowerSheetCoordinates (secondSheet h q) = (q.1, 0) := rfl
+  have hhi : upperSheetCoordinates (secondSheet h q) = q := rfl
+  rw [correctedSheetMap, hlo, hhi, Smale.SheetCorrection.centeredCorrection_zero, add_zero,
+    Smale.SheetCorrection.centeredCorrection_eq_sub hcenter]
+  dsimp only [Function.comp_apply]
+  abel
+
+private def Smale.RankThreeWhitneyModel.correctionDomain (U : Set Space) (Dlo : Set LowerSheet)
+    (Dhi : Set UpperSheet) : Set Space :=
+  U ∩
+    (lowerSheetCoordinates ⁻¹' (Dlo ∩ Smale.SheetCorrection.centerProjection ⁻¹' Dlo) ∩
+      upperSheetCoordinates ⁻¹' (Dhi ∩ Smale.SheetCorrection.centerProjection ⁻¹' Dhi))
+
+private theorem
+    Smale.RankThreeWhitneyModel.isOpen_correctionDomain {U : Set Space} {Dlo : Set LowerSheet}
+    {Dhi : Set UpperSheet} (hU : IsOpen U) (hDlo : IsOpen Dlo) (hDhi : IsOpen Dhi) :
+    IsOpen (correctionDomain U Dlo Dhi) :=
+  hU.inter
+    (((hDlo.inter (hDlo.preimage Smale.SheetCorrection.centerProjection.continuous)).preimage
+          lowerSheetCoordinates.continuous).inter
+      ((hDhi.inter (hDhi.preimage Smale.SheetCorrection.centerProjection.continuous)).preimage
+        upperSheetCoordinates.continuous))
+
+private theorem Smale.RankThreeWhitneyModel.contDiffOn_correctedSheetMap {F : Type*}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] {G : Space → F} {Rlo : LowerSheet → F}
+    {Rhi : UpperSheet → F} {h : ℝ} {U : Set Space} {Dlo : Set LowerSheet} {Dhi : Set UpperSheet}
+    (hG : ContDiffOn ℝ ∞ G U) (hRlo : ContDiffOn ℝ ∞ Rlo Dlo)
+    (hGlo : ContDiffOn ℝ ∞ (G ∘ firstSheet) Dlo) (hRhi : ContDiffOn ℝ ∞ Rhi Dhi)
+    (hGhi : ContDiffOn ℝ ∞ (G ∘ secondSheet h) Dhi) :
+    ContDiffOn ℝ ∞ (correctedSheetMap G Rlo Rhi h) (correctionDomain U Dlo Dhi) :=
+  ((hG.mono Set.inter_subset_left).add
+        ((Smale.SheetCorrection.contDiffOn_centeredCorrection hRlo hGlo).comp
+          lowerSheetCoordinates.contDiff.contDiffOn (fun _ hp => hp.2.1))).add
+    ((Smale.SheetCorrection.contDiffOn_centeredCorrection hRhi hGhi).comp
+      upperSheetCoordinates.contDiff.contDiffOn (fun _ hp => hp.2.2))
+
+private theorem Smale.RankThreeWhitneyModel.hasFDerivAt_correctedSheetMap_zero {F : Type*}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] {G : Space → F} {Rlo : LowerSheet → F}
+    {Rhi : UpperSheet → F} {h : ℝ} {p : ℝ × ℝ} {L : Space →L[ℝ] F} {Llo : LowerSheet →L[ℝ] F}
+    {Lhi : UpperSheet →L[ℝ] F} (hG : HasFDerivAt G L (p, 0)) (hRlo : HasFDerivAt Rlo Llo (p.1, 0))
+    (hGlo : HasFDerivAt (G ∘ firstSheet) Llo (p.1, 0)) (hRhi : HasFDerivAt Rhi Lhi (p.1, 0))
+    (hGhi : HasFDerivAt (G ∘ secondSheet h) Lhi (p.1, 0)) :
+    HasFDerivAt (correctedSheetMap G Rlo Rhi h) L (p, 0) := by
+  have hlo :
+    HasFDerivAt
+      (Smale.SheetCorrection.centeredCorrection Rlo (G ∘ firstSheet) ∘ lowerSheetCoordinates)
+      (0 : Space →L[ℝ] F) (p, 0) := by
+    simpa only [ContinuousLinearMap.zero_comp] using
+      (Smale.SheetCorrection.hasFDerivAt_centeredCorrection_zero hRlo hGlo).comp
+        (p, (0 : Lower × Upper)) lowerSheetCoordinates.hasFDerivAt
+  have hhi :
+    HasFDerivAt
+      (Smale.SheetCorrection.centeredCorrection Rhi (G ∘ secondSheet h) ∘ upperSheetCoordinates)
+      (0 : Space →L[ℝ] F) (p, 0) := by
+    simpa only [ContinuousLinearMap.zero_comp] using
+      (Smale.SheetCorrection.hasFDerivAt_centeredCorrection_zero hRhi hGhi).comp
+        (p, (0 : Lower × Upper)) upperSheetCoordinates.hasFDerivAt
+  convert (hG.add hlo).add hhi using 1 <;>
+    first
+    | rfl
+    | simp only [add_zero]
+
+private def Smale.TubularBigon.RankThreeTangentAdaptedChart.shearedCoordinates {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) :
+    Smale.RankThreeWhitneyModel.Space → ((ℝ × ℝ) × EuclideanSpace ℝ (Fin 3)) :=
+  Smale.FrameField.shearedMap c.base c.normal
+
+private def Smale.TubularBigon.RankThreeTangentAdaptedChart.correctedCoordinates {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) :
+    Smale.RankThreeWhitneyModel.Space → ((ℝ × ℝ) × EuclideanSpace ℝ (Fin 3)) :=
+  Smale.RankThreeWhitneyModel.correctedSheetMap c.shearedCoordinates
+    (d.retimedSheetTransition tube.chart) (e.retimedSheetTransition tube.chart) h
+
+private theorem
+    Smale.TubularBigon.RankThreeTangentAdaptedChart.correctedCoordinates_zero {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) (p : ℝ × ℝ) :
+    c.correctedCoordinates (p, 0) = (p, 0) := by
+  rw [correctedCoordinates, Smale.RankThreeWhitneyModel.correctedSheetMap_zero]
+  exact Smale.FrameField.shearedMap_zero c.base c.normal p
+
+private theorem Smale.TubularBigon.RankThreeTangentAdaptedChart.hasFDerivAt_shearedCoordinates_zero
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {S T : Set M} {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) {p : ℝ × ℝ}
+    (hp : p ∈ Smale.WhitneyPairModel.bigon h) :
+    HasFDerivAt c.shearedCoordinates (Smale.FrameField.shearedBlock (c.base p) (c.normal p))
+      (p, 0) :=
+  Smale.FrameField.hasFDerivAt_shearedMap_zero
+    ((c.smooth_base.contDiffAt (c.open_domain.mem_nhds (c.contains hp))).differentiableAt
+      (by simp))
+    ((c.smooth_normal.contDiffAt (c.open_domain.mem_nhds (c.contains hp))).differentiableAt
+      (by simp))
+
+private theorem
+    Smale.TubularBigon.RankThreeTangentAdaptedChart.hasFDerivAt_sheared_lower {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    HasFDerivAt (c.shearedCoordinates ∘ Smale.RankThreeWhitneyModel.firstSheet)
+      ((d.sheetDifferential tube.chart t).comp Smale.WhitneyPairModel.halfTimeDerivative)
+      (2 * t - 1, 0) := by
+  have hd :=
+    (c.hasFDerivAt_shearedCoordinates_zero (tube.lowerBoundaryArc_mem_bigon ht)).comp
+      (2 * t - 1, (0 : Smale.RankThreeWhitneyModel.Lower))
+      (Smale.RankThreeWhitneyModel.hasFDerivAt_firstSheet (2 * t - 1, 0))
+  rwa [Smale.WhitneyPairModel.lowerBoundaryArc, c.lower_model_tangent ht] at hd
+
+private theorem
+    Smale.TubularBigon.RankThreeTangentAdaptedChart.hasFDerivAt_sheared_upper {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    HasFDerivAt (c.shearedCoordinates ∘ Smale.RankThreeWhitneyModel.secondSheet h)
+      ((e.sheetDifferential tube.chart t).comp Smale.WhitneyPairModel.halfTimeDerivative)
+      (2 * t - 1, 0) := by
+  have hd :=
+    (c.hasFDerivAt_shearedCoordinates_zero (tube.upperBoundaryArc_mem_bigon ht)).comp
+      (2 * t - 1, (0 : Smale.RankThreeWhitneyModel.Upper))
+      (Smale.RankThreeWhitneyModel.hasFDerivAt_secondSheet h (2 * t - 1, 0))
+  rwa [c.upper_model_tangent ht] at hd
+
+private theorem
+    Smale.TubularBigon.RankThreeTangentAdaptedChart.hasFDerivAt_correctedCoordinates_zero
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {S T : Set M} {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) {p : ℝ × ℝ}
+    (hp : p ∈ Smale.WhitneyPairModel.bigon h) :
+    HasFDerivAt c.correctedCoordinates (Smale.FrameField.shearedBlock (c.base p) (c.normal p))
+      (p, 0) := by
+  have hpr := Smale.WhitneyPairModel.bigon_subset_rectangle tube.height_pos hp
+  have ht : Smale.WhitneyPairModel.arcTime p ∈ Set.Icc (0 : ℝ) 1 := by
+    change 0 ≤ (p.1 + 1) / 2 ∧ (p.1 + 1) / 2 ≤ 1
+    constructor <;> linarith [hpr.1.1, hpr.1.2]
+  have htime : 2 * Smale.WhitneyPairModel.arcTime p - 1 = p.1 := by
+    dsimp [Smale.WhitneyPairModel.arcTime]; ring
+  have hRlo :=
+    d.hasFDerivAt_retimedSheetTransition tube.chart ht (tube.lower_chart_center_mem_target d ht)
+  have hRhi :=
+    e.hasFDerivAt_retimedSheetTransition tube.chart ht (tube.upper_chart_center_mem_target e ht)
+  have hGlo := c.hasFDerivAt_sheared_lower ht
+  have hGhi := c.hasFDerivAt_sheared_upper ht
+  rw [htime] at hRlo hRhi hGlo hGhi
+  exact
+    Smale.RankThreeWhitneyModel.hasFDerivAt_correctedSheetMap_zero
+      (c.hasFDerivAt_shearedCoordinates_zero hp) hRlo hGlo hRhi hGhi
+
+private theorem
+    Smale.TubularBigon.RankThreeTangentAdaptedChart.retimed_lower_center_germ {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    (fun s : ℝ => d.retimedSheetTransition tube.chart (s, 0)) =ᶠ[𝓝 (2 * t - 1)]
+      (fun s => c.shearedCoordinates (Smale.RankThreeWhitneyModel.firstSheet (s, 0))) := by
+  have hct : ContinuousAt (fun s : ℝ => (s + 1) / 2) (2 * t - 1) := by fun_prop
+  have heq : (2 * t - 1 + 1) / 2 = t := by ring
+  have htime : Filter.Tendsto (fun s : ℝ => (s + 1) / 2) (𝓝 (2 * t - 1)) (𝓝 t) := by
+    simpa only [heq] using hct.tendsto
+  filter_upwards [(tube.lower_sheetTransition_center_germ d ht).comp_tendsto htime] with s hs
+  change
+    d.sheetTransition tube.chart (Smale.WhitneyPairModel.sheetTimeCoordinates (s, 0)) =
+      Smale.FrameField.shearedMap c.base c.normal ((s, 0), 0)
+  rw [Smale.WhitneyPairModel.sheetTimeCoordinates_apply, Smale.FrameField.shearedMap_zero]
+  dsimp only [Function.comp_apply] at hs
+  rw [hs]
+  have hlin : 2 * ((s + 1) / 2) - 1 = s := by ring
+  simp only [Smale.WhitneyPairModel.lowerBoundaryArc, hlin]
+
+private theorem
+    Smale.TubularBigon.RankThreeTangentAdaptedChart.retimed_upper_center_germ {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    (fun s : ℝ => e.retimedSheetTransition tube.chart (s, 0)) =ᶠ[𝓝 (2 * t - 1)]
+      (fun s => c.shearedCoordinates (Smale.RankThreeWhitneyModel.secondSheet h (s, 0))) := by
+  have hct : ContinuousAt (fun s : ℝ => (s + 1) / 2) (2 * t - 1) := by fun_prop
+  have heq : (2 * t - 1 + 1) / 2 = t := by ring
+  have htime : Filter.Tendsto (fun s : ℝ => (s + 1) / 2) (𝓝 (2 * t - 1)) (𝓝 t) := by
+    simpa only [heq] using hct.tendsto
+  filter_upwards [(tube.upper_sheetTransition_center_germ e ht).comp_tendsto htime] with s hs
+  change
+    e.sheetTransition tube.chart (Smale.WhitneyPairModel.sheetTimeCoordinates (s, 0)) =
+      Smale.FrameField.shearedMap c.base c.normal ((s, h * (1 - s ^ 2)), 0)
+  rw [Smale.WhitneyPairModel.sheetTimeCoordinates_apply, Smale.FrameField.shearedMap_zero]
+  dsimp only [Function.comp_apply] at hs
+  rw [hs]
+  have hlin : 2 * ((s + 1) / 2) - 1 = s := by ring
+  simp only [Smale.WhitneyPairModel.upperBoundaryArc, hlin]
+
+private def Smale.TubularBigon.RankThreeTangentAdaptedChart.shearedDomain {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) :
+    Set Smale.RankThreeWhitneyModel.Space :=
+  Prod.fst ⁻¹' c.domain
+
+private def Smale.TubularBigon.RankThreeTangentAdaptedChart.lowerCorrectionDomain {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) :
+    Set Smale.RankThreeWhitneyModel.LowerSheet :=
+  d.retimedDomain tube.chart ∩ Smale.RankThreeWhitneyModel.firstSheet ⁻¹' c.shearedDomain
+
+private def Smale.TubularBigon.RankThreeTangentAdaptedChart.upperCorrectionDomain {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) :
+    Set Smale.RankThreeWhitneyModel.UpperSheet :=
+  e.retimedDomain tube.chart ∩ Smale.RankThreeWhitneyModel.secondSheet h ⁻¹' c.shearedDomain
+
+private def Smale.TubularBigon.RankThreeTangentAdaptedChart.centerMatchingTimes {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) : Set ℝ :=
+  interior
+    {s |
+      d.retimedSheetTransition tube.chart (s, 0) =
+          c.shearedCoordinates (Smale.RankThreeWhitneyModel.firstSheet (s, 0)) ∧
+        e.retimedSheetTransition tube.chart (s, 0) =
+          c.shearedCoordinates (Smale.RankThreeWhitneyModel.secondSheet h (s, 0))}
+
+private def Smale.TubularBigon.RankThreeTangentAdaptedChart.nonlinearDomain {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) :
+    Set Smale.RankThreeWhitneyModel.Space :=
+  Smale.RankThreeWhitneyModel.correctionDomain c.shearedDomain c.lowerCorrectionDomain
+      c.upperCorrectionDomain ∩
+    (fun p : Smale.RankThreeWhitneyModel.Space => p.1.1) ⁻¹' c.centerMatchingTimes
+
+private theorem Smale.TubularBigon.RankThreeTangentAdaptedChart.isOpen_shearedDomain {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) : IsOpen c.shearedDomain :=
+  c.open_domain.preimage continuous_fst
+
+private theorem
+    Smale.TubularBigon.RankThreeTangentAdaptedChart.isOpen_lowerCorrectionDomain {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) :
+    IsOpen c.lowerCorrectionDomain :=
+  (d.isOpen_retimedDomain tube.chart).inter
+    (c.isOpen_shearedDomain.preimage Smale.RankThreeWhitneyModel.contDiff_firstSheet.continuous)
+
+private theorem
+    Smale.TubularBigon.RankThreeTangentAdaptedChart.isOpen_upperCorrectionDomain {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) :
+    IsOpen c.upperCorrectionDomain :=
+  (e.isOpen_retimedDomain tube.chart).inter
+    (c.isOpen_shearedDomain.preimage
+      (Smale.RankThreeWhitneyModel.contDiff_secondSheet h).continuous)
+
+private theorem Smale.TubularBigon.RankThreeTangentAdaptedChart.isOpen_nonlinearDomain {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) : IsOpen c.nonlinearDomain :=
+  (Smale.RankThreeWhitneyModel.isOpen_correctionDomain c.isOpen_shearedDomain
+        c.isOpen_lowerCorrectionDomain c.isOpen_upperCorrectionDomain).inter
+    (isOpen_interior.preimage (by fun_prop))
+
+private theorem Smale.TubularBigon.RankThreeTangentAdaptedChart.contDiffOn_correctedCoordinates
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {S T : Set M} {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) :
+    ContDiffOn ℝ ∞ c.correctedCoordinates c.nonlinearDomain := by
+  have hG : ContDiffOn ℝ ∞ c.shearedCoordinates c.shearedDomain :=
+    Smale.FrameField.contDiffOn_shearedMap c.smooth_base c.smooth_normal
+  exact
+    (Smale.RankThreeWhitneyModel.contDiffOn_correctedSheetMap hG
+          ((d.contDiffOn_retimedSheetTransition tube.chart).mono Set.inter_subset_left)
+          (hG.comp Smale.RankThreeWhitneyModel.contDiff_firstSheet.contDiffOn (fun _ hp => hp.2))
+          ((e.contDiffOn_retimedSheetTransition tube.chart).mono Set.inter_subset_left)
+          (hG.comp (Smale.RankThreeWhitneyModel.contDiff_secondSheet h).contDiffOn
+            (fun _ hp => hp.2))).mono
+      Set.inter_subset_left
+
+private theorem
+    Smale.TubularBigon.RankThreeTangentAdaptedChart.centerMatchingTimes_contains {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1) : 2 * t - 1 ∈ c.centerMatchingTimes :=
+  mem_interior_iff_mem_nhds.mpr
+    ((c.retimed_lower_center_germ ht).and (c.retimed_upper_center_germ ht))
+
+private theorem
+    Smale.TubularBigon.RankThreeTangentAdaptedChart.lowerCorrectionDomain_contains_center
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {S T : Set M} {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    (2 * t - 1, (0 : Smale.RankThreeWhitneyModel.Lower)) ∈ c.lowerCorrectionDomain := by
+  refine
+    ⟨d.retimedDomain_contains_center tube.chart ht (tube.lower_chart_center_mem_target d ht), ?_⟩
+  exact c.contains (tube.lowerBoundaryArc_mem_bigon ht)
+
+private theorem
+    Smale.TubularBigon.RankThreeTangentAdaptedChart.upperCorrectionDomain_contains_center
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {S T : Set M} {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1) :
+    (2 * t - 1, (0 : Smale.RankThreeWhitneyModel.Upper)) ∈ c.upperCorrectionDomain := by
+  refine
+    ⟨e.retimedDomain_contains_center tube.chart ht (tube.upper_chart_center_mem_target e ht), ?_⟩
+  exact c.contains (tube.upperBoundaryArc_mem_bigon ht)
+
+private theorem Smale.TubularBigon.RankThreeTangentAdaptedChart.nonlinearDomain_contains_zero
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {S T : Set M} {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) {p : ℝ × ℝ}
+    (hp : p ∈ Smale.WhitneyPairModel.bigon h) :
+    (p, (0 : Smale.RankThreeWhitneyModel.Lower × Smale.RankThreeWhitneyModel.Upper)) ∈
+      c.nonlinearDomain := by
+  have hpr := Smale.WhitneyPairModel.bigon_subset_rectangle tube.height_pos hp
+  have ht : Smale.WhitneyPairModel.arcTime p ∈ Set.Icc (0 : ℝ) 1 := by
+    change 0 ≤ (p.1 + 1) / 2 ∧ (p.1 + 1) / 2 ≤ 1
+    constructor <;> linarith [hpr.1.1, hpr.1.2]
+  have htime : 2 * Smale.WhitneyPairModel.arcTime p - 1 = p.1 := by
+    dsimp [Smale.WhitneyPairModel.arcTime]; ring
+  have hlo := c.lowerCorrectionDomain_contains_center ht
+  have hhi := c.upperCorrectionDomain_contains_center ht
+  have hmatch := c.centerMatchingTimes_contains ht
+  rw [htime] at hlo hhi hmatch
+  exact ⟨⟨c.contains hp, ⟨hlo, hlo⟩, ⟨hhi, hhi⟩⟩, hmatch⟩
+
+private theorem
+    Smale.TubularBigon.RankThreeTangentAdaptedChart.lower_native_parameters {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e)
+    {q : Smale.RankThreeWhitneyModel.LowerSheet}
+    (hq : Smale.RankThreeWhitneyModel.firstSheet q ∈ c.nonlinearDomain) :
+    (Smale.WhitneyPairModel.sheetTimeCoordinates q, (0 : EuclideanSpace ℝ (Fin 3))) ∈
+        d.chart.source ∧
+      d.chart (Smale.WhitneyPairModel.sheetTimeCoordinates q, 0) ∈ tube.chart.target :=
+  hq.1.2.1.1.1
+
+private theorem
+    Smale.TubularBigon.RankThreeTangentAdaptedChart.upper_native_parameters {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e)
+    {q : Smale.RankThreeWhitneyModel.UpperSheet}
+    (hq : Smale.RankThreeWhitneyModel.secondSheet h q ∈ c.nonlinearDomain) :
+    (Smale.WhitneyPairModel.sheetTimeCoordinates q, (0 : EuclideanSpace ℝ (Fin 2))) ∈
+        e.chart.source ∧
+      e.chart (Smale.WhitneyPairModel.sheetTimeCoordinates q, 0) ∈ tube.chart.target :=
+  hq.1.2.2.1.1
+
+private theorem
+    Smale.TubularBigon.RankThreeTangentAdaptedChart.correctedCoordinates_lower_of_mem_domain
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {S T : Set M} {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e)
+    {q : Smale.RankThreeWhitneyModel.LowerSheet}
+    (hq : Smale.RankThreeWhitneyModel.firstSheet q ∈ c.nonlinearDomain) :
+    c.correctedCoordinates (Smale.RankThreeWhitneyModel.firstSheet q) =
+      d.retimedSheetTransition tube.chart q := by
+  have hJ : q.1 ∈ c.centerMatchingTimes := hq.2
+  have hm :=
+    (show
+        c.centerMatchingTimes ⊆
+          {s : ℝ |
+            d.retimedSheetTransition tube.chart (s, 0) =
+                c.shearedCoordinates (Smale.RankThreeWhitneyModel.firstSheet (s, 0)) ∧
+              e.retimedSheetTransition tube.chart (s, 0) =
+                c.shearedCoordinates (Smale.RankThreeWhitneyModel.secondSheet h (s, 0))}
+        from interior_subset)
+      hJ
+  exact Smale.RankThreeWhitneyModel.correctedSheetMap_lower q hm.1
+
+private theorem
+    Smale.TubularBigon.RankThreeTangentAdaptedChart.correctedCoordinates_upper_of_mem_domain
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {S T : Set M} {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e)
+    {q : Smale.RankThreeWhitneyModel.UpperSheet}
+    (hq : Smale.RankThreeWhitneyModel.secondSheet h q ∈ c.nonlinearDomain) :
+    c.correctedCoordinates (Smale.RankThreeWhitneyModel.secondSheet h q) =
+      e.retimedSheetTransition tube.chart q := by
+  have hJ : q.1 ∈ c.centerMatchingTimes := hq.2
+  have hm :=
+    (show
+        c.centerMatchingTimes ⊆
+          {s : ℝ |
+            d.retimedSheetTransition tube.chart (s, 0) =
+                c.shearedCoordinates (Smale.RankThreeWhitneyModel.firstSheet (s, 0)) ∧
+              e.retimedSheetTransition tube.chart (s, 0) =
+                c.shearedCoordinates (Smale.RankThreeWhitneyModel.secondSheet h (s, 0))}
+        from interior_subset)
+      hJ
+  exact Smale.RankThreeWhitneyModel.correctedSheetMap_upper q hm.2
+
+private structure
+    Smale.TubularBigon.RankThreeSheetParametrizedChart {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M} {a b : ℝ → M}
+    {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ} {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    (tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3)
+    (d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map)
+    (e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map) where
+  radius : ℝ
+  radius_pos : 0 < radius
+  chart :
+    PartialDiffeomorph 𝓘(ℝ, Smale.RankThreeWhitneyModel.Space) 𝓘(ℝ, E)
+      Smale.RankThreeWhitneyModel.Space M ∞
+  source_contains : Smale.WhitneyPairModel.bigon h ×ˢ Metric.closedBall 0 radius ⊆ chart.source
+  zero_section : ∀ p, chart (p, 0) = tube.map p
+  target_subset : chart.target ⊆ tube.chart.target
+  lower_source :
+    ∀ q : Smale.RankThreeWhitneyModel.LowerSheet,
+      Smale.RankThreeWhitneyModel.firstSheet q ∈ chart.source →
+        (Smale.WhitneyPairModel.sheetTimeCoordinates q, (0 : EuclideanSpace ℝ (Fin 3))) ∈
+          d.chart.source
+  upper_source :
+    ∀ q : Smale.RankThreeWhitneyModel.UpperSheet,
+      Smale.RankThreeWhitneyModel.secondSheet h q ∈ chart.source →
+        (Smale.WhitneyPairModel.sheetTimeCoordinates q, (0 : EuclideanSpace ℝ (Fin 2))) ∈
+          e.chart.source
+  lower :
+    ∀ q : Smale.RankThreeWhitneyModel.LowerSheet,
+      Smale.RankThreeWhitneyModel.firstSheet q ∈ chart.source →
+        chart (Smale.RankThreeWhitneyModel.firstSheet q) =
+          d.chart (Smale.WhitneyPairModel.sheetTimeCoordinates q, 0)
+  upper :
+    ∀ q : Smale.RankThreeWhitneyModel.UpperSheet,
+      Smale.RankThreeWhitneyModel.secondSheet h q ∈ chart.source →
+        chart (Smale.RankThreeWhitneyModel.secondSheet h q) =
+          e.chart (Smale.WhitneyPairModel.sheetTimeCoordinates q, 0)
+
+private theorem
+    Smale.TubularBigon.RankThreeTangentAdaptedChart.nonempty_rankThreeSheetParametrizedChart
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {S T : Set M} {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeTangentAdaptedChart tube d e) :
+    Nonempty (Smale.TubularBigon.RankThreeSheetParametrizedChart tube d e) := by
+  have hinj :
+    Set.InjOn c.correctedCoordinates
+      (Smale.WhitneyPairModel.bigon h ×ˢ
+        {(0 : Smale.RankThreeWhitneyModel.Lower × Smale.RankThreeWhitneyModel.Upper)}) := by
+    rintro ⟨p, z⟩ ⟨hp, hz⟩ ⟨q, w⟩ ⟨hq, hw⟩ heq
+    have hz0 : z = 0 := hz
+    have hw0 : w = 0 := hw
+    subst z
+    subst w
+    rw [c.correctedCoordinates_zero, c.correctedCoordinates_zero] at heq
+    exact Prod.ext (congrArg (fun v : (ℝ × ℝ) × EuclideanSpace ℝ (Fin 3) => v.1) heq) rfl
+  have hlocal :
+    ∀
+      p ∈
+        Smale.WhitneyPairModel.bigon h ×ˢ
+          {(0 : Smale.RankThreeWhitneyModel.Lower × Smale.RankThreeWhitneyModel.Upper)},
+      IsLocalDiffeomorphAt 𝓘(ℝ, Smale.RankThreeWhitneyModel.Space)
+        𝓘(ℝ, (ℝ × ℝ) × EuclideanSpace ℝ (Fin 3)) ∞ c.correctedCoordinates p := by
+    rintro ⟨p, z⟩ ⟨hp, hz⟩
+    have hz0 : z = 0 := hz
+    subst z
+    apply
+      Smale.isLocalDiffeomorphAt_of_contMDiffOn (D := Smale.RankThreeWhitneyModel.Space) (E :=
+        (ℝ × ℝ) × EuclideanSpace ℝ (Fin 3)) (M := (ℝ × ℝ) × EuclideanSpace ℝ (Fin 3))
+        c.isOpen_nonlinearDomain (c.nonlinearDomain_contains_zero hp)
+        c.contDiffOn_correctedCoordinates.contMDiffOn
+    rw [mfderiv_eq_fderiv, (c.hasFDerivAt_correctedCoordinates_zero hp).fderiv]
+    exact
+      Smale.FrameField.isInvertible_shearedBlock (c.base p) (c.normal p)
+        (c.normal_invertible p (c.contains hp))
+  have hzeroDomain :
+    Smale.WhitneyPairModel.bigon h ×ˢ
+        {(0 : Smale.RankThreeWhitneyModel.Lower × Smale.RankThreeWhitneyModel.Upper)} ⊆
+      c.nonlinearDomain := by
+    rintro ⟨p, z⟩ ⟨hp, hz⟩
+    have hz0 : z = 0 := hz
+    subst z
+    exact c.nonlinearDomain_contains_zero hp
+  obtain ⟨χ, hzeroχ, hχD, hχ⟩ :=
+    Smale.exists_partialDiffeomorph_near_compact
+      ((Smale.WhitneyPairModel.isCompact_bigon tube.height_pos).prod isCompact_singleton) hinj
+      hlocal c.isOpen_nonlinearDomain hzeroDomain
+  let Φ := χ.trans tube.chart
+  have hzeroΦ :
+    Smale.WhitneyPairModel.bigon h ×ˢ
+        {(0 : Smale.RankThreeWhitneyModel.Lower × Smale.RankThreeWhitneyModel.Upper)} ⊆
+      Φ.source := by
+    rintro ⟨p, z⟩ ⟨hp, hz⟩
+    have hz0 : z = 0 := hz
+    subst z
+    refine ⟨hzeroχ ⟨hp, rfl⟩, ?_⟩
+    change χ (p, 0) ∈ tube.chart.source
+    rw [hχ, c.correctedCoordinates_zero]
+    exact tube.source_contains ⟨hp, Metric.mem_closedBall_self tube.radius_pos.le⟩
+  obtain ⟨ε, hε, hsource⟩ :=
+    Smale.DiskFraming.exists_pos_prod_closedBall_subset
+      (Smale.WhitneyPairModel.isCompact_bigon tube.height_pos) Φ.open_source hzeroΦ
+  have hformula (p : Smale.RankThreeWhitneyModel.Space) :
+    Φ p = tube.chart (c.correctedCoordinates p) := by
+    change tube.chart (χ p) = tube.chart (c.correctedCoordinates p)
+    rw [hχ]
+  refine
+    ⟨{  radius := ε
+        radius_pos := hε
+        chart := Φ
+        source_contains := hsource
+        zero_section := ?_
+        target_subset := fun _ hy => hy.1
+        lower_source := fun q hq => (c.lower_native_parameters (hχD hq.1)).1
+        upper_source := fun q hq => (c.upper_native_parameters (hχD hq.1)).1
+        lower := ?_
+        upper := ?_ }⟩
+  · intro p
+    rw [hformula, c.correctedCoordinates_zero, tube.zero_section]
+  · intro q hq
+    rw [hformula, c.correctedCoordinates_lower_of_mem_domain (hχD hq.1)]
+    exact tube.chart.right_inv' (c.lower_native_parameters (hχD hq.1)).2
+  · intro q hq
+    rw [hformula, c.correctedCoordinates_upper_of_mem_domain (hχD hq.1)]
+    exact tube.chart.right_inv' (c.upper_native_parameters (hχD hq.1)).2
+
+private theorem Smale.TubularBigon.nonempty_rankThreeSheetParametrizedChart_of_opposite_corner_signs
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {S T : Set M} {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    (tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3)
+    (d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map)
+    (e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map)
+    (hsign : tube.rankThreeSheetPairDet d e 0 * tube.rankThreeSheetPairDet d e 1 < 0) :
+    Nonempty (RankThreeSheetParametrizedChart tube d e) := by
+  obtain ⟨c⟩ := tube.nonempty_rankThreeTangentAdaptedChart_of_opposite_corner_signs d e hsign
+  exact c.nonempty_rankThreeSheetParametrizedChart
+
+private theorem Smale.TubularBigon.RankThreeSheetParametrizedChart.lower_mem_sheet {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeSheetParametrizedChart tube d e)
+    {q : Smale.RankThreeWhitneyModel.LowerSheet}
+    (hq : Smale.RankThreeWhitneyModel.firstSheet q ∈ c.chart.source) :
+    c.chart (Smale.RankThreeWhitneyModel.firstSheet q) ∈ S := by
+  rw [c.lower q hq]
+  exact (d.sheet _ (c.lower_source q hq)).mpr rfl
+
+private theorem Smale.TubularBigon.RankThreeSheetParametrizedChart.upper_mem_sheet {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeSheetParametrizedChart tube d e)
+    {q : Smale.RankThreeWhitneyModel.UpperSheet}
+    (hq : Smale.RankThreeWhitneyModel.secondSheet h q ∈ c.chart.source) :
+    c.chart (Smale.RankThreeWhitneyModel.secondSheet h q) ∈ T := by
+  rw [c.upper q hq]
+  exact (e.sheet _ (c.upper_source q hq)).mpr rfl
+
+private theorem
+    Smale.SheetRecognition.eventually_mem_sheet_iff {W D B E M : Type*} [NormedAddCommGroup W]
+    [NormedSpace ℝ W] [NormedAddCommGroup D] [NormedSpace ℝ D] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] (Φ : PartialDiffeomorph 𝓘(ℝ, W) 𝓘(ℝ, E) W M ∞)
+    (ψ : PartialDiffeomorph 𝓘(ℝ, D × B) 𝓘(ℝ, E) (D × B) M ∞) {S : Set M}
+    (hsheet : ∀ q ∈ ψ.source, ψ q ∈ S ↔ q.2 = 0) {ι : D → W} (hι : Continuous ι) {σ τ : D → D}
+    (hτ : Continuous τ) (hτσ : Function.LeftInverse τ σ) (hστ : Function.RightInverse τ σ)
+    (hparam : ∀ q : D, ι q ∈ Φ.source → (σ q, (0 : B)) ∈ ψ.source ∧ Φ (ι q) = ψ (σ q, 0)) {q₀ : D}
+    (hq₀ : ι q₀ ∈ Φ.source) : ∀ᶠ z in 𝓝 (ι q₀), z ∈ Φ.source ∧ (Φ z ∈ S ↔ z ∈ Set.range ι) := by
+  let recover : W → W := fun z => ι (τ ((ψ.symm (Φ z)).1))
+  have htarget : Φ (ι q₀) ∈ ψ.target := by
+    rw [(hparam q₀ hq₀).2]
+    exact ψ.map_source' (hparam q₀ hq₀).1
+  have hΦ : ContinuousAt Φ (ι q₀) :=
+    (Φ.contMDiffOn_toFun.contMDiffAt (Φ.open_source.mem_nhds hq₀)).continuousAt
+  have hψ : ContinuousAt ψ.symm (Φ (ι q₀)) :=
+    (ψ.contMDiffOn_invFun.contMDiffAt (ψ.open_target.mem_nhds htarget)).continuousAt
+  have hrec : ContinuousAt recover (ι q₀) :=
+    hι.continuousAt.comp (hτ.continuousAt.comp (continuousAt_fst.comp (hψ.comp hΦ)))
+  have hreczero : recover (ι q₀) = ι q₀ := by
+    have hcoord : ψ.symm (Φ (ι q₀)) = (σ q₀, (0 : B)) := by
+      rw [(hparam q₀ hq₀).2]
+      exact ψ.left_inv' (hparam q₀ hq₀).1
+    change ι (τ ((ψ.symm (Φ (ι q₀))).1)) = ι q₀
+    rw [hcoord]
+    exact congrArg ι (hτσ q₀)
+  have hrecSource : ∀ᶠ z in 𝓝 (ι q₀), recover z ∈ Φ.source :=
+    hrec.preimage_mem_nhds (by rw [hreczero]; exact Φ.open_source.mem_nhds hq₀)
+  have htargetNear : ∀ᶠ z in 𝓝 (ι q₀), Φ z ∈ ψ.target :=
+    hΦ.preimage_mem_nhds (ψ.open_target.mem_nhds htarget)
+  filter_upwards [Φ.open_source.mem_nhds hq₀, htargetNear, hrecSource] with z hz hzψ hzrec
+  refine ⟨hz, ?_⟩
+  constructor
+  · intro hzS
+    let q := ψ.symm (Φ z)
+    have hq : q ∈ ψ.source := ψ.map_target' hzψ
+    have hqzero : q.2 = 0 :=
+      (hsheet q hq).mp
+        (by
+          change ψ (ψ.symm (Φ z)) ∈ S
+          have he : ψ (ψ.symm (Φ z)) = Φ z := ψ.right_inv' hzψ
+          rw [he]
+          exact hzS)
+    have heq : Φ (recover z) = Φ z := by
+      change Φ (ι (τ q.1)) = Φ z
+      rw [(hparam (τ q.1) hzrec).2, hστ q.1]
+      have hqeq : (q.1, (0 : B)) = q := by
+        apply Prod.ext
+        · rfl
+        · exact hqzero.symm
+      rw [hqeq]
+      exact ψ.right_inv' hzψ
+    exact ⟨τ q.1, Φ.toPartialEquiv.injOn hzrec hz heq⟩
+  · rintro ⟨q, hqz⟩
+    have hq : ι q ∈ Φ.source := hqz.symm ▸ hz
+    rw [← hqz, (hparam q hq).2]
+    exact (hsheet _ (hparam q hq).1).mpr rfl
+
+private def Smale.WhitneyPairModel.sheetTimeInverse {A : Type*} (q : (ℝ × A)) : (ℝ × A) :=
+  (2 * q.1 - 1, q.2)
+
+private theorem Smale.WhitneyPairModel.contDiff_sheetTimeInverse {A : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] : ContDiff ℝ ∞ (sheetTimeInverse (A := A)) := by
+  unfold sheetTimeInverse
+  fun_prop
+
+private theorem
+    Smale.WhitneyPairModel.sheetTimeInverse_leftInverse {A : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] : Function.LeftInverse (sheetTimeInverse (A := A)) sheetTimeCoordinates := by
+  intro q
+  rw [sheetTimeCoordinates_apply]
+  apply Prod.ext
+  · change 2 * ((q.1 + 1) / 2) - 1 = q.1
+    ring
+  · rfl
+
+private theorem
+    Smale.WhitneyPairModel.sheetTimeInverse_rightInverse {A : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] : Function.RightInverse (sheetTimeInverse (A := A)) sheetTimeCoordinates := by
+  intro q
+  rw [sheetTimeCoordinates_apply]
+  apply Prod.ext
+  · change (2 * q.1 - 1 + 1) / 2 = q.1
+    ring
+  · rfl
+
+private theorem
+    Smale.TubularBigon.RankThreeSheetParametrizedChart.eventually_lower_mem_iff {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeSheetParametrizedChart tube d e)
+    {q : Smale.RankThreeWhitneyModel.LowerSheet}
+    (hq : Smale.RankThreeWhitneyModel.firstSheet q ∈ c.chart.source) :
+    ∀ᶠ z in 𝓝 (Smale.RankThreeWhitneyModel.firstSheet q),
+      z ∈ c.chart.source ∧
+        (c.chart z ∈ S ↔ z ∈ Set.range Smale.RankThreeWhitneyModel.firstSheet) :=
+  Smale.SheetRecognition.eventually_mem_sheet_iff c.chart d.chart d.sheet
+    Smale.RankThreeWhitneyModel.contDiff_firstSheet.continuous
+    Smale.WhitneyPairModel.contDiff_sheetTimeInverse.continuous
+    Smale.WhitneyPairModel.sheetTimeInverse_leftInverse
+    Smale.WhitneyPairModel.sheetTimeInverse_rightInverse
+    (fun q hq => ⟨c.lower_source q hq, c.lower q hq⟩) hq
+
+private theorem
+    Smale.TubularBigon.RankThreeSheetParametrizedChart.eventually_upper_mem_iff {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeSheetParametrizedChart tube d e)
+    {q : Smale.RankThreeWhitneyModel.UpperSheet}
+    (hq : Smale.RankThreeWhitneyModel.secondSheet h q ∈ c.chart.source) :
+    ∀ᶠ z in 𝓝 (Smale.RankThreeWhitneyModel.secondSheet h q),
+      z ∈ c.chart.source ∧
+        (c.chart z ∈ T ↔ z ∈ Set.range (Smale.RankThreeWhitneyModel.secondSheet h)) :=
+  Smale.SheetRecognition.eventually_mem_sheet_iff c.chart e.chart e.sheet
+    (Smale.RankThreeWhitneyModel.contDiff_secondSheet h).continuous
+    Smale.WhitneyPairModel.contDiff_sheetTimeInverse.continuous
+    Smale.WhitneyPairModel.sheetTimeInverse_leftInverse
+    Smale.WhitneyPairModel.sheetTimeInverse_rightInverse
+    (fun q hq => ⟨c.upper_source q hq, c.upper q hq⟩) hq
+
+
+private theorem Smale.TubularBigon.lower_center_mem_sheet {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M} {a b : ℝ → M}
+    {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ} {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁} {n : ℕ}
+    (tube : Smale.TubularBigon (E := E) S T a b k.map l.map h n) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1) : tube.map (2 * t - 1, 0) ∈ S := by
+  rw [tube.lower t ht, ← k.center t ht]
+  exact
+    (k.first_sheet (t, 0)
+          (k.contains_strip ⟨ht, neg_nonpos.mpr k.width_pos.le, k.width_pos.le⟩)).mpr
+      rfl
+
+private theorem Smale.TubularBigon.upper_center_mem_sheet {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M} {a b : ℝ → M}
+    {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ} {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁} {n : ℕ}
+    (tube : Smale.TubularBigon (E := E) S T a b k.map l.map h n) {t : ℝ}
+    (ht : t ∈ Set.Icc (0 : ℝ) 1) : tube.map (Smale.WhitneyPairModel.upperBoundaryArc h t) ∈ T := by
+  change tube.map (2 * t - 1, h * (1 - (2 * t - 1) ^ 2)) ∈ T
+  rw [tube.upper t ht, ← l.center t ht]
+  exact
+    (l.first_sheet (t, 0)
+          (l.contains_strip ⟨ht, neg_nonpos.mpr l.width_pos.le, l.width_pos.le⟩)).mpr
+      rfl
+
+private theorem Smale.TubularBigon.map_mem_first_iff {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M} {a b : ℝ → M}
+    {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ} {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁} {n : ℕ}
+    (tube : Smale.TubularBigon (E := E) S T a b k.map l.map h n) {p : ℝ × ℝ}
+    (hp : p ∈ Smale.WhitneyPairModel.bigon h) : tube.map p ∈ S ↔ p.2 = 0 := by
+  constructor
+  · intro hpS
+    have hfront : p ∈ frontier (Smale.WhitneyPairModel.bigon h) := by
+      rw [frontier, (Smale.WhitneyPairModel.isClosed_bigon h).closure_eq]
+      exact ⟨hp, fun hi => tube.interior_avoids p hi (Or.inl hpS)⟩
+    obtain ⟨t, ht, rfl | rfl⟩ :=
+      (Smale.WhitneyPairModel.mem_frontier_bigon_iff_exists_time tube.height_pos p).mp hfront
+    · rfl
+    · have hlt : (t, (0 : ℝ)) ∈ l.domain :=
+        l.contains_strip ⟨ht, neg_nonpos.mpr l.width_pos.le, l.width_pos.le⟩
+      rw [tube.upper t ht, ← l.center t ht] at hpS
+      rcases (l.second_sheet (t, 0) hlt).mp hpS with ht0 | ht1
+      · change t = 0 at ht0
+        rw [ht0]
+        norm_num
+      · change t = 1 at ht1
+        rw [ht1]
+        norm_num
+  · intro hpzero
+    have hpr := Smale.WhitneyPairModel.bigon_subset_rectangle tube.height_pos hp
+    have ht : Smale.WhitneyPairModel.arcTime p ∈ Set.Icc (0 : ℝ) 1 := by
+      change 0 ≤ (p.1 + 1) / 2 ∧ (p.1 + 1) / 2 ≤ 1
+      constructor <;> linarith [hpr.1.1, hpr.1.2]
+    have hbase : p.1 = 2 * Smale.WhitneyPairModel.arcTime p - 1 := by
+      dsimp [Smale.WhitneyPairModel.arcTime]; ring
+    have heq : p = (2 * Smale.WhitneyPairModel.arcTime p - 1, 0) := Prod.ext hbase hpzero
+    rw [heq]
+    exact tube.lower_center_mem_sheet ht
+
+private theorem Smale.TubularBigon.map_mem_second_iff {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M} {a b : ℝ → M}
+    {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ} {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁} {n : ℕ}
+    (tube : Smale.TubularBigon (E := E) S T a b k.map l.map h n) {p : ℝ × ℝ}
+    (hp : p ∈ Smale.WhitneyPairModel.bigon h) : tube.map p ∈ T ↔ p.2 = h * (1 - p.1 ^ 2) := by
+  constructor
+  · intro hpT
+    have hfront : p ∈ frontier (Smale.WhitneyPairModel.bigon h) := by
+      rw [frontier, (Smale.WhitneyPairModel.isClosed_bigon h).closure_eq]
+      exact ⟨hp, fun hi => tube.interior_avoids p hi (Or.inr hpT)⟩
+    obtain ⟨t, ht, rfl | rfl⟩ :=
+      (Smale.WhitneyPairModel.mem_frontier_bigon_iff_exists_time tube.height_pos p).mp hfront
+    · have hkt : (t, (0 : ℝ)) ∈ k.domain :=
+        k.contains_strip ⟨ht, neg_nonpos.mpr k.width_pos.le, k.width_pos.le⟩
+      rw [tube.lower t ht, ← k.center t ht] at hpT
+      rcases (k.second_sheet (t, 0) hkt).mp hpT with ht0 | ht1
+      · change t = 0 at ht0
+        rw [ht0]
+        norm_num
+      · change t = 1 at ht1
+        rw [ht1]
+        norm_num
+    · rfl
+  · intro hpupper
+    have hpr := Smale.WhitneyPairModel.bigon_subset_rectangle tube.height_pos hp
+    have ht : Smale.WhitneyPairModel.arcTime p ∈ Set.Icc (0 : ℝ) 1 := by
+      change 0 ≤ (p.1 + 1) / 2 ∧ (p.1 + 1) / 2 ≤ 1
+      constructor <;> linarith [hpr.1.1, hpr.1.2]
+    have hbase : p.1 = 2 * Smale.WhitneyPairModel.arcTime p - 1 := by
+      dsimp [Smale.WhitneyPairModel.arcTime]; ring
+    have heq : p = Smale.WhitneyPairModel.upperBoundaryArc h (Smale.WhitneyPairModel.arcTime p) :=
+      by
+      apply Prod.ext hbase
+      change p.2 = h * (1 - (2 * Smale.WhitneyPairModel.arcTime p - 1) ^ 2)
+      rw [← hbase]
+      exact hpupper
+    rw [heq]
+    exact tube.upper_center_mem_sheet ht
+
+private theorem Smale.SheetRecognition.exists_open_recognition_domain {W E M : Type*}
+    [NormedAddCommGroup W] [NormedSpace ℝ W] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] (Φ : PartialDiffeomorph 𝓘(ℝ, W) 𝓘(ℝ, E) W M ∞)
+    {S : Set M} {A K : Set W} (hS : IsClosed S) (hK : K ⊆ Φ.source)
+    (hforward : ∀ z ∈ Φ.source, z ∈ A → Φ z ∈ S)
+    (hlocal : ∀ z ∈ Φ.source, z ∈ A → ∀ᶠ w in 𝓝 z, w ∈ Φ.source ∧ (Φ w ∈ S ↔ w ∈ A))
+    (hcontact : ∀ z ∈ K, Φ z ∈ S ↔ z ∈ A) :
+    ∃ U : Set W, IsOpen U ∧ K ⊆ U ∧ U ⊆ Φ.source ∧ ∀ z ∈ U, Φ z ∈ S ↔ z ∈ A := by
+  have hnear : ∀ z ∈ K, ∀ᶠ w in 𝓝 z, w ∈ Φ.source ∧ (Φ w ∈ S ↔ w ∈ A) := by
+    intro z hz
+    by_cases hzA : z ∈ A
+    · exact hlocal z (hK hz) hzA
+    have hzS : Φ z ∉ S := fun hs => hzA ((hcontact z hz).mp hs)
+    have hΦ : ContinuousAt Φ z :=
+      (Φ.contMDiffOn_toFun.contMDiffAt (Φ.open_source.mem_nhds (hK hz))).continuousAt
+    have havoid : ∀ᶠ w in 𝓝 z, Φ w ∉ S := hΦ.preimage_mem_nhds (hS.isOpen_compl.mem_nhds hzS)
+    filter_upwards [Φ.open_source.mem_nhds (hK hz), havoid] with w hw hwS
+    exact ⟨hw, ⟨fun hs => (hwS hs).elim, fun ha => (hwS (hforward w hw ha)).elim⟩⟩
+  let U := interior {z : W | z ∈ Φ.source ∧ (Φ z ∈ S ↔ z ∈ A)}
+  have hsub : U ⊆ {z : W | z ∈ Φ.source ∧ (Φ z ∈ S ↔ z ∈ A)} := interior_subset
+  exact
+    ⟨U, isOpen_interior, fun z hz => mem_interior_iff_mem_nhds.mpr (hnear z hz), fun _ hz =>
+      (hsub hz).1, fun _ hz => (hsub hz).2⟩
+
+private theorem Smale.RankThreeWhitneyModel.zero_mem_firstSheet_iff (p : ℝ × ℝ) :
+    (p, (0 : Lower × Upper)) ∈ Set.range firstSheet ↔ p.2 = 0 := by
+  constructor
+  · rintro ⟨q, hq⟩
+    exact (congrArg (fun z : Space => z.1.2) hq).symm
+  · intro hp
+    refine ⟨(p.1, 0), ?_⟩
+    exact Prod.ext (Prod.ext rfl hp.symm) rfl
+
+private theorem Smale.RankThreeWhitneyModel.zero_mem_secondSheet_iff (h : ℝ) (p : ℝ × ℝ) :
+    (p, (0 : Lower × Upper)) ∈ Set.range (secondSheet h) ↔ p.2 = h * (1 - p.1 ^ 2) := by
+  constructor
+  · rintro ⟨q, hq⟩
+    have hs : q.1 = p.1 := congrArg (fun z : Space => z.1.1) hq
+    have ht : h * (1 - q.1 ^ 2) = p.2 := congrArg (fun z : Space => z.1.2) hq
+    rw [hs] at ht
+    exact ht.symm
+  · intro hp
+    refine ⟨(p.1, 0), ?_⟩
+    exact Prod.ext (Prod.ext rfl hp.symm) rfl
+
+private theorem
+    Smale.TubularBigon.RankThreeSheetParametrizedChart.exists_open_full_sheet_neighborhood
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {S T : Set M} {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeSheetParametrizedChart tube d e) (hS : IsClosed S)
+    (hT : IsClosed T) :
+    ∃ U : Set Smale.RankThreeWhitneyModel.Space,
+      IsOpen U ∧
+        Smale.WhitneyPairModel.bigon h ×ˢ
+              {(0 : Smale.RankThreeWhitneyModel.Lower × Smale.RankThreeWhitneyModel.Upper)} ⊆
+            U ∧
+          U ⊆ c.chart.source ∧
+            (∀ z ∈ U, c.chart z ∈ S ↔ z ∈ Set.range Smale.RankThreeWhitneyModel.firstSheet) ∧
+              ∀ z ∈ U,
+                c.chart z ∈ T ↔ z ∈ Set.range (Smale.RankThreeWhitneyModel.secondSheet h) := by
+  have hzero :
+    Smale.WhitneyPairModel.bigon h ×ˢ
+        {(0 : Smale.RankThreeWhitneyModel.Lower × Smale.RankThreeWhitneyModel.Upper)} ⊆
+      c.chart.source := by
+    rintro ⟨p, z⟩ ⟨hp, hz⟩
+    have hz0 : z = 0 := hz
+    subst z
+    exact c.source_contains ⟨hp, Metric.mem_closedBall_self c.radius_pos.le⟩
+  have hfirst :
+    ∀
+      z ∈
+        Smale.WhitneyPairModel.bigon h ×ˢ
+          {(0 : Smale.RankThreeWhitneyModel.Lower × Smale.RankThreeWhitneyModel.Upper)},
+      c.chart z ∈ S ↔ z ∈ Set.range Smale.RankThreeWhitneyModel.firstSheet := by
+    rintro ⟨p, z⟩ ⟨hp, hz⟩
+    have hz0 : z = 0 := hz
+    subst z
+    rw [c.zero_section]
+    exact
+      (tube.map_mem_first_iff hp).trans
+        (Smale.RankThreeWhitneyModel.zero_mem_firstSheet_iff p).symm
+  have hsecond :
+    ∀
+      z ∈
+        Smale.WhitneyPairModel.bigon h ×ˢ
+          {(0 : Smale.RankThreeWhitneyModel.Lower × Smale.RankThreeWhitneyModel.Upper)},
+      c.chart z ∈ T ↔ z ∈ Set.range (Smale.RankThreeWhitneyModel.secondSheet h) := by
+    rintro ⟨p, z⟩ ⟨hp, hz⟩
+    have hz0 : z = 0 := hz
+    subst z
+    rw [c.zero_section]
+    exact
+      (tube.map_mem_second_iff hp).trans
+        (Smale.RankThreeWhitneyModel.zero_mem_secondSheet_iff h p).symm
+  obtain ⟨U, hU, hKU, hUsource, hUS⟩ :=
+    Smale.SheetRecognition.exists_open_recognition_domain c.chart (A :=
+      Set.range Smale.RankThreeWhitneyModel.firstSheet) hS hzero
+      (fun z hz ⟨q, hq⟩ => by
+        rw [← hq] at hz ⊢
+        exact c.lower_mem_sheet hz)
+      (fun z hz ⟨q, hq⟩ => by
+        rw [← hq] at hz ⊢
+        exact c.eventually_lower_mem_iff hz)
+      hfirst
+  obtain ⟨V, hV, hKV, -, hVT⟩ :=
+    Smale.SheetRecognition.exists_open_recognition_domain c.chart (A :=
+      Set.range (Smale.RankThreeWhitneyModel.secondSheet h)) hT hzero
+      (fun z hz ⟨q, hq⟩ => by
+        rw [← hq] at hz ⊢
+        exact c.upper_mem_sheet hz)
+      (fun z hz ⟨q, hq⟩ => by
+        rw [← hq] at hz ⊢
+        exact c.eventually_upper_mem_iff hz)
+      hsecond
+  exact
+    ⟨U ∩ V, hU.inter hV, fun z hz => ⟨hKU hz, hKV hz⟩, fun _ hz => hUsource hz.1, fun z hz =>
+      hUS z hz.1, fun z hz => hVT z hz.2⟩
+
+private def Smale.RankThreeWhitneyModel.nativeFirstSheet {F H M : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [TopologicalSpace H] {J : ModelWithCorners ℝ F H} [TopologicalSpace M]
+    [ChartedSpace H M] (Φ : PartialDiffeomorph 𝓘(ℝ, Space) J Space M ∞) : Set M :=
+  Φ '' (Set.range firstSheet ∩ Φ.source)
+
+private def Smale.RankThreeWhitneyModel.nativeSecondSheet {F H M : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [TopologicalSpace H] {J : ModelWithCorners ℝ F H} [TopologicalSpace M]
+    [ChartedSpace H M] (Φ : PartialDiffeomorph 𝓘(ℝ, Space) J Space M ∞) (h : ℝ) : Set M :=
+  Φ '' (Set.range (secondSheet h) ∩ Φ.source)
+
+private structure Smale.TubularBigon.RankThreeCompatibleChart {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M} {a b : ℝ → M}
+    {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ} {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    (tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3) where
+  radius : ℝ
+  radius_pos : 0 < radius
+  chart :
+    PartialDiffeomorph 𝓘(ℝ, Smale.RankThreeWhitneyModel.Space) 𝓘(ℝ, E)
+      Smale.RankThreeWhitneyModel.Space M ∞
+  source_contains : Smale.WhitneyPairModel.bigon h ×ˢ Metric.closedBall 0 radius ⊆ chart.source
+  zero_section : ∀ p, chart (p, 0) = tube.map p
+  target_subset : chart.target ⊆ tube.chart.target
+  first_sheet :
+    ∀ z ∈ chart.source, chart z ∈ S ↔ z ∈ Set.range Smale.RankThreeWhitneyModel.firstSheet
+  second_sheet :
+    ∀ z ∈ chart.source, chart z ∈ T ↔ z ∈ Set.range (Smale.RankThreeWhitneyModel.secondSheet h)
+
+private theorem Smale.TubularBigon.RankThreeSheetParametrizedChart.nonempty_rankThreeCompatibleChart
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {S T : Set M} {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    {d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map}
+    {e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map}
+    (c : Smale.TubularBigon.RankThreeSheetParametrizedChart tube d e) (hS : IsClosed S)
+    (hT : IsClosed T) : Nonempty (Smale.TubularBigon.RankThreeCompatibleChart tube) := by
+  obtain ⟨U, hU, hKU, hUsource, hfirst, hsecond⟩ := c.exists_open_full_sheet_neighborhood hS hT
+  have hlocal :
+    IsLocalDiffeomorphOn 𝓘(ℝ, Smale.RankThreeWhitneyModel.Space) 𝓘(ℝ, E) ∞ c.chart U := fun z =>
+    ⟨c.chart, hUsource z.property, fun _ _ => rfl⟩
+  let Φ :=
+    Smale.partialDiffeomorphOfInjectiveLocal hU (c.chart.toPartialEquiv.injOn.mono hUsource)
+      hlocal
+  have hzero :
+    Smale.WhitneyPairModel.bigon h ×ˢ
+        {(0 : Smale.RankThreeWhitneyModel.Lower × Smale.RankThreeWhitneyModel.Upper)} ⊆
+      Φ.source :=
+    hKU
+  obtain ⟨ε, hε, hsource⟩ :=
+    Smale.DiskFraming.exists_pos_prod_closedBall_subset
+      (Smale.WhitneyPairModel.isCompact_bigon tube.height_pos) Φ.open_source hzero
+  refine
+    ⟨{  radius := ε
+        radius_pos := hε
+        chart := Φ
+        source_contains := hsource
+        zero_section := c.zero_section
+        target_subset := ?_
+        first_sheet := hfirst
+        second_sheet := hsecond }⟩
+  intro y hy
+  change y ∈ c.chart '' U at hy
+  obtain ⟨z, hz, rfl⟩ := hy
+  exact c.target_subset (c.chart.map_source' (hUsource hz))
+
+private theorem Smale.TubularBigon.nonempty_rankThreeCompatibleChart_of_opposite_corner_signs
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    {S T : Set M} {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    (tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3)
+    (d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map)
+    (e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map)
+    (hS : IsClosed S) (hT : IsClosed T)
+    (hsign : tube.rankThreeSheetPairDet d e 0 * tube.rankThreeSheetPairDet d e 1 < 0) :
+    Nonempty (RankThreeCompatibleChart tube) := by
+  obtain ⟨c⟩ := tube.nonempty_rankThreeSheetParametrizedChart_of_opposite_corner_signs d e hsign
+  exact c.nonempty_rankThreeCompatibleChart hS hT
+
+private theorem Smale.TubularBigon.RankThreeCompatibleChart.nativeFirstSheet_eq {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    (c : Smale.TubularBigon.RankThreeCompatibleChart tube) :
+    Smale.RankThreeWhitneyModel.nativeFirstSheet c.chart = S ∩ c.chart.target := by
+  ext y
+  constructor
+  · rintro ⟨z, ⟨hzModel, hzSource⟩, rfl⟩
+    exact ⟨(c.first_sheet z hzSource).mpr hzModel, c.chart.map_source' hzSource⟩
+  · intro hy
+    have hz := c.chart.map_target' hy.2
+    have hzy : c.chart (c.chart.symm y) = y := c.chart.right_inv' hy.2
+    refine ⟨c.chart.symm y, ⟨?_, hz⟩, hzy⟩
+    apply (c.first_sheet _ hz).mp
+    change c.chart (c.chart.symm y) ∈ S
+    rw [hzy]
+    exact hy.1
+
+private theorem Smale.TubularBigon.RankThreeCompatibleChart.nativeSecondSheet_eq {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    (c : Smale.TubularBigon.RankThreeCompatibleChart tube) :
+    Smale.RankThreeWhitneyModel.nativeSecondSheet c.chart h = T ∩ c.chart.target := by
+  ext y
+  constructor
+  · rintro ⟨z, ⟨hzModel, hzSource⟩, rfl⟩
+    exact ⟨(c.second_sheet z hzSource).mpr hzModel, c.chart.map_source' hzSource⟩
+  · intro hy
+    have hz := c.chart.map_target' hy.2
+    have hzy : c.chart (c.chart.symm y) = y := c.chart.right_inv' hy.2
+    refine ⟨c.chart.symm y, ⟨?_, hz⟩, hzy⟩
+    apply (c.second_sheet _ hz).mp
+    change c.chart (c.chart.symm y) ∈ T
+    rw [hzy]
+    exact hy.1
+
+private theorem Smale.RankThreeWhitneyModel.GraphMotion.exists_native_cancellation {F H M : Type*}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] {J : ModelWithCorners ℝ F H}
+    [TopologicalSpace M] [ChartedSpace H M] [T2Space M]
+    (Φ :
+      PartialDiffeomorph 𝓘(ℝ, Smale.RankThreeWhitneyModel.Space) J
+        Smale.RankThreeWhitneyModel.Space M ∞)
+    {h : ℝ} (a : Smale.RankThreeWhitneyModel.GraphMotion h Φ.source) (hh : 0 < h) :
+    ∃ K : Set M,
+      IsCompact K ∧
+        K ⊆ Φ.target ∧
+          ∃ A : ℝ × M → M,
+            ContMDiff (𝓘(ℝ, ℝ).prod J) J ∞ A ∧
+              (∀ y, A (0, y) = y) ∧
+                (∀ t, ∃ d : Diffeomorph J J M M ∞, ∀ y, A (t, y) = d y) ∧
+                  (∀ t y, y ∉ K → A (t, y) = y) ∧
+                    Disjoint
+                      ((fun y => A (1, y)) '' Smale.RankThreeWhitneyModel.nativeFirstSheet Φ)
+                      (Smale.RankThreeWhitneyModel.nativeSecondSheet Φ h) := by
+  have hsource : ∀ t, Set.MapsTo (fun z => a.family (t, z)) Φ.source Φ.source := by
+    intro t
+    obtain ⟨d, hd⟩ := a.diffeomorph t
+    have hdfix : ∀ z ∉ a.support, d z = z := fun z hz => (hd z).trans (a.fixed t z hz)
+    intro z hz
+    change a.family (t, z) ∈ Φ.source
+    rw [← hd z]
+    exact Smale.SupportedDiffeomorph.mapsTo_source Φ d.toEquiv a.support_subset hdfix hz
+  let A : ℝ × M → M := fun p =>
+    Smale.SupportedDiffeomorph.extendMap Φ (fun z => a.family (p.1, z)) p.2
+  have hcompact : IsCompact (Φ '' a.support) :=
+    a.compact_support.image_of_continuousOn
+      (Φ.contMDiffOn_toFun.continuousOn.mono a.support_subset)
+  have htarget : Φ '' a.support ⊆ Φ.target := by
+    rintro _ ⟨z, hz, rfl⟩
+    exact Φ.map_source' (a.support_subset hz)
+  have hfamily :
+    ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, Smale.RankThreeWhitneyModel.Space))
+      𝓘(ℝ, Smale.RankThreeWhitneyModel.Space) ∞ a.family := by
+    exact a.smooth.contMDiff.comp (contMDiff_fst.prodMk_space contMDiff_snd)
+  refine
+    ⟨Φ '' a.support, hcompact, htarget, A,
+      Smale.SupportedDiffeomorph.contMDiff_extendFamily Φ hfamily a.compact_support
+        a.support_subset a.fixed hsource,
+      ?_, ?_, ?_, ?_⟩
+  · intro y
+    have hzero : (fun z => a.family (0, z)) = id := funext a.initial
+    change Smale.SupportedDiffeomorph.extendMap Φ (fun z => a.family (0, z)) y = y
+    rw [hzero]
+    exact Smale.SupportedDiffeomorph.extendMap_id Φ y
+  · intro t
+    obtain ⟨d, hd⟩ := a.diffeomorph t
+    have hdfix : ∀ z ∉ a.support, d z = z := fun z hz => (hd z).trans (a.fixed t z hz)
+    refine ⟨Smale.SupportedDiffeomorph.extension Φ d a.compact_support a.support_subset hdfix, ?_⟩
+    intro y
+    change
+      Smale.SupportedDiffeomorph.extendMap Φ (fun z => a.family (t, z)) y =
+        Smale.SupportedDiffeomorph.extendMap Φ d y
+    exact
+      congrArg
+        (fun f : Smale.RankThreeWhitneyModel.Space → Smale.RankThreeWhitneyModel.Space =>
+          Smale.SupportedDiffeomorph.extendMap Φ f y)
+        (funext (fun z => (hd z).symm))
+  · intro t y hy
+    exact Smale.SupportedDiffeomorph.extendMap_eq_of_notMem_image Φ (a.fixed t) hy
+  · rw [Set.disjoint_left]
+    intro y hy₁ hy₂
+    obtain ⟨x, hx, hxy⟩ := hy₁
+    obtain ⟨z, ⟨⟨p, hp⟩, hz⟩, hzx⟩ := hx
+    obtain ⟨w, ⟨⟨q, hq⟩, hw⟩, hwy⟩ := hy₂
+    have hleft : A (1, Φ z) = y := by rw [hzx]; exact hxy
+    have hcomm : A (1, Φ z) = Φ (a.family (1, z)) :=
+      Smale.SupportedDiffeomorph.extendMap_chart Φ (fun v => a.family (1, v)) hz
+    have heq : a.family (1, z) = w :=
+      Φ.toPartialEquiv.injOn (hsource 1 hz) hw (hcomm.symm.trans (hleft.trans hwy.symm))
+    apply a.firstSheet_ne_secondSheet hh p q
+    rw [hp, hq]
+    exact heq
+
+private theorem
+    Smale.RankThreeWhitneyModel.exists_supported_native_bigon_cancellation {F H M : Type*}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] {J : ModelWithCorners ℝ F H}
+    [TopologicalSpace M] [ChartedSpace H M] [T2Space M]
+    (Φ : PartialDiffeomorph 𝓘(ℝ, Space) J Space M ∞) {h : ℝ} (hh : 0 < h)
+    (hsource : ∀ p ∈ Smale.WhitneyPairModel.bigon h, (p, (0 : Lower × Upper)) ∈ Φ.source) :
+    ∃ K : Set M,
+      IsCompact K ∧
+        K ⊆ Φ.target ∧
+          ∃ A : ℝ × M → M,
+            ContMDiff (𝓘(ℝ, ℝ).prod J) J ∞ A ∧
+              (∀ y, A (0, y) = y) ∧
+                (∀ t, ∃ d : Diffeomorph J J M M ∞, ∀ y, A (t, y) = d y) ∧
+                  (∀ t y, y ∉ K → A (t, y) = y) ∧
+                    Disjoint ((fun y => A (1, y)) '' nativeFirstSheet Φ)
+                      (nativeSecondSheet Φ h) := by
+  obtain ⟨a⟩ := nonempty_graphMotion hh Φ.open_source hsource
+  exact a.exists_native_cancellation Φ hh
+
+private theorem
+    Smale.SupportedDiffeomorph.image_inter_eq_diff {X : Type*} (d : X ≃ X) {S T U : Set X}
+    (hfix : ∀ x ∉ U, d x = x) (hdisjoint : Disjoint (d '' (S ∩ U)) (T ∩ U)) :
+    (d '' S) ∩ T = (S ∩ T) \ U := by
+  ext y
+  constructor
+  · rintro ⟨⟨x, hx, hxy⟩, hyT⟩
+    have hyU : y ∉ U := by
+      intro hy
+      have hxU : x ∈ U := by
+        by_contra hnot
+        have he : x = y := (hfix x hnot).symm.trans hxy
+        exact hnot (he.symm ▸ hy)
+      exact Set.disjoint_left.mp hdisjoint ⟨x, ⟨hx, hxU⟩, hxy⟩ ⟨hyT, hy⟩
+    have he : x = y := d.injective (hxy.trans (hfix y hyU).symm)
+    exact ⟨⟨he ▸ hx, hyT⟩, hyU⟩
+  · rintro ⟨⟨hyS, hyT⟩, hyU⟩
+    exact ⟨⟨y, hyS, hfix y hyU⟩, hyT⟩
+
+private theorem Smale.SupportedDiffeomorph.preimage_target_eq_diff_of_relative_removal {X Y : Type*}
+    (d : X ≃ X) (F : Y → X) {T R : Set X} (hfix : ∀ y ∈ (Set.range F ∩ T) \ R, d y = y)
+    (himage : (d '' Set.range F) ∩ T = (Set.range F ∩ T) \ R) :
+    (d ∘ F) ⁻¹' T = (F ⁻¹' T) \ (F ⁻¹' R) := by
+  ext x
+  constructor
+  · intro hx
+    have hy : d (F x) ∈ (d '' Set.range F) ∩ T := ⟨⟨F x, ⟨x, rfl⟩, rfl⟩, hx⟩
+    rw [himage] at hy
+    have heq : F x = d (F x) := d.injective (hfix _ hy).symm
+    change F x ∈ T ∧ F x ∉ R
+    rw [heq]
+    exact ⟨hy.1.2, hy.2⟩
+  · intro hx
+    have hy : F x ∈ (Set.range F ∩ T) \ R := ⟨⟨⟨x, rfl⟩, hx.1⟩, hx.2⟩
+    change d (F x) ∈ T
+    rw [hfix _ hy]
+    exact hx.1
+
+private theorem Smale.SupportedDiffeomorph.eventuallyEq_comp_of_fixed_off_closed {X Y : Type*}
+    [TopologicalSpace X] [TopologicalSpace Y] {d : X → X} {F : Y → X} {K : Set X}
+    (hK : IsClosed K) (hfix : ∀ y ∉ K, d y = y) (hF : Continuous F) {x : Y} (hx : F x ∉ K) :
+    (d ∘ F) =ᶠ[𝓝 x] F := by
+  filter_upwards [hF.continuousAt.preimage_mem_nhds (hK.isOpen_compl.mem_nhds hx)] with y hy
+  exact hfix _ hy
+
+private theorem Smale.RankThreeWhitneyModel.firstSheet_eq_secondSheet_iff {h : ℝ} (hh : 0 < h)
+    (p : LowerSheet) (q : UpperSheet) :
+    firstSheet p = secondSheet h q ↔ p.1 = q.1 ∧ p.2 = 0 ∧ q.2 = 0 ∧ (q.1 = -1 ∨ q.1 = 1) := by
+  rcases p with ⟨s, u⟩
+  rcases q with ⟨t, v⟩
+  constructor
+  · intro heq
+    have hst : s = t := congrArg (fun z : Space => z.1.1) heq
+    have ht : 0 = h * (1 - t ^ 2) := congrArg (fun z : Space => z.1.2) heq
+    have hu : u = 0 := congrArg (fun z : Space => z.2.1) heq
+    have hv : v = 0 := (congrArg (fun z : Space => z.2.2) heq).symm
+    have hsq : t ^ 2 = 1 := by
+      have hz := (mul_eq_zero.mp ht.symm).resolve_left hh.ne'
+      linarith
+    have hprod : (t + 1) * (t - 1) = 0 := by nlinarith
+    refine ⟨hst, hu, hv, ?_⟩
+    rcases mul_eq_zero.mp hprod with hm | hp
+    · left
+      linarith
+    · right
+      linarith
+  · rintro ⟨hst, hu, hv, ht⟩
+    change s = t at hst
+    change u = 0 at hu
+    change v = 0 at hv
+    subst s
+    subst u
+    subst v
+    rcases ht with ht | ht
+    · change t = -1 at ht
+      subst t
+      simp [firstSheet, secondSheet]
+    · change t = 1 at ht
+      subst t
+      simp [firstSheet, secondSheet]
+
+private theorem Smale.TubularBigon.RankThreeCompatibleChart.intersection_in_target_eq {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    (c : Smale.TubularBigon.RankThreeCompatibleChart tube) :
+    (S ∩ T) ∩ c.chart.target = {a 0, a 1} := by
+  have hc0 : c.chart (Smale.RankThreeWhitneyModel.firstSheet (-1, 0)) = a 0 := by
+    calc
+      c.chart (Smale.RankThreeWhitneyModel.firstSheet (-1, 0)) = tube.map (-1, 0) :=
+        c.zero_section (-1, 0)
+      _ = a 0 := by simpa using tube.lower 0 (by simp)
+  have hc1 : c.chart (Smale.RankThreeWhitneyModel.firstSheet (1, 0)) = a 1 := by
+    calc
+      c.chart (Smale.RankThreeWhitneyModel.firstSheet (1, 0)) = tube.map (1, 0) :=
+        c.zero_section (1, 0)
+      _ = a 1 := by
+        have he := tube.lower 1 (by simp)
+        norm_num at he
+        exact he
+  have hcorner :
+    ∀ s : ℝ,
+      s = -1 ∨ s = 1 →
+        c.chart (Smale.RankThreeWhitneyModel.firstSheet (s, 0)) ∈ (S ∩ T) ∩ c.chart.target := by
+    intro s hs
+    have hb : (s, (0 : ℝ)) ∈ Smale.WhitneyPairModel.bigon h := by
+      rcases hs with rfl | rfl <;> simp [Smale.WhitneyPairModel.bigon]
+    have hsource : Smale.RankThreeWhitneyModel.firstSheet (s, 0) ∈ c.chart.source :=
+      c.source_contains ⟨hb, Metric.mem_closedBall_self c.radius_pos.le⟩
+    refine
+      ⟨⟨(c.first_sheet _ hsource).mpr ⟨(s, 0), rfl⟩, (c.second_sheet _ hsource).mpr ?_⟩,
+        c.chart.map_source' hsource⟩
+    refine ⟨(s, 0), ?_⟩
+    rcases hs with rfl | rfl <;>
+      simp [Smale.RankThreeWhitneyModel.firstSheet, Smale.RankThreeWhitneyModel.secondSheet]
+  ext y
+  change y ∈ (S ∩ T) ∩ c.chart.target ↔ y = a 0 ∨ y = a 1
+  constructor
+  · intro hy
+    have hz := c.chart.map_target' hy.2
+    have hzy : c.chart (c.chart.symm y) = y := c.chart.right_inv' hy.2
+    have hlo : c.chart.symm y ∈ Set.range Smale.RankThreeWhitneyModel.firstSheet := by
+      apply (c.first_sheet _ hz).mp
+      change c.chart (c.chart.symm y) ∈ S
+      rw [hzy]
+      exact hy.1.1
+    have hhi : c.chart.symm y ∈ Set.range (Smale.RankThreeWhitneyModel.secondSheet h) := by
+      apply (c.second_sheet _ hz).mp
+      change c.chart (c.chart.symm y) ∈ T
+      rw [hzy]
+      exact hy.1.2
+    obtain ⟨p, hp⟩ := hlo
+    obtain ⟨q, hq⟩ := hhi
+    obtain ⟨hst, hu, _, hends⟩ :=
+      (Smale.RankThreeWhitneyModel.firstSheet_eq_secondSheet_iff tube.height_pos p q).mp
+        (hp.trans hq.symm)
+    have hpq : p = (q.1, 0) := Prod.ext hst hu
+    rw [hpq] at hp
+    have hycorner : y = c.chart (Smale.RankThreeWhitneyModel.firstSheet (q.1, 0)) :=
+      hzy.symm.trans (congrArg c.chart hp.symm)
+    rcases hends with hm | hp
+    · left
+      rw [hm] at hycorner
+      exact hycorner.trans hc0
+    · right
+      rw [hp] at hycorner
+      exact hycorner.trans hc1
+  · rintro (rfl | rfl)
+    · rw [← hc0]
+      exact hcorner (-1) (Or.inl rfl)
+    · rw [← hc1]
+      exact hcorner 1 (Or.inr rfl)
+
+private theorem Smale.TubularBigon.RankThreeCompatibleChart.exists_cancellation {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {S T : Set M}
+    {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    (c : Smale.TubularBigon.RankThreeCompatibleChart tube) [T2Space M] :
+    ∃ K : Set M,
+      IsCompact K ∧
+        K ⊆ c.chart.target ∧
+          ∃ A : ℝ × M → M,
+            ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, E)) 𝓘(ℝ, E) ∞ A ∧
+              (∀ y, A (0, y) = y) ∧
+                (∀ t, ∃ d : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞, ∀ y, A (t, y) = d y) ∧
+                  (∀ t y, y ∉ K → A (t, y) = y) ∧
+                    ((fun y => A (1, y)) '' S) ∩ T = (S ∩ T) \ {a 0, a 1} := by
+  obtain ⟨K, hK, hKsource, A, hA, hzero, hdiff, hfix, hdisjoint⟩ :=
+    Smale.RankThreeWhitneyModel.exists_supported_native_bigon_cancellation c.chart tube.height_pos
+      (fun _ hp => c.source_contains ⟨hp, Metric.mem_closedBall_self c.radius_pos.le⟩)
+  rw [c.nativeFirstSheet_eq, c.nativeSecondSheet_eq] at hdisjoint
+  obtain ⟨d, hd⟩ := hdiff 1
+  have hdfix : ∀ y ∉ c.chart.target, d y = y := by
+    intro y hy
+    exact (hd y).symm.trans (hfix 1 y (fun h => hy (hKsource h)))
+  have hdeq : (fun y => A (1, y)) = d := funext hd
+  have hdisjoint' : Disjoint (d '' (S ∩ c.chart.target)) (T ∩ c.chart.target) := by
+    rw [← hdeq]
+    exact hdisjoint
+  have hinter : (d '' S) ∩ T = (S ∩ T) \ c.chart.target :=
+    Smale.SupportedDiffeomorph.image_inter_eq_diff d.toEquiv hdfix hdisjoint'
+  refine ⟨K, hK, hKsource, A, hA, hzero, hdiff, hfix, ?_⟩
+  rw [hdeq, hinter, ← c.intersection_in_target_eq]
+  ext y
+  simp only [Set.mem_sdiff, Set.mem_inter_iff]
+  tauto
+
+private theorem
+    Smale.TubularBigon.RankThreeCompatibleChart.exists_relative_cancellation {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {S T : Set M} {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    {tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3}
+    (c : Smale.TubularBigon.RankThreeCompatibleChart tube) :
+    ∃ K : Set M,
+      IsCompact K ∧
+        K ⊆ c.chart.target ∧
+          Disjoint K ((S ∩ T) \ {a 0, a 1}) ∧
+            ∃ A : ℝ × M → M,
+              ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, E)) 𝓘(ℝ, E) ∞ A ∧
+                (∀ y, A (0, y) = y) ∧
+                  (∀ t, ∃ d : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞, ∀ y, A (t, y) = d y) ∧
+                    (∀ t y, y ∉ K → A (t, y) = y) ∧
+                      ((fun y => A (1, y)) '' S) ∩ T = (S ∩ T) \ {a 0, a 1} := by
+  obtain ⟨K, hK, hKt, A, hA⟩ := c.exists_cancellation
+  refine ⟨K, hK, hKt, ?_, A, hA⟩
+  apply Set.disjoint_left.mpr
+  intro y hyK hy
+  have hc : y ∈ (S ∩ T) ∩ c.chart.target := ⟨hy.1, hKt hyK⟩
+  rw [c.intersection_in_target_eq] at hc
+  exact hy.2 hc
+
+private theorem Smale.TubularBigon.exists_rankThree_relative_cancellation {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {S T : Set M} {a b : ℝ → M} {k₀ k₁ l₀ l₁ : (ℝ × ℝ) → M} {h : ℝ}
+    {k : Smale.CleanStripPatch (E := E) S T a k₀ k₁}
+    {l : Smale.CleanStripPatch (E := E) T S b l₀ l₁}
+    (tube : Smale.TubularBigon (E := E) S T a b k.map l.map h 3)
+    (d :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Lower (EuclideanSpace ℝ (Fin 3)) (E := E)
+        S k.map)
+    (e :
+      Smale.StripNormalData Smale.RankThreeWhitneyModel.Upper (EuclideanSpace ℝ (Fin 2)) (E := E)
+        T l.map)
+    (hS : IsClosed S) (hT : IsClosed T)
+    (hsign : tube.rankThreeSheetPairDet d e 0 * tube.rankThreeSheetPairDet d e 1 < 0) :
+    ∃ K : Set M,
+      IsCompact K ∧
+        K ⊆ tube.chart.target ∧
+          Disjoint K ((S ∩ T) \ {a 0, a 1}) ∧
+            ∃ A : ℝ × M → M,
+              ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, E)) 𝓘(ℝ, E) ∞ A ∧
+                (∀ y, A (0, y) = y) ∧
+                  (∀ t, ∃ D : Diffeomorph 𝓘(ℝ, E) 𝓘(ℝ, E) M M ∞, ∀ y, A (t, y) = D y) ∧
+                    (∀ t y, y ∉ K → A (t, y) = y) ∧
+                      ((fun y => A (1, y)) '' S) ∩ T = (S ∩ T) \ {a 0, a 1} := by
+  obtain ⟨c⟩ := tube.nonempty_rankThreeCompatibleChart_of_opposite_corner_signs d e hS hT hsign
+  obtain ⟨K, hK, hKt, hd, A, hA⟩ := c.exists_relative_cancellation
+  exact ⟨K, hK, hKt.trans c.target_subset, hd, A, hA⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.exists_belt_whitney_cancellation_of_opposite_signs
+    {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    {f : M → ℝ} {p : M} (D : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hdim : Module.finrank ℝ E = 6)
+    (hindex : Module.finrank ℝ D.chart.NegativeCoordinates = 2)
+    (hnull :
+      ∀ γ : C(Smale.Hemisphere.Sphere 1, D.LowerLevel),
+        ∃ q, γ.Homotopic (ContinuousMap.const _ q))
+    (r : (ℝ × D.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient 3)
+    (g : C(Smale.Hemisphere.Sphere 2, D.UpperLevel)) :
+    letI := Smale.RegularLevel.chartedSpace hf D.upper_regular
+    letI : Fact (Module.finrank ℝ D.chart.PositiveCoordinates = 3 + 1) :=
+      ⟨by have hh := D.chart.finrank_negative_add_positive; omega⟩
+    ∀ (_hg : ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g) (_hinj : Function.Injective g)
+      (_hi : ∀ x, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) g x))
+      (_ht :
+        ∀ x y,
+          Smale.NativeTransversality.At (𝓡 2) (𝓡 3) 𝓘(ℝ, Smale.RegularLevel.Model E) g
+            D.surgery.beltSphere x y)
+      (x₀ x₁ : Smale.Hemisphere.Sphere 2),
+      x₀ ∈ D.beltIntersectionPoints 2 g →
+        x₁ ∈ D.beltIntersectionPoints 2 g →
+          D.beltIntersectionSign 2 r g x₀ * D.beltIntersectionSign 2 r g x₁ = -1 →
+            ∃ K : Set D.UpperLevel,
+              IsCompact K ∧
+                Disjoint K ((Set.range g ∩ Set.range D.surgery.beltSphere) \ {g x₀, g x₁}) ∧
+                  ∃ A : ℝ × D.UpperLevel → D.UpperLevel,
+                    ContMDiff (𝓘(ℝ, ℝ).prod 𝓘(ℝ, Smale.RegularLevel.Model E))
+                        𝓘(ℝ, Smale.RegularLevel.Model E) ∞ A ∧
+                      (∀ y, A (0, y) = y) ∧
+                        (∀ t,
+                            ∃ e :
+                              Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E)
+                                𝓘(ℝ, Smale.RegularLevel.Model E) D.UpperLevel D.UpperLevel ∞,
+                              ∀ y, A (t, y) = e y) ∧
+                          (∀ t y, y ∉ K → A (t, y) = y) ∧
+                            ((fun y => A (1, y)) '' Set.range g) ∩
+                                Set.range D.surgery.beltSphere =
+                              (Set.range g ∩ Set.range D.surgery.beltSphere) \ {g x₀, g x₁} := by
+  let _ := Smale.RegularLevel.chartedSpace hf D.upper_regular
+  let _ : Fact (Module.finrank ℝ D.chart.PositiveCoordinates = 3 + 1) :=
+    ⟨by have hh := D.chart.finrank_negative_add_positive; omega⟩
+  intro hg hinj hi ht x₀ x₁ hx₀ hx₁ hsign
+  obtain ⟨y₀, hy₀⟩ := hx₀
+  obtain ⟨y₁, hy₁⟩ := hx₁
+  have hne : x₀ ≠ x₁ := by
+    intro heq
+    rw [heq] at hsign
+    have hs : ∀ s : SignType, s * s ≠ -1 := by decide
+    exact hs _ hsign
+  obtain ⟨a, b, ha₀, ha₁, _, _, k₀, k₁, l₀, l₁, k, l, ⟨d⟩, ⟨e⟩, htube⟩ :=
+    D.exists_belt_tubular_strip_pair hf hdim hindex hnull g hg hinj hi (fun x y hxy => ht x y hxy)
+      x₀ x₁ y₀ y₁ hy₀ hy₁ hne
+  obtain ⟨tube⟩ := htube 1 (by norm_num)
+  have hcenter₀ : g x₀ = d.chart (Smale.StripCoordinates.center 0) :=
+    ha₀.symm.trans ((k.center 0 (by simp)).symm.trans (d.center 0))
+  have hcenter₁ : g x₁ = d.chart (Smale.StripCoordinates.center 1) :=
+    ha₁.symm.trans ((k.center 1 (by simp)).symm.trans (d.center 1))
+  have hcorner :=
+    (D.opposite_beltIntersectionSigns_iff_Whitney_corners hf hdim hindex r g hg hinj hi ht tube d
+          e x₀ x₁ hcenter₀ hcenter₁).mp
+      hsign
+  obtain ⟨K, hK, _, hdisjoint, A, hA, hA₀, hAt, hfix, hcancel⟩ :=
+    tube.exists_rankThree_relative_cancellation d e (isCompact_range g.continuous).isClosed
+      D.belt_isClosedEmbedding.isClosed_range hcorner
+  rw [ha₀, ha₁] at hcancel hdisjoint
+  exact ⟨K, hK, hdisjoint, A, hA, hA₀, hAt, hfix, hcancel⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.exists_signed_belt_cancellation_step {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} {p : M}
+    (D : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (hindex : Module.finrank ℝ D.chart.NegativeCoordinates = 2)
+    (hnull :
+      ∀ γ : C(Smale.Hemisphere.Sphere 1, D.LowerLevel),
+        ∃ q, γ.Homotopic (ContinuousMap.const _ q))
+    (r : (ℝ × D.chart.NegativeCoordinates) ≃L[ℝ] Smale.Hemisphere.Ambient 3)
+    (g : C(Smale.Hemisphere.Sphere 2, D.UpperLevel)) :
+    letI := Smale.RegularLevel.chartedSpace hf D.upper_regular
+    letI : Fact (Module.finrank ℝ D.chart.PositiveCoordinates = 3 + 1) :=
+      ⟨by have hh := D.chart.finrank_negative_add_positive; omega⟩
+    ∀ (_hg : ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g) (_hinj : Function.Injective g)
+      (_hi : ∀ x, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) g x))
+      (_ht :
+        ∀ x y,
+          Smale.NativeTransversality.At (𝓡 2) (𝓡 3) 𝓘(ℝ, Smale.RegularLevel.Model E) g
+            D.surgery.beltSphere x y)
+      (x₀ x₁ : Smale.Hemisphere.Sphere 2),
+      x₀ ∈ D.beltIntersectionPoints 2 g →
+        x₁ ∈ D.beltIntersectionPoints 2 g →
+          D.beltIntersectionSign 2 r g x₀ * D.beltIntersectionSign 2 r g x₁ = -1 →
+            ∃ e :
+              Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+                D.UpperLevel D.UpperLevel ∞,
+              ∃ g' : C(Smale.Hemisphere.Sphere 2, D.UpperLevel),
+                Smale.SupportedDiffeomorph.IsotopicToIdentity e ∧
+                  (∀ x, g' x = e (g x)) ∧
+                    ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g' ∧
+                      Function.Injective g' ∧
+                        (∀ x,
+                            Function.Injective
+                              (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) g' x)) ∧
+                          (∀ x y,
+                              Smale.NativeTransversality.At (𝓡 2) (𝓡 3)
+                                𝓘(ℝ, Smale.RegularLevel.Model E) g' D.surgery.beltSphere x y) ∧
+                            D.beltIntersectionPoints 2 g' =
+                                D.beltIntersectionPoints 2 g \ { x₀, x₁ } ∧
+                              (∀ x ∈ D.beltIntersectionPoints 2 g',
+                                  (g' : Smale.Hemisphere.Sphere 2 → D.UpperLevel) =ᶠ[𝓝 x] g) ∧
+                                ∀ x ∈ D.beltIntersectionPoints 2 g',
+                                  D.beltIntersectionSign 2 r g' x =
+                                    D.beltIntersectionSign 2 r g x := by
+  let _ := Smale.RegularLevel.chartedSpace hf D.upper_regular
+  let _ : Fact (Module.finrank ℝ D.chart.PositiveCoordinates = 3 + 1) :=
+    ⟨by have hh := D.chart.finrank_negative_add_positive; omega⟩
+  let _ : Fact (Module.finrank ℝ (Smale.Hemisphere.Ambient 3) = 2 + 1) :=
+    ⟨finrank_euclideanSpace_fin⟩
+  intro hg hinj hi ht x₀ x₁ hx₀ hx₁ hsign
+  obtain ⟨K, hK, hdis, A, hA, hA₀, hAt, hfix, hcancel⟩ :=
+    D.exists_belt_whitney_cancellation_of_opposite_signs hf hdim hindex hnull r g hg hinj hi ht x₀
+      x₁ hx₀ hx₁ hsign
+  obtain ⟨e, he⟩ := hAt 1
+  have hisotopy : Smale.SupportedDiffeomorph.IsotopicToIdentity e := ⟨A, hA, hA₀, he, hAt⟩
+  have hfixe : ∀ y ∉ K, e y = y := fun y hy => (he y).symm.trans (hfix 1 y hy)
+  have hfun : (fun y => A (1, y)) = e := funext he
+  rw [hfun] at hcancel
+  let g' : C(Smale.Hemisphere.Sphere 2, D.UpperLevel) := ⟨e ∘ g, e.continuous.comp g.continuous⟩
+  have hg' : ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g' := e.contMDiff.comp hg
+  have hinj' : Function.Injective g' := e.injective.comp hinj
+  have hi' : ∀ x, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) g' x) := by
+    intro x
+    change Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) (e ∘ g) x)
+    rw [mfderiv_comp x (e.mdifferentiable (by simp) _) (hg.mdifferentiableAt (by simp))]
+    exact
+      ((e.toOpenPartialHomeomorph_mdifferentiable (by simp)).mfderiv_injective (by trivial)).comp
+        (hi x)
+  have hfixR : ∀ y ∈ (Set.range g ∩ Set.range D.surgery.beltSphere) \ {g x₀, g x₁}, e y = y := by
+    intro y hy
+    exact hfixe y (fun hyK => Set.disjoint_left.mp hdis hyK hy)
+  have hpre :=
+    Smale.SupportedDiffeomorph.preimage_target_eq_diff_of_relative_removal e.toEquiv
+      (g : Smale.Hemisphere.Sphere 2 → D.UpperLevel) hfixR hcancel
+  have hp : (g : Smale.Hemisphere.Sphere 2 → D.UpperLevel) ⁻¹' {g x₀, g x₁} = { x₀, x₁ } := by
+    ext x
+    change (g x = g x₀ ∨ g x = g x₁) ↔ (x = x₀ ∨ x = x₁)
+    exact or_congr hinj.eq_iff hinj.eq_iff
+  have hpoints : D.beltIntersectionPoints 2 g' = D.beltIntersectionPoints 2 g \ { x₀, x₁ } :=
+    hpre.trans
+      (congrArg (fun s : Set (Smale.Hemisphere.Sphere 2) => D.beltIntersectionPoints 2 g \ s) hp)
+  have hgerm :
+    ∀ x ∈ D.beltIntersectionPoints 2 g',
+      (g' : Smale.Hemisphere.Sphere 2 → D.UpperLevel) =ᶠ[𝓝 x] g := by
+    intro x hx
+    have hxold : x ∈ D.beltIntersectionPoints 2 g \ { x₀, x₁ } := hpoints ▸ hx
+    have hy : g x ∈ (Set.range g ∩ Set.range D.surgery.beltSphere) \ {g x₀, g x₁} := by
+      refine ⟨⟨⟨x, rfl⟩, hxold.1⟩, ?_⟩
+      change x ∉ (g : Smale.Hemisphere.Sphere 2 → D.UpperLevel) ⁻¹' {g x₀, g x₁}
+      rw [hp]
+      exact hxold.2
+    exact
+      Smale.SupportedDiffeomorph.eventuallyEq_comp_of_fixed_off_closed hK.isClosed hfixe
+        g.continuous (fun hyK => Set.disjoint_left.mp hdis hyK hy)
+  have ht' :
+    ∀ x y,
+      Smale.NativeTransversality.At (𝓡 2) (𝓡 3) 𝓘(ℝ, Smale.RegularLevel.Model E) g'
+        D.surgery.beltSphere x y := by
+    intro x y hxy
+    have hx : x ∈ D.beltIntersectionPoints 2 g' := ⟨y, hxy⟩
+    have hnear := hgerm x hx
+    have hpoint : g' x = g x := hnear.eq_of_nhds
+    have hder :
+      (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) g' x :
+          EuclideanSpace ℝ (Fin 2) →L[ℝ] Smale.RegularLevel.Model E) =
+        mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) g x :=
+      hnear.mfderiv_eq
+    change
+      Function.Surjective
+        ((mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) g' x :
+              EuclideanSpace ℝ (Fin 2) →L[ℝ] Smale.RegularLevel.Model E).coprod
+          (mfderiv (𝓡 3) 𝓘(ℝ, Smale.RegularLevel.Model E) D.surgery.beltSphere y :
+            EuclideanSpace ℝ (Fin 3) →L[ℝ] Smale.RegularLevel.Model E))
+    rw [hder]
+    exact ht x y (hxy.trans hpoint)
+  refine ⟨e, g', hisotopy, fun _ => rfl, hg', hinj', hi', ht', hpoints, hgerm, ?_⟩
+  intro x hx
+  have hnormal : (D.beltNormal ∘ g') =ᶠ[𝓝 x] (D.beltNormal ∘ g) := by
+    filter_upwards [hgerm x hx] with z hz
+    exact congrArg D.beltNormal hz
+  have hder :
+    (mfderiv (𝓡 2) 𝓘(ℝ, D.chart.NegativeCoordinates) (D.beltNormal ∘ g') x :
+        EuclideanSpace ℝ (Fin 2) →L[ℝ] D.chart.NegativeCoordinates) =
+      mfderiv (𝓡 2) 𝓘(ℝ, D.chart.NegativeCoordinates) (D.beltNormal ∘ g) x :=
+    hnormal.mfderiv_eq
+  have hjac : D.beltIntersectionJacobian 2 r g' x = D.beltIntersectionJacobian 2 r g x :=
+    congrArg
+      (fun L : EuclideanSpace ℝ (Fin 2) →L[ℝ] D.chart.NegativeCoordinates =>
+        Smale.SphereNormalCoordinates.normalJacobian r x L)
+      hder
+  exact congrArg SignType.sign hjac
+
+private def Smale.ManifoldMorse.MorseSurgeryData.IsTransverseBeltSphere {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (D : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hdim : Module.finrank ℝ E = 6) (hindex : Module.finrank ℝ D.chart.NegativeCoordinates = 2)
+    (g : C(Smale.Hemisphere.Sphere 2, D.UpperLevel)) : Prop :=
+  letI := Smale.RegularLevel.chartedSpace hf D.upper_regular
+  letI : Fact (Module.finrank ℝ D.chart.PositiveCoordinates = 3 + 1) :=
+    ⟨by have hh := D.chart.finrank_negative_add_positive; omega⟩
+  ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ g ∧
+    Function.Injective g ∧
+      (∀ x, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) g x)) ∧
+        ∀ x y,
+          Smale.NativeTransversality.At (𝓡 2) (𝓡 3) 𝓘(ℝ, Smale.RegularLevel.Model E) g
+            D.surgery.beltSphere x y
+
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.finite_points_of_isTransverseBeltSphere {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {p : M}
+    (D : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    [T2Space M] [CompactSpace M] (hdim : Module.finrank ℝ E = 6)
+    (hindex : Module.finrank ℝ D.chart.NegativeCoordinates = 2)
+    {g : C(Smale.Hemisphere.Sphere 2, D.UpperLevel)}
+    (hg : D.IsTransverseBeltSphere hf hdim hindex g) : (D.beltIntersectionPoints 2 g).Finite := by
+  let _ := Smale.RegularLevel.chartedSpace hf D.upper_regular
+  let _ : Fact (Module.finrank ℝ D.chart.PositiveCoordinates = 3 + 1) :=
+    ⟨by have hh := D.chart.finrank_negative_add_positive; omega⟩
+  obtain ⟨hs, hinj, _, ht⟩ := hg
+  exact D.finite_beltIntersectionPoints hf 3 2 hindex g hs hinj ht
+
+private def
+    MorseCancel.nativeMorseCount (E : Type*) [NormedAddCommGroup E] [NormedSpace ℝ E] {M : Type*}
+    [TopologicalSpace M] [ChartedSpace E M] (f : M → ℝ) (k : ℕ) : ℕ :=
+  {z : M | z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ nativeMorseIndex E f z = k}.ncard
+
+private theorem
+    MorseCancel.indexed_criticalPoints_after_pair_removal {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ} {p q : M}
+    (hcrit :
+      ∀ z,
+        z ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+          z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ z ≠ p ∧ z ≠ q)
+    (hkeep : ∀ z ∈ Smale.ManifoldMorse.criticalPoints E g, g =ᶠ[𝓝 z] f) (k : ℕ) :
+    {z : M | z ∈ Smale.ManifoldMorse.criticalPoints E g ∧ nativeMorseIndex E g z = k} =
+      {z : M | z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ nativeMorseIndex E f z = k} \
+        { p, q } := by
+  ext z
+  simp only [Set.mem_ofPred_eq, Set.mem_sdiff, Set.mem_insert_iff, Set.mem_singleton_iff, not_or]
+  constructor
+  · rintro ⟨hzg, hindex⟩
+    obtain ⟨hzf, hzp, hzq⟩ := (hcrit z).mp hzg
+    rw [nativeMorseIndex_congr_germ (hkeep z hzg)] at hindex
+    exact ⟨⟨hzf, hindex⟩, hzp, hzq⟩
+  · rintro ⟨⟨hzf, hindex⟩, hzp, hzq⟩
+    have hzg := (hcrit z).mpr ⟨hzf, hzp, hzq⟩
+    exact ⟨hzg, (nativeMorseIndex_congr_germ (hkeep z hzg)).trans hindex⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.nativeMorseCount_after_pair_removal {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ} {p q : M}
+    (hfinite : (Smale.ManifoldMorse.criticalPoints E f).Finite)
+    (hp : p ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hq : q ∈ Smale.ManifoldMorse.criticalPoints E f) (hpq : p ≠ q)
+    (hcrit :
+      ∀ z,
+        z ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+          z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ z ≠ p ∧ z ≠ q)
+    (hkeep : ∀ z ∈ Smale.ManifoldMorse.criticalPoints E g, g =ᶠ[𝓝 z] f) (k : ℕ) :
+    nativeMorseCount E g k + (if nativeMorseIndex E f p = k then 1 else 0) +
+        (if nativeMorseIndex E f q = k then 1 else 0) =
+      nativeMorseCount E f k := by
+  let K := {z : M | z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ nativeMorseIndex E f z = k}
+  have hK : K.Finite := hfinite.subset (fun _ hz => hz.1)
+  have hdiff : K \ (K ∩ { p, q }) = K \ { p, q } := by
+    ext z
+    simp only [Set.mem_sdiff, Set.mem_inter_iff]
+    tauto
+  have hrem :
+    (K ∩ { p, q }).ncard =
+      (if nativeMorseIndex E f p = k then 1 else 0) +
+        (if nativeMorseIndex E f q = k then 1 else 0) := by
+    by_cases hip : nativeMorseIndex E f p = k
+    · have hpK : p ∈ K := ⟨hp, hip⟩
+      rw [Set.inter_insert_of_mem hpK, ite_eq_left hip]
+      by_cases hiq : nativeMorseIndex E f q = k
+      · rw [Set.inter_singleton_of_mem (show q ∈ K from ⟨hq, hiq⟩), ite_eq_left hiq,
+          Set.ncard_pair hpq]
+      · rw [Set.inter_singleton_of_notMem (show q ∉ K from fun h => hiq h.2), ite_eq_right hiq]
+        simp
+    · have hpK : p ∉ K := fun h => hip h.2
+      rw [Set.inter_insert_of_notMem hpK, ite_eq_right hip]
+      by_cases hiq : nativeMorseIndex E f q = k
+      · rw [Set.inter_singleton_of_mem (show q ∈ K from ⟨hq, hiq⟩), ite_eq_left hiq]
+        simp
+      · rw [Set.inter_singleton_of_notMem (show q ∉ K from fun h => hiq h.2), ite_eq_right hiq]
+        simp
+  have hc := Set.ncard_sdiff_add_ncard_of_subset (Set.inter_subset_left : K ∩ { p, q } ⊆ K) hK
+  rw [hdiff, hrem] at hc
+  unfold nativeMorseCount
+  rw [indexed_criticalPoints_after_pair_removal hcrit hkeep k]
+  exact (Nat.add_assoc _ _ _).trans hc
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.nativeMorseCount_adjacent_pair {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ} {p q : M}
+    (hfinite : (Smale.ManifoldMorse.criticalPoints E f).Finite)
+    (hp : p ∈ Smale.ManifoldMorse.criticalPoints E f)
+    (hq : q ∈ Smale.ManifoldMorse.criticalPoints E f) (hpq : p ≠ q)
+    (hcrit :
+      ∀ z,
+        z ∈ Smale.ManifoldMorse.criticalPoints E g ↔
+          z ∈ Smale.ManifoldMorse.criticalPoints E f ∧ z ≠ p ∧ z ≠ q)
+    (hkeep : ∀ z ∈ Smale.ManifoldMorse.criticalPoints E g, g =ᶠ[𝓝 z] f) {k : ℕ}
+    (hip : nativeMorseIndex E f p = k) (hiq : nativeMorseIndex E f q = k + 1) :
+    nativeMorseCount E g k + 1 = nativeMorseCount E f k ∧
+      nativeMorseCount E g (k + 1) + 1 = nativeMorseCount E f (k + 1) ∧
+        ∀ j, j ≠ k → j ≠ k + 1 → nativeMorseCount E g j = nativeMorseCount E f j := by
+  have hc := nativeMorseCount_after_pair_removal hfinite hp hq hpq hcrit hkeep
+  refine ⟨?_, ?_, ?_⟩
+  · simpa [hip, hiq] using hc k
+  · simpa [hip, hiq, show k ≠ k + 1 by omega] using hc (k + 1)
+  · intro j hj hj'
+    simpa only [hip, hiq, ite_eq_right (Ne.symm hj), ite_eq_right (Ne.symm hj'),
+      Nat.add_zero] using hc j
+
+private def
+    Smale.RadialCoreShrink.shrink {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] (a : ℝ)
+    (y : E) : E :=
+  (Max.max (‖y‖ - Max.max a 0) 0 / ‖y‖) • y
+
+@[simp]
+private theorem
+    Smale.RadialCoreShrink.shrink_zero {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (a : ℝ) : shrink a (0 : E) = 0 := by simp [shrink]
+
+private theorem
+    Smale.RadialCoreShrink.norm_shrink {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (a : ℝ) (y : E) : ‖shrink a y‖ = Max.max (‖y‖ - Max.max a 0) 0 := by
+  by_cases hy : y = 0
+  · subst y
+    rw [shrink_zero, norm_zero]
+    exact (max_eq_right (by linarith [le_max_right a 0])).symm
+  rw [shrink, norm_smul, Real.norm_eq_abs,
+    abs_of_nonneg (div_nonneg (le_max_right _ _) (norm_nonneg y)),
+    div_mul_cancel₀ _ (norm_ne_zero_iff.mpr hy)]
+
+private theorem
+    Smale.RadialCoreShrink.norm_shrink_le {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (a : ℝ) (y : E) : ‖shrink a y‖ ≤ ‖y‖ := by
+  rw [norm_shrink]
+  exact max_le (sub_le_self _ (le_max_right a 0)) (norm_nonneg y)
+
+@[simp]
+private theorem Smale.RadialCoreShrink.shrink_zero_parameter {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (y : E) : shrink 0 y = y := by
+  by_cases hy : y = 0
+  · subst y
+    exact shrink_zero 0
+  rw [shrink, max_self, sub_zero, max_eq_left (norm_nonneg y), div_self (norm_ne_zero_iff.mpr hy),
+    one_smul]
+
+private theorem
+    Smale.RadialCoreShrink.shrink_eq_zero {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    {a : ℝ} {y : E} (hy : ‖y‖ ≤ a) : shrink a y = 0 := by
+  rw [shrink, max_eq_right (sub_nonpos.mpr (hy.trans (le_max_left a 0))), zero_div, zero_smul]
+
+private theorem Smale.RadialCoreShrink.continuous_shrink {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] : Continuous (fun z : ℝ × E => shrink z.1 z.2) := by
+  rw [continuous_iff_continuousAt]
+  rintro ⟨a, y⟩
+  by_cases hy : y = 0
+  · subst y
+    change Filter.Tendsto (fun z : ℝ × E => shrink z.1 z.2) (𝓝 (a, 0)) (𝓝 (shrink a 0))
+    rw [shrink_zero]
+    apply squeeze_zero_norm (fun z => norm_shrink_le z.1 z.2)
+    simpa only [ContinuousAt, norm_zero] using
+      (continuous_snd.norm.continuousAt : ContinuousAt (fun z : ℝ × E => ‖z.2‖) (a, 0))
+  exact
+    (((continuous_snd.norm.sub (continuous_fst.max continuous_const)).max
+              continuous_const).continuousAt.div
+          continuous_snd.norm.continuousAt (norm_ne_zero_iff.mpr hy)).smul
+      continuous_snd.continuousAt
+
+private def Smale.HandleCoreDeformation.denominator {N P : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] (z : Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P) :
+    ℝ :=
+  Max.max ‖(z.1 : N)‖ (1 - ‖(z.2 : P)‖ / 2)
+
+private theorem Smale.HandleCoreDeformation.denominator_pos {N P : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] (z : Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P) :
+    0 < denominator z := by
+  have hy : ‖(z.2 : P)‖ ≤ 1 := mem_closedBall_zero_iff.mp z.2.property
+  have h := le_max_right ‖(z.1 : N)‖ (1 - ‖(z.2 : P)‖ / 2)
+  dsimp [denominator]
+  linarith
+
+private theorem
+    Smale.HandleCoreDeformation.continuous_denominator {N P : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] : Continuous (denominator (N := N) (P := P)) :=
+  (continuous_subtype_val.comp continuous_fst).norm.max
+    (continuous_const.sub ((continuous_subtype_val.comp continuous_snd).norm.div_const 2))
+
+private def
+    Smale.HandleCoreDeformation.negative {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] (z : Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P) :
+    Smale.MorseHandle.UnitDisk N :=
+  ⟨(denominator z)⁻¹ • (z.1 : N),
+    by
+    rw [mem_closedBall_zero_iff, norm_smul, Real.norm_eq_abs,
+      abs_of_pos (inv_pos.mpr (denominator_pos z))]
+    calc
+      _ ≤ (denominator z)⁻¹ * denominator z :=
+        mul_le_mul_of_nonneg_left (le_max_left _ _) (inv_pos.mpr (denominator_pos z)).le
+      _ = 1 := inv_mul_cancel₀ (denominator_pos z).ne'⟩
+
+private def Smale.HandleCoreDeformation.positive {N P : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P]
+    (z : Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P) :
+    Smale.MorseHandle.UnitDisk P :=
+  ⟨Smale.RadialCoreShrink.shrink (2 * (1 - ‖(z.1 : N)‖)) (z.2 : P),
+    mem_closedBall_zero_iff.mpr
+      ((Smale.RadialCoreShrink.norm_shrink_le _ _).trans
+        (mem_closedBall_zero_iff.mp z.2.property))⟩
+
+private theorem Smale.HandleCoreDeformation.continuous_negative {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] : Continuous (negative (N := N) (P := P)) :=
+  ((continuous_denominator.inv₀ (fun z => (denominator_pos z).ne')).smul
+        (continuous_subtype_val.comp continuous_fst)).subtype_mk
+    _
+
+private theorem Smale.HandleCoreDeformation.continuous_positive {N P : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] : Continuous (positive (N := N) (P := P)) :=
+  (Smale.RadialCoreShrink.continuous_shrink.comp
+        ((continuous_const.mul
+              (continuous_const.sub (continuous_subtype_val.comp continuous_fst).norm)).prodMk
+          (continuous_subtype_val.comp continuous_snd))).subtype_mk
+    _
+
+private def
+    Smale.HandleCoreDeformation.collapse {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] :
+    C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P,
+      Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P) :=
+  ⟨fun z => (negative z, positive z), continuous_negative.prodMk continuous_positive⟩
+
+private def Smale.HandleCoreDeformation.faceCore {N P : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] : Set (Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P) :=
+  {z | ‖(z.1 : N)‖ = 1 ∨ (z.2 : P) = 0}
+
+private theorem Smale.HandleCoreDeformation.collapse_mem {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P]
+    (z : Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P) : collapse z ∈ faceCore := by
+  rcases le_total (1 - ‖(z.2 : P)‖ / 2) ‖(z.1 : N)‖ with h | h
+  · left
+    have hx : 0 < ‖(z.1 : N)‖ := by
+      have hpos := denominator_pos z
+      rwa [denominator, max_eq_left h] at hpos
+    change ‖(denominator z)⁻¹ • (z.1 : N)‖ = 1
+    rw [denominator, max_eq_left h, norm_smul, Real.norm_eq_abs, abs_of_pos (inv_pos.mpr hx),
+      inv_mul_cancel₀ hx.ne']
+  · right
+    apply Smale.RadialCoreShrink.shrink_eq_zero
+    linarith
+
+private theorem Smale.HandleCoreDeformation.collapse_face {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P]
+    (z : Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P) (hz : ‖(z.1 : N)‖ = 1) :
+    collapse z = z := by
+  have hd : denominator z = 1 := by
+    rw [denominator, hz, max_eq_left]
+    linarith [norm_nonneg (z.2 : P)]
+  apply Prod.ext
+  · apply Subtype.ext
+    change (denominator z)⁻¹ • (z.1 : N) = (z.1 : N)
+    rw [hd, inv_one, one_smul]
+  · apply Subtype.ext
+    change Smale.RadialCoreShrink.shrink (2 * (1 - ‖(z.1 : N)‖)) (z.2 : P) = (z.2 : P)
+    rw [hz, sub_self, MulZeroClass.mul_zero, Smale.RadialCoreShrink.shrink_zero_parameter]
+
+private theorem Smale.HandleCoreDeformation.collapse_core {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P]
+    (z : Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P) (hz : (z.2 : P) = 0) :
+    collapse z = z := by
+  have hd : denominator z = 1 := by
+    rw [denominator, hz, norm_zero, zero_div, sub_zero]
+    exact max_eq_right (mem_closedBall_zero_iff.mp z.1.property)
+  apply Prod.ext
+  · apply Subtype.ext
+    change (denominator z)⁻¹ • (z.1 : N) = (z.1 : N)
+    rw [hd, inv_one, one_smul]
+  · apply Subtype.ext
+    change Smale.RadialCoreShrink.shrink (2 * (1 - ‖(z.1 : N)‖)) (z.2 : P) = (z.2 : P)
+    rw [hz, Smale.RadialCoreShrink.shrink_zero]
+
+private theorem Smale.HandleCoreDeformation.collapse_fixed {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P]
+    (z : Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P) (hz : z ∈ faceCore) :
+    collapse z = z :=
+  hz.elim (collapse_face z) (collapse_core z)
+
+private def
+    Smale.HandleCoreDeformation.diskBlend {V : Type*} [NormedAddCommGroup V] [NormedSpace ℝ V]
+    (t : (unitInterval)) (x y : Smale.MorseHandle.UnitDisk V) : Smale.MorseHandle.UnitDisk V :=
+  ⟨(1 - (t : ℝ)) • (x : V) + (t : ℝ) • (y : V),
+    (convex_closedBall (0 : V) 1) x.property y.property (sub_nonneg.mpr t.property.2) t.property.1
+      (sub_add_cancel 1 (t : ℝ))⟩
+
+private theorem Smale.HandleCoreDeformation.continuous_diskBlend {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] :
+    Continuous
+      (fun q : (unitInterval) × (Smale.MorseHandle.UnitDisk V × Smale.MorseHandle.UnitDisk V) =>
+        diskBlend q.1 q.2.1 q.2.2) :=
+  (((continuous_const.sub (continuous_subtype_val.comp continuous_fst)).smul
+            (continuous_subtype_val.comp continuous_snd.fst)).add
+        ((continuous_subtype_val.comp continuous_fst).smul
+          (continuous_subtype_val.comp continuous_snd.snd))).subtype_mk
+    _
+
+@[simp]
+private theorem Smale.HandleCoreDeformation.diskBlend_zero {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] (x y : Smale.MorseHandle.UnitDisk V) : diskBlend 0 x y = x := by
+  apply Subtype.ext
+  simp [diskBlend]
+
+@[simp]
+private theorem Smale.HandleCoreDeformation.diskBlend_one {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] (x y : Smale.MorseHandle.UnitDisk V) : diskBlend 1 x y = y := by
+  apply Subtype.ext
+  simp [diskBlend]
+
+@[simp]
+private theorem Smale.HandleCoreDeformation.diskBlend_self {V : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℝ V] (t : (unitInterval)) (x : Smale.MorseHandle.UnitDisk V) :
+    diskBlend t x x = x := by
+  apply Subtype.ext
+  change (1 - (t : ℝ)) • (x : V) + (t : ℝ) • (x : V) = (x : V)
+  rw [← add_smul, sub_add_cancel, one_smul]
+
+private def
+    Smale.HandleCoreDeformation.deformation {N P : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] :
+    (ContinuousMap.id (Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P)).HomotopyRel
+      collapse faceCore
+    where
+  toFun q := (diskBlend q.1 q.2.1 (collapse q.2).1, diskBlend q.1 q.2.2 (collapse q.2).2)
+  continuous_toFun :=
+    (continuous_diskBlend.comp
+          (continuous_fst.prodMk
+            (continuous_snd.fst.prodMk (collapse.continuous.comp continuous_snd).fst))).prodMk
+      (continuous_diskBlend.comp
+        (continuous_fst.prodMk
+          (continuous_snd.snd.prodMk (collapse.continuous.comp continuous_snd).snd)))
+  map_zero_left z := by simp
+  map_one_left z := by simp
+  prop' t z
+    hz := by
+    change (diskBlend t z.1 (collapse z).1, diskBlend t z.2 (collapse z).2) = z
+    rw [collapse_fixed z hz]
+    simp
+
+private def Smale.ClosedCover.mapOfClosedPieces {R P X Y : Type*} [TopologicalSpace R]
+    [TopologicalSpace P] [TopologicalSpace X] [TopologicalSpace Y] (r : R → X) (p : P → X)
+    (hr : Topology.IsClosedEmbedding r) (hp : Topology.IsClosedEmbedding p)
+    (hcover : Set.range r ∪ Set.range p = Set.univ) (f : C(R, Y)) (g : C(P, Y))
+    (hagree : ∀ a b, r a = p b → f a = g b) : C(X, Y) := by
+  let a := hr.isEmbedding.toHomeomorph
+  let b := hp.isEmbedding.toHomeomorph
+  refine ⟨glue hcover (fun x => f (a.symm x)) (fun x => g (b.symm x)), ?_⟩
+  apply
+    continuous_glue hcover hr.isClosed_range hp.isClosed_range _ _
+      (f.continuous.comp a.symm.continuous) (g.continuous.comp b.symm.continuous)
+  intro x y hxy
+  apply hagree
+  exact
+    (congrArg Subtype.val (a.apply_symm_apply x)).trans
+      (hxy.trans (congrArg Subtype.val (b.apply_symm_apply y)).symm)
+
+private theorem Smale.ClosedCover.mapOfClosedPieces_left {R P X Y : Type*} [TopologicalSpace R]
+    [TopologicalSpace P] [TopologicalSpace X] [TopologicalSpace Y] (r : R → X) (p : P → X)
+    (hr : Topology.IsClosedEmbedding r) (hp : Topology.IsClosedEmbedding p)
+    (hcover : Set.range r ∪ Set.range p = Set.univ) (f : C(R, Y)) (g : C(P, Y))
+    (hagree : ∀ a b, r a = p b → f a = g b) (x : R) :
+    mapOfClosedPieces r p hr hp hcover f g hagree (r x) = f x := by
+  let a := hr.isEmbedding.toHomeomorph
+  let b := hp.isEmbedding.toHomeomorph
+  change glue hcover (fun z => f (a.symm z)) (fun z => g (b.symm z)) (r x) = f x
+  exact
+    (glue_left hcover _ _ ⟨r x, Set.mem_range_self x⟩).trans (congrArg f (a.symm_apply_apply x))
+
+private theorem Smale.ClosedCover.mapOfClosedPieces_right {R P X Y : Type*} [TopologicalSpace R]
+    [TopologicalSpace P] [TopologicalSpace X] [TopologicalSpace Y] (r : R → X) (p : P → X)
+    (hr : Topology.IsClosedEmbedding r) (hp : Topology.IsClosedEmbedding p)
+    (hcover : Set.range r ∪ Set.range p = Set.univ) (f : C(R, Y)) (g : C(P, Y))
+    (hagree : ∀ a b, r a = p b → f a = g b) (x : P) :
+    mapOfClosedPieces r p hr hp hcover f g hagree (p x) = g x := by
+  let a := hr.isEmbedding.toHomeomorph
+  let b := hp.isEmbedding.toHomeomorph
+  have hagree' :
+    ∀ u : Set.range r, ∀ v : Set.range p, (u : X) = v → f (a.symm u) = g (b.symm v) := by
+    intro u v huv
+    apply hagree
+    exact
+      (congrArg Subtype.val (a.apply_symm_apply u)).trans
+        (huv.trans (congrArg Subtype.val (b.apply_symm_apply v)).symm)
+  change glue hcover (fun z => f (a.symm z)) (fun z => g (b.symm z)) (p x) = g x
+  exact
+    (glue_right hcover _ _ hagree' ⟨p x, Set.mem_range_self x⟩).trans
+      (congrArg g (b.symm_apply_apply x))
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Recognition/Smale9.lean b/LeanPool/HopfProblem/Recognition/Smale9.lean
new file mode 100644
index 000000000..cf190fafb
--- /dev/null
+++ b/LeanPool/HopfProblem/Recognition/Smale9.lean
@@ -0,0 +1,5664 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Recognition.Smale8
+public import LeanPool.HopfProblem.Foundations.Core5
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Foundations.LineBundleTransport
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.Recognition.Smale1
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology1
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology2
+import all LeanPool.HopfProblem.Recognition.Smale2
+import all LeanPool.HopfProblem.Recognition.Smale3
+import all LeanPool.HopfProblem.Recognition.Smale4
+import all LeanPool.HopfProblem.Recognition.Smale5
+import all LeanPool.HopfProblem.Recognition.Degree1
+import all LeanPool.HopfProblem.Recognition.Degree2
+import all LeanPool.HopfProblem.Recognition.Smale6
+import all LeanPool.HopfProblem.Recognition.Smale8
+import all LeanPool.HopfProblem.Foundations.Core5
+
+/-!
+# Hopf problem: recognition · smale 9
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def
+    Smale.HandleCoreAttachment.core {N P X : Type*} [NormedAddCommGroup N] [NormedAddCommGroup P]
+    [TopologicalSpace X] (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X)) :
+    C(Smale.MorseHandle.UnitDisk N, X) :=
+  ⟨fun x => h (x, ⟨0, by simp⟩), h.continuous.comp (continuous_id.prodMk continuous_const)⟩
+
+private def Smale.HandleCoreAttachment.coreSpace {N P R X : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace X] (r : R → X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X)) : Set X :=
+  Set.range r ∪ Set.range (core h)
+
+private theorem Smale.HandleCoreAttachment.collapse_lands {N P R X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] [TopologicalSpace X] (r : R → X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X))
+    (hface : ∀ z, h z ∈ Set.range r ↔ ‖(z.1 : N)‖ = 1)
+    (z : Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P) :
+    h (Smale.HandleCoreDeformation.collapse z) ∈ coreSpace r h := by
+  rcases Smale.HandleCoreDeformation.collapse_mem z with hz | hz
+  · exact Or.inl ((hface (Smale.HandleCoreDeformation.collapse z)).mpr hz)
+  · right
+    refine ⟨(Smale.HandleCoreDeformation.collapse z).1, ?_⟩
+    apply congrArg h
+    exact Prod.ext rfl (Subtype.ext hz.symm)
+
+private def Smale.HandleCoreAttachment.oldToCore {N P R X : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace R] [TopologicalSpace X] (r : R → X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X))
+    (hr : Topology.IsClosedEmbedding r) : C(R, coreSpace r h) :=
+  ⟨fun a => ⟨r a, Or.inl (Set.mem_range_self a)⟩, hr.continuous.subtype_mk _⟩
+
+private def Smale.HandleCoreAttachment.handleToCore {N P R X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] [TopologicalSpace X] (r : R → X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X))
+    (hface : ∀ z, h z ∈ Set.range r ↔ ‖(z.1 : N)‖ = 1) :
+    C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, coreSpace r h) :=
+  ⟨fun z => ⟨h (Smale.HandleCoreDeformation.collapse z), collapse_lands r h hface z⟩,
+    (h.continuous.comp Smale.HandleCoreDeformation.collapse.continuous).subtype_mk _⟩
+
+private theorem Smale.HandleCoreAttachment.coreMaps_agree {N P R X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] [TopologicalSpace R]
+    [TopologicalSpace X] (r : R → X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X))
+    (hr : Topology.IsClosedEmbedding r) (hface : ∀ z, h z ∈ Set.range r ↔ ‖(z.1 : N)‖ = 1) (a : R)
+    (z : Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P) (haz : r a = h z) :
+    oldToCore r h hr a = handleToCore r h hface z := by
+  have hz : ‖(z.1 : N)‖ = 1 := (hface z).mp ⟨a, haz⟩
+  apply Subtype.ext
+  change r a = h (Smale.HandleCoreDeformation.collapse z)
+  rw [Smale.HandleCoreDeformation.collapse_face z hz]
+  exact haz
+
+private def Smale.HandleCoreAttachment.retraction {N P R X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] [TopologicalSpace R]
+    [TopologicalSpace X] (r : R → X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X))
+    (hr : Topology.IsClosedEmbedding r) (hh : Topology.IsClosedEmbedding h)
+    (hcover : Set.range r ∪ Set.range h = Set.univ)
+    (hface : ∀ z, h z ∈ Set.range r ↔ ‖(z.1 : N)‖ = 1) : C(X, coreSpace r h) :=
+  Smale.ClosedCover.mapOfClosedPieces r h hr hh hcover (oldToCore r h hr) (handleToCore r h hface)
+    (coreMaps_agree r h hr hface)
+
+private theorem Smale.HandleCoreAttachment.retraction_old {N P R X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] [TopologicalSpace R]
+    [TopologicalSpace X] (r : R → X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X))
+    (hr : Topology.IsClosedEmbedding r) (hh : Topology.IsClosedEmbedding h)
+    (hcover : Set.range r ∪ Set.range h = Set.univ)
+    (hface : ∀ z, h z ∈ Set.range r ↔ ‖(z.1 : N)‖ = 1) (a : R) :
+    (retraction r h hr hh hcover hface (r a) : X) = r a :=
+  congrArg Subtype.val
+    (Smale.ClosedCover.mapOfClosedPieces_left r h hr hh hcover (oldToCore r h hr)
+      (handleToCore r h hface) (coreMaps_agree r h hr hface) a)
+
+private theorem
+    Smale.HandleCoreAttachment.retraction_handle {N P R X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] [TopologicalSpace R]
+    [TopologicalSpace X] (r : R → X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X))
+    (hr : Topology.IsClosedEmbedding r) (hh : Topology.IsClosedEmbedding h)
+    (hcover : Set.range r ∪ Set.range h = Set.univ)
+    (hface : ∀ z, h z ∈ Set.range r ↔ ‖(z.1 : N)‖ = 1)
+    (z : Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P) :
+    (retraction r h hr hh hcover hface (h z) : X) = h (Smale.HandleCoreDeformation.collapse z) :=
+  congrArg Subtype.val
+    (Smale.ClosedCover.mapOfClosedPieces_right r h hr hh hcover (oldToCore r h hr)
+      (handleToCore r h hface) (coreMaps_agree r h hr hface) z)
+
+private theorem Smale.HandleCoreAttachment.retraction_fixed {N P R X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] [TopologicalSpace R]
+    [TopologicalSpace X] (r : R → X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X))
+    (hr : Topology.IsClosedEmbedding r) (hh : Topology.IsClosedEmbedding h)
+    (hcover : Set.range r ∪ Set.range h = Set.univ)
+    (hface : ∀ z, h z ∈ Set.range r ↔ ‖(z.1 : N)‖ = 1) (x : X) (hx : x ∈ coreSpace r h) :
+    (retraction r h hr hh hcover hface x : X) = x := by
+  rcases hx with ⟨a, rfl⟩ | ⟨z, rfl⟩
+  · exact retraction_old r h hr hh hcover hface a
+  · change (retraction r h hr hh hcover hface (h (z, ⟨0, by simp⟩)) : X) = h (z, ⟨0, by simp⟩)
+    rw [retraction_handle, Smale.HandleCoreDeformation.collapse_core _ rfl]
+
+private theorem Smale.HandleCoreAttachment.time_cover {N P R X : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace X] (r : R → X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X))
+    (hcover : Set.range r ∪ Set.range h = Set.univ) :
+    Set.range (Prod.map (id : (unitInterval) → (unitInterval)) r) ∪
+        Set.range (Prod.map (id : (unitInterval) → (unitInterval)) h) =
+      Set.univ := by
+  apply Set.eq_univ_of_forall
+  rintro ⟨t, x⟩
+  have hx : x ∈ Set.range r ∪ Set.range h := by rw [hcover]; trivial
+  rcases hx with ⟨a, rfl⟩ | ⟨z, rfl⟩
+  · exact Or.inl ⟨(t, a), rfl⟩
+  · exact Or.inr ⟨(t, z), rfl⟩
+
+private def
+    Smale.HandleCoreAttachment.oldMotion {R X : Type*} [TopologicalSpace R] [TopologicalSpace X]
+    (r : R → X) (hr : Topology.IsClosedEmbedding r) : C((unitInterval) × R, X) :=
+  ⟨fun q => r q.2, hr.continuous.comp continuous_snd⟩
+
+private def Smale.HandleCoreAttachment.handleMotion {N P X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] [TopologicalSpace X]
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X)) :
+    C((unitInterval) × (Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P), X) :=
+  h.comp Smale.HandleCoreDeformation.deformation.toHomotopy.toContinuousMap
+
+private theorem Smale.HandleCoreAttachment.motions_agree {N P R X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] [TopologicalSpace R]
+    [TopologicalSpace X] (r : R → X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X))
+    (hr : Topology.IsClosedEmbedding r) (hface : ∀ z, h z ∈ Set.range r ↔ ‖(z.1 : N)‖ = 1)
+    (a : (unitInterval) × R)
+    (z : (unitInterval) × (Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P))
+    (haz : Prod.map id r a = Prod.map id h z) : oldMotion r hr a = handleMotion h z := by
+  have ha : r a.2 = h z.2 := congrArg Prod.snd haz
+  have hz : z.2 ∈ Smale.HandleCoreDeformation.faceCore := Or.inl ((hface z.2).mp ⟨a.2, ha⟩)
+  change r a.2 = h (Smale.HandleCoreDeformation.deformation (z.1, z.2))
+  rw [Smale.HandleCoreDeformation.deformation.eq_fst z.1 hz]
+  exact ha
+
+private def
+    Smale.HandleCoreAttachment.motion {N P R X : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    [NormedAddCommGroup P] [NormedSpace ℝ P] [TopologicalSpace R] [TopologicalSpace X] (r : R → X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X))
+    (hr : Topology.IsClosedEmbedding r) (hh : Topology.IsClosedEmbedding h)
+    (hcover : Set.range r ∪ Set.range h = Set.univ)
+    (hface : ∀ z, h z ∈ Set.range r ↔ ‖(z.1 : N)‖ = 1) : C((unitInterval) × X, X) :=
+  Smale.ClosedCover.mapOfClosedPieces (Prod.map id r) (Prod.map id h)
+    (Topology.IsClosedEmbedding.id.prodMap hr) (Topology.IsClosedEmbedding.id.prodMap hh)
+    (time_cover r h hcover) (oldMotion r hr) (handleMotion h) (motions_agree r h hr hface)
+
+private theorem Smale.HandleCoreAttachment.motion_old {N P R X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] [TopologicalSpace R]
+    [TopologicalSpace X] (r : R → X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X))
+    (hr : Topology.IsClosedEmbedding r) (hh : Topology.IsClosedEmbedding h)
+    (hcover : Set.range r ∪ Set.range h = Set.univ)
+    (hface : ∀ z, h z ∈ Set.range r ↔ ‖(z.1 : N)‖ = 1) (t : (unitInterval)) (a : R) :
+    motion r h hr hh hcover hface (t, r a) = r a :=
+  Smale.ClosedCover.mapOfClosedPieces_left (Prod.map id r) (Prod.map id h)
+    (Topology.IsClosedEmbedding.id.prodMap hr) (Topology.IsClosedEmbedding.id.prodMap hh)
+    (time_cover r h hcover) (oldMotion r hr) (handleMotion h) (motions_agree r h hr hface) (t, a)
+
+private theorem Smale.HandleCoreAttachment.motion_handle {N P R X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] [TopologicalSpace R]
+    [TopologicalSpace X] (r : R → X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X))
+    (hr : Topology.IsClosedEmbedding r) (hh : Topology.IsClosedEmbedding h)
+    (hcover : Set.range r ∪ Set.range h = Set.univ)
+    (hface : ∀ z, h z ∈ Set.range r ↔ ‖(z.1 : N)‖ = 1) (t : (unitInterval))
+    (z : Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P) :
+    motion r h hr hh hcover hface (t, h z) = h (Smale.HandleCoreDeformation.deformation (t, z)) :=
+  Smale.ClosedCover.mapOfClosedPieces_right (Prod.map id r) (Prod.map id h)
+    (Topology.IsClosedEmbedding.id.prodMap hr) (Topology.IsClosedEmbedding.id.prodMap hh)
+    (time_cover r h hcover) (oldMotion r hr) (handleMotion h) (motions_agree r h hr hface) (t, z)
+
+private def Smale.HandleCoreAttachment.coreInclusion {N P R X : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace X] (r : R → X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X)) :
+    C(coreSpace r h, X) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private def Smale.HandleCoreAttachment.deformation {N P R X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] [TopologicalSpace R]
+    [TopologicalSpace X] (r : R → X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X))
+    (hr : Topology.IsClosedEmbedding r) (hh : Topology.IsClosedEmbedding h)
+    (hcover : Set.range r ∪ Set.range h = Set.univ)
+    (hface : ∀ z, h z ∈ Set.range r ↔ ‖(z.1 : N)‖ = 1) :
+    (ContinuousMap.id X).HomotopyRel
+      ((coreInclusion r h).comp (retraction r h hr hh hcover hface)) (coreSpace r h)
+    where
+  toFun := motion r h hr hh hcover hface
+  continuous_toFun := (motion r h hr hh hcover hface).continuous
+  map_zero_left
+    x := by
+    have hx : x ∈ Set.range r ∪ Set.range h := by rw [hcover]; trivial
+    rcases hx with ⟨a, rfl⟩ | ⟨z, rfl⟩
+    · exact motion_old r h hr hh hcover hface 0 a
+    · rw [motion_handle]
+      exact congrArg h (Smale.HandleCoreDeformation.deformation.toHomotopy.map_zero_left z)
+  map_one_left
+    x := by
+    change motion r h hr hh hcover hface (1, x) = (retraction r h hr hh hcover hface x : X)
+    have hx : x ∈ Set.range r ∪ Set.range h := by rw [hcover]; trivial
+    rcases hx with ⟨a, rfl⟩ | ⟨z, rfl⟩
+    · rw [motion_old, retraction_old]
+    · rw [motion_handle, retraction_handle]
+      exact congrArg h (Smale.HandleCoreDeformation.deformation.toHomotopy.map_one_left z)
+  prop' t x
+    hx := by
+    change motion r h hr hh hcover hface (t, x) = x
+    rcases hx with ⟨a, rfl⟩ | ⟨z, rfl⟩
+    · exact motion_old r h hr hh hcover hface t a
+    · change motion r h hr hh hcover hface (t, h (z, ⟨0, by simp⟩)) = h (z, ⟨0, by simp⟩)
+      rw [motion_handle]
+      exact congrArg h (Smale.HandleCoreDeformation.deformation.eq_fst t (Or.inr rfl))
+
+private def Smale.HandleCoreAttachment.homotopyEquiv {N P R X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] [TopologicalSpace R]
+    [TopologicalSpace X] (r : R → X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X))
+    (hr : Topology.IsClosedEmbedding r) (hh : Topology.IsClosedEmbedding h)
+    (hcover : Set.range r ∪ Set.range h = Set.univ)
+    (hface : ∀ z, h z ∈ Set.range r ↔ ‖(z.1 : N)‖ = 1) : coreSpace r h ≃ₕ X
+    where
+  toFun := coreInclusion r h
+  invFun := retraction r h hr hh hcover hface
+  left_inv := by
+    have heq :
+      (retraction r h hr hh hcover hface).comp (coreInclusion r h) =
+        ContinuousMap.id (coreSpace r h) := by
+      apply ContinuousMap.ext
+      intro x
+      exact Subtype.ext (retraction_fixed r h hr hh hcover hface x.val x.property)
+    rw [heq]
+  right_inv := ⟨(deformation r h hr hh hcover hface).toHomotopy.symm⟩
+
+private def Smale.ClosedHandleCore.oldInclusion {N P X : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace X] (A : Set X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X)) :
+    C(A, ↥(A ∪ Set.range h)) :=
+  ⟨Set.inclusion (fun _ hx => Or.inl hx), continuous_inclusion _⟩
+
+private def Smale.ClosedHandleCore.handleInclusion {N P X : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace X] (A : Set X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X)) :
+    C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, ↥(A ∪ Set.range h)) :=
+  ⟨fun z => ⟨h z, Or.inr (Set.mem_range_self z)⟩, h.continuous.subtype_mk _⟩
+
+private theorem Smale.ClosedHandleCore.old_closed {N P X : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace X] (A : Set X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X)) (hA : IsClosed A) :
+    Topology.IsClosedEmbedding (oldInclusion A h) :=
+  Smale.ClosedCover.isClosedEmbedding_codRestrict hA.isClosedEmbedding_subtypeVal
+    (fun x => Or.inl x.property)
+
+private theorem Smale.ClosedHandleCore.handle_closed {N P X : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace X] (A : Set X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X))
+    (hh : Topology.IsClosedEmbedding h) : Topology.IsClosedEmbedding (handleInclusion A h) :=
+  Smale.ClosedCover.isClosedEmbedding_codRestrict hh (fun z => Or.inr (Set.mem_range_self z))
+
+private theorem Smale.ClosedHandleCore.pieces_cover {N P X : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace X] (A : Set X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X)) :
+    Set.range (oldInclusion A h) ∪ Set.range (handleInclusion A h) = Set.univ := by
+  apply Set.eq_univ_of_forall
+  rintro ⟨x, hx | ⟨z, rfl⟩⟩
+  · exact Or.inl ⟨⟨x, hx⟩, rfl⟩
+  · exact Or.inr ⟨z, rfl⟩
+
+private theorem Smale.ClosedHandleCore.handle_mem_old_iff {N P X : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace X] (A : Set X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X))
+    (z : Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P) :
+    handleInclusion A h z ∈ Set.range (oldInclusion A h) ↔ h z ∈ A := by
+  constructor
+  · rintro ⟨a, ha⟩
+    have heq : (a : X) = h z := congrArg Subtype.val ha
+    exact heq ▸ a.property
+  · intro hz
+    exact ⟨⟨h z, hz⟩, rfl⟩
+
+private theorem Smale.ClosedHandleCore.core_subset {N P X : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace X] (A : Set X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X)) :
+    A ∪ Set.range (Smale.HandleCoreAttachment.core h) ⊆ A ∪ Set.range h := by
+  rintro x (hx | ⟨z, rfl⟩)
+  · exact Or.inl hx
+  · exact Or.inr ⟨(z, ⟨0, by simp⟩), rfl⟩
+
+private theorem Smale.ClosedHandleCore.coreSpace_iff {N P X : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace X] (A : Set X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X))
+    (x : ↥(A ∪ Set.range h)) :
+    x ∈ Smale.HandleCoreAttachment.coreSpace (oldInclusion A h) (handleInclusion A h) ↔
+      x.val ∈ A ∪ Set.range (Smale.HandleCoreAttachment.core h) := by
+  constructor
+  · rintro (⟨a, ha⟩ | ⟨z, hz⟩)
+    · left
+      have heq : (a : X) = x.val := congrArg Subtype.val ha
+      exact heq ▸ a.property
+    · right
+      exact ⟨z, congrArg Subtype.val hz⟩
+  · rintro (hx | ⟨z, hz⟩)
+    · exact Or.inl ⟨⟨x.val, hx⟩, Subtype.ext rfl⟩
+    · exact Or.inr ⟨z, Subtype.ext hz⟩
+
+private def Smale.ClosedHandleCore.coreUnionHomeomorph {N P X : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace X] (A : Set X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X)) :
+    ↥(A ∪ Set.range (Smale.HandleCoreAttachment.core h)) ≃ₜ
+      Smale.HandleCoreAttachment.coreSpace (oldInclusion A h) (handleInclusion A h)
+    where
+  toFun x := ⟨⟨x.val, core_subset A h x.property⟩, (coreSpace_iff A h _).mpr x.property⟩
+  invFun x := ⟨x.val.val, (coreSpace_iff A h x.val).mp x.property⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := (continuous_subtype_val.subtype_mk _).subtype_mk _
+  continuous_invFun := (continuous_subtype_val.comp continuous_subtype_val).subtype_mk _
+
+private def Smale.ClosedHandleCore.unionHomotopyEquiv {N P X : Type*} [NormedAddCommGroup N]
+    [NormedAddCommGroup P] [TopologicalSpace X] (A : Set X)
+    (h : C(Smale.MorseHandle.UnitDisk N × Smale.MorseHandle.UnitDisk P, X)) [NormedSpace ℝ N]
+    [NormedSpace ℝ P] (hA : IsClosed A) (hh : Topology.IsClosedEmbedding h)
+    (hface : ∀ z, h z ∈ A ↔ ‖(z.1 : N)‖ = 1) :
+    ↥(A ∪ Set.range (Smale.HandleCoreAttachment.core h)) ≃ₕ ↥(A ∪ Set.range h) :=
+  (coreUnionHomeomorph A h).toHomotopyEquiv.trans
+    (Smale.HandleCoreAttachment.homotopyEquiv (oldInclusion A h) (handleInclusion A h)
+      (old_closed A h hA) (handle_closed A h hh) (pieces_cover A h)
+      (fun z => (handle_mem_old_iff A h z).trans (hface z)))
+
+attribute [local instance 100] Classical.propDecidable in
+private abbrev
+    Smale.ManifoldMorse.MorseSurgeryData.HandleDomain {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) :=
+  Smale.MorseHandle.UnitDisk d.chart.NegativeCoordinates ×
+    Smale.MorseHandle.UnitDisk d.chart.PositiveCoordinates
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.MorseSurgeryData.handleMap {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) : C(d.HandleDomain, M) :=
+  d.chart.attachingHandleMap d.radius d.radius_pos d.block
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    Smale.ManifoldMorse.MorseSurgeryData.handleFacePoint {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (u : Smale.PuncturedHandle.UnitSphere d.chart.NegativeCoordinates)
+    (v : Smale.MorseHandle.UnitDisk d.chart.PositiveCoordinates) : d.HandleDomain :=
+  (⟨u, Metric.sphere_subset_closedBall u.property⟩, v)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.handleMap_core {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (u : Smale.PuncturedHandle.UnitSphere d.chart.NegativeCoordinates) :
+    d.handleMap (d.handleFacePoint u ⟨0, by simp⟩) = (d.surgery.attachingSphere u : M) := by
+  rw [d.attaching_eq]
+  rfl
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.MorseSurgeryData.coreMap {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) :
+    C(Smale.MorseHandle.UnitDisk d.chart.NegativeCoordinates, M) :=
+  Smale.HandleCoreAttachment.core d.handleMap
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    Smale.ManifoldMorse.MorseSurgeryData.coreMap_boundary {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (u : Smale.PuncturedHandle.UnitSphere d.chart.NegativeCoordinates) :
+    d.coreMap ⟨u, Metric.sphere_subset_closedBall u.property⟩ =
+      (d.surgery.attachingSphere u : M) :=
+  d.handleMap_core u
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.coreMap_lower_iff {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (u : Smale.MorseHandle.UnitDisk d.chart.NegativeCoordinates) :
+    f (d.coreMap u) ≤ f p - d.radius ^ 2 ↔ ‖(u : d.chart.NegativeCoordinates)‖ = 1 :=
+  d.chart.attachingHandleMap_lower_iff d.radius d.radius_pos d.block (u, ⟨0, by simp⟩)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.coreMap_isClosedEmbedding {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) [T2Space M] :
+    Topology.IsClosedEmbedding d.coreMap := by
+  apply d.coreMap.continuous.isClosedEmbedding
+  intro x y hxy
+  have heq :=
+    (d.chart.attachingHandleMap_isClosedEmbedding d.radius d.radius_pos d.block).injective hxy
+  exact congrArg Prod.fst heq
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.MorseSurgeryData.coreUnionHomotopyEquiv {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) [T2Space M] (hf : Continuous f) :
+    ↥({y : M | f y ≤ f p - d.radius ^ 2} ∪ Set.range d.coreMap) ≃ₕ
+      { y : M // f y ≤ f p + d.radius ^ 2 } :=
+  (Smale.ClosedHandleCore.unionHomotopyEquiv {y : M | f y ≤ f p - d.radius ^ 2} d.handleMap
+        (isClosed_le hf continuous_const)
+        (d.chart.attachingHandleMap_isClosedEmbedding d.radius d.radius_pos d.block)
+        (d.chart.attachingHandleMap_lower_iff d.radius d.radius_pos d.block)).trans
+    d.attachmentHomeomorph.toHomotopyEquiv
+
+private structure Smale.EmbeddedCellAttachment (N X : Type*) [NormedAddCommGroup N]
+    [TopologicalSpace X] where
+  old : Set X
+  old_closed : IsClosed old
+  cell : C(MorseHandle.UnitDisk N, X)
+  cell_closed : Topology.IsClosedEmbedding cell
+  cover : old ∪ Set.range cell = Set.univ
+  boundary : ∀ z, cell z ∈ old ↔ ‖(z : N)‖ = 1
+
+private def
+    Smale.EmbeddedCellAttachment.ofUnion {N X : Type*} [NormedAddCommGroup N] [TopologicalSpace X]
+    (A : Set X) (e : C(Smale.MorseHandle.UnitDisk N, X)) (hA : IsClosed A)
+    (he : Topology.IsClosedEmbedding e) (hface : ∀ z, e z ∈ A ↔ ‖(z : N)‖ = 1) :
+    Smale.EmbeddedCellAttachment N ↥(A ∪ Set.range e)
+    where
+  old := {x | x.val ∈ A}
+  old_closed := hA.preimage continuous_subtype_val
+  cell := ⟨fun z => ⟨e z, Or.inr (Set.mem_range_self z)⟩, e.continuous.subtype_mk _⟩
+  cell_closed :=
+    Smale.ClosedCover.isClosedEmbedding_codRestrict he (fun z => Or.inr (Set.mem_range_self z))
+  cover := by
+    apply Set.eq_univ_of_forall
+    rintro ⟨x, hx | ⟨z, rfl⟩⟩
+    · exact Or.inl hx
+    · exact Or.inr ⟨z, rfl⟩
+  boundary := hface
+
+private def Smale.EmbeddedCellAttachment.oldNeighborhood {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) : Set X :=
+  (D.cell '' {z : Smale.MorseHandle.UnitDisk N | ‖(z : N)‖ ≤ 1 / 2})ᶜ
+
+private def Smale.EmbeddedCellAttachment.diskPatch {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) : Set X :=
+  D.oldᶜ
+
+private theorem
+    Smale.EmbeddedCellAttachment.isOpen_oldNeighborhood {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) : IsOpen D.oldNeighborhood :=
+  (D.cell_closed.isClosedMap _
+      (isClosed_le continuous_subtype_val.norm continuous_const)).isOpen_compl
+
+private theorem Smale.EmbeddedCellAttachment.isOpen_diskPatch {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) : IsOpen D.diskPatch :=
+  D.old_closed.isOpen_compl
+
+private theorem Smale.EmbeddedCellAttachment.cell_mem_oldNeighborhood_iff {N X : Type*}
+    [NormedAddCommGroup N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X)
+    (z : Smale.MorseHandle.UnitDisk N) : D.cell z ∈ D.oldNeighborhood ↔ 1 / 2 < ‖(z : N)‖ := by
+  constructor
+  · intro hz
+    by_contra! hnorm
+    exact hz ⟨z, hnorm, rfl⟩
+  · rintro hnorm ⟨w, hw, heq⟩
+    have hwz : w = z := D.cell_closed.injective heq
+    subst w
+    exact (not_le_of_gt hnorm) hw
+
+private theorem
+    Smale.EmbeddedCellAttachment.cell_mem_diskPatch_iff {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X)
+    (z : Smale.MorseHandle.UnitDisk N) : D.cell z ∈ D.diskPatch ↔ ‖(z : N)‖ < 1 := by
+  change D.cell z ∉ D.old ↔ ‖(z : N)‖ < 1
+  rw [D.boundary]
+  have hz : ‖(z : N)‖ ≤ 1 := mem_closedBall_zero_iff.mp z.property
+  constructor
+  · intro h
+    exact lt_of_le_of_ne hz h
+  · exact ne_of_lt
+
+private theorem
+    Smale.EmbeddedCellAttachment.old_subset_neighborhood {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) : D.old ⊆ D.oldNeighborhood := by
+  rintro x hx ⟨z, hz, rfl⟩
+  have heq := (D.boundary z).mp hx
+  change ‖(z : N)‖ ≤ 1 / 2 at hz
+  linarith
+
+private theorem Smale.EmbeddedCellAttachment.open_cover {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    D.oldNeighborhood ∪ D.diskPatch = Set.univ := by
+  apply Set.eq_univ_of_forall
+  intro x
+  by_cases hx : x ∈ D.old
+  · exact Or.inl (D.old_subset_neighborhood hx)
+  · exact Or.inr hx
+
+private theorem
+    Smale.EmbeddedCellAttachment.diskPatch_subset_range {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    D.diskPatch ⊆ Set.range D.cell := by
+  intro x hx
+  have hcover : x ∈ D.old ∪ Set.range D.cell := by rw [D.cover]; trivial
+  exact hcover.resolve_left hx
+
+private theorem
+    Smale.EmbeddedCellAttachment.overlap_subset_range {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    D.oldNeighborhood ∩ D.diskPatch ⊆ Set.range D.cell :=
+  Set.inter_subset_right.trans D.diskPatch_subset_range
+
+private def Smale.EmbeddedCellAttachment.diskHomeomorph {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    { z : Smale.MorseHandle.UnitDisk N // ‖(z : N)‖ < 1 } ≃ₜ D.diskPatch :=
+  (Homeomorph.setCongr
+        (by
+          ext z
+          exact (D.cell_mem_diskPatch_iff z).symm)).trans
+    (D.cell_closed.isEmbedding.homeomorphOfSubsetRange D.diskPatch_subset_range)
+
+private def Smale.EmbeddedCellAttachment.overlapHomeomorph {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    { z : Smale.MorseHandle.UnitDisk N // 1 / 2 < ‖(z : N)‖ ∧ ‖(z : N)‖ < 1 } ≃ₜ
+      ↥(D.oldNeighborhood ∩ D.diskPatch) :=
+  (Homeomorph.setCongr
+        (by
+          ext z
+          exact
+            (and_congr (D.cell_mem_oldNeighborhood_iff z)
+                (D.cell_mem_diskPatch_iff z)).symm)).trans
+    (D.cell_closed.isEmbedding.homeomorphOfSubsetRange D.overlap_subset_range)
+
+private abbrev Smale.OuterDisk.Space (E : Type*) [NormedAddCommGroup E] :=
+  { z : Smale.MorseHandle.UnitDisk E // 1 / 2 < ‖(z : E)‖ }
+
+private theorem Smale.OuterDisk.norm_pos {E : Type*} [NormedAddCommGroup E] (z : Space E) :
+    0 < ‖(z.val : E)‖ := by linarith [z.property]
+
+private def Smale.OuterDisk.sphereDisk {E : Type*} [NormedAddCommGroup E] :
+    C(Metric.sphere (0 : E) 1, Smale.MorseHandle.UnitDisk E) :=
+  ⟨Set.inclusion Metric.sphere_subset_closedBall, continuous_inclusion _⟩
+
+private theorem Smale.OuterDisk.sphereDisk_mem {E : Type*} [NormedAddCommGroup E]
+    (u : Metric.sphere (0 : E) 1) : 1 / 2 < ‖(sphereDisk u : E)‖ := by
+  change 1 / 2 < ‖(u : E)‖
+  rw [mem_sphere_zero_iff_norm.mp u.property]
+  norm_num
+
+private def Smale.OuterDisk.fromSphere {E : Type*} [NormedAddCommGroup E] :
+    C(Metric.sphere (0 : E) 1, Space E) :=
+  ⟨fun u => ⟨sphereDisk u, sphereDisk_mem u⟩, sphereDisk.continuous.subtype_mk _⟩
+
+private def Smale.OuterDisk.toSphere {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] :
+    C(Space E, Metric.sphere (0 : E) 1) :=
+  ⟨fun z => Smale.RadialExtension.direction (z.val : E) (norm_ne_zero_iff.mp (norm_pos z).ne'),
+    (((continuous_subtype_val.comp continuous_subtype_val).norm.inv₀
+              (fun z => (norm_pos z).ne')).smul
+          (continuous_subtype_val.comp continuous_subtype_val)).subtype_mk
+      _⟩
+
+private theorem Smale.OuterDisk.fromSphere_toSphere_boundary {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (z : Space E) (hz : ‖(z.val : E)‖ = 1) : fromSphere (toSphere z) = z := by
+  apply Subtype.ext
+  apply Subtype.ext
+  change ‖(z.val : E)‖⁻¹ • (z.val : E) = (z.val : E)
+  rw [hz, inv_one, one_smul]
+
+private def Smale.OuterDisk.blendVector {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (q : (unitInterval) × Space E) : E :=
+  ((1 - (q.1 : ℝ)) + (q.1 : ℝ) / ‖(q.2.val : E)‖) • (q.2.val : E)
+
+private theorem Smale.OuterDisk.continuous_blendVector {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] : Continuous (blendVector (E := E)) := by
+  have ht : Continuous (fun q : (unitInterval) × Space E => (q.1 : ℝ)) :=
+    continuous_subtype_val.comp continuous_fst
+  have hz : Continuous (fun q : (unitInterval) × Space E => (q.2.val : E)) :=
+    continuous_subtype_val.comp (continuous_subtype_val.comp continuous_snd)
+  exact ((continuous_const.sub ht).add (ht.div hz.norm (fun q => (norm_pos q.2).ne'))).smul hz
+
+private theorem
+    Smale.OuterDisk.norm_blendVector {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (t : (unitInterval)) (z : Space E) :
+    ‖blendVector (t, z)‖ = (1 - (t : ℝ)) * ‖(z.val : E)‖ + (t : ℝ) := by
+  have hscale : 0 ≤ (1 - (t : ℝ)) + (t : ℝ) / ‖(z.val : E)‖ :=
+    add_nonneg (sub_nonneg.mpr t.property.2) (div_nonneg t.property.1 (norm_pos z).le)
+  rw [blendVector, norm_smul, Real.norm_eq_abs, abs_of_nonneg hscale, add_mul,
+    div_mul_cancel₀ _ (norm_pos z).ne']
+
+private theorem
+    Smale.OuterDisk.norm_blendVector_mem {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (t : (unitInterval)) (z : Space E) :
+    1 / 2 < ‖blendVector (t, z)‖ ∧ ‖blendVector (t, z)‖ ≤ 1 := by
+  rw [norm_blendVector]
+  have hz : ‖(z.val : E)‖ ∈ Set.Ioc (1 / 2 : ℝ) 1 :=
+    ⟨z.property, mem_closedBall_zero_iff.mp z.val.property⟩
+  have h :=
+    (convex_Ioc (𝕜 := ℝ) (1 / 2 : ℝ) 1) hz (by norm_num : (1 : ℝ) ∈ Ioc (1 / 2) 1)
+      (sub_nonneg.mpr t.property.2) t.property.1 (sub_add_cancel 1 (t : ℝ))
+  simpa only [Set.mem_Ioc, smul_eq_mul, mul_one] using h
+
+private def Smale.OuterDisk.blend {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (q : (unitInterval) × Space E) : Space E :=
+  ⟨⟨blendVector q, mem_closedBall_zero_iff.mpr (norm_blendVector_mem q.1 q.2).2⟩,
+    (norm_blendVector_mem q.1 q.2).1⟩
+
+private theorem
+    Smale.OuterDisk.continuous_blend {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] :
+    Continuous (blend (E := E)) :=
+  (continuous_blendVector.subtype_mk _).subtype_mk _
+
+private def Smale.OuterDisk.deformation {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] :
+    (ContinuousMap.id (Space E)).HomotopyRel (fromSphere.comp toSphere) {z | ‖(z.val : E)‖ = 1}
+    where
+  toFun := blend
+  continuous_toFun := continuous_blend
+  map_zero_left
+    z := by
+    apply Subtype.ext
+    apply Subtype.ext
+    simp [blend, blendVector]
+  map_one_left
+    z := by
+    apply Subtype.ext
+    apply Subtype.ext
+    simp [blend, blendVector, fromSphere, sphereDisk, toSphere, Smale.RadialExtension.direction]
+  prop' t z
+    hz := by
+    apply Subtype.ext
+    apply Subtype.ext
+    change ((1 - (t : ℝ)) + (t : ℝ) / ‖(z.val : E)‖) • (z.val : E) = (z.val : E)
+    rw [hz, div_one, sub_add_cancel, one_smul]
+
+private def Smale.EmbeddedCellAttachment.oldInclusion {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) : C(D.old, D.oldNeighborhood) :=
+  ⟨Set.inclusion D.old_subset_neighborhood, continuous_inclusion _⟩
+
+private def
+    Smale.EmbeddedCellAttachment.outerParameterHomeomorph {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    Smale.OuterDisk.Space N ≃ₜ (D.cell ⁻¹' D.oldNeighborhood) :=
+  Homeomorph.setCongr (by ext z; exact (D.cell_mem_oldNeighborhood_iff z).symm)
+
+private def Smale.EmbeddedCellAttachment.outerInclusion {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    C(Smale.OuterDisk.Space N, D.oldNeighborhood) :=
+  ⟨fun z => ⟨D.cell z.val, (D.cell_mem_oldNeighborhood_iff z.val).mpr z.property⟩,
+    (D.cell.continuous.comp continuous_subtype_val).subtype_mk _⟩
+
+private theorem
+    Smale.EmbeddedCellAttachment.oldInclusion_closed {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    Topology.IsClosedEmbedding D.oldInclusion :=
+  Smale.ClosedCover.isClosedEmbedding_codRestrict D.old_closed.isClosedEmbedding_subtypeVal
+    (fun x => D.old_subset_neighborhood x.property)
+
+private theorem
+    Smale.EmbeddedCellAttachment.outerInclusion_closed {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    Topology.IsClosedEmbedding D.outerInclusion :=
+  (D.oldNeighborhood.restrictPreimage_isClosedEmbedding D.cell_closed).comp
+    D.outerParameterHomeomorph.isClosedEmbedding
+
+private theorem
+    Smale.EmbeddedCellAttachment.oldNeighborhood_cover {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    Set.range D.oldInclusion ∪ Set.range D.outerInclusion = Set.univ := by
+  apply Set.eq_univ_of_forall
+  rintro ⟨x, hx⟩
+  have hcover : x ∈ D.old ∪ Set.range D.cell := by rw [D.cover]; trivial
+  rcases hcover with hA | ⟨z, rfl⟩
+  · exact Or.inl ⟨⟨x, hA⟩, rfl⟩
+  · exact Or.inr ⟨⟨z, (D.cell_mem_oldNeighborhood_iff z).mp hx⟩, rfl⟩
+
+private theorem Smale.EmbeddedCellAttachment.sphere_attaches {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) (u : Metric.sphere (0 : N) 1) :
+    D.cell (Smale.OuterDisk.sphereDisk u) ∈ D.old :=
+  (D.boundary _).mpr (mem_sphere_zero_iff_norm.mp u.property)
+
+private def Smale.EmbeddedCellAttachment.attachingSphere {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    C(Metric.sphere (0 : N) 1, D.old) :=
+  ⟨fun u => ⟨D.cell (Smale.OuterDisk.sphereDisk u), D.sphere_attaches u⟩,
+    (D.cell.continuous.comp Smale.OuterDisk.sphereDisk.continuous).subtype_mk _⟩
+
+private theorem
+    Smale.EmbeddedCellAttachment.retractionMaps_agree {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) [NormedSpace ℝ N] (a : D.old)
+    (z : Smale.OuterDisk.Space N) (haz : D.oldInclusion a = D.outerInclusion z) :
+    a = D.attachingSphere (Smale.OuterDisk.toSphere z) := by
+  have heq : (a : X) = D.cell z.val := congrArg Subtype.val haz
+  have hnorm : ‖(z.val : N)‖ = 1 := (D.boundary z.val).mp (heq ▸ a.property)
+  have hs : Smale.OuterDisk.sphereDisk (Smale.OuterDisk.toSphere z) = z.val :=
+    congrArg Subtype.val (Smale.OuterDisk.fromSphere_toSphere_boundary z hnorm)
+  apply Subtype.ext
+  change (a : X) = D.cell (Smale.OuterDisk.sphereDisk (Smale.OuterDisk.toSphere z))
+  rw [hs]
+  exact heq
+
+private def Smale.EmbeddedCellAttachment.oldRetraction {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) [NormedSpace ℝ N] :
+    C(D.oldNeighborhood, D.old) :=
+  Smale.ClosedCover.mapOfClosedPieces D.oldInclusion D.outerInclusion D.oldInclusion_closed
+    D.outerInclusion_closed D.oldNeighborhood_cover (ContinuousMap.id D.old)
+    (D.attachingSphere.comp Smale.OuterDisk.toSphere) D.retractionMaps_agree
+
+private theorem Smale.EmbeddedCellAttachment.oldRetraction_old {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) [NormedSpace ℝ N] (a : D.old) :
+    D.oldRetraction (D.oldInclusion a) = a :=
+  Smale.ClosedCover.mapOfClosedPieces_left D.oldInclusion D.outerInclusion D.oldInclusion_closed
+    D.outerInclusion_closed D.oldNeighborhood_cover (ContinuousMap.id D.old)
+    (D.attachingSphere.comp Smale.OuterDisk.toSphere) D.retractionMaps_agree a
+
+private theorem
+    Smale.EmbeddedCellAttachment.oldRetraction_outer {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) [NormedSpace ℝ N]
+    (z : Smale.OuterDisk.Space N) :
+    D.oldRetraction (D.outerInclusion z) = D.attachingSphere (Smale.OuterDisk.toSphere z) :=
+  Smale.ClosedCover.mapOfClosedPieces_right D.oldInclusion D.outerInclusion D.oldInclusion_closed
+    D.outerInclusion_closed D.oldNeighborhood_cover (ContinuousMap.id D.old)
+    (D.attachingSphere.comp Smale.OuterDisk.toSphere) D.retractionMaps_agree z
+
+private theorem
+    Smale.EmbeddedCellAttachment.neighborhood_time_cover {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    Set.range (Prod.map (id : (unitInterval) → (unitInterval)) D.oldInclusion) ∪
+        Set.range (Prod.map (id : (unitInterval) → (unitInterval)) D.outerInclusion) =
+      Set.univ := by
+  apply Set.eq_univ_of_forall
+  rintro ⟨t, x⟩
+  have hx : x ∈ Set.range D.oldInclusion ∪ Set.range D.outerInclusion := by
+    rw [D.oldNeighborhood_cover]
+    trivial
+  rcases hx with ⟨a, rfl⟩ | ⟨z, rfl⟩
+  · exact Or.inl ⟨(t, a), rfl⟩
+  · exact Or.inr ⟨(t, z), rfl⟩
+
+private def Smale.EmbeddedCellAttachment.stationaryOld {N X : Type*} [NormedAddCommGroup N]
+    [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    C((unitInterval) × D.old, D.oldNeighborhood) :=
+  D.oldInclusion.comp ContinuousMap.snd
+
+private def Smale.EmbeddedCellAttachment.movingOuter {N X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    C((unitInterval) × Smale.OuterDisk.Space N, D.oldNeighborhood) :=
+  D.outerInclusion.comp Smale.OuterDisk.deformation.toHomotopy.toContinuousMap
+
+private theorem Smale.EmbeddedCellAttachment.neighborhoodMotions_agree {N X : Type*}
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [TopologicalSpace X]
+    (D : Smale.EmbeddedCellAttachment N X) (a : (unitInterval) × D.old)
+    (z : (unitInterval) × Smale.OuterDisk.Space N)
+    (haz : Prod.map id D.oldInclusion a = Prod.map id D.outerInclusion z) :
+    D.stationaryOld a = D.movingOuter z := by
+  have ha : D.oldInclusion a.2 = D.outerInclusion z.2 := congrArg Prod.snd haz
+  have heq : (a.2 : X) = D.cell z.2.val := congrArg Subtype.val ha
+  have hn : ‖(z.2.val : N)‖ = 1 := (D.boundary z.2.val).mp (heq ▸ a.2.property)
+  change D.oldInclusion a.2 = D.outerInclusion (Smale.OuterDisk.deformation (z.1, z.2))
+  rw [Smale.OuterDisk.deformation.eq_fst z.1 hn]
+  exact ha
+
+private def Smale.EmbeddedCellAttachment.neighborhoodMotion {N X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    C((unitInterval) × D.oldNeighborhood, D.oldNeighborhood) :=
+  Smale.ClosedCover.mapOfClosedPieces (Prod.map id D.oldInclusion) (Prod.map id D.outerInclusion)
+    (Topology.IsClosedEmbedding.id.prodMap D.oldInclusion_closed)
+    (Topology.IsClosedEmbedding.id.prodMap D.outerInclusion_closed) D.neighborhood_time_cover
+    D.stationaryOld D.movingOuter D.neighborhoodMotions_agree
+
+private theorem
+    Smale.EmbeddedCellAttachment.neighborhoodMotion_old {N X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X)
+    (t : (unitInterval)) (a : D.old) :
+    D.neighborhoodMotion (t, D.oldInclusion a) = D.oldInclusion a :=
+  Smale.ClosedCover.mapOfClosedPieces_left (Prod.map id D.oldInclusion)
+    (Prod.map id D.outerInclusion) (Topology.IsClosedEmbedding.id.prodMap D.oldInclusion_closed)
+    (Topology.IsClosedEmbedding.id.prodMap D.outerInclusion_closed) D.neighborhood_time_cover
+    D.stationaryOld D.movingOuter D.neighborhoodMotions_agree (t, a)
+
+private theorem
+    Smale.EmbeddedCellAttachment.neighborhoodMotion_outer {N X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X)
+    (t : (unitInterval)) (z : Smale.OuterDisk.Space N) :
+    D.neighborhoodMotion (t, D.outerInclusion z) =
+      D.outerInclusion (Smale.OuterDisk.deformation (t, z)) :=
+  Smale.ClosedCover.mapOfClosedPieces_right (Prod.map id D.oldInclusion)
+    (Prod.map id D.outerInclusion) (Topology.IsClosedEmbedding.id.prodMap D.oldInclusion_closed)
+    (Topology.IsClosedEmbedding.id.prodMap D.outerInclusion_closed) D.neighborhood_time_cover
+    D.stationaryOld D.movingOuter D.neighborhoodMotions_agree (t, z)
+
+private def Smale.EmbeddedCellAttachment.oldDeformation {N X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    (ContinuousMap.id D.oldNeighborhood).HomotopyRel (D.oldInclusion.comp D.oldRetraction)
+      (Set.range D.oldInclusion)
+    where
+  toFun := D.neighborhoodMotion
+  continuous_toFun := D.neighborhoodMotion.continuous
+  map_zero_left
+    x := by
+    have hx : x ∈ Set.range D.oldInclusion ∪ Set.range D.outerInclusion := by
+      rw [D.oldNeighborhood_cover]
+      trivial
+    rcases hx with ⟨a, rfl⟩ | ⟨z, rfl⟩
+    · exact D.neighborhoodMotion_old 0 a
+    · rw [D.neighborhoodMotion_outer]
+      exact congrArg D.outerInclusion (Smale.OuterDisk.deformation.toHomotopy.map_zero_left z)
+  map_one_left
+    x := by
+    change D.neighborhoodMotion (1, x) = D.oldInclusion (D.oldRetraction x)
+    have hx : x ∈ Set.range D.oldInclusion ∪ Set.range D.outerInclusion := by
+      rw [D.oldNeighborhood_cover]
+      trivial
+    rcases hx with ⟨a, rfl⟩ | ⟨z, rfl⟩
+    · rw [D.neighborhoodMotion_old, D.oldRetraction_old]
+    · rw [D.neighborhoodMotion_outer, D.oldRetraction_outer]
+      exact congrArg D.outerInclusion (Smale.OuterDisk.deformation.toHomotopy.map_one_left z)
+  prop' t x
+    hx := by
+    obtain ⟨a, rfl⟩ := hx
+    exact D.neighborhoodMotion_old t a
+
+private def Smale.EmbeddedCellAttachment.oldHomotopyEquiv {N X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    D.old ≃ₕ D.oldNeighborhood where
+  toFun := D.oldInclusion
+  invFun := D.oldRetraction
+  left_inv := by
+    have heq : D.oldRetraction.comp D.oldInclusion = ContinuousMap.id D.old :=
+      ContinuousMap.ext D.oldRetraction_old
+    rw [heq]
+  right_inv := ⟨D.oldDeformation.toHomotopy.symm⟩
+
+private abbrev Smale.DiskAnnulus.OpenDisk (E : Type*) [NormedAddCommGroup E] :=
+  { z : Smale.MorseHandle.UnitDisk E // ‖(z : E)‖ < 1 }
+
+private abbrev Smale.DiskAnnulus.Annulus (E : Type*) [NormedAddCommGroup E] :=
+  { z : Smale.MorseHandle.UnitDisk E // 1 / 2 < ‖(z : E)‖ ∧ ‖(z : E)‖ < 1 }
+
+private theorem Smale.DiskAnnulus.norm_pos {E : Type*} [NormedAddCommGroup E] (z : Annulus E) :
+    0 < ‖(z.val : E)‖ := by linarith [z.property.1]
+
+private def Smale.DiskAnnulus.openDiskHomeomorph {E : Type*} [NormedAddCommGroup E] :
+    OpenDisk E ≃ₜ Metric.ball (0 : E) 1
+    where
+  toFun z := ⟨z.val.val, mem_ball_zero_iff.mpr z.property⟩
+  invFun
+    z :=
+    ⟨⟨z.val, mem_closedBall_zero_iff.mpr (mem_ball_zero_iff.mp z.property).le⟩,
+      mem_ball_zero_iff.mp z.property⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := (continuous_subtype_val.comp continuous_subtype_val).subtype_mk _
+  continuous_invFun := (continuous_subtype_val.subtype_mk _).subtype_mk _
+
+private theorem Smale.DiskAnnulus.openDisk_contractible {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] : ContractibleSpace (OpenDisk E) := by
+  let : ContractibleSpace (Metric.ball (0 : E) 1) :=
+    (convex_ball (0 : E) 1).contractibleSpace ⟨0, by simp⟩
+  exact openDiskHomeomorph.contractibleSpace
+
+private def Smale.DiskAnnulus.toSphere {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] :
+    C(Annulus E, Metric.sphere (0 : E) 1) :=
+  ⟨fun z => Smale.RadialExtension.direction (z.val : E) (norm_ne_zero_iff.mp (norm_pos z).ne'),
+    (((continuous_subtype_val.comp continuous_subtype_val).norm.inv₀
+              (fun z => (norm_pos z).ne')).smul
+          (continuous_subtype_val.comp continuous_subtype_val)).subtype_mk
+      _⟩
+
+private theorem Smale.DiskAnnulus.norm_middle {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (u : Metric.sphere (0 : E) 1) : ‖(3 / 4 : ℝ) • (u : E)‖ = 3 / 4 := by
+  rw [norm_smul, Real.norm_eq_abs, abs_of_pos (by norm_num : (0 : ℝ) < 3 / 4),
+    mem_sphere_zero_iff_norm.mp u.property, mul_one]
+
+private def Smale.DiskAnnulus.middleDisk {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (u : Metric.sphere (0 : E) 1) : Smale.MorseHandle.UnitDisk E :=
+  ⟨(3 / 4 : ℝ) • (u : E), by
+    rw [mem_closedBall_zero_iff, norm_middle]
+    norm_num⟩
+
+private theorem
+    Smale.DiskAnnulus.middleDisk_mem {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (u : Metric.sphere (0 : E) 1) : 1 / 2 < ‖(middleDisk u : E)‖ ∧ ‖(middleDisk u : E)‖ < 1 := by
+  change 1 / 2 < ‖(3 / 4 : ℝ) • (u : E)‖ ∧ ‖(3 / 4 : ℝ) • (u : E)‖ < 1
+  rw [norm_middle]
+  norm_num
+
+private def Smale.DiskAnnulus.fromSphere {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] :
+    C(Metric.sphere (0 : E) 1, Annulus E) :=
+  ⟨fun u => ⟨middleDisk u, middleDisk_mem u⟩,
+    ((continuous_const.smul continuous_subtype_val).subtype_mk _).subtype_mk _⟩
+
+private theorem
+    Smale.DiskAnnulus.toSphere_fromSphere {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (u : Metric.sphere (0 : E) 1) : toSphere (fromSphere u) = u := by
+  apply Subtype.ext
+  change ‖(3 / 4 : ℝ) • (u : E)‖⁻¹ • ((3 / 4 : ℝ) • (u : E)) = (u : E)
+  rw [norm_middle, inv_smul_smul₀ (by norm_num : (3 / 4 : ℝ) ≠ 0)]
+
+private def Smale.DiskAnnulus.blendVector {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (q : (unitInterval) × Annulus E) : E :=
+  ((1 - (q.1 : ℝ)) + (q.1 : ℝ) * ((3 / 4 : ℝ) / ‖(q.2.val : E)‖)) • (q.2.val : E)
+
+private theorem Smale.DiskAnnulus.continuous_blendVector {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] : Continuous (blendVector (E := E)) := by
+  have ht : Continuous (fun q : (unitInterval) × Annulus E => (q.1 : ℝ)) :=
+    continuous_subtype_val.comp continuous_fst
+  have hz : Continuous (fun q : (unitInterval) × Annulus E => (q.2.val : E)) :=
+    continuous_subtype_val.comp (continuous_subtype_val.comp continuous_snd)
+  exact
+    ((continuous_const.sub ht).add
+          (ht.mul (continuous_const.div hz.norm (fun q => (norm_pos q.2).ne')))).smul
+      hz
+
+private theorem
+    Smale.DiskAnnulus.norm_blendVector {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (t : (unitInterval)) (z : Annulus E) :
+    ‖blendVector (t, z)‖ = (1 - (t : ℝ)) * ‖(z.val : E)‖ + (t : ℝ) * (3 / 4) := by
+  have hscale : 0 ≤ (1 - (t : ℝ)) + (t : ℝ) * ((3 / 4 : ℝ) / ‖(z.val : E)‖) :=
+    add_nonneg (sub_nonneg.mpr t.property.2)
+      (mul_nonneg t.property.1 (div_nonneg (by norm_num) (norm_pos z).le))
+  rw [blendVector, norm_smul, Real.norm_eq_abs, abs_of_nonneg hscale, add_mul, mul_assoc,
+    div_mul_cancel₀ _ (norm_pos z).ne']
+
+private theorem Smale.DiskAnnulus.norm_blendVector_mem {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (t : (unitInterval)) (z : Annulus E) :
+    1 / 2 < ‖blendVector (t, z)‖ ∧ ‖blendVector (t, z)‖ < 1 := by
+  rw [norm_blendVector]
+  have h :=
+    (convex_Ioo (𝕜 := ℝ) (1 / 2 : ℝ) 1) z.property (by norm_num : (3 / 4 : ℝ) ∈ Ioo (1 / 2) 1)
+      (sub_nonneg.mpr t.property.2) t.property.1 (sub_add_cancel 1 (t : ℝ))
+  exact h
+
+private def Smale.DiskAnnulus.blend {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (q : (unitInterval) × Annulus E) : Annulus E :=
+  ⟨⟨blendVector q, mem_closedBall_zero_iff.mpr (norm_blendVector_mem q.1 q.2).2.le⟩,
+    norm_blendVector_mem q.1 q.2⟩
+
+private theorem
+    Smale.DiskAnnulus.continuous_blend {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] :
+    Continuous (blend (E := E)) :=
+  (continuous_blendVector.subtype_mk _).subtype_mk _
+
+private def Smale.DiskAnnulus.deformation {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] :
+    (ContinuousMap.id (Annulus E)).Homotopy (fromSphere.comp toSphere)
+    where
+  toFun := blend
+  continuous_toFun := continuous_blend
+  map_zero_left
+    z := by
+    apply Subtype.ext
+    apply Subtype.ext
+    simp [blend, blendVector]
+  map_one_left
+    z := by
+    apply Subtype.ext
+    apply Subtype.ext
+    simp [blend, blendVector, fromSphere, middleDisk, toSphere, Smale.RadialExtension.direction,
+      div_eq_mul_inv, smul_smul]
+
+private def
+    Smale.DiskAnnulus.sphereHomotopyEquiv {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] :
+    Metric.sphere (0 : E) 1 ≃ₕ Annulus E
+    where
+  toFun := fromSphere
+  invFun := toSphere
+  left_inv := by
+    have heq : toSphere.comp fromSphere = ContinuousMap.id (Metric.sphere (0 : E) 1) :=
+      ContinuousMap.ext toSphere_fromSphere
+    rw [heq]
+  right_inv := ⟨deformation.symm⟩
+
+private theorem
+    Smale.EmbeddedCellAttachment.diskPatch_contractible {N X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    ContractibleSpace D.diskPatch := by
+  let : ContractibleSpace (Smale.DiskAnnulus.OpenDisk N) :=
+    Smale.DiskAnnulus.openDisk_contractible
+  exact D.diskHomeomorph.symm.contractibleSpace
+
+private def Smale.EmbeddedCellAttachment.overlapSphereEquiv {N X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    Metric.sphere (0 : N) 1 ≃ₕ ↥(D.oldNeighborhood ∩ D.diskPatch) :=
+  Smale.DiskAnnulus.sphereHomotopyEquiv.trans D.overlapHomeomorph.toHomotopyEquiv
+
+private def Smale.EmbeddedCellAttachment.overlapOldMap {N X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X) :
+    C(↥(D.oldNeighborhood ∩ D.diskPatch), D.old) :=
+  D.oldRetraction.comp (ContinuousMap.inclusion Set.inter_subset_left)
+
+private theorem
+    Smale.EmbeddedCellAttachment.overlapOldMap_sphere {N X : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [TopologicalSpace X] (D : Smale.EmbeddedCellAttachment N X)
+    (u : Metric.sphere (0 : N) 1) :
+    D.overlapOldMap (D.overlapSphereEquiv u) = D.attachingSphere u := by
+  let z : Smale.OuterDisk.Space N :=
+    ⟨(Smale.DiskAnnulus.fromSphere u).val, (Smale.DiskAnnulus.fromSphere u).property.1⟩
+  change D.oldRetraction (D.outerInclusion z) = D.attachingSphere u
+  rw [D.oldRetraction_outer]
+  apply congrArg D.attachingSphere
+  exact Smale.DiskAnnulus.toSphere_fromSphere u
+
+private theorem Smale.EmbeddedCellAttachment.overlapOldMap_comp_sphere {N X : Type*}
+    [NormedAddCommGroup N] [NormedSpace ℝ N] [TopologicalSpace X]
+    (D : Smale.EmbeddedCellAttachment N X) :
+    D.overlapOldMap.comp D.overlapSphereEquiv.toFun = D.attachingSphere :=
+  ContinuousMap.ext D.overlapOldMap_sphere
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    Smale.ManifoldMorse.MorseSurgeryData.coreCellPresentation {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f) :
+    Smale.EmbeddedCellAttachment d.chart.NegativeCoordinates
+      ↥({y : M | f y ≤ f p - d.radius ^ 2} ∪ Set.range d.coreMap) :=
+  Smale.EmbeddedCellAttachment.ofUnion _ d.coreMap (isClosed_le hf continuous_const)
+    d.coreMap_isClosedEmbedding d.coreMap_lower_iff
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    Smale.ManifoldMorse.MorseSurgeryData.cellOldHomeomorph {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f) :
+    { y : M // f y ≤ f p - d.radius ^ 2 } ≃ₜ (d.coreCellPresentation hf).old
+    where
+  toFun x := ⟨⟨x.val, Or.inl x.property⟩, x.property⟩
+  invFun x := ⟨x.val.val, x.property⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := (continuous_subtype_val.subtype_mk _).subtype_mk _
+  continuous_invFun := (continuous_subtype_val.comp continuous_subtype_val).subtype_mk _
+
+attribute [local instance 100] Classical.propDecidable in
+private def
+    Smale.ManifoldMorse.MorseSurgeryData.coreBoundaryMap {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) :
+    C(Metric.sphere (0 : d.chart.NegativeCoordinates) 1, { y : M // f y ≤ f p - d.radius ^ 2 }) :=
+  (⟨Set.inclusion (fun _ hx => hx.le), continuous_inclusion _⟩ :
+        C(d.LowerLevel, { y : M // f y ≤ f p - d.radius ^ 2 })).comp
+    d.surgery.attachingSphere
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem Smale.ManifoldMorse.MorseSurgeryData.coreCell_attaching_eq {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [T2Space M]
+    {f : M → ℝ} {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (hf : Continuous f) :
+    (d.coreCellPresentation hf).attachingSphere =
+      (d.cellOldHomeomorph hf).toHomotopyEquiv.toFun.comp d.coreBoundaryMap := by
+  apply ContinuousMap.ext
+  intro u
+  apply Subtype.ext
+  apply Subtype.ext
+  exact d.coreMap_boundary u
+
+attribute [local instance 100] Classical.propDecidable in
+private def Smale.ManifoldMorse.MorseSurgeryData.realizedLowerInclusion {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} (d : Smale.ManifoldMorse.MorseSurgeryData E f p) :
+    C({ y : M // f y ≤ f p - d.radius ^ 2 }, { y : M // f y ≤ f p + d.radius ^ 2 }) :=
+  ⟨fun x => d.attachmentHomeomorph ⟨x.val, Or.inl x.property⟩,
+    d.attachmentHomeomorph.continuous.comp (continuous_inclusion (fun _ hx => Or.inl hx))⟩
+
+private theorem
+    AdaptedWindows.forward_limit_below_regular_level {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a : ℝ}
+    (hreg : ∀ x, f x = a → x ∉ Smale.ManifoldMorse.criticalPoints E f) (x : { y : M // f y = a })
+    {p : M} (hlim : Filter.Tendsto (fun t => S.flow t x) Filter.atTop (𝓝 p)) : f p < a := by
+  obtain ⟨r, hr, q, hq, -, hqLim, hheight⟩ :=
+    Degree.FlowCancellation.exists_native_descent_endpoints hf S.smooth S.flow S.integral S.zero
+      S.descent S.distinct (x : M)
+  have hqp : q = p := tendsto_nhds_unique hqLim hlim
+  have hh := (hheight (hreg x x.property)).1
+  simpa only [hqp, x.property] using hh
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem AdaptedWindows.place_one_handle_in_distinct_minimum_basins {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (q : Smale.ManifoldMorse.criticalPoints E f) (hone : MorseCancel.nativeMorseIndex E f q = 1)
+    (u v : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (hnot : ¬Joined ((S.data q).coreBoundaryMap u) ((S.data q).coreBoundaryMap v)) :
+    letI := Smale.RegularLevel.chartedSpace hf (S.data q).lower_regular
+    ∃ d :
+      Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+        (S.data q).LowerLevel (S.data q).LowerLevel ∞,
+      Smale.SupportedDiffeomorph.IsotopicToIdentity d ∧
+        ∃ p r : Smale.ManifoldMorse.criticalPoints E f,
+          MorseCancel.nativeMorseIndex E f p = 0 ∧
+            MorseCancel.nativeMorseIndex E f r = 0 ∧
+              p ≠ r ∧
+                f p < S.toSurgeryWindows.lower q ∧
+                  f r < S.toSurgeryWindows.lower q ∧
+                    Filter.Tendsto
+                        (fun t => S.flow t (d ((S.data q).surgery.attachingSphere u)).val)
+                        Filter.atTop (𝓝 p.val) ∧
+                      Filter.Tendsto
+                          (fun t => S.flow t (d ((S.data q).surgery.attachingSphere v)).val)
+                          Filter.atTop (𝓝 r.val) ∧
+                        ∀ w : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1,
+                          Filter.Tendsto
+                              (fun t => S.flow t (d ((S.data q).surgery.attachingSphere w)).val)
+                              Filter.atTop (𝓝 p.val) ∨
+                            Filter.Tendsto
+                              (fun t => S.flow t (d ((S.data q).surgery.attachingSphere w)).val)
+                              Filter.atTop (𝓝 r.val) := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data q).lower_regular
+  let _ := Smale.RegularLevel.isManifold hf (S.data q).lower_regular
+  let ι : C((S.data q).LowerLevel, { z : M // f z ≤ S.toSurgeryWindows.lower q }) :=
+    ⟨fun x => ⟨x.val, x.property.le⟩, continuous_subtype_val.subtype_mk _⟩
+  let α := (S.data q).surgery.attachingSphere
+  have hxy : α u ≠ α v := by
+    intro h
+    have hh : (S.data q).coreBoundaryMap u = (S.data q).coreBoundaryMap v := congrArg ι h
+    exact hnot (hh ▸ Joined.refl _)
+  obtain ⟨d, hd, ⟨p, hp, hpu⟩, ⟨r, hr, hrv⟩⟩ :=
+    MorseCancel.exists_isotopic_two_points_in_dense (J := 𝓘(ℝ, Smale.RegularLevel.Model E))
+      (S.dense_regular_level_minimum_basins hf (S.data q).lower_regular) hxy
+  have hpq := S.forward_limit_below_regular_level hf (S.data q).lower_regular (d (α u)) hpu
+  have hrq := S.forward_limit_below_regular_level hf (S.data q).lower_regular (d (α v)) hrv
+  have hpr : p ≠ r := by
+    intro h
+    subst r
+    let : LocallyPathConnectedSpace M := ChartedSpace.locallyPathConnectedSpace E M
+    have hnew : Joined (ι (d (α u))) (ι (d (α v))) :=
+      MorseCancel.joined_sublevel_of_common_forward_limit S.flow hf.continuous
+        (Smale.FlowConstruction.antitone_flow_height hf S.flow S.integral S.zero S.descent)
+        (ι (d (α u))) (ι (d (α v))) hpq hpu hrv
+    exact
+      hnot
+        (((MorseCancel.isotopicToIdentity_joined hd (α u)).map ι.continuous).trans
+          (hnew.trans ((MorseCancel.isotopicToIdentity_joined hd (α v)).map ι.continuous).symm))
+  refine ⟨d, hd, p, r, hp, hr, hpr, hpq, hrq, hpu, hrv, ?_⟩
+  intro w
+  have hindex : Module.finrank ℝ (S.data q).chart.NegativeCoordinates = 1 :=
+    (MorseCancel.nativeMorseIndex_eq_chart (S.data q).chart).symm.trans hone
+  have huv : u ≠ v := fun h => hxy (congrArg α h)
+  rcases MorseCancel.unitSphere_eq_two_points_of_finrank_one hindex u v huv w with h | h
+  · subst w
+    exact Or.inl hpu
+  · subst w
+    exact Or.inr hrv
+
+private theorem MorseCancel.fderiv_beltPassage_upper_fst {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] (ρ s w : ℝ) (u : N) (v : P) :
+    (fderiv ℝ (fun t => Degree.BeltPassage.upper ρ t u v) s w).1 = (ρ * w) • u := by
+  have hfirst : HasDerivAt (fun t : ℝ => (Degree.BeltPassage.upper ρ t u v).1) (ρ • u) s := by
+    simpa only [Degree.BeltPassage.upper, id_eq, mul_one] using
+      ((hasDerivAt_id s).const_mul ρ).smul_const u
+  have hchain :
+    fderiv ℝ (fun t => (Degree.BeltPassage.upper ρ t u v).1) s =
+      (ContinuousLinearMap.fst ℝ N P).comp
+        (fderiv ℝ (fun t => Degree.BeltPassage.upper ρ t u v) s) := by
+    have hh :=
+      fderiv_comp s (ContinuousLinearMap.fst ℝ N P).differentiableAt
+        ((Degree.BeltPassage.contDiff_upper ρ u v).differentiable (by simp) s)
+    rw [(ContinuousLinearMap.fst ℝ N P).fderiv] at hh
+    exact hh
+  have hh := congrArg (fun L : ℝ →L[ℝ] N => L w) hchain
+  rw [hfirst.hasFDerivAt.fderiv] at hh
+  change w • (ρ • u) = (fderiv ℝ (fun t => Degree.BeltPassage.upper ρ t u v) s w).1 at hh
+  rw [smul_smul, mul_comm w ρ] at hh
+  exact hh.symm
+
+private theorem MorseCancel.injective_fderiv_beltPassage_upper {N P : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] [NormedAddCommGroup P] [NormedSpace ℝ P] {ρ : ℝ} (hρ : ρ ≠ 0) (s : ℝ)
+    {u : N} (hu : u ≠ 0) (v : P) :
+    Function.Injective (fderiv ℝ (fun t => Degree.BeltPassage.upper ρ t u v) s) := by
+  intro a b hab
+  have hh := congrArg Prod.fst hab
+  rw [fderiv_beltPassage_upper_fst, fderiv_beltPassage_upper_fst] at hh
+  exact mul_left_cancel₀ hρ (smul_left_injective ℝ hu hh)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.nativeBeltArc_derivative_injective {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    {f : M → ℝ} (S : AdaptedWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) {s : ℝ} (hs : |s| ≤ 1) :
+    Function.Injective (mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, E) (nativeBeltArc S q u v) s) := by
+  have ht := nativeBeltArc_coordinates_mem_target S q u v hs
+  have hu : u.val ≠ 0 := by
+    intro h
+    have hn := mem_sphere_zero_iff_norm.mp u.property
+    rw [h, norm_zero] at hn
+    exact zero_ne_one hn
+  change
+    Function.Injective
+      (mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, E)
+        ((S.data q).chart.splitChart.symm ∘
+          (fun t => Degree.BeltPassage.upper (S.data q).radius t u.val v.val))
+        s)
+  rw [mfderiv_comp s ((S.data q).chart.splitChart.symm.mdifferentiableAt (by simp) ht)
+      ((Degree.BeltPassage.contDiff_upper (S.data q).radius u.val
+            v.val).contMDiff.mdifferentiableAt
+        (by simp)),
+    mfderiv_eq_fderiv]
+  exact
+    (Smale.PartialChart.bijective_mfderiv (S.data q).chart.splitChart.symm ht).injective.comp
+      (injective_fderiv_beltPassage_upper (S.data q).radius_pos.ne' s hu v.val)
+
+private theorem
+    Smale.RegularLevel.contMDiffWithinAt_iff_inclusion {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {b : ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f) {G H X : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H] (I : ModelWithCorners ℝ G H)
+    [TopologicalSpace X] [ChartedSpace H X] (g : X → { x : M // f x = b }) (S : Set X) (x : X) :
+    letI := chartedSpace hf hreg
+    ContMDiffWithinAt I 𝓘(ℝ, Model E) ∞ g S x ↔
+      ContMDiffWithinAt I 𝓘(ℝ, E) ∞ (Subtype.val ∘ g) S x := by
+  let _ := chartedSpace hf hreg
+  constructor
+  · intro hg
+    exact (Smale.RegularLevel.contMDiff_inclusion hf hreg).contMDiffAt.comp_contMDiffWithinAt x hg
+  · intro hg
+    apply contMDiffWithinAt_iff_target.mpr
+    refine ⟨Topology.IsInducing.subtypeVal.continuousWithinAt_iff.mpr hg.continuousWithinAt, ?_⟩
+    let Φ := heightChart hf hreg (g x)
+    have hΦ : ContMDiffAt 𝓘(ℝ, E) 𝓘(ℝ, ℝ × Model E) ∞ Φ (g x) :=
+      Φ.contMDiffOn_toFun.contMDiffAt
+        (Φ.open_source.mem_nhds (heightChart_mem_source hf hreg (g x)))
+    have hcomp := hΦ.comp_contMDiffWithinAt x hg
+    change ContMDiffWithinAt I 𝓘(ℝ, Model E) ∞ (fun y => (Φ (g y)).2) S x
+    exact contDiff_snd.contMDiff.contMDiffAt.comp_contMDiffWithinAt x hcomp
+
+private theorem Smale.RegularLevel.contMDiffOn_iff_inclusion {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} {b : ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hreg : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f) {G H X : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H] (I : ModelWithCorners ℝ G H)
+    [TopologicalSpace X] [ChartedSpace H X] (g : X → { x : M // f x = b }) (S : Set X) :
+    letI := chartedSpace hf hreg
+    ContMDiffOn I 𝓘(ℝ, Model E) ∞ g S ↔ ContMDiffOn I 𝓘(ℝ, E) ∞ (Subtype.val ∘ g) S := by
+  let _ := chartedSpace hf hreg
+  exact
+    forall_congr'
+      (fun x => forall_congr' (fun _ => contMDiffWithinAt_iff_inclusion hf hreg I g S x))
+
+attribute [local instance 100] Classical.propDecidable in
+private def MorseCancel.nativeBeltLevelArc {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) (s : ℝ) :
+    (S.data q).UpperLevel :=
+  if hs : |s| ≤ 1 then ⟨nativeBeltArc S q u v s, nativeBeltArc_height S q u v hs⟩
+  else (S.data q).surgery.beltSphere v
+
+private theorem
+    MorseCancel.nativeBeltLevelArc_coe {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) {s : ℝ} (hs : |s| ≤ 1) :
+    (nativeBeltLevelArc S q u v s).val = nativeBeltArc S q u v s := by
+  simp only [nativeBeltLevelArc, dite_eq_left hs]
+
+private theorem MorseCancel.nativeBeltLevelArc_coe_germ {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    {f : M → ℝ} (S : AdaptedWindows E f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) {s : ℝ}
+    (hs : s ∈ Set.Ioo (-1 : ℝ) 1) :
+    (Subtype.val ∘ nativeBeltLevelArc S q u v) =ᶠ[𝓝 s] nativeBeltArc S q u v := by
+  filter_upwards [Ioo_mem_nhds hs.1 hs.2] with t ht
+  exact nativeBeltLevelArc_coe S q u v (abs_le.mpr ⟨ht.1.le, ht.2.le⟩)
+
+private theorem MorseCancel.nativeBeltLevelArc_contMDiffOn {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    {f : M → ℝ} [FiniteDimensional ℝ E] (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) :
+    let _ := Smale.RegularLevel.chartedSpace hf (S.data q).upper_regular
+    ContMDiffOn 𝓘(ℝ, ℝ) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ (nativeBeltLevelArc S q u v)
+      (Set.Ioo (-1 : ℝ) 1) := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data q).upper_regular
+  apply
+    (Smale.RegularLevel.contMDiffOn_iff_inclusion hf (S.data q).upper_regular 𝓘(ℝ, ℝ)
+        (nativeBeltLevelArc S q u v) (Set.Ioo (-1 : ℝ) 1)).mpr
+  apply (nativeBeltArc_contMDiffOn S q u v).congr
+  intro s hs
+  exact nativeBeltLevelArc_coe S q u v (abs_le.mpr ⟨hs.1.le, hs.2.le⟩)
+
+private theorem
+    MorseCancel.nativeBeltLevelArc_derivative_injective {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    {f : M → ℝ} [FiniteDimensional ℝ E] (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) {s : ℝ}
+    (hs : s ∈ Set.Ioo (-1 : ℝ) 1) :
+    let _ := Smale.RegularLevel.chartedSpace hf (S.data q).upper_regular
+    Function.Injective
+      (mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, Smale.RegularLevel.Model E) (nativeBeltLevelArc S q u v) s) := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data q).upper_regular
+  have hg := nativeBeltLevelArc_coe_germ S q u v hs
+  apply
+    Smale.RegularLevel.injective_mfderiv_of_inclusion hf (S.data q).upper_regular 𝓘(ℝ, ℝ)
+      (nativeBeltLevelArc S q u v) s
+  · exact
+      ((nativeBeltArc_contMDiffOn S q u v).contMDiffAt
+            (Ioo_mem_nhds hs.1 hs.2)).congr_of_eventuallyEq
+        hg
+  · rw [hg.mfderiv_eq]
+    exact nativeBeltArc_derivative_injective S q u v (abs_le.mpr ⟨hs.1.le, hs.2.le⟩)
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.nativeBeltLevelArc_normal {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (q : Smale.ManifoldMorse.criticalPoints E f)
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) {s : ℝ} (hs : |s| ≤ 1) :
+    (S.data q).beltNormal (nativeBeltLevelArc S q u v s) = ((S.data q).radius * s) • u.val := by
+  change ((S.data q).chart.splitChart (nativeBeltLevelArc S q u v s).val).1 = _
+  rw [nativeBeltLevelArc_coe S q u v hs]
+  exact
+    congrArg Prod.fst
+      ((S.data q).chart.splitChart.right_inv' (nativeBeltArc_coordinates_mem_target S q u v hs))
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.nativeBeltLevelArc_transverse {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (hq : nativeMorseIndex E f q = 1) (n : ℕ)
+    [Fact (Module.finrank ℝ (S.data q).chart.PositiveCoordinates = n + 1)]
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) :
+    let _ := Smale.RegularLevel.chartedSpace hf (S.data q).upper_regular
+    Function.Surjective
+      ((mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, Smale.RegularLevel.Model E) (nativeBeltLevelArc S q u v) 0 :
+            ℝ →L[ℝ] Smale.RegularLevel.Model E).coprod
+        (mfderiv (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) (S.data q).surgery.beltSphere v)) := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data q).upper_regular
+  let d := S.data q
+  let γ := nativeBeltLevelArc S q u v
+  let L : ℝ →L[ℝ] d.chart.NegativeCoordinates :=
+    ContinuousLinearMap.toSpanSingleton ℝ (d.radius • u.val)
+  have hpoint : γ 0 = d.surgery.beltSphere v :=
+    Subtype.ext
+      ((nativeBeltLevelArc_coe S q u v (s := 0) (by simp)).trans (nativeBeltArc_zero S q u v))
+  have hgerm : d.beltNormal ∘ γ =ᶠ[𝓝 (0 : ℝ)] L := by
+    filter_upwards [Ioo_mem_nhds (show (-1 : ℝ) < 0 by norm_num)
+        (show (0 : ℝ) < 1 by norm_num)] with
+      s hs
+    change d.beltNormal (nativeBeltLevelArc S q u v s) = s • (d.radius • u.val)
+    rw [nativeBeltLevelArc_normal S q u v (abs_le.mpr ⟨hs.1.le, hs.2.le⟩), smul_smul,
+      mul_comm s d.radius]
+  have hnormalDerivative :
+    mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, d.chart.NegativeCoordinates) (d.beltNormal ∘ γ) 0 = L := by
+    rw [hgerm.mfderiv_eq, mfderiv_eq_fderiv, L.fderiv]
+  have hγ :=
+    (nativeBeltLevelArc_contMDiffOn S hf q u v).contMDiffAt
+      (Ioo_mem_nhds (show (-1 : ℝ) < 0 by norm_num) (show (0 : ℝ) < 1 by norm_num))
+  have hnormal :=
+    (d.contMDiffOn_beltNormal hf).contMDiffAt
+      (d.isOpen_beltNormalDomain.mem_nhds (d.belt_mem_normalDomain v))
+  let A : ℝ →L[ℝ] Smale.RegularLevel.Model E :=
+    mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, Smale.RegularLevel.Model E) γ 0
+  let B : EuclideanSpace ℝ (Fin n) →L[ℝ] Smale.RegularLevel.Model E :=
+    mfderiv (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) d.surgery.beltSphere v
+  let Q : Smale.RegularLevel.Model E →L[ℝ] d.chart.NegativeCoordinates :=
+    mfderiv 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, d.chart.NegativeCoordinates) d.beltNormal
+      (d.surgery.beltSphere v)
+  have hnγ :
+    MDifferentiableAt 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, d.chart.NegativeCoordinates)
+      d.beltNormal (γ 0) := by
+    rw [hpoint]
+    exact hnormal.mdifferentiableAt (by simp)
+  have hQA : Q.comp A = L := by
+    have hh := mfderiv_comp 0 hnγ (hγ.mdifferentiableAt (by simp))
+    rw [hpoint] at hh
+    exact hh.symm.trans hnormalDerivative
+  have hu : u.val ≠ 0 := by
+    intro h
+    have hn := mem_sphere_zero_iff_norm.mp u.property
+    rw [h, norm_zero] at hn
+    exact zero_ne_one hn
+  have hLi : Function.Injective L := smul_left_injective ℝ (smul_ne_zero d.radius_pos.ne' hu)
+  have hdim : Module.finrank ℝ ℝ = Module.finrank ℝ d.chart.NegativeCoordinates := by
+    rw [Module.finrank_self]
+    exact ((nativeMorseIndex_eq_chart d.chart).symm.trans hq).symm
+  have hLs : Function.Surjective L :=
+    (LinearMap.injective_iff_surjective_of_finrank_eq_finrank (f := L.toLinearMap) hdim).mp hLi
+  have hQAs : Function.Surjective (Q.comp A) := hQA.symm ▸ hLs
+  have hker : B.range = Q.ker := d.range_belt_derivative_eq_normal_kernel hf n v
+  change Function.Surjective (A.coprod B)
+  intro z
+  obtain ⟨s, hs⟩ := hQAs (Q z)
+  have hmem : z - A s ∈ Q.ker := by
+    change Q (z - A s) = 0
+    change Q (A s) = Q z at hs
+    rw [map_sub, hs, sub_self]
+  rw [← hker] at hmem
+  obtain ⟨w, hw⟩ := hmem
+  change B w = z - A s at hw
+  refine ⟨(s, w), ?_⟩
+  change A s + B w = z
+  rw [hw]
+  abel
+
+private theorem MorseCancel.transverse_circle_of_arc_germ {D G H N : Type*} [NormedAddCommGroup D]
+    [NormedSpace ℝ D] [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H]
+    {J : ModelWithCorners ℝ G H} [TopologicalSpace N] [ChartedSpace H N] {α : ℝ → N}
+    {γ : Circle → N} {ψ : ℝ → Circle} (hγ : ContMDiff (𝓡 1) J ∞ γ)
+    (hψ : ContMDiff 𝓘(ℝ, ℝ) (𝓡 1) ∞ ψ) (hgerm : γ ∘ ψ =ᶠ[𝓝 (0 : ℝ)] α) (B : D →L[ℝ] G)
+    (htrans : Function.Surjective ((mfderiv 𝓘(ℝ, ℝ) J α 0 : ℝ →L[ℝ] G).coprod B)) :
+    Function.Surjective ((mfderiv (𝓡 1) J γ (ψ 0) : EuclideanSpace ℝ (Fin 1) →L[ℝ] G).coprod B) :=
+  by
+  let A : EuclideanSpace ℝ (Fin 1) →L[ℝ] G := mfderiv (𝓡 1) J γ (ψ 0)
+  let P : ℝ →L[ℝ] EuclideanSpace ℝ (Fin 1) := mfderiv 𝓘(ℝ, ℝ) (𝓡 1) ψ 0
+  let A₀ : ℝ →L[ℝ] G := mfderiv 𝓘(ℝ, ℝ) J α 0
+  have hc := mfderiv_comp 0 (hγ.mdifferentiableAt (by simp)) (hψ.mdifferentiableAt (by simp))
+  have heq : A.comp P = A₀ := hc.symm.trans hgerm.mfderiv_eq
+  intro y
+  obtain ⟨⟨a, b⟩, hab⟩ := htrans y
+  refine ⟨(P a, b), ?_⟩
+  have ha := congrArg (fun L : ℝ →L[ℝ] G => L a) heq
+  change A (P a) + B b = y
+  change A (P a) = A₀ a at ha
+  rw [ha]
+  exact hab
+
+private theorem MorseCancel.surjective_coprod_comp_left {A A' B G : Type*} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] [NormedAddCommGroup A'] [NormedSpace ℝ A'] [NormedAddCommGroup B]
+    [NormedSpace ℝ B] [NormedAddCommGroup G] [NormedSpace ℝ G] (L : A →L[ℝ] G) (R : B →L[ℝ] G)
+    (P : A' →L[ℝ] A) (hP : Function.Surjective P) (htrans : Function.Surjective (L.coprod R)) :
+    Function.Surjective ((L.comp P).coprod R) := by
+  intro y
+  obtain ⟨⟨a, b⟩, hab⟩ := htrans y
+  obtain ⟨a', ha⟩ := hP a
+  refine ⟨(a', b), ?_⟩
+  change L (P a') + R b = y
+  rw [ha]
+  exact hab
+
+private def MorseCancel.euclideanTail (n : ℕ) :
+    Smale.Hemisphere.Ambient (n + 1) →L[ℝ] Smale.Hemisphere.Ambient n :=
+  ({    toFun := fun x => WithLp.toLp 2 (fun i : Fin n => x i.succ)
+        map_add' := by intro x y; ext i; rfl
+        map_smul' := by intro a x; ext i; rfl } :
+      Smale.Hemisphere.Ambient (n + 1) →ₗ[ℝ] Smale.Hemisphere.Ambient n).toContinuousLinearMap
+
+private theorem
+    MorseCancel.euclideanTail_hemisphere {n : ℕ} (b : Bool) (x : Smale.Hemisphere.Ball n) :
+    euclideanTail n (Smale.Hemisphere.point b x).val = x.val := by
+  ext i
+  rfl
+
+private theorem MorseCancel.exists_belt_point_avoiding_smooth_image {E M D H Y : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [NormedAddCommGroup D] [NormedSpace ℝ D]
+    [FiniteDimensional ℝ D] [TopologicalSpace H] {I : ModelWithCorners ℝ D H} [TopologicalSpace Y]
+    [ChartedSpace H Y] [IsManifold I ∞ Y] [LindelofSpace Y] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (n : ℕ)
+    [Fact (Module.finrank ℝ d.chart.PositiveCoordinates = n + 1)] (g : Y → M)
+    (hg : ContMDiff I 𝓘(ℝ, E) ∞ g) (hdim : Module.finrank ℝ D < n) :
+    ∃ v : Metric.sphere (0 : d.chart.PositiveCoordinates) 1,
+      (d.surgery.beltSphere v).val ∉ Set.range g := by
+  let b :=
+    (stdOrthonormalBasis ℝ d.chart.PositiveCoordinates).reindex
+      (finCongr (Fact.out : Module.finrank ℝ d.chart.PositiveCoordinates = n + 1))
+  let L : d.chart.PositiveCoordinates ≃ₗᵢ[ℝ] Smale.Hemisphere.Ambient (n + 1) := b.repr
+  let P : M → Smale.Hemisphere.Ambient n := fun x =>
+    euclideanTail n (d.radius⁻¹ • L (d.chart.splitChart x).2)
+  let U : Set Y := g ⁻¹' d.chart.splitChart.source
+  have hU : IsOpen U := d.chart.splitChart.open_source.preimage hg.continuous
+  have hPg : ContMDiffOn I 𝓘(ℝ, Smale.Hemisphere.Ambient n) ∞ (P ∘ g) U := by
+    have hc :
+      ContMDiffOn I 𝓘(ℝ, d.chart.NegativeCoordinates × d.chart.PositiveCoordinates) ∞
+        (d.chart.splitChart ∘ g) U :=
+      d.chart.splitChart.contMDiffOn_toFun.comp hg.contMDiffOn (fun _ hy => hy)
+    let A :
+      d.chart.NegativeCoordinates × d.chart.PositiveCoordinates →L[ℝ]
+        Smale.Hemisphere.Ambient n :=
+      (euclideanTail n).comp
+        ((d.radius⁻¹ • L.toContinuousLinearEquiv.toContinuousLinearMap).comp
+          (ContinuousLinearMap.snd ℝ d.chart.NegativeCoordinates d.chart.PositiveCoordinates))
+    have hQ :
+      ContDiff ℝ ∞
+        (fun z : d.chart.NegativeCoordinates × d.chart.PositiveCoordinates =>
+          euclideanTail n (d.radius⁻¹ • L z.2)) :=
+      A.contDiff
+    exact hQ.contMDiff.comp_contMDiffOn hc
+  have hdense :=
+    Smale.GeneralPosition.dense_compl_manifold_image hU hPg
+      (show Module.finrank ℝ D < Module.finrank ℝ (Smale.Hemisphere.Ambient n) by
+        simpa only [Smale.Hemisphere.Ambient, finrank_euclideanSpace_fin] using hdim)
+  obtain ⟨x, hxavoid, hxnorm⟩ := hdense.exists_dist_lt 0 (show (0 : ℝ) < 1 by norm_num)
+  have hx : ‖x‖ < 1 := by simpa only [dist_zero_left] using hxnorm
+  let xB : Smale.Hemisphere.Ball n := ⟨x, mem_closedBall_zero_iff.mpr hx.le⟩
+  let w := Smale.Hemisphere.point Bool.true xB
+  let v : Metric.sphere (0 : d.chart.PositiveCoordinates) 1 :=
+    ⟨L.symm w.val, by
+      rw [mem_sphere_zero_iff_norm, L.symm.norm_map]
+      exact mem_sphere_zero_iff_norm.mp w.property⟩
+  have hcoord : d.chart.splitChart (d.surgery.beltSphere v).val = (0, d.radius • v.val) := by
+    rw [d.belt_eq, d.chart.beltCoreMap_coe]
+    exact d.chart.splitChart.right_inv' (d.belt_model_mem_target v)
+  have hproject : P (d.surgery.beltSphere v).val = x := by
+    change
+      euclideanTail n (d.radius⁻¹ • L (d.chart.splitChart (d.surgery.beltSphere v).val).2) = x
+    rw [hcoord]
+    change euclideanTail n (d.radius⁻¹ • L (d.radius • (L.symm w.val))) = x
+    rw [L.map_smul, L.apply_symm_apply, smul_smul, inv_mul_cancel₀ d.radius_pos.ne', one_smul]
+    exact euclideanTail_hemisphere Bool.true xB
+  refine ⟨v, ?_⟩
+  rintro ⟨y, hy⟩
+  apply hxavoid
+  refine ⟨y, ?_, ?_⟩
+  · change g y ∈ d.chart.splitChart.source
+    rw [hy]
+    exact d.belt_mem_normalDomain v
+  · change P (g y) = x
+    rw [hy]
+    exact hproject
+
+private theorem AdaptedWindows.exists_belt_point_reaching_level {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (q : Smale.ManifoldMorse.criticalPoints E f) (n : ℕ)
+    [Fact (Module.finrank ℝ (S.data q).chart.PositiveCoordinates = n + 1)] {a : ℝ} (hqa : f q < a)
+    {d : ℕ}
+    (hlow :
+      ∀ p : Smale.ManifoldMorse.criticalPoints E f,
+        f p ≤ a → MorseCancel.nativeMorseIndex E f p ≤ d)
+    (hdim : d < n) :
+    ∃ v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1,
+      ((S.data q).surgery.beltSphere v).val ∈ Degree.FlowCancellation.levelBasin S.flow f a := by
+  let _ := S.finite.fintype
+  let K := MorseCancel.LowBackwardBasinIndex (E := E) (f := f) a
+  let Z := EuclideanSpace ℝ (Fin 0)
+  let V := EuclideanSpace ℝ (Fin d)
+  let _ : Countable K := MorseCancel.lowBackwardBasinIndex_countable S a
+  let _ : DiscreteTopology K := inferInstance
+  let _ : ChartedSpace Z K := ChartedSpace.ofDiscreteTopology
+  let _ : IsManifold 𝓘(ℝ, Z) ∞ K := IsManifold.of_discreteTopology ∞
+  obtain ⟨g, hg, hcover⟩ := S.exists_low_backward_obstruction_images hf a hlow
+  let G : K × V → M := fun z => g z.1 z.2
+  have hG : ContMDiff (𝓘(ℝ, Z).prod 𝓘(ℝ, V)) 𝓘(ℝ, E) ∞ G :=
+    MorseCancel.contMDiff_discrete_family g hg
+  have hrange : Set.range G = MorseCancel.backwardLowBasins S a := by
+    rw [hcover]
+    exact MorseCancel.range_discrete_family g
+  obtain ⟨v, hv⟩ :=
+    MorseCancel.exists_belt_point_avoiding_smooth_image (S.data q) n G hG
+      (show Module.finrank ℝ (Z × V) < n by
+        simpa only [Z, V, Module.finrank_prod, finrank_euclideanSpace_fin, zero_add] using hdim)
+  have hforward := (S.belt_basin_iff hf q ((S.data q).surgery.beltSphere v)).mpr ⟨v, rfl⟩
+  obtain ⟨p, hp, _, _, hback, _, _⟩ :=
+    Degree.FlowCancellation.exists_native_descent_endpoints hf S.smooth S.flow S.integral S.zero
+      S.descent S.distinct ((S.data q).surgery.beltSphere v).val
+  have hap : a < f p :=
+    lt_of_not_ge
+      (fun h =>
+        hv
+          (hrange.symm ▸
+            (show ((S.data q).surgery.beltSphere v).val ∈ MorseCancel.backwardLowBasins S a from
+              ⟨⟨p, hp⟩, h, hback⟩)))
+  exact
+    ⟨v,
+      Degree.FlowCancellation.exists_level_crossing_of_endpoint_limits S.flow hf.continuous hback
+        hforward hap hqa⟩
+
+private theorem AdaptedWindows.joinedIn_level_minimum_basin_reaching_level {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (p : Smale.ManifoldMorse.criticalPoints E f) (hp : MorseCancel.nativeMorseIndex E f p = 0)
+    {a b : ℝ} (hpb : f p < b) (hba : b ≤ a)
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hb : ∀ y, f y = b → y ∉ Smale.ManifoldMorse.criticalPoints E f) {d : ℕ}
+    (hlow :
+      ∀ q : Smale.ManifoldMorse.criticalPoints E f,
+        f q ≤ a → MorseCancel.nativeMorseIndex E f q ≤ d)
+    (hdim : 1 + d < Module.finrank ℝ E) {x y : M} (hxb : f x = b) (hyb : f y = b)
+    (hx : Filter.Tendsto (fun t => S.flow t x) Filter.atTop (𝓝 p.val))
+    (hy : Filter.Tendsto (fun t => S.flow t y) Filter.atTop (𝓝 p.val))
+    (hxa : x ∈ Degree.FlowCancellation.levelBasin S.flow f a)
+    (hya : y ∈ Degree.FlowCancellation.levelBasin S.flow f a) :
+    JoinedIn
+      {z : M |
+        f z = b ∧
+          Filter.Tendsto (fun t => S.flow t z) Filter.atTop (𝓝 p.val) ∧
+            z ∈ Degree.FlowCancellation.levelBasin S.flow f a}
+      x y := by
+  let _ := S.finite.fintype
+  let K := MorseCancel.LowBackwardBasinIndex (E := E) (f := f) a
+  let Z := EuclideanSpace ℝ (Fin 0)
+  let V := EuclideanSpace ℝ (Fin d)
+  let _ : Countable K := MorseCancel.lowBackwardBasinIndex_countable S a
+  let _ : DiscreteTopology K := inferInstance
+  let _ : ChartedSpace Z K := ChartedSpace.ofDiscreteTopology
+  let _ : IsManifold 𝓘(ℝ, Z) ∞ K := IsManifold.of_discreteTopology ∞
+  obtain ⟨g, hg, hcover⟩ := S.exists_low_backward_obstruction_images hf a hlow
+  have hG : ContMDiff (𝓘(ℝ, Z).prod 𝓘(ℝ, V)) 𝓘(ℝ, E) ∞ (fun z : K × V => g z.1 z.2) :=
+    MorseCancel.contMDiff_discrete_family g hg
+  let G : C(K × V, M) := ⟨fun z => g z.1 z.2, hG.continuous⟩
+  have hrange : Set.range G = MorseCancel.backwardLowBasins S a := by
+    rw [hcover]
+    exact MorseCancel.range_discrete_family g
+  have hclosed : IsClosed (Set.range G) := by
+    rw [hrange]
+    exact MorseCancel.isClosed_backwardLowBasins S hf a
+  have hdim' : 1 + Module.finrank ℝ (Z × V) < Module.finrank ℝ E := by
+    simpa only [Z, V, Module.finrank_prod, finrank_euclideanSpace_fin, zero_add] using hdim
+  have hnot (z : M) (hz : z ∈ Degree.FlowCancellation.levelBasin S.flow f a) : z ∉ Set.range G := by
+    rw [hrange]
+    intro hlowz
+    have hc : z ∈ (Degree.FlowCancellation.levelBasin S.flow f a)ᶜ := by
+      rw [MorseCancel.levelBasin_compl_eq_endpoint_obstruction S hf ha]
+      exact Or.inr hlowz
+    exact hc hz
+  let U : TopologicalSpace.Opens M :=
+    ⟨{z | Filter.Tendsto (fun t => S.flow t z) Filter.atTop (𝓝 p.val)},
+      S.isOpen_minimum_forward_basin hf p hp⟩
+  let xU : U := ⟨x, hx⟩
+  let yU : U := ⟨y, hy⟩
+  have hjoined : Joined xU yU := (S.joinedIn_minimum_basin hf p hp hx hy).joined_subtype
+  obtain ⟨η, -, havoid⟩ :=
+    MorseCancel.exists_smooth_path_avoiding_closed_image_in_open U hjoined.somePath G hG hclosed
+      hdim' (hnot x hxa) (hnot y hya)
+  have hcross (c : ℝ) (hbc : b ≤ c) (hca : c ≤ a) (u : unitInterval) :
+    (η u).val ∈ Degree.FlowCancellation.levelBasin S.flow f c := by
+    obtain ⟨q, hq, _, _, hback, _, _⟩ :=
+      Degree.FlowCancellation.exists_native_descent_endpoints hf S.smooth S.flow S.integral S.zero
+        S.descent S.distinct (η u).val
+    have hqa : a < f q :=
+      lt_of_not_ge
+        (fun h =>
+          havoid u
+            (hrange.symm ▸
+              (show (η u).val ∈ MorseCancel.backwardLowBasins S a from ⟨⟨q, hq⟩, h, hback⟩)))
+    exact
+      Degree.FlowCancellation.exists_level_crossing_of_endpoint_limits S.flow hf.continuous hback
+        (η u).property (hca.trans_lt hqa) (hpb.trans_le hbc)
+  let _ := Smale.RegularLevel.chartedSpace hf hb
+  let xL : { z : M // f z = b } := ⟨x, hxb⟩
+  let yL : { z : M // f z = b } := ⟨y, hyb⟩
+  obtain ⟨Φ, hsource, htarget, hformula, -⟩ :=
+    Degree.FlowCancellation.exists_native_level_flow_cylinder hf hb S.smooth S.flow S.integral
+      (fun z hz => S.descent z (hb z hz)) xL
+  have hcont : Continuous (fun u : unitInterval => Φ.symm (η u).val) :=
+    Φ.contMDiffOn_invFun.continuousOn.comp_continuous (continuous_subtype_val.comp η.continuous)
+      (fun u => htarget.symm ▸ hcross b le_rfl hba u)
+  have hlevelInverse (z : { w : M // f w = b }) : Φ.symm z.val = (z, 0) := by
+    have hs : (z, (0 : ℝ)) ∈ Φ.source := by rw [hsource]; trivial
+    have he : Φ (z, 0) = z.val := by rw [hformula, S.flow.map_zero_apply]
+    have hi : Φ.symm (Φ (z, 0)) = (z, 0) := Φ.left_inv' hs
+    rwa [he] at hi
+  let γ : Path x y :=
+    { toFun := fun u => (Φ.symm (η u).val).1.val
+      continuous_toFun := continuous_subtype_val.comp (continuous_fst.comp hcont)
+      source' := by
+        rw [η.source]
+        exact congrArg (fun z : { w : M // f w = b } × ℝ => z.1.val) (hlevelInverse xL)
+      target' := by
+        rw [η.target]
+        exact congrArg (fun z : { w : M // f w = b } × ℝ => z.1.val) (hlevelInverse yL) }
+  refine ⟨γ, fun u => ⟨(Φ.symm (η u).val).1.property, ?_, ?_⟩⟩
+  · let z := Φ.symm (η u).val
+    have hi : Φ z = (η u).val := Φ.right_inv' (htarget.symm ▸ hcross b le_rfl hba u)
+    have hflow : S.flow z.2 z.1.val = (η u).val := (hformula z).symm.trans hi
+    have hlim : Filter.Tendsto (fun t => S.flow t (S.flow z.2 z.1.val)) Filter.atTop (𝓝 p.val) :=
+      hflow.symm ▸ (η u).property
+    exact (MorseCancel.flow_time_atTop_limit_iff S.flow z.2 z.1.val p.val).mp hlim
+  · let z := Φ.symm (η u).val
+    have hi : Φ z = (η u).val := Φ.right_inv' (htarget.symm ▸ hcross b le_rfl hba u)
+    have hflow : S.flow z.2 z.1.val = (η u).val := (hformula z).symm.trans hi
+    exact
+      (Degree.FlowCancellation.levelBasin_flow_iff S.flow f a z.2 z.1.val).mp
+        (hflow.symm ▸ hcross a hba le_rfl u)
+
+private theorem AdaptedWindows.exists_belt_arc_closing_path_reaching_level {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (p q : Smale.ManifoldMorse.criticalPoints E f) (hp : MorseCancel.nativeMorseIndex E f p = 0)
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1)
+    (hbranches :
+      ∀ w : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1,
+        Filter.Tendsto (fun t => S.flow t ((S.data q).surgery.attachingSphere w).val) Filter.atTop
+          (𝓝 p.val))
+    {a : ℝ} (hba : S.toSurgeryWindows.upper q ≤ a)
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hv : ((S.data q).surgery.beltSphere v).val ∈ Degree.FlowCancellation.levelBasin S.flow f a)
+    {d : ℕ}
+    (hlow :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E f,
+        f z ≤ a → MorseCancel.nativeMorseIndex E f z ≤ d)
+    (hdim : 1 + d < Module.finrank ℝ E) :
+    ∃ r : ℝ,
+      0 < r ∧
+        r < 1 ∧
+          (∀ s : ℝ,
+              |s| ≤ r →
+                MorseCancel.nativeBeltArc S q u v s ∈
+                  Degree.FlowCancellation.levelBasin S.flow f a) ∧
+            (∀ s : ℝ,
+                0 < |s| →
+                  |s| ≤ r →
+                    Filter.Tendsto (fun t => S.flow t (MorseCancel.nativeBeltArc S q u v s))
+                      Filter.atTop (𝓝 p.val)) ∧
+              JoinedIn
+                {z : M |
+                  f z = S.toSurgeryWindows.upper q ∧
+                    Filter.Tendsto (fun t => S.flow t z) Filter.atTop (𝓝 p.val) ∧
+                      z ∈ Degree.FlowCancellation.levelBasin S.flow f a}
+                (MorseCancel.nativeBeltArc S q u v r) (MorseCancel.nativeBeltArc S q u v (-r)) := by
+  obtain ⟨ε, hε, hε1, hmin⟩ :=
+    S.exists_two_sided_belt_branch_in_minimum_basin hf p q hp u v hbranches
+  have hB : IsOpen (Degree.FlowCancellation.levelBasin S.flow f a) :=
+    (Degree.FlowCancellation.smooth_signed_level_time hf S.smooth S.flow S.integral
+        (fun z hz => S.descent z (ha z hz))).1
+  have hα0 :
+    MorseCancel.nativeBeltArc S q u v 0 ∈ Degree.FlowCancellation.levelBasin S.flow f a := by
+    rw [MorseCancel.nativeBeltArc_zero]
+    exact hv
+  have hc : ContinuousAt (MorseCancel.nativeBeltArc S q u v) 0 :=
+    ((MorseCancel.nativeBeltArc_contMDiffOn S q u v).contMDiffAt
+        (Ioo_mem_nhds (show (-1 : ℝ) < 0 by norm_num)
+          (show (0 : ℝ) < 1 by norm_num))).continuousAt
+  have hnear :
+    ∀ᶠ s in 𝓝 (0 : ℝ),
+      MorseCancel.nativeBeltArc S q u v s ∈ Degree.FlowCancellation.levelBasin S.flow f a :=
+    hc.preimage_mem_nhds (hB.mem_nhds hα0)
+  obtain ⟨δ, hδ, hball⟩ := Metric.nhds_basis_ball.mem_iff.mp hnear
+  let r := Min.min (ε / 2) (δ / 2)
+  have hr : 0 < r := lt_min (half_pos hε) (half_pos hδ)
+  have hrε : r < ε := (min_le_left _ _).trans_lt (half_lt_self hε)
+  have hrδ : r < δ := (min_le_right _ _).trans_lt (half_lt_self hδ)
+  have hr1 : r < 1 := hrε.trans_le hε1
+  have hreach (s : ℝ) (hs : |s| ≤ r) :
+    MorseCancel.nativeBeltArc S q u v s ∈ Degree.FlowCancellation.levelBasin S.flow f a := by
+    apply hball
+    rw [Metric.mem_ball, Real.dist_eq, sub_zero]
+    exact hs.trans_lt hrδ
+  have hall (s : ℝ) (hs : 0 < |s|) (hsr : |s| ≤ r) :
+    Filter.Tendsto (fun t => S.flow t (MorseCancel.nativeBeltArc S q u v s)) Filter.atTop
+      (𝓝 p.val) :=
+    hmin s hs (hsr.trans_lt hrε)
+  have hpb : f p < S.toSurgeryWindows.upper q :=
+    (S.forward_limit_below_regular_level hf (S.data q).lower_regular
+          ((S.data q).surgery.attachingSphere u) (hbranches u)).trans
+      ((S.toSurgeryWindows.lower_lt_value q).trans (S.toSurgeryWindows.value_lt_upper q))
+  have hpr : |r| = r := abs_of_pos hr
+  have hmr : |-r| = r := by rw [abs_neg, hpr]
+  refine ⟨r, hr, hr1, hreach, hall, ?_⟩
+  exact
+    S.joinedIn_level_minimum_basin_reaching_level hf p hp hpb hba ha (S.data q).upper_regular hlow
+      hdim (MorseCancel.nativeBeltArc_height S q u v (by rw [hpr]; exact hr1.le))
+      (MorseCancel.nativeBeltArc_height S q u v (by rw [hmr]; exact hr1.le))
+      (hall r (hpr.symm ▸ hr) hpr.le) (hall (-r) (hmr.symm ▸ hr) hmr.le) (hreach r hpr.le)
+      (hreach (-r) hmr.le)
+
+private theorem MorseCancel.single_belt_intersection_of_arc_and_minimum_range {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (p q : Smale.ManifoldMorse.criticalPoints E f) (hpq : p ≠ q)
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) {X : Type*}
+    {γ : X → (S.data q).UpperLevel} (hγi : Function.Injective γ) {z₀ : X}
+    (hzero : γ z₀ = (S.data q).surgery.beltSphere v) {r : ℝ} (hr1 : r ≤ 1)
+    (himage :
+      ∀ z,
+        γ z ∈ nativeBeltLevelArc S q u v '' Set.Icc (-r) r ∨
+          Filter.Tendsto (fun t => S.flow t (γ z).val) Filter.atTop (𝓝 p.val)) :
+    ∀ z w, γ z = (S.data q).surgery.beltSphere w ↔ z = z₀ ∧ v = w := by
+  intro z w
+  constructor
+  · intro hzw
+    rcases himage z with hshort | hmin
+    · obtain ⟨s, hs, hsz⟩ := hshort
+      have hs1 : |s| ≤ 1 := abs_le.mpr ⟨by linarith [hs.1], by linarith [hs.2]⟩
+      have hsw : nativeBeltArc S q u v s = ((S.data q).surgery.beltSphere w).val := by
+        rw [← nativeBeltLevelArc_coe S q u v hs1]
+        exact congrArg Subtype.val (hsz.trans hzw)
+      obtain ⟨-, hvw⟩ := (nativeBeltArc_belt_eq_iff S q u v w hs1).mp hsw
+      refine ⟨hγi ?_, hvw⟩
+      exact hzw.trans ((congrArg (S.data q).surgery.beltSphere hvw).symm.trans hzero.symm)
+    · have hqz := (S.belt_basin_iff hf q ((S.data q).surgery.beltSphere w)).mpr ⟨w, rfl⟩
+      rw [hzw] at hmin
+      exact False.elim (hpq (Subtype.ext (tendsto_nhds_unique hmin hqz)))
+  · rintro ⟨rfl, rfl⟩
+    exact hzero
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem AdaptedWindows.exists_single_belt_circle_in_open_with_image {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (p q : Smale.ManifoldMorse.criticalPoints E f) (hp : MorseCancel.nativeMorseIndex E f p = 0)
+    (hpq : p ≠ q) (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1)
+    (O : TopologicalSpace.Opens M) {r : ℝ} (hr : 0 < r) (hr1 : r < 1)
+    (hshortO : ∀ s ∈ Set.Icc (-r) r, MorseCancel.nativeBeltArc S q u v s ∈ O)
+    (hpath :
+      JoinedIn
+        {z : M |
+          f z = S.toSurgeryWindows.upper q ∧
+            Filter.Tendsto (fun t => S.flow t z) Filter.atTop (𝓝 p.val) ∧ z ∈ O}
+        (MorseCancel.nativeBeltArc S q u v r) (MorseCancel.nativeBeltArc S q u v (-r)))
+    (hdim : 4 ≤ Module.finrank ℝ E) :
+    let _ := Smale.RegularLevel.chartedSpace hf (S.data q).upper_regular
+    ∃ γ : C(Circle, (S.data q).UpperLevel),
+      ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ γ ∧
+        Function.Injective γ ∧
+          (∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) γ z)) ∧
+            (∀ z, (γ z).val ∈ O) ∧
+              (∀ s ∈ Set.Icc (-r) r,
+                  γ (Circle.exp (2 * Real.pi / (2 * r + 1) * (s + r))) =
+                    MorseCancel.nativeBeltLevelArc S q u v s) ∧
+                (∀ z w,
+                    γ z = (S.data q).surgery.beltSphere w ↔
+                      z = Circle.exp (2 * Real.pi / (2 * r + 1) * r) ∧ v = w) ∧
+                  ∀ z,
+                    γ z ∈ MorseCancel.nativeBeltLevelArc S q u v '' Set.Icc (-r) r ∨
+                      Filter.Tendsto (fun t => S.flow t (γ z).val) Filter.atTop (𝓝 p.val) := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data q).upper_regular
+  let _ := Smale.RegularLevel.isManifold hf (S.data q).upper_regular
+  let α := MorseCancel.nativeBeltLevelArc S q u v
+  let U : TopologicalSpace.Opens (S.data q).UpperLevel :=
+    ⟨{z | Filter.Tendsto (fun t => S.flow t z.val) Filter.atTop (𝓝 p.val) ∧ z.val ∈ O},
+      ((S.isOpen_minimum_forward_basin hf p hp).inter O.isOpen).preimage continuous_subtype_val⟩
+  have hpr : |r| ≤ 1 := by rw [abs_of_pos hr]; exact hr1.le
+  have hmr : |-r| ≤ 1 := by rw [abs_neg]; exact hpr
+  have hplus : α r ∈ U := by
+    change Filter.Tendsto (fun t => S.flow t (α r).val) Filter.atTop (𝓝 p.val) ∧ (α r).val ∈ O
+    rw [MorseCancel.nativeBeltLevelArc_coe S q u v hpr]
+    exact hpath.source_mem.2
+  have hminus : α (-r) ∈ U := by
+    change
+      Filter.Tendsto (fun t => S.flow t (α (-r)).val) Filter.atTop (𝓝 p.val) ∧ (α (-r)).val ∈ O
+    rw [MorseCancel.nativeBeltLevelArc_coe S q u v hmr]
+    exact hpath.target_mem.2
+  let η : Path (⟨α r, hplus⟩ : U) (⟨α (-r), hminus⟩ : U) :=
+    { toFun := fun t => ⟨⟨hpath.somePath t, (hpath.somePath_mem t).1⟩, (hpath.somePath_mem t).2⟩
+      continuous_toFun := (hpath.somePath.continuous.subtype_mk _).subtype_mk _
+      source' :=
+        Subtype.ext
+          (Subtype.ext
+            (hpath.somePath.source.trans (MorseCancel.nativeBeltLevelArc_coe S q u v hpr).symm))
+      target' :=
+        Subtype.ext
+          (Subtype.ext
+            (hpath.somePath.target.trans (MorseCancel.nativeBeltLevelArc_coe S q u v hmr).symm)) }
+  have hαi : Set.InjOn α (Set.Icc (-1 : ℝ) 1) := by
+    intro x hx y hy hxy
+    apply MorseCancel.nativeBeltArc_injOn S q u v hx hy
+    have hh := congrArg Subtype.val hxy
+    rw [MorseCancel.nativeBeltLevelArc_coe S q u v (abs_le.mpr hx),
+      MorseCancel.nativeBeltLevelArc_coe S q u v (abs_le.mpr hy)] at hh
+    exact hh
+  have hdimL : 3 ≤ Module.finrank ℝ (Smale.RegularLevel.Model E) := by
+    simp only [Smale.RegularLevel.Model, finrank_euclideanSpace_fin]
+    omega
+  obtain ⟨γ, hγ, hγi, hγd, hshort, himage⟩ :=
+    MorseCancel.exists_embedded_circle_through_arc U hr hr1
+      (MorseCancel.nativeBeltLevelArc_contMDiffOn S hf q u v) hαi
+      (fun _ hs => MorseCancel.nativeBeltLevelArc_derivative_injective S hf q u v hs) hplus hminus
+      η hdimL
+  let z₀ := Circle.exp (2 * Real.pi / (2 * r + 1) * r)
+  have hzero : γ z₀ = (S.data q).surgery.beltSphere v := by
+    have hh := hshort 0 ⟨by linarith, hr.le⟩
+    rw [zero_add] at hh
+    apply Subtype.ext
+    exact
+      (congrArg Subtype.val hh).trans
+        ((MorseCancel.nativeBeltLevelArc_coe S q u v (s := 0) (by simp)).trans
+          (MorseCancel.nativeBeltArc_zero S q u v))
+  have himage' (z : Circle) :
+    γ z ∈ MorseCancel.nativeBeltLevelArc S q u v '' Set.Icc (-r) r ∨
+      Filter.Tendsto (fun t => S.flow t (γ z).val) Filter.atTop (𝓝 p.val) := by
+    rcases himage (Set.mem_range_self z) with hz | hz
+    · exact Or.inl hz
+    · exact Or.inr hz.1
+  refine ⟨γ, hγ, hγi, hγd, ?_, hshort, ?_, himage'⟩
+  · intro z
+    rcases himage (Set.mem_range_self z) with hz | hz
+    · obtain ⟨s, hs, hsz⟩ := hz
+      rw [← hsz,
+        MorseCancel.nativeBeltLevelArc_coe S q u v
+          (abs_le.mpr ⟨by linarith [hs.1], by linarith [hs.2]⟩)]
+      exact hshortO s hs
+    · exact hz.2
+  · apply
+      MorseCancel.single_belt_intersection_of_arc_and_minimum_range S hf p q hpq u v hγi hzero
+        hr1.le
+    exact himage'
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    AdaptedWindows.exists_transverse_belt_circle_reaching_level_with_endpoints {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (p q : Smale.ManifoldMorse.criticalPoints E f) (hp : MorseCancel.nativeMorseIndex E f p = 0)
+    (hq : MorseCancel.nativeMorseIndex E f q = 1) (n : ℕ)
+    [Fact (Module.finrank ℝ (S.data q).chart.PositiveCoordinates = n + 1)]
+    (u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (hbranches :
+      ∀ w : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1,
+        Filter.Tendsto (fun t => S.flow t ((S.data q).surgery.attachingSphere w).val) Filter.atTop
+          (𝓝 p.val))
+    {a : ℝ} (hba : S.toSurgeryWindows.upper q ≤ a)
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f) {d : ℕ}
+    (hlow :
+      ∀ z : Smale.ManifoldMorse.criticalPoints E f,
+        f z ≤ a → MorseCancel.nativeMorseIndex E f z ≤ d)
+    (hdn : d < n) (hcut : 1 + d < Module.finrank ℝ E) (hdim : 4 ≤ Module.finrank ℝ E) :
+    let _ := Smale.RegularLevel.chartedSpace hf (S.data q).upper_regular
+    ∃ v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1,
+      ∃ γ : C(Circle, (S.data q).UpperLevel),
+        ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ γ ∧
+          Function.Injective γ ∧
+            (∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) γ z)) ∧
+              (∀ z, (γ z).val ∈ Degree.FlowCancellation.levelBasin S.flow f a) ∧
+                ∃ z₀ : Circle,
+                  (∀ z w, γ z = (S.data q).surgery.beltSphere w ↔ z = z₀ ∧ v = w) ∧
+                    (Function.Surjective
+                        ((mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) γ z₀ :
+                              EuclideanSpace ℝ (Fin 1) →L[ℝ] Smale.RegularLevel.Model E).coprod
+                          (mfderiv (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E)
+                            (S.data q).surgery.beltSphere v))) ∧
+                      ∀ z,
+                        Filter.Tendsto (fun t => S.flow t (γ z).val) Filter.atTop (𝓝 p.val) ∨
+                          Filter.Tendsto (fun t => S.flow t (γ z).val) Filter.atTop (𝓝 q.val) := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data q).upper_regular
+  let _ := Smale.RegularLevel.isManifold hf (S.data q).upper_regular
+  have hqa : f q < a := (S.toSurgeryWindows.value_lt_upper q).trans_le hba
+  obtain ⟨v, hv⟩ := S.exists_belt_point_reaching_level hf q n hqa hlow hdn
+  obtain ⟨r, hr, hr1, hreach, hmin, hpath⟩ :=
+    S.exists_belt_arc_closing_path_reaching_level hf p q hp u v hbranches hba ha hv hlow hcut
+  let O : TopologicalSpace.Opens M :=
+    ⟨Degree.FlowCancellation.levelBasin S.flow f a,
+      (Degree.FlowCancellation.smooth_signed_level_time hf S.smooth S.flow S.integral
+          (fun z hz => S.descent z (ha z hz))).1⟩
+  have hpq : p ≠ q := by
+    intro heq
+    have hh := hp
+    rw [heq, hq] at hh
+    exact Nat.one_ne_zero hh
+  obtain ⟨γ, hγ, hγi, hγd, hγreach, hshort, hsingle, himage⟩ :=
+    S.exists_single_belt_circle_in_open_with_image hf p q hp hpq u v O hr hr1
+      (fun s hs => hreach s (abs_le.mpr hs)) hpath hdim
+  let ψ : ℝ → Circle := fun t => Circle.exp (2 * Real.pi / (2 * r + 1) * (t + r))
+  have hψ : ContMDiff 𝓘(ℝ, ℝ) (𝓡 1) ∞ ψ :=
+    contMDiff_circleExp.comp (contDiff_const.mul (contDiff_id.add contDiff_const)).contMDiff
+  have heq : γ ∘ ψ =ᶠ[𝓝 (0 : ℝ)] MorseCancel.nativeBeltLevelArc S q u v := by
+    filter_upwards [Ioo_mem_nhds (neg_lt_zero.mpr hr) hr] with t ht
+    exact hshort t ⟨ht.1.le, ht.2.le⟩
+  have hendpoints (z : Circle) :
+    Filter.Tendsto (fun t => S.flow t (γ z).val) Filter.atTop (𝓝 p.val) ∨
+      Filter.Tendsto (fun t => S.flow t (γ z).val) Filter.atTop (𝓝 q.val) := by
+    rcases himage z with hshortz | hzmin
+    · obtain ⟨s, hs, hsz⟩ := hshortz
+      have hsr : |s| ≤ r := abs_le.mpr hs
+      have hs1 : |s| ≤ 1 := hsr.trans hr1.le
+      by_cases hs0 : s = 0
+      · right
+        have hz : (γ z).val = ((S.data q).surgery.beltSphere v).val := by
+          rw [← hsz, MorseCancel.nativeBeltLevelArc_coe S q u v hs1, hs0,
+            MorseCancel.nativeBeltArc_zero]
+        rw [hz]
+        exact (S.belt_basin_iff hf q ((S.data q).surgery.beltSphere v)).mpr ⟨v, rfl⟩
+      · left
+        rw [← hsz, MorseCancel.nativeBeltLevelArc_coe S q u v hs1]
+        exact hmin s (abs_pos.mpr hs0) hsr
+    · exact Or.inl hzmin
+  refine
+    ⟨v, γ, hγ, hγi, hγd, hγreach, Circle.exp (2 * Real.pi / (2 * r + 1) * r), hsingle, ?_,
+      hendpoints⟩
+  let B : EuclideanSpace ℝ (Fin n) →L[ℝ] Smale.RegularLevel.Model E :=
+    mfderiv (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) (S.data q).surgery.beltSphere v
+  have hαtrans :
+    Function.Surjective
+      ((mfderiv 𝓘(ℝ, ℝ) 𝓘(ℝ, Smale.RegularLevel.Model E) (MorseCancel.nativeBeltLevelArc S q u v)
+              0 :
+            ℝ →L[ℝ] Smale.RegularLevel.Model E).coprod
+        B) :=
+    MorseCancel.nativeBeltLevelArc_transverse S hf q hq n u v
+  have ht :
+    Function.Surjective
+      ((mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) γ (ψ 0) :
+            EuclideanSpace ℝ (Fin 1) →L[ℝ] Smale.RegularLevel.Model E).coprod
+        B) :=
+    MorseCancel.transverse_circle_of_arc_germ (D := EuclideanSpace ℝ (Fin n)) (J :=
+      𝓘(ℝ, Smale.RegularLevel.Model E)) (α := MorseCancel.nativeBeltLevelArc S q u v) (γ := γ)
+      (ψ := ψ) hγ hψ heq B hαtrans
+  have hp0 : ψ 0 = Circle.exp (2 * Real.pi / (2 * r + 1) * r) := by
+    dsimp [ψ]
+    rw [zero_add]
+  rw [hp0] at ht
+  exact ht
+
+private theorem
+    AdaptedWindows.exists_native_level_basin_transport {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ}
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hb : ∀ y, f y = b → y ∉ Smale.ManifoldMorse.criticalPoints E f) (za : { x : M // f x = a })
+    (zb : { x : M // f x = b }) :
+    let _ := Smale.RegularLevel.chartedSpace hf ha
+    let _ := Smale.RegularLevel.chartedSpace hf hb
+    ∃ D :
+      PartialDiffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+        { x : M // f x = a } { x : M // f x = b } ∞,
+      D.source = {x | x.val ∈ Degree.FlowCancellation.levelBasin S.flow f b} ∧
+        D.target = {y | y.val ∈ Degree.FlowCancellation.levelBasin S.flow f a} ∧
+          ∀ x ∈ D.source, ∃ t : ℝ, S.flow t x.val = (D x).val := by
+  let _ := Smale.RegularLevel.chartedSpace hf ha
+  let _ := Smale.RegularLevel.chartedSpace hf hb
+  let _ := Smale.RegularLevel.isManifold hf ha
+  let _ := Smale.RegularLevel.isManifold hf hb
+  let A := { x : M // f x = a }
+  let B := { x : M // f x = b }
+  obtain ⟨Φa, hsa, hta, hfa, -⟩ :=
+    Degree.FlowCancellation.exists_native_level_flow_cylinder hf ha S.smooth S.flow S.integral
+      (fun x hx => S.descent x (ha x hx)) za
+  obtain ⟨Φb, hsb, htb, hfb, -⟩ :=
+    Degree.FlowCancellation.exists_native_level_flow_cylinder hf hb S.smooth S.flow S.integral
+      (fun x hx => S.descent x (hb x hx)) zb
+  let U : Set A := {x | x.val ∈ Degree.FlowCancellation.levelBasin S.flow f b}
+  let V : Set B := {x | x.val ∈ Degree.FlowCancellation.levelBasin S.flow f a}
+  let P : A → B := fun x => (Φb.symm x.val).1
+  let Q : B → A := fun y => (Φa.symm y.val).1
+  have hU : IsOpen U := by
+    have hh : IsOpen (Degree.FlowCancellation.levelBasin S.flow f b) := htb ▸ Φb.open_target
+    exact hh.preimage continuous_subtype_val
+  have hV : IsOpen V := by
+    have hh : IsOpen (Degree.FlowCancellation.levelBasin S.flow f a) := hta ▸ Φa.open_target
+    exact hh.preimage continuous_subtype_val
+  have hPa (x : A) (t : ℝ) : Φa.symm (S.flow t x.val) = (x, t) := by
+    have hs : (x, t) ∈ Φa.source := by rw [hsa]; trivial
+    have hh : Φa.symm (Φa (x, t)) = (x, t) := Φa.left_inv' hs
+    rwa [hfa] at hh
+  have hPb (y : B) (t : ℝ) : Φb.symm (S.flow t y.val) = (y, t) := by
+    have hs : (y, t) ∈ Φb.source := by rw [hsb]; trivial
+    have hh : Φb.symm (Φb (y, t)) = (y, t) := Φb.left_inv' hs
+    rwa [hfb] at hh
+  have horbP (x : A) (hx : x ∈ U) : S.flow (-(Φb.symm x.val).2) x.val = (P x).val := by
+    have hh : S.flow (Φb.symm x.val).2 (P x).val = x.val :=
+      (hfb (Φb.symm x.val)).symm.trans (Φb.right_inv' (htb.symm ▸ hx))
+    have hi := congrArg (S.flow (-(Φb.symm x.val).2)) hh
+    rw [← S.flow.map_add, neg_add_cancel, S.flow.map_zero_apply] at hi
+    exact hi.symm
+  have horbQ (y : B) (hy : y ∈ V) : S.flow (-(Φa.symm y.val).2) y.val = (Q y).val := by
+    have hh : S.flow (Φa.symm y.val).2 (Q y).val = y.val :=
+      (hfa (Φa.symm y.val)).symm.trans (Φa.right_inv' (hta.symm ▸ hy))
+    have hi := congrArg (S.flow (-(Φa.symm y.val).2)) hh
+    rw [← S.flow.map_add, neg_add_cancel, S.flow.map_zero_apply] at hi
+    exact hi.symm
+  have hPU : Set.MapsTo P U V := by
+    intro x hx
+    have hxa : x.val ∈ Degree.FlowCancellation.levelBasin S.flow f a :=
+      ⟨0, by simpa only [S.flow.map_zero_apply] using x.property⟩
+    change (P x).val ∈ Degree.FlowCancellation.levelBasin S.flow f a
+    exact
+      horbP x hx ▸
+        (Degree.FlowCancellation.levelBasin_flow_iff S.flow f a (-(Φb.symm x.val).2) x.val).mpr
+          hxa
+  have hQV : Set.MapsTo Q V U := by
+    intro y hy
+    have hyb : y.val ∈ Degree.FlowCancellation.levelBasin S.flow f b :=
+      ⟨0, by simpa only [S.flow.map_zero_apply] using y.property⟩
+    change (Q y).val ∈ Degree.FlowCancellation.levelBasin S.flow f b
+    exact
+      horbQ y hy ▸
+        (Degree.FlowCancellation.levelBasin_flow_iff S.flow f b (-(Φa.symm y.val).2) y.val).mpr
+          hyb
+  have hQP (x : A) (hx : x ∈ U) : Q (P x) = x := by
+    have hh := hPa x (-(Φb.symm x.val).2)
+    rw [horbP x hx] at hh
+    exact congrArg Prod.fst hh
+  have hPQ (y : B) (hy : y ∈ V) : P (Q y) = y := by
+    have hh := hPb y (-(Φa.symm y.val).2)
+    rw [horbQ y hy] at hh
+    exact congrArg Prod.fst hh
+  have hPs :
+    ContMDiffOn 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ P U := by
+    have hh :=
+      Φb.contMDiffOn_invFun.comp (Smale.RegularLevel.contMDiff_inclusion hf ha).contMDiffOn
+        (show Set.MapsTo (Subtype.val : A → M) U Φb.target from fun _ hx => htb.symm ▸ hx)
+    exact contMDiff_fst.comp_contMDiffOn hh
+  have hQs :
+    ContMDiffOn 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ Q V := by
+    have hh :=
+      Φa.contMDiffOn_invFun.comp (Smale.RegularLevel.contMDiff_inclusion hf hb).contMDiffOn
+        (show Set.MapsTo (Subtype.val : B → M) V Φa.target from fun _ hy => hta.symm ▸ hy)
+    exact contMDiff_fst.comp_contMDiffOn hh
+  let D :
+    PartialDiffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E) A B ∞ :=
+    { toFun := P
+      invFun := Q
+      source := U
+      target := V
+      map_source' := hPU
+      map_target' := hQV
+      left_inv' := hQP
+      right_inv' := hPQ
+      open_source := hU
+      open_target := hV
+      contMDiffOn_toFun := hPs
+      contMDiffOn_invFun := hQs }
+  exact ⟨D, rfl, rfl, fun x hx => ⟨-(Φb.symm x.val).2, horbP x hx⟩⟩
+
+private theorem
+    AdaptedWindows.belt_complement_reaches_lower_level {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f)
+    (y : (S.data p).UpperLevel) (hy : y ∉ Set.range (S.data p).surgery.beltSphere) :
+    y.val ∈ Degree.FlowCancellation.levelBasin S.flow f (S.toSurgeryWindows.lower p) := by
+  obtain ⟨a, ha, b, hb, hback, hforward, hheights⟩ :=
+    Degree.FlowCancellation.exists_native_descent_endpoints hf S.smooth S.flow S.integral S.zero
+      S.descent S.distinct y.val
+  have hyreg : y.val ∉ Smale.ManifoldMorse.criticalPoints E f :=
+    (S.data p).upper_regular y.val y.property
+  have hbelow : f b < S.toSurgeryWindows.lower p := by
+    rcases lt_trichotomy (f b) (f p) with h | h | h
+    · exact (S.toSurgeryWindows.value_lt_upper ⟨b, hb⟩).trans (S.separated ⟨b, hb⟩ p h)
+    · have heq : b = p.val := S.distinct hb p.property h
+      subst b
+      exact (hy ((S.belt_basin_iff hf p y).mp hforward)).elim
+    · have hup : f y.val < f b := by
+        rw [y.property]
+        exact (S.separated p ⟨b, hb⟩ h).trans (S.toSurgeryWindows.lower_lt_value ⟨b, hb⟩)
+      exact (not_lt_of_ge hup.le (hheights hyreg).1).elim
+  have hlow : S.toSurgeryWindows.lower p < f y.val := by
+    rw [y.property]
+    exact (S.toSurgeryWindows.lower_lt_value p).trans (S.toSurgeryWindows.value_lt_upper p)
+  exact
+    Degree.FlowCancellation.exists_level_crossing_of_endpoint_limits S.flow hf.continuous hback
+      hforward (hlow.trans (hheights hyreg).2) hbelow
+
+private theorem
+    AdaptedWindows.exists_belt_complement_lower_transport {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f)
+    (u : Metric.sphere (0 : (S.data p).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data p).chart.PositiveCoordinates) 1) :
+    ∃ D :
+      C(((Set.range (S.data p).surgery.beltSphere)ᶜ : Set (S.data p).UpperLevel),
+        (S.data p).LowerLevel),
+      (∀ x, ∃ t : ℝ, S.flow t x.val.val = (D x).val) ∧
+        ∀ x (y : (S.data p).LowerLevel) (t : ℝ), S.flow t x.val.val = y.val → D x = y := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data p).upper_regular
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data p).lower_regular
+  obtain ⟨P, hsource, -, horbit⟩ :=
+    S.exists_native_level_basin_transport hf (S.data p).upper_regular (S.data p).lower_regular
+      ((S.data p).surgery.beltSphere v) ((S.data p).surgery.attachingSphere u)
+  have hsrc (x : ((Set.range (S.data p).surgery.beltSphere)ᶜ : Set (S.data p).UpperLevel)) :
+    x.val ∈ P.source := hsource.symm ▸ S.belt_complement_reaches_lower_level hf p x.val x.property
+  let D :
+    C(((Set.range (S.data p).surgery.beltSphere)ᶜ : Set (S.data p).UpperLevel),
+      (S.data p).LowerLevel) :=
+    ⟨fun x => P x.val,
+      P.contMDiffOn_toFun.continuousOn.comp_continuous continuous_subtype_val hsrc⟩
+  refine ⟨D, fun x => horbit x.val (hsrc x), ?_⟩
+  intro x y t hty
+  obtain ⟨s, hs⟩ := horbit x.val (hsrc x)
+  have hshared : S.flow 0 (D x).val = S.flow (s - t) y.val := by
+    rw [S.flow.map_zero_apply]
+    change (P x.val).val = S.flow (s - t) y.val
+    rw [← hs, ← hty, ← S.flow.map_add, sub_add_cancel]
+  apply Subtype.ext
+  exact
+    MorseCancel.native_same_level_orbit_points hf S.smooth S.flow S.integral
+      (fun z hz => S.descent z ((S.data p).lower_regular z hz)) (D x).property y.property hshared
+
+private def MorseCancel.nativeUpperMeridianInComplement {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    {f : M → ℝ} (S : AdaptedWindows E f) (p : Smale.ManifoldMorse.criticalPoints E f)
+    (v : Metric.sphere (0 : (S.data p).chart.PositiveCoordinates) 1) (s : unitInterval)
+    (hs : 0 < (s : ℝ)) :
+    C(Metric.sphere (0 : (S.data p).chart.NegativeCoordinates) 1,
+      ((Set.range (S.data p).surgery.beltSphere)ᶜ : Set (S.data p).UpperLevel))
+    where
+  toFun u := ⟨nativeUpperMeridian S p v s u, nativeUpperMeridian_avoids_belt S p v s hs u⟩
+  continuous_toFun := (nativeUpperMeridian S p v s).continuous.subtype_mk _
+
+private theorem MorseCancel.lower_transport_upperMeridian_eq {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (p : Smale.ManifoldMorse.criticalPoints E f)
+    (D :
+      C(((Set.range (S.data p).surgery.beltSphere)ᶜ : Set (S.data p).UpperLevel),
+        (S.data p).LowerLevel))
+    (hD : ∀ x (y : (S.data p).LowerLevel) (t : ℝ), S.flow t x.val.val = y.val → D x = y)
+    (v : Metric.sphere (0 : (S.data p).chart.PositiveCoordinates) 1) (s : unitInterval)
+    (hs : 0 < (s : ℝ)) :
+    D.comp (nativeUpperMeridianInComplement S p v s hs) = nativeLowerMeridian S p v s := by
+  apply ContinuousMap.ext
+  intro u
+  exact
+    hD (nativeUpperMeridianInComplement S p v s hs u) (nativeLowerMeridian S p v s u)
+      (Degree.BeltPassage.time s) (nativeUpperMeridian_flow S p v s hs u)
+
+private theorem
+    AdaptedWindows.exists_lower_transport_with_meridians {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f)
+    (u : Metric.sphere (0 : (S.data p).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data p).chart.PositiveCoordinates) 1) :
+    ∃ D :
+      C(((Set.range (S.data p).surgery.beltSphere)ᶜ : Set (S.data p).UpperLevel),
+        (S.data p).LowerLevel),
+      (∀ x, ∃ t : ℝ, S.flow t x.val.val = (D x).val) ∧
+        (∀ x (y : (S.data p).LowerLevel) (t : ℝ), S.flow t x.val.val = y.val → D x = y) ∧
+          ∀ (w : Metric.sphere (0 : (S.data p).chart.PositiveCoordinates) 1) (s : unitInterval)
+            (hs : 0 < (s : ℝ)),
+            (D.comp (MorseCancel.nativeUpperMeridianInComplement S p w s hs)).Homotopic
+              (S.data p).surgery.attachingSphere := by
+  obtain ⟨D, horbit, hunique⟩ := S.exists_belt_complement_lower_transport hf p u v
+  refine ⟨D, horbit, hunique, ?_⟩
+  intro w s hs
+  rw [MorseCancel.lower_transport_upperMeridian_eq S p D hunique w s hs]
+  exact MorseCancel.nativeLowerMeridian_homotopic_attaching S p w s
+
+private theorem
+    AdaptedWindows.exists_lower_passage_homology_relation {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f)
+    (u : Metric.sphere (0 : (S.data p).chart.NegativeCoordinates) 1)
+    (v : Metric.sphere (0 : (S.data p).chart.PositiveCoordinates) 1)
+    (H : C(ℝ × Smale.Hemisphere.Sphere 2, (S.data p).UpperLevel)) {τ : ℝ}
+    (hτ : τ ∈ Set.Ioo (0 : ℝ) 1) (x₀ : Smale.Hemisphere.Sphere 2)
+    (hcross :
+      ∀ t ∈ Set.Icc (0 : ℝ) 1,
+        ∀ x : Smale.Hemisphere.Sphere 2,
+          H (t, x) ∈ Set.range (S.data p).surgery.beltSphere ↔ t = τ ∧ x = x₀) :
+    ∃ D :
+      C(((Set.range (S.data p).surgery.beltSphere)ᶜ : Set (S.data p).UpperLevel),
+        (S.data p).LowerLevel),
+      (∀ x, ∃ t : ℝ, S.flow t x.val.val = (D x).val) ∧
+        (∀ x (y : (S.data p).LowerLevel) (t : ℝ), S.flow t x.val.val = y.val → D x = y) ∧
+          (∀ (w : Metric.sphere (0 : (S.data p).chart.PositiveCoordinates) 1) (s : unitInterval)
+              (hs : 0 < (s : ℝ)),
+              (D.comp (MorseCancel.nativeUpperMeridianInComplement S p w s hs)).Homotopic
+                (S.data p).surgery.attachingSphere) ∧
+            let G :=
+              D.comp
+                (Degree.PassageHomology.puncturedPassageTrace H
+                  (Set.range (S.data p).surgery.beltSphere) hτ x₀ hcross)
+            (∀ z : ({(τ, x₀)}ᶜ : Set (ℝ × Smale.Hemisphere.Sphere 2)),
+                z.val.1 ∈ Set.Icc (0 : ℝ) 1 → ∃ t : ℝ, S.flow t (H z.val).val = (G z).val) ∧
+              ∀ (ε : ℝ) (hε : 0 < ε) (hεx : ε < Real.exp τ),
+                SingularMayerVietoris.singularHomologyMap
+                    (G.comp (Degree.PassageHomology.cylinderSlice τ x₀ 1 hτ.2.ne')) 2 =
+                  SingularMayerVietoris.singularHomologyMap
+                      (G.comp (Degree.PassageHomology.cylinderSlice τ x₀ 0 hτ.1.ne)) 2 +
+                    SingularMayerVietoris.singularHomologyMap
+                      (G.comp (Degree.PassageHomology.cylinderLink τ x₀ ε hε hεx)) 2 := by
+  obtain ⟨D, horbit, hunique, hmeridian⟩ := S.exists_lower_transport_with_meridians hf p u v
+  refine ⟨D, horbit, hunique, hmeridian, ?_, ?_⟩
+  · intro z hz
+    have hh :=
+      horbit
+        (Degree.PassageHomology.puncturedPassageTrace H (Set.range (S.data p).surgery.beltSphere)
+          hτ x₀ hcross z)
+    rw [Degree.PassageHomology.puncturedPassageTrace_on_interval H
+        (Set.range (S.data p).surgery.beltSphere) hτ x₀ hcross z hz] at hh
+    exact hh
+  · intro ε hε hεx
+    exact
+      Degree.PassageHomology.punctured_cylinder_trace_relation hτ x₀ hε hεx
+        (D.comp
+          (Degree.PassageHomology.puncturedPassageTrace H
+            (Set.range (S.data p).surgery.beltSphere) hτ x₀ hcross))
+        2 (by decide)
+
+private def
+    Smale.PartialChart.openInclusion {E H X : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [TopologicalSpace X] [ChartedSpace H X]
+    (U : TopologicalSpace.Opens X) [Nonempty U] : PartialDiffeomorph I I U X ∞ := by
+  let h : OpenPartialHomeomorph U X := U.isOpen.isOpenEmbedding_subtypeVal.toOpenPartialHomeomorph
+  refine
+    { toPartialEquiv := h.toPartialEquiv
+      open_source := h.open_source
+      open_target := h.open_target
+      contMDiffOn_toFun := contMDiff_subtype_val.contMDiffOn
+      contMDiffOn_invFun := ?_ }
+  change ContMDiffOn I I ∞ h.symm h.target
+  intro x hx
+  apply (ContMDiffWithinAt.subtypeVal_comp_iff U h.symm h.target x).mp
+  apply contMDiffWithinAt_id.congr_of_mem (fun y hy => ?_) hx
+  exact h.right_inv hy
+
+private theorem Smale.PartialChart.openInclusion_target {E H X : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [TopologicalSpace X]
+    [ChartedSpace H X] (U : TopologicalSpace.Opens X) [Nonempty U] :
+    (openInclusion (I := I) U).target = U := by
+  change U.isOpen.isOpenEmbedding_subtypeVal.toOpenPartialHomeomorph.target = U
+  rw [Topology.IsOpenEmbedding.toOpenPartialHomeomorph_target]
+  exact Subtype.range_coe
+
+private theorem Smale.PartialChart.openInclusion_symm_coe {E H X : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [TopologicalSpace X]
+    [ChartedSpace H X] (U : TopologicalSpace.Opens X) [Nonempty U] {x : X} (hx : x ∈ U) :
+    ((openInclusion (I := I) U).symm x).val = x := by
+  have h :=
+    (openInclusion (I := I) U).right_inv
+      (show x ∈ (openInclusion (I := I) U).target by rw [openInclusion_target]; exact hx)
+  exact h
+
+private def Degree.PassageHomology.puncturedVectorSpace (E : Type) [NormedAddCommGroup E] :
+    TopologicalSpace.Opens E :=
+  ⟨({0}ᶜ : Set E), isOpen_compl_singleton⟩
+
+private theorem
+    Degree.PassageHomology.radialCylinderHomeomorph_symm_fst (E : Type) [NormedAddCommGroup E]
+    [InnerProductSpace ℝ E] (x : ({0}ᶜ : Set E)) :
+    ((radialCylinderHomeomorph E).symm x).1 = Real.log ‖x.val‖ := by
+  have hn : 0 < ‖x.val‖ := norm_pos_iff.mpr x.property
+  change Real.expOrderIso.symm ((homeomorphUnitSphereProd E) x).2 = _
+  rw [Real.log_of_pos hn]
+  congr 1
+  apply Subtype.ext
+  exact homeomorphUnitSphereProd_apply_snd_coe E x
+
+private theorem Degree.PassageHomology.radialCylinderHomeomorph_symm_snd_coe (E : Type)
+    [NormedAddCommGroup E] [InnerProductSpace ℝ E] (x : ({0}ᶜ : Set E)) :
+    (((radialCylinderHomeomorph E).symm x).2 : E) = ‖x.val‖⁻¹ • x.val := by
+  change (((homeomorphUnitSphereProd E) x).1 : E) = _
+  exact homeomorphUnitSphereProd_apply_fst_coe E x
+
+private def Degree.PassageHomology.radialCylinderDiffeomorph (E : Type) [NormedAddCommGroup E]
+    [InnerProductSpace ℝ E] (n : ℕ) [Fact (Module.finrank ℝ E = n + 1)] :
+    Diffeomorph (𝓘(ℝ, ℝ).prod (𝓡 n)) 𝓘(ℝ, E) (ℝ × Metric.sphere (0 : E) 1)
+      (puncturedVectorSpace E) ∞
+    where
+  toEquiv := (radialCylinderHomeomorph E).toEquiv
+  contMDiff_toFun := by
+    apply (ContMDiff.subtypeVal_comp_iff (puncturedVectorSpace E) _).mp
+    change
+      ContMDiff (𝓘(ℝ, ℝ).prod (𝓡 n)) 𝓘(ℝ, E) ∞
+        (fun p : ℝ × Metric.sphere (0 : E) 1 => Real.exp p.1 • p.2.val)
+    exact
+      (Real.contDiff_exp.contMDiff.comp contMDiff_fst).smul
+        ((contMDiff_coe_sphere (n := n)).comp contMDiff_snd)
+  contMDiff_invFun := by
+    have hn : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ (fun x : puncturedVectorSpace E => ‖x.val‖) := by
+      intro x
+      exact (contDiffAt_norm ℝ x.property).contMDiffAt.comp x contMDiff_subtype_val.contMDiffAt
+    have hl : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ (fun x : puncturedVectorSpace E => Real.log ‖x.val‖) := by
+      intro x
+      exact
+        (Real.contDiffAt_log.mpr (norm_ne_zero_iff.mpr x.property)).contMDiffAt.comp x
+          hn.contMDiffAt
+    have hraw :
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, E) ∞ (fun x : puncturedVectorSpace E => ‖x.val‖⁻¹ • x.val) :=
+      (hn.inv₀ (fun x => norm_ne_zero_iff.mpr x.property)).smul contMDiff_subtype_val
+    have hfst :
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞
+        (fun x : puncturedVectorSpace E => ((radialCylinderHomeomorph E).symm x).1) := by
+      have heq :
+        (fun x : puncturedVectorSpace E => ((radialCylinderHomeomorph E).symm x).1) =
+          (fun x => Real.log ‖x.val‖) :=
+        funext (fun x => radialCylinderHomeomorph_symm_fst E x)
+      rw [heq]
+      exact hl
+    have hval :
+      ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, E) ∞
+        (fun x : puncturedVectorSpace E => (((radialCylinderHomeomorph E).symm x).2 : E)) := by
+      have heq :
+        (fun x : puncturedVectorSpace E => (((radialCylinderHomeomorph E).symm x).2 : E)) =
+          (fun x => ‖x.val‖⁻¹ • x.val) :=
+        funext (fun x => radialCylinderHomeomorph_symm_snd_coe E x)
+      rw [heq]
+      exact hraw
+    have hsnd :
+      ContMDiff 𝓘(ℝ, E) (𝓡 n) ∞
+        (fun x : puncturedVectorSpace E => ((radialCylinderHomeomorph E).symm x).2) :=
+      hval.codRestrict_sphere (fun x => ((radialCylinderHomeomorph E).symm x).2.property)
+    exact hfst.prodMk hsnd
+
+private def Degree.PassageHomology.radialCylinderChart (E : Type) [NormedAddCommGroup E]
+    [InnerProductSpace ℝ E] (n : ℕ) [Fact (Module.finrank ℝ E = n + 1)]
+    (u : Metric.sphere (0 : E) 1) :
+    PartialDiffeomorph (𝓘(ℝ, ℝ).prod (𝓡 n)) 𝓘(ℝ, E) (ℝ × Metric.sphere (0 : E) 1) E ∞ := by
+  let _ : Nonempty (puncturedVectorSpace E) :=
+    ⟨⟨u.val, Metric.ne_of_mem_sphere u.property one_ne_zero⟩⟩
+  exact
+    (radialCylinderDiffeomorph E n).toPartialDiffeomorph.trans
+      (Smale.PartialChart.openInclusion (I := 𝓘(ℝ, E)) (puncturedVectorSpace E))
+
+private theorem
+    Degree.PassageHomology.radialCylinderChart_mem_source (E : Type) [NormedAddCommGroup E]
+    [InnerProductSpace ℝ E] (n : ℕ) [Fact (Module.finrank ℝ E = n + 1)]
+    (u : Metric.sphere (0 : E) 1) (p : ℝ × Metric.sphere (0 : E) 1) :
+    p ∈ (radialCylinderChart E n u).source :=
+  ⟨Set.mem_univ _, Set.mem_univ _⟩
+
+private theorem
+    Degree.PassageHomology.radialCylinderChart_mem_target (E : Type) [NormedAddCommGroup E]
+    [InnerProductSpace ℝ E] (n : ℕ) [Fact (Module.finrank ℝ E = n + 1)]
+    (u : Metric.sphere (0 : E) 1) (z : E) : z ∈ (radialCylinderChart E n u).target ↔ z ≠ 0 := by
+  let _ : Nonempty (puncturedVectorSpace E) :=
+    ⟨⟨u.val, Metric.ne_of_mem_sphere u.property one_ne_zero⟩⟩
+  change
+    (z ∈ (Smale.PartialChart.openInclusion (I := 𝓘(ℝ, E)) (puncturedVectorSpace E)).target ∧
+        (Smale.PartialChart.openInclusion (I := 𝓘(ℝ, E)) (puncturedVectorSpace E)).symm z ∈
+          Set.univ) ↔
+      z ≠ 0
+  rw [Smale.PartialChart.openInclusion_target]
+  exact ⟨fun h => h.1, fun h => ⟨h, Set.mem_univ _⟩⟩
+
+private theorem Degree.PassageHomology.radialCylinderChart_symm_eq (E : Type) [NormedAddCommGroup E]
+    [InnerProductSpace ℝ E] (n : ℕ) [Fact (Module.finrank ℝ E = n + 1)]
+    (u : Metric.sphere (0 : E) 1) (z : E) (hz : z ≠ 0) :
+    (radialCylinderChart E n u).symm z = (radialCylinderHomeomorph E).symm ⟨z, hz⟩ := by
+  let _ : Nonempty (puncturedVectorSpace E) :=
+    ⟨⟨u.val, Metric.ne_of_mem_sphere u.property one_ne_zero⟩⟩
+  change
+    (radialCylinderDiffeomorph E n).symm
+        ((Smale.PartialChart.openInclusion (I := 𝓘(ℝ, E)) (puncturedVectorSpace E)).symm z) =
+      _
+  have heq :
+    (Smale.PartialChart.openInclusion (I := 𝓘(ℝ, E)) (puncturedVectorSpace E)).symm z =
+      (⟨z, hz⟩ : puncturedVectorSpace E) :=
+    Subtype.ext
+      (Smale.PartialChart.openInclusion_symm_coe (I := 𝓘(ℝ, E)) (puncturedVectorSpace E) hz)
+  rw [heq]
+  rfl
+
+private abbrev Smale.PuncturedRadial.Space (N : Type*) [Zero N] :=
+  { u : N // u ≠ 0 }
+
+private def Smale.PuncturedRadial.toSphere {N : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N] :
+    C(Space N, Metric.sphere (0 : N) 1) :=
+  ⟨fun u => Smale.RadialExtension.direction u.val u.property,
+    ((continuous_subtype_val.norm.inv₀ (fun u => norm_ne_zero_iff.mpr u.property)).smul
+          continuous_subtype_val).subtype_mk
+      _⟩
+
+private def
+    Smale.PuncturedRadial.fromSphere {N : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N] (r : ℝ)
+    (hr : 0 < r) : C(Metric.sphere (0 : N) 1, Space N) :=
+  ⟨fun u => ⟨r • (u : N), smul_ne_zero hr.ne' (ne_zero_of_mem_unit_sphere u)⟩,
+    (continuous_const.smul continuous_subtype_val).subtype_mk _⟩
+
+private theorem Smale.PuncturedRadial.toSphere_fromSphere {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] (r : ℝ) (hr : 0 < r) (u : Metric.sphere (0 : N) 1) :
+    toSphere (fromSphere r hr u) = u := by
+  apply Subtype.ext
+  change ‖r • (u : N)‖⁻¹ • (r • (u : N)) = (u : N)
+  rw [norm_smul, Real.norm_eq_abs, abs_of_pos hr, mem_sphere_zero_iff_norm.mp u.property, mul_one,
+    inv_smul_smul₀ hr.ne']
+
+private def
+    Smale.PuncturedRadial.blendVector {N : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N] (r : ℝ)
+    (q : (unitInterval) × Space N) : N :=
+  ((1 - (q.1 : ℝ)) + (q.1 : ℝ) * (r / ‖q.2.val‖)) • q.2.val
+
+private theorem Smale.PuncturedRadial.continuous_blendVector {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] (r : ℝ) : Continuous (blendVector (N := N) r) := by
+  have ht : Continuous (fun q : (unitInterval) × Space N => (q.1 : ℝ)) :=
+    continuous_subtype_val.comp continuous_fst
+  have hu : Continuous (fun q : (unitInterval) × Space N => q.2.val) :=
+    continuous_subtype_val.comp continuous_snd
+  exact
+    ((continuous_const.sub ht).add
+          (ht.mul
+            (continuous_const.div hu.norm (fun q => norm_ne_zero_iff.mpr q.2.property)))).smul
+      hu
+
+private theorem Smale.PuncturedRadial.blendVector_ne_zero {N : Type*} [NormedAddCommGroup N]
+    [NormedSpace ℝ N] (r : ℝ) (hr : 0 < r) (q : (unitInterval) × Space N) : blendVector r q ≠ 0 :=
+  by
+  have hu : 0 < ‖q.2.val‖ := norm_pos_iff.mpr q.2.property
+  have hpos : 0 < (1 - (q.1 : ℝ)) + (q.1 : ℝ) * (r / ‖q.2.val‖) := by
+    have h :=
+      (convex_Ioi (𝕜 := ℝ) (0 : ℝ)) (by norm_num : (1 : ℝ) ∈ Ioi 0) (div_pos hr hu)
+        (sub_nonneg.mpr q.1.property.2) q.1.property.1 (sub_add_cancel 1 (q.1 : ℝ))
+    simpa only [smul_eq_mul, mul_one, Set.mem_Ioi] using h
+  exact smul_ne_zero hpos.ne' q.2.property
+
+private def
+    Smale.PuncturedRadial.deformation {N : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N] (r : ℝ)
+    (hr : 0 < r) : (ContinuousMap.id (Space N)).Homotopy ((fromSphere r hr).comp toSphere)
+    where
+  toFun q := ⟨blendVector r q, blendVector_ne_zero r hr q⟩
+  continuous_toFun := (continuous_blendVector r).subtype_mk _
+  map_zero_left
+    u := by
+    apply Subtype.ext
+    simp [blendVector]
+  map_one_left
+    u := by
+    apply Subtype.ext
+    simp [blendVector, fromSphere, toSphere, Smale.RadialExtension.direction, div_eq_mul_inv,
+      smul_smul]
+
+private def
+    Smale.PuncturedRadial.sphereHomotopyEquiv {N : Type*} [NormedAddCommGroup N] [NormedSpace ℝ N]
+    (r : ℝ) (hr : 0 < r) : Metric.sphere (0 : N) 1 ≃ₕ Space N
+    where
+  toFun := fromSphere r hr
+  invFun := toSphere
+  left_inv := by
+    have heq : toSphere.comp (fromSphere r hr) = ContinuousMap.id (Metric.sphere (0 : N) 1) :=
+      ContinuousMap.ext (toSphere_fromSphere r hr)
+    rw [heq]
+  right_inv := ⟨(deformation r hr).symm⟩
+
+private theorem Smale.LocalDegree.exists_pos_remainder_bound {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F} (L : E ≃L[ℝ] F)
+    (hf : HasFDerivAt f L.toContinuousLinearMap 0) (hzero : f 0 = 0) :
+    ∃ ε : ℝ, 0 < ε ∧ ∀ x ∈ Metric.ball (0 : E) ε, ‖f x - L x‖ ≤ (1 / 2 : ℝ) * ‖L x‖ := by
+  have herr : (fun x : E => f x - L x) =o[𝓝 (0 : E)] (fun x : E => x) := by
+    convert hf.isLittleO using 1
+    · rfl
+    · rfl
+    · simp only [hzero, sub_zero]
+      rfl
+    · simp only [sub_zero]
+  have hbig : (fun x : E => x) =O[𝓝 (0 : E)] (fun x : E => L x) := by
+    apply Asymptotics.isBigO_iff.mpr
+    refine ⟨‖L.symm.toContinuousLinearMap‖, Filter.Eventually.of_forall ?_⟩
+    intro x
+    have h := L.symm.toContinuousLinearMap.le_opNorm (L x)
+    simpa only [ContinuousLinearEquiv.coe_coe, L.symm_apply_apply] using h
+  exact
+    Metric.eventually_nhds_iff_ball.mp
+      ((herr.trans_isBigO hbig).bound (by norm_num : (0 : ℝ) < 1 / 2))
+
+private def Smale.LocalDegree.blend {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (f : E → F) (L : E ≃L[ℝ] F) (t : (unitInterval))
+    (x : E) : F :=
+  L x + (t : ℝ) • (f x - L x)
+
+private theorem
+    Smale.LocalDegree.blend_ne_zero {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F} (L : E ≃L[ℝ] F) (t : (unitInterval))
+    {x : E} (hx : x ≠ 0) (hbound : ‖f x - L x‖ ≤ (1 / 2 : ℝ) * ‖L x‖) : blend f L t x ≠ 0 := by
+  have hL : L x ≠ 0 := fun h => hx (L.injective (h.trans (map_zero L).symm))
+  have hsmall : ‖(t : ℝ) • (f x - L x)‖ < ‖L x‖ := by
+    rw [norm_smul, Real.norm_eq_abs, abs_of_nonneg t.property.1]
+    calc
+      (t : ℝ) * ‖f x - L x‖ ≤ ‖f x - L x‖ := mul_le_of_le_one_left (norm_nonneg _) t.property.2
+      _ ≤ (1 / 2 : ℝ) * ‖L x‖ := hbound
+      _ < ‖L x‖ := by nlinarith [norm_pos_iff.mpr hL]
+  intro h
+  have heq : (t : ℝ) • (f x - L x) = -L x := by
+    change L x + (t : ℝ) • (f x - L x) = 0 at h
+    rw [add_comm] at h
+    exact add_eq_zero_iff_eq_neg.mp h
+  rw [heq, norm_neg] at hsmall
+  exact (lt_irrefl _ hsmall)
+
+private theorem
+    Smale.LocalDegree.image_ne_zero {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F} (L : E ≃L[ℝ] F) {x : E} (hx : x ≠ 0)
+    (hbound : ‖f x - L x‖ ≤ (1 / 2 : ℝ) * ‖L x‖) : f x ≠ 0 := by
+  have h := blend_ne_zero L (1 : (unitInterval)) hx hbound
+  change L x + (1 : ℝ) • (f x - L x) ≠ 0 at h
+  simpa using h
+
+private def Smale.LocalDegree.linearSphereMap {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (L : E ≃L[ℝ] F) (r : ℝ) (hr : 0 < r) :
+    C(Metric.sphere (0 : E) 1, Smale.PuncturedRadial.Space F) :=
+  ⟨fun u =>
+    ⟨L (r • (u : E)), fun h =>
+      (smul_ne_zero hr.ne' (ne_zero_of_mem_unit_sphere u))
+        (L.injective (h.trans (map_zero L).symm))⟩,
+    (L.continuous.comp (continuous_const.smul continuous_subtype_val)).subtype_mk _⟩
+
+private def Smale.LocalDegree.boundaryMap {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (f : E → F) (L : E ≃L[ℝ] F) (r : ℝ) (hr : 0 < r)
+    (hc : Continuous (fun u : Metric.sphere (0 : E) 1 => f (r • (u : E))))
+    (hb :
+      ∀ u : Metric.sphere (0 : E) 1,
+        ‖f (r • (u : E)) - L (r • (u : E))‖ ≤ (1 / 2 : ℝ) * ‖L (r • (u : E))‖) :
+    C(Metric.sphere (0 : E) 1, Smale.PuncturedRadial.Space F) :=
+  ⟨fun u =>
+    ⟨f (r • (u : E)),
+      image_ne_zero L (smul_ne_zero hr.ne' (ne_zero_of_mem_unit_sphere u)) (hb u)⟩,
+    hc.subtype_mk _⟩
+
+private def
+    Smale.LocalDegree.boundaryHomotopy {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (f : E → F) (L : E ≃L[ℝ] F) (r : ℝ) (hr : 0 < r)
+    (hc : Continuous (fun u : Metric.sphere (0 : E) 1 => f (r • (u : E))))
+    (hb :
+      ∀ u : Metric.sphere (0 : E) 1,
+        ‖f (r • (u : E)) - L (r • (u : E))‖ ≤ (1 / 2 : ℝ) * ‖L (r • (u : E))‖) :
+    (linearSphereMap L r hr).Homotopy (boundaryMap f L r hr hc hb)
+    where
+  toFun
+    q :=
+    ⟨blend f L q.1 (r • (q.2 : E)),
+      blend_ne_zero L q.1 (smul_ne_zero hr.ne' (ne_zero_of_mem_unit_sphere q.2)) (hb q.2)⟩
+  continuous_toFun := by
+    have ht : Continuous (fun q : (unitInterval) × Metric.sphere (0 : E) 1 => (q.1 : ℝ)) :=
+      continuous_subtype_val.comp continuous_fst
+    have hL :
+      Continuous (fun q : (unitInterval) × Metric.sphere (0 : E) 1 => L (r • (q.2 : E))) :=
+      L.continuous.comp (continuous_const.smul (continuous_subtype_val.comp continuous_snd))
+    exact (hL.add (ht.smul ((hc.comp continuous_snd).sub hL))).subtype_mk _
+  map_zero_left
+    u := by
+    apply Subtype.ext
+    simp [blend, linearSphereMap]
+  map_one_left
+    u := by
+    apply Subtype.ext
+    simp [blend, boundaryMap]
+
+private structure
+    Smale.LocalDegree.BoundaryData {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (f : E → F) (L : E ≃L[ℝ] F) (s : Set E) where
+  radius : ℝ
+  radius_pos : 0 < radius
+  ball_subset : Metric.closedBall 0 radius ⊆ s
+  continuous : Continuous (fun u : Metric.sphere (0 : E) 1 => f (radius • (u : E)))
+  remainder_bound :
+    ∀ u : Metric.sphere (0 : E) 1,
+      ‖f (radius • (u : E)) - L (radius • (u : E))‖ ≤ (1 / 2 : ℝ) * ‖L (radius • (u : E))‖
+
+public
+theorem Smale.LocalDegree.norm_radius_smul {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (r : ℝ) (hr : 0 < r) (u : Metric.sphere (0 : E) 1) : ‖r • (u : E)‖ = r := by
+  rw [norm_smul, Real.norm_eq_abs, abs_of_pos hr, mem_sphere_zero_iff_norm.mp u.property, mul_one]
+
+private theorem Smale.LocalDegree.nonempty_boundaryData {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F} (L : E ≃L[ℝ] F)
+    {s : Set E} (hf : HasFDerivAt f L.toContinuousLinearMap 0) (hzero : f 0 = 0)
+    (hs : s ∈ 𝓝 (0 : E)) (hc : ContinuousOn f s) : Nonempty (BoundaryData f L s) := by
+  obtain ⟨δ, hδ, hδs⟩ := Metric.mem_nhds_iff.mp hs
+  obtain ⟨ε, hε, hεb⟩ := exists_pos_remainder_bound L hf hzero
+  let r : ℝ := Min.min δ ε / 2
+  have hr : 0 < r := half_pos (lt_min hδ hε)
+  have hrδ : r < δ := (half_lt_self (lt_min hδ hε)).trans_le (min_le_left δ ε)
+  have hrε : r < ε := (half_lt_self (lt_min hδ hε)).trans_le (min_le_right δ ε)
+  have hball : Metric.closedBall (0 : E) r ⊆ s := (Metric.closedBall_subset_ball hrδ).trans hδs
+  have hparam (u : Metric.sphere (0 : E) 1) : r • (u : E) ∈ Metric.closedBall (0 : E) r := by
+    rw [mem_closedBall_zero_iff, norm_radius_smul r hr u]
+  have hparamc : Continuous (fun u : Metric.sphere (0 : E) 1 => r • (u : E)) :=
+    continuous_const.smul continuous_subtype_val
+  refine ⟨⟨r, hr, hball, hc.comp_continuous hparamc (fun u => hball (hparam u)), ?_⟩⟩
+  intro u
+  apply hεb
+  rw [mem_ball_zero_iff, norm_radius_smul r hr u]
+  exact hrε
+
+private theorem
+    Smale.LocalDegree.nonempty_boundaryData_of_contDiffAt {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F} (L : E ≃L[ℝ] F)
+    {s : Set E} (hf : HasFDerivAt f L.toContinuousLinearMap 0) (hzero : f 0 = 0)
+    (hs : s ∈ 𝓝 (0 : E)) (hc : ContDiffAt ℝ ∞ f 0) : Nonempty (BoundaryData f L s) := by
+  obtain ⟨t, ht, htc⟩ := contDiffAt_zero.mp (hc.of_le (by simp))
+  obtain ⟨b⟩ :=
+    nonempty_boundaryData L hf hzero (Filter.inter_mem hs ht) (htc.mono Set.inter_subset_right)
+  exact ⟨{ b with ball_subset := b.ball_subset.trans Set.inter_subset_left }⟩
+
+private def
+    Smale.LocalDegree.BoundaryData.map {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F} {L : E ≃L[ℝ] F} {s : Set E}
+    (b : Smale.LocalDegree.BoundaryData f L s) :
+    C(Metric.sphere (0 : E) 1, Smale.PuncturedRadial.Space F) :=
+  Smale.LocalDegree.boundaryMap f L b.radius b.radius_pos b.continuous b.remainder_bound
+
+private theorem Smale.LocalDegree.BoundaryData.map_coe {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F} {L : E ≃L[ℝ] F}
+    {s : Set E} (b : Smale.LocalDegree.BoundaryData f L s) (u : Metric.sphere (0 : E) 1) :
+    (b.map u).val = f (b.radius • (u : E)) :=
+  rfl
+
+private def
+    Smale.LocalDegree.BoundaryData.homotopy {E F : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F} {L : E ≃L[ℝ] F} {s : Set E}
+    (b : Smale.LocalDegree.BoundaryData f L s) :
+    (Smale.LocalDegree.linearSphereMap L b.radius b.radius_pos).Homotopy b.map :=
+  Smale.LocalDegree.boundaryHomotopy f L b.radius b.radius_pos b.continuous b.remainder_bound
+
+private def Smale.LocalDegree.puncturedLinearHomeomorph {E F : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] (L : E ≃L[ℝ] F) :
+    Smale.PuncturedRadial.Space E ≃ₜ Smale.PuncturedRadial.Space F :=
+  L.toHomeomorph.subtype
+    (fun x => by
+      change x ≠ 0 ↔ L x ≠ 0
+      constructor
+      · intro hx h
+        exact hx (L.injective (h.trans (map_zero L).symm))
+      · intro hx h
+        exact hx (h ▸ map_zero L))
+
+private def
+    Smale.LocalDegree.linearSphereEquiv {E F : Type} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [NormedAddCommGroup F] [NormedSpace ℝ F] (L : E ≃L[ℝ] F) (r : ℝ) (hr : 0 < r) :
+    Metric.sphere (0 : E) 1 ≃ₕ Smale.PuncturedRadial.Space F :=
+  (Smale.PuncturedRadial.sphereHomotopyEquiv r hr).trans
+    (puncturedLinearHomeomorph L).toHomotopyEquiv
+
+private theorem Smale.LocalDegree.BoundaryData.homology_compare {E F : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F} {L : E ≃L[ℝ] F}
+    {s : Set E} (b : Smale.LocalDegree.BoundaryData f L s) (k : ℕ) :
+    SingularMayerVietoris.singularHomologyMap b.map k =
+      SingularMayerVietoris.singularHomologyMap
+        (Smale.LocalDegree.linearSphereMap L b.radius b.radius_pos) k :=
+  (PeriodTorusHigherHomology.homotopy_homologyMap b.homotopy k).symm
+
+private def Smale.LocalDegree.BoundaryData.normalizedMap {E F : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [NormedAddCommGroup F] [NormedSpace ℝ F] {f : E → F} {L : E ≃L[ℝ] F}
+    {s : Set E} (b : Smale.LocalDegree.BoundaryData f L s) :
+    C(Metric.sphere (0 : E) 1, Metric.sphere (0 : F) 1) :=
+  Smale.PuncturedRadial.toSphere.comp b.map
+
+private def MorseCancel.radialParameterChart (τ : ℝ) (u : (Smale.Hemisphere.Sphere 2)) :
+    PartialDiffeomorph (𝓡 3) (𝓘(ℝ, ℝ).prod (𝓡 2)) (EuclideanSpace ℝ (Fin 3))
+      (ℝ × (Smale.Hemisphere.Sphere 2)) ∞ := by
+  let _ : Fact (Module.finrank ℝ (EuclideanSpace ℝ (Fin 3)) = 2 + 1) := ⟨by simp⟩
+  let b := Degree.PassageHomology.cylinderPuncture τ u
+  let T : Diffeomorph (𝓡 3) (𝓡 3) (EuclideanSpace ℝ (Fin 3)) (EuclideanSpace ℝ (Fin 3)) ∞ :=
+    { toEquiv :=
+        { toFun := fun z => b + z
+          invFun := fun z => z - b
+          left_inv := fun z => add_sub_cancel_left b z
+          right_inv := by intro z; simp }
+      contMDiff_toFun := (contDiff_const.add contDiff_id).contMDiff
+      contMDiff_invFun := (contDiff_id.sub contDiff_const).contMDiff }
+  exact
+    T.toPartialDiffeomorph.trans
+      (Degree.PassageHomology.radialCylinderChart (EuclideanSpace ℝ (Fin 3)) 2 u).symm
+
+private theorem MorseCancel.radialParameterChart_zero_mem_source (τ : ℝ)
+    (u : (Smale.Hemisphere.Sphere 2)) :
+    (0 : (EuclideanSpace ℝ (Fin 3))) ∈ (radialParameterChart τ u).source := by
+  let _ : Fact (Module.finrank ℝ (EuclideanSpace ℝ (Fin 3)) = 2 + 1) := ⟨by simp⟩
+  change
+    (0 : (EuclideanSpace ℝ (Fin 3))) ∈ Set.univ ∧
+      Degree.PassageHomology.cylinderPuncture τ u + 0 ∈
+        (Degree.PassageHomology.radialCylinderChart (EuclideanSpace ℝ (Fin 3)) 2 u).target
+  rw [add_zero, Degree.PassageHomology.radialCylinderChart_mem_target]
+  exact
+    ⟨Set.mem_univ _,
+      norm_pos_iff.mp
+        (by rw [Degree.PassageHomology.norm_cylinderPuncture]; exact Real.exp_pos τ)⟩
+
+private theorem MorseCancel.radialParameterChart_zero (τ : ℝ) (u : (Smale.Hemisphere.Sphere 2)) :
+    radialParameterChart τ u 0 = (τ, u) := by
+  let _ : Fact (Module.finrank ℝ (EuclideanSpace ℝ (Fin 3)) = 2 + 1) := ⟨by simp⟩
+  change
+    (Degree.PassageHomology.radialCylinderChart (EuclideanSpace ℝ (Fin 3)) 2 u).symm
+        (Degree.PassageHomology.cylinderPuncture τ u + 0) =
+      (τ, u)
+  rw [add_zero]
+  have heq :
+    Degree.PassageHomology.radialCylinderChart (EuclideanSpace ℝ (Fin 3)) 2 u (τ, u) =
+      Degree.PassageHomology.cylinderPuncture τ u :=
+    rfl
+  rw [← heq]
+  exact
+    (Degree.PassageHomology.radialCylinderChart (EuclideanSpace ℝ (Fin 3)) 2 u).left_inv
+      (Degree.PassageHomology.radialCylinderChart_mem_source (EuclideanSpace ℝ (Fin 3)) 2 u
+        (τ, u))
+
+private theorem MorseCancel.radialParameterChart_apply (τ : ℝ) (u : (Smale.Hemisphere.Sphere 2))
+    (z : (EuclideanSpace ℝ (Fin 3))) (hz : Degree.PassageHomology.cylinderPuncture τ u + z ≠ 0) :
+    radialParameterChart τ u z =
+      (Degree.PassageHomology.radialCylinderHomeomorph (EuclideanSpace ℝ (Fin 3))).symm
+        ⟨Degree.PassageHomology.cylinderPuncture τ u + z, hz⟩ := by
+  let _ : Fact (Module.finrank ℝ (EuclideanSpace ℝ (Fin 3)) = 2 + 1) := ⟨by simp⟩
+  exact
+    Degree.PassageHomology.radialCylinderChart_symm_eq (EuclideanSpace ℝ (Fin 3)) 2 u
+      (Degree.PassageHomology.cylinderPuncture τ u + z) hz
+
+private theorem
+    MorseCancel.radialParameterChart_link (τ : ℝ) (u : (Smale.Hemisphere.Sphere 2)) (ε : ℝ)
+    (hε : 0 < ε) (hεu : ε < Real.exp τ) (w : (Smale.Hemisphere.Sphere 2)) :
+    radialParameterChart τ u (ε • w.val) =
+      (Degree.PassageHomology.cylinderLink τ u ε hε hεu w).val := by
+  have hz : Degree.PassageHomology.cylinderPuncture τ u + ε • w.val ≠ 0 :=
+    (Degree.PassageHomology.linkingSphere (Degree.PassageHomology.cylinderPuncture τ u) ε hε
+          (by rwa [Degree.PassageHomology.norm_cylinderPuncture]) w).property.1
+  exact radialParameterChart_apply τ u (ε • w.val) hz
+
+private theorem
+    NoExotic.IntLinearAutomorphism.apply_eq_mul (e : ℤ ≃ₗ[ℤ] ℤ) (k : ℤ) : e k = e 1 * k := by
+  simpa only [smul_eq_mul, mul_one, mul_comm] using e.map_smul k 1
+
+private theorem NoExotic.IntLinearAutomorphism.apply_one_eq_one_or_neg_one (e : ℤ ≃ₗ[ℤ] ℤ) :
+    e 1 = 1 ∨ e 1 = -1 := by
+  apply Int.eq_one_or_neg_one_of_mul_eq_one (v := e.symm 1)
+  rw [← apply_eq_mul, e.apply_symm_apply]
+
+private theorem
+    MorseCancel.two_sphere_map_unit_of_homology_bijective {Y : Type} [TopologicalSpace Y]
+    (e : (Smale.Hemisphere.Sphere 2) ≃ₜ Y) (g : C((Smale.Hemisphere.Sphere 2), Y))
+    (hg : Function.Bijective (SingularMayerVietoris.singularHomologyMap g 2)) :
+    ∃ k : ℤ,
+      (k = 1 ∨ k = -1) ∧
+        SingularMayerVietoris.singularHomologyMap g 2 =
+          k •
+            SingularMayerVietoris.singularHomologyMap (e : C((Smale.Hemisphere.Sphere 2), Y)) 2 :=
+  by
+  let H := SphereHomology.unitSphereHomologyTopEquiv 1
+  let B := LinearEquiv.ofBijective (SingularMayerVietoris.singularHomologyMap g 2) hg
+  let J := PeriodTorusHigherHomology.homeomorphHomologyEquiv e 2
+  let K : ℤ ≃ₗ[ℤ] ℤ := H.symm.trans (B.trans (J.symm.trans H))
+  refine ⟨K 1, NoExotic.IntLinearAutomorphism.apply_one_eq_one_or_neg_one K, ?_⟩
+  apply LinearMap.ext
+  intro a
+  change B a = K 1 • J a
+  apply J.symm.injective
+  rw [map_zsmul, J.symm_apply_apply]
+  apply H.injective
+  rw [map_zsmul]
+  have hh := NoExotic.IntLinearAutomorphism.apply_eq_mul K (H a)
+  simpa only [K, LinearEquiv.trans_apply, LinearEquiv.symm_apply_apply, smul_eq_mul] using hh
+
+private abbrev Smale.PuncturedBall.Space (E : Type*) [NormedAddCommGroup E] (R : ℝ) :=
+  { x : E // x ≠ 0 ∧ ‖x‖ < R }
+
+private def Smale.PuncturedBall.toPunctured {E : Type*} [NormedAddCommGroup E] (R : ℝ) :
+    C(Space E R, Smale.PuncturedRadial.Space E) :=
+  ⟨fun x => ⟨x.val, x.property.1⟩, continuous_subtype_val.subtype_mk _⟩
+
+private def
+    Smale.PuncturedBall.toSphere {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] (R : ℝ) :
+    C(Space E R, Metric.sphere (0 : E) 1) :=
+  Smale.PuncturedRadial.toSphere.comp (toPunctured R)
+
+private def
+    Smale.PuncturedBall.fromSphere {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] (R : ℝ)
+    (r : ℝ) (hr : 0 < r) (hrR : r < R) : C(Metric.sphere (0 : E) 1, Space E R) :=
+  ⟨fun u =>
+    ⟨r • (u : E), smul_ne_zero hr.ne' (ne_zero_of_mem_unit_sphere u),
+      by
+      rw [norm_smul, Real.norm_eq_abs, abs_of_pos hr, mem_sphere_zero_iff_norm.mp u.property,
+        mul_one]
+      exact hrR⟩,
+    (continuous_const.smul continuous_subtype_val).subtype_mk _⟩
+
+private theorem Smale.PuncturedBall.toSphere_fromSphere {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (R : ℝ) (r : ℝ) (hr : 0 < r) (hrR : r < R) (u : Metric.sphere (0 : E) 1) :
+    toSphere R (fromSphere R r hr hrR u) = u :=
+  Smale.PuncturedRadial.toSphere_fromSphere r hr u
+
+private def
+    Smale.PuncturedBall.blendVector {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] (R : ℝ)
+    (r : ℝ) (q : (unitInterval) × Space E R) : E :=
+  Smale.PuncturedRadial.blendVector r (q.1, toPunctured R q.2)
+
+private theorem Smale.PuncturedBall.continuous_blendVector {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (R : ℝ) (r : ℝ) : Continuous (blendVector (E := E) R r) :=
+  (Smale.PuncturedRadial.continuous_blendVector r).comp
+    (continuous_fst.prodMk ((toPunctured R).continuous.comp continuous_snd))
+
+private theorem
+    Smale.PuncturedBall.norm_blendVector {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (R : ℝ) (r : ℝ) (hr : 0 < r) (t : (unitInterval)) (x : Space E R) :
+    ‖blendVector R r (t, x)‖ = (1 - (t : ℝ)) * ‖x.val‖ + (t : ℝ) * r := by
+  have hn : 0 < ‖x.val‖ := norm_pos_iff.mpr x.property.1
+  have hscale : 0 ≤ (1 - (t : ℝ)) + (t : ℝ) * (r / ‖x.val‖) :=
+    add_nonneg (sub_nonneg.mpr t.property.2) (mul_nonneg t.property.1 (div_nonneg hr.le hn.le))
+  change ‖((1 - (t : ℝ)) + (t : ℝ) * (r / ‖x.val‖)) • x.val‖ = _
+  rw [norm_smul, Real.norm_eq_abs, abs_of_nonneg hscale, add_mul, mul_assoc,
+    div_mul_cancel₀ _ hn.ne']
+
+private theorem Smale.PuncturedBall.norm_blendVector_lt {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (R : ℝ) (r : ℝ) (hr : 0 < r) (hrR : r < R) (t : (unitInterval))
+    (x : Space E R) : ‖blendVector R r (t, x)‖ < R := by
+  rw [norm_blendVector R r hr]
+  exact
+    (convex_Iio (𝕜 := ℝ) R) x.property.2 hrR (sub_nonneg.mpr t.property.2) t.property.1
+      (sub_add_cancel 1 (t : ℝ))
+
+private def
+    Smale.PuncturedBall.deformation {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E] (R : ℝ)
+    (r : ℝ) (hr : 0 < r) (hrR : r < R) :
+    (ContinuousMap.id (Space E R)).Homotopy ((fromSphere R r hr hrR).comp (toSphere R))
+    where
+  toFun
+    q :=
+    ⟨blendVector R r q, Smale.PuncturedRadial.blendVector_ne_zero r hr (q.1, toPunctured R q.2),
+      norm_blendVector_lt R r hr hrR q.1 q.2⟩
+  continuous_toFun := (continuous_blendVector R r).subtype_mk _
+  map_zero_left
+    x := by
+    apply Subtype.ext
+    simp [blendVector, Smale.PuncturedRadial.blendVector, toPunctured]
+  map_one_left
+    x := by
+    apply Subtype.ext
+    simp [blendVector, Smale.PuncturedRadial.blendVector, toPunctured, fromSphere, toSphere,
+      Smale.PuncturedRadial.toSphere, Smale.RadialExtension.direction, div_eq_mul_inv, smul_smul]
+
+private def
+    Smale.PuncturedBall.sphereHomotopyEquiv {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (R : ℝ) (r : ℝ) (hr : 0 < r) (hrR : r < R) : Metric.sphere (0 : E) 1 ≃ₕ Space E R
+    where
+  toFun := fromSphere R r hr hrR
+  invFun := toSphere R
+  left_inv := by
+    have h :
+      (toSphere (E := E) R).comp (fromSphere R r hr hrR) =
+        ContinuousMap.id (Metric.sphere (0 : E) 1) :=
+      ContinuousMap.ext (toSphere_fromSphere R r hr hrR)
+    rw [h]
+  right_inv := ⟨(deformation R r hr hrR).symm⟩
+
+private def MorseCancel.nativeBeltTubeSource {E M : Type} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) :
+    C(Metric.sphere (0 : d.chart.PositiveCoordinates) 1 ×
+        Smale.PuncturedBall.Space d.chart.NegativeCoordinates 1,
+      d.chart.beltSource d.radius d.radius_pos)
+    where
+  toFun
+    z :=
+    ⟨(z.1, z.2.val),
+      d.chart.enlarged_closed_belt_subset_source d.radius d.radius_pos d.block
+        ⟨Set.mem_univ _, by
+          rw [mem_closedBall_zero_iff]
+          exact z.2.property.2.le.trans (by norm_num)⟩⟩
+  continuous_toFun :=
+    (continuous_fst.prodMk (continuous_subtype_val.comp continuous_snd)).subtype_mk _
+
+private def
+    MorseCancel.nativeBeltTubeInComplement {E M : Type} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) :
+    C(Metric.sphere (0 : d.chart.PositiveCoordinates) 1 ×
+        Smale.PuncturedBall.Space d.chart.NegativeCoordinates 1,
+      ((Set.range d.surgery.beltSphere)ᶜ : Set d.UpperLevel))
+    where
+  toFun
+    z := by
+    let y := d.chart.beltNeighborhoodHomeomorph d.radius d.radius_pos (nativeBeltTubeSource d z)
+    refine ⟨y.val, ?_⟩
+    intro hy
+    have hz := (d.beltNormal_eq_zero_iff y.property).mpr hy
+    have heq : d.beltNormal y.val = d.radius • z.2.val :=
+      d.chart.beltNeighborhoodHomeomorph_normal d.radius d.radius_pos (nativeBeltTubeSource d z)
+    rw [heq] at hz
+    exact (smul_ne_zero d.radius_pos.ne' z.2.property.1) hz
+  continuous_toFun :=
+    (continuous_subtype_val.comp
+          ((d.chart.beltNeighborhoodHomeomorph d.radius d.radius_pos).continuous.comp
+            (nativeBeltTubeSource d).continuous)).subtype_mk
+      _
+
+private def MorseCancel.nativeBeltTubeMeridian {E M : Type} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (v : Metric.sphere (0 : d.chart.PositiveCoordinates) 1) (r : ℝ) (hr : 0 < r) (hr1 : r < 1) :
+    C(Metric.sphere (0 : d.chart.NegativeCoordinates) 1,
+      ((Set.range d.surgery.beltSphere)ᶜ : Set d.UpperLevel)) :=
+  (nativeBeltTubeInComplement d).comp
+    ((ContinuousMap.const _ v).prodMk (Smale.PuncturedBall.fromSphere 1 r hr hr1))
+
+private theorem MorseCancel.nativeBeltTube_homotopic_meridian {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) {X : Type} [TopologicalSpace X]
+    (a : C(X, Metric.sphere (0 : d.chart.PositiveCoordinates) 1))
+    (b : C(X, Smale.PuncturedBall.Space d.chart.NegativeCoordinates 1))
+    (v : Metric.sphere (0 : d.chart.PositiveCoordinates) 1)
+    (ha : a.Homotopic (ContinuousMap.const _ v)) (r : ℝ) (hr : 0 < r) (hr1 : r < 1) :
+    ((nativeBeltTubeInComplement d).comp (a.prodMk b)).Homotopic
+      ((nativeBeltTubeMeridian d v r hr hr1).comp ((Smale.PuncturedBall.toSphere 1).comp b)) := by
+  let c := (Smale.PuncturedBall.toSphere 1).comp b
+  let b' := (Smale.PuncturedBall.fromSphere 1 r hr hr1).comp c
+  have hb : b.Homotopic b' := by
+    have H := (Smale.PuncturedBall.deformation 1 r hr hr1).compContinuousMap b
+    exact ⟨H⟩
+  have hpair := ha.prodMk hb
+  have hh := (ContinuousMap.Homotopic.refl (nativeBeltTubeInComplement d)).comp hpair
+  have heq :
+    (nativeBeltTubeInComplement d).comp ((ContinuousMap.const _ v).prodMk b') =
+      (nativeBeltTubeMeridian d v r hr hr1).comp c := by
+    apply ContinuousMap.ext
+    intro x
+    rfl
+  rw [heq] at hh
+  exact hh
+
+private theorem MorseCancel.nativeBeltTubeMeridian_eq {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    [IsManifold 𝓘(ℝ, E) ∞ M] (S : AdaptedWindows E f)
+    (q : Smale.ManifoldMorse.criticalPoints E f)
+    (v : Metric.sphere (0 : (S.data q).chart.PositiveCoordinates) 1) (r : ℝ) (hr : 0 < r)
+    (hr1 : r < 1) :
+    nativeBeltTubeMeridian (S.data q) v r hr hr1 =
+      nativeUpperMeridianInComplement S q v ⟨r, hr.le, hr1.le⟩ hr := by
+  apply ContinuousMap.ext
+  intro u
+  apply Subtype.ext
+  apply Subtype.ext
+  change
+    (S.data q).chart.splitChart.symm
+        ((Smale.MorseHandle.ambientMap (S.data q).radius (v.val, r • u.val)).swap) =
+      (S.data q).chart.splitChart.symm (Degree.BeltPassage.upper (S.data q).radius r u.val v.val)
+  congr 1
+  simp only [Smale.MorseHandle.ambientMap, Degree.BeltPassage.upper, Prod.swap, norm_smul,
+    Real.norm_eq_abs, abs_of_pos hr, mem_sphere_zero_iff_norm.mp u.property, mul_one, smul_smul]
+
+private def
+    MorseCancel.parameterBallBoundary {A : Type} [NormedAddCommGroup A] [NormedSpace ℝ A] (r : ℝ)
+    (hr : 0 < r) : C(Metric.sphere (0 : A) 1, Metric.closedBall (0 : A) r)
+    where
+  toFun
+    u := ⟨r • u.val, by rw [mem_closedBall_zero_iff, Smale.LocalDegree.norm_radius_smul r hr u]⟩
+  continuous_toFun := by
+    have h : Continuous (fun u : Metric.sphere (0 : A) 1 => r • u.val) :=
+      continuous_const.smul continuous_subtype_val
+    exact h.subtype_mk _
+
+private def MorseCancel.parameterBallCenter {A : Type} [NormedAddCommGroup A] (r : ℝ) (hr : 0 < r) :
+    Metric.closedBall (0 : A) r :=
+  ⟨0, by simpa using hr.le⟩
+
+private def MorseCancel.parameterBallContraction {A : Type} [NormedAddCommGroup A] [NormedSpace ℝ A]
+    (r : ℝ) (hr : 0 < r) :
+    (parameterBallBoundary (A := A) r hr).Homotopy
+      (ContinuousMap.const _ (parameterBallCenter r hr))
+    where
+  toFun
+    z :=
+    ⟨(1 - (z.1 : ℝ)) • (r • z.2.val),
+      by
+      rw [mem_closedBall_zero_iff, norm_smul, Real.norm_eq_abs,
+        abs_of_nonneg (sub_nonneg.mpr z.1.property.2),
+        Smale.LocalDegree.norm_radius_smul r hr z.2]
+      exact mul_le_of_le_one_left hr.le (by linarith [z.1.property.1])⟩
+  continuous_toFun := by
+    have h :
+      Continuous
+        (fun z : unitInterval × Metric.sphere (0 : A) 1 => (1 - (z.1 : ℝ)) • (r • z.2.val)) :=
+      (continuous_const.sub (continuous_subtype_val.comp continuous_fst)).smul
+        (continuous_const.smul (continuous_subtype_val.comp continuous_snd))
+    exact h.subtype_mk _
+  map_zero_left u := by apply Subtype.ext; simp [parameterBallBoundary]
+  map_one_left u := by apply Subtype.ext; simp [parameterBallCenter]
+
+private theorem MorseCancel.parameterBall_boundary_nullhomotopic {A : Type} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] {Y : Type} [TopologicalSpace Y] (r : ℝ) (hr : 0 < r)
+    (g : C(Metric.closedBall (0 : A) r, Y)) :
+    (g.comp (parameterBallBoundary r hr)).Homotopic
+      (ContinuousMap.const _ (g (parameterBallCenter r hr))) := by
+  have h := (ContinuousMap.Homotopic.refl g).comp ⟨parameterBallContraction r hr⟩
+  exact h
+
+private theorem MorseCancel.normalized_pos_smul {F : Type} [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (r : ℝ) (hr : 0 < r) (x : F) : ‖r • x‖⁻¹ • (r • x) = ‖x‖⁻¹ • x := by
+  rw [norm_smul, Real.norm_eq_abs, abs_of_pos hr, mul_inv_rev, smul_smul, mul_assoc,
+    inv_mul_cancel₀ hr.ne', mul_one]
+
+private def MorseCancel.beltBallCoordinates {E M A : Type} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M} [NormedAddCommGroup A]
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (ε : ℝ)
+    (F : C(Metric.closedBall (0 : A) ε, d.chart.beltTarget d.radius)) :
+    C(Metric.closedBall (0 : A) ε,
+      Metric.sphere (0 : d.chart.PositiveCoordinates) 1 × d.chart.NegativeCoordinates) :=
+  ⟨fun z => ((d.chart.beltNeighborhoodHomeomorph d.radius d.radius_pos).symm (F z)).val,
+    continuous_subtype_val.comp
+      ((d.chart.beltNeighborhoodHomeomorph d.radius d.radius_pos).symm.continuous.comp
+        F.continuous)⟩
+
+private theorem MorseCancel.beltBallCoordinates_normal {E M A : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    [NormedAddCommGroup A] (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (ε : ℝ) (F : C(Metric.closedBall (0 : A) ε, d.chart.beltTarget d.radius))
+    (z : Metric.closedBall (0 : A) ε) :
+    (beltBallCoordinates d ε F z).2 = d.radius⁻¹ • d.beltNormal (F z).val :=
+  rfl
+
+private def
+    MorseCancel.beltBallBoundaryNormal {E M A : Type} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M} [NormedAddCommGroup A]
+    [NormedSpace ℝ A] (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (ε : ℝ) (hε : 0 < ε)
+    (F : C(Metric.closedBall (0 : A) ε, d.chart.beltTarget d.radius))
+    (hsmall : ∀ z, ‖(beltBallCoordinates d ε F z).2‖ < 1)
+    (hne : ∀ u, (beltBallCoordinates d ε F (parameterBallBoundary ε hε u)).2 ≠ 0) :
+    C(Metric.sphere (0 : A) 1, Smale.PuncturedBall.Space d.chart.NegativeCoordinates 1) :=
+  ⟨fun u => ⟨(beltBallCoordinates d ε F (parameterBallBoundary ε hε u)).2, hne u, hsmall _⟩,
+    ((beltBallCoordinates d ε F).continuous.snd.comp
+          (parameterBallBoundary ε hε).continuous).subtype_mk
+      _⟩
+
+private def MorseCancel.beltBallBoundaryInComplement {E M A : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (ε : ℝ) (hε : 0 < ε) (F : C(Metric.closedBall (0 : A) ε, d.chart.beltTarget d.radius))
+    (hsmall : ∀ z, ‖(beltBallCoordinates d ε F z).2‖ < 1)
+    (hne : ∀ u, (beltBallCoordinates d ε F (parameterBallBoundary ε hε u)).2 ≠ 0) :
+    C(Metric.sphere (0 : A) 1, ((Set.range d.surgery.beltSphere)ᶜ : Set d.UpperLevel)) :=
+  (nativeBeltTubeInComplement d).comp
+    (((ContinuousMap.fst.comp (beltBallCoordinates d ε F)).comp
+          (parameterBallBoundary ε hε)).prodMk
+      (beltBallBoundaryNormal d ε hε F hsmall hne))
+
+private theorem MorseCancel.beltBallBoundaryInComplement_coe {E M A : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (ε : ℝ) (hε : 0 < ε) (F : C(Metric.closedBall (0 : A) ε, d.chart.beltTarget d.radius))
+    (hsmall : ∀ z, ‖(beltBallCoordinates d ε F z).2‖ < 1)
+    (hne : ∀ u, (beltBallCoordinates d ε F (parameterBallBoundary ε hε u)).2 ≠ 0)
+    (u : Metric.sphere (0 : A) 1) :
+    (beltBallBoundaryInComplement d ε hε F hsmall hne u).val =
+      (F (parameterBallBoundary ε hε u)).val := by
+  let y := F (parameterBallBoundary ε hε u)
+  let e := d.chart.beltNeighborhoodHomeomorph d.radius d.radius_pos
+  change
+    (e
+          (nativeBeltTubeSource d
+            ((e.symm y).val.1, (beltBallBoundaryNormal d ε hε F hsmall hne u)))).val =
+      y.val
+  have hs :
+    nativeBeltTubeSource d ((e.symm y).val.1, (beltBallBoundaryNormal d ε hε F hsmall hne u)) =
+      e.symm y := by
+    apply Subtype.ext
+    rfl
+  rw [hs, e.apply_symm_apply]
+
+private theorem
+    MorseCancel.beltBallBoundary_homotopic_meridian {E M A : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (ε : ℝ) (hε : 0 < ε) (F : C(Metric.closedBall (0 : A) ε, d.chart.beltTarget d.radius))
+    (hsmall : ∀ z, ‖(beltBallCoordinates d ε F z).2‖ < 1)
+    (hne : ∀ u, (beltBallCoordinates d ε F (parameterBallBoundary ε hε u)).2 ≠ 0) (r : ℝ)
+    (hr : 0 < r) (hr1 : r < 1) :
+    (beltBallBoundaryInComplement d ε hε F hsmall hne).Homotopic
+      ((nativeBeltTubeMeridian d (beltBallCoordinates d ε F (parameterBallCenter ε hε)).1 r hr
+            hr1).comp
+        ((Smale.PuncturedBall.toSphere 1).comp (beltBallBoundaryNormal d ε hε F hsmall hne))) := by
+  let a := ContinuousMap.fst.comp (beltBallCoordinates d ε F)
+  have ha := parameterBall_boundary_nullhomotopic ε hε a
+  exact
+    nativeBeltTube_homotopic_meridian d (a.comp (parameterBallBoundary ε hε))
+      (beltBallBoundaryNormal d ε hε F hsmall hne) (a (parameterBallCenter ε hε)) ha r hr hr1
+
+private theorem MorseCancel.beltBallBoundary_normalized_coe {E M A : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    [NormedAddCommGroup A] [NormedSpace ℝ A] (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (ε : ℝ) (hε : 0 < ε) (F : C(Metric.closedBall (0 : A) ε, d.chart.beltTarget d.radius))
+    (hsmall : ∀ z, ‖(beltBallCoordinates d ε F z).2‖ < 1)
+    (hne : ∀ u, (beltBallCoordinates d ε F (parameterBallBoundary ε hε u)).2 ≠ 0)
+    (u : Metric.sphere (0 : A) 1) :
+    (Smale.PuncturedBall.toSphere 1 (beltBallBoundaryNormal d ε hε F hsmall hne u)).val =
+      ‖d.beltNormal (F (parameterBallBoundary ε hε u)).val‖⁻¹ •
+        d.beltNormal (F (parameterBallBoundary ε hε u)).val := by
+  change
+    ‖d.radius⁻¹ • d.beltNormal (F (parameterBallBoundary ε hε u)).val‖⁻¹ •
+        (d.radius⁻¹ • d.beltNormal (F (parameterBallBoundary ε hε u)).val) =
+      _
+  exact normalized_pos_smul d.radius⁻¹ (inv_pos.mpr d.radius_pos) _
+
+private theorem MorseCancel.normal_boundary_homotopic_native_meridian {E M A : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ}
+    {p : M} [NormedAddCommGroup A] [NormedSpace ℝ A]
+    (d : Smale.ManifoldMorse.MorseSurgeryData E f p) (g : A → d.UpperLevel)
+    {L : A ≃L[ℝ] d.chart.NegativeCoordinates} {s : Set A}
+    (b : Smale.LocalDegree.BoundaryData (d.beltNormal ∘ g) L s) (hc : ContinuousOn g s)
+    (hdomain : ∀ z ∈ s, g z ∈ d.beltNormalDomain)
+    (hsmall : ∀ z ∈ s, ‖d.radius⁻¹ • d.beltNormal (g z)‖ < 1) (r : ℝ) (hr : 0 < r) (hr1 : r < 1) :
+    ∃ J : C(Metric.sphere (0 : A) 1, ((Set.range d.surgery.beltSphere)ᶜ : Set d.UpperLevel)),
+      (∀ u, (J u).val = g (b.radius • u.val)) ∧
+        ∃ v : Metric.sphere (0 : d.chart.PositiveCoordinates) 1,
+          J.Homotopic ((nativeBeltTubeMeridian d v r hr hr1).comp b.normalizedMap) := by
+  let F : C(Metric.closedBall (0 : A) b.radius, d.chart.beltTarget d.radius) :=
+    { toFun := fun z => ⟨g z.val, hdomain z.val (b.ball_subset z.property)⟩
+      continuous_toFun :=
+        (hc.comp_continuous continuous_subtype_val (fun z => b.ball_subset z.property)).subtype_mk
+          _ }
+  have hsmallF : ∀ z, ‖(beltBallCoordinates d b.radius F z).2‖ < 1 := by
+    intro z
+    rw [beltBallCoordinates_normal]
+    exact hsmall z.val (b.ball_subset z.property)
+  have hne :
+    ∀ u,
+      (beltBallCoordinates d b.radius F (parameterBallBoundary b.radius b.radius_pos u)).2 ≠ 0 := by
+    intro u
+    rw [beltBallCoordinates_normal]
+    exact smul_ne_zero (inv_ne_zero d.radius_pos.ne') (b.map u).property
+  let J := beltBallBoundaryInComplement d b.radius b.radius_pos F hsmallF hne
+  have hJ : ∀ u, (J u).val = g (b.radius • u.val) := by
+    intro u
+    exact beltBallBoundaryInComplement_coe d b.radius b.radius_pos F hsmallF hne u
+  let v := (beltBallCoordinates d b.radius F (parameterBallCenter b.radius b.radius_pos)).1
+  have hH := beltBallBoundary_homotopic_meridian d b.radius b.radius_pos F hsmallF hne r hr hr1
+  have heq :
+    (Smale.PuncturedBall.toSphere 1).comp
+        (beltBallBoundaryNormal d b.radius b.radius_pos F hsmallF hne) =
+      b.normalizedMap := by
+    apply ContinuousMap.ext
+    intro u
+    apply Subtype.ext
+    exact beltBallBoundary_normalized_coe d b.radius b.radius_pos F hsmallF hne u
+  rw [heq] at hH
+  exact ⟨J, hJ, v, hH⟩
+
+private theorem
+    MorseCancel.exists_small_native_belt_neighborhood {E M A : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    [NormedAddCommGroup A] (d : Smale.ManifoldMorse.MorseSurgeryData E f p)
+    (G : A → d.UpperLevel) (v : Metric.sphere (0 : d.chart.PositiveCoordinates) 1) {t : Set A}
+    (ht : t ∈ 𝓝 (0 : A)) (hc : ContinuousOn G t) (hcenter : G 0 = d.surgery.beltSphere v) :
+    ∃ s : Set A,
+      s ∈ 𝓝 (0 : A) ∧
+        s ⊆ t ∧
+          ContinuousOn G s ∧
+            (∀ z ∈ s, G z ∈ d.beltNormalDomain) ∧
+              (∀ z ∈ s, ‖d.radius⁻¹ • d.beltNormal (G z)‖ < 1) := by
+  have hG : ContinuousAt G 0 := hc.continuousAt ht
+  have hdomain : G 0 ∈ d.beltNormalDomain := hcenter ▸ d.belt_mem_normalDomain v
+  have hsplit : ContinuousAt d.chart.splitChart (G 0).val :=
+    d.chart.splitChart.contMDiffOn_toFun.continuousOn.continuousAt
+      (d.chart.splitChart.open_source.mem_nhds hdomain)
+  have hGM : ContinuousAt (fun z : A => (G z).val) 0 :=
+    (continuous_subtype_val : Continuous (Subtype.val : d.UpperLevel → M)).continuousAt.comp hG
+  have hsplitG : ContinuousAt (fun z : A => d.chart.splitChart (G z).val) 0 :=
+    ContinuousAt.comp (f := fun z : A => (G z).val) hsplit hGM
+  have hnormal : ContinuousAt (fun z => d.beltNormal (G z)) 0 := by
+    change ContinuousAt (fun z : A => (d.chart.splitChart (G z).val).1) 0
+    exact hsplitG.fst
+  have hsize : ContinuousAt (fun z => ‖d.radius⁻¹ • d.beltNormal (G z)‖) 0 :=
+    (hnormal.const_smul d.radius⁻¹).norm
+  have hzero : ‖d.radius⁻¹ • d.beltNormal (G 0)‖ < 1 := by
+    rw [hcenter, d.beltNormal_belt, smul_zero, norm_zero]
+    norm_num
+  have h₀ : G ⁻¹' d.beltNormalDomain ∈ 𝓝 (0 : A) :=
+    hG.preimage_mem_nhds (d.isOpen_beltNormalDomain.mem_nhds hdomain)
+  have h₁ : {z : A | ‖d.radius⁻¹ • d.beltNormal (G z)‖ < 1} ∈ 𝓝 (0 : A) :=
+    hsize.preimage_mem_nhds (Iio_mem_nhds hzero)
+  let s := t ∩ (G ⁻¹' d.beltNormalDomain ∩ {z : A | ‖d.radius⁻¹ • d.beltNormal (G z)‖ < 1})
+  refine
+    ⟨s, Filter.inter_mem ht (Filter.inter_mem h₀ h₁), Set.inter_subset_left,
+      hc.mono Set.inter_subset_left, ?_, ?_⟩
+  · intro z hz
+    exact hz.2.1
+  · intro z hz
+    exact hz.2.2
+
+private theorem Degree.MorseRearrangement.exists_radius_supported_bump_preparation {E F H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [NormedAddCommGroup F]
+    [NormedSpace ℝ F] [TopologicalSpace H] {J : ModelWithCorners ℝ F H} [TopologicalSpace M]
+    [ChartedSpace H M] [T2Space M] (Φ : PartialDiffeomorph 𝓘(ℝ, E) J E M ∞) {β : E → ℝ}
+    (hβ : ContDiff ℝ ∞ β) (hcompact : HasCompactSupport β) (hsupport : tsupport β ⊆ Φ.source)
+    {C : Set M} (hC : ∀ y ∈ C, y ∉ Φ '' tsupport β) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∀ a : E,
+          ‖a‖ < ε →
+            ∀ e : Diffeomorph J J M M ∞,
+              (∀ y, e y = Smale.SupportedDiffeomorph.bumpFamily Φ β (a, y)) →
+                Nonempty
+                  (Smale.SupportedDiffeomorph.SupportedRelativeIsotopy e (Φ '' tsupport β) C) := by
+  obtain ⟨ε, hε, hsmall⟩ :=
+    Smale.SupportedDiffeomorph.exists_small_supported_bump_isotopy Φ hβ hcompact hsupport
+  refine ⟨ε, hε, ?_⟩
+  intro a ha e he
+  obtain ⟨A, hA, hzero, hdiff, hfix, hterminal⟩ := hsmall a ha
+  have hone : ∀ y, A (1, y) = e y := by
+    intro y
+    rw [he]
+    by_cases hy : y ∈ Φ.target
+    · have hh := hterminal (Φ.symm y) (Φ.map_target' hy)
+      have hpoint : Φ (Φ.symm y) = y := Φ.right_inv' hy
+      rw [hpoint] at hh
+      change A (1, y) = Smale.SupportedDiffeomorph.extendMap Φ (fun x => x + β x • a) y
+      rw [Smale.SupportedDiffeomorph.extendMap_of_mem Φ _ hy]
+      exact hh
+    · have hnot : y ∉ Φ '' tsupport β := by
+        rintro ⟨x, hx, rfl⟩
+        exact hy (Φ.map_source' (hsupport hx))
+      rw [hfix 1 y hnot, Smale.SupportedDiffeomorph.bumpFamily_fixed_outside Φ β a hnot]
+  refine
+    ⟨{  family := A
+        smooth := hA
+        zero := hzero
+        one := hone
+        slices := ?_
+        fixedOutside := hfix
+        fixedOn := fun t y hy => hfix t y (hC y hy) }⟩
+  intro t
+  obtain ⟨d, hd⟩ := hdiff t
+  exact ⟨d, fun y => (hd y).symm⟩
+
+private theorem Degree.MorseRearrangement.ambient_patch_support_compact {G K N X : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace K] {J : ModelWithCorners ℝ G K}
+    [TopologicalSpace N] [ChartedSpace K N] [TopologicalSpace X]
+    (p : Smale.NativeTransversality.Patch J X (N := N)) :
+    IsCompact (p.chart.symm '' tsupport p.cutoff) :=
+  p.cutoff_compact.isCompact.image_of_continuousOn
+    (p.chart.contMDiffOn_invFun.continuousOn.mono p.cutoff_support)
+
+private theorem Degree.MorseRearrangement.exists_ambient_patch_in_open {G K N X : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace K] {J : ModelWithCorners ℝ G K}
+    [TopologicalSpace N] [ChartedSpace K N] [TopologicalSpace X] [FiniteDimensional ℝ G]
+    [J.Boundaryless] [IsManifold J ∞ N] [CompactSpace X] [T2Space X] {f : X → N}
+    (hf : Continuous f) {U : Set N} (hU : IsOpen U) (x : X) (hfxU : f x ∈ U) :
+    ∃ p : Smale.NativeTransversality.Patch J X (N := N),
+      p.Compatible f ∧ x ∈ interior p.core ∧ p.chart.symm '' tsupport p.cutoff ⊆ U := by
+  let c := NoExotic.modelChartPartialDiffeomorph (I := J) (f x)
+  have hcx : f x ∈ c.source := mem_extChartAt_source _
+  let V : Set G := c.target ∩ c.symm ⁻¹' U
+  have hV : IsOpen V := c.contMDiffOn_invFun.continuousOn.isOpen_inter_preimage c.open_target hU
+  have hcv : c (f x) ∈ V :=
+    ⟨c.map_source' hcx, by
+      change c.symm (c (f x)) ∈ U
+      have heq : c.symm (c (f x)) = f x := c.left_inv' hcx
+      rw [heq]
+      exact hfxU⟩
+  obtain ⟨r, hr, hball⟩ := Metric.mem_nhds_iff.mp (hV.mem_nhds hcv)
+  obtain ⟨β, hβ, hsupport, W, hW, hcenter, -, hone⟩ :=
+    LineBundleTransport.exists_smooth_cutoff_near_closed (K := {c (f x)}) (U :=
+      Metric.ball (c (f x)) r) isClosed_singleton Metric.isOpen_ball
+      (Set.singleton_subset_iff.mpr (Metric.mem_ball_self hr))
+  have hcompact : HasCompactSupport β :=
+    (ProperSpace.isCompact_closedBall (c (f x)) r).of_isClosed_subset (isClosed_tsupport β)
+      (hsupport.trans Metric.ball_subset_closedBall)
+  let O : Set N := c.source ∩ c ⁻¹' W
+  have hO : IsOpen O := c.contMDiffOn_toFun.continuousOn.isOpen_inter_preimage c.open_source hW
+  have hfx : f x ∈ O := ⟨hcx, hcenter (Set.mem_singleton _)⟩
+  obtain ⟨C, hC, -, hxC, hCO⟩ :=
+    exists_compact_closed_between (isCompact_singleton (x := x)) (hO.preimage hf)
+      (Set.singleton_subset_iff.mpr hfx)
+  let p : Smale.NativeTransversality.Patch J X (N := N) :=
+    { core := C
+      core_compact := hC
+      chart := c
+      cutoff := β
+      cutoff_smooth := hβ
+      cutoff_compact := hcompact
+      cutoff_support := hsupport.trans (hball.trans Set.inter_subset_left)
+      plateau := O
+      plateau_open := hO
+      plateau_source := Set.inter_subset_left
+      plateau_one := by
+        intro y hy
+        filter_upwards [hW.mem_nhds hy.2] with z hz
+        exact hone hz }
+  refine ⟨p, hCO, hxC (Set.mem_singleton x), ?_⟩
+  rintro y ⟨z, hz, rfl⟩
+  exact (hball (hsupport hz)).2
+
+private theorem
+    Degree.MorseRearrangement.exists_relative_ambient_patch_step {D Z G H H' K X Y N : Type*}
+    [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D] [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup G] [NormedSpace ℝ G]
+    [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H'] [TopologicalSpace K]
+    {I : ModelWithCorners ℝ D H} {I' : ModelWithCorners ℝ Z H'} {J : ModelWithCorners ℝ G K}
+    [I.Boundaryless] [I'.Boundaryless] [J.Boundaryless] [TopologicalSpace X] [ChartedSpace H X]
+    [IsManifold I ∞ X] [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y]
+    [CompactSpace Y] [TopologicalSpace N] [ChartedSpace K N] [IsManifold J ∞ N] [T2Space N]
+    [LindelofSpace (X × Y)] {ι : Type*} [Finite ι]
+    (p : ι → Smale.NativeTransversality.Patch J X (N := N)) (i : ι) {f : X → N} {g : Y → N}
+    (hf : ContMDiff I J ∞ f) (hg : ContMDiff I' J ∞ g) (hcompatible : ∀ j, (p j).Compatible f)
+    (hdim : Module.finrank ℝ D + Module.finrank ℝ Z = Module.finrank ℝ G) {B : Set X}
+    (hB : IsCompact B) (htrans : ∀ x ∈ B, ∀ y, Smale.NativeTransversality.At I I' J f g x y)
+    {C : Set N} (hC : ∀ y ∈ C, y ∉ (p i).chart.symm '' tsupport (p i).cutoff) :
+    ∃ e : Diffeomorph J J N N ∞,
+      (∀ j, (p j).Compatible (e ∘ f)) ∧
+        (∀ x ∈ B ∪ (p i).core, ∀ y, Smale.NativeTransversality.At I I' J (e ∘ f) g x y) ∧
+          Nonempty
+            (Smale.SupportedDiffeomorph.SupportedRelativeIsotopy e
+              ((p i).chart.symm '' tsupport (p i).cutoff) C) := by
+  let A : G × X → N := fun q =>
+    Smale.SupportedDiffeomorph.bumpFamily (p i).chart.symm (p i).cutoff (q.1, f q.2)
+  have hkeep : ∀ᶠ a in 𝓝 (0 : G), ∀ j, (p j).Compatible (fun x => A (a, x)) := by
+    apply Filter.eventually_all.mpr
+    intro j
+    exact
+      Smale.SupportedDiffeomorph.eventually_bumpFamily_maps_compact_into_open (p i).chart.symm
+        (p i).cutoff_smooth (p i).cutoff_compact (p i).cutoff_support hf.continuous
+        (p j).core_compact (p j).plateau_open (hcompatible j)
+  obtain ⟨δ, hδ, -, hsmooth, -⟩ :=
+    Smale.SupportedDiffeomorph.exists_radius_ambient_bumpFamily (p i).chart.symm
+      (p i).cutoff_smooth (p i).cutoff_compact (p i).cutoff_support
+  have hA : ContMDiffOn (𝓘(ℝ, G).prod I) J ∞ A (Metric.ball (0 : G) δ ×ˢ Set.univ) := by
+    intro q hq
+    have hsmall : ‖q.1‖ < δ := by simpa only [Metric.mem_ball, dist_zero_right] using hq.1
+    have hpair :
+      ContMDiffAt (𝓘(ℝ, G).prod I) (𝓘(ℝ, G).prod J) ∞ (fun r : G × X => (r.1, f r.2)) q :=
+      contMDiffAt_fst.prodMk (hf.comp contMDiff_snd).contMDiffAt
+    exact ((hsmooth (q.1, f q.2) hsmall).comp q hpair).contMDiffWithinAt
+  have hzero : (fun x => A (0, x)) = f := by
+    funext x
+    exact Smale.SupportedDiffeomorph.bumpFamily_zero _ _ _
+  have hregular :
+    ∀ᶠ a in 𝓝 (0 : G),
+      ∀ z ∈ B ×ˢ (Set.univ : Set Y),
+        Smale.NativeTransversality.At I I' J (fun x => A (a, x)) g z.1 z.2 := by
+    apply
+      Smale.NativeTransversality.eventually_on_compact Metric.isOpen_ball hA hg hdim
+        (hB.prod isCompact_univ) (Metric.mem_ball_self hδ)
+    intro z hz
+    rw [hzero]
+    exact htrans z.1 hz.1 z.2
+  obtain ⟨ε, hε, hsmall⟩ := Metric.mem_nhds_iff.mp (hkeep.and hregular)
+  obtain ⟨η, hη, hisotopy⟩ :=
+    exists_radius_supported_bump_preparation (p i).chart.symm (p i).cutoff_smooth
+      (p i).cutoff_compact (p i).cutoff_support hC
+  obtain ⟨a, ha, e, he, -, -, hnew⟩ :=
+    Smale.ChartMapPerturbation.exists_ambient_transverse_plateau (p i).chart hf hg
+      (p i).cutoff_smooth (p i).cutoff_compact (p i).cutoff_support hdim (lt_min hε hη)
+  have hgood :=
+    hsmall
+      (show a ∈ Metric.ball (0 : G) ε by
+        simpa only [Metric.mem_ball, dist_zero_right] using (lt_min_iff.mp ha).1)
+  have heq : (fun x => A (a, x)) = e ∘ f := funext (fun x => (he (f x)).symm)
+  refine ⟨e, ?_, ?_, hisotopy a (lt_min_iff.mp ha).2 e he⟩
+  · intro j
+    exact heq ▸ hgood.1 j
+  · intro x hx y
+    rcases hx with hx | hx
+    · exact heq ▸ hgood.2 (x, y) ⟨hx, Set.mem_univ y⟩
+    · intro hxy
+      have hplateau := hcompatible i hx
+      exact hnew x ((p i).plateau_source hplateau) ((p i).plateau_one _ hplateau) y hxy
+
+private def Degree.MorseRearrangement.compose_supported_ambient_isotopies {G K N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace K] {J : ModelWithCorners ℝ G K}
+    [TopologicalSpace N] [ChartedSpace K N] {e d : Diffeomorph J J N N ∞} {K₁ K₂ C : Set N}
+    (A : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy e K₁ C)
+    (B : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy d K₂ C) :
+    Smale.SupportedDiffeomorph.SupportedRelativeIsotopy (e.trans d) (K₁ ∪ K₂) C
+    where
+  family := fun p => B.family (p.1, A.family p)
+  smooth := B.smooth.comp (contMDiff_fst.prodMk A.smooth)
+  zero := fun x => by rw [A.zero, B.zero]
+  one := fun x => by change B.family (1, A.family (1, x)) = d (e x); rw [A.one, B.one]
+  slices := by
+    intro t
+    obtain ⟨d₁, hd₁⟩ := A.slices t
+    obtain ⟨d₂, hd₂⟩ := B.slices t
+    refine ⟨d₁.trans d₂, ?_⟩
+    intro x
+    change d₂ (d₁ x) = B.family (t, A.family (t, x))
+    rw [hd₁, hd₂]
+  fixedOutside := by
+    intro t x hx
+    rw [A.fixedOutside t x (fun h => hx (Or.inl h)), B.fixedOutside t x (fun h => hx (Or.inr h))]
+  fixedOn := by
+    intro t x hx
+    rw [A.fixedOn t x hx, B.fixedOn t x hx]
+
+private theorem Degree.MorseRearrangement.exists_finite_relative_patch_diffeomorph
+    {D Z G H H' K X Y N : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    [TopologicalSpace K] {I : ModelWithCorners ℝ D H} {I' : ModelWithCorners ℝ Z H'}
+    {J : ModelWithCorners ℝ G K} [I.Boundaryless] [I'.Boundaryless] [J.Boundaryless]
+    [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X] [TopologicalSpace Y]
+    [ChartedSpace H' Y] [IsManifold I' ∞ Y] [CompactSpace Y] [TopologicalSpace N]
+    [ChartedSpace K N] [IsManifold J ∞ N] [T2Space N] [LindelofSpace (X × Y)] {ι : Type*}
+    [Finite ι] (p : ι → Smale.NativeTransversality.Patch J X (N := N)) {f : X → N} {g : Y → N}
+    (hf : ContMDiff I J ∞ f) (hg : ContMDiff I' J ∞ g) (hcompatible : ∀ j, (p j).Compatible f)
+    (hdim : Module.finrank ℝ D + Module.finrank ℝ Z = Module.finrank ℝ G) {U : Set N}
+    (hsupport : ∀ j, (p j).chart.symm '' tsupport (p j).cutoff ⊆ U) (s : Finset ι) :
+    ∃ (e : Diffeomorph J J N N ∞) (C : Set N),
+      IsCompact C ∧
+        C ⊆ U ∧
+          Nonempty (Smale.SupportedDiffeomorph.SupportedRelativeIsotopy e C Uᶜ) ∧
+            (∀ j, (p j).Compatible (e ∘ f)) ∧
+              ∀ j ∈ s,
+                ∀ x ∈ (p j).core, ∀ y, Smale.NativeTransversality.At I I' J (e ∘ f) g x y := by
+  classical
+    induction s using Finset.induction_on with
+  |
+    empty =>
+    let A : Smale.SupportedDiffeomorph.SupportedRelativeIsotopy (Diffeomorph.refl J N ∞) ∅ Uᶜ :=
+      { family := Prod.snd
+        smooth := contMDiff_snd
+        zero := fun _ => rfl
+        one := fun _ => rfl
+        slices := fun _ => ⟨Diffeomorph.refl J N ∞, fun _ => rfl⟩
+        fixedOutside := fun _ _ _ => rfl
+        fixedOn := fun _ _ _ => rfl }
+    refine ⟨Diffeomorph.refl J N ∞, ∅, isCompact_empty, Set.empty_subset _, ⟨A⟩, hcompatible, ?_⟩
+    intro j hj
+    simp at hj
+  | @insert i s _ ih =>
+    obtain ⟨e₁, C₁, hC₁, hC₁U, ⟨A₁⟩, hc₁, ht₁⟩ := ih
+    let B : Set X := ⋃ j ∈ s, (p j).core
+    have hB : IsCompact B := s.isCompact_biUnion (fun j _ => (p j).core_compact)
+    have htrans : ∀ x ∈ B, ∀ y, Smale.NativeTransversality.At I I' J (e₁ ∘ f) g x y := by
+      intro x hx y
+      obtain ⟨j, hj, hxj⟩ := Set.mem_iUnion₂.mp hx
+      exact ht₁ j hj x hxj y
+    obtain ⟨e₂, hc₂, ht₂, ⟨A₂⟩⟩ :=
+      exists_relative_ambient_patch_step (C := Uᶜ) p i (e₁.contMDiff.comp hf) hg hc₁ hdim hB
+        htrans (fun y hy hys => hy (hsupport i hys))
+    refine
+      ⟨e₁.trans e₂, C₁ ∪ ((p i).chart.symm '' tsupport (p i).cutoff),
+        hC₁.union (ambient_patch_support_compact (p i)), Set.union_subset hC₁U (hsupport i),
+        ⟨compose_supported_ambient_isotopies A₁ A₂⟩, hc₂, ?_⟩
+    intro j hj x hx y
+    rcases Finset.mem_insert.mp hj with rfl | hjs
+    · exact ht₂ x (Or.inr hx) y
+    · exact ht₂ x (Or.inl (Set.mem_iUnion₂.mpr ⟨j, hjs, hx⟩)) y
+
+private theorem Degree.MorseRearrangement.exists_supported_ambient_transverse_in_open
+    {D Z G H H' K X Y N : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    [TopologicalSpace K] {I : ModelWithCorners ℝ D H} {I' : ModelWithCorners ℝ Z H'}
+    {J : ModelWithCorners ℝ G K} [I.Boundaryless] [I'.Boundaryless] [J.Boundaryless]
+    [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X] [TopologicalSpace Y]
+    [ChartedSpace H' Y] [IsManifold I' ∞ Y] [CompactSpace Y] [TopologicalSpace N]
+    [ChartedSpace K N] [IsManifold J ∞ N] [T2Space N] [CompactSpace X] [T2Space X] {f : X → N}
+    {g : Y → N} (hf : ContMDiff I J ∞ f) (hg : ContMDiff I' J ∞ g)
+    (hdim : Module.finrank ℝ D + Module.finrank ℝ Z = Module.finrank ℝ G) {U : Set N}
+    (hU : IsOpen U) (hfU : Set.range f ⊆ U) :
+    ∃ (e : Diffeomorph J J N N ∞) (C : Set N),
+      IsCompact C ∧
+        C ⊆ U ∧
+          Nonempty (Smale.SupportedDiffeomorph.SupportedRelativeIsotopy e C Uᶜ) ∧
+            ∀ x y, Smale.NativeTransversality.At I I' J (e ∘ f) g x y := by
+  classical
+  choose p hp hx hs using fun x : X =>
+    exists_ambient_patch_in_open (J := J) hf.continuous hU x (hfU (Set.mem_range_self x))
+  have hcover : (Set.univ : Set X) ⊆ ⋃ x : X, interior (p x).core := by
+    intro x _
+    exact Set.mem_iUnion.mpr ⟨x, hx x⟩
+  obtain ⟨s, hscover⟩ :=
+    isCompact_univ.elim_finite_subcover (fun x : X => interior (p x).core)
+      (fun _ => isOpen_interior) hcover
+  obtain ⟨e, C, hC, hCU, hIso, -, ht⟩ :=
+    exists_finite_relative_patch_diffeomorph (fun i : s => p i.1) hf hg (fun i => hp i.1) hdim
+      (fun i => hs i.1) Finset.univ
+  refine ⟨e, C, hC, hCU, hIso, ?_⟩
+  intro x y
+  obtain ⟨i, hi, hxi⟩ := Set.mem_iUnion₂.mp (hscover (Set.mem_univ x))
+  exact ht ⟨i, hi⟩ (Finset.mem_univ _) x (interior_subset hxi) y
+
+private theorem Degree.MorseRearrangement.exists_supported_ambient_disjoint_in_open
+    {D Z G H H' K X Y N : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    [TopologicalSpace K] {I : ModelWithCorners ℝ D H} {I' : ModelWithCorners ℝ Z H'}
+    {J : ModelWithCorners ℝ G K} [I.Boundaryless] [I'.Boundaryless] [J.Boundaryless]
+    [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X] [CompactSpace X] [T2Space X]
+    [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y] [CompactSpace Y]
+    [TopologicalSpace N] [ChartedSpace K N] [IsManifold J ∞ N] [T2Space N] {f : X → N} {g : Y → N}
+    (hf : ContMDiff I J ∞ f) (hg : ContMDiff I' J ∞ g)
+    (hdim : Module.finrank ℝ D + Module.finrank ℝ Z < Module.finrank ℝ G) {U : Set N}
+    (hU : IsOpen U) (hfU : Set.range f ⊆ U) :
+    ∃ (e : Diffeomorph J J N N ∞) (C : Set N),
+      IsCompact C ∧
+        C ⊆ U ∧
+          Nonempty (Smale.SupportedDiffeomorph.SupportedRelativeIsotopy e C Uᶜ) ∧
+            Disjoint (Set.range (e ∘ f)) (Set.range g) := by
+  classical
+  let d := Module.finrank ℝ G - (Module.finrank ℝ D + Module.finrank ℝ Z)
+  let f' : X × Smale.Hemisphere.Sphere d → N := f ∘ Prod.fst
+  have hf' : ContMDiff (I.prod (𝓡 d)) J ∞ f' := hf.comp contMDiff_fst
+  have hdim' :
+    Module.finrank ℝ (D × EuclideanSpace ℝ (Fin d)) + Module.finrank ℝ Z = Module.finrank ℝ G := by
+    simp only [Module.finrank_prod, finrank_euclideanSpace, Fintype.card_fin]
+    dsimp [d]
+    omega
+  have hf'U : Set.range f' ⊆ U := by
+    rintro _ ⟨x, rfl⟩
+    exact hfU (Set.mem_range_self x.1)
+  obtain ⟨e, C, hC, hCU, hIso, ht⟩ :=
+    exists_supported_ambient_transverse_in_open hf' hg hdim' hU hf'U
+  have htrans : ∀ x y, Smale.NativeTransversality.At I I' J (e ∘ f) g x y := by
+    intro x y
+    let w : Smale.Hemisphere.Sphere d := Smale.Hemisphere.point Bool.true ⟨0, by simp []⟩
+    apply
+      native_transverse_of_ignored_factor (I'' := 𝓡 d) w
+        ((e.contMDiff.comp hf).mdifferentiable (by simp) x)
+    exact ht (x, w) y
+  exact ⟨e, C, hC, hCU, hIso, disjoint_ranges_of_native_transverse_dimension htrans hdim⟩
+
+private theorem Degree.MorseRearrangement.exists_supported_ambient_disjoint_fixing_closed
+    {D Z G H H' K X Y N : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    [TopologicalSpace K] {I : ModelWithCorners ℝ D H} {I' : ModelWithCorners ℝ Z H'}
+    {J : ModelWithCorners ℝ G K} [I.Boundaryless] [I'.Boundaryless] [J.Boundaryless]
+    [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X] [CompactSpace X] [T2Space X]
+    [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y] [CompactSpace Y]
+    [TopologicalSpace N] [ChartedSpace K N] [IsManifold J ∞ N] [T2Space N] {f : X → N} {g : Y → N}
+    (hf : ContMDiff I J ∞ f) (hg : ContMDiff I' J ∞ g)
+    (hdim : Module.finrank ℝ D + Module.finrank ℝ Z < Module.finrank ℝ G) {C : Set N}
+    (hC : IsClosed C) (hfC : Disjoint (Set.range f) C) :
+    ∃ (e : Diffeomorph J J N N ∞) (K : Set N),
+      IsCompact K ∧
+        K ⊆ Cᶜ ∧
+          Nonempty (Smale.SupportedDiffeomorph.SupportedRelativeIsotopy e K C) ∧
+            Disjoint (Set.range (e ∘ f)) (Set.range g) := by
+  have hfU : Set.range f ⊆ Cᶜ := fun _ hx hy => Set.disjoint_left.mp hfC hx hy
+  obtain ⟨e, K, hK, hKU, hIso, hdisj⟩ :=
+    exists_supported_ambient_disjoint_in_open hf hg hdim hC.isOpen_compl hfU
+  refine ⟨e, K, hK, hKU, ?_, hdisj⟩
+  simpa only [compl_compl] using hIso
+
+private def
+    Degree.MorseRearrangement.otherSheetImages {ι X N : Type*} (a : ι → X → N) (i : ι) : Set N :=
+  ⋃ j : { j : ι // j ≠ i }, Set.range (a j.val)
+
+private theorem
+    Degree.MorseRearrangement.mem_otherSheetImages {ι X N : Type*} (a : ι → X → N) (i j : ι)
+    (hji : j ≠ i) (x : X) : a j x ∈ otherSheetImages a i :=
+  Set.mem_iUnion.mpr ⟨⟨j, hji⟩, Set.mem_range_self x⟩
+
+private def Degree.MorseRearrangement.sheetSum (X : Type) : ℕ → Type
+  | 0 => PEmpty
+  | n + 1 => X ⊕ sheetSum X n
+
+private instance Degree.MorseRearrangement.sheetSumTopology {X : Type} [TopologicalSpace X] :
+    (n : ℕ) → TopologicalSpace (sheetSum X n)
+  | 0 => inferInstanceAs (TopologicalSpace PEmpty)
+  | n + 1 =>
+    let _ := sheetSumTopology (X := X) n
+    inferInstanceAs (TopologicalSpace (X ⊕ sheetSum X n))
+
+private instance Degree.MorseRearrangement.sheetSumCompact {X : Type} [TopologicalSpace X]
+    [CompactSpace X] : (n : ℕ) → CompactSpace (sheetSum X n)
+  | 0 => inferInstanceAs (CompactSpace PEmpty)
+  | n + 1 =>
+    let _ := sheetSumCompact (X := X) n
+    inferInstanceAs (CompactSpace (X ⊕ sheetSum X n))
+
+private instance Degree.MorseRearrangement.sheetSumT2 {X : Type} [TopologicalSpace X] [T2Space X] :
+    (n : ℕ) → T2Space (sheetSum X n)
+  | 0 => inferInstanceAs (T2Space PEmpty)
+  | n + 1 =>
+    let _ := sheetSumT2 (X := X) n
+    inferInstanceAs (T2Space (X ⊕ sheetSum X n))
+
+private instance Degree.MorseRearrangement.sheetSumSecondCountable {X : Type} [TopologicalSpace X]
+    [SecondCountableTopology X] : (n : ℕ) → SecondCountableTopology (sheetSum X n)
+  | 0 => inferInstanceAs (SecondCountableTopology PEmpty)
+  | n + 1 =>
+    let _ := sheetSumSecondCountable (X := X) n
+    inferInstanceAs (SecondCountableTopology (X ⊕ sheetSum X n))
+
+private instance
+    Degree.MorseRearrangement.sheetSumChartedSpace {X : Type} [TopologicalSpace X] {H : Type}
+    [TopologicalSpace H] [ChartedSpace H X] : (n : ℕ) → ChartedSpace H (sheetSum X n)
+  | 0 => ChartedSpace.empty H PEmpty
+  | n + 1 =>
+    let _ := sheetSumChartedSpace (X := X) (H := H) n
+    inferInstanceAs (ChartedSpace H (X ⊕ sheetSum X n))
+
+private instance
+    Degree.MorseRearrangement.sheetSumIsManifold {X : Type} [TopologicalSpace X] {E H : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [ChartedSpace H X] [IsManifold I ∞ X] : (n : ℕ) → IsManifold I ∞ (sheetSum X n)
+  | 0 =>
+    let _ : ChartedSpace H PEmpty := sheetSumChartedSpace (X := X) 0
+    inferInstanceAs (IsManifold I ∞ PEmpty)
+  | n + 1 =>
+    let _ := sheetSumIsManifold (X := X) (I := I) n
+    inferInstanceAs (IsManifold I ∞ (X ⊕ sheetSum X n))
+
+private def Degree.MorseRearrangement.sheetSumMap {X : Type} {N : Type} :
+    (n : ℕ) → (Fin n → X → N) → sheetSum X n → N
+  | 0, _, x => x.elim
+  | n + 1, a, x => Sum.elim (a 0) (sheetSumMap n (fun i => a i.succ)) x
+
+private theorem
+    Degree.MorseRearrangement.range_sheetSumMap {X : Type} {N : Type}
+    (n : ℕ) (a : Fin n → X → N) : Set.range (sheetSumMap n a) = ⋃ i, Set.range (a i) := by
+  induction n with
+  | zero =>
+    ext y
+    simp only [Set.mem_range, Set.mem_iUnion]
+    constructor
+    · rintro ⟨x, _⟩
+      exact x.elim
+    · rintro ⟨i, _⟩
+      exact Fin.elim0 i
+  | succ n ih =>
+    ext y
+    constructor
+    · rintro ⟨x, hx⟩
+      rcases x with x | x
+      · exact Set.mem_iUnion.mpr ⟨0, ⟨x, hx⟩⟩
+      · have hy : y ∈ Set.range (sheetSumMap n (fun i => a i.succ)) := ⟨x, hx⟩
+        rw [ih] at hy
+        obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hy
+        exact Set.mem_iUnion.mpr ⟨i.succ, hi⟩
+    · intro hy
+      obtain ⟨i, x, hx⟩ := Set.mem_iUnion.mp hy
+      cases i using Fin.cases with
+      | zero => exact ⟨Sum.inl x, hx⟩
+      | succ
+        i =>
+        have hy' : y ∈ ⋃ i : Fin n, Set.range (a i.succ) := Set.mem_iUnion.mpr ⟨i, ⟨x, hx⟩⟩
+        rw [← ih] at hy'
+        obtain ⟨z, hz⟩ := hy'
+        exact ⟨Sum.inr z, hz⟩
+
+private theorem Degree.MorseRearrangement.contMDiff_sheetSumMap {X : Type} [TopologicalSpace X]
+    {E H : Type} [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H]
+    {I : ModelWithCorners ℝ E H} [ChartedSpace H X] {G K N : Type} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace K] {J : ModelWithCorners ℝ G K} [TopologicalSpace N]
+    [ChartedSpace K N] (n : ℕ) (a : Fin n → X → N) (ha : ∀ i, ContMDiff I J ∞ (a i)) :
+    ContMDiff I J ∞ (sheetSumMap n a) := by
+  induction n with
+  | zero => intro x; exact x.elim
+  | succ n ih => exact (ha 0).sumElim (ih (fun i => a i.succ) (fun i => ha i.succ))
+
+private theorem Degree.MorseRearrangement.exists_sheetSumMap_for_finite_family {X : Type}
+    [TopologicalSpace X] {E H : Type} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [ChartedSpace H X] {G K N : Type}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace K] {J : ModelWithCorners ℝ G K}
+    [TopologicalSpace N] [ChartedSpace K N] {ι : Type} [Finite ι] (a : ι → X → N)
+    (ha : ∀ i, ContMDiff I J ∞ (a i)) :
+    ∃ (n : ℕ) (b : sheetSum X n → N), ContMDiff I J ∞ b ∧ Set.range b = ⋃ i, Set.range (a i) := by
+  classical
+  let _ : Fintype ι := Fintype.ofFinite ι
+  let e := Fintype.equivFin ι
+  let a' : Fin (Fintype.card ι) → X → N := fun j => a (e.symm j)
+  refine
+    ⟨Fintype.card ι, sheetSumMap (Fintype.card ι) a',
+      contMDiff_sheetSumMap _ a' (fun j => ha (e.symm j)), ?_⟩
+  rw [range_sheetSumMap]
+  ext y
+  constructor
+  · intro hy
+    obtain ⟨j, hj⟩ := Set.mem_iUnion.mp hy
+    exact Set.mem_iUnion.mpr ⟨e.symm j, hj⟩
+  · intro hy
+    obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hy
+    refine Set.mem_iUnion.mpr ⟨e i, ?_⟩
+    simpa only [a', e.symm_apply_apply] using hi
+
+private theorem
+    Degree.FlowSuspension.exists_relative_regular_level_isotopy_realization {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun y => (⟨y, V y⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hdesc : ∀ y, y ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f y (V y) < 0)
+    (F : Flow ℝ M) (hF : ∀ y, IsMIntegralCurve (fun t => F t y) V) {a b c : ℝ} (ha : a < c)
+    (hb : c < b) (hband : ∀ y, f y ∈ Set.Icc a b → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hreg : ∀ y, f y = c → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (z : { y : M // f y = c }) :
+    let _ := Smale.RegularLevel.chartedSpace hf hreg
+    ∀
+      (D :
+        Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+          { y : M // f y = c } { y : M // f y = c } ∞)
+      (K T : Set { y : M // f y = c }),
+      IsCompact K →
+        Smale.SupportedDiffeomorph.SupportedRelativeIsotopy D K T →
+          ∃ (r : ℝ) (C : Set M) (W V' : (y : M) → TangentSpace 𝓘(ℝ, E) y) (H G : Flow ℝ M),
+            0 < r ∧
+              r < c - a ∧
+                IsCompact C ∧
+                  C ⊆ f ⁻¹' Set.Ioo a b ∧
+                    ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞
+                        (fun y => (⟨y, W y⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+                      (∀ y, IsMIntegralCurve (fun t => H t y) W) ∧
+                        (∀ y,
+                            Set.range (fun t => H t y) = Set.range (fun t => F t y) ∧
+                              (∀ p,
+                                  Filter.Tendsto (fun t => H t y) Filter.atTop (𝓝 p) ↔
+                                    Filter.Tendsto (fun t => F t y) Filter.atTop (𝓝 p)) ∧
+                                ∀ p,
+                                  Filter.Tendsto (fun t => H t y) Filter.atBot (𝓝 p) ↔
+                                    Filter.Tendsto (fun t => F t y) Filter.atBot (𝓝 p)) ∧
+                          ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞
+                              (fun y => (⟨y, V' y⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+                            (∀ y, IsMIntegralCurve (fun t => G t y) V') ∧
+                              (∀ y, V' y = 0 ↔ V y = 0) ∧
+                                (∀ y,
+                                    y ∉ Smale.ManifoldMorse.criticalPoints E f →
+                                      mvfderiv 𝓘(ℝ, E) f y (V' y) < 0) ∧
+                                  (∀ y ∈ Smale.ManifoldMorse.criticalPoints E f,
+                                      ∀ᶠ x in 𝓝 y, V' x = V x) ∧
+                                    (∀ y ∉ C, ∀ᶠ x in 𝓝 y, V' x = W x) ∧
+                                      (∀ x : { y : M // f y = c }, G 1 x = H 1 (D x)) ∧
+                                        (∀ x : { y : M // f y = c }, f (H 1 x) = c - r) ∧
+                                          (∀ x : { y : M // f y = c },
+                                              ∀ t : ℝ, t ≤ 0 → G t x = H t x) ∧
+                                            (∀ x : { y : M // f y = c },
+                                                ∀ t : ℝ, 0 ≤ t → G t (H 1 x) = H t (H 1 x)) ∧
+                                              ∀ x ∈ T, ∀ t : ℝ, G t x = H t x := by
+  let _ := Smale.RegularLevel.chartedSpace hf hreg
+  let _ := Smale.RegularLevel.isManifold hf hreg
+  dsimp only
+  intro D K T hK I
+  obtain
+    ⟨r, W, H, A, hr, hrbound, hW, hH, hWzero, hWneg, hWgerm, hgeometry, hsource, -, hformula,
+      hheight, hmodel⟩ :=
+    Degree.FlowTimeChange.exists_normalized_whole_level_cylinder hf hV hdesc F hF ha hb hband hreg
+      z
+  obtain
+    ⟨C, V', G, Ψ, hC, hCsub, hV', hG, hzero, hneg, hgerm, -, -, hfull, hend, hfixed, -, hleft,
+      hright, -⟩ :=
+    exists_native_whole_level_holonomy A hsource hf hr (fun p hp => hheight p ⟨hp.1.le, hp.2.le⟩)
+      W hW hmodel H hH D hK I
+  have hCband : C ⊆ f ⁻¹' Set.Ioo a b := by
+    intro y hy
+    have hh := (hCsub hy).2
+    change f y ∈ Set.Ioo (c - r) c at hh
+    exact ⟨by linarith [hh.1], lt_trans hh.2 hb⟩
+  have hcritical (y : M) (hy : y ∈ Smale.ManifoldMorse.criticalPoints E f) :
+    ∀ᶠ x in 𝓝 y, V' x = V x := by
+    have hout : y ∉ C := fun hc => hband y ⟨(hCband hc).1.le, (hCband hc).2.le⟩ hy
+    filter_upwards [hgerm y hout, hWgerm y hy] with x hx hx'
+    exact hx.trans hx'
+  obtain ⟨htailLeft, htailRight⟩ :=
+    native_whole_level_exterior_tails A Subtype.val H G hformula D Ψ hleft hright hfull
+  have hA0 (x : { y : M // f y = c }) : A (x, 0) = (x : M) := by rw [hformula, H.map_zero_apply]
+  have hA1 (x : { y : M // f y = c }) : A (x, 1) = H 1 x := hformula (x, 1)
+  refine
+    ⟨r, C, W, V', H, G, hr, hrbound, hC, hCband, hW, hH, hgeometry, hV', hG, fun y =>
+      (hzero y).trans (hWzero y), fun y hy => hneg y (hWneg y hy), hcritical, hgerm, ?_, ?_, ?_,
+      ?_, ?_⟩
+  · intro x
+    rw [← hA0 x, hend, hA1]
+  · intro x
+    have hh := hheight (x, 1) (show (1 : ℝ) ∈ Set.Icc 0 1 by constructor <;> norm_num)
+    rw [hA1, mul_one] at hh
+    exact hh
+  · intro x t ht
+    simpa only [hA0] using htailLeft x t ht
+  · intro x t ht
+    simpa only [hA1] using htailRight x t ht
+  · intro x hx t
+    have hh := hfixed x hx 0 t
+    rw [hA0, zero_add, hformula] at hh
+    exact hh
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    MorseCancel.exists_morseSurgeryData_of_field_germ_lt {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hfinite : (Smale.ManifoldMorse.criticalPoints E f).Finite)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0)
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p)
+    (hunique : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, f x = f p → x = p)
+    (heq : ∀ᶠ x in 𝓝 p, V x = c.descentField x) {ε : ℝ} (hε : 0 < ε) :
+    ∃ d : Smale.ManifoldMorse.MorseSurgeryData E f p,
+      d.radius < ε ∧
+        d.chart = c ∧
+          (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f,
+              f x ∈ Set.Icc (f p - d.radius ^ 2) (f p + d.radius ^ 2) → x = p) ∧
+            ∀ z,
+              z ∈
+                  Metric.closedBall (0 : d.chart.NegativeCoordinates) (2 * d.radius) ×ˢ
+                    Metric.closedBall (0 : d.chart.PositiveCoordinates) (2 * d.radius) →
+                ∀ᶠ x in 𝓝 (d.chart.splitChart.symm z), V x = d.chart.descentField x := by
+  obtain ⟨ρ, hρ, hρε, W, hW, -, heqW, hblockW, hband⟩ :=
+    c.exists_isolated_fieldCompatibleBlock_lt hfinite hunique V heq hε
+  have hblock :
+    Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+        Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) ⊆
+      c.splitChart.target :=
+    fun z hz => (hblockW hz).1
+  have hmodel :
+    ∀ z,
+      z ∈
+          Metric.closedBall (0 : c.NegativeCoordinates) (2 * ρ) ×ˢ
+            Metric.closedBall (0 : c.PositiveCoordinates) (2 * ρ) →
+        ∀ᶠ x in 𝓝 (c.splitChart.symm z), V x = c.descentField x := by
+    intro z hz
+    filter_upwards [hW.mem_nhds (hblockW hz).2] with x hx
+    exact heqW x hx
+  have hagreement :
+    ∀ x ∈ Set.range (c.attachingHandleMap ρ hρ hblock), ∀ᶠ y in 𝓝 x, V y = c.descentField y := by
+    rintro _ ⟨z, rfl⟩
+    exact hmodel _ (Smale.MorseHandle.modelMap_mem_product hρ z)
+  obtain ⟨e, hfront, hfixed, horbit⟩ :=
+    c.exists_attachingUnionHomeomorph_with_level_and_orbits hf hV hzero hdesc F hF ρ hρ hblock
+      hagreement hband
+  have hregular (b : ℝ) (hb : b ∈ Set.Icc (f p - ρ ^ 2) (f p + ρ ^ 2)) (hne : b ≠ f p) (x : M)
+    (hx : f x = b) : x ∉ Smale.ManifoldMorse.criticalPoints E f := by
+    intro hcrit
+    exact hne (hx.symm.trans (congrArg f (hband x hcrit (hx ▸ hb))))
+  have hlower : ∀ x, f x = f p - ρ ^ 2 → x ∉ Smale.ManifoldMorse.criticalPoints E f :=
+    hregular _ ⟨le_rfl, by linarith [sq_nonneg ρ]⟩ (by nlinarith [sq_pos_of_pos hρ])
+  have hupper : ∀ x, f x = f p + ρ ^ 2 → x ∉ Smale.ManifoldMorse.criticalPoints E f :=
+    hregular _ ⟨by linarith [sq_nonneg ρ], le_rfl⟩ (by nlinarith [sq_pos_of_pos hρ])
+  have hbottom : ∀ x, f x = f p - ρ ^ 2 → ∀ t : ℝ, 0 < t → f (F t x) < f p - ρ ^ 2 := by
+    intro x hx t ht
+    have hh :=
+      Smale.FlowConstruction.strictAnti_flow_height hf (hV.of_le (by simp)) F hF hzero hdesc
+        (hlower x hx) ht
+    simpa only [F.map_zero_apply, hx] using hh
+  have hlevel :=
+    Smale.FlowConstruction.frontier_sublevel_eq_of_strict_flow hf.continuous F
+      (Smale.FlowConstruction.antitone_flow_height hf F hF hzero hdesc) hbottom
+  have horbits :=
+    c.followsModelBoundaryOrbits_of_flow (hV.of_le (by simp)) F hF ρ hρ hblock (e := e) (horbit :=
+      horbit) hmodel
+  exact
+    ⟨{  radius := ρ
+        radius_pos := hρ
+        chart := c
+        block := hblock
+        attachmentHomeomorph := e
+        attachment_frontier := hfront
+        attachment_fixed := hfixed
+        attachment_model_orbits := horbits
+        surgery := c.levelSurgeryBoundaryPair hf.continuous ρ hρ hblock hlevel e hfront
+        oldExterior_eq := fun _ => rfl
+        newExterior_eq := fun _ => rfl
+        oldPiece_eq := fun _ => rfl
+        newPiece_eq := fun _ => rfl
+        belt_eq := c.beltSphere_eq_beltCoreMap hf.continuous ρ hρ hblock hlevel e hfront hfixed
+        lower_regular := hlower
+        upper_regular := hupper }, hρε, rfl, hband, hmodel⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_adapted_windows_with_prescribed_flow {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f))
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0)
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (c :
+      ∀ p : Smale.ManifoldMorse.criticalPoints E f,
+        Smale.ManifoldMorse.SignedMorseChart (E := E) f p.val)
+    (hmodel :
+      ∀ p : Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ x in 𝓝 p.val, V x = (c p).descentField x) :
+    ∃ S : AdaptedWindows E f, S.field = V ∧ S.flow = F ∧ ∀ p, (S.data p).chart = c p := by
+  have hfinite := Smale.ManifoldMorse.finite_criticalPoints hf hm
+  obtain ⟨r, hr, hgap⟩ := Smale.ManifoldMorse.exists_separated_value_radii hfinite hinj
+  have hex (p : Smale.ManifoldMorse.criticalPoints E f) :=
+    exists_morseSurgeryData_of_field_germ_lt hf hfinite hV F hF hzero hdesc (c p)
+      (fun x hx hfx => hinj hx p.property hfx) (hmodel p) (hr p)
+  choose d hd hchart hisolated hgerm using hex
+  have hseparated (p q : Smale.ManifoldMorse.criticalPoints E f) (hpq : f p < f q) :
+    f p + (d p).radius ^ 2 < f q - (d q).radius ^ 2 := by
+    have hp : (d p).radius ^ 2 < (r p) ^ 2 := by
+      nlinarith [mul_pos (sub_pos.mpr (hd p)) (add_pos (hr p) (d p).radius_pos)]
+    have hq : (d q).radius ^ 2 < (r q) ^ 2 := by
+      nlinarith [mul_pos (sub_pos.mpr (hd q)) (add_pos (hr q) (d q).radius_pos)]
+    linarith [hgap p q hpq]
+  exact
+    ⟨{  finite := hfinite
+        distinct := hinj
+        data := d
+        isolated := hisolated
+        separated := hseparated
+        field := V
+        flow := F
+        smooth := hV
+        integral := hF
+        zero := hzero
+        descent := hdesc
+        model_germ := hgerm }, rfl, rfl, hchart⟩
+
+private theorem
+    AdaptedWindows.exists_embedded_level_transport {E M G H X : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [CompactSpace M] {f : M → ℝ} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [TopologicalSpace X]
+    [ChartedSpace H X] (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ}
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hb : ∀ y, f y = b → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (γ : C(X, { x : M // f x = a })) (x₀ : X) :
+    let _ := Smale.RegularLevel.chartedSpace hf ha
+    let _ := Smale.RegularLevel.chartedSpace hf hb
+    ContMDiff J 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ γ →
+      Function.Injective γ →
+        (∀ z, Function.Injective (mfderiv J 𝓘(ℝ, Smale.RegularLevel.Model E) γ z)) →
+          (∀ z, (γ z).val ∈ Degree.FlowCancellation.levelBasin S.flow f b) →
+            ∃ D :
+              PartialDiffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+                { x : M // f x = a } { x : M // f x = b } ∞,
+              D.source = {x | x.val ∈ Degree.FlowCancellation.levelBasin S.flow f b} ∧
+                D.target = {y | y.val ∈ Degree.FlowCancellation.levelBasin S.flow f a} ∧
+                  ∃ Γ : C(X, { x : M // f x = b }),
+                    ContMDiff J 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ Γ ∧
+                      Function.Injective Γ ∧
+                        (∀ z,
+                            Function.Injective (mfderiv J 𝓘(ℝ, Smale.RegularLevel.Model E) Γ z)) ∧
+                          (∀ z, D (γ z) = Γ z) ∧
+                            (∀ z, D.symm (Γ z) = γ z) ∧
+                              ∀ z, ∃ t : ℝ, S.flow t (γ z).val = (Γ z).val := by
+  let _ := Smale.RegularLevel.chartedSpace hf ha
+  let _ := Smale.RegularLevel.chartedSpace hf hb
+  let _ := Smale.RegularLevel.isManifold hf ha
+  let _ := Smale.RegularLevel.isManifold hf hb
+  change
+    ContMDiff J 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ γ →
+      Function.Injective γ →
+        (∀ z, Function.Injective (mfderiv J 𝓘(ℝ, Smale.RegularLevel.Model E) γ z)) →
+          (∀ z, (γ z).val ∈ Degree.FlowCancellation.levelBasin S.flow f b) → _
+  intro hγ hγi hγd hreach
+  obtain ⟨t, ht⟩ := hreach x₀
+  let zb : { x : M // f x = b } := ⟨S.flow t (γ x₀).val, ht⟩
+  obtain ⟨D, hsource, htarget, horbit⟩ := S.exists_native_level_basin_transport hf ha hb (γ x₀) zb
+  have hmaps (z : X) : γ z ∈ D.source := hsource.symm ▸ hreach z
+  have hDγ : ContMDiff J 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ (D ∘ γ) := by
+    intro z
+    exact
+      (D.contMDiffOn_toFun.contMDiffAt (D.open_source.mem_nhds (hmaps z))).comp z hγ.contMDiffAt
+  let Γ : C(X, { x : M // f x = b }) := ⟨D ∘ γ, hDγ.continuous⟩
+  have hΓi : Function.Injective Γ := by
+    intro x y hxy
+    exact hγi (D.toPartialEquiv.injOn (hmaps x) (hmaps y) hxy)
+  have hΓd : ∀ z, Function.Injective (mfderiv J 𝓘(ℝ, Smale.RegularLevel.Model E) Γ z) := by
+    intro z
+    change Function.Injective (mfderiv J 𝓘(ℝ, Smale.RegularLevel.Model E) (D ∘ γ) z)
+    rw [mfderiv_comp z (D.mdifferentiableAt (by simp) (hmaps z)) (hγ.mdifferentiableAt (by simp))]
+    exact (Smale.PartialChart.bijective_mfderiv D (hmaps z)).1.comp (hγd z)
+  refine ⟨D, hsource, htarget, Γ, hDγ, hΓi, hΓd, fun _ => rfl, ?_, ?_⟩
+  · intro z
+    exact D.left_inv' (hmaps z)
+  · intro z
+    exact horbit (γ z) (hmaps z)
+
+private def MorseCancel.standardCircleParametrization :
+    Diffeomorph (𝓡 1) (𝓡 1) (Smale.Hemisphere.Sphere 1) Circle ∞ := by
+  let _ : Fact (Module.finrank ℝ ℂ = 1 + 1) := ⟨Complex.finrank_real_complex⟩
+  exact Smale.SphereCoordinates.standardParametrization ℂ 1
+
+private theorem MorseCancel.contMDiff_comp_standardCircle {G H N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [TopologicalSpace N]
+    [ChartedSpace H N] {γ : Circle → N} (hγ : ContMDiff (𝓡 1) J ∞ γ) :
+    ContMDiff (𝓡 1) J ∞ (γ ∘ standardCircleParametrization) :=
+  hγ.comp standardCircleParametrization.contMDiff
+
+private theorem MorseCancel.injective_comp_standardCircle {N : Type*}
+    {γ : Circle → N} (hγ : Function.Injective γ) :
+    Function.Injective (γ ∘ standardCircleParametrization) :=
+  hγ.comp standardCircleParametrization.injective
+
+private theorem MorseCancel.injective_derivative_comp_standardCircle {G H N : Type*}
+    [NormedAddCommGroup G] [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H}
+    [TopologicalSpace N] [ChartedSpace H N] {γ : Circle → N} (hγ : ContMDiff (𝓡 1) J ∞ γ)
+    (hi : ∀ z, Function.Injective (mfderiv (𝓡 1) J γ z)) (z : Smale.Hemisphere.Sphere 1) :
+    Function.Injective (mfderiv (𝓡 1) J (γ ∘ standardCircleParametrization) z) := by
+  rw [mfderiv_comp z (hγ.mdifferentiableAt (by simp))
+      (standardCircleParametrization.contMDiff.mdifferentiableAt (by simp))]
+  exact
+    (hi _).comp
+      (standardCircleParametrization.mfderivToContinuousLinearEquiv (by simp) z).injective
+
+private theorem MorseCancel.transverse_comp_standardCircle {G H N : Type*} [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [TopologicalSpace H] {J : ModelWithCorners ℝ G H} [TopologicalSpace N]
+    [ChartedSpace H N] {D : Type*} [NormedAddCommGroup D] [NormedSpace ℝ D] {γ : Circle → N}
+    (hγ : ContMDiff (𝓡 1) J ∞ γ) (B : D →L[ℝ] G) (z : Smale.Hemisphere.Sphere 1)
+    (htrans :
+      Function.Surjective
+        ((mfderiv (𝓡 1) J γ (standardCircleParametrization z) :
+              EuclideanSpace ℝ (Fin 1) →L[ℝ] G).coprod
+          B)) :
+    Function.Surjective
+      ((mfderiv (𝓡 1) J (γ ∘ standardCircleParametrization) z :
+            EuclideanSpace ℝ (Fin 1) →L[ℝ] G).coprod
+        B) := by
+  let L : EuclideanSpace ℝ (Fin 1) →L[ℝ] G := mfderiv (𝓡 1) J γ (standardCircleParametrization z)
+  let P : EuclideanSpace ℝ (Fin 1) →L[ℝ] EuclideanSpace ℝ (Fin 1) :=
+    mfderiv (𝓡 1) (𝓡 1) standardCircleParametrization z
+  have hP : Function.Surjective P :=
+    (standardCircleParametrization.mfderivToContinuousLinearEquiv (by simp) z).surjective
+  rw [mfderiv_comp z (hγ.mdifferentiableAt (by simp))
+      (standardCircleParametrization.contMDiff.mdifferentiableAt (by simp))]
+  change Function.Surjective ((L.comp P).coprod B)
+  exact surjective_coprod_comp_left L B P hP htrans
+
+private theorem
+    AdaptedWindows.attachingSphere_reaches_lower_cut {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f) {a : ℝ}
+    (hap : a < f p) (hgap : ∀ q : Smale.ManifoldMorse.criticalPoints E f, f q < f p → f q < a)
+    (u : Metric.sphere (0 : (S.data p).chart.NegativeCoordinates) 1) :
+    ((S.data p).surgery.attachingSphere u).val ∈ Degree.FlowCancellation.levelBasin S.flow f a := by
+  let x := (S.data p).surgery.attachingSphere u
+  have hback := (S.attaching_basin_iff hf p x).mpr ⟨u, rfl⟩
+  obtain ⟨r, hr, q, hq, -, hforward, hheights⟩ :=
+    Degree.FlowCancellation.exists_native_descent_endpoints hf S.smooth S.flow S.integral S.zero
+      S.descent S.distinct x.val
+  have hxreg : x.val ∉ Smale.ManifoldMorse.criticalPoints E f :=
+    (S.data p).lower_regular x.val x.property
+  have hxp : f x.val < f p := by
+    have hh := x.property
+    change f x.val = f p - (S.data p).radius ^ 2 at hh
+    rw [hh]
+    nlinarith [(S.data p).radius_pos]
+  have hqa : f q < a := hgap ⟨q, hq⟩ ((hheights hxreg).1.trans hxp)
+  exact
+    Degree.FlowCancellation.exists_level_crossing_of_endpoint_limits S.flow hf.continuous hback
+      hforward hap hqa
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem AdaptedWindows.exists_attaching_circle_lower_transport {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (p : Smale.ManifoldMorse.criticalPoints E f)
+    [Fact (Module.finrank ℝ (S.data p).chart.NegativeCoordinates = 1 + 1)] {a : ℝ}
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f) (hap : a < f p)
+    (hgap : ∀ q : Smale.ManifoldMorse.criticalPoints E f, f q < f p → f q < a) :
+    let _ := Smale.RegularLevel.chartedSpace hf (S.data p).lower_regular
+    let _ := Smale.RegularLevel.chartedSpace hf ha
+    ∃ e :
+      Diffeomorph (𝓡 1) (𝓡 1) (Smale.Hemisphere.Sphere 1)
+        (Metric.sphere (0 : (S.data p).chart.NegativeCoordinates) 1) ∞,
+      ∃ D :
+        PartialDiffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+          (S.data p).LowerLevel { y : M // f y = a } ∞,
+        D.source = {x | x.val ∈ Degree.FlowCancellation.levelBasin S.flow f a} ∧
+          D.target =
+              {y |
+                y.val ∈
+                  Degree.FlowCancellation.levelBasin S.flow f (S.toSurgeryWindows.lower p)} ∧
+            ∃ Γ : C(Smale.Hemisphere.Sphere 1, { y : M // f y = a }),
+              ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ Γ ∧
+                Function.Injective Γ ∧
+                  (∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) Γ z)) ∧
+                    (∀ z, D ((S.data p).surgery.attachingSphere (e z)) = Γ z) ∧
+                      (∀ z, D.symm (Γ z) = (S.data p).surgery.attachingSphere (e z)) ∧
+                        ∀ z,
+                          ∃ t : ℝ,
+                            S.flow t ((S.data p).surgery.attachingSphere (e z)).val = (Γ z).val :=
+  by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data p).lower_regular
+  let _ := Smale.RegularLevel.chartedSpace hf ha
+  let _ := Smale.RegularLevel.isManifold hf (S.data p).lower_regular
+  let _ := Smale.RegularLevel.isManifold hf ha
+  let e := Smale.SphereCoordinates.standardParametrization (S.data p).chart.NegativeCoordinates 1
+  let γ : C(Smale.Hemisphere.Sphere 1, (S.data p).LowerLevel) :=
+    ⟨(S.data p).surgery.attachingSphere ∘ e,
+      ((S.data p).attaching_smooth hf 1).continuous.comp e.continuous⟩
+  have hγ : ContMDiff (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ γ :=
+    ((S.data p).attaching_smooth hf 1).comp e.contMDiff
+  have hγi : Function.Injective γ :=
+    (S.data p).attaching_isClosedEmbedding.injective.comp e.injective
+  have hγd : ∀ z, Function.Injective (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) γ z) := by
+    intro z
+    change
+      Function.Injective
+        (mfderiv (𝓡 1) 𝓘(ℝ, Smale.RegularLevel.Model E) ((S.data p).surgery.attachingSphere ∘ e)
+          z)
+    rw [mfderiv_comp z (((S.data p).attaching_smooth hf 1).mdifferentiableAt (by simp))
+        (e.contMDiff.mdifferentiableAt (by simp))]
+    exact
+      ((S.data p).attaching_derivative_injective hf 1 (e z)).comp
+        (e.mfderivToContinuousLinearEquiv (by simp) z).injective
+  have hreach (z : Smale.Hemisphere.Sphere 1) :
+    (γ z).val ∈ Degree.FlowCancellation.levelBasin S.flow f a :=
+    S.attachingSphere_reaches_lower_cut hf p hap hgap (e z)
+  obtain ⟨D, hsource, htarget, Γ, hΓ, hΓi, hΓd, hD, hiD, hflow⟩ :=
+    S.exists_embedded_level_transport hf (S.data p).lower_regular ha γ
+      (MorseCancel.standardCircleParametrization.symm (1 : Circle)) hγ hγi hγd hreach
+  exact ⟨e, D, hsource, htarget, Γ, hΓ, hΓi, hΓd, hD, hiD, hflow⟩
+
+private theorem
+    AdaptedWindows.backward_basin_reaches_attaching_level {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f) {x : M}
+    (hx : x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hback : Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 p.val)) :
+    x ∈ Degree.FlowCancellation.levelBasin S.flow f (S.toSurgeryWindows.lower p) := by
+  obtain ⟨r, hr, q, hq, hback', hforward, hheights⟩ :=
+    Degree.FlowCancellation.exists_native_descent_endpoints hf S.smooth S.flow S.integral S.zero
+      S.descent S.distinct x
+  have hrp : r = p.val := tendsto_nhds_unique hback' hback
+  have hqp : f q < f p := by
+    have hh := (hheights hx).1.trans (hheights hx).2
+    rwa [hrp] at hh
+  have hqlo : f q < S.toSurgeryWindows.lower p :=
+    (S.toSurgeryWindows.value_lt_upper ⟨q, hq⟩).trans (S.separated ⟨q, hq⟩ p hqp)
+  exact
+    Degree.FlowCancellation.exists_level_crossing_of_endpoint_limits S.flow hf.continuous hback
+      hforward (S.toSurgeryWindows.lower_lt_value p) hqlo
+
+private theorem AdaptedWindows.transported_attaching_range_iff {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f) {a : ℝ}
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f) {X : Type*}
+    (e : X → Metric.sphere (0 : (S.data p).chart.NegativeCoordinates) 1)
+    (he : Function.Surjective e) (Γ : X → { y : M // f y = a })
+    (hflow : ∀ z, ∃ t : ℝ, S.flow t ((S.data p).surgery.attachingSphere (e z)).val = (Γ z).val)
+    (y : { x : M // f x = a }) :
+    y ∈ Set.range Γ ↔ Filter.Tendsto (fun t => S.flow t y.val) Filter.atBot (𝓝 p.val) := by
+  constructor
+  · rintro ⟨z, rfl⟩
+    obtain ⟨t, ht⟩ := hflow z
+    have hback :=
+      (S.attaching_basin_iff hf p ((S.data p).surgery.attachingSphere (e z))).mpr ⟨e z, rfl⟩
+    rw [← ht]
+    exact (MorseCancel.flow_time_atBot_limit_iff S.flow t _ p.val).mpr hback
+  · intro hy
+    obtain ⟨t, ht⟩ := S.backward_basin_reaches_attaching_level hf p (ha y.val y.property) hy
+    let x : (S.data p).LowerLevel := ⟨S.flow t y.val, ht⟩
+    have hxback : Filter.Tendsto (fun s => S.flow s x.val) Filter.atBot (𝓝 p.val) :=
+      (MorseCancel.flow_time_atBot_limit_iff S.flow t y.val p.val).mpr hy
+    obtain ⟨u, hu⟩ := (S.attaching_basin_iff hf p x).mp hxback
+    obtain ⟨z, hz⟩ := he u
+    obtain ⟨s, hs⟩ := hflow z
+    have hattach : S.flow t y.val = ((S.data p).surgery.attachingSphere (e z)).val := by
+      rw [hz]
+      exact (congrArg Subtype.val hu).symm
+    have hshared : S.flow 0 (Γ z).val = S.flow (s + t) y.val := by
+      rw [S.flow.map_zero_apply, S.flow.map_add, hattach, hs]
+    refine ⟨z, Subtype.ext ?_⟩
+    exact
+      MorseCancel.native_same_level_orbit_points hf S.smooth S.flow S.integral
+        (fun w hw => S.descent w (ha w hw)) (Γ z).property y.property hshared
+
+private theorem
+    AdaptedWindows.forward_endpoint_of_attaching_branches {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p q : Smale.ManifoldMorse.criticalPoints E f)
+    (hbranches :
+      ∀ u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1,
+        Filter.Tendsto (fun t => S.flow t ((S.data q).surgery.attachingSphere u).val) Filter.atTop
+          (𝓝 p.val))
+    {x : M} (hx : x ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hback : Filter.Tendsto (fun t => S.flow t x) Filter.atBot (𝓝 q.val)) :
+    Filter.Tendsto (fun t => S.flow t x) Filter.atTop (𝓝 p.val) := by
+  obtain ⟨t, ht⟩ := S.backward_basin_reaches_attaching_level hf q hx hback
+  let y : (S.data q).LowerLevel := ⟨S.flow t x, ht⟩
+  have hyback : Filter.Tendsto (fun s => S.flow s y.val) Filter.atBot (𝓝 q.val) :=
+    (MorseCancel.flow_time_atBot_limit_iff S.flow t x q.val).mpr hback
+  obtain ⟨u, hu⟩ := (S.attaching_basin_iff hf q y).mp hyback
+  have hyforward : Filter.Tendsto (fun s => S.flow s y.val) Filter.atTop (𝓝 p.val) := by
+    rw [← hu]
+    exact hbranches u
+  exact (MorseCancel.flow_time_atTop_limit_iff S.flow t x p.val).mp hyforward
+
+private theorem AdaptedWindows.attaching_branches_of_same_flow {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S T : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p q : Smale.ManifoldMorse.criticalPoints E f)
+    (hflow : T.flow = S.flow)
+    (hbranches :
+      ∀ u : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1,
+        Filter.Tendsto (fun t => S.flow t ((S.data q).surgery.attachingSphere u).val) Filter.atTop
+          (𝓝 p.val)) :
+    ∀ u : Metric.sphere (0 : (T.data q).chart.NegativeCoordinates) 1,
+      Filter.Tendsto (fun t => T.flow t ((T.data q).surgery.attachingSphere u).val) Filter.atTop
+        (𝓝 p.val) := by
+  intro u
+  let x := (T.data q).surgery.attachingSphere u
+  have hback := (T.attaching_basin_iff hf q x).mpr ⟨u, rfl⟩
+  rw [hflow] at hback ⊢
+  exact
+    S.forward_endpoint_of_attaching_branches hf p q hbranches
+      ((T.data q).lower_regular x.val x.property) hback
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.exists_adapted_windows_with_prescribed_flow_lt {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f)
+    (hinj : Set.InjOn f (Smale.ManifoldMorse.criticalPoints E f))
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V)
+    (hzero : ∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0)
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (c :
+      ∀ p : Smale.ManifoldMorse.criticalPoints E f,
+        Smale.ManifoldMorse.SignedMorseChart (E := E) f p.val)
+    (hmodel :
+      ∀ p : Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ x in 𝓝 p.val, V x = (c p).descentField x)
+    (ε : Smale.ManifoldMorse.criticalPoints E f → ℝ) (hε : ∀ p, 0 < ε p) :
+    ∃ S : AdaptedWindows E f,
+      S.field = V ∧ S.flow = F ∧ (∀ p, (S.data p).chart = c p) ∧ ∀ p, (S.data p).radius < ε p := by
+  have hfinite := Smale.ManifoldMorse.finite_criticalPoints hf hm
+  obtain ⟨r, hr, hgap⟩ := Smale.ManifoldMorse.exists_separated_value_radii hfinite hinj
+  have hex (p : Smale.ManifoldMorse.criticalPoints E f) :=
+    exists_morseSurgeryData_of_field_germ_lt hf hfinite hV F hF hzero hdesc (c p)
+      (fun x hx hfx => hinj hx p.property hfx) (hmodel p) (lt_min (hr p) (hε p))
+  choose d hd hchart hisolated hgerm using hex
+  have hdr (p : Smale.ManifoldMorse.criticalPoints E f) : (d p).radius < r p :=
+    (hd p).trans_le (min_le_left _ _)
+  have hde (p : Smale.ManifoldMorse.criticalPoints E f) : (d p).radius < ε p :=
+    (hd p).trans_le (min_le_right _ _)
+  have hseparated (p q : Smale.ManifoldMorse.criticalPoints E f) (hpq : f p < f q) :
+    f p + (d p).radius ^ 2 < f q - (d q).radius ^ 2 := by
+    have hp : (d p).radius ^ 2 < (r p) ^ 2 := by
+      nlinarith [mul_pos (sub_pos.mpr (hdr p)) (add_pos (hr p) (d p).radius_pos)]
+    have hq : (d q).radius ^ 2 < (r q) ^ 2 := by
+      nlinarith [mul_pos (sub_pos.mpr (hdr q)) (add_pos (hr q) (d q).radius_pos)]
+    linarith [hgap p q hpq]
+  exact
+    ⟨{  finite := hfinite
+        distinct := hinj
+        data := d
+        isolated := hisolated
+        separated := hseparated
+        field := V
+        flow := F
+        smooth := hV
+        integral := hF
+        zero := hzero
+        descent := hdesc
+        model_germ := hgerm }, rfl, rfl, hchart, hde⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem AdaptedWindows.exists_same_flow_windows_avoiding_level {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) {a : ℝ}
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    ∃ T : AdaptedWindows E f,
+      T.field = S.field ∧
+        T.flow = S.flow ∧
+          (∀ p, (T.data p).chart = (S.data p).chart) ∧
+            (∀ p : Smale.ManifoldMorse.criticalPoints E f,
+                f p < a → T.toSurgeryWindows.upper p < a) ∧
+              ∀ p : Smale.ManifoldMorse.criticalPoints E f,
+                a < f p → a < T.toSurgeryWindows.lower p := by
+  let ε : Smale.ManifoldMorse.criticalPoints E f → ℝ := fun p => Real.sqrt |f p - a|
+  have hε (p : Smale.ManifoldMorse.criticalPoints E f) : 0 < ε p := by
+    apply Real.sqrt_pos.mpr
+    exact abs_pos.mpr (sub_ne_zero.mpr (fun h => ha p.val h p.property))
+  obtain ⟨T, hfield, hflow, hcharts, hsmall⟩ :=
+    MorseCancel.exists_adapted_windows_with_prescribed_flow_lt hf hm S.distinct S.smooth S.flow
+      S.integral S.zero S.descent (fun p => (S.data p).chart) S.critical_model_germ ε hε
+  have hsq (p : Smale.ManifoldMorse.criticalPoints E f) : (T.data p).radius ^ 2 < |f p - a| := by
+    have hp := mul_pos (sub_pos.mpr (hsmall p)) (add_pos (hε p) (T.data p).radius_pos)
+    have heq : (ε p) ^ 2 = |f p - a| := Real.sq_sqrt (abs_nonneg _)
+    nlinarith
+  refine ⟨T, hfield, hflow, hcharts, ?_, ?_⟩
+  · intro p hp
+    have hh := hsq p
+    rw [abs_of_neg (sub_neg.mpr hp)] at hh
+    change f p + (T.data p).radius ^ 2 < a
+    linarith
+  · intro p hp
+    have hh := hsq p
+    rw [abs_of_pos (sub_pos.mpr hp)] at hh
+    change a < f p - (T.data p).radius ^ 2
+    linarith
+
+private theorem AdaptedWindows.regular_interval_around_level {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ} (S : AdaptedWindows E f)
+    {a : ℝ} (hreg : ∀ x, f x = a → x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    ∃ l u : ℝ,
+      l < a ∧ a < u ∧ ∀ x, f x ∈ Set.Icc l u → x ∉ Smale.ManifoldMorse.criticalPoints E f := by
+  have ha : a ∉ f '' Smale.ManifoldMorse.criticalPoints E f := by
+    rintro ⟨x, hx, hfx⟩
+    exact hreg x hfx hx
+  obtain ⟨ε, hε, hball⟩ :=
+    Metric.mem_nhds_iff.mp ((S.finite.image f).isClosed.isOpen_compl.mem_nhds ha)
+  refine ⟨a - ε / 2, a + ε / 2, by linarith, by linarith, ?_⟩
+  intro x hx hcrit
+  have hh : f x ∈ Metric.ball a ε := by
+    rw [Metric.mem_ball, Real.dist_eq, abs_lt]
+    constructor <;> linarith [hx.1, hx.2]
+  exact hball hh ⟨x, hcrit, rfl⟩
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem
+    AdaptedWindows.realize_one_handle_minimum_branches {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (hone : MorseCancel.nativeMorseIndex E f q = 1)
+    (u v : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (hnot : ¬Joined ((S.data q).coreBoundaryMap u) ((S.data q).coreBoundaryMap v)) :
+    ∃ (V : (x : M) → TangentSpace 𝓘(ℝ, E) x) (G : Flow ℝ M) (p r :
+      Smale.ManifoldMorse.criticalPoints E f),
+      ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)) ∧
+        (∀ x, IsMIntegralCurve (fun t => G t x) V) ∧
+          (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, V x = 0) ∧
+            (∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0) ∧
+              (∀ x ∈ Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ y in 𝓝 x, V y = S.field y) ∧
+                MorseCancel.nativeMorseIndex E f p = 0 ∧
+                  MorseCancel.nativeMorseIndex E f r = 0 ∧
+                    p ≠ r ∧
+                      f p < S.toSurgeryWindows.lower q ∧
+                        f r < S.toSurgeryWindows.lower q ∧
+                          (∀ x : (S.data q).LowerLevel,
+                              Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 q.val) ↔
+                                x ∈ Set.range (S.data q).surgery.attachingSphere) ∧
+                            Filter.Tendsto
+                                (fun t => G t ((S.data q).surgery.attachingSphere u).val)
+                                Filter.atTop (𝓝 p.val) ∧
+                              Filter.Tendsto
+                                  (fun t => G t ((S.data q).surgery.attachingSphere v).val)
+                                  Filter.atTop (𝓝 r.val) ∧
+                                (∀ w : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1,
+                                    Filter.Tendsto
+                                        (fun t => G t ((S.data q).surgery.attachingSphere w).val)
+                                        Filter.atTop (𝓝 p.val) ∨
+                                      Filter.Tendsto
+                                        (fun t => G t ((S.data q).surgery.attachingSphere w).val)
+                                        Filter.atTop (𝓝 r.val)) ∧
+                                  ∀ j : Smale.ManifoldMorse.criticalPoints E f,
+                                    j ≠ q →
+                                      j ≠ p →
+                                        j ≠ r →
+                                          ∀ x,
+                                            ¬(Filter.Tendsto (fun t => G t x) Filter.atBot
+                                                  (𝓝 q.val) ∧
+                                                Filter.Tendsto (fun t => G t x) Filter.atTop
+                                                  (𝓝 j.val)) := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data q).lower_regular
+  obtain ⟨d, hd, p, r, hp, hr, hpr, hpq, hrq, hpu, hrv, hall⟩ :=
+    S.place_one_handle_in_distinct_minimum_basins hf q hone u v hnot
+  obtain ⟨l, b, hl, hb, hband⟩ := S.regular_interval_around_level (S.data q).lower_regular
+  obtain
+    ⟨ρ, C, W, V, H, G, hρ, hρbound, hC, hCband, hW, hH, hgeometry, hV, hG, hzero, hdesc, hgerms,
+      houtside, hend, hheight, hleft, hright⟩ :=
+    Degree.FlowSuspension.exists_native_regular_level_isotopy_realization hf S.smooth S.descent
+      S.flow S.integral hl hb hband (S.data q).lower_regular
+      ((S.data q).surgery.attachingSphere u) d hd
+  obtain ⟨hback, hforward⟩ :=
+    Degree.FlowSuspension.whole_level_basins_of_holonomy S.flow H G Subtype.val d
+      (fun x z => (hgeometry x).2.1 z) (fun x z => (hgeometry x).2.2 z) hend hleft hright
+  have hbq (x : (S.data q).LowerLevel) :
+    Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 q.val) ↔
+      x ∈ Set.range (S.data q).surgery.attachingSphere :=
+    (hback x q.val).trans (S.attaching_basin_iff hf q x)
+  have hends (w : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1) :
+    Filter.Tendsto (fun t => G t ((S.data q).surgery.attachingSphere w).val) Filter.atTop
+        (𝓝 p.val) ∨
+      Filter.Tendsto (fun t => G t ((S.data q).surgery.attachingSphere w).val) Filter.atTop
+        (𝓝 r.val) :=
+    (hall w).imp ((hforward _ p.val).mpr) ((hforward _ r.val).mpr)
+  refine
+    ⟨V, G, p, r, hV, hG, (fun x hx => (hzero x).mpr (S.zero x hx)), hdesc, hgerms, hp, hr, hpr,
+      hpq, hrq, hbq, (hforward _ p.val).mpr hpu, (hforward _ r.val).mpr hrv, hends, ?_⟩
+  intro j hjq hjp hjr x hx
+  have hmono :=
+    Smale.FlowConstruction.antitone_flow_height hf G hG (fun y hy => (hzero y).mpr (S.zero y hy))
+      hdesc x
+  have hforwardHeight := hf.continuous.continuousAt.tendsto.comp hx.2
+  have hbackwardHeight := hf.continuous.continuousAt.tendsto.comp hx.1
+  have hle : f j ≤ f q :=
+    (hmono.le_of_tendsto hforwardHeight 0).trans (hmono.ge_of_tendsto hbackwardHeight 0)
+  have hjq' : f j < f q :=
+    lt_of_le_of_ne hle (fun h => hjq (Subtype.ext (S.distinct j.property q.property h)))
+  have hjlow : f j < S.toSurgeryWindows.lower q :=
+    (S.toSurgeryWindows.value_lt_upper j).trans (S.separated j q hjq')
+  obtain ⟨t, ht⟩ :=
+    Degree.FlowCancellation.exists_level_crossing_of_endpoint_limits G hf.continuous hx.1 hx.2
+      (S.toSurgeryWindows.lower_lt_value q) hjlow
+  let z : (S.data q).LowerLevel := ⟨G t x, ht⟩
+  have hzq : Filter.Tendsto (fun s => G s z) Filter.atBot (𝓝 q.val) :=
+    (MorseCancel.flow_time_atBot_limit_iff G t x q.val).mpr hx.1
+  have hzj : Filter.Tendsto (fun s => G s z) Filter.atTop (𝓝 j.val) :=
+    (MorseCancel.flow_time_atTop_limit_iff G t x j.val).mpr hx.2
+  obtain ⟨w, hw⟩ := (hbq z).mp hzq
+  have hh := hends w
+  rw [hw] at hh
+  rcases hh with hp' | hr'
+  · exact hjp (Subtype.ext (tendsto_nhds_unique hzj hp'))
+  · exact hjr (Subtype.ext (tendsto_nhds_unique hzj hr'))
+
+private theorem
+    AdaptedWindows.exists_relative_level_surgery_system {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f) {c : ℝ}
+    (hc : ∀ y, f y = c → y ∉ Smale.ManifoldMorse.criticalPoints E f) (z : { y : M // f y = c })
+    (ε : Smale.ManifoldMorse.criticalPoints E f → ℝ) (hε : ∀ p, 0 < ε p) :
+    let _ := Smale.RegularLevel.chartedSpace hf hc
+    ∀
+      (D :
+        Diffeomorph 𝓘(ℝ, Smale.RegularLevel.Model E) 𝓘(ℝ, Smale.RegularLevel.Model E)
+          { y : M // f y = c } { y : M // f y = c } ∞)
+      (K P : Set { y : M // f y = c }),
+      IsCompact K →
+        Smale.SupportedDiffeomorph.SupportedRelativeIsotopy D K P →
+          ∃ T : AdaptedWindows E f,
+            (∀ p, (T.data p).chart = (S.data p).chart) ∧
+              (∀ p, (T.data p).radius < ε p) ∧
+                (∀ p ∈ Smale.ManifoldMorse.criticalPoints E f,
+                    ∀ᶠ y in 𝓝 p, T.field y = S.field y) ∧
+                  (∀ x : { y : M // f y = c },
+                      ∀ p : M,
+                        Filter.Tendsto (fun t => T.flow t x.val) Filter.atBot (𝓝 p) ↔
+                          Filter.Tendsto (fun t => S.flow t x.val) Filter.atBot (𝓝 p)) ∧
+                    (∀ x : { y : M // f y = c },
+                        ∀ p : M,
+                          Filter.Tendsto (fun t => T.flow t x.val) Filter.atTop (𝓝 p) ↔
+                            Filter.Tendsto (fun t => S.flow t (D x).val) Filter.atTop (𝓝 p)) ∧
+                      ∀ x ∈ P,
+                        Set.range (fun t => T.flow t x.val) =
+                          Set.range (fun t => S.flow t x.val) := by
+  let _ := Smale.RegularLevel.chartedSpace hf hc
+  dsimp only
+  intro D K P hK I
+  obtain ⟨a, b, ha, hb, hband⟩ := S.regular_interval_around_level hc
+  obtain
+    ⟨_, _, _, V, H, G, -, -, -, -, -, -, hgeometry, hV, hG, hzero, hdesc, hgerms, -, hend, -,
+      hleft, hright, hprotected⟩ :=
+    Degree.FlowSuspension.exists_relative_regular_level_isotopy_realization hf S.smooth S.descent
+      S.flow S.integral ha hb hband hc z D K P hK I
+  have hmodel (p : Smale.ManifoldMorse.criticalPoints E f) :
+    ∀ᶠ y in 𝓝 p.val, V y = (S.data p).chart.descentField y := by
+    filter_upwards [hgerms p.val p.property, S.critical_model_germ p] with y hy hys
+    exact hy.trans hys
+  obtain ⟨T, hfield, hflow, hcharts, hradii⟩ :=
+    MorseCancel.exists_adapted_windows_with_prescribed_flow_lt hf hm S.distinct hV G hG
+      (fun y hy => (hzero y).mpr (S.zero y hy)) hdesc (fun p => (S.data p).chart) hmodel ε hε
+  obtain ⟨hback, hforward⟩ :=
+    Degree.FlowSuspension.whole_level_basins_of_holonomy S.flow H G Subtype.val D
+      (fun x p => (hgeometry x).2.1 p) (fun x p => (hgeometry x).2.2 p) hend hleft hright
+  refine ⟨T, hcharts, hradii, ?_, ?_, ?_, ?_⟩
+  · intro p hp
+    rw [hfield]
+    exact hgerms p hp
+  · intro x p
+    rw [hflow]
+    exact hback x p
+  · intro x p
+    rw [hflow]
+    exact hforward x p
+  · intro x hx
+    rw [hflow]
+    have heq : (fun t => G t x.val) = (fun t => H t x.val) := funext (fun t => hprotected x hx t)
+    rw [heq]
+    exact (hgeometry x.val).1
+
+private theorem AdaptedWindows.exists_native_family_level_transport {ι E M F H X : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] {I : ModelWithCorners ℝ F H}
+    [TopologicalSpace X] [ChartedSpace H X] [CompactSpace X] (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ}
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hb : ∀ y, f y = b → y ∉ Smale.ManifoldMorse.criticalPoints E f) (za : { x : M // f x = a })
+    (zb : { x : M // f x = b }) (α : ι → X → { x : M // f x = a }) :
+    let _ := Smale.RegularLevel.chartedSpace hf ha
+    let _ := Smale.RegularLevel.chartedSpace hf hb
+    (∀ j, ContMDiff I 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ (α j)) →
+      (∀ j, Function.Injective (α j)) →
+        (∀ j x, Function.Injective (mfderiv I 𝓘(ℝ, Smale.RegularLevel.Model E) (α j) x)) →
+          Pairwise (fun i j => Disjoint (Set.range (α i)) (Set.range (α j))) →
+            (∀ j x, (α j x).val ∈ Degree.FlowCancellation.levelBasin S.flow f b) →
+              ∃ β : ι → X → { x : M // f x = b },
+                (∀ j, ContMDiff I 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ (β j)) ∧
+                  (∀ j, Topology.IsClosedEmbedding (β j)) ∧
+                    (∀ j x,
+                        Function.Injective (mfderiv I 𝓘(ℝ, Smale.RegularLevel.Model E) (β j) x)) ∧
+                      Pairwise (fun i j => Disjoint (Set.range (β i)) (Set.range (β j))) ∧
+                        ∀ j x, ∃ t : ℝ, S.flow t (α j x).val = (β j x).val := by
+  let _ := Smale.RegularLevel.chartedSpace hf ha
+  let _ := Smale.RegularLevel.chartedSpace hf hb
+  let _ := Smale.RegularLevel.isManifold hf ha
+  let _ := Smale.RegularLevel.isManifold hf hb
+  dsimp only
+  intro hα hαinj hαimm hpair hreach
+  obtain ⟨P, hsource, -, horbit⟩ := S.exists_native_level_basin_transport hf ha hb za zb
+  have hsrc (j : ι) (x : X) : α j x ∈ P.source := by
+    rw [hsource]
+    exact hreach j x
+  let β : ι → X → { x : M // f x = b } := fun j => P ∘ α j
+  have hβ (j : ι) : ContMDiff I 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ (β j) := by
+    intro x
+    exact
+      (P.contMDiffOn_toFun.contMDiffAt (P.open_source.mem_nhds (hsrc j x))).comp x
+        (hα j).contMDiffAt
+  have hinj (j : ι) : Function.Injective (β j) := by
+    intro x y hxy
+    exact hαinj j (P.toPartialEquiv.injOn (hsrc j x) (hsrc j y) hxy)
+  refine
+    ⟨β, hβ, fun j => (hβ j).continuous.isClosedEmbedding (hinj j), ?_, ?_, fun j x =>
+      horbit (α j x) (hsrc j x)⟩
+  · intro j x
+    have hP := P.contMDiffOn_toFun.contMDiffAt (P.open_source.mem_nhds (hsrc j x))
+    change Function.Injective (mfderiv I 𝓘(ℝ, Smale.RegularLevel.Model E) (P ∘ α j) x)
+    rw [mfderiv_comp x (hP.mdifferentiableAt (by simp)) ((hα j).mdifferentiableAt (by simp))]
+    exact (Smale.PartialChart.bijective_mfderiv P (hsrc j x)).injective.comp (hαimm j x)
+  · intro i j hij
+    apply Set.disjoint_left.mpr
+    intro z hiz hjz
+    obtain ⟨x, hx⟩ := hiz
+    obtain ⟨y, hy⟩ := hjz
+    have heq : α i x = α j y := P.toPartialEquiv.injOn (hsrc i x) (hsrc j y) (hx.trans hy.symm)
+    exact Set.disjoint_left.mp (hpair hij) (Set.mem_range_self x) ⟨y, heq.symm⟩
+
+private theorem AdaptedWindows.reaches_lower_of_excluded_critical_limit {E M : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ} (hab : a < b)
+    (hb : ∀ y, f y = b → y ∉ Smale.ManifoldMorse.criticalPoints E f) (p : M)
+    (hwindow : ∀ q ∈ Smale.ManifoldMorse.criticalPoints E f, f q ∈ Set.Icc a b → q = p)
+    (x : { y : M // f y = b })
+    (hexcluded : ¬Filter.Tendsto (fun t => S.flow t x.val) Filter.atTop (𝓝 p)) :
+    x.val ∈ Degree.FlowCancellation.levelBasin S.flow f a := by
+  obtain ⟨q, hq, r, hr, hback, hforward, hheights⟩ :=
+    Degree.FlowCancellation.exists_native_descent_endpoints hf S.smooth S.flow S.integral S.zero
+      S.descent S.distinct x.val
+  have hregular := hb x.val x.property
+  have hbelow : f r < a := by
+    by_contra h
+    have hrb : f r < b := by simpa only [x.property] using (hheights hregular).1
+    have heq := hwindow r hr ⟨le_of_not_gt h, hrb.le⟩
+    exact hexcluded (heq ▸ hforward)
+  have habove : a < f q := by
+    have hbq : b < f q := by simpa only [x.property] using (hheights hregular).2
+    exact hab.trans hbq
+  exact
+    Degree.FlowCancellation.exists_level_crossing_of_endpoint_limits S.flow hf.continuous hback
+      hforward habove hbelow
+
+private theorem
+    AdaptedWindows.reaches_old_lower_of_belt_avoidance {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S T : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f)
+    (D : (S.data p).UpperLevel → (S.data p).UpperLevel)
+    (hforward :
+      ∀ x : (S.data p).UpperLevel,
+        ∀ q : M,
+          Filter.Tendsto (fun t => T.flow t x.val) Filter.atTop (𝓝 q) ↔
+            Filter.Tendsto (fun t => S.flow t (D x).val) Filter.atTop (𝓝 q))
+    (x : (S.data p).UpperLevel) (hx : D x ∉ Set.range (S.data p).surgery.beltSphere) :
+    x.val ∈ Degree.FlowCancellation.levelBasin T.flow f (S.toSurgeryWindows.lower p) := by
+  apply
+    T.reaches_lower_of_excluded_critical_limit hf
+      ((S.toSurgeryWindows.lower_lt_value p).trans (S.toSurgeryWindows.value_lt_upper p))
+      (S.data p).upper_regular p.val (S.isolated p) x
+  intro h
+  exact hx ((S.belt_basin_iff hf p (D x)).mp ((hforward x p.val).mp h))
+
+private theorem
+    Degree.MorseRearrangement.exists_whole_family_avoidance {ι D Z G H H' K X Y N : Type}
+    [Finite ι] [NormedAddCommGroup D] [NormedSpace ℝ D] [FiniteDimensional ℝ D]
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [FiniteDimensional ℝ Z] [NormedAddCommGroup G]
+    [NormedSpace ℝ G] [FiniteDimensional ℝ G] [TopologicalSpace H] [TopologicalSpace H']
+    [TopologicalSpace K] {I : ModelWithCorners ℝ D H} {I' : ModelWithCorners ℝ Z H'}
+    {J : ModelWithCorners ℝ G K} [I.Boundaryless] [I'.Boundaryless] [J.Boundaryless]
+    [TopologicalSpace X] [ChartedSpace H X] [IsManifold I ∞ X] [CompactSpace X] [T2Space X]
+    [TopologicalSpace Y] [ChartedSpace H' Y] [IsManifold I' ∞ Y] [CompactSpace Y]
+    [TopologicalSpace N] [ChartedSpace K N] [IsManifold J ∞ N] [T2Space N] (a : ι → X → N)
+    (ha : ∀ j, ContMDiff I J ∞ (a j)) {g : Y → N} (hg : ContMDiff I' J ∞ g)
+    (hdim : Module.finrank ℝ D + Module.finrank ℝ Z < Module.finrank ℝ G) {C : Set N}
+    (hC : IsClosed C) (haC : ∀ j, Disjoint (Set.range (a j)) C) :
+    ∃ (e : Diffeomorph J J N N ∞) (K : Set N),
+      IsCompact K ∧
+        K ⊆ Cᶜ ∧
+          Nonempty (Smale.SupportedDiffeomorph.SupportedRelativeIsotopy e K C) ∧
+            ∀ j, Disjoint (Set.range (e ∘ a j)) (Set.range g) := by
+  obtain ⟨n, b, hb, hbrange⟩ := exists_sheetSumMap_for_finite_family a ha
+  have hbC : Disjoint (Set.range b) C := by
+    apply Set.disjoint_left.mpr
+    intro z hz hzC
+    rw [hbrange] at hz
+    obtain ⟨j, hj⟩ := Set.mem_iUnion.mp hz
+    exact Set.disjoint_left.mp (haC j) hj hzC
+  obtain ⟨e, K, hK, hKC, hIso, hdisj⟩ :=
+    exists_supported_ambient_disjoint_fixing_closed hb hg hdim hC hbC
+  refine ⟨e, K, hK, hKC, hIso, ?_⟩
+  intro j
+  apply Set.disjoint_left.mpr
+  intro z hz hzg
+  obtain ⟨x, hx⟩ := hz
+  have hx' : a j x ∈ Set.range b := by
+    rw [hbrange]
+    exact Set.mem_iUnion.mpr ⟨j, Set.mem_range_self x⟩
+  obtain ⟨w, hw⟩ := hx'
+  apply Set.disjoint_left.mp hdisj _ hzg
+  refine ⟨w, ?_⟩
+  change e (b w) = z
+  rw [hw]
+  exact hx
+
+private theorem AdaptedWindows.exists_middle_family_descent {ι E M : Type} [Finite ι]
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hm : Smale.ManifoldMorse.IsMorse E f) (hdim : Module.finrank ℝ E = 6)
+    (p : Smale.ManifoldMorse.criticalPoints E f) (hp : MorseCancel.nativeMorseIndex E f p = 3)
+    (α : ι → (Smale.Hemisphere.Sphere 2) → (S.data p).UpperLevel) {P : Set (S.data p).UpperLevel}
+    (hP : IsClosed P) (hαP : ∀ j, Disjoint (Set.range (α j)) P)
+    (ε : Smale.ManifoldMorse.criticalPoints E f → ℝ) (hε : ∀ q, 0 < ε q) :
+    let _ := Smale.RegularLevel.chartedSpace hf (S.data p).upper_regular
+    let _ := Smale.RegularLevel.chartedSpace hf (S.data p).lower_regular
+    (∀ j, ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ (α j)) →
+      (∀ j, Function.Injective (α j)) →
+        (∀ j x, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) (α j) x)) →
+          Pairwise (fun i j => Disjoint (Set.range (α i)) (Set.range (α j))) →
+            ∃ T : AdaptedWindows E f,
+              (∀ q, (T.data q).chart = (S.data q).chart) ∧
+                (∀ q, (T.data q).radius < ε q) ∧
+                  (∀ q ∈ Smale.ManifoldMorse.criticalPoints E f,
+                      ∀ᶠ y in 𝓝 q, T.field y = S.field y) ∧
+                    (∀ x : (S.data p).UpperLevel,
+                        ∀ q : M,
+                          Filter.Tendsto (fun t => T.flow t x.val) Filter.atBot (𝓝 q) ↔
+                            Filter.Tendsto (fun t => S.flow t x.val) Filter.atBot (𝓝 q)) ∧
+                      (∀ x ∈ P,
+                          Set.range (fun t => T.flow t x.val) =
+                            Set.range (fun t => S.flow t x.val)) ∧
+                        ∃ β : ι → (Smale.Hemisphere.Sphere 2) → (S.data p).LowerLevel,
+                          (∀ j, ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ (β j)) ∧
+                            (∀ j, Topology.IsClosedEmbedding (β j)) ∧
+                              (∀ j x,
+                                  Function.Injective
+                                    (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) (β j) x)) ∧
+                                Pairwise
+                                    (fun i j => Disjoint (Set.range (β i)) (Set.range (β j))) ∧
+                                  (∀ j x, ∃ t : ℝ, T.flow t (α j x).val = (β j x).val) ∧
+                                    ∀ j x q,
+                                      Filter.Tendsto (fun t => T.flow t (β j x).val) Filter.atBot
+                                          (𝓝 q) ↔
+                                        Filter.Tendsto (fun t => S.flow t (α j x).val)
+                                          Filter.atBot (𝓝 q) := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data p).upper_regular
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data p).lower_regular
+  let _ := Smale.RegularLevel.isManifold hf (S.data p).upper_regular
+  let _ : CompactSpace (S.data p).UpperLevel :=
+    isCompact_iff_compactSpace.mp (isClosed_eq hf.continuous continuous_const).isCompact
+  let _ : Fact (Module.finrank ℝ (S.data p).chart.NegativeCoordinates = 2 + 1) :=
+    ⟨(MorseCancel.nativeMorseIndex_eq_chart (S.data p).chart).symm.trans hp⟩
+  let _ : Fact (Module.finrank ℝ (S.data p).chart.PositiveCoordinates = 2 + 1) :=
+    ⟨by
+      have hs := (S.data p).chart.finrank_negative_add_positive
+      have hn := (MorseCancel.nativeMorseIndex_eq_chart (S.data p).chart).symm.trans hp
+      omega⟩
+  dsimp only
+  intro hα hαinj hαimm hpair
+  have hdim' :
+    Module.finrank ℝ (EuclideanSpace ℝ (Fin 2)) + Module.finrank ℝ (EuclideanSpace ℝ (Fin 2)) <
+      Module.finrank ℝ (Smale.RegularLevel.Model E) := by simp [Smale.RegularLevel.Model, hdim]
+  obtain ⟨D, K, hK, -, ⟨A⟩, havoid⟩ :=
+    Degree.MorseRearrangement.exists_whole_family_avoidance α hα ((S.data p).belt_smooth hf 2)
+      hdim' hP hαP
+  let x₀ : (Smale.Hemisphere.Sphere 2) := Smale.Hemisphere.point Bool.true ⟨0, by simp []⟩
+  let u :=
+    Smale.SphereCoordinates.standardParametrization (S.data p).chart.NegativeCoordinates 2 x₀
+  let v :=
+    Smale.SphereCoordinates.standardParametrization (S.data p).chart.PositiveCoordinates 2 x₀
+  obtain ⟨T, hcharts, hradii, hgerms, hback, hforward, hprotected⟩ :=
+    S.exists_relative_level_surgery_system hf hm (S.data p).upper_regular
+      ((S.data p).surgery.beltSphere v) ε hε D K P hK A
+  have hreach (j : ι) (x : (Smale.Hemisphere.Sphere 2)) :
+    (α j x).val ∈ Degree.FlowCancellation.levelBasin T.flow f (S.toSurgeryWindows.lower p) := by
+    apply S.reaches_old_lower_of_belt_avoidance T hf p D hforward (α j x)
+    intro hx
+    exact Set.disjoint_left.mp (havoid j) ⟨x, rfl⟩ hx
+  obtain ⟨β, hβ, hβe, hβi, hβpair, horbit⟩ :=
+    T.exists_native_family_level_transport hf (S.data p).upper_regular (S.data p).lower_regular
+      ((S.data p).surgery.beltSphere v) ((S.data p).surgery.attachingSphere u) α hα hαinj hαimm
+      hpair hreach
+  refine ⟨T, hcharts, hradii, hgerms, hback, hprotected, β, hβ, hβe, hβi, hβpair, horbit, ?_⟩
+  intro j x q
+  obtain ⟨t, ht⟩ := horbit j x
+  rw [← ht]
+  exact (MorseCancel.flow_time_atBot_limit_iff T.flow t (α j x).val q).trans (hback (α j x) q)
+
+private theorem AdaptedWindows.exists_native_attaching_lower_cut {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f) (n : ℕ)
+    [Fact (Module.finrank ℝ (S.data p).chart.NegativeCoordinates = n + 1)] {a : ℝ}
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f) (hap : a < f p)
+    (hgap : ∀ q : Smale.ManifoldMorse.criticalPoints E f, f q < f p → f q < a) :
+    let _ := Smale.RegularLevel.chartedSpace hf ha
+    ∃ Γ : C(Smale.Hemisphere.Sphere n, { y : M // f y = a }),
+      ContMDiff (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ Γ ∧
+        Topology.IsClosedEmbedding Γ ∧
+          (∀ z, Function.Injective (mfderiv (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) Γ z)) ∧
+            (∀ z,
+                ∃ t : ℝ,
+                  S.flow t
+                      ((S.data p).surgery.attachingSphere
+                          (Smale.SphereCoordinates.standardParametrization
+                            (S.data p).chart.NegativeCoordinates n z)).val =
+                    (Γ z).val) ∧
+              ∀ y : { x : M // f x = a },
+                y ∈ Set.range Γ ↔
+                  Filter.Tendsto (fun t => S.flow t y.val) Filter.atBot (𝓝 p.val) := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data p).lower_regular
+  let _ := Smale.RegularLevel.chartedSpace hf ha
+  let e := Smale.SphereCoordinates.standardParametrization (S.data p).chart.NegativeCoordinates n
+  let γ : C(Smale.Hemisphere.Sphere n, (S.data p).LowerLevel) :=
+    ⟨(S.data p).surgery.attachingSphere ∘ e,
+      ((S.data p).attaching_smooth hf n).continuous.comp e.continuous⟩
+  have hγ : ContMDiff (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ γ :=
+    ((S.data p).attaching_smooth hf n).comp e.contMDiff
+  have hγi : Function.Injective γ :=
+    (S.data p).attaching_isClosedEmbedding.injective.comp e.injective
+  have hγd : ∀ z, Function.Injective (mfderiv (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) γ z) := by
+    intro z
+    change
+      Function.Injective
+        (mfderiv (𝓡 n) 𝓘(ℝ, Smale.RegularLevel.Model E) ((S.data p).surgery.attachingSphere ∘ e)
+          z)
+    rw [mfderiv_comp z (((S.data p).attaching_smooth hf n).mdifferentiableAt (by simp))
+        (e.contMDiff.mdifferentiableAt (by simp))]
+    exact
+      ((S.data p).attaching_derivative_injective hf n (e z)).comp
+        (e.mfderivToContinuousLinearEquiv (by simp) z).injective
+  have hreach (z : Smale.Hemisphere.Sphere n) :
+    (γ z).val ∈ Degree.FlowCancellation.levelBasin S.flow f a :=
+    S.attachingSphere_reaches_lower_cut hf p hap hgap (e z)
+  let x₀ : Smale.Hemisphere.Sphere n := Smale.Hemisphere.point Bool.true ⟨0, by simp []⟩
+  obtain ⟨D, -, -, Γ, hΓ, hΓi, hΓd, -, -, hflow⟩ :=
+    S.exists_embedded_level_transport hf (S.data p).lower_regular ha γ x₀ hγ hγi hγd hreach
+  refine ⟨Γ, hΓ, hΓ.continuous.isClosedEmbedding hΓi, hΓd, hflow, ?_⟩
+  intro y
+  exact S.transported_attaching_range_iff hf p ha e e.surjective Γ hflow y
+
+private theorem AdaptedWindows.not_backward_basin_on_upper_level {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (p : Smale.ManifoldMorse.criticalPoints E f)
+    (x : (S.data p).UpperLevel) :
+    ¬Filter.Tendsto (fun t => S.flow t x.val) Filter.atBot (𝓝 p.val) := by
+  intro hx
+  obtain ⟨q, hq, r, hr, hback, _, hheights⟩ :=
+    Degree.FlowCancellation.exists_native_descent_endpoints hf S.smooth S.flow S.integral S.zero
+      S.descent S.distinct x.val
+  have heq : q = p.val := tendsto_nhds_unique hback hx
+  have hh := (hheights ((S.data p).upper_regular x.val x.property)).2
+  rw [heq, x.property] at hh
+  exact (not_lt_of_ge (S.toSurgeryWindows.value_lt_upper p).le) hh
+
+private theorem
+    AdaptedWindows.transported_backward_basin_image {E M X : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ} (hab : b < a)
+    (hb : ∀ y, f y = b → y ∉ Smale.ManifoldMorse.criticalPoints E f) (p : M) (hap : a < f p)
+    (α : X → { y : M // f y = a }) (β : X → { y : M // f y = b })
+    (hα :
+      ∀ x : { y : M // f y = a },
+        x ∈ Set.range α ↔ Filter.Tendsto (fun t => S.flow t x.val) Filter.atBot (𝓝 p))
+    (horbit : ∀ z, ∃ t : ℝ, S.flow t (α z).val = (β z).val) :
+    ∀ y : { x : M // f x = b },
+      y ∈ Set.range β ↔ Filter.Tendsto (fun t => S.flow t y.val) Filter.atBot (𝓝 p) := by
+  intro y
+  constructor
+  · rintro ⟨z, rfl⟩
+    obtain ⟨t, ht⟩ := horbit z
+    rw [← ht]
+    exact
+      (MorseCancel.flow_time_atBot_limit_iff S.flow t (α z).val p).mpr
+        ((hα (α z)).mp (Set.mem_range_self z))
+  · intro hy
+    obtain ⟨q, hq, r, hr, _, hforward, hheights⟩ :=
+      Degree.FlowCancellation.exists_native_descent_endpoints hf S.smooth S.flow S.integral S.zero
+        S.descent S.distinct y.val
+    have hrb : f r < b := by simpa only [y.property] using (hheights (hb y.val y.property)).1
+    obtain ⟨s, hs⟩ :=
+      Degree.FlowCancellation.exists_level_crossing_of_endpoint_limits S.flow hf.continuous hy
+        hforward hap (hrb.trans hab)
+    let x : { z : M // f z = a } := ⟨S.flow s y.val, hs⟩
+    have hx : Filter.Tendsto (fun t => S.flow t x.val) Filter.atBot (𝓝 p) :=
+      (MorseCancel.flow_time_atBot_limit_iff S.flow s y.val p).mpr hy
+    obtain ⟨z, hz⟩ := (hα x).mpr hx
+    obtain ⟨t, ht⟩ := horbit z
+    have hshared : S.flow 0 (β z).val = S.flow (t + s) y.val := by
+      rw [S.flow.map_zero_apply, ← ht, hz]
+      exact (S.flow.map_add t s y.val).symm
+    refine ⟨z, Subtype.ext ?_⟩
+    exact
+      MorseCancel.native_same_level_orbit_points hf S.smooth S.flow S.integral
+        (fun z hz => S.descent z (hb z hz)) (β z).property y.property hshared
+
+private def MorseCancel.nativeIndexThreeAttachingSphere {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] {f : M → ℝ}
+    (S : AdaptedWindows E f) (p : Smale.ManifoldMorse.criticalPoints E f)
+    (hp : nativeMorseIndex E f p = 3) : C((Smale.Hemisphere.Sphere 2), (S.data p).LowerLevel) := by
+  let _ : Fact (Module.finrank ℝ (S.data p).chart.NegativeCoordinates = 2 + 1) :=
+    ⟨(nativeMorseIndex_eq_chart (S.data p).chart).symm.trans hp⟩
+  exact
+    (S.data p).surgery.attachingSphere.comp
+      ((Smale.SphereCoordinates.standardParametrization (S.data p).chart.NegativeCoordinates
+            2).toHomeomorph :
+        C((Smale.Hemisphere.Sphere 2),
+          Metric.sphere (0 : (S.data p).chart.NegativeCoordinates) 1))
+
+private theorem AdaptedWindows.exists_middle_family_step {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f)
+    (hdim : Module.finrank ℝ E = 6) (p : Smale.ManifoldMorse.criticalPoints E f)
+    (hp : MorseCancel.nativeMorseIndex E f p = 3) (n : ℕ)
+    (α : Fin n → (Smale.Hemisphere.Sphere 2) → (S.data p).UpperLevel)
+    {P : Set (S.data p).UpperLevel} (hP : IsClosed P) (hαP : ∀ j, Disjoint (Set.range (α j)) P)
+    (ε : Smale.ManifoldMorse.criticalPoints E f → ℝ) (hε : ∀ q, 0 < ε q) :
+    let _ := Smale.RegularLevel.chartedSpace hf (S.data p).upper_regular
+    let _ := Smale.RegularLevel.chartedSpace hf (S.data p).lower_regular
+    (∀ j, ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ (α j)) →
+      (∀ j, Function.Injective (α j)) →
+        (∀ j x, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) (α j) x)) →
+          Pairwise (fun i j => Disjoint (Set.range (α i)) (Set.range (α j))) →
+            ∃ T : AdaptedWindows E f,
+              (∀ q, (T.data q).chart = (S.data q).chart) ∧
+                (∀ q, (T.data q).radius < ε q) ∧
+                  (∀ q ∈ Smale.ManifoldMorse.criticalPoints E f,
+                      ∀ᶠ y in 𝓝 q, T.field y = S.field y) ∧
+                    (∀ x : (S.data p).UpperLevel,
+                        ∀ q : M,
+                          Filter.Tendsto (fun t => T.flow t x.val) Filter.atBot (𝓝 q) ↔
+                            Filter.Tendsto (fun t => S.flow t x.val) Filter.atBot (𝓝 q)) ∧
+                      (∀ x ∈ P,
+                          Set.range (fun t => T.flow t x.val) =
+                            Set.range (fun t => S.flow t x.val)) ∧
+                        ∃ Γ : Fin (n + 1) → (Smale.Hemisphere.Sphere 2) → (S.data p).LowerLevel,
+                          (∀ j, ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ (Γ j)) ∧
+                            (∀ j, Topology.IsClosedEmbedding (Γ j)) ∧
+                              (∀ j x,
+                                  Function.Injective
+                                    (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) (Γ j) x)) ∧
+                                Pairwise
+                                    (fun i j => Disjoint (Set.range (Γ i)) (Set.range (Γ j))) ∧
+                                  (∀ x,
+                                      ∃ t : ℝ,
+                                        T.flow t
+                                            (MorseCancel.nativeIndexThreeAttachingSphere T p hp
+                                                x).val =
+                                          (Γ 0 x).val) ∧
+                                    (∀ y : (S.data p).LowerLevel,
+                                        y ∈ Set.range (Γ 0) ↔
+                                          Filter.Tendsto (fun t => T.flow t y.val) Filter.atBot
+                                            (𝓝 p.val)) ∧
+                                      (∀ j x, ∃ t : ℝ, T.flow t (α j x).val = (Γ j.succ x).val) ∧
+                                        (∀ j x q,
+                                            Filter.Tendsto (fun t => T.flow t (Γ j.succ x).val)
+                                                Filter.atBot (𝓝 q) ↔
+                                              Filter.Tendsto (fun t => S.flow t (α j x).val)
+                                                Filter.atBot (𝓝 q)) ∧
+                                          ∀ j q,
+                                            S.toSurgeryWindows.upper p < f q →
+                                              (∀ x : (S.data p).UpperLevel,
+                                                  x ∈ Set.range (α j) ↔
+                                                    Filter.Tendsto (fun t => S.flow t x.val)
+                                                      Filter.atBot (𝓝 q)) →
+                                                ∀ y : (S.data p).LowerLevel,
+                                                  y ∈ Set.range (Γ j.succ) ↔
+                                                    Filter.Tendsto (fun t => T.flow t y.val)
+                                                      Filter.atBot (𝓝 q) := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data p).upper_regular
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data p).lower_regular
+  dsimp only
+  intro hα hαinj hαimm hpair
+  obtain
+    ⟨T, hcharts, hradii, hgerms, hback, hprotected, β, hβ, hβe, hβi, hβpair, horbit, hlabels⟩ :=
+    S.exists_middle_family_descent hf hm hdim p hp α hP hαP ε hε hα hαinj hαimm hpair
+  let _ : Fact (Module.finrank ℝ (T.data p).chart.NegativeCoordinates = 2 + 1) :=
+    ⟨(MorseCancel.nativeMorseIndex_eq_chart (T.data p).chart).symm.trans hp⟩
+  have hgap (q : Smale.ManifoldMorse.criticalPoints E f) (hqp : f q < f p) :
+    f q < S.toSurgeryWindows.lower p :=
+    (S.toSurgeryWindows.value_lt_upper q).trans (S.separated q p hqp)
+  obtain ⟨γ, hγ, hγe, hγi, hγflow, hγrange⟩ :=
+    T.exists_native_attaching_lower_cut hf p 2 (S.data p).lower_regular
+      (S.toSurgeryWindows.lower_lt_value p) hgap
+  have hdisj (j : Fin n) : Disjoint (Set.range γ) (Set.range (β j)) := by
+    apply Set.disjoint_left.mpr
+    intro z hzγ hzβ
+    obtain ⟨x, hx⟩ := hzβ
+    have hb := (hγrange z).mp hzγ
+    rw [← hx] at hb
+    exact S.not_backward_basin_on_upper_level hf p (α j x) ((hlabels j x p.val).mp hb)
+  let Γ : Fin (n + 1) → (Smale.Hemisphere.Sphere 2) → (S.data p).LowerLevel := Fin.cases γ β
+  have hΓpair : Pairwise (fun i j => Disjoint (Set.range (Γ i)) (Set.range (Γ j))) := by
+    intro i j hij
+    cases i using Fin.cases with
+    | zero =>
+      cases j using Fin.cases with
+      | zero => exact (hij rfl).elim
+      | succ j => exact hdisj j
+    | succ i =>
+      cases j using Fin.cases with
+      | zero => exact (hdisj i).symm
+      | succ j => exact hβpair (fun h => hij (congrArg Fin.succ h))
+  refine
+    ⟨T, hcharts, hradii, hgerms, hback, hprotected, Γ, ?_, ?_, ?_, hΓpair, hγflow, hγrange,
+      horbit, hlabels, ?_⟩
+  · intro j
+    cases j using Fin.cases with
+    | zero => exact hγ
+    | succ j => exact hβ j
+  · intro j
+    cases j using Fin.cases with
+    | zero => exact hγe
+    | succ j => exact hβe j
+  · intro j
+    cases j using Fin.cases with
+    | zero => exact hγi
+    | succ j => exact hβi j
+  · intro j q hq hfull
+    apply
+      T.transported_backward_basin_image hf
+        ((S.toSurgeryWindows.lower_lt_value p).trans (S.toSurgeryWindows.value_lt_upper p))
+        (S.data p).lower_regular q hq (α j) (β j)
+    · intro x
+      exact (hfull x).trans (hback x q).symm
+    · exact horbit j
+
+private theorem AdaptedWindows.reaches_lower_in_regular_band {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ} (hab : b < a)
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hgap : ∀ q ∈ Smale.ManifoldMorse.criticalPoints E f, f q ∉ Set.Icc b a)
+    (x : { y : M // f y = a }) : x.val ∈ Degree.FlowCancellation.levelBasin S.flow f b := by
+  obtain ⟨q, hq, r, hr, hback, hforward, hheights⟩ :=
+    Degree.FlowCancellation.exists_native_descent_endpoints hf S.smooth S.flow S.integral S.zero
+      S.descent S.distinct x.val
+  have hra : f r < a := by simpa only [x.property] using (hheights (ha x.val x.property)).1
+  have haq : a < f q := by simpa only [x.property] using (hheights (ha x.val x.property)).2
+  have hrb : f r < b := by
+    by_contra h
+    exact hgap r hr ⟨le_of_not_gt h, hra.le⟩
+  exact
+    Degree.FlowCancellation.exists_level_crossing_of_endpoint_limits S.flow hf.continuous hback
+      hforward (hab.trans haq) hrb
+
+private theorem AdaptedWindows.exists_regular_band_family_transport {ι E M F H X : Type}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ}
+    [NormedAddCommGroup F] [NormedSpace ℝ F] [TopologicalSpace H] {I : ModelWithCorners ℝ F H}
+    [TopologicalSpace X] [ChartedSpace H X] [CompactSpace X] (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ} (hab : b < a)
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hb : ∀ y, f y = b → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hgap : ∀ q ∈ Smale.ManifoldMorse.criticalPoints E f, f q ∉ Set.Icc b a)
+    (za : { x : M // f x = a }) (α : ι → X → { x : M // f x = a }) :
+    let _ := Smale.RegularLevel.chartedSpace hf ha
+    let _ := Smale.RegularLevel.chartedSpace hf hb
+    (∀ j, ContMDiff I 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ (α j)) →
+      (∀ j, Function.Injective (α j)) →
+        (∀ j x, Function.Injective (mfderiv I 𝓘(ℝ, Smale.RegularLevel.Model E) (α j) x)) →
+          Pairwise (fun i j => Disjoint (Set.range (α i)) (Set.range (α j))) →
+            ∃ β : ι → X → { x : M // f x = b },
+              (∀ j, ContMDiff I 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ (β j)) ∧
+                (∀ j, Topology.IsClosedEmbedding (β j)) ∧
+                  (∀ j x,
+                      Function.Injective (mfderiv I 𝓘(ℝ, Smale.RegularLevel.Model E) (β j) x)) ∧
+                    Pairwise (fun i j => Disjoint (Set.range (β i)) (Set.range (β j))) ∧
+                      (∀ j x, ∃ t : ℝ, S.flow t (α j x).val = (β j x).val) ∧
+                        ∀ j q,
+                          a < f q →
+                            (∀ x : { y : M // f y = a },
+                                x ∈ Set.range (α j) ↔
+                                  Filter.Tendsto (fun t => S.flow t x.val) Filter.atBot (𝓝 q)) →
+                              ∀ y : { x : M // f x = b },
+                                y ∈ Set.range (β j) ↔
+                                  Filter.Tendsto (fun t => S.flow t y.val) Filter.atBot (𝓝 q) := by
+  let _ := Smale.RegularLevel.chartedSpace hf ha
+  let _ := Smale.RegularLevel.chartedSpace hf hb
+  dsimp only
+  intro hα hαinj hαimm hpair
+  obtain ⟨t, ht⟩ := S.reaches_lower_in_regular_band hf hab ha hgap za
+  obtain ⟨β, hβ, hβe, hβi, hβpair, horbit⟩ :=
+    S.exists_native_family_level_transport hf ha hb za ⟨S.flow t za.val, ht⟩ α hα hαinj hαimm
+      hpair (fun j x => S.reaches_lower_in_regular_band hf hab ha hgap (α j x))
+  refine ⟨β, hβ, hβe, hβi, hβpair, horbit, ?_⟩
+  intro j q hq hfull
+  exact S.transported_backward_basin_image hf hab hb q hq (α j) (β j) hfull (horbit j)
+
+private def
+    MorseCancel.IsNativeMiddleBasinFamily {E M : Type} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M]
+    {f : M → ℝ} (S : AdaptedWindows E f) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a : ℝ}
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f) {n : ℕ}
+    (p : Fin n → Smale.ManifoldMorse.criticalPoints E f)
+    (α : Fin n → (Smale.Hemisphere.Sphere 2) → { y : M // f y = a }) : Prop :=
+  let _ := Smale.RegularLevel.chartedSpace hf ha
+  (∀ j, ContMDiff (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) ∞ (α j)) ∧
+    (∀ j, Topology.IsClosedEmbedding (α j)) ∧
+      (∀ j x, Function.Injective (mfderiv (𝓡 2) 𝓘(ℝ, Smale.RegularLevel.Model E) (α j) x)) ∧
+        Pairwise (fun i j => Disjoint (Set.range (α i)) (Set.range (α j))) ∧
+          ∀ j y,
+            y ∈ Set.range (α j) ↔
+              Filter.Tendsto (fun t => S.flow t y.val) Filter.atBot (𝓝 (p j).val)
+
+private theorem
+    AdaptedWindows.exists_regular_band_middle_basin_family {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) {a b : ℝ} (hab : b < a)
+    (ha : ∀ y, f y = a → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hb : ∀ y, f y = b → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (hgap : ∀ q ∈ Smale.ManifoldMorse.criticalPoints E f, f q ∉ Set.Icc b a)
+    (za : { x : M // f x = a }) {n : ℕ} (p : Fin n → Smale.ManifoldMorse.criticalPoints E f)
+    (hp : ∀ j, a < f (p j)) (α : Fin n → (Smale.Hemisphere.Sphere 2) → { x : M // f x = a })
+    (hα : MorseCancel.IsNativeMiddleBasinFamily S hf ha p α) :
+    ∃ β : Fin n → (Smale.Hemisphere.Sphere 2) → { x : M // f x = b },
+      MorseCancel.IsNativeMiddleBasinFamily S hf hb p β ∧
+        ∀ j x, ∃ t : ℝ, S.flow t (α j x).val = (β j x).val := by
+  let _ := Smale.RegularLevel.chartedSpace hf ha
+  let _ := Smale.RegularLevel.chartedSpace hf hb
+  obtain ⟨hs, he, hi, hpair, hfull⟩ := hα
+  obtain ⟨β, hβs, hβe, hβi, hβpair, hflow, hβfull⟩ :=
+    S.exists_regular_band_family_transport hf hab ha hb hgap za α hs (fun j => (he j).injective)
+      hi hpair
+  exact ⟨β, ⟨hβs, hβe, hβi, hβpair, fun j => hβfull j (p j).val (hp j) (hfull j)⟩, hflow⟩
+
+private theorem AdaptedWindows.exists_middle_basin_family_step {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f)
+    (hdim : Module.finrank ℝ E = 6) (q : Smale.ManifoldMorse.criticalPoints E f)
+    (hq : MorseCancel.nativeMorseIndex E f q = 3) {n : ℕ}
+    (p : Fin n → Smale.ManifoldMorse.criticalPoints E f)
+    (hp : ∀ j, S.toSurgeryWindows.upper q < f (p j))
+    (α : Fin n → (Smale.Hemisphere.Sphere 2) → (S.data q).UpperLevel)
+    (hα : MorseCancel.IsNativeMiddleBasinFamily S hf (S.data q).upper_regular p α)
+    (ε : Smale.ManifoldMorse.criticalPoints E f → ℝ) (hε : ∀ r, 0 < ε r) :
+    ∃ T : AdaptedWindows E f,
+      (∀ r, (T.data r).chart = (S.data r).chart) ∧
+        (∀ r, (T.data r).radius < ε r) ∧
+          (∀ r ∈ Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ y in 𝓝 r, T.field y = S.field y) ∧
+            ∃ Γ : Fin (n + 1) → (Smale.Hemisphere.Sphere 2) → (S.data q).LowerLevel,
+              MorseCancel.IsNativeMiddleBasinFamily T hf (S.data q).lower_regular (Fin.cases q p)
+                Γ := by
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data q).upper_regular
+  let _ := Smale.RegularLevel.chartedSpace hf (S.data q).lower_regular
+  obtain ⟨hs, he, hi, hpair, hfull⟩ := hα
+  obtain ⟨T, hcharts, hradii, hgerms, -, -, Γ, hΓs, hΓe, hΓi, hΓpair, -, hΓzero, -, -, hΓfull⟩ :=
+    S.exists_middle_family_step hf hm hdim q hq n α isClosed_empty (fun j => Set.disjoint_empty _)
+      ε hε hs (fun j => (he j).injective) hi hpair
+  refine ⟨T, hcharts, hradii, hgerms, Γ, hΓs, hΓe, hΓi, hΓpair, ?_⟩
+  intro j
+  cases j using Fin.cases with
+  | zero => exact hΓzero
+  | succ j => exact hΓfull j (p j).val (hp j) (hfull j)
+
+private theorem AdaptedWindows.exists_middle_block_realization {E M : Type} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {f : M → ℝ} (S : AdaptedWindows E f)
+    (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f) (hm : Smale.ManifoldMorse.IsMorse E f)
+    (hdim : Module.finrank ℝ E = 6) (n : ℕ) {c : ℝ}
+    (hc : ∀ y, f y = c → y ∉ Smale.ManifoldMorse.criticalPoints E f)
+    (p : Fin n → Smale.ManifoldMorse.criticalPoints E f)
+    (hp : ∀ j, MorseCancel.nativeMorseIndex E f (p j) = 3)
+    (horder : StrictMono (fun j => f (p j))) (habove : ∀ j, c < f (p j))
+    (hblock :
+      ∀ j (q : Smale.ManifoldMorse.criticalPoints E f), c < f q → f q ≤ f (p j) → q ∈ Set.range p)
+    (ε : Smale.ManifoldMorse.criticalPoints E f → ℝ) (hε : ∀ q, 0 < ε q) :
+    ∃ T : AdaptedWindows E f,
+      (∀ q, (T.data q).chart = (S.data q).chart) ∧
+        (∀ q, (T.data q).radius < ε q) ∧
+          (∀ q ∈ Smale.ManifoldMorse.criticalPoints E f, ∀ᶠ y in 𝓝 q, T.field y = S.field y) ∧
+            ∃ α : Fin n → (Smale.Hemisphere.Sphere 2) → { y : M // f y = c },
+              MorseCancel.IsNativeMiddleBasinFamily T hf hc p α := by
+  induction n generalizing S c ε with
+  |
+    zero =>
+    obtain ⟨T, hfield, -, hcharts, hradii⟩ :=
+      MorseCancel.exists_adapted_windows_with_prescribed_flow_lt hf hm S.distinct S.smooth S.flow
+        S.integral S.zero S.descent (fun q => (S.data q).chart) S.critical_model_germ ε hε
+    refine ⟨T, hcharts, hradii, ?_, (fun j => Fin.elim0 j), ?_⟩
+    · intro q hq
+      exact Filter.Eventually.of_forall (fun y => congrFun hfield y)
+    · exact
+        ⟨fun j => Fin.elim0 j, fun j => Fin.elim0 j, fun j => Fin.elim0 j, fun j => Fin.elim0 j,
+          fun j => Fin.elim0 j⟩
+  | succ n ih =>
+    let a := S.toSurgeryWindows.upper (p 0)
+    have hpa : f (p 0) < a := S.toSurgeryWindows.value_lt_upper (p 0)
+    have htail (j : Fin n) : a < f (p j.succ) :=
+      (S.separated (p 0) (p j.succ) (horder (Fin.succ_pos j))).trans
+        (S.toSurgeryWindows.lower_lt_value (p j.succ))
+    have htailblock (j : Fin n) (q : Smale.ManifoldMorse.criticalPoints E f) (haq : a < f q)
+      (hqj : f q ≤ f (p j.succ)) : q ∈ Set.range (fun i : Fin n => p i.succ) := by
+      obtain ⟨i, hi⟩ := hblock j.succ q ((habove 0).trans (hpa.trans haq)) hqj
+      cases i using Fin.cases with
+      | zero => exact (not_lt_of_ge haq.le (hi ▸ hpa)).elim
+      | succ i => exact ⟨i, hi⟩
+    let δ := Real.sqrt (f (p 0) - c)
+    have hδ : 0 < δ := Real.sqrt_pos.mpr (sub_pos.mpr (habove 0))
+    let η : Smale.ManifoldMorse.criticalPoints E f → ℝ := fun q =>
+      Min.min (ε q) (Min.min (S.data q).radius δ)
+    have hη (q : Smale.ManifoldMorse.criticalPoints E f) : 0 < η q :=
+      lt_min (hε q) (lt_min (S.data q).radius_pos hδ)
+    obtain ⟨T, hchartsT, hradiiT, hgermsT, α, hα⟩ :=
+      ih S (S.data (p 0)).upper_regular (fun j => p j.succ) (fun j => hp j.succ)
+        (fun i j hij => horder (Fin.succ_lt_succ_iff.mpr hij)) htail htailblock η hη
+    have hradius : (T.data (p 0)).radius < (S.data (p 0)).radius :=
+      (hradiiT (p 0)).trans_le ((min_le_right _ _).trans (min_le_left _ _))
+    have hradδ : (T.data (p 0)).radius < δ :=
+      (hradiiT (p 0)).trans_le ((min_le_right _ _).trans (min_le_right _ _))
+    have hupper : T.toSurgeryWindows.upper (p 0) < a := by
+      have hh :=
+        mul_pos (sub_pos.mpr hradius)
+          (add_pos (S.data (p 0)).radius_pos (T.data (p 0)).radius_pos)
+      change f (p 0) + (T.data (p 0)).radius ^ 2 < f (p 0) + (S.data (p 0)).radius ^ 2
+      nlinarith
+    have hlower : c < T.toSurgeryWindows.lower (p 0) := by
+      have hh := mul_pos (sub_pos.mpr hradδ) (add_pos hδ (T.data (p 0)).radius_pos)
+      have hs : δ ^ 2 = f (p 0) - c := Real.sq_sqrt (sub_pos.mpr (habove 0)).le
+      change c < f (p 0) - (T.data (p 0)).radius ^ 2
+      nlinarith
+    have hgapUpper :
+      ∀ q ∈ Smale.ManifoldMorse.criticalPoints E f,
+        f q ∉ Set.Icc (T.toSurgeryWindows.upper (p 0)) a := by
+      intro q hq hh
+      have heq :=
+        S.isolated (p 0) q hq
+          ⟨((S.toSurgeryWindows.lower_lt_value (p 0)).trans
+                  (T.toSurgeryWindows.value_lt_upper (p 0))).le.trans
+              hh.1,
+            hh.2⟩
+      rw [heq] at hh
+      exact not_le_of_gt (T.toSurgeryWindows.value_lt_upper (p 0)) hh.1
+    let _ : Fact (Module.finrank ℝ (S.data (p 0)).chart.PositiveCoordinates = 2 + 1) :=
+      ⟨by
+        have hs := (S.data (p 0)).chart.finrank_negative_add_positive
+        have hn := (MorseCancel.nativeMorseIndex_eq_chart (S.data (p 0)).chart).symm.trans (hp 0)
+        omega⟩
+    let x₀ : (Smale.Hemisphere.Sphere 2) := Smale.Hemisphere.point Bool.true ⟨0, by simp⟩
+    let v :=
+      Smale.SphereCoordinates.standardParametrization (S.data (p 0)).chart.PositiveCoordinates 2
+        x₀
+    obtain ⟨β, hβ, -⟩ :=
+      T.exists_regular_band_middle_basin_family hf hupper (S.data (p 0)).upper_regular
+        (T.data (p 0)).upper_regular hgapUpper ((S.data (p 0)).surgery.beltSphere v)
+        (fun j => p j.succ) htail α hα
+    obtain ⟨U, hchartsU, hradiiU, hgermsU, Γ, hΓ⟩ :=
+      T.exists_middle_basin_family_step hf hm hdim (p 0) (hp 0) (fun j => p j.succ)
+        (fun j => hupper.trans (htail j)) β hβ ε hε
+    have hp_cases : Fin.cases (p 0) (fun j => p j.succ) = p := by
+      funext j
+      cases j using Fin.cases <;> rfl
+    rw [hp_cases] at hΓ
+    have hbelow (q : Smale.ManifoldMorse.criticalPoints E f) (hqp : f q < f (p 0)) : f q < c := by
+      by_contra h
+      have hcq : c < f q :=
+        lt_of_le_of_ne (le_of_not_gt h) (Ne.symm (fun heq => hc q.val heq q.property))
+      obtain ⟨j, hj⟩ := hblock 0 q hcq hqp.le
+      have hh := horder.monotone (Fin.zero_le j)
+      rw [hj] at hh
+      exact not_lt_of_ge hh hqp
+    have hgapLower :
+      ∀ q ∈ Smale.ManifoldMorse.criticalPoints E f,
+        f q ∉ Set.Icc c (T.toSurgeryWindows.lower (p 0)) := by
+      intro q hq hh
+      exact
+        not_le_of_gt (hbelow ⟨q, hq⟩ (hh.2.trans_lt (T.toSurgeryWindows.lower_lt_value (p 0))))
+          hh.1
+    obtain ⟨Ω, hΩ, -⟩ :=
+      U.exists_regular_band_middle_basin_family hf hlower (T.data (p 0)).lower_regular hc
+        hgapLower (MorseCancel.nativeIndexThreeAttachingSphere T (p 0) (hp 0) x₀) p
+        (fun j =>
+          (T.toSurgeryWindows.lower_lt_value (p 0)).trans_le (horder.monotone (Fin.zero_le j)))
+        Γ hΓ
+    refine ⟨U, fun q => (hchartsU q).trans (hchartsT q), hradiiU, ?_, Ω, hΩ⟩
+    intro q hq
+    filter_upwards [hgermsU q hq, hgermsT q hq] with y hyU hyT
+    exact hyU.trans hyT
+
+private theorem MorseCancel.unique_connection_of_distinct_minimum_branches {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [T2Space M] {f : M → ℝ}
+    (S : Smale.ManifoldMorse.SurgeryWindows E f) (hf : Continuous f) (G : Flow ℝ M)
+    (p r q : Smale.ManifoldMorse.criticalPoints E f) (hone : nativeMorseIndex E f q = 1)
+    (hpr : p ≠ r) (hp : f p < S.lower q)
+    (u v : Metric.sphere (0 : (S.data q).chart.NegativeCoordinates) 1)
+    (hback :
+      ∀ x : (S.data q).LowerLevel,
+        Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 q.val) ↔
+          x ∈ Set.range (S.data q).surgery.attachingSphere)
+    (hu :
+      Filter.Tendsto (fun t => G t ((S.data q).surgery.attachingSphere u).val) Filter.atTop
+        (𝓝 p.val))
+    (hv :
+      Filter.Tendsto (fun t => G t ((S.data q).surgery.attachingSphere v).val) Filter.atTop
+        (𝓝 r.val)) :
+    Filter.Tendsto (fun t => G t ((S.data q).surgery.attachingSphere u).val) Filter.atBot
+        (𝓝 q.val) ∧
+      ∀ x,
+        Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 q.val) →
+          Filter.Tendsto (fun t => G t x) Filter.atTop (𝓝 p.val) →
+            ∃ t, G t ((S.data q).surgery.attachingSphere u).val = x := by
+  have hdim : Module.finrank ℝ (S.data q).chart.NegativeCoordinates = 1 :=
+    (nativeMorseIndex_eq_chart (S.data q).chart).symm.trans hone
+  have huv : u ≠ v := by
+    intro h
+    apply hpr
+    apply Subtype.ext
+    exact tendsto_nhds_unique (h ▸ hu) hv
+  have hbu :
+    Filter.Tendsto (fun t => G t ((S.data q).surgery.attachingSphere u).val) Filter.atBot
+      (𝓝 q.val) :=
+    (hback _).mpr (Set.mem_range_self u)
+  have hsingle (x : (S.data q).LowerLevel)
+    (hb : Filter.Tendsto (fun t => G t x) Filter.atBot (𝓝 q.val))
+    (hp' : Filter.Tendsto (fun t => G t x) Filter.atTop (𝓝 p.val)) :
+    x = (S.data q).surgery.attachingSphere u := by
+    obtain ⟨w, hw⟩ := (hback x).mp hb
+    rcases unitSphere_eq_two_points_of_finrank_one hdim u v huv w with h | h
+    · exact (congrArg (S.data q).surgery.attachingSphere h).symm.trans hw |>.symm
+    · have hx : (S.data q).surgery.attachingSphere v = x := h ▸ hw
+      have hrv : Filter.Tendsto (fun t => G t x) Filter.atTop (𝓝 r.val) := hx ▸ hv
+      exact False.elim (hpr (Subtype.ext (tendsto_nhds_unique hp' hrv)))
+  have h :=
+    Degree.FlowSuspension.unique_connection_of_level_basin_intersection G G hf
+      (S.lower_lt_value q) hp id (fun _ => Iff.rfl) (fun _ => Iff.rfl)
+      ((S.data q).surgery.attachingSphere u) hbu hu hsingle
+  exact ⟨h.1, h.2.2⟩
+
+private def
+    MorseCancel.shiftedSignedMorseChart {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (k : ℝ) :
+    Smale.ManifoldMorse.SignedMorseChart (E := E) (fun x => f x + k) p
+    where
+  weights := c.weights
+  signs := c.signs
+  chart := c.chart
+  mem_source := c.mem_source
+  center := c.center
+  equation x hx := by rw [c.equation x hx]; ring
+  inverse_equation z hz := by rw [c.inverse_equation z hz]; ring
+
+private theorem
+    MorseCancel.isMorseAt_add_const {E M : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (hm : Smale.ManifoldMorse.IsMorseAt E f p) (k : ℝ) :
+    Smale.ManifoldMorse.IsMorseAt E (fun x => f x + k) p := by
+  obtain ⟨e, he, hp, hgood⟩ := hm
+  have hd : fderiv ℝ ((fun x => f x + k) ∘ e.symm) = fderiv ℝ (f ∘ e.symm) := by
+    funext z
+    exact fderiv_add_const k
+  refine ⟨e, he, hp, ?_⟩
+  rw [hd]
+  exact hgood
+
+private theorem MorseCancel.isMorseAt_of_add_const_germ {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ} {p : M}
+    (hm : Smale.ManifoldMorse.IsMorseAt E f p) {k : ℝ} (hgerm : g =ᶠ[𝓝 p] fun x => f x + k) :
+    Smale.ManifoldMorse.IsMorseAt E g p :=
+  Degree.MorseCancellationPreservation.isMorseAt_of_same_germ (isMorseAt_add_const hm k) hgerm
+
+private theorem MorseCancel.nativeMorseIndex_add_const {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (k : ℝ) :
+    nativeMorseIndex E (fun x => f x + k) p = nativeMorseIndex E f p := by
+  rw [nativeMorseIndex_eq_chart (shiftedSignedMorseChart c k), nativeMorseIndex_eq_chart c]
+  rfl
+
+private theorem MorseCancel.nativeMorseIndex_of_add_const_germ {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ} {p : M}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) {k : ℝ}
+    (hgerm : g =ᶠ[𝓝 p] fun x => f x + k) : nativeMorseIndex E g p = nativeMorseIndex E f p :=
+  (nativeMorseIndex_congr_germ hgerm).trans (nativeMorseIndex_add_const c k)
+
+private theorem MorseCancel.mfderiv_of_add_const_germ {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ} {p : M}
+    (hf : MDifferentiableAt 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f p) {k : ℝ} (hgerm : g =ᶠ[𝓝 p] fun x => f x + k) :
+    mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) g p = mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) f p := by
+  calc
+    _ = (mfderiv 𝓘(ℝ, E) 𝓘(ℝ, ℝ) (fun x => f x + k) p : E →L[ℝ] ℝ) := hgerm.mfderiv_eq
+    _ = _ := by
+      have hs : mvfderiv 𝓘(ℝ, E) (fun x => f x + k) p = mvfderiv 𝓘(ℝ, E) f p := by
+        rw [mvfderiv_fun_add hf mdifferentiableAt_const, mvfderiv_const, add_zero]
+      exact hs
+
+private theorem MorseCancel.exists_signed_morse_chart_of_germ_preserving_field {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hgerm : g =ᶠ[𝓝 p] f) :
+    ∃ d : Smale.ManifoldMorse.SignedMorseChart (E := E) g p, d.descentField = c.descentField := by
+  obtain ⟨U, hUsub, hU, hpU⟩ := mem_nhds_iff.mp hgerm
+  let d : Smale.ManifoldMorse.SignedMorseChart (E := E) g p :=
+    { weights := c.weights
+      signs := c.signs
+      chart := Smale.PartialChart.restrictSource c.chart hU
+      mem_source := ⟨c.mem_source, hpU⟩
+      center := c.center
+      equation := by
+        intro x hx
+        have hxs : x ∈ c.chart.source ∩ U := hx
+        have hxeq : g x = f x := hUsub hxs.2
+        change g x = g p + ∑ i, c.weights i * (c.chart x i) ^ 2
+        rw [hxeq, hgerm.self_of_nhds]
+        exact c.equation x hxs.1
+      inverse_equation := by
+        intro z hz
+        have hzs : z ∈ c.chart.target ∩ c.chart.symm ⁻¹' U := hz
+        have hzeq : g (c.chart.symm z) = f (c.chart.symm z) := hUsub hzs.2
+        change g (c.chart.symm z) = g p + ∑ i, c.weights i * z i ^ 2
+        rw [hzeq, hgerm.self_of_nhds]
+        exact c.inverse_equation z hzs.1 }
+  exact ⟨d, rfl⟩
+
+private theorem MorseCancel.exists_signed_morse_chart_of_shift_germ_preserving_field {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] {f g : M → ℝ}
+    {p : M} (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) {k : ℝ}
+    (hgerm : g =ᶠ[𝓝 p] fun x => f x + k) :
+    ∃ d : Smale.ManifoldMorse.SignedMorseChart (E := E) g p, d.descentField = c.descentField := by
+  obtain ⟨d, hd⟩ :=
+    exists_signed_morse_chart_of_germ_preserving_field (shiftedSignedMorseChart c k) hgerm
+  exact ⟨d, hd⟩
+
+private theorem Degree.FlowCancellation.levelBasin_eq_of_orbit_level_bridge {X : Type*}
+    [TopologicalSpace X] (F : Flow ℝ X) (f : X → ℝ) (a b : ℝ) (D : X → X)
+    (hlevel : D '' {x | f x = a} = {x | f x = b}) (horbit : ∀ x, ∃ t, F t x = D x) :
+    levelBasin F f a = levelBasin F f b := by
+  ext x
+  constructor
+  · rintro ⟨s, hs⟩
+    obtain ⟨t, ht⟩ := horbit (F s x)
+    have hDy : f (D (F s x)) = b := by
+      have hh : D (F s x) ∈ D '' {y | f y = a} := Set.mem_image_of_mem D hs
+      rw [hlevel] at hh
+      exact hh
+    exact ⟨t + s, by rw [F.map_add, ht]; exact hDy⟩
+  · rintro ⟨s, hs⟩
+    have hy : F s x ∈ D '' {y | f y = a} := by rw [hlevel]; exact hs
+    obtain ⟨y, hy, heq⟩ := hy
+    change f y = a at hy
+    obtain ⟨t, ht⟩ := horbit y
+    have hyB : y ∈ levelBasin F f a := ⟨0, by simpa only [F.map_zero_apply] using hy⟩
+    have hh := (levelBasin_flow_iff F f a t y).mpr hyB
+    rw [ht, heq] at hh
+    exact (levelBasin_flow_iff F f a s x).mp hh
+
+private theorem
+    Degree.FlowCancellation.levelBasin_eq_of_regular_band {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M] [ChartedSpace E M]
+    [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M] {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {a b : ℝ} (hab : a ≤ b)
+    (hband : ∀ x, f x ∈ Set.Icc a b → x ∉ Smale.ManifoldMorse.criticalPoints E f) :
+    levelBasin F f a = levelBasin F f b := by
+  obtain ⟨D, hlevel, -, horbit⟩ :=
+    Degree.FlowTimeChange.exists_orbit_preserving_ambient_band_bridge hf hV hdesc F hF hab hband
+  exact levelBasin_eq_of_orbit_level_bridge F f a b D hlevel horbit
+
+private theorem MorseCancel.image_flow_invariant_section {X A B : Type*} [TopologicalSpace X]
+    [TopologicalSpace A] [TopologicalSpace B] (F : Flow ℝ X) (e : A ≃ₜ B) (ι : A → X) (κ : B → X)
+    (horbit : ∀ x, ∃ t, F t (ι x) = κ (e x)) {P : X → Prop} (hP : ∀ t x, P (F t x) ↔ P x) :
+    e '' {x | P (ι x)} = {y | P (κ y)} := by
+  ext y
+  constructor
+  · rintro ⟨x, hx, rfl⟩
+    obtain ⟨t, ht⟩ := horbit x
+    have hh := (hP t (ι x)).mpr hx
+    rwa [ht] at hh
+  · intro hy
+    obtain ⟨t, ht⟩ := horbit (e.symm y)
+    have heq : e (e.symm y) = y := e.apply_symm_apply y
+    rw [heq] at ht
+    refine ⟨e.symm y, ?_, heq⟩
+    apply (hP t (ι (e.symm y))).mp
+    rwa [ht]
+
+private theorem
+    MorseCancel.isCompact_flow_invariant_section_iff {X A B : Type*} [TopologicalSpace X]
+    [TopologicalSpace A] [TopologicalSpace B] (F : Flow ℝ X) (e : A ≃ₜ B) (ι : A → X) (κ : B → X)
+    (horbit : ∀ x, ∃ t, F t (ι x) = κ (e x)) {P : X → Prop} (hP : ∀ t x, P (F t x) ↔ P x) :
+    IsCompact {y : B | P (κ y)} ↔ IsCompact {x : A | P (ι x)} := by
+  rw [← image_flow_invariant_section F e ι κ horbit hP]
+  exact e.isCompact_image
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.isCompact_native_belt_basin {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} {p : M} {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) (r : ℝ) (hr : 0 < r)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) ⊆
+        c.splitChart.target)
+    (hfield :
+      ∀
+        z ∈
+          Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+            Metric.closedBall (0 : c.PositiveCoordinates) (2 * r),
+        ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y)
+    (hboundary : ∀ x, f x = f p + r ^ 2 → mvfderiv 𝓘(ℝ, E) f x (V x) < 0) :
+    IsCompact
+      {x : { y : M // f y = f p + r ^ 2 } |
+        Filter.Tendsto (fun t => F t (x : M)) Filter.atTop (𝓝 p)} := by
+  have heq :
+    {x : { y : M // f y = f p + r ^ 2 } |
+        Filter.Tendsto (fun t => F t (x : M)) Filter.atTop (𝓝 p)} =
+      Set.range (c.beltCoreMap r hr hblock) := by
+    ext x
+    simpa only [Set.mem_ofPred_eq, Set.mem_range, Subtype.ext_iff] using
+      native_belt_core_basin_iff c hf hV F hF r hr hblock hfield hboundary x.property
+  rw [heq]
+  exact isCompact_range (c.beltCoreMap r hr hblock).continuous
+
+attribute [local instance 100] Classical.propDecidable in
+private theorem MorseCancel.isCompact_native_attaching_basin {E M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace M] [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M]
+    {f : M → ℝ} {p : M} {V : (x : M) → TangentSpace 𝓘(ℝ, E) x}
+    (c : Smale.ManifoldMorse.SignedMorseChart (E := E) f p) (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) (r : ℝ) (hr : 0 < r)
+    (hblock :
+      Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+          Metric.closedBall (0 : c.PositiveCoordinates) (2 * r) ⊆
+        c.splitChart.target)
+    (hfield :
+      ∀
+        z ∈
+          Metric.closedBall (0 : c.NegativeCoordinates) (2 * r) ×ˢ
+            Metric.closedBall (0 : c.PositiveCoordinates) (2 * r),
+        ∀ᶠ y in 𝓝 (c.splitChart.symm z), V y = c.descentField y)
+    (hboundary : ∀ x, f x = f p - r ^ 2 → mvfderiv 𝓘(ℝ, E) f x (V x) < 0) :
+    IsCompact
+      {x : { y : M // f y = f p - r ^ 2 } |
+        Filter.Tendsto (fun t => F t (x : M)) Filter.atBot (𝓝 p)} := by
+  have heq :
+    {x : { y : M // f y = f p - r ^ 2 } |
+        Filter.Tendsto (fun t => F t (x : M)) Filter.atBot (𝓝 p)} =
+      Set.range (c.attachingCoreMap r hr hblock) := by
+    ext x
+    simpa only [Set.mem_ofPred_eq, Set.mem_range, Subtype.ext_iff] using
+      native_attaching_core_basin_iff c hf hV F hF r hr hblock hfield hboundary x.property
+  rw [heq]
+  exact isCompact_range (c.attachingCoreMap r hr hblock).continuous
+
+private theorem
+    Degree.FlowCancellation.isCompact_invariant_section_iff_of_regular_band {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {a b : ℝ} (hab : a ≤ b)
+    (hband : ∀ x, f x ∈ Set.Icc a b → x ∉ Smale.ManifoldMorse.criticalPoints E f) {P : M → Prop}
+    (hP : ∀ t x, P (F t x) ↔ P x) :
+    IsCompact {x : { y : M // f y = b } | P (x : M)} ↔
+      IsCompact {x : { y : M // f y = a } | P (x : M)} := by
+  have ha : ∀ x, f x = a → x ∉ Smale.ManifoldMorse.criticalPoints E f := by
+    intro x hx
+    exact hband x (by rw [hx]; exact ⟨le_rfl, hab⟩)
+  have hb : ∀ x, f x = b → x ∉ Smale.ManifoldMorse.criticalPoints E f := by
+    intro x hx
+    exact hband x (by rw [hx]; exact ⟨hab, le_rfl⟩)
+  let _ := Smale.RegularLevel.chartedSpace hf ha
+  let _ := Smale.RegularLevel.chartedSpace hf hb
+  obtain ⟨D, e, -, he, horbit⟩ :=
+    Degree.FlowTimeChange.exists_orbit_preserving_native_band_bridge hf hV hdesc F hF hab hband ha
+      hb
+  apply
+    MorseCancel.isCompact_flow_invariant_section_iff F e.toHomeomorph Subtype.val Subtype.val _ hP
+  intro x
+  obtain ⟨t, ht⟩ := horbit x
+  exact ⟨t, ht.trans (he x).symm⟩
+
+private theorem Degree.FlowCancellation.isCompact_forward_section_iff_of_regular_band {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {a b : ℝ} (hab : a ≤ b)
+    (hband : ∀ x, f x ∈ Set.Icc a b → x ∉ Smale.ManifoldMorse.criticalPoints E f) (p : M) :
+    IsCompact
+        {x : { y : M // f y = b } | Filter.Tendsto (fun t => F t (x : M)) Filter.atTop (𝓝 p)} ↔
+      IsCompact
+        {x : { y : M // f y = a } | Filter.Tendsto (fun t => F t (x : M)) Filter.atTop (𝓝 p)} :=
+  isCompact_invariant_section_iff_of_regular_band hf hV hdesc F hF hab hband (P := fun x =>
+    Filter.Tendsto (fun t => F t x) Filter.atTop (𝓝 p))
+    (fun t x => MorseCancel.flow_time_atTop_limit_iff F t x p)
+
+private theorem Degree.FlowCancellation.isCompact_backward_section_iff_of_regular_band {E M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] [IsManifold 𝓘(ℝ, E) ∞ M] [T2Space M] [CompactSpace M]
+    {V : (x : M) → TangentSpace 𝓘(ℝ, E) x} {f : M → ℝ} (hf : ContMDiff 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ f)
+    (hV : ContMDiff 𝓘(ℝ, E) (𝓘(ℝ, E).tangent) ∞ (fun x => (⟨x, V x⟩ : TangentBundle 𝓘(ℝ, E) M)))
+    (hdesc : ∀ x, x ∉ Smale.ManifoldMorse.criticalPoints E f → mvfderiv 𝓘(ℝ, E) f x (V x) < 0)
+    (F : Flow ℝ M) (hF : ∀ x, IsMIntegralCurve (fun t => F t x) V) {a b : ℝ} (hab : a ≤ b)
+    (hband : ∀ x, f x ∈ Set.Icc a b → x ∉ Smale.ManifoldMorse.criticalPoints E f) (p : M) :
+    IsCompact
+        {x : { y : M // f y = b } | Filter.Tendsto (fun t => F t (x : M)) Filter.atBot (𝓝 p)} ↔
+      IsCompact
+        {x : { y : M // f y = a } | Filter.Tendsto (fun t => F t (x : M)) Filter.atBot (𝓝 p)} :=
+  isCompact_invariant_section_iff_of_regular_band hf hV hdesc F hF hab hband (P := fun x =>
+    Filter.Tendsto (fun t => F t x) Filter.atBot (𝓝 p))
+    (fun t x => MorseCancel.flow_time_atBot_limit_iff F t x p)
+
+private def
+    Degree.MorseRearrangement.nativeCylinderWeight {Z H N E M : Type*} [NormedAddCommGroup Z]
+    [NormedSpace ℝ Z] [TopologicalSpace H] {I : ModelWithCorners ℝ Z H} [TopologicalSpace N]
+    [ChartedSpace H N] [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace M]
+    [ChartedSpace E M] (A : PartialDiffeomorph (I.prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) (N × ℝ) M ∞) (θ : N → ℝ)
+    (x : M) : ℝ :=
+  θ (A.symm x).1
+
+private theorem Degree.MorseRearrangement.contMDiffOn_nativeCylinderWeight {Z H N E M : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [TopologicalSpace H] {I : ModelWithCorners ℝ Z H}
+    [TopologicalSpace N] [ChartedSpace H N] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M]
+    (A : PartialDiffeomorph (I.prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) (N × ℝ) M ∞) {θ : N → ℝ}
+    (hθ : ContMDiff I 𝓘(ℝ, ℝ) ∞ θ) :
+    ContMDiffOn 𝓘(ℝ, E) 𝓘(ℝ, ℝ) ∞ (nativeCylinderWeight A θ) A.target :=
+  hθ.comp_contMDiffOn (contMDiff_fst.comp_contMDiffOn A.contMDiffOn_invFun)
+
+private theorem Degree.MorseRearrangement.nativeCylinderWeight_mem_Icc {Z H N E M : Type*}
+    [NormedAddCommGroup Z] [NormedSpace ℝ Z] [TopologicalSpace H] {I : ModelWithCorners ℝ Z H}
+    [TopologicalSpace N] [ChartedSpace H N] [NormedAddCommGroup E] [NormedSpace ℝ E]
+    [TopologicalSpace M] [ChartedSpace E M]
+    (A : PartialDiffeomorph (I.prod 𝓘(ℝ, ℝ)) 𝓘(ℝ, E) (N × ℝ) M ∞) {θ : N → ℝ}
+    (hθ : ∀ z, θ z ∈ Set.Icc (0 : ℝ) 1) (x : M) :
+    nativeCylinderWeight A θ x ∈ Set.Icc (0 : ℝ) 1 :=
+  hθ _
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Threefold/SixSphereComplexAtlas.lean b/LeanPool/HopfProblem/Threefold/SixSphereComplexAtlas.lean
new file mode 100644
index 000000000..87da9767c
--- /dev/null
+++ b/LeanPool/HopfProblem/Threefold/SixSphereComplexAtlas.lean
@@ -0,0 +1,96 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.MainTheorem.Core2
+public import LeanPool.HopfProblem.Recognition.Smale13
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods8
+import all LeanPool.HopfProblem.Recognition.Smale7
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods11
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods12
+import all LeanPool.HopfProblem.MainTheorem.Core2
+import all LeanPool.HopfProblem.Recognition.Degree3
+import all LeanPool.HopfProblem.Recognition.Smale13
+
+/-!
+# Hopf problem: threefold · six sphere complex atlas
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold SpecialPeriods.Threefold.space_isSmoothRealManifold
+    SpecialPeriods.Threefold.space_compact SpecialPeriods.Threefold.space_t2Space
+    SpecialPeriods.Threefold.space_secondCountable in
+private def
+    SixSphereComplexAtlas.threefoldHomeomorph : SpecialPeriods.Threefold.Space ≃ₜ unitSphere 6 :=
+  Classical.choice
+    (Smale.homeomorphic_sixSphere_of_homotopySixSphere (ℂ × ComplexPlane₂)
+      SpecialPeriods.Threefold.Space SpecialPeriods.Threefold.real_dimension
+      Degree.threefoldHomotopyEquiv)
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold SpecialPeriods.Threefold.space_isSmoothRealManifold
+    SpecialPeriods.Threefold.space_compact SpecialPeriods.Threefold.space_t2Space
+    SpecialPeriods.Threefold.space_secondCountable in
+private def SixSphereComplexAtlas.modelEquiv : (ℂ × ComplexPlane₂) ≃L[ℂ] EuclideanSpace ℂ (Fin 3) :=
+  SpecialPeriods.Threefold.cuspModelEquiv.symm.trans (EuclideanSpace.equiv (Fin 3) ℂ).symm
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold SpecialPeriods.Threefold.space_isSmoothRealManifold
+    SpecialPeriods.Threefold.space_compact SpecialPeriods.Threefold.space_t2Space
+    SpecialPeriods.Threefold.space_secondCountable in
+public
+theorem SixSphereComplexAtlas.exists_complex_analytic_atlas :
+    ∃ atlas : ChartedSpace (EuclideanSpace ℂ (Fin 3)) (unitSphere 6),
+      letI := atlas
+      IsManifold 𝓘(ℂ, EuclideanSpace ℂ (Fin 3)) ω (unitSphere 6) := by
+  let := ManifoldAtlasTransport.chartedSpace (H := ℂ × ComplexPlane₂) threefoldHomeomorph
+  let := ManifoldAtlasTransport.isManifold 𝓘(ℂ, ℂ × ComplexPlane₂) ω threefoldHomeomorph
+  exact
+    ⟨SpecialPeriods.Threefold.ModelChange.chartedSpace modelEquiv (unitSphere 6),
+      SpecialPeriods.Threefold.ModelChange.isManifold modelEquiv (unitSphere 6) ω⟩
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold SpecialPeriods.Threefold.space_isSmoothRealManifold
+    SpecialPeriods.Threefold.space_compact SpecialPeriods.Threefold.space_t2Space
+    SpecialPeriods.Threefold.space_secondCountable in
+public
+theorem SixSphereComplexAtlas.exists_complex_atlas :
+    ∃ atlas : ChartedSpace (EuclideanSpace ℂ (Fin 3)) (unitSphere 6),
+      letI := atlas
+      IsManifold 𝓘(ℂ, EuclideanSpace ℂ (Fin 3)) 1 (unitSphere 6) := by
+  obtain ⟨atlas, h⟩ := exists_complex_analytic_atlas
+  refine ⟨atlas, ?_⟩
+  let := atlas
+  let := h
+  infer_instance
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Threefold/SpecialPeriods1.lean b/LeanPool/HopfProblem/Threefold/SpecialPeriods1.lean
new file mode 100644
index 000000000..acb8b5e79
--- /dev/null
+++ b/LeanPool/HopfProblem/Threefold/SpecialPeriods1.lean
@@ -0,0 +1,976 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Foundations.Core4
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap1
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Foundations.Core4
+
+/-!
+# Hopf problem: threefold · special periods 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def SpecialPeriods.CuspFamily.logBase (ε : ℝ) : TopologicalSpace.Opens ℂ :=
+  ⟨CuspUniformization.exponential ⁻¹' Metric.ball 0 ε,
+    Metric.isOpen_ball.preimage CuspUniformization.exponential_holomorphic.continuous⟩
+
+private abbrev SpecialPeriods.CuspFamily.LogBase (ε : ℝ) :=
+  logBase ε
+
+@[simp]
+private theorem SpecialPeriods.CuspFamily.mem_logBase (ε : ℝ) (s : ℂ) :
+    s ∈ logBase ε ↔ ‖CuspUniformization.exponential s‖ < ε := by simp [logBase, Metric.mem_ball]
+
+private def SpecialPeriods.CuspFamily.puncturedDisc (ε : ℝ) : TopologicalSpace.Opens ℂ :=
+  ⟨Metric.ball 0 ε ∩ {t | t ≠ 0},
+    Metric.isOpen_ball.inter (isOpen_ne_fun continuous_id continuous_const)⟩
+
+@[simp]
+private theorem SpecialPeriods.CuspFamily.mem_puncturedDisc (ε : ℝ) (t : ℂ) :
+    t ∈ puncturedDisc ε ↔ ‖t‖ < ε ∧ t ≠ 0 := by simp [puncturedDisc, Metric.mem_ball]
+
+private def SpecialPeriods.CuspFamily.baseExponential (ε : ℝ) (s : LogBase ε) : puncturedDisc ε :=
+  ⟨CuspUniformization.exponential s, s.2, CuspUniformization.exponential_ne_zero s⟩
+
+private theorem SpecialPeriods.CuspFamily.baseExponential_surjective (ε : ℝ) :
+    Function.Surjective (baseExponential ε) := by
+  intro t
+  let s : LogBase ε :=
+    ⟨CuspUniformization.logarithm t,
+      by
+      change CuspUniformization.exponential (CuspUniformization.logarithm t) ∈ Metric.ball 0 ε
+      rw [CuspUniformization.exponential_logarithm t.2.2]
+      exact t.2.1⟩
+  exact ⟨s, Subtype.ext (CuspUniformization.exponential_logarithm t.2.2)⟩
+
+private theorem SpecialPeriods.CuspFamily.exponential_sub_int (s : ℂ) (k : ℤ) :
+    CuspUniformization.exponential (s - k) = CuspUniformization.exponential s := by
+  rw [sub_eq_add_neg, ← Int.cast_neg, CuspUniformization.exponential_add,
+    CuspUniformization.exponential_int, mul_one]
+
+private def
+    SpecialPeriods.CuspFamily.logBaseTranslate (ε : ℝ) (k : ℤ) (s : LogBase ε) : LogBase ε :=
+  ⟨(s : ℂ) - k,
+    by
+    change CuspUniformization.exponential ((s : ℂ) - k) ∈ Metric.ball 0 ε
+    rw [exponential_sub_int]
+    exact s.2⟩
+
+@[simp]
+private theorem SpecialPeriods.CuspFamily.logBaseTranslate_coe (ε : ℝ) (k : ℤ) (s : LogBase ε) :
+    (logBaseTranslate ε k s : ℂ) = (s : ℂ) - k :=
+  rfl
+
+@[instance_reducible]
+private def
+    SpecialPeriods.CuspFamily.logBaseAction (ε : ℝ) : MulAction (Multiplicative ℤ) (LogBase ε)
+    where
+  smul g s := logBaseTranslate ε g.toAdd s
+  mul_smul g h
+    s := by
+    apply Subtype.ext
+    change (s : ℂ) - ((g.toAdd + h.toAdd : ℤ) : ℂ) = ((s : ℂ) - h.toAdd) - g.toAdd
+    push_cast
+    abel
+  one_smul
+    s := by
+    apply Subtype.ext
+    change (s : ℂ) - ((1 : Multiplicative ℤ).toAdd : ℂ) = (s : ℂ)
+    simp only [toAdd_one, Int.cast_zero, sub_zero]
+
+private theorem SpecialPeriods.CuspFamily.logBaseTranslate_holomorphic (ε : ℝ) (k : ℤ) :
+    ContMDiff (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) ω (logBaseTranslate ε k) := by
+  intro s
+  have he :
+    ContMDiffAt (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) ω
+        (Subtype.val ∘ logBaseTranslate ε k) s ↔
+      ContMDiffAt (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) ω (logBaseTranslate ε k)
+        s :=
+    ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+  exact he.mp ((contMDiff_subtype_val.sub contMDiff_const) s)
+
+private theorem SpecialPeriods.CuspFamily.logBase_action_holomorphic (ε : ℝ) :
+    letI := logBaseAction ε
+    ∀ g : Multiplicative ℤ,
+      ContMDiff (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) ω
+        (fun s : LogBase ε => g • s) := by
+  let := logBaseAction ε
+  intro g
+  exact logBaseTranslate_holomorphic ε g.toAdd
+
+private theorem SpecialPeriods.CuspFamily.logBase_continuousConstSMul (ε : ℝ) :
+    letI := logBaseAction ε
+    ContinuousConstSMul (Multiplicative ℤ) (LogBase ε) := by
+  let := logBaseAction ε
+  exact ⟨fun g => (logBase_action_holomorphic ε g).continuous⟩
+
+private theorem SpecialPeriods.CuspFamily.logBase_free_action (ε : ℝ) :
+    letI := logBaseAction ε
+    IsCancelSMul (Multiplicative ℤ) (LogBase ε) := by
+  let := logBaseAction ε
+  constructor
+  intro g h s he
+  have hc := congrArg (Subtype.val : LogBase ε → ℂ) he
+  change (s : ℂ) - g.toAdd = (s : ℂ) - h.toAdd at hc
+  apply Multiplicative.toAdd.injective
+  exact_mod_cast sub_right_inj.mp hc
+
+@[simp]
+private theorem SpecialPeriods.CuspFamily.baseExponential_smul (ε : ℝ) (g : Multiplicative ℤ)
+    (s : LogBase ε) :
+    letI := logBaseAction ε
+    baseExponential ε (g • s) = baseExponential ε s := by
+  let := logBaseAction ε
+  apply Subtype.ext
+  exact exponential_sub_int s g.toAdd
+
+private theorem SpecialPeriods.CuspFamily.baseExponential_eq_iff_orbit (ε : ℝ) (s t : LogBase ε) :
+    letI := logBaseAction ε
+    baseExponential ε s = baseExponential ε t ↔ s ∈ MulAction.orbit (Multiplicative ℤ) t := by
+  let := logBaseAction ε
+  constructor
+  · intro h
+    obtain ⟨k, hk⟩ :=
+      (CuspUniformization.exponential_eq_iff (s : ℂ) t).mp (congrArg Subtype.val h)
+    refine ⟨Multiplicative.ofAdd (-k), Subtype.ext ?_⟩
+    change (t : ℂ) - ((-k : ℤ) : ℂ) = (s : ℂ)
+    rw [hk, Int.cast_neg, sub_neg_eq_add]
+  · rintro ⟨g, rfl⟩
+    exact baseExponential_smul ε g t
+
+private def SpecialPeriods.CuspFamily.scalarExponentialChart (s : ℂ) : OpenPartialHomeomorph ℂ ℂ :=
+  CuspUniformization.exponential_holomorphic.contDiffAt.toOpenPartialHomeomorph
+    CuspUniformization.exponential
+    ((CuspUniformization.exponential_hasDerivAt s).hasFDerivAt_equiv
+      (mul_ne_zero (CuspUniformization.exponential_ne_zero s)
+        CuspUniformization.exponential_factor_ne_zero))
+    (by simp)
+
+private theorem SpecialPeriods.CuspFamily.scalarExponentialChart_mem_source (s : ℂ) :
+    s ∈ (scalarExponentialChart s).source :=
+  CuspUniformization.exponential_holomorphic.contDiffAt.mem_toOpenPartialHomeomorph_source
+    ((CuspUniformization.exponential_hasDerivAt s).hasFDerivAt_equiv
+      (mul_ne_zero (CuspUniformization.exponential_ne_zero s)
+        CuspUniformization.exponential_factor_ne_zero))
+    (by simp)
+
+private theorem SpecialPeriods.CuspFamily.scalarExponentialChart_holomorphic (s : ℂ) :
+    ContDiffOn ℂ ω (scalarExponentialChart s) (scalarExponentialChart s).source :=
+  CuspUniformization.exponential_holomorphic.contDiffOn
+
+private theorem SpecialPeriods.CuspFamily.scalarExponentialChart_symm_holomorphic (s : ℂ) :
+    ContDiffOn ℂ ω (scalarExponentialChart s).symm (scalarExponentialChart s).target := by
+  intro t ht
+  exact
+    ((scalarExponentialChart s).contDiffAt_symm ht
+        ((CuspUniformization.exponential_hasDerivAt
+              ((scalarExponentialChart s).symm t)).hasFDerivAt_equiv
+          (mul_ne_zero (CuspUniformization.exponential_ne_zero _)
+            CuspUniformization.exponential_factor_ne_zero))
+        CuspUniformization.exponential_holomorphic.contDiffAt).contDiffWithinAt
+
+private theorem SpecialPeriods.CuspFamily.exponential_isLocalDiffeomorph :
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) ω
+      CuspUniformization.exponential := by
+  intro s
+  refine
+    ⟨{  toPartialEquiv := (scalarExponentialChart s).toPartialEquiv
+        open_source := (scalarExponentialChart s).open_source
+        open_target := (scalarExponentialChart s).open_target
+        contMDiffOn_toFun := (scalarExponentialChart_holomorphic s).contMDiffOn
+        contMDiffOn_invFun := (scalarExponentialChart_symm_holomorphic s).contMDiffOn },
+      scalarExponentialChart_mem_source s, ?_⟩
+  intro t _
+  rfl
+
+private theorem SpecialPeriods.CuspFamily.baseExponential_isLocalDiffeomorph (ε : ℝ) :
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) ω
+      (baseExponential ε) :=
+  isLocalDiffeomorph_restrictOpens (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ)
+    exponential_isLocalDiffeomorph (logBase ε) (puncturedDisc ε)
+    (fun s hs => ⟨hs, CuspUniformization.exponential_ne_zero s⟩)
+
+private theorem SpecialPeriods.CuspFamily.baseExponential_isLocalHomeomorph (ε : ℝ) :
+    IsLocalHomeomorph (baseExponential ε) :=
+  (baseExponential_isLocalDiffeomorph ε).isLocalHomeomorph
+
+private theorem SpecialPeriods.CuspFamily.baseExponential_covering (ε : ℝ) :
+    letI := logBaseAction ε
+    IsQuotientCoveringMap (baseExponential ε) (Multiplicative ℤ) := by
+  let := logBaseAction ε
+  let := logBase_continuousConstSMul ε
+  let := logBase_free_action ε
+  exact
+    quotientCoveringMap_of_localHomeomorph (baseExponential_isLocalHomeomorph ε)
+      (baseExponential_surjective ε) (baseExponential_eq_iff_orbit ε)
+
+private instance SpecialPeriods.CuspFamily.logBaseProductChartedSpace (ε : ℝ) :
+    ChartedSpace (ℂ × ComplexPlane₂) (LogBase ε × ComplexPlane₂) :=
+  inferInstanceAs (ChartedSpace (ModelProd ℂ ComplexPlane₂) (LogBase ε × ComplexPlane₂))
+
+private instance SpecialPeriods.CuspFamily.logBaseProductManifold (ε : ℝ) :
+    IsManifold (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (LogBase ε × ComplexPlane₂) := by
+  rw [modelWithCornersSelf_prod]
+  exact
+    IsManifold.prod (I := (modelWithCornersSelf ℂ ℂ)) (I' :=
+      (modelWithCornersSelf ℂ ComplexPlane₂)) (LogBase ε) ComplexPlane₂
+
+private def SpecialPeriods.CuspFamily.logCoverProductEquiv (ε : ℝ) :
+    CuspUniformization.LogCover ε ≃ (LogBase ε × ComplexPlane₂)
+    where
+  toFun p := (⟨p.1.1, p.2⟩, p.1.2)
+  invFun p := ⟨((p.1 : ℂ), p.2), p.1.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+
+@[simp]
+private theorem SpecialPeriods.CuspFamily.logCoverProductEquiv_snd (ε : ℝ)
+    (p : CuspUniformization.LogCover ε) : (logCoverProductEquiv ε p).2 = p.1.2 :=
+  rfl
+
+private theorem SpecialPeriods.CuspFamily.logCoverProductEquiv_holomorphic (ε : ℝ) :
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (logCoverProductEquiv ε) := by
+  have hb :
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) (modelWithCornersSelf ℂ ℂ) ω
+      (fun p : CuspUniformization.LogCover ε => p.1.1) :=
+    contDiff_fst.contMDiff.comp contMDiff_subtype_val
+  have hb' :
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) (modelWithCornersSelf ℂ ℂ) ω
+      (fun p : CuspUniformization.LogCover ε => (⟨p.1.1, p.2⟩ : LogBase ε)) := by
+    intro p
+    have he :
+      ContMDiffAt (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) (modelWithCornersSelf ℂ ℂ) ω
+          (Subtype.val ∘ fun q : CuspUniformization.LogCover ε => (⟨q.1.1, q.2⟩ : LogBase ε)) p ↔
+        ContMDiffAt (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) (modelWithCornersSelf ℂ ℂ) ω
+          (fun q : CuspUniformization.LogCover ε => (⟨q.1.1, q.2⟩ : LogBase ε)) p :=
+      ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+    exact he.mp (hb p)
+  have hz :
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) (modelWithCornersSelf ℂ ComplexPlane₂)
+      ω (fun p : CuspUniformization.LogCover ε => p.1.2) :=
+    contDiff_snd.contMDiff.comp contMDiff_subtype_val
+  rw [modelWithCornersSelf_prod]
+  exact hb'.prodMk hz
+
+private theorem SpecialPeriods.CuspFamily.logCoverProductEquiv_symm_holomorphic (ε : ℝ) :
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (logCoverProductEquiv ε).symm := by
+  have hb :
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) (modelWithCornersSelf ℂ ℂ) ω
+      (Prod.fst : LogBase ε × ComplexPlane₂ → LogBase ε) := by
+    rw [modelWithCornersSelf_prod]
+    exact contMDiff_fst
+  have hz :
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) (modelWithCornersSelf ℂ ComplexPlane₂)
+      ω (Prod.snd : LogBase ε × ComplexPlane₂ → ComplexPlane₂) := by
+    rw [modelWithCornersSelf_prod]
+    exact contMDiff_snd
+  have hp :
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω
+      (fun p : LogBase ε × ComplexPlane₂ => ((p.1 : ℂ), p.2)) :=
+    (contMDiff_subtype_val.comp hb).prodMk_space hz
+  intro p
+  have he :
+    ContMDiffAt (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+        (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω
+        (Subtype.val ∘ (logCoverProductEquiv ε).symm) p ↔
+      ContMDiffAt (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+        (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (logCoverProductEquiv ε).symm p :=
+    ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+  exact he.mp (hp p)
+
+private def SpecialPeriods.CuspFamily.logCoverProductBiholomorph (ε : ℝ) :
+    Diffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) (CuspUniformization.LogCover ε)
+      (LogBase ε × ComplexPlane₂) ω
+    where
+  toEquiv := logCoverProductEquiv ε
+  contMDiff_toFun := logCoverProductEquiv_holomorphic ε
+  contMDiff_invFun := logCoverProductEquiv_symm_holomorphic ε
+
+/-- Analytic correction data defining a cusp family on a punctured disc. -/
+public
+structure SpecialPeriods.CuspFamily.Data where
+  /-- The diagonal holomorphic correction coefficient. -/
+  μ : ℂ → ℂ
+  /-- The lower-left holomorphic correction coefficient. -/
+  b : ℂ → ℂ
+  /-- The off-diagonal holomorphic correction coefficient. -/
+  h : ℂ → ℂ
+  /-- The radius on which the cusp-family estimates hold. -/
+  radius : ℝ
+  radius_pos : 0 < radius
+  radius_lt_one : radius < 1
+  holomorphic :
+    ∀ i j,
+      ContDiffOn ℂ ω (fun t => SpecialPeriods.cuspCorrection μ b h t i j) (Metric.ball 0 radius)
+  smallDrift : ToricSpace.SmallDrift (SpecialPeriods.cuspCorrection μ b h) radius
+
+/-- The correction matrix associated to cusp-family data. -/
+public
+abbrev SpecialPeriods.CuspFamily.Data.correction (D : SpecialPeriods.CuspFamily.Data) :
+    ℂ → Matrix (Fin 2) (Fin 2) ℂ :=
+  SpecialPeriods.cuspCorrection D.μ D.b D.h
+
+private theorem
+    SpecialPeriods.CuspFamily.Data.logarithmic_height (D : SpecialPeriods.CuspFamily.Data)
+    (s : SpecialPeriods.CuspFamily.LogBase D.radius) :
+    Real.log ‖CuspUniformization.exponential (s : ℂ)‖ < 0 :=
+  Real.log_neg (norm_pos_iff.mpr (CuspUniformization.exponential_ne_zero _))
+    (((SpecialPeriods.CuspFamily.mem_logBase _ _).mp s.2).trans D.radius_lt_one)
+
+private theorem
+    SpecialPeriods.CuspFamily.Data.logarithmic_drift (D : SpecialPeriods.CuspFamily.Data)
+    (s : SpecialPeriods.CuspFamily.LogBase D.radius) :
+    ToricSpace.entryNorm
+        (ToricSpace.driftMatrix D.correction (CuspUniformization.exponential (s : ℂ))) ≤
+      -Real.log ‖CuspUniformization.exponential (s : ℂ)‖ / 4 :=
+  D.smallDrift _ (norm_pos_iff.mpr (CuspUniformization.exponential_ne_zero _))
+    ((SpecialPeriods.CuspFamily.mem_logBase _ _).mp s.2)
+
+private def SpecialPeriods.CuspFamily.Data.point (D : SpecialPeriods.CuspFamily.Data)
+    (s : SpecialPeriods.CuspFamily.LogBase D.radius) : PeriodDomain :=
+  SpecialPeriods.cuspPeriodDomain D.μ D.b D.h s (D.logarithmic_height s) (D.logarithmic_drift s)
+
+private theorem SpecialPeriods.CuspFamily.Data.correction_entry_holomorphic
+    (D : SpecialPeriods.CuspFamily.Data) (i j : Fin 2) :
+    ContMDiff (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) ω
+      (fun s : SpecialPeriods.CuspFamily.LogBase D.radius =>
+        D.correction (CuspUniformization.exponential (s : ℂ)) i j) := by
+  intro s
+  have hC :
+    ContMDiffAt (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) ω
+      (fun t => D.correction t i j) (CuspUniformization.exponential (s : ℂ)) :=
+    ((D.holomorphic i j).contDiffAt (Metric.isOpen_ball.mem_nhds s.2)).contMDiffAt
+  exact
+    hC.comp s
+      ((CuspUniformization.exponential_holomorphic.contMDiff.comp
+          contMDiff_subtype_val).contMDiffAt)
+
+private def SpecialPeriods.CuspFamily.Data.periods (D : SpecialPeriods.CuspFamily.Data) :
+    HolomorphicPeriodMap ℂ (SpecialPeriods.CuspFamily.LogBase D.radius)
+    where
+  point := D.point
+  holomorphic_tau := contMDiff_subtype_val.add (D.correction_entry_holomorphic 0 1)
+  holomorphic_mu := D.correction_entry_holomorphic 1 1
+  holomorphic_beta := by
+    convert (D.correction_entry_holomorphic 1 0).sub contMDiff_subtype_val using 1
+    funext s
+    change
+      D.b (CuspUniformization.exponential (s : ℂ)) - (s : ℂ) -
+          D.h (CuspUniformization.exponential (s : ℂ)) =
+        (D.b (CuspUniformization.exponential (s : ℂ)) -
+            D.h (CuspUniformization.exponential (s : ℂ))) -
+          (s : ℂ)
+    ring
+
+@[simp]
+private theorem SpecialPeriods.CuspFamily.Data.periods_point (D : SpecialPeriods.CuspFamily.Data)
+    (s : SpecialPeriods.CuspFamily.LogBase D.radius) : D.periods.point s = D.point s :=
+  rfl
+
+private theorem SpecialPeriods.CuspFamily.Data.point_leftBlock (D : SpecialPeriods.CuspFamily.Data)
+    (s : SpecialPeriods.CuspFamily.LogBase D.radius) :
+    (D.point s).val.leftBlock = CuspUniformization.logarithmicPeriod D.correction (s : ℂ) :=
+  SpecialPeriods.cuspPeriodPoint_leftBlock D.μ D.b D.h s
+
+private abbrev SpecialPeriods.CuspFamily.Data.TotalSpace (D : SpecialPeriods.CuspFamily.Data) :=
+  D.periods.TotalSpace
+
+private def SpecialPeriods.CuspFamily.Data.familyCover (D : SpecialPeriods.CuspFamily.Data) :
+    CuspUniformization.LogCover D.radius → D.TotalSpace :=
+  D.periods.quotientMap ∘ SpecialPeriods.CuspFamily.logCoverProductEquiv D.radius
+
+@[simp]
+private theorem
+    SpecialPeriods.CuspFamily.Data.familyCover_apply (D : SpecialPeriods.CuspFamily.Data)
+    (x : CuspUniformization.LogCover D.radius) :
+    D.familyCover x = D.periods.quotientMap (⟨x.1.1, x.2⟩, x.1.2) :=
+  rfl
+
+private theorem SpecialPeriods.CuspFamily.Data.familyCover_surjective
+    (D : SpecialPeriods.CuspFamily.Data) : Function.Surjective D.familyCover :=
+  D.periods.quotientMap_surjective.comp
+    (SpecialPeriods.CuspFamily.logCoverProductEquiv D.radius).surjective
+
+private theorem SpecialPeriods.CuspFamily.Data.familyCover_holomorphic
+    (D : SpecialPeriods.CuspFamily.Data) :
+    letI := D.periods.totalChartedSpace
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω D.familyCover := by
+  let := D.periods.totalChartedSpace
+  exact
+    D.periods.quotientMap_holomorphic.comp
+      (SpecialPeriods.CuspFamily.logCoverProductBiholomorph D.radius).contMDiff
+
+private theorem SpecialPeriods.CuspFamily.Data.familyCover_isLocalDiffeomorph
+    (D : SpecialPeriods.CuspFamily.Data) :
+    letI := D.periods.totalChartedSpace
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω D.familyCover := by
+  let := D.periods.totalChartedSpace
+  let := D.periods.coveringAction
+  have hq :=
+    CoveringQuotient.project_isLocalDiffeomorph D.periods.quotientCoveringMap
+      D.periods.coveringAction_holomorphic
+  intro x
+  exact
+    ((SpecialPeriods.CuspFamily.logCoverProductBiholomorph D.radius).isLocalDiffeomorph x).comp
+      (K := modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) (P := D.TotalSpace)
+      (hq (SpecialPeriods.CuspFamily.logCoverProductEquiv D.radius x))
+
+private theorem
+    SpecialPeriods.CuspFamily.Data.quotientMap_eq_iff (D : SpecialPeriods.CuspFamily.Data)
+    (x y : SpecialPeriods.CuspFamily.LogBase D.radius × ComplexPlane₂) :
+    D.periods.quotientMap x = D.periods.quotientMap y ↔
+      x.1 = y.1 ∧ x.2 - y.2 ∈ (D.periods.point y.1).lattice := by
+  rcases x with ⟨s, z⟩
+  rcases y with ⟨t, w⟩
+  constructor
+  · intro he
+    have hs : s = t := congrArg Prod.fst he
+    subst t
+    refine ⟨rfl, ?_⟩
+    apply (Submodule.Quotient.eq _).mp
+    exact (D.periods.fibreInclusion_injective s) he
+  · rintro ⟨hs, he⟩
+    dsimp only at hs he
+    subst t
+    exact congrArg (D.periods.fibreInclusion s) ((Submodule.Quotient.eq _).mpr he)
+
+private theorem
+    SpecialPeriods.CuspFamily.Data.familyCover_eq_iff (D : SpecialPeriods.CuspFamily.Data)
+    (x y : CuspUniformization.LogCover D.radius) :
+    D.familyCover x = D.familyCover y ↔
+      x.1.1 = y.1.1 ∧
+        ∃ m n : Fin 2 → ℤ,
+          x.1.2 =
+            y.1.2 + (fun i => (m i : ℂ)) +
+              CuspUniformization.logarithmicPeriod D.correction y.1.1 *ᵥ (fun i => (n i : ℂ)) := by
+  let s : SpecialPeriods.CuspFamily.LogBase D.radius := ⟨y.1.1, y.2⟩
+  have hlat :
+    (D.periods.point s).lattice =
+      (CuspUniformization.periodData D.correction y.1.1 (D.logarithmic_height s)
+          (D.logarithmic_drift s)).lattice := by
+    exact
+      (SpecialPeriods.cusp_period_lattice_eq D.μ D.b D.h (D.point s) y.1.1 rfl rfl rfl
+          (D.logarithmic_height s) (D.logarithmic_drift s)).symm
+  rw [familyCover_apply, familyCover_apply, D.quotientMap_eq_iff]
+  change
+    (⟨x.1.1, x.2⟩ : SpecialPeriods.CuspFamily.LogBase D.radius) = s ∧
+        x.1.2 - y.1.2 ∈ (D.periods.point s).lattice ↔
+      _
+  rw [hlat, FullPeriodMatrix.mem_lattice_iff]
+  constructor
+  · rintro ⟨hs, m, n, hmn⟩
+    refine ⟨congrArg Subtype.val hs, m, n, ?_⟩
+    change
+      x.1.2 - y.1.2 =
+        (fun i => (m i : ℂ)) +
+          CuspUniformization.logarithmicPeriod D.correction y.1.1 *ᵥ (fun i => (n i : ℂ)) at hmn
+    rw [sub_eq_iff_eq_add] at hmn
+    rw [hmn]
+    abel
+  · rintro ⟨hs, m, n, hmn⟩
+    refine ⟨Subtype.ext hs, m, n, ?_⟩
+    change
+      x.1.2 - y.1.2 =
+        (fun i => (m i : ℂ)) +
+          CuspUniformization.logarithmicPeriod D.correction y.1.1 *ᵥ (fun i => (n i : ℂ))
+    rw [hmn]
+    abel
+
+private def SpecialPeriods.CuspFamily.cuspIntegralMatrix (k : ℤ) : LatticeMatrix :=
+  !![1, 0, 0, 0; 0, 1, 0, 0; 0, k, 1, 0; -k, 0, 0, 1]
+
+@[simp]
+private theorem SpecialPeriods.CuspFamily.cuspIntegralMatrix_zero : cuspIntegralMatrix 0 = 1 := by
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp [cuspIntegralMatrix]
+
+@[simp]
+private theorem SpecialPeriods.CuspFamily.cuspIntegralMatrix_one : cuspIntegralMatrix 1 = M₀ :=
+  rfl
+
+private theorem SpecialPeriods.CuspFamily.cuspIntegralMatrix_add (k l : ℤ) :
+    cuspIntegralMatrix (k + l) = cuspIntegralMatrix k * cuspIntegralMatrix l := by
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp [cuspIntegralMatrix, Matrix.mul_apply, Fin.sum_univ_four]
+  all_goals ring
+
+private def SpecialPeriods.CuspFamily.cuspRealEquiv (k : ℤ) : RealPlane₄ ≃ₗ[ℝ] RealPlane₄
+    where
+  toFun x := ![x 0, x 1, x 2 + (k : ℝ) * x 1, x 3 - (k : ℝ) * x 0]
+  invFun x := ![x 0, x 1, x 2 - (k : ℝ) * x 1, x 3 + (k : ℝ) * x 0]
+  map_add' x
+    y := by
+    ext i
+    fin_cases i <;> simp <;> ring
+  map_smul' a
+    x := by
+    ext i
+    fin_cases i <;> simp [smul_eq_mul] <;> ring
+  left_inv
+    x := by
+    ext i
+    fin_cases i <;> simp
+  right_inv
+    x := by
+    ext i
+    fin_cases i <;> simp
+
+private theorem SpecialPeriods.CuspFamily.cuspRealEquiv_apply (k : ℤ) (x : RealPlane₄) :
+    cuspRealEquiv k x = (cuspIntegralMatrix k).map (Int.castRingHom ℝ) *ᵥ x := by
+  ext i
+  fin_cases i <;>
+      simp [cuspRealEquiv, cuspIntegralMatrix, Matrix.mulVec, dotProduct, Fin.sum_univ_four] <;>
+    ring
+
+@[simp]
+private theorem SpecialPeriods.CuspFamily.cuspRealEquiv_zero :
+    cuspRealEquiv 0 = LinearEquiv.refl ℝ RealPlane₄ := by
+  ext x i
+  fin_cases i <;> simp [cuspRealEquiv]
+
+private theorem SpecialPeriods.CuspFamily.cuspRealEquiv_add_apply (k l : ℤ) (x : RealPlane₄) :
+    cuspRealEquiv (k + l) x = cuspRealEquiv k (cuspRealEquiv l x) := by
+  ext i
+  fin_cases i <;> simp [cuspRealEquiv] <;> ring
+
+@[simp]
+private theorem SpecialPeriods.CuspFamily.cuspRealEquiv_neg (k : ℤ) :
+    cuspRealEquiv (-k) = (cuspRealEquiv k).symm := by
+  ext x i
+  fin_cases i <;> simp [cuspRealEquiv, sub_eq_add_neg]
+
+private theorem SpecialPeriods.CuspFamily.cuspRealEquiv_realCast (k : ℤ) (v : Lattice) :
+    cuspRealEquiv k (Elliptic.realCast v) = Elliptic.realCast (cuspIntegralMatrix k *ᵥ v) := by
+  rw [cuspRealEquiv_apply]
+  ext i
+  exact (RingHom.map_mulVec (Int.castRingHom ℝ) (cuspIntegralMatrix k) v i).symm
+
+private theorem SpecialPeriods.CuspFamily.cuspRealEquiv_complexCast (k : ℤ) (x : RealPlane₄) :
+    (fun i => ((cuspRealEquiv k x) i : ℂ)) =
+      (cuspIntegralMatrix k).map (Int.castRingHom ℂ) *ᵥ (fun i => (x i : ℂ)) := by
+  ext i
+  fin_cases i <;>
+      simp [cuspRealEquiv, cuspIntegralMatrix, Matrix.mulVec, dotProduct, Fin.sum_univ_four] <;>
+    ring
+
+private theorem SpecialPeriods.CuspFamily.cuspRealEquiv_mem_standardLattice (k : ℤ) {x : RealPlane₄}
+    (hx : x ∈ standardLattice) : cuspRealEquiv k x ∈ standardLattice := by
+  obtain ⟨v, rfl⟩ := (Elliptic.standardLattice_mem_iff x).mp hx
+  exact
+    (Elliptic.standardLattice_mem_iff _).mpr
+      ⟨cuspIntegralMatrix k *ᵥ v, cuspRealEquiv_realCast k v⟩
+
+private theorem SpecialPeriods.CuspFamily.cuspRealEquiv_map_standardLattice (k : ℤ) :
+    standardLattice.map ((cuspRealEquiv k).restrictScalars ℤ).toLinearMap = standardLattice := by
+  ext x
+  rw [Submodule.mem_map]
+  constructor
+  · rintro ⟨y, hy, rfl⟩
+    exact cuspRealEquiv_mem_standardLattice k hy
+  · intro hx
+    refine ⟨cuspRealEquiv (-k) x, cuspRealEquiv_mem_standardLattice (-k) hx, ?_⟩
+    change cuspRealEquiv k (cuspRealEquiv (-k) x) = x
+    rw [cuspRealEquiv_neg, LinearEquiv.apply_symm_apply]
+
+/-- The lattice-linear automorphism of the cusp torus with exponent `k`. -/
+public
+def SpecialPeriods.CuspFamily.cuspTorusLinearEquiv (k : ℤ) : RealTorus₄ ≃ₗ[ℤ] RealTorus₄ :=
+  Submodule.Quotient.equiv standardLattice standardLattice ((cuspRealEquiv k).restrictScalars ℤ)
+    (cuspRealEquiv_map_standardLattice k)
+
+/-- The torus homeomorphism induced by the cusp lattice automorphism. -/
+public
+def SpecialPeriods.CuspFamily.cuspTorusHomeomorph (k : ℤ) : RealTorus₄ ≃ₜ RealTorus₄
+    where
+  toEquiv := (cuspTorusLinearEquiv k).toEquiv
+  continuous_toFun := by
+    apply standardLattice.isQuotientMap_mkQ.continuous_iff.mpr
+    exact standardLattice.continuous_mkQ.comp (cuspRealEquiv k).toContinuousLinearEquiv.continuous
+  continuous_invFun := by
+    apply standardLattice.isQuotientMap_mkQ.continuous_iff.mpr
+    exact
+      standardLattice.continuous_mkQ.comp
+        (cuspRealEquiv k).symm.toContinuousLinearEquiv.continuous
+
+private theorem SpecialPeriods.CuspFamily.cuspTorusHomeomorph_mkQ (k : ℤ) (x : RealPlane₄) :
+    cuspTorusHomeomorph k (standardLattice.mkQ x) = standardLattice.mkQ (cuspRealEquiv k x) :=
+  rfl
+
+private theorem SpecialPeriods.CuspFamily.cuspTorusHomeomorph_zero_apply (x : RealTorus₄) :
+    cuspTorusHomeomorph 0 x = x := by
+  obtain ⟨y, rfl⟩ := standardLattice.mkQ_surjective x
+  rw [cuspTorusHomeomorph_mkQ, cuspRealEquiv_zero]
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.CuspFamily.cuspTorusHomeomorph_zero_eq :
+    cuspTorusHomeomorph 0 = Homeomorph.refl RealTorus₄ := by
+  apply Homeomorph.ext
+  exact cuspTorusHomeomorph_zero_apply
+
+private theorem SpecialPeriods.CuspFamily.cuspTorusHomeomorph_add_apply (k l : ℤ) (x : RealTorus₄) :
+    cuspTorusHomeomorph (k + l) x = cuspTorusHomeomorph k (cuspTorusHomeomorph l x) := by
+  obtain ⟨y, rfl⟩ := standardLattice.mkQ_surjective x
+  rw [cuspTorusHomeomorph_mkQ, cuspTorusHomeomorph_mkQ, cuspTorusHomeomorph_mkQ,
+    cuspRealEquiv_add_apply]
+
+@[instance_reducible]
+private def SpecialPeriods.CuspFamily.cuspTorusAction : MulAction (Multiplicative ℤ) RealTorus₄
+    where
+  smul k x := cuspTorusHomeomorph k.toAdd x
+  one_smul := cuspTorusHomeomorph_zero_apply
+  mul_smul k l := cuspTorusHomeomorph_add_apply k.toAdd l.toAdd
+
+@[simp]
+private theorem SpecialPeriods.CuspFamily.cusp_exponential_sub_int (s : ℂ) (k : ℤ) :
+    CuspUniformization.exponential (s - (k : ℂ)) = CuspUniformization.exponential s := by
+  rw [sub_eq_add_neg, ← Int.cast_neg, CuspUniformization.exponential_add,
+    CuspUniformization.exponential_int, mul_one]
+
+private theorem SpecialPeriods.CuspFamily.cuspPeriodPoint_matrix_covariance (μ b h : ℂ → ℂ) (s : ℂ)
+    (k : ℤ) :
+    (SpecialPeriods.cuspPeriodPoint μ b h (s - (k : ℂ))).matrix *
+        (cuspIntegralMatrix k).map (Int.castRingHom ℂ) =
+      (SpecialPeriods.cuspPeriodPoint μ b h s).matrix := by
+  ext i j
+  fin_cases i <;> fin_cases j <;>
+      simp [PeriodPoint.matrix, SpecialPeriods.cuspPeriodPoint, cuspIntegralMatrix,
+        Matrix.mul_apply, Fin.sum_univ_four, cusp_exponential_sub_int] <;>
+    ring
+
+@[instance_reducible]
+private def SpecialPeriods.CuspFamily.Data.totalAction (D : SpecialPeriods.CuspFamily.Data) :
+    MulAction (Multiplicative ℤ) D.TotalSpace := by
+  let := SpecialPeriods.CuspFamily.logBaseAction D.radius
+  let := SpecialPeriods.CuspFamily.cuspTorusAction
+  exact
+    inferInstanceAs
+      (MulAction (Multiplicative ℤ) (SpecialPeriods.CuspFamily.LogBase D.radius × RealTorus₄))
+
+private theorem SpecialPeriods.CuspFamily.Data.totalAction_continuous
+    (D : SpecialPeriods.CuspFamily.Data) :
+    letI := D.totalAction
+    ContinuousConstSMul (Multiplicative ℤ) D.TotalSpace := by
+  let := D.totalAction
+  constructor
+  intro k
+  exact
+    ((SpecialPeriods.CuspFamily.logBaseTranslate_holomorphic D.radius k.toAdd).continuous.comp
+          continuous_fst).prodMk
+      ((SpecialPeriods.CuspFamily.cuspTorusHomeomorph k.toAdd).continuous.comp continuous_snd)
+
+private theorem
+    SpecialPeriods.CuspFamily.Data.periodEquiv_matrix (D : SpecialPeriods.CuspFamily.Data)
+    (s : SpecialPeriods.CuspFamily.LogBase D.radius) (x : RealPlane₄) :
+    D.periods.periodEquiv s x = (D.periods.point s).val.matrix *ᵥ (fun i => (x i : ℂ)) := by
+  rw [HolomorphicPeriodMap.periodEquiv_coordinates]
+  ext i
+  fin_cases i <;> simp [PeriodPoint.matrix, Matrix.mulVec, dotProduct, Fin.sum_univ_four]
+
+private theorem
+    SpecialPeriods.CuspFamily.Data.periodEquiv_monodromy (D : SpecialPeriods.CuspFamily.Data)
+    (k : ℤ) (s : SpecialPeriods.CuspFamily.LogBase D.radius) (x : RealPlane₄) :
+    D.periods.periodEquiv (SpecialPeriods.CuspFamily.logBaseTranslate D.radius k s)
+        (SpecialPeriods.CuspFamily.cuspRealEquiv k x) =
+      D.periods.periodEquiv s x := by
+  rw [D.periodEquiv_matrix, SpecialPeriods.CuspFamily.cuspRealEquiv_complexCast,
+    Matrix.mulVec_mulVec, D.periodEquiv_matrix]
+  change
+    ((SpecialPeriods.cuspPeriodPoint D.μ D.b D.h ((s : ℂ) - (k : ℂ))).matrix *
+          (SpecialPeriods.CuspFamily.cuspIntegralMatrix k).map (Int.castRingHom ℂ)) *ᵥ
+        (fun i => (x i : ℂ)) =
+      _
+  rw [SpecialPeriods.CuspFamily.cuspPeriodPoint_matrix_covariance]
+  rfl
+
+private theorem SpecialPeriods.CuspFamily.Data.periodEquiv_symm_monodromy
+    (D : SpecialPeriods.CuspFamily.Data) (k : ℤ) (s : SpecialPeriods.CuspFamily.LogBase D.radius)
+    (z : ComplexPlane₂) :
+    (D.periods.periodEquiv (SpecialPeriods.CuspFamily.logBaseTranslate D.radius k s)).symm z =
+      SpecialPeriods.CuspFamily.cuspRealEquiv k ((D.periods.periodEquiv s).symm z) := by
+  apply
+    (D.periods.periodEquiv (SpecialPeriods.CuspFamily.logBaseTranslate D.radius k s)).injective
+  rw [LinearEquiv.apply_symm_apply, D.periodEquiv_monodromy, LinearEquiv.apply_symm_apply]
+
+private def SpecialPeriods.CuspFamily.Data.complexLift (D : SpecialPeriods.CuspFamily.Data)
+    (k : Multiplicative ℤ) (x : SpecialPeriods.CuspFamily.LogBase D.radius × ComplexPlane₂) :
+    SpecialPeriods.CuspFamily.LogBase D.radius × ComplexPlane₂ :=
+  (SpecialPeriods.CuspFamily.logBaseTranslate D.radius k.toAdd x.1, x.2)
+
+private theorem SpecialPeriods.CuspFamily.Data.complexLift_quotientMap
+    (D : SpecialPeriods.CuspFamily.Data) (k : Multiplicative ℤ)
+    (x : SpecialPeriods.CuspFamily.LogBase D.radius × ComplexPlane₂) :
+    letI := D.totalAction
+    D.periods.quotientMap (D.complexLift k x) = k • D.periods.quotientMap x := by
+  let := D.totalAction
+  change
+    (SpecialPeriods.CuspFamily.logBaseTranslate D.radius k.toAdd x.1,
+        standardLattice.mkQ
+          ((D.periods.periodEquiv
+                (SpecialPeriods.CuspFamily.logBaseTranslate D.radius k.toAdd x.1)).symm
+            x.2)) =
+      (SpecialPeriods.CuspFamily.logBaseTranslate D.radius k.toAdd x.1,
+        SpecialPeriods.CuspFamily.cuspTorusHomeomorph k.toAdd
+          (standardLattice.mkQ ((D.periods.periodEquiv x.1).symm x.2)))
+  rw [D.periodEquiv_symm_monodromy, SpecialPeriods.CuspFamily.cuspTorusHomeomorph_mkQ]
+
+private theorem SpecialPeriods.CuspFamily.Data.complexLift_holomorphic
+    (D : SpecialPeriods.CuspFamily.Data) (k : Multiplicative ℤ) :
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (D.complexLift k) := by
+  rw [modelWithCornersSelf_prod]
+  exact
+    ((SpecialPeriods.CuspFamily.logBaseTranslate_holomorphic D.radius k.toAdd).comp
+          contMDiff_fst).prodMk
+      contMDiff_snd
+
+private theorem SpecialPeriods.CuspFamily.Data.totalAction_holomorphic
+    (D : SpecialPeriods.CuspFamily.Data) (k : Multiplicative ℤ) :
+    letI := D.periods.totalChartedSpace
+    letI := D.totalAction
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (fun x : D.TotalSpace => k • x) := by
+  let := D.periods.totalChartedSpace
+  let := D.totalAction
+  let := D.periods.coveringAction
+  apply
+    CoveringQuotient.contMDiff_of_comp D.periods.quotientCoveringMap
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω
+  have hf := D.periods.quotientMap_holomorphic.comp (D.complexLift_holomorphic k)
+  exact hf.congr (fun x => (D.complexLift_quotientMap k x).symm)
+
+private theorem SpecialPeriods.CuspFamily.Data.familyCover_logarithmicShift
+    (D : SpecialPeriods.CuspFamily.Data) (k : ℤ) (x : CuspUniformization.LogCover D.radius) :
+    letI := D.totalAction
+    D.familyCover (CuspUniformization.logCoverTransform D.correction D.radius ⟨k, 0, 0⟩ x) =
+      Multiplicative.ofAdd (-k) • D.familyCover x := by
+  let := D.totalAction
+  have he :
+    SpecialPeriods.CuspFamily.logCoverProductEquiv D.radius
+        (CuspUniformization.logCoverTransform D.correction D.radius ⟨k, 0, 0⟩ x) =
+      D.complexLift (Multiplicative.ofAdd (-k))
+        (SpecialPeriods.CuspFamily.logCoverProductEquiv D.radius x) := by
+    apply Prod.ext
+    · apply Subtype.ext
+      change x.1.1 + (k : ℂ) = x.1.1 - ((-k : ℤ) : ℂ)
+      simp only [Int.cast_neg, sub_neg_eq_add]
+    · simp only [SpecialPeriods.CuspFamily.logCoverProductEquiv_snd,
+        CuspUniformization.logCoverTransform_coe, CuspUniformization.logDeckTransform_snd,
+        Pi.zero_apply, Int.cast_zero, ofAdd_neg]
+      change
+        x.1.2 + (0 : ComplexPlane₂) +
+            CuspUniformization.logarithmicPeriod D.correction x.1.1 *ᵥ 0 =
+          x.1.2
+      rw [add_zero, Matrix.mulVec_zero, add_zero]
+  change D.periods.quotientMap (SpecialPeriods.CuspFamily.logCoverProductEquiv D.radius _) = _
+  rw [he, D.complexLift_quotientMap]
+  rfl
+
+private theorem
+    SpecialPeriods.CuspFamily.Data.familyCover_period (D : SpecialPeriods.CuspFamily.Data)
+    (m n : Fin 2 → ℤ) (x : CuspUniformization.LogCover D.radius) :
+    D.familyCover (CuspUniformization.logCoverTransform D.correction D.radius ⟨0, m, n⟩ x) =
+      D.familyCover x := by
+  apply (D.familyCover_eq_iff _ x).mpr
+  refine ⟨?_, m, n, rfl⟩
+  change x.1.1 + ((0 : ℤ) : ℂ) = x.1.1
+  simp
+
+private theorem
+    SpecialPeriods.CuspFamily.Data.familyCover_logDeck (D : SpecialPeriods.CuspFamily.Data)
+    (g : CuspUniformization.LogDeck) (x : CuspUniformization.LogCover D.radius) :
+    letI := D.totalAction
+    D.familyCover (CuspUniformization.logCoverTransform D.correction D.radius g x) =
+      Multiplicative.ofAdd (-g.k) • D.familyCover x := by
+  let := D.totalAction
+  have hg : g = (⟨g.k, 0, 0⟩ : CuspUniformization.LogDeck) * ⟨0, g.m, g.n⟩ := by
+    apply CuspUniformization.LogDeck.ext <;> simp
+  have he :
+    CuspUniformization.logCoverTransform D.correction D.radius g x =
+      CuspUniformization.logCoverTransform D.correction D.radius ⟨g.k, 0, 0⟩
+        (CuspUniformization.logCoverTransform D.correction D.radius ⟨0, g.m, g.n⟩ x) := by
+    apply Subtype.ext
+    exact
+      (congrArg (fun u => CuspUniformization.logDeckTransform D.correction u x) hg).trans
+        (CuspUniformization.logDeckTransform_mul D.correction _ _ x)
+  rw [he, D.familyCover_logarithmicShift, D.familyCover_period]
+
+/-- The quotient total space of a cusp family. -/
+public
+def SpecialPeriods.CuspFamily.Data.Space (D : SpecialPeriods.CuspFamily.Data) : Type :=
+  @MulAction.orbitRel.Quotient (Multiplicative ℤ) D.TotalSpace _ D.totalAction
+
+private instance SpecialPeriods.CuspFamily.Data.spaceTopology (D : SpecialPeriods.CuspFamily.Data) :
+    TopologicalSpace D.Space :=
+  inferInstanceAs
+    (TopologicalSpace
+      (@MulAction.orbitRel.Quotient (Multiplicative ℤ) D.TotalSpace _ D.totalAction))
+
+private def SpecialPeriods.CuspFamily.Data.quotient (D : SpecialPeriods.CuspFamily.Data) :
+    D.TotalSpace → D.Space := by
+  let := D.totalAction
+  exact Quotient.mk (MulAction.orbitRel (Multiplicative ℤ) D.TotalSpace)
+
+private theorem
+    SpecialPeriods.CuspFamily.Data.quotient_surjective (D : SpecialPeriods.CuspFamily.Data) :
+    Function.Surjective D.quotient :=
+  Quotient.mk_surjective
+
+private theorem SpecialPeriods.CuspFamily.Data.quotient_eq_iff (D : SpecialPeriods.CuspFamily.Data)
+    (x y : D.TotalSpace) :
+    letI := D.totalAction
+    D.quotient x = D.quotient y ↔ ∃ k : Multiplicative ℤ, k • y = x :=
+  Quotient.eq''
+
+@[simp]
+private theorem SpecialPeriods.CuspFamily.Data.quotient_smul (D : SpecialPeriods.CuspFamily.Data)
+    (k : Multiplicative ℤ) (x : D.TotalSpace) :
+    letI := D.totalAction
+    D.quotient (k • x) = D.quotient x := by
+  let := D.totalAction
+  exact (D.quotient_eq_iff _ _).mpr ⟨k, rfl⟩
+
+private def SpecialPeriods.CuspFamily.Data.projection (D : SpecialPeriods.CuspFamily.Data) :
+    D.Space → SpecialPeriods.CuspFamily.puncturedDisc D.radius := by
+  let := SpecialPeriods.CuspFamily.logBaseAction D.radius
+  let := D.totalAction
+  exact
+    Quotient.lift (fun x : D.TotalSpace => SpecialPeriods.CuspFamily.baseExponential D.radius x.1)
+      (by
+        rintro x y ⟨k, hk⟩
+        rw [← hk]
+        exact SpecialPeriods.CuspFamily.baseExponential_smul D.radius k y.1)
+
+@[simp]
+private theorem
+    SpecialPeriods.CuspFamily.Data.projection_quotient (D : SpecialPeriods.CuspFamily.Data)
+    (x : D.TotalSpace) :
+    D.projection (D.quotient x) = SpecialPeriods.CuspFamily.baseExponential D.radius x.1 :=
+  rfl
+
+private theorem
+    SpecialPeriods.CuspFamily.Data.quotientCoveringMap (D : SpecialPeriods.CuspFamily.Data) :
+    letI := D.totalAction
+    IsQuotientCoveringMap D.quotient (Multiplicative ℤ) := by
+  let := SpecialPeriods.CuspFamily.logBaseAction D.radius
+  let := D.totalAction
+  let := D.totalAction_continuous
+  refine
+    { toIsQuotientMap := isQuotientMap_quotient_mk'
+      continuous_const_smul := ContinuousConstSMul.continuous_const_smul
+      apply_eq_iff_mem_orbit := Quotient.eq''
+      disjoint := ?_ }
+  intro x
+  obtain ⟨U, hU, hd⟩ := (SpecialPeriods.CuspFamily.baseExponential_covering D.radius).disjoint x.1
+  refine ⟨Prod.fst ⁻¹' U, continuous_fst.continuousAt hU, ?_⟩
+  rintro k ⟨z, ⟨w, hw, rfl⟩, hz⟩
+  exact hd k ⟨k • w.1, ⟨w.1, hw, rfl⟩, hz⟩
+
+@[instance_reducible]
+private def SpecialPeriods.CuspFamily.Data.chartedSpace (D : SpecialPeriods.CuspFamily.Data) :
+    ChartedSpace (ℂ × ComplexPlane₂) D.Space := by
+  let := D.periods.totalChartedSpace
+  let := D.totalAction
+  exact CoveringQuotient.chartedSpace (E := ℂ × ComplexPlane₂) D.quotientCoveringMap
+
+private theorem
+    SpecialPeriods.CuspFamily.Data.quotient_holomorphic (D : SpecialPeriods.CuspFamily.Data) :
+    letI := D.periods.totalChartedSpace
+    letI := D.chartedSpace
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω D.quotient := by
+  let := D.periods.totalChartedSpace
+  let := D.periods.totalSpace_isManifold
+  let := D.totalAction
+  exact CoveringQuotient.contMDiff_project D.quotientCoveringMap ω D.totalAction_holomorphic
+
+private theorem SpecialPeriods.CuspFamily.Data.quotient_isLocalDiffeomorph
+    (D : SpecialPeriods.CuspFamily.Data) :
+    letI := D.periods.totalChartedSpace
+    letI := D.chartedSpace
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω D.quotient := by
+  let := D.periods.totalChartedSpace
+  let := D.periods.totalSpace_isManifold
+  let := D.totalAction
+  exact
+    CoveringQuotient.project_isLocalDiffeomorph D.quotientCoveringMap D.totalAction_holomorphic
+
+/-- The covering map from the logarithmic cover to the cusp-family space. -/
+public
+def SpecialPeriods.CuspFamily.Data.iteratedCover (D : SpecialPeriods.CuspFamily.Data) :
+    CuspUniformization.LogCover D.radius → D.Space :=
+  D.quotient ∘ D.familyCover
+
+private theorem SpecialPeriods.CuspFamily.Data.iteratedCover_surjective
+    (D : SpecialPeriods.CuspFamily.Data) : Function.Surjective D.iteratedCover :=
+  D.quotient_surjective.comp D.familyCover_surjective
+
+private theorem SpecialPeriods.CuspFamily.Data.iteratedCover_holomorphic
+    (D : SpecialPeriods.CuspFamily.Data) :
+    letI := D.chartedSpace
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω D.iteratedCover := by
+  let := D.periods.totalChartedSpace
+  let := D.chartedSpace
+  exact D.quotient_holomorphic.comp D.familyCover_holomorphic
+
+private theorem SpecialPeriods.CuspFamily.Data.iteratedCover_isLocalDiffeomorph
+    (D : SpecialPeriods.CuspFamily.Data) :
+    letI := D.chartedSpace
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω D.iteratedCover := by
+  let := D.periods.totalChartedSpace
+  let := D.chartedSpace
+  intro x
+  exact
+    (D.familyCover_isLocalDiffeomorph x).comp (K := modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (P := D.Space) (D.quotient_isLocalDiffeomorph (D.familyCover x))
+
+@[simp]
+private theorem SpecialPeriods.CuspFamily.Data.projection_iteratedCover
+    (D : SpecialPeriods.CuspFamily.Data) (x : CuspUniformization.LogCover D.radius) :
+    (D.projection (D.iteratedCover x) : ℂ) = CuspUniformization.exponential x.1.1 :=
+  rfl
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Threefold/SpecialPeriods10.lean b/LeanPool/HopfProblem/Threefold/SpecialPeriods10.lean
new file mode 100644
index 000000000..dd7e828d0
--- /dev/null
+++ b/LeanPool/HopfProblem/Threefold/SpecialPeriods10.lean
@@ -0,0 +1,2500 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Elliptic.Core6
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen1
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap1
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Foundations.Core4
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods3
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.PeriodFamily.Core1
+import all LeanPool.HopfProblem.PeriodFamily.Core2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods7
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import all LeanPool.HopfProblem.Elliptic.Core3
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldGluing1
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.Elliptic.Core4
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods8
+import all LeanPool.HopfProblem.Foundations.TwoOpenTransition
+import all LeanPool.HopfProblem.Elliptic.Core5
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods8
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods9
+import all LeanPool.HopfProblem.Toric.DiagonalQuotient2
+import all LeanPool.HopfProblem.Foundations.SplitGroupExtension
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization4
+import all LeanPool.HopfProblem.Pi1.ThreefoldOverlapMappingTorus2
+import all LeanPool.HopfProblem.PeriodFamily.Core3
+import all LeanPool.HopfProblem.Elliptic.Core6
+
+/-!
+# Hopf problem: threefold · special periods 10
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def SpecialPeriods.EllipticAttachingMeridians.clockwiseRegularMeridian (b : Bool) :
+    Path
+      (SpecialPeriods.triangleRegularProject
+        PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+      (SpecialPeriods.triangleRegularProject
+        PeriodFamily.Meridians.normalizedRegularMeridianBasepoint) :=
+  if PeriodFamily.Meridians.normalizationReversesMeridians then
+    PeriodFamily.Meridians.compatibleRegularMeridian b
+  else (PeriodFamily.Meridians.compatibleRegularMeridian b).symm
+
+private theorem
+    SpecialPeriods.EllipticAttachingMeridians.clockwiseRegularMeridian_coordinate (b : Bool)
+    (t : unitInterval) :
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph (clockwiseRegularMeridian b t) =
+      fixedClockwiseMeridian b t := by
+  by_cases ho : 0 < RiemannMapping.normalizationOrientation
+  · have h := PeriodFamily.Meridians.compatibleRegularMeridian_coordinate b t
+    rw [PeriodFamily.Meridians.compatiblePlanarMeridian_eq, ite_eq_left ho] at h
+    simpa only [clockwiseRegularMeridian, PeriodFamily.Meridians.normalizationReversesMeridians,
+      decide_eq_true_eq.mpr ho, ↓reduceIte, fixedClockwiseMeridian] using h
+  · have h := PeriodFamily.Meridians.compatibleRegularMeridian_coordinate b (unitInterval.symm t)
+    rw [PeriodFamily.Meridians.compatiblePlanarMeridian_eq, ite_eq_right ho] at h
+    simpa only [clockwiseRegularMeridian, PeriodFamily.Meridians.normalizationReversesMeridians,
+      decide_eq_false_iff_not.mpr ho, Bool.false_eq_true, ↓reduceIte, fixedClockwiseMeridian,
+      Path.symm_apply, Function.comp_apply] using h
+
+private theorem
+    SpecialPeriods.EllipticAttachingMeridians.clockwiseRegularMeridian_class (b : Bool) :
+    FundamentalGroup.fromPath (Path.Homotopic.Quotient.mk (clockwiseRegularMeridian b)) =
+      if PeriodFamily.Meridians.normalizationReversesMeridians then
+        PeriodFamily.Meridians.compatibleRegularMeridianClass b
+      else (PeriodFamily.Meridians.compatibleRegularMeridianClass b)⁻¹ := by
+  by_cases h : PeriodFamily.Meridians.normalizationReversesMeridians = Bool.true
+  · simp only [clockwiseRegularMeridian, h, ↓reduceIte]
+    rfl
+  · have hn : PeriodFamily.Meridians.normalizationReversesMeridians = Bool.false :=
+      Bool.eq_false_iff.mpr h
+    simp only [clockwiseRegularMeridian, hn, Bool.false_eq_true, ↓reduceIte]
+    rw [FundamentalGroup.inv_def]
+    exact Path.Homotopic.Quotient.mk_symm _
+
+private def SpecialPeriods.EllipticAttachingMeridians.LinearizationControl.analyticMeridianSquare
+    {f : ℂ → ℂ} (D : SpecialPeriods.EllipticAttachingMeridians.LinearizationControl f) (b : Bool)
+    (hc : f 0 = SpecialPeriods.EllipticAttachingMeridians.center b) (A : ℂ) (hA : A ≠ 0)
+    (hAr : ‖A‖ < D.radius) :
+    SpecialPeriods.EllipticAttachingMeridians.LoopSquare (D.analyticCirclePath b hc A hA hAr)
+      (SpecialPeriods.EllipticAttachingMeridians.fixedClockwiseMeridian b) :=
+  (D.analyticCircleSquare b hc A hA hAr).trans
+    (SpecialPeriods.EllipticAttachingMeridians.clockwiseCircleSquare b (deriv f 0 * A)
+      (D.linearCoefficient_ne_zero A hA) (D.linearCoefficient_norm_lt_one A hAr))
+
+private def SpecialPeriods.EllipticAttachingMeridians.LinearizationControl.regularMeridianSquare
+    {f : ℂ → ℂ} (D : SpecialPeriods.EllipticAttachingMeridians.LinearizationControl f) (b : Bool)
+    (hc : f 0 = SpecialPeriods.EllipticAttachingMeridians.center b) (A : ℂ) (hA : A ≠ 0)
+    (hAr : ‖A‖ < D.radius) {a : SpecialPeriods.TriangleRegularQuotient} (p : Path a a)
+    (hp :
+      ∀ t : unitInterval,
+        (SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph (p t) : ℂ) =
+          f (A * SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit t)) :
+    SpecialPeriods.EllipticAttachingMeridians.LoopSquare p
+      (SpecialPeriods.EllipticAttachingMeridians.clockwiseRegularMeridian b) := by
+  let S := D.analyticMeridianSquare b hc A hA hAr
+  refine
+    { map :=
+        ⟨fun tu => SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm (S.map tu),
+          SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm.continuous.comp
+            S.map.continuous⟩
+      initial := ?_
+      final := ?_
+      closed := ?_ }
+  · intro t
+    have he : S.map (0, t) = SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph (p t) := by
+      apply Subtype.ext
+      exact (congrArg Subtype.val (S.initial t)).trans (hp t).symm
+    change SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm (S.map (0, t)) = p t
+    rw [he, SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm_apply_apply]
+  · intro t
+    change
+      SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm (S.map (1, t)) =
+        SpecialPeriods.EllipticAttachingMeridians.clockwiseRegularMeridian b t
+    rw [S.final t, ←
+      SpecialPeriods.EllipticAttachingMeridians.clockwiseRegularMeridian_coordinate b t,
+      SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm_apply_apply]
+  · intro t
+    exact congrArg SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm (S.closed t)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.EllipticGeometry.attachingPlanePartial (j : Elliptic.Kind) :
+    PartialDiffeomorph 𝓘(ℂ) 𝓘(ℂ) ℂ ℂ ω :=
+  (SpecialPeriods.triangleOrbitCoordinatePartial (.inr j)).symm.trans
+    SpecialPeriods.Triangle.trianglePlaneUniformization.toPartialDiffeomorph
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingPlanePartial_source
+    (j : Elliptic.Kind) : (attachingPlanePartial j).source = (SpecialPeriods.unitDisc : Set ℂ) := by
+  change
+    (SpecialPeriods.Triangle.ellipticFullChart j).target ∩
+        (SpecialPeriods.Triangle.ellipticFullChart j).symm ⁻¹'
+          (Set.univ : Set SpecialPeriods.TriangleOrbitSpace) =
+      _
+  rw [Set.preimage_univ, Set.inter_univ, SpecialPeriods.Triangle.ellipticFullChart_target]
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.EllipticGeometry.attachingPlaneCoordinate (j : Elliptic.Kind) :
+    ℂ → ℂ :=
+  attachingPlanePartial j
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingPlaneCoordinate_apply
+    (j : Elliptic.Kind) (q : ℂ) :
+    attachingPlaneCoordinate j q =
+      SpecialPeriods.Triangle.trianglePlaneUniformization
+        ((SpecialPeriods.Triangle.ellipticFullChart j).symm q) :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.EllipticGeometry.attachingPlaneCoordinate_isLocalDiffeomorphAt
+    (j : Elliptic.Kind) {q : ℂ} (hq : q ∈ SpecialPeriods.unitDisc) :
+    IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω (attachingPlaneCoordinate j) q := by
+  apply (attachingPlanePartial j).isLocalDiffeomorphAt _ _ _
+  rwa [attachingPlanePartial_source]
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingPlaneCoordinate_analyticAt
+    (j : Elliptic.Kind) {q : ℂ} (hq : q ∈ SpecialPeriods.unitDisc) :
+    AnalyticAt ℂ (attachingPlaneCoordinate j) q :=
+  (attachingPlaneCoordinate_isLocalDiffeomorphAt j hq).contMDiffAt.contDiffAt.analyticAt
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingPlaneCoordinate_deriv_ne_zero
+    (j : Elliptic.Kind) {q : ℂ} (hq : q ∈ SpecialPeriods.unitDisc) :
+    deriv (attachingPlaneCoordinate j) q ≠ 0 :=
+  SpecialPeriods.MuTorsor.SourceOrders.deriv_ne_zero_of_isLocalDiffeomorph
+    (attachingPlaneCoordinate_isLocalDiffeomorphAt j hq)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingPlaneCoordinate_analyticAt_zero
+    (j : Elliptic.Kind) : AnalyticAt ℂ (attachingPlaneCoordinate j) 0 :=
+  attachingPlaneCoordinate_analyticAt j (by simp [SpecialPeriods.unitDisc])
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.EllipticGeometry.attachingPlaneCoordinate_deriv_zero_ne_zero
+    (j : Elliptic.Kind) : deriv (attachingPlaneCoordinate j) 0 ≠ 0 :=
+  attachingPlaneCoordinate_deriv_ne_zero j (by simp [SpecialPeriods.unitDisc])
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingPlaneCoordinate_zero
+    (j : Elliptic.Kind) :
+    attachingPlaneCoordinate j 0 =
+      SpecialPeriods.Triangle.trianglePlaneUniformization
+        (SpecialPeriods.Triangle.ellipticOrbitCenter j) := by
+  rw [attachingPlaneCoordinate_apply, ← SpecialPeriods.Triangle.ellipticFullChart_center j]
+  rw [(SpecialPeriods.Triangle.ellipticFullChart j).left_inv
+      (SpecialPeriods.Triangle.ellipticFullChart_center_mem_source j)]
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingPlaneCoordinate_three_zero :
+    attachingPlaneCoordinate .three 0 = 0 := by
+  rw [attachingPlaneCoordinate_zero, SpecialPeriods.Triangle.ellipticOrbitCenter_three,
+    SpecialPeriods.Triangle.trianglePlaneUniformization_centerOne]
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingPlaneCoordinate_four_zero :
+    attachingPlaneCoordinate .four 0 = 1 := by
+  rw [attachingPlaneCoordinate_zero, SpecialPeriods.Triangle.ellipticOrbitCenter_four,
+    SpecialPeriods.Triangle.trianglePlaneUniformization_centerTwo]
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.EllipticGeometry.attaching_compactInverse_eq (j : Elliptic.Kind)
+    (q : ℂ) :
+    (SpecialPeriods.Threefold.punctureChart (Option.some j)).symm q =
+      SpecialPeriods.triangleOpenInclusion
+        ((SpecialPeriods.Triangle.ellipticFullChart j).symm q) :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingPlaneCoordinate_compactInverse
+    (j : Elliptic.Kind) (q : ℂ) :
+    SpecialPeriods.Triangle.triangleSphereUniformization
+        ((SpecialPeriods.Threefold.punctureChart (Option.some j)).symm q) =
+      ((attachingPlaneCoordinate j q : ℂ) : RiemannSphere) := by
+  rw [attaching_compactInverse_eq,
+    SpecialPeriods.Triangle.triangleSphereUniformization_openInclusion]
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingPlaneCoordinate_eq_regularPlane
+    (j : Elliptic.Kind) (q : ℂ) (x : SpecialPeriods.TriangleRegularQuotient)
+    (hx :
+      SpecialPeriods.Threefold.regularInclusion x =
+        (SpecialPeriods.Threefold.punctureChart (Option.some j)).symm q) :
+    (SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph x : ℂ) =
+      attachingPlaneCoordinate j q := by
+  apply OnePoint.coe_injective (X := ℂ)
+  calc
+    ((SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph x : ℂ) : RiemannSphere) =
+        SpecialPeriods.Triangle.triangleSphereUniformization
+          (SpecialPeriods.Threefold.regularInclusion x) :=
+      rfl
+    _ =
+        SpecialPeriods.Triangle.triangleSphereUniformization
+          ((SpecialPeriods.Threefold.punctureChart (Option.some j)).symm q) :=
+      (congrArg SpecialPeriods.Triangle.triangleSphereUniformization hx)
+    _ = ((attachingPlaneCoordinate j q : ℂ) : RiemannSphere) :=
+      attachingPlaneCoordinate_compactInverse j q
+
+private def SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex : Elliptic.Kind → Bool
+  | .three => Bool.false
+  | .four => Bool.true
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingPlaneCoordinate_zero_eq_center
+    (j : Elliptic.Kind) :
+    attachingPlaneCoordinate j 0 =
+      SpecialPeriods.EllipticAttachingMeridians.center (attachingMeridianIndex j) := by
+  cases j with
+  | three => exact attachingPlaneCoordinate_three_zero
+  | four => exact attachingPlaneCoordinate_four_zero
+
+private def SpecialPeriods.Threefold.EllipticGeometry.attachingPlaneControl (j : Elliptic.Kind) :
+    SpecialPeriods.EllipticAttachingMeridians.LinearizationControl (attachingPlaneCoordinate j) :=
+  SpecialPeriods.EllipticAttachingMeridians.analyticLinearizationControl
+    (attachingPlaneCoordinate_analyticAt_zero j) (attachingPlaneCoordinate_deriv_zero_ne_zero j)
+
+private def
+    SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianRadius (j : Elliptic.Kind) : ℝ :=
+  Min.min (SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (attachingPlaneControl j).radius
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianRadius_pos
+    (j : Elliptic.Kind) : 0 < attachingMeridianRadius j :=
+  lt_min (SpecialPeriods.Threefold.specialBaseCover.radius_pos (Option.some j))
+    (attachingPlaneControl j).radius_pos
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianRadius_le_filling
+    (j : Elliptic.Kind) :
+    attachingMeridianRadius j ≤
+      SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j) :=
+  min_le_left _ _
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianRadius_le_control
+    (j : Elliptic.Kind) : attachingMeridianRadius j ≤ (attachingPlaneControl j).radius :=
+  min_le_right _ _
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.exists_small_attaching_parameters
+    (j : Elliptic.Kind) :
+    ∃ s₀ : ℂ,
+      0 < s₀.im ∧ ‖CuspUniformization.exponential s₀‖ ^ j.order < attachingMeridianRadius j :=
+  Elliptic.LogGauge.exists_logMeridian_parameters j (attachingMeridianRadius j)
+    (attachingMeridianRadius_pos j)
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attaching_parameters_filling_bound
+    (j : Elliptic.Kind) {s₀ : ℂ}
+    (hr : ‖CuspUniformization.exponential s₀‖ ^ j.order < attachingMeridianRadius j) :
+    ‖CuspUniformization.exponential s₀‖ ^ j.order <
+      SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j) :=
+  hr.trans_le (attachingMeridianRadius_le_filling j)
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attaching_parameters_control_bound
+    (j : Elliptic.Kind) {s₀ : ℂ}
+    (hr : ‖CuspUniformization.exponential s₀‖ ^ j.order < attachingMeridianRadius j) :
+    ‖CuspUniformization.exponential s₀ ^ j.order‖ < (attachingPlaneControl j).radius := by
+  rw [norm_pow]
+  exact hr.trans_le (attachingMeridianRadius_le_control j)
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attaching_initial_coordinate_ne_zero
+    (j : Elliptic.Kind) (s₀ : ℂ) : CuspUniformization.exponential s₀ ^ j.order ≠ 0 :=
+  pow_ne_zero j.order (CuspUniformization.exponential_ne_zero s₀)
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attaching_log_parameter_clockwise
+    (j : Elliptic.Kind) (s₀ : ℂ) (t : (unitInterval)) :
+    CuspUniformization.exponential (s₀ - ((t : ℝ) : ℂ) / (j.order : ℂ)) ^ j.order =
+      CuspUniformization.exponential s₀ ^ j.order *
+        SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit t := by
+  have hn : (j.order : ℂ) ≠ 0 := by exact_mod_cast j.order_pos.ne'
+  simp only [CuspUniformization.exponential,
+    SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit, ← Complex.exp_nat_mul,
+    ← Complex.exp_add]
+  congr 1
+  field_simp
+  ring
+
+public
+theorem SpecialPeriods.EllipticAttachingMeridians.homotopic_conjugate_map_eq {X : Type*}
+    [TopologicalSpace X] {b : X} {G : Type*} [Group G] {p q : Path b b} (K : Path b b)
+    (h : p.Homotopic (K.trans (q.trans K.symm))) (φ : FundamentalGroup X b →* G)
+    (hcomm : ∀ g h : G, Commute g h) :
+    φ (FundamentalGroup.fromPath (Path.Homotopic.Quotient.mk p)) =
+      φ (FundamentalGroup.fromPath (Path.Homotopic.Quotient.mk q)) := by
+  have hclass :
+    FundamentalGroup.fromPath (Path.Homotopic.Quotient.mk p) =
+      (FundamentalGroup.fromPath (Path.Homotopic.Quotient.mk K))⁻¹ *
+          FundamentalGroup.fromPath (Path.Homotopic.Quotient.mk q) *
+        FundamentalGroup.fromPath (Path.Homotopic.Quotient.mk K) :=
+    Path.Homotopic.Quotient.eq.mpr h
+  rw [hclass, map_mul, map_mul, map_inv]
+  exact (hcomm _ _).inv_mul_cancel
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.LoopSquare.map_whisker_eq {X : Type*}
+    [TopologicalSpace X] {a b : X} {G : Type*} [Group G] {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) (τ : Path b a)
+    (φ : FundamentalGroup X b →* G) (hcomm : ∀ g h : G, Commute g h) :
+    φ (FundamentalGroup.fromPath (Path.Homotopic.Quotient.mk (τ.trans (p.trans τ.symm)))) =
+      φ (FundamentalGroup.fromPath (Path.Homotopic.Quotient.mk q)) :=
+  SpecialPeriods.EllipticAttachingMeridians.homotopic_conjugate_map_eq (τ.trans S.tail)
+    (S.homotopic_whisker_conjugate τ) φ hcomm
+
+private abbrev
+    SpecialPeriods.Threefold.EllipticGeometry.attachingFullLoop (j : Elliptic.Kind) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im) :=
+  Elliptic.LogGauge.logMeridianLoop (SpecialPeriods.EllipticFilling.specialLocalData j) j.twist
+    (Elliptic.mainTwist_admissible j) s₀ hs₀
+
+@[simp]
+private theorem
+    SpecialPeriods.Threefold.EllipticGeometry.attachingFullLoop_projection (j : Elliptic.Kind)
+    (s₀ : ℂ) (hs₀ : 0 < s₀.im) (t : (unitInterval)) :
+    (SpecialPeriods.EllipticFilling.specialFullFillingProjection j
+          (attachingFullLoop j s₀ hs₀ t) :
+        ℂ) =
+      (Elliptic.LogGauge.logMeridianRoot j s₀ hs₀ t : ℂ) ^ j.order :=
+  rfl
+
+private theorem
+    SpecialPeriods.Threefold.EllipticGeometry.attachingFullLoop_mem_piece (j : Elliptic.Kind)
+    (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (t : (unitInterval)) :
+    attachingFullLoop j s₀ hs₀ t ∈
+      SpecialPeriods.EllipticFilling.pieceDomain SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+        SpecialPeriods.Threefold.specialBaseCover j := by
+  change
+    ‖(SpecialPeriods.EllipticFilling.specialFullFillingProjection j
+            (attachingFullLoop j s₀ hs₀ t) :
+          ℂ)‖ <
+      _
+  rw [attachingFullLoop_projection, Elliptic.LogGauge.logMeridianRoot_pow_norm]
+  exact hr
+
+private def
+    SpecialPeriods.Threefold.EllipticGeometry.attachingBasepoint (j : Elliptic.Kind) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    LocalSpace j :=
+  ⟨attachingFullLoop j s₀ hs₀ 0, attachingFullLoop_mem_piece j s₀ hs₀ hr 0⟩
+
+private def SpecialPeriods.Threefold.EllipticGeometry.attachingLoop (j : Elliptic.Kind) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    Path (attachingBasepoint j s₀ hs₀ hr) (attachingBasepoint j s₀ hs₀ hr)
+    where
+  toFun t := ⟨attachingFullLoop j s₀ hs₀ t, attachingFullLoop_mem_piece j s₀ hs₀ hr t⟩
+  continuous_toFun := (attachingFullLoop j s₀ hs₀).continuous.subtype_mk _
+  source' := rfl
+  target' := Subtype.ext (attachingFullLoop j s₀ hs₀).target
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.parameter_attachingLoop_ne_zero
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (t : (unitInterval)) : parameter j (attachingLoop j s₀ hs₀ hr t) ≠ 0 :=
+  pow_ne_zero j.order (Elliptic.LogGauge.logMeridianRoot_ne_zero j s₀ hs₀ t)
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.projectionToBase_attachingLoop
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (t : (unitInterval)) :
+    SpecialPeriods.Threefold.specialEllipticPieceProjectionToBase j
+        (attachingLoop j s₀ hs₀ hr t) =
+      (SpecialPeriods.Threefold.punctureChart (Option.some j)).symm
+        ((Elliptic.LogGauge.logMeridianRoot j s₀ hs₀ t : ℂ) ^ j.order) :=
+  rfl
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.projectionToBase_attachingLoop_mem_regular
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (t : (unitInterval)) :
+    SpecialPeriods.Threefold.specialEllipticPieceProjectionToBase j
+        (attachingLoop j s₀ hs₀ hr t) ∈
+      SpecialPeriods.Threefold.regularPatch :=
+  (SpecialPeriods.EllipticFilling.pieceProjectionToBase_mem_regular_iff
+        SpecialPeriods.specialPeriodMap SpecialPeriods.specialPeriodMap_generator₁
+        SpecialPeriods.specialPeriodMap_generator₂ SpecialPeriods.Threefold.specialBaseCover j
+        _).mpr
+    (parameter_attachingLoop_ne_zero j s₀ hs₀ hr t)
+
+private def SpecialPeriods.Threefold.EllipticGeometry.pieceSurfaceRetractionFundamentalGroupEquiv
+    (j : Elliptic.Kind) (x : LocalSpace j) :
+    FundamentalGroup (LocalSpace j) x ≃*
+      FundamentalGroup (SpecialPeriods.EllipticFilling.SpecialCentralSurface j)
+        (pieceSurfaceRetraction j x) :=
+  EllipticRetractionTopology.fundamentalGroupEquivAt (pieceSurfaceHomotopyEquiv j).symm x
+
+private abbrev
+    SpecialPeriods.Threefold.EllipticGeometry.attachingFlatBase (j : Elliptic.Kind) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im) : RealPlane₄ :=
+  Elliptic.LogGauge.logMeridianFlat (SpecialPeriods.EllipticFilling.specialLocalData j) j.twist s₀
+    hs₀ 0
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.pieceSurfaceRetraction_attachingBasepoint
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    pieceSurfaceRetraction j (attachingBasepoint j s₀ hs₀ hr) =
+      Elliptic.affineCoverProjection j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+        (Elliptic.mainTwist_admissible j) (attachingFlatBase j s₀ hs₀) :=
+  Elliptic.LogGauge.fillingSurfaceRetraction_quotient_flat
+    (SpecialPeriods.EllipticFilling.specialLocalData j) j.twist (Elliptic.mainTwist_admissible j)
+    (Elliptic.LogGauge.logMeridianRoot j s₀ hs₀ 0) (attachingFlatBase j s₀ hs₀)
+
+private def
+    SpecialPeriods.Threefold.EllipticGeometry.attachingDeckEquiv (j : Elliptic.Kind) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    FundamentalGroup (LocalSpace j) (attachingBasepoint j s₀ hs₀ hr) ≃*
+      Elliptic.AffineDeckGroup j j.twist :=
+  (pieceSurfaceRetractionFundamentalGroupEquiv j (attachingBasepoint j s₀ hs₀ hr)).trans
+    ((MulEquiv.cast (M :=
+          FundamentalGroup (SpecialPeriods.EllipticFilling.SpecialCentralSurface j))
+          (pieceSurfaceRetraction_attachingBasepoint j s₀ hs₀ hr)).trans
+      (Elliptic.surfaceFundamentalGroupDeckEquiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+        (Elliptic.mainTwist_admissible j) (attachingFlatBase j s₀ hs₀)))
+
+private def
+    SpecialPeriods.Threefold.EllipticGeometry.attachingRetractionLoop (j : Elliptic.Kind) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    Path
+      (Elliptic.affineCoverProjection j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+        (Elliptic.mainTwist_admissible j) (attachingFlatBase j s₀ hs₀))
+      (Elliptic.affineCoverProjection j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+        (Elliptic.mainTwist_admissible j) (attachingFlatBase j s₀ hs₀)) :=
+  ((attachingLoop j s₀ hs₀ hr).map (pieceSurfaceRetraction j).continuous).cast
+    (pieceSurfaceRetraction_attachingBasepoint j s₀ hs₀ hr).symm
+    (pieceSurfaceRetraction_attachingBasepoint j s₀ hs₀ hr).symm
+
+private theorem
+    SpecialPeriods.Threefold.EllipticGeometry.attachingRetractionLoop_eq (j : Elliptic.Kind)
+    (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    attachingRetractionLoop j s₀ hs₀ hr =
+      Elliptic.LogGauge.logMeridianSurfaceLoop (SpecialPeriods.EllipticFilling.specialLocalData j)
+        j.twist (Elliptic.mainTwist_admissible j) s₀ hs₀ := by
+  ext t
+  rfl
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingDeckEquiv_attachingLoop
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    attachingDeckEquiv j s₀ hs₀ hr (FundamentalGroup.fromPath ⟦attachingLoop j s₀ hs₀ hr⟧) =
+      (Elliptic.deckGenerator j j.twist)⁻¹ := by
+  change
+    Elliptic.surfaceFundamentalGroupDeckEquiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+        (Elliptic.mainTwist_admissible j) (attachingFlatBase j s₀ hs₀)
+        (MulEquiv.cast (M :=
+          FundamentalGroup (SpecialPeriods.EllipticFilling.SpecialCentralSurface j))
+          (pieceSurfaceRetraction_attachingBasepoint j s₀ hs₀ hr)
+          (FundamentalGroup.fromPath
+            ⟦(attachingLoop j s₀ hs₀ hr).map (pieceSurfaceRetraction j).continuous⟧)) =
+      _
+  rw [Elliptic.LogGauge.fundamentalGroup_cast_loop]
+  change
+    Elliptic.surfaceFundamentalGroupDeckEquiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+        (Elliptic.mainTwist_admissible j) (attachingFlatBase j s₀ hs₀)
+        (FundamentalGroup.fromPath ⟦attachingRetractionLoop j s₀ hs₀ hr⟧) =
+      _
+  rw [attachingRetractionLoop_eq]
+  exact
+    Elliptic.LogGauge.surfaceFundamentalGroupDeckEquiv_logMeridian
+      (SpecialPeriods.EllipticFilling.specialLocalData j) j.twist
+      (Elliptic.mainTwist_admissible j) s₀ hs₀
+
+private abbrev SpecialPeriods.Threefold.EllipticGeometry.attachingFibreFullLoop (j : Elliptic.Kind)
+    (s₀ : ℂ) (hs₀ : 0 < s₀.im) (w : Lattice) :=
+  Elliptic.LogGauge.fibreTranslationLoop (SpecialPeriods.EllipticFilling.specialLocalData j)
+    j.twist (Elliptic.mainTwist_admissible j) (Elliptic.LogGauge.logMeridianRoot j s₀ hs₀ 0)
+    (attachingFlatBase j s₀ hs₀) w
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingFibreFullLoop_projection
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im) (w : Lattice) (t : (unitInterval)) :
+    (SpecialPeriods.EllipticFilling.specialFullFillingProjection j
+          (attachingFibreFullLoop j s₀ hs₀ w t) :
+        ℂ) =
+      CuspUniformization.exponential s₀ ^ j.order := by
+  change (Elliptic.LogGauge.logMeridianRoot j s₀ hs₀ 0 : ℂ) ^ j.order = _
+  rw [Elliptic.LogGauge.logMeridianRoot_zero]
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingFibreFullLoop_mem_piece
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (w : Lattice) (t : (unitInterval)) :
+    attachingFibreFullLoop j s₀ hs₀ w t ∈
+      SpecialPeriods.EllipticFilling.pieceDomain SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+        SpecialPeriods.Threefold.specialBaseCover j := by
+  change
+    ‖(SpecialPeriods.EllipticFilling.specialFullFillingProjection j
+            (attachingFibreFullLoop j s₀ hs₀ w t) :
+          ℂ)‖ <
+      _
+  rw [attachingFibreFullLoop_projection, norm_pow]
+  exact hr
+
+private def
+    SpecialPeriods.Threefold.EllipticGeometry.attachingFibreLoop (j : Elliptic.Kind) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (w : Lattice) : Path (attachingBasepoint j s₀ hs₀ hr) (attachingBasepoint j s₀ hs₀ hr)
+    where
+  toFun
+    t := ⟨attachingFibreFullLoop j s₀ hs₀ w t, attachingFibreFullLoop_mem_piece j s₀ hs₀ hr w t⟩
+  continuous_toFun := (attachingFibreFullLoop j s₀ hs₀ w).continuous.subtype_mk _
+  source' := Subtype.ext (attachingFibreFullLoop j s₀ hs₀ w).source
+  target' := Subtype.ext (attachingFibreFullLoop j s₀ hs₀ w).target
+
+@[simp]
+private theorem
+    SpecialPeriods.Threefold.EllipticGeometry.parameter_attachingFibreLoop (j : Elliptic.Kind)
+    (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (w : Lattice) (t : (unitInterval)) :
+    parameter j (attachingFibreLoop j s₀ hs₀ hr w t) =
+      CuspUniformization.exponential s₀ ^ j.order :=
+  attachingFibreFullLoop_projection j s₀ hs₀ w t
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.parameter_attachingFibreLoop_ne_zero
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (w : Lattice) (t : (unitInterval)) : parameter j (attachingFibreLoop j s₀ hs₀ hr w t) ≠ 0 := by
+  rw [parameter_attachingFibreLoop]
+  exact pow_ne_zero j.order (CuspUniformization.exponential_ne_zero s₀)
+
+private theorem
+    SpecialPeriods.Threefold.EllipticGeometry.projectionToBase_attachingFibreLoop_mem_regular
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (w : Lattice) (t : (unitInterval)) :
+    SpecialPeriods.Threefold.specialEllipticPieceProjectionToBase j
+        (attachingFibreLoop j s₀ hs₀ hr w t) ∈
+      SpecialPeriods.Threefold.regularPatch :=
+  (SpecialPeriods.EllipticFilling.pieceProjectionToBase_mem_regular_iff
+        SpecialPeriods.specialPeriodMap SpecialPeriods.specialPeriodMap_generator₁
+        SpecialPeriods.specialPeriodMap_generator₂ SpecialPeriods.Threefold.specialBaseCover j
+        _).mpr
+    (parameter_attachingFibreLoop_ne_zero j s₀ hs₀ hr w t)
+
+private def
+    SpecialPeriods.Threefold.EllipticGeometry.attachingFibreRetractionLoop (j : Elliptic.Kind)
+    (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (w : Lattice) :
+    Path
+      (Elliptic.affineCoverProjection j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+        (Elliptic.mainTwist_admissible j) (attachingFlatBase j s₀ hs₀))
+      (Elliptic.affineCoverProjection j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+        (Elliptic.mainTwist_admissible j) (attachingFlatBase j s₀ hs₀)) :=
+  ((attachingFibreLoop j s₀ hs₀ hr w).map (pieceSurfaceRetraction j).continuous).cast
+    (pieceSurfaceRetraction_attachingBasepoint j s₀ hs₀ hr).symm
+    (pieceSurfaceRetraction_attachingBasepoint j s₀ hs₀ hr).symm
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingFibreRetractionLoop_eq
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (w : Lattice) :
+    attachingFibreRetractionLoop j s₀ hs₀ hr w =
+      Elliptic.LogGauge.fibreTranslationSurfaceLoop
+        (SpecialPeriods.EllipticFilling.specialLocalData j) j.twist
+        (Elliptic.mainTwist_admissible j) (Elliptic.LogGauge.logMeridianRoot j s₀ hs₀ 0)
+        (attachingFlatBase j s₀ hs₀) w := by
+  ext t
+  rfl
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingDeckEquiv_attachingFibreLoop
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (w : Lattice) :
+    attachingDeckEquiv j s₀ hs₀ hr
+        (FundamentalGroup.fromPath ⟦attachingFibreLoop j s₀ hs₀ hr w⟧) =
+      Elliptic.deckTranslationHom j j.twist (Multiplicative.ofAdd (-w)) := by
+  change
+    Elliptic.surfaceFundamentalGroupDeckEquiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+        (Elliptic.mainTwist_admissible j) (attachingFlatBase j s₀ hs₀)
+        (MulEquiv.cast (M :=
+          FundamentalGroup (SpecialPeriods.EllipticFilling.SpecialCentralSurface j))
+          (pieceSurfaceRetraction_attachingBasepoint j s₀ hs₀ hr)
+          (FundamentalGroup.fromPath
+            ⟦(attachingFibreLoop j s₀ hs₀ hr w).map (pieceSurfaceRetraction j).continuous⟧)) =
+      _
+  rw [Elliptic.LogGauge.fundamentalGroup_cast_loop]
+  change
+    Elliptic.surfaceFundamentalGroupDeckEquiv j
+        (SpecialPeriods.EllipticFilling.specialLocalData j).centralPeriod j.twist
+        (Elliptic.mainTwist_admissible j) (attachingFlatBase j s₀ hs₀)
+        (FundamentalGroup.fromPath ⟦attachingFibreRetractionLoop j s₀ hs₀ hr w⟧) =
+      _
+  rw [attachingFibreRetractionLoop_eq]
+  exact
+    Elliptic.LogGauge.fibreTranslationSurfaceLoop_deck
+      (SpecialPeriods.EllipticFilling.specialLocalData j) j.twist
+      (Elliptic.mainTwist_admissible j) (Elliptic.LogGauge.logMeridianRoot j s₀ hs₀ 0)
+      (attachingFlatBase j s₀ hs₀) w
+
+attribute [local instance] SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+private def
+    SpecialPeriods.Threefold.EllipticGeometry.attachingUpstairsPoint (j : Elliptic.Kind) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im) (t : (unitInterval)) : SpecialPeriods.TriangleRegularPoint :=
+  SpecialPeriods.EllipticFilling.localBase j
+    (Elliptic.LogGauge.logMeridianRootStar (j := j) s₀ hs₀ t)
+
+attribute [local instance] SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingUpstairsPoint_continuous
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im) :
+    Continuous (attachingUpstairsPoint j s₀ hs₀) :=
+  (SpecialPeriods.EllipticFilling.localBase_continuous j).comp
+    (Elliptic.LogGauge.logMeridianRootStar_continuous s₀ hs₀)
+
+attribute [local instance] SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.EllipticGeometry.attachingUpstairsPoint_one (j : Elliptic.Kind)
+    (s₀ : ℂ) (hs₀ : 0 < s₀.im) :
+    attachingUpstairsPoint j s₀ hs₀ 1 =
+      SpecialPeriods.Triangle.ellipticGenerator j • attachingUpstairsPoint j s₀ hs₀ 0 := by
+  have hr :
+    Elliptic.LogGauge.logMeridianRootStar (j := j) s₀ hs₀ 1 =
+      SpecialPeriods.EllipticFilling.puncturedRotation j
+        (Elliptic.LogGauge.logMeridianRootStar (j := j) s₀ hs₀ 0) :=
+    Subtype.ext (Elliptic.LogGauge.logMeridianRoot_one j s₀ hs₀)
+  unfold attachingUpstairsPoint
+  rw [hr, SpecialPeriods.EllipticFilling.localBase_rotation]
+
+attribute [local instance] SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingFlatBase_eq_negativeLog
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im) :
+    attachingFlatBase j s₀ hs₀ =
+      ((SpecialPeriods.EllipticFilling.specialLocalData j).periods.periodEquiv
+            (Elliptic.LogGauge.logMeridianRoot j s₀ hs₀ 0)).symm
+        (-s₀ •
+          Elliptic.LogGauge.periodVector
+            (SpecialPeriods.EllipticFilling.specialLocalData j).periods j.twist
+            (Elliptic.LogGauge.logMeridianRoot j s₀ hs₀ 0)) := by
+  change
+    ((SpecialPeriods.EllipticFilling.specialLocalData j).periods.periodEquiv _).symm
+        (-Elliptic.LogGauge.logMeridianParameter j s₀ 0 •
+          Elliptic.LogGauge.periodVector
+            (SpecialPeriods.EllipticFilling.specialLocalData j).periods j.twist _) =
+      _
+  rw [Elliptic.LogGauge.logMeridianParameter_zero]
+
+attribute [local instance] SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.specialPuncturedOverlap_eq_gauge
+    (j : Elliptic.Kind)
+    (x :
+      SpecialPeriods.EllipticFilling.MainFillingStar SpecialPeriods.specialPeriodMap j
+        SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂) :
+    (SpecialPeriods.EllipticFilling.puncturedFillingBiholomorph SpecialPeriods.specialPeriodMap j
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+          x).val =
+      (SpecialPeriods.EllipticFilling.tautologicalOverlapBiholomorph
+          SpecialPeriods.specialPeriodMap j SpecialPeriods.specialPeriodMap_generator₁
+          SpecialPeriods.specialPeriodMap_generator₂
+          (Elliptic.LogGauge.fillingToTautologicalBiholomorph
+            (SpecialPeriods.EllipticFilling.specialLocalData j) j.twist
+            (Elliptic.mainTwist_admissible j) x)).val :=
+  rfl
+
+attribute [local instance] SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.EllipticGeometry.smallOverlap_attachingLoop (j : Elliptic.Kind)
+    (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (t : (unitInterval)) :
+    SpecialPeriods.EllipticFilling.smallOverlap SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+        SpecialPeriods.Threefold.specialBaseCover j (attachingLoop j s₀ hs₀ hr t) =
+      (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂).quotient
+        (attachingUpstairsPoint j s₀ hs₀ t, 0) := by
+  rw [SpecialPeriods.EllipticFilling.smallOverlap_apply_mainStar SpecialPeriods.specialPeriodMap
+      SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+      SpecialPeriods.Threefold.specialBaseCover j _
+      (parameter_attachingLoop_ne_zero j s₀ hs₀ hr t),
+    specialPuncturedOverlap_eq_gauge]
+  change
+    (SpecialPeriods.EllipticFilling.tautologicalOverlapBiholomorph SpecialPeriods.specialPeriodMap
+          j SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+          (Elliptic.LogGauge.fillingToTautologicalBiholomorph
+            (SpecialPeriods.EllipticFilling.specialLocalData j) j.twist
+            (Elliptic.mainTwist_admissible j)
+            (Elliptic.LogGauge.logMeridianFillingPoint
+              (SpecialPeriods.EllipticFilling.specialLocalData j) j.twist
+              (Elliptic.mainTwist_admissible j) s₀ hs₀ t))).val =
+      _
+  rw [Elliptic.LogGauge.fillingToTautological_logMeridian]
+  change
+    (SpecialPeriods.EllipticFilling.tautologicalOverlapBiholomorph SpecialPeriods.specialPeriodMap
+          j SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+          (Elliptic.LogGauge.starProject (SpecialPeriods.EllipticFilling.specialLocalData j) 0
+            (Matrix.mulVec_zero j.matrix)
+            (Elliptic.LogGauge.zeroSection
+              (SpecialPeriods.EllipticFilling.specialLocalData j).periods
+              (Elliptic.LogGauge.logMeridianRootStar (j := j) s₀ hs₀ t)))).val =
+      _
+  exact
+    congrArg Subtype.val
+      (SpecialPeriods.EllipticFilling.tautologicalOverlapBiholomorph_project
+        SpecialPeriods.specialPeriodMap j SpecialPeriods.specialPeriodMap_generator₁
+        SpecialPeriods.specialPeriodMap_generator₂
+        (Elliptic.LogGauge.zeroSection (SpecialPeriods.EllipticFilling.specialLocalData j).periods
+          (Elliptic.LogGauge.logMeridianRootStar (j := j) s₀ hs₀ t)))
+
+attribute [local instance] SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.smallOverlap_attachingFibreLoop
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (w : Lattice) (t : (unitInterval)) :
+    SpecialPeriods.EllipticFilling.smallOverlap SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+        SpecialPeriods.Threefold.specialBaseCover j (attachingFibreLoop j s₀ hs₀ hr w t) =
+      (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂).quotient
+        (attachingUpstairsPoint j s₀ hs₀ 0,
+          standardLattice.mkQ ((t : ℝ) • Elliptic.realCast w)) := by
+  rw [SpecialPeriods.EllipticFilling.smallOverlap_apply_mainStar SpecialPeriods.specialPeriodMap
+      SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+      SpecialPeriods.Threefold.specialBaseCover j _
+      (parameter_attachingFibreLoop_ne_zero j s₀ hs₀ hr w t),
+    specialPuncturedOverlap_eq_gauge]
+  change
+    (SpecialPeriods.EllipticFilling.tautologicalOverlapBiholomorph SpecialPeriods.specialPeriodMap
+          j SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+          (Elliptic.LogGauge.fillingToTautologicalBiholomorph
+            (SpecialPeriods.EllipticFilling.specialLocalData j) j.twist
+            (Elliptic.mainTwist_admissible j)
+            (Elliptic.LogGauge.fibreTranslationFillingPoint
+              (SpecialPeriods.EllipticFilling.specialLocalData j) j.twist
+              (Elliptic.mainTwist_admissible j)
+              (Elliptic.LogGauge.logMeridianRootStar (j := j) s₀ hs₀ 0)
+              (attachingFlatBase j s₀ hs₀) w t))).val =
+      _
+  rw [attachingFlatBase_eq_negativeLog]
+  have hg :=
+    Elliptic.LogGauge.fillingToTautological_fibreTranslation
+      (SpecialPeriods.EllipticFilling.specialLocalData j) j.twist
+      (Elliptic.mainTwist_admissible j) (Elliptic.LogGauge.logMeridianRootStar (j := j) s₀ hs₀ 0)
+      w s₀ (Elliptic.LogGauge.logMeridianRoot_zero j s₀ hs₀).symm t
+  refine
+    (congrArg
+          (fun q :
+              Elliptic.LogGauge.TautologicalStar
+                (SpecialPeriods.EllipticFilling.specialLocalData j) =>
+            (SpecialPeriods.EllipticFilling.tautologicalOverlapBiholomorph
+                SpecialPeriods.specialPeriodMap j SpecialPeriods.specialPeriodMap_generator₁
+                SpecialPeriods.specialPeriodMap_generator₂ q).val)
+          hg).trans
+      ?_
+  refine
+    (congrArg Subtype.val
+          (SpecialPeriods.EllipticFilling.tautologicalOverlapBiholomorph_project
+            SpecialPeriods.specialPeriodMap j SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂
+            (Elliptic.LogGauge.fibreTranslationFamilyStar
+              (SpecialPeriods.EllipticFilling.specialLocalData j)
+              (Elliptic.LogGauge.logMeridianRootStar (j := j) s₀ hs₀ 0) 0 w t))).trans
+      ?_
+  change
+    (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂).quotient
+        (attachingUpstairsPoint j s₀ hs₀ 0,
+          standardLattice.mkQ (0 + (t : ℝ) • Elliptic.realCast w)) =
+      _
+  rw [zero_add]
+
+attribute [local instance] SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.specialEllipticOverlap_attachingLoop
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (t : (unitInterval)) :
+    SpecialPeriods.Threefold.specialEllipticOverlap j (attachingLoop j s₀ hs₀ hr t) =
+      (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂).quotient
+        (attachingUpstairsPoint j s₀ hs₀ t, 0) :=
+  smallOverlap_attachingLoop j s₀ hs₀ hr t
+
+attribute [local instance] SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.specialEllipticOverlap_attachingFibreLoop
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (w : Lattice) (t : (unitInterval)) :
+    SpecialPeriods.Threefold.specialEllipticOverlap j (attachingFibreLoop j s₀ hs₀ hr w t) =
+      (PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂).quotient
+        (attachingUpstairsPoint j s₀ hs₀ 0,
+          standardLattice.mkQ ((t : ℝ) • Elliptic.realCast w)) :=
+  smallOverlap_attachingFibreLoop j s₀ hs₀ hr w t
+
+private theorem SpecialPeriods.Threefold.previousStageHom_surjective_of_overlapFillingHom_surjective
+    (s : Finset Puncture) (i : Puncture) (hi : i ∉ s)
+    (hF : Function.Surjective (overlapFillingHom i)) :
+    Function.Surjective (previousStageHom s i) := by
+  have hV : Function.Surjective (attachmentCover s i hi).overlapHomV := by
+    intro γ
+    obtain ⟨δ, hδ⟩ := hF (attachmentRightGroupEquiv s i hi γ)
+    obtain ⟨ε, hε⟩ := (attachmentOverlapGroupEquiv s i hi).surjective δ
+    refine ⟨ε, (attachmentRightGroupEquiv s i hi).injective ?_⟩
+    exact
+      (DFunLike.congr_fun (attachmentRightGroupEquiv_overlap s i hi) ε).trans
+        ((congrArg (overlapFillingHom i) hε).trans hδ)
+  intro γ
+  obtain ⟨δ, hδ⟩ :=
+    (attachmentCover s i hi).inclusionHomU_surjective_of_overlapHomV_surjective hV γ
+  exact
+    ⟨attachmentLeftGroupEquiv s i hi δ,
+      (DFunLike.congr_fun (attachmentLeftGroupEquiv_inclusion s i hi) δ).trans hδ⟩
+
+private def SpecialPeriods.Threefold.stageRegularInclusion (s : Finset Puncture) :
+    C(liftedPatch Option.none, partialPatch s) :=
+  ⟨fun x => ⟨x.val, regular_le_partialPatch s x.property⟩, continuous_subtype_val.subtype_mk _⟩
+
+private theorem SpecialPeriods.Threefold.stageRegularInclusion_empty_fundamentalGroup_map_surjective
+    (x : liftedPatch Option.none) :
+    Function.Surjective (FundamentalGroup.map (stageRegularInclusion ∅) x) := by
+  exact (homeomorphFundamentalGroupEquiv emptyStageHomeomorph.symm x).surjective
+
+private theorem SpecialPeriods.Threefold.stageRegularInclusion_insert_fundamentalGroup_map
+    (s : Finset Puncture) (i : Puncture) (x : liftedPatch Option.none) :
+    (FundamentalGroup.map (previousStageInclusion s i) (stageRegularInclusion s x)).comp
+        (FundamentalGroup.map (stageRegularInclusion s) x) =
+      FundamentalGroup.map (stageRegularInclusion (Insert.insert i s)) x := by
+  ext γ
+  obtain ⟨p⟩ := γ
+  apply congrArg Path.Homotopic.Quotient.mk
+  ext t
+  rfl
+
+private theorem SpecialPeriods.Threefold.stageRegularInclusion_fundamentalGroup_map_surjective
+    (hF : ∀ i : Puncture, Function.Surjective (overlapFillingHom i)) (s : Finset Puncture)
+    (x : liftedPatch Option.none) :
+    Function.Surjective (FundamentalGroup.map (stageRegularInclusion s) x) := by
+  induction s using Finset.induction_on with
+  | empty => exact stageRegularInclusion_empty_fundamentalGroup_map_surjective x
+  | @insert i s hi ih =>
+    have := partialPatch_pathConnectedSpace s
+    have hprev :=
+      fundamentalGroup_map_surjective_at_of_pathConnected (previousStageInclusion s i)
+        ⟨attachmentPoint i, attachmentPoint_mem_partialPatch s i⟩ (stageRegularInclusion s x)
+        (previousStageHom_surjective_of_overlapFillingHom_surjective s i hi (hF i))
+    have hcomp := hprev.comp ih
+    rw [← stageRegularInclusion_insert_fundamentalGroup_map s i x]
+    exact hcomp
+
+private def SpecialPeriods.Threefold.regularLiftedInclusion : C(liftedPatch Option.none, Space) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private theorem SpecialPeriods.Threefold.regularLiftedInclusion_fundamentalGroup_map_surjective
+    (hF : ∀ i : Puncture, Function.Surjective (overlapFillingHom i))
+    (x : liftedPatch Option.none) :
+    Function.Surjective (FundamentalGroup.map regularLiftedInclusion x) := by
+  have hstage := stageRegularInclusion_fundamentalGroup_map_surjective hF Finset.univ x
+  have hfull := (fullStageFundamentalGroupEquiv (stageRegularInclusion Finset.univ x)).surjective
+  have hmap :
+    (fullStageFundamentalGroupEquiv (stageRegularInclusion Finset.univ x)).toMonoidHom.comp
+        (FundamentalGroup.map (stageRegularInclusion Finset.univ) x) =
+      FundamentalGroup.map regularLiftedInclusion x := by
+    ext γ
+    obtain ⟨p⟩ := γ
+    apply congrArg Path.Homotopic.Quotient.mk
+    ext t
+    rfl
+  rw [← hmap]
+  exact hfull.comp hstage
+
+private def SpecialPeriods.EllipticAttachingSurjectivity.fullCover (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) :
+    SpecialPeriods.Disc × ComplexPlane₂ → SpecialPeriods.EllipticFilling.fillingSpace P h₁ h₂ j :=
+  SpecialPeriods.EllipticFilling.fillingQuotient P h₁ h₂ j ∘
+    (SpecialPeriods.EllipticFilling.localPeriods P j).quotientMap
+
+@[simp]
+private theorem SpecialPeriods.EllipticAttachingSurjectivity.fullCover_projection_coe
+    (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) (x : SpecialPeriods.Disc × ComplexPlane₂) :
+    (SpecialPeriods.EllipticFilling.fillingProjection P h₁ h₂ j (fullCover P h₁ h₂ j x) : ℂ) =
+      (x.1 : ℂ) ^ j.order :=
+  rfl
+
+private theorem SpecialPeriods.EllipticAttachingSurjectivity.fillingQuotient_finite_fibre
+    (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) (y : SpecialPeriods.EllipticFilling.fillingSpace P h₁ h₂ j) :
+    Finite (SpecialPeriods.EllipticFilling.fillingQuotient P h₁ h₂ j ⁻¹' { y }) := by
+  apply Nat.finite_of_card_ne_zero
+  have hcard :=
+    (SpecialPeriods.EllipticFilling.localData P h₁ h₂ j).quotient_fibre_card j.twist
+      (Elliptic.mainTwist_admissible j) y
+  change
+    Nat.card (SpecialPeriods.EllipticFilling.fillingQuotient P h₁ h₂ j ⁻¹' { y }) =
+      j.order at hcard
+  rw [hcard]
+  exact j.order_pos.ne'
+
+private theorem SpecialPeriods.EllipticAttachingSurjectivity.fullCover_isCoveringMap
+    (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) : IsCoveringMap (fullCover P h₁ h₂ j) := by
+  let := (SpecialPeriods.EllipticFilling.localPeriods P j).coveringAction
+  exact
+    CoveringComposition.covering_comp_of_finite_fibres
+      (SpecialPeriods.EllipticFilling.localPeriods P j).quotientCoveringMap.isCoveringMap
+      (SpecialPeriods.EllipticFilling.fillingQuotient_isCoveringMap P h₁ h₂ j)
+      (fillingQuotient_finite_fibre P h₁ h₂ j)
+
+private theorem SpecialPeriods.EllipticAttachingSurjectivity.fullCover_surjective
+    (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) : Function.Surjective (fullCover P h₁ h₂ j) :=
+  (SpecialPeriods.EllipticFilling.fillingQuotient_surjective P h₁ h₂ j).comp
+    (SpecialPeriods.EllipticFilling.localPeriods P j).quotientMap_surjective
+
+private def SpecialPeriods.EllipticAttachingSurjectivity.powerDisc (m : ℕ) (r : ℝ) :
+    TopologicalSpace.Opens SpecialPeriods.Disc :=
+  ⟨{z | ‖(z : ℂ)‖ ^ m < r}, isOpen_lt (continuous_subtype_val.norm.pow m) continuous_const⟩
+
+private def SpecialPeriods.EllipticAttachingSurjectivity.powerDiscRadius (m : ℕ) (r : ℝ) : ℝ :=
+  r ^ (m : ℝ)⁻¹
+
+private theorem SpecialPeriods.EllipticAttachingSurjectivity.powerDiscRadius_pos (m : ℕ) (r : ℝ)
+    (hr : 0 < r) : 0 < powerDiscRadius m r :=
+  Real.rpow_pos_of_pos hr _
+
+private theorem SpecialPeriods.EllipticAttachingSurjectivity.powerDiscRadius_pow (m : ℕ) (r : ℝ)
+    (hm : 0 < m) (hr : 0 < r) : powerDiscRadius m r ^ m = r :=
+  Real.rpow_inv_natCast_pow hr.le hm.ne'
+
+private theorem SpecialPeriods.EllipticAttachingSurjectivity.powerDiscRadius_lt_one (m : ℕ) (r : ℝ)
+    (hm : 0 < m) (hr : 0 < r) (hr1 : r < 1) : powerDiscRadius m r < 1 :=
+  Real.rpow_lt_one hr.le hr1 (inv_pos.mpr (Nat.cast_pos.mpr hm))
+
+private theorem SpecialPeriods.EllipticAttachingSurjectivity.norm_pow_lt_iff_norm_lt_powerDiscRadius
+    (m : ℕ) (r : ℝ) (hm : 0 < m) (hr : 0 < r) (z : ℂ) : ‖z‖ ^ m < r ↔ ‖z‖ < powerDiscRadius m r :=
+  by
+  calc
+    ‖z‖ ^ m < r ↔ ‖z‖ ^ m < powerDiscRadius m r ^ m := by rw [powerDiscRadius_pow m r hm hr]
+    _ ↔ ‖z‖ < powerDiscRadius m r :=
+      pow_lt_pow_iff_left₀ (norm_nonneg z) (powerDiscRadius_pos m r hr).le hm.ne'
+
+private def SpecialPeriods.EllipticAttachingSurjectivity.powerDiscBallHomeomorph (m : ℕ) (r : ℝ)
+    (hm : 0 < m) (hr : 0 < r) (hr1 : r < 1) :
+    powerDisc m r ≃ₜ Metric.ball (0 : ℂ) (powerDiscRadius m r)
+    where
+  toFun
+    z :=
+    ⟨((z : SpecialPeriods.Disc) : ℂ), by
+      simpa only [Metric.mem_ball, dist_zero_right] using
+        (norm_pow_lt_iff_norm_lt_powerDiscRadius m r hm hr _).mp z.property⟩
+  invFun
+    z :=
+    ⟨⟨z, by
+        change (z : ℂ) ∈ Metric.ball (0 : ℂ) 1
+        simpa only [Metric.mem_ball, dist_zero_right] using
+          (show ‖(z : ℂ)‖ < powerDiscRadius m r by
+                simpa only [Metric.mem_ball, dist_zero_right] using z.property).trans
+            (powerDiscRadius_lt_one m r hm hr hr1)⟩,
+      by
+      apply (norm_pow_lt_iff_norm_lt_powerDiscRadius m r hm hr _).mpr
+      simpa only [Metric.mem_ball, dist_zero_right] using z.property⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := (continuous_subtype_val.comp continuous_subtype_val).subtype_mk _
+  continuous_invFun := (continuous_subtype_val.subtype_mk _).subtype_mk _
+
+private theorem
+    SpecialPeriods.EllipticAttachingSurjectivity.powerDisc_contractibleSpace (m : ℕ) (r : ℝ)
+    (hm : 0 < m) (hr : 0 < r) (hr1 : r < 1) : ContractibleSpace (powerDisc m r) := by
+  apply (powerDiscBallHomeomorph m r hm hr hr1).contractibleSpace_iff.mpr
+  exact
+    (convex_ball (0 : ℂ) (powerDiscRadius m r)).contractibleSpace
+      ⟨0, Metric.mem_ball_self (powerDiscRadius_pos m r hr)⟩
+
+private theorem
+    SpecialPeriods.EllipticAttachingSurjectivity.powerDisc_punctured_image (m : ℕ) (r : ℝ)
+    (hm : 0 < m) (hr : 0 < r) (hr1 : r < 1) :
+    (fun z : powerDisc m r => ((z : SpecialPeriods.Disc) : ℂ)) ''
+        {z : powerDisc m r | ((z : SpecialPeriods.Disc) : ℂ) ≠ 0} =
+      Metric.ball (0 : ℂ) (powerDiscRadius m r) \ {0} := by
+  let e := powerDiscBallHomeomorph m r hm hr hr1
+  ext z
+  constructor
+  · rintro ⟨w, hw, rfl⟩
+    exact ⟨(e w).property, hw⟩
+  · rintro ⟨hz, hne⟩
+    refine ⟨e.symm ⟨z, hz⟩, ?_, rfl⟩
+    exact hne
+
+private theorem
+    SpecialPeriods.EllipticAttachingSurjectivity.powerDisc_punctured_isPathConnected (m : ℕ)
+    (r : ℝ) (hm : 0 < m) (hr : 0 < r) (hr1 : r < 1) :
+    IsPathConnected {z : powerDisc m r | ((z : SpecialPeriods.Disc) : ℂ) ≠ 0} := by
+  have h : Topology.IsInducing (fun z : powerDisc m r => ((z : SpecialPeriods.Disc) : ℂ)) :=
+    Topology.IsInducing.subtypeVal.comp Topology.IsInducing.subtypeVal
+  apply h.isPathConnected_iff.mpr
+  rw [powerDisc_punctured_image m r hm hr hr1]
+  exact
+    SpecialPeriods.Threefold.punctured_complex_ball_isPathConnected (powerDiscRadius_pos m r hr)
+
+private abbrev SpecialPeriods.EllipticAttachingSurjectivity.SmallCoverSource
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :=
+  powerDisc j.order (C.radius (Option.some j)) × ComplexPlane₂
+
+private theorem SpecialPeriods.EllipticAttachingSurjectivity.fullCover_mem_pieceDomain_iff
+    (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind)
+    (x : SpecialPeriods.Disc × ComplexPlane₂) :
+    fullCover P h₁ h₂ j x ∈ SpecialPeriods.EllipticFilling.pieceDomain P h₁ h₂ C j ↔
+      x.1 ∈ powerDisc j.order (C.radius (Option.some j)) := by
+  change
+    ‖(SpecialPeriods.EllipticFilling.fillingProjection P h₁ h₂ j (fullCover P h₁ h₂ j x) : ℂ)‖ <
+        _ ↔
+      _
+  rw [fullCover_projection_coe, norm_pow]
+  rfl
+
+private def SpecialPeriods.EllipticAttachingSurjectivity.smallCoverHomeomorph
+    (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    SmallCoverSource C j ≃ₜ
+      (fullCover P h₁ h₂ j ⁻¹'
+        (SpecialPeriods.EllipticFilling.pieceDomain P h₁ h₂ C j :
+          Set (SpecialPeriods.EllipticFilling.fillingSpace P h₁ h₂ j)))
+    where
+  toFun
+    x :=
+    ⟨((x.1 : SpecialPeriods.Disc), x.2),
+      (fullCover_mem_pieceDomain_iff P h₁ h₂ C j _).mpr x.1.property⟩
+  invFun x := (⟨x.val.1, (fullCover_mem_pieceDomain_iff P h₁ h₂ C j _).mp x.property⟩, x.val.2)
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun :=
+    ((continuous_subtype_val.comp continuous_fst).prodMk continuous_snd).subtype_mk _
+  continuous_invFun :=
+    ((continuous_fst.comp continuous_subtype_val).subtype_mk _).prodMk
+      (continuous_snd.comp continuous_subtype_val)
+
+private def SpecialPeriods.EllipticAttachingSurjectivity.smallCover (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    SmallCoverSource C j → SpecialPeriods.EllipticFilling.Piece P h₁ h₂ C j :=
+  (SpecialPeriods.EllipticFilling.pieceDomain P h₁ h₂ C j :
+          Set (SpecialPeriods.EllipticFilling.fillingSpace P h₁ h₂ j)).restrictPreimage
+      (fullCover P h₁ h₂ j) ∘
+    smallCoverHomeomorph P h₁ h₂ C j
+
+private theorem SpecialPeriods.EllipticAttachingSurjectivity.smallCover_isCoveringMap
+    (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    IsCoveringMap (smallCover P h₁ h₂ C j) :=
+  ((fullCover_isCoveringMap P h₁ h₂ j).restrictPreimage
+        (SpecialPeriods.EllipticFilling.pieceDomain P h₁ h₂ C j :
+          Set (SpecialPeriods.EllipticFilling.fillingSpace P h₁ h₂ j))).comp_homeomorph
+    (smallCoverHomeomorph P h₁ h₂ C j)
+
+private theorem SpecialPeriods.EllipticAttachingSurjectivity.smallCover_surjective
+    (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    Function.Surjective (smallCover P h₁ h₂ C j) :=
+  ((fullCover_surjective P h₁ h₂ j).restrictPreimage
+        (SpecialPeriods.EllipticFilling.pieceDomain P h₁ h₂ C j :
+          Set (SpecialPeriods.EllipticFilling.fillingSpace P h₁ h₂ j))).comp
+    (smallCoverHomeomorph P h₁ h₂ C j).surjective
+
+private theorem SpecialPeriods.EllipticAttachingSurjectivity.smallCoverSource_simplyConnectedSpace
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    SimplyConnectedSpace (SmallCoverSource C j) := by
+  let :=
+    powerDisc_contractibleSpace j.order (C.radius (Option.some j)) j.order_pos
+      (C.radius_pos (Option.some j)) (C.radius_lt_chart (Option.some j))
+  infer_instance
+
+private def
+    SpecialPeriods.EllipticAttachingSurjectivity.puncturedPiece (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    Set (SpecialPeriods.EllipticFilling.Piece P h₁ h₂ C j) :=
+  {x | (SpecialPeriods.EllipticFilling.fillingProjection P h₁ h₂ j x : ℂ) ≠ 0}
+
+private theorem SpecialPeriods.EllipticAttachingSurjectivity.smallCover_preimage_puncturedPiece
+    (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    smallCover P h₁ h₂ C j ⁻¹' puncturedPiece P h₁ h₂ C j =
+      {z : powerDisc j.order (C.radius (Option.some j)) | ((z : SpecialPeriods.Disc) : ℂ) ≠ 0} ×ˢ
+        (Set.univ : Set ComplexPlane₂) := by
+  ext x
+  change
+    (((x.1 : SpecialPeriods.Disc) : ℂ) ^ j.order ≠ 0) ↔
+      (((x.1 : SpecialPeriods.Disc) : ℂ) ≠ 0 ∧ True)
+  simp only [ne_eq, pow_eq_zero_iff j.order_pos.ne', and_true]
+
+private theorem
+    SpecialPeriods.EllipticAttachingSurjectivity.smallCover_punctured_preimage_isPathConnected
+    (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    IsPathConnected (smallCover P h₁ h₂ C j ⁻¹' puncturedPiece P h₁ h₂ C j) := by
+  rw [smallCover_preimage_puncturedPiece]
+  exact
+    (powerDisc_punctured_isPathConnected j.order (C.radius (Option.some j)) j.order_pos
+          (C.radius_pos (Option.some j)) (C.radius_lt_chart (Option.some j))).prod
+      isPathConnected_univ
+
+private def SpecialPeriods.EllipticAttachingSurjectivity.puncturedPieceInclusion
+    (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    C(puncturedPiece P h₁ h₂ C j, SpecialPeriods.EllipticFilling.Piece P h₁ h₂ C j) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private theorem
+  SpecialPeriods.EllipticAttachingSurjectivity.puncturedPieceInclusion_fundamentalGroup_surjective
+    (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind)
+    (x : puncturedPiece P h₁ h₂ C j) :
+    Function.Surjective (FundamentalGroup.map (puncturedPieceInclusion P h₁ h₂ C j) x) := by
+  let := smallCoverSource_simplyConnectedSpace C j
+  exact
+    covering_restriction_fundamentalGroup_map_surjective (smallCover_isCoveringMap P h₁ h₂ C j)
+      (smallCover_surjective P h₁ h₂ C j) (puncturedPiece P h₁ h₂ C j)
+      (smallCover_punctured_preimage_isPathConnected P h₁ h₂ C j) x
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.Threefold.localPieceChartedSpace in
+private abbrev SpecialPeriods.Threefold.ellipticPuncturedPiece (j : Elliptic.Kind) :
+    Set (SpecialEllipticPiece j) :=
+  SpecialPeriods.EllipticAttachingSurjectivity.puncturedPiece SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+    specialBaseCover j
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.Threefold.localPieceChartedSpace in
+private def SpecialPeriods.Threefold.ellipticPuncturedPieceInclusion (j : Elliptic.Kind) :
+    C(ellipticPuncturedPiece j, SpecialEllipticPiece j) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.ellipticPuncturedPieceInclusion_fundamentalGroup_surjective
+    (j : Elliptic.Kind) (x : ellipticPuncturedPiece j) :
+    Function.Surjective (FundamentalGroup.map (ellipticPuncturedPieceInclusion j) x) :=
+  SpecialPeriods.EllipticAttachingSurjectivity.puncturedPieceInclusion_fundamentalGroup_surjective
+    SpecialPeriods.specialPeriodMap SpecialPeriods.specialPeriodMap_generator₁
+    SpecialPeriods.specialPeriodMap_generator₂ specialBaseCover j x
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.Threefold.localPieceChartedSpace in
+private def SpecialPeriods.Threefold.overlapAsFillingSubsetHomeomorph (i : Puncture) :
+    {x : liftedPatch (Option.some i) | (x : Space) ∈ liftedPatch Option.none} ≃ₜ RegularOverlap i
+    where
+  toFun x := ⟨x.val.val, x.property, x.val.property⟩
+  invFun x := ⟨⟨x.val, x.property.2⟩, x.property.1⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := (continuous_subtype_val.comp continuous_subtype_val).subtype_mk _
+  continuous_invFun := (continuous_subtype_val.subtype_mk _).subtype_mk _
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.ellipticPuncturedPiece_mem_iff (j : Elliptic.Kind)
+    (x : SpecialEllipticPiece j) :
+    x ∈ ellipticPuncturedPiece j ↔
+      ((patchBiholomorph (Option.some (Option.some j)) x :
+            liftedPatch (Option.some (Option.some j))) :
+          Space) ∈
+        liftedPatch Option.none := by
+  change
+    (SpecialPeriods.EllipticFilling.fillingProjection SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+            j x :
+          ℂ) ≠
+        0 ↔
+      projection (SpecialPeriods.Threefold.inclusion (Option.some (Option.some j)) x) ∈
+        regularPatch
+  exact
+    (SpecialPeriods.EllipticFilling.pieceProjectionToBase_mem_regular_iff
+          SpecialPeriods.specialPeriodMap SpecialPeriods.specialPeriodMap_generator₁
+          SpecialPeriods.specialPeriodMap_generator₂ specialBaseCover j x).symm.trans
+      (Iff.of_eq
+        (congrArg (fun y => y ∈ regularPatch)
+          (projection_inclusion (Option.some (Option.some j)) x).symm))
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.Threefold.localPieceChartedSpace in
+private def SpecialPeriods.Threefold.ellipticPuncturedPieceHomeomorph (j : Elliptic.Kind) :
+    ellipticPuncturedPiece j ≃ₜ RegularOverlap (Option.some j) :=
+  ((patchBiholomorph (Option.some (Option.some j))).toHomeomorph.subtype (p := fun x =>
+        x ∈ ellipticPuncturedPiece j) (q := fun x : liftedPatch (Option.some (Option.some j)) =>
+        (x : Space) ∈ liftedPatch Option.none) (ellipticPuncturedPiece_mem_iff j)).trans
+    (overlapAsFillingSubsetHomeomorph (Option.some j))
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.ellipticPuncturedPiece_fundamentalGroup_naturality
+    (j : Elliptic.Kind) (x : RegularOverlap (Option.some j)) :
+    (homeomorphFundamentalGroupEquiv
+            (patchBiholomorph (Option.some (Option.some j))).toHomeomorph.symm
+            (overlapFillingInclusion (Option.some j) x)).toMonoidHom.comp
+        (FundamentalGroup.map (overlapFillingInclusion (Option.some j)) x) =
+      (FundamentalGroup.map (ellipticPuncturedPieceInclusion j)
+            ((ellipticPuncturedPieceHomeomorph j).symm x)).comp
+        (homeomorphFundamentalGroupEquiv (ellipticPuncturedPieceHomeomorph j).symm
+            x).toMonoidHom := by
+  ext γ
+  obtain ⟨p⟩ := γ
+  apply congrArg Path.Homotopic.Quotient.mk
+  ext t
+  rfl
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.overlapFillingInclusion_elliptic_fundamentalGroup_surjective
+    (j : Elliptic.Kind) (x : RegularOverlap (Option.some j)) :
+    Function.Surjective (FundamentalGroup.map (overlapFillingInclusion (Option.some j)) x) := by
+  let eF :=
+    homeomorphFundamentalGroupEquiv
+      (patchBiholomorph (Option.some (Option.some j))).toHomeomorph.symm
+      (overlapFillingInclusion (Option.some j) x)
+  let eO := homeomorphFundamentalGroupEquiv (ellipticPuncturedPieceHomeomorph j).symm x
+  let f :=
+    FundamentalGroup.map (ellipticPuncturedPieceInclusion j)
+      ((ellipticPuncturedPieceHomeomorph j).symm x)
+  intro γ
+  obtain ⟨δ, hδ⟩ :=
+    ellipticPuncturedPieceInclusion_fundamentalGroup_surjective j
+      ((ellipticPuncturedPieceHomeomorph j).symm x) (eF γ)
+  refine ⟨eO.symm δ, eF.injective ?_⟩
+  exact
+    (DFunLike.congr_fun (ellipticPuncturedPiece_fundamentalGroup_naturality j x)
+          (eO.symm δ)).trans
+      ((congrArg f (eO.apply_symm_apply δ)).trans hδ)
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.overlapFillingHom_elliptic_surjective (j : Elliptic.Kind) :
+    Function.Surjective (overlapFillingHom (Option.some j)) :=
+  overlapFillingInclusion_elliptic_fundamentalGroup_surjective j
+    (regularOverlapPoint (Option.some j))
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private abbrev SpecialPeriods.Threefold.CuspAttaching.radius : ℝ :=
+  SpecialPeriods.Threefold.specialBaseCover.radius Option.none
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private abbrev SpecialPeriods.Threefold.CuspAttaching.Disc :=
+  CuspQuotient.disc radius
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private abbrev SpecialPeriods.Threefold.CuspAttaching.data : SpecialPeriods.CuspFamily.Data :=
+  SpecialPeriods.specialCuspData.shrink radius
+    (SpecialPeriods.Threefold.specialBaseCover.radius_pos Option.none)
+    SpecialPeriods.Threefold.specialCuspRadius_le
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private abbrev SpecialPeriods.Threefold.CuspAttaching.regularData :
+    PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint :=
+  SpecialPeriods.Threefold.regularFamilyData SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.CuspAttaching.cuspZeroSection :
+    Disc → SpecialPeriods.Threefold.SpecialCuspPiece :=
+  CuspQuotient.zeroSection SpecialPeriods.specialCuspData.correction radius
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.cuspZeroSection_continuous :
+    Continuous cuspZeroSection :=
+  CuspQuotient.zeroSection_continuous SpecialPeriods.specialCuspData.correction radius
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.CuspAttaching.regularZeroSection :
+    SpecialPeriods.Threefold.regularPatch → SpecialPeriods.Threefold.SpecialRegularFamily :=
+  SpecialPeriods.Threefold.regularFamilyZeroSection SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.regularZeroSection_continuous :
+    Continuous regularZeroSection :=
+  SpecialPeriods.Threefold.regularFamilyZeroSection_continuous SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.CuspAttaching.regularBase (t : Disc) (ht : (t : ℂ) ≠ 0) :
+    SpecialPeriods.Threefold.regularPatch :=
+  ⟨SpecialPeriods.Threefold.specialBaseCover.fillingEmbedding Option.none t,
+    (SpecialPeriods.Threefold.specialBaseCover.fillingEmbedding_mem_regular_iff Option.none t).mpr
+      ht⟩
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.cuspZeroSection_projection (t : Disc) :
+    SpecialPeriods.Threefold.specialCuspPieceProjectionToBase (cuspZeroSection t) =
+      SpecialPeriods.Threefold.specialBaseCover.fillingEmbedding Option.none t := by
+  change
+    (SpecialPeriods.Threefold.punctureChart Option.none).symm
+        (CuspQuotient.projection SpecialPeriods.specialCuspData.correction radius
+          (CuspQuotient.zeroSection SpecialPeriods.specialCuspData.correction radius t)) =
+      _
+  rw [CuspQuotient.projection_zeroSection]
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.cuspZeroSection_mem_overlap (t : Disc)
+    (ht : (t : ℂ) ≠ 0) : cuspZeroSection t ∈ SpecialPeriods.Threefold.specialCuspOverlap.source :=
+  by
+  rw [SpecialPeriods.Threefold.specialCuspOverlap_source]
+  change
+    SpecialPeriods.Threefold.specialCuspPieceProjectionToBase (cuspZeroSection t) ∈
+      SpecialPeriods.Threefold.regularPatch
+  rw [cuspZeroSection_projection]
+  exact (regularBase t ht).property
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.overlap_cuspZeroSection_projection (t : Disc)
+    (ht : (t : ℂ) ≠ 0) :
+    SpecialPeriods.Threefold.specialRegularFamilyProjection
+        (SpecialPeriods.Threefold.specialCuspOverlap (cuspZeroSection t)) =
+      regularBase t ht := by
+  apply Subtype.ext
+  exact
+    (SpecialPeriods.Threefold.specialCuspOverlap_base _ (cuspZeroSection_mem_overlap t ht)).trans
+      (cuspZeroSection_projection t)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private abbrev SpecialPeriods.Threefold.CuspAttaching.OverlapBase :=
+  { b : SpecialPeriods.Threefold.regularPatch //
+    (b : SpecialPeriods.TriangleCompactifiedOrbitSpace) ∈
+      SpecialPeriods.Threefold.specialBaseCover.fillingPatch Option.none }
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.CuspAttaching.overlapCoordinate (b : OverlapBase) : Disc :=
+  SpecialPeriods.Threefold.specialBaseCover.fillingChart Option.none ⟨b.val, b.property⟩
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.overlapCoordinate_continuous :
+    Continuous overlapCoordinate :=
+  (SpecialPeriods.Threefold.specialBaseCover.fillingChart Option.none).continuous.comp
+    ((continuous_subtype_val.comp continuous_subtype_val).subtype_mk _)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.overlapCoordinate_ne_zero (b : OverlapBase) :
+    (overlapCoordinate b : ℂ) ≠ 0 :=
+  (SpecialPeriods.Threefold.specialBaseCover.fillingPatch_regular_iff_coordinate_ne_zero
+        Option.none b.property).mp
+    b.val.property
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem
+    SpecialPeriods.Threefold.CuspAttaching.regularBase_overlapCoordinate (b : OverlapBase) :
+    regularBase (overlapCoordinate b) (overlapCoordinate_ne_zero b) = b.val := by
+  apply Subtype.ext
+  change
+    ((SpecialPeriods.Threefold.specialBaseCover.fillingChart Option.none).symm
+          (SpecialPeriods.Threefold.specialBaseCover.fillingChart Option.none
+            ⟨b.val, b.property⟩)).val =
+      b.val.val
+  exact
+    congrArg Subtype.val
+      ((SpecialPeriods.Threefold.specialBaseCover.fillingChart Option.none).symm_apply_apply
+        ⟨b.val, b.property⟩)
+
+private theorem SpecialPeriods.CuspFamily.Data.familyCover_zero (D : SpecialPeriods.CuspFamily.Data)
+    (s : SpecialPeriods.CuspFamily.LogBase D.radius) :
+    D.familyCover ⟨((s : ℂ), 0), s.property⟩ = (s, 0) := by
+  simp only [familyCover_apply, HolomorphicPeriodMap.quotientMap, map_zero]
+
+@[simp]
+private theorem
+    SpecialPeriods.CuspFamily.Data.iteratedCover_zero (D : SpecialPeriods.CuspFamily.Data)
+    (s : SpecialPeriods.CuspFamily.LogBase D.radius) :
+    D.iteratedCover ⟨((s : ℂ), 0), s.property⟩ = D.quotient (s, 0) := by
+  change D.quotient (D.familyCover _) = _
+  rw [D.familyCover_zero]
+
+private theorem SpecialPeriods.CuspGlobalOverlap.familyMap_iteratedCover_zero
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (s : SpecialPeriods.CuspFamily.LogBase C.radius) :
+    familyMap C D hrcap (C.iteratedCover ⟨((s : ℂ), 0), s.property⟩) =
+      D.zeroSection
+        (D.baseQuotient (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap s)) := by
+  rw [C.iteratedCover_zero, familyMap_quotient, D.zeroSection_baseQuotient]
+  rfl
+
+private theorem SpecialPeriods.CuspGlobalOverlap.cuspToRegularPartial_zeroSection_log
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (hperiod :
+      ∀ s : SpecialPeriods.CuspFamily.LogBase C.radius,
+        D.periods.point (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap s) =
+          C.periods.point s)
+    (s : SpecialPeriods.CuspFamily.LogBase C.radius) (t : CuspQuotient.disc C.radius)
+    (ht : (t : ℂ) = CuspUniformization.exponential s) :
+    letI :=
+      CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+        C.smallDrift
+    letI := D.chartedSpace (familyCovering D)
+    cuspToRegularPartial C D hrcap hperiod (CuspQuotient.zeroSection C.correction C.radius t) =
+      D.zeroSection
+        (D.baseQuotient (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap s)) := by
+  let :=
+    CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+      C.smallDrift
+  let := D.chartedSpace (familyCovering D)
+  have htne : (t : ℂ) ≠ 0 := by
+    rw [ht]
+    exact CuspUniformization.exponential_ne_zero s
+  have hsource :
+    CuspQuotient.zeroSection C.correction C.radius t ∈
+      CuspUniformization.puncturedQuotientOpen C.correction C.radius := by
+    change
+      CuspQuotient.projection C.correction C.radius
+          (CuspQuotient.zeroSection C.correction C.radius t) ≠
+        0
+    rw [CuspQuotient.projection_zeroSection]
+    exact htne
+  rw [cuspToRegularPartial_apply C D hrcap hperiod _ hsource]
+  have he :
+    (⟨CuspQuotient.zeroSection C.correction C.radius t, hsource⟩ :
+        CuspUniformization.PuncturedQuotient C.correction C.radius) =
+      CuspUniformization.puncturedCuspCover C.correction C.radius ⟨((s : ℂ), 0), s.property⟩ := by
+    apply Subtype.ext
+    exact (CuspUniformization.puncturedCuspCover_zero C.correction C.radius s t ht).symm
+  rw [he, puncturedBiholomorph_cover C D hrcap hperiod]
+  exact familyMap_iteratedCover_zero C D hrcap s
+
+private theorem SpecialPeriods.CuspGlobalOverlap.cuspToRegularPartial_zeroSection
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (hperiod :
+      ∀ s : SpecialPeriods.CuspFamily.LogBase C.radius,
+        D.periods.point (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap s) =
+          C.periods.point s)
+    (t : CuspQuotient.disc C.radius) (ht : (t : ℂ) ≠ 0) :
+    letI :=
+      CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+        C.smallDrift
+    letI := D.chartedSpace (familyCovering D)
+    cuspToRegularPartial C D hrcap hperiod (CuspQuotient.zeroSection C.correction C.radius t) =
+      D.zeroSection
+        (D.projection
+          (cuspToRegularPartial C D hrcap hperiod
+            (CuspQuotient.zeroSection C.correction C.radius t))) := by
+  let :=
+    CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+      C.smallDrift
+  let := D.chartedSpace (familyCovering D)
+  obtain ⟨s, hs⟩ :=
+    SpecialPeriods.CuspFamily.baseExponential_surjective C.radius
+      (⟨t, t.property, ht⟩ : SpecialPeriods.CuspFamily.puncturedDisc C.radius)
+  have he : (t : ℂ) = CuspUniformization.exponential s := (congrArg Subtype.val hs).symm
+  rw [cuspToRegularPartial_zeroSection_log C D hrcap hperiod s t he, D.projection_zeroSection]
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.radius_le_cuspChart :
+    radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width :=
+  SpecialPeriods.Threefold.specialBaseCover_cusp_radius_bounds.2.2.le
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.period_agreement
+    (s : SpecialPeriods.CuspFamily.LogBase radius) :
+    regularData.periods.point
+        (SpecialPeriods.CuspFamily.logBaseToRegular radius radius_le_cuspChart s) =
+      data.periods.point s :=
+  SpecialPeriods.CuspGlobalOverlap.spherePeriod_agreement
+    SpecialPeriods.Triangle.triangleSphereUniformization
+    SpecialPeriods.Triangle.triangleSphereUniformization_cusp
+    SpecialPeriods.Triangle.triangleSphereUniformization_centerOne
+    SpecialPeriods.Triangle.triangleSphereUniformization_centerTwo radius
+    (SpecialPeriods.Threefold.specialBaseCover.radius_pos Option.none)
+    SpecialPeriods.Threefold.specialCuspRadius_le radius_le_cuspChart s
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.regularZeroSection_projection_eq
+    (x : SpecialPeriods.Threefold.SpecialRegularFamily) :
+    regularZeroSection (SpecialPeriods.Threefold.specialRegularFamilyProjection x) =
+      regularData.zeroSection (regularData.projection x) := by
+  change
+    regularData.zeroSection
+        (SpecialPeriods.Threefold.regularBiholomorph.symm
+          (SpecialPeriods.Threefold.regularBiholomorph (regularData.projection x))) =
+      _
+  exact
+    congrArg regularData.zeroSection
+      (SpecialPeriods.Threefold.regularBiholomorph.symm_apply_apply (regularData.projection x))
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.overlap_cuspZeroSection (t : Disc)
+    (ht : (t : ℂ) ≠ 0) :
+    SpecialPeriods.Threefold.specialCuspOverlap (cuspZeroSection t) =
+      regularZeroSection (regularBase t ht) := by
+  have hzero :=
+    SpecialPeriods.CuspGlobalOverlap.cuspToRegularPartial_zeroSection data regularData
+      radius_le_cuspChart period_agreement t ht
+  change
+    SpecialPeriods.Threefold.specialCuspOverlap (cuspZeroSection t) =
+      regularData.zeroSection
+        (regularData.projection
+          (SpecialPeriods.Threefold.specialCuspOverlap (cuspZeroSection t))) at hzero
+  calc
+    SpecialPeriods.Threefold.specialCuspOverlap (cuspZeroSection t) =
+        regularData.zeroSection
+          (regularData.projection
+            (SpecialPeriods.Threefold.specialCuspOverlap (cuspZeroSection t))) :=
+      hzero
+    _ =
+        regularZeroSection
+          (SpecialPeriods.Threefold.specialRegularFamilyProjection
+            (SpecialPeriods.Threefold.specialCuspOverlap (cuspZeroSection t))) :=
+      (regularZeroSection_projection_eq _).symm
+    _ = regularZeroSection (regularBase t ht) :=
+      congrArg regularZeroSection (overlap_cuspZeroSection_projection t ht)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.inclusion_cuspZeroSection (t : Disc)
+    (ht : (t : ℂ) ≠ 0) :
+    SpecialPeriods.Threefold.inclusion (Option.some Option.none) (cuspZeroSection t) =
+      SpecialPeriods.Threefold.inclusion Option.none (regularZeroSection (regularBase t ht)) := by
+  apply
+    (SpecialPeriods.Threefold.gluingData.inclusion_eq_iff (Option.some Option.none) Option.none _
+        _).mpr
+  exact ⟨cuspZeroSection_mem_overlap t ht, overlap_cuspZeroSection t ht⟩
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace in
+private def SpecialPeriods.Threefold.CuspAttaching.extendedSection :
+    Disc → SpecialPeriods.Threefold.Space :=
+  SpecialPeriods.Threefold.inclusion (Option.some Option.none) ∘ cuspZeroSection
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.extendedSection_continuous :
+    Continuous extendedSection :=
+  (SpecialPeriods.Threefold.inclusion_openEmbedding (Option.some Option.none)).continuous.comp
+    cuspZeroSection_continuous
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace in
+private def SpecialPeriods.Threefold.CuspAttaching.regularSection :
+    SpecialPeriods.Threefold.regularPatch → SpecialPeriods.Threefold.Space :=
+  SpecialPeriods.Threefold.inclusion Option.none ∘ regularZeroSection
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.regularSection_continuous :
+    Continuous regularSection :=
+  (SpecialPeriods.Threefold.inclusion_openEmbedding Option.none).continuous.comp
+    regularZeroSection_continuous
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace in
+private def SpecialPeriods.Threefold.CuspAttaching.attachedRegularSection :
+    OverlapBase → SpecialPeriods.Threefold.Space :=
+  regularSection ∘ Subtype.val
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.attachedRegularSection_continuous :
+    Continuous attachedRegularSection :=
+  regularSection_continuous.comp continuous_subtype_val
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.attachedRegularSection_eq_extended
+    (b : OverlapBase) : attachedRegularSection b = extendedSection (overlapCoordinate b) := by
+  have h := inclusion_cuspZeroSection (overlapCoordinate b) (overlapCoordinate_ne_zero b)
+  rw [regularBase_overlapCoordinate] at h
+  exact h.symm
+
+private def
+    SpecialPeriods.Threefold.CuspAttaching.attachedRegularSectionLoopContraction {b : OverlapBase}
+    (p : Path b b) :
+    (p.map attachedRegularSection_continuous).Homotopy (Path.refl (attachedRegularSection b)) := by
+  let H := CuspQuotient.discLoopContraction (p.map overlapCoordinate_continuous)
+  refine
+    { toFun := fun u => extendedSection (H u)
+      continuous_toFun := extendedSection_continuous.comp H.continuous
+      map_zero_left := ?_
+      map_one_left := ?_
+      prop' := ?_ }
+  · intro t
+    exact
+      (congrArg extendedSection (H.map_zero_left t)).trans
+        (attachedRegularSection_eq_extended (p t)).symm
+  · intro t
+    exact
+      (congrArg extendedSection (H.map_one_left t)).trans
+        (attachedRegularSection_eq_extended b).symm
+  · intro r t ht
+    rcases ht with rfl | rfl
+    · exact
+        (congrArg extendedSection (Path.Homotopy.source H r)).trans
+          ((attachedRegularSection_eq_extended b).symm.trans
+            (congrArg attachedRegularSection p.source.symm))
+    · exact
+        (congrArg extendedSection (Path.Homotopy.target H r)).trans
+          ((attachedRegularSection_eq_extended b).symm.trans
+            (congrArg attachedRegularSection p.target.symm))
+
+private def SpecialPeriods.Threefold.CuspAttaching.regularLoopInOverlap
+    {b : SpecialPeriods.Threefold.regularPatch}
+    (hb :
+      (b : SpecialPeriods.TriangleCompactifiedOrbitSpace) ∈
+        SpecialPeriods.Threefold.specialBaseCover.fillingPatch Option.none)
+    (p : Path b b)
+    (hp :
+      ∀ t,
+        (p t : SpecialPeriods.TriangleCompactifiedOrbitSpace) ∈
+          SpecialPeriods.Threefold.specialBaseCover.fillingPatch Option.none) :
+    Path (⟨b, hb⟩ : OverlapBase) ⟨b, hb⟩
+    where
+  toFun t := ⟨p t, hp t⟩
+  continuous_toFun := p.continuous.subtype_mk _
+  source' := Subtype.ext p.source
+  target' := Subtype.ext p.target
+
+private theorem SpecialPeriods.Threefold.CuspAttaching.regularLoopInOverlap_map
+    {b : SpecialPeriods.Threefold.regularPatch}
+    (hb :
+      (b : SpecialPeriods.TriangleCompactifiedOrbitSpace) ∈
+        SpecialPeriods.Threefold.specialBaseCover.fillingPatch Option.none)
+    (p : Path b b)
+    (hp :
+      ∀ t,
+        (p t : SpecialPeriods.TriangleCompactifiedOrbitSpace) ∈
+          SpecialPeriods.Threefold.specialBaseCover.fillingPatch Option.none) :
+    (regularLoopInOverlap hb p hp).map attachedRegularSection_continuous =
+      p.map regularSection_continuous := by
+  ext t
+  rfl
+
+private def SpecialPeriods.Threefold.CuspAttaching.regularSectionLoopContraction_of_mem
+    {b : SpecialPeriods.Threefold.regularPatch} (p : Path b b)
+    (hp :
+      ∀ t,
+        (p t : SpecialPeriods.TriangleCompactifiedOrbitSpace) ∈
+          SpecialPeriods.Threefold.specialBaseCover.fillingPatch Option.none) :
+    (p.map regularSection_continuous).Homotopy (Path.refl (regularSection b)) := by
+  have hb :
+    (b : SpecialPeriods.TriangleCompactifiedOrbitSpace) ∈
+      SpecialPeriods.Threefold.specialBaseCover.fillingPatch Option.none := by
+    simpa only [p.source] using hp 0
+  exact
+    (attachedRegularSectionLoopContraction (regularLoopInOverlap hb p hp)).cast
+      (regularLoopInOverlap_map hb p hp) rfl
+
+private theorem SpecialPeriods.Threefold.CuspAttaching.regularSection_loop_nullhomotopic_of_mem
+    {b : SpecialPeriods.Threefold.regularPatch} (p : Path b b)
+    (hp :
+      ∀ t,
+        (p t : SpecialPeriods.TriangleCompactifiedOrbitSpace) ∈
+          SpecialPeriods.Threefold.specialBaseCover.fillingPatch Option.none) :
+    Path.Homotopic (p.map regularSection_continuous) (Path.refl (regularSection b)) :=
+  ⟨regularSectionLoopContraction_of_mem p hp⟩
+
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace
+    SpecialPeriods.Threefold.chartedSpace in
+private def SpecialPeriods.Threefold.CuspAttaching.fillingHomeomorph :
+    SpecialPeriods.Threefold.SpecialCuspPiece ≃ₜ
+      SpecialPeriods.Threefold.liftedPatch (Option.some Option.none) :=
+  (SpecialPeriods.Threefold.patchBiholomorph (Option.some Option.none)).toHomeomorph
+
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace
+    SpecialPeriods.Threefold.chartedSpace in
+private abbrev SpecialPeriods.Threefold.CuspAttaching.NonzeroFibre (s : ℂ) :=
+  CuspQuotient.projection data.correction radius ⁻¹' {CuspUniformization.exponential s}
+
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace
+    SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.nonzeroFibre_mem_regular (s : ℂ)
+    (x : NonzeroFibre s) :
+    (fillingHomeomorph x.val).val ∈ SpecialPeriods.Threefold.liftedPatch Option.none := by
+  change
+    SpecialPeriods.Threefold.projection (fillingHomeomorph x.val) ∈
+      SpecialPeriods.Threefold.regularPatch
+  have hp :
+    SpecialPeriods.Threefold.projection (fillingHomeomorph x.val) =
+      SpecialPeriods.Threefold.CuspPiece.projectionToBase SpecialPeriods.specialCuspData
+        SpecialPeriods.Threefold.specialBaseCover x.val :=
+    SpecialPeriods.Threefold.gluingData.projection_inclusion (Option.some Option.none) x.val
+  rw [hp]
+  apply
+    (SpecialPeriods.Threefold.CuspPiece.projectionToBase_mem_regular_iff
+        SpecialPeriods.specialCuspData SpecialPeriods.Threefold.specialBaseCover x.val).mpr
+  have hx :
+    CuspQuotient.projection data.correction radius x.val = CuspUniformization.exponential s :=
+    x.property
+  exact hx.trans_ne (CuspUniformization.exponential_ne_zero s)
+
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace
+    SpecialPeriods.Threefold.chartedSpace in
+private def SpecialPeriods.Threefold.CuspAttaching.fibreToOverlap (s : ℂ) :
+    C(NonzeroFibre s, SpecialPeriods.Threefold.RegularOverlap Option.none)
+    where
+  toFun
+    x :=
+    ⟨fillingHomeomorph x.val, nonzeroFibre_mem_regular s x, (fillingHomeomorph x.val).property⟩
+  continuous_toFun :=
+    (continuous_subtype_val.comp
+          (fillingHomeomorph.continuous.comp continuous_subtype_val)).subtype_mk
+      _
+
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace
+    SpecialPeriods.Threefold.chartedSpace in
+private theorem
+    SpecialPeriods.Threefold.CuspAttaching.fibreToOverlap_fundamentalGroup_factors (s : ℂ)
+    (x : NonzeroFibre s) (γ : FundamentalGroup (NonzeroFibre s) x) :
+    FundamentalGroup.map (SpecialPeriods.Threefold.overlapFillingInclusion Option.none)
+        (fibreToOverlap s x) (FundamentalGroup.map (fibreToOverlap s) x γ) =
+      homeomorphFundamentalGroupEquiv fillingHomeomorph x.val
+        (FundamentalGroup.map ⟨Subtype.val, continuous_subtype_val⟩ x γ) := by
+  obtain ⟨p⟩ := γ
+  apply congrArg Path.Homotopic.Quotient.mk
+  ext t
+  rfl
+
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace
+    SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.exists_surjective_overlap_basepoint (s : ℂ)
+    (hs : ‖CuspUniformization.exponential s‖ < radius) :
+    ∃ x : SpecialPeriods.Threefold.RegularOverlap Option.none,
+      Function.Surjective
+        (FundamentalGroup.map (SpecialPeriods.Threefold.overlapFillingInclusion Option.none) x) :=
+  by
+  have hpos : 0 < ‖CuspUniformization.exponential s‖ :=
+    norm_pos_iff.mpr (CuspUniformization.exponential_ne_zero s)
+  have hlog := Real.log_neg hpos (hs.trans data.radius_lt_one)
+  have hRp := data.smallDrift _ hpos hs
+  let x : NonzeroFibre s := CuspUniformization.fibreBasePoint data.correction radius s hs hlog hRp
+  have hf : Function.Surjective (FundamentalGroup.map ⟨Subtype.val, continuous_subtype_val⟩ x) :=
+    CuspUniformization.fibreInclusionFundamentalGroupMap_surjective data.correction radius s hs
+      hlog hRp data.radius_pos data.radius_lt_one data.holomorphic data.smallDrift
+  refine ⟨fibreToOverlap s x, ?_⟩
+  intro γ
+  obtain ⟨δ, rfl⟩ := (homeomorphFundamentalGroupEquiv fillingHomeomorph x.val).surjective γ
+  obtain ⟨ε, rfl⟩ := hf δ
+  exact
+    ⟨FundamentalGroup.map (fibreToOverlap s) x ε, fibreToOverlap_fundamentalGroup_factors s x ε⟩
+
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace
+    SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.exists_small_exponential :
+    ∃ s : ℂ, ‖CuspUniformization.exponential s‖ < radius := by
+  have hr : 0 < radius / 2 := half_pos data.radius_pos
+  have ht : ((radius / 2 : ℝ) : ℂ) ≠ 0 := by exact_mod_cast ne_of_gt hr
+  refine ⟨CuspUniformization.logarithm ((radius / 2 : ℝ) : ℂ), ?_⟩
+  rw [CuspUniformization.exponential_logarithm ht, Complex.norm_real, Real.norm_eq_abs,
+    abs_of_pos hr]
+  exact half_lt_self data.radius_pos
+
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace
+    SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.cusp_overlapFillingHom_surjective :
+    Function.Surjective (overlapFillingHom (Option.none : Puncture)) := by
+  obtain ⟨s, hs⟩ := CuspAttaching.exists_small_exponential
+  obtain ⟨x, hx⟩ := CuspAttaching.exists_surjective_overlap_basepoint s hs
+  let := liftedPatch_regular_inter_pathConnectedSpace (Option.none : Puncture)
+  exact
+    fundamentalGroup_map_surjective_at_of_pathConnected (overlapFillingInclusion Option.none) x
+      (regularOverlapPoint Option.none) hx
+
+private theorem SpecialPeriods.Threefold.overlapFillingHom_surjective (i : Puncture) :
+    Function.Surjective (overlapFillingHom i) := by
+  cases i with
+  | none => exact cusp_overlapFillingHom_surjective
+  | some j => exact overlapFillingHom_elliptic_surjective j
+
+private theorem SpecialPeriods.Threefold.regularLiftedInclusion_fundamentalGroup_surjective
+    (x : liftedPatch Option.none) :
+    Function.Surjective (FundamentalGroup.map regularLiftedInclusion x) :=
+  regularLiftedInclusion_fundamentalGroup_map_surjective overlapFillingHom_surjective x
+
+private def SpecialPeriods.Threefold.regularFamilyInclusionMap : C(SpecialRegularFamily, Space) :=
+  ⟨SpecialPeriods.Threefold.inclusion Option.none,
+    (inclusion_openEmbedding Option.none).continuous⟩
+
+private theorem SpecialPeriods.Threefold.regularFamilyInclusionMap_fundamentalGroup_surjective
+    (x : SpecialRegularFamily) :
+    Function.Surjective (FundamentalGroup.map regularFamilyInclusionMap x) := by
+  let e := gluingData.patchHomeomorph Option.none
+  have hpatch := regularLiftedInclusion_fundamentalGroup_surjective (e x)
+  have hlocal := (homeomorphFundamentalGroupEquiv e x).surjective
+  have hmap :
+    (FundamentalGroup.map regularLiftedInclusion (e x)).comp
+        (homeomorphFundamentalGroupEquiv e x).toMonoidHom =
+      FundamentalGroup.map regularFamilyInclusionMap x := by
+    ext γ
+    obtain ⟨p⟩ := γ
+    apply congrArg Path.Homotopic.Quotient.mk
+    ext t
+    rfl
+  rw [← hmap]
+  exact hpatch.comp hlocal
+
+private def SpecialPeriods.Threefold.specialRegularFamilyMarkedPoint : SpecialRegularFamily :=
+  ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁
+        SpecialPeriods.specialPeriodMap_generator₂)).fundamentalGroupBasepoint
+    (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+
+private def SpecialPeriods.Threefold.specialRegularFamilyMarkedLatticeHom :
+    Multiplicative Lattice →*
+      FundamentalGroup SpecialRegularFamily specialRegularFamilyMarkedPoint :=
+  ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁
+        SpecialPeriods.specialPeriodMap_generator₂)).latticeFundamentalGroupHom
+    (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+
+private def SpecialPeriods.Threefold.specialRegularFamilyMarkedSectionHom :
+    FundamentalGroup SpecialPeriods.TriangleRegularQuotient
+        (SpecialPeriods.triangleRegularProject
+          (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)) →*
+      FundamentalGroup SpecialRegularFamily specialRegularFamilyMarkedPoint :=
+  ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁
+        SpecialPeriods.specialPeriodMap_generator₂)).sectionFundamentalGroupHom
+    (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+
+private def SpecialPeriods.Threefold.specialRegularFamilyMarkedMeridianPath (b : Bool) :
+    Path specialRegularFamilyMarkedPoint specialRegularFamilyMarkedPoint :=
+  (PeriodFamily.Meridians.compatibleRegularMeridian b).map
+    ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁
+        SpecialPeriods.specialPeriodMap_generator₂)).zeroSection_continuous
+
+private def SpecialPeriods.Threefold.specialRegularFamilyMarkedMeridianClass (b : Bool) :
+    FundamentalGroup SpecialRegularFamily specialRegularFamilyMarkedPoint :=
+  FundamentalGroup.fromPath
+    (Path.Homotopic.Quotient.mk (specialRegularFamilyMarkedMeridianPath b))
+
+@[simp]
+private theorem
+    SpecialPeriods.Threefold.specialRegularFamilyMarkedMeridianClass_eq_section (b : Bool) :
+    specialRegularFamilyMarkedMeridianClass b =
+      specialRegularFamilyMarkedSectionHom
+        (PeriodFamily.Meridians.compatibleRegularMeridianClass b) :=
+  rfl
+
+private def SpecialPeriods.Threefold.specialRegularFamilyMarkedFundamentalGroupEquiv :
+    FundamentalGroup SpecialRegularFamily specialRegularFamilyMarkedPoint ≃*
+      (Multiplicative Lattice) ⋊[PeriodFamily.Meridians.sourceFreeLatticeAction]
+        (FreeGroup Bool) :=
+  PeriodFamily.markedRegularFundamentalGroupEquiv SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+
+@[simp]
+private theorem SpecialPeriods.Threefold.specialRegularFamilyMarkedFundamentalGroupEquiv_lattice
+    (v : Multiplicative Lattice) :
+    specialRegularFamilyMarkedFundamentalGroupEquiv (specialRegularFamilyMarkedLatticeHom v) =
+      SemidirectProduct.inl v :=
+  PeriodFamily.markedRegularFundamentalGroupEquiv_lattice SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂ v
+
+private theorem SpecialPeriods.Threefold.specialRegularFamilyMarkedFundamentalGroupEquiv_meridian
+    (b : Bool) :
+    specialRegularFamilyMarkedFundamentalGroupEquiv (specialRegularFamilyMarkedMeridianClass b) =
+      SemidirectProduct.inr (FreeGroup.of b) :=
+  PeriodFamily.markedRegularFundamentalGroupEquiv_meridian SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂ b
+
+private theorem SpecialPeriods.Threefold.specialRegularFamilyMarkedMeridian_conjugation (b : Bool)
+    (v : Multiplicative Lattice) :
+    specialRegularFamilyMarkedMeridianClass b * specialRegularFamilyMarkedLatticeHom v *
+        (specialRegularFamilyMarkedMeridianClass b)⁻¹ =
+      specialRegularFamilyMarkedLatticeHom
+        (PeriodFamily.Meridians.sourceFreeLatticeAction (FreeGroup.of b) v) := by
+  apply specialRegularFamilyMarkedFundamentalGroupEquiv.injective
+  rw [map_mul, map_mul, map_inv, specialRegularFamilyMarkedFundamentalGroupEquiv_meridian,
+    specialRegularFamilyMarkedFundamentalGroupEquiv_lattice,
+    specialRegularFamilyMarkedFundamentalGroupEquiv_lattice]
+  simpa only [map_inv] using
+    (SemidirectProduct.inl_aut (φ := PeriodFamily.Meridians.sourceFreeLatticeAction)
+        (FreeGroup.of b) v).symm
+
+private theorem SpecialPeriods.Threefold.specialRegularFamilyMarkedMeridian_first_conjugation
+    (v : Lattice) :
+    specialRegularFamilyMarkedMeridianClass Bool.false *
+          specialRegularFamilyMarkedLatticeHom (Multiplicative.ofAdd v) *
+        (specialRegularFamilyMarkedMeridianClass Bool.false)⁻¹ =
+      specialRegularFamilyMarkedLatticeHom (Multiplicative.ofAdd (A₁ *ᵥ v)) := by
+  rw [specialRegularFamilyMarkedMeridian_conjugation]
+  exact
+    congrArg specialRegularFamilyMarkedLatticeHom
+      (Multiplicative.toAdd.injective
+        (PeriodFamily.Meridians.sourceFreeLatticeAction_first (Multiplicative.ofAdd v)))
+
+private theorem SpecialPeriods.Threefold.specialRegularFamilyMarkedMeridian_second_conjugation
+    (v : Lattice) :
+    specialRegularFamilyMarkedMeridianClass Bool.true *
+          specialRegularFamilyMarkedLatticeHom (Multiplicative.ofAdd v) *
+        (specialRegularFamilyMarkedMeridianClass Bool.true)⁻¹ =
+      specialRegularFamilyMarkedLatticeHom (Multiplicative.ofAdd (A₂ *ᵥ v)) := by
+  rw [specialRegularFamilyMarkedMeridian_conjugation]
+  exact
+    congrArg specialRegularFamilyMarkedLatticeHom
+      (Multiplicative.toAdd.injective
+        (PeriodFamily.Meridians.sourceFreeLatticeAction_second (Multiplicative.ofAdd v)))
+
+private def SpecialPeriods.Threefold.PiOne.basepoint : SpecialPeriods.Threefold.Space :=
+  SpecialPeriods.Threefold.regularFamilyInclusionMap
+    SpecialPeriods.Threefold.specialRegularFamilyMarkedPoint
+
+private abbrev SpecialPeriods.Threefold.PiOne.GlobalGroup :=
+  FundamentalGroup SpecialPeriods.Threefold.Space basepoint
+
+private def SpecialPeriods.Threefold.PiOne.regularHom :
+    FundamentalGroup SpecialPeriods.Threefold.SpecialRegularFamily
+        SpecialPeriods.Threefold.specialRegularFamilyMarkedPoint →*
+      GlobalGroup :=
+  FundamentalGroup.map SpecialPeriods.Threefold.regularFamilyInclusionMap
+    SpecialPeriods.Threefold.specialRegularFamilyMarkedPoint
+
+private theorem
+    SpecialPeriods.Threefold.PiOne.regularHom_surjective : Function.Surjective regularHom :=
+  SpecialPeriods.Threefold.regularFamilyInclusionMap_fundamentalGroup_surjective
+    SpecialPeriods.Threefold.specialRegularFamilyMarkedPoint
+
+private def SpecialPeriods.Threefold.PiOne.latticeHom : Multiplicative Lattice →* GlobalGroup :=
+  regularHom.comp SpecialPeriods.Threefold.specialRegularFamilyMarkedLatticeHom
+
+private def SpecialPeriods.Threefold.PiOne.meridian (b : Bool) : GlobalGroup :=
+  regularHom (SpecialPeriods.Threefold.specialRegularFamilyMarkedMeridianClass b)
+
+private theorem SpecialPeriods.Threefold.PiOne.meridian_first_conjugation (v : Lattice) :
+    meridian Bool.false * latticeHom (Multiplicative.ofAdd v) * (meridian Bool.false)⁻¹ =
+      latticeHom (Multiplicative.ofAdd (A₁ *ᵥ v)) := by
+  simpa only [map_mul, map_inv, meridian, latticeHom, MonoidHom.comp_apply] using
+    congrArg regularHom
+      (SpecialPeriods.Threefold.specialRegularFamilyMarkedMeridian_first_conjugation v)
+
+private theorem SpecialPeriods.Threefold.PiOne.meridian_second_conjugation (v : Lattice) :
+    meridian Bool.true * latticeHom (Multiplicative.ofAdd v) * (meridian Bool.true)⁻¹ =
+      latticeHom (Multiplicative.ofAdd (A₂ *ᵥ v)) := by
+  simpa only [map_mul, map_inv, meridian, latticeHom, MonoidHom.comp_apply] using
+    congrArg regularHom
+      (SpecialPeriods.Threefold.specialRegularFamilyMarkedMeridian_second_conjugation v)
+
+private theorem
+    SpecialPeriods.Threefold.PiOne.hom_ext {H : Type*} [Monoid H] (f g : GlobalGroup →* H)
+    (hL : ∀ v : Multiplicative Lattice, f (latticeHom v) = g (latticeHom v))
+    (hM : ∀ b : Bool, f (meridian b) = g (meridian b)) : f = g := by
+  have h :=
+    PeriodFamily.markedRegularFundamentalGroupHom_ext SpecialPeriods.specialPeriodMap
+      SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+      (f.comp regularHom) (g.comp regularHom) hL hM
+  ext γ
+  obtain ⟨δ, rfl⟩ := regularHom_surjective γ
+  exact DFunLike.congr_fun h δ
+
+private theorem
+    SpecialPeriods.Threefold.PiOne.hom_eq_one {H : Type*} [Monoid H] (f : GlobalGroup →* H)
+    (hL : ∀ v : Multiplicative Lattice, f (latticeHom v) = 1)
+    (hM : ∀ b : Bool, f (meridian b) = 1) : f = 1 :=
+  hom_ext f 1 hL hM
+
+private def
+    SpecialPeriods.Threefold.EllipticGeometry.attachingPieceInclusionMap (j : Elliptic.Kind) :
+    C(LocalSpace j, SpecialPeriods.Threefold.Space) :=
+  ⟨SpecialPeriods.Threefold.EllipticGeometry.inclusion j, inclusion_continuous j⟩
+
+private theorem
+    SpecialPeriods.Threefold.EllipticGeometry.inclusion_eq_regular_overlap (j : Elliptic.Kind)
+    (x : LocalSpace j) (hx : x ∈ (SpecialPeriods.Threefold.specialEllipticOverlap j).source) :
+    SpecialPeriods.Threefold.EllipticGeometry.inclusion j x =
+      SpecialPeriods.Threefold.regularFamilyInclusionMap
+        (SpecialPeriods.Threefold.specialEllipticOverlap j x) := by
+  change
+    SpecialPeriods.Threefold.gluingData.inclusion (Option.some (Option.some j)) x =
+      SpecialPeriods.Threefold.gluingData.inclusion Option.none
+        (SpecialPeriods.Threefold.specialEllipticOverlap j x)
+  exact
+    (SpecialPeriods.Threefold.gluingData.inclusion_eq_iff (Option.some (Option.some j))
+          Option.none x _).mpr
+      ⟨hx, rfl⟩
+
+private theorem
+    SpecialPeriods.Threefold.EllipticGeometry.attachingLoop_mem_overlap (j : Elliptic.Kind)
+    (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (t : (unitInterval)) :
+    attachingLoop j s₀ hs₀ hr t ∈ (SpecialPeriods.Threefold.specialEllipticOverlap j).source := by
+  rw [SpecialPeriods.Threefold.specialEllipticOverlap_source]
+  exact projectionToBase_attachingLoop_mem_regular j s₀ hs₀ hr t
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingFibreLoop_mem_overlap
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (w : Lattice) (t : (unitInterval)) :
+    attachingFibreLoop j s₀ hs₀ hr w t ∈
+      (SpecialPeriods.Threefold.specialEllipticOverlap j).source := by
+  rw [SpecialPeriods.Threefold.specialEllipticOverlap_source]
+  exact projectionToBase_attachingFibreLoop_mem_regular j s₀ hs₀ hr w t
+
+private theorem
+    SpecialPeriods.Threefold.EllipticGeometry.attachingRegularPoint_one_eq (j : Elliptic.Kind)
+    (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).quotient
+        (attachingUpstairsPoint j s₀ hs₀ 1, 0) =
+      ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).quotient
+        (attachingUpstairsPoint j s₀ hs₀ 0, 0) := by
+  calc
+    _ = SpecialPeriods.Threefold.specialEllipticOverlap j (attachingLoop j s₀ hs₀ hr 1) :=
+      (specialEllipticOverlap_attachingLoop j s₀ hs₀ hr 1).symm
+    _ = SpecialPeriods.Threefold.specialEllipticOverlap j (attachingLoop j s₀ hs₀ hr 0) :=
+      (congrArg (SpecialPeriods.Threefold.specialEllipticOverlap j)
+        (attachingLoop j s₀ hs₀ hr).target)
+    _ = _ := specialEllipticOverlap_attachingLoop j s₀ hs₀ hr 0
+
+private def
+    SpecialPeriods.Threefold.EllipticGeometry.attachingRegularLoop (j : Elliptic.Kind) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    Path
+      (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).fundamentalGroupBasepoint
+        (attachingUpstairsPoint j s₀ hs₀ 0))
+      (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).fundamentalGroupBasepoint
+        (attachingUpstairsPoint j s₀ hs₀ 0))
+    where
+  toFun
+    t :=
+    ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁
+          SpecialPeriods.specialPeriodMap_generator₂)).quotient
+      (attachingUpstairsPoint j s₀ hs₀ t, 0)
+  continuous_toFun :=
+    ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁
+          SpecialPeriods.specialPeriodMap_generator₂)).quotient_continuous.comp
+      ((attachingUpstairsPoint_continuous j s₀ hs₀).prodMk continuous_const)
+  source' := rfl
+  target' := attachingRegularPoint_one_eq j s₀ hs₀ hr
+
+private def SpecialPeriods.Threefold.EllipticGeometry.attachingRegularBaseLoop (j : Elliptic.Kind)
+    (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    Path (SpecialPeriods.triangleRegularProject (attachingUpstairsPoint j s₀ hs₀ 0))
+      (SpecialPeriods.triangleRegularProject (attachingUpstairsPoint j s₀ hs₀ 0)) :=
+  (attachingRegularLoop j s₀ hs₀ hr).map
+    ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁
+        SpecialPeriods.specialPeriodMap_generator₂)).projection_continuous
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingRegularLoop_eq_zeroSection
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    attachingRegularLoop j s₀ hs₀ hr =
+      (attachingRegularBaseLoop j s₀ hs₀ hr).map
+        ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).zeroSection_continuous := by
+  ext t
+  rfl
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingRegularBaseLoop_compact
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (t : (unitInterval)) :
+    SpecialPeriods.Threefold.regularInclusion (attachingRegularBaseLoop j s₀ hs₀ hr t) =
+      (SpecialPeriods.Threefold.punctureChart (Option.some j)).symm
+        (CuspUniformization.exponential (s₀ - ((t : ℝ) : ℂ) / (j.order : ℂ)) ^ j.order) := by
+  have h :=
+    SpecialPeriods.Threefold.specialEllipticOverlap_base j (attachingLoop j s₀ hs₀ hr t)
+      (attachingLoop_mem_overlap j s₀ hs₀ hr t)
+  rw [specialEllipticOverlap_attachingLoop] at h
+  exact h.trans (projectionToBase_attachingLoop j s₀ hs₀ hr t)
+
+private theorem
+    SpecialPeriods.Threefold.EllipticGeometry.attachingGlobalBasepoint_eq (j : Elliptic.Kind)
+    (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    SpecialPeriods.Threefold.EllipticGeometry.inclusion j (attachingBasepoint j s₀ hs₀ hr) =
+      SpecialPeriods.Threefold.regularFamilyInclusionMap
+        (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)).fundamentalGroupBasepoint
+          (attachingUpstairsPoint j s₀ hs₀ 0)) := by
+  exact
+    (inclusion_eq_regular_overlap j (attachingLoop j s₀ hs₀ hr 0)
+          (attachingLoop_mem_overlap j s₀ hs₀ hr 0)).trans
+      (congrArg SpecialPeriods.Threefold.regularFamilyInclusionMap
+        (specialEllipticOverlap_attachingLoop j s₀ hs₀ hr 0))
+
+private def
+    SpecialPeriods.Threefold.EllipticGeometry.includedAttachingLoop (j : Elliptic.Kind) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    Path
+      (SpecialPeriods.Threefold.regularFamilyInclusionMap
+        (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)).fundamentalGroupBasepoint
+          (attachingUpstairsPoint j s₀ hs₀ 0)))
+      (SpecialPeriods.Threefold.regularFamilyInclusionMap
+        (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)).fundamentalGroupBasepoint
+          (attachingUpstairsPoint j s₀ hs₀ 0))) :=
+  ((attachingLoop j s₀ hs₀ hr).map (inclusion_continuous j)).cast
+    (attachingGlobalBasepoint_eq j s₀ hs₀ hr).symm (attachingGlobalBasepoint_eq j s₀ hs₀ hr).symm
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.includedAttachingLoop_eq_regular
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    includedAttachingLoop j s₀ hs₀ hr =
+      (attachingRegularLoop j s₀ hs₀ hr).map
+        SpecialPeriods.Threefold.regularFamilyInclusionMap.continuous := by
+  ext t
+  exact
+    (inclusion_eq_regular_overlap j (attachingLoop j s₀ hs₀ hr t)
+          (attachingLoop_mem_overlap j s₀ hs₀ hr t)).trans
+      (congrArg SpecialPeriods.Threefold.regularFamilyInclusionMap
+        (specialEllipticOverlap_attachingLoop j s₀ hs₀ hr t))
+
+private def SpecialPeriods.Threefold.EllipticGeometry.includedAttachingFibreLoop (j : Elliptic.Kind)
+    (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (w : Lattice) :
+    Path
+      (SpecialPeriods.Threefold.regularFamilyInclusionMap
+        (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)).fundamentalGroupBasepoint
+          (attachingUpstairsPoint j s₀ hs₀ 0)))
+      (SpecialPeriods.Threefold.regularFamilyInclusionMap
+        (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)).fundamentalGroupBasepoint
+          (attachingUpstairsPoint j s₀ hs₀ 0))) :=
+  ((attachingFibreLoop j s₀ hs₀ hr w).map (inclusion_continuous j)).cast
+    (attachingGlobalBasepoint_eq j s₀ hs₀ hr).symm (attachingGlobalBasepoint_eq j s₀ hs₀ hr).symm
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingRegularBaseLoop_plane
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (t : (unitInterval)) :
+    (SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+          (attachingRegularBaseLoop j s₀ hs₀ hr t) :
+        ℂ) =
+      attachingPlaneCoordinate j
+        (CuspUniformization.exponential s₀ ^ j.order *
+          SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit t) := by
+  have h :=
+    attachingPlaneCoordinate_eq_regularPlane j _ (attachingRegularBaseLoop j s₀ hs₀ hr t)
+      (attachingRegularBaseLoop_compact j s₀ hs₀ hr t)
+  rwa [attaching_log_parameter_clockwise] at h
+
+private def
+    SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianSquare (j : Elliptic.Kind) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (hsmall : ‖CuspUniformization.exponential s₀‖ ^ j.order < attachingMeridianRadius j) :
+    SpecialPeriods.EllipticAttachingMeridians.LoopSquare (attachingRegularBaseLoop j s₀ hs₀ hr)
+      (SpecialPeriods.EllipticAttachingMeridians.clockwiseRegularMeridian
+        (attachingMeridianIndex j)) :=
+  (attachingPlaneControl j).regularMeridianSquare (attachingMeridianIndex j)
+    (attachingPlaneCoordinate_zero_eq_center j) (CuspUniformization.exponential s₀ ^ j.order)
+    (attaching_initial_coordinate_ne_zero j s₀) (attaching_parameters_control_bound j hsmall)
+    (attachingRegularBaseLoop j s₀ hs₀ hr) (attachingRegularBaseLoop_plane j s₀ hs₀ hr)
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingMeridian_map_whisker
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (hsmall : ‖CuspUniformization.exponential s₀‖ ^ j.order < attachingMeridianRadius j)
+    {G : Type*} [Group G]
+    (τ :
+      Path
+        (SpecialPeriods.triangleRegularProject
+          PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+        (SpecialPeriods.triangleRegularProject (attachingUpstairsPoint j s₀ hs₀ 0)))
+    (φ :
+      FundamentalGroup SpecialPeriods.TriangleRegularQuotient
+          (SpecialPeriods.triangleRegularProject
+            PeriodFamily.Meridians.normalizedRegularMeridianBasepoint) →*
+        G)
+    (hcomm : ∀ g h : G, Commute g h) :
+    φ
+        (FundamentalGroup.fromPath
+          (Path.Homotopic.Quotient.mk
+            (τ.trans ((attachingRegularBaseLoop j s₀ hs₀ hr).trans τ.symm)))) =
+      if PeriodFamily.Meridians.normalizationReversesMeridians then
+        φ (PeriodFamily.Meridians.compatibleRegularMeridianClass (attachingMeridianIndex j))
+      else
+        (φ
+            (PeriodFamily.Meridians.compatibleRegularMeridianClass
+              (attachingMeridianIndex j)))⁻¹ := by
+  have h := (attachingMeridianSquare j s₀ hs₀ hr hsmall).map_whisker_eq τ φ hcomm
+  rw [SpecialPeriods.EllipticAttachingMeridians.clockwiseRegularMeridian_class] at h
+  simpa only [apply_ite, map_inv] using h
+
+private def
+    SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingParameter (j : Elliptic.Kind) : ℂ :=
+  (exists_small_attaching_parameters j).choose
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingParameter_im_pos
+    (j : Elliptic.Kind) : 0 < (chosenAttachingParameter j).im :=
+  (exists_small_attaching_parameters j).choose_spec.1
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingParameter_bound
+    (j : Elliptic.Kind) :
+    ‖CuspUniformization.exponential (chosenAttachingParameter j)‖ ^ j.order <
+      attachingMeridianRadius j :=
+  (exists_small_attaching_parameters j).choose_spec.2
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingParameter_filling_bound
+    (j : Elliptic.Kind) :
+    ‖CuspUniformization.exponential (chosenAttachingParameter j)‖ ^ j.order <
+      SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j) :=
+  attaching_parameters_filling_bound j (chosenAttachingParameter_bound j)
+
+private def SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingBasepoint (j : Elliptic.Kind) :
+    SpecialPeriods.TriangleRegularQuotient :=
+  SpecialPeriods.triangleRegularProject
+    (attachingUpstairsPoint j (chosenAttachingParameter j) (chosenAttachingParameter_im_pos j) 0)
+
+private def SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingBaseLoop (j : Elliptic.Kind) :
+    Path (chosenAttachingBasepoint j) (chosenAttachingBasepoint j) :=
+  attachingRegularBaseLoop j (chosenAttachingParameter j) (chosenAttachingParameter_im_pos j)
+    (chosenAttachingParameter_filling_bound j)
+
+private def SpecialPeriods.Threefold.EllipticGeometry.chosenAttachingSquare (j : Elliptic.Kind) :
+    SpecialPeriods.EllipticAttachingMeridians.LoopSquare (chosenAttachingBaseLoop j)
+      (SpecialPeriods.EllipticAttachingMeridians.clockwiseRegularMeridian
+        (attachingMeridianIndex j)) :=
+  attachingMeridianSquare j (chosenAttachingParameter j) (chosenAttachingParameter_im_pos j)
+    (chosenAttachingParameter_filling_bound j) (chosenAttachingParameter_bound j)
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Threefold/SpecialPeriods11.lean b/LeanPool/HopfProblem/Threefold/SpecialPeriods11.lean
new file mode 100644
index 000000000..0f4270887
--- /dev/null
+++ b/LeanPool/HopfProblem/Threefold/SpecialPeriods11.lean
@@ -0,0 +1,3777 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.MainTheorem.Core1
+public import LeanPool.HopfProblem.Recognition.Smale10
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.Foundations.TriangleRegularBaseFundamentalGroup
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap1
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+import all LeanPool.HopfProblem.Lattice.Core2
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.PeriodFamily.PeriodDomain
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods3
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.PeriodFamily.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods6
+import all LeanPool.HopfProblem.PeriodFamily.Core2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import all LeanPool.HopfProblem.Elliptic.Core3
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldGluing1
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.Elliptic.Core4
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldGluing2
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods8
+import all LeanPool.HopfProblem.Elliptic.Core5
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods8
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods9
+import all LeanPool.HopfProblem.Foundations.SplitGroupExtension
+import all LeanPool.HopfProblem.PeriodFamily.Core3
+import all LeanPool.HopfProblem.Elliptic.Core6
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods10
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods9
+import all LeanPool.HopfProblem.Pi1.TwistGroup
+import all LeanPool.HopfProblem.PeriodFamily.Core5
+import all LeanPool.HopfProblem.Recognition.Smale10
+import all LeanPool.HopfProblem.Foundations.CanonicalProduct
+import all LeanPool.HopfProblem.MainTheorem.Core1
+
+/-!
+# Hopf problem: threefold · special periods 11
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def SpecialPeriods.Threefold.EllipticGeometry.regularColumnLoop
+    (b : SpecialPeriods.TriangleRegularPoint) (w : Lattice) :
+    Path
+      (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).fundamentalGroupBasepoint
+        b)
+      (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).fundamentalGroupBasepoint
+        b) :=
+  (PeriodFamily.FlatTorus.periodLoop w).map
+    (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁
+          SpecialPeriods.specialPeriodMap_generator₂)).quotient_continuous.comp
+      (continuous_const.prodMk continuous_id))
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.regularColumnLoop_apply
+    (b : SpecialPeriods.TriangleRegularPoint) (w : Lattice) (t : (unitInterval)) :
+    regularColumnLoop b w t =
+      ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).quotient
+        (b, standardLattice.mkQ ((t : ℝ) • Elliptic.realCast w)) := by
+  change
+    ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).quotient
+        (b, PeriodFamily.FlatTorus.periodLoop w t) =
+      _
+  rw [PeriodFamily.FlatTorus.periodLoop_apply]
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.regularColumnLoop_class
+    (b : SpecialPeriods.TriangleRegularPoint) (w : Lattice) :
+    FundamentalGroup.fromPath ⟦regularColumnLoop b w⟧ =
+      ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).latticeFundamentalGroupHom
+        b (Multiplicative.ofAdd w) :=
+  (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁
+          SpecialPeriods.specialPeriodMap_generator₂)).latticeFundamentalGroupHom_periodLoop
+      b w).symm
+
+private def SpecialPeriods.Threefold.EllipticGeometry.globalColumnLoop
+    (b : SpecialPeriods.TriangleRegularPoint) (w : Lattice) :
+    Path
+      (SpecialPeriods.Threefold.regularFamilyInclusionMap
+        (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)).fundamentalGroupBasepoint
+          b))
+      (SpecialPeriods.Threefold.regularFamilyInclusionMap
+        (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)).fundamentalGroupBasepoint
+          b)) :=
+  (regularColumnLoop b w).map SpecialPeriods.Threefold.regularFamilyInclusionMap.continuous
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.globalColumnLoop_apply
+    (b : SpecialPeriods.TriangleRegularPoint) (w : Lattice) (t : (unitInterval)) :
+    globalColumnLoop b w t =
+      SpecialPeriods.Threefold.regularFamilyInclusionMap
+        (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)).quotient
+          (b, standardLattice.mkQ ((t : ℝ) • Elliptic.realCast w))) :=
+  congrArg SpecialPeriods.Threefold.regularFamilyInclusionMap (regularColumnLoop_apply b w t)
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.globalColumnLoop_class
+    (b : SpecialPeriods.TriangleRegularPoint) (w : Lattice) :
+    FundamentalGroup.fromPath ⟦globalColumnLoop b w⟧ =
+      FundamentalGroup.map SpecialPeriods.Threefold.regularFamilyInclusionMap
+        (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)).fundamentalGroupBasepoint
+          b)
+        (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)).latticeFundamentalGroupHom
+          b (Multiplicative.ofAdd w)) :=
+  congrArg
+    (FundamentalGroup.map SpecialPeriods.Threefold.regularFamilyInclusionMap
+      (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).fundamentalGroupBasepoint
+        b))
+    (regularColumnLoop_class b w)
+
+private def SpecialPeriods.Threefold.EllipticGeometry.upstairsPathGlobalTail
+    {b : SpecialPeriods.TriangleRegularPoint}
+    (p : Path (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint) b) :
+    Path SpecialPeriods.Threefold.PiOne.basepoint
+      (SpecialPeriods.Threefold.regularFamilyInclusionMap
+        (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)).fundamentalGroupBasepoint
+          b)) :=
+  (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).zeroSectionPath
+        p).map
+    SpecialPeriods.Threefold.regularFamilyInclusionMap.continuous
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.upstairsPathGlobalTail_symm
+    {b : SpecialPeriods.TriangleRegularPoint}
+    (p : Path (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint) b) :
+    (upstairsPathGlobalTail p).symm =
+      (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                SpecialPeriods.specialPeriodMap_generator₁
+                SpecialPeriods.specialPeriodMap_generator₂)).zeroSectionPath
+            p.symm).map
+        SpecialPeriods.Threefold.regularFamilyInclusionMap.continuous := by
+  ext t
+  rfl
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.transport_globalColumnLoop
+    {b : SpecialPeriods.TriangleRegularPoint}
+    (p : Path (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint) b) (w : Lattice) :
+    FundamentalGroup.fundamentalGroupMulEquivOfPath (upstairsPathGlobalTail p).symm
+        (FundamentalGroup.fromPath ⟦globalColumnLoop b w⟧) =
+      SpecialPeriods.Threefold.PiOne.latticeHom (Multiplicative.ofAdd w) := by
+  rw [upstairsPathGlobalTail_symm, globalColumnLoop_class]
+  exact
+    (fundamentalGroup_basepoint_naturality_apply
+          SpecialPeriods.Threefold.regularFamilyInclusionMap
+          (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                SpecialPeriods.specialPeriodMap_generator₁
+                SpecialPeriods.specialPeriodMap_generator₂)).zeroSectionPath
+            p.symm)
+          (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                SpecialPeriods.specialPeriodMap_generator₁
+                SpecialPeriods.specialPeriodMap_generator₂)).latticeFundamentalGroupHom
+            b (Multiplicative.ofAdd w))).trans
+      (congrArg
+        (FundamentalGroup.map SpecialPeriods.Threefold.regularFamilyInclusionMap
+          (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                SpecialPeriods.specialPeriodMap_generator₁
+                SpecialPeriods.specialPeriodMap_generator₂)).fundamentalGroupBasepoint
+            (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)))
+        (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)).latticeFundamentalGroupHom_baseChange
+          p.symm (Multiplicative.ofAdd w)))
+
+private theorem
+    SpecialPeriods.Threefold.EllipticGeometry.attachingLoop_pow_order (j : Elliptic.Kind)
+    (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    (FundamentalGroup.fromPath ⟦attachingLoop j s₀ hs₀ hr⟧) ^ j.order =
+      FundamentalGroup.fromPath ⟦attachingFibreLoop j s₀ hs₀ hr j.twist⟧ := by
+  apply (attachingDeckEquiv j s₀ hs₀ hr).injective
+  rw [map_pow, attachingDeckEquiv_attachingLoop, attachingDeckEquiv_attachingFibreLoop, inv_pow,
+    Elliptic.deckGenerator_pow_order j j.twist (Elliptic.mainTwist_admissible j).1]
+  exact (map_inv (Elliptic.deckTranslationHom j j.twist) (Multiplicative.ofAdd j.twist)).symm
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.includedAttachingFibreLoop_eq_column
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (w : Lattice) :
+    includedAttachingFibreLoop j s₀ hs₀ hr w =
+      globalColumnLoop (attachingUpstairsPoint j s₀ hs₀ 0) w := by
+  ext t
+  rw [globalColumnLoop_apply]
+  exact
+    (inclusion_eq_regular_overlap j (attachingFibreLoop j s₀ hs₀ hr w t)
+          (attachingFibreLoop_mem_overlap j s₀ hs₀ hr w t)).trans
+      (congrArg SpecialPeriods.Threefold.regularFamilyInclusionMap
+        (specialEllipticOverlap_attachingFibreLoop j s₀ hs₀ hr w t))
+
+private def
+    SpecialPeriods.Threefold.EllipticGeometry.attachingUpstairsTail (j : Elliptic.Kind) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im) :
+    Path (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+      (attachingUpstairsPoint j s₀ hs₀ 0) :=
+  PathConnectedSpace.somePath _ _
+
+private def SpecialPeriods.Threefold.EllipticGeometry.attachingBaseTail (j : Elliptic.Kind) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im) :
+    Path
+      (SpecialPeriods.triangleRegularProject
+        (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint))
+      (SpecialPeriods.triangleRegularProject (attachingUpstairsPoint j s₀ hs₀ 0)) :=
+  (attachingUpstairsTail j s₀ hs₀).map SpecialPeriods.triangleRegularProject_covering.continuous
+
+private def
+    SpecialPeriods.Threefold.EllipticGeometry.attachingGlobalTail (j : Elliptic.Kind) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im) :
+    Path SpecialPeriods.Threefold.PiOne.basepoint
+      (SpecialPeriods.Threefold.regularFamilyInclusionMap
+        (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)).fundamentalGroupBasepoint
+          (attachingUpstairsPoint j s₀ hs₀ 0))) :=
+  upstairsPathGlobalTail (attachingUpstairsTail j s₀ hs₀)
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingGlobalTail_eq_zeroSection
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im) :
+    attachingGlobalTail j s₀ hs₀ =
+      ((attachingBaseTail j s₀ hs₀).map
+            ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                SpecialPeriods.specialPeriodMap_generator₁
+                SpecialPeriods.specialPeriodMap_generator₂)).zeroSection_continuous).map
+        SpecialPeriods.Threefold.regularFamilyInclusionMap.continuous := by
+  ext t
+  rfl
+
+private def
+    SpecialPeriods.Threefold.EllipticGeometry.attachingTransportHom (j : Elliptic.Kind) (s₀ : ℂ)
+    (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    FundamentalGroup (LocalSpace j) (attachingBasepoint j s₀ hs₀ hr) →*
+      SpecialPeriods.Threefold.PiOne.GlobalGroup :=
+  (FundamentalGroup.fundamentalGroupMulEquivOfPath
+        (attachingGlobalTail j s₀ hs₀).symm).toMonoidHom.comp
+    ((MulEquiv.cast (M := FundamentalGroup SpecialPeriods.Threefold.Space)
+          (attachingGlobalBasepoint_eq j s₀ hs₀ hr)).toMonoidHom.comp
+      (FundamentalGroup.map (attachingPieceInclusionMap j) (attachingBasepoint j s₀ hs₀ hr)))
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingTransportHom_fromPath
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (γ : Path (attachingBasepoint j s₀ hs₀ hr) (attachingBasepoint j s₀ hs₀ hr)) :
+    attachingTransportHom j s₀ hs₀ hr (FundamentalGroup.fromPath ⟦γ⟧) =
+      FundamentalGroup.fundamentalGroupMulEquivOfPath (attachingGlobalTail j s₀ hs₀).symm
+        (FundamentalGroup.fromPath
+          ⟦(γ.map (inclusion_continuous j)).cast (attachingGlobalBasepoint_eq j s₀ hs₀ hr).symm
+              (attachingGlobalBasepoint_eq j s₀ hs₀ hr).symm⟧) := by
+  change
+    FundamentalGroup.fundamentalGroupMulEquivOfPath (attachingGlobalTail j s₀ hs₀).symm
+        (MulEquiv.cast (M := FundamentalGroup SpecialPeriods.Threefold.Space)
+          (attachingGlobalBasepoint_eq j s₀ hs₀ hr)
+          (FundamentalGroup.fromPath ⟦γ.map (inclusion_continuous j)⟧)) =
+      _
+  rw [Elliptic.LogGauge.fundamentalGroup_cast_loop]
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingTransportHom_fibreLoop
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (w : Lattice) :
+    attachingTransportHom j s₀ hs₀ hr
+        (FundamentalGroup.fromPath ⟦attachingFibreLoop j s₀ hs₀ hr w⟧) =
+      SpecialPeriods.Threefold.PiOne.latticeHom (Multiplicative.ofAdd w) := by
+  rw [attachingTransportHom_fromPath]
+  change
+    FundamentalGroup.fundamentalGroupMulEquivOfPath (attachingGlobalTail j s₀ hs₀).symm
+        (FundamentalGroup.fromPath ⟦includedAttachingFibreLoop j s₀ hs₀ hr w⟧) =
+      _
+  rw [includedAttachingFibreLoop_eq_column]
+  exact transport_globalColumnLoop (attachingUpstairsTail j s₀ hs₀) w
+
+private def SpecialPeriods.Threefold.EllipticGeometry.transportedAttachingLoop (j : Elliptic.Kind)
+    (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    Path SpecialPeriods.Threefold.PiOne.basepoint SpecialPeriods.Threefold.PiOne.basepoint :=
+  (attachingGlobalTail j s₀ hs₀).trans
+    ((includedAttachingLoop j s₀ hs₀ hr).trans (attachingGlobalTail j s₀ hs₀).symm)
+
+private def SpecialPeriods.Threefold.EllipticGeometry.transportedAttachingClass (j : Elliptic.Kind)
+    (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    SpecialPeriods.Threefold.PiOne.GlobalGroup :=
+  attachingTransportHom j s₀ hs₀ hr (FundamentalGroup.fromPath ⟦attachingLoop j s₀ hs₀ hr⟧)
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.transportedAttachingClass_fromPath
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    transportedAttachingClass j s₀ hs₀ hr =
+      FundamentalGroup.fromPath ⟦transportedAttachingLoop j s₀ hs₀ hr⟧ := by
+  rw [transportedAttachingClass, attachingTransportHom_fromPath]
+  change
+    FundamentalGroup.fundamentalGroupMulEquivOfPath (attachingGlobalTail j s₀ hs₀).symm
+        (Path.Homotopic.Quotient.mk (includedAttachingLoop j s₀ hs₀ hr)) =
+      _
+  rw [fundamentalGroup_basepoint_change_mk, Path.symm_symm]
+  rfl
+
+private def
+    SpecialPeriods.Threefold.EllipticGeometry.transportedAttachingBaseLoop (j : Elliptic.Kind)
+    (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    Path
+      (SpecialPeriods.triangleRegularProject
+        (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint))
+      (SpecialPeriods.triangleRegularProject
+        (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)) :=
+  (attachingBaseTail j s₀ hs₀).trans
+    ((attachingRegularBaseLoop j s₀ hs₀ hr).trans (attachingBaseTail j s₀ hs₀).symm)
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.map_twice_tail_mo1973_26156
+    {X Y Z : Type*} [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace Z] {a b : X}
+    (p : Path a b) (q : Path b b) {f : X → Y} {g : Y → Z} (hf : Continuous f)
+    (hg : Continuous g) :
+    ((p.trans (q.trans p.symm)).map hf).map hg =
+      ((p.map hf).map hg).trans (((q.map hf).map hg).trans ((p.map hf).map hg).symm) := by
+  simp only [Path.map_trans, Path.map_symm]
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.transportedAttachingLoop_eq_zeroSection
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    transportedAttachingLoop j s₀ hs₀ hr =
+      ((transportedAttachingBaseLoop j s₀ hs₀ hr).map
+            ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+                SpecialPeriods.specialPeriodMap_generator₁
+                SpecialPeriods.specialPeriodMap_generator₂)).zeroSection_continuous).map
+        SpecialPeriods.Threefold.regularFamilyInclusionMap.continuous := by
+  simp only [transportedAttachingLoop, transportedAttachingBaseLoop]
+  rw [attachingGlobalTail_eq_zeroSection, includedAttachingLoop_eq_regular,
+    attachingRegularLoop_eq_zeroSection]
+  exact
+    (map_twice_tail_mo1973_26156 (attachingBaseTail j s₀ hs₀)
+        (attachingRegularBaseLoop j s₀ hs₀ hr)
+        ((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂)).zeroSection_continuous
+        SpecialPeriods.Threefold.regularFamilyInclusionMap.continuous).symm
+
+private def SpecialPeriods.Threefold.EllipticGeometry.attachingBaseSectionHom :
+    FundamentalGroup SpecialPeriods.TriangleRegularQuotient
+        (SpecialPeriods.triangleRegularProject
+          (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)) →*
+      SpecialPeriods.Threefold.PiOne.GlobalGroup :=
+  SpecialPeriods.Threefold.PiOne.regularHom.comp
+    (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁
+          SpecialPeriods.specialPeriodMap_generator₂)).sectionFundamentalGroupHom
+      (PeriodFamily.Meridians.normalizedRegularMeridianBasepoint))
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.transportedAttachingClass_eq_baseImage
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    transportedAttachingClass j s₀ hs₀ hr =
+      attachingBaseSectionHom
+        (FundamentalGroup.fromPath ⟦transportedAttachingBaseLoop j s₀ hs₀ hr⟧) := by
+  rw [transportedAttachingClass_fromPath, transportedAttachingLoop_eq_zeroSection]
+  rfl
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.transportedAttachingClass_pow_order
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)) :
+    transportedAttachingClass j s₀ hs₀ hr ^ j.order =
+      SpecialPeriods.Threefold.PiOne.latticeHom (Multiplicative.ofAdd j.twist) := by
+  change
+    (attachingTransportHom j s₀ hs₀ hr (FundamentalGroup.fromPath ⟦attachingLoop j s₀ hs₀ hr⟧)) ^
+        j.order =
+      _
+  rw [← map_pow, attachingLoop_pow_order, attachingTransportHom_fibreLoop]
+
+private abbrev SpecialPeriods.Threefold.CuspAttaching.cuspLift
+    (s : SpecialPeriods.CuspFamily.LogBase radius) : SpecialPeriods.TriangleRegularPoint :=
+  SpecialPeriods.CuspFamily.logBaseToRegular radius radius_le_cuspChart s
+
+private theorem SpecialPeriods.Threefold.CuspAttaching.cuspParameter_norm_lt
+    (s : SpecialPeriods.CuspFamily.LogBase radius) :
+    ‖CuspUniformization.exponential s‖ < radius :=
+  (SpecialPeriods.CuspFamily.mem_logBase radius s).mp s.property
+
+private theorem SpecialPeriods.Threefold.CuspAttaching.cuspParameter_log_neg
+    (s : SpecialPeriods.CuspFamily.LogBase radius) :
+    Real.log ‖CuspUniformization.exponential s‖ < 0 :=
+  Real.log_neg (norm_pos_iff.mpr (CuspUniformization.exponential_ne_zero s))
+    ((cuspParameter_norm_lt s).trans data.radius_lt_one)
+
+private theorem SpecialPeriods.Threefold.CuspAttaching.cuspParameter_drift_bound
+    (s : SpecialPeriods.CuspFamily.LogBase radius) :
+    ToricSpace.entryNorm
+        (ToricSpace.driftMatrix data.correction (CuspUniformization.exponential s)) ≤
+      -Real.log ‖CuspUniformization.exponential s‖ / 4 :=
+  data.smallDrift _ (norm_pos_iff.mpr (CuspUniformization.exponential_ne_zero s))
+    (cuspParameter_norm_lt s)
+
+private abbrev SpecialPeriods.Threefold.CuspAttaching.nativePeriodData
+    (s : SpecialPeriods.CuspFamily.LogBase radius) : FullPeriodMatrix :=
+  CuspUniformization.periodData data.correction s (cuspParameter_log_neg s)
+    (cuspParameter_drift_bound s)
+
+private def SpecialPeriods.Threefold.CuspAttaching.nativeFibreMap
+    (s : SpecialPeriods.CuspFamily.LogBase radius) :
+    (nativePeriodData s).Torus → SpecialPeriods.Threefold.SpecialCuspPiece :=
+  CuspUniformization.fibreMap data.correction radius s (cuspParameter_norm_lt s)
+    (cuspParameter_log_neg s) (cuspParameter_drift_bound s)
+
+private theorem SpecialPeriods.Threefold.CuspAttaching.nativeFibreMap_continuous
+    (s : SpecialPeriods.CuspFamily.LogBase radius) : Continuous (nativeFibreMap s) :=
+  CuspUniformization.fibreMap_continuous data.correction radius s (cuspParameter_norm_lt s)
+    (cuspParameter_log_neg s) (cuspParameter_drift_bound s)
+
+private theorem SpecialPeriods.Threefold.CuspAttaching.nativeFibreMap_mkQ
+    (s : SpecialPeriods.CuspFamily.LogBase radius) (z : ComplexPlane₂) :
+    nativeFibreMap s ((nativePeriodData s).lattice.mkQ z) =
+      CuspUniformization.fibreCover data.correction radius s (cuspParameter_norm_lt s) z :=
+  rfl
+
+private def SpecialPeriods.Threefold.CuspAttaching.logVector
+    (s : SpecialPeriods.CuspFamily.LogBase radius) (z : ComplexPlane₂) :
+    CuspUniformization.LogCover radius :=
+  ⟨((s : ℂ), z), s.property⟩
+
+private def SpecialPeriods.Threefold.CuspAttaching.regularFamilyInclusionMap :
+    C(SpecialPeriods.Threefold.SpecialRegularFamily, SpecialPeriods.Threefold.Space) :=
+  ⟨SpecialPeriods.Threefold.inclusion Option.none,
+    (SpecialPeriods.Threefold.inclusion_openEmbedding Option.none).continuous⟩
+
+private def SpecialPeriods.Threefold.CuspAttaching.globalLatticeHom
+    (b : SpecialPeriods.TriangleRegularPoint) :
+    Multiplicative Lattice →*
+      FundamentalGroup SpecialPeriods.Threefold.Space
+        (SpecialPeriods.Threefold.inclusion Option.none
+          (regularData.fundamentalGroupBasepoint b)) :=
+  (FundamentalGroup.map regularFamilyInclusionMap (regularData.fundamentalGroupBasepoint b)).comp
+    (regularData.latticeFundamentalGroupHom b)
+
+private def SpecialPeriods.Threefold.CuspAttaching.regularFibreMap
+    (b : SpecialPeriods.TriangleRegularPoint) :
+    C(RealTorus₄, SpecialPeriods.Threefold.SpecialRegularFamily) :=
+  ⟨fun x => regularData.quotient (b, x),
+    regularData.quotient_continuous.comp (continuous_const.prodMk continuous_id)⟩
+
+private def SpecialPeriods.Threefold.CuspAttaching.regularLatticeLoop
+    (b : SpecialPeriods.TriangleRegularPoint) (v : Lattice) :
+    Path (regularData.fundamentalGroupBasepoint b) (regularData.fundamentalGroupBasepoint b) :=
+  (PeriodFamily.FlatTorus.periodLoop v).map (regularFibreMap b).continuous
+
+private def SpecialPeriods.Threefold.CuspAttaching.globalLatticeLoop
+    (b : SpecialPeriods.TriangleRegularPoint) (v : Lattice) :
+    Path
+      (SpecialPeriods.Threefold.inclusion Option.none (regularData.fundamentalGroupBasepoint b))
+      (SpecialPeriods.Threefold.inclusion Option.none
+        (regularData.fundamentalGroupBasepoint b)) :=
+  (regularLatticeLoop b v).map regularFamilyInclusionMap.continuous
+
+private theorem SpecialPeriods.Threefold.CuspAttaching.globalLatticeLoop_apply
+    (b : SpecialPeriods.TriangleRegularPoint) (v : Lattice) (t : (unitInterval)) :
+    globalLatticeLoop b v t =
+      SpecialPeriods.Threefold.inclusion Option.none
+        (regularData.quotient (b, standardLattice.mkQ ((t : ℝ) • Elliptic.realCast v))) :=
+  congrArg
+    (fun x : RealTorus₄ =>
+      SpecialPeriods.Threefold.inclusion Option.none (regularData.quotient (b, x)))
+    (PeriodFamily.FlatTorus.periodLoop_apply v t)
+
+private theorem SpecialPeriods.Threefold.CuspAttaching.globalLatticeHom_periodLoop
+    (b : SpecialPeriods.TriangleRegularPoint) (v : Lattice) :
+    globalLatticeHom b (Multiplicative.ofAdd v) =
+      Path.Homotopic.Quotient.mk (globalLatticeLoop b v) := by
+  change
+    FundamentalGroup.map regularFamilyInclusionMap (regularData.fundamentalGroupBasepoint b)
+        (regularData.latticeFundamentalGroupHom b (Multiplicative.ofAdd v)) =
+      _
+  rw [regularData.latticeFundamentalGroupHom_periodLoop]
+  rfl
+
+private def SpecialPeriods.Threefold.CuspAttaching.nativeGlobalPeriodLoop
+    (s : SpecialPeriods.CuspFamily.LogBase radius) (v : Lattice) :
+    Path (SpecialPeriods.Threefold.inclusion (Option.some Option.none) (nativeFibreMap s 0))
+      (SpecialPeriods.Threefold.inclusion (Option.some Option.none) (nativeFibreMap s 0)) :=
+  (((nativePeriodData s).periodLoop (CuspUniformization.sourcePeriodCoordinates v)).map
+        (nativeFibreMap_continuous s)).map
+    (SpecialPeriods.Threefold.inclusion_openEmbedding (Option.some Option.none)).continuous
+
+private theorem SpecialPeriods.Threefold.CuspAttaching.nativePeriodData_matrix_eq_regular_leftBlock
+    (s : SpecialPeriods.CuspFamily.LogBase radius) :
+    (nativePeriodData s).matrix = (regularData.periods.point (cuspLift s)).val.leftBlock := by
+  exact
+    ((congrArg (fun p : PeriodDomain => p.val.leftBlock) (period_agreement s)).trans
+        (data.point_leftBlock s)).symm
+
+private theorem SpecialPeriods.Threefold.CuspAttaching.native_periodVector_sourceCoordinates
+    (s : SpecialPeriods.CuspFamily.LogBase radius) (v : Lattice) :
+    (nativePeriodData s).periodVector (CuspUniformization.sourcePeriodCoordinates v) =
+      regularData.periods.periodEquiv (cuspLift s) (Elliptic.realCast v) := by
+  calc
+    _ = (regularData.periods.point (cuspLift s)).periodVector v :=
+      (regularData.periods.point (cuspLift s)).fullPeriod_periodVector (nativePeriodData s)
+        (nativePeriodData_matrix_eq_regular_leftBlock s) v
+    _ = _ := (regularData.periodEquiv_realCast (cuspLift s) v).symm
+
+private theorem
+  SpecialPeriods.Threefold.CuspAttaching.sourcePeriodCoordinates_eq_integer_of_projection_zero
+    (v : Lattice) (hv : CuspUniformization.cuspLatticeProjection v = 0) :
+    CuspUniformization.sourcePeriodCoordinates v = (![v 2, v 3], 0) := by
+  change (![v 2, v 3], CuspUniformization.cuspLatticeProjection v) = _
+  rw [hv]
+
+private theorem
+  SpecialPeriods.Threefold.CuspAttaching.nativeFibre_periodLoop_nullhomotopic_of_projection_zero
+    (s : SpecialPeriods.CuspFamily.LogBase radius) (v : Lattice)
+    (hv : CuspUniformization.cuspLatticeProjection v = 0) :
+    Path.Homotopic
+      (((nativePeriodData s).periodLoop (CuspUniformization.sourcePeriodCoordinates v)).map
+        (nativeFibreMap_continuous s))
+      (Path.refl (nativeFibreMap s 0)) := by
+  rw [sourcePeriodCoordinates_eq_integer_of_projection_zero v hv]
+  exact
+    CuspUniformization.fibre_integerPeriod_loop_nullhomotopic data.correction radius s
+      (cuspParameter_norm_lt s) (cuspParameter_log_neg s) (cuspParameter_drift_bound s)
+      data.radius_pos data.radius_lt_one data.holomorphic data.smallDrift ![v 2, v 3]
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.familyMap_iteratedCover_logVector
+    (s : SpecialPeriods.CuspFamily.LogBase radius) (z : ComplexPlane₂) :
+    SpecialPeriods.CuspGlobalOverlap.familyMap data regularData radius_le_cuspChart
+        (data.iteratedCover (logVector s z)) =
+      regularData.quotient (regularData.periods.quotientMap (cuspLift s, z)) := by
+  change
+    regularData.quotient
+        (HolomorphicPeriodMap.periodPullbackMap data.periods regularData.periods
+          (SpecialPeriods.CuspFamily.logBaseToRegular radius radius_le_cuspChart)
+          (data.periods.quotientMap (s, z))) =
+      _
+  apply congrArg regularData.quotient
+  exact
+    HolomorphicPeriodMap.periodPullbackMap_quotientMap data.periods regularData.periods
+      (SpecialPeriods.CuspFamily.logBaseToRegular radius radius_le_cuspChart) period_agreement
+      (s, z)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.fibreCover_mem_overlap
+    (s : SpecialPeriods.CuspFamily.LogBase radius) (z : ComplexPlane₂) :
+    CuspUniformization.fibreCover data.correction radius s (cuspParameter_norm_lt s) z ∈
+      SpecialPeriods.Threefold.specialCuspOverlap.source := by
+  rw [SpecialPeriods.Threefold.specialCuspOverlap_source]
+  change
+    SpecialPeriods.Threefold.CuspPiece.projectionToBase SpecialPeriods.specialCuspData
+        SpecialPeriods.Threefold.specialBaseCover
+        (CuspUniformization.fibreCover data.correction radius s (cuspParameter_norm_lt s) z) ∈
+      SpecialPeriods.Threefold.regularPatch
+  apply
+    (SpecialPeriods.Threefold.CuspPiece.projectionToBase_mem_regular_iff
+        SpecialPeriods.specialCuspData SpecialPeriods.Threefold.specialBaseCover _).mpr
+  exact
+    (CuspUniformization.projection_fibreCover data.correction radius s (cuspParameter_norm_lt s)
+          z).trans_ne
+      (CuspUniformization.exponential_ne_zero s)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.overlap_fibreCover
+    (s : SpecialPeriods.CuspFamily.LogBase radius) (z : ComplexPlane₂) :
+    SpecialPeriods.Threefold.specialCuspOverlap
+        (CuspUniformization.fibreCover data.correction radius s (cuspParameter_norm_lt s) z) =
+      regularData.quotient (regularData.periods.quotientMap (cuspLift s, z)) := by
+  let :=
+    CuspQuotient.chartedSpace data.correction radius data.radius_pos data.radius_lt_one
+      data.holomorphic data.smallDrift
+  let := regularData.chartedSpace (SpecialPeriods.CuspGlobalOverlap.familyCovering regularData)
+  have hx :
+    CuspUniformization.fibreCover data.correction radius s (cuspParameter_norm_lt s) z ∈
+      CuspUniformization.puncturedQuotientOpen data.correction radius := by
+    change
+      CuspQuotient.projection data.correction radius
+          (CuspUniformization.fibreCover data.correction radius s (cuspParameter_norm_lt s) z) ≠
+        0
+    rw [CuspUniformization.projection_fibreCover]
+    exact CuspUniformization.exponential_ne_zero s
+  have he :
+    (⟨CuspUniformization.fibreCover data.correction radius s (cuspParameter_norm_lt s) z, hx⟩ :
+        CuspUniformization.PuncturedQuotient data.correction radius) =
+      CuspUniformization.puncturedCuspCover data.correction radius (logVector s z) := by
+    apply Subtype.ext
+    rfl
+  have h :=
+    SpecialPeriods.CuspGlobalOverlap.cuspToRegularPartial_apply data regularData
+      radius_le_cuspChart period_agreement
+      (CuspUniformization.fibreCover data.correction radius s (cuspParameter_norm_lt s) z) hx
+  have hrepresentative :=
+    congrArg
+      (fun x : CuspUniformization.PuncturedQuotient data.correction radius =>
+        (SpecialPeriods.CuspGlobalOverlap.puncturedBiholomorph data regularData
+            radius_le_cuspChart period_agreement x :
+          regularData.Space))
+      he
+  have hcover :=
+    SpecialPeriods.CuspGlobalOverlap.puncturedBiholomorph_cover data regularData
+      radius_le_cuspChart period_agreement (logVector s z)
+  change
+    SpecialPeriods.Threefold.specialCuspOverlap
+        (CuspUniformization.fibreCover data.correction radius s (cuspParameter_norm_lt s) z) =
+      _ at h
+  exact h.trans (hrepresentative.trans (hcover.trans (familyMap_iteratedCover_logVector s z)))
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.inclusion_fibreCover
+    (s : SpecialPeriods.CuspFamily.LogBase radius) (z : ComplexPlane₂) :
+    SpecialPeriods.Threefold.inclusion (Option.some Option.none)
+        (CuspUniformization.fibreCover data.correction radius s (cuspParameter_norm_lt s) z) =
+      SpecialPeriods.Threefold.inclusion Option.none
+        (regularData.quotient (regularData.periods.quotientMap (cuspLift s, z))) := by
+  apply
+    (SpecialPeriods.Threefold.gluingData.inclusion_eq_iff (Option.some Option.none) Option.none _
+        _).mpr
+  exact ⟨fibreCover_mem_overlap s z, overlap_fibreCover s z⟩
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspAttaching.inclusion_nativeFibreMap_zero
+    (s : SpecialPeriods.CuspFamily.LogBase radius) :
+    SpecialPeriods.Threefold.inclusion (Option.some Option.none) (nativeFibreMap s 0) =
+      SpecialPeriods.Threefold.inclusion Option.none
+        (regularData.fundamentalGroupBasepoint (cuspLift s)) := by
+  have hz :
+    nativeFibreMap s 0 =
+      CuspUniformization.fibreCover data.correction radius s (cuspParameter_norm_lt s) 0 := by
+    simpa only [map_zero] using nativeFibreMap_mkQ s 0
+  rw [hz, inclusion_fibreCover]
+  change
+    SpecialPeriods.Threefold.inclusion Option.none
+        (regularData.quotient (regularData.periods.quotientMap (cuspLift s, 0))) =
+      SpecialPeriods.Threefold.inclusion Option.none (regularData.quotient (cuspLift s, 0))
+  simp only [HolomorphicPeriodMap.quotientMap, map_zero]
+
+private theorem SpecialPeriods.Threefold.CuspAttaching.nativeGlobalPeriodLoop_apply
+    (s : SpecialPeriods.CuspFamily.LogBase radius) (v : Lattice) (t : (unitInterval)) :
+    nativeGlobalPeriodLoop s v t =
+      SpecialPeriods.Threefold.inclusion (Option.some Option.none)
+        (CuspUniformization.fibreCover data.correction radius s (cuspParameter_norm_lt s)
+          ((t : ℝ) •
+            (nativePeriodData s).periodVector (CuspUniformization.sourcePeriodCoordinates v))) := by
+  exact
+    (congrArg
+          (fun x : (nativePeriodData s).Torus =>
+            SpecialPeriods.Threefold.inclusion (Option.some Option.none) (nativeFibreMap s x))
+          ((nativePeriodData s).periodLoop_apply (CuspUniformization.sourcePeriodCoordinates v)
+            t)).trans
+      (congrArg (SpecialPeriods.Threefold.inclusion (Option.some Option.none))
+        (nativeFibreMap_mkQ s _))
+
+private theorem SpecialPeriods.Threefold.CuspAttaching.quotientMap_nativePeriodVector
+    (s : SpecialPeriods.CuspFamily.LogBase radius) (v : Lattice) (t : (unitInterval)) :
+    regularData.periods.quotientMap
+        (cuspLift s,
+          (t : ℝ) •
+            (nativePeriodData s).periodVector (CuspUniformization.sourcePeriodCoordinates v)) =
+      (cuspLift s, standardLattice.mkQ ((t : ℝ) • Elliptic.realCast v)) := by
+  have hs :
+    (t : ℝ) • (nativePeriodData s).periodVector (CuspUniformization.sourcePeriodCoordinates v) =
+      regularData.periods.periodEquiv (cuspLift s) ((t : ℝ) • Elliptic.realCast v) :=
+    (congrArg (fun z : ComplexPlane₂ => (t : ℝ) • z)
+          (native_periodVector_sourceCoordinates s v)).trans
+      ((regularData.periods.periodEquiv (cuspLift s)).map_smul (t : ℝ) (Elliptic.realCast v)).symm
+  change
+    (cuspLift s,
+        standardLattice.mkQ
+          ((regularData.periods.periodEquiv (cuspLift s)).symm
+            ((t : ℝ) •
+              (nativePeriodData s).periodVector
+                (CuspUniformization.sourcePeriodCoordinates v)))) =
+      _
+  apply congrArg (fun x : RealTorus₄ => (cuspLift s, x))
+  apply congrArg standardLattice.mkQ
+  exact
+    (congrArg (regularData.periods.periodEquiv (cuspLift s)).symm hs).trans
+      ((regularData.periods.periodEquiv (cuspLift s)).symm_apply_apply _)
+
+private theorem SpecialPeriods.Threefold.CuspAttaching.nativeGlobalPeriodLoop_cast
+    (s : SpecialPeriods.CuspFamily.LogBase radius) (v : Lattice) :
+    (nativeGlobalPeriodLoop s v).cast (inclusion_nativeFibreMap_zero s).symm
+        (inclusion_nativeFibreMap_zero s).symm =
+      globalLatticeLoop (cuspLift s) v := by
+  apply Path.ext
+  funext t
+  change nativeGlobalPeriodLoop s v t = globalLatticeLoop (cuspLift s) v t
+  exact
+    (nativeGlobalPeriodLoop_apply s v t).trans
+      ((inclusion_fibreCover s _).trans
+        ((congrArg
+              (fun x => SpecialPeriods.Threefold.inclusion Option.none (regularData.quotient x))
+              (quotientMap_nativePeriodVector s v t)).trans
+          (globalLatticeLoop_apply (cuspLift s) v t).symm))
+
+private theorem SpecialPeriods.Threefold.CuspAttaching.globalLatticeLoop_nullhomotopic_at_cusp
+    (s : SpecialPeriods.CuspFamily.LogBase radius) (v : Lattice)
+    (hv : CuspUniformization.cuspLatticeProjection v = 0) :
+    Path.Homotopic (globalLatticeLoop (cuspLift s) v)
+      (Path.refl
+        (SpecialPeriods.Threefold.inclusion Option.none
+          (regularData.fundamentalGroupBasepoint (cuspLift s)))) := by
+  have h :=
+    (nativeFibre_periodLoop_nullhomotopic_of_projection_zero s v hv).map
+      (⟨SpecialPeriods.Threefold.inclusion (Option.some Option.none),
+          (SpecialPeriods.Threefold.inclusion_openEmbedding
+              (Option.some Option.none)).continuous⟩ :
+        C(SpecialPeriods.Threefold.SpecialCuspPiece, SpecialPeriods.Threefold.Space))
+  change
+    Path.Homotopic (nativeGlobalPeriodLoop s v)
+      (Path.refl
+        (SpecialPeriods.Threefold.inclusion (Option.some Option.none) (nativeFibreMap s 0))) at h
+  have hc :=
+    h.pathCast (inclusion_nativeFibreMap_zero s).symm (inclusion_nativeFibreMap_zero s).symm
+  have hr :
+    (Path.refl
+            (SpecialPeriods.Threefold.inclusion (Option.some Option.none)
+              (nativeFibreMap s 0))).cast
+        (inclusion_nativeFibreMap_zero s).symm (inclusion_nativeFibreMap_zero s).symm =
+      Path.refl
+        (SpecialPeriods.Threefold.inclusion Option.none
+          (regularData.fundamentalGroupBasepoint (cuspLift s))) := by
+    apply Path.ext
+    funext _
+    exact inclusion_nativeFibreMap_zero s
+  rw [nativeGlobalPeriodLoop_cast, hr] at hc
+  exact hc
+
+private theorem SpecialPeriods.Threefold.CuspAttaching.globalLatticeHom_eq_one_at_cusp
+    (s : SpecialPeriods.CuspFamily.LogBase radius) (v : Lattice)
+    (hv : CuspUniformization.cuspLatticeProjection v = 0) :
+    globalLatticeHom (cuspLift s) (Multiplicative.ofAdd v) = 1 := by
+  rw [globalLatticeHom_periodLoop]
+  exact Quotient.sound (globalLatticeLoop_nullhomotopic_at_cusp s v hv)
+
+private def SpecialPeriods.Threefold.CuspAttaching.globalZeroSectionPath
+    {b₀ b₁ : SpecialPeriods.TriangleRegularPoint} (p : Path b₀ b₁) :
+    Path
+      (SpecialPeriods.Threefold.inclusion Option.none (regularData.fundamentalGroupBasepoint b₀))
+      (SpecialPeriods.Threefold.inclusion Option.none
+        (regularData.fundamentalGroupBasepoint b₁)) :=
+  (regularData.zeroSectionPath p).map regularFamilyInclusionMap.continuous
+
+private theorem SpecialPeriods.Threefold.CuspAttaching.globalLatticeHom_baseChange
+    {b₀ b₁ : SpecialPeriods.TriangleRegularPoint} (p : Path b₀ b₁) (v : Multiplicative Lattice) :
+    FundamentalGroup.fundamentalGroupMulEquivOfPath (globalZeroSectionPath p)
+        (globalLatticeHom b₀ v) =
+      globalLatticeHom b₁ v := by
+  exact
+    (fundamentalGroup_basepoint_naturality_apply regularFamilyInclusionMap
+          (regularData.zeroSectionPath p) (regularData.latticeFundamentalGroupHom b₀ v)).trans
+      (congrArg
+        (FundamentalGroup.map regularFamilyInclusionMap
+          (regularData.fundamentalGroupBasepoint b₁))
+        (regularData.latticeFundamentalGroupHom_baseChange p v))
+
+private theorem SpecialPeriods.Threefold.CuspAttaching.globalLatticeHom_eq_one_of_projection_zero
+    (b : SpecialPeriods.TriangleRegularPoint) (v : Lattice)
+    (hv : CuspUniformization.cuspLatticeProjection v = 0) :
+    globalLatticeHom b (Multiplicative.ofAdd v) = 1 := by
+  obtain ⟨s, hs⟩ := exists_small_exponential
+  let s' : SpecialPeriods.CuspFamily.LogBase radius :=
+    ⟨s, (SpecialPeriods.CuspFamily.mem_logBase radius s).mpr hs⟩
+  let p : Path (cuspLift s') b := PathConnectedSpace.somePath _ _
+  calc
+    globalLatticeHom b (Multiplicative.ofAdd v) =
+        FundamentalGroup.fundamentalGroupMulEquivOfPath (globalZeroSectionPath p)
+          (globalLatticeHom (cuspLift s') (Multiplicative.ofAdd v)) :=
+      (globalLatticeHom_baseChange p (Multiplicative.ofAdd v)).symm
+    _ = FundamentalGroup.fundamentalGroupMulEquivOfPath (globalZeroSectionPath p) 1 :=
+      (congrArg (FundamentalGroup.fundamentalGroupMulEquivOfPath (globalZeroSectionPath p))
+        (globalLatticeHom_eq_one_at_cusp s' v hv))
+    _ = 1 := map_one _
+
+private theorem
+    SpecialPeriods.Threefold.PiOne.latticeHom_eq_one_of_cusp_projection_zero (v : Lattice)
+    (hv : CuspUniformization.cuspLatticeProjection v = 0) :
+    latticeHom (Multiplicative.ofAdd v) = 1 :=
+  SpecialPeriods.Threefold.CuspAttaching.globalLatticeHom_eq_one_of_projection_zero
+    PeriodFamily.Meridians.normalizedRegularMeridianBasepoint v hv
+
+private theorem
+    SpecialPeriods.Threefold.PiOne.latticeHom_eq_one_of_cusp_monodromy_kernel (v : Lattice)
+    (hv : (M₀ - 1) *ᵥ v = 0) : latticeHom (Multiplicative.ofAdd v) = 1 :=
+  latticeHom_eq_one_of_cusp_projection_zero v
+    ((CuspUniformization.cuspLatticeProjection_eq_zero_iff v).mpr hv)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+private def SpecialPeriods.Threefold.CuspPeripheral.planeToRegularBase :
+    SpecialPeriods.Triangle.TwicePuncturedPlane → SpecialPeriods.Threefold.regularPatch :=
+  SpecialPeriods.Threefold.regularBiholomorph ∘
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspPeripheral.planeToRegularBase_continuous :
+    Continuous planeToRegularBase :=
+  SpecialPeriods.Threefold.regularBiholomorph.continuous.comp
+    SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm.continuous
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspPeripheral.planeToRegularBase_eq_finiteInverse
+    (z : SpecialPeriods.Triangle.TwicePuncturedPlane) :
+    (planeToRegularBase z : SpecialPeriods.TriangleCompactifiedOrbitSpace) =
+      SpecialPeriods.MuTorsor.Cover.finiteInverse
+        SpecialPeriods.Triangle.triangleSphereUniformization (z : ℂ) := by
+  apply SpecialPeriods.Triangle.triangleSphereUniformization.injective
+  have hfinite :
+    SpecialPeriods.Triangle.triangleSphereUniformization
+        (planeToRegularBase z : SpecialPeriods.TriangleCompactifiedOrbitSpace) =
+      ((z : ℂ) : RiemannSphere) := by
+    change
+      ((SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph
+              (SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm z) :
+            ℂ) :
+          RiemannSphere) =
+        ((z : ℂ) : RiemannSphere)
+    rw [SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.apply_symm_apply]
+  exact
+    hfinite.trans
+      (SpecialPeriods.MuTorsor.Cover.apply_finiteInverse
+          SpecialPeriods.Triangle.triangleSphereUniformization (z : ℂ)).symm
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspPeripheral.exists_cusp_exterior_bound :
+    ∃ A : ℝ,
+      0 < A ∧
+        ∀ z : SpecialPeriods.Triangle.TwicePuncturedPlane,
+          A ≤ ‖(z : ℂ)‖ →
+            (planeToRegularBase z : SpecialPeriods.TriangleCompactifiedOrbitSpace) ∈
+              SpecialPeriods.Threefold.specialBaseCover.fillingPatch Option.none := by
+  obtain ⟨A, hA, hmem⟩ :=
+    SpecialPeriods.MuTorsor.Cover.finitePullback_contains_exterior
+      SpecialPeriods.Triangle.triangleSphereUniformization
+      SpecialPeriods.Triangle.triangleSphereUniformization_cusp
+      (SpecialPeriods.Threefold.specialBaseCover.fillingPatch Option.none)
+      (SpecialPeriods.Threefold.specialBaseCover.point_mem_fillingPatch Option.none)
+  refine ⟨A, hA, fun z hz => ?_⟩
+  rw [planeToRegularBase_eq_finiteInverse]
+  apply hmem
+  simpa only [Set.mem_compl_iff, Metric.mem_ball, dist_zero_right, not_lt] using hz
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspPeripheral.exists_outerCircle_in_cusp :
+    ∃ R : ℝ,
+      ∃ hR : 2 ≤ R,
+        ∀ t : unitInterval,
+          (planeToRegularBase (SpecialPeriods.Triangle.outerPositiveCircle R hR t) :
+              SpecialPeriods.TriangleCompactifiedOrbitSpace) ∈
+            SpecialPeriods.Threefold.specialBaseCover.fillingPatch Option.none := by
+  obtain ⟨A, _, hA⟩ := exists_cusp_exterior_bound
+  let R : ℝ := Max.max 2 (A + 1)
+  have hR : 2 ≤ R := le_max_left _ _
+  refine ⟨R, hR, fun t => hA _ ?_⟩
+  have hnorm := SpecialPeriods.Triangle.outerPositiveCircle_norm_lower_bound R hR t
+  have hlarge : A + 1 ≤ R := le_max_right _ _
+  linarith
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+private def SpecialPeriods.Threefold.CuspPeripheral.outerRadius : ℝ :=
+  exists_outerCircle_in_cusp.choose
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspPeripheral.outerRadius_ge_two : 2 ≤ outerRadius :=
+  exists_outerCircle_in_cusp.choose_spec.choose
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+private def SpecialPeriods.Threefold.CuspPeripheral.outerRegularCircle :
+    Path
+      (planeToRegularBase
+        (SpecialPeriods.Triangle.outerCircleBasepoint outerRadius outerRadius_ge_two))
+      (planeToRegularBase
+        (SpecialPeriods.Triangle.outerCircleBasepoint outerRadius outerRadius_ge_two)) :=
+  (SpecialPeriods.Triangle.outerPositiveCircle outerRadius outerRadius_ge_two).map
+    planeToRegularBase_continuous
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.CuspPeripheral.outerRegularCircle_mem_cusp (t : unitInterval) :
+    (outerRegularCircle t : SpecialPeriods.TriangleCompactifiedOrbitSpace) ∈
+      SpecialPeriods.Threefold.specialBaseCover.fillingPatch Option.none :=
+  exists_outerCircle_in_cusp.choose_spec.choose_spec t
+
+private def SpecialPeriods.Threefold.CuspPeripheral.planeSection :
+    SpecialPeriods.Triangle.TwicePuncturedPlane → SpecialPeriods.Threefold.Space :=
+  SpecialPeriods.Threefold.CuspAttaching.regularSection ∘ planeToRegularBase
+
+private theorem SpecialPeriods.Threefold.CuspPeripheral.planeSection_continuous :
+    Continuous planeSection :=
+  SpecialPeriods.Threefold.CuspAttaching.regularSection_continuous.comp
+    planeToRegularBase_continuous
+
+private def SpecialPeriods.Threefold.CuspPeripheral.planeSectionMap :
+    C(SpecialPeriods.Triangle.TwicePuncturedPlane, SpecialPeriods.Threefold.Space) :=
+  ⟨planeSection, planeSection_continuous⟩
+
+private theorem SpecialPeriods.Threefold.CuspPeripheral.outerPositiveCircle_section_nullhomotopic :
+    Path.Homotopic
+      ((SpecialPeriods.Triangle.outerPositiveCircle outerRadius outerRadius_ge_two).map
+        planeSection_continuous)
+      (Path.refl
+        (planeSection
+          (SpecialPeriods.Triangle.outerCircleBasepoint outerRadius outerRadius_ge_two))) := by
+  have h :=
+    SpecialPeriods.Threefold.CuspAttaching.regularSection_loop_nullhomotopic_of_mem
+      outerRegularCircle outerRegularCircle_mem_cusp
+  have heq :
+    outerRegularCircle.map SpecialPeriods.Threefold.CuspAttaching.regularSection_continuous =
+      (SpecialPeriods.Triangle.outerPositiveCircle outerRadius outerRadius_ge_two).map
+        planeSection_continuous := by
+    ext t
+    rfl
+  exact heq ▸ h
+
+private theorem
+    SpecialPeriods.Threefold.CuspPeripheral.positiveOuterMeridian_section_nullhomotopic :
+    Path.Homotopic
+      ((SpecialPeriods.Triangle.positiveOuterMeridian outerRadius outerRadius_ge_two).map
+        planeSection_continuous)
+      (Path.refl (planeSection SpecialPeriods.Triangle.meridianBasepoint)) := by
+  let a :=
+    (SpecialPeriods.Triangle.outerMeridianTail outerRadius outerRadius_ge_two).map
+      planeSection_continuous
+  let b :=
+    (SpecialPeriods.Triangle.outerPositiveCircle outerRadius outerRadius_ge_two).map
+      planeSection_continuous
+  have hb :
+    b.Homotopic
+      (Path.refl
+        (planeSection
+          (SpecialPeriods.Triangle.outerCircleBasepoint outerRadius outerRadius_ge_two))) :=
+    outerPositiveCircle_section_nullhomotopic
+  have h₁ := ((Path.Homotopic.refl a).hcomp hb).hcomp (Path.Homotopic.refl a.symm)
+  have h₂ := (Path.Homotopic.trans_refl a).hcomp (Path.Homotopic.refl a.symm)
+  have h := h₁.trans (h₂.trans (Path.Homotopic.trans_symm a))
+  simpa only [SpecialPeriods.Triangle.positiveOuterMeridian_eq_tail_circle_tail, Path.map_trans,
+    ← Path.map_symm] using h
+
+private theorem SpecialPeriods.Threefold.CuspPeripheral.planeSection_positiveOuterMeridian_eq_one :
+    FundamentalGroup.map planeSectionMap SpecialPeriods.Triangle.meridianBasepoint
+        (Path.Homotopic.Quotient.mk
+          (SpecialPeriods.Triangle.positiveOuterMeridian outerRadius outerRadius_ge_two)) =
+      1 :=
+  Path.Homotopic.Quotient.eq.mpr positiveOuterMeridian_section_nullhomotopic
+
+private theorem SpecialPeriods.Threefold.CuspPeripheral.planeSection_meridian_product_eq_one :
+    FundamentalGroup.map planeSectionMap SpecialPeriods.Triangle.meridianBasepoint
+          (SpecialPeriods.Triangle.meridianClass Bool.false) *
+        FundamentalGroup.map planeSectionMap SpecialPeriods.Triangle.meridianBasepoint
+          (SpecialPeriods.Triangle.meridianClass Bool.true) =
+      1 := by
+  rw [← map_mul, ←
+    SpecialPeriods.Triangle.positiveOuterMeridian_class_eq outerRadius outerRadius_ge_two]
+  exact planeSection_positiveOuterMeridian_eq_one
+
+private theorem
+    SpecialPeriods.Threefold.CuspPeripheral.planeSection_oriented_meridian_product_eq_one
+    (reverse : Bool) :
+    FundamentalGroup.map planeSectionMap SpecialPeriods.Triangle.meridianBasepoint
+          (FreeMeridianMarking.orientedClass reverse Bool.false) *
+        FundamentalGroup.map planeSectionMap SpecialPeriods.Triangle.meridianBasepoint
+          (FreeMeridianMarking.orientedClass reverse Bool.true) =
+      1 := by
+  cases reverse with
+  | false => exact planeSection_meridian_product_eq_one
+  | true =>
+    simp only [FreeMeridianMarking.orientedClass_true, map_inv]
+    have h := planeSection_meridian_product_eq_one
+    have hx := eq_inv_of_mul_eq_one_left h
+    rw [hx, inv_inv, mul_inv_cancel]
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+private theorem SpecialPeriods.Threefold.PiOne.planeSection_regularCoordinate
+    (q : SpecialPeriods.TriangleRegularQuotient) :
+    SpecialPeriods.Threefold.CuspPeripheral.planeSection
+        (SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph q) =
+      SpecialPeriods.Threefold.regularFamilyInclusionMap
+        (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)).zeroSection
+          q) := by
+  change
+    SpecialPeriods.Threefold.inclusion Option.none
+        (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)).zeroSection
+          (SpecialPeriods.Threefold.regularBiholomorph.symm
+            (SpecialPeriods.Threefold.regularBiholomorph
+              (SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm
+                (SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph q))))) =
+      SpecialPeriods.Threefold.inclusion Option.none
+        (((PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)).zeroSection
+          q)
+  rw [SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph.symm_apply_apply,
+    SpecialPeriods.Threefold.regularBiholomorph.symm_apply_apply]
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+private theorem SpecialPeriods.Threefold.PiOne.planeSection_basepoint :
+    SpecialPeriods.Threefold.CuspPeripheral.planeSectionMap
+        SpecialPeriods.Triangle.meridianBasepoint =
+      basepoint := by
+  have h :=
+    planeSection_regularCoordinate
+      (SpecialPeriods.triangleRegularProject
+        PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)
+  rw [PeriodFamily.Meridians.normalizedRegularMeridianBasepoint_coordinate] at h
+  exact h
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+private def SpecialPeriods.Threefold.PiOne.pointedPlaneHom :
+    FundamentalGroup SpecialPeriods.Triangle.TwicePuncturedPlane
+        SpecialPeriods.Triangle.meridianBasepoint →*
+      GlobalGroup :=
+  FundamentalGroup.mapOfEq SpecialPeriods.Threefold.CuspPeripheral.planeSectionMap
+    planeSection_basepoint
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+public
+theorem SpecialPeriods.Threefold.PiOne.mapOfEq_eq_one_of_map_eq_one_mo1973_26295
+    {X Y : Type*} [TopologicalSpace X] [TopologicalSpace Y] (f : C(X, Y)) {x : X} {y : Y}
+    (e : f x = y) (g : FundamentalGroup X x) (h : FundamentalGroup.map f x g = 1) :
+    FundamentalGroup.mapOfEq f e g = 1 := by
+  subst y
+  simpa only [FundamentalGroup.mapOfEq, CategoryTheory.eqToIso_refl, MonoidHom.comp_apply,
+    MulEquiv.coe_toMonoidHom, CategoryTheory.Iso.refl_conj] using h
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.PiOne.pointedPlaneHom_oriented_product_eq_one (reverse : Bool) :
+    pointedPlaneHom (FreeMeridianMarking.orientedClass reverse Bool.false) *
+        pointedPlaneHom (FreeMeridianMarking.orientedClass reverse Bool.true) =
+      1 := by
+  rw [← map_mul]
+  apply mapOfEq_eq_one_of_map_eq_one_mo1973_26295
+  rw [map_mul]
+  exact
+    SpecialPeriods.Threefold.CuspPeripheral.planeSection_oriented_meridian_product_eq_one reverse
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+private theorem SpecialPeriods.Threefold.PiOne.regularHom_section_eq_plane
+    (g :
+      FundamentalGroup SpecialPeriods.TriangleRegularQuotient
+        (SpecialPeriods.triangleRegularProject
+          PeriodFamily.Meridians.normalizedRegularMeridianBasepoint)) :
+    regularHom (SpecialPeriods.Threefold.specialRegularFamilyMarkedSectionHom g) =
+      pointedPlaneHom (PeriodFamily.Meridians.compatibleBasePlaneEquiv g) := by
+  unfold pointedPlaneHom
+  rw [PeriodFamily.Meridians.compatibleBasePlaneEquiv_apply, FundamentalGroup.mapOfEq_apply,
+    FundamentalGroup.mapOfEq_apply]
+  obtain ⟨p⟩ := g
+  apply congrArg Path.Homotopic.Quotient.mk
+  ext t
+  exact (planeSection_regularCoordinate (p t)).symm
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+private theorem SpecialPeriods.Threefold.PiOne.meridian_eq_pointedPlane (b : Bool) :
+    meridian b =
+      pointedPlaneHom
+        (FreeMeridianMarking.orientedClass PeriodFamily.Meridians.normalizationReversesMeridians
+          b) := by
+  rw [meridian, SpecialPeriods.Threefold.specialRegularFamilyMarkedMeridianClass_eq_section,
+    regularHom_section_eq_plane, PeriodFamily.Meridians.compatibleBasePlaneEquiv_meridianClass]
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+private theorem SpecialPeriods.Threefold.PiOne.meridian_product_eq_one :
+    meridian Bool.false * meridian Bool.true = 1 := by
+  rw [meridian_eq_pointedPlane, meridian_eq_pointedPlane]
+  exact
+    pointedPlaneHom_oriented_product_eq_one PeriodFamily.Meridians.normalizationReversesMeridians
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+private theorem SpecialPeriods.Threefold.PiOne.meridian_second_eq_first_inv :
+    meridian Bool.true = (meridian Bool.false)⁻¹ :=
+  eq_inv_of_mul_eq_one_right meridian_product_eq_one
+
+private def SpecialPeriods.Threefold.PiOne.c : GlobalGroup :=
+  latticeHom (Multiplicative.ofAdd ε)
+
+private theorem SpecialPeriods.Threefold.PiOne.latticeHom_eq_one_of_first_two_coordinates_zero
+    (v : Lattice) (h₀ : v 0 = 0) (h₁ : v 1 = 0) : latticeHom (Multiplicative.ofAdd v) = 1 :=
+  latticeHom_eq_one_of_cusp_monodromy_kernel v ((M₀_sub_one_kernel v).mpr ⟨h₀, h₁⟩)
+
+private theorem SpecialPeriods.Threefold.PiOne.latticeHom_eq_c_zpow (v : Lattice) :
+    latticeHom (Multiplicative.ofAdd v) = c ^ γ v :=
+  LatticeCuspNormalClosure.image_eq_zpow_gamma latticeHom (meridian Bool.false)
+    meridian_first_conjugation latticeHom_eq_one_of_first_two_coordinates_zero v
+
+private theorem SpecialPeriods.Threefold.PiOne.c_mem_center : c ∈ Subgroup.center GlobalGroup := by
+  apply
+    LatticeCuspNormalClosure.image_epsilon_mem_center_of_hom_ext latticeHom (meridian Bool.false)
+      (meridian Bool.true) meridian_first_conjugation meridian_second_conjugation
+      latticeHom_eq_one_of_first_two_coordinates_zero
+  intro f g hL hx hy
+  apply hom_ext f g hL
+  intro b
+  cases b
+  · exact hx
+  · exact hy
+
+private theorem SpecialPeriods.Threefold.PiOne.c_commute (g : GlobalGroup) : Commute c g :=
+  (Subgroup.mem_center_iff.mp c_mem_center g).symm
+
+private theorem SpecialPeriods.Threefold.PiOne.commute_all_of_marked_mo1973_26322
+    (g : GlobalGroup) (hL : ∀ v : Multiplicative Lattice, Commute g (latticeHom v))
+    (hM : ∀ b : Bool, Commute g (meridian b)) : ∀ h : GlobalGroup, Commute g h := by
+  have heq : (MulAut.conj g).toMonoidHom = MonoidHom.id GlobalGroup := by
+    apply hom_ext
+    · intro v
+      change g * latticeHom v * g⁻¹ = latticeHom v
+      rw [(hL v).eq, mul_inv_cancel_right]
+    · intro b
+      change g * meridian b * g⁻¹ = meridian b
+      rw [(hM b).eq, mul_inv_cancel_right]
+  intro h
+  have hh : g * h * g⁻¹ = h := DFunLike.congr_fun heq h
+  exact (mul_inv_eq_iff_eq_mul).mp hh
+
+private theorem SpecialPeriods.Threefold.PiOne.meridian_first_commute (g : GlobalGroup) :
+    Commute (meridian Bool.false) g := by
+  apply commute_all_of_marked_mo1973_26322 (meridian Bool.false)
+  · intro v
+    change Commute (meridian Bool.false) (latticeHom (Multiplicative.ofAdd v.toAdd))
+    rw [latticeHom_eq_c_zpow]
+    exact (c_commute (meridian Bool.false)).symm.zpow_right _
+  · intro b
+    cases b
+    · exact Commute.refl _
+    · rw [meridian_second_eq_first_inv]
+      exact (Commute.refl (meridian Bool.false)).inv_right
+
+private theorem SpecialPeriods.Threefold.PiOne.all_commute (g h : GlobalGroup) : Commute g h := by
+  apply commute_all_of_marked_mo1973_26322 g
+  · intro v
+    change Commute g (latticeHom (Multiplicative.ofAdd v.toAdd))
+    rw [latticeHom_eq_c_zpow]
+    exact (c_commute g).symm.zpow_right _
+  · intro b
+    cases b
+    · exact (meridian_first_commute g).symm
+    · rw [meridian_second_eq_first_inv]
+      exact (meridian_first_commute g).symm.inv_right
+
+@[simp]
+private theorem SpecialPeriods.Threefold.EllipticGeometry.attachingBaseSectionHom_compatibleMeridian
+    (b : Bool) :
+    attachingBaseSectionHom (PeriodFamily.Meridians.compatibleRegularMeridianClass b) =
+      SpecialPeriods.Threefold.PiOne.meridian b :=
+  rfl
+
+private theorem
+    SpecialPeriods.Threefold.EllipticGeometry.transportedAttachingClass_eq_oriented_meridian
+    (j : Elliptic.Kind) (s₀ : ℂ) (hs₀ : 0 < s₀.im)
+    (hr :
+      ‖CuspUniformization.exponential s₀‖ ^ j.order <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j))
+    (hsmall : ‖CuspUniformization.exponential s₀‖ ^ j.order < attachingMeridianRadius j) :
+    transportedAttachingClass j s₀ hs₀ hr =
+      if PeriodFamily.Meridians.normalizationReversesMeridians then
+        SpecialPeriods.Threefold.PiOne.meridian (attachingMeridianIndex j)
+      else (SpecialPeriods.Threefold.PiOne.meridian (attachingMeridianIndex j))⁻¹ := by
+  rw [transportedAttachingClass_eq_baseImage]
+  have h :=
+    attachingMeridian_map_whisker j s₀ hs₀ hr hsmall (attachingBaseTail j s₀ hs₀)
+      attachingBaseSectionHom SpecialPeriods.Threefold.PiOne.all_commute
+  simpa only [transportedAttachingBaseLoop, attachingBaseSectionHom_compatibleMeridian] using! h
+
+private theorem
+  SpecialPeriods.Threefold.EllipticGeometry.chosenTransportedAttachingClass_eq_oriented_meridian
+    (j : Elliptic.Kind) :
+    transportedAttachingClass j (chosenAttachingParameter j) (chosenAttachingParameter_im_pos j)
+        (chosenAttachingParameter_filling_bound j) =
+      if PeriodFamily.Meridians.normalizationReversesMeridians then
+        SpecialPeriods.Threefold.PiOne.meridian (attachingMeridianIndex j)
+      else (SpecialPeriods.Threefold.PiOne.meridian (attachingMeridianIndex j))⁻¹ :=
+  transportedAttachingClass_eq_oriented_meridian j (chosenAttachingParameter j)
+    (chosenAttachingParameter_im_pos j) (chosenAttachingParameter_filling_bound j)
+    (chosenAttachingParameter_bound j)
+
+private theorem SpecialPeriods.Threefold.EllipticGeometry.clockwise_meridian_pow_order
+    (j : Elliptic.Kind) :
+    (if PeriodFamily.Meridians.normalizationReversesMeridians then
+          SpecialPeriods.Threefold.PiOne.meridian (attachingMeridianIndex j)
+        else (SpecialPeriods.Threefold.PiOne.meridian (attachingMeridianIndex j))⁻¹) ^
+        j.order =
+      SpecialPeriods.Threefold.PiOne.latticeHom (Multiplicative.ofAdd j.twist) := by
+  have h :=
+    transportedAttachingClass_pow_order j (chosenAttachingParameter j)
+      (chosenAttachingParameter_im_pos j) (chosenAttachingParameter_filling_bound j)
+  rwa [chosenTransportedAttachingClass_eq_oriented_meridian] at h
+
+private def SpecialPeriods.Threefold.PiOne.orientedCentral (reverse : Bool) : GlobalGroup :=
+  if reverse then c else c⁻¹
+
+private theorem SpecialPeriods.Threefold.PiOne.orientedCentral_commute (reverse : Bool)
+    (g : GlobalGroup) : Commute (orientedCentral reverse) g :=
+  all_commute _ _
+
+private theorem SpecialPeriods.Threefold.PiOne.c_eq_one_of_orientedCentral_eq_one (reverse : Bool)
+    (h : orientedCentral reverse = 1) : c = 1 := by
+  cases reverse with
+  | false => exact inv_eq_one.mp h
+  | true => exact h
+
+private theorem SpecialPeriods.Threefold.PiOne.trivial_of_oriented_elliptic_power_relations
+    (reverse : Bool) (h₃ : meridian Bool.false ^ 3 = orientedCentral reverse)
+    (h₄ : meridian Bool.true ^ 4 = (orientedCentral reverse)⁻¹) : ∀ g : GlobalGroup, g = 1 := by
+  have hgen :=
+    TwistGroup.main_realization_generators_eq_one (orientedCentral reverse) (meridian Bool.false)
+      (meridian Bool.true) (orientedCentral_commute reverse _) (orientedCentral_commute reverse _)
+      meridian_product_eq_one h₃ h₄
+  have hc : c = 1 := c_eq_one_of_orientedCentral_eq_one reverse hgen.1
+  have hid : MonoidHom.id GlobalGroup = 1 := by
+    apply hom_eq_one
+    · intro v
+      change latticeHom (Multiplicative.ofAdd v.toAdd) = 1
+      rw [latticeHom_eq_c_zpow, hc, one_zpow]
+    · intro b
+      cases b
+      · exact hgen.2.1
+      · exact hgen.2.2
+  intro g
+  exact DFunLike.congr_fun hid g
+
+private theorem SpecialPeriods.Threefold.PiOne.meridian_pow_order (j : Elliptic.Kind) :
+    meridian (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j) ^ j.order =
+      orientedCentral PeriodFamily.Meridians.normalizationReversesMeridians ^ γ j.twist := by
+  have h := SpecialPeriods.Threefold.EllipticGeometry.clockwise_meridian_pow_order j
+  rw [latticeHom_eq_c_zpow] at h
+  cases hreverse : PeriodFamily.Meridians.normalizationReversesMeridians with
+  |
+    false =>
+    have hinv :
+      meridian (SpecialPeriods.Threefold.EllipticGeometry.attachingMeridianIndex j) ^ j.order =
+        (c ^ γ j.twist)⁻¹ := by
+      simpa only [hreverse, Bool.false_eq_true, ↓reduceIte, inv_pow, inv_inv] using
+        congrArg (fun g : GlobalGroup => g⁻¹) h
+    simpa only [orientedCentral, hreverse, Bool.false_eq_true, ↓reduceIte, inv_zpow] using hinv
+  | true => simpa only [orientedCentral, hreverse, ↓reduceIte] using h
+
+private theorem SpecialPeriods.Threefold.PiOne.meridian_first_cube :
+    meridian Bool.false ^ 3 =
+      orientedCentral PeriodFamily.Meridians.normalizationReversesMeridians := by
+  have h := meridian_pow_order Elliptic.Kind.three
+  change
+    meridian Bool.false ^ 3 =
+      orientedCentral PeriodFamily.Meridians.normalizationReversesMeridians ^ (1 : ℤ) at h
+  simpa only [zpow_one] using h
+
+private theorem SpecialPeriods.Threefold.PiOne.meridian_second_fourth :
+    meridian Bool.true ^ 4 =
+      (orientedCentral PeriodFamily.Meridians.normalizationReversesMeridians)⁻¹ := by
+  have h := meridian_pow_order Elliptic.Kind.four
+  change
+    meridian Bool.true ^ 4 =
+      orientedCentral PeriodFamily.Meridians.normalizationReversesMeridians ^ (-1 : ℤ) at h
+  simpa only [zpow_neg_one] using h
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold SpecialPeriods.Threefold.space_connected in
+private theorem SpecialPeriods.Threefold.space_isRealAnalyticManifold :
+    IsManifold 𝓘(ℝ, ℂ × ComplexPlane₂) ω Space :=
+  complexManifold_isRealManifold Space ω
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold SpecialPeriods.Threefold.space_connected in
+private theorem SpecialPeriods.Threefold.space_isSmoothRealManifold :
+    IsManifold 𝓘(ℝ, ℂ × ComplexPlane₂) ∞ Space := by
+  let := space_isRealAnalyticManifold
+  infer_instance
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold SpecialPeriods.Threefold.space_connected in
+private theorem
+    SpecialPeriods.Threefold.real_dimension : Module.finrank ℝ (ℂ × ComplexPlane₂) = 6 := by
+  simp [ComplexPlane₂, Module.finrank_prod, Module.finrank_pi_fintype]
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold SpecialPeriods.Threefold.space_connected in
+private theorem
+    SpecialPeriods.Threefold.space_locallyPathConnected : LocallyPathConnectedSpace Space :=
+  ChartedSpace.locallyPathConnectedSpace (ℂ × ComplexPlane₂) Space
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.space_isManifold SpecialPeriods.Threefold.space_connected in
+private theorem SpecialPeriods.Threefold.space_pathConnected : PathConnectedSpace Space := by
+  let := space_locallyPathConnected
+  exact pathConnectedSpace_iff_connectedSpace.mpr space_connected
+
+private theorem SpecialPeriods.Threefold.PiOne.trivial (g : GlobalGroup) : g = 1 :=
+  trivial_of_oriented_elliptic_power_relations
+    PeriodFamily.Meridians.normalizationReversesMeridians meridian_first_cube
+    meridian_second_fourth g
+
+private theorem SpecialPeriods.Threefold.space_simplyConnected : SimplyConnectedSpace Space := by
+  have := space_pathConnected
+  exact simplyConnectedSpace_of_fundamentalGroup_eq_one PiOne.basepoint PiOne.trivial
+
+private theorem SpecialPeriods.Threefold.space_paths_homotopic {x y : Space} (p q : Path x y) :
+    Path.Homotopic p q := by
+  have := space_simplyConnected
+  exact SimplyConnectedSpace.paths_homotopic p q
+
+private theorem SpecialPeriods.Threefold.space_loops_nullhomotopic {x : Space} (p : Path x x) :
+    Path.Homotopic p (Path.refl x) :=
+  space_paths_homotopic p (Path.refl x)
+
+private def SpecialPeriods.Threefold.LowDegrees.singularH0Equiv :
+    SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 0 ≃ₗ[ℤ] ℤ := by
+  have := SpecialPeriods.Threefold.space_pathConnected
+  exact PeriodTorusHigherHomology.connectedHomologyZeroEquiv SpecialPeriods.Threefold.Space
+
+private theorem SpecialPeriods.Threefold.LowDegrees.singularH1_eq_zero
+    (a : SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 1) : a = 0 := by
+  have := SpecialPeriods.Threefold.space_pathConnected
+  obtain ⟨p, hp⟩ :=
+    FirstHurewicz.loopHomologyClass_surjective SpecialPeriods.Threefold.PiOne.basepoint a
+  exact
+    hp.symm.trans
+      ((FirstHurewicz.loopHomologyClass_homotopic
+            (SpecialPeriods.Threefold.space_loops_nullhomotopic p)).trans
+        (FirstHurewicz.loopHomologyClass_refl SpecialPeriods.Threefold.PiOne.basepoint))
+
+private theorem SpecialPeriods.Threefold.LowDegrees.singularH1_subsingleton :
+    Subsingleton (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 1) :=
+  ⟨fun a b => (singularH1_eq_zero a).trans (singularH1_eq_zero b).symm⟩
+
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.Gluing.localFlow_mem_overlap
+    (F :
+      ∀ i : SpecialPeriods.Threefold.Index,
+        ℂ → SpecialPeriods.Threefold.localPiece i → SpecialPeriods.Threefold.localPiece i)
+    (hbase :
+      ∀ i s x,
+        SpecialPeriods.Threefold.localProjectionToBase i (F i s x) =
+          SpecialPeriods.Threefold.localProjectionToBase i x)
+    (i : SpecialPeriods.Threefold.Puncture) (s : ℂ)
+    (x : SpecialPeriods.Threefold.localPiece (Option.some i))
+    (hx : x ∈ (SpecialPeriods.Threefold.localOverlap i).source) :
+    F (Option.some i) s x ∈ (SpecialPeriods.Threefold.localOverlap i).source := by
+  rw [SpecialPeriods.Threefold.localOverlap_source] at hx ⊢
+  change
+    SpecialPeriods.Threefold.localProjectionToBase (Option.some i) (F (Option.some i) s x) ∈
+      SpecialPeriods.Threefold.specialBaseCover.patch Option.none
+  rw [hbase]
+  exact hx
+
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.Gluing.inclusion_localOverlap
+    (i : SpecialPeriods.Threefold.Puncture)
+    (x : SpecialPeriods.Threefold.localPiece (Option.some i))
+    (hx : x ∈ (SpecialPeriods.Threefold.localOverlap i).source) :
+    SpecialPeriods.Threefold.inclusion Option.none (SpecialPeriods.Threefold.localOverlap i x) =
+      SpecialPeriods.Threefold.inclusion (Option.some i) x :=
+  ((SpecialPeriods.Threefold.gluingData.inclusion_eq_iff (Option.some i) Option.none x
+          (SpecialPeriods.Threefold.localOverlap i x)).mpr
+      ⟨hx, rfl⟩).symm
+
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.Gluing.compatible
+    (F :
+      ∀ i : SpecialPeriods.Threefold.Index,
+        ℂ → SpecialPeriods.Threefold.localPiece i → SpecialPeriods.Threefold.localPiece i)
+    (hbase :
+      ∀ i s x,
+        SpecialPeriods.Threefold.localProjectionToBase i (F i s x) =
+          SpecialPeriods.Threefold.localProjectionToBase i x)
+    (hoverlap :
+      ∀ i s x,
+        x ∈ (SpecialPeriods.Threefold.localOverlap i).source →
+          SpecialPeriods.Threefold.localOverlap i (F (Option.some i) s x) =
+            F Option.none s (SpecialPeriods.Threefold.localOverlap i x))
+    (s : ℂ) :
+    SpecialPeriods.Threefold.gluingData.Compatible
+      (fun i x => SpecialPeriods.Threefold.inclusion i (F i s x)) := by
+  intro i j x hx
+  by_cases hij : i = j
+  · subst j
+    change
+      SpecialPeriods.Threefold.inclusion i
+          (F i s (SpecialPeriods.Threefold.gluingData.transition i i x)) =
+        SpecialPeriods.Threefold.inclusion i (F i s x)
+    rw [SpecialPeriods.Threefold.gluingData.self_eq]
+    rfl
+  · cases i with
+    | none =>
+      cases j with
+      | none => exact (hij rfl).elim
+      | some j =>
+        change x ∈ (SpecialPeriods.Threefold.localOverlap j).target at hx
+        change
+          SpecialPeriods.Threefold.inclusion (Option.some j)
+              (F (Option.some j) s ((SpecialPeriods.Threefold.localOverlap j).symm x)) =
+            SpecialPeriods.Threefold.inclusion Option.none (F Option.none s x)
+        have hy := (SpecialPeriods.Threefold.localOverlap j).map_target hx
+        calc
+          SpecialPeriods.Threefold.inclusion (Option.some j)
+                (F (Option.some j) s ((SpecialPeriods.Threefold.localOverlap j).symm x)) =
+              SpecialPeriods.Threefold.inclusion Option.none
+                (SpecialPeriods.Threefold.localOverlap j
+                  (F (Option.some j) s ((SpecialPeriods.Threefold.localOverlap j).symm x))) :=
+            (inclusion_localOverlap j _ (localFlow_mem_overlap F hbase j s _ hy)).symm
+          _ =
+              SpecialPeriods.Threefold.inclusion Option.none
+                (F Option.none s
+                  (SpecialPeriods.Threefold.localOverlap j
+                    ((SpecialPeriods.Threefold.localOverlap j).symm x))) :=
+            (congrArg (SpecialPeriods.Threefold.inclusion Option.none) (hoverlap j s _ hy))
+          _ = SpecialPeriods.Threefold.inclusion Option.none (F Option.none s x) :=
+            congrArg (fun y => SpecialPeriods.Threefold.inclusion Option.none (F Option.none s y))
+              ((SpecialPeriods.Threefold.localOverlap j).right_inv hx)
+    | some i =>
+      cases j with
+      | none =>
+        change x ∈ (SpecialPeriods.Threefold.localOverlap i).source at hx
+        change
+          SpecialPeriods.Threefold.inclusion Option.none
+              (F Option.none s (SpecialPeriods.Threefold.localOverlap i x)) =
+            SpecialPeriods.Threefold.inclusion (Option.some i) (F (Option.some i) s x)
+        rw [← hoverlap i s x hx]
+        exact inclusion_localOverlap i _ (localFlow_mem_overlap F hbase i s x hx)
+      | some j =>
+        have hij' : i ≠ j := fun h => hij (congrArg Option.some h)
+        change
+          x ∈
+            (SpecialPeriods.Threefold.gluingStar.transition (Option.some i)
+                (Option.some j)).source at hx
+        rw [SpecialPeriods.Threefold.gluingStar.transition_some_some_source_eq_empty hij'] at hx
+        exact hx.elim
+
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace in
+private def SpecialPeriods.Threefold.VerticalAction.Gluing.glue
+    (F :
+      ∀ i : SpecialPeriods.Threefold.Index,
+        ℂ → SpecialPeriods.Threefold.localPiece i → SpecialPeriods.Threefold.localPiece i)
+    (hbase :
+      ∀ i s x,
+        SpecialPeriods.Threefold.localProjectionToBase i (F i s x) =
+          SpecialPeriods.Threefold.localProjectionToBase i x)
+    (hoverlap :
+      ∀ i s x,
+        x ∈ (SpecialPeriods.Threefold.localOverlap i).source →
+          SpecialPeriods.Threefold.localOverlap i (F (Option.some i) s x) =
+            F Option.none s (SpecialPeriods.Threefold.localOverlap i x))
+    (s : ℂ) : SpecialPeriods.Threefold.Space → SpecialPeriods.Threefold.Space :=
+  SpecialPeriods.Threefold.gluingData.descend
+    (fun i x => SpecialPeriods.Threefold.inclusion i (F i s x)) (compatible F hbase hoverlap s)
+
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Gluing.glue_inclusion
+    (F :
+      ∀ i : SpecialPeriods.Threefold.Index,
+        ℂ → SpecialPeriods.Threefold.localPiece i → SpecialPeriods.Threefold.localPiece i)
+    (hbase :
+      ∀ i s x,
+        SpecialPeriods.Threefold.localProjectionToBase i (F i s x) =
+          SpecialPeriods.Threefold.localProjectionToBase i x)
+    (hoverlap :
+      ∀ i s x,
+        x ∈ (SpecialPeriods.Threefold.localOverlap i).source →
+          SpecialPeriods.Threefold.localOverlap i (F (Option.some i) s x) =
+            F Option.none s (SpecialPeriods.Threefold.localOverlap i x))
+    (s : ℂ) (i : SpecialPeriods.Threefold.Index) (x : SpecialPeriods.Threefold.localPiece i) :
+    glue F hbase hoverlap s (SpecialPeriods.Threefold.inclusion i x) =
+      SpecialPeriods.Threefold.inclusion i (F i s x) :=
+  SpecialPeriods.Threefold.gluingData.descend_inclusion _ (compatible F hbase hoverlap s) i x
+
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.Gluing.glue_projection
+    (F :
+      ∀ i : SpecialPeriods.Threefold.Index,
+        ℂ → SpecialPeriods.Threefold.localPiece i → SpecialPeriods.Threefold.localPiece i)
+    (hbase :
+      ∀ i s x,
+        SpecialPeriods.Threefold.localProjectionToBase i (F i s x) =
+          SpecialPeriods.Threefold.localProjectionToBase i x)
+    (hoverlap :
+      ∀ i s x,
+        x ∈ (SpecialPeriods.Threefold.localOverlap i).source →
+          SpecialPeriods.Threefold.localOverlap i (F (Option.some i) s x) =
+            F Option.none s (SpecialPeriods.Threefold.localOverlap i x))
+    (s : ℂ) (x : SpecialPeriods.Threefold.Space) :
+    SpecialPeriods.Threefold.projection (glue F hbase hoverlap s x) =
+      SpecialPeriods.Threefold.projection x := by
+  obtain ⟨i, x, rfl⟩ := SpecialPeriods.Threefold.gluingData.inclusion_jointly_surjective x
+  rw [glue_inclusion, SpecialPeriods.Threefold.projection_inclusion,
+    SpecialPeriods.Threefold.projection_inclusion, hbase]
+
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.Gluing.glue_zero
+    (F :
+      ∀ i : SpecialPeriods.Threefold.Index,
+        ℂ → SpecialPeriods.Threefold.localPiece i → SpecialPeriods.Threefold.localPiece i)
+    (hbase :
+      ∀ i s x,
+        SpecialPeriods.Threefold.localProjectionToBase i (F i s x) =
+          SpecialPeriods.Threefold.localProjectionToBase i x)
+    (hoverlap :
+      ∀ i s x,
+        x ∈ (SpecialPeriods.Threefold.localOverlap i).source →
+          SpecialPeriods.Threefold.localOverlap i (F (Option.some i) s x) =
+            F Option.none s (SpecialPeriods.Threefold.localOverlap i x))
+    (hzero : ∀ i x, F i 0 x = x) (x : SpecialPeriods.Threefold.Space) :
+    glue F hbase hoverlap 0 x = x := by
+  obtain ⟨i, x, rfl⟩ := SpecialPeriods.Threefold.gluingData.inclusion_jointly_surjective x
+  rw [glue_inclusion, hzero]
+
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.Gluing.glue_add
+    (F :
+      ∀ i : SpecialPeriods.Threefold.Index,
+        ℂ → SpecialPeriods.Threefold.localPiece i → SpecialPeriods.Threefold.localPiece i)
+    (hbase :
+      ∀ i s x,
+        SpecialPeriods.Threefold.localProjectionToBase i (F i s x) =
+          SpecialPeriods.Threefold.localProjectionToBase i x)
+    (hoverlap :
+      ∀ i s x,
+        x ∈ (SpecialPeriods.Threefold.localOverlap i).source →
+          SpecialPeriods.Threefold.localOverlap i (F (Option.some i) s x) =
+            F Option.none s (SpecialPeriods.Threefold.localOverlap i x))
+    (hadd : ∀ i s t x, F i (s + t) x = F i s (F i t x)) (s t : ℂ)
+    (x : SpecialPeriods.Threefold.Space) :
+    glue F hbase hoverlap (s + t) x = glue F hbase hoverlap s (glue F hbase hoverlap t x) := by
+  obtain ⟨i, x, rfl⟩ := SpecialPeriods.Threefold.gluingData.inclusion_jointly_surjective x
+  rw [glue_inclusion, glue_inclusion, glue_inclusion, hadd]
+
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.Gluing.glue_int_cast
+    (F :
+      ∀ i : SpecialPeriods.Threefold.Index,
+        ℂ → SpecialPeriods.Threefold.localPiece i → SpecialPeriods.Threefold.localPiece i)
+    (hbase :
+      ∀ i s x,
+        SpecialPeriods.Threefold.localProjectionToBase i (F i s x) =
+          SpecialPeriods.Threefold.localProjectionToBase i x)
+    (hoverlap :
+      ∀ i s x,
+        x ∈ (SpecialPeriods.Threefold.localOverlap i).source →
+          SpecialPeriods.Threefold.localOverlap i (F (Option.some i) s x) =
+            F Option.none s (SpecialPeriods.Threefold.localOverlap i x))
+    (hint : ∀ i (n : ℤ) x, F i (n : ℂ) x = x) (n : ℤ) (x : SpecialPeriods.Threefold.Space) :
+    glue F hbase hoverlap (n : ℂ) x = x := by
+  obtain ⟨i, x, rfl⟩ := SpecialPeriods.Threefold.gluingData.inclusion_jointly_surjective x
+  rw [glue_inclusion, hint]
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.Gluing.inclusion_isLocalDiffeomorph
+    (i : SpecialPeriods.Threefold.Index) :
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (SpecialPeriods.Threefold.inclusion i) := by
+  intro x
+  exact
+    ((SpecialPeriods.Threefold.patchBiholomorph i).isLocalDiffeomorph x).comp (K :=
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))) (P := SpecialPeriods.Threefold.Space)
+      (isLocalDiffeomorph_subtypeVal (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+        (SpecialPeriods.Threefold.liftedPatch i) (SpecialPeriods.Threefold.patchBiholomorph i x))
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.Gluing.holomorphic_of_comp_patchLine
+    (f : SpecialPeriods.Threefold.Space × ℂ → SpecialPeriods.Threefold.Space)
+    (hf :
+      ∀ i,
+        ContMDiff (((modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ))
+          (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω
+          (fun p : SpecialPeriods.Threefold.localPiece i × ℂ =>
+            f (SpecialPeriods.Threefold.inclusion i p.1, p.2))) :
+    ContMDiff (((modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω f := by
+  rintro ⟨y, s⟩
+  obtain ⟨i, x, rfl⟩ := SpecialPeriods.Threefold.gluingData.inclusion_jointly_surjective y
+  let q : SpecialPeriods.Threefold.localPiece i × ℂ → SpecialPeriods.Threefold.Space × ℂ :=
+    fun p => (SpecialPeriods.Threefold.inclusion i p.1, p.2)
+  have hq :
+    IsLocalDiffeomorphAt
+      (((modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ))
+      (((modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ)) ω q
+      (x, s) :=
+    CanonicalProduct.isLocalDiffeomorphAt_prodLine (inclusion_isLocalDiffeomorph i x)
+  have hc :
+    ContMDiff (((modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (f ∘ q) :=
+    hf i
+  have hh := hc.contMDiffAt.comp (q (x, s)) hq.localInverse_contMDiffAt
+  apply hh.congr_of_eventuallyEq
+  filter_upwards [hq.localInverse_eventuallyEq_right] with z hz
+  change f z = f (q (hq.localInverse z))
+  exact (congrArg f hz).symm
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.Gluing.glue_joint_holomorphic
+    (F :
+      ∀ i : SpecialPeriods.Threefold.Index,
+        ℂ → SpecialPeriods.Threefold.localPiece i → SpecialPeriods.Threefold.localPiece i)
+    (hbase :
+      ∀ i s x,
+        SpecialPeriods.Threefold.localProjectionToBase i (F i s x) =
+          SpecialPeriods.Threefold.localProjectionToBase i x)
+    (hoverlap :
+      ∀ i s x,
+        x ∈ (SpecialPeriods.Threefold.localOverlap i).source →
+          SpecialPeriods.Threefold.localOverlap i (F (Option.some i) s x) =
+            F Option.none s (SpecialPeriods.Threefold.localOverlap i x))
+    (hF :
+      ∀ i,
+        ContMDiff (((modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ))
+          (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω
+          (fun p : SpecialPeriods.Threefold.localPiece i × ℂ => F i p.2 p.1)) :
+    ContMDiff (((modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω
+      (fun p : SpecialPeriods.Threefold.Space × ℂ => glue F hbase hoverlap p.2 p.1) := by
+  apply holomorphic_of_comp_patchLine
+  intro i
+  simp_rw [glue_inclusion]
+  exact (SpecialPeriods.Threefold.inclusion_holomorphic i).comp (hF i)
+
+private def
+    SpecialPeriods.Threefold.VerticalAction.Cusp.multiplier (s : ℂ) : ToricSpace.ActingTorus :=
+  ToricSpace.fibreMultiplier
+    ![1, Units.mk0 (Complex.exp (2 * Real.pi * Complex.I * s)) (Complex.exp_ne_zero _)]
+
+@[simp]
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Cusp.multiplier_zero : multiplier 0 = 1 := by
+  ext i
+  fin_cases i <;> simp [multiplier, ToricSpace.fibreMultiplier]
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.multiplier_add (s t : ℂ) :
+    multiplier (s + t) = multiplier s * multiplier t := by
+  ext i
+  fin_cases i <;> simp [multiplier, ToricSpace.fibreMultiplier, mul_add, Complex.exp_add]
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.multiplier_int_cast (n : ℤ) :
+    multiplier (n : ℂ) = 1 := by
+  have he : Complex.exp (2 * Real.pi * Complex.I * (n : ℂ)) = 1 := by
+    simpa only [mul_comm] using Complex.exp_int_mul_two_pi_mul_I n
+  ext i
+  fin_cases i <;> simp [multiplier, ToricSpace.fibreMultiplier, he]
+
+private def SpecialPeriods.Threefold.VerticalAction.Cusp.toricFlow (s : ℂ) :
+    ToricSpace.Space → ToricSpace.Space :=
+  ToricSpace.torusAction (multiplier s)
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.toricFlow_zero (x : ToricSpace.Space) :
+    toricFlow 0 x = x := by simp [toricFlow]
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.toricFlow_add (s t : ℂ)
+    (x : ToricSpace.Space) : toricFlow (s + t) x = toricFlow s (toricFlow t x) := by
+  simp only [toricFlow, multiplier_add, ToricSpace.torusAction_mul]
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.toricFlow_int_cast (n : ℤ)
+    (x : ToricSpace.Space) : toricFlow (n : ℂ) x = x := by simp [toricFlow]
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.toricFlow_time (s : ℂ)
+    (x : ToricSpace.Space) : ToricSpace.time (toricFlow s x) = ToricSpace.time x := by
+  exact ToricSpace.time_fibreMultiplier _ x
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.toricFlow_inclusion (s : ℂ)
+    (a : ToricFan.Triangle) (z : ToricCharts.CoordinateSpace 3) :
+    toricFlow s (ToricSpace.inclusion a z) =
+      ToricSpace.inclusion a (ToricSpace.scale a (multiplier s) z) :=
+  ToricSpace.torusAction_inclusion _ _ _
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.multiplier_holomorphic :
+    ContDiff ℂ ω (fun s : ℂ => fun i => (multiplier s i : ℂ)) := by
+  apply contDiff_pi.mpr
+  intro i
+  fin_cases i
+  · exact contDiff_const
+  · exact (contDiff_const.mul contDiff_id).cexp
+  · exact contDiff_const
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.multiplier_factors_holomorphic
+    (a : ToricFan.Triangle) : ContDiff ℂ ω (fun s => ToricSpace.factors a (multiplier s)) := by
+  apply contDiffOn_univ.mp
+  exact
+    (ToricCharts.monomial_contDiffOn a.dual ω).comp multiplier_holomorphic.contDiffOn
+      (fun s _ => ToricCharts.torus_subset_domain _ (fun i => (multiplier s i).ne_zero))
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.toricFlow_scale_joint_holomorphic
+    (a : ToricFan.Triangle) :
+    ContDiff ℂ ω
+      (fun p : ℂ × ToricCharts.CoordinateSpace 3 => ToricSpace.scale a (multiplier p.1) p.2) :=
+  ((multiplier_factors_holomorphic a).comp contDiff_fst).mul contDiff_snd
+
+private theorem
+  SpecialPeriods.Threefold.VerticalAction.Cusp.toricFlow_scale_joint_contMDiff_mo1973_28674
+    (a : ToricFan.Triangle) :
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω
+      (fun q : ℂ × ToricCharts.CoordinateSpace 3 => ToricSpace.scale a (multiplier q.1) q.2) :=
+  (toricFlow_scale_joint_holomorphic a).contMDiff
+
+private theorem
+  SpecialPeriods.Threefold.VerticalAction.Cusp.toricChartInverse_holomorphic_mo1973_28675
+    (a : ToricFan.Triangle) (x : ToricSpace.Space)
+    (hx : x ∈ (ToricSpace.parametrization a).target) :
+    ContMDiffAt (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω
+      (ToricSpace.parametrization a).symm x := by
+  have he :
+    (ToricSpace.parametrization a).symm ∈
+      IsManifold.maximalAtlas (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω
+        ToricSpace.Space :=
+    IsManifold.subset_maximalAtlas (Set.mem_range_self a)
+  exact contMDiffAt_of_mem_maximalAtlas he hx
+
+private theorem
+  SpecialPeriods.Threefold.VerticalAction.Cusp.toricFlow_local_coordinates_holomorphic_mo1973_28676
+    (a : ToricFan.Triangle) (p : ℂ × ToricSpace.Space)
+    (hp : p.2 ∈ (ToricSpace.parametrization a).target) :
+    ContMDiffAt
+      (((modelWithCornersSelf ℂ ℂ)).prod (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)))
+      (modelWithCornersSelf ℂ (ℂ × ToricCharts.CoordinateSpace 3)) ω
+      (fun q : ℂ × ToricSpace.Space => (q.1, (ToricSpace.parametrization a).symm q.2)) p := by
+  have hinv := toricChartInverse_holomorphic_mo1973_28675 a p.2 hp
+  have hfirst :
+    ContMDiffAt
+      (((modelWithCornersSelf ℂ ℂ)).prod (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)))
+      (modelWithCornersSelf ℂ ℂ) ω (Prod.fst : ℂ × ToricSpace.Space → ℂ) p :=
+    contMDiffAt_fst
+  have hsecond :
+    ContMDiffAt
+      (((modelWithCornersSelf ℂ ℂ)).prod (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω
+      (fun q : ℂ × ToricSpace.Space => (ToricSpace.parametrization a).symm q.2) p :=
+    hinv.comp p contMDiffAt_snd
+  exact hfirst.prodMk_space hsecond
+
+private theorem
+  SpecialPeriods.Threefold.VerticalAction.Cusp.toricFlow_local_scaled_holomorphic_mo1973_28677
+    (a : ToricFan.Triangle) (p : ℂ × ToricSpace.Space)
+    (hp : p.2 ∈ (ToricSpace.parametrization a).target) :
+    ContMDiffAt
+      (((modelWithCornersSelf ℂ ℂ)).prod (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω
+      (fun q : ℂ × ToricSpace.Space =>
+        ToricSpace.scale a (multiplier q.1) ((ToricSpace.parametrization a).symm q.2))
+      p := by
+  exact
+    ContMDiffAt.comp (I :=
+      ((modelWithCornersSelf ℂ ℂ)).prod (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)))
+      (I' := modelWithCornersSelf ℂ (ℂ × ToricCharts.CoordinateSpace 3)) (I'' :=
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))) (f :=
+      fun q : ℂ × ToricSpace.Space => (q.1, (ToricSpace.parametrization a).symm q.2)) (g :=
+      fun q : ℂ × ToricCharts.CoordinateSpace 3 => ToricSpace.scale a (multiplier q.1) q.2) p
+      (toricFlow_scale_joint_contMDiff_mo1973_28674 a
+        (p.1, (ToricSpace.parametrization a).symm p.2))
+      (toricFlow_local_coordinates_holomorphic_mo1973_28676 a p hp)
+
+private theorem
+  SpecialPeriods.Threefold.VerticalAction.Cusp.toricFlow_local_holomorphic_mo1973_28678
+    (a : ToricFan.Triangle) (p : ℂ × ToricSpace.Space)
+    (hp : p.2 ∈ (ToricSpace.parametrization a).target) :
+    ContMDiffAt
+      (((modelWithCornersSelf ℂ ℂ)).prod (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω
+      (fun q : ℂ × ToricSpace.Space =>
+        ToricSpace.inclusion a
+          (ToricSpace.scale a (multiplier q.1) ((ToricSpace.parametrization a).symm q.2)))
+      p :=
+  (ToricSpace.inclusion_holomorphic a).contMDiffAt.comp p
+    (toricFlow_local_scaled_holomorphic_mo1973_28677 a p hp)
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.toricFlow_joint_holomorphic :
+    ContMDiff
+      (((modelWithCornersSelf ℂ ℂ)).prod (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω
+      (fun p : ℂ × ToricSpace.Space => toricFlow p.1 p.2) := by
+  intro p
+  let a := ToricSpace.preferredTriangle p.2
+  have hp : p.2 ∈ (ToricSpace.parametrization a).target := by
+    rw [ToricSpace.parametrization_target]
+    exact ToricSpace.preferred_mem p.2
+  apply (toricFlow_local_holomorphic_mo1973_28678 a p hp).congr_of_eventuallyEq
+  filter_upwards [continuous_snd.continuousAt.preimage_mem_nhds
+      ((ToricSpace.parametrization a).open_target.mem_nhds hp)] with
+    q hq
+  calc
+    toricFlow q.1 q.2 =
+        toricFlow q.1 (ToricSpace.inclusion a ((ToricSpace.parametrization a).symm q.2)) :=
+      congrArg (toricFlow q.1) ((ToricSpace.parametrization a).right_inv hq).symm
+    _ = _ := toricFlow_inclusion q.1 a _
+
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Cusp.fibreMultiplier_variableMultiplier_commute
+    (u : Fin 2 → ℂˣ) (v : ℂ → Fin 2 → ℂˣ) (x : ToricSpace.Space) :
+    ToricSpace.torusAction (ToricSpace.fibreMultiplier u) (ToricSpace.variableMultiplier v x) =
+      ToricSpace.variableMultiplier v (ToricSpace.torusAction (ToricSpace.fibreMultiplier u) x) :=
+  by
+  simp only [ToricSpace.variableMultiplier, ToricSpace.time_fibreMultiplier,
+    ToricSpace.torusAction_mul]
+  rw [mul_comm]
+
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Cusp.fibreMultiplier_twistedTranslate_commute
+    (u : Fin 2 → ℂˣ) (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ) (x : ToricSpace.Space) :
+    ToricSpace.torusAction (ToricSpace.fibreMultiplier u) (ToricSpace.twistedTranslate C v x) =
+      ToricSpace.twistedTranslate C v (ToricSpace.torusAction (ToricSpace.fibreMultiplier u) x) :=
+  by
+  unfold ToricSpace.twistedTranslate
+  rw [fibreMultiplier_variableMultiplier_commute, ToricSpace.fibreMultiplier_translate]
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.toricFlow_twistedTranslate
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (s : ℂ) (v : Fin 2 → ℤ) (x : ToricSpace.Space) :
+    toricFlow s (ToricSpace.twistedTranslate C v x) =
+      ToricSpace.twistedTranslate C v (toricFlow s x) :=
+  fibreMultiplier_twistedTranslate_commute _ C v x
+
+private def
+    SpecialPeriods.Threefold.VerticalAction.Cusp.tubeFlow (D : TopologicalSpace.Opens ℂ) (s : ℂ)
+    (x : ToricSpace.Tube D) : ToricSpace.Tube D :=
+  ⟨toricFlow s x, by
+    change ToricSpace.time (toricFlow s x) ∈ D
+    rw [toricFlow_time]
+    exact x.property⟩
+
+@[simp]
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Cusp.tubeFlow_zero (D : TopologicalSpace.Opens ℂ)
+    (x : ToricSpace.Tube D) : tubeFlow D 0 x = x :=
+  Subtype.ext (toricFlow_zero x)
+
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Cusp.tubeFlow_add (D : TopologicalSpace.Opens ℂ)
+    (s t : ℂ) (x : ToricSpace.Tube D) : tubeFlow D (s + t) x = tubeFlow D s (tubeFlow D t x) :=
+  Subtype.ext (toricFlow_add s t x)
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.tubeFlow_int_cast
+    (D : TopologicalSpace.Opens ℂ) (n : ℤ) (x : ToricSpace.Tube D) : tubeFlow D (n : ℂ) x = x :=
+  Subtype.ext (toricFlow_int_cast n x)
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.tubeFlow_translate
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (D : TopologicalSpace.Opens ℂ) (s : ℂ) (v : Fin 2 → ℤ)
+    (x : ToricSpace.Tube D) :
+    tubeFlow D s (ToricSpace.tubeTranslate C D v x) =
+      ToricSpace.tubeTranslate C D v (tubeFlow D s x) :=
+  Subtype.ext (toricFlow_twistedTranslate C s v x)
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.tubeFlow_joint_holomorphic
+    (D : TopologicalSpace.Opens ℂ) :
+    ContMDiff
+      (((modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω
+      (fun p : ToricSpace.Tube D × ℂ => tubeFlow D p.2 p.1) := by
+  intro p
+  have he :
+    ContMDiffAt
+        (((modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))).prod
+          (modelWithCornersSelf ℂ ℂ))
+        (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω
+        (fun q : ToricSpace.Tube D × ℂ => (tubeFlow D q.2 q.1 : ToricSpace.Space)) p ↔
+      ContMDiffAt
+        (((modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))).prod
+          (modelWithCornersSelf ℂ ℂ))
+        (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω
+        (fun q : ToricSpace.Tube D × ℂ => tubeFlow D q.2 q.1) p :=
+    ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+  exact
+    he.mp
+      (toricFlow_joint_holomorphic.comp
+        (contMDiff_snd.prodMk (contMDiff_subtype_val.comp contMDiff_fst)) p)
+
+private def
+    SpecialPeriods.Threefold.VerticalAction.Cusp.flow (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (s : ℂ) : CuspQuotient.QuotientSpace C ε → CuspQuotient.QuotientSpace C ε :=
+  Quotient.lift (fun x => CuspQuotient.quotientMap C ε (tubeFlow (CuspQuotient.disc ε) s x))
+    (by
+      let := ToricSpace.tubeAction C (CuspQuotient.disc ε)
+      intro x y hxy
+      change x ∈ MulAction.orbit CuspQuotient.LatticeGroup y at hxy
+      obtain ⟨g, rfl⟩ := hxy
+      change
+        CuspQuotient.quotientMap C ε
+            (tubeFlow (CuspQuotient.disc ε) s
+              (ToricSpace.tubeTranslate C (CuspQuotient.disc ε) g.toAdd y)) =
+          _
+      rw [tubeFlow_translate, CuspQuotient.quotientMap_translate])
+
+@[simp]
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Cusp.flow_zero (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (x : CuspQuotient.QuotientSpace C ε) : flow C ε 0 x = x := by
+  induction x using Quotient.inductionOn with
+  | h x => exact congrArg (CuspQuotient.quotientMap C ε) (tubeFlow_zero _ x)
+
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Cusp.flow_add (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (s t : ℂ) (x : CuspQuotient.QuotientSpace C ε) :
+    flow C ε (s + t) x = flow C ε s (flow C ε t x) := by
+  induction x using Quotient.inductionOn with
+  | h x => exact congrArg (CuspQuotient.quotientMap C ε) (tubeFlow_add _ s t x)
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.flow_int_cast
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (n : ℤ) (x : CuspQuotient.QuotientSpace C ε) :
+    flow C ε (n : ℂ) x = x := by
+  induction x using Quotient.inductionOn with
+  | h x => exact congrArg (CuspQuotient.quotientMap C ε) (tubeFlow_int_cast _ n x)
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.projection_flow
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (s : ℂ) (x : CuspQuotient.QuotientSpace C ε) :
+    CuspQuotient.projection C ε (flow C ε s x) = CuspQuotient.projection C ε x := by
+  induction x using Quotient.inductionOn with
+  | h x => exact toricFlow_time s x
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.quotientMap_isLocalDiffeomorph
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    letI := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (CuspQuotient.quotientMap C ε) :=
+  by
+  let := ToricSpace.tubeAction C (CuspQuotient.disc ε)
+  exact
+    CoveringQuotient.project_isLocalDiffeomorph
+      (CuspQuotient.quotientMap_covering C ε hε hε1 hC hR)
+      (fun v => ToricSpace.tubeTranslate_holomorphic C (CuspQuotient.disc ε) v.toAdd hC)
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.flow_joint_holomorphic
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    letI := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+    ContMDiff
+      (((modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω
+      (fun p : CuspQuotient.QuotientSpace C ε × ℂ => flow C ε p.2 p.1) := by
+  let := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+  have hq :=
+    CanonicalProduct.isLocalDiffeomorph_prodLine (quotientMap_isLocalDiffeomorph C ε hε hε1 hC hR)
+  have hs :
+    Function.Surjective
+      (fun p : ToricSpace.Tube (CuspQuotient.disc ε) × ℂ =>
+        (CuspQuotient.quotientMap C ε p.1, p.2)) := by
+    rintro ⟨q, s⟩
+    obtain ⟨x, rfl⟩ := Quotient.exists_rep q
+    exact ⟨(x, s), rfl⟩
+  apply
+    contMDiff_of_comp_localDiffeomorph
+      (((modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))).prod (modelWithCornersSelf ℂ ℂ))
+      (((modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) hq hs
+  exact
+    (CuspQuotient.quotientMap_holomorphic C ε hε hε1 hC hR).comp
+      (tubeFlow_joint_holomorphic (CuspQuotient.disc ε))
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.torusAction_torusPoint
+    (u : ToricSpace.ActingTorus) (w : ToricCharts.CoordinateSpace 3) :
+    ToricSpace.torusAction u (CuspUniformization.torusPoint w) =
+      CuspUniformization.torusPoint (fun j => (u j : ℂ) * w j) := by
+  change
+    ToricSpace.torusAction u
+        (ToricSpace.inclusion ToricSpace.referenceTriangle
+          (ToricCharts.monomial ToricSpace.referenceTriangle.dual w)) =
+      ToricSpace.inclusion ToricSpace.referenceTriangle
+        (ToricCharts.monomial ToricSpace.referenceTriangle.dual ((fun j => (u j : ℂ)) * w))
+  rw [ToricSpace.torusAction_inclusion, ToricCharts.monomial_mul]
+  rfl
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.toricFlow_torusPoint (s : ℂ)
+    (w : ToricCharts.CoordinateSpace 3) :
+    toricFlow s (CuspUniformization.torusPoint w) =
+      CuspUniformization.torusPoint ![w 0, CuspUniformization.exponential s * w 1, w 2] := by
+  rw [toricFlow, torusAction_torusPoint]
+  apply congrArg CuspUniformization.torusPoint
+  ext i
+  fin_cases i <;> simp [multiplier, ToricSpace.fibreMultiplier, CuspUniformization.exponential]
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.toricFlow_exponentialPoint (s t : ℂ)
+    (z : ComplexPlane₂) :
+    toricFlow s (CuspUniformization.exponentialPoint t z) =
+      CuspUniformization.exponentialPoint t (z + s • (![0, 1] : ComplexPlane₂)) := by
+  change
+    toricFlow s (CuspUniformization.torusPoint (CuspUniformization.exponentialCoordinates t z)) =
+      CuspUniformization.torusPoint
+        (CuspUniformization.exponentialCoordinates t (z + s • (![0, 1] : ComplexPlane₂)))
+  rw [toricFlow_torusPoint]
+  apply congrArg CuspUniformization.torusPoint
+  ext i
+  fin_cases i <;>
+    simp [CuspUniformization.exponentialCoordinates, CuspUniformization.exponential_add, mul_comm]
+
+private def SpecialPeriods.Threefold.VerticalAction.Cusp.logFlow (ε : ℝ) (s : ℂ)
+    (p : CuspUniformization.LogCover ε) : CuspUniformization.LogCover ε :=
+  ⟨(p.val.1, p.val.2 + s • (![0, 1] : ComplexPlane₂)), p.property⟩
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.toricFlow_totalExponentialPoint (s : ℂ)
+    (p : ℂ × ComplexPlane₂) :
+    toricFlow s (CuspUniformization.totalExponentialPoint p) =
+      CuspUniformization.totalExponentialPoint (p.1, p.2 + s • (![0, 1] : ComplexPlane₂)) :=
+  toricFlow_exponentialPoint s (CuspUniformization.exponential p.1) p.2
+
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Cusp.tubeFlow_totalExponentialLift (ε : ℝ) (s : ℂ)
+    (p : CuspUniformization.LogCover ε) :
+    tubeFlow (CuspQuotient.disc ε) s (CuspUniformization.totalExponentialLift ε p) =
+      CuspUniformization.totalExponentialLift ε (logFlow ε s p) :=
+  Subtype.ext (toricFlow_totalExponentialPoint s p)
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.flow_totalCuspCover
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (s : ℂ) (p : CuspUniformization.LogCover ε) :
+    flow C ε s (CuspUniformization.totalCuspCover C ε p) =
+      CuspUniformization.totalCuspCover C ε (logFlow ε s p) := by
+  change
+    CuspQuotient.quotientMap C ε
+        (tubeFlow (CuspQuotient.disc ε) s (CuspUniformization.totalExponentialLift ε p)) =
+      _
+  rw [tubeFlow_totalExponentialLift]
+  rfl
+
+private def SpecialPeriods.Threefold.VerticalAction.Period.vector (s : ℂ) : ComplexPlane₂ :=
+  ![0, s]
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Period.vector_zero : vector 0 = 0 := by
+  ext i
+  fin_cases i <;> rfl
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Period.vector_add (s t : ℂ) :
+    vector (s + t) = vector s + vector t := by
+  ext i
+  fin_cases i <;> simp [vector]
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Period.vector_eq_smul (s : ℂ) :
+    vector s = s • (![0, 1] : ComplexPlane₂) := by
+  ext i
+  fin_cases i <;> simp [vector]
+
+private def SpecialPeriods.Threefold.VerticalAction.Period.vectorFlow {B : Type*} (s : ℂ)
+    (x : B × ComplexPlane₂) : B × ComplexPlane₂ :=
+  (x.1, x.2 + vector s)
+
+private def SpecialPeriods.Threefold.VerticalAction.Period.flow {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] (P : HolomorphicPeriodMap V B)
+    (s : ℂ) (x : P.TotalSpace) : P.TotalSpace :=
+  (x.1, x.2 + standardLattice.mkQ ((P.periodEquiv x.1).symm (vector s)))
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Period.flow_quotientMap {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    (P : HolomorphicPeriodMap V B) (s : ℂ) (x : B × ComplexPlane₂) :
+    flow P s (P.quotientMap x) = P.quotientMap (vectorFlow s x) := by
+  simp only [flow, HolomorphicPeriodMap.quotientMap, vectorFlow, map_add]
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Period.flow_projection {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    (P : HolomorphicPeriodMap V B) (s : ℂ) (x : P.TotalSpace) :
+    P.projection (flow P s x) = P.projection x :=
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Period.flow_zero {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    (P : HolomorphicPeriodMap V B) (x : P.TotalSpace) : flow P 0 x = x := by simp [flow]
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Period.flow_add {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    (P : HolomorphicPeriodMap V B) (s t : ℂ) (x : P.TotalSpace) :
+    flow P (s + t) x = flow P s (flow P t x) := by
+  simp only [flow, vector_add, map_add]
+  congr 1
+  abel
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Period.periodEquiv_delta {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    (P : HolomorphicPeriodMap V B) (b : B) :
+    P.periodEquiv b (Pi.basisFun ℝ (Fin 4) 3) = (![0, 1] : ComplexPlane₂) := by
+  rw [P.periodEquiv_coordinates]
+  ext i
+  fin_cases i <;> simp
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Period.inverse_vector_int_mem {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    (P : HolomorphicPeriodMap V B) (b : B) (n : ℤ) :
+    (P.periodEquiv b).symm (vector (n : ℂ)) ∈ standardLattice := by
+  have he : P.periodEquiv b (n • Pi.basisFun ℝ (Fin 4) 3) = vector (n : ℂ) := by
+    rw [map_zsmul, periodEquiv_delta]
+    ext i
+    fin_cases i <;> simp [vector]
+  rw [← he, LinearEquiv.symm_apply_apply]
+  apply Submodule.smul_mem
+  exact Submodule.subset_span ⟨3, rfl⟩
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Period.flow_int_cast {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    (P : HolomorphicPeriodMap V B) (n : ℤ) (x : P.TotalSpace) : flow P (n : ℂ) x = x := by
+  have hz : standardLattice.mkQ ((P.periodEquiv x.1).symm (vector (n : ℂ))) = 0 :=
+    (Submodule.Quotient.mk_eq_zero standardLattice).mpr (inverse_vector_int_mem P x.1 n)
+  simp [flow, hz]
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Triangle.rightBlock_vector {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (g : SpecialPeriods.TriangleGroup) (b : B) (s : ℂ) :
+    D.rightBlock g b *ᵥ SpecialPeriods.Threefold.VerticalAction.Period.vector s =
+      SpecialPeriods.Threefold.VerticalAction.Period.vector s := by
+  rw [SpecialPeriods.Threefold.VerticalAction.Period.vector_eq_smul, Matrix.mulVec_smul,
+    D.rightBlock_fixes_second]
+
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Triangle.vectorFlow_complexLift {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) (s : ℂ)
+    (g : SpecialPeriods.TriangleGroup) (x : B × ComplexPlane₂) :
+    SpecialPeriods.Threefold.VerticalAction.Period.vectorFlow s (D.complexLift g x) =
+      D.complexLift g (SpecialPeriods.Threefold.VerticalAction.Period.vectorFlow s x) := by
+  simp only [SpecialPeriods.Threefold.VerticalAction.Period.vectorFlow,
+    PeriodFamily.Data.complexLift, Matrix.mulVec_add, rightBlock_vector]
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Triangle.periodFlow_smul {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) (s : ℂ)
+    (g : SpecialPeriods.TriangleGroup) (x : D.TotalSpace) :
+    letI := D.totalAction
+    SpecialPeriods.Threefold.VerticalAction.Period.flow D.periods s (g • x) =
+      g • SpecialPeriods.Threefold.VerticalAction.Period.flow D.periods s x := by
+  let := D.totalAction
+  obtain ⟨w, rfl⟩ := D.periods.quotientMap_surjective x
+  rw [← D.complexLift_quotientMap,
+    SpecialPeriods.Threefold.VerticalAction.Period.flow_quotientMap, vectorFlow_complexLift,
+    D.complexLift_quotientMap, SpecialPeriods.Threefold.VerticalAction.Period.flow_quotientMap]
+
+private def
+    SpecialPeriods.Threefold.VerticalAction.Triangle.flow {V B : Type*} [NormedAddCommGroup V]
+    [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) (s : ℂ) :
+    D.Space → D.Space := by
+  let := D.totalAction
+  exact
+    Quotient.lift
+      (fun x => D.quotient (SpecialPeriods.Threefold.VerticalAction.Period.flow D.periods s x))
+      (by
+        intro x y hxy
+        have he : D.quotient x = D.quotient y := Quotient.sound hxy
+        obtain ⟨g, hg⟩ := (D.quotient_eq_iff x y).mp he
+        rw [← hg, periodFlow_smul, D.quotient_smul])
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Triangle.flow_quotient {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) (s : ℂ)
+    (x : D.TotalSpace) :
+    flow D s (D.quotient x) =
+      D.quotient (SpecialPeriods.Threefold.VerticalAction.Period.flow D.periods s x) :=
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Triangle.flow_projection {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) (s : ℂ) (x : D.Space) :
+    D.projection (flow D s x) = D.projection x := by
+  obtain ⟨x, rfl⟩ := D.quotient_surjective x
+  rw [flow_quotient, D.projection_quotient, D.projection_quotient,
+    SpecialPeriods.Threefold.VerticalAction.Period.flow_projection]
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Triangle.flow_zero {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) (x : D.Space) :
+    flow D 0 x = x := by
+  obtain ⟨x, rfl⟩ := D.quotient_surjective x
+  rw [flow_quotient, SpecialPeriods.Threefold.VerticalAction.Period.flow_zero]
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Triangle.flow_add {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) (s t : ℂ)
+    (x : D.Space) : flow D (s + t) x = flow D s (flow D t x) := by
+  obtain ⟨x, rfl⟩ := D.quotient_surjective x
+  simp only [flow_quotient, SpecialPeriods.Threefold.VerticalAction.Period.flow_add]
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Triangle.flow_int_cast {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B) (n : ℤ) (x : D.Space) :
+    flow D (n : ℂ) x = x := by
+  obtain ⟨x, rfl⟩ := D.quotient_surjective x
+  rw [flow_quotient, SpecialPeriods.Threefold.VerticalAction.Period.flow_int_cast]
+
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Period.vector_holomorphic : ContDiff ℂ ω vector :=
+  by
+  apply contDiff_pi.mpr
+  intro i
+  fin_cases i
+  · exact contDiff_const
+  · exact contDiff_id
+
+@[instance_reducible]
+private def SpecialPeriods.Threefold.VerticalAction.Period.vectorChartedSpace {V B : Type*}
+    [NormedAddCommGroup V] [TopologicalSpace B] [ChartedSpace V B] :
+    ChartedSpace (V × ComplexPlane₂) (B × ComplexPlane₂) :=
+  inferInstanceAs (ChartedSpace (ModelProd V ComplexPlane₂) (B × ComplexPlane₂))
+
+attribute [local instance] SpecialPeriods.Threefold.VerticalAction.Period.vectorChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Period.jointVectorFlow_holomorphic {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B] :
+    ContMDiff (((modelWithCornersSelf ℂ (V × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ (V × ComplexPlane₂)) ω
+      (fun x : (B × ComplexPlane₂) × ℂ => vectorFlow x.2 x.1) := by
+  rw [modelWithCornersSelf_prod]
+  exact
+    (contMDiff_fst.comp contMDiff_fst).prodMk
+      ((contMDiff_snd.comp contMDiff_fst).add (vector_holomorphic.contMDiff.comp contMDiff_snd))
+
+attribute [local instance] SpecialPeriods.Threefold.VerticalAction.Period.vectorChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.Period.jointFlow_holomorphic {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    (P : HolomorphicPeriodMap V B) [IsManifold (modelWithCornersSelf ℂ V) ω B] :
+    letI := P.totalChartedSpace
+    ContMDiff (((modelWithCornersSelf ℂ (V × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ (V × ComplexPlane₂)) ω
+      (fun x : P.TotalSpace × ℂ => flow P x.2 x.1) := by
+  let := P.totalChartedSpace
+  have hq := CanonicalProduct.isLocalDiffeomorph_prodLine P.quotientMap_isLocalDiffeomorph
+  have hs : Function.Surjective (fun x : (B × ComplexPlane₂) × ℂ => (P.quotientMap x.1, x.2)) := by
+    rintro ⟨y, s⟩
+    obtain ⟨x, rfl⟩ := P.quotientMap_surjective y
+    exact ⟨(x, s), rfl⟩
+  apply
+    contMDiff_of_comp_localDiffeomorph
+      (((modelWithCornersSelf ℂ (V × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ))
+      (((modelWithCornersSelf ℂ (V × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ (V × ComplexPlane₂)) hq hs
+  change
+    ContMDiff (((modelWithCornersSelf ℂ (V × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ (V × ComplexPlane₂)) ω
+      (fun x : (B × ComplexPlane₂) × ℂ => flow P x.2 (P.quotientMap x.1))
+  simp_rw [flow_quotientMap]
+  exact P.quotientMap_holomorphic.comp jointVectorFlow_holomorphic
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Triangle.jointFlow_holomorphic {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    [MulAction SpecialPeriods.TriangleGroup B] (D : PeriodFamily.Data V B)
+    (hq : IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup)
+    [IsManifold (modelWithCornersSelf ℂ V) ω B] :
+    letI := D.chartedSpace hq
+    ContMDiff (((modelWithCornersSelf ℂ (V × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ (V × ComplexPlane₂)) ω (fun x : D.Space × ℂ => flow D x.2 x.1) := by
+  let := D.periods.totalChartedSpace
+  let := D.chartedSpace hq
+  have hl := CanonicalProduct.isLocalDiffeomorph_prodLine (D.quotient_isLocalDiffeomorph hq)
+  have hs : Function.Surjective (fun x : D.TotalSpace × ℂ => (D.quotient x.1, x.2)) := by
+    rintro ⟨y, s⟩
+    obtain ⟨x, rfl⟩ := D.quotient_surjective y
+    exact ⟨(x, s), rfl⟩
+  apply
+    contMDiff_of_comp_localDiffeomorph
+      (((modelWithCornersSelf ℂ (V × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ))
+      (((modelWithCornersSelf ℂ (V × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ (V × ComplexPlane₂)) hl hs
+  change
+    ContMDiff (((modelWithCornersSelf ℂ (V × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ (V × ComplexPlane₂)) ω
+      (fun x : D.TotalSpace × ℂ => flow D x.2 (D.quotient x.1))
+  simp_rw [flow_quotient]
+  exact
+    (D.quotient_holomorphic hq).comp
+      (SpecialPeriods.Threefold.VerticalAction.Period.jointFlow_holomorphic D.periods)
+
+private def SpecialPeriods.Threefold.VerticalAction.Cusp.overlapVectorCover
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (p : CuspUniformization.LogCover C.radius) : D.Space :=
+  D.quotient
+    (D.periods.quotientMap
+      (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap ⟨p.val.1, p.property⟩, p.val.2))
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.overlapVectorCover_logFlow
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) (s : ℂ)
+    (p : CuspUniformization.LogCover C.radius) :
+    overlapVectorCover C D hrcap (logFlow C.radius s p) =
+      SpecialPeriods.Threefold.VerticalAction.Triangle.flow D s
+        (overlapVectorCover C D hrcap p) := by
+  unfold overlapVectorCover
+  rw [SpecialPeriods.Threefold.VerticalAction.Triangle.flow_quotient,
+    SpecialPeriods.Threefold.VerticalAction.Period.flow_quotientMap]
+  apply congrArg D.quotient
+  apply congrArg D.periods.quotientMap
+  change
+    (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap ⟨p.val.1, p.property⟩,
+        p.val.2 + s • (![0, 1] : ComplexPlane₂)) =
+      (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap ⟨p.val.1, p.property⟩,
+        p.val.2 + SpecialPeriods.Threefold.VerticalAction.Period.vector s)
+  rw [SpecialPeriods.Threefold.VerticalAction.Period.vector_eq_smul]
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.familyMap_iteratedCover_eq_vectorCover
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (hperiod :
+      ∀ s : SpecialPeriods.CuspFamily.LogBase C.radius,
+        D.periods.point (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap s) =
+          C.periods.point s)
+    (p : CuspUniformization.LogCover C.radius) :
+    SpecialPeriods.CuspGlobalOverlap.familyMap C D hrcap (C.iteratedCover p) =
+      overlapVectorCover C D hrcap p := by
+  change
+    D.quotient
+        (HolomorphicPeriodMap.periodPullbackMap C.periods D.periods
+          (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap)
+          (C.periods.quotientMap (⟨p.val.1, p.property⟩, p.val.2))) =
+      _
+  exact
+    congrArg D.quotient
+      (HolomorphicPeriodMap.periodPullbackMap_quotientMap C.periods D.periods
+        (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap) hperiod
+        (⟨p.val.1, p.property⟩, p.val.2))
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.cuspToRegularPartial_totalCuspCover
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (hperiod :
+      ∀ s : SpecialPeriods.CuspFamily.LogBase C.radius,
+        D.periods.point (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap s) =
+          C.periods.point s)
+    (p : CuspUniformization.LogCover C.radius) :
+    letI :=
+      CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+        C.smallDrift
+    letI := D.chartedSpace (SpecialPeriods.CuspGlobalOverlap.familyCovering D)
+    SpecialPeriods.CuspGlobalOverlap.cuspToRegularPartial C D hrcap hperiod
+        (CuspUniformization.totalCuspCover C.correction C.radius p) =
+      overlapVectorCover C D hrcap p := by
+  let :=
+    CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+      C.smallDrift
+  let := D.chartedSpace (SpecialPeriods.CuspGlobalOverlap.familyCovering D)
+  exact
+    (SpecialPeriods.CuspGlobalOverlap.cuspToRegularPartial_apply C D hrcap hperiod
+          (CuspUniformization.totalCuspCover C.correction C.radius p)
+          (CuspUniformization.puncturedCuspCover C.correction C.radius p).property).trans
+      ((SpecialPeriods.CuspGlobalOverlap.puncturedBiholomorph_cover C D hrcap hperiod p).trans
+        (familyMap_iteratedCover_eq_vectorCover C D hrcap hperiod p))
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.cuspToRegularPartial_flow
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (hperiod :
+      ∀ s : SpecialPeriods.CuspFamily.LogBase C.radius,
+        D.periods.point (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap s) =
+          C.periods.point s)
+    (s : ℂ) (x : CuspQuotient.QuotientSpace C.correction C.radius)
+    (hx : CuspQuotient.projection C.correction C.radius x ≠ 0) :
+    letI :=
+      CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+        C.smallDrift
+    letI := D.chartedSpace (SpecialPeriods.CuspGlobalOverlap.familyCovering D)
+    SpecialPeriods.CuspGlobalOverlap.cuspToRegularPartial C D hrcap hperiod
+        (flow C.correction C.radius s x) =
+      SpecialPeriods.Threefold.VerticalAction.Triangle.flow D s
+        (SpecialPeriods.CuspGlobalOverlap.cuspToRegularPartial C D hrcap hperiod x) := by
+  let :=
+    CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+      C.smallDrift
+  let := D.chartedSpace (SpecialPeriods.CuspGlobalOverlap.familyCovering D)
+  obtain ⟨p, hp⟩ := CuspUniformization.puncturedCuspCover_surjective C.correction C.radius ⟨x, hx⟩
+  have he : CuspUniformization.totalCuspCover C.correction C.radius p = x :=
+    congrArg Subtype.val hp
+  rw [← he, flow_totalCuspCover, cuspToRegularPartial_totalCuspCover C D hrcap hperiod,
+    cuspToRegularPartial_totalCuspCover C D hrcap hperiod]
+  exact overlapVectorCover_logFlow C D hrcap s p
+
+private abbrev SpecialPeriods.Threefold.CuspGeometry.data : SpecialPeriods.CuspFamily.Data :=
+  SpecialPeriods.Threefold.CuspPiece.restrictedData SpecialPeriods.specialCuspData
+    SpecialPeriods.Threefold.specialBaseCover SpecialPeriods.Threefold.specialCuspRadius_le
+
+private abbrev SpecialPeriods.Threefold.CuspGeometry.LocalSpace :=
+  SpecialPeriods.Threefold.SpecialCuspPiece
+
+@[instance_reducible]
+private def SpecialPeriods.Threefold.CuspGeometry.nativeChartedSpace :
+    ChartedSpace (ToricCharts.CoordinateSpace 3) LocalSpace :=
+  SpecialPeriods.Threefold.CuspPiece.nativeChartedSpace SpecialPeriods.specialCuspData
+    SpecialPeriods.Threefold.specialBaseCover SpecialPeriods.Threefold.specialCuspRadius_le
+
+attribute [local instance] SpecialPeriods.Threefold.CuspGeometry.nativeChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.Threefold.specialCuspPieceChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.CuspGeometry.parameter : LocalSpace → ℂ :=
+  CuspQuotient.projection data.correction data.radius
+
+attribute [local instance] SpecialPeriods.Threefold.CuspGeometry.nativeChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace SpecialPeriods.Threefold.chartedSpace in
+private def SpecialPeriods.Threefold.VerticalAction.Cusp.specialFlow (s : ℂ) :
+    SpecialPeriods.Threefold.CuspGeometry.LocalSpace →
+      SpecialPeriods.Threefold.CuspGeometry.LocalSpace :=
+  flow ((SpecialPeriods.Threefold.CuspGeometry.data)).correction
+    ((SpecialPeriods.Threefold.CuspGeometry.data)).radius s
+
+attribute [local instance] SpecialPeriods.Threefold.CuspGeometry.nativeChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace SpecialPeriods.Threefold.chartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.specialFlow_zero
+    (x : SpecialPeriods.Threefold.CuspGeometry.LocalSpace) : specialFlow 0 x = x :=
+  flow_zero ((SpecialPeriods.Threefold.CuspGeometry.data)).correction
+    ((SpecialPeriods.Threefold.CuspGeometry.data)).radius x
+
+attribute [local instance] SpecialPeriods.Threefold.CuspGeometry.nativeChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.specialFlow_add (s t : ℂ)
+    (x : SpecialPeriods.Threefold.CuspGeometry.LocalSpace) :
+    specialFlow (s + t) x = specialFlow s (specialFlow t x) :=
+  flow_add ((SpecialPeriods.Threefold.CuspGeometry.data)).correction
+    ((SpecialPeriods.Threefold.CuspGeometry.data)).radius s t x
+
+attribute [local instance] SpecialPeriods.Threefold.CuspGeometry.nativeChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace SpecialPeriods.Threefold.chartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.specialFlow_int_cast (n : ℤ)
+    (x : SpecialPeriods.Threefold.CuspGeometry.LocalSpace) : specialFlow (n : ℂ) x = x :=
+  flow_int_cast ((SpecialPeriods.Threefold.CuspGeometry.data)).correction
+    ((SpecialPeriods.Threefold.CuspGeometry.data)).radius n x
+
+attribute [local instance] SpecialPeriods.Threefold.CuspGeometry.nativeChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace SpecialPeriods.Threefold.chartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.parameter_specialFlow (s : ℂ)
+    (x : SpecialPeriods.Threefold.CuspGeometry.LocalSpace) :
+    SpecialPeriods.Threefold.CuspGeometry.parameter (specialFlow s x) =
+      SpecialPeriods.Threefold.CuspGeometry.parameter x :=
+  projection_flow ((SpecialPeriods.Threefold.CuspGeometry.data)).correction
+    ((SpecialPeriods.Threefold.CuspGeometry.data)).radius s x
+
+attribute [local instance] SpecialPeriods.Threefold.CuspGeometry.nativeChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.specialFlow_joint_holomorphic :
+    ContMDiff
+      (((modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω
+      (fun p : SpecialPeriods.Threefold.CuspGeometry.LocalSpace × ℂ => specialFlow p.2 p.1) :=
+  flow_joint_holomorphic ((SpecialPeriods.Threefold.CuspGeometry.data)).correction
+    ((SpecialPeriods.Threefold.CuspGeometry.data)).radius
+    ((SpecialPeriods.Threefold.CuspGeometry.data)).radius_pos
+    ((SpecialPeriods.Threefold.CuspGeometry.data)).radius_lt_one
+    ((SpecialPeriods.Threefold.CuspGeometry.data)).holomorphic
+    ((SpecialPeriods.Threefold.CuspGeometry.data)).smallDrift
+
+attribute [local instance] SpecialPeriods.Threefold.CuspGeometry.nativeChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.specialFlow_joint_common_holomorphic :
+    ContMDiff (((modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω
+      (fun p : SpecialPeriods.Threefold.CuspGeometry.LocalSpace × ℂ => specialFlow p.2 p.1) := by
+  let e :
+    Diffeomorph (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      SpecialPeriods.Threefold.CuspGeometry.LocalSpace
+      SpecialPeriods.Threefold.CuspGeometry.LocalSpace ω :=
+    SpecialPeriods.Threefold.CuspPiece.nativeToCommon SpecialPeriods.specialCuspData
+      SpecialPeriods.Threefold.specialBaseCover SpecialPeriods.Threefold.specialCuspRadius_le
+  have he :
+    ContMDiff (((modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ))
+      (((modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))).prod (modelWithCornersSelf ℂ ℂ))
+      ω (fun p : SpecialPeriods.Threefold.CuspGeometry.LocalSpace × ℂ => (e.symm p.1, p.2)) :=
+    (e.symm.contMDiff.comp contMDiff_fst).prodMk contMDiff_snd
+  exact e.contMDiff.comp (specialFlow_joint_holomorphic.comp he)
+
+attribute [local instance] SpecialPeriods.Threefold.CuspGeometry.nativeChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace SpecialPeriods.Threefold.chartedSpace in
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Cusp.specialCuspPieceProjectionToBase_specialFlow
+    (s : ℂ) (x : SpecialPeriods.Threefold.CuspGeometry.LocalSpace) :
+    SpecialPeriods.Threefold.specialCuspPieceProjectionToBase (specialFlow s x) =
+      SpecialPeriods.Threefold.specialCuspPieceProjectionToBase x := by
+  change
+    SpecialPeriods.Threefold.CuspPiece.projectionToBase SpecialPeriods.specialCuspData
+        SpecialPeriods.Threefold.specialBaseCover (specialFlow s x) =
+      SpecialPeriods.Threefold.CuspPiece.projectionToBase SpecialPeriods.specialCuspData
+        SpecialPeriods.Threefold.specialBaseCover x
+  rw [SpecialPeriods.Threefold.CuspPiece.projectionToBase_apply,
+    SpecialPeriods.Threefold.CuspPiece.projectionToBase_apply]
+  exact congrArg _ (parameter_specialFlow s x)
+
+private abbrev SpecialPeriods.Threefold.VerticalAction.Regular.data :
+    PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint :=
+  PeriodFamily.regularData SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Regular.baseCovering :
+    IsQuotientCoveringMap data.baseQuotient SpecialPeriods.TriangleGroup :=
+  PeriodFamily.regularCovering SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+
+private def SpecialPeriods.Threefold.VerticalAction.Regular.flow (s : ℂ) :
+    SpecialPeriods.Threefold.SpecialRegularFamily →
+      SpecialPeriods.Threefold.SpecialRegularFamily :=
+  SpecialPeriods.Threefold.VerticalAction.Triangle.flow data s
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Regular.flow_projection (s : ℂ)
+    (x : SpecialPeriods.Threefold.SpecialRegularFamily) :
+    SpecialPeriods.Threefold.specialRegularFamilyProjectionToBase (flow s x) =
+      SpecialPeriods.Threefold.specialRegularFamilyProjectionToBase x := by
+  change
+    SpecialPeriods.Threefold.regularInclusion
+        (data.projection (SpecialPeriods.Threefold.VerticalAction.Triangle.flow data s x)) =
+      SpecialPeriods.Threefold.regularInclusion (data.projection x)
+  rw [SpecialPeriods.Threefold.VerticalAction.Triangle.flow_projection]
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Regular.flow_zero
+    (x : SpecialPeriods.Threefold.SpecialRegularFamily) : flow 0 x = x :=
+  SpecialPeriods.Threefold.VerticalAction.Triangle.flow_zero data x
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Regular.flow_add (s t : ℂ)
+    (x : SpecialPeriods.Threefold.SpecialRegularFamily) : flow (s + t) x = flow s (flow t x) :=
+  SpecialPeriods.Threefold.VerticalAction.Triangle.flow_add data s t x
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Regular.flow_int_cast (n : ℤ)
+    (x : SpecialPeriods.Threefold.SpecialRegularFamily) : flow (n : ℂ) x = x :=
+  SpecialPeriods.Threefold.VerticalAction.Triangle.flow_int_cast data n x
+
+attribute [local instance] SpecialPeriods.Threefold.specialRegularFamilyChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.Regular.jointFlow_holomorphic :
+    ContMDiff (((modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω
+      (fun x : SpecialPeriods.Threefold.SpecialRegularFamily × ℂ => flow x.2 x.1) :=
+  SpecialPeriods.Threefold.VerticalAction.Triangle.jointFlow_holomorphic data baseCovering
+
+attribute [local instance] SpecialPeriods.Threefold.specialCuspPieceChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.Cusp.specialCuspOverlap_specialFlow (s : ℂ)
+    (x : SpecialPeriods.Threefold.SpecialCuspPiece)
+    (hx : x ∈ SpecialPeriods.Threefold.specialCuspOverlap.source) :
+    SpecialPeriods.Threefold.specialCuspOverlap (specialFlow s x) =
+      SpecialPeriods.Threefold.VerticalAction.Regular.flow s
+        (SpecialPeriods.Threefold.specialCuspOverlap x) := by
+  have hp :=
+    SpecialPeriods.CuspGlobalOverlap.spherePeriod_agreement
+      SpecialPeriods.Triangle.triangleSphereUniformization
+      SpecialPeriods.Triangle.triangleSphereUniformization_cusp
+      SpecialPeriods.Triangle.triangleSphereUniformization_centerOne
+      SpecialPeriods.Triangle.triangleSphereUniformization_centerTwo
+      (SpecialPeriods.Threefold.specialBaseCover.radius Option.none)
+      (SpecialPeriods.Threefold.specialBaseCover.radius_pos Option.none)
+      SpecialPeriods.Threefold.specialCuspRadius_le
+      SpecialPeriods.Threefold.specialBaseCover_cusp_radius_bounds.2.2.le
+  have hn := (SpecialPeriods.Threefold.specialCuspNativeOverlap_source_iff x).mp hx.2
+  exact
+    cuspToRegularPartial_flow SpecialPeriods.Threefold.CuspGeometry.data
+      SpecialPeriods.Threefold.VerticalAction.Regular.data
+      SpecialPeriods.Threefold.specialBaseCover_cusp_radius_bounds.2.2.le hp s x hn
+
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Elliptic.linearMatrix_vector (j : Elliptic.Kind)
+    (p : PeriodDomain) (s : ℂ) :
+    Elliptic.linearMatrix j p *ᵥ SpecialPeriods.Threefold.VerticalAction.Period.vector s =
+      SpecialPeriods.Threefold.VerticalAction.Period.vector s := by
+  cases j <;> ext i <;> fin_cases i <;>
+    simp [Elliptic.linearMatrix, PeriodPoint.R₁, PeriodPoint.R₂,
+      SpecialPeriods.Threefold.VerticalAction.Period.vector, Matrix.mulVec, dotProduct,
+      Fin.sum_univ_two]
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Elliptic.complexLift_vectorFlow
+    {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j) (v : Lattice) (s : ℂ)
+    (x : SpecialPeriods.Disc × ComplexPlane₂) :
+    D.complexLift v (SpecialPeriods.Threefold.VerticalAction.Period.vectorFlow s x) =
+      SpecialPeriods.Threefold.VerticalAction.Period.vectorFlow s (D.complexLift v x) := by
+  apply Prod.ext
+  · rfl
+  · change
+      Elliptic.linearMatrix j (D.periods.point x.1) *ᵥ
+            (x.2 + SpecialPeriods.Threefold.VerticalAction.Period.vector s) +
+          _ =
+        (Elliptic.linearMatrix j (D.periods.point x.1) *ᵥ x.2 + _) +
+          SpecialPeriods.Threefold.VerticalAction.Period.vector s
+    rw [Matrix.mulVec_add, linearMatrix_vector]
+    abel
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Elliptic.periodFlow_permutation
+    {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j) (v : Lattice) (s : ℂ)
+    (x : D.TotalSpace) :
+    SpecialPeriods.Threefold.VerticalAction.Period.flow D.periods s (D.permutation v x) =
+      D.permutation v (SpecialPeriods.Threefold.VerticalAction.Period.flow D.periods s x) := by
+  obtain ⟨z, rfl⟩ := D.periods.quotientMap_surjective x
+  rw [← D.complexLift_quotientMap,
+    SpecialPeriods.Threefold.VerticalAction.Period.flow_quotientMap,
+    SpecialPeriods.Threefold.VerticalAction.Period.flow_quotientMap, ← D.complexLift_quotientMap,
+    complexLift_vectorFlow]
+
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Elliptic.periodFlow_action {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : j.matrix *ᵥ v = v) (s : ℂ)
+    (g : Elliptic.CyclicGroup j) (x : D.TotalSpace) :
+    letI := D.action v hv
+    SpecialPeriods.Threefold.VerticalAction.Period.flow D.periods s (g • x) =
+      g • SpecialPeriods.Threefold.VerticalAction.Period.flow D.periods s x := by
+  let := D.action v hv
+  have h :
+    Function.Semiconj (SpecialPeriods.Threefold.VerticalAction.Period.flow D.periods s)
+      (D.permutation v) (D.permutation v) :=
+    periodFlow_permutation D v s
+  change
+    SpecialPeriods.Threefold.VerticalAction.Period.flow D.periods s
+        ((D.permutation v ^ g.toAdd.val) x) =
+      (D.permutation v ^ g.toAdd.val)
+        (SpecialPeriods.Threefold.VerticalAction.Period.flow D.periods s x)
+  simp only [Equiv.Perm.coe_pow]
+  exact h.iterate_right g.toAdd.val x
+
+private def SpecialPeriods.Threefold.VerticalAction.Elliptic.flow {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (s : ℂ) :
+    D.Space v hv → D.Space v hv := by
+  let := D.action v hv.1
+  exact
+    Elliptic.FiniteQuotient.descend
+      (fun x =>
+        D.quotient v hv (SpecialPeriods.Threefold.VerticalAction.Period.flow D.periods s x))
+      (by
+        intro g x
+        rw [periodFlow_action D v hv.1 s g x, D.quotient_smul])
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Elliptic.flow_quotient {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (s : ℂ)
+    (x : D.TotalSpace) :
+    flow D v hv s (D.quotient v hv x) =
+      D.quotient v hv (SpecialPeriods.Threefold.VerticalAction.Period.flow D.periods s x) :=
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Elliptic.flow_projection {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (s : ℂ)
+    (x : D.Space v hv) : D.projection v hv (flow D v hv s x) = D.projection v hv x := by
+  obtain ⟨y, rfl⟩ := D.quotient_surjective v hv x
+  rw [flow_quotient, D.projection_quotient, D.projection_quotient]
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Elliptic.flow_zero {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v)
+    (x : D.Space v hv) : flow D v hv 0 x = x := by
+  obtain ⟨y, rfl⟩ := D.quotient_surjective v hv x
+  rw [flow_quotient, SpecialPeriods.Threefold.VerticalAction.Period.flow_zero]
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Elliptic.flow_add {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (s t : ℂ)
+    (x : D.Space v hv) : flow D v hv (s + t) x = flow D v hv s (flow D v hv t x) := by
+  obtain ⟨y, rfl⟩ := D.quotient_surjective v hv x
+  rw [flow_quotient, flow_quotient, flow_quotient,
+    SpecialPeriods.Threefold.VerticalAction.Period.flow_add]
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Elliptic.flow_int_cast {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (n : ℤ)
+    (x : D.Space v hv) : flow D v hv (n : ℂ) x = x := by
+  obtain ⟨y, rfl⟩ := D.quotient_surjective v hv x
+  rw [flow_quotient, SpecialPeriods.Threefold.VerticalAction.Period.flow_int_cast]
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Elliptic.quotient_isLocalDiffeomorph
+    {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j) (v : Lattice)
+    (hv : Elliptic.AdmissibleTwist j v) :
+    letI := D.periods.totalChartedSpace
+    letI := D.chartedSpace v hv
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω (D.quotient v hv) := by
+  let := D.periods.totalChartedSpace
+  let := D.periods.totalSpace_isManifold
+  let := D.action v hv.1
+  exact
+    CoveringQuotient.project_isLocalDiffeomorph (D.quotientCoveringMap v hv)
+      (D.action_holomorphic v hv.1)
+
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Elliptic.jointFlow_holomorphic {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) :
+    letI := D.chartedSpace v hv
+    ContMDiff (((modelWithCornersSelf ℂ Elliptic.FamilyModel)).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω
+      (fun x : D.Space v hv × ℂ => flow D v hv x.2 x.1) := by
+  let := D.periods.totalChartedSpace
+  let := D.chartedSpace v hv
+  have hq := CanonicalProduct.isLocalDiffeomorph_prodLine (quotient_isLocalDiffeomorph D v hv)
+  have hs : Function.Surjective (fun x : D.TotalSpace × ℂ => (D.quotient v hv x.1, x.2)) := by
+    rintro ⟨y, s⟩
+    obtain ⟨x, rfl⟩ := D.quotient_surjective v hv y
+    exact ⟨(x, s), rfl⟩
+  apply
+    contMDiff_of_comp_localDiffeomorph
+      (((modelWithCornersSelf ℂ Elliptic.FamilyModel)).prod (modelWithCornersSelf ℂ ℂ))
+      (((modelWithCornersSelf ℂ Elliptic.FamilyModel)).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) hq hs
+  change
+    ContMDiff (((modelWithCornersSelf ℂ Elliptic.FamilyModel)).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω
+      (fun x : D.TotalSpace × ℂ => flow D v hv x.2 (D.quotient v hv x.1))
+  simp_rw [flow_quotient]
+  exact
+    (D.quotient_holomorphic v hv).comp
+      (SpecialPeriods.Threefold.VerticalAction.Period.jointFlow_holomorphic D.periods)
+
+attribute [local instance] SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.HolomorphicForms.EllipticCover.rootDomain (j : Elliptic.Kind) :
+    TopologicalSpace.Opens SpecialPeriods.Disc :=
+  ⟨{z | ‖(z : ℂ) ^ j.order‖ < SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)},
+    isOpen_lt (continuous_subtype_val.pow j.order).norm continuous_const⟩
+
+attribute [local instance] SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private abbrev SpecialPeriods.Threefold.HolomorphicForms.EllipticCover.Root (j : Elliptic.Kind) :=
+  rootDomain j
+
+attribute [local instance] SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private abbrev SpecialPeriods.Threefold.HolomorphicForms.EllipticCover.Cover (j : Elliptic.Kind) :=
+  Root j × ComplexPlane₂
+
+attribute [local instance] SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+@[instance_reducible]
+private def SpecialPeriods.Threefold.HolomorphicForms.EllipticCover.coverChartedSpace
+    (j : Elliptic.Kind) : ChartedSpace Elliptic.FamilyModel (Cover j) :=
+  inferInstanceAs (ChartedSpace (ModelProd ℂ ComplexPlane₂) (Root j × ComplexPlane₂))
+
+attribute [local instance] SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+private def
+    SpecialPeriods.Threefold.VerticalAction.Elliptic.specialFullFlow (j : Elliptic.Kind) (s : ℂ) :
+    SpecialPeriods.EllipticFilling.SpecialFullFilling j →
+      SpecialPeriods.EllipticFilling.SpecialFullFilling j :=
+  flow (SpecialPeriods.EllipticFilling.specialLocalData j) j.twist
+    (Elliptic.mainTwist_admissible j) s
+
+attribute [local instance] SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Elliptic.specialFullFlow_quotient
+    (j : Elliptic.Kind) (s : ℂ)
+    (x : (SpecialPeriods.EllipticFilling.specialLocalData j).TotalSpace) :
+    specialFullFlow j s
+        ((SpecialPeriods.EllipticFilling.specialLocalData j).quotient j.twist
+          (Elliptic.mainTwist_admissible j) x) =
+      (SpecialPeriods.EllipticFilling.specialLocalData j).quotient j.twist
+        (Elliptic.mainTwist_admissible j)
+        (SpecialPeriods.Threefold.VerticalAction.Period.flow
+          (SpecialPeriods.EllipticFilling.specialLocalData j).periods s x) :=
+  rfl
+
+attribute [local instance] SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Elliptic.specialFullFlow_projection
+    (j : Elliptic.Kind) (s : ℂ) (x : SpecialPeriods.EllipticFilling.SpecialFullFilling j) :
+    SpecialPeriods.EllipticFilling.specialFullFillingProjection j (specialFullFlow j s x) =
+      SpecialPeriods.EllipticFilling.specialFullFillingProjection j x :=
+  flow_projection (SpecialPeriods.EllipticFilling.specialLocalData j) j.twist
+    (Elliptic.mainTwist_admissible j) s x
+
+attribute [local instance] SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.Elliptic.specialFullFlow_joint_holomorphic
+    (j : Elliptic.Kind) :
+    ContMDiff (((modelWithCornersSelf ℂ Elliptic.FamilyModel)).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω
+      (fun x : SpecialPeriods.EllipticFilling.SpecialFullFilling j × ℂ =>
+        specialFullFlow j x.2 x.1) :=
+  jointFlow_holomorphic (SpecialPeriods.EllipticFilling.specialLocalData j) j.twist
+    (Elliptic.mainTwist_admissible j)
+
+attribute [local instance] SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+private def SpecialPeriods.Threefold.VerticalAction.Elliptic.specialFlow (j : Elliptic.Kind) (s : ℂ)
+    (x : SpecialPeriods.Threefold.EllipticGeometry.LocalSpace j) :
+    SpecialPeriods.Threefold.EllipticGeometry.LocalSpace j :=
+  ⟨specialFullFlow j s x.val,
+    by
+    change
+      ‖(SpecialPeriods.EllipticFilling.specialFullFillingProjection j
+              (specialFullFlow j s x.val) :
+            ℂ)‖ <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)
+    rw [specialFullFlow_projection]
+    exact x.property⟩
+
+attribute [local instance] SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Elliptic.specialFlow_coe (j : Elliptic.Kind)
+    (s : ℂ) (x : SpecialPeriods.Threefold.EllipticGeometry.LocalSpace j) :
+    (specialFlow j s x : SpecialPeriods.EllipticFilling.SpecialFullFilling j) =
+      specialFullFlow j s x.val :=
+  rfl
+
+attribute [local instance] SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+@[simp]
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Elliptic.specialFlow_parameter (j : Elliptic.Kind)
+    (s : ℂ) (x : SpecialPeriods.Threefold.EllipticGeometry.LocalSpace j) :
+    SpecialPeriods.Threefold.EllipticGeometry.parameter j (specialFlow j s x) =
+      SpecialPeriods.Threefold.EllipticGeometry.parameter j x :=
+  congrArg (Subtype.val : SpecialPeriods.Disc → ℂ) (specialFullFlow_projection j s x.val)
+
+attribute [local instance] SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Elliptic.specialFlow_projectionToBase
+    (j : Elliptic.Kind) (s : ℂ) (x : SpecialPeriods.Threefold.EllipticGeometry.LocalSpace j) :
+    SpecialPeriods.Threefold.specialEllipticPieceProjectionToBase j (specialFlow j s x) =
+      SpecialPeriods.Threefold.specialEllipticPieceProjectionToBase j x := by
+  change
+    (SpecialPeriods.Threefold.punctureChart (Option.some j)).symm
+        (SpecialPeriods.Threefold.EllipticGeometry.parameter j (specialFlow j s x)) =
+      (SpecialPeriods.Threefold.punctureChart (Option.some j)).symm
+        (SpecialPeriods.Threefold.EllipticGeometry.parameter j x)
+  rw [specialFlow_parameter]
+
+attribute [local instance] SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.Elliptic.specialFlow_joint_holomorphic
+    (j : Elliptic.Kind) :
+    ContMDiff (((modelWithCornersSelf ℂ Elliptic.FamilyModel)).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω
+      (fun x : SpecialPeriods.Threefold.EllipticGeometry.LocalSpace j × ℂ =>
+        specialFlow j x.2 x.1) := by
+  have hi :
+    ContMDiff (((modelWithCornersSelf ℂ Elliptic.FamilyModel)).prod (modelWithCornersSelf ℂ ℂ))
+      (((modelWithCornersSelf ℂ Elliptic.FamilyModel)).prod (modelWithCornersSelf ℂ ℂ)) ω
+      (fun x : SpecialPeriods.Threefold.EllipticGeometry.LocalSpace j × ℂ =>
+        ((x.1 : SpecialPeriods.EllipticFilling.SpecialFullFilling j), x.2)) :=
+    (contMDiff_subtype_val.comp contMDiff_fst).prodMk contMDiff_snd
+  have h := (specialFullFlow_joint_holomorphic j).comp hi
+  intro x
+  have he :
+    ContMDiffAt (((modelWithCornersSelf ℂ Elliptic.FamilyModel)).prod (modelWithCornersSelf ℂ ℂ))
+        (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω
+        (fun y : SpecialPeriods.Threefold.EllipticGeometry.LocalSpace j × ℂ =>
+          (specialFlow j y.2 y.1 : SpecialPeriods.EllipticFilling.SpecialFullFilling j))
+        x ↔
+      ContMDiffAt
+        (((modelWithCornersSelf ℂ Elliptic.FamilyModel)).prod (modelWithCornersSelf ℂ ℂ))
+        (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω
+        (fun y : SpecialPeriods.Threefold.EllipticGeometry.LocalSpace j × ℂ =>
+          specialFlow j y.2 y.1)
+        x :=
+    ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+  exact he.mp (h x)
+
+attribute [local instance] SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+@[simp]
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Elliptic.specialFlow_zero (j : Elliptic.Kind)
+    (x : SpecialPeriods.Threefold.EllipticGeometry.LocalSpace j) : specialFlow j 0 x = x :=
+  Subtype.ext
+    (flow_zero (SpecialPeriods.EllipticFilling.specialLocalData j) j.twist
+      (Elliptic.mainTwist_admissible j) x.val)
+
+attribute [local instance] SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.Elliptic.specialFlow_add (j : Elliptic.Kind)
+    (s t : ℂ) (x : SpecialPeriods.Threefold.EllipticGeometry.LocalSpace j) :
+    specialFlow j (s + t) x = specialFlow j s (specialFlow j t x) :=
+  Subtype.ext
+    (flow_add (SpecialPeriods.EllipticFilling.specialLocalData j) j.twist
+      (Elliptic.mainTwist_admissible j) s t x.val)
+
+attribute [local instance] SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+@[simp]
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Elliptic.specialFlow_int_cast (j : Elliptic.Kind)
+    (n : ℤ) (x : SpecialPeriods.Threefold.EllipticGeometry.LocalSpace j) :
+    specialFlow j (n : ℂ) x = x :=
+  Subtype.ext
+    (flow_int_cast (SpecialPeriods.EllipticFilling.specialLocalData j) j.twist
+      (Elliptic.mainTwist_admissible j) n x.val)
+
+private def SpecialPeriods.Threefold.VerticalAction.Elliptic.Gauge.familyFlow
+    (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc) (s : ℂ)
+    (x : Elliptic.LogGauge.FamilyStar P) : Elliptic.LogGauge.FamilyStar P :=
+  ⟨SpecialPeriods.Threefold.VerticalAction.Period.flow P s x.val, x.property⟩
+
+private def SpecialPeriods.Threefold.VerticalAction.Elliptic.Gauge.coverFlow (s : ℂ)
+    (x : Elliptic.LogGauge.CoverStar) : Elliptic.LogGauge.CoverStar :=
+  ⟨SpecialPeriods.Threefold.VerticalAction.Period.vectorFlow s x.val, x.property⟩
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Elliptic.Gauge.familyFlow_project
+    (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc) (s : ℂ) (x : Elliptic.LogGauge.CoverStar) :
+    familyFlow P s (Elliptic.LogGauge.project P x) =
+      Elliptic.LogGauge.project P (coverFlow s x) :=
+  Subtype.ext (SpecialPeriods.Threefold.VerticalAction.Period.flow_quotientMap P s x.val)
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Elliptic.Gauge.gaugeLift_coverFlow
+    (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc) (v : Lattice) (a : ℂ → ℂ) (s : ℂ)
+    (x : Elliptic.LogGauge.CoverStar) :
+    Elliptic.LogGauge.gaugeLift P v a (coverFlow s x) =
+      coverFlow s (Elliptic.LogGauge.gaugeLift P v a x) := by
+  apply Subtype.ext
+  apply Prod.ext
+  · rfl
+  · change
+      (x.val.2 + SpecialPeriods.Threefold.VerticalAction.Period.vector s) +
+          a x.val.1 • Elliptic.LogGauge.periodVector P v x.val.1 =
+        (x.val.2 + a x.val.1 • Elliptic.LogGauge.periodVector P v x.val.1) +
+          SpecialPeriods.Threefold.VerticalAction.Period.vector s
+    exact add_right_comm _ _ _
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Elliptic.Gauge.gaugeMap_familyFlow
+    (P : HolomorphicPeriodMap ℂ SpecialPeriods.Disc) (v : Lattice) (s : ℂ)
+    (x : Elliptic.LogGauge.FamilyStar P) :
+    Elliptic.LogGauge.gaugeMap P v (familyFlow P s x) =
+      familyFlow P s (Elliptic.LogGauge.gaugeMap P v x) := by
+  obtain ⟨y, rfl⟩ := Elliptic.LogGauge.project_surjective P x
+  rw [familyFlow_project, Elliptic.LogGauge.gaugeMap_project, Elliptic.LogGauge.gaugeMap_project,
+    familyFlow_project, gaugeLift_coverFlow]
+
+private def
+    SpecialPeriods.Threefold.VerticalAction.Elliptic.Gauge.fillingStarFlow {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (v : Lattice) (hv : Elliptic.AdmissibleTwist j v) (s : ℂ)
+    (x : Elliptic.LogGauge.FillingStar D v hv) : Elliptic.LogGauge.FillingStar D v hv :=
+  ⟨SpecialPeriods.Threefold.VerticalAction.Elliptic.flow D v hv s x.val,
+    by
+    change
+      (D.projection v hv (SpecialPeriods.Threefold.VerticalAction.Elliptic.flow D v hv s x.val) :
+          ℂ) ≠
+        0
+    rw [SpecialPeriods.Threefold.VerticalAction.Elliptic.flow_projection]
+    exact x.property⟩
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Elliptic.Gauge.fillingStarFlow_project
+    {j : Elliptic.Kind} (D : Elliptic.Equivariant.Data j) (v : Lattice)
+    (hv : Elliptic.AdmissibleTwist j v) (s : ℂ) (x : Elliptic.LogGauge.FamilyStar D.periods) :
+    fillingStarFlow D v hv s (Elliptic.LogGauge.fillingStarProject D v hv x) =
+      Elliptic.LogGauge.fillingStarProject D v hv (familyFlow D.periods s x) :=
+  Subtype.ext (SpecialPeriods.Threefold.VerticalAction.Elliptic.flow_quotient D v hv s x.val)
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Elliptic.Gauge.localTotalMap_familyFlow
+    (P : HolomorphicPeriodMap ℂ ℍ) (j : Elliptic.Kind) (s : ℂ)
+    (x : Elliptic.LogGauge.FamilyStar (SpecialPeriods.EllipticFilling.localPeriods P j)) :
+    SpecialPeriods.EllipticFilling.localTotalMap P j
+        (familyFlow (SpecialPeriods.EllipticFilling.localPeriods P j) s x) =
+      SpecialPeriods.Threefold.VerticalAction.Period.flow (PeriodFamily.regularPeriods P) s
+        (SpecialPeriods.EllipticFilling.localTotalMap P j x) := by rfl
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Elliptic.Gauge.regularMap_familyFlow
+    (P : HolomorphicPeriodMap ℂ ℍ) (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (s : ℂ) (x : Elliptic.LogGauge.FamilyStar (SpecialPeriods.EllipticFilling.localPeriods P j)) :
+    SpecialPeriods.EllipticFilling.regularMap P j h₁ h₂
+        (familyFlow (SpecialPeriods.EllipticFilling.localPeriods P j) s x) =
+      SpecialPeriods.Threefold.VerticalAction.Triangle.flow (PeriodFamily.regularData P h₁ h₂) s
+        (SpecialPeriods.EllipticFilling.regularMap P j h₁ h₂ x) := by
+  change
+    (PeriodFamily.regularData P h₁ h₂).quotient
+        (SpecialPeriods.EllipticFilling.localTotalMap P j
+          (familyFlow (SpecialPeriods.EllipticFilling.localPeriods P j) s x)) =
+      SpecialPeriods.Threefold.VerticalAction.Triangle.flow (PeriodFamily.regularData P h₁ h₂) s
+        ((PeriodFamily.regularData P h₁ h₂).quotient
+          (SpecialPeriods.EllipticFilling.localTotalMap P j x))
+  rw [SpecialPeriods.Threefold.VerticalAction.Triangle.flow_quotient, localTotalMap_familyFlow]
+  rfl
+
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Elliptic.Gauge.puncturedFillingBiholomorph_project
+    (P : HolomorphicPeriodMap ℂ ℍ) (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (x : Elliptic.LogGauge.FamilyStar (SpecialPeriods.EllipticFilling.localPeriods P j)) :
+    (SpecialPeriods.EllipticFilling.puncturedFillingBiholomorph P j h₁ h₂
+          (Elliptic.LogGauge.fillingStarProject
+            (SpecialPeriods.EllipticFilling.localData P h₁ h₂ j) j.twist
+            (Elliptic.mainTwist_admissible j) x)).val =
+      SpecialPeriods.EllipticFilling.regularMap P j h₁ h₂
+        (Elliptic.LogGauge.gaugeMap (SpecialPeriods.EllipticFilling.localPeriods P j) j.twist
+          x) := by
+  change
+    (SpecialPeriods.EllipticFilling.tautologicalOverlapBiholomorph P j h₁ h₂
+          (Elliptic.LogGauge.fillingToTautologicalBiholomorph
+            (SpecialPeriods.EllipticFilling.localData P h₁ h₂ j) j.twist
+            (Elliptic.mainTwist_admissible j)
+            (Elliptic.LogGauge.fillingStarProject
+              (SpecialPeriods.EllipticFilling.localData P h₁ h₂ j) j.twist
+              (Elliptic.mainTwist_admissible j) x))).val =
+      _
+  rw [Elliptic.LogGauge.fillingToTautologicalBiholomorph_project]
+  exact
+    congrArg Subtype.val
+      (SpecialPeriods.EllipticFilling.tautologicalOverlapBiholomorph_project P j h₁ h₂
+        (Elliptic.LogGauge.gaugeMap (SpecialPeriods.EllipticFilling.localPeriods P j) j.twist x))
+
+private theorem
+  SpecialPeriods.Threefold.VerticalAction.Elliptic.Gauge.puncturedFillingBiholomorph_fillingStarFlow
+    (P : HolomorphicPeriodMap ℂ ℍ) (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (s : ℂ) (x : SpecialPeriods.EllipticFilling.MainFillingStar P j h₁ h₂) :
+    (SpecialPeriods.EllipticFilling.puncturedFillingBiholomorph P j h₁ h₂
+          (fillingStarFlow (SpecialPeriods.EllipticFilling.localData P h₁ h₂ j) j.twist
+            (Elliptic.mainTwist_admissible j) s x)).val =
+      SpecialPeriods.Threefold.VerticalAction.Triangle.flow (PeriodFamily.regularData P h₁ h₂) s
+        (SpecialPeriods.EllipticFilling.puncturedFillingBiholomorph P j h₁ h₂ x).val := by
+  obtain ⟨y, rfl⟩ :=
+    Elliptic.LogGauge.fillingStarProject_surjective
+      (SpecialPeriods.EllipticFilling.localData P h₁ h₂ j) j.twist
+      (Elliptic.mainTwist_admissible j) x
+  rw [fillingStarFlow_project, puncturedFillingBiholomorph_project,
+    puncturedFillingBiholomorph_project, SpecialPeriods.EllipticFilling.localData_periods,
+    gaugeMap_familyFlow, regularMap_familyFlow]
+
+attribute [local instance] SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.Elliptic.specialEllipticOverlap_specialFlow
+    (j : Elliptic.Kind) (s : ℂ) (x : SpecialPeriods.Threefold.EllipticGeometry.LocalSpace j)
+    (hx : x ∈ (SpecialPeriods.Threefold.specialEllipticOverlap j).source) :
+    SpecialPeriods.Threefold.specialEllipticOverlap j (specialFlow j s x) =
+      SpecialPeriods.Threefold.VerticalAction.Regular.flow s
+        (SpecialPeriods.Threefold.specialEllipticOverlap j x) := by
+  have hx0 : (SpecialPeriods.EllipticFilling.specialFullFillingProjection j x.val : ℂ) ≠ 0 :=
+    (SpecialPeriods.EllipticFilling.smallOverlap_mem_source SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+          SpecialPeriods.Threefold.specialBaseCover j x).mp
+      hx
+  have hs0 :
+    (SpecialPeriods.EllipticFilling.specialFullFillingProjection j (specialFlow j s x).val : ℂ) ≠
+      0 := by
+    rw [specialFlow_coe, specialFullFlow_projection]
+    exact hx0
+  change
+    SpecialPeriods.EllipticFilling.smallOverlap SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+        SpecialPeriods.Threefold.specialBaseCover j (specialFlow j s x) =
+      SpecialPeriods.Threefold.VerticalAction.Regular.flow s
+        (SpecialPeriods.EllipticFilling.smallOverlap SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+          SpecialPeriods.Threefold.specialBaseCover j x)
+  rw [SpecialPeriods.EllipticFilling.smallOverlap_apply_mainStar SpecialPeriods.specialPeriodMap
+      SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+      SpecialPeriods.Threefold.specialBaseCover j (specialFlow j s x) hs0,
+    SpecialPeriods.EllipticFilling.smallOverlap_apply_mainStar SpecialPeriods.specialPeriodMap
+      SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+      SpecialPeriods.Threefold.specialBaseCover j x hx0]
+  exact
+    Gauge.puncturedFillingBiholomorph_fillingStarFlow SpecialPeriods.specialPeriodMap j
+      SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂ s
+      ⟨x.val, hx0⟩
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+private def SpecialPeriods.Threefold.VerticalAction.localFlow :
+    (i : SpecialPeriods.Threefold.Index) →
+      ℂ → SpecialPeriods.Threefold.localPiece i → SpecialPeriods.Threefold.localPiece i
+  | none => Regular.flow
+  | some Option.none => Cusp.specialFlow
+  | some (Option.some j) => Elliptic.specialFlow j
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.localFlow_projection
+    (i : SpecialPeriods.Threefold.Index) (s : ℂ) (x : SpecialPeriods.Threefold.localPiece i) :
+    SpecialPeriods.Threefold.localProjectionToBase i (localFlow i s x) =
+      SpecialPeriods.Threefold.localProjectionToBase i x := by
+  cases i with
+  | none => exact Regular.flow_projection s x
+  | some i =>
+    cases i with
+    | none => exact Cusp.specialCuspPieceProjectionToBase_specialFlow s x
+    | some j => exact Elliptic.specialFlow_projectionToBase j s x
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.localFlow_overlap
+    (i : SpecialPeriods.Threefold.Puncture) (s : ℂ)
+    (x : SpecialPeriods.Threefold.localPiece (Option.some i))
+    (hx : x ∈ (SpecialPeriods.Threefold.localOverlap i).source) :
+    SpecialPeriods.Threefold.localOverlap i (localFlow (Option.some i) s x) =
+      localFlow Option.none s (SpecialPeriods.Threefold.localOverlap i x) := by
+  cases i with
+  | none => exact Cusp.specialCuspOverlap_specialFlow s x hx
+  | some j => exact Elliptic.specialEllipticOverlap_specialFlow j s x hx
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.localFlow_zero
+    (i : SpecialPeriods.Threefold.Index) (x : SpecialPeriods.Threefold.localPiece i) :
+    localFlow i 0 x = x := by
+  cases i with
+  | none => exact Regular.flow_zero x
+  | some i =>
+    cases i with
+    | none => exact Cusp.specialFlow_zero x
+    | some j => exact Elliptic.specialFlow_zero j x
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.localFlow_add (i : SpecialPeriods.Threefold.Index)
+    (s t : ℂ) (x : SpecialPeriods.Threefold.localPiece i) :
+    localFlow i (s + t) x = localFlow i s (localFlow i t x) := by
+  cases i with
+  | none => exact Regular.flow_add s t x
+  | some i =>
+    cases i with
+    | none => exact Cusp.specialFlow_add s t x
+    | some j => exact Elliptic.specialFlow_add j s t x
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.localFlow_int_cast
+    (i : SpecialPeriods.Threefold.Index) (n : ℤ) (x : SpecialPeriods.Threefold.localPiece i) :
+    localFlow i (n : ℂ) x = x := by
+  cases i with
+  | none => exact Regular.flow_int_cast n x
+  | some i =>
+    cases i with
+    | none => exact Cusp.specialFlow_int_cast n x
+    | some j => exact Elliptic.specialFlow_int_cast j n x
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.localFlow_joint_holomorphic
+    (i : SpecialPeriods.Threefold.Index) :
+    ContMDiff (((modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω
+      (fun p : SpecialPeriods.Threefold.localPiece i × ℂ => localFlow i p.2 p.1) := by
+  cases i with
+  | none => exact Regular.jointFlow_holomorphic
+  | some i =>
+    cases i with
+    | none => exact Cusp.specialFlow_joint_common_holomorphic
+    | some j => exact Elliptic.specialFlow_joint_holomorphic j
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+private def SpecialPeriods.Threefold.VerticalAction.flow (s : ℂ) :
+    SpecialPeriods.Threefold.Space → SpecialPeriods.Threefold.Space :=
+  Gluing.glue localFlow localFlow_projection localFlow_overlap s
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.flow_inclusion (s : ℂ)
+    (i : SpecialPeriods.Threefold.Index) (x : SpecialPeriods.Threefold.localPiece i) :
+    flow s (SpecialPeriods.Threefold.inclusion i x) =
+      SpecialPeriods.Threefold.inclusion i (localFlow i s x) :=
+  Gluing.glue_inclusion localFlow localFlow_projection localFlow_overlap s i x
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.flow_elliptic (j : Elliptic.Kind) (s : ℂ)
+    (x : SpecialPeriods.Threefold.EllipticGeometry.LocalSpace j) :
+    flow s (SpecialPeriods.Threefold.EllipticGeometry.inclusion j x) =
+      SpecialPeriods.Threefold.EllipticGeometry.inclusion j (Elliptic.specialFlow j s x) :=
+  flow_inclusion s (Option.some (Option.some j)) x
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+@[simp]
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.flow_zero (x : SpecialPeriods.Threefold.Space) :
+    flow 0 x = x :=
+  Gluing.glue_zero localFlow localFlow_projection localFlow_overlap localFlow_zero x
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.flow_add (s t : ℂ)
+    (x : SpecialPeriods.Threefold.Space) : flow (s + t) x = flow s (flow t x) :=
+  Gluing.glue_add localFlow localFlow_projection localFlow_overlap localFlow_add s t x
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.flow_int_cast (n : ℤ)
+    (x : SpecialPeriods.Threefold.Space) : flow (n : ℂ) x = x :=
+  Gluing.glue_int_cast localFlow localFlow_projection localFlow_overlap localFlow_int_cast n x
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.projection_flow (s : ℂ)
+    (x : SpecialPeriods.Threefold.Space) :
+    SpecialPeriods.Threefold.projection (flow s x) = SpecialPeriods.Threefold.projection x :=
+  Gluing.glue_projection localFlow localFlow_projection localFlow_overlap s x
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.projectionSphere_flow (s : ℂ)
+    (x : SpecialPeriods.Threefold.Space) :
+    SpecialPeriods.Threefold.projectionSphere (flow s x) =
+      SpecialPeriods.Threefold.projectionSphere x := by
+  simp only [SpecialPeriods.Threefold.projectionSphere, Function.comp_def, projection_flow]
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.jointFlow_holomorphic :
+    ContMDiff (((modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω
+      (fun p : SpecialPeriods.Threefold.Space × ℂ => flow p.2 p.1) :=
+  Gluing.glue_joint_holomorphic localFlow localFlow_projection localFlow_overlap
+    localFlow_joint_holomorphic
+
+private def
+    SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential (s : ℂ) : ℂˣ :=
+  Units.mk0 (CuspUniformization.exponential s) (CuspUniformization.exponential_ne_zero s)
+
+@[simp]
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential_coe (s : ℂ) :
+    (normalizedExponential s : ℂ) = CuspUniformization.exponential s :=
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential_zero :
+    normalizedExponential 0 = 1 := by
+  apply Units.ext
+  exact CuspUniformization.exponential_zero
+
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential_add (s t : ℂ) :
+    normalizedExponential (s + t) = normalizedExponential s * normalizedExponential t := by
+  apply Units.ext
+  exact CuspUniformization.exponential_add s t
+
+@[simp]
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential_int (n : ℤ) :
+    normalizedExponential (n : ℂ) = 1 := by
+  apply Units.ext
+  exact CuspUniformization.exponential_int n
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential_eq_iff
+    (s t : ℂ) : normalizedExponential s = normalizedExponential t ↔ ∃ n : ℤ, s = t + n := by
+  rw [← Units.val_inj, normalizedExponential_coe, normalizedExponential_coe]
+  exact CuspUniformization.exponential_eq_iff s t
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential_eq_one_iff
+    (s : ℂ) : normalizedExponential s = 1 ↔ ∃ n : ℤ, s = (n : ℂ) := by
+  simpa using normalizedExponential_eq_iff s 0
+
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential_surjective :
+    Function.Surjective normalizedExponential := by
+  intro u
+  refine ⟨CuspUniformization.logarithm (u : ℂ), ?_⟩
+  apply Units.ext
+  exact CuspUniformization.exponential_logarithm u.ne_zero
+
+private def SpecialPeriods.Threefold.VerticalAction.Exponential.integerPeriods : AddSubgroup ℂ :=
+  AddSubgroup.zmultiples (1 : ℂ)
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Exponential.mem_integerPeriods_iff (s : ℂ) :
+    s ∈ integerPeriods ↔ ∃ n : ℤ, s = (n : ℂ) := by
+  simp only [integerPeriods, AddSubgroup.mem_zmultiples_iff, zsmul_one, eq_comm]
+
+private def SpecialPeriods.Threefold.VerticalAction.Exponential.Parameter :=
+  ℂ ⧸ integerPeriods
+
+private instance SpecialPeriods.Threefold.VerticalAction.Exponential.instLocal1 :
+    AddCommGroup Parameter :=
+  inferInstanceAs (AddCommGroup (ℂ ⧸ integerPeriods))
+
+private def
+    SpecialPeriods.Threefold.VerticalAction.Exponential.parameterProjection : ℂ →+ Parameter :=
+  QuotientAddGroup.mk' integerPeriods
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Exponential.parameterProjection_surjective :
+    Function.Surjective parameterProjection :=
+  QuotientAddGroup.mk'_surjective integerPeriods
+
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Exponential.parameterProjection_eq_iff (s t : ℂ) :
+    parameterProjection s = parameterProjection t ↔ ∃ n : ℤ, s - t = (n : ℂ) :=
+  QuotientAddGroup.eq_iff_sub_mem.trans (mem_integerPeriods_iff (s - t))
+
+private def SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponentialAddHom :
+    ℂ →+ Additive ℂˣ
+    where
+  toFun s := Additive.ofMul (normalizedExponential s)
+  map_zero' := normalizedExponential_zero
+  map_add' := normalizedExponential_add
+
+private def SpecialPeriods.Threefold.VerticalAction.Exponential.parameterExponentialAddHom :
+    Parameter →+ Additive ℂˣ :=
+  QuotientAddGroup.lift integerPeriods normalizedExponentialAddHom
+    (by
+      intro s hs
+      change normalizedExponential s = 1
+      exact (normalizedExponential_eq_one_iff s).mpr ((mem_integerPeriods_iff s).mp hs))
+
+private def
+    SpecialPeriods.Threefold.VerticalAction.Exponential.parameterExponential (p : Parameter) :
+    ℂˣ :=
+  Additive.toMul (parameterExponentialAddHom p)
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Exponential.parameterExponential_projection
+    (s : ℂ) : parameterExponential (parameterProjection s) = normalizedExponential s :=
+  rfl
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Exponential.parameterExponential_injective :
+    Function.Injective parameterExponential := by
+  intro p q h
+  obtain ⟨s, rfl⟩ := parameterProjection_surjective p
+  obtain ⟨t, rfl⟩ := parameterProjection_surjective q
+  rw [parameterExponential_projection, parameterExponential_projection] at h
+  obtain ⟨n, hn⟩ := (normalizedExponential_eq_iff s t).mp h
+  apply (parameterProjection_eq_iff s t).mpr
+  exact ⟨n, by simp [hn]⟩
+
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Exponential.parameterExponential_surjective :
+    Function.Surjective parameterExponential := by
+  intro u
+  obtain ⟨s, hs⟩ := normalizedExponential_surjective u
+  exact ⟨parameterProjection s, hs⟩
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Exponential.parameterExponential_bijective :
+    Function.Bijective parameterExponential :=
+  ⟨parameterExponential_injective, parameterExponential_surjective⟩
+
+private def SpecialPeriods.Threefold.VerticalAction.Exponential.parameterMulEquiv :
+    Multiplicative Parameter ≃* ℂˣ :=
+  MulEquiv.ofBijective parameterExponentialAddHom.toMultiplicativeLeft
+    parameterExponential_bijective
+
+@[simp]
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Exponential.parameterMulEquiv_projection (s : ℂ) :
+    parameterMulEquiv (Multiplicative.ofAdd (parameterProjection s)) = normalizedExponential s :=
+  rfl
+
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential_holomorphic :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω normalizedExponential := by
+  apply ContMDiff.of_comp_isOpenEmbedding Units.isOpenEmbedding_val
+  exact CuspUniformization.exponential_holomorphic.contMDiff
+
+private def SpecialPeriods.Threefold.VerticalAction.Exponential.unitsExponentialChart (s : ℂ) :
+    PartialDiffeomorph 𝓘(ℂ) 𝓘(ℂ) ℂ ℂˣ ω
+    where
+  toFun := normalizedExponential
+  invFun := (SpecialPeriods.CuspFamily.scalarExponentialChart s).symm ∘ Units.val
+  source := (SpecialPeriods.CuspFamily.scalarExponentialChart s).source
+  target := Units.val ⁻¹' (SpecialPeriods.CuspFamily.scalarExponentialChart s).target
+  map_source' := by
+    intro t ht
+    exact (SpecialPeriods.CuspFamily.scalarExponentialChart s).map_source ht
+  map_target' := by
+    intro t ht
+    exact (SpecialPeriods.CuspFamily.scalarExponentialChart s).map_target ht
+  left_inv' := by
+    intro t ht
+    exact (SpecialPeriods.CuspFamily.scalarExponentialChart s).left_inv ht
+  right_inv' := by
+    intro t ht
+    apply Units.ext
+    exact (SpecialPeriods.CuspFamily.scalarExponentialChart s).right_inv ht
+  open_source := (SpecialPeriods.CuspFamily.scalarExponentialChart s).open_source
+  open_target :=
+    (SpecialPeriods.CuspFamily.scalarExponentialChart s).open_target.preimage Units.continuous_val
+  contMDiffOn_toFun := normalizedExponential_holomorphic.contMDiffOn
+  contMDiffOn_invFun :=
+    (SpecialPeriods.CuspFamily.scalarExponentialChart_symm_holomorphic s).contMDiffOn.comp
+      Units.contMDiff_val.contMDiffOn (fun _ ht => ht)
+
+private theorem
+  SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential_isLocalDiffeomorph :
+    IsLocalDiffeomorph 𝓘(ℂ) 𝓘(ℂ) ω normalizedExponential := by
+  intro s
+  exact
+    ⟨unitsExponentialChart s, SpecialPeriods.CuspFamily.scalarExponentialChart_mem_source s,
+      fun _ _ => rfl⟩
+
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential_continuous :
+    Continuous normalizedExponential :=
+  normalizedExponential_holomorphic.continuous
+
+private structure SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow (M : Type*) where
+  toFun : ℂ → M → M
+  zero_apply : ∀ x, toFun 0 x = x
+  add_apply : ∀ s t x, toFun (s + t) x = toFun s (toFun t x)
+  int_apply : ∀ (n : ℤ) x, toFun (n : ℂ) x = x
+
+private instance SpecialPeriods.Threefold.VerticalAction.Factor.instCoeFun1 {M : Type*} :
+    CoeFun (AdditiveFlow M) (fun _ => ℂ → M → M) :=
+  ⟨AdditiveFlow.toFun⟩
+
+private theorem
+  SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow.apply_eq_of_parameterProjection_eq
+    {M : Type*} (F : SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow M) {s t : ℂ}
+    (h :
+      SpecialPeriods.Threefold.VerticalAction.Exponential.parameterProjection s =
+        SpecialPeriods.Threefold.VerticalAction.Exponential.parameterProjection t)
+    (x : M) : F s x = F t x := by
+  obtain ⟨n, hn⟩ :=
+    (SpecialPeriods.Threefold.VerticalAction.Exponential.parameterProjection_eq_iff s t).mp h
+  have hs : s = t + (n : ℂ) := by linear_combination hn
+  rw [hs, F.add_apply, F.int_apply]
+
+private def SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow.parameterAct {M : Type*}
+    (F : SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow M)
+    (p : SpecialPeriods.Threefold.VerticalAction.Exponential.Parameter) (x : M) : M :=
+  Quotient.lift (fun s : ℂ => F s x)
+    (fun _ _ h => F.apply_eq_of_parameterProjection_eq (Quotient.sound h) x) p
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow.parameterAct_projection
+    {M : Type*} (F : SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow M) (s : ℂ)
+    (x : M) :
+    F.parameterAct (SpecialPeriods.Threefold.VerticalAction.Exponential.parameterProjection s) x =
+      F s x :=
+  rfl
+
+private def SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow.act {M : Type*}
+    (F : SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow M) (u : ℂˣ) (x : M) : M :=
+  F.parameterAct
+    (SpecialPeriods.Threefold.VerticalAction.Exponential.parameterMulEquiv.symm u).toAdd x
+
+@[simp]
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow.act_normalizedExponential
+    {M : Type*} (F : SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow M) (s : ℂ)
+    (x : M) :
+    F.act (SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential s) x =
+      F s x := by
+  have he :
+    SpecialPeriods.Threefold.VerticalAction.Exponential.parameterMulEquiv.symm
+        (SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential s) =
+      Multiplicative.ofAdd
+        (SpecialPeriods.Threefold.VerticalAction.Exponential.parameterProjection s) := by
+    apply SpecialPeriods.Threefold.VerticalAction.Exponential.parameterMulEquiv.injective
+    rw [SpecialPeriods.Threefold.VerticalAction.Exponential.parameterMulEquiv.apply_symm_apply,
+      SpecialPeriods.Threefold.VerticalAction.Exponential.parameterMulEquiv_projection]
+  rw [act, he]
+  exact F.parameterAct_projection s x
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow.act_one {M : Type*}
+    (F : SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow M) (x : M) : F.act 1 x = x :=
+  by
+  simpa only [SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential_zero,
+    F.zero_apply] using F.act_normalizedExponential 0 x
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow.act_mul {M : Type*}
+    (F : SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow M) (u v : ℂˣ) (x : M) :
+    F.act (u * v) x = F.act u (F.act v x) := by
+  obtain ⟨s, rfl⟩ :=
+    SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential_surjective u
+  obtain ⟨t, rfl⟩ :=
+    SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential_surjective v
+  rw [← SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential_add,
+    F.act_normalizedExponential, F.act_normalizedExponential, F.act_normalizedExponential,
+    F.add_apply]
+
+@[instance_reducible]
+private def SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow.action {M : Type*}
+    (F : SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow M) : MulAction ℂˣ M
+    where
+  smul := F.act
+  one_smul := F.act_one
+  mul_smul := F.act_mul
+
+@[simp]
+private theorem
+    SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow.action_normalizedExponential
+    {M : Type*} (F : SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow M) (s : ℂ)
+    (x : M) :
+    letI := F.action
+    SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential s • x = F s x :=
+  F.act_normalizedExponential s x
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow.act_inv_act {M : Type*}
+    (F : SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow M) (u : ℂˣ) (x : M) :
+    F.act u⁻¹ (F.act u x) = x := by rw [← F.act_mul, inv_mul_cancel, F.act_one]
+
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow.act_act_inv {M : Type*}
+    (F : SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow M) (u : ℂˣ) (x : M) :
+    F.act u (F.act u⁻¹ x) = x := by rw [← F.act_mul, mul_inv_cancel, F.act_one]
+
+private def SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow.equiv {M : Type*}
+    (F : SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow M) (u : ℂˣ) : M ≃ M
+    where
+  toFun := F.act u
+  invFun := F.act u⁻¹
+  left_inv := F.act_inv_act u
+  right_inv := F.act_act_inv u
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow.act_holomorphic
+    {E H M : Type*} [NormedAddCommGroup E] [NormedSpace ℂ E] [TopologicalSpace H]
+    [TopologicalSpace M] [ChartedSpace H M] {I : ModelWithCorners ℂ E H}
+    (F : SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow M)
+    (hF : ContMDiff (I.prod 𝓘(ℂ)) I ω (fun p : M × ℂ => F p.2 p.1)) :
+    ContMDiff (I.prod 𝓘(ℂ)) I ω (fun p : M × ℂˣ => F.act p.2 p.1) := by
+  intro p
+  obtain ⟨s, hs⟩ :=
+    SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential_surjective p.2
+  let e :=
+    SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential_isLocalDiffeomorph s
+  have hlog : ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω e.localInverse p.2 := by
+    simpa only [hs] using e.localInverse_contMDiffAt
+  have hpair :
+    ContMDiffAt (I.prod 𝓘(ℂ)) (I.prod 𝓘(ℂ)) ω (fun q : M × ℂˣ => (q.1, e.localInverse q.2)) p :=
+    contMDiffAt_fst.prodMk (hlog.comp p contMDiffAt_snd)
+  have hcomp : ContMDiffAt (I.prod 𝓘(ℂ)) I ω (fun q : M × ℂˣ => F (e.localInverse q.2) q.1) p :=
+    hF.contMDiffAt.comp p hpair
+  apply hcomp.congr_of_eventuallyEq
+  have he := e.localInverse_eventuallyEq_right
+  rw [hs] at he
+  filter_upwards [(continuous_snd.tendsto p).eventually he] with q hq
+  change
+    SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential
+        (e.localInverse q.2) =
+      q.2 at hq
+  exact
+    (congrArg (fun u => F.act u q.1) hq).symm.trans
+      (F.act_normalizedExponential (e.localInverse q.2) q.1)
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow.act_holomorphic_const
+    {E H M : Type*} [NormedAddCommGroup E] [NormedSpace ℂ E] [TopologicalSpace H]
+    [TopologicalSpace M] [ChartedSpace H M] {I : ModelWithCorners ℂ E H}
+    (F : SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow M)
+    (hF : ContMDiff (I.prod 𝓘(ℂ)) I ω (fun p : M × ℂ => F p.2 p.1)) (u : ℂˣ) :
+    ContMDiff I I ω (F.act u) :=
+  (F.act_holomorphic hF).comp (contMDiff_id.prodMk contMDiff_const)
+
+private theorem SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow.action_holomorphic
+    {E H M : Type*} [NormedAddCommGroup E] [NormedSpace ℂ E] [TopologicalSpace H]
+    [TopologicalSpace M] [ChartedSpace H M] {I : ModelWithCorners ℂ E H}
+    (F : SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow M)
+    (hF : ContMDiff (I.prod 𝓘(ℂ)) I ω (fun p : M × ℂ => F p.2 p.1)) :
+    letI := F.action
+    ContMDiff (I.prod 𝓘(ℂ)) I ω (fun p : M × ℂˣ => p.2 • p.1) :=
+  F.act_holomorphic hF
+
+private def SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow.biholomorph {E H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℂ E] [TopologicalSpace H] [TopologicalSpace M]
+    [ChartedSpace H M] (I : ModelWithCorners ℂ E H)
+    (F : SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow M)
+    (hF : ContMDiff (I.prod 𝓘(ℂ)) I ω (fun p : M × ℂ => F p.2 p.1)) (u : ℂˣ) :
+    Diffeomorph I I M M ω where
+  toEquiv := F.equiv u
+  contMDiff_toFun := F.act_holomorphic_const hF u
+  contMDiff_invFun := F.act_holomorphic_const hF u⁻¹
+
+private theorem
+  SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow.biholomorph_normalizedExponential
+    {M : Type*} (F : SpecialPeriods.Threefold.VerticalAction.Factor.AdditiveFlow M) {E H : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℂ E] [TopologicalSpace H] [TopologicalSpace M]
+    [ChartedSpace H M] {I : ModelWithCorners ℂ E H}
+    (hF : ContMDiff (I.prod 𝓘(ℂ)) I ω (fun p : M × ℂ => F p.2 p.1)) (s : ℂ) (x : M) :
+    F.biholomorph I hF
+        (SpecialPeriods.Threefold.VerticalAction.Exponential.normalizedExponential s) x =
+      F s x :=
+  F.act_normalizedExponential s x
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+private def SpecialPeriods.Threefold.VerticalAction.additiveFlow :
+    Factor.AdditiveFlow SpecialPeriods.Threefold.Space
+    where
+  toFun := flow
+  zero_apply := flow_zero
+  add_apply := flow_add
+  int_apply := flow_int_cast
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+@[instance_reducible]
+private def SpecialPeriods.Threefold.VerticalAction.action :
+    MulAction ℂˣ SpecialPeriods.Threefold.Space :=
+  additiveFlow.action
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.action_normalizedExponential (s : ℂ)
+    (x : SpecialPeriods.Threefold.Space) :
+    letI := action
+    Exponential.normalizedExponential s • x = flow s x :=
+  additiveFlow.action_normalizedExponential s x
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.action_joint_holomorphic :
+    letI := action
+    ContMDiff (((modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω
+      (fun p : SpecialPeriods.Threefold.Space × ℂˣ => p.2 • p.1) :=
+  additiveFlow.action_holomorphic jointFlow_holomorphic
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.VerticalAction.action_holomorphic :
+    letI := action
+    ContMDiff (((modelWithCornersSelf ℂ ℂ)).prod (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω
+      (fun p : ℂˣ × SpecialPeriods.Threefold.Space => p.1 • p.2) := by
+  let := action
+  have hs :
+    ContMDiff (((modelWithCornersSelf ℂ ℂ)).prod (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)))
+      (((modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))).prod (modelWithCornersSelf ℂ ℂ)) ω
+      (fun p : ℂˣ × SpecialPeriods.Threefold.Space => (p.2, p.1)) :=
+    contMDiff_snd.prodMk contMDiff_fst
+  have hh := action_joint_holomorphic.comp hs
+  simpa only [Function.comp_def] using hh
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.projectionSphere_action (u : ℂˣ)
+    (x : SpecialPeriods.Threefold.Space) :
+    letI := action
+    SpecialPeriods.Threefold.projectionSphere (u • x) =
+      SpecialPeriods.Threefold.projectionSphere x := by
+  let := action
+  obtain ⟨s, rfl⟩ := Exponential.normalizedExponential_surjective u
+  rw [action_normalizedExponential, projectionSphere_flow]
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+private def SpecialPeriods.Threefold.VerticalAction.actionBiholomorph (u : ℂˣ) :
+    Diffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) SpecialPeriods.Threefold.Space
+      SpecialPeriods.Threefold.Space ω :=
+  additiveFlow.biholomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) jointFlow_holomorphic u
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.VerticalAction.actionBiholomorph_exponential (s : ℂ)
+    (x : SpecialPeriods.Threefold.Space) :
+    actionBiholomorph (Exponential.normalizedExponential s) x = flow s x :=
+  additiveFlow.biholomorph_normalizedExponential jointFlow_holomorphic s x
+
+private theorem SpecialPeriods.Threefold.FiniteActionFixed.Period.inverse_vector_real {V B : Type*}
+    [NormedAddCommGroup V] [NormedSpace ℂ V] [TopologicalSpace B] [ChartedSpace V B]
+    (P : HolomorphicPeriodMap V B) (b : B) (s : ℝ) :
+    (P.periodEquiv b).symm (SpecialPeriods.Threefold.VerticalAction.Period.vector (s : ℂ)) =
+      s • Pi.basisFun ℝ (Fin 4) 3 := by
+  apply (P.periodEquiv b).injective
+  rw [LinearEquiv.apply_symm_apply, map_smul,
+    SpecialPeriods.Threefold.VerticalAction.Period.periodEquiv_delta]
+  ext i
+  fin_cases i <;> simp [SpecialPeriods.Threefold.VerticalAction.Period.vector]
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Threefold/SpecialPeriods12.lean b/LeanPool/HopfProblem/Threefold/SpecialPeriods12.lean
new file mode 100644
index 000000000..e8f283514
--- /dev/null
+++ b/LeanPool/HopfProblem/Threefold/SpecialPeriods12.lean
@@ -0,0 +1,279 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.MainTheorem.SixSphereCube3
+public import LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology4
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology1
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz1
+import all LeanPool.HopfProblem.Hurewicz.SecondHurewicz
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods8
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods11
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology3
+import all LeanPool.HopfProblem.Hurewicz.HigherHurewicz1
+import all LeanPool.HopfProblem.Hurewicz.HigherHurewicz2
+import all LeanPool.HopfProblem.MainTheorem.SixSphereCube2
+import all LeanPool.HopfProblem.Hurewicz.SixthHurewicz
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldHomology4
+import all LeanPool.HopfProblem.MainTheorem.SixSphereCube3
+
+/-!
+# Hopf problem: threefold · special periods 12
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem SpecialPeriods.Threefold.HomotopyTwo.piTwo_subsingleton
+    (x : SpecialPeriods.Threefold.Space) : Subsingleton (π_ 2 SpecialPeriods.Threefold.Space x) :=
+  by
+  have := SpecialPeriods.Threefold.space_simplyConnected
+  have := ThreefoldHomology.SecondDegree.homologyTwo_subsingleton
+  exact (SecondHurewicz.SimplyConnected.hurewiczPi2Equiv x).injective.subsingleton
+
+private theorem SpecialPeriods.Threefold.HomotopyThree.piThree_subsingleton
+    (x : SpecialPeriods.Threefold.Space) : Subsingleton (π_ 3 SpecialPeriods.Threefold.Space x) :=
+  by
+  have := SpecialPeriods.Threefold.space_simplyConnected
+  have := SpecialPeriods.Threefold.HomotopyTwo.piTwo_subsingleton x
+  have := ThreefoldHomology.ThirdDegree.homologyThree_subsingleton
+  exact (ThirdHurewicz.hurewiczPi3Equiv x).injective.subsingleton
+
+private theorem SpecialPeriods.Threefold.HomotopyFour.piFour_subsingleton
+    (x : SpecialPeriods.Threefold.Space) : Subsingleton (π_ 4 SpecialPeriods.Threefold.Space x) :=
+  by
+  have := SpecialPeriods.Threefold.space_simplyConnected
+  have := SpecialPeriods.Threefold.HomotopyTwo.piTwo_subsingleton x
+  have := SpecialPeriods.Threefold.HomotopyThree.piThree_subsingleton x
+  have := ThreefoldHomology.FourthDegree.homologyFour_subsingleton
+  exact (FourthHurewicz.hurewiczPi4Equiv x).injective.subsingleton
+
+private theorem SpecialPeriods.Threefold.HomotopyFive.piFive_subsingleton
+    (x : SpecialPeriods.Threefold.Space) : Subsingleton (π_ 5 SpecialPeriods.Threefold.Space x) :=
+  by
+  have := SpecialPeriods.Threefold.space_simplyConnected
+  have := SpecialPeriods.Threefold.HomotopyTwo.piTwo_subsingleton x
+  have := SpecialPeriods.Threefold.HomotopyThree.piThree_subsingleton x
+  have := SpecialPeriods.Threefold.HomotopyFour.piFour_subsingleton x
+  have := ThreefoldHomology.FifthDegree.homologyFive_subsingleton
+  exact (FifthHurewicz.hurewiczPi5Equiv x).injective.subsingleton
+
+private def
+    SpecialPeriods.Threefold.HomotopySix.hurewiczEquiv (x : SpecialPeriods.Threefold.Space) :
+    Additive (π_ 6 SpecialPeriods.Threefold.Space x) ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 6 := by
+  letI := SpecialPeriods.Threefold.space_simplyConnected
+  letI := SpecialPeriods.Threefold.HomotopyTwo.piTwo_subsingleton x
+  letI := SpecialPeriods.Threefold.HomotopyThree.piThree_subsingleton x
+  letI := SpecialPeriods.Threefold.HomotopyFour.piFour_subsingleton x
+  letI := SpecialPeriods.Threefold.HomotopyFive.piFive_subsingleton x
+  exact SixthHurewicz.hurewiczLinearEquiv x
+
+@[simp]
+private theorem
+    SpecialPeriods.Threefold.HomotopySix.hurewiczEquiv_mk (x : SpecialPeriods.Threefold.Space)
+    (p : GenLoop (Fin 6) SpecialPeriods.Threefold.Space x) :
+    hurewiczEquiv x (Additive.ofMul (⟦p⟧ : π_ 6 SpecialPeriods.Threefold.Space x)) =
+      SixthHurewicz.cubeHomologyClass p :=
+  rfl
+
+private def SpecialPeriods.Threefold.HomotopySix.piSixEquiv (x : SpecialPeriods.Threefold.Space) :
+    Additive (π_ 6 SpecialPeriods.Threefold.Space x) ≃ₗ[ℤ] ℤ :=
+  (hurewiczEquiv x).trans ThreefoldHomology.TopDegree.homologySixEquiv
+
+private def SpecialPeriods.Threefold.HomotopySix.generator (x : SpecialPeriods.Threefold.Space) :
+    Additive (π_ 6 SpecialPeriods.Threefold.Space x) :=
+  (hurewiczEquiv x).symm ThreefoldHomology.TopDegree.topClass
+
+@[simp]
+private theorem SpecialPeriods.Threefold.HomotopySix.hurewiczEquiv_generator
+    (x : SpecialPeriods.Threefold.Space) :
+    hurewiczEquiv x (generator x) = ThreefoldHomology.TopDegree.topClass :=
+  (hurewiczEquiv x).apply_symm_apply _
+
+private theorem SpecialPeriods.Threefold.HomotopySix.exists_cube_topClass
+    (x : SpecialPeriods.Threefold.Space) :
+    ∃ p : GenLoop (Fin 6) SpecialPeriods.Threefold.Space x,
+      SixthHurewicz.cubeHomologyClass p = ThreefoldHomology.TopDegree.topClass := by
+  obtain ⟨p, hp⟩ := Quotient.exists_rep (Additive.toMul (generator x))
+  have hclass : Additive.ofMul (⟦p⟧ : π_ 6 SpecialPeriods.Threefold.Space x) = generator x :=
+    congrArg Additive.ofMul hp
+  exact
+    ⟨p,
+      (hurewiczEquiv_mk x p).symm.trans
+        ((congrArg (hurewiczEquiv x) hclass).trans (hurewiczEquiv_generator x))⟩
+
+private def
+    SpecialPeriods.Threefold.HomotopySix.generatingCube (x : SpecialPeriods.Threefold.Space) :
+    GenLoop (Fin 6) SpecialPeriods.Threefold.Space x :=
+  Classical.choose (exists_cube_topClass x)
+
+@[simp]
+private theorem SpecialPeriods.Threefold.HomotopySix.generatingCube_homologyClass
+    (x : SpecialPeriods.Threefold.Space) :
+    SixthHurewicz.cubeHomologyClass (generatingCube x) = ThreefoldHomology.TopDegree.topClass :=
+  Classical.choose_spec (exists_cube_topClass x)
+
+@[instance_reducible]
+private def ManifoldAtlasTransport.chartedSpace {H M N : Type*} [TopologicalSpace H] [Nonempty H]
+    [TopologicalSpace M] [TopologicalSpace N] [ChartedSpace H M] (h : M ≃ₜ N) : ChartedSpace H N
+    where
+  atlas :=
+    (fun e : OpenPartialHomeomorph M H => e.lift_openEmbedding h.isOpenEmbedding) '' atlas H M
+  chartAt y := (chartAt H (h.symm y)).lift_openEmbedding h.isOpenEmbedding
+  mem_chart_source y := ⟨h.symm y, mem_chart_source H (h.symm y), h.apply_symm_apply y⟩
+  chart_mem_atlas y := ⟨chartAt H (h.symm y), chart_mem_atlas H (h.symm y), rfl⟩
+
+public
+theorem
+    ManifoldAtlasTransport.transition_eq {H M N : Type*} [TopologicalSpace H] [Nonempty H]
+    [TopologicalSpace M] [TopologicalSpace N] (h : M ≃ₜ N) (e e' : OpenPartialHomeomorph M H) :
+    (e.lift_openEmbedding h.isOpenEmbedding).symm.trans
+        (e'.lift_openEmbedding h.isOpenEmbedding) =
+      e.symm.trans e' :=
+  e.lift_openEmbedding_trans e' h.isOpenEmbedding
+
+private theorem ManifoldAtlasTransport.isManifold {H M N : Type*} [TopologicalSpace H] [Nonempty H]
+    [TopologicalSpace M] [TopologicalSpace N] [ChartedSpace H M] {𝕜 E : Type*}
+    [NontriviallyNormedField 𝕜] [NormedAddCommGroup E] [NormedSpace 𝕜 E]
+    (I : ModelWithCorners 𝕜 E H) (n : ℕ∞ω) (h : M ≃ₜ N) [IsManifold I n M] :
+    letI := chartedSpace (H := H) h
+    IsManifold I n N := by
+  let := chartedSpace (H := H) h
+  refine { compatible := ?_ }
+  rintro _ _ ⟨e, he, rfl⟩ ⟨e', he', rfl⟩
+  rw [transition_eq]
+  exact (contDiffGroupoid n I).compatible he he'
+
+private theorem SpecialPeriods.Threefold.HomologySphere.homology_subsingleton (n : ℕ) (hn0 : n ≠ 0)
+    (hn6 : n ≠ 6) :
+    Subsingleton (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space n) := by
+  by_cases hn : 6 < n
+  · exact ThreefoldHomology.Finiteness.homology_subsingleton_of_lt hn
+  have hn' : n ≤ 6 := Nat.le_of_not_gt hn
+  interval_cases n
+  · exact (hn0 rfl).elim
+  · exact SpecialPeriods.Threefold.LowDegrees.singularH1_subsingleton
+  · exact ThreefoldHomology.SecondDegree.homologyTwo_subsingleton
+  · exact ThreefoldHomology.ThirdDegree.homologyThree_subsingleton
+  · exact ThreefoldHomology.FourthDegree.homologyFour_subsingleton
+  · exact ThreefoldHomology.FifthDegree.homologyFive_subsingleton
+  · exact (hn6 rfl).elim
+
+
+private def SpecialPeriods.Threefold.HomologySphere.homologySixEquivSixSphere :
+    SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 6 ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology SixSphere 6 :=
+  ThreefoldHomology.TopDegree.homologySixEquiv.trans SixSphereHomology.homologySixEquiv.symm
+
+private theorem SpecialPeriods.Threefold.SphereHomologyMap.six_surjective_of_topClass_preimage
+    (f : C(SixSphere, SpecialPeriods.Threefold.Space))
+    (a : SingularMayerVietoris.SingularHomology SixSphere 6)
+    (ha :
+      SingularMayerVietoris.singularHomologyMap f 6 a = ThreefoldHomology.TopDegree.topClass) :
+    Function.Surjective (SingularMayerVietoris.singularHomologyMap f 6) := by
+  intro b
+  refine ⟨ThreefoldHomology.TopDegree.homologySixEquiv b • a, ?_⟩
+  rw [map_zsmul, ha]
+  exact (ThreefoldHomology.TopDegree.eq_smul_topClass b).symm
+
+private theorem SpecialPeriods.Threefold.SphereHomologyMap.six_bijective_of_topClass_preimage
+    (f : C(SixSphere, SpecialPeriods.Threefold.Space))
+    (a : SingularMayerVietoris.SingularHomology SixSphere 6)
+    (ha :
+      SingularMayerVietoris.singularHomologyMap f 6 a = ThreefoldHomology.TopDegree.topClass) :
+    Function.Bijective (SingularMayerVietoris.singularHomologyMap f 6) := by
+  let :
+    IsNoetherian ℤ (SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space 6) :=
+    isNoetherian_of_injective ThreefoldHomology.TopDegree.homologySixEquiv.toLinearMap
+      ThreefoldHomology.TopDegree.homologySixEquiv.injective
+  have hsurj := six_surjective_of_topClass_preimage f a ha
+  refine ⟨?_, hsurj⟩
+  exact
+    IsNoetherian.injective_of_surjective_of_injective
+      SpecialPeriods.Threefold.HomologySphere.homologySixEquivSixSphere.symm.toLinearMap
+      (SingularMayerVietoris.singularHomologyMap f 6)
+      SpecialPeriods.Threefold.HomologySphere.homologySixEquivSixSphere.symm.injective hsurj
+
+private theorem
+    SpecialPeriods.Threefold.SphereHomologyMap.homologyMap_bijective_of_topClass_preimage
+    (f : C(SixSphere, SpecialPeriods.Threefold.Space))
+    (a : SingularMayerVietoris.SingularHomology SixSphere 6)
+    (ha : SingularMayerVietoris.singularHomologyMap f 6 a = ThreefoldHomology.TopDegree.topClass)
+    (n : ℕ) : Function.Bijective (SingularMayerVietoris.singularHomologyMap f n) := by
+  by_cases hn0 : n = 0
+  · subst n
+    let := SpecialPeriods.Threefold.space_pathConnected
+    exact SphereHomology.singularHomologyMap_zero_bijective f
+  by_cases hn6 : n = 6
+  · subst n
+    exact six_bijective_of_topClass_preimage f a ha
+  let := SpecialPeriods.Threefold.HomologySphere.homology_subsingleton n hn0 hn6
+  let := SixSphereHomology.homology_subsingleton n hn0 hn6
+  exact ⟨Function.injective_of_subsingleton _, Function.surjective_to_subsingleton _⟩
+
+private def SpecialPeriods.Threefold.SphereHomologyMap.homologyEquivOfTopClassPreimage
+    (f : C(SixSphere, SpecialPeriods.Threefold.Space))
+    (a : SingularMayerVietoris.SingularHomology SixSphere 6)
+    (ha : SingularMayerVietoris.singularHomologyMap f 6 a = ThreefoldHomology.TopDegree.topClass)
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology SixSphere n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space n :=
+  LinearEquiv.ofBijective (SingularMayerVietoris.singularHomologyMap f n)
+    (homologyMap_bijective_of_topClass_preimage f a ha n)
+
+private def SpecialPeriods.Threefold.SphereHomologyEquivalence.sourceCubeClass :
+    SingularMayerVietoris.SingularHomology SixSphere 6 :=
+  SixthHurewicz.cubeHomologyClass SixSphereCube.cubeSphereLoop
+
+private def SpecialPeriods.Threefold.SphereHomologyEquivalence.sphereMap
+    (x : SpecialPeriods.Threefold.Space) : C(SixSphere, SpecialPeriods.Threefold.Space) :=
+  SixSphereCube.factorMap (SpecialPeriods.Threefold.HomotopySix.generatingCube x)
+
+@[simp]
+private theorem SpecialPeriods.Threefold.SphereHomologyEquivalence.sphereMap_sourceCubeClass
+    (x : SpecialPeriods.Threefold.Space) :
+    SingularMayerVietoris.singularHomologyMap (sphereMap x) 6 sourceCubeClass =
+      ThreefoldHomology.TopDegree.topClass :=
+  (SixSphereCube.factor_cubeHomologyClass
+        (SpecialPeriods.Threefold.HomotopySix.generatingCube x)).trans
+    (SpecialPeriods.Threefold.HomotopySix.generatingCube_homologyClass x)
+
+private theorem SpecialPeriods.Threefold.SphereHomologyEquivalence.homologyMap_bijective
+    (x : SpecialPeriods.Threefold.Space) (n : ℕ) :
+    Function.Bijective (SingularMayerVietoris.singularHomologyMap (sphereMap x) n) :=
+  SpecialPeriods.Threefold.SphereHomologyMap.homologyMap_bijective_of_topClass_preimage
+    (sphereMap x) sourceCubeClass (sphereMap_sourceCubeClass x) n
+
+private def SpecialPeriods.Threefold.SphereHomologyEquivalence.homologyEquiv
+    (x : SpecialPeriods.Threefold.Space) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology SixSphere n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology SpecialPeriods.Threefold.Space n :=
+  SpecialPeriods.Threefold.SphereHomologyMap.homologyEquivOfTopClassPreimage (sphereMap x)
+    sourceCubeClass (sphereMap_sourceCubeClass x) n
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Threefold/SpecialPeriods2.lean b/LeanPool/HopfProblem/Threefold/SpecialPeriods2.lean
new file mode 100644
index 000000000..67b1c2f12
--- /dev/null
+++ b/LeanPool/HopfProblem/Threefold/SpecialPeriods2.lean
@@ -0,0 +1,247 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Uniformization.CuspUniformization2
+public import LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization2
+
+/-!
+# Hopf problem: threefold · special periods 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem SpecialPeriods.CuspFamily.Data.totalPeriodQuotientMap_eq_of_familyCover_eq
+    (D : SpecialPeriods.CuspFamily.Data) {x y : CuspUniformization.LogCover D.radius}
+    (h : D.familyCover x = D.familyCover y) :
+    CuspUniformization.totalPeriodQuotientMap D.correction D.radius x =
+      CuspUniformization.totalPeriodQuotientMap D.correction D.radius y := by
+  obtain ⟨hs, m, n, hmn⟩ := (D.familyCover_eq_iff x y).mp h
+  apply (CuspUniformization.totalPeriodQuotientMap_eq_iff D.correction D.radius x y).mpr
+  exact ⟨0, m, n, by simpa only [Int.cast_zero, add_zero] using hs, hmn⟩
+
+private theorem
+    SpecialPeriods.CuspFamily.Data.iteratedCover_logDeck (D : SpecialPeriods.CuspFamily.Data)
+    (g : CuspUniformization.LogDeck) (x : CuspUniformization.LogCover D.radius) :
+    D.iteratedCover (CuspUniformization.logCoverTransform D.correction D.radius g x) =
+      D.iteratedCover x := by
+  let := D.totalAction
+  change
+    D.quotient (D.familyCover (CuspUniformization.logCoverTransform D.correction D.radius g x)) =
+      D.quotient (D.familyCover x)
+  rw [D.familyCover_logDeck, D.quotient_smul]
+
+public
+theorem
+    SpecialPeriods.CuspFamily.Data.iteratedCover_eq_iff (D : SpecialPeriods.CuspFamily.Data)
+    (x y : CuspUniformization.LogCover D.radius) :
+    D.iteratedCover x = D.iteratedCover y ↔
+      CuspUniformization.TotalPeriodRelated D.correction x y := by
+  let := D.totalAction
+  constructor
+  · intro h
+    obtain ⟨k, hk⟩ := (D.quotient_eq_iff (D.familyCover x) (D.familyCover y)).mp h
+    let z := CuspUniformization.logCoverTransform D.correction D.radius ⟨-k.toAdd, 0, 0⟩ y
+    have hz : D.familyCover z = k • D.familyCover y := by
+      simpa only [neg_neg, ofAdd_toAdd] using D.familyCover_logarithmicShift (-k.toAdd) y
+    have hxy := D.totalPeriodQuotientMap_eq_of_familyCover_eq (hk.symm.trans hz.symm)
+    have hzy :
+      CuspUniformization.totalPeriodQuotientMap D.correction D.radius z =
+        CuspUniformization.totalPeriodQuotientMap D.correction D.radius y := by
+      apply (CuspUniformization.totalPeriodQuotientMap_eq_iff D.correction D.radius z y).mpr
+      exact ⟨-k.toAdd, 0, 0, rfl, rfl⟩
+    exact
+      (CuspUniformization.totalPeriodQuotientMap_eq_iff D.correction D.radius x y).mp
+        (hxy.trans hzy)
+  · intro h
+    obtain ⟨g, hg⟩ :=
+      (CuspUniformization.totalPeriodRelated_iff_exists_logDeck D.correction x y).mp h
+    have he : CuspUniformization.logCoverTransform D.correction D.radius g y = x := Subtype.ext hg
+    rw [← he, D.iteratedCover_logDeck]
+
+private def SpecialPeriods.CuspFamily.Data.directToIterated (D : SpecialPeriods.CuspFamily.Data) :
+    CuspUniformization.TotalPeriodQuotient D.correction D.radius → D.Space :=
+  Quotient.lift D.iteratedCover (fun x y h => (D.iteratedCover_eq_iff x y).mpr h)
+
+private theorem SpecialPeriods.CuspFamily.Data.directToIterated_bijective
+    (D : SpecialPeriods.CuspFamily.Data) : Function.Bijective D.directToIterated := by
+  constructor
+  · intro x y
+    induction x using Quotient.inductionOn with
+    | h x =>
+      induction y using Quotient.inductionOn with
+      | h y =>
+        intro he
+        exact Quotient.sound ((D.iteratedCover_eq_iff x y).mp he)
+  · intro y
+    obtain ⟨x, rfl⟩ := D.iteratedCover_surjective y
+    exact ⟨CuspUniformization.totalPeriodQuotientMap D.correction D.radius x, rfl⟩
+
+private def
+    SpecialPeriods.CuspFamily.Data.directToIteratedEquiv (D : SpecialPeriods.CuspFamily.Data) :
+    CuspUniformization.TotalPeriodQuotient D.correction D.radius ≃ D.Space :=
+  Equiv.ofBijective D.directToIterated D.directToIterated_bijective
+
+@[simp]
+private theorem SpecialPeriods.CuspFamily.Data.directToIteratedEquiv_symm_iteratedCover
+    (D : SpecialPeriods.CuspFamily.Data) (x : CuspUniformization.LogCover D.radius) :
+    D.directToIteratedEquiv.symm (D.iteratedCover x) =
+      CuspUniformization.totalPeriodQuotientMap D.correction D.radius x :=
+  D.directToIteratedEquiv.symm_apply_apply
+    (CuspUniformization.totalPeriodQuotientMap D.correction D.radius x)
+
+private theorem SpecialPeriods.CuspFamily.Data.directToIterated_holomorphic
+    (D : SpecialPeriods.CuspFamily.Data) :
+    letI :=
+      CuspUniformization.totalPeriodQuotientChartedSpace D.correction D.radius D.radius_pos
+        D.radius_lt_one D.holomorphic D.smallDrift
+    letI := D.chartedSpace
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω D.directToIterated := by
+  let := CuspUniformization.logCoverAction D.correction D.radius
+  let :=
+    CuspUniformization.totalPeriodQuotientChartedSpace D.correction D.radius D.radius_pos
+      D.radius_lt_one D.holomorphic D.smallDrift
+  let := D.chartedSpace
+  apply
+    CoveringQuotient.contMDiff_of_comp
+      (CuspUniformization.totalPeriodQuotientMap_covering D.correction D.radius D.radius_pos
+        D.radius_lt_one D.holomorphic D.smallDrift)
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω
+  exact D.iteratedCover_holomorphic
+
+private theorem SpecialPeriods.CuspFamily.Data.directToIteratedEquiv_symm_holomorphic
+    (D : SpecialPeriods.CuspFamily.Data) :
+    letI :=
+      CuspUniformization.totalPeriodQuotientChartedSpace D.correction D.radius D.radius_pos
+        D.radius_lt_one D.holomorphic D.smallDrift
+    letI := D.chartedSpace
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω D.directToIteratedEquiv.symm := by
+  let :=
+    CuspUniformization.totalPeriodQuotientChartedSpace D.correction D.radius D.radius_pos
+      D.radius_lt_one D.holomorphic D.smallDrift
+  let := D.chartedSpace
+  apply
+    contMDiff_of_comp_localDiffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      D.iteratedCover_isLocalDiffeomorph D.iteratedCover_surjective
+  have he :
+    D.directToIteratedEquiv.symm ∘ D.iteratedCover =
+      CuspUniformization.totalPeriodQuotientMap D.correction D.radius :=
+    funext D.directToIteratedEquiv_symm_iteratedCover
+  rw [he]
+  exact
+    CuspUniformization.totalPeriodQuotientMap_holomorphic D.correction D.radius D.radius_pos
+      D.radius_lt_one D.holomorphic D.smallDrift
+
+private def SpecialPeriods.CuspFamily.Data.directQuotientBiholomorph
+    (D : SpecialPeriods.CuspFamily.Data) :
+    letI :=
+      CuspUniformization.totalPeriodQuotientChartedSpace D.correction D.radius D.radius_pos
+        D.radius_lt_one D.holomorphic D.smallDrift
+    letI := D.chartedSpace
+    Diffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (CuspUniformization.TotalPeriodQuotient D.correction D.radius) D.Space ω := by
+  let :=
+    CuspUniformization.totalPeriodQuotientChartedSpace D.correction D.radius D.radius_pos
+      D.radius_lt_one D.holomorphic D.smallDrift
+  let := D.chartedSpace
+  exact
+    { toEquiv := D.directToIteratedEquiv
+      contMDiff_toFun := D.directToIterated_holomorphic
+      contMDiff_invFun := D.directToIteratedEquiv_symm_holomorphic }
+
+private def SpecialPeriods.CuspFamily.Data.puncturedFamilyBiholomorph
+    (D : SpecialPeriods.CuspFamily.Data) :
+    letI := D.chartedSpace
+    letI :=
+      CuspQuotient.chartedSpace D.correction D.radius D.radius_pos D.radius_lt_one D.holomorphic
+        D.smallDrift
+    Diffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) D.Space
+      (CuspUniformization.PuncturedQuotient D.correction D.radius) ω := by
+  let := D.chartedSpace
+  let :=
+    CuspQuotient.chartedSpace D.correction D.radius D.radius_pos D.radius_lt_one D.holomorphic
+      D.smallDrift
+  let :=
+    CuspUniformization.totalPeriodQuotientChartedSpace D.correction D.radius D.radius_pos
+      D.radius_lt_one D.holomorphic D.smallDrift
+  exact
+    D.directQuotientBiholomorph.symm.trans
+      (CuspUniformization.totalUniformizationBiholomorph D.correction D.radius D.radius_pos
+        D.radius_lt_one D.holomorphic D.smallDrift)
+
+@[simp]
+private theorem SpecialPeriods.CuspFamily.Data.puncturedFamilyBiholomorph_iteratedCover
+    (D : SpecialPeriods.CuspFamily.Data) (x : CuspUniformization.LogCover D.radius) :
+    letI := D.chartedSpace
+    letI :=
+      CuspQuotient.chartedSpace D.correction D.radius D.radius_pos D.radius_lt_one D.holomorphic
+        D.smallDrift
+    D.puncturedFamilyBiholomorph (D.iteratedCover x) =
+      CuspUniformization.puncturedCuspCover D.correction D.radius x := by
+  let := D.chartedSpace
+  let :=
+    CuspQuotient.chartedSpace D.correction D.radius D.radius_pos D.radius_lt_one D.holomorphic
+      D.smallDrift
+  let :=
+    CuspUniformization.totalPeriodQuotientChartedSpace D.correction D.radius D.radius_pos
+      D.radius_lt_one D.holomorphic D.smallDrift
+  change
+    CuspUniformization.totalUniformizationBiholomorph D.correction D.radius D.radius_pos
+        D.radius_lt_one D.holomorphic D.smallDrift
+        (D.directToIteratedEquiv.symm (D.iteratedCover x)) =
+      _
+  rw [D.directToIteratedEquiv_symm_iteratedCover,
+    CuspUniformization.totalUniformizationBiholomorph_quotientMap]
+
+private theorem SpecialPeriods.CuspFamily.Data.puncturedFamilyBiholomorph_preserves_base
+    (D : SpecialPeriods.CuspFamily.Data) (x : D.Space) :
+    letI := D.chartedSpace
+    letI :=
+      CuspQuotient.chartedSpace D.correction D.radius D.radius_pos D.radius_lt_one D.holomorphic
+        D.smallDrift
+    CuspQuotient.projection D.correction D.radius (D.puncturedFamilyBiholomorph x) =
+      (D.projection x : ℂ) := by
+  let := D.chartedSpace
+  let :=
+    CuspQuotient.chartedSpace D.correction D.radius D.radius_pos D.radius_lt_one D.holomorphic
+      D.smallDrift
+  obtain ⟨y, rfl⟩ := D.iteratedCover_surjective x
+  rw [D.puncturedFamilyBiholomorph_iteratedCover, D.projection_iteratedCover]
+  exact CuspUniformization.projection_totalCuspCover D.correction D.radius y
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Threefold/SpecialPeriods3.lean b/LeanPool/HopfProblem/Threefold/SpecialPeriods3.lean
new file mode 100644
index 000000000..306931feb
--- /dev/null
+++ b/LeanPool/HopfProblem/Threefold/SpecialPeriods3.lean
@@ -0,0 +1,357 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Foundations.LocalOrbitQuotient
+import all LeanPool.HopfProblem.Foundations.LocalOrbitQuotient
+
+/-!
+# Hopf problem: threefold · special periods 3
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem SpecialPeriods.CoprodTorsion.word_prod_injective {ι : Type*} {M : ι → Type*}
+    [∀ i, Monoid (M i)] : Function.Injective (Monoid.CoprodI.Word.prod (M := M)) := by
+  classical exact (Monoid.CoprodI.Word.equiv (M := M)).symm.injective
+
+private theorem SpecialPeriods.CoprodTorsion.word_prod_eq_one_iff {ι : Type*} {M : ι → Type*}
+    [∀ i, Monoid (M i)] (w : Monoid.CoprodI.Word M) :
+    w.prod = 1 ↔ w = Monoid.CoprodI.Word.empty := by
+  constructor
+  · intro h
+    apply word_prod_injective
+    simpa only [Monoid.CoprodI.Word.prod_empty] using h
+  · rintro rfl
+    exact Monoid.CoprodI.Word.prod_empty
+
+private theorem SpecialPeriods.CoprodTorsion.neWord_prod_ne_one {ι : Type*} {M : ι → Type*}
+    [∀ i, Monoid (M i)] {i j : ι} (w : Monoid.CoprodI.NeWord M i j) : w.prod ≠ 1 := by
+  intro h
+  have hw : w.toWord = Monoid.CoprodI.Word.empty := (word_prod_eq_one_iff w.toWord).mp h
+  exact w.toList_ne_nil (congrArg Monoid.CoprodI.Word.toList hw)
+
+private def
+    SpecialPeriods.CoprodTorsion.neWord_pow_succ {ι : Type*} {M : ι → Type*} [∀ i, Monoid (M i)]
+    {i j : ι} (w : Monoid.CoprodI.NeWord M i j) (h : i ≠ j) : ℕ → Monoid.CoprodI.NeWord M i j
+  | 0 => w
+  | n + 1 => Monoid.CoprodI.NeWord.append (neWord_pow_succ w h n) h.symm w
+
+private theorem SpecialPeriods.CoprodTorsion.neWord_pow_succ_prod {ι : Type*} {M : ι → Type*}
+    [∀ i, Monoid (M i)] {i j : ι} (w : Monoid.CoprodI.NeWord M i j) (h : i ≠ j) (n : ℕ) :
+    (neWord_pow_succ w h n).prod = w.prod ^ (n + 1) := by
+  induction n with
+  | zero => simp [neWord_pow_succ]
+  | succ n ih => simp only [neWord_pow_succ, Monoid.CoprodI.NeWord.append_prod, ih, pow_succ]
+
+private theorem SpecialPeriods.CoprodTorsion.neWord_pow_ne_one {ι : Type*} {M : ι → Type*}
+    [∀ i, Monoid (M i)] {i j : ι} (w : Monoid.CoprodI.NeWord M i j) (h : i ≠ j) (n : ℕ)
+    (hn : 0 < n) : w.prod ^ n ≠ 1 := by
+  cases n with
+  | zero => exact (Nat.lt_irrefl 0 hn).elim
+  | succ n =>
+    rw [← neWord_pow_succ_prod w h n]
+    exact neWord_prod_ne_one _
+
+
+private theorem
+    SpecialPeriods.CoprodTorsion.word_pow_ne_one_of_endpoints_ne {ι : Type*} {M : ι → Type*}
+    [∀ i, Monoid (M i)] (w : Monoid.CoprodI.Word M)
+    (h : w.toList.head?.map Sigma.fst ≠ w.toList.getLast?.map Sigma.fst) (n : ℕ) (hn : 0 < n) :
+    w.prod ^ n ≠ 1 := by
+  have hw : w ≠ Monoid.CoprodI.Word.empty := by
+    rintro rfl
+    exact h rfl
+  obtain ⟨i, j, v, rfl⟩ := Monoid.CoprodI.NeWord.of_word w hw
+  have hij : i ≠ j := by
+    simpa only [Monoid.CoprodI.NeWord.toWord, Monoid.CoprodI.NeWord.toList_head?,
+      Monoid.CoprodI.NeWord.toList_getLast?, Option.map_some, ne_eq, Option.some.injEq] using h
+  exact neWord_pow_ne_one v hij n hn
+
+private theorem SpecialPeriods.CoprodTorsion.word_not_isOfFinOrder_of_endpoints_ne {ι : Type*}
+    {M : ι → Type*} [∀ i, Monoid (M i)] (w : Monoid.CoprodI.Word M)
+    (h : w.toList.head?.map Sigma.fst ≠ w.toList.getLast?.map Sigma.fst) : ¬IsOfFinOrder w.prod :=
+  by
+  rintro hf
+  obtain ⟨n, hn, hpow⟩ := hf.exists_pow_eq_one
+  exact word_pow_ne_one_of_endpoints_ne w h n hn hpow
+
+private theorem SpecialPeriods.CoprodTorsion.word_not_isOfFinOrder_of_head_getLast {ι : Type*}
+    {M : ι → Type*} [∀ i, Monoid (M i)] (w : Monoid.CoprodI.Word M) (a b : Σ i, M i)
+    (ha : w.toList.head? = Option.some a) (hb : w.toList.getLast? = Option.some b)
+    (hab : a.1 ≠ b.1) : ¬IsOfFinOrder w.prod := by
+  apply word_not_isOfFinOrder_of_endpoints_ne w
+  simpa only [ha, hb, Option.map_some, ne_eq, Option.some.injEq] using hab
+
+private theorem SpecialPeriods.CoprodTorsion.exists_shorter_conjugate {ι : Type*} {G : ι → Type*}
+    [∀ i, Group (G i)] (w : Monoid.CoprodI.Word G) (a b : Σ i, G i) (l : List (Σ i, G i))
+    (hw : w.toList = a :: (l ++ [b])) (hab : a.1 = b.1) :
+    ∃ v : Monoid.CoprodI.Word G, v.toList.length < w.toList.length ∧ IsConj v.prod w.prod := by
+  classical
+  rcases a with ⟨i, a⟩
+  rcases b with ⟨j, b⟩
+  dsimp only at hab
+  subst j
+  have hchain : (l ++ [Sigma.mk i b]).IsChain (fun x y : Σ i, G i => x.1 ≠ y.1) := by
+    have hc := w.chain_ne
+    rw [hw] at hc
+    exact hc.tail
+  have hletters : ∀ x ∈ l, Sigma.snd x ≠ 1 := by
+    intro x hx
+    apply w.ne_one x
+    rw [hw]
+    exact List.mem_cons_of_mem _ (List.mem_append_left _ hx)
+  let middle : Monoid.CoprodI.Word G := ⟨l, hletters, hchain.left_of_append⟩
+  have hp : w.prod = Monoid.CoprodI.of a * (middle.prod * Monoid.CoprodI.of b) := by
+    simp [Monoid.CoprodI.Word.prod, hw, middle]
+  by_cases hba : b * a = 1
+  · refine ⟨middle, ?_, ?_⟩
+    · simp only [middle, hw, List.length_cons, List.length_append]
+      omega
+    · apply isConj_iff.mpr
+      refine ⟨Monoid.CoprodI.of a, ?_⟩
+      have hb : Monoid.CoprodI.of b = (Monoid.CoprodI.of a : Monoid.CoprodI G)⁻¹ := by
+        apply eq_inv_of_mul_eq_one_left
+        rw [← map_mul, hba, map_one]
+      rw [hp, hb, mul_assoc]
+  · let v : Monoid.CoprodI.Word G :=
+      { toList := l ++ [⟨i, b * a⟩]
+        ne_one := by
+          intro x hx
+          rcases List.mem_append.mp hx with hx | hx
+          · exact hletters x hx
+          · have hx' : x = ⟨i, b * a⟩ := List.mem_singleton.mp hx
+            subst x
+            exact hba
+        chain_ne := by
+          apply List.IsChain.append hchain.left_of_append (List.isChain_singleton _)
+          intro x hx y hy
+          have hy' : y = ⟨i, b * a⟩ := by simpa using hy.symm
+          subst y
+          exact (List.isChain_append.mp hchain).2.2 x hx ⟨i, b⟩ (by simp) }
+    refine ⟨v, ?_, ?_⟩
+    · simp only [v, hw, List.length_cons, List.length_append]
+      omega
+    · apply isConj_iff.mpr
+      refine ⟨Monoid.CoprodI.of a, ?_⟩
+      have hv : v.prod = middle.prod * Monoid.CoprodI.of (b * a) := by
+        simp only [Monoid.CoprodI.Word.prod, v, middle, List.map_append, List.map_singleton,
+          List.prod_append, List.prod_singleton]
+      rw [hv, hp, map_mul]
+      simp only [mul_assoc, mul_inv_cancel, mul_one]
+
+private theorem SpecialPeriods.CoprodTorsion.list_cases_endpoints_mo1973_16238 {α : Type*}
+    (l : List α) : l = [] ∨ (∃ a, l = [a]) ∨ ∃ a m b, l = a :: (m ++ [b]) := by
+  induction l using List.bidirectionalRec with
+  | nil => exact Or.inl rfl
+  | singleton a => exact Or.inr (Or.inl ⟨a, rfl⟩)
+  | cons_append a l b _ => exact Or.inr (Or.inr ⟨a, l, b, rfl⟩)
+
+private theorem SpecialPeriods.CoprodTorsion.coprodI_isOfFinOrder_conjugate_factor {ι : Type*}
+    {G : ι → Type*} [∀ i, Group (G i)] (x : Monoid.CoprodI G) (hx : IsOfFinOrder x) :
+    x = 1 ∨ ∃ (i : ι) (a : G i), IsConj (Monoid.CoprodI.of a) x := by
+  classical
+  let P : ℕ → Prop := fun n => ∃ w : Monoid.CoprodI.Word G, w.toList.length = n ∧ IsConj w.prod x
+  have hP : ∃ n, P n := by
+    refine ⟨(Monoid.CoprodI.Word.equiv x).toList.length, Monoid.CoprodI.Word.equiv x, rfl, ?_⟩
+    have hp : (Monoid.CoprodI.Word.equiv x).prod = x :=
+      (Monoid.CoprodI.Word.equiv (M := G)).symm_apply_apply x
+    rw [hp]
+  obtain ⟨w, hwlen, hwconj⟩ := Nat.find_spec hP
+  have hmin (v : Monoid.CoprodI.Word G) (hv : IsConj v.prod x) :
+    w.toList.length ≤ v.toList.length := by
+    rw [hwlen]
+    exact Nat.find_min' hP ⟨v, rfl, hv⟩
+  have hwfin : IsOfFinOrder w.prod := hwconj.symm.isOfFinOrder hx
+  rcases list_cases_endpoints_mo1973_16238 w.toList with hnil | ⟨a, hsingle⟩ | ⟨a, l, b, hw⟩
+  · left
+    have hp : w.prod = 1 := by simp [Monoid.CoprodI.Word.prod, hnil]
+    simpa only [hp, isConj_one_right] using hwconj
+  · right
+    refine ⟨a.1, a.2, ?_⟩
+    have hp : w.prod = Monoid.CoprodI.of a.2 := by simp [Monoid.CoprodI.Word.prod, hsingle]
+    simpa only [hp] using hwconj
+  · by_cases hab : a.1 = b.1
+    · obtain ⟨v, hvlen, hvconj⟩ := exists_shorter_conjugate w a b l hw hab
+      exact (Nat.not_lt_of_ge (hmin v (hvconj.trans hwconj)) hvlen).elim
+    · exfalso
+      apply
+        word_not_isOfFinOrder_of_head_getLast w a b (by simp [hw])
+          (by rw [hw, ← List.cons_append, List.getLast?_append_of_ne_nil _ (by simp)]; rfl) hab
+          hwfin
+
+private theorem
+    SpecialPeriods.CoprodTorsion.coprodI_nontrivial_isOfFinOrder_conjugate_factor {ι : Type*}
+    {G : ι → Type*} [∀ i, Group (G i)] (x : Monoid.CoprodI G) (hx : IsOfFinOrder x)
+    (hne : x ≠ 1) : ∃ (i : ι) (a : G i), a ≠ 1 ∧ IsConj (Monoid.CoprodI.of a) x := by
+  obtain hx | ⟨i, a, ha⟩ := coprodI_isOfFinOrder_conjugate_factor x hx
+  · exact (hne hx).elim
+  · refine ⟨i, a, ?_, ha⟩
+    rintro rfl
+    exact hne (by simpa using ha.symm)
+
+private theorem SpecialPeriods.CoprodTorsion.coprod_nontrivial_isOfFinOrder_conjugate_factor
+    {A B : Type u} [Group A] [Group B] (x : Monoid.Coprod A B) (hx : IsOfFinOrder x)
+    (hne : x ≠ 1) :
+    (∃ a : A, a ≠ 1 ∧ IsConj (Monoid.Coprod.inl a) x) ∨
+      ∃ b : B, b ≠ 1 ∧ IsConj (Monoid.Coprod.inr b) x := by
+  let H : Bool → Type _ := fun b => cond b B A
+  let : ∀ b, Group (H b) := Bool.rec (inferInstance : Group A) (inferInstance : Group B)
+  let toI : Monoid.Coprod A B →* Monoid.CoprodI H :=
+    Monoid.Coprod.lift (Monoid.CoprodI.of (M := H) (i := Bool.false))
+      (Monoid.CoprodI.of (M := H) (i := Bool.true))
+  let fromI : Monoid.CoprodI H →* Monoid.Coprod A B :=
+    Monoid.CoprodI.lift fun b =>
+      match b with
+      | false => Monoid.Coprod.inl
+      | true => Monoid.Coprod.inr
+  have hleft : fromI.comp toI = MonoidHom.id (Monoid.Coprod A B) := by
+    apply Monoid.Coprod.hom_ext
+    · ext a
+      simp [toI, fromI]
+    · ext b
+      simp [toI, fromI]
+  have hleft_apply (y : Monoid.Coprod A B) : fromI (toI y) = y := DFunLike.congr_fun hleft y
+  have hto_ne : toI x ≠ 1 := by
+    intro he
+    apply hne
+    have hh := congrArg fromI he
+    simpa only [hleft_apply, map_one] using hh
+  obtain ⟨b, a, hane, ha⟩ :=
+    coprodI_nontrivial_isOfFinOrder_conjugate_factor (toI x) (toI.isOfFinOrder hx) hto_ne
+  have ha' := fromI.map_isConj ha
+  rw [hleft_apply] at ha'
+  cases b with
+  | false => exact Or.inl ⟨a, hane, by simpa [fromI] using ha'⟩
+  | true => exact Or.inr ⟨a, hane, by simpa [fromI] using ha'⟩
+
+private theorem SpecialPeriods.CoprodTorsion.coprodI_conjugate_factor {ι : Type*} {G : ι → Type*}
+    [∀ i, Group (G i)] {i : ι} (a b : G i) (ha : a ≠ 1) (g : Monoid.CoprodI G)
+    (h : g⁻¹ * Monoid.CoprodI.of a * g = Monoid.CoprodI.of b) :
+    ∃ c : G i, g = Monoid.CoprodI.of c := by
+  classical
+  have hb : b ≠ 1 := by
+    intro hb
+    have he : (Monoid.CoprodI.of a : Monoid.CoprodI G) = 1 := by
+      have hh := congrArg (fun x : Monoid.CoprodI G => g * x * g⁻¹) h
+      simpa only [hb, map_one, mul_one, one_mul, mul_assoc, mul_inv_cancel, inv_mul_cancel,
+        mul_inv_cancel_left] using hh
+    apply ha
+    apply Monoid.CoprodI.of_injective i
+    simpa only [map_one] using he
+  let p : Monoid.CoprodI.Word.Pair G i :=
+    Monoid.CoprodI.Word.equivPair i (Monoid.CoprodI.Word.equiv g)
+  have he : Monoid.CoprodI.Word.rcons p = Monoid.CoprodI.Word.equiv g :=
+    (Monoid.CoprodI.Word.equivPair i).symm_apply_apply (Monoid.CoprodI.Word.equiv g)
+  have hg : g = Monoid.CoprodI.of p.head * p.tail.prod := by
+    calc
+      g = (Monoid.CoprodI.Word.equiv g).prod :=
+        ((Monoid.CoprodI.Word.equiv (M := G)).symm_apply_apply g).symm
+      _ = (Monoid.CoprodI.Word.rcons p).prod := (congrArg Monoid.CoprodI.Word.prod he.symm)
+      _ = Monoid.CoprodI.of p.head * p.tail.prod := Monoid.CoprodI.Word.prod_rcons p
+  by_cases ht : p.tail = Monoid.CoprodI.Word.empty
+  · exact ⟨p.head, by simpa only [ht, Monoid.CoprodI.Word.prod_empty, mul_one] using hg⟩
+  · obtain ⟨j, k, w, hw⟩ := Monoid.CoprodI.NeWord.of_word p.tail ht
+    have hji : j ≠ i := by
+      have hh := p.fstIdx_ne
+      rw [← hw] at hh
+      simpa only [Monoid.CoprodI.Word.fstIdx, Monoid.CoprodI.NeWord.toWord,
+        Monoid.CoprodI.NeWord.toList_head?, Option.map_some, ne_eq, Option.some.injEq] using hh
+    let d : G i := p.head⁻¹ * a * p.head
+    have hd : d ≠ 1 := by
+      intro hd
+      apply ha
+      have hh := congrArg (fun x : G i => p.head * x * p.head⁻¹) hd
+      simpa only [d, mul_assoc, mul_inv_cancel, inv_mul_cancel, mul_one, one_mul,
+        mul_inv_cancel_left] using hh
+    let v : Monoid.CoprodI.NeWord G k k :=
+      Monoid.CoprodI.NeWord.append
+        (Monoid.CoprodI.NeWord.append w.inv hji (Monoid.CoprodI.NeWord.singleton d hd)) hji.symm w
+    have hgp : g = Monoid.CoprodI.of p.head * w.prod := by
+      simpa only [Monoid.CoprodI.NeWord.prod, hw] using hg
+    have hv : v.prod = Monoid.CoprodI.of b := by
+      rw [hgp] at h
+      simpa only [v, Monoid.CoprodI.NeWord.append_prod, Monoid.CoprodI.NeWord.inv_prod,
+        Monoid.CoprodI.NeWord.prod_singleton, d, map_mul, map_inv, mul_inv_rev, mul_assoc] using h
+    have hvw : v.toWord = (Monoid.CoprodI.NeWord.singleton b hb).toWord := by
+      apply word_prod_injective
+      exact hv.trans (Monoid.CoprodI.NeWord.prod_singleton b hb).symm
+    have hlen := congrArg (fun t : Monoid.CoprodI.Word G => t.toList.length) hvw
+    simp only [v, Monoid.CoprodI.NeWord.toWord, Monoid.CoprodI.NeWord.toList, List.length_append,
+      List.length_singleton] at hlen
+    have hpos : 0 < w.toList.length := List.length_pos_iff.mpr w.toList_ne_nil
+    omega
+
+private theorem SpecialPeriods.CoprodTorsion.coprodI_commute_of {ι : Type*} {G : ι → Type*}
+    [∀ i, Group (G i)] {i : ι} (a : G i) (ha : a ≠ 1) (g : Monoid.CoprodI G)
+    (h : Commute (Monoid.CoprodI.of a) g) : ∃ b : G i, g = Monoid.CoprodI.of b := by
+  apply coprodI_conjugate_factor a a ha g
+  have hh := congrArg (fun x : Monoid.CoprodI G => g⁻¹ * x) h.eq
+  simpa only [mul_assoc, inv_mul_cancel_left] using hh
+
+private theorem
+    SpecialPeriods.CoprodTorsion.coprod_commute_inl {A B : Type u} [Group A] [Group B] (a : A)
+    (ha : a ≠ 1) (g : Monoid.Coprod A B) (h : Commute (Monoid.Coprod.inl a) g) :
+    ∃ b : A, g = Monoid.Coprod.inl b := by
+  let H : Bool → Type u := fun b => cond b B A
+  let : ∀ b, Group (H b) := Bool.rec (inferInstance : Group A) (inferInstance : Group B)
+  let toI : Monoid.Coprod A B →* Monoid.CoprodI H :=
+    Monoid.Coprod.lift (Monoid.CoprodI.of (M := H) (i := Bool.false))
+      (Monoid.CoprodI.of (M := H) (i := Bool.true))
+  let fromI : Monoid.CoprodI H →* Monoid.Coprod A B :=
+    Monoid.CoprodI.lift fun b =>
+      match b with
+      | false => Monoid.Coprod.inl
+      | true => Monoid.Coprod.inr
+  have hleft : fromI.comp toI = MonoidHom.id (Monoid.Coprod A B) := by
+    apply Monoid.Coprod.hom_ext
+    · ext b
+      simp [toI, fromI]
+    · ext b
+      simp [toI, fromI]
+  have hleft_apply (x : Monoid.Coprod A B) : fromI (toI x) = x := DFunLike.congr_fun hleft x
+  have hc : Commute (Monoid.CoprodI.of (i := Bool.false) a) (toI g) := by
+    have hh := congrArg toI h.eq
+    simpa only [commute_iff_eq, map_mul, toI, Monoid.Coprod.lift_apply_inl] using hh
+  obtain ⟨b, hb⟩ := coprodI_commute_of (G := H) (i := Bool.false) a ha (toI g) hc
+  refine ⟨b, ?_⟩
+  have hh := congrArg fromI hb
+  simpa only [hleft_apply, fromI, Monoid.CoprodI.lift_of] using hh
+
+public
+theorem SpecialPeriods.CoprodTorsion.coprod_commute_inr {A B : Type u} [Group A] [Group B] (a : B)
+    (ha : a ≠ 1) (g : Monoid.Coprod A B) (h : Commute (Monoid.Coprod.inr a) g) :
+    ∃ b : B, g = Monoid.Coprod.inr b := by
+  have hc : Commute (Monoid.Coprod.inl a) (Monoid.Coprod.swap A B g) := by
+    have hh := congrArg (Monoid.Coprod.swap A B) h.eq
+    simpa only [commute_iff_eq, map_mul, Monoid.Coprod.swap_inr] using hh
+  obtain ⟨b, hb⟩ := coprod_commute_inl a ha (Monoid.Coprod.swap A B g) hc
+  refine ⟨b, ?_⟩
+  have hh := congrArg (Monoid.Coprod.swap B A) hb
+  simpa only [Monoid.Coprod.swap_swap, Monoid.Coprod.swap_inl] using hh
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Threefold/SpecialPeriods4.lean b/LeanPool/HopfProblem/Threefold/SpecialPeriods4.lean
new file mode 100644
index 000000000..f5f239f65
--- /dev/null
+++ b/LeanPool/HopfProblem/Threefold/SpecialPeriods4.lean
@@ -0,0 +1,826 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Uniformization.SpecialPeriods3
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods3
+
+/-!
+# Hopf problem: threefold · special periods 4
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private abbrev SpecialPeriods.Threefold.Puncture :=
+  Option Elliptic.Kind
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.puncturePoint :
+    Puncture → SpecialPeriods.TriangleCompactifiedOrbitSpace
+  | none => SpecialPeriods.triangleCuspPoint
+  | some j => SpecialPeriods.Triangle.ellipticCompactifiedCenter j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.puncturePoint_injective : Function.Injective puncturePoint := by
+  intro i j h
+  cases i with
+  | none =>
+    cases j with
+    | none => rfl
+    | some j => exact (SpecialPeriods.Triangle.ellipticCompactifiedCenter_ne_cusp j h.symm).elim
+  | some i =>
+    cases j with
+    | none => exact (SpecialPeriods.Triangle.ellipticCompactifiedCenter_ne_cusp i h).elim
+    | some j =>
+      congr 1
+      cases i <;> cases j
+      · rfl
+      · exact (SpecialPeriods.triangleCompactifiedCenterOne_ne_centerTwo h).elim
+      · exact (SpecialPeriods.triangleCompactifiedCenterOne_ne_centerTwo h.symm).elim
+      · rfl
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.punctureChart :
+    Puncture → OpenPartialHomeomorph SpecialPeriods.TriangleCompactifiedOrbitSpace ℂ
+  | none => SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl
+  | some j => SpecialPeriods.Triangle.ellipticCompactifiedChart j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.punctureChartRadius : Puncture → ℝ
+  | none => SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width
+  | some _ => 1
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.punctureChartRadius_pos (i : Puncture) :
+    0 < punctureChartRadius i := by
+  cases i with
+  | none => exact SpecialPeriods.Triangle.cuspRadius_pos SpecialPeriods.Triangle.width
+  | some j => norm_num [punctureChartRadius]
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.punctureChart_target (i : Puncture) :
+    (punctureChart i).target = Metric.ball 0 (punctureChartRadius i) := by
+  cases i with
+  | none =>
+    exact SpecialPeriods.Triangle.cuspFullChart_target SpecialPeriods.Triangle.width le_rfl
+  | some j => exact SpecialPeriods.Triangle.ellipticCompactifiedChart_target j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.puncturePoint_mem_source (i : Puncture) :
+    puncturePoint i ∈ (punctureChart i).source := by
+  cases i with
+  | none =>
+    exact SpecialPeriods.Triangle.cuspPoint_mem_cuspNeighborhood SpecialPeriods.Triangle.width
+  | some j => exact SpecialPeriods.Triangle.ellipticCompactifiedChart_center_mem_source j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.punctureChart_point (i : Puncture) :
+    punctureChart i (puncturePoint i) = 0 := by
+  cases i with
+  | none =>
+    exact SpecialPeriods.Triangle.cuspFullChart_cuspPoint SpecialPeriods.Triangle.width le_rfl
+  | some j => exact SpecialPeriods.Triangle.ellipticCompactifiedChart_center j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.punctureChart_symm_zero (i : Puncture) :
+    (punctureChart i).symm 0 = puncturePoint i := by
+  rw [← punctureChart_point i]
+  exact (punctureChart i).left_inv (puncturePoint_mem_source i)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.punctureChart_eq_zero_iff (i : Puncture)
+    {x : SpecialPeriods.TriangleCompactifiedOrbitSpace} (hx : x ∈ (punctureChart i).source) :
+    punctureChart i x = 0 ↔ x = puncturePoint i := by
+  constructor
+  · intro h
+    apply (punctureChart i).injOn hx (puncturePoint_mem_source i)
+    exact h.trans (punctureChart_point i).symm
+  · rintro rfl
+    exact punctureChart_point i
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.punctureChart_holomorphic (i : Puncture) :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (punctureChart i) (punctureChart i).source := by
+  cases i with
+  | none => exact SpecialPeriods.triangleCompactified_cuspChart_holomorphic
+  | some j => exact SpecialPeriods.Triangle.ellipticCompactifiedChart_holomorphic j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.punctureChart_symm_holomorphic (i : Puncture) :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (punctureChart i).symm (punctureChart i).target := by
+  cases i with
+  | none => exact SpecialPeriods.triangleCompactified_cuspChart_symm_holomorphic
+  | some j => exact SpecialPeriods.Triangle.ellipticCompactifiedChart_symm_holomorphic j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.puncturePartial (i : Puncture) :
+    PartialDiffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace ℂ ω
+    where
+  toPartialEquiv := (punctureChart i).toPartialEquiv
+  open_source := (punctureChart i).open_source
+  open_target := (punctureChart i).open_target
+  contMDiffOn_toFun := punctureChart_holomorphic i
+  contMDiffOn_invFun := punctureChart_symm_holomorphic i
+
+private theorem
+    SpecialPeriods.Threefold.exists_pairwise_disjoint_opens {I X : Type*} [TopologicalSpace X]
+    [Finite I] [T2Space X] (p : I → X) (hp : Function.Injective p)
+    (U : I → TopologicalSpace.Opens X) (hU : ∀ i, p i ∈ U i) :
+    ∃ V : I → TopologicalSpace.Opens X,
+      (∀ i, p i ∈ V i) ∧
+        (∀ i, V i ≤ U i) ∧ Pairwise (fun i j => Disjoint (V i : Set X) (V j : Set X)) := by
+  obtain ⟨W, hW, hdisj⟩ := (Set.finite_range p).t2_separation
+  refine
+    ⟨fun i => ⟨W (p i) ∩ U i, (hW (p i)).2.inter (U i).isOpen⟩, fun i => ⟨(hW (p i)).1, hU i⟩,
+      fun _ => Set.inter_subset_right, ?_⟩
+  intro i j hij
+  exact
+    (hdisj (Set.mem_range_self i) (Set.mem_range_self j) (fun h => hij (hp h))).mono
+      Set.inter_subset_left Set.inter_subset_left
+
+private def SpecialPeriods.Threefold.coordinateDisc {X : Type*} [TopologicalSpace X]
+    (e : OpenPartialHomeomorph X ℂ) (r : ℝ) : TopologicalSpace.Opens X :=
+  ⟨e.source ∩ e ⁻¹' Metric.ball 0 r, e.isOpen_inter_preimage Metric.isOpen_ball⟩
+
+@[simp]
+private theorem SpecialPeriods.Threefold.mem_coordinateDisc {X : Type*} [TopologicalSpace X]
+    (e : OpenPartialHomeomorph X ℂ) (r : ℝ) (x : X) :
+    x ∈ coordinateDisc e r ↔ x ∈ e.source ∧ e x ∈ Metric.ball 0 r :=
+  Iff.rfl
+
+private theorem SpecialPeriods.Threefold.center_mem_coordinateDisc {X : Type*} [TopologicalSpace X]
+    (e : OpenPartialHomeomorph X ℂ) {p : X} (hp : p ∈ e.source) (h0 : e p = 0) {r : ℝ}
+    (hr : 0 < r) : p ∈ coordinateDisc e r := by exact ⟨hp, h0 ▸ Metric.mem_ball_self hr⟩
+
+private theorem
+    SpecialPeriods.Threefold.coordinateDisc_eq_symm_image {X : Type*} [TopologicalSpace X]
+    (e : OpenPartialHomeomorph X ℂ) {r : ℝ} (hr : Metric.ball 0 r ⊆ e.target) :
+    (coordinateDisc e r : Set X) = e.symm '' Metric.ball 0 r :=
+  (e.symm_image_eq_source_inter_preimage hr).symm
+
+private theorem
+    SpecialPeriods.Threefold.exists_coordinateDisc_subset {X : Type*} [TopologicalSpace X]
+    (e : OpenPartialHomeomorph X ℂ) {p : X} (hp : p ∈ e.source) (h0 : e p = 0)
+    (U : TopologicalSpace.Opens X) (hU : p ∈ U) {R : ℝ} (hR : 0 < R) :
+    ∃ r : ℝ, 0 < r ∧ r < R ∧ Metric.ball 0 r ⊆ e.target ∧ coordinateDisc e r ≤ U := by
+  have hnhds : e.target ∩ e.symm ⁻¹' (U : Set X) ∈ 𝓝 (e p) :=
+    Filter.inter_mem (e.open_target.mem_nhds (e.map_source hp))
+      ((e.tendsto_symm hp).eventually (U.isOpen.mem_nhds hU))
+  rw [h0] at hnhds
+  obtain ⟨r, hr, hball⟩ := Metric.mem_nhds_iff.mp hnhds
+  let ρ := Min.min r (R / 2)
+  have hρr : ρ ≤ r := min_le_left _ _
+  have hρball : Metric.ball (0 : ℂ) ρ ⊆ e.target ∩ e.symm ⁻¹' (U : Set X) :=
+    (Metric.ball_subset_ball hρr).trans hball
+  refine
+    ⟨ρ, lt_min hr (half_pos hR), (min_le_right _ _).trans_lt (half_lt_self hR),
+      hρball.trans Set.inter_subset_left, ?_⟩
+  intro x hx
+  have hmem := (hρball hx.2).2
+  change e.symm (e x) ∈ (U : Set X) at hmem
+  rw [e.left_inv hx.1] at hmem
+  exact hmem
+
+private theorem SpecialPeriods.Threefold.exists_pairwise_disjoint_coordinateDiscs {I X : Type*}
+    [TopologicalSpace X] [Finite I] [T2Space X] (p : I → X) (hp : Function.Injective p)
+    (e : I → OpenPartialHomeomorph X ℂ) (hsource : ∀ i, p i ∈ (e i).source)
+    (hzero : ∀ i, e i (p i) = 0) (U : I → TopologicalSpace.Opens X) (hU : ∀ i, p i ∈ U i)
+    (R : I → ℝ) (hR : ∀ i, 0 < R i) :
+    ∃ r : I → ℝ,
+      (∀ i, 0 < r i ∧ r i < R i) ∧
+        (∀ i, Metric.ball 0 (r i) ⊆ (e i).target) ∧
+          (∀ i, coordinateDisc (e i) (r i) ≤ U i) ∧
+            Pairwise
+              (fun i j =>
+                Disjoint (coordinateDisc (e i) (r i) : Set X)
+                  (coordinateDisc (e j) (r j) : Set X)) := by
+  obtain ⟨V, hpV, hVU, hVdisj⟩ := exists_pairwise_disjoint_opens p hp U hU
+  have hdisc (i : I) :=
+    exists_coordinateDisc_subset (e i) (hsource i) (hzero i) (V i) (hpV i) (hR i)
+  choose r hr hrR htarget hsubset using hdisc
+  refine ⟨r, fun i => ⟨hr i, hrR i⟩, htarget, fun i => (hsubset i).trans (hVU i), ?_⟩
+  intro i j hij
+  exact (hVdisj hij).mono (hsubset i) (hsubset j)
+
+private theorem SpecialPeriods.ModularCoverTools.injective_of_covering_singleton_fibre {X B : Type*}
+    [TopologicalSpace X] [TopologicalSpace B] [PathConnectedSpace B] {f : X → B}
+    (hf : IsCoveringMap f) (b₀ : B) (h₀ : Subsingleton (f ⁻¹' { b₀ })) : Function.Injective f := by
+  intro x y hxy
+  let γ : Path.Homotopic.Quotient (f x) b₀ := .mk (PathConnectedSpace.somePath (f x) b₀)
+  have he : (⟨x, rfl⟩ : f ⁻¹' {f x}) = ⟨y, hxy.symm⟩ := (hf.monodromy_bijective γ).1 (h₀.elim _ _)
+  exact congrArg Subtype.val he
+
+private theorem SpecialPeriods.ModularCoverTools.injective_of_open_dense {X Y : Type*}
+    [TopologicalSpace X] [TopologicalSpace Y] [T2Space X] {f : X → Y} {D : Set Y}
+    (hf : IsOpenMap f) (hD : Dense D) (hi : Set.InjOn f (f ⁻¹' D)) : Function.Injective f := by
+  intro x y hxy
+  by_contra hne
+  obtain ⟨U, V, hU, hV, hx, hy, hUV⟩ := t2_separation hne
+  have hnonempty : (f '' U ∩ f '' V).Nonempty := ⟨f x, ⟨x, hx, rfl⟩, y, hy, hxy.symm⟩
+  obtain ⟨z, hzD, ⟨u, hu, huz⟩, ⟨v, hv, hvz⟩⟩ :=
+    hD.exists_mem_open ((hf U hU).inter (hf V hV)) hnonempty
+  have huv : u = v :=
+    hi (by simpa only [Set.mem_preimage, huz] using hzD)
+      (by simpa only [Set.mem_preimage, hvz] using hzD) (huz.trans hvz.symm)
+  subst v
+  exact hUV.le_bot ⟨hu, hv⟩
+
+private theorem SpecialPeriods.ModularCoverTools.complex_compl_countable_pathConnected {S : Set ℂ}
+    (hS : S.Countable) : PathConnectedSpace ↥(Sᶜ) :=
+  isPathConnected_iff_pathConnectedSpace.mp
+    (hS.isPathConnected_compl_of_one_lt_rank (by simp [Complex.rank_real_complex]))
+
+private theorem SpecialPeriods.ModularCoverTools.complex_compl_pair_pathConnected (a b : ℂ) :
+    PathConnectedSpace ↥(({ a, b } : Set ℂ)ᶜ) :=
+  complex_compl_countable_pathConnected (Set.toFinite _).countable
+
+private theorem SpecialPeriods.ModularCoverTools.complex_compl_countable_dense {S : Set ℂ}
+    (hS : S.Countable) : Dense Sᶜ :=
+  hS.dense_compl ℝ
+
+private theorem SpecialPeriods.ModularCoverTools.complex_compl_pair_dense (a b : ℂ) :
+    Dense (({ a, b } : Set ℂ)ᶜ) :=
+  complex_compl_countable_dense (Set.toFinite _).countable
+
+private def SpecialPeriods.TauEquivariance.intertwiningSubgroup {G X Y : Type*} [Group G]
+    (α : G →* Equiv.Perm X) (β : G →* Equiv.Perm Y) (f : X → Y) : Subgroup G
+    where
+  carrier := {g | ∀ x, f (α g x) = β g (f x)}
+  one_mem' := by intro x; simp
+  mul_mem' := by
+    intro g h hg hh x
+    simpa only [map_mul, Equiv.Perm.coe_mul, Function.comp_apply] using
+      (hg (α h x)).trans (congrArg (β g) (hh x))
+  inv_mem' := by
+    intro g hg x
+    apply (β g).injective
+    have h := hg (α g⁻¹ x)
+    simpa using h.symm
+
+private theorem SpecialPeriods.GlobalTauNormalization.trace_neg_two_triples (p q r : ℤ)
+    (hdet : -p ^ 2 - q * r = 1) (htr : p + q - r = -2) :
+    (p = 0 ∧ q = -1 ∧ r = 1) ∨ (p = 1 ∧ q = -2 ∧ r = 1) ∨ (p = 1 ∧ q = -1 ∧ r = 2) := by
+  have hq : q = r - p - 2 := by omega
+  rw [hq] at hdet
+  have hquad : p ^ 2 - p * r + r ^ 2 - 2 * r + 1 = 0 := by nlinarith only [hdet]
+  have hp₀ : 0 ≤ p := by nlinarith only [hquad, sq_nonneg (2 * r - p - 2), sq_nonneg p]
+  have hp_upper : 2 * p ≤ 3 := by
+    nlinarith only [hquad, sq_nonneg (2 * r - p - 2), sq_nonneg (p - 1)]
+  have hp₁ : p ≤ 1 := by omega
+  have hr_lower : 4 ≤ 8 * r := by nlinarith only [hquad, sq_nonneg (2 * p - r), sq_nonneg r]
+  have hr_upper : 10 * r ≤ 23 := by
+    nlinarith only [hquad, sq_nonneg (2 * p - r), sq_nonneg (r - 3)]
+  have hr₁ : 1 ≤ r := by omega
+  have hr₂ : r ≤ 2 := by omega
+  have hp_cases : p = 0 ∨ p = 1 := by omega
+  have hr_cases : r = 1 ∨ r = 2 := by omega
+  rcases hp_cases with rfl | rfl
+  · rcases hr_cases with rfl | rfl
+    · left
+      omega
+    · norm_num at hquad
+  · rcases hr_cases with rfl | rfl
+    · right
+      left
+      omega
+    · right
+      right
+      omega
+
+private def SpecialPeriods.TauCusp.simplePoleCoordinate (a : ℂ → ℂ) (t : ℂ) : ℂ :=
+  1728 * t / a t
+
+private def SpecialPeriods.TauCusp.simplePoleQ (a : ℂ → ℂ) (t : ℂ) : ℂ :=
+  SpecialPeriods.modularCuspQ (simplePoleCoordinate a t)
+
+private def SpecialPeriods.TauCusp.simplePoleUnit (a : ℂ → ℂ) (t : ℂ) : ℂ :=
+  (1728 / a t) * SpecialPeriods.modularCuspUnit (simplePoleCoordinate a t)
+
+@[simp]
+private theorem SpecialPeriods.TauCusp.simplePoleCoordinate_zero (a : ℂ → ℂ) :
+    simplePoleCoordinate a 0 = 0 := by simp [simplePoleCoordinate]
+
+@[simp]
+private theorem SpecialPeriods.TauCusp.simplePoleQ_zero (a : ℂ → ℂ) : simplePoleQ a 0 = 0 := by
+  simp [simplePoleQ]
+
+@[simp]
+private theorem
+    SpecialPeriods.TauCusp.simplePoleUnit_zero (a : ℂ → ℂ) : simplePoleUnit a 0 = 1 / a 0 := by
+  simp [simplePoleUnit]
+  ring
+
+private theorem
+    SpecialPeriods.TauCusp.simplePoleCoordinate_analyticAt {a : ℂ → ℂ} (ha : AnalyticAt ℂ a 0)
+    (ha0 : a 0 ≠ 0) : AnalyticAt ℂ (simplePoleCoordinate a) 0 :=
+  (analyticAt_const.mul analyticAt_id).div ha ha0
+
+private theorem SpecialPeriods.TauCusp.simplePoleQ_analyticAt {a : ℂ → ℂ} (ha : AnalyticAt ℂ a 0)
+    (ha0 : a 0 ≠ 0) : AnalyticAt ℂ (simplePoleQ a) 0 := by
+  have hq : AnalyticAt ℂ SpecialPeriods.modularCuspQ (simplePoleCoordinate a 0) := by
+    simpa only [simplePoleCoordinate_zero] using SpecialPeriods.modularCuspQ_analyticAt_zero
+  exact hq.comp (simplePoleCoordinate_analyticAt ha ha0)
+
+private theorem SpecialPeriods.TauCusp.simplePoleUnit_analyticAt {a : ℂ → ℂ} (ha : AnalyticAt ℂ a 0)
+    (ha0 : a 0 ≠ 0) : AnalyticAt ℂ (simplePoleUnit a) 0 := by
+  have hu : AnalyticAt ℂ SpecialPeriods.modularCuspUnit (simplePoleCoordinate a 0) := by
+    simpa only [simplePoleCoordinate_zero] using SpecialPeriods.modularCuspUnit_analyticAt_zero
+  exact (analyticAt_const.div ha ha0).mul (hu.comp (simplePoleCoordinate_analyticAt ha ha0))
+
+private theorem SpecialPeriods.TauCusp.simplePoleQ_eq_mul_unit (a : ℂ → ℂ) (t : ℂ) :
+    simplePoleQ a t = t * simplePoleUnit a t := by
+  rw [simplePoleQ, SpecialPeriods.modularCuspQ_eq_mul_unit]
+  simp only [simplePoleCoordinate, simplePoleUnit]
+  ring
+
+private theorem
+    SpecialPeriods.TauCusp.simplePoleQ_eventually_j_eq {a : ℂ → ℂ} (ha : AnalyticAt ℂ a 0)
+    (ha0 : a 0 ≠ 0) :
+    ∀ᶠ t in 𝓝 (0 : ℂ), t ≠ 0 → SpecialPeriods.modularJInQ (simplePoleQ a t) = a t / t := by
+  have hj :
+    ∀ᶠ u in 𝓝 (0 : ℂ),
+      u ≠ 0 → SpecialPeriods.modularJInQ (SpecialPeriods.modularCuspQ u) = 1728 / u :=
+    eventually_nhdsWithin_iff.mp SpecialPeriods.modularCuspQ_eventually_j_eq
+  have hc : Filter.Tendsto (simplePoleCoordinate a) (𝓝 0) (𝓝 0) := by
+    simpa only [simplePoleCoordinate_zero] using
+      (simplePoleCoordinate_analyticAt ha ha0).continuousAt.tendsto
+  filter_upwards [hc.eventually hj, ha.continuousAt.eventually_ne ha0] with t hjt hat
+  intro ht
+  have hct : simplePoleCoordinate a t ≠ 0 := div_ne_zero (mul_ne_zero (by norm_num) ht) hat
+  rw [simplePoleQ, hjt hct, simplePoleCoordinate]
+  field_simp
+
+private theorem
+    SpecialPeriods.TauCusp.exists_simplePoleQ_coordinate {a : ℂ → ℂ} (ha : AnalyticAt ℂ a 0)
+    (ha0 : a 0 ≠ 0) {R : ℝ} (hR : 0 < R) :
+    ∃ r > 0,
+      AnalyticOnNhd ℂ (simplePoleQ a) (Metric.ball 0 r) ∧
+        AnalyticOnNhd ℂ (simplePoleUnit a) (Metric.ball 0 r) ∧
+          ∀ t ∈ Metric.ball (0 : ℂ) r,
+            a t ≠ 0 ∧
+              simplePoleUnit a t ≠ 0 ∧
+                ‖simplePoleQ a t‖ < R ∧
+                  (t ≠ 0 → SpecialPeriods.modularJInQ (simplePoleQ a t) = a t / t) := by
+  have hq := simplePoleQ_analyticAt ha ha0
+  have hu := simplePoleUnit_analyticAt ha ha0
+  have hu0 : simplePoleUnit a 0 ≠ 0 := by
+    rw [simplePoleUnit_zero]
+    exact one_div_ne_zero ha0
+  have hn : ∀ᶠ t in 𝓝 (0 : ℂ), ‖simplePoleQ a t‖ < R := by
+    have h :=
+      hq.continuousAt.preimage_mem_nhds
+        (show Metric.ball (0 : ℂ) R ∈ 𝓝 (simplePoleQ a 0)
+          by
+          rw [simplePoleQ_zero]
+          exact Metric.ball_mem_nhds _ hR)
+    filter_upwards [h] with t ht
+    simpa only [Set.mem_preimage, Metric.mem_ball, dist_zero_right] using ht
+  have hall :
+    ∀ᶠ t in 𝓝 (0 : ℂ),
+      AnalyticAt ℂ (simplePoleQ a) t ∧
+        AnalyticAt ℂ (simplePoleUnit a) t ∧
+          a t ≠ 0 ∧
+            simplePoleUnit a t ≠ 0 ∧
+              ‖simplePoleQ a t‖ < R ∧
+                (t ≠ 0 → SpecialPeriods.modularJInQ (simplePoleQ a t) = a t / t) := by
+    filter_upwards [hq.eventually_analyticAt, hu.eventually_analyticAt,
+      ha.continuousAt.eventually_ne ha0, hu.continuousAt.eventually_ne hu0, hn,
+      simplePoleQ_eventually_j_eq ha ha0] with t hqt hut hat hut0 hnt hjt
+    exact ⟨hqt, hut, hat, hut0, hnt, hjt⟩
+  obtain ⟨r, hr, hball⟩ := Metric.mem_nhds_iff.mp hall
+  exact ⟨r, hr, fun t ht => (hball ht).1, fun t ht => (hball ht).2.1, fun t ht => (hball ht).2.2⟩
+
+private theorem SpecialPeriods.TauCusp.mem_logBase_iff_im (r : ℝ) (hr : 0 < r) (s : ℂ) :
+    s ∈ SpecialPeriods.CuspFamily.logBase r ↔ -Real.log r / (2 * Real.pi) < s.im :=
+  CuspUniformization.mem_logDomain_iff_im r hr (s, 0)
+
+private theorem SpecialPeriods.TauCusp.logBase_eq_halfSpace (r : ℝ) (hr : 0 < r) :
+    (SpecialPeriods.CuspFamily.logBase r : Set ℂ) = {s | -Real.log r / (2 * Real.pi) < s.im} := by
+  ext s
+  exact mem_logBase_iff_im r hr s
+
+private theorem SpecialPeriods.TauCusp.logBase_convex (r : ℝ) (hr : 0 < r) :
+    Convex ℝ (SpecialPeriods.CuspFamily.logBase r : Set ℂ) := by
+  rw [logBase_eq_halfSpace r hr]
+  exact (convex_Ioi (-Real.log r / (2 * Real.pi))).linear_preimage Complex.imLm
+
+private theorem SpecialPeriods.TauCusp.logBase_set_nonempty (r : ℝ) (hr : 0 < r) :
+    (SpecialPeriods.CuspFamily.logBase r : Set ℂ).Nonempty := by
+  obtain ⟨p, hp⟩ := CuspUniformization.logDomain_nonempty r hr
+  exact ⟨p.1, hp⟩
+
+private theorem SpecialPeriods.TauCusp.exponential_eq_qParam_one (s : ℂ) :
+    CuspUniformization.exponential s = Function.Periodic.qParam 1 s := by
+  simp only [CuspUniformization.exponential, Function.Periodic.qParam, Complex.ofReal_one,
+    div_one]
+
+private theorem SpecialPeriods.TauCusp.qParam_eq_exponential_div (w : ℝ) (s : ℂ) :
+    Function.Periodic.qParam w s = CuspUniformization.exponential (s / w) := by
+  simp only [CuspUniformization.exponential, Function.Periodic.qParam, mul_div_assoc]
+
+private theorem SpecialPeriods.TauCusp.norm_exponential_lt_one_iff (s : ℂ) :
+    ‖CuspUniformization.exponential s‖ < 1 ↔ 0 < s.im := by
+  simpa only [SpecialPeriods.CuspFamily.mem_logBase, Real.log_one, neg_zero, zero_div] using
+    mem_logBase_iff_im 1 zero_lt_one s
+
+private theorem SpecialPeriods.TauCusp.upperHalfPlane_of_exponential_norm_lt_one {s : ℂ}
+    (hs : ‖CuspUniformization.exponential s‖ < 1) : 0 < s.im :=
+  (norm_exponential_lt_one_iff s).mp hs
+
+public
+theorem SpecialPeriods.TauCusp.exponential_norm_lt_one_of_upperHalfPlane {s : ℂ} (hs : 0 < s.im) :
+    ‖CuspUniformization.exponential s‖ < 1 :=
+  (norm_exponential_lt_one_iff s).mpr hs
+
+private theorem SpecialPeriods.TauCusp.analytic_unit_normalized_logarithm {u : ℂ → ℂ}
+    (hu : AnalyticAt ℂ u 0) (hu0 : u 0 ≠ 0) :
+    ∃ r > 0,
+      ∃ h : ℂ → ℂ,
+        AnalyticOnNhd ℂ h (Metric.ball 0 r) ∧
+          h 0 = CuspUniformization.logarithm (u 0) ∧
+            ∀ t ∈ Metric.ball 0 r, CuspUniformization.exponential (h t) = u t := by
+  let s := CuspUniformization.logarithm (u 0)
+  let e := SpecialPeriods.CuspFamily.scalarExponentialChart s
+  have hs : s ∈ e.source := SpecialPeriods.CuspFamily.scalarExponentialChart_mem_source s
+  have he0 : e s = u 0 := CuspUniformization.exponential_logarithm hu0
+  have huT : u 0 ∈ e.target := he0 ▸ e.map_source hs
+  have hlocal : ∀ᶠ t in 𝓝 (0 : ℂ), AnalyticAt ℂ u t ∧ u t ∈ e.target :=
+    hu.eventually_analyticAt.and (hu.continuousAt (e.open_target.mem_nhds huT))
+  obtain ⟨r, hr, hball⟩ := Metric.mem_nhds_iff.mp hlocal
+  refine ⟨r, hr, e.symm ∘ u, ?_, ?_, ?_⟩
+  · intro t ht
+    have hInv : ContDiffOn ℂ ω e.symm e.target :=
+      SpecialPeriods.CuspFamily.scalarExponentialChart_symm_holomorphic s
+    exact
+      ((hInv (u t) (hball ht).2).contDiffAt (e.open_target.mem_nhds (hball ht).2)).analyticAt.comp
+        (hball ht).1
+  · change e.symm (u 0) = s
+    rw [← he0]
+    exact e.left_inv hs
+  · intro t ht
+    exact e.right_inv (hball ht).2
+
+private theorem SpecialPeriods.TauCusp.modularJInQ_exponential {z : ℂ} (hz : 0 < z.im) :
+    SpecialPeriods.modularJInQ (CuspUniformization.exponential z) =
+      SpecialPeriods.modularJ (UpperHalfPlane.ofComplex z) := by
+  simpa only [Function.Periodic.qParam, Complex.ofReal_one, div_one,
+    CuspUniformization.exponential, UpperHalfPlane.ofComplex_apply_of_im_pos hz] using
+    SpecialPeriods.modularJInQ_qParam (UpperHalfPlane.ofComplex z)
+
+private def SpecialPeriods.TauCusp.correctedLogarithm (h : ℂ → ℂ) (s : ℂ) : ℂ :=
+  s + h (CuspUniformization.exponential s)
+
+private theorem SpecialPeriods.TauCusp.correctedLogarithm_exponential (h : ℂ → ℂ) (s : ℂ) :
+    CuspUniformization.exponential (correctedLogarithm h s) =
+      CuspUniformization.exponential s *
+        CuspUniformization.exponential (h (CuspUniformization.exponential s)) :=
+  CuspUniformization.exponential_add _ _
+
+private theorem SpecialPeriods.TauCusp.correctedLogarithm_sub_int (h : ℂ → ℂ) (s : ℂ) (k : ℤ) :
+    correctedLogarithm h (s - k) = correctedLogarithm h s - k := by
+  simp only [correctedLogarithm, SpecialPeriods.CuspFamily.exponential_sub_int]
+  abel
+
+private theorem SpecialPeriods.TauCusp.correctedLogarithm_analyticAt {r : ℝ} {h : ℂ → ℂ}
+    (hh : AnalyticOnNhd ℂ h (Metric.ball 0 r)) {s : ℂ}
+    (hs : s ∈ SpecialPeriods.CuspFamily.logBase r) : AnalyticAt ℂ (correctedLogarithm h) s :=
+  analyticAt_id.add
+    ((hh (CuspUniformization.exponential s) hs).comp
+      CuspUniformization.exponential_holomorphic.contDiffAt.analyticAt)
+
+private theorem SpecialPeriods.TauCusp.exists_simplePole_logarithmic_lift {a : ℂ → ℂ}
+    (ha : AnalyticAt ℂ a 0) (ha0 : a 0 ≠ 0) {R r₀ : ℝ} (hR : 0 < R) (hr₀ : 0 < r₀) :
+    ∃ r > 0,
+      r < r₀ ∧
+        r < 1 ∧
+          ∃ h : ℂ → ℂ,
+            AnalyticOnNhd ℂ h (Metric.ball 0 r) ∧
+              h 0 = CuspUniformization.logarithm (1 / a 0) ∧
+                (∀ t ∈ Metric.ball 0 r,
+                    CuspUniformization.exponential (h t) = simplePoleUnit a t) ∧
+                  ∀ s ∈ SpecialPeriods.CuspFamily.logBase r,
+                    CuspUniformization.exponential (correctedLogarithm h s) =
+                        simplePoleQ a (CuspUniformization.exponential s) ∧
+                      0 < (correctedLogarithm h s).im ∧
+                        ‖CuspUniformization.exponential (correctedLogarithm h s)‖ < R ∧
+                          SpecialPeriods.modularJ
+                              (UpperHalfPlane.ofComplex (correctedLogarithm h s)) =
+                            a (CuspUniformization.exponential s) /
+                              CuspUniformization.exponential s := by
+  obtain ⟨rq, hrq, _, _, hq⟩ := exists_simplePoleQ_coordinate ha ha0 (lt_min hR zero_lt_one)
+  obtain ⟨rh, hrh, h, hh, hh0, he⟩ :=
+    analytic_unit_normalized_logarithm (simplePoleUnit_analyticAt ha ha0)
+      (by simpa using one_div_ne_zero ha0)
+  obtain ⟨r, hr, hrr⟩ :=
+    exists_between
+      (show 0 < Min.min rq (Min.min rh (Min.min r₀ 1)) from
+        lt_min hrq (lt_min hrh (lt_min hr₀ zero_lt_one)))
+  have hparts : r < rq ∧ r < rh ∧ r < r₀ ∧ r < 1 := by simpa only [lt_min_iff] using hrr
+  have hh' : AnalyticOnNhd ℂ h (Metric.ball 0 r) :=
+    hh.mono (Metric.ball_subset_ball hparts.2.1.le)
+  refine ⟨r, hr, hparts.2.2.1, hparts.2.2.2, h, hh', ?_, ?_, ?_⟩
+  · simpa only [simplePoleUnit_zero] using hh0
+  · intro t ht
+    exact he t (Metric.ball_subset_ball hparts.2.1.le ht)
+  · intro s hs
+    have hst : CuspUniformization.exponential s ∈ Metric.ball (0 : ℂ) r := hs
+    have hsq := hq (CuspUniformization.exponential s) (Metric.ball_subset_ball hparts.1.le hst)
+    have hse := he (CuspUniformization.exponential s) (Metric.ball_subset_ball hparts.2.1.le hst)
+    have hτq :
+      CuspUniformization.exponential (correctedLogarithm h s) =
+        simplePoleQ a (CuspUniformization.exponential s) := by
+      rw [correctedLogarithm_exponential, hse, simplePoleQ_eq_mul_unit]
+    have hτpos : 0 < (correctedLogarithm h s).im :=
+      upperHalfPlane_of_exponential_norm_lt_one
+        (by rw [hτq]; exact lt_of_lt_of_le hsq.2.2.1 (min_le_right R 1))
+    refine ⟨hτq, hτpos, ?_, ?_⟩
+    · rw [hτq]
+      exact lt_of_lt_of_le hsq.2.2.1 (min_le_left R 1)
+    · rw [← modularJInQ_exponential hτpos, hτq]
+      exact hsq.2.2.2 (CuspUniformization.exponential_ne_zero s)
+
+private def SpecialPeriods.TauCusp.correctedLogarithmWidth (w : ℝ) (h : ℂ → ℂ) (s : ℂ) : ℂ :=
+  s / w + h (Function.Periodic.qParam w s)
+
+private theorem
+    SpecialPeriods.TauCusp.correctedLogarithmWidth_eq_correctedLogarithm (w : ℝ) (h : ℂ → ℂ)
+    (s : ℂ) : correctedLogarithmWidth w h s = correctedLogarithm h (s / w) := by
+  simp only [correctedLogarithmWidth, correctedLogarithm, qParam_eq_exponential_div]
+
+private theorem
+    SpecialPeriods.TauCusp.correctedLogarithmWidth_exponential (w : ℝ) (h : ℂ → ℂ) (s : ℂ) :
+    CuspUniformization.exponential (correctedLogarithmWidth w h s) =
+      Function.Periodic.qParam w s *
+        CuspUniformization.exponential (h (Function.Periodic.qParam w s)) := by
+  rw [correctedLogarithmWidth_eq_correctedLogarithm, correctedLogarithm_exponential, ←
+    qParam_eq_exponential_div]
+
+private theorem
+    SpecialPeriods.TauCusp.correctedLogarithmWidth_analyticAt (w : ℝ) {r : ℝ} {h : ℂ → ℂ}
+    (hh : AnalyticOnNhd ℂ h (Metric.ball 0 r)) {s : ℂ} (hs : ‖Function.Periodic.qParam w s‖ < r) :
+    AnalyticAt ℂ (correctedLogarithmWidth w h) s := by
+  have hs' : s / w ∈ SpecialPeriods.CuspFamily.logBase r := by
+    rw [SpecialPeriods.CuspFamily.mem_logBase]
+    simpa only [qParam_eq_exponential_div] using hs
+  have hcomp :=
+    (correctedLogarithm_analyticAt hh hs').comp (f := fun z : ℂ => z / (w : ℂ))
+      (show AnalyticAt ℂ (fun z : ℂ => z / (w : ℂ)) s from analyticAt_id.div_const)
+  have hfun : correctedLogarithmWidth w h = correctedLogarithm h ∘ (fun z : ℂ => z / (w : ℂ)) :=
+    funext (correctedLogarithmWidth_eq_correctedLogarithm w h)
+  rw [hfun]
+  exact hcomp
+
+private theorem
+    SpecialPeriods.TauCusp.correctedLogarithmWidth_analyticOnNhd (w : ℝ) {r : ℝ} {h : ℂ → ℂ}
+    (hh : AnalyticOnNhd ℂ h (Metric.ball 0 r)) :
+    AnalyticOnNhd ℂ (correctedLogarithmWidth w h) {s : ℂ | ‖Function.Periodic.qParam w s‖ < r} :=
+  fun _ hs => correctedLogarithmWidth_analyticAt w hh hs
+
+private theorem SpecialPeriods.TauCusp.div_sub_int_mul_width (w : ℝ) (hw : w ≠ 0) (s : ℂ) (k : ℤ) :
+    (s - (k : ℂ) * w) / w = s / w - k := by
+  have hwC : (w : ℂ) ≠ 0 := Complex.ofReal_ne_zero.mpr hw
+  rw [sub_div, mul_div_cancel_right₀ _ hwC]
+
+private theorem
+    SpecialPeriods.TauCusp.qParam_sub_int_mul_width (w : ℝ) (hw : w ≠ 0) (s : ℂ) (k : ℤ) :
+    Function.Periodic.qParam w (s - (k : ℂ) * w) = Function.Periodic.qParam w s := by
+  rw [qParam_eq_exponential_div, div_sub_int_mul_width w hw,
+    SpecialPeriods.CuspFamily.exponential_sub_int, qParam_eq_exponential_div]
+
+private theorem
+    SpecialPeriods.TauCusp.correctedLogarithmWidth_sub_int_mul_width (w : ℝ) (hw : w ≠ 0)
+    (h : ℂ → ℂ) (s : ℂ) (k : ℤ) :
+    correctedLogarithmWidth w h (s - (k : ℂ) * w) = correctedLogarithmWidth w h s - k := by
+  simp only [correctedLogarithmWidth_eq_correctedLogarithm, div_sub_int_mul_width w hw,
+    correctedLogarithm_sub_int]
+
+private theorem SpecialPeriods.TauCusp.exists_simplePole_logarithmic_lift_width (w : ℝ) (hw : 0 < w)
+    {a : ℂ → ℂ} (ha : AnalyticAt ℂ a 0) (ha0 : a 0 ≠ 0) {R r₀ : ℝ} (hR : 0 < R) (hr₀ : 0 < r₀) :
+    ∃ r > 0,
+      r < r₀ ∧
+        r < 1 ∧
+          ∃ h : ℂ → ℂ,
+            AnalyticOnNhd ℂ h (Metric.ball 0 r) ∧
+              h 0 = CuspUniformization.logarithm (1 / a 0) ∧
+                (∀ t ∈ Metric.ball 0 r,
+                    CuspUniformization.exponential (h t) = simplePoleUnit a t) ∧
+                  ∀ s ∈ {s : ℂ | ‖Function.Periodic.qParam w s‖ < r},
+                    CuspUniformization.exponential (correctedLogarithmWidth w h s) =
+                        simplePoleQ a (Function.Periodic.qParam w s) ∧
+                      0 < (correctedLogarithmWidth w h s).im ∧
+                        ‖CuspUniformization.exponential (correctedLogarithmWidth w h s)‖ < R ∧
+                          SpecialPeriods.modularJ
+                              (UpperHalfPlane.ofComplex (correctedLogarithmWidth w h s)) =
+                            a (Function.Periodic.qParam w s) / Function.Periodic.qParam w s := by
+  obtain ⟨r, hr, hrr₀, hr1, h, hh, hh0, he, hτ⟩ :=
+    exists_simplePole_logarithmic_lift ha ha0 hR hr₀
+  refine ⟨r, hr, hrr₀, hr1, h, hh, hh0, he, ?_⟩
+  intro s hs
+  have hwC : (w : ℂ) ≠ 0 := Complex.ofReal_ne_zero.mpr hw.ne'
+  obtain ⟨z, rfl⟩ := mul_right_surjective₀ hwC s
+  have hz : z ∈ SpecialPeriods.CuspFamily.logBase r := by
+    apply (SpecialPeriods.CuspFamily.mem_logBase r z).mpr
+    simpa only [Set.mem_ofPred_eq, qParam_eq_exponential_div, mul_div_cancel_right₀ _ hwC] using
+      hs
+  simpa only [correctedLogarithmWidth_eq_correctedLogarithm, qParam_eq_exponential_div,
+    mul_div_cancel_right₀ _ hwC] using hτ z hz
+
+private theorem SpecialPeriods.TauCusp.upperHalfPlane_ambient_analyticAt {τ : ℍ → ℍ}
+    (hτ : ContMDiff 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) ω τ) {s : ℂ} (hs : 0 < s.im) :
+    AnalyticAt ℂ (fun z : ℂ => (τ (UpperHalfPlane.ofComplex z) : ℂ)) s := by
+  have hc : ContMDiffAt 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) ω (fun z : ℂ => (τ (UpperHalfPlane.ofComplex z) : ℂ)) s :=
+    ((UpperHalfPlane.contMDiff_coe.comp hτ) (UpperHalfPlane.ofComplex s)).comp s
+      (UpperHalfPlane.contMDiffAt_ofComplex hs)
+  exact hc.contDiffAt.analyticAt
+
+private theorem SpecialPeriods.TauCusp.widthLogBase_convex (w : ℝ) {r : ℝ} (hr : 0 < r) :
+    Convex ℝ {s : ℂ | ‖Function.Periodic.qParam w s‖ < r} := by
+  have hset :
+    {s : ℂ | ‖Function.Periodic.qParam w s‖ < r} =
+      (LinearMap.mulRight ℝ (w : ℂ)⁻¹) ⁻¹' (SpecialPeriods.CuspFamily.logBase r : Set ℂ) := by
+    ext s
+    change
+      ‖Function.Periodic.qParam w s‖ < r ↔ s * (w : ℂ)⁻¹ ∈ SpecialPeriods.CuspFamily.logBase r
+    rw [SpecialPeriods.CuspFamily.mem_logBase, qParam_eq_exponential_div, div_eq_mul_inv]
+  rw [hset]
+  exact (logBase_convex r hr).linear_preimage (LinearMap.mulRight ℝ (w : ℂ)⁻¹)
+
+private theorem
+    SpecialPeriods.TauCusp.upperHalfPlane_of_qParam_norm_lt_one (w : ℝ) (hw : 0 < w) {s : ℂ}
+    (hs : ‖Function.Periodic.qParam w s‖ < 1) : 0 < s.im := by
+  have hsd : 0 < (s / (w : ℂ)).im :=
+    upperHalfPlane_of_exponential_norm_lt_one (by simpa only [qParam_eq_exponential_div] using hs)
+  rw [Complex.div_ofReal_im] at hsd
+  exact (div_pos_iff_of_pos_right hw).mp hsd
+
+private theorem SpecialPeriods.TauCusp.eqOn_correctedLogarithmWidth_of_eventuallyEq (w : ℝ) {r : ℝ}
+    (hr : 0 < r) {h τ : ℂ → ℂ} (hh : AnalyticOnNhd ℂ h (Metric.ball 0 r))
+    (hτ : AnalyticOnNhd ℂ τ {s : ℂ | ‖Function.Periodic.qParam w s‖ < r}) {a : ℂ}
+    (ha : ‖Function.Periodic.qParam w a‖ < r) (heq : τ =ᶠ[𝓝 a] correctedLogarithmWidth w h) :
+    Set.EqOn τ (correctedLogarithmWidth w h) {s : ℂ | ‖Function.Periodic.qParam w s‖ < r} :=
+  hτ.eqOn_of_preconnected_of_eventuallyEq (correctedLogarithmWidth_analyticOnNhd w hh)
+    (widthLogBase_convex w hr).isPreconnected ha heq
+
+private theorem SpecialPeriods.TauCusp.native_eqOn_correctedLogarithmWidth_of_eventuallyEq (w : ℝ)
+    (hw : 0 < w) {r : ℝ} (hr : 0 < r) (hr1 : r < 1) {h : ℂ → ℂ}
+    (hh : AnalyticOnNhd ℂ h (Metric.ball 0 r)) {τ : ℍ → ℍ} (hτ : ContMDiff 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) ω τ)
+    {a : ℂ} (ha : ‖Function.Periodic.qParam w a‖ < r)
+    (heq :
+      (fun z : ℂ => (τ (UpperHalfPlane.ofComplex z) : ℂ)) =ᶠ[𝓝 a] correctedLogarithmWidth w h) :
+    Set.EqOn (fun z : ℂ => (τ (UpperHalfPlane.ofComplex z) : ℂ)) (correctedLogarithmWidth w h)
+      {s : ℂ | ‖Function.Periodic.qParam w s‖ < r} := by
+  apply eqOn_correctedLogarithmWidth_of_eventuallyEq w hr hh ?_ ha heq
+  intro s hs
+  exact
+    upperHalfPlane_ambient_analyticAt hτ
+      (upperHalfPlane_of_qParam_norm_lt_one w hw (lt_trans hs hr1))
+
+private theorem SpecialPeriods.TauCusp.exists_native_source_cusp_point_mo1973_17243 (w : ℝ)
+    (hw : 0 < w) {r : ℝ} (hr : 0 < r) : ∃ a : ℍ, ‖Function.Periodic.qParam w (a : ℂ)‖ < r := by
+  obtain ⟨s, hs⟩ := logBase_set_nonempty (Min.min r 1) (lt_min hr zero_lt_one)
+  have hsn : ‖CuspUniformization.exponential s‖ < Min.min r 1 :=
+    (SpecialPeriods.CuspFamily.mem_logBase (Min.min r 1) s).mp hs
+  have hspos : 0 < s.im :=
+    upperHalfPlane_of_exponential_norm_lt_one (lt_of_lt_of_le hsn (min_le_right r 1))
+  have hswpos : 0 < (s * (w : ℂ)).im := by
+    simpa only [Complex.mul_im, Complex.ofReal_re, Complex.ofReal_im, MulZeroClass.mul_zero,
+      zero_add] using mul_pos hspos hw
+  refine ⟨⟨s * w, hswpos⟩, ?_⟩
+  have hwC : (w : ℂ) ≠ 0 := Complex.ofReal_ne_zero.mpr hw.ne'
+  simpa only [qParam_eq_exponential_div, mul_div_cancel_right₀ _ hwC] using
+    lt_of_lt_of_le hsn (min_le_left r 1)
+
+private theorem SpecialPeriods.TauCusp.sub_int_mul_width_im_pos_mo1973_17244 (w : ℝ) (k : ℤ)
+    {s : ℂ} (hs : 0 < s.im) : 0 < (s - (k : ℂ) * w).im := by
+  simpa only [Complex.sub_im, Complex.mul_im, Complex.intCast_im, Complex.ofReal_im,
+    MulZeroClass.mul_zero, MulZeroClass.zero_mul, add_zero, sub_zero] using hs
+
+private theorem
+    SpecialPeriods.TauCusp.global_native_sub_int_mul_width_of_cuspFormula (w : ℝ) (hw : 0 < w)
+    {r : ℝ} (hr : 0 < r) {h : ℂ → ℂ} {τ : ℍ → ℍ} (hτ : ContMDiff 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) ω τ)
+    (hcusp :
+      ∀ z : ℍ,
+        ‖Function.Periodic.qParam w (z : ℂ)‖ < r → (τ z : ℂ) = correctedLogarithmWidth w h z)
+    (k : ℤ) (z : ℍ) :
+    (τ (UpperHalfPlane.ofComplex ((z : ℂ) - (k : ℂ) * w)) : ℂ) = (τ z : ℂ) - k := by
+  have hleft :
+    AnalyticOnNhd ℂ (fun s : ℂ => (τ (UpperHalfPlane.ofComplex (s - (k : ℂ) * w)) : ℂ))
+      UpperHalfPlane.upperHalfPlaneSet := by
+    intro s hs
+    have hshift : AnalyticAt ℂ (fun t : ℂ => t - (k : ℂ) * w) s :=
+      analyticAt_id.sub analyticAt_const
+    exact
+      (upperHalfPlane_ambient_analyticAt hτ (sub_int_mul_width_im_pos_mo1973_17244 w k hs)).comp
+        (f := fun t : ℂ => t - (k : ℂ) * w) (x := s) hshift
+  have hright :
+    AnalyticOnNhd ℂ (fun s : ℂ => (τ (UpperHalfPlane.ofComplex s) : ℂ) - k)
+      UpperHalfPlane.upperHalfPlaneSet :=
+    fun s hs => (upperHalfPlane_ambient_analyticAt hτ hs).sub analyticAt_const
+  have hconnected : IsPreconnected UpperHalfPlane.upperHalfPlaneSet :=
+    ((convex_Ioi (0 : ℝ)).linear_preimage Complex.imLm).isPreconnected
+  obtain ⟨a, ha⟩ := exists_native_source_cusp_point_mo1973_17243 w hw hr
+  have hcuspAmbient {s : ℂ} (hs : 0 < s.im) (hsq : ‖Function.Periodic.qParam w s‖ < r) :
+    (τ (UpperHalfPlane.ofComplex s) : ℂ) = correctedLogarithmWidth w h s := by
+    simpa only [UpperHalfPlane.ofComplex_apply_of_im_pos hs] using hcusp ⟨s, hs⟩ hsq
+  have hqOpen : IsOpen {s : ℂ | ‖Function.Periodic.qParam w s‖ < r} :=
+    isOpen_lt (Function.Periodic.continuous_qParam (h := w)).norm continuous_const
+  have heq :
+    (fun s : ℂ => (τ (UpperHalfPlane.ofComplex (s - (k : ℂ) * w)) : ℂ)) =ᶠ[𝓝 (a : ℂ)]
+      (fun s : ℂ => (τ (UpperHalfPlane.ofComplex s) : ℂ) - k) := by
+    filter_upwards [hqOpen.mem_nhds ha,
+      UpperHalfPlane.isOpen_upperHalfPlaneSet.mem_nhds a.im_pos] with s hsq hs
+    have hskq : ‖Function.Periodic.qParam w (s - (k : ℂ) * w)‖ < r := by
+      rw [qParam_sub_int_mul_width w hw.ne']
+      exact hsq
+    rw [hcuspAmbient (sub_int_mul_width_im_pos_mo1973_17244 w k hs) hskq, hcuspAmbient hs hsq,
+      correctedLogarithmWidth_sub_int_mul_width w hw.ne']
+  have hglobal := hleft.eqOn_of_preconnected_of_eventuallyEq hright hconnected a.im_pos heq
+  have hz :
+    (τ (UpperHalfPlane.ofComplex ((z : ℂ) - (k : ℂ) * w)) : ℂ) =
+      (τ (UpperHalfPlane.ofComplex (z : ℂ)) : ℂ) - k :=
+    hglobal z.im_pos
+  simpa only [UpperHalfPlane.ofComplex_apply] using hz
+
+private theorem SpecialPeriods.TauCusp.simplePole_factorization {F : ℂ → ℂ} (hF : MeromorphicAt F 0)
+    (horder : meromorphicOrderAt F 0 = (-1 : ℤ)) :
+    ∃ a : ℂ → ℂ,
+      AnalyticAt ℂ a 0 ∧ a 0 ≠ 0 ∧ ∃ r > 0, ∀ t ∈ Metric.ball 0 r, t ≠ 0 → F t = a t / t := by
+  obtain ⟨a, ha, ha0, heq⟩ := (meromorphicOrderAt_eq_int_iff hF).mp horder
+  have heq' : ∀ᶠ t in 𝓝[≠] (0 : ℂ), F t = a t / t := by
+    filter_upwards [heq] with t ht
+    simpa [sub_zero, zpow_neg_one, smul_eq_mul, div_eq_mul_inv, mul_comm] using ht
+  rw [eventually_nhdsWithin_iff] at heq'
+  obtain ⟨r, hr, hball⟩ := Metric.mem_nhds_iff.mp heq'
+  exact ⟨a, ha, ha0, r, hr, fun t ht hne => hball ht hne⟩
+
+private theorem SpecialPeriods.TauCusp.simplePole_factorization_of_tendsto {F : ℂ → ℂ}
+    (hF : MeromorphicAt F 0) (horder : meromorphicOrderAt F 0 = (-1 : ℤ)) {c : ℂ}
+    (hc : Filter.Tendsto (fun t => t * F t) (𝓝[≠] 0) (𝓝 c)) :
+    ∃ a : ℂ → ℂ,
+      AnalyticAt ℂ a 0 ∧
+        a 0 ≠ 0 ∧ a 0 = c ∧ ∃ r > 0, ∀ t ∈ Metric.ball 0 r, t ≠ 0 → F t = a t / t := by
+  obtain ⟨a, ha, ha0, r, hr, hball⟩ := simplePole_factorization hF horder
+  have heq : (fun t => t * F t) =ᶠ[𝓝[≠] (0 : ℂ)] a := by
+    have hnear : ∀ᶠ t in 𝓝[≠] (0 : ℂ), t ∈ Metric.ball 0 r :=
+      nhdsWithin_le_nhds (Metric.ball_mem_nhds (0 : ℂ) hr)
+    filter_upwards [hnear, self_mem_nhdsWithin] with t ht hne
+    have ht0 : t ≠ 0 := hne
+    rw [hball t ht ht0]
+    field_simp [ht0]
+  have hvalue : a 0 = c := tendsto_nhds_unique ha.continuousAt.continuousWithinAt (hc.congr' heq)
+  exact ⟨a, ha, ha0, hvalue, r, hr, hball⟩
+
+private theorem SpecialPeriods.TauCusp.exists_upperHalfPlane_qParam_small_mo1973_17412 (w : ℝ)
+    (hw : 0 < w) (r : ℝ) (hr : 0 < r) (hr1 : r < 1) :
+    ∃ a : ℍ, ‖Function.Periodic.qParam w (a : ℂ)‖ < r := by
+  obtain ⟨s, hs⟩ := logBase_set_nonempty r hr
+  have hsNorm : ‖CuspUniformization.exponential s‖ < r :=
+    (SpecialPeriods.CuspFamily.mem_logBase r s).mp hs
+  have hsIm : 0 < s.im := upperHalfPlane_of_exponential_norm_lt_one (hsNorm.trans hr1)
+  have hwsIm : 0 < ((w : ℂ) * s).im := by
+    simpa only [Complex.mul_im, Complex.ofReal_re, Complex.ofReal_im, MulZeroClass.zero_mul,
+      add_zero] using mul_pos hw hsIm
+  refine ⟨⟨(w : ℂ) * s, hwsIm⟩, ?_⟩
+  change ‖Function.Periodic.qParam w ((w : ℂ) * s)‖ < r
+  have hwC : (w : ℂ) ≠ 0 := Complex.ofReal_ne_zero.mpr hw.ne'
+  rw [qParam_eq_exponential_div, mul_div_cancel_left₀ s hwC]
+  exact hsNorm
+
+private theorem SpecialPeriods.TauCusp.isOpen_qParam_norm_lt_mo1973_17413 (w r : ℝ) :
+    IsOpen {s : ℂ | ‖Function.Periodic.qParam w s‖ < r} :=
+  isOpen_lt (Function.Periodic.continuous_qParam (h := w)).norm continuous_const
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Threefold/SpecialPeriods5.lean b/LeanPool/HopfProblem/Threefold/SpecialPeriods5.lean
new file mode 100644
index 000000000..3073d007f
--- /dev/null
+++ b/LeanPool/HopfProblem/Threefold/SpecialPeriods5.lean
@@ -0,0 +1,165 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Uniformization.SpecialPeriods4
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods4
+
+/-!
+# Hopf problem: threefold · special periods 5
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem SpecialPeriods.TauCusp.exists_global_normalized_lift_of_meromorphic_cusp (F : ℍ → ℂ)
+    (hF : MDifferentiable 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) F)
+    (h₃ :
+      ∀ a : ℍ,
+        F a = 0 → ∃ k : ℕ, analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (a : ℂ) = (3 * k : ℕ))
+    (h₂ :
+      ∀ a : ℍ,
+        F a = 1728 →
+          ∃ k : ℕ,
+            analyticOrderAt (fun z => F (UpperHalfPlane.ofComplex z) - 1728) (a : ℂ) =
+              (2 * k : ℕ))
+    (w : ℝ) (hw : 0 < w) (Fc : ℂ → ℂ) (hFc : MeromorphicAt Fc 0)
+    (horder : meromorphicOrderAt Fc 0 = (-1 : ℤ)) {c : ℂ}
+    (hc : Filter.Tendsto (fun t => t * Fc t) (𝓝[≠] 0) (𝓝 c)) {r₀ : ℝ} (hr₀ : 0 < r₀)
+    (hsource :
+      ∀ z : ℍ,
+        ‖Function.Periodic.qParam w (z : ℂ)‖ < r₀ →
+          F z = Fc (Function.Periodic.qParam w (z : ℂ))) :
+    ∃ τ : ℍ → ℍ,
+      ContMDiff 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) ω τ ∧
+        (∀ z : ℍ, SpecialPeriods.modularJ (τ z) = F z) ∧
+          ∃ r > 0,
+            r < r₀ ∧
+              r < 1 ∧
+                ∃ h : ℂ → ℂ,
+                  AnalyticOnNhd ℂ h (Metric.ball 0 r) ∧
+                    h 0 = CuspUniformization.logarithm (1 / c) ∧
+                      ∀ z : ℍ,
+                        ‖Function.Periodic.qParam w (z : ℂ)‖ < r →
+                          (τ z : ℂ) = correctedLogarithmWidth w h (z : ℂ) := by
+  obtain ⟨a, ha, ha0, hac, rF, hrF, hfactor⟩ := simplePole_factorization_of_tendsto hFc horder hc
+  obtain ⟨r, hr, hrr, hr1, h, hh, hh0, _, hlift⟩ :=
+    exists_simplePole_logarithmic_lift_width w hw ha ha0 (R := 1) (r₀ := Min.min r₀ rF)
+      zero_lt_one (lt_min hr₀ hrF)
+  have hrr₀ : r < r₀ := lt_of_lt_of_le hrr (min_le_left r₀ rF)
+  have hrrF : r < rF := lt_of_lt_of_le hrr (min_le_right r₀ rF)
+  have hlocalJ (s : ℂ) (hs : ‖Function.Periodic.qParam w s‖ < r) :
+    SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (correctedLogarithmWidth w h s)) =
+      F (UpperHalfPlane.ofComplex s) := by
+    have hspos : 0 < s.im := upperHalfPlane_of_qParam_norm_lt_one w hw (hs.trans hr1)
+    have hqt : Function.Periodic.qParam w s ∈ Metric.ball (0 : ℂ) rF := by
+      simpa only [Metric.mem_ball, dist_zero_right] using hs.trans hrrF
+    have hfactorq :=
+      hfactor (Function.Periodic.qParam w s) hqt (Function.Periodic.qParam_ne_zero (h := w) s)
+    have hsourceq : F (UpperHalfPlane.ofComplex s) = Fc (Function.Periodic.qParam w s) := by
+      have he :=
+        hsource (UpperHalfPlane.ofComplex s)
+          (by simpa only [UpperHalfPlane.ofComplex_apply_of_im_pos hspos] using hs.trans hrr₀)
+      simpa only [UpperHalfPlane.ofComplex_apply_of_im_pos hspos] using he
+    exact (hlift s hs).2.2.2.trans (hfactorq.symm.trans hsourceq.symm)
+  obtain ⟨z₀, hz₀⟩ := exists_upperHalfPlane_qParam_small_mo1973_17412 w hw r hr hr1
+  have hJgerm :
+    (fun s =>
+        SpecialPeriods.modularJ
+          (UpperHalfPlane.ofComplex (correctedLogarithmWidth w h s))) =ᶠ[𝓝 (z₀ : ℂ)]
+      F ∘ UpperHalfPlane.ofComplex := by
+    filter_upwards [(isOpen_qParam_norm_lt_mo1973_17413 w r).mem_nhds hz₀] with s hs
+    exact hlocalJ s hs
+  obtain ⟨τ, hτ, hJ, hgerm⟩ :=
+    SpecialPeriods.ModularGermLift.exists_holomorphic_modularJ_lift_upperHalfPlane_extending F hF
+      h₃ h₂ z₀ (correctedLogarithmWidth w h) (correctedLogarithmWidth_analyticAt w hh hz₀)
+      (hlift z₀ hz₀).2.1 hJgerm
+  have hformula := native_eqOn_correctedLogarithmWidth_of_eventuallyEq w hw hr hr1 hh hτ hz₀ hgerm
+  refine ⟨τ, hτ, hJ, r, hr, hrr₀, hr1, h, hh, ?_, ?_⟩
+  · simpa only [hac] using hh0
+  · intro z hz
+    have hzEq :
+      (τ (UpperHalfPlane.ofComplex (z : ℂ)) : ℂ) = correctedLogarithmWidth w h (z : ℂ) :=
+      hformula hz
+    simpa only [UpperHalfPlane.ofComplex_apply] using hzEq
+
+public
+theorem SpecialPeriods.TauCusp.exists_simplePole_normalized_limit_mo1973_17415
+    {Fc : ℂ → ℂ} (hFc : MeromorphicAt Fc 0) (horder : meromorphicOrderAt Fc 0 = (-1 : ℤ)) :
+    ∃ c : ℂ, c ≠ 0 ∧ Filter.Tendsto (fun t => t * Fc t) (𝓝[≠] 0) (𝓝 c) := by
+  obtain ⟨a, ha, ha0, r, hr, hball⟩ := simplePole_factorization hFc horder
+  refine ⟨a 0, ha0, ?_⟩
+  have heq : (fun t => t * Fc t) =ᶠ[𝓝[≠] (0 : ℂ)] a := by
+    have hnear : ∀ᶠ t in 𝓝[≠] (0 : ℂ), t ∈ Metric.ball 0 r :=
+      nhdsWithin_le_nhds (Metric.ball_mem_nhds (0 : ℂ) hr)
+    filter_upwards [hnear, self_mem_nhdsWithin] with t ht hne
+    have ht0 : t ≠ 0 := hne
+    rw [hball t ht ht0]
+    field_simp [ht0]
+  exact ha.continuousAt.continuousWithinAt.congr' heq.symm
+
+private theorem SpecialPeriods.TauCusp.exists_global_normalized_lift_of_simplePole_cusp (F : ℍ → ℂ)
+    (hF : MDifferentiable 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) F)
+    (h₃ :
+      ∀ a : ℍ,
+        F a = 0 → ∃ k : ℕ, analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (a : ℂ) = (3 * k : ℕ))
+    (h₂ :
+      ∀ a : ℍ,
+        F a = 1728 →
+          ∃ k : ℕ,
+            analyticOrderAt (fun z => F (UpperHalfPlane.ofComplex z) - 1728) (a : ℂ) =
+              (2 * k : ℕ))
+    (w : ℝ) (hw : 0 < w) (Fc : ℂ → ℂ) (hFc : MeromorphicAt Fc 0)
+    (horder : meromorphicOrderAt Fc 0 = (-1 : ℤ)) {r₀ : ℝ} (hr₀ : 0 < r₀)
+    (hsource :
+      ∀ z : ℍ,
+        ‖Function.Periodic.qParam w (z : ℂ)‖ < r₀ →
+          F z = Fc (Function.Periodic.qParam w (z : ℂ))) :
+    ∃ c : ℂ,
+      c ≠ 0 ∧
+        Filter.Tendsto (fun t => t * Fc t) (𝓝[≠] 0) (𝓝 c) ∧
+          ∃ τ : ℍ → ℍ,
+            ContMDiff 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) ω τ ∧
+              (∀ z : ℍ, SpecialPeriods.modularJ (τ z) = F z) ∧
+                ∃ r > 0,
+                  r < r₀ ∧
+                    r < 1 ∧
+                      ∃ h : ℂ → ℂ,
+                        AnalyticOnNhd ℂ h (Metric.ball 0 r) ∧
+                          h 0 = CuspUniformization.logarithm (1 / c) ∧
+                            ∀ z : ℍ,
+                              ‖Function.Periodic.qParam w (z : ℂ)‖ < r →
+                                (τ z : ℂ) = correctedLogarithmWidth w h (z : ℂ) := by
+  obtain ⟨c, hc0, hc⟩ := exists_simplePole_normalized_limit_mo1973_17415 hFc horder
+  exact
+    ⟨c, hc0, hc,
+      exists_global_normalized_lift_of_meromorphic_cusp F hF h₃ h₂ w hw Fc hFc horder hc hr₀
+        hsource⟩
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Threefold/SpecialPeriods6.lean b/LeanPool/HopfProblem/Threefold/SpecialPeriods6.lean
new file mode 100644
index 000000000..f5f8f1692
--- /dev/null
+++ b/LeanPool/HopfProblem/Threefold/SpecialPeriods6.lean
@@ -0,0 +1,1302 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.PeriodFamily.Core2
+public import LeanPool.HopfProblem.CuspFibre.CuspCentralHomology4
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods3
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods4
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods5
+import all LeanPool.HopfProblem.PeriodFamily.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods6
+import all LeanPool.HopfProblem.PeriodFamily.Core2
+import all LeanPool.HopfProblem.CuspFibre.CuspCentralHomology4
+
+/-!
+# Hopf problem: threefold · special periods 6
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private structure SpecialPeriods.Construction.PeriodFunctions where
+  data : SpecialPeriods.BetaTorsor.Data
+  beta : ℍ → ℂ
+  beta_holomorphic : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω beta
+  beta_generators : data.GeneratorLaws beta
+  tau_cusp :
+    ∃ h : ℂ → ℂ,
+      AnalyticAt ℂ h 0 ∧
+        ∀ᶠ z in UpperHalfPlane.atImInfty,
+          (data.tau z : ℂ) =
+            (z : ℂ) / SpecialPeriods.Triangle.width + h (SpecialPeriods.Triangle.cuspQ z)
+  mu_cusp : SpecialPeriods.MuTorsor.CuspRegular data.mu
+  beta_cusp : SpecialPeriods.MuTorsor.CuspRegular (fun z => beta z + (data.tau z : ℂ))
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Construction.eventually_norm_cuspQ_lt_mo1973_18146 {r : ℝ}
+    (hr : 0 < r) : ∀ᶠ z in UpperHalfPlane.atImInfty, ‖SpecialPeriods.Triangle.cuspQ z‖ < r := by
+  have ht := SpecialPeriods.Triangle.cuspQ_tendsto_atImInfty.mono_right nhdsWithin_le_nhds
+  simpa only [Metric.mem_ball, dist_zero_right] using
+    ht.eventually (Metric.ball_mem_nhds (0 : ℂ) hr)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Construction.exists_periodFunctions_of_sphere
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere)) :
+    ∃ F : PeriodFunctions, F.data.tau = SpecialPeriods.TriangleSource.tauOfSphere π hπ h₀ h₁ := by
+  let τ := SpecialPeriods.TriangleSource.tauOfSphere π hπ h₀ h₁
+  have hτa := SpecialPeriods.TriangleSource.tauOfSphere_holomorphic π hπ h₀ h₁
+  have hτc := SpecialPeriods.TriangleSource.tauOfSphere_covariant π hπ h₀ h₁
+  have hJ := SpecialPeriods.TriangleSource.tauOfSphere_modular π hπ h₀ h₁
+  obtain ⟨r, hr, _, h, hh, hτformula⟩ := SpecialPeriods.TriangleSource.tauOfSphere_cusp π hπ h₀ h₁
+  have hh0 : AnalyticAt ℂ h 0 := hh 0 (Metric.mem_ball_self hr)
+  have hτformula' :
+    ∀ᶠ z in UpperHalfPlane.atImInfty,
+      (τ z : ℂ) = (z : ℂ) / SpecialPeriods.Triangle.width + h (SpecialPeriods.Triangle.cuspQ z) :=
+    by
+    filter_upwards [eventually_norm_cuspQ_lt_mo1973_18146 hr] with z hz
+    exact hτformula z hz
+  obtain ⟨ru, hru, u, hu, hu0, hqu⟩ :=
+    SpecialPeriods.TriangleSource.tauOfSphere_cusp_unit π hπ h₀ h₁
+  have hu0a : AnalyticAt ℂ u 0 := hu 0 (Metric.mem_ball_self hru)
+  have hqu' :
+    ∀ᶠ z in UpperHalfPlane.atImInfty,
+      Function.Periodic.qParam 1 (τ z) =
+        SpecialPeriods.Triangle.cuspQ z * u (SpecialPeriods.Triangle.cuspQ z) := by
+    filter_upwards [eventually_norm_cuspQ_lt_mo1973_18146 hru] with z hz
+    exact hqu z hz
+  obtain ⟨μ, hμ, _⟩ :=
+    SpecialPeriods.MuTorsor.exists_unique_solution π hπ h₀ h₁ hτc hτa hJ hu0a hu0 hqu'
+  let D : SpecialPeriods.BetaTorsor.Data :=
+    { tau := τ
+      mu := μ
+      tau_holomorphic := hτa
+      mu_holomorphic := hμ.holomorphic
+      tau_covariant := hτc
+      mu_one := hμ.generatorOne
+      mu_two := hμ.generatorTwo }
+  obtain ⟨β, b, hβ, hb, _, Y, hβformula⟩ := D.exists_solution_with_cusp_extension π hπ
+  have hβformula' :
+    ∀ᶠ z in UpperHalfPlane.atImInfty, β z + (D.tau z : ℂ) = b (SpecialPeriods.Triangle.cuspQ z) :=
+    by
+    apply (UpperHalfPlane.atImInfty_mem _).mpr
+    exact ⟨Y + 1, fun z hz => hβformula z (by linarith)⟩
+  exact
+    ⟨{  data := D
+        beta := β
+        beta_holomorphic := hβ.holomorphic
+        beta_generators := hβ.generators
+        tau_cusp := ⟨h, hh0, hτformula'⟩
+        mu_cusp := hμ.cuspRegular
+        beta_cusp := ⟨b, hb, hβformula'⟩ }, rfl⟩
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Construction.periodFunctionsOfSphere
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere)) :
+    PeriodFunctions :=
+  (exists_periodFunctions_of_sphere π hπ h₀ h₁).choose
+
+private theorem SpecialPeriods.Construction.triangle_invariant_of_generators {A : Type*} (f : ℍ → A)
+    (h₁ : ∀ z, f (SpecialPeriods.Triangle.generatorOneSL • z) = f z)
+    (h₂ : ∀ z, f (SpecialPeriods.Triangle.generatorTwoSL • z) = f z)
+    (g : SpecialPeriods.TriangleGroup) :
+    ∀ z, f (SpecialPeriods.triangleGeometricRepresentation g z) = f z := by
+  let := SpecialPeriods.triangleGeometricAction
+  have hg :
+    g ∈
+      Subgroup.closure
+        ({ SpecialPeriods.triangleGenerator₁, SpecialPeriods.triangleGenerator₂ } :
+          Set SpecialPeriods.TriangleGroup) := by
+    rw [SpecialPeriods.triangle_generators_generate]
+    trivial
+  change ∀ z, f (g • z) = f z
+  induction hg using Subgroup.closure_induction with
+  | mem a ha =>
+    rcases ha with rfl | rfl
+    · intro z
+      change
+        f (SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleGenerator₁ z) =
+          f z
+      simpa only [SpecialPeriods.triangleGeometricRepresentation_generator₁_apply] using h₁ z
+    · intro z
+      change
+        f (SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleGenerator₂ z) =
+          f z
+      simpa only [SpecialPeriods.triangleGeometricRepresentation_generator₂_apply] using h₂ z
+  | one => intro z; rw [one_smul]
+  | mul g h _ _ ihg ihh => intro z; rw [SemigroupAction.mul_smul, ihg, ihh]
+  | inv g _ ih =>
+    intro z
+    simpa only [smul_inv_smul] using (ih (g⁻¹ • z)).symm
+
+private theorem
+    SpecialPeriods.Construction.discriminant_invariant_of_generator_laws (P : ℍ → PeriodPoint)
+    (hτ : ∀ z, 0 < (P z).τ.im)
+    (h₁ : ∀ z, P (SpecialPeriods.Triangle.generatorOneSL • z) = (P z).step₁)
+    (h₂ : ∀ z, P (SpecialPeriods.Triangle.generatorTwoSL • z) = (P z).step₂) :
+    ∀ (g : SpecialPeriods.TriangleGroup) (z : ℍ),
+      (P (SpecialPeriods.triangleGeometricRepresentation g z)).discriminant =
+        (P z).discriminant := by
+  apply triangle_invariant_of_generators (fun z => (P z).discriminant)
+  · intro z
+    rw [h₁ z, PeriodPoint.step₁_discriminant (P z) (ne_of_gt (hτ z))]
+  · intro z
+    rw [h₂ z, PeriodPoint.step₂_discriminant (P z) (ne_of_gt (hτ z))]
+
+private theorem
+    SpecialPeriods.Construction.periodPoint_im_tau_pos (D : SpecialPeriods.BetaTorsor.Data)
+    (β : ℍ → ℂ) (z : ℍ) : 0 < (D.periodPoint β z).τ.im :=
+  (D.tau z).im_pos
+
+private theorem SpecialPeriods.Construction.periodPoint_generator₁_iff
+    (D : SpecialPeriods.BetaTorsor.Data) {β : ℍ → ℂ} (z : ℍ) :
+    D.periodPoint β (SpecialPeriods.Triangle.generatorOneSL • z) = (D.periodPoint β z).step₁ ↔
+      β (SpecialPeriods.Triangle.generatorOneSL • z) =
+        β z + SpecialPeriods.BetaTorsor.phiOne D.tau D.mu z := by
+  constructor
+  · intro h
+    have hb := congrArg PeriodPoint.β h
+    simpa only [SpecialPeriods.BetaTorsor.Data.periodPoint, PeriodPoint.step₁,
+      SpecialPeriods.BetaTorsor.phiOne, sub_eq_add_neg, add_assoc] using hb
+  · intro hb
+    apply PeriodPoint.ext
+    · exact D.tau_covariant.1 z
+    · exact D.mu_one z
+    · simpa only [SpecialPeriods.BetaTorsor.Data.periodPoint, PeriodPoint.step₁,
+        SpecialPeriods.BetaTorsor.phiOne, sub_eq_add_neg, add_assoc] using hb
+
+private theorem SpecialPeriods.Construction.periodPoint_generator₂_iff
+    (D : SpecialPeriods.BetaTorsor.Data) {β : ℍ → ℂ} (z : ℍ) :
+    D.periodPoint β (SpecialPeriods.Triangle.generatorTwoSL • z) = (D.periodPoint β z).step₂ ↔
+      β (SpecialPeriods.Triangle.generatorTwoSL • z) =
+        β z + SpecialPeriods.BetaTorsor.phiTwo D.tau D.mu z := by
+  constructor
+  · intro h
+    have hb := congrArg PeriodPoint.β h
+    simpa only [SpecialPeriods.BetaTorsor.Data.periodPoint, PeriodPoint.step₂,
+      SpecialPeriods.BetaTorsor.phiTwo, sub_eq_add_neg, add_assoc] using hb
+  · intro hb
+    apply PeriodPoint.ext
+    · exact D.tau_covariant.2 z
+    · exact D.mu_two z
+    · simpa only [SpecialPeriods.BetaTorsor.Data.periodPoint, PeriodPoint.step₂,
+        SpecialPeriods.BetaTorsor.phiTwo, sub_eq_add_neg, add_assoc] using hb
+
+private theorem
+    SpecialPeriods.Construction.periodPoint_generator₁ (D : SpecialPeriods.BetaTorsor.Data)
+    {β : ℍ → ℂ} (hβ : D.GeneratorLaws β) (z : ℍ) :
+    D.periodPoint β (SpecialPeriods.Triangle.generatorOneSL • z) = (D.periodPoint β z).step₁ :=
+  (periodPoint_generator₁_iff D z).mpr (hβ.1 z)
+
+private theorem
+    SpecialPeriods.Construction.periodPoint_generator₂ (D : SpecialPeriods.BetaTorsor.Data)
+    {β : ℍ → ℂ} (hβ : D.GeneratorLaws β) (z : ℍ) :
+    D.periodPoint β (SpecialPeriods.Triangle.generatorTwoSL • z) = (D.periodPoint β z).step₂ :=
+  (periodPoint_generator₂_iff D z).mpr (hβ.2 z)
+
+private theorem
+    SpecialPeriods.Construction.continuous_discriminant (D : SpecialPeriods.BetaTorsor.Data)
+    {β : ℍ → ℂ} (hβ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω β) :
+    Continuous (fun z => (D.periodPoint β z).discriminant) := by
+  exact
+    continuousOn_univ.mp
+      (PeriodPoint.continuousOn_discriminant (D.periodPoint β)
+        (UpperHalfPlane.contMDiff_coe.comp D.tau_holomorphic).continuous.continuousOn
+        D.mu_holomorphic.continuous.continuousOn hβ.continuous.continuousOn
+        (fun z _ => (D.tau z).im_pos.ne'))
+
+private theorem
+    SpecialPeriods.Construction.discriminant_invariant (D : SpecialPeriods.BetaTorsor.Data)
+    {β : ℍ → ℂ} (hβ : D.GeneratorLaws β) (g : SpecialPeriods.TriangleGroup) (z : ℍ) :
+    (D.periodPoint β (SpecialPeriods.triangleGeometricRepresentation g z)).discriminant =
+      (D.periodPoint β z).discriminant :=
+  discriminant_invariant_of_generator_laws (D.periodPoint β) (periodPoint_im_tau_pos D β)
+    (periodPoint_generator₁ D hβ) (periodPoint_generator₂ D hβ) g z
+
+private theorem
+    SpecialPeriods.Construction.periodMap_generator₁ (D : SpecialPeriods.BetaTorsor.Data)
+    {β : ℍ → ℂ} (hβ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω β) (hAdm : ∀ z : ℍ, (D.periodPoint β z).Admissible)
+    (hgen : D.GeneratorLaws β) (z : ℍ) :
+    (D.periodMap β hβ hAdm).point (SpecialPeriods.Triangle.generatorOneSL • z) =
+      ((D.periodMap β hβ hAdm).point z).step₁ :=
+  Subtype.ext (periodPoint_generator₁ D hgen z)
+
+private theorem
+    SpecialPeriods.Construction.periodMap_generator₂ (D : SpecialPeriods.BetaTorsor.Data)
+    {β : ℍ → ℂ} (hβ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω β) (hAdm : ∀ z : ℍ, (D.periodPoint β z).Admissible)
+    (hgen : D.GeneratorLaws β) (z : ℍ) :
+    (D.periodMap β hβ hAdm).point (SpecialPeriods.Triangle.generatorTwoSL • z) =
+      ((D.periodMap β hβ hAdm).point z).step₂ :=
+  Subtype.ext (periodPoint_generator₂ D hgen z)
+
+private theorem SpecialPeriods.Construction.shiftedPeriodMap_generator₁
+    (D : SpecialPeriods.BetaTorsor.Data) {β : ℍ → ℂ} (hβ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω β) (c : ℂ)
+    (hAdm : ∀ z : ℍ, ((D.periodPoint β z).shiftBeta c).Admissible) (hgen : D.GeneratorLaws β)
+    (z : ℍ) :
+    (D.shiftedPeriodMap β hβ c hAdm).point (SpecialPeriods.Triangle.generatorOneSL • z) =
+      ((D.shiftedPeriodMap β hβ c hAdm).point z).step₁ :=
+  periodMap_generator₁ D (hβ.add contMDiff_const) hAdm (hgen.add_const D c) z
+
+private theorem SpecialPeriods.Construction.shiftedPeriodMap_generator₂
+    (D : SpecialPeriods.BetaTorsor.Data) {β : ℍ → ℂ} (hβ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω β) (c : ℂ)
+    (hAdm : ∀ z : ℍ, ((D.periodPoint β z).shiftBeta c).Admissible) (hgen : D.GeneratorLaws β)
+    (z : ℍ) :
+    (D.shiftedPeriodMap β hβ c hAdm).point (SpecialPeriods.Triangle.generatorTwoSL • z) =
+      ((D.shiftedPeriodMap β hβ c hAdm).point z).step₂ :=
+  periodMap_generator₂ D (hβ.add contMDiff_const) hAdm (hgen.add_const D c) z
+
+private theorem SpecialPeriods.Construction.exponential_normalized_eq_cuspQ (z : ℍ) :
+    CuspUniformization.exponential ((z : ℂ) / SpecialPeriods.Triangle.width) =
+      SpecialPeriods.Triangle.cuspQ z := by
+  simp only [CuspUniformization.exponential, SpecialPeriods.Triangle.cuspQ_eq_exp, mul_div_assoc]
+
+private theorem
+    SpecialPeriods.Construction.cusp_analytic_tendsto {f : ℂ → ℂ} (hf : AnalyticAt ℂ f 0) :
+    Filter.Tendsto (fun z : ℍ => f (SpecialPeriods.Triangle.cuspQ z)) UpperHalfPlane.atImInfty
+      (𝓝 (f 0)) :=
+  hf.continuousAt.tendsto.comp
+    (SpecialPeriods.Triangle.cuspQ_tendsto_atImInfty.mono_right nhdsWithin_le_nhds)
+
+private theorem
+    SpecialPeriods.Construction.tau_im_tendsto_atTop_of_cusp_formula {τ : ℍ → ℍ} {h : ℂ → ℂ}
+    (hh : AnalyticAt ℂ h 0)
+    (hτ :
+      ∀ᶠ z in UpperHalfPlane.atImInfty,
+        (τ z : ℂ) =
+          (z : ℂ) / SpecialPeriods.Triangle.width + h (SpecialPeriods.Triangle.cuspQ z)) :
+    Filter.Tendsto (fun z : ℍ => (τ z).im) UpperHalfPlane.atImInfty Filter.atTop := by
+  have hheight :
+    Filter.Tendsto (fun z : ℍ => z.im / SpecialPeriods.Triangle.width) UpperHalfPlane.atImInfty
+      Filter.atTop :=
+    (show Filter.Tendsto UpperHalfPlane.im UpperHalfPlane.atImInfty Filter.atTop from
+          Filter.tendsto_comap).atTop_div_const
+      SpecialPeriods.Triangle.width_pos
+  have hremainder :
+    Filter.Tendsto (fun z : ℍ => (h (SpecialPeriods.Triangle.cuspQ z)).im)
+      UpperHalfPlane.atImInfty (𝓝 (h 0).im) :=
+    Complex.continuous_im.continuousAt.tendsto.comp (cusp_analytic_tendsto hh)
+  apply (hheight.atTop_add hremainder).congr'
+  filter_upwards [hτ] with z hz
+  simpa only [Complex.add_im, Complex.div_ofReal_im, UpperHalfPlane.coe_im] using
+    (congrArg Complex.im hz).symm
+
+private theorem SpecialPeriods.Construction.periodPoint_eventually_eq_cuspPeriodPoint {τ : ℍ → ℍ}
+    {μ β : ℍ → ℂ} {m b h : ℂ → ℂ}
+    (hτ :
+      ∀ᶠ z in UpperHalfPlane.atImInfty,
+        (τ z : ℂ) = (z : ℂ) / SpecialPeriods.Triangle.width + h (SpecialPeriods.Triangle.cuspQ z))
+    (hμ : ∀ᶠ z in UpperHalfPlane.atImInfty, μ z = m (SpecialPeriods.Triangle.cuspQ z))
+    (hβ :
+      ∀ᶠ z in UpperHalfPlane.atImInfty, β z + (τ z : ℂ) = b (SpecialPeriods.Triangle.cuspQ z)) :
+    ∀ᶠ z in UpperHalfPlane.atImInfty,
+      (⟨(τ z : ℂ), μ z, β z⟩ : PeriodPoint) =
+        SpecialPeriods.cuspPeriodPoint m b h ((z : ℂ) / SpecialPeriods.Triangle.width) := by
+  filter_upwards [hτ, hμ, hβ] with z hτz hμz hβz
+  apply PeriodPoint.ext
+  · simpa only [SpecialPeriods.cuspPeriodPoint, exponential_normalized_eq_cuspQ] using hτz
+  · simpa only [SpecialPeriods.cuspPeriodPoint, exponential_normalized_eq_cuspQ] using hμz
+  · change
+      β z =
+        b (CuspUniformization.exponential ((z : ℂ) / SpecialPeriods.Triangle.width)) -
+            (z : ℂ) / SpecialPeriods.Triangle.width -
+          h (CuspUniformization.exponential ((z : ℂ) / SpecialPeriods.Triangle.width))
+    rw [exponential_normalized_eq_cuspQ]
+    calc
+      β z = b (SpecialPeriods.Triangle.cuspQ z) - (τ z : ℂ) := eq_sub_of_add_eq hβz
+      _ =
+          b (SpecialPeriods.Triangle.cuspQ z) - (z : ℂ) / SpecialPeriods.Triangle.width -
+            h (SpecialPeriods.Triangle.cuspQ z) := by
+        rw [hτz]
+        ring
+
+private theorem SpecialPeriods.Construction.eventual_cuspQ_radius {P : ℍ → Prop}
+    (hP : ∀ᶠ z in UpperHalfPlane.atImInfty, P z) :
+    ∃ r : ℝ, 0 < r ∧ ∀ z : ℍ, ‖SpecialPeriods.Triangle.cuspQ z‖ < r → P z := by
+  obtain ⟨Y, hY⟩ := (UpperHalfPlane.atImInfty_mem _).mp hP
+  refine ⟨Real.exp (-2 * Real.pi * Y / SpecialPeriods.Triangle.width), Real.exp_pos _, ?_⟩
+  intro z hz
+  exact hY z ((SpecialPeriods.Triangle.cuspQ_norm_lt_exp_iff Y z).mp hz).le
+
+private theorem SpecialPeriods.Construction.eventual_cuspQ_radius_lt {P : ℍ → Prop} {r₀ : ℝ}
+    (hr₀ : 0 < r₀) (hP : ∀ᶠ z in UpperHalfPlane.atImInfty, P z) :
+    ∃ r : ℝ, 0 < r ∧ r < r₀ ∧ ∀ z : ℍ, ‖SpecialPeriods.Triangle.cuspQ z‖ < r → P z := by
+  obtain ⟨r, hr, h⟩ := eventual_cuspQ_radius hP
+  refine
+    ⟨Min.min r (r₀ / 2), lt_min hr (half_pos hr₀), (min_le_right _ _).trans_lt (half_lt_self hr₀),
+      ?_⟩
+  intro z hz
+  exact h z (hz.trans_le (min_le_left _ _))
+
+private theorem SpecialPeriods.Construction.beta_add_const_cusp_formula {τ : ℍ → ℍ} {β : ℍ → ℂ}
+    {b : ℂ → ℂ}
+    (hβ : ∀ᶠ z in UpperHalfPlane.atImInfty, β z + (τ z : ℂ) = b (SpecialPeriods.Triangle.cuspQ z))
+    (c : ℂ) :
+    ∀ᶠ z in UpperHalfPlane.atImInfty,
+      (β z + c) + (τ z : ℂ) = (fun q => b q + c) (SpecialPeriods.Triangle.cuspQ z) := by
+  filter_upwards [hβ] with z hz
+  simpa only [add_right_comm] using congrArg (fun w : ℂ => w + c) hz
+
+private def SpecialPeriods.Construction.orbitDescend (f : ℍ → ℝ)
+    (hinv :
+      ∀ (g : SpecialPeriods.TriangleGroup) (z : ℍ),
+        f (SpecialPeriods.triangleGeometricRepresentation g z) = f z) :
+    SpecialPeriods.TriangleOrbitSpace → ℝ :=
+  Quotient.lift f fun x y hxy =>
+    by
+    change
+      ∃ g : SpecialPeriods.TriangleGroup,
+        SpecialPeriods.triangleGeometricRepresentation g y = x at hxy
+    obtain ⟨g, hg⟩ := hxy
+    exact (congrArg f hg).symm.trans (hinv g y)
+
+private theorem SpecialPeriods.Construction.orbitDescend_continuous (f : ℍ → ℝ)
+    (hinv :
+      ∀ (g : SpecialPeriods.TriangleGroup) (z : ℍ),
+        f (SpecialPeriods.triangleGeometricRepresentation g z) = f z)
+    (hf : Continuous f) : Continuous (orbitDescend f hinv) :=
+  hf.quotient_lift _
+
+private def SpecialPeriods.Construction.compactDescend (f : ℍ → ℝ)
+    (hinv :
+      ∀ (g : SpecialPeriods.TriangleGroup) (z : ℍ),
+        f (SpecialPeriods.triangleGeometricRepresentation g z) = f z)
+    (c : ℝ) : SpecialPeriods.TriangleCompactifiedOrbitSpace → ℝ :=
+  OnePoint.rec c (orbitDescend f hinv)
+
+@[simp]
+private theorem SpecialPeriods.Construction.compactDescend_projection (f : ℍ → ℝ)
+    (hinv :
+      ∀ (g : SpecialPeriods.TriangleGroup) (z : ℍ),
+        f (SpecialPeriods.triangleGeometricRepresentation g z) = f z)
+    (c : ℝ) (z : ℍ) :
+    compactDescend f hinv c
+        (SpecialPeriods.triangleOpenInclusion (SpecialPeriods.triangleOrbitProjection z)) =
+      f z :=
+  rfl
+
+private theorem SpecialPeriods.Construction.compactDescend_continuousAt_openInclusion (f : ℍ → ℝ)
+    (hinv :
+      ∀ (g : SpecialPeriods.TriangleGroup) (z : ℍ),
+        f (SpecialPeriods.triangleGeometricRepresentation g z) = f z)
+    (c : ℝ) (hf : Continuous f) (q : SpecialPeriods.TriangleOrbitSpace) :
+    ContinuousAt (compactDescend f hinv c) (SpecialPeriods.triangleOpenInclusion q) :=
+  OnePoint.continuousAt_coe.mpr (orbitDescend_continuous f hinv hf).continuousAt
+
+private theorem SpecialPeriods.Construction.compactDescend_continuousOn (f : ℍ → ℝ)
+    (hinv :
+      ∀ (g : SpecialPeriods.TriangleGroup) (z : ℍ),
+        f (SpecialPeriods.triangleGeometricRepresentation g z) = f z)
+    (c : ℝ) (hf : Continuous f) :
+    ContinuousOn (compactDescend f hinv c)
+      ({ SpecialPeriods.triangleCuspPoint } :
+          Set SpecialPeriods.TriangleCompactifiedOrbitSpace)ᶜ := by
+  intro x hx
+  induction x using OnePoint.rec with
+  | infty => exact (hx rfl).elim
+  | coe q => exact (compactDescend_continuousAt_openInclusion f hinv c hf q).continuousWithinAt
+
+private theorem SpecialPeriods.Construction.compactDescend_eventually_of_atImInfty (f : ℍ → ℝ)
+    (hinv :
+      ∀ (g : SpecialPeriods.TriangleGroup) (z : ℍ),
+        f (SpecialPeriods.triangleGeometricRepresentation g z) = f z)
+    (c : ℝ) (P : ℝ → Prop) (hP : ∀ᶠ z in UpperHalfPlane.atImInfty, P (f z)) :
+    ∀ᶠ x in 𝓝[≠] SpecialPeriods.triangleCuspPoint, P (compactDescend f hinv c x) := by
+  obtain ⟨Y, hY⟩ := (UpperHalfPlane.atImInfty_mem _).mp hP
+  filter_upwards [nhdsWithin_le_nhds (SpecialPeriods.Triangle.cuspNeighborhood_mem_nhds Y),
+    self_mem_nhdsWithin] with x hx hxne
+  induction x using OnePoint.rec with
+  | infty => exact (hxne rfl).elim
+  | coe
+    q =>
+    obtain ⟨z, hz, rfl⟩ :=
+      (SpecialPeriods.Triangle.mem_cuspImage Y q).mp
+        ((SpecialPeriods.Triangle.openInclusion_mem_cuspNeighborhood Y q).mp hx)
+    exact hY z hz.le
+
+private theorem SpecialPeriods.Construction.compactDescend_tendsto_atBot (f : ℍ → ℝ)
+    (hinv :
+      ∀ (g : SpecialPeriods.TriangleGroup) (z : ℍ),
+        f (SpecialPeriods.triangleGeometricRepresentation g z) = f z)
+    (c : ℝ) (hlim : Filter.Tendsto f UpperHalfPlane.atImInfty Filter.atBot) :
+    Filter.Tendsto (compactDescend f hinv c) (𝓝[≠] SpecialPeriods.triangleCuspPoint)
+      Filter.atBot := by
+  refine Filter.tendsto_atBot.mpr fun R => ?_
+  exact
+    compactDescend_eventually_of_atImInfty f hinv c (fun t => t ≤ R) (hlim.eventually_le_atBot R)
+
+private theorem
+    SpecialPeriods.Construction.bddAbove_range_of_triangle_invariant_tendsto_atBot (f : ℍ → ℝ)
+    (hf : Continuous f)
+    (hinv :
+      ∀ (g : SpecialPeriods.TriangleGroup) (z : ℍ),
+        f (SpecialPeriods.triangleGeometricRepresentation g z) = f z)
+    (hlim : Filter.Tendsto f UpperHalfPlane.atImInfty Filter.atBot) : BddAbove (Set.range f) := by
+  apply
+    (SpecialPeriods.bddAbove_image_punctured_of_tendsto_atBot SpecialPeriods.triangleCuspPoint
+        (compactDescend f hinv 0) (compactDescend_continuousOn f hinv 0 hf)
+        (compactDescend_tendsto_atBot f hinv 0 hlim)).mono
+  rintro _ ⟨z, rfl⟩
+  exact
+    ⟨SpecialPeriods.triangleOpenInclusion (SpecialPeriods.triangleOrbitProjection z),
+      SpecialPeriods.triangleOpenInclusion_ne_cusp _, compactDescend_projection f hinv 0 z⟩
+
+private theorem SpecialPeriods.Construction.PeriodFunctions.tau_im_tendsto_atTop
+    (F : SpecialPeriods.Construction.PeriodFunctions) :
+    Filter.Tendsto (fun z : ℍ => (F.data.tau z).im) UpperHalfPlane.atImInfty Filter.atTop := by
+  obtain ⟨h, hh, hτ⟩ := F.tau_cusp
+  exact SpecialPeriods.Construction.tau_im_tendsto_atTop_of_cusp_formula hh hτ
+
+private theorem SpecialPeriods.Construction.PeriodFunctions.beta_add_tau_im_eventually_bounded
+    (F : SpecialPeriods.Construction.PeriodFunctions) :
+    ∃ M : ℝ, ∀ᶠ z in UpperHalfPlane.atImInfty, (F.beta z + (F.data.tau z : ℂ)).im ≤ M := by
+  obtain ⟨M, Y, hM⟩ := UpperHalfPlane.isBoundedAtImInfty_iff.mp F.beta_cusp.bounded
+  refine ⟨M, (UpperHalfPlane.atImInfty_mem _).mpr ⟨Y, ?_⟩⟩
+  intro z hz
+  exact ((le_abs_self _).trans (Complex.abs_im_le_norm _)).trans (hM z hz)
+
+private theorem SpecialPeriods.Construction.PeriodFunctions.discriminant_tendsto_atBot
+    (F : SpecialPeriods.Construction.PeriodFunctions) :
+    Filter.Tendsto (fun z => (F.data.periodPoint F.beta z).discriminant) UpperHalfPlane.atImInfty
+      Filter.atBot :=
+  PeriodPoint.tendsto_discriminant_atBot (F.data.periodPoint F.beta)
+    (Filter.Eventually.of_forall fun z => (F.data.tau z).im_pos) F.tau_im_tendsto_atTop
+    F.beta_add_tau_im_eventually_bounded
+
+private theorem SpecialPeriods.Construction.PeriodFunctions.discriminant_bddAbove
+    (F : SpecialPeriods.Construction.PeriodFunctions) :
+    BddAbove (Set.range fun z => (F.data.periodPoint F.beta z).discriminant) :=
+  SpecialPeriods.Construction.bddAbove_range_of_triangle_invariant_tendsto_atBot _
+    (SpecialPeriods.Construction.continuous_discriminant F.data F.beta_holomorphic)
+    (SpecialPeriods.Construction.discriminant_invariant F.data F.beta_generators)
+    F.discriminant_tendsto_atBot
+
+private theorem SpecialPeriods.Construction.PeriodFunctions.exists_negative_imaginary_shift
+    (F : SpecialPeriods.Construction.PeriodFunctions) :
+    ∃ M : ℝ,
+      0 < M ∧
+        ∀ z : ℍ, ((F.data.periodPoint F.beta z).shiftBeta (-((M : ℂ) * Complex.I))).Admissible :=
+  PeriodPoint.exists_negative_imaginary_shift_of_bddAbove (F.data.periodPoint F.beta)
+    (fun z => (F.data.tau z).im_pos) F.discriminant_bddAbove
+
+private def SpecialPeriods.Construction.PeriodFunctions.shiftHeight
+    (F : SpecialPeriods.Construction.PeriodFunctions) : ℝ :=
+  F.exists_negative_imaginary_shift.choose
+
+private def SpecialPeriods.Construction.PeriodFunctions.shiftConstant
+    (F : SpecialPeriods.Construction.PeriodFunctions) : ℂ :=
+  -((F.shiftHeight : ℂ) * Complex.I)
+
+private theorem SpecialPeriods.Construction.PeriodFunctions.shifted_admissible
+    (F : SpecialPeriods.Construction.PeriodFunctions) (z : ℍ) :
+    ((F.data.periodPoint F.beta z).shiftBeta F.shiftConstant).Admissible :=
+  F.exists_negative_imaginary_shift.choose_spec.2 z
+
+private def SpecialPeriods.Construction.PeriodFunctions.admissiblePeriods
+    (F : SpecialPeriods.Construction.PeriodFunctions) : HolomorphicPeriodMap ℂ ℍ :=
+  F.data.shiftedPeriodMap F.beta F.beta_holomorphic F.shiftConstant F.shifted_admissible
+
+@[simp]
+private theorem SpecialPeriods.Construction.PeriodFunctions.admissiblePeriods_tau
+    (F : SpecialPeriods.Construction.PeriodFunctions) (z : ℍ) :
+    (F.admissiblePeriods.point z).val.τ = (F.data.tau z : ℂ) :=
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.Construction.PeriodFunctions.admissiblePeriods_beta
+    (F : SpecialPeriods.Construction.PeriodFunctions) (z : ℍ) :
+    (F.admissiblePeriods.point z).val.β = F.beta z + F.shiftConstant :=
+  rfl
+
+private theorem SpecialPeriods.Construction.PeriodFunctions.admissiblePeriods_generator₁
+    (F : SpecialPeriods.Construction.PeriodFunctions) (z : ℍ) :
+    F.admissiblePeriods.point (SpecialPeriods.Triangle.generatorOneSL • z) =
+      (F.admissiblePeriods.point z).step₁ :=
+  SpecialPeriods.Construction.shiftedPeriodMap_generator₁ F.data F.beta_holomorphic
+    F.shiftConstant F.shifted_admissible F.beta_generators z
+
+private theorem SpecialPeriods.Construction.PeriodFunctions.admissiblePeriods_generator₂
+    (F : SpecialPeriods.Construction.PeriodFunctions) (z : ℍ) :
+    F.admissiblePeriods.point (SpecialPeriods.Triangle.generatorTwoSL • z) =
+      (F.admissiblePeriods.point z).step₂ :=
+  SpecialPeriods.Construction.shiftedPeriodMap_generator₂ F.data F.beta_holomorphic
+    F.shiftConstant F.shifted_admissible F.beta_generators z
+
+private theorem SpecialPeriods.Construction.PeriodFunctions.admissiblePeriods_beta_cusp
+    (F : SpecialPeriods.Construction.PeriodFunctions) :
+    SpecialPeriods.MuTorsor.CuspRegular
+      (fun z => (F.admissiblePeriods.point z).val.β + (F.admissiblePeriods.point z).val.τ) := by
+  obtain ⟨b, hb, hβ⟩ := F.beta_cusp
+  exact
+    ⟨fun q => b q + F.shiftConstant, hb.add analyticAt_const,
+      SpecialPeriods.Construction.beta_add_const_cusp_formula hβ F.shiftConstant⟩
+
+private theorem SpecialPeriods.Construction.PeriodFunctions.exists_cusp_data
+    (F : SpecialPeriods.Construction.PeriodFunctions) :
+    ∃ C : SpecialPeriods.CuspFamily.Data,
+      ∀ z : ℍ,
+        ‖SpecialPeriods.Triangle.cuspQ z‖ < C.radius →
+          (F.admissiblePeriods.point z).val =
+            SpecialPeriods.cuspPeriodPoint C.μ C.b C.h
+              ((z : ℂ) / SpecialPeriods.Triangle.width) := by
+  obtain ⟨h, hh, hτ⟩ := F.tau_cusp
+  obtain ⟨m, hm, hμ⟩ := F.mu_cusp
+  obtain ⟨b, hb, hβ⟩ := F.admissiblePeriods_beta_cusp
+  have hβ' :
+    ∀ᶠ z in UpperHalfPlane.atImInfty,
+      (F.beta z + F.shiftConstant) + (F.data.tau z : ℂ) = b (SpecialPeriods.Triangle.cuspQ z) := by
+    simpa only [admissiblePeriods_beta, admissiblePeriods_tau] using hβ
+  have hpoint :
+    ∀ᶠ z in UpperHalfPlane.atImInfty,
+      (F.admissiblePeriods.point z).val =
+        SpecialPeriods.cuspPeriodPoint m b h ((z : ℂ) / SpecialPeriods.Triangle.width) :=
+    SpecialPeriods.Construction.periodPoint_eventually_eq_cuspPeriodPoint hτ hμ hβ'
+  obtain ⟨ε, hε, hε1, hR, hC⟩ :=
+    SpecialPeriods.exists_cuspCorrection_admissible_radius_of_analyticAt hm hb hh
+  obtain ⟨r, hr, hrε, hmatch⟩ := SpecialPeriods.Construction.eventual_cuspQ_radius_lt hε hpoint
+  refine
+    ⟨{  μ := m
+        b := b
+        h := h
+        radius := r
+        radius_pos := hr
+        radius_lt_one := hrε.trans hε1
+        holomorphic := fun i j => (hC i j).mono (Metric.ball_subset_ball hrε.le)
+        smallDrift := fun t ht0 htr => hR t ht0 (htr.trans hrε) }, hmatch⟩
+
+private def SpecialPeriods.Construction.PeriodFunctions.cuspData
+    (F : SpecialPeriods.Construction.PeriodFunctions) : SpecialPeriods.CuspFamily.Data :=
+  F.exists_cusp_data.choose
+
+private theorem SpecialPeriods.Construction.PeriodFunctions.cuspData_periodPoint
+    (F : SpecialPeriods.Construction.PeriodFunctions) (z : ℍ)
+    (hz : ‖SpecialPeriods.Triangle.cuspQ z‖ < F.cuspData.radius) :
+    (F.admissiblePeriods.point z).val =
+      SpecialPeriods.cuspPeriodPoint F.cuspData.μ F.cuspData.b F.cuspData.h
+        ((z : ℂ) / SpecialPeriods.Triangle.width) :=
+  F.exists_cusp_data.choose_spec z hz
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Construction.periodMapOfSphere
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere)) :
+    HolomorphicPeriodMap ℂ ℍ :=
+  (periodFunctionsOfSphere π hπ h₀ h₁).admissiblePeriods
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Construction.periodMapOfSphere_generator₁
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere))
+    (z : ℍ) :
+    (periodMapOfSphere π hπ h₀ h₁).point (SpecialPeriods.Triangle.generatorOneSL • z) =
+      ((periodMapOfSphere π hπ h₀ h₁).point z).step₁ :=
+  (periodFunctionsOfSphere π hπ h₀ h₁).admissiblePeriods_generator₁ z
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Construction.periodMapOfSphere_generator₂
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere))
+    (z : ℍ) :
+    (periodMapOfSphere π hπ h₀ h₁).point (SpecialPeriods.Triangle.generatorTwoSL • z) =
+      ((periodMapOfSphere π hπ h₀ h₁).point z).step₂ :=
+  (periodFunctionsOfSphere π hπ h₀ h₁).admissiblePeriods_generator₂ z
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Construction.cuspDataOfSphere
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere)) :
+    SpecialPeriods.CuspFamily.Data :=
+  (periodFunctionsOfSphere π hπ h₀ h₁).cuspData
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Construction.cuspDataOfSphere_periodPoint
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere))
+    (z : ℍ) (hz : ‖SpecialPeriods.Triangle.cuspQ z‖ < (cuspDataOfSphere π hπ h₀ h₁).radius) :
+    ((periodMapOfSphere π hπ h₀ h₁).point z).val =
+      SpecialPeriods.cuspPeriodPoint (cuspDataOfSphere π hπ h₀ h₁).μ
+        (cuspDataOfSphere π hπ h₀ h₁).b (cuspDataOfSphere π hπ h₀ h₁).h
+        ((z : ℂ) / SpecialPeriods.Triangle.width) :=
+  (periodFunctionsOfSphere π hπ h₀ h₁).cuspData_periodPoint z hz
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private structure SpecialPeriods.Threefold.BaseCover where
+  radius : Puncture → ℝ
+  radius_pos : ∀ i, 0 < radius i
+  radius_lt_chart : ∀ i, radius i < punctureChartRadius i
+  pairwise_disjoint :
+    Pairwise
+      (fun i j =>
+        Disjoint
+          (coordinateDisc (punctureChart i) (radius i) :
+            Set SpecialPeriods.TriangleCompactifiedOrbitSpace)
+          (coordinateDisc (punctureChart j) (radius j) :
+            Set SpecialPeriods.TriangleCompactifiedOrbitSpace))
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.BaseCover.fillingPatch (C : SpecialPeriods.Threefold.BaseCover)
+    (i : SpecialPeriods.Threefold.Puncture) :
+    TopologicalSpace.Opens SpecialPeriods.TriangleCompactifiedOrbitSpace :=
+  SpecialPeriods.Threefold.coordinateDisc (SpecialPeriods.Threefold.punctureChart i) (C.radius i)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.BaseCover.mem_fillingPatch
+    (C : SpecialPeriods.Threefold.BaseCover) (i : SpecialPeriods.Threefold.Puncture)
+    (x : SpecialPeriods.TriangleCompactifiedOrbitSpace) :
+    x ∈ C.fillingPatch i ↔
+      x ∈ (SpecialPeriods.Threefold.punctureChart i).source ∧
+        ‖SpecialPeriods.Threefold.punctureChart i x‖ < C.radius i := by
+  simp only [fillingPatch, SpecialPeriods.Threefold.mem_coordinateDisc, Metric.mem_ball,
+    dist_zero_right]
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.BaseCover.fillingPatch_subset_chart
+    (C : SpecialPeriods.Threefold.BaseCover) (i : SpecialPeriods.Threefold.Puncture) :
+    (C.fillingPatch i : Set SpecialPeriods.TriangleCompactifiedOrbitSpace) ⊆
+      (SpecialPeriods.Threefold.punctureChart i).source :=
+  Set.inter_subset_left
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.BaseCover.coordinateBall_subset_target
+    (C : SpecialPeriods.Threefold.BaseCover) (i : SpecialPeriods.Threefold.Puncture) :
+    Metric.ball (0 : ℂ) (C.radius i) ⊆ (SpecialPeriods.Threefold.punctureChart i).target := by
+  rw [SpecialPeriods.Threefold.punctureChart_target]
+  exact Metric.ball_subset_ball (C.radius_lt_chart i).le
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.BaseCover.fillingPatch_eq_inverse_image
+    (C : SpecialPeriods.Threefold.BaseCover) (i : SpecialPeriods.Threefold.Puncture) :
+    (C.fillingPatch i : Set SpecialPeriods.TriangleCompactifiedOrbitSpace) =
+      (SpecialPeriods.Threefold.punctureChart i).symm '' Metric.ball 0 (C.radius i) :=
+  SpecialPeriods.Threefold.coordinateDisc_eq_symm_image (SpecialPeriods.Threefold.punctureChart i)
+    (C.coordinateBall_subset_target i)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.BaseCover.point_mem_fillingPatch
+    (C : SpecialPeriods.Threefold.BaseCover) (i : SpecialPeriods.Threefold.Puncture) :
+    SpecialPeriods.Threefold.puncturePoint i ∈ C.fillingPatch i :=
+  SpecialPeriods.Threefold.center_mem_coordinateDisc (SpecialPeriods.Threefold.punctureChart i)
+    (SpecialPeriods.Threefold.puncturePoint_mem_source i)
+    (SpecialPeriods.Threefold.punctureChart_point i) (C.radius_pos i)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.BaseCover.fillingPatch_disjoint
+    (C : SpecialPeriods.Threefold.BaseCover) {i j : SpecialPeriods.Threefold.Puncture}
+    (hij : i ≠ j) :
+    Disjoint (C.fillingPatch i : Set SpecialPeriods.TriangleCompactifiedOrbitSpace)
+      (C.fillingPatch j : Set SpecialPeriods.TriangleCompactifiedOrbitSpace) :=
+  C.pairwise_disjoint hij
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.BaseCover.point_mem_fillingPatch_iff
+    (C : SpecialPeriods.Threefold.BaseCover) (i j : SpecialPeriods.Threefold.Puncture) :
+    SpecialPeriods.Threefold.puncturePoint i ∈ C.fillingPatch j ↔ i = j := by
+  constructor
+  · intro h
+    by_contra hij
+    exact Set.disjoint_left.mp (C.fillingPatch_disjoint hij) (C.point_mem_fillingPatch i) h
+  · rintro rfl
+    exact C.point_mem_fillingPatch i
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.BaseCover.chart_eq_zero_iff
+    (C : SpecialPeriods.Threefold.BaseCover) (i : SpecialPeriods.Threefold.Puncture)
+    {x : SpecialPeriods.TriangleCompactifiedOrbitSpace} (hx : x ∈ C.fillingPatch i) :
+    SpecialPeriods.Threefold.punctureChart i x = 0 ↔
+      x = SpecialPeriods.Threefold.puncturePoint i :=
+  SpecialPeriods.Threefold.punctureChart_eq_zero_iff i (C.fillingPatch_subset_chart i hx)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.BaseCover.inverse_mem_fillingPatch
+    (C : SpecialPeriods.Threefold.BaseCover) (i : SpecialPeriods.Threefold.Puncture) {z : ℂ}
+    (hz : z ∈ Metric.ball 0 (C.radius i)) :
+    (SpecialPeriods.Threefold.punctureChart i).symm z ∈ C.fillingPatch i := by
+  have ht := C.coordinateBall_subset_target i hz
+  refine ⟨(SpecialPeriods.Threefold.punctureChart i).map_target ht, ?_⟩
+  change
+    SpecialPeriods.Threefold.punctureChart i ((SpecialPeriods.Threefold.punctureChart i).symm z) ∈
+      Metric.ball 0 (C.radius i)
+  rw [(SpecialPeriods.Threefold.punctureChart i).right_inv ht]
+  exact hz
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.exists_baseCover_below (R : Puncture → ℝ) (hR : ∀ i, 0 < R i) :
+    ∃ C : BaseCover, ∀ i, C.radius i < R i := by
+  obtain ⟨r, hr, _, _, hdisj⟩ :=
+    exists_pairwise_disjoint_coordinateDiscs puncturePoint puncturePoint_injective punctureChart
+      puncturePoint_mem_source punctureChart_point (fun _ => ⊤) (fun _ => trivial)
+      (fun i => Min.min (R i) (punctureChartRadius i))
+      (fun i => lt_min (hR i) (punctureChartRadius_pos i))
+  exact
+    ⟨{  radius := r
+        radius_pos := fun i => (hr i).1
+        radius_lt_chart := fun i => (hr i).2.trans_le (min_le_right _ _)
+        pairwise_disjoint := hdisj }, fun i => (hr i).2.trans_le (min_le_left _ _)⟩
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.sphereRadiusCap
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere)) :
+    Puncture → ℝ
+  | none => (SpecialPeriods.Construction.cuspDataOfSphere π hπ h₀ h₁).radius
+  | some _ => 1
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.sphereRadiusCap_pos
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere))
+    (i : Puncture) : 0 < sphereRadiusCap π hπ h₀ h₁ i := by
+  cases i with
+  | none => exact (SpecialPeriods.Construction.cuspDataOfSphere π hπ h₀ h₁).radius_pos
+  | some j => norm_num [sphereRadiusCap]
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.baseCoverOfSphere
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere)) :
+    BaseCover :=
+  (exists_baseCover_below (sphereRadiusCap π hπ h₀ h₁) (sphereRadiusCap_pos π hπ h₀ h₁)).choose
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.baseCoverOfSphere_radius_lt_cap
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere))
+    (i : Puncture) : (baseCoverOfSphere π hπ h₀ h₁).radius i < sphereRadiusCap π hπ h₀ h₁ i :=
+  (exists_baseCover_below (sphereRadiusCap π hπ h₀ h₁)
+        (sphereRadiusCap_pos π hπ h₀ h₁)).choose_spec
+    i
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.baseCoverOfSphere_cusp_radius_bounds
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere)) :
+    0 < (baseCoverOfSphere π hπ h₀ h₁).radius Option.none ∧
+      (baseCoverOfSphere π hπ h₀ h₁).radius Option.none <
+          (SpecialPeriods.Construction.cuspDataOfSphere π hπ h₀ h₁).radius ∧
+        (baseCoverOfSphere π hπ h₀ h₁).radius Option.none <
+          SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width :=
+  ⟨(baseCoverOfSphere π hπ h₀ h₁).radius_pos Option.none,
+    baseCoverOfSphere_radius_lt_cap π hπ h₀ h₁ Option.none,
+    (baseCoverOfSphere π hπ h₀ h₁).radius_lt_chart Option.none⟩
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.regularPatch :
+    TopologicalSpace.Opens SpecialPeriods.TriangleCompactifiedOrbitSpace :=
+  ⟨({ SpecialPeriods.triangleCuspPoint, SpecialPeriods.triangleCompactifiedCenterOne,
+          SpecialPeriods.triangleCompactifiedCenterTwo } :
+        Set SpecialPeriods.TriangleCompactifiedOrbitSpace)ᶜ,
+    (((Set.finite_singleton SpecialPeriods.triangleCompactifiedCenterTwo).insert
+            SpecialPeriods.triangleCompactifiedCenterOne).insert
+        SpecialPeriods.triangleCuspPoint).isClosed.isOpen_compl⟩
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.mem_regularPatch
+    (x : SpecialPeriods.TriangleCompactifiedOrbitSpace) :
+    x ∈ regularPatch ↔
+      x ≠ SpecialPeriods.triangleCuspPoint ∧
+        x ≠ SpecialPeriods.triangleCompactifiedCenterOne ∧
+          x ≠ SpecialPeriods.triangleCompactifiedCenterTwo := by
+  simp only [regularPatch, TopologicalSpace.Opens.mem_mk, Set.mem_compl_iff, Set.mem_insert_iff,
+    Set.mem_singleton_iff, not_or]
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.openInclusion_mem_regularPatch_iff
+    (q : SpecialPeriods.TriangleOrbitSpace) :
+    SpecialPeriods.triangleOpenInclusion q ∈ regularPatch ↔
+      q ∈ SpecialPeriods.triangleOrbitRegularDomain := by
+  rw [mem_regularPatch, SpecialPeriods.triangleOrbitRegularDomain_mem_iff]
+  constructor
+  · rintro ⟨_, h₁, h₂⟩
+    exact
+      ⟨fun h => h₁ (congrArg SpecialPeriods.triangleOpenInclusion h), fun h =>
+        h₂ (congrArg SpecialPeriods.triangleOpenInclusion h)⟩
+  · rintro ⟨h₁, h₂⟩
+    exact
+      ⟨SpecialPeriods.triangleOpenInclusion_ne_cusp q, fun h => h₁ (OnePoint.coe_injective h),
+        fun h => h₂ (OnePoint.coe_injective h)⟩
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.regularInclusion :
+    SpecialPeriods.TriangleRegularQuotient → SpecialPeriods.TriangleCompactifiedOrbitSpace :=
+  SpecialPeriods.triangleOpenInclusion ∘ SpecialPeriods.triangleRegularToOrbit
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.regularInclusion_isOpenEmbedding :
+    Topology.IsOpenEmbedding regularInclusion :=
+  SpecialPeriods.triangleOpenInclusion_isOpenEmbedding.comp
+    SpecialPeriods.triangleRegularToOrbit_isOpenEmbedding
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.regularInclusion_mem
+    (q : SpecialPeriods.TriangleRegularQuotient) : regularInclusion q ∈ regularPatch := by
+  apply (openInclusion_mem_regularPatch_iff (SpecialPeriods.triangleRegularToOrbit q)).mpr
+  exact Set.mem_range_self q
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.regularInclusion_range :
+    Set.range regularInclusion =
+      (regularPatch : Set SpecialPeriods.TriangleCompactifiedOrbitSpace) := by
+  ext x
+  constructor
+  · rintro ⟨q, rfl⟩
+    exact regularInclusion_mem q
+  · intro hx
+    obtain ⟨q, hq⟩ := OnePoint.ne_infty_iff_exists.mp ((mem_regularPatch x).mp hx).1
+    have hq' : SpecialPeriods.triangleOpenInclusion q = x := hq
+    have hreg : q ∈ SpecialPeriods.triangleOrbitRegularDomain :=
+      (openInclusion_mem_regularPatch_iff q).mp (hq' ▸ hx)
+    obtain ⟨r, hr⟩ := hreg
+    exact ⟨r, (congrArg SpecialPeriods.triangleOpenInclusion hr).trans hq'⟩
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.regularInclusion_isLocalDiffeomorph :
+    IsLocalDiffeomorph 𝓘(ℂ) 𝓘(ℂ) ω regularInclusion := by
+  intro q
+  have hreg : IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω SpecialPeriods.triangleRegularToOrbit q :=
+    (SpecialPeriods.triangleRegularOrbitBiholomorph.isLocalDiffeomorph q).comp (K := 𝓘(ℂ)) (P :=
+      SpecialPeriods.TriangleOrbitSpace)
+      (isLocalDiffeomorph_subtypeVal 𝓘(ℂ) SpecialPeriods.triangleOrbitRegularDomain
+        (SpecialPeriods.triangleRegularOrbitBiholomorph q))
+  exact
+    hreg.comp (K := 𝓘(ℂ)) (P := SpecialPeriods.TriangleCompactifiedOrbitSpace)
+      (SpecialPeriods.triangleOpenInclusion_isLocalDiffeomorph
+        (SpecialPeriods.triangleRegularToOrbit q))
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.regularInclusionToPatch
+    (q : SpecialPeriods.TriangleRegularQuotient) : regularPatch :=
+  ⟨regularInclusion q, regularInclusion_mem q⟩
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.regularInclusionToPatch_isLocalDiffeomorph :
+    IsLocalDiffeomorph 𝓘(ℂ) 𝓘(ℂ) ω regularInclusionToPatch :=
+  isLocalDiffeomorph_codRestrictOpens 𝓘(ℂ) 𝓘(ℂ) regularInclusion_isLocalDiffeomorph regularPatch
+    regularInclusion_mem
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.regularInclusionToPatch_bijective :
+    Function.Bijective regularInclusionToPatch := by
+  constructor
+  · intro q r h
+    exact regularInclusion_isOpenEmbedding.injective (congrArg Subtype.val h)
+  · intro x
+    have hx : x.val ∈ Set.range regularInclusion := by
+      rw [regularInclusion_range]
+      exact x.property
+    obtain ⟨q, hq⟩ := hx
+    exact ⟨q, Subtype.ext hq⟩
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.regularBiholomorph :
+    Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleRegularQuotient regularPatch ω :=
+  regularInclusionToPatch_isLocalDiffeomorph.diffeomorphOfBijective
+    regularInclusionToPatch_bijective
+
+private abbrev SpecialPeriods.Threefold.Index :=
+  Option Puncture
+
+private theorem SpecialPeriods.Threefold.mem_regularPatch_iff_ne_puncture
+    (x : SpecialPeriods.TriangleCompactifiedOrbitSpace) :
+    x ∈ regularPatch ↔ ∀ i : Puncture, x ≠ puncturePoint i := by
+  rw [mem_regularPatch]
+  constructor
+  · rintro ⟨hc, h₁, h₂⟩ i
+    cases i with
+    | none => exact hc
+    | some j => cases j <;> assumption
+  · intro h
+    exact ⟨h Option.none, h (Option.some .three), h (Option.some .four)⟩
+
+private theorem SpecialPeriods.Threefold.not_mem_regularPatch_iff
+    (x : SpecialPeriods.TriangleCompactifiedOrbitSpace) :
+    x ∉ regularPatch ↔ ∃ i : Puncture, x = puncturePoint i := by
+  classical
+  rw [mem_regularPatch_iff_ne_puncture]
+  simp only [Classical.not_forall, ne_eq, Classical.not_not]
+
+private def SpecialPeriods.Threefold.BaseCover.patch (C : SpecialPeriods.Threefold.BaseCover) :
+    SpecialPeriods.Threefold.Index →
+      TopologicalSpace.Opens SpecialPeriods.TriangleCompactifiedOrbitSpace
+  | none => SpecialPeriods.Threefold.regularPatch
+  | some i => C.fillingPatch i
+
+private theorem
+    SpecialPeriods.Threefold.BaseCover.exists_patch (C : SpecialPeriods.Threefold.BaseCover)
+    (x : SpecialPeriods.TriangleCompactifiedOrbitSpace) :
+    ∃ i : SpecialPeriods.Threefold.Index, x ∈ C.patch i := by
+  classical
+  by_cases hx : x ∈ SpecialPeriods.Threefold.regularPatch
+  · exact ⟨Option.none, hx⟩
+  · obtain ⟨i, rfl⟩ := (SpecialPeriods.Threefold.not_mem_regularPatch_iff x).mp hx
+    exact ⟨Option.some i, C.point_mem_fillingPatch i⟩
+
+private theorem
+    SpecialPeriods.Threefold.BaseCover.isOpenCover (C : SpecialPeriods.Threefold.BaseCover) :
+    TopologicalSpace.IsOpenCover C.patch := by
+  change (⨆ i, C.patch i) = ⊤
+  apply top_unique
+  intro x _
+  obtain ⟨i, hi⟩ := C.exists_patch x
+  exact (le_iSup C.patch i) hi
+
+private theorem
+    SpecialPeriods.Threefold.BaseCover.patch_iUnion (C : SpecialPeriods.Threefold.BaseCover) :
+    ⋃ i : SpecialPeriods.Threefold.Index,
+        (C.patch i : Set SpecialPeriods.TriangleCompactifiedOrbitSpace) =
+      Set.univ :=
+  C.isOpenCover.iSup_set_eq_univ
+
+private theorem SpecialPeriods.Threefold.BaseCover.fillingPatch_regular_iff
+    (C : SpecialPeriods.Threefold.BaseCover) (i : SpecialPeriods.Threefold.Puncture)
+    {x : SpecialPeriods.TriangleCompactifiedOrbitSpace} (hx : x ∈ C.fillingPatch i) :
+    x ∈ SpecialPeriods.Threefold.regularPatch ↔ x ≠ SpecialPeriods.Threefold.puncturePoint i := by
+  constructor
+  · intro h
+    exact (SpecialPeriods.Threefold.mem_regularPatch_iff_ne_puncture x).mp h i
+  · intro hne
+    apply (SpecialPeriods.Threefold.mem_regularPatch_iff_ne_puncture x).mpr
+    intro j hxj
+    have hji : j = i := (C.point_mem_fillingPatch_iff j i).mp (hxj ▸ hx)
+    exact hne (hxj.trans (congrArg SpecialPeriods.Threefold.puncturePoint hji))
+
+private theorem SpecialPeriods.Threefold.BaseCover.fillingPatch_regular_iff_coordinate_ne_zero
+    (C : SpecialPeriods.Threefold.BaseCover) (i : SpecialPeriods.Threefold.Puncture)
+    {x : SpecialPeriods.TriangleCompactifiedOrbitSpace} (hx : x ∈ C.fillingPatch i) :
+    x ∈ SpecialPeriods.Threefold.regularPatch ↔ SpecialPeriods.Threefold.punctureChart i x ≠ 0 :=
+  (C.fillingPatch_regular_iff i hx).trans (not_congr (C.chart_eq_zero_iff i hx)).symm
+
+private theorem SpecialPeriods.Threefold.BaseCover.inverse_mem_regular_iff
+    (C : SpecialPeriods.Threefold.BaseCover) (i : SpecialPeriods.Threefold.Puncture) {z : ℂ}
+    (hz : z ∈ Metric.ball 0 (C.radius i)) :
+    (SpecialPeriods.Threefold.punctureChart i).symm z ∈ SpecialPeriods.Threefold.regularPatch ↔
+      z ≠ 0 := by
+  rw [C.fillingPatch_regular_iff_coordinate_ne_zero i (C.inverse_mem_fillingPatch i hz),
+    (SpecialPeriods.Threefold.punctureChart i).right_inv (C.coordinateBall_subset_target i hz)]
+
+/-- The open complex coordinate ball of radius `r`. -/
+public
+def SpecialPeriods.Threefold.coordinateBall (r : ℝ) : TopologicalSpace.Opens ℂ :=
+  ⟨Metric.ball 0 r, Metric.isOpen_ball⟩
+
+@[simp]
+public
+theorem SpecialPeriods.Threefold.mem_coordinateBall (r : ℝ) (z : ℂ) :
+    z ∈ coordinateBall r ↔ z ∈ Metric.ball 0 r :=
+  Iff.rfl
+
+private def SpecialPeriods.Threefold.coordinateDiscForward {X : Type*} [TopologicalSpace X]
+    [ChartedSpace ℂ X] (e : PartialDiffeomorph 𝓘(ℂ) 𝓘(ℂ) X ℂ ω) (r : ℝ) :
+    coordinateDisc e.toOpenPartialHomeomorph r → coordinateBall r := fun x => ⟨e x, x.property.2⟩
+
+private def SpecialPeriods.Threefold.coordinateDiscInverse {X : Type*} [TopologicalSpace X]
+    [ChartedSpace ℂ X] (e : PartialDiffeomorph 𝓘(ℂ) 𝓘(ℂ) X ℂ ω) (r : ℝ)
+    (hball : Metric.ball 0 r ⊆ e.target) :
+    coordinateBall r → coordinateDisc e.toOpenPartialHomeomorph r := fun z =>
+  ⟨e.symm z, e.map_target (hball z.property),
+    by
+    change e (e.symm (z : ℂ)) ∈ Metric.ball 0 r
+    have he : e (e.symm (z : ℂ)) = (z : ℂ) := e.right_inv (hball z.property)
+    exact he.symm ▸ z.property⟩
+
+private theorem SpecialPeriods.Threefold.coordinateDiscForward_holomorphic {X : Type*}
+    [TopologicalSpace X] [ChartedSpace ℂ X] (e : PartialDiffeomorph 𝓘(ℂ) 𝓘(ℂ) X ℂ ω) (r : ℝ) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (coordinateDiscForward e r) := by
+  have hf :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun x : coordinateDisc e.toOpenPartialHomeomorph r => e (x : X)) :=
+    e.contMDiffOn.comp_contMDiff contMDiff_subtype_val (fun x => x.property.1)
+  intro x
+  have h :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (fun y => (coordinateDiscForward e r y : ℂ)) x ↔
+      ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (coordinateDiscForward e r) x :=
+    ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+  exact h.mp (hf x)
+
+private theorem SpecialPeriods.Threefold.coordinateDiscInverse_holomorphic {X : Type*}
+    [TopologicalSpace X] [ChartedSpace ℂ X] (e : PartialDiffeomorph 𝓘(ℂ) 𝓘(ℂ) X ℂ ω) (r : ℝ)
+    (hball : Metric.ball 0 r ⊆ e.target) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (coordinateDiscInverse e r hball) := by
+  have hf : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z : coordinateBall r => e.symm (z : ℂ)) :=
+    e.symm.contMDiffOn.comp_contMDiff contMDiff_subtype_val (fun z => hball z.property)
+  intro z
+  have h :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (fun w => (coordinateDiscInverse e r hball w : X)) z ↔
+      ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (coordinateDiscInverse e r hball) z :=
+    ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+  exact h.mp (hf z)
+
+private def SpecialPeriods.Threefold.coordinateDiscBiholomorph {X : Type*} [TopologicalSpace X]
+    [ChartedSpace ℂ X] (e : PartialDiffeomorph 𝓘(ℂ) 𝓘(ℂ) X ℂ ω) (r : ℝ)
+    (hball : Metric.ball 0 r ⊆ e.target) :
+    Diffeomorph 𝓘(ℂ) 𝓘(ℂ) (coordinateDisc e.toOpenPartialHomeomorph r) (coordinateBall r) ω
+    where
+  toFun := coordinateDiscForward e r
+  invFun := coordinateDiscInverse e r hball
+  left_inv x := Subtype.ext (e.left_inv x.property.1)
+  right_inv z := Subtype.ext (e.right_inv (hball z.property))
+  contMDiff_toFun := coordinateDiscForward_holomorphic e r
+  contMDiff_invFun := coordinateDiscInverse_holomorphic e r hball
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.BaseCover.fillingChart (C : SpecialPeriods.Threefold.BaseCover)
+    (i : SpecialPeriods.Threefold.Puncture) :
+    Diffeomorph 𝓘(ℂ) 𝓘(ℂ) (C.fillingPatch i)
+      (SpecialPeriods.Threefold.coordinateBall (C.radius i)) ω :=
+  SpecialPeriods.Threefold.coordinateDiscBiholomorph (SpecialPeriods.Threefold.puncturePartial i)
+    (C.radius i) (C.coordinateBall_subset_target i)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def
+    SpecialPeriods.Threefold.BaseCover.fillingEmbedding (C : SpecialPeriods.Threefold.BaseCover)
+    (i : SpecialPeriods.Threefold.Puncture) :
+    SpecialPeriods.Threefold.coordinateBall (C.radius i) →
+      SpecialPeriods.TriangleCompactifiedOrbitSpace :=
+  fun z => ((C.fillingChart i).symm z : SpecialPeriods.TriangleCompactifiedOrbitSpace)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.BaseCover.punctureChart_fillingEmbedding
+    (C : SpecialPeriods.Threefold.BaseCover) (i : SpecialPeriods.Threefold.Puncture)
+    (z : SpecialPeriods.Threefold.coordinateBall (C.radius i)) :
+    SpecialPeriods.Threefold.punctureChart i (C.fillingEmbedding i z) = (z : ℂ) :=
+  (SpecialPeriods.Threefold.punctureChart i).right_inv
+    (C.coordinateBall_subset_target i z.property)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.BaseCover.fillingEmbedding_mem_regular_iff
+    (C : SpecialPeriods.Threefold.BaseCover) (i : SpecialPeriods.Threefold.Puncture)
+    (z : SpecialPeriods.Threefold.coordinateBall (C.radius i)) :
+    C.fillingEmbedding i z ∈ SpecialPeriods.Threefold.regularPatch ↔ (z : ℂ) ≠ 0 :=
+  C.inverse_mem_regular_iff i z.property
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.BaseCover.fillingEmbedding_eq_point_iff
+    (C : SpecialPeriods.Threefold.BaseCover) (i : SpecialPeriods.Threefold.Puncture)
+    (z : SpecialPeriods.Threefold.coordinateBall (C.radius i)) :
+    C.fillingEmbedding i z = SpecialPeriods.Threefold.puncturePoint i ↔ (z : ℂ) = 0 := by
+  constructor
+  · intro h
+    have he := congrArg (SpecialPeriods.Threefold.punctureChart i) h
+    simpa only [C.punctureChart_fillingEmbedding,
+      SpecialPeriods.Threefold.punctureChart_point] using he
+  · intro h
+    change
+      (SpecialPeriods.Threefold.punctureChart i).symm (z : ℂ) =
+        SpecialPeriods.Threefold.puncturePoint i
+    rw [h, SpecialPeriods.Threefold.punctureChart_symm_zero]
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private abbrev SpecialPeriods.Threefold.regularFamilyData (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint :=
+  PeriodFamily.regularData P h₁ h₂
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private abbrev SpecialPeriods.Threefold.RegularFamily (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    Type :=
+  (regularFamilyData P h₁ h₂).Space
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+@[instance_reducible]
+private def SpecialPeriods.Threefold.regularFamilyChartedSpace (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    ChartedSpace (ℂ × ComplexPlane₂) (RegularFamily P h₁ h₂) :=
+  (regularFamilyData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.regularFamily_t2Space (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    T2Space (RegularFamily P h₁ h₂) :=
+  (regularFamilyData P h₁ h₂).spaceT2Space_of_properlyDiscontinuous
+    (PeriodFamily.regularCovering P h₁ h₂)
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.regularFamily_secondCountable (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    SecondCountableTopology (RegularFamily P h₁ h₂) :=
+  (regularFamilyData P h₁ h₂).spaceSecondCountable (PeriodFamily.regularCovering P h₁ h₂)
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.regularFamily_isManifold (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    letI := regularFamilyChartedSpace P h₁ h₂
+    IsManifold (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (RegularFamily P h₁ h₂) :=
+  (regularFamilyData P h₁ h₂).isManifold (PeriodFamily.regularCovering P h₁ h₂)
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.regularFamilyProjection (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    RegularFamily P h₁ h₂ → regularPatch :=
+  regularBiholomorph ∘ (regularFamilyData P h₁ h₂).projection
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.regularFamilyProjection_proper (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    IsProperMap (regularFamilyProjection P h₁ h₂) :=
+  regularBiholomorph.toHomeomorph.isProperMap.comp
+    ((regularFamilyData P h₁ h₂).projection_proper (PeriodFamily.regularCovering P h₁ h₂))
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.regularFamilyProjectionToBase (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    RegularFamily P h₁ h₂ → SpecialPeriods.TriangleCompactifiedOrbitSpace := fun x =>
+  (regularFamilyProjection P h₁ h₂ x : SpecialPeriods.TriangleCompactifiedOrbitSpace)
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.regularFamilyZeroSection (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    regularPatch → RegularFamily P h₁ h₂ :=
+  (regularFamilyData P h₁ h₂).zeroSection ∘ regularBiholomorph.symm
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.regularFamilyZeroSection_continuous
+    (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    Continuous (regularFamilyZeroSection P h₁ h₂) :=
+  (regularFamilyData P h₁ h₂).zeroSection_continuous.comp regularBiholomorph.symm.continuous
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Threefold/SpecialPeriods7.lean b/LeanPool/HopfProblem/Threefold/SpecialPeriods7.lean
new file mode 100644
index 000000000..5b0dfe91c
--- /dev/null
+++ b/LeanPool/HopfProblem/Threefold/SpecialPeriods7.lean
@@ -0,0 +1,2176 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Uniformization.CuspUniformization3
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap1
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.Foundations.LocalOrbitQuotient
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods3
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.PeriodFamily.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods6
+import all LeanPool.HopfProblem.PeriodFamily.Core2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import all LeanPool.HopfProblem.Elliptic.Core3
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldGluing1
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization3
+
+/-!
+# Hopf problem: threefold · special periods 7
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.specialBaseCover : BaseCover :=
+  baseCoverOfSphere SpecialPeriods.Triangle.triangleSphereUniformization
+    SpecialPeriods.Triangle.triangleSphereUniformization_cusp
+    SpecialPeriods.Triangle.triangleSphereUniformization_centerOne
+    SpecialPeriods.Triangle.triangleSphereUniformization_centerTwo
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.specialBaseCover_cusp_radius_bounds :
+    0 < specialBaseCover.radius Option.none ∧
+      specialBaseCover.radius Option.none < SpecialPeriods.specialCuspData.radius ∧
+        specialBaseCover.radius Option.none <
+          SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width :=
+  baseCoverOfSphere_cusp_radius_bounds SpecialPeriods.Triangle.triangleSphereUniformization
+    SpecialPeriods.Triangle.triangleSphereUniformization_cusp
+    SpecialPeriods.Triangle.triangleSphereUniformization_centerOne
+    SpecialPeriods.Triangle.triangleSphereUniformization_centerTwo
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.regularPatchPoint : regularPatch := by
+  let x := SpecialPeriods.Triangle.triangleSphereUniformization.symm ((2 : ℂ) : RiemannSphere)
+  have hx : SpecialPeriods.Triangle.triangleSphereUniformization x = ((2 : ℂ) : RiemannSphere) :=
+    SpecialPeriods.Triangle.triangleSphereUniformization.apply_symm_apply _
+  refine ⟨x, (mem_regularPatch x).mpr ⟨?_, ?_, ?_⟩⟩
+  · intro h
+    have he := congrArg SpecialPeriods.Triangle.triangleSphereUniformization h
+    rw [hx, SpecialPeriods.Triangle.triangleSphereUniformization_cusp] at he
+    exact OnePoint.coe_ne_infty (2 : ℂ) he
+  · intro h
+    have he := congrArg SpecialPeriods.Triangle.triangleSphereUniformization h
+    change
+      SpecialPeriods.Triangle.triangleSphereUniformization x =
+        SpecialPeriods.Triangle.triangleSphereUniformization
+          (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) at he
+    rw [hx, SpecialPeriods.Triangle.triangleSphereUniformization_centerOne] at he
+    have he' := OnePoint.coe_injective he
+    norm_num at he'
+  · intro h
+    have he := congrArg SpecialPeriods.Triangle.triangleSphereUniformization h
+    change
+      SpecialPeriods.Triangle.triangleSphereUniformization x =
+        SpecialPeriods.Triangle.triangleSphereUniformization
+          (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) at he
+    rw [hx, SpecialPeriods.Triangle.triangleSphereUniformization_centerTwo] at he
+    have he' := OnePoint.coe_injective he
+    norm_num at he'
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private abbrev SpecialPeriods.Threefold.SpecialRegularFamily :=
+  RegularFamily SpecialPeriods.specialPeriodMap SpecialPeriods.specialPeriodMap_generator₁
+    SpecialPeriods.specialPeriodMap_generator₂
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+@[instance_reducible]
+private def SpecialPeriods.Threefold.specialRegularFamilyChartedSpace :
+    ChartedSpace (ℂ × ComplexPlane₂) SpecialRegularFamily :=
+  regularFamilyChartedSpace SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.specialRegularFamilyProjection :
+    SpecialRegularFamily → regularPatch :=
+  regularFamilyProjection SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.specialRegularFamilyProjectionToBase :
+    SpecialRegularFamily → SpecialPeriods.TriangleCompactifiedOrbitSpace :=
+  regularFamilyProjectionToBase SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.specialRegularFamilyProjection_proper :
+    IsProperMap specialRegularFamilyProjection :=
+  regularFamilyProjection_proper SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.specialRegularFamily_t2Space : T2Space SpecialRegularFamily :=
+  regularFamily_t2Space SpecialPeriods.specialPeriodMap SpecialPeriods.specialPeriodMap_generator₁
+    SpecialPeriods.specialPeriodMap_generator₂
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.specialRegularFamily_secondCountable :
+    SecondCountableTopology SpecialRegularFamily :=
+  regularFamily_secondCountable SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.specialRegularFamily_isManifold :
+    letI := specialRegularFamilyChartedSpace
+    IsManifold (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω SpecialRegularFamily :=
+  regularFamily_isManifold SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.specialRegularFamilyPoint : SpecialRegularFamily :=
+  regularFamilyZeroSection SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+    regularPatchPoint
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.specialRegularFamily_nonempty : Nonempty SpecialRegularFamily :=
+  ⟨specialRegularFamilyPoint⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.EllipticFilling.ellipticNeighborhoodChart_symm_generator
+    (j : Elliptic.Kind) (z : SpecialPeriods.Disc) :
+    letI := SpecialPeriods.Triangle.ellipticNeighborhoodAction j
+    (SpecialPeriods.Triangle.ellipticNeighborhoodChart j).symm (Elliptic.familyRotation j z) =
+      SpecialPeriods.Triangle.ellipticStabilizerGenerator j •
+        (SpecialPeriods.Triangle.ellipticNeighborhoodChart j).symm z := by
+  let := SpecialPeriods.Triangle.ellipticNeighborhoodAction j
+  apply (SpecialPeriods.Triangle.ellipticNeighborhoodChart j).injective
+  change
+    SpecialPeriods.Triangle.ellipticNeighborhoodChart j
+        ((SpecialPeriods.Triangle.ellipticNeighborhoodChart j).symm
+          (Elliptic.familyRotation j z)) =
+      SpecialPeriods.Triangle.ellipticNeighborhoodChart j
+        (SpecialPeriods.Triangle.ellipticStabilizerGenerator j •
+          (SpecialPeriods.Triangle.ellipticNeighborhoodChart j).symm z)
+  rw [Diffeomorph.apply_symm_apply, SpecialPeriods.Triangle.ellipticNeighborhoodChart_generator,
+    Diffeomorph.apply_symm_apply]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.EllipticFilling.ellipticNeighborhoodChart_symm_generatorSL
+    (j : Elliptic.Kind) (z : SpecialPeriods.Disc) :
+    ((SpecialPeriods.Triangle.ellipticNeighborhoodChart j).symm (Elliptic.familyRotation j z) :
+        ℍ) =
+      SpecialPeriods.Triangle.ellipticGeneratorSL j •
+        ((SpecialPeriods.Triangle.ellipticNeighborhoodChart j).symm z : ℍ) := by
+  let := SpecialPeriods.Triangle.ellipticNeighborhoodAction j
+  have h :=
+    congrArg (Subtype.val : SpecialPeriods.Triangle.ellipticNeighborhood j → ℍ)
+      (ellipticNeighborhoodChart_symm_generator j z)
+  simpa only [SpecialPeriods.Triangle.ellipticNeighborhood_smul_val,
+    SpecialPeriods.Triangle.ellipticStabilizerGenerator_val,
+    SpecialPeriods.Triangle.ellipticGenerator_smul] using h
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private def SpecialPeriods.EllipticFilling.neighborhoodLift (j : Elliptic.Kind)
+    (z : SpecialPeriods.Disc) : ℍ :=
+  ((SpecialPeriods.Triangle.ellipticNeighborhoodChart j).symm z : ℍ)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.EllipticFilling.neighborhoodLift_holomorphic (j : Elliptic.Kind) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (neighborhoodLift j) :=
+  contMDiff_subtype_val.comp (SpecialPeriods.Triangle.ellipticNeighborhoodChart j).symm.contMDiff
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.EllipticFilling.neighborhoodLift_rotation (j : Elliptic.Kind)
+    (z : SpecialPeriods.Disc) :
+    neighborhoodLift j (Elliptic.familyRotation j z) =
+      SpecialPeriods.Triangle.ellipticGeneratorSL j • neighborhoodLift j z :=
+  ellipticNeighborhoodChart_symm_generatorSL j z
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private def SpecialPeriods.EllipticFilling.localPeriods (P : HolomorphicPeriodMap ℂ ℍ)
+    (j : Elliptic.Kind) : HolomorphicPeriodMap ℂ SpecialPeriods.Disc
+    where
+  point z := P.point (neighborhoodLift j z)
+  holomorphic_tau := P.holomorphic_tau.comp (neighborhoodLift_holomorphic j)
+  holomorphic_mu := P.holomorphic_mu.comp (neighborhoodLift_holomorphic j)
+  holomorphic_beta := P.holomorphic_beta.comp (neighborhoodLift_holomorphic j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+@[simp]
+private theorem SpecialPeriods.EllipticFilling.localPeriods_point (P : HolomorphicPeriodMap ℂ ℍ)
+    (j : Elliptic.Kind) (z : SpecialPeriods.Disc) :
+    (localPeriods P j).point z = P.point (neighborhoodLift j z) :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem
+    SpecialPeriods.EllipticFilling.localPeriods_covariance (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) (z : SpecialPeriods.Disc) :
+    (localPeriods P j).point (Elliptic.familyRotation j z) =
+      Elliptic.periodStep j ((localPeriods P j).point z) := by
+  simp only [localPeriods_point, neighborhoodLift_rotation]
+  cases j
+  · exact h₁ _
+  · exact h₂ _
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private def SpecialPeriods.EllipticFilling.localData (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) : Elliptic.Equivariant.Data j
+    where
+  periods := localPeriods P j
+  covariance := localPeriods_covariance P h₁ h₂ j
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+@[simp]
+private theorem SpecialPeriods.EllipticFilling.localData_periods (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) : (localData P h₁ h₂ j).periods = localPeriods P j :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private abbrev SpecialPeriods.EllipticFilling.fillingSpace (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) :=
+  (localData P h₁ h₂ j).Space j.twist (Elliptic.mainTwist_admissible j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private def SpecialPeriods.EllipticFilling.fillingQuotient (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) : (localPeriods P j).TotalSpace → fillingSpace P h₁ h₂ j :=
+  (localData P h₁ h₂ j).quotient j.twist (Elliptic.mainTwist_admissible j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private def SpecialPeriods.EllipticFilling.fillingProjection (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) : fillingSpace P h₁ h₂ j → SpecialPeriods.Disc :=
+  (localData P h₁ h₂ j).projection j.twist (Elliptic.mainTwist_admissible j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+@[instance_reducible]
+private def SpecialPeriods.EllipticFilling.fillingChartedSpace (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) : ChartedSpace Elliptic.FamilyModel (fillingSpace P h₁ h₂ j) :=
+  (localData P h₁ h₂ j).chartedSpace j.twist (Elliptic.mainTwist_admissible j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.EllipticFilling.filling_isManifold (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) :
+    letI := fillingChartedSpace P h₁ h₂ j
+    IsManifold (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω (fillingSpace P h₁ h₂ j) :=
+  (localData P h₁ h₂ j).isManifold j.twist (Elliptic.mainTwist_admissible j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.EllipticFilling.fillingQuotient_isCoveringMap
+    (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) : IsCoveringMap (fillingQuotient P h₁ h₂ j) :=
+  (localData P h₁ h₂ j).quotient_isCoveringMap j.twist (Elliptic.mainTwist_admissible j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem
+    SpecialPeriods.EllipticFilling.fillingQuotient_surjective (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) : Function.Surjective (fillingQuotient P h₁ h₂ j) :=
+  (localData P h₁ h₂ j).quotient_surjective j.twist (Elliptic.mainTwist_admissible j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem
+    SpecialPeriods.EllipticFilling.fillingProjection_proper (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) : IsProperMap (fillingProjection P h₁ h₂ j) :=
+  (localData P h₁ h₂ j).projection_proper j.twist (Elliptic.mainTwist_admissible j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem
+    SpecialPeriods.EllipticFilling.fillingProjection_surjective (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) : Function.Surjective (fillingProjection P h₁ h₂ j) :=
+  (localData P h₁ h₂ j).projection_surjective j.twist (Elliptic.mainTwist_admissible j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem
+    SpecialPeriods.EllipticFilling.fillingProjection_continuous (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) : Continuous (fillingProjection P h₁ h₂ j) :=
+  (localData P h₁ h₂ j).projection_continuous j.twist (Elliptic.mainTwist_admissible j)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.EllipticFilling.smallDisc (r : ℝ) :
+    TopologicalSpace.Opens SpecialPeriods.Disc :=
+  ⟨{z | ‖(z : ℂ)‖ < r}, isOpen_lt continuous_subtype_val.norm continuous_const⟩
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.EllipticFilling.smallDiscHomeomorph (r : ℝ) (hr : r < 1) :
+    smallDisc r ≃ₜ SpecialPeriods.Threefold.coordinateBall r
+    where
+  toFun
+    z :=
+    ⟨((z : SpecialPeriods.Disc) : ℂ), by
+      simpa [SpecialPeriods.Threefold.coordinateBall, smallDisc] using z.property⟩
+  invFun
+    z := by
+    have hz : ‖(z : ℂ)‖ < r := by
+      simpa [SpecialPeriods.Threefold.coordinateBall, smallDisc] using z.property
+    exact ⟨⟨(z : ℂ), by simpa [SpecialPeriods.unitDisc] using hz.trans hr⟩, hz⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := (continuous_subtype_val.comp continuous_subtype_val).subtype_mk _
+  continuous_invFun := (continuous_subtype_val.subtype_mk _).subtype_mk _
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.EllipticFilling.pieceDomain (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    TopologicalSpace.Opens (fillingSpace P h₁ h₂ j) :=
+  ⟨{y | ‖(fillingProjection P h₁ h₂ j y : ℂ)‖ < C.radius (Option.some j)},
+    isOpen_lt (continuous_subtype_val.comp (fillingProjection_continuous P h₁ h₂ j)).norm
+      continuous_const⟩
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private abbrev SpecialPeriods.EllipticFilling.Piece (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :=
+  pieceDomain P h₁ h₂ C j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+@[instance_reducible]
+private def SpecialPeriods.EllipticFilling.pieceChartedSpace (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    ChartedSpace Elliptic.FamilyModel (Piece P h₁ h₂ C j) := by
+  letI := fillingChartedSpace P h₁ h₂ j
+  infer_instance
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.EllipticFilling.piece_t2Space (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) : T2Space (Piece P h₁ h₂ C j) :=
+  inferInstance
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.EllipticFilling.piece_secondCountable (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    SecondCountableTopology (Piece P h₁ h₂ C j) :=
+  inferInstance
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.EllipticFilling.piece_isManifold (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    letI := pieceChartedSpace P h₁ h₂ C j
+    IsManifold (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω (Piece P h₁ h₂ C j) := by
+  let := fillingChartedSpace P h₁ h₂ j
+  let := filling_isManifold P h₁ h₂ j
+  infer_instance
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.EllipticFilling.pieceCoordinate (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    Piece P h₁ h₂ C j → SpecialPeriods.Threefold.coordinateBall (C.radius (Option.some j)) :=
+  fun y =>
+  ⟨(fillingProjection P h₁ h₂ j y : ℂ),
+    by
+    change (fillingProjection P h₁ h₂ j y : ℂ) ∈ Metric.ball 0 (C.radius (Option.some j))
+    rw [Metric.mem_ball, dist_zero_right]
+    exact y.property⟩
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.EllipticFilling.pieceCoordinate_surjective (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    Function.Surjective (pieceCoordinate P h₁ h₂ C j) := by
+  intro z
+  have hz : ‖(z : ℂ)‖ < C.radius (Option.some j) := by
+    simpa only [SpecialPeriods.Threefold.mem_coordinateBall, Metric.mem_ball,
+      dist_zero_right] using z.property
+  have hr : C.radius (Option.some j) < 1 := C.radius_lt_chart (Option.some j)
+  let w : SpecialPeriods.Disc :=
+    ⟨z, by
+      change (z : ℂ) ∈ Metric.ball 0 1
+      simpa only [Metric.mem_ball, dist_zero_right] using hz.trans hr⟩
+  obtain ⟨y, hy⟩ := fillingProjection_surjective P h₁ h₂ j w
+  have hy' : y ∈ pieceDomain P h₁ h₂ C j := by
+    change ‖(fillingProjection P h₁ h₂ j y : ℂ)‖ < C.radius (Option.some j)
+    rw [hy]
+    exact hz
+  refine ⟨⟨y, hy'⟩, Subtype.ext ?_⟩
+  exact congrArg (Subtype.val : SpecialPeriods.Disc → ℂ) hy
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.EllipticFilling.pieceCoordinate_proper (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    IsProperMap (pieceCoordinate P h₁ h₂ C j) :=
+  (smallDiscHomeomorph (C.radius (Option.some j))
+        (C.radius_lt_chart (Option.some j))).isProperMap.comp
+    ((fillingProjection_proper P h₁ h₂ j).restrictPreimage
+      (smallDisc (C.radius (Option.some j)) : Set SpecialPeriods.Disc))
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.EllipticFilling.pieceProjection (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    Piece P h₁ h₂ C j → C.fillingPatch (Option.some j) :=
+  (C.fillingChart (Option.some j)).symm ∘ pieceCoordinate P h₁ h₂ C j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.EllipticFilling.pieceProjection_surjective (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    Function.Surjective (pieceProjection P h₁ h₂ C j) :=
+  (C.fillingChart (Option.some j)).symm.surjective.comp (pieceCoordinate_surjective P h₁ h₂ C j)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.EllipticFilling.pieceProjection_proper (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    IsProperMap (pieceProjection P h₁ h₂ C j) :=
+  (C.fillingChart (Option.some j)).symm.toHomeomorph.isProperMap.comp
+    (pieceCoordinate_proper P h₁ h₂ C j)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.EllipticFilling.pieceProjectionToBase (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    Piece P h₁ h₂ C j → SpecialPeriods.TriangleCompactifiedOrbitSpace := fun y =>
+  (pieceProjection P h₁ h₂ C j y : SpecialPeriods.TriangleCompactifiedOrbitSpace)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.EllipticFilling.pieceProjectionToBase_mem_regular_iff
+    (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) (y : Piece P h₁ h₂ C j) :
+    pieceProjectionToBase P h₁ h₂ C j y ∈ SpecialPeriods.Threefold.regularPatch ↔
+      (fillingProjection P h₁ h₂ j y : ℂ) ≠ 0 :=
+  C.fillingEmbedding_mem_regular_iff (Option.some j) (pieceCoordinate P h₁ h₂ C j y)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private abbrev SpecialPeriods.Threefold.SpecialEllipticPiece (j : Elliptic.Kind) :=
+  SpecialPeriods.EllipticFilling.Piece SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+    specialBaseCover j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+@[instance_reducible]
+private def SpecialPeriods.Threefold.specialEllipticPieceChartedSpace (j : Elliptic.Kind) :
+    ChartedSpace (ℂ × ComplexPlane₂) (SpecialEllipticPiece j) :=
+  SpecialPeriods.EllipticFilling.pieceChartedSpace SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+    specialBaseCover j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.specialEllipticPieceProjection (j : Elliptic.Kind) :
+    SpecialEllipticPiece j → specialBaseCover.fillingPatch (Option.some j) :=
+  SpecialPeriods.EllipticFilling.pieceProjection SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+    specialBaseCover j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.specialEllipticPieceProjectionToBase (j : Elliptic.Kind) :
+    SpecialEllipticPiece j → SpecialPeriods.TriangleCompactifiedOrbitSpace :=
+  SpecialPeriods.EllipticFilling.pieceProjectionToBase SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+    specialBaseCover j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.specialEllipticPieceProjection_proper (j : Elliptic.Kind) :
+    IsProperMap (specialEllipticPieceProjection j) :=
+  SpecialPeriods.EllipticFilling.pieceProjection_proper SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+    specialBaseCover j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.specialEllipticPieceProjection_surjective (j : Elliptic.Kind) :
+    Function.Surjective (specialEllipticPieceProjection j) :=
+  SpecialPeriods.EllipticFilling.pieceProjection_surjective SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+    specialBaseCover j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.specialEllipticPiece_t2Space (j : Elliptic.Kind) :
+    T2Space (SpecialEllipticPiece j) :=
+  SpecialPeriods.EllipticFilling.piece_t2Space SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+    specialBaseCover j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.specialEllipticPiece_secondCountable (j : Elliptic.Kind) :
+    SecondCountableTopology (SpecialEllipticPiece j) :=
+  SpecialPeriods.EllipticFilling.piece_secondCountable SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+    specialBaseCover j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.specialEllipticPiece_isManifold (j : Elliptic.Kind) :
+    letI := specialEllipticPieceChartedSpace j
+    IsManifold (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (SpecialEllipticPiece j) :=
+  SpecialPeriods.EllipticFilling.piece_isManifold SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+    specialBaseCover j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.specialEllipticPiece_nonempty (j : Elliptic.Kind) :
+    Nonempty (SpecialEllipticPiece j) := by
+  obtain ⟨x, _⟩ :=
+    specialEllipticPieceProjection_surjective j
+      ⟨puncturePoint (Option.some j), specialBaseCover.point_mem_fillingPatch (Option.some j)⟩
+  exact ⟨x⟩
+
+private def SpecialPeriods.CuspFamily.Data.shrink (D : SpecialPeriods.CuspFamily.Data) (r : ℝ)
+    (hr : 0 < r) (hrD : r ≤ D.radius) : SpecialPeriods.CuspFamily.Data
+    where
+  μ := D.μ
+  b := D.b
+  h := D.h
+  radius := r
+  radius_pos := hr
+  radius_lt_one := hrD.trans_lt D.radius_lt_one
+  holomorphic i j := (D.holomorphic i j).mono (Metric.ball_subset_ball hrD)
+  smallDrift := D.smallDrift.mono hrD
+
+private theorem SpecialPeriods.CuspFamily.complex_width_ne_zero_mo1973_20202 :
+    (SpecialPeriods.Triangle.width : ℂ) ≠ 0 :=
+  Complex.ofReal_ne_zero.mpr SpecialPeriods.Triangle.width_ne_zero
+
+private theorem SpecialPeriods.CuspFamily.qParam_width_mul (s : ℂ) :
+    Function.Periodic.qParam SpecialPeriods.Triangle.width
+        ((SpecialPeriods.Triangle.width : ℂ) * s) =
+      CuspUniformization.exponential s := by
+  unfold Function.Periodic.qParam CuspUniformization.exponential
+  congr 1
+  rw [mul_left_comm, mul_div_cancel_left₀ _ complex_width_ne_zero_mo1973_20202]
+
+private theorem SpecialPeriods.CuspFamily.exponential_div_width (z : ℍ) :
+    CuspUniformization.exponential ((z : ℂ) / SpecialPeriods.Triangle.width) =
+      SpecialPeriods.Triangle.cuspQ z := by
+  simp only [CuspUniformization.exponential, SpecialPeriods.Triangle.cuspQ,
+    Function.Periodic.qParam, mul_div_assoc]
+
+private theorem SpecialPeriods.CuspFamily.logBase_scaled_height_mo1973_20205 (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (s : LogBase r) :
+    SpecialPeriods.Triangle.width < ((SpecialPeriods.Triangle.width : ℂ) * (s : ℂ)).im := by
+  apply
+    (Function.Periodic.norm_qParam_lt_iff SpecialPeriods.Triangle.width_pos
+        SpecialPeriods.Triangle.width _).mp
+  rw [qParam_width_mul]
+  exact ((mem_logBase r s).mp s.property).trans_le hrcap
+
+private def SpecialPeriods.CuspFamily.cuspOverlapUpperDomain (r : ℝ) : TopologicalSpace.Opens ℍ :=
+  ⟨{z | ‖SpecialPeriods.Triangle.cuspQ z‖ < r},
+    isOpen_lt SpecialPeriods.Triangle.cuspQ_continuous.norm continuous_const⟩
+
+@[simp]
+private theorem SpecialPeriods.CuspFamily.mem_cuspOverlapUpperDomain (r : ℝ) (z : ℍ) :
+    z ∈ cuspOverlapUpperDomain r ↔ ‖SpecialPeriods.Triangle.cuspQ z‖ < r :=
+  Iff.rfl
+
+private theorem SpecialPeriods.CuspFamily.cuspOverlapUpperDomain_subset_horodisc (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) :
+    (cuspOverlapUpperDomain r : Set ℍ) ⊆
+      SpecialPeriods.Triangle.horodisc SpecialPeriods.Triangle.width := by
+  intro z hz
+  exact
+    (SpecialPeriods.Triangle.cuspQ_norm_lt_exp_iff SpecialPeriods.Triangle.width z).mp
+      (hz.trans_le hrcap)
+
+private theorem SpecialPeriods.CuspFamily.cuspOverlapUpperDomain_subset_regular (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) :
+    (cuspOverlapUpperDomain r : Set ℍ) ⊆ SpecialPeriods.triangleRegularLocus :=
+  (cuspOverlapUpperDomain_subset_horodisc r hrcap).trans
+    (SpecialPeriods.Triangle.horodisc_subset_triangleRegularLocus SpecialPeriods.Triangle.width
+      le_rfl)
+
+private def SpecialPeriods.CuspFamily.logBaseToUpperHalfPlane (r : ℝ)
+    (_hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (s : LogBase r) : ℍ :=
+  UpperHalfPlane.ofComplex ((SpecialPeriods.Triangle.width : ℂ) * (s : ℂ))
+
+@[simp]
+private theorem SpecialPeriods.CuspFamily.logBaseToUpperHalfPlane_coe (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (s : LogBase r) :
+    (logBaseToUpperHalfPlane r hrcap s : ℂ) = (SpecialPeriods.Triangle.width : ℂ) * (s : ℂ) :=
+  congrArg UpperHalfPlane.coe
+    (UpperHalfPlane.ofComplex_apply_of_im_pos
+      (SpecialPeriods.Triangle.width_pos.trans (logBase_scaled_height_mo1973_20205 r hrcap s)))
+
+private theorem SpecialPeriods.CuspFamily.logBaseToUpperHalfPlane_mem_horodisc (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (s : LogBase r) :
+    logBaseToUpperHalfPlane r hrcap s ∈
+      SpecialPeriods.Triangle.horodisc SpecialPeriods.Triangle.width := by
+  change SpecialPeriods.Triangle.width < (logBaseToUpperHalfPlane r hrcap s).im
+  rw [← UpperHalfPlane.coe_im, logBaseToUpperHalfPlane_coe]
+  exact logBase_scaled_height_mo1973_20205 r hrcap s
+
+@[simp]
+private theorem SpecialPeriods.CuspFamily.logBaseToUpperHalfPlane_cuspQ (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (s : LogBase r) :
+    SpecialPeriods.Triangle.cuspQ (logBaseToUpperHalfPlane r hrcap s) =
+      CuspUniformization.exponential s := by
+  rw [SpecialPeriods.Triangle.cuspQ, logBaseToUpperHalfPlane_coe, qParam_width_mul]
+
+private theorem SpecialPeriods.CuspFamily.logBaseToUpperHalfPlane_mem_domain (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (s : LogBase r) : logBaseToUpperHalfPlane r hrcap s ∈ cuspOverlapUpperDomain r := by
+  rw [mem_cuspOverlapUpperDomain, logBaseToUpperHalfPlane_cuspQ]
+  exact (mem_logBase r s).mp s.property
+
+private theorem SpecialPeriods.CuspFamily.logBaseToUpperHalfPlane_holomorphic (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (logBaseToUpperHalfPlane r hrcap) := by
+  have h :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun s : LogBase r => (SpecialPeriods.Triangle.width : ℂ) * (s : ℂ)) :=
+    contMDiff_const.mul contMDiff_subtype_val
+  intro s
+  exact
+    (UpperHalfPlane.contMDiffAt_ofComplex
+          (SpecialPeriods.Triangle.width_pos.trans
+            (logBase_scaled_height_mo1973_20205 r hrcap s))).comp
+      s (h s)
+
+private def SpecialPeriods.CuspFamily.logBaseToOverlapUpperDomain (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (s : LogBase r) : cuspOverlapUpperDomain r :=
+  ⟨logBaseToUpperHalfPlane r hrcap s, logBaseToUpperHalfPlane_mem_domain r hrcap s⟩
+
+private def SpecialPeriods.CuspFamily.overlapUpperToLogBase (r : ℝ) (z : cuspOverlapUpperDomain r) :
+    LogBase r :=
+  ⟨(z.val : ℂ) / SpecialPeriods.Triangle.width,
+    by
+    rw [mem_logBase, exponential_div_width]
+    exact z.property⟩
+
+@[simp]
+private theorem SpecialPeriods.CuspFamily.overlapUpperToLogBase_coe (r : ℝ)
+    (z : cuspOverlapUpperDomain r) :
+    (overlapUpperToLogBase r z : ℂ) = (z.val : ℂ) / SpecialPeriods.Triangle.width :=
+  rfl
+
+private theorem SpecialPeriods.CuspFamily.logBaseToOverlapUpperDomain_holomorphic (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (logBaseToOverlapUpperDomain r hrcap) := by
+  intro s
+  have hi :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (Subtype.val ∘ logBaseToOverlapUpperDomain r hrcap) s ↔
+      ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (logBaseToOverlapUpperDomain r hrcap) s :=
+    ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+  exact hi.mp (logBaseToUpperHalfPlane_holomorphic r hrcap s)
+
+private theorem SpecialPeriods.CuspFamily.overlapUpperToLogBase_holomorphic (r : ℝ) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (overlapUpperToLogBase r) := by
+  have h :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω
+      (fun z : cuspOverlapUpperDomain r => (z.val : ℂ) / SpecialPeriods.Triangle.width) :=
+    (UpperHalfPlane.contMDiff_coe.comp contMDiff_subtype_val).div_const
+      (SpecialPeriods.Triangle.width : ℂ)
+  intro z
+  have hi :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (Subtype.val ∘ overlapUpperToLogBase r) z ↔
+      ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (overlapUpperToLogBase r) z :=
+    ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+  exact hi.mp (h z)
+
+private def SpecialPeriods.CuspFamily.logBaseBiholomorph (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) :
+    Diffeomorph 𝓘(ℂ) 𝓘(ℂ) (LogBase r) (cuspOverlapUpperDomain r) ω
+    where
+  toFun := logBaseToOverlapUpperDomain r hrcap
+  invFun := overlapUpperToLogBase r
+  left_inv
+    s := by
+    apply Subtype.ext
+    change (logBaseToUpperHalfPlane r hrcap s : ℂ) / SpecialPeriods.Triangle.width = (s : ℂ)
+    rw [logBaseToUpperHalfPlane_coe, mul_div_cancel_left₀ _ complex_width_ne_zero_mo1973_20202]
+  right_inv
+    z := by
+    apply Subtype.ext
+    apply UpperHalfPlane.ext
+    change (logBaseToUpperHalfPlane r hrcap (overlapUpperToLogBase r z) : ℂ) = (z.val : ℂ)
+    rw [logBaseToUpperHalfPlane_coe, overlapUpperToLogBase_coe,
+      mul_div_cancel₀ _ complex_width_ne_zero_mo1973_20202]
+  contMDiff_toFun := logBaseToOverlapUpperDomain_holomorphic r hrcap
+  contMDiff_invFun := overlapUpperToLogBase_holomorphic r
+
+private theorem SpecialPeriods.CuspFamily.logBaseToUpperHalfPlane_injective (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) :
+    Function.Injective (logBaseToUpperHalfPlane r hrcap) := by
+  intro s t h
+  exact (logBaseBiholomorph r hrcap).injective (Subtype.ext h)
+
+private theorem SpecialPeriods.CuspFamily.logBaseToUpperHalfPlane_isLocalDiffeomorph (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) :
+    IsLocalDiffeomorph 𝓘(ℂ) 𝓘(ℂ) ω (logBaseToUpperHalfPlane r hrcap) := by
+  intro s
+  exact
+    ((logBaseBiholomorph r hrcap).isLocalDiffeomorph s).comp (K := 𝓘(ℂ)) (P := ℍ)
+      (isLocalDiffeomorph_subtypeVal 𝓘(ℂ) (cuspOverlapUpperDomain r)
+        (logBaseBiholomorph r hrcap s))
+
+private theorem SpecialPeriods.CuspFamily.logBaseToUpperHalfPlane_range (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) :
+    Set.range (logBaseToUpperHalfPlane r hrcap) = (cuspOverlapUpperDomain r : Set ℍ) := by
+  ext z
+  constructor
+  · rintro ⟨s, rfl⟩
+    exact logBaseToUpperHalfPlane_mem_domain r hrcap s
+  · intro hz
+    obtain ⟨s, hs⟩ := (logBaseBiholomorph r hrcap).surjective ⟨z, hz⟩
+    exact ⟨s, congrArg Subtype.val hs⟩
+
+private def SpecialPeriods.CuspFamily.logBaseToRegular (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (s : LogBase r) : SpecialPeriods.TriangleRegularPoint :=
+  ⟨logBaseToUpperHalfPlane r hrcap s,
+    (cuspOverlapUpperDomain_subset_regular r hrcap)
+      (logBaseToUpperHalfPlane_mem_domain r hrcap s)⟩
+
+@[simp]
+private theorem SpecialPeriods.CuspFamily.logBaseToRegular_coe (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (s : LogBase r) :
+    ((logBaseToRegular r hrcap s : ℍ) : ℂ) = (SpecialPeriods.Triangle.width : ℂ) * (s : ℂ) :=
+  logBaseToUpperHalfPlane_coe r hrcap s
+
+private theorem SpecialPeriods.CuspFamily.logBaseToRegular_mem_horodisc (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (s : LogBase r) :
+    (logBaseToRegular r hrcap s : ℍ) ∈
+      SpecialPeriods.Triangle.horodisc SpecialPeriods.Triangle.width :=
+  logBaseToUpperHalfPlane_mem_horodisc r hrcap s
+
+@[simp]
+private theorem SpecialPeriods.CuspFamily.logBaseToRegular_cuspQ (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (s : LogBase r) :
+    SpecialPeriods.Triangle.cuspQ (logBaseToRegular r hrcap s : ℍ) =
+      CuspUniformization.exponential s :=
+  logBaseToUpperHalfPlane_cuspQ r hrcap s
+
+private theorem SpecialPeriods.CuspFamily.logBaseToRegular_injective (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) :
+    Function.Injective (logBaseToRegular r hrcap) := by
+  intro s t h
+  exact logBaseToUpperHalfPlane_injective r hrcap (congrArg Subtype.val h)
+
+private theorem SpecialPeriods.CuspFamily.logBaseToRegular_isLocalDiffeomorph (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) :
+    IsLocalDiffeomorph 𝓘(ℂ) 𝓘(ℂ) ω (logBaseToRegular r hrcap) :=
+  isLocalDiffeomorph_codRestrictOpens 𝓘(ℂ) 𝓘(ℂ)
+    (logBaseToUpperHalfPlane_isLocalDiffeomorph r hrcap) SpecialPeriods.triangleRegularDomain
+    (fun s => (logBaseToRegular r hrcap s).property)
+
+private theorem SpecialPeriods.CuspFamily.logBaseToRegular_holomorphic (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (logBaseToRegular r hrcap) :=
+  (logBaseToRegular_isLocalDiffeomorph r hrcap).contMDiff
+
+private theorem SpecialPeriods.CuspFamily.logBaseToUpperHalfPlane_translate (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) (k : ℤ)
+    (s : LogBase r) :
+    logBaseToUpperHalfPlane r hrcap (logBaseTranslate r k s) =
+      SpecialPeriods.triangleGeometricRepresentation (SpecialPeriods.triangleCuspGenerator ^ k)
+        (logBaseToUpperHalfPlane r hrcap s) := by
+  apply UpperHalfPlane.ext
+  rw [logBaseToUpperHalfPlane_coe, logBaseTranslate_coe,
+    SpecialPeriods.triangleGeometricRepresentation_cusp_zpow_coe, logBaseToUpperHalfPlane_coe]
+  ring
+
+private theorem SpecialPeriods.CuspFamily.logBaseToRegular_translate (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) (k : ℤ)
+    (s : LogBase r) :
+    logBaseToRegular r hrcap (logBaseTranslate r k s) =
+      (SpecialPeriods.triangleCuspGenerator ^ k) • logBaseToRegular r hrcap s :=
+  Subtype.ext (logBaseToUpperHalfPlane_translate r hrcap k s)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.CuspPiece.restrictedData (D : SpecialPeriods.CuspFamily.Data)
+    (C : SpecialPeriods.Threefold.BaseCover) (hcap : C.radius Option.none ≤ D.radius) :
+    SpecialPeriods.CuspFamily.Data :=
+  D.shrink (C.radius Option.none) (C.radius_pos Option.none) hcap
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private abbrev SpecialPeriods.Threefold.CuspPiece.Space (D : SpecialPeriods.CuspFamily.Data)
+    (C : SpecialPeriods.Threefold.BaseCover) :=
+  CuspQuotient.QuotientSpace D.correction (C.radius Option.none)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+@[instance_reducible]
+private def
+    SpecialPeriods.Threefold.CuspPiece.nativeChartedSpace (D : SpecialPeriods.CuspFamily.Data)
+    (C : SpecialPeriods.Threefold.BaseCover) (hcap : C.radius Option.none ≤ D.radius) :
+    ChartedSpace (ToricCharts.CoordinateSpace 3) (Space D C) :=
+  CuspQuotient.chartedSpace D.correction (C.radius Option.none) (C.radius_pos Option.none)
+    (restrictedData D C hcap).radius_lt_one (restrictedData D C hcap).holomorphic
+    (restrictedData D C hcap).smallDrift
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.CuspPiece.space_t2Space (D : SpecialPeriods.CuspFamily.Data)
+    (C : SpecialPeriods.Threefold.BaseCover) (hcap : C.radius Option.none ≤ D.radius) :
+    T2Space (Space D C) :=
+  CuspQuotient.quotient_t2Space D.correction (C.radius Option.none) (C.radius_pos Option.none)
+    (restrictedData D C hcap).radius_lt_one (restrictedData D C hcap).holomorphic
+    (restrictedData D C hcap).smallDrift
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspPiece.space_secondCountable
+    (D : SpecialPeriods.CuspFamily.Data) (C : SpecialPeriods.Threefold.BaseCover)
+    (hcap : C.radius Option.none ≤ D.radius) : SecondCountableTopology (Space D C) :=
+  CuspQuotient.quotient_secondCountable D.correction (C.radius Option.none)
+    (C.radius_pos Option.none) (restrictedData D C hcap).radius_lt_one
+    (restrictedData D C hcap).holomorphic (restrictedData D C hcap).smallDrift
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.CuspPiece.space_connected (D : SpecialPeriods.CuspFamily.Data)
+    (C : SpecialPeriods.Threefold.BaseCover) : ConnectedSpace (Space D C) :=
+  CuspQuotient.quotient_connected D.correction (C.radius Option.none) (C.radius_pos Option.none)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.CuspPiece.space_nonempty (D : SpecialPeriods.CuspFamily.Data)
+    (C : SpecialPeriods.Threefold.BaseCover) : Nonempty (Space D C) := by
+  let := space_connected D C
+  infer_instance
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.CuspPiece.native_isManifold (D : SpecialPeriods.CuspFamily.Data)
+    (C : SpecialPeriods.Threefold.BaseCover) (hcap : C.radius Option.none ≤ D.radius) :
+    letI := nativeChartedSpace D C hcap
+    IsManifold (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (Space D C) :=
+  CuspQuotient.isManifold D.correction (C.radius Option.none) (C.radius_pos Option.none)
+    (restrictedData D C hcap).radius_lt_one (restrictedData D C hcap).holomorphic
+    (restrictedData D C hcap).smallDrift
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.CuspPiece.coordinate (D : SpecialPeriods.CuspFamily.Data)
+    (C : SpecialPeriods.Threefold.BaseCover) :
+    Space D C → SpecialPeriods.Threefold.coordinateBall (C.radius Option.none) :=
+  CuspQuotient.baseMap D.correction (C.radius Option.none)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.CuspPiece.coordinate_proper (D : SpecialPeriods.CuspFamily.Data)
+    (C : SpecialPeriods.Threefold.BaseCover) (hcap : C.radius Option.none ≤ D.radius) :
+    IsProperMap (coordinate D C) :=
+  CuspQuotient.baseMap_proper D.correction (C.radius Option.none) (C.radius_pos Option.none)
+    (restrictedData D C hcap).radius_lt_one (restrictedData D C hcap).holomorphic
+    (restrictedData D C hcap).smallDrift
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.CuspPiece.projection (D : SpecialPeriods.CuspFamily.Data)
+    (C : SpecialPeriods.Threefold.BaseCover) : Space D C → C.fillingPatch Option.none :=
+  (C.fillingChart Option.none).symm ∘ coordinate D C
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.CuspPiece.projection_proper (D : SpecialPeriods.CuspFamily.Data)
+    (C : SpecialPeriods.Threefold.BaseCover) (hcap : C.radius Option.none ≤ D.radius) :
+    IsProperMap (projection D C) :=
+  (C.fillingChart Option.none).symm.toHomeomorph.isProperMap.comp (coordinate_proper D C hcap)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.CuspPiece.projectionToBase (D : SpecialPeriods.CuspFamily.Data)
+    (C : SpecialPeriods.Threefold.BaseCover) :
+    Space D C → SpecialPeriods.TriangleCompactifiedOrbitSpace := fun x =>
+  (projection D C x : SpecialPeriods.TriangleCompactifiedOrbitSpace)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.CuspPiece.projectionToBase_apply
+    (D : SpecialPeriods.CuspFamily.Data) (C : SpecialPeriods.Threefold.BaseCover)
+    (x : Space D C) :
+    projectionToBase D C x =
+      (SpecialPeriods.Threefold.punctureChart Option.none).symm
+        (CuspQuotient.projection D.correction (C.radius Option.none) x) :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.CuspPiece.projectionToBase_mem_regular_iff
+    (D : SpecialPeriods.CuspFamily.Data) (C : SpecialPeriods.Threefold.BaseCover)
+    (x : Space D C) :
+    projectionToBase D C x ∈ SpecialPeriods.Threefold.regularPatch ↔
+      CuspQuotient.projection D.correction (C.radius Option.none) x ≠ 0 :=
+  C.fillingEmbedding_mem_regular_iff Option.none (coordinate D C x)
+
+private def SpecialPeriods.Threefold.cuspModelEquiv :
+    ToricCharts.CoordinateSpace 3 ≃L[ℂ] (ℂ × ComplexPlane₂)
+    where
+  toFun x := (x 0, fun i => x i.succ)
+  invFun x := ![x.1, x.2 0, x.2 1]
+  left_inv
+    x := by
+    ext i
+    fin_cases i <;> rfl
+  right_inv
+    x := by
+    apply Prod.ext
+    · rfl
+    · ext i
+      fin_cases i <;> rfl
+  map_add' x y := rfl
+  map_smul' r x := rfl
+  continuous_toFun := (continuous_apply 0).prodMk (continuous_pi fun i => continuous_apply i.succ)
+  continuous_invFun :=
+    continuous_pi fun i => by
+      fin_cases i
+      · exact continuous_fst
+      · exact (continuous_apply 0).comp continuous_snd
+      · exact (continuous_apply 1).comp continuous_snd
+
+@[instance_reducible]
+private def SpecialPeriods.Threefold.ModelChange.chartedSpace {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [NormedAddCommGroup F] [NormedSpace ℂ F] (e : E ≃L[ℂ] F) (X : Type*)
+    [TopologicalSpace X] [ChartedSpace E X] : ChartedSpace F X
+    where
+  atlas :=
+    (fun c : OpenPartialHomeomorph X E => c.trans e.toHomeomorph.toOpenPartialHomeomorph) ''
+      atlas E X
+  chartAt x := (chartAt E x).trans e.toHomeomorph.toOpenPartialHomeomorph
+  mem_chart_source x := by simp only [mfld_simps]
+  chart_mem_atlas x := Set.mem_image_of_mem _ (chart_mem_atlas E x)
+
+@[simp]
+private theorem
+    SpecialPeriods.Threefold.ModelChange.chartAt_target {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [NormedAddCommGroup F] [NormedSpace ℂ F] (e : E ≃L[ℂ] F) (X : Type*)
+    [TopologicalSpace X] [ChartedSpace E X] (x : X) :
+    letI := chartedSpace e X
+    (chartAt F x).target = e.symm ⁻¹' (chartAt E x).target := by
+  simp [chartAt, ChartedSpace.chartAt]
+
+private def SpecialPeriods.Threefold.ModelChange.diffeomorph {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [NormedAddCommGroup F] [NormedSpace ℂ F] (e : E ≃L[ℂ] F) (X : Type*)
+    [TopologicalSpace X] [ChartedSpace E X] (n : ℕ∞ω) :
+    letI := chartedSpace e X
+    Diffeomorph (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ F) X X n := by
+  let := chartedSpace e X
+  have hchart (x y : X) : chartAt F x y = e (chartAt E x y) := rfl
+  have hsymm (x : X) (y : F) : (chartAt F x).symm y = (chartAt E x).symm (e.symm y) := rfl
+  refine { toEquiv := Equiv.refl X, contMDiff_toFun := ?_, contMDiff_invFun := ?_ }
+  · intro x
+    apply contMDiffWithinAt_iff'.2
+    refine ⟨continuousWithinAt_id, ?_⟩
+    apply e.contDiff.contDiffWithinAt.congr_of_mem
+    · intro y hy
+      have hy' : y ∈ (chartAt E x).target := by simpa [hchart, hsymm] using hy.1
+      simpa [hchart, hsymm, extChartAt, OpenPartialHomeomorph.extend, Function.comp_def] using
+        congrArg e ((chartAt E x).right_inv hy')
+    · simp only [mfld_simps]
+  · intro x
+    apply contMDiffWithinAt_iff'.2
+    refine ⟨continuousWithinAt_id, ?_⟩
+    apply e.symm.contDiff.contDiffWithinAt.congr_of_mem
+    · intro y hy
+      have hy' : e.symm y ∈ (chartAt E x).target := by
+        simpa only [mfld_simps, chartAt_target] using hy.1
+      simpa [hchart, hsymm, extChartAt, OpenPartialHomeomorph.extend, Function.comp_def] using
+        (chartAt E x).right_inv hy'
+    · simp only [mfld_simps]
+
+private theorem SpecialPeriods.Threefold.ModelChange.isManifold {E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [NormedAddCommGroup F] [NormedSpace ℂ F] (e : E ≃L[ℂ] F) (X : Type*)
+    [TopologicalSpace X] [ChartedSpace E X] (n : ℕ∞ω)
+    [IsManifold (modelWithCornersSelf ℂ E) n X] :
+    letI := chartedSpace e X
+    IsManifold (modelWithCornersSelf ℂ F) n X := by
+  let := chartedSpace e X
+  apply isManifold_of_contDiffOn
+  rintro _ _ ⟨c, hc, rfl⟩ ⟨d, hd, rfl⟩
+  have hcd : ContDiffOn ℂ n (c.symm.trans d) (c.symm.trans d).source := by
+    simpa [contDiffPregroupoid] using
+      ((contDiffGroupoid n (modelWithCornersSelf ℂ E)).compatible hc hd).1
+  have hcomp :=
+    e.contDiff.comp_contDiffOn
+      (hcd.comp e.symm.contDiff.contDiffOn
+        (show Set.MapsTo e.symm (e.symm ⁻¹' (c.symm.trans d).source) (c.symm.trans d).source from
+          fun _ hy => hy))
+  simpa [Set.preimage_preimage, Function.comp_def, OpenPartialHomeomorph.trans_source,
+    OpenPartialHomeomorph.trans_target] using hcomp
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+@[instance_reducible]
+private def
+    SpecialPeriods.Threefold.CuspPiece.commonChartedSpace (D : SpecialPeriods.CuspFamily.Data)
+    (C : SpecialPeriods.Threefold.BaseCover) (hcap : C.radius Option.none ≤ D.radius) :
+    ChartedSpace (ℂ × ComplexPlane₂) (Space D C) := by
+  let := nativeChartedSpace D C hcap
+  exact
+    SpecialPeriods.Threefold.ModelChange.chartedSpace SpecialPeriods.Threefold.cuspModelEquiv
+      (Space D C)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.CuspPiece.common_isManifold (D : SpecialPeriods.CuspFamily.Data)
+    (C : SpecialPeriods.Threefold.BaseCover) (hcap : C.radius Option.none ≤ D.radius) :
+    letI := commonChartedSpace D C hcap
+    IsManifold (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (Space D C) := by
+  let := nativeChartedSpace D C hcap
+  let := native_isManifold D C hcap
+  exact
+    SpecialPeriods.Threefold.ModelChange.isManifold SpecialPeriods.Threefold.cuspModelEquiv
+      (Space D C) ω
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.CuspPiece.nativeToCommon (D : SpecialPeriods.CuspFamily.Data)
+    (C : SpecialPeriods.Threefold.BaseCover) (hcap : C.radius Option.none ≤ D.radius) :
+    letI := nativeChartedSpace D C hcap
+    letI := commonChartedSpace D C hcap
+    Diffeomorph (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) (Space D C) (Space D C) ω := by
+  let := nativeChartedSpace D C hcap
+  exact
+    SpecialPeriods.Threefold.ModelChange.diffeomorph SpecialPeriods.Threefold.cuspModelEquiv
+      (Space D C) ω
+
+private structure
+    SpecialPeriods.Threefold.Star.Input (B : Type u) [TopologicalSpace B] (I : Type u) where
+  patch : Option I → TopologicalSpace.Opens B
+  cover : TopologicalSpace.IsOpenCover patch
+  disjoint :
+    Pairwise
+      (fun i j : I => Disjoint (patch (Option.some i) : Set B) (patch (Option.some j) : Set B))
+  piece : Option I → TopCat.{u}
+  toBase : ∀ i, C(piece i, B)
+  toBase_mem : ∀ i x, toBase i x ∈ patch i
+  overlap : ∀ i, OpenPartialHomeomorph (piece (Option.some i)) (piece Option.none)
+  source_eq : ∀ i, (overlap i).source = toBase (Option.some i) ⁻¹' (patch Option.none : Set B)
+  target_eq : ∀ i, (overlap i).target = toBase Option.none ⁻¹' (patch (Option.some i) : Set B)
+  preserves_base :
+    ∀ i x, x ∈ (overlap i).source → toBase Option.none (overlap i x) = toBase (Option.some i) x
+
+private def SpecialPeriods.Threefold.Star.Input.transition {B I : Type u} [TopologicalSpace B]
+    (D : SpecialPeriods.Threefold.Star.Input B I) :
+    ∀ i j : Option I, OpenPartialHomeomorph (D.piece i) (D.piece j)
+  | none, Option.none => OpenPartialHomeomorph.refl _
+  | none, Option.some j => (D.overlap j).symm
+  | some i, Option.none => D.overlap i
+  | some i, Option.some j => by
+    classical
+      exact
+      if h : i = j then by
+        subst j
+        exact OpenPartialHomeomorph.refl _
+      else (D.overlap i).trans (D.overlap j).symm
+
+@[simp]
+private theorem SpecialPeriods.Threefold.Star.Input.transition_none_none {B I : Type u}
+    [TopologicalSpace B] (D : SpecialPeriods.Threefold.Star.Input B I) :
+    D.transition Option.none Option.none = OpenPartialHomeomorph.refl (D.piece Option.none) :=
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.Threefold.Star.Input.transition_none_some {B I : Type u}
+    [TopologicalSpace B] (D : SpecialPeriods.Threefold.Star.Input B I) (i : I) :
+    D.transition Option.none (Option.some i) = (D.overlap i).symm :=
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.Threefold.Star.Input.transition_some_none {B I : Type u}
+    [TopologicalSpace B] (D : SpecialPeriods.Threefold.Star.Input B I) (i : I) :
+    D.transition (Option.some i) Option.none = D.overlap i :=
+  rfl
+
+private theorem SpecialPeriods.Threefold.Star.Input.transition_some_self {B I : Type u}
+    [TopologicalSpace B] (D : SpecialPeriods.Threefold.Star.Input B I) (i : I) :
+    D.transition (Option.some i) (Option.some i) =
+      OpenPartialHomeomorph.refl (D.piece (Option.some i)) := by simp [transition]
+
+private theorem SpecialPeriods.Threefold.Star.Input.transition_some_some_of_ne {B I : Type u}
+    [TopologicalSpace B] (D : SpecialPeriods.Threefold.Star.Input B I) {i j : I} (h : i ≠ j) :
+    D.transition (Option.some i) (Option.some j) = (D.overlap i).trans (D.overlap j).symm := by
+  simp [transition, h]
+
+@[simp]
+private theorem
+    SpecialPeriods.Threefold.Star.Input.transition_self {B I : Type u} [TopologicalSpace B]
+    (D : SpecialPeriods.Threefold.Star.Input B I) (i : Option I) :
+    D.transition i i = OpenPartialHomeomorph.refl (D.piece i) := by
+  cases i with
+  | none => simp
+  | some i => exact D.transition_some_self i
+
+private theorem
+    SpecialPeriods.Threefold.Star.Input.transition_symm {B I : Type u} [TopologicalSpace B]
+    (D : SpecialPeriods.Threefold.Star.Input B I) (i j : Option I) :
+    (D.transition i j).symm = D.transition j i := by
+  cases i with
+  | none => cases j <;> simp
+  | some i =>
+    cases j with
+    | none => simp
+    | some j =>
+      by_cases h : i = j
+      · subst j
+        simp
+      · rw [D.transition_some_some_of_ne h, D.transition_some_some_of_ne (Ne.symm h)]
+        simp only [OpenPartialHomeomorph.trans_symm_eq_symm_trans_symm,
+          OpenPartialHomeomorph.symm_symm]
+
+private theorem SpecialPeriods.Threefold.Star.Input.overlap_symm_preserves_base {B I : Type u}
+    [TopologicalSpace B] (D : SpecialPeriods.Threefold.Star.Input B I) (i : I)
+    (x : D.piece Option.none) (hx : x ∈ (D.overlap i).target) :
+    D.toBase (Option.some i) ((D.overlap i).symm x) = D.toBase Option.none x := by
+  have h := D.preserves_base i ((D.overlap i).symm x) ((D.overlap i).map_target hx)
+  rw [(D.overlap i).right_inv hx] at h
+  exact h.symm
+
+@[simp]
+private theorem SpecialPeriods.Threefold.Star.Input.toBase_preimage_own {B I : Type u}
+    [TopologicalSpace B] (D : SpecialPeriods.Threefold.Star.Input B I) (i : Option I) :
+    D.toBase i ⁻¹' (D.patch i : Set B) = Set.univ :=
+  Set.eq_univ_of_forall (D.toBase_mem i)
+
+private theorem SpecialPeriods.Threefold.Star.Input.filling_preimage_eq_empty {B I : Type u}
+    [TopologicalSpace B] (D : SpecialPeriods.Threefold.Star.Input B I) {i j : I} (h : i ≠ j) :
+    D.toBase (Option.some i) ⁻¹' (D.patch (Option.some j) : Set B) = ∅ := by
+  apply Set.eq_empty_iff_forall_notMem.mpr
+  intro x hx
+  exact Set.disjoint_left.mp (D.disjoint h) (D.toBase_mem (Option.some i) x) hx
+
+private theorem
+    SpecialPeriods.Threefold.Star.Input.transition_some_some_source_eq_empty {B I : Type u}
+    [TopologicalSpace B] (D : SpecialPeriods.Threefold.Star.Input B I) {i j : I} (h : i ≠ j) :
+    (D.transition (Option.some i) (Option.some j)).source = ∅ := by
+  rw [D.transition_some_some_of_ne h, OpenPartialHomeomorph.trans_source]
+  apply Set.eq_empty_iff_forall_notMem.mpr
+  rintro x ⟨hx, hy⟩
+  have hb : D.toBase Option.none (D.overlap i x) ∈ D.patch (Option.some j) := by
+    simpa only [OpenPartialHomeomorph.symm_source, D.target_eq j, Set.mem_preimage,
+      SetLike.mem_coe] using hy
+  rw [D.preserves_base i x hx] at hb
+  exact Set.disjoint_left.mp (D.disjoint h) (D.toBase_mem (Option.some i) x) hb
+
+private theorem SpecialPeriods.Threefold.Star.Input.transition_source_eq {B I : Type u}
+    [TopologicalSpace B] (D : SpecialPeriods.Threefold.Star.Input B I) (i j : Option I) :
+    (D.transition i j).source = D.toBase i ⁻¹' (D.patch j : Set B) := by
+  cases i with
+  | none =>
+    cases j with
+    | none => simp
+    | some j => simpa using D.target_eq j
+  | some i =>
+    cases j with
+    | none => exact D.source_eq i
+    | some j =>
+      by_cases h : i = j
+      · subst j
+        simp
+      · rw [D.transition_some_some_source_eq_empty h, D.filling_preimage_eq_empty h]
+
+private theorem SpecialPeriods.Threefold.Star.Input.transition_preserves_base {B I : Type u}
+    [TopologicalSpace B] (D : SpecialPeriods.Threefold.Star.Input B I) (i j : Option I)
+    (x : D.piece i) (hx : x ∈ (D.transition i j).source) :
+    D.toBase j (D.transition i j x) = D.toBase i x := by
+  cases i with
+  | none =>
+    cases j with
+    | none => rfl
+    | some j => exact D.overlap_symm_preserves_base j x hx
+  | some i =>
+    cases j with
+    | none => exact D.preserves_base i x hx
+    | some j =>
+      by_cases h : i = j
+      · subst j
+        simp
+      · rw [D.transition_some_some_source_eq_empty h] at hx
+        exact hx.elim
+
+private theorem SpecialPeriods.Threefold.Star.Input.eq_or_eq_or_eq_of_common_base {B I : Type u}
+    [TopologicalSpace B] (D : SpecialPeriods.Threefold.Star.Input B I) (i j k : Option I) {b : B}
+    (hi : b ∈ D.patch i) (hj : b ∈ D.patch j) (hk : b ∈ D.patch k) : i = j ∨ j = k ∨ i = k := by
+  have he : ∀ a c : I, b ∈ D.patch (Option.some a) → b ∈ D.patch (Option.some c) → a = c := by
+    intro a c ha hc
+    by_contra h
+    exact Set.disjoint_left.mp (D.disjoint h) ha hc
+  cases i with
+  | none =>
+    cases j with
+    | none => exact Or.inl rfl
+    | some j =>
+      cases k with
+      | none => exact Or.inr (Or.inr rfl)
+      | some k => exact Or.inr (Or.inl (congrArg Option.some (he j k hj hk)))
+  | some i =>
+    cases j with
+    | none =>
+      cases k with
+      | none => exact Or.inr (Or.inl rfl)
+      | some k => exact Or.inr (Or.inr (congrArg Option.some (he i k hi hk)))
+    | some j => exact Or.inl (congrArg Option.some (he i j hi hj))
+
+private theorem
+    SpecialPeriods.Threefold.Star.Input.transition_cocycle {B I : Type u} [TopologicalSpace B]
+    (D : SpecialPeriods.Threefold.Star.Input B I) (i j k : Option I) (x : D.piece i)
+    (hx : x ∈ (D.transition i j).source) (hy : D.transition i j x ∈ (D.transition j k).source) :
+    D.transition j k (D.transition i j x) = D.transition i k x := by
+  have hj : D.toBase i x ∈ D.patch j := by
+    simpa only [D.transition_source_eq i j, Set.mem_preimage, SetLike.mem_coe] using hx
+  have hk : D.toBase i x ∈ D.patch k := by
+    have h : D.toBase j (D.transition i j x) ∈ D.patch k := by
+      simpa only [D.transition_source_eq j k, Set.mem_preimage, SetLike.mem_coe] using hy
+    rwa [D.transition_preserves_base i j x hx] at h
+  rcases D.eq_or_eq_or_eq_of_common_base i j k (D.toBase_mem i x) hj hk with hij | hjk | hik
+  · subst j
+    simp
+  · subst k
+    simp
+  · subst k
+    rw [← D.transition_symm i j, D.transition_self]
+    exact (D.transition i j).left_inv hx
+
+private abbrev SpecialPeriods.Threefold.Star.Input.toData {B I : Type u} [TopologicalSpace B]
+    (D : SpecialPeriods.Threefold.Star.Input B I) : ThreefoldGluing.Data B
+    where
+  J := Option I
+  patch := D.patch
+  cover := D.cover
+  piece := D.piece
+  toBase := D.toBase
+  toBase_mem := D.toBase_mem
+  transition := D.transition
+  source_eq := D.transition_source_eq
+  self_eq := D.transition_self
+  symm_eq := D.transition_symm
+  preserves_base := D.transition_preserves_base
+  cocycle := D.transition_cocycle
+
+private theorem SpecialPeriods.Threefold.Star.Input.transition_holomorphic {B I : Type u}
+    [TopologicalSpace B] (D : SpecialPeriods.Threefold.Star.Input B I) {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℂ E] [∀ i, ChartedSpace E (D.piece i)]
+    (hhol :
+      ∀ i,
+        ContMDiffOn (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (D.overlap i)
+          (D.overlap i).source)
+    (hinv :
+      ∀ i,
+        ContMDiffOn (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (D.overlap i).symm
+          (D.overlap i).target)
+    (i j : Option I) :
+    ContMDiffOn (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (D.transition i j)
+      (D.transition i j).source := by
+  cases i with
+  | none =>
+    cases j with
+    | none =>
+      rw [D.transition_none_none]
+      change
+        ContMDiffOn (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω
+          (id : D.piece Option.none → D.piece Option.none) Set.univ
+      exact contMDiffOn_id
+    | some j =>
+      rw [D.transition_none_some]
+      simpa only [OpenPartialHomeomorph.symm_source] using hinv j
+  | some i =>
+    cases j with
+    | none =>
+      rw [D.transition_some_none]
+      exact hhol i
+    | some j =>
+      by_cases h : i = j
+      · subst j
+        rw [D.transition_some_self]
+        change
+          ContMDiffOn (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω
+            (id : D.piece (Option.some i) → D.piece (Option.some i)) Set.univ
+        exact contMDiffOn_id
+      · rw [D.transition_some_some_source_eq_empty h]
+        exact contMDiffOn_empty
+
+private theorem SpecialPeriods.Threefold.Star.Input.toData_transition_holomorphic {B I : Type u}
+    [TopologicalSpace B] (D : SpecialPeriods.Threefold.Star.Input B I) {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℂ E] [∀ i, ChartedSpace E (D.piece i)]
+    (hhol :
+      ∀ i,
+        ContMDiffOn (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (D.overlap i)
+          (D.overlap i).source)
+    (hinv :
+      ∀ i,
+        ContMDiffOn (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (D.overlap i).symm
+          (D.overlap i).target)
+    (i j : D.toData.J) :
+    ContMDiffOn (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (D.toData.transition i j)
+      (D.toData.transition i j).source := by
+  change
+    ContMDiffOn (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ E) ω (D.transition i j)
+      (D.transition i j).source
+  exact D.transition_holomorphic hhol hinv i j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.specialCuspRadius_le :
+    specialBaseCover.radius Option.none ≤ SpecialPeriods.specialCuspData.radius :=
+  specialBaseCover_cusp_radius_bounds.2.1.le
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private abbrev SpecialPeriods.Threefold.SpecialCuspPiece :=
+  CuspPiece.Space SpecialPeriods.specialCuspData specialBaseCover
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+@[instance_reducible]
+private def SpecialPeriods.Threefold.specialCuspPieceChartedSpace :
+    ChartedSpace (ℂ × ComplexPlane₂) SpecialCuspPiece :=
+  CuspPiece.commonChartedSpace SpecialPeriods.specialCuspData specialBaseCover
+    specialCuspRadius_le
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.specialCuspPieceProjection :
+    SpecialCuspPiece → specialBaseCover.fillingPatch Option.none :=
+  CuspPiece.projection SpecialPeriods.specialCuspData specialBaseCover
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.specialCuspPieceProjectionToBase :
+    SpecialCuspPiece → SpecialPeriods.TriangleCompactifiedOrbitSpace :=
+  CuspPiece.projectionToBase SpecialPeriods.specialCuspData specialBaseCover
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.specialCuspPieceProjection_proper :
+    IsProperMap specialCuspPieceProjection :=
+  CuspPiece.projection_proper SpecialPeriods.specialCuspData specialBaseCover specialCuspRadius_le
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.specialCuspPiece_t2Space : T2Space SpecialCuspPiece :=
+  CuspPiece.space_t2Space SpecialPeriods.specialCuspData specialBaseCover specialCuspRadius_le
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.specialCuspPiece_secondCountable :
+    SecondCountableTopology SpecialCuspPiece :=
+  CuspPiece.space_secondCountable SpecialPeriods.specialCuspData specialBaseCover
+    specialCuspRadius_le
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.specialCuspPiece_isManifold :
+    letI := specialCuspPieceChartedSpace
+    IsManifold (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω SpecialCuspPiece :=
+  CuspPiece.common_isManifold SpecialPeriods.specialCuspData specialBaseCover specialCuspRadius_le
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.specialCuspPiece_nonempty : Nonempty SpecialCuspPiece :=
+  CuspPiece.space_nonempty SpecialPeriods.specialCuspData specialBaseCover
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.localPiece : Index → TopCat
+  | none => TopCat.of SpecialRegularFamily
+  | some Option.none => TopCat.of SpecialCuspPiece
+  | some (Option.some j) => TopCat.of (SpecialEllipticPiece j)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+@[instance_reducible]
+private def SpecialPeriods.Threefold.localPieceChartedSpace (i : Index) :
+    ChartedSpace (ℂ × ComplexPlane₂) (localPiece i) := by
+  cases i with
+  | none => exact specialRegularFamilyChartedSpace
+  | some i =>
+    cases i with
+    | none => exact specialCuspPieceChartedSpace
+    | some j => exact specialEllipticPieceChartedSpace j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.localPiece_nonempty (i : Index) : Nonempty (localPiece i) := by
+  cases i with
+  | none => exact specialRegularFamily_nonempty
+  | some i =>
+    cases i with
+    | none => exact specialCuspPiece_nonempty
+    | some j => exact specialEllipticPiece_nonempty j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.localPiece_t2Space (i : Index) : T2Space (localPiece i) := by
+  cases i with
+  | none => exact specialRegularFamily_t2Space
+  | some i =>
+    cases i with
+    | none => exact specialCuspPiece_t2Space
+    | some j => exact specialEllipticPiece_t2Space j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.localPiece_secondCountable (i : Index) :
+    SecondCountableTopology (localPiece i) := by
+  cases i with
+  | none => exact specialRegularFamily_secondCountable
+  | some i =>
+    cases i with
+    | none => exact specialCuspPiece_secondCountable
+    | some j => exact specialEllipticPiece_secondCountable j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.localPiece_isManifold (i : Index) :
+    IsManifold (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (localPiece i) := by
+  cases i with
+  | none => exact specialRegularFamily_isManifold
+  | some i =>
+    cases i with
+    | none => exact specialCuspPiece_isManifold
+    | some j => exact specialEllipticPiece_isManifold j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace in
+private def SpecialPeriods.Threefold.localProjection :
+    (i : Index) → localPiece i → specialBaseCover.patch i
+  | none => specialRegularFamilyProjection
+  | some Option.none => specialCuspPieceProjection
+  | some (Option.some j) => specialEllipticPieceProjection j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.localProjection_proper (i : Index) :
+    IsProperMap (localProjection i) := by
+  cases i with
+  | none => exact specialRegularFamilyProjection_proper
+  | some i =>
+    cases i with
+    | none => exact specialCuspPieceProjection_proper
+    | some j => exact specialEllipticPieceProjection_proper j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace in
+private def SpecialPeriods.Threefold.localProjectionToBase (i : Index) (x : localPiece i) :
+    SpecialPeriods.TriangleCompactifiedOrbitSpace :=
+  localProjection i x
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.localProjectionToBase_mem (i : Index) (x : localPiece i) :
+    localProjectionToBase i x ∈ specialBaseCover.patch i :=
+  (localProjection i x).property
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.localProjectionToBase_continuous (i : Index) :
+    Continuous (localProjectionToBase i) :=
+  continuous_subtype_val.comp (localProjection_proper i).continuous
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.localPieceChartedSpace in
+private def SpecialPeriods.Threefold.localBaseMap (i : Index) :
+    C(localPiece i, SpecialPeriods.TriangleCompactifiedOrbitSpace) :=
+  ⟨localProjectionToBase i, localProjectionToBase_continuous i⟩
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.CuspGlobalOverlap.sphereRegularData
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere)) :
+    PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint :=
+  PeriodFamily.regularData (SpecialPeriods.Construction.periodMapOfSphere π hπ h₀ h₁)
+    (SpecialPeriods.Construction.periodMapOfSphere_generator₁ π hπ h₀ h₁)
+    (SpecialPeriods.Construction.periodMapOfSphere_generator₂ π hπ h₀ h₁)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.CuspGlobalOverlap.sphereCuspData
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere))
+    (r : ℝ) (hr : 0 < r)
+    (hrD : r ≤ (SpecialPeriods.Construction.cuspDataOfSphere π hπ h₀ h₁).radius) :
+    SpecialPeriods.CuspFamily.Data :=
+  (SpecialPeriods.Construction.cuspDataOfSphere π hπ h₀ h₁).shrink r hr hrD
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.CuspGlobalOverlap.sphereCuspData_periodPoint
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere))
+    (r : ℝ) (hr : 0 < r)
+    (hrD : r ≤ (SpecialPeriods.Construction.cuspDataOfSphere π hπ h₀ h₁).radius)
+    (s : SpecialPeriods.CuspFamily.LogBase r) :
+    ((sphereCuspData π hπ h₀ h₁ r hr hrD).periods.point s).val =
+      SpecialPeriods.cuspPeriodPoint (SpecialPeriods.Construction.cuspDataOfSphere π hπ h₀ h₁).μ
+        (SpecialPeriods.Construction.cuspDataOfSphere π hπ h₀ h₁).b
+        (SpecialPeriods.Construction.cuspDataOfSphere π hπ h₀ h₁).h (s : ℂ) :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.CuspGlobalOverlap.spherePeriod_point
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere))
+    (r : ℝ) (hrD : r ≤ (SpecialPeriods.Construction.cuspDataOfSphere π hπ h₀ h₁).radius)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (s : SpecialPeriods.CuspFamily.LogBase r) :
+    ((sphereRegularData π hπ h₀ h₁).periods.point
+          (SpecialPeriods.CuspFamily.logBaseToRegular r hrcap s)).val =
+      SpecialPeriods.cuspPeriodPoint (SpecialPeriods.Construction.cuspDataOfSphere π hπ h₀ h₁).μ
+        (SpecialPeriods.Construction.cuspDataOfSphere π hπ h₀ h₁).b
+        (SpecialPeriods.Construction.cuspDataOfSphere π hπ h₀ h₁).h (s : ℂ) := by
+  have hz :
+    ‖SpecialPeriods.Triangle.cuspQ (SpecialPeriods.CuspFamily.logBaseToRegular r hrcap s : ℍ)‖ <
+      (SpecialPeriods.Construction.cuspDataOfSphere π hπ h₀ h₁).radius := by
+    rw [SpecialPeriods.CuspFamily.logBaseToRegular_cuspQ]
+    exact ((SpecialPeriods.CuspFamily.mem_logBase r s).mp s.property).trans_le hrD
+  have h :=
+    SpecialPeriods.Construction.cuspDataOfSphere_periodPoint π hπ h₀ h₁
+      (SpecialPeriods.CuspFamily.logBaseToRegular r hrcap s : ℍ) hz
+  rw [SpecialPeriods.CuspFamily.logBaseToRegular_coe,
+    mul_div_cancel_left₀ _
+      (Complex.ofReal_ne_zero.mpr SpecialPeriods.Triangle.width_ne_zero)] at h
+  exact h
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.CuspGlobalOverlap.spherePeriod_agreement
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere))
+    (r : ℝ) (hr : 0 < r)
+    (hrD : r ≤ (SpecialPeriods.Construction.cuspDataOfSphere π hπ h₀ h₁).radius)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (s : SpecialPeriods.CuspFamily.LogBase r) :
+    (sphereRegularData π hπ h₀ h₁).periods.point
+        (SpecialPeriods.CuspFamily.logBaseToRegular r hrcap s) =
+      (sphereCuspData π hπ h₀ h₁ r hr hrD).periods.point s := by
+  apply Subtype.ext
+  rw [sphereCuspData_periodPoint]
+  exact spherePeriod_point π hπ h₀ h₁ r hrD hrcap s
+
+private def SpecialPeriods.CuspGlobalOverlap.QuotientComparison.totalMap
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (f : SpecialPeriods.CuspFamily.LogBase C.radius → SpecialPeriods.TriangleRegularPoint)
+    (x : C.TotalSpace) : D.TotalSpace :=
+  (f x.1, x.2)
+
+private theorem SpecialPeriods.CuspGlobalOverlap.QuotientComparison.totalMap_injective
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (f : SpecialPeriods.CuspFamily.LogBase C.radius → SpecialPeriods.TriangleRegularPoint)
+    (hf : Function.Injective f) : Function.Injective (totalMap C D f) := by
+  intro x y h
+  exact Prod.ext (hf (congrArg Prod.fst h)) (congrArg (fun z : D.TotalSpace => z.2) h)
+
+private theorem SpecialPeriods.CuspGlobalOverlap.QuotientComparison.totalMap_equivariant
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (f : SpecialPeriods.CuspFamily.LogBase C.radius → SpecialPeriods.TriangleRegularPoint)
+    (hbase :
+      ∀ (k : ℤ) (s : SpecialPeriods.CuspFamily.LogBase C.radius),
+        f (SpecialPeriods.CuspFamily.logBaseTranslate C.radius k s) =
+          SpecialPeriods.triangleCuspGenerator ^ k • f s)
+    (htorus :
+      ∀ k : ℤ,
+        SpecialPeriods.triangleTorusHomeomorph (SpecialPeriods.triangleCuspGenerator ^ k) =
+          SpecialPeriods.CuspFamily.cuspTorusHomeomorph k)
+    (k : Multiplicative ℤ) (x : C.TotalSpace) :
+    letI := C.totalAction
+    letI := D.totalAction
+    totalMap C D f (k • x) = SpecialPeriods.triangleCuspGenerator ^ k.toAdd • totalMap C D f x := by
+  let := C.totalAction
+  let := D.totalAction
+  change
+    (f (SpecialPeriods.CuspFamily.logBaseTranslate C.radius k.toAdd x.1),
+        SpecialPeriods.CuspFamily.cuspTorusHomeomorph k.toAdd x.2) =
+      (SpecialPeriods.triangleCuspGenerator ^ k.toAdd • f x.1,
+        SpecialPeriods.triangleTorusHomeomorph (SpecialPeriods.triangleCuspGenerator ^ k.toAdd)
+          x.2)
+  rw [hbase, htorus]
+
+private def SpecialPeriods.CuspGlobalOverlap.QuotientComparison.descend
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (f : SpecialPeriods.CuspFamily.LogBase C.radius → SpecialPeriods.TriangleRegularPoint)
+    (hbase :
+      ∀ (k : ℤ) (s : SpecialPeriods.CuspFamily.LogBase C.radius),
+        f (SpecialPeriods.CuspFamily.logBaseTranslate C.radius k s) =
+          SpecialPeriods.triangleCuspGenerator ^ k • f s)
+    (htorus :
+      ∀ k : ℤ,
+        SpecialPeriods.triangleTorusHomeomorph (SpecialPeriods.triangleCuspGenerator ^ k) =
+          SpecialPeriods.CuspFamily.cuspTorusHomeomorph k) :
+    C.Space → D.Space := by
+  letI := C.totalAction
+  letI := D.totalAction
+  exact
+    Quotient.lift (D.quotient ∘ totalMap C D f)
+      (by
+        rintro x y ⟨k, hk⟩
+        change D.quotient (totalMap C D f x) = D.quotient (totalMap C D f y)
+        rw [← hk, totalMap_equivariant C D f hbase htorus, D.quotient_smul])
+
+private theorem SpecialPeriods.CuspGlobalOverlap.QuotientComparison.descend_injective
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (f : SpecialPeriods.CuspFamily.LogBase C.radius → SpecialPeriods.TriangleRegularPoint)
+    (hbase :
+      ∀ (k : ℤ) (s : SpecialPeriods.CuspFamily.LogBase C.radius),
+        f (SpecialPeriods.CuspFamily.logBaseTranslate C.radius k s) =
+          SpecialPeriods.triangleCuspGenerator ^ k • f s)
+    (htorus :
+      ∀ k : ℤ,
+        SpecialPeriods.triangleTorusHomeomorph (SpecialPeriods.triangleCuspGenerator ^ k) =
+          SpecialPeriods.CuspFamily.cuspTorusHomeomorph k)
+    (hf : Function.Injective f)
+    (hreturn :
+      ∀ (g : SpecialPeriods.TriangleGroup) (s t : SpecialPeriods.CuspFamily.LogBase C.radius),
+        g • f t = f s → ∃ k : ℤ, SpecialPeriods.triangleCuspGenerator ^ k = g) :
+    Function.Injective (descend C D f hbase htorus) := by
+  let := C.totalAction
+  let := D.totalAction
+  intro x y hxy
+  obtain ⟨a, rfl⟩ := C.quotient_surjective x
+  obtain ⟨b, rfl⟩ := C.quotient_surjective y
+  obtain ⟨g, hg⟩ := (D.quotient_eq_iff _ _).mp hxy
+  have hb : g • f b.1 = f a.1 := congrArg Prod.fst hg
+  obtain ⟨k, rfl⟩ := hreturn g a.1 b.1 hb
+  apply (C.quotient_eq_iff _ _).mpr
+  refine ⟨Multiplicative.ofAdd k, ?_⟩
+  apply totalMap_injective C D f hf
+  rw [totalMap_equivariant C D f hbase htorus]
+  exact hg
+
+private theorem SpecialPeriods.CuspGlobalOverlap.QuotientComparison.range_descend
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (f : SpecialPeriods.CuspFamily.LogBase C.radius → SpecialPeriods.TriangleRegularPoint)
+    (hbase :
+      ∀ (k : ℤ) (s : SpecialPeriods.CuspFamily.LogBase C.radius),
+        f (SpecialPeriods.CuspFamily.logBaseTranslate C.radius k s) =
+          SpecialPeriods.triangleCuspGenerator ^ k • f s)
+    (htorus :
+      ∀ k : ℤ,
+        SpecialPeriods.triangleTorusHomeomorph (SpecialPeriods.triangleCuspGenerator ^ k) =
+          SpecialPeriods.CuspFamily.cuspTorusHomeomorph k) :
+    Set.range (descend C D f hbase htorus) = D.projection ⁻¹' Set.range (D.baseQuotient ∘ f) := by
+  let := D.totalAction
+  ext y
+  constructor
+  · rintro ⟨x, rfl⟩
+    obtain ⟨a, rfl⟩ := C.quotient_surjective x
+    exact ⟨a.1, rfl⟩
+  · rintro ⟨s, hs⟩
+    obtain ⟨⟨b, t⟩, rfl⟩ := D.quotient_surjective y
+    have hbase' : D.baseQuotient (f s) = D.baseQuotient b := hs
+    have hrel : ∃ g : SpecialPeriods.TriangleGroup, g • b = f s := Quotient.eq''.mp hbase'
+    obtain ⟨g, hg⟩ := hrel
+    refine ⟨C.quotient (s, SpecialPeriods.triangleTorusHomeomorph g t), ?_⟩
+    apply (D.quotient_eq_iff _ _).mpr
+    exact ⟨g, Prod.ext hg rfl⟩
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace in
+private def SpecialPeriods.CuspGlobalOverlap.baseCover (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) :
+    SpecialPeriods.CuspFamily.LogBase r → SpecialPeriods.TriangleRegularQuotient :=
+  SpecialPeriods.triangleRegularProject ∘ SpecialPeriods.CuspFamily.logBaseToRegular r hrcap
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace in
+private theorem SpecialPeriods.CuspGlobalOverlap.baseCover_isLocalDiffeomorph (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) :
+    IsLocalDiffeomorph 𝓘(ℂ) 𝓘(ℂ) ω (baseCover r hrcap) := by
+  intro s
+  exact
+    (SpecialPeriods.CuspFamily.logBaseToRegular_isLocalDiffeomorph r hrcap s).comp (K := 𝓘(ℂ))
+      (P := SpecialPeriods.TriangleRegularQuotient)
+      (SpecialPeriods.triangleRegularProject_isLocalDiffeomorph
+        (SpecialPeriods.CuspFamily.logBaseToRegular r hrcap s))
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace in
+private def SpecialPeriods.CuspGlobalOverlap.basePatch (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) :
+    TopologicalSpace.Opens SpecialPeriods.TriangleRegularQuotient :=
+  ⟨Set.range (baseCover r hrcap), (baseCover_isLocalDiffeomorph r hrcap).isOpen_range⟩
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace in
+private def SpecialPeriods.CuspGlobalOverlap.compactBase :
+    SpecialPeriods.TriangleRegularQuotient → SpecialPeriods.TriangleCompactifiedOrbitSpace :=
+  SpecialPeriods.triangleOpenInclusion ∘ SpecialPeriods.triangleRegularToOrbit
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace in
+@[simp]
+private theorem SpecialPeriods.CuspGlobalOverlap.compactBase_baseCover (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (s : SpecialPeriods.CuspFamily.LogBase r) :
+    compactBase (baseCover r hrcap s) =
+      SpecialPeriods.triangleOpenInclusion
+        (SpecialPeriods.triangleOrbitProjection
+          (SpecialPeriods.CuspFamily.logBaseToRegular r hrcap s : ℍ)) :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace in
+private theorem SpecialPeriods.CuspGlobalOverlap.compactBase_baseCover_mem_chart (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (s : SpecialPeriods.CuspFamily.LogBase r) :
+    compactBase (baseCover r hrcap s) ∈
+      (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).source := by
+  apply
+    (SpecialPeriods.Triangle.openInclusion_mem_cuspNeighborhood SpecialPeriods.Triangle.width
+        _).mpr
+  exact
+    ⟨(SpecialPeriods.CuspFamily.logBaseToRegular r hrcap s : ℍ),
+      SpecialPeriods.CuspFamily.logBaseToRegular_mem_horodisc r hrcap s, rfl⟩
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace in
+private theorem SpecialPeriods.CuspGlobalOverlap.cuspFullChart_compactBase_baseCover (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (s : SpecialPeriods.CuspFamily.LogBase r) :
+    SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl
+        (compactBase (baseCover r hrcap s)) =
+      CuspUniformization.exponential s := by
+  rw [compactBase_baseCover]
+  exact
+    (SpecialPeriods.Triangle.cuspFullChart_mk SpecialPeriods.Triangle.width le_rfl
+          ⟨(SpecialPeriods.CuspFamily.logBaseToRegular r hrcap s : ℍ),
+            SpecialPeriods.CuspFamily.logBaseToRegular_mem_horodisc r hrcap s⟩).trans
+      (SpecialPeriods.CuspFamily.logBaseToRegular_cuspQ r hrcap s)
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace in
+private theorem SpecialPeriods.CuspGlobalOverlap.logBaseToRegular_return (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (g : SpecialPeriods.TriangleGroup) (s t : SpecialPeriods.CuspFamily.LogBase r)
+    (he :
+      g • SpecialPeriods.CuspFamily.logBaseToRegular r hrcap t =
+        SpecialPeriods.CuspFamily.logBaseToRegular r hrcap s) :
+    ∃ k : ℤ, SpecialPeriods.triangleCuspGenerator ^ k = g := by
+  apply Subgroup.mem_zpowers_iff.mp
+  apply
+    SpecialPeriods.Triangle.triangle_horodisc_overlap_mem_cusp SpecialPeriods.Triangle.width
+      le_rfl g
+  exact
+    ⟨(SpecialPeriods.CuspFamily.logBaseToRegular r hrcap s : ℍ),
+      ⟨(SpecialPeriods.CuspFamily.logBaseToRegular r hrcap t : ℍ),
+        SpecialPeriods.CuspFamily.logBaseToRegular_mem_horodisc r hrcap t,
+        congrArg Subtype.val he⟩,
+      SpecialPeriods.CuspFamily.logBaseToRegular_mem_horodisc r hrcap s⟩
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace in
+private theorem SpecialPeriods.CuspGlobalOverlap.mem_basePatch_iff (r : ℝ)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (q : SpecialPeriods.TriangleRegularQuotient) :
+    q ∈ basePatch r hrcap ↔
+      compactBase q ∈
+          (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).source ∧
+        ‖SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl
+              (compactBase q)‖ <
+          r := by
+  constructor
+  · rintro ⟨s, rfl⟩
+    refine ⟨compactBase_baseCover_mem_chart r hrcap s, ?_⟩
+    rw [cuspFullChart_compactBase_baseCover]
+    exact (SpecialPeriods.CuspFamily.mem_logBase r s).mp s.property
+  · rintro ⟨hsource, hnorm⟩
+    have himage :
+      SpecialPeriods.triangleRegularToOrbit q ∈
+        SpecialPeriods.Triangle.cuspImage SpecialPeriods.Triangle.width :=
+      (SpecialPeriods.Triangle.openInclusion_mem_cuspNeighborhood SpecialPeriods.Triangle.width
+            _).mp
+        hsource
+    obtain ⟨z, hz, he⟩ := himage
+    have hqz : ‖SpecialPeriods.Triangle.cuspQ z‖ < r := by
+      have hcoord :=
+        SpecialPeriods.Triangle.cuspFullChart_mk SpecialPeriods.Triangle.width le_rfl
+          (⟨z, hz⟩ : SpecialPeriods.Triangle.horodisc SpecialPeriods.Triangle.width)
+      change
+        SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl
+            (SpecialPeriods.triangleOpenInclusion (SpecialPeriods.triangleOrbitProjection z)) =
+          SpecialPeriods.Triangle.cuspQ z at hcoord
+      rw [he] at hcoord
+      exact hcoord ▸ hnorm
+    obtain ⟨s, hs⟩ :=
+      (SpecialPeriods.CuspFamily.logBaseToUpperHalfPlane_range r hrcap ▸ hqz :
+        z ∈ Set.range (SpecialPeriods.CuspFamily.logBaseToUpperHalfPlane r hrcap))
+    refine ⟨s, SpecialPeriods.triangleRegularToOrbit_injective ?_⟩
+    change
+      SpecialPeriods.triangleOrbitProjection
+          (SpecialPeriods.CuspFamily.logBaseToUpperHalfPlane r hrcap s) =
+        SpecialPeriods.triangleRegularToOrbit q
+    rw [hs]
+    exact he
+
+@[instance_reducible]
+private def SpecialPeriods.EllipticFilling.coveringChartedSpace {A : Type*} [TopologicalSpace A]
+    [ChartedSpace ℂ A] : ChartedSpace (ℂ × ComplexPlane₂) (A × ComplexPlane₂) :=
+  inferInstanceAs (ChartedSpace (ModelProd ℂ ComplexPlane₂) (A × ComplexPlane₂))
+
+attribute [local instance] SpecialPeriods.EllipticFilling.coveringChartedSpace in
+private theorem SpecialPeriods.EllipticFilling.coveringManifold {A : Type*} [TopologicalSpace A]
+    [ChartedSpace ℂ A] [IsManifold (modelWithCornersSelf ℂ ℂ) ω A] :
+    IsManifold (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (A × ComplexPlane₂) := by
+  rw [modelWithCornersSelf_prod]
+  exact
+    IsManifold.prod (I := (modelWithCornersSelf ℂ ℂ)) (I' :=
+      (modelWithCornersSelf ℂ ComplexPlane₂)) A ComplexPlane₂
+
+attribute [local instance] SpecialPeriods.EllipticFilling.coveringChartedSpace
+    SpecialPeriods.EllipticFilling.coveringManifold in
+public
+theorem SpecialPeriods.EllipticFilling.localDiffeomorphAt_of_comp {E F K M N T : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℂ E] [NormedAddCommGroup F] [NormedSpace ℂ F]
+    [NormedAddCommGroup K] [NormedSpace ℂ K] [TopologicalSpace M] [ChartedSpace E M]
+    [TopologicalSpace N] [ChartedSpace F N] [TopologicalSpace T] [ChartedSpace K T] {q : M → N}
+    {f : N → T} {x : M}
+    (hq : IsLocalDiffeomorphAt (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ F) ω q x)
+    (hf :
+      IsLocalDiffeomorphAt (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ K) ω (f ∘ q) x) :
+    IsLocalDiffeomorphAt (modelWithCornersSelf ℂ F) (modelWithCornersSelf ℂ K) ω f (q x) := by
+  have hx : hq.localInverse (q x) = x := hq.localInverse_left_inv hq.localInverse_mem_target
+  have hf' :
+    IsLocalDiffeomorphAt (modelWithCornersSelf ℂ E) (modelWithCornersSelf ℂ K) ω (f ∘ q)
+      (hq.localInverse (q x)) := by
+    rw [hx]
+    exact hf
+  have h := hq.localInverse_isLocalDiffeomorphAt.comp (K := modelWithCornersSelf ℂ K) (P := T) hf'
+  apply isLocalDiffeomorphAt_congr_of_eventuallyEq h
+  filter_upwards [hq.localInverse_eventuallyEq_right] with y hy
+  change f y = f (q (hq.localInverse y))
+  rw [show q (hq.localInverse y) = y from hy]
+
+attribute [local instance] SpecialPeriods.EllipticFilling.coveringChartedSpace
+    SpecialPeriods.EllipticFilling.coveringManifold in
+private def
+    SpecialPeriods.EllipticFilling.productPartialDiffeomorph {A B : Type*} [TopologicalSpace A]
+    [ChartedSpace ℂ A] [TopologicalSpace B] [ChartedSpace ℂ B]
+    (e : PartialDiffeomorph (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) A B ω) :
+    PartialDiffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) (A × ComplexPlane₂) (B × ComplexPlane₂) ω
+    where
+  toPartialEquiv :=
+    (e.toOpenPartialHomeomorph.prod (OpenPartialHomeomorph.refl ComplexPlane₂)).toPartialEquiv
+  open_source := e.open_source.prod isOpen_univ
+  open_target := e.open_target.prod isOpen_univ
+  contMDiffOn_toFun := by
+    rw [modelWithCornersSelf_prod]
+    exact
+      (e.contMDiffOn_toFun.comp contMDiff_fst.contMDiffOn (fun _ hx => hx.1)).prodMk
+        contMDiff_snd.contMDiffOn
+  contMDiffOn_invFun := by
+    rw [modelWithCornersSelf_prod]
+    exact
+      (e.contMDiffOn_invFun.comp contMDiff_fst.contMDiffOn (fun _ hx => hx.1)).prodMk
+        contMDiff_snd.contMDiffOn
+
+attribute [local instance] SpecialPeriods.EllipticFilling.coveringChartedSpace
+    SpecialPeriods.EllipticFilling.coveringManifold in
+private theorem SpecialPeriods.EllipticFilling.productMap_isLocalDiffeomorph {A B : Type*}
+    [TopologicalSpace A] [ChartedSpace ℂ A] [TopologicalSpace B] [ChartedSpace ℂ B] {f : A → B}
+    (hf : IsLocalDiffeomorph (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) ω f) :
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω
+      (fun x : A × ComplexPlane₂ => (f x.1, x.2)) := by
+  intro x
+  obtain ⟨e, hx, he⟩ := hf x.1
+  refine ⟨productPartialDiffeomorph e, ⟨hx, Set.mem_univ _⟩, ?_⟩
+  intro y hy
+  exact Prod.ext (he hy.1) rfl
+
+attribute [local instance] SpecialPeriods.EllipticFilling.coveringChartedSpace
+    SpecialPeriods.EllipticFilling.coveringManifold in
+private def SpecialPeriods.EllipticFilling.periodFamilyMap {A B : Type*} [TopologicalSpace A]
+    [ChartedSpace ℂ A] [TopologicalSpace B] [ChartedSpace ℂ B] (Q : HolomorphicPeriodMap ℂ A)
+    (P : HolomorphicPeriodMap ℂ B) (f : A → B) : Q.TotalSpace → P.TotalSpace := fun x =>
+  (f x.1, x.2)
+
+attribute [local instance] SpecialPeriods.EllipticFilling.coveringChartedSpace
+    SpecialPeriods.EllipticFilling.coveringManifold in
+private theorem
+    SpecialPeriods.EllipticFilling.periodFamilyMap_cover {A B : Type*} [TopologicalSpace A]
+    [ChartedSpace ℂ A] [TopologicalSpace B] [ChartedSpace ℂ B] (Q : HolomorphicPeriodMap ℂ A)
+    (P : HolomorphicPeriodMap ℂ B) (f : A → B) (hperiod : ∀ a, Q.point a = P.point (f a))
+    (x : A × ComplexPlane₂) :
+    periodFamilyMap Q P f (Q.quotientMap x) = P.quotientMap (f x.1, x.2) := by
+  apply Prod.ext
+  · rfl
+  · change
+      standardLattice.mkQ ((Q.periodEquiv x.1).symm x.2) =
+        standardLattice.mkQ ((P.periodEquiv (f x.1)).symm x.2)
+    rw [show Q.periodEquiv x.1 = P.periodEquiv (f x.1) by
+        simp only [HolomorphicPeriodMap.periodEquiv, hperiod] ]
+
+attribute [local instance] SpecialPeriods.EllipticFilling.coveringChartedSpace
+    SpecialPeriods.EllipticFilling.coveringManifold in
+private theorem SpecialPeriods.EllipticFilling.periodFamilyMap_isLocalDiffeomorph {A B : Type*}
+    [TopologicalSpace A] [ChartedSpace ℂ A] [TopologicalSpace B] [ChartedSpace ℂ B]
+    [IsManifold (modelWithCornersSelf ℂ ℂ) ω A] [IsManifold (modelWithCornersSelf ℂ ℂ) ω B]
+    (Q : HolomorphicPeriodMap ℂ A) (P : HolomorphicPeriodMap ℂ B) (f : A → B)
+    (hperiod : ∀ a, Q.point a = P.point (f a))
+    (hf : IsLocalDiffeomorph (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) ω f) :
+    letI := Q.totalChartedSpace
+    letI := P.totalChartedSpace
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (periodFamilyMap Q P f) := by
+  let := Q.totalChartedSpace
+  let := P.totalChartedSpace
+  let := Q.coveringAction
+  have hQ :
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω Q.quotientMap :=
+    CoveringQuotient.project_isLocalDiffeomorph Q.quotientCoveringMap Q.coveringAction_holomorphic
+  have hP :
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω P.quotientMap := by
+    let := P.coveringAction
+    exact
+      CoveringQuotient.project_isLocalDiffeomorph P.quotientCoveringMap
+        P.coveringAction_holomorphic
+  intro y
+  obtain ⟨x, rfl⟩ := Q.quotientMap_surjective y
+  apply localDiffeomorphAt_of_comp (hQ x)
+  have h :=
+    (productMap_isLocalDiffeomorph hf x).comp (K := (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)))
+      (P := P.TotalSpace) (hP (f x.1, x.2))
+  exact
+    isLocalDiffeomorphAt_congr_of_eventuallyEq h
+      (Filter.Eventually.of_forall (periodFamilyMap_cover Q P f hperiod))
+
+attribute [local instance] SpecialPeriods.EllipticFilling.coveringChartedSpace
+    SpecialPeriods.EllipticFilling.coveringManifold in
+private def SpecialPeriods.EllipticFilling.restrictPeriods {B : Type*} [TopologicalSpace B]
+    [ChartedSpace ℂ B] (P : HolomorphicPeriodMap ℂ B) (U : TopologicalSpace.Opens B) :
+    HolomorphicPeriodMap ℂ U where
+  point x := P.point x
+  holomorphic_tau := P.holomorphic_tau.comp contMDiff_subtype_val
+  holomorphic_mu := P.holomorphic_mu.comp contMDiff_subtype_val
+  holomorphic_beta := P.holomorphic_beta.comp contMDiff_subtype_val
+
+attribute [local instance] SpecialPeriods.EllipticFilling.coveringChartedSpace
+    SpecialPeriods.EllipticFilling.coveringManifold in
+private def SpecialPeriods.EllipticFilling.periodFamilyOpen {B : Type*} [TopologicalSpace B]
+    [ChartedSpace ℂ B] (P : HolomorphicPeriodMap ℂ B) (U : TopologicalSpace.Opens B) :
+    TopologicalSpace.Opens P.TotalSpace :=
+  ⟨P.projection ⁻¹' (U : Set B), U.isOpen.preimage continuous_fst⟩
+
+attribute [local instance] SpecialPeriods.EllipticFilling.coveringChartedSpace
+    SpecialPeriods.EllipticFilling.coveringManifold in
+private def SpecialPeriods.EllipticFilling.restrictFamilyMap {B : Type*} [TopologicalSpace B]
+    [ChartedSpace ℂ B] (P : HolomorphicPeriodMap ℂ B) (U : TopologicalSpace.Opens B) :
+    (restrictPeriods P U).TotalSpace → periodFamilyOpen P U := fun x => ⟨(x.1.1, x.2), x.1.2⟩
+
+attribute [local instance] SpecialPeriods.EllipticFilling.coveringChartedSpace
+    SpecialPeriods.EllipticFilling.coveringManifold in
+private theorem SpecialPeriods.EllipticFilling.restrictFamilyMap_bijective {B : Type*}
+    [TopologicalSpace B] [ChartedSpace ℂ B] (P : HolomorphicPeriodMap ℂ B)
+    (U : TopologicalSpace.Opens B) : Function.Bijective (restrictFamilyMap P U) := by
+  constructor
+  · intro x y h
+    have he := congrArg Subtype.val h
+    exact
+      Prod.ext (Subtype.ext (congrArg (fun z : B × RealTorus₄ => z.1) he))
+        (congrArg (fun z : B × RealTorus₄ => z.2) he)
+  · intro y
+    exact ⟨(⟨y.1.1, y.2⟩, y.1.2), rfl⟩
+
+attribute [local instance] SpecialPeriods.EllipticFilling.coveringChartedSpace
+    SpecialPeriods.EllipticFilling.coveringManifold in
+private theorem SpecialPeriods.EllipticFilling.restrictFamilyMap_isLocalDiffeomorph {B : Type*}
+    [TopologicalSpace B] [ChartedSpace ℂ B] [IsManifold (modelWithCornersSelf ℂ ℂ) ω B]
+    (P : HolomorphicPeriodMap ℂ B) (U : TopologicalSpace.Opens B) :
+    letI := (restrictPeriods P U).totalChartedSpace
+    letI := P.totalChartedSpace
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (restrictFamilyMap P U) := by
+  let := (restrictPeriods P U).totalChartedSpace
+  let := P.totalChartedSpace
+  exact
+    isLocalDiffeomorph_codRestrictOpens (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (periodFamilyMap_isLocalDiffeomorph (restrictPeriods P U) P Subtype.val (fun _ => rfl)
+        (isLocalDiffeomorph_subtypeVal (modelWithCornersSelf ℂ ℂ) U))
+      (periodFamilyOpen P U) (fun x => x.1.2)
+
+attribute [local instance] SpecialPeriods.EllipticFilling.coveringChartedSpace
+    SpecialPeriods.EllipticFilling.coveringManifold in
+private def
+    SpecialPeriods.EllipticFilling.restrictFamilyBiholomorph {B : Type*} [TopologicalSpace B]
+    [ChartedSpace ℂ B] [IsManifold (modelWithCornersSelf ℂ ℂ) ω B] (P : HolomorphicPeriodMap ℂ B)
+    (U : TopologicalSpace.Opens B) :
+    letI := (restrictPeriods P U).totalChartedSpace
+    letI := P.totalChartedSpace
+    Diffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) (restrictPeriods P U).TotalSpace
+      (periodFamilyOpen P U) ω := by
+  let := (restrictPeriods P U).totalChartedSpace
+  let := P.totalChartedSpace
+  exact
+    (restrictFamilyMap_isLocalDiffeomorph P U).diffeomorphOfBijective
+      (restrictFamilyMap_bijective P U)
+
+attribute [local instance] SpecialPeriods.EllipticFilling.coveringChartedSpace
+    SpecialPeriods.EllipticFilling.coveringManifold in
+@[simp]
+private theorem SpecialPeriods.EllipticFilling.restrictFamilyBiholomorph_symm_apply {B : Type*}
+    [TopologicalSpace B] [ChartedSpace ℂ B] [IsManifold (modelWithCornersSelf ℂ ℂ) ω B]
+    (P : HolomorphicPeriodMap ℂ B) (U : TopologicalSpace.Opens B) (x : periodFamilyOpen P U) :
+    letI := (restrictPeriods P U).totalChartedSpace
+    letI := P.totalChartedSpace
+    (restrictFamilyBiholomorph P U).symm x = (⟨x.1.1, x.2⟩, x.1.2) := by
+  let := (restrictPeriods P U).totalChartedSpace
+  let := P.totalChartedSpace
+  apply (restrictFamilyBiholomorph P U).injective
+  exact (restrictFamilyBiholomorph P U).apply_symm_apply x
+
+private theorem SpecialPeriods.CuspGlobalOverlap.familyCovering
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    IsQuotientCoveringMap D.baseQuotient SpecialPeriods.TriangleGroup :=
+  SpecialPeriods.triangleRegularProject_covering
+
+private def SpecialPeriods.CuspGlobalOverlap.familyMap (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) :
+    C.Space → D.Space :=
+  QuotientComparison.descend C D (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap)
+    (SpecialPeriods.CuspFamily.logBaseToRegular_translate C.radius hrcap)
+    SpecialPeriods.triangleTorusHomeomorph_cusp_zpow
+
+@[simp]
+private theorem
+    SpecialPeriods.CuspGlobalOverlap.familyMap_quotient (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (x : C.TotalSpace) :
+    familyMap C D hrcap (C.quotient x) =
+      D.quotient (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap x.1, x.2) :=
+  rfl
+
+private theorem
+    SpecialPeriods.CuspGlobalOverlap.familyMap_injective (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) :
+    Function.Injective (familyMap C D hrcap) :=
+  QuotientComparison.descend_injective C D
+    (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap)
+    (SpecialPeriods.CuspFamily.logBaseToRegular_translate C.radius hrcap)
+    SpecialPeriods.triangleTorusHomeomorph_cusp_zpow
+    (SpecialPeriods.CuspFamily.logBaseToRegular_injective C.radius hrcap)
+    (logBaseToRegular_return C.radius hrcap)
+
+private def SpecialPeriods.CuspGlobalOverlap.familyPatch (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) :
+    TopologicalSpace.Opens D.Space :=
+  ⟨D.projection ⁻¹' (basePatch C.radius hrcap : Set SpecialPeriods.TriangleRegularQuotient),
+    (basePatch C.radius hrcap).isOpen.preimage D.projection_continuous⟩
+
+private theorem
+    SpecialPeriods.CuspGlobalOverlap.familyMap_range (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) :
+    Set.range (familyMap C D hrcap) = (familyPatch C D hrcap : Set D.Space) :=
+  QuotientComparison.range_descend C D (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap)
+    (SpecialPeriods.CuspFamily.logBaseToRegular_translate C.radius hrcap)
+    SpecialPeriods.triangleTorusHomeomorph_cusp_zpow
+
+private theorem
+    SpecialPeriods.CuspGlobalOverlap.familyMap_mem_patch (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (x : C.Space) : familyMap C D hrcap x ∈ familyPatch C D hrcap := by
+  change familyMap C D hrcap x ∈ (familyPatch C D hrcap : Set D.Space)
+  rw [← familyMap_range]
+  exact Set.mem_range_self x
+
+private def SpecialPeriods.CuspGlobalOverlap.familyMapInto (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (x : C.Space) : familyPatch C D hrcap :=
+  ⟨familyMap C D hrcap x, familyMap_mem_patch C D hrcap x⟩
+
+private theorem SpecialPeriods.CuspGlobalOverlap.familyMapInto_bijective
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) :
+    Function.Bijective (familyMapInto C D hrcap) := by
+  constructor
+  · intro x y h
+    exact familyMap_injective C D hrcap (congrArg Subtype.val h)
+  · intro y
+    have hy : y.val ∈ Set.range (familyMap C D hrcap) := by
+      rw [familyMap_range]
+      exact y.property
+    obtain ⟨x, hx⟩ := hy
+    exact ⟨x, Subtype.ext hx⟩
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Threefold/SpecialPeriods8.lean b/LeanPool/HopfProblem/Threefold/SpecialPeriods8.lean
new file mode 100644
index 000000000..8eb8a2483
--- /dev/null
+++ b/LeanPool/HopfProblem/Threefold/SpecialPeriods8.lean
@@ -0,0 +1,2792 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Foundations.FibreTopology
+public import LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap2
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.Recognition.Smale1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen1
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap1
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Foundations.Core4
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.Foundations.LocalOrbitQuotient
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods3
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.PeriodFamily.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods6
+import all LeanPool.HopfProblem.PeriodFamily.Core2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import all LeanPool.HopfProblem.Elliptic.Core3
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldGluing1
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.Elliptic.Core4
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldGluing2
+import all LeanPool.HopfProblem.Foundations.FibreTopology
+import all LeanPool.HopfProblem.PeriodFamily.HolomorphicPeriodMap2
+
+/-!
+# Hopf problem: threefold · special periods 8
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem SpecialPeriods.CuspGlobalOverlap.familyMap_isLocalDiffeomorph
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (hperiod :
+      ∀ s : SpecialPeriods.CuspFamily.LogBase C.radius,
+        D.periods.point (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap s) =
+          C.periods.point s) :
+    letI := C.chartedSpace
+    letI := D.chartedSpace (familyCovering D)
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (familyMap C D hrcap) := by
+  let := C.periods.totalChartedSpace
+  let := D.periods.totalChartedSpace
+  let := D.periods.totalSpace_isManifold
+  let := C.chartedSpace
+  let := D.chartedSpace (familyCovering D)
+  have hmap :=
+    HolomorphicPeriodMap.periodPullbackMap_isLocalDiffeomorph C.periods D.periods
+      (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap) hperiod
+      (SpecialPeriods.CuspFamily.logBaseToRegular_isLocalDiffeomorph C.radius hrcap)
+  have hq :
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω D.quotient := by
+    let := D.totalAction
+    exact
+      CoveringQuotient.project_isLocalDiffeomorph (D.quotientCoveringMap (familyCovering D))
+        D.totalAction_holomorphic
+  apply
+    isLocalDiffeomorph_of_comp_surjective (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      C.quotient_isLocalDiffeomorph C.quotient_surjective
+  intro x
+  exact
+    (hmap x).comp (K := (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))) (P := D.Space)
+      (hq (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap x.1, x.2))
+
+private theorem SpecialPeriods.CuspGlobalOverlap.familyMapInto_isLocalDiffeomorph
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (hperiod :
+      ∀ s : SpecialPeriods.CuspFamily.LogBase C.radius,
+        D.periods.point (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap s) =
+          C.periods.point s) :
+    letI := C.chartedSpace
+    letI := D.chartedSpace (familyCovering D)
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (familyMapInto C D hrcap) := by
+  let := C.chartedSpace
+  let := D.chartedSpace (familyCovering D)
+  exact
+    isLocalDiffeomorph_codRestrictOpens (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (familyMap_isLocalDiffeomorph C D hrcap hperiod) (familyPatch C D hrcap)
+      (familyMap_mem_patch C D hrcap)
+
+private def SpecialPeriods.CuspGlobalOverlap.familyBiholomorph (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (hperiod :
+      ∀ s : SpecialPeriods.CuspFamily.LogBase C.radius,
+        D.periods.point (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap s) =
+          C.periods.point s) :
+    letI := C.chartedSpace
+    letI := D.chartedSpace (familyCovering D)
+    Diffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) C.Space (familyPatch C D hrcap) ω := by
+  letI := C.chartedSpace
+  letI := D.chartedSpace (familyCovering D)
+  exact
+    (familyMapInto_isLocalDiffeomorph C D hrcap hperiod).diffeomorphOfBijective
+      (familyMapInto_bijective C D hrcap)
+
+private def SpecialPeriods.CuspGlobalOverlap.compactProjection
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint) :
+    D.Space → SpecialPeriods.TriangleCompactifiedOrbitSpace :=
+  compactBase ∘ D.projection
+
+private def
+    SpecialPeriods.CuspGlobalOverlap.puncturedBiholomorph (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (hperiod :
+      ∀ s : SpecialPeriods.CuspFamily.LogBase C.radius,
+        D.periods.point (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap s) =
+          C.periods.point s) :
+    letI :=
+      CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+        C.smallDrift
+    letI := D.chartedSpace (familyCovering D)
+    Diffeomorph (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (CuspUniformization.PuncturedQuotient C.correction C.radius) (familyPatch C D hrcap) ω := by
+  letI := C.chartedSpace
+  letI :=
+    CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+      C.smallDrift
+  letI := D.chartedSpace (familyCovering D)
+  exact C.puncturedFamilyBiholomorph.symm.trans (familyBiholomorph C D hrcap hperiod)
+
+private theorem SpecialPeriods.CuspGlobalOverlap.puncturedBiholomorph_cover
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (hperiod :
+      ∀ s : SpecialPeriods.CuspFamily.LogBase C.radius,
+        D.periods.point (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap s) =
+          C.periods.point s)
+    (x : CuspUniformization.LogCover C.radius) :
+    letI :=
+      CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+        C.smallDrift
+    letI := D.chartedSpace (familyCovering D)
+    (puncturedBiholomorph C D hrcap hperiod
+          (CuspUniformization.puncturedCuspCover C.correction C.radius x) :
+        D.Space) =
+      familyMap C D hrcap (C.iteratedCover x) := by
+  let := C.chartedSpace
+  let :=
+    CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+      C.smallDrift
+  let := D.chartedSpace (familyCovering D)
+  change
+    familyMap C D hrcap
+        (C.puncturedFamilyBiholomorph.symm
+          (CuspUniformization.puncturedCuspCover C.correction C.radius x)) =
+      _
+  rw [← C.puncturedFamilyBiholomorph_iteratedCover, Diffeomorph.symm_apply_apply]
+
+private theorem SpecialPeriods.CuspGlobalOverlap.familyMap_compactProjection_mem_chart
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (x : C.Space) :
+    compactProjection D (familyMap C D hrcap x) ∈
+      (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).source := by
+  obtain ⟨a, rfl⟩ := C.quotient_surjective x
+  exact compactBase_baseCover_mem_chart C.radius hrcap a.1
+
+private theorem SpecialPeriods.CuspGlobalOverlap.familyMap_compactProjection_coordinate
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (x : C.Space) :
+    SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl
+        (compactProjection D (familyMap C D hrcap x)) =
+      (C.projection x : ℂ) := by
+  obtain ⟨a, rfl⟩ := C.quotient_surjective x
+  exact cuspFullChart_compactBase_baseCover C.radius hrcap a.1
+
+private theorem SpecialPeriods.CuspGlobalOverlap.puncturedBiholomorph_coordinate
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (hperiod :
+      ∀ s : SpecialPeriods.CuspFamily.LogBase C.radius,
+        D.periods.point (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap s) =
+          C.periods.point s)
+    (x : CuspUniformization.PuncturedQuotient C.correction C.radius) :
+    letI :=
+      CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+        C.smallDrift
+    letI := D.chartedSpace (familyCovering D)
+    SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl
+        (compactProjection D (puncturedBiholomorph C D hrcap hperiod x)) =
+      CuspQuotient.projection C.correction C.radius x := by
+  let := C.chartedSpace
+  let :=
+    CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+      C.smallDrift
+  let := D.chartedSpace (familyCovering D)
+  obtain ⟨y, rfl⟩ := C.puncturedFamilyBiholomorph.surjective x
+  change
+    SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl
+        (compactProjection D
+          (familyMap C D hrcap
+            (C.puncturedFamilyBiholomorph.symm (C.puncturedFamilyBiholomorph y)))) =
+      _
+  rw [Diffeomorph.symm_apply_apply, familyMap_compactProjection_coordinate]
+  exact (C.puncturedFamilyBiholomorph_preserves_base y).symm
+
+private theorem SpecialPeriods.CuspGlobalOverlap.puncturedBiholomorph_base_mem_chart
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (hperiod :
+      ∀ s : SpecialPeriods.CuspFamily.LogBase C.radius,
+        D.periods.point (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap s) =
+          C.periods.point s)
+    (x : CuspUniformization.PuncturedQuotient C.correction C.radius) :
+    letI :=
+      CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+        C.smallDrift
+    letI := D.chartedSpace (familyCovering D)
+    compactProjection D (puncturedBiholomorph C D hrcap hperiod x) ∈
+      (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).source := by
+  let := C.chartedSpace
+  let :=
+    CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+      C.smallDrift
+  let := D.chartedSpace (familyCovering D)
+  exact familyMap_compactProjection_mem_chart C D hrcap (C.puncturedFamilyBiholomorph.symm x)
+
+private theorem SpecialPeriods.CuspGlobalOverlap.puncturedBiholomorph_preserves_base
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (hperiod :
+      ∀ s : SpecialPeriods.CuspFamily.LogBase C.radius,
+        D.periods.point (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap s) =
+          C.periods.point s)
+    (x : CuspUniformization.PuncturedQuotient C.correction C.radius) :
+    letI :=
+      CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+        C.smallDrift
+    letI := D.chartedSpace (familyCovering D)
+    compactProjection D (puncturedBiholomorph C D hrcap hperiod x) =
+      (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).symm
+        (CuspQuotient.projection C.correction C.radius x) := by
+  let :=
+    CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+      C.smallDrift
+  let := D.chartedSpace (familyCovering D)
+  rw [← puncturedBiholomorph_coordinate C D hrcap hperiod x]
+  exact
+    ((SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).left_inv
+        (puncturedBiholomorph_base_mem_chart C D hrcap hperiod x)).symm
+
+private theorem SpecialPeriods.CuspGlobalOverlap.logBase_nonempty (r : ℝ) (hr : 0 < r) :
+    Nonempty (SpecialPeriods.CuspFamily.LogBase r) := by
+  have hhalf : 0 < r / 2 := half_pos hr
+  have hnorm : ‖((r / 2 : ℝ) : ℂ)‖ < r := by
+    rw [Complex.norm_real, Real.norm_eq_abs, abs_of_pos hhalf]
+    linarith
+  let t : SpecialPeriods.CuspFamily.puncturedDisc r :=
+    ⟨((r / 2 : ℝ) : ℂ),
+      (SpecialPeriods.CuspFamily.mem_puncturedDisc r _).mpr
+        ⟨hnorm, Complex.ofReal_ne_zero.mpr hhalf.ne'⟩⟩
+  obtain ⟨s, _⟩ := SpecialPeriods.CuspFamily.baseExponential_surjective r t
+  exact ⟨s⟩
+
+private theorem SpecialPeriods.CuspGlobalOverlap.cyclicSpace_nonempty
+    (C : SpecialPeriods.CuspFamily.Data) : Nonempty C.Space := by
+  obtain ⟨s⟩ := logBase_nonempty C.radius C.radius_pos
+  exact ⟨C.quotient (s, 0)⟩
+
+private theorem SpecialPeriods.CuspGlobalOverlap.puncturedSpace_nonempty
+    (C : SpecialPeriods.CuspFamily.Data) :
+    Nonempty (CuspUniformization.PuncturedQuotient C.correction C.radius) := by
+  obtain ⟨s⟩ := logBase_nonempty C.radius C.radius_pos
+  exact ⟨CuspUniformization.puncturedCuspCover C.correction C.radius ⟨((s : ℂ), 0), s.property⟩⟩
+
+private theorem
+    SpecialPeriods.CuspGlobalOverlap.familyPatch_nonempty (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) :
+    Nonempty (familyPatch C D hrcap) :=
+  (cyclicSpace_nonempty C).map (familyMapInto C D hrcap)
+
+private def
+    SpecialPeriods.CuspGlobalOverlap.cuspToRegularPartial (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (hperiod :
+      ∀ s : SpecialPeriods.CuspFamily.LogBase C.radius,
+        D.periods.point (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap s) =
+          C.periods.point s) :
+    letI :=
+      CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+        C.smallDrift
+    letI := D.chartedSpace (familyCovering D)
+    PartialDiffeomorph (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (CuspQuotient.QuotientSpace C.correction C.radius) D.Space ω := by
+  letI :=
+    CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+      C.smallDrift
+  letI := D.chartedSpace (familyCovering D)
+  exact
+    (opensInclusionPartialDiffeomorph (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+          (CuspUniformization.puncturedQuotientOpen C.correction C.radius)
+          (puncturedSpace_nonempty C)).symm.trans
+      ((puncturedBiholomorph C D hrcap hperiod).toPartialDiffeomorph.trans
+        (opensInclusionPartialDiffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+          (familyPatch C D hrcap) (familyPatch_nonempty C D hrcap)))
+
+@[simp]
+private theorem SpecialPeriods.CuspGlobalOverlap.cuspToRegularPartial_source
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (hperiod :
+      ∀ s : SpecialPeriods.CuspFamily.LogBase C.radius,
+        D.periods.point (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap s) =
+          C.periods.point s) :
+    letI :=
+      CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+        C.smallDrift
+    letI := D.chartedSpace (familyCovering D)
+    (cuspToRegularPartial C D hrcap hperiod).source =
+      (CuspUniformization.puncturedQuotientOpen C.correction C.radius : Set _) := by
+  let :=
+    CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+      C.smallDrift
+  let := D.chartedSpace (familyCovering D)
+  simp [cuspToRegularPartial, PartialDiffeomorph.trans, PartialDiffeomorph.symm,
+    Diffeomorph.toPartialDiffeomorph, opensInclusionPartialDiffeomorph]
+
+@[simp]
+private theorem SpecialPeriods.CuspGlobalOverlap.cuspToRegularPartial_target
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (hperiod :
+      ∀ s : SpecialPeriods.CuspFamily.LogBase C.radius,
+        D.periods.point (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap s) =
+          C.periods.point s) :
+    letI :=
+      CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+        C.smallDrift
+    letI := D.chartedSpace (familyCovering D)
+    (cuspToRegularPartial C D hrcap hperiod).target = (familyPatch C D hrcap : Set D.Space) := by
+  let :=
+    CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+      C.smallDrift
+  let := D.chartedSpace (familyCovering D)
+  simp [cuspToRegularPartial, PartialDiffeomorph.trans, PartialDiffeomorph.symm,
+    Diffeomorph.toPartialDiffeomorph, opensInclusionPartialDiffeomorph]
+
+private theorem SpecialPeriods.CuspGlobalOverlap.cuspToRegularPartial_source_iff
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (hperiod :
+      ∀ s : SpecialPeriods.CuspFamily.LogBase C.radius,
+        D.periods.point (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap s) =
+          C.periods.point s)
+    (x : CuspQuotient.QuotientSpace C.correction C.radius) :
+    letI :=
+      CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+        C.smallDrift
+    letI := D.chartedSpace (familyCovering D)
+    x ∈ (cuspToRegularPartial C D hrcap hperiod).source ↔
+      CuspQuotient.projection C.correction C.radius x ≠ 0 := by
+  let :=
+    CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+      C.smallDrift
+  let := D.chartedSpace (familyCovering D)
+  rw [cuspToRegularPartial_source]
+  rfl
+
+private theorem SpecialPeriods.CuspGlobalOverlap.cuspToRegularPartial_target_iff
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (hperiod :
+      ∀ s : SpecialPeriods.CuspFamily.LogBase C.radius,
+        D.periods.point (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap s) =
+          C.periods.point s)
+    (y : D.Space) :
+    letI :=
+      CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+        C.smallDrift
+    letI := D.chartedSpace (familyCovering D)
+    y ∈ (cuspToRegularPartial C D hrcap hperiod).target ↔
+      compactProjection D y ∈
+          (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).source ∧
+        ‖SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl
+              (compactProjection D y)‖ <
+          C.radius := by
+  let :=
+    CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+      C.smallDrift
+  let := D.chartedSpace (familyCovering D)
+  rw [cuspToRegularPartial_target]
+  exact mem_basePatch_iff C.radius hrcap (D.projection y)
+
+private theorem SpecialPeriods.CuspGlobalOverlap.cuspToRegularPartial_apply
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (hperiod :
+      ∀ s : SpecialPeriods.CuspFamily.LogBase C.radius,
+        D.periods.point (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap s) =
+          C.periods.point s)
+    (x : CuspQuotient.QuotientSpace C.correction C.radius)
+    (hx : x ∈ CuspUniformization.puncturedQuotientOpen C.correction C.radius) :
+    letI :=
+      CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+        C.smallDrift
+    letI := D.chartedSpace (familyCovering D)
+    cuspToRegularPartial C D hrcap hperiod x =
+      (puncturedBiholomorph C D hrcap hperiod ⟨x, hx⟩ : D.Space) := by
+  let :=
+    CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+      C.smallDrift
+  let := D.chartedSpace (familyCovering D)
+  let e :=
+    (CuspUniformization.puncturedQuotientOpen C.correction
+          C.radius).openPartialHomeomorphSubtypeCoe
+      (puncturedSpace_nonempty C)
+  have he : e.symm x = ⟨x, hx⟩ :=
+    e.left_inv (Set.mem_univ (⟨x, hx⟩ : CuspUniformization.PuncturedQuotient _ _))
+  change (puncturedBiholomorph C D hrcap hperiod (e.symm x) : D.Space) = _
+  rw [he]
+
+private theorem SpecialPeriods.CuspGlobalOverlap.cuspToRegularPartial_preserves_base
+    (C : SpecialPeriods.CuspFamily.Data)
+    (D : PeriodFamily.Data ℂ SpecialPeriods.TriangleRegularPoint)
+    (hrcap : C.radius ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (hperiod :
+      ∀ s : SpecialPeriods.CuspFamily.LogBase C.radius,
+        D.periods.point (SpecialPeriods.CuspFamily.logBaseToRegular C.radius hrcap s) =
+          C.periods.point s)
+    (x : CuspQuotient.QuotientSpace C.correction C.radius)
+    (hx : x ∈ CuspUniformization.puncturedQuotientOpen C.correction C.radius) :
+    letI :=
+      CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+        C.smallDrift
+    letI := D.chartedSpace (familyCovering D)
+    compactProjection D (cuspToRegularPartial C D hrcap hperiod x) =
+      (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).symm
+        (CuspQuotient.projection C.correction C.radius x) := by
+  let :=
+    CuspQuotient.chartedSpace C.correction C.radius C.radius_pos C.radius_lt_one C.holomorphic
+      C.smallDrift
+  let := D.chartedSpace (familyCovering D)
+  rw [cuspToRegularPartial_apply C D hrcap hperiod x hx]
+  exact puncturedBiholomorph_preserves_base C D hrcap hperiod ⟨x, hx⟩
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.CuspGlobalOverlap.sphereCuspToRegularPartial
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere))
+    (r : ℝ) (hr : 0 < r)
+    (hrD : r ≤ (SpecialPeriods.Construction.cuspDataOfSphere π hπ h₀ h₁).radius)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width) :
+    letI :=
+      CuspQuotient.chartedSpace ((sphereCuspData π hπ h₀ h₁ r hr hrD)).correction
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).radius
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).radius_pos
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).radius_lt_one
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).holomorphic
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).smallDrift
+    letI :=
+      ((sphereRegularData π hπ h₀ h₁)).chartedSpace
+        (familyCovering (sphereRegularData π hπ h₀ h₁))
+    PartialDiffeomorph (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (CuspQuotient.QuotientSpace ((sphereCuspData π hπ h₀ h₁ r hr hrD)).correction
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).radius)
+      ((sphereRegularData π hπ h₀ h₁)).Space ω :=
+  cuspToRegularPartial (sphereCuspData π hπ h₀ h₁ r hr hrD) (sphereRegularData π hπ h₀ h₁) hrcap
+    (spherePeriod_agreement π hπ h₀ h₁ r hr hrD hrcap)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.CuspGlobalOverlap.sphereCuspToRegularPartial_source_iff
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere))
+    (r : ℝ) (hr : 0 < r)
+    (hrD : r ≤ (SpecialPeriods.Construction.cuspDataOfSphere π hπ h₀ h₁).radius)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (x :
+      CuspQuotient.QuotientSpace ((sphereCuspData π hπ h₀ h₁ r hr hrD)).correction
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).radius) :
+    letI :=
+      CuspQuotient.chartedSpace ((sphereCuspData π hπ h₀ h₁ r hr hrD)).correction
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).radius
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).radius_pos
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).radius_lt_one
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).holomorphic
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).smallDrift
+    letI :=
+      ((sphereRegularData π hπ h₀ h₁)).chartedSpace
+        (familyCovering (sphereRegularData π hπ h₀ h₁))
+    x ∈ (sphereCuspToRegularPartial π hπ h₀ h₁ r hr hrD hrcap).source ↔
+      CuspQuotient.projection ((sphereCuspData π hπ h₀ h₁ r hr hrD)).correction
+          ((sphereCuspData π hπ h₀ h₁ r hr hrD)).radius x ≠
+        0 :=
+  cuspToRegularPartial_source_iff (sphereCuspData π hπ h₀ h₁ r hr hrD)
+    (sphereRegularData π hπ h₀ h₁) hrcap (spherePeriod_agreement π hπ h₀ h₁ r hr hrD hrcap) x
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.CuspGlobalOverlap.sphereCuspToRegularPartial_target_iff
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere))
+    (r : ℝ) (hr : 0 < r)
+    (hrD : r ≤ (SpecialPeriods.Construction.cuspDataOfSphere π hπ h₀ h₁).radius)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (y : ((sphereRegularData π hπ h₀ h₁)).Space) :
+    letI :=
+      CuspQuotient.chartedSpace ((sphereCuspData π hπ h₀ h₁ r hr hrD)).correction
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).radius
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).radius_pos
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).radius_lt_one
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).holomorphic
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).smallDrift
+    letI :=
+      ((sphereRegularData π hπ h₀ h₁)).chartedSpace
+        (familyCovering (sphereRegularData π hπ h₀ h₁))
+    y ∈ (sphereCuspToRegularPartial π hπ h₀ h₁ r hr hrD hrcap).target ↔
+      compactProjection (sphereRegularData π hπ h₀ h₁) y ∈
+          (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).source ∧
+        ‖SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl
+              (compactProjection (sphereRegularData π hπ h₀ h₁) y)‖ <
+          r :=
+  cuspToRegularPartial_target_iff (sphereCuspData π hπ h₀ h₁ r hr hrD)
+    (sphereRegularData π hπ h₀ h₁) hrcap (spherePeriod_agreement π hπ h₀ h₁ r hr hrD hrcap) y
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.CuspGlobalOverlap.sphereCuspToRegularPartial_preserves_base
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere))
+    (r : ℝ) (hr : 0 < r)
+    (hrD : r ≤ (SpecialPeriods.Construction.cuspDataOfSphere π hπ h₀ h₁).radius)
+    (hrcap : r ≤ SpecialPeriods.Triangle.cuspRadius SpecialPeriods.Triangle.width)
+    (x :
+      CuspQuotient.QuotientSpace ((sphereCuspData π hπ h₀ h₁ r hr hrD)).correction
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).radius)
+    (hx :
+      x ∈
+        CuspUniformization.puncturedQuotientOpen ((sphereCuspData π hπ h₀ h₁ r hr hrD)).correction
+          ((sphereCuspData π hπ h₀ h₁ r hr hrD)).radius) :
+    letI :=
+      CuspQuotient.chartedSpace ((sphereCuspData π hπ h₀ h₁ r hr hrD)).correction
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).radius
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).radius_pos
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).radius_lt_one
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).holomorphic
+        ((sphereCuspData π hπ h₀ h₁ r hr hrD)).smallDrift
+    letI :=
+      ((sphereRegularData π hπ h₀ h₁)).chartedSpace
+        (familyCovering (sphereRegularData π hπ h₀ h₁))
+    compactProjection (sphereRegularData π hπ h₀ h₁)
+        (sphereCuspToRegularPartial π hπ h₀ h₁ r hr hrD hrcap x) =
+      (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).symm
+        (CuspQuotient.projection ((sphereCuspData π hπ h₀ h₁ r hr hrD)).correction
+          ((sphereCuspData π hπ h₀ h₁ r hr hrD)).radius x) :=
+  cuspToRegularPartial_preserves_base (sphereCuspData π hπ h₀ h₁ r hr hrD)
+    (sphereRegularData π hπ h₀ h₁) hrcap (spherePeriod_agreement π hπ h₀ h₁ r hr hrD hrcap) x hx
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace in
+@[instance_reducible]
+private def SpecialPeriods.Threefold.instChartedSpace1 :
+    ChartedSpace (ToricCharts.CoordinateSpace 3) SpecialCuspPiece :=
+  CuspPiece.nativeChartedSpace SpecialPeriods.specialCuspData specialBaseCover
+    specialCuspRadius_le
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.instChartedSpace1 in
+private def SpecialPeriods.Threefold.specialCuspNativeOverlap :
+    PartialDiffeomorph (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) SpecialCuspPiece SpecialRegularFamily ω :=
+  SpecialPeriods.CuspGlobalOverlap.sphereCuspToRegularPartial
+    SpecialPeriods.Triangle.triangleSphereUniformization
+    SpecialPeriods.Triangle.triangleSphereUniformization_cusp
+    SpecialPeriods.Triangle.triangleSphereUniformization_centerOne
+    SpecialPeriods.Triangle.triangleSphereUniformization_centerTwo
+    (specialBaseCover.radius Option.none) (specialBaseCover.radius_pos Option.none)
+    specialCuspRadius_le specialBaseCover_cusp_radius_bounds.2.2.le
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.instChartedSpace1 in
+private theorem
+    SpecialPeriods.Threefold.specialCuspNativeOverlap_source_iff (x : SpecialCuspPiece) :
+    x ∈ specialCuspNativeOverlap.source ↔
+      CuspQuotient.projection SpecialPeriods.specialCuspData.correction
+          (specialBaseCover.radius Option.none) x ≠
+        0 :=
+  SpecialPeriods.CuspGlobalOverlap.sphereCuspToRegularPartial_source_iff
+    SpecialPeriods.Triangle.triangleSphereUniformization
+    SpecialPeriods.Triangle.triangleSphereUniformization_cusp
+    SpecialPeriods.Triangle.triangleSphereUniformization_centerOne
+    SpecialPeriods.Triangle.triangleSphereUniformization_centerTwo
+    (specialBaseCover.radius Option.none) (specialBaseCover.radius_pos Option.none)
+    specialCuspRadius_le specialBaseCover_cusp_radius_bounds.2.2.le x
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.instChartedSpace1 in
+private theorem
+    SpecialPeriods.Threefold.specialCuspNativeOverlap_target_iff (y : SpecialRegularFamily) :
+    y ∈ specialCuspNativeOverlap.target ↔
+      specialRegularFamilyProjectionToBase y ∈ (punctureChart Option.none).source ∧
+        ‖punctureChart Option.none (specialRegularFamilyProjectionToBase y)‖ <
+          specialBaseCover.radius Option.none :=
+  SpecialPeriods.CuspGlobalOverlap.sphereCuspToRegularPartial_target_iff
+    SpecialPeriods.Triangle.triangleSphereUniformization
+    SpecialPeriods.Triangle.triangleSphereUniformization_cusp
+    SpecialPeriods.Triangle.triangleSphereUniformization_centerOne
+    SpecialPeriods.Triangle.triangleSphereUniformization_centerTwo
+    (specialBaseCover.radius Option.none) (specialBaseCover.radius_pos Option.none)
+    specialCuspRadius_le specialBaseCover_cusp_radius_bounds.2.2.le y
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.instChartedSpace1 in
+private theorem SpecialPeriods.Threefold.specialCuspNativeOverlap_base (x : SpecialCuspPiece)
+    (hx : x ∈ specialCuspNativeOverlap.source) :
+    specialRegularFamilyProjectionToBase (specialCuspNativeOverlap x) =
+      specialCuspPieceProjectionToBase x :=
+  SpecialPeriods.CuspGlobalOverlap.sphereCuspToRegularPartial_preserves_base
+    SpecialPeriods.Triangle.triangleSphereUniformization
+    SpecialPeriods.Triangle.triangleSphereUniformization_cusp
+    SpecialPeriods.Triangle.triangleSphereUniformization_centerOne
+    SpecialPeriods.Triangle.triangleSphereUniformization_centerTwo
+    (specialBaseCover.radius Option.none) (specialBaseCover.radius_pos Option.none)
+    specialCuspRadius_le specialBaseCover_cusp_radius_bounds.2.2.le x
+    ((specialCuspNativeOverlap_source_iff x).mp hx)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.instChartedSpace1 in
+private def SpecialPeriods.Threefold.specialCuspOverlap :
+    PartialDiffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) SpecialCuspPiece SpecialRegularFamily ω :=
+  (Diffeomorph.toPartialDiffeomorph
+        (CuspPiece.nativeToCommon SpecialPeriods.specialCuspData specialBaseCover
+            specialCuspRadius_le).symm).trans
+    specialCuspNativeOverlap
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.instChartedSpace1 in
+private theorem SpecialPeriods.Threefold.specialCuspOverlap_source :
+    specialCuspOverlap.source =
+      specialCuspPieceProjectionToBase ⁻¹'
+        (regularPatch : Set SpecialPeriods.TriangleCompactifiedOrbitSpace) := by
+  ext x
+  change (x ∈ (Set.univ : Set SpecialCuspPiece) ∧ x ∈ specialCuspNativeOverlap.source) ↔ _
+  simp only [Set.mem_univ, true_and]
+  exact
+    (specialCuspNativeOverlap_source_iff x).trans
+      (CuspPiece.projectionToBase_mem_regular_iff SpecialPeriods.specialCuspData specialBaseCover
+          x).symm
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.instChartedSpace1 in
+private theorem SpecialPeriods.Threefold.specialCuspOverlap_target :
+    specialCuspOverlap.target =
+      specialRegularFamilyProjectionToBase ⁻¹'
+        (specialBaseCover.fillingPatch Option.none :
+          Set SpecialPeriods.TriangleCompactifiedOrbitSpace) := by
+  ext y
+  change
+    (y ∈ specialCuspNativeOverlap.target ∧
+        specialCuspNativeOverlap.symm y ∈ (Set.univ : Set SpecialCuspPiece)) ↔
+      _
+  simp only [Set.mem_univ, and_true]
+  exact
+    (specialCuspNativeOverlap_target_iff y).trans
+      (specialBaseCover.mem_fillingPatch Option.none
+          (specialRegularFamilyProjectionToBase y)).symm
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.specialCuspPieceChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.instChartedSpace1 in
+private theorem SpecialPeriods.Threefold.specialCuspOverlap_base (x : SpecialCuspPiece)
+    (hx : x ∈ specialCuspOverlap.source) :
+    specialRegularFamilyProjectionToBase (specialCuspOverlap x) =
+      specialCuspPieceProjectionToBase x :=
+  specialCuspNativeOverlap_base x hx.2
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private def SpecialPeriods.EllipticFilling.neighborhoodPoint (j : Elliptic.Kind)
+    (z : Elliptic.LogGauge.BaseStar) : SpecialPeriods.Triangle.ellipticNeighborhood j :=
+  (SpecialPeriods.Triangle.ellipticNeighborhoodChart j).symm z.val
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.EllipticFilling.neighborhoodPoint_ne_center (j : Elliptic.Kind)
+    (z : Elliptic.LogGauge.BaseStar) :
+    neighborhoodPoint j z ≠ SpecialPeriods.Triangle.ellipticNeighborhoodCenter j := by
+  intro he
+  have hc := congrArg (SpecialPeriods.Triangle.ellipticNeighborhoodChart j) he
+  have hz : z.val = SpecialPeriods.discZero := by
+    simpa only [neighborhoodPoint, Diffeomorph.apply_symm_apply,
+      SpecialPeriods.Triangle.ellipticNeighborhoodChart_center] using hc
+  exact z.property (congrArg (fun u : SpecialPeriods.Disc => (u : ℂ)) hz)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.EllipticFilling.localBase_regular (j : Elliptic.Kind)
+    (z : Elliptic.LogGauge.BaseStar) :
+    (neighborhoodPoint j z : ℍ) ∈ SpecialPeriods.triangleRegularLocus := by
+  have hself :
+    SpecialPeriods.triangleOrbitProjection (neighborhoodPoint j z) ≠
+      SpecialPeriods.Triangle.ellipticOrbitCenter j :=
+    fun he =>
+    neighborhoodPoint_ne_center j z
+      ((SpecialPeriods.Triangle.ellipticNeighborhood_projection_eq_center_iff j
+            (neighborhoodPoint j z)).mp
+        he)
+  have hother :=
+    SpecialPeriods.Triangle.ellipticNeighborhood_avoids_other j (neighborhoodPoint j z)
+      (neighborhoodPoint j z).property
+  apply (SpecialPeriods.triangleOrbitProjection_mem_regularDomain_iff _).mp
+  apply (SpecialPeriods.triangleOrbitRegularDomain_mem_iff _).mpr
+  cases j
+  · exact ⟨hself, hother⟩
+  · exact ⟨hother, hself⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private def SpecialPeriods.EllipticFilling.localBase (j : Elliptic.Kind)
+    (z : Elliptic.LogGauge.BaseStar) : SpecialPeriods.TriangleRegularPoint :=
+  ⟨neighborhoodPoint j z, localBase_regular j z⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+@[simp]
+private theorem SpecialPeriods.EllipticFilling.localBase_val (j : Elliptic.Kind)
+    (z : Elliptic.LogGauge.BaseStar) :
+    (localBase j z : ℍ) =
+      ((SpecialPeriods.Triangle.ellipticNeighborhoodChart j).symm z.val : ℍ) :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.EllipticFilling.localBase_mem_neighborhood (j : Elliptic.Kind)
+    (z : Elliptic.LogGauge.BaseStar) :
+    (localBase j z : ℍ) ∈ SpecialPeriods.Triangle.ellipticNeighborhood j :=
+  (neighborhoodPoint j z).property
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.EllipticFilling.localBase_injective (j : Elliptic.Kind) :
+    Function.Injective (localBase j) := by
+  intro z w he
+  have hv : (localBase j z : ℍ) = (localBase j w : ℍ) :=
+    congrArg (fun u : SpecialPeriods.TriangleRegularPoint => (u : ℍ)) he
+  have hn :
+    (SpecialPeriods.Triangle.ellipticNeighborhoodChart j).symm z.val =
+      (SpecialPeriods.Triangle.ellipticNeighborhoodChart j).symm w.val :=
+    Subtype.ext hv
+  exact Subtype.ext ((SpecialPeriods.Triangle.ellipticNeighborhoodChart j).symm.injective hn)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.EllipticFilling.localBase_isLocalDiffeomorph (j : Elliptic.Kind) :
+    IsLocalDiffeomorph 𝓘(ℂ) 𝓘(ℂ) ω (localBase j) := by
+  have hn : IsLocalDiffeomorph 𝓘(ℂ) 𝓘(ℂ) ω (neighborhoodPoint j) := by
+    intro z
+    exact
+      (isLocalDiffeomorph_subtypeVal 𝓘(ℂ) Elliptic.LogGauge.baseOpen z).comp (K := 𝓘(ℂ)) (P :=
+        SpecialPeriods.Triangle.ellipticNeighborhood j)
+        ((SpecialPeriods.Triangle.ellipticNeighborhoodChart j).symm.isLocalDiffeomorph z.val)
+  have hv :
+    IsLocalDiffeomorph 𝓘(ℂ) 𝓘(ℂ) ω
+      (fun z : Elliptic.LogGauge.BaseStar => (neighborhoodPoint j z : ℍ)) := by
+    intro z
+    exact
+      (hn z).comp (K := 𝓘(ℂ)) (P := ℍ)
+        (isLocalDiffeomorph_subtypeVal 𝓘(ℂ) (SpecialPeriods.Triangle.ellipticNeighborhood j)
+          (neighborhoodPoint j z))
+  exact
+    isLocalDiffeomorph_codRestrictOpens 𝓘(ℂ) 𝓘(ℂ) hv SpecialPeriods.triangleRegularDomain
+      (localBase_regular j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.EllipticFilling.localBase_holomorphic (j : Elliptic.Kind) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (localBase j) :=
+  (localBase_isLocalDiffeomorph j).contMDiff
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.EllipticFilling.localBase_continuous (j : Elliptic.Kind) :
+    Continuous (localBase j) :=
+  (localBase_holomorphic j).continuous
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.EllipticFilling.ellipticCenter_not_regular (j : Elliptic.Kind) :
+    SpecialPeriods.Triangle.ellipticCenter j ∉ SpecialPeriods.triangleRegularLocus := by
+  cases j
+  · exact SpecialPeriods.triangle_centerOne_not_regular
+  · exact SpecialPeriods.triangle_centerTwo_not_regular
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem
+    SpecialPeriods.EllipticFilling.neighborhoodChart_ne_zero_of_regular (j : Elliptic.Kind)
+    (u : SpecialPeriods.Triangle.ellipticNeighborhood j)
+    (hu : (u : ℍ) ∈ SpecialPeriods.triangleRegularLocus) :
+    (SpecialPeriods.Triangle.ellipticNeighborhoodChart j u : ℂ) ≠ 0 := by
+  intro he
+  have hchart : SpecialPeriods.Triangle.ellipticNeighborhoodChart j u = SpecialPeriods.discZero :=
+    Subtype.ext he
+  have huc : u = SpecialPeriods.Triangle.ellipticNeighborhoodCenter j :=
+    (SpecialPeriods.Triangle.ellipticNeighborhoodChart j).injective
+      (hchart.trans (SpecialPeriods.Triangle.ellipticNeighborhoodChart_center j).symm)
+  have hc : (u : ℍ) = SpecialPeriods.Triangle.ellipticCenter j := congrArg Subtype.val huc
+  exact ellipticCenter_not_regular j (hc ▸ hu)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.EllipticFilling.localBase_range (j : Elliptic.Kind) :
+    Set.range (localBase j) =
+      {u : SpecialPeriods.TriangleRegularPoint |
+        (u : ℍ) ∈ SpecialPeriods.Triangle.ellipticNeighborhood j} := by
+  ext u
+  constructor
+  · rintro ⟨z, rfl⟩
+    exact localBase_mem_neighborhood j z
+  · intro hu
+    let v : SpecialPeriods.Triangle.ellipticNeighborhood j := ⟨u.val, hu⟩
+    let z : Elliptic.LogGauge.BaseStar :=
+      ⟨SpecialPeriods.Triangle.ellipticNeighborhoodChart j v,
+        neighborhoodChart_ne_zero_of_regular j v u.property⟩
+    refine ⟨z, ?_⟩
+    apply Subtype.ext
+    change
+      ((SpecialPeriods.Triangle.ellipticNeighborhoodChart j).symm
+            (SpecialPeriods.Triangle.ellipticNeighborhoodChart j v) :
+          ℍ) =
+        (u : ℍ)
+    exact
+      congrArg (fun q : SpecialPeriods.Triangle.ellipticNeighborhood j => (q : ℍ))
+        ((SpecialPeriods.Triangle.ellipticNeighborhoodChart j).symm_apply_apply v)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private def SpecialPeriods.EllipticFilling.puncturedRotation (j : Elliptic.Kind)
+    (z : Elliptic.LogGauge.BaseStar) : Elliptic.LogGauge.BaseStar :=
+  ⟨Elliptic.familyRotation j z.val, Elliptic.LogGauge.familyRotation_ne_zero j z.val z.property⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+@[simp]
+private theorem SpecialPeriods.EllipticFilling.puncturedRotation_val (j : Elliptic.Kind)
+    (z : Elliptic.LogGauge.BaseStar) :
+    (puncturedRotation j z).val = Elliptic.familyRotation j z.val :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.EllipticFilling.localBase_rotation (j : Elliptic.Kind)
+    (z : Elliptic.LogGauge.BaseStar) :
+    localBase j (puncturedRotation j z) =
+      SpecialPeriods.Triangle.ellipticGenerator j • localBase j z := by
+  let := SpecialPeriods.Triangle.ellipticNeighborhoodAction j
+  have he :
+    (SpecialPeriods.Triangle.ellipticNeighborhoodChart j).symm (Elliptic.familyRotation j z.val) =
+      SpecialPeriods.Triangle.ellipticStabilizerGenerator j •
+        (SpecialPeriods.Triangle.ellipticNeighborhoodChart j).symm z.val := by
+    apply (SpecialPeriods.Triangle.ellipticNeighborhoodChart j).injective
+    change
+      SpecialPeriods.Triangle.ellipticNeighborhoodChart j
+          ((SpecialPeriods.Triangle.ellipticNeighborhoodChart j).symm
+            (Elliptic.familyRotation j z.val)) =
+        SpecialPeriods.Triangle.ellipticNeighborhoodChart j
+          (SpecialPeriods.Triangle.ellipticStabilizerGenerator j •
+            (SpecialPeriods.Triangle.ellipticNeighborhoodChart j).symm z.val)
+    rw [Diffeomorph.apply_symm_apply, SpecialPeriods.Triangle.ellipticNeighborhoodChart_generator,
+      Diffeomorph.apply_symm_apply]
+  apply Subtype.ext
+  exact congrArg (fun u : SpecialPeriods.Triangle.ellipticNeighborhood j => (u : ℍ)) he
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem
+    SpecialPeriods.EllipticFilling.localBase_rotation_iterate (j : Elliptic.Kind) (n : ℕ)
+    (z : Elliptic.LogGauge.BaseStar) :
+    localBase j ((puncturedRotation j)^[n] z) =
+      SpecialPeriods.Triangle.ellipticGenerator j ^ n • localBase j z := by
+  induction n with
+  | zero => simp
+  | succ n ih =>
+    rw [Function.iterate_succ_apply', localBase_rotation, ih, pow_succ', SemigroupAction.mul_smul]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private def SpecialPeriods.EllipticFilling.baseQuotient (j : Elliptic.Kind) :
+    Elliptic.LogGauge.BaseStar → SpecialPeriods.TriangleRegularQuotient :=
+  SpecialPeriods.triangleRegularProject ∘ localBase j
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+@[simp]
+private theorem SpecialPeriods.EllipticFilling.baseQuotient_toOrbit (j : Elliptic.Kind)
+    (z : Elliptic.LogGauge.BaseStar) :
+    SpecialPeriods.triangleRegularToOrbit (baseQuotient j z) =
+      SpecialPeriods.triangleOrbitProjection (localBase j z : ℍ) :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.EllipticFilling.localBase_orbit_classification (j : Elliptic.Kind)
+    (g : SpecialPeriods.TriangleGroup) (z w : Elliptic.LogGauge.BaseStar)
+    (h : g • localBase j z = localBase j w) :
+    ∃ n : ℕ,
+      n < j.order ∧
+        g = SpecialPeriods.Triangle.ellipticGenerator j ^ n ∧ w = (puncturedRotation j)^[n] z := by
+  have hambient : g • (localBase j z : ℍ) = (localBase j w : ℍ) := congrArg Subtype.val h
+  have hg : g ∈ SpecialPeriods.Triangle.ellipticStabilizer j :=
+    SpecialPeriods.Triangle.ellipticNeighborhood_return j g
+      ⟨(localBase j w : ℍ), ⟨(localBase j z : ℍ), localBase_mem_neighborhood j z, hambient⟩,
+        localBase_mem_neighborhood j w⟩
+  obtain ⟨n, hn, rfl⟩ := (SpecialPeriods.Triangle.mem_ellipticStabilizer_iff j g).mp hg
+  refine ⟨n, hn, rfl, ?_⟩
+  apply localBase_injective j
+  exact ((localBase_rotation_iterate j n z).trans h).symm
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.EllipticFilling.ellipticFullChart_localBase (j : Elliptic.Kind)
+    (z : Elliptic.LogGauge.BaseStar) :
+    SpecialPeriods.Triangle.ellipticFullChart j
+        (SpecialPeriods.triangleOrbitProjection (localBase j z : ℍ)) =
+      (z.val : ℂ) ^ j.order := by
+  rw [localBase_val, SpecialPeriods.Triangle.ellipticFullChart_projection]
+  change
+    ((SpecialPeriods.Triangle.ellipticNeighborhoodChart j
+              ((SpecialPeriods.Triangle.ellipticNeighborhoodChart j).symm z.val) :
+            SpecialPeriods.Disc) :
+          ℂ) ^
+        j.order =
+      _
+  rw [Diffeomorph.apply_symm_apply]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.EllipticFilling.ellipticFullChart_baseQuotient (j : Elliptic.Kind)
+    (z : Elliptic.LogGauge.BaseStar) :
+    SpecialPeriods.Triangle.ellipticFullChart j
+        (SpecialPeriods.triangleRegularToOrbit (baseQuotient j z)) =
+      (z.val : ℂ) ^ j.order :=
+  ellipticFullChart_localBase j z
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private def SpecialPeriods.EllipticFilling.regularBasePatch (j : Elliptic.Kind) :
+    TopologicalSpace.Opens SpecialPeriods.TriangleRegularQuotient :=
+  ⟨SpecialPeriods.triangleRegularToOrbit ⁻¹'
+      (SpecialPeriods.Triangle.ellipticNeighborhoodImage j :
+        Set SpecialPeriods.TriangleOrbitSpace),
+    (SpecialPeriods.Triangle.ellipticNeighborhoodImage j).isOpen.preimage
+      SpecialPeriods.triangleRegularToOrbit_continuous⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.EllipticFilling.baseQuotient_mem_regularBasePatch (j : Elliptic.Kind)
+    (z : Elliptic.LogGauge.BaseStar) : baseQuotient j z ∈ regularBasePatch j :=
+  ⟨(localBase j z : ℍ), localBase_mem_neighborhood j z, rfl⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.EllipticFilling.baseQuotient_range (j : Elliptic.Kind) :
+    Set.range (baseQuotient j) =
+      (regularBasePatch j : Set SpecialPeriods.TriangleRegularQuotient) := by
+  ext q
+  constructor
+  · rintro ⟨z, rfl⟩
+    exact baseQuotient_mem_regularBasePatch j z
+  · rintro ⟨u, hu, he⟩
+    change
+      SpecialPeriods.triangleOrbitProjection u = SpecialPeriods.triangleRegularToOrbit q at he
+    have hreg : u ∈ SpecialPeriods.triangleRegularLocus := by
+      apply (SpecialPeriods.triangleOrbitProjection_mem_regularDomain_iff u).mp
+      rw [he]
+      exact ⟨q, rfl⟩
+    have hin : (⟨u, hreg⟩ : SpecialPeriods.TriangleRegularPoint) ∈ Set.range (localBase j) := by
+      rw [localBase_range]
+      exact hu
+    obtain ⟨z, hz⟩ := hin
+    refine ⟨z, SpecialPeriods.triangleRegularToOrbit_injective ?_⟩
+    rw [baseQuotient_toOrbit, hz]
+    exact he
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.EllipticFilling.regularBasePatch_mem_iff_compactifiedChart
+    (j : Elliptic.Kind) (q : SpecialPeriods.TriangleRegularQuotient) :
+    q ∈ regularBasePatch j ↔
+      SpecialPeriods.triangleOpenInclusion (SpecialPeriods.triangleRegularToOrbit q) ∈
+        (SpecialPeriods.Triangle.ellipticCompactifiedChart j).source := by
+  rw [SpecialPeriods.Triangle.openInclusion_mem_ellipticCompactifiedChart_source,
+    SpecialPeriods.Triangle.ellipticFullChart_source]
+  rfl
+
+private theorem SpecialPeriods.EllipticFilling.ellipticGenerator_dual_matrix (j : Elliptic.Kind) :
+    (SpecialPeriods.triangleDualRepresentation (SpecialPeriods.Triangle.ellipticGenerator j) :
+        LatticeMatrix) =
+      j.matrix := by
+  cases j
+  · exact SpecialPeriods.triangleDualRepresentation_generator₁_matrix
+  · exact SpecialPeriods.triangleDualRepresentation_generator₂_matrix
+
+private theorem SpecialPeriods.EllipticFilling.ellipticGenerator_torus_mkQ (j : Elliptic.Kind)
+    (x : RealPlane₄) :
+    SpecialPeriods.triangleTorusHomeomorph (SpecialPeriods.Triangle.ellipticGenerator j)
+        (standardLattice.mkQ x) =
+      standardLattice.mkQ (Elliptic.flatLinear j x) := by
+  rw [SpecialPeriods.triangleTorusHomeomorph_mkQ, SpecialPeriods.triangleRealEquiv_apply,
+    ellipticGenerator_dual_matrix]
+  rfl
+
+private theorem SpecialPeriods.EllipticFilling.ellipticGenerator_torus_eq (j : Elliptic.Kind) :
+    SpecialPeriods.triangleTorusHomeomorph (SpecialPeriods.Triangle.ellipticGenerator j) =
+      Elliptic.flatTorusAffine j 0 := by
+  apply Homeomorph.ext
+  intro x
+  obtain ⟨u, rfl⟩ := standardLattice.mkQ_surjective x
+  rw [ellipticGenerator_torus_mkQ, Elliptic.flatTorusAffine_mkQ]
+  have hz : Elliptic.realCast (0 : Lattice) = 0 := by
+    ext i
+    simp [Elliptic.realCast]
+  rw [Elliptic.flatAffine, hz, smul_zero, add_zero]
+
+private theorem
+    SpecialPeriods.EllipticFilling.flatTorusAffine_zero_iterate (j : Elliptic.Kind) (n : ℕ)
+    (x : RealTorus₄) :
+    (Elliptic.flatTorusAffine j 0)^[n] x =
+      SpecialPeriods.triangleTorusHomeomorph (SpecialPeriods.Triangle.ellipticGenerator j ^ n)
+        x := by
+  induction n with
+  | zero => simp
+  | succ n ih =>
+    rw [Function.iterate_succ_apply', ih, pow_succ',
+      SpecialPeriods.triangleTorusHomeomorph_mul_apply, ellipticGenerator_torus_eq]
+
+private theorem SpecialPeriods.EllipticFilling.zeroAction_apply {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (g : Elliptic.CyclicGroup j) (x : D.TotalSpace) :
+    letI := D.action 0 (Matrix.mulVec_zero j.matrix)
+    g • x =
+      ((Elliptic.familyRotation j)^[g.toAdd.val] x.1,
+        SpecialPeriods.triangleTorusHomeomorph
+          (SpecialPeriods.Triangle.ellipticGenerator j ^ g.toAdd.val) x.2) := by
+  let := D.action 0 (Matrix.mulVec_zero j.matrix)
+  rw [D.action_apply, flatTorusAffine_zero_iterate]
+
+private theorem SpecialPeriods.EllipticFilling.zeroStarAction_coe {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (g : Elliptic.CyclicGroup j)
+    (x : Elliptic.LogGauge.FamilyStar D.periods) :
+    letI := Elliptic.LogGauge.starAction D 0 (Matrix.mulVec_zero j.matrix)
+    ((g • x : Elliptic.LogGauge.FamilyStar D.periods) : D.TotalSpace) =
+      ((Elliptic.familyRotation j)^[g.toAdd.val] x.1.1,
+        SpecialPeriods.triangleTorusHomeomorph
+          (SpecialPeriods.Triangle.ellipticGenerator j ^ g.toAdd.val) x.1.2) := by
+  let := D.action 0 (Matrix.mulVec_zero j.matrix)
+  let := Elliptic.LogGauge.starAction D 0 (Matrix.mulVec_zero j.matrix)
+  rw [Elliptic.LogGauge.starAction_coe, zeroAction_apply]
+
+private theorem SpecialPeriods.EllipticFilling.zeroStarAction_fst {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (g : Elliptic.CyclicGroup j)
+    (x : Elliptic.LogGauge.FamilyStar D.periods) :
+    letI := Elliptic.LogGauge.starAction D 0 (Matrix.mulVec_zero j.matrix)
+    (g • x : Elliptic.LogGauge.FamilyStar D.periods).1.1 =
+      (Elliptic.familyRotation j)^[g.toAdd.val] x.1.1 := by
+  let := Elliptic.LogGauge.starAction D 0 (Matrix.mulVec_zero j.matrix)
+  exact congrArg Prod.fst (zeroStarAction_coe D g x)
+
+private theorem SpecialPeriods.EllipticFilling.zeroStarAction_snd {j : Elliptic.Kind}
+    (D : Elliptic.Equivariant.Data j) (g : Elliptic.CyclicGroup j)
+    (x : Elliptic.LogGauge.FamilyStar D.periods) :
+    letI := Elliptic.LogGauge.starAction D 0 (Matrix.mulVec_zero j.matrix)
+    (g • x : Elliptic.LogGauge.FamilyStar D.periods).1.2 =
+      SpecialPeriods.triangleTorusHomeomorph
+        (SpecialPeriods.Triangle.ellipticGenerator j ^ g.toAdd.val) x.1.2 := by
+  let := Elliptic.LogGauge.starAction D 0 (Matrix.mulVec_zero j.matrix)
+  exact congrArg Prod.snd (zeroStarAction_coe D g x)
+
+private def SpecialPeriods.EllipticFilling.localTotalMap (P : HolomorphicPeriodMap ℂ ℍ)
+    (j : Elliptic.Kind) :
+    Elliptic.LogGauge.FamilyStar (localPeriods P j) →
+      (PeriodFamily.regularPeriods P).TotalSpace :=
+  fun x => (localBase j ⟨x.1.1, x.2⟩, x.1.2)
+
+private theorem
+    SpecialPeriods.EllipticFilling.localTotalMap_injective (P : HolomorphicPeriodMap ℂ ℍ)
+    (j : Elliptic.Kind) : Function.Injective (localTotalMap P j) := by
+  intro x y h
+  have hb := localBase_injective j (congrArg Prod.fst h)
+  apply Subtype.ext
+  exact
+    Prod.ext (congrArg Subtype.val hb)
+      (congrArg (fun z : (PeriodFamily.regularPeriods P).TotalSpace => z.2) h)
+
+private theorem SpecialPeriods.EllipticFilling.localTotalMap_isLocalDiffeomorph
+    (P : HolomorphicPeriodMap ℂ ℍ) (j : Elliptic.Kind) :
+    letI := (localPeriods P j).totalChartedSpace
+    letI := (PeriodFamily.regularPeriods P).totalChartedSpace
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω (localTotalMap P j) := by
+  let Q := restrictPeriods (localPeriods P j) Elliptic.LogGauge.baseOpen
+  let := (localPeriods P j).totalChartedSpace
+  let := (PeriodFamily.regularPeriods P).totalChartedSpace
+  let := Q.totalChartedSpace
+  let e := restrictFamilyBiholomorph (localPeriods P j) Elliptic.LogGauge.baseOpen
+  have hm :=
+    periodFamilyMap_isLocalDiffeomorph Q (PeriodFamily.regularPeriods P) (localBase j)
+      (fun _ => rfl) (localBase_isLocalDiffeomorph j)
+  intro x
+  have h :=
+    (e.symm.isLocalDiffeomorph x).comp (K := (modelWithCornersSelf ℂ Elliptic.FamilyModel)) (P :=
+      (PeriodFamily.regularPeriods P).TotalSpace) (hm (e.symm x))
+  apply isLocalDiffeomorphAt_congr_of_eventuallyEq h
+  apply Filter.Eventually.of_forall
+  intro y
+  change
+    localTotalMap P j y =
+      periodFamilyMap Q (PeriodFamily.regularPeriods P) (localBase j)
+        ((restrictFamilyBiholomorph (localPeriods P j) Elliptic.LogGauge.baseOpen).symm y)
+  rw [restrictFamilyBiholomorph_symm_apply]
+  rfl
+
+private theorem
+    SpecialPeriods.EllipticFilling.puncturedRotation_iterate_coe (j : Elliptic.Kind) (n : ℕ)
+    (z : Elliptic.LogGauge.BaseStar) :
+    ((puncturedRotation j)^[n] z).val = (Elliptic.familyRotation j)^[n] z.val := by
+  induction n with
+  | zero => rfl
+  | succ n ih =>
+    rw [Function.iterate_succ_apply', puncturedRotation_val, ih, Function.iterate_succ_apply']
+
+private theorem SpecialPeriods.EllipticFilling.localTotalMap_smul (P : HolomorphicPeriodMap ℂ ℍ)
+    (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (g : Elliptic.CyclicGroup j) (x : Elliptic.LogGauge.FamilyStar (localPeriods P j)) :
+    letI := Elliptic.LogGauge.starAction (localData P h₁ h₂ j) 0 (Matrix.mulVec_zero j.matrix)
+    letI := (PeriodFamily.regularData P h₁ h₂).totalAction
+    localTotalMap P j (g • x) =
+      SpecialPeriods.Triangle.ellipticGenerator j ^ g.toAdd.val • localTotalMap P j x := by
+  let L := localData P h₁ h₂ j
+  let D := PeriodFamily.regularData P h₁ h₂
+  let := Elliptic.LogGauge.starAction L 0 (Matrix.mulVec_zero j.matrix)
+  let := D.totalAction
+  have hb :
+    (⟨(g • x : Elliptic.LogGauge.FamilyStar L.periods).1.1,
+          (g • x : Elliptic.LogGauge.FamilyStar L.periods).2⟩ :
+        Elliptic.LogGauge.BaseStar) =
+      (puncturedRotation j)^[g.toAdd.val] ⟨x.1.1, x.2⟩ := by
+    apply Subtype.ext
+    exact
+      (zeroStarAction_fst L g x).trans
+        (puncturedRotation_iterate_coe j g.toAdd.val ⟨x.1.1, x.2⟩).symm
+  apply Prod.ext
+  · change
+      localBase j
+          ⟨(g • x : Elliptic.LogGauge.FamilyStar L.periods).1.1,
+            (g • x : Elliptic.LogGauge.FamilyStar L.periods).2⟩ =
+        SpecialPeriods.Triangle.ellipticGenerator j ^ g.toAdd.val • localBase j ⟨x.1.1, x.2⟩
+    rw [hb, localBase_rotation_iterate]
+  · exact zeroStarAction_snd L g x
+
+private def
+    SpecialPeriods.EllipticFilling.regularMap (P : HolomorphicPeriodMap ℂ ℍ) (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    Elliptic.LogGauge.FamilyStar (localPeriods P j) → (PeriodFamily.regularData P h₁ h₂).Space :=
+  (PeriodFamily.regularData P h₁ h₂).quotient ∘ localTotalMap P j
+
+@[simp]
+private theorem SpecialPeriods.EllipticFilling.regularMap_base (P : HolomorphicPeriodMap ℂ ℍ)
+    (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (x : Elliptic.LogGauge.FamilyStar (localPeriods P j)) :
+    (PeriodFamily.regularData P h₁ h₂).projection (regularMap P j h₁ h₂ x) =
+      baseQuotient j ⟨x.1.1, x.2⟩ :=
+  rfl
+
+private theorem SpecialPeriods.EllipticFilling.regularMap_smul (P : HolomorphicPeriodMap ℂ ℍ)
+    (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (g : Elliptic.CyclicGroup j) (x : Elliptic.LogGauge.FamilyStar (localPeriods P j)) :
+    letI := Elliptic.LogGauge.starAction (localData P h₁ h₂ j) 0 (Matrix.mulVec_zero j.matrix)
+    regularMap P j h₁ h₂ (g • x) = regularMap P j h₁ h₂ x := by
+  let := Elliptic.LogGauge.starAction (localData P h₁ h₂ j) 0 (Matrix.mulVec_zero j.matrix)
+  let := (PeriodFamily.regularData P h₁ h₂).totalAction
+  change
+    (PeriodFamily.regularData P h₁ h₂).quotient (localTotalMap P j (g • x)) =
+      (PeriodFamily.regularData P h₁ h₂).quotient (localTotalMap P j x)
+  rw [localTotalMap_smul, PeriodFamily.Data.quotient_smul]
+
+private theorem SpecialPeriods.EllipticFilling.regularMap_isLocalDiffeomorph
+    (P : HolomorphicPeriodMap ℂ ℍ) (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    letI := (localPeriods P j).totalChartedSpace
+    letI := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω (regularMap P j h₁ h₂) := by
+  let := (localPeriods P j).totalChartedSpace
+  let := (PeriodFamily.regularPeriods P).totalChartedSpace
+  let := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+  intro x
+  exact
+    (localTotalMap_isLocalDiffeomorph P j x).comp (K :=
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel)) (P :=
+      (PeriodFamily.regularData P h₁ h₂).Space)
+      ((PeriodFamily.regularData P h₁ h₂).quotient_isLocalDiffeomorph
+        (PeriodFamily.regularCovering P h₁ h₂) (localTotalMap P j x))
+
+private def SpecialPeriods.EllipticFilling.regularOverlap (P : HolomorphicPeriodMap ℂ ℍ)
+    (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    TopologicalSpace.Opens (PeriodFamily.regularData P h₁ h₂).Space :=
+  ⟨(PeriodFamily.regularData P h₁ h₂).projection ⁻¹'
+      (regularBasePatch j : Set SpecialPeriods.TriangleRegularQuotient),
+    (regularBasePatch j).isOpen.preimage (PeriodFamily.regularData P h₁ h₂).projection_continuous⟩
+
+@[simp]
+private theorem SpecialPeriods.EllipticFilling.regularOverlap_mem (P : HolomorphicPeriodMap ℂ ℍ)
+    (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (y : (PeriodFamily.regularData P h₁ h₂).Space) :
+    y ∈ regularOverlap P j h₁ h₂ ↔
+      (PeriodFamily.regularData P h₁ h₂).projection y ∈ regularBasePatch j :=
+  Iff.rfl
+
+private theorem SpecialPeriods.EllipticFilling.regularMap_mem_overlap (P : HolomorphicPeriodMap ℂ ℍ)
+    (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (x : Elliptic.LogGauge.FamilyStar (localPeriods P j)) :
+    regularMap P j h₁ h₂ x ∈ regularOverlap P j h₁ h₂ := by
+  rw [regularOverlap_mem, regularMap_base]
+  exact baseQuotient_mem_regularBasePatch j ⟨x.1.1, x.2⟩
+
+private theorem SpecialPeriods.EllipticFilling.regularMap_range (P : HolomorphicPeriodMap ℂ ℍ)
+    (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    Set.range (regularMap P j h₁ h₂) =
+      (regularOverlap P j h₁ h₂ : Set (PeriodFamily.regularData P h₁ h₂).Space) := by
+  let D := PeriodFamily.regularData P h₁ h₂
+  let := D.totalAction
+  ext y
+  constructor
+  · rintro ⟨x, rfl⟩
+    exact regularMap_mem_overlap P j h₁ h₂ x
+  · intro hy
+    obtain ⟨u, rfl⟩ := D.quotient_surjective y
+    have hb : D.baseQuotient u.1 ∈ regularBasePatch j := hy
+    have hz' : D.baseQuotient u.1 ∈ Set.range (baseQuotient j) := by
+      rw [baseQuotient_range]
+      exact hb
+    obtain ⟨z, hz⟩ := hz'
+    have hbase : D.baseQuotient (localBase j z) = D.baseQuotient u.1 := hz
+    obtain ⟨g, hg⟩ := (PeriodFamily.regularCovering P h₁ h₂).apply_eq_iff_mem_orbit.mp hbase
+    let x : Elliptic.LogGauge.FamilyStar (localPeriods P j) :=
+      ⟨(z.val, SpecialPeriods.triangleTorusHomeomorph g u.2), z.property⟩
+    refine ⟨x, ?_⟩
+    change D.quotient (localTotalMap P j x) = D.quotient u
+    apply (D.quotient_eq_iff _ _).mpr
+    exact ⟨g, Prod.ext hg rfl⟩
+
+private theorem SpecialPeriods.EllipticFilling.regularMap_eq_iff (P : HolomorphicPeriodMap ℂ ℍ)
+    (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (x y : Elliptic.LogGauge.FamilyStar (localPeriods P j)) :
+    letI := Elliptic.LogGauge.starAction (localData P h₁ h₂ j) 0 (Matrix.mulVec_zero j.matrix)
+    regularMap P j h₁ h₂ x = regularMap P j h₁ h₂ y ↔ ∃ g : Elliptic.CyclicGroup j, g • y = x := by
+  let L := localData P h₁ h₂ j
+  let D := PeriodFamily.regularData P h₁ h₂
+  let := Elliptic.LogGauge.starAction L 0 (Matrix.mulVec_zero j.matrix)
+  let := D.totalAction
+  constructor
+  · intro h
+    obtain ⟨g, hg⟩ := (D.quotient_eq_iff (localTotalMap P j x) (localTotalMap P j y)).mp h
+    have hb : g • localBase j ⟨y.1.1, y.2⟩ = localBase j ⟨x.1.1, x.2⟩ := congrArg Prod.fst hg
+    obtain ⟨n, hn, hgn, _⟩ := localBase_orbit_classification j g ⟨y.1.1, y.2⟩ ⟨x.1.1, x.2⟩ hb
+    let c : Elliptic.CyclicGroup j := Multiplicative.ofAdd (n : ZMod j.order)
+    refine ⟨c, localTotalMap_injective P j ?_⟩
+    calc
+      localTotalMap P j (c • y) =
+          SpecialPeriods.Triangle.ellipticGenerator j ^ n • localTotalMap P j y := by
+        rw [localTotalMap_smul]
+        simp only [c, toAdd_ofAdd, ZMod.val_natCast_of_lt hn]
+      _ = localTotalMap P j x := hgn ▸ hg
+  · rintro ⟨g, rfl⟩
+    exact regularMap_smul P j h₁ h₂ g y
+
+private def SpecialPeriods.EllipticFilling.regularMapToOverlap (P : HolomorphicPeriodMap ℂ ℍ)
+    (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (x : Elliptic.LogGauge.FamilyStar (localPeriods P j)) : regularOverlap P j h₁ h₂ :=
+  ⟨regularMap P j h₁ h₂ x, regularMap_mem_overlap P j h₁ h₂ x⟩
+
+private theorem SpecialPeriods.EllipticFilling.regularMapToOverlap_surjective
+    (P : HolomorphicPeriodMap ℂ ℍ) (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    Function.Surjective (regularMapToOverlap P j h₁ h₂) := by
+  intro y
+  have hy : y.val ∈ Set.range (regularMap P j h₁ h₂) := by
+    rw [regularMap_range]
+    exact y.property
+  obtain ⟨x, hx⟩ := hy
+  exact ⟨x, Subtype.ext hx⟩
+
+private def SpecialPeriods.EllipticFilling.tautologicalToOverlap (P : HolomorphicPeriodMap ℂ ℍ)
+    (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    Elliptic.LogGauge.TautologicalStar (localData P h₁ h₂ j) → regularOverlap P j h₁ h₂ := by
+  let := Elliptic.LogGauge.starAction (localData P h₁ h₂ j) 0 (Matrix.mulVec_zero j.matrix)
+  exact
+    Quotient.lift (regularMapToOverlap P j h₁ h₂)
+      (by
+        rintro x y ⟨g, hg⟩
+        apply Subtype.ext
+        exact (regularMap_eq_iff P j h₁ h₂ x y).mpr ⟨g, hg⟩)
+
+private theorem SpecialPeriods.EllipticFilling.tautologicalToOverlap_injective
+    (P : HolomorphicPeriodMap ℂ ℍ) (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    Function.Injective (tautologicalToOverlap P j h₁ h₂) := by
+  let L := localData P h₁ h₂ j
+  let := Elliptic.LogGauge.starAction L 0 (Matrix.mulVec_zero j.matrix)
+  intro a b h
+  obtain ⟨x, rfl⟩ := Elliptic.LogGauge.starProject_surjective L 0 (Matrix.mulVec_zero j.matrix) a
+  obtain ⟨y, rfl⟩ := Elliptic.LogGauge.starProject_surjective L 0 (Matrix.mulVec_zero j.matrix) b
+  have hxy : regularMap P j h₁ h₂ x = regularMap P j h₁ h₂ y := congrArg Subtype.val h
+  exact Quotient.sound ((regularMap_eq_iff P j h₁ h₂ x y).mp hxy)
+
+private theorem SpecialPeriods.EllipticFilling.tautologicalToOverlap_surjective
+    (P : HolomorphicPeriodMap ℂ ℍ) (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    Function.Surjective (tautologicalToOverlap P j h₁ h₂) := by
+  intro y
+  obtain ⟨x, rfl⟩ := regularMapToOverlap_surjective P j h₁ h₂ y
+  exact
+    ⟨Elliptic.LogGauge.starProject (localData P h₁ h₂ j) 0 (Matrix.mulVec_zero j.matrix) x, rfl⟩
+
+private theorem SpecialPeriods.EllipticFilling.tautologicalToOverlap_bijective
+    (P : HolomorphicPeriodMap ℂ ℍ) (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    Function.Bijective (tautologicalToOverlap P j h₁ h₂) :=
+  ⟨tautologicalToOverlap_injective P j h₁ h₂, tautologicalToOverlap_surjective P j h₁ h₂⟩
+
+private theorem SpecialPeriods.EllipticFilling.regularMapToOverlap_isLocalDiffeomorph
+    (P : HolomorphicPeriodMap ℂ ℍ) (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    letI := (localPeriods P j).totalChartedSpace
+    letI := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω (regularMapToOverlap P j h₁ h₂) := by
+  let := (localPeriods P j).totalChartedSpace
+  let := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+  exact
+    isLocalDiffeomorph_codRestrictOpens (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) (regularMap_isLocalDiffeomorph P j h₁ h₂)
+      (regularOverlap P j h₁ h₂) (regularMap_mem_overlap P j h₁ h₂)
+
+private theorem SpecialPeriods.EllipticFilling.tautologicalToOverlap_isLocalDiffeomorph
+    (P : HolomorphicPeriodMap ℂ ℍ) (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    letI :=
+      Elliptic.LogGauge.starChartedSpace (localData P h₁ h₂ j) 0 (Matrix.mulVec_zero j.matrix)
+    letI := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω (tautologicalToOverlap P j h₁ h₂) := by
+  let L := localData P h₁ h₂ j
+  let := L.periods.totalChartedSpace
+  let := L.periods.totalSpace_isManifold
+  let := Elliptic.LogGauge.starAction L 0 (Matrix.mulVec_zero j.matrix)
+  let := Elliptic.LogGauge.starChartedSpace L 0 (Matrix.mulVec_zero j.matrix)
+  let := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+  have hq :
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) ω
+      (Elliptic.LogGauge.starProject L 0 (Matrix.mulVec_zero j.matrix)) :=
+    CoveringQuotient.project_isLocalDiffeomorph
+      (Elliptic.LogGauge.starCoveringMap L 0 (Matrix.mulVec_zero j.matrix))
+      (Elliptic.LogGauge.starAction_holomorphic L 0 (Matrix.mulVec_zero j.matrix))
+  intro y
+  obtain ⟨x, rfl⟩ := Elliptic.LogGauge.starProject_surjective L 0 (Matrix.mulVec_zero j.matrix) y
+  exact localDiffeomorphAt_of_comp (hq x) (regularMapToOverlap_isLocalDiffeomorph P j h₁ h₂ x)
+
+private def
+    SpecialPeriods.EllipticFilling.tautologicalOverlapBiholomorph (P : HolomorphicPeriodMap ℂ ℍ)
+    (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    letI :=
+      Elliptic.LogGauge.starChartedSpace (localData P h₁ h₂ j) 0 (Matrix.mulVec_zero j.matrix)
+    letI := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+    Diffeomorph (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (Elliptic.LogGauge.TautologicalStar (localData P h₁ h₂ j)) (regularOverlap P j h₁ h₂) ω := by
+  let := Elliptic.LogGauge.starChartedSpace (localData P h₁ h₂ j) 0 (Matrix.mulVec_zero j.matrix)
+  let := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+  exact
+    (tautologicalToOverlap_isLocalDiffeomorph P j h₁ h₂).diffeomorphOfBijective
+      (tautologicalToOverlap_bijective P j h₁ h₂)
+
+@[simp]
+private theorem SpecialPeriods.EllipticFilling.tautologicalOverlapBiholomorph_project
+    (P : HolomorphicPeriodMap ℂ ℍ) (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (x : Elliptic.LogGauge.FamilyStar (localPeriods P j)) :
+    tautologicalOverlapBiholomorph P j h₁ h₂
+        (Elliptic.LogGauge.starProject (localData P h₁ h₂ j) 0 (Matrix.mulVec_zero j.matrix) x) =
+      regularMapToOverlap P j h₁ h₂ x :=
+  rfl
+
+private theorem SpecialPeriods.EllipticFilling.tautologicalOverlapBiholomorph_coordinate
+    (P : HolomorphicPeriodMap ℂ ℍ) (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (x : Elliptic.LogGauge.TautologicalStar (localData P h₁ h₂ j)) :
+    SpecialPeriods.Triangle.ellipticFullChart j
+        (SpecialPeriods.triangleRegularToOrbit
+          ((PeriodFamily.regularData P h₁ h₂).projection
+            (tautologicalOverlapBiholomorph P j h₁ h₂ x).val)) =
+      ((Elliptic.LogGauge.starProjection (localData P h₁ h₂ j) 0 (Matrix.mulVec_zero j.matrix) x :
+          SpecialPeriods.Disc) :
+        ℂ) := by
+  obtain ⟨y, rfl⟩ :=
+    Elliptic.LogGauge.starProject_surjective (localData P h₁ h₂ j) 0 (Matrix.mulVec_zero j.matrix)
+      x
+  change
+    SpecialPeriods.Triangle.ellipticFullChart j
+        (SpecialPeriods.triangleRegularToOrbit (baseQuotient j ⟨y.1.1, y.2⟩)) =
+      (y.1.1 : ℂ) ^ j.order
+  exact ellipticFullChart_baseQuotient j ⟨y.1.1, y.2⟩
+
+private abbrev SpecialPeriods.EllipticFilling.MainFillingStar (P : HolomorphicPeriodMap ℂ ℍ)
+    (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :=
+  Elliptic.LogGauge.FillingStar (localData P h₁ h₂ j) j.twist (Elliptic.mainTwist_admissible j)
+
+private def
+    SpecialPeriods.EllipticFilling.puncturedFillingBiholomorph (P : HolomorphicPeriodMap ℂ ℍ)
+    (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    letI := fillingChartedSpace P h₁ h₂ j
+    letI := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+    Diffeomorph (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) (MainFillingStar P j h₁ h₂)
+      (regularOverlap P j h₁ h₂) ω := by
+  let L := localData P h₁ h₂ j
+  let := fillingChartedSpace P h₁ h₂ j
+  let := Elliptic.LogGauge.starChartedSpace L 0 (Matrix.mulVec_zero j.matrix)
+  let := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+  exact
+    (Elliptic.LogGauge.mainFillingToTautologicalBiholomorph L).trans
+      (tautologicalOverlapBiholomorph P j h₁ h₂)
+
+private theorem SpecialPeriods.EllipticFilling.puncturedFillingBiholomorph_coordinate
+    (P : HolomorphicPeriodMap ℂ ℍ) (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (x : MainFillingStar P j h₁ h₂) :
+    SpecialPeriods.Triangle.ellipticFullChart j
+        (SpecialPeriods.triangleRegularToOrbit
+          ((PeriodFamily.regularData P h₁ h₂).projection
+            (puncturedFillingBiholomorph P j h₁ h₂ x).val)) =
+      (fillingProjection P h₁ h₂ j x.val : ℂ) := by
+  let L := localData P h₁ h₂ j
+  have h :=
+    tautologicalOverlapBiholomorph_coordinate P j h₁ h₂
+      (Elliptic.LogGauge.mainFillingToTautologicalBiholomorph L x)
+  have hb :=
+    congrArg (fun z : Elliptic.LogGauge.BaseStar => ((z : SpecialPeriods.Disc) : ℂ))
+      (Elliptic.LogGauge.mainFillingToTautologicalBiholomorph_base L x)
+  exact h.trans hb
+
+private def SpecialPeriods.EllipticFilling.regularCompactProjection (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂) :
+    (PeriodFamily.regularData P h₁ h₂).Space → SpecialPeriods.TriangleCompactifiedOrbitSpace :=
+  fun x =>
+  SpecialPeriods.triangleOpenInclusion
+    (SpecialPeriods.triangleRegularToOrbit ((PeriodFamily.regularData P h₁ h₂).projection x))
+
+private theorem SpecialPeriods.EllipticFilling.puncturedFillingBiholomorph_base
+    (P : HolomorphicPeriodMap ℂ ℍ) (j : Elliptic.Kind)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (x : MainFillingStar P j h₁ h₂) :
+    regularCompactProjection P h₁ h₂ (puncturedFillingBiholomorph P j h₁ h₂ x).val =
+      (SpecialPeriods.Triangle.ellipticCompactifiedChart j).symm
+        (fillingProjection P h₁ h₂ j x.val : ℂ) := by
+  let y := puncturedFillingBiholomorph P j h₁ h₂ x
+  have hs :
+    regularCompactProjection P h₁ h₂ y.val ∈
+      (SpecialPeriods.Triangle.ellipticCompactifiedChart j).source :=
+    (regularBasePatch_mem_iff_compactifiedChart j _).mp y.property
+  have hc :
+    SpecialPeriods.Triangle.ellipticCompactifiedChart j (regularCompactProjection P h₁ h₂ y.val) =
+      (fillingProjection P h₁ h₂ j x.val : ℂ) := by
+    rw [regularCompactProjection, SpecialPeriods.Triangle.ellipticCompactifiedChart_openInclusion]
+    exact puncturedFillingBiholomorph_coordinate P j h₁ h₂ x
+  exact
+    ((SpecialPeriods.Triangle.ellipticCompactifiedChart j).left_inv hs).symm.trans
+      (congrArg (SpecialPeriods.Triangle.ellipticCompactifiedChart j).symm hc)
+
+private theorem
+    SpecialPeriods.EllipticFilling.mainFillingStar_nonempty (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) : Nonempty (MainFillingStar P j h₁ h₂) := by
+  let z : SpecialPeriods.Disc := ⟨(1 / 2 : ℂ), by norm_num [SpecialPeriods.unitDisc]⟩
+  obtain ⟨y, hy⟩ := fillingProjection_surjective P h₁ h₂ j z
+  refine ⟨⟨y, ?_⟩⟩
+  change (fillingProjection P h₁ h₂ j y : ℂ) ≠ 0
+  rw [hy]
+  norm_num [z]
+
+private theorem
+    SpecialPeriods.EllipticFilling.regularOverlap_nonempty (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) : Nonempty (regularOverlap P j h₁ h₂) := by
+  obtain ⟨x⟩ := mainFillingStar_nonempty P h₁ h₂ j
+  exact ⟨puncturedFillingBiholomorph P j h₁ h₂ x⟩
+
+private theorem SpecialPeriods.EllipticFilling.piece_nonempty (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) : Nonempty (Piece P h₁ h₂ C j) :=
+  by
+  obtain ⟨x, _⟩ :=
+    pieceProjection_surjective P h₁ h₂ C j
+      ⟨SpecialPeriods.Threefold.puncturePoint (Option.some j),
+        C.point_mem_fillingPatch (Option.some j)⟩
+  exact ⟨x⟩
+
+private theorem SpecialPeriods.EllipticFilling.regularOverlap_mem_iff_compactifiedChart
+    (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) (y : (PeriodFamily.regularData P h₁ h₂).Space) :
+    y ∈ regularOverlap P j h₁ h₂ ↔
+      regularCompactProjection P h₁ h₂ y ∈
+        (SpecialPeriods.Triangle.ellipticCompactifiedChart j).source :=
+  regularBasePatch_mem_iff_compactifiedChart j ((PeriodFamily.regularData P h₁ h₂).projection y)
+
+private def SpecialPeriods.EllipticFilling.puncturedFillingPartial (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) :
+    letI := fillingChartedSpace P h₁ h₂ j
+    letI := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+    PartialDiffeomorph (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) (fillingSpace P h₁ h₂ j)
+      (PeriodFamily.regularData P h₁ h₂).Space ω := by
+  let := fillingChartedSpace P h₁ h₂ j
+  let := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+  exact
+    (opensInclusionPartialDiffeomorph (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+          (Elliptic.LogGauge.fillingOpen (localData P h₁ h₂ j) j.twist
+            (Elliptic.mainTwist_admissible j))
+          (mainFillingStar_nonempty P h₁ h₂ j)).symm.trans
+      ((puncturedFillingBiholomorph P j h₁ h₂).toPartialDiffeomorph.trans
+        (opensInclusionPartialDiffeomorph (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+          (regularOverlap P j h₁ h₂) (regularOverlap_nonempty P h₁ h₂ j)))
+
+@[simp]
+private theorem SpecialPeriods.EllipticFilling.puncturedFillingPartial_source
+    (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) :
+    letI := fillingChartedSpace P h₁ h₂ j
+    letI := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+    (puncturedFillingPartial P h₁ h₂ j).source =
+      (Elliptic.LogGauge.fillingOpen (localData P h₁ h₂ j) j.twist
+          (Elliptic.mainTwist_admissible j) :
+        Set _) := by
+  let := fillingChartedSpace P h₁ h₂ j
+  let := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+  simp [puncturedFillingPartial, PartialDiffeomorph.trans, PartialDiffeomorph.symm,
+    Diffeomorph.toPartialDiffeomorph, opensInclusionPartialDiffeomorph]
+
+@[simp]
+private theorem SpecialPeriods.EllipticFilling.puncturedFillingPartial_target
+    (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) :
+    letI := fillingChartedSpace P h₁ h₂ j
+    letI := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+    (puncturedFillingPartial P h₁ h₂ j).target =
+      (regularOverlap P j h₁ h₂ : Set (PeriodFamily.regularData P h₁ h₂).Space) := by
+  let := fillingChartedSpace P h₁ h₂ j
+  let := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+  simp [puncturedFillingPartial, PartialDiffeomorph.trans, PartialDiffeomorph.symm,
+    Diffeomorph.toPartialDiffeomorph, opensInclusionPartialDiffeomorph]
+
+@[simp]
+private theorem SpecialPeriods.EllipticFilling.puncturedFillingPartial_apply
+    (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) (x : MainFillingStar P j h₁ h₂) :
+    letI := fillingChartedSpace P h₁ h₂ j
+    letI := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+    puncturedFillingPartial P h₁ h₂ j x.val = (puncturedFillingBiholomorph P j h₁ h₂ x).val := by
+  let := fillingChartedSpace P h₁ h₂ j
+  let := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+  let e :=
+    (Elliptic.LogGauge.fillingOpen (localData P h₁ h₂ j) j.twist
+          (Elliptic.mainTwist_admissible j)).openPartialHomeomorphSubtypeCoe
+      (mainFillingStar_nonempty P h₁ h₂ j)
+  have he : e.symm x.val = x := e.left_inv (Set.mem_univ x)
+  change
+    (puncturedFillingBiholomorph P j h₁ h₂ (e.symm x.val) :
+        (PeriodFamily.regularData P h₁ h₂).Space) =
+      _
+  rw [he]
+
+private theorem
+    SpecialPeriods.EllipticFilling.puncturedFillingPartial_base (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) (x : fillingSpace P h₁ h₂ j)
+    (hx : x ∈ (puncturedFillingPartial P h₁ h₂ j).source) :
+    letI := fillingChartedSpace P h₁ h₂ j
+    letI := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+    regularCompactProjection P h₁ h₂ (puncturedFillingPartial P h₁ h₂ j x) =
+      (SpecialPeriods.Triangle.ellipticCompactifiedChart j).symm
+        (fillingProjection P h₁ h₂ j x : ℂ) := by
+  let := fillingChartedSpace P h₁ h₂ j
+  let := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+  have hx' :
+    x ∈
+      (Elliptic.LogGauge.fillingOpen (localData P h₁ h₂ j) j.twist
+          (Elliptic.mainTwist_admissible j) :
+        Set (fillingSpace P h₁ h₂ j)) := by simpa only [puncturedFillingPartial_source] using hx
+  rw [puncturedFillingPartial_apply P h₁ h₂ j ⟨x, hx'⟩]
+  exact puncturedFillingBiholomorph_base P j h₁ h₂ ⟨x, hx'⟩
+
+private theorem SpecialPeriods.EllipticFilling.puncturedFillingPartial_coordinate
+    (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) (x : fillingSpace P h₁ h₂ j)
+    (hx : x ∈ (puncturedFillingPartial P h₁ h₂ j).source) :
+    letI := fillingChartedSpace P h₁ h₂ j
+    letI := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+    SpecialPeriods.Triangle.ellipticCompactifiedChart j
+        (regularCompactProjection P h₁ h₂ (puncturedFillingPartial P h₁ h₂ j x)) =
+      (fillingProjection P h₁ h₂ j x : ℂ) := by
+  let := fillingChartedSpace P h₁ h₂ j
+  let := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+  have hx' :
+    x ∈
+      (Elliptic.LogGauge.fillingOpen (localData P h₁ h₂ j) j.twist
+          (Elliptic.mainTwist_admissible j) :
+        Set (fillingSpace P h₁ h₂ j)) := by simpa only [puncturedFillingPartial_source] using hx
+  rw [puncturedFillingPartial_apply P h₁ h₂ j ⟨x, hx'⟩, regularCompactProjection,
+    SpecialPeriods.Triangle.ellipticCompactifiedChart_openInclusion]
+  exact puncturedFillingBiholomorph_coordinate P j h₁ h₂ ⟨x, hx'⟩
+
+private theorem SpecialPeriods.EllipticFilling.puncturedFillingPartial_symm_coordinate
+    (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (j : Elliptic.Kind) (y : (PeriodFamily.regularData P h₁ h₂).Space)
+    (hy : y ∈ (puncturedFillingPartial P h₁ h₂ j).target) :
+    letI := fillingChartedSpace P h₁ h₂ j
+    letI := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+    (fillingProjection P h₁ h₂ j ((puncturedFillingPartial P h₁ h₂ j).symm y) : ℂ) =
+      SpecialPeriods.Triangle.ellipticCompactifiedChart j (regularCompactProjection P h₁ h₂ y) := by
+  let := fillingChartedSpace P h₁ h₂ j
+  let := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+  have h :=
+    puncturedFillingPartial_coordinate P h₁ h₂ j ((puncturedFillingPartial P h₁ h₂ j).symm y)
+      ((puncturedFillingPartial P h₁ h₂ j).map_target hy)
+  have he : puncturedFillingPartial P h₁ h₂ j ((puncturedFillingPartial P h₁ h₂ j).symm y) = y :=
+    (puncturedFillingPartial P h₁ h₂ j).right_inv hy
+  exact
+    h.symm.trans
+      (congrArg
+        (fun z : (PeriodFamily.regularData P h₁ h₂).Space =>
+          SpecialPeriods.Triangle.ellipticCompactifiedChart j
+            (regularCompactProjection P h₁ h₂ z))
+        he)
+
+private def SpecialPeriods.EllipticFilling.smallOverlap (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    letI := pieceChartedSpace P h₁ h₂ C j
+    letI := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+    PartialDiffeomorph (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+      (modelWithCornersSelf ℂ Elliptic.FamilyModel) (Piece P h₁ h₂ C j)
+      (PeriodFamily.regularData P h₁ h₂).Space ω := by
+  let := fillingChartedSpace P h₁ h₂ j
+  let := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+  exact
+    (opensInclusionPartialDiffeomorph (modelWithCornersSelf ℂ Elliptic.FamilyModel)
+          (pieceDomain P h₁ h₂ C j) (piece_nonempty P h₁ h₂ C j)).trans
+      (puncturedFillingPartial P h₁ h₂ j)
+
+@[simp]
+private theorem SpecialPeriods.EllipticFilling.smallOverlap_apply (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) (x : Piece P h₁ h₂ C j) :
+    smallOverlap P h₁ h₂ C j x = puncturedFillingPartial P h₁ h₂ j x.val :=
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.EllipticFilling.smallOverlap_source (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    (smallOverlap P h₁ h₂ C j).source =
+      pieceProjectionToBase P h₁ h₂ C j ⁻¹'
+        (SpecialPeriods.Threefold.regularPatch :
+          Set SpecialPeriods.TriangleCompactifiedOrbitSpace) := by
+  let := fillingChartedSpace P h₁ h₂ j
+  let := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+  change
+    Set.univ ∩
+        (Subtype.val : Piece P h₁ h₂ C j → fillingSpace P h₁ h₂ j) ⁻¹'
+          (puncturedFillingPartial P h₁ h₂ j).source =
+      _
+  rw [Set.univ_inter, puncturedFillingPartial_source]
+  ext x
+  exact (pieceProjectionToBase_mem_regular_iff P h₁ h₂ C j x).symm
+
+private theorem
+    SpecialPeriods.EllipticFilling.smallOverlap_mem_source (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) (x : Piece P h₁ h₂ C j) :
+    x ∈ (smallOverlap P h₁ h₂ C j).source ↔ (fillingProjection P h₁ h₂ j x.val : ℂ) ≠ 0 := by
+  rw [smallOverlap_source]
+  exact pieceProjectionToBase_mem_regular_iff P h₁ h₂ C j x
+
+private theorem
+    SpecialPeriods.EllipticFilling.smallOverlap_apply_mainStar (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) (x : Piece P h₁ h₂ C j)
+    (hx : (fillingProjection P h₁ h₂ j x.val : ℂ) ≠ 0) :
+    smallOverlap P h₁ h₂ C j x =
+      (puncturedFillingBiholomorph P j h₁ h₂ (⟨x.val, hx⟩ : MainFillingStar P j h₁ h₂)).val :=
+  puncturedFillingPartial_apply P h₁ h₂ j ⟨x.val, hx⟩
+
+@[simp]
+private theorem SpecialPeriods.EllipticFilling.smallOverlap_target (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) :
+    (smallOverlap P h₁ h₂ C j).target =
+      regularCompactProjection P h₁ h₂ ⁻¹'
+        (C.fillingPatch (Option.some j) : Set SpecialPeriods.TriangleCompactifiedOrbitSpace) := by
+  let := fillingChartedSpace P h₁ h₂ j
+  let := (PeriodFamily.regularData P h₁ h₂).chartedSpace (PeriodFamily.regularCovering P h₁ h₂)
+  change
+    (puncturedFillingPartial P h₁ h₂ j).target ∩
+        (puncturedFillingPartial P h₁ h₂ j).symm ⁻¹'
+          ((pieceDomain P h₁ h₂ C j).openPartialHomeomorphSubtypeCoe
+              (piece_nonempty P h₁ h₂ C j)).target =
+      _
+  rw [TopologicalSpace.Opens.openPartialHomeomorphSubtypeCoe_target]
+  ext y
+  constructor
+  · rintro ⟨hy, hyV⟩
+    have hyOverlap : y ∈ regularOverlap P j h₁ h₂ := by
+      change y ∈ (regularOverlap P j h₁ h₂ : Set (PeriodFamily.regularData P h₁ h₂).Space)
+      rw [← puncturedFillingPartial_target P h₁ h₂ j]
+      exact hy
+    refine
+      (C.mem_fillingPatch (Option.some j) (regularCompactProjection P h₁ h₂ y)).mpr
+        ⟨(regularOverlap_mem_iff_compactifiedChart P h₁ h₂ j y).mp hyOverlap, ?_⟩
+    change
+      ‖SpecialPeriods.Triangle.ellipticCompactifiedChart j (regularCompactProjection P h₁ h₂ y)‖ <
+        C.radius (Option.some j)
+    rw [← puncturedFillingPartial_symm_coordinate P h₁ h₂ j y hy]
+    exact hyV
+  · intro hy
+    have hy' := (C.mem_fillingPatch (Option.some j) (regularCompactProjection P h₁ h₂ y)).mp hy
+    have hyFull : y ∈ (puncturedFillingPartial P h₁ h₂ j).target := by
+      rw [puncturedFillingPartial_target]
+      exact (regularOverlap_mem_iff_compactifiedChart P h₁ h₂ j y).mpr hy'.1
+    refine ⟨hyFull, ?_⟩
+    change
+      ‖(fillingProjection P h₁ h₂ j ((puncturedFillingPartial P h₁ h₂ j).symm y) : ℂ)‖ <
+        C.radius (Option.some j)
+    rw [puncturedFillingPartial_symm_coordinate P h₁ h₂ j y hyFull]
+    exact hy'.2
+
+private theorem SpecialPeriods.EllipticFilling.smallOverlap_base (P : HolomorphicPeriodMap ℂ ℍ)
+    (h₁ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorOneSL • z) = (P.point z).step₁)
+    (h₂ : ∀ z : ℍ, P.point (SpecialPeriods.Triangle.generatorTwoSL • z) = (P.point z).step₂)
+    (C : SpecialPeriods.Threefold.BaseCover) (j : Elliptic.Kind) (x : Piece P h₁ h₂ C j)
+    (hx : x ∈ (smallOverlap P h₁ h₂ C j).source) :
+    regularCompactProjection P h₁ h₂ (smallOverlap P h₁ h₂ C j x) =
+      pieceProjectionToBase P h₁ h₂ C j x := by
+  rw [smallOverlap_apply]
+  exact
+    puncturedFillingPartial_base P h₁ h₂ j x.val
+      (by
+        rw [puncturedFillingPartial_source]
+        exact (smallOverlap_mem_source P h₁ h₂ C j x).mp hx)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+private def SpecialPeriods.Threefold.specialEllipticOverlap (j : Elliptic.Kind) :
+    PartialDiffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) (SpecialEllipticPiece j) SpecialRegularFamily
+      ω :=
+  SpecialPeriods.EllipticFilling.smallOverlap SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+    specialBaseCover j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.specialEllipticOverlap_source (j : Elliptic.Kind) :
+    (specialEllipticOverlap j).source =
+      specialEllipticPieceProjectionToBase j ⁻¹'
+        (regularPatch : Set SpecialPeriods.TriangleCompactifiedOrbitSpace) :=
+  SpecialPeriods.EllipticFilling.smallOverlap_source SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+    specialBaseCover j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.specialEllipticOverlap_target (j : Elliptic.Kind) :
+    (specialEllipticOverlap j).target =
+      specialRegularFamilyProjectionToBase ⁻¹'
+        (specialBaseCover.fillingPatch (Option.some j) :
+          Set SpecialPeriods.TriangleCompactifiedOrbitSpace) :=
+  SpecialPeriods.EllipticFilling.smallOverlap_target SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+    specialBaseCover j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.specialRegularFamilyChartedSpace
+    SpecialPeriods.Threefold.specialEllipticPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.specialEllipticOverlap_base (j : Elliptic.Kind)
+    (x : SpecialEllipticPiece j) (hx : x ∈ (specialEllipticOverlap j).source) :
+    specialRegularFamilyProjectionToBase (specialEllipticOverlap j x) =
+      specialEllipticPieceProjectionToBase j x :=
+  SpecialPeriods.EllipticFilling.smallOverlap_base SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+    specialBaseCover j x hx
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+private def SpecialPeriods.Threefold.localOverlap :
+    (i : Puncture) →
+      PartialDiffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+        (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) (localPiece (Option.some i))
+        (localPiece Option.none) ω
+  | none => specialCuspOverlap
+  | some j => specialEllipticOverlap j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.localOverlap_source (i : Puncture) :
+    (localOverlap i).source =
+      localBaseMap (Option.some i) ⁻¹'
+        (specialBaseCover.patch Option.none :
+          Set SpecialPeriods.TriangleCompactifiedOrbitSpace) := by
+  cases i with
+  | none => exact specialCuspOverlap_source
+  | some j => exact specialEllipticOverlap_source j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.localOverlap_target (i : Puncture) :
+    (localOverlap i).target =
+      localBaseMap Option.none ⁻¹'
+        (specialBaseCover.patch (Option.some i) :
+          Set SpecialPeriods.TriangleCompactifiedOrbitSpace) := by
+  cases i with
+  | none => exact specialCuspOverlap_target
+  | some j => exact specialEllipticOverlap_target j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.localOverlap_base (i : Puncture) (x : localPiece (Option.some i))
+    (hx : x ∈ (localOverlap i).source) :
+    localBaseMap Option.none (localOverlap i x) = localBaseMap (Option.some i) x := by
+  cases i with
+  | none => exact specialCuspOverlap_base x hx
+  | some j => exact specialEllipticOverlap_base j x hx
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+private abbrev SpecialPeriods.Threefold.gluingStar :
+    Star.Input SpecialPeriods.TriangleCompactifiedOrbitSpace Puncture
+    where
+  patch := specialBaseCover.patch
+  cover := specialBaseCover.isOpenCover
+  disjoint := specialBaseCover.pairwise_disjoint
+  piece := localPiece
+  toBase := localBaseMap
+  toBase_mem := localProjectionToBase_mem
+  overlap i := (localOverlap i).toOpenPartialHomeomorph
+  source_eq := localOverlap_source
+  target_eq := localOverlap_target
+  preserves_base := localOverlap_base
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+private abbrev SpecialPeriods.Threefold.gluingData :
+    ThreefoldGluing.Data SpecialPeriods.TriangleCompactifiedOrbitSpace :=
+  gluingStar.toData
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.gluingData_transition_holomorphic (i j : Index) :
+    ContMDiffOn (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (gluingData.transition i j)
+      (gluingData.transition i j).source :=
+  gluingStar.toData_transition_holomorphic (fun i => (localOverlap i).contMDiffOn)
+    (fun i => (localOverlap i).symm.contMDiffOn) i j
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace in
+private theorem SpecialPeriods.Threefold.gluingData_localProjection_proper (i : Index) :
+    IsProperMap (gluingData.localProjection i) :=
+  localProjection_proper i
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace SpecialPeriods.Threefold.localPiece_nonempty
+    SpecialPeriods.Threefold.localPiece_t2Space
+    SpecialPeriods.Threefold.localPiece_secondCountable
+    SpecialPeriods.Threefold.localPiece_isManifold in
+private abbrev SpecialPeriods.Threefold.Space :=
+  gluingData.Space
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace SpecialPeriods.Threefold.localPiece_nonempty
+    SpecialPeriods.Threefold.localPiece_t2Space
+    SpecialPeriods.Threefold.localPiece_secondCountable
+    SpecialPeriods.Threefold.localPiece_isManifold in
+@[instance_reducible]
+private def SpecialPeriods.Threefold.chartedSpace : ChartedSpace (ℂ × ComplexPlane₂) Space :=
+  gluingData.chartedSpace
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace SpecialPeriods.Threefold.localPiece_nonempty
+    SpecialPeriods.Threefold.localPiece_t2Space
+    SpecialPeriods.Threefold.localPiece_secondCountable
+    SpecialPeriods.Threefold.localPiece_isManifold in
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+private abbrev SpecialPeriods.Threefold.projection :
+    Space → SpecialPeriods.TriangleCompactifiedOrbitSpace :=
+  gluingData.projection
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace SpecialPeriods.Threefold.localPiece_nonempty
+    SpecialPeriods.Threefold.localPiece_t2Space
+    SpecialPeriods.Threefold.localPiece_secondCountable
+    SpecialPeriods.Threefold.localPiece_isManifold in
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.projection_proper : IsProperMap projection :=
+  gluingData.projection_proper gluingData_localProjection_proper
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace SpecialPeriods.Threefold.localPiece_nonempty
+    SpecialPeriods.Threefold.localPiece_t2Space
+    SpecialPeriods.Threefold.localPiece_secondCountable
+    SpecialPeriods.Threefold.localPiece_isManifold in
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.space_compact : CompactSpace Space :=
+  gluingData.compactSpace gluingData_localProjection_proper
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace SpecialPeriods.Threefold.localPiece_nonempty
+    SpecialPeriods.Threefold.localPiece_t2Space
+    SpecialPeriods.Threefold.localPiece_secondCountable
+    SpecialPeriods.Threefold.localPiece_isManifold in
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.space_t2Space : T2Space Space :=
+  gluingData.spaceT2
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace SpecialPeriods.Threefold.localPiece_nonempty
+    SpecialPeriods.Threefold.localPiece_t2Space
+    SpecialPeriods.Threefold.localPiece_secondCountable
+    SpecialPeriods.Threefold.localPiece_isManifold in
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.space_secondCountable : SecondCountableTopology Space :=
+  gluingData.secondCountableSpace_of_compactBase
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace SpecialPeriods.Threefold.localPiece_nonempty
+    SpecialPeriods.Threefold.localPiece_t2Space
+    SpecialPeriods.Threefold.localPiece_secondCountable
+    SpecialPeriods.Threefold.localPiece_isManifold in
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.space_isManifold :
+    IsManifold (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω Space :=
+  gluingData.isManifold gluingData_transition_holomorphic
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace SpecialPeriods.Threefold.localPiece_nonempty
+    SpecialPeriods.Threefold.localPiece_t2Space
+    SpecialPeriods.Threefold.localPiece_secondCountable
+    SpecialPeriods.Threefold.localPiece_isManifold in
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.space_nonempty : Nonempty Space :=
+  ⟨gluingData.inclusion Option.none specialRegularFamilyPoint⟩
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace SpecialPeriods.Threefold.localPiece_nonempty
+    SpecialPeriods.Threefold.localPiece_t2Space
+    SpecialPeriods.Threefold.localPiece_secondCountable
+    SpecialPeriods.Threefold.localPiece_isManifold in
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+private def SpecialPeriods.Threefold.projectionSphere : Space → RiemannSphere :=
+  SpecialPeriods.Triangle.triangleSphereUniformization ∘ projection
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace SpecialPeriods.Threefold.localPiece_nonempty
+    SpecialPeriods.Threefold.localPiece_t2Space
+    SpecialPeriods.Threefold.localPiece_secondCountable
+    SpecialPeriods.Threefold.localPiece_isManifold in
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+private abbrev SpecialPeriods.Threefold.inclusion (i : Index) : localPiece i → Space :=
+  gluingData.inclusion i
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace SpecialPeriods.Threefold.localPiece_nonempty
+    SpecialPeriods.Threefold.localPiece_t2Space
+    SpecialPeriods.Threefold.localPiece_secondCountable
+    SpecialPeriods.Threefold.localPiece_isManifold in
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.inclusion_openEmbedding (i : Index) :
+    Topology.IsOpenEmbedding (SpecialPeriods.Threefold.inclusion i) :=
+  gluingData.inclusion_openEmbedding i
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace SpecialPeriods.Threefold.localPiece_nonempty
+    SpecialPeriods.Threefold.localPiece_t2Space
+    SpecialPeriods.Threefold.localPiece_secondCountable
+    SpecialPeriods.Threefold.localPiece_isManifold in
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.inclusion_holomorphic (i : Index) :
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (SpecialPeriods.Threefold.inclusion i) :=
+  gluingData.inclusion_holomorphic gluingData_transition_holomorphic i
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace SpecialPeriods.Threefold.localPiece_nonempty
+    SpecialPeriods.Threefold.localPiece_t2Space
+    SpecialPeriods.Threefold.localPiece_secondCountable
+    SpecialPeriods.Threefold.localPiece_isManifold in
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.projection_inclusion (i : Index) (x : localPiece i) :
+    projection (SpecialPeriods.Threefold.inclusion i x) = localProjectionToBase i x :=
+  gluingData.projection_inclusion i x
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace SpecialPeriods.Threefold.localPiece_nonempty
+    SpecialPeriods.Threefold.localPiece_t2Space
+    SpecialPeriods.Threefold.localPiece_secondCountable
+    SpecialPeriods.Threefold.localPiece_isManifold in
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.inclusion_range (i : Index) :
+    Set.range (SpecialPeriods.Threefold.inclusion i) =
+      projection ⁻¹'
+        (specialBaseCover.patch i : Set SpecialPeriods.TriangleCompactifiedOrbitSpace) :=
+  gluingData.inclusion_range i
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace SpecialPeriods.Threefold.localPiece_nonempty
+    SpecialPeriods.Threefold.localPiece_t2Space
+    SpecialPeriods.Threefold.localPiece_secondCountable
+    SpecialPeriods.Threefold.localPiece_isManifold in
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+private abbrev SpecialPeriods.Threefold.liftedPatch (i : Index) : TopologicalSpace.Opens Space :=
+  gluingData.liftedPatch i
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.localPieceChartedSpace SpecialPeriods.Threefold.localPiece_nonempty
+    SpecialPeriods.Threefold.localPiece_t2Space
+    SpecialPeriods.Threefold.localPiece_secondCountable
+    SpecialPeriods.Threefold.localPiece_isManifold in
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+private def SpecialPeriods.Threefold.patchBiholomorph (i : Index) :
+    Diffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) (localPiece i) (liftedPatch i) ω :=
+  gluingData.patchBiholomorph gluingData_transition_holomorphic i
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.specialRegularFamilyProjection_fibre_isConnected
+    (b : regularPatch) : IsConnected (specialRegularFamilyProjection ⁻¹' { b }) := by
+  let D :=
+    regularFamilyData SpecialPeriods.specialPeriodMap SpecialPeriods.specialPeriodMap_generator₁
+      SpecialPeriods.specialPeriodMap_generator₂
+  have hf (q : SpecialPeriods.TriangleRegularQuotient) : IsConnected (D.projection ⁻¹' { q }) := by
+    obtain ⟨z, rfl⟩ :=
+      (PeriodFamily.regularCovering SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁
+            SpecialPeriods.specialPeriodMap_generator₂).surjective
+        q
+    apply isConnected_iff_connectedSpace.mpr
+    exact
+      (D.fibreHomeomorph
+            (PeriodFamily.regularCovering SpecialPeriods.specialPeriodMap
+              SpecialPeriods.specialPeriodMap_generator₁
+              SpecialPeriods.specialPeriodMap_generator₂)
+            z).connectedSpace_iff.mp
+        inferInstance
+  change IsConnected ((regularBiholomorph.toHomeomorph ∘ D.projection) ⁻¹' { b })
+  exact
+    FibreTopology.fibre_isConnected_comp_homeomorph D.projection regularBiholomorph.toHomeomorph b
+      (hf (regularBiholomorph.symm b))
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.specialCuspPieceCoordinate_fibre_isConnected
+    (b : coordinateBall (specialBaseCover.radius Option.none)) :
+    IsConnected
+      (CuspPiece.coordinate SpecialPeriods.specialCuspData specialBaseCover ⁻¹' { b }) := by
+  let D :=
+    CuspPiece.restrictedData SpecialPeriods.specialCuspData specialBaseCover specialCuspRadius_le
+  have he :
+    CuspPiece.coordinate SpecialPeriods.specialCuspData specialBaseCover ⁻¹' { b } =
+      CuspQuotient.projection SpecialPeriods.specialCuspData.correction
+          (specialBaseCover.radius Option.none) ⁻¹'
+        {(b : ℂ)} := by
+    ext x
+    exact Subtype.ext_iff
+  rw [he]
+  exact
+    CuspUniformization.fibre_connected SpecialPeriods.specialCuspData.correction
+      (specialBaseCover.radius Option.none) (specialBaseCover.radius_pos Option.none)
+      D.radius_lt_one D.holomorphic D.smallDrift b
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.specialCuspPieceProjection_fibre_isConnected
+    (b : specialBaseCover.fillingPatch Option.none) :
+    IsConnected (specialCuspPieceProjection ⁻¹' { b }) := by
+  change
+    IsConnected
+      ((((specialBaseCover.fillingChart Option.none).symm.toHomeomorph) ∘
+          CuspPiece.coordinate SpecialPeriods.specialCuspData specialBaseCover) ⁻¹'
+        { b })
+  exact
+    FibreTopology.fibre_isConnected_comp_homeomorph
+      (CuspPiece.coordinate SpecialPeriods.specialCuspData specialBaseCover)
+      (specialBaseCover.fillingChart Option.none).symm.toHomeomorph b
+      (specialCuspPieceCoordinate_fibre_isConnected (specialBaseCover.fillingChart Option.none b))
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.specialEllipticPieceCoordinate_fibre_isConnected
+    (j : Elliptic.Kind) (b : coordinateBall (specialBaseCover.radius (Option.some j))) :
+    IsConnected
+      (SpecialPeriods.EllipticFilling.pieceCoordinate SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+          specialBaseCover j ⁻¹'
+        { b }) := by
+  let f :=
+    SpecialPeriods.EllipticFilling.fillingProjection SpecialPeriods.specialPeriodMap
+      SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂ j
+  let S : Set SpecialPeriods.Disc :=
+    SpecialPeriods.EllipticFilling.smallDisc (specialBaseCover.radius (Option.some j))
+  let e :=
+    SpecialPeriods.EllipticFilling.smallDiscHomeomorph (specialBaseCover.radius (Option.some j))
+      (specialBaseCover.radius_lt_chart (Option.some j))
+  have hf (q : SpecialPeriods.Disc) : IsConnected (f ⁻¹' { q }) :=
+    (SpecialPeriods.EllipticFilling.localData SpecialPeriods.specialPeriodMap
+          SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+          j).projection_fibre_isConnected
+      j.twist (Elliptic.mainTwist_admissible j) q
+  change IsConnected ((e ∘ S.restrictPreimage f) ⁻¹' { b })
+  exact
+    FibreTopology.fibre_isConnected_comp_homeomorph (S.restrictPreimage f) e b
+      (FibreTopology.restrictPreimage_fibre_isConnected f S (e.symm b) (hf (e.symm b).val))
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.specialEllipticPieceProjection_fibre_isConnected
+    (j : Elliptic.Kind) (b : specialBaseCover.fillingPatch (Option.some j)) :
+    IsConnected (specialEllipticPieceProjection j ⁻¹' { b }) := by
+  change
+    IsConnected
+      ((((specialBaseCover.fillingChart (Option.some j)).symm.toHomeomorph) ∘
+          SpecialPeriods.EllipticFilling.pieceCoordinate SpecialPeriods.specialPeriodMap
+            SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+            specialBaseCover j) ⁻¹'
+        { b })
+  exact
+    FibreTopology.fibre_isConnected_comp_homeomorph
+      (SpecialPeriods.EllipticFilling.pieceCoordinate SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+        specialBaseCover j)
+      (specialBaseCover.fillingChart (Option.some j)).symm.toHomeomorph b
+      (specialEllipticPieceCoordinate_fibre_isConnected j
+        (specialBaseCover.fillingChart (Option.some j) b))
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace
+    SpecialPeriods.triangleOrbitChartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.localProjection_fibre_isConnected (i : Index)
+    (b : specialBaseCover.patch i) : IsConnected (localProjection i ⁻¹' { b }) := by
+  cases i with
+  | none => exact specialRegularFamilyProjection_fibre_isConnected b
+  | some i =>
+    cases i with
+    | none => exact specialCuspPieceProjection_fibre_isConnected b
+    | some j => exact specialEllipticPieceProjection_fibre_isConnected j b
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.gluingData_localProjection_fibre_isConnected (i : Index)
+    (b : specialBaseCover.patch i) : IsConnected (gluingData.localProjection i ⁻¹' { b }) :=
+  localProjection_fibre_isConnected i b
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.projection_fibre_isConnected
+    (b : SpecialPeriods.TriangleCompactifiedOrbitSpace) : IsConnected (projection ⁻¹' { b }) :=
+  gluingData.projection_fibre_isConnected gluingData_localProjection_fibre_isConnected b
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace
+    SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.space_connected : ConnectedSpace Space :=
+  gluingData.connectedSpace gluingData_localProjection_proper
+    gluingData_localProjection_fibre_isConnected
+
+public
+theorem SpecialPeriods.Threefold.punctured_complex_ball_isPathConnected {r : ℝ} (hr : 0 < r) :
+    IsPathConnected (Metric.ball (0 : ℂ) r \ {0}) := by
+  let e : OpenPartialHomeomorph ℂ ℂ := OpenPartialHomeomorph.univBall (0 : ℂ) r
+  have hsource : e.source = Set.univ := OpenPartialHomeomorph.univBall_source _ _
+  have htarget : e.target = Metric.ball 0 r := OpenPartialHomeomorph.univBall_target _ hr
+  have hzero : e 0 = 0 := OpenPartialHomeomorph.univBall_apply_zero _ _
+  have hinj : Function.Injective e := by
+    intro z w h
+    exact e.injOn (by rw [hsource]; trivial) (by rw [hsource]; trivial) h
+  have himage : e '' ({0}ᶜ : Set ℂ) = Metric.ball 0 r \ {0} := by
+    ext z
+    constructor
+    · rintro ⟨w, hw, rfl⟩
+      refine ⟨?_, ?_⟩
+      · rw [← htarget]
+        exact e.map_source (by rw [hsource]; trivial)
+      · change e w ≠ 0
+        intro h
+        exact hw (hinj (h.trans hzero.symm))
+    · rintro ⟨hz, hne⟩
+      have hzt : z ∈ e.target := by rwa [htarget]
+      refine ⟨e.symm z, ?_, e.right_inv hzt⟩
+      change e.symm z ≠ 0
+      intro h
+      have he := e.right_inv hzt
+      rw [h, hzero] at he
+      exact hne he.symm
+  have hconn : IsPathConnected ({0}ᶜ : Set ℂ) :=
+    isPathConnected_compl_singleton_of_one_lt_rank (by simp) 0
+  have him := hconn.image (OpenPartialHomeomorph.continuous_univBall (0 : ℂ) r)
+  change IsPathConnected (e '' ({0}ᶜ : Set ℂ)) at him
+  rwa [himage] at him
+
+private theorem SpecialPeriods.Threefold.regularPatch_isPathConnected :
+    IsPathConnected (regularPatch : Set SpecialPeriods.TriangleCompactifiedOrbitSpace) := by
+  rw [← regularInclusion_range]
+  exact isPathConnected_range regularInclusion_isOpenEmbedding.continuous
+
+private theorem SpecialPeriods.Threefold.BaseCover.fillingPatch_isPathConnected
+    (C : SpecialPeriods.Threefold.BaseCover) (i : SpecialPeriods.Threefold.Puncture) :
+    IsPathConnected (C.fillingPatch i : Set SpecialPeriods.TriangleCompactifiedOrbitSpace) := by
+  rw [C.fillingPatch_eq_inverse_image i]
+  exact
+    (Metric.isPathConnected_ball (C.radius_pos i)).image'
+      ((SpecialPeriods.Threefold.punctureChart i).continuousOn_symm.mono
+        (C.coordinateBall_subset_target i))
+
+private theorem SpecialPeriods.Threefold.BaseCover.regular_inter_fillingPatch_eq_image
+    (C : SpecialPeriods.Threefold.BaseCover) (i : SpecialPeriods.Threefold.Puncture) :
+    (SpecialPeriods.Threefold.regularPatch : Set SpecialPeriods.TriangleCompactifiedOrbitSpace) ∩
+        C.fillingPatch i =
+      (SpecialPeriods.Threefold.punctureChart i).symm '' (Metric.ball 0 (C.radius i) \ {0}) := by
+  ext x
+  constructor
+  · rintro ⟨hr, hx⟩
+    refine
+      ⟨SpecialPeriods.Threefold.punctureChart i x, ⟨?_, ?_⟩,
+        (SpecialPeriods.Threefold.punctureChart i).left_inv (C.fillingPatch_subset_chart i hx)⟩
+    · simpa only [Metric.mem_ball, dist_zero_right] using ((C.mem_fillingPatch i x).mp hx).2
+    · exact (C.fillingPatch_regular_iff_coordinate_ne_zero i hx).mp hr
+  · rintro ⟨z, ⟨hz, hne⟩, rfl⟩
+    exact ⟨(C.inverse_mem_regular_iff i hz).mpr hne, C.inverse_mem_fillingPatch i hz⟩
+
+private theorem SpecialPeriods.Threefold.BaseCover.regular_inter_fillingPatch_isPathConnected
+    (C : SpecialPeriods.Threefold.BaseCover) (i : SpecialPeriods.Threefold.Puncture) :
+    IsPathConnected
+      ((SpecialPeriods.Threefold.regularPatch :
+          Set SpecialPeriods.TriangleCompactifiedOrbitSpace) ∩
+        C.fillingPatch i) := by
+  rw [C.regular_inter_fillingPatch_eq_image i]
+  exact
+    (SpecialPeriods.Threefold.punctured_complex_ball_isPathConnected (C.radius_pos i)).image'
+      ((SpecialPeriods.Threefold.punctureChart i).continuousOn_symm.mono
+        (Set.sdiff_subset.trans (C.coordinateBall_subset_target i)))
+
+private theorem SpecialPeriods.Threefold.BaseCover.patch_isPathConnected
+    (C : SpecialPeriods.Threefold.BaseCover) (i : SpecialPeriods.Threefold.Index) :
+    IsPathConnected (C.patch i : Set SpecialPeriods.TriangleCompactifiedOrbitSpace) := by
+  cases i with
+  | none => exact SpecialPeriods.Threefold.regularPatch_isPathConnected
+  | some i => exact C.fillingPatch_isPathConnected i
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.instLocal1 : LocallyPathConnectedSpace Space :=
+  ChartedSpace.locallyPathConnectedSpace (ℂ × ComplexPlane₂) Space
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.instLocal1 in
+private theorem SpecialPeriods.Threefold.projection_preimage_isPathConnected
+    {s : Set SpecialPeriods.TriangleCompactifiedOrbitSpace} (hsopen : IsOpen s)
+    (hs : IsConnected s) : IsPathConnected (projection ⁻¹' s) :=
+  FibreTopology.isPathConnected_preimage_of_proper_of_connected_fibres projection_proper
+    projection_fibre_isConnected hsopen hs
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.instLocal1 in
+private theorem SpecialPeriods.Threefold.liftedPatch_isPathConnected (i : Index) :
+    IsPathConnected (liftedPatch i : Set Space) :=
+  projection_preimage_isPathConnected (specialBaseCover.patch i).isOpen
+    (specialBaseCover.patch_isPathConnected i).isConnected
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.instLocal1 in
+private theorem SpecialPeriods.Threefold.liftedPatch_regular_inter_isPathConnected (i : Puncture) :
+    IsPathConnected ((liftedPatch Option.none : Set Space) ∩ liftedPatch (Option.some i)) :=
+  projection_preimage_isPathConnected
+    (regularPatch.isOpen.inter (specialBaseCover.fillingPatch i).isOpen)
+    (specialBaseCover.regular_inter_fillingPatch_isPathConnected i).isConnected
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.instLocal1 in
+private theorem SpecialPeriods.Threefold.liftedPatch_regular_inter_nonempty (i : Puncture) :
+    ((liftedPatch Option.none : Set Space) ∩ liftedPatch (Option.some i)).Nonempty :=
+  (liftedPatch_regular_inter_isPathConnected i).nonempty
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.instLocal1 in
+private theorem
+    SpecialPeriods.Threefold.liftedPatch_regular_inter_pathConnectedSpace (i : Puncture) :
+    PathConnectedSpace
+      ↥((liftedPatch Option.none : Set Space) ∩ (liftedPatch (Option.some i) : Set Space)) :=
+  isPathConnected_iff_pathConnectedSpace.mp (liftedPatch_regular_inter_isPathConnected i)
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.instLocal1 in
+private theorem SpecialPeriods.Threefold.liftedFilling_disjoint {i j : Puncture} (hij : i ≠ j) :
+    Disjoint (liftedPatch (Option.some i) : Set Space) (liftedPatch (Option.some j)) := by
+  apply Set.disjoint_left.mpr
+  intro x hi hj
+  exact Set.disjoint_left.mp (specialBaseCover.fillingPatch_disjoint hij) hi hj
+
+attribute [local instance] SpecialPeriods.Threefold.chartedSpace in
+attribute [local instance] SpecialPeriods.Threefold.instLocal1 in
+private theorem SpecialPeriods.Threefold.liftedPatch_iUnion :
+    ⋃ i : Index, (liftedPatch i : Set Space) = Set.univ := by
+  change
+    (⋃ i : Index,
+        projection ⁻¹'
+          (specialBaseCover.patch i : Set SpecialPeriods.TriangleCompactifiedOrbitSpace)) =
+      Set.univ
+  rw [← Set.preimage_iUnion, specialBaseCover.patch_iUnion, Set.preimage_univ]
+
+private def
+    SpecialPeriods.Threefold.partialPatch (s : Finset Puncture) : TopologicalSpace.Opens Space :=
+  liftedPatch Option.none ⊔ ⨆ i ∈ s, liftedPatch (Option.some i)
+
+@[simp]
+private theorem SpecialPeriods.Threefold.mem_partialPatch (s : Finset Puncture) (x : Space) :
+    x ∈ partialPatch s ↔ x ∈ liftedPatch Option.none ∨ ∃ i ∈ s, x ∈ liftedPatch (Option.some i) :=
+  by
+  simp only [partialPatch, TopologicalSpace.Opens.mem_sup, TopologicalSpace.Opens.mem_iSup,
+    exists_prop]
+
+@[simp]
+private theorem
+    SpecialPeriods.Threefold.partialPatch_empty : partialPatch ∅ = liftedPatch Option.none := by
+  apply TopologicalSpace.Opens.ext
+  apply Set.ext
+  intro x
+  change x ∈ partialPatch ∅ ↔ x ∈ liftedPatch Option.none
+  simp only [mem_partialPatch, Finset.notMem_empty, false_and, exists_false, or_false]
+
+private theorem SpecialPeriods.Threefold.regular_le_partialPatch (s : Finset Puncture) :
+    liftedPatch Option.none ≤ partialPatch s := fun x hx => (mem_partialPatch s x).mpr (Or.inl hx)
+
+private theorem
+    SpecialPeriods.Threefold.filling_le_partialPatch {s : Finset Puncture} {i : Puncture}
+    (hi : i ∈ s) : liftedPatch (Option.some i) ≤ partialPatch s := fun x hx =>
+  (mem_partialPatch s x).mpr (Or.inr ⟨i, hi, hx⟩)
+
+private theorem SpecialPeriods.Threefold.partialPatch_mono {s t : Finset Puncture} (hst : s ⊆ t) :
+    partialPatch s ≤ partialPatch t := by
+  intro x hx
+  rcases (mem_partialPatch s x).mp hx with hx | ⟨i, hi, hx⟩
+  · exact regular_le_partialPatch t hx
+  · exact filling_le_partialPatch (hst hi) hx
+
+@[simp]
+private theorem SpecialPeriods.Threefold.partialPatch_insert (s : Finset Puncture) (i : Puncture) :
+    partialPatch (Insert.insert i s) = partialPatch s ⊔ liftedPatch (Option.some i) := by
+  apply TopologicalSpace.Opens.ext
+  apply Set.ext
+  intro x
+  change x ∈ partialPatch (Insert.insert i s) ↔ x ∈ partialPatch s ⊔ liftedPatch (Option.some i)
+  simp only [mem_partialPatch, Finset.mem_insert, TopologicalSpace.Opens.mem_sup]
+  constructor
+  · rintro (hr | ⟨j, hj | hj, hx⟩)
+    · exact Or.inl (Or.inl hr)
+    · subst j
+      exact Or.inr hx
+    · exact Or.inl (Or.inr ⟨j, hj, hx⟩)
+  · rintro ((hr | ⟨j, hj, hx⟩) | hx)
+    · exact Or.inl hr
+    · exact Or.inr ⟨j, Or.inr hj, hx⟩
+    · exact Or.inr ⟨i, Or.inl rfl, hx⟩
+
+private theorem
+    SpecialPeriods.Threefold.partialPatch_le_insert (s : Finset Puncture) (i : Puncture) :
+    partialPatch s ≤ partialPatch (Insert.insert i s) :=
+  partialPatch_mono (Finset.subset_insert i s)
+
+private theorem SpecialPeriods.Threefold.filling_le_partialPatch_insert (s : Finset Puncture)
+    (i : Puncture) : liftedPatch (Option.some i) ≤ partialPatch (Insert.insert i s) :=
+  filling_le_partialPatch (Finset.mem_insert_self i s)
+
+@[simp]
+private theorem SpecialPeriods.Threefold.partialPatch_univ : partialPatch Finset.univ = ⊤ := by
+  apply top_unique
+  intro x _
+  have hx : x ∈ ⋃ j : Index, (liftedPatch j : Set Space) := by
+    rw [liftedPatch_iUnion]
+    trivial
+  obtain ⟨j, hj⟩ := Set.mem_iUnion.mp hx
+  cases j with
+  | none => exact regular_le_partialPatch _ hj
+  | some i => exact filling_le_partialPatch (Finset.mem_univ i) hj
+
+private theorem SpecialPeriods.Threefold.partialPatch_inter_filling_eq (s : Finset Puncture)
+    (i : Puncture) (hi : i ∉ s) :
+    (partialPatch s : Set Space) ∩ liftedPatch (Option.some i) =
+      (liftedPatch Option.none : Set Space) ∩ liftedPatch (Option.some i) := by
+  ext x
+  constructor
+  · rintro ⟨hx, hxi⟩
+    rcases (mem_partialPatch s x).mp hx with hr | ⟨j, hj, hxj⟩
+    · exact ⟨hr, hxi⟩
+    · have hji : j ≠ i := fun h => hi (h ▸ hj)
+      exact (Set.disjoint_left.mp (liftedFilling_disjoint hji) hxj hxi).elim
+  · rintro ⟨hr, hxi⟩
+    exact ⟨regular_le_partialPatch s hr, hxi⟩
+
+private theorem SpecialPeriods.Threefold.partialPatch_isPathConnected (s : Finset Puncture) :
+    IsPathConnected (partialPatch s : Set Space) := by
+  induction s using Finset.induction_on with
+  | empty =>
+    rw [partialPatch_empty]
+    exact liftedPatch_isPathConnected Option.none
+  | @insert i s _ ih =>
+    rw [partialPatch_insert, TopologicalSpace.Opens.coe_sup]
+    apply ih.union (liftedPatch_isPathConnected (Option.some i))
+    obtain ⟨x, hr, hi⟩ := liftedPatch_regular_inter_nonempty i
+    exact ⟨x, regular_le_partialPatch s hr, hi⟩
+
+private theorem SpecialPeriods.Threefold.partialPatch_pathConnectedSpace (s : Finset Puncture) :
+    PathConnectedSpace (partialPatch s) :=
+  isPathConnected_iff_pathConnectedSpace.mp (partialPatch_isPathConnected s)
+
+private def SpecialPeriods.Threefold.attachmentPoint (i : Puncture) : Space :=
+  (liftedPatch_regular_inter_nonempty i).choose
+
+private theorem SpecialPeriods.Threefold.attachmentPoint_mem_regular (i : Puncture) :
+    attachmentPoint i ∈ liftedPatch Option.none :=
+  (liftedPatch_regular_inter_nonempty i).choose_spec.1
+
+private theorem SpecialPeriods.Threefold.attachmentPoint_mem_filling (i : Puncture) :
+    attachmentPoint i ∈ liftedPatch (Option.some i) :=
+  (liftedPatch_regular_inter_nonempty i).choose_spec.2
+
+private theorem SpecialPeriods.Threefold.attachmentPoint_mem_partialPatch (s : Finset Puncture)
+    (i : Puncture) : attachmentPoint i ∈ partialPatch s :=
+  regular_le_partialPatch s (attachmentPoint_mem_regular i)
+
+private def SpecialPeriods.Threefold.subspacePreimageHomeomorph {X : Type*} [TopologicalSpace X]
+    {A B : Set X} (hBA : B ⊆ A) : ((Subtype.val : A → X) ⁻¹' B) ≃ₜ B
+    where
+  toFun x := ⟨x.val.val, x.property⟩
+  invFun x := ⟨⟨x.val, hBA x.property⟩, x.property⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := (continuous_subtype_val.comp continuous_subtype_val).subtype_mk _
+  continuous_invFun := (continuous_subtype_val.subtype_mk _).subtype_mk _
+
+private def
+    SpecialPeriods.Threefold.subspacePreimageInterHomeomorph {X : Type*} [TopologicalSpace X]
+    {A B C : Set X} (hBC : B ∩ C ⊆ A) :
+    ↥(((Subtype.val : A → X) ⁻¹' B) ∩ ((Subtype.val : A → X) ⁻¹' C)) ≃ₜ ↥(B ∩ C) :=
+  subspacePreimageHomeomorph hBC
+
+private def SpecialPeriods.Threefold.attachmentLeft (s : Finset Puncture) (i : Puncture) :
+    TopologicalSpace.Opens (partialPatch (Insert.insert i s)) :=
+  TopologicalSpace.Opens.comap ⟨Subtype.val, continuous_subtype_val⟩ (partialPatch s)
+
+private def SpecialPeriods.Threefold.attachmentRight (s : Finset Puncture) (i : Puncture) :
+    TopologicalSpace.Opens (partialPatch (Insert.insert i s)) :=
+  TopologicalSpace.Opens.comap ⟨Subtype.val, continuous_subtype_val⟩ (liftedPatch (Option.some i))
+
+private def SpecialPeriods.Threefold.attachmentBase (s : Finset Puncture) (i : Puncture) :
+    partialPatch (Insert.insert i s) :=
+  ⟨attachmentPoint i, attachmentPoint_mem_partialPatch (Insert.insert i s) i⟩
+
+private theorem
+    SpecialPeriods.Threefold.attachmentLeft_union_right (s : Finset Puncture) (i : Puncture) :
+    (attachmentLeft s i : Set (partialPatch (Insert.insert i s))) ∪ attachmentRight s i =
+      Set.univ := by
+  apply Set.eq_univ_of_forall
+  intro x
+  change (x : Space) ∈ partialPatch s ∨ (x : Space) ∈ liftedPatch (Option.some i)
+  exact (le_of_eq (partialPatch_insert s i)) x.property
+
+private theorem SpecialPeriods.Threefold.attachmentLeft_isPathConnected (s : Finset Puncture)
+    (i : Puncture) :
+    IsPathConnected (attachmentLeft s i : Set (partialPatch (Insert.insert i s))) :=
+  (partialPatch_isPathConnected s).preimage_coe (partialPatch_le_insert s i)
+
+private theorem SpecialPeriods.Threefold.attachmentRight_isPathConnected (s : Finset Puncture)
+    (i : Puncture) :
+    IsPathConnected (attachmentRight s i : Set (partialPatch (Insert.insert i s))) :=
+  (liftedPatch_isPathConnected (Option.some i)).preimage_coe (filling_le_partialPatch_insert s i)
+
+private theorem
+    SpecialPeriods.Threefold.attachment_intersection_eq (s : Finset Puncture) (i : Puncture)
+    (hi : i ∉ s) :
+    (attachmentLeft s i : Set (partialPatch (Insert.insert i s))) ∩ attachmentRight s i =
+      (Subtype.val : partialPatch (Insert.insert i s) → Space) ⁻¹'
+        ((liftedPatch Option.none : Set Space) ∩ liftedPatch (Option.some i)) := by
+  change
+    (Subtype.val : partialPatch (Insert.insert i s) → Space) ⁻¹' (partialPatch s : Set Space) ∩
+        (Subtype.val : partialPatch (Insert.insert i s) → Space) ⁻¹'
+          (liftedPatch (Option.some i) : Set Space) =
+      _
+  rw [← Set.preimage_inter, partialPatch_inter_filling_eq s i hi]
+
+private theorem
+    SpecialPeriods.Threefold.attachmentIntersection_isPathConnected (s : Finset Puncture)
+    (i : Puncture) (hi : i ∉ s) :
+    IsPathConnected
+      ((attachmentLeft s i : Set (partialPatch (Insert.insert i s))) ∩ attachmentRight s i) := by
+  rw [attachment_intersection_eq s i hi]
+  exact
+    (liftedPatch_regular_inter_isPathConnected i).preimage_coe
+      (fun _ hx => regular_le_partialPatch (Insert.insert i s) hx.1)
+
+private def
+    SpecialPeriods.Threefold.attachmentCover (s : Finset Puncture) (i : Puncture) (hi : i ∉ s) :
+    FundamentalGroupVanKampen.TwoOpenCover (partialPatch (Insert.insert i s))
+    where
+  U := attachmentLeft s i
+  V := attachmentRight s i
+  cover := attachmentLeft_union_right s i
+  pathConnectedU := attachmentLeft_isPathConnected s i
+  pathConnectedV := attachmentRight_isPathConnected s i
+  pathConnectedIntersection := attachmentIntersection_isPathConnected s i hi
+  base := attachmentBase s i
+  baseU := attachmentPoint_mem_partialPatch s i
+  baseV := attachmentPoint_mem_filling i
+
+private def SpecialPeriods.Threefold.attachmentLeftHomeomorph (s : Finset Puncture) (i : Puncture)
+    (hi : i ∉ s) : (attachmentCover s i hi).U ≃ₜ partialPatch s :=
+  subspacePreimageHomeomorph (partialPatch_le_insert s i)
+
+private def SpecialPeriods.Threefold.attachmentRightHomeomorph (s : Finset Puncture) (i : Puncture)
+    (hi : i ∉ s) : (attachmentCover s i hi).V ≃ₜ liftedPatch (Option.some i) :=
+  subspacePreimageHomeomorph (filling_le_partialPatch_insert s i)
+
+private def
+    SpecialPeriods.Threefold.attachmentOverlapHomeomorph (s : Finset Puncture) (i : Puncture)
+    (hi : i ∉ s) :
+    (attachmentCover s i hi).overlap ≃ₜ
+      ((liftedPatch Option.none : Set Space) ∩ liftedPatch (Option.some i) : Set Space) :=
+  (subspacePreimageInterHomeomorph (fun _ hx => partialPatch_le_insert s i hx.1)).trans
+    (Homeomorph.setCongr (partialPatch_inter_filling_eq s i hi))
+
+private abbrev SpecialPeriods.Threefold.AttachmentGroup (s : Finset Puncture) (i : Puncture) :=
+  FundamentalGroup (partialPatch (Insert.insert i s)) (attachmentBase s i)
+
+private abbrev SpecialPeriods.Threefold.PreviousStageGroup (s : Finset Puncture) (i : Puncture) :=
+  FundamentalGroup (partialPatch s) ⟨attachmentPoint i, attachmentPoint_mem_partialPatch s i⟩
+
+private abbrev SpecialPeriods.Threefold.FillingGroup (i : Puncture) :=
+  FundamentalGroup (liftedPatch (Option.some i))
+    ⟨attachmentPoint i, attachmentPoint_mem_filling i⟩
+
+private abbrev SpecialPeriods.Threefold.RegularOverlap (i : Puncture) :=
+  ((liftedPatch Option.none : Set Space) ∩ liftedPatch (Option.some i) : Set Space)
+
+private abbrev SpecialPeriods.Threefold.regularOverlapPoint (i : Puncture) : RegularOverlap i :=
+  ⟨attachmentPoint i, attachmentPoint_mem_regular i, attachmentPoint_mem_filling i⟩
+
+private abbrev SpecialPeriods.Threefold.RegularOverlapGroup (i : Puncture) :=
+  FundamentalGroup (RegularOverlap i) (regularOverlapPoint i)
+
+private def SpecialPeriods.Threefold.previousStageInclusion (s : Finset Puncture) (i : Puncture) :
+    C(partialPatch s, partialPatch (Insert.insert i s)) :=
+  ⟨fun x => ⟨x.val, partialPatch_le_insert s i x.property⟩, continuous_subtype_val.subtype_mk _⟩
+
+private def SpecialPeriods.Threefold.overlapFillingInclusion (i : Puncture) :
+    C(RegularOverlap i, liftedPatch (Option.some i)) :=
+  ⟨fun x => ⟨x.val, x.property.2⟩, continuous_subtype_val.subtype_mk _⟩
+
+private def SpecialPeriods.Threefold.previousStageHom (s : Finset Puncture) (i : Puncture) :
+    PreviousStageGroup s i →* AttachmentGroup s i :=
+  FundamentalGroup.map (previousStageInclusion s i)
+    ⟨attachmentPoint i, attachmentPoint_mem_partialPatch s i⟩
+
+private def SpecialPeriods.Threefold.overlapFillingHom (i : Puncture) :
+    RegularOverlapGroup i →* FillingGroup i :=
+  FundamentalGroup.map (overlapFillingInclusion i) (regularOverlapPoint i)
+
+private def SpecialPeriods.Threefold.attachmentLeftGroupEquiv (s : Finset Puncture) (i : Puncture)
+    (hi : i ∉ s) : (attachmentCover s i hi).UGroup ≃* PreviousStageGroup s i :=
+  homeomorphFundamentalGroupEquiv (attachmentLeftHomeomorph s i hi)
+    (attachmentCover s i hi).baseUPoint
+
+private def SpecialPeriods.Threefold.attachmentRightGroupEquiv (s : Finset Puncture) (i : Puncture)
+    (hi : i ∉ s) : (attachmentCover s i hi).VGroup ≃* FillingGroup i :=
+  homeomorphFundamentalGroupEquiv (attachmentRightHomeomorph s i hi)
+    (attachmentCover s i hi).baseVPoint
+
+private def
+    SpecialPeriods.Threefold.attachmentOverlapGroupEquiv (s : Finset Puncture) (i : Puncture)
+    (hi : i ∉ s) : (attachmentCover s i hi).OverlapGroup ≃* RegularOverlapGroup i :=
+  homeomorphFundamentalGroupEquiv (attachmentOverlapHomeomorph s i hi)
+    (attachmentCover s i hi).baseOverlapPoint
+
+private theorem SpecialPeriods.Threefold.attachmentLeftGroupEquiv_inclusion (s : Finset Puncture)
+    (i : Puncture) (hi : i ∉ s) :
+    (previousStageHom s i).comp (attachmentLeftGroupEquiv s i hi).toMonoidHom =
+      (attachmentCover s i hi).inclusionHomU := by
+  ext γ
+  obtain ⟨p⟩ := γ
+  apply congrArg Path.Homotopic.Quotient.mk
+  ext t
+  rfl
+
+private theorem SpecialPeriods.Threefold.attachmentRightGroupEquiv_overlap (s : Finset Puncture)
+    (i : Puncture) (hi : i ∉ s) :
+    (attachmentRightGroupEquiv s i hi).toMonoidHom.comp (attachmentCover s i hi).overlapHomV =
+      (overlapFillingHom i).comp (attachmentOverlapGroupEquiv s i hi).toMonoidHom := by
+  ext γ
+  obtain ⟨p⟩ := γ
+  apply congrArg Path.Homotopic.Quotient.mk
+  ext t
+  rfl
+
+private def
+    SpecialPeriods.Threefold.emptyStageHomeomorph : partialPatch ∅ ≃ₜ liftedPatch Option.none :=
+  Homeomorph.setCongr (by rw [partialPatch_empty])
+
+private def SpecialPeriods.Threefold.fullStageHomeomorph : partialPatch Finset.univ ≃ₜ Space
+    where
+  toFun := Subtype.val
+  invFun x := ⟨x, by rw [partialPatch_univ]; trivial⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := continuous_subtype_val
+  continuous_invFun :=
+    continuous_id.subtype_mk (fun x : Space => by rw [partialPatch_univ]; trivial)
+
+private def SpecialPeriods.Threefold.fullStageFundamentalGroupEquiv (x : partialPatch Finset.univ) :
+    FundamentalGroup (partialPatch Finset.univ) x ≃* FundamentalGroup Space x.val :=
+  homeomorphFundamentalGroupEquiv fullStageHomeomorph x
+
+private def SpecialPeriods.EllipticFilling.specialLocalData (j : Elliptic.Kind) :
+    Elliptic.Equivariant.Data j :=
+  localData SpecialPeriods.specialPeriodMap SpecialPeriods.specialPeriodMap_generator₁
+    SpecialPeriods.specialPeriodMap_generator₂ j
+
+private abbrev SpecialPeriods.EllipticFilling.SpecialFullFilling (j : Elliptic.Kind) :=
+  fillingSpace SpecialPeriods.specialPeriodMap SpecialPeriods.specialPeriodMap_generator₁
+    SpecialPeriods.specialPeriodMap_generator₂ j
+
+@[instance_reducible]
+private def SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace (j : Elliptic.Kind) :
+    ChartedSpace Elliptic.FamilyModel (SpecialFullFilling j) :=
+  fillingChartedSpace SpecialPeriods.specialPeriodMap SpecialPeriods.specialPeriodMap_generator₁
+    SpecialPeriods.specialPeriodMap_generator₂ j
+
+private def SpecialPeriods.EllipticFilling.specialFullFillingProjection (j : Elliptic.Kind) :
+    SpecialFullFilling j → SpecialPeriods.Disc :=
+  fillingProjection SpecialPeriods.specialPeriodMap SpecialPeriods.specialPeriodMap_generator₁
+    SpecialPeriods.specialPeriodMap_generator₂ j
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Threefold/SpecialPeriods9.lean b/LeanPool/HopfProblem/Threefold/SpecialPeriods9.lean
new file mode 100644
index 000000000..bafb0606e
--- /dev/null
+++ b/LeanPool/HopfProblem/Threefold/SpecialPeriods9.lean
@@ -0,0 +1,1067 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Uniformization.SpecialPeriods8
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods3
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import all LeanPool.HopfProblem.Elliptic.Core3
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods7
+import all LeanPool.HopfProblem.Elliptic.Core4
+import all LeanPool.HopfProblem.Foundations.FibreTopology
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods8
+import all LeanPool.HopfProblem.Foundations.TwoOpenTransition
+import all LeanPool.HopfProblem.Elliptic.Core5
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods8
+
+/-!
+# Hopf problem: threefold · special periods 9
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private abbrev SpecialPeriods.EllipticFilling.SpecialCentralSurface (j : Elliptic.Kind) :=
+  Elliptic.Surface j (specialLocalData j).centralPeriod j.twist (Elliptic.mainTwist_admissible j)
+
+private def SpecialPeriods.EllipticFilling.specialCentralInclusion (j : Elliptic.Kind) :
+    SpecialCentralSurface j → SpecialFullFilling j :=
+  (specialLocalData j).centralFibreInclusion j.twist (Elliptic.mainTwist_admissible j)
+
+private theorem SpecialPeriods.EllipticFilling.specialCentralInclusion_isClosedEmbedding
+    (j : Elliptic.Kind) : Topology.IsClosedEmbedding (specialCentralInclusion j) :=
+  (specialLocalData j).centralFibreInclusion_isClosedEmbedding j.twist
+    (Elliptic.mainTwist_admissible j)
+
+private theorem SpecialPeriods.EllipticFilling.specialCentralInclusion_range (j : Elliptic.Kind) :
+    Set.range (specialCentralInclusion j) =
+      specialFullFillingProjection j ⁻¹' { Elliptic.discZero } :=
+  (specialLocalData j).range_centralFibreInclusion j.twist (Elliptic.mainTwist_admissible j)
+
+private def SpecialPeriods.EllipticFilling.specialCentralSurfaceIntoFilling (j : Elliptic.Kind) :
+    ContinuousMap (SpecialCentralSurface j) (SpecialFullFilling j) :=
+  (specialLocalData j).surfaceIntoFilling j.twist (Elliptic.mainTwist_admissible j)
+
+private def SpecialPeriods.EllipticFilling.specialCentralSurfaceRetraction (j : Elliptic.Kind) :
+    ContinuousMap (SpecialFullFilling j) (SpecialCentralSurface j) :=
+  (specialLocalData j).fillingSurfaceRetraction j.twist (Elliptic.mainTwist_admissible j)
+
+private def SpecialPeriods.EllipticFilling.specialCentralSurfaceStrongDeformationRetraction
+    (j : Elliptic.Kind) :
+    (ContinuousMap.id (SpecialFullFilling j)).HomotopyRel
+      ((specialCentralSurfaceIntoFilling j).comp (specialCentralSurfaceRetraction j))
+      (Set.range (specialCentralSurfaceIntoFilling j)) :=
+  (specialLocalData j).fillingSurfaceStrongDeformationRetraction j.twist
+    (Elliptic.mainTwist_admissible j)
+
+private abbrev SpecialPeriods.EllipticFilling.SpecialCentralPeriodTorus (j : Elliptic.Kind) :=
+  (specialLocalData j).centralPeriod.val.Torus
+
+private def SpecialPeriods.EllipticFilling.specialCentralPeriodCover (j : Elliptic.Kind) :
+    C(SpecialCentralPeriodTorus j, SpecialCentralSurface j) :=
+  Elliptic.HigherHomology.periodCover j (specialLocalData j).centralPeriod j.twist
+    (Elliptic.mainTwist_admissible j)
+
+private def
+    SpecialPeriods.EllipticFilling.specialCentralSurfaceHomologyCoordinates (j : Elliptic.Kind)
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (SpecialCentralSurface j) n ≃ₗ[ℤ]
+      (Fin (Elliptic.HigherHomology.ellipticBettiNumber n) → ℤ) :=
+  Elliptic.HigherHomology.surfaceHomologyCoordinates j (specialLocalData j).centralPeriod n
+
+private abbrev SpecialPeriods.Threefold.EllipticGeometry.LocalSpace (j : Elliptic.Kind) :=
+  SpecialPeriods.Threefold.SpecialEllipticPiece j
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private def
+    SpecialPeriods.Threefold.EllipticGeometry.parameter (j : Elliptic.Kind) (x : LocalSpace j) :
+    ℂ :=
+  SpecialPeriods.EllipticFilling.specialFullFillingProjection j x.val
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Threefold.EllipticGeometry.inclusion (j : Elliptic.Kind) :
+    LocalSpace j → SpecialPeriods.Threefold.Space :=
+  SpecialPeriods.Threefold.inclusion (Option.some (Option.some j))
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.Threefold.EllipticGeometry.inclusion_openEmbedding (j : Elliptic.Kind) :
+    Topology.IsOpenEmbedding (SpecialPeriods.Threefold.EllipticGeometry.inclusion j) :=
+  SpecialPeriods.Threefold.inclusion_openEmbedding (Option.some (Option.some j))
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.inclusion_injective (j : Elliptic.Kind) :
+    Function.Injective (SpecialPeriods.Threefold.EllipticGeometry.inclusion j) :=
+  (inclusion_openEmbedding j).injective
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.inclusion_continuous (j : Elliptic.Kind) :
+    Continuous (SpecialPeriods.Threefold.EllipticGeometry.inclusion j) :=
+  (inclusion_openEmbedding j).continuous
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.inclusion_range (j : Elliptic.Kind) :
+    Set.range (SpecialPeriods.Threefold.EllipticGeometry.inclusion j) =
+      SpecialPeriods.Threefold.projection ⁻¹'
+        (SpecialPeriods.Threefold.specialBaseCover.fillingPatch (Option.some j) :
+          Set SpecialPeriods.TriangleCompactifiedOrbitSpace) :=
+  SpecialPeriods.Threefold.inclusion_range (Option.some (Option.some j))
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.EllipticGeometry.projection_inclusion (j : Elliptic.Kind)
+    (x : LocalSpace j) :
+    SpecialPeriods.Threefold.projection
+        (SpecialPeriods.Threefold.EllipticGeometry.inclusion j x) =
+      SpecialPeriods.Threefold.specialEllipticPieceProjectionToBase j x :=
+  SpecialPeriods.Threefold.projection_inclusion (Option.some (Option.some j)) x
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.projection_inclusion_eq_point_iff
+    (j : Elliptic.Kind) (x : LocalSpace j) :
+    SpecialPeriods.Threefold.projection
+          (SpecialPeriods.Threefold.EllipticGeometry.inclusion j x) =
+        SpecialPeriods.Threefold.puncturePoint (Option.some j) ↔
+      parameter j x = 0 := by
+  rw [projection_inclusion]
+  exact
+    SpecialPeriods.Threefold.specialBaseCover.fillingEmbedding_eq_point_iff (Option.some j)
+      (SpecialPeriods.EllipticFilling.pieceCoordinate SpecialPeriods.specialPeriodMap
+        SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+        SpecialPeriods.Threefold.specialBaseCover j x)
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private def
+    SpecialPeriods.Threefold.EllipticGeometry.sphereValue (j : Elliptic.Kind) : RiemannSphere :=
+  SpecialPeriods.Triangle.triangleSphereUniformization
+    (SpecialPeriods.Threefold.puncturePoint (Option.some j))
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.chartedSpace SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.projectionSphere_inclusion_eq_value_iff
+    (j : Elliptic.Kind) (x : LocalSpace j) :
+    SpecialPeriods.Threefold.projectionSphere
+          (SpecialPeriods.Threefold.EllipticGeometry.inclusion j x) =
+        sphereValue j ↔
+      parameter j x = 0 :=
+  SpecialPeriods.Triangle.triangleSphereUniformization.injective.eq_iff.trans
+    (projection_inclusion_eq_point_iff j x)
+
+attribute [local instance] SpecialPeriods.Threefold.space_t2Space in
+@[simp]
+private theorem SpecialPeriods.Threefold.EllipticGeometry.fullProjection_specialCentralInclusion
+    (j : Elliptic.Kind) (x : SpecialPeriods.EllipticFilling.SpecialCentralSurface j) :
+    SpecialPeriods.EllipticFilling.specialFullFillingProjection j
+        (SpecialPeriods.EllipticFilling.specialCentralInclusion j x) =
+      Elliptic.discZero := by
+  have hx := Set.mem_range_self (f := SpecialPeriods.EllipticFilling.specialCentralInclusion j) x
+  rw [SpecialPeriods.EllipticFilling.specialCentralInclusion_range] at hx
+  exact hx
+
+attribute [local instance] SpecialPeriods.Threefold.space_t2Space in
+private def SpecialPeriods.Threefold.EllipticGeometry.pieceCentralInclusion (j : Elliptic.Kind) :
+    SpecialPeriods.EllipticFilling.SpecialCentralSurface j → LocalSpace j := fun x =>
+  ⟨SpecialPeriods.EllipticFilling.specialCentralInclusion j x,
+    by
+    change
+      ‖(SpecialPeriods.EllipticFilling.specialFullFillingProjection j
+              (SpecialPeriods.EllipticFilling.specialCentralInclusion j x) :
+            ℂ)‖ <
+        SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)
+    rw [fullProjection_specialCentralInclusion]
+    change ‖(0 : ℂ)‖ < SpecialPeriods.Threefold.specialBaseCover.radius (Option.some j)
+    simpa only [norm_zero] using
+      SpecialPeriods.Threefold.specialBaseCover.radius_pos (Option.some j)⟩
+
+attribute [local instance] SpecialPeriods.Threefold.space_t2Space in
+@[simp]
+private theorem SpecialPeriods.Threefold.EllipticGeometry.parameter_pieceCentralInclusion
+    (j : Elliptic.Kind) (x : SpecialPeriods.EllipticFilling.SpecialCentralSurface j) :
+    parameter j (pieceCentralInclusion j x) = 0 := by
+  change
+    (SpecialPeriods.EllipticFilling.specialFullFillingProjection j
+          (SpecialPeriods.EllipticFilling.specialCentralInclusion j x) :
+        ℂ) =
+      0
+  rw [fullProjection_specialCentralInclusion]
+  rfl
+
+attribute [local instance] SpecialPeriods.Threefold.space_t2Space in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.pieceCentralInclusion_continuous
+    (j : Elliptic.Kind) : Continuous (pieceCentralInclusion j) :=
+  (SpecialPeriods.EllipticFilling.specialCentralInclusion_isClosedEmbedding
+        j).continuous.subtype_mk
+    _
+
+attribute [local instance] SpecialPeriods.Threefold.space_t2Space in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.pieceCentralInclusion_injective
+    (j : Elliptic.Kind) : Function.Injective (pieceCentralInclusion j) := by
+  intro x y hxy
+  exact
+    (SpecialPeriods.EllipticFilling.specialCentralInclusion_isClosedEmbedding j).injective
+      (congrArg Subtype.val hxy)
+
+attribute [local instance] SpecialPeriods.Threefold.space_t2Space in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.pieceCentralInclusion_range
+    (j : Elliptic.Kind) : Set.range (pieceCentralInclusion j) = parameter j ⁻¹' {0} := by
+  ext x
+  constructor
+  · rintro ⟨a, rfl⟩
+    change
+      (SpecialPeriods.EllipticFilling.specialFullFillingProjection j
+            (SpecialPeriods.EllipticFilling.specialCentralInclusion j a) :
+          ℂ) =
+        0
+    rw [fullProjection_specialCentralInclusion]
+    rfl
+  · intro hx
+    have hm : x.val ∈ Set.range (SpecialPeriods.EllipticFilling.specialCentralInclusion j) := by
+      rw [SpecialPeriods.EllipticFilling.specialCentralInclusion_range]
+      exact Subtype.ext hx
+    obtain ⟨a, ha⟩ := hm
+    exact ⟨a, Subtype.ext ha⟩
+
+attribute [local instance] SpecialPeriods.Threefold.space_t2Space in
+private def SpecialPeriods.Threefold.EllipticGeometry.centralSurfaceInclusion (j : Elliptic.Kind) :
+    SpecialPeriods.EllipticFilling.SpecialCentralSurface j → SpecialPeriods.Threefold.Space :=
+  SpecialPeriods.Threefold.EllipticGeometry.inclusion j ∘ pieceCentralInclusion j
+
+attribute [local instance] SpecialPeriods.Threefold.space_t2Space in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.centralSurfaceInclusion_continuous
+    (j : Elliptic.Kind) : Continuous (centralSurfaceInclusion j) :=
+  (inclusion_continuous j).comp (pieceCentralInclusion_continuous j)
+
+attribute [local instance] SpecialPeriods.Threefold.space_t2Space in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.centralSurfaceInclusion_injective
+    (j : Elliptic.Kind) : Function.Injective (centralSurfaceInclusion j) :=
+  (SpecialPeriods.Threefold.EllipticGeometry.inclusion_injective j).comp
+    (pieceCentralInclusion_injective j)
+
+attribute [local instance] SpecialPeriods.Threefold.space_t2Space in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.centralSurfaceInclusion_isClosedEmbedding
+    (j : Elliptic.Kind) : Topology.IsClosedEmbedding (centralSurfaceInclusion j) :=
+  (centralSurfaceInclusion_continuous j).isClosedEmbedding (centralSurfaceInclusion_injective j)
+
+attribute [local instance] SpecialPeriods.Threefold.space_t2Space in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.centralSurfaceInclusion_isEmbedding
+    (j : Elliptic.Kind) : Topology.IsEmbedding (centralSurfaceInclusion j) :=
+  (centralSurfaceInclusion_isClosedEmbedding j).isEmbedding
+
+attribute [local instance] SpecialPeriods.Threefold.space_t2Space in
+@[simp]
+private theorem SpecialPeriods.Threefold.EllipticGeometry.projectionSphere_centralSurfaceInclusion
+    (j : Elliptic.Kind) (x : SpecialPeriods.EllipticFilling.SpecialCentralSurface j) :
+    SpecialPeriods.Threefold.projectionSphere (centralSurfaceInclusion j x) = sphereValue j :=
+  (projectionSphere_inclusion_eq_value_iff j (pieceCentralInclusion j x)).mpr
+    (parameter_pieceCentralInclusion j x)
+
+attribute [local instance] SpecialPeriods.Threefold.space_t2Space in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.centralSurfaceInclusion_range
+    (j : Elliptic.Kind) :
+    Set.range (centralSurfaceInclusion j) =
+      SpecialPeriods.Threefold.projectionSphere ⁻¹' {sphereValue j} := by
+  ext y
+  constructor
+  · rintro ⟨x, rfl⟩
+    exact projectionSphere_centralSurfaceInclusion j x
+  · intro hy
+    have hyproj :
+      SpecialPeriods.Threefold.projection y =
+        SpecialPeriods.Threefold.puncturePoint (Option.some j) :=
+      SpecialPeriods.Triangle.triangleSphereUniformization.injective hy
+    have hm : y ∈ Set.range (SpecialPeriods.Threefold.EllipticGeometry.inclusion j) := by
+      rw [inclusion_range]
+      change
+        SpecialPeriods.Threefold.projection y ∈
+          SpecialPeriods.Threefold.specialBaseCover.fillingPatch (Option.some j)
+      rw [hyproj]
+      exact SpecialPeriods.Threefold.specialBaseCover.point_mem_fillingPatch (Option.some j)
+    obtain ⟨x, rfl⟩ := hm
+    have hx : x ∈ Set.range (pieceCentralInclusion j) := by
+      rw [pieceCentralInclusion_range]
+      exact (projectionSphere_inclusion_eq_value_iff j x).mp hy
+    obtain ⟨a, rfl⟩ := hx
+    exact ⟨a, rfl⟩
+
+attribute [local instance] SpecialPeriods.Threefold.space_t2Space in
+private def
+    SpecialPeriods.Threefold.EllipticGeometry.centralSurfaceFibreHomeomorph (j : Elliptic.Kind) :
+    SpecialPeriods.EllipticFilling.SpecialCentralSurface j ≃ₜ
+      (SpecialPeriods.Threefold.projectionSphere ⁻¹' {sphereValue j}) :=
+  (centralSurfaceInclusion_isEmbedding j).toHomeomorph.trans
+    (Homeomorph.setCongr (centralSurfaceInclusion_range j))
+
+attribute [local instance] SpecialPeriods.Threefold.space_t2Space in
+private theorem
+    SpecialPeriods.Threefold.EllipticGeometry.centralSurfaceFibreHomeomorph_symm_inclusion
+    (j : Elliptic.Kind) (x : SpecialPeriods.Threefold.projectionSphere ⁻¹' {sphereValue j}) :
+    centralSurfaceInclusion j ((centralSurfaceFibreHomeomorph j).symm x) =
+      (x : SpecialPeriods.Threefold.Space) :=
+  congrArg Subtype.val ((centralSurfaceFibreHomeomorph j).apply_symm_apply x)
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.chartedSpace in
+private abbrev SpecialPeriods.Threefold.EllipticGeometry.pieceFullDomain (j : Elliptic.Kind) :
+    Set (SpecialPeriods.EllipticFilling.SpecialFullFilling j) :=
+  SpecialPeriods.EllipticFilling.pieceDomain SpecialPeriods.specialPeriodMap
+    SpecialPeriods.specialPeriodMap_generator₁ SpecialPeriods.specialPeriodMap_generator₂
+    SpecialPeriods.Threefold.specialBaseCover j
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.chartedSpace in
+private def SpecialPeriods.Threefold.EllipticGeometry.centralSurfaceIntoPiece (j : Elliptic.Kind) :
+    C(SpecialPeriods.EllipticFilling.SpecialCentralSurface j, LocalSpace j) :=
+  ⟨pieceCentralInclusion j, pieceCentralInclusion_continuous j⟩
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.fullCentralSurface_subset_piece
+    (j : Elliptic.Kind) :
+    Set.range (SpecialPeriods.EllipticFilling.specialCentralSurfaceIntoFilling j) ⊆
+      pieceFullDomain j := by
+  rintro _ ⟨a, rfl⟩
+  exact (pieceCentralInclusion j a).property
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.chartedSpace in
+private theorem SpecialPeriods.Threefold.EllipticGeometry.fullCentralHomotopy_preserves_piece
+    (j : Elliptic.Kind) (t : unitInterval)
+    (x : SpecialPeriods.EllipticFilling.SpecialFullFilling j) (hx : x ∈ pieceFullDomain j) :
+    SpecialPeriods.EllipticFilling.specialCentralSurfaceStrongDeformationRetraction j (t, x) ∈
+      pieceFullDomain j :=
+  (Elliptic.fillingRadial_projection_norm_le j j.twist (Elliptic.mainTwist_admissible j) t
+        x).trans_lt
+    hx
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.chartedSpace in
+private def SpecialPeriods.Threefold.EllipticGeometry.pieceSurfaceRetraction (j : Elliptic.Kind) :
+    C(LocalSpace j, SpecialPeriods.EllipticFilling.SpecialCentralSurface j) :=
+  restrictedRetraction (SpecialPeriods.EllipticFilling.specialCentralSurfaceRetraction j)
+    (pieceFullDomain j)
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.chartedSpace in
+@[simp]
+private theorem SpecialPeriods.Threefold.EllipticGeometry.pieceSurfaceRetraction_comp_inclusion
+    (j : Elliptic.Kind) :
+    (pieceSurfaceRetraction j).comp (centralSurfaceIntoPiece j) = ContinuousMap.id _ :=
+  restrictedRetraction_comp_inclusion
+    (SpecialPeriods.EllipticFilling.specialCentralSurfaceIntoFilling j)
+    (SpecialPeriods.EllipticFilling.specialCentralSurfaceRetraction j)
+    ((SpecialPeriods.EllipticFilling.specialLocalData j).fillingSurfaceRetraction_comp_inclusion
+      j.twist (Elliptic.mainTwist_admissible j))
+    (pieceFullDomain j) (fullCentralSurface_subset_piece j)
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.chartedSpace in
+private def SpecialPeriods.Threefold.EllipticGeometry.pieceStrongDeformationRetraction
+    (j : Elliptic.Kind) :
+    (ContinuousMap.id (LocalSpace j)).HomotopyRel
+      ((centralSurfaceIntoPiece j).comp (pieceSurfaceRetraction j))
+      (Set.range (centralSurfaceIntoPiece j)) :=
+  restrictedRetractionHomotopy (SpecialPeriods.EllipticFilling.specialCentralSurfaceIntoFilling j)
+    (SpecialPeriods.EllipticFilling.specialCentralSurfaceRetraction j)
+    (SpecialPeriods.EllipticFilling.specialCentralSurfaceStrongDeformationRetraction j)
+    (pieceFullDomain j) (fullCentralSurface_subset_piece j)
+    (fullCentralHomotopy_preserves_piece j)
+
+attribute [local instance] SpecialPeriods.Threefold.specialEllipticPieceChartedSpace
+    SpecialPeriods.EllipticFilling.specialFullFillingChartedSpace
+    SpecialPeriods.Threefold.chartedSpace in
+private def
+    SpecialPeriods.Threefold.EllipticGeometry.pieceSurfaceHomotopyEquiv (j : Elliptic.Kind) :
+    SpecialPeriods.EllipticFilling.SpecialCentralSurface j ≃ₕ LocalSpace j :=
+  retractionHomotopyEquiv (centralSurfaceIntoPiece j) (pieceSurfaceRetraction j)
+    (pieceSurfaceRetraction_comp_inclusion j) (pieceStrongDeformationRetraction j)
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.cast_id_map_mo1973_23351 {X : Type*}
+    [TopologicalSpace X] {a b : X} (p : Path a b) :
+    (Path.id.map p.continuous).cast p.source.symm p.target.symm = p := by
+  ext t
+  rfl
+
+private structure
+    SpecialPeriods.EllipticAttachingMeridians.LoopSquare {X : Type*} [TopologicalSpace X]
+    {a b : X} (p : Path a a) (q : Path b b) where
+  map : C(unitInterval × unitInterval, X)
+  initial : ∀ u, map (0, u) = p u
+  final : ∀ u, map (1, u) = q u
+  closed : ∀ t, map (t, 0) = map (t, 1)
+
+private def SpecialPeriods.EllipticAttachingMeridians.LoopSquare.ofContinuous {X : Type*}
+    [TopologicalSpace X] {a b : X} {p : Path a a} {q : Path b b}
+    (L : unitInterval × unitInterval → X) (hL : Continuous L) (h₀ : ∀ u, L (0, u) = p u)
+    (h₁ : ∀ u, L (1, u) = q u) (hc : ∀ t, L (t, 0) = L (t, 1)) :
+    SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q
+    where
+  map := ⟨L, hL⟩
+  initial := h₀
+  final := h₁
+  closed := hc
+
+private def
+    SpecialPeriods.EllipticAttachingMeridians.LoopSquare.tail {X : Type*} [TopologicalSpace X]
+    {a b : X} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) : Path a b
+    where
+  toFun t := S.map (t, 0)
+  continuous_toFun := S.map.continuous.comp (continuous_id.prodMk continuous_const)
+  source' := (S.initial 0).trans p.source
+  target' := (S.final 0).trans q.source
+
+private def
+    SpecialPeriods.EllipticAttachingMeridians.LoopSquare.homotopy {X : Type*} [TopologicalSpace X]
+    {a b : X} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) :
+    p.toContinuousMap.Homotopy q.toContinuousMap
+    where
+  toFun := S.map
+  continuous_toFun := S.map.continuous
+  map_zero_left := S.initial
+  map_one_left := S.final
+
+private theorem
+    SpecialPeriods.EllipticAttachingMeridians.LoopSquare.homotopy_evalAt_zero {X : Type*}
+    [TopologicalSpace X] {a b : X} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) :
+    (S.homotopy.evalAt 0).cast p.source.symm q.source.symm = S.tail := by
+  ext t
+  rfl
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.LoopSquare.homotopy_evalAt_one {X : Type*}
+    [TopologicalSpace X] {a b : X} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) :
+    (S.homotopy.evalAt 1).cast p.target.symm q.target.symm = S.tail := by
+  ext t
+  exact (S.closed t).symm
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.LoopSquare.homotopic_boundary {X : Type*}
+    [TopologicalSpace X] {a b : X} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) :
+    (p.trans S.tail).Homotopic (S.tail.trans q) := by
+  have h :=
+    (Path.Homotopic.map_trans_evalAt S.homotopy Path.id).pathCast p.source.symm q.target.symm
+  rw [Path.cast_trans (Path.id.map p.continuous) (S.homotopy.evalAt 1) p.source.symm p.target.symm
+      q.target.symm,
+    Path.cast_trans (S.homotopy.evalAt 0) (Path.id.map q.continuous) p.source.symm q.source.symm
+      q.target.symm,
+    SpecialPeriods.EllipticAttachingMeridians.cast_id_map_mo1973_23351 p,
+    SpecialPeriods.EllipticAttachingMeridians.cast_id_map_mo1973_23351 q, S.homotopy_evalAt_zero,
+    S.homotopy_evalAt_one] at h
+  exact h
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.LoopSquare.homotopic_conjugate {X : Type*}
+    [TopologicalSpace X] {a b : X} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) :
+    p.Homotopic (S.tail.trans (q.trans S.tail.symm)) := by
+  have hcancel : ((p.trans S.tail).trans S.tail.symm).Homotopic p :=
+    (Path.Homotopic.trans_assoc p S.tail S.tail.symm).trans
+      (((Path.Homotopic.refl p).hcomp (Path.Homotopic.trans_symm S.tail)).trans
+        (Path.Homotopic.trans_refl p))
+  exact
+    hcancel.symm.trans
+      ((S.homotopic_boundary.hcomp (Path.Homotopic.refl S.tail.symm)).trans
+        (Path.Homotopic.trans_assoc S.tail q S.tail.symm))
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.LoopSquare.quotient_conjugate {X : Type*}
+    [TopologicalSpace X] {a b : X} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) :
+    Path.Homotopic.Quotient.mk p =
+      (Path.Homotopic.Quotient.mk S.tail).trans
+        ((Path.Homotopic.Quotient.mk q).trans (Path.Homotopic.Quotient.mk S.tail).symm) :=
+  Path.Homotopic.Quotient.eq.mpr S.homotopic_conjugate
+
+private structure SpecialPeriods.EllipticAttachingMeridians.LinearizationControl (f : ℂ → ℂ) where
+  radius : ℝ
+  radius_pos : 0 < radius
+  derivative_ne_zero : deriv f 0 ≠ 0
+  continuousOn : ContinuousOn f (Metric.ball 0 radius)
+  error : ∀ z : ℂ, ‖z‖ < radius → ‖f z - f 0 - deriv f 0 * z‖ ≤ ‖deriv f 0‖ / 2 * ‖z‖
+  image_small : ∀ z : ℂ, ‖z‖ < radius → ‖f z - f 0‖ < 1 / 2
+  linear_small : ∀ z : ℂ, ‖z‖ < radius → ‖deriv f 0 * z‖ < 1 / 2
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.nonempty_linearizationControl {f : ℂ → ℂ}
+    (hf : AnalyticAt ℂ f 0) (hd : deriv f 0 ≠ 0) : Nonempty (LinearizationControl f) := by
+  have hderiv := hf.differentiableAt.hasDerivAt
+  have herr : ∀ᶠ z in 𝓝 (0 : ℂ), ‖f z - f 0 - deriv f 0 * z‖ ≤ ‖deriv f 0‖ / 2 * ‖z‖ := by
+    simpa only [sub_zero, smul_eq_mul, mul_comm] using
+      hderiv.isLittleO.bound (half_pos (norm_pos_iff.mpr hd))
+  have hv : ∀ᶠ z in 𝓝 (0 : ℂ), ‖f z - f 0‖ < 1 / 2 := by
+    have h : ContinuousAt (fun z : ℂ => ‖f z - f 0‖) 0 :=
+      (hf.continuousAt.sub continuousAt_const).norm
+    exact h.eventually (gt_mem_nhds (by simp : ‖f 0 - f 0‖ < (1 / 2 : ℝ)))
+  have hl : ∀ᶠ z in 𝓝 (0 : ℂ), ‖deriv f 0 * z‖ < 1 / 2 := by
+    have h : ContinuousAt (fun z : ℂ => ‖deriv f 0 * z‖) 0 :=
+      (continuousAt_const.mul continuousAt_id).norm
+    exact h.eventually (gt_mem_nhds (by simp : ‖deriv f 0 * (0 : ℂ)‖ < (1 / 2 : ℝ)))
+  obtain ⟨r, hr, hs⟩ :=
+    Metric.eventually_nhds_iff.mp (hf.eventually_continuousAt.and (herr.and (hv.and hl)))
+  refine
+    ⟨{  radius := r
+        radius_pos := hr
+        derivative_ne_zero := hd
+        continuousOn := ?_
+        error := ?_
+        image_small := ?_
+        linear_small := ?_ }⟩
+  · intro z hz
+    exact (hs (by simpa only [Metric.mem_ball] using hz)).1.continuousWithinAt
+  · intro z hz
+    exact (hs (by simpa only [dist_zero_right] using hz)).2.1
+  · intro z hz
+    exact (hs (by simpa only [dist_zero_right] using hz)).2.2.1
+  · intro z hz
+    exact (hs (by simpa only [dist_zero_right] using hz)).2.2.2
+
+private def SpecialPeriods.EllipticAttachingMeridians.analyticLinearizationControl {f : ℂ → ℂ}
+    (hf : AnalyticAt ℂ f 0) (hd : deriv f 0 ≠ 0) : LinearizationControl f :=
+  Classical.choice (nonempty_linearizationControl hf hd)
+
+private def
+    SpecialPeriods.EllipticAttachingMeridians.interpolate (f : ℂ → ℂ) (s : unitInterval) (z : ℂ) :
+    ℂ :=
+  (((1 - (s : ℝ) : ℝ) : ℂ) * f z) + ((s : ℝ) : ℂ) * (f 0 + deriv f 0 * z)
+
+@[simp]
+private theorem SpecialPeriods.EllipticAttachingMeridians.interpolate_zero (f : ℂ → ℂ) (z : ℂ) :
+    interpolate f 0 z = f z := by simp [interpolate]
+
+@[simp]
+private theorem SpecialPeriods.EllipticAttachingMeridians.interpolate_one (f : ℂ → ℂ) (z : ℂ) :
+    interpolate f 1 z = f 0 + deriv f 0 * z := by simp [interpolate]
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.interpolate_sub_linear (f : ℂ → ℂ)
+    (s : unitInterval) (z : ℂ) :
+    interpolate f s z - f 0 - deriv f 0 * z =
+      (((1 - (s : ℝ) : ℝ) : ℂ) * (f z - f 0 - deriv f 0 * z)) := by
+  simp only [interpolate, Complex.ofReal_sub, Complex.ofReal_one]
+  ring
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.interpolate_sub_center (f : ℂ → ℂ)
+    (s : unitInterval) (z : ℂ) :
+    interpolate f s z - f 0 =
+      (((1 - (s : ℝ) : ℝ) : ℂ) * (f z - f 0)) + ((s : ℝ) : ℂ) * (deriv f 0 * z) := by
+  simp only [interpolate, Complex.ofReal_sub, Complex.ofReal_one]
+  ring
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.norm_coe_interval_mo1973_23380
+    (s : unitInterval) : ‖((s : ℝ) : ℂ)‖ = (s : ℝ) := by
+  rw [Complex.norm_real, Real.norm_eq_abs, abs_of_nonneg s.property.1]
+
+public
+theorem SpecialPeriods.EllipticAttachingMeridians.norm_one_sub_coe_interval_mo1973_23381
+    (s : unitInterval) : ‖(((1 - (s : ℝ) : ℝ) : ℂ))‖ = 1 - (s : ℝ) := by
+  rw [Complex.norm_real, Real.norm_eq_abs, abs_of_nonneg (sub_nonneg.mpr s.property.2)]
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.LinearizationControl.interpolate_error
+    {f : ℂ → ℂ} (D : SpecialPeriods.EllipticAttachingMeridians.LinearizationControl f)
+    (s : unitInterval) {z : ℂ} (hz : ‖z‖ < D.radius) :
+    ‖SpecialPeriods.EllipticAttachingMeridians.interpolate f s z - f 0 - deriv f 0 * z‖ ≤
+      ‖deriv f 0‖ / 2 * ‖z‖ := by
+  rw [SpecialPeriods.EllipticAttachingMeridians.interpolate_sub_linear, norm_mul,
+    SpecialPeriods.EllipticAttachingMeridians.norm_one_sub_coe_interval_mo1973_23381]
+  calc
+    (1 - (s : ℝ)) * ‖f z - f 0 - deriv f 0 * z‖ ≤ 1 * ‖f z - f 0 - deriv f 0 * z‖ :=
+      mul_le_mul_of_nonneg_right (by linarith [s.property.1]) (norm_nonneg _)
+    _ ≤ ‖deriv f 0‖ / 2 * ‖z‖ := by simpa only [one_mul] using D.error z hz
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.LinearizationControl.interpolate_ne_center
+    {f : ℂ → ℂ} (D : SpecialPeriods.EllipticAttachingMeridians.LinearizationControl f)
+    (s : unitInterval) {z : ℂ} (hz : ‖z‖ < D.radius) (hz0 : z ≠ 0) :
+    SpecialPeriods.EllipticAttachingMeridians.interpolate f s z ≠ f 0 := by
+  intro h
+  have he := D.interpolate_error s hz
+  rw [h, sub_self, zero_sub, norm_neg, norm_mul] at he
+  have hprod : 0 < ‖deriv f 0‖ * ‖z‖ :=
+    mul_pos (norm_pos_iff.mpr D.derivative_ne_zero) (norm_pos_iff.mpr hz0)
+  nlinarith
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.LinearizationControl.interpolate_norm_le
+    {f : ℂ → ℂ} (D : SpecialPeriods.EllipticAttachingMeridians.LinearizationControl f)
+    (s : unitInterval) {z : ℂ} (hz : ‖z‖ < D.radius) :
+    ‖SpecialPeriods.EllipticAttachingMeridians.interpolate f s z - f 0‖ ≤ 1 / 2 := by
+  rw [SpecialPeriods.EllipticAttachingMeridians.interpolate_sub_center]
+  calc
+    ‖(((1 - (s : ℝ) : ℝ) : ℂ) * (f z - f 0)) + ((s : ℝ) : ℂ) * (deriv f 0 * z)‖ ≤
+        ‖(((1 - (s : ℝ) : ℝ) : ℂ) * (f z - f 0))‖ + ‖((s : ℝ) : ℂ) * (deriv f 0 * z)‖ :=
+      norm_add_le _ _
+    _ = (1 - (s : ℝ)) * ‖f z - f 0‖ + (s : ℝ) * ‖deriv f 0 * z‖ := by
+      rw [norm_mul, norm_mul,
+        SpecialPeriods.EllipticAttachingMeridians.norm_one_sub_coe_interval_mo1973_23381,
+        SpecialPeriods.EllipticAttachingMeridians.norm_coe_interval_mo1973_23380]
+    _ ≤ (1 - (s : ℝ)) * (1 / 2) + (s : ℝ) * (1 / 2) :=
+      (add_le_add
+        (mul_le_mul_of_nonneg_left (D.image_small z hz).le (sub_nonneg.mpr s.property.2))
+        (mul_le_mul_of_nonneg_left (D.linear_small z hz).le s.property.1))
+    _ = 1 / 2 := by ring
+
+private def SpecialPeriods.EllipticAttachingMeridians.center (b : Bool) : ℂ :=
+  if b then 1 else 0
+
+private def SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit (t : unitInterval) : ℂ :=
+  Complex.exp (-(2 * Real.pi : ℂ) * Complex.I * (t : ℝ))
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit_continuous :
+    Continuous clockwiseUnit := by
+  unfold clockwiseUnit
+  fun_prop
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit_ne_zero (t : unitInterval) :
+    clockwiseUnit t ≠ 0 :=
+  Complex.exp_ne_zero _
+
+@[simp]
+private theorem SpecialPeriods.EllipticAttachingMeridians.norm_clockwiseUnit (t : unitInterval) :
+    ‖clockwiseUnit t‖ = 1 := by simp [clockwiseUnit, Complex.norm_exp]
+
+@[simp]
+private theorem
+    SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit_zero : clockwiseUnit 0 = 1 := by
+  simp [clockwiseUnit]
+
+@[simp]
+private theorem
+    SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit_one : clockwiseUnit 1 = 1 := by
+  change Complex.exp (-(2 * Real.pi : ℂ) * Complex.I * (1 : ℝ)) = 1
+  rw [Complex.ofReal_one, mul_one, neg_mul]
+  simpa only [zero_sub, Complex.exp_zero] using Complex.exp_periodic.sub_eq (0 : ℂ)
+
+private def SpecialPeriods.EllipticAttachingMeridians.clockwiseCircle (b : Bool) (A : ℂ)
+    (t : unitInterval) : ℂ :=
+  SpecialPeriods.EllipticAttachingMeridians.center b + A * clockwiseUnit t
+
+private theorem
+    SpecialPeriods.EllipticAttachingMeridians.clockwiseCircle_continuous (b : Bool) (A : ℂ) :
+    Continuous (clockwiseCircle b A) :=
+  continuous_const.add (continuous_const.mul clockwiseUnit_continuous)
+
+@[simp]
+private theorem SpecialPeriods.EllipticAttachingMeridians.clockwiseCircle_zero (b : Bool) (A : ℂ) :
+    clockwiseCircle b A 0 = SpecialPeriods.EllipticAttachingMeridians.center b + A := by
+  simp [clockwiseCircle]
+
+@[simp]
+private theorem SpecialPeriods.EllipticAttachingMeridians.clockwiseCircle_one (b : Bool) (A : ℂ) :
+    clockwiseCircle b A 1 = SpecialPeriods.EllipticAttachingMeridians.center b + A := by
+  simp [clockwiseCircle]
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.center_add_mem_twicePuncturedPlaneDomain
+    (b : Bool) {z : ℂ} (hz : z ≠ 0) (hn : ‖z‖ < 1) :
+    SpecialPeriods.EllipticAttachingMeridians.center b + z ∈
+      SpecialPeriods.Triangle.twicePuncturedPlaneDomain := by
+  have hz₁ : z ≠ 1 := by
+    intro h
+    rw [h, NormOneClass.norm_one] at hn
+    exact (lt_irrefl 1) hn
+  have hzneg : z ≠ -1 := by
+    intro h
+    rw [h, norm_neg, NormOneClass.norm_one] at hn
+    exact (lt_irrefl 1) hn
+  change
+    SpecialPeriods.EllipticAttachingMeridians.center b + z ≠ 0 ∧
+      SpecialPeriods.EllipticAttachingMeridians.center b + z ≠ 1
+  cases b with
+  | false =>
+    simpa only [SpecialPeriods.EllipticAttachingMeridians.center, Bool.false_eq_true, ↓reduceIte,
+      zero_add] using And.intro hz hz₁
+  | true =>
+    change 1 + z ≠ 0 ∧ 1 + z ≠ 1
+    constructor
+    · intro h
+      apply hzneg
+      calc
+        z = (1 + z) - 1 := by ring
+        _ = -1 := by rw [h, zero_sub]
+    · intro h
+      exact hz (add_left_cancel (h.trans (add_zero 1).symm))
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.clockwiseCircle_mem (b : Bool) (A : ℂ)
+    (hA : A ≠ 0) (hAn : ‖A‖ < 1) (t : unitInterval) :
+    clockwiseCircle b A t ∈ SpecialPeriods.Triangle.twicePuncturedPlaneDomain := by
+  apply center_add_mem_twicePuncturedPlaneDomain b
+  · exact mul_ne_zero hA (clockwiseUnit_ne_zero t)
+  · simpa only [norm_mul, norm_clockwiseUnit, mul_one] using hAn
+
+private def
+    SpecialPeriods.EllipticAttachingMeridians.circleBasepoint (b : Bool) (A : ℂ) (hA : A ≠ 0)
+    (hAn : ‖A‖ < 1) : SpecialPeriods.Triangle.TwicePuncturedPlane :=
+  ⟨SpecialPeriods.EllipticAttachingMeridians.center b + A,
+    center_add_mem_twicePuncturedPlaneDomain b hA hAn⟩
+
+private def
+    SpecialPeriods.EllipticAttachingMeridians.clockwiseCirclePath (b : Bool) (A : ℂ) (hA : A ≠ 0)
+    (hAn : ‖A‖ < 1) : Path (circleBasepoint b A hA hAn) (circleBasepoint b A hA hAn)
+    where
+  toFun t := ⟨clockwiseCircle b A t, clockwiseCircle_mem b A hA hAn t⟩
+  continuous_toFun := (clockwiseCircle_continuous b A).subtype_mk _
+  source' := Subtype.ext (clockwiseCircle_zero b A)
+  target' := Subtype.ext (clockwiseCircle_one b A)
+
+private def SpecialPeriods.EllipticAttachingMeridians.anchor (b : Bool) : ℂ :=
+  if b then -(1 / 2) else 1 / 2
+
+private theorem
+    SpecialPeriods.EllipticAttachingMeridians.anchor_ne_zero (b : Bool) : anchor b ≠ 0 := by
+  cases b <;> norm_num [anchor]
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.norm_anchor_lt_one (b : Bool) :
+    ‖anchor b‖ < 1 := by cases b <;> norm_num [anchor, norm_div]
+
+private def SpecialPeriods.EllipticAttachingMeridians.fixedClockwiseMeridian (b : Bool) :
+    Path SpecialPeriods.Triangle.meridianBasepoint SpecialPeriods.Triangle.meridianBasepoint :=
+  (if b then SpecialPeriods.Triangle.positiveMeridianOne
+    else SpecialPeriods.Triangle.positiveMeridianZero).symm
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.positiveTurn_symm_mo1973_23503
+    (t : unitInterval) :
+    Complex.exp ((2 * Real.pi : ℂ) * Complex.I * (unitInterval.symm t : ℝ)) = clockwiseUnit t := by
+  rw [unitInterval.coe_symm_eq]
+  have he :
+    (2 * Real.pi : ℂ) * Complex.I * ((1 - (t : ℝ) : ℝ) : ℂ) =
+      -(2 * Real.pi : ℂ) * Complex.I * (t : ℝ) + 2 * Real.pi * Complex.I := by
+    push_cast
+    ring
+  rw [he, Complex.exp_periodic]
+  rfl
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.fixedClockwiseMeridian_coe (b : Bool)
+    (t : unitInterval) : (fixedClockwiseMeridian b t : ℂ) = clockwiseCircle b (anchor b) t := by
+  cases b with
+  |
+    false =>
+    change (SpecialPeriods.Triangle.positiveMeridianZero (unitInterval.symm t) : ℂ) = _
+    rw [SpecialPeriods.Triangle.positiveMeridianZero_apply, positiveTurn_symm_mo1973_23503]
+    simp [clockwiseCircle, SpecialPeriods.EllipticAttachingMeridians.center, anchor]
+  |
+    true =>
+    change (SpecialPeriods.Triangle.positiveMeridianOne (unitInterval.symm t) : ℂ) = _
+    rw [SpecialPeriods.Triangle.positiveMeridianOne_apply, positiveTurn_symm_mo1973_23503]
+    simp [clockwiseCircle, SpecialPeriods.EllipticAttachingMeridians.center, anchor,
+      sub_eq_add_neg]
+
+private theorem
+    SpecialPeriods.EllipticAttachingMeridians.LinearizationControl.interpolate_mem {f : ℂ → ℂ}
+    (D : SpecialPeriods.EllipticAttachingMeridians.LinearizationControl f) (b : Bool)
+    (hc : f 0 = SpecialPeriods.EllipticAttachingMeridians.center b) (s : unitInterval) {z : ℂ}
+    (hz : ‖z‖ < D.radius) (hz0 : z ≠ 0) :
+    SpecialPeriods.EllipticAttachingMeridians.interpolate f s z ∈
+      SpecialPeriods.Triangle.twicePuncturedPlaneDomain := by
+  have hn : ‖SpecialPeriods.EllipticAttachingMeridians.interpolate f s z - f 0‖ < 1 :=
+    (D.interpolate_norm_le s hz).trans_lt (by norm_num)
+  have hm :=
+    SpecialPeriods.EllipticAttachingMeridians.center_add_mem_twicePuncturedPlaneDomain b
+      (sub_ne_zero.mpr (D.interpolate_ne_center s hz hz0)) hn
+  have he :
+    SpecialPeriods.EllipticAttachingMeridians.center b +
+        (SpecialPeriods.EllipticAttachingMeridians.interpolate f s z - f 0) =
+      SpecialPeriods.EllipticAttachingMeridians.interpolate f s z := by
+    rw [← hc]
+    ring
+  rwa [he] at hm
+
+private theorem
+    SpecialPeriods.EllipticAttachingMeridians.LinearizationControl.parameterCircle_norm_lt
+    {f : ℂ → ℂ} (D : SpecialPeriods.EllipticAttachingMeridians.LinearizationControl f) (A : ℂ)
+    (hAr : ‖A‖ < D.radius) (t : unitInterval) :
+    ‖A * SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit t‖ < D.radius := by
+  simpa only [norm_mul, SpecialPeriods.EllipticAttachingMeridians.norm_clockwiseUnit,
+    mul_one] using hAr
+
+private theorem
+    SpecialPeriods.EllipticAttachingMeridians.LinearizationControl.parameterCircle_ne_zero
+    (A : ℂ) (hA : A ≠ 0) (t : unitInterval) :
+    A * SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit t ≠ 0 :=
+  mul_ne_zero hA (SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit_ne_zero t)
+
+private def SpecialPeriods.EllipticAttachingMeridians.LinearizationControl.analyticCircleBasepoint
+    {f : ℂ → ℂ} (D : SpecialPeriods.EllipticAttachingMeridians.LinearizationControl f) (b : Bool)
+    (hc : f 0 = SpecialPeriods.EllipticAttachingMeridians.center b) (A : ℂ) (hA : A ≠ 0)
+    (hAr : ‖A‖ < D.radius) : SpecialPeriods.Triangle.TwicePuncturedPlane :=
+  ⟨f A, by
+    simpa only [SpecialPeriods.EllipticAttachingMeridians.interpolate_zero] using
+      D.interpolate_mem b hc 0 hAr hA⟩
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.LinearizationControl.analyticCircle_mem
+    {f : ℂ → ℂ} (D : SpecialPeriods.EllipticAttachingMeridians.LinearizationControl f) (b : Bool)
+    (hc : f 0 = SpecialPeriods.EllipticAttachingMeridians.center b) (A : ℂ) (hA : A ≠ 0)
+    (hAr : ‖A‖ < D.radius) (t : unitInterval) :
+    f (A * SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit t) ∈
+      SpecialPeriods.Triangle.twicePuncturedPlaneDomain := by
+  simpa only [SpecialPeriods.EllipticAttachingMeridians.interpolate_zero] using
+    D.interpolate_mem b hc 0 (D.parameterCircle_norm_lt A hAr t) (parameterCircle_ne_zero A hA t)
+
+private theorem
+    SpecialPeriods.EllipticAttachingMeridians.LinearizationControl.analyticCircle_continuous
+    {f : ℂ → ℂ} (D : SpecialPeriods.EllipticAttachingMeridians.LinearizationControl f) (A : ℂ)
+    (hAr : ‖A‖ < D.radius) :
+    Continuous
+      (fun t : unitInterval =>
+        f (A * SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit t)) :=
+  D.continuousOn.comp_continuous
+    (continuous_const.mul SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit_continuous)
+    (fun t => by
+      rw [Metric.mem_ball, dist_zero_right]
+      exact D.parameterCircle_norm_lt A hAr t)
+
+private def
+    SpecialPeriods.EllipticAttachingMeridians.LinearizationControl.analyticCirclePath {f : ℂ → ℂ}
+    (D : SpecialPeriods.EllipticAttachingMeridians.LinearizationControl f) (b : Bool)
+    (hc : f 0 = SpecialPeriods.EllipticAttachingMeridians.center b) (A : ℂ) (hA : A ≠ 0)
+    (hAr : ‖A‖ < D.radius) :
+    Path (D.analyticCircleBasepoint b hc A hA hAr) (D.analyticCircleBasepoint b hc A hA hAr)
+    where
+  toFun
+    t :=
+    ⟨f (A * SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit t),
+      D.analyticCircle_mem b hc A hA hAr t⟩
+  continuous_toFun := (D.analyticCircle_continuous A hAr).subtype_mk _
+  source' := Subtype.ext (by simp [analyticCircleBasepoint])
+  target' := Subtype.ext (by simp [analyticCircleBasepoint])
+
+private theorem
+    SpecialPeriods.EllipticAttachingMeridians.LinearizationControl.linearCoefficient_ne_zero
+    {f : ℂ → ℂ} (D : SpecialPeriods.EllipticAttachingMeridians.LinearizationControl f) (A : ℂ)
+    (hA : A ≠ 0) : deriv f 0 * A ≠ 0 :=
+  mul_ne_zero D.derivative_ne_zero hA
+
+private theorem
+  SpecialPeriods.EllipticAttachingMeridians.LinearizationControl.linearCoefficient_norm_lt_one
+    {f : ℂ → ℂ} (D : SpecialPeriods.EllipticAttachingMeridians.LinearizationControl f) (A : ℂ)
+    (hAr : ‖A‖ < D.radius) : ‖deriv f 0 * A‖ < 1 :=
+  (D.linear_small A hAr).trans (by norm_num)
+
+private def SpecialPeriods.EllipticAttachingMeridians.LinearizationControl.analyticCircleSquare
+    {f : ℂ → ℂ} (D : SpecialPeriods.EllipticAttachingMeridians.LinearizationControl f) (b : Bool)
+    (hc : f 0 = SpecialPeriods.EllipticAttachingMeridians.center b) (A : ℂ) (hA : A ≠ 0)
+    (hAr : ‖A‖ < D.radius) :
+    SpecialPeriods.EllipticAttachingMeridians.LoopSquare (D.analyticCirclePath b hc A hA hAr)
+      (SpecialPeriods.EllipticAttachingMeridians.clockwiseCirclePath b (deriv f 0 * A)
+        (D.linearCoefficient_ne_zero A hA) (D.linearCoefficient_norm_lt_one A hAr)) := by
+  let L : unitInterval × unitInterval → ℂ := fun tu =>
+    SpecialPeriods.EllipticAttachingMeridians.interpolate f tu.1
+      (A * SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit tu.2)
+  have hfc :
+    Continuous
+      (fun tu : unitInterval × unitInterval =>
+        f (A * SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit tu.2)) :=
+    (D.analyticCircle_continuous A hAr).comp continuous_snd
+  have hL : Continuous L := by
+    have ht : Continuous (fun tu : unitInterval × unitInterval => (tu.1 : ℝ)) :=
+      continuous_subtype_val.comp continuous_fst
+    have hu :
+      Continuous
+        (fun tu : unitInterval × unitInterval =>
+          A * SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit tu.2) :=
+      continuous_const.mul
+        (SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit_continuous.comp continuous_snd)
+    exact
+      ((Complex.continuous_ofReal.comp (continuous_const.sub ht)).mul hfc).add
+        ((Complex.continuous_ofReal.comp ht).mul (continuous_const.add (continuous_const.mul hu)))
+  refine
+    SpecialPeriods.EllipticAttachingMeridians.LoopSquare.ofContinuous
+      (fun tu =>
+        ⟨L tu,
+          D.interpolate_mem b hc tu.1 (D.parameterCircle_norm_lt A hAr tu.2)
+            (parameterCircle_ne_zero A hA tu.2)⟩)
+      (hL.subtype_mk _) ?_ ?_ ?_
+  · intro u
+    apply Subtype.ext
+    exact SpecialPeriods.EllipticAttachingMeridians.interpolate_zero f _
+  · intro u
+    apply Subtype.ext
+    change
+      SpecialPeriods.EllipticAttachingMeridians.interpolate f 1
+          (A * SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit u) =
+        SpecialPeriods.EllipticAttachingMeridians.center b +
+          (deriv f 0 * A) * SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit u
+    rw [SpecialPeriods.EllipticAttachingMeridians.interpolate_one, hc, mul_assoc]
+  · intro t
+    apply Subtype.ext
+    change
+      SpecialPeriods.EllipticAttachingMeridians.interpolate f t
+          (A * SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit 0) =
+        SpecialPeriods.EllipticAttachingMeridians.interpolate f t
+          (A * SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit 1)
+    rw [SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit_zero,
+      SpecialPeriods.EllipticAttachingMeridians.clockwiseUnit_one]
+
+private def SpecialPeriods.EllipticAttachingMeridians.coefficientInterpolation (d a : ℂ)
+    (s : unitInterval) : ℂ :=
+  Complex.exp (((1 - (s : ℝ) : ℝ) : ℂ) * Complex.log d + ((s : ℝ) : ℂ) * Complex.log a)
+
+private theorem
+    SpecialPeriods.EllipticAttachingMeridians.coefficientInterpolation_continuous (d a : ℂ) :
+    Continuous (coefficientInterpolation d a) := by
+  unfold coefficientInterpolation
+  exact
+    Complex.continuous_exp.comp
+      (((Complex.continuous_ofReal.comp (continuous_const.sub continuous_subtype_val)).mul
+            continuous_const).add
+        ((Complex.continuous_ofReal.comp continuous_subtype_val).mul continuous_const))
+
+@[simp]
+private theorem SpecialPeriods.EllipticAttachingMeridians.coefficientInterpolation_zero (d a : ℂ)
+    (hd : d ≠ 0) : coefficientInterpolation d a 0 = d := by
+  simpa [coefficientInterpolation] using Complex.exp_log hd
+
+@[simp]
+private theorem SpecialPeriods.EllipticAttachingMeridians.coefficientInterpolation_one (d a : ℂ)
+    (ha : a ≠ 0) : coefficientInterpolation d a 1 = a := by
+  simpa [coefficientInterpolation] using Complex.exp_log ha
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.coefficientInterpolation_ne_zero (d a : ℂ)
+    (s : unitInterval) : coefficientInterpolation d a s ≠ 0 :=
+  Complex.exp_ne_zero _
+
+private theorem
+    SpecialPeriods.EllipticAttachingMeridians.coefficientInterpolation_norm_lt_one (d a : ℂ)
+    (s : unitInterval) (hd : d ≠ 0) (ha : a ≠ 0) (hdnorm : ‖d‖ < 1) (hanorm : ‖a‖ < 1) :
+    ‖coefficientInterpolation d a s‖ < 1 := by
+  have hdlog : Real.log ‖d‖ < 0 := Real.log_neg (norm_pos_iff.mpr hd) hdnorm
+  have halog : Real.log ‖a‖ < 0 := Real.log_neg (norm_pos_iff.mpr ha) hanorm
+  rw [coefficientInterpolation, Complex.norm_exp, Real.exp_lt_one_iff]
+  simp only [Complex.add_re, Complex.mul_re, Complex.ofReal_re, Complex.ofReal_im,
+    MulZeroClass.zero_mul, sub_zero, Complex.log_re]
+  by_cases hs : (s : ℝ) = 0
+  · simpa [hs] using hdlog
+  · exact
+      add_neg_of_nonpos_of_neg
+        (mul_nonpos_of_nonneg_of_nonpos (sub_nonneg.mpr s.property.2) hdlog.le)
+        (mul_neg_of_pos_of_neg (lt_of_le_of_ne s.property.1 (Ne.symm hs)) halog)
+
+private def SpecialPeriods.EllipticAttachingMeridians.clockwiseCircleSquare (b : Bool) (A : ℂ)
+    (hA : A ≠ 0) (hAn : ‖A‖ < 1) :
+    LoopSquare (clockwiseCirclePath b A hA hAn) (fixedClockwiseMeridian b)
+    where
+  map :=
+    { toFun
+        st :=
+        ⟨clockwiseCircle b (coefficientInterpolation A (anchor b) st.1) st.2,
+          clockwiseCircle_mem b _ (coefficientInterpolation_ne_zero A (anchor b) st.1)
+            (coefficientInterpolation_norm_lt_one A (anchor b) st.1 hA (anchor_ne_zero b) hAn
+              (norm_anchor_lt_one b))
+            st.2⟩
+      continuous_toFun :=
+        (continuous_const.add
+              (((coefficientInterpolation_continuous A (anchor b)).comp continuous_fst).mul
+                (clockwiseUnit_continuous.comp continuous_snd))).subtype_mk
+          _ }
+  initial
+    t := by
+    apply Subtype.ext
+    change clockwiseCircle b (coefficientInterpolation A (anchor b) 0) t = clockwiseCircle b A t
+    rw [coefficientInterpolation_zero A (anchor b) hA]
+  final
+    t := by
+    apply Subtype.ext
+    change
+      clockwiseCircle b (coefficientInterpolation A (anchor b) 1) t =
+        (fixedClockwiseMeridian b t : ℂ)
+    rw [coefficientInterpolation_one A (anchor b) (anchor_ne_zero b)]
+    exact (fixedClockwiseMeridian_coe b t).symm
+  closed
+    s := by
+    apply Subtype.ext
+    exact
+      (clockwiseCircle_zero b (coefficientInterpolation A (anchor b) s)).trans
+        (clockwiseCircle_one b (coefficientInterpolation A (anchor b) s)).symm
+
+private def SpecialPeriods.EllipticAttachingMeridians.LoopSquare.postcompose {X : Type*}
+    [TopologicalSpace X] {a b : X} {p : Path a a} {q : Path b b} {Y : Type*} [TopologicalSpace Y]
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) (f : X → Y)
+    (hf : Continuous f) :
+    SpecialPeriods.EllipticAttachingMeridians.LoopSquare (p.map hf) (q.map hf)
+    where
+  map := ⟨fun z => f (S.map z), hf.comp S.map.continuous⟩
+  initial u := congrArg f (S.initial u)
+  final u := congrArg f (S.final u)
+  closed t := congrArg f (S.closed t)
+
+private def
+    SpecialPeriods.EllipticAttachingMeridians.LoopSquare.trans {X : Type*} [TopologicalSpace X]
+    {a b c : X} {p : Path a a} {q : Path b b} {r : Path c c}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q)
+    (T : SpecialPeriods.EllipticAttachingMeridians.LoopSquare q r) :
+    SpecialPeriods.EllipticAttachingMeridians.LoopSquare p r
+    where
+  map := (S.homotopy.trans T.homotopy).toContinuousMap
+  initial := (S.homotopy.trans T.homotopy).map_zero_left
+  final := (S.homotopy.trans T.homotopy).map_one_left
+  closed
+    t := by
+    change (S.homotopy.trans T.homotopy) (t, 0) = (S.homotopy.trans T.homotopy) (t, 1)
+    simp only [ContinuousMap.Homotopy.trans_apply]
+    split_ifs with ht
+    · exact S.closed _
+    · exact T.closed _
+
+private theorem SpecialPeriods.EllipticAttachingMeridians.LoopSquare.homotopic_whisker_conjugate
+    {X : Type*} [TopologicalSpace X] {a b : X} {p : Path a a} {q : Path b b}
+    (S : SpecialPeriods.EllipticAttachingMeridians.LoopSquare p q) (τ : Path b a) :
+    (τ.trans (p.trans τ.symm)).Homotopic
+      ((τ.trans S.tail).trans (q.trans (τ.trans S.tail).symm)) := by
+  apply Path.Homotopic.Quotient.eq.mp
+  simp only [Path.trans_symm, Path.Homotopic.Quotient.mk_trans, Path.Homotopic.Quotient.mk_symm]
+  rw [S.quotient_conjugate]
+  simp only [Path.Homotopic.Quotient.trans_assoc]
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Toric/CuspHoneycombHexagon.lean b/LeanPool/HopfProblem/Toric/CuspHoneycombHexagon.lean
new file mode 100644
index 000000000..471181bb0
--- /dev/null
+++ b/LeanPool/HopfProblem/Toric/CuspHoneycombHexagon.lean
@@ -0,0 +1,2959 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.CuspFibre.CuspPositiveRetraction
+public import LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Foundations.TriangleRegularBaseFundamentalGroup
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.Toric.ToricSpace2
+import all LeanPool.HopfProblem.CuspFibre.CuspPositiveRetraction
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+import all LeanPool.HopfProblem.Elliptic.Core1
+
+/-!
+# Hopf problem: toric · cusp honeycomb hexagon
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def CuspHoneycombPositive.positiveCell (v : Fin 2 → ℤ) :
+    Set CuspPositiveRetraction.PositiveCentralFibre :=
+  {q | (q.1 : ToricSpace.Space) ∈ ToricSpace.rayDivisor v}
+
+private theorem
+    CuspHoneycombPositive.positiveCell_isClosed (v : Fin 2 → ℤ) : IsClosed (positiveCell v) :=
+  (ToricSpace.rayDivisor_isClosed v).preimage (continuous_subtype_val.comp continuous_subtype_val)
+
+private theorem CuspHoneycombPositive.positiveCells_locallyFinite : LocallyFinite positiveCell :=
+  ToricSpace.rayDivisors_locallyFinite.preimage_continuous
+    (continuous_subtype_val.comp continuous_subtype_val)
+
+private theorem CuspHoneycombPositive.iUnion_positiveCell :
+    (⋃ v : Fin 2 → ℤ, positiveCell v) = Set.univ := by
+  apply Set.eq_univ_of_forall
+  intro q
+  have hq : (q.1 : ToricSpace.Space) ∈ ToricSpace.time ⁻¹' {0} := q.2
+  rw [ToricSpace.central_fibre_eq_rayDivisors] at hq
+  obtain ⟨v, hv⟩ := Set.mem_iUnion.mp hq
+  exact Set.mem_iUnion.mpr ⟨v, hv⟩
+
+private def CuspHoneycombPositive.positiveCellComponentHomeomorph (v : Fin 2 → ℤ) :
+    positiveCell v ≃ₜ CuspHoneycombHexagon.PositiveComponent v
+    where
+  toFun q := ⟨⟨q.1.1.1, q.2⟩, q.1.1.2⟩
+  invFun x := ⟨⟨⟨x.1.1, x.2⟩, ToricSpace.time_eq_zero_of_mem_rayDivisor x.1.2⟩, x.1.2⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    apply Continuous.subtype_mk
+    exact continuous_subtype_val.comp (continuous_subtype_val.comp continuous_subtype_val)
+  continuous_invFun := by
+    apply Continuous.subtype_mk
+    apply Continuous.subtype_mk
+    apply Continuous.subtype_mk
+    exact continuous_subtype_val.comp continuous_subtype_val
+
+private abbrev CuspHoneycombPositive.positiveCellZeroHomeomorph :
+    positiveCell 0 ≃ₜ CuspHoneycombHexagon.PositiveE0 :=
+  positiveCellComponentHomeomorph 0
+
+private theorem CuspHoneycombPositive.positiveCentralTranslate_mem_positiveCell
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (u v : Fin 2 → ℤ)
+    (q : CuspPositiveRetraction.PositiveCentralFibre) :
+    CuspCollapse.positiveCentralTranslate C₀ u q ∈ positiveCell v ↔
+      q ∈ positiveCell (v - ToricSpace.cuspVector u) :=
+  ToricSpace.twistedTranslate_mem_rayDivisor (CuspPositive.positiveTwist C₀) u v
+    (q.1 : ToricSpace.Space)
+
+private def CuspHoneycombPositive.positiveE0CellHomeomorph (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) : CuspHoneycombHexagon.PositiveE0 ≃ₜ positiveCell v :=
+  positiveCellZeroHomeomorph.symm.trans
+    ((CuspCollapse.positiveCentralHomeomorph C₀ (-ToricSpace.cuspVector v)).subtype
+      (fun q =>
+        by
+        change
+          q ∈ positiveCell 0 ↔
+            CuspCollapse.positiveCentralTranslate C₀ (-ToricSpace.cuspVector v) q ∈ positiveCell v
+        rw [positiveCentralTranslate_mem_positiveCell, ToricSpace.cuspVector_neg,
+          ToricSpace.cuspVector_cuspVector, neg_neg, sub_self]))
+
+private def
+    CuspHoneycombHexagon.orientedCoordinates (i : Fin 6) (z : ToricCharts.CoordinateSpace 2) :
+    ToricCharts.CoordinateSpace 2 :=
+  if i = 1 ∨ i = 2 ∨ i = 3 then ![z 1, z 0] else z
+
+@[simp]
+private theorem CuspHoneycombHexagon.orientedCoordinates_involutive (i : Fin 6)
+    (z : ToricCharts.CoordinateSpace 2) : orientedCoordinates i (orientedCoordinates i z) = z := by
+  by_cases hi : i = 1 ∨ i = 2 ∨ i = 3
+  · funext j
+    fin_cases j <;> simp [orientedCoordinates, hi]
+  · simp [orientedCoordinates, hi]
+
+private theorem CuspHoneycombHexagon.orientedCoordinates_continuous (i : Fin 6) :
+    Continuous (orientedCoordinates i) := by
+  unfold orientedCoordinates
+  split_ifs
+  · apply continuous_pi
+    intro j
+    fin_cases j
+    · exact continuous_apply 1
+    · exact continuous_apply 0
+  · exact continuous_id
+
+private def CuspHoneycombHexagon.orientedHomeomorph (i : Fin 6) :
+    ToricCharts.CoordinateSpace 2 ≃ₜ ToricCharts.CoordinateSpace 2
+    where
+  toFun := orientedCoordinates i
+  invFun := orientedCoordinates i
+  left_inv := orientedCoordinates_involutive i
+  right_inv := orientedCoordinates_involutive i
+  continuous_toFun := orientedCoordinates_continuous i
+  continuous_invFun := orientedCoordinates_continuous i
+
+private def CuspHoneycombHexagon.firstCoordinate : Fin 6 → Fin 3 :=
+  ![1, 2, 2, 1, 0, 0]
+
+private def CuspHoneycombHexagon.secondCoordinate : Fin 6 → Fin 3 :=
+  ![2, 1, 0, 0, 1, 2]
+
+private theorem CuspHoneycombHexagon.firstCoordinate_vertex (i : Fin 6) :
+    (ToricComponent.zeroTriangle i).vertex (firstCoordinate i) = ToricComponent.hexagonRay i := by
+  fin_cases i <;> decide
+
+private theorem CuspHoneycombHexagon.secondCoordinate_vertex (i : Fin 6) :
+    (ToricComponent.zeroTriangle i).vertex (secondCoordinate i) =
+      ToricComponent.hexagonRay (i + 1) := by fin_cases i <;> decide
+
+private theorem CuspHoneycombHexagon.coordinates_exhaustive (i : Fin 6) (j : Fin 3) :
+    j = ToricComponent.zeroCoordinate i ∨ j = firstCoordinate i ∨ j = secondCoordinate i := by
+  fin_cases i <;> fin_cases j <;> decide
+
+private def CuspHoneycombHexagon.liftCoordinates (i : Fin 6) (z : ToricCharts.CoordinateSpace 2) :
+    ToricCharts.CoordinateSpace 3 :=
+  ToricComponent.insertZero (ToricComponent.zeroCoordinate i) (orientedCoordinates i z)
+
+@[simp]
+private theorem CuspHoneycombHexagon.liftCoordinates_zero (i : Fin 6)
+    (z : ToricCharts.CoordinateSpace 2) :
+    liftCoordinates i z (ToricComponent.zeroCoordinate i) = 0 :=
+  ToricComponent.insertZero_at _ _
+
+@[simp]
+private theorem CuspHoneycombHexagon.liftCoordinates_first (i : Fin 6)
+    (z : ToricCharts.CoordinateSpace 2) : liftCoordinates i z (firstCoordinate i) = z 0 := by
+  fin_cases i <;> rfl
+
+@[simp]
+private theorem CuspHoneycombHexagon.liftCoordinates_second (i : Fin 6)
+    (z : ToricCharts.CoordinateSpace 2) : liftCoordinates i z (secondCoordinate i) = z 1 := by
+  fin_cases i <;> rfl
+
+private theorem CuspHoneycombHexagon.liftCoordinates_table (i : Fin 6)
+    (z : ToricCharts.CoordinateSpace 2) :
+    liftCoordinates i z =
+      ![![0, z 0, z 1], ![0, z 1, z 0], ![z 1, 0, z 0], ![z 1, z 0, 0], ![z 0, z 1, 0],
+          ![z 0, 0, z 1] ]
+        i := by fin_cases i <;> ext j <;> fin_cases j <;> rfl
+
+private theorem CuspHoneycombHexagon.liftCoordinates_vector (i : Fin 6) (a b : ℂ) :
+    liftCoordinates i ![a, b] =
+      ![![0, a, b], ![0, b, a], ![b, 0, a], ![b, a, 0], ![a, b, 0], ![a, 0, b] ] i :=
+  liftCoordinates_table i ![a, b]
+
+private def CuspHoneycombHexagon.chartPoint (i : Fin 6) (z : ToricCharts.CoordinateSpace 2) :
+    ToricSpace.rayDivisor 0 :=
+  ToricComponent.affineInclusion (ToricComponent.zeroChart i) (orientedCoordinates i z)
+
+@[simp]
+private theorem
+    CuspHoneycombHexagon.chartPoint_coe (i : Fin 6) (z : ToricCharts.CoordinateSpace 2) :
+    (chartPoint i z : ToricSpace.Space) =
+      ToricSpace.inclusion (ToricComponent.zeroTriangle i) (liftCoordinates i z) :=
+  rfl
+
+private theorem CuspHoneycombHexagon.chartPoint_openEmbedding (i : Fin 6) :
+    Topology.IsOpenEmbedding (chartPoint i) :=
+  (ToricComponent.affineInclusion_openEmbedding (ToricComponent.zeroChart i)).comp
+    (orientedHomeomorph i).isOpenEmbedding
+
+private theorem CuspHoneycombHexagon.chartPoint_injective (i : Fin 6) :
+    Function.Injective (chartPoint i) :=
+  (chartPoint_openEmbedding i).injective
+
+private theorem
+    CuspHoneycombHexagon.chartPoint_continuous (i : Fin 6) : Continuous (chartPoint i) :=
+  (chartPoint_openEmbedding i).continuous
+
+private theorem CuspHoneycombHexagon.chartPoint_jointly_surjective (x : ToricSpace.rayDivisor 0) :
+    ∃ i z, chartPoint i z = x := by
+  obtain ⟨c, z, hz⟩ := ToricComponent.affineInclusion_jointly_surjective x
+  obtain ⟨i, rfl⟩ := ToricComponent.zeroChart_surjective c
+  refine ⟨i, orientedCoordinates i z, ?_⟩
+  change
+    ToricComponent.affineInclusion (ToricComponent.zeroChart i)
+        (orientedCoordinates i (orientedCoordinates i z)) =
+      x
+  rw [orientedCoordinates_involutive]
+  exact hz
+
+private theorem CuspHoneycombHexagon.chartPoint_eq_iff (i j : Fin 6)
+    (z w : ToricCharts.CoordinateSpace 2) :
+    chartPoint i z = chartPoint j w ↔
+      liftCoordinates i z ∈
+          (ToricFan.Triangle.chartChange (ToricComponent.zeroTriangle i)
+              (ToricComponent.zeroTriangle j)).source ∧
+        ToricFan.Triangle.chartChange (ToricComponent.zeroTriangle i)
+            (ToricComponent.zeroTriangle j) (liftCoordinates i z) =
+          liftCoordinates j w := by
+  rw [Subtype.ext_iff, chartPoint_coe, chartPoint_coe, ToricSpace.inclusion_eq_iff]
+
+private theorem CuspHoneycombHexagon.chartPoint_mem_rayDivisor_iff (i k : Fin 6)
+    (z : ToricCharts.CoordinateSpace 2) :
+    (chartPoint i z : ToricSpace.Space) ∈ ToricSpace.rayDivisor (ToricComponent.hexagonRay k) ↔
+      (k = i ∧ z 0 = 0) ∨ (k = i + 1 ∧ z 1 = 0) := by
+  rw [chartPoint_coe, ToricSpace.mem_rayDivisor_inclusion]
+  constructor
+  · rintro ⟨j, hj, hv⟩
+    rcases coordinates_exhaustive i j with rfl | rfl | rfl
+    · exact
+        (ToricComponent.hexagonRay_ne_zero k
+            ((ToricComponent.zeroTriangle_vertex i).symm.trans hv).symm).elim
+    · exact
+        Or.inl
+          ⟨(ToricComponent.hexagonRay_injective ((firstCoordinate_vertex i).symm.trans hv)).symm,
+            by simpa only [liftCoordinates_first] using hj⟩
+    · exact
+        Or.inr
+          ⟨(ToricComponent.hexagonRay_injective ((secondCoordinate_vertex i).symm.trans hv)).symm,
+            by simpa only [liftCoordinates_second] using hj⟩
+  · rintro (⟨hki, hz⟩ | ⟨hki, hz⟩)
+    · subst k
+      exact ⟨firstCoordinate i, (liftCoordinates_first i z).trans hz, firstCoordinate_vertex i⟩
+    · subst k
+      exact ⟨secondCoordinate i, (liftCoordinates_second i z).trans hz, secondCoordinate_vertex i⟩
+
+private def CuspHoneycombHexagon.nextTransitionMatrix : Fin 6 → Matrix (Fin 3) (Fin 3) ℤ :=
+  ![!![1, 1, 0; 0, -1, 0; 0, 1, 1], !![0, 0, -1; 1, 0, 1; 0, 1, 1],
+    !![0, 0, -1; 1, 0, 1; 0, 1, 1], !![1, 1, 0; 0, -1, 0; 0, 1, 1],
+    !![1, 1, 0; 1, 0, 1; -1, 0, 0], !![1, 1, 0; 1, 0, 1; -1, 0, 0] ]
+
+private theorem CuspHoneycombHexagon.transition_next (i : Fin 6) :
+    ToricFan.Triangle.transition (ToricComponent.zeroTriangle i)
+        (ToricComponent.zeroTriangle (i + 1)) =
+      nextTransitionMatrix i := by fin_cases i <;> decide
+
+private theorem CuspHoneycombHexagon.next_source_iff (i : Fin 6) (a b : ℂ) :
+    liftCoordinates i ![a, b] ∈
+        (ToricFan.Triangle.chartChange (ToricComponent.zeroTriangle i)
+            (ToricComponent.zeroTriangle (i + 1))).source ↔
+      a ≠ 0 := by
+  rw [ToricFan.Triangle.chartChange_source, transition_next, liftCoordinates_vector]
+  fin_cases i <;>
+    norm_num [ToricCharts.domain, nextTransitionMatrix, Fin.forall_fin_succ, Matrix.cons_val_two,
+      Matrix.cons_val_three, Matrix.cons_val_four, Matrix.vecHead, Matrix.vecTail]
+
+private theorem CuspHoneycombHexagon.next_transition (i : Fin 6) (a b : ℂ) :
+    ToricFan.Triangle.chartChange (ToricComponent.zeroTriangle i)
+        (ToricComponent.zeroTriangle (i + 1)) (liftCoordinates i ![a, b]) =
+      liftCoordinates (i + 1) ![a * b, a⁻¹] := by
+  change ToricCharts.monomial (ToricFan.Triangle.transition _ _) _ = _
+  rw [transition_next, liftCoordinates_vector, liftCoordinates_vector]
+  fin_cases i <;> ext j <;> fin_cases j <;>
+    norm_num [ToricCharts.monomial, nextTransitionMatrix, Fin.prod_univ_succ, Fin.add_def,
+      Matrix.cons_val_two, Matrix.cons_val_three, Matrix.cons_val_four, Matrix.vecHead,
+      Matrix.vecTail, mul_comm]
+
+private theorem CuspHoneycombHexagon.chartPoint_next (i : Fin 6) (a b : ℂ) (ha : a ≠ 0) :
+    chartPoint (i + 1) ![a * b, a⁻¹] = chartPoint i ![a, b] := by
+  symm
+  exact
+    (chartPoint_eq_iff i (i + 1) ![a, b] ![a * b, a⁻¹]).mpr
+      ⟨(next_source_iff i a b).mpr ha, next_transition i a b⟩
+
+private theorem CuspHoneycombHexagon.chartPoint_eq_next_iff (i : Fin 6) (a b c d : ℂ) :
+    chartPoint i ![a, b] = chartPoint (i + 1) ![c, d] ↔ a ≠ 0 ∧ c = a * b ∧ d = a⁻¹ := by
+  constructor
+  · intro he
+    have ha := (next_source_iff i a b).mp ((chartPoint_eq_iff i (i + 1) _ _).mp he).1
+    have hw : ![c, d] = ![a * b, a⁻¹] :=
+      chartPoint_injective (i + 1) (he.symm.trans (chartPoint_next i a b ha).symm)
+    exact ⟨ha, congrFun hw 0, congrFun hw 1⟩
+  · rintro ⟨ha, rfl, rfl⟩
+    exact (chartPoint_next i a b ha).symm
+
+private theorem CuspHoneycombHexagon.chartPoint_eq_nonadjacent_nonzero {i j : Fin 6}
+    {z w : ToricCharts.CoordinateSpace 2} (hji : j ≠ i) (hnext : j ≠ i + 1) (hprev : i ≠ j + 1)
+    (he : chartPoint i z = chartPoint j w) : z 0 ≠ 0 ∧ z 1 ≠ 0 := by
+  have hcoe : (chartPoint i z : ToricSpace.Space) = (chartPoint j w : ToricSpace.Space) :=
+    congrArg Subtype.val he
+  constructor
+  · intro hz
+    have hm :
+      (chartPoint j w : ToricSpace.Space) ∈ ToricSpace.rayDivisor (ToricComponent.hexagonRay i) :=
+      by
+      rw [← hcoe]
+      exact (chartPoint_mem_rayDivisor_iff i i z).mpr (Or.inl ⟨rfl, hz⟩)
+    rcases (chartPoint_mem_rayDivisor_iff j i w).mp hm with ⟨hi, _⟩ | ⟨hi, _⟩
+    · exact hji hi.symm
+    · exact hprev hi
+  · intro hz
+    have hm :
+      (chartPoint j w : ToricSpace.Space) ∈
+        ToricSpace.rayDivisor (ToricComponent.hexagonRay (i + 1)) := by
+      rw [← hcoe]
+      exact (chartPoint_mem_rayDivisor_iff i (i + 1) z).mpr (Or.inr ⟨rfl, hz⟩)
+    rcases (chartPoint_mem_rayDivisor_iff j (i + 1) w).mp hm with ⟨hi, _⟩ | ⟨hi, _⟩
+    · exact hnext hi.symm
+    · exact hji (add_right_cancel hi).symm
+
+private def CuspHoneycombHexagon.previousTransitionMatrix : Fin 6 → Matrix (Fin 3) (Fin 3) ℤ :=
+  ![!![0, 0, -1; 1, 0, 1; 0, 1, 1], !![1, 1, 0; 0, -1, 0; 0, 1, 1],
+    !![1, 1, 0; 1, 0, 1; -1, 0, 0], !![1, 1, 0; 1, 0, 1; -1, 0, 0],
+    !![1, 1, 0; 0, -1, 0; 0, 1, 1], !![0, 0, -1; 1, 0, 1; 0, 1, 1] ]
+
+private theorem CuspHoneycombHexagon.transition_previous (i : Fin 6) :
+    ToricFan.Triangle.transition (ToricComponent.zeroTriangle i)
+        (ToricComponent.zeroTriangle (i + 5)) =
+      previousTransitionMatrix i := by fin_cases i <;> decide
+
+private theorem CuspHoneycombHexagon.previous_source_iff (i : Fin 6) (a b : ℂ) :
+    liftCoordinates i ![a, b] ∈
+        (ToricFan.Triangle.chartChange (ToricComponent.zeroTriangle i)
+            (ToricComponent.zeroTriangle (i + 5))).source ↔
+      b ≠ 0 := by
+  rw [ToricFan.Triangle.chartChange_source, transition_previous, liftCoordinates_vector]
+  fin_cases i <;>
+    norm_num [ToricCharts.domain, previousTransitionMatrix, Fin.forall_fin_succ,
+      Matrix.cons_val_two, Matrix.cons_val_three, Matrix.cons_val_four, Matrix.vecHead,
+      Matrix.vecTail]
+
+private theorem CuspHoneycombHexagon.previous_transition (i : Fin 6) (a b : ℂ) :
+    ToricFan.Triangle.chartChange (ToricComponent.zeroTriangle i)
+        (ToricComponent.zeroTriangle (i + 5)) (liftCoordinates i ![a, b]) =
+      liftCoordinates (i + 5) ![b⁻¹, a * b] := by
+  change ToricCharts.monomial (ToricFan.Triangle.transition _ _) _ = _
+  rw [transition_previous, liftCoordinates_vector, liftCoordinates_vector]
+  fin_cases i <;> ext j <;> fin_cases j <;>
+      norm_num [ToricCharts.monomial, previousTransitionMatrix, Fin.prod_univ_succ, Fin.add_def,
+        Matrix.cons_val_two, Matrix.cons_val_three, Matrix.cons_val_four, Matrix.vecHead,
+        Matrix.vecTail, mul_comm] <;>
+    rfl
+
+private theorem CuspHoneycombHexagon.chartPoint_previous (i : Fin 6) (a b : ℂ) (hb : b ≠ 0) :
+    chartPoint (i + 5) ![b⁻¹, a * b] = chartPoint i ![a, b] := by
+  symm
+  exact
+    (chartPoint_eq_iff i (i + 5) ![a, b] ![b⁻¹, a * b]).mpr
+      ⟨(previous_source_iff i a b).mpr hb, previous_transition i a b⟩
+
+private theorem CuspHoneycombHexagon.chartPoint_eq_previous_iff (i : Fin 6) (a b c d : ℂ) :
+    chartPoint i ![a, b] = chartPoint (i + 5) ![c, d] ↔ b ≠ 0 ∧ c = b⁻¹ ∧ d = a * b := by
+  constructor
+  · intro he
+    have hb := (previous_source_iff i a b).mp ((chartPoint_eq_iff i (i + 5) _ _).mp he).1
+    have hw : ![c, d] = ![b⁻¹, a * b] :=
+      chartPoint_injective (i + 5) (he.symm.trans (chartPoint_previous i a b hb).symm)
+    exact ⟨hb, congrFun hw 0, congrFun hw 1⟩
+  · rintro ⟨hb, rfl, rfl⟩
+    exact (chartPoint_previous i a b hb).symm
+
+private theorem CuspHoneycombHexagon.chartPoint_offset_two (i : Fin 6) (a b : ℂ) (ha : a ≠ 0)
+    (hb : b ≠ 0) : chartPoint (i + 2) ![b, (a * b)⁻¹] = chartPoint i ![a, b] := by
+  have hi : (i + 1) + 1 = i + 2 := by rw [add_assoc]; rfl
+  have hm : a * b * a⁻¹ = b := by rw [mul_right_comm, mul_inv_cancel₀ ha, one_mul]
+  simpa only [hi, hm] using
+    (chartPoint_next (i + 1) (a * b) a⁻¹ (mul_ne_zero ha hb)).trans (chartPoint_next i a b ha)
+
+private theorem CuspHoneycombHexagon.chartPoint_offset_three (i : Fin 6) (a b : ℂ) (ha : a ≠ 0)
+    (hb : b ≠ 0) : chartPoint (i + 3) ![a⁻¹, b⁻¹] = chartPoint i ![a, b] := by
+  have hi : (i + 2) + 1 = i + 3 := by rw [add_assoc]; rfl
+  have hm : b * (a * b)⁻¹ = a⁻¹ := by simp [mul_inv_rev, hb]
+  simpa only [hi, hm] using
+    (chartPoint_next (i + 2) b (a * b)⁻¹ hb).trans (chartPoint_offset_two i a b ha hb)
+
+private theorem CuspHoneycombHexagon.chartPoint_offset_four (i : Fin 6) (a b : ℂ) (ha : a ≠ 0)
+    (hb : b ≠ 0) : chartPoint (i + 4) ![(a * b)⁻¹, a] = chartPoint i ![a, b] := by
+  have hi : (i + 3) + 1 = i + 4 := by rw [add_assoc]; rfl
+  have hm : a⁻¹ * b⁻¹ = (a * b)⁻¹ := by simp [mul_inv_rev, mul_comm]
+  simpa only [hi, hm, inv_inv] using
+    (chartPoint_next (i + 3) a⁻¹ b⁻¹ (inv_ne_zero ha)).trans (chartPoint_offset_three i a b ha hb)
+
+private theorem CuspHoneycombHexagon.chartPoint_eq_offset_two_iff (i : Fin 6) (a b c d : ℂ) :
+    chartPoint i ![a, b] = chartPoint (i + 2) ![c, d] ↔ a ≠ 0 ∧ b ≠ 0 ∧ c = b ∧ d = (a * b)⁻¹ := by
+  constructor
+  · intro he
+    obtain ⟨ha, hb⟩ :=
+      chartPoint_eq_nonadjacent_nonzero (by fin_cases i <;> decide : i + 2 ≠ i)
+        (by fin_cases i <;> decide : i + 2 ≠ i + 1) (by fin_cases i <;> decide : i ≠ (i + 2) + 1)
+        he
+    have hw : ![c, d] = ![b, (a * b)⁻¹] :=
+      chartPoint_injective (i + 2) (he.symm.trans (chartPoint_offset_two i a b ha hb).symm)
+    exact ⟨ha, hb, congrFun hw 0, congrFun hw 1⟩
+  · rintro ⟨ha, hb, hc, hd⟩
+    subst c d
+    exact (chartPoint_offset_two i a b ha hb).symm
+
+private theorem CuspHoneycombHexagon.chartPoint_eq_offset_three_iff (i : Fin 6) (a b c d : ℂ) :
+    chartPoint i ![a, b] = chartPoint (i + 3) ![c, d] ↔ a ≠ 0 ∧ b ≠ 0 ∧ c = a⁻¹ ∧ d = b⁻¹ := by
+  constructor
+  · intro he
+    obtain ⟨ha, hb⟩ :=
+      chartPoint_eq_nonadjacent_nonzero (by fin_cases i <;> decide : i + 3 ≠ i)
+        (by fin_cases i <;> decide : i + 3 ≠ i + 1) (by fin_cases i <;> decide : i ≠ (i + 3) + 1)
+        he
+    have hw : ![c, d] = ![a⁻¹, b⁻¹] :=
+      chartPoint_injective (i + 3) (he.symm.trans (chartPoint_offset_three i a b ha hb).symm)
+    exact ⟨ha, hb, congrFun hw 0, congrFun hw 1⟩
+  · rintro ⟨ha, hb, hc, hd⟩
+    subst c d
+    exact (chartPoint_offset_three i a b ha hb).symm
+
+private theorem CuspHoneycombHexagon.chartPoint_eq_offset_four_iff (i : Fin 6) (a b c d : ℂ) :
+    chartPoint i ![a, b] = chartPoint (i + 4) ![c, d] ↔ a ≠ 0 ∧ b ≠ 0 ∧ c = (a * b)⁻¹ ∧ d = a := by
+  constructor
+  · intro he
+    obtain ⟨ha, hb⟩ :=
+      chartPoint_eq_nonadjacent_nonzero (by fin_cases i <;> decide : i + 4 ≠ i)
+        (by fin_cases i <;> decide : i + 4 ≠ i + 1) (by fin_cases i <;> decide : i ≠ (i + 4) + 1)
+        he
+    have hw : ![c, d] = ![(a * b)⁻¹, a] :=
+      chartPoint_injective (i + 4) (he.symm.trans (chartPoint_offset_four i a b ha hb).symm)
+    exact ⟨ha, hb, congrFun hw 0, congrFun hw 1⟩
+  · rintro ⟨ha, hb, hc, hd⟩
+    subst c d
+    exact (chartPoint_offset_four i a b ha hb).symm
+
+private theorem CuspHoneycombHexagon.unitSquare_mul_eq_one_iff {a b : ℝ} (ha : a ∈ Set.Icc 0 1)
+    (hb : b ∈ Set.Icc 0 1) : a * b = 1 ↔ a = 1 ∧ b = 1 := by
+  constructor
+  · intro h
+    have hab : a * b ≤ a := mul_le_of_le_one_right ha.1 hb.2
+    have hba : a * b ≤ b := mul_le_of_le_one_left hb.1 ha.2
+    rw [h] at hab hba
+    exact ⟨le_antisymm ha.2 hab, le_antisymm hb.2 hba⟩
+  · rintro ⟨rfl, rfl⟩
+    exact one_mul 1
+
+private theorem CuspHoneycombHexagon.unitSquare_inv_iff {a b : ℝ} (ha : a ∈ Set.Icc 0 1)
+    (hb : b ∈ Set.Icc 0 1) : ((a : ℂ) ≠ 0 ∧ (b : ℂ) = (a : ℂ)⁻¹) ↔ a = 1 ∧ b = 1 := by
+  constructor
+  · rintro ⟨ha0, hbInv⟩
+    have hC : (a : ℂ) * (b : ℂ) = 1 := by rw [hbInv, mul_inv_cancel₀ ha0]
+    apply (unitSquare_mul_eq_one_iff ha hb).mp
+    exact_mod_cast hC
+  · rintro ⟨rfl, rfl⟩
+    simp
+
+private theorem CuspHoneycombHexagon.unitSquare_inv_mul_iff {a b c : ℝ} (ha : a ∈ Set.Icc 0 1)
+    (hb : b ∈ Set.Icc 0 1) (hc : c ∈ Set.Icc 0 1) :
+    ((a : ℂ) ≠ 0 ∧ (b : ℂ) ≠ 0 ∧ (c : ℂ) = ((a : ℂ) * (b : ℂ))⁻¹) ↔ a = 1 ∧ b = 1 ∧ c = 1 := by
+  constructor
+  · rintro ⟨ha0, hb0, hcInv⟩
+    have hab : a * b ∈ Set.Icc 0 1 :=
+      ⟨mul_nonneg ha.1 hb.1, (mul_le_of_le_one_right ha.1 hb.2).trans ha.2⟩
+    have hmul : a * b = 1 ∧ c = 1 :=
+      (unitSquare_inv_iff hab hc).mp
+        ⟨by simpa only [Complex.ofReal_mul] using mul_ne_zero ha0 hb0, by
+          simpa only [Complex.ofReal_mul] using hcInv⟩
+    obtain ⟨ha1, hb1⟩ := (unitSquare_mul_eq_one_iff ha hb).mp hmul.1
+    exact ⟨ha1, hb1, hmul.2⟩
+  · rintro ⟨rfl, rfl, rfl⟩
+    simp
+
+private theorem
+    CuspHoneycombHexagon.unitSquare_transition_one_iff {a b c d : ℝ} (ha : a ∈ Set.Icc 0 1)
+    (hd : d ∈ Set.Icc 0 1) :
+    ((a : ℂ) ≠ 0 ∧ (c : ℂ) = (a : ℂ) * (b : ℂ) ∧ (d : ℂ) = (a : ℂ)⁻¹) ↔ a = 1 ∧ c = b ∧ d = 1 := by
+  constructor
+  · rintro ⟨ha0, hc, hdInv⟩
+    obtain ⟨ha1, hd1⟩ := (unitSquare_inv_iff ha hd).mp ⟨ha0, hdInv⟩
+    refine ⟨ha1, ?_, hd1⟩
+    exact_mod_cast (show (c : ℂ) = (b : ℂ) by simpa [ha1] using hc)
+  · rintro ⟨rfl, rfl, rfl⟩
+    simp
+
+private theorem
+    CuspHoneycombHexagon.unitSquare_transition_two_iff {a b c d : ℝ} (ha : a ∈ Set.Icc 0 1)
+    (hb : b ∈ Set.Icc 0 1) (hd : d ∈ Set.Icc 0 1) :
+    ((a : ℂ) ≠ 0 ∧ (b : ℂ) ≠ 0 ∧ (c : ℂ) = (b : ℂ) ∧ (d : ℂ) = ((a : ℂ) * (b : ℂ))⁻¹) ↔
+      a = 1 ∧ b = 1 ∧ c = 1 ∧ d = 1 := by
+  constructor
+  · rintro ⟨ha0, hb0, hc, hdInv⟩
+    obtain ⟨ha1, hb1, hd1⟩ := (unitSquare_inv_mul_iff ha hb hd).mp ⟨ha0, hb0, hdInv⟩
+    refine ⟨ha1, hb1, ?_, hd1⟩
+    exact_mod_cast (show (c : ℂ) = 1 by simpa [hb1] using hc)
+  · rintro ⟨rfl, rfl, rfl, rfl⟩
+    simp
+
+private theorem
+    CuspHoneycombHexagon.unitSquare_transition_three_iff {a b c d : ℝ} (ha : a ∈ Set.Icc 0 1)
+    (hb : b ∈ Set.Icc 0 1) (hc : c ∈ Set.Icc 0 1) (hd : d ∈ Set.Icc 0 1) :
+    ((a : ℂ) ≠ 0 ∧ (b : ℂ) ≠ 0 ∧ (c : ℂ) = (a : ℂ)⁻¹ ∧ (d : ℂ) = (b : ℂ)⁻¹) ↔
+      a = 1 ∧ b = 1 ∧ c = 1 ∧ d = 1 := by
+  constructor
+  · rintro ⟨ha0, hb0, hcInv, hdInv⟩
+    obtain ⟨ha1, hc1⟩ := (unitSquare_inv_iff ha hc).mp ⟨ha0, hcInv⟩
+    obtain ⟨hb1, hd1⟩ := (unitSquare_inv_iff hb hd).mp ⟨hb0, hdInv⟩
+    exact ⟨ha1, hb1, hc1, hd1⟩
+  · rintro ⟨rfl, rfl, rfl, rfl⟩
+    simp
+
+private theorem
+    CuspHoneycombHexagon.unitSquare_transition_four_iff {a b c d : ℝ} (ha : a ∈ Set.Icc 0 1)
+    (hb : b ∈ Set.Icc 0 1) (hc : c ∈ Set.Icc 0 1) :
+    ((a : ℂ) ≠ 0 ∧ (b : ℂ) ≠ 0 ∧ (c : ℂ) = ((a : ℂ) * (b : ℂ))⁻¹ ∧ (d : ℂ) = (a : ℂ)) ↔
+      a = 1 ∧ b = 1 ∧ c = 1 ∧ d = 1 := by
+  constructor
+  · rintro ⟨ha0, hb0, hcInv, hd⟩
+    obtain ⟨ha1, hb1, hc1⟩ := (unitSquare_inv_mul_iff ha hb hc).mp ⟨ha0, hb0, hcInv⟩
+    refine ⟨ha1, hb1, hc1, ?_⟩
+    exact_mod_cast (show (d : ℂ) = 1 by simpa [ha1] using hd)
+  · rintro ⟨rfl, rfl, rfl, rfl⟩
+    simp
+
+private theorem
+    CuspHoneycombHexagon.unitSquare_transition_five_iff {a b c d : ℝ} (hb : b ∈ Set.Icc 0 1)
+    (hc : c ∈ Set.Icc 0 1) :
+    ((b : ℂ) ≠ 0 ∧ (c : ℂ) = (b : ℂ)⁻¹ ∧ (d : ℂ) = (a : ℂ) * (b : ℂ)) ↔ b = 1 ∧ c = 1 ∧ d = a := by
+  constructor
+  · rintro ⟨hb0, hcInv, hd⟩
+    obtain ⟨hb1, hc1⟩ := (unitSquare_inv_iff hb hc).mp ⟨hb0, hcInv⟩
+    refine ⟨hb1, hc1, ?_⟩
+    exact_mod_cast (show (d : ℂ) = (a : ℂ) by simpa [hb1] using hd)
+  · rintro ⟨rfl, rfl, rfl⟩
+    simp
+
+private theorem CuspHoneycombHexagon.squareComplexCoordinates_vector (p : Square) :
+    (fun k : Fin 2 => (p.1 k : ℂ)) = ![(p.1 0 : ℂ), (p.1 1 : ℂ)] := by
+  ext k
+  fin_cases k <;> rfl
+
+private theorem CuspHoneycombHexagon.squareComplexCoordinates_injective :
+    Function.Injective (fun p : Square => fun k : Fin 2 => (p.1 k : ℂ)) := by
+  intro p q h
+  apply Subtype.ext
+  funext k
+  exact Complex.ofReal_injective (congrFun h k)
+
+private theorem CuspHoneycombHexagon.chartPoint_square_eq_iff (i j : Fin 6) (p q : Square) :
+    chartPoint i (fun k => (p.1 k : ℂ)) = chartPoint j (fun k => (q.1 k : ℂ)) ↔
+      SquareRel i j p q := by
+  obtain ⟨k, rfl⟩ : ∃ k : Fin 6, j = i + k := ⟨j - i, by rw [add_comm i (j - i), sub_add_cancel]⟩
+  fin_cases k
+  · change
+      chartPoint i (fun k => (p.1 k : ℂ)) = chartPoint (i + 0) (fun k => (q.1 k : ℂ)) ↔
+        SquareRel i (i + 0) p q
+    rw [add_zero, squareRel_self]
+    exact ((chartPoint_injective i).comp squareComplexCoordinates_injective).eq_iff
+  · change
+      chartPoint i (fun k => (p.1 k : ℂ)) = chartPoint (i + 1) (fun k => (q.1 k : ℂ)) ↔
+        SquareRel i (i + 1) p q
+    rw [squareComplexCoordinates_vector p, squareComplexCoordinates_vector q,
+      chartPoint_eq_next_iff, squareRel_next]
+    simpa only [and_assoc, and_comm, and_left_comm] using
+      (unitSquare_transition_one_iff (a := p.1 0) (b := p.1 1) (c := q.1 0) (d := q.1 1) (p.2 0)
+        (q.2 1))
+  · change
+      chartPoint i (fun k => (p.1 k : ℂ)) = chartPoint (i + 2) (fun k => (q.1 k : ℂ)) ↔
+        SquareRel i (i + 2) p q
+    rw [squareComplexCoordinates_vector p, squareComplexCoordinates_vector q,
+      chartPoint_eq_offset_two_iff, squareRel_add_two]
+    simpa only [Fin.forall_fin_two, and_assoc] using
+      (unitSquare_transition_two_iff (a := p.1 0) (b := p.1 1) (c := q.1 0) (d := q.1 1) (p.2 0)
+        (p.2 1) (q.2 1))
+  · change
+      chartPoint i (fun k => (p.1 k : ℂ)) = chartPoint (i + 3) (fun k => (q.1 k : ℂ)) ↔
+        SquareRel i (i + 3) p q
+    rw [squareComplexCoordinates_vector p, squareComplexCoordinates_vector q,
+      chartPoint_eq_offset_three_iff, squareRel_add_three]
+    simpa only [Fin.forall_fin_two, and_assoc] using
+      (unitSquare_transition_three_iff (a := p.1 0) (b := p.1 1) (c := q.1 0) (d := q.1 1) (p.2 0)
+        (p.2 1) (q.2 0) (q.2 1))
+  · change
+      chartPoint i (fun k => (p.1 k : ℂ)) = chartPoint (i + 4) (fun k => (q.1 k : ℂ)) ↔
+        SquareRel i (i + 4) p q
+    rw [squareComplexCoordinates_vector p, squareComplexCoordinates_vector q,
+      chartPoint_eq_offset_four_iff, squareRel_add_four]
+    simpa only [Fin.forall_fin_two, and_assoc] using
+      (unitSquare_transition_four_iff (a := p.1 0) (b := p.1 1) (c := q.1 0) (d := q.1 1) (p.2 0)
+        (p.2 1) (q.2 0))
+  · change
+      chartPoint i (fun k => (p.1 k : ℂ)) = chartPoint (i + 5) (fun k => (q.1 k : ℂ)) ↔
+        SquareRel i (i + 5) p q
+    rw [squareComplexCoordinates_vector p, squareComplexCoordinates_vector q,
+      chartPoint_eq_previous_iff, squareRel_prev]
+    exact unitSquare_transition_five_iff (p.2 1) (q.2 0)
+
+private def CuspQuotient.componentBoundary (v : Fin 2 → ℤ) : Set (ToricSpace.rayDivisor 0) :=
+  {x | (x : ToricSpace.Space) ∈ ToricSpace.rayDivisor v}
+
+private def CuspHoneycombHexagon.orientedSquare (i : Fin 6) (p : Square) : Square :=
+  if i = 1 ∨ i = 2 ∨ i = 3 then ⟨![p.1 1, p.1 0], by intro k; fin_cases k <;> exact p.2 _⟩ else p
+
+@[simp]
+private theorem CuspHoneycombHexagon.orientedSquare_involutive (i : Fin 6) (p : Square) :
+    orientedSquare i (orientedSquare i p) = p := by
+  by_cases hi : i = 1 ∨ i = 2 ∨ i = 3
+  · apply Subtype.ext
+    funext k
+    fin_cases k <;> simp [orientedSquare, hi]
+  · simp [orientedSquare, hi]
+
+private theorem CuspHoneycombHexagon.orientedCoordinates_square (i : Fin 6) (p : Square) :
+    orientedCoordinates i (fun k => (p.1 k : ℂ)) = fun k => ((orientedSquare i p).1 k : ℂ) := by
+  by_cases hi : i = 1 ∨ i = 2 ∨ i = 3
+  · funext k
+    fin_cases k <;> simp [orientedSquare, orientedCoordinates, hi]
+  · simp [orientedSquare, orientedCoordinates, hi]
+
+private def CuspHoneycombHexagon.squarePoint (i : Fin 6) (p : Square) : PositiveE0 :=
+  ⟨chartPoint i (fun k => (p.1 k : ℂ)),
+    by
+    apply (affineInclusion_mem_positive_iff (ToricComponent.zeroChart i) _).mpr
+    rw [orientedCoordinates_square]
+    exact ⟨(orientedSquare i p).1, fun k => ((orientedSquare i p).2 k).1, rfl⟩⟩
+
+@[simp]
+private theorem CuspHoneycombHexagon.squarePoint_coe (i : Fin 6) (p : Square) :
+    (squarePoint i p : ToricSpace.rayDivisor 0) = chartPoint i (fun k => (p.1 k : ℂ)) :=
+  rfl
+
+private theorem
+    CuspHoneycombHexagon.squarePoint_continuous (i : Fin 6) : Continuous (squarePoint i) := by
+  have h : Continuous (fun p : Square => fun k => (p.1 k : ℂ)) :=
+    continuous_pi fun k =>
+      Complex.continuous_ofReal.comp ((continuous_apply k).comp continuous_subtype_val)
+  exact ((chartPoint_continuous i).comp h).subtype_mk _
+
+private theorem CuspHoneycombHexagon.squarePoint_eq_iff (i j : Fin 6) (p q : Square) :
+    squarePoint i p = squarePoint j q ↔ SquareRel i j p q := by
+  rw [← chartPoint_square_eq_iff]
+  exact Subtype.ext_iff
+
+private theorem CuspHoneycombHexagon.squarePoint_jointly_surjective (x : PositiveE0) :
+    ∃ (i : Fin 6) (p : Square), squarePoint i p = x := by
+  obtain ⟨i, r, hr, he⟩ := positiveE0_bounded_chart x
+  let p : Square := ⟨r.1, fun k => ⟨r.2 k, hr k⟩⟩
+  refine ⟨i, orientedSquare i p, Subtype.ext ?_⟩
+  change
+    ToricComponent.affineInclusion (ToricComponent.zeroChart i)
+        (orientedCoordinates i (fun k => ((orientedSquare i p).1 k : ℂ))) =
+      x.1
+  rw [orientedCoordinates_square, orientedSquare_involutive]
+  exact congrArg Subtype.val he
+
+private abbrev CuspHoneycombHexagon.TileSpace :=
+  Fin 6 × Square
+
+private def CuspHoneycombHexagon.squareProjection (p : TileSpace) : PositiveE0 :=
+  squarePoint p.1 p.2
+
+private theorem CuspHoneycombHexagon.squareProjection_continuous : Continuous squareProjection :=
+  continuous_prod_of_discrete_left.mpr squarePoint_continuous
+
+private theorem
+    CuspHoneycombHexagon.squareProjection_surjective : Function.Surjective squareProjection :=
+  by
+  intro x
+  obtain ⟨i, p, hp⟩ := squarePoint_jointly_surjective x
+  exact ⟨(i, p), hp⟩
+
+private def CuspHoneycombHexagon.positiveBoundary (k : Fin 6) : Set PositiveE0 :=
+  Subtype.val ⁻¹' CuspQuotient.componentBoundary (ToricComponent.hexagonRay k)
+
+private theorem
+    CuspHoneycombHexagon.squarePoint_mem_positiveBoundary_iff (i k : Fin 6) (p : Square) :
+    squarePoint i p ∈ positiveBoundary k ↔ (k = i ∧ p.1 0 = 0) ∨ (k = i + 1 ∧ p.1 1 = 0) := by
+  change
+    (chartPoint i (fun j => (p.1 j : ℂ)) : ToricSpace.Space) ∈
+        ToricSpace.rayDivisor (ToricComponent.hexagonRay k) ↔
+      _
+  rw [chartPoint_mem_rayDivisor_iff]
+  simp
+
+private def CuspHoneycombHexagon.polygonProjection (p : TileSpace) : Hexagon :=
+  ⟨tile p.1 p.2, tile_mem_hexagon p.1 p.2⟩
+
+private theorem CuspHoneycombHexagon.polygonProjection_continuous : Continuous polygonProjection :=
+  (continuous_prod_of_discrete_left.mpr tile_continuous).subtype_mk _
+
+private theorem CuspHoneycombHexagon.polygonProjection_surjective :
+    Function.Surjective polygonProjection := by
+  intro x
+  obtain ⟨i, p, hp⟩ := tile_jointly_surjective x
+  exact ⟨(i, p), Subtype.ext hp⟩
+
+private theorem
+    CuspHoneycombHexagon.squareProjection_eq_iff_polygonProjection_eq (a b : TileSpace) :
+    squareProjection a = squareProjection b ↔ polygonProjection a = polygonProjection b := by
+  change squarePoint a.1 a.2 = squarePoint b.1 b.2 ↔ _
+  rw [squarePoint_eq_iff, Subtype.ext_iff]
+  exact (tile_eq_iff a.1 b.1 a.2 b.2).symm
+
+private def CuspHoneycombHexagon.positiveE0HexagonHomeomorph : PositiveE0 ≃ₜ Hexagon :=
+  CommonFibres.homeomorph squareProjection polygonProjection squareProjection_surjective
+    squareProjection_continuous polygonProjection_continuous polygonProjection_surjective
+    squareProjection_eq_iff_polygonProjection_eq
+
+@[simp]
+private theorem
+    CuspHoneycombHexagon.positiveE0HexagonHomeomorph_squarePoint (i : Fin 6) (p : Square) :
+    (positiveE0HexagonHomeomorph (squarePoint i p) : Plane) = tile i p := by
+  exact
+    congrArg Subtype.val
+      (CommonFibres.homeomorph_apply squareProjection polygonProjection
+        squareProjection_surjective squareProjection_continuous polygonProjection_continuous
+        polygonProjection_surjective squareProjection_eq_iff_polygonProjection_eq (i, p))
+
+private theorem CuspHoneycombHexagon.positiveE0HexagonHomeomorph_cornerZero (i : Fin 6) :
+    (positiveE0HexagonHomeomorph (squarePoint i cornerZero) : Plane) = vertex i := by simp
+
+private theorem CuspHoneycombHexagon.squarePoint_cornerZero_coe (i : Fin 6) :
+    ((squarePoint i cornerZero : ToricSpace.rayDivisor 0) : ToricSpace.Space) =
+      ToricSpace.inclusion (ToricComponent.zeroTriangle i) 0 := by
+  rw [squarePoint_coe, chartPoint_coe]
+  congr 1
+  ext k
+  rcases coordinates_exhaustive i k with rfl | rfl | rfl <;> simp [cornerZero]
+
+private theorem CuspHoneycombHexagon.squarePoint_cornerZero_mem_positiveBoundary_iff (i k : Fin 6) :
+    squarePoint i cornerZero ∈ positiveBoundary k ↔ k = i ∨ k = i + 1 := by
+  rw [squarePoint_mem_positiveBoundary_iff]
+  simp [cornerZero]
+
+private theorem CuspHoneycombHexagon.positiveE0HexagonHomeomorph_mem_side_iff (x : PositiveE0)
+    (k : Fin 6) : (positiveE0HexagonHomeomorph x : Plane) ∈ side k ↔ x ∈ positiveBoundary k := by
+  obtain ⟨i, p, rfl⟩ := squarePoint_jointly_surjective x
+  rw [positiveE0HexagonHomeomorph_squarePoint, tile_mem_side_iff,
+    squarePoint_mem_positiveBoundary_iff]
+
+private theorem CuspHoneycombHexagon.positiveE0HexagonHomeomorph_mem_boundary_iff (x : PositiveE0) :
+    (positiveE0HexagonHomeomorph x : Plane) ∈ ⋃ k, side k ↔ x ∈ ⋃ k, positiveBoundary k := by
+  simp only [Set.mem_iUnion]
+  exact exists_congr (fun k => positiveE0HexagonHomeomorph_mem_side_iff x k)
+
+private def CuspHoneycombHexagon.positiveBoundaryHexagonHomeomorph (k : Fin 6) :
+    positiveBoundary k ≃ₜ side k
+    where
+  toFun
+    x :=
+    ⟨(positiveE0HexagonHomeomorph x.1 : Plane),
+      (positiveE0HexagonHomeomorph_mem_side_iff x.1 k).mpr x.2⟩
+  invFun
+    y :=
+    ⟨positiveE0HexagonHomeomorph.symm ⟨y.1, y.2.1⟩,
+      by
+      apply (positiveE0HexagonHomeomorph_mem_side_iff _ k).mp
+      simpa only [Homeomorph.apply_symm_apply] using y.2⟩
+  left_inv x := Subtype.ext (positiveE0HexagonHomeomorph.symm_apply_apply x.1)
+  right_inv
+    y := by
+    apply Subtype.ext
+    change
+      (positiveE0HexagonHomeomorph (positiveE0HexagonHomeomorph.symm ⟨y.1, y.2.1⟩) : Plane) = y.1
+    rw [Homeomorph.apply_symm_apply]
+  continuous_toFun :=
+    (continuous_subtype_val.comp
+          (positiveE0HexagonHomeomorph.continuous.comp continuous_subtype_val)).subtype_mk
+      _
+  continuous_invFun :=
+    (positiveE0HexagonHomeomorph.symm.continuous.comp
+          (continuous_subtype_val.subtype_mk _)).subtype_mk
+      _
+
+private theorem CuspHoneycombHexagon.sideFunctional_continuous (k : Fin 6) :
+    Continuous (sideFunctional k) := by fin_cases k <;> unfold sideFunctional <;> fun_prop
+
+private theorem CuspHoneycombHexagon.sideFunctional_add (k : Fin 6) (x y : Plane) :
+    sideFunctional k (x + y) = sideFunctional k x + sideFunctional k y := by
+  fin_cases k <;> simp [sideFunctional] <;> ring
+
+private theorem CuspHoneycombHexagon.sideFunctional_smul (k : Fin 6) (a : ℝ) (x : Plane) :
+    sideFunctional k (a • x) = a * sideFunctional k x := by
+  fin_cases k <;> simp [sideFunctional] <;> ring
+
+private theorem CuspHoneycombHexagon.mem_hexagon_iff_sideFunctional_le (x : Plane) :
+    x ∈ Hexagon ↔ ∀ k : Fin 6, sideFunctional k x ≤ 1 := by
+  constructor
+  · rintro ⟨hx, hy, hxy⟩ k
+    have hx' := abs_le.mp hx
+    have hy' := abs_le.mp hy
+    have hxy' := abs_le.mp hxy
+    fin_cases k
+    · exact hx'.2
+    · exact hxy'.2
+    · exact hy'.2
+    · change -x 0 ≤ 1
+      linarith [hx'.1]
+    · change -x 0 - x 1 ≤ 1
+      linarith [hxy'.1]
+    · change -x 1 ≤ 1
+      linarith [hy'.1]
+  · intro h
+    have h0 := h 0
+    have h1 := h 1
+    have h2 := h 2
+    have h3 := h 3
+    have h4 := h 4
+    have h5 := h 5
+    simp only [sideFunctional_zero, sideFunctional_one, sideFunctional_two, sideFunctional_three,
+      sideFunctional_four, sideFunctional_five] at h0 h1 h2 h3 h4 h5
+    exact
+      ⟨abs_le.mpr ⟨by linarith, h0⟩, abs_le.mpr ⟨by linarith, h2⟩, abs_le.mpr ⟨by linarith, h1⟩⟩
+
+private theorem CuspHoneycombHexagon.hexagon_convex : Convex ℝ Hexagon := by
+  intro x hx y hy a b ha hb hab
+  apply (mem_hexagon_iff_sideFunctional_le _).mpr
+  intro k
+  rw [sideFunctional_add, sideFunctional_smul, sideFunctional_smul]
+  calc
+    a * sideFunctional k x + b * sideFunctional k y ≤ a * 1 + b * 1 :=
+      add_le_add (mul_le_mul_of_nonneg_left ((mem_hexagon_iff_sideFunctional_le x).mp hx k) ha)
+        (mul_le_mul_of_nonneg_left ((mem_hexagon_iff_sideFunctional_le y).mp hy k) hb)
+    _ = 1 := by simpa only [mul_one] using hab
+
+private theorem CuspHoneycombHexagon.hexagon_isClosed : IsClosed Hexagon := by
+  have he : Hexagon = ⋂ k : Fin 6, {x | sideFunctional k x ≤ 1} := by
+    ext x
+    simp only [Set.mem_iInter, Set.mem_ofPred_eq, mem_hexagon_iff_sideFunctional_le]
+  rw [he]
+  exact isClosed_iInter fun k => isClosed_le (sideFunctional_continuous k) continuous_const
+
+private theorem CuspHoneycombHexagon.hexagon_subset_closedBall :
+    Hexagon ⊆ Metric.closedBall (0 : Plane) 1 := by
+  intro x hx
+  rw [Metric.mem_closedBall, dist_zero_right]
+  apply (pi_norm_le_iff_of_nonneg (show (0 : ℝ) ≤ 1 by norm_num)).mpr
+  intro i
+  fin_cases i
+  · exact hx.1
+  · exact hx.2.1
+
+private theorem CuspHoneycombHexagon.hexagon_isCompact : IsCompact Hexagon :=
+  (ProperSpace.isCompact_closedBall (0 : Plane) 1).of_isClosed_subset hexagon_isClosed
+    hexagon_subset_closedBall
+
+private theorem CuspHoneycombHexagon.hexagon_isBounded : Bornology.IsBounded Hexagon :=
+  hexagon_isCompact.isBounded
+
+private theorem CuspHoneycombHexagon.ball_half_subset_hexagon :
+    Metric.ball (0 : Plane) (1 / 2) ⊆ Hexagon := by
+  intro x hx
+  have hn : ‖x‖ < 1 / 2 := by simpa only [Metric.mem_ball, dist_zero_right] using hx
+  have h0 : |x 0| ≤ ‖x‖ := norm_le_pi_norm x 0
+  have h1 : |x 1| ≤ ‖x‖ := norm_le_pi_norm x 1
+  have hsum := abs_add_le (x 0) (x 1)
+  exact ⟨by linarith, by linarith, by linarith⟩
+
+private theorem CuspHoneycombHexagon.hexagon_mem_nhds_zero : Hexagon ∈ 𝓝 (0 : Plane) :=
+  Filter.mem_of_superset (Metric.ball_mem_nhds _ (by norm_num)) ball_half_subset_hexagon
+
+private theorem CuspHoneycombHexagon.zero_mem_interior_hexagon : (0 : Plane) ∈ interior Hexagon :=
+  mem_interior_iff_mem_nhds.mpr hexagon_mem_nhds_zero
+
+private theorem CuspHoneycombHexagon.hexagon_interior_nonempty : (interior Hexagon).Nonempty :=
+  ⟨0, zero_mem_interior_hexagon⟩
+
+private theorem CuspHoneycombHexagon.mem_interior_hexagon_iff (x : Plane) :
+    x ∈ interior Hexagon ↔ ∀ k : Fin 6, sideFunctional k x < 1 := by
+  constructor
+  · intro hx k
+    have hle := (mem_hexagon_iff_sideFunctional_le x).mp (interior_subset hx) k
+    apply lt_of_le_of_ne hle
+    intro heq
+    have hopen : IsOpen ((fun a : ℝ => a • x) ⁻¹' interior Hexagon) :=
+      isOpen_interior.preimage (continuous_id.smul continuous_const)
+    have hone : (1 : ℝ) ∈ (fun a : ℝ => a • x) ⁻¹' interior Hexagon := by
+      simpa only [Set.mem_preimage, one_smul] using hx
+    obtain ⟨δ, hδ, hball⟩ := Metric.isOpen_iff.mp hopen 1 hone
+    have ha : (1 + δ / 2) • x ∈ interior Hexagon :=
+      hball
+        (by
+          change Dist.dist (1 + δ / 2) (1 : ℝ) < δ
+          rw [Real.dist_eq, add_sub_cancel_left, abs_of_pos (half_pos hδ)]
+          exact half_lt_self hδ)
+    have hb := (mem_hexagon_iff_sideFunctional_le _).mp (interior_subset ha) k
+    rw [sideFunctional_smul, heq, mul_one] at hb
+    linarith
+  · intro hx
+    let U : Set Plane := ⋂ k : Fin 6, {y | sideFunctional k y < 1}
+    have hU : IsOpen U :=
+      isOpen_iInter_of_finite fun k => isOpen_lt (sideFunctional_continuous k) continuous_const
+    have hxU : x ∈ U := Set.mem_iInter.mpr hx
+    have hUK : U ⊆ Hexagon := by
+      intro y hy
+      apply (mem_hexagon_iff_sideFunctional_le y).mpr
+      intro k
+      exact (Set.mem_iInter.mp hy k).le
+    exact mem_interior_iff_mem_nhds.mpr (Filter.mem_of_superset (hU.mem_nhds hxU) hUK)
+
+private theorem CuspHoneycombHexagon.frontier_hexagon : frontier Hexagon = ⋃ k : Fin 6, side k := by
+  ext x
+  rw [frontier, hexagon_isClosed.closure_eq, Set.mem_sdiff, mem_interior_hexagon_iff,
+    Set.mem_iUnion]
+  constructor
+  · rintro ⟨hx, hn⟩
+    push Not at hn
+    obtain ⟨k, hk⟩ := hn
+    exact ⟨k, hx, le_antisymm ((mem_hexagon_iff_sideFunctional_le x).mp hx k) hk⟩
+  · rintro ⟨k, hx, hk⟩
+    exact ⟨hx, fun h => (h k).ne hk⟩
+
+private abbrev CuspHoneycombRadial.UnitSphere (E : Type*) [NormedAddCommGroup E] :=
+  Metric.sphere (0 : E) (1 : ℝ)
+
+private theorem CuspHoneycombRadial.unitSphere_norm {E : Type*} [NormedAddCommGroup E]
+    (x : UnitSphere E) : ‖(x : E)‖ = 1 :=
+  mem_sphere_zero_iff_norm.mp x.2
+
+private theorem CuspHoneycombRadial.unitSphere_ne_zero {E : Type*} [NormedAddCommGroup E]
+    (x : UnitSphere E) : (x : E) ≠ 0 :=
+  norm_ne_zero_iff.mp (by rw [unitSphere_norm]; exact one_ne_zero)
+
+private def CuspHoneycombRadial.direction {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (x : { x : E // x ≠ 0 }) : UnitSphere E :=
+  ⟨NormedSpace.normalize x.1, mem_sphere_zero_iff_norm.mpr (NormedSpace.norm_normalize x.2)⟩
+
+private theorem CuspHoneycombRadial.direction_continuous {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] : Continuous (direction (E := E)) := by
+  apply Continuous.subtype_mk
+  exact
+    (continuous_subtype_val.norm.inv₀
+          (fun x : { x : E // x ≠ 0 } => norm_ne_zero_iff.mpr x.2)).smul
+      continuous_subtype_val
+
+private theorem CuspHoneycombRadial.norm_smul_direction {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (x : { x : E // x ≠ 0 }) : ‖x.1‖ • (direction x : E) = x.1 :=
+  NormedSpace.norm_smul_normalize x.1
+
+private theorem
+    CuspHoneycombRadial.direction_sphere {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (x : UnitSphere E) (hx : (x : E) ≠ 0) : direction ⟨(x : E), hx⟩ = x :=
+  Subtype.ext (NormedSpace.normalize_eq_self_of_norm_eq_one (unitSphere_norm x))
+
+private def CuspHoneycombRadial.radialOffZero_mo1973_11510 {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (e : UnitSphere E ≃ₜ UnitSphere E) (x : { x : E // x ≠ 0 }) : E :=
+  ‖x.1‖ • (e (direction x) : E)
+
+private theorem CuspHoneycombRadial.radialOffZero_continuous_mo1973_11511 {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] (e : UnitSphere E ≃ₜ UnitSphere E) :
+    Continuous (radialOffZero_mo1973_11510 e) :=
+  continuous_subtype_val.norm.smul
+    (continuous_subtype_val.comp (e.continuous.comp direction_continuous))
+
+private def CuspHoneycombRadial.radialMap {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (e : UnitSphere E ≃ₜ UnitSphere E) (x : E) : E := by
+  classical exact if hx : x = 0 then 0 else radialOffZero_mo1973_11510 e ⟨x, hx⟩
+
+@[simp]
+private theorem
+    CuspHoneycombRadial.radialMap_zero {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (e : UnitSphere E ≃ₜ UnitSphere E) : radialMap e (0 : E) = 0 := by simp [radialMap]
+
+private theorem CuspHoneycombRadial.radialMap_apply_of_ne_zero {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (e : UnitSphere E ≃ₜ UnitSphere E) {x : E} (hx : x ≠ 0) :
+    radialMap e x = ‖x‖ • (e (direction ⟨x, hx⟩) : E) := by
+  simp only [radialMap, dite_eq_right hx, radialOffZero_mo1973_11510]
+
+@[simp]
+private theorem
+    CuspHoneycombRadial.radialMap_norm {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (e : UnitSphere E ≃ₜ UnitSphere E) (x : E) : ‖radialMap e x‖ = ‖x‖ := by
+  by_cases hx : x = 0
+  · simp only [hx, radialMap_zero]
+  · rw [radialMap_apply_of_ne_zero e hx, norm_smul, norm_norm, unitSphere_norm, mul_one]
+
+@[simp]
+private theorem CuspHoneycombRadial.radialMap_eq_zero_iff {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (e : UnitSphere E ≃ₜ UnitSphere E) (x : E) : radialMap e x = 0 ↔ x = 0 := by
+  constructor
+  · intro h
+    apply norm_eq_zero.mp
+    rw [← radialMap_norm e x, h, norm_zero]
+  · rintro rfl
+    exact radialMap_zero e
+
+private theorem
+    CuspHoneycombRadial.radialMap_ne_zero {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (e : UnitSphere E ≃ₜ UnitSphere E) {x : E} (hx : x ≠ 0) : radialMap e x ≠ 0 := fun h =>
+  hx ((radialMap_eq_zero_iff e x).mp h)
+
+private theorem CuspHoneycombRadial.direction_radialMap {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (e : UnitSphere E ≃ₜ UnitSphere E) {x : E} (hx : x ≠ 0) :
+    direction ⟨radialMap e x, radialMap_ne_zero e hx⟩ = e (direction ⟨x, hx⟩) := by
+  apply Subtype.ext
+  change ‖radialMap e x‖⁻¹ • radialMap e x = (e (direction ⟨x, hx⟩) : E)
+  rw [radialMap_norm, radialMap_apply_of_ne_zero e hx, smul_smul,
+    inv_mul_cancel₀ (norm_ne_zero_iff.mpr hx), one_smul]
+
+private theorem
+    CuspHoneycombRadial.radialMap_sphere {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (e : UnitSphere E ≃ₜ UnitSphere E) (x : UnitSphere E) : radialMap e (x : E) = (e x : E) := by
+  rw [radialMap_apply_of_ne_zero e (unitSphere_ne_zero x), unitSphere_norm, direction_sphere,
+    one_smul]
+
+private theorem
+    CuspHoneycombRadial.radialMap_symm {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (e : UnitSphere E ≃ₜ UnitSphere E) (x : E) : radialMap e.symm (radialMap e x) = x := by
+  by_cases hx : x = 0
+  · simp only [hx, radialMap_zero]
+  · rw [radialMap_apply_of_ne_zero e.symm (radialMap_ne_zero e hx), radialMap_norm,
+      direction_radialMap e hx, e.symm_apply_apply]
+    exact norm_smul_direction ⟨x, hx⟩
+
+private theorem CuspHoneycombRadial.radialMap_continuousAt_zero {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (e : UnitSphere E ≃ₜ UnitSphere E) : ContinuousAt (radialMap e) (0 : E) := by
+  change Filter.Tendsto (radialMap e) (𝓝 (0 : E)) (𝓝 (radialMap e 0))
+  rw [radialMap_zero]
+  apply tendsto_zero_iff_norm_tendsto_zero.mpr
+  have h : Filter.Tendsto (fun x : E => ‖x‖) (𝓝 (0 : E)) (𝓝 (0 : ℝ)) := by
+    simpa only [norm_zero] using (continuous_norm.tendsto (0 : E))
+  simpa only [radialMap_norm] using h
+
+private theorem
+    CuspHoneycombRadial.radialMap_continuousOn_nonzero {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (e : UnitSphere E ≃ₜ UnitSphere E) :
+    ContinuousOn (radialMap e) {x : E | x ≠ 0} := by
+  rw [continuousOn_iff_continuous_domRestrict]
+  exact
+    (radialOffZero_continuous_mo1973_11511 e).congr
+      (fun x : { x : E // x ≠ 0 } => (radialMap_apply_of_ne_zero e x.2).symm)
+
+private theorem CuspHoneycombRadial.radialMap_continuous {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (e : UnitSphere E ≃ₜ UnitSphere E) : Continuous (radialMap e) := by
+  apply continuous_iff_continuousAt.mpr
+  intro x
+  by_cases hx : x = 0
+  · subst x
+    exact radialMap_continuousAt_zero e
+  · exact
+      (radialMap_continuousOn_nonzero e).continuousAt
+        ((isOpen_ne_fun continuous_id continuous_const).mem_nhds hx)
+
+private def
+    CuspHoneycombRadial.radialHomeomorph {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    (e : UnitSphere E ≃ₜ UnitSphere E) : E ≃ₜ E
+    where
+  toFun := radialMap e
+  invFun := radialMap e.symm
+  left_inv := radialMap_symm e
+  right_inv := radialMap_symm e.symm
+  continuous_toFun := radialMap_continuous e
+  continuous_invFun := radialMap_continuous e.symm
+
+@[simp]
+private theorem CuspHoneycombRadial.radialHomeomorph_norm {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (e : UnitSphere E ≃ₜ UnitSphere E) (x : E) : ‖radialHomeomorph e x‖ = ‖x‖ :=
+  radialMap_norm e x
+
+private theorem CuspHoneycombRadial.radialHomeomorph_sphere {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] (e : UnitSphere E ≃ₜ UnitSphere E) (x : UnitSphere E) :
+    radialHomeomorph e (x : E) = (e x : E) :=
+  radialMap_sphere e x
+
+private theorem CuspHoneycombRadial.homeomorph_mem_image_iff_mo1973_11532 {E : Type*}
+    [NormedAddCommGroup E] (H : E ≃ₜ E) {S T : Set E} (hST : H '' S = T) (x : E) :
+    x ∈ S ↔ H x ∈ T := by
+  rw [← hST]
+  exact H.injective.mem_set_image.symm
+
+private theorem CuspHoneycombRadial.homeomorph_image_eq_of_mem_iff_mo1973_11533 {E : Type*}
+    [NormedAddCommGroup E] (F : E ≃ₜ E) {K : Set E} (hmem : ∀ x, F x ∈ K ↔ x ∈ K) : F '' K = K := by
+  apply Set.Subset.antisymm
+  · rintro y ⟨x, hx, rfl⟩
+    exact (hmem x).mpr hx
+  · intro y hy
+    refine ⟨F.symm y, ?_, F.apply_symm_apply y⟩
+    apply (hmem (F.symm y)).mp
+    rwa [F.apply_symm_apply]
+
+public
+theorem CuspHoneycombRadial.exists_homeomorph_extending_frontier {E : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] {K : Set E} (hconv : Convex ℝ K)
+    (hclosed : IsClosed K) (hbounded : Bornology.IsBounded K) (hne : (interior K).Nonempty)
+    (e : frontier K ≃ₜ frontier K) :
+    ∃ F : E ≃ₜ E, F '' K = K ∧ ∀ x : frontier K, F (x : E) = (e x : E) := by
+  obtain ⟨H, _hinterior, hclosure, hfrontier⟩ :=
+    exists_homeomorph_image_interior_closure_frontier_eq_unitBall hconv hne hbounded
+  have hK : H '' K = Metric.closedBall (0 : E) 1 := by
+    simpa only [hclosed.closure_eq] using hclosure
+  let HB : frontier K ≃ₜ UnitSphere E :=
+    H.subtype (homeomorph_mem_image_iff_mo1973_11532 H hfrontier)
+  let eS : UnitSphere E ≃ₜ UnitSphere E := HB.symm.trans (e.trans HB)
+  let F : E ≃ₜ E := H.trans ((radialHomeomorph eS).trans H.symm)
+  have hmemF (x : E) : F x ∈ K ↔ x ∈ K := by
+    rw [homeomorph_mem_image_iff_mo1973_11532 H hK (F x),
+      homeomorph_mem_image_iff_mo1973_11532 H hK x]
+    change
+      H (H.symm (radialHomeomorph eS (H x))) ∈ Metric.closedBall (0 : E) 1 ↔
+        H x ∈ Metric.closedBall (0 : E) 1
+    rw [H.apply_symm_apply]
+    simp only [Metric.mem_closedBall, dist_zero_right, radialHomeomorph_norm]
+  refine ⟨F, homeomorph_image_eq_of_mem_iff_mo1973_11533 F hmemF, ?_⟩
+  intro x
+  change H.symm (radialHomeomorph eS (HB x : E)) = (e x : E)
+  rw [radialHomeomorph_sphere]
+  change H.symm (HB (e (HB.symm (HB x))) : E) = (e x : E)
+  rw [HB.symm_apply_apply]
+  exact H.symm_apply_apply (e x : E)
+
+private def
+    CuspHoneycombRadial.boundaryExtension {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    {K : Set E} (hconv : Convex ℝ K) (hclosed : IsClosed K) (hbounded : Bornology.IsBounded K)
+    (hne : (interior K).Nonempty) (e : frontier K ≃ₜ frontier K) : E ≃ₜ E :=
+  (exists_homeomorph_extending_frontier hconv hclosed hbounded hne e).choose
+
+private theorem CuspHoneycombRadial.boundaryExtension_image {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {K : Set E} (hconv : Convex ℝ K) (hclosed : IsClosed K)
+    (hbounded : Bornology.IsBounded K) (hne : (interior K).Nonempty)
+    (e : frontier K ≃ₜ frontier K) : boundaryExtension hconv hclosed hbounded hne e '' K = K :=
+  (exists_homeomorph_extending_frontier hconv hclosed hbounded hne e).choose_spec.1
+
+private theorem CuspHoneycombRadial.boundaryExtension_frontier {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {K : Set E} (hconv : Convex ℝ K) (hclosed : IsClosed K)
+    (hbounded : Bornology.IsBounded K) (hne : (interior K).Nonempty)
+    (e : frontier K ≃ₜ frontier K) (x : frontier K) :
+    boundaryExtension hconv hclosed hbounded hne e (x : E) = (e x : E) :=
+  (exists_homeomorph_extending_frontier hconv hclosed hbounded hne e).choose_spec.2 x
+
+private def
+    CuspHoneycombRadial.boundarySetExtension {E : Type*} [NormedAddCommGroup E] [NormedSpace ℝ E]
+    {K : Set E} (hconv : Convex ℝ K) (hclosed : IsClosed K) (hbounded : Bornology.IsBounded K)
+    (hne : (interior K).Nonempty) (e : frontier K ≃ₜ frontier K) : K ≃ₜ K :=
+  (boundaryExtension hconv hclosed hbounded hne e).subtype
+    (homeomorph_mem_image_iff_mo1973_11532 _
+      (boundaryExtension_image hconv hclosed hbounded hne e))
+
+private theorem CuspHoneycombRadial.boundarySetExtension_frontier {E : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] {K : Set E} (hconv : Convex ℝ K) (hclosed : IsClosed K)
+    (hbounded : Bornology.IsBounded K) (hne : (interior K).Nonempty)
+    (e : frontier K ≃ₜ frontier K) (x : frontier K) :
+    (boundarySetExtension hconv hclosed hbounded hne e ⟨(x : E), hclosed.frontier_subset x.2⟩ :
+        E) =
+      (e x : E) :=
+  boundaryExtension_frontier hconv hclosed hbounded hne e x
+
+private abbrev CuspHoneycombHexagon.PositiveE0Boundary :=
+  (⋃ k : Fin 6, positiveBoundary k)
+
+private def CuspHoneycombHexagon.positiveE0BoundaryHexagonHomeomorph :
+    PositiveE0Boundary ≃ₜ frontier Hexagon
+    where
+  toFun
+    x :=
+    ⟨(positiveE0HexagonHomeomorph x.1 : Plane),
+      by
+      rw [frontier_hexagon]
+      exact (positiveE0HexagonHomeomorph_mem_boundary_iff x.1).mpr x.2⟩
+  invFun
+    y :=
+    ⟨positiveE0HexagonHomeomorph.symm ⟨y.1, hexagon_isClosed.frontier_subset y.2⟩,
+      by
+      apply (positiveE0HexagonHomeomorph_mem_boundary_iff _).mp
+      simpa only [Homeomorph.apply_symm_apply, ← frontier_hexagon] using y.2⟩
+  left_inv x := Subtype.ext (positiveE0HexagonHomeomorph.symm_apply_apply x.1)
+  right_inv
+    y := by
+    apply Subtype.ext
+    change
+      (positiveE0HexagonHomeomorph
+            (positiveE0HexagonHomeomorph.symm ⟨y.1, hexagon_isClosed.frontier_subset y.2⟩) :
+          Plane) =
+        y.1
+    rw [Homeomorph.apply_symm_apply]
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    exact
+      continuous_subtype_val.comp
+        (positiveE0HexagonHomeomorph.continuous.comp continuous_subtype_val)
+  continuous_invFun := by
+    apply Continuous.subtype_mk
+    exact positiveE0HexagonHomeomorph.symm.continuous.comp (continuous_subtype_val.subtype_mk _)
+
+@[simp]
+private theorem
+    CuspHoneycombHexagon.positiveE0BoundaryHexagonHomeomorph_coe (x : PositiveE0Boundary) :
+    (positiveE0BoundaryHexagonHomeomorph x : Plane) = (positiveE0HexagonHomeomorph x.1 : Plane) :=
+  rfl
+
+private def
+    CuspHoneycombHexagon.polygonBoundaryConjugate (b : PositiveE0Boundary ≃ₜ PositiveE0Boundary) :
+    frontier Hexagon ≃ₜ frontier Hexagon :=
+  positiveE0BoundaryHexagonHomeomorph.symm.trans (b.trans positiveE0BoundaryHexagonHomeomorph)
+
+@[simp]
+private theorem CuspHoneycombHexagon.polygonBoundaryConjugate_apply
+    (b : PositiveE0Boundary ≃ₜ PositiveE0Boundary) (x : PositiveE0Boundary) :
+    polygonBoundaryConjugate b (positiveE0BoundaryHexagonHomeomorph x) =
+      positiveE0BoundaryHexagonHomeomorph (b x) := by
+  change
+    positiveE0BoundaryHexagonHomeomorph
+        (b (positiveE0BoundaryHexagonHomeomorph.symm (positiveE0BoundaryHexagonHomeomorph x))) =
+      _
+  rw [Homeomorph.symm_apply_apply]
+
+private def CuspHoneycombHexagon.positiveE0BoundaryExtension
+    (b : PositiveE0Boundary ≃ₜ PositiveE0Boundary) : PositiveE0 ≃ₜ PositiveE0 :=
+  positiveE0HexagonHomeomorph.trans
+    ((CuspHoneycombRadial.boundarySetExtension hexagon_convex hexagon_isClosed hexagon_isBounded
+          hexagon_interior_nonempty (polygonBoundaryConjugate b)).trans
+      positiveE0HexagonHomeomorph.symm)
+
+private theorem CuspHoneycombHexagon.positiveE0BoundaryExtension_boundary
+    (b : PositiveE0Boundary ≃ₜ PositiveE0Boundary) (x : PositiveE0Boundary) :
+    positiveE0BoundaryExtension b (x : PositiveE0) = (b x : PositiveE0) := by
+  apply positiveE0HexagonHomeomorph.injective
+  change
+    positiveE0HexagonHomeomorph
+        (positiveE0HexagonHomeomorph.symm
+          (CuspHoneycombRadial.boundarySetExtension hexagon_convex hexagon_isClosed
+            hexagon_isBounded hexagon_interior_nonempty (polygonBoundaryConjugate b)
+            (positiveE0HexagonHomeomorph x.1))) =
+      _
+  rw [Homeomorph.apply_symm_apply]
+  apply Subtype.ext
+  have h :=
+    CuspHoneycombRadial.boundarySetExtension_frontier hexagon_convex hexagon_isClosed
+      hexagon_isBounded hexagon_interior_nonempty (polygonBoundaryConjugate b)
+      (positiveE0BoundaryHexagonHomeomorph x)
+  simpa only [polygonBoundaryConjugate_apply, positiveE0BoundaryHexagonHomeomorph_coe] using h
+
+private def
+    CuspHoneycombHexagon.positiveBoundaryArc (k : Fin 6) : unitInterval ≃ₜ positiveBoundary k :=
+  (sideIntervalHomeomorph k).trans (positiveBoundaryHexagonHomeomorph k).symm
+
+@[simp]
+private theorem CuspHoneycombHexagon.positiveBoundaryArc_hexagon (k : Fin 6) (t : unitInterval) :
+    (positiveE0HexagonHomeomorph (positiveBoundaryArc k t).1 : Plane) =
+      (1 - (t : ℝ)) • vertex (k - 1) + (t : ℝ) • vertex k := by
+  change
+    (positiveBoundaryHexagonHomeomorph k
+          ((positiveBoundaryHexagonHomeomorph k).symm (sideIntervalHomeomorph k t)) :
+        Plane) =
+      _
+  rw [Homeomorph.apply_symm_apply]
+  exact sideIntervalHomeomorph_apply k t
+
+@[simp]
+private theorem CuspHoneycombHexagon.positiveBoundaryArc_zero (k : Fin 6) :
+    (positiveBoundaryArc k 0).1 = squarePoint (k - 1) cornerZero := by
+  apply positiveE0HexagonHomeomorph.injective
+  apply Subtype.ext
+  rw [positiveBoundaryArc_hexagon, positiveE0HexagonHomeomorph_cornerZero]
+  simp
+
+@[simp]
+private theorem CuspHoneycombHexagon.positiveBoundaryArc_one (k : Fin 6) :
+    (positiveBoundaryArc k 1).1 = squarePoint k cornerZero := by
+  apply positiveE0HexagonHomeomorph.injective
+  apply Subtype.ext
+  rw [positiveBoundaryArc_hexagon, positiveE0HexagonHomeomorph_cornerZero]
+  simp
+
+private theorem CuspHoneycombHexagon.positiveBoundaryArc_zero_coe (k : Fin 6) :
+    (((positiveBoundaryArc k 0).1 : ToricSpace.rayDivisor 0) : ToricSpace.Space) =
+      ToricSpace.inclusion (ToricComponent.zeroTriangle (k - 1)) 0 := by
+  rw [positiveBoundaryArc_zero, squarePoint_cornerZero_coe]
+
+private theorem CuspHoneycombHexagon.positiveBoundaryArc_one_coe (k : Fin 6) :
+    (((positiveBoundaryArc k 1).1 : ToricSpace.rayDivisor 0) : ToricSpace.Space) =
+      ToricSpace.inclusion (ToricComponent.zeroTriangle k) 0 := by
+  rw [positiveBoundaryArc_one, squarePoint_cornerZero_coe]
+
+private theorem CuspHoneycombHexagon.positiveBoundaryArc_next_endpoint (k : Fin 6) :
+    (positiveBoundaryArc k 1).1 = (positiveBoundaryArc (k + 1) 0).1 := by
+  rw [positiveBoundaryArc_one, positiveBoundaryArc_zero, add_sub_cancel_right]
+
+private theorem CuspHoneycombHexagon.positiveBoundary_inter_next (k : Fin 6) :
+    positiveBoundary k ∩ positiveBoundary (k + 1) = {squarePoint k cornerZero} := by
+  ext x
+  constructor
+  · intro hx
+    have hy : (positiveE0HexagonHomeomorph x : Plane) ∈ side k ∩ side (k + 1) :=
+      ⟨(positiveE0HexagonHomeomorph_mem_side_iff x k).mpr hx.1,
+        (positiveE0HexagonHomeomorph_mem_side_iff x (k + 1)).mpr hx.2⟩
+    rw [side_inter_next, Set.mem_singleton_iff] at hy
+    change x = squarePoint k cornerZero
+    apply positiveE0HexagonHomeomorph.injective
+    apply Subtype.ext
+    exact hy.trans (positiveE0HexagonHomeomorph_cornerZero k).symm
+  · intro hx
+    have hx' : x = squarePoint k cornerZero := hx
+    subst x
+    exact
+      ⟨(squarePoint_cornerZero_mem_positiveBoundary_iff k k).mpr (Or.inl rfl),
+        (squarePoint_cornerZero_mem_positiveBoundary_iff k (k + 1)).mpr (Or.inr rfl)⟩
+
+private theorem
+    CuspHoneycombHexagon.positiveBoundary_disjoint_nonadjacent {i j : Fin 6} (hij : i ≠ j)
+    (hnext : j ≠ i + 1) (hprev : i ≠ j + 1) :
+    Disjoint (positiveBoundary i) (positiveBoundary j) := by
+  apply Set.disjoint_left.mpr
+  intro x hx hy
+  exact
+    Set.disjoint_left.mp (side_disjoint_nonadjacent hij hnext hprev)
+      ((positiveE0HexagonHomeomorph_mem_side_iff x i).mpr hx)
+      ((positiveE0HexagonHomeomorph_mem_side_iff x j).mpr hy)
+
+private def CuspHoneycombHexagon.boundaryArcInclusion (k : Fin 6) (x : positiveBoundary k) :
+    (⋃ j : Fin 6, positiveBoundary j) :=
+  ⟨x.1, Set.mem_iUnion.mpr ⟨k, x.2⟩⟩
+
+private theorem CuspHoneycombHexagon.boundaryArcInclusion_continuous (k : Fin 6) :
+    Continuous (boundaryArcInclusion k) :=
+  continuous_subtype_val.subtype_mk _
+
+private def CuspHoneycombHexagon.boundaryArcProjection
+    (P : ∀ k : Fin 6, unitInterval ≃ₜ positiveBoundary k) (p : Fin 6 × unitInterval) :
+    (⋃ j : Fin 6, positiveBoundary j) :=
+  boundaryArcInclusion p.1 (P p.1 p.2)
+
+private theorem CuspHoneycombHexagon.boundaryArcProjection_continuous
+    (P : ∀ k : Fin 6, unitInterval ≃ₜ positiveBoundary k) :
+    Continuous (boundaryArcProjection P) :=
+  continuous_prod_of_discrete_left.mpr
+    (fun k => (boundaryArcInclusion_continuous k).comp (P k).continuous)
+
+private theorem CuspHoneycombHexagon.boundaryArcProjection_surjective
+    (P : ∀ k : Fin 6, unitInterval ≃ₜ positiveBoundary k) :
+    Function.Surjective (boundaryArcProjection P) := by
+  intro x
+  obtain ⟨k, hk⟩ := Set.mem_iUnion.mp x.2
+  obtain ⟨t, ht⟩ := (P k).surjective ⟨x.1, hk⟩
+  refine ⟨(k, t), ?_⟩
+  apply Subtype.ext
+  change (P k t).1 = x.1
+  exact congrArg (fun y : positiveBoundary k => y.1) ht
+
+private theorem CuspHoneycombHexagon.boundaryArcFamily_eq_self_iff
+    (P : ∀ k : Fin 6, unitInterval ≃ₜ positiveBoundary k) (i : Fin 6) (t u : unitInterval) :
+    (P i t).1 = (P i u).1 ↔ t = u := by
+  constructor
+  · intro h
+    exact (P i).injective (Subtype.ext h)
+  · rintro rfl
+    rfl
+
+private theorem CuspHoneycombHexagon.boundaryArcFamily_eq_next_iff
+    (P : ∀ k : Fin 6, unitInterval ≃ₜ positiveBoundary k)
+    (hP0 : ∀ k, (P k 0).1 = (positiveBoundaryArc k 0).1)
+    (hP1 : ∀ k, (P k 1).1 = (positiveBoundaryArc k 1).1) (i : Fin 6) (t u : unitInterval) :
+    (P i t).1 = (P (i + 1) u).1 ↔ t = 1 ∧ u = 0 := by
+  constructor
+  · intro h
+    have hm : (P i t).1 ∈ positiveBoundary i ∩ positiveBoundary (i + 1) := by
+      refine ⟨(P i t).2, ?_⟩
+      rw [h]
+      exact (P (i + 1) u).2
+    have hx : (P i t).1 = squarePoint i cornerZero := by
+      simpa only [positiveBoundary_inter_next, Set.mem_singleton_iff] using hm
+    constructor
+    · apply (P i).injective
+      apply Subtype.ext
+      rw [hP1 i, positiveBoundaryArc_one]
+      exact hx
+    · apply (P (i + 1)).injective
+      apply Subtype.ext
+      rw [hP0 (i + 1), positiveBoundaryArc_zero, add_sub_cancel_right]
+      exact h.symm.trans hx
+  · rintro ⟨rfl, rfl⟩
+    rw [hP1 i, hP0 (i + 1)]
+    exact positiveBoundaryArc_next_endpoint i
+
+private theorem CuspHoneycombHexagon.boundaryArcFamily_ne_nonadjacent
+    (P : ∀ k : Fin 6, unitInterval ≃ₜ positiveBoundary k) {i j : Fin 6} (hij : i ≠ j)
+    (hnext : j ≠ i + 1) (hprev : i ≠ j + 1) (t u : unitInterval) : (P i t).1 ≠ (P j u).1 := by
+  intro h
+  apply Set.disjoint_left.mp (positiveBoundary_disjoint_nonadjacent hij hnext hprev) (P i t).2
+  rw [h]
+  exact (P j u).2
+
+private theorem CuspHoneycombHexagon.boundaryArcFamilies_sameFibres
+    (P Q : ∀ k : Fin 6, unitInterval ≃ₜ positiveBoundary k)
+    (hP0 : ∀ k, (P k 0).1 = (positiveBoundaryArc k 0).1)
+    (hP1 : ∀ k, (P k 1).1 = (positiveBoundaryArc k 1).1)
+    (hQ0 : ∀ k, (Q k 0).1 = (positiveBoundaryArc k 0).1)
+    (hQ1 : ∀ k, (Q k 1).1 = (positiveBoundaryArc k 1).1) (i j : Fin 6) (t u : unitInterval) :
+    (P i t).1 = (P j u).1 ↔ (Q i t).1 = (Q j u).1 := by
+  by_cases hij : i = j
+  · subst j
+    rw [boundaryArcFamily_eq_self_iff, boundaryArcFamily_eq_self_iff]
+  by_cases hnext : j = i + 1
+  · subst j
+    rw [boundaryArcFamily_eq_next_iff P hP0 hP1, boundaryArcFamily_eq_next_iff Q hQ0 hQ1]
+  by_cases hprev : i = j + 1
+  · subst i
+    rw [eq_comm (a := (P (j + 1) t).1), eq_comm (a := (Q (j + 1) t).1),
+      boundaryArcFamily_eq_next_iff P hP0 hP1, boundaryArcFamily_eq_next_iff Q hQ0 hQ1]
+  exact
+    iff_of_false (boundaryArcFamily_ne_nonadjacent P hij hnext hprev t u)
+      (boundaryArcFamily_ne_nonadjacent Q hij hnext hprev t u)
+
+private theorem CuspHoneycombHexagon.boundaryArcProjection_sameFibres
+    (P Q : ∀ k : Fin 6, unitInterval ≃ₜ positiveBoundary k)
+    (hP0 : ∀ k, (P k 0).1 = (positiveBoundaryArc k 0).1)
+    (hP1 : ∀ k, (P k 1).1 = (positiveBoundaryArc k 1).1)
+    (hQ0 : ∀ k, (Q k 0).1 = (positiveBoundaryArc k 0).1)
+    (hQ1 : ∀ k, (Q k 1).1 = (positiveBoundaryArc k 1).1) (a b : Fin 6 × unitInterval) :
+    boundaryArcProjection P a = boundaryArcProjection P b ↔
+      boundaryArcProjection Q a = boundaryArcProjection Q b := by
+  have h := boundaryArcFamilies_sameFibres P Q hP0 hP1 hQ0 hQ1 a.1 b.1 a.2 b.2
+  constructor
+  · intro hab
+    apply Subtype.ext
+    exact h.mp (congrArg Subtype.val hab)
+  · intro hab
+    apply Subtype.ext
+    exact h.mpr (congrArg Subtype.val hab)
+
+private def CuspHoneycombHexagon.boundaryGluingHomeomorph
+    (P : ∀ k : Fin 6, unitInterval ≃ₜ positiveBoundary k)
+    (hP0 : ∀ k, (P k 0).1 = (positiveBoundaryArc k 0).1)
+    (hP1 : ∀ k, (P k 1).1 = (positiveBoundaryArc k 1).1) :
+    (⋃ k : Fin 6, positiveBoundary k) ≃ₜ (⋃ k : Fin 6, positiveBoundary k) :=
+  CommonFibres.homeomorph (boundaryArcProjection positiveBoundaryArc) (boundaryArcProjection P)
+    (boundaryArcProjection_surjective positiveBoundaryArc)
+    (boundaryArcProjection_continuous positiveBoundaryArc) (boundaryArcProjection_continuous P)
+    (boundaryArcProjection_surjective P)
+    (boundaryArcProjection_sameFibres positiveBoundaryArc P (fun _ => rfl) (fun _ => rfl) hP0 hP1)
+
+@[simp]
+private theorem CuspHoneycombHexagon.boundaryGluingHomeomorph_apply
+    (P : ∀ k : Fin 6, unitInterval ≃ₜ positiveBoundary k)
+    (hP0 : ∀ k, (P k 0).1 = (positiveBoundaryArc k 0).1)
+    (hP1 : ∀ k, (P k 1).1 = (positiveBoundaryArc k 1).1) (k : Fin 6) (t : unitInterval) :
+    boundaryGluingHomeomorph P hP0 hP1 (boundaryArcInclusion k (positiveBoundaryArc k t)) =
+      boundaryArcInclusion k (P k t) :=
+  CommonFibres.homeomorph_apply (boundaryArcProjection positiveBoundaryArc)
+    (boundaryArcProjection P) (boundaryArcProjection_surjective positiveBoundaryArc)
+    (boundaryArcProjection_continuous positiveBoundaryArc) (boundaryArcProjection_continuous P)
+    (boundaryArcProjection_surjective P)
+    (boundaryArcProjection_sameFibres positiveBoundaryArc P (fun _ => rfl) (fun _ => rfl) hP0 hP1)
+    (k, t)
+
+private noncomputable def
+    CuspHoneycombHexagon.oppositePositiveBoundaryMap (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) (x : positiveBoundary k) : positiveBoundary (k + 3) :=
+  ⟨⟨⟨ToricSpace.twistedTranslate (CuspPositive.positiveTwist C₀)
+          (ToricSpace.cuspVector (ToricComponent.hexagonRay k)) (x.1.1 : ToricSpace.Space),
+        by
+        rw [ToricSpace.twistedTranslate_mem_rayDivisor, ToricSpace.cuspVector_cuspVector]
+        simp only [zero_sub, neg_neg]
+        exact x.2⟩,
+      CuspPositive.twistedTranslate_positiveTwist_preserves_positivePart C₀
+        (ToricSpace.cuspVector (ToricComponent.hexagonRay k)) x.1.2⟩,
+    by
+    change
+      ToricSpace.twistedTranslate (CuspPositive.positiveTwist C₀)
+          (ToricSpace.cuspVector (ToricComponent.hexagonRay k)) (x.1.1 : ToricSpace.Space) ∈
+        ToricSpace.rayDivisor (ToricComponent.hexagonRay (k + 3))
+    rw [ToricComponent.hexagonRay_opposite, ToricSpace.twistedTranslate_mem_rayDivisor,
+      ToricSpace.cuspVector_cuspVector, sub_self]
+    exact x.1.1.2⟩
+
+private noncomputable def CuspHoneycombHexagon.oppositePositiveBoundaryInv_mo1973_11577
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (k : Fin 6) (y : positiveBoundary (k + 3)) :
+    positiveBoundary k :=
+  ⟨⟨⟨ToricSpace.twistedTranslate (CuspPositive.positiveTwist C₀)
+          (-ToricSpace.cuspVector (ToricComponent.hexagonRay k)) (y.1.1 : ToricSpace.Space),
+        by
+        rw [ToricSpace.twistedTranslate_mem_rayDivisor, ToricSpace.cuspVector_neg,
+          ToricSpace.cuspVector_cuspVector, neg_neg, zero_sub, ←
+          ToricComponent.hexagonRay_opposite]
+        exact y.2⟩,
+      CuspPositive.twistedTranslate_positiveTwist_preserves_positivePart C₀
+        (-ToricSpace.cuspVector (ToricComponent.hexagonRay k)) y.1.2⟩,
+    by
+    change
+      ToricSpace.twistedTranslate (CuspPositive.positiveTwist C₀)
+          (-ToricSpace.cuspVector (ToricComponent.hexagonRay k)) (y.1.1 : ToricSpace.Space) ∈
+        ToricSpace.rayDivisor (ToricComponent.hexagonRay k)
+    rw [ToricSpace.twistedTranslate_mem_rayDivisor, ToricSpace.cuspVector_neg,
+      ToricSpace.cuspVector_cuspVector, neg_neg, sub_self]
+    exact y.1.1.2⟩
+
+private noncomputable def CuspHoneycombHexagon.oppositePositiveBoundaryHomeomorph
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (k : Fin 6) : positiveBoundary k ≃ₜ positiveBoundary (k + 3)
+    where
+  toFun := oppositePositiveBoundaryMap C₀ k
+  invFun := oppositePositiveBoundaryInv_mo1973_11577 C₀ k
+  left_inv
+    x := by
+    apply Subtype.ext
+    apply Subtype.ext
+    apply Subtype.ext
+    change
+      ToricSpace.twistedTranslate (CuspPositive.positiveTwist C₀)
+          (-ToricSpace.cuspVector (ToricComponent.hexagonRay k))
+          (ToricSpace.twistedTranslate (CuspPositive.positiveTwist C₀)
+            (ToricSpace.cuspVector (ToricComponent.hexagonRay k)) (x.1.1 : ToricSpace.Space)) =
+        (x.1.1 : ToricSpace.Space)
+    rw [ToricSpace.twistedTranslate_add, neg_add_cancel, ToricSpace.twistedTranslate_zero]
+  right_inv
+    y := by
+    apply Subtype.ext
+    apply Subtype.ext
+    apply Subtype.ext
+    change
+      ToricSpace.twistedTranslate (CuspPositive.positiveTwist C₀)
+          (ToricSpace.cuspVector (ToricComponent.hexagonRay k))
+          (ToricSpace.twistedTranslate (CuspPositive.positiveTwist C₀)
+            (-ToricSpace.cuspVector (ToricComponent.hexagonRay k)) (y.1.1 : ToricSpace.Space)) =
+        (y.1.1 : ToricSpace.Space)
+    rw [ToricSpace.twistedTranslate_add, add_neg_cancel, ToricSpace.twistedTranslate_zero]
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    apply Continuous.subtype_mk
+    apply Continuous.subtype_mk
+    exact
+      (ToricSpace.centralTranslationHomeomorph (CuspPositive.positiveTwist C₀)
+            (ToricSpace.cuspVector (ToricComponent.hexagonRay k))).continuous.comp
+        (continuous_subtype_val.comp (continuous_subtype_val.comp continuous_subtype_val))
+  continuous_invFun := by
+    apply Continuous.subtype_mk
+    apply Continuous.subtype_mk
+    apply Continuous.subtype_mk
+    exact
+      (ToricSpace.centralTranslationHomeomorph (CuspPositive.positiveTwist C₀)
+            (-ToricSpace.cuspVector (ToricComponent.hexagonRay k))).continuous.comp
+        (continuous_subtype_val.comp (continuous_subtype_val.comp continuous_subtype_val))
+
+private theorem CuspHoneycombHexagon.oppositePositiveBoundaryHomeomorph_coe
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (k : Fin 6) (x : positiveBoundary k) :
+    ((oppositePositiveBoundaryHomeomorph C₀ k x).1.1 : ToricSpace.Space) =
+      ToricSpace.twistedTranslate (CuspPositive.positiveTwist C₀)
+        (ToricSpace.cuspVector (ToricComponent.hexagonRay k)) (x.1.1 : ToricSpace.Space) :=
+  rfl
+
+private theorem CuspHoneycombHexagon.zeroTriangle_shift_opposite_previous (k : Fin 6) :
+    (ToricComponent.zeroTriangle (k - 1)).shift (-ToricComponent.hexagonRay k) =
+      ToricComponent.zeroTriangle (k + 3) := by fin_cases k <;> decide
+
+private theorem CuspHoneycombHexagon.zeroTriangle_shift_opposite_current (k : Fin 6) :
+    (ToricComponent.zeroTriangle k).shift (-ToricComponent.hexagonRay k) =
+      ToricComponent.zeroTriangle (k + 2) := by fin_cases k <;> decide
+
+private theorem CuspHoneycombHexagon.opposite_twistedTranslate_origin_previous
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (k : Fin 6) :
+    ToricSpace.twistedTranslate C (ToricSpace.cuspVector (ToricComponent.hexagonRay k))
+        (ToricSpace.inclusion (ToricComponent.zeroTriangle (k - 1)) 0) =
+      ToricSpace.inclusion (ToricComponent.zeroTriangle (k + 3)) 0 := by
+  rw [ToricSpace.twistedTranslate_origin, ToricSpace.cuspVector_cuspVector,
+    zeroTriangle_shift_opposite_previous]
+
+private theorem CuspHoneycombHexagon.opposite_twistedTranslate_origin_current
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (k : Fin 6) :
+    ToricSpace.twistedTranslate C (ToricSpace.cuspVector (ToricComponent.hexagonRay k))
+        (ToricSpace.inclusion (ToricComponent.zeroTriangle k) 0) =
+      ToricSpace.inclusion (ToricComponent.zeroTriangle (k + 2)) 0 := by
+  rw [ToricSpace.twistedTranslate_origin, ToricSpace.cuspVector_cuspVector,
+    zeroTriangle_shift_opposite_current]
+
+private noncomputable def
+    CuspHoneycombHexagon.reversedOppositeBoundaryArc (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) : unitInterval ≃ₜ positiveBoundary (k + 3) :=
+  unitInterval.symmHomeomorph.trans
+    ((positiveBoundaryArc k).trans (oppositePositiveBoundaryHomeomorph C₀ k))
+
+private theorem
+    CuspHoneycombHexagon.reversedOppositeBoundaryArc_zero (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) : reversedOppositeBoundaryArc C₀ k 0 = positiveBoundaryArc (k + 3) 0 := by
+  apply Subtype.ext
+  apply Subtype.ext
+  apply Subtype.ext
+  change
+    ((oppositePositiveBoundaryHomeomorph C₀ k (positiveBoundaryArc k (unitInterval.symm 0))).1.1 :
+        ToricSpace.Space) =
+      ((positiveBoundaryArc (k + 3) 0).1.1 : ToricSpace.Space)
+  rw [unitInterval.symm_zero, oppositePositiveBoundaryHomeomorph_coe, positiveBoundaryArc_one_coe,
+    opposite_twistedTranslate_origin_current, positiveBoundaryArc_zero_coe]
+  have hi : (k + 3) - 1 = k + 2 := by fin_cases k <;> decide
+  rw [hi]
+
+private theorem CuspHoneycombHexagon.reversedOppositeBoundaryArc_one (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) : reversedOppositeBoundaryArc C₀ k 1 = positiveBoundaryArc (k + 3) 1 := by
+  apply Subtype.ext
+  apply Subtype.ext
+  apply Subtype.ext
+  change
+    ((oppositePositiveBoundaryHomeomorph C₀ k (positiveBoundaryArc k (unitInterval.symm 1))).1.1 :
+        ToricSpace.Space) =
+      ((positiveBoundaryArc (k + 3) 1).1.1 : ToricSpace.Space)
+  rw [unitInterval.symm_one, oppositePositiveBoundaryHomeomorph_coe, positiveBoundaryArc_zero_coe,
+    opposite_twistedTranslate_origin_previous, positiveBoundaryArc_one_coe]
+
+private noncomputable def
+    CuspHoneycombHexagon.compatibleBoundaryArc (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    (k : Fin 6) → unitInterval ≃ₜ positiveBoundary k :=
+  Fin.cases (positiveBoundaryArc 0)
+    (Fin.cases (positiveBoundaryArc 1)
+      (Fin.cases (positiveBoundaryArc 2)
+        (Fin.cases (reversedOppositeBoundaryArc C₀ 0)
+          (Fin.cases (reversedOppositeBoundaryArc C₀ 1)
+            (Fin.cases (reversedOppositeBoundaryArc C₀ 2) (fun i => Fin.elim0 i))))))
+
+private theorem CuspHoneycombHexagon.compatibleBoundaryArc_zero (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) : compatibleBoundaryArc C₀ k 0 = positiveBoundaryArc k 0 := by
+  fin_cases k
+  · rfl
+  · rfl
+  · rfl
+  · exact reversedOppositeBoundaryArc_zero C₀ 0
+  · exact reversedOppositeBoundaryArc_zero C₀ 1
+  · exact reversedOppositeBoundaryArc_zero C₀ 2
+
+private theorem CuspHoneycombHexagon.compatibleBoundaryArc_one (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) : compatibleBoundaryArc C₀ k 1 = positiveBoundaryArc k 1 := by
+  fin_cases k
+  · rfl
+  · rfl
+  · rfl
+  · exact reversedOppositeBoundaryArc_one C₀ 0
+  · exact reversedOppositeBoundaryArc_one C₀ 1
+  · exact reversedOppositeBoundaryArc_one C₀ 2
+
+private theorem
+    CuspHoneycombHexagon.compatibleBoundaryArc_zero_point (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) : (compatibleBoundaryArc C₀ k 0).1 = squarePoint (k - 1) cornerZero := by
+  rw [compatibleBoundaryArc_zero, positiveBoundaryArc_zero]
+
+private theorem CuspHoneycombHexagon.compatibleBoundaryArc_one_point (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) : (compatibleBoundaryArc C₀ k 1).1 = squarePoint k cornerZero := by
+  rw [compatibleBoundaryArc_one, positiveBoundaryArc_one]
+
+private theorem CuspHoneycombHexagon.oppositePositiveBoundaryHomeomorph_twice_coe
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (k : Fin 6) (x : positiveBoundary k) :
+    ((oppositePositiveBoundaryHomeomorph C₀ (k + 3)
+              (oppositePositiveBoundaryHomeomorph C₀ k x)).1.1 :
+        ToricSpace.Space) =
+      (x.1.1 : ToricSpace.Space) := by
+  rw [oppositePositiveBoundaryHomeomorph_coe, oppositePositiveBoundaryHomeomorph_coe,
+    ToricComponent.hexagonRay_opposite, ToricSpace.cuspVector_neg,
+    ToricSpace.twistedTranslate_add, neg_add_cancel, ToricSpace.twistedTranslate_zero]
+
+private theorem CuspHoneycombHexagon.compatibleBoundaryArc_opposite (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) (t : unitInterval) :
+    compatibleBoundaryArc C₀ (k + 3) (unitInterval.symm t) =
+      oppositePositiveBoundaryHomeomorph C₀ k (compatibleBoundaryArc C₀ k t) := by
+  apply Subtype.ext
+  apply Subtype.ext
+  apply Subtype.ext
+  fin_cases k
+  · change
+      ((oppositePositiveBoundaryHomeomorph C₀ 0
+                (positiveBoundaryArc 0 (unitInterval.symm (unitInterval.symm t)))).1.1 :
+          ToricSpace.Space) =
+        ((oppositePositiveBoundaryHomeomorph C₀ 0 (positiveBoundaryArc 0 t)).1.1 :
+          ToricSpace.Space)
+    rw [unitInterval.symm_symm]
+  · change
+      ((oppositePositiveBoundaryHomeomorph C₀ 1
+                (positiveBoundaryArc 1 (unitInterval.symm (unitInterval.symm t)))).1.1 :
+          ToricSpace.Space) =
+        ((oppositePositiveBoundaryHomeomorph C₀ 1 (positiveBoundaryArc 1 t)).1.1 :
+          ToricSpace.Space)
+    rw [unitInterval.symm_symm]
+  · change
+      ((oppositePositiveBoundaryHomeomorph C₀ 2
+                (positiveBoundaryArc 2 (unitInterval.symm (unitInterval.symm t)))).1.1 :
+          ToricSpace.Space) =
+        ((oppositePositiveBoundaryHomeomorph C₀ 2 (positiveBoundaryArc 2 t)).1.1 :
+          ToricSpace.Space)
+    rw [unitInterval.symm_symm]
+  · exact
+      (oppositePositiveBoundaryHomeomorph_twice_coe C₀ 0
+          (positiveBoundaryArc 0 (unitInterval.symm t))).symm
+  · exact
+      (oppositePositiveBoundaryHomeomorph_twice_coe C₀ 1
+          (positiveBoundaryArc 1 (unitInterval.symm t))).symm
+  · exact
+      (oppositePositiveBoundaryHomeomorph_twice_coe C₀ 2
+          (positiveBoundaryArc 2 (unitInterval.symm t))).symm
+
+private theorem
+    CuspHoneycombHexagon.compatibleBoundaryArc_opposite_coe (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) (t : unitInterval) :
+    ((compatibleBoundaryArc C₀ (k + 3) (unitInterval.symm t)).1.1 : ToricSpace.Space) =
+      ToricSpace.twistedTranslate (CuspPositive.positiveTwist C₀)
+        (ToricSpace.cuspVector (ToricComponent.hexagonRay k))
+        ((compatibleBoundaryArc C₀ k t).1.1 : ToricSpace.Space) := by
+  rw [compatibleBoundaryArc_opposite, oppositePositiveBoundaryHomeomorph_coe]
+
+private def CuspHoneycombHexagon.compatibleBoundaryHomeomorph (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    PositiveE0Boundary ≃ₜ PositiveE0Boundary :=
+  boundaryGluingHomeomorph (compatibleBoundaryArc C₀)
+    (fun k => congrArg Subtype.val (compatibleBoundaryArc_zero C₀ k))
+    (fun k => congrArg Subtype.val (compatibleBoundaryArc_one C₀ k))
+
+private theorem
+    CuspHoneycombHexagon.compatibleBoundaryHomeomorph_arc (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) (t : unitInterval) :
+    compatibleBoundaryHomeomorph C₀ (boundaryArcInclusion k (positiveBoundaryArc k t)) =
+      boundaryArcInclusion k (compatibleBoundaryArc C₀ k t) :=
+  boundaryGluingHomeomorph_apply _ _ _ k t
+
+private def CuspHoneycombHexagon.compatibleComponentHomeomorph (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    PositiveE0 ≃ₜ PositiveE0 :=
+  positiveE0BoundaryExtension (compatibleBoundaryHomeomorph C₀)
+
+private theorem
+    CuspHoneycombHexagon.compatibleComponentHomeomorph_arc (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) (t : unitInterval) :
+    compatibleComponentHomeomorph C₀ (positiveBoundaryArc k t).1 =
+      (compatibleBoundaryArc C₀ k t).1 := by
+  exact
+    (positiveE0BoundaryExtension_boundary (compatibleBoundaryHomeomorph C₀)
+          (boundaryArcInclusion k (positiveBoundaryArc k t))).trans
+      (congrArg Subtype.val (compatibleBoundaryHomeomorph_arc C₀ k t))
+
+private theorem CuspHoneycombHexagon.compatibleComponentHomeomorph_mem_boundary_iff
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (x : PositiveE0) (k : Fin 6) :
+    compatibleComponentHomeomorph C₀ x ∈ positiveBoundary k ↔ x ∈ positiveBoundary k := by
+  constructor
+  · intro hx
+    obtain ⟨t, ht⟩ :=
+      (compatibleBoundaryArc C₀ k).surjective ⟨compatibleComponentHomeomorph C₀ x, hx⟩
+    have he : (positiveBoundaryArc k t).1 = x := by
+      apply (compatibleComponentHomeomorph C₀).injective
+      rw [compatibleComponentHomeomorph_arc]
+      exact congrArg Subtype.val ht
+    rw [← he]
+    exact (positiveBoundaryArc k t).2
+  · intro hx
+    obtain ⟨t, ht⟩ := (positiveBoundaryArc k).surjective ⟨x, hx⟩
+    have he : (positiveBoundaryArc k t).1 = x := congrArg Subtype.val ht
+    rw [← he, compatibleComponentHomeomorph_arc]
+    exact (compatibleBoundaryArc C₀ k t).2
+
+private def CuspHoneycombHexagon.compatibleHexagonHomeomorph (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    Hexagon ≃ₜ PositiveE0 :=
+  positiveE0HexagonHomeomorph.symm.trans (compatibleComponentHomeomorph C₀)
+
+private theorem CuspHoneycombHexagon.compatibleHexagonHomeomorph_sideInterval
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (k : Fin 6) (t : unitInterval) :
+    compatibleHexagonHomeomorph C₀
+        ⟨(sideIntervalHomeomorph k t : Plane), (sideIntervalHomeomorph k t).2.1⟩ =
+      (compatibleBoundaryArc C₀ k t).1 :=
+  compatibleComponentHomeomorph_arc C₀ k t
+
+private theorem CuspHoneycombHexagon.compatibleHexagonHomeomorph_mem_boundary_iff
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (x : Hexagon) (k : Fin 6) :
+    compatibleHexagonHomeomorph C₀ x ∈ positiveBoundary k ↔ (x : Plane) ∈ side k := by
+  change
+    compatibleComponentHomeomorph C₀ (positiveE0HexagonHomeomorph.symm x) ∈ positiveBoundary k ↔ _
+  rw [compatibleComponentHomeomorph_mem_boundary_iff]
+  exact
+    (positiveE0HexagonHomeomorph_mem_side_iff (positiveE0HexagonHomeomorph.symm x) k).symm.trans
+      (by rw [Homeomorph.apply_symm_apply])
+
+private def CuspHoneycombHexagon.compatibleCellHomeomorph (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    CuspHoneycombTiling.baseCell ≃ₜ PositiveE0 :=
+  CuspHoneycombTiling.standardHexagonDualHomeomorph.symm.trans (compatibleHexagonHomeomorph C₀)
+
+private theorem
+    CuspHoneycombHexagon.compatibleCellHomeomorph_sideInterval (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) (t : unitInterval) :
+    compatibleCellHomeomorph C₀
+        (CuspHoneycombTiling.standardHexagonDualHomeomorph
+          ⟨(sideIntervalHomeomorph k t : Plane), (sideIntervalHomeomorph k t).2.1⟩) =
+      (compatibleBoundaryArc C₀ k t).1 := by
+  change
+    compatibleHexagonHomeomorph C₀
+        (CuspHoneycombTiling.standardHexagonDualHomeomorph.symm
+          (CuspHoneycombTiling.standardHexagonDualHomeomorph _)) =
+      _
+  rw [Homeomorph.symm_apply_apply]
+  exact compatibleHexagonHomeomorph_sideInterval C₀ k t
+
+private theorem CuspHoneycombHexagon.compatibleCellHomeomorph_mem_boundary_iff
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (x : CuspHoneycombTiling.baseCell) (k : Fin 6) :
+    compatibleCellHomeomorph C₀ x ∈ positiveBoundary k ↔
+      (x : Plane) ∈ CuspHoneycombTiling.cell (ToricComponent.hexagonRay k) := by
+  change
+    compatibleHexagonHomeomorph C₀ (CuspHoneycombTiling.standardHexagonDualHomeomorph.symm x) ∈
+        positiveBoundary k ↔
+      _
+  rw [compatibleHexagonHomeomorph_mem_boundary_iff]
+  have h :=
+    CuspHoneycombTiling.standardHexagonDualHomeomorph_mem_cell_iff_side k
+      (CuspHoneycombTiling.standardHexagonDualHomeomorph.symm x)
+  simpa only [Homeomorph.apply_symm_apply] using h.symm
+
+private theorem ToricFan.areAdjacent_iff_hexagonRay (v w : Fin 2 → ℤ) :
+    AreAdjacent v w ↔ ∃ k : Fin 6, w - v = ToricComponent.hexagonRay k := by
+  have hedges : ∀ i : Fin 3, ∃ k : Fin 6, edgeDirection i = ToricComponent.hexagonRay k := by
+    intro i
+    fin_cases i <;> decide
+  have hrays :
+    ∀ k : Fin 6,
+      ∃ i : Fin 3,
+        ToricComponent.hexagonRay k = edgeDirection i ∨
+          ToricComponent.hexagonRay k = -edgeDirection i := by
+    intro k
+    fin_cases k <;> decide
+  constructor
+  · rintro ⟨i, hi | hi⟩
+    · obtain ⟨k, hk⟩ := hedges i
+      exact ⟨k, hi.trans hk⟩
+    · obtain ⟨k, hk⟩ := hedges i
+      refine ⟨k + 3, hi.trans ?_⟩
+      rw [hk, ToricComponent.hexagonRay_opposite]
+  · rintro ⟨k, hk⟩
+    obtain ⟨i, hi | hi⟩ := hrays k
+    · exact ⟨i, Or.inl (hk.trans hi)⟩
+    · exact ⟨i, Or.inr (hk.trans hi)⟩
+
+private theorem CuspHoneycombTiling.baseCell_inter_cell_nonempty_iff_hexagonRay
+    (v : CuspHoneycombTiling.Lattice) :
+    (baseCell ∩ cell v).Nonempty ↔ v = 0 ∨ ∃ k : Fin 6, v = ToricComponent.hexagonRay k := by
+  rw [baseCell_inter_cell_nonempty_iff]
+  simp [ToricComponent.hexagonRay, Fin.exists_fin_succ, or_assoc, or_left_comm, or_comm]
+
+private theorem CuspHoneycombTiling.cell_inter_cell_nonempty_iff_adjacent
+    (v w : CuspHoneycombTiling.Lattice) :
+    (cell v ∩ cell w).Nonempty ↔ v = w ∨ ToricFan.AreAdjacent v w := by
+  rw [cell_inter_cell_nonempty_iff_baseCell, baseCell_inter_cell_nonempty_iff_hexagonRay, ←
+    ToricFan.areAdjacent_iff_hexagonRay, sub_eq_zero]
+  exact or_congr eq_comm Iff.rfl
+
+private theorem CuspHoneycombHexagon.compatibleCellHomeomorph_mem_rayDivisor_iff
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (x : CuspHoneycombTiling.baseCell) (v : Fin 2 → ℤ) :
+    ((compatibleCellHomeomorph C₀ x).1 : ToricSpace.Space) ∈ ToricSpace.rayDivisor v ↔
+      (x : Plane) ∈ CuspHoneycombTiling.cell v := by
+  by_cases hv : v = 0
+  · subst v
+    exact
+      iff_of_true (compatibleCellHomeomorph C₀ x).1.2
+        (by simpa only [CuspHoneycombTiling.cell_zero] using x.2)
+  constructor
+  · intro hx
+    have hmeet : (ToricSpace.rayDivisor 0 ∩ ToricSpace.rayDivisor v).Nonempty :=
+      ⟨((compatibleCellHomeomorph C₀ x).1 : ToricSpace.Space),
+        (compatibleCellHomeomorph C₀ x).1.2, hx⟩
+    have hadj : ToricFan.AreAdjacent 0 v :=
+      (ToricSpace.rayDivisor_inter_nonempty_iff 0 v (fun h => hv h.symm)).mp hmeet
+    obtain ⟨k, hk⟩ := (ToricFan.areAdjacent_iff_hexagonRay 0 v).mp hadj
+    have hvk : v = ToricComponent.hexagonRay k := by simpa only [sub_zero] using hk
+    subst v
+    change compatibleCellHomeomorph C₀ x ∈ positiveBoundary k at hx
+    exact (compatibleCellHomeomorph_mem_boundary_iff C₀ x k).mp hx
+  · intro hx
+    have hmeet : (CuspHoneycombTiling.baseCell ∩ CuspHoneycombTiling.cell v).Nonempty :=
+      ⟨(x : Plane), x.2, hx⟩
+    rcases (CuspHoneycombTiling.baseCell_inter_cell_nonempty_iff_hexagonRay v).mp hmeet with
+      hzero | ⟨k, hk⟩
+    · exact (hv hzero).elim
+    · subst v
+      exact (compatibleCellHomeomorph_mem_boundary_iff C₀ x k).mpr hx
+
+private theorem
+    CuspHoneycombHexagon.compatibleCellHomeomorph_opposite (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (k : Fin 6) (x : CuspHoneycombTiling.baseCell)
+    (hx : (x : Plane) ∈ CuspHoneycombTiling.cell (ToricComponent.hexagonRay k)) :
+    ((compatibleCellHomeomorph C₀
+            ⟨(x : Plane) - CuspHoneycombTiling.latticePoint (ToricComponent.hexagonRay k),
+              hx⟩).1 :
+        ToricSpace.Space) =
+      ToricSpace.twistedTranslate (CuspPositive.positiveTwist C₀)
+        (ToricSpace.cuspVector (ToricComponent.hexagonRay k))
+        ((compatibleCellHomeomorph C₀ x).1 : ToricSpace.Space) := by
+  let y : Hexagon := CuspHoneycombTiling.standardHexagonDualHomeomorph.symm x
+  have hy : (y : Plane) ∈ side k := by
+    apply (CuspHoneycombTiling.standardHexagonDualHomeomorph_mem_cell_iff_side k y).mp
+    simpa only [y, Homeomorph.apply_symm_apply] using hx
+  obtain ⟨t, ht⟩ := (sideIntervalHomeomorph k).surjective ⟨y, hy⟩
+  have hxt :
+    CuspHoneycombTiling.standardHexagonDualHomeomorph
+        ⟨(sideIntervalHomeomorph k t : Plane), (sideIntervalHomeomorph k t).2.1⟩ =
+      x := by
+    have hyt :
+      (⟨(sideIntervalHomeomorph k t : Plane), (sideIntervalHomeomorph k t).2.1⟩ : Hexagon) = y :=
+      Subtype.ext (congrArg (fun z : side k => (z : Plane)) ht)
+    rw [hyt]
+    exact CuspHoneycombTiling.standardHexagonDualHomeomorph.apply_symm_apply x
+  have hshift :
+    CuspHoneycombTiling.standardHexagonDualHomeomorph
+        ⟨(sideIntervalHomeomorph (k + 3) (unitInterval.symm t) : Plane),
+          (sideIntervalHomeomorph (k + 3) (unitInterval.symm t)).2.1⟩ =
+      ⟨(x : Plane) - CuspHoneycombTiling.latticePoint (ToricComponent.hexagonRay k), hx⟩ := by
+    apply Subtype.ext
+    change
+      CuspHoneycombTiling.dualStandardPlaneHomeomorph.symm
+          (sideIntervalHomeomorph (k + 3) (unitInterval.symm t) : Plane) =
+        (x : Plane) - CuspHoneycombTiling.latticePoint (ToricComponent.hexagonRay k)
+    rw [CuspHoneycombTiling.dual_sideInterval_opposite]
+    exact
+      congrArg
+        (fun z : CuspHoneycombTiling.baseCell =>
+          (z : Plane) - CuspHoneycombTiling.latticePoint (ToricComponent.hexagonRay k))
+        hxt
+  rw [← hshift, compatibleCellHomeomorph_sideInterval, ← hxt,
+    compatibleCellHomeomorph_sideInterval]
+  exact compatibleBoundaryArc_opposite_coe C₀ k t
+
+private def CuspHoneycomb.cellHomeomorph (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v : (CuspHoneycombTiling.Lattice)) :
+    CuspHoneycombTiling.cell v ≃ₜ CuspHoneycombPositive.positiveCell v :=
+  (CuspHoneycombTiling.cellTranslationHomeomorph v).symm.trans
+    ((CuspHoneycombHexagon.compatibleCellHomeomorph C₀).trans
+      (CuspHoneycombPositive.positiveE0CellHomeomorph C₀ v))
+
+@[simp]
+private theorem CuspHoneycomb.cellHomeomorph_coe (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v : (CuspHoneycombTiling.Lattice)) (x : CuspHoneycombTiling.cell v) :
+    ((cellHomeomorph C₀ v x).1.1 : ToricSpace.Space) =
+      ToricSpace.twistedTranslate (CuspPositive.positiveTwist C₀) (-ToricSpace.cuspVector v)
+        ((CuspHoneycombHexagon.compatibleCellHomeomorph C₀
+              ((CuspHoneycombTiling.cellTranslationHomeomorph v).symm x)).1 :
+          ToricSpace.Space) :=
+  rfl
+
+private theorem CuspHoneycomb.cellHomeomorph_mem_positiveCell_iff (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v w : (CuspHoneycombTiling.Lattice)) (x : CuspHoneycombTiling.cell v) :
+    (cellHomeomorph C₀ v x : CuspPositiveRetraction.PositiveCentralFibre) ∈
+        CuspHoneycombPositive.positiveCell w ↔
+      (x : (CuspHoneycombTiling.Plane)) ∈ CuspHoneycombTiling.cell w := by
+  change ((cellHomeomorph C₀ v x).1.1 : ToricSpace.Space) ∈ ToricSpace.rayDivisor w ↔ _
+  rw [cellHomeomorph_coe, ToricSpace.twistedTranslate_mem_rayDivisor, ToricSpace.cuspVector_neg,
+    ToricSpace.cuspVector_cuspVector, neg_neg,
+    CuspHoneycombHexagon.compatibleCellHomeomorph_mem_rayDivisor_iff]
+  change
+    (x : (CuspHoneycombTiling.Plane)) - CuspHoneycombTiling.latticePoint v ∈
+        CuspHoneycombTiling.cell (w - v) ↔
+      _
+  rw [CuspHoneycombTiling.sub_latticePoint_mem_cell_iff]
+  have he : v + (w - v) = w := by abel
+  rw [he]
+
+private theorem CuspHoneycomb.cellHomeomorph_compatible (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v w : (CuspHoneycombTiling.Lattice)) (x : CuspHoneycombTiling.cell v)
+    (y : CuspHoneycombTiling.cell w)
+    (hxy : (x : (CuspHoneycombTiling.Plane)) = (y : (CuspHoneycombTiling.Plane))) :
+    (cellHomeomorph C₀ v x : CuspPositiveRetraction.PositiveCentralFibre) =
+      (cellHomeomorph C₀ w y : CuspPositiveRetraction.PositiveCentralFibre) := by
+  have hxw : (x : (CuspHoneycombTiling.Plane)) ∈ CuspHoneycombTiling.cell w := by
+    rw [hxy]
+    exact y.2
+  have hnonempty : (CuspHoneycombTiling.cell v ∩ CuspHoneycombTiling.cell w).Nonempty :=
+    ⟨x, x.2, hxw⟩
+  rcases (CuspHoneycombTiling.cell_inter_cell_nonempty_iff_adjacent v w).mp hnonempty with rfl |
+    hadj
+  · have he : x = y := Subtype.ext hxy
+    rw [he]
+  obtain ⟨k, hk⟩ := (ToricFan.areAdjacent_iff_hexagonRay v w).mp hadj
+  have hw : w = v + ToricComponent.hexagonRay k := (sub_eq_iff_eq_add.mp hk).trans (add_comm _ _)
+  let a : CuspHoneycombTiling.baseCell := (CuspHoneycombTiling.cellTranslationHomeomorph v).symm x
+  let b : CuspHoneycombTiling.baseCell := (CuspHoneycombTiling.cellTranslationHomeomorph w).symm y
+  have ha :
+    (a : (CuspHoneycombTiling.Plane)) ∈ CuspHoneycombTiling.cell (ToricComponent.hexagonRay k) := by
+    change
+      (x : (CuspHoneycombTiling.Plane)) - CuspHoneycombTiling.latticePoint v ∈
+        CuspHoneycombTiling.cell (ToricComponent.hexagonRay k)
+    apply
+      (CuspHoneycombTiling.sub_latticePoint_mem_cell_iff v (ToricComponent.hexagonRay k) x).mpr
+    simpa only [← hw] using hxw
+  have hb :
+    b =
+      ⟨(a : (CuspHoneycombTiling.Plane)) -
+          CuspHoneycombTiling.latticePoint (ToricComponent.hexagonRay k),
+        ha⟩ := by
+    apply Subtype.ext
+    change
+      (y : (CuspHoneycombTiling.Plane)) - CuspHoneycombTiling.latticePoint w =
+        ((x : (CuspHoneycombTiling.Plane)) - CuspHoneycombTiling.latticePoint v) -
+          CuspHoneycombTiling.latticePoint (ToricComponent.hexagonRay k)
+    rw [← hxy, hw, CuspHoneycombTiling.latticePoint_add]
+    abel
+  apply Subtype.ext
+  apply Subtype.ext
+  rw [cellHomeomorph_coe, cellHomeomorph_coe]
+  change
+    ToricSpace.twistedTranslate (CuspPositive.positiveTwist C₀) (-ToricSpace.cuspVector v)
+        ((CuspHoneycombHexagon.compatibleCellHomeomorph C₀ a).1 : ToricSpace.Space) =
+      ToricSpace.twistedTranslate (CuspPositive.positiveTwist C₀) (-ToricSpace.cuspVector w)
+        ((CuspHoneycombHexagon.compatibleCellHomeomorph C₀ b).1 : ToricSpace.Space)
+  rw [hb, CuspHoneycombHexagon.compatibleCellHomeomorph_opposite C₀ k a ha,
+    ToricSpace.twistedTranslate_add]
+  have hu :
+    -ToricSpace.cuspVector w + ToricSpace.cuspVector (ToricComponent.hexagonRay k) =
+      -ToricSpace.cuspVector v := by
+    rw [hw, ToricSpace.cuspVector_add]
+    abel
+  rw [hu]
+
+private theorem CuspHoneycomb.cellHomeomorph_eq_iff (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v w : (CuspHoneycombTiling.Lattice)) (x : CuspHoneycombTiling.cell v)
+    (y : CuspHoneycombTiling.cell w) :
+    (cellHomeomorph C₀ v x : CuspPositiveRetraction.PositiveCentralFibre) =
+        (cellHomeomorph C₀ w y : CuspPositiveRetraction.PositiveCentralFibre) ↔
+      (x : (CuspHoneycombTiling.Plane)) = (y : (CuspHoneycombTiling.Plane)) := by
+  constructor
+  · intro h
+    have hxw : (x : (CuspHoneycombTiling.Plane)) ∈ CuspHoneycombTiling.cell w :=
+      (cellHomeomorph_mem_positiveCell_iff C₀ v w x).mp
+        (by
+          rw [h]
+          exact (cellHomeomorph C₀ w y).2)
+    have hcomp := cellHomeomorph_compatible C₀ v w x ⟨x, hxw⟩ rfl
+    have he : cellHomeomorph C₀ w ⟨x, hxw⟩ = cellHomeomorph C₀ w y :=
+      Subtype.ext (hcomp.symm.trans h)
+    exact congrArg Subtype.val ((cellHomeomorph C₀ w).injective he)
+  · exact cellHomeomorph_compatible C₀ v w x y
+
+private def CuspHoneycombClosedCover.projection {ι X : Type*} (A : ι → Set X) (p : Σ i, A i) : X :=
+  p.2.1
+
+private theorem CuspHoneycombClosedCover.projection_continuous {ι X : Type*} [TopologicalSpace X]
+    (A : ι → Set X) : Continuous (projection A) :=
+  continuous_sigma_iff.mpr fun _ => continuous_subtype_val
+
+private theorem CuspHoneycombClosedCover.projection_surjective {ι X : Type*} {A : ι → Set X}
+    (hcover : ⋃ i, A i = Set.univ) : Function.Surjective (projection A) := by
+  intro x
+  have hx : x ∈ ⋃ i, A i := by rw [hcover]; trivial
+  obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hx
+  exact ⟨⟨i, x, hi⟩, rfl⟩
+
+private theorem CuspHoneycombClosedCover.projection_isClosedMap {ι X : Type*} [TopologicalSpace X]
+    {A : ι → Set X} (hclosed : ∀ i, IsClosed (A i)) (hloc : LocallyFinite A) :
+    IsClosedMap (projection A) := by
+  intro S hS
+  let F : ι → Set X := fun i => (Subtype.val : A i → X) '' ((fun x : A i => Sigma.mk i x) ⁻¹' S)
+  have hFclosed (i : ι) : IsClosed (F i) :=
+    (hclosed i).isClosedMap_subtype_val _ (hS.preimage continuous_sigmaMk)
+  have hFsub (i : ι) : F i ⊆ A i := by
+    rintro x ⟨a, _, rfl⟩
+    exact a.2
+  have heq : projection A '' S = ⋃ i, F i := by
+    ext x
+    constructor
+    · rintro ⟨⟨i, a⟩, ha, rfl⟩
+      exact Set.mem_iUnion.mpr ⟨i, a, ha, rfl⟩
+    · intro hx
+      obtain ⟨i, a, ha, rfl⟩ := Set.mem_iUnion.mp hx
+      exact ⟨⟨i, a⟩, ha, rfl⟩
+  rw [heq]
+  exact (hloc.subset hFsub).isClosed_iUnion hFclosed
+
+private theorem CuspHoneycombClosedCover.projection_isQuotientMap {ι X : Type*} [TopologicalSpace X]
+    {A : ι → Set X} (hcover : ⋃ i, A i = Set.univ) (hclosed : ∀ i, IsClosed (A i))
+    (hloc : LocallyFinite A) : Topology.IsQuotientMap (projection A) :=
+  (projection_isClosedMap hclosed hloc).isQuotientMap (projection_continuous A)
+    (projection_surjective hcover)
+
+private def CuspHoneycombClosedCover.quotientHomeomorph {X Y : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] {Z : Type*} [TopologicalSpace Z] (f : Z → X) (g : Z → Y)
+    (hf : Topology.IsQuotientMap f) (hg : Topology.IsQuotientMap g)
+    (hfg : ∀ a b, f a = f b ↔ g a = g b) : X ≃ₜ Y
+    where
+  toFun := CuspHoneycombHexagon.CommonFibres.descend f g hf.surjective
+  invFun := CuspHoneycombHexagon.CommonFibres.descend g f hg.surjective
+  left_inv
+    x := by
+    obtain ⟨a, rfl⟩ := hf.surjective x
+    rw [CuspHoneycombHexagon.CommonFibres.descend_apply f g hf.surjective
+        (fun a b => (hfg a b).mp),
+      CuspHoneycombHexagon.CommonFibres.descend_apply g f hg.surjective
+        (fun a b => (hfg a b).mpr)]
+  right_inv
+    y := by
+    obtain ⟨a, rfl⟩ := hg.surjective y
+    rw [CuspHoneycombHexagon.CommonFibres.descend_apply g f hg.surjective
+        (fun a b => (hfg a b).mpr),
+      CuspHoneycombHexagon.CommonFibres.descend_apply f g hf.surjective (fun a b => (hfg a b).mp)]
+  continuous_toFun :=
+    CuspHoneycombHexagon.CommonFibres.descend_continuous f g hf.surjective hf hg.continuous
+      (fun a b => (hfg a b).mp)
+  continuous_invFun :=
+    CuspHoneycombHexagon.CommonFibres.descend_continuous g f hg.surjective hg hf.continuous
+      (fun a b => (hfg a b).mpr)
+
+private theorem CuspHoneycombClosedCover.quotientHomeomorph_apply {X Y : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] {Z : Type*} [TopologicalSpace Z] (f : Z → X) (g : Z → Y)
+    (hf : Topology.IsQuotientMap f) (hg : Topology.IsQuotientMap g)
+    (hfg : ∀ a b, f a = f b ↔ g a = g b) (a : Z) : quotientHomeomorph f g hf hg hfg (f a) = g a :=
+  CuspHoneycombHexagon.CommonFibres.descend_apply f g hf.surjective (fun a b => (hfg a b).mp) a
+
+private def CuspHoneycombClosedCover.sigmaHomeomorph {ι X Y : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] (A : ι → Set X) (B : ι → Set Y) (e : ∀ i, A i ≃ₜ B i) :
+    (Σ i, A i) ≃ₜ (Σ i, B i) where
+  toFun p := ⟨p.1, e p.1 p.2⟩
+  invFun p := ⟨p.1, (e p.1).symm p.2⟩
+  left_inv := by rintro ⟨i, a⟩; simp
+  right_inv := by rintro ⟨i, b⟩; simp
+  continuous_toFun := continuous_sigma_iff.mpr fun i => continuous_sigmaMk.comp (e i).continuous
+  continuous_invFun :=
+    continuous_sigma_iff.mpr fun i => continuous_sigmaMk.comp (e i).symm.continuous
+
+private def
+    CuspHoneycombClosedCover.homeomorph {ι X Y : Type*} [TopologicalSpace X] [TopologicalSpace Y]
+    (A : ι → Set X) (B : ι → Set Y) (e : ∀ i, A i ≃ₜ B i) (hAcov : ⋃ i, A i = Set.univ)
+    (hAcl : ∀ i, IsClosed (A i)) (hAloc : LocallyFinite A) (hBcov : ⋃ i, B i = Set.univ)
+    (hBcl : ∀ i, IsClosed (B i)) (hBloc : LocallyFinite B)
+    (hglue : ∀ i j (x : A i) (y : A j), (x : X) = (y : X) ↔ (e i x : Y) = (e j y : Y)) : X ≃ₜ Y :=
+  quotientHomeomorph (projection A) (projection B ∘ sigmaHomeomorph A B e)
+    (projection_isQuotientMap hAcov hAcl hAloc)
+    ((projection_isQuotientMap hBcov hBcl hBloc).comp (sigmaHomeomorph A B e).isQuotientMap)
+    (fun a b => hglue a.1 b.1 a.2 b.2)
+
+private theorem CuspHoneycombClosedCover.homeomorph_apply {ι X Y : Type*} [TopologicalSpace X]
+    [TopologicalSpace Y] (A : ι → Set X) (B : ι → Set Y) (e : ∀ i, A i ≃ₜ B i)
+    (hAcov : ⋃ i, A i = Set.univ) (hAcl : ∀ i, IsClosed (A i)) (hAloc : LocallyFinite A)
+    (hBcov : ⋃ i, B i = Set.univ) (hBcl : ∀ i, IsClosed (B i)) (hBloc : LocallyFinite B)
+    (hglue : ∀ i j (x : A i) (y : A j), (x : X) = (y : X) ↔ (e i x : Y) = (e j y : Y)) (i : ι)
+    (x : A i) : homeomorph A B e hAcov hAcl hAloc hBcov hBcl hBloc hglue (x : X) = (e i x : Y) :=
+  quotientHomeomorph_apply _ _ _ _ _ (⟨i, x⟩ : Σ i, A i)
+
+private def CuspHoneycomb.honeycombHomeomorph (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    (CuspHoneycombTiling.Plane) ≃ₜ CuspPositiveRetraction.PositiveCentralFibre :=
+  CuspHoneycombClosedCover.homeomorph CuspHoneycombTiling.cell CuspHoneycombPositive.positiveCell
+    (cellHomeomorph C₀) CuspHoneycombTiling.iUnion_cell CuspHoneycombTiling.cell_isClosed
+    CuspHoneycombTiling.cell_locallyFinite CuspHoneycombPositive.iUnion_positiveCell
+    CuspHoneycombPositive.positiveCell_isClosed CuspHoneycombPositive.positiveCells_locallyFinite
+    (fun v w x y => (cellHomeomorph_eq_iff C₀ v w x y).symm)
+
+private theorem CuspHoneycomb.honeycombHomeomorph_cell (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v : (CuspHoneycombTiling.Lattice)) (x : CuspHoneycombTiling.cell v) :
+    honeycombHomeomorph C₀ (x : (CuspHoneycombTiling.Plane)) =
+      (cellHomeomorph C₀ v x : CuspPositiveRetraction.PositiveCentralFibre) :=
+  CuspHoneycombClosedCover.homeomorph_apply CuspHoneycombTiling.cell
+    CuspHoneycombPositive.positiveCell (cellHomeomorph C₀) CuspHoneycombTiling.iUnion_cell
+    CuspHoneycombTiling.cell_isClosed CuspHoneycombTiling.cell_locallyFinite
+    CuspHoneycombPositive.iUnion_positiveCell CuspHoneycombPositive.positiveCell_isClosed
+    CuspHoneycombPositive.positiveCells_locallyFinite
+    (fun v w x y => (cellHomeomorph_eq_iff C₀ v w x y).symm) v x
+
+private theorem CuspHoneycomb.honeycombHomeomorph_cell_coe (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v : (CuspHoneycombTiling.Lattice)) (x : CuspHoneycombTiling.cell v) :
+    ((honeycombHomeomorph C₀ (x : (CuspHoneycombTiling.Plane))).1 : ToricSpace.Space) =
+      ToricSpace.twistedTranslate (CuspPositive.positiveTwist C₀) (-ToricSpace.cuspVector v)
+        ((CuspHoneycombHexagon.compatibleCellHomeomorph C₀
+              ((CuspHoneycombTiling.cellTranslationHomeomorph v).symm x)).1 :
+          ToricSpace.Space) := by rw [honeycombHomeomorph_cell, cellHomeomorph_coe]
+
+private theorem
+    CuspHoneycomb.honeycombHomeomorph_mem_positiveCell_iff (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v : (CuspHoneycombTiling.Lattice)) (x : (CuspHoneycombTiling.Plane)) :
+    honeycombHomeomorph C₀ x ∈ CuspHoneycombPositive.positiveCell v ↔
+      x ∈ CuspHoneycombTiling.cell v := by
+  obtain ⟨w, hw⟩ := CuspHoneycombTiling.exists_mem_cell x
+  rw [honeycombHomeomorph_cell C₀ w ⟨x, hw⟩]
+  exact cellHomeomorph_mem_positiveCell_iff C₀ w v ⟨x, hw⟩
+
+private theorem CuspHoneycomb.cellHomeomorph_translate (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (u v : (CuspHoneycombTiling.Lattice)) (x : CuspHoneycombTiling.cell v) :
+    (cellHomeomorph C₀ (v + ToricSpace.cuspVector u)
+          (CuspHoneycombTiling.cellShiftHomeomorph v (ToricSpace.cuspVector u) x) :
+        CuspPositiveRetraction.PositiveCentralFibre) =
+      CuspCollapse.positiveCentralTranslate C₀ u (cellHomeomorph C₀ v x) := by
+  have hnorm :
+    (CuspHoneycombTiling.cellTranslationHomeomorph (v + ToricSpace.cuspVector u)).symm
+        (CuspHoneycombTiling.cellShiftHomeomorph v (ToricSpace.cuspVector u) x) =
+      (CuspHoneycombTiling.cellTranslationHomeomorph v).symm x := by
+    apply Subtype.ext
+    change
+      ((x : (CuspHoneycombTiling.Plane)) +
+            CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector u)) -
+          CuspHoneycombTiling.latticePoint (v + ToricSpace.cuspVector u) =
+        (x : (CuspHoneycombTiling.Plane)) - CuspHoneycombTiling.latticePoint v
+    rw [CuspHoneycombTiling.latticePoint_add]
+    abel
+  have hu : -ToricSpace.cuspVector (v + ToricSpace.cuspVector u) = u + -ToricSpace.cuspVector v :=
+    by
+    rw [ToricSpace.cuspVector_add, ToricSpace.cuspVector_cuspVector]
+    abel
+  apply Subtype.ext
+  apply Subtype.ext
+  simp only [cellHomeomorph_coe, CuspCollapse.positiveCentralTranslate_coe, hnorm]
+  rw [ToricSpace.twistedTranslate_add, hu]
+
+private theorem CuspHoneycomb.honeycombHomeomorph_equivariant (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (u : (CuspHoneycombTiling.Lattice)) (x : (CuspHoneycombTiling.Plane)) :
+    honeycombHomeomorph C₀ (x + CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector u)) =
+      CuspCollapse.positiveCentralTranslate C₀ u (honeycombHomeomorph C₀ x) := by
+  obtain ⟨v, hx⟩ := CuspHoneycombTiling.exists_mem_cell x
+  let a : CuspHoneycombTiling.cell v := ⟨x, hx⟩
+  have ha : (a : (CuspHoneycombTiling.Plane)) = x := rfl
+  have hshift :=
+    honeycombHomeomorph_cell C₀ (v + ToricSpace.cuspVector u)
+      (CuspHoneycombTiling.cellShiftHomeomorph v (ToricSpace.cuspVector u) a)
+  have hbase :=
+    congrArg (CuspCollapse.positiveCentralTranslate C₀ u) (honeycombHomeomorph_cell C₀ v a).symm
+  simpa only [CuspHoneycombTiling.cellShiftHomeomorph_coe, ha] using
+    hshift.trans ((cellHomeomorph_translate C₀ u v a).trans hbase)
+
+private theorem CuspHoneycomb.honeycombHomeomorph_add_latticePoint (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (v : (CuspHoneycombTiling.Lattice)) (x : (CuspHoneycombTiling.Plane)) :
+    honeycombHomeomorph C₀ (x + CuspHoneycombTiling.latticePoint v) =
+      CuspCollapse.positiveCentralTranslate C₀ (-ToricSpace.cuspVector v)
+        (honeycombHomeomorph C₀ x) := by
+  simpa only [ToricSpace.cuspVector_neg, ToricSpace.cuspVector_cuspVector, neg_neg] using
+    honeycombHomeomorph_equivariant C₀ (-ToricSpace.cuspVector v) x
+
+private theorem CuspHoneycomb.honeycombHomeomorph_symm_equivariant (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (u : (CuspHoneycombTiling.Lattice)) (q : CuspPositiveRetraction.PositiveCentralFibre) :
+    (honeycombHomeomorph C₀).symm (CuspCollapse.positiveCentralTranslate C₀ u q) =
+      (honeycombHomeomorph C₀).symm q +
+        CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector u) := by
+  apply (honeycombHomeomorph C₀).injective
+  rw [Homeomorph.apply_symm_apply, honeycombHomeomorph_equivariant, Homeomorph.apply_symm_apply]
+
+private theorem CuspHoneycomb.standardHexagonDualHomeomorph_vertex_coe (i : Fin 6) :
+    (CuspHoneycombTiling.standardHexagonDualHomeomorph
+          ⟨CuspHoneycombHexagon.vertex i, (CuspHoneycombHexagon.vertex_mem_side_self i).1⟩ :
+        (CuspHoneycombTiling.Plane)) =
+      CuspHoneycombTiling.triangleBarycenter (ToricComponent.zeroTriangle i) :=
+  CuspHoneycombTiling.dual_standard_vertex i
+
+private theorem CuspHoneycomb.compatibleCellHomeomorph_vertex (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (i : Fin 6) :
+    CuspHoneycombHexagon.compatibleCellHomeomorph C₀
+        (CuspHoneycombTiling.standardHexagonDualHomeomorph
+          ⟨CuspHoneycombHexagon.vertex i, (CuspHoneycombHexagon.vertex_mem_side_self i).1⟩) =
+      CuspHoneycombHexagon.squarePoint i CuspHoneycombHexagon.cornerZero := by
+  simpa only [CuspHoneycombHexagon.sideIntervalHomeomorph_one,
+    CuspHoneycombHexagon.compatibleBoundaryArc_one_point] using
+    CuspHoneycombHexagon.compatibleCellHomeomorph_sideInterval C₀ i 1
+
+private theorem CuspHoneycomb.triangleBarycenter_zeroTriangle_mem_baseCell (i : Fin 6) :
+    CuspHoneycombTiling.triangleBarycenter (ToricComponent.zeroTriangle i) ∈
+      CuspHoneycombTiling.baseCell := by
+  rw [← standardHexagonDualHomeomorph_vertex_coe i]
+  exact
+    (CuspHoneycombTiling.standardHexagonDualHomeomorph
+        ⟨CuspHoneycombHexagon.vertex i, (CuspHoneycombHexagon.vertex_mem_side_self i).1⟩).2
+
+private theorem
+    CuspHoneycomb.compatibleCellHomeomorph_triangleBarycenter (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (i : Fin 6) :
+    CuspHoneycombHexagon.compatibleCellHomeomorph C₀
+        ⟨CuspHoneycombTiling.triangleBarycenter (ToricComponent.zeroTriangle i),
+          triangleBarycenter_zeroTriangle_mem_baseCell i⟩ =
+      CuspHoneycombHexagon.squarePoint i CuspHoneycombHexagon.cornerZero := by
+  have hi :
+    (⟨CuspHoneycombTiling.triangleBarycenter (ToricComponent.zeroTriangle i),
+          triangleBarycenter_zeroTriangle_mem_baseCell i⟩ :
+        CuspHoneycombTiling.baseCell) =
+      CuspHoneycombTiling.standardHexagonDualHomeomorph
+        ⟨CuspHoneycombHexagon.vertex i, (CuspHoneycombHexagon.vertex_mem_side_self i).1⟩ := by
+    apply Subtype.ext
+    exact (standardHexagonDualHomeomorph_vertex_coe i).symm
+  rw [hi, compatibleCellHomeomorph_vertex]
+
+private theorem CuspHoneycomb.compatibleCellHomeomorph_triangleBarycenter_coe
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (i : Fin 6) :
+    ((CuspHoneycombHexagon.compatibleCellHomeomorph C₀
+            ⟨CuspHoneycombTiling.triangleBarycenter (ToricComponent.zeroTriangle i),
+              triangleBarycenter_zeroTriangle_mem_baseCell i⟩).1 :
+        ToricSpace.Space) =
+      ToricSpace.inclusion (ToricComponent.zeroTriangle i) 0 := by
+  rw [compatibleCellHomeomorph_triangleBarycenter,
+    CuspHoneycombHexagon.squarePoint_cornerZero_coe]
+
+private theorem CuspHoneycomb.honeycombHomeomorph_zeroTriangleBarycenter_coe
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (i : Fin 6) :
+    ((honeycombHomeomorph C₀
+            (CuspHoneycombTiling.triangleBarycenter (ToricComponent.zeroTriangle i))).1 :
+        ToricSpace.Space) =
+      ToricSpace.inclusion (ToricComponent.zeroTriangle i) 0 := by
+  let a : CuspHoneycombTiling.baseCell :=
+    ⟨CuspHoneycombTiling.triangleBarycenter (ToricComponent.zeroTriangle i),
+      triangleBarycenter_zeroTriangle_mem_baseCell i⟩
+  let x : CuspHoneycombTiling.cell 0 := CuspHoneycombTiling.cellTranslationHomeomorph 0 a
+  have hx :
+    (x : (CuspHoneycombTiling.Plane)) =
+      CuspHoneycombTiling.triangleBarycenter (ToricComponent.zeroTriangle i) := by
+    change
+      (a : (CuspHoneycombTiling.Plane)) + CuspHoneycombTiling.latticePoint 0 =
+        CuspHoneycombTiling.triangleBarycenter (ToricComponent.zeroTriangle i)
+    rw [CuspHoneycombTiling.latticePoint_zero, add_zero]
+  have hnorm : (CuspHoneycombTiling.cellTranslationHomeomorph 0).symm x = a :=
+    (CuspHoneycombTiling.cellTranslationHomeomorph 0).symm_apply_apply a
+  have h := honeycombHomeomorph_cell_coe C₀ 0 x
+  rw [hx, hnorm, ToricSpace.cuspVector_zero, neg_zero, ToricSpace.twistedTranslate_zero] at h
+  exact h.trans (compatibleCellHomeomorph_triangleBarycenter_coe C₀ i)
+
+private theorem CuspHoneycomb.triangle_eq_zeroTriangle_shift (s : ToricFan.Triangle) :
+    ∃ i : Fin 6,
+      ∃ v : (CuspHoneycombTiling.Lattice), s = (ToricComponent.zeroTriangle i).shift v := by
+  rcases s with ⟨a, b, u⟩
+  cases u
+  · refine ⟨0, ![a, b], ?_⟩
+    ext <;> simp [ToricComponent.zeroTriangle, ToricFan.Triangle.shift]
+  · refine ⟨1, ![a + 1, b], ?_⟩
+    ext <;> simp [ToricComponent.zeroTriangle, ToricFan.Triangle.shift]
+
+private theorem
+    CuspHoneycomb.honeycombHomeomorph_triangleBarycenter_coe (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (s : ToricFan.Triangle) :
+    ((honeycombHomeomorph C₀ (CuspHoneycombTiling.triangleBarycenter s)).1 : ToricSpace.Space) =
+      ToricSpace.inclusion s 0 := by
+  obtain ⟨i, v, rfl⟩ := triangle_eq_zeroTriangle_shift s
+  rw [CuspHoneycombTiling.triangleBarycenter_shift, honeycombHomeomorph_add_latticePoint,
+    CuspCollapse.positiveCentralTranslate_coe, honeycombHomeomorph_zeroTriangleBarycenter_coe,
+    ToricSpace.twistedTranslate_origin, ToricSpace.cuspVector_neg,
+    ToricSpace.cuspVector_cuspVector, neg_neg]
+
+private abbrev CuspHoneycomb.PhasePlane :=
+  ToricSpace.CompactFibreTorus × (CuspHoneycombTiling.Plane)
+
+private def CuspHoneycomb.phaseCoordinatesHomeomorph (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    PhasePlane ≃ₜ CuspCollapse.PhasePositiveSpace :=
+  (Homeomorph.refl ToricSpace.CompactFibreTorus).prodCongr (honeycombHomeomorph C₀)
+
+private def CuspHoneycomb.honeycombPolarMap (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    PhasePlane → CuspRetraction.CentralFibre :=
+  CuspCollapse.centralPolarMap ∘ phaseCoordinatesHomeomorph C₀
+
+private theorem CuspHoneycomb.honeycombPolarMap_surjective (C₀ : Matrix (Fin 2) (Fin 2) ℂ) :
+    Function.Surjective (honeycombPolarMap C₀) :=
+  CuspCollapse.centralPolarMap_surjective.comp (phaseCoordinatesHomeomorph C₀).surjective
+
+private def CuspHoneycomb.honeycombDeckMap (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ)
+    (p : PhasePlane) : PhasePlane :=
+  (CuspCollapse.deckFibrePhase C₀ v * p.1,
+    p.2 + CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v))
+
+private def
+    CuspHoneycomb.honeycombCollapseMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    PhasePlane → CuspRetraction.QuotientCentralFibre C ε :=
+  CuspCollapse.centralCollapseMap C ε hε ∘ phaseCoordinatesHomeomorph (C 0)
+
+private theorem
+    CuspHoneycomb.honeycombCollapseMap_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : Continuous (honeycombCollapseMap C ε hε) :=
+  (CuspCollapse.centralCollapseMap_continuous C ε hε).comp
+    (phaseCoordinatesHomeomorph (C 0)).continuous
+
+private theorem
+    CuspHoneycomb.honeycombCollapseMap_surjective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : Function.Surjective (honeycombCollapseMap C ε hε) :=
+  (CuspCollapse.centralCollapseMap_surjective C ε hε).comp
+    (phaseCoordinatesHomeomorph (C 0)).surjective
+
+private theorem CuspHoneycomb.honeycombCollapseMap_isQuotientMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε)) :
+    Topology.IsQuotientMap (honeycombCollapseMap C ε hε) :=
+  (CuspCollapse.centralCollapseMap_isQuotientMap C ε hε hC).comp
+    (phaseCoordinatesHomeomorph (C 0)).isQuotientMap
+
+private def
+    CuspHoneycomb.honeycombCollapseRelation (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (p q : PhasePlane) :
+    Prop :=
+  ∃ v : Fin 2 → ℤ,
+    p.2 = q.2 + CuspHoneycombTiling.latticePoint (ToricSpace.cuspVector v) ∧
+      p.1⁻¹ * (CuspCollapse.deckFibrePhase C₀ v * q.1) ∈
+        MulAction.stabilizer ToricSpace.CompactFibreTorus
+          ((honeycombHomeomorph C₀ p.2).1 : ToricSpace.Space)
+
+private theorem CuspHoneycomb.honeycombCollapseMap_eq_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (p q : PhasePlane) :
+    honeycombCollapseMap C ε hε p = honeycombCollapseMap C ε hε q ↔
+      honeycombCollapseRelation (C 0) p q := by
+  change
+    CuspCollapse.centralCollapseMap C ε hε (phaseCoordinatesHomeomorph (C 0) p) =
+        CuspCollapse.centralCollapseMap C ε hε (phaseCoordinatesHomeomorph (C 0) q) ↔
+      _
+  rw [CuspCollapse.centralCollapseMap_eq_iff]
+  unfold CuspCollapse.centralCollapseRelation honeycombCollapseRelation
+  apply exists_congr
+  intro v
+  change
+    honeycombHomeomorph (C 0) p.2 =
+          CuspCollapse.positiveCentralTranslate (C 0) v (honeycombHomeomorph (C 0) q.2) ∧
+        _ ↔
+      _
+  rw [← honeycombHomeomorph_equivariant, (honeycombHomeomorph (C 0)).injective.eq_iff]
+  rfl
+
+private def
+    ToricCharts.coordinateExp {d : ℕ} (z : CoordinateSpace d) : CoordinateSpace d := fun j =>
+  Complex.exp (z j)
+
+private theorem ToricCharts.coordinateExp_continuous {d : ℕ} : Continuous (@coordinateExp d) :=
+  continuous_pi fun j => Complex.continuous_exp.comp (continuous_apply j)
+
+private theorem ToricCharts.range_coordinateExp {d : ℕ} :
+    Set.range (@coordinateExp d) = (torus : Set (CoordinateSpace d)) := by
+  ext z
+  constructor
+  · rintro ⟨w, rfl⟩ j
+    exact Complex.exp_ne_zero (w j)
+  · intro hz
+    refine ⟨fun j => Complex.log (z j), ?_⟩
+    funext j
+    exact Complex.exp_log (hz j)
+
+private theorem CuspQuotient.affineTube_isOpen (ε : ℝ) : IsOpen (affineTube ε) :=
+  isOpen_lt ToricFan.Triangle.time_holomorphic.continuous.norm continuous_const
+
+private theorem CuspQuotient.affineTube_isSimplyConnected {ε : ℝ} (hε : 0 < ε) :
+    IsSimplyConnected (affineTube ε) := by
+  let :=
+    (affineTube_starConvex ε).contractibleSpace
+      (show (affineTube ε).Nonempty from
+        ⟨0, by simpa [affineTube, ToricFan.Triangle.time] using hε⟩)
+  exact SimplyConnectedSpace.ofContractible _
+
+private def CuspQuotient.logarithmicTube (ε : ℝ) : Set (ToricCharts.CoordinateSpace 3) :=
+  {z | (z 0 + z 1 + z 2).re < Real.log ε}
+
+private theorem CuspQuotient.logarithmicTube_convex (ε : ℝ) : Convex ℝ (logarithmicTube ε) := by
+  apply convex_halfSpace_lt
+  constructor
+  · intro z w
+    simp only [Pi.add_apply, Complex.add_re]
+    ring
+  · intro r z
+    simp only [Pi.smul_apply, Complex.add_re, Complex.smul_re, smul_eq_mul]
+    ring
+
+private theorem CuspQuotient.logarithmicTube_nonempty (ε : ℝ) : (logarithmicTube ε).Nonempty := by
+  refine ⟨![((Real.log ε - 1 : ℝ) : ℂ), 0, 0], ?_⟩
+  simp [logarithmicTube]
+
+private theorem CuspQuotient.norm_time_coordinateExp (z : ToricCharts.CoordinateSpace 3) :
+    ‖ToricFan.Triangle.time (ToricCharts.coordinateExp z)‖ = Real.exp (z 0 + z 1 + z 2).re := by
+  simp only [ToricFan.Triangle.time, ToricCharts.coordinateExp, ← Complex.exp_add,
+    Complex.norm_exp]
+
+private theorem CuspQuotient.coordinateExp_mem_affineTube_iff {ε : ℝ} (hε : 0 < ε)
+    (z : ToricCharts.CoordinateSpace 3) :
+    ToricCharts.coordinateExp z ∈ affineTube ε ↔ z ∈ logarithmicTube ε := by
+  change
+    ‖ToricFan.Triangle.time (ToricCharts.coordinateExp z)‖ < ε ↔ (z 0 + z 1 + z 2).re < Real.log ε
+  rw [norm_time_coordinateExp]
+  exact (Real.lt_log_iff_exp_lt hε).symm
+
+private theorem CuspQuotient.coordinateExp_image_logarithmicTube {ε : ℝ} (hε : 0 < ε) :
+    ToricCharts.coordinateExp '' logarithmicTube ε = ToricCharts.torus ∩ affineTube ε := by
+  ext z
+  constructor
+  · rintro ⟨w, hw, rfl⟩
+    exact ⟨fun j => Complex.exp_ne_zero _, (coordinateExp_mem_affineTube_iff hε w).mpr hw⟩
+  · rintro ⟨hzT, hz⟩
+    obtain ⟨w, rfl⟩ := ToricCharts.range_coordinateExp.symm ▸ hzT
+    exact ⟨w, (coordinateExp_mem_affineTube_iff hε w).mp hz, rfl⟩
+
+private theorem CuspQuotient.torus_inter_affineTube_isPathConnected {ε : ℝ} (hε : 0 < ε) :
+    IsPathConnected (ToricCharts.torus ∩ affineTube ε) := by
+  rw [← coordinateExp_image_logarithmicTube hε]
+  exact
+    ((logarithmicTube_convex ε).isPathConnected (logarithmicTube_nonempty ε)).image
+      ToricCharts.coordinateExp_continuous
+
+private theorem CuspQuotient.domain_inter_affineTube_isPathConnected (A : Matrix (Fin 3) (Fin 3) ℤ)
+    {ε : ℝ} (hε : 0 < ε) : IsPathConnected (ToricCharts.domain A ∩ affineTube ε) := by
+  apply
+    ((ToricCharts.domain_open A).inter (affineTube_isOpen ε)).isConnected_iff_isPathConnected.mp
+  apply (torus_inter_affineTube_isPathConnected hε).isConnected.subset_closure
+  · exact fun _ hz => ⟨ToricCharts.torus_subset_domain A hz.1, hz.2⟩
+  · intro z hz
+    simpa only [Set.inter_comm] using
+      (ToricCharts.torus_dense.open_subset_closure_inter (affineTube_isOpen ε) hz.2)
+
+private theorem CuspQuotient.inclusion_affineTube_subset (s : ToricFan.Triangle) (ε : ℝ) :
+    ToricSpace.inclusion s '' affineTube ε ⊆
+      (ToricSpace.tubeOpen (disc ε) : Set ToricSpace.Space) := by
+  rw [tube_eq_union]
+  exact Set.subset_iUnion (fun t => ToricSpace.inclusion t '' affineTube ε) s
+
+private theorem CuspQuotient.inclusion_affineTube_isOpen (s : ToricFan.Triangle) (ε : ℝ) :
+    IsOpen (ToricSpace.inclusion s '' affineTube ε) :=
+  (ToricSpace.inclusion_openEmbedding s).isOpenMap _ (affineTube_isOpen ε)
+
+private theorem CuspQuotient.inclusion_affineTube_isSimplyConnected (s : ToricFan.Triangle) {ε : ℝ}
+    (hε : 0 < ε) : IsSimplyConnected (ToricSpace.inclusion s '' affineTube ε) :=
+  (ToricSpace.inclusion_openEmbedding s).isEmbedding.isSimplyConnected_image.mpr
+    (affineTube_isSimplyConnected hε)
+
+private theorem CuspQuotient.inclusion_affineTubes_inter (s t : ToricFan.Triangle) (ε : ℝ) :
+    (ToricSpace.inclusion s '' affineTube ε) ∩ (ToricSpace.inclusion t '' affineTube ε) =
+      ToricSpace.inclusion s ''
+        (ToricCharts.domain (ToricFan.Triangle.transition s t) ∩ affineTube ε) := by
+  ext x
+  constructor
+  · rintro ⟨⟨z, hz, rfl⟩, ⟨w, _, hw⟩⟩
+    refine ⟨z, ⟨?_, hz⟩, rfl⟩
+    simpa only [ToricFan.Triangle.chartChange_source] using
+      ((ToricSpace.inclusion_eq_iff s t z w).mp hw.symm).1
+  · rintro ⟨z, ⟨hzD, hz⟩, rfl⟩
+    have hzS : z ∈ (ToricFan.Triangle.chartChange s t).source := by
+      simpa only [ToricFan.Triangle.chartChange_source] using hzD
+    refine ⟨⟨z, hz, rfl⟩, ToricFan.Triangle.chartChange s t z, ?_, ?_⟩
+    · change ‖ToricFan.Triangle.time (ToricFan.Triangle.chartChange s t z)‖ < ε
+      have he :
+        ToricFan.Triangle.time (ToricFan.Triangle.chartChange s t z) = ToricFan.Triangle.time z :=
+        ToricFan.Triangle.chartChange_preserves_time s t hzS
+      rw [he]
+      exact hz
+    · exact ((ToricSpace.inclusion_eq_iff s t z _).mpr ⟨hzS, rfl⟩).symm
+
+private theorem
+    CuspQuotient.inclusion_affineTubes_inter_isPathConnected (s t : ToricFan.Triangle) {ε : ℝ}
+    (hε : 0 < ε) :
+    IsPathConnected
+      ((ToricSpace.inclusion s '' affineTube ε) ∩ (ToricSpace.inclusion t '' affineTube ε)) := by
+  rw [inclusion_affineTubes_inter]
+  exact
+    (domain_inter_affineTube_isPathConnected (ToricFan.Triangle.transition s t) hε).image
+      (ToricSpace.inclusion_openEmbedding s).continuous
+
+private def CuspQuotient.affineTubeChart (ε : ℝ) (s : ToricFan.Triangle) :
+    Set (ToricSpace.Tube (disc ε)) :=
+  Subtype.val ⁻¹' (ToricSpace.inclusion s '' affineTube ε)
+
+private theorem CuspQuotient.affineTubeChart_isOpen (ε : ℝ) (s : ToricFan.Triangle) :
+    IsOpen (affineTubeChart ε s) :=
+  (inclusion_affineTube_isOpen s ε).preimage continuous_subtype_val
+
+private theorem CuspQuotient.affineTubeChart_isSimplyConnected {ε : ℝ} (hε : 0 < ε)
+    (s : ToricFan.Triangle) : IsSimplyConnected (affineTubeChart ε s) := by
+  apply Topology.IsEmbedding.subtypeVal.isSimplyConnected_image.mp
+  have he :
+    (Subtype.val : ToricSpace.Tube (disc ε) → ToricSpace.Space) '' affineTubeChart ε s =
+      ToricSpace.inclusion s '' affineTube ε := by
+    ext x
+    constructor
+    · rintro ⟨y, hy, rfl⟩
+      exact hy
+    · intro hx
+      exact ⟨⟨x, inclusion_affineTube_subset s ε hx⟩, hx, rfl⟩
+  rw [he]
+  exact inclusion_affineTube_isSimplyConnected s hε
+
+private theorem CuspQuotient.affineTubeCharts_inter_isPathConnected {ε : ℝ} (hε : 0 < ε)
+    (s t : ToricFan.Triangle) : IsPathConnected (affineTubeChart ε s ∩ affineTubeChart ε t) := by
+  change
+    IsPathConnected
+      ((Subtype.val : ToricSpace.Tube (disc ε) → ToricSpace.Space) ⁻¹'
+        ((ToricSpace.inclusion s '' affineTube ε) ∩ (ToricSpace.inclusion t '' affineTube ε)))
+  exact
+    (inclusion_affineTubes_inter_isPathConnected s t hε).preimage_coe
+      (Set.inter_subset_left.trans (inclusion_affineTube_subset s ε))
+
+private theorem CuspQuotient.affineTubeCharts_cover (ε : ℝ) :
+    ⋃ s : ToricFan.Triangle, affineTubeChart ε s = Set.univ := by
+  unfold affineTubeChart
+  rw [← Set.preimage_iUnion, ← tube_eq_union]
+  ext x
+  simp
+
+private theorem CuspQuotient.tube_simplyConnected {ε : ℝ} (hε : 0 < ε) :
+    SimplyConnectedSpace (ToricSpace.Tube (disc ε)) := by
+  obtain ⟨x, hx⟩ := tube_charts_common_point hε
+  have hxTube : x ∈ (ToricSpace.tubeOpen (disc ε) : Set ToricSpace.Space) :=
+    inclusion_affineTube_subset ToricSpace.referenceTriangle ε
+      (Set.mem_iInter.mp hx ToricSpace.referenceTriangle)
+  exact
+    simplyConnectedSpace_of_open_cover (affineTubeChart ε) (affineTubeChart_isOpen ε)
+      (affineTubeCharts_cover ε) (affineTubeChart_isSimplyConnected hε) ⟨x, hxTube⟩
+      (fun s => Set.mem_iInter.mp hx s) (affineTubeCharts_inter_isPathConnected hε)
+
+private theorem CuspQuotient.quotient_pathConnected (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : PathConnectedSpace (QuotientSpace C ε) := by
+  let : SimplyConnectedSpace (ToricSpace.Tube (disc ε)) := tube_simplyConnected hε
+  have hq : Function.Surjective (quotientMap C ε) := Quotient.mk_surjective
+  exact hq.pathConnectedSpace (quotientMap_continuous C ε)
+
+private def
+    CuspQuotient.fundamentalGroupEquivAt (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (e : ToricSpace.Tube (disc ε)) :
+    FundamentalGroup (QuotientSpace C ε) (quotientMap C ε e) ≃* LatticeGroup := by
+  let := ToricSpace.tubeAction C (disc ε)
+  let := tube_simplyConnected hε
+  let hq := quotientMap_covering C ε hε hε1 hC hR
+  exact (hq.fundamentalGroupEquiv ⟨e, rfl⟩).trans MulOpposite.opMulEquiv.symm
+
+private def
+    CuspQuotient.fundamentalGroupEquiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (x : QuotientSpace C ε) :
+    FundamentalGroup (QuotientSpace C ε) x ≃* LatticeGroup := by
+  let := ToricSpace.tubeAction C (disc ε)
+  let := tube_simplyConnected hε
+  let hq := quotientMap_covering C ε hε hε1 hC hR
+  let e : quotientMap C ε ⁻¹' { x } := ⟨(hq.surjective x).choose, (hq.surjective x).choose_spec⟩
+  exact (hq.fundamentalGroupEquiv e).trans MulOpposite.opMulEquiv.symm
+
+private theorem
+    CuspQuotient.fundamentalGroupEquivAt_monodromy (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (e : ToricSpace.Tube (disc ε))
+    (γ : FundamentalGroup (QuotientSpace C ε) (quotientMap C ε e)) :
+    letI := ToricSpace.tubeAction C (disc ε)
+    ToricSpace.tubeTranslate C (disc ε) (fundamentalGroupEquivAt C ε hε hε1 hC hR e γ).toAdd e =
+      ((quotientMap_covering C ε hε hε1 hC hR).isCoveringMap.monodromy γ ⟨e, rfl⟩ :
+        ToricSpace.Tube (disc ε)) := by
+  let := ToricSpace.tubeAction C (disc ε)
+  let := tube_simplyConnected hε
+  exact (quotientMap_covering C ε hε hε1 hC hR).unop_fundamentalGroupToMulOpposite_smul
+
+private def CuspQuotient.singularH1Equiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (x : QuotientSpace C ε) :
+    FirstHurewicz.SingularH1 (QuotientSpace C ε) ≃ₗ[ℤ] (Fin 2 → ℤ) := by
+  let := quotient_pathConnected C ε hε
+  exact FirstHurewicz.singularH1EquivOfPi1 x (fundamentalGroupEquiv C ε hε hε1 hC hR x)
+
+private def ToricSpace.fibreCoordinatePhase (s : ToricFan.Triangle) (u : CompactFibreTorus) :
+    CompactTorus := fun i =>
+  ⟨factors s (compactTorusUnits (compactFibrePhase u)) i,
+    mem_sphere_zero_iff_norm.mpr (norm_factors_compactTorusUnits s (compactFibrePhase u) i)⟩
+
+@[simp]
+private theorem ToricSpace.fibreCoordinatePhase_coe (s : ToricFan.Triangle) (u : CompactFibreTorus)
+    (i : Fin 3) :
+    (fibreCoordinatePhase s u i : ℂ) = factors s (compactTorusUnits (compactFibrePhase u)) i :=
+  rfl
+
+private theorem
+    ToricSpace.fibreCoordinatePhase_prod (s : ToricFan.Triangle) (u : CompactFibreTorus) :
+    ∏ i, fibreCoordinatePhase s u i = 1 := by
+  apply Circle.ext
+  change Circle.coeHom (∏ i, fibreCoordinatePhase s u i) = (1 : ℂ)
+  rw [map_prod]
+  change (∏ i, factors s (compactTorusUnits (compactFibrePhase u)) i) = 1
+  simpa [compactFibrePhase, Fin.prod_univ_succ, ToricFan.Triangle.time, mul_assoc] using
+    time_factors s (compactTorusUnits (compactFibrePhase u))
+
+private theorem ToricSpace.monomial_rays_fibreCoordinatePhase (s : ToricFan.Triangle)
+    (u : CompactFibreTorus) :
+    ToricCharts.monomial s.rays (fun i => (fibreCoordinatePhase s u i : ℂ)) = fun i =>
+      (compactFibrePhase u i : ℂ) :=
+  monomial_rays_factors s (compactTorusUnits (compactFibrePhase u))
+
+private theorem ToricSpace.compactFibreAction_inclusion_eq_self_iff_coordinatePhase
+    (u : CompactFibreTorus) (s : ToricFan.Triangle) (z : ToricCharts.CoordinateSpace 3) :
+    compactFibreAction u (ToricSpace.inclusion s z) = ToricSpace.inclusion s z ↔
+      ∀ i, z i ≠ 0 → fibreCoordinatePhase s u i = 1 := by
+  rw [compactFibreAction_eq_compact, compactTorusAction_inclusion_eq_self_iff]
+  simp only [← fibreCoordinatePhase_coe, Circle.coe_eq_one]
+
+private theorem ToricSpace.compactFibrePhase_vertexDifference (s : ToricFan.Triangle) (j k : Fin 3)
+    (a : Circle) :
+    compactFibrePhase (fun i => a ^ (s.vertex k i - s.vertex j i)) =
+      rayCompactPhase (s.vertex j) a⁻¹ * rayCompactPhase (s.vertex k) a := by
+  funext i
+  fin_cases i <;> simp [compactFibrePhase, rayCompactPhase, zpow_sub, mul_comm]
+
+private theorem ToricSpace.factors_vertexDifferencePhase (s : ToricFan.Triangle) (j k : Fin 3)
+    (a : Circle) :
+    factors s (fibreMultiplier (compactFibreUnits (fun i => a ^ (s.vertex k i - s.vertex j i)))) =
+      (fun i => if i = j then (a : ℂ)⁻¹ else 1) * (fun i => if i = k then (a : ℂ) else 1) := by
+  rw [← compactTorusUnits_compactFibrePhase, compactFibrePhase_vertexDifference, map_mul,
+    factors_mul, factors_rayCompactPhase_vertex, factors_rayCompactPhase_vertex]
+  rfl
+
+private theorem ToricSpace.compactFibreAction_inclusion_eq_self_iff_of_at_most_one_zero
+    (u : CompactFibreTorus) (s : ToricFan.Triangle) (z : ToricCharts.CoordinateSpace 3)
+    (j : Fin 3) (hz : ∀ i, i ≠ j → z i ≠ 0) :
+    compactFibreAction u (ToricSpace.inclusion s z) = ToricSpace.inclusion s z ↔ u = 1 := by
+  constructor
+  · intro h
+    have hf := (compactFibreAction_inclusion_eq_self_iff_coordinatePhase u s z).mp h
+    have hrest (i : Fin 3) (hij : i ≠ j) : fibreCoordinatePhase s u i = 1 := hf i (hz i hij)
+    have hp : (∏ i, fibreCoordinatePhase s u i) = fibreCoordinatePhase s u j :=
+      Finset.prod_eq_single j (fun i _ hij => hrest i hij) (by simp)
+    have hj : fibreCoordinatePhase s u j = 1 := hp.symm.trans (fibreCoordinatePhase_prod s u)
+    have hall : fibreCoordinatePhase s u = 1 := by
+      funext i
+      by_cases hij : i = j
+      · simpa only [hij, Pi.one_apply] using hj
+      · exact hrest i hij
+    have hr := monomial_rays_fibreCoordinatePhase s u
+    have hc : (fun i => (fibreCoordinatePhase s u i : ℂ)) = 1 := by
+      rw [hall]
+      rfl
+    rw [hc, ToricCharts.monomial_ones] at hr
+    funext i
+    apply Circle.ext
+    have hi := congrFun hr i.castSucc
+    fin_cases i <;> simpa [compactFibrePhase] using hi.symm
+  · rintro rfl
+    exact compactFibreAction_one _
+
+private theorem
+    ToricSpace.compactFibreAction_inclusion_eq_self_iff_of_two_zero (u : CompactFibreTorus)
+    (s : ToricFan.Triangle) (z : ToricCharts.CoordinateSpace 3) (j k : Fin 3) (hjk : j ≠ k)
+    (hzj : z j = 0) (hzk : z k = 0) (hz : ∀ i, i ≠ j → i ≠ k → z i ≠ 0) :
+    compactFibreAction u (ToricSpace.inclusion s z) = ToricSpace.inclusion s z ↔
+      ∃ a : Circle, ∀ i : Fin 2, u i = a ^ (s.vertex k i - s.vertex j i) := by
+  constructor
+  · intro h
+    have hf := (compactFibreAction_inclusion_eq_self_iff_coordinatePhase u s z).mp h
+    have hrest (i : Fin 3) (hij : i ≠ j) (hik : i ≠ k) : fibreCoordinatePhase s u i = 1 :=
+      hf i (hz i hij hik)
+    have hp : fibreCoordinatePhase s u j * fibreCoordinatePhase s u k = 1 := by
+      calc
+        fibreCoordinatePhase s u j * fibreCoordinatePhase s u k =
+            ∏ i ∈ ({ j, k } : Finset (Fin 3)), fibreCoordinatePhase s u i :=
+          (Finset.prod_pair hjk).symm
+        _ = ∏ i, fibreCoordinatePhase s u i := by
+          apply Finset.prod_subset (Finset.subset_univ _)
+          intro i _ hi
+          have hi' : i ≠ j ∧ i ≠ k := by simpa using hi
+          exact hrest i hi'.1 hi'.2
+        _ = 1 := fibreCoordinatePhase_prod s u
+    have hj : fibreCoordinatePhase s u j = (fibreCoordinatePhase s u k)⁻¹ :=
+      eq_inv_iff_mul_eq_one.mpr hp
+    let a := fibreCoordinatePhase s u k
+    have hc :
+      (fun i => (fibreCoordinatePhase s u i : ℂ)) =
+        (fun i => if i = j then (a : ℂ)⁻¹ else 1) * (fun i => if i = k then (a : ℂ) else 1) := by
+      funext i
+      by_cases hij : i = j
+      · subst i
+        simp [hj, hjk, a]
+      · by_cases hik : i = k
+        · subst i
+          simp [hjk.symm, a]
+        · simp [hij, hik, hrest i hij hik]
+    have hr := monomial_rays_fibreCoordinatePhase s u
+    rw [hc, ToricCharts.monomial_mul, monomial_single_coordinate_phase,
+      monomial_single_coordinate_phase] at hr
+    refine ⟨a, ?_⟩
+    intro i
+    apply Circle.ext
+    have hi := congrFun hr i.castSucc
+    have hphase : compactFibrePhase u i.castSucc = u i := by fin_cases i <;> rfl
+    rw [hphase] at hi
+    change (u i : ℂ) = (a : ℂ) ^ (s.vertex k i - s.vertex j i)
+    rw [ToricFan.Triangle.vertex, ToricFan.Triangle.vertex, zpow_sub₀ a.coe_ne_zero,
+      div_eq_mul_inv]
+    simpa only [Pi.mul_apply, inv_zpow, mul_comm] using hi.symm
+  · rintro ⟨a, ha⟩
+    have hu : u = fun i => a ^ (s.vertex k i - s.vertex j i) := funext ha
+    rw [compactFibreAction, torusAction_inclusion_eq_self_iff, hu]
+    intro i hi
+    have hij : i ≠ j := fun hij => hi (hij ▸ hzj)
+    have hik : i ≠ k := fun hik => hi (hik ▸ hzk)
+    rw [factors_vertexDifferencePhase]
+    simp [hij, hik]
+
+@[simp]
+private theorem ToricSpace.compactFibreAction_inclusion_zero (u : CompactFibreTorus)
+    (s : ToricFan.Triangle) :
+    compactFibreAction u (ToricSpace.inclusion s 0) = ToricSpace.inclusion s 0 := by
+  rw [compactFibreAction, torusAction_inclusion_eq_self_iff]
+  intro i hi
+  exact (hi rfl).elim
+
+private def ToricSpace.edgeCompactPhase (d : Fin 2 → ℤ) : Circle →* CompactFibreTorus
+    where
+  toFun a i := a ^ d i
+  map_one' := by
+    funext i
+    exact one_zpow (d i)
+  map_mul' a
+    b := by
+    funext i
+    exact mul_zpow a b (d i)
+
+private def ToricSpace.edgeCircle (d : Fin 2 → ℤ) : Subgroup CompactFibreTorus :=
+  (edgeCompactPhase d).range
+
+private theorem ToricSpace.mem_edgeCircle_iff (d : Fin 2 → ℤ) (u : CompactFibreTorus) :
+    u ∈ edgeCircle d ↔ ∃ a : Circle, ∀ i : Fin 2, u i = a ^ d i := by
+  change (∃ a : Circle, edgeCompactPhase d a = u) ↔ _
+  constructor
+  · rintro ⟨a, ha⟩
+    exact ⟨a, fun i => (congrFun ha i).symm⟩
+  · rintro ⟨a, ha⟩
+    exact ⟨a, funext fun i => (ha i).symm⟩
+
+private theorem ToricSpace.edgeCompactPhase_continuous (d : Fin 2 → ℤ) :
+    Continuous (edgeCompactPhase d) := by
+  apply continuous_pi
+  intro i
+  exact continuous_id.zpow (d i)
+
+private theorem
+    ToricSpace.compactFibre_stabilizer_eq_bot_of_at_most_one_zero (s : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) (j : Fin 3) (hz : ∀ i, i ≠ j → z i ≠ 0) :
+    MulAction.stabilizer CompactFibreTorus (ToricSpace.inclusion s z) = ⊥ := by
+  ext u
+  rw [MulAction.mem_stabilizer_iff, Subgroup.mem_bot]
+  exact compactFibreAction_inclusion_eq_self_iff_of_at_most_one_zero u s z j hz
+
+private theorem ToricSpace.compactFibre_stabilizer_eq_edgeCircle_of_two_zero (s : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) (j k : Fin 3) (hjk : j ≠ k) (hzj : z j = 0)
+    (hzk : z k = 0) (hz : ∀ i, i ≠ j → i ≠ k → z i ≠ 0) :
+    MulAction.stabilizer CompactFibreTorus (ToricSpace.inclusion s z) =
+      edgeCircle (s.vertex k - s.vertex j) := by
+  ext u
+  rw [MulAction.mem_stabilizer_iff, mem_edgeCircle_iff]
+  exact compactFibreAction_inclusion_eq_self_iff_of_two_zero u s z j k hjk hzj hzk hz
+
+private theorem ToricSpace.compactFibre_stabilizer_inclusion_zero (s : ToricFan.Triangle) :
+    MulAction.stabilizer CompactFibreTorus (ToricSpace.inclusion s 0) = ⊤ := by
+  ext u
+  rw [MulAction.mem_stabilizer_iff]
+  exact ⟨fun _ => Subgroup.mem_top u, fun _ => compactFibreAction_inclusion_zero u s⟩
+
+private theorem CuspHoneycomb.honeycombHomeomorph_branchVertices (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (y : (CuspHoneycombTiling.Plane)) :
+    ToricSpace.branchVertices ((honeycombHomeomorph C₀ y).1 : ToricSpace.Space) =
+      {v : (CuspHoneycombTiling.Lattice) | y ∈ CuspHoneycombTiling.cell v} := by
+  ext v
+  exact honeycombHomeomorph_mem_positiveCell_iff C₀ v y
+
+private theorem CuspHoneycomb.honeycombHomeomorph_branchCount (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (y : (CuspHoneycombTiling.Plane)) :
+    ToricSpace.branchCount ((honeycombHomeomorph C₀ y).1 : ToricSpace.Space) =
+      {v : (CuspHoneycombTiling.Lattice) | y ∈ CuspHoneycombTiling.cell v}.ncard := by
+  rw [← ToricSpace.branchVertices_ncard, honeycombHomeomorph_branchVertices]
+
+private theorem CuspHoneycombTiling.frontier_baseCell :
+    frontier baseCell = ⋃ k : Fin 6, baseCell ∩ cell (ToricComponent.hexagonRay k) := by
+  have hpre : dualStandardPlaneHomeomorph ⁻¹' CuspHoneycombHexagon.Hexagon = baseCell :=
+    Set.ext dualStandardPlaneHomeomorph_mem_hexagon
+  calc
+    frontier baseCell = dualStandardPlaneHomeomorph ⁻¹' frontier CuspHoneycombHexagon.Hexagon := by
+      rw [dualStandardPlaneHomeomorph.preimage_frontier, hpre]
+    _ = ⋃ k : Fin 6, dualStandardPlaneHomeomorph ⁻¹' CuspHoneycombHexagon.side k := by
+      rw [CuspHoneycombHexagon.frontier_hexagon, Set.preimage_iUnion]
+    _ = ⋃ k : Fin 6, baseCell ∩ cell (ToricComponent.hexagonRay k) := by
+      apply Set.iUnion_congr
+      intro k
+      rw [← dual_image_side, Homeomorph.image_eq_preimage_symm, Homeomorph.symm_symm]
+
+private theorem CuspHoneycombTiling.mem_frontier_baseCell_iff (y : Plane) :
+    y ∈ frontier baseCell ↔
+      y ∈ baseCell ∧ ∃ v : CuspHoneycombTiling.Lattice, v ≠ 0 ∧ y ∈ cell v := by
+  rw [frontier_baseCell, Set.mem_iUnion]
+  constructor
+  · rintro ⟨k, hy, hv⟩
+    refine ⟨hy, ToricComponent.hexagonRay k, ?_, hv⟩
+    fin_cases k <;> decide
+  · rintro ⟨hy, v, hv, hyv⟩
+    rcases (baseCell_inter_cell_nonempty_iff_hexagonRay v).mp ⟨y, hy, hyv⟩ with hz | ⟨k, rfl⟩
+    · exact (hv hz).elim
+    · exact ⟨k, hy, hyv⟩
+
+private theorem CuspHoneycombTiling.mem_interior_baseCell_iff (y : Plane) :
+    y ∈ interior baseCell ↔ ∀ v : CuspHoneycombTiling.Lattice, y ∈ cell v ↔ v = 0 := by
+  constructor
+  · intro hy v
+    constructor
+    · intro hyv
+      by_contra hv
+      have hf := (mem_frontier_baseCell_iff y).mpr ⟨interior_subset hy, v, hv, hyv⟩
+      exact ((mem_interior_iff_notMem_frontier (interior_subset hy)).mp hy) hf
+    · rintro rfl
+      simpa only [cell_zero] using interior_subset hy
+  · intro hy
+    have hbase : y ∈ baseCell := by simpa only [cell_zero] using (hy 0).mpr rfl
+    apply (mem_interior_iff_notMem_frontier hbase).mpr
+    intro hf
+    obtain ⟨_, v, hv, hyv⟩ := (mem_frontier_baseCell_iff y).mp hf
+    exact hv ((hy v).mp hyv)
+
+private theorem
+    CuspHoneycombTiling.mem_interior_cell_iff (v : CuspHoneycombTiling.Lattice) (y : Plane) :
+    y ∈ interior (cell v) ↔ ∀ w : CuspHoneycombTiling.Lattice, y ∈ cell w ↔ w = v := by
+  have hpre : (Homeomorph.subRight (latticePoint v)) ⁻¹' baseCell = cell v := rfl
+  have hint : y ∈ interior (cell v) ↔ y - latticePoint v ∈ interior baseCell := by
+    rw [← hpre, ← Homeomorph.preimage_interior]
+    rfl
+  rw [hint, mem_interior_baseCell_iff]
+  constructor
+  · intro hy w
+    have h := hy (w - v)
+    rw [sub_latticePoint_mem_cell_iff, add_comm v (w - v), sub_add_cancel] at h
+    exact h.trans sub_eq_zero
+  · intro hy w
+    rw [sub_latticePoint_mem_cell_iff, hy, add_eq_left]
+
+private theorem CuspHoneycombTiling.containingCells_eq_singleton_iff (y : Plane)
+    (v : CuspHoneycombTiling.Lattice) :
+    {w : CuspHoneycombTiling.Lattice | y ∈ cell w} = { v } ↔ y ∈ interior (cell v) := by
+  rw [mem_interior_cell_iff]
+  exact Set.ext_iff
+
+private theorem CuspHoneycombTiling.containingCells_ncard_eq_one_iff (y : Plane) :
+    {v : CuspHoneycombTiling.Lattice | y ∈ cell v}.ncard = 1 ↔
+      ∃ v : CuspHoneycombTiling.Lattice, y ∈ interior (cell v) := by
+  rw [Set.ncard_eq_one]
+  exact exists_congr fun v => containingCells_eq_singleton_iff y v
+
+private theorem
+    CuspHoneycomb.honeycombHomeomorph_branchCount_eq_one_iff (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (y : CuspHoneycombTiling.Plane) :
+    ToricSpace.branchCount ((honeycombHomeomorph C₀ y).1 : ToricSpace.Space) = 1 ↔
+      ∃ v : CuspHoneycombTiling.Lattice, y ∈ interior (CuspHoneycombTiling.cell v) := by
+  rw [honeycombHomeomorph_branchCount, CuspHoneycombTiling.containingCells_ncard_eq_one_iff]
+
+private theorem ToricSpace.compactFibre_stabilizer_eq_bot_of_branchVertices_singleton (x : Space)
+    (v : Fin 2 → ℤ) (hx : branchVertices x = { v }) :
+    MulAction.stabilizer CompactFibreTorus x = ⊥ := by
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  have hv : ToricSpace.inclusion s z ∈ rayDivisor v := by
+    change v ∈ branchVertices (ToricSpace.inclusion s z)
+    rw [hx]
+    exact Set.mem_singleton v
+  obtain ⟨j, _, hjv⟩ := (mem_rayDivisor_inclusion v s z).mp hv
+  apply compactFibre_stabilizer_eq_bot_of_at_most_one_zero s z j
+  intro i hij hzi
+  have hi : s.vertex i ∈ branchVertices (ToricSpace.inclusion s z) :=
+    (mem_rayDivisor_vertex s i z).mpr hzi
+  have hiv : s.vertex i = v := by simpa only [hx, Set.mem_singleton_iff] using hi
+  exact hij (s.vertex_injective (hiv.trans hjv.symm))
+
+private theorem CuspHoneycomb.honeycombHomeomorph_stabilizer_eq_bot (C₀ : Matrix (Fin 2) (Fin 2) ℂ)
+    (y : (CuspHoneycombTiling.Plane)) (v : (CuspHoneycombTiling.Lattice))
+    (hcells : {u : (CuspHoneycombTiling.Lattice) | y ∈ CuspHoneycombTiling.cell u} = { v }) :
+    MulAction.stabilizer ToricSpace.CompactFibreTorus
+        ((honeycombHomeomorph C₀ y).1 : ToricSpace.Space) =
+      ⊥ :=
+  ToricSpace.compactFibre_stabilizer_eq_bot_of_branchVertices_singleton _ v
+    ((honeycombHomeomorph_branchVertices C₀ y).trans hcells)
+
+private theorem CuspHoneycomb.honeycombHomeomorph_stabilizer_eq_bot_of_mem_interior
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (y : (CuspHoneycombTiling.Plane))
+    (v : (CuspHoneycombTiling.Lattice)) (hy : y ∈ interior (CuspHoneycombTiling.cell v)) :
+    MulAction.stabilizer ToricSpace.CompactFibreTorus
+        ((honeycombHomeomorph C₀ y).1 : ToricSpace.Space) =
+      ⊥ :=
+  honeycombHomeomorph_stabilizer_eq_bot C₀ y v
+    ((CuspHoneycombTiling.containingCells_eq_singleton_iff y v).mpr hy)
+
+private theorem CuspHoneycomb.honeycombHomeomorph_stabilizer_triangleBarycenter
+    (C₀ : Matrix (Fin 2) (Fin 2) ℂ) (s : ToricFan.Triangle) :
+    MulAction.stabilizer ToricSpace.CompactFibreTorus
+        ((honeycombHomeomorph C₀ (CuspHoneycombTiling.triangleBarycenter s)).1 :
+          ToricSpace.Space) =
+      ⊤ := by
+  rw [honeycombHomeomorph_triangleBarycenter_coe]
+  exact ToricSpace.compactFibre_stabilizer_inclusion_zero s
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Toric/DiagonalQuotient1.lean b/LeanPool/HopfProblem/Toric/DiagonalQuotient1.lean
new file mode 100644
index 000000000..d2132af7e
--- /dev/null
+++ b/LeanPool/HopfProblem/Toric/DiagonalQuotient1.lean
@@ -0,0 +1,406 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Uniformization.SpecialPeriods6
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods6
+
+/-!
+# Hopf problem: toric · diagonal quotient 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def
+    DiagonalQuotient.fibreHomeomorphOfLocalTrivializations {E B F J : Type*} [TopologicalSpace E]
+    [TopologicalSpace B] [TopologicalSpace F] (f : E → B) (U : J → TopologicalSpace.Opens B)
+    (h : ∀ i, (f ⁻¹' (U i : Set B)) ≃ₜ ((U i) × F)) (hbase : ∀ i x, ((h i x).1 : B) = f x.val)
+    (i : J) (b : B) (hb : b ∈ U i) : (f ⁻¹' { b }) ≃ₜ F := by
+  let lift : (f ⁻¹' { b }) → (f ⁻¹' (U i : Set B)) := fun x =>
+    ⟨x.val, by
+      change f x.val ∈ U i
+      rw [show f x.val = b from x.property]
+      exact hb⟩
+  let inv : F → (f ⁻¹' { b }) := fun t =>
+    ⟨((h i).symm (⟨b, hb⟩, t)).val,
+      by
+      change f ((h i).symm (⟨b, hb⟩, t)).val = b
+      rw [← hbase i]
+      simp⟩
+  have hlift : Continuous lift := continuous_subtype_val.subtype_mk _
+  have hpair (x : (f ⁻¹' { b })) : ((⟨b, hb⟩ : U i), (h i (lift x)).2) = h i (lift x) := by
+    apply Prod.ext
+    · apply Subtype.ext
+      exact ((hbase i (lift x)).trans x.property).symm
+    · rfl
+  refine
+    { toFun := fun x => (h i (lift x)).2
+      invFun := inv
+      left_inv := ?_
+      right_inv := ?_
+      continuous_toFun := continuous_snd.comp ((h i).continuous.comp hlift)
+      continuous_invFun := ?_ }
+  · intro x
+    apply Subtype.ext
+    change ((h i).symm ((⟨b, hb⟩ : U i), (h i (lift x)).2)).val = x.val
+    rw [hpair x, (h i).symm_apply_apply]
+  · intro t
+    change (h i (lift (inv t))).2 = t
+    have hinv : lift (inv t) = (h i).symm (⟨b, hb⟩, t) := by
+      apply Subtype.ext
+      rfl
+    rw [hinv, (h i).apply_symm_apply]
+  · exact
+      (continuous_subtype_val.comp
+            ((h i).symm.continuous.comp (continuous_const.prodMk continuous_id))).subtype_mk
+        _
+
+private theorem DiagonalQuotient.restrictPreimage_eq_fst_comp {E B F J : Type*} [TopologicalSpace E]
+    [TopologicalSpace B] [TopologicalSpace F] (f : E → B) (U : J → TopologicalSpace.Opens B)
+    (h : ∀ i, (f ⁻¹' (U i : Set B)) ≃ₜ ((U i) × F)) (hbase : ∀ i x, ((h i x).1 : B) = f x.val)
+    (i : J) : (U i : Set B).restrictPreimage f = Prod.fst ∘ h i := by
+  funext x
+  apply Subtype.ext
+  exact (hbase i x).symm
+
+private theorem DiagonalQuotient.restrictPreimage_proper_of_localTrivializations {E B F J : Type*}
+    [TopologicalSpace E] [TopologicalSpace B] [TopologicalSpace F] [CompactSpace F] (f : E → B)
+    (U : J → TopologicalSpace.Opens B) (h : ∀ i, (f ⁻¹' (U i : Set B)) ≃ₜ ((U i) × F))
+    (hbase : ∀ i x, ((h i x).1 : B) = f x.val) (i : J) :
+    IsProperMap ((U i : Set B).restrictPreimage f) := by
+  rw [restrictPreimage_eq_fst_comp f U h hbase i]
+  exact isProperMap_fst_of_compactSpace.comp (h i).isProperMap
+
+private theorem
+    DiagonalQuotient.proper_of_localTrivializations {E B F J : Type*} [TopologicalSpace E]
+    [TopologicalSpace B] [TopologicalSpace F] [CompactSpace F] (f : E → B) (hf : Continuous f)
+    (U : J → TopologicalSpace.Opens B) (hU : TopologicalSpace.IsOpenCover U)
+    (h : ∀ i, (f ⁻¹' (U i : Set B)) ≃ₜ ((U i) × F)) (hbase : ∀ i x, ((h i x).1 : B) = f x.val) :
+    IsProperMap f := by
+  have hp := restrictPreimage_proper_of_localTrivializations f U h hbase
+  apply isProperMap_iff_isClosedMap_and_compact_fibers.mpr
+  refine ⟨hf, hU.isClosedMap_iff_restrictPreimage.mpr (fun i => (hp i).isClosedMap), ?_⟩
+  intro b
+  obtain ⟨i, hi⟩ := hU.exists_mem b
+  have hc :=
+    ((hp i).isCompact_preimage (isCompact_singleton (x := (⟨b, hi⟩ : U i)))).image
+      continuous_subtype_val
+  simpa only [Set.image_val_preimage_restrictPreimage, Set.image_singleton] using hc
+
+private theorem
+    DiagonalQuotient.t2Space_of_localTrivializations {E B F J : Type*} [TopologicalSpace E]
+    [TopologicalSpace B] [TopologicalSpace F] [T2Space B] [T2Space F] (f : E → B)
+    (hf : Continuous f) (U : J → TopologicalSpace.Opens B) (hU : TopologicalSpace.IsOpenCover U)
+    (h : ∀ i, (f ⁻¹' (U i : Set B)) ≃ₜ ((U i) × F)) :
+    T2Space E := by
+  constructor
+  intro x y hxy
+  by_cases hb : f x = f y
+  · obtain ⟨i, hi⟩ := hU.exists_mem (f x)
+    have hx : x ∈ f ⁻¹' (U i : Set B) := hi
+    have hy : y ∈ f ⁻¹' (U i : Set B) := by
+      change f y ∈ U i
+      rw [← hb]
+      exact hi
+    let a : f ⁻¹' (U i : Set B) := ⟨x, hx⟩
+    let b : f ⁻¹' (U i : Set B) := ⟨y, hy⟩
+    have hab : a ≠ b := fun he => hxy (congrArg Subtype.val he)
+    let : T2Space (f ⁻¹' (U i : Set B)) := (h i).symm.t2Space
+    obtain ⟨V, W, hV, hW, ha, hb', hVW⟩ := t2_separation hab
+    have hopen : IsOpen (f ⁻¹' (U i : Set B)) := (U i).isOpen.preimage hf
+    refine
+      ⟨Subtype.val '' V, Subtype.val '' W, hopen.isOpenMap_subtype_val _ hV,
+        hopen.isOpenMap_subtype_val _ hW, ⟨a, ha, rfl⟩, ⟨b, hb', rfl⟩, ?_⟩
+    apply Set.disjoint_left.mpr
+    rintro z ⟨a', ha', hza⟩ ⟨b', hb'', hzb⟩
+    have hab' : a' = b' := Subtype.ext (hza.trans hzb.symm)
+    exact (Set.disjoint_left.mp hVW) ha' (hab'.symm ▸ hb'')
+  · obtain ⟨V, W, hV, hW, hx, hy, hVW⟩ := t2_separation hb
+    exact ⟨f ⁻¹' V, f ⁻¹' W, hV.preimage hf, hW.preimage hf, hx, hy, hVW.preimage f⟩
+
+/-- The orbit-space quotient of a group action on the base. -/
+public
+abbrev DiagonalQuotient.BaseSpace (G B : Type*) [Group G] [MulAction G B] :=
+  MulAction.orbitRel.Quotient G B
+
+private abbrev DiagonalQuotient.Space (G B F : Type*) [Group G] [MulAction G B] [MulAction G F] :=
+  MulAction.orbitRel.Quotient G (B × F)
+
+/-- The quotient map from a base to its orbit space. -/
+public
+def DiagonalQuotient.baseQuotient (G B : Type*) [Group G] [MulAction G B] : B → BaseSpace G B :=
+  Quotient.mk (MulAction.orbitRel G B)
+
+private def DiagonalQuotient.quotient (G B F : Type*) [Group G] [MulAction G B] [MulAction G F] :
+    B × F → Space G B F :=
+  Quotient.mk (MulAction.orbitRel G (B × F))
+
+private theorem DiagonalQuotient.quotient_surjective (G B F : Type*) [Group G] [MulAction G B]
+    [MulAction G F] : Function.Surjective (quotient G B F) :=
+  Quotient.mk_surjective
+
+private theorem
+    DiagonalQuotient.quotient_eq_iff (G B F : Type*) [Group G] [MulAction G B] [MulAction G F]
+    (x y : B × F) : quotient G B F x = quotient G B F y ↔ ∃ g : G, g • y = x :=
+  Quotient.eq''
+
+@[simp]
+private theorem
+    DiagonalQuotient.quotient_smul (G B F : Type*) [Group G] [MulAction G B] [MulAction G F]
+    (g : G) (x : B × F) : quotient G B F (g • x) = quotient G B F x :=
+  (quotient_eq_iff G B F _ _).mpr ⟨g, rfl⟩
+
+private def DiagonalQuotient.projection (G B F : Type*) [Group G] [MulAction G B] [MulAction G F] :
+    Space G B F → BaseSpace G B :=
+  Quotient.lift (fun x : B × F => baseQuotient G B x.1)
+    (by
+      rintro x y ⟨g, hg⟩
+      exact Quotient.sound ⟨g, congrArg Prod.fst hg⟩)
+
+private def
+    DiagonalQuotient.fibreInclusion (G B F : Type*) [Group G] [MulAction G B] [MulAction G F]
+    (b : B) (f : F) : Space G B F :=
+  quotient G B F (b, f)
+
+private theorem DiagonalQuotient.baseQuotient_continuous (G B : Type*) [Group G] [MulAction G B]
+    [TopologicalSpace B] : Continuous (baseQuotient G B) :=
+  continuous_quot_mk
+
+private theorem DiagonalQuotient.quotient_continuous (G B F : Type*) [Group G] [MulAction G B]
+    [MulAction G F] [TopologicalSpace B] [TopologicalSpace F] : Continuous (quotient G B F) :=
+  continuous_quot_mk
+
+private theorem DiagonalQuotient.quotient_isQuotientMap (G B F : Type*) [Group G] [MulAction G B]
+    [MulAction G F] [TopologicalSpace B] [TopologicalSpace F] :
+    Topology.IsQuotientMap (quotient G B F) :=
+  isQuotientMap_quotient_mk'
+
+private theorem DiagonalQuotient.projection_continuous (G B F : Type*) [Group G] [MulAction G B]
+    [MulAction G F] [TopologicalSpace B] [TopologicalSpace F] : Continuous (projection G B F) :=
+  (quotient_isQuotientMap G B F).continuous_iff.mpr
+    ((baseQuotient_continuous G B).comp continuous_fst)
+
+private theorem DiagonalQuotient.fibreInclusion_continuous (G B F : Type*) [Group G] [MulAction G B]
+    [MulAction G F] [TopologicalSpace B] [TopologicalSpace F] (b : B) :
+    Continuous (fibreInclusion G B F b) :=
+  (quotient_continuous G B F).comp (continuous_const.prodMk continuous_id)
+
+private def DiagonalQuotient.baseLocalInverse {G : Type*} {B : Type*} [Group G] [MulAction G B]
+    [TopologicalSpace B] (hq : IsQuotientCoveringMap (baseQuotient G B) G) (b : B) :
+    OpenPartialHomeomorph (BaseSpace G B) B :=
+  hq.isCoveringMap.isLocalHomeomorph.localInverseAt b
+
+private theorem DiagonalQuotient.baseQuotient_localInverse {G : Type*} {B : Type*} [Group G]
+    [MulAction G B] [TopologicalSpace B] (hq : IsQuotientCoveringMap (baseQuotient G B) G) (b : B)
+    {x : BaseSpace G B} (hx : x ∈ (baseLocalInverse hq b).source) :
+    baseQuotient G B (baseLocalInverse hq b x) = x :=
+  hq.isCoveringMap.isLocalHomeomorph.apply_localInverseAt_of_mem hx
+
+private def
+    DiagonalQuotient.patch {G : Type*} {B : Type*} [Group G] [MulAction G B] [TopologicalSpace B]
+    (hq : IsQuotientCoveringMap (baseQuotient G B) G) (b : B) :
+    TopologicalSpace.Opens (BaseSpace G B) :=
+  ⟨(baseLocalInverse hq b).source, (baseLocalInverse hq b).open_source⟩
+
+private theorem
+    DiagonalQuotient.baseQuotient_mem_patch {G : Type*} {B : Type*} [Group G] [MulAction G B]
+    [TopologicalSpace B] (hq : IsQuotientCoveringMap (baseQuotient G B) G) (b : B) :
+    baseQuotient G B b ∈ patch hq b :=
+  hq.isCoveringMap.isLocalHomeomorph.apply_self_mem_localInverseAt_source
+
+private theorem DiagonalQuotient.patch_cover {G : Type*} {B : Type*} [Group G] [MulAction G B]
+    [TopologicalSpace B] (hq : IsQuotientCoveringMap (baseQuotient G B) G) :
+    TopologicalSpace.IsOpenCover (patch hq) := by
+  apply TopologicalSpace.IsOpenCover.of_sets (fun b => (baseLocalInverse hq b).open_source)
+  apply Set.eq_univ_of_forall
+  intro x
+  obtain ⟨b, rfl⟩ := hq.surjective x
+  exact Set.mem_iUnion.mpr ⟨b, baseQuotient_mem_patch hq b⟩
+
+private theorem
+    DiagonalQuotient.fibreInclusion_injective {G : Type*} {B : Type*} {F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B]
+    (hq : IsQuotientCoveringMap (baseQuotient G B) G) (b : B) :
+    Function.Injective (fibreInclusion G B F b) := by
+  let := hq.isCancelSMul
+  intro x y hxy
+  obtain ⟨g, hg⟩ := (quotient_eq_iff G B F _ _).mp hxy
+  have hb : g • b = b := congrArg Prod.fst hg
+  have hg1 : g = 1 := IsCancelSMul.right_cancel _ _ b (hb.trans (one_smul G b).symm)
+  simpa only [hg1, one_smul] using (congrArg Prod.snd hg).symm
+
+private theorem DiagonalQuotient.quotientCoveringMap {G : Type*} {B : Type*} {F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B] [TopologicalSpace F]
+    (hq : IsQuotientCoveringMap (baseQuotient G B) G) [ContinuousConstSMul G F] :
+    IsQuotientCoveringMap (quotient G B F) G
+    where
+  toIsQuotientMap := quotient_isQuotientMap G B F
+  continuous_const_smul
+    g := (hq.continuous_const_smul g).prodMap (ContinuousConstSMul.continuous_const_smul g)
+  apply_eq_iff_mem_orbit := Quotient.eq''
+  disjoint
+    x := by
+    obtain ⟨U, hU, hd⟩ := hq.disjoint x.1
+    refine ⟨Prod.fst ⁻¹' U, continuous_fst.continuousAt hU, ?_⟩
+    rintro g ⟨z, ⟨w, hw, rfl⟩, hz⟩
+    exact hd g ⟨g • w.1, ⟨w.1, hw, rfl⟩, hz⟩
+
+private theorem
+    DiagonalQuotient.quotient_isCoveringMap {G : Type*} {B : Type*} {F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B] [TopologicalSpace F]
+    (hq : IsQuotientCoveringMap (baseQuotient G B) G) [ContinuousConstSMul G F] :
+    IsCoveringMap (quotient G B F) :=
+  (quotientCoveringMap (F := F) hq).isCoveringMap
+
+private theorem
+    DiagonalQuotient.quotient_isOpenQuotientMap {G : Type*} {B : Type*} {F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B] [TopologicalSpace F]
+    (hq : IsQuotientCoveringMap (baseQuotient G B) G) [ContinuousConstSMul G F] :
+    IsOpenQuotientMap (quotient G B F) := by
+  let := hq.toContinuousConstSMul
+  exact MulAction.isOpenQuotientMap_quotientMk
+
+private def DiagonalQuotient.patchMap {G : Type*} {B : Type*} {F : Type*} [Group G] [MulAction G B]
+    [MulAction G F] [TopologicalSpace B] (hq : IsQuotientCoveringMap (baseQuotient G B) G) (b : B)
+    (x : patch hq b × F) : Space G B F :=
+  quotient G B F (baseLocalInverse hq b x.1, x.2)
+
+@[simp]
+private theorem DiagonalQuotient.projection_patchMap {G : Type*} {B : Type*} {F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B]
+    (hq : IsQuotientCoveringMap (baseQuotient G B) G) (b : B) (x : patch hq b × F) :
+    projection G B F (patchMap hq b x) = (x.1 : BaseSpace G B) :=
+  baseQuotient_localInverse hq b x.1.property
+
+private theorem DiagonalQuotient.patchMap_injective {G : Type*} {B : Type*} {F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B]
+    (hq : IsQuotientCoveringMap (baseQuotient G B) G) (b : B) :
+    Function.Injective (patchMap (F := F) hq b) := by
+  let := hq.isCancelSMul
+  intro x y hxy
+  have hbase : x.1 = y.1 :=
+    Subtype.ext (by simpa only [projection_patchMap] using congrArg (projection G B F) hxy)
+  obtain ⟨g, hg⟩ := (quotient_eq_iff G B F _ _).mp hxy
+  have hgbase : g • baseLocalInverse hq b y.1 = baseLocalInverse hq b y.1 := by
+    have he := congrArg Prod.fst hg
+    change g • baseLocalInverse hq b y.1 = baseLocalInverse hq b x.1 at he
+    simpa only [hbase] using he
+  have hg1 : g = 1 :=
+    IsCancelSMul.right_cancel _ _ (baseLocalInverse hq b y.1)
+      (hgbase.trans (one_smul G (baseLocalInverse hq b y.1)).symm)
+  apply Prod.ext hbase
+  simpa only [hg1, one_smul] using (congrArg Prod.snd hg).symm
+
+private theorem DiagonalQuotient.patchMap_continuous {G : Type*} {B : Type*} {F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B] [TopologicalSpace F]
+    (hq : IsQuotientCoveringMap (baseQuotient G B) G) (b : B) :
+    Continuous (patchMap (F := F) hq b) :=
+  (quotient_continuous G B F).comp
+    ((baseLocalInverse hq b).isOpenEmbedding_restrict.continuous.prodMap continuous_id)
+
+private theorem
+    DiagonalQuotient.patchMap_openEmbedding {G : Type*} {B : Type*} {F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B] [TopologicalSpace F]
+    (hq : IsQuotientCoveringMap (baseQuotient G B) G) [ContinuousConstSMul G F] (b : B) :
+    Topology.IsOpenEmbedding (patchMap (F := F) hq b) :=
+  .of_continuous_injective_isOpenMap (patchMap_continuous hq b) (patchMap_injective hq b)
+    ((quotient_isOpenQuotientMap (F := F) hq).isOpenMap.comp
+      ((baseLocalInverse hq b).isOpenEmbedding_restrict.isOpenMap.prodMap IsOpenMap.id))
+
+private theorem DiagonalQuotient.patchMap_range {G : Type*} {B : Type*} {F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B]
+    (hq : IsQuotientCoveringMap (baseQuotient G B) G) (b : B) :
+    Set.range (patchMap (F := F) hq b) = projection G B F ⁻¹' (patch hq b : Set _) := by
+  ext y
+  constructor
+  · rintro ⟨x, rfl⟩
+    rw [Set.mem_preimage, projection_patchMap]
+    exact x.1.property
+  · intro hy
+    obtain ⟨⟨z, f⟩, rfl⟩ := quotient_surjective G B F y
+    change baseQuotient G B z ∈ patch hq b at hy
+    obtain ⟨g, hg⟩ := hq.apply_eq_iff_mem_orbit.mp (baseQuotient_localInverse hq b hy)
+    refine ⟨(⟨baseQuotient G B z, hy⟩, g • f), ?_⟩
+    apply (quotient_eq_iff G B F _ _).mpr
+    exact ⟨g, Prod.ext hg rfl⟩
+
+private def
+    DiagonalQuotient.patchHomeomorph {G : Type*} {B : Type*} {F : Type*} [Group G] [MulAction G B]
+    [MulAction G F] [TopologicalSpace B] [TopologicalSpace F]
+    (hq : IsQuotientCoveringMap (baseQuotient G B) G) [ContinuousConstSMul G F] (b : B) :
+    (projection G B F ⁻¹' (patch hq b : Set _)) ≃ₜ (patch hq b × F) :=
+  ((patchMap_openEmbedding (F := F) hq b).isEmbedding.toHomeomorph.trans
+      (Homeomorph.setCongr (patchMap_range hq b))).symm
+
+private theorem
+    DiagonalQuotient.patchHomeomorph_projection {G : Type*} {B : Type*} {F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B] [TopologicalSpace F]
+    (hq : IsQuotientCoveringMap (baseQuotient G B) G) [ContinuousConstSMul G F] (b : B)
+    (x : projection G B F ⁻¹' (patch hq b : Set _)) :
+    ((patchHomeomorph hq b x).1 : BaseSpace G B) = projection G B F x.val := by
+  have hp := projection_patchMap hq b (patchHomeomorph hq b x)
+  have he : patchMap hq b (patchHomeomorph hq b x) = x.val :=
+    congrArg Subtype.val ((patchHomeomorph hq b).symm_apply_apply x)
+  rw [he] at hp
+  exact hp.symm
+
+private def DiagonalQuotient.fibreHomeomorphOver {G : Type*} {B : Type*} {F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B] [TopologicalSpace F]
+    (hq : IsQuotientCoveringMap (baseQuotient G B) G) [ContinuousConstSMul G F] (b : B) :
+    (projection G B F ⁻¹' {baseQuotient G B b}) ≃ₜ F :=
+  fibreHomeomorphOfLocalTrivializations (projection G B F) (patch hq) (patchHomeomorph hq)
+    (patchHomeomorph_projection hq) b (baseQuotient G B b) (baseQuotient_mem_patch hq b)
+
+private theorem DiagonalQuotient.projection_proper {G : Type*} {B : Type*} {F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B] [TopologicalSpace F]
+    (hq : IsQuotientCoveringMap (baseQuotient G B) G) [ContinuousConstSMul G F] [CompactSpace F] :
+    IsProperMap (projection G B F) :=
+  proper_of_localTrivializations (projection G B F) (projection_continuous G B F) (patch hq)
+    (patch_cover hq) (patchHomeomorph hq) (patchHomeomorph_projection hq)
+
+private theorem DiagonalQuotient.spaceT2Space {G : Type*} {B : Type*} {F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B] [TopologicalSpace F]
+    (hq : IsQuotientCoveringMap (baseQuotient G B) G) [ContinuousConstSMul G F]
+    [T2Space (BaseSpace G B)] [T2Space F] : T2Space (Space G B F) :=
+  t2Space_of_localTrivializations (projection G B F) (projection_continuous G B F) (patch hq)
+    (patch_cover hq) (patchHomeomorph hq)
+
+private theorem DiagonalQuotient.baseT2Space {G : Type*} {B : Type*} [Group G] [MulAction G B]
+    [TopologicalSpace B] (hq : IsQuotientCoveringMap (baseQuotient G B) G) [T2Space B]
+    [LocallyCompactSpace B] [ProperlyDiscontinuousSMul G B] : T2Space (BaseSpace G B) := by
+  let := hq.toContinuousConstSMul
+  infer_instance
+
+private theorem DiagonalQuotient.spaceSecondCountable {G : Type*} {B : Type*} {F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B] [TopologicalSpace F]
+    (hq : IsQuotientCoveringMap (baseQuotient G B) G) [ContinuousConstSMul G F]
+    [SecondCountableTopology B] [SecondCountableTopology F] :
+    SecondCountableTopology (Space G B F) :=
+  (quotient_isQuotientMap G B F).secondCountableTopology
+    (quotient_isOpenQuotientMap (F := F) hq).isOpenMap
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Toric/DiagonalQuotient2.lean b/LeanPool/HopfProblem/Toric/DiagonalQuotient2.lean
new file mode 100644
index 000000000..4bb2ad453
--- /dev/null
+++ b/LeanPool/HopfProblem/Toric/DiagonalQuotient2.lean
@@ -0,0 +1,451 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Recognition.Smale7
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.Toric.DiagonalQuotient1
+import all LeanPool.HopfProblem.Recognition.Smale7
+
+/-!
+# Hopf problem: toric · diagonal quotient 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem DiagonalQuotient.quotient_smul_fst {G B F : Type*} [Group G] [MulAction G B]
+    [MulAction G F] (g : G) (b : B) (f : F) :
+    quotient G B F (g • b, f) = quotient G B F (b, g⁻¹ • f) := by
+  apply (quotient_eq_iff G B F _ _).mpr
+  exact ⟨g, by simp⟩
+
+private def CuspQuotient.sectionCoordinates (t : ℂ) : ToricCharts.CoordinateSpace 3 :=
+  ![t, 1, 1]
+
+@[simp]
+private theorem CuspQuotient.time_sectionCoordinates (t : ℂ) :
+    ToricFan.Triangle.time (sectionCoordinates t) = t := by
+  simp [ToricFan.Triangle.time, sectionCoordinates]
+
+private theorem CuspQuotient.sectionCoordinates_holomorphic : ContDiff ℂ ω sectionCoordinates := by
+  apply contDiff_pi.mpr
+  intro i
+  fin_cases i
+  · exact contDiff_id
+  · exact contDiff_const
+  · exact contDiff_const
+
+private def CuspQuotient.sectionLift (ε : ℝ) (t : disc ε) : ToricSpace.Tube (disc ε) :=
+  ⟨ToricSpace.inclusion ToricSpace.referenceTriangle (sectionCoordinates t),
+    by
+    change
+      ToricSpace.time (ToricSpace.inclusion ToricSpace.referenceTriangle (sectionCoordinates t)) ∈
+        disc ε
+    simpa only [ToricSpace.time_inclusion, time_sectionCoordinates] using t.2⟩
+
+private theorem CuspQuotient.sectionLift_continuous (ε : ℝ) : Continuous (sectionLift ε) :=
+  (((ToricSpace.inclusion_openEmbedding ToricSpace.referenceTriangle).continuous.comp
+            sectionCoordinates_holomorphic.continuous).comp
+        continuous_subtype_val).subtype_mk
+    _
+
+private def CuspQuotient.zeroSection (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    disc ε → QuotientSpace C ε :=
+  quotientMap C ε ∘ sectionLift ε
+
+@[simp]
+private theorem CuspQuotient.projection_zeroSection (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (t : disc ε) : projection C ε (zeroSection C ε t) = t := by
+  change
+    ToricSpace.time (ToricSpace.inclusion ToricSpace.referenceTriangle (sectionCoordinates t)) = t
+  simp
+
+private theorem CuspQuotient.zeroSection_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    Continuous (zeroSection C ε) :=
+  (quotientMap_continuous C ε).comp (sectionLift_continuous ε)
+
+private def CuspQuotient.discLoopContraction {ε : ℝ} {z : disc ε} (p : Path z z) :
+    p.Homotopy (Path.refl z)
+    where
+  toFun
+    u :=
+    ⟨(1 - (u.1 : ℝ)) • (p u.2 : ℂ) + (u.1 : ℝ) • (z : ℂ),
+      (convex_ball (0 : ℂ) ε) (p u.2).2 z.2 (sub_nonneg.mpr u.1.2.2) u.1.2.1 (sub_add_cancel _ _)⟩
+  continuous_toFun := by fun_prop
+  map_zero_left t := by apply Subtype.ext; simp
+  map_one_left t := by apply Subtype.ext; simp
+  prop' s t
+    ht := by
+    apply Subtype.ext
+    change (1 - (s : ℝ)) • (p t : ℂ) + (s : ℝ) • (z : ℂ) = (p t : ℂ)
+    rcases ht with rfl | rfl <;> simp <;> ring
+
+private def
+    DiagonalQuotient.zeroSection {G B F : Type*} [Group G] [MulAction G B] [MulAction G F] (c : F)
+    (hc : ∀ g : G, g • c = c) : BaseSpace G B → Space G B F :=
+  Quotient.lift (fun b : B => quotient G B F (b, c))
+    (by
+      rintro b b' ⟨g, hg⟩
+      exact (quotient_eq_iff G B F _ _).mpr ⟨g, Prod.ext hg (hc g)⟩)
+
+private theorem DiagonalQuotient.zeroSection_continuous {G B F : Type*} [Group G] [MulAction G B]
+    [MulAction G F] [TopologicalSpace B] [TopologicalSpace F] (c : F) (hc : ∀ g : G, g • c = c) :
+    Continuous (zeroSection (B := B) c hc) :=
+  isQuotientMap_quotient_mk'.continuous_iff.mpr
+    ((quotient_continuous G B F).comp (continuous_id.prodMk continuous_const))
+
+@[simp]
+private theorem DiagonalQuotient.projection_zeroSection {G B F : Type*} [Group G] [MulAction G B]
+    [MulAction G F] (c : F) (hc : ∀ g : G, g • c = c) (x : BaseSpace G B) :
+    projection G B F (zeroSection c hc x) = x := by
+  induction x using Quotient.inductionOn with
+  | h b => rfl
+
+private def DiagonalQuotient.fibreFundamentalGroupHom {G B F : Type*} [Group G] [MulAction G B]
+    [MulAction G F] [TopologicalSpace B] [TopologicalSpace F] (b : B) (c : F) :
+    FundamentalGroup F c →* FundamentalGroup (Space G B F) (fibreInclusion G B F b c) :=
+  FundamentalGroup.map ⟨fibreInclusion G B F b, fibreInclusion_continuous G B F b⟩ c
+
+private def DiagonalQuotient.projectionFundamentalGroupHom {G B F : Type*} [Group G] [MulAction G B]
+    [MulAction G F] [TopologicalSpace B] [TopologicalSpace F] (b : B) (c : F) :
+    FundamentalGroup (Space G B F) (fibreInclusion G B F b c) →*
+      FundamentalGroup (BaseSpace G B) (baseQuotient G B b) :=
+  FundamentalGroup.map ⟨projection G B F, projection_continuous G B F⟩ (fibreInclusion G B F b c)
+
+private def DiagonalQuotient.sectionFundamentalGroupHom {G B F : Type*} [Group G] [MulAction G B]
+    [MulAction G F] [TopologicalSpace B] [TopologicalSpace F] (c : F) (hc : ∀ g : G, g • c = c)
+    (b : B) :
+    FundamentalGroup (BaseSpace G B) (baseQuotient G B b) →*
+      FundamentalGroup (Space G B F) (fibreInclusion G B F b c) :=
+  FundamentalGroup.map ⟨zeroSection c hc, zeroSection_continuous c hc⟩ (baseQuotient G B b)
+
+private theorem
+    DiagonalQuotient.projectionFundamentalGroupHom_comp_section {G B F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B] [TopologicalSpace F] (c : F)
+    (hc : ∀ g : G, g • c = c) (b : B) :
+    (projectionFundamentalGroupHom (G := G) b c).comp (sectionFundamentalGroupHom c hc b) =
+      MonoidHom.id (FundamentalGroup (BaseSpace G B) (baseQuotient G B b)) := by
+  apply DFunLike.ext
+  intro γ
+  induction γ using Path.Homotopic.Quotient.ind with
+  | mk
+    γ =>
+    change
+      Path.Homotopic.Quotient.mk
+          ((γ.map (zeroSection_continuous c hc)).map (projection_continuous G B F)) =
+        Path.Homotopic.Quotient.mk γ
+    apply congrArg Path.Homotopic.Quotient.mk
+    ext t
+    exact projection_zeroSection c hc (γ t)
+
+@[simp]
+private theorem DiagonalQuotient.projectionFundamentalGroupHom_fibre {G B F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B] [TopologicalSpace F] (b : B) (c : F)
+    (γ : FundamentalGroup F c) :
+    projectionFundamentalGroupHom (G := G) b c (fibreFundamentalGroupHom b c γ) = 1 := by
+  induction γ using Path.Homotopic.Quotient.ind with
+  | mk
+    γ =>
+    change
+      Path.Homotopic.Quotient.mk
+          ((γ.map (fibreInclusion_continuous G B F b)).map (projection_continuous G B F)) =
+        Path.Homotopic.Quotient.mk (Path.refl (baseQuotient G B b))
+    apply congrArg Path.Homotopic.Quotient.mk
+    ext t
+    rfl
+
+private theorem DiagonalQuotient.fibreFundamentalGroupHom_range_le_ker {G B F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B] [TopologicalSpace F] (b : B) (c : F) :
+    (fibreFundamentalGroupHom (G := G) b c).range ≤
+      (projectionFundamentalGroupHom (G := G) b c).ker := by
+  rintro γ ⟨δ, rfl⟩
+  exact projectionFundamentalGroupHom_fibre b c δ
+
+private def
+    DiagonalQuotient.deckTransportHom {G B : Type*} [Group G] [MulAction G B] [TopologicalSpace B]
+    (hq : IsQuotientCoveringMap (baseQuotient G B) G) (b : B) :
+    FundamentalGroup (BaseSpace G B) (baseQuotient G B b) →* G :=
+  (MulEquiv.inv' G).symm.toMonoidHom.comp (hq.fundamentalGroupToMulOpposite ⟨b, rfl⟩)
+
+private theorem DiagonalQuotient.deckTransportHom_monodromy {G B : Type*} [Group G] [MulAction G B]
+    [TopologicalSpace B] (hq : IsQuotientCoveringMap (baseQuotient G B) G) (b : B)
+    (γ : FundamentalGroup (BaseSpace G B) (baseQuotient G B b)) :
+    (deckTransportHom hq b γ)⁻¹ • b = (hq.isCoveringMap.monodromy γ ⟨b, rfl⟩ : B) := by
+  change ((hq.fundamentalGroupToMulOpposite ⟨b, rfl⟩ γ).unop⁻¹)⁻¹ • b = _
+  rw [inv_inv]
+  exact hq.unop_fundamentalGroupToMulOpposite_smul
+
+private def DiagonalQuotient.fibreActionFundamentalGroupHom {G F : Type*} [Group G] [MulAction G F]
+    [TopologicalSpace F] [ContinuousConstSMul G F] (c : F) (hc : ∀ g : G, g • c = c) (g : G) :
+    FundamentalGroup F c →* FundamentalGroup F c :=
+  FundamentalGroup.mapOfEq ⟨fun x : F => g • x, ContinuousConstSMul.continuous_const_smul g⟩
+    (hc g)
+
+private theorem DiagonalQuotient.quotient_loop_lift_of_projection_eq_refl {G B F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B] [TopologicalSpace F]
+    [ContinuousConstSMul G F] (hq : IsQuotientCoveringMap (baseQuotient G B) G) (b : B) (c : F)
+    (γ : Path.Homotopic.Quotient (fibreInclusion G B F b c) (fibreInclusion G B F b c))
+    (hγ :
+      γ.map ⟨projection G B F, projection_continuous G B F⟩ =
+        Path.Homotopic.Quotient.refl (baseQuotient G B b)) :
+    ∃ δ : Path.Homotopic.Quotient (b, c) (b, c),
+      δ.map ⟨quotient G B F, quotient_continuous G B F⟩ = γ := by
+  induction γ using Path.Homotopic.Quotient.ind with
+  | mk γ =>
+    let cov := (quotientCoveringMap (F := F) hq).isCoveringMap
+    let L : C(unitInterval, B × F) := cov.liftPath γ (b, c) γ.source
+    let γb : Path (baseQuotient G B b) (baseQuotient G B b) := γ.map (projection_continuous G B F)
+    let Lb : C(unitInterval, B) := ⟨fun t => (L t).1, continuous_fst.comp L.continuous⟩
+    have hLb : Lb = hq.isCoveringMap.liftPath γb b γb.source := by
+      apply (hq.isCoveringMap.eq_liftPath_iff' γb.source).mpr
+      constructor
+      · funext t
+        exact congrArg (projection G B F) (congrFun (cov.liftPath_lifts γ (b, c) γ.source) t)
+      · exact congrArg Prod.fst (cov.liftPath_zero γ (b, c) γ.source)
+    have hnull : γb.Homotopic (Path.refl (baseQuotient G B b)) := by
+      apply Path.Homotopic.Quotient.eq.mp
+      exact hγ
+    have hbaseEnd : hq.isCoveringMap.liftPath γb b γb.source 1 = b := by
+      have h := hq.isCoveringMap.liftPath_apply_one_eq_of_homotopicRel hnull b γb.source rfl
+      have hc : hq.isCoveringMap.liftPath (Path.refl (baseQuotient G B b)) b rfl 1 = b := by
+        exact
+          congrArg (fun p : C(unitInterval, B) => p 1)
+            (hq.isCoveringMap.liftPath_const (e := b) rfl)
+      exact h.trans hc
+    have hfirst : (L 1).1 = b := (congrArg (fun p : C(unitInterval, B) => p 1) hLb).trans hbaseEnd
+    have hquot : quotient G B F (L 1) = quotient G B F (b, c) :=
+      (congrFun (cov.liftPath_lifts γ (b, c) γ.source) 1).trans γ.target
+    have hsecond : (L 1).2 = c := by
+      apply fibreInclusion_injective (F := F) hq b
+      have hp : (b, (L 1).2) = L 1 := Prod.ext hfirst.symm rfl
+      exact (congrArg (quotient G B F) hp).trans hquot
+    have hlast : L 1 = (b, c) := Prod.ext hfirst hsecond
+    let δ : Path (b, c) (b, c) := ⟨L, cov.liftPath_zero γ (b, c) γ.source, hlast⟩
+    refine ⟨Path.Homotopic.Quotient.mk δ, ?_⟩
+    change
+      Path.Homotopic.Quotient.mk (δ.map (quotient_continuous G B F)) =
+        Path.Homotopic.Quotient.mk γ
+    apply congrArg Path.Homotopic.Quotient.mk
+    ext t
+    exact congrFun (cov.liftPath_lifts γ (b, c) γ.source) t
+
+private theorem DiagonalQuotient.product_loop_eq_vertical_of_fst_eq_refl {B F : Type*}
+    [TopologicalSpace B] [TopologicalSpace F] (b : B) (c : F)
+    (α : Path.Homotopic.Quotient (b, c) (b, c)) (h : α.map ⟨Prod.fst, continuous_fst⟩ = .refl b) :
+    α =
+      (α.map ⟨Prod.snd, continuous_snd⟩).map
+        ⟨fun f : F => (b, f), continuous_const.prodMk continuous_id⟩ := by
+  have hv (β : Path.Homotopic.Quotient c c) :
+    Path.Homotopic.prod (.refl b) β =
+      β.map ⟨fun f : F => (b, f), continuous_const.prodMk continuous_id⟩ := by
+    induction β using Path.Homotopic.Quotient.ind with
+    | mk p => rfl
+  calc
+    α =
+        Path.Homotopic.prod (α.map ⟨Prod.fst, continuous_fst⟩)
+          (α.map ⟨Prod.snd, continuous_snd⟩) :=
+      (Path.Homotopic.prod_projLeft_projRight α).symm
+    _ = Path.Homotopic.prod (.refl b) (α.map ⟨Prod.snd, continuous_snd⟩) := by rw [h]
+    _ =
+        (α.map ⟨Prod.snd, continuous_snd⟩).map
+          ⟨fun f : F => (b, f), continuous_const.prodMk continuous_id⟩ :=
+      hv _
+
+private theorem
+    DiagonalQuotient.product_vertical_loop_map_injective {B F : Type*} [TopologicalSpace B]
+    [TopologicalSpace F] (b : B) (c : F) :
+    Function.Injective
+      (fun β : Path.Homotopic.Quotient c c =>
+        β.map ⟨fun f : F => (b, f), continuous_const.prodMk continuous_id⟩) := by
+  have hleft (β : Path.Homotopic.Quotient c c) :
+    (β.map ⟨fun f : F => (b, f), continuous_const.prodMk continuous_id⟩).map
+        ⟨Prod.snd, continuous_snd⟩ =
+      β := by
+    induction β using Path.Homotopic.Quotient.ind with
+    | mk p => rfl
+  intro α β h
+  have hs :=
+    congrArg (fun γ : Path.Homotopic.Quotient (b, c) (b, c) => γ.map ⟨Prod.snd, continuous_snd⟩) h
+  exact (hleft α).symm.trans (hs.trans (hleft β))
+
+private theorem DiagonalQuotient.fibreFundamentalGroupHom_injective {G B F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B] [TopologicalSpace F]
+    [ContinuousConstSMul G F] (hq : IsQuotientCoveringMap (baseQuotient G B) G) (b : B) (c : F) :
+    Function.Injective (fibreFundamentalGroupHom (G := G) b c) := by
+  intro α β h
+  apply product_vertical_loop_map_injective b c
+  apply (quotient_isCoveringMap (F := F) hq).injective_path_homotopic_map (b, c) (b, c)
+  change
+    (Path.Homotopic.Quotient.map α
+            ⟨fun f : F => (b, f), continuous_const.prodMk continuous_id⟩).map
+        ⟨quotient G B F, quotient_continuous G B F⟩ =
+      (Path.Homotopic.Quotient.map β
+            ⟨fun f : F => (b, f), continuous_const.prodMk continuous_id⟩).map
+        ⟨quotient G B F, quotient_continuous G B F⟩
+  rw [← Path.Homotopic.Quotient.map_comp, ← Path.Homotopic.Quotient.map_comp]
+  exact h
+
+private theorem DiagonalQuotient.fibreFundamentalGroupHom_range_eq_ker {G B F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B] [TopologicalSpace F]
+    [ContinuousConstSMul G F] (hq : IsQuotientCoveringMap (baseQuotient G B) G) (b : B) (c : F) :
+    (fibreFundamentalGroupHom (G := G) b c).range =
+      (projectionFundamentalGroupHom (G := G) b c).ker := by
+  apply le_antisymm (fibreFundamentalGroupHom_range_le_ker b c)
+  intro γ hγ
+  change
+    Path.Homotopic.Quotient.map γ ⟨projection G B F, projection_continuous G B F⟩ =
+      Path.Homotopic.Quotient.refl (baseQuotient G B b) at hγ
+  obtain ⟨α, hα⟩ := quotient_loop_lift_of_projection_eq_refl hq b c γ hγ
+  have hfst : α.map ⟨Prod.fst, continuous_fst⟩ = Path.Homotopic.Quotient.refl b := by
+    apply hq.isCoveringMap.injective_path_homotopic_map b b
+    change
+      (α.map ⟨Prod.fst, continuous_fst⟩).map ⟨baseQuotient G B, baseQuotient_continuous G B⟩ =
+        Path.Homotopic.Quotient.refl (baseQuotient G B b)
+    have hs :
+      (α.map ⟨Prod.fst, continuous_fst⟩).map ⟨baseQuotient G B, baseQuotient_continuous G B⟩ =
+        (α.map ⟨quotient G B F, quotient_continuous G B F⟩).map
+          ⟨projection G B F, projection_continuous G B F⟩ := by
+      rw [← Path.Homotopic.Quotient.map_comp, ← Path.Homotopic.Quotient.map_comp]
+      rfl
+    exact
+      hs.trans
+        ((congrArg
+              (fun η :
+                  Path.Homotopic.Quotient (fibreInclusion G B F b c) (fibreInclusion G B F b c) =>
+                η.map ⟨projection G B F, projection_continuous G B F⟩)
+              hα).trans
+          hγ)
+  refine ⟨α.map ⟨Prod.snd, continuous_snd⟩, ?_⟩
+  have hv :=
+    congrArg
+      (fun η : Path.Homotopic.Quotient (b, c) (b, c) =>
+        η.map ⟨quotient G B F, quotient_continuous G B F⟩)
+      (product_loop_eq_vertical_of_fst_eq_refl b c α hfst)
+  rw [← Path.Homotopic.Quotient.map_comp] at hv
+  exact hv.symm.trans hα
+
+private def
+    DiagonalQuotient.liftedFibreHomotopy {G B F : Type*} [Group G] [MulAction G B] [MulAction G F]
+    [TopologicalSpace B] [TopologicalSpace F] [ContinuousConstSMul G F]
+    (hq : IsQuotientCoveringMap (baseQuotient G B) G) (b : B)
+    (γ : Path (baseQuotient G B b) (baseQuotient G B b)) (g : G)
+    (hend : (hq.isCoveringMap.monodromy (.mk γ) ⟨b, rfl⟩ : B) = g⁻¹ • b) :
+    ContinuousMap.Homotopy
+      (⟨fibreInclusion G B F b, fibreInclusion_continuous G B F b⟩ : C(F, Space G B F))
+      ⟨fun f : F => fibreInclusion G B F b (g • f),
+        (fibreInclusion_continuous G B F b).comp (ContinuousConstSMul.continuous_const_smul g)⟩
+    where
+  toFun p := quotient G B F (hq.isCoveringMap.liftPath γ b γ.source p.1, p.2)
+  continuous_toFun :=
+    (quotient_continuous G B F).comp
+      (((hq.isCoveringMap.liftPath γ b γ.source).continuous.comp continuous_fst).prodMk
+        continuous_snd)
+  map_zero_left
+    f := by
+    change quotient G B F (hq.isCoveringMap.liftPath γ b γ.source 0, f) = quotient G B F (b, f)
+    rw [hq.isCoveringMap.liftPath_zero]
+  map_one_left
+    f := by
+    change
+      quotient G B F ((hq.isCoveringMap.monodromy (.mk γ) ⟨b, rfl⟩ : B), f) =
+        quotient G B F (b, g • f)
+    rw [hend, quotient_smul_fst, inv_inv]
+
+private theorem DiagonalQuotient.fundamentalGroup_conjugation_of_homotopy {F E : Type*}
+    [TopologicalSpace F] [TopologicalSpace E] (f₀ f₁ : C(F, E)) (H : f₀.Homotopy f₁) (c : F)
+    (e : E) (h₀ : f₀ c = e) (h₁ : f₁ c = e) (v : FundamentalGroup F c) :
+    let s : FundamentalGroup E e := .mk ((H.evalAt c).cast h₀.symm h₁.symm)
+    s * FundamentalGroup.mapOfEq f₀ h₀ v * s⁻¹ = FundamentalGroup.mapOfEq f₁ h₁ v := by
+  let s : FundamentalGroup E e := .mk ((H.evalAt c).cast h₀.symm h₁.symm)
+  change s * FundamentalGroup.mapOfEq f₀ h₀ v * s⁻¹ = FundamentalGroup.mapOfEq f₁ h₁ v
+  have hsquare : s * FundamentalGroup.mapOfEq f₀ h₀ v = FundamentalGroup.mapOfEq f₁ h₁ v * s := by
+    obtain ⟨p, rfl⟩ := Path.Homotopic.Quotient.mk_surjective v
+    simp only [s, FundamentalGroup.mul_def, FundamentalGroup.mapOfEq_apply,
+      ← Path.Homotopic.Quotient.mk_map, ← Path.Homotopic.Quotient.mk_cast,
+      ← Path.Homotopic.Quotient.mk_trans]
+    apply Path.Homotopic.Quotient.eq.mpr
+    have hp := (Path.Homotopic.map_trans_evalAt H p).pathCast h₀.symm h₁.symm
+    rw [Path.cast_trans (p.map f₀.continuous) (H.evalAt c) h₀.symm h₀.symm h₁.symm,
+      Path.cast_trans (H.evalAt c) (p.map f₁.continuous) h₀.symm h₁.symm h₁.symm] at hp
+    exact hp
+  rw [hsquare, mul_inv_cancel_right]
+
+public
+theorem DiagonalQuotient.fundamentalGroup_mapOfEq_comp {A B C : Type*} [TopologicalSpace A]
+    [TopologicalSpace B] [TopologicalSpace C] (f : C(A, B)) (g : C(B, C)) (a : A) (b : B) (c : C)
+    (hf : f a = b) (hg : g b = c) (v : FundamentalGroup A a) :
+    FundamentalGroup.mapOfEq (g.comp f) ((congrArg g hf).trans hg) v =
+      FundamentalGroup.mapOfEq g hg (FundamentalGroup.mapOfEq f hf v) := by
+  simp only [FundamentalGroup.mapOfEq_apply, Path.Homotopic.Quotient.map_cast,
+    Path.Homotopic.Quotient.map_comp, Path.Homotopic.Quotient.cast_cast]
+
+private theorem
+    DiagonalQuotient.sectionFundamentalGroupHom_conjugate_fibre {G B F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B] [TopologicalSpace F]
+    [ContinuousConstSMul G F] (hq : IsQuotientCoveringMap (baseQuotient G B) G) (c : F)
+    (hc : ∀ g : G, g • c = c) (b : B) (β : FundamentalGroup (BaseSpace G B) (baseQuotient G B b))
+    (v : FundamentalGroup F c) :
+    sectionFundamentalGroupHom c hc b β * fibreFundamentalGroupHom b c v *
+        (sectionFundamentalGroupHom c hc b β)⁻¹ =
+      fibreFundamentalGroupHom b c
+        (fibreActionFundamentalGroupHom c hc (deckTransportHom hq b β) v) := by
+  obtain ⟨γ, rfl⟩ := Path.Homotopic.Quotient.mk_surjective β
+  let g : G := deckTransportHom hq b (.mk γ)
+  have hend : (hq.isCoveringMap.monodromy (.mk γ) ⟨b, rfl⟩ : B) = g⁻¹ • b :=
+    (deckTransportHom_monodromy hq b (.mk γ)).symm
+  let i : C(F, Space G B F) := ⟨fibreInclusion G B F b, fibreInclusion_continuous G B F b⟩
+  let a : C(F, F) := ⟨fun f : F => g • f, ContinuousConstSMul.continuous_const_smul g⟩
+  let H : i.Homotopy (i.comp a) := liftedFibreHomotopy (F := F) hq b γ g hend
+  have h₁ : (i.comp a) c = i c := congrArg i (hc g)
+  let s : FundamentalGroup (Space G B F) (i c) := .mk ((H.evalAt c).cast rfl h₁.symm)
+  have hs : s = sectionFundamentalGroupHom c hc b (.mk γ) := by
+    change
+      Path.Homotopic.Quotient.mk ((H.evalAt c).cast rfl h₁.symm) =
+        Path.Homotopic.Quotient.mk (γ.map (zeroSection_continuous c hc))
+    apply congrArg Path.Homotopic.Quotient.mk
+    ext t
+    change quotient G B F (hq.isCoveringMap.liftPath γ b γ.source t, c) = zeroSection c hc (γ t)
+    have hlift : baseQuotient G B (hq.isCoveringMap.liftPath γ b γ.source t) = γ t :=
+      congrFun (hq.isCoveringMap.liftPath_lifts γ b γ.source) t
+    exact congrArg (zeroSection c hc) hlift
+  have hi (w : FundamentalGroup F c) :
+    FundamentalGroup.mapOfEq i rfl w = fibreFundamentalGroupHom b c w := by
+    rw [FundamentalGroup.mapOfEq_apply]
+    exact Path.Homotopic.Quotient.cast_rfl_rfl _
+  have hterminal :
+    FundamentalGroup.mapOfEq (i.comp a) h₁ v =
+      fibreFundamentalGroupHom b c (fibreActionFundamentalGroupHom c hc g v) := by
+    have hcomp := fundamentalGroup_mapOfEq_comp a i c c (i c) (hc g) rfl v
+    rw [hi] at hcomp
+    exact hcomp
+  have hconj := fundamentalGroup_conjugation_of_homotopy i (i.comp a) H c (i c) rfl h₁ v
+  change
+    s * FundamentalGroup.mapOfEq i rfl v * s⁻¹ = FundamentalGroup.mapOfEq (i.comp a) h₁ v at hconj
+  rw [hs, hi, hterminal] at hconj
+  exact hconj
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Toric/DiagonalQuotient3.lean b/LeanPool/HopfProblem/Toric/DiagonalQuotient3.lean
new file mode 100644
index 000000000..307c017c2
--- /dev/null
+++ b/LeanPool/HopfProblem/Toric/DiagonalQuotient3.lean
@@ -0,0 +1,141 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Recognition.Smale8
+import all LeanPool.HopfProblem.Toric.DiagonalQuotient1
+import all LeanPool.HopfProblem.Recognition.Smale8
+
+/-!
+# Hopf problem: toric · diagonal quotient 3
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def DiagonalQuotient.sectionMap {G B F : Type*} [Group G] [MulAction G B] [MulAction G F]
+    [TopologicalSpace B] (U : TopologicalSpace.Opens (BaseSpace G B)) (s : C(U, B)) (x : U × F) :
+    Space G B F :=
+  quotient G B F (s x.1, x.2)
+
+private theorem DiagonalQuotient.sectionMap_continuous {G B F : Type*} [Group G] [MulAction G B]
+    [MulAction G F] [TopologicalSpace B] [TopologicalSpace F]
+    (U : TopologicalSpace.Opens (BaseSpace G B)) (s : C(U, B)) :
+    Continuous (sectionMap (F := F) U s) :=
+  (quotient_continuous G B F).comp (s.continuous.prodMap continuous_id)
+
+public
+theorem DiagonalQuotient.baseSection_openEmbedding {G B : Type*} [Group G] [MulAction G B]
+    [TopologicalSpace B] (hq : IsQuotientCoveringMap (baseQuotient G B) G)
+    (U : TopologicalSpace.Opens (BaseSpace G B)) (s : C(U, B))
+    (hs : ∀ x : U, baseQuotient G B (s x) = x) : Topology.IsOpenEmbedding s := by
+  apply hq.isCoveringMap.isLocalHomeomorph.isOpenEmbedding_of_comp _ s.continuous
+  have hcomp : baseQuotient G B ∘ s = (Subtype.val : U → BaseSpace G B) := funext hs
+  rw [hcomp]
+  exact U.isOpenEmbedding'
+
+@[simp]
+private theorem DiagonalQuotient.projection_sectionMap {G B F : Type*} [Group G] [MulAction G B]
+    [MulAction G F] [TopologicalSpace B] (U : TopologicalSpace.Opens (BaseSpace G B))
+    (s : C(U, B)) (hs : ∀ x : U, baseQuotient G B (s x) = x) (x : U × F) :
+    projection G B F (sectionMap U s x) = (x.1 : BaseSpace G B) :=
+  hs x.1
+
+private theorem DiagonalQuotient.sectionMap_injective {G B F : Type*} [Group G] [MulAction G B]
+    [MulAction G F] [TopologicalSpace B] (hq : IsQuotientCoveringMap (baseQuotient G B) G)
+    (U : TopologicalSpace.Opens (BaseSpace G B)) (s : C(U, B))
+    (hs : ∀ x : U, baseQuotient G B (s x) = x) : Function.Injective (sectionMap (F := F) U s) := by
+  intro x y hxy
+  have hbase : x.1 = y.1 :=
+    Subtype.ext
+      (by simpa only [projection_sectionMap U s hs] using congrArg (projection G B F) hxy)
+  apply Prod.ext hbase
+  apply fibreInclusion_injective hq (s y.1)
+  simpa only [sectionMap, fibreInclusion, hbase] using hxy
+
+private theorem DiagonalQuotient.sectionMap_range {G B F : Type*} [Group G] [MulAction G B]
+    [MulAction G F] [TopologicalSpace B] (hq : IsQuotientCoveringMap (baseQuotient G B) G)
+    (U : TopologicalSpace.Opens (BaseSpace G B)) (s : C(U, B))
+    (hs : ∀ x : U, baseQuotient G B (s x) = x) :
+    Set.range (sectionMap (F := F) U s) = projection G B F ⁻¹' (U : Set _) := by
+  ext y
+  constructor
+  · rintro ⟨x, rfl⟩
+    rw [Set.mem_preimage, projection_sectionMap U s hs]
+    exact x.1.property
+  · intro hy
+    obtain ⟨⟨z, f⟩, rfl⟩ := quotient_surjective G B F y
+    change baseQuotient G B z ∈ U at hy
+    obtain ⟨g, hg⟩ := hq.apply_eq_iff_mem_orbit.mp (hs ⟨baseQuotient G B z, hy⟩)
+    refine ⟨(⟨baseQuotient G B z, hy⟩, g • f), ?_⟩
+    exact (quotient_eq_iff G B F _ _).mpr ⟨g, Prod.ext hg rfl⟩
+
+private theorem DiagonalQuotient.sectionMap_openEmbedding {G B F : Type*} [Group G] [MulAction G B]
+    [MulAction G F] [TopologicalSpace B] [TopologicalSpace F] [ContinuousConstSMul G F]
+    (hq : IsQuotientCoveringMap (baseQuotient G B) G) (U : TopologicalSpace.Opens (BaseSpace G B))
+    (s : C(U, B)) (hs : ∀ x : U, baseQuotient G B (s x) = x) :
+    Topology.IsOpenEmbedding (sectionMap (F := F) U s) :=
+  .of_continuous_injective_isOpenMap (sectionMap_continuous U s) (sectionMap_injective hq U s hs)
+    ((quotient_isOpenQuotientMap (F := F) hq).isOpenMap.comp
+      ((baseSection_openEmbedding hq U s hs).isOpenMap.prodMap IsOpenMap.id))
+
+private def
+    DiagonalQuotient.sectionHomeomorph {G B F : Type*} [Group G] [MulAction G B] [MulAction G F]
+    [TopologicalSpace B] [TopologicalSpace F] [ContinuousConstSMul G F]
+    (hq : IsQuotientCoveringMap (baseQuotient G B) G) (U : TopologicalSpace.Opens (BaseSpace G B))
+    (s : C(U, B)) (hs : ∀ x : U, baseQuotient G B (s x) = x) :
+    (projection G B F ⁻¹' (U : Set _)) ≃ₜ (U × F) :=
+  ((sectionMap_openEmbedding (F := F) hq U s hs).isEmbedding.toHomeomorph.trans
+      (Homeomorph.setCongr (sectionMap_range hq U s hs))).symm
+
+private theorem
+    DiagonalQuotient.sectionHomeomorph_projection {G B F : Type*} [Group G] [MulAction G B]
+    [MulAction G F] [TopologicalSpace B] [TopologicalSpace F] [ContinuousConstSMul G F]
+    (hq : IsQuotientCoveringMap (baseQuotient G B) G) (U : TopologicalSpace.Opens (BaseSpace G B))
+    (s : C(U, B)) (hs : ∀ x : U, baseQuotient G B (s x) = x)
+    (x : projection G B F ⁻¹' (U : Set _)) :
+    ((sectionHomeomorph hq U s hs x).1 : BaseSpace G B) = projection G B F x.val := by
+  have hp := projection_sectionMap U s hs (sectionHomeomorph hq U s hs x)
+  have he : sectionMap U s (sectionHomeomorph hq U s hs x) = x.val :=
+    congrArg Subtype.val ((sectionHomeomorph hq U s hs).symm_apply_apply x)
+  rw [he] at hp
+  exact hp.symm
+
+@[simp]
+private theorem DiagonalQuotient.sectionHomeomorph_apply_quotient {G B F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B] [TopologicalSpace F]
+    [ContinuousConstSMul G F] (hq : IsQuotientCoveringMap (baseQuotient G B) G)
+    (U : TopologicalSpace.Opens (BaseSpace G B)) (s : C(U, B))
+    (hs : ∀ x : U, baseQuotient G B (s x) = x) (x : U) (f : F) :
+    sectionHomeomorph hq U s hs
+        ⟨quotient G B F (s x, f), by
+          change baseQuotient G B (s x) ∈ U
+          rw [hs x]
+          exact x.property⟩ =
+      (x, f) :=
+  (sectionHomeomorph hq U s hs).apply_symm_apply (x, f)
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Toric/DiagonalQuotient4.lean b/LeanPool/HopfProblem/Toric/DiagonalQuotient4.lean
new file mode 100644
index 000000000..803f6ddd1
--- /dev/null
+++ b/LeanPool/HopfProblem/Toric/DiagonalQuotient4.lean
@@ -0,0 +1,97 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Pi1.TwistGroup
+import all LeanPool.HopfProblem.Toric.DiagonalQuotient1
+import all LeanPool.HopfProblem.Toric.DiagonalQuotient2
+import all LeanPool.HopfProblem.Foundations.SplitGroupExtension
+import all LeanPool.HopfProblem.Pi1.TwistGroup
+
+/-!
+# Hopf problem: toric · diagonal quotient 4
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+public
+theorem DiagonalQuotient.fundamentalGroup_basepointChange_of_homotopy {F E : Type*}
+    [TopologicalSpace F] [TopologicalSpace E] (f₀ f₁ : C(F, E)) (H : f₀.Homotopy f₁) (c : F)
+    (v : FundamentalGroup F c) :
+    FundamentalGroup.fundamentalGroupMulEquivOfPath (H.evalAt c) (FundamentalGroup.map f₀ c v) =
+      FundamentalGroup.map f₁ c v := by
+  obtain ⟨p, rfl⟩ := Path.Homotopic.Quotient.mk_surjective v
+  rw [fundamentalGroup_basepoint_change_apply]
+  change
+    (Path.Homotopic.Quotient.mk (H.evalAt c)).symm.trans
+        ((Path.Homotopic.Quotient.mk (p.map f₀.continuous)).trans
+          (Path.Homotopic.Quotient.mk (H.evalAt c))) =
+      Path.Homotopic.Quotient.mk (p.map f₁.continuous)
+  have hsquare :
+    (Path.Homotopic.Quotient.mk (p.map f₀.continuous)).trans
+        (Path.Homotopic.Quotient.mk (H.evalAt c)) =
+      (Path.Homotopic.Quotient.mk (H.evalAt c)).trans
+        (Path.Homotopic.Quotient.mk (p.map f₁.continuous)) := by
+    rw [← Path.Homotopic.Quotient.mk_trans, ← Path.Homotopic.Quotient.mk_trans]
+    exact Path.Homotopic.Quotient.eq.mpr (Path.Homotopic.map_trans_evalAt H p)
+  rw [hsquare, ← Path.Homotopic.Quotient.trans_assoc, Path.Homotopic.Quotient.symm_trans,
+    Path.Homotopic.Quotient.refl_trans]
+
+private def DiagonalQuotient.fibreBasepointHomotopy {G B F : Type*} [Group G] [MulAction G B]
+    [MulAction G F] [TopologicalSpace B] [TopologicalSpace F] {b₀ b₁ : B} (p : Path b₀ b₁) :
+    ContinuousMap.Homotopy
+      (⟨fibreInclusion G B F b₀, fibreInclusion_continuous G B F b₀⟩ : C(F, Space G B F))
+      ⟨fibreInclusion G B F b₁, fibreInclusion_continuous G B F b₁⟩
+    where
+  toFun x := quotient G B F (p x.1, x.2)
+  continuous_toFun :=
+    (quotient_continuous G B F).comp ((p.continuous.comp continuous_fst).prodMk continuous_snd)
+  map_zero_left
+    f := by
+    change quotient G B F (p 0, f) = quotient G B F (b₀, f)
+    rw [p.source]
+  map_one_left
+    f := by
+    change quotient G B F (p 1, f) = quotient G B F (b₁, f)
+    rw [p.target]
+
+private def
+    DiagonalQuotient.fibreBasepointPath {G B F : Type*} [Group G] [MulAction G B] [MulAction G F]
+    [TopologicalSpace B] [TopologicalSpace F] (c : F) {b₀ b₁ : B} (p : Path b₀ b₁) :
+    Path (fibreInclusion G B F b₀ c) (fibreInclusion G B F b₁ c) :=
+  (fibreBasepointHomotopy (G := G) (F := F) p).evalAt c
+
+private theorem DiagonalQuotient.fibreFundamentalGroupHom_baseChange {G B F : Type*} [Group G]
+    [MulAction G B] [MulAction G F] [TopologicalSpace B] [TopologicalSpace F] (c : F) {b₀ b₁ : B}
+    (p : Path b₀ b₁) (v : FundamentalGroup F c) :
+    FundamentalGroup.fundamentalGroupMulEquivOfPath (fibreBasepointPath (G := G) c p)
+        (fibreFundamentalGroupHom (G := G) b₀ c v) =
+      fibreFundamentalGroupHom (G := G) b₁ c v :=
+  fundamentalGroup_basepointChange_of_homotopy _ _ (fibreBasepointHomotopy (G := G) (F := F) p) c
+    v
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Toric/ToricSpace1.lean b/LeanPool/HopfProblem/Toric/ToricSpace1.lean
new file mode 100644
index 000000000..d54129531
--- /dev/null
+++ b/LeanPool/HopfProblem/Toric/ToricSpace1.lean
@@ -0,0 +1,2792 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen1
+
+/-!
+# Hopf problem: toric · toric space 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private abbrev ToricCharts.CoordinateSpace (d : ℕ) :=
+  Fin d → ℂ
+
+private def ToricCharts.torus {d : ℕ} : Set (CoordinateSpace d) :=
+  {z | ∀ j, z j ≠ 0}
+
+private theorem ToricCharts.torus_open {d : ℕ} : IsOpen (torus : Set (CoordinateSpace d)) := by
+  unfold torus
+  simp only [Set.ofPred_forall]
+  exact isOpen_iInter_of_finite fun j => isOpen_ne_fun (continuous_apply j) continuous_const
+
+private theorem ToricCharts.torus_dense {d : ℕ} : Dense (torus : Set (CoordinateSpace d)) := by
+  simpa [torus, Set.pi] using
+    (dense_pi (Set.univ : Set (Fin d)) fun _ _ => dense_compl_singleton (0 : ℂ))
+
+private def ToricCharts.monomial {d : ℕ} (A : Matrix (Fin d) (Fin d) ℤ) (z : CoordinateSpace d) :
+    CoordinateSpace d := fun i => ∏ j, z j ^ A i j
+
+private def ToricCharts.domain {d : ℕ} (A : Matrix (Fin d) (Fin d) ℤ) : Set (CoordinateSpace d) :=
+  {z | ∀ i j, A i j < 0 → z j ≠ 0}
+
+private theorem
+    ToricCharts.domain_open {d : ℕ} (A : Matrix (Fin d) (Fin d) ℤ) : IsOpen (domain A) := by
+  unfold domain
+  simp only [Set.ofPred_forall]
+  apply isOpen_iInter_of_finite
+  intro i
+  apply isOpen_iInter_of_finite
+  intro j
+  by_cases h : A i j < 0
+  · simpa [h] using isOpen_ne_fun (continuous_apply j) continuous_const
+  · simp [h]
+
+private theorem ToricCharts.torus_subset_domain {d : ℕ} (A : Matrix (Fin d) (Fin d) ℤ) :
+    torus ⊆ domain A := fun _ hz _ j _ => hz j
+
+private theorem ToricCharts.monomial_mapsTo_torus {d : ℕ} (A : Matrix (Fin d) (Fin d) ℤ) :
+    Set.MapsTo (monomial A) torus torus := by
+  intro z hz i
+  exact Finset.prod_ne_zero_iff.mpr fun j _ => zpow_ne_zero _ (hz j)
+
+private theorem ToricCharts.monomial_contDiffOn {d : ℕ} (A : Matrix (Fin d) (Fin d) ℤ) (n : ℕ∞ω) :
+    ContDiffOn ℂ n (monomial A) (domain A) := by
+  apply contDiffOn_pi.mpr
+  intro i
+  apply contDiffOn_prod
+  intro j _
+  cases h : A i j with
+  | ofNat k =>
+    simpa only [h, Int.ofNat_eq_natCast, zpow_natCast] using
+      (contDiff_apply ℂ ℂ j).contDiffOn.pow k
+  | negSucc k =>
+    have hn : A i j < 0 := by omega
+    intro z hz
+    simpa only [h, zpow_negSucc] using
+      ((contDiff_apply ℂ ℂ j).contDiffWithinAt.pow (k + 1)).fun_inv (pow_ne_zero _ (hz i j hn))
+
+private theorem ToricCharts.prod_zpow_eq_mo1973_9082 {d : ℕ} (a : ℂ) (ha : a ≠ 0)
+    (s : Finset (Fin d)) (k : Fin d → ℤ) : (∏ i ∈ s, a ^ k i) = a ^ ∑ i ∈ s, k i := by
+  induction s using Finset.induction_on with
+  | empty => simp
+  | @insert i s hi ih => simp [hi, ih, zpow_add₀ ha]
+
+private theorem ToricCharts.monomial_mul_on_torus {d : ℕ} (A B : Matrix (Fin d) (Fin d) ℤ)
+    {z : CoordinateSpace d} (hz : z ∈ torus) : monomial A (monomial B z) = monomial (A * B) z := by
+  funext i
+  simp only [monomial, Matrix.mul_apply]
+  calc
+    (∏ k, (∏ j, z j ^ B k j) ^ A i k) = ∏ k, ∏ j, z j ^ (A i k * B k j) := by
+      apply Finset.prod_congr rfl
+      intro k _
+      rw [← Finset.prod_zpow]
+      apply Finset.prod_congr rfl
+      intro j _
+      rw [← zpow_mul, mul_comm]
+    _ = ∏ j, ∏ k, z j ^ (A i k * B k j) := Finset.prod_comm
+    _ = ∏ j, z j ^ ∑ k, A i k * B k j := by
+      apply Finset.prod_congr rfl
+      intro j _
+      exact prod_zpow_eq_mo1973_9082 (z j) (hz j) _ _
+
+@[simp]
+private theorem ToricCharts.monomial_one {d : ℕ} (z : CoordinateSpace d) : monomial 1 z = z := by
+  funext i
+  simp [monomial, Matrix.one_apply]
+
+private theorem ToricCharts.monomial_mul {d : ℕ} (A : Matrix (Fin d) (Fin d) ℤ)
+    (z w : CoordinateSpace d) : monomial A (z * w) = monomial A z * monomial A w := by
+  funext i
+  simp [monomial, mul_zpow, Finset.prod_mul_distrib]
+
+@[simp]
+private theorem
+    ToricCharts.monomial_ones {d : ℕ} (A : Matrix (Fin d) (Fin d) ℤ) : monomial A 1 = 1 := by
+  funext i
+  simp [monomial]
+
+private def
+    ToricCharts.overlap {d : ℕ} (A B : Matrix (Fin d) (Fin d) ℤ) : Set (CoordinateSpace d) :=
+  domain A ∩ monomial A ⁻¹' domain B
+
+private theorem ToricCharts.overlap_open {d : ℕ} (A B : Matrix (Fin d) (Fin d) ℤ) :
+    IsOpen (overlap A B) :=
+  (monomial_contDiffOn A 0).continuousOn.isOpen_inter_preimage (domain_open A) (domain_open B)
+
+private theorem ToricCharts.torus_subset_overlap {d : ℕ} (A B : Matrix (Fin d) (Fin d) ℤ) :
+    torus ⊆ overlap A B := fun _ hz =>
+  ⟨torus_subset_domain A hz, torus_subset_domain B (monomial_mapsTo_torus A hz)⟩
+
+private theorem ToricCharts.monomial_inverse_on_overlap {d : ℕ} (A B : Matrix (Fin d) (Fin d) ℤ)
+    (hBA : B * A = 1) : Set.EqOn (monomial B ∘ monomial A) id (overlap A B) := by
+  have h : Set.EqOn (monomial B ∘ monomial A) id (overlap A B ∩ torus) := by
+    intro z hz
+    simpa [hBA] using monomial_mul_on_torus B A hz.2
+  refine
+    h.of_subset_closure ?_ continuousOn_id Set.inter_subset_left
+      (torus_dense.open_subset_closure_inter (overlap_open A B))
+  exact
+    (monomial_contDiffOn B 0).continuousOn.comp
+      ((monomial_contDiffOn A 0).continuousOn.mono Set.inter_subset_left) (fun _ hz => hz.2)
+
+private def
+    ToricCharts.changeOfCoordinates {d : ℕ} (A B : Matrix (Fin d) (Fin d) ℤ) (hAB : A * B = 1)
+    (hBA : B * A = 1) : OpenPartialHomeomorph (CoordinateSpace d) (CoordinateSpace d)
+    where
+  toFun := monomial A
+  invFun := monomial B
+  source := overlap A B
+  target := overlap B A
+  map_source' z
+    hz :=
+    ⟨hz.2, by
+      change (monomial B ∘ monomial A) z ∈ domain A
+      rw [monomial_inverse_on_overlap A B hBA hz]
+      exact hz.1⟩
+  map_target' z
+    hz :=
+    ⟨hz.2, by
+      change (monomial A ∘ monomial B) z ∈ domain B
+      rw [monomial_inverse_on_overlap B A hAB hz]
+      exact hz.1⟩
+  left_inv' := monomial_inverse_on_overlap A B hBA
+  right_inv' := monomial_inverse_on_overlap B A hAB
+  open_source := overlap_open A B
+  open_target := overlap_open B A
+  continuousOn_toFun := (monomial_contDiffOn A 0).continuousOn.mono Set.inter_subset_left
+  continuousOn_invFun := (monomial_contDiffOn B 0).continuousOn.mono Set.inter_subset_left
+
+private theorem ToricCharts.changeOfCoordinates_holomorphic {d : ℕ} (A B : Matrix (Fin d) (Fin d) ℤ)
+    (hAB : A * B = 1) (hBA : B * A = 1) :
+    ContDiffOn ℂ ω (changeOfCoordinates A B hAB hBA) (changeOfCoordinates A B hAB hBA).source :=
+  (monomial_contDiffOn A ω).mono Set.inter_subset_left
+
+
+private def ToricCharts.HeightOne (A : Matrix (Fin 3) (Fin 3) ℤ) : Prop :=
+  ∀ j, ∑ i, A i j = 1
+
+private theorem ToricCharts.column_single_of_zero {A : Matrix (Fin 3) (Fin 3) ℤ} (hA : HeightOne A)
+    {z : CoordinateSpace 3} (hz : z ∈ domain A) {j : Fin 3} (hj : z j = 0) :
+    ∃ k : Fin 3, ∀ i, A i j = if i = k then 1 else 0 := by
+  have hn (i : Fin 3) : 0 ≤ A i j := by
+    by_contra h
+    exact hz i j (lt_of_not_ge h) hj
+  have hsum := hA j
+  simp only [Fin.sum_univ_succ, Fin.succ_zero_eq_one, Fin.succ_one_eq_two, Fin.sum_univ_zero,
+    add_zero] at hsum
+  have h0 := hn 0
+  have h1 := hn 1
+  have h2 := hn 2
+  have hcases : A 0 j = 1 ∨ A 1 j = 1 ∨ A 2 j = 1 := by omega
+  rcases hcases with h | h | h
+  · refine ⟨0, ?_⟩
+    intro i
+    fin_cases i <;> simp <;> omega
+  · refine ⟨1, ?_⟩
+    intro i
+    fin_cases i <;> simp <;> omega
+  · refine ⟨2, ?_⟩
+    intro i
+    fin_cases i <;> simp <;> omega
+
+private theorem ToricCharts.monomial_zero_of_column_single {A : Matrix (Fin 3) (Fin 3) ℤ}
+    {z : CoordinateSpace 3} {j k : Fin 3} (hj : z j = 0)
+    (hc : ∀ i, A i j = if i = k then 1 else 0) : monomial A z k = 0 := by
+  apply Finset.prod_eq_zero (Finset.mem_univ j)
+  simp [hj, hc]
+
+private theorem
+    ToricCharts.inverse_mapsTo_domain {A B : Matrix (Fin 3) (Fin 3) ℤ} (hA : HeightOne A)
+    (hBA : B * A = 1) : Set.MapsTo (monomial A) (domain A) (domain B) := by
+  intro z hz i k hB hzero
+  obtain ⟨j, _, hj⟩ := Finset.prod_eq_zero_iff.mp hzero
+  have hzj : z j = 0 := eq_zero_of_zpow_eq_zero hj
+  have hAj : A k j ≠ 0 := by
+    intro he
+    simp [he] at hj
+  obtain ⟨l, hl⟩ := column_single_of_zero hA hz hzj
+  have hkl : k = l := by
+    by_contra h
+    exact hAj (by simp [hl, h])
+  subst l
+  have hentry := congrFun (congrFun hBA i) j
+  have hnonneg : 0 ≤ B i k := by
+    have he : B i k = (1 : Matrix (Fin 3) (Fin 3) ℤ) i j := by
+      simpa [Matrix.mul_apply, hl] using hentry
+    rw [he, Matrix.one_apply]
+    split_ifs <;> norm_num
+  exact (not_lt_of_ge hnonneg) hB
+
+private theorem ToricCharts.overlap_eq_domain {A B : Matrix (Fin 3) (Fin 3) ℤ} (hA : HeightOne A)
+    (hBA : B * A = 1) : overlap A B = domain A := by
+  exact Set.inter_eq_left.mpr (inverse_mapsTo_domain hA hBA)
+
+private theorem ToricCharts.domain_composition {A B : Matrix (Fin 3) (Fin 3) ℤ} (hA : HeightOne A) :
+    overlap A B ⊆ domain (B * A) := by
+  intro z hz i j hC hzj
+  obtain ⟨k, hk⟩ := column_single_of_zero hA hz.1 hzj
+  have hzAk : monomial A z k = 0 := monomial_zero_of_column_single hzj hk
+  have hBk : B i k < 0 := by simpa [Matrix.mul_apply, hk] using hC
+  exact hz.2 i k hBk hzAk
+
+private theorem
+    ToricCharts.monomial_mul_on_overlap {A B : Matrix (Fin 3) (Fin 3) ℤ} (hA : HeightOne A) :
+    Set.EqOn (monomial B ∘ monomial A) (monomial (B * A)) (overlap A B) := by
+  have h : Set.EqOn (monomial B ∘ monomial A) (monomial (B * A)) (overlap A B ∩ torus) :=
+    fun _ hz => monomial_mul_on_torus B A hz.2
+  refine
+    h.of_subset_closure ?_ ?_ Set.inter_subset_left
+      (torus_dense.open_subset_closure_inter (overlap_open A B))
+  · exact
+      (monomial_contDiffOn B 0).continuousOn.comp
+        ((monomial_contDiffOn A 0).continuousOn.mono Set.inter_subset_left) (fun _ hz => hz.2)
+  · exact (monomial_contDiffOn (B * A) 0).continuousOn.mono (domain_composition hA)
+
+@[ext]
+private structure ToricFan.Triangle where
+  a : ℤ
+  b : ℤ
+  upper : Bool
+  deriving DecidableEq
+
+private instance ToricFan.instLocal1 : Countable Triangle := by
+  apply Function.Injective.countable (f := fun s : Triangle => (s.a, s.b, s.upper))
+  intro s t h
+  simpa only [Prod.mk.injEq, Triangle.ext_iff, and_assoc] using h
+
+private def ToricFan.Triangle.rays (s : ToricFan.Triangle) : Matrix (Fin 3) (Fin 3) ℤ :=
+  if s.upper then !![s.a + 1, s.a, s.a + 1; s.b, s.b + 1, s.b + 1; 1, 1, 1]
+  else !![s.a, s.a + 1, s.a; s.b, s.b, s.b + 1; 1, 1, 1]
+
+private def ToricFan.Triangle.dual (s : ToricFan.Triangle) : Matrix (Fin 3) (Fin 3) ℤ :=
+  if s.upper then !![0, -1, s.b + 1; -1, 0, s.a + 1; 1, 1, -1 - s.a - s.b]
+  else !![-1, -1, 1 + s.a + s.b; 1, 0, -s.a; 0, 1, -s.b]
+
+private theorem ToricFan.Triangle.dual_rays (s : ToricFan.Triangle) : s.dual * s.rays = 1 := by
+  ext i j
+  cases h : s.upper <;> fin_cases i <;> fin_cases j <;>
+      simp [dual, rays, h, Matrix.mul_apply, Fin.sum_univ_succ] <;>
+    ring
+
+private theorem ToricFan.Triangle.rays_dual (s : ToricFan.Triangle) : s.rays * s.dual = 1 := by
+  ext i j
+  cases h : s.upper <;> fin_cases i <;> fin_cases j <;>
+      simp [dual, rays, h, Matrix.mul_apply, Fin.sum_univ_succ] <;>
+    ring
+
+
+@[simp]
+private theorem
+    ToricFan.Triangle.rays_height (s : ToricFan.Triangle) (j : Fin 3) : s.rays 2 j = 1 := by
+  cases h : s.upper <;> fin_cases j <;> simp [rays, h]
+
+private def ToricFan.Triangle.transition (s t : ToricFan.Triangle) : Matrix (Fin 3) (Fin 3) ℤ :=
+  t.dual * s.rays
+
+@[simp]
+private theorem ToricFan.Triangle.transition_self (s : ToricFan.Triangle) : transition s s = 1 :=
+  s.dual_rays
+
+private theorem ToricFan.Triangle.transition_mul (r s t : ToricFan.Triangle) :
+    transition s t * transition r s = transition r t := by
+  unfold transition
+  rw [Matrix.mul_assoc, ← Matrix.mul_assoc s.rays, rays_dual, Matrix.one_mul]
+
+private theorem ToricFan.Triangle.transition_covariance (s t : ToricFan.Triangle) :
+    t.rays * transition s t = s.rays := by
+  rw [transition, ← Matrix.mul_assoc, rays_dual, Matrix.one_mul]
+
+private theorem ToricFan.Triangle.transition_heightOne (s t : ToricFan.Triangle) :
+    ToricCharts.HeightOne (transition s t) := by
+  intro j
+  have h := congrFun (congrFun (transition_covariance s t) 2) j
+  simpa [Matrix.mul_apply] using h
+
+private def ToricFan.Triangle.chartChange (s t : ToricFan.Triangle) :
+    OpenPartialHomeomorph (ToricCharts.CoordinateSpace 3) (ToricCharts.CoordinateSpace 3) :=
+  ToricCharts.changeOfCoordinates (transition s t) (transition t s)
+    (by rw [transition_mul, transition_self]) (by rw [transition_mul, transition_self])
+
+@[simp]
+private theorem ToricFan.Triangle.chartChange_source (s t : ToricFan.Triangle) :
+    (chartChange s t).source = ToricCharts.domain (transition s t) :=
+  ToricCharts.overlap_eq_domain (transition_heightOne s t)
+    (by rw [transition_mul, transition_self])
+
+private theorem ToricFan.Triangle.chartChange_self_source (s : ToricFan.Triangle) :
+    (chartChange s s).source = Set.univ := by
+  rw [chartChange_source, transition_self]
+  ext z
+  simp only [ToricCharts.domain, Set.mem_ofPred_eq, Set.mem_univ, iff_true]
+  intro i j h
+  simp only [Matrix.one_apply] at h
+  split_ifs at h <;> omega
+
+@[simp]
+private theorem ToricFan.Triangle.chartChange_self_apply (s : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) : chartChange s s z = z := by
+  change ToricCharts.monomial (transition s s) z = z
+  rw [transition_self, ToricCharts.monomial_one]
+
+private theorem ToricFan.Triangle.chartChange_cocycle (r s t : ToricFan.Triangle)
+    {z : ToricCharts.CoordinateSpace 3} (hz : z ∈ (chartChange r s).source)
+    (hsz : chartChange r s z ∈ (chartChange s t).source) :
+    z ∈ (chartChange r t).source ∧ chartChange s t (chartChange r s z) = chartChange r t z := by
+  rw [chartChange_source] at hz hsz ⊢
+  have hm : z ∈ ToricCharts.overlap (transition r s) (transition s t) := ⟨hz, hsz⟩
+  constructor
+  · simpa only [transition_mul] using ToricCharts.domain_composition (transition_heightOne r s) hm
+  · change
+      ToricCharts.monomial (transition s t) (ToricCharts.monomial (transition r s) z) =
+        ToricCharts.monomial (transition r t) z
+    simpa only [Function.comp_apply, transition_mul] using
+      ToricCharts.monomial_mul_on_overlap (transition_heightOne r s) hm
+
+private theorem ToricFan.Triangle.chartChange_inter (r s t : ToricFan.Triangle)
+    {z : ToricCharts.CoordinateSpace 3} (hs : z ∈ (chartChange r s).source)
+    (ht : z ∈ (chartChange r t).source) : chartChange r s z ∈ (chartChange s t).source := by
+  have hi : chartChange r s z ∈ (chartChange s r).source := (chartChange r s).map_source hs
+  have hinv : chartChange s r (chartChange r s z) = z := (chartChange r s).left_inv hs
+  exact (chartChange_cocycle s r t hi (by rwa [hinv])).1
+
+private theorem ToricFan.Triangle.chartChange_holomorphic (s t : ToricFan.Triangle) :
+    ContDiffOn ℂ ω (chartChange s t) (chartChange s t).source :=
+  ToricCharts.changeOfCoordinates_holomorphic _ _ _ _
+
+private def ToricFan.Triangle.time (z : ToricCharts.CoordinateSpace 3) : ℂ :=
+  z 0 * z 1 * z 2
+
+private theorem ToricFan.Triangle.time_holomorphic : ContDiff ℂ ω time := by
+  exact ((contDiff_apply ℂ ℂ 0).mul (contDiff_apply ℂ ℂ 1)).mul (contDiff_apply ℂ ℂ 2)
+
+private theorem ToricFan.Triangle.monomial_rays_height (s : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) : ToricCharts.monomial s.rays z 2 = time z := by
+  simp [ToricCharts.monomial, rays_height, Fin.prod_univ_succ, time, mul_assoc]
+
+private theorem ToricFan.Triangle.chartChange_preserves_time (s t : ToricFan.Triangle) :
+    Set.EqOn (time ∘ chartChange s t) time (chartChange s t).source := by
+  have h :
+    Set.EqOn (time ∘ chartChange s t) time ((chartChange s t).source ∩ ToricCharts.torus) := by
+    intro z hz
+    change time (ToricCharts.monomial (transition s t) z) = time z
+    have he := congrFun (ToricCharts.monomial_mul_on_torus t.rays (transition s t) hz.2) 2
+    simpa only [transition_covariance, monomial_rays_height] using he
+  refine
+    h.of_subset_closure ?_ time_holomorphic.continuous.continuousOn Set.inter_subset_left
+      (ToricCharts.torus_dense.open_subset_closure_inter (chartChange s t).open_source)
+  exact time_holomorphic.continuous.comp_continuousOn (chartChange s t).continuousOn
+
+private theorem ToricFan.Triangle.central_fibre (z : ToricCharts.CoordinateSpace 3) :
+    time z = 0 ↔ z 0 = 0 ∨ z 1 = 0 ∨ z 2 = 0 := by simp [time, mul_eq_zero, or_assoc]
+
+private abbrev ToricSpace.gluingCore : TopCat.GlueData.MkCore
+    where
+  J := ToricFan.Triangle
+  U := fun _ => TopCat.of (ToricCharts.CoordinateSpace 3)
+  V s
+    t :=
+    ⟨(ToricFan.Triangle.chartChange s t).source, (ToricFan.Triangle.chartChange s t).open_source⟩
+  t s
+    t :=
+    TopCat.ofHom
+      { toFun := fun z =>
+          ⟨ToricFan.Triangle.chartChange s t z,
+            (ToricFan.Triangle.chartChange s t).map_source z.2⟩
+        continuous_toFun :=
+          (ToricFan.Triangle.chartChange s t).continuousOn.domRestrict.subtype_mk _ }
+  V_id
+    s := by
+    apply TopologicalSpace.Opens.ext
+    exact ToricFan.Triangle.chartChange_self_source s
+  t_id
+    s := by
+    funext z
+    exact Subtype.ext (ToricFan.Triangle.chartChange_self_apply s z.1)
+  t_inter := by
+    intro r s t z hz
+    exact ToricFan.Triangle.chartChange_inter r s t z.2 hz
+  cocycle r s t z
+    hz :=
+    (ToricFan.Triangle.chartChange_cocycle r s t z.2
+        (ToricFan.Triangle.chartChange_inter r s t z.2 hz)).2
+
+private abbrev ToricSpace.gluing : TopCat.GlueData :=
+  TopCat.GlueData.mk' gluingCore
+
+private abbrev ToricSpace.Space :=
+  gluing.toGlueData.glued
+
+private def ToricSpace.inclusion (s : ToricFan.Triangle) : ToricCharts.CoordinateSpace 3 → Space :=
+  gluing.toGlueData.ι s
+
+private theorem ToricSpace.inclusion_openEmbedding (s : ToricFan.Triangle) :
+    Topology.IsOpenEmbedding (ToricSpace.inclusion s) :=
+  gluing.ι_isOpenEmbedding s
+
+private theorem ToricSpace.inclusion_jointly_surjective (x : Space) :
+    ∃ s z, ToricSpace.inclusion s z = x :=
+  gluing.ι_jointly_surjective x
+
+private theorem ToricSpace.inclusion_eq_iff (s t : ToricFan.Triangle)
+    (z w : ToricCharts.CoordinateSpace 3) :
+    ToricSpace.inclusion s z = ToricSpace.inclusion t w ↔
+      z ∈ (ToricFan.Triangle.chartChange s t).source ∧ ToricFan.Triangle.chartChange s t z = w := by
+  refine (gluing.ι_eq_iff_rel s t z w).trans ?_
+  constructor
+  · rintro ⟨⟨v, hv⟩, h1, h2⟩
+    change v = z at h1
+    change ToricFan.Triangle.chartChange s t v = w at h2
+    subst v
+    exact ⟨hv, h2⟩
+  · rintro ⟨hz, he⟩
+    exact ⟨⟨z, hz⟩, rfl, he⟩
+
+private def ToricSpace.parametrization (s : ToricFan.Triangle) :
+    OpenPartialHomeomorph (ToricCharts.CoordinateSpace 3) Space :=
+  (inclusion_openEmbedding s).toOpenPartialHomeomorph (ToricSpace.inclusion s)
+
+@[simp]
+private theorem ToricSpace.parametrization_target (s : ToricFan.Triangle) :
+    (parametrization s).target = Set.range (ToricSpace.inclusion s) := by simp [parametrization]
+
+private theorem ToricSpace.parametrization_transition (s t : ToricFan.Triangle)
+    {z : ToricCharts.CoordinateSpace 3}
+    (hz : ToricSpace.inclusion s z ∈ Set.range (ToricSpace.inclusion t)) :
+    z ∈ (ToricFan.Triangle.chartChange s t).source ∧
+      (parametrization t).symm (ToricSpace.inclusion s z) = ToricFan.Triangle.chartChange s t z :=
+  by
+  obtain ⟨w, hw⟩ := hz
+  have he := (inclusion_eq_iff s t z w).mp hw.symm
+  refine ⟨he.1, ?_⟩
+  rw [← hw]
+  exact ((inclusion_openEmbedding t).toOpenPartialHomeomorph_left_inv).trans he.2.symm
+
+private def ToricSpace.preferredTriangle (x : Space) : ToricFan.Triangle :=
+  (inclusion_jointly_surjective x).choose
+
+private theorem ToricSpace.preferred_mem (x : Space) :
+    x ∈ Set.range (ToricSpace.inclusion (preferredTriangle x)) :=
+  (inclusion_jointly_surjective x).choose_spec
+
+private instance ToricSpace.chartedSpace : ChartedSpace (ToricCharts.CoordinateSpace 3) Space
+    where
+  atlas := Set.range (fun s : ToricFan.Triangle => (parametrization s).symm)
+  chartAt x := (parametrization (preferredTriangle x)).symm
+  mem_chart_source
+    x := by
+    change x ∈ (parametrization (preferredTriangle x)).target
+    rw [parametrization_target]
+    exact preferred_mem x
+  chart_mem_atlas x := Set.mem_range_self _
+
+private theorem ToricSpace.transition_holomorphic (s t : ToricFan.Triangle) :
+    ContDiffOn ℂ ω ((parametrization s).trans (parametrization t).symm)
+      ((parametrization s).trans (parametrization t).symm).source := by
+  have hparam (s : ToricFan.Triangle) (z : ToricCharts.CoordinateSpace 3) :
+    parametrization s z = ToricSpace.inclusion s z := rfl
+  have h :
+    ∀ z ∈ ((parametrization s).trans (parametrization t).symm).source,
+      z ∈ (ToricFan.Triangle.chartChange s t).source ∧
+        ((parametrization s).trans (parametrization t).symm) z =
+          ToricFan.Triangle.chartChange s t z := by
+    intro z hz
+    exact parametrization_transition s t (by simpa [hparam] using hz.2)
+  exact
+    ((ToricFan.Triangle.chartChange_holomorphic s t).mono (fun z hz => (h z hz).1)).congr
+      (fun z hz => (h z hz).2)
+
+private instance ToricSpace.isManifold :
+    IsManifold (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω Space := by
+  apply isManifold_of_contDiffOn
+  intro e e' he he'
+  obtain ⟨s, rfl⟩ := he
+  obtain ⟨t, rfl⟩ := he'
+  simpa using transition_holomorphic s t
+
+private instance ToricSpace.secondCountableTopology : SecondCountableTopology Space := by
+  let U : ToricFan.Triangle → Set Space := fun s => Set.range (ToricSpace.inclusion s)
+  let (s : ToricFan.Triangle) : SecondCountableTopology (U s) :=
+    (inclusion_openEmbedding s).isEmbedding.toHomeomorph.symm.secondCountableTopology
+  apply
+    TopologicalSpace.secondCountableTopology_of_countable_cover (U := U)
+      (fun s => (inclusion_openEmbedding s).isOpen_range)
+  apply Set.eq_univ_of_forall
+  intro x
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  exact Set.mem_iUnion.mpr ⟨s, Set.mem_range_self z⟩
+
+private def ToricSpace.time (x : Space) : ℂ :=
+  ToricFan.Triangle.time ((parametrization (preferredTriangle x)).symm x)
+
+@[simp]
+private theorem
+    ToricSpace.time_inclusion (s : ToricFan.Triangle) (z : ToricCharts.CoordinateSpace 3) :
+    time (ToricSpace.inclusion s z) = ToricFan.Triangle.time z := by
+  change
+    ToricFan.Triangle.time
+        ((parametrization (preferredTriangle (ToricSpace.inclusion s z))).symm
+          (ToricSpace.inclusion s z)) =
+      ToricFan.Triangle.time z
+  have h :=
+    parametrization_transition s (preferredTriangle (ToricSpace.inclusion s z))
+      (preferred_mem (ToricSpace.inclusion s z))
+  rw [h.2]
+  exact ToricFan.Triangle.chartChange_preserves_time _ _ h.1
+
+private theorem ToricSpace.time_comp_parametrization (s : ToricFan.Triangle) :
+    time ∘ parametrization s = ToricFan.Triangle.time := by
+  funext z
+  exact time_inclusion s z
+
+private theorem ToricSpace.time_holomorphic :
+    ContMDiff (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) (modelWithCornersSelf ℂ ℂ)
+      ω time := by
+  intro x
+  rw [contMDiffAt_iff_source]
+  have hchart :
+    chartAt (ToricCharts.CoordinateSpace 3) x = (parametrization (preferredTriangle x)).symm :=
+    rfl
+  simpa [extChartAt, OpenPartialHomeomorph.extend, hchart, time_comp_parametrization] using
+    ToricFan.Triangle.time_holomorphic.contMDiff.contMDiffAt.contMDiffWithinAt (s := Set.univ)
+      (x := (parametrization (preferredTriangle x)).symm x)
+
+private def ToricSpace.referenceTriangle : ToricFan.Triangle :=
+  ⟨0, 0, Bool.false⟩
+
+private def ToricSpace.openTorus : Set Space :=
+  ToricSpace.inclusion referenceTriangle '' ToricCharts.torus
+
+private theorem ToricSpace.inclusion_torus_subset (s : ToricFan.Triangle) :
+    ToricSpace.inclusion s '' ToricCharts.torus ⊆ openTorus := by
+  rintro _ ⟨z, hz, rfl⟩
+  refine
+    ⟨ToricFan.Triangle.chartChange s referenceTriangle z, ToricCharts.monomial_mapsTo_torus _ hz,
+      ?_⟩
+  exact
+    ((inclusion_eq_iff s referenceTriangle z _).mpr
+        ⟨ToricCharts.torus_subset_overlap _ _ hz, rfl⟩).symm
+
+private theorem ToricSpace.mem_openTorus_iff (x : Space) : x ∈ openTorus ↔ time x ≠ 0 := by
+  constructor
+  · rintro ⟨z, hz, rfl⟩
+    rw [time_inclusion]
+    exact mul_ne_zero (mul_ne_zero (hz 0) (hz 1)) (hz 2)
+  · intro hx
+    obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+    have hz : z ∈ ToricCharts.torus := by
+      have h : (z 0 ≠ 0 ∧ z 1 ≠ 0) ∧ z 2 ≠ 0 := by
+        simpa only [time_inclusion, ToricFan.Triangle.time, mul_ne_zero_iff] using hx
+      intro i
+      fin_cases i
+      · exact h.1.1
+      · exact h.1.2
+      · exact h.2
+    exact inclusion_torus_subset s ⟨z, hz, rfl⟩
+
+private theorem ToricSpace.openTorus_isOpen : IsOpen openTorus := by
+  have he : openTorus = {x | time x ≠ 0} := Set.ext mem_openTorus_iff
+  rw [he]
+  exact isOpen_ne_fun time_holomorphic.continuous continuous_const
+
+private theorem ToricSpace.openTorus_dense : Dense openTorus := by
+  intro x
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  apply closure_mono (inclusion_torus_subset s)
+  exact
+    mem_closure_image (inclusion_openEmbedding s).continuous.continuousAt
+      (ToricCharts.torus_dense z)
+
+private theorem ToricSpace.inclusion_holomorphic (s : ToricFan.Triangle) :
+    ContMDiff (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (ToricSpace.inclusion s) := by
+  have he :
+    (parametrization s).symm ∈
+      IsManifold.maximalAtlas (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω Space :=
+    IsManifold.subset_maximalAtlas (Set.mem_range_self s)
+  have h := contMDiffOn_symm_of_mem_maximalAtlas he
+  change
+    ContMDiffOn (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (ToricSpace.inclusion s)
+      Set.univ at h
+  exact contMDiffOn_univ.mp h
+
+private def
+    ToricSpace.descend {Y : Type*} (f : ToricFan.Triangle → ToricCharts.CoordinateSpace 3 → Y)
+    (x : Space) : Y :=
+  f (preferredTriangle x) ((parametrization (preferredTriangle x)).symm x)
+
+private theorem ToricSpace.descend_inclusion {Y : Type*}
+    (f : ToricFan.Triangle → ToricCharts.CoordinateSpace 3 → Y)
+    (h :
+      ∀ s t z,
+        z ∈ (ToricFan.Triangle.chartChange s t).source →
+          f t (ToricFan.Triangle.chartChange s t z) = f s z)
+    (s : ToricFan.Triangle) (z : ToricCharts.CoordinateSpace 3) :
+    descend f (ToricSpace.inclusion s z) = f s z := by
+  change
+    f (preferredTriangle (ToricSpace.inclusion s z))
+        ((parametrization (preferredTriangle (ToricSpace.inclusion s z))).symm
+          (ToricSpace.inclusion s z)) =
+      f s z
+  have he :=
+    parametrization_transition s (preferredTriangle (ToricSpace.inclusion s z))
+      (preferred_mem (ToricSpace.inclusion s z))
+  rw [he.2]
+  exact h _ _ _ he.1
+
+private theorem
+    ToricSpace.descend_holomorphic {F H Y : Type*} [NormedAddCommGroup F] [NormedSpace ℂ F]
+    [TopologicalSpace H] [TopologicalSpace Y] [ChartedSpace H Y] (I : ModelWithCorners ℂ F H)
+    (f : ToricFan.Triangle → ToricCharts.CoordinateSpace 3 → Y)
+    (h :
+      ∀ s t z,
+        z ∈ (ToricFan.Triangle.chartChange s t).source →
+          f t (ToricFan.Triangle.chartChange s t z) = f s z)
+    (hf : ∀ s, ContMDiff (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) I ω (f s)) :
+    ContMDiff (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) I ω (descend f) := by
+  have hcomp (s : ToricFan.Triangle) : descend f ∘ parametrization s = f s := by
+    funext z
+    exact descend_inclusion f h s z
+  intro x
+  rw [contMDiffAt_iff_source]
+  have hchart :
+    chartAt (ToricCharts.CoordinateSpace 3) x = (parametrization (preferredTriangle x)).symm :=
+    rfl
+  simpa [extChartAt, OpenPartialHomeomorph.extend, hchart, hcomp] using
+    (hf (preferredTriangle x)).contMDiffAt.contMDiffWithinAt (s := Set.univ) (x :=
+      (parametrization (preferredTriangle x)).symm x)
+
+private theorem ToricSpace.contMDiffOn_of_comp_inclusion {F H Y : Type*} [NormedAddCommGroup F]
+    [NormedSpace ℂ F] [TopologicalSpace H] [TopologicalSpace Y] [ChartedSpace H Y]
+    (I : ModelWithCorners ℂ F H) (f : Space → Y) {U : Set Space} (hU : IsOpen U)
+    (hf :
+      ∀ s,
+        ContMDiffOn (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) I ω
+          (f ∘ ToricSpace.inclusion s) (ToricSpace.inclusion s ⁻¹' U)) :
+    ContMDiffOn (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) I ω f U := by
+  have hparam (s : ToricFan.Triangle) (z : ToricCharts.CoordinateSpace 3) :
+    parametrization s z = ToricSpace.inclusion s z := rfl
+  intro x hx
+  apply ContMDiffAt.contMDiffWithinAt
+  rw [contMDiffAt_iff_source]
+  have he :
+    ToricSpace.inclusion (preferredTriangle x) ((parametrization (preferredTriangle x)).symm x) =
+      x :=
+    Topology.IsOpenEmbedding.toOpenPartialHomeomorph_right_inv
+      (ToricSpace.inclusion (preferredTriangle x)) (inclusion_openEmbedding _) (preferred_mem x)
+  have hm :
+    (parametrization (preferredTriangle x)).symm x ∈
+      ToricSpace.inclusion (preferredTriangle x) ⁻¹' U := by
+    change ToricSpace.inclusion _ _ ∈ U
+    rwa [he]
+  have hlocal :=
+    (hf (preferredTriangle x)).contMDiffAt
+      ((hU.preimage (inclusion_openEmbedding _).continuous).mem_nhds hm)
+  have hchart :
+    chartAt (ToricCharts.CoordinateSpace 3) x = (parametrization (preferredTriangle x)).symm :=
+    rfl
+  simpa [hparam, extChartAt, OpenPartialHomeomorph.extend, hchart, Function.comp_def] using
+    hlocal.contMDiffWithinAt (s := Set.univ)
+
+private def ToricSeparation.stripIndex (s : ToricFan.Triangle) : Fin 3 → ℤ :=
+  ![s.a, s.b, s.a + s.b + if s.upper then 1 else 0]
+
+private def ToricSeparation.pencil (k : Fin 3) (x : Fin 3 → ℤ) : ℤ :=
+  ![x 0, x 1, x 0 + x 1] k
+
+private def ToricSeparation.sign (a b : ℤ) : ℤ :=
+  if a < b then -1 else if b < a then 1 else 0
+
+private def ToricSeparation.stripValue (a b x : ℤ) : ℤ :=
+  sign a b * (2 * x - a - b - 1)
+
+private theorem ToricSeparation.sign_swap (a b : ℤ) : sign b a = -sign a b := by
+  unfold sign
+  split_ifs <;> omega
+
+private theorem ToricSeparation.stripValue_nonneg {a b x : ℤ} (hx : a ≤ x ∧ x ≤ a + 1) :
+    0 ≤ stripValue a b x := by
+  unfold stripValue sign
+  split_ifs <;> omega
+
+private theorem ToricSeparation.stripValue_zero_bounds {a b x : ℤ} (hx : a ≤ x ∧ x ≤ a + 1)
+    (hzero : stripValue a b x = 0) : b ≤ x ∧ x ≤ b + 1 := by
+  unfold stripValue sign at hzero
+  split_ifs at hzero <;> omega
+
+private theorem ToricSeparation.ray_strip_bounds (s : ToricFan.Triangle) (j k : Fin 3) :
+    stripIndex s k ≤ pencil k (fun i => s.rays i j) ∧
+      pencil k (fun i => s.rays i j) ≤ stripIndex s k + 1 := by
+  cases h : s.upper <;> fin_cases j <;> fin_cases k <;>
+      simp [stripIndex, pencil, ToricFan.Triangle.rays, h] <;>
+    omega
+
+private theorem ToricSeparation.transition_nonneg_of_bounds (s t : ToricFan.Triangle) (j : Fin 3)
+    (h :
+      ∀ k,
+        stripIndex t k ≤ pencil k (fun i => s.rays i j) ∧
+          pencil k (fun i => s.rays i j) ≤ stripIndex t k + 1) :
+    ∀ i, 0 ≤ ToricFan.Triangle.transition s t i j := by
+  have h0 := h 0
+  have h1 := h 1
+  have h2 := h 2
+  intro i
+  cases ht : t.upper <;> fin_cases i <;>
+        simp [ToricFan.Triangle.transition, ToricFan.Triangle.dual, ht, Matrix.mul_apply,
+          Fin.sum_univ_succ] <;>
+      simp [stripIndex, pencil, ht] at h0 h1 h2 <;>
+    omega
+
+private def ToricSeparation.character (s t : ToricFan.Triangle) : Fin 3 → ℤ :=
+  let e : Fin 3 → ℤ := fun k => sign (stripIndex s k) (stripIndex t k)
+  ![2 * (e 0 + e 2), 2 * (e 1 + e 2),
+    -(e 0 * (stripIndex s 0 + stripIndex t 0 + 1) + e 1 * (stripIndex s 1 + stripIndex t 1 + 1) +
+        e 2 * (stripIndex s 2 + stripIndex t 2 + 1))]
+
+private theorem ToricSeparation.character_swap (s t : ToricFan.Triangle) :
+    character t s = -character s t := by
+  have he (k : Fin 3) :
+    sign (stripIndex t k) (stripIndex s k) = -sign (stripIndex s k) (stripIndex t k) :=
+    sign_swap _ _
+  unfold character
+  simp only [he]
+  ext i
+  fin_cases i <;> dsimp <;> ring
+
+private def ToricSeparation.exponents (s t : ToricFan.Triangle) : Fin 3 → ℤ :=
+  character s t ᵥ* s.rays
+
+private theorem ToricSeparation.exponents_eq_sum (s t : ToricFan.Triangle) (j : Fin 3) :
+    exponents s t j =
+      ∑ k, stripValue (stripIndex s k) (stripIndex t k) (pencil k (fun i => s.rays i j)) := by
+  simp [exponents, character, Matrix.vecMul, dotProduct, Fin.sum_univ_succ, stripValue, pencil]
+  ring
+
+private theorem ToricSeparation.exponents_nonneg (s t : ToricFan.Triangle) (j : Fin 3) :
+    0 ≤ exponents s t j := by
+  rw [exponents_eq_sum]
+  exact Finset.sum_nonneg fun k _ => stripValue_nonneg (ray_strip_bounds s j k)
+
+private theorem
+    ToricSeparation.transition_nonneg_of_exponent_zero (s t : ToricFan.Triangle) (j : Fin 3)
+    (hzero : exponents s t j = 0) : ∀ i, 0 ≤ ToricFan.Triangle.transition s t i j := by
+  apply transition_nonneg_of_bounds s t j
+  intro k
+  apply stripValue_zero_bounds (ray_strip_bounds s j k)
+  rw [exponents_eq_sum] at hzero
+  exact
+    (Finset.sum_eq_zero_iff_of_nonneg (fun k _ => stripValue_nonneg (ray_strip_bounds s j k))).mp
+      hzero k (Finset.mem_univ k)
+
+private theorem
+    ToricSeparation.exponents_pos_of_transition_neg (s t : ToricFan.Triangle) (i j : Fin 3)
+    (hneg : ToricFan.Triangle.transition s t i j < 0) : 0 < exponents s t j := by
+  have hn := exponents_nonneg s t j
+  by_contra h
+  have hz : exponents s t j = 0 := by omega
+  exact (not_lt_of_ge (transition_nonneg_of_exponent_zero s t j hz i)) hneg
+
+private theorem ToricSeparation.exponents_transition (s t : ToricFan.Triangle) :
+    exponents t s ᵥ* ToricFan.Triangle.transition s t = -exponents s t := by
+  rw [exponents, character_swap, Matrix.vecMul_vecMul, ToricFan.Triangle.transition_covariance]
+  simp [exponents, Matrix.neg_vecMul]
+
+private theorem ToricSeparation.exponents_cancel (s t : ToricFan.Triangle) (j : Fin 3) :
+    exponents s t j + ∑ i, exponents t s i * ToricFan.Triangle.transition s t i j = 0 := by
+  have h := congrFun (exponents_transition s t) j
+  change (∑ i, exponents t s i * ToricFan.Triangle.transition s t i j) = -exponents s t j at h
+  omega
+
+private def ToricCharts.character (a : Fin 3 → ℤ) (z : CoordinateSpace 3) : ℂ :=
+  ∏ j, z j ^ a j
+
+private theorem ToricCharts.character_contDiff (a : Fin 3 → ℤ) (ha : ∀ j, 0 ≤ a j) (n : ℕ∞ω) :
+    ContDiff ℂ n (character a) := by
+  apply contDiff_prod
+  intro j _
+  have he :
+    (fun z : CoordinateSpace 3 => z j ^ a j) = (fun z : CoordinateSpace 3 => z j ^ (a j).toNat) :=
+    by
+    funext z
+    conv_lhs => rw [← Int.toNat_of_nonneg (ha j), zpow_natCast]
+  rw [he]
+  exact (contDiff_apply ℂ ℂ j).pow _
+
+private theorem ToricCharts.characters_mul_on_torus (A : Matrix (Fin 3) (Fin 3) ℤ) (a b : Fin 3 → ℤ)
+    (h : ∀ j, a j + ∑ i, b i * A i j = 0) {z : CoordinateSpace 3} (hz : z ∈ torus) :
+    character a z * character b (monomial A z) = 1 := by
+  have he := congrFun (monomial_mul_on_torus (fun _ j : Fin 3 => b j) A hz) 0
+  change character b (monomial A z) = ∏ j, z j ^ ∑ i, b i * A i j at he
+  rw [he]
+  unfold character
+  rw [← Finset.prod_mul_distrib]
+  calc
+    (∏ j, z j ^ a j * z j ^ ∑ i, b i * A i j) = ∏ _j : Fin 3, (1 : ℂ) := by
+      apply Finset.prod_congr rfl
+      intro j _
+      rw [← zpow_add₀ (hz j), h j, zpow_zero]
+    _ = 1 := by simp
+
+private theorem
+    ToricCharts.characters_mul_on_domain (A : Matrix (Fin 3) (Fin 3) ℤ) (a b : Fin 3 → ℤ)
+    (ha : ∀ j, 0 ≤ a j) (hb : ∀ j, 0 ≤ b j) (h : ∀ j, a j + ∑ i, b i * A i j = 0) :
+    Set.EqOn (fun z => character a z * character b (monomial A z)) (fun _ => 1) (domain A) := by
+  have he :
+    Set.EqOn (fun z => character a z * character b (monomial A z)) (fun _ => 1)
+      (domain A ∩ torus) :=
+    fun _ hz => characters_mul_on_torus A a b h hz.2
+  refine
+    he.of_subset_closure ?_ continuousOn_const Set.inter_subset_left
+      (torus_dense.open_subset_closure_inter (domain_open A))
+  exact
+    (character_contDiff a ha 0).continuous.continuousOn.mul
+      ((character_contDiff b hb 0).continuous.comp_continuousOn
+        (monomial_contDiffOn A 0).continuousOn)
+
+private def ToricCharts.overlapGraph (A : Matrix (Fin 3) (Fin 3) ℤ) :
+    Set (CoordinateSpace 3 × CoordinateSpace 3) :=
+  {p | p.1 ∈ domain A ∧ monomial A p.1 = p.2}
+
+private theorem ToricCharts.overlapGraph_closed (A : Matrix (Fin 3) (Fin 3) ℤ) (a b : Fin 3 → ℤ)
+    (ha : ∀ j, 0 ≤ a j) (hb : ∀ j, 0 ≤ b j) (hcancel : ∀ j, a j + ∑ i, b i * A i j = 0)
+    (hpos : ∀ i j, A i j < 0 → 0 < a j) : IsClosed (overlapGraph A) := by
+  let P : CoordinateSpace 3 × CoordinateSpace 3 → ℂ := fun p => character a p.1 * character b p.2
+  have hP : Continuous P :=
+    ((character_contDiff a ha 0).continuous.comp continuous_fst).mul
+      ((character_contDiff b hb 0).continuous.comp continuous_snd)
+  have hsubset : overlapGraph A ⊆ {p | P p = 1} := by
+    intro p hp
+    change character a p.1 * character b p.2 = 1
+    rw [← hp.2]
+    exact characters_mul_on_domain A a b ha hb hcancel hp.1
+  apply isClosed_of_closure_subset
+  intro p hp
+  have hPeq : P p = 1 := closure_minimal hsubset (isClosed_eq hP continuous_const) hp
+  have hD : p.1 ∈ domain A := by
+    intro i j hij hz
+    have hchar : character a p.1 = 0 := by
+      apply Finset.prod_eq_zero (Finset.mem_univ j)
+      rw [hz, zero_zpow _ (ne_of_gt (hpos i j hij))]
+    change character a p.1 * character b p.2 = 1 at hPeq
+    simp [hchar] at hPeq
+  refine ⟨hD, ?_⟩
+  let : (𝓝[overlapGraph A] p).NeBot := mem_closure_iff_nhdsWithin_neBot.mp hp
+  have hf : ContinuousAt (fun q : CoordinateSpace 3 × CoordinateSpace 3 => monomial A q.1) p :=
+    ((monomial_contDiffOn A 0).continuousOn.continuousAt ((domain_open A).mem_nhds hD)).comp
+      continuous_fst.continuousAt
+  have he :
+    (fun q : CoordinateSpace 3 × CoordinateSpace 3 => monomial A q.1) =ᶠ[𝓝[overlapGraph A] p]
+      Prod.snd := by
+    filter_upwards [self_mem_nhdsWithin (s := overlapGraph A) (a := p)] with q hq
+    exact hq.2
+  exact
+    tendsto_nhds_unique hf.continuousWithinAt
+      (continuous_snd.continuousAt.continuousWithinAt.congr' he.symm)
+
+private theorem ToricSpace.chart_overlap_graph_closed (s t : ToricFan.Triangle) :
+    IsClosed (ToricCharts.overlapGraph (ToricFan.Triangle.transition s t)) :=
+  ToricCharts.overlapGraph_closed (ToricFan.Triangle.transition s t)
+    (ToricSeparation.exponents s t) (ToricSeparation.exponents t s)
+    (ToricSeparation.exponents_nonneg s t) (ToricSeparation.exponents_nonneg t s)
+    (ToricSeparation.exponents_cancel s t) (ToricSeparation.exponents_pos_of_transition_neg s t)
+
+private instance ToricSpace.t2Space : T2Space Space := by
+  constructor
+  intro x y hxy
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  obtain ⟨t, w, rfl⟩ := inclusion_jointly_surjective y
+  have hn : (z, w) ∈ (ToricCharts.overlapGraph (ToricFan.Triangle.transition s t))ᶜ := by
+    intro h
+    apply hxy
+    exact (inclusion_eq_iff s t z w).mpr ⟨by simpa using h.1, h.2⟩
+  obtain ⟨U, V, hU, hV, hz, hw, hUV⟩ :=
+    isOpen_prod_iff.mp (chart_overlap_graph_closed s t).isOpen_compl z w hn
+  refine
+    ⟨ToricSpace.inclusion s '' U, ToricSpace.inclusion t '' V,
+      (inclusion_openEmbedding s).isOpenMap _ hU, (inclusion_openEmbedding t).isOpenMap _ hV,
+      Set.mem_image_of_mem _ hz, Set.mem_image_of_mem _ hw, ?_⟩
+  apply Set.disjoint_left.mpr
+  rintro q ⟨u, hu, hsu⟩ ⟨v, hv, htv⟩
+  have he := (inclusion_eq_iff s t u v).mp (hsu.trans htv.symm)
+  exact hUV (show (u, v) ∈ U ×ˢ V from ⟨hu, hv⟩) ⟨by simpa using he.1, he.2⟩
+
+private def ToricFan.Triangle.shift (s : ToricFan.Triangle) (v : Fin 2 → ℤ) : ToricFan.Triangle :=
+  ⟨s.a + v 0, s.b + v 1, s.upper⟩
+
+@[simp]
+private theorem ToricFan.Triangle.shift_zero (s : ToricFan.Triangle) : s.shift 0 = s := by
+  ext <;> simp [shift]
+
+private theorem ToricFan.Triangle.shift_add (s : ToricFan.Triangle) (v w : Fin 2 → ℤ) :
+    (s.shift v).shift w = s.shift (v + w) := by ext <;> simp [shift, add_assoc]
+
+private def ToricFan.Triangle.shear (v : Fin 2 → ℤ) : Matrix (Fin 3) (Fin 3) ℤ :=
+  !![1, 0, v 0; 0, 1, v 1; 0, 0, 1]
+
+@[simp]
+private theorem ToricFan.Triangle.shear_zero : shear 0 = 1 := by decide
+
+private theorem
+    ToricFan.Triangle.shear_add (v w : Fin 2 → ℤ) : shear v * shear w = shear (v + w) := by
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp [shear, Matrix.mul_apply, Fin.sum_univ_succ, add_comm]
+
+private theorem ToricFan.Triangle.rays_shift (s : ToricFan.Triangle) (v : Fin 2 → ℤ) :
+    (s.shift v).rays = shear v * s.rays := by
+  ext i j
+  cases hs : s.upper <;> fin_cases i <;> fin_cases j <;>
+      simp [rays, shift, shear, hs, Matrix.mul_apply, Fin.sum_univ_succ] <;>
+    ring
+
+private theorem ToricFan.Triangle.dual_shift (s : ToricFan.Triangle) (v : Fin 2 → ℤ) :
+    (s.shift v).dual = s.dual * shear (-v) := by
+  ext i j
+  cases hs : s.upper <;> fin_cases i <;> fin_cases j <;>
+      simp [dual, shift, shear, hs, Matrix.mul_apply, Fin.sum_univ_succ] <;>
+    ring
+
+private theorem ToricFan.Triangle.transition_shift (s t : ToricFan.Triangle) (v : Fin 2 → ℤ) :
+    transition (s.shift v) (t.shift v) = transition s t := by
+  rw [transition, dual_shift, rays_shift, Matrix.mul_assoc, ← Matrix.mul_assoc (shear (-v)),
+    shear_add]
+  simp [transition]
+
+private theorem
+    ToricFan.Triangle.chartChange_shift_source (s t : ToricFan.Triangle) (v : Fin 2 → ℤ) :
+    (chartChange (s.shift v) (t.shift v)).source = (chartChange s t).source := by
+  simp [transition_shift]
+
+private theorem ToricFan.Triangle.chartChange_shift_apply (s t : ToricFan.Triangle) (v : Fin 2 → ℤ)
+    (z : ToricCharts.CoordinateSpace 3) :
+    chartChange (s.shift v) (t.shift v) z = chartChange s t z := by
+  change
+    ToricCharts.monomial (transition (s.shift v) (t.shift v)) z =
+      ToricCharts.monomial (transition s t) z
+  rw [transition_shift]
+
+private theorem ToricSpace.translation_compatible (v : Fin 2 → ℤ) (s t : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) (hz : z ∈ (ToricFan.Triangle.chartChange s t).source) :
+    ToricSpace.inclusion (t.shift v) (ToricFan.Triangle.chartChange s t z) =
+      ToricSpace.inclusion (s.shift v) z := by
+  apply ((inclusion_eq_iff (s.shift v) (t.shift v) z _).mpr ?_).symm
+  exact
+    ⟨by simpa only [ToricFan.Triangle.chartChange_shift_source] using hz,
+      ToricFan.Triangle.chartChange_shift_apply s t v z⟩
+
+private def ToricSpace.translate (v : Fin 2 → ℤ) : Space → Space :=
+  descend (fun s z => ToricSpace.inclusion (s.shift v) z)
+
+@[simp]
+private theorem ToricSpace.translate_inclusion (v : Fin 2 → ℤ) (s : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) :
+    ToricSpace.translate v (ToricSpace.inclusion s z) = ToricSpace.inclusion (s.shift v) z :=
+  descend_inclusion _ (translation_compatible v) s z
+
+private theorem ToricSpace.translate_holomorphic (v : Fin 2 → ℤ) :
+    ContMDiff (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (ToricSpace.translate v) :=
+  descend_holomorphic _ _ (translation_compatible v) (fun s => inclusion_holomorphic (s.shift v))
+
+@[simp]
+private theorem ToricSpace.translate_zero (x : Space) : ToricSpace.translate 0 x = x := by
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  simp
+
+private theorem ToricSpace.translate_add (v w : Fin 2 → ℤ) (x : Space) :
+    ToricSpace.translate v (ToricSpace.translate w x) = ToricSpace.translate (v + w) x := by
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  simp [ToricFan.Triangle.shift_add, add_comm v w]
+
+private def ToricSpace.translationHomeomorph (v : Fin 2 → ℤ) : Space ≃ₜ Space
+    where
+  toFun := ToricSpace.translate v
+  invFun := ToricSpace.translate (-v)
+  left_inv x := by rw [ToricSpace.translate_add]; simp
+  right_inv x := by rw [ToricSpace.translate_add]; simp
+  continuous_toFun := (translate_holomorphic v).continuous
+  continuous_invFun := (translate_holomorphic (-v)).continuous
+
+@[simp]
+private theorem ToricSpace.time_translate (v : Fin 2 → ℤ) (x : Space) :
+    time (ToricSpace.translate v x) = time x := by
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  simp
+
+private abbrev ToricSpace.ActingTorus :=
+  Fin 3 → ℂˣ
+
+private def ToricSpace.factors (s : ToricFan.Triangle) (u : ActingTorus) :
+    ToricCharts.CoordinateSpace 3 :=
+  ToricCharts.monomial s.dual (fun j => (u j : ℂ))
+
+private theorem ToricSpace.factors_nonzero (s : ToricFan.Triangle) (u : ActingTorus) (j : Fin 3) :
+    factors s u j ≠ 0 :=
+  ToricCharts.monomial_mapsTo_torus _ (fun i => (u i).ne_zero) j
+
+private def ToricSpace.scale (s : ToricFan.Triangle) (u : ActingTorus)
+    (z : ToricCharts.CoordinateSpace 3) : ToricCharts.CoordinateSpace 3 :=
+  factors s u * z
+
+private theorem ToricSpace.scale_holomorphic (s : ToricFan.Triangle) (u : ActingTorus) :
+    ContDiff ℂ ω (scale s u) := by
+  apply contDiff_pi.mpr
+  intro j
+  exact contDiff_const.mul (contDiff_apply ℂ ℂ j)
+
+private theorem ToricSpace.scale_mem_source (s t : ToricFan.Triangle) (u : ActingTorus)
+    (z : ToricCharts.CoordinateSpace 3) :
+    scale s u z ∈ (ToricFan.Triangle.chartChange s t).source ↔
+      z ∈ (ToricFan.Triangle.chartChange s t).source := by
+  simp [ToricFan.Triangle.chartChange_source, ToricCharts.domain, scale, factors_nonzero]
+
+private theorem ToricSpace.transition_factors (s t : ToricFan.Triangle) (u : ActingTorus) :
+    ToricCharts.monomial (ToricFan.Triangle.transition s t) (factors s u) = factors t u := by
+  have he : ToricFan.Triangle.transition s t * s.dual = t.dual := by
+    rw [ToricFan.Triangle.transition, Matrix.mul_assoc, ToricFan.Triangle.rays_dual,
+      Matrix.mul_one]
+  change
+    ToricCharts.monomial (ToricFan.Triangle.transition s t)
+        (ToricCharts.monomial s.dual (fun j => (u j : ℂ))) =
+      _
+  rw [ToricCharts.monomial_mul_on_torus _ _ (fun j => (u j).ne_zero), he]
+  rfl
+
+private theorem ToricSpace.scale_transition (s t : ToricFan.Triangle) (u : ActingTorus)
+    (z : ToricCharts.CoordinateSpace 3) :
+    ToricFan.Triangle.chartChange s t (scale s u z) =
+      scale t u (ToricFan.Triangle.chartChange s t z) := by
+  change
+    ToricCharts.monomial (ToricFan.Triangle.transition s t) (factors s u * z) =
+      factors t u * ToricCharts.monomial (ToricFan.Triangle.transition s t) z
+  rw [ToricCharts.monomial_mul, transition_factors]
+
+private theorem ToricSpace.action_compatible (u : ActingTorus) (s t : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) (hz : z ∈ (ToricFan.Triangle.chartChange s t).source) :
+    ToricSpace.inclusion t (scale t u (ToricFan.Triangle.chartChange s t z)) =
+      ToricSpace.inclusion s (scale s u z) := by
+  exact
+    ((inclusion_eq_iff s t _ _).mpr
+        ⟨(scale_mem_source s t u z).mpr hz, scale_transition s t u z⟩).symm
+
+private def ToricSpace.torusAction (u : ActingTorus) : Space → Space :=
+  descend (fun s z => ToricSpace.inclusion s (scale s u z))
+
+@[simp]
+private theorem ToricSpace.torusAction_inclusion (u : ActingTorus) (s : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) :
+    torusAction u (ToricSpace.inclusion s z) = ToricSpace.inclusion s (scale s u z) :=
+  descend_inclusion _ (action_compatible u) s z
+
+private theorem ToricSpace.torusAction_holomorphic (u : ActingTorus) :
+    ContMDiff (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (torusAction u) :=
+  descend_holomorphic _ _ (action_compatible u)
+    (fun s => (inclusion_holomorphic s).comp (scale_holomorphic s u).contMDiff)
+
+@[simp]
+private theorem ToricSpace.factors_one (s : ToricFan.Triangle) : factors s 1 = 1 := by
+  change ToricCharts.monomial s.dual 1 = 1
+  exact ToricCharts.monomial_ones _
+
+private theorem ToricSpace.factors_mul (s : ToricFan.Triangle) (u v : ActingTorus) :
+    factors s (u * v) = factors s u * factors s v := by
+  change ToricCharts.monomial s.dual ((fun j => (u j : ℂ)) * (fun j => (v j : ℂ))) = _
+  exact ToricCharts.monomial_mul _ _ _
+
+@[simp]
+private theorem ToricSpace.scale_one (s : ToricFan.Triangle) (z : ToricCharts.CoordinateSpace 3) :
+    scale s 1 z = z := by simp [scale]
+
+private theorem ToricSpace.scale_mul (s : ToricFan.Triangle) (u v : ActingTorus)
+    (z : ToricCharts.CoordinateSpace 3) : scale s u (scale s v z) = scale s (u * v) z := by
+  simp [scale, factors_mul, mul_assoc]
+
+@[simp]
+private theorem ToricSpace.torusAction_one (x : Space) : torusAction 1 x = x := by
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  simp
+
+private theorem ToricSpace.torusAction_mul (u v : ActingTorus) (x : Space) :
+    torusAction u (torusAction v x) = torusAction (u * v) x := by
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  simp [scale_mul]
+
+private def ToricSpace.torusHomeomorph (u : ActingTorus) : Space ≃ₜ Space
+    where
+  toFun := torusAction u
+  invFun := torusAction u⁻¹
+  left_inv x := by rw [torusAction_mul]; simp
+  right_inv x := by rw [torusAction_mul]; simp
+  continuous_toFun := (torusAction_holomorphic u).continuous
+  continuous_invFun := (torusAction_holomorphic u⁻¹).continuous
+
+private theorem ToricSpace.time_factors (s : ToricFan.Triangle) (u : ActingTorus) :
+    ToricFan.Triangle.time (factors s u) = u 2 := by
+  have he := congrFun (ToricCharts.monomial_mul_on_torus s.rays s.dual (fun j => (u j).ne_zero)) 2
+  simpa only [factors, ToricFan.Triangle.rays_dual, ToricCharts.monomial_one,
+    ToricFan.Triangle.monomial_rays_height] using he
+
+private theorem ToricSpace.time_scale (s : ToricFan.Triangle) (u : ActingTorus)
+    (z : ToricCharts.CoordinateSpace 3) :
+    ToricFan.Triangle.time (scale s u z) = (u 2 : ℂ) * ToricFan.Triangle.time z := by
+  rw [← time_factors s u]
+  simp [ToricFan.Triangle.time, scale]
+  ring
+
+private theorem ToricSpace.time_torusAction (u : ActingTorus) (x : Space) :
+    time (torusAction u x) = (u 2 : ℂ) * time x := by
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  simp [time_scale]
+
+private def ToricSpace.fibreMultiplier (u : Fin 2 → ℂˣ) : ActingTorus :=
+  ![u 0, u 1, 1]
+
+@[simp]
+private theorem ToricSpace.time_fibreMultiplier (u : Fin 2 → ℂˣ) (x : Space) :
+    time (torusAction (fibreMultiplier u) x) = time x := by
+  simp [time_torusAction, fibreMultiplier]
+
+private theorem ToricSpace.shear_fibreMultiplier (v : Fin 2 → ℤ) (u : Fin 2 → ℂˣ) :
+    ToricCharts.monomial (ToricFan.Triangle.shear v) (fun j => (fibreMultiplier u j : ℂ)) =
+      (fun j => (fibreMultiplier u j : ℂ)) := by
+  ext i
+  fin_cases i <;>
+    simp [ToricCharts.monomial, ToricFan.Triangle.shear, fibreMultiplier, Fin.prod_univ_succ]
+
+private theorem ToricSpace.factors_shift_fibreMultiplier (s : ToricFan.Triangle) (v : Fin 2 → ℤ)
+    (u : Fin 2 → ℂˣ) : factors (s.shift v) (fibreMultiplier u) = factors s (fibreMultiplier u) := by
+  unfold factors
+  rw [ToricFan.Triangle.dual_shift, ←
+    ToricCharts.monomial_mul_on_torus s.dual (ToricFan.Triangle.shear (-v))
+      (fun j => (fibreMultiplier u j).ne_zero),
+    shear_fibreMultiplier]
+
+private theorem ToricSpace.fibreMultiplier_translate (v : Fin 2 → ℤ) (u : Fin 2 → ℂˣ) (x : Space) :
+    torusAction (fibreMultiplier u) (ToricSpace.translate v x) =
+      ToricSpace.translate v (torusAction (fibreMultiplier u) x) := by
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  simp [scale, factors_shift_fibreMultiplier]
+
+@[simp]
+private theorem ToricSpace.fibreMultiplier_one : fibreMultiplier 1 = 1 := by
+  ext i
+  fin_cases i <;> simp [fibreMultiplier]
+
+private theorem ToricSpace.fibreMultiplier_mul (u v : Fin 2 → ℂˣ) :
+    fibreMultiplier (u * v) = fibreMultiplier u * fibreMultiplier v := by
+  ext i
+  fin_cases i <;> simp [fibreMultiplier]
+
+private def ToricSpace.variableMultiplier (u : ℂ → Fin 2 → ℂˣ) (x : Space) : Space :=
+  torusAction (fibreMultiplier (u (time x))) x
+
+@[simp]
+private theorem ToricSpace.variableMultiplier_inclusion (u : ℂ → Fin 2 → ℂˣ) (s : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) :
+    variableMultiplier u (ToricSpace.inclusion s z) =
+      ToricSpace.inclusion s (scale s (fibreMultiplier (u (ToricFan.Triangle.time z))) z) := by
+  simp [variableMultiplier]
+
+@[simp]
+private theorem ToricSpace.time_variableMultiplier (u : ℂ → Fin 2 → ℂˣ) (x : Space) :
+    time (variableMultiplier u x) = time x := by simp [variableMultiplier]
+
+@[simp]
+private theorem
+    ToricSpace.variableMultiplier_one (x : Space) : variableMultiplier (fun _ => 1) x = x := by
+  simp [variableMultiplier]
+
+private theorem ToricSpace.variableMultiplier_mul (u v : ℂ → Fin 2 → ℂˣ) (x : Space) :
+    variableMultiplier u (variableMultiplier v x) = variableMultiplier (fun t => u t * v t) x := by
+  simp only [variableMultiplier, time_fibreMultiplier, torusAction_mul, fibreMultiplier_mul]
+
+private theorem
+    ToricSpace.variableMultiplier_translate (u : ℂ → Fin 2 → ℂˣ) (v : Fin 2 → ℤ) (x : Space) :
+    variableMultiplier u (ToricSpace.translate v x) =
+      ToricSpace.translate v (variableMultiplier u x) := by
+  simp [variableMultiplier, fibreMultiplier_translate]
+
+private theorem ToricSpace.varying_scale_holomorphic (s : ToricFan.Triangle) (u : ℂ → Fin 2 → ℂˣ)
+    {D : Set ℂ} (hu : ∀ j, ContDiffOn ℂ ω (fun t => (u t j : ℂ)) D) :
+    ContDiffOn ℂ ω (fun z => scale s (fibreMultiplier (u (ToricFan.Triangle.time z))) z)
+      (ToricFan.Triangle.time ⁻¹' D) := by
+  have hval :
+    ContDiffOn ℂ ω
+      (fun z : ToricCharts.CoordinateSpace 3 => fun j =>
+        (fibreMultiplier (u (ToricFan.Triangle.time z)) j : ℂ))
+      (ToricFan.Triangle.time ⁻¹' D) := by
+    apply contDiffOn_pi.mpr
+    intro j
+    fin_cases j
+    · exact (hu 0).comp ToricFan.Triangle.time_holomorphic.contDiffOn (fun _ hz => hz)
+    · exact (hu 1).comp ToricFan.Triangle.time_holomorphic.contDiffOn (fun _ hz => hz)
+    · exact contDiffOn_const
+  have hfactors :
+    ContDiffOn ℂ ω
+      (fun z : ToricCharts.CoordinateSpace 3 =>
+        factors s (fibreMultiplier (u (ToricFan.Triangle.time z))))
+      (ToricFan.Triangle.time ⁻¹' D) :=
+    (ToricCharts.monomial_contDiffOn s.dual ω).comp hval
+      (fun z _ =>
+        ToricCharts.torus_subset_domain _
+          (fun j => (fibreMultiplier (u (ToricFan.Triangle.time z)) j).ne_zero))
+  exact hfactors.mul contDiffOn_id
+
+private theorem
+    ToricSpace.variableMultiplier_holomorphic (u : ℂ → Fin 2 → ℂˣ) {D : Set ℂ} (hD : IsOpen D)
+    (hu : ∀ j, ContDiffOn ℂ ω (fun t => (u t j : ℂ)) D) :
+    ContMDiffOn (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (variableMultiplier u)
+      (time ⁻¹' D) := by
+  apply contMDiffOn_of_comp_inclusion _ _ (hD.preimage time_holomorphic.continuous)
+  intro s
+  have he :
+    (variableMultiplier u ∘ ToricSpace.inclusion s) =
+      (ToricSpace.inclusion s ∘ fun z =>
+        scale s (fibreMultiplier (u (ToricFan.Triangle.time z))) z) := by
+    funext z
+    exact variableMultiplier_inclusion u s z
+  rw [he]
+  have hpre : ToricSpace.inclusion s ⁻¹' (time ⁻¹' D) = ToricFan.Triangle.time ⁻¹' D := by
+    ext z
+    simp
+  rw [hpre]
+  exact (inclusion_holomorphic s).comp_contMDiffOn (varying_scale_holomorphic s u hu).contMDiffOn
+
+private def ToricSpace.cuspVector (v : Fin 2 → ℤ) : Fin 2 → ℤ :=
+  ![v 1, -v 0]
+
+@[simp]
+private theorem ToricSpace.cuspVector_zero : cuspVector 0 = 0 := by ext i; fin_cases i <;> rfl
+
+private theorem ToricSpace.cuspVector_add (v w : Fin 2 → ℤ) :
+    cuspVector (v + w) = cuspVector v + cuspVector w := by
+  ext i
+  fin_cases i <;> simp [cuspVector, add_comm]
+
+/-- The multiplicative torus factor obtained by exponentiating a period matrix. -/
+public
+def ToricSpace.exponentialMultiplier (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ) (t : ℂ) :
+    Fin 2 → ℂˣ := fun j =>
+  Units.mk0 (Complex.exp (2 * Real.pi * Complex.I * ((C t) *ᵥ (fun i => (v i : ℂ))) j))
+    (Complex.exp_ne_zero _)
+
+@[simp]
+private theorem ToricSpace.exponentialMultiplier_zero (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (t : ℂ) :
+    exponentialMultiplier C 0 t = 1 := by
+  ext j
+  simp [exponentialMultiplier, Matrix.mulVec, dotProduct]
+
+private theorem
+    ToricSpace.exponentialMultiplier_add (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (v w : Fin 2 → ℤ)
+    (t : ℂ) :
+    exponentialMultiplier C (v + w) t =
+      exponentialMultiplier C v t * exponentialMultiplier C w t := by
+  have he : (fun i => ((v + w) i : ℂ)) = (fun i => (v i : ℂ)) + (fun i => (w i : ℂ)) := by
+    ext i
+    simp
+  ext j
+  change
+    Complex.exp (2 * Real.pi * Complex.I * ((C t) *ᵥ (fun i => ((v + w) i : ℂ))) j) =
+      Complex.exp (2 * Real.pi * Complex.I * ((C t) *ᵥ (fun i => (v i : ℂ))) j) *
+        Complex.exp (2 * Real.pi * Complex.I * ((C t) *ᵥ (fun i => (w i : ℂ))) j)
+  rw [he, Matrix.mulVec_add]
+  simp only [Pi.add_apply, mul_add, Complex.exp_add]
+
+private theorem ToricSpace.exponentialMultiplier_holomorphic (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) {D : Set ℂ} (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) D) (j : Fin 2) :
+    ContDiffOn ℂ ω (fun t => (exponentialMultiplier C v t j : ℂ)) D := by
+  apply ContDiffOn.cexp
+  apply contDiffOn_const.mul
+  change ContDiffOn ℂ ω (fun t => ∑ i, C t j i * (v i : ℂ)) D
+  apply ContDiffOn.sum
+  intro i _
+  exact (hC j i).mul contDiffOn_const
+
+private def
+    ToricSpace.twistedTranslate (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ) (x : Space) :
+    Space :=
+  variableMultiplier (exponentialMultiplier C v) (ToricSpace.translate (cuspVector v) x)
+
+@[simp]
+private theorem ToricSpace.time_twistedTranslate (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ)
+    (x : Space) : time (twistedTranslate C v x) = time x := by simp [twistedTranslate]
+
+@[simp]
+private theorem ToricSpace.twistedTranslate_zero (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (x : Space) :
+    twistedTranslate C 0 x = x := by
+  have he : exponentialMultiplier C 0 = (fun _ => 1) := funext (exponentialMultiplier_zero C)
+  simp [twistedTranslate, he]
+
+private theorem ToricSpace.twistedTranslate_add (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (v w : Fin 2 → ℤ)
+    (x : Space) : twistedTranslate C v (twistedTranslate C w x) = twistedTranslate C (v + w) x := by
+  simp only [twistedTranslate]
+  rw [← variableMultiplier_translate, ToricSpace.translate_add, variableMultiplier_mul]
+  have he :
+    (fun t => exponentialMultiplier C v t * exponentialMultiplier C w t) =
+      exponentialMultiplier C (v + w) :=
+    funext fun t => (exponentialMultiplier_add C v w t).symm
+  rw [he, cuspVector_add]
+
+private theorem
+    ToricSpace.twistedTranslate_holomorphic (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ)
+    {D : Set ℂ} (hD : IsOpen D) (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) D) :
+    ContMDiffOn (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (twistedTranslate C v)
+      (time ⁻¹' D) := by
+  exact
+    (variableMultiplier_holomorphic _ hD (exponentialMultiplier_holomorphic C v hC)).comp
+      (translate_holomorphic (cuspVector v)).contMDiffOn (fun x hx => by simpa using hx)
+
+private def ToricSpace.tubeOpen (D : TopologicalSpace.Opens ℂ) : TopologicalSpace.Opens Space :=
+  ⟨time ⁻¹' (D : Set ℂ), D.isOpen.preimage time_holomorphic.continuous⟩
+
+private abbrev ToricSpace.Tube (D : TopologicalSpace.Opens ℂ) :=
+  tubeOpen D
+
+private def
+    ToricSpace.tubeTranslate (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (D : TopologicalSpace.Opens ℂ)
+    (v : Fin 2 → ℤ) (x : Tube D) : Tube D :=
+  ⟨twistedTranslate C v x, by
+    change time (twistedTranslate C v x) ∈ D
+    rw [time_twistedTranslate]
+    exact x.2⟩
+
+@[instance_reducible]
+private def
+    ToricSpace.tubeAction (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (D : TopologicalSpace.Opens ℂ) :
+    MulAction (Multiplicative (Fin 2 → ℤ)) (Tube D)
+    where
+  smul v x := tubeTranslate C D v.toAdd x
+  one_smul x := Subtype.ext (twistedTranslate_zero C x)
+  mul_smul v w x := Subtype.ext (twistedTranslate_add C v.toAdd w.toAdd x).symm
+
+private theorem ToricSpace.tubeTranslate_holomorphic (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (D : TopologicalSpace.Opens ℂ) (v : Fin 2 → ℤ)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (D : Set ℂ)) :
+    ContMDiff (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (tubeTranslate C D v) := by
+  intro x
+  have he :
+    ContMDiffAt (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+        (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω
+        (fun y : Tube D => (tubeTranslate C D v y : Space)) x ↔
+      ContMDiffAt (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+        (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (tubeTranslate C D v) x :=
+    ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+  apply he.mp
+  change
+    ContMDiffAt (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω
+      (fun y : Tube D => twistedTranslate C v (y : Space)) x
+  apply (contMDiffAt_subtype_iff (U := tubeOpen D) (f := twistedTranslate C v)).mpr
+  exact
+    (twistedTranslate_holomorphic C v D.isOpen hC).contMDiffAt ((tubeOpen D).isOpen.mem_nhds x.2)
+
+private def ToricSpace.torusCoordinates (x : Space) : ToricCharts.CoordinateSpace 3 :=
+  ToricCharts.monomial (preferredTriangle x).rays ((parametrization (preferredTriangle x)).symm x)
+
+private theorem ToricSpace.torusCoordinates_inclusion (s : ToricFan.Triangle)
+    {z : ToricCharts.CoordinateSpace 3} (hz : z ∈ ToricCharts.torus) :
+    torusCoordinates (ToricSpace.inclusion s z) = ToricCharts.monomial s.rays z := by
+  have he :=
+    parametrization_transition s (preferredTriangle (ToricSpace.inclusion s z))
+      (preferred_mem (ToricSpace.inclusion s z))
+  unfold torusCoordinates
+  rw [he.2]
+  change
+    ToricCharts.monomial (preferredTriangle (ToricSpace.inclusion s z)).rays
+        (ToricCharts.monomial
+          (ToricFan.Triangle.transition s (preferredTriangle (ToricSpace.inclusion s z))) z) =
+      _
+  rw [ToricCharts.monomial_mul_on_torus _ _ hz, ToricFan.Triangle.transition_covariance]
+
+@[simp]
+private theorem ToricSpace.torusCoordinates_time (x : Space) : torusCoordinates x 2 = time x :=
+  ToricFan.Triangle.monomial_rays_height _ _
+
+private theorem ToricSpace.torusCoordinates_nonzero {x : Space} (hx : x ∈ openTorus) (i : Fin 3) :
+    torusCoordinates x i ≠ 0 := by
+  obtain ⟨z, hz, rfl⟩ := hx
+  rw [torusCoordinates_inclusion _ hz]
+  exact ToricCharts.monomial_mapsTo_torus _ hz i
+
+private theorem ToricSpace.inclusion_preimage_openTorus (s : ToricFan.Triangle) :
+    ToricSpace.inclusion s ⁻¹' openTorus = ToricCharts.torus := by
+  ext z
+  simp [mem_openTorus_iff, ToricFan.Triangle.time, ToricCharts.torus, Fin.forall_fin_succ,
+    and_assoc]
+
+private theorem ToricSpace.torusCoordinates_holomorphic :
+    ContMDiffOn (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω torusCoordinates openTorus := by
+  apply contMDiffOn_of_comp_inclusion _ _ openTorus_isOpen
+  intro s
+  rw [inclusion_preimage_openTorus]
+  exact
+    ((ToricCharts.monomial_contDiffOn s.rays ω).mono
+          (ToricCharts.torus_subset_domain _)).contMDiffOn.congr
+      (fun z hz => torusCoordinates_inclusion s hz)
+
+private theorem
+    ToricSpace.torusCoordinates_translate (v : Fin 2 → ℤ) {x : Space} (hx : x ∈ openTorus) :
+    torusCoordinates (ToricSpace.translate v x) =
+      ToricCharts.monomial (ToricFan.Triangle.shear v) (torusCoordinates x) := by
+  obtain ⟨z, hz, rfl⟩ := hx
+  rw [translate_inclusion, torusCoordinates_inclusion _ hz, torusCoordinates_inclusion _ hz,
+    ToricFan.Triangle.rays_shift]
+  exact (ToricCharts.monomial_mul_on_torus _ _ hz).symm
+
+private theorem ToricSpace.monomial_rays_factors (s : ToricFan.Triangle) (u : ActingTorus) :
+    ToricCharts.monomial s.rays (factors s u) = (fun j => (u j : ℂ)) := by
+  rw [factors, ToricCharts.monomial_mul_on_torus _ _ (fun j => (u j).ne_zero),
+    ToricFan.Triangle.rays_dual, ToricCharts.monomial_one]
+
+private theorem
+    ToricSpace.torusCoordinates_action (u : ActingTorus) {x : Space} (hx : x ∈ openTorus) :
+    torusCoordinates (torusAction u x) = (fun j => (u j : ℂ)) * torusCoordinates x := by
+  obtain ⟨z, hz, rfl⟩ := hx
+  have hs : scale referenceTriangle u z ∈ ToricCharts.torus := fun j =>
+    mul_ne_zero (factors_nonzero _ _ j) (hz j)
+  rw [torusAction_inclusion, torusCoordinates_inclusion _ hs, torusCoordinates_inclusion _ hz]
+  rw [scale, ToricCharts.monomial_mul, monomial_rays_factors]
+
+private theorem ToricSpace.torusCoordinates_variableMultiplier (u : ℂ → Fin 2 → ℂˣ) {x : Space}
+    (hx : x ∈ openTorus) :
+    torusCoordinates (variableMultiplier u x) =
+      (fun j => (fibreMultiplier (u (time x)) j : ℂ)) * torusCoordinates x :=
+  torusCoordinates_action _ hx
+
+private theorem ToricSpace.torusCoordinates_twistedTranslate (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) {x : Space} (hx : x ∈ openTorus) :
+    torusCoordinates (twistedTranslate C v x) =
+      (fun j => (fibreMultiplier (exponentialMultiplier C v (time x)) j : ℂ)) *
+        ToricCharts.monomial (ToricFan.Triangle.shear (cuspVector v)) (torusCoordinates x) := by
+  have ht : ToricSpace.translate (cuspVector v) x ∈ openTorus := by
+    simpa only [mem_openTorus_iff, time_translate] using hx
+  rw [twistedTranslate, torusCoordinates_variableMultiplier _ ht, time_translate,
+    torusCoordinates_translate _ hx]
+
+private theorem
+    ToricSpace.torusCoordinates_twistedTranslate_apply (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) {x : Space} (hx : x ∈ openTorus) (i : Fin 2) :
+    torusCoordinates (twistedTranslate C v x) i.castSucc =
+      (exponentialMultiplier C v (time x) i : ℂ) * (time x) ^ cuspVector v i *
+        torusCoordinates x i.castSucc := by
+  rw [torusCoordinates_twistedTranslate C v hx]
+  fin_cases i <;>
+    simp [ToricCharts.monomial, ToricFan.Triangle.shear, fibreMultiplier, Fin.prod_univ_succ,
+      mul_comm, mul_left_comm, mul_assoc]
+
+private def
+    ToricSpace.logNorm (z : ToricCharts.CoordinateSpace 3) : Fin 3 → ℝ := fun i => Real.log ‖z i‖
+
+private theorem ToricSpace.logNorm_monomial (A : Matrix (Fin 3) (Fin 3) ℤ)
+    {z : ToricCharts.CoordinateSpace 3} (hz : z ∈ ToricCharts.torus) :
+    logNorm (ToricCharts.monomial A z) = A.map (Int.castRingHom ℝ) *ᵥ logNorm z := by
+  ext i
+  change Real.log ‖∏ j, z j ^ A i j‖ = ∑ j, (A i j : ℝ) * Real.log ‖z j‖
+  rw [norm_prod, Real.log_prod (fun j _ => norm_ne_zero_iff.mpr (zpow_ne_zero _ (hz j)))]
+  simp [norm_zpow, Real.log_zpow]
+
+private def ToricSpace.logCoordinates (x : Space) : Fin 3 → ℝ :=
+  logNorm (torusCoordinates x)
+
+private theorem ToricSpace.logCoordinates_inclusion (s : ToricFan.Triangle)
+    {z : ToricCharts.CoordinateSpace 3} (hz : z ∈ ToricCharts.torus) :
+    logCoordinates (ToricSpace.inclusion s z) = s.rays.map (Int.castRingHom ℝ) *ᵥ logNorm z := by
+  rw [logCoordinates, torusCoordinates_inclusion s hz, logNorm_monomial _ hz]
+
+@[simp]
+private theorem
+    ToricSpace.logCoordinates_time (x : Space) : logCoordinates x 2 = Real.log ‖time x‖ := by
+  simp [logCoordinates, logNorm]
+
+private theorem ToricSpace.logNorm_sum (s : ToricFan.Triangle) {z : ToricCharts.CoordinateSpace 3}
+    (hz : z ∈ ToricCharts.torus) : ∑ j, logNorm z j = Real.log ‖ToricFan.Triangle.time z‖ := by
+  have he := congrFun (logCoordinates_inclusion s hz) 2
+  simpa [Matrix.mulVec, dotProduct, logCoordinates_time] using he.symm
+
+/-- The real drift matrix determined by imaginary parts of the period correction. -/
+public
+def ToricSpace.driftMatrix (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (t : ℂ) :
+    Matrix (Fin 2) (Fin 2) ℝ := fun i j => -2 * Real.pi * (C t i j).im
+
+private theorem ToricSpace.exponentialMultiplier_log_norm (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) (t : ℂ) (i : Fin 2) :
+    Real.log ‖(exponentialMultiplier C v t i : ℂ)‖ =
+      (driftMatrix C t *ᵥ (fun j => (v j : ℝ))) i := by
+  simp [exponentialMultiplier, Complex.norm_exp, driftMatrix, Matrix.mulVec, dotProduct,
+    Fin.sum_univ_two, Complex.mul_re, Complex.mul_im]
+  ring
+
+private theorem ToricSpace.logCoordinates_twistedTranslate (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) {x : Space} (hx : x ∈ openTorus) (i : Fin 2) :
+    logCoordinates (twistedTranslate C v x) i.castSucc =
+      logCoordinates x i.castSucc + Real.log ‖time x‖ * (cuspVector v i : ℝ) +
+        (driftMatrix C (time x) *ᵥ (fun j => (v j : ℝ))) i := by
+  have ht : time x ≠ 0 := (mem_openTorus_iff x).mp hx
+  have hu : ‖(exponentialMultiplier C v (time x) i : ℂ)‖ ≠ 0 :=
+    norm_ne_zero_iff.mpr (exponentialMultiplier C v (time x) i).ne_zero
+  have hp : ‖(time x) ^ cuspVector v i‖ ≠ 0 := norm_ne_zero_iff.mpr (zpow_ne_zero _ ht)
+  have hz : ‖torusCoordinates x i.castSucc‖ ≠ 0 :=
+    norm_ne_zero_iff.mpr (torusCoordinates_nonzero hx _)
+  simp only [logCoordinates, logNorm, torusCoordinates_twistedTranslate_apply C v hx, norm_mul]
+  rw [Real.log_mul (mul_ne_zero hu hp) hz, Real.log_mul hu hp, exponentialMultiplier_log_norm,
+    norm_zpow, Real.log_zpow]
+  ring
+
+private def ToricSpace.position (x : Space) : Fin 2 → ℝ := fun i =>
+  logCoordinates x i.castSucc / Real.log ‖time x‖
+
+private theorem
+    ToricSpace.position_twistedTranslate (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ)
+    {x : Space} (hx : x ∈ openTorus) (ht : Real.log ‖time x‖ ≠ 0) (i : Fin 2) :
+    position (twistedTranslate C v x) i =
+      position x i + (cuspVector v i : ℝ) +
+        (driftMatrix C (time x) *ᵥ (fun j => (v j : ℝ))) i / Real.log ‖time x‖ := by
+  simp only [position, time_twistedTranslate, logCoordinates_twistedTranslate C v hx]
+  field_simp
+
+private def ToricSpace.latticeReal (v : Fin 2 → ℤ) : Fin 2 → ℝ := fun i => (v i : ℝ)
+
+private theorem ToricSpace.norm_latticeReal (v : Fin 2 → ℤ) : ‖latticeReal v‖ = ‖v‖ := by
+  apply le_antisymm
+  · apply (pi_norm_le_iff_of_nonneg (norm_nonneg _)).mpr
+    intro i
+    exact (Int.norm_cast_real (v i)).le.trans (norm_le_pi_norm v i)
+  · apply (pi_norm_le_iff_of_nonneg (norm_nonneg _)).mpr
+    intro i
+    rw [← Int.norm_cast_real (v i)]
+    exact norm_le_pi_norm (latticeReal v) i
+
+private theorem ToricSpace.lattice_bounded_finite (R : ℝ) :
+    {v : Fin 2 → ℤ | ‖latticeReal v‖ ≤ R}.Finite := by
+  have he : {v : Fin 2 → ℤ | ‖latticeReal v‖ ≤ R} = Metric.closedBall 0 R := by
+    ext v
+    simp [norm_latticeReal, Metric.mem_closedBall, dist_zero_right]
+  rw [he]
+  exact (ProperSpace.isCompact_closedBall _ _).finite_of_discrete
+
+/-- The sup norm of the entries of a real two-by-two matrix. -/
+public
+def ToricSpace.entryNorm (A : Matrix (Fin 2) (Fin 2) ℝ) : ℝ :=
+  ‖fun i : Fin 2 => fun j : Fin 2 => A i j‖
+
+private theorem ToricSpace.entryNorm_nonneg (A : Matrix (Fin 2) (Fin 2) ℝ) : 0 ≤ entryNorm A :=
+  norm_nonneg _
+
+private theorem ToricSpace.norm_cuspVector (v : Fin 2 → ℤ) :
+    ‖latticeReal (cuspVector v)‖ = ‖latticeReal v‖ := by
+  apply le_antisymm
+  · apply (pi_norm_le_iff_of_nonneg (norm_nonneg _)).mpr
+    intro i
+    fin_cases i
+    · exact norm_le_pi_norm (latticeReal v) 1
+    · simpa [latticeReal, cuspVector] using norm_le_pi_norm (latticeReal v) 0
+  · apply (pi_norm_le_iff_of_nonneg (norm_nonneg _)).mpr
+    intro i
+    fin_cases i
+    · simpa [latticeReal, cuspVector] using norm_le_pi_norm (latticeReal (cuspVector v)) 1
+    · exact norm_le_pi_norm (latticeReal (cuspVector v)) 0
+
+private theorem ToricSpace.norm_matrix_mulVec_le (A : Matrix (Fin 2) (Fin 2) ℝ) (v : Fin 2 → ℝ) :
+    ‖A *ᵥ v‖ ≤ 2 * entryNorm A * ‖v‖ := by
+  have hA := entryNorm_nonneg A
+  apply (pi_norm_le_iff_of_nonneg (by positivity)).mpr
+  intro i
+  calc
+    ‖(A *ᵥ v) i‖ ≤ ∑ j, ‖A i j * v j‖ := by
+      change ‖∑ j, A i j * v j‖ ≤ _
+      exact norm_sum_le _ _
+    _ ≤ ∑ _j : Fin 2, entryNorm A * ‖v‖ := by
+      apply Finset.sum_le_sum
+      intro j _
+      rw [norm_mul]
+      exact
+        mul_le_mul
+          ((norm_le_pi_norm (A i) j).trans
+            (norm_le_pi_norm (fun k : Fin 2 => fun l : Fin 2 => A k l) i))
+          (norm_le_pi_norm v j) (norm_nonneg _) (norm_nonneg _)
+    _ = 2 * entryNorm A * ‖v‖ := by simp; ring
+
+private theorem ToricSpace.position_displacement (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ)
+    {x : Space} (hx : x ∈ openTorus) (ht : Real.log ‖time x‖ ≠ 0) :
+    position (twistedTranslate C v x) - position x =
+      latticeReal (cuspVector v) +
+        (Real.log ‖time x‖)⁻¹ • (driftMatrix C (time x) *ᵥ latticeReal v) := by
+  ext i
+  simp only [Pi.sub_apply, Pi.add_apply, Pi.smul_apply, smul_eq_mul]
+  rw [position_twistedTranslate C v hx ht]
+  simp only [latticeReal, div_eq_mul_inv, Matrix.mulVec, dotProduct]
+  ring
+
+private theorem
+    ToricSpace.lattice_bound_of_small_drift (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ)
+    {x : Space} (hx : x ∈ openTorus) (ht : Real.log ‖time x‖ < 0)
+    (hR : entryNorm (driftMatrix C (time x)) ≤ -Real.log ‖time x‖ / 4) :
+    ‖latticeReal v‖ ≤ 2 * ‖position (twistedTranslate C v x) - position x‖ := by
+  let e := (Real.log ‖time x‖)⁻¹ • (driftMatrix C (time x) *ᵥ latticeReal v)
+  have hneg : 0 < -Real.log ‖time x‖ := neg_pos.mpr ht
+  have he : ‖e‖ ≤ ‖latticeReal v‖ / 2 := by
+    calc
+      ‖e‖ = (-Real.log ‖time x‖)⁻¹ * ‖driftMatrix C (time x) *ᵥ latticeReal v‖ := by
+        simp only [e, norm_smul, Real.norm_eq_abs, abs_inv, abs_of_neg ht]
+      _ ≤ (-Real.log ‖time x‖)⁻¹ * (2 * entryNorm (driftMatrix C (time x)) * ‖latticeReal v‖) :=
+        (mul_le_mul_of_nonneg_left (norm_matrix_mulVec_le _ _) (by positivity))
+      _ ≤ (-Real.log ‖time x‖)⁻¹ * (2 * (-Real.log ‖time x‖ / 4) * ‖latticeReal v‖) := by gcongr
+      _ = ‖latticeReal v‖ / 2 := by field_simp [ht.ne]; ring
+  have htriangle := norm_add_le (latticeReal (cuspVector v) + e) (-e)
+  have hnorm :
+    ‖latticeReal (cuspVector v) + e‖ = ‖position (twistedTranslate C v x) - position x‖ := by
+    rw [position_displacement C v hx ht.ne]
+  simp only [add_neg_cancel_right, norm_neg, norm_cuspVector] at htriangle
+  rw [hnorm] at htriangle
+  linarith
+
+private def ToricSpace.barycentric (z : ToricCharts.CoordinateSpace 3) : Fin 3 → ℝ := fun j =>
+  logNorm z j / Real.log ‖ToricFan.Triangle.time z‖
+
+private theorem
+    ToricSpace.barycentric_sum (s : ToricFan.Triangle) {z : ToricCharts.CoordinateSpace 3}
+    (hz : z ∈ ToricCharts.torus) (ht : Real.log ‖ToricFan.Triangle.time z‖ ≠ 0) :
+    ∑ j, barycentric z j = 1 := by
+  simp only [barycentric, ← Finset.sum_div, logNorm_sum s hz, div_self ht]
+
+private theorem
+    ToricSpace.position_inclusion (s : ToricFan.Triangle) {z : ToricCharts.CoordinateSpace 3}
+    (hz : z ∈ ToricCharts.torus) (i : Fin 2) :
+    position (ToricSpace.inclusion s z) i = ∑ j, (s.rays i.castSucc j : ℝ) * barycentric z j := by
+  simp only [position, time_inclusion, logCoordinates_inclusion s hz, Matrix.mulVec, dotProduct,
+    barycentric, Finset.sum_div, mul_div_assoc]
+  rfl
+
+private def ToricSpace.chartSize (s : ToricFan.Triangle) : ℝ :=
+  ‖(s.a : ℝ)‖ + ‖(s.b : ℝ)‖ + 1
+
+private theorem ToricSpace.chartSize_pos (s : ToricFan.Triangle) : 0 < chartSize s := by
+  unfold chartSize
+  positivity
+
+private theorem ToricSpace.ray_norm_le_chartSize (s : ToricFan.Triangle) (i : Fin 2) (j : Fin 3) :
+    ‖(s.rays i.castSucc j : ℝ)‖ ≤ chartSize s := by
+  have ha : ‖(s.a : ℝ)‖ ≤ chartSize s := by unfold chartSize; linarith [norm_nonneg (s.b : ℝ)]
+  have hb : ‖(s.b : ℝ)‖ ≤ chartSize s := by unfold chartSize; linarith [norm_nonneg (s.a : ℝ)]
+  have ha' : ‖(s.a : ℝ) + 1‖ ≤ chartSize s := (norm_add_le _ _).trans (by simp [chartSize])
+  have hb' : ‖(s.b : ℝ) + 1‖ ≤ chartSize s := (norm_add_le _ _).trans (by simp [chartSize])
+  cases hs : s.upper <;> fin_cases i <;> fin_cases j <;>
+    first
+    | simpa [ToricFan.Triangle.rays, hs] using ha
+    | simpa [ToricFan.Triangle.rays, hs] using hb
+    | simpa [ToricFan.Triangle.rays, hs] using ha'
+    | simpa [ToricFan.Triangle.rays, hs] using hb'
+
+private theorem ToricSpace.barycentric_lower_bound {z : ToricCharts.CoordinateSpace 3}
+    (hz : z ∈ ToricCharts.torus) {S ε : ℝ} (hS : 1 ≤ S) (hε : 0 < ε) (hε1 : ε < 1)
+    (ht : ‖ToricFan.Triangle.time z‖ < ε) (hzS : ∀ j, ‖z j‖ ≤ S) (j : Fin 3) :
+    -(Real.log S / (-Real.log ε)) ≤ barycentric z j := by
+  have hn : ToricFan.Triangle.time z ≠ 0 := mul_ne_zero (mul_ne_zero (hz 0) (hz 1)) (hz 2)
+  have hlogε : Real.log ε < 0 := Real.log_neg hε hε1
+  have hlogt : Real.log ‖ToricFan.Triangle.time z‖ < Real.log ε :=
+    Real.log_lt_log (norm_pos_iff.mpr hn) ht
+  have hη : 0 ≤ Real.log S / (-Real.log ε) :=
+    div_nonneg (Real.log_nonneg hS) (neg_nonneg.mpr hlogε.le)
+  have hlogz : Real.log ‖z j‖ ≤ Real.log S := Real.log_le_log (norm_pos_iff.mpr (hz j)) (hzS j)
+  have hmul := mul_le_mul_of_nonpos_left hlogt.le (neg_nonpos.mpr hη)
+  have he : -(Real.log S / (-Real.log ε)) * Real.log ε = Real.log S := by field_simp [hlogε.ne]
+  rw [he] at hmul
+  exact (le_div_iff_of_neg (hlogt.trans hlogε)).mpr (hlogz.trans hmul)
+
+private theorem ToricSpace.barycentric_norm_bound {z : ToricCharts.CoordinateSpace 3}
+    (hz : z ∈ ToricCharts.torus) {S ε : ℝ} (hS : 1 ≤ S) (hε : 0 < ε) (hε1 : ε < 1)
+    (ht : ‖ToricFan.Triangle.time z‖ < ε) (hzS : ∀ j, ‖z j‖ ≤ S) (j : Fin 3) :
+    ‖barycentric z j‖ ≤ 1 + 2 * (Real.log S / (-Real.log ε)) := by
+  let η := Real.log S / (-Real.log ε)
+  have hη : 0 ≤ η := div_nonneg (Real.log_nonneg hS) (neg_nonneg.mpr (Real.log_neg hε hε1).le)
+  have hlow (k : Fin 3) : -η ≤ barycentric z k := barycentric_lower_bound hz hS hε hε1 ht hzS k
+  have hn : ToricFan.Triangle.time z ≠ 0 := mul_ne_zero (mul_ne_zero (hz 0) (hz 1)) (hz 2)
+  have hs :=
+    barycentric_sum referenceTriangle hz (Real.log_neg (norm_pos_iff.mpr hn) (ht.trans hε1)).ne
+  have hsum : ∑ k : Fin 3, (barycentric z k + η) = 1 + 3 * η := by
+    rw [Finset.sum_add_distrib, hs]
+    simp
+  have hu :=
+    Finset.single_le_sum (s := Finset.univ) (f := fun k : Fin 3 => barycentric z k + η)
+      (fun k _ => by linarith [hlow k]) (Finset.mem_univ j)
+  rw [hsum] at hu
+  change ‖barycentric z j‖ ≤ 1 + 2 * η
+  rw [Real.norm_eq_abs, abs_le]
+  constructor <;> linarith [hlow j]
+
+private def ToricSpace.positionBound (s : ToricFan.Triangle) (S ε : ℝ) : ℝ :=
+  3 * chartSize s * (1 + 2 * (Real.log S / (-Real.log ε)))
+
+private theorem
+    ToricSpace.position_norm_bound (s : ToricFan.Triangle) {z : ToricCharts.CoordinateSpace 3}
+    (hz : z ∈ ToricCharts.torus) {S ε : ℝ} (hS : 1 ≤ S) (hε : 0 < ε) (hε1 : ε < 1)
+    (ht : ‖ToricFan.Triangle.time z‖ < ε) (hzS : ∀ j, ‖z j‖ ≤ S) :
+    ‖position (ToricSpace.inclusion s z)‖ ≤ positionBound s S ε := by
+  have hη : 0 ≤ Real.log S / (-Real.log ε) :=
+    div_nonneg (Real.log_nonneg hS) (neg_nonneg.mpr (Real.log_neg hε hε1).le)
+  have hsize := chartSize_pos s
+  apply (pi_norm_le_iff_of_nonneg (by unfold positionBound; positivity)).mpr
+  intro i
+  rw [position_inclusion s hz]
+  calc
+    ‖∑ j, (s.rays i.castSucc j : ℝ) * barycentric z j‖ ≤
+        ∑ j, ‖(s.rays i.castSucc j : ℝ) * barycentric z j‖ :=
+      norm_sum_le _ _
+    _ ≤ ∑ _j : Fin 3, chartSize s * (1 + 2 * (Real.log S / (-Real.log ε))) := by
+      apply Finset.sum_le_sum
+      intro j _
+      rw [norm_mul]
+      exact
+        mul_le_mul (ray_norm_le_chartSize s i j) (barycentric_norm_bound hz hS hε hε1 ht hzS j)
+          (norm_nonneg _) (chartSize_pos s).le
+    _ = positionBound s S ε := by simp [positionBound]; ring
+
+/-- The logarithmic bound required of a period correction near the cusp. -/
+public
+def ToricSpace.SmallDrift (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) : Prop :=
+  ∀ t : ℂ, 0 < ‖t‖ → ‖t‖ < ε → entryNorm (driftMatrix C t) ≤ -Real.log ‖t‖ / 4
+
+private def ToricSpace.chartNeighbourhood (s : ToricFan.Triangle) (n : ℕ) (ε : ℝ) : Set Space :=
+  ToricSpace.inclusion s ''
+    {z : ToricCharts.CoordinateSpace 3 |
+      (∀ j, ‖z j‖ < (n : ℝ) + 2) ∧ ‖ToricFan.Triangle.time z‖ < ε}
+
+private theorem ToricSpace.chartNeighbourhood_open (s : ToricFan.Triangle) (n : ℕ) (ε : ℝ) :
+    IsOpen (chartNeighbourhood s n ε) := by
+  apply (inclusion_openEmbedding s).isOpenMap
+  have hc : IsOpen {z : ToricCharts.CoordinateSpace 3 | ∀ j, ‖z j‖ < (n : ℝ) + 2} := by
+    simp only [Set.ofPred_forall]
+    exact isOpen_iInter_of_finite fun j => isOpen_lt (continuous_apply j).norm continuous_const
+  exact hc.inter (isOpen_lt ToricFan.Triangle.time_holomorphic.continuous.norm continuous_const)
+
+private theorem
+    ToricSpace.chartNeighbourhood_time {s : ToricFan.Triangle} {n : ℕ} {ε : ℝ} {x : Space}
+    (hx : x ∈ chartNeighbourhood s n ε) : ‖time x‖ < ε := by
+  obtain ⟨z, hz, rfl⟩ := hx
+  simpa only [time_inclusion] using hz.2
+
+private theorem ToricSpace.chartNeighbourhood_cover {ε : ℝ} {x : Space} (hx : ‖time x‖ < ε) :
+    ∃ s n, x ∈ chartNeighbourhood s n ε := by
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  obtain ⟨n, hn⟩ := exists_nat_gt ‖z‖
+  refine ⟨s, n, z, ⟨?_, by simpa using hx⟩, rfl⟩
+  intro j
+  have h := norm_le_pi_norm z j
+  linarith
+
+private def ToricSpace.chartTranslates (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (s t : ToricFan.Triangle) (n m : ℕ) : Set (Fin 2 → ℤ) :=
+  {v | (chartNeighbourhood s n ε ∩ twistedTranslate C v ⁻¹' chartNeighbourhood t m ε).Nonempty}
+
+private theorem
+    ToricSpace.chartTranslates_finite (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε : ℝ} (hε : 0 < ε)
+    (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : SmallDrift C ε) (s t : ToricFan.Triangle) (n m : ℕ) :
+    (chartTranslates C ε s t n m).Finite := by
+  apply
+    (lattice_bounded_finite
+        (2 * (positionBound s ((n : ℝ) + 2) ε + positionBound t ((m : ℝ) + 2) ε))).subset
+  intro v hv
+  have hcont : ContinuousOn (twistedTranslate C v) (chartNeighbourhood s n ε) :=
+    (twistedTranslate_holomorphic C v Metric.isOpen_ball hC).continuousOn.mono
+      (by
+        intro x hx
+        simpa only [Set.mem_preimage, Metric.mem_ball, dist_zero_right] using
+          chartNeighbourhood_time hx)
+  have hV :=
+    hcont.isOpen_inter_preimage (chartNeighbourhood_open s n ε) (chartNeighbourhood_open t m ε)
+  obtain ⟨p, hpT, hpV⟩ := openTorus_dense.exists_mem_open hV hv
+  obtain ⟨z, hz, rfl⟩ := hpV.1
+  have hzT : z ∈ ToricCharts.torus := by
+    rw [← inclusion_preimage_openTorus s]
+    exact hpT
+  obtain ⟨w, hw, hew⟩ := hpV.2
+  have hwT : w ∈ ToricCharts.torus := by
+    rw [← inclusion_preimage_openTorus t]
+    change ToricSpace.inclusion t w ∈ openTorus
+    rw [hew, mem_openTorus_iff, time_twistedTranslate]
+    exact (mem_openTorus_iff _).mp hpT
+  have ht : 0 < ‖time (ToricSpace.inclusion s z)‖ :=
+    norm_pos_iff.mpr ((mem_openTorus_iff _).mp hpT)
+  have htime : ‖time (ToricSpace.inclusion s z)‖ < ε := by simpa only [time_inclusion] using hz.2
+  have hvbound :=
+    lattice_bound_of_small_drift C v hpT (Real.log_neg ht (htime.trans hε1)) (hR _ ht htime)
+  have hpbound :=
+    position_norm_bound s hzT
+      (by have hn : 0 ≤ (n : ℝ) := Nat.cast_nonneg n; linarith : (1 : ℝ) ≤ n + 2) hε hε1 hz.2
+      (fun j => (hz.1 j).le)
+  have hqbound :=
+    position_norm_bound t hwT
+      (by have hm : 0 ≤ (m : ℝ) := Nat.cast_nonneg m; linarith : (1 : ℝ) ≤ m + 2) hε hε1 hw.2
+      (fun j => (hw.1 j).le)
+  rw [hew] at hqbound
+  have hd :=
+    norm_sub_le (position (twistedTranslate C v (ToricSpace.inclusion s z)))
+      (position (ToricSpace.inclusion s z))
+  change ‖latticeReal v‖ ≤ _
+  linarith
+
+private theorem ToricSpace.compact_translates_finite (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {ε : ℝ}
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : SmallDrift C ε) {K : Set Space} (hK : IsCompact K) (hKt : ∀ x ∈ K, ‖time x‖ < ε) :
+    {v : Fin 2 → ℤ | (twistedTranslate C v '' K ∩ K).Nonempty}.Finite := by
+  let U : ToricFan.Triangle × ℕ → Set Space := fun i => chartNeighbourhood i.1 i.2 ε
+  have hcover : K ⊆ ⋃ i, U i := by
+    intro x hx
+    obtain ⟨s, n, hn⟩ := chartNeighbourhood_cover (hKt x hx)
+    exact Set.mem_iUnion.mpr ⟨(s, n), hn⟩
+  obtain ⟨I, hI⟩ := hK.elim_finite_subcover U (fun i => chartNeighbourhood_open _ _ _) hcover
+  have hfinite : (⋃ i ∈ I, ⋃ j ∈ I, chartTranslates C ε i.1 j.1 i.2 j.2).Finite :=
+    I.finite_toSet.biUnion fun i _ =>
+      I.finite_toSet.biUnion fun j _ => chartTranslates_finite C hε hε1 hC hR i.1 j.1 i.2 j.2
+  apply hfinite.subset
+  rintro v ⟨q, ⟨p, hp, hpq⟩, hq⟩
+  obtain ⟨i, hi, hpi⟩ := Set.mem_iUnion₂.mp (hI hp)
+  obtain ⟨j, hj, hqj⟩ := Set.mem_iUnion₂.mp (hI hq)
+  apply Set.mem_iUnion₂.mpr ⟨i, hi, ?_⟩
+  apply Set.mem_iUnion₂.mpr ⟨j, hj, ?_⟩
+  exact ⟨p, hpi, by simpa only [Set.mem_preimage, hpq] using hqj⟩
+
+private theorem ToricSpace.SmallDrift.mono {C : ℂ → Matrix (Fin 2) (Fin 2) ℂ} {ε δ : ℝ}
+    (h : ToricSpace.SmallDrift C ε) (hδε : δ ≤ ε) : ToricSpace.SmallDrift C δ := fun t ht hδ =>
+  h t ht (hδ.trans_le hδε)
+
+private theorem ToricSpace.exists_smallDrift_radius (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (hC : ∀ i j, ContinuousAt (fun t => C t i j) 0) : ∃ ε : ℝ, 0 < ε ∧ ε < 1 ∧ SmallDrift C ε := by
+  have hentries :
+    ContinuousAt (fun t : ℂ => fun i : Fin 2 => fun j : Fin 2 => driftMatrix C t i j) 0 := by
+    apply continuousAt_pi.mpr
+    intro i
+    apply continuousAt_pi.mpr
+    intro j
+    exact continuousAt_const.mul (Complex.continuous_im.continuousAt.comp (hC i j))
+  have hnorm : ContinuousAt (fun t => entryNorm (driftMatrix C t)) 0 := hentries.norm
+  let M := entryNorm (driftMatrix C 0) + 1
+  have hM : entryNorm (driftMatrix C 0) < M := by dsimp [M]; linarith
+  have hevent : ∀ᶠ t in 𝓝 (0 : ℂ), entryNorm (driftMatrix C t) < M := hnorm (gt_mem_nhds hM)
+  obtain ⟨δ, hδ, hδbound⟩ := Metric.eventually_nhds_iff.mp hevent
+  let ε := Min.min δ (Min.min (1 / 2) (Real.exp (-4 * M)))
+  have hε : 0 < ε := lt_min hδ (lt_min (by norm_num) (Real.exp_pos _))
+  refine ⟨ε, hε, lt_of_le_of_lt ((min_le_right _ _).trans (min_le_left _ _)) (by norm_num), ?_⟩
+  intro t ht htε
+  have htδ : Dist.dist t 0 < δ := by
+    simpa only [dist_zero_right] using htε.trans_le (min_le_left _ _)
+  have hbound := hδbound htδ
+  have hlog : Real.log ‖t‖ ≤ -4 * M := by
+    have hsmall : ‖t‖ ≤ Real.exp (-4 * M) :=
+      htε.le.trans ((min_le_right _ _).trans (min_le_right _ _))
+    simpa only [Real.log_exp] using Real.log_le_log ht hsmall
+  linarith
+
+private abbrev CuspQuotient.LatticeGroup :=
+  Multiplicative (Fin 2 → ℤ)
+
+private def CuspQuotient.disc (ε : ℝ) : TopologicalSpace.Opens ℂ :=
+  ⟨Metric.ball 0 ε, Metric.isOpen_ball⟩
+
+private instance CuspQuotient.tube_locallyCompactSpace (ε : ℝ) :
+    LocallyCompactSpace (ToricSpace.Tube (disc ε)) :=
+  ChartedSpace.locallyCompactSpace (ToricCharts.CoordinateSpace 3) (ToricSpace.Tube (disc ε))
+
+private theorem CuspQuotient.continuous_action (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε)) :
+    letI := ToricSpace.tubeAction C (disc ε)
+    ContinuousConstSMul LatticeGroup (ToricSpace.Tube (disc ε)) := by
+  let := ToricSpace.tubeAction C (disc ε)
+  exact ⟨fun v => (ToricSpace.tubeTranslate_holomorphic C (disc ε) v.toAdd hC).continuous⟩
+
+private theorem CuspQuotient.proper_action (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    letI := ToricSpace.tubeAction C (disc ε)
+    ProperlyDiscontinuousSMul LatticeGroup (ToricSpace.Tube (disc ε)) := by
+  let := ToricSpace.tubeAction C (disc ε)
+  constructor
+  intro K L hK hL
+  let K' : Set ToricSpace.Space := Subtype.val '' (K ∪ L)
+  have hK' : IsCompact K' := (hK.union hL).image continuous_subtype_val
+  have hKt : ∀ x ∈ K', ‖ToricSpace.time x‖ < ε := by
+    rintro _ ⟨x, _, rfl⟩
+    have hx : ToricSpace.time (x : ToricSpace.Space) ∈ Metric.ball 0 ε := x.2
+    simpa only [Metric.mem_ball, dist_zero_right] using hx
+  have hfinite := ToricSpace.compact_translates_finite C hε hε1 hC hR hK' hKt
+  have hinj : Function.Injective (fun g : LatticeGroup => g.toAdd) := fun _ _ h =>
+    congrArg Multiplicative.ofAdd h
+  apply (hfinite.preimage hinj.injOn).subset
+  rintro g ⟨q, ⟨p, hp, hpq⟩, hq⟩
+  refine
+    ⟨(q : ToricSpace.Space), ⟨(p : ToricSpace.Space), ⟨p, Or.inl hp, rfl⟩, ?_⟩,
+      ⟨q, Or.inr hq, rfl⟩⟩
+  exact congrArg Subtype.val hpq
+
+private theorem CuspQuotient.free_action (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    letI := ToricSpace.tubeAction C (disc ε)
+    IsCancelSMul LatticeGroup (ToricSpace.Tube (disc ε)) := by
+  let := ToricSpace.tubeAction C (disc ε)
+  let := proper_action C ε hε hε1 hC hR
+  apply isCancelSMul_iff_eq_one_of_smul_eq.mpr
+  intro g x hg
+  let H := MulAction.stabilizer LatticeGroup x
+  let : Finite H := ProperlyDiscontinuousSMul.finite_stabilizer x
+  obtain ⟨n, hn, hpow⟩ := (isOfFinOrder_of_finite (⟨g, hg⟩ : H)).exists_pow_eq_one
+  have he : g ^ n = 1 := congrArg Subtype.val hpow
+  exact (isOfFinOrder_iff_pow_eq_one.mpr ⟨n, hn, he⟩).eq_one'
+
+private def CuspQuotient.relation (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    Setoid (ToricSpace.Tube (disc ε)) :=
+  letI := ToricSpace.tubeAction C (disc ε)
+  MulAction.orbitRel LatticeGroup (ToricSpace.Tube (disc ε))
+
+private abbrev CuspQuotient.QuotientSpace (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :=
+  Quotient (relation C ε)
+
+private def CuspQuotient.quotientMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    ToricSpace.Tube (disc ε) → QuotientSpace C ε :=
+  Quotient.mk (relation C ε)
+
+private theorem CuspQuotient.quotientMap_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    Continuous (quotientMap C ε) :=
+  continuous_quotient_mk'
+
+@[simp]
+private theorem CuspQuotient.quotientMap_translate (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (v : Fin 2 → ℤ) (x : ToricSpace.Tube (disc ε)) :
+    quotientMap C ε (ToricSpace.tubeTranslate C (disc ε) v x) = quotientMap C ε x := by
+  let := ToricSpace.tubeAction C (disc ε)
+  exact MulAction.orbitRel.Quotient.quotient_smul_eq (g := Multiplicative.ofAdd v) (a := x)
+
+private def
+    CuspQuotient.projection (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) : QuotientSpace C ε → ℂ :=
+  Quotient.lift (fun x : ToricSpace.Tube (disc ε) => ToricSpace.time (x : ToricSpace.Space))
+    (by
+      let := ToricSpace.tubeAction C (disc ε)
+      intro x y h
+      change x ∈ MulAction.orbit LatticeGroup y at h
+      obtain ⟨g, rfl⟩ := h
+      exact ToricSpace.time_twistedTranslate C g.toAdd y)
+
+@[simp]
+private theorem CuspQuotient.projection_quotientMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (x : ToricSpace.Tube (disc ε)) :
+    projection C ε (quotientMap C ε x) = ToricSpace.time (x : ToricSpace.Space) :=
+  rfl
+
+private theorem CuspQuotient.projection_mem_disc (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (x : QuotientSpace C ε) : projection C ε x ∈ disc ε := by
+  induction x using Quotient.inductionOn with
+  | h x => exact x.2
+
+private def
+    CuspQuotient.baseMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (x : QuotientSpace C ε) :
+    disc ε :=
+  ⟨projection C ε x, projection_mem_disc C ε x⟩
+
+private theorem CuspQuotient.projection_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    Continuous (projection C ε) :=
+  (ToricSpace.time_holomorphic.continuous.comp continuous_subtype_val).quotient_lift _
+
+private theorem CuspQuotient.baseMap_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    Continuous (baseMap C ε) :=
+  (projection_continuous C ε).subtype_mk _
+
+private theorem
+    CuspQuotient.quotientMap_covering (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    letI := ToricSpace.tubeAction C (disc ε)
+    IsQuotientCoveringMap (quotientMap C ε) LatticeGroup := by
+  let := ToricSpace.tubeAction C (disc ε)
+  let := continuous_action C ε hC
+  let := proper_action C ε hε hε1 hC hR
+  let := free_action C ε hε hε1 hC hR
+  exact isQuotientCoveringMap_quotientMk_of_properlyDiscontinuousSMul
+
+private theorem
+    CuspQuotient.quotient_t2Space (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : T2Space (QuotientSpace C ε) := by
+  let := ToricSpace.tubeAction C (disc ε)
+  let := continuous_action C ε hC
+  let := proper_action C ε hε hε1 hC hR
+  change T2Space (Quotient (MulAction.orbitRel LatticeGroup (ToricSpace.Tube (disc ε))))
+  infer_instance
+
+@[instance_reducible]
+private def CuspQuotient.chartedSpace (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    ChartedSpace (ToricCharts.CoordinateSpace 3) (QuotientSpace C ε) :=
+  letI := ToricSpace.tubeAction C (disc ε)
+  CoveringQuotient.chartedSpace (E := ToricCharts.CoordinateSpace 3)
+    (quotientMap_covering C ε hε hε1 hC hR)
+
+private theorem CuspQuotient.isManifold (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    letI := chartedSpace C ε hε hε1 hC hR
+    IsManifold (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (QuotientSpace C ε) := by
+  let := ToricSpace.tubeAction C (disc ε)
+  exact
+    CoveringQuotient.isManifold (E := ToricCharts.CoordinateSpace 3)
+      (quotientMap_covering C ε hε hε1 hC hR) ω
+      (fun v => ToricSpace.tubeTranslate_holomorphic C (disc ε) v.toAdd hC)
+
+private theorem CuspQuotient.quotientMap_holomorphic (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    letI := chartedSpace C ε hε hε1 hC hR
+    ContMDiff (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (quotientMap C ε) := by
+  let := ToricSpace.tubeAction C (disc ε)
+  exact
+    CoveringQuotient.contMDiff_project (E := ToricCharts.CoordinateSpace 3)
+      (quotientMap_covering C ε hε hε1 hC hR) ω
+      (fun v => ToricSpace.tubeTranslate_holomorphic C (disc ε) v.toAdd hC)
+
+private theorem CuspQuotient.exists_admissible_radius (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {r : ℝ}
+    (hr : 0 < r) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 r)) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ε < r ∧
+          ε < 1 ∧
+            ToricSpace.SmallDrift C ε ∧
+              ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε) := by
+  have hC0 : ∀ i j, ContinuousAt (fun z => C z i j) 0 := by
+    intro i j
+    exact (hC i j).continuousOn.continuousAt (Metric.isOpen_ball.mem_nhds (by simpa using hr))
+  obtain ⟨δ, hδ, hδ1, hR⟩ := ToricSpace.exists_smallDrift_radius C hC0
+  refine
+    ⟨Min.min δ (r / 2), lt_min hδ (half_pos hr), (min_le_right _ _).trans_lt (half_lt_self hr),
+      (min_le_left _ _).trans_lt hδ1, hR.mono (min_le_left _ _), ?_⟩
+  intro i j
+  exact (hC i j).mono (Metric.ball_subset_ball ((min_le_right _ _).trans (half_le_self hr.le)))
+
+private abbrev ToricFan.Triangle.RealPlane₄ :=
+  Fin 3 → ℝ
+
+private def ToricFan.Triangle.coordinates (s : ToricFan.Triangle) :
+    RealPlane₄ →ₗ[ℝ] RealPlane₄ :=
+  (s.dual.map (Int.castRingHom ℝ)).mulVecLin
+
+private def
+    ToricFan.Triangle.generate (s : ToricFan.Triangle) : RealPlane₄ →ₗ[ℝ] RealPlane₄ :=
+  (s.rays.map (Int.castRingHom ℝ)).mulVecLin
+
+private theorem ToricFan.Triangle.coordinates_lower (a b : ℤ) (x : RealPlane₄) :
+    coordinates ⟨a, b, Bool.false⟩ x =
+      ![(1 + (a : ℝ) + b) * x 2 - x 0 - x 1, x 0 - a * x 2, x 1 - b * x 2] := by
+  ext i
+  fin_cases i <;> simp [coordinates, dual, Matrix.mulVec, dotProduct, Fin.sum_univ_succ] <;> ring
+
+private theorem ToricFan.Triangle.coordinates_upper (a b : ℤ) (x : RealPlane₄) :
+    coordinates ⟨a, b, Bool.true⟩ x =
+      ![((b : ℝ) + 1) * x 2 - x 1, ((a : ℝ) + 1) * x 2 - x 0,
+        x 0 + x 1 - (1 + (a : ℝ) + b) * x 2] := by
+  ext i
+  fin_cases i <;> simp [coordinates, dual, Matrix.mulVec, dotProduct, Fin.sum_univ_succ] <;> ring
+
+private theorem
+    ToricFan.Triangle.coordinates_generate (s : ToricFan.Triangle) (x : RealPlane₄) :
+    s.coordinates (s.generate x) = x := by
+  change (s.dual.map (Int.castRingHom ℝ)) *ᵥ ((s.rays.map (Int.castRingHom ℝ)) *ᵥ x) = x
+  rw [Matrix.mulVec_mulVec, ← Matrix.map_mul, dual_rays]
+  simp
+
+private def ToricFan.Triangle.cone (s : ToricFan.Triangle) : ConvexCone ℝ RealPlane₄
+    where
+  carrier := {x | ∀ i, 0 ≤ s.coordinates x i}
+  smul_mem' := by
+    intro c hc x hx i
+    simpa using mul_nonneg hc.le (hx i)
+  add_mem' := by
+    intro x hx y hy i
+    simpa using add_nonneg (hx i) (hy i)
+
+@[simp]
+private theorem ToricFan.Triangle.mem_cone (s : ToricFan.Triangle) (x : RealPlane₄) :
+    x ∈ s.cone ↔ ∀ i, 0 ≤ s.coordinates x i :=
+  Iff.rfl
+
+private def ToricSpace.realCuspVector : (Fin 2 → ℝ) →ₗ[ℝ] (Fin 2 → ℝ)
+    where
+  toFun v := ![v 1, -v 0]
+  map_add' v w := by ext i; fin_cases i <;> simp [add_comm]
+  map_smul' a v := by ext i; fin_cases i <;> simp
+
+private theorem ToricSpace.realCuspVector_latticeReal (v : Fin 2 → ℤ) :
+    realCuspVector (latticeReal v) = latticeReal (cuspVector v) := by
+  ext i
+  fin_cases i <;> simp [realCuspVector, latticeReal, cuspVector]
+
+private theorem ToricSpace.realCuspVector_norm (v : Fin 2 → ℝ) : ‖realCuspVector v‖ = ‖v‖ := by
+  apply le_antisymm
+  · apply (pi_norm_le_iff_of_nonneg (norm_nonneg _)).mpr
+    intro i
+    fin_cases i
+    · exact norm_le_pi_norm v 1
+    · simpa [realCuspVector] using norm_le_pi_norm v 0
+  · apply (pi_norm_le_iff_of_nonneg (norm_nonneg _)).mpr
+    intro i
+    fin_cases i
+    · simpa [realCuspVector] using norm_le_pi_norm (realCuspVector v) 1
+    · exact norm_le_pi_norm (realCuspVector v) 0
+
+private def ToricSpace.displacement (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (t : ℂ) :
+    (Fin 2 → ℝ) →ₗ[ℝ] (Fin 2 → ℝ) :=
+  realCuspVector + (Real.log ‖t‖)⁻¹ • (driftMatrix C t).mulVecLin
+
+private theorem ToricSpace.displacement_error_bound (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {t : ℂ}
+    (ht : Real.log ‖t‖ < 0) (hR : entryNorm (driftMatrix C t) ≤ -Real.log ‖t‖ / 4)
+    (v : Fin 2 → ℝ) : ‖displacement C t v - realCuspVector v‖ ≤ ‖v‖ / 2 := by
+  have hneg : 0 < -Real.log ‖t‖ := neg_pos.mpr ht
+  have he : displacement C t v - realCuspVector v = (Real.log ‖t‖)⁻¹ • (driftMatrix C t *ᵥ v) := by
+    simp [displacement]
+  rw [he]
+  calc
+    ‖(Real.log ‖t‖)⁻¹ • (driftMatrix C t *ᵥ v)‖ = (-Real.log ‖t‖)⁻¹ * ‖driftMatrix C t *ᵥ v‖ := by
+      simp only [norm_smul, Real.norm_eq_abs, abs_inv, abs_of_neg ht]
+    _ ≤ (-Real.log ‖t‖)⁻¹ * (2 * entryNorm (driftMatrix C t) * ‖v‖) :=
+      (mul_le_mul_of_nonneg_left (norm_matrix_mulVec_le _ _) (by positivity))
+    _ ≤ (-Real.log ‖t‖)⁻¹ * (2 * (-Real.log ‖t‖ / 4) * ‖v‖) := by gcongr
+    _ = ‖v‖ / 2 := by field_simp [ht.ne]; ring
+
+private theorem ToricSpace.displacement_lower_bound (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {t : ℂ}
+    (ht : Real.log ‖t‖ < 0) (hR : entryNorm (driftMatrix C t) ≤ -Real.log ‖t‖ / 4)
+    (v : Fin 2 → ℝ) : ‖v‖ ≤ 2 * ‖displacement C t v‖ := by
+  have he := displacement_error_bound C ht hR v
+  have htri := norm_sub_le (displacement C t v) (displacement C t v - realCuspVector v)
+  rw [sub_sub_cancel, realCuspVector_norm] at htri
+  linarith
+
+private theorem ToricSpace.displacement_upper_bound (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {t : ℂ}
+    (ht : Real.log ‖t‖ < 0) (hR : entryNorm (driftMatrix C t) ≤ -Real.log ‖t‖ / 4)
+    (v : Fin 2 → ℝ) : ‖displacement C t v‖ ≤ 3 / 2 * ‖v‖ := by
+  have he := displacement_error_bound C ht hR v
+  have htri := norm_add_le (realCuspVector v) (displacement C t v - realCuspVector v)
+  rw [add_sub_cancel, realCuspVector_norm] at htri
+  linarith
+
+private theorem ToricSpace.displacement_bijective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {t : ℂ}
+    (ht : Real.log ‖t‖ < 0) (hR : entryNorm (driftMatrix C t) ≤ -Real.log ‖t‖ / 4) :
+    Function.Bijective (displacement C t) := by
+  have hinj : Function.Injective (displacement C t) := by
+    apply (LinearMap.ker_eq_bot).mp
+    apply LinearMap.ker_eq_bot'.mpr
+    intro v hv
+    have hb := displacement_lower_bound C ht hR v
+    rw [hv, norm_zero, MulZeroClass.mul_zero] at hb
+    exact norm_eq_zero.mp (le_antisymm hb (norm_nonneg _))
+  exact ⟨hinj, LinearMap.surjective_of_injective hinj⟩
+
+private theorem ToricSpace.exists_integer_rounding (u : Fin 2 → ℝ) :
+    ∃ v : Fin 2 → ℤ, ‖u + latticeReal v‖ ≤ 1 := by
+  refine ⟨fun i => -⌊u i⌋, ?_⟩
+  apply (pi_norm_le_iff_of_nonneg (by norm_num : (0 : ℝ) ≤ 1)).mpr
+  intro i
+  simp only [Pi.add_apply, latticeReal, Int.cast_neg, Real.norm_eq_abs]
+  rw [abs_le]
+  constructor <;> linarith [Int.floor_le (u i), Int.lt_floor_add_one (u i)]
+
+private theorem ToricSpace.position_twistedTranslate_displacement (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) {x : Space} (hx : x ∈ openTorus) (ht : Real.log ‖time x‖ ≠ 0) :
+    position (twistedTranslate C v x) = position x + displacement C (time x) (latticeReal v) := by
+  have he := position_displacement C v hx ht
+  rw [← realCuspVector_latticeReal] at he
+  change
+    position (twistedTranslate C v x) - position x = displacement C (time x) (latticeReal v) at he
+  exact (sub_eq_iff_eq_add.mp he).trans (add_comm _ _)
+
+private theorem ToricSpace.exists_bounded_translate (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {x : Space}
+    (hx : x ∈ openTorus) (ht : Real.log ‖time x‖ < 0)
+    (hR : entryNorm (driftMatrix C (time x)) ≤ -Real.log ‖time x‖ / 4) :
+    ∃ v : Fin 2 → ℤ, ‖position (twistedTranslate C v x)‖ ≤ 2 := by
+  obtain ⟨u, hu⟩ := (displacement_bijective C ht hR).surjective (position x)
+  obtain ⟨v, hv⟩ := exists_integer_rounding u
+  refine ⟨v, ?_⟩
+  rw [position_twistedTranslate_displacement C v hx ht.ne, ← hu, ← map_add]
+  exact (displacement_upper_bound C ht hR _).trans (by nlinarith)
+
+private theorem
+    ToricSpace.exists_torus_chart (s : ToricFan.Triangle) {x : Space} (hx : x ∈ openTorus) :
+    ∃ z ∈ ToricCharts.torus, ToricSpace.inclusion s z = x := by
+  obtain ⟨z, hz, rfl⟩ := hx
+  refine
+    ⟨ToricFan.Triangle.chartChange referenceTriangle s z, ToricCharts.monomial_mapsTo_torus _ hz,
+      ?_⟩
+  exact
+    ((inclusion_eq_iff referenceTriangle s z _).mpr
+        ⟨ToricCharts.torus_subset_overlap _ _ hz, rfl⟩).symm
+
+private def ToricSpace.positionPoint (y : Fin 2 → ℝ) : ToricFan.Triangle.RealPlane₄ :=
+  ![y 0, y 1, 1]
+
+private theorem ToricSpace.generate_barycentric (s : ToricFan.Triangle)
+    {z : ToricCharts.CoordinateSpace 3} (hz : z ∈ ToricCharts.torus)
+    (ht : Real.log ‖ToricFan.Triangle.time z‖ ≠ 0) :
+    s.generate (barycentric z) = positionPoint (position (ToricSpace.inclusion s z)) := by
+  ext i
+  fin_cases i
+  · exact (position_inclusion s hz 0).symm
+  · exact (position_inclusion s hz 1).symm
+  · simpa [ToricFan.Triangle.generate, Matrix.mulVec, dotProduct, positionPoint] using
+      barycentric_sum s hz ht
+
+private theorem ToricSpace.unit_chart_of_position_mem_cone (s : ToricFan.Triangle)
+    {z : ToricCharts.CoordinateSpace 3} (hz : z ∈ ToricCharts.torus)
+    (ht : Real.log ‖ToricFan.Triangle.time z‖ < 0)
+    (hp : positionPoint (position (ToricSpace.inclusion s z)) ∈ s.cone) : ‖z‖ ≤ 1 := by
+  rw [← generate_barycentric s hz ht.ne, ToricFan.Triangle.mem_cone,
+    ToricFan.Triangle.coordinates_generate] at hp
+  apply (pi_norm_le_iff_of_nonneg (by norm_num : (0 : ℝ) ≤ 1)).mpr
+  intro j
+  apply (Real.log_nonpos_iff (norm_nonneg _)).mp
+  have hj := (le_div_iff_of_neg ht).mp (hp j)
+  simpa [barycentric, logNorm] using hj
+
+private def ToricSpace.boundedTriangles : Set ToricFan.Triangle :=
+  {s | (-3 ≤ s.a ∧ s.a ≤ 3) ∧ (-3 ≤ s.b ∧ s.b ≤ 3)}
+
+private theorem ToricSpace.boundedTriangles_finite : boundedTriangles.Finite := by
+  have hf :=
+    (Set.finite_Icc (-3 : ℤ) 3).prod
+      ((Set.finite_Icc (-3 : ℤ) 3).prod (Set.finite_univ (α := Bool)))
+  have hi : Function.Injective (fun s : ToricFan.Triangle => (s.a, s.b, s.upper)) := by
+    intro s t h
+    simpa only [Prod.mk.injEq, ToricFan.Triangle.ext_iff, and_assoc] using h
+  apply (hf.preimage hi.injOn).subset
+  intro s hs
+  exact ⟨hs.1, hs.2, Set.mem_univ _⟩
+
+private theorem ToricSpace.exists_bounded_cone (y : Fin 2 → ℝ) (hy : ‖y‖ ≤ 2) :
+    ∃ s ∈ boundedTriangles, positionPoint y ∈ s.cone := by
+  let a := ⌊y 0⌋
+  let b := ⌊y 1⌋
+  have ha : (a : ℝ) ≤ y 0 := Int.floor_le _
+  have hb : (b : ℝ) ≤ y 1 := Int.floor_le _
+  have ha' : y 0 < (a : ℝ) + 1 := Int.lt_floor_add_one _
+  have hb' : y 1 < (b : ℝ) + 1 := Int.lt_floor_add_one _
+  have hy0 : -(2 : ℝ) ≤ y 0 ∧ y 0 ≤ 2 :=
+    abs_le.mp (by simpa only [Real.norm_eq_abs] using (norm_le_pi_norm y 0).trans hy)
+  have hy1 : -(2 : ℝ) ≤ y 1 ∧ y 1 ≤ 2 :=
+    abs_le.mp (by simpa only [Real.norm_eq_abs] using (norm_le_pi_norm y 1).trans hy)
+  have haI : (-3 : ℤ) ≤ a ∧ a ≤ 3 := by
+    constructor
+    · exact_mod_cast (show (-3 : ℝ) ≤ (a : ℝ) by linarith)
+    · exact_mod_cast (show (a : ℝ) ≤ 3 by linarith)
+  have hbI : (-3 : ℤ) ≤ b ∧ b ≤ 3 := by
+    constructor
+    · exact_mod_cast (show (-3 : ℝ) ≤ (b : ℝ) by linarith)
+    · exact_mod_cast (show (b : ℝ) ≤ 3 by linarith)
+  by_cases hsum : y 0 + y 1 ≤ 1 + (a : ℝ) + b
+  · refine ⟨⟨a, b, Bool.false⟩, ⟨haI, hbI⟩, ?_⟩
+    rw [ToricFan.Triangle.mem_cone, ToricFan.Triangle.coordinates_lower]
+    intro i
+    fin_cases i <;> dsimp [positionPoint] <;> linarith
+  · refine ⟨⟨a, b, Bool.true⟩, ⟨haI, hbI⟩, ?_⟩
+    rw [ToricFan.Triangle.mem_cone, ToricFan.Triangle.coordinates_upper]
+    intro i
+    fin_cases i <;> dsimp [positionPoint] <;> linarith
+
+private theorem ToricSpace.exists_unit_chart_of_bounded_position {x : Space} (hx : x ∈ openTorus)
+    (ht : Real.log ‖time x‖ < 0) (hp : ‖position x‖ ≤ 2) :
+    ∃ s ∈ boundedTriangles,
+      ∃ z ∈ Metric.closedBall (0 : ToricCharts.CoordinateSpace 3) 1,
+        ToricSpace.inclusion s z = x := by
+  obtain ⟨s, hs, hp⟩ := exists_bounded_cone (position x) hp
+  obtain ⟨z, hz, rfl⟩ := exists_torus_chart s hx
+  refine ⟨s, hs, z, ?_, rfl⟩
+  rw [Metric.mem_closedBall, dist_zero_right]
+  exact unit_chart_of_position_mem_cone s hz (by simpa using ht) hp
+
+private theorem
+    ToricSpace.exists_bounded_chart_translate (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {x : Space}
+    (hx : x ∈ openTorus) (ht : Real.log ‖time x‖ < 0)
+    (hR : entryNorm (driftMatrix C (time x)) ≤ -Real.log ‖time x‖ / 4) :
+    ∃ v : Fin 2 → ℤ,
+      ∃ s ∈ boundedTriangles,
+        ∃ z ∈ Metric.closedBall (0 : ToricCharts.CoordinateSpace 3) 1,
+          ToricSpace.inclusion s z = twistedTranslate C v x := by
+  obtain ⟨v, hv⟩ := exists_bounded_translate C hx ht hR
+  refine ⟨v, ?_⟩
+  apply exists_unit_chart_of_bounded_position _ (by simpa using ht) hv
+  simpa only [mem_openTorus_iff, time_twistedTranslate] using hx
+
+private def CuspQuotient.compactRepresentatives (η : ℝ) : Set ToricSpace.Space :=
+  ⋃ s ∈ ToricSpace.boundedTriangles,
+    ToricSpace.inclusion s ''
+      (Metric.closedBall (0 : ToricCharts.CoordinateSpace 3) 1 ∩
+        ToricFan.Triangle.time ⁻¹' Metric.closedBall 0 η)
+
+private theorem CuspQuotient.compactRepresentatives_compact (η : ℝ) :
+    IsCompact (compactRepresentatives η) := by
+  apply ToricSpace.boundedTriangles_finite.isCompact_biUnion
+  intro s _
+  exact
+    ((ProperSpace.isCompact_closedBall _ _).inter_right
+          (Metric.isClosed_closedBall.preimage
+            ToricFan.Triangle.time_holomorphic.continuous)).image
+      (ToricSpace.inclusion_openEmbedding s).continuous
+
+private theorem CuspQuotient.compactRepresentatives_time {η : ℝ} {x : ToricSpace.Space}
+    (hx : x ∈ compactRepresentatives η) : ‖ToricSpace.time x‖ ≤ η := by
+  obtain ⟨s, _, z, hz, rfl⟩ := Set.mem_iUnion₂.mp hx
+  simpa only [ToricSpace.time_inclusion, Set.mem_preimage, Metric.mem_closedBall,
+    dist_zero_right] using hz.2
+
+private def CuspQuotient.tubeRepresentatives (ε η : ℝ) : Set (ToricSpace.Tube (disc ε)) :=
+  Subtype.val ⁻¹' compactRepresentatives η
+
+private theorem CuspQuotient.tubeRepresentatives_compact {ε η : ℝ} (hηε : η < ε) :
+    IsCompact (tubeRepresentatives ε η) := by
+  apply
+    Topology.IsEmbedding.subtypeVal.isInducing.isCompact_preimage'
+      (compactRepresentatives_compact η)
+  intro x hx
+  have hxt : x ∈ ToricSpace.tubeOpen (disc ε) := by
+    change ToricSpace.time x ∈ Metric.ball 0 ε
+    simpa only [Metric.mem_ball, dist_zero_right] using
+      (compactRepresentatives_time hx).trans_lt hηε
+  exact ⟨⟨x, hxt⟩, rfl⟩
+
+private def
+    CuspQuotient.quotientRepresentatives (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (η : ℝ) :
+    Set (QuotientSpace C ε) :=
+  quotientMap C ε '' tubeRepresentatives ε η
+
+private theorem
+    CuspQuotient.quotientRepresentatives_compact (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    {η : ℝ} (hηε : η < ε) : IsCompact (quotientRepresentatives C ε η) :=
+  (tubeRepresentatives_compact hηε).image (quotientMap_continuous C ε)
+
+private theorem
+    CuspQuotient.torus_mem_quotientRepresentatives (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε1 : ε < 1) (hR : ToricSpace.SmallDrift C ε) {η : ℝ} {x : ToricSpace.Tube (disc ε)}
+    (hx : (x : ToricSpace.Space) ∈ ToricSpace.openTorus)
+    (hxη : ‖ToricSpace.time (x : ToricSpace.Space)‖ ≤ η) :
+    quotientMap C ε x ∈ quotientRepresentatives C ε η := by
+  have hxt : ‖ToricSpace.time (x : ToricSpace.Space)‖ < ε := by
+    have hxε : ToricSpace.time (x : ToricSpace.Space) ∈ Metric.ball 0 ε := x.2
+    simpa only [Metric.mem_ball, dist_zero_right] using hxε
+  have ht : 0 < ‖ToricSpace.time (x : ToricSpace.Space)‖ :=
+    norm_pos_iff.mpr ((ToricSpace.mem_openTorus_iff _).mp hx)
+  obtain ⟨v, s, hs, z, hz, he⟩ :=
+    ToricSpace.exists_bounded_chart_translate C hx (Real.log_neg ht (hxt.trans hε1)) (hR _ ht hxt)
+  refine ⟨ToricSpace.tubeTranslate C (disc ε) v x, ?_, quotientMap_translate C ε v x⟩
+  change ToricSpace.twistedTranslate C v (x : ToricSpace.Space) ∈ compactRepresentatives η
+  refine Set.mem_iUnion₂.mpr ⟨s, hs, z, ⟨hz, ?_⟩, he⟩
+  change ToricFan.Triangle.time z ∈ Metric.closedBall 0 η
+  rw [← ToricSpace.time_inclusion s z, he, ToricSpace.time_twistedTranslate,
+    Metric.mem_closedBall, dist_zero_right]
+  exact hxη
+
+private theorem CuspQuotient.tube_torus_dense (ε : ℝ) :
+    Dense
+      ((Subtype.val : ToricSpace.Tube (disc ε) → ToricSpace.Space) ⁻¹' ToricSpace.openTorus) :=
+  ToricSpace.openTorus_dense.preimage
+    (ToricSpace.tubeOpen (disc ε)).isOpen.isOpenEmbedding_subtypeVal.isOpenMap
+
+private theorem CuspQuotient.mem_quotientRepresentatives (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) {η : ℝ} (hη : 0 < η) (hηε : η < ε)
+    {x : ToricSpace.Tube (disc ε)} (hxη : ‖ToricSpace.time (x : ToricSpace.Space)‖ ≤ η) :
+    quotientMap C ε x ∈ quotientRepresentatives C ε η := by
+  let := quotient_t2Space C ε hε hε1 hC hR
+  by_cases hx : (x : ToricSpace.Space) ∈ ToricSpace.openTorus
+  · exact torus_mem_quotientRepresentatives C ε hε1 hR hx hxη
+  have hzero : ToricSpace.time (x : ToricSpace.Space) = 0 := by
+    simpa only [ToricSpace.mem_openTorus_iff, Classical.not_not] using hx
+  let A := quotientMap C ε ⁻¹' quotientRepresentatives C ε η
+  have hA : IsClosed A :=
+    (quotientRepresentatives_compact C ε hηε).isClosed.preimage (quotientMap_continuous C ε)
+  let U : Set (ToricSpace.Tube (disc ε)) := {p | ‖ToricSpace.time (p : ToricSpace.Space)‖ < η}
+  have hU : IsOpen U :=
+    isOpen_lt (ToricSpace.time_holomorphic.continuous.comp continuous_subtype_val).norm
+      continuous_const
+  by_contra hn
+  have hxU : x ∈ U := by simpa [U, hzero] using hη
+  obtain ⟨p, hp, hpU, hpA⟩ :=
+    (tube_torus_dense ε).exists_mem_open (hU.inter hA.isOpen_compl) ⟨x, hxU, hn⟩
+  exact hpA (torus_mem_quotientRepresentatives C ε hε1 hR hp hpU.le)
+
+private theorem CuspQuotient.closedDisc_preimage_compact (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) {η : ℝ} (hη : 0 < η) (hηε : η < ε) :
+    IsCompact (projection C ε ⁻¹' Metric.closedBall 0 η) := by
+  have he : projection C ε ⁻¹' Metric.closedBall 0 η = quotientRepresentatives C ε η := by
+    ext q
+    constructor
+    · induction q using Quotient.inductionOn with
+      | h x =>
+        intro hx
+        exact
+          mem_quotientRepresentatives C ε hε hε1 hC hR hη hηε
+            (by
+              simpa only [Set.mem_preimage, projection, Quotient.lift_mk, Metric.mem_closedBall,
+                dist_zero_right] using hx)
+    · rintro ⟨x, hx, rfl⟩
+      simpa only [Set.mem_preimage, projection_quotientMap, Metric.mem_closedBall,
+        dist_zero_right] using compactRepresentatives_time hx
+  rw [he]
+  exact quotientRepresentatives_compact C ε hηε
+
+private theorem CuspQuotient.baseMap_proper (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : IsProperMap (baseMap C ε) := by
+  apply isProperMap_iff_isCompact_preimage.mpr
+  refine ⟨baseMap_continuous C ε, ?_⟩
+  intro K hK
+  rcases K.eq_empty_or_nonempty with rfl | hne
+  · simp
+  obtain ⟨t, ht, hmax⟩ := hK.exists_isMaxOn hne continuous_subtype_val.norm.continuousOn
+  have htε : ‖(t : ℂ)‖ < ε := by
+    have htball : (t : ℂ) ∈ Metric.ball 0 ε := t.2
+    simpa only [Metric.mem_ball, dist_zero_right] using htball
+  obtain ⟨η, htη, hηε⟩ := exists_between htε
+  have hη : 0 < η := (norm_nonneg _).trans_lt htη
+  apply
+    (closedDisc_preimage_compact C ε hε hε1 hC hR hη hηε).of_isClosed_subset
+      (hK.isClosed.preimage (baseMap_continuous C ε))
+  intro q hq
+  have hb : ‖projection C ε q‖ ≤ ‖(t : ℂ)‖ := hmax hq
+  simpa only [Set.mem_preimage, Metric.mem_closedBall, dist_zero_right] using hb.trans htη.le
+
+private def CuspQuotient.affineTube (ε : ℝ) : Set (ToricCharts.CoordinateSpace 3) :=
+  {z | ‖ToricFan.Triangle.time z‖ < ε}
+
+private theorem CuspQuotient.affineTube_starConvex (ε : ℝ) : StarConvex ℝ 0 (affineTube ε) := by
+  intro z hz a b ha hb hab
+  have hb1 : b ≤ 1 := by linarith
+  simp only [smul_zero, zero_add]
+  change ‖ToricFan.Triangle.time (b • z)‖ < ε
+  have he : ‖ToricFan.Triangle.time (b • z)‖ = b ^ 3 * ‖ToricFan.Triangle.time z‖ := by
+    simp only [ToricFan.Triangle.time, Pi.smul_apply, norm_mul, norm_smul, Real.norm_eq_abs,
+      abs_of_nonneg hb]
+    ring
+  rw [he]
+  exact (mul_le_of_le_one_left (norm_nonneg _) (pow_le_one₀ hb hb1)).trans_lt hz
+
+private theorem
+    CuspQuotient.affineTube_connected {ε : ℝ} (hε : 0 < ε) : IsConnected (affineTube ε) :=
+  ((affineTube_starConvex ε).isPathConnected
+      (by simpa [affineTube, ToricFan.Triangle.time] using hε)).isConnected
+
+private theorem CuspQuotient.tube_eq_union (ε : ℝ) :
+    (ToricSpace.tubeOpen (disc ε) : Set ToricSpace.Space) =
+      ⋃ s : ToricFan.Triangle, ToricSpace.inclusion s '' affineTube ε := by
+  ext x
+  constructor
+  · intro hx
+    obtain ⟨s, z, rfl⟩ := ToricSpace.inclusion_jointly_surjective x
+    refine Set.mem_iUnion.mpr ⟨s, z, ?_, rfl⟩
+    have he : ToricSpace.time (ToricSpace.inclusion s z) ∈ Metric.ball 0 ε := hx
+    simpa only [affineTube, Set.mem_ofPred_eq, ToricSpace.time_inclusion, Metric.mem_ball,
+      dist_zero_right] using he
+  · intro hx
+    obtain ⟨s, z, hz, rfl⟩ := Set.mem_iUnion.mp hx
+    change ToricSpace.time (ToricSpace.inclusion s z) ∈ Metric.ball 0 ε
+    simpa only [affineTube, Set.mem_ofPred_eq, ToricSpace.time_inclusion, Metric.mem_ball,
+      dist_zero_right] using hz
+
+private theorem CuspQuotient.tube_charts_common_point {ε : ℝ} (hε : 0 < ε) :
+    (⋂ s : ToricFan.Triangle, ToricSpace.inclusion s '' affineTube ε).Nonempty := by
+  let x := ToricSpace.inclusion ToricSpace.referenceTriangle ![((ε / 2 : ℝ) : ℂ), 1, 1]
+  have hxT : x ∈ ToricSpace.openTorus := by
+    apply ToricSpace.inclusion_torus_subset ToricSpace.referenceTriangle
+    refine ⟨_, ?_, rfl⟩
+    intro i
+    fin_cases i
+    · change ((ε / 2 : ℝ) : ℂ) ≠ 0
+      exact_mod_cast (half_pos hε).ne'
+    · exact one_ne_zero
+    · exact one_ne_zero
+  have hxt : ‖ToricSpace.time x‖ < ε := by
+    simpa [x, ToricFan.Triangle.time, abs_of_pos hε] using half_lt_self hε
+  refine ⟨x, Set.mem_iInter.mpr fun s => ?_⟩
+  obtain ⟨z, _, he⟩ := ToricSpace.exists_torus_chart s hxT
+  refine ⟨z, ?_, he⟩
+  change ‖ToricFan.Triangle.time z‖ < ε
+  rw [← ToricSpace.time_inclusion s z, he]
+  exact hxt
+
+private theorem CuspQuotient.tube_connected {ε : ℝ} (hε : 0 < ε) :
+    ConnectedSpace (ToricSpace.Tube (disc ε)) := by
+  apply isConnected_iff_connectedSpace.mp
+  have hpre : IsPreconnected (⋃ s : ToricFan.Triangle, ToricSpace.inclusion s '' affineTube ε) :=
+    isPreconnected_iUnion (tube_charts_common_point hε)
+      (fun s =>
+        (affineTube_connected hε).isPreconnected.image _
+          (ToricSpace.inclusion_openEmbedding s).continuous.continuousOn)
+  rw [← tube_eq_union] at hpre
+  refine ⟨⟨ToricSpace.inclusion ToricSpace.referenceTriangle 0, ?_⟩, hpre⟩
+  change ToricSpace.time (ToricSpace.inclusion ToricSpace.referenceTriangle 0) ∈ Metric.ball 0 ε
+  simpa [ToricFan.Triangle.time] using hε
+
+private theorem
+    CuspQuotient.quotient_connected (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) :
+    ConnectedSpace (QuotientSpace C ε) := by
+  let := tube_connected hε
+  infer_instance
+
+private theorem CuspQuotient.quotient_secondCountable (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : SecondCountableTopology (QuotientSpace C ε) := by
+  let := ToricSpace.tubeAction C (disc ε)
+  have hq := quotientMap_covering C ε hε hε1 hC hR
+  exact hq.toIsQuotientMap.secondCountableTopology hq.isCoveringMap.isOpenMap
+
+private def CuspQuotient.centralAffine : Set (ToricCharts.CoordinateSpace 3) :=
+  {z | ToricFan.Triangle.time z = 0}
+
+private def CuspQuotient.centralOrigin : centralAffine :=
+  ⟨0, by simp [centralAffine, ToricFan.Triangle.time]⟩
+
+private theorem CuspQuotient.centralAffine_starConvex : StarConvex ℝ 0 centralAffine := by
+  intro z hz a b _ _ _
+  simp only [smul_zero, zero_add]
+  change ToricFan.Triangle.time (b • z) = 0
+  obtain h | h | h := (ToricFan.Triangle.central_fibre z).mp hz
+  all_goals simp [ToricFan.Triangle.time, Pi.smul_apply, h]
+
+private instance CuspQuotient.centralAffine_connected : ConnectedSpace centralAffine :=
+  isConnected_iff_connectedSpace.mp
+    ((centralAffine_starConvex.isPathConnected centralOrigin.2).isConnected)
+
+private def
+    CuspQuotient.centralLift (ε : ℝ) (hε : 0 < ε) (s : ToricFan.Triangle) (z : centralAffine) :
+    ToricSpace.Tube (disc ε) :=
+  ⟨ToricSpace.inclusion s z,
+    by
+    change ToricSpace.time (ToricSpace.inclusion s z) ∈ Metric.ball 0 ε
+    rw [ToricSpace.time_inclusion, z.2]
+    simpa using hε⟩
+
+private theorem CuspQuotient.centralLift_continuous (ε : ℝ) (hε : 0 < ε) (s : ToricFan.Triangle) :
+    Continuous (centralLift ε hε s) :=
+  ((ToricSpace.inclusion_openEmbedding s).continuous.comp continuous_subtype_val).subtype_mk _
+
+private def CuspQuotient.centralChartMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (s : ToricFan.Triangle) : centralAffine → QuotientSpace C ε :=
+  quotientMap C ε ∘ centralLift ε hε s
+
+private theorem CuspQuotient.centralChartMap_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (s : ToricFan.Triangle) : Continuous (centralChartMap C ε hε s) :=
+  (quotientMap_continuous C ε).comp (centralLift_continuous ε hε s)
+
+private theorem
+    CuspQuotient.centralChartMap_range_connected (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (s : ToricFan.Triangle) : IsConnected (Set.range (centralChartMap C ε hε s)) :=
+  isConnected_range (centralChartMap_continuous C ε hε s)
+
+@[simp]
+private theorem CuspQuotient.projection_centralChartMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (s : ToricFan.Triangle) (z : centralAffine) :
+    projection C ε (centralChartMap C ε hε s z) = 0 := by
+  change ToricSpace.time (ToricSpace.inclusion s z) = 0
+  rw [ToricSpace.time_inclusion, z.2]
+
+private theorem CuspQuotient.centralChartMap_origin_shift (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (s : ToricFan.Triangle) (v : Fin 2 → ℤ) :
+    centralChartMap C ε hε (s.shift (ToricSpace.cuspVector v)) centralOrigin =
+      centralChartMap C ε hε s centralOrigin := by
+  have he :
+    ToricSpace.tubeTranslate C (disc ε) v (centralLift ε hε s centralOrigin) =
+      centralLift ε hε (s.shift (ToricSpace.cuspVector v)) centralOrigin := by
+    apply Subtype.ext
+    simp [ToricSpace.tubeTranslate, centralLift, centralOrigin, ToricSpace.twistedTranslate,
+      ToricSpace.variableMultiplier, ToricSpace.translate_inclusion,
+      ToricSpace.torusAction_inclusion, ToricSpace.scale]
+  exact
+    (congrArg (quotientMap C ε) he).symm.trans
+      (quotientMap_translate C ε v (centralLift ε hε s centralOrigin))
+
+private theorem
+    CuspQuotient.centralChartMap_origin_reference (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (s : ToricFan.Triangle) :
+    centralChartMap C ε hε s centralOrigin =
+      centralChartMap C ε hε ⟨0, 0, s.upper⟩ centralOrigin := by
+  let v : Fin 2 → ℤ := ![-s.b, s.a]
+  have he : (⟨0, 0, s.upper⟩ : ToricFan.Triangle).shift (ToricSpace.cuspVector v) = s := by
+    ext <;> simp [ToricFan.Triangle.shift, ToricSpace.cuspVector, v]
+  simpa only [he] using centralChartMap_origin_shift C ε hε ⟨0, 0, s.upper⟩ v
+
+private theorem CuspQuotient.reference_central_overlap :
+    ToricSpace.inclusion (⟨0, 0, Bool.false⟩ : ToricFan.Triangle) ![1, 0, 0] =
+      ToricSpace.inclusion (⟨0, 0, Bool.true⟩ : ToricFan.Triangle) ![0, 0, 1] := by
+  have hA :
+    ToricFan.Triangle.transition ⟨0, 0, Bool.false⟩ ⟨0, 0, Bool.true⟩ =
+      !![1, 1, 0; 1, 0, 1; -1, 0, 0] := by decide
+  apply (ToricSpace.inclusion_eq_iff _ _ _ _).mpr
+  constructor
+  · rw [ToricFan.Triangle.chartChange_source]
+    intro i j hij
+    rw [hA] at hij
+    fin_cases i <;> fin_cases j <;> norm_num at hij
+    norm_num
+  · change ToricCharts.monomial (ToricFan.Triangle.transition _ _) _ = _
+    rw [hA]
+    ext i
+    fin_cases i <;> norm_num [ToricCharts.monomial, Fin.prod_univ_succ]
+
+private theorem
+    CuspQuotient.reference_centralChartMap_overlap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) :
+    (Set.range (centralChartMap C ε hε ⟨0, 0, Bool.false⟩) ∩
+        Set.range (centralChartMap C ε hε ⟨0, 0, Bool.true⟩)).Nonempty := by
+  let z : centralAffine := ⟨![1, 0, 0], by simp [centralAffine, ToricFan.Triangle.time]⟩
+  let w : centralAffine := ⟨![0, 0, 1], by simp [centralAffine, ToricFan.Triangle.time]⟩
+  refine ⟨centralChartMap C ε hε ⟨0, 0, Bool.false⟩ z, Set.mem_range_self z, w, ?_⟩
+  apply congrArg (quotientMap C ε)
+  exact Subtype.ext reference_central_overlap.symm
+
+private theorem CuspQuotient.central_fibre_eq_union (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) :
+    projection C ε ⁻¹' {0} = ⋃ s : ToricFan.Triangle, Set.range (centralChartMap C ε hε s) := by
+  ext q
+  constructor
+  · induction q using Quotient.inductionOn with
+    | h x =>
+      intro hx
+      have hx0 : ToricSpace.time (x : ToricSpace.Space) = 0 := hx
+      obtain ⟨s, z, he⟩ := ToricSpace.inclusion_jointly_surjective (x : ToricSpace.Space)
+      have hz : z ∈ centralAffine := by
+        change ToricFan.Triangle.time z = 0
+        rw [← ToricSpace.time_inclusion s z, he, hx0]
+      refine Set.mem_iUnion.mpr ⟨s, ⟨z, hz⟩, ?_⟩
+      apply congrArg (quotientMap C ε)
+      exact Subtype.ext he
+  · intro hq
+    obtain ⟨s, z, rfl⟩ := Set.mem_iUnion.mp hq
+    exact projection_centralChartMap C ε hε s z
+
+private theorem CuspQuotient.central_fibre_connected (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) : IsConnected (projection C ε ⁻¹' {0}) := by
+  let U := fun s : ToricFan.Triangle => Set.range (centralChartMap C ε hε s)
+  let R := U ⟨0, 0, Bool.false⟩ ∪ U ⟨0, 0, Bool.true⟩
+  have hU (s : ToricFan.Triangle) : IsPreconnected (U s) :=
+    (centralChartMap_range_connected C ε hε s).isPreconnected
+  have hR : IsPreconnected R :=
+    IsPreconnected.union' (reference_centralChartMap_overlap C ε hε) (hU _) (hU _)
+  have horigin (s : ToricFan.Triangle) : centralChartMap C ε hε s centralOrigin ∈ R := by
+    rw [centralChartMap_origin_reference]
+    cases hs : s.upper
+    · exact Or.inl (Set.mem_range_self _)
+    · exact Or.inr (Set.mem_range_self _)
+  have hcommon : (⋂ s : ToricFan.Triangle, R ∪ U s).Nonempty := by
+    refine
+      ⟨centralChartMap C ε hε ⟨0, 0, Bool.false⟩ centralOrigin, Set.mem_iInter.mpr fun s => ?_⟩
+    exact Or.inl (Or.inl (Set.mem_range_self _))
+  have hpre : IsPreconnected (⋃ s : ToricFan.Triangle, R ∪ U s) :=
+    isPreconnected_iUnion hcommon
+      (fun s =>
+        IsPreconnected.union'
+          ⟨centralChartMap C ε hε s centralOrigin, horigin s, Set.mem_range_self _⟩ hR (hU s))
+  have he : (⋃ s : ToricFan.Triangle, R ∪ U s) = ⋃ s : ToricFan.Triangle, U s := by
+    apply subset_antisymm
+    · intro q hq
+      obtain ⟨s, hq⟩ := Set.mem_iUnion.mp hq
+      rcases hq with (hq | hq) | hq
+      · exact Set.mem_iUnion.mpr ⟨⟨0, 0, Bool.false⟩, hq⟩
+      · exact Set.mem_iUnion.mpr ⟨⟨0, 0, Bool.true⟩, hq⟩
+      · exact Set.mem_iUnion.mpr ⟨s, hq⟩
+    · intro q hq
+      obtain ⟨s, hq⟩ := Set.mem_iUnion.mp hq
+      exact Set.mem_iUnion.mpr ⟨s, Or.inr hq⟩
+  rw [he] at hpre
+  rw [central_fibre_eq_union C ε hε]
+  exact
+    ⟨⟨centralChartMap C ε hε ⟨0, 0, Bool.false⟩ centralOrigin,
+        Set.mem_iUnion.mpr ⟨⟨0, 0, Bool.false⟩, Set.mem_range_self _⟩⟩,
+      hpre⟩
+
+private def CuspHoneycombHexagon.CommonFibres.descend {A X Y : Type*} (f : A → X) (g : A → Y)
+    (hf : Function.Surjective f) (x : X) : Y :=
+  g (hf x).choose
+
+private theorem
+    CuspHoneycombHexagon.CommonFibres.descend_apply {A X Y : Type*} (f : A → X) (g : A → Y)
+    (hf : Function.Surjective f) (hfg : ∀ a b, f a = f b → g a = g b) (a : A) :
+    descend f g hf (f a) = g a :=
+  hfg _ a (hf (f a)).choose_spec
+
+private theorem CuspHoneycombHexagon.CommonFibres.descend_surjective {A X Y : Type*} (f : A → X)
+    (g : A → Y) (hf : Function.Surjective f) (hfg : ∀ a b, f a = f b → g a = g b)
+    (hg : Function.Surjective g) : Function.Surjective (descend f g hf) := by
+  intro y
+  obtain ⟨a, rfl⟩ := hg y
+  exact ⟨f a, descend_apply f g hf hfg a⟩
+
+private theorem CuspHoneycombHexagon.CommonFibres.descend_injective {A X Y : Type*} (f : A → X)
+    (g : A → Y) (hf : Function.Surjective f) (hgf : ∀ a b, g a = g b → f a = f b) :
+    Function.Injective (descend f g hf) := by
+  intro x y h
+  have he := hgf (hf x).choose (hf y).choose h
+  exact (hf x).choose_spec.symm.trans (he.trans (hf y).choose_spec)
+
+private theorem CuspHoneycombHexagon.CommonFibres.descend_continuous {A X Y : Type*} (f : A → X)
+    (g : A → Y) (hf : Function.Surjective f) [TopologicalSpace A] [TopologicalSpace X]
+    [TopologicalSpace Y] (hq : Topology.IsQuotientMap f) (hg : Continuous g)
+    (hfg : ∀ a b, f a = f b → g a = g b) : Continuous (descend f g hf) := by
+  apply hq.continuous_iff.mpr
+  have he : descend f g hf ∘ f = g := funext (descend_apply f g hf hfg)
+  rwa [he]
+
+private def CuspHoneycombHexagon.CommonFibres.homeomorph {A X Y : Type*} (f : A → X) (g : A → Y)
+    (hf : Function.Surjective f) [TopologicalSpace A] [TopologicalSpace X] [TopologicalSpace Y]
+    [CompactSpace A] [T2Space X] [T2Space Y] (hfc : Continuous f) (hgc : Continuous g)
+    (hg : Function.Surjective g) (hfg : ∀ a b, f a = f b ↔ g a = g b) : X ≃ₜ Y := by
+  have hX : IsCompact (Set.univ : Set X) := by
+    rw [← Set.range_eq_univ.mpr hf]
+    exact isCompact_range hfc
+  letI : CompactSpace X := ⟨hX⟩
+  have hd : Continuous (descend f g hf) :=
+    descend_continuous f g hf (hfc.isClosedMap.isQuotientMap hfc hf) hgc (fun a b => (hfg a b).mp)
+  let e : X ≃ Y :=
+    Equiv.ofBijective (descend f g hf)
+      ⟨descend_injective f g hf (fun a b => (hfg a b).mpr),
+        descend_surjective f g hf (fun a b => (hfg a b).mp) hg⟩
+  exact Equiv.toHomeomorphOfContinuousClosed e hd hd.isClosedMap
+
+@[simp]
+private theorem
+    CuspHoneycombHexagon.CommonFibres.homeomorph_apply {A X Y : Type*} (f : A → X) (g : A → Y)
+    (hf : Function.Surjective f) [TopologicalSpace A] [TopologicalSpace X] [TopologicalSpace Y]
+    [CompactSpace A] [T2Space X] [T2Space Y] (hfc : Continuous f) (hgc : Continuous g)
+    (hg : Function.Surjective g) (hfg : ∀ a b, f a = f b ↔ g a = g b) (a : A) :
+    homeomorph f g hf hfc hgc hg hfg (f a) = g a :=
+  descend_apply f g hf (fun a b => (hfg a b).mp) a
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Toric/ToricSpace2.lean b/LeanPool/HopfProblem/Toric/ToricSpace2.lean
new file mode 100644
index 000000000..1b9ce1eab
--- /dev/null
+++ b/LeanPool/HopfProblem/Toric/ToricSpace2.lean
@@ -0,0 +1,3173 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Foundations.InvariantSubsetQuotient
+public import LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.Foundations.InvariantSubsetQuotient
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+
+/-!
+# Hopf problem: toric · toric space 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem ToricSpace.factors_continuous (s : ToricFan.Triangle) : Continuous (factors s) := by
+  apply continuous_pi
+  intro i
+  change Continuous (fun u : ActingTorus => ∏ j, (u j : ℂ) ^ s.dual i j)
+  exact
+    continuous_finsetProd _
+      (fun j _ =>
+        (Units.continuous_val.comp (continuous_apply j)).zpow₀ _ (fun u => Or.inl (u j).ne_zero))
+
+private theorem ToricSpace.torusAction_joint_continuous :
+    Continuous (fun p : ActingTorus × Space => torusAction p.1 p.2) := by
+  rw [continuous_iff_continuousAt]
+  rintro ⟨u, x⟩
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  have hlocal :
+    Continuous
+      (fun p : ActingTorus × ToricCharts.CoordinateSpace 3 =>
+        ToricSpace.inclusion s (scale s p.1 p.2)) :=
+    (inclusion_openEmbedding s).continuous.comp
+      (((factors_continuous s).comp continuous_fst).mul continuous_snd)
+  apply
+    (((Topology.IsOpenEmbedding.id (X := ActingTorus)).prodMap
+            (inclusion_openEmbedding s)).continuousAt_iff
+        (g := fun p : ActingTorus × Space => torusAction p.1 p.2) (x := (u, z))).mp
+  change
+    ContinuousAt
+      (fun p : ActingTorus × ToricCharts.CoordinateSpace 3 =>
+        torusAction p.1 (ToricSpace.inclusion s p.2))
+      (u, z)
+  simpa only [torusAction_inclusion] using hlocal.continuousAt (x := (u, z))
+
+private theorem ToricSpace.fibreMultiplier_continuous : Continuous fibreMultiplier := by
+  apply continuous_pi
+  intro i
+  fin_cases i
+  · exact continuous_apply 0
+  · exact continuous_apply 1
+  · exact continuous_const
+
+private def ToricSpace.displacementMatrix (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (t : ℂ) :
+    Matrix (Fin 2) (Fin 2) ℝ :=
+  !![0, 1; -1, 0] + (Real.log ‖t‖)⁻¹ • driftMatrix C t
+
+private theorem ToricSpace.displacementMatrix_mulVec (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (t : ℂ)
+    (y : Fin 2 → ℝ) : displacementMatrix C t *ᵥ y = displacement C t y := by
+  rw [displacementMatrix, Matrix.add_mulVec, Matrix.smul_mulVec]
+  change
+    !![(0 : ℝ), 1; -1, 0] *ᵥ y + (Real.log ‖t‖)⁻¹ • (driftMatrix C t *ᵥ y) =
+      realCuspVector y + (Real.log ‖t‖)⁻¹ • (driftMatrix C t *ᵥ y)
+  congr 1
+  ext i
+  fin_cases i <;> simp [realCuspVector, Matrix.mulVec, dotProduct, Fin.sum_univ_two]
+
+private def ToricSpace.inverseDisplacement (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (t : ℂ) :
+    (Fin 2 → ℝ) →ₗ[ℝ] (Fin 2 → ℝ) :=
+  (displacementMatrix C t)⁻¹.mulVecLin
+
+@[simp]
+private theorem ToricSpace.inverseDisplacement_add (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (t : ℂ)
+    (y z : Fin 2 → ℝ) :
+    inverseDisplacement C t (y + z) = inverseDisplacement C t y + inverseDisplacement C t z :=
+  map_add _ _ _
+
+private theorem ToricSpace.displacementMatrix_isUnit (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {t : ℂ}
+    (ht : Real.log ‖t‖ < 0) (hR : entryNorm (driftMatrix C t) ≤ -Real.log ‖t‖ / 4) :
+    IsUnit (displacementMatrix C t) := by
+  apply Matrix.mulVec_surjective_iff_isUnit.mp
+  intro y
+  obtain ⟨z, hz⟩ := (displacement_bijective C ht hR).surjective y
+  exact ⟨z, (displacementMatrix_mulVec C t z).trans hz⟩
+
+private theorem ToricSpace.displacementMatrix_det_ne_zero (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {t : ℂ}
+    (ht : Real.log ‖t‖ < 0) (hR : entryNorm (driftMatrix C t) ≤ -Real.log ‖t‖ / 4) :
+    (displacementMatrix C t).det ≠ 0 :=
+  isUnit_iff_ne_zero.mp ((Matrix.isUnit_iff_isUnit_det _).mp (displacementMatrix_isUnit C ht hR))
+
+private theorem
+    ToricSpace.inverseDisplacement_displacement (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {t : ℂ}
+    (ht : Real.log ‖t‖ < 0) (hR : entryNorm (driftMatrix C t) ≤ -Real.log ‖t‖ / 4)
+    (y : Fin 2 → ℝ) : inverseDisplacement C t (displacement C t y) = y := by
+  change (displacementMatrix C t)⁻¹ *ᵥ displacement C t y = y
+  rw [← displacementMatrix_mulVec, Matrix.mulVec_mulVec,
+    Matrix.nonsing_inv_mul _ (isUnit_iff_ne_zero.mpr (displacementMatrix_det_ne_zero C ht hR)),
+    Matrix.one_mulVec]
+
+private theorem
+    ToricSpace.displacement_inverseDisplacement (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {t : ℂ}
+    (ht : Real.log ‖t‖ < 0) (hR : entryNorm (driftMatrix C t) ≤ -Real.log ‖t‖ / 4)
+    (y : Fin 2 → ℝ) : displacement C t (inverseDisplacement C t y) = y := by
+  rw [← displacementMatrix_mulVec]
+  change displacementMatrix C t *ᵥ ((displacementMatrix C t)⁻¹ *ᵥ y) = y
+  rw [Matrix.mulVec_mulVec,
+    Matrix.mul_nonsing_inv _ (isUnit_iff_ne_zero.mpr (displacementMatrix_det_ne_zero C ht hR)),
+    Matrix.one_mulVec]
+
+private theorem ToricSpace.inverseDisplacement_norm_le (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {t : ℂ}
+    (ht : Real.log ‖t‖ < 0) (hR : entryNorm (driftMatrix C t) ≤ -Real.log ‖t‖ / 4)
+    (y : Fin 2 → ℝ) : ‖inverseDisplacement C t y‖ ≤ 2 * ‖y‖ := by
+  have h := displacement_lower_bound C ht hR (inverseDisplacement C t y)
+  rwa [displacement_inverseDisplacement C ht hR y] at h
+
+private theorem
+    ToricSpace.displacementMatrix_continuousAt (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {t : ℂ}
+    (hC : ∀ i j, ContinuousAt (fun s => C s i j) t) (ht0 : t ≠ 0) (htlog : Real.log ‖t‖ ≠ 0) :
+    ContinuousAt (displacementMatrix C) t := by
+  have hlog : ContinuousAt (fun s : ℂ => (Real.log ‖s‖)⁻¹) t :=
+    ((Real.continuousAt_log (norm_ne_zero_iff.mpr ht0)).comp continuous_norm.continuousAt).inv₀
+      htlog
+  apply continuousAt_pi.mpr
+  intro i
+  apply continuousAt_pi.mpr
+  intro j
+  change
+    ContinuousAt
+      (fun s : ℂ => !![(0 : ℝ), 1; -1, 0] i j + (Real.log ‖s‖)⁻¹ * (-2 * Real.pi * (C s i j).im))
+      t
+  exact
+    continuousAt_const.add
+      (hlog.mul (continuousAt_const.mul (Complex.continuous_im.continuousAt.comp (hC i j))))
+
+private theorem ToricSpace.inverseDisplacement_continuousAt_of_det_ne_zero
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {t : ℂ} (hC : ∀ i j, ContinuousAt (fun s => C s i j) t)
+    (ht0 : t ≠ 0) (htlog : Real.log ‖t‖ ≠ 0) (hdet : (displacementMatrix C t).det ≠ 0)
+    (y : Fin 2 → ℝ) :
+    ContinuousAt (fun p : ℂ × (Fin 2 → ℝ) => inverseDisplacement C p.1 p.2) (t, y) := by
+  have hi : ContinuousAt (fun s : ℂ => (displacementMatrix C s)⁻¹) t :=
+    (continuousAt_matrix_inv (displacementMatrix C t)
+          (by simpa only [Ring.inverse_eq_inv'] using ContinuousInv₀.continuousAt_inv₀ hdet)).comp
+      (displacementMatrix_continuousAt C hC ht0 htlog)
+  have hm : Continuous (fun p : Matrix (Fin 2) (Fin 2) ℝ × (Fin 2 → ℝ) => p.1 *ᵥ p.2) :=
+    continuous_fst.matrix_mulVec continuous_snd
+  have hp : ContinuousAt (fun p : ℂ × (Fin 2 → ℝ) => (displacementMatrix C p.1)⁻¹) (t, y) :=
+    ContinuousAt.comp (f := fun p : ℂ × (Fin 2 → ℝ) => p.1) (g := fun s : ℂ =>
+      (displacementMatrix C s)⁻¹) hi continuous_fst.continuousAt
+  exact hm.continuousAt.comp (hp.prodMk continuous_snd.continuousAt)
+
+private theorem
+    ToricSpace.inverseDisplacement_continuousAt (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) {t : ℂ}
+    (hC : ∀ i j, ContinuousAt (fun s => C s i j) t) (ht : Real.log ‖t‖ < 0)
+    (hR : entryNorm (driftMatrix C t) ≤ -Real.log ‖t‖ / 4) (y : Fin 2 → ℝ) :
+    ContinuousAt (fun p : ℂ × (Fin 2 → ℝ) => inverseDisplacement C p.1 p.2) (t, y) := by
+  have ht0 : t ≠ 0 := by
+    rintro rfl
+    simp at ht
+  exact
+    inverseDisplacement_continuousAt_of_det_ne_zero C hC ht0 ht.ne
+      (displacementMatrix_det_ne_zero C ht hR) y
+
+private theorem ToricSpace.position_continuousAt {x : Space} (hx : time x ≠ 0)
+    (hlog : Real.log ‖time x‖ ≠ 0) : ContinuousAt position x := by
+  have hxT : x ∈ openTorus := (mem_openTorus_iff x).mpr hx
+  have hc : ContinuousAt torusCoordinates x :=
+    torusCoordinates_holomorphic.continuousOn.continuousAt (openTorus_isOpen.mem_nhds hxT)
+  have ht : ContinuousAt (fun y : Space => Real.log ‖time y‖) x :=
+    ContinuousAt.comp (f := fun y : Space => ‖time y‖) (g := Real.log)
+      (Real.continuousAt_log (norm_ne_zero_iff.mpr hx))
+      time_holomorphic.continuous.continuousAt.norm
+  apply continuousAt_pi.mpr
+  intro i
+  have hi : ContinuousAt (fun y : Space => torusCoordinates y i.castSucc) x :=
+    (continuous_apply i.castSucc).continuousAt.comp hc
+  have hli : ContinuousAt (fun y : Space => Real.log ‖torusCoordinates y i.castSucc‖) x :=
+    ContinuousAt.comp (f := fun y : Space => ‖torusCoordinates y i.castSucc‖) (g := Real.log)
+      (Real.continuousAt_log (norm_ne_zero_iff.mpr (torusCoordinates_nonzero hxT i.castSucc)))
+      hi.norm
+  exact hli.div ht hlog
+
+private theorem ToricSpace.position_norm_le_on_chartNeighbourhood {ε : ℝ} (hε : 0 < ε) (hε1 : ε < 1)
+    {s : ToricFan.Triangle} {n : ℕ} {x : Space} (hx : x ∈ chartNeighbourhood s n ε) :
+    ‖position x‖ ≤ Max.max 0 (positionBound s ((n : ℝ) + 2) ε) := by
+  by_cases ht : time x = 0
+  · have hp : position x = 0 := by
+      ext i
+      simp [position, ht]
+    rw [hp, norm_zero]
+    exact le_max_left _ _
+  · obtain ⟨z, hz, rfl⟩ := hx
+    have hzT : z ∈ ToricCharts.torus := by
+      rw [← inclusion_preimage_openTorus s]
+      exact (mem_openTorus_iff _).mpr ht
+    have hS : (1 : ℝ) ≤ (n : ℝ) + 2 := by
+      have hn := Nat.cast_nonneg (α := ℝ) n
+      linarith
+    exact
+      (position_norm_bound s hzT hS hε hε1 hz.2 (fun j => (hz.1 j).le)).trans (le_max_right _ _)
+
+private theorem ToricSpace.position_locally_bounded {ε : ℝ} (hε : 0 < ε) (hε1 : ε < 1) {x : Space}
+    (ht : ‖time x‖ < ε) : ∃ B : ℝ, 0 ≤ B ∧ ∀ᶠ y in 𝓝 x, ‖time y‖ < ε ∧ ‖position y‖ ≤ B := by
+  obtain ⟨s, n, hx⟩ := chartNeighbourhood_cover ht
+  refine ⟨Max.max 0 (positionBound s ((n : ℝ) + 2) ε), le_max_left _ _, ?_⟩
+  filter_upwards [(chartNeighbourhood_open s n ε).mem_nhds hx] with y hy
+  exact ⟨chartNeighbourhood_time hy, position_norm_le_on_chartNeighbourhood hε hε1 hy⟩
+
+private def
+    ToricCharts.coordinateModulus {d : ℕ} (z : CoordinateSpace d) : CoordinateSpace d := fun i =>
+  (‖z i‖ : ℂ)
+
+@[simp]
+private theorem ToricCharts.coordinateModulus_apply {d : ℕ} (z : CoordinateSpace d) (i : Fin d) :
+    coordinateModulus z i = (‖z i‖ : ℂ) :=
+  rfl
+
+private theorem ToricCharts.coordinateModulus_continuous {d : ℕ} :
+    Continuous (coordinateModulus : CoordinateSpace d → CoordinateSpace d) := by
+  exact continuous_pi fun i => Complex.continuous_ofReal.comp (continuous_apply i).norm
+
+@[simp]
+private theorem ToricCharts.coordinateModulus_idempotent {d : ℕ} (z : CoordinateSpace d) :
+    coordinateModulus (coordinateModulus z) = coordinateModulus z := by
+  funext i
+  simp [coordinateModulus]
+
+@[simp]
+private theorem ToricCharts.coordinateModulus_mem_domain_iff {d : ℕ} (A : Matrix (Fin d) (Fin d) ℤ)
+    (z : CoordinateSpace d) : coordinateModulus z ∈ domain A ↔ z ∈ domain A := by simp [domain]
+
+@[simp]
+private theorem ToricCharts.coordinateModulus_mem_torus_iff {d : ℕ} (z : CoordinateSpace d) :
+    coordinateModulus z ∈ torus ↔ z ∈ torus := by simp [torus]
+
+private theorem ToricCharts.monomial_coordinateModulus {d : ℕ} (A : Matrix (Fin d) (Fin d) ℤ)
+    (z : CoordinateSpace d) :
+    monomial A (coordinateModulus z) = coordinateModulus (monomial A z) := by
+  funext i
+  simp [monomial, coordinateModulus, norm_prod, norm_zpow]
+
+private def ToricCharts.nonnegativeCoordinates {d : ℕ} : Set (CoordinateSpace d) :=
+  {z | ∃ r : Fin d → ℝ, (∀ i, 0 ≤ r i) ∧ z = fun i => (r i : ℂ)}
+
+private theorem ToricCharts.coordinateModulus_eq_self_iff {d : ℕ} (z : CoordinateSpace d) :
+    coordinateModulus z = z ↔ z ∈ nonnegativeCoordinates := by
+  constructor
+  · intro hz
+    exact ⟨fun i => ‖z i‖, fun i => norm_nonneg _, hz.symm⟩
+  · rintro ⟨r, hr, rfl⟩
+    funext i
+    exact congrArg Complex.ofReal (Complex.norm_of_nonneg (hr i))
+
+private theorem ToricSpace.chartChange_coordinateModulus (s t : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) :
+    ToricFan.Triangle.chartChange s t (ToricCharts.coordinateModulus z) =
+      ToricCharts.coordinateModulus (ToricFan.Triangle.chartChange s t z) :=
+  ToricCharts.monomial_coordinateModulus (ToricFan.Triangle.transition s t) z
+
+private theorem ToricSpace.coordinateModulus_overlap (s t : ToricFan.Triangle)
+    {z : ToricCharts.CoordinateSpace 3} (hz : z ∈ (ToricFan.Triangle.chartChange s t).source) :
+    ToricSpace.inclusion t (ToricCharts.coordinateModulus (ToricFan.Triangle.chartChange s t z)) =
+      ToricSpace.inclusion s (ToricCharts.coordinateModulus z) := by
+  symm
+  apply (inclusion_eq_iff s t _ _).mpr
+  refine ⟨?_, chartChange_coordinateModulus s t z⟩
+  simpa only [ToricFan.Triangle.chartChange_source,
+    ToricCharts.coordinateModulus_mem_domain_iff] using hz
+
+private def ToricSpace.modulus : Space → Space :=
+  descend fun s z => ToricSpace.inclusion s (ToricCharts.coordinateModulus z)
+
+@[simp]
+private theorem
+    ToricSpace.modulus_inclusion (s : ToricFan.Triangle) (z : ToricCharts.CoordinateSpace 3) :
+    modulus (ToricSpace.inclusion s z) =
+      ToricSpace.inclusion s (ToricCharts.coordinateModulus z) :=
+  descend_inclusion _ (fun s t _z hz => coordinateModulus_overlap s t hz) s z
+
+private theorem ToricSpace.modulus_continuous : Continuous modulus := by
+  apply continuous_iff_continuousAt.mpr
+  intro x
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  apply
+    ((parametrization s).continuousAt_iff_continuousAt_comp_right
+        (show ToricSpace.inclusion s z ∈ (parametrization s).target by simp)).mpr
+  have h : modulus ∘ parametrization s = ToricSpace.inclusion s ∘ ToricCharts.coordinateModulus :=
+    by
+    funext w
+    exact modulus_inclusion s w
+  rw [h]
+  exact
+    ((inclusion_openEmbedding s).continuous.comp
+        ToricCharts.coordinateModulus_continuous).continuousAt
+
+@[simp]
+private theorem ToricSpace.modulus_idempotent (x : Space) : modulus (modulus x) = modulus x := by
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  simp only [modulus_inclusion, ToricCharts.coordinateModulus_idempotent]
+
+@[simp]
+private theorem ToricSpace.time_modulus (x : Space) : time (modulus x) = (‖time x‖ : ℂ) := by
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  simp [ToricFan.Triangle.time]
+
+private def ToricSpace.positivePart : Set Space :=
+  {x | modulus x = x}
+
+private abbrev ToricSpace.PositivePart :=
+  positivePart
+
+private theorem ToricSpace.positivePart_isClosed : IsClosed positivePart :=
+  isClosed_eq modulus_continuous continuous_id
+
+@[simp]
+private theorem ToricSpace.inclusion_mem_positivePart_iff (s : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) :
+    ToricSpace.inclusion s z ∈ positivePart ↔ z ∈ ToricCharts.nonnegativeCoordinates := by
+  change modulus (ToricSpace.inclusion s z) = ToricSpace.inclusion s z ↔ _
+  rw [modulus_inclusion, (inclusion_openEmbedding s).injective.eq_iff,
+    ToricCharts.coordinateModulus_eq_self_iff]
+
+@[simp]
+private theorem ToricSpace.modulus_mem_positivePart (x : Space) : modulus x ∈ positivePart :=
+  modulus_idempotent x
+
+private def ToricSpace.modulusRetraction (x : Space) : PositivePart :=
+  ⟨modulus x, modulus_mem_positivePart x⟩
+
+@[simp]
+private theorem ToricSpace.modulusRetraction_coe (x : Space) :
+    (modulusRetraction x : Space) = modulus x :=
+  rfl
+
+private abbrev ToricSpace.CompactTorus :=
+  Fin 3 → Circle
+
+private def ToricSpace.compactTorusUnits : CompactTorus →* ActingTorus
+    where
+  toFun u i := Circle.toUnits (u i)
+  map_one' := by
+    funext i
+    exact Circle.toUnits.map_one
+  map_mul' u
+    v := by
+    funext i
+    exact Circle.toUnits.map_mul (u i) (v i)
+
+@[simp]
+private theorem ToricSpace.compactTorusUnits_apply (u : CompactTorus) (i : Fin 3) :
+    (compactTorusUnits u i : ℂ) = (u i : ℂ) :=
+  rfl
+
+private theorem ToricSpace.compactTorusUnits_continuous : Continuous compactTorusUnits := by
+  apply continuous_pi
+  intro i
+  apply Units.continuous_iff.mpr
+  have h : Continuous (fun u : CompactTorus => (u i : ℂ)) :=
+    continuous_subtype_val.comp (continuous_apply i)
+  exact ⟨h, h.inv₀ (fun u => (u i).coe_ne_zero)⟩
+
+private def ToricSpace.compactTorusAction (u : CompactTorus) (x : Space) : Space :=
+  torusAction (compactTorusUnits u) x
+
+@[simp]
+private theorem ToricSpace.compactTorusAction_one (x : Space) : compactTorusAction 1 x = x := by
+  simp [compactTorusAction]
+
+private theorem ToricSpace.compactTorusAction_mul (u v : CompactTorus) (x : Space) :
+    compactTorusAction u (compactTorusAction v x) = compactTorusAction (u * v) x := by
+  simp [compactTorusAction, torusAction_mul]
+
+private instance ToricSpace.compactTorusMulAction : MulAction CompactTorus Space
+    where
+  smul := compactTorusAction
+  one_smul := compactTorusAction_one
+  mul_smul u v x := (compactTorusAction_mul u v x).symm
+
+private theorem ToricSpace.compactTorusAction_continuous :
+    Continuous (fun p : CompactTorus × Space => compactTorusAction p.1 p.2) := by
+  have h : Continuous (fun p : CompactTorus × Space => (compactTorusUnits p.1, p.2)) :=
+    (compactTorusUnits_continuous.comp continuous_fst).prodMk continuous_snd
+  change
+    Continuous
+      ((fun p : ActingTorus × Space => torusAction p.1 p.2) ∘
+        (fun p : CompactTorus × Space => (compactTorusUnits p.1, p.2)))
+  exact torusAction_joint_continuous.comp h
+
+private instance ToricSpace.compactTorusContinuousSMul : ContinuousSMul CompactTorus Space :=
+  ⟨compactTorusAction_continuous⟩
+
+@[simp]
+private theorem ToricSpace.norm_factors_compactTorusUnits (s : ToricFan.Triangle) (u : CompactTorus)
+    (i : Fin 3) : ‖factors s (compactTorusUnits u) i‖ = 1 := by
+  simp [factors, ToricCharts.monomial, norm_prod, norm_zpow, Circle.norm_coe]
+
+private theorem ToricSpace.coordinateModulus_scale_compactTorusUnits (s : ToricFan.Triangle)
+    (u : CompactTorus) (z : ToricCharts.CoordinateSpace 3) :
+    ToricCharts.coordinateModulus (scale s (compactTorusUnits u) z) =
+      ToricCharts.coordinateModulus z := by
+  funext i
+  change (‖factors s (compactTorusUnits u) i * z i‖ : ℂ) = (‖z i‖ : ℂ)
+  rw [norm_mul, norm_factors_compactTorusUnits, one_mul]
+
+@[simp]
+private theorem ToricSpace.modulus_compactTorusAction (u : CompactTorus) (x : Space) :
+    modulus (compactTorusAction u x) = modulus x := by
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  simp [compactTorusAction, coordinateModulus_scale_compactTorusUnits]
+
+@[simp]
+private theorem ToricSpace.norm_time_compactTorusAction (u : CompactTorus) (x : Space) :
+    ‖time (compactTorusAction u x)‖ = ‖time x‖ := by
+  simp [compactTorusAction, time_torusAction, Circle.norm_coe]
+
+private theorem ToricSpace.exists_unitNorm_scale_modulus (s : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) :
+    ∃ u : ActingTorus, (∀ i, ‖(u i : ℂ)‖ = 1) ∧ scale s u (ToricCharts.coordinateModulus z) = z :=
+  by
+  classical
+  have hphase (c : ℂ) : ∃ w : ℂ, ‖w‖ = 1 ∧ w * (‖c‖ : ℂ) = c := by
+    by_cases hc : c = 0
+    · exact ⟨1, NormOneClass.norm_one, by simp [hc]⟩
+    · refine ⟨c / (‖c‖ : ℂ), ?_, ?_⟩
+      · rw [norm_div, Complex.norm_real, norm_norm, div_self (norm_ne_zero_iff.mpr hc)]
+      · exact
+          div_mul_cancel₀ _ (by simpa only [ne_eq, Complex.ofReal_eq_zero, norm_eq_zero] using hc)
+  choose w hw hmul using fun i => hphase (z i)
+  have hw0 : w ∈ ToricCharts.torus := by
+    intro i hi
+    have h := hw i
+    rw [hi, norm_zero] at h
+    exact zero_ne_one h
+  let u : ActingTorus := fun i =>
+    Units.mk0 (ToricCharts.monomial s.rays w i) (ToricCharts.monomial_mapsTo_torus s.rays hw0 i)
+  have hu : ∀ i, ‖(u i : ℂ)‖ = 1 := by
+    intro i
+    change ‖ToricCharts.monomial s.rays w i‖ = 1
+    simp only [ToricCharts.monomial, norm_prod, norm_zpow, hw, one_zpow, Finset.prod_const_one]
+  refine ⟨u, hu, ?_⟩
+  have hf : factors s u = w := by
+    change ToricCharts.monomial s.dual (ToricCharts.monomial s.rays w) = w
+    rw [ToricCharts.monomial_mul_on_torus _ _ hw0, ToricFan.Triangle.dual_rays,
+      ToricCharts.monomial_one]
+  ext i
+  change factors s u i * (‖z i‖ : ℂ) = z i
+  rw [hf]
+  exact hmul i
+
+private theorem ToricSpace.exists_compactTorus_scale_modulus (s : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) :
+    ∃ u : CompactTorus, scale s (compactTorusUnits u) (ToricCharts.coordinateModulus z) = z := by
+  obtain ⟨u, hu, hz⟩ := exists_unitNorm_scale_modulus s z
+  let v : CompactTorus := fun i => ⟨(u i : ℂ), mem_sphere_zero_iff_norm.mpr (hu i)⟩
+  refine ⟨v, ?_⟩
+  have hv : compactTorusUnits v = u := by
+    funext i
+    apply Units.ext
+    rfl
+  rw [hv]
+  exact hz
+
+private theorem ToricSpace.exists_compactTorusAction_modulus (x : Space) :
+    ∃ u : CompactTorus, compactTorusAction u (modulus x) = x := by
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  obtain ⟨u, hu⟩ := exists_compactTorus_scale_modulus s z
+  refine ⟨u, ?_⟩
+  change
+    torusAction (compactTorusUnits u) (modulus (ToricSpace.inclusion s z)) =
+      ToricSpace.inclusion s z
+  rw [modulus_inclusion, torusAction_inclusion, hu]
+
+private def ToricSpace.polarMultiplication (p : CompactTorus × PositivePart) : Space :=
+  compactTorusAction p.1 p.2
+
+private theorem ToricSpace.polarMultiplication_continuous : Continuous polarMultiplication := by
+  have h : Continuous (fun p : CompactTorus × PositivePart => (p.1, (p.2 : Space))) :=
+    continuous_fst.prodMk (continuous_subtype_val.comp continuous_snd)
+  change
+    Continuous
+      ((fun p : CompactTorus × Space => compactTorusAction p.1 p.2) ∘
+        (fun p : CompactTorus × PositivePart => (p.1, (p.2 : Space))))
+  exact compactTorusAction_continuous.comp h
+
+private theorem
+    ToricSpace.polarMultiplication_surjective : Function.Surjective polarMultiplication := by
+  intro x
+  obtain ⟨u, hu⟩ := exists_compactTorusAction_modulus x
+  exact ⟨(u, modulusRetraction x), hu⟩
+
+private theorem
+    ToricSpace.compactTorusAction_injective_of_time_ne_zero {x : Space} (hx : time x ≠ 0) :
+    Function.Injective (fun u : CompactTorus => compactTorusAction u x) := by
+  intro u v huv
+  have hxt : x ∈ openTorus := (mem_openTorus_iff x).mpr hx
+  have he := congrArg torusCoordinates huv
+  change
+    torusCoordinates (torusAction (compactTorusUnits u) x) =
+      torusCoordinates (torusAction (compactTorusUnits v) x) at he
+  rw [torusCoordinates_action _ hxt, torusCoordinates_action _ hxt] at he
+  funext i
+  apply Circle.ext
+  exact mul_right_cancel₀ (torusCoordinates_nonzero hxt i) (congrFun he i)
+
+private def ToricSpace.compactTorusActionShear : CompactTorus × Space ≃ₜ CompactTorus × Space
+    where
+  toFun p := (p.1, p.1 • p.2)
+  invFun p := (p.1, p.1⁻¹ • p.2)
+  left_inv p := by simp
+  right_inv p := by simp
+  continuous_toFun := continuous_fst.prodMk ContinuousSMul.continuous_smul
+  continuous_invFun := continuous_fst.prodMk (continuous_fst.inv.smul continuous_snd)
+
+private theorem ToricSpace.compactTorusAction_isClosedMap :
+    IsClosedMap (fun p : CompactTorus × Space => compactTorusAction p.1 p.2) :=
+  isClosedMap_snd_of_compactSpace.comp compactTorusActionShear.isClosedMap
+
+private theorem ToricSpace.polarMultiplication_isClosedMap : IsClosedMap polarMultiplication := by
+  have h : IsClosedMap (fun p : CompactTorus × PositivePart => (p.1, (p.2 : Space))) :=
+    ((Homeomorph.refl CompactTorus).isClosedEmbedding.prodMap
+        positivePart_isClosed.isClosedEmbedding_subtypeVal).isClosedMap
+  change
+    IsClosedMap
+      ((fun p : CompactTorus × Space => compactTorusAction p.1 p.2) ∘
+        (fun p : CompactTorus × PositivePart => (p.1, (p.2 : Space))))
+  exact compactTorusAction_isClosedMap.comp h
+
+private abbrev ToricSpace.ClosedPositiveTube (η : ℝ) :=
+  { x : PositivePart // ‖time (x : Space)‖ ≤ η }
+
+private theorem ToricSpace.closedPolarMap_mem_iff (η : ℝ) (p : CompactTorus × PositivePart) :
+    polarMultiplication p ∈ {x : Space | ‖time x‖ ≤ η} ↔
+      p.2 ∈ {x : PositivePart | ‖time (x : Space)‖ ≤ η} := by
+  change ‖time (compactTorusAction p.1 p.2)‖ ≤ η ↔ ‖time (p.2 : Space)‖ ≤ η
+  rw [norm_time_compactTorusAction]
+
+private def ToricSpace.closedPolarMap (η : ℝ) :
+    CompactTorus × ClosedPositiveTube η → { x : Space // ‖time x‖ ≤ η } :=
+  ProductRestriction.productRestriction polarMultiplication
+    {x : PositivePart | ‖time (x : Space)‖ ≤ η} {x : Space | ‖time x‖ ≤ η}
+    (closedPolarMap_mem_iff η)
+
+@[simp]
+private theorem ToricSpace.closedPolarMap_coe (η : ℝ) (p : CompactTorus × ClosedPositiveTube η) :
+    (closedPolarMap η p : Space) = compactTorusAction p.1 (p.2.1 : Space) :=
+  rfl
+
+private theorem ToricSpace.closedPolarMap_continuous (η : ℝ) : Continuous (closedPolarMap η) :=
+  ProductRestriction.productRestriction_continuous _ _ _ _ polarMultiplication_continuous
+
+private theorem ToricSpace.closedPolarMap_isClosedMap (η : ℝ) : IsClosedMap (closedPolarMap η) :=
+  ProductRestriction.productRestriction_isClosedMap _ _ _ _ polarMultiplication_isClosedMap
+
+private theorem
+    ToricSpace.closedPolarMap_surjective (η : ℝ) : Function.Surjective (closedPolarMap η) :=
+  ProductRestriction.productRestriction_surjective _ _ _ _ polarMultiplication_surjective
+
+private theorem ToricSpace.closedPolarMap_isQuotientMap (η : ℝ) :
+    Topology.IsQuotientMap (closedPolarMap η) :=
+  (closedPolarMap_isClosedMap η).isQuotientMap (closedPolarMap_continuous η)
+    (closedPolarMap_surjective η)
+
+private def ToricSpace.closedModulusRetraction (η : ℝ) (x : { x : Space // ‖time x‖ ≤ η }) :
+    ClosedPositiveTube η :=
+  ⟨modulusRetraction x, by
+    change ‖time (modulus (x : Space))‖ ≤ η
+    simpa only [time_modulus, Complex.norm_real, norm_norm] using x.property⟩
+
+@[simp]
+private theorem ToricSpace.closedModulusRetraction_closedPolarMap (η : ℝ)
+    (p : CompactTorus × ClosedPositiveTube η) :
+    closedModulusRetraction η (closedPolarMap η p) = p.2 := by
+  apply Subtype.ext
+  apply Subtype.ext
+  change modulus (compactTorusAction p.1 (p.2.1 : Space)) = (p.2.1 : Space)
+  rw [modulus_compactTorusAction]
+  exact p.2.1.property
+
+private def ToricSpace.phaseShear (v : Fin 2 → ℤ) (u : CompactTorus) : CompactTorus :=
+  ![u 0 * u 2 ^ v 0, u 1 * u 2 ^ v 1, u 2]
+
+private theorem ToricSpace.phaseShear_coe (v : Fin 2 → ℤ) (u : CompactTorus) :
+    (fun j => (phaseShear v u j : ℂ)) =
+      ToricCharts.monomial (ToricFan.Triangle.shear v) (fun j => (u j : ℂ)) := by
+  funext i
+  fin_cases i <;>
+    simp [phaseShear, ToricCharts.monomial, ToricFan.Triangle.shear, Fin.prod_univ_succ]
+
+private theorem ToricSpace.factors_shift_phaseShear (s : ToricFan.Triangle) (v : Fin 2 → ℤ)
+    (u : CompactTorus) :
+    factors (s.shift v) (compactTorusUnits (phaseShear v u)) = factors s (compactTorusUnits u) := by
+  change
+    ToricCharts.monomial (s.shift v).dual (fun j => (phaseShear v u j : ℂ)) =
+      ToricCharts.monomial s.dual (fun j => (u j : ℂ))
+  rw [ToricFan.Triangle.dual_shift, phaseShear_coe,
+    ToricCharts.monomial_mul_on_torus _ _ (fun j => (u j).coe_ne_zero), Matrix.mul_assoc,
+    ToricFan.Triangle.shear_add]
+  simp
+
+private theorem
+    ToricSpace.translate_compactTorusAction (v : Fin 2 → ℤ) (u : CompactTorus) (x : Space) :
+    ToricSpace.translate v (compactTorusAction u x) =
+      compactTorusAction (phaseShear v u) (ToricSpace.translate v x) := by
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  simp [compactTorusAction, scale, factors_shift_phaseShear]
+
+private abbrev CuspHoneycombTiling.Plane :=
+  Fin 2 → ℝ
+
+private abbrev CuspHoneycombTiling.Lattice :=
+  Fin 2 → ℤ
+
+private def CuspHoneycombTiling.latticePoint (v : CuspHoneycombTiling.Lattice) : Plane := fun i =>
+  (v i : ℝ)
+
+@[simp]
+private theorem
+    CuspHoneycombTiling.latticePoint_apply (v : CuspHoneycombTiling.Lattice) (i : Fin 2) :
+    latticePoint v i = (v i : ℝ) :=
+  rfl
+
+@[simp]
+private theorem CuspHoneycombTiling.latticePoint_zero : latticePoint 0 = 0 := by
+  funext i
+  simp [latticePoint]
+
+@[simp]
+private theorem CuspHoneycombTiling.latticePoint_add (v w : CuspHoneycombTiling.Lattice) :
+    latticePoint (v + w) = latticePoint v + latticePoint w := by
+  funext i
+  simp [latticePoint]
+
+@[simp]
+private theorem CuspHoneycombTiling.latticePoint_neg (v : CuspHoneycombTiling.Lattice) :
+    latticePoint (-v) = -latticePoint v := by
+  funext i
+  simp [latticePoint]
+
+private def CuspHoneycombTiling.baseCell : Set Plane :=
+  {x | |2 * x 0 + x 1| ≤ 1 ∧ |x 0 - x 1| ≤ 1 ∧ |x 0 + 2 * x 1| ≤ 1}
+
+private def CuspHoneycombTiling.cell (v : CuspHoneycombTiling.Lattice) : Set Plane :=
+  {x | x - latticePoint v ∈ baseCell}
+
+@[simp]
+private theorem CuspHoneycombTiling.mem_baseCell (x : Plane) :
+    x ∈ baseCell ↔ |2 * x 0 + x 1| ≤ 1 ∧ |x 0 - x 1| ≤ 1 ∧ |x 0 + 2 * x 1| ≤ 1 :=
+  Iff.rfl
+
+@[simp]
+private theorem CuspHoneycombTiling.mem_cell (v : CuspHoneycombTiling.Lattice) (x : Plane) :
+    x ∈ cell v ↔ x - latticePoint v ∈ baseCell :=
+  Iff.rfl
+
+@[simp]
+private theorem CuspHoneycombTiling.cell_zero : cell 0 = baseCell := by
+  ext x
+  simp only [mem_cell, latticePoint_zero, sub_zero]
+
+private theorem CuspHoneycombTiling.baseCell_coordinate_bound_sharp {x : Plane} (hx : x ∈ baseCell)
+    (i : Fin 2) : |x i| ≤ (2 / 3 : ℝ) := by
+  obtain ⟨h0, h1, h2⟩ := hx
+  have h0' := abs_le.mp h0
+  have h1' := abs_le.mp h1
+  have h2' := abs_le.mp h2
+  fin_cases i
+  · change |x 0| ≤ (2 / 3 : ℝ)
+    exact abs_le.mpr ⟨by linarith [h0'.1, h1'.1], by linarith [h0'.2, h1'.2]⟩
+  · change |x 1| ≤ (2 / 3 : ℝ)
+    exact abs_le.mpr ⟨by linarith [h2'.1, h1'.2], by linarith [h2'.2, h1'.1]⟩
+
+private theorem CuspHoneycombTiling.baseCell_coordinate_bound {x : Plane} (hx : x ∈ baseCell)
+    (i : Fin 2) : |x i| ≤ 1 :=
+  (baseCell_coordinate_bound_sharp hx i).trans (by norm_num)
+
+private theorem
+    CuspHoneycombTiling.cell_coordinate_bound {v : CuspHoneycombTiling.Lattice} {x : Plane}
+    (hx : x ∈ cell v) (i : Fin 2) : |x i - (v i : ℝ)| ≤ 1 :=
+  baseCell_coordinate_bound hx i
+
+private theorem
+    CuspHoneycombTiling.add_latticePoint_mem_cell_iff (v w : CuspHoneycombTiling.Lattice)
+    (x : Plane) : x + latticePoint w ∈ cell (v + w) ↔ x ∈ cell v := by
+  simp only [mem_cell, latticePoint_add, add_sub_add_right_eq_sub]
+
+private def CuspHoneycombTiling.squareCenter (p q : ℝ) : CuspHoneycombTiling.Lattice :=
+  if q ≤ p then if 2 * p + q ≤ 1 then 0 else if 2 ≤ p + 2 * q then 1 else ![1, 0]
+  else if p + 2 * q ≤ 1 then 0 else if 2 ≤ 2 * p + q then 1 else ![0, 1]
+
+private theorem CuspHoneycombTiling.mem_cell_squareCenter (p q : ℝ) (hp0 : 0 ≤ p) (hp1 : p ≤ 1)
+    (hq0 : 0 ≤ q) (hq1 : q ≤ 1) : (![p, q] : Plane) ∈ cell (squareCenter p q) := by
+  unfold squareCenter
+  split_ifs
+  all_goals
+    simp only [mem_cell, mem_baseCell, Pi.sub_apply, latticePoint_apply, Matrix.cons_val_zero,
+      Matrix.cons_val_one, Matrix.cons_val_fin_one, Pi.zero_apply, Pi.one_apply, Int.cast_zero,
+      Int.cast_one, sub_zero, abs_le]
+  all_goals repeat' apply And.intro
+  all_goals linarith
+
+private def CuspHoneycombTiling.floorCenter (x : Plane) : CuspHoneycombTiling.Lattice := fun i =>
+  ⌊x i⌋ + squareCenter (Int.fract (x 0)) (Int.fract (x 1)) i
+
+private theorem CuspHoneycombTiling.sub_latticePoint_floorCenter (x : Plane) :
+    x - latticePoint (floorCenter x) =
+      (![Int.fract (x 0), Int.fract (x 1)] : Plane) -
+        latticePoint (squareCenter (Int.fract (x 0)) (Int.fract (x 1))) := by
+  funext i
+  simp only [Pi.sub_apply, latticePoint, floorCenter, Int.cast_add, sub_add_eq_sub_sub]
+  rw [Int.self_sub_floor]
+  fin_cases i <;> rfl
+
+private theorem
+    CuspHoneycombTiling.mem_cell_floorCenter (x : Plane) : x ∈ cell (floorCenter x) := by
+  change x - latticePoint (floorCenter x) ∈ baseCell
+  rw [sub_latticePoint_floorCenter]
+  exact
+    mem_cell_squareCenter _ _ (Int.fract_nonneg _) (Int.fract_lt_one _).le (Int.fract_nonneg _)
+      (Int.fract_lt_one _).le
+
+private theorem CuspHoneycombTiling.exists_mem_cell (x : Plane) :
+    ∃ v : CuspHoneycombTiling.Lattice, x ∈ cell v :=
+  ⟨floorCenter x, mem_cell_floorCenter x⟩
+
+private theorem CuspHoneycombTiling.iUnion_cell :
+    (⋃ v : CuspHoneycombTiling.Lattice, cell v) = Set.univ := by
+  ext x
+  simp only [Set.mem_iUnion, Set.mem_univ, iff_true]
+  exact exists_mem_cell x
+
+private theorem CuspHoneycombTiling.baseCell_isClosed : IsClosed baseCell := by
+  have h0 : IsClosed {x : Plane | |2 * x 0 + x 1| ≤ 1} :=
+    isClosed_le ((continuous_const.mul (continuous_apply 0)).add (continuous_apply 1)).abs
+      continuous_const
+  have h1 : IsClosed {x : Plane | |x 0 - x 1| ≤ 1} :=
+    isClosed_le ((continuous_apply 0).sub (continuous_apply 1)).abs continuous_const
+  have h2 : IsClosed {x : Plane | |x 0 + 2 * x 1| ≤ 1} :=
+    isClosed_le ((continuous_apply 0).add (continuous_const.mul (continuous_apply 1))).abs
+      continuous_const
+  exact h0.inter (h1.inter h2)
+
+private theorem CuspHoneycombTiling.baseCell_isCompact : IsCompact baseCell := by
+  apply
+    (CompactIccSpace.isCompact_Icc : IsCompact (Set.Icc (-1 : Plane) 1)).of_isClosed_subset
+      baseCell_isClosed
+  intro x hx
+  exact
+    ⟨fun i => (abs_le.mp (baseCell_coordinate_bound hx i)).1, fun i =>
+      (abs_le.mp (baseCell_coordinate_bound hx i)).2⟩
+
+private theorem
+    CuspHoneycombTiling.cell_isClosed (v : CuspHoneycombTiling.Lattice) : IsClosed (cell v) :=
+  baseCell_isClosed.preimage (continuous_id.sub continuous_const)
+
+private theorem CuspHoneycombTiling.cell_finite_inter_ball (x : Plane) :
+    {v : CuspHoneycombTiling.Lattice | (cell v ∩ Metric.ball x 1).Nonempty}.Finite := by
+  have hbox : {v : CuspHoneycombTiling.Lattice | ∀ i, v i ∈ Set.Icc ⌈x i - 2⌉ ⌊x i + 2⌋}.Finite :=
+    Set.Finite.pi' (fun i => Set.finite_Icc ⌈x i - 2⌉ ⌊x i + 2⌋)
+  apply hbox.subset
+  rintro v ⟨y, hyv, hyx⟩ i
+  have hcoord := abs_le.mp (cell_coordinate_bound hyv i)
+  have hdist : |y i - x i| < 1 := by
+    simpa only [Real.dist_eq] using (dist_le_pi_dist y x i).trans_lt (Metric.mem_ball.mp hyx)
+  have hnear := abs_lt.mp hdist
+  constructor
+  · apply Int.ceil_le.mpr
+    linarith [hcoord.2, hnear.1]
+  · apply Int.le_floor.mpr
+    linarith [hcoord.1, hnear.2]
+
+private theorem CuspHoneycombTiling.cell_locallyFinite : LocallyFinite cell := by
+  intro x
+  exact ⟨Metric.ball x 1, Metric.ball_mem_nhds x (by norm_num), cell_finite_inter_ball x⟩
+
+private theorem
+    CuspHoneycombTiling.baseCell_inter_cell_nonempty_iff (v : CuspHoneycombTiling.Lattice) :
+    (baseCell ∩ cell v).Nonempty ↔
+      v = 0 ∨
+        v = ![1, 0] ∨ v = ![0, 1] ∨ v = ![1, -1] ∨ v = ![-1, 0] ∨ v = ![0, -1] ∨ v = ![-1, 1] := by
+  constructor
+  · rintro ⟨x, hx, hxv⟩
+    have hcoord (i : Fin 2) : -1 ≤ v i ∧ v i ≤ 1 := by
+      have hbase := abs_le.mp (baseCell_coordinate_bound_sharp hx i)
+      have hshift := abs_le.mp (baseCell_coordinate_bound_sharp hxv i)
+      change -(2 / 3 : ℝ) ≤ x i - (v i : ℝ) ∧ x i - (v i : ℝ) ≤ 2 / 3 at hshift
+      have hlo : (-2 : ℝ) < (v i : ℝ) := by linarith [hbase.1, hshift.2]
+      have hhi : (v i : ℝ) < (2 : ℝ) := by linarith [hbase.2, hshift.1]
+      have hlo' : (-2 : ℤ) < v i := by exact_mod_cast hlo
+      have hhi' : v i < (2 : ℤ) := by exact_mod_cast hhi
+      omega
+    have hbase := abs_le.mp hx.1
+    have hshift := abs_le.mp hxv.1
+    change
+      (-1 : ℝ) ≤ 2 * (x 0 - (v 0 : ℝ)) + (x 1 - (v 1 : ℝ)) ∧
+        2 * (x 0 - (v 0 : ℝ)) + (x 1 - (v 1 : ℝ)) ≤ 1 at hshift
+    have hlinear : (-2 : ℝ) ≤ 2 * (v 0 : ℝ) + (v 1 : ℝ) ∧ 2 * (v 0 : ℝ) + (v 1 : ℝ) ≤ 2 := by
+      constructor <;> linarith [hbase.1, hbase.2, hshift.1, hshift.2]
+    have hlinear' : (-2 : ℤ) ≤ 2 * v 0 + v 1 ∧ 2 * v 0 + v 1 ≤ 2 := by exact_mod_cast hlinear
+    have h0 := hcoord 0
+    have h1 := hcoord 1
+    simp only [funext_iff, Fin.forall_fin_two, Pi.zero_apply, Matrix.cons_val_zero,
+      Matrix.cons_val_one]
+    omega
+  · intro hv
+    refine ⟨fun i => (v i : ℝ) / 2, ?_, ?_⟩
+    · rcases hv with rfl | rfl | rfl | rfl | rfl | rfl | rfl <;> norm_num [baseCell]
+    · rcases hv with rfl | rfl | rfl | rfl | rfl | rfl | rfl <;>
+        norm_num [cell, baseCell, latticePoint]
+
+private theorem CuspHoneycombTiling.cell_inter_cell_nonempty_iff_baseCell
+    (v w : CuspHoneycombTiling.Lattice) :
+    (cell v ∩ cell w).Nonempty ↔ (baseCell ∩ cell (w - v)).Nonempty := by
+  constructor
+  · rintro ⟨x, hxv, hxw⟩
+    refine ⟨x - latticePoint v, hxv, ?_⟩
+    apply (add_latticePoint_mem_cell_iff (w - v) v (x - latticePoint v)).mp
+    simpa only [sub_add_cancel] using hxw
+  · rintro ⟨x, hx, hxwv⟩
+    refine ⟨x + latticePoint v, ?_, ?_⟩
+    · have h := (add_latticePoint_mem_cell_iff 0 v x).mpr (by simpa only [cell_zero] using hx)
+      simpa only [zero_add] using h
+    · simpa only [sub_add_cancel] using (add_latticePoint_mem_cell_iff (w - v) v x).mpr hxwv
+
+private abbrev CuspHoneycombHexagon.Plane :=
+  Fin 2 → ℝ
+
+private abbrev CuspHoneycombHexagon.Square :=
+  { p : Plane // ∀ i, p i ∈ Set.Icc (0 : ℝ) 1 }
+
+private theorem CuspHoneycombHexagon.square_isCompact :
+    IsCompact {p : Plane | ∀ i, p i ∈ Set.Icc (0 : ℝ) 1} :=
+  isCompact_pi_infinite (fun _ => CompactIccSpace.isCompact_Icc)
+
+private instance CuspHoneycombHexagon.square_compactSpace : CompactSpace Square :=
+  isCompact_iff_compactSpace.mp square_isCompact
+
+private def CuspHoneycombHexagon.SquareRel (i j : Fin 6) (p q : Square) : Prop :=
+  (i = j ∧ p = q) ∨
+    (j = i + 1 ∧ p.1 0 = 1 ∧ q.1 1 = 1 ∧ q.1 0 = p.1 1) ∨
+      (i = j + 1 ∧ p.1 1 = 1 ∧ q.1 0 = 1 ∧ q.1 1 = p.1 0) ∨ ((∀ k, p.1 k = 1) ∧ (∀ k, q.1 k = 1))
+
+private theorem CuspHoneycombHexagon.square_eq_of_all_one (p q : Square) (hp : ∀ k, p.1 k = 1)
+    (hq : ∀ k, q.1 k = 1) : p = q := by
+  apply Subtype.ext
+  funext k
+  exact (hp k).trans (hq k).symm
+
+@[simp]
+private theorem CuspHoneycombHexagon.squareRel_self (i : Fin 6) (p q : Square) :
+    SquareRel i i p q ↔ p = q := by
+  have hne : i ≠ i + 1 := (show ∀ i : Fin 6, i ≠ i + 1 by decide) i
+  constructor
+  · rintro (⟨_, h⟩ | ⟨h, _⟩ | ⟨h, _⟩ | ⟨hp, hq⟩)
+    · exact h
+    · exact (hne h).elim
+    · exact (hne h).elim
+    · exact square_eq_of_all_one p q hp hq
+  · exact fun h => Or.inl ⟨rfl, h⟩
+
+@[simp]
+private theorem CuspHoneycombHexagon.squareRel_next (i : Fin 6) (p q : Square) :
+    SquareRel i (i + 1) p q ↔ p.1 0 = 1 ∧ q.1 1 = 1 ∧ q.1 0 = p.1 1 := by
+  have hne : i ≠ i + 1 := (show ∀ i : Fin 6, i ≠ i + 1 by decide) i
+  have hne₂ : i ≠ (i + 1) + 1 := (show ∀ i : Fin 6, i ≠ (i + 1) + 1 by decide) i
+  constructor
+  · rintro (⟨h, _⟩ | ⟨_, h⟩ | ⟨h, _⟩ | ⟨hp, hq⟩)
+    · exact (hne h).elim
+    · exact h
+    · exact (hne₂ h).elim
+    · exact ⟨hp 0, hq 1, (hq 0).trans (hp 1).symm⟩
+  · exact fun h => Or.inr (Or.inl ⟨rfl, h⟩)
+
+@[simp]
+private theorem CuspHoneycombHexagon.squareRel_prev (i : Fin 6) (p q : Square) :
+    SquareRel i (i + 5) p q ↔ p.1 1 = 1 ∧ q.1 0 = 1 ∧ q.1 1 = p.1 0 := by
+  have hne : i ≠ i + 5 := (show ∀ i : Fin 6, i ≠ i + 5 by decide) i
+  have hnext : i + 5 ≠ i + 1 := (show ∀ i : Fin 6, i + 5 ≠ i + 1 by decide) i
+  have hprev : i = (i + 5) + 1 := (show ∀ i : Fin 6, i = (i + 5) + 1 by decide) i
+  constructor
+  · rintro (⟨h, _⟩ | ⟨h, _⟩ | ⟨_, h⟩ | ⟨hp, hq⟩)
+    · exact (hne h).elim
+    · exact (hnext h).elim
+    · exact h
+    · exact ⟨hp 1, hq 0, (hq 1).trans (hp 0).symm⟩
+  · exact fun h => Or.inr (Or.inr (Or.inl ⟨hprev, h⟩))
+
+private theorem
+    CuspHoneycombHexagon.squareRel_nonadjacent (i j : Fin 6) (p q : Square) (hij : i ≠ j)
+    (hnext : j ≠ i + 1) (hprev : i ≠ j + 1) :
+    SquareRel i j p q ↔ (∀ k, p.1 k = 1) ∧ (∀ k, q.1 k = 1) := by
+  simp only [SquareRel, hij, hnext, hprev, false_and, false_or]
+
+@[simp]
+private theorem CuspHoneycombHexagon.squareRel_add_two (i : Fin 6) (p q : Square) :
+    SquareRel i (i + 2) p q ↔ (∀ k, p.1 k = 1) ∧ (∀ k, q.1 k = 1) :=
+  squareRel_nonadjacent i (i + 2) p q ((show ∀ i : Fin 6, i ≠ i + 2 by decide) i)
+    ((show ∀ i : Fin 6, i + 2 ≠ i + 1 by decide) i)
+    ((show ∀ i : Fin 6, i ≠ (i + 2) + 1 by decide) i)
+
+@[simp]
+private theorem CuspHoneycombHexagon.squareRel_add_three (i : Fin 6) (p q : Square) :
+    SquareRel i (i + 3) p q ↔ (∀ k, p.1 k = 1) ∧ (∀ k, q.1 k = 1) :=
+  squareRel_nonadjacent i (i + 3) p q ((show ∀ i : Fin 6, i ≠ i + 3 by decide) i)
+    ((show ∀ i : Fin 6, i + 3 ≠ i + 1 by decide) i)
+    ((show ∀ i : Fin 6, i ≠ (i + 3) + 1 by decide) i)
+
+@[simp]
+private theorem CuspHoneycombHexagon.squareRel_add_four (i : Fin 6) (p q : Square) :
+    SquareRel i (i + 4) p q ↔ (∀ k, p.1 k = 1) ∧ (∀ k, q.1 k = 1) :=
+  squareRel_nonadjacent i (i + 4) p q ((show ∀ i : Fin 6, i ≠ i + 4 by decide) i)
+    ((show ∀ i : Fin 6, i + 4 ≠ i + 1 by decide) i)
+    ((show ∀ i : Fin 6, i ≠ (i + 4) + 1 by decide) i)
+
+private def ToricCharts.zeroCount (z : CoordinateSpace 3) : ℕ :=
+  Nat.card { j : Fin 3 // z j = 0 }
+
+private def ToricCharts.vanishingIndices (z : CoordinateSpace 3) : Finset (Fin 3) := by
+  classical exact Finset.univ.filter (fun j => z j = 0)
+
+@[simp]
+private theorem ToricCharts.mem_vanishingIndices (z : CoordinateSpace 3) (j : Fin 3) :
+    j ∈ vanishingIndices z ↔ z j = 0 := by classical simp [vanishingIndices]
+
+private theorem ToricCharts.vanishingIndices_card (z : CoordinateSpace 3) :
+    (vanishingIndices z).card = zeroCount z := by
+  classical
+  rw [zeroCount, Nat.card_eq_fintype_card, Fintype.card_subtype]
+  rfl
+
+private theorem ToricCharts.vanishingIndices_nonempty (z : CoordinateSpace 3) :
+    (vanishingIndices z).Nonempty ↔ ToricFan.Triangle.time z = 0 := by
+  constructor
+  · rintro ⟨j, hj⟩
+    have hp : ∏ k, z k = 0 :=
+      Finset.prod_eq_zero (Finset.mem_univ j) ((mem_vanishingIndices z j).mp hj)
+    simpa [ToricFan.Triangle.time, Fin.prod_univ_succ, mul_assoc] using hp
+  · intro hz
+    obtain h | h | h := (ToricFan.Triangle.central_fibre z).mp hz
+    · exact ⟨0, (mem_vanishingIndices z 0).mpr h⟩
+    · exact ⟨1, (mem_vanishingIndices z 1).mpr h⟩
+    · exact ⟨2, (mem_vanishingIndices z 2).mpr h⟩
+
+private theorem ToricCharts.zeroCount_pos_iff (z : CoordinateSpace 3) :
+    0 < zeroCount z ↔ ToricFan.Triangle.time z = 0 := by
+  rw [← vanishingIndices_card, Finset.card_pos, vanishingIndices_nonempty]
+
+@[simp]
+private theorem ToricCharts.zeroCount_zero : zeroCount (0 : CoordinateSpace 3) = 3 := by
+  classical simp [zeroCount, Nat.card_eq_fintype_card]
+
+public
+theorem ToricCharts.equal_columns_of_left_inverse {A B : Matrix (Fin 3) (Fin 3) ℤ}
+    (hBA : B * A = 1) {j k : Fin 3} (hcol : ∀ i, A i j = A i k) : j = k := by
+  have he : (B * A) j j = (B * A) j k := by
+    simp only [Matrix.mul_apply]
+    exact Finset.sum_congr rfl (fun i _ => congrArg (fun c => B j i * c) (hcol i))
+  rw [hBA] at he
+  by_contra hne
+  simp [hne] at he
+
+private theorem
+    ToricCharts.zeroCount_le_monomial {A B : Matrix (Fin 3) (Fin 3) ℤ} (hA : HeightOne A)
+    (hBA : B * A = 1) {z : CoordinateSpace 3} (hz : z ∈ domain A) :
+    zeroCount z ≤ zeroCount (monomial A z) := by
+  have hcol (j : { j : Fin 3 // z j = 0 }) : ∃ k : Fin 3, ∀ i, A i j = if i = k then 1 else 0 :=
+    column_single_of_zero hA hz j.2
+  choose f hf using hcol
+  let g : { j : Fin 3 // z j = 0 } → { k : Fin 3 // monomial A z k = 0 } := fun j =>
+    ⟨f j, monomial_zero_of_column_single j.2 (hf j)⟩
+  apply Nat.card_le_card_of_injective g
+  intro j k h
+  have hfk : f j = f k := congrArg Subtype.val h
+  apply Subtype.ext
+  apply equal_columns_of_left_inverse hBA
+  intro i
+  rw [hf j i, hf k i, hfk]
+
+private theorem ToricCharts.zeroCount_monomial {A B : Matrix (Fin 3) (Fin 3) ℤ} (hA : HeightOne A)
+    (hB : HeightOne B) (hAB : A * B = 1) (hBA : B * A = 1) {z : CoordinateSpace 3}
+    (hz : z ∈ domain A) : zeroCount (monomial A z) = zeroCount z := by
+  have hw := inverse_mapsTo_domain hA hBA hz
+  have he : monomial B (monomial A z) = z := monomial_inverse_on_overlap A B hBA ⟨hz, hw⟩
+  have hle := zeroCount_le_monomial hB hAB hw
+  rw [he] at hle
+  exact le_antisymm hle (zeroCount_le_monomial hA hBA hz)
+
+private theorem ToricCharts.zeroCount_mul (u z : CoordinateSpace 3) (hu : ∀ j, u j ≠ 0) :
+    zeroCount (u * z) = zeroCount z := by
+  apply Nat.card_congr
+  exact
+    Equiv.subtypeEquivRight (fun j => by simp only [Pi.mul_apply, mul_eq_zero, hu j, false_or])
+
+private theorem ToricFan.Triangle.zeroCount_chartChange (s t : ToricFan.Triangle)
+    {z : ToricCharts.CoordinateSpace 3} (hz : z ∈ (chartChange s t).source) :
+    ToricCharts.zeroCount (chartChange s t z) = ToricCharts.zeroCount z := by
+  apply
+    ToricCharts.zeroCount_monomial (transition_heightOne s t) (transition_heightOne t s)
+      (by rw [transition_mul, transition_self]) (by rw [transition_mul, transition_self])
+  simpa only [chartChange_source] using hz
+
+private theorem ToricFan.Triangle.origin_mem_chartChange_source (s t : ToricFan.Triangle) :
+    (0 : ToricCharts.CoordinateSpace 3) ∈ (chartChange s t).source ↔ s = t := by
+  constructor
+  · intro hz
+    rw [chartChange_source] at hz
+    have hn (i j : Fin 3) : 0 ≤ transition s t i j := by
+      by_contra h
+      exact hz i j (lt_of_not_ge h) rfl
+    have h00 := hn 0 0
+    have h01 := hn 0 1
+    have h02 := hn 0 2
+    have h10 := hn 1 0
+    have h11 := hn 1 1
+    have h12 := hn 1 2
+    have h20 := hn 2 0
+    have h21 := hn 2 1
+    have h22 := hn 2 2
+    cases hs : s.upper <;> cases ht : t.upper
+    all_goals
+      simp [transition, dual, rays, hs, ht, Matrix.mul_apply,
+        Fin.sum_univ_succ] at h00 h01 h02 h10 h11 h12 h20 h21 h22
+    all_goals
+      first
+      | omega
+      | apply ToricFan.Triangle.ext
+        · omega
+        · omega
+        · simp [hs, ht]
+  · rintro rfl
+    rw [chartChange_self_source]
+    exact Set.mem_univ _
+
+private def ToricSpace.branchCount (x : Space) : ℕ :=
+  ToricCharts.zeroCount ((parametrization (preferredTriangle x)).symm x)
+
+private theorem ToricSpace.branchCount_inclusion (s : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) :
+    branchCount (ToricSpace.inclusion s z) = ToricCharts.zeroCount z := by
+  have he :=
+    parametrization_transition s (preferredTriangle (ToricSpace.inclusion s z))
+      (preferred_mem (ToricSpace.inclusion s z))
+  unfold branchCount
+  rw [he.2]
+  exact ToricFan.Triangle.zeroCount_chartChange s _ he.1
+
+private theorem ToricSpace.branchCount_pos_iff (x : Space) : 0 < branchCount x ↔ time x = 0 := by
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  rw [branchCount_inclusion, ToricCharts.zeroCount_pos_iff, time_inclusion]
+
+private theorem ToricSpace.inclusion_origin_injective (s t : ToricFan.Triangle) :
+    ToricSpace.inclusion s 0 = ToricSpace.inclusion t 0 ↔ s = t := by
+  constructor
+  · intro he
+    exact
+      (ToricFan.Triangle.origin_mem_chartChange_source s t).mp
+        ((inclusion_eq_iff s t 0 0).mp he).1
+  · rintro rfl
+    rfl
+
+private theorem
+    ToricSpace.twistedTranslate_origin (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ)
+    (s : ToricFan.Triangle) :
+    twistedTranslate C v (ToricSpace.inclusion s 0) =
+      ToricSpace.inclusion (s.shift (cuspVector v)) 0 := by
+  simp [twistedTranslate, translate_inclusion, variableMultiplier, scale]
+
+@[simp]
+private theorem ToricSpace.branchCount_translate (v : Fin 2 → ℤ) (x : Space) :
+    branchCount (ToricSpace.translate v x) = branchCount x := by
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  rw [translate_inclusion, branchCount_inclusion, branchCount_inclusion]
+
+@[simp]
+private theorem ToricSpace.branchCount_torusAction (u : ActingTorus) (x : Space) :
+    branchCount (torusAction u x) = branchCount x := by
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  rw [torusAction_inclusion, branchCount_inclusion, branchCount_inclusion]
+  exact ToricCharts.zeroCount_mul (factors s u) z (factors_nonzero s u)
+
+@[simp]
+private theorem
+    ToricSpace.branchCount_twistedTranslate (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ)
+    (x : Space) : branchCount (twistedTranslate C v x) = branchCount x := by
+  simp [twistedTranslate, variableMultiplier]
+
+private def ToricFan.Triangle.vertex (s : ToricFan.Triangle) (j : Fin 3) : Fin 2 → ℤ := fun i =>
+  s.rays i.castSucc j
+
+private theorem ToricFan.Triangle.vertex_eq_iff (s t : ToricFan.Triangle) (j k : Fin 3) :
+    s.vertex j = t.vertex k ↔ ∀ i, s.rays i j = t.rays i k := by
+  constructor
+  · intro h i
+    fin_cases i
+    · exact congrFun h 0
+    · exact congrFun h 1
+    · simp
+  · intro h
+    funext i
+    exact h i.castSucc
+
+private theorem ToricFan.Triangle.vertex_injective (s : ToricFan.Triangle) :
+    Function.Injective s.vertex := by
+  intro j k h
+  exact ToricCharts.equal_columns_of_left_inverse s.dual_rays ((vertex_eq_iff s s j k).mp h)
+
+private theorem
+    ToricFan.Triangle.transition_column_iff_vertex (s t : ToricFan.Triangle) (j k : Fin 3) :
+    (∀ i, transition s t i j = if i = k then 1 else 0) ↔ s.vertex j = t.vertex k := by
+  rw [vertex_eq_iff]
+  constructor
+  · intro h i
+    have hc := congrFun (congrFun (transition_covariance s t) i) j
+    simpa only [Matrix.mul_apply, h, mul_ite, mul_one, MulZeroClass.mul_zero, Finset.sum_ite_eq',
+      Finset.mem_univ, ite_true] using hc.symm
+  · intro h i
+    have hc := congrFun (congrFun t.dual_rays i) k
+    simpa only [transition, Matrix.mul_apply, h, Matrix.one_apply] using hc
+
+@[simp]
+private theorem ToricFan.Triangle.vertex_shift (s : ToricFan.Triangle) (v : Fin 2 → ℤ) (j : Fin 3) :
+    (s.shift v).vertex j = s.vertex j + v := by
+  ext i
+  cases hs : s.upper <;> fin_cases i <;> fin_cases j <;> simp [vertex, shift, rays, hs] <;> ring
+
+private def
+    ToricFan.Triangle.chartBranches (s : ToricFan.Triangle) (z : ToricCharts.CoordinateSpace 3) :
+    Set (Fin 2 → ℤ) :=
+  s.vertex '' {j | z j = 0}
+
+private theorem ToricFan.Triangle.chartBranches_finite (s : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) : (chartBranches s z).Finite :=
+  (Set.toFinite _).image _
+
+private theorem ToricFan.Triangle.chartBranches_ncard (s : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) : (chartBranches s z).ncard = ToricCharts.zeroCount z := by
+  rw [chartBranches, Set.ncard_image_of_injective _ (vertex_injective s)]
+  rfl
+
+private theorem ToricFan.Triangle.chartBranches_subset_change (s t : ToricFan.Triangle)
+    {z : ToricCharts.CoordinateSpace 3} (hz : z ∈ (chartChange s t).source) :
+    chartBranches s z ⊆ chartBranches t (chartChange s t z) := by
+  rintro v ⟨j, hj, rfl⟩
+  obtain ⟨k, hk⟩ :=
+    ToricCharts.column_single_of_zero (transition_heightOne s t)
+      (by simpa only [chartChange_source] using hz) hj
+  refine ⟨k, ToricCharts.monomial_zero_of_column_single hj hk, ?_⟩
+  exact ((transition_column_iff_vertex s t j k).mp hk).symm
+
+private theorem ToricFan.Triangle.chartBranches_change (s t : ToricFan.Triangle)
+    {z : ToricCharts.CoordinateSpace 3} (hz : z ∈ (chartChange s t).source) :
+    chartBranches t (chartChange s t z) = chartBranches s z := by
+  apply subset_antisymm
+  · have h := chartBranches_subset_change t s ((chartChange s t).map_source hz)
+    have hi : chartChange t s (chartChange s t z) = z := (chartChange s t).left_inv hz
+    rwa [hi] at h
+  · exact chartBranches_subset_change s t hz
+
+private theorem ToricFan.Triangle.chartBranches_mul (s : ToricFan.Triangle)
+    (u z : ToricCharts.CoordinateSpace 3) (hu : ∀ j, u j ≠ 0) :
+    chartBranches s (u * z) = chartBranches s z := by
+  unfold chartBranches
+  congr 1
+  ext j
+  simp [hu]
+
+private theorem ToricFan.Triangle.chartBranches_shift (s : ToricFan.Triangle) (v : Fin 2 → ℤ)
+    (z : ToricCharts.CoordinateSpace 3) :
+    chartBranches (s.shift v) z = (fun w => w + v) '' chartBranches s z := by
+  simp only [chartBranches, Set.image_image, vertex_shift]
+
+private def ToricSpace.branchVertices : Space → Set (Fin 2 → ℤ) :=
+  descend ToricFan.Triangle.chartBranches
+
+@[simp]
+private theorem ToricSpace.branchVertices_inclusion (s : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) :
+    branchVertices (ToricSpace.inclusion s z) = ToricFan.Triangle.chartBranches s z :=
+  descend_inclusion ToricFan.Triangle.chartBranches
+    (fun s t _ hz => ToricFan.Triangle.chartBranches_change s t hz) s z
+
+private theorem ToricSpace.branchVertices_finite (x : Space) : (branchVertices x).Finite :=
+  ToricFan.Triangle.chartBranches_finite _ _
+
+private theorem
+    ToricSpace.branchVertices_ncard (x : Space) : (branchVertices x).ncard = branchCount x :=
+  ToricFan.Triangle.chartBranches_ncard _ _
+
+private theorem ToricSpace.branchVertices_nonempty (x : Space) :
+    (branchVertices x).Nonempty ↔ time x = 0 := by
+  rw [← Set.ncard_pos (branchVertices_finite x), branchVertices_ncard, branchCount_pos_iff]
+
+private def ToricSpace.rayDivisor (v : Fin 2 → ℤ) : Set Space :=
+  {x | v ∈ branchVertices x}
+
+private theorem ToricSpace.mem_rayDivisor_inclusion (v : Fin 2 → ℤ) (s : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) :
+    ToricSpace.inclusion s z ∈ rayDivisor v ↔ ∃ j, z j = 0 ∧ s.vertex j = v := by
+  change v ∈ branchVertices (ToricSpace.inclusion s z) ↔ _
+  rw [branchVertices_inclusion]
+  rfl
+
+private theorem ToricSpace.mem_rayDivisor_vertex (s : ToricFan.Triangle) (j : Fin 3)
+    (z : ToricCharts.CoordinateSpace 3) :
+    ToricSpace.inclusion s z ∈ rayDivisor (s.vertex j) ↔ z j = 0 := by
+  rw [mem_rayDivisor_inclusion]
+  constructor
+  · rintro ⟨k, hk, he⟩
+    rwa [(ToricFan.Triangle.vertex_injective s) he] at hk
+  · intro hj
+    exact ⟨j, hj, rfl⟩
+
+private theorem ToricSpace.preimage_rayDivisor (v : Fin 2 → ℤ) (s : ToricFan.Triangle) :
+    ToricSpace.inclusion s ⁻¹' rayDivisor v = ⋃ j : Fin 3, {z | z j = 0 ∧ s.vertex j = v} := by
+  ext z
+  simp only [Set.mem_preimage, mem_rayDivisor_inclusion, Set.mem_iUnion, Set.mem_ofPred_eq]
+
+private theorem ToricSpace.rayDivisor_isClosed (v : Fin 2 → ℤ) : IsClosed (rayDivisor v) := by
+  rw [← isOpen_compl_iff, gluing.isOpen_iff]
+  change ∀ s : ToricFan.Triangle, IsOpen (ToricSpace.inclusion s ⁻¹' (rayDivisor v)ᶜ)
+  intro s
+  rw [Set.preimage_compl, isOpen_compl_iff, preimage_rayDivisor]
+  apply isClosed_iUnion_of_finite
+  intro j
+  exact (isClosed_eq (continuous_apply j) continuous_const).inter isClosed_const
+
+private theorem ToricSpace.time_eq_zero_of_mem_rayDivisor {v : Fin 2 → ℤ} {x : Space}
+    (hx : x ∈ rayDivisor v) : time x = 0 :=
+  (branchVertices_nonempty x).mp ⟨v, hx⟩
+
+private theorem
+    ToricSpace.central_fibre_eq_rayDivisors : time ⁻¹' {0} = ⋃ v : Fin 2 → ℤ, rayDivisor v := by
+  ext x
+  simp only [Set.mem_preimage, Set.mem_singleton_iff, Set.mem_iUnion, rayDivisor,
+    Set.mem_ofPred_eq, ← branchVertices_nonempty, Set.nonempty_def]
+
+private theorem ToricSpace.branchVertices_translate (v : Fin 2 → ℤ) (x : Space) :
+    branchVertices (ToricSpace.translate v x) = (fun w => w + v) '' branchVertices x := by
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  rw [translate_inclusion, branchVertices_inclusion, branchVertices_inclusion,
+    ToricFan.Triangle.chartBranches_shift]
+
+private theorem ToricSpace.branchVertices_torusAction (u : ActingTorus) (x : Space) :
+    branchVertices (torusAction u x) = branchVertices x := by
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  rw [torusAction_inclusion, branchVertices_inclusion, branchVertices_inclusion]
+  exact ToricFan.Triangle.chartBranches_mul s (factors s u) z (factors_nonzero s u)
+
+private theorem ToricSpace.branchVertices_twistedTranslate (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (v : Fin 2 → ℤ) (x : Space) :
+    branchVertices (twistedTranslate C v x) = (fun w => w + cuspVector v) '' branchVertices x := by
+  simp only [twistedTranslate, variableMultiplier, branchVertices_torusAction,
+    branchVertices_translate]
+
+private theorem ToricSpace.twistedTranslate_mem_rayDivisor (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (v w : Fin 2 → ℤ) (x : Space) :
+    twistedTranslate C v x ∈ rayDivisor w ↔ x ∈ rayDivisor (w - cuspVector v) := by
+  change w ∈ branchVertices (twistedTranslate C v x) ↔ _
+  rw [branchVertices_twistedTranslate]
+  constructor
+  · rintro ⟨u, hu, he⟩
+    have : u = w - cuspVector v := eq_sub_iff_add_eq.mpr he
+    rwa [← this]
+  · intro hx
+    exact ⟨w - cuspVector v, hx, sub_add_cancel _ _⟩
+
+private def ToricComponent.insertZero (j : Fin 3) (z : ToricCharts.CoordinateSpace 2) :
+    ToricCharts.CoordinateSpace 3 :=
+  Fin.insertNth j 0 z
+
+private def ToricComponent.removeCoordinate (j : Fin 3) (z : ToricCharts.CoordinateSpace 3) :
+    ToricCharts.CoordinateSpace 2 :=
+  Fin.removeNth j z
+
+@[simp]
+private theorem ToricComponent.insertZero_at (j : Fin 3) (z : ToricCharts.CoordinateSpace 2) :
+    insertZero j z j = 0 :=
+  Fin.insertNth_apply_same (α := fun _ : Fin 3 => ℂ) j 0 z
+
+@[simp]
+private theorem ToricComponent.removeCoordinate_insertZero (j : Fin 3)
+    (z : ToricCharts.CoordinateSpace 2) : removeCoordinate j (insertZero j z) = z :=
+  Fin.removeNth_insertNth (α := fun _ : Fin 3 => ℂ) j 0 z
+
+private theorem
+    ToricComponent.insertZero_removeCoordinate (j : Fin 3) (z : ToricCharts.CoordinateSpace 3)
+    (hz : z j = 0) : insertZero j (removeCoordinate j z) = z :=
+  Fin.insertNth_eq_iff.mpr ⟨hz.symm, rfl⟩
+
+private theorem
+    ToricComponent.insertZero_holomorphic (j : Fin 3) : ContDiff ℂ ω (insertZero j) := by
+  apply contDiff_pi.mpr
+  intro k
+  obtain rfl | ⟨l, rfl⟩ := Fin.eq_self_or_eq_succAbove j k
+  · simpa only [insertZero_at] using
+      (contDiff_const : ContDiff ℂ ω (fun _ : ToricCharts.CoordinateSpace 2 => (0 : ℂ)))
+  · simpa only [insertZero, Fin.insertNth_apply_succAbove] using (contDiff_apply ℂ ℂ l)
+
+private theorem ToricComponent.removeCoordinate_holomorphic (j : Fin 3) :
+    ContDiff ℂ ω (removeCoordinate j) := by
+  apply contDiff_pi.mpr
+  intro i
+  exact contDiff_apply ℂ ℂ (j.succAbove i)
+
+private structure ToricComponent.ChartIndex (v : Fin 2 → ℤ) where
+  triangle : ToricFan.Triangle
+  coordinate : Fin 3
+  vertex_eq : triangle.vertex coordinate = v
+
+private theorem ToricComponent.insertZero_mem {v : Fin 2 → ℤ} (c : ChartIndex v)
+    (z : ToricCharts.CoordinateSpace 2) :
+    ToricSpace.inclusion c.triangle (insertZero c.coordinate z) ∈ ToricSpace.rayDivisor v := by
+  have h :=
+    (ToricSpace.mem_rayDivisor_vertex c.triangle c.coordinate (insertZero c.coordinate z)).mpr
+      (insertZero_at c.coordinate z)
+  simpa only [c.vertex_eq] using h
+
+private def ToricComponent.planeHomeomorph {v : Fin 2 → ℤ} (c : ChartIndex v) :
+    ToricCharts.CoordinateSpace 2 ≃ₜ
+      ToricSpace.inclusion c.triangle ⁻¹' ToricSpace.rayDivisor v := by
+  refine
+    { toFun := fun z => ⟨insertZero c.coordinate z, insertZero_mem c z⟩
+      invFun := fun w => removeCoordinate c.coordinate w
+      left_inv := fun z => removeCoordinate_insertZero c.coordinate z
+      right_inv := ?_
+      continuous_toFun := ?_
+      continuous_invFun := ?_ }
+  · intro w
+    apply Subtype.ext
+    apply insertZero_removeCoordinate
+    have hw :
+      ToricSpace.inclusion c.triangle (w : ToricCharts.CoordinateSpace 3) ∈
+        ToricSpace.rayDivisor v :=
+      w.2
+    exact
+      (ToricSpace.mem_rayDivisor_vertex c.triangle c.coordinate w).mp
+        (by simpa only [c.vertex_eq] using hw)
+  · exact (insertZero_holomorphic c.coordinate).continuous.subtype_mk _
+  · exact (removeCoordinate_holomorphic c.coordinate).continuous.comp continuous_subtype_val
+
+private def ToricComponent.affineInclusion {v : Fin 2 → ℤ} (c : ChartIndex v)
+    (z : ToricCharts.CoordinateSpace 2) : ToricSpace.rayDivisor v :=
+  ⟨ToricSpace.inclusion c.triangle (insertZero c.coordinate z), insertZero_mem c z⟩
+
+private theorem ToricComponent.affineInclusion_openEmbedding {v : Fin 2 → ℤ} (c : ChartIndex v) :
+    Topology.IsOpenEmbedding (affineInclusion c) :=
+  ((ToricSpace.inclusion_openEmbedding c.triangle).restrictPreimage
+        (ToricSpace.rayDivisor v)).comp
+    (planeHomeomorph c).isOpenEmbedding
+
+private theorem ToricComponent.affineInclusion_jointly_surjective {v : Fin 2 → ℤ}
+    (x : ToricSpace.rayDivisor v) :
+    ∃ c : ChartIndex v, ∃ z : ToricCharts.CoordinateSpace 2, affineInclusion c z = x := by
+  obtain ⟨s, z, hz⟩ := ToricSpace.inclusion_jointly_surjective (x : ToricSpace.Space)
+  have hx : ToricSpace.inclusion s z ∈ ToricSpace.rayDivisor v := by rw [hz]; exact x.2
+  obtain ⟨j, hj, hv⟩ := (ToricSpace.mem_rayDivisor_inclusion v s z).mp hx
+  refine ⟨⟨s, j, hv⟩, removeCoordinate j z, ?_⟩
+  apply Subtype.ext
+  change ToricSpace.inclusion s (insertZero j (removeCoordinate j z)) = (x : ToricSpace.Space)
+  rw [insertZero_removeCoordinate j z hj]
+  exact hz
+
+private def
+    CuspQuotient.branchCount (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) : QuotientSpace C ε → ℕ :=
+  Quotient.lift
+    (fun x : ToricSpace.Tube (disc ε) => ToricSpace.branchCount (x : ToricSpace.Space))
+    (by
+      let := ToricSpace.tubeAction C (disc ε)
+      intro x y h
+      change x ∈ MulAction.orbit LatticeGroup y at h
+      obtain ⟨g, rfl⟩ := h
+      exact ToricSpace.branchCount_twistedTranslate C g.toAdd y)
+
+private theorem
+    CuspQuotient.centralChartMap_origin_eq_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (s t : ToricFan.Triangle) :
+    centralChartMap C ε hε s centralOrigin = centralChartMap C ε hε t centralOrigin ↔
+      s.upper = t.upper := by
+  let := ToricSpace.tubeAction C (disc ε)
+  constructor
+  · intro he
+    have horb := Quotient.exact he
+    change
+      centralLift ε hε s centralOrigin ∈
+        MulAction.orbit LatticeGroup (centralLift ε hε t centralOrigin) at horb
+    obtain ⟨g, hg⟩ := horb
+    have he' :
+      ToricSpace.twistedTranslate C g.toAdd (ToricSpace.inclusion t 0) =
+        ToricSpace.inclusion s 0 :=
+      congrArg Subtype.val hg
+    rw [ToricSpace.twistedTranslate_origin] at he'
+    have hst := (ToricSpace.inclusion_origin_injective _ _).mp he'
+    exact (congrArg ToricFan.Triangle.upper hst).symm
+  · intro hst
+    rw [centralChartMap_origin_reference C ε hε s, centralChartMap_origin_reference C ε hε t, hst]
+
+@[simp]
+private theorem ToricSpace.cuspVector_neg (v : Fin 2 → ℤ) : cuspVector (-v) = -cuspVector v := by
+  ext i
+  fin_cases i <;> simp [cuspVector]
+
+@[simp]
+private theorem
+    ToricSpace.cuspVector_cuspVector (v : Fin 2 → ℤ) : cuspVector (cuspVector v) = -v := by
+  ext i
+  fin_cases i <;> simp [cuspVector]
+
+private theorem ToricSpace.cuspVector_injective : Function.Injective cuspVector := by
+  intro v w h
+  have h' := congrArg cuspVector h
+  simpa only [cuspVector_cuspVector, neg_inj] using h'
+
+private def CuspQuotient.componentLift (ε : ℝ) (hε : 0 < ε) (x : ToricSpace.rayDivisor 0) :
+    ToricSpace.Tube (disc ε) :=
+  ⟨x, by
+    change ToricSpace.time (x : ToricSpace.Space) ∈ Metric.ball 0 ε
+    rw [ToricSpace.time_eq_zero_of_mem_rayDivisor x.2]
+    simpa using hε⟩
+
+private theorem ToricSpace.rayDivisors_locallyFinite : LocallyFinite rayDivisor := by
+  intro x
+  let s := preferredTriangle x
+  refine
+    ⟨Set.range (ToricSpace.inclusion s),
+      (inclusion_openEmbedding s).isOpen_range.mem_nhds (preferred_mem x), ?_⟩
+  apply (Set.finite_range s.vertex).subset
+  rintro v ⟨y, hy, ⟨z, rfl⟩⟩
+  obtain ⟨j, _, hj⟩ := (mem_rayDivisor_inclusion v s z).mp hy
+  exact ⟨j, hj⟩
+
+private def
+    ToricSpace.centralTranslationHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (v : Fin 2 → ℤ) :
+    Space ≃ₜ Space :=
+  (translationHomeomorph (cuspVector v)).trans
+    (torusHomeomorph (fibreMultiplier (exponentialMultiplier C v 0)))
+
+private def ToricComponent.zeroTriangle : Fin 6 → ToricFan.Triangle :=
+  ![⟨0, 0, Bool.false⟩, ⟨-1, 0, Bool.true⟩, ⟨-1, 0, Bool.false⟩, ⟨-1, -1, Bool.true⟩,
+    ⟨0, -1, Bool.false⟩, ⟨0, -1, Bool.true⟩]
+
+private def ToricComponent.zeroCoordinate : Fin 6 → Fin 3 :=
+  ![0, 0, 1, 2, 2, 1]
+
+private theorem ToricComponent.zeroTriangle_vertex (i : Fin 6) :
+    (zeroTriangle i).vertex (zeroCoordinate i) = 0 := by fin_cases i <;> decide
+
+private def ToricComponent.zeroChart (i : Fin 6) : ChartIndex 0 :=
+  ⟨zeroTriangle i, zeroCoordinate i, zeroTriangle_vertex i⟩
+
+private theorem ToricComponent.zeroChart_surjective : Function.Surjective zeroChart := by
+  rintro ⟨⟨a, b, u⟩, j, hj⟩
+  have h0 := congrFun hj 0
+  have h1 := congrFun hj 1
+  cases u <;> fin_cases j
+  · change a = 0 at h0
+    change b = 0 at h1
+    subst a b
+    exact ⟨0, rfl⟩
+  · change a + 1 = 0 at h0
+    change b = 0 at h1
+    have ha : a = -1 := by omega
+    subst a b
+    exact ⟨2, rfl⟩
+  · change a = 0 at h0
+    change b + 1 = 0 at h1
+    have hb : b = -1 := by omega
+    subst a b
+    exact ⟨4, rfl⟩
+  · change a + 1 = 0 at h0
+    change b = 0 at h1
+    have ha : a = -1 := by omega
+    subst a b
+    exact ⟨1, rfl⟩
+  · change a = 0 at h0
+    change b + 1 = 0 at h1
+    have hb : b = -1 := by omega
+    subst a b
+    exact ⟨5, rfl⟩
+  · change a + 1 = 0 at h0
+    change b + 1 = 0 at h1
+    have ha : a = -1 := by omega
+    have hb : b = -1 := by omega
+    subst a b
+    exact ⟨3, rfl⟩
+
+private def ToricComponent.hexagonRay : Fin 6 → (Fin 2 → ℤ) :=
+  ![![1, 0], ![0, 1], ![-1, 1], ![-1, 0], ![0, -1], ![1, -1] ]
+
+private theorem ToricComponent.hexagonRay_injective : Function.Injective hexagonRay := by decide
+
+private theorem ToricComponent.hexagonRay_ne_zero (i : Fin 6) : hexagonRay i ≠ 0 := by
+  fin_cases i <;> decide
+
+private theorem
+    ToricComponent.hexagonRay_opposite (i : Fin 6) : hexagonRay (i + 3) = -hexagonRay i := by
+  fin_cases i <;> decide
+
+private def CuspHoneycombHexagon.vertex (i : Fin 6) : Plane := fun k =>
+  (ToricComponent.hexagonRay i k : ℝ)
+
+private def CuspHoneycombHexagon.midpoint (i : Fin 6) : Plane :=
+  (1 / 2 : ℝ) • (vertex (i - 1) + vertex i)
+
+private def CuspHoneycombHexagon.Hexagon : Set Plane :=
+  {x | |x 0| ≤ 1 ∧ |x 1| ≤ 1 ∧ |x 0 + x 1| ≤ 1}
+
+private def CuspHoneycombHexagon.sideFunctional (k : Fin 6) (x : Plane) : ℝ :=
+  ![x 0, x 0 + x 1, x 1, -x 0, -x 0 - x 1, -x 1] k
+
+private def CuspHoneycombHexagon.side (k : Fin 6) : Set Plane :=
+  {x | x ∈ Hexagon ∧ sideFunctional k x = 1}
+
+@[simp]
+private theorem CuspHoneycombHexagon.sideFunctional_zero (x : Plane) : sideFunctional 0 x = x 0 :=
+  rfl
+
+@[simp]
+private theorem
+    CuspHoneycombHexagon.sideFunctional_one (x : Plane) : sideFunctional 1 x = x 0 + x 1 :=
+  rfl
+
+@[simp]
+private theorem CuspHoneycombHexagon.sideFunctional_two (x : Plane) : sideFunctional 2 x = x 1 :=
+  rfl
+
+@[simp]
+private theorem CuspHoneycombHexagon.sideFunctional_three (x : Plane) : sideFunctional 3 x = -x 0 :=
+  rfl
+
+@[simp]
+private theorem
+    CuspHoneycombHexagon.sideFunctional_four (x : Plane) : sideFunctional 4 x = -x 0 - x 1 :=
+  rfl
+
+@[simp]
+private theorem CuspHoneycombHexagon.sideFunctional_five (x : Plane) : sideFunctional 5 x = -x 1 :=
+  rfl
+
+private def CuspHoneycombHexagon.cornerZero : Square :=
+  ⟨fun _ => 0, fun _ => ⟨le_rfl, zero_le_one⟩⟩
+
+private def CuspHoneycombHexagon.cornerOne : Square :=
+  ⟨fun _ => 1, fun _ => ⟨zero_le_one, le_rfl⟩⟩
+
+private def CuspHoneycombHexagon.tile (i : Fin 6) (p : Square) : Plane :=
+  (1 - Max.max (p.1 0) (p.1 1)) • vertex i +
+      Max.max (p.1 1 - p.1 0) 0 • CuspHoneycombHexagon.midpoint i +
+    Max.max (p.1 0 - p.1 1) 0 • CuspHoneycombHexagon.midpoint (i + 1)
+
+private theorem CuspHoneycombHexagon.tile_continuous (i : Fin 6) : Continuous (tile i) := by
+  have h0 : Continuous (fun p : Square => p.1 0) :=
+    (continuous_apply 0).comp continuous_subtype_val
+  have h1 : Continuous (fun p : Square => p.1 1) :=
+    (continuous_apply 1).comp continuous_subtype_val
+  exact
+    (((continuous_const.sub (h0.max h1)).smul continuous_const).add
+          (((h1.sub h0).max continuous_const).smul continuous_const)).add
+      (((h0.sub h1).max continuous_const).smul continuous_const)
+
+private theorem CuspHoneycombHexagon.tile_of_le (i : Fin 6) (p : Square) (hp : p.1 0 ≤ p.1 1) :
+    tile i p = (1 - p.1 1) • vertex i + (p.1 1 - p.1 0) • CuspHoneycombHexagon.midpoint i := by
+  simp only [tile, max_eq_right hp, max_eq_left (sub_nonneg.mpr hp),
+    max_eq_right (sub_nonpos.mpr hp), zero_smul, add_zero]
+
+private theorem CuspHoneycombHexagon.tile_of_ge (i : Fin 6) (p : Square) (hp : p.1 1 ≤ p.1 0) :
+    tile i p = (1 - p.1 0) • vertex i + (p.1 0 - p.1 1) • CuspHoneycombHexagon.midpoint (i + 1) :=
+  by
+  simp only [tile, max_eq_left hp, max_eq_right (sub_nonpos.mpr hp),
+    max_eq_left (sub_nonneg.mpr hp), zero_smul, add_zero]
+
+private theorem CuspHoneycombHexagon.tile_fst_one (i : Fin 6) (p : Square) (hp : p.1 0 = 1) :
+    tile i p = (1 - p.1 1) • CuspHoneycombHexagon.midpoint (i + 1) := by
+  rw [tile_of_ge i p (by simpa only [hp] using (p.2 1).2)]
+  simp only [hp, sub_self, zero_smul, zero_add]
+
+private theorem CuspHoneycombHexagon.tile_fst_zero (i : Fin 6) (p : Square) (hp : p.1 0 = 0) :
+    tile i p = (1 - p.1 1) • vertex i + p.1 1 • CuspHoneycombHexagon.midpoint i := by
+  rw [tile_of_le i p (by simpa only [hp] using (p.2 1).1)]
+  simp only [hp, sub_zero]
+
+@[simp]
+private theorem
+    CuspHoneycombHexagon.tile_cornerZero (i : Fin 6) : tile i cornerZero = vertex i := by
+  rw [tile_fst_zero i cornerZero rfl]
+  simp only [cornerZero, sub_zero, one_smul, zero_smul, add_zero]
+
+@[simp]
+private theorem CuspHoneycombHexagon.tile_cornerOne (i : Fin 6) : tile i cornerOne = 0 := by
+  rw [tile_fst_one i cornerOne rfl]
+  simp only [cornerOne, sub_self, zero_smul]
+
+@[simp]
+private theorem CuspHoneycombHexagon.vertex_zero : vertex 0 = ![1, 0] := by
+  funext k
+  fin_cases k
+  · change ((1 : ℤ) : ℝ) = 1
+    norm_num
+  · change ((0 : ℤ) : ℝ) = 0
+    norm_num
+
+@[simp]
+private theorem CuspHoneycombHexagon.vertex_one : vertex 1 = ![0, 1] := by
+  funext k
+  fin_cases k
+  · change ((0 : ℤ) : ℝ) = 0
+    norm_num
+  · change ((1 : ℤ) : ℝ) = 1
+    norm_num
+
+@[simp]
+private theorem CuspHoneycombHexagon.vertex_two : vertex 2 = ![-1, 1] := by
+  funext k
+  fin_cases k
+  · change ((-1 : ℤ) : ℝ) = -1
+    norm_num
+  · change ((1 : ℤ) : ℝ) = 1
+    norm_num
+
+@[simp]
+private theorem CuspHoneycombHexagon.vertex_three : vertex 3 = ![-1, 0] := by
+  funext k
+  fin_cases k
+  · change ((-1 : ℤ) : ℝ) = -1
+    norm_num
+  · change ((0 : ℤ) : ℝ) = 0
+    norm_num
+
+@[simp]
+private theorem CuspHoneycombHexagon.vertex_four : vertex 4 = ![0, -1] := by
+  funext k
+  fin_cases k
+  · change ((0 : ℤ) : ℝ) = 0
+    norm_num
+  · change ((-1 : ℤ) : ℝ) = -1
+    norm_num
+
+@[simp]
+private theorem CuspHoneycombHexagon.vertex_five : vertex 5 = ![1, -1] := by
+  funext k
+  fin_cases k
+  · change ((1 : ℤ) : ℝ) = 1
+    norm_num
+  · change ((-1 : ℤ) : ℝ) = -1
+    norm_num
+
+private def CuspHoneycombHexagon.rotate : Plane ≃ₗ[ℝ] Plane
+    where
+  toFun x := ![-x 1, x 0 + x 1]
+  invFun x := ![x 0 + x 1, -x 0]
+  left_inv
+    x := by
+    funext k
+    fin_cases k <;> simp
+  right_inv
+    x := by
+    funext k
+    fin_cases k <;> simp
+  map_add' x
+    y := by
+    funext k
+    fin_cases k <;> simp <;> ring
+  map_smul' r
+    x := by
+    funext k
+    fin_cases k <;> simp; ring
+
+@[simp]
+private theorem
+    CuspHoneycombHexagon.rotate_vertex (i : Fin 6) : rotate (vertex i) = vertex (i + 1) := by
+  have hr :
+    ∀ i : Fin 6,
+      ToricComponent.hexagonRay (i + 1) 0 = -ToricComponent.hexagonRay i 1 ∧
+        ToricComponent.hexagonRay (i + 1) 1 =
+          ToricComponent.hexagonRay i 0 + ToricComponent.hexagonRay i 1 := by decide
+  funext k
+  fin_cases k
+  · change -(ToricComponent.hexagonRay i 1 : ℝ) = (ToricComponent.hexagonRay (i + 1) 0 : ℝ)
+    rw [(hr i).1, Int.cast_neg]
+  · change
+      (ToricComponent.hexagonRay i 0 : ℝ) + (ToricComponent.hexagonRay i 1 : ℝ) =
+        (ToricComponent.hexagonRay (i + 1) 1 : ℝ)
+    rw [(hr i).2, Int.cast_add]
+
+@[simp]
+private theorem CuspHoneycombHexagon.rotate_midpoint (i : Fin 6) :
+    rotate (CuspHoneycombHexagon.midpoint i) = CuspHoneycombHexagon.midpoint (i + 1) := by
+  simp only [CuspHoneycombHexagon.midpoint, map_smul, map_add, rotate_vertex, sub_add_cancel,
+    add_sub_cancel_right]
+
+@[simp]
+private theorem CuspHoneycombHexagon.rotate_tile (i : Fin 6) (p : Square) :
+    rotate (tile i p) = tile (i + 1) p := by
+  simp only [tile, map_add, map_smul, rotate_vertex, rotate_midpoint]
+
+private theorem CuspHoneycombHexagon.sector_formula_0 (α β : ℝ) :
+    α • vertex 0 + β • vertex (0 + 1) = ![α, β] := by
+  ext k
+  fin_cases k
+  · change α * ((1 : ℤ) : ℝ) + β * ((0 : ℤ) : ℝ) = α
+    norm_num [sub_eq_add_neg]
+  · change α * ((0 : ℤ) : ℝ) + β * ((1 : ℤ) : ℝ) = β
+    norm_num [sub_eq_add_neg]
+
+private theorem CuspHoneycombHexagon.sector_formula_1 (α β : ℝ) :
+    α • vertex 1 + β • vertex (1 + 1) = ![-β, α + β] := by
+  ext k
+  fin_cases k
+  · change α * ((0 : ℤ) : ℝ) + β * ((-1 : ℤ) : ℝ) = -β
+    norm_num [sub_eq_add_neg]
+  · change α * ((1 : ℤ) : ℝ) + β * ((1 : ℤ) : ℝ) = α + β
+    norm_num [sub_eq_add_neg]
+
+private theorem CuspHoneycombHexagon.sector_formula_2 (α β : ℝ) :
+    α • vertex 2 + β • vertex (2 + 1) = ![-α - β, α] := by
+  ext k
+  fin_cases k
+  · change α * ((-1 : ℤ) : ℝ) + β * ((-1 : ℤ) : ℝ) = -α - β
+    norm_num [sub_eq_add_neg]
+  · change α * ((1 : ℤ) : ℝ) + β * ((0 : ℤ) : ℝ) = α
+    norm_num [sub_eq_add_neg]
+
+private theorem CuspHoneycombHexagon.sector_formula_3 (α β : ℝ) :
+    α • vertex 3 + β • vertex (3 + 1) = ![-α, -β] := by
+  ext k
+  fin_cases k
+  · change α * ((-1 : ℤ) : ℝ) + β * ((0 : ℤ) : ℝ) = -α
+    norm_num [sub_eq_add_neg]
+  · change α * ((0 : ℤ) : ℝ) + β * ((-1 : ℤ) : ℝ) = -β
+    norm_num [sub_eq_add_neg]
+
+private theorem CuspHoneycombHexagon.sector_formula_4 (α β : ℝ) :
+    α • vertex 4 + β • vertex (4 + 1) = ![β, -α - β] := by
+  ext k
+  fin_cases k
+  · change α * ((0 : ℤ) : ℝ) + β * ((1 : ℤ) : ℝ) = β
+    norm_num [sub_eq_add_neg]
+  · change α * ((-1 : ℤ) : ℝ) + β * ((-1 : ℤ) : ℝ) = -α - β
+    norm_num [sub_eq_add_neg]
+
+private theorem CuspHoneycombHexagon.sector_formula_5 (α β : ℝ) :
+    α • vertex 5 + β • vertex (5 + 1) = ![α + β, -α] := by
+  ext k
+  fin_cases k
+  · change α * ((1 : ℤ) : ℝ) + β * ((1 : ℤ) : ℝ) = α + β
+    norm_num [sub_eq_add_neg]
+  · change α * ((-1 : ℤ) : ℝ) + β * ((0 : ℤ) : ℝ) = -α
+    norm_num [sub_eq_add_neg]
+
+private theorem CuspHoneycombHexagon.sector_decomposition {x : Plane} (hx : x ∈ Hexagon) :
+    ∃ i : Fin 6, ∃ α β : ℝ, 0 ≤ α ∧ 0 ≤ β ∧ α + β ≤ 1 ∧ x = α • vertex i + β • vertex (i + 1) := by
+  obtain ⟨h0, h1, h01⟩ := hx
+  obtain ⟨h0l, h0u⟩ := abs_le.mp h0
+  obtain ⟨h1l, h1u⟩ := abs_le.mp h1
+  obtain ⟨h01l, h01u⟩ := abs_le.mp h01
+  by_cases ha : 0 ≤ x 0
+  · by_cases hb : 0 ≤ x 1
+    · refine ⟨0, x 0, x 1, ha, hb, h01u, ?_⟩
+      rw [sector_formula_0]
+      exact funext (Fin.forall_fin_two.mpr ⟨rfl, rfl⟩)
+    · by_cases hab : 0 ≤ x 0 + x 1
+      · refine ⟨5, -x 1, x 0 + x 1, ?_, hab, ?_, ?_⟩
+        · linarith
+        · linarith
+        · rw [sector_formula_5]
+          refine funext (Fin.forall_fin_two.mpr ⟨?_, ?_⟩) <;>
+              simp only [Matrix.cons_val_zero, Matrix.cons_val_one] <;>
+            ring
+      · refine ⟨4, -(x 0 + x 1), x 0, ?_, ha, ?_, ?_⟩
+        · linarith
+        · linarith
+        · rw [sector_formula_4]
+          refine funext (Fin.forall_fin_two.mpr ⟨?_, ?_⟩) <;>
+            simp only [Matrix.cons_val_zero, Matrix.cons_val_one];
+          ring
+  · by_cases hb : 0 ≤ x 1
+    · by_cases hab : 0 ≤ x 0 + x 1
+      · refine ⟨1, x 0 + x 1, -x 0, hab, ?_, ?_, ?_⟩
+        · linarith
+        · linarith
+        · rw [sector_formula_1]
+          refine funext (Fin.forall_fin_two.mpr ⟨?_, ?_⟩) <;>
+              simp only [Matrix.cons_val_zero, Matrix.cons_val_one] <;>
+            ring
+      · refine ⟨2, x 1, -(x 0 + x 1), hb, ?_, ?_, ?_⟩
+        · linarith
+        · linarith
+        · rw [sector_formula_2]
+          refine funext (Fin.forall_fin_two.mpr ⟨?_, ?_⟩) <;>
+            simp only [Matrix.cons_val_zero, Matrix.cons_val_one];
+          ring
+    · refine ⟨3, -x 0, -x 1, ?_, ?_, ?_, ?_⟩
+      · linarith
+      · linarith
+      · linarith
+      · rw [sector_formula_3]
+        refine funext (Fin.forall_fin_two.mpr ⟨?_, ?_⟩) <;>
+            simp only [Matrix.cons_val_zero, Matrix.cons_val_one] <;>
+          ring
+
+private theorem
+    CuspHoneycombHexagon.sector_mem_hexagon (i : Fin 6) {α β : ℝ} (hα : 0 ≤ α) (hβ : 0 ≤ β)
+    (hαβ : α + β ≤ 1) : α • vertex i + β • vertex (i + 1) ∈ Hexagon := by
+  fin_cases i
+  · change α • vertex 0 + β • vertex (0 + 1) ∈ Hexagon
+    rw [sector_formula_0]
+    simp only [Hexagon, Set.mem_ofPred_eq, Matrix.cons_val_zero, Matrix.cons_val_one, abs_le]
+    refine ⟨⟨?_, ?_⟩, ⟨?_, ?_⟩, ?_, ?_⟩ <;> linarith
+  · change α • vertex 1 + β • vertex (1 + 1) ∈ Hexagon
+    rw [sector_formula_1]
+    simp only [Hexagon, Set.mem_ofPred_eq, Matrix.cons_val_zero, Matrix.cons_val_one, abs_le]
+    refine ⟨⟨?_, ?_⟩, ⟨?_, ?_⟩, ?_, ?_⟩ <;> linarith
+  · change α • vertex 2 + β • vertex (2 + 1) ∈ Hexagon
+    rw [sector_formula_2]
+    simp only [Hexagon, Set.mem_ofPred_eq, Matrix.cons_val_zero, Matrix.cons_val_one, abs_le]
+    refine ⟨⟨?_, ?_⟩, ⟨?_, ?_⟩, ?_, ?_⟩ <;> linarith
+  · change α • vertex 3 + β • vertex (3 + 1) ∈ Hexagon
+    rw [sector_formula_3]
+    simp only [Hexagon, Set.mem_ofPred_eq, Matrix.cons_val_zero, Matrix.cons_val_one, abs_le]
+    refine ⟨⟨?_, ?_⟩, ⟨?_, ?_⟩, ?_, ?_⟩ <;> linarith
+  · change α • vertex 4 + β • vertex (4 + 1) ∈ Hexagon
+    rw [sector_formula_4]
+    simp only [Hexagon, Set.mem_ofPred_eq, Matrix.cons_val_zero, Matrix.cons_val_one, abs_le]
+    refine ⟨⟨?_, ?_⟩, ⟨?_, ?_⟩, ?_, ?_⟩ <;> linarith
+  · change α • vertex 5 + β • vertex (5 + 1) ∈ Hexagon
+    rw [sector_formula_5]
+    simp only [Hexagon, Set.mem_ofPred_eq, Matrix.cons_val_zero, Matrix.cons_val_one, abs_le]
+    refine ⟨⟨?_, ?_⟩, ⟨?_, ?_⟩, ?_, ?_⟩ <;> linarith
+
+private theorem CuspHoneycombHexagon.tile_zero_le (p : Square) (h : p.1 0 ≤ p.1 1) :
+    tile 0 p = ![1 - p.1 0, (p.1 0 - p.1 1) / 2] := by
+  rw [tile_of_le 0 p h]
+  have hindex : (0 : Fin 6) - 1 = 5 := by decide
+  rw [CuspHoneycombHexagon.midpoint, hindex, vertex_five, vertex_zero]
+  ext k
+  fin_cases k <;> norm_num; ring
+
+private theorem CuspHoneycombHexagon.tile_zero_ge (p : Square) (h : p.1 1 ≤ p.1 0) :
+    tile 0 p = ![1 - (p.1 0 + p.1 1) / 2, (p.1 0 - p.1 1) / 2] := by
+  rw [tile_of_ge 0 p h]
+  have hadd : (0 : Fin 6) + 1 = 1 := by decide
+  have hindex : (1 : Fin 6) - 1 = 0 := by decide
+  rw [hadd, CuspHoneycombHexagon.midpoint, hindex, vertex_zero, vertex_one]
+  ext k
+  fin_cases k <;> norm_num <;> ring
+
+private theorem CuspHoneycombHexagon.tile_one_le (p : Square) (h : p.1 0 ≤ p.1 1) :
+    tile 1 p = ![(p.1 1 - p.1 0) / 2, 1 - (p.1 0 + p.1 1) / 2] := by
+  rw [tile_of_le 1 p h]
+  have hindex : (1 : Fin 6) - 1 = 0 := by decide
+  rw [CuspHoneycombHexagon.midpoint, hindex, vertex_zero, vertex_one]
+  ext k
+  fin_cases k <;> norm_num <;> ring
+
+private theorem CuspHoneycombHexagon.tile_one_ge (p : Square) (h : p.1 1 ≤ p.1 0) :
+    tile 1 p = ![(p.1 1 - p.1 0) / 2, 1 - p.1 1] := by
+  rw [tile_of_ge 1 p h]
+  have hadd : (1 : Fin 6) + 1 = 2 := by decide
+  have hindex : (2 : Fin 6) - 1 = 1 := by decide
+  rw [hadd, CuspHoneycombHexagon.midpoint, hindex, vertex_one, vertex_two]
+  ext k
+  fin_cases k <;> norm_num; ring
+
+private theorem CuspHoneycombHexagon.tile_two_le (p : Square) (h : p.1 0 ≤ p.1 1) :
+    tile 2 p = ![(p.1 0 + p.1 1) / 2 - 1, 1 - p.1 0] := by
+  rw [tile_of_le 2 p h]
+  have hindex : (2 : Fin 6) - 1 = 1 := by decide
+  rw [CuspHoneycombHexagon.midpoint, hindex, vertex_one, vertex_two]
+  ext k
+  fin_cases k <;> norm_num; ring
+
+private theorem CuspHoneycombHexagon.tile_two_ge (p : Square) (h : p.1 1 ≤ p.1 0) :
+    tile 2 p = ![p.1 1 - 1, 1 - (p.1 0 + p.1 1) / 2] := by
+  rw [tile_of_ge 2 p h]
+  have hadd : (2 : Fin 6) + 1 = 3 := by decide
+  have hindex : (3 : Fin 6) - 1 = 2 := by decide
+  rw [hadd, CuspHoneycombHexagon.midpoint, hindex, vertex_two, vertex_three]
+  ext k
+  fin_cases k <;> norm_num; ring
+
+private theorem CuspHoneycombHexagon.tile_three_le (p : Square) (h : p.1 0 ≤ p.1 1) :
+    tile 3 p = ![p.1 0 - 1, (p.1 1 - p.1 0) / 2] := by
+  rw [tile_of_le 3 p h]
+  have hindex : (3 : Fin 6) - 1 = 2 := by decide
+  rw [CuspHoneycombHexagon.midpoint, hindex, vertex_two, vertex_three]
+  ext k
+  fin_cases k <;> norm_num; ring
+
+private theorem CuspHoneycombHexagon.tile_three_ge (p : Square) (h : p.1 1 ≤ p.1 0) :
+    tile 3 p = ![(p.1 0 + p.1 1) / 2 - 1, (p.1 1 - p.1 0) / 2] := by
+  rw [tile_of_ge 3 p h]
+  have hadd : (3 : Fin 6) + 1 = 4 := by decide
+  have hindex : (4 : Fin 6) - 1 = 3 := by decide
+  rw [hadd, CuspHoneycombHexagon.midpoint, hindex, vertex_three, vertex_four]
+  ext k
+  fin_cases k <;> norm_num <;> ring
+
+private theorem CuspHoneycombHexagon.tile_four_le (p : Square) (h : p.1 0 ≤ p.1 1) :
+    tile 4 p = ![(p.1 0 - p.1 1) / 2, (p.1 0 + p.1 1) / 2 - 1] := by
+  rw [tile_of_le 4 p h]
+  have hindex : (4 : Fin 6) - 1 = 3 := by decide
+  rw [CuspHoneycombHexagon.midpoint, hindex, vertex_three, vertex_four]
+  ext k
+  fin_cases k <;> norm_num <;> ring
+
+private theorem CuspHoneycombHexagon.tile_four_ge (p : Square) (h : p.1 1 ≤ p.1 0) :
+    tile 4 p = ![(p.1 0 - p.1 1) / 2, p.1 1 - 1] := by
+  rw [tile_of_ge 4 p h]
+  have hadd : (4 : Fin 6) + 1 = 5 := by decide
+  have hindex : (5 : Fin 6) - 1 = 4 := by decide
+  rw [hadd, CuspHoneycombHexagon.midpoint, hindex, vertex_four, vertex_five]
+  ext k
+  fin_cases k <;> norm_num; ring
+
+private theorem CuspHoneycombHexagon.tile_five_le (p : Square) (h : p.1 0 ≤ p.1 1) :
+    tile 5 p = ![1 - (p.1 0 + p.1 1) / 2, p.1 0 - 1] := by
+  rw [tile_of_le 5 p h]
+  have hindex : (5 : Fin 6) - 1 = 4 := by decide
+  rw [CuspHoneycombHexagon.midpoint, hindex, vertex_four, vertex_five]
+  ext k
+  fin_cases k <;> norm_num; ring
+
+private theorem CuspHoneycombHexagon.tile_five_ge (p : Square) (h : p.1 1 ≤ p.1 0) :
+    tile 5 p = ![1 - p.1 1, (p.1 0 + p.1 1) / 2 - 1] := by
+  rw [tile_of_ge 5 p h]
+  have hadd : (5 : Fin 6) + 1 = 0 := by decide
+  have hindex : (0 : Fin 6) - 1 = 5 := by decide
+  rw [hadd, CuspHoneycombHexagon.midpoint, hindex, vertex_five, vertex_zero]
+  ext k
+  fin_cases k <;> norm_num; ring
+
+private theorem CuspHoneycombHexagon.eq_cornerOne_iff (p : Square) :
+    p = cornerOne ↔ p.1 0 = 1 ∧ p.1 1 = 1 := by
+  constructor
+  · rintro rfl
+    exact ⟨rfl, rfl⟩
+  · rintro ⟨h0, h1⟩
+    apply Subtype.ext
+    ext k
+    fin_cases k <;> assumption
+
+private theorem CuspHoneycombHexagon.tile_zero_eq_one_iff (p q : Square) :
+    tile 0 p = tile 1 q ↔ p.1 0 = 1 ∧ q.1 1 = 1 ∧ q.1 0 = p.1 1 := by
+  constructor
+  · intro h
+    have hp0 := (p.property 0).2
+    have hp1 := (p.property 1).2
+    have hq0 := (q.property 0).2
+    have hq1 := (q.property 1).2
+    rcases le_total (p.1 0) (p.1 1) with hp | hp <;> rcases le_total (q.1 0) (q.1 1) with hq | hq
+    all_goals
+      first
+      | rw [tile_zero_le p hp] at h
+      | rw [tile_zero_ge p hp] at h
+      first
+      | rw [tile_one_le q hq] at h
+      | rw [tile_one_ge q hq] at h
+      have hx := congrFun h 0
+      have hy := congrFun h 1
+      simp only [Matrix.cons_val_zero, Matrix.cons_val_one] at hx hy
+      refine ⟨?_, ?_, ?_⟩ <;> linarith only [hp, hq, hx, hy, hp0, hp1, hq0, hq1]
+  · rintro ⟨hp, hq, hqp⟩
+    have hp' : p.1 1 ≤ p.1 0 := by simpa only [hp] using (p.property 1).2
+    have hq' : q.1 0 ≤ q.1 1 := by simpa only [hq] using (q.property 0).2
+    rw [tile_zero_ge p hp', tile_one_le q hq']
+    ext k
+    fin_cases k <;> simp [hp, hq, hqp] <;> ring
+
+private theorem CuspHoneycombHexagon.tile_zero_eq_five_iff (p q : Square) :
+    tile 0 p = tile 5 q ↔ p.1 1 = 1 ∧ q.1 0 = 1 ∧ p.1 0 = q.1 1 := by
+  constructor
+  · intro h
+    have hp0 := (p.property 0).2
+    have hp1 := (p.property 1).2
+    have hq0 := (q.property 0).2
+    have hq1 := (q.property 1).2
+    rcases le_total (p.1 0) (p.1 1) with hp | hp <;> rcases le_total (q.1 0) (q.1 1) with hq | hq
+    all_goals
+      first
+      | rw [tile_zero_le p hp] at h
+      | rw [tile_zero_ge p hp] at h
+      first
+      | rw [tile_five_le q hq] at h
+      | rw [tile_five_ge q hq] at h
+      have hx := congrFun h 0
+      have hy := congrFun h 1
+      simp only [Matrix.cons_val_zero, Matrix.cons_val_one] at hx hy
+      refine ⟨?_, ?_, ?_⟩ <;> linarith only [hp, hq, hx, hy, hp0, hp1, hq0, hq1]
+  · rintro ⟨hp, hq, hpq⟩
+    have hp' : p.1 0 ≤ p.1 1 := by simpa only [hp] using (p.property 0).2
+    have hq' : q.1 1 ≤ q.1 0 := by simpa only [hq] using (q.property 1).2
+    rw [tile_zero_le p hp', tile_five_ge q hq']
+    ext k
+    fin_cases k <;> simp [hp, hq, hpq]; ring
+
+private theorem CuspHoneycombHexagon.tile_zero_eq_two_iff (p q : Square) :
+    tile 0 p = tile 2 q ↔ p = cornerOne ∧ q = cornerOne := by
+  constructor
+  · intro h
+    have hp0 := (p.property 0).2
+    have hp1 := (p.property 1).2
+    have hq0 := (q.property 0).2
+    have hq1 := (q.property 1).2
+    rw [eq_cornerOne_iff, eq_cornerOne_iff]
+    rcases le_total (p.1 0) (p.1 1) with hp | hp <;> rcases le_total (q.1 0) (q.1 1) with hq | hq
+    all_goals
+      first
+      | rw [tile_zero_le p hp] at h
+      | rw [tile_zero_ge p hp] at h
+      first
+      | rw [tile_two_le q hq] at h
+      | rw [tile_two_ge q hq] at h
+      have hx := congrFun h 0
+      have hy := congrFun h 1
+      simp only [Matrix.cons_val_zero, Matrix.cons_val_one] at hx hy
+      refine ⟨⟨?_, ?_⟩, ⟨?_, ?_⟩⟩ <;> linarith only [hp, hq, hx, hy, hp0, hp1, hq0, hq1]
+  · rintro ⟨rfl, rfl⟩
+    simp
+
+private theorem CuspHoneycombHexagon.tile_zero_eq_three_iff (p q : Square) :
+    tile 0 p = tile 3 q ↔ p = cornerOne ∧ q = cornerOne := by
+  constructor
+  · intro h
+    have hp0 := (p.property 0).2
+    have hp1 := (p.property 1).2
+    have hq0 := (q.property 0).2
+    have hq1 := (q.property 1).2
+    rw [eq_cornerOne_iff, eq_cornerOne_iff]
+    rcases le_total (p.1 0) (p.1 1) with hp | hp <;> rcases le_total (q.1 0) (q.1 1) with hq | hq
+    all_goals
+      first
+      | rw [tile_zero_le p hp] at h
+      | rw [tile_zero_ge p hp] at h
+      first
+      | rw [tile_three_le q hq] at h
+      | rw [tile_three_ge q hq] at h
+      have hx := congrFun h 0
+      have hy := congrFun h 1
+      simp only [Matrix.cons_val_zero, Matrix.cons_val_one] at hx hy
+      refine ⟨⟨?_, ?_⟩, ⟨?_, ?_⟩⟩ <;> linarith only [hp, hq, hx, hy, hp0, hp1, hq0, hq1]
+  · rintro ⟨rfl, rfl⟩
+    simp
+
+private theorem CuspHoneycombHexagon.tile_zero_eq_four_iff (p q : Square) :
+    tile 0 p = tile 4 q ↔ p = cornerOne ∧ q = cornerOne := by
+  constructor
+  · intro h
+    have hp0 := (p.property 0).2
+    have hp1 := (p.property 1).2
+    have hq0 := (q.property 0).2
+    have hq1 := (q.property 1).2
+    rw [eq_cornerOne_iff, eq_cornerOne_iff]
+    rcases le_total (p.1 0) (p.1 1) with hp | hp <;> rcases le_total (q.1 0) (q.1 1) with hq | hq
+    all_goals
+      first
+      | rw [tile_zero_le p hp] at h
+      | rw [tile_zero_ge p hp] at h
+      first
+      | rw [tile_four_le q hq] at h
+      | rw [tile_four_ge q hq] at h
+      have hx := congrFun h 0
+      have hy := congrFun h 1
+      simp only [Matrix.cons_val_zero, Matrix.cons_val_one] at hx hy
+      refine ⟨⟨?_, ?_⟩, ⟨?_, ?_⟩⟩ <;> linarith only [hp, hq, hx, hy, hp0, hp1, hq0, hq1]
+  · rintro ⟨rfl, rfl⟩
+    simp
+
+private theorem CuspHoneycombHexagon.tile_zero_injective : Function.Injective (tile 0) := by
+  intro p q h
+  apply Subtype.ext
+  rcases le_total (p.1 0) (p.1 1) with hp | hp <;> rcases le_total (q.1 0) (q.1 1) with hq | hq
+  all_goals
+    first
+    | rw [tile_zero_le p hp] at h
+    | rw [tile_zero_ge p hp] at h
+    first
+    | rw [tile_zero_le q hq] at h
+    | rw [tile_zero_ge q hq] at h
+    have hx := congrFun h 0
+    have hy := congrFun h 1
+    simp only [Matrix.cons_val_zero, Matrix.cons_val_one] at hx hy
+    ext k
+    fin_cases k
+    · change p.1 0 = q.1 0
+      linarith only [hp, hq, hx, hy]
+    · change p.1 1 = q.1 1
+      linarith only [hp, hq, hx, hy]
+
+private theorem CuspHoneycombHexagon.rotate_iterate_tile (n : ℕ) (i : Fin 6) (p : Square) :
+    (rotate : Plane → Plane)^[n] (tile i p) = tile (i + (n : Fin 6)) p := by
+  induction n with
+  | zero => simp
+  | succ n ih =>
+    rw [Function.iterate_succ_apply', ih, rotate_tile]
+    congr 1
+    simp only [Nat.cast_succ, add_assoc]
+
+private theorem CuspHoneycombHexagon.tile_eq_iff_sub (i j : Fin 6) (p q : Square) :
+    tile i p = tile j q ↔ tile 0 p = tile (j - i) q := by
+  have hp : (rotate : Plane → Plane)^[i.val] (tile 0 p) = tile i p := by
+    rw [rotate_iterate_tile]
+    simp only [Fin.cast_val_eq_self, zero_add]
+  have hq : (rotate : Plane → Plane)^[i.val] (tile (j - i) q) = tile j q := by
+    rw [rotate_iterate_tile]
+    simp only [Fin.cast_val_eq_self, sub_add_cancel]
+  rw [← hp, ← hq]
+  exact (rotate.injective.iterate i.val).eq_iff
+
+private theorem CuspHoneycombHexagon.squareRel_sub (i j : Fin 6) (p q : Square) :
+    SquareRel 0 (j - i) p q ↔ SquareRel i j p q := by
+  have h0 : (0 : Fin 6) = j - i ↔ i = j := by rw [eq_sub_iff_add_eq, zero_add]
+  have h1 : j - i = (0 : Fin 6) + 1 ↔ j = i + 1 := by
+    rw [zero_add, sub_eq_iff_eq_add, add_comm (1 : Fin 6) i]
+  have h2 : (0 : Fin 6) = (j - i) + 1 ↔ i = j + 1 := by
+    have he : j - i + 1 = (j + 1) - i := by abel
+    rw [he, eq_sub_iff_add_eq, zero_add]
+  simp only [SquareRel, h0, h1, h2]
+
+private theorem
+    CuspHoneycombHexagon.eq_cornerOne_iff_all (p : Square) : p = cornerOne ↔ ∀ k, p.1 k = 1 :=
+  by
+  constructor
+  · rintro rfl
+    exact fun _ => rfl
+  · intro hp
+    exact square_eq_of_all_one p cornerOne hp (fun _ => rfl)
+
+private theorem CuspHoneycombHexagon.tile_zero_eq_iff (j : Fin 6) (p q : Square) :
+    tile 0 p = tile j q ↔ SquareRel 0 j p q := by
+  fin_cases j
+  · change tile 0 p = tile 0 q ↔ SquareRel 0 0 p q
+    rw [squareRel_self]
+    exact tile_zero_injective.eq_iff
+  · change tile 0 p = tile 1 q ↔ SquareRel 0 (0 + 1) p q
+    rw [squareRel_next]
+    exact tile_zero_eq_one_iff p q
+  · change tile 0 p = tile 2 q ↔ SquareRel 0 (0 + 2) p q
+    rw [squareRel_add_two, tile_zero_eq_two_iff, eq_cornerOne_iff_all, eq_cornerOne_iff_all]
+  · change tile 0 p = tile 3 q ↔ SquareRel 0 (0 + 3) p q
+    rw [squareRel_add_three, tile_zero_eq_three_iff, eq_cornerOne_iff_all, eq_cornerOne_iff_all]
+  · change tile 0 p = tile 4 q ↔ SquareRel 0 (0 + 4) p q
+    rw [squareRel_add_four, tile_zero_eq_four_iff, eq_cornerOne_iff_all, eq_cornerOne_iff_all]
+  · change tile 0 p = tile 5 q ↔ SquareRel 0 (0 + 5) p q
+    rw [squareRel_prev, tile_zero_eq_five_iff]
+    constructor <;> rintro ⟨h0, h1, h2⟩
+    · exact ⟨h0, h1, h2.symm⟩
+    · exact ⟨h0, h1, h2.symm⟩
+
+private theorem CuspHoneycombHexagon.tile_eq_iff (i j : Fin 6) (p q : Square) :
+    tile i p = tile j q ↔ SquareRel i j p q :=
+  (tile_eq_iff_sub i j p q).trans ((tile_zero_eq_iff (j - i) p q).trans (squareRel_sub i j p q))
+
+private theorem
+    CuspHoneycombHexagon.tile_sector_of_le (i : Fin 6) (p : Square) (hp : p.1 0 ≤ p.1 1) :
+    tile i p =
+      ((p.1 1 - p.1 0) / 2) • vertex (i - 1) + (1 - (p.1 0 + p.1 1) / 2) • vertex ((i - 1) + 1) :=
+  by
+  rw [tile_of_le i p hp, CuspHoneycombHexagon.midpoint, sub_add_cancel]
+  ext k
+  simp only [Pi.add_apply, Pi.smul_apply, smul_eq_mul]
+  ring
+
+private theorem
+    CuspHoneycombHexagon.tile_sector_of_ge (i : Fin 6) (p : Square) (hp : p.1 1 ≤ p.1 0) :
+    tile i p = (1 - (p.1 0 + p.1 1) / 2) • vertex i + ((p.1 0 - p.1 1) / 2) • vertex (i + 1) := by
+  rw [tile_of_ge i p hp, CuspHoneycombHexagon.midpoint, add_sub_cancel_right]
+  ext k
+  simp only [Pi.add_apply, Pi.smul_apply, smul_eq_mul]
+  ring
+
+private theorem
+    CuspHoneycombHexagon.tile_mem_hexagon (i : Fin 6) (p : Square) : tile i p ∈ Hexagon := by
+  have hp0 := p.2 0
+  have hp1 := p.2 1
+  rcases le_total (p.1 0) (p.1 1) with hp | hp
+  · rw [tile_sector_of_le i p hp]
+    apply sector_mem_hexagon (i - 1) <;> linarith [hp0.1, hp0.2, hp1.1, hp1.2]
+  · rw [tile_sector_of_ge i p hp]
+    apply sector_mem_hexagon i <;> linarith [hp0.1, hp0.2, hp1.1, hp1.2]
+
+private theorem
+    CuspHoneycombHexagon.exists_tile_of_sector (i : Fin 6) (α β : ℝ) (hα : 0 ≤ α) (hβ : 0 ≤ β)
+    (hαβ : α + β ≤ 1) : ∃ j : Fin 6, ∃ p : Square, tile j p = α • vertex i + β • vertex (i + 1) :=
+  by
+  rcases le_total β α with h | h
+  · let p : Square :=
+      ⟨![1 - α + β, 1 - α - β], by
+        intro k
+        fin_cases k
+        · change 0 ≤ 1 - α + β ∧ 1 - α + β ≤ 1
+          constructor <;> linarith
+        · change 0 ≤ 1 - α - β ∧ 1 - α - β ≤ 1
+          constructor <;> linarith⟩
+    have hp : p.1 1 ≤ p.1 0 := by
+      change 1 - α - β ≤ 1 - α + β
+      linarith
+    refine ⟨i, p, ?_⟩
+    rw [tile_sector_of_ge i p hp]
+    ext k
+    simp only [p, Matrix.cons_val_zero, Matrix.cons_val_one, Pi.add_apply, Pi.smul_apply,
+      smul_eq_mul]
+    ring
+  · let p : Square :=
+      ⟨![1 - α - β, 1 + α - β], by
+        intro k
+        fin_cases k
+        · change 0 ≤ 1 - α - β ∧ 1 - α - β ≤ 1
+          constructor <;> linarith
+        · change 0 ≤ 1 + α - β ∧ 1 + α - β ≤ 1
+          constructor <;> linarith⟩
+    have hp : p.1 0 ≤ p.1 1 := by
+      change 1 - α - β ≤ 1 + α - β
+      linarith
+    refine ⟨i + 1, p, ?_⟩
+    rw [tile_sector_of_le (i + 1) p hp, add_sub_cancel_right]
+    ext k
+    simp only [p, Matrix.cons_val_zero, Matrix.cons_val_one, Pi.add_apply, Pi.smul_apply,
+      smul_eq_mul]
+    ring
+
+private theorem CuspHoneycombHexagon.tile_jointly_surjective (x : Hexagon) :
+    ∃ i : Fin 6, ∃ p : Square, tile i p = x.val := by
+  obtain ⟨i, α, β, hα, hβ, hαβ, hx⟩ := sector_decomposition x.2
+  obtain ⟨j, p, hp⟩ := exists_tile_of_sector i α β hα hβ hαβ
+  exact ⟨j, p, hp.trans hx.symm⟩
+
+private theorem CuspHoneycombHexagon.tile_zero_side_zero_eq_one_iff (p : Square) :
+    sideFunctional 0 (tile 0 p) = 1 ↔ p.1 0 = 0 := by
+  rw [sideFunctional_zero]
+  have hp0 := (p.property 0).1
+  have hp1 := (p.property 1).1
+  rcases le_total (p.1 0) (p.1 1) with hp | hp
+  · rw [tile_zero_le p hp]
+    simp only [Matrix.cons_val_zero]
+    constructor <;> intro h <;> linarith only [hp, hp0, hp1, h]
+  · rw [tile_zero_ge p hp]
+    simp only [Matrix.cons_val_zero]
+    constructor <;> intro h <;> linarith only [hp, hp0, hp1, h]
+
+private theorem CuspHoneycombHexagon.tile_zero_side_one_eq_one_iff (p : Square) :
+    sideFunctional 1 (tile 0 p) = 1 ↔ p.1 1 = 0 := by
+  rw [sideFunctional_one]
+  have hp0 := (p.property 0).1
+  have hp1 := (p.property 1).1
+  rcases le_total (p.1 0) (p.1 1) with hp | hp
+  · rw [tile_zero_le p hp]
+    simp only [Matrix.cons_val_zero, Matrix.cons_val_one]
+    constructor <;> intro h <;> linarith only [hp, hp0, hp1, h]
+  · rw [tile_zero_ge p hp]
+    simp only [Matrix.cons_val_zero, Matrix.cons_val_one]
+    constructor <;> intro h <;> linarith only [hp, hp0, hp1, h]
+
+private theorem CuspHoneycombHexagon.tile_zero_side_two_lt_one (p : Square) :
+    sideFunctional 2 (tile 0 p) < 1 := by
+  rw [sideFunctional_two]
+  have hp0 := (p.property 0).2
+  have hp1 := (p.property 1).1
+  rcases le_total (p.1 0) (p.1 1) with hp | hp
+  · rw [tile_zero_le p hp]
+    simp only [Matrix.cons_val_one, Matrix.cons_val_zero]
+    linarith only [hp0, hp1]
+  · rw [tile_zero_ge p hp]
+    simp only [Matrix.cons_val_one, Matrix.cons_val_zero]
+    linarith only [hp0, hp1]
+
+private theorem CuspHoneycombHexagon.tile_zero_side_three_lt_one (p : Square) :
+    sideFunctional 3 (tile 0 p) < 1 := by
+  rw [sideFunctional_three]
+  have hp0 := (p.property 0).2
+  have hp1 := (p.property 1).2
+  rcases le_total (p.1 0) (p.1 1) with hp | hp
+  · rw [tile_zero_le p hp]
+    simp only [Matrix.cons_val_zero]
+    linarith only [hp0, hp1]
+  · rw [tile_zero_ge p hp]
+    simp only [Matrix.cons_val_zero]
+    linarith only [hp0, hp1]
+
+private theorem CuspHoneycombHexagon.tile_zero_side_four_lt_one (p : Square) :
+    sideFunctional 4 (tile 0 p) < 1 := by
+  rw [sideFunctional_four]
+  have hp0 := (p.property 0).2
+  have hp1 := (p.property 1).2
+  rcases le_total (p.1 0) (p.1 1) with hp | hp
+  · rw [tile_zero_le p hp]
+    simp only [Matrix.cons_val_zero, Matrix.cons_val_one]
+    linarith only [hp0, hp1]
+  · rw [tile_zero_ge p hp]
+    simp only [Matrix.cons_val_zero, Matrix.cons_val_one]
+    linarith only [hp0, hp1]
+
+private theorem CuspHoneycombHexagon.tile_zero_side_five_lt_one (p : Square) :
+    sideFunctional 5 (tile 0 p) < 1 := by
+  rw [sideFunctional_five]
+  have hp0 := (p.property 0).1
+  have hp1 := (p.property 1).2
+  rcases le_total (p.1 0) (p.1 1) with hp | hp
+  · rw [tile_zero_le p hp]
+    simp only [Matrix.cons_val_one, Matrix.cons_val_zero]
+    linarith only [hp0, hp1]
+  · rw [tile_zero_ge p hp]
+    simp only [Matrix.cons_val_one, Matrix.cons_val_zero]
+    linarith only [hp0, hp1]
+
+private theorem CuspHoneycombHexagon.tile_zero_side_eq_one_iff (p : Square) (k : Fin 6) :
+    sideFunctional k (tile 0 p) = 1 ↔ (k = 0 ∧ p.1 0 = 0) ∨ (k = 1 ∧ p.1 1 = 0) := by
+  fin_cases k
+  · simpa only [Fin.zero_eta, true_and, or_false,
+      show (0 : Fin 6) = 0 ↔ True from iff_true_intro rfl,
+      show (0 : Fin 6) = 1 ↔ False from iff_false_intro (by decide), false_and] using
+      tile_zero_side_zero_eq_one_iff p
+  · simpa only [Fin.mk_one, false_and, false_or, true_and,
+      show (1 : Fin 6) = 0 ↔ False from iff_false_intro (by decide),
+      show (1 : Fin 6) = 1 ↔ True from iff_true_intro rfl] using tile_zero_side_one_eq_one_iff p
+  · constructor
+    · intro h
+      exact ((tile_zero_side_two_lt_one p).ne h).elim
+    · rintro (⟨h, _⟩ | ⟨h, _⟩)
+      · exact ((show (2 : Fin 6) ≠ 0 by decide) h).elim
+      · exact ((show (2 : Fin 6) ≠ 1 by decide) h).elim
+  · constructor
+    · intro h
+      exact ((tile_zero_side_three_lt_one p).ne h).elim
+    · rintro (⟨h, _⟩ | ⟨h, _⟩)
+      · exact ((show (3 : Fin 6) ≠ 0 by decide) h).elim
+      · exact ((show (3 : Fin 6) ≠ 1 by decide) h).elim
+  · constructor
+    · intro h
+      exact ((tile_zero_side_four_lt_one p).ne h).elim
+    · rintro (⟨h, _⟩ | ⟨h, _⟩)
+      · exact ((show (4 : Fin 6) ≠ 0 by decide) h).elim
+      · exact ((show (4 : Fin 6) ≠ 1 by decide) h).elim
+  · constructor
+    · intro h
+      exact ((tile_zero_side_five_lt_one p).ne h).elim
+    · rintro (⟨h, _⟩ | ⟨h, _⟩)
+      · exact ((show (5 : Fin 6) ≠ 0 by decide) h).elim
+      · exact ((show (5 : Fin 6) ≠ 1 by decide) h).elim
+
+private theorem CuspHoneycombHexagon.sideFunctional_rotate (k : Fin 6) (x : Plane) :
+    sideFunctional (k + 1) (rotate x) = sideFunctional k x := by
+  fin_cases k
+  · change -x 1 + (x 0 + x 1) = x 0
+    ring
+  · change x 0 + x 1 = x 0 + x 1
+    rfl
+  · change -(-x 1) = x 1
+    ring
+  · change -(-x 1) - (x 0 + x 1) = -x 0
+    ring
+  · change -(x 0 + x 1) = -x 0 - x 1
+    ring
+  · change -x 1 = -x 1
+    rfl
+
+private theorem CuspHoneycombHexagon.sideFunctional_iterate (n : ℕ) (k : Fin 6) (x : Plane) :
+    sideFunctional (k + (n : Fin 6)) ((rotate : Plane → Plane)^[n] x) = sideFunctional k x := by
+  induction n with
+  | zero => simp
+  | succ n ih =>
+    rw [Nat.cast_succ, ← add_assoc, Function.iterate_succ_apply', sideFunctional_rotate, ih]
+
+private theorem CuspHoneycombHexagon.sideFunctional_tile_sub (i k : Fin 6) (p : Square) :
+    sideFunctional k (tile i p) = sideFunctional (k - i) (tile 0 p) := by
+  have h := sideFunctional_iterate i.val (k - i) (tile 0 p)
+  simpa only [rotate_iterate_tile, Fin.cast_val_eq_self, sub_add_cancel, zero_add] using h
+
+private theorem CuspHoneycombHexagon.tile_mem_side_iff (i k : Fin 6) (p : Square) :
+    tile i p ∈ side k ↔ (k = i ∧ p.1 0 = 0) ∨ (k = i + 1 ∧ p.1 1 = 0) := by
+  have h1 : k - i = (1 : Fin 6) ↔ k = i + 1 := by rw [sub_eq_iff_eq_add, add_comm (1 : Fin 6) i]
+  change (tile i p ∈ Hexagon ∧ sideFunctional k (tile i p) = 1) ↔ _
+  rw [sideFunctional_tile_sub]
+  simp only [tile_mem_hexagon i p, true_and, tile_zero_side_eq_one_iff, sub_eq_zero, h1]
+
+private def CuspHoneycombTiling.dualStandardLinearEquiv : Plane ≃ₗ[ℝ] Plane
+    where
+  toFun x := ![2 * x 0 + x 1, x 1 - x 0]
+  invFun y := ![(y 0 - y 1) / 3, (y 0 + 2 * y 1) / 3]
+  left_inv
+    x := by
+    funext i
+    fin_cases i
+    · change ((2 * x 0 + x 1) - (x 1 - x 0)) / 3 = x 0
+      ring
+    · change ((2 * x 0 + x 1) + 2 * (x 1 - x 0)) / 3 = x 1
+      ring
+  right_inv
+    y := by
+    funext i
+    fin_cases i
+    · change 2 * ((y 0 - y 1) / 3) + (y 0 + 2 * y 1) / 3 = y 0
+      ring
+    · change (y 0 + 2 * y 1) / 3 - (y 0 - y 1) / 3 = y 1
+      ring
+  map_add' x
+    y := by
+    funext i
+    fin_cases i
+    · change 2 * (x 0 + y 0) + (x 1 + y 1) = (2 * x 0 + x 1) + (2 * y 0 + y 1)
+      ring
+    · change (x 1 + y 1) - (x 0 + y 0) = (x 1 - x 0) + (y 1 - y 0)
+      ring
+  map_smul' a
+    x := by
+    funext i
+    fin_cases i
+    · change 2 * (a * x 0) + a * x 1 = a * (2 * x 0 + x 1)
+      ring
+    · change a * x 1 - a * x 0 = a * (x 1 - x 0)
+      ring
+
+private def CuspHoneycombTiling.dualStandardPlaneHomeomorph : Plane ≃ₜ Plane
+    where
+  toEquiv := dualStandardLinearEquiv.toEquiv
+  continuous_toFun := by
+    apply continuous_pi
+    intro i
+    fin_cases i
+    · exact (continuous_const.mul (continuous_apply 0)).add (continuous_apply 1)
+    · exact (continuous_apply 1).sub (continuous_apply 0)
+  continuous_invFun := by
+    apply continuous_pi
+    intro i
+    fin_cases i
+    · exact ((continuous_apply 0).sub (continuous_apply 1)).div_const 3
+    · exact ((continuous_apply 0).add (continuous_const.mul (continuous_apply 1))).div_const 3
+
+@[simp]
+private theorem CuspHoneycombTiling.dualStandardPlaneHomeomorph_apply (x : Plane) :
+    dualStandardPlaneHomeomorph x = ![2 * x 0 + x 1, x 1 - x 0] :=
+  rfl
+
+private theorem CuspHoneycombTiling.dualStandardPlaneHomeomorph_mem_hexagon (x : Plane) :
+    dualStandardPlaneHomeomorph x ∈ CuspHoneycombHexagon.Hexagon ↔ x ∈ baseCell := by
+  change (|2 * x 0 + x 1| ≤ 1 ∧ |x 1 - x 0| ≤ 1 ∧ |2 * x 0 + x 1 + (x 1 - x 0)| ≤ 1) ↔ _
+  have he : 2 * x 0 + x 1 + (x 1 - x 0) = x 0 + 2 * x 1 := by ring
+  rw [he, abs_sub_comm (x 1) (x 0)]
+  rfl
+
+private theorem CuspHoneycombTiling.dualStandardPlaneHomeomorph_symm_mem_baseCell (y : Plane) :
+    dualStandardPlaneHomeomorph.symm y ∈ baseCell ↔ y ∈ CuspHoneycombHexagon.Hexagon := by
+  simpa only [Homeomorph.apply_symm_apply] using
+    (dualStandardPlaneHomeomorph_mem_hexagon (dualStandardPlaneHomeomorph.symm y)).symm
+
+private def
+    CuspHoneycombTiling.standardHexagonDualHomeomorph : CuspHoneycombHexagon.Hexagon ≃ₜ baseCell
+    where
+  toFun
+    y :=
+    ⟨dualStandardPlaneHomeomorph.symm y,
+      (dualStandardPlaneHomeomorph_symm_mem_baseCell y).mpr y.2⟩
+  invFun x := ⟨dualStandardPlaneHomeomorph x, (dualStandardPlaneHomeomorph_mem_hexagon x).mpr x.2⟩
+  left_inv y := Subtype.ext (dualStandardPlaneHomeomorph.apply_symm_apply y)
+  right_inv x := Subtype.ext (dualStandardPlaneHomeomorph.symm_apply_apply x)
+  continuous_toFun :=
+    (dualStandardPlaneHomeomorph.symm.continuous.comp continuous_subtype_val).subtype_mk _
+  continuous_invFun :=
+    (dualStandardPlaneHomeomorph.continuous.comp continuous_subtype_val).subtype_mk _
+
+@[simp]
+private theorem
+    CuspHoneycombTiling.standardHexagonDualHomeomorph_coe (y : CuspHoneycombHexagon.Hexagon) :
+    (standardHexagonDualHomeomorph y : Plane) = dualStandardPlaneHomeomorph.symm y :=
+  rfl
+
+private def CuspHoneycombTiling.triangleBarycenter (s : ToricFan.Triangle) : Plane := fun i =>
+  ((s.vertex 0 i : ℝ) + (s.vertex 1 i : ℝ) + (s.vertex 2 i : ℝ)) / 3
+
+private theorem CuspHoneycombTiling.triangleBarycenter_zeroTriangle (i : Fin 6) :
+    triangleBarycenter (ToricComponent.zeroTriangle i) = fun j =>
+      ((ToricComponent.hexagonRay i j : ℝ) + (ToricComponent.hexagonRay (i + 1) j : ℝ)) / 3 := by
+  have hs :
+    (ToricComponent.zeroTriangle i).vertex 0 + (ToricComponent.zeroTriangle i).vertex 1 +
+        (ToricComponent.zeroTriangle i).vertex 2 =
+      ToricComponent.hexagonRay i + ToricComponent.hexagonRay (i + 1) := by fin_cases i <;> decide
+  funext j
+  have hj :
+    (ToricComponent.zeroTriangle i).vertex 0 j + (ToricComponent.zeroTriangle i).vertex 1 j +
+        (ToricComponent.zeroTriangle i).vertex 2 j =
+      ToricComponent.hexagonRay i j + ToricComponent.hexagonRay (i + 1) j :=
+    congrFun hs j
+  have hreal :
+    ((ToricComponent.zeroTriangle i).vertex 0 j : ℝ) +
+          ((ToricComponent.zeroTriangle i).vertex 1 j : ℝ) +
+        ((ToricComponent.zeroTriangle i).vertex 2 j : ℝ) =
+      (ToricComponent.hexagonRay i j : ℝ) + (ToricComponent.hexagonRay (i + 1) j : ℝ) := by
+    exact_mod_cast hj
+  exact congrArg (fun r : ℝ => r / 3) hreal
+
+private theorem CuspHoneycombTiling.dual_standard_vertex (i : Fin 6) :
+    dualStandardPlaneHomeomorph.symm (CuspHoneycombHexagon.vertex i) =
+      triangleBarycenter (ToricComponent.zeroTriangle i) := by
+  have hr :
+    ∀ i : Fin 6,
+      ToricComponent.hexagonRay (i + 1) 0 = -ToricComponent.hexagonRay i 1 ∧
+        ToricComponent.hexagonRay (i + 1) 1 =
+          ToricComponent.hexagonRay i 0 + ToricComponent.hexagonRay i 1 := by decide
+  rw [triangleBarycenter_zeroTriangle]
+  funext j
+  fin_cases j
+  · change
+      ((ToricComponent.hexagonRay i 0 : ℝ) - (ToricComponent.hexagonRay i 1 : ℝ)) / 3 =
+        ((ToricComponent.hexagonRay i 0 : ℝ) + (ToricComponent.hexagonRay (i + 1) 0 : ℝ)) / 3
+    rw [(hr i).1, Int.cast_neg]
+    ring
+  · change
+      ((ToricComponent.hexagonRay i 0 : ℝ) + 2 * (ToricComponent.hexagonRay i 1 : ℝ)) / 3 =
+        ((ToricComponent.hexagonRay i 1 : ℝ) + (ToricComponent.hexagonRay (i + 1) 1 : ℝ)) / 3
+    rw [(hr i).2, Int.cast_add]
+    ring
+
+private theorem CuspHoneycombTiling.mem_neighbor_cell_iff_sideFunctional (k : Fin 6) (x : Plane)
+    (hx : x ∈ baseCell) :
+    x ∈ cell (ToricComponent.hexagonRay k) ↔
+      CuspHoneycombHexagon.sideFunctional k (dualStandardPlaneHomeomorph x) = 1 := by
+  have h0 := abs_le.mp hx.1
+  have h1 := abs_le.mp hx.2.1
+  have h2 := abs_le.mp hx.2.2
+  fin_cases k <;>
+    norm_num [cell, baseCell, latticePoint, ToricComponent.hexagonRay,
+      CuspHoneycombHexagon.sideFunctional, dualStandardPlaneHomeomorph_apply, abs_le]
+  all_goals
+    constructor
+    · intro h
+      linarith
+    · intro h
+      repeat' apply And.intro
+      all_goals linarith
+
+private theorem CuspHoneycombTiling.dual_image_side (k : Fin 6) :
+    dualStandardPlaneHomeomorph.symm '' CuspHoneycombHexagon.side k =
+      baseCell ∩ cell (ToricComponent.hexagonRay k) := by
+  ext x
+  constructor
+  · rintro ⟨y, hy, rfl⟩
+    have hx : dualStandardPlaneHomeomorph.symm y ∈ baseCell :=
+      (dualStandardPlaneHomeomorph_symm_mem_baseCell y).mpr hy.1
+    refine ⟨hx, (mem_neighbor_cell_iff_sideFunctional k _ hx).mpr ?_⟩
+    simpa only [Homeomorph.apply_symm_apply] using hy.2
+  · intro hx
+    refine ⟨dualStandardPlaneHomeomorph x, ?_, dualStandardPlaneHomeomorph.symm_apply_apply x⟩
+    exact
+      ⟨(dualStandardPlaneHomeomorph_mem_hexagon x).mpr hx.1,
+        (mem_neighbor_cell_iff_sideFunctional k x hx.1).mp hx.2⟩
+
+private theorem CuspHoneycombTiling.standardHexagonDualHomeomorph_mem_cell_iff_side (k : Fin 6)
+    (x : CuspHoneycombHexagon.Hexagon) :
+    (standardHexagonDualHomeomorph x : Plane) ∈ cell (ToricComponent.hexagonRay k) ↔
+      (x : Plane) ∈ CuspHoneycombHexagon.side k := by
+  have h :=
+    mem_neighbor_cell_iff_sideFunctional k (standardHexagonDualHomeomorph x)
+      (standardHexagonDualHomeomorph x).property
+  simpa only [standardHexagonDualHomeomorph_coe, Homeomorph.apply_symm_apply,
+    CuspHoneycombHexagon.side, Set.mem_ofPred_eq, x.property, true_and] using h
+
+private def CuspHoneycombHexagon.segmentIntervalHomeomorph {E : Type*} [AddCommGroup E] [Module ℝ E]
+    [TopologicalSpace E] [ContinuousAdd E] [ContinuousSMul ℝ E] [T2Space E] (a b : E)
+    (hab : a ≠ b) : unitInterval ≃ₜ segment ℝ a b :=
+  ((Path.segment a b).continuous.isClosedEmbedding
+        (Path.segment_injective_of_ne hab)).isEmbedding.toHomeomorph.trans
+    (Homeomorph.setCongr (Path.range_segment a b))
+
+@[simp]
+private theorem CuspHoneycombHexagon.segmentIntervalHomeomorph_apply {E : Type*} [AddCommGroup E]
+    [Module ℝ E] [TopologicalSpace E] [ContinuousAdd E] [ContinuousSMul ℝ E] [T2Space E] (a b : E)
+    (hab : a ≠ b) (t : unitInterval) :
+    (segmentIntervalHomeomorph a b hab t : E) = (1 - (t : ℝ)) • a + (t : ℝ) • b := by
+  change AffineMap.lineMap a b (t : ℝ) = _
+  exact AffineMap.lineMap_apply_module _ _ _
+
+private theorem CuspHoneycombHexagon.vertex_injective : Function.Injective vertex := by
+  intro i j hij
+  apply ToricComponent.hexagonRay_injective
+  funext k
+  have h := congrFun hij k
+  change (ToricComponent.hexagonRay i k : ℝ) = (ToricComponent.hexagonRay j k : ℝ) at h
+  exact_mod_cast h
+
+private theorem CuspHoneycombHexagon.vertex_prev_ne (k : Fin 6) : vertex (k - 1) ≠ vertex k := by
+  intro h
+  exact (show ∀ k : Fin 6, k - 1 ≠ k by decide) k (vertex_injective h)
+
+private theorem CuspHoneycombHexagon.side_eq_segment (k : Fin 6) :
+    side k = segment ℝ (vertex (k - 1)) (vertex k) := by
+  have hpred :
+    ∀ k : Fin 6,
+      k - 1 =
+        ![⟨5, by decide⟩, ⟨0, by decide⟩, ⟨1, by decide⟩, ⟨2, by decide⟩, ⟨3, by decide⟩,
+            ⟨4, by decide⟩]
+          k := by decide
+  rw [hpred k, segment_eq_image]
+  ext x
+  constructor
+  · rintro ⟨⟨h0, h1, h01⟩, hk⟩
+    obtain ⟨h0l, h0u⟩ := abs_le.mp h0
+    obtain ⟨h1l, h1u⟩ := abs_le.mp h1
+    obtain ⟨h01l, h01u⟩ := abs_le.mp h01
+    refine ⟨![x 1 + 1, x 1, -x 0, 1 - x 1, -x 1, x 0] k, ?_, ?_⟩
+    · fin_cases k <;> norm_num [sideFunctional] at hk ⊢ <;> constructor <;> linarith
+    · funext j
+      fin_cases k <;> fin_cases j <;>
+          norm_num [sideFunctional, vertex, ToricComponent.hexagonRay, Pi.add_apply,
+            Pi.smul_apply, smul_eq_mul] at hk ⊢ <;>
+        linarith
+  · rintro ⟨t, ⟨ht0, ht1⟩, rfl⟩
+    fin_cases k <;>
+          norm_num [side, Hexagon, sideFunctional, vertex, ToricComponent.hexagonRay,
+            Matrix.vecHead, Matrix.vecTail, Pi.add_apply, Pi.smul_apply, smul_eq_mul, abs_le] <;>
+        (repeat' constructor) <;>
+      linarith
+
+private def CuspHoneycombHexagon.sideIntervalHomeomorph (k : Fin 6) : unitInterval ≃ₜ side k :=
+  (segmentIntervalHomeomorph (vertex (k - 1)) (vertex k) (vertex_prev_ne k)).trans
+    (Homeomorph.setCongr (side_eq_segment k).symm)
+
+@[simp]
+private theorem CuspHoneycombHexagon.sideIntervalHomeomorph_apply (k : Fin 6) (t : unitInterval) :
+    (sideIntervalHomeomorph k t : Plane) = (1 - (t : ℝ)) • vertex (k - 1) + (t : ℝ) • vertex k := by
+  change (segmentIntervalHomeomorph (vertex (k - 1)) (vertex k) (vertex_prev_ne k) t : Plane) = _
+  exact segmentIntervalHomeomorph_apply _ _ _ _
+
+private theorem CuspHoneycombHexagon.sideIntervalHomeomorph_one (k : Fin 6) :
+    (sideIntervalHomeomorph k 1 : Plane) = vertex k := by simp
+
+private theorem CuspHoneycombHexagon.eq_vertex_of_consecutive_sideFunctional (k : Fin 6) (x : Plane)
+    (h0 : sideFunctional k x = 1) (h1 : sideFunctional (k + 1) x = 1) : x = vertex k := by
+  fin_cases k <;> ext l <;> fin_cases l <;>
+      norm_num [sideFunctional, vertex, ToricComponent.hexagonRay, Fin.add_def, Matrix.cons_val,
+        Matrix.vecHead, Matrix.vecTail] at h0 h1 ⊢ <;>
+    linarith
+
+private theorem CuspHoneycombHexagon.vertex_mem_side_self (k : Fin 6) : vertex k ∈ side k := by
+  fin_cases k <;>
+    norm_num [side, Hexagon, sideFunctional, vertex, ToricComponent.hexagonRay, Fin.add_def,
+      Matrix.cons_val, Matrix.vecHead, Matrix.vecTail]
+
+private theorem
+    CuspHoneycombHexagon.vertex_mem_side_next (k : Fin 6) : vertex k ∈ side (k + 1) := by
+  fin_cases k <;>
+    norm_num [side, Hexagon, sideFunctional, vertex, ToricComponent.hexagonRay, Fin.add_def,
+      Matrix.cons_val, Matrix.vecHead, Matrix.vecTail]
+
+private theorem
+    CuspHoneycombHexagon.side_inter_next (k : Fin 6) : side k ∩ side (k + 1) = {vertex k} := by
+  ext x
+  constructor
+  · intro hx
+    exact eq_vertex_of_consecutive_sideFunctional k x hx.1.2 hx.2.2
+  · intro hx
+    rw [Set.mem_singleton_iff] at hx
+    subst x
+    exact ⟨vertex_mem_side_self k, vertex_mem_side_next k⟩
+
+private theorem CuspHoneycombHexagon.side_disjoint_add_two (k : Fin 6) :
+    Disjoint (side k) (side (k + 2)) := by
+  apply Set.disjoint_left.mpr
+  intro x hx hy
+  obtain ⟨h0l, h0u⟩ := abs_le.mp hx.1.1
+  obtain ⟨h1l, h1u⟩ := abs_le.mp hx.1.2.1
+  obtain ⟨h01l, h01u⟩ := abs_le.mp hx.1.2.2
+  have h0 := hx.2
+  have h2 := hy.2
+  fin_cases k <;>
+      norm_num [sideFunctional, Fin.add_def, Matrix.cons_val, Matrix.cons_val_two,
+        Matrix.cons_val_three, Matrix.cons_val_four, Matrix.vecHead, Matrix.vecTail] at h0 h2 <;>
+    linarith only [h0, h2, h0l, h0u, h1l, h1u, h01l, h01u]
+
+private theorem CuspHoneycombHexagon.side_disjoint_add_three (k : Fin 6) :
+    Disjoint (side k) (side (k + 3)) := by
+  apply Set.disjoint_left.mpr
+  intro x hx hy
+  have h0 := hx.2
+  have h3 := hy.2
+  fin_cases k <;>
+      norm_num [sideFunctional, Fin.add_def, Matrix.cons_val, Matrix.cons_val_two,
+        Matrix.cons_val_three, Matrix.cons_val_four, Matrix.vecHead, Matrix.vecTail] at h0 h3 <;>
+    linarith only [h0, h3]
+
+private theorem CuspHoneycombHexagon.side_disjoint_add_four (k : Fin 6) :
+    Disjoint (side k) (side (k + 4)) := by
+  have hi : (k + 4) + 2 = k := by
+    rw [add_assoc]
+    change k + 0 = k
+    exact add_zero k
+  simpa only [hi] using (side_disjoint_add_two (k + 4)).symm
+
+private theorem CuspHoneycombHexagon.side_disjoint_nonadjacent {i j : Fin 6} (hij : i ≠ j)
+    (hnext : j ≠ i + 1) (hprev : i ≠ j + 1) : Disjoint (side i) (side j) := by
+  obtain ⟨k, rfl⟩ : ∃ k : Fin 6, j = i + k := ⟨j - i, by rw [add_comm i (j - i), sub_add_cancel]⟩
+  fin_cases k
+  · exact (hij (by change i = i + 0; simp)).elim
+  · exact (hnext rfl).elim
+  · change Disjoint (side i) (side (i + 2))
+    exact side_disjoint_add_two i
+  · change Disjoint (side i) (side (i + 3))
+    exact side_disjoint_add_three i
+  · change Disjoint (side i) (side (i + 4))
+    exact side_disjoint_add_four i
+  · apply False.elim
+    apply hprev
+    change i = (i + 5) + 1
+    rw [add_assoc]
+    change i = i + 0
+    exact (add_zero i).symm
+
+private theorem CuspHoneycombTiling.standard_vertex_opposite (k : Fin 6) :
+    CuspHoneycombHexagon.vertex (k + 3) = -CuspHoneycombHexagon.vertex k := by
+  funext i
+  change (ToricComponent.hexagonRay (k + 3) i : ℝ) = -(ToricComponent.hexagonRay k i : ℝ)
+  rw [ToricComponent.hexagonRay_opposite]
+  simp only [Pi.neg_apply, Int.cast_neg]
+
+private theorem CuspHoneycombTiling.dual_latticePoint_ray (k : Fin 6) :
+    dualStandardLinearEquiv (latticePoint (ToricComponent.hexagonRay k)) =
+      CuspHoneycombHexagon.vertex (k - 1) + CuspHoneycombHexagon.vertex k := by
+  have h :
+    ∀ k : Fin 6,
+      ToricComponent.hexagonRay (k - 1) 0 + ToricComponent.hexagonRay k 0 =
+          2 * ToricComponent.hexagonRay k 0 + ToricComponent.hexagonRay k 1 ∧
+        ToricComponent.hexagonRay (k - 1) 1 + ToricComponent.hexagonRay k 1 =
+          ToricComponent.hexagonRay k 1 - ToricComponent.hexagonRay k 0 := by decide
+  funext i
+  fin_cases i
+  · change
+      2 * (ToricComponent.hexagonRay k 0 : ℝ) + (ToricComponent.hexagonRay k 1 : ℝ) =
+        (ToricComponent.hexagonRay (k - 1) 0 : ℝ) + (ToricComponent.hexagonRay k 0 : ℝ)
+    exact_mod_cast (h k).1.symm
+  · change
+      (ToricComponent.hexagonRay k 1 : ℝ) - (ToricComponent.hexagonRay k 0 : ℝ) =
+        (ToricComponent.hexagonRay (k - 1) 1 : ℝ) + (ToricComponent.hexagonRay k 1 : ℝ)
+    exact_mod_cast (h k).2.symm
+
+private theorem CuspHoneycombTiling.dual_sideInterval_opposite (k : Fin 6) (t : unitInterval) :
+    dualStandardPlaneHomeomorph.symm
+        (CuspHoneycombHexagon.sideIntervalHomeomorph (k + 3) (unitInterval.symm t) : Plane) =
+      dualStandardPlaneHomeomorph.symm (CuspHoneycombHexagon.sideIntervalHomeomorph k t : Plane) -
+        latticePoint (ToricComponent.hexagonRay k) := by
+  change
+    dualStandardLinearEquiv.symm
+        (CuspHoneycombHexagon.sideIntervalHomeomorph (k + 3) (unitInterval.symm t) : Plane) =
+      dualStandardLinearEquiv.symm (CuspHoneycombHexagon.sideIntervalHomeomorph k t : Plane) -
+        latticePoint (ToricComponent.hexagonRay k)
+  apply dualStandardLinearEquiv.injective
+  simp only [map_sub, LinearEquiv.apply_symm_apply, dual_latticePoint_ray]
+  have hidx : ∀ k : Fin 6, k + 3 - 1 = (k - 1) + 3 := by decide
+  simp only [CuspHoneycombHexagon.sideIntervalHomeomorph_apply, unitInterval.coe_symm_eq, hidx,
+    standard_vertex_opposite]
+  funext i
+  simp only [Pi.smul_apply, Pi.add_apply, Pi.sub_apply, Pi.neg_apply, smul_eq_mul]
+  ring
+
+private theorem
+    CuspHoneycombTiling.sub_latticePoint_mem_cell_iff (v w : CuspHoneycombTiling.Lattice)
+    (x : Plane) : x - latticePoint v ∈ cell w ↔ x ∈ cell (v + w) := by
+  simp only [mem_cell, latticePoint_add, sub_sub]
+
+private def CuspHoneycombTiling.cellTranslationHomeomorph (v : CuspHoneycombTiling.Lattice) :
+    baseCell ≃ₜ cell v
+    where
+  toFun
+    x := ⟨(x : Plane) + latticePoint v, by simpa only [mem_cell, add_sub_cancel_right] using x.2⟩
+  invFun y := ⟨(y : Plane) - latticePoint v, y.2⟩
+  left_inv x := Subtype.ext (add_sub_cancel_right (x : Plane) (latticePoint v))
+  right_inv y := Subtype.ext (sub_add_cancel (y : Plane) (latticePoint v))
+  continuous_toFun := (continuous_subtype_val.add continuous_const).subtype_mk _
+  continuous_invFun := (continuous_subtype_val.sub continuous_const).subtype_mk _
+
+private def CuspHoneycombTiling.cellShiftHomeomorph (v w : CuspHoneycombTiling.Lattice) :
+    cell v ≃ₜ cell (v + w)
+    where
+  toFun x := ⟨(x : Plane) + latticePoint w, (add_latticePoint_mem_cell_iff v w x).mpr x.2⟩
+  invFun
+    y :=
+    ⟨(y : Plane) - latticePoint w,
+      (sub_latticePoint_mem_cell_iff w v y).mpr (by simpa only [add_comm w v] using y.2)⟩
+  left_inv x := Subtype.ext (add_sub_cancel_right (x : Plane) (latticePoint w))
+  right_inv y := Subtype.ext (sub_add_cancel (y : Plane) (latticePoint w))
+  continuous_toFun := (continuous_subtype_val.add continuous_const).subtype_mk _
+  continuous_invFun := (continuous_subtype_val.sub continuous_const).subtype_mk _
+
+@[simp]
+private theorem CuspHoneycombTiling.cellShiftHomeomorph_coe (v w : CuspHoneycombTiling.Lattice)
+    (x : cell v) : (cellShiftHomeomorph v w x : Plane) = (x : Plane) + latticePoint w :=
+  rfl
+
+private theorem CuspHoneycombTiling.triangleBarycenter_shift (s : ToricFan.Triangle)
+    (v : CuspHoneycombTiling.Lattice) :
+    triangleBarycenter (s.shift v) = triangleBarycenter s + latticePoint v := by
+  funext i
+  simp only [triangleBarycenter, ToricFan.Triangle.vertex_shift, Pi.add_apply, Int.cast_add,
+    latticePoint_apply]
+  ring
+
+private abbrev ToricSpace.CompactFibreTorus :=
+  Fin 2 → Circle
+
+private def ToricSpace.compactFibreUnits : CompactFibreTorus →* (Fin 2 → ℂˣ)
+    where
+  toFun u i := Circle.toUnits (u i)
+  map_one' := by
+    funext i
+    exact Circle.toUnits.map_one
+  map_mul' u
+    v := by
+    funext i
+    exact Circle.toUnits.map_mul (u i) (v i)
+
+private def ToricSpace.compactFibrePhase (u : CompactFibreTorus) : CompactTorus :=
+  ![u 0, u 1, 1]
+
+private theorem ToricSpace.compactFibrePhase_continuous : Continuous compactFibrePhase := by
+  apply continuous_pi
+  intro i
+  fin_cases i
+  · exact continuous_apply 0
+  · exact continuous_apply 1
+  · exact continuous_const
+
+private theorem ToricSpace.compactTorusUnits_compactFibrePhase (u : CompactFibreTorus) :
+    compactTorusUnits (compactFibrePhase u) = fibreMultiplier (compactFibreUnits u) := by
+  funext i
+  fin_cases i
+  · rfl
+  · rfl
+  · exact Circle.toUnits.map_one
+
+private def ToricSpace.compactFibreAction (u : CompactFibreTorus) (x : Space) : Space :=
+  torusAction (fibreMultiplier (compactFibreUnits u)) x
+
+private theorem ToricSpace.compactFibreAction_eq_compact (u : CompactFibreTorus) (x : Space) :
+    compactFibreAction u x = compactTorusAction (compactFibrePhase u) x := by
+  rw [compactTorusAction, compactTorusUnits_compactFibrePhase]
+  rfl
+
+@[simp]
+private theorem ToricSpace.compactFibreAction_one (x : Space) : compactFibreAction 1 x = x := by
+  simp only [compactFibreAction, map_one, fibreMultiplier_one, torusAction_one]
+
+private theorem ToricSpace.compactFibreAction_mul (u v : CompactFibreTorus) (x : Space) :
+    compactFibreAction u (compactFibreAction v x) = compactFibreAction (u * v) x := by
+  simp only [compactFibreAction, map_mul, fibreMultiplier_mul, torusAction_mul]
+
+private instance ToricSpace.compactFibreMulAction : MulAction CompactFibreTorus Space
+    where
+  smul := compactFibreAction
+  one_smul := compactFibreAction_one
+  mul_smul u v x := (compactFibreAction_mul u v x).symm
+
+private theorem ToricSpace.compactFibreAction_continuous :
+    Continuous (fun p : CompactFibreTorus × Space => compactFibreAction p.1 p.2) := by
+  have h :=
+    compactTorusAction_continuous.comp
+      ((compactFibrePhase_continuous.comp continuous_fst).prodMk continuous_snd)
+  exact h.congr (fun _ => (compactFibreAction_eq_compact _ _).symm)
+
+private instance ToricSpace.compactFibreContinuousSMul : ContinuousSMul CompactFibreTorus Space :=
+  ⟨compactFibreAction_continuous⟩
+
+@[simp]
+private theorem ToricSpace.time_compactFibreAction (u : CompactFibreTorus) (x : Space) :
+    time (compactFibreAction u x) = time x :=
+  time_fibreMultiplier _ x
+
+@[simp]
+private theorem ToricSpace.modulus_compactFibreAction (u : CompactFibreTorus) (x : Space) :
+    modulus (compactFibreAction u x) = modulus x := by
+  rw [compactFibreAction_eq_compact, modulus_compactTorusAction]
+
+private def
+    ToricSpace.compactFibreActionShear : CompactFibreTorus × Space ≃ₜ CompactFibreTorus × Space
+    where
+  toFun p := (p.1, p.1 • p.2)
+  invFun p := (p.1, p.1⁻¹ • p.2)
+  left_inv p := by simp
+  right_inv p := by simp
+  continuous_toFun := continuous_fst.prodMk ContinuousSMul.continuous_smul
+  continuous_invFun := continuous_fst.prodMk (continuous_fst.inv.smul continuous_snd)
+
+private theorem ToricSpace.compactFibreAction_isProperMap :
+    IsProperMap (fun p : CompactFibreTorus × Space => compactFibreAction p.1 p.2) :=
+  isProperMap_snd_of_compactSpace.comp compactFibreActionShear.isProperMap
+
+private theorem
+    ToricSpace.torusAction_inclusion_eq_self_iff (u : ActingTorus) (s : ToricFan.Triangle)
+    (z : ToricCharts.CoordinateSpace 3) :
+    torusAction u (ToricSpace.inclusion s z) = ToricSpace.inclusion s z ↔
+      ∀ i, z i ≠ 0 → factors s u i = 1 := by
+  rw [torusAction_inclusion, (inclusion_openEmbedding s).injective.eq_iff]
+  constructor
+  · intro h i hi
+    apply mul_right_cancel₀ hi
+    simpa only [scale, Pi.mul_apply, one_mul] using congrFun h i
+  · intro h
+    funext i
+    change factors s u i * z i = z i
+    by_cases hi : z i = 0
+    · simp only [hi, MulZeroClass.mul_zero]
+    · rw [h i hi, one_mul]
+
+private theorem ToricSpace.compactTorusAction_inclusion_eq_self_iff (u : CompactTorus)
+    (s : ToricFan.Triangle) (z : ToricCharts.CoordinateSpace 3) :
+    compactTorusAction u (ToricSpace.inclusion s z) = ToricSpace.inclusion s z ↔
+      ∀ i, z i ≠ 0 → factors s (compactTorusUnits u) i = 1 :=
+  torusAction_inclusion_eq_self_iff (compactTorusUnits u) s z
+
+private def ToricSpace.rayCompactPhase (v : Fin 2 → ℤ) (a : Circle) : CompactTorus :=
+  ![a ^ v 0, a ^ v 1, a]
+
+@[simp]
+private theorem
+    ToricSpace.rayCompactPhase_two (v : Fin 2 → ℤ) (a : Circle) : rayCompactPhase v a 2 = a :=
+  rfl
+
+private theorem
+    ToricSpace.rayCompactPhase_vertex_coe (s : ToricFan.Triangle) (j : Fin 3) (a : Circle) :
+    (fun i => (rayCompactPhase (s.vertex j) a i : ℂ)) = fun i => (a : ℂ) ^ s.rays i j := by
+  funext i
+  fin_cases i <;> simp [rayCompactPhase, ToricFan.Triangle.vertex]
+
+private theorem
+    ToricSpace.monomial_single_coordinate_phase (A : Matrix (Fin 3) (Fin 3) ℤ) (j : Fin 3)
+    (a : ℂ) : ToricCharts.monomial A (fun k => if k = j then a else 1) = fun i => a ^ A i j := by
+  funext i
+  change (∏ k, (if k = j then a else 1) ^ A i k) = _
+  calc
+    (∏ k, (if k = j then a else 1) ^ A i k) = ∏ k, if k = j then a ^ A i k else 1 := by
+      apply Finset.prod_congr rfl
+      intro k _
+      split_ifs <;> simp
+    _ = a ^ A i j := by simp
+
+private theorem ToricSpace.factors_rayCompactPhase_vertex (s : ToricFan.Triangle) (j : Fin 3)
+    (a : Circle) :
+    factors s (compactTorusUnits (rayCompactPhase (s.vertex j) a)) = fun i =>
+      if i = j then (a : ℂ) else 1 := by
+  let w : ToricCharts.CoordinateSpace 3 := fun i => if i = j then (a : ℂ) else 1
+  have hw : w ∈ ToricCharts.torus := by
+    intro i
+    dsimp [w]
+    split_ifs
+    · exact a.coe_ne_zero
+    · exact one_ne_zero
+  have hv : (fun i => (rayCompactPhase (s.vertex j) a i : ℂ)) = ToricCharts.monomial s.rays w := by
+    rw [rayCompactPhase_vertex_coe]
+    exact (monomial_single_coordinate_phase s.rays j a).symm
+  change ToricCharts.monomial s.dual (fun i => (rayCompactPhase (s.vertex j) a i : ℂ)) = _
+  rw [hv, ToricCharts.monomial_mul_on_torus _ _ hw, ToricFan.Triangle.dual_rays,
+    ToricCharts.monomial_one]
+
+private theorem ToricSpace.rayCompactPhase_fixes_of_mem_rayDivisor (v : Fin 2 → ℤ) (a : Circle)
+    {x : Space} (hx : x ∈ rayDivisor v) : compactTorusAction (rayCompactPhase v a) x = x := by
+  obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+  obtain ⟨j, hj, rfl⟩ := (mem_rayDivisor_inclusion v s z).mp hx
+  apply (compactTorusAction_inclusion_eq_self_iff _ s z).mpr
+  intro i hi
+  have hij : i ≠ j := by
+    intro h
+    subst i
+    exact hi hj
+  rw [factors_rayCompactPhase_vertex]
+  exact ite_eq_right hij
+
+private def
+    CuspHoneycombHexagon.positiveComponentSet (v : Fin 2 → ℤ) : Set (ToricSpace.rayDivisor v) :=
+  Subtype.val ⁻¹' ToricSpace.positivePart
+
+private abbrev CuspHoneycombHexagon.PositiveComponent (v : Fin 2 → ℤ) :=
+  positiveComponentSet v
+
+private abbrev CuspHoneycombHexagon.PositiveE0 :=
+  PositiveComponent 0
+
+private theorem CuspHoneycombHexagon.coordinateModulus_insertZero (j : Fin 3)
+    (z : ToricCharts.CoordinateSpace 2) :
+    ToricCharts.coordinateModulus (ToricComponent.insertZero j z) =
+      ToricComponent.insertZero j (ToricCharts.coordinateModulus z) := by
+  funext k
+  obtain rfl | ⟨i, rfl⟩ := Fin.eq_self_or_eq_succAbove j k
+  · simp [ToricCharts.coordinateModulus]
+  · simp [ToricCharts.coordinateModulus, ToricComponent.insertZero, Fin.insertNth_apply_succAbove]
+
+private theorem CuspHoneycombHexagon.affineInclusion_mem_positive_iff {v : Fin 2 → ℤ}
+    (c : ToricComponent.ChartIndex v) (z : ToricCharts.CoordinateSpace 2) :
+    ToricComponent.affineInclusion c z ∈ positiveComponentSet v ↔
+      z ∈ ToricCharts.nonnegativeCoordinates := by
+  change
+    ToricSpace.modulus
+          (ToricSpace.inclusion c.triangle (ToricComponent.insertZero c.coordinate z)) =
+        ToricSpace.inclusion c.triangle (ToricComponent.insertZero c.coordinate z) ↔
+      _
+  rw [ToricSpace.modulus_inclusion, coordinateModulus_insertZero,
+    (ToricSpace.inclusion_openEmbedding c.triangle).injective.eq_iff, ←
+    ToricCharts.coordinateModulus_eq_self_iff]
+  constructor
+  · intro h
+    simpa only [ToricComponent.removeCoordinate_insertZero] using
+      congrArg (ToricComponent.removeCoordinate c.coordinate) h
+  · intro h
+    exact congrArg (ToricComponent.insertZero c.coordinate) h
+
+private abbrev CuspHoneycombHexagon.PositiveQuadrant :=
+  { r : Fin 2 → ℝ // ∀ i, 0 ≤ r i }
+
+private def
+    CuspHoneycombHexagon.positiveAffineInclusion {v : Fin 2 → ℤ} (c : ToricComponent.ChartIndex v)
+    (r : PositiveQuadrant) : PositiveComponent v :=
+  ⟨ToricComponent.affineInclusion c (fun i => (r.1 i : ℂ)),
+    (affineInclusion_mem_positive_iff c _).mpr ⟨r.1, r.2, rfl⟩⟩
+
+private theorem CuspHoneycombHexagon.twistedTranslate_zero_correction (v : Fin 2 → ℤ)
+    (x : ToricSpace.Space) :
+    ToricSpace.twistedTranslate (fun _ => 0) v x =
+      ToricSpace.translate (ToricSpace.cuspVector v) x := by
+  have he : ToricSpace.exponentialMultiplier (fun _ => 0) v = fun _ => 1 := by
+    funext t
+    ext i
+    simp [ToricSpace.exponentialMultiplier]
+  simp [ToricSpace.twistedTranslate, he]
+
+private theorem CuspHoneycombHexagon.zeroComponent_bounded_chart (x : ToricSpace.rayDivisor 0) :
+    ∃ (i : Fin 6) (z : ToricCharts.CoordinateSpace 2),
+      ‖z‖ ≤ 1 ∧ ToricComponent.affineInclusion (ToricComponent.zeroChart i) z = x := by
+  let C : ℂ → Matrix (Fin 2) (Fin 2) ℂ := fun _ => 0
+  have hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 (1 : ℝ)) := fun _ _ =>
+    contDiffOn_const
+  obtain ⟨ε, hε, _, hε1, hR, hCε⟩ := CuspQuotient.exists_admissible_radius C (by norm_num) hC
+  let a : ToricSpace.Tube (CuspQuotient.disc ε) := CuspQuotient.componentLift ε hε x
+  have ha0 : ToricSpace.time (a : ToricSpace.Space) = 0 :=
+    ToricSpace.time_eq_zero_of_mem_rayDivisor x.2
+  have hrep :=
+    CuspQuotient.mem_quotientRepresentatives C ε hε hε1 hCε hR (half_pos hε) (half_lt_self hε)
+      (x := a)
+      (by
+        rw [ha0, norm_zero]
+        exact (half_pos hε).le)
+  obtain ⟨b, hb, hba⟩ := hrep
+  let := ToricSpace.tubeAction C (CuspQuotient.disc ε)
+  have horb := Quotient.exact hba
+  change b ∈ MulAction.orbit CuspQuotient.LatticeGroup a at horb
+  obtain ⟨g, hg⟩ := horb
+  have hgb :
+    ToricSpace.translate (ToricSpace.cuspVector g.toAdd) (x : ToricSpace.Space) =
+      (b : ToricSpace.Space) := by
+    have h := congrArg Subtype.val hg
+    change
+      ToricSpace.twistedTranslate C g.toAdd (x : ToricSpace.Space) = (b : ToricSpace.Space) at h
+    rwa [show C = (fun _ => 0) from rfl, twistedTranslate_zero_correction] at h
+  change (b : ToricSpace.Space) ∈ CuspQuotient.compactRepresentatives (ε / 2) at hb
+  obtain ⟨s, _hs, z, hz, hzb⟩ := Set.mem_iUnion₂.mp hb
+  have hx :
+    ToricSpace.inclusion (s.shift (-ToricSpace.cuspVector g.toAdd)) z = (x : ToricSpace.Space) := by
+    rw [← ToricSpace.translate_inclusion, hzb, ← hgb, ToricSpace.translate_add]
+    simp
+  obtain ⟨j, hj, hv⟩ := (ToricSpace.mem_rayDivisor_inclusion 0 _ z).mp (hx.symm ▸ x.2)
+  let c : ToricComponent.ChartIndex 0 := ⟨s.shift (-ToricSpace.cuspVector g.toAdd), j, hv⟩
+  obtain ⟨i, hi⟩ := ToricComponent.zeroChart_surjective c
+  refine ⟨i, ToricComponent.removeCoordinate j z, ?_, ?_⟩
+  · have hz1 : ‖z‖ ≤ 1 := by simpa only [Metric.mem_closedBall, dist_zero_right] using hz.1
+    apply (pi_norm_le_iff_of_nonneg (by norm_num : (0 : ℝ) ≤ 1)).mpr
+    intro k
+    exact (norm_le_pi_norm z (j.succAbove k)).trans hz1
+  · rw [hi]
+    apply Subtype.ext
+    change
+      ToricSpace.inclusion (s.shift (-ToricSpace.cuspVector g.toAdd))
+          (ToricComponent.insertZero j (ToricComponent.removeCoordinate j z)) =
+        (x : ToricSpace.Space)
+    rw [ToricComponent.insertZero_removeCoordinate j z hj]
+    exact hx
+
+private theorem CuspHoneycombHexagon.positiveE0_bounded_chart (x : PositiveE0) :
+    ∃ (i : Fin 6) (r : PositiveQuadrant),
+      (∀ k, r.1 k ≤ 1) ∧ positiveAffineInclusion (ToricComponent.zeroChart i) r = x := by
+  obtain ⟨i, z, hz, he⟩ := zeroComponent_bounded_chart x.1
+  have hp :
+    ToricComponent.affineInclusion (ToricComponent.zeroChart i) z ∈ positiveComponentSet 0 :=
+    he.symm ▸ x.2
+  obtain ⟨r, hr, hzr⟩ := (affineInclusion_mem_positive_iff (ToricComponent.zeroChart i) z).mp hp
+  refine ⟨i, ⟨r, hr⟩, ?_, Subtype.ext ?_⟩
+  · intro k
+    have hk := (norm_le_pi_norm z k).trans hz
+    rwa [hzr, Complex.norm_of_nonneg (hr k)] at hk
+  · change ToricComponent.affineInclusion (ToricComponent.zeroChart i) (fun k => (r k : ℂ)) = x.1
+    rw [← hzr]
+    exact he
+
+private def ToricFan.edgeDirection : Fin 3 → (Fin 2 → ℤ) :=
+  ![![1, 0], ![0, 1], ![1, -1] ]
+
+private def ToricFan.AreAdjacent (v w : Fin 2 → ℤ) : Prop :=
+  ∃ i : Fin 3, w - v = edgeDirection i ∨ w - v = -edgeDirection i
+
+private theorem
+    ToricFan.Triangle.vertices_adjacent (s : ToricFan.Triangle) {j k : Fin 3} (hjk : j ≠ k) :
+    ToricFan.AreAdjacent (s.vertex j) (s.vertex k) := by
+  cases hs : s.upper <;> fin_cases j <;> fin_cases k <;>
+    simp_all [ToricFan.AreAdjacent, vertex, rays, ToricFan.edgeDirection, funext_iff,
+      Fin.exists_fin_succ, Fin.forall_fin_succ]
+
+private theorem ToricFan.Triangle.triangle_for_edge (v : Fin 2 → ℤ) (i : Fin 3) :
+    ∃ s : ToricFan.Triangle,
+      ∃ j k : Fin 3, s.vertex j = v ∧ s.vertex k = v + ToricFan.edgeDirection i := by
+  fin_cases i
+  · refine ⟨⟨v 0, v 1, Bool.false⟩, 0, 1, ?_, ?_⟩
+    all_goals ext a; fin_cases a <;> simp [vertex, rays, ToricFan.edgeDirection]
+  · refine ⟨⟨v 0, v 1, Bool.false⟩, 0, 2, ?_, ?_⟩
+    all_goals ext a; fin_cases a <;> simp [vertex, rays, ToricFan.edgeDirection]
+  · refine ⟨⟨v 0, v 1 - 1, Bool.false⟩, 2, 1, ?_, ?_⟩
+    all_goals ext a; fin_cases a <;> simp [vertex, rays, ToricFan.edgeDirection, sub_eq_add_neg]
+
+private theorem ToricFan.Triangle.exists_triangle_of_adjacent {v w : Fin 2 → ℤ}
+    (h : ToricFan.AreAdjacent v w) :
+    ∃ s : ToricFan.Triangle, ∃ j k : Fin 3, s.vertex j = v ∧ s.vertex k = w := by
+  obtain ⟨i, hi | hi⟩ := h
+  · have hw : w = v + ToricFan.edgeDirection i := by
+      exact (sub_eq_iff_eq_add.mp hi).trans (add_comm _ _)
+    obtain ⟨s, j, k, hj, hk⟩ := triangle_for_edge v i
+    exact ⟨s, j, k, hj, hk.trans hw.symm⟩
+  · have hv : v = w + ToricFan.edgeDirection i := by
+      ext a
+      have h := congrFun hi a
+      change w a - v a = -ToricFan.edgeDirection i a at h
+      change v a = w a + ToricFan.edgeDirection i a
+      omega
+    obtain ⟨s, j, k, hj, hk⟩ := triangle_for_edge w i
+    exact ⟨s, k, j, hk.trans hv.symm, hj⟩
+
+private theorem ToricSpace.rayDivisor_inter_nonempty_iff_vertices (v w : Fin 2 → ℤ) :
+    (rayDivisor v ∩ rayDivisor w).Nonempty ↔
+      ∃ s : ToricFan.Triangle, ∃ j k : Fin 3, s.vertex j = v ∧ s.vertex k = w := by
+  constructor
+  · rintro ⟨x, hxv, hxw⟩
+    obtain ⟨s, z, rfl⟩ := inclusion_jointly_surjective x
+    obtain ⟨j, _, hj⟩ := (mem_rayDivisor_inclusion v s z).mp hxv
+    obtain ⟨k, _, hk⟩ := (mem_rayDivisor_inclusion w s z).mp hxw
+    exact ⟨s, j, k, hj, hk⟩
+  · rintro ⟨s, j, k, rfl, rfl⟩
+    exact
+      ⟨ToricSpace.inclusion s 0, (mem_rayDivisor_vertex s j 0).mpr rfl,
+        (mem_rayDivisor_vertex s k 0).mpr rfl⟩
+
+private theorem ToricSpace.rayDivisor_inter_nonempty_iff (v w : Fin 2 → ℤ) (hvw : v ≠ w) :
+    (rayDivisor v ∩ rayDivisor w).Nonempty ↔ ToricFan.AreAdjacent v w := by
+  rw [rayDivisor_inter_nonempty_iff_vertices]
+  constructor
+  · rintro ⟨s, j, k, rfl, rfl⟩
+    exact ToricFan.Triangle.vertices_adjacent s (fun h => hvw (congrArg s.vertex h))
+  · exact ToricFan.Triangle.exists_triangle_of_adjacent
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology1.lean b/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology1.lean
new file mode 100644
index 000000000..e384ba6a4
--- /dev/null
+++ b/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology1.lean
@@ -0,0 +1,220 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+
+/-!
+# Hopf problem: torus homology · period torus higher homology 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.singularHomologyMap_id (X : Type) [TopologicalSpace X] (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (ContinuousMap.id X) n = LinearMap.id := by
+  have h :=
+    ((AlgebraicTopology.singularHomologyFunctor (ModuleCat ℤ) n).obj (ModuleCat.of ℤ ℤ)).map_id
+      (TopCat.of X)
+  exact congrArg ModuleCat.Hom.hom h
+
+public
+theorem PeriodTorusHigherHomology.singularHomologyMap_comp {X Y Z : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] [TopologicalSpace Z] (f : C(X, Y)) (g : C(Y, Z)) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (g.comp f) n =
+      (SingularMayerVietoris.singularHomologyMap g n).comp
+        (SingularMayerVietoris.singularHomologyMap f n) := by
+  have h :=
+    ((AlgebraicTopology.singularHomologyFunctor (ModuleCat ℤ) n).obj (ModuleCat.of ℤ ℤ)).map_comp
+      (TopCat.ofHom f) (TopCat.ofHom g)
+  exact congrArg ModuleCat.Hom.hom h
+
+private def PeriodTorusHigherHomology.singularChainHomotopy {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] {f g : C(X, Y)} (H : f.Homotopy g) :
+    _root_.Homotopy (FirstHurewicz.singularChainMap f) (FirstHurewicz.singularChainMap g) :=
+  TopCat.Homotopy.singularChainComplexFunctorObjMap (f := TopCat.ofHom f) (g := TopCat.ofHom g) H
+    (ModuleCat.of ℤ ℤ)
+
+private theorem PeriodTorusHigherHomology.homotopy_homologyMap {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] {f g : C(X, Y)} (H : f.Homotopy g) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap f n =
+      SingularMayerVietoris.singularHomologyMap g n :=
+  congrArg ModuleCat.Hom.hom ((singularChainHomotopy H).homologyMap_eq n)
+
+private theorem PeriodTorusHigherHomology.homotopic_homologyMap {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] {f g : C(X, Y)} (h : f.Homotopic g) (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap f n =
+      SingularMayerVietoris.singularHomologyMap g n := by
+  obtain ⟨H⟩ := h
+  exact homotopy_homologyMap H n
+
+private def PeriodTorusHigherHomology.homotopyInverseHomologyEquiv {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (g : C(Y, X))
+    (hgf : (g.comp f).Homotopic (ContinuousMap.id X))
+    (hfg : (f.comp g).Homotopic (ContinuousMap.id Y)) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology X n ≃ₗ[ℤ] SingularMayerVietoris.SingularHomology Y n
+    where
+  toLinearMap := SingularMayerVietoris.singularHomologyMap f n
+  invFun := SingularMayerVietoris.singularHomologyMap g n
+  left_inv
+    a := by
+    have h := homotopic_homologyMap hgf n
+    rw [singularHomologyMap_comp, singularHomologyMap_id] at h
+    exact LinearMap.congr_fun h a
+  right_inv
+    a := by
+    have h := homotopic_homologyMap hfg n
+    rw [singularHomologyMap_comp, singularHomologyMap_id] at h
+    exact LinearMap.congr_fun h a
+
+private def PeriodTorusHigherHomology.homotopyEquivHomologyEquiv {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (e : X ≃ₕ Y) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology X n ≃ₗ[ℤ] SingularMayerVietoris.SingularHomology Y n :=
+  homotopyInverseHomologyEquiv e.toFun e.invFun e.left_inv e.right_inv n
+
+@[simp]
+private theorem PeriodTorusHigherHomology.homotopyEquivHomologyEquiv_toLinearMap {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (e : X ≃ₕ Y) (n : ℕ) :
+    (homotopyEquivHomologyEquiv e n).toLinearMap =
+      SingularMayerVietoris.singularHomologyMap e.toFun n :=
+  rfl
+
+@[simp]
+private theorem PeriodTorusHigherHomology.homotopyEquivHomologyEquiv_apply {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (e : X ≃ₕ Y) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology X n) :
+    homotopyEquivHomologyEquiv e n a = SingularMayerVietoris.singularHomologyMap e.toFun n a :=
+  rfl
+
+@[simp]
+private theorem PeriodTorusHigherHomology.homotopyEquivHomologyEquiv_symm_apply {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (e : X ≃ₕ Y) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology Y n) :
+    (homotopyEquivHomologyEquiv e n).symm a =
+      SingularMayerVietoris.singularHomologyMap e.symm.toFun n a :=
+  rfl
+
+private def PeriodTorusHigherHomology.homeomorphHomologyEquiv {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (e : X ≃ₜ Y) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology X n ≃ₗ[ℤ] SingularMayerVietoris.SingularHomology Y n :=
+  homotopyEquivHomologyEquiv e.toHomotopyEquiv n
+
+@[simp]
+private theorem PeriodTorusHigherHomology.homeomorphHomologyEquiv_toLinearMap {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (e : X ≃ₜ Y) (n : ℕ) :
+    (homeomorphHomologyEquiv e n).toLinearMap =
+      SingularMayerVietoris.singularHomologyMap (e : C(X, Y)) n :=
+  rfl
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv_apply {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (e : X ≃ₜ Y) (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    homeomorphHomologyEquiv e n a = SingularMayerVietoris.singularHomologyMap (e : C(X, Y)) n a :=
+  rfl
+
+@[simp]
+private theorem PeriodTorusHigherHomology.homeomorphHomologyEquiv_symm_apply {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (e : X ≃ₜ Y) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology Y n) :
+    (homeomorphHomologyEquiv e n).symm a =
+      SingularMayerVietoris.singularHomologyMap (e.symm : C(Y, X)) n a :=
+  rfl
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv_symm {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (e : X ≃ₜ Y) (n : ℕ) :
+    (homeomorphHomologyEquiv e n).symm = homeomorphHomologyEquiv e.symm n := by
+  apply LinearEquiv.ext
+  intro a
+  rfl
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.homeomorphHomologyEquiv_refl (X : Type) [TopologicalSpace X]
+    (n : ℕ) :
+    homeomorphHomologyEquiv (Homeomorph.refl X) n =
+      LinearEquiv.refl ℤ (SingularMayerVietoris.SingularHomology X n) := by
+  apply LinearEquiv.ext
+  intro a
+  change SingularMayerVietoris.singularHomologyMap (ContinuousMap.id X) n a = a
+  rw [singularHomologyMap_id]
+  rfl
+
+private theorem PeriodTorusHigherHomology.homeomorphHomologyEquiv_trans {X Y Z : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace Z] (e : X ≃ₜ Y) (f : Y ≃ₜ Z)
+    (n : ℕ) :
+    homeomorphHomologyEquiv (e.trans f) n =
+      (homeomorphHomologyEquiv e n).trans (homeomorphHomologyEquiv f n) := by
+  apply LinearEquiv.ext
+  intro a
+  change
+    SingularMayerVietoris.singularHomologyMap ((f : C(Y, Z)).comp (e : C(X, Y))) n a =
+      SingularMayerVietoris.singularHomologyMap (f : C(Y, Z)) n
+        (SingularMayerVietoris.singularHomologyMap (e : C(X, Y)) n a)
+  rw [singularHomologyMap_comp]
+  rfl
+
+private def PeriodTorusHigherHomology.connectedHomologyZeroEquiv (X : Type) [TopologicalSpace X]
+    [PathConnectedSpace X] : SingularMayerVietoris.SingularHomology X 0 ≃ₗ[ℤ] ℤ :=
+  (CategoryTheory.asIso ((TopCat.of X).singularHomology₀ε (ModuleCat.of ℤ ℤ))).toLinearEquiv
+
+private theorem PeriodTorusHigherHomology.totallyDisconnected_homology_isZero (X : Type)
+    [TopologicalSpace X] [TotallyDisconnectedSpace X] (n : ℕ) (hn : n ≠ 0) :
+    CategoryTheory.Limits.IsZero (SingularMayerVietoris.SingularHomology X n) :=
+  AlgebraicTopology.isZero_singularHomologyFunctor_of_totallyDisconnectedSpace (ModuleCat ℤ) n
+    (ModuleCat.of ℤ ℤ) (TopCat.of X) hn
+
+private theorem PeriodTorusHigherHomology.totallyDisconnected_homology_subsingleton (X : Type)
+    [TopologicalSpace X] [TotallyDisconnectedSpace X] (n : ℕ) (hn : n ≠ 0) :
+    Subsingleton (SingularMayerVietoris.SingularHomology X n) :=
+  ModuleCat.subsingleton_of_isZero (totallyDisconnected_homology_isZero X n hn)
+
+private abbrev PeriodTorusHigherHomology.pointHomologyZeroEquiv :
+    SingularMayerVietoris.SingularHomology Unit 0 ≃ₗ[ℤ] ℤ :=
+  connectedHomologyZeroEquiv Unit
+
+private theorem PeriodTorusHigherHomology.point_homology_subsingleton (n : ℕ) (hn : n ≠ 0) :
+    Subsingleton (SingularMayerVietoris.SingularHomology Unit n) :=
+  totallyDisconnected_homology_subsingleton Unit n hn
+
+private def PeriodTorusHigherHomology.contractibleHomologyEquivPoint (X : Type) [TopologicalSpace X]
+    [ContractibleSpace X] (n : ℕ) :
+    SingularMayerVietoris.SingularHomology X n ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology Unit n :=
+  homotopyEquivHomologyEquiv (Classical.choice (ContractibleSpace.hequiv_unit X)) n
+
+private theorem PeriodTorusHigherHomology.contractible_homology_subsingleton (X : Type)
+    [TopologicalSpace X] [ContractibleSpace X] (n : ℕ) (hn : n ≠ 0) :
+    Subsingleton (SingularMayerVietoris.SingularHomology X n) := by
+  let := point_homology_subsingleton n hn
+  exact (contractibleHomologyEquivPoint X n).injective.subsingleton
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology2.lean b/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology2.lean
new file mode 100644
index 000000000..ab42589a2
--- /dev/null
+++ b/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology2.lean
@@ -0,0 +1,1343 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+
+/-!
+# Hopf problem: torus homology · period torus higher homology 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem PeriodTorusHigherHomology.splitExactPair_injective_mo1973_4431 {A B C : Type*}
+    [AddCommGroup A] [AddCommGroup B] [AddCommGroup C] [Module ℤ A] [Module ℤ B] [Module ℤ C]
+    (i : A →ₗ[ℤ] B) (p : B →ₗ[ℤ] A) (d : B →ₗ[ℤ] C) (hpi : p.comp i = LinearMap.id)
+    (hex : LinearMap.range i = LinearMap.ker d) : Function.Injective (p.prod d) := by
+  intro b b' h
+  have hp : p b = p b' := congrArg Prod.fst h
+  have hd : d b = d b' := congrArg Prod.snd h
+  have hb : b - b' ∈ LinearMap.ker d := by
+    change d (b - b') = 0
+    rw [map_sub, hd, sub_self]
+  rw [← hex] at hb
+  obtain ⟨a, ha⟩ := hb
+  have hpa : p (i a) = a := LinearMap.congr_fun hpi a
+  have ha0 : a = 0 := by
+    calc
+      a = p (i a) := hpa.symm
+      _ = p (b - b') := (congrArg p ha)
+      _ = 0 := by rw [map_sub, hp, sub_self]
+  have hdiff : b - b' = 0 := by rw [← ha, ha0, map_zero]
+  exact sub_eq_zero.mp hdiff
+
+private theorem PeriodTorusHigherHomology.splitExactPair_surjective_mo1973_4432 {A B C : Type*}
+    [AddCommGroup A] [AddCommGroup B] [AddCommGroup C] [Module ℤ A] [Module ℤ B] [Module ℤ C]
+    (i : A →ₗ[ℤ] B) (p : B →ₗ[ℤ] A) (d : B →ₗ[ℤ] C) (hpi : p.comp i = LinearMap.id)
+    (hex : LinearMap.range i = LinearMap.ker d) (hsurj : Function.Surjective d) :
+    Function.Surjective (p.prod d) := by
+  rintro ⟨a, c⟩
+  obtain ⟨b, hb⟩ := hsurj c
+  refine ⟨b + i (a - p b), ?_⟩
+  apply Prod.ext
+  · change p (b + i (a - p b)) = a
+    have hpa : p (i (a - p b)) = a - p b := LinearMap.congr_fun hpi (a - p b)
+    rw [map_add, hpa, ← add_sub_assoc, add_comm (p b) a, add_sub_cancel_right]
+  · change d (b + i (a - p b)) = c
+    have hi : i (a - p b) ∈ LinearMap.range i := ⟨a - p b, rfl⟩
+    rw [hex] at hi
+    have hdi : d (i (a - p b)) = 0 := hi
+    rw [map_add, hdi, add_zero, hb]
+
+private def
+    PeriodTorusHigherHomology.splitExactEquiv {A B C : Type*} [AddCommGroup A] [AddCommGroup B]
+    [AddCommGroup C] [Module ℤ A] [Module ℤ B] [Module ℤ C] (i : A →ₗ[ℤ] B) (p : B →ₗ[ℤ] A)
+    (d : B →ₗ[ℤ] C) (hpi : p.comp i = LinearMap.id) (hex : LinearMap.range i = LinearMap.ker d)
+    (hsurj : Function.Surjective d) : B ≃ₗ[ℤ] (A × C) :=
+  ({
+        Equiv.ofBijective (fun b : B => (p b, d b))
+          ⟨splitExactPair_injective_mo1973_4431 i p d hpi hex,
+            splitExactPair_surjective_mo1973_4432 i p d hpi hex hsurj⟩ with
+        map_add' b b' := Prod.ext (map_add p b b') (map_add d b b') } :
+      B ≃+ (A × C)).toIntLinearEquiv
+
+@[simp]
+private theorem PeriodTorusHigherHomology.splitExactEquiv_apply {A B C : Type*} [AddCommGroup A]
+    [AddCommGroup B] [AddCommGroup C] [Module ℤ A] [Module ℤ B] [Module ℤ C] (i : A →ₗ[ℤ] B)
+    (p : B →ₗ[ℤ] A) (d : B →ₗ[ℤ] C) (hpi : p.comp i = LinearMap.id)
+    (hex : LinearMap.range i = LinearMap.ker d) (hsurj : Function.Surjective d) (b : B) :
+    splitExactEquiv i p d hpi hex hsurj b = (p b, d b) :=
+  rfl
+
+private theorem
+    PeriodTorusHigherHomology.splitExactEquiv_apply_inclusion {A B C : Type*} [AddCommGroup A]
+    [AddCommGroup B] [AddCommGroup C] [Module ℤ A] [Module ℤ B] [Module ℤ C] (i : A →ₗ[ℤ] B)
+    (p : B →ₗ[ℤ] A) (d : B →ₗ[ℤ] C) (hpi : p.comp i = LinearMap.id)
+    (hex : LinearMap.range i = LinearMap.ker d) (hsurj : Function.Surjective d) (a : A) :
+    splitExactEquiv i p d hpi hex hsurj (i a) = (a, 0) := by
+  have hpa : p (i a) = a := LinearMap.congr_fun hpi a
+  have hi : i a ∈ LinearMap.range i := ⟨a, rfl⟩
+  rw [hex] at hi
+  have hdi : d (i a) = 0 := hi
+  rw [splitExactEquiv_apply, hpa, hdi]
+
+private def
+    PeriodTorusHigherHomology.intLinearMapOfAddHom {A B : Type*} [AddCommGroup A] [AddCommGroup B]
+    {modA : Module ℤ A} {modB : Module ℤ B} (f : A →+ B) : A →ₗ[ℤ] B
+    where
+  toFun := f
+  map_add' := f.map_add
+  map_smul' n
+    a := by
+    change f (modA.smul n a) = modB.smul n (f a)
+    rw [int_smul_eq_zsmul, int_smul_eq_zsmul]
+    exact f.map_zsmul n a
+
+private def PeriodTorusHigherHomology.pairSumMap (A : Type*) [AddCommGroup A] [Module ℤ A] :
+    (A × A) →ₗ[ℤ] A :=
+  intLinearMapOfAddHom
+    { toFun ac := ac.1 + ac.2
+      map_zero' := add_zero 0
+      map_add' ac bd := add_add_add_comm ac.1 bd.1 ac.2 bd.2 }
+
+private def PeriodTorusHigherHomology.negativeFirstMap (A : Type*) [AddCommGroup A] [Module ℤ A] :
+    (A × A) →ₗ[ℤ] A :=
+  intLinearMapOfAddHom
+    { toFun ac := -ac.1
+      map_zero' := neg_zero
+      map_add' ac bd := neg_add ac.1 bd.1 }
+
+@[simp]
+private theorem PeriodTorusHigherHomology.pairSumMap_apply (A : Type*) [AddCommGroup A] [Module ℤ A]
+    (ac : A × A) : pairSumMap A ac = ac.1 + ac.2 :=
+  rfl
+
+private theorem PeriodTorusHigherHomology.circleBoundary_sum_eq_zero {A : Type*} [AddCommGroup A]
+    [Module ℤ A] {B : Type*} [AddCommGroup B] [Module ℤ B] (δ : B →ₗ[ℤ] (A × A))
+    (hrange : LinearMap.range δ = LinearMap.ker (pairSumMap A)) (b : B) : (δ b).1 + (δ b).2 = 0 :=
+  by
+  have hb : δ b ∈ LinearMap.range δ := ⟨b, rfl⟩
+  rw [hrange] at hb
+  exact hb
+
+private theorem
+    PeriodTorusHigherHomology.circleBoundary_negativeFirst_ker {A : Type*} [AddCommGroup A]
+    [Module ℤ A] {B : Type*} [AddCommGroup B] [Module ℤ B] (δ : B →ₗ[ℤ] (A × A))
+    (hrange : LinearMap.range δ = LinearMap.ker (pairSumMap A)) :
+    LinearMap.ker ((negativeFirstMap A).comp δ) = LinearMap.ker δ := by
+  ext b
+  change -(δ b).1 = 0 ↔ δ b = 0
+  constructor
+  · intro hb
+    have hfst : (δ b).1 = 0 := neg_eq_zero.mp hb
+    have hsnd := circleBoundary_sum_eq_zero δ hrange b
+    rw [hfst, zero_add] at hsnd
+    exact Prod.ext hfst hsnd
+  · intro hb
+    rw [hb]
+    exact neg_zero
+
+private theorem PeriodTorusHigherHomology.circleBoundary_negativeFirst_surjective {A : Type*}
+    [AddCommGroup A] [Module ℤ A] {B : Type*} [AddCommGroup B] [Module ℤ B] (δ : B →ₗ[ℤ] (A × A))
+    (hrange : LinearMap.range δ = LinearMap.ker (pairSumMap A)) :
+    Function.Surjective ((negativeFirstMap A).comp δ) := by
+  intro a
+  have ha : (-a, a) ∈ LinearMap.ker (pairSumMap A) := neg_add_cancel a
+  rw [← hrange] at ha
+  obtain ⟨b, hb⟩ := ha
+  refine ⟨b, ?_⟩
+  change -(δ b).1 = a
+  rw [hb]
+  exact neg_neg a
+
+private def
+    PeriodTorusHigherHomology.circleSplitExactEquiv {A : Type*} [AddCommGroup A] [Module ℤ A]
+    {B P : Type*} [AddCommGroup B] [AddCommGroup P] [Module ℤ B] [Module ℤ P] (i : P →ₗ[ℤ] B)
+    (p : B →ₗ[ℤ] P) (δ : B →ₗ[ℤ] (A × A)) (hpi : p.comp i = LinearMap.id)
+    (hker : LinearMap.range i = LinearMap.ker δ)
+    (hrange : LinearMap.range δ = LinearMap.ker (pairSumMap A)) : B ≃ₗ[ℤ] (P × A) :=
+  splitExactEquiv i p ((negativeFirstMap A).comp δ) hpi
+    (hker.trans (circleBoundary_negativeFirst_ker δ hrange).symm)
+    (circleBoundary_negativeFirst_surjective δ hrange)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.circleSplitExactEquiv_apply_inclusion {A : Type*}
+    [AddCommGroup A] [Module ℤ A] {B P : Type*} [AddCommGroup B] [AddCommGroup P] [Module ℤ B]
+    [Module ℤ P] (i : P →ₗ[ℤ] B) (p : B →ₗ[ℤ] P) (δ : B →ₗ[ℤ] (A × A))
+    (hpi : p.comp i = LinearMap.id) (hker : LinearMap.range i = LinearMap.ker δ)
+    (hrange : LinearMap.range δ = LinearMap.ker (pairSumMap A)) (a : P) :
+    circleSplitExactEquiv i p δ hpi hker hrange (i a) = (a, 0) :=
+  splitExactEquiv_apply_inclusion i p ((negativeFirstMap A).comp δ) hpi
+    (hker.trans (circleBoundary_negativeFirst_ker δ hrange).symm)
+    (circleBoundary_negativeFirst_surjective δ hrange) a
+
+private def
+    PeriodTorusHigherHomology.sumInlMap (X Y : Type) [TopologicalSpace X] [TopologicalSpace Y] :
+    C(X, X ⊕ Y) :=
+  ⟨Sum.inl, continuous_inl⟩
+
+private def
+    PeriodTorusHigherHomology.sumInrMap (X Y : Type) [TopologicalSpace X] [TopologicalSpace Y] :
+    C(Y, X ⊕ Y) :=
+  ⟨Sum.inr, continuous_inr⟩
+
+private def
+    PeriodTorusHigherHomology.sumElimMap {X Y Z : Type} [TopologicalSpace X] [TopologicalSpace Y]
+    [TopologicalSpace Z] (f : C(X, Z)) (g : C(Y, Z)) : C(X ⊕ Y, Z) :=
+  ⟨Sum.elim f g, f.continuous.sumElim g.continuous⟩
+
+private theorem
+    PeriodTorusHigherHomology.singularSimplex_sum_split (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) (σ : FirstHurewicz.SingularSimplex (X ⊕ Y) n) :
+    (∃ τ : FirstHurewicz.SingularSimplex X n, σ = (sumInlMap X Y).comp τ) ∨
+      (∃ τ : FirstHurewicz.SingularSimplex Y n, σ = (sumInrMap X Y).comp τ) := by
+  rcases Sum.isConnected_iff.mp (isConnected_range σ.continuous) with ⟨s, _, hs⟩ | ⟨s, _, hs⟩
+  · have hr : Set.range σ ⊆ Set.range (Sum.inl : X → X ⊕ Y) :=
+      hs.trans_subset (Set.image_subset_range _ _)
+    obtain ⟨g, hg⟩ := Set.range_subset_range_iff_exists_comp.mp hr
+    have hc : Continuous g := Topology.IsEmbedding.inl.continuous_iff.mpr (hg ▸ σ.continuous)
+    exact Or.inl ⟨⟨g, hc⟩, ContinuousMap.ext (congrFun hg)⟩
+  · have hr : Set.range σ ⊆ Set.range (Sum.inr : Y → X ⊕ Y) :=
+      hs.trans_subset (Set.image_subset_range _ _)
+    obtain ⟨g, hg⟩ := Set.range_subset_range_iff_exists_comp.mp hr
+    have hc : Continuous g := Topology.IsEmbedding.inr.continuous_iff.mpr (hg ▸ σ.continuous)
+    exact Or.inr ⟨⟨g, hc⟩, ContinuousMap.ext (congrFun hg)⟩
+
+private def
+    PeriodTorusHigherHomology.sumSimplexMap (X Y : Type) [TopologicalSpace X] [TopologicalSpace Y]
+    (n : ℕ) :
+    FirstHurewicz.SingularSimplex X n ⊕ FirstHurewicz.SingularSimplex Y n →
+      FirstHurewicz.SingularSimplex (X ⊕ Y) n :=
+  Sum.elim ((sumInlMap X Y).comp) ((sumInrMap X Y).comp)
+
+private theorem PeriodTorusHigherHomology.sumSimplexMap_injective (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) : Function.Injective (sumSimplexMap X Y n) := by
+  classical
+  let z : stdSimplex ℝ (Fin (n + 1)) := Classical.choice inferInstance
+  intro σ τ h
+  cases σ with
+  | inl σ =>
+    cases τ with
+    | inl τ =>
+      congr 1
+      exact ContinuousMap.ext fun t => Sum.inl.inj (congrArg (fun f => f t) h)
+    | inr τ => exact False.elim (Sum.inl_ne_inr (congrArg (fun f => f z) h))
+  | inr σ =>
+    cases τ with
+    | inl τ => exact False.elim (Sum.inr_ne_inl (congrArg (fun f => f z) h))
+    | inr τ =>
+      congr 1
+      exact ContinuousMap.ext fun t => Sum.inr.inj (congrArg (fun f => f t) h)
+
+private theorem PeriodTorusHigherHomology.sumSimplexMap_surjective (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) : Function.Surjective (sumSimplexMap X Y n) := by
+  intro σ
+  rcases singularSimplex_sum_split X Y n σ with ⟨τ, hτ⟩ | ⟨τ, hτ⟩
+  · exact ⟨Sum.inl τ, hτ.symm⟩
+  · exact ⟨Sum.inr τ, hτ.symm⟩
+
+private def PeriodTorusHigherHomology.sumSimplexEquiv (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) :
+    FirstHurewicz.SingularSimplex X n ⊕ FirstHurewicz.SingularSimplex Y n ≃
+      FirstHurewicz.SingularSimplex (X ⊕ Y) n :=
+  Equiv.ofBijective (sumSimplexMap X Y n)
+    ⟨sumSimplexMap_injective X Y n, sumSimplexMap_surjective X Y n⟩
+
+@[simp]
+private theorem PeriodTorusHigherHomology.sumSimplexEquiv_symm_inl (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) (σ : FirstHurewicz.SingularSimplex X n) :
+    (sumSimplexEquiv X Y n).symm ((sumInlMap X Y).comp σ) = Sum.inl σ :=
+  (sumSimplexEquiv X Y n).symm_apply_apply (Sum.inl σ)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.sumSimplexEquiv_symm_inr (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) (σ : FirstHurewicz.SingularSimplex Y n) :
+    (sumSimplexEquiv X Y n).symm ((sumInrMap X Y).comp σ) = Sum.inr σ :=
+  (sumSimplexEquiv X Y n).symm_apply_apply (Sum.inr σ)
+
+private def PeriodTorusHigherHomology.sumChainComplexMap (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] :
+    FirstHurewicz.singularComplex X ⊞ FirstHurewicz.singularComplex Y ⟶
+      FirstHurewicz.singularComplex (X ⊕ Y) :=
+  CategoryTheory.Limits.biprod.desc (FirstHurewicz.singularChainMap (sumInlMap X Y))
+    (FirstHurewicz.singularChainMap (sumInrMap X Y))
+
+private def PeriodTorusHigherHomology.sumChainInverseDegree_mo1973_4506 (X Y : Type)
+    [TopologicalSpace X] [TopologicalSpace Y] (n : ℕ) :
+    FirstHurewicz.Chains (X ⊕ Y) n →ₗ[ℤ]
+      (FirstHurewicz.singularComplex X ⊞ FirstHurewicz.singularComplex Y).X n :=
+  FirstHurewicz.chainLift (X ⊕ Y) n fun σ =>
+    Sum.elim
+      (fun τ =>
+        (CategoryTheory.Limits.biprod.inl :
+                FirstHurewicz.singularComplex X ⟶
+                  FirstHurewicz.singularComplex X ⊞ FirstHurewicz.singularComplex Y).f
+            n |>.hom
+          (FirstHurewicz.simplexChain X n τ))
+      (fun τ =>
+        (CategoryTheory.Limits.biprod.inr :
+                FirstHurewicz.singularComplex Y ⟶
+                  FirstHurewicz.singularComplex X ⊞ FirstHurewicz.singularComplex Y).f
+            n |>.hom
+          (FirstHurewicz.simplexChain Y n τ))
+      ((sumSimplexEquiv X Y n).symm σ)
+
+private theorem PeriodTorusHigherHomology.sumChainInverseDegree_inl_mo1973_4507 (X Y : Type)
+    [TopologicalSpace X] [TopologicalSpace Y] (n : ℕ) (σ : FirstHurewicz.SingularSimplex X n) :
+    sumChainInverseDegree_mo1973_4506 X Y n
+        (FirstHurewicz.simplexChain (X ⊕ Y) n ((sumInlMap X Y).comp σ)) =
+      ((CategoryTheory.Limits.biprod.inl :
+                FirstHurewicz.singularComplex X ⟶
+                  FirstHurewicz.singularComplex X ⊞ FirstHurewicz.singularComplex Y).f
+            n).hom
+        (FirstHurewicz.simplexChain X n σ) := by
+  simp only [sumChainInverseDegree_mo1973_4506, FirstHurewicz.chainLift_simplex,
+    sumSimplexEquiv_symm_inl, Sum.elim_inl]
+
+private theorem PeriodTorusHigherHomology.sumChainInverseDegree_inr_mo1973_4508 (X Y : Type)
+    [TopologicalSpace X] [TopologicalSpace Y] (n : ℕ) (σ : FirstHurewicz.SingularSimplex Y n) :
+    sumChainInverseDegree_mo1973_4506 X Y n
+        (FirstHurewicz.simplexChain (X ⊕ Y) n ((sumInrMap X Y).comp σ)) =
+      ((CategoryTheory.Limits.biprod.inr :
+                FirstHurewicz.singularComplex Y ⟶
+                  FirstHurewicz.singularComplex X ⊞ FirstHurewicz.singularComplex Y).f
+            n).hom
+        (FirstHurewicz.simplexChain Y n σ) := by
+  simp only [sumChainInverseDegree_mo1973_4506, FirstHurewicz.chainLift_simplex,
+    sumSimplexEquiv_symm_inr, Sum.elim_inr]
+
+private theorem PeriodTorusHigherHomology.sumChainComplexMap_comp_inverse_mo1973_4509 (X Y : Type)
+    [TopologicalSpace X] [TopologicalSpace Y] (n : ℕ) :
+    (sumChainComplexMap X Y).f n ≫ ModuleCat.ofHom (sumChainInverseDegree_mo1973_4506 X Y n) =
+      𝟙 ((FirstHurewicz.singularComplex X ⊞ FirstHurewicz.singularComplex Y).X n) := by
+  apply HomologicalComplex.biprodX_ext_from
+  · calc
+      _ =
+          ((CategoryTheory.Limits.biprod.inl :
+                    FirstHurewicz.singularComplex X ⟶
+                      FirstHurewicz.singularComplex X ⊞ FirstHurewicz.singularComplex Y).f
+                n ≫
+              (sumChainComplexMap X Y).f n) ≫
+            ModuleCat.ofHom (sumChainInverseDegree_mo1973_4506 X Y n) :=
+        (CategoryTheory.Category.assoc _ _ _).symm
+      _ =
+          (FirstHurewicz.singularChainMap (sumInlMap X Y)).f n ≫
+            ModuleCat.ofHom (sumChainInverseDegree_mo1973_4506 X Y n) :=
+        (congrArg
+          (fun f : FirstHurewicz.Chains X n ⟶ FirstHurewicz.Chains (X ⊕ Y) n =>
+            f ≫ ModuleCat.ofHom (sumChainInverseDegree_mo1973_4506 X Y n))
+          (HomologicalComplex.biprod_inl_desc_f (FirstHurewicz.singularChainMap (sumInlMap X Y))
+            (FirstHurewicz.singularChainMap (sumInrMap X Y)) n))
+      _ = _ := by
+        apply ModuleCat.hom_ext
+        apply FirstHurewicz.chainMap_ext X n
+        intro σ
+        change
+          sumChainInverseDegree_mo1973_4506 X Y n
+              (FirstHurewicz.inducedChain (sumInlMap X Y) n (FirstHurewicz.simplexChain X n σ)) =
+            _
+        rw [FirstHurewicz.inducedChain_simplex, sumChainInverseDegree_inl_mo1973_4507,
+          CategoryTheory.Category.comp_id]
+  · calc
+      _ =
+          ((CategoryTheory.Limits.biprod.inr :
+                    FirstHurewicz.singularComplex Y ⟶
+                      FirstHurewicz.singularComplex X ⊞ FirstHurewicz.singularComplex Y).f
+                n ≫
+              (sumChainComplexMap X Y).f n) ≫
+            ModuleCat.ofHom (sumChainInverseDegree_mo1973_4506 X Y n) :=
+        (CategoryTheory.Category.assoc _ _ _).symm
+      _ =
+          (FirstHurewicz.singularChainMap (sumInrMap X Y)).f n ≫
+            ModuleCat.ofHom (sumChainInverseDegree_mo1973_4506 X Y n) :=
+        (congrArg
+          (fun f : FirstHurewicz.Chains Y n ⟶ FirstHurewicz.Chains (X ⊕ Y) n =>
+            f ≫ ModuleCat.ofHom (sumChainInverseDegree_mo1973_4506 X Y n))
+          (HomologicalComplex.biprod_inr_desc_f (FirstHurewicz.singularChainMap (sumInlMap X Y))
+            (FirstHurewicz.singularChainMap (sumInrMap X Y)) n))
+      _ = _ := by
+        apply ModuleCat.hom_ext
+        apply FirstHurewicz.chainMap_ext Y n
+        intro σ
+        change
+          sumChainInverseDegree_mo1973_4506 X Y n
+              (FirstHurewicz.inducedChain (sumInrMap X Y) n (FirstHurewicz.simplexChain Y n σ)) =
+            _
+        rw [FirstHurewicz.inducedChain_simplex, sumChainInverseDegree_inr_mo1973_4508,
+          CategoryTheory.Category.comp_id]
+
+private theorem PeriodTorusHigherHomology.sumChainInverse_comp_map_mo1973_4510 (X Y : Type)
+    [TopologicalSpace X] [TopologicalSpace Y] (n : ℕ) :
+    ModuleCat.ofHom (sumChainInverseDegree_mo1973_4506 X Y n) ≫ (sumChainComplexMap X Y).f n =
+      𝟙 (FirstHurewicz.Chains (X ⊕ Y) n) := by
+  apply ModuleCat.hom_ext
+  apply FirstHurewicz.chainMap_ext (X ⊕ Y) n
+  intro σ
+  rcases singularSimplex_sum_split X Y n σ with ⟨τ, rfl⟩ | ⟨τ, rfl⟩
+  · change
+      ((sumChainComplexMap X Y).f n).hom
+          (sumChainInverseDegree_mo1973_4506 X Y n
+            (FirstHurewicz.simplexChain (X ⊕ Y) n ((sumInlMap X Y).comp τ))) =
+        _
+    rw [sumChainInverseDegree_inl_mo1973_4507]
+    exact
+      (congrArg (fun f => f.hom (FirstHurewicz.simplexChain X n τ))
+            (HomologicalComplex.biprod_inl_desc_f (FirstHurewicz.singularChainMap (sumInlMap X Y))
+              (FirstHurewicz.singularChainMap (sumInrMap X Y)) n)).trans
+        (FirstHurewicz.inducedChain_simplex (sumInlMap X Y) n τ)
+  · change
+      ((sumChainComplexMap X Y).f n).hom
+          (sumChainInverseDegree_mo1973_4506 X Y n
+            (FirstHurewicz.simplexChain (X ⊕ Y) n ((sumInrMap X Y).comp τ))) =
+        _
+    rw [sumChainInverseDegree_inr_mo1973_4508]
+    exact
+      (congrArg (fun f => f.hom (FirstHurewicz.simplexChain Y n τ))
+            (HomologicalComplex.biprod_inr_desc_f (FirstHurewicz.singularChainMap (sumInlMap X Y))
+              (FirstHurewicz.singularChainMap (sumInrMap X Y)) n)).trans
+        (FirstHurewicz.inducedChain_simplex (sumInrMap X Y) n τ)
+
+private theorem PeriodTorusHigherHomology.sumChainComplexMap_component_isIso_mo1973_4511
+    (X Y : Type) [TopologicalSpace X] [TopologicalSpace Y] (n : ℕ) :
+    CategoryTheory.IsIso ((sumChainComplexMap X Y).f n) :=
+  ⟨⟨ModuleCat.ofHom (sumChainInverseDegree_mo1973_4506 X Y n),
+      sumChainComplexMap_comp_inverse_mo1973_4509 X Y n,
+      sumChainInverse_comp_map_mo1973_4510 X Y n⟩⟩
+
+private def PeriodTorusHigherHomology.sumChainComplexIso (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] :
+    FirstHurewicz.singularComplex X ⊞ FirstHurewicz.singularComplex Y ≅
+      FirstHurewicz.singularComplex (X ⊕ Y) := by
+  letI (n : ℕ) : CategoryTheory.IsIso ((sumChainComplexMap X Y).f n) :=
+    sumChainComplexMap_component_isIso_mo1973_4511 X Y n
+  letI : CategoryTheory.IsIso (sumChainComplexMap X Y) :=
+    HomologicalComplex.Hom.isIso_of_components (sumChainComplexMap X Y)
+  exact CategoryTheory.asIso (sumChainComplexMap X Y)
+
+private def PeriodTorusHigherHomology.sumHomologyEquiv (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (X ⊕ Y) n ≃ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology X n × SingularMayerVietoris.SingularHomology Y n) :=
+  ((HomologicalComplex.homologyFunctor (ModuleCat ℤ) (ComplexShape.down ℕ) n).mapIso
+        (sumChainComplexIso X Y)).symm.toLinearEquiv.trans
+    (SingularMayerVietoris.homologyBiprodEquiv (FirstHurewicz.singularComplex X)
+      (FirstHurewicz.singularComplex Y) n)
+
+private theorem
+    PeriodTorusHigherHomology.sumHomologyEquiv_symm_apply (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology X n × SingularMayerVietoris.SingularHomology Y n) :
+    (sumHomologyEquiv X Y n).symm a =
+      SingularMayerVietoris.singularHomologyMap (sumInlMap X Y) n a.1 +
+        SingularMayerVietoris.singularHomologyMap (sumInrMap X Y) n a.2 := by
+  change
+    (HomologicalComplex.homologyMap (sumChainComplexMap X Y) n).hom
+        ((SingularMayerVietoris.homologyBiprodEquiv (FirstHurewicz.singularComplex X)
+              (FirstHurewicz.singularComplex Y) n).symm
+          a) =
+      _
+  exact
+    SingularMayerVietoris.homologyBiprodEquiv_desc n
+      (FirstHurewicz.singularChainMap (sumInlMap X Y))
+      (FirstHurewicz.singularChainMap (sumInrMap X Y)) a
+
+@[simp]
+private theorem PeriodTorusHigherHomology.sumHomologyEquiv_inl (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    sumHomologyEquiv X Y n (SingularMayerVietoris.singularHomologyMap (sumInlMap X Y) n a) =
+      (a, 0) := by
+  apply (sumHomologyEquiv X Y n).symm.injective
+  rw [LinearEquiv.symm_apply_apply, sumHomologyEquiv_symm_apply, map_zero, add_zero]
+
+@[simp]
+private theorem PeriodTorusHigherHomology.sumHomologyEquiv_inr (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) (a : SingularMayerVietoris.SingularHomology Y n) :
+    sumHomologyEquiv X Y n (SingularMayerVietoris.singularHomologyMap (sumInrMap X Y) n a) =
+      (0, a) := by
+  apply (sumHomologyEquiv X Y n).symm.injective
+  rw [LinearEquiv.symm_apply_apply, sumHomologyEquiv_symm_apply, map_zero, zero_add]
+
+private theorem PeriodTorusHigherHomology.sumElim_homology_inl_mo1973_4520 {X : Type} {Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] {Z : Type} [TopologicalSpace Z] (f : C(X, Z))
+    (g : C(Y, Z)) (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    SingularMayerVietoris.singularHomologyMap (sumElimMap f g) n
+        (SingularMayerVietoris.singularHomologyMap (sumInlMap X Y) n a) =
+      SingularMayerVietoris.singularHomologyMap f n a := by
+  have h :=
+    ((AlgebraicTopology.singularHomologyFunctor (ModuleCat ℤ) n).obj (ModuleCat.of ℤ ℤ)).map_comp
+      (TopCat.ofHom (sumInlMap X Y)) (TopCat.ofHom (sumElimMap f g))
+  exact (LinearMap.congr_fun (congrArg ModuleCat.Hom.hom h) a).symm
+
+private theorem PeriodTorusHigherHomology.sumElim_homology_inr_mo1973_4521 {X : Type} {Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] {Z : Type} [TopologicalSpace Z] (f : C(X, Z))
+    (g : C(Y, Z)) (n : ℕ) (a : SingularMayerVietoris.SingularHomology Y n) :
+    SingularMayerVietoris.singularHomologyMap (sumElimMap f g) n
+        (SingularMayerVietoris.singularHomologyMap (sumInrMap X Y) n a) =
+      SingularMayerVietoris.singularHomologyMap g n a := by
+  have h :=
+    ((AlgebraicTopology.singularHomologyFunctor (ModuleCat ℤ) n).obj (ModuleCat.of ℤ ℤ)).map_comp
+      (TopCat.ofHom (sumInrMap X Y)) (TopCat.ofHom (sumElimMap f g))
+  exact (LinearMap.congr_fun (congrArg ModuleCat.Hom.hom h) a).symm
+
+private theorem PeriodTorusHigherHomology.disjointHomology_id_apply_mo1973_4522 {X : Type}
+    [TopologicalSpace X] (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    SingularMayerVietoris.singularHomologyMap (ContinuousMap.id X) n a = a := by
+  have h :=
+    ((AlgebraicTopology.singularHomologyFunctor (ModuleCat ℤ) n).obj (ModuleCat.of ℤ ℤ)).map_id
+      (TopCat.of X)
+  exact LinearMap.congr_fun (congrArg ModuleCat.Hom.hom h) a
+
+private theorem PeriodTorusHigherHomology.sumHomologyEquiv_sumElim_symm {X : Type} {Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] {Z : Type} [TopologicalSpace Z] (f : C(X, Z))
+    (g : C(Y, Z)) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology X n × SingularMayerVietoris.SingularHomology Y n) :
+    SingularMayerVietoris.singularHomologyMap (sumElimMap f g) n
+        ((sumHomologyEquiv X Y n).symm a) =
+      SingularMayerVietoris.singularHomologyMap f n a.1 +
+        SingularMayerVietoris.singularHomologyMap g n a.2 := by
+  rw [sumHomologyEquiv_symm_apply, map_add, sumElim_homology_inl_mo1973_4520,
+    sumElim_homology_inr_mo1973_4521]
+
+private theorem PeriodTorusHigherHomology.sumHomologyEquiv_sumElim {X : Type} {Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] {Z : Type} [TopologicalSpace Z] (f : C(X, Z))
+    (g : C(Y, Z)) (n : ℕ) (a : SingularMayerVietoris.SingularHomology (X ⊕ Y) n) :
+    SingularMayerVietoris.singularHomologyMap (sumElimMap f g) n a =
+      SingularMayerVietoris.singularHomologyMap f n (sumHomologyEquiv X Y n a).1 +
+        SingularMayerVietoris.singularHomologyMap g n (sumHomologyEquiv X Y n a).2 := by
+  have h := sumHomologyEquiv_sumElim_symm f g n (sumHomologyEquiv X Y n a)
+  rwa [LinearEquiv.symm_apply_apply] at h
+
+private theorem
+    PeriodTorusHigherHomology.sumHomologyEquiv_fold {X : Type} [TopologicalSpace X] (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (X ⊕ X) n) :
+    SingularMayerVietoris.singularHomologyMap
+        (sumElimMap (ContinuousMap.id X) (ContinuousMap.id X)) n a =
+      (sumHomologyEquiv X X n a).1 + (sumHomologyEquiv X X n a).2 := by
+  rw [sumHomologyEquiv_sumElim, disjointHomology_id_apply_mo1973_4522,
+    disjointHomology_id_apply_mo1973_4522]
+
+private theorem
+    PeriodTorusHigherHomology.CircleTopology.intervalContractible (a b : ℝ) (hab : a < b) :
+    ContractibleSpace (Set.Ioo a b) :=
+  (convex_Ioo a b).contractibleSpace ⟨(a + b) / 2, by constructor <;> linarith⟩
+
+private def
+    PeriodTorusHigherHomology.CircleTopology.puncturedIntervalInl (t : Set.Ioo (0 : ℝ) (1 / 2)) :
+    { s : Set.Ioo (0 : ℝ) 1 // (s : ℝ) ≠ 1 / 2 } :=
+  ⟨⟨t, t.property.1, t.property.2.trans (by norm_num)⟩, ne_of_lt t.property.2⟩
+
+private def
+    PeriodTorusHigherHomology.CircleTopology.puncturedIntervalInr (t : Set.Ioo (1 / 2 : ℝ) 1) :
+    { s : Set.Ioo (0 : ℝ) 1 // (s : ℝ) ≠ 1 / 2 } :=
+  ⟨⟨t, (by norm_num : (0 : ℝ) < 1 / 2).trans t.property.1, t.property.2⟩, ne_of_gt t.property.1⟩
+
+private theorem PeriodTorusHigherHomology.CircleTopology.puncturedIntervalInl_continuous :
+    Continuous puncturedIntervalInl :=
+  (continuous_subtype_val.subtype_mk _).subtype_mk _
+
+private theorem PeriodTorusHigherHomology.CircleTopology.puncturedIntervalInr_continuous :
+    Continuous puncturedIntervalInr :=
+  (continuous_subtype_val.subtype_mk _).subtype_mk _
+
+private theorem PeriodTorusHigherHomology.CircleTopology.puncturedIntervalInl_isOpenMap :
+    IsOpenMap puncturedIntervalInl :=
+  (isOpen_Ioo.isOpenMap_subtype_val.subtype_mk _).subtype_mk _
+
+private theorem PeriodTorusHigherHomology.CircleTopology.puncturedIntervalInr_isOpenMap :
+    IsOpenMap puncturedIntervalInr :=
+  (isOpen_Ioo.isOpenMap_subtype_val.subtype_mk _).subtype_mk _
+
+private def PeriodTorusHigherHomology.CircleTopology.puncturedIntervalSumEquiv_mo1973_4536 :
+    (Set.Ioo (0 : ℝ) (1 / 2) ⊕ Set.Ioo (1 / 2 : ℝ) 1) ≃
+      { t : Set.Ioo (0 : ℝ) 1 // (t : ℝ) ≠ 1 / 2 } :=
+  Equiv.ofBijective (Sum.elim puncturedIntervalInl puncturedIntervalInr)
+    (by
+      constructor
+      · intro s t h
+        have hcoord :=
+          congrArg (fun u : { t : Set.Ioo (0 : ℝ) 1 // (t : ℝ) ≠ 1 / 2 } => (u.val : ℝ)) h
+        rcases s with s | s <;> rcases t with t | t
+        · exact congrArg Sum.inl (Subtype.ext hcoord)
+        · change (s : ℝ) = (t : ℝ) at hcoord
+          linarith [s.property.2, t.property.1]
+        · change (s : ℝ) = (t : ℝ) at hcoord
+          linarith [s.property.1, t.property.2]
+        · exact congrArg Sum.inr (Subtype.ext hcoord)
+      · intro t
+        rcases lt_or_gt_of_ne t.property with ht | ht
+        · exact ⟨Sum.inl ⟨t.val, t.val.property.1, ht⟩, rfl⟩
+        · exact ⟨Sum.inr ⟨t.val, ht, t.val.property.2⟩, rfl⟩)
+
+private def PeriodTorusHigherHomology.CircleTopology.puncturedIntervalHomeomorph :
+    { t : Set.Ioo (0 : ℝ) 1 // (t : ℝ) ≠ 1 / 2 } ≃ₜ
+      (Set.Ioo (0 : ℝ) (1 / 2) ⊕ Set.Ioo (1 / 2 : ℝ) 1) :=
+  (puncturedIntervalSumEquiv_mo1973_4536.toHomeomorphOfContinuousOpen
+      (puncturedIntervalInl_continuous.sumElim puncturedIntervalInr_continuous)
+      (puncturedIntervalInl_isOpenMap.sumElim puncturedIntervalInr_isOpenMap)).symm
+
+/-- The additive circle of circumference one. -/
+public
+abbrev PeriodTorusHigherHomology.CircleTopology.Circle :=
+  AddCircle (1 : ℝ)
+
+private def PeriodTorusHigherHomology.CircleTopology.halfPoint :
+    PeriodTorusHigherHomology.CircleTopology.Circle :=
+  ((1 / 2 : ℝ) : PeriodTorusHigherHomology.CircleTopology.Circle)
+
+private theorem PeriodTorusHigherHomology.CircleTopology.halfPoint_ne_zero : halfPoint ≠ 0 := by
+  intro h
+  have he :=
+    (AddCircle.coe_eq_zero_iff_of_mem_Ico (p := (1 : ℝ)) (a := (1 / 2 : ℝ)) (by norm_num)).mp h
+  norm_num at he
+
+private def PeriodTorusHigherHomology.CircleTopology.arcU :
+    Set PeriodTorusHigherHomology.CircleTopology.Circle :=
+  ({0} : Set PeriodTorusHigherHomology.CircleTopology.Circle)ᶜ
+
+private def PeriodTorusHigherHomology.CircleTopology.arcV :
+    Set PeriodTorusHigherHomology.CircleTopology.Circle :=
+  ({ halfPoint } : Set PeriodTorusHigherHomology.CircleTopology.Circle)ᶜ
+
+@[simp]
+private theorem PeriodTorusHigherHomology.CircleTopology.mem_arcU
+    (x : PeriodTorusHigherHomology.CircleTopology.Circle) : x ∈ arcU ↔ x ≠ 0 :=
+  Iff.rfl
+
+@[simp]
+private theorem PeriodTorusHigherHomology.CircleTopology.mem_arcV
+    (x : PeriodTorusHigherHomology.CircleTopology.Circle) : x ∈ arcV ↔ x ≠ halfPoint :=
+  Iff.rfl
+
+private theorem PeriodTorusHigherHomology.CircleTopology.arcU_open : IsOpen arcU :=
+  isOpen_compl_singleton
+
+private theorem PeriodTorusHigherHomology.CircleTopology.arcV_open : IsOpen arcV :=
+  isOpen_compl_singleton
+
+private theorem PeriodTorusHigherHomology.CircleTopology.arc_cover : arcU ∪ arcV = Set.univ := by
+  ext x
+  simp only [Set.mem_union, mem_arcU, mem_arcV, Set.mem_univ, iff_true]
+  by_cases hx : x = 0
+  · right
+    rw [hx]
+    exact Ne.symm halfPoint_ne_zero
+  · exact Or.inl hx
+
+private def PeriodTorusHigherHomology.CircleTopology.puncturedCircleHomeomorph (a : ℝ) :
+    ({(a : PeriodTorusHigherHomology.CircleTopology.Circle)}ᶜ :
+        Set PeriodTorusHigherHomology.CircleTopology.Circle) ≃ₜ
+      Set.Ioo a (a + 1) :=
+  (AddCircle.openPartialHomeomorphCoe (1 : ℝ) a).toHomeomorphSourceTarget.symm
+
+private def PeriodTorusHigherHomology.CircleTopology.arcUHomeomorph : arcU ≃ₜ Set.Ioo (0 : ℝ) 1 :=
+  (puncturedCircleHomeomorph 0).trans (Homeomorph.setCongr (by simp))
+
+private def PeriodTorusHigherHomology.CircleTopology.arcVHomeomorph :
+    arcV ≃ₜ Set.Ioo (1 / 2 : ℝ) (3 / 2) :=
+  (puncturedCircleHomeomorph (1 / 2)).trans (Homeomorph.setCongr (by norm_num))
+
+@[simp]
+private theorem PeriodTorusHigherHomology.CircleTopology.arcUHomeomorph_coe (x : arcU) :
+    (((arcUHomeomorph x : Set.Ioo (0 : ℝ) 1) : ℝ) :
+        PeriodTorusHigherHomology.CircleTopology.Circle) =
+      (x : PeriodTorusHigherHomology.CircleTopology.Circle) :=
+  congrArg Subtype.val (arcUHomeomorph.symm_apply_apply x)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.CircleTopology.arcVHomeomorph_coe (x : arcV) :
+    (((arcVHomeomorph x : Set.Ioo (1 / 2 : ℝ) (3 / 2)) : ℝ) :
+        PeriodTorusHigherHomology.CircleTopology.Circle) =
+      (x : PeriodTorusHigherHomology.CircleTopology.Circle) :=
+  congrArg Subtype.val (arcVHomeomorph.symm_apply_apply x)
+
+private instance
+    PeriodTorusHigherHomology.CircleTopology.arcUContractible : ContractibleSpace arcU := by
+  let : ContractibleSpace (Set.Ioo (0 : ℝ) 1) := intervalContractible 0 1 zero_lt_one
+  exact arcUHomeomorph.contractibleSpace
+
+private instance
+    PeriodTorusHigherHomology.CircleTopology.arcVContractible : ContractibleSpace arcV := by
+  let : ContractibleSpace (Set.Ioo (1 / 2 : ℝ) (3 / 2)) :=
+    intervalContractible (1 / 2) (3 / 2) (by norm_num)
+  exact arcVHomeomorph.contractibleSpace
+
+private instance PeriodTorusHigherHomology.CircleTopology.leftIntervalContractible :
+    ContractibleSpace (Set.Ioo (0 : ℝ) (1 / 2)) :=
+  intervalContractible 0 (1 / 2) (by norm_num)
+
+private instance PeriodTorusHigherHomology.CircleTopology.rightIntervalContractible :
+    ContractibleSpace (Set.Ioo (1 / 2 : ℝ) 1) :=
+  intervalContractible (1 / 2) 1 (by norm_num)
+
+private def PeriodTorusHigherHomology.CircleTopology.intersectionSubtypeHomeomorph {T : Type*}
+    [TopologicalSpace T] (U V : Set T) : ↥(U ∩ V) ≃ₜ { x : U // (x : T) ∈ V }
+    where
+  toFun x := ⟨⟨x.val, x.property.1⟩, x.property.2⟩
+  invFun x := ⟨x.val.val, x.val.property, x.property⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := (continuous_subtype_val.subtype_mk _).subtype_mk _
+  continuous_invFun := (continuous_subtype_val.comp continuous_subtype_val).subtype_mk _
+
+private theorem PeriodTorusHigherHomology.CircleTopology.arcU_mem_arcV_iff (x : arcU) :
+    (x : PeriodTorusHigherHomology.CircleTopology.Circle) ∈ arcV ↔
+      (arcUHomeomorph x : ℝ) ≠ 1 / 2 := by
+  change (x : PeriodTorusHigherHomology.CircleTopology.Circle) ≠ halfPoint ↔ _
+  let m : Set.Ioo (0 : ℝ) 1 := ⟨1 / 2, by norm_num⟩
+  have hm :
+    (arcUHomeomorph.symm m : PeriodTorusHigherHomology.CircleTopology.Circle) = halfPoint := rfl
+  constructor
+  · intro hx ht
+    have ht' : arcUHomeomorph x = m := Subtype.ext ht
+    have hx' : x = arcUHomeomorph.symm m :=
+      (arcUHomeomorph.symm_apply_apply x).symm.trans (congrArg arcUHomeomorph.symm ht')
+    exact hx ((congrArg Subtype.val hx').trans hm)
+  · intro hx ht
+    have hx' : x = arcUHomeomorph.symm m := Subtype.ext (ht.trans hm.symm)
+    apply hx
+    change (arcUHomeomorph x : ℝ) = (m : ℝ)
+    rw [hx', Homeomorph.apply_symm_apply]
+
+private def PeriodTorusHigherHomology.CircleTopology.intersectionPuncturedHomeomorph :
+    ↥(arcU ∩ arcV) ≃ₜ { t : Set.Ioo (0 : ℝ) 1 // (t : ℝ) ≠ 1 / 2 } :=
+  (intersectionSubtypeHomeomorph arcU arcV).trans (arcUHomeomorph.subtype arcU_mem_arcV_iff)
+
+private def PeriodTorusHigherHomology.CircleTopology.intersectionHomeomorph :
+    ↥(arcU ∩ arcV) ≃ₜ (Set.Ioo (0 : ℝ) (1 / 2) ⊕ Set.Ioo (1 / 2 : ℝ) 1) :=
+  intersectionPuncturedHomeomorph.trans puncturedIntervalHomeomorph
+
+private def
+    PeriodTorusHigherHomology.CircleTopology.contractionPoint (S : Type*) [TopologicalSpace S]
+    [ContractibleSpace S] : S :=
+  Classical.choose (id_nullhomotopic S)
+
+private theorem PeriodTorusHigherHomology.CircleTopology.contractionPoint_homotopic (S : Type*)
+    [TopologicalSpace S] [ContractibleSpace S] :
+    (ContinuousMap.const S (contractionPoint S)).Homotopic (ContinuousMap.id S) :=
+  (Classical.choose_spec (id_nullhomotopic S)).symm
+
+private def PeriodTorusHigherHomology.CircleTopology.contractibleProdHomotopyEquiv (S X : Type*)
+    [TopologicalSpace S] [TopologicalSpace X] [ContractibleSpace S] : (S × X) ≃ₕ X
+    where
+  toFun := ContinuousMap.snd
+  invFun := (ContinuousMap.const X (contractionPoint S)).prodMk (ContinuousMap.id X)
+  left_inv := (contractionPoint_homotopic S).prodMap (.refl (ContinuousMap.id X))
+  right_inv := .refl (ContinuousMap.id X)
+
+private def PeriodTorusHigherHomology.CircleTopology.sumContinuousMap {A A' B B' : Type*}
+    [TopologicalSpace A] [TopologicalSpace A'] [TopologicalSpace B] [TopologicalSpace B']
+    (f : C(A, A')) (g : C(B, B')) : C(A ⊕ B, A' ⊕ B') :=
+  ⟨Sum.map f g, f.continuous.sumMap g.continuous⟩
+
+private def
+    PeriodTorusHigherHomology.CircleTopology.sumHomotopy {A A' B B' : Type*} [TopologicalSpace A]
+    [TopologicalSpace A'] [TopologicalSpace B] [TopologicalSpace B'] {f₀ f₁ : C(A, A')}
+    {g₀ g₁ : C(B, B')} (F : f₀.Homotopy f₁) (G : g₀.Homotopy g₁) :
+    (sumContinuousMap f₀ g₀).Homotopy (sumContinuousMap f₁ g₁)
+    where
+  toFun := Sum.elim (fun p => Sum.inl (F p)) (fun p => Sum.inr (G p)) ∘ Homeomorph.prodSumDistrib
+  continuous_toFun :=
+    ((continuous_inl.comp F.continuous).sumElim (continuous_inr.comp G.continuous)).comp
+      Homeomorph.prodSumDistrib.continuous
+  map_zero_left := by
+    intro x
+    cases x with
+    | inl a => exact congrArg Sum.inl (F.map_zero_left a)
+    | inr b => exact congrArg Sum.inr (G.map_zero_left b)
+  map_one_left := by
+    intro x
+    cases x with
+    | inl a => exact congrArg Sum.inl (F.map_one_left a)
+    | inr b => exact congrArg Sum.inr (G.map_one_left b)
+
+private def PeriodTorusHigherHomology.CircleTopology.sumHomotopyEquiv {A A' B B' : Type*}
+    [TopologicalSpace A] [TopologicalSpace A'] [TopologicalSpace B] [TopologicalSpace B']
+    (eA : A ≃ₕ A') (eB : B ≃ₕ B') : (A ⊕ B) ≃ₕ (A' ⊕ B')
+    where
+  toFun := sumContinuousMap eA.toFun eB.toFun
+  invFun := sumContinuousMap eA.invFun eB.invFun
+  left_inv := by
+    rcases eA.left_inv with ⟨F⟩
+    rcases eB.left_inv with ⟨G⟩
+    refine ⟨(sumHomotopy F G).cast ?_ ?_⟩
+    · ext x
+      cases x <;> rfl
+    · ext x
+      cases x <;> rfl
+  right_inv := by
+    rcases eA.right_inv with ⟨F⟩
+    rcases eB.right_inv with ⟨G⟩
+    refine ⟨(sumHomotopy F G).cast ?_ ?_⟩
+    · ext x
+      cases x <;> rfl
+    · ext x
+      cases x <;> rfl
+
+private def PeriodTorusHigherHomology.CircleTopology.circleLiftContraction {S : Type*}
+    [TopologicalSpace S] (f : C(S, AddCircle (1 : ℝ))) (l : C(S, ℝ))
+    (hlift : ∀ s, (l s : AddCircle (1 : ℝ)) = f s) : f.Homotopy (ContinuousMap.const S 0)
+    where
+  toFun p := (((1 - (p.1 : ℝ)) * l p.2 : ℝ) : AddCircle (1 : ℝ))
+  continuous_toFun :=
+    (AddCircle.continuous_mk' (1 : ℝ)).comp
+      ((continuous_const.sub (continuous_subtype_val.comp continuous_fst)).mul
+        (l.continuous.comp continuous_snd))
+  map_zero_left s := by simpa using hlift s
+  map_one_left s := by simp
+
+private def PeriodTorusHigherHomology.CircleTopology.circleProductLiftContraction {S X : Type*}
+    [TopologicalSpace S] [TopologicalSpace X] (f : C(S, AddCircle (1 : ℝ) × X)) (l : C(S, ℝ))
+    (hlift : ∀ s, (l s : AddCircle (1 : ℝ)) = (f s).1) :
+    f.Homotopy ⟨fun s => (0, (f s).2), continuous_const.prodMk f.continuous.snd⟩
+    where
+  toFun p := ((((1 - (p.1 : ℝ)) * l p.2 : ℝ) : AddCircle (1 : ℝ)), (f p.2).2)
+  continuous_toFun :=
+    ((AddCircle.continuous_mk' (1 : ℝ)).comp
+          ((continuous_const.sub (continuous_subtype_val.comp continuous_fst)).mul
+            (l.continuous.comp continuous_snd))).prodMk
+      (f.continuous.snd.comp continuous_snd)
+  map_zero_left
+    s := by
+    apply Prod.ext
+    · simpa using hlift s
+    · rfl
+  map_one_left s := by simp
+
+private def PeriodTorusHigherHomology.CircleTopology.productU (X : Type*) :
+    Set (PeriodTorusHigherHomology.CircleTopology.Circle × X) :=
+  Prod.fst ⁻¹' arcU
+
+private def PeriodTorusHigherHomology.CircleTopology.productV (X : Type*) :
+    Set (PeriodTorusHigherHomology.CircleTopology.Circle × X) :=
+  Prod.fst ⁻¹' arcV
+
+private theorem
+    PeriodTorusHigherHomology.CircleTopology.productU_open (X : Type*) [TopologicalSpace X] :
+    IsOpen (productU X) :=
+  arcU_open.preimage continuous_fst
+
+private theorem
+    PeriodTorusHigherHomology.CircleTopology.productV_open (X : Type*) [TopologicalSpace X] :
+    IsOpen (productV X) :=
+  arcV_open.preimage continuous_fst
+
+private theorem PeriodTorusHigherHomology.CircleTopology.product_cover (X : Type*) :
+    productU X ∪ productV X = Set.univ := by
+  change
+    Prod.fst ⁻¹' arcU ∪ Prod.fst ⁻¹' arcV =
+      (Set.univ : Set (PeriodTorusHigherHomology.CircleTopology.Circle × X))
+  rw [← Set.preimage_union, arc_cover, Set.preimage_univ]
+
+private def
+    PeriodTorusHigherHomology.CircleTopology.productProjection (X : Type*) [TopologicalSpace X] :
+    C(PeriodTorusHigherHomology.CircleTopology.Circle × X, X) :=
+  ContinuousMap.snd
+
+private def
+    PeriodTorusHigherHomology.CircleTopology.productSection (X : Type*) [TopologicalSpace X] :
+    C(X, PeriodTorusHigherHomology.CircleTopology.Circle × X) :=
+  (ContinuousMap.const X (0 : PeriodTorusHigherHomology.CircleTopology.Circle)).prodMk
+    (ContinuousMap.id X)
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.CircleTopology.productProjection_comp_productSection (X : Type*)
+    [TopologicalSpace X] : (productProjection X).comp (productSection X) = ContinuousMap.id X :=
+  rfl
+
+private def
+    PeriodTorusHigherHomology.CircleTopology.productUInclusion (X : Type*) [TopologicalSpace X] :
+    C(productU X, PeriodTorusHigherHomology.CircleTopology.Circle × X) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private def
+    PeriodTorusHigherHomology.CircleTopology.productVInclusion (X : Type*) [TopologicalSpace X] :
+    C(productV X, PeriodTorusHigherHomology.CircleTopology.Circle × X) :=
+  ⟨Subtype.val, continuous_subtype_val⟩
+
+private def PeriodTorusHigherHomology.CircleTopology.productIntersectionToU (X : Type*)
+    [TopologicalSpace X] : C(↥(productU X ∩ productV X), productU X) :=
+  ⟨fun z => ⟨z.val, z.property.1⟩, continuous_subtype_val.subtype_mk _⟩
+
+private def PeriodTorusHigherHomology.CircleTopology.productIntersectionToV (X : Type*)
+    [TopologicalSpace X] : C(↥(productU X ∩ productV X), productV X) :=
+  ⟨fun z => ⟨z.val, z.property.2⟩, continuous_subtype_val.subtype_mk _⟩
+
+private def PeriodTorusHigherHomology.CircleTopology.foldMap (X : Type*) [TopologicalSpace X] :
+    C(X ⊕ X, X) :=
+  ⟨Sum.elim id id, continuous_id.sumElim continuous_id⟩
+
+private def
+    PeriodTorusHigherHomology.CircleTopology.productArcHomeomorph (X : Type*) [TopologicalSpace X]
+    (S : Set PeriodTorusHigherHomology.CircleTopology.Circle) :
+    ↥(Prod.fst ⁻¹' S : Set (PeriodTorusHigherHomology.CircleTopology.Circle × X)) ≃ₜ S × X
+    where
+  toFun z := (⟨z.val.1, z.property⟩, z.val.2)
+  invFun z := ⟨(z.1.val, z.2), z.1.property⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := (continuous_subtype_val.fst.subtype_mk _).prodMk continuous_subtype_val.snd
+  continuous_invFun :=
+    ((continuous_subtype_val.comp continuous_fst).prodMk continuous_snd).subtype_mk _
+
+private def
+    PeriodTorusHigherHomology.CircleTopology.productUHomeomorph (X : Type*) [TopologicalSpace X] :
+    productU X ≃ₜ arcU × X :=
+  productArcHomeomorph X arcU
+
+private def
+    PeriodTorusHigherHomology.CircleTopology.productVHomeomorph (X : Type*) [TopologicalSpace X] :
+    productV X ≃ₜ arcV × X :=
+  productArcHomeomorph X arcV
+
+private def PeriodTorusHigherHomology.CircleTopology.productIntersectionArcHomeomorph (X : Type*)
+    [TopologicalSpace X] : ↥(productU X ∩ productV X) ≃ₜ ↥(arcU ∩ arcV) × X :=
+  productArcHomeomorph X (arcU ∩ arcV)
+
+private def PeriodTorusHigherHomology.CircleTopology.productIntersectionHomeomorph (X : Type*)
+    [TopologicalSpace X] :
+    ↥(productU X ∩ productV X) ≃ₜ (Set.Ioo (0 : ℝ) (1 / 2) × X) ⊕ (Set.Ioo (1 / 2 : ℝ) 1 × X) :=
+  ((productIntersectionArcHomeomorph X).trans
+        (intersectionHomeomorph.prodCongr (Homeomorph.refl X))).trans
+    Homeomorph.sumProdDistrib
+
+private def PeriodTorusHigherHomology.CircleTopology.productUHomotopyEquiv (X : Type*)
+    [TopologicalSpace X] : productU X ≃ₕ X :=
+  (productUHomeomorph X).toHomotopyEquiv.trans (contractibleProdHomotopyEquiv arcU X)
+
+private def PeriodTorusHigherHomology.CircleTopology.productVHomotopyEquiv (X : Type*)
+    [TopologicalSpace X] : productV X ≃ₕ X :=
+  (productVHomeomorph X).toHomotopyEquiv.trans (contractibleProdHomotopyEquiv arcV X)
+
+private def PeriodTorusHigherHomology.CircleTopology.productIntersectionHomotopyEquiv (X : Type*)
+    [TopologicalSpace X] : ↥(productU X ∩ productV X) ≃ₕ X ⊕ X :=
+  (productIntersectionHomeomorph X).toHomotopyEquiv.trans
+    (sumHomotopyEquiv (contractibleProdHomotopyEquiv (Set.Ioo (0 : ℝ) (1 / 2)) X)
+      (contractibleProdHomotopyEquiv (Set.Ioo (1 / 2 : ℝ) 1) X))
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.CircleTopology.productIntersectionHomotopyEquiv_fold (X : Type*)
+    [TopologicalSpace X] (z : ↥(productU X ∩ productV X)) :
+    foldMap X (productIntersectionHomotopyEquiv X z) = z.val.2 := by
+  let c : ↥(arcU ∩ arcV) := ⟨z.val.1, z.property⟩
+  change
+    Sum.elim id id
+        (Sum.map (fun t : Set.Ioo (0 : ℝ) (1 / 2) × X => t.2)
+          (fun t : Set.Ioo (1 / 2 : ℝ) 1 × X => t.2)
+          (Homeomorph.sumProdDistrib (intersectionHomeomorph c, z.val.2))) =
+      z.val.2
+  cases h : intersectionHomeomorph c <;> rfl
+
+private theorem PeriodTorusHigherHomology.CircleTopology.productIntersectionToU_fold (X : Type*)
+    [TopologicalSpace X] :
+    (productUHomotopyEquiv X).toFun.comp (productIntersectionToU X) =
+      (foldMap X).comp (productIntersectionHomotopyEquiv X).toFun := by
+  apply ContinuousMap.ext
+  intro z
+  exact (productIntersectionHomotopyEquiv_fold X z).symm
+
+private theorem PeriodTorusHigherHomology.CircleTopology.productIntersectionToV_fold (X : Type*)
+    [TopologicalSpace X] :
+    (productVHomotopyEquiv X).toFun.comp (productIntersectionToV X) =
+      (foldMap X).comp (productIntersectionHomotopyEquiv X).toFun := by
+  apply ContinuousMap.ext
+  intro z
+  exact (productIntersectionHomotopyEquiv_fold X z).symm
+
+private def
+    PeriodTorusHigherHomology.CircleTopology.productUCoordinate (X : Type*) [TopologicalSpace X] :
+    C(productU X, ℝ) :=
+  ⟨fun z => (arcUHomeomorph ((productUHomeomorph X z).1) : ℝ),
+    continuous_subtype_val.comp
+      (arcUHomeomorph.continuous.comp (productUHomeomorph X).continuous.fst)⟩
+
+private def
+    PeriodTorusHigherHomology.CircleTopology.productVCoordinate (X : Type*) [TopologicalSpace X] :
+    C(productV X, ℝ) :=
+  ⟨fun z => (arcVHomeomorph ((productVHomeomorph X z).1) : ℝ),
+    continuous_subtype_val.comp
+      (arcVHomeomorph.continuous.comp (productVHomeomorph X).continuous.fst)⟩
+
+@[simp]
+private theorem PeriodTorusHigherHomology.CircleTopology.productUCoordinate_coe (X : Type*)
+    [TopologicalSpace X] (z : productU X) :
+    ((productUCoordinate X z : ℝ) : PeriodTorusHigherHomology.CircleTopology.Circle) = z.val.1 :=
+  arcUHomeomorph_coe _
+
+@[simp]
+private theorem PeriodTorusHigherHomology.CircleTopology.productVCoordinate_coe (X : Type*)
+    [TopologicalSpace X] (z : productV X) :
+    ((productVCoordinate X z : ℝ) : PeriodTorusHigherHomology.CircleTopology.Circle) = z.val.1 :=
+  arcVHomeomorph_coe _
+
+private def PeriodTorusHigherHomology.CircleTopology.productUInclusionHomotopy (X : Type*)
+    [TopologicalSpace X] :
+    (productUInclusion X).Homotopy ((productSection X).comp (productUHomotopyEquiv X).toFun) :=
+  circleProductLiftContraction (productUInclusion X) (productUCoordinate X)
+    (productUCoordinate_coe X)
+
+private def PeriodTorusHigherHomology.CircleTopology.productVInclusionHomotopy (X : Type*)
+    [TopologicalSpace X] :
+    (productVInclusion X).Homotopy ((productSection X).comp (productVHomotopyEquiv X).toFun) :=
+  circleProductLiftContraction (productVInclusion X) (productVCoordinate X)
+    (productVCoordinate_coe X)
+
+private def
+    PeriodTorusHigherHomology.productArcHomologyEquiv (X : Type) [TopologicalSpace X] (n : ℕ) :
+    (SingularMayerVietoris.SingularHomology (CircleTopology.productU X) n ×
+        SingularMayerVietoris.SingularHomology (CircleTopology.productV X) n) ≃ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology X n × SingularMayerVietoris.SingularHomology X n) :=
+  ((homotopyEquivHomologyEquiv (CircleTopology.productUHomotopyEquiv X) n).toAddEquiv.prodCongr
+      (homotopyEquivHomologyEquiv (CircleTopology.productVHomotopyEquiv X)
+          n).toAddEquiv).toIntLinearEquiv
+
+private def
+    PeriodTorusHigherHomology.productIntersectionHomologyEquiv (X : Type) [TopologicalSpace X]
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology
+        (CircleTopology.productU X ∩ CircleTopology.productV X :
+          Set ((PeriodTorusHigherHomology.CircleTopology.Circle) × X))
+        n ≃ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology X n × SingularMayerVietoris.SingularHomology X n) :=
+  (homotopyEquivHomologyEquiv (CircleTopology.productIntersectionHomotopyEquiv X) n).trans
+    (sumHomologyEquiv X X n)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.productIntersectionHomologyEquiv_apply (X : Type)
+    [TopologicalSpace X] (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (CircleTopology.productU X ∩ CircleTopology.productV X :
+          Set ((PeriodTorusHigherHomology.CircleTopology.Circle) × X))
+        n) :
+    productIntersectionHomologyEquiv X n a =
+      sumHomologyEquiv X X n
+        (SingularMayerVietoris.singularHomologyMap
+          (CircleTopology.productIntersectionHomotopyEquiv X).toFun n a) :=
+  rfl
+
+private abbrev
+    PeriodTorusHigherHomology.circleSectionHomology (X : Type) [TopologicalSpace X] (n : ℕ) :
+    SingularMayerVietoris.SingularHomology X n →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) × X) n :=
+  SingularMayerVietoris.singularHomologyMap (CircleTopology.productSection X) n
+
+private abbrev PeriodTorusHigherHomology.circleProjectionHomology (X : Type) [TopologicalSpace X]
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology ((PeriodTorusHigherHomology.CircleTopology.Circle) × X)
+        n →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology X n :=
+  SingularMayerVietoris.singularHomologyMap (CircleTopology.productProjection X) n
+
+@[simp]
+private theorem PeriodTorusHigherHomology.circleProjection_section (X : Type) [TopologicalSpace X]
+    (n : ℕ) : (circleProjectionHomology X n).comp (circleSectionHomology X n) = LinearMap.id := by
+  rw [← singularHomologyMap_comp, CircleTopology.productProjection_comp_productSection,
+    singularHomologyMap_id]
+
+private theorem PeriodTorusHigherHomology.productUInclusion_homology (X : Type) [TopologicalSpace X]
+    (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (CircleTopology.productUInclusion X) n =
+      (circleSectionHomology X n).comp
+        (homotopyEquivHomologyEquiv (CircleTopology.productUHomotopyEquiv X) n).toLinearMap := by
+  rw [homotopy_homologyMap (CircleTopology.productUInclusionHomotopy X) n,
+    singularHomologyMap_comp]
+  rfl
+
+private theorem PeriodTorusHigherHomology.productVInclusion_homology (X : Type) [TopologicalSpace X]
+    (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (CircleTopology.productVInclusion X) n =
+      (circleSectionHomology X n).comp
+        (homotopyEquivHomologyEquiv (CircleTopology.productVHomotopyEquiv X) n).toLinearMap := by
+  rw [homotopy_homologyMap (CircleTopology.productVInclusionHomotopy X) n,
+    singularHomologyMap_comp]
+  rfl
+
+private theorem
+    PeriodTorusHigherHomology.productFold_homology (X : Type) [TopologicalSpace X] (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (X ⊕ X) n) :
+    SingularMayerVietoris.singularHomologyMap (CircleTopology.foldMap X) n a =
+      (sumHomologyEquiv X X n a).1 + (sumHomologyEquiv X X n a).2 :=
+  sumHomologyEquiv_fold n a
+
+private theorem
+    PeriodTorusHigherHomology.productIntersectionToU_homology (X : Type) [TopologicalSpace X]
+    (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (CircleTopology.productU X ∩ CircleTopology.productV X :
+          Set ((PeriodTorusHigherHomology.CircleTopology.Circle) × X))
+        n) :
+    homotopyEquivHomologyEquiv (CircleTopology.productUHomotopyEquiv X) n
+        (SingularMayerVietoris.singularHomologyMap (CircleTopology.productIntersectionToU X) n
+          a) =
+      (productIntersectionHomologyEquiv X n a).1 + (productIntersectionHomologyEquiv X n a).2 := by
+  change
+    SingularMayerVietoris.singularHomologyMap (CircleTopology.productUHomotopyEquiv X).toFun n
+        (SingularMayerVietoris.singularHomologyMap (CircleTopology.productIntersectionToU X) n
+          a) =
+      _
+  rw [← LinearMap.comp_apply, ← singularHomologyMap_comp,
+    CircleTopology.productIntersectionToU_fold, singularHomologyMap_comp]
+  exact productFold_homology X n _
+
+private theorem
+    PeriodTorusHigherHomology.productIntersectionToV_homology (X : Type) [TopologicalSpace X]
+    (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (CircleTopology.productU X ∩ CircleTopology.productV X :
+          Set ((PeriodTorusHigherHomology.CircleTopology.Circle) × X))
+        n) :
+    homotopyEquivHomologyEquiv (CircleTopology.productVHomotopyEquiv X) n
+        (SingularMayerVietoris.singularHomologyMap (CircleTopology.productIntersectionToV X) n
+          a) =
+      (productIntersectionHomologyEquiv X n a).1 + (productIntersectionHomologyEquiv X n a).2 := by
+  change
+    SingularMayerVietoris.singularHomologyMap (CircleTopology.productVHomotopyEquiv X).toFun n
+        (SingularMayerVietoris.singularHomologyMap (CircleTopology.productIntersectionToV X) n
+          a) =
+      _
+  rw [← LinearMap.comp_apply, ← singularHomologyMap_comp,
+    CircleTopology.productIntersectionToV_fold, singularHomologyMap_comp]
+  exact productFold_homology X n _
+
+private theorem PeriodTorusHigherHomology.circleProductLeftHomologyMap_apply (X : Type)
+    [TopologicalSpace X] (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (CircleTopology.productU X ∩ CircleTopology.productV X :
+          Set ((PeriodTorusHigherHomology.CircleTopology.Circle) × X))
+        n) :
+    productArcHomologyEquiv X n
+        (SingularMayerVietoris.leftHomologyMap (CircleTopology.productU X)
+          (CircleTopology.productV X) n a) =
+      ((productIntersectionHomologyEquiv X n a).1 + (productIntersectionHomologyEquiv X n a).2,
+        -((productIntersectionHomologyEquiv X n a).1 +
+            (productIntersectionHomologyEquiv X n a).2)) := by
+  rw [SingularMayerVietoris.leftHomologyMap_apply]
+  change
+    (homotopyEquivHomologyEquiv (CircleTopology.productUHomotopyEquiv X) n
+          (SingularMayerVietoris.singularHomologyMap (CircleTopology.productIntersectionToU X) n
+            a),
+        homotopyEquivHomologyEquiv (CircleTopology.productVHomotopyEquiv X) n
+          (-SingularMayerVietoris.singularHomologyMap (CircleTopology.productIntersectionToV X) n
+              a)) =
+      _
+  rw [map_neg, productIntersectionToU_homology, productIntersectionToV_homology]
+
+private theorem PeriodTorusHigherHomology.circleProductRightHomologyMap_apply (X : Type)
+    [TopologicalSpace X] (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology (CircleTopology.productU X) n ×
+        SingularMayerVietoris.SingularHomology (CircleTopology.productV X) n) :
+    SingularMayerVietoris.rightHomologyMap (CircleTopology.productU X) (CircleTopology.productV X)
+        n a =
+      circleSectionHomology X n
+        ((productArcHomologyEquiv X n a).1 + (productArcHomologyEquiv X n a).2) := by
+  rw [SingularMayerVietoris.rightHomologyMap_apply]
+  change
+    SingularMayerVietoris.singularHomologyMap (CircleTopology.productUInclusion X) n a.1 +
+        SingularMayerVietoris.singularHomologyMap (CircleTopology.productVInclusion X) n a.2 =
+      _
+  rw [productUInclusion_homology, productVInclusion_homology]
+  exact (map_add (circleSectionHomology X n) _ _).symm
+
+private abbrev
+    PeriodTorusHigherHomology.circleMayerVietorisConnecting (X : Type) [TopologicalSpace X]
+    (n : ℕ) :
+    SingularMayerVietoris.SingularHomology ((PeriodTorusHigherHomology.CircleTopology.Circle) × X)
+        (n + 1) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology
+        (CircleTopology.productU X ∩ CircleTopology.productV X :
+          Set ((PeriodTorusHigherHomology.CircleTopology.Circle) × X))
+        n :=
+  SingularMayerVietoris.connectingHomomorphism (CircleTopology.productU X)
+    (CircleTopology.productV X) (CircleTopology.productU_open X) (CircleTopology.productV_open X)
+    (CircleTopology.product_cover X) n
+
+private def
+    PeriodTorusHigherHomology.circleBoundaryCoordinates (X : Type) [TopologicalSpace X] (n : ℕ) :
+    SingularMayerVietoris.SingularHomology ((PeriodTorusHigherHomology.CircleTopology.Circle) × X)
+        (n + 1) →ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology X n × SingularMayerVietoris.SingularHomology X n) :=
+  (productIntersectionHomologyEquiv X n).toLinearMap.comp (circleMayerVietorisConnecting X n)
+
+private theorem
+    PeriodTorusHigherHomology.circleBoundaryCoordinates_range (X : Type) [TopologicalSpace X]
+    (n : ℕ) :
+    LinearMap.range (circleBoundaryCoordinates X n) =
+      LinearMap.ker (pairSumMap (SingularMayerVietoris.SingularHomology X n)) := by
+  ext a
+  constructor
+  · rintro ⟨b, rfl⟩
+    have hb :
+      circleMayerVietorisConnecting X n b ∈ LinearMap.range (circleMayerVietorisConnecting X n) :=
+      ⟨b, rfl⟩
+    rw [SingularMayerVietoris.exact_at_intersection (CircleTopology.productU X)
+        (CircleTopology.productV X) (CircleTopology.productU_open X)
+        (CircleTopology.productV_open X) (CircleTopology.product_cover X)] at hb
+    have he := congrArg (productArcHomologyEquiv X n) hb
+    rw [circleProductLeftHomologyMap_apply, map_zero] at he
+    exact congrArg Prod.fst he
+  · intro ha
+    have ha' : a.1 + a.2 = 0 := ha
+    have hleft :
+      SingularMayerVietoris.leftHomologyMap (CircleTopology.productU X)
+          (CircleTopology.productV X) n ((productIntersectionHomologyEquiv X n).symm a) =
+        0 := by
+      apply (productArcHomologyEquiv X n).injective
+      rw [circleProductLeftHomologyMap_apply, LinearEquiv.apply_symm_apply, map_zero]
+      exact Prod.ext ha' (ha' ▸ neg_zero)
+    have hi :
+      (productIntersectionHomologyEquiv X n).symm a ∈
+        LinearMap.range (circleMayerVietorisConnecting X n) := by
+      rw [SingularMayerVietoris.exact_at_intersection (CircleTopology.productU X)
+          (CircleTopology.productV X) (CircleTopology.productU_open X)
+          (CircleTopology.productV_open X) (CircleTopology.product_cover X)]
+      exact hleft
+    obtain ⟨b, hb⟩ := hi
+    refine ⟨b, ?_⟩
+    change productIntersectionHomologyEquiv X n (circleMayerVietorisConnecting X n b) = a
+    rw [hb, LinearEquiv.apply_symm_apply]
+
+private theorem PeriodTorusHigherHomology.circleProductRightHomologyMap_range (X : Type)
+    [TopologicalSpace X] (n : ℕ) :
+    LinearMap.range
+        (SingularMayerVietoris.rightHomologyMap (CircleTopology.productU X)
+          (CircleTopology.productV X) n) =
+      LinearMap.range (circleSectionHomology X n) := by
+  ext b
+  constructor
+  · rintro ⟨a, rfl⟩
+    exact
+      ⟨(productArcHomologyEquiv X n a).1 + (productArcHomologyEquiv X n a).2,
+        (circleProductRightHomologyMap_apply X n a).symm⟩
+  · rintro ⟨a, rfl⟩
+    refine ⟨(productArcHomologyEquiv X n).symm (a, 0), ?_⟩
+    rw [circleProductRightHomologyMap_apply, LinearEquiv.apply_symm_apply]
+    exact congrArg (circleSectionHomology X n) (add_zero a)
+
+private theorem
+    PeriodTorusHigherHomology.circleBoundaryCoordinates_ker (X : Type) [TopologicalSpace X]
+    (n : ℕ) :
+    LinearMap.range (circleSectionHomology X (n + 1)) =
+      LinearMap.ker (circleBoundaryCoordinates X n) := by
+  rw [circleBoundaryCoordinates, SingularMayerVietoris.rightTransport_second_ker]
+  rw [←
+    SingularMayerVietoris.exact_at_ambient (CircleTopology.productU X) (CircleTopology.productV X)
+      (CircleTopology.productU_open X) (CircleTopology.productV_open X)
+      (CircleTopology.product_cover X)]
+  exact (circleProductRightHomologyMap_range X (n + 1)).symm
+
+private def PeriodTorusHigherHomology.circleBoundary (X : Type) [TopologicalSpace X] (n : ℕ) :
+    SingularMayerVietoris.SingularHomology ((PeriodTorusHigherHomology.CircleTopology.Circle) × X)
+        (n + 1) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology X n :=
+  (negativeFirstMap (SingularMayerVietoris.SingularHomology X n)).comp
+    (circleBoundaryCoordinates X n)
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.circleBoundary_apply (X : Type) [TopologicalSpace X] (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) × X) (n + 1)) :
+    circleBoundary X n a = -(circleBoundaryCoordinates X n a).1 :=
+  rfl
+
+private theorem PeriodTorusHigherHomology.circleBoundary_surjective (X : Type) [TopologicalSpace X]
+    (n : ℕ) : Function.Surjective (circleBoundary X n) :=
+  circleBoundary_negativeFirst_surjective (circleBoundaryCoordinates X n)
+    (circleBoundaryCoordinates_range X n)
+
+private theorem
+    PeriodTorusHigherHomology.circleBoundary_exact (X : Type) [TopologicalSpace X] (n : ℕ) :
+    LinearMap.range (circleSectionHomology X (n + 1)) = LinearMap.ker (circleBoundary X n) :=
+  (circleBoundaryCoordinates_ker X n).trans
+    (circleBoundary_negativeFirst_ker (circleBoundaryCoordinates X n)
+        (circleBoundaryCoordinates_range X n)).symm
+
+private def
+    PeriodTorusHigherHomology.circleProductHomologyEquiv (X : Type) [TopologicalSpace X] (n : ℕ) :
+    SingularMayerVietoris.SingularHomology ((PeriodTorusHigherHomology.CircleTopology.Circle) × X)
+        (n + 1) ≃ₗ[ℤ]
+      (SingularMayerVietoris.SingularHomology X (n + 1) ×
+        SingularMayerVietoris.SingularHomology X n) :=
+  circleSplitExactEquiv (circleSectionHomology X (n + 1)) (circleProjectionHomology X (n + 1))
+    (circleBoundaryCoordinates X n) (circleProjection_section X (n + 1))
+    (circleBoundaryCoordinates_ker X n) (circleBoundaryCoordinates_range X n)
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.circleProductHomologyEquiv_apply (X : Type) [TopologicalSpace X]
+    (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) × X) (n + 1)) :
+    circleProductHomologyEquiv X n a =
+      (circleProjectionHomology X (n + 1) a, circleBoundary X n a) :=
+  rfl
+
+private theorem PeriodTorusHigherHomology.circleProductHomologyEquiv_section (X : Type)
+    [TopologicalSpace X] (n : ℕ) (a : SingularMayerVietoris.SingularHomology X (n + 1)) :
+    circleProductHomologyEquiv X n (circleSectionHomology X (n + 1) a) = (a, 0) :=
+  circleSplitExactEquiv_apply_inclusion _ _ _ _ _ _ a
+
+private theorem PeriodTorusHigherHomology.circleSectionHomology_zero_surjective (X : Type)
+    [TopologicalSpace X] : Function.Surjective (circleSectionHomology X 0) := by
+  intro b
+  obtain ⟨a, ha⟩ :=
+    SingularMayerVietoris.rightHomologyMap_zero_surjective (CircleTopology.productU X)
+      (CircleTopology.productV X) (CircleTopology.productU_open X)
+      (CircleTopology.productV_open X) (CircleTopology.product_cover X) b
+  exact
+    ⟨(productArcHomologyEquiv X 0 a).1 + (productArcHomologyEquiv X 0 a).2,
+      (circleProductRightHomologyMap_apply X 0 a).symm.trans ha⟩
+
+private def
+    PeriodTorusHigherHomology.circleProductHomologyZeroEquiv (X : Type) [TopologicalSpace X] :
+    SingularMayerVietoris.SingularHomology ((PeriodTorusHigherHomology.CircleTopology.Circle) × X)
+        0 ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology X 0
+    where
+  toLinearMap := circleProjectionHomology X 0
+  invFun := circleSectionHomology X 0
+  left_inv
+    b := by
+    obtain ⟨a, rfl⟩ := circleSectionHomology_zero_surjective X b
+    exact
+      congrArg (circleSectionHomology X 0) (LinearMap.congr_fun (circleProjection_section X 0) a)
+  right_inv a := LinearMap.congr_fun (circleProjection_section X 0) a
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology3.lean b/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology3.lean
new file mode 100644
index 000000000..f607f2656
--- /dev/null
+++ b/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology3.lean
@@ -0,0 +1,287 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.HomologyTheory.SphereHomology1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology1
+
+/-!
+# Hopf problem: torus homology · period torus higher homology 3
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem PeriodTorusHigherHomology.connectingMap_cycleClass
+    {S : CategoryTheory.ShortComplex (ChainComplex (ModuleCat.{0} ℤ) ℕ)} (hS : S.ShortExact)
+    (n : ℕ) (c : SingularMayerVietoris.ModuleHomology.Cycle S.X₃ (n + 1)) (z₂ : S.X₂.X (n + 1))
+    (hz₂ : (S.g.f (n + 1)).hom z₂ = c.1) (z₁ : SingularMayerVietoris.ModuleHomology.Cycle S.X₁ n)
+    (hz₁ : (S.f.f n).hom z₁.1 = (S.X₂.d (n + 1) n).hom z₂) :
+    SingularMayerVietoris.connectingMap hS n
+        (SingularMayerVietoris.ModuleHomology.cycleClass S.X₃ (n + 1) c) =
+      SingularMayerVietoris.ModuleHomology.cycleClass S.X₁ n z₁ := by
+  have hc : (S.X₃.d (n + 1) n).hom c.1 = 0 := by
+    have h := SingularMayerVietoris.ModuleHomology.cycle_condition S.X₃ (n + 1) c
+    rw [Nat.add_sub_cancel] at h
+    exact h
+  have hnext : (ComplexShape.down ℕ).next (n + 1) = n := (ComplexShape.down ℕ).next_eq' (by simp)
+  have h₃ :=
+    SingularMayerVietoris.ModuleHomology.cycleClass_eq_homologyClassOfCycle_of_next S.X₃ (n + 1) c
+      n hnext hc
+  have hδ := SingularMayerVietoris.connectingMap_homologyClassOfCycle hS n c.1 hc z₂ hz₂ z₁.1 hz₁
+  have h₁ :=
+    SingularMayerVietoris.ModuleHomology.cycleClass_eq_homologyClassOfCycle_of_next S.X₁ n z₁
+      ((ComplexShape.down ℕ).next n) rfl
+      (SingularMayerVietoris.connectingMap_lift_is_cycle hS n z₂ z₁.1 hz₁ _)
+  exact (congrArg (SingularMayerVietoris.connectingMap hS n) h₃).trans (hδ.trans h₁.symm)
+
+private theorem
+    PeriodTorusHigherHomology.smallConnectingMap_cycleClass {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ)
+    (c :
+      SingularMayerVietoris.ModuleHomology.Cycle (SingularMayerVietoris.smallComplex U V) (n + 1))
+    (z₂ : (SingularMayerVietoris.middleComplex U V).X (n + 1))
+    (hz₂ : ((SingularMayerVietoris.rightMap U V).f (n + 1)).hom z₂ = c.1)
+    (z₁ :
+      SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex (U ∩ V : Set X))
+        n)
+    (hz₁ :
+      ((SingularMayerVietoris.leftMap U V).f n).hom z₁.1 =
+        ((SingularMayerVietoris.middleComplex U V).d (n + 1) n).hom z₂) :
+    SingularMayerVietoris.smallConnectingMap U V n
+        (SingularMayerVietoris.ModuleHomology.cycleClass (SingularMayerVietoris.smallComplex U V)
+          (n + 1) c) =
+      SingularMayerVietoris.ModuleHomology.cycleClass
+        (FirstHurewicz.singularComplex (U ∩ V : Set X)) n z₁ :=
+  connectingMap_cycleClass (SingularMayerVietoris.chainSequence_shortExact U V) n c z₂ hz₂ z₁ hz₁
+
+private theorem PeriodTorusHigherHomology.connectingHomomorphism_cycleClass {X : Type}
+    [TopologicalSpace X] (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ)
+    (n : ℕ)
+    (c :
+      SingularMayerVietoris.ModuleHomology.Cycle (SingularMayerVietoris.smallComplex U V) (n + 1))
+    (z₂ : (SingularMayerVietoris.middleComplex U V).X (n + 1))
+    (hz₂ : ((SingularMayerVietoris.rightMap U V).f (n + 1)).hom z₂ = c.1)
+    (z₁ :
+      SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex (U ∩ V : Set X))
+        n)
+    (hz₁ :
+      ((SingularMayerVietoris.leftMap U V).f n).hom z₁.1 =
+        ((SingularMayerVietoris.middleComplex U V).d (n + 1) n).hom z₂) :
+    SingularMayerVietoris.connectingHomomorphism U V hU hV hcover n
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) (n + 1)
+          (SingularMayerVietoris.ModuleHomology.mapCycles
+            (SingularMayerVietoris.smallInclusion U V) (n + 1) c)) =
+      SingularMayerVietoris.ModuleHomology.cycleClass
+        (FirstHurewicz.singularComplex (U ∩ V : Set X)) n z₁ := by
+  rw [← SingularMayerVietoris.ModuleHomology.homologyMap_cycleClass]
+  change
+    SingularMayerVietoris.connectingHomomorphism U V hU hV hcover n
+        (SingularMayerVietoris.smallHomologyComparison U V (n + 1)
+          (SingularMayerVietoris.ModuleHomology.cycleClass
+            (SingularMayerVietoris.smallComplex U V) (n + 1) c)) =
+      _
+  rw [SingularMayerVietoris.connectingHomomorphism_comparison]
+  exact smallConnectingMap_cycleClass U V n c z₂ hz₂ z₁ hz₁
+
+private def PeriodTorusHigherHomology.pointCycle {X : Type} [TopologicalSpace X] (x : X) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 0 :=
+  SingularMayerVietoris.ModuleHomology.mkCycle (FirstHurewicz.singularComplex X) 0
+    (FirstHurewicz.simplexChain X 0 (ContinuousMap.const (FirstHurewicz.Simplex 0) x))
+    (by
+      have h := (FirstHurewicz.singularComplex X).shape 0 0 (by simp)
+      exact
+        congrArg
+          (fun f =>
+            f.hom
+              (FirstHurewicz.simplexChain X 0 (ContinuousMap.const (FirstHurewicz.Simplex 0) x)))
+          h)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.pointCycle_val {X : Type} [TopologicalSpace X] (x : X) :
+    (pointCycle x).1 =
+      FirstHurewicz.simplexChain X 0 (ContinuousMap.const (FirstHurewicz.Simplex 0) x) :=
+  rfl
+
+private def PeriodTorusHigherHomology.pointClass {X : Type} [TopologicalSpace X] (x : X) :
+    SingularMayerVietoris.SingularHomology X 0 :=
+  SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 0
+    (pointCycle x)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.mapCycles_pointCycle {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (x : X) :
+    SingularMayerVietoris.ModuleHomology.mapCycles (FirstHurewicz.singularChainMap f) 0
+        (pointCycle x) =
+      pointCycle (f x) := by
+  apply Subtype.ext
+  rw [SingularMayerVietoris.ModuleHomology.mapCycles_val, pointCycle_val, pointCycle_val]
+  change
+    FirstHurewicz.inducedChain f 0
+        (FirstHurewicz.simplexChain X 0 (ContinuousMap.const (FirstHurewicz.Simplex 0) x)) =
+      _
+  rw [FirstHurewicz.inducedChain_simplex]
+  apply congrArg (FirstHurewicz.simplexChain Y 0)
+  apply ContinuousMap.ext
+  intro t
+  rfl
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.singularHomologyMap_pointClass {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (x : X) :
+    SingularMayerVietoris.singularHomologyMap f 0 (pointClass x) = pointClass (f x) := by
+  change
+    (HomologicalComplex.homologyMap (FirstHurewicz.singularChainMap f) 0).hom
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 0
+          (pointCycle x)) =
+      _
+  rw [SingularMayerVietoris.ModuleHomology.homologyMap_cycleClass, mapCycles_pointCycle]
+  rfl
+
+private def PeriodTorusHigherHomology.pointCycleLift_mo1973_4686 {X : Type} [TopologicalSpace X]
+    (x : X) : ModuleCat.of ℤ ℤ ⟶ (FirstHurewicz.singularComplex X).cycles 0 :=
+  (FirstHurewicz.singularComplex X).liftCycles
+    ((TopCat.toSSet.obj (TopCat.of X)).ιChainComplex (R := ModuleCat.of ℤ ℤ)
+      (FirstHurewicz.simplexIndex X 0 (ContinuousMap.const (FirstHurewicz.Simplex 0) x)))
+    0 (by simp) (by simp)
+
+private theorem PeriodTorusHigherHomology.pointClass_eq_pointCycleLift_mo1973_4687 {X : Type}
+    [TopologicalSpace X] (x : X) :
+    pointClass x =
+      (FirstHurewicz.singularComplex X).homologyπ 0 ((pointCycleLift_mo1973_4686 x).hom 1) := by
+  rw [pointClass, SingularMayerVietoris.ModuleHomology.cycleClass_eq_homologyClassOfCycle,
+    SingularMayerVietoris.homologyClassOfCycle]
+  apply congrArg ((FirstHurewicz.singularComplex X).homologyπ 0).hom
+  apply
+    (ModuleCat.mono_iff_injective ((FirstHurewicz.singularComplex X).iCycles 0)).mp inferInstance
+  have h₁ :=
+    (FirstHurewicz.singularComplex X).i_cyclesMk (pointCycle x).1 (0 - 1)
+      (SingularMayerVietoris.ModuleHomology.next_nat 0)
+      (SingularMayerVietoris.ModuleHomology.cycle_condition (FirstHurewicz.singularComplex X) 0
+        (pointCycle x))
+  have h₂ :=
+    congrArg (fun f => f.hom 1)
+      ((FirstHurewicz.singularComplex X).liftCycles_i
+        ((TopCat.toSSet.obj (TopCat.of X)).ιChainComplex (R := ModuleCat.of ℤ ℤ)
+          (FirstHurewicz.simplexIndex X 0 (ContinuousMap.const (FirstHurewicz.Simplex 0) x)))
+        0 (by simp) (by simp))
+  exact h₁.trans h₂.symm
+
+@[simp]
+private theorem PeriodTorusHigherHomology.pointClass_augmentation {X : Type} [TopologicalSpace X]
+    (x : X) : ((TopCat.of X).singularHomology₀ε (ModuleCat.of ℤ ℤ)).hom (pointClass x) = 1 := by
+  rw [pointClass_eq_pointCycleLift_mo1973_4687]
+  exact
+    congrArg (fun f => f.hom 1)
+      ((TopCat.toSSet.obj (TopCat.of X)).liftCycles_ιChainComplex_homologyπ_homology₀ε
+        (ModuleCat.of ℤ ℤ)
+        (FirstHurewicz.simplexIndex X 0 (ContinuousMap.const (FirstHurewicz.Simplex 0) x)))
+
+@[simp]
+private theorem PeriodTorusHigherHomology.connectedHomologyZeroEquiv_pointClass {X : Type}
+    [TopologicalSpace X] [PathConnectedSpace X] (x : X) :
+    connectedHomologyZeroEquiv X (pointClass x) = 1 :=
+  pointClass_augmentation x
+
+private theorem PeriodTorusHigherHomology.eq_zsmul_pointClass {X : Type} [TopologicalSpace X]
+    [PathConnectedSpace X] (x : X) (a : SingularMayerVietoris.SingularHomology X 0) :
+    a = connectedHomologyZeroEquiv X a • pointClass x := by
+  apply (connectedHomologyZeroEquiv X).injective
+  rw [map_zsmul, connectedHomologyZeroEquiv_pointClass, zsmul_eq_mul, mul_one]
+  simp
+
+private theorem PeriodTorusHigherHomology.connectedHomologyZeroEquiv_natural {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] [PathConnectedSpace X] [PathConnectedSpace Y]
+    (f : C(X, Y)) (a : SingularMayerVietoris.SingularHomology X 0) :
+    connectedHomologyZeroEquiv Y (SingularMayerVietoris.singularHomologyMap f 0 a) =
+      connectedHomologyZeroEquiv X a := by
+  let x : X := Classical.arbitrary X
+  calc
+    connectedHomologyZeroEquiv Y (SingularMayerVietoris.singularHomologyMap f 0 a) =
+        connectedHomologyZeroEquiv Y
+          (SingularMayerVietoris.singularHomologyMap f 0
+            (connectedHomologyZeroEquiv X a • pointClass x)) :=
+      congrArg
+        (fun b => connectedHomologyZeroEquiv Y (SingularMayerVietoris.singularHomologyMap f 0 b))
+        (eq_zsmul_pointClass x a)
+    _ = connectedHomologyZeroEquiv X a := by
+      rw [map_zsmul, map_zsmul, singularHomologyMap_pointClass,
+        connectedHomologyZeroEquiv_pointClass, zsmul_eq_mul, mul_one]
+      simp
+
+private def PeriodTorusHigherHomology.trivialFirstEquiv_mo1973_4693 (A B : Type*) [AddCommGroup A]
+    [AddCommGroup B] [Module ℤ B] [Subsingleton A] : (A × B) ≃ₗ[ℤ] B :=
+  ({    toFun a := a.2
+        invFun b := (0, b)
+        left_inv _ := Prod.ext (Subsingleton.elim _ _) rfl
+        right_inv _ := rfl
+        map_add' _ _ := rfl } : (A × B) ≃+ B).toIntLinearEquiv
+
+/-- The canonical linear equivalence from first homology of the circle to the integers. -/
+public
+def PeriodTorusHigherHomology.circleHomologyOneEquiv :
+    SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.CircleTopology.Circle)
+        1 ≃ₗ[ℤ]
+      ℤ := by
+  letI := point_homology_subsingleton 1 (by decide)
+  exact
+    ((homeomorphHomologyEquiv
+              (Homeomorph.prodUnique (PeriodTorusHigherHomology.CircleTopology.Circle) Unit).symm
+              1).trans
+          (circleProductHomologyEquiv Unit 0)).trans
+      ((trivialFirstEquiv_mo1973_4693 (SingularMayerVietoris.SingularHomology Unit 1)
+            (SingularMayerVietoris.SingularHomology Unit 0)).trans
+        pointHomologyZeroEquiv)
+
+private theorem PeriodTorusHigherHomology.circleHomologyOneEquiv_apply
+    (a :
+      SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.CircleTopology.Circle)
+        1) :
+    circleHomologyOneEquiv a =
+      pointHomologyZeroEquiv
+        (circleBoundary Unit 0
+          (homeomorphHomologyEquiv
+            (Homeomorph.prodUnique (PeriodTorusHigherHomology.CircleTopology.Circle) Unit).symm 1
+            a)) :=
+  rfl
+
+private theorem PeriodTorusHigherHomology.circle_homology_subsingleton (n : ℕ) :
+    Subsingleton
+      (SingularMayerVietoris.SingularHomology (PeriodTorusHigherHomology.CircleTopology.Circle)
+        (n + 2)) := by
+  let := point_homology_subsingleton (n + 2) (Nat.succ_ne_zero _)
+  let := point_homology_subsingleton (n + 1) (Nat.succ_ne_zero _)
+  exact
+    ((homeomorphHomologyEquiv
+            (Homeomorph.prodUnique (PeriodTorusHigherHomology.CircleTopology.Circle) Unit).symm
+            (n + 2)).trans
+        (circleProductHomologyEquiv Unit (n + 1))).injective.subsingleton
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology4.lean b/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology4.lean
new file mode 100644
index 000000000..9cf52df20
--- /dev/null
+++ b/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology4.lean
@@ -0,0 +1,1767 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.HomologyTheory.SphereHomology2
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology3
+import all LeanPool.HopfProblem.HomologyTheory.SphereHomology2
+
+/-!
+# Hopf problem: torus homology · period torus higher homology 4
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+@[instance_reducible]
+private def PeriodTorusHigherHomology.integerLinearMapModule {A B : Type*} [AddCommGroup A]
+    [AddCommGroup B] [modA : Module ℤ A] [modB : Module ℤ B] : Module ℤ (A →ₗ[ℤ] B) :=
+  @LinearMap.module ℤ ℤ ℤ A B _ _ _ _ modA modB (RingHom.id ℤ) _ modB
+    (@smulCommClass_self ℤ B _ modB.toMulAction)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule in
+@[instance_reducible]
+private def
+    PeriodTorusHigherHomology.integerTensorModule {A B : Type*} [AddCommGroup A] [AddCommGroup B]
+    [modA : Module ℤ A] [modB : Module ℤ B] : Module ℤ (A ⊗[ℤ] B) :=
+  @TensorProduct.instModule ℤ _ A B _ _ modA modB
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomology.integerBilinearRightApply {A B C : Type*} [AddCommGroup A]
+    [AddCommGroup B] [AddCommGroup C] [Module ℤ A] [Module ℤ B] [Module ℤ C]
+    (F : A →ₗ[ℤ] B →ₗ[ℤ] C) (b : B) : A →ₗ[ℤ] C
+    where
+  toFun a := F a b
+  map_add' a a' := congrArg (fun l : B →ₗ[ℤ] C => l b) (F.map_add a a')
+  map_smul' r a := congrArg (fun l : B →ₗ[ℤ] C => l b) (F.map_smul r a)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.integerBilinearRightApply_apply {A B C : Type*} [AddCommGroup A]
+    [AddCommGroup B] [AddCommGroup C] [Module ℤ A] [Module ℤ B] [Module ℤ C]
+    (F : A →ₗ[ℤ] B →ₗ[ℤ] C) (b : B) (a : A) : integerBilinearRightApply F b a = F a b :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomology.integerBilinearFlip {A B C : Type*} [AddCommGroup A]
+    [AddCommGroup B] [AddCommGroup C] [Module ℤ A] [Module ℤ B] [Module ℤ C]
+    (F : A →ₗ[ℤ] B →ₗ[ℤ] C) : B →ₗ[ℤ] A →ₗ[ℤ] C
+    where
+  toFun := integerBilinearRightApply F
+  map_add' b
+    b' := by
+    apply LinearMap.ext
+    intro a
+    exact (F a).map_add b b'
+  map_smul' r
+    b := by
+    apply LinearMap.ext
+    intro a
+    exact (F a).map_smul r b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodTorusHigherHomology.integerBilinearFlip_apply {A B C : Type*} [AddCommGroup A]
+    [AddCommGroup B] [AddCommGroup C] [Module ℤ A] [Module ℤ B] [Module ℤ C]
+    (F : A →ₗ[ℤ] B →ₗ[ℤ] C) (b : B) (a : A) : integerBilinearFlip F b a = F a b :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomology.chainBilinearLift (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (p q : ℕ) {M : Type} [AddCommGroup M] [modM : Module ℤ M]
+    (f : FirstHurewicz.SingularSimplex X p → FirstHurewicz.SingularSimplex Y q → M) :
+    FirstHurewicz.Chains X p →ₗ[ℤ] FirstHurewicz.Chains Y q →ₗ[ℤ] M :=
+  FirstHurewicz.chainLift X p fun σ => FirstHurewicz.chainLift Y q (f σ)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.chainBilinearLift_simplex_left (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (p q : ℕ) {M : Type} [AddCommGroup M] [modM : Module ℤ M]
+    (f : FirstHurewicz.SingularSimplex X p → FirstHurewicz.SingularSimplex Y q → M)
+    (σ : FirstHurewicz.SingularSimplex X p) :
+    chainBilinearLift X Y p q f (FirstHurewicz.simplexChain X p σ) =
+      FirstHurewicz.chainLift Y q (f σ) :=
+  FirstHurewicz.chainLift_simplex X p _ σ
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomology.chainBilinearLift_simplex (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (p q : ℕ) {M : Type} [AddCommGroup M] [modM : Module ℤ M]
+    (f : FirstHurewicz.SingularSimplex X p → FirstHurewicz.SingularSimplex Y q → M)
+    (σ : FirstHurewicz.SingularSimplex X p) (τ : FirstHurewicz.SingularSimplex Y q) :
+    chainBilinearLift X Y p q f (FirstHurewicz.simplexChain X p σ)
+        (FirstHurewicz.simplexChain Y q τ) =
+      f σ τ := by rw [chainBilinearLift_simplex_left, FirstHurewicz.chainLift_simplex]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.chainBilinearMap_ext (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (p q : ℕ) {M : Type} [AddCommGroup M] [modM : Module ℤ M]
+    {F G : FirstHurewicz.Chains X p →ₗ[ℤ] FirstHurewicz.Chains Y q →ₗ[ℤ] M}
+    (h :
+      ∀ σ τ,
+        F (FirstHurewicz.simplexChain X p σ) (FirstHurewicz.simplexChain Y q τ) =
+          G (FirstHurewicz.simplexChain X p σ) (FirstHurewicz.simplexChain Y q τ)) :
+    F = G := by
+  apply FirstHurewicz.chainMap_ext X p
+  intro σ
+  apply FirstHurewicz.chainMap_ext Y q
+  intro τ
+  exact h σ τ
+
+private def PeriodTorusHigherHomology.zeroSimplexValue {X : Type} [TopologicalSpace X]
+    (σ : FirstHurewicz.SingularSimplex X 0) : X :=
+  σ (stdSimplex.vertex (S := ℝ) (0 : Fin 1))
+
+@[simp]
+private theorem PeriodTorusHigherHomology.zeroSimplexValue_comp {X X' : Type} [TopologicalSpace X]
+    [TopologicalSpace X'] (f : C(X, X')) (σ : FirstHurewicz.SingularSimplex X 0) :
+    zeroSimplexValue (f.comp σ) = f (zeroSimplexValue σ) :=
+  rfl
+
+private def PeriodTorusHigherHomology.crossInsertLeft {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (x : X) : C(Y, X × Y) :=
+  ⟨fun y => (x, y), continuous_const.prodMk continuous_id⟩
+
+private def PeriodTorusHigherHomology.crossInsertRight {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (y : Y) : C(X, X × Y) :=
+  ⟨fun x => (x, y), continuous_id.prodMk continuous_const⟩
+
+private theorem
+    PeriodTorusHigherHomology.crossInsertLeft_natural {X Y X' Y' : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] [TopologicalSpace X'] [TopologicalSpace Y'] (f : C(X, X')) (g : C(Y, Y'))
+    (x : X) : (f.prodMap g).comp (crossInsertLeft x) = (crossInsertLeft (f x)).comp g :=
+  rfl
+
+private theorem PeriodTorusHigherHomology.inducedChain_crossInsertLeft {X Y X' Y' : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace X'] [TopologicalSpace Y']
+    (f : C(X, X')) (g : C(Y, Y')) (x : X) (n : ℕ) (c : FirstHurewicz.Chains Y n) :
+    FirstHurewicz.inducedChain (f.prodMap g) n
+        (FirstHurewicz.inducedChain (crossInsertLeft x) n c) =
+      FirstHurewicz.inducedChain (crossInsertLeft (f x)) n (FirstHurewicz.inducedChain g n c) := by
+  have h :=
+    congrArg (fun h : C(Y, X' × Y') => FirstHurewicz.inducedChain h n c)
+      (crossInsertLeft_natural f g x)
+  simpa only [FirstHurewicz.inducedChain_comp, LinearMap.comp_apply] using h
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomology.crossProductZeroLeft (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) :
+    FirstHurewicz.Chains X 0 →ₗ[ℤ]
+      FirstHurewicz.Chains Y n →ₗ[ℤ] FirstHurewicz.Chains (X × Y) n :=
+  chainBilinearLift X Y 0 n fun σ τ =>
+    FirstHurewicz.simplexChain (X × Y) n ((crossInsertLeft (zeroSimplexValue σ)).comp τ)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomology.crossProductZeroRight (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) :
+    FirstHurewicz.Chains X n →ₗ[ℤ]
+      FirstHurewicz.Chains Y 0 →ₗ[ℤ] FirstHurewicz.Chains (X × Y) n :=
+  chainBilinearLift X Y n 0 fun σ τ =>
+    FirstHurewicz.simplexChain (X × Y) n ((crossInsertRight (zeroSimplexValue τ)).comp σ)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodTorusHigherHomology.crossProductZeroLeft_simplex_left {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (n : ℕ) (σ : FirstHurewicz.SingularSimplex X 0) :
+    crossProductZeroLeft X Y n (FirstHurewicz.simplexChain X 0 σ) =
+      FirstHurewicz.inducedChain (crossInsertLeft (Y := Y) (zeroSimplexValue σ)) n := by
+  apply FirstHurewicz.chainMap_ext Y n
+  intro τ
+  rw [crossProductZeroLeft, chainBilinearLift_simplex, FirstHurewicz.inducedChain_simplex]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomology.crossProductZeroLeft_simplex {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) (σ : FirstHurewicz.SingularSimplex X 0)
+    (τ : FirstHurewicz.SingularSimplex Y n) :
+    crossProductZeroLeft X Y n (FirstHurewicz.simplexChain X 0 σ)
+        (FirstHurewicz.simplexChain Y n τ) =
+      FirstHurewicz.simplexChain (X × Y) n ((crossInsertLeft (zeroSimplexValue σ)).comp τ) := by
+  rw [crossProductZeroLeft_simplex_left, FirstHurewicz.inducedChain_simplex]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodTorusHigherHomology.crossProductZeroRight_simplex_right {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (n : ℕ) (c : FirstHurewicz.Chains X n)
+    (τ : FirstHurewicz.SingularSimplex Y 0) :
+    crossProductZeroRight X Y n c (FirstHurewicz.simplexChain Y 0 τ) =
+      FirstHurewicz.inducedChain (crossInsertRight (zeroSimplexValue τ)) n c := by
+  have h :
+    integerBilinearRightApply (crossProductZeroRight X Y n) (FirstHurewicz.simplexChain Y 0 τ) =
+      FirstHurewicz.inducedChain (crossInsertRight (zeroSimplexValue τ)) n := by
+    apply FirstHurewicz.chainMap_ext X n
+    intro σ
+    simp only [integerBilinearRightApply_apply, crossProductZeroRight, chainBilinearLift_simplex,
+      FirstHurewicz.inducedChain_simplex]
+  exact LinearMap.congr_fun h c
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomology.crossProductZeroRight_simplex {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) (σ : FirstHurewicz.SingularSimplex X n)
+    (τ : FirstHurewicz.SingularSimplex Y 0) :
+    crossProductZeroRight X Y n (FirstHurewicz.simplexChain X n σ)
+        (FirstHurewicz.simplexChain Y 0 τ) =
+      FirstHurewicz.simplexChain (X × Y) n ((crossInsertRight (zeroSimplexValue τ)).comp σ) := by
+  rw [crossProductZeroRight_simplex_right, FirstHurewicz.inducedChain_simplex]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductZeroLeft_natural {X Y X' Y' : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace X'] [TopologicalSpace Y']
+    (f : C(X, X')) (g : C(Y, Y')) (n : ℕ) (a : FirstHurewicz.Chains X 0)
+    (b : FirstHurewicz.Chains Y n) :
+    FirstHurewicz.inducedChain (f.prodMap g) n (crossProductZeroLeft X Y n a b) =
+      crossProductZeroLeft X' Y' n (FirstHurewicz.inducedChain f 0 a)
+        (FirstHurewicz.inducedChain g n b) := by
+  have h :
+    (FirstHurewicz.inducedChain (f.prodMap g) n).comp
+        (integerBilinearRightApply (crossProductZeroLeft X Y n) b) =
+      (integerBilinearRightApply (crossProductZeroLeft X' Y' n)
+            (FirstHurewicz.inducedChain g n b)).comp
+        (FirstHurewicz.inducedChain f 0) := by
+    apply FirstHurewicz.chainMap_ext X 0
+    intro σ
+    simp only [LinearMap.comp_apply, integerBilinearRightApply_apply,
+      FirstHurewicz.inducedChain_simplex, crossProductZeroLeft_simplex_left,
+      zeroSimplexValue_comp]
+    exact inducedChain_crossInsertLeft f g (zeroSimplexValue σ) n b
+  exact LinearMap.congr_fun h a
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomology.integerBilinearPostcompose {A B C D : Type*} [AddCommGroup A]
+    [AddCommGroup B] [AddCommGroup C] [AddCommGroup D] [Module ℤ A] [Module ℤ B] [Module ℤ C]
+    [Module ℤ D] (F : A →ₗ[ℤ] B →ₗ[ℤ] C) (g : C →ₗ[ℤ] D) : A →ₗ[ℤ] B →ₗ[ℤ] D
+    where
+  toFun a := g.comp (F a)
+  map_add' a
+    a' := by
+    apply LinearMap.ext
+    intro b
+    exact
+      (congrArg (fun l : B →ₗ[ℤ] C => g (l b)) (F.map_add a a')).trans
+        (g.map_add (F a b) (F a' b))
+  map_smul' r
+    a := by
+    apply LinearMap.ext
+    intro b
+    exact (congrArg (fun l : B →ₗ[ℤ] C => g (l b)) (F.map_smul r a)).trans (g.map_smul r (F a b))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodTorusHigherHomology.integerBilinearPostcompose_apply {A B C D : Type*}
+    [AddCommGroup A] [AddCommGroup B] [AddCommGroup C] [AddCommGroup D] [Module ℤ A] [Module ℤ B]
+    [Module ℤ C] [Module ℤ D] (F : A →ₗ[ℤ] B →ₗ[ℤ] C) (g : C →ₗ[ℤ] D) (a : A) (b : B) :
+    integerBilinearPostcompose F g a b = g (F a b) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    PeriodTorusHigherHomology.integerBilinearPrecompose {A B C A' B' : Type*} [AddCommGroup A]
+    [AddCommGroup B] [AddCommGroup C] [AddCommGroup A'] [AddCommGroup B'] [Module ℤ A]
+    [Module ℤ B] [Module ℤ C] [Module ℤ A'] [Module ℤ B'] (F : A →ₗ[ℤ] B →ₗ[ℤ] C) (f : A' →ₗ[ℤ] A)
+    (g : B' →ₗ[ℤ] B) : A' →ₗ[ℤ] B' →ₗ[ℤ] C
+    where
+  toFun a := (F (f a)).comp g
+  map_add' a
+    a' := by
+    apply LinearMap.ext
+    intro b
+    exact
+      (congrArg (fun x => F x (g b)) (f.map_add a a')).trans
+        (congrArg (fun l : B →ₗ[ℤ] C => l (g b)) (F.map_add (f a) (f a')))
+  map_smul' r
+    a := by
+    apply LinearMap.ext
+    intro b
+    exact
+      (congrArg (fun x => F x (g b)) (f.map_smul r a)).trans
+        (congrArg (fun l : B →ₗ[ℤ] C => l (g b)) (F.map_smul r (f a)))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodTorusHigherHomology.integerBilinearPrecompose_apply {A B C A' B' : Type*}
+    [AddCommGroup A] [AddCommGroup B] [AddCommGroup C] [AddCommGroup A'] [AddCommGroup B']
+    [Module ℤ A] [Module ℤ B] [Module ℤ C] [Module ℤ A'] [Module ℤ B'] (F : A →ₗ[ℤ] B →ₗ[ℤ] C)
+    (f : A' →ₗ[ℤ] A) (g : B' →ₗ[ℤ] B) (a : A') (b : B') :
+    integerBilinearPrecompose F f g a b = F (f a) (g b) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomology.integerFormalBilinearMap_ext (V W : Type*) (p q : ℕ) {M : Type*}
+    [AddCommGroup M] [Module ℤ M]
+    {F G :
+      SingularMayerVietoris.FormalChains V p →ₗ[ℤ] SingularMayerVietoris.FormalChains W q →ₗ[ℤ] M}
+    (h :
+      ∀ v w,
+        F (SingularMayerVietoris.formalSimplex v) (SingularMayerVietoris.formalSimplex w) =
+          G (SingularMayerVietoris.formalSimplex v) (SingularMayerVietoris.formalSimplex w)) :
+    F = G := by
+  apply SingularMayerVietoris.formalChains_ext
+  intro v
+  apply SingularMayerVietoris.formalChains_ext
+  intro w
+  exact h v w
+
+private theorem PeriodTorusHigherHomology.formalChains_bilinear_ext {V W M : Type*} {n m : ℕ}
+    [AddCommGroup M] [Module ℤ M]
+    {f g :
+      SingularMayerVietoris.FormalChains V n →ₗ[ℤ] SingularMayerVietoris.FormalChains W m →ₗ[ℤ] M}
+    (h :
+      ∀ v w,
+        f (SingularMayerVietoris.formalSimplex v) (SingularMayerVietoris.formalSimplex w) =
+          g (SingularMayerVietoris.formalSimplex v) (SingularMayerVietoris.formalSimplex w)) :
+    f = g := by
+  apply SingularMayerVietoris.formalChains_ext
+  intro v
+  apply SingularMayerVietoris.formalChains_ext
+  exact h v
+
+private def PeriodTorusHigherHomology.formalBilinearLift {V W M : Type*} {n m : ℕ} [AddCommGroup M]
+    [Module ℤ M] (f : (Fin n → V) → (Fin m → W) → M) :
+    SingularMayerVietoris.FormalChains V n →ₗ[ℤ] SingularMayerVietoris.FormalChains W m →ₗ[ℤ] M :=
+  SingularMayerVietoris.formalLift fun v => SingularMayerVietoris.formalLift (f v)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.formalBilinearLift_simplex {V W M : Type*} {n m : ℕ}
+    [AddCommGroup M] [Module ℤ M] (f : (Fin n → V) → (Fin m → W) → M) (v : Fin n → V)
+    (w : Fin m → W) :
+    formalBilinearLift f (SingularMayerVietoris.formalSimplex v)
+        (SingularMayerVietoris.formalSimplex w) =
+      f v w := by simp [formalBilinearLift]
+
+private def PeriodTorusHigherHomology.formalPointCrossProduct {V W : Type*} (q : ℕ) :
+    SingularMayerVietoris.FormalChains V 1 →ₗ[ℤ]
+      SingularMayerVietoris.FormalChains W (q + 1) →ₗ[ℤ]
+        SingularMayerVietoris.FormalChains (V × W) (q + 1) :=
+  SingularMayerVietoris.formalLift fun v =>
+    SingularMayerVietoris.formalMap (fun w => (v 0, w)) (q + 1)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.formalPointCrossProduct_simplex_left {V W : Type*} (q : ℕ)
+    (v : Fin 1 → V) (d : SingularMayerVietoris.FormalChains W (q + 1)) :
+    formalPointCrossProduct q (SingularMayerVietoris.formalSimplex v) d =
+      SingularMayerVietoris.formalMap (fun w => (v 0, w)) (q + 1) d := by
+  exact LinearMap.congr_fun (SingularMayerVietoris.formalLift_simplex _ _) d
+
+private theorem PeriodTorusHigherHomology.formalPointCrossProduct_simplex {V W : Type*} (q : ℕ)
+    (v : Fin 1 → V) (w : Fin (q + 1) → W) :
+    formalPointCrossProduct q (SingularMayerVietoris.formalSimplex v)
+        (SingularMayerVietoris.formalSimplex w) =
+      SingularMayerVietoris.formalSimplex (fun i => (v 0, w i)) := by
+  rw [formalPointCrossProduct_simplex_left, SingularMayerVietoris.formalMap_simplex]
+  rfl
+
+@[simp]
+private theorem PeriodTorusHigherHomology.formalPointCrossProduct_zero_simplex_right {V W : Type*}
+    (c : SingularMayerVietoris.FormalChains V 1) (w : Fin 1 → W) :
+    formalPointCrossProduct 0 c (SingularMayerVietoris.formalSimplex w) =
+      SingularMayerVietoris.formalMap (fun v => (v, w 0)) 1 c := by
+  have h :
+    (formalPointCrossProduct (V := V) 0).flip (SingularMayerVietoris.formalSimplex w) =
+      SingularMayerVietoris.formalMap (fun v => (v, w 0)) 1 := by
+    apply SingularMayerVietoris.formalChains_ext
+    intro v
+    simp only [LinearMap.flip_apply, formalPointCrossProduct_simplex,
+      SingularMayerVietoris.formalMap_simplex]
+    congr 1
+    funext i
+    rw [Fin.eq_zero i]
+    rfl
+  exact LinearMap.congr_fun h c
+
+private theorem PeriodTorusHigherHomology.formalBoundary_pointCrossProduct {V W : Type*} (q : ℕ)
+    (c : SingularMayerVietoris.FormalChains V 1)
+    (d : SingularMayerVietoris.FormalChains W (q + 2)) :
+    SingularMayerVietoris.formalBoundary (q + 1) (formalPointCrossProduct (q + 1) c d) =
+      formalPointCrossProduct q c (SingularMayerVietoris.formalBoundary (q + 1) d) := by
+  have h :
+    (formalPointCrossProduct (V := V) (W := W) (q + 1)).compr₂
+        (SingularMayerVietoris.formalBoundary (q + 1)) =
+      (formalPointCrossProduct q).compl₂ (SingularMayerVietoris.formalBoundary (q + 1)) := by
+    apply formalChains_bilinear_ext
+    intro v w
+    simp only [LinearMap.compr₂_apply, LinearMap.compl₂_apply,
+      formalPointCrossProduct_simplex_left]
+    exact
+      (SingularMayerVietoris.formalMap_boundary (fun z => (v 0, z)) (q + 1)
+          (SingularMayerVietoris.formalSimplex w)).symm
+  exact LinearMap.congr_fun (LinearMap.congr_fun h c) d
+
+private theorem
+    PeriodTorusHigherHomology.formalMap_pointCrossProduct {V W V' W' : Type*} (f : V → V')
+    (g : W → W') (q : ℕ) (c : SingularMayerVietoris.FormalChains V 1)
+    (d : SingularMayerVietoris.FormalChains W (q + 1)) :
+    SingularMayerVietoris.formalMap (Prod.map f g) (q + 1) (formalPointCrossProduct q c d) =
+      formalPointCrossProduct q (SingularMayerVietoris.formalMap f 1 c)
+        (SingularMayerVietoris.formalMap g (q + 1) d) := by
+  have h :
+    (formalPointCrossProduct (V := V) (W := W) q).compr₂
+        (SingularMayerVietoris.formalMap (Prod.map f g) (q + 1)) =
+      ((formalPointCrossProduct q).compl₂ (SingularMayerVietoris.formalMap g (q + 1))).comp
+        (SingularMayerVietoris.formalMap f 1) := by
+    apply formalChains_bilinear_ext
+    intro v w
+    simp only [LinearMap.compr₂_apply, LinearMap.compl₂_apply, LinearMap.comp_apply,
+      formalPointCrossProduct_simplex, SingularMayerVietoris.formalMap_simplex]
+    rfl
+  exact LinearMap.congr_fun (LinearMap.congr_fun h c) d
+
+/-- The formal chain-level cross product with an oriented edge. -/
+public
+def PeriodTorusHigherHomology.formalEdgeCrossProduct {V W : Type*} :
+    (q : ℕ) →
+      SingularMayerVietoris.FormalChains V 2 →ₗ[ℤ]
+        SingularMayerVietoris.FormalChains W (q + 1) →ₗ[ℤ]
+          SingularMayerVietoris.FormalChains (V × W) (q + 2)
+  | 0 =>
+    (SingularMayerVietoris.formalLift fun w : Fin 1 → W =>
+        SingularMayerVietoris.formalMap (fun v => (v, w 0)) 2).flip
+  | q + 1 =>
+    formalBilinearLift fun v w =>
+      SingularMayerVietoris.formalCone (v 0, w 0) (q + 2)
+        (formalPointCrossProduct (q + 1)
+            (SingularMayerVietoris.formalBoundary 1 (SingularMayerVietoris.formalSimplex v))
+            (SingularMayerVietoris.formalSimplex w) -
+          formalEdgeCrossProduct q (SingularMayerVietoris.formalSimplex v)
+            (SingularMayerVietoris.formalBoundary (q + 1)
+              (SingularMayerVietoris.formalSimplex w)))
+
+@[simp]
+private theorem PeriodTorusHigherHomology.formalEdgeCrossProduct_zero_simplex_right {V W : Type*}
+    (c : SingularMayerVietoris.FormalChains V 2) (w : Fin 1 → W) :
+    formalEdgeCrossProduct 0 c (SingularMayerVietoris.formalSimplex w) =
+      SingularMayerVietoris.formalMap (fun v => (v, w 0)) 2 c := by
+  exact LinearMap.congr_fun (SingularMayerVietoris.formalLift_simplex _ _) c
+
+@[simp]
+private theorem PeriodTorusHigherHomology.formalEdgeCrossProduct_simplex_succ {V W : Type*} (q : ℕ)
+    (v : Fin 2 → V) (w : Fin (q + 2) → W) :
+    formalEdgeCrossProduct (q + 1) (SingularMayerVietoris.formalSimplex v)
+        (SingularMayerVietoris.formalSimplex w) =
+      SingularMayerVietoris.formalCone (v 0, w 0) (q + 2)
+        (formalPointCrossProduct (q + 1)
+            (SingularMayerVietoris.formalBoundary 1 (SingularMayerVietoris.formalSimplex v))
+            (SingularMayerVietoris.formalSimplex w) -
+          formalEdgeCrossProduct q (SingularMayerVietoris.formalSimplex v)
+            (SingularMayerVietoris.formalBoundary (q + 1)
+              (SingularMayerVietoris.formalSimplex w))) :=
+  formalBilinearLift_simplex _ _ _
+
+private theorem PeriodTorusHigherHomology.formalBoundary_edgeCrossProduct_zero {V W : Type*}
+    (c : SingularMayerVietoris.FormalChains V 2) (d : SingularMayerVietoris.FormalChains W 1) :
+    SingularMayerVietoris.formalBoundary 1 (formalEdgeCrossProduct 0 c d) =
+      formalPointCrossProduct 0 (SingularMayerVietoris.formalBoundary 1 c) d := by
+  have h :
+    (formalEdgeCrossProduct (V := V) (W := W) 0).compr₂ (SingularMayerVietoris.formalBoundary 1) =
+      (formalPointCrossProduct 0).comp (SingularMayerVietoris.formalBoundary 1) := by
+    apply formalChains_bilinear_ext
+    intro v w
+    simp only [LinearMap.compr₂_apply, LinearMap.comp_apply,
+      formalEdgeCrossProduct_zero_simplex_right, formalPointCrossProduct_zero_simplex_right]
+    exact
+      (SingularMayerVietoris.formalMap_boundary (fun z => (z, w 0)) 1
+          (SingularMayerVietoris.formalSimplex v)).symm
+  exact LinearMap.congr_fun (LinearMap.congr_fun h c) d
+
+private theorem PeriodTorusHigherHomology.formalBoundary_edgeCrossProduct {V W : Type*} :
+    ∀ (q : ℕ) (c : SingularMayerVietoris.FormalChains V 2)
+      (d : SingularMayerVietoris.FormalChains W (q + 2)),
+      SingularMayerVietoris.formalBoundary (q + 2) (formalEdgeCrossProduct (q + 1) c d) =
+        formalPointCrossProduct (q + 1) (SingularMayerVietoris.formalBoundary 1 c) d -
+          formalEdgeCrossProduct q c (SingularMayerVietoris.formalBoundary (q + 1) d) := by
+  intro q
+  induction q with
+  | zero =>
+    intro c d
+    have h :
+      (formalEdgeCrossProduct (V := V) (W := W) 1).compr₂
+          (SingularMayerVietoris.formalBoundary 2) =
+        (formalPointCrossProduct 1).comp (SingularMayerVietoris.formalBoundary 1) -
+          (formalEdgeCrossProduct 0).compl₂ (SingularMayerVietoris.formalBoundary 1) := by
+      apply formalChains_bilinear_ext
+      intro v w
+      change
+        SingularMayerVietoris.formalBoundary 2
+            (formalEdgeCrossProduct 1 (SingularMayerVietoris.formalSimplex v)
+              (SingularMayerVietoris.formalSimplex w)) =
+          _
+      rw [formalEdgeCrossProduct_simplex_succ, SingularMayerVietoris.formalBoundary_cone]
+      have hz :
+        SingularMayerVietoris.formalBoundary 1
+            (formalPointCrossProduct 1
+                (SingularMayerVietoris.formalBoundary 1 (SingularMayerVietoris.formalSimplex v))
+                (SingularMayerVietoris.formalSimplex w) -
+              formalEdgeCrossProduct 0 (SingularMayerVietoris.formalSimplex v)
+                (SingularMayerVietoris.formalBoundary 1
+                  (SingularMayerVietoris.formalSimplex w))) =
+          0 := by
+        rw [map_sub, formalBoundary_pointCrossProduct, formalBoundary_edgeCrossProduct_zero,
+          sub_self]
+      rw [hz, map_zero, sub_zero]
+      rfl
+    exact LinearMap.congr_fun (LinearMap.congr_fun h c) d
+  | succ q ih =>
+    intro c d
+    have h :
+      (formalEdgeCrossProduct (V := V) (W := W) (q + 2)).compr₂
+          (SingularMayerVietoris.formalBoundary (q + 3)) =
+        (formalPointCrossProduct (q + 2)).comp (SingularMayerVietoris.formalBoundary 1) -
+          (formalEdgeCrossProduct (q + 1)).compl₂
+            (SingularMayerVietoris.formalBoundary (q + 2)) := by
+      apply formalChains_bilinear_ext
+      intro v w
+      change
+        SingularMayerVietoris.formalBoundary (q + 3)
+            (formalEdgeCrossProduct (q + 2) (SingularMayerVietoris.formalSimplex v)
+              (SingularMayerVietoris.formalSimplex w)) =
+          _
+      rw [formalEdgeCrossProduct_simplex_succ, SingularMayerVietoris.formalBoundary_cone]
+      have hz :
+        SingularMayerVietoris.formalBoundary (q + 2)
+            (formalPointCrossProduct (q + 2)
+                (SingularMayerVietoris.formalBoundary 1 (SingularMayerVietoris.formalSimplex v))
+                (SingularMayerVietoris.formalSimplex w) -
+              formalEdgeCrossProduct (q + 1) (SingularMayerVietoris.formalSimplex v)
+                (SingularMayerVietoris.formalBoundary (q + 2)
+                  (SingularMayerVietoris.formalSimplex w))) =
+          0 := by
+        rw [map_sub, formalBoundary_pointCrossProduct, ih,
+          SingularMayerVietoris.formalBoundary_boundary, map_zero, sub_zero, sub_self]
+      rw [hz, map_zero, sub_zero]
+      rfl
+    exact LinearMap.congr_fun (LinearMap.congr_fun h c) d
+
+private theorem
+    PeriodTorusHigherHomology.formalMap_edgeCrossProduct {V W V' W' : Type*} (f : V → V')
+    (g : W → W') :
+    ∀ (q : ℕ) (c : SingularMayerVietoris.FormalChains V 2)
+      (d : SingularMayerVietoris.FormalChains W (q + 1)),
+      SingularMayerVietoris.formalMap (Prod.map f g) (q + 2) (formalEdgeCrossProduct q c d) =
+        formalEdgeCrossProduct q (SingularMayerVietoris.formalMap f 2 c)
+          (SingularMayerVietoris.formalMap g (q + 1) d) := by
+  intro q
+  induction q with
+  | zero =>
+    intro c d
+    have h :
+      (formalEdgeCrossProduct (V := V) (W := W) 0).compr₂
+          (SingularMayerVietoris.formalMap (Prod.map f g) 2) =
+        ((formalEdgeCrossProduct 0).compl₂ (SingularMayerVietoris.formalMap g 1)).comp
+          (SingularMayerVietoris.formalMap f 2) := by
+      apply formalChains_bilinear_ext
+      intro v w
+      simp only [LinearMap.compr₂_apply, LinearMap.compl₂_apply, LinearMap.comp_apply,
+        formalEdgeCrossProduct_zero_simplex_right, SingularMayerVietoris.formalMap_simplex]
+      rfl
+    exact LinearMap.congr_fun (LinearMap.congr_fun h c) d
+  | succ q ih =>
+    intro c d
+    have h :
+      (formalEdgeCrossProduct (V := V) (W := W) (q + 1)).compr₂
+          (SingularMayerVietoris.formalMap (Prod.map f g) (q + 3)) =
+        ((formalEdgeCrossProduct (q + 1)).compl₂ (SingularMayerVietoris.formalMap g (q + 2))).comp
+          (SingularMayerVietoris.formalMap f 2) := by
+      apply formalChains_bilinear_ext
+      intro v w
+      simp only [LinearMap.compr₂_apply, LinearMap.compl₂_apply, LinearMap.comp_apply,
+        SingularMayerVietoris.formalMap_simplex, formalEdgeCrossProduct_simplex_succ]
+      rw [SingularMayerVietoris.formalMap_cone]
+      congr 1
+      rw [map_sub, formalMap_pointCrossProduct, ih, SingularMayerVietoris.formalMap_boundary,
+        SingularMayerVietoris.formalMap_boundary, SingularMayerVietoris.formalMap_simplex,
+        SingularMayerVietoris.formalMap_simplex]
+    exact LinearMap.congr_fun (LinearMap.congr_fun h c) d
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.affineSimplex_constant {n p : ℕ} (a : FirstHurewicz.Simplex p) :
+    SingularMayerVietoris.affineSimplex (fun _ : Fin (n + 1) => a) =
+      ContinuousMap.const (FirstHurewicz.Simplex n) a := by
+  apply ContinuousMap.ext
+  intro t
+  apply Subtype.ext
+  change (∑ i, t i • (a : Fin (p + 1) → ℝ)) = (a : Fin (p + 1) → ℝ)
+  rw [← Finset.sum_smul, stdSimplex.sum_eq_one t, one_smul]
+
+private def PeriodTorusHigherHomology.productAffineSimplex {n p q : ℕ}
+    (v : Fin (n + 1) → FirstHurewicz.Simplex p × FirstHurewicz.Simplex q) :
+    C(FirstHurewicz.Simplex n, FirstHurewicz.Simplex p × FirstHurewicz.Simplex q) :=
+  (SingularMayerVietoris.affineSimplex (fun i => (v i).1)).prodMk
+    (SingularMayerVietoris.affineSimplex (fun i => (v i).2))
+
+@[simp]
+private theorem PeriodTorusHigherHomology.productAffineSimplex_vertex {n p q : ℕ}
+    (v : Fin (n + 1) → FirstHurewicz.Simplex p × FirstHurewicz.Simplex q) (i : Fin (n + 1)) :
+    productAffineSimplex v (SingularMayerVietoris.stdVertices n i) = v i := by
+  apply Prod.ext <;> simp [productAffineSimplex, SingularMayerVietoris.stdVertices]
+
+private theorem PeriodTorusHigherHomology.productAffineSimplex_face {n p q : ℕ}
+    (v : Fin (n + 2) → FirstHurewicz.Simplex p × FirstHurewicz.Simplex q) (i : Fin (n + 2)) :
+    (productAffineSimplex v).comp (FirstHurewicz.simplexFace n i) =
+      productAffineSimplex (fun j => v (i.succAbove j)) := by
+  apply ContinuousMap.ext
+  intro t
+  apply Prod.ext
+  · exact
+      congrArg (fun f : C(FirstHurewicz.Simplex n, FirstHurewicz.Simplex p) => f t)
+        (SingularMayerVietoris.affineSimplex_face (fun j => (v j).1) i)
+  · exact
+      congrArg (fun f : C(FirstHurewicz.Simplex n, FirstHurewicz.Simplex q) => f t)
+        (SingularMayerVietoris.affineSimplex_face (fun j => (v j).2) i)
+
+private theorem PeriodTorusHigherHomology.prodMap_productAffineSimplex {m p q r s : ℕ}
+    (v : Fin (p + 1) → FirstHurewicz.Simplex r) (w : Fin (q + 1) → FirstHurewicz.Simplex s)
+    (z : Fin (m + 1) → FirstHurewicz.Simplex p × FirstHurewicz.Simplex q) :
+    ((SingularMayerVietoris.affineSimplex v).prodMap (SingularMayerVietoris.affineSimplex w)).comp
+        (productAffineSimplex z) =
+      productAffineSimplex
+        (fun j =>
+          (SingularMayerVietoris.affineSimplex v (z j).1,
+            SingularMayerVietoris.affineSimplex w (z j).2)) := by
+  apply ContinuousMap.ext
+  intro t
+  apply Prod.ext
+  · exact
+      congrArg (fun f : C(FirstHurewicz.Simplex m, FirstHurewicz.Simplex r) => f t)
+        (SingularMayerVietoris.affineSimplex_comp v (fun j => (z j).1))
+  · exact
+      congrArg (fun f : C(FirstHurewicz.Simplex m, FirstHurewicz.Simplex s) => f t)
+        (SingularMayerVietoris.affineSimplex_comp w (fun j => (z j).2))
+
+private def PeriodTorusHigherHomology.productAffineChainMap (p q n : ℕ) :
+    SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex p × FirstHurewicz.Simplex q)
+        (n + 1) →ₗ[ℤ]
+      FirstHurewicz.Chains (FirstHurewicz.Simplex p × FirstHurewicz.Simplex q) n :=
+  SingularMayerVietoris.formalLift fun v =>
+    FirstHurewicz.simplexChain (FirstHurewicz.Simplex p × FirstHurewicz.Simplex q) n
+      (productAffineSimplex v)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.productAffineChainMap_simplex (p q n : ℕ)
+    (v : Fin (n + 1) → FirstHurewicz.Simplex p × FirstHurewicz.Simplex q) :
+    productAffineChainMap p q n (SingularMayerVietoris.formalSimplex v) =
+      FirstHurewicz.simplexChain (FirstHurewicz.Simplex p × FirstHurewicz.Simplex q) n
+        (productAffineSimplex v) :=
+  SingularMayerVietoris.formalLift_simplex _ _
+
+private theorem PeriodTorusHigherHomology.productAffineChainMap_boundary (p q n : ℕ)
+    (c :
+      SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex p × FirstHurewicz.Simplex q)
+        (n + 2)) :
+    ((FirstHurewicz.singularComplex (FirstHurewicz.Simplex p × FirstHurewicz.Simplex q)).d (n + 1)
+            n).hom
+        (productAffineChainMap p q (n + 1) c) =
+      productAffineChainMap p q n (SingularMayerVietoris.formalBoundary (n + 1) c) := by
+  have h :
+    (((FirstHurewicz.singularComplex (FirstHurewicz.Simplex p × FirstHurewicz.Simplex q)).d
+              (n + 1) n).hom).comp
+        (productAffineChainMap p q (n + 1)) =
+      (productAffineChainMap p q n).comp (SingularMayerVietoris.formalBoundary (n + 1)) := by
+    apply SingularMayerVietoris.formalChains_ext
+    intro v
+    change
+      ((FirstHurewicz.singularComplex (FirstHurewicz.Simplex p × FirstHurewicz.Simplex q)).d
+              (n + 1) n).hom
+          (productAffineChainMap p q (n + 1) (SingularMayerVietoris.formalSimplex v)) =
+        _
+    rw [productAffineChainMap_simplex, FirstHurewicz.boundary_simplex]
+    change
+      _ =
+        productAffineChainMap p q n
+          (SingularMayerVietoris.formalBoundary (n + 1) (SingularMayerVietoris.formalSimplex v))
+    rw [SingularMayerVietoris.formalBoundary_simplex, map_sum]
+    apply Finset.sum_congr rfl
+    intro i hi
+    rw [map_zsmul, productAffineChainMap_simplex, productAffineSimplex_face]
+    rfl
+  exact LinearMap.congr_fun h c
+
+private theorem PeriodTorusHigherHomology.inducedChain_productAffineChainMap {m p q r s : ℕ}
+    (v : Fin (p + 1) → FirstHurewicz.Simplex r) (w : Fin (q + 1) → FirstHurewicz.Simplex s)
+    (c :
+      SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex p × FirstHurewicz.Simplex q)
+        (m + 1)) :
+    FirstHurewicz.inducedChain
+        ((SingularMayerVietoris.affineSimplex v).prodMap (SingularMayerVietoris.affineSimplex w))
+        m (productAffineChainMap p q m c) =
+      productAffineChainMap r s m
+        (SingularMayerVietoris.formalMap
+          ((SingularMayerVietoris.affineSimplex v).prodMap
+            (SingularMayerVietoris.affineSimplex w))
+          (m + 1) c) := by
+  have h :
+    (FirstHurewicz.inducedChain
+            ((SingularMayerVietoris.affineSimplex v).prodMap
+              (SingularMayerVietoris.affineSimplex w))
+            m).comp
+        (productAffineChainMap p q m) =
+      (productAffineChainMap r s m).comp
+        (SingularMayerVietoris.formalMap
+          ((SingularMayerVietoris.affineSimplex v).prodMap
+            (SingularMayerVietoris.affineSimplex w))
+          (m + 1)) := by
+    apply SingularMayerVietoris.formalChains_ext
+    intro z
+    simp only [LinearMap.comp_apply, productAffineChainMap_simplex,
+      FirstHurewicz.inducedChain_simplex, SingularMayerVietoris.formalMap_simplex,
+      prodMap_productAffineSimplex]
+    rfl
+  exact LinearMap.congr_fun h c
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomology.crossProductEdge (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) :
+    FirstHurewicz.Chains X 1 →ₗ[ℤ]
+      FirstHurewicz.Chains Y n →ₗ[ℤ] FirstHurewicz.Chains (X × Y) (n + 1) :=
+  chainBilinearLift X Y 1 n fun σ τ =>
+    FirstHurewicz.inducedChain (σ.prodMap τ) (n + 1)
+      (productAffineChainMap 1 n (n + 1)
+        (formalEdgeCrossProduct n
+          (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+          (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices n))))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodTorusHigherHomology.crossProductEdge_simplex (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) (σ : FirstHurewicz.SingularSimplex X 1)
+    (τ : FirstHurewicz.SingularSimplex Y n) :
+    crossProductEdge X Y n (FirstHurewicz.simplexChain X 1 σ) (FirstHurewicz.simplexChain Y n τ) =
+      FirstHurewicz.inducedChain (σ.prodMap τ) (n + 1)
+        (productAffineChainMap 1 n (n + 1)
+          (formalEdgeCrossProduct n
+            (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+            (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices n)))) :=
+  chainBilinearLift_simplex X Y 1 n _ σ τ
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomology.crossProductEdge_natural {X Y X' Y' : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] [TopologicalSpace X'] [TopologicalSpace Y'] (f : C(X, X')) (g : C(Y, Y'))
+    (n : ℕ) (a : FirstHurewicz.Chains X 1) (b : FirstHurewicz.Chains Y n) :
+    FirstHurewicz.inducedChain (f.prodMap g) (n + 1) (crossProductEdge X Y n a b) =
+      crossProductEdge X' Y' n (FirstHurewicz.inducedChain f 1 a)
+        (FirstHurewicz.inducedChain g n b) := by
+  have h :
+    integerBilinearPostcompose (crossProductEdge X Y n)
+        (FirstHurewicz.inducedChain (f.prodMap g) (n + 1)) =
+      integerBilinearPrecompose (crossProductEdge X' Y' n) (FirstHurewicz.inducedChain f 1)
+        (FirstHurewicz.inducedChain g n) := by
+    apply chainBilinearMap_ext X Y 1 n
+    intro σ τ
+    simp only [integerBilinearPostcompose_apply, integerBilinearPrecompose_apply,
+      FirstHurewicz.inducedChain_simplex, crossProductEdge_simplex]
+    have hc : (f.comp σ).prodMap (g.comp τ) = (f.prodMap g).comp (σ.prodMap τ) := rfl
+    rw [hc, FirstHurewicz.inducedChain_comp]
+    rfl
+  exact LinearMap.congr_fun (LinearMap.congr_fun h a) b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.affineSimplex_stdVertices_image {n p : ℕ}
+    (v : Fin (n + 1) → FirstHurewicz.Simplex p) :
+    SingularMayerVietoris.affineSimplex v ∘ SingularMayerVietoris.stdVertices n = v := by
+  funext i
+  exact SingularMayerVietoris.affineSimplex_vertex v i
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.productAffineSimplex_point_left {n p q : ℕ}
+    (a : FirstHurewicz.Simplex p) (v : Fin (n + 1) → FirstHurewicz.Simplex q) :
+    productAffineSimplex (fun i => (a, v i)) =
+      (crossInsertLeft a).comp (SingularMayerVietoris.affineSimplex v) := by
+  rw [productAffineSimplex, affineSimplex_constant]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.productAffineSimplex_point_right {n p q : ℕ}
+    (v : Fin (n + 1) → FirstHurewicz.Simplex p) (b : FirstHurewicz.Simplex q) :
+    productAffineSimplex (fun i => (v i, b)) =
+      (crossInsertRight b).comp (SingularMayerVietoris.affineSimplex v) := by
+  rw [productAffineSimplex, affineSimplex_constant]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductZeroLeft_affineChainMap (p q n : ℕ)
+    (a : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex p) 1)
+    (b : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex q) (n + 1)) :
+    crossProductZeroLeft (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q) n
+        (SingularMayerVietoris.affineChainMap p 0 a)
+        (SingularMayerVietoris.affineChainMap q n b) =
+      productAffineChainMap p q n (formalPointCrossProduct n a b) := by
+  have h :
+    integerBilinearPrecompose
+        (crossProductZeroLeft (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q) n)
+        (SingularMayerVietoris.affineChainMap p 0) (SingularMayerVietoris.affineChainMap q n) =
+      integerBilinearPostcompose (formalPointCrossProduct n) (productAffineChainMap p q n) := by
+    apply integerFormalBilinearMap_ext
+    intro v w
+    simp only [integerBilinearPrecompose_apply, integerBilinearPostcompose_apply,
+      SingularMayerVietoris.affineChainMap_simplex, crossProductZeroLeft_simplex]
+    have hv : zeroSimplexValue (SingularMayerVietoris.affineSimplex v) = v 0 :=
+      SingularMayerVietoris.affineSimplex_vertex v 0
+    rw [hv]
+    calc
+      _ =
+          productAffineChainMap p q n
+            (SingularMayerVietoris.formalSimplex (fun i => (v 0, w i))) := by
+        rw [productAffineChainMap_simplex, productAffineSimplex_point_left]
+      _ = _ := congrArg (productAffineChainMap p q n) (formalPointCrossProduct_simplex n v w).symm
+  exact LinearMap.congr_fun (LinearMap.congr_fun h a) b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductEdge_affineChainMap (p q n : ℕ)
+    (a : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex p) 2)
+    (b : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex q) (n + 1)) :
+    crossProductEdge (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q) n
+        (SingularMayerVietoris.affineChainMap p 1 a)
+        (SingularMayerVietoris.affineChainMap q n b) =
+      productAffineChainMap p q (n + 1) (formalEdgeCrossProduct n a b) := by
+  have h :
+    integerBilinearPrecompose
+        (crossProductEdge (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q) n)
+        (SingularMayerVietoris.affineChainMap p 1) (SingularMayerVietoris.affineChainMap q n) =
+      integerBilinearPostcompose (formalEdgeCrossProduct n) (productAffineChainMap p q (n + 1)) :=
+    by
+    apply integerFormalBilinearMap_ext
+    intro v w
+    simp only [integerBilinearPrecompose_apply, integerBilinearPostcompose_apply,
+      SingularMayerVietoris.affineChainMap_simplex, crossProductEdge_simplex]
+    rw [inducedChain_productAffineChainMap]
+    change
+      productAffineChainMap p q (n + 1)
+          (SingularMayerVietoris.formalMap
+            (Prod.map (SingularMayerVietoris.affineSimplex v)
+              (SingularMayerVietoris.affineSimplex w))
+            (n + 2)
+            (formalEdgeCrossProduct n
+              (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+              (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices n)))) =
+        _
+    rw [formalMap_edgeCrossProduct, SingularMayerVietoris.formalMap_simplex,
+      SingularMayerVietoris.formalMap_simplex, affineSimplex_stdVertices_image,
+      affineSimplex_stdVertices_image]
+  exact LinearMap.congr_fun (LinearMap.congr_fun h a) b
+
+private def PeriodTorusHigherHomology.formalTriangleCrossProduct {V W : Type*} :
+    (q : ℕ) →
+      SingularMayerVietoris.FormalChains V 3 →ₗ[ℤ]
+        SingularMayerVietoris.FormalChains W (q + 1) →ₗ[ℤ]
+          SingularMayerVietoris.FormalChains (V × W) (q + 3)
+  | 0 =>
+    (SingularMayerVietoris.formalLift fun w : Fin 1 → W =>
+        SingularMayerVietoris.formalMap (fun v => (v, w 0)) 3).flip
+  | q + 1 =>
+    formalBilinearLift fun v w =>
+      SingularMayerVietoris.formalCone (v 0, w 0) (q + 3)
+        (formalEdgeCrossProduct (q + 1)
+            (SingularMayerVietoris.formalBoundary 2 (SingularMayerVietoris.formalSimplex v))
+            (SingularMayerVietoris.formalSimplex w) +
+          formalTriangleCrossProduct q (SingularMayerVietoris.formalSimplex v)
+            (SingularMayerVietoris.formalBoundary (q + 1)
+              (SingularMayerVietoris.formalSimplex w)))
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.formalTriangleCrossProduct_zero_simplex_right {V W : Type*}
+    (c : SingularMayerVietoris.FormalChains V 3) (w : Fin 1 → W) :
+    formalTriangleCrossProduct 0 c (SingularMayerVietoris.formalSimplex w) =
+      SingularMayerVietoris.formalMap (fun v => (v, w 0)) 3 c := by
+  exact LinearMap.congr_fun (SingularMayerVietoris.formalLift_simplex _ _) c
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.formalTriangleCrossProduct_simplex_succ {V W : Type*} (q : ℕ)
+    (v : Fin 3 → V) (w : Fin (q + 2) → W) :
+    formalTriangleCrossProduct (q + 1) (SingularMayerVietoris.formalSimplex v)
+        (SingularMayerVietoris.formalSimplex w) =
+      SingularMayerVietoris.formalCone (v 0, w 0) (q + 3)
+        (formalEdgeCrossProduct (q + 1)
+            (SingularMayerVietoris.formalBoundary 2 (SingularMayerVietoris.formalSimplex v))
+            (SingularMayerVietoris.formalSimplex w) +
+          formalTriangleCrossProduct q (SingularMayerVietoris.formalSimplex v)
+            (SingularMayerVietoris.formalBoundary (q + 1)
+              (SingularMayerVietoris.formalSimplex w))) :=
+  formalBilinearLift_simplex _ _ _
+
+private theorem PeriodTorusHigherHomology.formalBoundary_triangleCrossProduct_zero {V W : Type*}
+    (c : SingularMayerVietoris.FormalChains V 3) (d : SingularMayerVietoris.FormalChains W 1) :
+    SingularMayerVietoris.formalBoundary 2 (formalTriangleCrossProduct 0 c d) =
+      formalEdgeCrossProduct 0 (SingularMayerVietoris.formalBoundary 2 c) d := by
+  have h :
+    (formalTriangleCrossProduct (V := V) (W := W) 0).compr₂
+        (SingularMayerVietoris.formalBoundary 2) =
+      (formalEdgeCrossProduct 0).comp (SingularMayerVietoris.formalBoundary 2) := by
+    apply formalChains_bilinear_ext
+    intro v w
+    simp only [LinearMap.compr₂_apply, LinearMap.comp_apply,
+      formalTriangleCrossProduct_zero_simplex_right, formalEdgeCrossProduct_zero_simplex_right]
+    exact
+      (SingularMayerVietoris.formalMap_boundary (fun z => (z, w 0)) 2
+          (SingularMayerVietoris.formalSimplex v)).symm
+  exact LinearMap.congr_fun (LinearMap.congr_fun h c) d
+
+private theorem PeriodTorusHigherHomology.formalBoundary_triangleCrossProduct {V W : Type*} :
+    ∀ (q : ℕ) (c : SingularMayerVietoris.FormalChains V 3)
+      (d : SingularMayerVietoris.FormalChains W (q + 2)),
+      SingularMayerVietoris.formalBoundary (q + 3) (formalTriangleCrossProduct (q + 1) c d) =
+        formalEdgeCrossProduct (q + 1) (SingularMayerVietoris.formalBoundary 2 c) d +
+          formalTriangleCrossProduct q c (SingularMayerVietoris.formalBoundary (q + 1) d) := by
+  intro q
+  induction q with
+  | zero =>
+    intro c d
+    have h :
+      (formalTriangleCrossProduct (V := V) (W := W) 1).compr₂
+          (SingularMayerVietoris.formalBoundary 3) =
+        (formalEdgeCrossProduct 1).comp (SingularMayerVietoris.formalBoundary 2) +
+          (formalTriangleCrossProduct 0).compl₂ (SingularMayerVietoris.formalBoundary 1) := by
+      apply formalChains_bilinear_ext
+      intro v w
+      change
+        SingularMayerVietoris.formalBoundary 3
+            (formalTriangleCrossProduct 1 (SingularMayerVietoris.formalSimplex v)
+              (SingularMayerVietoris.formalSimplex w)) =
+          _
+      rw [formalTriangleCrossProduct_simplex_succ, SingularMayerVietoris.formalBoundary_cone]
+      have hz :
+        SingularMayerVietoris.formalBoundary 2
+            (formalEdgeCrossProduct 1
+                (SingularMayerVietoris.formalBoundary 2 (SingularMayerVietoris.formalSimplex v))
+                (SingularMayerVietoris.formalSimplex w) +
+              formalTriangleCrossProduct 0 (SingularMayerVietoris.formalSimplex v)
+                (SingularMayerVietoris.formalBoundary 1
+                  (SingularMayerVietoris.formalSimplex w))) =
+          0 := by
+        rw [map_add, formalBoundary_edgeCrossProduct,
+          SingularMayerVietoris.formalBoundary_boundary, map_zero, LinearMap.zero_apply, zero_sub,
+          formalBoundary_triangleCrossProduct_zero, neg_add_cancel]
+      rw [hz, map_zero, sub_zero]
+      rfl
+    exact LinearMap.congr_fun (LinearMap.congr_fun h c) d
+  | succ q ih =>
+    intro c d
+    have h :
+      (formalTriangleCrossProduct (V := V) (W := W) (q + 2)).compr₂
+          (SingularMayerVietoris.formalBoundary (q + 4)) =
+        (formalEdgeCrossProduct (q + 2)).comp (SingularMayerVietoris.formalBoundary 2) +
+          (formalTriangleCrossProduct (q + 1)).compl₂
+            (SingularMayerVietoris.formalBoundary (q + 2)) := by
+      apply formalChains_bilinear_ext
+      intro v w
+      change
+        SingularMayerVietoris.formalBoundary (q + 4)
+            (formalTriangleCrossProduct (q + 2) (SingularMayerVietoris.formalSimplex v)
+              (SingularMayerVietoris.formalSimplex w)) =
+          _
+      rw [formalTriangleCrossProduct_simplex_succ, SingularMayerVietoris.formalBoundary_cone]
+      have hz :
+        SingularMayerVietoris.formalBoundary (q + 3)
+            (formalEdgeCrossProduct (q + 2)
+                (SingularMayerVietoris.formalBoundary 2 (SingularMayerVietoris.formalSimplex v))
+                (SingularMayerVietoris.formalSimplex w) +
+              formalTriangleCrossProduct (q + 1) (SingularMayerVietoris.formalSimplex v)
+                (SingularMayerVietoris.formalBoundary (q + 2)
+                  (SingularMayerVietoris.formalSimplex w))) =
+          0 := by
+        rw [map_add, formalBoundary_edgeCrossProduct,
+          SingularMayerVietoris.formalBoundary_boundary, map_zero, LinearMap.zero_apply, zero_sub,
+          ih, SingularMayerVietoris.formalBoundary_boundary, map_zero, add_zero, neg_add_cancel]
+      rw [hz, map_zero, sub_zero]
+      rfl
+    exact LinearMap.congr_fun (LinearMap.congr_fun h c) d
+
+private theorem
+    PeriodTorusHigherHomology.formalMap_triangleCrossProduct {V W V' W' : Type*} (f : V → V')
+    (g : W → W') :
+    ∀ (q : ℕ) (c : SingularMayerVietoris.FormalChains V 3)
+      (d : SingularMayerVietoris.FormalChains W (q + 1)),
+      SingularMayerVietoris.formalMap (Prod.map f g) (q + 3) (formalTriangleCrossProduct q c d) =
+        formalTriangleCrossProduct q (SingularMayerVietoris.formalMap f 3 c)
+          (SingularMayerVietoris.formalMap g (q + 1) d) := by
+  intro q
+  induction q with
+  | zero =>
+    intro c d
+    have h :
+      (formalTriangleCrossProduct (V := V) (W := W) 0).compr₂
+          (SingularMayerVietoris.formalMap (Prod.map f g) 3) =
+        ((formalTriangleCrossProduct 0).compl₂ (SingularMayerVietoris.formalMap g 1)).comp
+          (SingularMayerVietoris.formalMap f 3) := by
+      apply formalChains_bilinear_ext
+      intro v w
+      simp only [LinearMap.compr₂_apply, LinearMap.compl₂_apply, LinearMap.comp_apply,
+        formalTriangleCrossProduct_zero_simplex_right, SingularMayerVietoris.formalMap_simplex]
+      rfl
+    exact LinearMap.congr_fun (LinearMap.congr_fun h c) d
+  | succ q ih =>
+    intro c d
+    have h :
+      (formalTriangleCrossProduct (V := V) (W := W) (q + 1)).compr₂
+          (SingularMayerVietoris.formalMap (Prod.map f g) (q + 4)) =
+        ((formalTriangleCrossProduct (q + 1)).compl₂
+              (SingularMayerVietoris.formalMap g (q + 2))).comp
+          (SingularMayerVietoris.formalMap f 3) := by
+      apply formalChains_bilinear_ext
+      intro v w
+      simp only [LinearMap.compr₂_apply, LinearMap.compl₂_apply, LinearMap.comp_apply,
+        SingularMayerVietoris.formalMap_simplex, formalTriangleCrossProduct_simplex_succ]
+      rw [SingularMayerVietoris.formalMap_cone]
+      congr 1
+      rw [map_add, formalMap_edgeCrossProduct, ih, SingularMayerVietoris.formalMap_boundary,
+        SingularMayerVietoris.formalMap_boundary, SingularMayerVietoris.formalMap_simplex,
+        SingularMayerVietoris.formalMap_simplex]
+    exact LinearMap.congr_fun (LinearMap.congr_fun h c) d
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomology.crossProductTriangle (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) :
+    FirstHurewicz.Chains X 2 →ₗ[ℤ]
+      FirstHurewicz.Chains Y n →ₗ[ℤ] FirstHurewicz.Chains (X × Y) (n + 2) :=
+  chainBilinearLift X Y 2 n fun σ τ =>
+    FirstHurewicz.inducedChain (σ.prodMap τ) (n + 2)
+      (productAffineChainMap 2 n (n + 2)
+        (formalTriangleCrossProduct n
+          (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 2))
+          (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices n))))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.crossProductTriangle_simplex (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) (σ : FirstHurewicz.SingularSimplex X 2)
+    (τ : FirstHurewicz.SingularSimplex Y n) :
+    crossProductTriangle X Y n (FirstHurewicz.simplexChain X 2 σ)
+        (FirstHurewicz.simplexChain Y n τ) =
+      FirstHurewicz.inducedChain (σ.prodMap τ) (n + 2)
+        (productAffineChainMap 2 n (n + 2)
+          (formalTriangleCrossProduct n
+            (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 2))
+            (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices n)))) :=
+  chainBilinearLift_simplex X Y 2 n _ σ τ
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductTriangle_natural {X Y X' Y' : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace X'] [TopologicalSpace Y']
+    (f : C(X, X')) (g : C(Y, Y')) (n : ℕ) (a : FirstHurewicz.Chains X 2)
+    (b : FirstHurewicz.Chains Y n) :
+    FirstHurewicz.inducedChain (f.prodMap g) (n + 2) (crossProductTriangle X Y n a b) =
+      crossProductTriangle X' Y' n (FirstHurewicz.inducedChain f 2 a)
+        (FirstHurewicz.inducedChain g n b) := by
+  have h :
+    integerBilinearPostcompose (crossProductTriangle X Y n)
+        (FirstHurewicz.inducedChain (f.prodMap g) (n + 2)) =
+      integerBilinearPrecompose (crossProductTriangle X' Y' n) (FirstHurewicz.inducedChain f 2)
+        (FirstHurewicz.inducedChain g n) := by
+    apply chainBilinearMap_ext X Y 2 n
+    intro σ τ
+    simp only [integerBilinearPostcompose_apply, integerBilinearPrecompose_apply,
+      FirstHurewicz.inducedChain_simplex, crossProductTriangle_simplex]
+    have hc : (f.comp σ).prodMap (g.comp τ) = (f.prodMap g).comp (σ.prodMap τ) := rfl
+    rw [hc, FirstHurewicz.inducedChain_comp]
+    rfl
+  exact LinearMap.congr_fun (LinearMap.congr_fun h a) b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductTriangle_affineChainMap (p q n : ℕ)
+    (a : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex p) 3)
+    (b : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex q) (n + 1)) :
+    crossProductTriangle (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q) n
+        (SingularMayerVietoris.affineChainMap p 2 a)
+        (SingularMayerVietoris.affineChainMap q n b) =
+      productAffineChainMap p q (n + 2) (formalTriangleCrossProduct n a b) := by
+  have h :
+    integerBilinearPrecompose
+        (crossProductTriangle (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q) n)
+        (SingularMayerVietoris.affineChainMap p 2) (SingularMayerVietoris.affineChainMap q n) =
+      integerBilinearPostcompose (formalTriangleCrossProduct n)
+        (productAffineChainMap p q (n + 2)) := by
+    apply integerFormalBilinearMap_ext
+    intro v w
+    simp only [integerBilinearPrecompose_apply, integerBilinearPostcompose_apply,
+      SingularMayerVietoris.affineChainMap_simplex, crossProductTriangle_simplex]
+    rw [inducedChain_productAffineChainMap]
+    change
+      productAffineChainMap p q (n + 2)
+          (SingularMayerVietoris.formalMap
+            (Prod.map (SingularMayerVietoris.affineSimplex v)
+              (SingularMayerVietoris.affineSimplex w))
+            (n + 3)
+            (formalTriangleCrossProduct n
+              (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 2))
+              (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices n)))) =
+        _
+    rw [formalMap_triangleCrossProduct, SingularMayerVietoris.formalMap_simplex,
+      SingularMayerVietoris.formalMap_simplex, affineSimplex_stdVertices_image,
+      affineSimplex_stdVertices_image]
+  exact LinearMap.congr_fun (LinearMap.congr_fun h a) b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductTriangle_boundary_zero_affine (p q : ℕ)
+    (a : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex p) 3)
+    (b : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex q) 1) :
+    ((FirstHurewicz.singularComplex (FirstHurewicz.Simplex p × FirstHurewicz.Simplex q)).d 2
+            1).hom
+        (crossProductTriangle (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q) 0
+          (SingularMayerVietoris.affineChainMap p 2 a)
+          (SingularMayerVietoris.affineChainMap q 0 b)) =
+      crossProductEdge (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q) 0
+        (((FirstHurewicz.singularComplex (FirstHurewicz.Simplex p)).d 2 1).hom
+          (SingularMayerVietoris.affineChainMap p 2 a))
+        (SingularMayerVietoris.affineChainMap q 0 b) := by
+  rw [crossProductTriangle_affineChainMap, productAffineChainMap_boundary,
+    formalBoundary_triangleCrossProduct_zero, SingularMayerVietoris.affineChainMap_boundary,
+    crossProductEdge_affineChainMap]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductTriangle_boundary_affine (p q n : ℕ)
+    (a : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex p) 3)
+    (b : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex q) (n + 2)) :
+    ((FirstHurewicz.singularComplex (FirstHurewicz.Simplex p × FirstHurewicz.Simplex q)).d (n + 3)
+            (n + 2)).hom
+        (crossProductTriangle (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q) (n + 1)
+          (SingularMayerVietoris.affineChainMap p 2 a)
+          (SingularMayerVietoris.affineChainMap q (n + 1) b)) =
+      crossProductEdge (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q) (n + 1)
+          (((FirstHurewicz.singularComplex (FirstHurewicz.Simplex p)).d 2 1).hom
+            (SingularMayerVietoris.affineChainMap p 2 a))
+          (SingularMayerVietoris.affineChainMap q (n + 1) b) +
+        crossProductTriangle (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q) n
+          (SingularMayerVietoris.affineChainMap p 2 a)
+          (((FirstHurewicz.singularComplex (FirstHurewicz.Simplex q)).d (n + 1) n).hom
+            (SingularMayerVietoris.affineChainMap q (n + 1) b)) := by
+  rw [crossProductTriangle_affineChainMap, productAffineChainMap_boundary,
+    formalBoundary_triangleCrossProduct, map_add, SingularMayerVietoris.affineChainMap_boundary,
+    SingularMayerVietoris.affineChainMap_boundary, crossProductEdge_affineChainMap,
+    crossProductTriangle_affineChainMap]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductTriangle_boundary_zero {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (a : FirstHurewicz.Chains X 2)
+    (b : FirstHurewicz.Chains Y 0) :
+    ((FirstHurewicz.singularComplex (X × Y)).d 2 1).hom (crossProductTriangle X Y 0 a b) =
+      crossProductEdge X Y 0 (((FirstHurewicz.singularComplex X).d 2 1).hom a) b := by
+  have h :
+    integerBilinearPostcompose (crossProductTriangle X Y 0)
+        ((FirstHurewicz.singularComplex (X × Y)).d 2 1).hom =
+      integerBilinearPrecompose (crossProductEdge X Y 0)
+        ((FirstHurewicz.singularComplex X).d 2 1).hom LinearMap.id := by
+    apply chainBilinearMap_ext X Y 2 0
+    intro σ τ
+    have hstd :=
+      crossProductTriangle_boundary_zero_affine 2 0
+        (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 2))
+        (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 0))
+    have hστ := congrArg (FirstHurewicz.inducedChain (σ.prodMap τ) 1) hstd
+    simpa only [integerBilinearPostcompose_apply, integerBilinearPrecompose_apply,
+      LinearMap.id_apply, FirstHurewicz.inducedChain_boundary, crossProductTriangle_natural,
+      crossProductEdge_natural, SingularMayerVietoris.affineChainMap_stdVertices,
+      FirstHurewicz.inducedChain_simplex, ContinuousMap.comp_id] using hστ
+  exact LinearMap.congr_fun (LinearMap.congr_fun h a) b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomology.crossProductTriangle_boundary {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) (a : FirstHurewicz.Chains X 2)
+    (b : FirstHurewicz.Chains Y (n + 1)) :
+    ((FirstHurewicz.singularComplex (X × Y)).d (n + 3) (n + 2)).hom
+        (crossProductTriangle X Y (n + 1) a b) =
+      crossProductEdge X Y (n + 1) (((FirstHurewicz.singularComplex X).d 2 1).hom a) b +
+        crossProductTriangle X Y n a (((FirstHurewicz.singularComplex Y).d (n + 1) n).hom b) := by
+  have h :
+    integerBilinearPostcompose (crossProductTriangle X Y (n + 1))
+        ((FirstHurewicz.singularComplex (X × Y)).d (n + 3) (n + 2)).hom =
+      integerBilinearPrecompose (crossProductEdge X Y (n + 1))
+          ((FirstHurewicz.singularComplex X).d 2 1).hom LinearMap.id +
+        integerBilinearPrecompose (crossProductTriangle X Y n) LinearMap.id
+          ((FirstHurewicz.singularComplex Y).d (n + 1) n).hom := by
+    apply chainBilinearMap_ext X Y 2 (n + 1)
+    intro σ τ
+    have hstd :=
+      crossProductTriangle_boundary_affine 2 (n + 1) n
+        (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 2))
+        (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices (n + 1)))
+    have hστ := congrArg (FirstHurewicz.inducedChain (σ.prodMap τ) (n + 2)) hstd
+    simpa only [integerBilinearPostcompose_apply, integerBilinearPrecompose_apply,
+      LinearMap.add_apply, LinearMap.id_apply, map_add, FirstHurewicz.inducedChain_boundary,
+      crossProductTriangle_natural, crossProductEdge_natural,
+      SingularMayerVietoris.affineChainMap_stdVertices, FirstHurewicz.inducedChain_simplex,
+      ContinuousMap.comp_id] using hστ
+  exact LinearMap.congr_fun (LinearMap.congr_fun h a) b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductTriangle_boundary_of_right_cycle {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (n : ℕ) (a : FirstHurewicz.Chains X 2)
+    (b : FirstHurewicz.Chains Y n)
+    (hb : ((FirstHurewicz.singularComplex Y).d n (n - 1)).hom b = 0) :
+    ((FirstHurewicz.singularComplex (X × Y)).d (n + 2) (n + 1)).hom
+        (crossProductTriangle X Y n a b) =
+      crossProductEdge X Y n (((FirstHurewicz.singularComplex X).d 2 1).hom a) b := by
+  cases n with
+  | zero => exact crossProductTriangle_boundary_zero a b
+  | succ
+    n =>
+    have hb' : ((FirstHurewicz.singularComplex Y).d (n + 1) n).hom b = 0 := by
+      simpa only [Nat.succ_sub_one] using hb
+    simp only [crossProductTriangle_boundary, hb', map_zero, add_zero]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductEdge_boundary_zero_affine (p q : ℕ)
+    (a : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex p) 2)
+    (b : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex q) 1) :
+    ((FirstHurewicz.singularComplex (FirstHurewicz.Simplex p × FirstHurewicz.Simplex q)).d 1
+            0).hom
+        (crossProductEdge (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q) 0
+          (SingularMayerVietoris.affineChainMap p 1 a)
+          (SingularMayerVietoris.affineChainMap q 0 b)) =
+      crossProductZeroLeft (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q) 0
+        (((FirstHurewicz.singularComplex (FirstHurewicz.Simplex p)).d 1 0).hom
+          (SingularMayerVietoris.affineChainMap p 1 a))
+        (SingularMayerVietoris.affineChainMap q 0 b) := by
+  rw [crossProductEdge_affineChainMap, productAffineChainMap_boundary,
+    formalBoundary_edgeCrossProduct_zero, SingularMayerVietoris.affineChainMap_boundary,
+    crossProductZeroLeft_affineChainMap]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductEdge_boundary_affine (p q n : ℕ)
+    (a : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex p) 2)
+    (b : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex q) (n + 2)) :
+    ((FirstHurewicz.singularComplex (FirstHurewicz.Simplex p × FirstHurewicz.Simplex q)).d (n + 2)
+            (n + 1)).hom
+        (crossProductEdge (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q) (n + 1)
+          (SingularMayerVietoris.affineChainMap p 1 a)
+          (SingularMayerVietoris.affineChainMap q (n + 1) b)) =
+      crossProductZeroLeft (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q) (n + 1)
+          (((FirstHurewicz.singularComplex (FirstHurewicz.Simplex p)).d 1 0).hom
+            (SingularMayerVietoris.affineChainMap p 1 a))
+          (SingularMayerVietoris.affineChainMap q (n + 1) b) -
+        crossProductEdge (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q) n
+          (SingularMayerVietoris.affineChainMap p 1 a)
+          (((FirstHurewicz.singularComplex (FirstHurewicz.Simplex q)).d (n + 1) n).hom
+            (SingularMayerVietoris.affineChainMap q (n + 1) b)) := by
+  rw [crossProductEdge_affineChainMap, productAffineChainMap_boundary,
+    formalBoundary_edgeCrossProduct, map_sub, SingularMayerVietoris.affineChainMap_boundary,
+    SingularMayerVietoris.affineChainMap_boundary, crossProductZeroLeft_affineChainMap,
+    crossProductEdge_affineChainMap]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomology.crossProductEdge_boundary_zero {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (a : FirstHurewicz.Chains X 1) (b : FirstHurewicz.Chains Y 0) :
+    ((FirstHurewicz.singularComplex (X × Y)).d 1 0).hom (crossProductEdge X Y 0 a b) =
+      crossProductZeroLeft X Y 0 (((FirstHurewicz.singularComplex X).d 1 0).hom a) b := by
+  have h :
+    integerBilinearPostcompose (crossProductEdge X Y 0)
+        ((FirstHurewicz.singularComplex (X × Y)).d 1 0).hom =
+      integerBilinearPrecompose (crossProductZeroLeft X Y 0)
+        ((FirstHurewicz.singularComplex X).d 1 0).hom LinearMap.id := by
+    apply chainBilinearMap_ext X Y 1 0
+    intro σ τ
+    have hstd :=
+      crossProductEdge_boundary_zero_affine 1 0
+        (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+        (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 0))
+    have hστ := congrArg (FirstHurewicz.inducedChain (σ.prodMap τ) 0) hstd
+    simpa only [integerBilinearPostcompose_apply, integerBilinearPrecompose_apply,
+      LinearMap.id_apply, FirstHurewicz.inducedChain_boundary, crossProductEdge_natural,
+      crossProductZeroLeft_natural, SingularMayerVietoris.affineChainMap_stdVertices,
+      FirstHurewicz.inducedChain_simplex, ContinuousMap.comp_id] using hστ
+  exact LinearMap.congr_fun (LinearMap.congr_fun h a) b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomology.crossProductEdge_boundary {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) (a : FirstHurewicz.Chains X 1)
+    (b : FirstHurewicz.Chains Y (n + 1)) :
+    ((FirstHurewicz.singularComplex (X × Y)).d (n + 2) (n + 1)).hom
+        (crossProductEdge X Y (n + 1) a b) =
+      crossProductZeroLeft X Y (n + 1) (((FirstHurewicz.singularComplex X).d 1 0).hom a) b -
+        crossProductEdge X Y n a (((FirstHurewicz.singularComplex Y).d (n + 1) n).hom b) := by
+  have h :
+    integerBilinearPostcompose (crossProductEdge X Y (n + 1))
+        ((FirstHurewicz.singularComplex (X × Y)).d (n + 2) (n + 1)).hom =
+      integerBilinearPrecompose (crossProductZeroLeft X Y (n + 1))
+          ((FirstHurewicz.singularComplex X).d 1 0).hom LinearMap.id -
+        integerBilinearPrecompose (crossProductEdge X Y n) LinearMap.id
+          ((FirstHurewicz.singularComplex Y).d (n + 1) n).hom := by
+    apply chainBilinearMap_ext X Y 1 (n + 1)
+    intro σ τ
+    have hstd :=
+      crossProductEdge_boundary_affine 1 (n + 1) n
+        (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+        (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices (n + 1)))
+    have hστ := congrArg (FirstHurewicz.inducedChain (σ.prodMap τ) (n + 1)) hstd
+    simpa only [integerBilinearPostcompose_apply, integerBilinearPrecompose_apply,
+      LinearMap.sub_apply, LinearMap.id_apply, map_sub, FirstHurewicz.inducedChain_boundary,
+      crossProductEdge_natural, crossProductZeroLeft_natural,
+      SingularMayerVietoris.affineChainMap_stdVertices, FirstHurewicz.inducedChain_simplex,
+      ContinuousMap.comp_id] using hστ
+  exact LinearMap.congr_fun (LinearMap.congr_fun h a) b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductEdge_cycle {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) (a : FirstHurewicz.Chains X 1) (b : FirstHurewicz.Chains Y n)
+    (ha : ((FirstHurewicz.singularComplex X).d 1 0).hom a = 0)
+    (hb : ((FirstHurewicz.singularComplex Y).d n (n - 1)).hom b = 0) :
+    ((FirstHurewicz.singularComplex (X × Y)).d (n + 1) n).hom (crossProductEdge X Y n a b) = 0 := by
+  cases n with
+  | zero =>
+    have h := crossProductEdge_boundary_zero a b
+    rw [ha, map_zero, LinearMap.zero_apply] at h
+    exact h
+  | succ
+    n =>
+    have hb' : ((FirstHurewicz.singularComplex Y).d (n + 1) n).hom b = 0 := by
+      simpa only [Nat.succ_sub_one] using hb
+    simp only [crossProductEdge_boundary, ha, hb', map_zero, LinearMap.zero_apply, sub_self]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductEdge_boundary_of_left_cycle {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (n : ℕ) (a : FirstHurewicz.Chains X 1)
+    (ha : ((FirstHurewicz.singularComplex X).d 1 0).hom a = 0)
+    (b : FirstHurewicz.Chains Y (n + 1)) :
+    ((FirstHurewicz.singularComplex (X × Y)).d (n + 2) (n + 1)).hom
+        (crossProductEdge X Y (n + 1) a b) =
+      -crossProductEdge X Y n a (((FirstHurewicz.singularComplex Y).d (n + 1) n).hom b) := by
+  simp only [crossProductEdge_boundary, ha, map_zero, LinearMap.zero_apply, zero_sub]
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private abbrev PeriodTorusHigherHomology.homologyBoundaries (K : ChainComplex (ModuleCat.{0} ℤ) ℕ)
+    (n : ℕ) : Submodule ℤ (SingularMayerVietoris.ModuleHomology.Cycle K n) :=
+  FirstHurewicz.ChainHomology.ShortBoundaries (K.sc n)
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private theorem
+    PeriodTorusHigherHomology.homologyLinearMap_ext (K : ChainComplex (ModuleCat.{0} ℤ) ℕ)
+    (n : ℕ) {M : Type*} [AddCommGroup M] [Module ℤ M] {f g : K.homology n →ₗ[ℤ] M}
+    (h :
+      ∀ c : SingularMayerVietoris.ModuleHomology.Cycle K n,
+        f (SingularMayerVietoris.ModuleHomology.cycleClass K n c) =
+          g (SingularMayerVietoris.ModuleHomology.cycleClass K n c)) :
+    f = g := by
+  apply LinearMap.ext
+  intro x
+  obtain ⟨c, rfl⟩ := SingularMayerVietoris.ModuleHomology.cycleClass_surjective K n x
+  exact h c
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private theorem
+    PeriodTorusHigherHomology.homologyBoundaries_le_ker (K : ChainComplex (ModuleCat.{0} ℤ) ℕ)
+    (n : ℕ) {M : Type*} [AddCommGroup M] [Module ℤ M]
+    (f : SingularMayerVietoris.ModuleHomology.Cycle K n →ₗ[ℤ] M)
+    (hf : ∀ b : K.X (n + 1), f (SingularMayerVietoris.ModuleHomology.boundaryCycle K n b) = 0) :
+    homologyBoundaries K n ≤ LinearMap.ker f := by
+  rintro c ⟨b, hb⟩
+  have hc : SingularMayerVietoris.ModuleHomology.cycleClass K n c = 0 :=
+    (FirstHurewicz.ChainHomology.shortCycleClass_eq_zero_iff (K.sc n) c).mpr
+      ⟨b, congrArg Subtype.val hb⟩
+  obtain ⟨b', hb'⟩ := (SingularMayerVietoris.ModuleHomology.cycleClass_eq_zero_iff K n c).mp hc
+  have he : SingularMayerVietoris.ModuleHomology.boundaryCycle K n b' = c := Subtype.ext hb'
+  exact (congrArg f he).symm.trans (hf b')
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+private def PeriodTorusHigherHomology.homologyDesc (K : ChainComplex (ModuleCat.{0} ℤ) ℕ) (n : ℕ)
+    {M : Type*} [AddCommGroup M] [Module ℤ M]
+    (f : SingularMayerVietoris.ModuleHomology.Cycle K n →ₗ[ℤ] M)
+    (hf : ∀ b : K.X (n + 1), f (SingularMayerVietoris.ModuleHomology.boundaryCycle K n b) = 0) :
+    K.homology n →ₗ[ℤ] M :=
+  ((homologyBoundaries K n).liftQ f (homologyBoundaries_le_ker K n f hf)).comp
+    (K.sc n).moduleCatHomologyIso.hom.hom
+
+attribute [local instance] FirstHurewicz.ChainHomology.shortCycleModule in
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.homologyDesc_cycleClass (K : ChainComplex (ModuleCat.{0} ℤ) ℕ)
+    (n : ℕ) {M : Type*} [AddCommGroup M] [Module ℤ M]
+    (f : SingularMayerVietoris.ModuleHomology.Cycle K n →ₗ[ℤ] M)
+    (hf : ∀ b : K.X (n + 1), f (SingularMayerVietoris.ModuleHomology.boundaryCycle K n b) = 0)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle K n) :
+    homologyDesc K n f hf (SingularMayerVietoris.ModuleHomology.cycleClass K n c) = f c := by
+  have h :=
+    congrArg (fun q => q.hom (Submodule.Quotient.mk c)) (K.sc n).moduleCatHomologyIso.inv_hom_id
+  exact congrArg ((homologyBoundaries K n).liftQ f (homologyBoundaries_le_ker K n f hf)) h
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomology.crossProductCycles (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 1 →ₗ[ℤ]
+      SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex Y) n →ₗ[ℤ]
+        SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex (X × Y)) (n + 1)
+    where
+  toFun
+    a :=
+    { toFun
+        b :=
+        SingularMayerVietoris.ModuleHomology.mkCycle (FirstHurewicz.singularComplex (X × Y))
+          (n + 1) (crossProductEdge X Y n a.1 b.1)
+          (by
+            rw [Nat.add_sub_cancel]
+            exact
+              crossProductEdge_cycle n a.1 b.1
+                (SingularMayerVietoris.ModuleHomology.cycle_condition
+                  (FirstHurewicz.singularComplex X) 1 a)
+                (SingularMayerVietoris.ModuleHomology.cycle_condition
+                  (FirstHurewicz.singularComplex Y) n b))
+      map_add' b
+        c := by
+        apply Subtype.ext
+        exact (crossProductEdge X Y n a.1).map_add b.1 c.1
+      map_smul' r
+        b := by
+        apply Subtype.ext
+        exact (crossProductEdge X Y n a.1).map_smul r b.1 }
+  map_add' a
+    b := by
+    apply LinearMap.ext
+    intro c
+    apply Subtype.ext
+    exact
+      congrArg
+        (fun f : FirstHurewicz.Chains Y n →ₗ[ℤ] FirstHurewicz.Chains (X × Y) (n + 1) => f c.1)
+        ((crossProductEdge X Y n).map_add a.1 b.1)
+  map_smul' r
+    a := by
+    apply LinearMap.ext
+    intro c
+    apply Subtype.ext
+    exact
+      congrArg
+        (fun f : FirstHurewicz.Chains Y n →ₗ[ℤ] FirstHurewicz.Chains (X × Y) (n + 1) => f c.1)
+        ((crossProductEdge X Y n).map_smul r a.1)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodTorusHigherHomology.crossProductCycles_val (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ)
+    (a : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 1)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex Y) n) :
+    (crossProductCycles X Y n a b).1 = crossProductEdge X Y n a.1 b.1 :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomology.crossProductCycleClasses (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 1 →ₗ[ℤ]
+      SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex Y) n →ₗ[ℤ]
+        (FirstHurewicz.singularComplex (X × Y)).homology (n + 1) :=
+  integerBilinearPostcompose (crossProductCycles X Y n)
+    (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex (X × Y))
+      (n + 1))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductCycleClasses_boundary_right {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (n : ℕ)
+    (a : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 1)
+    (b : FirstHurewicz.Chains Y (n + 1)) :
+    crossProductCycleClasses X Y n a
+        (SingularMayerVietoris.ModuleHomology.boundaryCycle (FirstHurewicz.singularComplex Y) n
+          b) =
+      0 := by
+  apply
+    (SingularMayerVietoris.ModuleHomology.cycleClass_eq_zero_iff
+        (FirstHurewicz.singularComplex (X × Y)) (n + 1) _).mpr
+  refine ⟨-crossProductEdge X Y (n + 1) a.1 b, ?_⟩
+  change
+    ((FirstHurewicz.singularComplex (X × Y)).d (n + 2) (n + 1)).hom
+        (-crossProductEdge X Y (n + 1) a.1 b) =
+      crossProductEdge X Y n a.1 (((FirstHurewicz.singularComplex Y).d (n + 1) n).hom b)
+  rw [map_neg,
+    crossProductEdge_boundary_of_left_cycle n a.1
+      (SingularMayerVietoris.ModuleHomology.cycle_condition (FirstHurewicz.singularComplex X) 1
+        a),
+    neg_neg]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomology.crossProductHomologyFixed {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ)
+    (a : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 1) :
+    (FirstHurewicz.singularComplex Y).homology n →ₗ[ℤ]
+      (FirstHurewicz.singularComplex (X × Y)).homology (n + 1) :=
+  homologyDesc (FirstHurewicz.singularComplex Y) n (crossProductCycleClasses X Y n a)
+    (crossProductCycleClasses_boundary_right n a)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodTorusHigherHomology.crossProductHomologyFixed_cycleClass {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (n : ℕ)
+    (a : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 1)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex Y) n) :
+    crossProductHomologyFixed n a
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex Y) n b) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex (X × Y))
+        (n + 1) (crossProductCycles X Y n a b) :=
+  homologyDesc_cycleClass _ _ _ _ b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomology.crossProductHomologyCycles (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 1 →ₗ[ℤ]
+      ((FirstHurewicz.singularComplex Y).homology n →ₗ[ℤ]
+        (FirstHurewicz.singularComplex (X × Y)).homology (n + 1))
+    where
+  toFun a := crossProductHomologyFixed n a
+  map_add' a
+    b := by
+    apply homologyLinearMap_ext (FirstHurewicz.singularComplex Y) n
+    intro c
+    change
+      crossProductHomologyFixed n (a + b)
+          (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex Y) n
+            c) =
+        crossProductHomologyFixed n a
+            (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex Y) n
+              c) +
+          crossProductHomologyFixed n b
+            (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex Y) n
+              c)
+    simp only [crossProductHomologyFixed_cycleClass]
+    exact
+      congrArg
+        (fun f :
+            SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex Y) n →ₗ[ℤ]
+              (FirstHurewicz.singularComplex (X × Y)).homology (n + 1) =>
+          f c)
+        ((crossProductCycleClasses X Y n).map_add a b)
+  map_smul' r
+    a := by
+    apply homologyLinearMap_ext (FirstHurewicz.singularComplex Y) n
+    intro c
+    simp only [LinearMap.smul_apply, RingHom.id_apply, crossProductHomologyFixed_cycleClass]
+    exact
+      congrArg
+        (fun f :
+            SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex Y) n →ₗ[ℤ]
+              (FirstHurewicz.singularComplex (X × Y)).homology (n + 1) =>
+          f c)
+        ((crossProductCycleClasses X Y n).map_smul r a)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductCycleClasses_boundary_left {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (n : ℕ) (a : FirstHurewicz.Chains X 2)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex Y) n) :
+    crossProductCycleClasses X Y n
+        (SingularMayerVietoris.ModuleHomology.boundaryCycle (FirstHurewicz.singularComplex X) 1 a)
+        b =
+      0 := by
+  apply
+    (SingularMayerVietoris.ModuleHomology.cycleClass_eq_zero_iff
+        (FirstHurewicz.singularComplex (X × Y)) (n + 1) _).mpr
+  refine ⟨crossProductTriangle X Y n a b.1, ?_⟩
+  exact
+    crossProductTriangle_boundary_of_right_cycle n a b.1
+      (SingularMayerVietoris.ModuleHomology.cycle_condition (FirstHurewicz.singularComplex Y) n b)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductHomologyCycles_boundary_left {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (n : ℕ) (a : FirstHurewicz.Chains X 2) :
+    crossProductHomologyCycles X Y n
+        (SingularMayerVietoris.ModuleHomology.boundaryCycle (FirstHurewicz.singularComplex X) 1
+          a) =
+      0 := by
+  apply homologyLinearMap_ext (FirstHurewicz.singularComplex Y) n
+  intro b
+  change
+    crossProductHomologyFixed n
+        (SingularMayerVietoris.ModuleHomology.boundaryCycle (FirstHurewicz.singularComplex X) 1 a)
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex Y) n b) =
+      0
+  rw [crossProductHomologyFixed_cycleClass]
+  exact crossProductCycleClasses_boundary_left n a b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomology.crossProductHomology (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) :
+    (FirstHurewicz.singularComplex X).homology 1 →ₗ[ℤ]
+      (FirstHurewicz.singularComplex Y).homology n →ₗ[ℤ]
+        (FirstHurewicz.singularComplex (X × Y)).homology (n + 1) :=
+  homologyDesc (FirstHurewicz.singularComplex X) 1 (crossProductHomologyCycles X Y n)
+    (crossProductHomologyCycles_boundary_left n)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodTorusHigherHomology.crossProductHomology_cycleClass (X Y : Type)
+    [TopologicalSpace X] [TopologicalSpace Y] (n : ℕ)
+    (a : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 1)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex Y) n) :
+    crossProductHomology X Y n
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 1 a)
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex Y) n b) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex (X × Y))
+        (n + 1) (crossProductCycles X Y n a b) := by
+  rw [crossProductHomology, homologyDesc_cycleClass]
+  exact crossProductHomologyFixed_cycleClass n a b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductEdge_zero_eq_zeroRight (X Y : Type)
+    [TopologicalSpace X] [TopologicalSpace Y] :
+    crossProductEdge X Y 0 = crossProductZeroRight X Y 1 := by
+  apply chainBilinearMap_ext X Y 1 0
+  intro σ τ
+  rw [crossProductEdge_simplex, formalEdgeCrossProduct_zero_simplex_right,
+    SingularMayerVietoris.formalMap_simplex, productAffineChainMap_simplex,
+    FirstHurewicz.inducedChain_simplex, crossProductZeroRight_simplex]
+  apply congrArg (FirstHurewicz.simplexChain (X × Y) 1)
+  change
+    (σ.prodMap τ).comp
+        (productAffineSimplex
+          (fun i =>
+            (SingularMayerVietoris.stdVertices 1 i, SingularMayerVietoris.stdVertices 0 0))) =
+      (crossInsertRight (zeroSimplexValue τ)).comp σ
+  rw [productAffineSimplex_point_right, SingularMayerVietoris.affineSimplex_stdVertices,
+    ContinuousMap.comp_id]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductEdge_zero_simplex_right (X Y : Type)
+    [TopologicalSpace X] [TopologicalSpace Y] (a : FirstHurewicz.Chains X 1)
+    (τ : FirstHurewicz.SingularSimplex Y 0) :
+    crossProductEdge X Y 0 a (FirstHurewicz.simplexChain Y 0 τ) =
+      FirstHurewicz.inducedChain (crossInsertRight (zeroSimplexValue τ)) 1 a := by
+  rw [crossProductEdge_zero_eq_zeroRight, crossProductZeroRight_simplex_right]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductEdge_pointCycle_right (X Y : Type)
+    [TopologicalSpace X] [TopologicalSpace Y] (a : FirstHurewicz.Chains X 1) (y : Y) :
+    crossProductEdge X Y 0 a (pointCycle y).1 =
+      FirstHurewicz.inducedChain (crossInsertRight y) 1 a := by
+  rw [pointCycle_val, crossProductEdge_zero_simplex_right]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodTorusHigherHomology.crossProductCycles_pointCycle_right (X Y : Type)
+    [TopologicalSpace X] [TopologicalSpace Y]
+    (a : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 1) (y : Y) :
+    crossProductCycles X Y 0 a (pointCycle y) =
+      SingularMayerVietoris.ModuleHomology.mapCycles
+        (FirstHurewicz.singularChainMap (crossInsertRight y)) 1 a := by
+  apply Subtype.ext
+  rw [crossProductCycles_val, SingularMayerVietoris.ModuleHomology.mapCycles_val]
+  exact crossProductEdge_pointCycle_right X Y a.1 y
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodTorusHigherHomology.crossProductHomology_pointClass_right (X Y : Type)
+    [TopologicalSpace X] [TopologicalSpace Y] (a : SingularMayerVietoris.SingularHomology X 1)
+    (y : Y) :
+    crossProductHomology X Y 0 a (pointClass y) =
+      SingularMayerVietoris.singularHomologyMap (crossInsertRight y) 1 a := by
+  obtain ⟨c, rfl⟩ :=
+    SingularMayerVietoris.ModuleHomology.cycleClass_surjective (FirstHurewicz.singularComplex X) 1
+      a
+  change
+    crossProductHomology X Y 0
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 1 c)
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex Y) 0
+          (pointCycle y)) =
+      _
+  rw [crossProductHomology_cycleClass, crossProductCycles_pointCycle_right]
+  exact
+    (SingularMayerVietoris.ModuleHomology.homologyMap_cycleClass
+        (FirstHurewicz.singularChainMap (crossInsertRight y)) 1 c).symm
+
+private theorem PeriodTorusHigherHomology.formalBoundary_edge_simplex {V : Type*} (v : Fin 2 → V) :
+    SingularMayerVietoris.formalBoundary 1 (SingularMayerVietoris.formalSimplex v) =
+      SingularMayerVietoris.formalSimplex (fun _ : Fin 1 => v 1) -
+        SingularMayerVietoris.formalSimplex (fun _ : Fin 1 => v 0) := by
+  rw [SingularMayerVietoris.formalBoundary_simplex]
+  change
+    (∑ i : Fin 2, (-1 : ℤ) ^ i.val • SingularMayerVietoris.formalSimplex (v ∘ i.succAbove)) = _
+  simp only [Fin.sum_univ_two, Fin.val_zero, Fin.val_one, pow_zero, pow_one, one_smul,
+    neg_one_smul, ← sub_eq_add_neg]
+  congr 1 <;> congr 1 <;> funext i <;> rw [Fin.eq_zero i] <;> rfl
+
+private theorem
+    PeriodTorusHigherHomology.formalPointCrossProduct_edge_boundary {V W : Type*} (q : ℕ)
+    (v : Fin 2 → V) (d : SingularMayerVietoris.FormalChains W (q + 1)) :
+    formalPointCrossProduct q
+        (SingularMayerVietoris.formalBoundary 1 (SingularMayerVietoris.formalSimplex v)) d =
+      SingularMayerVietoris.formalMap (fun w => (v 1, w)) (q + 1) d -
+        SingularMayerVietoris.formalMap (fun w => (v 0, w)) (q + 1) d := by
+  rw [formalBoundary_edge_simplex, map_sub, LinearMap.sub_apply,
+    formalPointCrossProduct_simplex_left, formalPointCrossProduct_simplex_left]
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology5.lean b/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology5.lean
new file mode 100644
index 000000000..5b954de0e
--- /dev/null
+++ b/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology5.lean
@@ -0,0 +1,106 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Elliptic.Core8
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology4
+import all LeanPool.HopfProblem.Elliptic.Core8
+
+/-!
+# Hopf problem: torus homology · period torus higher homology 5
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem
+    PeriodTorusHigherHomology.formalPointCrossProduct_mem_supported {V W : Type*} {S : Set V}
+    {T : Set W} (q : ℕ) {c : SingularMayerVietoris.FormalChains V 1}
+    {d : SingularMayerVietoris.FormalChains W (q + 1)}
+    (hc : c ∈ SingularMayerVietoris.formalChainsSupported S 1)
+    (hd : d ∈ SingularMayerVietoris.formalChainsSupported T (q + 1)) :
+    formalPointCrossProduct q c d ∈
+      SingularMayerVietoris.formalChainsSupported (S ×ˢ T) (q + 1) := by
+  apply
+    SingularMayerVietoris.formalLinearMap_mem_of_supported ((formalPointCrossProduct q).flip d)
+      (SingularMayerVietoris.formalChainsSupported (S ×ˢ T) (q + 1)) hc
+  intro v hv
+  change formalPointCrossProduct q (SingularMayerVietoris.formalSimplex v) d ∈ _
+  rw [formalPointCrossProduct_simplex_left]
+  exact
+    SingularMayerVietoris.formalMap_mem_supported (S := T) (T := S ×ˢ T) (fun w => (v 0, w))
+      (fun _ hw => ⟨hv 0, hw⟩) hd
+
+public
+theorem PeriodTorusHigherHomology.formalEdgeCrossProduct_mem_supported {V W : Type*} {S : Set V}
+    {T : Set W} :
+    ∀ (q : ℕ) {c : SingularMayerVietoris.FormalChains V 2}
+      {d : SingularMayerVietoris.FormalChains W (q + 1)},
+      c ∈ SingularMayerVietoris.formalChainsSupported S 2 →
+        d ∈ SingularMayerVietoris.formalChainsSupported T (q + 1) →
+          formalEdgeCrossProduct q c d ∈
+            SingularMayerVietoris.formalChainsSupported (S ×ˢ T) (q + 2) := by
+  intro q
+  induction q with
+  | zero =>
+    intro c d hc hd
+    apply
+      SingularMayerVietoris.formalLinearMap_mem_of_supported (formalEdgeCrossProduct 0 c)
+        (SingularMayerVietoris.formalChainsSupported (S ×ˢ T) 2) hd
+    intro w hw
+    rw [formalEdgeCrossProduct_zero_simplex_right]
+    exact
+      SingularMayerVietoris.formalMap_mem_supported (S := S) (T := S ×ˢ T) (fun v => (v, w 0))
+        (fun _ hv => ⟨hv, hw 0⟩) hc
+  | succ q ih =>
+    intro c d hc hd
+    apply
+      SingularMayerVietoris.formalLinearMap_mem_of_supported
+        ((formalEdgeCrossProduct (q + 1)).flip d)
+        (SingularMayerVietoris.formalChainsSupported (S ×ˢ T) (q + 3)) hc
+    intro v hv
+    change formalEdgeCrossProduct (q + 1) (SingularMayerVietoris.formalSimplex v) d ∈ _
+    apply
+      SingularMayerVietoris.formalLinearMap_mem_of_supported
+        (formalEdgeCrossProduct (q + 1) (SingularMayerVietoris.formalSimplex v))
+        (SingularMayerVietoris.formalChainsSupported (S ×ˢ T) (q + 3)) hd
+    intro w hw
+    rw [formalEdgeCrossProduct_simplex_succ]
+    apply
+      SingularMayerVietoris.formalCone_mem_supported (show (v 0, w 0) ∈ S ×ˢ T from ⟨hv 0, hw 0⟩)
+    apply Submodule.sub_mem
+    · exact
+        formalPointCrossProduct_mem_supported (q + 1)
+          (SingularMayerVietoris.formalBoundary_mem_supported 1
+            (SingularMayerVietoris.formalSimplex_mem_supported hv))
+          (SingularMayerVietoris.formalSimplex_mem_supported hw)
+    · exact
+        ih (SingularMayerVietoris.formalSimplex_mem_supported hv)
+          (SingularMayerVietoris.formalBoundary_mem_supported (q + 1)
+            (SingularMayerVietoris.formalSimplex_mem_supported hw))
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology6.lean b/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology6.lean
new file mode 100644
index 000000000..00a8dc320
--- /dev/null
+++ b/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology6.lean
@@ -0,0 +1,1718 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.PeriodFamily.PeriodDomain
+public import LeanPool.HopfProblem.Recognition.Smale4
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology3
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology4
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+import all LeanPool.HopfProblem.Lattice.Core2
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.PeriodFamily.PeriodDomain
+import all LeanPool.HopfProblem.Recognition.Smale4
+
+/-!
+# Hopf problem: torus homology · period torus higher homology 6
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def PeriodTorusHigherHomologyExterior.squareA₁ : Matrix (Fin 6) (Fin 6) ℤ :=
+  LocalSystemMatrices.exteriorSquare A₁
+
+private def PeriodTorusHigherHomologyExterior.squareA₂ : Matrix (Fin 6) (Fin 6) ℤ :=
+  LocalSystemMatrices.exteriorSquare A₂
+
+private def PeriodTorusHigherHomologyExterior.squareM₀ : Matrix (Fin 6) (Fin 6) ℤ :=
+  LocalSystemMatrices.exteriorSquare M₀
+
+private def PeriodTorusHigherHomologyExterior.cubeA₁ : LatticeMatrix :=
+  LocalSystemMatrices.exteriorCube A₁
+
+private def PeriodTorusHigherHomologyExterior.cubeA₂ : LatticeMatrix :=
+  LocalSystemMatrices.exteriorCube A₂
+
+private def PeriodTorusHigherHomologyExterior.cubeM₀ : LatticeMatrix :=
+  LocalSystemMatrices.exteriorCube M₀
+
+private theorem PeriodTorusHigherHomologyExterior.squareA₁_eq :
+    squareA₁ =
+      !![0, 1, 0, 0, 0, 0;
+        -1, -1, 0, 0, 0, 0;
+        1, 0, 1, 0, 0, 0;
+        -6, 0, 0, 1, 0, 0;
+        6, 2, 6, -1, 0, 1;
+        -8, -2, -6, 1, -1, -1] := by decide
+
+private theorem PeriodTorusHigherHomologyExterior.squareA₂_eq :
+    squareA₂ =
+      !![0, -1, 0, 0, 0, 0;
+        1, 0, 0, 0, 0, 0;
+        0, 1, 1, 0, 0, 0;
+        0, -6, 0, 1, 0, 0;
+        0, 3, 0, 0, 0, -1;
+        -3, -6, -6, 1, 1, 0] := by decide
+
+private theorem PeriodTorusHigherHomologyExterior.squareM₀_eq :
+    squareM₀ =
+      !![1, 0, 0, 0, 0, 0;
+        1, 1, 0, 0, 0, 0;
+        0, 0, 1, 0, 0, 0;
+        0, 0, 0, 1, 0, 0;
+        1, 0, 0, 0, 1, 0;
+        1, 1, 0, 0, 1, 1] := by decide
+
+private theorem PeriodTorusHigherHomologyExterior.cubeA₁_eq :
+    cubeA₁ = !![1, 0, 0, 0; -1, 0, 1, 0; 1, -1, -1, 0; -2, -6, 0, 1] := by decide
+
+private theorem PeriodTorusHigherHomologyExterior.cubeA₂_eq :
+    cubeA₂ = !![1, 0, 0, 0; 0, 0, -1, 0; 1, 1, 0, 0; 3, 0, -6, 1] := by decide
+
+private theorem PeriodTorusHigherHomologyExterior.cubeM₀_eq :
+    cubeM₀ = !![1, 0, 0, 0; 0, 1, 0, 0; 0, 1, 1, 0; -1, 0, 0, 1] := by decide
+
+/-- The product of `n` unit circles. -/
+public
+abbrev PeriodTorusHigherHomology.ProductTorus (n : ℕ) :=
+  Fin n → AddCircle (1 : ℝ)
+
+/-- The additive quotient map from real coordinates to the product torus. -/
+public
+def PeriodTorusHigherHomology.coordinateProjection (n : ℕ) : (Fin n → ℝ) →+ ProductTorus n
+    where
+  toFun x i := (x i : AddCircle (1 : ℝ))
+  map_zero' := by ext i; rfl
+  map_add' x y := by ext i; exact AddCircle.coe_add (1 : ℝ) (x i) (y i)
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.coordinateProjection_apply (n : ℕ) (x : Fin n → ℝ) (i : Fin n) :
+    coordinateProjection n x i = (x i : AddCircle (1 : ℝ)) :=
+  rfl
+
+private theorem PeriodTorusHigherHomology.coordinateProjection_continuous (n : ℕ) :
+    Continuous (coordinateProjection n) := by
+  exact continuous_pi (fun i => (AddCircle.continuous_mk' (1 : ℝ)).comp (continuous_apply i))
+
+private theorem PeriodTorusHigherHomology.coordinateProjection_eq_zero_iff (n : ℕ) (x : Fin n → ℝ) :
+    coordinateProjection n x = 0 ↔ ∃ v : Fin n → ℤ, x = fun i => (v i : ℝ) := by
+  constructor
+  · intro h
+    have hi : ∀ i, ∃ k : ℤ, (k : ℝ) = x i := by
+      intro i
+      have hz := congrFun h i
+      change (x i : AddCircle (1 : ℝ)) = 0 at hz
+      simpa only [zsmul_eq_mul, mul_one] using (AddCircle.coe_eq_zero_iff (1 : ℝ)).mp hz
+    choose v hv using hi
+    exact ⟨v, funext fun i => (hv i).symm⟩
+  · rintro ⟨v, rfl⟩
+    ext i
+    change ((v i : ℝ) : AddCircle (1 : ℝ)) = 0
+    apply (AddCircle.coe_eq_zero_iff (1 : ℝ)).mpr
+    exact ⟨v i, by simp⟩
+
+private theorem PeriodTorusHigherHomology.coordinateProjection_surjective (n : ℕ) :
+    Function.Surjective (coordinateProjection n) := by
+  intro t
+  have h : ∀ i, ∃ x : ℝ, (x : AddCircle (1 : ℝ)) = t i := by
+    intro i
+    exact QuotientAddGroup.mk_surjective (t i)
+  choose x hx using h
+  exact ⟨x, funext hx⟩
+
+private def PeriodTorusHigherHomology.productTorusSuccHomeomorph (n : ℕ) :
+    ProductTorus (n + 1) ≃ₜ AddCircle (1 : ℝ) × ProductTorus n
+    where
+  toFun x := (x 0, fun i => x i.succ)
+  invFun x := Fin.cons x.1 x.2
+  left_inv x := Fin.cons_self_tail x
+  right_inv x := by simp
+  continuous_toFun := (continuous_apply 0).prodMk (continuous_pi fun i => continuous_apply i.succ)
+  continuous_invFun := by
+    apply continuous_pi
+    intro i
+    refine Fin.cases ?_ (fun j => ?_) i
+    · exact continuous_fst
+    · exact (continuous_apply j).comp continuous_snd
+
+@[simp]
+private theorem PeriodTorusHigherHomology.productTorusSuccHomeomorph_apply (n : ℕ)
+    (x : ProductTorus (n + 1)) : productTorusSuccHomeomorph n x = (x 0, fun i => x i.succ) :=
+  rfl
+
+private def PeriodTorusHigherHomology.productTorusZeroHomeomorph : ProductTorus 0 ≃ₜ PUnit
+    where
+  toFun _ := PUnit.unit
+  invFun _ := Fin.elim0
+  left_inv _ := Subsingleton.elim _ _
+  right_inv _ := Subsingleton.elim _ _
+  continuous_toFun := continuous_const
+  continuous_invFun := continuous_const
+
+private def PeriodTorusHigherHomology.coordinatePeriodLoop (n : ℕ) (v : Fin n → ℤ) :
+    Path (0 : ProductTorus n) 0 :=
+  ((Path.segment (0 : Fin n → ℝ) (fun i => (v i : ℝ))).map
+        (coordinateProjection_continuous n)).cast
+    (map_zero (coordinateProjection n)).symm
+    ((coordinateProjection_eq_zero_iff n _).mpr ⟨v, rfl⟩).symm
+
+@[simp]
+private theorem PeriodTorusHigherHomology.coordinatePeriodLoop_apply (n : ℕ) (v : Fin n → ℤ)
+    (t : unitInterval) (i : Fin n) :
+    coordinatePeriodLoop n v t i = ((t : ℝ) * (v i : ℝ) : AddCircle (1 : ℝ)) := by
+  simp only [coordinatePeriodLoop, Path.cast_coe, Path.map_coe, Function.comp_apply,
+    Path.segment_apply, AffineMap.lineMap_apply_module, smul_zero, zero_add,
+    coordinateProjection_apply, Pi.smul_apply, smul_eq_mul]
+
+private theorem PeriodTorusHigherHomology.standardLattice_le_coordinateProjection_ker :
+    standardLattice ≤ LinearMap.ker (coordinateProjection 4).toIntLinearMap := by
+  intro x hx
+  obtain ⟨v, rfl⟩ := (Elliptic.standardLattice_mem_iff x).mp hx
+  exact (coordinateProjection_eq_zero_iff 4 _).mpr ⟨v, rfl⟩
+
+private def PeriodTorusHigherHomology.flatTorusCircleMap : RealTorus₄ →ₗ[ℤ] ProductTorus 4 :=
+  standardLattice.liftQ (coordinateProjection 4).toIntLinearMap
+    standardLattice_le_coordinateProjection_ker
+
+private theorem
+    PeriodTorusHigherHomology.flatTorusCircleMap_continuous : Continuous flatTorusCircleMap :=
+  by
+  apply standardLattice.isQuotientMap_mkQ.continuous_iff.mpr
+  exact coordinateProjection_continuous 4
+
+private theorem PeriodTorusHigherHomology.flatTorusCircleMap_injective :
+    Function.Injective flatTorusCircleMap := by
+  intro a b hab
+  obtain ⟨x, rfl⟩ := standardLattice.mkQ_surjective a
+  obtain ⟨y, rfl⟩ := standardLattice.mkQ_surjective b
+  have hz : coordinateProjection 4 (x - y) = 0 := by
+    rw [map_sub]
+    exact sub_eq_zero.mpr hab
+  obtain ⟨v, hv⟩ := (coordinateProjection_eq_zero_iff 4 (x - y)).mp hz
+  apply (Elliptic.flatTorus_mkQ_eq_iff x y).mpr
+  exact ⟨v, hv⟩
+
+private theorem PeriodTorusHigherHomology.flatTorusCircleMap_surjective :
+    Function.Surjective flatTorusCircleMap := by
+  intro t
+  obtain ⟨x, hx⟩ := coordinateProjection_surjective 4 t
+  exact ⟨standardLattice.mkQ x, hx⟩
+
+private def PeriodTorusHigherHomology.flatTorusCircleHomeomorph : RealTorus₄ ≃ₜ ProductTorus 4 :=
+  Equiv.toHomeomorphOfContinuousClosed
+    (Equiv.ofBijective flatTorusCircleMap
+      ⟨flatTorusCircleMap_injective, flatTorusCircleMap_surjective⟩)
+    flatTorusCircleMap_continuous flatTorusCircleMap_continuous.isClosedMap
+
+private theorem PeriodTorusHigherHomology.flatTorusCircleHomeomorph_mkQ (x : RealPlane₄) :
+    flatTorusCircleHomeomorph (standardLattice.mkQ x) = coordinateProjection 4 x :=
+  rfl
+
+private def PeriodTorusHigherHomology.periodTorusCircleHomeomorph (p : PeriodDomain) :
+    p.Torus ≃ₜ ProductTorus 4 :=
+  (Elliptic.flatTorusPeriodHomeomorph p).symm.trans flatTorusCircleHomeomorph
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.periodTorusCircleHomeomorph_flatProjection (p : PeriodDomain)
+    (x : RealPlane₄) :
+    periodTorusCircleHomeomorph p (Elliptic.flatProjection p x) = coordinateProjection 4 x := by
+  rw [periodTorusCircleHomeomorph, Homeomorph.trans_apply,
+    Elliptic.flatTorusPeriodHomeomorph_symm_flatProjection, flatTorusCircleHomeomorph_mkQ]
+
+@[simp]
+private theorem PeriodTorusHigherHomology.periodTorusCircleHomeomorph_zero (p : PeriodDomain) :
+    periodTorusCircleHomeomorph p 0 = 0 := by
+  have h := periodTorusCircleHomeomorph_flatProjection p 0
+  simpa only [Elliptic.flatProjection, map_zero] using h
+
+private theorem
+    PeriodTorusHigherHomology.periodTorusCircleHomeomorph_periodLoop_apply (p : PeriodDomain)
+    (v : Lattice) (t : unitInterval) :
+    periodTorusCircleHomeomorph p (p.periodLoop v t) = coordinatePeriodLoop 4 v t := by
+  rw [PeriodDomain.periodLoop_apply]
+  have hv : (t : ℝ) • p.periodVector v = Elliptic.periodEquiv p ((t : ℝ) • Elliptic.realCast v) :=
+    by rw [map_smul, Elliptic.periodEquiv_realCast, p.periodVector_eq_sum]
+  rw [hv]
+  change
+    periodTorusCircleHomeomorph p (Elliptic.flatProjection p ((t : ℝ) • Elliptic.realCast v)) = _
+  rw [periodTorusCircleHomeomorph_flatProjection]
+  ext i
+  rw [coordinatePeriodLoop_apply]
+  rfl
+
+private theorem PeriodTorusHigherHomology.periodTorusCircleHomeomorph_periodLoop (p : PeriodDomain)
+    (v : Lattice) :
+    (p.periodLoop v).map (periodTorusCircleHomeomorph p).continuous =
+      (coordinatePeriodLoop 4 v).cast (periodTorusCircleHomeomorph_zero p)
+        (periodTorusCircleHomeomorph_zero p) := by
+  apply Path.ext
+  funext t
+  exact periodTorusCircleHomeomorph_periodLoop_apply p v t
+
+private def PeriodTorusHigherHomology.CirclePaths.circleTranslation (a : ℝ) :
+    C((PeriodTorusHigherHomology.CircleTopology.Circle),
+      (PeriodTorusHigherHomology.CircleTopology.Circle)) :=
+  ⟨fun z => (a : (PeriodTorusHigherHomology.CircleTopology.Circle)) + z, by
+    exact
+      (continuous_const :
+            Continuous
+              (fun _ : (PeriodTorusHigherHomology.CircleTopology.Circle) =>
+                (a : (PeriodTorusHigherHomology.CircleTopology.Circle)))).add
+        continuous_id⟩
+
+@[simp]
+private theorem PeriodTorusHigherHomology.CirclePaths.circleTranslation_apply (a : ℝ)
+    (z : (PeriodTorusHigherHomology.CircleTopology.Circle)) :
+    circleTranslation a z = (a : (PeriodTorusHigherHomology.CircleTopology.Circle)) + z :=
+  rfl
+
+private def PeriodTorusHigherHomology.CirclePaths.circleTranslationHomotopy (a : ℝ) :
+    (circleTranslation a).Homotopy
+      (ContinuousMap.id (PeriodTorusHigherHomology.CircleTopology.Circle))
+    where
+  toFun
+    p := ((((1 - (p.1 : ℝ)) * a : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle)) + p.2)
+  continuous_toFun :=
+    ((AddCircle.continuous_mk' (1 : ℝ)).comp
+          ((continuous_const.sub (continuous_subtype_val.comp continuous_fst)).mul
+            continuous_const)).add
+      continuous_snd
+  map_zero_left z := by simp
+  map_one_left z := by simp
+
+@[simp]
+private theorem PeriodTorusHigherHomology.CirclePaths.circleTranslation_singularHomologyMap (a : ℝ)
+    (n : ℕ) : SingularMayerVietoris.singularHomologyMap (circleTranslation a) n = LinearMap.id := by
+  rw [PeriodTorusHigherHomology.homotopy_homologyMap (circleTranslationHomotopy a) n,
+    PeriodTorusHigherHomology.singularHomologyMap_id]
+
+private theorem PeriodTorusHigherHomology.CirclePaths.circleTranslation_inducedHomology (a : ℝ) :
+    FirstHurewicz.inducedHomology (circleTranslation a) = LinearMap.id :=
+  circleTranslation_singularHomologyMap a 1
+
+private theorem
+    PeriodTorusHigherHomology.CirclePaths.loopHomologyClass_map_circleTranslation (a : ℝ)
+    {x : (PeriodTorusHigherHomology.CircleTopology.Circle)} (p : Path x x) :
+    FirstHurewicz.loopHomologyClass (p.map (circleTranslation a).continuous) =
+      FirstHurewicz.loopHomologyClass p := by
+  rw [← FirstHurewicz.inducedHomology_loopHomologyClass (circleTranslation a) x p,
+    circleTranslation_inducedHomology]
+  rfl
+
+private def PeriodTorusHigherHomology.CirclePaths.quarterIntersection :
+    ↥(PeriodTorusHigherHomology.CircleTopology.arcU ∩
+        PeriodTorusHigherHomology.CircleTopology.arcV) :=
+  PeriodTorusHigherHomology.CircleTopology.intersectionHomeomorph.symm
+    (Sum.inl ⟨(1 / 4 : ℝ), by norm_num⟩)
+
+private def PeriodTorusHigherHomology.CirclePaths.threeQuarterIntersection :
+    ↥(PeriodTorusHigherHomology.CircleTopology.arcU ∩
+        PeriodTorusHigherHomology.CircleTopology.arcV) :=
+  PeriodTorusHigherHomology.CircleTopology.intersectionHomeomorph.symm
+    (Sum.inr ⟨(3 / 4 : ℝ), by norm_num⟩)
+
+private def PeriodTorusHigherHomology.CirclePaths.quarterPoint :
+    (PeriodTorusHigherHomology.CircleTopology.Circle) :=
+  quarterIntersection.val
+
+private def PeriodTorusHigherHomology.CirclePaths.threeQuarterPoint :
+    (PeriodTorusHigherHomology.CircleTopology.Circle) :=
+  threeQuarterIntersection.val
+
+@[simp]
+private theorem PeriodTorusHigherHomology.CirclePaths.quarterPoint_coe :
+    quarterPoint = ((1 / 4 : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle)) :=
+  rfl
+
+@[simp]
+private theorem PeriodTorusHigherHomology.CirclePaths.quarterIntersection_component :
+    PeriodTorusHigherHomology.CircleTopology.intersectionHomeomorph quarterIntersection =
+      Sum.inl ⟨(1 / 4 : ℝ), by norm_num⟩ :=
+  PeriodTorusHigherHomology.CircleTopology.intersectionHomeomorph.apply_symm_apply _
+
+@[simp]
+private theorem PeriodTorusHigherHomology.CirclePaths.threeQuarterIntersection_component :
+    PeriodTorusHigherHomology.CircleTopology.intersectionHomeomorph threeQuarterIntersection =
+      Sum.inr ⟨(3 / 4 : ℝ), by norm_num⟩ :=
+  PeriodTorusHigherHomology.CircleTopology.intersectionHomeomorph.apply_symm_apply _
+
+private def PeriodTorusHigherHomology.CirclePaths.quarterU :
+    PeriodTorusHigherHomology.CircleTopology.arcU :=
+  ⟨quarterPoint, quarterIntersection.property.1⟩
+
+private def PeriodTorusHigherHomology.CirclePaths.quarterV :
+    PeriodTorusHigherHomology.CircleTopology.arcV :=
+  ⟨quarterPoint, quarterIntersection.property.2⟩
+
+private def PeriodTorusHigherHomology.CirclePaths.threeQuarterU :
+    PeriodTorusHigherHomology.CircleTopology.arcU :=
+  ⟨threeQuarterPoint, threeQuarterIntersection.property.1⟩
+
+private def PeriodTorusHigherHomology.CirclePaths.threeQuarterV :
+    PeriodTorusHigherHomology.CircleTopology.arcV :=
+  ⟨threeQuarterPoint, threeQuarterIntersection.property.2⟩
+
+private def PeriodTorusHigherHomology.CirclePaths.uPath : Path quarterU threeQuarterU
+    where
+  toFun
+    t :=
+    PeriodTorusHigherHomology.CircleTopology.arcUHomeomorph.symm
+      ⟨(1 / 4 : ℝ) + (t : ℝ) / 2, by
+        have ht := t.property
+        constructor <;> linarith [ht.1, ht.2]⟩
+  continuous_toFun :=
+    PeriodTorusHigherHomology.CircleTopology.arcUHomeomorph.symm.continuous.comp
+      ((continuous_const.add (continuous_subtype_val.div_const 2)).subtype_mk
+        (fun t => by
+          change (1 / 4 : ℝ) + (t : ℝ) / 2 ∈ Set.Ioo (0 : ℝ) 1
+          constructor <;> linarith [t.property.1, t.property.2]))
+  source' := by
+    apply Subtype.ext
+    change
+      (((1 / 4 : ℝ) + (0 : unitInterval) / 2 : ℝ) :
+          (PeriodTorusHigherHomology.CircleTopology.Circle)) =
+        ((1 / 4 : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle))
+    norm_num
+  target' := by
+    apply Subtype.ext
+    change
+      (((1 / 4 : ℝ) + (1 : unitInterval) / 2 : ℝ) :
+          (PeriodTorusHigherHomology.CircleTopology.Circle)) =
+        ((3 / 4 : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle))
+    norm_num
+
+private def PeriodTorusHigherHomology.CirclePaths.vPath : Path threeQuarterV quarterV
+    where
+  toFun
+    t :=
+    PeriodTorusHigherHomology.CircleTopology.arcVHomeomorph.symm
+      ⟨(3 / 4 : ℝ) + (t : ℝ) / 2, by
+        have ht := t.property
+        constructor <;> linarith [ht.1, ht.2]⟩
+  continuous_toFun :=
+    PeriodTorusHigherHomology.CircleTopology.arcVHomeomorph.symm.continuous.comp
+      ((continuous_const.add (continuous_subtype_val.div_const 2)).subtype_mk
+        (fun t => by
+          change (3 / 4 : ℝ) + (t : ℝ) / 2 ∈ Set.Ioo (1 / 2 : ℝ) (3 / 2)
+          constructor <;> linarith [t.property.1, t.property.2]))
+  source' := by
+    apply Subtype.ext
+    change
+      (((3 / 4 : ℝ) + (0 : unitInterval) / 2 : ℝ) :
+          (PeriodTorusHigherHomology.CircleTopology.Circle)) =
+        ((3 / 4 : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle))
+    norm_num
+  target' := by
+    apply Subtype.ext
+    change
+      (((3 / 4 : ℝ) + (1 : unitInterval) / 2 : ℝ) :
+          (PeriodTorusHigherHomology.CircleTopology.Circle)) =
+        ((1 / 4 : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle))
+    convert AddCircle.coe_add_period (1 : ℝ) (1 / 4 : ℝ) using 1
+    norm_num
+
+private def
+    PeriodTorusHigherHomology.CirclePaths.uCirclePath : Path quarterPoint threeQuarterPoint :=
+  uPath.map continuous_subtype_val
+
+private def
+    PeriodTorusHigherHomology.CirclePaths.vCirclePath : Path threeQuarterPoint quarterPoint :=
+  vPath.map continuous_subtype_val
+
+@[simp]
+private theorem PeriodTorusHigherHomology.CirclePaths.uCirclePath_apply (t : unitInterval) :
+    uCirclePath t =
+      (((1 / 4 : ℝ) + (t : ℝ) / 2 : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle)) :=
+  rfl
+
+@[simp]
+private theorem PeriodTorusHigherHomology.CirclePaths.vCirclePath_apply (t : unitInterval) :
+    vCirclePath t =
+      (((3 / 4 : ℝ) + (t : ℝ) / 2 : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle)) :=
+  rfl
+
+private def PeriodTorusHigherHomology.CirclePaths.quarterLoop : Path quarterPoint quarterPoint
+    where
+  toFun t := (((1 / 4 : ℝ) + (t : ℝ) : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle))
+  continuous_toFun :=
+    (AddCircle.continuous_mk' (1 : ℝ)).comp (continuous_const.add continuous_subtype_val)
+  source' := by
+    change
+      (((1 / 4 : ℝ) + (0 : unitInterval) : ℝ) :
+          (PeriodTorusHigherHomology.CircleTopology.Circle)) =
+        _;
+    simp
+  target' := AddCircle.coe_add_period (1 : ℝ) (1 / 4 : ℝ)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.CirclePaths.quarterLoop_apply (t : unitInterval) :
+    quarterLoop t =
+      (((1 / 4 : ℝ) + (t : ℝ) : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle)) :=
+  rfl
+
+private theorem PeriodTorusHigherHomology.CirclePaths.uCirclePath_trans_vCirclePath :
+    uCirclePath.trans vCirclePath = quarterLoop := by
+  apply Path.ext
+  funext t
+  rw [Path.trans_apply]
+  split_ifs <;> simp only [uCirclePath_apply, vCirclePath_apply, quarterLoop_apply]
+  · congr 1
+    ring
+  · congr 1
+    ring
+
+/-- The positively oriented standard loop around the unit circle. -/
+public
+def PeriodTorusHigherHomology.CirclePaths.positiveLoop :
+    Path (0 : (PeriodTorusHigherHomology.CircleTopology.Circle)) 0
+    where
+  toFun t := ((t : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle))
+  continuous_toFun := (AddCircle.continuous_mk' (1 : ℝ)).comp continuous_subtype_val
+  source' := AddCircle.coe_zero (1 : ℝ)
+  target' := AddCircle.coe_period (1 : ℝ)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.CirclePaths.positiveLoop_apply (t : unitInterval) :
+    positiveLoop t = ((t : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle)) :=
+  rfl
+
+private theorem PeriodTorusHigherHomology.CirclePaths.quarterTranslation_zero :
+    circleTranslation (1 / 4) (0 : (PeriodTorusHigherHomology.CircleTopology.Circle)) =
+      quarterPoint := by simp only [circleTranslation_apply, add_zero, quarterPoint_coe]
+
+private theorem PeriodTorusHigherHomology.CirclePaths.quarterLoop_eq_translation :
+    quarterLoop =
+      (positiveLoop.map (circleTranslation (1 / 4)).continuous).cast quarterTranslation_zero.symm
+        quarterTranslation_zero.symm := by
+  apply Path.ext
+  funext t
+  change
+    (((1 / 4 : ℝ) + (t : ℝ) : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle)) =
+      ((1 / 4 : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle)) +
+        ((t : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle))
+  exact AddCircle.coe_add (1 : ℝ) (1 / 4 : ℝ) (t : ℝ)
+
+private theorem PeriodTorusHigherHomology.CirclePaths.quarterLoop_homologyClass :
+    FirstHurewicz.loopHomologyClass quarterLoop = FirstHurewicz.loopHomologyClass positiveLoop := by
+  have hc :
+    FirstHurewicz.loopHomologyClass quarterLoop =
+      FirstHurewicz.loopHomologyClass (positiveLoop.map (circleTranslation (1 / 4)).continuous) :=
+    by
+    apply
+      FirstHurewicz.homologyToChainClass_injective
+        (PeriodTorusHigherHomology.CircleTopology.Circle)
+    rw [FirstHurewicz.homologyToChainClass_loopHomologyClass,
+      FirstHurewicz.homologyToChainClass_loopHomologyClass, quarterLoop_eq_translation,
+      FirstHurewicz.pathClass_cast]
+  exact hc.trans (loopHomologyClass_map_circleTranslation (1 / 4) positiveLoop)
+
+private theorem PeriodTorusHigherHomology.CirclePaths.boundaryOne_arcSum :
+    FirstHurewicz.boundaryOne (PeriodTorusHigherHomology.CircleTopology.Circle)
+        (FirstHurewicz.pathChain uCirclePath + FirstHurewicz.pathChain vCirclePath) =
+      0 := by
+  rw [map_add, FirstHurewicz.boundaryOne_pathChain, FirstHurewicz.boundaryOne_pathChain]
+  abel
+
+private def PeriodTorusHigherHomology.CirclePaths.arcSumCycle :
+    FirstHurewicz.Cycles1 (PeriodTorusHigherHomology.CircleTopology.Circle) :=
+  FirstHurewicz.mkCycle1 (PeriodTorusHigherHomology.CircleTopology.Circle)
+    (FirstHurewicz.pathChain uCirclePath + FirstHurewicz.pathChain vCirclePath) boundaryOne_arcSum
+
+private theorem PeriodTorusHigherHomology.CirclePaths.arcSumCycle_class :
+    FirstHurewicz.cycleClass (PeriodTorusHigherHomology.CircleTopology.Circle) arcSumCycle =
+      FirstHurewicz.loopHomologyClass quarterLoop := by
+  apply
+    FirstHurewicz.homologyToChainClass_injective (PeriodTorusHigherHomology.CircleTopology.Circle)
+  rw [FirstHurewicz.homologyToChainClass_cycleClass,
+    FirstHurewicz.homologyToChainClass_loopHomologyClass]
+  change
+    FirstHurewicz.chainClass (PeriodTorusHigherHomology.CircleTopology.Circle)
+        (FirstHurewicz.pathChain uCirclePath + FirstHurewicz.pathChain vCirclePath) =
+      _
+  rw [map_add, ← uCirclePath_trans_vCirclePath, FirstHurewicz.pathClass_trans]
+  rfl
+
+private theorem PeriodTorusHigherHomology.CirclePaths.arcSumCycle_positiveLoop_class :
+    FirstHurewicz.cycleClass (PeriodTorusHigherHomology.CircleTopology.Circle) arcSumCycle =
+      FirstHurewicz.loopHomologyClass positiveLoop :=
+  arcSumCycle_class.trans quarterLoop_homologyClass
+
+private def PeriodTorusHigherHomology.CirclePaths.quarterIntersectionSection (X : Type*)
+    [TopologicalSpace X] :
+    C(X,
+      ↥(PeriodTorusHigherHomology.CircleTopology.productU X ∩
+          PeriodTorusHigherHomology.CircleTopology.productV X)) :=
+  ⟨fun x => ⟨(quarterPoint, x), quarterIntersection.property⟩,
+    (continuous_const.prodMk continuous_id).subtype_mk _⟩
+
+private def PeriodTorusHigherHomology.CirclePaths.threeQuarterIntersectionSection (X : Type*)
+    [TopologicalSpace X] :
+    C(X,
+      ↥(PeriodTorusHigherHomology.CircleTopology.productU X ∩
+          PeriodTorusHigherHomology.CircleTopology.productV X)) :=
+  ⟨fun x => ⟨(threeQuarterPoint, x), threeQuarterIntersection.property⟩,
+    (continuous_const.prodMk continuous_id).subtype_mk _⟩
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.CirclePaths.quarterIntersectionSection_component (X : Type*)
+    [TopologicalSpace X] (x : X) :
+    PeriodTorusHigherHomology.CircleTopology.productIntersectionHomotopyEquiv X
+        (quarterIntersectionSection X x) =
+      Sum.inl x := by
+  change
+    Sum.map (fun t : Set.Ioo (0 : ℝ) (1 / 2) × X => t.2)
+        (fun t : Set.Ioo (1 / 2 : ℝ) 1 × X => t.2)
+        (Homeomorph.sumProdDistrib
+          (PeriodTorusHigherHomology.CircleTopology.intersectionHomeomorph quarterIntersection,
+            x)) =
+      _
+  rw [quarterIntersection_component]
+  rfl
+
+private theorem PeriodTorusHigherHomology.CirclePaths.quarterIntersectionSection_comp (X : Type*)
+    [TopologicalSpace X] :
+    (PeriodTorusHigherHomology.CircleTopology.productIntersectionHomotopyEquiv X).toFun.comp
+        (quarterIntersectionSection X) =
+      ⟨Sum.inl, continuous_inl⟩ := by
+  apply ContinuousMap.ext
+  intro x
+  exact quarterIntersectionSection_component X x
+
+@[simp]
+private theorem PeriodTorusHigherHomology.CirclePaths.threeQuarterIntersectionSection_component
+    (X : Type*) [TopologicalSpace X] (x : X) :
+    PeriodTorusHigherHomology.CircleTopology.productIntersectionHomotopyEquiv X
+        (threeQuarterIntersectionSection X x) =
+      Sum.inr x := by
+  change
+    Sum.map (fun t : Set.Ioo (0 : ℝ) (1 / 2) × X => t.2)
+        (fun t : Set.Ioo (1 / 2 : ℝ) 1 × X => t.2)
+        (Homeomorph.sumProdDistrib
+          (PeriodTorusHigherHomology.CircleTopology.intersectionHomeomorph
+              threeQuarterIntersection,
+            x)) =
+      _
+  rw [threeQuarterIntersection_component]
+  rfl
+
+private theorem
+    PeriodTorusHigherHomology.CirclePaths.threeQuarterIntersectionSection_comp (X : Type*)
+    [TopologicalSpace X] :
+    (PeriodTorusHigherHomology.CircleTopology.productIntersectionHomotopyEquiv X).toFun.comp
+        (threeQuarterIntersectionSection X) =
+      ⟨Sum.inr, continuous_inr⟩ := by
+  apply ContinuousMap.ext
+  intro x
+  exact threeQuarterIntersectionSection_component X x
+
+private def PeriodTorusHigherHomology.positiveCircleCross (X : Type) [TopologicalSpace X] (n : ℕ) :
+    SingularMayerVietoris.SingularHomology X n →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) × X) (n + 1) :=
+  crossProductHomology (PeriodTorusHigherHomology.CircleTopology.Circle) X n
+    (FirstHurewicz.loopHomologyClass CirclePaths.positiveLoop)
+
+private theorem PeriodTorusHigherHomology.positiveCircleCross_arcSum_cycleClass (X : Type)
+    [TopologicalSpace X] (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    positiveCircleCross X n
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n b) =
+      SingularMayerVietoris.ModuleHomology.cycleClass
+        (FirstHurewicz.singularComplex ((PeriodTorusHigherHomology.CircleTopology.Circle) × X))
+        (n + 1)
+        (crossProductCycles (PeriodTorusHigherHomology.CircleTopology.Circle) X n
+          CirclePaths.arcSumCycle b) := by
+  have h :
+    SingularMayerVietoris.ModuleHomology.cycleClass
+        (FirstHurewicz.singularComplex (PeriodTorusHigherHomology.CircleTopology.Circle)) 1
+        CirclePaths.arcSumCycle =
+      FirstHurewicz.loopHomologyClass CirclePaths.positiveLoop :=
+    CirclePaths.arcSumCycle_positiveLoop_class
+  change
+    crossProductHomology (PeriodTorusHigherHomology.CircleTopology.Circle) X n
+        (FirstHurewicz.loopHomologyClass CirclePaths.positiveLoop)
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n b) =
+      _
+  rw [← h]
+  exact
+    crossProductHomology_cycleClass (PeriodTorusHigherHomology.CircleTopology.Circle) X n
+      CirclePaths.arcSumCycle b
+
+private theorem PeriodTorusHigherHomology.quarterIntersectionHomology_coordinates (X : Type)
+    [TopologicalSpace X] (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    productIntersectionHomologyEquiv X n
+        (SingularMayerVietoris.singularHomologyMap (CirclePaths.quarterIntersectionSection X) n
+          a) =
+      (a, 0) := by
+  rw [productIntersectionHomologyEquiv_apply, ← LinearMap.comp_apply, ← singularHomologyMap_comp,
+    CirclePaths.quarterIntersectionSection_comp]
+  exact sumHomologyEquiv_inl X X n a
+
+private theorem PeriodTorusHigherHomology.threeQuarterIntersectionHomology_coordinates (X : Type)
+    [TopologicalSpace X] (n : ℕ) (a : SingularMayerVietoris.SingularHomology X n) :
+    productIntersectionHomologyEquiv X n
+        (SingularMayerVietoris.singularHomologyMap (CirclePaths.threeQuarterIntersectionSection X)
+          n a) =
+      (0, a) := by
+  rw [productIntersectionHomologyEquiv_apply, ← LinearMap.comp_apply, ← singularHomologyMap_comp,
+    CirclePaths.threeQuarterIntersectionSection_comp]
+  exact sumHomologyEquiv_inr X X n a
+
+private def
+    PeriodTorusHigherHomology.intersectionDifferenceCycle (X : Type) [TopologicalSpace X] (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    SingularMayerVietoris.ModuleHomology.Cycle
+      (FirstHurewicz.singularComplex
+        (CircleTopology.productU X ∩ CircleTopology.productV X :
+          Set ((PeriodTorusHigherHomology.CircleTopology.Circle) × X)))
+      n :=
+  SingularMayerVietoris.ModuleHomology.mapCycles
+      (FirstHurewicz.singularChainMap (CirclePaths.threeQuarterIntersectionSection X)) n b -
+    SingularMayerVietoris.ModuleHomology.mapCycles
+      (FirstHurewicz.singularChainMap (CirclePaths.quarterIntersectionSection X)) n b
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.intersectionDifferenceCycle_val (X : Type) [TopologicalSpace X]
+    (n : ℕ) (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    (intersectionDifferenceCycle X n b).1 =
+      FirstHurewicz.inducedChain (CirclePaths.threeQuarterIntersectionSection X) n b.1 -
+        FirstHurewicz.inducedChain (CirclePaths.quarterIntersectionSection X) n b.1 := by
+  change
+    (SingularMayerVietoris.ModuleHomology.mapCycles
+            (FirstHurewicz.singularChainMap (CirclePaths.threeQuarterIntersectionSection X)) n
+            b).1 -
+        (SingularMayerVietoris.ModuleHomology.mapCycles
+            (FirstHurewicz.singularChainMap (CirclePaths.quarterIntersectionSection X)) n b).1 =
+      _
+  rw [SingularMayerVietoris.ModuleHomology.mapCycles_val,
+    SingularMayerVietoris.ModuleHomology.mapCycles_val]
+
+private theorem PeriodTorusHigherHomology.intersectionDifferenceCycle_class_coordinates (X : Type)
+    [TopologicalSpace X] (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    productIntersectionHomologyEquiv X n
+        (SingularMayerVietoris.ModuleHomology.cycleClass
+          (FirstHurewicz.singularComplex
+            (CircleTopology.productU X ∩ CircleTopology.productV X :
+              Set ((PeriodTorusHigherHomology.CircleTopology.Circle) × X)))
+          n (intersectionDifferenceCycle X n b)) =
+      (-SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n b,
+        SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n b) := by
+  rw [intersectionDifferenceCycle, map_sub, map_sub, ←
+    SingularMayerVietoris.ModuleHomology.homologyMap_cycleClass, ←
+    SingularMayerVietoris.ModuleHomology.homologyMap_cycleClass]
+  change
+    productIntersectionHomologyEquiv X n
+          (SingularMayerVietoris.singularHomologyMap
+            (CirclePaths.threeQuarterIntersectionSection X) n
+            (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n
+              b)) -
+        productIntersectionHomologyEquiv X n
+          (SingularMayerVietoris.singularHomologyMap (CirclePaths.quarterIntersectionSection X) n
+            (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n
+              b)) =
+      _
+  rw [threeQuarterIntersectionHomology_coordinates, quarterIntersectionHomology_coordinates]
+  simp only [Prod.mk_sub_mk, zero_sub, sub_zero]
+
+private theorem
+    PeriodTorusHigherHomology.quarterIntersectionSection_toU (X : Type) [TopologicalSpace X] :
+    (CircleTopology.productIntersectionToU X).comp (CirclePaths.quarterIntersectionSection X) =
+      ((CircleTopology.productUHomeomorph X).symm :
+            C(CircleTopology.arcU × X, CircleTopology.productU X)).comp
+        ((ContinuousMap.const X CirclePaths.quarterU).prodMk (ContinuousMap.id X)) :=
+  rfl
+
+private theorem
+    PeriodTorusHigherHomology.quarterIntersectionSection_toV (X : Type) [TopologicalSpace X] :
+    (CircleTopology.productIntersectionToV X).comp (CirclePaths.quarterIntersectionSection X) =
+      ((CircleTopology.productVHomeomorph X).symm :
+            C(CircleTopology.arcV × X, CircleTopology.productV X)).comp
+        ((ContinuousMap.const X CirclePaths.quarterV).prodMk (ContinuousMap.id X)) :=
+  rfl
+
+private theorem PeriodTorusHigherHomology.threeQuarterIntersectionSection_toU (X : Type)
+    [TopologicalSpace X] :
+    (CircleTopology.productIntersectionToU X).comp
+        (CirclePaths.threeQuarterIntersectionSection X) =
+      ((CircleTopology.productUHomeomorph X).symm :
+            C(CircleTopology.arcU × X, CircleTopology.productU X)).comp
+        ((ContinuousMap.const X CirclePaths.threeQuarterU).prodMk (ContinuousMap.id X)) :=
+  rfl
+
+private theorem PeriodTorusHigherHomology.threeQuarterIntersectionSection_toV (X : Type)
+    [TopologicalSpace X] :
+    (CircleTopology.productIntersectionToV X).comp
+        (CirclePaths.threeQuarterIntersectionSection X) =
+      ((CircleTopology.productVHomeomorph X).symm :
+            C(CircleTopology.arcV × X, CircleTopology.productV X)).comp
+        ((ContinuousMap.const X CirclePaths.threeQuarterV).prodMk (ContinuousMap.id X)) :=
+  rfl
+
+private theorem PeriodTorusHigherHomology.crossProductEdge_boundary_of_right_cycle {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (n : ℕ) (a : FirstHurewicz.Chains X 1)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex Y) n) :
+    ((FirstHurewicz.singularComplex (X × Y)).d (n + 1) n).hom (crossProductEdge X Y n a b.1) =
+      crossProductZeroLeft X Y n (((FirstHurewicz.singularComplex X).d 1 0).hom a) b.1 := by
+  cases n with
+  | zero => exact crossProductEdge_boundary_zero a b.1
+  | succ
+    n =>
+    have hb : ((FirstHurewicz.singularComplex Y).d (n + 1) n).hom b.1 = 0 := by
+      simpa only [Nat.succ_sub_one] using
+        SingularMayerVietoris.ModuleHomology.cycle_condition (FirstHurewicz.singularComplex Y)
+          (n + 1) b
+    simp only [crossProductEdge_boundary, hb, map_zero, sub_zero]
+
+private theorem
+    PeriodTorusHigherHomology.crossProductEdge_path_boundary {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) {x y : X} (p : Path x y)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex Y) n) :
+    ((FirstHurewicz.singularComplex (X × Y)).d (n + 1) n).hom
+        (crossProductEdge X Y n (FirstHurewicz.pathChain p) b.1) =
+      FirstHurewicz.inducedChain (crossInsertLeft y) n b.1 -
+        FirstHurewicz.inducedChain (crossInsertLeft x) n b.1 := by
+  rw [crossProductEdge_boundary_of_right_cycle]
+  change
+    crossProductZeroLeft X Y n (FirstHurewicz.boundaryOne X (FirstHurewicz.pathChain p)) b.1 = _
+  rw [FirstHurewicz.boundaryOne_pathChain, map_sub, LinearMap.sub_apply]
+  simp only [FirstHurewicz.pointChain, crossProductZeroLeft_simplex_left]
+  rfl
+
+private theorem PeriodTorusHigherHomology.const_prodMk_id_eq_crossInsertLeft_mo1973_12793
+    {X Y : Type} [TopologicalSpace X] [TopologicalSpace Y] (x : X) :
+    (ContinuousMap.const Y x).prodMk (ContinuousMap.id Y) = crossInsertLeft x := by
+  apply ContinuousMap.ext
+  intro y
+  rfl
+
+private def PeriodTorusHigherHomology.uCrossChain (X : Type) [TopologicalSpace X] (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    FirstHurewicz.Chains (CircleTopology.productU X) (n + 1) :=
+  FirstHurewicz.inducedChain
+    ((CircleTopology.productUHomeomorph X).symm :
+      C(CircleTopology.arcU × X, CircleTopology.productU X))
+    (n + 1)
+    (crossProductEdge CircleTopology.arcU X n (FirstHurewicz.pathChain CirclePaths.uPath) b.1)
+
+private def PeriodTorusHigherHomology.vCrossChain (X : Type) [TopologicalSpace X] (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    FirstHurewicz.Chains (CircleTopology.productV X) (n + 1) :=
+  FirstHurewicz.inducedChain
+    ((CircleTopology.productVHomeomorph X).symm :
+      C(CircleTopology.arcV × X, CircleTopology.productV X))
+    (n + 1)
+    (crossProductEdge CircleTopology.arcV X n (FirstHurewicz.pathChain CirclePaths.vPath) b.1)
+
+private theorem
+    PeriodTorusHigherHomology.uCrossChain_boundary (X : Type) [TopologicalSpace X] (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    ((FirstHurewicz.singularComplex (CircleTopology.productU X)).d (n + 1) n).hom
+        (uCrossChain X n b) =
+      FirstHurewicz.inducedChain (CircleTopology.productIntersectionToU X) n
+        (intersectionDifferenceCycle X n b).1 := by
+  rw [uCrossChain, ← FirstHurewicz.inducedChain_boundary, crossProductEdge_path_boundary,
+    intersectionDifferenceCycle_val]
+  simp only [map_sub]
+  congr 1
+  · have h :=
+      congrArg (fun f => FirstHurewicz.inducedChain f n b.1)
+        (threeQuarterIntersectionSection_toU X)
+    simpa only [const_prodMk_id_eq_crossInsertLeft_mo1973_12793, FirstHurewicz.inducedChain_comp,
+      LinearMap.comp_apply] using h.symm
+  · have h :=
+      congrArg (fun f => FirstHurewicz.inducedChain f n b.1) (quarterIntersectionSection_toU X)
+    simpa only [const_prodMk_id_eq_crossInsertLeft_mo1973_12793, FirstHurewicz.inducedChain_comp,
+      LinearMap.comp_apply] using h.symm
+
+private theorem
+    PeriodTorusHigherHomology.vCrossChain_boundary (X : Type) [TopologicalSpace X] (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    ((FirstHurewicz.singularComplex (CircleTopology.productV X)).d (n + 1) n).hom
+        (vCrossChain X n b) =
+      -FirstHurewicz.inducedChain (CircleTopology.productIntersectionToV X) n
+          (intersectionDifferenceCycle X n b).1 := by
+  rw [vCrossChain, ← FirstHurewicz.inducedChain_boundary, crossProductEdge_path_boundary,
+    intersectionDifferenceCycle_val]
+  simp only [map_sub, neg_sub]
+  congr 1
+  · have h :=
+      congrArg (fun f => FirstHurewicz.inducedChain f n b.1) (quarterIntersectionSection_toV X)
+    simpa only [const_prodMk_id_eq_crossInsertLeft_mo1973_12793, FirstHurewicz.inducedChain_comp,
+      LinearMap.comp_apply] using h.symm
+  · have h :=
+      congrArg (fun f => FirstHurewicz.inducedChain f n b.1)
+        (threeQuarterIntersectionSection_toV X)
+    simpa only [const_prodMk_id_eq_crossInsertLeft_mo1973_12793, FirstHurewicz.inducedChain_comp,
+      LinearMap.comp_apply] using h.symm
+
+private theorem
+    PeriodTorusHigherHomology.uCrossChain_inclusion (X : Type) [TopologicalSpace X] (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    FirstHurewicz.inducedChain (CircleTopology.productUInclusion X) (n + 1) (uCrossChain X n b) =
+      crossProductEdge (PeriodTorusHigherHomology.CircleTopology.Circle) X n
+        (FirstHurewicz.pathChain CirclePaths.uCirclePath) b.1 := by
+  have hi :
+    (CircleTopology.productUInclusion X).comp
+        ((CircleTopology.productUHomeomorph X).symm :
+          C(CircleTopology.arcU × X, CircleTopology.productU X)) =
+      (⟨Subtype.val, continuous_subtype_val⟩ :
+            C(CircleTopology.arcU, (PeriodTorusHigherHomology.CircleTopology.Circle))).prodMap
+        (ContinuousMap.id X) :=
+    rfl
+  rw [uCrossChain, ← LinearMap.comp_apply, ← FirstHurewicz.inducedChain_comp, hi,
+    crossProductEdge_natural, FirstHurewicz.inducedChain_id, LinearMap.id_apply,
+    FirstHurewicz.inducedChain_pathChain]
+  rfl
+
+private theorem
+    PeriodTorusHigherHomology.vCrossChain_inclusion (X : Type) [TopologicalSpace X] (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    FirstHurewicz.inducedChain (CircleTopology.productVInclusion X) (n + 1) (vCrossChain X n b) =
+      crossProductEdge (PeriodTorusHigherHomology.CircleTopology.Circle) X n
+        (FirstHurewicz.pathChain CirclePaths.vCirclePath) b.1 := by
+  have hi :
+    (CircleTopology.productVInclusion X).comp
+        ((CircleTopology.productVHomeomorph X).symm :
+          C(CircleTopology.arcV × X, CircleTopology.productV X)) =
+      (⟨Subtype.val, continuous_subtype_val⟩ :
+            C(CircleTopology.arcV, (PeriodTorusHigherHomology.CircleTopology.Circle))).prodMap
+        (ContinuousMap.id X) :=
+    rfl
+  rw [vCrossChain, ← LinearMap.comp_apply, ← FirstHurewicz.inducedChain_comp, hi,
+    crossProductEdge_natural, FirstHurewicz.inducedChain_id, LinearMap.id_apply,
+    FirstHurewicz.inducedChain_pathChain]
+  rfl
+
+private theorem
+    PeriodTorusHigherHomology.arcCrossChains_inclusion_sum (X : Type) [TopologicalSpace X]
+    (n : ℕ) (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    FirstHurewicz.inducedChain (CircleTopology.productUInclusion X) (n + 1) (uCrossChain X n b) +
+        FirstHurewicz.inducedChain (CircleTopology.productVInclusion X) (n + 1)
+          (vCrossChain X n b) =
+      crossProductEdge (PeriodTorusHigherHomology.CircleTopology.Circle) X n
+        (FirstHurewicz.pathChain CirclePaths.uCirclePath +
+          FirstHurewicz.pathChain CirclePaths.vCirclePath)
+        b.1 := by rw [uCrossChain_inclusion, vCrossChain_inclusion, map_add, LinearMap.add_apply]
+
+private def PeriodTorusHigherHomology.biprodElement_mo1973_12801
+    (K L : ChainComplex (ModuleCat.{0} ℤ) ℕ) (n : ℕ) (a : K.X n) (b : L.X n) : (K ⊞ L).X n :=
+  ((CategoryTheory.Limits.biprod.inl : K ⟶ K ⊞ L).f n).hom a +
+    ((CategoryTheory.Limits.biprod.inr : L ⟶ K ⊞ L).f n).hom b
+
+private theorem PeriodTorusHigherHomology.biprod_lift_f_apply_mo1973_12802
+    {J K L : ChainComplex (ModuleCat.{0} ℤ) ℕ} (f : J ⟶ K) (g : J ⟶ L) (n : ℕ) (z : J.X n) :
+    ((CategoryTheory.Limits.biprod.lift f g).f n).hom z =
+      ((CategoryTheory.Limits.biprod.inl : K ⟶ K ⊞ L).f n).hom ((f.f n).hom z) +
+        ((CategoryTheory.Limits.biprod.inr : L ⟶ K ⊞ L).f n).hom ((g.f n).hom z) := by
+  have htotal :=
+    congrArg (fun h => h.hom (((CategoryTheory.Limits.biprod.lift f g).f n).hom z))
+      (HomologicalComplex.biprod_total_f K L n)
+  have hfst := congrArg (fun h => h.hom z) (HomologicalComplex.biprod_lift_fst_f f g n)
+  have hsnd := congrArg (fun h => h.hom z) (HomologicalComplex.biprod_lift_snd_f f g n)
+  change
+    ((CategoryTheory.Limits.biprod.fst : K ⊞ L ⟶ K).f n).hom
+        (((CategoryTheory.Limits.biprod.lift f g).f n).hom z) =
+      (f.f n).hom z at hfst
+  change
+    ((CategoryTheory.Limits.biprod.snd : K ⊞ L ⟶ L).f n).hom
+        (((CategoryTheory.Limits.biprod.lift f g).f n).hom z) =
+      (g.f n).hom z at hsnd
+  change
+    ((CategoryTheory.Limits.biprod.inl : K ⟶ K ⊞ L).f n).hom
+          (((CategoryTheory.Limits.biprod.fst : K ⊞ L ⟶ K).f n).hom
+            (((CategoryTheory.Limits.biprod.lift f g).f n).hom z)) +
+        ((CategoryTheory.Limits.biprod.inr : L ⟶ K ⊞ L).f n).hom
+          (((CategoryTheory.Limits.biprod.snd : K ⊞ L ⟶ L).f n).hom
+            (((CategoryTheory.Limits.biprod.lift f g).f n).hom z)) =
+      ((CategoryTheory.Limits.biprod.lift f g).f n).hom z at htotal
+  rw [hfst, hsnd] at htotal
+  exact htotal.symm
+
+private theorem PeriodTorusHigherHomology.biprodElement_desc_mo1973_12803
+    {K L T : ChainComplex (ModuleCat.{0} ℤ) ℕ} (f : K ⟶ T) (g : L ⟶ T) (n : ℕ) (a : K.X n)
+    (b : L.X n) :
+    ((CategoryTheory.Limits.biprod.desc f g).f n).hom (biprodElement_mo1973_12801 K L n a b) =
+      (f.f n).hom a + (g.f n).hom b := by
+  change
+    ((CategoryTheory.Limits.biprod.desc f g).f n).hom
+        (((CategoryTheory.Limits.biprod.inl : K ⟶ K ⊞ L).f n).hom a +
+          ((CategoryTheory.Limits.biprod.inr : L ⟶ K ⊞ L).f n).hom b) =
+      _
+  rw [map_add]
+  congr 1
+  · exact congrArg (fun h => h.hom a) (HomologicalComplex.biprod_inl_desc_f f g n)
+  · exact congrArg (fun h => h.hom b) (HomologicalComplex.biprod_inr_desc_f f g n)
+
+private theorem PeriodTorusHigherHomology.biprodElement_boundary_mo1973_12804
+    (K L : ChainComplex (ModuleCat.{0} ℤ) ℕ) (i j : ℕ) (a : K.X i) (b : L.X i) :
+    ((K ⊞ L).d i j).hom (biprodElement_mo1973_12801 K L i a b) =
+      biprodElement_mo1973_12801 K L j ((K.d i j).hom a) ((L.d i j).hom b) := by
+  have hK := congrArg (fun f => f.hom a) ((CategoryTheory.Limits.biprod.inl : K ⟶ K ⊞ L).comm i j)
+  have hL := congrArg (fun f => f.hom b) ((CategoryTheory.Limits.biprod.inr : L ⟶ K ⊞ L).comm i j)
+  change
+    ((K ⊞ L).d i j).hom (((CategoryTheory.Limits.biprod.inl : K ⟶ K ⊞ L).f i).hom a) =
+      ((CategoryTheory.Limits.biprod.inl : K ⟶ K ⊞ L).f j).hom ((K.d i j).hom a) at hK
+  change
+    ((K ⊞ L).d i j).hom (((CategoryTheory.Limits.biprod.inr : L ⟶ K ⊞ L).f i).hom b) =
+      ((CategoryTheory.Limits.biprod.inr : L ⟶ K ⊞ L).f j).hom ((L.d i j).hom b) at hL
+  change
+    ((K ⊞ L).d i j).hom
+        (((CategoryTheory.Limits.biprod.inl : K ⟶ K ⊞ L).f i).hom a +
+          ((CategoryTheory.Limits.biprod.inr : L ⟶ K ⊞ L).f i).hom b) =
+      _
+  rw [map_add, hK, hL]
+  rfl
+
+private theorem PeriodTorusHigherHomology.biprod_lift_eq_boundary_mo1973_12805
+    {J K L : ChainComplex (ModuleCat.{0} ℤ) ℕ} (f : J ⟶ K) (g : J ⟶ L) (i j : ℕ) (a : K.X i)
+    (b : L.X i) (z : J.X j) (ha : (K.d i j).hom a = (f.f j).hom z)
+    (hb : (L.d i j).hom b = (g.f j).hom z) :
+    ((CategoryTheory.Limits.biprod.lift f g).f j).hom z =
+      ((K ⊞ L).d i j).hom (biprodElement_mo1973_12801 K L i a b) := by
+  have hlift := biprod_lift_f_apply_mo1973_12802 f g j z
+  have hboundary := biprodElement_boundary_mo1973_12804 K L i j a b
+  have hab := congrArg₂ (biprodElement_mo1973_12801 K L j) ha hb
+  exact hlift.trans (hab.symm.trans hboundary.symm)
+
+private def
+    PeriodTorusHigherHomology.twoChainMiddle {X : Type} [TopologicalSpace X] (U V : Set X) (n : ℕ)
+    (a : FirstHurewicz.Chains U (n + 1)) (b : FirstHurewicz.Chains V (n + 1)) :
+    (SingularMayerVietoris.middleComplex U V).X (n + 1) :=
+  biprodElement_mo1973_12801 (FirstHurewicz.singularComplex U) (FirstHurewicz.singularComplex V)
+    (n + 1) a b
+
+private theorem PeriodTorusHigherHomology.twoChainMiddle_rightMap {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) (a : FirstHurewicz.Chains U (n + 1))
+    (b : FirstHurewicz.Chains V (n + 1)) :
+    ((SingularMayerVietoris.rightMap U V).f (n + 1)).hom (twoChainMiddle U V n a b) =
+      ((SingularMayerVietoris.toSmallLeft U V).f (n + 1)).hom a +
+        ((SingularMayerVietoris.toSmallRight U V).f (n + 1)).hom b :=
+  biprodElement_desc_mo1973_12803 (SingularMayerVietoris.toSmallLeft U V)
+    (SingularMayerVietoris.toSmallRight U V) (n + 1) a b
+
+private theorem PeriodTorusHigherHomology.twoChainMiddle_boundary {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) (a : FirstHurewicz.Chains U (n + 1))
+    (b : FirstHurewicz.Chains V (n + 1))
+    (z :
+      SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex (U ∩ V : Set X))
+        n)
+    (ha :
+      ((FirstHurewicz.singularComplex U).d (n + 1) n).hom a =
+        FirstHurewicz.inducedChain (ContinuousMap.inclusion (Set.inter_subset_left : U ∩ V ⊆ U)) n
+          z.1)
+    (hb :
+      ((FirstHurewicz.singularComplex V).d (n + 1) n).hom b =
+        -FirstHurewicz.inducedChain (ContinuousMap.inclusion (Set.inter_subset_right : U ∩ V ⊆ V))
+            n z.1) :
+    ((SingularMayerVietoris.leftMap U V).f n).hom z.1 =
+      ((SingularMayerVietoris.middleComplex U V).d (n + 1) n).hom (twoChainMiddle U V n a b) :=
+  biprod_lift_eq_boundary_mo1973_12805 (SingularMayerVietoris.intersectionToLeft U V)
+    (-(SingularMayerVietoris.intersectionToRight U V)) (n + 1) n a b z.1 ha hb
+
+private theorem
+    PeriodTorusHigherHomology.twoChainSmallCycle_condition {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) (a : FirstHurewicz.Chains U (n + 1))
+    (b : FirstHurewicz.Chains V (n + 1))
+    (z :
+      SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex (U ∩ V : Set X))
+        n)
+    (ha :
+      ((FirstHurewicz.singularComplex U).d (n + 1) n).hom a =
+        FirstHurewicz.inducedChain (ContinuousMap.inclusion (Set.inter_subset_left : U ∩ V ⊆ U)) n
+          z.1)
+    (hb :
+      ((FirstHurewicz.singularComplex V).d (n + 1) n).hom b =
+        -FirstHurewicz.inducedChain (ContinuousMap.inclusion (Set.inter_subset_right : U ∩ V ⊆ V))
+            n z.1) :
+    ((SingularMayerVietoris.smallComplex U V).d (n + 1) n).hom
+        (((SingularMayerVietoris.rightMap U V).f (n + 1)).hom (twoChainMiddle U V n a b)) =
+      0 := by
+  have hcomm :=
+    congrArg (fun f => f.hom (twoChainMiddle U V n a b))
+      ((SingularMayerVietoris.rightMap U V).comm (n + 1) n)
+  have hzero := congrArg (fun f => (f.f n).hom z.1) (SingularMayerVietoris.leftMap_rightMap U V)
+  calc
+    _ =
+        ((SingularMayerVietoris.rightMap U V).f n).hom
+          (((SingularMayerVietoris.middleComplex U V).d (n + 1) n).hom
+            (twoChainMiddle U V n a b)) :=
+      hcomm
+    _ =
+        ((SingularMayerVietoris.rightMap U V).f n).hom
+          (((SingularMayerVietoris.leftMap U V).f n).hom z.1) :=
+      (congrArg ((SingularMayerVietoris.rightMap U V).f n).hom
+        (twoChainMiddle_boundary U V n a b z ha hb).symm)
+    _ = 0 := hzero
+
+private def
+    PeriodTorusHigherHomology.twoChainSmallCycle {X : Type} [TopologicalSpace X] (U V : Set X)
+    (n : ℕ) (a : FirstHurewicz.Chains U (n + 1)) (b : FirstHurewicz.Chains V (n + 1))
+    (z :
+      SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex (U ∩ V : Set X))
+        n)
+    (ha :
+      ((FirstHurewicz.singularComplex U).d (n + 1) n).hom a =
+        FirstHurewicz.inducedChain (ContinuousMap.inclusion (Set.inter_subset_left : U ∩ V ⊆ U)) n
+          z.1)
+    (hb :
+      ((FirstHurewicz.singularComplex V).d (n + 1) n).hom b =
+        -FirstHurewicz.inducedChain (ContinuousMap.inclusion (Set.inter_subset_right : U ∩ V ⊆ V))
+            n z.1) :
+    SingularMayerVietoris.ModuleHomology.Cycle (SingularMayerVietoris.smallComplex U V) (n + 1) :=
+  SingularMayerVietoris.ModuleHomology.mkCycle (SingularMayerVietoris.smallComplex U V) (n + 1)
+    (((SingularMayerVietoris.rightMap U V).f (n + 1)).hom (twoChainMiddle U V n a b))
+    (by
+      rw [Nat.add_sub_cancel]
+      exact twoChainSmallCycle_condition U V n a b z ha hb)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.twoChainSmallCycle_val {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) (a : FirstHurewicz.Chains U (n + 1))
+    (b : FirstHurewicz.Chains V (n + 1))
+    (z :
+      SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex (U ∩ V : Set X))
+        n)
+    (ha :
+      ((FirstHurewicz.singularComplex U).d (n + 1) n).hom a =
+        FirstHurewicz.inducedChain (ContinuousMap.inclusion (Set.inter_subset_left : U ∩ V ⊆ U)) n
+          z.1)
+    (hb :
+      ((FirstHurewicz.singularComplex V).d (n + 1) n).hom b =
+        -FirstHurewicz.inducedChain (ContinuousMap.inclusion (Set.inter_subset_right : U ∩ V ⊆ V))
+            n z.1) :
+    (twoChainSmallCycle U V n a b z ha hb).1 =
+      ((SingularMayerVietoris.rightMap U V).f (n + 1)).hom (twoChainMiddle U V n a b) :=
+  rfl
+
+private theorem
+    PeriodTorusHigherHomology.twoChainSmallCycle_ambient_val {X : Type} [TopologicalSpace X]
+    (U V : Set X) (n : ℕ) (a : FirstHurewicz.Chains U (n + 1))
+    (b : FirstHurewicz.Chains V (n + 1))
+    (z :
+      SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex (U ∩ V : Set X))
+        n)
+    (ha :
+      ((FirstHurewicz.singularComplex U).d (n + 1) n).hom a =
+        FirstHurewicz.inducedChain (ContinuousMap.inclusion (Set.inter_subset_left : U ∩ V ⊆ U)) n
+          z.1)
+    (hb :
+      ((FirstHurewicz.singularComplex V).d (n + 1) n).hom b =
+        -FirstHurewicz.inducedChain (ContinuousMap.inclusion (Set.inter_subset_right : U ∩ V ⊆ V))
+            n z.1) :
+    (SingularMayerVietoris.ModuleHomology.mapCycles (SingularMayerVietoris.smallInclusion U V)
+          (n + 1) (twoChainSmallCycle U V n a b z ha hb)).1 =
+      FirstHurewicz.inducedChain (SingularMayerVietoris.subtypeInclusion U) (n + 1) a +
+        FirstHurewicz.inducedChain (SingularMayerVietoris.subtypeInclusion V) (n + 1) b := by
+  rw [SingularMayerVietoris.ModuleHomology.mapCycles_val, twoChainSmallCycle_val,
+    twoChainMiddle_rightMap, map_add]
+  have hU :=
+    congrArg (fun f => (f.f (n + 1)).hom a) (SingularMayerVietoris.toSmallLeft_inclusion U V)
+  have hV :=
+    congrArg (fun f => (f.f (n + 1)).hom b) (SingularMayerVietoris.toSmallRight_inclusion U V)
+  exact congrArg₂ (· + ·) hU hV
+
+private theorem
+    PeriodTorusHigherHomology.connectingHomomorphism_twoChain {X : Type} [TopologicalSpace X]
+    (U V : Set X) (hU : IsOpen U) (hV : IsOpen V) (hcover : U ∪ V = Set.univ) (n : ℕ)
+    (a : FirstHurewicz.Chains U (n + 1)) (b : FirstHurewicz.Chains V (n + 1))
+    (z :
+      SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex (U ∩ V : Set X))
+        n)
+    (ha :
+      ((FirstHurewicz.singularComplex U).d (n + 1) n).hom a =
+        FirstHurewicz.inducedChain (ContinuousMap.inclusion (Set.inter_subset_left : U ∩ V ⊆ U)) n
+          z.1)
+    (hb :
+      ((FirstHurewicz.singularComplex V).d (n + 1) n).hom b =
+        -FirstHurewicz.inducedChain (ContinuousMap.inclusion (Set.inter_subset_right : U ∩ V ⊆ V))
+            n z.1) :
+    SingularMayerVietoris.connectingHomomorphism U V hU hV hcover n
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) (n + 1)
+          (SingularMayerVietoris.ModuleHomology.mapCycles
+            (SingularMayerVietoris.smallInclusion U V) (n + 1)
+            (twoChainSmallCycle U V n a b z ha hb))) =
+      SingularMayerVietoris.ModuleHomology.cycleClass
+        (FirstHurewicz.singularComplex (U ∩ V : Set X)) n z :=
+  connectingHomomorphism_cycleClass U V hU hV hcover n (twoChainSmallCycle U V n a b z ha hb)
+    (twoChainMiddle U V n a b) rfl z (twoChainMiddle_boundary U V n a b z ha hb)
+
+private def
+    PeriodTorusHigherHomology.positiveCircleSmallCycle (X : Type) [TopologicalSpace X] (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    SingularMayerVietoris.ModuleHomology.Cycle
+      (SingularMayerVietoris.smallComplex (CircleTopology.productU X) (CircleTopology.productV X))
+      (n + 1) :=
+  twoChainSmallCycle (CircleTopology.productU X) (CircleTopology.productV X) n (uCrossChain X n b)
+    (vCrossChain X n b) (intersectionDifferenceCycle X n b) (uCrossChain_boundary X n b)
+    (vCrossChain_boundary X n b)
+
+private theorem PeriodTorusHigherHomology.positiveCircleSmallCycle_ambient_val (X : Type)
+    [TopologicalSpace X] (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    (SingularMayerVietoris.ModuleHomology.mapCycles
+          (SingularMayerVietoris.smallInclusion (CircleTopology.productU X)
+            (CircleTopology.productV X))
+          (n + 1) (positiveCircleSmallCycle X n b)).1 =
+      crossProductEdge (PeriodTorusHigherHomology.CircleTopology.Circle) X n
+        (FirstHurewicz.pathChain CirclePaths.uCirclePath +
+          FirstHurewicz.pathChain CirclePaths.vCirclePath)
+        b.1 :=
+  (twoChainSmallCycle_ambient_val (CircleTopology.productU X) (CircleTopology.productV X) n
+        (uCrossChain X n b) (vCrossChain X n b) (intersectionDifferenceCycle X n b)
+        (uCrossChain_boundary X n b) (vCrossChain_boundary X n b)).trans
+    (arcCrossChains_inclusion_sum X n b)
+
+private theorem PeriodTorusHigherHomology.positiveCircleSmallCycle_ambient_eq (X : Type)
+    [TopologicalSpace X] (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    SingularMayerVietoris.ModuleHomology.mapCycles
+        (SingularMayerVietoris.smallInclusion (CircleTopology.productU X)
+          (CircleTopology.productV X))
+        (n + 1) (positiveCircleSmallCycle X n b) =
+      crossProductCycles (PeriodTorusHigherHomology.CircleTopology.Circle) X n
+        CirclePaths.arcSumCycle b := by
+  apply Subtype.ext
+  exact positiveCircleSmallCycle_ambient_val X n b
+
+private theorem PeriodTorusHigherHomology.positiveCircleSmallCycle_ambient_class (X : Type)
+    [TopologicalSpace X] (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    SingularMayerVietoris.ModuleHomology.cycleClass
+        (FirstHurewicz.singularComplex ((PeriodTorusHigherHomology.CircleTopology.Circle) × X))
+        (n + 1)
+        (SingularMayerVietoris.ModuleHomology.mapCycles
+          (SingularMayerVietoris.smallInclusion (CircleTopology.productU X)
+            (CircleTopology.productV X))
+          (n + 1) (positiveCircleSmallCycle X n b)) =
+      positiveCircleCross X n
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n b) :=
+  by
+  rw [positiveCircleSmallCycle_ambient_eq]
+  exact (positiveCircleCross_arcSum_cycleClass X n b).symm
+
+private theorem PeriodTorusHigherHomology.circleConnecting_positiveCircleCross_cycleClass (X : Type)
+    [TopologicalSpace X] (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    circleMayerVietorisConnecting X n
+        (positiveCircleCross X n
+          (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n
+            b)) =
+      SingularMayerVietoris.ModuleHomology.cycleClass
+        (FirstHurewicz.singularComplex
+          (CircleTopology.productU X ∩ CircleTopology.productV X :
+            Set ((PeriodTorusHigherHomology.CircleTopology.Circle) × X)))
+        n (intersectionDifferenceCycle X n b) := by
+  rw [← positiveCircleSmallCycle_ambient_class]
+  exact
+    connectingHomomorphism_twoChain (CircleTopology.productU X) (CircleTopology.productV X)
+      (CircleTopology.productU_open X) (CircleTopology.productV_open X)
+      (CircleTopology.product_cover X) n (uCrossChain X n b) (vCrossChain X n b)
+      (intersectionDifferenceCycle X n b) (uCrossChain_boundary X n b)
+      (vCrossChain_boundary X n b)
+
+private theorem PeriodTorusHigherHomology.circleBoundaryCoordinates_positiveCircleCross_cycleClass
+    (X : Type) [TopologicalSpace X] (n : ℕ)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) n) :
+    circleBoundaryCoordinates X n
+        (positiveCircleCross X n
+          (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n
+            b)) =
+      (-SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n b,
+        SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n b) := by
+  change
+    productIntersectionHomologyEquiv X n
+        (circleMayerVietorisConnecting X n
+          (positiveCircleCross X n
+            (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) n
+              b))) =
+      _
+  rw [circleConnecting_positiveCircleCross_cycleClass]
+  exact intersectionDifferenceCycle_class_coordinates X n b
+
+private theorem PeriodTorusHigherHomology.circleBoundaryCoordinates_positiveCircleCross (X : Type)
+    [TopologicalSpace X] (n : ℕ) (b : SingularMayerVietoris.SingularHomology X n) :
+    circleBoundaryCoordinates X n (positiveCircleCross X n b) = (-b, b) := by
+  obtain ⟨c, rfl⟩ :=
+    SingularMayerVietoris.ModuleHomology.cycleClass_surjective (FirstHurewicz.singularComplex X) n
+      b
+  exact circleBoundaryCoordinates_positiveCircleCross_cycleClass X n c
+
+private theorem PeriodTorusHigherHomology.circleBoundary_positiveCircleCross (X : Type)
+    [TopologicalSpace X] (n : ℕ) (b : SingularMayerVietoris.SingularHomology X n) :
+    circleBoundary X n (positiveCircleCross X n b) = b := by
+  rw [circleBoundary_apply, circleBoundaryCoordinates_positiveCircleCross]
+  exact neg_neg b
+
+private def PeriodTorusHigherHomology.circleProductMap {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) :
+    C((PeriodTorusHigherHomology.CircleTopology.Circle) × X,
+      (PeriodTorusHigherHomology.CircleTopology.Circle) × Y) :=
+  ⟨fun z => (z.1, f z.2), continuous_fst.prodMk (f.continuous.comp continuous_snd)⟩
+
+private def PeriodTorusHigherHomology.intersectionProductMap {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) :
+    C(↥(CircleTopology.productU X ∩ CircleTopology.productV X),
+      ↥(CircleTopology.productU Y ∩ CircleTopology.productV Y)) :=
+  ⟨fun z => ⟨circleProductMap f z.val, z.property⟩,
+    ((circleProductMap f).continuous.comp continuous_subtype_val).subtype_mk _⟩
+
+private theorem
+    PeriodTorusHigherHomology.circleProductMap_projection {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) :
+    (CircleTopology.productProjection Y).comp (circleProductMap f) =
+      f.comp (CircleTopology.productProjection X) :=
+  rfl
+
+private theorem PeriodTorusHigherHomology.intersectionProductMap_homotopyEquiv {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : C(X, Y)) :
+    (CircleTopology.productIntersectionHomotopyEquiv Y).toFun.comp (intersectionProductMap f) =
+      (CircleTopology.sumContinuousMap f f).comp
+        (CircleTopology.productIntersectionHomotopyEquiv X).toFun := by
+  apply ContinuousMap.ext
+  intro z
+  let c : ↥(CircleTopology.arcU ∩ CircleTopology.arcV) := ⟨z.val.1, z.property⟩
+  change
+    Sum.map (fun t : Set.Ioo (0 : ℝ) (1 / 2) × Y => t.2)
+        (fun t : Set.Ioo (1 / 2 : ℝ) 1 × Y => t.2)
+        (Homeomorph.sumProdDistrib (CircleTopology.intersectionHomeomorph c, f z.val.2)) =
+      Sum.map f f
+        (Sum.map (fun t : Set.Ioo (0 : ℝ) (1 / 2) × X => t.2)
+          (fun t : Set.Ioo (1 / 2 : ℝ) 1 × X => t.2)
+          (Homeomorph.sumProdDistrib (CircleTopology.intersectionHomeomorph c, z.val.2)))
+  cases h : CircleTopology.intersectionHomeomorph c <;> rfl
+
+private theorem PeriodTorusHigherHomology.circleProjectionHomology_naturality {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : C(X, Y)) (n : ℕ) :
+    (circleProjectionHomology Y n).comp
+        (SingularMayerVietoris.singularHomologyMap (circleProductMap f) n) =
+      (SingularMayerVietoris.singularHomologyMap f n).comp (circleProjectionHomology X n) := by
+  rw [← singularHomologyMap_comp, circleProductMap_projection, singularHomologyMap_comp]
+
+private theorem
+    PeriodTorusHigherHomology.sumHomologyEquiv_naturality {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] {X' Y' : Type} [TopologicalSpace X'] [TopologicalSpace Y'] (f : C(X, X'))
+    (g : C(Y, Y')) (n : ℕ) (a : SingularMayerVietoris.SingularHomology (X ⊕ Y) n) :
+    sumHomologyEquiv X' Y' n
+        (SingularMayerVietoris.singularHomologyMap (CircleTopology.sumContinuousMap f g) n a) =
+      (SingularMayerVietoris.singularHomologyMap f n (sumHomologyEquiv X Y n a).1,
+        SingularMayerVietoris.singularHomologyMap g n (sumHomologyEquiv X Y n a).2) := by
+  have hsum :
+    CircleTopology.sumContinuousMap f g =
+      sumElimMap ((sumInlMap X' Y').comp f) ((sumInrMap X' Y').comp g) := by
+    ext x
+    cases x <;> rfl
+  simp only [hsum, sumHomologyEquiv_sumElim, singularHomologyMap_comp, LinearMap.comp_apply,
+    map_add, sumHomologyEquiv_inl, sumHomologyEquiv_inr, Prod.mk_add_mk, add_zero, zero_add]
+
+private theorem PeriodTorusHigherHomology.productIntersectionHomologyEquiv_naturality {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : C(X, Y)) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        (CircleTopology.productU X ∩ CircleTopology.productV X :
+          Set ((PeriodTorusHigherHomology.CircleTopology.Circle) × X))
+        n) :
+    productIntersectionHomologyEquiv Y n
+        (SingularMayerVietoris.singularHomologyMap (intersectionProductMap f) n a) =
+      (SingularMayerVietoris.singularHomologyMap f n (productIntersectionHomologyEquiv X n a).1,
+        SingularMayerVietoris.singularHomologyMap f n
+          (productIntersectionHomologyEquiv X n a).2) := by
+  have h :=
+    congrArg (fun g => SingularMayerVietoris.singularHomologyMap g n)
+      (intersectionProductMap_homotopyEquiv f)
+  rw [singularHomologyMap_comp, singularHomologyMap_comp] at h
+  calc
+    _ =
+        sumHomologyEquiv Y Y n
+          (SingularMayerVietoris.singularHomologyMap (CircleTopology.sumContinuousMap f f) n
+            (SingularMayerVietoris.singularHomologyMap
+              (CircleTopology.productIntersectionHomotopyEquiv X).toFun n a)) :=
+      congrArg (sumHomologyEquiv Y Y n) (LinearMap.congr_fun h a)
+    _ = _ := sumHomologyEquiv_naturality f f n _
+
+private theorem PeriodTorusHigherHomology.circleProductMap_mapsToU {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) :
+    Set.MapsTo (circleProductMap f) (CircleTopology.productU X) (CircleTopology.productU Y) :=
+  fun _ h => h
+
+private theorem PeriodTorusHigherHomology.circleProductMap_mapsToV {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) :
+    Set.MapsTo (circleProductMap f) (CircleTopology.productV X) (CircleTopology.productV Y) :=
+  fun _ h => h
+
+private theorem PeriodTorusHigherHomology.circleProductIntersectionRestriction_eq {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : C(X, Y)) :
+    SingularMayerVietoris.intersectionRestriction (circleProductMap f) (CircleTopology.productU X)
+        (CircleTopology.productV X) (CircleTopology.productU Y) (CircleTopology.productV Y)
+        (circleProductMap_mapsToU f) (circleProductMap_mapsToV f) =
+      intersectionProductMap f :=
+  rfl
+
+private theorem PeriodTorusHigherHomology.circleMayerVietorisConnecting_naturality {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : C(X, Y)) (n : ℕ) :
+    (SingularMayerVietoris.singularHomologyMap (intersectionProductMap f) n).comp
+        (circleMayerVietorisConnecting X n) =
+      (circleMayerVietorisConnecting Y n).comp
+        (SingularMayerVietoris.singularHomologyMap (circleProductMap f) (n + 1)) := by
+  have h :=
+    SingularMayerVietoris.connectingHomomorphism_naturality (circleProductMap f)
+      (CircleTopology.productU X) (CircleTopology.productV X) (CircleTopology.productU Y)
+      (CircleTopology.productV Y) (circleProductMap_mapsToU f) (circleProductMap_mapsToV f)
+      (CircleTopology.productU_open X) (CircleTopology.productV_open X)
+      (CircleTopology.product_cover X) (CircleTopology.productU_open Y)
+      (CircleTopology.productV_open Y) (CircleTopology.product_cover Y) n
+  rw [circleProductIntersectionRestriction_eq] at h
+  exact h
+
+private theorem PeriodTorusHigherHomology.circleBoundaryCoordinates_naturality {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : C(X, Y)) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) × X) (n + 1)) :
+    circleBoundaryCoordinates Y n
+        (SingularMayerVietoris.singularHomologyMap (circleProductMap f) (n + 1) a) =
+      (SingularMayerVietoris.singularHomologyMap f n (circleBoundaryCoordinates X n a).1,
+        SingularMayerVietoris.singularHomologyMap f n (circleBoundaryCoordinates X n a).2) := by
+  have h := LinearMap.congr_fun (circleMayerVietorisConnecting_naturality f n) a
+  change
+    SingularMayerVietoris.singularHomologyMap (intersectionProductMap f) n
+        (circleMayerVietorisConnecting X n a) =
+      circleMayerVietorisConnecting Y n
+        (SingularMayerVietoris.singularHomologyMap (circleProductMap f) (n + 1) a) at h
+  change
+    productIntersectionHomologyEquiv Y n
+        (circleMayerVietorisConnecting Y n
+          (SingularMayerVietoris.singularHomologyMap (circleProductMap f) (n + 1) a)) =
+      _
+  rw [← h]
+  exact productIntersectionHomologyEquiv_naturality f n (circleMayerVietorisConnecting X n a)
+
+private theorem
+    PeriodTorusHigherHomology.circleBoundary_naturality {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (f : C(X, Y)) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) × X) (n + 1)) :
+    circleBoundary Y n
+        (SingularMayerVietoris.singularHomologyMap (circleProductMap f) (n + 1) a) =
+      SingularMayerVietoris.singularHomologyMap f n (circleBoundary X n a) := by
+  change
+    -(circleBoundaryCoordinates Y n
+            (SingularMayerVietoris.singularHomologyMap (circleProductMap f) (n + 1) a)).1 =
+      SingularMayerVietoris.singularHomologyMap f n (-(circleBoundaryCoordinates X n a).1)
+  rw [circleBoundaryCoordinates_naturality, map_neg]
+
+private theorem PeriodTorusHigherHomology.circleProductHomologyEquiv_naturality {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : C(X, Y)) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology
+        ((PeriodTorusHigherHomology.CircleTopology.Circle) × X) (n + 1)) :
+    circleProductHomologyEquiv Y n
+        (SingularMayerVietoris.singularHomologyMap (circleProductMap f) (n + 1) a) =
+      (SingularMayerVietoris.singularHomologyMap f (n + 1) (circleProductHomologyEquiv X n a).1,
+        SingularMayerVietoris.singularHomologyMap f n (circleProductHomologyEquiv X n a).2) := by
+  apply Prod.ext
+  · exact LinearMap.congr_fun (circleProjectionHomology_naturality f (n + 1)) a
+  · exact circleBoundary_naturality f n a
+
+private theorem PeriodTorusHigherHomology.circleProductHomologyEquiv_symm_naturality {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (f : C(X, Y)) (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology X (n + 1) ×
+        SingularMayerVietoris.SingularHomology X n) :
+    SingularMayerVietoris.singularHomologyMap (circleProductMap f) (n + 1)
+        ((circleProductHomologyEquiv X n).symm a) =
+      (circleProductHomologyEquiv Y n).symm
+        (SingularMayerVietoris.singularHomologyMap f (n + 1) a.1,
+          SingularMayerVietoris.singularHomologyMap f n a.2) := by
+  apply (circleProductHomologyEquiv Y n).injective
+  rw [circleProductHomologyEquiv_naturality, LinearEquiv.apply_symm_apply,
+    LinearEquiv.apply_symm_apply]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductCycles_natural {X Y X' Y' : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace X'] [TopologicalSpace Y']
+    (f : C(X, X')) (g : C(Y, Y')) (n : ℕ)
+    (a : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 1)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex Y) n) :
+    SingularMayerVietoris.ModuleHomology.mapCycles (FirstHurewicz.singularChainMap (f.prodMap g))
+        (n + 1) (crossProductCycles X Y n a b) =
+      crossProductCycles X' Y' n
+        (SingularMayerVietoris.ModuleHomology.mapCycles (FirstHurewicz.singularChainMap f) 1 a)
+        (SingularMayerVietoris.ModuleHomology.mapCycles (FirstHurewicz.singularChainMap g) n b) :=
+  by
+  apply Subtype.ext
+  simp only [SingularMayerVietoris.ModuleHomology.mapCycles_val, crossProductCycles_val]
+  exact crossProductEdge_natural f g n a.1 b.1
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductHomology_natural {X Y X' Y' : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace X'] [TopologicalSpace Y']
+    (f : C(X, X')) (g : C(Y, Y')) (n : ℕ) (a : (FirstHurewicz.singularComplex X).homology 1)
+    (b : (FirstHurewicz.singularComplex Y).homology n) :
+    (HomologicalComplex.homologyMap (FirstHurewicz.singularChainMap (f.prodMap g)) (n + 1)).hom
+        (crossProductHomology X Y n a b) =
+      crossProductHomology X' Y' n
+        ((HomologicalComplex.homologyMap (FirstHurewicz.singularChainMap f) 1).hom a)
+        ((HomologicalComplex.homologyMap (FirstHurewicz.singularChainMap g) n).hom b) := by
+  obtain ⟨a, rfl⟩ :=
+    SingularMayerVietoris.ModuleHomology.cycleClass_surjective (FirstHurewicz.singularComplex X) 1
+      a
+  obtain ⟨b, rfl⟩ :=
+    SingularMayerVietoris.ModuleHomology.cycleClass_surjective (FirstHurewicz.singularComplex Y) n
+      b
+  rw [crossProductHomology_cycleClass,
+    SingularMayerVietoris.ModuleHomology.homologyMap_cycleClass,
+    SingularMayerVietoris.ModuleHomology.homologyMap_cycleClass,
+    SingularMayerVietoris.ModuleHomology.homologyMap_cycleClass, crossProductHomology_cycleClass,
+    crossProductCycles_natural]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductHomology_snd {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (n : ℕ) (a : SingularMayerVietoris.SingularHomology X 1)
+    (b : SingularMayerVietoris.SingularHomology Y n) :
+    SingularMayerVietoris.singularHomologyMap (ContinuousMap.snd : C(X × Y, Y)) (n + 1)
+        (crossProductHomology X Y n a b) =
+      0 := by
+  let : Subsingleton (SingularMayerVietoris.SingularHomology Unit 1) :=
+    point_homology_subsingleton 1 (by decide)
+  let f : C(X, Unit) := ContinuousMap.const X ()
+  have hz : SingularMayerVietoris.singularHomologyMap f 1 a = 0 := Subsingleton.elim _ _
+  have hn := crossProductHomology_natural f (ContinuousMap.id Y) n a b
+  change
+    SingularMayerVietoris.singularHomologyMap (f.prodMap (ContinuousMap.id Y)) (n + 1)
+        (crossProductHomology X Y n a b) =
+      crossProductHomology Unit Y n (SingularMayerVietoris.singularHomologyMap f 1 a)
+        (SingularMayerVietoris.singularHomologyMap (ContinuousMap.id Y) n b) at hn
+  rw [hz, map_zero, LinearMap.zero_apply] at hn
+  calc
+    _ =
+        SingularMayerVietoris.singularHomologyMap (ContinuousMap.snd : C(Unit × Y, Y)) (n + 1)
+          (SingularMayerVietoris.singularHomologyMap (f.prodMap (ContinuousMap.id Y)) (n + 1)
+            (crossProductHomology X Y n a b)) := by
+      exact
+        LinearMap.congr_fun
+          (singularHomologyMap_comp (f.prodMap (ContinuousMap.id Y))
+            (ContinuousMap.snd : C(Unit × Y, Y)) (n + 1))
+          (crossProductHomology X Y n a b)
+    _ = 0 := by rw [hn, map_zero]
+
+@[simp]
+private theorem PeriodTorusHigherHomology.circleProjection_positiveCircleCross (X : Type)
+    [TopologicalSpace X] (n : ℕ) (b : SingularMayerVietoris.SingularHomology X n) :
+    circleProjectionHomology X (n + 1) (positiveCircleCross X n b) = 0 :=
+  crossProductHomology_snd n (FirstHurewicz.loopHomologyClass CirclePaths.positiveLoop) b
+
+private theorem PeriodTorusHigherHomology.circleProductHomologyEquiv_positiveCircleCross (X : Type)
+    [TopologicalSpace X] (n : ℕ) (b : SingularMayerVietoris.SingularHomology X n) :
+    circleProductHomologyEquiv X n (positiveCircleCross X n b) = (0, b) := by
+  apply Prod.ext
+  · exact circleProjection_positiveCircleCross X n b
+  · exact circleBoundary_positiveCircleCross X n b
+
+private theorem
+    PeriodTorusHigherHomology.positiveCircleCross_eq_symm (X : Type) [TopologicalSpace X]
+    (n : ℕ) (b : SingularMayerVietoris.SingularHomology X n) :
+    positiveCircleCross X n b = (circleProductHomologyEquiv X n).symm (0, b) := by
+  apply (circleProductHomologyEquiv X n).injective
+  rw [circleProductHomologyEquiv_positiveCircleCross, LinearEquiv.apply_symm_apply]
+
+private theorem
+    PeriodTorusHigherHomology.circleProductHomologyEquiv_symm_eq_section_add_cross (X : Type)
+    [TopologicalSpace X] (n : ℕ)
+    (a :
+      SingularMayerVietoris.SingularHomology X (n + 1) ×
+        SingularMayerVietoris.SingularHomology X n) :
+    (circleProductHomologyEquiv X n).symm a =
+      circleSectionHomology X (n + 1) a.1 + positiveCircleCross X n a.2 := by
+  apply (circleProductHomologyEquiv X n).injective
+  rw [LinearEquiv.apply_symm_apply, map_add, circleProductHomologyEquiv_section,
+    circleProductHomologyEquiv_positiveCircleCross]
+  exact Prod.ext (add_zero _).symm (zero_add _).symm
+
+private theorem
+    PeriodTorusHigherHomology.positiveCircleCross_naturality {X : Type} [TopologicalSpace X]
+    {Y : Type} [TopologicalSpace Y] (f : C(X, Y)) (n : ℕ)
+    (b : SingularMayerVietoris.SingularHomology X n) :
+    SingularMayerVietoris.singularHomologyMap (circleProductMap f) (n + 1)
+        (positiveCircleCross X n b) =
+      positiveCircleCross Y n (SingularMayerVietoris.singularHomologyMap f n b) := by
+  calc
+    _ =
+        SingularMayerVietoris.singularHomologyMap (circleProductMap f) (n + 1)
+          ((circleProductHomologyEquiv X n).symm (0, b)) :=
+      congrArg (SingularMayerVietoris.singularHomologyMap (circleProductMap f) (n + 1))
+        (positiveCircleCross_eq_symm X n b)
+    _ =
+        (circleProductHomologyEquiv Y n).symm
+          (0, SingularMayerVietoris.singularHomologyMap f n b) := by
+      simpa only [map_zero] using circleProductHomologyEquiv_symm_naturality f n (0, b)
+    _ = _ :=
+      (positiveCircleCross_eq_symm Y n (SingularMayerVietoris.singularHomologyMap f n b)).symm
+
+private abbrev PeriodTorusHigherHomology.binomialModule (r n : ℕ) :=
+  Fin (r.choose n) → ℤ
+
+private def PeriodTorusHigherHomology.binomialPascalIndexEquiv (r n : ℕ) :
+    Fin ((r + 1).choose (n + 1)) ≃ Fin (r.choose (n + 1)) ⊕ Fin (r.choose n) :=
+  (finCongr ((Nat.choose_succ_succ' r n).trans (Nat.add_comm _ _))).trans finSumFinEquiv.symm
+
+private def PeriodTorusHigherHomology.binomialModuleSuccEquiv (r n : ℕ) :
+    binomialModule (r + 1) (n + 1) ≃ₗ[ℤ] binomialModule r (n + 1) × binomialModule r n :=
+  (LinearEquiv.piCongrLeft' ℤ (fun _ => ℤ) (binomialPascalIndexEquiv r n)).trans
+    (LinearEquiv.sumArrowLequivProdArrow _ _ ℤ ℤ)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.binomialModuleSuccEquiv_apply_fst (r n : ℕ)
+    (x : binomialModule (r + 1) (n + 1)) (i : Fin (r.choose (n + 1))) :
+    (binomialModuleSuccEquiv r n x).1 i = x ((binomialPascalIndexEquiv r n).symm (Sum.inl i)) :=
+  rfl
+
+@[simp]
+private theorem PeriodTorusHigherHomology.binomialModuleSuccEquiv_apply_snd (r n : ℕ)
+    (x : binomialModule (r + 1) (n + 1)) (i : Fin (r.choose n)) :
+    (binomialModuleSuccEquiv r n x).2 i = x ((binomialPascalIndexEquiv r n).symm (Sum.inr i)) :=
+  rfl
+
+private def
+    PeriodTorusHigherHomology.integerBinomialZeroEquiv (r : ℕ) : ℤ ≃ₗ[ℤ] binomialModule r 0 :=
+  (LinearEquiv.funUnique (Fin 1) ℤ ℤ).symm.trans
+    (LinearEquiv.piCongrLeft' ℤ (fun _ => ℤ) (finCongr (Nat.choose_zero_right r)).symm)
+
+private theorem PeriodTorusHigherHomology.binomialModule_finrank (r n : ℕ) :
+    Module.finrank ℤ (binomialModule r n) = r.choose n :=
+  Module.finrank_fin_fun ℤ
+
+private theorem PeriodTorusHigherHomology.binomialModule_subsingleton_of_lt {r n : ℕ} (h : r < n) :
+    Subsingleton (binomialModule r n) := by
+  change Subsingleton (Fin (r.choose n) → ℤ)
+  rw [Nat.choose_eq_zero_of_lt h]
+  infer_instance
+
+private instance PeriodTorusHigherHomology.binomialModule_zero_succ_subsingleton (n : ℕ) :
+    Subsingleton (binomialModule 0 (n + 1)) :=
+  binomialModule_subsingleton_of_lt (Nat.zero_lt_succ n)
+
+private theorem PeriodTorusHigherHomology.binomialModule_eq_zero_of_lt {r n : ℕ} (h : r < n)
+    (x : binomialModule r n) : x = 0 :=
+  @Subsingleton.elim (binomialModule r n) (binomialModule_subsingleton_of_lt h) x 0
+
+private def PeriodTorusHigherHomology.productTorusHomologyEquiv :
+    (r n : ℕ) → SingularMayerVietoris.SingularHomology (ProductTorus r) n ≃ₗ[ℤ] binomialModule r n
+  | r, 0 => (connectedHomologyZeroEquiv (ProductTorus r)).trans (integerBinomialZeroEquiv r)
+  | 0, n + 1 =>
+    by
+    letI := totallyDisconnected_homology_subsingleton PUnit (n + 1) (Nat.succ_ne_zero n)
+    exact
+      (homeomorphHomologyEquiv productTorusZeroHomeomorph (n + 1)).trans
+        (LinearEquiv.ofSubsingleton (SingularMayerVietoris.SingularHomology PUnit (n + 1))
+          (binomialModule 0 (n + 1)))
+  | r + 1, n + 1 =>
+    ((homeomorphHomologyEquiv (productTorusSuccHomeomorph r) (n + 1)).toAddEquiv.trans
+        ((circleProductHomologyEquiv (ProductTorus r) n).toAddEquiv.trans
+          (((productTorusHomologyEquiv r (n + 1)).toAddEquiv.prodCongr
+                (productTorusHomologyEquiv r n).toAddEquiv).trans
+            (binomialModuleSuccEquiv r n).symm.toAddEquiv))).toIntLinearEquiv
+
+@[simp]
+private theorem PeriodTorusHigherHomology.productTorusHomologyEquiv_zero (r : ℕ) :
+    productTorusHomologyEquiv r 0 =
+      (connectedHomologyZeroEquiv (ProductTorus r)).trans (integerBinomialZeroEquiv r) := by
+  cases r <;> rfl
+
+private theorem PeriodTorusHigherHomology.productTorusHomologyEquiv_succ (r n : ℕ) :
+    productTorusHomologyEquiv (r + 1) (n + 1) =
+      ((homeomorphHomologyEquiv (productTorusSuccHomeomorph r) (n + 1)).toAddEquiv.trans
+          ((circleProductHomologyEquiv (ProductTorus r) n).toAddEquiv.trans
+            (((productTorusHomologyEquiv r (n + 1)).toAddEquiv.prodCongr
+                  (productTorusHomologyEquiv r n).toAddEquiv).trans
+              (binomialModuleSuccEquiv r n).symm.toAddEquiv))).toIntLinearEquiv :=
+  rfl
+
+private theorem PeriodTorusHigherHomology.productTorusHomologyEquiv_succ_apply (r n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (ProductTorus (r + 1)) (n + 1)) :
+    binomialModuleSuccEquiv r n (productTorusHomologyEquiv (r + 1) (n + 1) a) =
+      (productTorusHomologyEquiv r (n + 1)
+          (circleProjectionHomology (ProductTorus r) (n + 1)
+            (homeomorphHomologyEquiv (productTorusSuccHomeomorph r) (n + 1) a)),
+        productTorusHomologyEquiv r n
+          (circleBoundary (ProductTorus r) n
+            (homeomorphHomologyEquiv (productTorusSuccHomeomorph r) (n + 1) a))) := by
+  rw [productTorusHomologyEquiv_succ]
+  change
+    binomialModuleSuccEquiv r n
+        ((binomialModuleSuccEquiv r n).symm
+          (((productTorusHomologyEquiv r (n + 1)).toAddEquiv.prodCongr
+              (productTorusHomologyEquiv r n).toAddEquiv)
+            (circleProductHomologyEquiv (ProductTorus r) n
+              (homeomorphHomologyEquiv (productTorusSuccHomeomorph r) (n + 1) a)))) =
+      _
+  rw [LinearEquiv.apply_symm_apply, circleProductHomologyEquiv_apply]
+  rfl
+
+private theorem PeriodTorusHigherHomology.productTorus_homology_free (r n : ℕ) :
+    Module.Free ℤ (SingularMayerVietoris.SingularHomology (ProductTorus r) n) :=
+  Module.Free.of_equiv (productTorusHomologyEquiv r n).symm
+
+private theorem PeriodTorusHigherHomology.productTorus_homology_finite (r n : ℕ) :
+    Module.Finite ℤ (SingularMayerVietoris.SingularHomology (ProductTorus r) n) :=
+  Module.Finite.of_surjective (productTorusHomologyEquiv r n).symm.toLinearMap
+    (productTorusHomologyEquiv r n).symm.surjective
+
+private theorem PeriodTorusHigherHomology.productTorus_homology_finrank (r n : ℕ) :
+    Module.finrank ℤ (SingularMayerVietoris.SingularHomology (ProductTorus r) n) = r.choose n := by
+  rw [(productTorusHomologyEquiv r n).finrank_eq]
+  exact binomialModule_finrank r n
+
+private theorem PeriodTorusHigherHomology.productTorus_homology_torsionFree (r n : ℕ) :
+    Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology (ProductTorus r) n) := by
+  let := productTorus_homology_free r n
+  infer_instance
+
+private theorem
+    PeriodTorusHigherHomology.productTorus_homology_subsingleton_of_lt {r n : ℕ} (h : r < n) :
+    Subsingleton (SingularMayerVietoris.SingularHomology (ProductTorus r) n) := by
+  let := binomialModule_subsingleton_of_lt h
+  exact (productTorusHomologyEquiv r n).injective.subsingleton
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology7.lean b/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology7.lean
new file mode 100644
index 000000000..7e85ee1df
--- /dev/null
+++ b/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology7.lean
@@ -0,0 +1,4228 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+public import LeanPool.HopfProblem.Threefold.SpecialPeriods5
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology3
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology4
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+import all LeanPool.HopfProblem.Lattice.Core2
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.PeriodFamily.PeriodDomain
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods5
+
+/-!
+# Hopf problem: torus homology · period torus higher homology 7
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def
+    PeriodTorusHigherHomology.torusMatrixLinearMap {m n : ℕ} (A : Matrix (Fin m) (Fin n) ℤ) :
+    ProductTorus n →ₗ[ℤ] ProductTorus m
+    where
+  toFun x i := ∑ j, A i j • x j
+  map_add' x
+    y := by
+    ext i
+    simp only [Pi.add_apply, smul_add, Finset.sum_add_distrib]
+  map_smul' r
+    x := by
+    ext i
+    change (∑ j, A i j • (r • x j)) = r • ∑ j, A i j • x j
+    rw [Finset.smul_sum]
+    apply Finset.sum_congr rfl
+    intro j _
+    exact SMulCommClass.smul_comm (A i j) r (x j)
+
+private theorem PeriodTorusHigherHomology.torusMatrixLinearMap_continuous {m n : ℕ}
+    (A : Matrix (Fin m) (Fin n) ℤ) : Continuous (torusMatrixLinearMap A) := by
+  apply continuous_pi
+  intro i
+  change Continuous (fun x : ProductTorus n => ∑ j, A i j • x j)
+  exact continuous_finsetSum Finset.univ (fun j _ => (continuous_apply j).zsmul (A i j))
+
+private def PeriodTorusHigherHomology.torusMatrixMap {m n : ℕ} (A : Matrix (Fin m) (Fin n) ℤ) :
+    C(ProductTorus n, ProductTorus m) :=
+  ⟨torusMatrixLinearMap A, torusMatrixLinearMap_continuous A⟩
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.torusMatrixMap_apply {m n : ℕ} (A : Matrix (Fin m) (Fin n) ℤ)
+    (x : ProductTorus n) (i : Fin m) : torusMatrixMap A x i = ∑ j, A i j • x j :=
+  rfl
+
+private theorem PeriodTorusHigherHomology.torusMatrixMap_coordinateProjection {m n : ℕ}
+    (A : Matrix (Fin m) (Fin n) ℤ) (x : Fin n → ℝ) :
+    torusMatrixMap A (coordinateProjection n x) =
+      coordinateProjection m (A.map (Int.castRingHom ℝ) *ᵥ x) := by
+  ext i
+  change
+    (∑ j, A i j • (x j : AddCircle (1 : ℝ))) = ((∑ j, (A i j : ℝ) * x j : ℝ) : AddCircle (1 : ℝ))
+  have h :=
+    map_sum (QuotientAddGroup.mk' (AddSubgroup.zmultiples (1 : ℝ))) (fun j : Fin n => A i j • x j)
+      Finset.univ
+  calc
+    _ = ((∑ j, A i j • x j : ℝ) : AddCircle (1 : ℝ)) := h.symm
+    _ = _ := congrArg (fun y : ℝ => (y : AddCircle (1 : ℝ))) (by simp only [zsmul_eq_mul])
+
+@[simp]
+private theorem PeriodTorusHigherHomology.torusMatrixMap_one (n : ℕ) :
+    torusMatrixMap (1 : Matrix (Fin n) (Fin n) ℤ) = ContinuousMap.id (ProductTorus n) := by
+  apply ContinuousMap.ext
+  intro x
+  ext i
+  simp [torusMatrixMap_apply, Matrix.one_apply]
+
+private theorem
+    PeriodTorusHigherHomology.torusMatrixMap_mul {m n r : ℕ} (A : Matrix (Fin m) (Fin n) ℤ)
+    (B : Matrix (Fin n) (Fin r) ℤ) :
+    torusMatrixMap (A * B) = (torusMatrixMap A).comp (torusMatrixMap B) := by
+  apply ContinuousMap.ext
+  intro x
+  ext i
+  change (∑ j, (A * B) i j • x j) = ∑ k, A i k • ∑ j, B k j • x j
+  simp only [Matrix.mul_apply, Finset.sum_smul, SemigroupAction.mul_smul, Finset.smul_sum]
+  exact Finset.sum_comm
+
+private def PeriodTorusHigherHomologyPontryagin.cyclicMap (X Y Z : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] [TopologicalSpace Z] : C(Y × (Z × X), X × (Y × Z)) :=
+  ⟨fun p => (p.2.2, (p.1, p.2.1)), by fun_prop⟩
+
+private def PeriodTorusHigherHomologyPontryagin.additionMap (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G] : C(G × G, G) :=
+  ⟨fun p => p.1 + p.2, continuous_fst.add continuous_snd⟩
+
+private def PeriodTorusHigherHomologyPontryagin.rightAdditionMap (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G] : C(G × (G × G), G) :=
+  (additionMap G).comp ((ContinuousMap.id G).prodMap (additionMap G))
+
+@[simp]
+private theorem PeriodTorusHigherHomologyPontryagin.rightAdditionMap_comp_cyclic (G : Type)
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G] :
+    (rightAdditionMap G).comp (cyclicMap G G G) = rightAdditionMap G := by
+  ext p
+  change p.2.2 + (p.1 + p.2.1) = p.1 + (p.2.1 + p.2.2)
+  abel
+
+private theorem PeriodTorusHigherHomologyPontryagin.rightAddition_homology_cyclic (G : Type)
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G] (n : ℕ) :
+    (SingularMayerVietoris.singularHomologyMap (rightAdditionMap G) n).comp
+        (SingularMayerVietoris.singularHomologyMap (cyclicMap G G G) n) =
+      SingularMayerVietoris.singularHomologyMap (rightAdditionMap G) n := by
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp, rightAdditionMap_comp_cyclic]
+
+private theorem
+    PeriodTorusHigherHomologyPontryagin.additionMap_natural {G : Type} [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G] {H : Type} [TopologicalSpace H] [AddCommGroup H]
+    [IsTopologicalAddGroup H] (f : C(G, H)) (hf : ∀ x y, f (x + y) = f x + f y) :
+    f.comp (additionMap G) = (additionMap H).comp (f.prodMap f) := by
+  ext p
+  exact hf p.1 p.2
+
+private theorem PeriodTorusHigherHomologyPontryagin.addition_homology_natural {G : Type}
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G] {H : Type}
+    [TopologicalSpace H] [AddCommGroup H] [IsTopologicalAddGroup H] (f : C(G, H))
+    (hf : ∀ x y, f (x + y) = f x + f y) (n : ℕ) :
+    (SingularMayerVietoris.singularHomologyMap f n).comp
+        (SingularMayerVietoris.singularHomologyMap (additionMap G) n) =
+      (SingularMayerVietoris.singularHomologyMap (additionMap H) n).comp
+        (SingularMayerVietoris.singularHomologyMap (f.prodMap f) n) := by
+  rw [← PeriodTorusHigherHomology.singularHomologyMap_comp, additionMap_natural f hf,
+    PeriodTorusHigherHomology.singularHomologyMap_comp]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    PeriodTorusHigherHomologyPontryagin.product (G : Type) [TopologicalSpace G] [AddCommGroup G]
+    [IsTopologicalAddGroup G] (n : ℕ) :
+    SingularMayerVietoris.SingularHomology G 1 →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology G n →ₗ[ℤ]
+        SingularMayerVietoris.SingularHomology G (n + 1) :=
+  PeriodTorusHigherHomology.integerBilinearPostcompose
+    (PeriodTorusHigherHomology.crossProductHomology G G n)
+    (SingularMayerVietoris.singularHomologyMap (additionMap G) (n + 1))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodTorusHigherHomologyPontryagin.product_apply (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G] (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology G 1)
+    (b : SingularMayerVietoris.SingularHomology G n) :
+    product G n a b =
+      SingularMayerVietoris.singularHomologyMap (additionMap G) (n + 1)
+        (PeriodTorusHigherHomology.crossProductHomology G G n a b) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private abbrev PeriodTorusHigherHomologyPontryagin.product11 (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G] :
+    SingularMayerVietoris.SingularHomology G 1 →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology G 1 →ₗ[ℤ]
+        SingularMayerVietoris.SingularHomology G 2 :=
+  product G 1
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private abbrev PeriodTorusHigherHomologyPontryagin.product12 (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G] :
+    SingularMayerVietoris.SingularHomology G 1 →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology G 2 →ₗ[ℤ]
+        SingularMayerVietoris.SingularHomology G 3 :=
+  product G 2
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomologyPontryagin.tripleProduct (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G] :
+    SingularMayerVietoris.SingularHomology G 1 →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology G 1 →ₗ[ℤ]
+        SingularMayerVietoris.SingularHomology G 1 →ₗ[ℤ]
+          SingularMayerVietoris.SingularHomology G 3
+    where
+  toFun a := PeriodTorusHigherHomology.integerBilinearPostcompose (product11 G) (product12 G a)
+  map_add' a
+    b := by
+    apply LinearMap.ext
+    intro c
+    apply LinearMap.ext
+    intro d
+    exact
+      congrArg
+        (fun f :
+            SingularMayerVietoris.SingularHomology G 2 →ₗ[ℤ]
+              SingularMayerVietoris.SingularHomology G 3 =>
+          f (product11 G c d))
+        ((product12 G).map_add a b)
+  map_smul' r
+    a := by
+    apply LinearMap.ext
+    intro c
+    apply LinearMap.ext
+    intro d
+    exact
+      congrArg
+        (fun f :
+            SingularMayerVietoris.SingularHomology G 2 →ₗ[ℤ]
+              SingularMayerVietoris.SingularHomology G 3 =>
+          f (product11 G c d))
+        ((product12 G).map_smul r a)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem
+    PeriodTorusHigherHomologyPontryagin.tripleProduct_apply (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    (a b c : SingularMayerVietoris.SingularHomology G 1) :
+    tripleProduct G a b c = product12 G a (product11 G b c) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomologyPontryagin.product_natural {G H : Type} [TopologicalSpace G]
+    [TopologicalSpace H] [AddCommGroup G] [AddCommGroup H] [IsTopologicalAddGroup G]
+    [IsTopologicalAddGroup H] (f : C(G, H)) (hf : ∀ x y, f (x + y) = f x + f y) (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology G 1)
+    (b : SingularMayerVietoris.SingularHomology G n) :
+    SingularMayerVietoris.singularHomologyMap f (n + 1) (product G n a b) =
+      product H n (SingularMayerVietoris.singularHomologyMap f 1 a)
+        (SingularMayerVietoris.singularHomologyMap f n b) :=
+  (LinearMap.congr_fun (addition_homology_natural f hf (n + 1))
+        (PeriodTorusHigherHomology.crossProductHomology G G n a b)).trans
+    (congrArg (SingularMayerVietoris.singularHomologyMap (additionMap H) (n + 1))
+      (PeriodTorusHigherHomology.crossProductHomology_natural f f n a b))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomologyPontryagin.tripleProduct_natural {G H : Type}
+    [TopologicalSpace G] [TopologicalSpace H] [AddCommGroup G] [AddCommGroup H]
+    [IsTopologicalAddGroup G] [IsTopologicalAddGroup H] (f : C(G, H))
+    (hf : ∀ x y, f (x + y) = f x + f y) (a b c : SingularMayerVietoris.SingularHomology G 1) :
+    SingularMayerVietoris.singularHomologyMap f 3 (tripleProduct G a b c) =
+      tripleProduct H (SingularMayerVietoris.singularHomologyMap f 1 a)
+        (SingularMayerVietoris.singularHomologyMap f 1 b)
+        (SingularMayerVietoris.singularHomologyMap f 1 c) := by
+  change
+    SingularMayerVietoris.singularHomologyMap f 3 (product G 2 a (product G 1 b c)) =
+      product H 2 (SingularMayerVietoris.singularHomologyMap f 1 a)
+        (product H 1 (SingularMayerVietoris.singularHomologyMap f 1 b)
+          (SingularMayerVietoris.singularHomologyMap f 1 c))
+  rw [product_natural f hf 2, product_natural f hf 1]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomologyPontryagin.tripleProduct_eq_cross (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    (a b c : SingularMayerVietoris.SingularHomology G 1) :
+    tripleProduct G a b c =
+      SingularMayerVietoris.singularHomologyMap (rightAdditionMap G) 3
+        (PeriodTorusHigherHomology.crossProductHomology G (G × G) 2 a
+          (PeriodTorusHigherHomology.crossProductHomology G G 1 b c)) := by
+  have h :=
+    PeriodTorusHigherHomology.crossProductHomology_natural (ContinuousMap.id G) (additionMap G) 2
+      a (PeriodTorusHigherHomology.crossProductHomology G G 1 b c)
+  change
+    SingularMayerVietoris.singularHomologyMap ((ContinuousMap.id G).prodMap (additionMap G)) 3
+        (PeriodTorusHigherHomology.crossProductHomology G (G × G) 2 a
+          (PeriodTorusHigherHomology.crossProductHomology G G 1 b c)) =
+      PeriodTorusHigherHomology.crossProductHomology G G 2
+        (SingularMayerVietoris.singularHomologyMap (ContinuousMap.id G) 1 a)
+        (SingularMayerVietoris.singularHomologyMap (additionMap G) 2
+          (PeriodTorusHigherHomology.crossProductHomology G G 1 b c)) at h
+  rw [PeriodTorusHigherHomology.singularHomologyMap_id, LinearMap.id_apply] at h
+  calc
+    tripleProduct G a b c =
+        SingularMayerVietoris.singularHomologyMap (additionMap G) 3
+          (PeriodTorusHigherHomology.crossProductHomology G G 2 a
+            (SingularMayerVietoris.singularHomologyMap (additionMap G) 2
+              (PeriodTorusHigherHomology.crossProductHomology G G 1 b c))) :=
+      rfl
+    _ =
+        SingularMayerVietoris.singularHomologyMap (additionMap G) 3
+          (SingularMayerVietoris.singularHomologyMap
+            ((ContinuousMap.id G).prodMap (additionMap G)) 3
+            (PeriodTorusHigherHomology.crossProductHomology G (G × G) 2 a
+              (PeriodTorusHigherHomology.crossProductHomology G G 1 b c))) :=
+      (congrArg (SingularMayerVietoris.singularHomologyMap (additionMap G) 3) h.symm)
+    _ = _ :=
+      (LinearMap.congr_fun
+          (PeriodTorusHigherHomology.singularHomologyMap_comp
+            ((ContinuousMap.id G).prodMap (additionMap G)) (additionMap G) 3)
+          (PeriodTorusHigherHomology.crossProductHomology G (G × G) 2 a
+            (PeriodTorusHigherHomology.crossProductHomology G G 1 b c))).symm
+
+private def PeriodTorusHigherHomology.binomialCoordinateBasis (r n : ℕ) :
+    Module.Basis (Fin (r.choose n)) ℤ (binomialModule r n) :=
+  Pi.basisFun ℤ (Fin (r.choose n))
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.binomialCoordinateBasis_apply (r n : ℕ) (i : Fin (r.choose n)) :
+    binomialCoordinateBasis r n i = Pi.single i 1 :=
+  Pi.basisFun_apply ℤ (Fin (r.choose n)) i
+
+@[simp]
+private theorem PeriodTorusHigherHomology.binomialModuleSuccEquiv_single_inl (r n : ℕ)
+    (i : Fin (r.choose (n + 1))) :
+    binomialModuleSuccEquiv r n (Pi.single ((binomialPascalIndexEquiv r n).symm (Sum.inl i)) 1) =
+      (Pi.single i 1, 0) := by
+  apply Prod.ext
+  · funext j
+    simp only [binomialModuleSuccEquiv_apply_fst, Pi.single_apply, Equiv.apply_eq_iff_eq,
+      Sum.inl.injEq]
+  · funext j
+    simp only [binomialModuleSuccEquiv_apply_snd, Pi.single_apply, Equiv.apply_eq_iff_eq,
+      Sum.inr_ne_inl, ite_false, Pi.zero_apply]
+
+@[simp]
+private theorem PeriodTorusHigherHomology.binomialModuleSuccEquiv_single_inr (r n : ℕ)
+    (i : Fin (r.choose n)) :
+    binomialModuleSuccEquiv r n (Pi.single ((binomialPascalIndexEquiv r n).symm (Sum.inr i)) 1) =
+      (0, Pi.single i 1) := by
+  apply Prod.ext
+  · funext j
+    simp only [binomialModuleSuccEquiv_apply_fst, Pi.single_apply, Equiv.apply_eq_iff_eq,
+      Sum.inl_ne_inr, ite_false, Pi.zero_apply]
+  · funext j
+    simp only [binomialModuleSuccEquiv_apply_snd, Pi.single_apply, Equiv.apply_eq_iff_eq,
+      Sum.inr.injEq]
+
+private theorem PeriodTorusHigherHomology.integerBinomialZeroEquiv_one_single (r : ℕ)
+    (i : Fin (r.choose 0)) : integerBinomialZeroEquiv r 1 = Pi.single i 1 := by
+  have hsingle : Subsingleton (Fin (r.choose 0)) := by
+    rw [Nat.choose_zero_right]
+    infer_instance
+  funext j
+  have hij : i = j := hsingle.elim i j
+  subst j
+  simp [integerBinomialZeroEquiv]
+
+private theorem PeriodTorusHigherHomology.binomialModuleSuccEquiv_top (n : ℕ) :
+    binomialModuleSuccEquiv n n (fun _ => 1) = (0, fun _ => 1) := by
+  apply Prod.ext
+  · exact binomialModule_eq_zero_of_lt (Nat.lt_succ_self n) _
+  · rfl
+
+private def PeriodTorusHigherHomology.productTorusTopClass (n : ℕ) :
+    SingularMayerVietoris.SingularHomology (ProductTorus n) n :=
+  (productTorusHomologyEquiv n n).symm (fun _ => (1 : ℤ))
+
+@[simp]
+private theorem PeriodTorusHigherHomology.productTorusHomologyEquiv_topClass (n : ℕ) :
+    productTorusHomologyEquiv n n (productTorusTopClass n) = fun _ => (1 : ℤ) :=
+  (productTorusHomologyEquiv n n).apply_symm_apply _
+
+@[simp]
+private theorem PeriodTorusHigherHomology.productTorusTopClass_zero :
+    productTorusTopClass 0 = pointClass (0 : ProductTorus 0) := by
+  apply (productTorusHomologyEquiv 0 0).injective
+  rw [productTorusHomologyEquiv_topClass, productTorusHomologyEquiv_zero]
+  simp only [LinearEquiv.trans_apply, connectedHomologyZeroEquiv_pointClass]
+  rfl
+
+private theorem PeriodTorusHigherHomology.productTorusTopClass_succ_coordinates (n : ℕ) :
+    circleProductHomologyEquiv (ProductTorus n) n
+        (homeomorphHomologyEquiv (productTorusSuccHomeomorph n) (n + 1)
+          (productTorusTopClass (n + 1))) =
+      (0, productTorusTopClass n) := by
+  apply Prod.ext
+  · exact
+      @Subsingleton.elim (SingularMayerVietoris.SingularHomology (ProductTorus n) (n + 1))
+        (productTorus_homology_subsingleton_of_lt (Nat.lt_succ_self n)) _ _
+  · apply (productTorusHomologyEquiv n n).injective
+    have h :=
+      congrArg Prod.snd (productTorusHomologyEquiv_succ_apply n n (productTorusTopClass (n + 1)))
+    rw [productTorusHomologyEquiv_topClass, binomialModuleSuccEquiv_top] at h
+    exact h.symm.trans (productTorusHomologyEquiv_topClass n).symm
+
+private theorem PeriodTorusHigherHomology.productTorusTopClass_succ_boundary (n : ℕ) :
+    circleBoundary (ProductTorus n) n
+        (homeomorphHomologyEquiv (productTorusSuccHomeomorph n) (n + 1)
+          (productTorusTopClass (n + 1))) =
+      productTorusTopClass n :=
+  congrArg Prod.snd (productTorusTopClass_succ_coordinates n)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.flatTorusCircleHomeomorph_add (x y : RealTorus₄) :
+    flatTorusCircleHomeomorph (x + y) =
+      flatTorusCircleHomeomorph x + flatTorusCircleHomeomorph y :=
+  flatTorusCircleMap.map_add x y
+
+private theorem
+    PeriodTorusHigherHomology.periodTorusCircle_inducedHomology_periodLoop (p : PeriodDomain)
+    (v : Lattice) :
+    FirstHurewicz.inducedHomology (periodTorusCircleHomeomorph p : C(_, _))
+        (FirstHurewicz.loopHomologyClass (p.periodLoop v)) =
+      FirstHurewicz.loopHomologyClass (coordinatePeriodLoop 4 v) := by
+  rw [FirstHurewicz.inducedHomology_loopHomologyClass, periodTorusCircleHomeomorph_periodLoop]
+  rfl
+
+private def PeriodTorusHigherHomology.coordinateCircleMap {n : ℕ} (v : Fin n → ℤ) :
+    C((PeriodTorusHigherHomology.CircleTopology.Circle), ProductTorus n)
+    where
+  toFun z i := v i • z
+  continuous_toFun := continuous_pi fun i => continuous_id.zsmul (v i)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.coordinateCircleMap_apply {n : ℕ} (v : Fin n → ℤ)
+    (z : (PeriodTorusHigherHomology.CircleTopology.Circle)) (i : Fin n) :
+    coordinateCircleMap v z i = v i • z :=
+  rfl
+
+@[simp]
+private theorem PeriodTorusHigherHomology.coordinateCircleMap_zero {n : ℕ} (v : Fin n → ℤ) :
+    coordinateCircleMap v 0 = 0 := by
+  ext i
+  exact smul_zero (v i)
+
+private theorem PeriodTorusHigherHomology.coordinateCircleMap_add {n : ℕ} (v : Fin n → ℤ)
+    (x y : (PeriodTorusHigherHomology.CircleTopology.Circle)) :
+    coordinateCircleMap v (x + y) = coordinateCircleMap v x + coordinateCircleMap v y := by
+  ext i
+  exact smul_add (v i) x y
+
+private theorem
+    PeriodTorusHigherHomology.coordinateCircleMap_positiveLoop_apply {n : ℕ} (v : Fin n → ℤ)
+    (t : unitInterval) :
+    coordinateCircleMap v (CirclePaths.positiveLoop t) = coordinatePeriodLoop n v t := by
+  ext i
+  rw [coordinateCircleMap_apply, CirclePaths.positiveLoop_apply, coordinatePeriodLoop_apply]
+  change
+    ((v i • (t : ℝ) : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle)) =
+      (((t : ℝ) * (v i : ℝ) : ℝ) : (PeriodTorusHigherHomology.CircleTopology.Circle))
+  congr 1
+  simp only [zsmul_eq_mul, mul_comm]
+
+private theorem PeriodTorusHigherHomology.coordinateCircleMap_positiveLoop {n : ℕ} (v : Fin n → ℤ) :
+    CirclePaths.positiveLoop.map (coordinateCircleMap v).continuous =
+      (coordinatePeriodLoop n v).cast (coordinateCircleMap_zero v) (coordinateCircleMap_zero v) :=
+  by
+  apply Path.ext
+  funext t
+  exact coordinateCircleMap_positiveLoop_apply v t
+
+private theorem
+    PeriodTorusHigherHomology.coordinateCircleMap_positiveHomology {n : ℕ} (v : Fin n → ℤ) :
+    FirstHurewicz.inducedHomology (coordinateCircleMap v)
+        (FirstHurewicz.loopHomologyClass CirclePaths.positiveLoop) =
+      FirstHurewicz.loopHomologyClass (coordinatePeriodLoop n v) := by
+  rw [FirstHurewicz.inducedHomology_loopHomologyClass, coordinateCircleMap_positiveLoop]
+  rfl
+
+private theorem PeriodTorusHigherHomology.coordinatePeriodLoop_eq_projection (n : ℕ) (v : Fin n → ℤ)
+    (t : unitInterval) :
+    coordinatePeriodLoop n v t = coordinateProjection n ((t : ℝ) • (fun i => (v i : ℝ))) := by
+  ext i
+  rw [coordinatePeriodLoop_apply]
+  rfl
+
+private theorem PeriodTorusHigherHomology.torusMatrixMap_coordinatePeriodLoop_apply {m n : ℕ}
+    (A : Matrix (Fin m) (Fin n) ℤ) (v : Fin n → ℤ) (t : unitInterval) :
+    torusMatrixMap A (coordinatePeriodLoop n v t) = coordinatePeriodLoop m (A *ᵥ v) t := by
+  rw [coordinatePeriodLoop_eq_projection, torusMatrixMap_coordinateProjection,
+    coordinatePeriodLoop_eq_projection, Matrix.mulVec_smul]
+  congr 2
+  ext i
+  exact ((Int.castRingHom ℝ).map_mulVec A v i).symm
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.torusMatrixMap_zero {m n : ℕ} (A : Matrix (Fin m) (Fin n) ℤ) :
+    torusMatrixMap A 0 = 0 :=
+  (torusMatrixLinearMap A).map_zero
+
+private theorem PeriodTorusHigherHomology.torusMatrixMap_coordinatePeriodLoop {m n : ℕ}
+    (A : Matrix (Fin m) (Fin n) ℤ) (v : Fin n → ℤ) :
+    (coordinatePeriodLoop n v).map (torusMatrixMap A).continuous =
+      (coordinatePeriodLoop m (A *ᵥ v)).cast (torusMatrixMap_zero A) (torusMatrixMap_zero A) := by
+  apply Path.ext
+  funext t
+  exact torusMatrixMap_coordinatePeriodLoop_apply A v t
+
+private theorem PeriodTorusHigherHomology.torusMatrixMap_coordinatePeriodHomology {m n : ℕ}
+    (A : Matrix (Fin m) (Fin n) ℤ) (v : Fin n → ℤ) :
+    FirstHurewicz.inducedHomology (torusMatrixMap A)
+        (FirstHurewicz.loopHomologyClass (coordinatePeriodLoop n v)) =
+      FirstHurewicz.loopHomologyClass (coordinatePeriodLoop m (A *ᵥ v)) := by
+  rw [FirstHurewicz.inducedHomology_loopHomologyClass, torusMatrixMap_coordinatePeriodLoop]
+  rfl
+
+private def PeriodTorusHigherHomology.torusHeadCircleMap (n : ℕ) :
+    C((PeriodTorusHigherHomology.CircleTopology.Circle), ProductTorus (n + 1)) :=
+  coordinateCircleMap (Pi.single (0 : Fin (n + 1)) 1)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.torusHeadCircleMap_apply (n : ℕ)
+    (z : (PeriodTorusHigherHomology.CircleTopology.Circle)) :
+    torusHeadCircleMap n z = Fin.cons z 0 := by
+  ext i
+  refine Fin.cases ?_ (fun j => ?_) i
+  · simp [torusHeadCircleMap, coordinateCircleMap_apply]
+  · simp [torusHeadCircleMap, coordinateCircleMap_apply]
+
+private def
+    PeriodTorusHigherHomology.torusTailMap (n : ℕ) : C(ProductTorus n, ProductTorus (n + 1)) :=
+  ((productTorusSuccHomeomorph n).symm : C(_, _)).comp
+    (CircleTopology.productSection (ProductTorus n))
+
+@[simp]
+private theorem PeriodTorusHigherHomology.torusTailMap_apply (n : ℕ) (x : ProductTorus n) :
+    torusTailMap n x = Fin.cons 0 x :=
+  rfl
+
+private theorem PeriodTorusHigherHomology.torusTailMap_add (n : ℕ) (x y : ProductTorus n) :
+    torusTailMap n (x + y) = torusTailMap n x + torusTailMap n y := by
+  ext i
+  refine Fin.cases ?_ (fun j => ?_) i <;> simp [torusTailMap_apply]
+
+private theorem PeriodTorusHigherHomology.torusTailMap_zero (n : ℕ) : torusTailMap n 0 = 0 := by
+  ext i
+  refine Fin.cases ?_ (fun j => ?_) i <;> simp [torusTailMap_apply]
+
+private theorem
+    PeriodTorusHigherHomology.torusTailMap_coordinatePeriodLoop (n : ℕ) (v : Fin n → ℤ) :
+    (coordinatePeriodLoop n v).map (torusTailMap n).continuous =
+      (coordinatePeriodLoop (n + 1) (Fin.cons 0 v)).cast (torusTailMap_zero n)
+        (torusTailMap_zero n) := by
+  apply Path.ext
+  funext t
+  apply funext
+  intro i
+  change
+    torusTailMap n (coordinatePeriodLoop n v t) i =
+      coordinatePeriodLoop (n + 1) (Fin.cons 0 v) t i
+  refine Fin.cases ?_ (fun j => ?_) i
+  · simp [torusTailMap_apply, coordinatePeriodLoop_apply]
+  · simp [torusTailMap_apply, coordinatePeriodLoop_apply]
+
+private theorem
+    PeriodTorusHigherHomology.torusTailMap_coordinatePeriodHomology (n : ℕ) (v : Fin n → ℤ) :
+    SingularMayerVietoris.singularHomologyMap (torusTailMap n) 1
+        (FirstHurewicz.loopHomologyClass (coordinatePeriodLoop n v)) =
+      FirstHurewicz.loopHomologyClass (coordinatePeriodLoop (n + 1) (Fin.cons 0 v)) := by
+  rw [SingularMayerVietoris.singularHomologyMap_one,
+    FirstHurewicz.inducedHomology_loopHomologyClass, torusTailMap_coordinatePeriodLoop]
+  rfl
+
+private theorem PeriodTorusHigherHomology.productTorusSucc_inverse_eq_add (n : ℕ) :
+    ((productTorusSuccHomeomorph n).symm :
+        C((PeriodTorusHigherHomology.CircleTopology.Circle) × ProductTorus n,
+          ProductTorus (n + 1))) =
+      (PeriodTorusHigherHomologyPontryagin.additionMap (ProductTorus (n + 1))).comp
+        ((torusHeadCircleMap n).prodMap (torusTailMap n)) := by
+  apply ContinuousMap.ext
+  rintro ⟨z, x⟩
+  change Fin.cons z x = torusHeadCircleMap n z + torusTailMap n x
+  rw [torusHeadCircleMap_apply, torusTailMap_apply]
+  ext i
+  refine Fin.cases ?_ (fun j => ?_) i <;> simp
+
+private theorem PeriodTorusHigherHomology.torusSplit_positiveCircleCross (r n : ℕ)
+    (b : SingularMayerVietoris.SingularHomology (ProductTorus r) n) :
+    SingularMayerVietoris.singularHomologyMap ((productTorusSuccHomeomorph r).symm : C(_, _))
+        (n + 1) (positiveCircleCross (ProductTorus r) n b) =
+      PeriodTorusHigherHomologyPontryagin.product (ProductTorus (r + 1)) n
+        (SingularMayerVietoris.singularHomologyMap (torusHeadCircleMap r) 1
+          (FirstHurewicz.loopHomologyClass CirclePaths.positiveLoop))
+        (SingularMayerVietoris.singularHomologyMap (torusTailMap r) n b) := by
+  rw [PeriodTorusHigherHomologyPontryagin.product_apply]
+  have h :=
+    crossProductHomology_natural (torusHeadCircleMap r) (torusTailMap r) n
+      (FirstHurewicz.loopHomologyClass CirclePaths.positiveLoop) b
+  rw [← h]
+  rw [productTorusSucc_inverse_eq_add, singularHomologyMap_comp]
+  rfl
+
+private theorem PeriodTorusHigherHomology.torusHeadCircleMap_positiveHomology (n : ℕ) :
+    SingularMayerVietoris.singularHomologyMap (torusHeadCircleMap n) 1
+        (FirstHurewicz.loopHomologyClass CirclePaths.positiveLoop) =
+      FirstHurewicz.loopHomologyClass (coordinatePeriodLoop (n + 1) (Pi.single 0 1)) :=
+  coordinateCircleMap_positiveHomology (Pi.single (0 : Fin (n + 1)) 1)
+
+private theorem PeriodTorusHigherHomology.productTorusTopClass_succ_cross (n : ℕ) :
+    productTorusTopClass (n + 1) =
+      SingularMayerVietoris.singularHomologyMap ((productTorusSuccHomeomorph n).symm : C(_, _))
+        (n + 1) (positiveCircleCross (ProductTorus n) n (productTorusTopClass n)) := by
+  apply (homeomorphHomologyEquiv (productTorusSuccHomeomorph n) (n + 1)).injective
+  apply (circleProductHomologyEquiv (ProductTorus n) n).injective
+  rw [productTorusTopClass_succ_coordinates]
+  change
+    (0, productTorusTopClass n) =
+      circleProductHomologyEquiv (ProductTorus n) n
+        (homeomorphHomologyEquiv (productTorusSuccHomeomorph n) (n + 1)
+          ((homeomorphHomologyEquiv (productTorusSuccHomeomorph n) (n + 1)).symm
+            (positiveCircleCross (ProductTorus n) n (productTorusTopClass n))))
+  rw [LinearEquiv.apply_symm_apply, circleProductHomologyEquiv_positiveCircleCross]
+
+private theorem PeriodTorusHigherHomology.productTorusTopClass_succ_product (n : ℕ) :
+    productTorusTopClass (n + 1) =
+      PeriodTorusHigherHomologyPontryagin.product (ProductTorus (n + 1)) n
+        (FirstHurewicz.loopHomologyClass (coordinatePeriodLoop (n + 1) (Pi.single 0 1)))
+        (SingularMayerVietoris.singularHomologyMap (torusTailMap n) n (productTorusTopClass n)) :=
+  by
+  rw [productTorusTopClass_succ_cross, torusSplit_positiveCircleCross,
+    torusHeadCircleMap_positiveHomology]
+
+private theorem PeriodTorusHigherHomology.productTorusTopClass_one :
+    productTorusTopClass 1 =
+      FirstHurewicz.loopHomologyClass (coordinatePeriodLoop 1 (Pi.single 0 1)) := by
+  rw [productTorusTopClass_succ_cross, productTorusTopClass_zero, positiveCircleCross,
+    crossProductHomology_pointClass_right]
+  have hmap :
+    ((productTorusSuccHomeomorph 0).symm :
+            C((PeriodTorusHigherHomology.CircleTopology.Circle) × ProductTorus 0,
+              ProductTorus 1)).comp
+        (crossInsertRight (0 : ProductTorus 0)) =
+      torusHeadCircleMap 0 := by
+    apply ContinuousMap.ext
+    intro z
+    rw [torusHeadCircleMap_apply]
+    rfl
+  rw [← LinearMap.comp_apply, ← singularHomologyMap_comp, hmap]
+  exact torusHeadCircleMap_positiveHomology 0
+
+private theorem PeriodTorusHigherHomology.productTorusTopClass_two :
+    productTorusTopClass 2 =
+      PeriodTorusHigherHomologyPontryagin.product (ProductTorus 2) 1
+        (FirstHurewicz.loopHomologyClass (coordinatePeriodLoop 2 (Pi.single 0 1)))
+        (FirstHurewicz.loopHomologyClass (coordinatePeriodLoop 2 (Pi.single 1 1))) := by
+  rw [productTorusTopClass_succ_product, productTorusTopClass_one,
+    torusTailMap_coordinatePeriodHomology]
+  congr 3
+  decide
+
+private theorem PeriodTorusHigherHomology.productTorusTopClass_three :
+    productTorusTopClass 3 =
+      PeriodTorusHigherHomologyPontryagin.tripleProduct (ProductTorus 3)
+        (FirstHurewicz.loopHomologyClass (coordinatePeriodLoop 3 (Pi.single 0 1)))
+        (FirstHurewicz.loopHomologyClass (coordinatePeriodLoop 3 (Pi.single 1 1)))
+        (FirstHurewicz.loopHomologyClass (coordinatePeriodLoop 3 (Pi.single 2 1))) := by
+  rw [productTorusTopClass_succ_product, productTorusTopClass_two,
+    PeriodTorusHigherHomologyPontryagin.product_natural (torusTailMap 2) (torusTailMap_add 2),
+    torusTailMap_coordinatePeriodHomology, torusTailMap_coordinatePeriodHomology]
+  have h₁ : Fin.cons 0 (Pi.single 0 1 : Fin 2 → ℤ) = (Pi.single 1 1 : Fin 3 → ℤ) := by decide
+  have h₂ : Fin.cons 0 (Pi.single 1 1 : Fin 2 → ℤ) = (Pi.single 2 1 : Fin 3 → ℤ) := by decide
+  rw [h₁, h₂]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule in
+private def PeriodTorusHigherHomologyPontryagin.multilinearOfBilinear {M N : Type*} [AddCommGroup M]
+    [Module ℤ M] [AddCommGroup N] [Module ℤ N] (β : M →ₗ[ℤ] M →ₗ[ℤ] N) :
+    MultilinearMap ℤ (fun _ : Fin 2 => M) N
+    where
+  toFun v := β (v 0) (v 1)
+  map_update_add' {hDecEq} v i x
+    y := by
+    have heq : hDecEq = instDecidableEqFin 2 := Subsingleton.elim _ _
+    subst hDecEq
+    fin_cases i <;> simp
+  map_update_smul' {hDecEq} v i r
+    x := by
+    have heq : hDecEq = instDecidableEqFin 2 := Subsingleton.elim _ _
+    subst hDecEq
+    fin_cases i <;> simp
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule in
+private def PeriodTorusHigherHomologyPontryagin.alternatingOfBilinear {M N : Type*} [AddCommGroup M]
+    [Module ℤ M] [AddCommGroup N] [Module ℤ N] (β : M →ₗ[ℤ] M →ₗ[ℤ] N)
+    (hdiag : ∀ x : M, β x x = 0) : AlternatingMap ℤ M N (Fin 2)
+    where
+  toMultilinearMap := multilinearOfBilinear β
+  map_eq_zero_of_eq' v i j hij
+    hne := by
+    have h : v 0 = v 1 := by fin_cases i <;> fin_cases j <;> simp_all
+    change β (v 0) (v 1) = 0
+    rw [h]
+    exact hdiag _
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule in
+private theorem PeriodTorusHigherHomologyPontryagin.skewBilinear_diagonal_zero {M N : Type*}
+    [AddCommGroup M] [Module ℤ M] [AddCommGroup N] [Module ℤ N] [Module.IsTorsionFree ℤ N]
+    (β : M →ₗ[ℤ] M →ₗ[ℤ] N) (hskew : ∀ x y : M, β x y = -β y x) (x : M) : β x x = 0 := by
+  apply (smul_eq_zero_iff_right (show (2 : ℤ) ≠ 0 by decide)).mp
+  rw [two_smul ℤ]
+  exact add_eq_zero_iff_eq_neg.mpr (hskew x x)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule in
+private def
+    PeriodTorusHigherHomologyPontryagin.multilinearOfTrilinear {M N : Type*} [AddCommGroup M]
+    [Module ℤ M] [AddCommGroup N] [Module ℤ N] (g : M →ₗ[ℤ] M →ₗ[ℤ] M →ₗ[ℤ] N) :
+    MultilinearMap ℤ (fun _ : Fin 3 => M) N
+    where
+  toFun v := g (v 0) (v 1) (v 2)
+  map_update_add' {hDecEq} v i x
+    y := by
+    have heq : hDecEq = instDecidableEqFin 3 := Subsingleton.elim _ _
+    subst hDecEq
+    fin_cases i <;> simp
+  map_update_smul' {hDecEq} v i r
+    x := by
+    have heq : hDecEq = instDecidableEqFin 3 := Subsingleton.elim _ _
+    subst hDecEq
+    fin_cases i <;> simp
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule in
+private def
+    PeriodTorusHigherHomologyPontryagin.alternatingOfTrilinear {M N : Type*} [AddCommGroup M]
+    [Module ℤ M] [AddCommGroup N] [Module ℤ N] (g : M →ₗ[ℤ] M →ₗ[ℤ] M →ₗ[ℤ] N)
+    (h01 : ∀ x z : M, g x x z = 0) (h02 : ∀ x y : M, g x y x = 0) (h12 : ∀ x y : M, g x y y = 0) :
+    AlternatingMap ℤ M N (Fin 3)
+    where
+  toMultilinearMap := multilinearOfTrilinear g
+  map_eq_zero_of_eq' v i j hij
+    hne := by
+    have h : v 0 = v 1 ∨ v 0 = v 2 ∨ v 1 = v 2 := by fin_cases i <;> fin_cases j <;> simp_all
+    change g (v 0) (v 1) (v 2) = 0
+    rcases h with h | h | h
+    · rw [h]
+      exact h01 _ _
+    · rw [h]
+      exact h02 _ _
+    · rw [h]
+      exact h12 _ _
+
+private theorem
+    PeriodTorusHigherHomology.formalMap_comp {V W Z : Type*} (f : W → Z) (g : V → W) (n : ℕ)
+    (c : SingularMayerVietoris.FormalChains V n) :
+    SingularMayerVietoris.formalMap f n (SingularMayerVietoris.formalMap g n c) =
+      SingularMayerVietoris.formalMap (f ∘ g) n c := by
+  have h :
+    (SingularMayerVietoris.formalMap f n).comp (SingularMayerVietoris.formalMap g n) =
+      SingularMayerVietoris.formalMap (f ∘ g) n := by
+    apply SingularMayerVietoris.formalChains_ext
+    intro v
+    simp only [LinearMap.comp_apply, SingularMayerVietoris.formalMap_simplex, Function.comp_assoc]
+  exact LinearMap.congr_fun h c
+
+private theorem PeriodTorusHigherHomology.formalMap_prod_swap {V W V' W' : Type*} (f : V → V')
+    (g : W → W') (n : ℕ) (c : SingularMayerVietoris.FormalChains (W × V) n) :
+    SingularMayerVietoris.formalMap (Prod.map f g) n
+        (SingularMayerVietoris.formalMap Prod.swap n c) =
+      SingularMayerVietoris.formalMap Prod.swap n
+        (SingularMayerVietoris.formalMap (Prod.map g f) n c) := by
+  rw [formalMap_comp, formalMap_comp]
+  rfl
+
+private theorem PeriodTorusHigherHomology.formalMap_swap_pointCrossProduct_one {V W : Type*}
+    (c : SingularMayerVietoris.FormalChains V 1) (d : SingularMayerVietoris.FormalChains W 2) :
+    SingularMayerVietoris.formalMap Prod.swap 2 (formalPointCrossProduct 1 c d) =
+      formalEdgeCrossProduct 0 d c := by
+  have h :
+    (formalPointCrossProduct (V := V) (W := W) 1).compr₂
+        (SingularMayerVietoris.formalMap Prod.swap 2) =
+      (formalEdgeCrossProduct 0).flip := by
+    apply formalChains_bilinear_ext
+    intro v w
+    change
+      SingularMayerVietoris.formalMap Prod.swap 2
+          (formalPointCrossProduct 1 (SingularMayerVietoris.formalSimplex v)
+            (SingularMayerVietoris.formalSimplex w)) =
+        formalEdgeCrossProduct 0 (SingularMayerVietoris.formalSimplex w)
+          (SingularMayerVietoris.formalSimplex v)
+    calc
+      _ =
+          SingularMayerVietoris.formalMap Prod.swap 2
+            (SingularMayerVietoris.formalMap (fun z => (v 0, z)) 2
+              (SingularMayerVietoris.formalSimplex w)) :=
+        congrArg (SingularMayerVietoris.formalMap Prod.swap 2)
+          (formalPointCrossProduct_simplex_left 1 v (SingularMayerVietoris.formalSimplex w))
+      _ =
+          SingularMayerVietoris.formalMap (fun z => (z, v 0)) 2
+            (SingularMayerVietoris.formalSimplex w) := by
+        rw [formalMap_comp]
+        rfl
+      _ = _ :=
+        (formalEdgeCrossProduct_zero_simplex_right (SingularMayerVietoris.formalSimplex w) v).symm
+  exact LinearMap.congr_fun (LinearMap.congr_fun h c) d
+
+private theorem PeriodTorusHigherHomology.formalMap_swap_edgeCrossProduct_zero {V W : Type*}
+    (c : SingularMayerVietoris.FormalChains V 2) (d : SingularMayerVietoris.FormalChains W 1) :
+    SingularMayerVietoris.formalMap Prod.swap 2 (formalEdgeCrossProduct 0 c d) =
+      formalPointCrossProduct 1 d c := by
+  have h :
+    (formalEdgeCrossProduct (V := V) (W := W) 0).compr₂
+        (SingularMayerVietoris.formalMap Prod.swap 2) =
+      (formalPointCrossProduct 1).flip := by
+    apply formalChains_bilinear_ext
+    intro v w
+    change
+      SingularMayerVietoris.formalMap Prod.swap 2
+          (formalEdgeCrossProduct 0 (SingularMayerVietoris.formalSimplex v)
+            (SingularMayerVietoris.formalSimplex w)) =
+        formalPointCrossProduct 1 (SingularMayerVietoris.formalSimplex w)
+          (SingularMayerVietoris.formalSimplex v)
+    calc
+      _ =
+          SingularMayerVietoris.formalMap Prod.swap 2
+            (SingularMayerVietoris.formalMap (fun z => (z, w 0)) 2
+              (SingularMayerVietoris.formalSimplex v)) :=
+        congrArg (SingularMayerVietoris.formalMap Prod.swap 2)
+          (formalEdgeCrossProduct_zero_simplex_right (SingularMayerVietoris.formalSimplex v) w)
+      _ =
+          SingularMayerVietoris.formalMap (fun z => (w 0, z)) 2
+            (SingularMayerVietoris.formalSimplex v) := by
+        rw [formalMap_comp]
+        rfl
+      _ = _ :=
+        (formalPointCrossProduct_simplex_left 1 w (SingularMayerVietoris.formalSimplex v)).symm
+  exact LinearMap.congr_fun (LinearMap.congr_fun h c) d
+
+private def PeriodTorusHigherHomology.formalEdgeSwapDefect {V W : Type*} :
+    SingularMayerVietoris.FormalChains V 2 →ₗ[ℤ]
+      SingularMayerVietoris.FormalChains W 2 →ₗ[ℤ] SingularMayerVietoris.FormalChains (V × W) 3 :=
+  formalEdgeCrossProduct 1 +
+    (formalEdgeCrossProduct 1).flip.compr₂ (SingularMayerVietoris.formalMap Prod.swap 3)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.formalEdgeSwapDefect_apply {V W : Type*}
+    (c : SingularMayerVietoris.FormalChains V 2) (d : SingularMayerVietoris.FormalChains W 2) :
+    formalEdgeSwapDefect c d =
+      formalEdgeCrossProduct 1 c d +
+        SingularMayerVietoris.formalMap Prod.swap 3 (formalEdgeCrossProduct 1 d c) :=
+  rfl
+
+private theorem PeriodTorusHigherHomology.formalBoundary_edgeSwapDefect {V W : Type*}
+    (c : SingularMayerVietoris.FormalChains V 2) (d : SingularMayerVietoris.FormalChains W 2) :
+    SingularMayerVietoris.formalBoundary 2 (formalEdgeSwapDefect c d) = 0 := by
+  rw [formalEdgeSwapDefect_apply, map_add, formalBoundary_edgeCrossProduct, ←
+    SingularMayerVietoris.formalMap_boundary, formalBoundary_edgeCrossProduct, map_sub,
+    formalMap_swap_pointCrossProduct_one, formalMap_swap_edgeCrossProduct_zero]
+  abel
+
+private theorem PeriodTorusHigherHomology.formalMap_edgeSwapDefect {V W V' W' : Type*} (f : V → V')
+    (g : W → W') (c : SingularMayerVietoris.FormalChains V 2)
+    (d : SingularMayerVietoris.FormalChains W 2) :
+    SingularMayerVietoris.formalMap (Prod.map f g) 3 (formalEdgeSwapDefect c d) =
+      formalEdgeSwapDefect (SingularMayerVietoris.formalMap f 2 c)
+        (SingularMayerVietoris.formalMap g 2 d) := by
+  rw [formalEdgeSwapDefect_apply, map_add, formalMap_edgeCrossProduct, formalMap_prod_swap,
+    formalMap_edgeCrossProduct, formalEdgeSwapDefect_apply]
+
+private def PeriodTorusHigherHomology.formalEdgeSwapHomotopy {V W : Type*} :
+    SingularMayerVietoris.FormalChains V 2 →ₗ[ℤ]
+      SingularMayerVietoris.FormalChains W 2 →ₗ[ℤ] SingularMayerVietoris.FormalChains (V × W) 4 :=
+  formalBilinearLift fun v w =>
+    SingularMayerVietoris.formalCone (v 0, w 0) 3
+      (formalEdgeSwapDefect (SingularMayerVietoris.formalSimplex v)
+        (SingularMayerVietoris.formalSimplex w))
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.formalEdgeSwapHomotopy_simplex {V W : Type*} (v : Fin 2 → V)
+    (w : Fin 2 → W) :
+    formalEdgeSwapHomotopy (SingularMayerVietoris.formalSimplex v)
+        (SingularMayerVietoris.formalSimplex w) =
+      SingularMayerVietoris.formalCone (v 0, w 0) 3
+        (formalEdgeSwapDefect (SingularMayerVietoris.formalSimplex v)
+          (SingularMayerVietoris.formalSimplex w)) :=
+  formalBilinearLift_simplex _ _ _
+
+private theorem PeriodTorusHigherHomology.formalEdgeSwapHomotopy_boundary {V W : Type*}
+    (c : SingularMayerVietoris.FormalChains V 2) (d : SingularMayerVietoris.FormalChains W 2) :
+    SingularMayerVietoris.formalBoundary 3 (formalEdgeSwapHomotopy c d) =
+      formalEdgeSwapDefect c d := by
+  have h :
+    (formalEdgeSwapHomotopy (V := V) (W := W)).compr₂ (SingularMayerVietoris.formalBoundary 3) =
+      formalEdgeSwapDefect := by
+    apply formalChains_bilinear_ext
+    intro v w
+    simp only [LinearMap.compr₂_apply, formalEdgeSwapHomotopy_simplex,
+      SingularMayerVietoris.formalBoundary_cone, formalBoundary_edgeSwapDefect, map_zero,
+      sub_zero]
+  exact LinearMap.congr_fun (LinearMap.congr_fun h c) d
+
+private theorem
+    PeriodTorusHigherHomology.formalMap_edgeSwapHomotopy {V W V' W' : Type*} (f : V → V')
+    (g : W → W') (c : SingularMayerVietoris.FormalChains V 2)
+    (d : SingularMayerVietoris.FormalChains W 2) :
+    SingularMayerVietoris.formalMap (Prod.map f g) 4 (formalEdgeSwapHomotopy c d) =
+      formalEdgeSwapHomotopy (SingularMayerVietoris.formalMap f 2 c)
+        (SingularMayerVietoris.formalMap g 2 d) := by
+  have h :
+    (formalEdgeSwapHomotopy (V := V) (W := W)).compr₂
+        (SingularMayerVietoris.formalMap (Prod.map f g) 4) =
+      ((formalEdgeSwapHomotopy).compl₂ (SingularMayerVietoris.formalMap g 2)).comp
+        (SingularMayerVietoris.formalMap f 2) := by
+    apply formalChains_bilinear_ext
+    intro v w
+    simp only [LinearMap.compr₂_apply, LinearMap.compl₂_apply, LinearMap.comp_apply,
+      SingularMayerVietoris.formalMap_simplex, formalEdgeSwapHomotopy_simplex]
+    rw [SingularMayerVietoris.formalMap_cone, formalMap_edgeSwapDefect,
+      SingularMayerVietoris.formalMap_simplex, SingularMayerVietoris.formalMap_simplex]
+    rfl
+  exact LinearMap.congr_fun (LinearMap.congr_fun h c) d
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.prodSwap_productAffineSimplex {n p q : ℕ}
+    (v : Fin (n + 1) → FirstHurewicz.Simplex p × FirstHurewicz.Simplex q) :
+    (ContinuousMap.prodSwap :
+            C(FirstHurewicz.Simplex p × FirstHurewicz.Simplex q,
+              FirstHurewicz.Simplex q × FirstHurewicz.Simplex p)).comp
+        (productAffineSimplex v) =
+      productAffineSimplex (Prod.swap ∘ v) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.inducedChain_swap_productAffineChainMap (p q n : ℕ)
+    (c :
+      SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex p × FirstHurewicz.Simplex q)
+        (n + 1)) :
+    FirstHurewicz.inducedChain
+        (ContinuousMap.prodSwap :
+          C(FirstHurewicz.Simplex p × FirstHurewicz.Simplex q,
+            FirstHurewicz.Simplex q × FirstHurewicz.Simplex p))
+        n (productAffineChainMap p q n c) =
+      productAffineChainMap q p n (SingularMayerVietoris.formalMap Prod.swap (n + 1) c) := by
+  have h :
+    (FirstHurewicz.inducedChain
+            (ContinuousMap.prodSwap :
+              C(FirstHurewicz.Simplex p × FirstHurewicz.Simplex q,
+                FirstHurewicz.Simplex q × FirstHurewicz.Simplex p))
+            n).comp
+        (productAffineChainMap p q n) =
+      (productAffineChainMap q p n).comp (SingularMayerVietoris.formalMap Prod.swap (n + 1)) := by
+    apply SingularMayerVietoris.formalChains_ext
+    intro v
+    simp only [LinearMap.comp_apply, productAffineChainMap_simplex,
+      FirstHurewicz.inducedChain_simplex, SingularMayerVietoris.formalMap_simplex,
+      prodSwap_productAffineSimplex]
+  exact LinearMap.congr_fun h c
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.inducedChain_prodMap_swap {X Y X' Y' : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace X'] [TopologicalSpace Y']
+    (f : C(X, X')) (g : C(Y, Y')) (n : ℕ) (c : FirstHurewicz.Chains (Y × X) n) :
+    FirstHurewicz.inducedChain (f.prodMap g) n
+        (FirstHurewicz.inducedChain ContinuousMap.prodSwap n c) =
+      FirstHurewicz.inducedChain ContinuousMap.prodSwap n
+        (FirstHurewicz.inducedChain (g.prodMap f) n c) := by
+  calc
+    _ = FirstHurewicz.inducedChain ((f.prodMap g).comp ContinuousMap.prodSwap) n c :=
+      (LinearMap.congr_fun (FirstHurewicz.inducedChain_comp _ _ n) c).symm
+    _ = FirstHurewicz.inducedChain (ContinuousMap.prodSwap.comp (g.prodMap f)) n c := rfl
+    _ = _ := LinearMap.congr_fun (FirstHurewicz.inducedChain_comp _ _ n) c
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomology.crossProductSwapHomotopy (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] :
+    FirstHurewicz.Chains X 1 →ₗ[ℤ]
+      FirstHurewicz.Chains Y 1 →ₗ[ℤ] FirstHurewicz.Chains (X × Y) 3 :=
+  chainBilinearLift X Y 1 1 fun σ τ =>
+    FirstHurewicz.inducedChain (σ.prodMap τ) 3
+      (productAffineChainMap 1 1 3
+        (formalEdgeSwapHomotopy
+          (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+          (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodTorusHigherHomology.crossProductSwapHomotopy_simplex (X Y : Type)
+    [TopologicalSpace X] [TopologicalSpace Y] (σ : FirstHurewicz.SingularSimplex X 1)
+    (τ : FirstHurewicz.SingularSimplex Y 1) :
+    crossProductSwapHomotopy X Y (FirstHurewicz.simplexChain X 1 σ)
+        (FirstHurewicz.simplexChain Y 1 τ) =
+      FirstHurewicz.inducedChain (σ.prodMap τ) 3
+        (productAffineChainMap 1 1 3
+          (formalEdgeSwapHomotopy
+            (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+            (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1)))) :=
+  chainBilinearLift_simplex X Y 1 1 _ σ τ
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductSwapHomotopy_natural {X Y X' Y' : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace X'] [TopologicalSpace Y']
+    (f : C(X, X')) (g : C(Y, Y')) (a : FirstHurewicz.Chains X 1) (b : FirstHurewicz.Chains Y 1) :
+    FirstHurewicz.inducedChain (f.prodMap g) 3 (crossProductSwapHomotopy X Y a b) =
+      crossProductSwapHomotopy X' Y' (FirstHurewicz.inducedChain f 1 a)
+        (FirstHurewicz.inducedChain g 1 b) := by
+  have h :
+    integerBilinearPostcompose (crossProductSwapHomotopy X Y)
+        (FirstHurewicz.inducedChain (f.prodMap g) 3) =
+      integerBilinearPrecompose (crossProductSwapHomotopy X' Y') (FirstHurewicz.inducedChain f 1)
+        (FirstHurewicz.inducedChain g 1) := by
+    apply chainBilinearMap_ext X Y 1 1
+    intro σ τ
+    simp only [integerBilinearPostcompose_apply, integerBilinearPrecompose_apply,
+      FirstHurewicz.inducedChain_simplex, crossProductSwapHomotopy_simplex]
+    have hc : (f.comp σ).prodMap (g.comp τ) = (f.prodMap g).comp (σ.prodMap τ) := rfl
+    rw [hc, FirstHurewicz.inducedChain_comp]
+    rfl
+  exact LinearMap.congr_fun (LinearMap.congr_fun h a) b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductSwapHomotopy_affineChainMap (p q : ℕ)
+    (a : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex p) 2)
+    (b : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex q) 2) :
+    crossProductSwapHomotopy (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q)
+        (SingularMayerVietoris.affineChainMap p 1 a)
+        (SingularMayerVietoris.affineChainMap q 1 b) =
+      productAffineChainMap p q 3 (formalEdgeSwapHomotopy a b) := by
+  have h :
+    integerBilinearPrecompose
+        (crossProductSwapHomotopy (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q))
+        (SingularMayerVietoris.affineChainMap p 1) (SingularMayerVietoris.affineChainMap q 1) =
+      integerBilinearPostcompose formalEdgeSwapHomotopy (productAffineChainMap p q 3) := by
+    apply integerFormalBilinearMap_ext
+    intro v w
+    simp only [integerBilinearPrecompose_apply, integerBilinearPostcompose_apply,
+      SingularMayerVietoris.affineChainMap_simplex, crossProductSwapHomotopy_simplex]
+    rw [inducedChain_productAffineChainMap]
+    change
+      productAffineChainMap p q 3
+          (SingularMayerVietoris.formalMap
+            (Prod.map (SingularMayerVietoris.affineSimplex v)
+              (SingularMayerVietoris.affineSimplex w))
+            4
+            (formalEdgeSwapHomotopy
+              (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+              (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1)))) =
+        _
+    rw [formalMap_edgeSwapHomotopy, SingularMayerVietoris.formalMap_simplex,
+      SingularMayerVietoris.formalMap_simplex, affineSimplex_stdVertices_image,
+      affineSimplex_stdVertices_image]
+  exact LinearMap.congr_fun (LinearMap.congr_fun h a) b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductSwapHomotopy_boundary_affine (p q : ℕ)
+    (a : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex p) 2)
+    (b : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex q) 2) :
+    ((FirstHurewicz.singularComplex (FirstHurewicz.Simplex p × FirstHurewicz.Simplex q)).d 3
+            2).hom
+        (crossProductSwapHomotopy (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q)
+          (SingularMayerVietoris.affineChainMap p 1 a)
+          (SingularMayerVietoris.affineChainMap q 1 b)) =
+      crossProductEdge (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q) 1
+          (SingularMayerVietoris.affineChainMap p 1 a)
+          (SingularMayerVietoris.affineChainMap q 1 b) +
+        FirstHurewicz.inducedChain ContinuousMap.prodSwap 2
+          (crossProductEdge (FirstHurewicz.Simplex q) (FirstHurewicz.Simplex p) 1
+            (SingularMayerVietoris.affineChainMap q 1 b)
+            (SingularMayerVietoris.affineChainMap p 1 a)) := by
+  rw [crossProductSwapHomotopy_affineChainMap, productAffineChainMap_boundary,
+    formalEdgeSwapHomotopy_boundary, formalEdgeSwapDefect_apply, map_add,
+    crossProductEdge_affineChainMap, crossProductEdge_affineChainMap,
+    inducedChain_swap_productAffineChainMap]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductSwapHomotopy_boundary {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (a : FirstHurewicz.Chains X 1)
+    (b : FirstHurewicz.Chains Y 1) :
+    ((FirstHurewicz.singularComplex (X × Y)).d 3 2).hom (crossProductSwapHomotopy X Y a b) =
+      crossProductEdge X Y 1 a b +
+        FirstHurewicz.inducedChain ContinuousMap.prodSwap 2 (crossProductEdge Y X 1 b a) := by
+  have h :
+    integerBilinearPostcompose (crossProductSwapHomotopy X Y)
+        ((FirstHurewicz.singularComplex (X × Y)).d 3 2).hom =
+      crossProductEdge X Y 1 +
+        integerBilinearPostcompose (integerBilinearFlip (crossProductEdge Y X 1))
+          (FirstHurewicz.inducedChain ContinuousMap.prodSwap 2) := by
+    apply chainBilinearMap_ext X Y 1 1
+    intro σ τ
+    have hstd :=
+      crossProductSwapHomotopy_boundary_affine 1 1
+        (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+        (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+    have hστ := congrArg (FirstHurewicz.inducedChain (σ.prodMap τ) 2) hstd
+    simpa only [integerBilinearPostcompose_apply, integerBilinearFlip_apply, LinearMap.add_apply,
+      map_add, FirstHurewicz.inducedChain_boundary, crossProductSwapHomotopy_natural,
+      inducedChain_prodMap_swap, crossProductEdge_natural,
+      SingularMayerVietoris.affineChainMap_stdVertices, FirstHurewicz.inducedChain_simplex,
+      ContinuousMap.comp_id] using hστ
+  exact LinearMap.congr_fun (LinearMap.congr_fun h a) b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductCycleClasses_add_swap_eq_zero {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y]
+    (a : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 1)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex Y) 1) :
+    crossProductCycleClasses X Y 1 a b +
+        SingularMayerVietoris.singularHomologyMap ContinuousMap.prodSwap 2
+          (crossProductCycleClasses Y X 1 b a) =
+      0 := by
+  change
+    SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex (X × Y)) 2
+          (crossProductCycles X Y 1 a b) +
+        (HomologicalComplex.homologyMap (FirstHurewicz.singularChainMap ContinuousMap.prodSwap)
+              2).hom
+          (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex (Y × X))
+            2 (crossProductCycles Y X 1 b a)) =
+      0
+  rw [SingularMayerVietoris.ModuleHomology.homologyMap_cycleClass, ← map_add]
+  apply
+    (SingularMayerVietoris.ModuleHomology.cycleClass_eq_zero_iff
+        (FirstHurewicz.singularComplex (X × Y)) 2 _).mpr
+  refine ⟨crossProductSwapHomotopy X Y a.1 b.1, ?_⟩
+  rw [Submodule.coe_add, SingularMayerVietoris.ModuleHomology.mapCycles_val]
+  exact crossProductSwapHomotopy_boundary a.1 b.1
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductHomology_add_swap_eq_zero {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (a : SingularMayerVietoris.SingularHomology X 1)
+    (b : SingularMayerVietoris.SingularHomology Y 1) :
+    crossProductHomology X Y 1 a b +
+        SingularMayerVietoris.singularHomologyMap ContinuousMap.prodSwap 2
+          (crossProductHomology Y X 1 b a) =
+      0 := by
+  obtain ⟨a, rfl⟩ :=
+    SingularMayerVietoris.ModuleHomology.cycleClass_surjective (FirstHurewicz.singularComplex X) 1
+      a
+  obtain ⟨b, rfl⟩ :=
+    SingularMayerVietoris.ModuleHomology.cycleClass_surjective (FirstHurewicz.singularComplex Y) 1
+      b
+  rw [crossProductHomology_cycleClass, crossProductHomology_cycleClass]
+  exact crossProductCycleClasses_add_swap_eq_zero a b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomology.crossProductHomology_swap {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] (a : SingularMayerVietoris.SingularHomology X 1)
+    (b : SingularMayerVietoris.SingularHomology Y 1) :
+    SingularMayerVietoris.singularHomologyMap ContinuousMap.prodSwap 2
+        (crossProductHomology X Y 1 a b) =
+      -crossProductHomology Y X 1 b a := by
+  have h := crossProductHomology_add_swap_eq_zero b a
+  exact eq_neg_of_add_eq_zero_right h
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductHomology_pushforward_anticommute {X Z : Type}
+    [TopologicalSpace X] [TopologicalSpace Z] (f : C(X × X, Z))
+    (hf : f.comp ContinuousMap.prodSwap = f) (a b : SingularMayerVietoris.SingularHomology X 1) :
+    SingularMayerVietoris.singularHomologyMap f 2 (crossProductHomology X X 1 a b) =
+      -SingularMayerVietoris.singularHomologyMap f 2 (crossProductHomology X X 1 b a) := by
+  have h :=
+    congrArg (SingularMayerVietoris.singularHomologyMap f 2) (crossProductHomology_swap a b)
+  rw [map_neg] at h
+  have hc :=
+    LinearMap.congr_fun (singularHomologyMap_comp (ContinuousMap.prodSwap : C(X × X, X × X)) f 2)
+      (crossProductHomology X X 1 a b)
+  rw [hf] at hc
+  exact hc.trans h
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomologyPontryagin.product11_skew (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    (a b : SingularMayerVietoris.SingularHomology G 1) : product11 G a b = -product11 G b a :=
+  PeriodTorusHigherHomology.crossProductHomology_pushforward_anticommute (additionMap G)
+    (by ext p; exact add_comm p.2 p.1) a b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomologyPontryagin.product11_self (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)]
+    (a : SingularMayerVietoris.SingularHomology G 1) : product11 G a a = 0 :=
+  skewBilinear_diagonal_zero (product11 G) (product11_skew G) a
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    PeriodTorusHigherHomologyPontryagin.homologyAlternatingTwo (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] :
+    AlternatingMap ℤ (SingularMayerVietoris.SingularHomology G 1)
+      (SingularMayerVietoris.SingularHomology G 2) (Fin 2) :=
+  alternatingOfBilinear (product11 G) (product11_self G)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomologyPontryagin.homologyWedgeTwo (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] :
+    (⋀[ℤ]^2 (SingularMayerVietoris.SingularHomology G 1)) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology G 2 :=
+  exteriorPower.alternatingMapLinearEquiv (homologyAlternatingTwo G)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodTorusHigherHomologyPontryagin.homologyWedgeTwo_apply_ιMulti (G : Type)
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)]
+    (v : Fin 2 → SingularMayerVietoris.SingularHomology G 1) :
+    homologyWedgeTwo G (exteriorPower.ιMulti ℤ 2 v) = product11 G (v 0) (v 1) :=
+  exteriorPower.alternatingMapLinearEquiv_apply_ιMulti _ _
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomologyPontryagin.latticeWedgeTwo (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)]
+    (c : Lattice →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1) :
+    (⋀[ℤ]^2 Lattice) →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 2 :=
+  (homologyWedgeTwo G).comp (exteriorPower.map 2 c)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodTorusHigherHomologyPontryagin.latticeWedgeTwo_apply_ιMulti (G : Type)
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)]
+    (c : Lattice →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1) (v : Fin 2 → Lattice) :
+    latticeWedgeTwo G c (exteriorPower.ιMulti ℤ 2 v) = product11 G (c (v 0)) (c (v 1)) := by
+  change homologyWedgeTwo G (exteriorPower.map 2 c (exteriorPower.ιMulti ℤ 2 v)) = _
+  rw [exteriorPower.map_apply_ιMulti, homologyWedgeTwo_apply_ιMulti]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomologyPontryagin.latticeWedgeTwo_natural {G : Type}
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] {H : Type}
+    [TopologicalSpace H] [AddCommGroup H] [IsTopologicalAddGroup H]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology H 2)] (f : C(G, H))
+    (hf : ∀ x y, f (x + y) = f x + f y)
+    (c : Lattice →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1)
+    (d : Lattice →ₗ[ℤ] SingularMayerVietoris.SingularHomology H 1) (A : Lattice →ₗ[ℤ] Lattice)
+    (hmark : ∀ v, SingularMayerVietoris.singularHomologyMap f 1 (c v) = d (A v)) :
+    (SingularMayerVietoris.singularHomologyMap f 2).comp (latticeWedgeTwo G c) =
+      (latticeWedgeTwo H d).comp (exteriorPower.map 2 A) := by
+  apply exteriorPower.linearMap_ext
+  apply AlternatingMap.ext
+  intro v
+  change
+    SingularMayerVietoris.singularHomologyMap f 2
+        (latticeWedgeTwo G c (exteriorPower.ιMulti ℤ 2 v)) =
+      latticeWedgeTwo H d (exteriorPower.map 2 A (exteriorPower.ιMulti ℤ 2 v))
+  rw [exteriorPower.map_apply_ιMulti, latticeWedgeTwo_apply_ιMulti, latticeWedgeTwo_apply_ιMulti]
+  rw [product_natural f hf 1, hmark, hmark]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    PeriodTorusHigherHomology.integerTrilinearPostcompose {A B C D E : Type*} [AddCommGroup A]
+    [AddCommGroup B] [AddCommGroup C] [AddCommGroup D] [AddCommGroup E] [Module ℤ A] [Module ℤ B]
+    [Module ℤ C] [Module ℤ D] [Module ℤ E] (F : A →ₗ[ℤ] B →ₗ[ℤ] C →ₗ[ℤ] D) (g : D →ₗ[ℤ] E) :
+    A →ₗ[ℤ] B →ₗ[ℤ] C →ₗ[ℤ] E
+    where
+  toFun a := integerBilinearPostcompose (F a) g
+  map_add' a
+    a' := by
+    apply LinearMap.ext
+    intro b
+    apply LinearMap.ext
+    intro c
+    simp only [integerBilinearPostcompose_apply, map_add, LinearMap.add_apply]
+  map_smul' r
+    a := by
+    apply LinearMap.ext
+    intro b
+    apply LinearMap.ext
+    intro c
+    exact
+      (congrArg (fun l : B →ₗ[ℤ] C →ₗ[ℤ] D => g (l b c)) (F.map_smul r a)).trans
+        (g.map_smul r (F a b c))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodTorusHigherHomology.integerTrilinearPostcompose_apply {A B C D E : Type*}
+    [AddCommGroup A] [AddCommGroup B] [AddCommGroup C] [AddCommGroup D] [AddCommGroup E]
+    [Module ℤ A] [Module ℤ B] [Module ℤ C] [Module ℤ D] [Module ℤ E]
+    (F : A →ₗ[ℤ] B →ₗ[ℤ] C →ₗ[ℤ] D) (g : D →ₗ[ℤ] E) (a : A) (b : B) (c : C) :
+    integerTrilinearPostcompose F g a b c = g (F a b c) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomology.integerTrilinearPrecompose {A B C D A' B' C' : Type*}
+    [AddCommGroup A] [AddCommGroup B] [AddCommGroup C] [AddCommGroup D] [AddCommGroup A']
+    [AddCommGroup B'] [AddCommGroup C'] [Module ℤ A] [Module ℤ B] [Module ℤ C] [Module ℤ D]
+    [Module ℤ A'] [Module ℤ B'] [Module ℤ C'] (F : A →ₗ[ℤ] B →ₗ[ℤ] C →ₗ[ℤ] D) (f : A' →ₗ[ℤ] A)
+    (g : B' →ₗ[ℤ] B) (h : C' →ₗ[ℤ] C) : A' →ₗ[ℤ] B' →ₗ[ℤ] C' →ₗ[ℤ] D
+    where
+  toFun a := integerBilinearPrecompose (F (f a)) g h
+  map_add' a
+    a' := by
+    apply LinearMap.ext
+    intro b
+    apply LinearMap.ext
+    intro c
+    simp only [integerBilinearPrecompose_apply, map_add, LinearMap.add_apply]
+  map_smul' r
+    a := by
+    apply LinearMap.ext
+    intro b
+    apply LinearMap.ext
+    intro c
+    exact
+      (congrArg (fun x => F x (g b) (h c)) (f.map_smul r a)).trans
+        (congrArg (fun l : B →ₗ[ℤ] C →ₗ[ℤ] D => l (g b) (h c)) (F.map_smul r (f a)))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.integerTrilinearPrecompose_apply {A B C D A' B' C' : Type*}
+    [AddCommGroup A] [AddCommGroup B] [AddCommGroup C] [AddCommGroup D] [AddCommGroup A']
+    [AddCommGroup B'] [AddCommGroup C'] [Module ℤ A] [Module ℤ B] [Module ℤ C] [Module ℤ D]
+    [Module ℤ A'] [Module ℤ B'] [Module ℤ C'] (F : A →ₗ[ℤ] B →ₗ[ℤ] C →ₗ[ℤ] D) (f : A' →ₗ[ℤ] A)
+    (g : B' →ₗ[ℤ] B) (h : C' →ₗ[ℤ] C) (a : A') (b : B') (c : C') :
+    integerTrilinearPrecompose F f g h a b c = F (f a) (g b) (h c) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    PeriodTorusHigherHomology.integerTrilinearLeftAssociated {A B C D E : Type*} [AddCommGroup A]
+    [AddCommGroup B] [AddCommGroup C] [AddCommGroup D] [AddCommGroup E] [Module ℤ A] [Module ℤ B]
+    [Module ℤ C] [Module ℤ D] [Module ℤ E] (F : A →ₗ[ℤ] B →ₗ[ℤ] D) (G : D →ₗ[ℤ] C →ₗ[ℤ] E) :
+    A →ₗ[ℤ] B →ₗ[ℤ] C →ₗ[ℤ] E
+    where
+  toFun a := integerBilinearPrecompose G (F a) LinearMap.id
+  map_add' a
+    a' := by
+    apply LinearMap.ext
+    intro b
+    apply LinearMap.ext
+    intro c
+    simp only [integerBilinearPrecompose_apply, LinearMap.id_apply, map_add, LinearMap.add_apply]
+  map_smul' r
+    a := by
+    apply LinearMap.ext
+    intro b
+    apply LinearMap.ext
+    intro c
+    exact
+      (congrArg (fun l : B →ₗ[ℤ] D => G (l b) c) (F.map_smul r a)).trans
+        (congrArg (fun l : C →ₗ[ℤ] E => l c) (G.map_smul r (F a b)))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    PeriodTorusHigherHomology.integerTrilinearRightAssociated {A B C D E : Type*} [AddCommGroup A]
+    [AddCommGroup B] [AddCommGroup C] [AddCommGroup D] [AddCommGroup E] [Module ℤ A] [Module ℤ B]
+    [Module ℤ C] [Module ℤ D] [Module ℤ E] (F : A →ₗ[ℤ] D →ₗ[ℤ] E) (G : B →ₗ[ℤ] C →ₗ[ℤ] D) :
+    A →ₗ[ℤ] B →ₗ[ℤ] C →ₗ[ℤ] E
+    where
+  toFun a := integerBilinearPostcompose G (F a)
+  map_add' a
+    a' := by
+    apply LinearMap.ext
+    intro b
+    apply LinearMap.ext
+    intro c
+    simp only [integerBilinearPostcompose_apply, map_add, LinearMap.add_apply]
+  map_smul' r
+    a := by
+    apply LinearMap.ext
+    intro b
+    apply LinearMap.ext
+    intro c
+    exact congrArg (fun l : D →ₗ[ℤ] E => l (G b c)) (F.map_smul r a)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomology.chainTrilinearLift (X Y Z : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] [TopologicalSpace Z] (p q r : ℕ) {M : Type} [AddCommGroup M] [Module ℤ M]
+    (f :
+      FirstHurewicz.SingularSimplex X p →
+        FirstHurewicz.SingularSimplex Y q → FirstHurewicz.SingularSimplex Z r → M) :
+    FirstHurewicz.Chains X p →ₗ[ℤ]
+      FirstHurewicz.Chains Y q →ₗ[ℤ] FirstHurewicz.Chains Z r →ₗ[ℤ] M :=
+  FirstHurewicz.chainLift X p fun σ => chainBilinearLift Y Z q r (f σ)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.chainTrilinearLift_simplex (X Y Z : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] [TopologicalSpace Z] (p q r : ℕ) {M : Type} [AddCommGroup M] [Module ℤ M]
+    (f :
+      FirstHurewicz.SingularSimplex X p →
+        FirstHurewicz.SingularSimplex Y q → FirstHurewicz.SingularSimplex Z r → M)
+    (σ : FirstHurewicz.SingularSimplex X p) (τ : FirstHurewicz.SingularSimplex Y q)
+    (υ : FirstHurewicz.SingularSimplex Z r) :
+    chainTrilinearLift X Y Z p q r f (FirstHurewicz.simplexChain X p σ)
+        (FirstHurewicz.simplexChain Y q τ) (FirstHurewicz.simplexChain Z r υ) =
+      f σ τ υ := by
+  rw [chainTrilinearLift, FirstHurewicz.chainLift_simplex, chainBilinearLift_simplex]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.chainTrilinearMap_ext (X Y Z : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] [TopologicalSpace Z] (p q r : ℕ) {M : Type} [AddCommGroup M] [Module ℤ M]
+    {F G :
+      FirstHurewicz.Chains X p →ₗ[ℤ]
+        FirstHurewicz.Chains Y q →ₗ[ℤ] FirstHurewicz.Chains Z r →ₗ[ℤ] M}
+    (h :
+      ∀ σ τ υ,
+        F (FirstHurewicz.simplexChain X p σ) (FirstHurewicz.simplexChain Y q τ)
+            (FirstHurewicz.simplexChain Z r υ) =
+          G (FirstHurewicz.simplexChain X p σ) (FirstHurewicz.simplexChain Y q τ)
+            (FirstHurewicz.simplexChain Z r υ)) :
+    F = G := by
+  apply FirstHurewicz.chainMap_ext X p
+  intro σ
+  apply chainBilinearMap_ext Y Z q r
+  exact h σ
+
+private theorem
+    PeriodTorusHigherHomology.formalMap_comp_apply {V W Z : Type*} (f : W → Z) (g : V → W)
+    (n : ℕ) (c : SingularMayerVietoris.FormalChains V n) :
+    SingularMayerVietoris.formalMap f n (SingularMayerVietoris.formalMap g n c) =
+      SingularMayerVietoris.formalMap (f ∘ g) n c := by
+  have h :
+    (SingularMayerVietoris.formalMap f n).comp (SingularMayerVietoris.formalMap g n) =
+      SingularMayerVietoris.formalMap (f ∘ g) n := by
+    apply SingularMayerVietoris.formalChains_ext
+    intro v
+    simp only [LinearMap.comp_apply, SingularMayerVietoris.formalMap_simplex, Function.comp_assoc]
+  exact LinearMap.congr_fun h c
+
+private theorem PeriodTorusHigherHomology.formalMap_id_apply {V : Type*} (n : ℕ)
+    (c : SingularMayerVietoris.FormalChains V n) :
+    SingularMayerVietoris.formalMap (id : V → V) n c = c := by
+  have h : SingularMayerVietoris.formalMap (id : V → V) n = LinearMap.id := by
+    apply SingularMayerVietoris.formalChains_ext
+    intro v
+    simp only [SingularMayerVietoris.formalMap_simplex, LinearMap.id_apply]
+    rfl
+  exact LinearMap.congr_fun h c
+
+private theorem PeriodTorusHigherHomology.formalEdgeCrossProduct_point_left {V W Z : Type*} (q : ℕ)
+    (a : SingularMayerVietoris.FormalChains V 1) (b : SingularMayerVietoris.FormalChains W 2)
+    (c : SingularMayerVietoris.FormalChains Z (q + 1)) :
+    SingularMayerVietoris.formalMap (fun p : (V × W) × Z => (p.1.1, (p.1.2, p.2))) (q + 2)
+        (formalEdgeCrossProduct q (formalPointCrossProduct 1 a b) c) =
+      formalPointCrossProduct (q + 1) a (formalEdgeCrossProduct q b c) := by
+  have h :
+    (SingularMayerVietoris.formalMap (fun p : (V × W) × Z => (p.1.1, (p.1.2, p.2))) (q + 2)).comp
+        (((formalEdgeCrossProduct q).flip c).comp ((formalPointCrossProduct 1).flip b)) =
+      (formalPointCrossProduct (q + 1)).flip (formalEdgeCrossProduct q b c) := by
+    apply SingularMayerVietoris.formalChains_ext
+    intro v
+    simp only [LinearMap.comp_apply, LinearMap.flip_apply, formalPointCrossProduct_simplex_left]
+    have hn := formalMap_edgeCrossProduct (fun w : W => (v 0, w)) (id : Z → Z) q b c
+    rw [formalMap_id_apply] at hn
+    rw [← hn, formalMap_comp_apply]
+    rfl
+  exact LinearMap.congr_fun h a
+
+private theorem
+    PeriodTorusHigherHomology.formalEdgeCrossProduct_point_middle {V W Z : Type*} (q : ℕ)
+    (a : SingularMayerVietoris.FormalChains V 2) (b : SingularMayerVietoris.FormalChains W 1)
+    (c : SingularMayerVietoris.FormalChains Z (q + 1)) :
+    SingularMayerVietoris.formalMap (fun p : (V × W) × Z => (p.1.1, (p.1.2, p.2))) (q + 2)
+        (formalEdgeCrossProduct q (formalEdgeCrossProduct 0 a b) c) =
+      formalEdgeCrossProduct q a (formalPointCrossProduct q b c) := by
+  have h :
+    (SingularMayerVietoris.formalMap (fun p : (V × W) × Z => (p.1.1, (p.1.2, p.2))) (q + 2)).comp
+        (((formalEdgeCrossProduct q).flip c).comp (formalEdgeCrossProduct 0 a)) =
+      (formalEdgeCrossProduct q a).comp ((formalPointCrossProduct q).flip c) := by
+    apply SingularMayerVietoris.formalChains_ext
+    intro w
+    simp only [LinearMap.comp_apply, LinearMap.flip_apply]
+    rw [formalEdgeCrossProduct_zero_simplex_right, formalPointCrossProduct_simplex_left]
+    have hl := formalMap_edgeCrossProduct (fun v : V => (v, w 0)) (id : Z → Z) q a c
+    have hr := formalMap_edgeCrossProduct (id : V → V) (fun z : Z => (w 0, z)) q a c
+    rw [formalMap_id_apply] at hl hr
+    rw [← hl, formalMap_comp_apply, ← hr]
+    rfl
+  exact LinearMap.congr_fun h b
+
+private theorem PeriodTorusHigherHomology.formalTriangleCrossProduct_point_right {V W Z : Type*}
+    (a : SingularMayerVietoris.FormalChains V 2) (b : SingularMayerVietoris.FormalChains W 2)
+    (c : SingularMayerVietoris.FormalChains Z 1) :
+    SingularMayerVietoris.formalMap (fun p : (V × W) × Z => (p.1.1, (p.1.2, p.2))) 3
+        (formalTriangleCrossProduct 0 (formalEdgeCrossProduct 1 a b) c) =
+      formalEdgeCrossProduct 1 a (formalEdgeCrossProduct 0 b c) := by
+  have h :
+    (SingularMayerVietoris.formalMap (fun p : (V × W) × Z => (p.1.1, (p.1.2, p.2))) 3).comp
+        (formalTriangleCrossProduct 0 (formalEdgeCrossProduct 1 a b)) =
+      (formalEdgeCrossProduct 1 a).comp (formalEdgeCrossProduct 0 b) := by
+    apply SingularMayerVietoris.formalChains_ext
+    intro z
+    simp only [LinearMap.comp_apply, formalTriangleCrossProduct_zero_simplex_right,
+      formalEdgeCrossProduct_zero_simplex_right, formalMap_comp_apply]
+    have hn := formalMap_edgeCrossProduct (id : V → V) (fun w : W => (w, z 0)) 1 a b
+    rw [formalMap_id_apply] at hn
+    exact hn
+  exact LinearMap.congr_fun h c
+
+private theorem PeriodTorusHigherHomology.formalChains_trilinear_ext {V W Z M : Type*} {n m l : ℕ}
+    [AddCommGroup M] [Module ℤ M]
+    {f g :
+      SingularMayerVietoris.FormalChains V n →ₗ[ℤ]
+        SingularMayerVietoris.FormalChains W m →ₗ[ℤ]
+          SingularMayerVietoris.FormalChains Z l →ₗ[ℤ] M}
+    (h :
+      ∀ v w z,
+        f (SingularMayerVietoris.formalSimplex v) (SingularMayerVietoris.formalSimplex w)
+            (SingularMayerVietoris.formalSimplex z) =
+          g (SingularMayerVietoris.formalSimplex v) (SingularMayerVietoris.formalSimplex w)
+            (SingularMayerVietoris.formalSimplex z)) :
+    f = g := by
+  apply SingularMayerVietoris.formalChains_ext
+  intro v
+  apply formalChains_bilinear_ext
+  exact h v
+
+private def
+    PeriodTorusHigherHomology.formalTrilinearLift {V W Z M : Type*} {n m l : ℕ} [AddCommGroup M]
+    [Module ℤ M] (f : (Fin n → V) → (Fin m → W) → (Fin l → Z) → M) :
+    SingularMayerVietoris.FormalChains V n →ₗ[ℤ]
+      SingularMayerVietoris.FormalChains W m →ₗ[ℤ]
+        SingularMayerVietoris.FormalChains Z l →ₗ[ℤ] M :=
+  SingularMayerVietoris.formalLift fun v => formalBilinearLift (f v)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.formalTrilinearLift_simplex {V W Z M : Type*} {n m l : ℕ}
+    [AddCommGroup M] [Module ℤ M] (f : (Fin n → V) → (Fin m → W) → (Fin l → Z) → M)
+    (v : Fin n → V) (w : Fin m → W) (z : Fin l → Z) :
+    formalTrilinearLift f (SingularMayerVietoris.formalSimplex v)
+        (SingularMayerVietoris.formalSimplex w) (SingularMayerVietoris.formalSimplex z) =
+      f v w z := by simp [formalTrilinearLift]
+
+private def PeriodTorusHigherHomology.formalAssociatorDefect {V W Z : Type*} (q : ℕ) :
+    SingularMayerVietoris.FormalChains V 2 →ₗ[ℤ]
+      SingularMayerVietoris.FormalChains W 2 →ₗ[ℤ]
+        SingularMayerVietoris.FormalChains Z (q + 1) →ₗ[ℤ]
+          SingularMayerVietoris.FormalChains (V × (W × Z)) (q + 3) :=
+  (formalEdgeCrossProduct 1).compr₂
+      ((formalTriangleCrossProduct q).compr₂
+        (SingularMayerVietoris.formalMap (fun p : (V × W) × Z => (p.1.1, (p.1.2, p.2)))
+          (q + 3))) -
+    ((LinearMap.llcomp ℤ (SingularMayerVietoris.FormalChains Z (q + 1))
+              (SingularMayerVietoris.FormalChains (W × Z) (q + 2))
+              (SingularMayerVietoris.FormalChains (V × (W × Z)) (q + 3))).compl₂
+          (formalEdgeCrossProduct q)).comp
+      (formalEdgeCrossProduct (q + 1))
+
+@[simp]
+private theorem PeriodTorusHigherHomology.formalAssociatorDefect_apply {V W Z : Type*} (q : ℕ)
+    (a : SingularMayerVietoris.FormalChains V 2) (b : SingularMayerVietoris.FormalChains W 2)
+    (c : SingularMayerVietoris.FormalChains Z (q + 1)) :
+    formalAssociatorDefect q a b c =
+      SingularMayerVietoris.formalMap (fun p : (V × W) × Z => (p.1.1, (p.1.2, p.2))) (q + 3)
+          (formalTriangleCrossProduct q (formalEdgeCrossProduct 1 a b) c) -
+        formalEdgeCrossProduct (q + 1) a (formalEdgeCrossProduct q b c) :=
+  rfl
+
+private theorem PeriodTorusHigherHomology.formalAssociatorDefect_zero {V W Z : Type*}
+    (a : SingularMayerVietoris.FormalChains V 2) (b : SingularMayerVietoris.FormalChains W 2)
+    (c : SingularMayerVietoris.FormalChains Z 1) : formalAssociatorDefect 0 a b c = 0 := by
+  rw [formalAssociatorDefect_apply, formalTriangleCrossProduct_point_right, sub_self]
+
+private theorem PeriodTorusHigherHomology.formalBoundary_associatorDefect {V W Z : Type*} (q : ℕ)
+    (a : SingularMayerVietoris.FormalChains V 2) (b : SingularMayerVietoris.FormalChains W 2)
+    (c : SingularMayerVietoris.FormalChains Z (q + 2)) :
+    SingularMayerVietoris.formalBoundary (q + 3) (formalAssociatorDefect (q + 1) a b c) =
+      formalAssociatorDefect q a b (SingularMayerVietoris.formalBoundary (q + 1) c) := by
+  simp only [formalAssociatorDefect_apply, map_sub, ← SingularMayerVietoris.formalMap_boundary,
+    formalBoundary_triangleCrossProduct, formalBoundary_edgeCrossProduct, map_add,
+    LinearMap.sub_apply, formalEdgeCrossProduct_point_middle]
+  rw [formalEdgeCrossProduct_point_left (q + 1) (SingularMayerVietoris.formalBoundary 1 a) b c]
+  abel
+
+private theorem PeriodTorusHigherHomology.formalMap_prodAssoc_naturality {V W Z V' W' Z' : Type*}
+    (f : V → V') (g : W → W') (h : Z → Z') (n : ℕ)
+    (c : SingularMayerVietoris.FormalChains ((V × W) × Z) n) :
+    SingularMayerVietoris.formalMap (Prod.map f (Prod.map g h)) n
+        (SingularMayerVietoris.formalMap (fun p : (V × W) × Z => (p.1.1, (p.1.2, p.2))) n c) =
+      SingularMayerVietoris.formalMap (fun p : (V' × W') × Z' => (p.1.1, (p.1.2, p.2))) n
+        (SingularMayerVietoris.formalMap (Prod.map (Prod.map f g) h) n c) := by
+  have heq :
+    (SingularMayerVietoris.formalMap (Prod.map f (Prod.map g h)) n).comp
+        (SingularMayerVietoris.formalMap (fun p : (V × W) × Z => (p.1.1, (p.1.2, p.2))) n) =
+      (SingularMayerVietoris.formalMap (fun p : (V' × W') × Z' => (p.1.1, (p.1.2, p.2))) n).comp
+        (SingularMayerVietoris.formalMap (Prod.map (Prod.map f g) h) n) := by
+    apply SingularMayerVietoris.formalChains_ext
+    intro v
+    simp only [LinearMap.comp_apply, SingularMayerVietoris.formalMap_simplex]
+    rfl
+  exact LinearMap.congr_fun heq c
+
+private theorem
+    PeriodTorusHigherHomology.formalMap_associatorDefect {V W Z V' W' Z' : Type*} (f : V → V')
+    (g : W → W') (h : Z → Z') (q : ℕ) (a : SingularMayerVietoris.FormalChains V 2)
+    (b : SingularMayerVietoris.FormalChains W 2)
+    (c : SingularMayerVietoris.FormalChains Z (q + 1)) :
+    SingularMayerVietoris.formalMap (Prod.map f (Prod.map g h)) (q + 3)
+        (formalAssociatorDefect q a b c) =
+      formalAssociatorDefect q (SingularMayerVietoris.formalMap f 2 a)
+        (SingularMayerVietoris.formalMap g 2 b) (SingularMayerVietoris.formalMap h (q + 1) c) := by
+  rw [formalAssociatorDefect_apply, map_sub, formalMap_prodAssoc_naturality,
+    formalMap_triangleCrossProduct, formalMap_edgeCrossProduct, formalMap_edgeCrossProduct,
+    formalMap_edgeCrossProduct]
+  rfl
+
+private def PeriodTorusHigherHomology.triplePostcomp_mo1973_13949 {V W Z U U' : Type*}
+    {n m l r s : ℕ}
+    (F :
+      SingularMayerVietoris.FormalChains V n →ₗ[ℤ]
+        SingularMayerVietoris.FormalChains W m →ₗ[ℤ]
+          SingularMayerVietoris.FormalChains Z l →ₗ[ℤ] SingularMayerVietoris.FormalChains U r)
+    (f : SingularMayerVietoris.FormalChains U r →ₗ[ℤ] SingularMayerVietoris.FormalChains U' s) :
+    SingularMayerVietoris.FormalChains V n →ₗ[ℤ]
+      SingularMayerVietoris.FormalChains W m →ₗ[ℤ]
+        SingularMayerVietoris.FormalChains Z l →ₗ[ℤ] SingularMayerVietoris.FormalChains U' s :=
+  F.compr₂
+    (LinearMap.llcomp ℤ (SingularMayerVietoris.FormalChains Z l)
+      (SingularMayerVietoris.FormalChains U r) (SingularMayerVietoris.FormalChains U' s) f)
+
+private def PeriodTorusHigherHomology.triplePrecompLast_mo1973_13950 {V W Z Z' U : Type*}
+    {n m l l' r : ℕ}
+    (F :
+      SingularMayerVietoris.FormalChains V n →ₗ[ℤ]
+        SingularMayerVietoris.FormalChains W m →ₗ[ℤ]
+          SingularMayerVietoris.FormalChains Z l →ₗ[ℤ] SingularMayerVietoris.FormalChains U r)
+    (f : SingularMayerVietoris.FormalChains Z' l' →ₗ[ℤ] SingularMayerVietoris.FormalChains Z l) :
+    SingularMayerVietoris.FormalChains V n →ₗ[ℤ]
+      SingularMayerVietoris.FormalChains W m →ₗ[ℤ]
+        SingularMayerVietoris.FormalChains Z' l' →ₗ[ℤ] SingularMayerVietoris.FormalChains U r :=
+  F.compr₂
+    ((LinearMap.llcomp ℤ (SingularMayerVietoris.FormalChains Z' l')
+          (SingularMayerVietoris.FormalChains Z l) (SingularMayerVietoris.FormalChains U r)).flip
+      f)
+
+private def PeriodTorusHigherHomology.formalAssociatorHomotopy {V W Z : Type*} :
+    (q : ℕ) →
+      SingularMayerVietoris.FormalChains V 2 →ₗ[ℤ]
+        SingularMayerVietoris.FormalChains W 2 →ₗ[ℤ]
+          SingularMayerVietoris.FormalChains Z (q + 1) →ₗ[ℤ]
+            SingularMayerVietoris.FormalChains (V × (W × Z)) (q + 4)
+  | 0 => 0
+  | q + 1 =>
+    formalTrilinearLift fun v w z =>
+      SingularMayerVietoris.formalCone (v 0, (w 0, z 0)) (q + 4)
+        (formalAssociatorDefect (q + 1) (SingularMayerVietoris.formalSimplex v)
+            (SingularMayerVietoris.formalSimplex w) (SingularMayerVietoris.formalSimplex z) -
+          formalAssociatorHomotopy q (SingularMayerVietoris.formalSimplex v)
+            (SingularMayerVietoris.formalSimplex w)
+            (SingularMayerVietoris.formalBoundary (q + 1)
+              (SingularMayerVietoris.formalSimplex z)))
+
+@[simp]
+private theorem PeriodTorusHigherHomology.formalAssociatorHomotopy_zero {V W Z : Type*}
+    (a : SingularMayerVietoris.FormalChains V 2) (b : SingularMayerVietoris.FormalChains W 2)
+    (c : SingularMayerVietoris.FormalChains Z 1) : formalAssociatorHomotopy 0 a b c = 0 :=
+  rfl
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.formalAssociatorHomotopy_simplex_succ {V W Z : Type*} (q : ℕ)
+    (v : Fin 2 → V) (w : Fin 2 → W) (z : Fin (q + 2) → Z) :
+    formalAssociatorHomotopy (q + 1) (SingularMayerVietoris.formalSimplex v)
+        (SingularMayerVietoris.formalSimplex w) (SingularMayerVietoris.formalSimplex z) =
+      SingularMayerVietoris.formalCone (v 0, (w 0, z 0)) (q + 4)
+        (formalAssociatorDefect (q + 1) (SingularMayerVietoris.formalSimplex v)
+            (SingularMayerVietoris.formalSimplex w) (SingularMayerVietoris.formalSimplex z) -
+          formalAssociatorHomotopy q (SingularMayerVietoris.formalSimplex v)
+            (SingularMayerVietoris.formalSimplex w)
+            (SingularMayerVietoris.formalBoundary (q + 1)
+              (SingularMayerVietoris.formalSimplex z))) :=
+  formalTrilinearLift_simplex _ _ _ _
+
+private theorem PeriodTorusHigherHomology.formalAssociatorHomotopy_boundary_zero {V W Z : Type*}
+    (a : SingularMayerVietoris.FormalChains V 2) (b : SingularMayerVietoris.FormalChains W 2)
+    (c : SingularMayerVietoris.FormalChains Z 1) :
+    SingularMayerVietoris.formalBoundary 3 (formalAssociatorHomotopy 0 a b c) =
+      formalAssociatorDefect 0 a b c := by
+  rw [formalAssociatorHomotopy_zero, map_zero, formalAssociatorDefect_zero]
+
+private theorem PeriodTorusHigherHomology.formalAssociatorHomotopy_boundary {V W Z : Type*} :
+    ∀ (q : ℕ) (a : SingularMayerVietoris.FormalChains V 2)
+      (b : SingularMayerVietoris.FormalChains W 2)
+      (c : SingularMayerVietoris.FormalChains Z (q + 2)),
+      SingularMayerVietoris.formalBoundary (q + 4) (formalAssociatorHomotopy (q + 1) a b c) +
+          formalAssociatorHomotopy q a b (SingularMayerVietoris.formalBoundary (q + 1) c) =
+        formalAssociatorDefect (q + 1) a b c := by
+  intro q
+  induction q with
+  | zero =>
+    intro a b c
+    have heq :
+      triplePostcomp_mo1973_13949 (formalAssociatorHomotopy (V := V) (W := W) (Z := Z) 1)
+            (SingularMayerVietoris.formalBoundary 4) +
+          triplePrecompLast_mo1973_13950 (formalAssociatorHomotopy 0)
+            (SingularMayerVietoris.formalBoundary 1) =
+        formalAssociatorDefect 1 := by
+      apply formalChains_trilinear_ext
+      intro v w z
+      change
+        SingularMayerVietoris.formalBoundary 4
+              (formalAssociatorHomotopy 1 (SingularMayerVietoris.formalSimplex v)
+                (SingularMayerVietoris.formalSimplex w) (SingularMayerVietoris.formalSimplex z)) +
+            formalAssociatorHomotopy 0 (SingularMayerVietoris.formalSimplex v)
+              (SingularMayerVietoris.formalSimplex w)
+              (SingularMayerVietoris.formalBoundary 1 (SingularMayerVietoris.formalSimplex z)) =
+          formalAssociatorDefect 1 (SingularMayerVietoris.formalSimplex v)
+            (SingularMayerVietoris.formalSimplex w) (SingularMayerVietoris.formalSimplex z)
+      have hz :
+        SingularMayerVietoris.formalBoundary 3
+            (formalAssociatorDefect 1 (SingularMayerVietoris.formalSimplex v)
+                (SingularMayerVietoris.formalSimplex w) (SingularMayerVietoris.formalSimplex z) -
+              formalAssociatorHomotopy 0 (SingularMayerVietoris.formalSimplex v)
+                (SingularMayerVietoris.formalSimplex w)
+                (SingularMayerVietoris.formalBoundary 1
+                  (SingularMayerVietoris.formalSimplex z))) =
+          0 := by
+        rw [map_sub, formalBoundary_associatorDefect, formalAssociatorDefect_zero,
+          formalAssociatorHomotopy_zero, map_zero, sub_self]
+      rw [formalAssociatorHomotopy_simplex_succ, SingularMayerVietoris.formalBoundary_cone, hz,
+        map_zero, sub_zero, sub_add_cancel]
+    exact LinearMap.congr_fun (LinearMap.congr_fun (LinearMap.congr_fun heq a) b) c
+  | succ q ih =>
+    intro a b c
+    have heq :
+      triplePostcomp_mo1973_13949 (formalAssociatorHomotopy (V := V) (W := W) (Z := Z) (q + 2))
+            (SingularMayerVietoris.formalBoundary (q + 5)) +
+          triplePrecompLast_mo1973_13950 (formalAssociatorHomotopy (q + 1))
+            (SingularMayerVietoris.formalBoundary (q + 2)) =
+        formalAssociatorDefect (q + 2) := by
+      apply formalChains_trilinear_ext
+      intro v w z
+      change
+        SingularMayerVietoris.formalBoundary (q + 5)
+              (formalAssociatorHomotopy (q + 2) (SingularMayerVietoris.formalSimplex v)
+                (SingularMayerVietoris.formalSimplex w) (SingularMayerVietoris.formalSimplex z)) +
+            formalAssociatorHomotopy (q + 1) (SingularMayerVietoris.formalSimplex v)
+              (SingularMayerVietoris.formalSimplex w)
+              (SingularMayerVietoris.formalBoundary (q + 2)
+                (SingularMayerVietoris.formalSimplex z)) =
+          formalAssociatorDefect (q + 2) (SingularMayerVietoris.formalSimplex v)
+            (SingularMayerVietoris.formalSimplex w) (SingularMayerVietoris.formalSimplex z)
+      have hp :
+        SingularMayerVietoris.formalBoundary (q + 4)
+            (formalAssociatorHomotopy (q + 1) (SingularMayerVietoris.formalSimplex v)
+              (SingularMayerVietoris.formalSimplex w)
+              (SingularMayerVietoris.formalBoundary (q + 2)
+                (SingularMayerVietoris.formalSimplex z))) =
+          formalAssociatorDefect (q + 1) (SingularMayerVietoris.formalSimplex v)
+            (SingularMayerVietoris.formalSimplex w)
+            (SingularMayerVietoris.formalBoundary (q + 2)
+              (SingularMayerVietoris.formalSimplex z)) := by
+        simpa only [SingularMayerVietoris.formalBoundary_boundary, map_zero, add_zero] using
+          ih (SingularMayerVietoris.formalSimplex v) (SingularMayerVietoris.formalSimplex w)
+            (SingularMayerVietoris.formalBoundary (q + 2) (SingularMayerVietoris.formalSimplex z))
+      have hz :
+        SingularMayerVietoris.formalBoundary (q + 4)
+            (formalAssociatorDefect (q + 2) (SingularMayerVietoris.formalSimplex v)
+                (SingularMayerVietoris.formalSimplex w) (SingularMayerVietoris.formalSimplex z) -
+              formalAssociatorHomotopy (q + 1) (SingularMayerVietoris.formalSimplex v)
+                (SingularMayerVietoris.formalSimplex w)
+                (SingularMayerVietoris.formalBoundary (q + 2)
+                  (SingularMayerVietoris.formalSimplex z))) =
+          0 := by rw [map_sub, formalBoundary_associatorDefect, hp, sub_self]
+      rw [formalAssociatorHomotopy_simplex_succ, SingularMayerVietoris.formalBoundary_cone, hz,
+        map_zero, sub_zero, sub_add_cancel]
+    exact LinearMap.congr_fun (LinearMap.congr_fun (LinearMap.congr_fun heq a) b) c
+
+private theorem PeriodTorusHigherHomology.formalMap_associatorHomotopy {V W Z V' W' Z' : Type*}
+    (f : V → V') (g : W → W') (h : Z → Z') :
+    ∀ (q : ℕ) (a : SingularMayerVietoris.FormalChains V 2)
+      (b : SingularMayerVietoris.FormalChains W 2)
+      (c : SingularMayerVietoris.FormalChains Z (q + 1)),
+      SingularMayerVietoris.formalMap (Prod.map f (Prod.map g h)) (q + 4)
+          (formalAssociatorHomotopy q a b c) =
+        formalAssociatorHomotopy q (SingularMayerVietoris.formalMap f 2 a)
+          (SingularMayerVietoris.formalMap g 2 b) (SingularMayerVietoris.formalMap h (q + 1) c) :=
+  by
+  intro q
+  induction q with
+  | zero =>
+    intro a b c
+    simp only [formalAssociatorHomotopy_zero, map_zero]
+  | succ q ih =>
+    intro a b c
+    have heq :
+      triplePostcomp_mo1973_13949 (formalAssociatorHomotopy (V := V) (W := W) (Z := Z) (q + 1))
+          (SingularMayerVietoris.formalMap (Prod.map f (Prod.map g h)) (q + 5)) =
+        ((triplePrecompLast_mo1973_13950 (formalAssociatorHomotopy (q + 1))
+                  (SingularMayerVietoris.formalMap h (q + 2))).compl₂
+              (SingularMayerVietoris.formalMap g 2)).comp
+          (SingularMayerVietoris.formalMap f 2) := by
+      apply formalChains_trilinear_ext
+      intro v w z
+      change
+        SingularMayerVietoris.formalMap (Prod.map f (Prod.map g h)) (q + 5)
+            (formalAssociatorHomotopy (q + 1) (SingularMayerVietoris.formalSimplex v)
+              (SingularMayerVietoris.formalSimplex w) (SingularMayerVietoris.formalSimplex z)) =
+          formalAssociatorHomotopy (q + 1)
+            (SingularMayerVietoris.formalMap f 2 (SingularMayerVietoris.formalSimplex v))
+            (SingularMayerVietoris.formalMap g 2 (SingularMayerVietoris.formalSimplex w))
+            (SingularMayerVietoris.formalMap h (q + 2) (SingularMayerVietoris.formalSimplex z))
+      simp only [SingularMayerVietoris.formalMap_simplex, formalAssociatorHomotopy_simplex_succ]
+      rw [SingularMayerVietoris.formalMap_cone]
+      congr 1
+      rw [map_sub, formalMap_associatorDefect, ih, SingularMayerVietoris.formalMap_boundary,
+        SingularMayerVietoris.formalMap_simplex, SingularMayerVietoris.formalMap_simplex,
+        SingularMayerVietoris.formalMap_simplex]
+    exact LinearMap.congr_fun (LinearMap.congr_fun (LinearMap.congr_fun heq a) b) c
+
+private def PeriodTorusHigherHomology.tripleAffineSimplex {n p q r : ℕ}
+    (v :
+      Fin (n + 1) →
+        FirstHurewicz.Simplex p × (FirstHurewicz.Simplex q × FirstHurewicz.Simplex r)) :
+    C(FirstHurewicz.Simplex n,
+      FirstHurewicz.Simplex p × (FirstHurewicz.Simplex q × FirstHurewicz.Simplex r)) :=
+  (SingularMayerVietoris.affineSimplex (fun i => (v i).1)).prodMk
+    (productAffineSimplex (fun i => (v i).2))
+
+private theorem PeriodTorusHigherHomology.tripleAffineSimplex_face {n p q r : ℕ}
+    (v :
+      Fin (n + 2) → FirstHurewicz.Simplex p × (FirstHurewicz.Simplex q × FirstHurewicz.Simplex r))
+    (i : Fin (n + 2)) :
+    (tripleAffineSimplex v).comp (FirstHurewicz.simplexFace n i) =
+      tripleAffineSimplex (fun j => v (i.succAbove j)) := by
+  apply ContinuousMap.ext
+  intro t
+  apply Prod.ext
+  · exact
+      congrArg (fun f : C(FirstHurewicz.Simplex n, FirstHurewicz.Simplex p) => f t)
+        (SingularMayerVietoris.affineSimplex_face (fun j => (v j).1) i)
+  · exact
+      congrArg
+        (fun f : C(FirstHurewicz.Simplex n, FirstHurewicz.Simplex q × FirstHurewicz.Simplex r) =>
+          f t)
+        (productAffineSimplex_face (fun j => (v j).2) i)
+
+private def PeriodTorusHigherHomology.tripleAffineChainMap (p q r n : ℕ) :
+    SingularMayerVietoris.FormalChains
+        (FirstHurewicz.Simplex p × (FirstHurewicz.Simplex q × FirstHurewicz.Simplex r))
+        (n + 1) →ₗ[ℤ]
+      FirstHurewicz.Chains
+        (FirstHurewicz.Simplex p × (FirstHurewicz.Simplex q × FirstHurewicz.Simplex r)) n :=
+  SingularMayerVietoris.formalLift fun v => FirstHurewicz.simplexChain _ n (tripleAffineSimplex v)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.tripleAffineChainMap_simplex (p q r n : ℕ)
+    (v :
+      Fin (n + 1) →
+        FirstHurewicz.Simplex p × (FirstHurewicz.Simplex q × FirstHurewicz.Simplex r)) :
+    tripleAffineChainMap p q r n (SingularMayerVietoris.formalSimplex v) =
+      FirstHurewicz.simplexChain _ n (tripleAffineSimplex v) :=
+  SingularMayerVietoris.formalLift_simplex _ _
+
+private theorem PeriodTorusHigherHomology.tripleAffineChainMap_boundary (p q r n : ℕ)
+    (c :
+      SingularMayerVietoris.FormalChains
+        (FirstHurewicz.Simplex p × (FirstHurewicz.Simplex q × FirstHurewicz.Simplex r)) (n + 2)) :
+    ((FirstHurewicz.singularComplex
+                (FirstHurewicz.Simplex p × (FirstHurewicz.Simplex q × FirstHurewicz.Simplex r))).d
+            (n + 1) n).hom
+        (tripleAffineChainMap p q r (n + 1) c) =
+      tripleAffineChainMap p q r n (SingularMayerVietoris.formalBoundary (n + 1) c) := by
+  have h :
+    (((FirstHurewicz.singularComplex
+                  (FirstHurewicz.Simplex p ×
+                    (FirstHurewicz.Simplex q × FirstHurewicz.Simplex r))).d
+              (n + 1) n).hom).comp
+        (tripleAffineChainMap p q r (n + 1)) =
+      (tripleAffineChainMap p q r n).comp (SingularMayerVietoris.formalBoundary (n + 1)) := by
+    apply SingularMayerVietoris.formalChains_ext
+    intro v
+    change
+      ((FirstHurewicz.singularComplex
+                  (FirstHurewicz.Simplex p ×
+                    (FirstHurewicz.Simplex q × FirstHurewicz.Simplex r))).d
+              (n + 1) n).hom
+          (tripleAffineChainMap p q r (n + 1) (SingularMayerVietoris.formalSimplex v)) =
+        _
+    rw [tripleAffineChainMap_simplex, FirstHurewicz.boundary_simplex]
+    change
+      _ =
+        tripleAffineChainMap p q r n
+          (SingularMayerVietoris.formalBoundary (n + 1) (SingularMayerVietoris.formalSimplex v))
+    rw [SingularMayerVietoris.formalBoundary_simplex, map_sum]
+    apply Finset.sum_congr rfl
+    intro i hi
+    rw [map_zsmul, tripleAffineChainMap_simplex, tripleAffineSimplex_face]
+    rfl
+  exact LinearMap.congr_fun h c
+
+private def PeriodTorusHigherHomology.affineProductLeft {a b p q r : ℕ}
+    (v : Fin (a + 1) → FirstHurewicz.Simplex p × FirstHurewicz.Simplex q)
+    (w : Fin (b + 1) → FirstHurewicz.Simplex r) :
+    C(FirstHurewicz.Simplex a × FirstHurewicz.Simplex b,
+      FirstHurewicz.Simplex p × (FirstHurewicz.Simplex q × FirstHurewicz.Simplex r)) :=
+  (Homeomorph.prodAssoc (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q)
+          (FirstHurewicz.Simplex r) :
+        C(_, _)).comp
+    ((productAffineSimplex v).prodMap (SingularMayerVietoris.affineSimplex w))
+
+private def PeriodTorusHigherHomology.affineProductRight {a b p q r : ℕ}
+    (v : Fin (a + 1) → FirstHurewicz.Simplex p)
+    (w : Fin (b + 1) → FirstHurewicz.Simplex q × FirstHurewicz.Simplex r) :
+    C(FirstHurewicz.Simplex a × FirstHurewicz.Simplex b,
+      FirstHurewicz.Simplex p × (FirstHurewicz.Simplex q × FirstHurewicz.Simplex r)) :=
+  (SingularMayerVietoris.affineSimplex v).prodMap (productAffineSimplex w)
+
+private theorem PeriodTorusHigherHomology.affineProductLeft_comp {a b m p q r : ℕ}
+    (v : Fin (a + 1) → FirstHurewicz.Simplex p × FirstHurewicz.Simplex q)
+    (w : Fin (b + 1) → FirstHurewicz.Simplex r)
+    (z : Fin (m + 1) → FirstHurewicz.Simplex a × FirstHurewicz.Simplex b) :
+    (affineProductLeft v w).comp (productAffineSimplex z) =
+      tripleAffineSimplex (fun j => affineProductLeft v w (z j)) := by
+  apply ContinuousMap.ext
+  intro t
+  apply Prod.ext
+  · exact
+      congrArg (fun f : C(FirstHurewicz.Simplex m, FirstHurewicz.Simplex p) => f t)
+        (SingularMayerVietoris.affineSimplex_comp (fun j => (v j).1) (fun j => (z j).1))
+  · apply Prod.ext
+    · exact
+        congrArg (fun f : C(FirstHurewicz.Simplex m, FirstHurewicz.Simplex q) => f t)
+          (SingularMayerVietoris.affineSimplex_comp (fun j => (v j).2) (fun j => (z j).1))
+    · exact
+        congrArg (fun f : C(FirstHurewicz.Simplex m, FirstHurewicz.Simplex r) => f t)
+          (SingularMayerVietoris.affineSimplex_comp w (fun j => (z j).2))
+
+private theorem PeriodTorusHigherHomology.affineProductRight_comp {a b m p q r : ℕ}
+    (v : Fin (a + 1) → FirstHurewicz.Simplex p)
+    (w : Fin (b + 1) → FirstHurewicz.Simplex q × FirstHurewicz.Simplex r)
+    (z : Fin (m + 1) → FirstHurewicz.Simplex a × FirstHurewicz.Simplex b) :
+    (affineProductRight v w).comp (productAffineSimplex z) =
+      tripleAffineSimplex (fun j => affineProductRight v w (z j)) := by
+  apply ContinuousMap.ext
+  intro t
+  apply Prod.ext
+  · exact
+      congrArg (fun f : C(FirstHurewicz.Simplex m, FirstHurewicz.Simplex p) => f t)
+        (SingularMayerVietoris.affineSimplex_comp v (fun j => (z j).1))
+  · apply Prod.ext
+    · exact
+        congrArg (fun f : C(FirstHurewicz.Simplex m, FirstHurewicz.Simplex q) => f t)
+          (SingularMayerVietoris.affineSimplex_comp (fun j => (w j).1) (fun j => (z j).2))
+    · exact
+        congrArg (fun f : C(FirstHurewicz.Simplex m, FirstHurewicz.Simplex r) => f t)
+          (SingularMayerVietoris.affineSimplex_comp (fun j => (w j).2) (fun j => (z j).2))
+
+private theorem PeriodTorusHigherHomology.inducedChain_affineProductLeft {a b m p q r : ℕ}
+    (v : Fin (a + 1) → FirstHurewicz.Simplex p × FirstHurewicz.Simplex q)
+    (w : Fin (b + 1) → FirstHurewicz.Simplex r)
+    (c :
+      SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex a × FirstHurewicz.Simplex b)
+        (m + 1)) :
+    FirstHurewicz.inducedChain (affineProductLeft v w) m (productAffineChainMap a b m c) =
+      tripleAffineChainMap p q r m
+        (SingularMayerVietoris.formalMap (affineProductLeft v w) (m + 1) c) := by
+  have h :
+    (FirstHurewicz.inducedChain (affineProductLeft v w) m).comp (productAffineChainMap a b m) =
+      (tripleAffineChainMap p q r m).comp
+        (SingularMayerVietoris.formalMap (affineProductLeft v w) (m + 1)) := by
+    apply SingularMayerVietoris.formalChains_ext
+    intro z
+    simp only [LinearMap.comp_apply, productAffineChainMap_simplex,
+      FirstHurewicz.inducedChain_simplex, SingularMayerVietoris.formalMap_simplex,
+      tripleAffineChainMap_simplex, affineProductLeft_comp]
+    rfl
+  exact LinearMap.congr_fun h c
+
+private theorem PeriodTorusHigherHomology.inducedChain_affineProductRight {a b m p q r : ℕ}
+    (v : Fin (a + 1) → FirstHurewicz.Simplex p)
+    (w : Fin (b + 1) → FirstHurewicz.Simplex q × FirstHurewicz.Simplex r)
+    (c :
+      SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex a × FirstHurewicz.Simplex b)
+        (m + 1)) :
+    FirstHurewicz.inducedChain (affineProductRight v w) m (productAffineChainMap a b m c) =
+      tripleAffineChainMap p q r m
+        (SingularMayerVietoris.formalMap (affineProductRight v w) (m + 1) c) := by
+  have h :
+    (FirstHurewicz.inducedChain (affineProductRight v w) m).comp (productAffineChainMap a b m) =
+      (tripleAffineChainMap p q r m).comp
+        (SingularMayerVietoris.formalMap (affineProductRight v w) (m + 1)) := by
+    apply SingularMayerVietoris.formalChains_ext
+    intro z
+    simp only [LinearMap.comp_apply, productAffineChainMap_simplex,
+      FirstHurewicz.inducedChain_simplex, SingularMayerVietoris.formalMap_simplex,
+      tripleAffineChainMap_simplex, affineProductRight_comp]
+    rfl
+  exact LinearMap.congr_fun h c
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    PeriodTorusHigherHomology.crossProductAssociatorDefect (X Y Z : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] [TopologicalSpace Z] (n : ℕ) :
+    FirstHurewicz.Chains X 1 →ₗ[ℤ]
+      FirstHurewicz.Chains Y 1 →ₗ[ℤ]
+        FirstHurewicz.Chains Z n →ₗ[ℤ] FirstHurewicz.Chains (X × (Y × Z)) (n + 2) :=
+  integerTrilinearPostcompose
+      (integerTrilinearLeftAssociated (crossProductEdge X Y 1) (crossProductTriangle (X × Y) Z n))
+      (FirstHurewicz.inducedChain (Homeomorph.prodAssoc X Y Z : C(_, _)) (n + 2)) -
+    integerTrilinearRightAssociated (crossProductEdge X (Y × Z) (n + 1)) (crossProductEdge Y Z n)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodTorusHigherHomology.crossProductAssociatorDefect_apply (X Y Z : Type)
+    [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace Z] (n : ℕ)
+    (a : FirstHurewicz.Chains X 1) (b : FirstHurewicz.Chains Y 1) (c : FirstHurewicz.Chains Z n) :
+    crossProductAssociatorDefect X Y Z n a b c =
+      FirstHurewicz.inducedChain (Homeomorph.prodAssoc X Y Z : C(_, _)) (n + 2)
+          (crossProductTriangle (X × Y) Z n (crossProductEdge X Y 1 a b) c) -
+        crossProductEdge X (Y × Z) (n + 1) a (crossProductEdge Y Z n b c) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    PeriodTorusHigherHomology.crossProductAssociatorHomotopy (X Y Z : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] [TopologicalSpace Z] (n : ℕ) :
+    FirstHurewicz.Chains X 1 →ₗ[ℤ]
+      FirstHurewicz.Chains Y 1 →ₗ[ℤ]
+        FirstHurewicz.Chains Z n →ₗ[ℤ] FirstHurewicz.Chains (X × (Y × Z)) (n + 3) :=
+  chainTrilinearLift X Y Z 1 1 n fun σ τ υ =>
+    FirstHurewicz.inducedChain (σ.prodMap (τ.prodMap υ)) (n + 3)
+      (tripleAffineChainMap 1 1 n (n + 3)
+        (formalAssociatorHomotopy n
+          (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+          (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+          (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices n))))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodTorusHigherHomology.crossProductAssociatorHomotopy_simplex (X Y Z : Type)
+    [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace Z] (n : ℕ)
+    (σ : FirstHurewicz.SingularSimplex X 1) (τ : FirstHurewicz.SingularSimplex Y 1)
+    (υ : FirstHurewicz.SingularSimplex Z n) :
+    crossProductAssociatorHomotopy X Y Z n (FirstHurewicz.simplexChain X 1 σ)
+        (FirstHurewicz.simplexChain Y 1 τ) (FirstHurewicz.simplexChain Z n υ) =
+      FirstHurewicz.inducedChain (σ.prodMap (τ.prodMap υ)) (n + 3)
+        (tripleAffineChainMap 1 1 n (n + 3)
+          (formalAssociatorHomotopy n
+            (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+            (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+            (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices n)))) :=
+  chainTrilinearLift_simplex X Y Z 1 1 n _ σ τ υ
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomology.crossProductAssociatorHomotopy_natural {X : Type} {Y : Type}
+    {Z : Type} [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace Z] {X' Y' Z' : Type}
+    [TopologicalSpace X'] [TopologicalSpace Y'] [TopologicalSpace Z'] (f : C(X, X'))
+    (g : C(Y, Y')) (h : C(Z, Z')) (n : ℕ) (a : FirstHurewicz.Chains X 1)
+    (b : FirstHurewicz.Chains Y 1) (c : FirstHurewicz.Chains Z n) :
+    FirstHurewicz.inducedChain (f.prodMap (g.prodMap h)) (n + 3)
+        (crossProductAssociatorHomotopy X Y Z n a b c) =
+      crossProductAssociatorHomotopy X' Y' Z' n (FirstHurewicz.inducedChain f 1 a)
+        (FirstHurewicz.inducedChain g 1 b) (FirstHurewicz.inducedChain h n c) := by
+  have heq :
+    integerTrilinearPostcompose (crossProductAssociatorHomotopy X Y Z n)
+        (FirstHurewicz.inducedChain (f.prodMap (g.prodMap h)) (n + 3)) =
+      integerTrilinearPrecompose (crossProductAssociatorHomotopy X' Y' Z' n)
+        (FirstHurewicz.inducedChain f 1) (FirstHurewicz.inducedChain g 1)
+        (FirstHurewicz.inducedChain h n) := by
+    apply chainTrilinearMap_ext X Y Z 1 1 n
+    intro σ τ υ
+    simp only [integerTrilinearPostcompose_apply, integerTrilinearPrecompose_apply,
+      FirstHurewicz.inducedChain_simplex, crossProductAssociatorHomotopy_simplex]
+    have hc :
+      (f.comp σ).prodMap ((g.comp τ).prodMap (h.comp υ)) =
+        (f.prodMap (g.prodMap h)).comp (σ.prodMap (τ.prodMap υ)) :=
+      rfl
+    rw [hc, FirstHurewicz.inducedChain_comp]
+    rfl
+  exact LinearMap.congr_fun (LinearMap.congr_fun (LinearMap.congr_fun heq a) b) c
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomology.inducedChain_prodAssoc_natural {X : Type} {Y : Type} {Z : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace Z] {X' Y' Z' : Type}
+    [TopologicalSpace X'] [TopologicalSpace Y'] [TopologicalSpace Z'] (f : C(X, X'))
+    (g : C(Y, Y')) (h : C(Z, Z')) (n : ℕ) (c : FirstHurewicz.Chains ((X × Y) × Z) n) :
+    FirstHurewicz.inducedChain (f.prodMap (g.prodMap h)) n
+        (FirstHurewicz.inducedChain (Homeomorph.prodAssoc X Y Z : C(_, _)) n c) =
+      FirstHurewicz.inducedChain (Homeomorph.prodAssoc X' Y' Z' : C(_, _)) n
+        (FirstHurewicz.inducedChain ((f.prodMap g).prodMap h) n c) := by
+  have hc :
+    (f.prodMap (g.prodMap h)).comp (Homeomorph.prodAssoc X Y Z : C(_, _)) =
+      (Homeomorph.prodAssoc X' Y' Z' : C(_, _)).comp ((f.prodMap g).prodMap h) :=
+    rfl
+  have heq := congrArg (fun k => FirstHurewicz.inducedChain k n c) hc
+  simpa only [FirstHurewicz.inducedChain_comp, LinearMap.comp_apply] using heq
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductAssociatorDefect_natural {X : Type} {Y : Type}
+    {Z : Type} [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace Z] {X' Y' Z' : Type}
+    [TopologicalSpace X'] [TopologicalSpace Y'] [TopologicalSpace Z'] (f : C(X, X'))
+    (g : C(Y, Y')) (h : C(Z, Z')) (n : ℕ) (a : FirstHurewicz.Chains X 1)
+    (b : FirstHurewicz.Chains Y 1) (c : FirstHurewicz.Chains Z n) :
+    FirstHurewicz.inducedChain (f.prodMap (g.prodMap h)) (n + 2)
+        (crossProductAssociatorDefect X Y Z n a b c) =
+      crossProductAssociatorDefect X' Y' Z' n (FirstHurewicz.inducedChain f 1 a)
+        (FirstHurewicz.inducedChain g 1 b) (FirstHurewicz.inducedChain h n c) := by
+  simp only [crossProductAssociatorDefect_apply, map_sub, inducedChain_prodAssoc_natural,
+    crossProductTriangle_natural, crossProductEdge_natural]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.productAffineSimplex_stdVertices_image {n p q : ℕ}
+    (v : Fin (n + 1) → FirstHurewicz.Simplex p × FirstHurewicz.Simplex q) :
+    productAffineSimplex v ∘ SingularMayerVietoris.stdVertices n = v := by
+  funext i
+  exact productAffineSimplex_vertex v i
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.prodMap_tripleAffineSimplex {a b c m p q r : ℕ}
+    (v : Fin (a + 1) → FirstHurewicz.Simplex p) (w : Fin (b + 1) → FirstHurewicz.Simplex q)
+    (z : Fin (c + 1) → FirstHurewicz.Simplex r)
+    (t :
+      Fin (m + 1) →
+        FirstHurewicz.Simplex a × (FirstHurewicz.Simplex b × FirstHurewicz.Simplex c)) :
+    ((SingularMayerVietoris.affineSimplex v).prodMap
+            ((SingularMayerVietoris.affineSimplex w).prodMap
+              (SingularMayerVietoris.affineSimplex z))).comp
+        (tripleAffineSimplex t) =
+      tripleAffineSimplex
+        (fun j =>
+          (SingularMayerVietoris.affineSimplex v (t j).1,
+            (SingularMayerVietoris.affineSimplex w (t j).2.1,
+              SingularMayerVietoris.affineSimplex z (t j).2.2))) := by
+  apply ContinuousMap.ext
+  intro s
+  apply Prod.ext
+  · exact
+      congrArg (fun f : C(FirstHurewicz.Simplex m, FirstHurewicz.Simplex p) => f s)
+        (SingularMayerVietoris.affineSimplex_comp v (fun j => (t j).1))
+  · apply Prod.ext
+    · exact
+        congrArg (fun f : C(FirstHurewicz.Simplex m, FirstHurewicz.Simplex q) => f s)
+          (SingularMayerVietoris.affineSimplex_comp w (fun j => (t j).2.1))
+    · exact
+        congrArg (fun f : C(FirstHurewicz.Simplex m, FirstHurewicz.Simplex r) => f s)
+          (SingularMayerVietoris.affineSimplex_comp z (fun j => (t j).2.2))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.inducedChain_tripleAffineChainMap {a b c m p q r : ℕ}
+    (v : Fin (a + 1) → FirstHurewicz.Simplex p) (w : Fin (b + 1) → FirstHurewicz.Simplex q)
+    (z : Fin (c + 1) → FirstHurewicz.Simplex r)
+    (t :
+      SingularMayerVietoris.FormalChains
+        (FirstHurewicz.Simplex a × (FirstHurewicz.Simplex b × FirstHurewicz.Simplex c)) (m + 1)) :
+    FirstHurewicz.inducedChain
+        ((SingularMayerVietoris.affineSimplex v).prodMap
+          ((SingularMayerVietoris.affineSimplex w).prodMap
+            (SingularMayerVietoris.affineSimplex z)))
+        m (tripleAffineChainMap a b c m t) =
+      tripleAffineChainMap p q r m
+        (SingularMayerVietoris.formalMap
+          ((SingularMayerVietoris.affineSimplex v).prodMap
+            ((SingularMayerVietoris.affineSimplex w).prodMap
+              (SingularMayerVietoris.affineSimplex z)))
+          (m + 1) t) := by
+  have h :
+    (FirstHurewicz.inducedChain
+            ((SingularMayerVietoris.affineSimplex v).prodMap
+              ((SingularMayerVietoris.affineSimplex w).prodMap
+                (SingularMayerVietoris.affineSimplex z)))
+            m).comp
+        (tripleAffineChainMap a b c m) =
+      (tripleAffineChainMap p q r m).comp
+        (SingularMayerVietoris.formalMap
+          ((SingularMayerVietoris.affineSimplex v).prodMap
+            ((SingularMayerVietoris.affineSimplex w).prodMap
+              (SingularMayerVietoris.affineSimplex z)))
+          (m + 1)) := by
+    apply SingularMayerVietoris.formalChains_ext
+    intro s
+    simp only [LinearMap.comp_apply, tripleAffineChainMap_simplex,
+      FirstHurewicz.inducedChain_simplex, SingularMayerVietoris.formalMap_simplex,
+      prodMap_tripleAffineSimplex]
+    rfl
+  exact LinearMap.congr_fun h t
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomology.crossProductTriangle_productAffineChainMap_left (p q r n : ℕ)
+    (a : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex p × FirstHurewicz.Simplex q) 3)
+    (b : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex r) (n + 1)) :
+    FirstHurewicz.inducedChain
+        (Homeomorph.prodAssoc (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q)
+            (FirstHurewicz.Simplex r) :
+          C(_, _))
+        (n + 2)
+        (crossProductTriangle (FirstHurewicz.Simplex p × FirstHurewicz.Simplex q)
+          (FirstHurewicz.Simplex r) n (productAffineChainMap p q 2 a)
+          (SingularMayerVietoris.affineChainMap r n b)) =
+      tripleAffineChainMap p q r (n + 2)
+        (SingularMayerVietoris.formalMap
+          (fun x :
+              (FirstHurewicz.Simplex p × FirstHurewicz.Simplex q) × FirstHurewicz.Simplex r =>
+            (x.1.1, (x.1.2, x.2)))
+          (n + 3) (formalTriangleCrossProduct n a b)) := by
+  have h :
+    integerBilinearPostcompose
+        (integerBilinearPrecompose
+          (crossProductTriangle (FirstHurewicz.Simplex p × FirstHurewicz.Simplex q)
+            (FirstHurewicz.Simplex r) n)
+          (productAffineChainMap p q 2) (SingularMayerVietoris.affineChainMap r n))
+        (FirstHurewicz.inducedChain
+          (Homeomorph.prodAssoc (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q)
+              (FirstHurewicz.Simplex r) :
+            C(_, _))
+          (n + 2)) =
+      integerBilinearPostcompose (formalTriangleCrossProduct n)
+        ((tripleAffineChainMap p q r (n + 2)).comp
+          (SingularMayerVietoris.formalMap
+            (fun x :
+                (FirstHurewicz.Simplex p × FirstHurewicz.Simplex q) × FirstHurewicz.Simplex r =>
+              (x.1.1, (x.1.2, x.2)))
+            (n + 3))) := by
+    apply integerFormalBilinearMap_ext
+    intro v w
+    simp only [integerBilinearPostcompose_apply, integerBilinearPrecompose_apply,
+      productAffineChainMap_simplex, SingularMayerVietoris.affineChainMap_simplex,
+      crossProductTriangle_simplex, LinearMap.comp_apply]
+    rw [← LinearMap.comp_apply, ← FirstHurewicz.inducedChain_comp]
+    change
+      FirstHurewicz.inducedChain (affineProductLeft v w) (n + 2)
+          (productAffineChainMap 2 n (n + 2)
+            (formalTriangleCrossProduct n
+              (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 2))
+              (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices n)))) =
+        _
+    rw [inducedChain_affineProductLeft]
+    apply congrArg (tripleAffineChainMap p q r (n + 2))
+    change
+      SingularMayerVietoris.formalMap
+          ((fun x :
+                (FirstHurewicz.Simplex p × FirstHurewicz.Simplex q) × FirstHurewicz.Simplex r =>
+              (x.1.1, (x.1.2, x.2))) ∘
+            Prod.map (productAffineSimplex v) (SingularMayerVietoris.affineSimplex w))
+          (n + 3)
+          (formalTriangleCrossProduct n
+            (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 2))
+            (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices n))) =
+        _
+    rw [← formalMap_comp_apply, formalMap_triangleCrossProduct,
+      SingularMayerVietoris.formalMap_simplex, SingularMayerVietoris.formalMap_simplex,
+      productAffineSimplex_stdVertices_image, affineSimplex_stdVertices_image]
+  exact LinearMap.congr_fun (LinearMap.congr_fun h a) b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductEdge_productAffineChainMap_right (p q r n : ℕ)
+    (a : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex p) 2)
+    (b :
+      SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex q × FirstHurewicz.Simplex r)
+        (n + 1)) :
+    crossProductEdge (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q × FirstHurewicz.Simplex r)
+        n (SingularMayerVietoris.affineChainMap p 1 a) (productAffineChainMap q r n b) =
+      tripleAffineChainMap p q r (n + 1) (formalEdgeCrossProduct n a b) := by
+  have h :
+    integerBilinearPrecompose
+        (crossProductEdge (FirstHurewicz.Simplex p)
+          (FirstHurewicz.Simplex q × FirstHurewicz.Simplex r) n)
+        (SingularMayerVietoris.affineChainMap p 1) (productAffineChainMap q r n) =
+      integerBilinearPostcompose (formalEdgeCrossProduct n)
+        (tripleAffineChainMap p q r (n + 1)) := by
+    apply integerFormalBilinearMap_ext
+    intro v w
+    simp only [integerBilinearPrecompose_apply, integerBilinearPostcompose_apply,
+      SingularMayerVietoris.affineChainMap_simplex, productAffineChainMap_simplex,
+      crossProductEdge_simplex]
+    change
+      FirstHurewicz.inducedChain (affineProductRight v w) (n + 1)
+          (productAffineChainMap 1 n (n + 1)
+            (formalEdgeCrossProduct n
+              (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+              (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices n)))) =
+        _
+    rw [inducedChain_affineProductRight]
+    change
+      tripleAffineChainMap p q r (n + 1)
+          (SingularMayerVietoris.formalMap
+            (Prod.map (SingularMayerVietoris.affineSimplex v) (productAffineSimplex w)) (n + 2)
+            (formalEdgeCrossProduct n
+              (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+              (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices n)))) =
+        _
+    rw [formalMap_edgeCrossProduct, SingularMayerVietoris.formalMap_simplex,
+      SingularMayerVietoris.formalMap_simplex, affineSimplex_stdVertices_image,
+      productAffineSimplex_stdVertices_image]
+  exact LinearMap.congr_fun (LinearMap.congr_fun h a) b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomology.crossProductAssociatorHomotopy_affineChainMap (p q r n : ℕ)
+    (a : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex p) 2)
+    (b : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex q) 2)
+    (c : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex r) (n + 1)) :
+    crossProductAssociatorHomotopy (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q)
+        (FirstHurewicz.Simplex r) n (SingularMayerVietoris.affineChainMap p 1 a)
+        (SingularMayerVietoris.affineChainMap q 1 b)
+        (SingularMayerVietoris.affineChainMap r n c) =
+      tripleAffineChainMap p q r (n + 3) (formalAssociatorHomotopy n a b c) := by
+  have heq :
+    integerTrilinearPrecompose
+        (crossProductAssociatorHomotopy (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q)
+          (FirstHurewicz.Simplex r) n)
+        (SingularMayerVietoris.affineChainMap p 1) (SingularMayerVietoris.affineChainMap q 1)
+        (SingularMayerVietoris.affineChainMap r n) =
+      integerTrilinearPostcompose (formalAssociatorHomotopy n)
+        (tripleAffineChainMap p q r (n + 3)) := by
+    apply SingularMayerVietoris.formalChains_ext
+    intro v
+    apply SingularMayerVietoris.formalChains_ext
+    intro w
+    apply SingularMayerVietoris.formalChains_ext
+    intro z
+    simp only [integerTrilinearPrecompose_apply, integerTrilinearPostcompose_apply,
+      SingularMayerVietoris.affineChainMap_simplex, crossProductAssociatorHomotopy_simplex]
+    rw [inducedChain_tripleAffineChainMap]
+    change
+      tripleAffineChainMap p q r (n + 3)
+          (SingularMayerVietoris.formalMap
+            (Prod.map (SingularMayerVietoris.affineSimplex v)
+              (Prod.map (SingularMayerVietoris.affineSimplex w)
+                (SingularMayerVietoris.affineSimplex z)))
+            (n + 4)
+            (formalAssociatorHomotopy n
+              (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+              (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+              (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices n)))) =
+        _
+    rw [formalMap_associatorHomotopy, SingularMayerVietoris.formalMap_simplex,
+      SingularMayerVietoris.formalMap_simplex, SingularMayerVietoris.formalMap_simplex,
+      affineSimplex_stdVertices_image, affineSimplex_stdVertices_image,
+      affineSimplex_stdVertices_image]
+  exact LinearMap.congr_fun (LinearMap.congr_fun (LinearMap.congr_fun heq a) b) c
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductAssociatorDefect_affineChainMap (p q r n : ℕ)
+    (a : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex p) 2)
+    (b : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex q) 2)
+    (c : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex r) (n + 1)) :
+    crossProductAssociatorDefect (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q)
+        (FirstHurewicz.Simplex r) n (SingularMayerVietoris.affineChainMap p 1 a)
+        (SingularMayerVietoris.affineChainMap q 1 b)
+        (SingularMayerVietoris.affineChainMap r n c) =
+      tripleAffineChainMap p q r (n + 2) (formalAssociatorDefect n a b c) := by
+  simp only [crossProductAssociatorDefect_apply, crossProductEdge_affineChainMap, Nat.reduceAdd,
+    crossProductTriangle_productAffineChainMap_left, crossProductEdge_productAffineChainMap_right,
+    formalAssociatorDefect_apply, map_sub]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomology.crossProductAssociatorHomotopy_boundary_zero_affine (p q r : ℕ)
+    (a : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex p) 2)
+    (b : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex q) 2)
+    (c : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex r) 1) :
+    ((FirstHurewicz.singularComplex
+                (FirstHurewicz.Simplex p × (FirstHurewicz.Simplex q × FirstHurewicz.Simplex r))).d
+            3 2).hom
+        (crossProductAssociatorHomotopy (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q)
+          (FirstHurewicz.Simplex r) 0 (SingularMayerVietoris.affineChainMap p 1 a)
+          (SingularMayerVietoris.affineChainMap q 1 b)
+          (SingularMayerVietoris.affineChainMap r 0 c)) =
+      crossProductAssociatorDefect (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q)
+        (FirstHurewicz.Simplex r) 0 (SingularMayerVietoris.affineChainMap p 1 a)
+        (SingularMayerVietoris.affineChainMap q 1 b)
+        (SingularMayerVietoris.affineChainMap r 0 c) := by
+  rw [crossProductAssociatorHomotopy_affineChainMap, tripleAffineChainMap_boundary,
+    formalAssociatorHomotopy_boundary_zero, crossProductAssociatorDefect_affineChainMap]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomology.crossProductAssociatorHomotopy_boundary_affine (p q r n : ℕ)
+    (a : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex p) 2)
+    (b : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex q) 2)
+    (c : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex r) (n + 2)) :
+    ((FirstHurewicz.singularComplex
+                  (FirstHurewicz.Simplex p ×
+                    (FirstHurewicz.Simplex q × FirstHurewicz.Simplex r))).d
+              (n + 4) (n + 3)).hom
+          (crossProductAssociatorHomotopy (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q)
+            (FirstHurewicz.Simplex r) (n + 1) (SingularMayerVietoris.affineChainMap p 1 a)
+            (SingularMayerVietoris.affineChainMap q 1 b)
+            (SingularMayerVietoris.affineChainMap r (n + 1) c)) +
+        crossProductAssociatorHomotopy (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q)
+          (FirstHurewicz.Simplex r) n (SingularMayerVietoris.affineChainMap p 1 a)
+          (SingularMayerVietoris.affineChainMap q 1 b)
+          (((FirstHurewicz.singularComplex (FirstHurewicz.Simplex r)).d (n + 1) n).hom
+            (SingularMayerVietoris.affineChainMap r (n + 1) c)) =
+      crossProductAssociatorDefect (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q)
+        (FirstHurewicz.Simplex r) (n + 1) (SingularMayerVietoris.affineChainMap p 1 a)
+        (SingularMayerVietoris.affineChainMap q 1 b)
+        (SingularMayerVietoris.affineChainMap r (n + 1) c) := by
+  rw [crossProductAssociatorHomotopy_affineChainMap, tripleAffineChainMap_boundary,
+    SingularMayerVietoris.affineChainMap_boundary, crossProductAssociatorHomotopy_affineChainMap,
+    ← map_add, formalAssociatorHomotopy_boundary, crossProductAssociatorDefect_affineChainMap]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomology.crossProductAssociatorHomotopy_boundary_zero {X Y Z : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace Z] (a : FirstHurewicz.Chains X 1)
+    (b : FirstHurewicz.Chains Y 1) (c : FirstHurewicz.Chains Z 0) :
+    ((FirstHurewicz.singularComplex (X × (Y × Z))).d 3 2).hom
+        (crossProductAssociatorHomotopy X Y Z 0 a b c) =
+      crossProductAssociatorDefect X Y Z 0 a b c := by
+  have heq :
+    integerTrilinearPostcompose (crossProductAssociatorHomotopy X Y Z 0)
+        ((FirstHurewicz.singularComplex (X × (Y × Z))).d 3 2).hom =
+      crossProductAssociatorDefect X Y Z 0 := by
+    apply chainTrilinearMap_ext X Y Z 1 1 0
+    intro σ τ υ
+    have hstd :=
+      crossProductAssociatorHomotopy_boundary_zero_affine 1 1 0
+        (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+        (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+        (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 0))
+    have hστυ := congrArg (FirstHurewicz.inducedChain (σ.prodMap (τ.prodMap υ)) 2) hstd
+    simpa only [integerTrilinearPostcompose_apply, FirstHurewicz.inducedChain_boundary,
+      crossProductAssociatorHomotopy_natural, crossProductAssociatorDefect_natural,
+      SingularMayerVietoris.affineChainMap_stdVertices, FirstHurewicz.inducedChain_simplex,
+      ContinuousMap.comp_id] using hστυ
+  exact LinearMap.congr_fun (LinearMap.congr_fun (LinearMap.congr_fun heq a) b) c
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductAssociatorHomotopy_boundary {X Y Z : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace Z] (n : ℕ)
+    (a : FirstHurewicz.Chains X 1) (b : FirstHurewicz.Chains Y 1)
+    (c : FirstHurewicz.Chains Z (n + 1)) :
+    ((FirstHurewicz.singularComplex (X × (Y × Z))).d (n + 4) (n + 3)).hom
+          (crossProductAssociatorHomotopy X Y Z (n + 1) a b c) +
+        crossProductAssociatorHomotopy X Y Z n a b
+          (((FirstHurewicz.singularComplex Z).d (n + 1) n).hom c) =
+      crossProductAssociatorDefect X Y Z (n + 1) a b c := by
+  have heq :
+    integerTrilinearPostcompose (crossProductAssociatorHomotopy X Y Z (n + 1))
+          ((FirstHurewicz.singularComplex (X × (Y × Z))).d (n + 4) (n + 3)).hom +
+        integerTrilinearPrecompose (crossProductAssociatorHomotopy X Y Z n) LinearMap.id
+          LinearMap.id ((FirstHurewicz.singularComplex Z).d (n + 1) n).hom =
+      crossProductAssociatorDefect X Y Z (n + 1) := by
+    apply chainTrilinearMap_ext X Y Z 1 1 (n + 1)
+    intro σ τ υ
+    have hstd :=
+      crossProductAssociatorHomotopy_boundary_affine 1 1 (n + 1) n
+        (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+        (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+        (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices (n + 1)))
+    have hστυ := congrArg (FirstHurewicz.inducedChain (σ.prodMap (τ.prodMap υ)) (n + 3)) hstd
+    simpa only [integerTrilinearPostcompose_apply, integerTrilinearPrecompose_apply,
+      LinearMap.add_apply, LinearMap.id_apply, map_add, FirstHurewicz.inducedChain_boundary,
+      crossProductAssociatorHomotopy_natural, crossProductAssociatorDefect_natural,
+      SingularMayerVietoris.affineChainMap_stdVertices, FirstHurewicz.inducedChain_simplex,
+      ContinuousMap.comp_id] using hστυ
+  exact LinearMap.congr_fun (LinearMap.congr_fun (LinearMap.congr_fun heq a) b) c
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomology.crossProductAssociatorHomotopy_boundary_of_cycle {X Y Z : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace Z] (n : ℕ)
+    (a : FirstHurewicz.Chains X 1) (b : FirstHurewicz.Chains Y 1) (c : FirstHurewicz.Chains Z n)
+    (hc : ((FirstHurewicz.singularComplex Z).d n (n - 1)).hom c = 0) :
+    ((FirstHurewicz.singularComplex (X × (Y × Z))).d (n + 3) (n + 2)).hom
+        (crossProductAssociatorHomotopy X Y Z n a b c) =
+      crossProductAssociatorDefect X Y Z n a b c := by
+  cases n with
+  | zero => exact crossProductAssociatorHomotopy_boundary_zero a b c
+  | succ
+    n =>
+    have hc' : ((FirstHurewicz.singularComplex Z).d (n + 1) n).hom c = 0 := by
+      simpa only [Nat.succ_sub_one] using hc
+    simpa only [hc', map_zero, add_zero] using crossProductAssociatorHomotopy_boundary n a b c
+
+private theorem PeriodTorusHigherHomology.formalMap_swap_pointCrossProduct_two {V W : Type*}
+    (c : SingularMayerVietoris.FormalChains V 1) (d : SingularMayerVietoris.FormalChains W 3) :
+    SingularMayerVietoris.formalMap Prod.swap 3 (formalPointCrossProduct 2 c d) =
+      formalTriangleCrossProduct 0 d c := by
+  have heq :
+    (formalPointCrossProduct (V := V) (W := W) 2).compr₂
+        (SingularMayerVietoris.formalMap Prod.swap 3) =
+      (formalTriangleCrossProduct 0).flip := by
+    apply formalChains_bilinear_ext
+    intro v w
+    change
+      SingularMayerVietoris.formalMap Prod.swap 3
+          (formalPointCrossProduct 2 (SingularMayerVietoris.formalSimplex v)
+            (SingularMayerVietoris.formalSimplex w)) =
+        formalTriangleCrossProduct 0 (SingularMayerVietoris.formalSimplex w)
+          (SingularMayerVietoris.formalSimplex v)
+    calc
+      _ =
+          SingularMayerVietoris.formalMap Prod.swap 3
+            (SingularMayerVietoris.formalMap (fun z => (v 0, z)) 3
+              (SingularMayerVietoris.formalSimplex w)) :=
+        congrArg (SingularMayerVietoris.formalMap Prod.swap 3)
+          (formalPointCrossProduct_simplex_left 2 v (SingularMayerVietoris.formalSimplex w))
+      _ =
+          SingularMayerVietoris.formalMap (fun z => (z, v 0)) 3
+            (SingularMayerVietoris.formalSimplex w) := by
+        rw [formalMap_comp]
+        rfl
+      _ = _ :=
+        (formalTriangleCrossProduct_zero_simplex_right (SingularMayerVietoris.formalSimplex w)
+            v).symm
+  exact LinearMap.congr_fun (LinearMap.congr_fun heq c) d
+
+private def PeriodTorusHigherHomology.formalMixedSwapDefect {V W : Type*} :
+    SingularMayerVietoris.FormalChains V 3 →ₗ[ℤ]
+      SingularMayerVietoris.FormalChains W 2 →ₗ[ℤ] SingularMayerVietoris.FormalChains (V × W) 4 :=
+  formalTriangleCrossProduct 1 -
+    (formalEdgeCrossProduct 2).flip.compr₂ (SingularMayerVietoris.formalMap Prod.swap 4)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.formalMixedSwapDefect_apply {V W : Type*}
+    (c : SingularMayerVietoris.FormalChains V 3) (d : SingularMayerVietoris.FormalChains W 2) :
+    formalMixedSwapDefect c d =
+      formalTriangleCrossProduct 1 c d -
+        SingularMayerVietoris.formalMap Prod.swap 4 (formalEdgeCrossProduct 2 d c) :=
+  rfl
+
+private theorem PeriodTorusHigherHomology.formalBoundary_mixedSwapDefect {V W : Type*}
+    (c : SingularMayerVietoris.FormalChains V 3) (d : SingularMayerVietoris.FormalChains W 2) :
+    SingularMayerVietoris.formalBoundary 3 (formalMixedSwapDefect c d) =
+      formalEdgeSwapDefect (SingularMayerVietoris.formalBoundary 2 c) d := by
+  rw [formalMixedSwapDefect_apply, map_sub, formalBoundary_triangleCrossProduct, ←
+    SingularMayerVietoris.formalMap_boundary, formalBoundary_edgeCrossProduct, map_sub,
+    formalMap_swap_pointCrossProduct_two, formalEdgeSwapDefect_apply]
+  abel
+
+private theorem PeriodTorusHigherHomology.formalMap_mixedSwapDefect {V W V' W' : Type*} (f : V → V')
+    (g : W → W') (c : SingularMayerVietoris.FormalChains V 3)
+    (d : SingularMayerVietoris.FormalChains W 2) :
+    SingularMayerVietoris.formalMap (Prod.map f g) 4 (formalMixedSwapDefect c d) =
+      formalMixedSwapDefect (SingularMayerVietoris.formalMap f 3 c)
+        (SingularMayerVietoris.formalMap g 2 d) := by
+  rw [formalMixedSwapDefect_apply, map_sub, formalMap_triangleCrossProduct, formalMap_prod_swap,
+    formalMap_edgeCrossProduct, formalMixedSwapDefect_apply]
+
+private def PeriodTorusHigherHomology.formalMixedSwapHomotopy {V W : Type*} :
+    SingularMayerVietoris.FormalChains V 3 →ₗ[ℤ]
+      SingularMayerVietoris.FormalChains W 2 →ₗ[ℤ] SingularMayerVietoris.FormalChains (V × W) 5 :=
+  formalBilinearLift fun v w =>
+    SingularMayerVietoris.formalCone (v 0, w 0) 4
+      (formalMixedSwapDefect (SingularMayerVietoris.formalSimplex v)
+          (SingularMayerVietoris.formalSimplex w) -
+        formalEdgeSwapHomotopy
+          (SingularMayerVietoris.formalBoundary 2 (SingularMayerVietoris.formalSimplex v))
+          (SingularMayerVietoris.formalSimplex w))
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.formalMixedSwapHomotopy_simplex {V W : Type*} (v : Fin 3 → V)
+    (w : Fin 2 → W) :
+    formalMixedSwapHomotopy (SingularMayerVietoris.formalSimplex v)
+        (SingularMayerVietoris.formalSimplex w) =
+      SingularMayerVietoris.formalCone (v 0, w 0) 4
+        (formalMixedSwapDefect (SingularMayerVietoris.formalSimplex v)
+            (SingularMayerVietoris.formalSimplex w) -
+          formalEdgeSwapHomotopy
+            (SingularMayerVietoris.formalBoundary 2 (SingularMayerVietoris.formalSimplex v))
+            (SingularMayerVietoris.formalSimplex w)) :=
+  formalBilinearLift_simplex _ _ _
+
+private theorem PeriodTorusHigherHomology.formalMixedSwapHomotopy_boundary {V W : Type*}
+    (c : SingularMayerVietoris.FormalChains V 3) (d : SingularMayerVietoris.FormalChains W 2) :
+    SingularMayerVietoris.formalBoundary 4 (formalMixedSwapHomotopy c d) +
+        formalEdgeSwapHomotopy (SingularMayerVietoris.formalBoundary 2 c) d =
+      formalMixedSwapDefect c d := by
+  have heq :
+    (formalMixedSwapHomotopy (V := V) (W := W)).compr₂ (SingularMayerVietoris.formalBoundary 4) +
+        (formalEdgeSwapHomotopy).comp (SingularMayerVietoris.formalBoundary 2) =
+      formalMixedSwapDefect := by
+    apply formalChains_bilinear_ext
+    intro v w
+    change
+      SingularMayerVietoris.formalBoundary 4
+            (formalMixedSwapHomotopy (SingularMayerVietoris.formalSimplex v)
+              (SingularMayerVietoris.formalSimplex w)) +
+          formalEdgeSwapHomotopy
+            (SingularMayerVietoris.formalBoundary 2 (SingularMayerVietoris.formalSimplex v))
+            (SingularMayerVietoris.formalSimplex w) =
+        formalMixedSwapDefect (SingularMayerVietoris.formalSimplex v)
+          (SingularMayerVietoris.formalSimplex w)
+    have hz :
+      SingularMayerVietoris.formalBoundary 3
+          (formalMixedSwapDefect (SingularMayerVietoris.formalSimplex v)
+              (SingularMayerVietoris.formalSimplex w) -
+            formalEdgeSwapHomotopy
+              (SingularMayerVietoris.formalBoundary 2 (SingularMayerVietoris.formalSimplex v))
+              (SingularMayerVietoris.formalSimplex w)) =
+        0 := by
+      rw [map_sub, formalBoundary_mixedSwapDefect, formalEdgeSwapHomotopy_boundary, sub_self]
+    rw [formalMixedSwapHomotopy_simplex, SingularMayerVietoris.formalBoundary_cone, hz, map_zero,
+      sub_zero, sub_add_cancel]
+  exact LinearMap.congr_fun (LinearMap.congr_fun heq c) d
+
+private theorem
+    PeriodTorusHigherHomology.formalMap_mixedSwapHomotopy {V W V' W' : Type*} (f : V → V')
+    (g : W → W') (c : SingularMayerVietoris.FormalChains V 3)
+    (d : SingularMayerVietoris.FormalChains W 2) :
+    SingularMayerVietoris.formalMap (Prod.map f g) 5 (formalMixedSwapHomotopy c d) =
+      formalMixedSwapHomotopy (SingularMayerVietoris.formalMap f 3 c)
+        (SingularMayerVietoris.formalMap g 2 d) := by
+  have heq :
+    (formalMixedSwapHomotopy (V := V) (W := W)).compr₂
+        (SingularMayerVietoris.formalMap (Prod.map f g) 5) =
+      ((formalMixedSwapHomotopy).compl₂ (SingularMayerVietoris.formalMap g 2)).comp
+        (SingularMayerVietoris.formalMap f 3) := by
+    apply formalChains_bilinear_ext
+    intro v w
+    simp only [LinearMap.compr₂_apply, LinearMap.compl₂_apply, LinearMap.comp_apply,
+      SingularMayerVietoris.formalMap_simplex, formalMixedSwapHomotopy_simplex]
+    rw [SingularMayerVietoris.formalMap_cone]
+    congr 1
+    rw [map_sub, formalMap_mixedSwapDefect, formalMap_edgeSwapHomotopy,
+      SingularMayerVietoris.formalMap_boundary, SingularMayerVietoris.formalMap_simplex,
+      SingularMayerVietoris.formalMap_simplex]
+  exact LinearMap.congr_fun (LinearMap.congr_fun heq c) d
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    PeriodTorusHigherHomology.crossProductMixedSwapHomotopy (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] :
+    FirstHurewicz.Chains X 2 →ₗ[ℤ]
+      FirstHurewicz.Chains Y 1 →ₗ[ℤ] FirstHurewicz.Chains (X × Y) 4 :=
+  chainBilinearLift X Y 2 1 fun σ τ =>
+    FirstHurewicz.inducedChain (σ.prodMap τ) 4
+      (productAffineChainMap 2 1 4
+        (formalMixedSwapHomotopy
+          (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 2))
+          (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodTorusHigherHomology.crossProductMixedSwapHomotopy_simplex (X Y : Type)
+    [TopologicalSpace X] [TopologicalSpace Y] (σ : FirstHurewicz.SingularSimplex X 2)
+    (τ : FirstHurewicz.SingularSimplex Y 1) :
+    crossProductMixedSwapHomotopy X Y (FirstHurewicz.simplexChain X 2 σ)
+        (FirstHurewicz.simplexChain Y 1 τ) =
+      FirstHurewicz.inducedChain (σ.prodMap τ) 4
+        (productAffineChainMap 2 1 4
+          (formalMixedSwapHomotopy
+            (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 2))
+            (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1)))) :=
+  chainBilinearLift_simplex X Y 2 1 _ σ τ
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductMixedSwapHomotopy_natural {X Y X' Y' : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace X'] [TopologicalSpace Y']
+    (f : C(X, X')) (g : C(Y, Y')) (a : FirstHurewicz.Chains X 2) (b : FirstHurewicz.Chains Y 1) :
+    FirstHurewicz.inducedChain (f.prodMap g) 4 (crossProductMixedSwapHomotopy X Y a b) =
+      crossProductMixedSwapHomotopy X' Y' (FirstHurewicz.inducedChain f 2 a)
+        (FirstHurewicz.inducedChain g 1 b) := by
+  have h :
+    integerBilinearPostcompose (crossProductMixedSwapHomotopy X Y)
+        (FirstHurewicz.inducedChain (f.prodMap g) 4) =
+      integerBilinearPrecompose (crossProductMixedSwapHomotopy X' Y')
+        (FirstHurewicz.inducedChain f 2) (FirstHurewicz.inducedChain g 1) := by
+    apply chainBilinearMap_ext X Y 2 1
+    intro σ τ
+    simp only [integerBilinearPostcompose_apply, integerBilinearPrecompose_apply,
+      FirstHurewicz.inducedChain_simplex, crossProductMixedSwapHomotopy_simplex]
+    have hc : (f.comp σ).prodMap (g.comp τ) = (f.prodMap g).comp (σ.prodMap τ) := rfl
+    rw [hc, FirstHurewicz.inducedChain_comp]
+    rfl
+  exact LinearMap.congr_fun (LinearMap.congr_fun h a) b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductMixedSwapHomotopy_affineChainMap (p q : ℕ)
+    (a : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex p) 3)
+    (b : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex q) 2) :
+    crossProductMixedSwapHomotopy (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q)
+        (SingularMayerVietoris.affineChainMap p 2 a)
+        (SingularMayerVietoris.affineChainMap q 1 b) =
+      productAffineChainMap p q 4 (formalMixedSwapHomotopy a b) := by
+  have h :
+    integerBilinearPrecompose
+        (crossProductMixedSwapHomotopy (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q))
+        (SingularMayerVietoris.affineChainMap p 2) (SingularMayerVietoris.affineChainMap q 1) =
+      integerBilinearPostcompose formalMixedSwapHomotopy (productAffineChainMap p q 4) := by
+    apply integerFormalBilinearMap_ext
+    intro v w
+    simp only [integerBilinearPrecompose_apply, integerBilinearPostcompose_apply,
+      SingularMayerVietoris.affineChainMap_simplex, crossProductMixedSwapHomotopy_simplex]
+    rw [inducedChain_productAffineChainMap]
+    change
+      productAffineChainMap p q 4
+          (SingularMayerVietoris.formalMap
+            (Prod.map (SingularMayerVietoris.affineSimplex v)
+              (SingularMayerVietoris.affineSimplex w))
+            5
+            (formalMixedSwapHomotopy
+              (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 2))
+              (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1)))) =
+        _
+    rw [formalMap_mixedSwapHomotopy, SingularMayerVietoris.formalMap_simplex,
+      SingularMayerVietoris.formalMap_simplex, affineSimplex_stdVertices_image,
+      affineSimplex_stdVertices_image]
+  exact LinearMap.congr_fun (LinearMap.congr_fun h a) b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductMixedSwapHomotopy_boundary_affine (p q : ℕ)
+    (a : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex p) 3)
+    (b : SingularMayerVietoris.FormalChains (FirstHurewicz.Simplex q) 2) :
+    ((FirstHurewicz.singularComplex (FirstHurewicz.Simplex p × FirstHurewicz.Simplex q)).d 4
+              3).hom
+          (crossProductMixedSwapHomotopy (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q)
+            (SingularMayerVietoris.affineChainMap p 2 a)
+            (SingularMayerVietoris.affineChainMap q 1 b)) +
+        crossProductSwapHomotopy (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q)
+          (((FirstHurewicz.singularComplex (FirstHurewicz.Simplex p)).d 2 1).hom
+            (SingularMayerVietoris.affineChainMap p 2 a))
+          (SingularMayerVietoris.affineChainMap q 1 b) =
+      crossProductTriangle (FirstHurewicz.Simplex p) (FirstHurewicz.Simplex q) 1
+          (SingularMayerVietoris.affineChainMap p 2 a)
+          (SingularMayerVietoris.affineChainMap q 1 b) -
+        FirstHurewicz.inducedChain ContinuousMap.prodSwap 3
+          (crossProductEdge (FirstHurewicz.Simplex q) (FirstHurewicz.Simplex p) 2
+            (SingularMayerVietoris.affineChainMap q 1 b)
+            (SingularMayerVietoris.affineChainMap p 2 a)) := by
+  rw [crossProductMixedSwapHomotopy_affineChainMap, productAffineChainMap_boundary,
+    SingularMayerVietoris.affineChainMap_boundary, crossProductSwapHomotopy_affineChainMap,
+    crossProductTriangle_affineChainMap, crossProductEdge_affineChainMap,
+    inducedChain_swap_productAffineChainMap, ← map_add, formalMixedSwapHomotopy_boundary,
+    formalMixedSwapDefect_apply, map_sub]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductMixedSwapHomotopy_boundary {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (a : FirstHurewicz.Chains X 2)
+    (b : FirstHurewicz.Chains Y 1) :
+    ((FirstHurewicz.singularComplex (X × Y)).d 4 3).hom (crossProductMixedSwapHomotopy X Y a b) +
+        crossProductSwapHomotopy X Y (((FirstHurewicz.singularComplex X).d 2 1).hom a) b =
+      crossProductTriangle X Y 1 a b -
+        FirstHurewicz.inducedChain ContinuousMap.prodSwap 3 (crossProductEdge Y X 2 b a) := by
+  have h :
+    integerBilinearPostcompose (crossProductMixedSwapHomotopy X Y)
+          ((FirstHurewicz.singularComplex (X × Y)).d 4 3).hom +
+        integerBilinearPrecompose (crossProductSwapHomotopy X Y)
+          ((FirstHurewicz.singularComplex X).d 2 1).hom LinearMap.id =
+      crossProductTriangle X Y 1 -
+        integerBilinearPostcompose (integerBilinearFlip (crossProductEdge Y X 2))
+          (FirstHurewicz.inducedChain ContinuousMap.prodSwap 3) := by
+    apply chainBilinearMap_ext X Y 2 1
+    intro σ τ
+    have hstd :=
+      crossProductMixedSwapHomotopy_boundary_affine 2 1
+        (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 2))
+        (SingularMayerVietoris.formalSimplex (SingularMayerVietoris.stdVertices 1))
+    have hστ := congrArg (FirstHurewicz.inducedChain (σ.prodMap τ) 3) hstd
+    simpa only [integerBilinearPostcompose_apply, integerBilinearPrecompose_apply,
+      integerBilinearFlip_apply, LinearMap.add_apply, LinearMap.sub_apply, LinearMap.id_apply,
+      map_add, map_sub, FirstHurewicz.inducedChain_boundary,
+      crossProductMixedSwapHomotopy_natural, crossProductSwapHomotopy_natural,
+      inducedChain_prodMap_swap, crossProductTriangle_natural, crossProductEdge_natural,
+      SingularMayerVietoris.affineChainMap_stdVertices, FirstHurewicz.inducedChain_simplex,
+      ContinuousMap.comp_id] using hστ
+  exact LinearMap.congr_fun (LinearMap.congr_fun h a) b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomology.crossProductMixedSwapHomotopy_boundary_of_cycle {X Y : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] (a : FirstHurewicz.Chains X 2)
+    (ha : ((FirstHurewicz.singularComplex X).d 2 1).hom a = 0) (b : FirstHurewicz.Chains Y 1) :
+    ((FirstHurewicz.singularComplex (X × Y)).d 4 3).hom (crossProductMixedSwapHomotopy X Y a b) =
+      crossProductTriangle X Y 1 a b -
+        FirstHurewicz.inducedChain ContinuousMap.prodSwap 3 (crossProductEdge Y X 2 b a) := by
+  simpa only [ha, map_zero, LinearMap.zero_apply, add_zero] using
+    crossProductMixedSwapHomotopy_boundary a b
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomology.crossProductTwoOneCycles (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] :
+    SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2 →ₗ[ℤ]
+      SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex Y) 1 →ₗ[ℤ]
+        SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex (X × Y)) 3
+    where
+  toFun
+    a :=
+    { toFun
+        b :=
+        SingularMayerVietoris.ModuleHomology.mkCycle (FirstHurewicz.singularComplex (X × Y)) 3
+          (crossProductTriangle X Y 1 a.1 b.1)
+          (by
+            change
+              ((FirstHurewicz.singularComplex (X × Y)).d 3 2).hom
+                  (crossProductTriangle X Y 1 a.1 b.1) =
+                0
+            simp only [crossProductTriangle_boundary,
+              SingularMayerVietoris.ModuleHomology.cycle_condition
+                  (FirstHurewicz.singularComplex X) 2 a,
+              SingularMayerVietoris.ModuleHomology.cycle_condition
+                  (FirstHurewicz.singularComplex Y) 1 b,
+              map_zero, LinearMap.zero_apply, zero_add])
+      map_add' b
+        c := by
+        apply Subtype.ext
+        exact (crossProductTriangle X Y 1 a.1).map_add b.1 c.1
+      map_smul' r
+        b := by
+        apply Subtype.ext
+        exact (crossProductTriangle X Y 1 a.1).map_smul r b.1 }
+  map_add' a
+    b := by
+    apply LinearMap.ext
+    intro c
+    apply Subtype.ext
+    exact
+      congrArg (fun f : FirstHurewicz.Chains Y 1 →ₗ[ℤ] FirstHurewicz.Chains (X × Y) 3 => f c.1)
+        ((crossProductTriangle X Y 1).map_add a.1 b.1)
+  map_smul' r
+    a := by
+    apply LinearMap.ext
+    intro c
+    apply Subtype.ext
+    exact
+      congrArg (fun f : FirstHurewicz.Chains Y 1 →ₗ[ℤ] FirstHurewicz.Chains (X × Y) 3 => f c.1)
+        ((crossProductTriangle X Y 1).map_smul r a.1)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.crossProductTwoOneCycles_val (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y]
+    (a : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex Y) 1) :
+    (crossProductTwoOneCycles X Y a b).1 = crossProductTriangle X Y 1 a.1 b.1 :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomology.crossProductHomologyTwoOne (X Y : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] :
+    SingularMayerVietoris.SingularHomology X 2 →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology Y 1 →ₗ[ℤ]
+        SingularMayerVietoris.SingularHomology (X × Y) 3 :=
+  integerBilinearPostcompose (integerBilinearFlip (crossProductHomology Y X 2))
+    (SingularMayerVietoris.singularHomologyMap ContinuousMap.prodSwap 3)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodTorusHigherHomology.crossProductHomologyTwoOne_apply (X Y : Type)
+    [TopologicalSpace X] [TopologicalSpace Y] (a : SingularMayerVietoris.SingularHomology X 2)
+    (b : SingularMayerVietoris.SingularHomology Y 1) :
+    crossProductHomologyTwoOne X Y a b =
+      SingularMayerVietoris.singularHomologyMap ContinuousMap.prodSwap 3
+        (crossProductHomology Y X 2 b a) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductHomologyTwoOne_cycleClass (X Y : Type)
+    [TopologicalSpace X] [TopologicalSpace Y]
+    (a : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 2)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex Y) 1) :
+    crossProductHomologyTwoOne X Y
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex X) 2 a)
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex Y) 1 b) =
+      SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex (X × Y)) 3
+        (crossProductTwoOneCycles X Y a b) := by
+  rw [crossProductHomologyTwoOne_apply, crossProductHomology_cycleClass]
+  change
+    (HomologicalComplex.homologyMap (FirstHurewicz.singularChainMap ContinuousMap.prodSwap) 3).hom
+        (SingularMayerVietoris.ModuleHomology.cycleClass (FirstHurewicz.singularComplex (Y × X)) 3
+          (crossProductCycles Y X 2 b a)) =
+      _
+  rw [SingularMayerVietoris.ModuleHomology.homologyMap_cycleClass]
+  apply Eq.symm
+  apply
+    (SingularMayerVietoris.ModuleHomology.cycleClass_eq_iff
+        (FirstHurewicz.singularComplex (X × Y)) 3 _ _).mpr
+  refine ⟨crossProductMixedSwapHomotopy X Y a.1 b.1, ?_⟩
+  simp only [crossProductTwoOneCycles_val, SingularMayerVietoris.ModuleHomology.mapCycles_val,
+    crossProductCycles_val]
+  exact
+    crossProductMixedSwapHomotopy_boundary_of_cycle a.1
+      (SingularMayerVietoris.ModuleHomology.cycle_condition (FirstHurewicz.singularComplex X) 2 a)
+      b.1
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductCycleClasses_associative {X Y Z : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace Z]
+    (a : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex X) 1)
+    (b : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex Y) 1)
+    (c : SingularMayerVietoris.ModuleHomology.Cycle (FirstHurewicz.singularComplex Z) 1) :
+    (HomologicalComplex.homologyMap
+            (FirstHurewicz.singularChainMap (Homeomorph.prodAssoc X Y Z : C(_, _))) 3).hom
+        (SingularMayerVietoris.ModuleHomology.cycleClass
+          (FirstHurewicz.singularComplex ((X × Y) × Z)) 3
+          (crossProductTwoOneCycles (X × Y) Z (crossProductCycles X Y 1 a b) c)) =
+      SingularMayerVietoris.ModuleHomology.cycleClass
+        (FirstHurewicz.singularComplex (X × (Y × Z))) 3
+        (crossProductCycles X (Y × Z) 2 a (crossProductCycles Y Z 1 b c)) := by
+  rw [SingularMayerVietoris.ModuleHomology.homologyMap_cycleClass]
+  apply
+    (SingularMayerVietoris.ModuleHomology.cycleClass_eq_iff
+        (FirstHurewicz.singularComplex (X × (Y × Z))) 3 _ _).mpr
+  refine ⟨crossProductAssociatorHomotopy X Y Z 1 a.1 b.1 c.1, ?_⟩
+  simp only [SingularMayerVietoris.ModuleHomology.mapCycles_val, crossProductTwoOneCycles_val,
+    crossProductCycles_val]
+  exact
+    crossProductAssociatorHomotopy_boundary_of_cycle 1 a.1 b.1 c.1
+      (SingularMayerVietoris.ModuleHomology.cycle_condition (FirstHurewicz.singularComplex Z) 1 c)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductHomology_associative {X Y Z : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace Z]
+    (a : SingularMayerVietoris.SingularHomology X 1)
+    (b : SingularMayerVietoris.SingularHomology Y 1)
+    (c : SingularMayerVietoris.SingularHomology Z 1) :
+    SingularMayerVietoris.singularHomologyMap (Homeomorph.prodAssoc X Y Z : C(_, _)) 3
+        (crossProductHomologyTwoOne (X × Y) Z (crossProductHomology X Y 1 a b) c) =
+      crossProductHomology X (Y × Z) 2 a (crossProductHomology Y Z 1 b c) := by
+  obtain ⟨a, rfl⟩ :=
+    SingularMayerVietoris.ModuleHomology.cycleClass_surjective (FirstHurewicz.singularComplex X) 1
+      a
+  obtain ⟨b, rfl⟩ :=
+    SingularMayerVietoris.ModuleHomology.cycleClass_surjective (FirstHurewicz.singularComplex Y) 1
+      b
+  obtain ⟨c, rfl⟩ :=
+    SingularMayerVietoris.ModuleHomology.cycleClass_surjective (FirstHurewicz.singularComplex Z) 1
+      c
+  rw [crossProductHomology_cycleClass, crossProductHomologyTwoOne_cycleClass,
+    crossProductHomology_cycleClass, crossProductHomology_cycleClass]
+  exact crossProductCycleClasses_associative a b c
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomology.crossProductCyclicMap (X Y Z : Type) [TopologicalSpace X]
+    [TopologicalSpace Y] [TopologicalSpace Z] : C(Y × (Z × X), X × (Y × Z)) :=
+  ContinuousMap.prodSwap.comp ((Homeomorph.prodAssoc Y Z X).symm : C(_, _))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.crossProductCyclicMap_assoc_swap {X Y Z : Type}
+    [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace Z] :
+    (crossProductCyclicMap X Y Z).comp
+        ((Homeomorph.prodAssoc Y Z X : C(_, _)).comp ContinuousMap.prodSwap) =
+      ContinuousMap.id (X × (Y × Z)) :=
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomology.crossProductHomology_cyclic {X Y Z : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] [TopologicalSpace Z] (a : SingularMayerVietoris.SingularHomology X 1)
+    (b : SingularMayerVietoris.SingularHomology Y 1)
+    (c : SingularMayerVietoris.SingularHomology Z 1) :
+    crossProductHomology X (Y × Z) 2 a (crossProductHomology Y Z 1 b c) =
+      SingularMayerVietoris.singularHomologyMap (crossProductCyclicMap X Y Z) 3
+        (crossProductHomology Y (Z × X) 2 b (crossProductHomology Z X 1 c a)) := by
+  have h := crossProductHomology_associative b c a
+  rw [crossProductHomologyTwoOne_apply] at h
+  have h' :=
+    congrArg (SingularMayerVietoris.singularHomologyMap (crossProductCyclicMap X Y Z) 3) h
+  have hmap :
+    (SingularMayerVietoris.singularHomologyMap (crossProductCyclicMap X Y Z) 3).comp
+        ((SingularMayerVietoris.singularHomologyMap (Homeomorph.prodAssoc Y Z X : C(_, _)) 3).comp
+          (SingularMayerVietoris.singularHomologyMap
+            (ContinuousMap.prodSwap : C(X × (Y × Z), (Y × Z) × X)) 3)) =
+      LinearMap.id := by
+    rw [← singularHomologyMap_comp, ← singularHomologyMap_comp, crossProductCyclicMap_assoc_swap,
+      singularHomologyMap_id]
+  exact
+    (LinearMap.congr_fun hmap
+          (crossProductHomology X (Y × Z) 2 a (crossProductHomology Y Z 1 b c))).symm.trans
+      h'
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomologyPontryagin.tripleProduct_cyclic (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    (a b c : SingularMayerVietoris.SingularHomology G 1) :
+    tripleProduct G a b c = tripleProduct G b c a := by
+  rw [tripleProduct_eq_cross G a b c, tripleProduct_eq_cross G b c a,
+    PeriodTorusHigherHomology.crossProductHomology_cyclic]
+  have he : PeriodTorusHigherHomology.crossProductCyclicMap G G G = cyclicMap G G G := by
+    apply ContinuousMap.ext
+    intro p
+    rfl
+  rw [he]
+  exact
+    LinearMap.congr_fun (rightAddition_homology_cyclic G 3)
+      (PeriodTorusHigherHomology.crossProductHomology G (G × G) 2 b
+        (PeriodTorusHigherHomology.crossProductHomology G G 1 c a))
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomologyPontryagin.tripleProduct_self12 (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)]
+    (a b : SingularMayerVietoris.SingularHomology G 1) : tripleProduct G a b b = 0 := by
+  rw [tripleProduct_apply, product11_self, map_zero]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomologyPontryagin.tripleProduct_self02 (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)]
+    (a b : SingularMayerVietoris.SingularHomology G 1) : tripleProduct G a b a = 0 :=
+  (tripleProduct_cyclic G a b a).trans (tripleProduct_self12 G b a)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomologyPontryagin.tripleProduct_self01 (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)]
+    (a b : SingularMayerVietoris.SingularHomology G 1) : tripleProduct G a a b = 0 :=
+  (tripleProduct_cyclic G a a b).trans (tripleProduct_self02 G a b)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def
+    PeriodTorusHigherHomologyPontryagin.homologyAlternatingThree (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] :
+    AlternatingMap ℤ (SingularMayerVietoris.SingularHomology G 1)
+      (SingularMayerVietoris.SingularHomology G 3) (Fin 3) :=
+  alternatingOfTrilinear (tripleProduct G) (tripleProduct_self01 G) (tripleProduct_self02 G)
+    (tripleProduct_self12 G)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomologyPontryagin.homologyWedgeThree (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] :
+    (⋀[ℤ]^3 (SingularMayerVietoris.SingularHomology G 1)) →ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology G 3 :=
+  exteriorPower.alternatingMapLinearEquiv (homologyAlternatingThree G)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodTorusHigherHomologyPontryagin.homologyWedgeThree_apply_ιMulti (G : Type)
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)]
+    (v : Fin 3 → SingularMayerVietoris.SingularHomology G 1) :
+    homologyWedgeThree G (exteriorPower.ιMulti ℤ 3 v) = tripleProduct G (v 0) (v 1) (v 2) :=
+  exteriorPower.alternatingMapLinearEquiv_apply_ιMulti _ _
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomologyPontryagin.latticeWedgeThree (G : Type) [TopologicalSpace G]
+    [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)]
+    (c : Lattice →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1) :
+    (⋀[ℤ]^3 Lattice) →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 3 :=
+  (homologyWedgeThree G).comp (exteriorPower.map 3 c)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem PeriodTorusHigherHomologyPontryagin.latticeWedgeThree_apply_ιMulti (G : Type)
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)]
+    (c : Lattice →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1) (v : Fin 3 → Lattice) :
+    latticeWedgeThree G c (exteriorPower.ιMulti ℤ 3 v) =
+      tripleProduct G (c (v 0)) (c (v 1)) (c (v 2)) := by
+  change homologyWedgeThree G (exteriorPower.map 3 c (exteriorPower.ιMulti ℤ 3 v)) = _
+  rw [exteriorPower.map_apply_ιMulti, homologyWedgeThree_apply_ιMulti]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomologyPontryagin.latticeWedgeThree_natural {G : Type}
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] {H : Type}
+    [TopologicalSpace H] [AddCommGroup H] [IsTopologicalAddGroup H]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology H 2)] (f : C(G, H))
+    (hf : ∀ x y, f (x + y) = f x + f y)
+    (c : Lattice →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1)
+    (d : Lattice →ₗ[ℤ] SingularMayerVietoris.SingularHomology H 1) (A : Lattice →ₗ[ℤ] Lattice)
+    (hmark : ∀ v, SingularMayerVietoris.singularHomologyMap f 1 (c v) = d (A v)) :
+    (SingularMayerVietoris.singularHomologyMap f 3).comp (latticeWedgeThree G c) =
+      (latticeWedgeThree H d).comp (exteriorPower.map 3 A) := by
+  apply exteriorPower.linearMap_ext
+  apply AlternatingMap.ext
+  intro v
+  change
+    SingularMayerVietoris.singularHomologyMap f 3
+        (latticeWedgeThree G c (exteriorPower.ιMulti ℤ 3 v)) =
+      latticeWedgeThree H d (exteriorPower.map 3 A (exteriorPower.ιMulti ℤ 3 v))
+  rw [exteriorPower.map_apply_ιMulti, latticeWedgeThree_apply_ιMulti,
+    latticeWedgeThree_apply_ιMulti]
+  rw [tripleProduct_natural f hf, hmark, hmark, hmark]
+  rfl
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomologyPontryagin.product11_mem_range_latticeWedgeTwo (G : Type)
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)]
+    (c : Lattice →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1) (hc : Function.Surjective c)
+    (a b : SingularMayerVietoris.SingularHomology G 1) :
+    product11 G a b ∈ LinearMap.range (latticeWedgeTwo G c) := by
+  obtain ⟨v, rfl⟩ := hc a
+  obtain ⟨w, rfl⟩ := hc b
+  refine ⟨exteriorPower.ιMulti ℤ 2 ![v, w], ?_⟩
+  simp
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem
+    PeriodTorusHigherHomologyPontryagin.tripleProduct_mem_range_latticeWedgeThree (G : Type)
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)]
+    (c : Lattice →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1) (hc : Function.Surjective c)
+    (a b d : SingularMayerVietoris.SingularHomology G 1) :
+    tripleProduct G a b d ∈ LinearMap.range (latticeWedgeThree G c) := by
+  obtain ⟨v, rfl⟩ := hc a
+  obtain ⟨w, rfl⟩ := hc b
+  obtain ⟨u, rfl⟩ := hc d
+  refine ⟨exteriorPower.ιMulti ℤ 3 ![v, w, u], ?_⟩
+  simp
+
+private theorem PeriodTorusHigherHomology.productTorusTopClass_two_is_product :
+    ∃ a b : SingularMayerVietoris.SingularHomology (ProductTorus 2) 1,
+      productTorusTopClass 2 =
+        PeriodTorusHigherHomologyPontryagin.product11 (ProductTorus 2) a b := by
+  refine
+    ⟨FirstHurewicz.loopHomologyClass (coordinatePeriodLoop 2 (Pi.single 0 1)),
+      SingularMayerVietoris.singularHomologyMap (torusTailMap 1) 1 (productTorusTopClass 1), ?_⟩
+  exact productTorusTopClass_succ_product 1
+
+private theorem PeriodTorusHigherHomology.productTorusTopClass_three_is_tripleProduct :
+    ∃ a b c : SingularMayerVietoris.SingularHomology (ProductTorus 3) 1,
+      productTorusTopClass 3 =
+        PeriodTorusHigherHomologyPontryagin.tripleProduct (ProductTorus 3) a b c := by
+  obtain ⟨a, b, hab⟩ := productTorusTopClass_two_is_product
+  refine
+    ⟨FirstHurewicz.loopHomologyClass (coordinatePeriodLoop 3 (Pi.single 0 1)),
+      SingularMayerVietoris.singularHomologyMap (torusTailMap 2) 1 a,
+      SingularMayerVietoris.singularHomologyMap (torusTailMap 2) 1 b, ?_⟩
+  rw [PeriodTorusHigherHomologyPontryagin.tripleProduct_apply,
+    productTorusTopClass_succ_product 2, hab,
+    PeriodTorusHigherHomologyPontryagin.product_natural (torusTailMap 2) (torusTailMap_add 2) 1]
+
+private theorem PeriodTorusHigherHomology.map_topClass_two_mem_range_latticeWedgeTwo {G : Type}
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)]
+    (c : Lattice →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1) (hc : Function.Surjective c)
+    (f : C(ProductTorus 2, G)) (hf : ∀ x y, f (x + y) = f x + f y) :
+    SingularMayerVietoris.singularHomologyMap f 2 (productTorusTopClass 2) ∈
+      LinearMap.range (PeriodTorusHigherHomologyPontryagin.latticeWedgeTwo G c) := by
+  obtain ⟨a, b, hab⟩ := productTorusTopClass_two_is_product
+  rw [hab, PeriodTorusHigherHomologyPontryagin.product_natural f hf 1]
+  exact PeriodTorusHigherHomologyPontryagin.product11_mem_range_latticeWedgeTwo G c hc _ _
+
+private theorem PeriodTorusHigherHomology.map_topClass_three_mem_range_latticeWedgeThree {G : Type}
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)]
+    (c : Lattice →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1) (hc : Function.Surjective c)
+    (f : C(ProductTorus 3, G)) (hf : ∀ x y, f (x + y) = f x + f y) :
+    SingularMayerVietoris.singularHomologyMap f 3 (productTorusTopClass 3) ∈
+      LinearMap.range (PeriodTorusHigherHomologyPontryagin.latticeWedgeThree G c) := by
+  obtain ⟨a, b, d, habd⟩ := productTorusTopClass_three_is_tripleProduct
+  rw [habd, PeriodTorusHigherHomologyPontryagin.tripleProduct_natural f hf]
+  exact PeriodTorusHigherHomologyPontryagin.tripleProduct_mem_range_latticeWedgeThree G c hc _ _ _
+
+private def PeriodTorusHigherHomology.omitHeadMatrix {r n : ℕ} (A : Matrix (Fin r) (Fin n) ℤ) :
+    Matrix (Fin (r + 1)) (Fin n) ℤ :=
+  Fin.cons 0 A
+
+private def PeriodTorusHigherHomology.takeHeadMatrix {r n : ℕ} (A : Matrix (Fin r) (Fin n) ℤ) :
+    Matrix (Fin (r + 1)) (Fin (n + 1)) ℤ :=
+  Fin.cons (Fin.cons 1 0) (fun i => Fin.cons 0 (A i))
+
+private theorem PeriodTorusHigherHomology.torusMatrixMap_omitHeadMatrix {r n : ℕ}
+    (A : Matrix (Fin r) (Fin n) ℤ) (x : ProductTorus n) :
+    torusMatrixMap (omitHeadMatrix A) x = Fin.cons 0 (torusMatrixMap A x) := by
+  have hzero (j : Fin n) : omitHeadMatrix A 0 j = 0 := rfl
+  have hsucc (i : Fin r) (j : Fin n) : omitHeadMatrix A i.succ j = A i j := rfl
+  funext i
+  change (∑ j, omitHeadMatrix A i j • x j) = _
+  refine Fin.cases ?_ (fun i => ?_) i
+  · simp [hzero]
+  · simp [hsucc]
+
+private theorem PeriodTorusHigherHomology.torusMatrixMap_takeHeadMatrix {r n : ℕ}
+    (A : Matrix (Fin r) (Fin n) ℤ) (x : ProductTorus (n + 1)) :
+    torusMatrixMap (takeHeadMatrix A) x = Fin.cons (x 0) (torusMatrixMap A (fun k => x k.succ)) :=
+  by
+  funext i
+  change (∑ j, takeHeadMatrix A i j • x j) = _
+  refine Fin.cases ?_ (fun i => ?_) i
+  · simp [takeHeadMatrix, Fin.sum_univ_succ]
+  · simp [takeHeadMatrix, Fin.sum_univ_succ]
+
+@[simp]
+private theorem PeriodTorusHigherHomology.torusMatrixMap_zero_source {r : ℕ}
+    (A : Matrix (Fin r) (Fin 0) ℤ) : torusMatrixMap A = ContinuousMap.const (ProductTorus 0) 0 := by
+  apply ContinuousMap.ext
+  intro x
+  funext i
+  simp
+
+private def PeriodTorusHigherHomology.coordinateTorusMap :
+    (r n : ℕ) → Fin (r.choose n) → C(ProductTorus n, ProductTorus r)
+  | 0, 0, _ => ContinuousMap.const _ 0
+  | 0, _n + 1, i => Fin.elim0 i
+  | _r + 1, 0, _ => ContinuousMap.const _ 0
+  | r + 1, n + 1, i =>
+    match binomialPascalIndexEquiv r n i with
+    | Sum.inl j =>
+      ((productTorusSuccHomeomorph r).symm :
+            C((PeriodTorusHigherHomology.CircleTopology.Circle) × ProductTorus r,
+              ProductTorus (r + 1))).comp
+        ((CircleTopology.productSection (ProductTorus r)).comp (coordinateTorusMap r (n + 1) j))
+    | Sum.inr j =>
+      ((productTorusSuccHomeomorph r).symm :
+            C((PeriodTorusHigherHomology.CircleTopology.Circle) × ProductTorus r,
+              ProductTorus (r + 1))).comp
+        ((circleProductMap (coordinateTorusMap r n j)).comp
+          (productTorusSuccHomeomorph n :
+            C(ProductTorus (n + 1),
+              (PeriodTorusHigherHomology.CircleTopology.Circle) × ProductTorus n)))
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.coordinateTorusMap_degree_zero (r : ℕ) (i : Fin (r.choose 0)) :
+    coordinateTorusMap r 0 i = ContinuousMap.const _ 0 := by cases r <;> rfl
+
+@[simp]
+private theorem PeriodTorusHigherHomology.coordinateTorusMap_omit_apply (r n : ℕ)
+    (j : Fin (r.choose (n + 1))) (x : ProductTorus (n + 1)) :
+    coordinateTorusMap (r + 1) (n + 1) ((binomialPascalIndexEquiv r n).symm (Sum.inl j)) x =
+      Fin.cons 0 (coordinateTorusMap r (n + 1) j x) := by
+  rw [coordinateTorusMap, Equiv.apply_symm_apply]
+  rfl
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.coordinateTorusMap_take_apply (r n : ℕ) (j : Fin (r.choose n))
+    (x : ProductTorus (n + 1)) :
+    coordinateTorusMap (r + 1) (n + 1) ((binomialPascalIndexEquiv r n).symm (Sum.inr j)) x =
+      Fin.cons (x 0) (coordinateTorusMap r n j (fun k => x k.succ)) := by
+  rw [coordinateTorusMap, Equiv.apply_symm_apply]
+  rfl
+
+private theorem
+    PeriodTorusHigherHomology.coordinateTorusMap_omit (r n : ℕ) (j : Fin (r.choose (n + 1))) :
+    (productTorusSuccHomeomorph r :
+            C(ProductTorus (r + 1),
+              (PeriodTorusHigherHomology.CircleTopology.Circle) × ProductTorus r)).comp
+        (coordinateTorusMap (r + 1) (n + 1) ((binomialPascalIndexEquiv r n).symm (Sum.inl j))) =
+      (CircleTopology.productSection (ProductTorus r)).comp (coordinateTorusMap r (n + 1) j) := by
+  apply ContinuousMap.ext
+  intro x
+  change
+    productTorusSuccHomeomorph r
+        (coordinateTorusMap (r + 1) (n + 1) ((binomialPascalIndexEquiv r n).symm (Sum.inl j)) x) =
+      _
+  rw [coordinateTorusMap_omit_apply]
+  simp only [productTorusSuccHomeomorph_apply, Fin.cons_zero, Fin.cons_succ]
+  rfl
+
+private theorem PeriodTorusHigherHomology.coordinateTorusMap_take (r n : ℕ) (j : Fin (r.choose n)) :
+    (productTorusSuccHomeomorph r :
+            C(ProductTorus (r + 1),
+              (PeriodTorusHigherHomology.CircleTopology.Circle) × ProductTorus r)).comp
+        (coordinateTorusMap (r + 1) (n + 1) ((binomialPascalIndexEquiv r n).symm (Sum.inr j))) =
+      (circleProductMap (coordinateTorusMap r n j)).comp
+        (productTorusSuccHomeomorph n :
+          C(ProductTorus (n + 1),
+            (PeriodTorusHigherHomology.CircleTopology.Circle) × ProductTorus n)) := by
+  apply ContinuousMap.ext
+  intro x
+  change
+    productTorusSuccHomeomorph r
+        (coordinateTorusMap (r + 1) (n + 1) ((binomialPascalIndexEquiv r n).symm (Sum.inr j)) x) =
+      _
+  rw [coordinateTorusMap_take_apply]
+  simp only [productTorusSuccHomeomorph_apply, Fin.cons_zero, Fin.cons_succ]
+  rfl
+
+private def PeriodTorusHigherHomology.coordinateTorusMatrix :
+    (r n : ℕ) → Fin (r.choose n) → Matrix (Fin r) (Fin n) ℤ
+  | 0, 0, _ => 0
+  | 0, _n + 1, i => Fin.elim0 i
+  | _r + 1, 0, _ => 0
+  | r + 1, n + 1, i =>
+    match binomialPascalIndexEquiv r n i with
+    | Sum.inl j => omitHeadMatrix (coordinateTorusMatrix r (n + 1) j)
+    | Sum.inr j => takeHeadMatrix (coordinateTorusMatrix r n j)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.coordinateTorusMatrix_omit (r n : ℕ)
+    (j : Fin (r.choose (n + 1))) :
+    coordinateTorusMatrix (r + 1) (n + 1) ((binomialPascalIndexEquiv r n).symm (Sum.inl j)) =
+      omitHeadMatrix (coordinateTorusMatrix r (n + 1) j) := by
+  rw [coordinateTorusMatrix, Equiv.apply_symm_apply]
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.coordinateTorusMatrix_take (r n : ℕ) (j : Fin (r.choose n)) :
+    coordinateTorusMatrix (r + 1) (n + 1) ((binomialPascalIndexEquiv r n).symm (Sum.inr j)) =
+      takeHeadMatrix (coordinateTorusMatrix r n j) := by
+  rw [coordinateTorusMatrix, Equiv.apply_symm_apply]
+
+private theorem PeriodTorusHigherHomology.coordinateTorusMap_eq_torusMatrixMap (r n : ℕ)
+    (i : Fin (r.choose n)) :
+    coordinateTorusMap r n i = torusMatrixMap (coordinateTorusMatrix r n i) := by
+  induction r generalizing n with
+  | zero =>
+    cases n with
+    | zero => rw [coordinateTorusMap_degree_zero, torusMatrixMap_zero_source]
+    | succ n => exact Fin.elim0 i
+  | succ r ih =>
+    cases n with
+    | zero => rw [coordinateTorusMap_degree_zero, torusMatrixMap_zero_source]
+    | succ n =>
+      obtain ⟨j, rfl⟩ := (binomialPascalIndexEquiv r n).symm.surjective i
+      cases j with
+      | inl j =>
+        apply ContinuousMap.ext
+        intro x
+        rw [coordinateTorusMap_omit_apply, coordinateTorusMatrix_omit,
+          torusMatrixMap_omitHeadMatrix, ih (n + 1) j]
+      | inr j =>
+        apply ContinuousMap.ext
+        intro x
+        rw [coordinateTorusMap_take_apply, coordinateTorusMatrix_take,
+          torusMatrixMap_takeHeadMatrix, ih n j]
+
+private def PeriodTorusHigherHomology.coordinateTorusClass (r n : ℕ) (i : Fin (r.choose n)) :
+    SingularMayerVietoris.SingularHomology (ProductTorus r) n :=
+  SingularMayerVietoris.singularHomologyMap (coordinateTorusMap r n i) n (productTorusTopClass n)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.coordinateTorusClass_zero (r : ℕ) (i : Fin (r.choose 0)) :
+    coordinateTorusClass r 0 i = pointClass (0 : ProductTorus r) := by
+  rw [coordinateTorusClass, productTorusTopClass_zero, singularHomologyMap_pointClass,
+    coordinateTorusMap_degree_zero]
+  rfl
+
+private theorem PeriodTorusHigherHomology.homeomorphHomology_coordinateTorusMap_omit (r n : ℕ)
+    (j : Fin (r.choose (n + 1)))
+    (a : SingularMayerVietoris.SingularHomology (ProductTorus (n + 1)) (n + 1)) :
+    homeomorphHomologyEquiv (productTorusSuccHomeomorph r) (n + 1)
+        (SingularMayerVietoris.singularHomologyMap
+          (coordinateTorusMap (r + 1) (n + 1) ((binomialPascalIndexEquiv r n).symm (Sum.inl j)))
+          (n + 1) a) =
+      circleSectionHomology (ProductTorus r) (n + 1)
+        (SingularMayerVietoris.singularHomologyMap (coordinateTorusMap r (n + 1) j) (n + 1) a) := by
+  change
+    ((SingularMayerVietoris.singularHomologyMap
+              (productTorusSuccHomeomorph r :
+                C(ProductTorus (r + 1),
+                  (PeriodTorusHigherHomology.CircleTopology.Circle) × ProductTorus r))
+              (n + 1)).comp
+          (SingularMayerVietoris.singularHomologyMap
+            (coordinateTorusMap (r + 1) (n + 1) ((binomialPascalIndexEquiv r n).symm (Sum.inl j)))
+            (n + 1)))
+        a =
+      _
+  rw [← singularHomologyMap_comp, coordinateTorusMap_omit, singularHomologyMap_comp]
+  rfl
+
+private theorem PeriodTorusHigherHomology.homeomorphHomology_coordinateTorusMap_take (r n : ℕ)
+    (j : Fin (r.choose n))
+    (a : SingularMayerVietoris.SingularHomology (ProductTorus (n + 1)) (n + 1)) :
+    homeomorphHomologyEquiv (productTorusSuccHomeomorph r) (n + 1)
+        (SingularMayerVietoris.singularHomologyMap
+          (coordinateTorusMap (r + 1) (n + 1) ((binomialPascalIndexEquiv r n).symm (Sum.inr j)))
+          (n + 1) a) =
+      SingularMayerVietoris.singularHomologyMap (circleProductMap (coordinateTorusMap r n j))
+        (n + 1) (homeomorphHomologyEquiv (productTorusSuccHomeomorph n) (n + 1) a) := by
+  change
+    ((SingularMayerVietoris.singularHomologyMap
+              (productTorusSuccHomeomorph r :
+                C(ProductTorus (r + 1),
+                  (PeriodTorusHigherHomology.CircleTopology.Circle) × ProductTorus r))
+              (n + 1)).comp
+          (SingularMayerVietoris.singularHomologyMap
+            (coordinateTorusMap (r + 1) (n + 1) ((binomialPascalIndexEquiv r n).symm (Sum.inr j)))
+            (n + 1)))
+        a =
+      _
+  rw [← singularHomologyMap_comp, coordinateTorusMap_take, singularHomologyMap_comp]
+  rfl
+
+private theorem PeriodTorusHigherHomology.circleCoordinates_coordinateTorusClass_omit (r n : ℕ)
+    (j : Fin (r.choose (n + 1))) :
+    circleProductHomologyEquiv (ProductTorus r) n
+        (homeomorphHomologyEquiv (productTorusSuccHomeomorph r) (n + 1)
+          (coordinateTorusClass (r + 1) (n + 1)
+            ((binomialPascalIndexEquiv r n).symm (Sum.inl j)))) =
+      (coordinateTorusClass r (n + 1) j, 0) := by
+  unfold coordinateTorusClass
+  rw [homeomorphHomology_coordinateTorusMap_omit, circleProductHomologyEquiv_section]
+
+private theorem PeriodTorusHigherHomology.circleCoordinates_coordinateTorusClass_take (r n : ℕ)
+    (j : Fin (r.choose n)) :
+    circleProductHomologyEquiv (ProductTorus r) n
+        (homeomorphHomologyEquiv (productTorusSuccHomeomorph r) (n + 1)
+          (coordinateTorusClass (r + 1) (n + 1)
+            ((binomialPascalIndexEquiv r n).symm (Sum.inr j)))) =
+      (0, coordinateTorusClass r n j) := by
+  unfold coordinateTorusClass
+  rw [homeomorphHomology_coordinateTorusMap_take, circleProductHomologyEquiv_naturality,
+    productTorusTopClass_succ_coordinates, map_zero]
+
+private theorem PeriodTorusHigherHomology.productTorusHomologyEquiv_succ_pair (r n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology (ProductTorus (r + 1)) (n + 1)) :
+    binomialModuleSuccEquiv r n (productTorusHomologyEquiv (r + 1) (n + 1) a) =
+      ((productTorusHomologyEquiv r (n + 1)).toAddEquiv.prodCongr
+          (productTorusHomologyEquiv r n).toAddEquiv)
+        (circleProductHomologyEquiv (ProductTorus r) n
+          (homeomorphHomologyEquiv (productTorusSuccHomeomorph r) (n + 1) a)) :=
+  productTorusHomologyEquiv_succ_apply r n a
+
+private theorem
+    PeriodTorusHigherHomology.productTorusHomologyEquiv_coordinateTorusClass_zero (r : ℕ)
+    (i : Fin (r.choose 0)) :
+    productTorusHomologyEquiv r 0 (coordinateTorusClass r 0 i) = Pi.single i 1 := by
+  rw [coordinateTorusClass_zero, productTorusHomologyEquiv_zero]
+  change
+    integerBinomialZeroEquiv r
+        (connectedHomologyZeroEquiv (ProductTorus r) (pointClass (0 : ProductTorus r))) =
+      _
+  rw [connectedHomologyZeroEquiv_pointClass]
+  exact integerBinomialZeroEquiv_one_single r i
+
+private theorem PeriodTorusHigherHomology.productTorusHomologyEquiv_coordinateTorusClass (r n : ℕ)
+    (i : Fin (r.choose n)) :
+    productTorusHomologyEquiv r n (coordinateTorusClass r n i) = Pi.single i 1 := by
+  induction r generalizing n with
+  | zero =>
+    cases n with
+    | zero => exact productTorusHomologyEquiv_coordinateTorusClass_zero 0 i
+    | succ n => exact Fin.elim0 i
+  | succ r ih =>
+    cases n with
+    | zero => exact productTorusHomologyEquiv_coordinateTorusClass_zero (r + 1) i
+    | succ n =>
+      obtain ⟨j, rfl⟩ := (binomialPascalIndexEquiv r n).symm.surjective i
+      cases j with
+      | inl j =>
+        apply (binomialModuleSuccEquiv r n).injective
+        rw [productTorusHomologyEquiv_succ_pair, circleCoordinates_coordinateTorusClass_omit,
+          binomialModuleSuccEquiv_single_inl]
+        change
+          (productTorusHomologyEquiv r (n + 1) (coordinateTorusClass r (n + 1) j),
+              productTorusHomologyEquiv r n 0) =
+            (Pi.single j 1, 0)
+        rw [ih (n + 1) j, map_zero]
+      | inr j =>
+        apply (binomialModuleSuccEquiv r n).injective
+        rw [productTorusHomologyEquiv_succ_pair, circleCoordinates_coordinateTorusClass_take,
+          binomialModuleSuccEquiv_single_inr]
+        change
+          (productTorusHomologyEquiv r (n + 1) 0,
+              productTorusHomologyEquiv r n (coordinateTorusClass r n j)) =
+            (0, Pi.single j 1)
+        rw [map_zero, ih n j]
+
+private def PeriodTorusHigherHomology.coordinateTorusBasis (r n : ℕ) :
+    Module.Basis (Fin (r.choose n)) ℤ
+      (SingularMayerVietoris.SingularHomology (ProductTorus r) n) :=
+  (binomialCoordinateBasis r n).map (productTorusHomologyEquiv r n).symm
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.coordinateTorusBasis_apply (r n : ℕ) (i : Fin (r.choose n)) :
+    coordinateTorusBasis r n i = coordinateTorusClass r n i := by
+  apply (productTorusHomologyEquiv r n).injective
+  rw [coordinateTorusBasis, Module.Basis.map_apply, LinearEquiv.apply_symm_apply,
+    binomialCoordinateBasis_apply, productTorusHomologyEquiv_coordinateTorusClass]
+
+private def PeriodTorusHigherHomology.realTorusHomologyEquiv (n : ℕ) :
+    SingularMayerVietoris.SingularHomology RealTorus₄ n ≃ₗ[ℤ] binomialModule 4 n :=
+  (homeomorphHomologyEquiv flatTorusCircleHomeomorph n).trans (productTorusHomologyEquiv 4 n)
+
+private def PeriodTorusHigherHomology.periodTorusHomologyEquiv (p : PeriodDomain) (n : ℕ) :
+    SingularMayerVietoris.SingularHomology p.Torus n ≃ₗ[ℤ] binomialModule 4 n :=
+  (homeomorphHomologyEquiv (periodTorusCircleHomeomorph p) n).trans
+    (productTorusHomologyEquiv 4 n)
+
+@[simp]
+private theorem PeriodTorusHigherHomology.realTorusHomologyEquiv_apply (n : ℕ)
+    (a : SingularMayerVietoris.SingularHomology RealTorus₄ n) :
+    realTorusHomologyEquiv n a =
+      productTorusHomologyEquiv 4 n
+        (SingularMayerVietoris.singularHomologyMap
+          (flatTorusCircleHomeomorph : C(RealTorus₄, ProductTorus 4)) n a) :=
+  rfl
+
+private theorem PeriodTorusHigherHomology.realTorus_homology_free (n : ℕ) :
+    Module.Free ℤ (SingularMayerVietoris.SingularHomology RealTorus₄ n) :=
+  Module.Free.of_equiv (realTorusHomologyEquiv n).symm
+
+private theorem PeriodTorusHigherHomology.realTorus_homology_finite (n : ℕ) :
+    Module.Finite ℤ (SingularMayerVietoris.SingularHomology RealTorus₄ n) :=
+  Module.Finite.of_surjective (realTorusHomologyEquiv n).symm.toLinearMap
+    (realTorusHomologyEquiv n).symm.surjective
+
+private theorem PeriodTorusHigherHomology.realTorus_homology_finrank (n : ℕ) :
+    Module.finrank ℤ (SingularMayerVietoris.SingularHomology RealTorus₄ n) = Nat.choose 4 n := by
+  rw [(realTorusHomologyEquiv n).finrank_eq]
+  exact binomialModule_finrank 4 n
+
+private theorem PeriodTorusHigherHomology.realTorus_homology_torsionFree (n : ℕ) :
+    Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology RealTorus₄ n) := by
+  let := realTorus_homology_free n
+  infer_instance
+
+public
+theorem PeriodTorusHigherHomology.realTorus_homology_subsingleton_of_lt {n : ℕ} (hn : 4 < n) :
+    Subsingleton (SingularMayerVietoris.SingularHomology RealTorus₄ n) := by
+  let := binomialModule_subsingleton_of_lt hn
+  exact (realTorusHomologyEquiv n).injective.subsingleton
+
+private theorem PeriodTorusHigherHomology.periodTorus_homology_subsingleton_of_lt (p : PeriodDomain)
+    {n : ℕ} (hn : 4 < n) : Subsingleton (SingularMayerVietoris.SingularHomology p.Torus n) := by
+  let := binomialModule_subsingleton_of_lt hn
+  exact (periodTorusHomologyEquiv p n).injective.subsingleton
+
+private def PeriodTorusHigherHomology.realTorusH4Equiv :
+    SingularMayerVietoris.SingularHomology RealTorus₄ 4 ≃ₗ[ℤ] ℤ :=
+  (realTorusHomologyEquiv 4).trans (integerBinomialZeroEquiv 4).symm
+
+private def
+    PeriodTorusHigherHomology.coordinateTorusMapAlong {X : Type} [TopologicalSpace X] {r : ℕ}
+    (e : X ≃ₜ ProductTorus r) (n : ℕ) (i : Fin (r.choose n)) : C(ProductTorus n, X) :=
+  (e.symm : C(ProductTorus r, X)).comp (coordinateTorusMap r n i)
+
+private def
+    PeriodTorusHigherHomology.coordinateTorusClassAlong {X : Type} [TopologicalSpace X] {r : ℕ}
+    (e : X ≃ₜ ProductTorus r) (n : ℕ) (i : Fin (r.choose n)) :
+    SingularMayerVietoris.SingularHomology X n :=
+  SingularMayerVietoris.singularHomologyMap (coordinateTorusMapAlong e n i) n
+    (productTorusTopClass n)
+
+private def
+    PeriodTorusHigherHomology.coordinateTorusBasisAlong {X : Type} [TopologicalSpace X] {r : ℕ}
+    (e : X ≃ₜ ProductTorus r) (n : ℕ) :
+    Module.Basis (Fin (r.choose n)) ℤ (SingularMayerVietoris.SingularHomology X n) :=
+  (coordinateTorusBasis r n).map (homeomorphHomologyEquiv e n).symm
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.coordinateTorusBasisAlong_apply {X : Type} [TopologicalSpace X]
+    {r : ℕ} (e : X ≃ₜ ProductTorus r) (n : ℕ) (i : Fin (r.choose n)) :
+    coordinateTorusBasisAlong e n i = coordinateTorusClassAlong e n i := by
+  rw [coordinateTorusBasisAlong, Module.Basis.map_apply, coordinateTorusBasis_apply,
+    homeomorphHomologyEquiv_symm_apply]
+  change
+    SingularMayerVietoris.singularHomologyMap (e.symm : C(ProductTorus r, X)) n
+        (SingularMayerVietoris.singularHomologyMap (coordinateTorusMap r n i) n
+          (productTorusTopClass n)) =
+      SingularMayerVietoris.singularHomologyMap
+        ((e.symm : C(ProductTorus r, X)).comp (coordinateTorusMap r n i)) n
+        (productTorusTopClass n)
+  rw [singularHomologyMap_comp]
+  rfl
+
+private theorem
+    PeriodTorusHigherHomology.coordinateTorusBasisAlong_coe {X : Type} [TopologicalSpace X]
+    {r : ℕ} (e : X ≃ₜ ProductTorus r) (n : ℕ) :
+    ⇑(coordinateTorusBasisAlong e n) = coordinateTorusClassAlong e n :=
+  funext (coordinateTorusBasisAlong_apply e n)
+
+private theorem
+    PeriodTorusHigherHomology.coordinateTorusClassAlong_span {X : Type} [TopologicalSpace X]
+    {r : ℕ} (e : X ≃ₜ ProductTorus r) (n : ℕ) :
+    Submodule.span ℤ (Set.range (coordinateTorusClassAlong e n)) = ⊤ := by
+  simpa only [coordinateTorusBasisAlong_coe] using (coordinateTorusBasisAlong e n).span_eq
+
+private theorem
+    PeriodTorusHigherHomology.surjective_of_coordinateTorusClassAlong_mem_range {X : Type}
+    [TopologicalSpace X] {r : ℕ} {M : Type*} [AddCommGroup M] [Module ℤ M]
+    (e : X ≃ₜ ProductTorus r) (n : ℕ) (f : M →ₗ[ℤ] SingularMayerVietoris.SingularHomology X n)
+    (hf : ∀ i : Fin (r.choose n), coordinateTorusClassAlong e n i ∈ LinearMap.range f) :
+    Function.Surjective f := by
+  apply LinearMap.range_eq_top.mp
+  apply top_unique
+  rw [← coordinateTorusClassAlong_span e n]
+  apply Submodule.span_le.mpr
+  rintro _ ⟨i, rfl⟩
+  exact hf i
+
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.torusMatrixMap_add {m n : ℕ} (A : Matrix (Fin m) (Fin n) ℤ)
+    (x y : ProductTorus n) : torusMatrixMap A (x + y) = torusMatrixMap A x + torusMatrixMap A y :=
+  (torusMatrixLinearMap A).map_add x y
+
+@[simp]
+private theorem PeriodTorusHigherHomology.coordinateTorusMap_add (r n : ℕ) (i : Fin (r.choose n))
+    (x y : ProductTorus n) :
+    coordinateTorusMap r n i (x + y) = coordinateTorusMap r n i x + coordinateTorusMap r n i y := by
+  simpa only [coordinateTorusMap_eq_torusMatrixMap] using
+    torusMatrixMap_add (coordinateTorusMatrix r n i) x y
+
+private theorem
+    PeriodTorusHigherHomology.homeomorph_symm_add_of_add {X Y : Type} [TopologicalSpace X]
+    [TopologicalSpace Y] [Add X] [Add Y] (e : X ≃ₜ Y) (he : ∀ x y, e (x + y) = e x + e y)
+    (x y : Y) : e.symm (x + y) = e.symm x + e.symm y := by
+  apply e.injective
+  rw [Homeomorph.apply_symm_apply, he, Homeomorph.apply_symm_apply, Homeomorph.apply_symm_apply]
+
+private theorem
+    PeriodTorusHigherHomology.coordinateTorusMapAlong_add {X : Type} [TopologicalSpace X]
+    [Add X] {r : ℕ} (e : X ≃ₜ ProductTorus r) (he : ∀ x y, e (x + y) = e x + e y) (n : ℕ)
+    (i : Fin (r.choose n)) (x y : ProductTorus n) :
+    coordinateTorusMapAlong e n i (x + y) =
+      coordinateTorusMapAlong e n i x + coordinateTorusMapAlong e n i y := by
+  change
+    e.symm (coordinateTorusMap r n i (x + y)) =
+      e.symm (coordinateTorusMap r n i x) + e.symm (coordinateTorusMap r n i y)
+  rw [coordinateTorusMap_add]
+  exact homeomorph_symm_add_of_add e he _ _
+
+private def PeriodTorusHigherHomologyExterior.standardExteriorBasis (m n : ℕ) :
+    Module.Basis (Set.powersetCard (Fin m) n) ℤ (⋀[ℤ]^n (Fin m → ℤ)) :=
+  (Pi.basisFun ℤ (Fin m)).exteriorPower n
+
+private theorem PeriodTorusHigherHomologyExterior.standardExterior_map_coefficient (m n : ℕ)
+    (A : Matrix (Fin m) (Fin m) ℤ) (s t : Set.powersetCard (Fin m) n) :
+    (standardExteriorBasis m n).repr
+        (exteriorPower.map n A.mulVecLin (standardExteriorBasis m n t)) s =
+      (A.submatrix (Set.powersetCard.ofFinEmbEquiv.symm s)
+          (Set.powersetCard.ofFinEmbEquiv.symm t)).det := by
+  unfold standardExteriorBasis
+  rw [exteriorPower.basis_repr_apply, exteriorPower.basis_apply, exteriorPower.ιMulti_family,
+    exteriorPower.map_apply_ιMulti, exteriorPower.ιMultiDual_apply_ιMulti]
+  have hmatrix :
+    (Matrix.of fun i j =>
+        (Pi.basisFun ℤ (Fin m)).coord (Set.powersetCard.ofFinEmbEquiv.symm s j)
+          ((A.mulVecLin ∘ ((Pi.basisFun ℤ (Fin m)) ∘ Set.powersetCard.ofFinEmbEquiv.symm t)) i)) =
+      (A.submatrix (Set.powersetCard.ofFinEmbEquiv.symm s)
+          (Set.powersetCard.ofFinEmbEquiv.symm t)).transpose := by
+    ext i j
+    simp only [Matrix.of_apply, Module.Basis.coord_apply, Pi.basisFun_repr, Function.comp_apply,
+      Pi.basisFun_apply, Matrix.mulVecLin_apply, Matrix.mulVec_single_one, Matrix.col_apply,
+      Matrix.transpose_apply, Matrix.submatrix_apply]
+  rw [hmatrix, Matrix.det_transpose]
+
+private abbrev PeriodTorusHigherHomologyExterior.latticeExterior (n : ℕ) :=
+  ⋀[ℤ]^n Lattice
+
+private def PeriodTorusHigherHomologyExterior.latticeBasis : Module.Basis (Fin 4) ℤ Lattice :=
+  Pi.basisFun ℤ (Fin 4)
+
+private def PeriodTorusHigherHomologyExterior.latticeExteriorBasis (n : ℕ) :
+    Module.Basis (Set.powersetCard (Fin 4) n) ℤ (latticeExterior n) :=
+  standardExteriorBasis 4 n
+
+private theorem PeriodTorusHigherHomologyExterior.pairIndices_strictMono (i : Fin 6) :
+    StrictMono (LocalSystemMatrices.pairIndices i) := by fin_cases i <;> decide
+
+private theorem PeriodTorusHigherHomologyExterior.tripleIndices_strictMono (i : Fin 4) :
+    StrictMono (LocalSystemMatrices.tripleIndices i) := by fin_cases i <;> decide
+
+private theorem PeriodTorusHigherHomologyExterior.pairIndices_injective :
+    Function.Injective LocalSystemMatrices.pairIndices := by decide
+
+private theorem PeriodTorusHigherHomologyExterior.tripleIndices_injective :
+    Function.Injective LocalSystemMatrices.tripleIndices := by decide
+
+private def PeriodTorusHigherHomologyExterior.pairEmbedding (i : Fin 6) : Fin 2 ↪o Fin 4 :=
+  OrderEmbedding.ofStrictMono (LocalSystemMatrices.pairIndices i) (pairIndices_strictMono i)
+
+private def PeriodTorusHigherHomologyExterior.tripleEmbedding (i : Fin 4) : Fin 3 ↪o Fin 4 :=
+  OrderEmbedding.ofStrictMono (LocalSystemMatrices.tripleIndices i) (tripleIndices_strictMono i)
+
+private def PeriodTorusHigherHomologyExterior.pairSubset (i : Fin 6) : Set.powersetCard (Fin 4) 2 :=
+  Set.powersetCard.ofFinEmbEquiv (pairEmbedding i)
+
+private def
+    PeriodTorusHigherHomologyExterior.tripleSubset (i : Fin 4) : Set.powersetCard (Fin 4) 3 :=
+  Set.powersetCard.ofFinEmbEquiv (tripleEmbedding i)
+
+@[simp]
+private theorem PeriodTorusHigherHomologyExterior.pairSubset_ordered (i : Fin 6) :
+    (Set.powersetCard.ofFinEmbEquiv.symm (pairSubset i) : Fin 2 → Fin 4) =
+      LocalSystemMatrices.pairIndices i := by
+  rw [pairSubset, Equiv.symm_apply_apply]
+  rfl
+
+@[simp]
+private theorem PeriodTorusHigherHomologyExterior.tripleSubset_ordered (i : Fin 4) :
+    (Set.powersetCard.ofFinEmbEquiv.symm (tripleSubset i) : Fin 3 → Fin 4) =
+      LocalSystemMatrices.tripleIndices i := by
+  rw [tripleSubset, Equiv.symm_apply_apply]
+  rfl
+
+private theorem
+    PeriodTorusHigherHomologyExterior.pairSubset_injective : Function.Injective pairSubset := by
+  intro i j hij
+  apply pairIndices_injective
+  simpa only [pairSubset_ordered] using
+    congrArg (fun s => (Set.powersetCard.ofFinEmbEquiv.symm s : Fin 2 → Fin 4)) hij
+
+private theorem PeriodTorusHigherHomologyExterior.tripleSubset_injective :
+    Function.Injective tripleSubset := by
+  intro i j hij
+  apply tripleIndices_injective
+  simpa only [tripleSubset_ordered] using
+    congrArg (fun s => (Set.powersetCard.ofFinEmbEquiv.symm s : Fin 3 → Fin 4)) hij
+
+private theorem
+    PeriodTorusHigherHomologyExterior.pairSubset_bijective : Function.Bijective pairSubset := by
+  apply (Fintype.bijective_iff_injective_and_card _).mpr
+  refine ⟨pairSubset_injective, ?_⟩
+  simpa only [Nat.card_eq_fintype_card, Fintype.card_fin, show Nat.choose 4 2 = 6 by decide] using
+    (Set.powersetCard.card (Fin 4) 2).symm
+
+private theorem PeriodTorusHigherHomologyExterior.tripleSubset_bijective :
+    Function.Bijective tripleSubset := by
+  apply (Fintype.bijective_iff_injective_and_card _).mpr
+  refine ⟨tripleSubset_injective, ?_⟩
+  simpa only [Nat.card_eq_fintype_card, Fintype.card_fin, show Nat.choose 4 3 = 4 by decide] using
+    (Set.powersetCard.card (Fin 4) 3).symm
+
+private def
+    PeriodTorusHigherHomologyExterior.pairSubsetEquiv : Fin 6 ≃ Set.powersetCard (Fin 4) 2 :=
+  Equiv.ofBijective pairSubset pairSubset_bijective
+
+private def
+    PeriodTorusHigherHomologyExterior.tripleSubsetEquiv : Fin 4 ≃ Set.powersetCard (Fin 4) 3 :=
+  Equiv.ofBijective tripleSubset tripleSubset_bijective
+
+private def
+    PeriodTorusHigherHomologyExterior.squareBasis : Module.Basis (Fin 6) ℤ (latticeExterior 2) :=
+  (latticeExteriorBasis 2).reindex pairSubsetEquiv.symm
+
+private def
+    PeriodTorusHigherHomologyExterior.cubeBasis : Module.Basis (Fin 4) ℤ (latticeExterior 3) :=
+  (latticeExteriorBasis 3).reindex tripleSubsetEquiv.symm
+
+private theorem PeriodTorusHigherHomologyExterior.squareBasis_apply (i : Fin 6) :
+    squareBasis i = exteriorPower.ιMulti ℤ 2 (latticeBasis ∘ LocalSystemMatrices.pairIndices i) :=
+  by
+  rw [squareBasis, Module.Basis.reindex_apply]
+  change (Pi.basisFun ℤ (Fin 4)).exteriorPower 2 (pairSubset i) = _
+  rw [exteriorPower.basis_apply, exteriorPower.ιMulti_family, pairSubset_ordered]
+  rfl
+
+private theorem PeriodTorusHigherHomologyExterior.cubeBasis_apply (i : Fin 4) :
+    cubeBasis i = exteriorPower.ιMulti ℤ 3 (latticeBasis ∘ LocalSystemMatrices.tripleIndices i) :=
+  by
+  rw [cubeBasis, Module.Basis.reindex_apply]
+  change (Pi.basisFun ℤ (Fin 4)).exteriorPower 3 (tripleSubset i) = _
+  rw [exteriorPower.basis_apply, exteriorPower.ιMulti_family, tripleSubset_ordered]
+  rfl
+
+private def
+    PeriodTorusHigherHomologyExterior.squareCoordinates : latticeExterior 2 ≃ₗ[ℤ] (Fin 6 → ℤ) :=
+  squareBasis.equivFun
+
+private def
+    PeriodTorusHigherHomologyExterior.cubeCoordinates : latticeExterior 3 ≃ₗ[ℤ] (Fin 4 → ℤ) :=
+  cubeBasis.equivFun
+
+@[simp]
+private theorem PeriodTorusHigherHomologyExterior.squareCoordinates_apply (x : latticeExterior 2)
+    (i : Fin 6) : squareCoordinates x i = squareBasis.repr x i :=
+  congrFun (squareBasis.equivFun_apply x) i
+
+@[simp]
+private theorem PeriodTorusHigherHomologyExterior.cubeCoordinates_apply (x : latticeExterior 3)
+    (i : Fin 4) : cubeCoordinates x i = cubeBasis.repr x i :=
+  congrFun (cubeBasis.equivFun_apply x) i
+
+private theorem PeriodTorusHigherHomologyExterior.latticeExterior_finrank (n : ℕ) :
+    Module.finrank ℤ (latticeExterior n) = Nat.choose 4 n := by
+  rw [exteriorPower.finrank_eq, Module.finrank_eq_card_basis latticeBasis, Fintype.card_fin]
+
+private theorem
+    PeriodTorusHigherHomology.coordinateTorusClassAlong_mem_range_latticeWedgeTwo {G : Type}
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] {r : ℕ}
+    (e : G ≃ₜ ProductTorus r) (he : ∀ x y, e (x + y) = e x + e y)
+    (c : Lattice →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1) (hc : Function.Surjective c)
+    (i : Fin (r.choose 2)) :
+    coordinateTorusClassAlong e 2 i ∈
+      LinearMap.range (PeriodTorusHigherHomologyPontryagin.latticeWedgeTwo G c) :=
+  map_topClass_two_mem_range_latticeWedgeTwo c hc (coordinateTorusMapAlong e 2 i)
+    (coordinateTorusMapAlong_add e he 2 i)
+
+private theorem
+    PeriodTorusHigherHomology.coordinateTorusClassAlong_mem_range_latticeWedgeThree {G : Type}
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] {r : ℕ}
+    (e : G ≃ₜ ProductTorus r) (he : ∀ x y, e (x + y) = e x + e y)
+    (c : Lattice →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1) (hc : Function.Surjective c)
+    (i : Fin (r.choose 3)) :
+    coordinateTorusClassAlong e 3 i ∈
+      LinearMap.range (PeriodTorusHigherHomologyPontryagin.latticeWedgeThree G c) :=
+  map_topClass_three_mem_range_latticeWedgeThree c hc (coordinateTorusMapAlong e 3 i)
+    (coordinateTorusMapAlong_add e he 3 i)
+
+private theorem PeriodTorusHigherHomology.latticeWedgeTwo_surjective_of_torusHomeomorph {G : Type}
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] {r : ℕ}
+    (e : G ≃ₜ ProductTorus r) (he : ∀ x y, e (x + y) = e x + e y)
+    (c : Lattice →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1) (hc : Function.Surjective c) :
+    Function.Surjective (PeriodTorusHigherHomologyPontryagin.latticeWedgeTwo G c) :=
+  surjective_of_coordinateTorusClassAlong_mem_range e 2
+    (PeriodTorusHigherHomologyPontryagin.latticeWedgeTwo G c)
+    (coordinateTorusClassAlong_mem_range_latticeWedgeTwo e he c hc)
+
+private theorem PeriodTorusHigherHomology.latticeWedgeThree_surjective_of_torusHomeomorph {G : Type}
+    [TopologicalSpace G] [AddCommGroup G] [IsTopologicalAddGroup G]
+    [Module.IsTorsionFree ℤ (SingularMayerVietoris.SingularHomology G 2)] {r : ℕ}
+    (e : G ≃ₜ ProductTorus r) (he : ∀ x y, e (x + y) = e x + e y)
+    (c : Lattice →ₗ[ℤ] SingularMayerVietoris.SingularHomology G 1) (hc : Function.Surjective c) :
+    Function.Surjective (PeriodTorusHigherHomologyPontryagin.latticeWedgeThree G c) :=
+  surjective_of_coordinateTorusClassAlong_mem_range e 3
+    (PeriodTorusHigherHomologyPontryagin.latticeWedgeThree G c)
+    (coordinateTorusClassAlong_mem_range_latticeWedgeThree e he c hc)
+
+private def PeriodTorusHigherHomologyExterior.exteriorMap (n : ℕ) (T : LatticeMatrix) :
+    latticeExterior n →ₗ[ℤ] latticeExterior n :=
+  exteriorPower.map n T.mulVecLin
+
+private theorem PeriodTorusHigherHomologyExterior.squareMap_coefficient (T : LatticeMatrix)
+    (i j : Fin 6) :
+    squareBasis.repr (exteriorMap 2 T (squareBasis j)) i =
+      LocalSystemMatrices.exteriorSquare T i j := by
+  rw [squareBasis, Module.Basis.repr_reindex_apply, Module.Basis.reindex_apply]
+  change
+    (standardExteriorBasis 4 2).repr
+        (exteriorPower.map 2 T.mulVecLin (standardExteriorBasis 4 2 (pairSubset j)))
+        (pairSubset i) =
+      _
+  rw [standardExterior_map_coefficient, pairSubset_ordered, pairSubset_ordered]
+  rfl
+
+private theorem
+    PeriodTorusHigherHomologyExterior.cubeMap_coefficient (T : LatticeMatrix) (i j : Fin 4) :
+    cubeBasis.repr (exteriorMap 3 T (cubeBasis j)) i = LocalSystemMatrices.exteriorCube T i j := by
+  rw [cubeBasis, Module.Basis.repr_reindex_apply, Module.Basis.reindex_apply]
+  change
+    (standardExteriorBasis 4 3).repr
+        (exteriorPower.map 3 T.mulVecLin (standardExteriorBasis 4 3 (tripleSubset j)))
+        (tripleSubset i) =
+      _
+  rw [standardExterior_map_coefficient, tripleSubset_ordered, tripleSubset_ordered]
+  rfl
+
+private theorem PeriodTorusHigherHomologyExterior.squareMap_toMatrix (T : LatticeMatrix) :
+    LinearMap.toMatrix squareBasis squareBasis (exteriorMap 2 T) =
+      LocalSystemMatrices.exteriorSquare T := by
+  ext i j
+  rw [LinearMap.toMatrix_apply]
+  exact squareMap_coefficient T i j
+
+private theorem PeriodTorusHigherHomologyExterior.cubeMap_toMatrix (T : LatticeMatrix) :
+    LinearMap.toMatrix cubeBasis cubeBasis (exteriorMap 3 T) =
+      LocalSystemMatrices.exteriorCube T := by
+  ext i j
+  rw [LinearMap.toMatrix_apply]
+  exact cubeMap_coefficient T i j
+
+private theorem PeriodTorusHigherHomologyExterior.squareCoordinates_map (T : LatticeMatrix)
+    (x : latticeExterior 2) :
+    squareCoordinates (exteriorMap 2 T x) =
+      LocalSystemMatrices.exteriorSquare T *ᵥ squareCoordinates x := by
+  have h := LinearMap.toMatrix_mulVec_repr squareBasis squareBasis (exteriorMap 2 T) x
+  rw [squareMap_toMatrix] at h
+  simpa only [squareCoordinates, Module.Basis.equivFun_apply] using h.symm
+
+private theorem PeriodTorusHigherHomologyExterior.cubeCoordinates_map (T : LatticeMatrix)
+    (x : latticeExterior 3) :
+    cubeCoordinates (exteriorMap 3 T x) =
+      LocalSystemMatrices.exteriorCube T *ᵥ cubeCoordinates x := by
+  have h := LinearMap.toMatrix_mulVec_repr cubeBasis cubeBasis (exteriorMap 3 T) x
+  rw [cubeMap_toMatrix] at h
+  simpa only [cubeCoordinates, Module.Basis.equivFun_apply] using h.symm
+
+private def PeriodTorusHigherHomology.coordinateH1Add (n : ℕ) :
+    (Fin n → ℤ) →+ FirstHurewicz.SingularH1 (ProductTorus n)
+    where
+  toFun v := ∑ i, v i • FirstHurewicz.loopHomologyClass (coordinatePeriodLoop n (Pi.single i 1))
+  map_zero' := by simp only [Pi.zero_apply, zero_zsmul, Finset.sum_const_zero]
+  map_add' v w := by simp only [Pi.add_apply, add_zsmul, Finset.sum_add_distrib]
+
+private def PeriodTorusHigherHomology.coordinateH1 (n : ℕ) :
+    (Fin n → ℤ) →ₗ[ℤ] FirstHurewicz.SingularH1 (ProductTorus n) :=
+  { toFun := coordinateH1Add n
+    map_add' := (coordinateH1Add n).map_add
+    map_smul' r
+      a := by
+      convert! (coordinateH1Add n).map_zsmul r a using 1
+      exact int_smul_eq_zsmul .. }
+
+private theorem PeriodTorusHigherHomology.coordinateH1_basis (n : ℕ) (i : Fin n) :
+    coordinateH1 n (Pi.basisFun ℤ (Fin n) i) =
+      FirstHurewicz.loopHomologyClass (coordinatePeriodLoop n (Pi.single i 1)) := by
+  simp [coordinateH1, coordinateH1Add, Pi.basisFun_apply, Pi.single_apply]
+
+@[simp]
+private theorem PeriodTorusHigherHomology.coordinateH1_single (n : ℕ) (i : Fin n) :
+    coordinateH1 n (Pi.single i 1) =
+      FirstHurewicz.loopHomologyClass (coordinatePeriodLoop n (Pi.single i 1)) := by
+  simpa only [Pi.basisFun_apply] using coordinateH1_basis n i
+
+private theorem PeriodTorusHigherHomology.coordinateH1_four_eq_periodMarking (p : PeriodDomain) :
+    coordinateH1 4 =
+      (FirstHurewicz.inducedHomology (periodTorusCircleHomeomorph p : C(_, _))).comp
+        p.singularH1Equiv.symm.toLinearMap := by
+  apply (Pi.basisFun ℤ (Fin 4)).ext
+  intro i
+  rw [coordinateH1_basis, LinearMap.comp_apply]
+  simp only [LinearEquiv.coe_coe]
+  rw [p.singularH1Equiv_symm_apply, periodTorusCircle_inducedHomology_periodLoop]
+  simp only [Pi.basisFun_apply]
+
+private theorem PeriodTorusHigherHomology.coordinateH1_four_apply (p : PeriodDomain) (v : Lattice) :
+    coordinateH1 4 v = FirstHurewicz.loopHomologyClass (coordinatePeriodLoop 4 v) := by
+  rw [coordinateH1_four_eq_periodMarking p, LinearMap.comp_apply]
+  simp only [LinearEquiv.coe_coe]
+  rw [p.singularH1Equiv_symm_apply, periodTorusCircle_inducedHomology_periodLoop]
+
+private theorem PeriodTorusHigherHomology.coordinateH1_four_bijective (p : PeriodDomain) :
+    Function.Bijective (coordinateH1 4) := by
+  rw [coordinateH1_four_eq_periodMarking p]
+  exact
+    (homeomorphHomologyEquiv (periodTorusCircleHomeomorph p) 1).bijective.comp
+      p.singularH1Equiv.symm.bijective
+
+private def PeriodTorusHigherHomology.coordinateH1FourEquiv (p : PeriodDomain) :
+    Lattice ≃ₗ[ℤ] FirstHurewicz.SingularH1 (ProductTorus 4) :=
+  LinearEquiv.ofBijective (coordinateH1 4) (coordinateH1_four_bijective p)
+
+private theorem PeriodTorusHigherHomology.coordinateH1_matrix_natural (p : PeriodDomain)
+    (A : LatticeMatrix) (v : Lattice) :
+    FirstHurewicz.inducedHomology (torusMatrixMap A) (coordinateH1 4 v) =
+      coordinateH1 4 (A *ᵥ v) := by
+  rw [coordinateH1_four_apply p, coordinateH1_four_apply p,
+    torusMatrixMap_coordinatePeriodHomology]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomology.coordinateTorusWedgeTwo :
+    (⋀[ℤ]^2 Lattice) →ₗ[ℤ] SingularMayerVietoris.SingularHomology (ProductTorus 4) 2 := by
+  letI := productTorus_homology_torsionFree 4 2
+  exact PeriodTorusHigherHomologyPontryagin.latticeWedgeTwo (ProductTorus 4) (coordinateH1 4)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private def PeriodTorusHigherHomology.coordinateTorusWedgeThree :
+    (⋀[ℤ]^3 Lattice) →ₗ[ℤ] SingularMayerVietoris.SingularHomology (ProductTorus 4) 3 := by
+  letI := productTorus_homology_torsionFree 4 2
+  exact PeriodTorusHigherHomologyPontryagin.latticeWedgeThree (ProductTorus 4) (coordinateH1 4)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.coordinateTorusWedgeTwo_apply_ιMulti (v : Fin 2 → Lattice) :
+    coordinateTorusWedgeTwo (exteriorPower.ιMulti ℤ 2 v) =
+      PeriodTorusHigherHomologyPontryagin.product11 (ProductTorus 4) (coordinateH1 4 (v 0))
+        (coordinateH1 4 (v 1)) := by
+  let := productTorus_homology_torsionFree 4 2
+  exact
+    PeriodTorusHigherHomologyPontryagin.latticeWedgeTwo_apply_ιMulti (ProductTorus 4)
+      (coordinateH1 4) v
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+@[simp]
+private theorem
+    PeriodTorusHigherHomology.coordinateTorusWedgeThree_apply_ιMulti (v : Fin 3 → Lattice) :
+    coordinateTorusWedgeThree (exteriorPower.ιMulti ℤ 3 v) =
+      PeriodTorusHigherHomologyPontryagin.tripleProduct (ProductTorus 4) (coordinateH1 4 (v 0))
+        (coordinateH1 4 (v 1)) (coordinateH1 4 (v 2)) := by
+  let := productTorus_homology_torsionFree 4 2
+  exact
+    PeriodTorusHigherHomologyPontryagin.latticeWedgeThree_apply_ιMulti (ProductTorus 4)
+      (coordinateH1 4) v
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.coordinateTorusWedgeTwo_apply_ιMulti_periodLoops
+    (p : PeriodDomain) (v : Fin 2 → Lattice) :
+    coordinateTorusWedgeTwo (exteriorPower.ιMulti ℤ 2 v) =
+      PeriodTorusHigherHomologyPontryagin.product11 (ProductTorus 4)
+        (FirstHurewicz.loopHomologyClass (coordinatePeriodLoop 4 (v 0)))
+        (FirstHurewicz.loopHomologyClass (coordinatePeriodLoop 4 (v 1))) := by
+  rw [coordinateTorusWedgeTwo_apply_ιMulti, coordinateH1_four_apply p, coordinateH1_four_apply p]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.coordinateTorusWedgeThree_apply_ιMulti_periodLoops
+    (p : PeriodDomain) (v : Fin 3 → Lattice) :
+    coordinateTorusWedgeThree (exteriorPower.ιMulti ℤ 3 v) =
+      PeriodTorusHigherHomologyPontryagin.tripleProduct (ProductTorus 4)
+        (FirstHurewicz.loopHomologyClass (coordinatePeriodLoop 4 (v 0)))
+        (FirstHurewicz.loopHomologyClass (coordinatePeriodLoop 4 (v 1)))
+        (FirstHurewicz.loopHomologyClass (coordinatePeriodLoop 4 (v 2))) := by
+  rw [coordinateTorusWedgeThree_apply_ιMulti, coordinateH1_four_apply p,
+    coordinateH1_four_apply p, coordinateH1_four_apply p]
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.coordinateTorusWedgeTwo_matrix (p : PeriodDomain)
+    (A : LatticeMatrix) :
+    (SingularMayerVietoris.singularHomologyMap (torusMatrixMap A) 2).comp
+        coordinateTorusWedgeTwo =
+      coordinateTorusWedgeTwo.comp (exteriorPower.map 2 A.mulVecLin) := by
+  let := productTorus_homology_torsionFree 4 2
+  exact
+    PeriodTorusHigherHomologyPontryagin.latticeWedgeTwo_natural (torusMatrixMap A)
+      (fun x y => (torusMatrixLinearMap A).map_add x y) (coordinateH1 4) (coordinateH1 4)
+      A.mulVecLin (coordinateH1_matrix_natural p A)
+
+attribute [local instance] PeriodTorusHigherHomology.integerLinearMapModule
+    PeriodTorusHigherHomology.integerTensorModule in
+private theorem PeriodTorusHigherHomology.coordinateTorusWedgeThree_matrix (p : PeriodDomain)
+    (A : LatticeMatrix) :
+    (SingularMayerVietoris.singularHomologyMap (torusMatrixMap A) 3).comp
+        coordinateTorusWedgeThree =
+      coordinateTorusWedgeThree.comp (exteriorPower.map 3 A.mulVecLin) := by
+  let := productTorus_homology_torsionFree 4 2
+  exact
+    PeriodTorusHigherHomologyPontryagin.latticeWedgeThree_natural (torusMatrixMap A)
+      (fun x y => (torusMatrixLinearMap A).map_add x y) (coordinateH1 4) (coordinateH1 4)
+      A.mulVecLin (coordinateH1_matrix_natural p A)
+
+private theorem PeriodTorusHigherHomology.coordinateH1_four_surjective :
+    Function.Surjective (coordinateH1 4) :=
+  (coordinateH1_four_bijective (Elliptic.examplePeriod .four)).surjective
+
+private theorem PeriodTorusHigherHomology.coordinateTorusWedgeTwo_surjective :
+    Function.Surjective coordinateTorusWedgeTwo := by
+  let := productTorus_homology_torsionFree 4 2
+  exact
+    latticeWedgeTwo_surjective_of_torusHomeomorph (Homeomorph.refl (ProductTorus 4))
+      (fun _ _ => rfl) (coordinateH1 4) coordinateH1_four_surjective
+
+private theorem PeriodTorusHigherHomology.coordinateTorusWedgeThree_surjective :
+    Function.Surjective coordinateTorusWedgeThree := by
+  let := productTorus_homology_torsionFree 4 2
+  exact
+    latticeWedgeThree_surjective_of_torusHomeomorph (Homeomorph.refl (ProductTorus 4))
+      (fun _ _ => rfl) (coordinateH1 4) coordinateH1_four_surjective
+
+private theorem PeriodTorusHigherHomology.coordinateTorusWedgeTwo_bijective :
+    Function.Bijective coordinateTorusWedgeTwo := by
+  let := productTorus_homology_free 4 2
+  let := productTorus_homology_finite 4 2
+  apply
+    OrzechProperty.bijective_of_surjective_of_finrank_le coordinateTorusWedgeTwo
+      coordinateTorusWedgeTwo_surjective
+  rw [PeriodTorusHigherHomologyExterior.latticeExterior_finrank, productTorus_homology_finrank]
+
+private theorem PeriodTorusHigherHomology.coordinateTorusWedgeThree_bijective :
+    Function.Bijective coordinateTorusWedgeThree := by
+  let := productTorus_homology_free 4 3
+  let := productTorus_homology_finite 4 3
+  apply
+    OrzechProperty.bijective_of_surjective_of_finrank_le coordinateTorusWedgeThree
+      coordinateTorusWedgeThree_surjective
+  rw [PeriodTorusHigherHomologyExterior.latticeExterior_finrank, productTorus_homology_finrank]
+
+private def PeriodTorusHigherHomology.coordinateTorusWedgeTwoEquiv :
+    PeriodTorusHigherHomologyExterior.latticeExterior 2 ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (ProductTorus 4) 2 :=
+  LinearEquiv.ofBijective coordinateTorusWedgeTwo coordinateTorusWedgeTwo_bijective
+
+private def PeriodTorusHigherHomology.coordinateTorusWedgeThreeEquiv :
+    PeriodTorusHigherHomologyExterior.latticeExterior 3 ≃ₗ[ℤ]
+      SingularMayerVietoris.SingularHomology (ProductTorus 4) 3 :=
+  LinearEquiv.ofBijective coordinateTorusWedgeThree coordinateTorusWedgeThree_bijective
+
+private def PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv :
+    SingularMayerVietoris.SingularHomology (ProductTorus 4) 2 ≃ₗ[ℤ]
+      PeriodTorusHigherHomologyExterior.latticeExterior 2 :=
+  coordinateTorusWedgeTwoEquiv.symm
+
+private def PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv :
+    SingularMayerVietoris.SingularHomology (ProductTorus 4) 3 ≃ₗ[ℤ]
+      PeriodTorusHigherHomologyExterior.latticeExterior 3 :=
+  coordinateTorusWedgeThreeEquiv.symm
+
+@[simp]
+private theorem PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv_wedge
+    (v : PeriodTorusHigherHomologyExterior.latticeExterior 2) :
+    coordinateTorusH2ExteriorEquiv (coordinateTorusWedgeTwo v) = v :=
+  coordinateTorusWedgeTwoEquiv.symm_apply_apply v
+
+@[simp]
+private theorem PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv_wedge
+    (v : PeriodTorusHigherHomologyExterior.latticeExterior 3) :
+    coordinateTorusH3ExteriorEquiv (coordinateTorusWedgeThree v) = v :=
+  coordinateTorusWedgeThreeEquiv.symm_apply_apply v
+
+private theorem PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv_symm_ιMulti
+    (v : Fin 3 → Lattice) :
+    coordinateTorusH3ExteriorEquiv.symm (exteriorPower.ιMulti ℤ 3 v) =
+      PeriodTorusHigherHomologyPontryagin.tripleProduct (ProductTorus 4)
+        (FirstHurewicz.loopHomologyClass (coordinatePeriodLoop 4 (v 0)))
+        (FirstHurewicz.loopHomologyClass (coordinatePeriodLoop 4 (v 1)))
+        (FirstHurewicz.loopHomologyClass (coordinatePeriodLoop 4 (v 2))) :=
+  coordinateTorusWedgeThree_apply_ιMulti_periodLoops (Elliptic.examplePeriod .four) v
+
+private theorem PeriodTorusHigherHomology.coordinateTorusH2ExteriorEquiv_matrix (A : LatticeMatrix)
+    (a : SingularMayerVietoris.SingularHomology (ProductTorus 4) 2) :
+    coordinateTorusH2ExteriorEquiv
+        (SingularMayerVietoris.singularHomologyMap (torusMatrixMap A) 2 a) =
+      exteriorPower.map 2 A.mulVecLin (coordinateTorusH2ExteriorEquiv a) := by
+  obtain ⟨v, rfl⟩ := coordinateTorusWedgeTwo_surjective a
+  have h :=
+    LinearMap.congr_fun (coordinateTorusWedgeTwo_matrix (Elliptic.examplePeriod .four) A) v
+  change
+    SingularMayerVietoris.singularHomologyMap (torusMatrixMap A) 2 (coordinateTorusWedgeTwo v) =
+      coordinateTorusWedgeTwo (exteriorPower.map 2 A.mulVecLin v) at h
+  rw [h, coordinateTorusH2ExteriorEquiv_wedge, coordinateTorusH2ExteriorEquiv_wedge]
+
+private theorem PeriodTorusHigherHomology.coordinateTorusH3ExteriorEquiv_matrix (A : LatticeMatrix)
+    (a : SingularMayerVietoris.SingularHomology (ProductTorus 4) 3) :
+    coordinateTorusH3ExteriorEquiv
+        (SingularMayerVietoris.singularHomologyMap (torusMatrixMap A) 3 a) =
+      exteriorPower.map 3 A.mulVecLin (coordinateTorusH3ExteriorEquiv a) := by
+  obtain ⟨v, rfl⟩ := coordinateTorusWedgeThree_surjective a
+  have h :=
+    LinearMap.congr_fun (coordinateTorusWedgeThree_matrix (Elliptic.examplePeriod .four) A) v
+  change
+    SingularMayerVietoris.singularHomologyMap (torusMatrixMap A) 3 (coordinateTorusWedgeThree v) =
+      coordinateTorusWedgeThree (exteriorPower.map 3 A.mulVecLin v) at h
+  rw [h, coordinateTorusH3ExteriorEquiv_wedge, coordinateTorusH3ExteriorEquiv_wedge]
+
+private def PeriodTorusHigherHomology.coordinateTorusH2Coordinates :
+    SingularMayerVietoris.SingularHomology (ProductTorus 4) 2 ≃ₗ[ℤ] (Fin 6 → ℤ) :=
+  coordinateTorusH2ExteriorEquiv.trans PeriodTorusHigherHomologyExterior.squareCoordinates
+
+private def PeriodTorusHigherHomology.coordinateTorusH3Coordinates :
+    SingularMayerVietoris.SingularHomology (ProductTorus 4) 3 ≃ₗ[ℤ] (Fin 4 → ℤ) :=
+  coordinateTorusH3ExteriorEquiv.trans PeriodTorusHigherHomologyExterior.cubeCoordinates
+
+private theorem PeriodTorusHigherHomology.coordinateTorusH2Coordinates_matrix (A : LatticeMatrix)
+    (a : SingularMayerVietoris.SingularHomology (ProductTorus 4) 2) :
+    coordinateTorusH2Coordinates
+        (SingularMayerVietoris.singularHomologyMap (torusMatrixMap A) 2 a) =
+      LocalSystemMatrices.exteriorSquare A *ᵥ coordinateTorusH2Coordinates a := by
+  change
+    PeriodTorusHigherHomologyExterior.squareCoordinates
+        (coordinateTorusH2ExteriorEquiv
+          (SingularMayerVietoris.singularHomologyMap (torusMatrixMap A) 2 a)) =
+      _
+  rw [coordinateTorusH2ExteriorEquiv_matrix]
+  exact
+    PeriodTorusHigherHomologyExterior.squareCoordinates_map A (coordinateTorusH2ExteriorEquiv a)
+
+private theorem PeriodTorusHigherHomology.coordinateTorusH3Coordinates_matrix (A : LatticeMatrix)
+    (a : SingularMayerVietoris.SingularHomology (ProductTorus 4) 3) :
+    coordinateTorusH3Coordinates
+        (SingularMayerVietoris.singularHomologyMap (torusMatrixMap A) 3 a) =
+      LocalSystemMatrices.exteriorCube A *ᵥ coordinateTorusH3Coordinates a := by
+  change
+    PeriodTorusHigherHomologyExterior.cubeCoordinates
+        (coordinateTorusH3ExteriorEquiv
+          (SingularMayerVietoris.singularHomologyMap (torusMatrixMap A) 3 a)) =
+      _
+  rw [coordinateTorusH3ExteriorEquiv_matrix]
+  exact PeriodTorusHigherHomologyExterior.cubeCoordinates_map A (coordinateTorusH3ExteriorEquiv a)
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology8.lean b/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology8.lean
new file mode 100644
index 000000000..ace13e726
--- /dev/null
+++ b/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology8.lean
@@ -0,0 +1,74 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Foundations.Complex
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology2
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology3
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology4
+import all LeanPool.HopfProblem.HomologyTheory.FirstHurewicz3
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology6
+import all LeanPool.HopfProblem.Foundations.Complex
+
+/-!
+# Hopf problem: torus homology · period torus higher homology 8
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem PeriodTorusHigherHomology.positiveCircleCross_pointClass :
+    positiveCircleCross Unit 0 (pointClass ()) =
+      homeomorphHomologyEquiv
+        (Homeomorph.prodUnique (PeriodTorusHigherHomology.CircleTopology.Circle) Unit).symm 1
+        (FirstHurewicz.loopHomologyClass CirclePaths.positiveLoop) :=
+  crossProductHomology_pointClass_right (PeriodTorusHigherHomology.CircleTopology.Circle) Unit
+    (FirstHurewicz.loopHomologyClass CirclePaths.positiveLoop) ()
+
+@[simp]
+private theorem PeriodTorusHigherHomology.circleHomologyOneEquiv_positiveLoop :
+    circleHomologyOneEquiv (FirstHurewicz.loopHomologyClass CirclePaths.positiveLoop) = 1 := by
+  rw [circleHomologyOneEquiv_apply, ← positiveCircleCross_pointClass,
+    circleBoundary_positiveCircleCross]
+  exact connectedHomologyZeroEquiv_pointClass ()
+
+@[simp]
+private theorem PeriodTorusHigherHomology.circleHomologyOneEquiv_symm_one :
+    circleHomologyOneEquiv.symm 1 = FirstHurewicz.loopHomologyClass CirclePaths.positiveLoop := by
+  apply circleHomologyOneEquiv.injective
+  rw [LinearEquiv.apply_symm_apply, circleHomologyOneEquiv_positiveLoop]
+
+public
+theorem PeriodTorusHigherHomology.circleHomologyOneEquiv_symm_int (k : ℤ) :
+    circleHomologyOneEquiv.symm k =
+      k • FirstHurewicz.loopHomologyClass CirclePaths.positiveLoop := by
+  apply circleHomologyOneEquiv.injective
+  rw [LinearEquiv.apply_symm_apply, map_zsmul, circleHomologyOneEquiv_positiveLoop]
+  simp
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology9.lean b/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology9.lean
new file mode 100644
index 000000000..a9b1f6d23
--- /dev/null
+++ b/LeanPool/HopfProblem/TorusHomology/PeriodTorusHigherHomology9.lean
@@ -0,0 +1,73 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.HomologyOfX.TrianglePeriodFamilyHomologyAlgebra
+import all LeanPool.HopfProblem.HomologyTheory.SingularMayerVietoris
+import all LeanPool.HopfProblem.TorusHomology.PeriodTorusHigherHomology1
+import all LeanPool.HopfProblem.HomologyOfX.TrianglePeriodFamilyHomologyAlgebra
+
+/-!
+# Hopf problem: torus homology · period torus higher homology 9
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+/-- Right translation by a fixed element as a continuous map. -/
+@[expose]
+public
+def PeriodTorusHigherHomology.rightTranslation {G : Type*} [TopologicalSpace G] [AddGroup G]
+    [IsTopologicalAddGroup G] (a : G) : C(G, G) :=
+  ⟨fun x => x + a, continuous_id.add continuous_const⟩
+
+@[simp]
+public
+theorem PeriodTorusHigherHomology.rightTranslation_apply {G : Type*} [TopologicalSpace G]
+    [AddGroup G] [IsTopologicalAddGroup G] (a x : G) : rightTranslation a x = x + a :=
+  rfl
+
+private def PeriodTorusHigherHomology.rightTranslationHomotopyAlong {G : Type*} [TopologicalSpace G]
+    [AddGroup G] [IsTopologicalAddGroup G] {a : G} (p : Path (0 : G) a) :
+    (ContinuousMap.id G).Homotopy (rightTranslation a)
+    where
+  toFun z := z.2 + p z.1
+  continuous_toFun := continuous_snd.add (p.continuous.comp continuous_fst)
+  map_zero_left x := by simp
+  map_one_left x := by simp
+
+private theorem PeriodTorusHigherHomology.rightTranslation_singularHomologyMap_of_path {G : Type}
+    [TopologicalSpace G] [AddGroup G] [IsTopologicalAddGroup G] {a : G} (p : Path (0 : G) a)
+    (n : ℕ) : SingularMayerVietoris.singularHomologyMap (rightTranslation a) n = LinearMap.id := by
+  rw [← homotopy_homologyMap (rightTranslationHomotopyAlong p) n, singularHomologyMap_id]
+
+@[simp]
+private theorem PeriodTorusHigherHomology.rightTranslation_singularHomologyMap {G : Type}
+    [TopologicalSpace G] [AddGroup G] [IsTopologicalAddGroup G] [PathConnectedSpace G] (a : G)
+    (n : ℕ) : SingularMayerVietoris.singularHomologyMap (rightTranslation a) n = LinearMap.id :=
+  rightTranslation_singularHomologyMap_of_path (PathConnectedSpace.somePath 0 a) n
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Uniformization/CuspUniformization1.lean b/LeanPool/HopfProblem/Uniformization/CuspUniformization1.lean
new file mode 100644
index 000000000..3d98471cc
--- /dev/null
+++ b/LeanPool/HopfProblem/Uniformization/CuspUniformization1.lean
@@ -0,0 +1,1340 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Toric.ToricSpace2
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Toric.ToricSpace2
+
+/-!
+# Hopf problem: uniformization · cusp uniformization 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+/-- The normalized complex exponential with period one. -/
+public
+def CuspUniformization.exponential (z : ℂ) : ℂ :=
+  Complex.exp (2 * Real.pi * Complex.I * z)
+
+private theorem
+    CuspUniformization.exponential_factor_ne_zero : (2 * Real.pi * Complex.I : ℂ) ≠ 0 := by
+  exact
+    mul_ne_zero (mul_ne_zero (by norm_num) (by exact_mod_cast Real.pi_ne_zero)) Complex.I_ne_zero
+
+@[simp]
+private theorem CuspUniformization.exponential_ne_zero (z : ℂ) : exponential z ≠ 0 :=
+  Complex.exp_ne_zero _
+
+@[simp]
+private theorem CuspUniformization.exponential_zero : exponential 0 = 1 := by simp [exponential]
+
+private theorem CuspUniformization.exponential_add (z w : ℂ) :
+    exponential (z + w) = exponential z * exponential w := by
+  simp only [exponential, mul_add, Complex.exp_add]
+
+@[simp]
+private theorem CuspUniformization.exponential_int (n : ℤ) : exponential n = 1 := by
+  simpa only [exponential, mul_comm] using Complex.exp_int_mul_two_pi_mul_I n
+
+private theorem CuspUniformization.exponential_eq_iff (z w : ℂ) :
+    exponential z = exponential w ↔ ∃ n : ℤ, z = w + n := by
+  rw [exponential, exponential, Complex.exp_eq_exp_iff_exists_int]
+  constructor
+  · rintro ⟨n, hn⟩
+    refine ⟨n, mul_left_cancel₀ exponential_factor_ne_zero ?_⟩
+    calc
+      (2 * Real.pi * Complex.I : ℂ) * z = _ := hn
+      _ = (2 * Real.pi * Complex.I : ℂ) * (w + n) := by ring
+  · rintro ⟨n, rfl⟩
+    exact ⟨n, by ring⟩
+
+/-- The normalized principal logarithm inverse to `exponential` away from zero. -/
+public
+def CuspUniformization.logarithm (t : ℂ) : ℂ :=
+  Complex.log t / (2 * Real.pi * Complex.I)
+
+private theorem CuspUniformization.exponential_logarithm {t : ℂ} (ht : t ≠ 0) :
+    exponential (logarithm t) = t := by
+  rw [exponential, logarithm, mul_div_cancel₀ _ exponential_factor_ne_zero]
+  exact Complex.exp_log ht
+
+private theorem CuspUniformization.exponential_holomorphic : ContDiff ℂ ω exponential :=
+  (contDiff_const.mul contDiff_id).cexp
+
+private theorem CuspUniformization.log_norm_exponential (s : ℂ) :
+    Real.log ‖exponential s‖ = -2 * Real.pi * s.im := by
+  simp [exponential, Complex.norm_exp, Complex.mul_re, Complex.mul_im]
+
+private def CuspUniformization.torusPoint (w : ToricCharts.CoordinateSpace 3) : ToricSpace.Space :=
+  ToricSpace.inclusion ToricSpace.referenceTriangle
+    (ToricCharts.monomial ToricSpace.referenceTriangle.dual w)
+
+private theorem CuspUniformization.torusPoint_mem {w : ToricCharts.CoordinateSpace 3}
+    (hw : w ∈ ToricCharts.torus) : torusPoint w ∈ ToricSpace.openTorus :=
+  ToricSpace.inclusion_torus_subset _ ⟨_, ToricCharts.monomial_mapsTo_torus _ hw, rfl⟩
+
+private theorem CuspUniformization.torusCoordinates_torusPoint {w : ToricCharts.CoordinateSpace 3}
+    (hw : w ∈ ToricCharts.torus) : ToricSpace.torusCoordinates (torusPoint w) = w := by
+  rw [torusPoint,
+    ToricSpace.torusCoordinates_inclusion _ (ToricCharts.monomial_mapsTo_torus _ hw),
+    ToricCharts.monomial_mul_on_torus _ _ hw, ToricFan.Triangle.rays_dual,
+    ToricCharts.monomial_one]
+
+private theorem CuspUniformization.torusPoint_torusCoordinates {x : ToricSpace.Space}
+    (hx : x ∈ ToricSpace.openTorus) : torusPoint (ToricSpace.torusCoordinates x) = x := by
+  obtain ⟨z, hz, rfl⟩ := hx
+  rw [ToricSpace.torusCoordinates_inclusion _ hz, torusPoint,
+    ToricCharts.monomial_mul_on_torus _ _ hz, ToricFan.Triangle.dual_rays,
+    ToricCharts.monomial_one]
+
+private theorem CuspUniformization.torusCoordinates_injective :
+    Set.InjOn ToricSpace.torusCoordinates ToricSpace.openTorus := by
+  intro x hx y hy he
+  rw [← torusPoint_torusCoordinates hx, ← torusPoint_torusCoordinates hy, he]
+
+private def CuspUniformization.exponentialCoordinates (t : ℂ) (z : ComplexPlane₂) :
+    ToricCharts.CoordinateSpace 3 :=
+  ![exponential (z 0), exponential (z 1), t]
+
+private theorem
+    CuspUniformization.exponentialCoordinates_mem {t : ℂ} (ht : t ≠ 0) (z : ComplexPlane₂) :
+    exponentialCoordinates t z ∈ ToricCharts.torus := by
+  intro i
+  fin_cases i
+  · exact exponential_ne_zero _
+  · exact exponential_ne_zero _
+  · exact ht
+
+private theorem CuspUniformization.exponentialCoordinates_holomorphic (t : ℂ) :
+    ContDiff ℂ ω (exponentialCoordinates t) := by
+  apply contDiff_pi.mpr
+  intro i
+  fin_cases i
+  · exact exponential_holomorphic.comp (contDiff_apply ℂ ℂ 0)
+  · exact exponential_holomorphic.comp (contDiff_apply ℂ ℂ 1)
+  · exact contDiff_const
+
+private def CuspUniformization.exponentialPoint (t : ℂ) : ComplexPlane₂ → ToricSpace.Space :=
+  torusPoint ∘ exponentialCoordinates t
+
+private theorem CuspUniformization.exponentialPoint_mem {t : ℂ} (ht : t ≠ 0) (z : ComplexPlane₂) :
+    exponentialPoint t z ∈ ToricSpace.openTorus :=
+  torusPoint_mem (exponentialCoordinates_mem ht z)
+
+private theorem CuspUniformization.torusCoordinates_exponentialPoint {t : ℂ} (ht : t ≠ 0)
+    (z : ComplexPlane₂) :
+    ToricSpace.torusCoordinates (exponentialPoint t z) = exponentialCoordinates t z :=
+  torusCoordinates_torusPoint (exponentialCoordinates_mem ht z)
+
+private theorem CuspUniformization.time_exponentialPoint {t : ℂ} (ht : t ≠ 0) (z : ComplexPlane₂) :
+    ToricSpace.time (exponentialPoint t z) = t := by
+  simpa [exponentialCoordinates] using congrFun (torusCoordinates_exponentialPoint ht z) 2
+
+private theorem CuspUniformization.exponentialPoint_holomorphic {t : ℂ} (ht : t ≠ 0) :
+    ContMDiff (modelWithCornersSelf ℂ ComplexPlane₂)
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (exponentialPoint t) := by
+  apply (ToricSpace.inclusion_holomorphic ToricSpace.referenceTriangle).comp
+  apply ContDiff.contMDiff
+  apply contDiffOn_univ.mp
+  exact
+    (ToricCharts.monomial_contDiffOn ToricSpace.referenceTriangle.dual ω).comp
+      (exponentialCoordinates_holomorphic t).contDiffOn
+      (fun z _ => ToricCharts.torus_subset_domain _ (exponentialCoordinates_mem ht z))
+
+private theorem CuspUniformization.exponentialPoint_surjective_fibre {t : ℂ} (ht : t ≠ 0)
+    {x : ToricSpace.Space} (hx : ToricSpace.time x = t) :
+    ∃ z : ComplexPlane₂, exponentialPoint t z = x := by
+  have hxT : x ∈ ToricSpace.openTorus := (ToricSpace.mem_openTorus_iff _).mpr (hx ▸ ht)
+  let z : ComplexPlane₂ := fun i => logarithm (ToricSpace.torusCoordinates x i.castSucc)
+  refine ⟨z, torusCoordinates_injective (exponentialPoint_mem ht z) hxT ?_⟩
+  rw [torusCoordinates_exponentialPoint ht]
+  ext i
+  fin_cases i
+  · exact exponential_logarithm (ToricSpace.torusCoordinates_nonzero hxT 0)
+  · exact exponential_logarithm (ToricSpace.torusCoordinates_nonzero hxT 1)
+  · simpa [exponentialCoordinates] using hx.symm
+
+private theorem
+    CuspUniformization.exponentialPoint_eq_iff {t : ℂ} (ht : t ≠ 0) (z w : ComplexPlane₂) :
+    exponentialPoint t z = exponentialPoint t w ↔ ∃ m : Fin 2 → ℤ, z = w + (fun i => (m i : ℂ)) :=
+  by
+  constructor
+  · intro he
+    have hec := congrArg ToricSpace.torusCoordinates he
+    rw [torusCoordinates_exponentialPoint ht, torusCoordinates_exponentialPoint ht] at hec
+    have hi (i : Fin 2) : ∃ n : ℤ, z i = w i + n := by
+      apply (exponential_eq_iff _ _).mp
+      have hi := congrFun hec i.castSucc
+      fin_cases i <;> exact hi
+    choose m hm using hi
+    exact ⟨m, funext hm⟩
+  · rintro ⟨m, rfl⟩
+    apply torusCoordinates_injective (exponentialPoint_mem ht _) (exponentialPoint_mem ht _)
+    rw [torusCoordinates_exponentialPoint ht, torusCoordinates_exponentialPoint ht]
+    ext i
+    fin_cases i
+    · exact (exponential_eq_iff _ _).mpr ⟨m 0, rfl⟩
+    · exact (exponential_eq_iff _ _).mpr ⟨m 1, rfl⟩
+    · rfl
+
+private theorem CuspUniformization.torusPoint_holomorphic :
+    ContMDiffOn (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω torusPoint ToricCharts.torus :=
+  (ToricSpace.inclusion_holomorphic ToricSpace.referenceTriangle).comp_contMDiffOn
+    ((ToricCharts.monomial_contDiffOn ToricSpace.referenceTriangle.dual ω).mono
+        (ToricCharts.torus_subset_domain _)).contMDiffOn
+
+private def CuspUniformization.torusChart :
+    OpenPartialHomeomorph ToricSpace.Space (ToricCharts.CoordinateSpace 3)
+    where
+  toFun := ToricSpace.torusCoordinates
+  invFun := torusPoint
+  source := ToricSpace.openTorus
+  target := ToricCharts.torus
+  map_source' _ hx := ToricSpace.torusCoordinates_nonzero hx
+  map_target' _ hw := torusPoint_mem hw
+  left_inv' _ hx := torusPoint_torusCoordinates hx
+  right_inv' _ hw := torusCoordinates_torusPoint hw
+  open_source := ToricSpace.openTorus_isOpen
+  open_target := ToricCharts.torus_open
+  continuousOn_toFun := ToricSpace.torusCoordinates_holomorphic.continuousOn
+  continuousOn_invFun := torusPoint_holomorphic.continuousOn
+
+private def CuspUniformization.logarithmicPeriod (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (s : ℂ) :
+    Matrix (Fin 2) (Fin 2) ℂ :=
+  s • B₀.map (Int.castRingHom ℂ) + C (exponential s)
+
+private theorem
+    CuspUniformization.logarithmicPeriod_apply (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (s : ℂ)
+    (v : Fin 2 → ℤ) (i : Fin 2) :
+    (logarithmicPeriod C s *ᵥ (fun j => (v j : ℂ))) i =
+      s * (ToricSpace.cuspVector v i : ℂ) + (C (exponential s) *ᵥ (fun j => (v j : ℂ))) i := by
+  fin_cases i <;>
+      simp [logarithmicPeriod, B₀, ToricSpace.cuspVector, Matrix.mulVec, dotProduct,
+        Fin.sum_univ_two, smul_eq_mul] <;>
+    ring
+
+private theorem CuspUniformization.imaginary_displacement (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (s : ℂ)
+    (ht : Real.log ‖exponential s‖ ≠ 0) (v : Fin 2 → ℝ) :
+    Real.log ‖exponential s‖ • ToricSpace.displacement C (exponential s) v =
+      (-2 * Real.pi) • ((logarithmicPeriod C s).map Complex.im *ᵥ v) := by
+  change
+    Real.log ‖exponential s‖ •
+        (ToricSpace.realCuspVector v +
+          (Real.log ‖exponential s‖)⁻¹ • (ToricSpace.driftMatrix C (exponential s) *ᵥ v)) =
+      _
+  rw [smul_add, smul_smul, mul_inv_cancel₀ ht, one_smul]
+  ext i
+  fin_cases i <;>
+      simp [logarithmicPeriod, B₀, ToricSpace.realCuspVector, ToricSpace.driftMatrix, smul_eq_mul,
+        log_norm_exponential] <;>
+    ring
+
+private theorem
+    CuspUniformization.logarithmicPeriod_nondegenerate (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (s : ℂ) (ht : Real.log ‖exponential s‖ < 0)
+    (hR :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4) :
+    Function.Bijective ((logarithmicPeriod C s).map Complex.im).mulVecLin := by
+  have hinj : Function.Injective ((logarithmicPeriod C s).map Complex.im).mulVecLin := by
+    apply LinearMap.ker_eq_bot.mp
+    apply LinearMap.ker_eq_bot'.mpr
+    intro v hv
+    have he := imaginary_displacement C s ht.ne v
+    change (logarithmicPeriod C s).map Complex.im *ᵥ v = 0 at hv
+    rw [hv, smul_zero] at he
+    have hd : ToricSpace.displacement C (exponential s) v = 0 :=
+      (smul_eq_zero.mp he).resolve_left ht.ne
+    exact (ToricSpace.displacement_bijective C ht hR).injective (hd.trans (map_zero _).symm)
+  exact ⟨hinj, LinearMap.surjective_of_injective hinj⟩
+
+private def CuspUniformization.periodData (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (s : ℂ)
+    (ht : Real.log ‖exponential s‖ < 0)
+    (hR :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4) :
+    FullPeriodMatrix :=
+  ⟨logarithmicPeriod C s, logarithmicPeriod_nondegenerate C s ht hR⟩
+
+private theorem CuspUniformization.exponential_logarithmicPeriod (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (s : ℂ) (v : Fin 2 → ℤ) (i : Fin 2) :
+    exponential ((logarithmicPeriod C s *ᵥ (fun j => (v j : ℂ))) i) =
+      (ToricSpace.exponentialMultiplier C v (exponential s) i : ℂ) *
+        exponential s ^ ToricSpace.cuspVector v i := by
+  rw [logarithmicPeriod_apply, exponential_add]
+  have he :
+    exponential (s * (ToricSpace.cuspVector v i : ℂ)) =
+      exponential s ^ ToricSpace.cuspVector v i := by
+    unfold exponential
+    rw [show
+        (2 * Real.pi * Complex.I : ℂ) * (s * (ToricSpace.cuspVector v i : ℂ)) =
+          (ToricSpace.cuspVector v i : ℂ) * (2 * Real.pi * Complex.I * s)
+        by ring,
+      Complex.exp_int_mul]
+  rw [he]
+  exact mul_comm _ _
+
+private theorem
+    CuspUniformization.twistedTranslate_exponentialPoint (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (s : ℂ) (v : Fin 2 → ℤ) (z : ComplexPlane₂) :
+    ToricSpace.twistedTranslate C v (exponentialPoint (exponential s) z) =
+      exponentialPoint (exponential s) (z + logarithmicPeriod C s *ᵥ (fun j => (v j : ℂ))) := by
+  have ht := exponential_ne_zero s
+  have hx := exponentialPoint_mem ht z
+  have hx' :
+    ToricSpace.twistedTranslate C v (exponentialPoint (exponential s) z) ∈ ToricSpace.openTorus :=
+    by simpa only [ToricSpace.mem_openTorus_iff, ToricSpace.time_twistedTranslate] using hx
+  apply torusCoordinates_injective hx' (exponentialPoint_mem ht _)
+  have hi (i : Fin 2) :
+    ToricSpace.torusCoordinates
+        (ToricSpace.twistedTranslate C v (exponentialPoint (exponential s) z)) i.castSucc =
+      exponential (z i + (logarithmicPeriod C s *ᵥ (fun j => (v j : ℂ))) i) := by
+    rw [ToricSpace.torusCoordinates_twistedTranslate_apply C v hx, time_exponentialPoint ht]
+    have hz :
+      ToricSpace.torusCoordinates (exponentialPoint (exponential s) z) i.castSucc =
+        exponential (z i) := by
+      rw [torusCoordinates_exponentialPoint ht]
+      fin_cases i <;> rfl
+    rw [hz, exponential_add, exponential_logarithmicPeriod]
+    ring
+  rw [torusCoordinates_exponentialPoint ht]
+  ext i
+  fin_cases i
+  · exact hi 0
+  · exact hi 1
+  · simp [exponentialCoordinates, ToricSpace.time_twistedTranslate, time_exponentialPoint ht]
+
+private def CuspUniformization.exponentialLift (ε : ℝ) (s : ℂ) (hs : ‖exponential s‖ < ε)
+    (z : ComplexPlane₂) : ToricSpace.Tube (CuspQuotient.disc ε) :=
+  ⟨exponentialPoint (exponential s) z,
+    by
+    change ToricSpace.time (exponentialPoint (exponential s) z) ∈ Metric.ball 0 ε
+    simpa only [time_exponentialPoint (exponential_ne_zero s), Metric.mem_ball,
+      dist_zero_right] using hs⟩
+
+private theorem
+    CuspUniformization.exponentialLift_continuous (ε : ℝ) (s : ℂ) (hs : ‖exponential s‖ < ε) :
+    Continuous (exponentialLift ε s hs) :=
+  (exponentialPoint_holomorphic (exponential_ne_zero s)).continuous.subtype_mk _
+
+private theorem CuspUniformization.exponentialLift_holomorphic (ε : ℝ) (s : ℂ)
+    (hs : ‖exponential s‖ < ε) :
+    ContMDiff (modelWithCornersSelf ℂ ComplexPlane₂)
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (exponentialLift ε s hs) := by
+  intro z
+  have he :
+    ContMDiffAt (modelWithCornersSelf ℂ ComplexPlane₂)
+        (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω
+        (fun w => (exponentialLift ε s hs w : ToricSpace.Space)) z ↔
+      ContMDiffAt (modelWithCornersSelf ℂ ComplexPlane₂)
+        (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (exponentialLift ε s hs) z :=
+    ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+  exact he.mp (exponentialPoint_holomorphic (exponential_ne_zero s) z)
+
+private def CuspUniformization.fibreCover (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (s : ℂ)
+    (hs : ‖exponential s‖ < ε) : ComplexPlane₂ → CuspQuotient.QuotientSpace C ε :=
+  CuspQuotient.quotientMap C ε ∘ exponentialLift ε s hs
+
+private theorem CuspUniformization.fibreCover_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (s : ℂ) (hs : ‖exponential s‖ < ε) : Continuous (fibreCover C ε s hs) :=
+  (CuspQuotient.quotientMap_continuous C ε).comp (exponentialLift_continuous ε s hs)
+
+@[simp]
+private theorem CuspUniformization.projection_fibreCover (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (s : ℂ) (hs : ‖exponential s‖ < ε) (z : ComplexPlane₂) :
+    CuspQuotient.projection C ε (fibreCover C ε s hs z) = exponential s :=
+  time_exponentialPoint (exponential_ne_zero s) z
+
+private theorem
+    CuspUniformization.fibreCover_eq_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (s : ℂ)
+    (hs : ‖exponential s‖ < ε) (hlog : Real.log ‖exponential s‖ < 0)
+    (hRp :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4)
+    (z w : ComplexPlane₂) :
+    fibreCover C ε s hs z = fibreCover C ε s hs w ↔ z - w ∈ (periodData C s hlog hRp).lattice := by
+  let := ToricSpace.tubeAction C (CuspQuotient.disc ε)
+  constructor
+  · intro he
+    have horb := Quotient.exact he
+    change
+      exponentialLift ε s hs z ∈
+        MulAction.orbit CuspQuotient.LatticeGroup (exponentialLift ε s hs w) at horb
+    obtain ⟨g, hg⟩ := horb
+    have hp :
+      exponentialPoint (exponential s) z =
+        exponentialPoint (exponential s)
+          (w + logarithmicPeriod C s *ᵥ (fun j => (g.toAdd j : ℂ))) :=
+      (congrArg Subtype.val hg).symm.trans (twistedTranslate_exponentialPoint C s g.toAdd w)
+    obtain ⟨m, hm⟩ := (exponentialPoint_eq_iff (exponential_ne_zero s) _ _).mp hp
+    apply (FullPeriodMatrix.mem_lattice_iff _ _).mpr
+    refine ⟨m, g.toAdd, ?_⟩
+    change z - w = (fun i => (m i : ℂ)) + logarithmicPeriod C s *ᵥ (fun j => (g.toAdd j : ℂ))
+    rw [hm]
+    abel
+  · intro he
+    obtain ⟨m, n, hmn⟩ := (FullPeriodMatrix.mem_lattice_iff _ _).mp he
+    have hp :
+      exponentialPoint (exponential s) z =
+        exponentialPoint (exponential s) (w + logarithmicPeriod C s *ᵥ (fun j => (n j : ℂ))) := by
+      apply (exponentialPoint_eq_iff (exponential_ne_zero s) _ _).mpr
+      refine ⟨m, ?_⟩
+      have he := sub_eq_iff_eq_add.mp hmn
+      change z = (fun i => (m i : ℂ)) + logarithmicPeriod C s *ᵥ (fun j => (n j : ℂ)) + w at he
+      rw [he]
+      abel
+    have hl :
+      exponentialLift ε s hs z =
+        ToricSpace.tubeTranslate C (CuspQuotient.disc ε) n (exponentialLift ε s hs w) :=
+      Subtype.ext (hp.trans (twistedTranslate_exponentialPoint C s n w).symm)
+    change
+      CuspQuotient.quotientMap C ε (exponentialLift ε s hs z) =
+        CuspQuotient.quotientMap C ε (exponentialLift ε s hs w)
+    rw [hl, CuspQuotient.quotientMap_translate]
+
+private def CuspUniformization.fibreMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (s : ℂ)
+    (hs : ‖exponential s‖ < ε) (hlog : Real.log ‖exponential s‖ < 0)
+    (hRp :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4) :
+    (periodData C s hlog hRp).Torus → CuspQuotient.QuotientSpace C ε :=
+  Quotient.lift (fibreCover C ε s hs)
+    (by
+      intro z w hzw
+      apply (fibreCover_eq_iff C ε s hs hlog hRp z w).mpr
+      exact (Submodule.Quotient.eq _).mp (Quotient.sound hzw))
+
+private theorem
+    CuspUniformization.fibreMap_injective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (s : ℂ)
+    (hs : ‖exponential s‖ < ε) (hlog : Real.log ‖exponential s‖ < 0)
+    (hRp :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4) :
+    Function.Injective (fibreMap C ε s hs hlog hRp) := by
+  intro x y
+  induction x using Quotient.inductionOn with
+  | h z =>
+    induction y using Quotient.inductionOn with
+    | h w =>
+      intro he
+      exact (Submodule.Quotient.eq _).mpr ((fibreCover_eq_iff C ε s hs hlog hRp z w).mp he)
+
+private theorem
+    CuspUniformization.fibreMap_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (s : ℂ)
+    (hs : ‖exponential s‖ < ε) (hlog : Real.log ‖exponential s‖ < 0)
+    (hRp :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4) :
+    Continuous (fibreMap C ε s hs hlog hRp) :=
+  (fibreCover_continuous C ε s hs).quotient_lift _
+
+@[simp]
+private theorem
+    CuspUniformization.projection_fibreMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (s : ℂ)
+    (hs : ‖exponential s‖ < ε) (hlog : Real.log ‖exponential s‖ < 0)
+    (hRp :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4)
+    (x : (periodData C s hlog hRp).Torus) :
+    CuspQuotient.projection C ε (fibreMap C ε s hs hlog hRp x) = exponential s := by
+  induction x using Quotient.inductionOn with
+  | h z => exact projection_fibreCover C ε s hs z
+
+private theorem CuspUniformization.fibreMap_range (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (s : ℂ)
+    (hs : ‖exponential s‖ < ε) (hlog : Real.log ‖exponential s‖ < 0)
+    (hRp :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4) :
+    Set.range (fibreMap C ε s hs hlog hRp) = CuspQuotient.projection C ε ⁻¹' {exponential s} := by
+  ext q
+  constructor
+  · rintro ⟨x, rfl⟩
+    exact projection_fibreMap C ε s hs hlog hRp x
+  · induction q using Quotient.inductionOn with
+    | h x =>
+      intro hx
+      have ht : ToricSpace.time (x : ToricSpace.Space) = exponential s := hx
+      obtain ⟨z, hz⟩ := exponentialPoint_surjective_fibre (exponential_ne_zero s) ht
+      refine ⟨(periodData C s hlog hRp).lattice.mkQ z, ?_⟩
+      apply congrArg (CuspQuotient.quotientMap C ε)
+      exact Subtype.ext hz
+
+private theorem
+    CuspUniformization.fibreMap_holomorphic (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (s : ℂ)
+    (hs : ‖exponential s‖ < ε) (hlog : Real.log ‖exponential s‖ < 0)
+    (hRp :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    letI := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+    ContMDiff (modelWithCornersSelf ℂ ComplexPlane₂)
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (fibreMap C ε s hs hlog hRp) := by
+  let := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+  apply DiscreteQuotient.contMDiff_of_comp_mkQ
+  exact
+    (CuspQuotient.quotientMap_holomorphic C ε hε hε1 hC hR).comp
+      (exponentialLift_holomorphic ε s hs)
+
+private def CuspUniformization.fibreMapToFibre (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (s : ℂ)
+    (hs : ‖exponential s‖ < ε) (hlog : Real.log ‖exponential s‖ < 0)
+    (hRp :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4)
+    (x : (periodData C s hlog hRp).Torus) : CuspQuotient.projection C ε ⁻¹' {exponential s} :=
+  ⟨fibreMap C ε s hs hlog hRp x, projection_fibreMap C ε s hs hlog hRp x⟩
+
+private theorem
+    CuspUniformization.fibreMapToFibre_bijective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (s : ℂ) (hs : ‖exponential s‖ < ε) (hlog : Real.log ‖exponential s‖ < 0)
+    (hRp :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4) :
+    Function.Bijective (fibreMapToFibre C ε s hs hlog hRp) := by
+  constructor
+  · intro x y he
+    exact fibreMap_injective C ε s hs hlog hRp (congrArg Subtype.val he)
+  · intro q
+    have hq : (q : CuspQuotient.QuotientSpace C ε) ∈ Set.range (fibreMap C ε s hs hlog hRp) := by
+      rw [fibreMap_range]
+      exact q.2
+    obtain ⟨x, hx⟩ := hq
+    exact ⟨x, Subtype.ext hx⟩
+
+private def CuspUniformization.fibreHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (s : ℂ)
+    (hs : ‖exponential s‖ < ε) (hlog : Real.log ‖exponential s‖ < 0)
+    (hRp :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    (periodData C s hlog hRp).Torus ≃ₜ CuspQuotient.projection C ε ⁻¹' {exponential s} := by
+  let := CuspQuotient.quotient_t2Space C ε hε hε1 hC hR
+  let e :=
+    Equiv.ofBijective (fibreMapToFibre C ε s hs hlog hRp)
+      (fibreMapToFibre_bijective C ε s hs hlog hRp)
+  exact
+    Continuous.homeoOfEquivCompactToT2 (f := e)
+      ((fibreMap_continuous C ε s hs hlog hRp).subtype_mk _)
+
+private theorem
+    CuspUniformization.fibreMap_isEmbedding (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (s : ℂ)
+    (hs : ‖exponential s‖ < ε) (hlog : Real.log ‖exponential s‖ < 0)
+    (hRp :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : Topology.IsEmbedding (fibreMap C ε s hs hlog hRp) := by
+  exact
+    Topology.IsEmbedding.subtypeVal.comp
+      (fibreHomeomorph C ε s hs hlog hRp hε hε1 hC hR).isEmbedding
+
+private theorem CuspUniformization.nonzero_fibre_torus (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) {t : ℂ} (ht0 : t ≠ 0) (ht : ‖t‖ < ε) :
+    letI := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+    ∃ p : FullPeriodMatrix,
+      ∃ f : p.Torus → CuspQuotient.QuotientSpace C ε,
+        ContMDiff (modelWithCornersSelf ℂ ComplexPlane₂)
+            (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω f ∧
+          Topology.IsEmbedding f ∧ Set.range f = CuspQuotient.projection C ε ⁻¹' { t } := by
+  let := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+  let s := logarithm t
+  have hst : exponential s = t := exponential_logarithm ht0
+  have hs : ‖exponential s‖ < ε := by simpa only [hst] using ht
+  have hpos : 0 < ‖exponential s‖ := norm_pos_iff.mpr (exponential_ne_zero s)
+  have hlog := Real.log_neg hpos (hs.trans hε1)
+  have hRp := hR _ hpos hs
+  refine
+    ⟨periodData C s hlog hRp, fibreMap C ε s hs hlog hRp,
+      fibreMap_holomorphic C ε s hs hlog hRp hε hε1 hC hR,
+      fibreMap_isEmbedding C ε s hs hlog hRp hε hε1 hC hR, ?_⟩
+  simpa only [hst] using fibreMap_range C ε s hs hlog hRp
+
+private theorem
+    CuspUniformization.nonzero_fibre_pathConnected (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) {t : ℂ} (ht0 : t ≠ 0) (ht : ‖t‖ < ε) :
+    IsPathConnected (CuspQuotient.projection C ε ⁻¹' { t }) := by
+  let := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+  obtain ⟨p, f, hf, _, he⟩ := nonzero_fibre_torus C ε hε hε1 hC hR ht0 ht
+  rw [← he]
+  exact isPathConnected_range hf.continuous
+
+private theorem
+    CuspUniformization.fibre_connected (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε)
+    (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (t : CuspQuotient.disc ε) :
+    IsConnected (CuspQuotient.projection C ε ⁻¹' {(t : ℂ)}) := by
+  by_cases ht0 : (t : ℂ) = 0
+  · rw [ht0]
+    exact CuspQuotient.central_fibre_connected C ε hε
+  · have ht : ‖(t : ℂ)‖ < ε := by
+      have htball : (t : ℂ) ∈ Metric.ball 0 ε := t.2
+      simpa only [Metric.mem_ball, dist_zero_right] using htball
+    exact (nonzero_fibre_pathConnected C ε hε hε1 hC hR ht0 ht).isConnected
+
+private def CuspUniformization.exponentialPair (z : ComplexPlane₂) : ComplexPlane₂ := fun i =>
+  exponential (z i)
+
+private theorem CuspUniformization.exponential_hasDerivAt (z : ℂ) :
+    HasDerivAt exponential (exponential z * (2 * Real.pi * Complex.I)) z := by
+  change
+    HasDerivAt (fun w : ℂ => Complex.exp (2 * Real.pi * Complex.I * w))
+      (Complex.exp (2 * Real.pi * Complex.I * z) * (2 * Real.pi * Complex.I)) z
+  convert! ((hasDerivAt_id z).const_mul (2 * Real.pi * Complex.I)).cexp using 1
+  simp
+
+private def CuspUniformization.exponentialPairDerivative (z : ComplexPlane₂) :
+    ComplexPlane₂ ≃L[ℂ] ComplexPlane₂ :=
+  ContinuousLinearEquiv.piCongrRight fun i =>
+    ContinuousLinearEquiv.unitsEquivAut ℂ
+      (Units.mk0 (exponential (z i) * (2 * Real.pi * Complex.I))
+        (mul_ne_zero (exponential_ne_zero _) exponential_factor_ne_zero))
+
+private theorem CuspUniformization.exponentialPair_hasFDerivAt (z : ComplexPlane₂) :
+    HasFDerivAt exponentialPair (exponentialPairDerivative z : ComplexPlane₂ →L[ℂ] ComplexPlane₂)
+      z := by
+  apply hasFDerivAt_pi''
+  intro i
+  convert!
+    ((exponential_hasDerivAt (z i)).hasFDerivAt_equiv
+          (mul_ne_zero (exponential_ne_zero _) exponential_factor_ne_zero)).comp
+      z (hasFDerivAt_apply (𝕜 := ℂ) i z) using
+    1
+
+/-- The two-by-two period correction matrix determined by three coefficient functions. -/
+public
+def SpecialPeriods.cuspCorrection (μ b h : ℂ → ℂ) (t : ℂ) : Matrix (Fin 2) (Fin 2) ℂ :=
+  !![6 * μ t, h t; b t - h t, μ t]
+
+private theorem SpecialPeriods.cuspCorrection_holomorphicOn {μ b h : ℂ → ℂ} {U : Set ℂ}
+    (hμ : ContDiffOn ℂ ω μ U) (hb : ContDiffOn ℂ ω b U) (hh : ContDiffOn ℂ ω h U) (i j : Fin 2) :
+    ContDiffOn ℂ ω (fun t => cuspCorrection μ b h t i j) U := by
+  fin_cases i <;> fin_cases j
+  · exact contDiffOn_const.mul hμ
+  · exact hh
+  · exact hb.sub hh
+  · exact hμ
+
+private theorem SpecialPeriods.exists_cuspCorrection_admissible_radius {μ b h : ℂ → ℂ} {r : ℝ}
+    (hr : 0 < r) (hμ : ContDiffOn ℂ ω μ (Metric.ball 0 r))
+    (hb : ContDiffOn ℂ ω b (Metric.ball 0 r)) (hh : ContDiffOn ℂ ω h (Metric.ball 0 r)) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ε < r ∧
+          ε < 1 ∧
+            ToricSpace.SmallDrift (cuspCorrection μ b h) ε ∧
+              ∀ i j, ContDiffOn ℂ ω (fun t => cuspCorrection μ b h t i j) (Metric.ball 0 ε) :=
+  CuspQuotient.exists_admissible_radius (cuspCorrection μ b h) hr
+    (cuspCorrection_holomorphicOn hμ hb hh)
+
+private theorem SpecialPeriods.exists_cuspCorrection_admissible_radius_of_analyticAt {μ b h : ℂ → ℂ}
+    (hμ : AnalyticAt ℂ μ 0) (hb : AnalyticAt ℂ b 0) (hh : AnalyticAt ℂ h 0) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ε < 1 ∧
+          ToricSpace.SmallDrift (cuspCorrection μ b h) ε ∧
+            ∀ i j, ContDiffOn ℂ ω (fun t => cuspCorrection μ b h t i j) (Metric.ball 0 ε) := by
+  obtain ⟨r, hr, hball⟩ :=
+    Metric.mem_nhds_iff.mp
+      (hμ.eventually_analyticAt.and (hb.eventually_analyticAt.and hh.eventually_analyticAt))
+  have hμr : ContDiffOn ℂ ω μ (Metric.ball 0 r) := fun t ht =>
+    (hball ht).1.contDiffAt.contDiffWithinAt
+  have hbr : ContDiffOn ℂ ω b (Metric.ball 0 r) := fun t ht =>
+    (hball ht).2.1.contDiffAt.contDiffWithinAt
+  have hhr : ContDiffOn ℂ ω h (Metric.ball 0 r) := fun t ht =>
+    (hball ht).2.2.contDiffAt.contDiffWithinAt
+  obtain ⟨ε, hε, _, hε1, hR, hC⟩ := exists_cuspCorrection_admissible_radius hr hμr hbr hhr
+  exact ⟨ε, hε, hε1, hR, hC⟩
+
+private def SpecialPeriods.cuspPeriodPoint (μ b h : ℂ → ℂ) (s : ℂ) : PeriodPoint :=
+  ⟨s + h (CuspUniformization.exponential s), μ (CuspUniformization.exponential s),
+    b (CuspUniformization.exponential s) - s - h (CuspUniformization.exponential s)⟩
+
+private theorem SpecialPeriods.cuspPeriodPoint_leftBlock (μ b h : ℂ → ℂ) (s : ℂ) :
+    (cuspPeriodPoint μ b h s).leftBlock =
+      CuspUniformization.logarithmicPeriod (cuspCorrection μ b h) s := by
+  ext i j
+  fin_cases i <;> fin_cases j <;>
+    simp [cuspPeriodPoint, PeriodPoint.leftBlock, CuspUniformization.logarithmicPeriod,
+      cuspCorrection, B₀, smul_eq_mul]
+  ring
+
+private theorem SpecialPeriods.correction_im_bound_of_smallDrift (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (s : ℂ)
+    (hR :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (CuspUniformization.exponential s)) ≤
+        -Real.log ‖CuspUniformization.exponential s‖ / 4)
+    (i j : Fin 2) : |(C (CuspUniformization.exponential s) i j).im| ≤ s.im / 4 := by
+  have hentry :
+    ‖ToricSpace.driftMatrix C (CuspUniformization.exponential s) i j‖ ≤
+      -Real.log ‖CuspUniformization.exponential s‖ / 4 :=
+    ((norm_le_pi_norm (ToricSpace.driftMatrix C (CuspUniformization.exponential s) i) j).trans
+          (norm_le_pi_norm
+            (fun k : Fin 2 => fun l : Fin 2 =>
+              ToricSpace.driftMatrix C (CuspUniformization.exponential s) k l)
+            i)).trans
+      hR
+  have hscaled :
+    (2 * Real.pi) * |(C (CuspUniformization.exponential s) i j).im| ≤
+      (2 * Real.pi) * (s.im / 4) := by
+    simpa [ToricSpace.driftMatrix, Real.norm_eq_abs, abs_mul, abs_of_pos Real.pi_pos,
+      CuspUniformization.log_norm_exponential, neg_mul, mul_div_assoc] using hentry
+  exact le_of_mul_le_mul_left hscaled (by positivity : 0 < 2 * Real.pi)
+
+private theorem SpecialPeriods.cuspPeriodPoint_admissible (μ b h : ℂ → ℂ) (s : ℂ)
+    (hlog : Real.log ‖CuspUniformization.exponential s‖ < 0)
+    (hR :
+      ToricSpace.entryNorm
+          (ToricSpace.driftMatrix (cuspCorrection μ b h) (CuspUniformization.exponential s)) ≤
+        -Real.log ‖CuspUniformization.exponential s‖ / 4) :
+    (cuspPeriodPoint μ b h s).Admissible := by
+  have hs : 0 < s.im := by
+    rw [CuspUniformization.log_norm_exponential] at hlog
+    have hp := Real.pi_pos
+    nlinarith
+  have hh := (abs_le.mp (correction_im_bound_of_smallDrift (cuspCorrection μ b h) s hR 0 1)).1
+  have hbh := (abs_le.mp (correction_im_bound_of_smallDrift (cuspCorrection μ b h) s hR 1 0)).2
+  change -(s.im / 4) ≤ (h (CuspUniformization.exponential s)).im at hh
+  change
+    (b (CuspUniformization.exponential s) - h (CuspUniformization.exponential s)).im ≤
+      s.im / 4 at hbh
+  have hτ : 0 < (s + h (CuspUniformization.exponential s)).im := by
+    rw [Complex.add_im]
+    linarith
+  have hβ :
+    (b (CuspUniformization.exponential s) - s - h (CuspUniformization.exponential s)).im < 0 := by
+    rw [Complex.sub_im] at hbh
+    rw [Complex.sub_im, Complex.sub_im]
+    linarith
+  refine ⟨hτ, ?_⟩
+  change
+    (b (CuspUniformization.exponential s) - s - h (CuspUniformization.exponential s)).im -
+        6 * (μ (CuspUniformization.exponential s)).im ^ 2 /
+          (s + h (CuspUniformization.exponential s)).im <
+      0
+  have hn :
+    0 ≤
+      6 * (μ (CuspUniformization.exponential s)).im ^ 2 /
+        (s + h (CuspUniformization.exponential s)).im :=
+    div_nonneg (mul_nonneg (by norm_num) (sq_nonneg _)) hτ.le
+  linarith
+
+private def SpecialPeriods.cuspPeriodDomain (μ b h : ℂ → ℂ) (s : ℂ)
+    (hlog : Real.log ‖CuspUniformization.exponential s‖ < 0)
+    (hR :
+      ToricSpace.entryNorm
+          (ToricSpace.driftMatrix (cuspCorrection μ b h) (CuspUniformization.exponential s)) ≤
+        -Real.log ‖CuspUniformization.exponential s‖ / 4) :
+    PeriodDomain :=
+  ⟨cuspPeriodPoint μ b h s, cuspPeriodPoint_admissible μ b h s hlog hR⟩
+
+private theorem SpecialPeriods.leftBlock_eq_logarithmicPeriod_of_cusp_expansion (μ b h : ℂ → ℂ)
+    (p : PeriodPoint) (s : ℂ) (hτ : p.τ = s + h (CuspUniformization.exponential s))
+    (hμ : p.μ = μ (CuspUniformization.exponential s))
+    (hβ : p.β = b (CuspUniformization.exponential s) - s - h (CuspUniformization.exponential s)) :
+    p.leftBlock = CuspUniformization.logarithmicPeriod (cuspCorrection μ b h) s := by
+  have hp : p = cuspPeriodPoint μ b h s := PeriodPoint.ext hτ hμ hβ
+  rw [hp, cuspPeriodPoint_leftBlock]
+
+private theorem SpecialPeriods.cusp_period_lattice_eq (μ b h : ℂ → ℂ) (p : PeriodDomain) (s : ℂ)
+    (hτ : p.val.τ = s + h (CuspUniformization.exponential s))
+    (hμ : p.val.μ = μ (CuspUniformization.exponential s))
+    (hβ :
+      p.val.β = b (CuspUniformization.exponential s) - s - h (CuspUniformization.exponential s))
+    (hlog : Real.log ‖CuspUniformization.exponential s‖ < 0)
+    (hRp :
+      ToricSpace.entryNorm
+          (ToricSpace.driftMatrix (cuspCorrection μ b h) (CuspUniformization.exponential s)) ≤
+        -Real.log ‖CuspUniformization.exponential s‖ / 4) :
+    (CuspUniformization.periodData (cuspCorrection μ b h) s hlog hRp).lattice = p.lattice := by
+  apply p.fullPeriodLattice_eq
+  exact (leftBlock_eq_logarithmicPeriod_of_cusp_expansion μ b h p.val s hτ hμ hβ).symm
+
+/-- The logarithmic covering domain lying over a disc of radius `ε`. -/
+public
+def CuspUniformization.logDomain (ε : ℝ) : TopologicalSpace.Opens (ℂ × ComplexPlane₂) :=
+  ⟨(fun p : ℂ × ComplexPlane₂ => exponential p.1) ⁻¹' Metric.ball 0 ε,
+    Metric.isOpen_ball.preimage (exponential_holomorphic.continuous.comp continuous_fst)⟩
+
+/-- The logarithmic cover of the radius-`ε` cusp domain. -/
+public
+abbrev CuspUniformization.LogCover (ε : ℝ) :=
+  logDomain ε
+
+@[simp]
+private theorem CuspUniformization.mem_logDomain (ε : ℝ) (p : ℂ × ComplexPlane₂) :
+    p ∈ logDomain ε ↔ ‖exponential p.1‖ < ε := by simp [logDomain, Metric.mem_ball]
+
+private def CuspUniformization.puncturedTubeOpen (ε : ℝ) :
+    TopologicalSpace.Opens (ToricSpace.Tube (CuspQuotient.disc ε)) :=
+  ⟨{x | ToricSpace.time (x : ToricSpace.Space) ≠ 0},
+    isOpen_ne_fun (ToricSpace.time_holomorphic.continuous.comp continuous_subtype_val)
+      continuous_const⟩
+
+private abbrev CuspUniformization.PuncturedTube (ε : ℝ) :=
+  puncturedTubeOpen ε
+
+private def CuspUniformization.puncturedQuotientOpen (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    TopologicalSpace.Opens (CuspQuotient.QuotientSpace C ε) :=
+  ⟨{x | CuspQuotient.projection C ε x ≠ 0},
+    isOpen_ne_fun (CuspQuotient.projection_continuous C ε) continuous_const⟩
+
+private abbrev CuspUniformization.PuncturedQuotient (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :=
+  puncturedQuotientOpen C ε
+
+private def CuspUniformization.totalExponentialPoint (p : ℂ × ComplexPlane₂) : ToricSpace.Space :=
+  exponentialPoint (exponential p.1) p.2
+
+@[simp]
+private theorem CuspUniformization.time_totalExponentialPoint (p : ℂ × ComplexPlane₂) :
+    ToricSpace.time (totalExponentialPoint p) = exponential p.1 :=
+  time_exponentialPoint (exponential_ne_zero p.1) p.2
+
+private theorem CuspUniformization.totalExponentialPoint_holomorphic :
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω totalExponentialPoint := by
+  apply (ToricSpace.inclusion_holomorphic ToricSpace.referenceTriangle).comp
+  apply ContDiff.contMDiff
+  apply contDiffOn_univ.mp
+  apply (ToricCharts.monomial_contDiffOn ToricSpace.referenceTriangle.dual ω).comp
+  · apply ContDiff.contDiffOn
+    apply contDiff_pi.mpr
+    intro i
+    fin_cases i
+    · exact exponential_holomorphic.comp ((contDiff_apply ℂ ℂ 0).comp contDiff_snd)
+    · exact exponential_holomorphic.comp ((contDiff_apply ℂ ℂ 1).comp contDiff_snd)
+    · exact exponential_holomorphic.comp contDiff_fst
+  · intro p _
+    exact
+      ToricCharts.torus_subset_domain _ (exponentialCoordinates_mem (exponential_ne_zero p.1) p.2)
+
+private def CuspUniformization.totalExponentialLift (ε : ℝ) (p : LogCover ε) :
+    ToricSpace.Tube (CuspQuotient.disc ε) :=
+  ⟨totalExponentialPoint p,
+    by
+    change ToricSpace.time (totalExponentialPoint p) ∈ Metric.ball 0 ε
+    rw [time_totalExponentialPoint]
+    exact p.2⟩
+
+private def CuspUniformization.puncturedExponential (ε : ℝ) (p : LogCover ε) : PuncturedTube ε :=
+  ⟨totalExponentialLift ε p,
+    by
+    change ToricSpace.time (totalExponentialPoint p) ≠ 0
+    rw [time_totalExponentialPoint]
+    exact exponential_ne_zero _⟩
+
+private def CuspUniformization.totalCuspCover (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (p : LogCover ε) : CuspQuotient.QuotientSpace C ε :=
+  CuspQuotient.quotientMap C ε (totalExponentialLift ε p)
+
+@[simp]
+private theorem
+    CuspUniformization.projection_totalCuspCover (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (p : LogCover ε) : CuspQuotient.projection C ε (totalCuspCover C ε p) = exponential p.1.1 :=
+  time_totalExponentialPoint p
+
+private def CuspUniformization.puncturedCuspCover (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (p : LogCover ε) : PuncturedQuotient C ε :=
+  ⟨totalCuspCover C ε p,
+    by
+    change CuspQuotient.projection C ε (totalCuspCover C ε p) ≠ 0
+    rw [projection_totalCuspCover]
+    exact exponential_ne_zero _⟩
+
+private def CuspUniformization.puncturedQuotientMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (p : PuncturedTube ε) : PuncturedQuotient C ε :=
+  ⟨CuspQuotient.quotientMap C ε p, p.2⟩
+
+private theorem CuspUniformization.totalExponentialLift_holomorphic (ε : ℝ) :
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (totalExponentialLift ε) := by
+  intro p
+  have he :
+    ContMDiffAt (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+        (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω
+        (fun q => (totalExponentialLift ε q : ToricSpace.Space)) p ↔
+      ContMDiffAt (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+        (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (totalExponentialLift ε) p :=
+    ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+  exact he.mp (totalExponentialPoint_holomorphic.comp contMDiff_subtype_val p)
+
+private theorem CuspUniformization.puncturedExponential_surjective (ε : ℝ) :
+    Function.Surjective (puncturedExponential ε) := by
+  intro x
+  let t : ℂ := ToricSpace.time (x.1 : ToricSpace.Space)
+  have ht : t ≠ 0 := x.2
+  obtain ⟨z, hz⟩ := exponentialPoint_surjective_fibre ht (x := (x.1 : ToricSpace.Space)) rfl
+  let p : LogCover ε :=
+    ⟨(logarithm t, z), by
+      change exponential (logarithm t) ∈ Metric.ball 0 ε
+      rw [exponential_logarithm ht]
+      exact x.1.2⟩
+  refine ⟨p, Subtype.ext (Subtype.ext ?_)⟩
+  change exponentialPoint (exponential (logarithm t)) z = (x.1 : ToricSpace.Space)
+  rw [exponential_logarithm ht]
+  exact hz
+
+private theorem
+    CuspUniformization.puncturedQuotientMap_surjective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) : Function.Surjective (puncturedQuotientMap C ε) := by
+  intro q
+  obtain ⟨x, hx⟩ := Quotient.exists_rep q.1
+  have hp : ToricSpace.time (x : ToricSpace.Space) ≠ 0 := by
+    have h := q.2
+    change CuspQuotient.projection C ε q.1 ≠ 0 at h
+    rwa [← hx] at h
+  exact ⟨⟨x, hp⟩, Subtype.ext hx⟩
+
+private theorem CuspUniformization.puncturedCuspCover_surjective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) : Function.Surjective (puncturedCuspCover C ε) :=
+  (puncturedQuotientMap_surjective C ε).comp (puncturedExponential_surjective ε)
+
+/-- The relation identifying points that differ by total cusp periods. -/
+public
+def CuspUniformization.TotalPeriodRelated (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (p q : ℂ × ComplexPlane₂) : Prop :=
+  ∃ (k : ℤ) (m n : Fin 2 → ℤ),
+    p.1 = q.1 + k ∧
+      p.2 = q.2 + (fun i => (m i : ℂ)) + logarithmicPeriod C q.1 *ᵥ (fun i => (n i : ℂ))
+
+private theorem CuspUniformization.totalCuspCover_eq_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (p q : LogCover ε) : totalCuspCover C ε p = totalCuspCover C ε q ↔ TotalPeriodRelated C p q :=
+  by
+  let := ToricSpace.tubeAction C (CuspQuotient.disc ε)
+  constructor
+  · intro h
+    have hs : exponential p.1.1 = exponential q.1.1 := by
+      simpa only [projection_totalCuspCover] using congrArg (CuspQuotient.projection C ε) h
+    obtain ⟨k, hk⟩ := (exponential_eq_iff _ _).mp hs
+    have horb := Quotient.exact h
+    change
+      totalExponentialLift ε p ∈
+        MulAction.orbit CuspQuotient.LatticeGroup (totalExponentialLift ε q) at horb
+    obtain ⟨g, hg⟩ := horb
+    have hp :
+      exponentialPoint (exponential q.1.1) p.1.2 =
+        exponentialPoint (exponential q.1.1)
+          (q.1.2 + logarithmicPeriod C q.1.1 *ᵥ (fun i => (g.toAdd i : ℂ))) := by
+      have he :=
+        (congrArg Subtype.val hg).symm.trans
+          (twistedTranslate_exponentialPoint C q.1.1 g.toAdd q.1.2)
+      change exponentialPoint (exponential p.1.1) p.1.2 = _ at he
+      rwa [hs] at he
+    obtain ⟨m, hm⟩ := (exponentialPoint_eq_iff (exponential_ne_zero q.1.1) _ _).mp hp
+    refine ⟨k, m, g.toAdd, hk, ?_⟩
+    rw [hm]
+    abel
+  · rintro ⟨k, m, n, hk, hmn⟩
+    have hs := (exponential_eq_iff p.1.1 q.1.1).mpr ⟨k, hk⟩
+    have hp :
+      totalExponentialPoint p = ToricSpace.twistedTranslate C n (totalExponentialPoint q) := by
+      change
+        exponentialPoint (exponential p.1.1) p.1.2 =
+          ToricSpace.twistedTranslate C n (exponentialPoint (exponential q.1.1) q.1.2)
+      rw [hs, twistedTranslate_exponentialPoint]
+      apply (exponentialPoint_eq_iff (exponential_ne_zero q.1.1) _ _).mpr
+      refine ⟨m, ?_⟩
+      rw [hmn]
+      abel
+    have hl :
+      totalExponentialLift ε p =
+        ToricSpace.tubeTranslate C (CuspQuotient.disc ε) n (totalExponentialLift ε q) :=
+      Subtype.ext hp
+    change
+      CuspQuotient.quotientMap C ε (totalExponentialLift ε p) =
+        CuspQuotient.quotientMap C ε (totalExponentialLift ε q)
+    rw [hl, CuspQuotient.quotientMap_translate]
+
+private theorem
+    CuspUniformization.puncturedCuspCover_eq_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (p q : LogCover ε) :
+    puncturedCuspCover C ε p = puncturedCuspCover C ε q ↔ TotalPeriodRelated C p q := by
+  rw [← totalCuspCover_eq_iff C ε p q]
+  exact Subtype.ext_iff
+
+@[simp]
+private theorem CuspUniformization.exponential_add_int (s : ℂ) (k : ℤ) :
+    exponential (s + k) = exponential s := by rw [exponential_add, exponential_int, mul_one]
+
+private theorem
+    CuspUniformization.logarithmicPeriod_mulVec_add_int (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (s : ℂ) (k : ℤ) (n : Fin 2 → ℤ) :
+    logarithmicPeriod C (s + k) *ᵥ (fun i => (n i : ℂ)) =
+      logarithmicPeriod C s *ᵥ (fun i => (n i : ℂ)) + fun i =>
+        (k : ℂ) * (ToricSpace.cuspVector n i : ℂ) := by
+  ext i
+  simp only [Pi.add_apply, logarithmicPeriod_apply, exponential_add_int]
+  ring
+
+@[ext]
+private structure CuspUniformization.LogDeck where
+  k : ℤ
+  m : Fin 2 → ℤ
+  n : Fin 2 → ℤ
+  deriving DecidableEq
+
+private instance CuspUniformization.LogDeck.instLocal1 : One CuspUniformization.LogDeck :=
+  ⟨⟨0, 0, 0⟩⟩
+
+private instance CuspUniformization.LogDeck.instLocal2 : Mul CuspUniformization.LogDeck :=
+  ⟨fun g h => ⟨g.k + h.k, g.m + h.m + h.k • ToricSpace.cuspVector g.n, g.n + h.n⟩⟩
+
+private instance CuspUniformization.LogDeck.instLocal3 : Inv CuspUniformization.LogDeck :=
+  ⟨fun g => ⟨-g.k, -g.m + g.k • ToricSpace.cuspVector g.n, -g.n⟩⟩
+
+@[simp]
+private theorem CuspUniformization.LogDeck.mul_k (g h : CuspUniformization.LogDeck) :
+    (g * h).k = g.k + h.k :=
+  rfl
+
+@[simp]
+private theorem CuspUniformization.LogDeck.mul_m (g h : CuspUniformization.LogDeck) :
+    (g * h).m = g.m + h.m + h.k • ToricSpace.cuspVector g.n :=
+  rfl
+
+@[simp]
+private theorem CuspUniformization.LogDeck.mul_n (g h : CuspUniformization.LogDeck) :
+    (g * h).n = g.n + h.n :=
+  rfl
+
+private instance CuspUniformization.LogDeck.instLocal4 : Group CuspUniformization.LogDeck
+    where
+  mul_assoc g h
+    l := by
+    apply CuspUniformization.LogDeck.ext
+    · simp only [mul_k, add_assoc]
+    · simp only [mul_m, mul_k, mul_n, ToricSpace.cuspVector_add, smul_add, add_smul]
+      abel
+    · simp only [mul_n, add_assoc]
+  one_mul
+    g := by
+    have hone : (1 : CuspUniformization.LogDeck) = ⟨0, 0, 0⟩ := rfl
+    apply CuspUniformization.LogDeck.ext <;> simp [hone]
+  mul_one
+    g := by
+    have hone : (1 : CuspUniformization.LogDeck) = ⟨0, 0, 0⟩ := rfl
+    apply CuspUniformization.LogDeck.ext <;> simp [hone]
+  inv_mul_cancel
+    g := by
+    have hone : (1 : CuspUniformization.LogDeck) = ⟨0, 0, 0⟩ := rfl
+    have hinv : g⁻¹ = ⟨-g.k, -g.m + g.k • ToricSpace.cuspVector g.n, -g.n⟩ := rfl
+    apply CuspUniformization.LogDeck.ext
+    · simp [hone, hinv]
+    · ext i
+      fin_cases i <;> simp [hone, hinv, ToricSpace.cuspVector]
+    · simp [hone, hinv]
+
+private def CuspUniformization.logDeckTransform (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (g : LogDeck)
+    (x : ℂ × ComplexPlane₂) : ℂ × ComplexPlane₂ :=
+  (x.1 + g.k, x.2 + (fun i => (g.m i : ℂ)) + logarithmicPeriod C x.1 *ᵥ (fun i => (g.n i : ℂ)))
+
+@[simp]
+private theorem
+    CuspUniformization.logDeckTransform_fst (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (g : LogDeck)
+    (x : ℂ × ComplexPlane₂) : (logDeckTransform C g x).1 = x.1 + g.k :=
+  rfl
+
+@[simp]
+private theorem
+    CuspUniformization.logDeckTransform_snd (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (g : LogDeck)
+    (x : ℂ × ComplexPlane₂) :
+    (logDeckTransform C g x).2 =
+      x.2 + (fun i => (g.m i : ℂ)) + logarithmicPeriod C x.1 *ᵥ (fun i => (g.n i : ℂ)) :=
+  rfl
+
+@[simp]
+private theorem CuspUniformization.logDeckTransform_one (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (x : ℂ × ComplexPlane₂) : logDeckTransform C 1 x = x := by
+  have hone : (1 : LogDeck) = ⟨0, 0, 0⟩ := rfl
+  apply Prod.ext
+  · simp [hone, logDeckTransform]
+  · ext i
+    fin_cases i <;> simp [hone, logDeckTransform, Matrix.vecHead, Matrix.vecTail]
+
+private theorem
+    CuspUniformization.logDeckTransform_mul (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (g h : LogDeck)
+    (x : ℂ × ComplexPlane₂) :
+    logDeckTransform C (g * h) x = logDeckTransform C g (logDeckTransform C h x) := by
+  apply Prod.ext
+  · simp only [logDeckTransform_fst, LogDeck.mul_k, Int.cast_add]
+    ring
+  · ext i
+    simp only [logDeckTransform_snd, logDeckTransform_fst, LogDeck.mul_m, LogDeck.mul_n,
+      logarithmicPeriod_mulVec_add_int, Pi.add_apply, Pi.smul_apply]
+    simp only [zsmul_eq_mul, Int.cast_add, Int.cast_mul, Int.cast_id]
+    simp only [Matrix.mulVec, dotProduct, Fin.sum_univ_two]
+    ring
+
+private theorem CuspUniformization.logDeckTransform_eq_self_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (g : LogDeck) (x : ℂ × ComplexPlane₂)
+    (hP : Function.Bijective ((logarithmicPeriod C x.1).map Complex.im).mulVecLin) :
+    logDeckTransform C g x = x ↔ g = 1 := by
+  constructor
+  · intro hx
+    have hk : g.k = 0 := by
+      have he := congrArg Prod.fst hx
+      have he' : (g.k : ℂ) = 0 := by simpa only [logDeckTransform_fst, add_eq_left] using he
+      exact_mod_cast he'
+    let p : FullPeriodMatrix := ⟨logarithmicPeriod C x.1, hP⟩
+    have he : p.periodLinear ((fun i => (g.m i : ℝ)), fun i => (g.n i : ℝ)) = p.periodLinear 0 := by
+      have hs : (fun i => (g.m i : ℂ)) + logarithmicPeriod C x.1 *ᵥ (fun i => (g.n i : ℂ)) = 0 := by
+        have hs := congrArg Prod.snd hx
+        simpa only [logDeckTransform_snd, add_assoc, add_eq_left] using hs
+      rw [map_zero]
+      ext i
+      simpa [FullPeriodMatrix.periodLinear, p] using congrFun hs i
+    have he' := p.periodLinear_bijective.injective he
+    apply LogDeck.ext hk
+    · ext i
+      have hm := congrFun (congrArg Prod.fst he') i
+      change (g.m i : ℝ) = 0 at hm
+      change g.m i = 0
+      exact_mod_cast hm
+    · ext i
+      have hn := congrFun (congrArg Prod.snd he') i
+      change (g.n i : ℝ) = 0 at hn
+      change g.n i = 0
+      exact_mod_cast hn
+  · rintro rfl
+    exact logDeckTransform_one C x
+
+private theorem CuspUniformization.logDeckTransform_mem_logDomain (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (g : LogDeck) (x : ℂ × ComplexPlane₂) :
+    logDeckTransform C g x ∈ logDomain ε ↔ x ∈ logDomain ε := by simp
+
+private def
+    CuspUniformization.logCoverTransform (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (g : LogDeck)
+    (x : LogCover ε) : LogCover ε :=
+  ⟨logDeckTransform C g x, (logDeckTransform_mem_logDomain C ε g x).mpr x.2⟩
+
+@[simp]
+private theorem CuspUniformization.logCoverTransform_coe (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (g : LogDeck) (x : LogCover ε) :
+    (logCoverTransform C ε g x : ℂ × ComplexPlane₂) = logDeckTransform C g x :=
+  rfl
+
+@[instance_reducible]
+private def CuspUniformization.logCoverAction (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    MulAction LogDeck (LogCover ε)
+    where
+  smul := logCoverTransform C ε
+  one_smul x := Subtype.ext (logDeckTransform_one C x)
+  mul_smul g h x := Subtype.ext (logDeckTransform_mul C g h x)
+
+private theorem CuspUniformization.logarithmicPeriod_logDomain_holomorphic
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε)) (i j : Fin 2) :
+    ContDiffOn ℂ ω (fun x : ℂ × ComplexPlane₂ => logarithmicPeriod C x.1 i j) (logDomain ε) := by
+  have he : ContDiff ℂ ω (fun x : ℂ × ComplexPlane₂ => exponential x.1) :=
+    exponential_holomorphic.comp contDiff_fst
+  change
+    ContDiffOn ℂ ω
+      (fun x : ℂ × ComplexPlane₂ =>
+        x.1 * (B₀.map (Int.castRingHom ℂ)) i j + C (exponential x.1) i j)
+      _
+  exact
+    (contDiff_fst.mul contDiff_const).contDiffOn.add
+      ((hC i j).comp he.contDiffOn (fun x hx => hx))
+
+private theorem CuspUniformization.logarithmicPeriod_logDomain_mulVec_holomorphic
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε)) (n : Fin 2 → ℤ) :
+    ContDiffOn ℂ ω (fun x : ℂ × ComplexPlane₂ => logarithmicPeriod C x.1 *ᵥ (fun i => (n i : ℂ)))
+      (logDomain ε) := by
+  apply contDiffOn_pi.mpr
+  intro i
+  simp only [Matrix.mulVec, dotProduct, Fin.sum_univ_two]
+  exact
+    ((logarithmicPeriod_logDomain_holomorphic C ε hC i 0).mul contDiffOn_const).add
+      ((logarithmicPeriod_logDomain_holomorphic C ε hC i 1).mul contDiffOn_const)
+
+private theorem
+    CuspUniformization.logDeckTransform_holomorphic (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε)) (g : LogDeck) :
+    ContDiffOn ℂ ω (logDeckTransform C g) (logDomain ε) := by
+  have hv :
+    ContDiffOn ℂ ω
+      (fun x : ℂ × ComplexPlane₂ => logarithmicPeriod C x.1 *ᵥ (fun i => (g.n i : ℂ)))
+      (logDomain ε) :=
+    logarithmicPeriod_logDomain_mulVec_holomorphic C ε hC g.n
+  exact
+    (contDiff_fst.add contDiff_const).contDiffOn.prodMk
+      ((contDiff_snd.add contDiff_const).contDiffOn.add hv)
+
+private theorem
+    CuspUniformization.logCover_action_holomorphic (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε)) (g : LogDeck) :
+    letI := logCoverAction C ε
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (fun x : LogCover ε => g • x) := by
+  let := logCoverAction C ε
+  intro x
+  have he :
+    ContMDiffAt (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+        (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω
+        (fun y : LogCover ε => ((g • y : LogCover ε) : ℂ × ComplexPlane₂)) x ↔
+      ContMDiffAt (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+        (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (fun y : LogCover ε => g • y) x :=
+    ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+  apply he.mp
+  have h := (logDeckTransform_holomorphic C ε hC g).contMDiffOn
+  exact
+    (h.contMDiffAt ((logDomain ε).isOpen.mem_nhds x.2)).comp x contMDiff_subtype_val.contMDiffAt
+
+private theorem
+    CuspUniformization.logCover_continuousConstSMul (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun t => C t i j) (Metric.ball 0 ε)) :
+    letI := logCoverAction C ε
+    ContinuousConstSMul LogDeck (LogCover ε) := by
+  let := logCoverAction C ε
+  exact ⟨fun g => (logCover_action_holomorphic C ε hC g).continuous⟩
+
+private theorem CuspUniformization.logCover_free_action (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε1 : ε < 1) (hR : ToricSpace.SmallDrift C ε) :
+    letI := logCoverAction C ε
+    IsCancelSMul LogDeck (LogCover ε) := by
+  let := logCoverAction C ε
+  apply isCancelSMul_iff_eq_one_of_smul_eq.mpr
+  intro g x hx
+  have hs : ‖exponential x.1.1‖ < ε := (mem_logDomain ε x).mp x.2
+  have hp : 0 < ‖exponential x.1.1‖ := norm_pos_iff.mpr (exponential_ne_zero _)
+  apply
+    (logDeckTransform_eq_self_iff C g x
+        (logarithmicPeriod_nondegenerate C x.1.1 (Real.log_neg hp (hs.trans hε1))
+          (hR _ hp hs))).mp
+  exact congrArg Subtype.val hx
+
+private theorem CuspUniformization.totalPeriodRelated_iff_exists_logDeck
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (p q : ℂ × ComplexPlane₂) :
+    TotalPeriodRelated C p q ↔ ∃ g : LogDeck, logDeckTransform C g q = p := by
+  constructor
+  · rintro ⟨k, m, n, hs, hz⟩
+    exact ⟨⟨k, m, n⟩, Prod.ext hs.symm hz.symm⟩
+  · rintro ⟨g, hg⟩
+    exact ⟨g.k, g.m, g.n, (congrArg Prod.fst hg).symm, (congrArg Prod.snd hg).symm⟩
+
+private theorem
+    CuspUniformization.puncturedCuspCover_eq_iff_orbit (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (p q : LogCover ε) :
+    letI := logCoverAction C ε
+    puncturedCuspCover C ε p = puncturedCuspCover C ε q ↔ p ∈ MulAction.orbit LogDeck q := by
+  let := logCoverAction C ε
+  rw [puncturedCuspCover_eq_iff, totalPeriodRelated_iff_exists_logDeck]
+  constructor
+  · rintro ⟨g, hg⟩
+    exact ⟨g, Subtype.ext hg⟩
+  · rintro ⟨g, hg⟩
+    exact ⟨g, congrArg Subtype.val hg⟩
+
+private theorem
+    CuspUniformization.mem_logDomain_iff_im (ε : ℝ) (hε : 0 < ε) (p : ℂ × ComplexPlane₂) :
+    p ∈ logDomain ε ↔ -Real.log ε / (2 * Real.pi) < p.1.im := by
+  rw [mem_logDomain, ← Real.log_lt_log_iff (norm_pos_iff.mpr (exponential_ne_zero p.1)) hε,
+    log_norm_exponential, div_lt_iff₀ (mul_pos (by norm_num) Real.pi_pos)]
+  constructor <;> intro h <;> nlinarith
+
+private theorem CuspUniformization.logDomain_nonempty (ε : ℝ) (hε : 0 < ε) :
+    (logDomain ε : Set (ℂ × ComplexPlane₂)).Nonempty := by
+  refine ⟨(((↑(-Real.log ε / (2 * Real.pi) + 1) : ℂ) * Complex.I), 0), ?_⟩
+  apply (mem_logDomain_iff_im ε hε _).mpr
+  simp only [Complex.mul_im, Complex.ofReal_re, Complex.ofReal_im, Complex.I_re, Complex.I_im,
+    mul_one, MulZeroClass.mul_zero, add_zero]
+  linarith
+
+private abbrev CuspUniformization.LogModel :=
+  ℂ × ComplexPlane₂
+
+private def CuspUniformization.logCoordinateLinear : LogModel ≃ₗ[ℂ] ToricCharts.CoordinateSpace 3
+    where
+  toFun p := ![p.2 0, p.2 1, p.1]
+  invFun w := (w 2, ![w 0, w 1])
+  left_inv
+    p := by
+    apply Prod.ext
+    · rfl
+    · ext i
+      fin_cases i <;> rfl
+  right_inv
+    w := by
+    ext i
+    fin_cases i <;> rfl
+  map_add' p
+    q := by
+    ext i
+    fin_cases i <;> rfl
+  map_smul' c
+    p := by
+    ext i
+    fin_cases i <;> rfl
+
+private def CuspUniformization.logCoordinateEquiv : LogModel ≃L[ℂ] ToricCharts.CoordinateSpace 3 :=
+  logCoordinateLinear.toContinuousLinearEquiv
+
+private def CuspUniformization.totalExponentialCoordinates (p : LogModel) :
+    ToricCharts.CoordinateSpace 3 :=
+  ![exponential (p.2 0), exponential (p.2 1), exponential p.1]
+
+private theorem CuspUniformization.totalExponentialCoordinates_mem_torus (p : LogModel) :
+    totalExponentialCoordinates p ∈ ToricCharts.torus := by
+  intro i
+  fin_cases i <;> exact exponential_ne_zero _
+
+private theorem CuspUniformization.totalExponentialCoordinates_holomorphic :
+    ContDiff ℂ ω totalExponentialCoordinates := by
+  apply contDiff_pi.mpr
+  intro i
+  fin_cases i
+  · exact exponential_holomorphic.comp ((contDiff_apply ℂ ℂ 0).comp contDiff_snd)
+  · exact exponential_holomorphic.comp ((contDiff_apply ℂ ℂ 1).comp contDiff_snd)
+  · exact exponential_holomorphic.comp contDiff_fst
+
+private def CuspUniformization.totalExponentialDerivative (p : LogModel) :
+    LogModel ≃L[ℂ] ToricCharts.CoordinateSpace 3 :=
+  ((ContinuousLinearEquiv.unitsEquivAut ℂ
+            (Units.mk0 (exponential p.1 * (2 * Real.pi * Complex.I))
+              (mul_ne_zero (exponential_ne_zero _) exponential_factor_ne_zero))).prodCongr
+        (exponentialPairDerivative p.2)).trans
+    logCoordinateEquiv
+
+private theorem CuspUniformization.totalExponentialCoordinates_hasFDerivAt (p : LogModel) :
+    HasFDerivAt totalExponentialCoordinates
+      (totalExponentialDerivative p : LogModel →L[ℂ] ToricCharts.CoordinateSpace 3) p := by
+  convert!
+    logCoordinateEquiv.hasFDerivAt.comp p
+      (((exponential_hasDerivAt p.1).hasFDerivAt_equiv
+            (mul_ne_zero (exponential_ne_zero _) exponential_factor_ne_zero)).prodMap
+        p (exponentialPair_hasFDerivAt p.2)) using
+    1
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Uniformization/CuspUniformization2.lean b/LeanPool/HopfProblem/Uniformization/CuspUniformization2.lean
new file mode 100644
index 000000000..2639e8d22
--- /dev/null
+++ b/LeanPool/HopfProblem/Uniformization/CuspUniformization2.lean
@@ -0,0 +1,652 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Foundations.Core4
+public import LeanPool.HopfProblem.PeriodFamily.PeriodDomain
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.Lattice.Core2
+import all LeanPool.HopfProblem.Toric.CuspHoneycombHexagon
+import all LeanPool.HopfProblem.Foundations.Core4
+import all LeanPool.HopfProblem.PeriodFamily.PeriodDomain
+
+/-!
+# Hopf problem: uniformization · cusp uniformization 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def CuspUniformization.totalExponentialChart (p : LogModel) :
+    OpenPartialHomeomorph LogModel (ToricCharts.CoordinateSpace 3) :=
+  totalExponentialCoordinates_holomorphic.contDiffAt.toOpenPartialHomeomorph
+    totalExponentialCoordinates (totalExponentialCoordinates_hasFDerivAt p) (by simp)
+
+private theorem CuspUniformization.totalExponentialChart_mem_source (p : LogModel) :
+    p ∈ (totalExponentialChart p).source :=
+  totalExponentialCoordinates_holomorphic.contDiffAt.mem_toOpenPartialHomeomorph_source
+    (totalExponentialCoordinates_hasFDerivAt p) (by simp)
+
+private theorem CuspUniformization.totalExponentialChart_holomorphic (p : LogModel) :
+    ContDiffOn ℂ ω (totalExponentialChart p) (totalExponentialChart p).source :=
+  totalExponentialCoordinates_holomorphic.contDiffOn
+
+private theorem CuspUniformization.totalExponentialChart_symm_holomorphic (p : LogModel) :
+    ContDiffOn ℂ ω (totalExponentialChart p).symm (totalExponentialChart p).target := by
+  intro w hw
+  exact
+    ((totalExponentialChart p).contDiffAt_symm hw
+        (totalExponentialCoordinates_hasFDerivAt ((totalExponentialChart p).symm w))
+        totalExponentialCoordinates_holomorphic.contDiffAt).contDiffWithinAt
+
+private theorem CuspUniformization.totalExponentialCoordinates_isLocalDiffeomorph :
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ LogModel)
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω totalExponentialCoordinates := by
+  intro p
+  refine
+    ⟨{  toPartialEquiv := (totalExponentialChart p).toPartialEquiv
+        open_source := (totalExponentialChart p).open_source
+        open_target := (totalExponentialChart p).open_target
+        contMDiffOn_toFun := (totalExponentialChart_holomorphic p).contMDiffOn
+        contMDiffOn_invFun := (totalExponentialChart_symm_holomorphic p).contMDiffOn },
+      totalExponentialChart_mem_source p, ?_⟩
+  intro q _
+  rfl
+
+private theorem
+    CuspUniformization.torusPoint_isLocalDiffeomorphAt {z : ToricCharts.CoordinateSpace 3}
+    (hz : z ∈ ToricCharts.torus) :
+    IsLocalDiffeomorphAt (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω torusPoint z := by
+  refine
+    ⟨{  toPartialEquiv := torusChart.symm.toPartialEquiv
+        open_source := torusChart.open_target
+        open_target := torusChart.open_source
+        contMDiffOn_toFun := torusPoint_holomorphic
+        contMDiffOn_invFun := ToricSpace.torusCoordinates_holomorphic }, hz, ?_⟩
+  intro w _
+  rfl
+
+private theorem CuspUniformization.totalExponentialPoint_isLocalDiffeomorph :
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ LogModel)
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω totalExponentialPoint := by
+  intro p
+  change
+    IsLocalDiffeomorphAt (modelWithCornersSelf ℂ LogModel)
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω
+      (torusPoint ∘ totalExponentialCoordinates) p
+  exact
+    (totalExponentialCoordinates_isLocalDiffeomorph p).comp (K :=
+      modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) (P := ToricSpace.Space)
+      (torusPoint_isLocalDiffeomorphAt (totalExponentialCoordinates_mem_torus p))
+
+private theorem CuspUniformization.totalExponentialLift_isLocalDiffeomorph (ε : ℝ) :
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ LogModel)
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (totalExponentialLift ε) := by
+  exact
+    isLocalDiffeomorph_restrictOpens (modelWithCornersSelf ℂ LogModel)
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      totalExponentialPoint_isLocalDiffeomorph (logDomain ε)
+      (ToricSpace.tubeOpen (CuspQuotient.disc ε))
+      (fun p hp => (totalExponentialLift ε ⟨p, hp⟩).prop)
+
+private theorem CuspUniformization.puncturedExponential_isLocalDiffeomorph (ε : ℝ) :
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ LogModel)
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (puncturedExponential ε) := by
+  exact
+    isLocalDiffeomorph_codRestrictOpens (modelWithCornersSelf ℂ LogModel)
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (totalExponentialLift_isLocalDiffeomorph ε) (puncturedTubeOpen ε)
+      (fun p => (puncturedExponential ε p).prop)
+
+private theorem CuspUniformization.quotientMap_isLocalDiffeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    letI := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (CuspQuotient.quotientMap C ε) :=
+  by
+  let := ToricSpace.tubeAction C (CuspQuotient.disc ε)
+  let := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+  exact
+    CoveringQuotient.project_isLocalDiffeomorph
+      (CuspQuotient.quotientMap_covering C ε hε hε1 hC hR)
+      (fun g => ToricSpace.tubeTranslate_holomorphic C (CuspQuotient.disc ε) g.toAdd hC)
+
+private theorem CuspUniformization.puncturedQuotientMap_isLocalDiffeomorph
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    letI := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (puncturedQuotientMap C ε) := by
+  let := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+  exact
+    isLocalDiffeomorph_restrictOpens (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (quotientMap_isLocalDiffeomorph C ε hε hε1 hC hR) (puncturedTubeOpen ε)
+      (puncturedQuotientOpen C ε) (fun _ hx => hx)
+
+private theorem CuspUniformization.puncturedCuspCover_isLocalDiffeomorph
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    letI := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (puncturedCuspCover C ε) := by
+  let := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+  intro p
+  change
+    IsLocalDiffeomorphAt (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω
+      (puncturedQuotientMap C ε ∘ puncturedExponential ε) p
+  exact
+    (puncturedExponential_isLocalDiffeomorph ε p).comp (K :=
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))) (P := PuncturedQuotient C ε)
+      (puncturedQuotientMap_isLocalDiffeomorph C ε hε hε1 hC hR (puncturedExponential ε p))
+
+private theorem CuspUniformization.puncturedCuspCover_holomorphic (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    letI := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (puncturedCuspCover C ε) := by
+  let := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+  exact (puncturedCuspCover_isLocalDiffeomorph C ε hε hε1 hC hR).contMDiff
+
+private theorem
+    CuspUniformization.puncturedCuspCover_isLocalHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : IsLocalHomeomorph (puncturedCuspCover C ε) := by
+  let := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+  exact (puncturedCuspCover_isLocalDiffeomorph C ε hε hε1 hC hR).isLocalHomeomorph
+
+private theorem
+    CuspUniformization.puncturedCuspCover_isOpenMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : IsOpenMap (puncturedCuspCover C ε) :=
+  (puncturedCuspCover_isLocalHomeomorph C ε hε hε1 hC hR).isOpenMap
+
+/-- The setoid of total-period equivalence on the logarithmic cover. -/
+public
+def CuspUniformization.totalPeriodRelation (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    Setoid (LogCover ε) where
+  r p q := TotalPeriodRelated C p q
+  iseqv :=
+    { refl p := (puncturedCuspCover_eq_iff C ε p p).mp rfl
+      symm
+        h :=
+        (puncturedCuspCover_eq_iff C ε _ _).mp ((puncturedCuspCover_eq_iff C ε _ _).mpr h).symm
+      trans h
+        h' :=
+        (puncturedCuspCover_eq_iff C ε _ _).mp
+          (((puncturedCuspCover_eq_iff C ε _ _).mpr h).trans
+            ((puncturedCuspCover_eq_iff C ε _ _).mpr h')) }
+
+/-- The quotient of the logarithmic cover by total-period equivalence. -/
+public
+abbrev CuspUniformization.TotalPeriodQuotient (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :=
+  Quotient (totalPeriodRelation C ε)
+
+/-- The canonical map to the total-period quotient. -/
+public
+def CuspUniformization.totalPeriodQuotientMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    LogCover ε → TotalPeriodQuotient C ε :=
+  Quotient.mk (totalPeriodRelation C ε)
+
+private theorem
+    CuspUniformization.totalPeriodQuotientMap_surjective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) : Function.Surjective (totalPeriodQuotientMap C ε) :=
+  Quotient.mk_surjective
+
+private theorem
+    CuspUniformization.totalPeriodQuotientMap_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) : Continuous (totalPeriodQuotientMap C ε) :=
+  continuous_quotient_mk'
+
+@[simp]
+public
+theorem CuspUniformization.totalPeriodQuotientMap_eq_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (p q : LogCover ε) :
+    totalPeriodQuotientMap C ε p = totalPeriodQuotientMap C ε q ↔ TotalPeriodRelated C p q :=
+  Quotient.eq''
+
+private def CuspUniformization.totalUniformizationMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    TotalPeriodQuotient C ε → PuncturedQuotient C ε :=
+  Quotient.lift (puncturedCuspCover C ε) fun p q h => (puncturedCuspCover_eq_iff C ε p q).mpr h
+
+private theorem
+    CuspUniformization.totalUniformizationMap_bijective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) : Function.Bijective (totalUniformizationMap C ε) := by
+  constructor
+  · intro p q
+    induction p using Quotient.inductionOn with
+    | h p =>
+      induction q using Quotient.inductionOn with
+      | h q =>
+        intro h
+        exact Quotient.sound ((puncturedCuspCover_eq_iff C ε p q).mp h)
+  · intro q
+    obtain ⟨p, hp⟩ := puncturedCuspCover_surjective C ε q
+    exact ⟨totalPeriodQuotientMap C ε p, hp⟩
+
+private def CuspUniformization.totalUniformizationEquiv (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) :
+    TotalPeriodQuotient C ε ≃ PuncturedQuotient C ε :=
+  Equiv.ofBijective (totalUniformizationMap C ε) (totalUniformizationMap_bijective C ε)
+
+@[simp]
+private theorem
+    CuspUniformization.totalUniformizationEquiv_quotientMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (p : LogCover ε) :
+    totalUniformizationEquiv C ε (totalPeriodQuotientMap C ε p) = puncturedCuspCover C ε p :=
+  rfl
+
+@[simp]
+private theorem
+    CuspUniformization.totalUniformizationEquiv_symm_cover (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (p : LogCover ε) :
+    (totalUniformizationEquiv C ε).symm (puncturedCuspCover C ε p) =
+      totalPeriodQuotientMap C ε p := by
+  simpa only [totalUniformizationEquiv_quotientMap] using
+    (totalUniformizationEquiv C ε).symm_apply_apply (totalPeriodQuotientMap C ε p)
+
+private theorem
+    CuspUniformization.totalUniformizationMap_continuous (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) : Continuous (totalUniformizationMap C ε) := by
+  apply Continuous.quotient_lift
+  exact
+    ((CuspQuotient.quotientMap_continuous C ε).comp
+          (totalExponentialLift_holomorphic ε).continuous).subtype_mk
+      _
+
+private theorem
+    CuspUniformization.totalUniformizationMap_isOpenMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : IsOpenMap (totalUniformizationMap C ε) := by
+  apply
+    IsOpenMap.of_comp (totalPeriodQuotientMap_continuous C ε)
+      (totalPeriodQuotientMap_surjective C ε)
+  exact puncturedCuspCover_isOpenMap C ε hε hε1 hC hR
+
+private def
+    CuspUniformization.totalUniformizationHomeomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) : TotalPeriodQuotient C ε ≃ₜ PuncturedQuotient C ε :=
+  (totalUniformizationEquiv C ε).toHomeomorphOfContinuousOpen
+    (totalUniformizationMap_continuous C ε) (totalUniformizationMap_isOpenMap C ε hε hε1 hC hR)
+
+@[simp]
+private theorem CuspUniformization.totalUniformizationHomeomorph_symm_cover
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (p : LogCover ε) :
+    (totalUniformizationHomeomorph C ε hε hε1 hC hR).symm (puncturedCuspCover C ε p) =
+      totalPeriodQuotientMap C ε p :=
+  totalUniformizationEquiv_symm_cover C ε p
+
+private theorem
+    CuspUniformization.puncturedCuspCover_covering (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    letI := logCoverAction C ε
+    IsQuotientCoveringMap (puncturedCuspCover C ε) LogDeck := by
+  let := logCoverAction C ε
+  let := logCover_continuousConstSMul C ε hC
+  let := logCover_free_action C ε hε1 hR
+  exact
+    quotientCoveringMap_of_localHomeomorph (puncturedCuspCover_isLocalHomeomorph C ε hε hε1 hC hR)
+      (puncturedCuspCover_surjective C ε) (puncturedCuspCover_eq_iff_orbit C ε)
+
+private theorem
+    CuspUniformization.totalPeriodQuotientMap_covering (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    letI := logCoverAction C ε
+    IsQuotientCoveringMap (totalPeriodQuotientMap C ε) LogDeck := by
+  let := logCoverAction C ε
+  have h :=
+    (puncturedCuspCover_covering C ε hε hε1 hC hR).homeomorph_comp
+      (totalUniformizationHomeomorph C ε hε hε1 hC hR).symm
+  have he :
+    (totalUniformizationHomeomorph C ε hε hε1 hC hR).symm ∘ puncturedCuspCover C ε =
+      totalPeriodQuotientMap C ε := by
+    funext p
+    exact totalUniformizationHomeomorph_symm_cover C ε hε hε1 hC hR p
+  rwa [he] at h
+
+@[instance_reducible]
+private def
+    CuspUniformization.totalPeriodQuotientChartedSpace (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    ChartedSpace (ℂ × ComplexPlane₂) (TotalPeriodQuotient C ε) :=
+  letI := logCoverAction C ε
+  CoveringQuotient.chartedSpace (E := ℂ × ComplexPlane₂)
+    (totalPeriodQuotientMap_covering C ε hε hε1 hC hR)
+
+private theorem
+    CuspUniformization.totalPeriodQuotientMap_holomorphic (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    letI := totalPeriodQuotientChartedSpace C ε hε hε1 hC hR
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (totalPeriodQuotientMap C ε) := by
+  let := logCoverAction C ε
+  exact
+    CoveringQuotient.contMDiff_project (totalPeriodQuotientMap_covering C ε hε hε1 hC hR) ω
+      (logCover_action_holomorphic C ε hC)
+
+private theorem
+    CuspUniformization.totalUniformizationMap_holomorphic (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    letI := totalPeriodQuotientChartedSpace C ε hε hε1 hC hR
+    letI := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+    ContMDiff (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω (totalUniformizationMap C ε) := by
+  let := logCoverAction C ε
+  let := totalPeriodQuotientChartedSpace C ε hε hε1 hC hR
+  let := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+  apply
+    CoveringQuotient.contMDiff_of_comp (totalPeriodQuotientMap_covering C ε hε hε1 hC hR)
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) ω
+  exact puncturedCuspCover_holomorphic C ε hε hε1 hC hR
+
+private theorem CuspUniformization.totalUniformizationEquiv_symm_holomorphic
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    letI := totalPeriodQuotientChartedSpace C ε hε hε1 hC hR
+    letI := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+    ContMDiff (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂)) ω (totalUniformizationEquiv C ε).symm := by
+  let := totalPeriodQuotientChartedSpace C ε hε hε1 hC hR
+  let := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+  apply
+    contMDiff_of_comp_localDiffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3))
+      (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (puncturedCuspCover_isLocalDiffeomorph C ε hε hε1 hC hR) (puncturedCuspCover_surjective C ε)
+  have he :
+    (totalUniformizationEquiv C ε).symm ∘ puncturedCuspCover C ε = totalPeriodQuotientMap C ε := by
+    funext p
+    exact totalUniformizationEquiv_symm_cover C ε p
+  rw [he]
+  exact totalPeriodQuotientMap_holomorphic C ε hε hε1 hC hR
+
+private def
+    CuspUniformization.totalUniformizationBiholomorph (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    letI := totalPeriodQuotientChartedSpace C ε hε hε1 hC hR
+    letI := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+    Diffeomorph (modelWithCornersSelf ℂ (ℂ × ComplexPlane₂))
+      (modelWithCornersSelf ℂ (ToricCharts.CoordinateSpace 3)) (TotalPeriodQuotient C ε)
+      (PuncturedQuotient C ε) ω := by
+  let := totalPeriodQuotientChartedSpace C ε hε hε1 hC hR
+  let := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+  exact
+    { toEquiv := totalUniformizationEquiv C ε
+      contMDiff_toFun := totalUniformizationMap_holomorphic C ε hε hε1 hC hR
+      contMDiff_invFun := totalUniformizationEquiv_symm_holomorphic C ε hε hε1 hC hR }
+
+@[simp]
+private theorem CuspUniformization.totalUniformizationBiholomorph_quotientMap
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (hε : 0 < ε) (hε1 : ε < 1)
+    (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (p : LogCover ε) :
+    letI := totalPeriodQuotientChartedSpace C ε hε hε1 hC hR
+    letI := CuspQuotient.chartedSpace C ε hε hε1 hC hR
+    totalUniformizationBiholomorph C ε hε hε1 hC hR (totalPeriodQuotientMap C ε p) =
+      puncturedCuspCover C ε p :=
+  rfl
+
+private def CuspUniformization.sourcePeriodCoordinates : Lattice ≃+ FullPeriodMatrix.IntegerPeriods
+    where
+  toFun v := (![v 2, v 3], ![v 0, v 1])
+  invFun c := ![c.2 0, c.2 1, c.1 0, c.1 1]
+  left_inv v := by ext i; fin_cases i <;> rfl
+  right_inv c := by apply Prod.ext <;> ext i <;> fin_cases i <;> rfl
+  map_add' v w := by apply Prod.ext <;> ext i <;> fin_cases i <;> rfl
+
+private def CuspUniformization.cuspLatticeProjection : Lattice →+ (Fin 2 → ℤ)
+    where
+  toFun v := ![v 0, v 1]
+  map_zero' := by ext i; fin_cases i <;> rfl
+  map_add' v w := by ext i; fin_cases i <;> rfl
+
+private theorem CuspUniformization.cuspLatticeProjection_eq_zero_iff (v : Lattice) :
+    cuspLatticeProjection v = 0 ↔ (M₀ - 1) *ᵥ v = 0 := by
+  rw [M₀_sub_one_kernel]
+  constructor
+  · intro h
+    exact ⟨congrFun h 0, congrFun h 1⟩
+  · rintro ⟨h₀, h₁⟩
+    ext i
+    fin_cases i <;> assumption
+
+private theorem
+    CuspUniformization.exponentialLift_period_translate (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (s : ℂ) (hs : ‖exponential s‖ < ε) (z : ComplexPlane₂) (m n : Fin 2 → ℤ) :
+    exponentialLift ε s hs
+        (z + (fun i => (m i : ℂ)) + logarithmicPeriod C s *ᵥ (fun j => (n j : ℂ))) =
+      ToricSpace.tubeTranslate C (CuspQuotient.disc ε) n (exponentialLift ε s hs z) := by
+  apply Subtype.ext
+  change
+    exponentialPoint (exponential s)
+        (z + (fun i => (m i : ℂ)) + logarithmicPeriod C s *ᵥ (fun j => (n j : ℂ))) =
+      ToricSpace.twistedTranslate C n (exponentialPoint (exponential s) z)
+  rw [twistedTranslate_exponentialPoint]
+  apply (exponentialPoint_eq_iff (exponential_ne_zero s) _ _).mpr
+  exact ⟨m, by abel⟩
+
+private def
+    CuspUniformization.fibreFundamentalGroupMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (s : ℂ)
+    (hs : ‖exponential s‖ < ε) (hlog : Real.log ‖exponential s‖ < 0)
+    (hRp :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4) :
+    FundamentalGroup (periodData C s hlog hRp).Torus 0 →*
+      FundamentalGroup (CuspQuotient.QuotientSpace C ε)
+        (CuspQuotient.quotientMap C ε (exponentialLift ε s hs 0)) :=
+  FundamentalGroup.map ⟨fibreMap C ε s hs hlog hRp, fibreMap_continuous C ε s hs hlog hRp⟩ 0
+
+private theorem
+    CuspUniformization.fibreFundamentalGroupMap_marking (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (s : ℂ) (hs : ‖exponential s‖ < ε) (hlog : Real.log ‖exponential s‖ < 0)
+    (hRp :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (γ : FundamentalGroup (periodData C s hlog hRp).Torus 0) :
+    CuspQuotient.fundamentalGroupEquivAt C ε hε hε1 hC hR (exponentialLift ε s hs 0)
+        (fibreFundamentalGroupMap C ε s hs hlog hRp γ) =
+      Multiplicative.ofAdd (((periodData C s hlog hRp).fundamentalGroupEquiv γ).toAdd.2) := by
+  let := ToricSpace.tubeAction C (CuspQuotient.disc ε)
+  let p := periodData C s hlog hRp
+  let hq := CuspQuotient.quotientMap_covering C ε hε hε1 hC hR
+  let c := (p.fundamentalGroupEquiv γ).toAdd
+  have hnat :=
+    covering_monodromy_naturality p.quotientCovering.isCoveringMap hq.isCoveringMap
+      ⟨exponentialLift ε s hs, exponentialLift_continuous ε s hs⟩
+      ⟨fibreMap C ε s hs hlog hRp, fibreMap_continuous C ε s hs hlog hRp⟩ (fun _ => rfl)
+      (0 : ComplexPlane₂) γ
+  have hper := p.fundamentalGroupEquiv_monodromy γ
+  have htrans := exponentialLift_period_translate C ε s hs 0 c.1 c.2
+  have he :
+    ToricSpace.tubeTranslate C (CuspQuotient.disc ε)
+        (CuspQuotient.fundamentalGroupEquivAt C ε hε hε1 hC hR (exponentialLift ε s hs 0)
+            (fibreFundamentalGroupMap C ε s hs hlog hRp γ)).toAdd
+        (exponentialLift ε s hs 0) =
+      ToricSpace.tubeTranslate C (CuspQuotient.disc ε) c.2 (exponentialLift ε s hs 0) := by
+    rw [CuspQuotient.fundamentalGroupEquivAt_monodromy]
+    change
+      (hq.isCoveringMap.monodromy
+            (Path.Homotopic.Quotient.map γ
+              ⟨fibreMap C ε s hs hlog hRp, fibreMap_continuous C ε s hs hlog hRp⟩)
+            ⟨exponentialLift ε s hs 0, rfl⟩ :
+          ToricSpace.Tube (CuspQuotient.disc ε)) =
+        _
+    apply hnat.trans
+    apply (congrArg (exponentialLift ε s hs) hper.symm).trans
+    change
+      exponentialLift ε s hs
+          ((fun i => (c.1 i : ℂ)) + logarithmicPeriod C s *ᵥ (fun j => (c.2 j : ℂ))) =
+        _
+    simpa only [zero_add] using htrans
+  exact hq.isCancelSMul.right_cancel _ _ (exponentialLift ε s hs 0) he
+
+private theorem
+    CuspUniformization.fibrePeriodLoop_marking (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ)
+    (s : ℂ) (hs : ‖exponential s‖ < ε) (hlog : Real.log ‖exponential s‖ < 0)
+    (hRp :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (m n : Fin 2 → ℤ) :
+    CuspQuotient.fundamentalGroupEquivAt C ε hε hε1 hC hR (exponentialLift ε s hs 0)
+        (fibreFundamentalGroupMap C ε s hs hlog hRp
+          (FundamentalGroup.fromPath ⟦(periodData C s hlog hRp).periodLoop (m, n)⟧)) =
+      Multiplicative.ofAdd n := by
+  rw [fibreFundamentalGroupMap_marking, FullPeriodMatrix.fundamentalGroupEquiv_periodLoop]
+  rfl
+
+private theorem
+    CuspUniformization.fibreFundamentalGroupMap_eq_one_iff (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (s : ℂ) (hs : ‖exponential s‖ < ε) (hlog : Real.log ‖exponential s‖ < 0)
+    (hRp :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (γ : FundamentalGroup (periodData C s hlog hRp).Torus 0) :
+    fibreFundamentalGroupMap C ε s hs hlog hRp γ = 1 ↔
+      ((periodData C s hlog hRp).fundamentalGroupEquiv γ).toAdd.2 = 0 := by
+  rw [←
+    (CuspQuotient.fundamentalGroupEquivAt C ε hε hε1 hC hR
+        (exponentialLift ε s hs 0)).map_eq_one_iff,
+    fibreFundamentalGroupMap_marking]
+  rfl
+
+private theorem
+    CuspUniformization.fibreFundamentalGroupMap_surjective (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (s : ℂ) (hs : ‖exponential s‖ < ε) (hlog : Real.log ‖exponential s‖ < 0)
+    (hRp :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    Function.Surjective (fibreFundamentalGroupMap C ε s hs hlog hRp) := by
+  intro γ
+  let n :=
+    (CuspQuotient.fundamentalGroupEquivAt C ε hε hε1 hC hR (exponentialLift ε s hs 0) γ).toAdd
+  refine ⟨FundamentalGroup.fromPath ⟦(periodData C s hlog hRp).periodLoop (0, n)⟧, ?_⟩
+  apply
+    (CuspQuotient.fundamentalGroupEquivAt C ε hε hε1 hC hR (exponentialLift ε s hs 0)).injective
+  rw [fibrePeriodLoop_marking]
+  rfl
+
+private theorem CuspUniformization.fibre_integerPeriod_loop_nullhomotopic
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (s : ℂ) (hs : ‖exponential s‖ < ε)
+    (hlog : Real.log ‖exponential s‖ < 0)
+    (hRp :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (m : Fin 2 → ℤ) :
+    Path.Homotopic
+      (((periodData C s hlog hRp).periodLoop (m, 0)).map (fibreMap_continuous C ε s hs hlog hRp))
+      (Path.refl (CuspQuotient.quotientMap C ε (exponentialLift ε s hs 0))) := by
+  have he :=
+    (fibreFundamentalGroupMap_eq_one_iff C ε s hs hlog hRp hε hε1 hC hR
+          (FundamentalGroup.fromPath ⟦(periodData C s hlog hRp).periodLoop (m, 0)⟧)).mpr
+      (by rw [FullPeriodMatrix.fundamentalGroupEquiv_periodLoop]; rfl)
+  exact Path.Homotopic.Quotient.eq.mp he
+
+private def CuspUniformization.fibreBasePoint (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (s : ℂ)
+    (hs : ‖exponential s‖ < ε) (hlog : Real.log ‖exponential s‖ < 0)
+    (hRp :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4) :
+    CuspQuotient.projection C ε ⁻¹' {exponential s} :=
+  fibreMapToFibre C ε s hs hlog hRp 0
+
+private def CuspUniformization.fibreInclusionFundamentalGroupMap (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ)
+    (ε : ℝ) (s : ℂ) (hs : ‖exponential s‖ < ε) (hlog : Real.log ‖exponential s‖ < 0)
+    (hRp :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4) :
+    FundamentalGroup (CuspQuotient.projection C ε ⁻¹' {exponential s})
+        (fibreBasePoint C ε s hs hlog hRp) →*
+      FundamentalGroup (CuspQuotient.QuotientSpace C ε)
+        (CuspQuotient.quotientMap C ε (exponentialLift ε s hs 0)) :=
+  FundamentalGroup.map ⟨Subtype.val, continuous_subtype_val⟩ (fibreBasePoint C ε s hs hlog hRp)
+
+private theorem CuspUniformization.fibreInclusionFundamentalGroupMap_comp_homeomorph
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (s : ℂ) (hs : ‖exponential s‖ < ε)
+    (hlog : Real.log ‖exponential s‖ < 0)
+    (hRp :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) (γ : FundamentalGroup (periodData C s hlog hRp).Torus 0) :
+    fibreInclusionFundamentalGroupMap C ε s hs hlog hRp
+        (homeomorphFundamentalGroupEquiv (fibreHomeomorph C ε s hs hlog hRp hε hε1 hC hR) 0 γ) =
+      fibreFundamentalGroupMap C ε s hs hlog hRp γ := by
+  obtain ⟨γ⟩ := γ
+  apply congrArg Path.Homotopic.Quotient.mk
+  ext t
+  rfl
+
+private theorem CuspUniformization.fibreInclusionFundamentalGroupMap_surjective
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (ε : ℝ) (s : ℂ) (hs : ‖exponential s‖ < ε)
+    (hlog : Real.log ‖exponential s‖ < 0)
+    (hRp :
+      ToricSpace.entryNorm (ToricSpace.driftMatrix C (exponential s)) ≤
+        -Real.log ‖exponential s‖ / 4)
+    (hε : 0 < ε) (hε1 : ε < 1) (hC : ∀ i j, ContDiffOn ℂ ω (fun z => C z i j) (Metric.ball 0 ε))
+    (hR : ToricSpace.SmallDrift C ε) :
+    Function.Surjective (fibreInclusionFundamentalGroupMap C ε s hs hlog hRp) := by
+  intro γ
+  obtain ⟨δ, hδ⟩ := fibreFundamentalGroupMap_surjective C ε s hs hlog hRp hε hε1 hC hR γ
+  refine
+    ⟨homeomorphFundamentalGroupEquiv (fibreHomeomorph C ε s hs hlog hRp hε hε1 hC hR) 0 δ, ?_⟩
+  rw [fibreInclusionFundamentalGroupMap_comp_homeomorph]
+  exact hδ
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Uniformization/CuspUniformization3.lean b/LeanPool/HopfProblem/Uniformization/CuspUniformization3.lean
new file mode 100644
index 000000000..42db40c6c
--- /dev/null
+++ b/LeanPool/HopfProblem/Uniformization/CuspUniformization3.lean
@@ -0,0 +1,68 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+
+/-!
+# Hopf problem: uniformization · cusp uniformization 3
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+/-- A branch of the normalized logarithm centered at a nonzero point. -/
+public
+def CuspUniformization.localLog (z0 z : ℂ) : ℂ :=
+  logarithm z0 + logarithm (z / z0)
+
+private theorem CuspUniformization.localLog_contDiffAt_of_mem_slitPlane {z0 z : ℂ}
+    (hz : z / z0 ∈ Complex.slitPlane) : ContDiffAt ℂ ω (localLog z0) z := by
+  change
+    ContDiffAt ℂ ω (fun w : ℂ => logarithm z0 + Complex.log (w / z0) / (2 * Real.pi * Complex.I))
+      z
+  exact
+    contDiffAt_const.add
+      (((Complex.contDiffAt_log hz).comp z (contDiffAt_id.div_const z0)).div_const _)
+
+private theorem CuspUniformization.localLog_contDiffAt {z0 : ℂ} (hz0 : z0 ≠ 0) :
+    ContDiffAt ℂ ω (localLog z0) z0 :=
+  localLog_contDiffAt_of_mem_slitPlane (by simp [hz0])
+
+private theorem CuspUniformization.exponential_localLog {z0 z : ℂ} (hz0 : z0 ≠ 0) (hz : z ≠ 0) :
+    exponential (localLog z0 z) = z := by
+  rw [localLog, exponential_add, exponential_logarithm hz0,
+    exponential_logarithm (div_ne_zero hz hz0), mul_div_cancel₀ _ hz0]
+
+public
+theorem CuspUniformization.logarithm_eq_localLog_add_int {z0 z : ℂ} (hz0 : z0 ≠ 0) (hz : z ≠ 0) :
+    ∃ n : ℤ, logarithm z = localLog z0 z + n := by
+  apply (exponential_eq_iff (logarithm z) (localLog z0 z)).mp
+  rw [exponential_logarithm hz, exponential_localLog hz0 hz]
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Uniformization/CuspUniformization4.lean b/LeanPool/HopfProblem/Uniformization/CuspUniformization4.lean
new file mode 100644
index 000000000..3a4538aae
--- /dev/null
+++ b/LeanPool/HopfProblem/Uniformization/CuspUniformization4.lean
@@ -0,0 +1,128 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Threefold.SpecialPeriods9
+public import LeanPool.HopfProblem.Toric.DiagonalQuotient2
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Toric.ToricSpace1
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods9
+import all LeanPool.HopfProblem.Toric.DiagonalQuotient2
+
+/-!
+# Hopf problem: uniformization · cusp uniformization 4
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+@[simp]
+private theorem CuspUniformization.exponentialPoint_zero (t : ℂ) :
+    exponentialPoint t 0 =
+      ToricSpace.inclusion ToricSpace.referenceTriangle (CuspQuotient.sectionCoordinates t) := by
+  change
+    ToricSpace.inclusion ToricSpace.referenceTriangle
+        (ToricCharts.monomial ToricSpace.referenceTriangle.dual (exponentialCoordinates t 0)) =
+      _
+  apply congrArg (ToricSpace.inclusion ToricSpace.referenceTriangle)
+  ext i
+  fin_cases i <;>
+    simp [ToricCharts.monomial, ToricSpace.referenceTriangle, ToricFan.Triangle.dual,
+      exponentialCoordinates, CuspQuotient.sectionCoordinates, Fin.prod_univ_succ]
+
+private theorem
+    CuspUniformization.totalExponentialLift_eq_sectionLift_of_zero (r : ℝ) (x : LogCover r)
+    (hx : x.1.2 = 0) (t : CuspQuotient.disc r) (ht : (t : ℂ) = exponential x.1.1) :
+    totalExponentialLift r x = CuspQuotient.sectionLift r t := by
+  apply Subtype.ext
+  change
+    exponentialPoint (exponential x.1.1) x.1.2 =
+      ToricSpace.inclusion ToricSpace.referenceTriangle (CuspQuotient.sectionCoordinates t)
+  rw [hx, exponentialPoint_zero, ← ht]
+
+private theorem CuspUniformization.totalCuspCover_eq_zeroSection_of_zero
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (x : LogCover r) (hx : x.1.2 = 0)
+    (t : CuspQuotient.disc r) (ht : (t : ℂ) = exponential x.1.1) :
+    totalCuspCover C r x = CuspQuotient.zeroSection C r t :=
+  congrArg (CuspQuotient.quotientMap C r)
+    (totalExponentialLift_eq_sectionLift_of_zero r x hx t ht)
+
+private theorem CuspUniformization.puncturedCuspCover_eq_zeroSection_of_zero
+    (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ) (x : LogCover r) (hx : x.1.2 = 0)
+    (t : CuspQuotient.disc r) (ht : (t : ℂ) = exponential x.1.1) :
+    (puncturedCuspCover C r x : CuspQuotient.QuotientSpace C r) =
+      CuspQuotient.zeroSection C r t :=
+  totalCuspCover_eq_zeroSection_of_zero C r x hx t ht
+
+private theorem
+    CuspUniformization.puncturedCuspCover_zero (C : ℂ → Matrix (Fin 2) (Fin 2) ℂ) (r : ℝ)
+    (s : SpecialPeriods.CuspFamily.LogBase r) (t : CuspQuotient.disc r)
+    (ht : (t : ℂ) = exponential s) :
+    (puncturedCuspCover C r ⟨((s : ℂ), 0), s.property⟩ : CuspQuotient.QuotientSpace C r) =
+      CuspQuotient.zeroSection C r t :=
+  puncturedCuspCover_eq_zeroSection_of_zero C r _ rfl t ht
+
+/-- The triangle-group action by multiplicative automorphisms of the lattice. -/
+@[expose]
+public
+def SpecialPeriods.triangleLatticeMulAutHom : TriangleGroup →* MulAut (Multiplicative Lattice)
+    where
+  toFun
+    g :=
+    (Matrix.SpecialLinearGroup.toLin' (triangleDualRepresentation g)).toAddEquiv.toMultiplicative
+  map_one' := by
+    apply MulEquiv.ext
+    intro n
+    apply Multiplicative.toAdd.injective
+    change Matrix.SpecialLinearGroup.toLin' (triangleDualRepresentation 1) n.toAdd = n.toAdd
+    rw [map_one, map_one]
+    rfl
+  map_mul' g
+    h := by
+    apply MulEquiv.ext
+    intro n
+    apply Multiplicative.toAdd.injective
+    change
+      Matrix.SpecialLinearGroup.toLin' (triangleDualRepresentation (g * h)) n.toAdd =
+        Matrix.SpecialLinearGroup.toLin' (triangleDualRepresentation g)
+          (Matrix.SpecialLinearGroup.toLin' (triangleDualRepresentation h) n.toAdd)
+    rw [map_mul, map_mul]
+    rfl
+
+@[simp]
+public
+theorem SpecialPeriods.triangleLatticeMulAutHom_toAdd (g : TriangleGroup)
+    (n : Multiplicative Lattice) :
+    (triangleLatticeMulAutHom g n).toAdd =
+      (triangleDualRepresentation g : LatticeMatrix) *ᵥ n.toAdd :=
+  rfl
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Uniformization/HolomorphicCousin.lean b/LeanPool/HopfProblem/Uniformization/HolomorphicCousin.lean
new file mode 100644
index 000000000..7787bd90e
--- /dev/null
+++ b/LeanPool/HopfProblem/Uniformization/HolomorphicCousin.lean
@@ -0,0 +1,115 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+
+/-!
+# Hopf problem: uniformization · holomorphic cousin
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem
+    HolomorphicCousin.exists_smoothPartitionOfUnity_normalized_near_closed {ι E H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace H]
+    (I : ModelWithCorners ℝ E H) [TopologicalSpace M] [ChartedSpace H M] [IsManifold I ∞ M]
+    [T2Space M] [SigmaCompactSpace M] (U : ι → Set M) (hUo : ∀ i, IsOpen (U i))
+    (hUc : Set.univ ⊆ ⋃ i, U i) (i₀ : ι) {K : Set M} (hK : IsClosed K) (hKU : K ⊆ U i₀) :
+    ∃ V : Set M,
+      IsOpen V ∧
+        K ⊆ V ∧
+          closure V ⊆ U i₀ ∧
+            ∃ ρ : SmoothPartitionOfUnity ι I M Set.univ,
+              ρ.IsSubordinate U ∧
+                Set.EqOn (ρ i₀) (fun _ => 1) (closure V) ∧
+                  ∀ i, i ≠ i₀ → Disjoint (tsupport (ρ i)) (closure V) := by
+  classical
+  let : LocallyCompactSpace H := I.locallyCompactSpace
+  let : LocallyCompactSpace M := ChartedSpace.locallyCompactSpace H M
+  obtain ⟨V, hVo, hKV, hVU⟩ := normal_exists_closure_subset hK (hUo i₀) hKU
+  let W : ι → Set M := fun i => if i = i₀ then U i else U i \ closure V
+  have hWo (i : ι) : IsOpen (W i) := by
+    by_cases hi : i = i₀
+    · simpa only [W, ite_eq_left hi] using hUo i
+    · simpa only [W, ite_eq_right hi] using (hUo i).sdiff isClosed_closure
+  have hWc : Set.univ ⊆ ⋃ i, W i := by
+    intro x hx
+    by_cases hxV : x ∈ closure V
+    · apply Set.mem_iUnion_of_mem i₀
+      simpa only [W, ite_eq_left rfl] using hVU hxV
+    · obtain ⟨i, hxi⟩ := Set.mem_iUnion.mp (hUc hx)
+      apply Set.mem_iUnion_of_mem i
+      by_cases hi : i = i₀
+      · simpa only [W, ite_eq_left hi] using hxi
+      · simpa only [W, ite_eq_right hi, Set.mem_sdiff] using And.intro hxi hxV
+  obtain ⟨ρ, hρW⟩ := SmoothPartitionOfUnity.exists_isSubordinate I isClosed_univ W hWo hWc
+  have hρU : ρ.IsSubordinate U := by
+    intro i x hx
+    have hxi := hρW i hx
+    by_cases hi : i = i₀
+    · simpa only [W, ite_eq_left hi] using hxi
+    · exact (show x ∈ U i \ closure V by simpa only [W, ite_eq_right hi] using hxi).1
+  have hdisjoint (i : ι) (hi : i ≠ i₀) : Disjoint (tsupport (ρ i)) (closure V) := by
+    apply Set.disjoint_left.mpr
+    intro x hx hxV
+    have hxi : x ∈ U i \ closure V := by simpa only [W, ite_eq_right hi] using hρW i hx
+    exact hxi.2 hxV
+  have hzero (x : M) (hx : x ∈ closure V) (i : ι) (hi : i ≠ i₀) : ρ i x = 0 := by
+    apply image_eq_zero_of_notMem_tsupport
+    exact fun hs => Set.disjoint_left.mp (hdisjoint i hi) hs hx
+  refine ⟨V, hVo, hKV, hVU, ρ, hρU, ?_, hdisjoint⟩
+  intro x hx
+  exact
+    (finsum_eq_single (fun i => ρ i x) i₀ (hzero x hx)).symm.trans (ρ.sum_eq_one (Set.mem_univ x))
+
+public
+theorem HolomorphicCousin.exists_smoothPartitionOfUnity_eq_one_near_closed {ι E H M : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [FiniteDimensional ℝ E] [TopologicalSpace H]
+    (I : ModelWithCorners ℝ E H) [TopologicalSpace M] [ChartedSpace H M] [IsManifold I ∞ M]
+    [T2Space M] [SigmaCompactSpace M] (U : ι → Set M) (hUo : ∀ i, IsOpen (U i))
+    (hUc : Set.univ ⊆ ⋃ i, U i) (i₀ : ι) {K : Set M} (hK : IsClosed K) (hKU : K ⊆ U i₀) :
+    ∃ V : Set M,
+      IsOpen V ∧
+        K ⊆ V ∧
+          V ⊆ U i₀ ∧
+            ∃ ρ : SmoothPartitionOfUnity ι I M Set.univ,
+              ρ.IsSubordinate U ∧
+                (∀ x ∈ V, ρ i₀ x = 1) ∧
+                  (∀ i, i ≠ i₀ → ∀ x ∈ V, ρ i x = 0) ∧
+                    ∀ i, i ≠ i₀ → Disjoint (tsupport (ρ i)) V := by
+  obtain ⟨V, hVo, hKV, hVU, ρ, hρU, hρone, hρdisjoint⟩ :=
+    exists_smoothPartitionOfUnity_normalized_near_closed I U hUo hUc i₀ hK hKU
+  refine ⟨V, hVo, hKV, subset_closure.trans hVU, ρ, hρU, ?_, ?_, ?_⟩
+  · intro x hx
+    exact hρone (subset_closure hx)
+  · intro i hi x hx
+    apply image_eq_zero_of_notMem_tsupport
+    exact fun hs => Set.disjoint_left.mp (hρdisjoint i hi) hs (subset_closure hx)
+  · intro i hi
+    exact (hρdisjoint i hi).mono_right subset_closure
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Uniformization/SpecialPeriods1.lean b/LeanPool/HopfProblem/Uniformization/SpecialPeriods1.lean
new file mode 100644
index 000000000..67aff36d0
--- /dev/null
+++ b/LeanPool/HopfProblem/Uniformization/SpecialPeriods1.lean
@@ -0,0 +1,469 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+
+/-!
+# Hopf problem: uniformization · special periods 1
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def SpecialPeriods.rho : ℂ :=
+  (1 + (Real.sqrt 3 : ℂ) * Complex.I) / 2
+
+@[simp]
+private theorem SpecialPeriods.rho_re : rho.re = 1 / 2 := by
+  norm_num [rho, Complex.div_re, Complex.normSq_apply]
+
+@[simp]
+private theorem SpecialPeriods.rho_im : rho.im = Real.sqrt 3 / 2 := by
+  norm_num [rho, Complex.div_im, Complex.normSq_apply]
+
+private theorem SpecialPeriods.rho_im_pos : 0 < rho.im := by
+  rw [rho_im]
+  positivity
+
+private theorem
+    SpecialPeriods.rho_eq_exp : rho = Complex.exp (((Real.pi / 3 : ℝ) : ℂ) * Complex.I) := by
+  rw [Complex.exp_ofReal_mul_I, Real.cos_pi_div_three, Real.sin_pi_div_three]
+  push_cast
+  unfold rho
+  ring
+
+private theorem SpecialPeriods.rho_sq : rho ^ 2 = rho - 1 := by
+  apply Complex.ext
+  · simp only [pow_two, Complex.mul_re, rho_re, rho_im, Complex.sub_re, Complex.one_re]
+    nlinarith [Real.sq_sqrt (by norm_num : (0 : ℝ) ≤ 3)]
+  · simp only [pow_two, Complex.mul_im, rho_re, rho_im, Complex.sub_im, Complex.one_im]
+    ring
+
+private theorem SpecialPeriods.norm_rho : ‖rho‖ = 1 := by
+  rw [← sq_eq_sq₀ (norm_nonneg _) zero_le_one, Complex.sq_norm, Complex.normSq_apply, rho_re,
+    rho_im]
+  nlinarith [Real.sq_sqrt (by norm_num : (0 : ℝ) ≤ 3)]
+
+private theorem SpecialPeriods.rho_cube : rho ^ 3 = -1 := by
+  calc
+    rho ^ 3 = rho * rho ^ 2 := by ring
+    _ = rho * (rho - 1) := by rw [rho_sq]
+    _ = -1 := by linear_combination rho_sq
+
+private theorem SpecialPeriods.conj_rho : starRingEnd ℂ rho = 1 - rho := by
+  apply Complex.ext <;> simp
+  ring
+
+private def SpecialPeriods.cayley (a z : ℂ) : ℂ :=
+  (a - starRingEnd ℂ a * z) / (1 - z)
+
+@[simp]
+private theorem SpecialPeriods.cayley_zero (a : ℂ) : cayley a 0 = a := by simp [cayley]
+
+private theorem
+    SpecialPeriods.one_sub_ne_zero_of_norm_lt_one {z : ℂ} (hz : ‖z‖ < 1) : 1 - z ≠ 0 := by
+  intro h
+  have : z = 1 := (sub_eq_zero.mp h).symm
+  simp [this] at hz
+
+private theorem SpecialPeriods.cayley_im (a z : ℂ) :
+    (cayley a z).im = a.im * (1 - Complex.normSq z) / Complex.normSq (1 - z) := by
+  simp only [cayley, Complex.div_im, Complex.sub_im, Complex.mul_im, Complex.conj_re,
+    Complex.conj_im, Complex.sub_re, Complex.mul_re, Complex.one_re, Complex.one_im,
+    Complex.normSq_apply]
+  ring
+
+private theorem SpecialPeriods.cayley_im_pos {a z : ℂ} (ha : 0 < a.im) (hz : ‖z‖ < 1) :
+    0 < (cayley a z).im := by
+  rw [cayley_im]
+  apply div_pos
+  · apply mul_pos ha
+    rw [sub_pos, Complex.normSq_eq_norm_sq]
+    nlinarith [norm_nonneg z]
+  · exact Complex.normSq_pos.mpr (one_sub_ne_zero_of_norm_lt_one hz)
+
+private theorem
+    SpecialPeriods.cayley_contDiffOn (a : ℂ) : ContDiffOn ℂ ω (cayley a) (Metric.ball 0 1) := by
+  apply ContDiffOn.div
+  · exact contDiffOn_const.sub (contDiffOn_const.mul contDiffOn_id)
+  · exact contDiffOn_const.sub contDiffOn_id
+  · intro z hz
+    exact one_sub_ne_zero_of_norm_lt_one (by simpa using hz)
+
+private def SpecialPeriods.sectionThree (τ : ℂ) : PeriodPoint :=
+  ⟨τ, (2 - τ) / 3, 2 * τ / 3 - Complex.I⟩
+
+private def SpecialPeriods.sectionFour (τ : ℂ) : PeriodPoint :=
+  ⟨τ, (1 - τ) / 2, 3 * τ / 2 - Complex.I⟩
+
+private theorem SpecialPeriods.sectionThree_discriminant (τ : ℂ) (hτ : τ.im ≠ 0) :
+    (sectionThree τ).discriminant = -1 := by
+  apply mul_left_cancel₀ hτ
+  simp [sectionThree, PeriodPoint.discriminant]
+  field_simp
+  ring
+
+private theorem SpecialPeriods.sectionFour_discriminant (τ : ℂ) (hτ : τ.im ≠ 0) :
+    (sectionFour τ).discriminant = -1 := by
+  apply mul_left_cancel₀ hτ
+  simp [sectionFour, PeriodPoint.discriminant]
+  field_simp
+  ring
+
+private theorem SpecialPeriods.sectionThree_admissible {τ : ℂ} (hτ : 0 < τ.im) :
+    (sectionThree τ).Admissible := by
+  refine ⟨hτ, ?_⟩
+  rw [sectionThree_discriminant τ hτ.ne']
+  norm_num
+
+private theorem SpecialPeriods.sectionFour_admissible {τ : ℂ} (hτ : 0 < τ.im) :
+    (sectionFour τ).Admissible := by
+  refine ⟨hτ, ?_⟩
+  rw [sectionFour_discriminant τ hτ.ne']
+  norm_num
+
+private theorem SpecialPeriods.sectionThree_step (τ : ℂ) (hτ : τ ≠ 0) :
+    (sectionThree τ).step₁ = sectionThree ((τ - 1) / τ) := by
+  apply PeriodPoint.ext <;> simp [sectionThree, PeriodPoint.step₁] <;> field_simp <;> ring
+
+private theorem SpecialPeriods.sectionFour_step (τ : ℂ) (hτ : τ ≠ 0) :
+    (sectionFour τ).step₂ = sectionFour (-1 / τ) := by
+  apply PeriodPoint.ext <;> simp [sectionFour, PeriodPoint.step₂] <;> field_simp <;> ring
+
+private def SpecialPeriods.rotateThree (z : ℂ) : ℂ :=
+  -rho * z
+
+private def SpecialPeriods.rotateFour (z : ℂ) : ℂ :=
+  -Complex.I * z
+
+@[simp]
+private theorem SpecialPeriods.norm_rotateThree (z : ℂ) : ‖rotateThree z‖ = ‖z‖ := by
+  simp [rotateThree, norm_rho]
+
+private theorem
+    SpecialPeriods.rotateThree_cube (z : ℂ) : rotateThree (rotateThree (rotateThree z)) = z :=
+  by
+  change -rho * (-rho * (-rho * z)) = z
+  calc
+    -rho * (-rho * (-rho * z)) = -(rho ^ 3) * z := by ring
+    _ = z := by rw [rho_cube]; ring
+
+private theorem SpecialPeriods.rotateFour_fourth (z : ℂ) :
+    rotateFour (rotateFour (rotateFour (rotateFour z))) = z := by simp [rotateFour, ← mul_assoc]
+
+private def SpecialPeriods.tauThree (z : ℂ) : ℂ :=
+  cayley rho z
+
+private def SpecialPeriods.tauFour (z : ℂ) : ℂ :=
+  cayley Complex.I (z ^ 2)
+
+private theorem SpecialPeriods.tauThree_im_pos {z : ℂ} (hz : ‖z‖ < 1) : 0 < (tauThree z).im :=
+  cayley_im_pos rho_im_pos hz
+
+private theorem SpecialPeriods.tauFour_im_pos {z : ℂ} (hz : ‖z‖ < 1) : 0 < (tauFour z).im := by
+  apply cayley_im_pos (by simp)
+  rw [norm_pow]
+  nlinarith [norm_nonneg z]
+
+private theorem SpecialPeriods.tauThree_ne_zero {z : ℂ} (hz : ‖z‖ < 1) : tauThree z ≠ 0 := by
+  intro he
+  have := tauThree_im_pos hz
+  simp [he] at this
+
+private theorem SpecialPeriods.tauFour_ne_zero {z : ℂ} (hz : ‖z‖ < 1) : tauFour z ≠ 0 := by
+  intro he
+  have := tauFour_im_pos hz
+  simp [he] at this
+
+private theorem SpecialPeriods.tauThree_rotate {z : ℂ} (hz : ‖z‖ < 1) :
+    tauThree (rotateThree z) = (tauThree z - 1) / tauThree z := by
+  have hd : 1 - z ≠ 0 := one_sub_ne_zero_of_norm_lt_one hz
+  have hr : 1 + rho * z ≠ 0 := by
+    simpa only [rotateThree, neg_mul, sub_neg_eq_add] using
+      one_sub_ne_zero_of_norm_lt_one (show ‖rotateThree z‖ < 1 by simpa using hz)
+  have hn : rho - (1 - rho) * (-rho * z) = rho + z := by linear_combination -z * rho_sq
+  rw [eq_div_iff (tauThree_ne_zero hz)]
+  simp only [tauThree, cayley, conj_rho, rotateThree]
+  rw [hn]
+  simp only [neg_mul, sub_neg_eq_add]
+  field_simp
+  linear_combination (1 - z ^ 2) * rho_sq
+
+private theorem SpecialPeriods.tauFour_rotate {z : ℂ} (hz : ‖z‖ < 1) :
+    tauFour (rotateFour z) = -1 / tauFour z := by
+  have hz2 : ‖z ^ 2‖ < 1 := by rw [norm_pow]; nlinarith [norm_nonneg z]
+  have hd : 1 - z ^ 2 ≠ 0 := one_sub_ne_zero_of_norm_lt_one hz2
+  have hp : 1 + z ^ 2 ≠ 0 := by
+    intro h
+    have he : z ^ 2 = -1 := eq_neg_of_add_eq_zero_right h
+    simp [he] at hz2
+  simp [tauFour, cayley, rotateFour, mul_pow, Complex.I_sq]
+  field_simp
+  ring_nf
+  simp
+
+private theorem SpecialPeriods.tauThree_contDiffOn : ContDiffOn ℂ ω tauThree (Metric.ball 0 1) :=
+  cayley_contDiffOn rho
+
+private theorem SpecialPeriods.tauFour_contDiffOn : ContDiffOn ℂ ω tauFour (Metric.ball 0 1) := by
+  apply (cayley_contDiffOn Complex.I).comp (contDiffOn_id.pow 2)
+  intro z hz
+  simp only [Metric.mem_ball, dist_zero_right, norm_pow, id_eq] at *
+  nlinarith [norm_nonneg z]
+
+private def SpecialPeriods.localThree (z : ℂ) : PeriodPoint :=
+  sectionThree (tauThree z)
+
+private def SpecialPeriods.localFour (z : ℂ) : PeriodPoint :=
+  sectionFour (tauFour z)
+
+private theorem
+    SpecialPeriods.localThree_admissible {z : ℂ} (hz : ‖z‖ < 1) : (localThree z).Admissible :=
+  sectionThree_admissible (tauThree_im_pos hz)
+
+private theorem
+    SpecialPeriods.localFour_admissible {z : ℂ} (hz : ‖z‖ < 1) : (localFour z).Admissible :=
+  sectionFour_admissible (tauFour_im_pos hz)
+
+private theorem SpecialPeriods.localThree_rotate {z : ℂ} (hz : ‖z‖ < 1) :
+    localThree (rotateThree z) = (localThree z).step₁ := by
+  rw [localThree, tauThree_rotate hz]
+  exact (sectionThree_step _ (tauThree_ne_zero hz)).symm
+
+private theorem SpecialPeriods.localFour_rotate {z : ℂ} (hz : ‖z‖ < 1) :
+    localFour (rotateFour z) = (localFour z).step₂ := by
+  rw [localFour, tauFour_rotate hz]
+  exact (sectionFour_step _ (tauFour_ne_zero hz)).symm
+
+/-- The open unit disc in the complex plane. -/
+public
+def SpecialPeriods.unitDisc : TopologicalSpace.Opens ℂ :=
+  ⟨Metric.ball 0 1, Metric.isOpen_ball⟩
+
+/-- The complex open unit disc as a subtype. -/
+public
+abbrev SpecialPeriods.Disc :=
+  unitDisc
+
+private theorem SpecialPeriods.disc_norm_lt_one (z : Disc) : ‖(z : ℂ)‖ < 1 := by
+  simpa [unitDisc] using z.property
+
+private theorem SpecialPeriods.tauThree_holomorphic :
+    ContMDiff 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) ω (fun z : Disc => tauThree z) :=
+  tauThree_contDiffOn.contMDiffOn.comp_contMDiff contMDiff_subtype_val (fun z => z.property)
+
+private theorem SpecialPeriods.tauFour_holomorphic :
+    ContMDiff 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) ω (fun z : Disc => tauFour z) :=
+  tauFour_contDiffOn.contMDiffOn.comp_contMDiff contMDiff_subtype_val (fun z => z.property)
+
+private def SpecialPeriods.threePeriodMap : HolomorphicPeriodMap ℂ Disc
+    where
+  point z := ⟨localThree z, localThree_admissible (disc_norm_lt_one z)⟩
+  holomorphic_tau := tauThree_holomorphic
+  holomorphic_mu := (contMDiff_const.sub tauThree_holomorphic).div_const 3
+  holomorphic_beta := ((contMDiff_const.mul tauThree_holomorphic).div_const 3).sub contMDiff_const
+
+private def SpecialPeriods.fourPeriodMap : HolomorphicPeriodMap ℂ Disc
+    where
+  point z := ⟨localFour z, localFour_admissible (disc_norm_lt_one z)⟩
+  holomorphic_tau := tauFour_holomorphic
+  holomorphic_mu := (contMDiff_const.sub tauFour_holomorphic).div_const 2
+  holomorphic_beta := ((contMDiff_const.mul tauFour_holomorphic).div_const 2).sub contMDiff_const
+
+private def SpecialPeriods.discZero : Disc :=
+  ⟨0, by simp [unitDisc]⟩
+
+@[simp]
+private theorem SpecialPeriods.discZero_val : (discZero : ℂ) = 0 :=
+  rfl
+
+private def SpecialPeriods.discScalar (c : ℂ) (hc : ‖c‖ = 1) (z : Disc) : Disc :=
+  ⟨c * z, by
+    have hn : ‖c * (z : ℂ)‖ < 1 := by simpa [norm_mul, hc] using disc_norm_lt_one z
+    simpa [unitDisc] using hn⟩
+
+@[simp]
+private theorem SpecialPeriods.discScalar_val (c : ℂ) (hc : ‖c‖ = 1) (z : Disc) :
+    (discScalar c hc z : ℂ) = c * z :=
+  rfl
+
+private theorem SpecialPeriods.discScalar_holomorphic (c : ℂ) (hc : ‖c‖ = 1) :
+    ContMDiff 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) ω (discScalar c hc) := by
+  intro z
+  have he :
+    ContMDiffAt 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) ω (fun w : Disc => (discScalar c hc w : ℂ)) z ↔
+      ContMDiffAt 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) ω (discScalar c hc) z :=
+    ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+  exact he.mp ((contMDiff_const.mul contMDiff_subtype_val) z)
+
+private theorem SpecialPeriods.discScalar_iterate_val (c : ℂ) (hc : ‖c‖ = 1) (n : ℕ) (z : Disc) :
+    ((discScalar c hc)^[n] z : ℂ) = c ^ n * z := by
+  induction n with
+  | zero => simp
+  | succ n ih =>
+    rw [Function.iterate_succ_apply', discScalar_val, ih, pow_succ']
+    rw [mul_assoc]
+
+private def SpecialPeriods.discRotateThree : Disc → Disc :=
+  discScalar (-rho) (by simpa using norm_rho)
+
+private def SpecialPeriods.discRotateFour : Disc → Disc :=
+  discScalar (-Complex.I) (by simp)
+
+private theorem SpecialPeriods.discRotateThree_holomorphic :
+    ContMDiff 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) ω discRotateThree :=
+  discScalar_holomorphic _ _
+
+private theorem
+    SpecialPeriods.discRotateFour_holomorphic : ContMDiff 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) ω discRotateFour :=
+  discScalar_holomorphic _ _
+
+private theorem SpecialPeriods.discRotateThree_cube (z : Disc) :
+    discRotateThree (discRotateThree (discRotateThree z)) = z :=
+  Subtype.ext (rotateThree_cube z)
+
+private theorem SpecialPeriods.discRotateFour_fourth (z : Disc) :
+    discRotateFour (discRotateFour (discRotateFour (discRotateFour z))) = z :=
+  Subtype.ext (rotateFour_fourth z)
+
+private theorem SpecialPeriods.discRotateThree_iterate_order : discRotateThree^[3] = id := by
+  funext z
+  exact discRotateThree_cube z
+
+private theorem SpecialPeriods.discRotateFour_iterate_order : discRotateFour^[4] = id := by
+  funext z
+  exact discRotateFour_fourth z
+
+private def SpecialPeriods.threeRotation : Diffeomorph 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) Disc Disc ω
+    where
+  toFun := discRotateThree
+  invFun := discRotateThree ∘ discRotateThree
+  left_inv := discRotateThree_cube
+  right_inv := discRotateThree_cube
+  contMDiff_toFun := discRotateThree_holomorphic
+  contMDiff_invFun := discRotateThree_holomorphic.comp discRotateThree_holomorphic
+
+private def SpecialPeriods.fourRotation : Diffeomorph 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) Disc Disc ω
+    where
+  toFun := discRotateFour
+  invFun := discRotateFour ∘ discRotateFour ∘ discRotateFour
+  left_inv := discRotateFour_fourth
+  right_inv := discRotateFour_fourth
+  contMDiff_toFun := discRotateFour_holomorphic
+  contMDiff_invFun :=
+    discRotateFour_holomorphic.comp (discRotateFour_holomorphic.comp discRotateFour_holomorphic)
+
+private theorem
+    SpecialPeriods.neg_rho_pow_ne_one {n : ℕ} (hn : 0 < n) (hn' : n < 3) : (-rho) ^ n ≠ 1 := by
+  interval_cases n
+  · simp only [pow_one]
+    intro he
+    have hh := congrArg Complex.im he
+    simp only [Complex.neg_im, Complex.one_im] at hh
+    linarith [rho_im_pos]
+  · rw [neg_sq, rho_sq]
+    intro he
+    have hh := congrArg Complex.im he
+    simp only [Complex.sub_im, Complex.one_im, sub_zero] at hh
+    linarith [rho_im_pos]
+
+private theorem SpecialPeriods.neg_I_pow_ne_one {n : ℕ} (hn : 0 < n) (hn' : n < 4) :
+    (-Complex.I) ^ n ≠ 1 := by
+  interval_cases n
+  · intro he
+    have hh := congrArg Complex.im he
+    norm_num at hh
+  · norm_num
+  · intro he
+    have hh := congrArg Complex.im he
+    norm_num [pow_succ] at hh
+
+private theorem SpecialPeriods.discScalar_iterate_fixed_iff (c : ℂ) (hc : ‖c‖ = 1) (n : ℕ)
+    (hn : c ^ n ≠ 1) (z : Disc) : (discScalar c hc)^[n] z = z ↔ z = discZero := by
+  constructor
+  · intro he
+    apply Subtype.ext
+    have hv := congrArg Subtype.val he
+    rw [discScalar_iterate_val] at hv
+    by_contra hz
+    apply hn
+    exact mul_right_cancel₀ hz (by simpa using hv)
+  · intro he
+    subst z
+    apply Subtype.ext
+    rw [discScalar_iterate_val]
+    simp
+
+private theorem SpecialPeriods.discRotateThree_iterate_fixed_iff (n : ℕ) (hn : 0 < n) (hn' : n < 3)
+    (z : Disc) : discRotateThree^[n] z = z ↔ z = discZero :=
+  discScalar_iterate_fixed_iff _ _ n (neg_rho_pow_ne_one hn hn') z
+
+private theorem SpecialPeriods.discRotateFour_iterate_fixed_iff (n : ℕ) (hn : 0 < n) (hn' : n < 4)
+    (z : Disc) : discRotateFour^[n] z = z ↔ z = discZero :=
+  discScalar_iterate_fixed_iff _ _ n (neg_I_pow_ne_one hn hn') z
+
+private theorem SpecialPeriods.threePeriodMap_rotate (z : Disc) :
+    threePeriodMap.point (discRotateThree z) = (threePeriodMap.point z).step₁ :=
+  Subtype.ext (localThree_rotate (disc_norm_lt_one z))
+
+private theorem SpecialPeriods.fourPeriodMap_rotate (z : Disc) :
+    fourPeriodMap.point (discRotateFour z) = (fourPeriodMap.point z).step₂ :=
+  Subtype.ext (localFour_rotate (disc_norm_lt_one z))
+
+private theorem SpecialPeriods.threePeriodMap_matrix_covariance (z : Disc) :
+    (threePeriodMap.point (discRotateThree z)).val.matrix * A₁.map (Int.castRingHom ℂ) =
+      (threePeriodMap.point z).val.R₁ * (threePeriodMap.point z).val.matrix := by
+  rw [threePeriodMap_rotate]
+  change (threePeriodMap.point z).val.step₁.matrix * _ = _
+  rw [PeriodPoint.step₁_matrix _
+      ((threePeriodMap.point z).val.τ_ne_zero (threePeriodMap.point z).property.1),
+    Matrix.mul_assoc]
+  have h : (T₁.map (Int.castRingHom ℂ)).transpose * A₁.map (Int.castRingHom ℂ) = 1 := by
+    change T₁.transpose.map (Int.castRingHom ℂ) * A₁.map (Int.castRingHom ℂ) = 1
+    rw [← Matrix.map_mul, show T₁.transpose * A₁ = 1 by decide]
+    simp
+  rw [h, Matrix.mul_one]
+
+private theorem SpecialPeriods.fourPeriodMap_matrix_covariance (z : Disc) :
+    (fourPeriodMap.point (discRotateFour z)).val.matrix * A₂.map (Int.castRingHom ℂ) =
+      (fourPeriodMap.point z).val.R₂ * (fourPeriodMap.point z).val.matrix := by
+  rw [fourPeriodMap_rotate]
+  change (fourPeriodMap.point z).val.step₂.matrix * _ = _
+  rw [PeriodPoint.step₂_matrix _
+      ((fourPeriodMap.point z).val.τ_ne_zero (fourPeriodMap.point z).property.1),
+    Matrix.mul_assoc]
+  have h : (T₂.map (Int.castRingHom ℂ)).transpose * A₂.map (Int.castRingHom ℂ) = 1 := by
+    change T₂.transpose.map (Int.castRingHom ℂ) * A₂.map (Int.castRingHom ℂ) = 1
+    rw [← Matrix.map_mul, show T₂.transpose * A₂ = 1 by decide]
+    simp
+  rw [h, Matrix.mul_one]
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Uniformization/SpecialPeriods2.lean b/LeanPool/HopfProblem/Uniformization/SpecialPeriods2.lean
new file mode 100644
index 000000000..24af61b2a
--- /dev/null
+++ b/LeanPool/HopfProblem/Uniformization/SpecialPeriods2.lean
@@ -0,0 +1,5642 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Threefold.SpecialPeriods3
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.Foundations.LocalOrbitQuotient
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods3
+
+/-!
+# Hopf problem: uniformization · special periods 2
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def SpecialPeriods.Triangle.width : ℝ :=
+  1 + Real.sqrt 2
+
+private theorem SpecialPeriods.Triangle.width_pos : 0 < width := by
+  unfold width
+  positivity
+
+private theorem SpecialPeriods.Triangle.one_lt_width : 1 < width := by
+  unfold width
+  have : 0 < Real.sqrt 2 := by positivity
+  linarith
+
+private theorem SpecialPeriods.Triangle.width_ne_zero : width ≠ 0 :=
+  width_pos.ne'
+
+private theorem SpecialPeriods.Triangle.width_sq : width ^ 2 = 2 * width + 1 := by
+  have hs := Real.sq_sqrt (by norm_num : (0 : ℝ) ≤ 2)
+  unfold width
+  nlinarith
+
+private theorem
+    SpecialPeriods.Triangle.width_sub_one_sq : (width - 1) ^ 2 = 2 := by nlinarith [width_sq]
+
+private def SpecialPeriods.Triangle.generatorOneSL : SL(2, ℝ) :=
+  ⟨!![0, -1; 1, 1], by norm_num [Matrix.det_fin_two_of]⟩
+
+private def SpecialPeriods.Triangle.generatorTwoSL : SL(2, ℝ) :=
+  ⟨!![1, width + 1; -1, -width], by simp [Matrix.det_fin_two_of]⟩
+
+private def SpecialPeriods.Triangle.cuspInverseSL : SL(2, ℝ) :=
+  ⟨!![1, width; 0, 1], by simp [Matrix.det_fin_two_of]⟩
+
+private def SpecialPeriods.Triangle.cuspSL : SL(2, ℝ) :=
+  cuspInverseSL⁻¹
+
+@[simp]
+private theorem SpecialPeriods.Triangle.coe_generatorOneSL :
+    (generatorOneSL : Matrix (Fin 2) (Fin 2) ℝ) = !![0, -1; 1, 1] :=
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.Triangle.coe_generatorTwoSL :
+    (generatorTwoSL : Matrix (Fin 2) (Fin 2) ℝ) = !![1, width + 1; -1, -width] :=
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.Triangle.coe_cuspSL :
+    (cuspSL : Matrix (Fin 2) (Fin 2) ℝ) = !![1, -width; 0, 1] := by
+  have hco : (cuspInverseSL : Matrix (Fin 2) (Fin 2) ℝ) = !![1, width; 0, 1] := rfl
+  simp [hco, cuspSL, Matrix.SpecialLinearGroup.coe_inv, Matrix.adjugate_fin_two]
+
+private theorem SpecialPeriods.Triangle.coe_generatorOneSL_sq :
+    ((generatorOneSL ^ 2 : SL(2, ℝ)) : Matrix (Fin 2) (Fin 2) ℝ) = !![-1, -1; 1, 0] := by
+  norm_num [Matrix.SpecialLinearGroup.coe_pow, pow_two, Matrix.mul_fin_two]
+
+private theorem SpecialPeriods.Triangle.generatorOneSL_cube : generatorOneSL ^ 3 = -1 := by
+  apply Subtype.ext
+  norm_num [Matrix.SpecialLinearGroup.coe_pow, pow_succ, Matrix.mul_fin_two, Matrix.one_fin_two]
+  ext i j
+  fin_cases i <;> fin_cases j <;> norm_num
+
+private theorem SpecialPeriods.Triangle.coe_generatorTwoSL_sq :
+    ((generatorTwoSL ^ 2 : SL(2, ℝ)) : Matrix (Fin 2) (Fin 2) ℝ) =
+      !![-width, -2 * width; width - 1, width] := by
+  rw [Matrix.SpecialLinearGroup.coe_pow, coe_generatorTwoSL, pow_two, Matrix.mul_fin_two]
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp <;> nlinarith [width_sq]
+
+private theorem SpecialPeriods.Triangle.generatorTwoSL_fourth : generatorTwoSL ^ 4 = -1 := by
+  have hsq : (generatorTwoSL ^ 2) ^ 2 = -1 := by
+    apply Subtype.ext
+    rw [Matrix.SpecialLinearGroup.coe_pow, coe_generatorTwoSL_sq,
+      Matrix.SpecialLinearGroup.coe_neg, Matrix.SpecialLinearGroup.coe_one, pow_two,
+      Matrix.mul_fin_two, Matrix.one_fin_two]
+    ext i j
+    fin_cases i <;> fin_cases j <;> simp <;> nlinarith [width_sq]
+  simpa only [← pow_mul] using hsq
+
+private theorem SpecialPeriods.Triangle.generatorOneSL_mul_generatorTwoSL :
+    generatorOneSL * generatorTwoSL = cuspInverseSL := by
+  apply Subtype.ext
+  simp [cuspInverseSL]
+
+private theorem SpecialPeriods.Triangle.generatorOneSL_mul_generatorTwoSL_mul_cuspSL :
+    generatorOneSL * generatorTwoSL * cuspSL = 1 := by
+  rw [generatorOneSL_mul_generatorTwoSL, cuspSL, mul_inv_cancel]
+
+private theorem SpecialPeriods.Triangle.cuspSL_inv : cuspSL⁻¹ = cuspInverseSL :=
+  inv_inv _
+
+private theorem SpecialPeriods.Triangle.sub_conj_ne_zero (a z : ℍ) :
+    (z : ℂ) - starRingEnd ℂ (a : ℂ) ≠ 0 := by
+  intro he
+  have him := congrArg Complex.im he
+  simp only [Complex.sub_im, Complex.conj_im, Complex.zero_im, UpperHalfPlane.coe_im] at him
+  linarith [a.im_pos, z.im_pos]
+
+private def SpecialPeriods.Triangle.cayleyCoordinate (a z : ℍ) : ℂ :=
+  ((z : ℂ) - a) / ((z : ℂ) - starRingEnd ℂ (a : ℂ))
+
+private theorem SpecialPeriods.Triangle.cayleyCoordinate_norm_lt_one (a z : ℍ) :
+    ‖cayleyCoordinate a z‖ < 1 := by
+  rw [cayleyCoordinate, norm_div]
+  apply (div_lt_one (norm_pos_iff.mpr (sub_conj_ne_zero a z))).mpr
+  have hsq : Complex.normSq ((z : ℂ) - a) < Complex.normSq ((z : ℂ) - starRingEnd ℂ (a : ℂ)) := by
+    simp only [Complex.normSq_apply, Complex.sub_re, Complex.sub_im, Complex.conj_re,
+      Complex.conj_im, UpperHalfPlane.coe_im]
+    nlinarith [mul_pos a.im_pos z.im_pos]
+  rw [Complex.normSq_eq_norm_sq, Complex.normSq_eq_norm_sq] at hsq
+  nlinarith [norm_nonneg ((z : ℂ) - a), norm_nonneg ((z : ℂ) - starRingEnd ℂ (a : ℂ))]
+
+private def SpecialPeriods.Triangle.toDisc (a z : ℍ) : SpecialPeriods.Disc :=
+  ⟨cayleyCoordinate a z, by
+    simpa [SpecialPeriods.unitDisc] using cayleyCoordinate_norm_lt_one a z⟩
+
+@[simp]
+private theorem
+    SpecialPeriods.Triangle.toDisc_val (a z : ℍ) : (toDisc a z : ℂ) = cayleyCoordinate a z :=
+  rfl
+
+private def SpecialPeriods.Triangle.fromDisc (a : ℍ) (z : SpecialPeriods.Disc) : ℍ :=
+  UpperHalfPlane.ofComplex (SpecialPeriods.cayley a z)
+
+@[simp]
+private theorem SpecialPeriods.Triangle.fromDisc_val (a : ℍ) (z : SpecialPeriods.Disc) :
+    (fromDisc a z : ℂ) = SpecialPeriods.cayley a z := by
+  simp only [fromDisc,
+    UpperHalfPlane.ofComplex_apply_of_im_pos
+        (SpecialPeriods.cayley_im_pos a.im_pos (SpecialPeriods.disc_norm_lt_one z))]
+
+@[simp]
+private theorem SpecialPeriods.Triangle.toDisc_center (a : ℍ) :
+    toDisc a a = (⟨0, by simp [SpecialPeriods.unitDisc]⟩ : SpecialPeriods.Disc) := by
+  apply Subtype.ext
+  simp [toDisc, cayleyCoordinate]
+
+private theorem SpecialPeriods.Triangle.cayleyCoordinate_holomorphic (a : ℍ) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (cayleyCoordinate a) :=
+  (UpperHalfPlane.contMDiff_coe.sub contMDiff_const).div₀
+    (UpperHalfPlane.contMDiff_coe.sub contMDiff_const) (sub_conj_ne_zero a)
+
+private theorem
+    SpecialPeriods.Triangle.toDisc_holomorphic (a : ℍ) : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (toDisc a) := by
+  intro z
+  have he :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (fun w : ℍ => (toDisc a w : ℂ)) z ↔
+      ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (toDisc a) z :=
+    ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+  exact he.mp (cayleyCoordinate_holomorphic a z)
+
+private theorem SpecialPeriods.Triangle.fromDisc_holomorphic (a : ℍ) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fromDisc a) := by
+  have hc : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z : SpecialPeriods.Disc => SpecialPeriods.cayley a z) :=
+    (SpecialPeriods.cayley_contDiffOn (a : ℂ)).contMDiffOn.comp_contMDiff contMDiff_subtype_val
+      (fun z => z.property)
+  intro z
+  exact
+    (UpperHalfPlane.contMDiffAt_ofComplex
+          (SpecialPeriods.cayley_im_pos a.im_pos (SpecialPeriods.disc_norm_lt_one z))).comp
+      z (hc z)
+
+private theorem
+    SpecialPeriods.Triangle.fromDisc_toDisc (a z : ℍ) : fromDisc a (toDisc a z) = z := by
+  apply UpperHalfPlane.ext
+  rw [fromDisc_val, toDisc_val]
+  have hd := sub_conj_ne_zero a z
+  have ha := sub_conj_ne_zero a a
+  have hc := SpecialPeriods.one_sub_ne_zero_of_norm_lt_one (cayleyCoordinate_norm_lt_one a z)
+  unfold SpecialPeriods.cayley cayleyCoordinate at *
+  field_simp [hd, ha, hc]
+  ring
+
+private theorem SpecialPeriods.Triangle.toDisc_fromDisc (a : ℍ) (z : SpecialPeriods.Disc) :
+    toDisc a (fromDisc a z) = z := by
+  apply Subtype.ext
+  rw [toDisc_val]
+  unfold cayleyCoordinate
+  rw [fromDisc_val]
+  have hd := SpecialPeriods.one_sub_ne_zero_of_norm_lt_one (SpecialPeriods.disc_norm_lt_one z)
+  have ha := sub_conj_ne_zero a a
+  have hz := sub_conj_ne_zero a (fromDisc a z)
+  rw [fromDisc_val] at hz
+  unfold SpecialPeriods.cayley at *
+  field_simp [hd, ha, hz]
+  ring_nf
+  field_simp [ha]
+
+private def SpecialPeriods.Triangle.cayleyBiholomorph (a : ℍ) :
+    Diffeomorph 𝓘(ℂ) 𝓘(ℂ) ℍ SpecialPeriods.Disc ω
+    where
+  toFun := toDisc a
+  invFun := fromDisc a
+  left_inv := fromDisc_toDisc a
+  right_inv := toDisc_fromDisc a
+  contMDiff_toFun := toDisc_holomorphic a
+  contMDiff_invFun := fromDisc_holomorphic a
+
+private def SpecialPeriods.Triangle.slDenom (g : SL(2, ℝ)) (z : ℂ) : ℂ :=
+  (g 1 0 : ℂ) * z + (g 1 1 : ℂ)
+
+private theorem SpecialPeriods.Triangle.slDenom_ne_zero (g : SL(2, ℝ)) (z : ℍ) : slDenom g z ≠ 0 :=
+  UpperHalfPlane.linear_ne_zero z (g.row_ne_zero 1)
+
+private theorem
+    SpecialPeriods.Triangle.sl_fixed_equation (g : SL(2, ℝ)) (a : ℍ) (hfix : g • a = a) :
+    (g 0 0 : ℂ) * a + (g 0 1 : ℂ) = (a : ℂ) * slDenom g a := by
+  have he := congrArg (fun z : ℍ => (z : ℂ)) hfix
+  apply (div_eq_iff (slDenom_ne_zero g a)).mp
+  simpa only [UpperHalfPlane.coe_specialLinearGroup_apply, Algebra.algebraMap_self,
+    RingHom.id_apply, slDenom] using he
+
+private theorem
+    SpecialPeriods.Triangle.sl_fixed_conj_equation (g : SL(2, ℝ)) (a : ℍ) (hfix : g • a = a) :
+    (g 0 0 : ℂ) * starRingEnd ℂ (a : ℂ) + (g 0 1 : ℂ) =
+      starRingEnd ℂ (a : ℂ) * slDenom g (starRingEnd ℂ (a : ℂ)) := by
+  simpa [slDenom] using congrArg (starRingEnd ℂ) (sl_fixed_equation g a hfix)
+
+private theorem SpecialPeriods.Triangle.sl_fixed_denominator_identity (g : SL(2, ℝ)) (a : ℍ)
+    (hfix : g • a = a) : ((g 0 0 : ℂ) - (g 1 0 : ℂ) * (a : ℂ)) * slDenom g a = 1 := by
+  have hdet : (g 0 0 : ℂ) * (g 1 1 : ℂ) - (g 0 1 : ℂ) * (g 1 0 : ℂ) = 1 := by
+    exact_mod_cast
+      (show g 0 0 * g 1 1 - g 0 1 * g 1 0 = 1 from
+        (Matrix.det_fin_two g.val).symm.trans g.property)
+  have hf := sl_fixed_equation g a hfix
+  unfold slDenom at *
+  linear_combination (g 1 0 : ℂ) * hf + hdet
+
+private theorem SpecialPeriods.Triangle.sl_fixed_conj_denominator (g : SL(2, ℝ)) (a : ℍ)
+    (hfix : g • a = a) : (g 0 0 : ℂ) - (g 1 0 : ℂ) * starRingEnd ℂ (a : ℂ) = slDenom g a := by
+  have hf := sl_fixed_equation g a hfix
+  have him := congrArg Complex.im hf
+  simp only [slDenom, Complex.add_im, Complex.mul_im, Complex.ofReal_re, Complex.ofReal_im,
+    MulZeroClass.zero_mul, add_zero, Complex.add_re, Complex.mul_re, sub_zero] at him
+  have hr : g 0 0 = 2 * g 1 0 * (a : ℂ).re + g 1 1 := by
+    apply mul_right_cancel₀ (show (a : ℂ).im ≠ 0 from a.im_ne_zero)
+    calc
+      g 0 0 * (a : ℂ).im =
+          (a : ℂ).re * (g 1 0 * (a : ℂ).im) + (a : ℂ).im * (g 1 0 * (a : ℂ).re + g 1 1) :=
+        him
+      _ = (2 * g 1 0 * (a : ℂ).re + g 1 1) * (a : ℂ).im := by ring
+  apply Complex.ext <;>
+      simp only [slDenom, Complex.sub_re, Complex.sub_im, Complex.mul_re, Complex.mul_im,
+        Complex.conj_re, Complex.conj_im, Complex.ofReal_re, Complex.ofReal_im, Complex.add_re,
+        Complex.add_im] <;>
+    nlinarith [hr]
+
+private theorem SpecialPeriods.Triangle.sl_fixed_denominator_norm (g : SL(2, ℝ)) (a : ℍ)
+    (hfix : g • a = a) : ‖slDenom g a‖ = 1 := by
+  have hc : starRingEnd ℂ (slDenom g a) = (g 0 0 : ℂ) - (g 1 0 : ℂ) * (a : ℂ) := by
+    simpa only [map_sub, map_mul, Complex.conj_ofReal, Complex.conj_conj] using
+      (congrArg (starRingEnd ℂ) (sl_fixed_conj_denominator g a hfix)).symm
+  have hm : starRingEnd ℂ (slDenom g a) * slDenom g a = 1 := by
+    rw [hc, sl_fixed_denominator_identity g a hfix]
+  have hn := congrArg Norm.norm hm
+  simp only [norm_mul, Complex.norm_conj, NormOneClass.norm_one] at hn
+  nlinarith [norm_nonneg (slDenom g a)]
+
+private def SpecialPeriods.Triangle.slMultiplier (g : SL(2, ℝ)) (a : ℍ) : ℂ :=
+  1 / slDenom g a ^ 2
+
+private theorem SpecialPeriods.Triangle.sl_hasStrictDerivAt_smul (g : SL(2, ℝ)) (a : ℍ) :
+    HasStrictDerivAt (fun z : ℂ => ((g • UpperHalfPlane.ofComplex z : ℍ) : ℂ)) (slMultiplier g a)
+      (a : ℂ) := by
+  have h :=
+    UpperHalfPlane.hasStrictDerivAt_smul (g := Matrix.SpecialLinearGroup.mapGL ℝ g) (by simp) a
+  simpa [MulAction.compHom_smul_def, slMultiplier, slDenom, UpperHalfPlane.denom] using h
+
+private theorem SpecialPeriods.Triangle.sl_deriv_smul (g : SL(2, ℝ)) (a : ℍ) :
+    deriv (fun z : ℂ => ((g • UpperHalfPlane.ofComplex z : ℍ) : ℂ)) (a : ℂ) = slMultiplier g a :=
+  (sl_hasStrictDerivAt_smul g a).hasDerivAt.deriv
+
+private theorem
+    SpecialPeriods.Triangle.slMultiplier_norm (g : SL(2, ℝ)) (a : ℍ) (hfix : g • a = a) :
+    ‖slMultiplier g a‖ = 1 := by simp [slMultiplier, sl_fixed_denominator_norm g a hfix]
+
+private theorem SpecialPeriods.Triangle.cayleyCoordinate_smul (g : SL(2, ℝ)) (a z : ℍ)
+    (hfix : g • a = a) : cayleyCoordinate a (g • z) = slMultiplier g a * cayleyCoordinate a z := by
+  have hd := slDenom_ne_zero g z
+  have ha := slDenom_ne_zero g a
+  have hn :
+    ((g 0 0 : ℂ) * z + (g 0 1 : ℂ)) / slDenom g z - (a : ℂ) =
+      ((g 0 0 : ℂ) - (g 1 0 : ℂ) * (a : ℂ)) * ((z : ℂ) - a) / slDenom g z := by
+    have hf := sl_fixed_equation g a hfix
+    field_simp [hd]
+    unfold slDenom at *
+    linear_combination hf
+  have hnbar :
+    ((g 0 0 : ℂ) * z + (g 0 1 : ℂ)) / slDenom g z - starRingEnd ℂ (a : ℂ) =
+      ((g 0 0 : ℂ) - (g 1 0 : ℂ) * starRingEnd ℂ (a : ℂ)) * ((z : ℂ) - starRingEnd ℂ (a : ℂ)) /
+        slDenom g z := by
+    have hf := sl_fixed_conj_equation g a hfix
+    field_simp [hd]
+    unfold slDenom at *
+    linear_combination hf
+  have hcoef : ((g 0 0 : ℂ) - (g 1 0 : ℂ) * (a : ℂ)) / slDenom g a = slMultiplier g a := by
+    rw [slMultiplier, div_eq_div_iff ha (pow_ne_zero 2 ha)]
+    have hf := sl_fixed_denominator_identity g a hfix
+    linear_combination slDenom g a * hf
+  unfold cayleyCoordinate
+  simp only [UpperHalfPlane.coe_specialLinearGroup_apply, Algebra.algebraMap_self,
+    RingHom.id_apply]
+  change
+    (((g 0 0 : ℂ) * z + (g 0 1 : ℂ)) / slDenom g z - (a : ℂ)) /
+        (((g 0 0 : ℂ) * z + (g 0 1 : ℂ)) / slDenom g z - starRingEnd ℂ (a : ℂ)) =
+      _
+  rw [hn, hnbar, div_div_div_cancel_right₀ hd, sl_fixed_conj_denominator g a hfix,
+    mul_div_mul_comm, hcoef]
+
+/-- The homomorphism from a finite cyclic group generated by an element of bounded order. -/
+public
+def SpecialPeriods.cyclicPowerHom {G : Type*} [Group G] (n : ℕ) (a : G) (ha : a ^ n = 1) :
+    Multiplicative (ZMod n) →* G :=
+  (ZMod.lift n
+      ⟨zmultiplesHom (Additive G) (Additive.ofMul a),
+        by
+        change a ^ (n : ℤ) = 1
+        simpa only [zpow_natCast] using ha⟩).toMultiplicativeLeft
+
+@[simp]
+private theorem SpecialPeriods.cyclicPowerHom_intCast {G : Type*} [Group G] (n : ℕ) (a : G)
+    (ha : a ^ n = 1) (k : ℤ) :
+    cyclicPowerHom n a ha (Multiplicative.ofAdd (k : ZMod n)) = a ^ k := by simp [cyclicPowerHom]
+
+@[simp]
+private theorem
+    SpecialPeriods.cyclicPowerHom_one {G : Type*} [Group G] (n : ℕ) (a : G) (ha : a ^ n = 1) :
+    cyclicPowerHom n a ha (Multiplicative.ofAdd (1 : ZMod n)) = a := by
+  simpa using cyclicPowerHom_intCast n a ha 1
+
+private theorem SpecialPeriods.cyclic_eq_generator_zpow_mo1973_15645 {n : ℕ}
+    (x : Multiplicative (ZMod n)) : ∃ k : ℤ, x = Multiplicative.ofAdd (1 : ZMod n) ^ k := by
+  obtain ⟨k, hk⟩ := ZMod.intCast_surjective x.toAdd
+  refine ⟨k, ?_⟩
+  change x.toAdd = k • (1 : ZMod n)
+  simpa using hk.symm
+
+private theorem SpecialPeriods.cyclic_hom_ext_mo1973_15646 {G : Type*} [Group G] {n : ℕ}
+    {f g : Multiplicative (ZMod n) →* G}
+    (h : f (Multiplicative.ofAdd 1) = g (Multiplicative.ofAdd 1)) : f = g := by
+  apply MonoidHom.ext
+  intro x
+  obtain ⟨k, rfl⟩ := cyclic_eq_generator_zpow_mo1973_15645 x
+  rw [map_zpow, map_zpow, h]
+
+/-- The free product of cyclic groups of orders three and four. -/
+public
+abbrev SpecialPeriods.TriangleGroup :=
+  Monoid.Coprod (Multiplicative (ZMod 3)) (Multiplicative (ZMod 4))
+
+private def SpecialPeriods.triangleGenerator₁ : TriangleGroup :=
+  Monoid.Coprod.inl (Multiplicative.ofAdd (1 : ZMod 3))
+
+private def SpecialPeriods.triangleGenerator₂ : TriangleGroup :=
+  Monoid.Coprod.inr (Multiplicative.ofAdd (1 : ZMod 4))
+
+private def SpecialPeriods.triangleCuspGenerator : TriangleGroup :=
+  (triangleGenerator₁ * triangleGenerator₂)⁻¹
+
+private theorem SpecialPeriods.triangleGenerator₁_order : orderOf triangleGenerator₁ = 3 := by
+  rw [triangleGenerator₁, orderOf_injective _ Monoid.Coprod.inl_injective,
+    orderOf_ofAdd_eq_addOrderOf, ZMod.addOrderOf_one]
+
+private theorem SpecialPeriods.triangleGenerator₂_order : orderOf triangleGenerator₂ = 4 := by
+  rw [triangleGenerator₂, orderOf_injective _ Monoid.Coprod.inr_injective,
+    orderOf_ofAdd_eq_addOrderOf, ZMod.addOrderOf_one]
+
+@[simp]
+private theorem SpecialPeriods.triangleGenerator₁_cube : triangleGenerator₁ ^ 3 = 1 := by
+  simpa only [triangleGenerator₁_order] using pow_orderOf_eq_one triangleGenerator₁
+
+private theorem SpecialPeriods.triangle_generators_generate :
+    Subgroup.closure ({ triangleGenerator₁, triangleGenerator₂ } : Set TriangleGroup) = ⊤ := by
+  apply top_unique
+  intro x hx
+  clear hx
+  induction x using Monoid.Coprod.induction_on with
+  | inl x =>
+    obtain ⟨k, rfl⟩ := cyclic_eq_generator_zpow_mo1973_15645 x
+    rw [map_zpow]
+    exact Subgroup.zpow_mem _ (Subgroup.subset_closure (by simp [triangleGenerator₁])) k
+  | inr x =>
+    obtain ⟨k, rfl⟩ := cyclic_eq_generator_zpow_mo1973_15645 x
+    rw [map_zpow]
+    exact Subgroup.zpow_mem _ (Subgroup.subset_closure (by simp [triangleGenerator₂])) k
+  | mul x y hx hy => exact Subgroup.mul_mem _ hx hy
+
+/-- The triangle-group homomorphism determined by elements of orders three and four. -/
+public
+def SpecialPeriods.triangleLift {G : Type*} [Group G] (a b : G) (ha : a ^ 3 = 1)
+    (hb : b ^ 4 = 1) : TriangleGroup →* G :=
+  Monoid.Coprod.lift (cyclicPowerHom 3 a ha) (cyclicPowerHom 4 b hb)
+
+@[simp]
+private theorem
+    SpecialPeriods.triangleLift_generator₁ {G : Type*} [Group G] (a b : G) (ha : a ^ 3 = 1)
+    (hb : b ^ 4 = 1) : triangleLift a b ha hb triangleGenerator₁ = a := by
+  simp [triangleLift, triangleGenerator₁]
+
+@[simp]
+private theorem
+    SpecialPeriods.triangleLift_generator₂ {G : Type*} [Group G] (a b : G) (ha : a ^ 3 = 1)
+    (hb : b ^ 4 = 1) : triangleLift a b ha hb triangleGenerator₂ = b := by
+  simp [triangleLift, triangleGenerator₂]
+
+@[simp]
+private theorem SpecialPeriods.triangleLift_cusp {G : Type*} [Group G] (a b : G) (ha : a ^ 3 = 1)
+    (hb : b ^ 4 = 1) : triangleLift a b ha hb triangleCuspGenerator = (a * b)⁻¹ := by
+  simp [triangleCuspGenerator]
+
+private theorem SpecialPeriods.triangle_hom_ext {G : Type*} [Group G] {f g : TriangleGroup →* G}
+    (h₁ : f triangleGenerator₁ = g triangleGenerator₁)
+    (h₂ : f triangleGenerator₂ = g triangleGenerator₂) : f = g := by
+  apply Monoid.Coprod.hom_ext
+  · exact cyclic_hom_ext_mo1973_15646 h₁
+  · exact cyclic_hom_ext_mo1973_15646 h₂
+
+private theorem SpecialPeriods.triangle_range {G : Type*} [Group G] (f : TriangleGroup →* G) :
+    f.range = Subgroup.closure ({f triangleGenerator₁, f triangleGenerator₂} : Set G) := by
+  rw [MonoidHom.range_eq_map, ← triangle_generators_generate, MonoidHom.map_closure,
+    Set.image_pair]
+
+/-- The first special-linear lattice generator, of order three. -/
+public
+def SpecialPeriods.triangleLatticeT₁ : SL(4, ℤ) :=
+  ⟨T₁, det_T₁⟩
+
+/-- The second special-linear lattice generator, of order four. -/
+public
+def SpecialPeriods.triangleLatticeT₂ : SL(4, ℤ) :=
+  ⟨T₂, det_T₂⟩
+
+public
+theorem SpecialPeriods.triangleLatticeT₁_cube : triangleLatticeT₁ ^ 3 = 1 :=
+  Subtype.ext T₁_cube
+
+public
+theorem SpecialPeriods.triangleLatticeT₂_fourth : triangleLatticeT₂ ^ 4 = 1 :=
+  Subtype.ext T₂_fourth
+
+/-- The special-linear representation of the triangle group on the lattice. -/
+public
+def SpecialPeriods.triangleLatticeRepresentation : TriangleGroup →* SL(4, ℤ) :=
+  triangleLift triangleLatticeT₁ triangleLatticeT₂ triangleLatticeT₁_cube triangleLatticeT₂_fourth
+
+@[simp]
+private theorem SpecialPeriods.triangleLatticeRepresentation_generator₁ :
+    triangleLatticeRepresentation triangleGenerator₁ = triangleLatticeT₁ :=
+  triangleLift_generator₁ ..
+
+@[simp]
+private theorem SpecialPeriods.triangleLatticeRepresentation_generator₂ :
+    triangleLatticeRepresentation triangleGenerator₂ = triangleLatticeT₂ :=
+  triangleLift_generator₂ ..
+
+private theorem SpecialPeriods.triangleLatticeRepresentation_cusp_matrix :
+    (triangleLatticeRepresentation triangleCuspGenerator : LatticeMatrix) = T₀ := by
+  rw [triangleLatticeRepresentation, triangleLift_cusp]
+  decide
+
+/-- The contragredient automorphism of the special linear lattice group. -/
+public
+def SpecialPeriods.latticeContragredient : SL(4, ℤ) →* SL(4, ℤ)
+    where
+  toFun A := Matrix.SpecialLinearGroup.transpose A⁻¹
+  map_one' := Subtype.ext (by simp [Matrix.SpecialLinearGroup.transpose])
+  map_mul' A
+    B :=
+    Subtype.ext
+      (by
+        change
+          (((A * B)⁻¹ : SL(4, ℤ)) : LatticeMatrix).transpose =
+            ((A⁻¹ : SL(4, ℤ)) : LatticeMatrix).transpose *
+              ((B⁻¹ : SL(4, ℤ)) : LatticeMatrix).transpose
+        simp only [mul_inv_rev, Matrix.SpecialLinearGroup.coe_mul, Matrix.transpose_mul])
+
+/-- The contragredient triangle-group representation on the lattice. -/
+public
+def SpecialPeriods.triangleDualRepresentation : TriangleGroup →* SL(4, ℤ) :=
+  latticeContragredient.comp triangleLatticeRepresentation
+
+private theorem SpecialPeriods.triangleDualRepresentation_generator₁_matrix :
+    (triangleDualRepresentation triangleGenerator₁ : LatticeMatrix) = A₁ := by
+  rw [triangleDualRepresentation, MonoidHom.comp_apply, triangleLatticeRepresentation_generator₁]
+  decide
+
+private theorem SpecialPeriods.triangleDualRepresentation_generator₂_matrix :
+    (triangleDualRepresentation triangleGenerator₂ : LatticeMatrix) = A₂ := by
+  rw [triangleDualRepresentation, MonoidHom.comp_apply, triangleLatticeRepresentation_generator₂]
+  decide
+
+private theorem SpecialPeriods.triangleDualRepresentation_cusp_matrix :
+    (triangleDualRepresentation triangleCuspGenerator : LatticeMatrix) = M₀ := by
+  change
+    (Matrix.adjugate
+          (triangleLatticeRepresentation triangleCuspGenerator : LatticeMatrix)).transpose =
+      M₀
+  rw [triangleLatticeRepresentation_cusp_matrix]
+  decide
+
+private def SpecialPeriods.Triangle.realSLPermutation : SL(2, ℝ) →* Equiv.Perm ℍ :=
+  MulAction.toPermHom (SL(2, ℝ)) ℍ
+
+@[simp]
+private theorem SpecialPeriods.Triangle.realSLPermutation_apply (A : SL(2, ℝ)) (z : ℍ) :
+    realSLPermutation A z = A • z :=
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.Triangle.realSLPermutation_neg_one : realSLPermutation (-1) = 1 := by
+  apply Equiv.ext
+  intro z
+  apply UpperHalfPlane.ext
+  change (((-1 : SL(2, ℝ)) • z : ℍ) : ℂ) = z
+  norm_num [UpperHalfPlane.coe_specialLinearGroup_apply, Matrix.SpecialLinearGroup.coe_neg,
+    Matrix.SpecialLinearGroup.coe_one, Matrix.one_apply]
+
+private def SpecialPeriods.Triangle.generatorOnePerm : Equiv.Perm ℍ :=
+  realSLPermutation generatorOneSL
+
+private def SpecialPeriods.Triangle.generatorTwoPerm : Equiv.Perm ℍ :=
+  realSLPermutation generatorTwoSL
+
+private theorem SpecialPeriods.Triangle.generatorOnePerm_cube : generatorOnePerm ^ 3 = 1 := by
+  rw [generatorOnePerm, ← map_pow, generatorOneSL_cube, realSLPermutation_neg_one]
+
+private theorem SpecialPeriods.Triangle.generatorTwoPerm_fourth : generatorTwoPerm ^ 4 = 1 := by
+  rw [generatorTwoPerm, ← map_pow, generatorTwoSL_fourth, realSLPermutation_neg_one]
+
+private def SpecialPeriods.Triangle.horizontalTranslation : Multiplicative ℝ →* Equiv.Perm ℍ :=
+  (AddAction.toPermHom ℝ ℍ).toMultiplicativeLeft
+
+@[simp]
+private theorem SpecialPeriods.Triangle.horizontalTranslation_apply (t : ℝ) (z : ℍ) :
+    horizontalTranslation (Multiplicative.ofAdd t) z = t +ᵥ z :=
+  rfl
+
+private theorem SpecialPeriods.Triangle.cuspSL_apply (z : ℍ) : cuspSL • z = (-width) +ᵥ z := by
+  apply UpperHalfPlane.ext
+  simp [UpperHalfPlane.coe_specialLinearGroup_apply, coe_cuspSL, add_comm]
+
+private theorem SpecialPeriods.Triangle.cuspSL_permutation_eq_translation :
+    realSLPermutation cuspSL = horizontalTranslation (Multiplicative.ofAdd (-width)) := by
+  apply Equiv.ext
+  exact cuspSL_apply
+
+private def SpecialPeriods.triangleGeometricRepresentation : TriangleGroup →* Equiv.Perm ℍ :=
+  triangleLift Triangle.generatorOnePerm Triangle.generatorTwoPerm Triangle.generatorOnePerm_cube
+    Triangle.generatorTwoPerm_fourth
+
+@[instance_reducible]
+private def SpecialPeriods.triangleGeometricAction : MulAction TriangleGroup ℍ :=
+  MulAction.compHom ℍ triangleGeometricRepresentation
+
+private theorem SpecialPeriods.triangleGeometricAction_smul (g : TriangleGroup) (z : ℍ) :
+    letI := triangleGeometricAction
+    g • z = triangleGeometricRepresentation g z :=
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.triangleGeometricRepresentation_generator₁ :
+    triangleGeometricRepresentation triangleGenerator₁ = Triangle.generatorOnePerm :=
+  triangleLift_generator₁ ..
+
+@[simp]
+private theorem SpecialPeriods.triangleGeometricRepresentation_generator₂ :
+    triangleGeometricRepresentation triangleGenerator₂ = Triangle.generatorTwoPerm :=
+  triangleLift_generator₂ ..
+
+private theorem SpecialPeriods.triangleGeometricRepresentation_generator₁_apply (z : ℍ) :
+    triangleGeometricRepresentation triangleGenerator₁ z = Triangle.generatorOneSL • z := by
+  rw [triangleGeometricRepresentation_generator₁]
+  rfl
+
+private theorem SpecialPeriods.triangleGeometricRepresentation_generator₂_apply (z : ℍ) :
+    triangleGeometricRepresentation triangleGenerator₂ z = Triangle.generatorTwoSL • z := by
+  rw [triangleGeometricRepresentation_generator₂]
+  rfl
+
+private theorem SpecialPeriods.triangleGeometricRepresentation_has_SL_lift (g : TriangleGroup) :
+    ∃ A : SL(2, ℝ), Triangle.realSLPermutation A = triangleGeometricRepresentation g := by
+  have hr : triangleGeometricRepresentation.range ≤ Triangle.realSLPermutation.range := by
+    rw [triangle_range]
+    apply (Subgroup.closure_le _).mpr
+    intro p hp
+    rcases hp with rfl | rfl
+    · exact ⟨Triangle.generatorOneSL, triangleGeometricRepresentation_generator₁.symm⟩
+    · exact ⟨Triangle.generatorTwoSL, triangleGeometricRepresentation_generator₂.symm⟩
+  exact hr ⟨g, rfl⟩
+
+private theorem SpecialPeriods.triangleGeometricRepresentation_cusp :
+    triangleGeometricRepresentation triangleCuspGenerator =
+      Triangle.realSLPermutation Triangle.cuspSL := by
+  rw [triangleGeometricRepresentation, triangleLift_cusp, Triangle.generatorOnePerm,
+    Triangle.generatorTwoPerm, ← map_mul, Triangle.generatorOneSL_mul_generatorTwoSL, ← map_inv]
+  rfl
+
+private theorem SpecialPeriods.triangleGeometricRepresentation_cusp_eq_translation :
+    triangleGeometricRepresentation triangleCuspGenerator =
+      Triangle.horizontalTranslation (Multiplicative.ofAdd (-Triangle.width)) :=
+  triangleGeometricRepresentation_cusp.trans Triangle.cuspSL_permutation_eq_translation
+
+@[simp]
+private theorem SpecialPeriods.triangleGeometricRepresentation_cusp_apply (z : ℍ) :
+    triangleGeometricRepresentation triangleCuspGenerator z = (-Triangle.width) +ᵥ z := by
+  rw [triangleGeometricRepresentation_cusp_eq_translation]
+  rfl
+
+private theorem SpecialPeriods.triangleGeometricRepresentation_cusp_zpow_apply (n : ℤ) (z : ℍ) :
+    triangleGeometricRepresentation (triangleCuspGenerator ^ n) z =
+      (-(n : ℝ) * Triangle.width) +ᵥ z := by
+  rw [map_zpow, triangleGeometricRepresentation_cusp_eq_translation, ← map_zpow, ← ofAdd_zsmul,
+    Triangle.horizontalTranslation_apply]
+  congr 1
+  simp only [zsmul_eq_mul, mul_neg, neg_mul]
+
+private theorem SpecialPeriods.triangleGeometricRepresentation_cusp_zpow_coe (n : ℤ) (z : ℍ) :
+    (triangleGeometricRepresentation (triangleCuspGenerator ^ n) z : ℂ) =
+      z - (n : ℂ) * Triangle.width := by
+  rw [triangleGeometricRepresentation_cusp_zpow_apply, UpperHalfPlane.coe_vadd]
+  push_cast
+  ring
+
+private theorem SpecialPeriods.triangleGeometricRepresentation_cusp_orbit_injective (z : ℍ) :
+    Function.Injective
+      (fun n : ℤ => triangleGeometricRepresentation (triangleCuspGenerator ^ n) z) := by
+  intro m n h
+  simp only [triangleGeometricRepresentation_cusp_zpow_apply] at h
+  have he := (UpperHalfPlane.vadd_right_cancel_iff z).mp h
+  have hmn := neg_injective (mul_right_cancel₀ Triangle.width_ne_zero he)
+  exact_mod_cast hmn
+
+private theorem SpecialPeriods.Triangle.specialLinear_holomorphic (g : SL(2, ℝ)) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z : ℍ => g • z) := by
+  exact UpperHalfPlane.contMDiff_smul (g := Matrix.SpecialLinearGroup.mapGL ℝ g) (by simp)
+
+private def SpecialPeriods.Triangle.centerOne : ℍ :=
+  ⟨SpecialPeriods.rho - 1, by
+    simpa only [Complex.sub_im, Complex.one_im, sub_zero] using SpecialPeriods.rho_im_pos⟩
+
+private def SpecialPeriods.Triangle.centerTwo : ℍ :=
+  ⟨-((width : ℂ) + 1) / 2 + ((width : ℂ) - 1) / 2 * Complex.I,
+    by
+    simp only [Complex.add_im, Complex.div_ofNat_im, Complex.neg_im, Complex.add_im,
+      Complex.ofReal_im, Complex.one_im, Complex.sub_im, Complex.mul_im, Complex.div_ofNat_re,
+      Complex.sub_re, Complex.ofReal_re, Complex.one_re, Complex.I_im, Complex.I_re]
+    linarith [one_lt_width]⟩
+
+@[simp]
+private theorem SpecialPeriods.Triangle.centerOne_val : (centerOne : ℂ) = SpecialPeriods.rho - 1 :=
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.Triangle.centerTwo_val :
+    (centerTwo : ℂ) = -((width : ℂ) + 1) / 2 + ((width : ℂ) - 1) / 2 * Complex.I :=
+  rfl
+
+private theorem SpecialPeriods.Triangle.centerTwo_re : centerTwo.re = -(width + 1) / 2 := by
+  simp [UpperHalfPlane.re, centerTwo]
+
+private theorem SpecialPeriods.Triangle.centerTwo_im : centerTwo.im = (width - 1) / 2 := by
+  simp [UpperHalfPlane.im, centerTwo]
+
+private theorem SpecialPeriods.Triangle.width_complex_sq : (width : ℂ) ^ 2 = 2 * width + 1 := by
+  exact_mod_cast width_sq
+
+private theorem SpecialPeriods.Triangle.generatorOne_coe (z : ℍ) :
+    ((generatorOneSL • z : ℍ) : ℂ) = -1 / ((z : ℂ) + 1) := by
+  rw [UpperHalfPlane.coe_specialLinearGroup_apply]
+  simp [generatorOneSL]
+
+private theorem SpecialPeriods.Triangle.generatorTwo_coe (z : ℍ) :
+    ((generatorTwoSL • z : ℍ) : ℂ) = ((z : ℂ) + (width : ℂ) + 1) / (-(z : ℂ) - width) := by
+  rw [UpperHalfPlane.coe_specialLinearGroup_apply]
+  simp [generatorTwoSL, add_assoc, sub_eq_add_neg]
+
+private theorem SpecialPeriods.Triangle.denominatorOne_ne_zero (z : ℍ) : (z : ℂ) + 1 ≠ 0 := by
+  intro he
+  have hi := congrArg Complex.im he
+  simp only [Complex.add_im, Complex.one_im, Complex.zero_im, add_zero,
+    UpperHalfPlane.coe_im] at hi
+  exact z.im_ne_zero hi
+
+private theorem SpecialPeriods.Triangle.denominatorTwo_ne_zero (z : ℍ) : -(z : ℂ) - width ≠ 0 := by
+  intro he
+  have hi := congrArg Complex.im he
+  simp only [Complex.sub_im, Complex.neg_im, Complex.ofReal_im, sub_zero, Complex.zero_im,
+    neg_eq_zero, UpperHalfPlane.coe_im] at hi
+  exact z.im_ne_zero hi
+
+private theorem SpecialPeriods.Triangle.centerTwo_polynomial :
+    (centerTwo : ℂ) ^ 2 + ((width : ℂ) + 1) * centerTwo + ((width : ℂ) + 1) = 0 := by
+  rw [centerTwo_val]
+  calc
+    _ =
+        -((width : ℂ) + 1) ^ 2 / 4 + ((width : ℂ) - 1) ^ 2 / 4 * Complex.I ^ 2 +
+          ((width : ℂ) + 1) := by ring
+    _ = -((width : ℂ) ^ 2 - 2 * width - 1) / 2 := by rw [Complex.I_sq]; ring
+    _ = 0 := by rw [width_complex_sq]; ring
+
+@[simp]
+private theorem
+    SpecialPeriods.Triangle.generatorOne_fix : generatorOneSL • centerOne = centerOne := by
+  apply UpperHalfPlane.ext
+  rw [generatorOne_coe, centerOne_val]
+  have hd : SpecialPeriods.rho ≠ 0 := by
+    intro he
+    have hi := congrArg Complex.im he
+    simp only [Complex.zero_im] at hi
+    exact (ne_of_gt SpecialPeriods.rho_im_pos) hi
+  simp only [sub_add_cancel]
+  apply (div_eq_iff hd).mpr
+  linear_combination -SpecialPeriods.rho_sq
+
+@[simp]
+private theorem
+    SpecialPeriods.Triangle.generatorTwo_fix : generatorTwoSL • centerTwo = centerTwo := by
+  apply UpperHalfPlane.ext
+  rw [generatorTwo_coe]
+  apply (div_eq_iff (denominatorTwo_ne_zero centerTwo)).mpr
+  linear_combination centerTwo_polynomial
+
+private theorem SpecialPeriods.Triangle.generatorOne_derivative_coefficient :
+    1 / ((centerOne : ℂ) + 1) ^ 2 = -SpecialPeriods.rho := by
+  rw [centerOne_val, sub_add_cancel]
+  apply
+    (div_eq_iff
+        (pow_ne_zero 2
+          (by
+            intro he
+            have hi := congrArg Complex.im he
+            simp only [Complex.zero_im] at hi
+            exact (ne_of_gt SpecialPeriods.rho_im_pos) hi))).mpr
+  linear_combination SpecialPeriods.rho_cube
+
+private theorem SpecialPeriods.Triangle.generatorTwo_denominator_sq :
+    (-(centerTwo : ℂ) - width) ^ 2 = Complex.I := by
+  rw [centerTwo_val]
+  calc
+    _ = ((width : ℂ) - 1) ^ 2 / 4 * (1 + 2 * Complex.I + Complex.I ^ 2) := by ring
+    _ = Complex.I := by
+      rw [Complex.I_sq]
+      have hs : ((width : ℂ) - 1) ^ 2 = 2 := by exact_mod_cast width_sub_one_sq
+      rw [hs]
+      ring
+
+private theorem SpecialPeriods.Triangle.generatorTwo_derivative_coefficient :
+    1 / (-(centerTwo : ℂ) - width) ^ 2 = -Complex.I := by
+  rw [generatorTwo_denominator_sq]
+  simp
+
+private theorem SpecialPeriods.Triangle.generatorOne_multiplier :
+    slMultiplier generatorOneSL centerOne = -SpecialPeriods.rho := by
+  simpa [slMultiplier, slDenom, generatorOneSL] using generatorOne_derivative_coefficient
+
+private theorem SpecialPeriods.Triangle.generatorTwo_multiplier :
+    slMultiplier generatorTwoSL centerTwo = -Complex.I := by
+  simpa [slMultiplier, slDenom, generatorTwoSL, sub_eq_add_neg] using
+    generatorTwo_derivative_coefficient
+
+private theorem SpecialPeriods.Triangle.generatorTwo_hasStrictDerivAt :
+    HasStrictDerivAt (fun z : ℂ => ((generatorTwoSL • UpperHalfPlane.ofComplex z : ℍ) : ℂ))
+      (-Complex.I) (centerTwo : ℂ) := by
+  rw [← generatorTwo_multiplier]
+  exact sl_hasStrictDerivAt_smul _ _
+
+private theorem SpecialPeriods.Triangle.generatorOne_cayley (z : ℍ) :
+    cayleyCoordinate centerOne (generatorOneSL • z) =
+      -SpecialPeriods.rho * cayleyCoordinate centerOne z := by
+  rw [cayleyCoordinate_smul _ _ _ generatorOne_fix, generatorOne_multiplier]
+
+private theorem SpecialPeriods.Triangle.generatorTwo_cayley (z : ℍ) :
+    cayleyCoordinate centerTwo (generatorTwoSL • z) = -Complex.I * cayleyCoordinate centerTwo z :=
+  by rw [cayleyCoordinate_smul _ _ _ generatorTwo_fix, generatorTwo_multiplier]
+
+private theorem SpecialPeriods.Triangle.generatorOne_toDisc (z : ℍ) :
+    toDisc centerOne (generatorOneSL • z) = SpecialPeriods.discRotateThree (toDisc centerOne z) :=
+  by
+  apply Subtype.ext
+  exact generatorOne_cayley z
+
+private theorem SpecialPeriods.Triangle.generatorTwo_toDisc (z : ℍ) :
+    toDisc centerTwo (generatorTwoSL • z) = SpecialPeriods.discRotateFour (toDisc centerTwo z) := by
+  apply Subtype.ext
+  exact generatorTwo_cayley z
+
+private theorem SpecialPeriods.Triangle.generatorOne_pow_toDisc (n : ℕ) (z : ℍ) :
+    toDisc centerOne (generatorOneSL ^ n • z) =
+      SpecialPeriods.discRotateThree^[n] (toDisc centerOne z) := by
+  induction n with
+  | zero => simp
+  | succ n ih =>
+    rw [pow_succ', SemigroupAction.mul_smul, generatorOne_toDisc, ih,
+      Function.iterate_succ_apply']
+
+private theorem SpecialPeriods.Triangle.generatorTwo_pow_toDisc (n : ℕ) (z : ℍ) :
+    toDisc centerTwo (generatorTwoSL ^ n • z) =
+      SpecialPeriods.discRotateFour^[n] (toDisc centerTwo z) := by
+  induction n with
+  | zero => simp
+  | succ n ih =>
+    rw [pow_succ', SemigroupAction.mul_smul, generatorTwo_toDisc, ih,
+      Function.iterate_succ_apply']
+
+private theorem
+    SpecialPeriods.Triangle.generatorOne_pow_fixed_iff (n : ℕ) (hn : 0 < n) (hn' : n < 3)
+    (z : ℍ) : generatorOneSL ^ n • z = z ↔ z = centerOne := by
+  have he :
+    generatorOneSL ^ n • z = z ↔ toDisc centerOne (generatorOneSL ^ n • z) = toDisc centerOne z :=
+    (cayleyBiholomorph centerOne).injective.eq_iff.symm
+  rw [he, generatorOne_pow_toDisc, SpecialPeriods.discRotateThree_iterate_fixed_iff n hn hn']
+  have hc : toDisc centerOne centerOne = SpecialPeriods.discZero := toDisc_center _
+  rw [← hc]
+  exact (cayleyBiholomorph centerOne).injective.eq_iff
+
+private theorem
+    SpecialPeriods.Triangle.generatorTwo_pow_fixed_iff (n : ℕ) (hn : 0 < n) (hn' : n < 4)
+    (z : ℍ) : generatorTwoSL ^ n • z = z ↔ z = centerTwo := by
+  have he :
+    generatorTwoSL ^ n • z = z ↔ toDisc centerTwo (generatorTwoSL ^ n • z) = toDisc centerTwo z :=
+    (cayleyBiholomorph centerTwo).injective.eq_iff.symm
+  rw [he, generatorTwo_pow_toDisc, SpecialPeriods.discRotateFour_iterate_fixed_iff n hn hn']
+  have hc : toDisc centerTwo centerTwo = SpecialPeriods.discZero := toDisc_center _
+  rw [← hc]
+  exact (cayleyBiholomorph centerTwo).injective.eq_iff
+
+private theorem SpecialPeriods.triangleGeometricRepresentation_holomorphic (g : TriangleGroup) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (triangleGeometricRepresentation g : ℍ → ℍ) := by
+  obtain ⟨A, hA⟩ := triangleGeometricRepresentation_has_SL_lift g
+  rw [← hA]
+  exact Triangle.specialLinear_holomorphic A
+
+private def
+    SpecialPeriods.triangleGeometricBiholomorph (g : TriangleGroup) : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) ℍ ℍ ω
+    where
+  toEquiv := triangleGeometricRepresentation g
+  contMDiff_toFun := triangleGeometricRepresentation_holomorphic g
+  contMDiff_invFun := by
+    change ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (((triangleGeometricRepresentation g)⁻¹ : Equiv.Perm ℍ) : ℍ → ℍ)
+    rw [← map_inv]
+    exact triangleGeometricRepresentation_holomorphic g⁻¹
+
+private def SpecialPeriods.Triangle.stripLeft : ℝ :=
+  -(width + 1) / 2
+
+private def SpecialPeriods.Triangle.stripRight : ℝ :=
+  (width - 1) / 2
+
+private theorem SpecialPeriods.Triangle.strip_width : stripRight - stripLeft = width := by
+  unfold stripRight stripLeft
+  ring
+
+private theorem SpecialPeriods.Triangle.stripRight_pos : 0 < stripRight := by
+  unfold stripRight
+  linarith [one_lt_width]
+
+private theorem SpecialPeriods.Triangle.stripRight_sq : stripRight ^ 2 = 1 / 2 := by
+  unfold stripRight
+  nlinarith [width_sub_one_sq]
+
+private theorem SpecialPeriods.Triangle.half_lt_stripRight : 1 / 2 < stripRight := by
+  nlinarith [stripRight_sq, stripRight_pos]
+
+private def SpecialPeriods.Triangle.fordRegion : Set ℍ :=
+  {z | stripLeft ≤ z.re ∧ z.re ≤ stripRight ∧ 1 ≤ ‖(z : ℂ) + 1‖ ∧ 1 ≤ ‖(z : ℂ)‖}
+
+private theorem SpecialPeriods.Triangle.fordRegion_closed : IsClosed fordRegion :=
+  (isClosed_le continuous_const UpperHalfPlane.continuous_re).inter
+    ((isClosed_le UpperHalfPlane.continuous_re continuous_const).inter
+      ((isClosed_le continuous_const
+            ((UpperHalfPlane.continuous_coe.add continuous_const).norm)).inter
+        (isClosed_le continuous_const UpperHalfPlane.continuous_coe.norm)))
+
+private theorem SpecialPeriods.Triangle.mem_fordRegion_of_one_le_im (z : ℍ) (hl : stripLeft ≤ z.re)
+    (hr : z.re ≤ stripRight) (hi : 1 ≤ z.im) : z ∈ fordRegion := by
+  refine ⟨hl, hr, ?_, ?_⟩
+  · have hh := Complex.im_le_norm ((z : ℂ) + 1)
+    simp only [Complex.add_im, Complex.one_im, add_zero, UpperHalfPlane.coe_im] at hh
+    exact hi.trans hh
+  · exact hi.trans (Complex.im_le_norm (z : ℂ))
+
+private theorem SpecialPeriods.Triangle.exists_cusp_translate_in_strip (z : ℍ) :
+    ∃ n : ℤ,
+      stripLeft ≤ ((-(n : ℝ) * width) +ᵥ z).re ∧ ((-(n : ℝ) * width) +ᵥ z).re < stripRight := by
+  let n : ℤ := ⌊(z.re - stripLeft) / width⌋
+  have hlo : (n : ℝ) ≤ (z.re - stripLeft) / width := Int.floor_le _
+  have hhi : (z.re - stripLeft) / width < (n : ℝ) + 1 := Int.lt_floor_add_one _
+  have hlo' := (le_div_iff₀ width_pos).mp hlo
+  have hhi' := (div_lt_iff₀ width_pos).mp hhi
+  refine ⟨n, ?_, ?_⟩ <;> simp only [UpperHalfPlane.vadd_re] <;> nlinarith [strip_width]
+
+private theorem SpecialPeriods.Triangle.sl_im (g : SL(2, ℝ)) (z : ℍ) :
+    (g • z).im = z.im / Complex.normSq (slDenom g z) := by
+  have h := UpperHalfPlane.im_smul_eq_div_normSq (Matrix.SpecialLinearGroup.mapGL ℝ g) z
+  simpa [MulAction.compHom_smul_def, UpperHalfPlane.denom, slDenom] using h
+
+private theorem SpecialPeriods.Triangle.generatorOne_im (z : ℍ) :
+    (generatorOneSL • z).im = z.im / Complex.normSq ((z : ℂ) + 1) := by
+  rw [sl_im]
+  simp [slDenom, generatorOneSL]
+
+private theorem SpecialPeriods.Triangle.generatorOne_sq_im (z : ℍ) :
+    (generatorOneSL ^ 2 • z).im = z.im / Complex.normSq (z : ℂ) := by
+  rw [sl_im]
+  have h0 : (generatorOneSL ^ 2 : SL(2, ℝ)) 1 0 = 1 :=
+    congrArg (fun M : Matrix (Fin 2) (Fin 2) ℝ => M 1 0) coe_generatorOneSL_sq
+  have h1 : (generatorOneSL ^ 2 : SL(2, ℝ)) 1 1 = 0 :=
+    congrArg (fun M : Matrix (Fin 2) (Fin 2) ℝ => M 1 1) coe_generatorOneSL_sq
+  simp [slDenom, h0, h1]
+
+private theorem SpecialPeriods.Triangle.im_lt_generatorOne_im (z : ℍ) (hz : ‖(z : ℂ) + 1‖ < 1) :
+    z.im < (generatorOneSL • z).im := by
+  rw [generatorOne_im]
+  have hd := Complex.normSq_pos.mpr (denominatorOne_ne_zero z)
+  have hs : Complex.normSq ((z : ℂ) + 1) < 1 := by
+    rw [Complex.normSq_eq_norm_sq]
+    nlinarith [norm_nonneg ((z : ℂ) + 1)]
+  apply (lt_div_iff₀ hd).mpr
+  nlinarith [z.im_pos]
+
+private theorem SpecialPeriods.Triangle.im_lt_generatorOne_sq_im (z : ℍ) (hz : ‖(z : ℂ)‖ < 1) :
+    z.im < (generatorOneSL ^ 2 • z).im := by
+  rw [generatorOne_sq_im]
+  have hs : Complex.normSq (z : ℂ) < 1 := by
+    rw [Complex.normSq_eq_norm_sq]
+    nlinarith [norm_nonneg (z : ℂ)]
+  apply (lt_div_iff₀ z.normSq_pos).mpr
+  nlinarith [z.im_pos]
+
+private theorem SpecialPeriods.Triangle.outside_fordRegion_increases_height (z : ℍ)
+    (hl : stripLeft ≤ z.re) (hr : z.re ≤ stripRight) (hz : z ∉ fordRegion) :
+    z.im < (generatorOneSL • z).im ∨ z.im < (generatorOneSL ^ 2 • z).im := by
+  by_cases h : 1 ≤ ‖(z : ℂ) + 1‖
+  · right
+    apply im_lt_generatorOne_sq_im
+    exact lt_of_not_ge (fun hh => hz ⟨hl, hr, h, hh⟩)
+  · exact Or.inl (im_lt_generatorOne_im z (lt_of_not_ge h))
+
+private theorem SpecialPeriods.Triangle.fordRegion_im_lower_bound (z : ℍ) (hz : z ∈ fordRegion) :
+    stripRight ≤ z.im := by
+  obtain ⟨hl, hr, hleft, hright⟩ := hz
+  have hnorm_left : 1 ≤ Complex.normSq ((z : ℂ) + 1) := by
+    rw [Complex.normSq_eq_norm_sq]
+    nlinarith [norm_nonneg ((z : ℂ) + 1)]
+  have hnorm_right : 1 ≤ Complex.normSq (z : ℂ) := by
+    rw [Complex.normSq_eq_norm_sq]
+    nlinarith [norm_nonneg (z : ℂ)]
+  simp only [Complex.normSq_apply, Complex.add_re, Complex.one_re, Complex.add_im, Complex.one_im,
+    add_zero, UpperHalfPlane.coe_re, UpperHalfPlane.coe_im] at hnorm_left hnorm_right
+  by_cases hx : z.re ≤ -(1 / 2)
+  · have hlow : -stripRight ≤ z.re + 1 := by
+      unfold stripLeft stripRight at *
+      linarith
+    have hupp : z.re + 1 ≤ stripRight := by linarith [half_lt_stripRight]
+    have hsq : (z.re + 1) ^ 2 ≤ stripRight ^ 2 := sq_le_sq' hlow hupp
+    nlinarith [stripRight_sq, stripRight_pos, z.im_pos]
+  · have hlow : -stripRight ≤ z.re := by linarith [half_lt_stripRight]
+    have hsq : z.re ^ 2 ≤ stripRight ^ 2 := sq_le_sq' hlow hr
+    nlinarith [stripRight_sq, stripRight_pos, z.im_pos]
+
+private def SpecialPeriods.Triangle.reductionBox (lo hi : ℝ) : Set ℍ :=
+  {z | stripLeft ≤ z.re ∧ z.re ≤ stripRight ∧ lo ≤ z.im ∧ z.im ≤ hi}
+
+private theorem SpecialPeriods.Triangle.coe_reductionBox (lo hi : ℝ) (hlo : 0 < lo) :
+    ((↑) : ℍ → ℂ) '' reductionBox lo hi = (Set.Icc stripLeft stripRight) ×ℂ (Set.Icc lo hi) := by
+  ext z
+  constructor
+  · rintro ⟨w, hw, rfl⟩
+    exact ⟨⟨hw.1, hw.2.1⟩, hw.2.2⟩
+  · rintro ⟨⟨hl, hr⟩, hlow, hupp⟩
+    exact ⟨⟨z, hlo.trans_le hlow⟩, ⟨hl, hr, hlow, hupp⟩, rfl⟩
+
+private theorem SpecialPeriods.Triangle.reductionBox_compact (lo hi : ℝ) (hlo : 0 < lo) :
+    IsCompact (reductionBox lo hi) := by
+  rw [UpperHalfPlane.isEmbedding_coe.isCompact_iff, coe_reductionBox lo hi hlo]
+  exact CompactIccSpace.isCompact_Icc.reProdIm CompactIccSpace.isCompact_Icc
+
+private def SpecialPeriods.Triangle.truncatedFordRegion (hi : ℝ) : Set ℍ :=
+  {z | z ∈ fordRegion ∧ z.im ≤ hi}
+
+private theorem SpecialPeriods.Triangle.truncatedFordRegion_compact (hi : ℝ) :
+    IsCompact (truncatedFordRegion hi) := by
+  refine
+    (reductionBox_compact stripRight hi stripRight_pos).of_isClosed_subset
+      (fordRegion_closed.inter (isClosed_le UpperHalfPlane.continuous_im continuous_const)) ?_
+  intro z hz
+  exact ⟨hz.1.1, hz.1.2.1, fordRegion_im_lower_bound z hz.1, hz.2⟩
+
+private theorem SpecialPeriods.Triangle.cuspSL_zpow_translate (n : ℤ) (z : ℍ) :
+    (cuspSL ^ n : SL(2, ℝ)) • z = (-(n : ℝ) * width) +ᵥ z := by
+  change realSLPermutation (cuspSL ^ n) z = _
+  rw [map_zpow, cuspSL_permutation_eq_translation, ← map_zpow, ← ofAdd_zsmul,
+    horizontalTranslation_apply]
+  congr 1
+  simp only [zsmul_eq_mul, mul_neg, neg_mul]
+
+private theorem
+    SpecialPeriods.Triangle.subgroup_normalize_strip (Γ : Subgroup SL(2, ℝ)) (hc : cuspSL ∈ Γ)
+    (z : ℍ) : ∃ g : Γ, stripLeft ≤ (g • z).re ∧ (g • z).re ≤ stripRight ∧ (g • z).im = z.im := by
+  obtain ⟨n, hl, hr⟩ := exists_cusp_translate_in_strip z
+  let g : Γ := (⟨cuspSL, hc⟩ : Γ) ^ n
+  have he : g • z = (-(n : ℝ) * width) +ᵥ z := by
+    change ((g : SL(2, ℝ)) • z) = _
+    simpa [g] using cuspSL_zpow_translate n z
+  refine ⟨g, ?_, ?_, ?_⟩
+  · simpa only [he] using hl
+  · simpa only [he] using hr.le
+  · rw [he, UpperHalfPlane.vadd_im]
+
+private theorem
+    SpecialPeriods.Triangle.subgroup_exists_fordRegion_representative (Γ : Subgroup SL(2, ℝ))
+    [ProperlyDiscontinuousSMul Γ ℍ] (ha : generatorOneSL ∈ Γ) (hc : cuspSL ∈ Γ) (z : ℍ) :
+    ∃ g : Γ, g • z ∈ fordRegion := by
+  classical
+  by_cases hh : ∃ g : Γ, 1 ≤ (g • z).im
+  · obtain ⟨g, hg⟩ := hh
+    obtain ⟨k, hkl, hkr, hki⟩ := subgroup_normalize_strip Γ hc (g • z)
+    refine ⟨k * g, ?_⟩
+    rw [SemigroupAction.mul_smul]
+    exact mem_fordRegion_of_one_le_im _ hkl hkr (hki ▸ hg)
+  have hbound (g : Γ) : (g • z).im < 1 := lt_of_not_ge (fun hg => hh ⟨g, hg⟩)
+  let candidates : Set Γ := {g | g • z ∈ reductionBox z.im 1}
+  have hfinite : candidates.Finite := by
+    have h :=
+      ProperlyDiscontinuousSMul.finite_disjoint_inter_image (Γ := Γ) (K := { z })
+        isCompact_singleton (reductionBox_compact z.im 1 z.im_pos)
+    simpa only [Set.image_singleton, Set.singleton_inter_nonempty] using h
+  have hnonempty : candidates.Nonempty := by
+    obtain ⟨g, hl, hr, hi⟩ := subgroup_normalize_strip Γ hc z
+    refine ⟨g, hl, hr, ?_, (hbound g).le⟩
+    rw [hi]
+  obtain ⟨g, hg, hmax⟩ := Set.exists_max_image candidates (fun g => (g • z).im) hfinite hnonempty
+  refine ⟨g, ?_⟩
+  by_contra hout
+  obtain ⟨m, hm⟩ : ∃ m : ℕ, (g • z).im < (generatorOneSL ^ m • (g • z)).im := by
+    rcases outside_fordRegion_increases_height (g • z) hg.1 hg.2.1 hout with h | h
+    · exact ⟨1, by simpa using h⟩
+    · exact ⟨2, h⟩
+  let a : Γ := ⟨generatorOneSL, ha⟩
+  let u : Γ := a ^ m * g
+  have hinc : (g • z).im < (u • z).im := by
+    dsimp only [u]
+    rw [SemigroupAction.mul_smul]
+    exact hm
+  obtain ⟨k, hkl, hkr, hki⟩ := subgroup_normalize_strip Γ hc (u • z)
+  let v : Γ := k * u
+  have hvim : (v • z).im = (u • z).im := by simpa only [v, SemigroupAction.mul_smul] using hki
+  have hv : v ∈ candidates := by
+    refine ⟨?_, ?_, ?_, (hbound v).le⟩
+    · simpa only [v, SemigroupAction.mul_smul] using hkl
+    · simpa only [v, SemigroupAction.mul_smul] using hkr
+    · have hbase : z.im ≤ (g • z).im := hg.2.2.1
+      linarith
+  have hle := hmax v hv
+  linarith
+
+private def SpecialPeriods.Triangle.pingPongOne : Set ℍ :=
+  {z | -1 < z.re}
+
+private def SpecialPeriods.Triangle.pingPongTwo : Set ℍ :=
+  {z | z.re < -1}
+
+private theorem SpecialPeriods.Triangle.pingPongOne_nonempty : pingPongOne.Nonempty := by
+  exact ⟨UpperHalfPlane.I, by norm_num [pingPongOne]⟩
+
+private theorem SpecialPeriods.Triangle.pingPongTwo_nonempty : pingPongTwo.Nonempty := by
+  refine ⟨⟨(-2 : ℂ) + Complex.I, by norm_num⟩, ?_⟩
+  norm_num [pingPongTwo]
+
+private theorem SpecialPeriods.Triangle.pingPong_disjoint : Disjoint pingPongOne pingPongTwo := by
+  apply Set.disjoint_left.mpr
+  intro z hz₁ hz₂
+  change -1 < z.re at hz₁
+  change z.re < -1 at hz₂
+  exact lt_asymm hz₁ hz₂
+
+private theorem SpecialPeriods.Triangle.smul_coe_of_matrix_mo1973_15784 (g : SL(2, ℝ))
+    (a b c d : ℝ) (hg : (g : Matrix (Fin 2) (Fin 2) ℝ) = !![a, b; c, d]) (z : ℍ) :
+    ((g • z : ℍ) : ℂ) = ((a : ℂ) * z + b) / ((c : ℂ) * z + d) := by
+  rw [UpperHalfPlane.coe_specialLinearGroup_apply]
+  change
+    (((((g : Matrix (Fin 2) (Fin 2) ℝ) 0 0) : ℂ) * z +
+          (((g : Matrix (Fin 2) (Fin 2) ℝ) 0 1) : ℂ)) /
+        (((((g : Matrix (Fin 2) (Fin 2) ℝ) 1 0) : ℂ)) * z +
+          (((g : Matrix (Fin 2) (Fin 2) ℝ) 1 1) : ℂ))) =
+      _
+  rw [hg]
+  rfl
+
+private theorem SpecialPeriods.Triangle.add_real_ne_zero_mo1973_15785 (z : ℍ) (c : ℝ) :
+    (z : ℂ) + c ≠ 0 := by
+  intro h
+  have hi := congrArg Complex.im h
+  simp only [Complex.add_im, Complex.ofReal_im, add_zero, Complex.zero_im,
+    UpperHalfPlane.coe_im] at hi
+  exact z.im_ne_zero hi
+
+private theorem SpecialPeriods.Triangle.generatorOneSL_smul_coe (z : ℍ) :
+    ((generatorOneSL • z : ℍ) : ℂ) = -((z : ℂ) + 1)⁻¹ := by
+  rw [smul_coe_of_matrix_mo1973_15784 generatorOneSL 0 (-1) 1 1 coe_generatorOneSL]
+  simp [div_eq_mul_inv]
+
+private theorem SpecialPeriods.Triangle.generatorOneSL_sq_smul_coe (z : ℍ) :
+    (((generatorOneSL ^ 2 : SL(2, ℝ)) • z : ℍ) : ℂ) = -1 - (z : ℂ)⁻¹ := by
+  rw [smul_coe_of_matrix_mo1973_15784 (generatorOneSL ^ 2) (-1) (-1) 1 0 coe_generatorOneSL_sq]
+  push_cast
+  field_simp [z.ne_zero]
+  ring
+
+private theorem SpecialPeriods.Triangle.generatorTwoSL_smul_coe (z : ℍ) :
+    ((generatorTwoSL • z : ℍ) : ℂ) = -1 - ((z : ℂ) + (width : ℂ))⁻¹ := by
+  rw [smul_coe_of_matrix_mo1973_15784 generatorTwoSL 1 (width + 1) (-1) (-width)
+      coe_generatorTwoSL]
+  push_cast
+  let u : ℂ := (z : ℂ) + (width : ℂ)
+  have hu : u ≠ 0 := add_real_ne_zero_mo1973_15785 z width
+  calc
+    _ = (u + 1) / (-u) := by dsimp [u]; congr 1 <;> ring
+    _ = -(1 + u⁻¹) := by rw [div_neg, add_div, div_self hu, one_div]
+    _ = -1 - u⁻¹ := by ring
+
+private theorem SpecialPeriods.Triangle.generatorTwoSL_sq_smul_coe (z : ℍ) :
+    (((generatorTwoSL ^ 2 : SL(2, ℝ)) • z : ℍ) : ℂ) =
+      -1 - ((z : ℂ) + (width : ℂ)) / (((width : ℂ) - 1) * z + (width : ℂ)) := by
+  rw [smul_coe_of_matrix_mo1973_15784 (generatorTwoSL ^ 2) (-width) (-2 * width) (width - 1) width
+      coe_generatorTwoSL_sq]
+  have hd : ((width : ℂ) - 1) * (z : ℂ) + (width : ℂ) ≠ 0 := by
+    intro h
+    have hi := congrArg Complex.im h
+    simp only [Complex.add_im, Complex.mul_im, Complex.sub_re, Complex.ofReal_re, Complex.one_re,
+      Complex.sub_im, Complex.ofReal_im, Complex.one_im, sub_zero, MulZeroClass.zero_mul,
+      add_zero, UpperHalfPlane.coe_im] at hi
+    exact (mul_pos (sub_pos.mpr one_lt_width) z.im_pos).ne' hi
+  push_cast
+  rw [eq_sub_iff_add_eq, ← add_div, div_eq_iff hd]
+  ring
+
+private theorem SpecialPeriods.Triangle.coe_generatorTwoSL_cube :
+    ((generatorTwoSL ^ 3 : SL(2, ℝ)) : Matrix (Fin 2) (Fin 2) ℝ) = !![width, width + 1; -1, -1] :=
+  by
+  rw [pow_succ, Matrix.SpecialLinearGroup.coe_mul, coe_generatorTwoSL_sq, coe_generatorTwoSL,
+    Matrix.mul_fin_two]
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp <;> nlinarith [width_sq]
+
+private theorem SpecialPeriods.Triangle.generatorTwoSL_cube_smul_coe (z : ℍ) :
+    (((generatorTwoSL ^ 3 : SL(2, ℝ)) • z : ℍ) : ℂ) = -(width : ℂ) - ((z : ℂ) + 1)⁻¹ := by
+  rw [smul_coe_of_matrix_mo1973_15784 (generatorTwoSL ^ 3) width (width + 1) (-1) (-1)
+      coe_generatorTwoSL_cube]
+  have hd : (z : ℂ) + 1 ≠ 0 := by simpa using add_real_ne_zero_mo1973_15785 z 1
+  push_cast
+  let u : ℂ := (z : ℂ) + 1
+  calc
+    _ = ((width : ℂ) * u + 1) / (-u) := by dsimp [u]; congr 1 <;> ring
+    _ = -((width : ℂ) + u⁻¹) := by rw [div_neg, add_div, mul_div_cancel_right₀ _ hd, one_div]
+    _ = -(width : ℂ) - u⁻¹ := by ring
+
+private theorem SpecialPeriods.Triangle.generatorOne_pingPong :
+    Set.MapsTo (fun z : ℍ => generatorOneSL • z) pingPongTwo pingPongOne := by
+  intro z hz
+  change -1 < (generatorOneSL • z).re
+  change z.re < -1 at hz
+  rw [← UpperHalfPlane.coe_re, generatorOneSL_smul_coe]
+  simp only [Complex.neg_re, Complex.inv_re, Complex.add_re, Complex.one_re,
+    UpperHalfPlane.coe_re]
+  have hden : 0 < Complex.normSq ((z : ℂ) + 1) :=
+    Complex.normSq_pos.mpr (by simpa using add_real_ne_zero_mo1973_15785 z 1)
+  have hn : (z.re + 1) / Complex.normSq ((z : ℂ) + 1) < 0 :=
+    div_neg_of_neg_of_pos (by linarith) hden
+  linarith
+
+private theorem SpecialPeriods.Triangle.generatorOne_sq_pingPong :
+    Set.MapsTo (fun z : ℍ => (generatorOneSL ^ 2 : SL(2, ℝ)) • z) pingPongTwo pingPongOne := by
+  intro z hz
+  change -1 < ((generatorOneSL ^ 2 : SL(2, ℝ)) • z).re
+  change z.re < -1 at hz
+  rw [← UpperHalfPlane.coe_re, generatorOneSL_sq_smul_coe]
+  simp only [Complex.sub_re, Complex.neg_re, Complex.one_re, Complex.inv_re,
+    UpperHalfPlane.coe_re]
+  have hn : z.re / Complex.normSq (z : ℂ) < 0 := div_neg_of_neg_of_pos (by linarith) z.normSq_pos
+  linarith
+
+private theorem SpecialPeriods.Triangle.generatorTwo_pingPong :
+    Set.MapsTo (fun z : ℍ => generatorTwoSL • z) pingPongOne pingPongTwo := by
+  intro z hz
+  change (generatorTwoSL • z).re < -1
+  change -1 < z.re at hz
+  rw [← UpperHalfPlane.coe_re, generatorTwoSL_smul_coe]
+  simp only [Complex.sub_re, Complex.neg_re, Complex.one_re, Complex.inv_re, Complex.add_re,
+    Complex.ofReal_re, UpperHalfPlane.coe_re]
+  have hp : 0 < (z.re + width) / Complex.normSq ((z : ℂ) + (width : ℂ)) :=
+    div_pos (by linarith [one_lt_width])
+      (Complex.normSq_pos.mpr (add_real_ne_zero_mo1973_15785 z width))
+  linarith
+
+private theorem SpecialPeriods.Triangle.generatorTwo_sq_pingPong :
+    Set.MapsTo (fun z : ℍ => (generatorTwoSL ^ 2 : SL(2, ℝ)) • z) pingPongOne pingPongTwo := by
+  intro z hz
+  change ((generatorTwoSL ^ 2 : SL(2, ℝ)) • z).re < -1
+  change -1 < z.re at hz
+  rw [← UpperHalfPlane.coe_re, generatorTwoSL_sq_smul_coe]
+  simp only [Complex.sub_re, Complex.neg_re, Complex.one_re]
+  suffices hpos : 0 < (((z : ℂ) + (width : ℂ)) / (((width : ℂ) - 1) * z + (width : ℂ))).re by
+    linarith
+  let u : ℂ := (z : ℂ) + (width : ℂ)
+  let v : ℂ := ((width : ℂ) - 1) * z + (width : ℂ)
+  have hu : 0 < u.re := by
+    change 0 < z.re + width
+    linarith [one_lt_width]
+  have hv : 0 < v.re := by
+    simp only [v, Complex.add_re, Complex.mul_re, Complex.sub_re, Complex.ofReal_re,
+      Complex.one_re, Complex.sub_im, Complex.ofReal_im, Complex.one_im, sub_zero,
+      MulZeroClass.zero_mul, UpperHalfPlane.coe_re]
+    nlinarith [one_lt_width]
+  have hvi : 0 < v.im := by
+    simp only [v, Complex.add_im, Complex.mul_im, Complex.sub_re, Complex.ofReal_re,
+      Complex.one_re, Complex.sub_im, Complex.ofReal_im, Complex.one_im, sub_zero,
+      MulZeroClass.zero_mul, add_zero, UpperHalfPlane.coe_im]
+    exact mul_pos (sub_pos.mpr one_lt_width) z.im_pos
+  have hui : 0 < u.im := by simpa [u] using z.im_pos
+  have hn : 0 < Complex.normSq v := by
+    apply Complex.normSq_pos.mpr
+    intro h
+    exact hv.ne' (by simpa using congrArg Complex.re h)
+  change 0 < (u / v).re
+  rw [Complex.div_re]
+  exact add_pos (div_pos (mul_pos hu hv) hn) (div_pos (mul_pos hui hvi) hn)
+
+private theorem SpecialPeriods.Triangle.generatorTwo_cube_pingPong :
+    Set.MapsTo (fun z : ℍ => (generatorTwoSL ^ 3 : SL(2, ℝ)) • z) pingPongOne pingPongTwo := by
+  intro z hz
+  change ((generatorTwoSL ^ 3 : SL(2, ℝ)) • z).re < -1
+  change -1 < z.re at hz
+  rw [← UpperHalfPlane.coe_re, generatorTwoSL_cube_smul_coe]
+  simp only [Complex.sub_re, Complex.neg_re, Complex.ofReal_re, Complex.inv_re, Complex.add_re,
+    Complex.one_re, UpperHalfPlane.coe_re]
+  have hp : 0 < (z.re + 1) / Complex.normSq ((z : ℂ) + 1) :=
+    div_pos (by linarith)
+      (Complex.normSq_pos.mpr (by simpa using add_real_ne_zero_mo1973_15785 z 1))
+  linarith [one_lt_width]
+
+private theorem SpecialPeriods.Triangle.generatorOnePerm_pow_apply (n : ℕ) (z : ℍ) :
+    (generatorOnePerm ^ n) z = (generatorOneSL ^ n : SL(2, ℝ)) • z := by
+  rw [generatorOnePerm, ← map_pow, realSLPermutation_apply]
+
+private theorem SpecialPeriods.Triangle.generatorTwoPerm_pow_apply (n : ℕ) (z : ℍ) :
+    (generatorTwoPerm ^ n) z = (generatorTwoSL ^ n : SL(2, ℝ)) • z := by
+  rw [generatorTwoPerm, ← map_pow, realSLPermutation_apply]
+
+private theorem SpecialPeriods.cyclicPowerHom_natCast'_mo1973_15799 {G : Type*} [Group G] (n : ℕ)
+    (a : G) (ha : a ^ n = 1) (m : ℕ) :
+    cyclicPowerHom n a ha (Multiplicative.ofAdd (m : ZMod n)) = a ^ m := by
+  simpa only [Int.cast_natCast, zpow_natCast] using cyclicPowerHom_intCast n a ha (m : ℤ)
+
+private theorem SpecialPeriods.cyclicPowerHom_two'_mo1973_15800 {G : Type*} [Group G] (n : ℕ)
+    (a : G) (ha : a ^ n = 1) :
+    cyclicPowerHom n a ha (Multiplicative.ofAdd (2 : ZMod n)) = a ^ 2 := by
+  simpa only [Nat.cast_ofNat] using cyclicPowerHom_natCast'_mo1973_15799 n a ha 2
+
+private theorem SpecialPeriods.cyclicPowerHom_three'_mo1973_15801 {G : Type*} [Group G] (n : ℕ)
+    (a : G) (ha : a ^ n = 1) :
+    cyclicPowerHom n a ha (Multiplicative.ofAdd (3 : ZMod n)) = a ^ 3 := by
+  simpa only [Nat.cast_ofNat] using cyclicPowerHom_natCast'_mo1973_15799 n a ha 3
+
+private theorem
+    SpecialPeriods.triangleLift_injective_of_pingPong {G α : Type*} [Group G] [MulAction G α]
+    (a b : G) (ha : a ^ 3 = 1) (hb : b ^ 4 = 1) (X Y : Set α) (hXY : Disjoint X Y)
+    (hX : X.Nonempty) (hY : Y.Nonempty) (ha₁ : Set.MapsTo (fun z => a • z) Y X)
+    (ha₂ : Set.MapsTo (fun z => a ^ 2 • z) Y X) (hb₁ : Set.MapsTo (fun z => b • z) X Y)
+    (hb₂ : Set.MapsTo (fun z => b ^ 2 • z) X Y) (hb₃ : Set.MapsTo (fun z => b ^ 3 • z) X Y) :
+    Function.Injective (triangleLift a b ha hb) := by
+  let H : Bool → Type := fun i => cond i (Multiplicative (ZMod 4)) (Multiplicative (ZMod 3))
+  let : ∀ i, Group (H i) :=
+    Bool.rec (inferInstance : Group (Multiplicative (ZMod 3)))
+      (inferInstance : Group (Multiplicative (ZMod 4)))
+  let f : ∀ i, H i →* G := fun i =>
+    match i with
+    | false => cyclicPowerHom 3 a ha
+    | true => cyclicPowerHom 4 b hb
+  let toI : TriangleGroup →* Monoid.CoprodI H :=
+    Monoid.Coprod.lift (Monoid.CoprodI.of (M := H) (i := Bool.false))
+      (Monoid.CoprodI.of (M := H) (i := Bool.true))
+  let fromI : Monoid.CoprodI H →* TriangleGroup :=
+    Monoid.CoprodI.lift fun i =>
+      match i with
+      | false => Monoid.Coprod.inl
+      | true => Monoid.Coprod.inr
+  have hleft : fromI.comp toI = MonoidHom.id TriangleGroup := by
+    apply triangle_hom_ext
+    · simp [toI, fromI, triangleGenerator₁]
+    · simp [toI, fromI, triangleGenerator₂]
+  have htoI : Function.Injective toI := by
+    apply Function.LeftInverse.injective (g := fromI)
+    intro z
+    exact DFunLike.congr_fun hleft z
+  have hrepresentation : triangleLift a b ha hb = (Monoid.CoprodI.lift f).comp toI := by
+    apply triangle_hom_ext
+    · simp only [triangleLift_generator₁, MonoidHom.coe_comp, Function.comp_apply]
+      exact (cyclicPowerHom_one 3 a ha).symm
+    · simp only [triangleLift_generator₂, MonoidHom.coe_comp, Function.comp_apply]
+      exact (cyclicPowerHom_one 4 b hb).symm
+  rw [hrepresentation, MonoidHom.coe_comp]
+  apply Function.Injective.comp _ htoI
+  let U : Bool → Set α := fun i => cond i Y X
+  apply Monoid.CoprodI.lift_injective_of_ping_pong f _ U
+  · intro i
+    cases i
+    · exact hX
+    · exact hY
+  · intro i j hij
+    cases i <;> cases j
+    · exact (hij rfl).elim
+    · exact hXY
+    · exact hXY.symm
+    · exact (hij rfl).elim
+  · intro i j hij g hg
+    cases i <;> cases j
+    · exact (hij rfl).elim
+    · change cyclicPowerHom 3 a ha g • Y ⊆ X
+      have hc : g = Multiplicative.ofAdd (1 : ZMod 3) ∨ g = Multiplicative.ofAdd (2 : ZMod 3) := by
+        exact
+          (by decide :
+              ∀ x : Multiplicative (ZMod 3),
+                x ≠ 1 → x = Multiplicative.ofAdd 1 ∨ x = Multiplicative.ofAdd 2)
+            g hg
+      rcases hc with rfl | rfl
+      · rw [cyclicPowerHom_one]
+        exact Set.smul_set_subset_iff.mpr (fun _ hz => ha₁ hz)
+      · rw [cyclicPowerHom_two'_mo1973_15800 3 a ha]
+        exact Set.smul_set_subset_iff.mpr (fun _ hz => ha₂ hz)
+    · change cyclicPowerHom 4 b hb g • X ⊆ Y
+      have hc :
+        g = Multiplicative.ofAdd (1 : ZMod 4) ∨
+          g = Multiplicative.ofAdd (2 : ZMod 4) ∨ g = Multiplicative.ofAdd (3 : ZMod 4) := by
+        exact
+          (by decide :
+              ∀ x : Multiplicative (ZMod 4),
+                x ≠ 1 →
+                  x = Multiplicative.ofAdd 1 ∨
+                    x = Multiplicative.ofAdd 2 ∨ x = Multiplicative.ofAdd 3)
+            g hg
+      rcases hc with rfl | rfl | rfl
+      · rw [cyclicPowerHom_one]
+        exact Set.smul_set_subset_iff.mpr (fun _ hz => hb₁ hz)
+      · rw [cyclicPowerHom_two'_mo1973_15800 4 b hb]
+        exact Set.smul_set_subset_iff.mpr (fun _ hz => hb₂ hz)
+      · rw [cyclicPowerHom_three'_mo1973_15801 4 b hb]
+        exact Set.smul_set_subset_iff.mpr (fun _ hz => hb₃ hz)
+    · exact (hij rfl).elim
+  · right
+    refine ⟨Bool.false, ?_⟩
+    change 3 ≤ Cardinal.mk (Multiplicative (ZMod 3))
+    simp
+
+private theorem SpecialPeriods.triangleGeometricRepresentation_injective :
+    Function.Injective triangleGeometricRepresentation := by
+  apply
+    triangleLift_injective_of_pingPong Triangle.generatorOnePerm Triangle.generatorTwoPerm
+      Triangle.generatorOnePerm_cube Triangle.generatorTwoPerm_fourth Triangle.pingPongOne
+      Triangle.pingPongTwo Triangle.pingPong_disjoint Triangle.pingPongOne_nonempty
+      Triangle.pingPongTwo_nonempty
+  · intro z hz
+    exact Triangle.generatorOne_pingPong hz
+  · intro z hz
+    change (Triangle.generatorOnePerm ^ 2) z ∈ Triangle.pingPongOne
+    rw [Triangle.generatorOnePerm_pow_apply]
+    exact Triangle.generatorOne_sq_pingPong hz
+  · intro z hz
+    exact Triangle.generatorTwo_pingPong hz
+  · intro z hz
+    change (Triangle.generatorTwoPerm ^ 2) z ∈ Triangle.pingPongTwo
+    rw [Triangle.generatorTwoPerm_pow_apply]
+    exact Triangle.generatorTwo_sq_pingPong hz
+  · intro z hz
+    change (Triangle.generatorTwoPerm ^ 3) z ∈ Triangle.pingPongTwo
+    rw [Triangle.generatorTwoPerm_pow_apply]
+    exact Triangle.generatorTwo_cube_pingPong hz
+
+private theorem SpecialPeriods.finiteTest_mixed_word_mo1973_15805 {G α : Type*} [Group G]
+    [MulAction G α] {H : Bool → Type*} [∀ i, Group (H i)] (f : ∀ i, H i →* G) (U : Bool → Set α)
+    (hpp : Pairwise fun i j => ∀ h : H i, h ≠ 1 → f i h • U j ⊆ U i)
+    (hcard : 3 ≤ Cardinal.mk (H Bool.false)) (xB : α) (hxB : xB ∈ U Bool.true)
+    (w : Monoid.CoprodI.NeWord H Bool.false Bool.true) :
+    ∃ h : H Bool.false,
+      (f Bool.false h * Monoid.CoprodI.lift f w.prod * (f Bool.false h)⁻¹) • xB ∈ U Bool.false := by
+  obtain ⟨h, hn1, hnh⟩ := Cardinal.exists_ne_ne_of_three_le hcard 1 w.head⁻¹
+  have hnot1 : h * w.head ≠ 1 := by
+    rw [← div_inv_eq_mul]
+    exact div_ne_one_of_ne hnh
+  let w' : Monoid.CoprodI.NeWord H Bool.false Bool.false :=
+    Monoid.CoprodI.NeWord.append (w.mulHead h hnot1) (by decide)
+      (Monoid.CoprodI.NeWord.singleton h⁻¹ (inv_ne_one.mpr hn1))
+  have hw' : Monoid.CoprodI.lift f w'.prod • xB ∈ U Bool.false :=
+    Set.smul_set_subset_iff.mp (Monoid.CoprodI.lift_word_ping_pong f U hpp w' (by decide)) hxB
+  refine ⟨h, ?_⟩
+  simpa [w'] using hw'
+
+private theorem SpecialPeriods.finiteTest_coprodI_mo1973_15806 {G α : Type*} [Group G]
+    [MulAction G α] {H : Bool → Type*} [∀ i, Group (H i)] (f : ∀ i, H i →* G) (U : Bool → Set α)
+    (hdisj : Disjoint (U Bool.false) (U Bool.true))
+    (hpp : Pairwise fun i j => ∀ h : H i, h ≠ 1 → f i h • U j ⊆ U i)
+    (hcard : 3 ≤ Cardinal.mk (H Bool.false)) (xA xB : α) (hxA : xA ∈ U Bool.false)
+    (hxB : xB ∈ U Bool.true) (w : Monoid.CoprodI H)
+    (hA : Monoid.CoprodI.lift f w • xA ∈ U Bool.false)
+    (hB :
+      ∀ h : H Bool.false,
+        (f Bool.false h * Monoid.CoprodI.lift f w * (f Bool.false h)⁻¹) • xB ∈ U Bool.true ∧
+          (f Bool.false h * (Monoid.CoprodI.lift f w)⁻¹ * (f Bool.false h)⁻¹) • xB ∈
+            U Bool.true) :
+    Monoid.CoprodI.lift f w = 1 := by
+  classical
+  let r := Monoid.CoprodI.Word.equiv (M := H) w
+  have hr : r.prod = w := (Monoid.CoprodI.Word.equiv (M := H)).symm_apply_apply w
+  by_cases hr0 : r = Monoid.CoprodI.Word.empty
+  · have hw1 : w = 1 := by rw [← hr, hr0, Monoid.CoprodI.Word.prod_empty]
+    simp [hw1]
+  obtain ⟨i, j, v, hv⟩ := Monoid.CoprodI.NeWord.of_word r hr0
+  have hvprod : v.prod = w := by
+    change v.toWord.prod = w
+    rw [hv]
+    exact hr
+  rw [← hvprod] at hA hB ⊢
+  suffices False by contradiction
+  cases i <;> cases j
+  · have hm : Monoid.CoprodI.lift f v.prod • xB ∈ U Bool.false :=
+      Set.smul_set_subset_iff.mp (Monoid.CoprodI.lift_word_ping_pong f U hpp v (by decide)) hxB
+    have hn : Monoid.CoprodI.lift f v.prod • xB ∈ U Bool.true := by
+      simpa only [map_one, one_mul, inv_one, mul_one] using (hB 1).1
+    exact hdisj.le_bot ⟨hm, hn⟩
+  · obtain ⟨h, hm⟩ := finiteTest_mixed_word_mo1973_15805 f U hpp hcard xB hxB v
+    exact hdisj.le_bot ⟨hm, (hB h).1⟩
+  · obtain ⟨h, hm⟩ := finiteTest_mixed_word_mo1973_15805 f U hpp hcard xB hxB v.inv
+    have hm' :
+      (f Bool.false h * (Monoid.CoprodI.lift f v.prod)⁻¹ * (f Bool.false h)⁻¹) • xB ∈
+        U Bool.false := by simpa only [Monoid.CoprodI.NeWord.inv_prod, map_inv] using hm
+    exact hdisj.le_bot ⟨hm', (hB h).2⟩
+  · have hm : Monoid.CoprodI.lift f v.prod • xA ∈ U Bool.true :=
+      Set.smul_set_subset_iff.mp (Monoid.CoprodI.lift_word_ping_pong f U hpp v (by decide)) hxA
+    exact hdisj.le_bot ⟨hA, hm⟩
+
+private theorem SpecialPeriods.finiteTest_cyclicPowerHom_two_mo1973_15807 {G : Type*} [Group G]
+    (n : ℕ) (a : G) (ha : a ^ n = 1) :
+    cyclicPowerHom n a ha (Multiplicative.ofAdd (2 : ZMod n)) = a ^ 2 := by
+  simpa only [Int.cast_ofNat, zpow_ofNat] using cyclicPowerHom_intCast n a ha (2 : ℤ)
+
+private theorem SpecialPeriods.finiteTest_cyclicPowerHom_three_mo1973_15808 {G : Type*} [Group G]
+    (n : ℕ) (a : G) (ha : a ^ n = 1) :
+    cyclicPowerHom n a ha (Multiplicative.ofAdd (3 : ZMod n)) = a ^ 3 := by
+  simpa only [Int.cast_ofNat, zpow_ofNat] using cyclicPowerHom_intCast n a ha (3 : ℤ)
+
+private theorem SpecialPeriods.triangleLift_eq_one_of_pingPong_finite_tests {G α : Type*} [Group G]
+    [MulAction G α] (a b : G) (ha : a ^ 3 = 1) (hb : b ^ 4 = 1) (X Y : Set α) (hXY : Disjoint X Y)
+    (ha₁ : Set.MapsTo (fun z => a • z) Y X) (ha₂ : Set.MapsTo (fun z => a ^ 2 • z) Y X)
+    (hb₁ : Set.MapsTo (fun z => b • z) X Y) (hb₂ : Set.MapsTo (fun z => b ^ 2 • z) X Y)
+    (hb₃ : Set.MapsTo (fun z => b ^ 3 • z) X Y) (xA xB : α) (hxA : xA ∈ X) (hxB : xB ∈ Y)
+    (w : TriangleGroup) (hA : triangleLift a b ha hb w • xA ∈ X)
+    (hB :
+      ∀ h : Multiplicative (ZMod 3),
+        (cyclicPowerHom 3 a ha h * triangleLift a b ha hb w * (cyclicPowerHom 3 a ha h)⁻¹) • xB ∈
+            Y ∧
+          (cyclicPowerHom 3 a ha h * (triangleLift a b ha hb w)⁻¹ * (cyclicPowerHom 3 a ha h)⁻¹) •
+              xB ∈
+            Y) :
+    triangleLift a b ha hb w = 1 := by
+  let H : Bool → Type := fun i => cond i (Multiplicative (ZMod 4)) (Multiplicative (ZMod 3))
+  let : ∀ i, Group (H i) :=
+    Bool.rec (inferInstance : Group (Multiplicative (ZMod 3)))
+      (inferInstance : Group (Multiplicative (ZMod 4)))
+  let f : ∀ i, H i →* G := fun i =>
+    match i with
+    | false => cyclicPowerHom 3 a ha
+    | true => cyclicPowerHom 4 b hb
+  let toI : TriangleGroup →* Monoid.CoprodI H :=
+    Monoid.Coprod.lift (Monoid.CoprodI.of (M := H) (i := Bool.false))
+      (Monoid.CoprodI.of (M := H) (i := Bool.true))
+  have hrepresentation : triangleLift a b ha hb = (Monoid.CoprodI.lift f).comp toI := by
+    apply triangle_hom_ext
+    · simp only [triangleLift_generator₁, MonoidHom.coe_comp, Function.comp_apply]
+      exact (cyclicPowerHom_one 3 a ha).symm
+    · simp only [triangleLift_generator₂, MonoidHom.coe_comp, Function.comp_apply]
+      exact (cyclicPowerHom_one 4 b hb).symm
+  let U : Bool → Set α := fun i => cond i Y X
+  have hpp : Pairwise fun i j => ∀ h : H i, h ≠ 1 → f i h • U j ⊆ U i := by
+    intro i j hij g hg
+    cases i <;> cases j
+    · exact (hij rfl).elim
+    · change cyclicPowerHom 3 a ha g • Y ⊆ X
+      have hc : g = Multiplicative.ofAdd (1 : ZMod 3) ∨ g = Multiplicative.ofAdd (2 : ZMod 3) := by
+        exact
+          (by decide :
+              ∀ x : Multiplicative (ZMod 3),
+                x ≠ 1 → x = Multiplicative.ofAdd 1 ∨ x = Multiplicative.ofAdd 2)
+            g hg
+      rcases hc with rfl | rfl
+      · rw [cyclicPowerHom_one]
+        exact Set.smul_set_subset_iff.mpr (fun _ hz => ha₁ hz)
+      · rw [finiteTest_cyclicPowerHom_two_mo1973_15807 3 a ha]
+        exact Set.smul_set_subset_iff.mpr (fun _ hz => ha₂ hz)
+    · change cyclicPowerHom 4 b hb g • X ⊆ Y
+      have hc :
+        g = Multiplicative.ofAdd (1 : ZMod 4) ∨
+          g = Multiplicative.ofAdd (2 : ZMod 4) ∨ g = Multiplicative.ofAdd (3 : ZMod 4) := by
+        exact
+          (by decide :
+              ∀ x : Multiplicative (ZMod 4),
+                x ≠ 1 →
+                  x = Multiplicative.ofAdd 1 ∨
+                    x = Multiplicative.ofAdd 2 ∨ x = Multiplicative.ofAdd 3)
+            g hg
+      rcases hc with rfl | rfl | rfl
+      · rw [cyclicPowerHom_one]
+        exact Set.smul_set_subset_iff.mpr (fun _ hz => hb₁ hz)
+      · rw [finiteTest_cyclicPowerHom_two_mo1973_15807 4 b hb]
+        exact Set.smul_set_subset_iff.mpr (fun _ hz => hb₂ hz)
+      · rw [finiteTest_cyclicPowerHom_three_mo1973_15808 4 b hb]
+        exact Set.smul_set_subset_iff.mpr (fun _ hz => hb₃ hz)
+    · exact (hij rfl).elim
+  have hcard : 3 ≤ Cardinal.mk (H Bool.false) := by
+    change 3 ≤ Cardinal.mk (Multiplicative (ZMod 3))
+    simp
+  have heval : triangleLift a b ha hb w = Monoid.CoprodI.lift f (toI w) :=
+    DFunLike.congr_fun hrepresentation w
+  rw [heval] at hA hB ⊢
+  exact finiteTest_coprodI_mo1973_15806 f U hXY hpp hcard xA xB hxA hxB (toI w) hA hB
+
+private def SpecialPeriods.Triangle.matrixGroup : Subgroup (SL(2, ℝ)) :=
+  Subgroup.closure ({ generatorOneSL, generatorTwoSL } : Set (SL(2, ℝ)))
+
+private theorem
+    SpecialPeriods.Triangle.generatorOneSL_mem_matrixGroup : generatorOneSL ∈ matrixGroup :=
+  Subgroup.subset_closure (by simp)
+
+private theorem
+    SpecialPeriods.Triangle.generatorTwoSL_mem_matrixGroup : generatorTwoSL ∈ matrixGroup :=
+  Subgroup.subset_closure (by simp)
+
+private theorem SpecialPeriods.Triangle.cuspSL_mem_matrixGroup : cuspSL ∈ matrixGroup := by
+  have h :=
+    matrixGroup.inv_mem
+      (matrixGroup.mul_mem generatorOneSL_mem_matrixGroup generatorTwoSL_mem_matrixGroup)
+  simpa only [generatorOneSL_mul_generatorTwoSL, cuspSL] using h
+
+private theorem
+    SpecialPeriods.Triangle.neg_one_mem_matrixGroup : (-1 : SL(2, ℝ)) ∈ matrixGroup := by
+  have h := matrixGroup.pow_mem generatorOneSL_mem_matrixGroup 3
+  simpa only [generatorOneSL_cube] using h
+
+private theorem SpecialPeriods.Triangle.matrixGroup_map_realSLPermutation :
+    matrixGroup.map realSLPermutation = SpecialPeriods.triangleGeometricRepresentation.range := by
+  rw [matrixGroup, MonoidHom.map_closure, Set.image_pair, SpecialPeriods.triangle_range]
+  simp only [SpecialPeriods.triangleGeometricRepresentation_generator₁,
+    SpecialPeriods.triangleGeometricRepresentation_generator₂, generatorOnePerm, generatorTwoPerm]
+
+private theorem SpecialPeriods.Triangle.matrixGroup_permutation_lift (A : SL(2, ℝ))
+    (hA : A ∈ matrixGroup) :
+    ∃ w : SpecialPeriods.TriangleGroup,
+      SpecialPeriods.triangleGeometricRepresentation w = realSLPermutation A := by
+  have hm : realSLPermutation A ∈ matrixGroup.map realSLPermutation := ⟨A, hA, rfl⟩
+  rw [matrixGroup_map_realSLPermutation] at hm
+  exact hm
+
+private theorem SpecialPeriods.Triangle.triangleGeometricRepresentation_matrixGroup_lift
+    (w : SpecialPeriods.TriangleGroup) :
+    ∃ A : matrixGroup, realSLPermutation A = SpecialPeriods.triangleGeometricRepresentation w := by
+  have hm :
+    SpecialPeriods.triangleGeometricRepresentation w ∈
+      SpecialPeriods.triangleGeometricRepresentation.range :=
+    ⟨w, rfl⟩
+  rw [← matrixGroup_map_realSLPermutation] at hm
+  obtain ⟨A, hA, hA'⟩ := hm
+  exact ⟨⟨A, hA⟩, hA'⟩
+
+private theorem SpecialPeriods.Triangle.realSLPermutation_eq_one_iff (A : SL(2, ℝ)) :
+    realSLPermutation A = 1 ↔ A = 1 ∨ A = -1 := by
+  constructor
+  · intro h
+    have hfix : ∀ z : ℍ, Matrix.SpecialLinearGroup.mapGL ℝ A • z = z := by
+      intro z
+      change realSLPermutation A z = z
+      rw [h]
+      rfl
+    have hc := UpperHalfPlane.forall_smul_eq_self_iff_mem_center.mp hfix
+    obtain ⟨r, hr⟩ := Matrix.GeneralLinearGroup.mem_center_iff_val_mem_range_scalar.mp hc
+    change Matrix.scalar (Fin 2) r = (A : Matrix (Fin 2) (Fin 2) ℝ) at hr
+    have hs : r ^ 2 = 1 := by
+      simpa [Matrix.scalar_apply, Matrix.det_diagonal] using congrArg Matrix.det hr
+    rcases sq_eq_one_iff.mp hs with h₁ | hneg
+    · left
+      apply Subtype.ext
+      simpa [h₁] using hr.symm
+    · right
+      apply Subtype.ext
+      simpa only [hneg, map_neg, map_one, Matrix.SpecialLinearGroup.coe_neg,
+        Matrix.SpecialLinearGroup.coe_one] using hr.symm
+  · rintro (rfl | rfl)
+    · exact map_one realSLPermutation
+    · exact realSLPermutation_neg_one
+
+private def SpecialPeriods.Triangle.testPointOne : ℍ :=
+  UpperHalfPlane.I
+
+private def SpecialPeriods.Triangle.testPointTwo : ℍ :=
+  ⟨(-2 : ℂ) + Complex.I, by norm_num⟩
+
+private theorem SpecialPeriods.Triangle.testPointOne_mem : testPointOne ∈ pingPongOne := by
+  norm_num [testPointOne, pingPongOne]
+
+private theorem SpecialPeriods.Triangle.testPointTwo_mem : testPointTwo ∈ pingPongTwo := by
+  norm_num [testPointTwo, pingPongTwo]
+
+private theorem SpecialPeriods.Triangle.pingPongOne_isOpen : IsOpen pingPongOne :=
+  isOpen_lt continuous_const UpperHalfPlane.continuous_re
+
+private theorem SpecialPeriods.Triangle.pingPongTwo_isOpen : IsOpen pingPongTwo :=
+  isOpen_lt UpperHalfPlane.continuous_re continuous_const
+
+private def SpecialPeriods.Triangle.cyclicConjugator (h : Multiplicative (ZMod 3)) : SL(2, ℝ) :=
+  generatorOneSL ^ h.toAdd.val
+
+private theorem SpecialPeriods.Triangle.cyclicConjugator_permutation (h : Multiplicative (ZMod 3)) :
+    realSLPermutation (cyclicConjugator h) =
+      SpecialPeriods.cyclicPowerHom 3 generatorOnePerm generatorOnePerm_cube h := by
+  rw [cyclicConjugator, map_pow]
+  change generatorOnePerm ^ h.toAdd.val = _
+  simpa only [Int.cast_natCast, ZMod.natCast_zmod_val, ofAdd_toAdd, zpow_natCast] using
+    (SpecialPeriods.cyclicPowerHom_intCast 3 generatorOnePerm generatorOnePerm_cube
+        (h.toAdd.val : ℤ)).symm
+
+private def SpecialPeriods.Triangle.identityTestSet : Set (SL(2, ℝ)) :=
+  {A |
+    0 < A 0 0 ∧
+      A • testPointOne ∈ pingPongOne ∧
+        ∀ h : Multiplicative (ZMod 3),
+          (cyclicConjugator h * A * (cyclicConjugator h)⁻¹) • testPointTwo ∈ pingPongTwo ∧
+            (cyclicConjugator h * A⁻¹ * (cyclicConjugator h)⁻¹) • testPointTwo ∈ pingPongTwo}
+
+private theorem SpecialPeriods.Triangle.identityTestSet_isOpen : IsOpen identityTestSet := by
+  have he : IsOpen {A : SL(2, ℝ) | 0 < A 0 0} := isOpen_lt continuous_const (by fun_prop)
+  have h₁ : IsOpen {A : SL(2, ℝ) | A • testPointOne ∈ pingPongOne} :=
+    pingPongOne_isOpen.preimage (by fun_prop)
+  have h₂ (h : Multiplicative (ZMod 3)) :
+    IsOpen
+      {A : SL(2, ℝ) |
+        (cyclicConjugator h * A * (cyclicConjugator h)⁻¹) • testPointTwo ∈ pingPongTwo ∧
+          (cyclicConjugator h * A⁻¹ * (cyclicConjugator h)⁻¹) • testPointTwo ∈ pingPongTwo} :=
+    (pingPongTwo_isOpen.preimage (by fun_prop)).inter (pingPongTwo_isOpen.preimage (by fun_prop))
+  simpa only [identityTestSet, Set.ofPred_and, Set.ofPred_forall] using
+    he.inter (h₁.inter (isOpen_iInter_of_finite h₂))
+
+private theorem
+    SpecialPeriods.Triangle.one_mem_identityTestSet : (1 : SL(2, ℝ)) ∈ identityTestSet := by
+  refine ⟨?_, ?_, ?_⟩
+  · norm_num [Matrix.SpecialLinearGroup.coe_one, Matrix.one_apply]
+  · simpa using testPointOne_mem
+  · intro h
+    simpa using And.intro testPointTwo_mem testPointTwo_mem
+
+private theorem
+    SpecialPeriods.Triangle.realSLPermutation_eq_one_of_mem_identityTestSet {A : SL(2, ℝ)}
+    (hA : A ∈ matrixGroup) (hT : A ∈ identityTestSet) : realSLPermutation A = 1 := by
+  obtain ⟨w, hw⟩ := matrixGroup_permutation_lift A hA
+  rw [← hw]
+  refine
+    SpecialPeriods.triangleLift_eq_one_of_pingPong_finite_tests generatorOnePerm generatorTwoPerm
+      generatorOnePerm_cube generatorTwoPerm_fourth pingPongOne pingPongTwo pingPong_disjoint ?_
+      ?_ ?_ ?_ ?_ testPointOne testPointTwo testPointOne_mem testPointTwo_mem w ?_ ?_
+  · intro z hz
+    exact generatorOne_pingPong hz
+  · intro z hz
+    change (generatorOnePerm ^ 2) z ∈ pingPongOne
+    rw [generatorOnePerm_pow_apply]
+    exact generatorOne_sq_pingPong hz
+  · intro z hz
+    exact generatorTwo_pingPong hz
+  · intro z hz
+    change (generatorTwoPerm ^ 2) z ∈ pingPongTwo
+    rw [generatorTwoPerm_pow_apply]
+    exact generatorTwo_sq_pingPong hz
+  · intro z hz
+    change (generatorTwoPerm ^ 3) z ∈ pingPongTwo
+    rw [generatorTwoPerm_pow_apply]
+    exact generatorTwo_cube_pingPong hz
+  · change SpecialPeriods.triangleGeometricRepresentation w testPointOne ∈ pingPongOne
+    rw [hw]
+    exact hT.2.1
+  · intro h
+    change
+      (SpecialPeriods.cyclicPowerHom 3 generatorOnePerm generatorOnePerm_cube h *
+                SpecialPeriods.triangleGeometricRepresentation w *
+              (SpecialPeriods.cyclicPowerHom 3 generatorOnePerm generatorOnePerm_cube h)⁻¹)
+            testPointTwo ∈
+          pingPongTwo ∧
+        (SpecialPeriods.cyclicPowerHom 3 generatorOnePerm generatorOnePerm_cube h *
+                (SpecialPeriods.triangleGeometricRepresentation w)⁻¹ *
+              (SpecialPeriods.cyclicPowerHom 3 generatorOnePerm generatorOnePerm_cube h)⁻¹)
+            testPointTwo ∈
+          pingPongTwo
+    rw [hw, ← cyclicConjugator_permutation]
+    have ht := hT.2.2 h
+    change
+      realSLPermutation (cyclicConjugator h * A * (cyclicConjugator h)⁻¹) testPointTwo ∈
+          pingPongTwo ∧
+        realSLPermutation (cyclicConjugator h * A⁻¹ * (cyclicConjugator h)⁻¹) testPointTwo ∈
+          pingPongTwo at ht
+    simpa only [map_mul, map_inv] using ht
+
+private theorem SpecialPeriods.Triangle.eq_one_of_mem_identityTestSet {A : SL(2, ℝ)}
+    (hA : A ∈ matrixGroup) (hT : A ∈ identityTestSet) : A = 1 := by
+  rcases
+    (realSLPermutation_eq_one_iff A).mp
+      (realSLPermutation_eq_one_of_mem_identityTestSet hA hT) with
+    h | h
+  · exact h
+  · have hp := hT.1
+    subst A
+    norm_num [Matrix.SpecialLinearGroup.coe_neg, Matrix.SpecialLinearGroup.coe_one,
+      Matrix.one_apply] at hp
+
+private theorem SpecialPeriods.Triangle.identityTestSet_preimage_matrixGroup :
+    (fun A : matrixGroup => (A : SL(2, ℝ))) ⁻¹' identityTestSet = { 1 } := by
+  ext A
+  constructor
+  · intro h
+    exact Set.mem_singleton_iff.mpr (Subtype.ext (eq_one_of_mem_identityTestSet A.property h))
+  · rintro rfl
+    exact one_mem_identityTestSet
+
+private instance SpecialPeriods.Triangle.matrixGroup_discrete : DiscreteTopology matrixGroup := by
+  apply discreteTopology_of_isOpen_singleton_one
+  rw [← identityTestSet_preimage_matrixGroup]
+  exact identityTestSet_isOpen.preimage continuous_subtype_val
+
+private theorem
+    SpecialPeriods.Triangle.matrixGroup_isClosed : IsClosed (matrixGroup : Set (SL(2, ℝ))) :=
+  Subgroup.isClosed_of_discrete
+
+private instance SpecialPeriods.Triangle.matrixGroup_properlyDiscontinuous :
+    ProperlyDiscontinuousSMul matrixGroup ℍ :=
+  inferInstance
+
+private instance SpecialPeriods.Triangle.matrixGroup_properSMul : ProperSMul matrixGroup ℍ := by
+  have : IsClosed (matrixGroup : Set (SL(2, ℝ))) := matrixGroup_isClosed
+  infer_instance
+
+private theorem
+    SpecialPeriods.Triangle.matrixGroup_isCompact_transporter {K L : Set ℍ} (hK : IsCompact K)
+    (hL : IsCompact L) : IsCompact {g : matrixGroup | (g • K ∩ L).Nonempty} :=
+  ProperSMul.isCompact_setOfPred_inter_nonempty hK hL
+
+private theorem SpecialPeriods.Triangle.matrixGroup_finite_compact_transporter {K L : Set ℍ}
+    (hK : IsCompact K) (hL : IsCompact L) : {g : matrixGroup | (g • K ∩ L).Nonempty}.Finite :=
+  isCompact_iff_finite.mp (matrixGroup_isCompact_transporter hK hL)
+
+private theorem SpecialPeriods.Triangle.matrixGroup_exists_fordRegion_representative (z : ℍ) :
+    ∃ g : matrixGroup, g • z ∈ fordRegion :=
+  subgroup_exists_fordRegion_representative matrixGroup generatorOneSL_mem_matrixGroup
+    cuspSL_mem_matrixGroup z
+
+private theorem SpecialPeriods.triangle_exists_fordRegion_representative (z : ℍ) :
+    ∃ g : TriangleGroup, triangleGeometricRepresentation g z ∈ Triangle.fordRegion := by
+  obtain ⟨A, hA⟩ := Triangle.matrixGroup_exists_fordRegion_representative z
+  obtain ⟨g, hg⟩ := Triangle.matrixGroup_permutation_lift A A.property
+  refine ⟨g, ?_⟩
+  rw [hg]
+  exact hA
+
+private theorem SpecialPeriods.triangle_exists_fordRegion_preimage (z : ℍ) :
+    ∃ w ∈ Triangle.fordRegion, ∃ g : TriangleGroup, triangleGeometricRepresentation g w = z := by
+  obtain ⟨g, hg⟩ := triangle_exists_fordRegion_representative z
+  refine ⟨triangleGeometricRepresentation g z, hg, g⁻¹, ?_⟩
+  rw [map_inv]
+  exact (triangleGeometricRepresentation g).symm_apply_apply z
+
+private theorem SpecialPeriods.triangle_translates_fordRegion_cover :
+    (⋃ g : TriangleGroup, (triangleGeometricRepresentation g) '' Triangle.fordRegion) =
+      Set.univ := by
+  apply Set.eq_univ_of_forall
+  intro z
+  obtain ⟨w, hw, g, hg⟩ := triangle_exists_fordRegion_preimage z
+  exact Set.mem_iUnion.mpr ⟨g, w, hw, hg⟩
+
+private def SpecialPeriods.Triangle.shimizuTranslation (w : ℝ) : SL(2, ℝ) :=
+  ⟨!![1, w; 0, 1], by simp [Matrix.det_fin_two_of]⟩
+
+@[simp]
+private theorem SpecialPeriods.Triangle.coe_shimizuTranslation (w : ℝ) :
+    (shimizuTranslation w : Matrix (Fin 2) (Fin 2) ℝ) = !![1, w; 0, 1] :=
+  rfl
+
+private theorem SpecialPeriods.Triangle.shimizuTranslation_width :
+    shimizuTranslation width = cuspInverseSL :=
+  rfl
+
+private theorem SpecialPeriods.Triangle.shimizu_conjugate_matrix (w : ℝ) (A : SL(2, ℝ)) :
+    ((A * shimizuTranslation w * A⁻¹ : SL(2, ℝ)) : Matrix (Fin 2) (Fin 2) ℝ) =
+      !![1 - w * A 0 0 * A 1 0, w * (A 0 0) ^ 2; -w * (A 1 0) ^ 2, 1 + w * A 0 0 * A 1 0] := by
+  have hdet : A 0 0 * A 1 1 - A 0 1 * A 1 0 = 1 :=
+    (Matrix.det_fin_two A.val).symm.trans A.property
+  simp only [Matrix.SpecialLinearGroup.coe_mul, Matrix.SpecialLinearGroup.coe_inv,
+    coe_shimizuTranslation, Matrix.adjugate_fin_two]
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp [Matrix.mul_apply, Fin.sum_univ_two] <;> nlinarith [hdet]
+
+private def SpecialPeriods.Triangle.shimizuSequence (w : ℝ) (A : SL(2, ℝ)) : ℕ → SL(2, ℝ)
+  | 0 => A
+  | n + 1 => shimizuSequence w A n * shimizuTranslation w * (shimizuSequence w A n)⁻¹
+
+private theorem SpecialPeriods.Triangle.shimizuSequence_mem (Γ : Subgroup (SL(2, ℝ))) (w : ℝ)
+    (A : SL(2, ℝ)) (hT : shimizuTranslation w ∈ Γ) (hA : A ∈ Γ) (n : ℕ) :
+    shimizuSequence w A n ∈ Γ := by
+  induction n with
+  | zero => exact hA
+  | succ n ih => exact Γ.mul_mem (Γ.mul_mem ih hT) (Γ.inv_mem ih)
+
+private theorem SpecialPeriods.Triangle.shimizuSequence_succ_matrix (w : ℝ) (A : SL(2, ℝ)) (n : ℕ) :
+    (shimizuSequence w A (n + 1) : Matrix (Fin 2) (Fin 2) ℝ) =
+      !![1 - w * shimizuSequence w A n 0 0 * shimizuSequence w A n 1 0,
+          w * (shimizuSequence w A n 0 0) ^ 2;
+        -w * (shimizuSequence w A n 1 0) ^ 2,
+          1 + w * shimizuSequence w A n 0 0 * shimizuSequence w A n 1 0] :=
+  shimizu_conjugate_matrix w (shimizuSequence w A n)
+
+private theorem
+    SpecialPeriods.Triangle.shimizuSequence_succ_zero_zero (w : ℝ) (A : SL(2, ℝ)) (n : ℕ) :
+    shimizuSequence w A (n + 1) 0 0 =
+      1 - shimizuSequence w A n 0 0 * (w * shimizuSequence w A n 1 0) := by
+  have h :=
+    congrArg (fun M : Matrix (Fin 2) (Fin 2) ℝ => M 0 0) (shimizuSequence_succ_matrix w A n)
+  simpa only [Matrix.of_apply, Matrix.cons_val_zero, mul_left_comm, mul_assoc] using h
+
+private theorem
+    SpecialPeriods.Triangle.shimizuSequence_succ_zero_one (w : ℝ) (A : SL(2, ℝ)) (n : ℕ) :
+    shimizuSequence w A (n + 1) 0 1 = w * (shimizuSequence w A n 0 0) ^ 2 := by
+  simpa using
+    congrArg (fun M : Matrix (Fin 2) (Fin 2) ℝ => M 0 1) (shimizuSequence_succ_matrix w A n)
+
+private theorem
+    SpecialPeriods.Triangle.shimizuSequence_succ_one_zero (w : ℝ) (A : SL(2, ℝ)) (n : ℕ) :
+    shimizuSequence w A (n + 1) 1 0 = -w * (shimizuSequence w A n 1 0) ^ 2 := by
+  simpa using
+    congrArg (fun M : Matrix (Fin 2) (Fin 2) ℝ => M 1 0) (shimizuSequence_succ_matrix w A n)
+
+private theorem
+    SpecialPeriods.Triangle.shimizuSequence_succ_one_one (w : ℝ) (A : SL(2, ℝ)) (n : ℕ) :
+    shimizuSequence w A (n + 1) 1 1 =
+      1 + shimizuSequence w A n 0 0 * (w * shimizuSequence w A n 1 0) := by
+  have h :=
+    congrArg (fun M : Matrix (Fin 2) (Fin 2) ℝ => M 1 1) (shimizuSequence_succ_matrix w A n)
+  simpa only [Matrix.of_apply, Matrix.cons_val_one, Matrix.cons_val_zero, mul_left_comm,
+    mul_assoc] using h
+
+private theorem
+    SpecialPeriods.Triangle.shimizuSequence_succ_scaled_lower_left (w : ℝ) (A : SL(2, ℝ))
+    (n : ℕ) : w * shimizuSequence w A (n + 1) 1 0 = -(w * shimizuSequence w A n 1 0) ^ 2 := by
+  rw [shimizuSequence_succ_one_zero]
+  ring
+
+private theorem SpecialPeriods.Triangle.shimizuSequence_lower_left_ne_zero (w : ℝ) (A : SL(2, ℝ))
+    (hw : w ≠ 0) (hA : A 1 0 ≠ 0) (n : ℕ) : shimizuSequence w A n 1 0 ≠ 0 := by
+  induction n with
+  | zero => exact hA
+  | succ n ih =>
+    rw [shimizuSequence_succ_one_zero]
+    exact mul_ne_zero (neg_ne_zero.mpr hw) (pow_ne_zero 2 ih)
+
+private theorem SpecialPeriods.Triangle.shimizu_recurrence_abs_le_initial (q : ℕ → ℝ)
+    (hq : ∀ n, q (n + 1) = -(q n) ^ 2) (hsmall : |q 0| ≤ 1) (n : ℕ) : |q n| ≤ |q 0| := by
+  induction n with
+  | zero => exact le_rfl
+  | succ n ih =>
+    rw [hq, abs_neg, abs_pow, pow_two]
+    calc
+      |q n| * |q n| ≤ |q 0| * |q 0| := mul_le_mul ih ih (abs_nonneg _) (abs_nonneg _)
+      _ ≤ |q 0| := by nlinarith [abs_nonneg (q 0)]
+
+private theorem SpecialPeriods.Triangle.shimizu_recurrence_geometric_bound (q : ℕ → ℝ)
+    (hq : ∀ n, q (n + 1) = -(q n) ^ 2) (hsmall : |q 0| ≤ 1) (n : ℕ) : |q n| ≤ |q 0| ^ (n + 1) := by
+  induction n with
+  | zero => simp
+  | succ n ih =>
+    rw [hq, abs_neg, abs_pow, pow_two]
+    calc
+      |q n| * |q n| ≤ |q 0| * |q 0| ^ (n + 1) :=
+        mul_le_mul (shimizu_recurrence_abs_le_initial q hq hsmall n) ih (abs_nonneg _)
+          (abs_nonneg _)
+      _ = |q 0| ^ (n + 1 + 1) := by rw [pow_succ]; ring
+
+private theorem SpecialPeriods.Triangle.shimizu_recurrence_a_bound (q a : ℕ → ℝ)
+    (hq : ∀ n, q (n + 1) = -(q n) ^ 2) (ha : ∀ n, a (n + 1) = 1 - a n * q n) (hsmall : |q 0| < 1)
+    (n : ℕ) : |a n| ≤ (1 + |a 0|) / (1 - |q 0|) := by
+  let M : ℝ := (1 + |a 0|) / (1 - |q 0|)
+  have hd : 0 < 1 - |q 0| := sub_pos.mpr hsmall
+  have hM : 0 ≤ M := div_nonneg (by positivity) hd.le
+  have hM_eq : M * (1 - |q 0|) = 1 + |a 0| := div_mul_cancel₀ _ hd.ne'
+  have hM_step : 1 + M * |q 0| ≤ M := by nlinarith [abs_nonneg (a 0)]
+  change |a n| ≤ M
+  induction n with
+  | zero =>
+    apply (le_div_iff₀ hd).mpr
+    nlinarith [mul_nonneg (abs_nonneg (a 0)) (abs_nonneg (q 0))]
+  | succ n ih =>
+    rw [ha]
+    calc
+      |1 - a n * q n| ≤ |(1 : ℝ)| + |a n * q n| := by
+        simpa only [Real.norm_eq_abs] using norm_sub_le (1 : ℝ) (a n * q n)
+      _ = 1 + |a n| * |q n| := by rw [abs_one, abs_mul]
+      _ ≤ 1 + M * |q 0| :=
+        (add_le_add (le_refl 1)
+          (mul_le_mul ih (shimizu_recurrence_abs_le_initial q hq hsmall.le n) (abs_nonneg _) hM))
+      _ ≤ M := hM_step
+
+private theorem SpecialPeriods.Triangle.shimizu_recurrence_tendsto (q a : ℕ → ℝ)
+    (hq : ∀ n, q (n + 1) = -(q n) ^ 2) (ha : ∀ n, a (n + 1) = 1 - a n * q n)
+    (hsmall : |q 0| < 1) :
+    Filter.Tendsto q Filter.atTop (𝓝 0) ∧ Filter.Tendsto a Filter.atTop (𝓝 1) := by
+  have hpow : Filter.Tendsto (fun n : ℕ => |q 0| ^ (n + 1)) Filter.atTop (𝓝 0) :=
+    (tendsto_pow_atTop_nhds_zero_of_lt_one (abs_nonneg _) hsmall).comp
+      (Filter.tendsto_add_atTop_nat 1)
+  have hqt : Filter.Tendsto q Filter.atTop (𝓝 0) := by
+    apply squeeze_zero_norm (f := q) (fun n => ?_) hpow
+    exact shimizu_recurrence_geometric_bound q hq hsmall.le n
+  let M : ℝ := (1 + |a 0|) / (1 - |q 0|)
+  have hM : 0 ≤ M := div_nonneg (by positivity) (sub_pos.mpr hsmall).le
+  have hprod : Filter.Tendsto (fun n => a n * q n) Filter.atTop (𝓝 0) := by
+    refine
+      squeeze_zero_norm (f := fun n : ℕ => a n * q n) (a := fun n => M * |q 0| ^ (n + 1)) ?_ ?_
+    · intro n
+      rw [Real.norm_eq_abs, abs_mul]
+      exact
+        mul_le_mul (shimizu_recurrence_a_bound q a hq ha hsmall n)
+          (shimizu_recurrence_geometric_bound q hq hsmall.le n) (abs_nonneg _) hM
+    · simpa only [MulZeroClass.mul_zero] using hpow.const_mul M
+  refine ⟨hqt, (Filter.tendsto_add_atTop_iff_nat 1).mp ?_⟩
+  simpa only [ha, sub_zero] using hprod.const_sub 1
+
+private theorem SpecialPeriods.Triangle.shimizuSequence_tendsto_translation (w : ℝ) (A : SL(2, ℝ))
+    (hw : w ≠ 0) (hsmall : |w * A 1 0| < 1) :
+    Filter.Tendsto (shimizuSequence w A) Filter.atTop (𝓝 (shimizuTranslation w)) := by
+  obtain ⟨hq, ha⟩ :=
+    shimizu_recurrence_tendsto (fun n => w * shimizuSequence w A n 1 0)
+      (fun n => shimizuSequence w A n 0 0) (shimizuSequence_succ_scaled_lower_left w A)
+      (shimizuSequence_succ_zero_zero w A) hsmall
+  have hc : Filter.Tendsto (fun n => shimizuSequence w A n 1 0) Filter.atTop (𝓝 (0 : ℝ)) := by
+    simpa [hw] using hq.div_const w
+  have hp :
+    Filter.Tendsto (fun n => shimizuSequence w A n 0 0 * (w * shimizuSequence w A n 1 0))
+      Filter.atTop (𝓝 (0 : ℝ)) := by simpa only [one_mul] using ha.mul hq
+  apply tendsto_subtype_rng.mpr
+  apply tendsto_pi_nhds.mpr
+  intro i
+  apply tendsto_pi_nhds.mpr
+  intro j
+  fin_cases i <;> fin_cases j
+  · change Filter.Tendsto (fun n => shimizuSequence w A n 0 0) Filter.atTop (𝓝 (1 : ℝ))
+    exact ha
+  · change Filter.Tendsto (fun n => shimizuSequence w A n 0 1) Filter.atTop (𝓝 w)
+    apply (Filter.tendsto_add_atTop_iff_nat 1).mp
+    simpa only [shimizuSequence_succ_zero_one, one_pow, mul_one] using (ha.pow 2).const_mul w
+  · change Filter.Tendsto (fun n => shimizuSequence w A n 1 0) Filter.atTop (𝓝 (0 : ℝ))
+    exact hc
+  · change Filter.Tendsto (fun n => shimizuSequence w A n 1 1) Filter.atTop (𝓝 (1 : ℝ))
+    apply (Filter.tendsto_add_atTop_iff_nat 1).mp
+    simpa only [shimizuSequence_succ_one_one, add_zero] using hp.const_add 1
+
+private theorem SpecialPeriods.Triangle.shimizu_leutbecher_scaled (Γ : Subgroup (SL(2, ℝ)))
+    [DiscreteTopology Γ] (w : ℝ) (hw : w ≠ 0) (hT : shimizuTranslation w ∈ Γ) (A : SL(2, ℝ))
+    (hA : A ∈ Γ) (hc : A 1 0 ≠ 0) : 1 ≤ |w * A 1 0| := by
+  by_contra! hsmall
+  let u : ℕ → Γ := fun n => ⟨shimizuSequence w A n, shimizuSequence_mem Γ w A hT hA n⟩
+  let t : Γ := ⟨shimizuTranslation w, hT⟩
+  have ht : Filter.Tendsto u Filter.atTop (𝓝 t) :=
+    tendsto_subtype_rng.mpr (shimizuSequence_tendsto_translation w A hw hsmall)
+  have he : ∀ᶠ n in Filter.atTop, u n = t := by
+    simpa only [nhds_discrete, Filter.tendsto_pure] using ht
+  obtain ⟨n, hn⟩ := he.exists
+  have hzero : shimizuSequence w A n 1 0 = 0 := by
+    have h := congrArg (fun B : Γ => (B : SL(2, ℝ)) 1 0) hn
+    simpa [u, t, shimizuTranslation] using h
+  exact shimizuSequence_lower_left_ne_zero w A hw hc n hzero
+
+private theorem
+    SpecialPeriods.Triangle.shimizu_leutbecher (Γ : Subgroup (SL(2, ℝ))) [DiscreteTopology Γ]
+    (w : ℝ) (hw : 0 < w) (hT : shimizuTranslation w ∈ Γ) (A : SL(2, ℝ)) (hA : A ∈ Γ)
+    (hc : A 1 0 ≠ 0) : 1 / w ≤ |A 1 0| := by
+  apply (div_le_iff₀ hw).mpr
+  simpa only [abs_mul, abs_of_pos hw, mul_comm] using
+    shimizu_leutbecher_scaled Γ w hw.ne' hT A hA hc
+
+private theorem
+    SpecialPeriods.Triangle.matrixGroup_lower_left_bound (A : SL(2, ℝ)) (hA : A ∈ matrixGroup)
+    (hc : A 1 0 ≠ 0) : 1 / width ≤ |A 1 0| := by
+  apply shimizu_leutbecher matrixGroup width width_pos ?_ A hA hc
+  rw [shimizuTranslation_width, ← generatorOneSL_mul_generatorTwoSL]
+  exact matrixGroup.mul_mem generatorOneSL_mem_matrixGroup generatorTwoSL_mem_matrixGroup
+
+private def SpecialPeriods.modularProjectivization : SL(2, ℤ) →* PSL(2, ℤ) :=
+  QuotientGroup.mk' (Subgroup.center (SL(2, ℤ)))
+
+private theorem SpecialPeriods.modular_neg_one_mem_center_mo1973_15869 :
+    (-1 : SL(2, ℤ)) ∈ Subgroup.center (SL(2, ℤ)) := by
+  apply Subgroup.mem_center_iff.mpr
+  intro A
+  apply Subtype.ext
+  change (A : Matrix (Fin 2) (Fin 2) ℤ) * (-1) = (-1) * A
+  simp
+
+private theorem SpecialPeriods.modularProjectivization_neg_one : modularProjectivization (-1) = 1 :=
+  (QuotientGroup.eq_one_iff _).mpr modular_neg_one_mem_center_mo1973_15869
+
+@[simp]
+private theorem SpecialPeriods.modularProjectivization_neg (A : SL(2, ℤ)) :
+    modularProjectivization (-A) = modularProjectivization A := by
+  have hn : (-1 : SL(2, ℤ)) * A = -A := by
+    apply Subtype.ext
+    change (-1 : Matrix (Fin 2) (Fin 2) ℤ) * A = -(A : Matrix (Fin 2) (Fin 2) ℤ)
+    simp
+  rw [← hn, map_mul, modularProjectivization_neg_one, one_mul]
+
+private def SpecialPeriods.triangleModularA : SL(2, ℤ) :=
+  ⟨!![1, -1; 1, 0], by decide⟩
+
+private theorem SpecialPeriods.triangleModularA_eq_T_mul_S :
+    triangleModularA = ModularGroup.T * ModularGroup.S := by decide
+
+private theorem SpecialPeriods.triangleModularA_cube : triangleModularA ^ 3 = -1 := by decide
+
+private theorem SpecialPeriods.modularS_square : ModularGroup.S ^ 2 = -1 := by decide
+
+private theorem SpecialPeriods.triangleModularA_mul_S :
+    triangleModularA * ModularGroup.S = -ModularGroup.T := by decide
+
+private def SpecialPeriods.triangleModularGenerator₁ : PSL(2, ℤ) :=
+  modularProjectivization triangleModularA
+
+private def SpecialPeriods.triangleModularGenerator₂ : PSL(2, ℤ) :=
+  modularProjectivization ModularGroup.S
+
+@[simp]
+private theorem
+    SpecialPeriods.triangleModularGenerator₁_cube : triangleModularGenerator₁ ^ 3 = 1 := by
+  rw [triangleModularGenerator₁, ← map_pow, triangleModularA_cube,
+    modularProjectivization_neg_one]
+
+@[simp]
+private theorem
+    SpecialPeriods.triangleModularGenerator₂_square : triangleModularGenerator₂ ^ 2 = 1 := by
+  rw [triangleModularGenerator₂, ← map_pow, modularS_square, modularProjectivization_neg_one]
+
+private theorem
+    SpecialPeriods.triangleModularGenerator₂_fourth : triangleModularGenerator₂ ^ 4 = 1 := by
+  rw [show 4 = 2 * 2 from rfl, pow_mul, triangleModularGenerator₂_square, one_pow]
+
+private theorem SpecialPeriods.triangleModularGenerator₁_mul_generator₂ :
+    triangleModularGenerator₁ * triangleModularGenerator₂ =
+      modularProjectivization ModularGroup.T := by
+  rw [triangleModularGenerator₁, triangleModularGenerator₂, ← map_mul, triangleModularA_mul_S,
+    modularProjectivization_neg]
+
+private def SpecialPeriods.triangleModularRepresentation : TriangleGroup →* PSL(2, ℤ) :=
+  triangleLift triangleModularGenerator₁ triangleModularGenerator₂ triangleModularGenerator₁_cube
+    triangleModularGenerator₂_fourth
+
+@[simp]
+private theorem SpecialPeriods.triangleModularRepresentation_generator₁ :
+    triangleModularRepresentation triangleGenerator₁ = triangleModularGenerator₁ :=
+  triangleLift_generator₁ ..
+
+@[simp]
+private theorem SpecialPeriods.triangleModularRepresentation_generator₂ :
+    triangleModularRepresentation triangleGenerator₂ = triangleModularGenerator₂ :=
+  triangleLift_generator₂ ..
+
+@[simp]
+private theorem SpecialPeriods.triangleModularRepresentation_cusp :
+    triangleModularRepresentation triangleCuspGenerator =
+      modularProjectivization ModularGroup.T⁻¹ := by
+  rw [triangleModularRepresentation, triangleLift_cusp, triangleModularGenerator₁_mul_generator₂,
+    map_inv]
+
+private theorem SpecialPeriods.modular_center_eq_one_or_neg_one_mo1973_15891 (A : SL(2, ℤ))
+    (hA : A ∈ Subgroup.center (SL(2, ℤ))) : A = 1 ∨ A = -1 := by
+  obtain ⟨r, hr, hrA⟩ := Matrix.SpecialLinearGroup.mem_center_iff.mp hA
+  have hr₂ : r ^ 2 = 1 := by simpa using hr
+  rcases sq_eq_one_iff.mp hr₂ with rfl | rfl
+  · left
+    apply Subtype.ext
+    simpa using hrA.symm
+  · right
+    apply Subtype.ext
+    simpa using hrA.symm
+
+private theorem SpecialPeriods.modular_center_le_permutation_kernel_mo1973_15892 :
+    Subgroup.center (SL(2, ℤ)) ≤ (MulAction.toPermHom (SL(2, ℤ)) ℍ).ker := by
+  intro A hA
+  rcases modular_center_eq_one_or_neg_one_mo1973_15891 A hA with rfl | rfl
+  · exact map_one _
+  · apply Equiv.ext
+    intro z
+    change (-1 : SL(2, ℤ)) • z = z
+    simp
+
+private def SpecialPeriods.modularPSLPermutation : PSL(2, ℤ) →* Equiv.Perm ℍ :=
+  QuotientGroup.lift (Subgroup.center (SL(2, ℤ))) (MulAction.toPermHom (SL(2, ℤ)) ℍ)
+    modular_center_le_permutation_kernel_mo1973_15892
+
+@[simp]
+private theorem SpecialPeriods.modularPSLPermutation_projectivization (A : SL(2, ℤ)) (z : ℍ) :
+    modularPSLPermutation (modularProjectivization A) z = A • z :=
+  rfl
+
+private def SpecialPeriods.triangleModularAction : TriangleGroup →* Equiv.Perm ℍ :=
+  modularPSLPermutation.comp triangleModularRepresentation
+
+@[simp]
+private theorem SpecialPeriods.triangleModularAction_generator₁_apply (z : ℍ) :
+    triangleModularAction triangleGenerator₁ z = triangleModularA • z := by
+  simp [triangleModularAction, triangleModularGenerator₁]
+
+@[simp]
+private theorem SpecialPeriods.triangleModularAction_generator₂_apply (z : ℍ) :
+    triangleModularAction triangleGenerator₂ z = ModularGroup.S • z := by
+  simp [triangleModularAction, triangleModularGenerator₂]
+
+private theorem SpecialPeriods.triangleModularAction_generator₁_coe (z : ℍ) :
+    (triangleModularAction triangleGenerator₁ z : ℂ) = (z - 1) / z := by
+  rw [triangleModularAction_generator₁_apply, UpperHalfPlane.coe_specialLinearGroup_apply]
+  simp [triangleModularA, sub_eq_add_neg]
+
+private theorem SpecialPeriods.triangleModularAction_generator₂_coe (z : ℍ) :
+    (triangleModularAction triangleGenerator₂ z : ℂ) = -1 / z := by
+  rw [triangleModularAction_generator₂_apply, UpperHalfPlane.coe_specialLinearGroup_apply]
+  simp [ModularGroup.S]
+
+@[simp]
+private theorem SpecialPeriods.triangleModularAction_cusp_apply (z : ℍ) :
+    triangleModularAction triangleCuspGenerator z = (-1 : ℝ) +ᵥ z := by
+  change modularPSLPermutation (triangleModularRepresentation triangleCuspGenerator) z = _
+  rw [triangleModularRepresentation_cusp, modularPSLPermutation_projectivization]
+  simpa using UpperHalfPlane.modular_T_zpow_smul z (-1)
+
+private theorem SpecialPeriods.triangleModularAction_cusp_coe (z : ℍ) :
+    (triangleModularAction triangleCuspGenerator z : ℂ) = z - 1 := by
+  simp [sub_eq_add_neg, add_comm]
+
+private theorem SpecialPeriods.neg_triangleModularA_cube : (-triangleModularA) ^ 3 = 1 := by decide
+
+private theorem SpecialPeriods.modularS_fourth : ModularGroup.S ^ 4 = 1 := by decide
+
+private theorem SpecialPeriods.neg_triangleModularA_mul_S :
+    (-triangleModularA) * ModularGroup.S = ModularGroup.T := by decide
+
+private def SpecialPeriods.triangleModularLinearRepresentation : TriangleGroup →* SL(2, ℤ) :=
+  triangleLift (-triangleModularA) ModularGroup.S neg_triangleModularA_cube modularS_fourth
+
+@[simp]
+private theorem SpecialPeriods.triangleModularLinearRepresentation_cusp :
+    triangleModularLinearRepresentation triangleCuspGenerator = ModularGroup.T⁻¹ := by
+  rw [triangleModularLinearRepresentation, triangleLift_cusp, neg_triangleModularA_mul_S]
+
+private theorem SpecialPeriods.equalDiagonalTriangular_pow_succ_mo1973_15916 {R : Type*}
+    [CommSemiring R] (a b : R) (n : ℕ) :
+    (!![a, b; 0, a] : Matrix (Fin 2) (Fin 2) R) ^ (n + 1) =
+      !![a ^ (n + 1), ((n + 1 : ℕ) : R) * a ^ n * b; 0, a ^ (n + 1)] := by
+  induction n with
+  | zero => simp
+  | succ n ih =>
+    rw [pow_succ, ih, Matrix.mul_fin_two]
+    ext i j
+    fin_cases i <;> fin_cases j <;> simp [pow_succ, Nat.cast_add, Nat.cast_one]
+    all_goals ring
+
+private theorem SpecialPeriods.integerTriangular_pow_upper_right_dvd_mo1973_15917 (a b : ℤ)
+    (n : ℕ) : (n : ℤ) ∣ ((!![a, b; 0, a] : Matrix (Fin 2) (Fin 2) ℤ) ^ n) 0 1 := by
+  cases n with
+  | zero => simp
+  | succ n =>
+    rw [equalDiagonalTriangular_pow_succ_mo1973_15916]
+    refine ⟨a ^ n * b, ?_⟩
+    simp [mul_assoc]
+
+private theorem SpecialPeriods.integerMatrix_commute_translation_entries_mo1973_15918
+    (M : Matrix (Fin 2) (Fin 2) ℤ) (h : Commute M !![1, -1; 0, 1]) : M 1 0 = 0 ∧ M 0 0 = M 1 1 := by
+  have h₀ := congrArg (fun N : Matrix (Fin 2) (Fin 2) ℤ => N 0 0) h.eq
+  have h₁ := congrArg (fun N : Matrix (Fin 2) (Fin 2) ℤ => N 0 1) h.eq
+  simp [Matrix.mul_apply, Fin.sum_univ_two] at h₀ h₁
+  constructor <;> linarith
+
+private theorem SpecialPeriods.integerMatrix_translationInverse_pow_exponent
+    (M : Matrix (Fin 2) (Fin 2) ℤ) (n : ℕ) (h : M ^ n = !![1, -1; 0, 1]) : n = 1 := by
+  have hc : Commute M !![1, -1; 0, 1] := by
+    rw [← h]
+    exact Commute.self_pow M n
+  obtain ⟨hc₀, hc₁⟩ := integerMatrix_commute_translation_entries_mo1973_15918 M hc
+  have hM : M = !![M 0 0, M 0 1; 0, M 0 0] := by
+    ext i j
+    fin_cases i <;> fin_cases j <;> simp [hc₀, hc₁]
+  have hd := integerTriangular_pow_upper_right_dvd_mo1973_15917 (M 0 0) (M 0 1) n
+  rw [← hM, h] at hd
+  apply Nat.eq_one_of_dvd_one
+  simpa [Int.natCast_dvd] using hd
+
+private theorem SpecialPeriods.modular_T_inv_pow_exponent (M : SL(2, ℤ)) (n : ℕ)
+    (h : M ^ n = ModularGroup.T⁻¹) : n = 1 := by
+  apply integerMatrix_translationInverse_pow_exponent (M : Matrix (Fin 2) (Fin 2) ℤ) n
+  simpa only [Matrix.SpecialLinearGroup.coe_pow, ModularGroup.coe_T_inv] using
+    congrArg (fun A : SL(2, ℤ) => (A : Matrix (Fin 2) (Fin 2) ℤ)) h
+
+private theorem SpecialPeriods.triangleCuspGenerator_pow_root_exponent (g : TriangleGroup) (n : ℕ)
+    (h : g ^ n = triangleCuspGenerator) : n = 1 := by
+  apply modular_T_inv_pow_exponent (triangleModularLinearRepresentation g) n
+  rw [← map_pow, h, triangleModularLinearRepresentation_cusp]
+
+private theorem SpecialPeriods.triangleCuspGenerator_zpow_root_exponent (g : TriangleGroup) (k : ℤ)
+    (h : g ^ k = triangleCuspGenerator) : k.natAbs = 1 := by
+  cases k with
+  | ofNat n =>
+    apply triangleCuspGenerator_pow_root_exponent g n
+    simpa only [Int.ofNat_eq_natCast, zpow_natCast] using h
+  | negSucc n =>
+    apply triangleCuspGenerator_pow_root_exponent g⁻¹ (n + 1)
+    simpa only [zpow_negSucc, inv_pow] using h
+
+@[simp]
+private theorem SpecialPeriods.Triangle.shimizuTranslation_zero : shimizuTranslation 0 = 1 := by
+  apply Subtype.ext
+  simp [coe_shimizuTranslation, Matrix.one_fin_two]
+
+private theorem SpecialPeriods.Triangle.shimizuTranslation_add (s t : ℝ) :
+    shimizuTranslation (s + t) = shimizuTranslation s * shimizuTranslation t := by
+  apply Subtype.ext
+  simp [Matrix.SpecialLinearGroup.coe_mul, coe_shimizuTranslation, add_comm]
+
+@[simp]
+private theorem SpecialPeriods.Triangle.shimizuTranslation_inv (t : ℝ) :
+    (shimizuTranslation t)⁻¹ = shimizuTranslation (-t) := by
+  apply inv_eq_of_mul_eq_one_right
+  rw [← shimizuTranslation_add, add_neg_cancel, shimizuTranslation_zero]
+
+private def SpecialPeriods.Triangle.shimizuTranslationHom : Multiplicative ℝ →* SL(2, ℝ)
+    where
+  toFun t := shimizuTranslation t.toAdd
+  map_one' := shimizuTranslation_zero
+  map_mul' s t := shimizuTranslation_add s.toAdd t.toAdd
+
+@[simp]
+private theorem SpecialPeriods.Triangle.shimizuTranslationHom_apply (t : ℝ) :
+    shimizuTranslationHom (Multiplicative.ofAdd t) = shimizuTranslation t :=
+  rfl
+
+private theorem SpecialPeriods.Triangle.shimizuTranslation_zpow (t : ℝ) (n : ℤ) :
+    shimizuTranslation t ^ n = shimizuTranslation ((n : ℝ) * t) := by
+  simpa only [← ofAdd_zsmul, shimizuTranslationHom_apply, zsmul_eq_mul] using
+    (map_zpow shimizuTranslationHom (Multiplicative.ofAdd t) n).symm
+
+private theorem SpecialPeriods.Triangle.shimizuTranslation_injective :
+    Function.Injective shimizuTranslation := by
+  intro s t h
+  have he := congrArg (fun A : SL(2, ℝ) => A 0 1) h
+  simpa [shimizuTranslation] using he
+
+private theorem
+    SpecialPeriods.Triangle.shimizuTranslation_continuous : Continuous shimizuTranslation := by
+  apply Topology.IsInducing.subtypeVal.continuous_iff.mpr
+  change Continuous (fun t : ℝ => (!![1, t; 0, 1] : Matrix (Fin 2) (Fin 2) ℝ))
+  apply continuous_matrix
+  intro i j
+  fin_cases i <;> fin_cases j <;>
+    first
+    | exact continuous_const
+    | exact continuous_id
+
+private theorem SpecialPeriods.Triangle.shimizuTranslation_neg_width :
+    shimizuTranslation (-width) = cuspSL := by
+  rw [← shimizuTranslation_inv, shimizuTranslation_width]
+  rfl
+
+private def SpecialPeriods.Triangle.translationSubgroup (Γ : Subgroup (SL(2, ℝ))) : AddSubgroup ℝ
+    where
+  carrier := {t | shimizuTranslation t ∈ Γ}
+  zero_mem' := by
+    change shimizuTranslation 0 ∈ Γ
+    rw [shimizuTranslation_zero]
+    exact Γ.one_mem
+  add_mem' := by
+    intro s t hs ht
+    change shimizuTranslation (s + t) ∈ Γ
+    rw [shimizuTranslation_add]
+    exact Γ.mul_mem hs ht
+  neg_mem' := by
+    intro t ht
+    change shimizuTranslation (-t) ∈ Γ
+    rw [← shimizuTranslation_inv]
+    exact Γ.inv_mem ht
+
+private def SpecialPeriods.Triangle.translationSubgroupMap (Γ : Subgroup (SL(2, ℝ))) :
+    translationSubgroup Γ → Γ := fun t => ⟨shimizuTranslation t, t.property⟩
+
+private theorem SpecialPeriods.Triangle.translationSubgroupMap_injective (Γ : Subgroup (SL(2, ℝ))) :
+    Function.Injective (translationSubgroupMap Γ) := by
+  intro s t h
+  apply Subtype.ext
+  exact shimizuTranslation_injective (congrArg Subtype.val h)
+
+private theorem
+    SpecialPeriods.Triangle.translationSubgroupMap_continuous (Γ : Subgroup (SL(2, ℝ))) :
+    Continuous (translationSubgroupMap Γ) := by
+  apply Topology.IsInducing.subtypeVal.continuous_iff.mpr
+  exact shimizuTranslation_continuous.comp continuous_subtype_val
+
+private instance SpecialPeriods.Triangle.translationSubgroup_discrete (Γ : Subgroup (SL(2, ℝ)))
+    [DiscreteTopology Γ] : DiscreteTopology (translationSubgroup Γ) :=
+  DiscreteTopology.of_continuous_injective (translationSubgroupMap_continuous Γ)
+    (translationSubgroupMap_injective Γ)
+
+private theorem SpecialPeriods.Triangle.translationSubgroup_cyclic (Γ : Subgroup (SL(2, ℝ)))
+    [DiscreteTopology Γ] : ∃ t : ℝ, translationSubgroup Γ = AddSubgroup.zmultiples t := by
+  have hc : IsAddCyclic (translationSubgroup Γ) :=
+    AddSubgroup.discrete_iff_addCyclic.mpr inferInstance
+  obtain ⟨t, ht⟩ :=
+    (AddSubgroup.isAddCyclic_iff_exists_zmultiples_eq_top (translationSubgroup Γ)).mp hc
+  exact ⟨t, ht.symm⟩
+
+private theorem SpecialPeriods.Triangle.width_mem_translationSubgroup_matrixGroup :
+    width ∈ translationSubgroup matrixGroup := by
+  change shimizuTranslation width ∈ matrixGroup
+  rw [shimizuTranslation_width, ← cuspSL_inv]
+  exact matrixGroup.inv_mem cuspSL_mem_matrixGroup
+
+private theorem SpecialPeriods.Triangle.neg_width_mem_translationSubgroup_matrixGroup :
+    -width ∈ translationSubgroup matrixGroup := by
+  change shimizuTranslation (-width) ∈ matrixGroup
+  rw [shimizuTranslation_neg_width]
+  exact cuspSL_mem_matrixGroup
+
+private theorem SpecialPeriods.Triangle.upperTriangular_det (A : SL(2, ℝ)) (hc : A 1 0 = 0) :
+    A 0 0 * A 1 1 = 1 := by
+  have hdet : A 0 0 * A 1 1 - A 0 1 * A 1 0 = 1 :=
+    (Matrix.det_fin_two A.val).symm.trans A.property
+  simpa only [hc, MulZeroClass.mul_zero, sub_zero] using hdet
+
+private theorem SpecialPeriods.Triangle.upperTriangular_zero_zero_ne_zero (A : SL(2, ℝ))
+    (hc : A 1 0 = 0) : A 0 0 ≠ 0 := by
+  intro ha
+  have h := upperTriangular_det A hc
+  simp [ha] at h
+
+private theorem
+    SpecialPeriods.Triangle.upperTriangular_one_one_ne_zero (A : SL(2, ℝ)) (hc : A 1 0 = 0) :
+    A 1 1 ≠ 0 := by
+  intro hd
+  have h := upperTriangular_det A hc
+  simp [hd] at h
+
+private theorem SpecialPeriods.Triangle.upperTriangular_conjugate_translation (A : SL(2, ℝ))
+    (hc : A 1 0 = 0) (t : ℝ) :
+    A * shimizuTranslation t * A⁻¹ = shimizuTranslation (t * (A 0 0) ^ 2) := by
+  apply Subtype.ext
+  rw [shimizu_conjugate_matrix, coe_shimizuTranslation]
+  ext i j
+  fin_cases i <;> fin_cases j <;> simp [hc]
+
+private theorem SpecialPeriods.Triangle.upperTriangular_inverse_lower_left (A : SL(2, ℝ))
+    (hc : A 1 0 = 0) : (A⁻¹ : SL(2, ℝ)) 1 0 = 0 := by
+  change (Matrix.adjugate (A : Matrix (Fin 2) (Fin 2) ℝ)) 1 0 = 0
+  simp [Matrix.adjugate_fin_two, hc]
+
+private theorem SpecialPeriods.Triangle.inverse_upper_left (A : SL(2, ℝ)) :
+    (A⁻¹ : SL(2, ℝ)) 0 0 = A 1 1 := by
+  change (Matrix.adjugate (A : Matrix (Fin 2) (Fin 2) ℝ)) 0 0 = A 1 1
+  simp [Matrix.adjugate_fin_two]
+
+private theorem SpecialPeriods.Triangle.neg_one_mul_realSL_mo1973_15956 (A : SL(2, ℝ)) :
+    (-1 : SL(2, ℝ)) * A = -A := by
+  apply Subtype.ext
+  change (-1 : Matrix (Fin 2) (Fin 2) ℝ) * A = -(A : Matrix (Fin 2) (Fin 2) ℝ)
+  simp
+
+private theorem SpecialPeriods.Triangle.realSLPermutation_neg (A : SL(2, ℝ)) :
+    realSLPermutation (-A) = realSLPermutation A := by
+  rw [← neg_one_mul_realSL_mo1973_15956, map_mul, realSLPermutation_neg_one, one_mul]
+
+private theorem SpecialPeriods.Triangle.realSLPermutation_eq_iff (A B : SL(2, ℝ)) :
+    realSLPermutation A = realSLPermutation B ↔ A = B ∨ A = -B := by
+  constructor
+  · intro h
+    have hk : realSLPermutation (A * B⁻¹) = 1 := by rw [map_mul, map_inv, h, mul_inv_cancel]
+    rcases (realSLPermutation_eq_one_iff _).mp hk with hk | hk
+    · exact Or.inl (mul_inv_eq_one.mp hk)
+    · right
+      have he := congrArg (fun C : SL(2, ℝ) => C * B) hk
+      simpa only [mul_assoc, inv_mul_cancel, mul_one, neg_one_mul_realSL_mo1973_15956] using he
+  · rintro (rfl | rfl)
+    · rfl
+    · exact realSLPermutation_neg B
+
+private theorem SpecialPeriods.Triangle.matrixGroup_of_permutation_mem_range (A : SL(2, ℝ))
+    (h : realSLPermutation A ∈ SpecialPeriods.triangleGeometricRepresentation.range) :
+    A ∈ matrixGroup := by
+  obtain ⟨g, hg⟩ := h
+  obtain ⟨B, hB⟩ := triangleGeometricRepresentation_matrixGroup_lift g
+  rcases (realSLPermutation_eq_iff A B).mp (hg.symm.trans hB.symm) with he | he
+  · rw [he]
+    exact B.property
+  · rw [he, ← neg_one_mul_realSL_mo1973_15956]
+    exact matrixGroup.mul_mem neg_one_mem_matrixGroup B.property
+
+private theorem SpecialPeriods.Triangle.same_permutation_lower_left_zero_iff (A B : SL(2, ℝ))
+    (h : realSLPermutation A = realSLPermutation B) : A 1 0 = 0 ↔ B 1 0 = 0 := by
+  rcases (realSLPermutation_eq_iff A B).mp h with rfl | rfl
+  · rfl
+  · change -(B 1 0) = 0 ↔ B 1 0 = 0
+    exact neg_eq_zero
+
+private theorem SpecialPeriods.Triangle.matrixGroup_translationSubgroup_eq :
+    translationSubgroup matrixGroup = AddSubgroup.zmultiples width := by
+  obtain ⟨t, ht⟩ := translationSubgroup_cyclic matrixGroup
+  have ht_mem : shimizuTranslation t ∈ matrixGroup := by
+    change t ∈ translationSubgroup matrixGroup
+    rw [ht]
+    exact AddSubgroup.mem_zmultiples t
+  have hw := neg_width_mem_translationSubgroup_matrixGroup
+  rw [ht, AddSubgroup.mem_zmultiples_iff] at hw
+  obtain ⟨k, hk⟩ := hw
+  obtain ⟨g, hg⟩ := matrixGroup_permutation_lift (shimizuTranslation t) ht_mem
+  have hroot : g ^ k = SpecialPeriods.triangleCuspGenerator := by
+    apply SpecialPeriods.triangleGeometricRepresentation_injective
+    rw [map_zpow, hg, ← map_zpow, shimizuTranslation_zpow]
+    have hk' : (k : ℝ) * t = -width := by simpa only [zsmul_eq_mul] using hk
+    rw [hk', shimizuTranslation_neg_width]
+    exact SpecialPeriods.triangleGeometricRepresentation_cusp.symm
+  have hk_abs := SpecialPeriods.triangleCuspGenerator_zpow_root_exponent g k hroot
+  have hk_cases : k = 1 ∨ k = -1 := by omega
+  rcases hk_cases with rfl | rfl
+  · have ht' : t = -width := by simpa using hk
+    rw [ht, ht', AddSubgroup.zmultiples_neg]
+  · have ht' : t = width := by simpa using congrArg Neg.neg hk
+    rw [ht, ht']
+
+private theorem SpecialPeriods.Triangle.shimizuTranslation_mem_matrixGroup_iff (t : ℝ) :
+    shimizuTranslation t ∈ matrixGroup ↔ ∃ n : ℤ, t = (n : ℝ) * width := by
+  change t ∈ translationSubgroup matrixGroup ↔ _
+  rw [matrixGroup_translationSubgroup_eq, AddSubgroup.mem_zmultiples_iff]
+  simp only [zsmul_eq_mul, eq_comm]
+
+private theorem SpecialPeriods.Triangle.upperTriangular_square_is_integer_mo1973_15963
+    (A : SL(2, ℝ)) (hA : A ∈ matrixGroup) (hc : A 1 0 = 0) : ∃ n : ℤ, (A 0 0) ^ 2 = (n : ℝ) := by
+  have hT : shimizuTranslation width ∈ matrixGroup := width_mem_translationSubgroup_matrixGroup
+  have hconj := matrixGroup.mul_mem (matrixGroup.mul_mem hA hT) (matrixGroup.inv_mem hA)
+  rw [upperTriangular_conjugate_translation A hc width] at hconj
+  obtain ⟨n, hn⟩ := (shimizuTranslation_mem_matrixGroup_iff _).mp hconj
+  refine ⟨n, mul_left_cancel₀ width_ne_zero ?_⟩
+  simpa only [mul_comm] using hn
+
+private theorem SpecialPeriods.Triangle.matrixGroup_upperTriangular_square_eq_one (A : SL(2, ℝ))
+    (hA : A ∈ matrixGroup) (hc : A 1 0 = 0) : (A 0 0) ^ 2 = 1 := by
+  obtain ⟨m, hm⟩ := upperTriangular_square_is_integer_mo1973_15963 A hA hc
+  obtain ⟨n, hn⟩ :=
+    upperTriangular_square_is_integer_mo1973_15963 A⁻¹ (matrixGroup.inv_mem hA)
+      (upperTriangular_inverse_lower_left A hc)
+  rw [inverse_upper_left] at hn
+  have hmpos : (0 : ℤ) < m := by
+    have hp : (0 : ℝ) < (m : ℝ) := by
+      rw [← hm]
+      exact sq_pos_of_ne_zero (upperTriangular_zero_zero_ne_zero A hc)
+    exact_mod_cast hp
+  have hnpos : (0 : ℤ) < n := by
+    have hp : (0 : ℝ) < (n : ℝ) := by
+      rw [← hn]
+      exact sq_pos_of_ne_zero (upperTriangular_one_one_ne_zero A hc)
+    exact_mod_cast hp
+  have hmn : m * n = 1 := by
+    have he : (m : ℝ) * (n : ℝ) = 1 := by
+      rw [← hm, ← hn, ← mul_pow, upperTriangular_det A hc, one_pow]
+    exact_mod_cast he
+  have hm1 : (1 : ℤ) ≤ m := by omega
+  have hn1 : (1 : ℤ) ≤ n := by omega
+  have hprod : 0 ≤ m * (n - 1) := mul_nonneg hmpos.le (sub_nonneg.mpr hn1)
+  have hm_eq : m = 1 := by nlinarith [hmn]
+  rw [hm, hm_eq, Int.cast_one]
+
+private theorem SpecialPeriods.Triangle.upperTriangular_eq_signed_translation_mo1973_15965
+    (A : SL(2, ℝ)) (hc : A 1 0 = 0) (ha : (A 0 0) ^ 2 = 1) :
+    A = shimizuTranslation (A 0 0 * A 0 1) ∨ A = -shimizuTranslation (A 0 0 * A 0 1) := by
+  have hdet := upperTriangular_det A hc
+  rcases sq_eq_one_iff.mp ha with ha | ha
+  · have hd : A 1 1 = 1 := by simpa [ha] using hdet
+    left
+    apply Subtype.ext
+    ext i j
+    fin_cases i <;> fin_cases j <;> simp [coe_shimizuTranslation, ha, hd, hc]
+  · have hd : A 1 1 = -1 := by rw [ha] at hdet; linarith
+    right
+    apply Subtype.ext
+    ext i j
+    fin_cases i <;> fin_cases j <;> simp [coe_shimizuTranslation, ha, hd, hc]
+
+private theorem SpecialPeriods.Triangle.translation_int_width_eq_cusp_zpow_mo1973_15966 (n : ℤ) :
+    shimizuTranslation ((n : ℝ) * width) = cuspSL ^ (-n) := by
+  rw [← shimizuTranslation_neg_width, shimizuTranslation_zpow]
+  simp
+
+private theorem SpecialPeriods.Triangle.matrixGroup_upperTriangular_iff (A : SL(2, ℝ))
+    (hA : A ∈ matrixGroup) : A 1 0 = 0 ↔ ∃ n : ℤ, A = cuspSL ^ n ∨ A = -(cuspSL ^ n) := by
+  constructor
+  · intro hc
+    have hs :=
+      upperTriangular_eq_signed_translation_mo1973_15965 A hc
+        (matrixGroup_upperTriangular_square_eq_one A hA hc)
+    have ht : shimizuTranslation (A 0 0 * A 0 1) ∈ matrixGroup := by
+      rcases hs with he | he
+      · exact he ▸ hA
+      · have hneg : -A ∈ matrixGroup := by
+          rw [← neg_one_mul_realSL_mo1973_15956]
+          exact matrixGroup.mul_mem neg_one_mem_matrixGroup hA
+        have he' := congrArg (fun B : SL(2, ℝ) => -B) he
+        rw [neg_neg] at he'
+        exact he' ▸ hneg
+    obtain ⟨n, hn⟩ := (shimizuTranslation_mem_matrixGroup_iff _).mp ht
+    refine ⟨-n, ?_⟩
+    simpa only [hn, translation_int_width_eq_cusp_zpow_mo1973_15966] using hs
+  · rintro ⟨n, rfl | rfl⟩
+    · rw [← shimizuTranslation_neg_width, shimizuTranslation_zpow]
+      rfl
+    · change -((cuspSL ^ n) 1 0) = 0
+      rw [← shimizuTranslation_neg_width, shimizuTranslation_zpow]
+      simp [shimizuTranslation]
+
+private theorem SpecialPeriods.Triangle.matrixGroup_upperTriangular_permutation (A : SL(2, ℝ))
+    (hA : A ∈ matrixGroup) (hc : A 1 0 = 0) :
+    ∃ n : ℤ,
+      realSLPermutation A =
+        SpecialPeriods.triangleGeometricRepresentation
+          (SpecialPeriods.triangleCuspGenerator ^ n) := by
+  obtain ⟨n, he | he⟩ := (matrixGroup_upperTriangular_iff A hA).mp hc
+  · refine ⟨n, ?_⟩
+    rw [he, map_zpow, map_zpow, SpecialPeriods.triangleGeometricRepresentation_cusp]
+  · refine ⟨n, ?_⟩
+    rw [he, realSLPermutation_neg, map_zpow, map_zpow,
+      SpecialPeriods.triangleGeometricRepresentation_cusp]
+
+private theorem SpecialPeriods.Triangle.matrixGroup_upperTriangular_smul (A : SL(2, ℝ))
+    (hA : A ∈ matrixGroup) (hc : A 1 0 = 0) : ∃ n : ℤ, ∀ z : ℍ, A • z = (-(n : ℝ) * width) +ᵥ z :=
+  by
+  obtain ⟨n, hn⟩ := matrixGroup_upperTriangular_permutation A hA hc
+  refine ⟨n, fun z => ?_⟩
+  change realSLPermutation A z = _
+  rw [hn, SpecialPeriods.triangleGeometricRepresentation_cusp_zpow_apply]
+
+private theorem SpecialPeriods.Triangle.triangleGeometric_upperTriangular_lift_iff
+    (g : SpecialPeriods.TriangleGroup) (A : SL(2, ℝ))
+    (hA : realSLPermutation A = SpecialPeriods.triangleGeometricRepresentation g) :
+    A 1 0 = 0 ↔ g ∈ Subgroup.zpowers SpecialPeriods.triangleCuspGenerator := by
+  constructor
+  · intro hc
+    have hmem : A ∈ matrixGroup := matrixGroup_of_permutation_mem_range A ⟨g, hA.symm⟩
+    obtain ⟨n, hn⟩ := matrixGroup_upperTriangular_permutation A hmem hc
+    exact
+      Subgroup.mem_zpowers_iff.mpr
+        ⟨n, SpecialPeriods.triangleGeometricRepresentation_injective (hn.symm.trans hA)⟩
+  · intro hg
+    obtain ⟨n, rfl⟩ := Subgroup.mem_zpowers_iff.mp hg
+    have he : realSLPermutation A = realSLPermutation (cuspSL ^ n) := by
+      rw [hA, map_zpow, map_zpow, SpecialPeriods.triangleGeometricRepresentation_cusp]
+    apply (same_permutation_lower_left_zero_iff _ _ he).mpr
+    rw [← shimizuTranslation_neg_width, shimizuTranslation_zpow]
+    rfl
+
+private def SpecialPeriods.Triangle.horodisc (Y : ℝ) : TopologicalSpace.Opens ℍ :=
+  ⟨{z | Y < z.im}, isOpen_lt continuous_const UpperHalfPlane.continuous_im⟩
+
+private theorem SpecialPeriods.Triangle.normSq_slDenom_lower_bound (A : SL(2, ℝ)) (z : ℍ) :
+    (A 1 0) ^ 2 * z.im ^ 2 ≤ Complex.normSq (slDenom A z) := by
+  have he : Complex.normSq (slDenom A z) = (A 1 0 * z.re + A 1 1) ^ 2 + (A 1 0 * z.im) ^ 2 := by
+    simp [slDenom, Complex.normSq_apply, pow_two]
+  rw [he]
+  nlinarith [sq_nonneg (A 1 0 * z.re + A 1 1)]
+
+private theorem SpecialPeriods.Triangle.matrixGroup_nonparabolic_im_bound (A : SL(2, ℝ))
+    (hA : A ∈ matrixGroup) (hc : A 1 0 ≠ 0) (z : ℍ) : (A • z).im ≤ width ^ 2 / z.im := by
+  have hlow := matrixGroup_lower_left_bound A hA hc
+  have hmul : 1 ≤ |A 1 0| * width := (div_le_iff₀ width_pos).mp hlow
+  have hsq : 1 ≤ (A 1 0) ^ 2 * width ^ 2 := by
+    have hs :=
+      sq_le_sq₀ (by norm_num : (0 : ℝ) ≤ 1) (mul_nonneg (abs_nonneg (A 1 0)) width_pos.le) |>.mpr
+        hmul
+    simpa only [one_pow, mul_pow, sq_abs] using hs
+  have hn := normSq_slDenom_lower_bound A z
+  have hden := Complex.normSq_pos.mpr (slDenom_ne_zero A z)
+  rw [sl_im]
+  apply (div_le_iff₀ hden).mpr
+  rw [div_mul_eq_mul_div]
+  apply (le_div_iff₀ z.im_pos).mpr
+  have h₁ := mul_le_mul_of_nonneg_left hn (sq_nonneg width)
+  have h₂ := mul_le_mul_of_nonneg_right hsq (sq_nonneg z.im)
+  nlinarith
+
+private theorem SpecialPeriods.Triangle.matrixGroup_nonparabolic_above_width (A : SL(2, ℝ))
+    (hA : A ∈ matrixGroup) (hc : A 1 0 ≠ 0) (z : ℍ) (hz : width < z.im) : (A • z).im < width := by
+  apply lt_of_le_of_lt (matrixGroup_nonparabolic_im_bound A hA hc z)
+  apply (div_lt_iff₀ z.im_pos).mpr
+  nlinarith [width_pos]
+
+private theorem SpecialPeriods.Triangle.matrixGroup_nonparabolic_disjoint_horodisc (Y : ℝ)
+    (hY : width ≤ Y) (A : SL(2, ℝ)) (hA : A ∈ matrixGroup) (hc : A 1 0 ≠ 0) :
+    Disjoint ((fun z : ℍ => A • z) '' (horodisc Y : Set ℍ)) (horodisc Y) := by
+  apply Set.disjoint_left.mpr
+  rintro w ⟨z, hz, rfl⟩ hw
+  have hlow := matrixGroup_nonparabolic_above_width A hA hc z (hY.trans_lt hz)
+  exact (not_lt_of_ge (le_trans hlow.le hY)) hw
+
+private theorem SpecialPeriods.Triangle.matrixGroup_horodisc_overlap_lower_left_zero (Y : ℝ)
+    (hY : width ≤ Y) (A : SL(2, ℝ)) (hA : A ∈ matrixGroup)
+    (hinter : ((fun z : ℍ => A • z) '' (horodisc Y : Set ℍ) ∩ horodisc Y).Nonempty) : A 1 0 = 0 :=
+  by
+  by_contra hc
+  exact
+    (Set.disjoint_iff_inter_eq_empty.mp
+          (matrixGroup_nonparabolic_disjoint_horodisc Y hY A hA hc)) ▸
+        hinter |>.ne_empty
+      rfl
+
+private theorem
+    SpecialPeriods.Triangle.horodisc_nonempty (Y : ℝ) : (horodisc Y : Set ℍ).Nonempty := by
+  let z : ℍ :=
+    ⟨((Max.max Y 0 + 1 : ℝ) : ℂ) * Complex.I,
+      by
+      simp only [Complex.mul_im, Complex.ofReal_re, Complex.ofReal_im, Complex.I_im, Complex.I_re,
+        mul_one, MulZeroClass.mul_zero, add_zero]
+      linarith [le_max_right Y 0]⟩
+  refine ⟨z, ?_⟩
+  change Y < (((Max.max Y 0 + 1 : ℝ) : ℂ) * Complex.I).im
+  simp only [Complex.mul_im, Complex.ofReal_re, Complex.ofReal_im, Complex.I_im, Complex.I_re,
+    mul_one, MulZeroClass.mul_zero, add_zero]
+  linarith [le_max_left Y 0]
+
+private theorem SpecialPeriods.Triangle.cusp_horodisc_invariant (Y : ℝ)
+    (g : Subgroup.zpowers SpecialPeriods.triangleCuspGenerator) :
+    Set.MapsTo
+      (fun z : ℍ =>
+        SpecialPeriods.triangleGeometricRepresentation (g : SpecialPeriods.TriangleGroup) z)
+      (horodisc Y) (horodisc Y) := by
+  obtain ⟨n, hn⟩ := Subgroup.mem_zpowers_iff.mp g.property
+  intro z hz
+  change
+    Y < (SpecialPeriods.triangleGeometricRepresentation (g : SpecialPeriods.TriangleGroup) z).im
+  rw [← hn, SpecialPeriods.triangleGeometricRepresentation_cusp_zpow_apply,
+    UpperHalfPlane.vadd_im]
+  exact hz
+
+private theorem SpecialPeriods.Triangle.triangle_horodisc_overlap_mem_cusp (Y : ℝ) (hY : width ≤ Y)
+    (g : SpecialPeriods.TriangleGroup)
+    (hinter :
+      ((SpecialPeriods.triangleGeometricRepresentation g) '' (horodisc Y : Set ℍ) ∩
+          horodisc Y).Nonempty) :
+    g ∈ Subgroup.zpowers SpecialPeriods.triangleCuspGenerator := by
+  obtain ⟨A, hA⟩ := triangleGeometricRepresentation_matrixGroup_lift g
+  apply (triangleGeometric_upperTriangular_lift_iff g A hA).mp
+  apply matrixGroup_horodisc_overlap_lower_left_zero Y hY A A.property
+  have he :
+    (fun z : ℍ => (A : SL(2, ℝ)) • z) = SpecialPeriods.triangleGeometricRepresentation g := by
+    funext z
+    change realSLPermutation A z = SpecialPeriods.triangleGeometricRepresentation g z
+    rw [hA]
+  simpa only [he] using hinter
+
+private def SpecialPeriods.Triangle.orbitHeightBound (z : ℍ) : ℝ :=
+  Max.max z.im (width ^ 2 / z.im)
+
+private theorem SpecialPeriods.Triangle.orbitHeightBound_continuous : Continuous orbitHeightBound :=
+  UpperHalfPlane.continuous_im.max
+    (continuous_const.div UpperHalfPlane.continuous_im (fun z => z.im_ne_zero))
+
+private theorem SpecialPeriods.Triangle.matrixGroup_im_le_orbitHeightBound (A : SL(2, ℝ))
+    (hA : A ∈ matrixGroup) (z : ℍ) : (A • z).im ≤ orbitHeightBound z := by
+  by_cases hc : A 1 0 = 0
+  · obtain ⟨n, hn⟩ := matrixGroup_upperTriangular_smul A hA hc
+    rw [hn z, UpperHalfPlane.vadd_im]
+    exact le_max_left _ _
+  · exact (matrixGroup_nonparabolic_im_bound A hA hc z).trans (le_max_right _ _)
+
+private theorem
+    SpecialPeriods.Triangle.triangle_im_le_orbitHeightBound (g : SpecialPeriods.TriangleGroup)
+    (z : ℍ) : (SpecialPeriods.triangleGeometricRepresentation g z).im ≤ orbitHeightBound z := by
+  obtain ⟨A, hA⟩ := triangleGeometricRepresentation_matrixGroup_lift g
+  rw [← hA]
+  exact matrixGroup_im_le_orbitHeightBound A A.property z
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private def SpecialPeriods.triangleMatrixLift (g : TriangleGroup) : Triangle.matrixGroup :=
+  (Triangle.triangleGeometricRepresentation_matrixGroup_lift g).choose
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.triangleMatrixLift_spec (g : TriangleGroup) :
+    Triangle.realSLPermutation (triangleMatrixLift g) = triangleGeometricRepresentation g :=
+  (Triangle.triangleGeometricRepresentation_matrixGroup_lift g).choose_spec
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem
+    SpecialPeriods.triangleMatrixLift_injective : Function.Injective triangleMatrixLift := by
+  intro g h hgh
+  apply triangleGeometricRepresentation_injective
+  rw [← triangleMatrixLift_spec, ← triangleMatrixLift_spec, hgh]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.triangleMatrixLift_smul (g : TriangleGroup) (z : ℍ) :
+    triangleMatrixLift g • z = g • z := by
+  exact congrArg (fun f : Equiv.Perm ℍ => f z) (triangleMatrixLift_spec g)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.triangleGeometricAction_properlyDiscontinuous :
+    ProperlyDiscontinuousSMul TriangleGroup ℍ where
+  finite_disjoint_inter_image {K L} hK
+    hL := by
+    have hf := Triangle.matrixGroup_finite_compact_transporter hK hL
+    apply (hf.preimage triangleMatrixLift_injective.injOn).subset
+    rintro g ⟨y, ⟨x, hx, hxy⟩, hy⟩
+    exact ⟨y, ⟨x, hx, (triangleMatrixLift_smul g x).trans hxy⟩, hy⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem
+    SpecialPeriods.triangleGeometricAction_continuous : ContinuousConstSMul TriangleGroup ℍ
+    where continuous_const_smul g := (triangleGeometricRepresentation_holomorphic g).continuous
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+attribute [local instance] SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangle_isOfFinOrder_of_fixed (g : TriangleGroup) (z : ℍ)
+    (hg : triangleGeometricRepresentation g z = z) : IsOfFinOrder g :=
+  FreeActionLocus.isOfFinOrder_of_smul_eq TriangleGroup ℍ g z hg
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+attribute [local instance] SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.triangleRegularLocus : Set ℍ :=
+  FreeActionLocus.locus TriangleGroup ℍ
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+attribute [local instance] SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.mem_triangleRegularLocus_iff (z : ℍ) :
+    z ∈ triangleRegularLocus ↔
+      ∀ g : TriangleGroup, triangleGeometricRepresentation g z = z → g = 1 :=
+  Iff.rfl
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+attribute [local instance] SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangleRegularLocus_invariant (g : TriangleGroup) (z : ℍ) :
+    triangleGeometricRepresentation g z ∈ triangleRegularLocus ↔ z ∈ triangleRegularLocus :=
+  FreeActionLocus.smul_mem_locus_iff TriangleGroup ℍ g z
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+attribute [local instance] SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.triangleRegularDomain : TopologicalSpace.Opens ℍ :=
+  FreeActionLocus.opens TriangleGroup ℍ
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+attribute [local instance] SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private abbrev SpecialPeriods.TriangleRegularPoint :=
+  triangleRegularDomain
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+attribute [local instance] SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private instance SpecialPeriods.triangleRegularPoint_locallyCompact :
+    LocallyCompactSpace TriangleRegularPoint :=
+  triangleRegularDomain.isOpen.locallyCompactSpace
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+attribute [local instance] SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private instance
+    SpecialPeriods.triangleRegularAction : MulAction TriangleGroup TriangleRegularPoint :=
+  FreeActionLocus.mulAction TriangleGroup ℍ
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+attribute [local instance] SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private instance SpecialPeriods.triangleRegularAction_free :
+    IsCancelSMul TriangleGroup TriangleRegularPoint :=
+  FreeActionLocus.isCancelSMul TriangleGroup ℍ
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+attribute [local instance] SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private instance SpecialPeriods.triangleRegularAction_continuous :
+    ContinuousConstSMul TriangleGroup TriangleRegularPoint :=
+  FreeActionLocus.continuousConstSMul TriangleGroup ℍ
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+attribute [local instance] SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private instance SpecialPeriods.triangleRegularAction_properlyDiscontinuous :
+    ProperlyDiscontinuousSMul TriangleGroup TriangleRegularPoint :=
+  FreeActionLocus.properlyDiscontinuousSMul TriangleGroup ℍ
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+attribute [local instance] SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangleRegularAction_holomorphic (g : TriangleGroup) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z : TriangleRegularPoint => g • z) :=
+  FreeActionLocus.smul_contMDiff TriangleGroup ℍ ℂ ω triangleGeometricRepresentation_holomorphic g
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+attribute [local instance] SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private abbrev SpecialPeriods.TriangleRegularQuotient :=
+  Quotient (MulAction.orbitRel TriangleGroup TriangleRegularPoint)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+attribute [local instance] SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def
+    SpecialPeriods.triangleRegularProject : TriangleRegularPoint → TriangleRegularQuotient :=
+  Quotient.mk _
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+attribute [local instance] SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangleRegularProject_surjective :
+    Function.Surjective triangleRegularProject :=
+  Quotient.mk_surjective
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+attribute [local instance] SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangleRegularProject_covering :
+    IsQuotientCoveringMap triangleRegularProject TriangleGroup :=
+  isQuotientCoveringMap_quotientMk_of_properlyDiscontinuousSMul
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+attribute [local instance] SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+@[instance_reducible]
+private def
+    SpecialPeriods.triangleRegularQuotientChartedSpace : ChartedSpace ℂ TriangleRegularQuotient :=
+  CoveringQuotient.chartedSpace (E := ℂ) triangleRegularProject_covering
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+attribute [local instance] SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangleRegularQuotient_isManifold :
+    letI := triangleRegularQuotientChartedSpace
+    IsManifold 𝓘(ℂ) ω TriangleRegularQuotient :=
+  CoveringQuotient.isManifold triangleRegularProject_covering ω triangleRegularAction_holomorphic
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+attribute [local instance] SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangleRegularProject_isLocalDiffeomorph :
+    letI := triangleRegularQuotientChartedSpace
+    IsLocalDiffeomorph 𝓘(ℂ) 𝓘(ℂ) ω triangleRegularProject :=
+  CoveringQuotient.project_isLocalDiffeomorph triangleRegularProject_covering
+    triangleRegularAction_holomorphic
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+attribute [local instance] SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangleRegularProject_holomorphic :
+    letI := triangleRegularQuotientChartedSpace
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω triangleRegularProject := by
+  let := triangleRegularQuotientChartedSpace
+  exact triangleRegularProject_isLocalDiffeomorph.contMDiff
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private abbrev SpecialPeriods.TriangleOrbitSpace :=
+  Quotient (MulAction.orbitRel TriangleGroup ℍ)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.triangleOrbitProjection : ℍ → TriangleOrbitSpace :=
+  Quotient.mk _
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangleOrbitProjection_surjective :
+    Function.Surjective triangleOrbitProjection :=
+  Quotient.mk_surjective
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem
+    SpecialPeriods.triangleOrbitProjection_continuous : Continuous triangleOrbitProjection :=
+  continuous_quot_mk
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangleOrbitProjection_eq_iff (x y : ℍ) :
+    triangleOrbitProjection x = triangleOrbitProjection y ↔
+      ∃ g : TriangleGroup, triangleGeometricRepresentation g y = x :=
+  Quotient.eq''
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+@[simp]
+private theorem SpecialPeriods.triangleOrbitProjection_smul (g : TriangleGroup) (z : ℍ) :
+    triangleOrbitProjection (triangleGeometricRepresentation g z) = triangleOrbitProjection z :=
+  (triangleOrbitProjection_eq_iff _ _).mpr ⟨g, rfl⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangleOrbitProjection_isOpenQuotientMap :
+    IsOpenQuotientMap triangleOrbitProjection :=
+  MulAction.isOpenQuotientMap_quotientMk
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem
+    SpecialPeriods.triangleOrbitProjection_isOpenMap : IsOpenMap triangleOrbitProjection :=
+  triangleOrbitProjection_isOpenQuotientMap.isOpenMap
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private instance SpecialPeriods.triangleOrbitSpace_t2 : T2Space TriangleOrbitSpace :=
+  inferInstance
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private instance SpecialPeriods.triangleOrbitSpace_locallyCompact :
+    LocallyCompactSpace TriangleOrbitSpace :=
+  triangleOrbitProjection_isOpenQuotientMap.locallyCompactSpace
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.triangleOrbitCenterOne : TriangleOrbitSpace :=
+  triangleOrbitProjection Triangle.centerOne
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.triangleOrbitCenterTwo : TriangleOrbitSpace :=
+  triangleOrbitProjection Triangle.centerTwo
+
+private abbrev SpecialPeriods.TriangleCompactifiedOrbitSpace :=
+  OnePoint TriangleOrbitSpace
+
+private def SpecialPeriods.triangleCuspPoint : TriangleCompactifiedOrbitSpace :=
+  (OnePoint.infty)
+
+private def
+    SpecialPeriods.triangleOpenInclusion : TriangleOrbitSpace → TriangleCompactifiedOrbitSpace :=
+  OnePoint.some
+
+private theorem SpecialPeriods.triangleOpenInclusion_isOpenEmbedding :
+    Topology.IsOpenEmbedding triangleOpenInclusion :=
+  OnePoint.isOpenEmbedding_coe
+
+private theorem SpecialPeriods.triangleOpenInclusion_ne_cusp (q : TriangleOrbitSpace) :
+    triangleOpenInclusion q ≠ triangleCuspPoint :=
+  OnePoint.coe_ne_infty q
+
+private theorem SpecialPeriods.triangleCompactifiedOrbitSpace_compact :
+    CompactSpace TriangleCompactifiedOrbitSpace :=
+  inferInstance
+
+private def SpecialPeriods.Triangle.cuspImage (Y : ℝ) :
+    TopologicalSpace.Opens SpecialPeriods.TriangleOrbitSpace :=
+  ⟨SpecialPeriods.triangleOrbitProjection '' (horodisc Y : Set ℍ),
+    SpecialPeriods.triangleOrbitProjection_isOpenMap _ (horodisc Y).isOpen⟩
+
+@[simp]
+private theorem
+    SpecialPeriods.Triangle.mem_cuspImage (Y : ℝ) (q : SpecialPeriods.TriangleOrbitSpace) :
+    q ∈ cuspImage Y ↔ ∃ z : ℍ, Y < z.im ∧ SpecialPeriods.triangleOrbitProjection z = q :=
+  Iff.rfl
+
+private theorem SpecialPeriods.Triangle.cuspImage_antitone :
+    Antitone (fun Y : ℝ => (cuspImage Y : Set SpecialPeriods.TriangleOrbitSpace)) := by
+  intro Y Z hYZ q hq
+  obtain ⟨z, hz, rfl⟩ := hq
+  exact ⟨z, hYZ.trans_lt hz, rfl⟩
+
+private theorem SpecialPeriods.Triangle.cuspImage_compl_subset_truncated_image (Y : ℝ) :
+    (cuspImage Y : Set SpecialPeriods.TriangleOrbitSpace)ᶜ ⊆
+      SpecialPeriods.triangleOrbitProjection '' truncatedFordRegion Y := by
+  intro q hq
+  obtain ⟨z, rfl⟩ := SpecialPeriods.triangleOrbitProjection_surjective q
+  obtain ⟨g, hg⟩ := SpecialPeriods.triangle_exists_fordRegion_representative z
+  have he :
+    SpecialPeriods.triangleOrbitProjection (SpecialPeriods.triangleGeometricRepresentation g z) =
+      SpecialPeriods.triangleOrbitProjection z :=
+    SpecialPeriods.triangleOrbitProjection_smul g z
+  refine ⟨SpecialPeriods.triangleGeometricRepresentation g z, ⟨hg, ?_⟩, he⟩
+  apply le_of_not_gt
+  intro hi
+  exact hq ⟨SpecialPeriods.triangleGeometricRepresentation g z, hi, he⟩
+
+private theorem SpecialPeriods.Triangle.cuspImage_compl_compact (Y : ℝ) :
+    IsCompact (cuspImage Y : Set SpecialPeriods.TriangleOrbitSpace)ᶜ :=
+  ((truncatedFordRegion_compact Y).image
+        SpecialPeriods.triangleOrbitProjection_continuous).of_isClosed_subset
+    (cuspImage Y).isOpen.isClosed_compl (cuspImage_compl_subset_truncated_image Y)
+
+private def SpecialPeriods.Triangle.cuspNeighborhood (Y : ℝ) :
+    TopologicalSpace.Opens SpecialPeriods.TriangleCompactifiedOrbitSpace :=
+  OnePoint.opensOfCompl (cuspImage Y : Set SpecialPeriods.TriangleOrbitSpace)ᶜ
+    (cuspImage Y).isOpen.isClosed_compl (cuspImage_compl_compact Y)
+
+@[simp]
+private theorem SpecialPeriods.Triangle.cuspPoint_mem_cuspNeighborhood (Y : ℝ) :
+    SpecialPeriods.triangleCuspPoint ∈ cuspNeighborhood Y :=
+  OnePoint.infty_mem_opensOfCompl _ _
+
+@[simp]
+private theorem SpecialPeriods.Triangle.openInclusion_mem_cuspNeighborhood (Y : ℝ)
+    (q : SpecialPeriods.TriangleOrbitSpace) :
+    SpecialPeriods.triangleOpenInclusion q ∈ cuspNeighborhood Y ↔ q ∈ cuspImage Y := by
+  change
+    (q : OnePoint SpecialPeriods.TriangleOrbitSpace) ∉
+        ((↑) : SpecialPeriods.TriangleOrbitSpace → OnePoint SpecialPeriods.TriangleOrbitSpace) ''
+          (cuspImage Y : Set SpecialPeriods.TriangleOrbitSpace)ᶜ ↔
+      _
+  simp only [OnePoint.coe_injective.mem_set_image, Set.mem_compl_iff, Classical.not_not]
+  rfl
+
+private theorem SpecialPeriods.Triangle.cuspNeighborhood_preimage (Y : ℝ) :
+    SpecialPeriods.triangleOpenInclusion ⁻¹'
+        (cuspNeighborhood Y : Set SpecialPeriods.TriangleCompactifiedOrbitSpace) =
+      cuspImage Y := by
+  ext q
+  exact openInclusion_mem_cuspNeighborhood Y q
+
+private theorem SpecialPeriods.Triangle.cuspNeighborhood_mem_nhds (Y : ℝ) :
+    (cuspNeighborhood Y : Set SpecialPeriods.TriangleCompactifiedOrbitSpace) ∈
+      𝓝 SpecialPeriods.triangleCuspPoint :=
+  (cuspNeighborhood Y).isOpen.mem_nhds (cuspPoint_mem_cuspNeighborhood Y)
+
+private theorem SpecialPeriods.Triangle.width_coe_ne_zero_mo1973_16106 : (width : ℂ) ≠ 0 :=
+  Complex.ofReal_ne_zero.mpr width_ne_zero
+
+private def SpecialPeriods.Triangle.cuspQ (z : ℍ) : ℂ :=
+  Function.Periodic.qParam width z
+
+private theorem SpecialPeriods.Triangle.cuspQ_eq_exp (z : ℍ) :
+    cuspQ z = Complex.exp (2 * Real.pi * Complex.I * z / width) :=
+  rfl
+
+private theorem SpecialPeriods.Triangle.cuspQ_holomorphic : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω cuspQ :=
+  (Function.Periodic.contDiff_qParam (h := width) ω).contMDiff.comp UpperHalfPlane.contMDiff_coe
+
+private theorem SpecialPeriods.Triangle.cuspQ_continuous : Continuous cuspQ :=
+  cuspQ_holomorphic.continuous
+
+private theorem SpecialPeriods.Triangle.cuspQ_ne_zero (z : ℍ) : cuspQ z ≠ 0 :=
+  Function.Periodic.qParam_ne_zero z
+
+private theorem SpecialPeriods.Triangle.cuspQ_hasStrictDerivAt (z : ℍ) :
+    HasStrictDerivAt (cuspQ ∘ UpperHalfPlane.ofComplex)
+      (cuspQ z * (2 * Real.pi * Complex.I / width)) (z : ℂ) := by
+  have h :
+    HasStrictDerivAt (Function.Periodic.qParam width)
+      (cuspQ z * (2 * Real.pi * Complex.I / width)) (z : ℂ) := by
+    simpa only [id_eq, mul_one] using!
+      (((hasStrictDerivAt_id (z : ℂ)).const_mul (2 * Real.pi * Complex.I)).div_const
+          (width : ℂ)).cexp
+  apply h.congr_of_eventuallyEq
+  filter_upwards [UpperHalfPlane.eventuallyEq_coe_comp_ofComplex z.im_pos] with w hw
+  change
+    Function.Periodic.qParam width w = Function.Periodic.qParam width (UpperHalfPlane.ofComplex w)
+  exact congrArg (Function.Periodic.qParam width) hw.symm
+
+private theorem SpecialPeriods.Triangle.cuspQ_deriv_ne_zero (z : ℍ) :
+    deriv (cuspQ ∘ UpperHalfPlane.ofComplex) (z : ℂ) ≠ 0 := by
+  rw [(cuspQ_hasStrictDerivAt z).hasDerivAt.deriv]
+  exact
+    mul_ne_zero (cuspQ_ne_zero z)
+      (div_ne_zero Complex.two_pi_I_ne_zero width_coe_ne_zero_mo1973_16106)
+
+private theorem SpecialPeriods.Triangle.cuspQ_norm_lt_one (z : ℍ) : ‖cuspQ z‖ < 1 :=
+  Function.Periodic.norm_qParam_lt_one width_pos z.im_pos
+
+private theorem SpecialPeriods.Triangle.cuspQ_norm_lt_exp_iff (A : ℝ) (z : ℍ) :
+    ‖cuspQ z‖ < Real.exp (-2 * Real.pi * A / width) ↔ A < z.im :=
+  Function.Periodic.norm_qParam_lt_iff width_pos A z
+
+private theorem SpecialPeriods.Triangle.cuspQ_cusp_zpow (n : ℤ) (z : ℍ) :
+    cuspQ
+        (SpecialPeriods.triangleGeometricRepresentation (SpecialPeriods.triangleCuspGenerator ^ n)
+          z) =
+      cuspQ z := by
+  rw [cuspQ, SpecialPeriods.triangleGeometricRepresentation_cusp_zpow_coe, cuspQ]
+  apply Complex.exp_eq_exp_iff_exists_int.mpr
+  refine ⟨-n, ?_⟩
+  push_cast
+  rw [mul_div_assoc, sub_div, mul_div_cancel_right₀ _ width_coe_ne_zero_mo1973_16106]
+  ring
+
+private theorem SpecialPeriods.Triangle.cuspQ_eq_iff (z w : ℍ) :
+    cuspQ z = cuspQ w ↔
+      ∃ n : ℤ,
+        SpecialPeriods.triangleGeometricRepresentation (SpecialPeriods.triangleCuspGenerator ^ n)
+            w =
+          z := by
+  constructor
+  · intro h
+    obtain ⟨m, hm⟩ := Function.Periodic.qParam_left_inv_mod_period width_ne_zero (z : ℂ)
+    obtain ⟨n, hn⟩ := Function.Periodic.qParam_left_inv_mod_period width_ne_zero (w : ℂ)
+    change Function.Periodic.invQParam width (cuspQ z) = (z : ℂ) + m * width at hm
+    change Function.Periodic.invQParam width (cuspQ w) = (w : ℂ) + n * width at hn
+    rw [h, hn] at hm
+    refine ⟨m - n, ?_⟩
+    apply UpperHalfPlane.ext
+    rw [SpecialPeriods.triangleGeometricRepresentation_cusp_zpow_coe]
+    push_cast
+    linear_combination hm
+  · rintro ⟨n, rfl⟩
+    exact cuspQ_cusp_zpow n w
+
+private def SpecialPeriods.Triangle.puncturedDisc : TopologicalSpace.Opens ℂ :=
+  ⟨{q : ℂ | q ≠ 0 ∧ ‖q‖ < 1},
+    isOpen_compl_singleton.inter (isOpen_lt continuous_norm continuous_const)⟩
+
+private abbrev SpecialPeriods.Triangle.PuncturedDisc :=
+  puncturedDisc
+
+private def SpecialPeriods.Triangle.cuspQMap (z : ℍ) : PuncturedDisc :=
+  ⟨cuspQ z, cuspQ_ne_zero z, cuspQ_norm_lt_one z⟩
+
+private theorem SpecialPeriods.Triangle.cuspQMap_surjective : Function.Surjective cuspQMap := by
+  intro q
+  refine
+    ⟨⟨Function.Periodic.invQParam width q,
+        Function.Periodic.im_invQParam_pos_of_norm_lt_one width_pos q.property.2 q.property.1⟩,
+      ?_⟩
+  apply Subtype.ext
+  exact Function.Periodic.qParam_right_inv width_ne_zero q.property.1
+
+private theorem SpecialPeriods.Triangle.qParam_width_isOpenMap_mo1973_16141 :
+    IsOpenMap (Function.Periodic.qParam width) := by
+  change IsOpenMap (Complex.exp ∘ (fun z : ℂ => 2 * Real.pi * Complex.I * z / width))
+  apply Complex.isOpenMap_exp.comp
+  have he :
+    (fun z : ℂ => 2 * Real.pi * Complex.I * z / width) =
+      (fun z : ℂ => (2 * Real.pi * Complex.I / width) * z) := by
+    funext z
+    ring
+  rw [he]
+  exact
+    (Homeomorph.mulLeft₀ _
+        (div_ne_zero Complex.two_pi_I_ne_zero width_coe_ne_zero_mo1973_16106)).isOpenMap
+
+private theorem SpecialPeriods.Triangle.cuspQ_isOpenMap : IsOpenMap cuspQ :=
+  qParam_width_isOpenMap_mo1973_16141.comp UpperHalfPlane.isOpenEmbedding_coe.isOpenMap
+
+private theorem SpecialPeriods.Triangle.cuspQ_tendsto_atImInfty :
+    Filter.Tendsto cuspQ UpperHalfPlane.atImInfty (𝓝[≠] (0 : ℂ)) :=
+  (Function.Periodic.qParam_tendsto width_pos).comp UpperHalfPlane.tendsto_coe_atImInfty
+
+private def SpecialPeriods.Triangle.cuspRadius (Y : ℝ) : ℝ :=
+  Real.exp (-2 * Real.pi * Y / width)
+
+@[simp]
+private theorem SpecialPeriods.Triangle.cuspRadius_pos (Y : ℝ) : 0 < cuspRadius Y :=
+  Real.exp_pos _
+
+private theorem
+    SpecialPeriods.Triangle.cuspRadius_le_one (Y : ℝ) (hY : 0 ≤ Y) : cuspRadius Y ≤ 1 := by
+  rw [cuspRadius, Real.exp_le_one_iff]
+  apply div_nonpos_of_nonpos_of_nonneg _ width_pos.le
+  exact
+    mul_nonpos_of_nonpos_of_nonneg (mul_nonpos_of_nonpos_of_nonneg (by norm_num) Real.pi_pos.le)
+      hY
+
+private def SpecialPeriods.Triangle.puncturedCuspBall (Y : ℝ) : TopologicalSpace.Opens ℂ :=
+  ⟨{q : ℂ | q ≠ 0 ∧ ‖q‖ < cuspRadius Y},
+    isOpen_compl_singleton.inter (isOpen_lt continuous_norm continuous_const)⟩
+
+@[simp]
+private theorem SpecialPeriods.Triangle.mem_puncturedCuspBall (Y : ℝ) (q : ℂ) :
+    q ∈ puncturedCuspBall Y ↔ q ≠ 0 ∧ ‖q‖ < cuspRadius Y :=
+  Iff.rfl
+
+private theorem SpecialPeriods.Triangle.cuspQ_mem_puncturedCuspBall_iff (Y : ℝ) (z : ℍ) :
+    cuspQ z ∈ puncturedCuspBall Y ↔ z ∈ horodisc Y := by
+  change (cuspQ z ≠ 0 ∧ ‖cuspQ z‖ < Real.exp (-2 * Real.pi * Y / width)) ↔ Y < z.im
+  constructor
+  · intro h
+    exact (cuspQ_norm_lt_exp_iff Y z).mp h.2
+  · intro h
+    exact ⟨cuspQ_ne_zero z, (cuspQ_norm_lt_exp_iff Y z).mpr h⟩
+
+private def SpecialPeriods.Triangle.cuspQHorodisc (Y : ℝ) (z : horodisc Y) : puncturedCuspBall Y :=
+  ⟨cuspQ z, (cuspQ_mem_puncturedCuspBall_iff Y z).mpr z.property⟩
+
+private theorem SpecialPeriods.Triangle.cuspQHorodisc_eq_iff (Y : ℝ) (z w : horodisc Y) :
+    cuspQHorodisc Y z = cuspQHorodisc Y w ↔
+      ∃ n : ℤ,
+        SpecialPeriods.triangleGeometricRepresentation (SpecialPeriods.triangleCuspGenerator ^ n)
+            (w : ℍ) =
+          (z : ℍ) :=
+  Subtype.ext_iff.trans (cuspQ_eq_iff z w)
+
+private theorem SpecialPeriods.Triangle.cuspQHorodisc_holomorphic (Y : ℝ) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (cuspQHorodisc Y) := by
+  have h : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z : horodisc Y => cuspQ (z : ℍ)) :=
+    cuspQ_holomorphic.comp contMDiff_subtype_val
+  intro z
+  have hi :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (fun w : horodisc Y => (cuspQHorodisc Y w : ℂ)) z ↔
+      ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (cuspQHorodisc Y) z :=
+    ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+  exact hi.mp (h z)
+
+private theorem
+    SpecialPeriods.Triangle.cuspQHorodisc_continuous (Y : ℝ) : Continuous (cuspQHorodisc Y) :=
+  (cuspQHorodisc_holomorphic Y).continuous
+
+private theorem
+    SpecialPeriods.Triangle.cuspQHorodisc_isOpenMap (Y : ℝ) : IsOpenMap (cuspQHorodisc Y) := by
+  apply (puncturedCuspBall Y).isOpen.isOpenEmbedding_subtypeVal.isOpenMap_iff.mpr
+  exact cuspQ_isOpenMap.comp (horodisc Y).isOpen.isOpenEmbedding_subtypeVal.isOpenMap
+
+private theorem SpecialPeriods.Triangle.cuspQHorodisc_surjective (Y : ℝ) (hY : 0 ≤ Y) :
+    Function.Surjective (cuspQHorodisc Y) := by
+  intro q
+  let q' : PuncturedDisc := ⟨q, q.property.1, q.property.2.trans_le (cuspRadius_le_one Y hY)⟩
+  obtain ⟨z, hz⟩ := cuspQMap_surjective q'
+  have hzq : cuspQ z = (q : ℂ) := congrArg Subtype.val hz
+  have hzY : z ∈ horodisc Y := by
+    apply (cuspQ_mem_puncturedCuspBall_iff Y z).mp
+    rw [hzq]
+    exact q.property
+  refine ⟨⟨z, hzY⟩, ?_⟩
+  exact Subtype.ext hzq
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous in
+private abbrev SpecialPeriods.Triangle.CuspHorodiscQuotient (Y : ℝ) :=
+  LocalOrbitQuotient.LocalQuotient (Subgroup.zpowers SpecialPeriods.triangleCuspGenerator)
+    (horodisc Y) (cusp_horodisc_invariant Y)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.cuspHorodiscProjection (Y : ℝ) :
+    horodisc Y → CuspHorodiscQuotient Y :=
+  LocalOrbitQuotient.localProjection _ _ _
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.cuspHorodiscProjection_eq_iff (Y : ℝ) (z w : horodisc Y) :
+    cuspHorodiscProjection Y z = cuspHorodiscProjection Y w ↔
+      ∃ n : ℤ,
+        SpecialPeriods.triangleGeometricRepresentation (SpecialPeriods.triangleCuspGenerator ^ n)
+            (w : ℍ) =
+          (z : ℍ) := by
+  rw [cuspHorodiscProjection, LocalOrbitQuotient.localProjection_eq_iff]
+  constructor
+  · rintro ⟨g, hg⟩
+    obtain ⟨n, hn⟩ := Subgroup.mem_zpowers_iff.mp g.property
+    refine ⟨n, ?_⟩
+    rw [hn]
+    exact hg
+  · rintro ⟨n, hn⟩
+    exact ⟨⟨SpecialPeriods.triangleCuspGenerator ^ n, Subgroup.zpow_mem_zpowers _ _⟩, hn⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.cuspHorodiscProjection_surjective (Y : ℝ) :
+    Function.Surjective (cuspHorodiscProjection Y) :=
+  LocalOrbitQuotient.localProjection_surjective _ _ _
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.cuspHorodiscProjection_continuous (Y : ℝ) :
+    Continuous (cuspHorodiscProjection Y) :=
+  LocalOrbitQuotient.localProjection_continuous _ _ _
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.cuspImageProjection (Y : ℝ) : horodisc Y → cuspImage Y :=
+  LocalOrbitQuotient.imageProjection (G := SpecialPeriods.TriangleGroup) (horodisc Y)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.cuspImageProjection_surjective (Y : ℝ) :
+    Function.Surjective (cuspImageProjection Y) :=
+  LocalOrbitQuotient.imageProjection_surjective (horodisc Y)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.cuspHorodiscImageHomeomorph (Y : ℝ) (hY : width ≤ Y) :
+    CuspHorodiscQuotient Y ≃ₜ cuspImage Y :=
+  LocalOrbitQuotient.localHomeomorph (Subgroup.zpowers SpecialPeriods.triangleCuspGenerator)
+    (horodisc Y) (cusp_horodisc_invariant Y) (triangle_horodisc_overlap_mem_cusp Y hY)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous in
+@[simp]
+private theorem SpecialPeriods.Triangle.cuspHorodiscImageHomeomorph_mk (Y : ℝ) (hY : width ≤ Y)
+    (z : horodisc Y) :
+    cuspHorodiscImageHomeomorph Y hY (cuspHorodiscProjection Y z) = cuspImageProjection Y z :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous in
+@[simp]
+private theorem SpecialPeriods.Triangle.cuspHorodiscImageHomeomorph_symm_mk (Y : ℝ) (hY : width ≤ Y)
+    (z : horodisc Y) :
+    (cuspHorodiscImageHomeomorph Y hY).symm (cuspImageProjection Y z) =
+      cuspHorodiscProjection Y z :=
+  (cuspHorodiscImageHomeomorph Y hY).symm_apply_apply (cuspHorodiscProjection Y z)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.cuspImageProjection_eq_iff (Y : ℝ) (hY : width ≤ Y)
+    (z w : horodisc Y) :
+    cuspImageProjection Y z = cuspImageProjection Y w ↔ cuspQ (z : ℍ) = cuspQ (w : ℍ) := by
+  rw [← cuspHorodiscImageHomeomorph_mk Y hY z, ← cuspHorodiscImageHomeomorph_mk Y hY w,
+    (cuspHorodiscImageHomeomorph Y hY).injective.eq_iff, cuspHorodiscProjection_eq_iff,
+    cuspQ_eq_iff]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.cuspHorodiscToBall (Y : ℝ) :
+    CuspHorodiscQuotient Y → puncturedCuspBall Y :=
+  Quotient.lift (cuspQHorodisc Y) fun z w h =>
+    (cuspQHorodisc_eq_iff Y z w).mpr ((cuspHorodiscProjection_eq_iff Y z w).mp (Quotient.sound h))
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.cuspHorodiscToBall_injective (Y : ℝ) :
+    Function.Injective (cuspHorodiscToBall Y) := by
+  intro x y
+  refine Quotient.inductionOn₂ x y ?_
+  intro z w h
+  exact (cuspHorodiscProjection_eq_iff Y z w).mpr ((cuspQHorodisc_eq_iff Y z w).mp h)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.cuspHorodiscToBall_surjective (Y : ℝ) (hY : 0 ≤ Y) :
+    Function.Surjective (cuspHorodiscToBall Y) := by
+  intro q
+  obtain ⟨z, rfl⟩ := cuspQHorodisc_surjective Y hY q
+  exact ⟨cuspHorodiscProjection Y z, rfl⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.cuspHorodiscToBall_continuous (Y : ℝ) :
+    Continuous (cuspHorodiscToBall Y) :=
+  (cuspQHorodisc_continuous Y).quotient_lift _
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.cuspHorodiscToBall_isOpenMap (Y : ℝ) :
+    IsOpenMap (cuspHorodiscToBall Y) :=
+  IsOpenMap.of_comp (cuspHorodiscProjection_continuous Y) (cuspHorodiscProjection_surjective Y)
+    (cuspQHorodisc_isOpenMap Y)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.cuspHorodiscBallHomeomorph (Y : ℝ) (hY : 0 ≤ Y) :
+    CuspHorodiscQuotient Y ≃ₜ puncturedCuspBall Y :=
+  Equiv.toHomeomorphOfContinuousOpen
+    (Equiv.ofBijective (cuspHorodiscToBall Y)
+      ⟨cuspHorodiscToBall_injective Y, cuspHorodiscToBall_surjective Y hY⟩)
+    (cuspHorodiscToBall_continuous Y) (cuspHorodiscToBall_isOpenMap Y)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.cuspImageHomeomorph (Y : ℝ) (hY : width ≤ Y) :
+    cuspImage Y ≃ₜ puncturedCuspBall Y :=
+  (cuspHorodiscImageHomeomorph Y hY).symm.trans
+    (cuspHorodiscBallHomeomorph Y (width_pos.le.trans hY))
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous in
+@[simp]
+private theorem
+    SpecialPeriods.Triangle.cuspImageHomeomorph_mk (Y : ℝ) (hY : width ≤ Y) (z : horodisc Y) :
+    cuspImageHomeomorph Y hY (cuspImageProjection Y z) = cuspQHorodisc Y z := by
+  change
+    cuspHorodiscToBall Y ((cuspHorodiscImageHomeomorph Y hY).symm (cuspImageProjection Y z)) = _
+  rw [cuspHorodiscImageHomeomorph_symm_mk]
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.cuspImageHomeomorph_mk_coe (Y : ℝ) (hY : width ≤ Y)
+    (z : horodisc Y) : (cuspImageHomeomorph Y hY (cuspImageProjection Y z) : ℂ) = cuspQ (z : ℍ) :=
+  by
+  rw [cuspImageHomeomorph_mk]
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous in
+@[simp]
+private theorem SpecialPeriods.Triangle.cuspImageHomeomorph_symm_q (Y : ℝ) (hY : width ≤ Y)
+    (z : horodisc Y) :
+    (cuspImageHomeomorph Y hY).symm (cuspQHorodisc Y z) = cuspImageProjection Y z := by
+  rw [← cuspImageHomeomorph_mk Y hY z, Homeomorph.symm_apply_apply]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.cuspImageHomeomorph_norm_lt_iff (Y Z : ℝ) (hY : width ≤ Y)
+    (hYZ : Y ≤ Z) (x : cuspImage Y) :
+    ‖(cuspImageHomeomorph Y hY x : ℂ)‖ < cuspRadius Z ↔
+      (x : SpecialPeriods.TriangleOrbitSpace) ∈ cuspImage Z := by
+  obtain ⟨z, rfl⟩ := cuspImageProjection_surjective Y x
+  rw [cuspImageHomeomorph_mk_coe]
+  change
+    ‖cuspQ (z : ℍ)‖ < Real.exp (-2 * Real.pi * Z / width) ↔
+      ∃ w : ℍ,
+        Z < w.im ∧
+          SpecialPeriods.triangleOrbitProjection w =
+            SpecialPeriods.triangleOrbitProjection (z : ℍ)
+  rw [cuspQ_norm_lt_exp_iff]
+  constructor
+  · intro hz
+    exact ⟨z, hz, rfl⟩
+  · rintro ⟨w, hw, he⟩
+    have hwY : w ∈ horodisc Y := hYZ.trans_lt hw
+    have he' : cuspImageProjection Y ⟨w, hwY⟩ = cuspImageProjection Y z := Subtype.ext he
+    have hq := (cuspImageProjection_eq_iff Y hY ⟨w, hwY⟩ z).mp he'
+    have hnorm := (cuspQ_norm_lt_exp_iff Z w).mpr hw
+    rw [hq] at hnorm
+    exact (cuspQ_norm_lt_exp_iff Z (z : ℍ)).mp hnorm
+
+private def SpecialPeriods.Triangle.boundedOrbitImage (R : ℝ) :
+    TopologicalSpace.Opens SpecialPeriods.TriangleOrbitSpace :=
+  ⟨SpecialPeriods.triangleOrbitProjection '' {z : ℍ | orbitHeightBound z < R},
+    SpecialPeriods.triangleOrbitProjection_isOpenMap _
+      (isOpen_lt orbitHeightBound_continuous continuous_const)⟩
+
+private theorem SpecialPeriods.Triangle.boundedOrbitImage_mono :
+    Monotone (fun R : ℝ => (boundedOrbitImage R : Set SpecialPeriods.TriangleOrbitSpace)) := by
+  intro R S hRS q hq
+  obtain ⟨z, hz, rfl⟩ := hq
+  exact ⟨z, hz.trans_le hRS, rfl⟩
+
+private theorem SpecialPeriods.Triangle.boundedOrbitImage_subset_cuspImage_compl (R : ℝ) :
+    (boundedOrbitImage R : Set SpecialPeriods.TriangleOrbitSpace) ⊆
+      (cuspImage R : Set SpecialPeriods.TriangleOrbitSpace)ᶜ := by
+  rintro q ⟨z, hz, rfl⟩ ⟨w, hw, he⟩
+  obtain ⟨g, hg⟩ := (SpecialPeriods.triangleOrbitProjection_eq_iff w z).mp he
+  have hb := triangle_im_le_orbitHeightBound g z
+  rw [hg] at hb
+  exact (not_lt_of_ge (le_trans hb hz.le)) hw
+
+private theorem SpecialPeriods.Triangle.boundedOrbitImage_cover :
+    (⋃ R : ℝ, (boundedOrbitImage R : Set SpecialPeriods.TriangleOrbitSpace)) = Set.univ := by
+  apply Set.eq_univ_of_forall
+  intro q
+  obtain ⟨z, rfl⟩ := SpecialPeriods.triangleOrbitProjection_surjective q
+  refine Set.mem_iUnion.mpr ⟨orbitHeightBound z + 1, z, ?_, rfl⟩
+  change orbitHeightBound z < orbitHeightBound z + 1
+  linarith
+
+private theorem SpecialPeriods.Triangle.compact_subset_cuspImage_compl
+    {K : Set SpecialPeriods.TriangleOrbitSpace} (hK : IsCompact K) :
+    ∃ Y : ℝ, width ≤ Y ∧ K ⊆ (cuspImage Y : Set SpecialPeriods.TriangleOrbitSpace)ᶜ := by
+  obtain ⟨R, hR⟩ :=
+    hK.elim_directed_cover
+      (fun R : ℝ => (boundedOrbitImage R : Set SpecialPeriods.TriangleOrbitSpace))
+      (fun R => (boundedOrbitImage R).isOpen)
+      (by rw [boundedOrbitImage_cover]; exact Set.subset_univ K)
+      (fun R S =>
+        ⟨Max.max R S, boundedOrbitImage_mono (le_max_left R S),
+          boundedOrbitImage_mono (le_max_right R S)⟩)
+  refine ⟨Max.max R width, le_max_right _ _, ?_⟩
+  exact
+    hR.trans
+      ((boundedOrbitImage_mono (le_max_left R width)).trans
+        (boundedOrbitImage_subset_cuspImage_compl (Max.max R width)))
+
+private theorem SpecialPeriods.Triangle.cuspNeighborhood_basis :
+    (𝓝 SpecialPeriods.triangleCuspPoint).HasBasis (fun Y : ℝ => width ≤ Y)
+      (fun Y => (cuspNeighborhood Y : Set SpecialPeriods.TriangleCompactifiedOrbitSpace)) := by
+  rw [Filter.hasBasis_iff]
+  intro U
+  constructor
+  · intro hU
+    obtain ⟨K, ⟨hKclosed, hKcompact⟩, hKU⟩ := OnePoint.hasBasis_nhds_infty.mem_iff.mp hU
+    obtain ⟨Y, hY, hKY⟩ := compact_subset_cuspImage_compl hKcompact
+    refine ⟨Y, hY, ?_⟩
+    intro x hx
+    induction x using OnePoint.rec
+    · exact hKU (Or.inr rfl)
+    · rename_i q
+      have hq : q ∈ cuspImage Y := (openInclusion_mem_cuspNeighborhood Y q).mp hx
+      exact hKU (Or.inl ⟨q, fun hqK => hKY hqK hq, rfl⟩)
+  · rintro ⟨Y, _, hYU⟩
+    exact Filter.mem_of_superset (cuspNeighborhood_mem_nhds Y) hYU
+
+private instance
+    SpecialPeriods.triangleOrbitSpace_noncompact : NoncompactSpace TriangleOrbitSpace where
+  noncompact_univ := by
+    intro hK
+    obtain ⟨Y, _, hY⟩ := Triangle.compact_subset_cuspImage_compl hK
+    obtain ⟨z, hz⟩ := Triangle.horodisc_nonempty Y
+    exact hY (Set.mem_univ (triangleOrbitProjection z)) ⟨z, hz, rfl⟩
+
+private theorem SpecialPeriods.triangleCompactifiedOrbitSpace_connected :
+    ConnectedSpace TriangleCompactifiedOrbitSpace :=
+  inferInstance
+
+private theorem SpecialPeriods.Triangle.cuspRadius_tendsto_zero :
+    Filter.Tendsto cuspRadius Filter.atTop (𝓝 0) := by
+  have hneg : -2 * Real.pi < 0 := by nlinarith [Real.pi_pos]
+  exact
+    Real.tendsto_exp_atBot.comp
+      ((Filter.tendsto_id.const_mul_atTop_of_neg hneg).atBot_div_const width_pos)
+
+private theorem SpecialPeriods.Triangle.exists_high_cuspRadius_lt (Y : ℝ) {ε : ℝ} (hε : 0 < ε) :
+    ∃ Z : ℝ, Y ≤ Z ∧ width ≤ Z ∧ cuspRadius Z < ε := by
+  have hsmall : ∀ᶠ Z in Filter.atTop, cuspRadius Z < ε :=
+    cuspRadius_tendsto_zero.eventually (gt_mem_nhds hε)
+  obtain ⟨Z, hZ⟩ := Filter.eventually_atTop.mp hsmall
+  refine ⟨Max.max Y (Max.max width Z), le_max_left _ _, ?_, hZ _ ?_⟩
+  · exact (le_max_left width Z).trans (le_max_right Y _)
+  · exact (le_max_right width Z).trans (le_max_right Y _)
+
+private def SpecialPeriods.Triangle.cuspFullForward (Y : ℝ) (hY : width ≤ Y) :
+    SpecialPeriods.TriangleCompactifiedOrbitSpace → ℂ := by
+  classical
+    exact
+    OnePoint.rec 0
+      (fun q : SpecialPeriods.TriangleOrbitSpace =>
+        if hq : q ∈ cuspImage Y then (cuspImageHomeomorph Y hY ⟨q, hq⟩ : ℂ) else 0)
+
+@[simp]
+private theorem SpecialPeriods.Triangle.cuspFullForward_cuspPoint (Y : ℝ) (hY : width ≤ Y) :
+    cuspFullForward Y hY SpecialPeriods.triangleCuspPoint = 0 :=
+  rfl
+
+private theorem SpecialPeriods.Triangle.cuspFullForward_openInclusion (Y : ℝ) (hY : width ≤ Y)
+    (q : SpecialPeriods.TriangleOrbitSpace) (hq : q ∈ cuspImage Y) :
+    cuspFullForward Y hY (SpecialPeriods.triangleOpenInclusion q) =
+      (cuspImageHomeomorph Y hY ⟨q, hq⟩ : ℂ) := by
+  classical
+  change (if h : q ∈ cuspImage Y then (cuspImageHomeomorph Y hY ⟨q, h⟩ : ℂ) else 0) = _
+  rw [dite_eq_left hq]
+
+private def SpecialPeriods.Triangle.cuspFullInverse (Y : ℝ) (hY : width ≤ Y) :
+    ℂ → SpecialPeriods.TriangleCompactifiedOrbitSpace := by
+  classical
+    exact fun z =>
+    if hz : z ∈ puncturedCuspBall Y then
+      SpecialPeriods.triangleOpenInclusion
+        ((cuspImageHomeomorph Y hY).symm ⟨z, hz⟩ : SpecialPeriods.TriangleOrbitSpace)
+    else SpecialPeriods.triangleCuspPoint
+
+@[simp]
+private theorem SpecialPeriods.Triangle.cuspFullInverse_zero (Y : ℝ) (hY : width ≤ Y) :
+    cuspFullInverse Y hY 0 = SpecialPeriods.triangleCuspPoint := by
+  classical simp [cuspFullInverse]
+
+private theorem SpecialPeriods.Triangle.cuspFullInverse_of_mem (Y : ℝ) (hY : width ≤ Y) (z : ℂ)
+    (hz : z ∈ puncturedCuspBall Y) :
+    cuspFullInverse Y hY z =
+      SpecialPeriods.triangleOpenInclusion
+        ((cuspImageHomeomorph Y hY).symm ⟨z, hz⟩ : SpecialPeriods.TriangleOrbitSpace) := by
+  classical simp [cuspFullInverse, hz]
+
+private theorem SpecialPeriods.Triangle.cuspFullInverse_of_not_mem (Y : ℝ) (hY : width ≤ Y) (z : ℂ)
+    (hz : z ∉ puncturedCuspBall Y) : cuspFullInverse Y hY z = SpecialPeriods.triangleCuspPoint := by
+  classical simp [cuspFullInverse, hz]
+
+private theorem SpecialPeriods.Triangle.cuspFullForward_continuousAt_openInclusion (Y : ℝ)
+    (hY : width ≤ Y) (q : SpecialPeriods.TriangleOrbitSpace) (hq : q ∈ cuspImage Y) :
+    ContinuousAt (cuspFullForward Y hY) (SpecialPeriods.triangleOpenInclusion q) := by
+  apply OnePoint.continuousAt_coe.mpr
+  have hc :
+    ContinuousOn
+      (fun q : SpecialPeriods.TriangleOrbitSpace =>
+        cuspFullForward Y hY (SpecialPeriods.triangleOpenInclusion q))
+      (cuspImage Y : Set SpecialPeriods.TriangleOrbitSpace) := by
+    rw [continuousOn_iff_continuous_domRestrict]
+    change
+      Continuous
+        (fun q : cuspImage Y => cuspFullForward Y hY (SpecialPeriods.triangleOpenInclusion q))
+    have he :
+      (fun q : cuspImage Y => cuspFullForward Y hY (SpecialPeriods.triangleOpenInclusion q)) =
+        (fun q : cuspImage Y => (cuspImageHomeomorph Y hY q : ℂ)) := by
+      funext q
+      exact cuspFullForward_openInclusion Y hY q q.property
+    rw [he]
+    exact continuous_subtype_val.comp (cuspImageHomeomorph Y hY).continuous
+  exact hc.continuousAt ((cuspImage Y).isOpen.mem_nhds hq)
+
+private theorem
+    SpecialPeriods.Triangle.cuspFullForward_continuousAt_cuspPoint (Y : ℝ) (hY : width ≤ Y) :
+    ContinuousAt (cuspFullForward Y hY) SpecialPeriods.triangleCuspPoint := by
+  change Filter.Tendsto (cuspFullForward Y hY) (𝓝 SpecialPeriods.triangleCuspPoint) (𝓝 (0 : ℂ))
+  apply Metric.tendsto_nhds.mpr
+  intro ε hε
+  obtain ⟨Z, hYZ, _, hZε⟩ := exists_high_cuspRadius_lt Y hε
+  filter_upwards [cuspNeighborhood_mem_nhds Z] with x hx
+  induction x using OnePoint.rec
+  · change Dist.dist (0 : ℂ) 0 < ε
+    simpa only [dist_self] using hε
+  · rename_i q
+    have hqZ : q ∈ cuspImage Z := (openInclusion_mem_cuspNeighborhood Z q).mp hx
+    have hqY : q ∈ cuspImage Y := cuspImage_antitone hYZ hqZ
+    have hn := (cuspImageHomeomorph_norm_lt_iff Y Z hY hYZ ⟨q, hqY⟩).mpr hqZ
+    change Dist.dist (cuspFullForward Y hY (SpecialPeriods.triangleOpenInclusion q)) 0 < ε
+    rw [cuspFullForward_openInclusion Y hY q hqY, dist_zero_right]
+    exact hn.trans hZε
+
+private theorem SpecialPeriods.Triangle.cuspFullForward_continuousOn (Y : ℝ) (hY : width ≤ Y) :
+    ContinuousOn (cuspFullForward Y hY)
+      (cuspNeighborhood Y : Set SpecialPeriods.TriangleCompactifiedOrbitSpace) := by
+  intro x hx
+  induction x using OnePoint.rec
+  · exact (cuspFullForward_continuousAt_cuspPoint Y hY).continuousWithinAt
+  · rename_i q
+    exact
+      (cuspFullForward_continuousAt_openInclusion Y hY q
+          ((openInclusion_mem_cuspNeighborhood Y q).mp hx)).continuousWithinAt
+
+private theorem SpecialPeriods.Triangle.cuspFullInverse_continuousAt_of_mem (Y : ℝ) (hY : width ≤ Y)
+    (z : ℂ) (hz : z ∈ puncturedCuspBall Y) : ContinuousAt (cuspFullInverse Y hY) z := by
+  have hc : ContinuousOn (cuspFullInverse Y hY) (puncturedCuspBall Y : Set ℂ) := by
+    rw [continuousOn_iff_continuous_domRestrict]
+    change Continuous (fun z : puncturedCuspBall Y => cuspFullInverse Y hY z)
+    have he :
+      (fun z : puncturedCuspBall Y => cuspFullInverse Y hY z) =
+        (fun z : puncturedCuspBall Y =>
+          SpecialPeriods.triangleOpenInclusion
+            ((cuspImageHomeomorph Y hY).symm z : SpecialPeriods.TriangleOrbitSpace)) := by
+      funext z
+      exact cuspFullInverse_of_mem Y hY z z.property
+    rw [he]
+    exact
+      SpecialPeriods.triangleOpenInclusion_isOpenEmbedding.continuous.comp
+        (continuous_subtype_val.comp (cuspImageHomeomorph Y hY).symm.continuous)
+  exact hc.continuousAt ((puncturedCuspBall Y).isOpen.mem_nhds hz)
+
+private theorem SpecialPeriods.Triangle.cuspFullInverse_continuousAt_zero (Y : ℝ) (hY : width ≤ Y) :
+    ContinuousAt (cuspFullInverse Y hY) 0 := by
+  classical
+  change Filter.Tendsto (cuspFullInverse Y hY) (𝓝 (0 : ℂ)) (𝓝 (cuspFullInverse Y hY 0))
+  rw [cuspFullInverse_zero, cuspNeighborhood_basis.tendsto_right_iff]
+  intro Z _
+  filter_upwards [Metric.ball_mem_nhds (0 : ℂ) (cuspRadius_pos (Max.max Y Z))] with z hz
+  by_cases hp : z ∈ puncturedCuspBall Y
+  · rw [cuspFullInverse_of_mem Y hY z hp]
+    apply (openInclusion_mem_cuspNeighborhood Z _).mpr
+    apply cuspImage_antitone (le_max_right Y Z)
+    apply
+      (cuspImageHomeomorph_norm_lt_iff Y (Max.max Y Z) hY (le_max_left Y Z)
+          ((cuspImageHomeomorph Y hY).symm ⟨z, hp⟩)).mp
+    simpa using hz
+  · rw [cuspFullInverse_of_not_mem Y hY z hp]
+    exact cuspPoint_mem_cuspNeighborhood Z
+
+private theorem SpecialPeriods.Triangle.cuspFullInverse_continuousOn (Y : ℝ) (hY : width ≤ Y) :
+    ContinuousOn (cuspFullInverse Y hY) (Metric.ball (0 : ℂ) (cuspRadius Y)) := by
+  classical
+  intro z hz
+  by_cases h0 : z = 0
+  · subst z
+    exact (cuspFullInverse_continuousAt_zero Y hY).continuousWithinAt
+  · exact (cuspFullInverse_continuousAt_of_mem Y hY z ⟨h0, by simpa using hz⟩).continuousWithinAt
+
+private def SpecialPeriods.Triangle.cuspFullChart (Y : ℝ) (hY : width ≤ Y) :
+    OpenPartialHomeomorph SpecialPeriods.TriangleCompactifiedOrbitSpace ℂ := by
+  classical
+    exact
+    { toFun := cuspFullForward Y hY
+      invFun := cuspFullInverse Y hY
+      source := cuspNeighborhood Y
+      target := Metric.ball 0 (cuspRadius Y)
+      map_source' := by
+        intro x hx
+        induction x using OnePoint.rec
+        · change (0 : ℂ) ∈ Metric.ball 0 (cuspRadius Y)
+          simpa only [Metric.mem_ball, dist_self] using cuspRadius_pos Y
+        · rename_i q
+          have hq : q ∈ cuspImage Y := (openInclusion_mem_cuspNeighborhood Y q).mp hx
+          change
+            cuspFullForward Y hY (SpecialPeriods.triangleOpenInclusion q) ∈
+              Metric.ball 0 (cuspRadius Y)
+          rw [cuspFullForward_openInclusion Y hY q hq]
+          simpa using (cuspImageHomeomorph Y hY ⟨q, hq⟩).property.2
+      map_target' := by
+        intro z _
+        by_cases hz : z ∈ puncturedCuspBall Y
+        · rw [cuspFullInverse_of_mem Y hY z hz]
+          exact
+            (openInclusion_mem_cuspNeighborhood Y _).mpr
+              ((cuspImageHomeomorph Y hY).symm ⟨z, hz⟩).property
+        · rw [cuspFullInverse_of_not_mem Y hY z hz]
+          exact cuspPoint_mem_cuspNeighborhood Y
+      left_inv' := by
+        intro x hx
+        induction x using OnePoint.rec
+        · exact cuspFullInverse_zero Y hY
+        · rename_i q
+          have hq : q ∈ cuspImage Y := (openInclusion_mem_cuspNeighborhood Y q).mp hx
+          change
+            cuspFullInverse Y hY (cuspFullForward Y hY (SpecialPeriods.triangleOpenInclusion q)) =
+              SpecialPeriods.triangleOpenInclusion q
+          rw [cuspFullForward_openInclusion Y hY q hq]
+          rw [cuspFullInverse_of_mem Y hY _ (cuspImageHomeomorph Y hY ⟨q, hq⟩).property]
+          change
+            SpecialPeriods.triangleOpenInclusion
+                ((cuspImageHomeomorph Y hY).symm (cuspImageHomeomorph Y hY ⟨q, hq⟩)) =
+              _
+          rw [Homeomorph.symm_apply_apply]
+      right_inv' := by
+        intro z hz
+        by_cases h0 : z = 0
+        · subst z
+          rw [cuspFullInverse_zero, cuspFullForward_cuspPoint]
+        · have hp : z ∈ puncturedCuspBall Y := ⟨h0, by simpa using hz⟩
+          rw [cuspFullInverse_of_mem Y hY z hp]
+          rw [cuspFullForward_openInclusion Y hY _
+              ((cuspImageHomeomorph Y hY).symm ⟨z, hp⟩).property]
+          exact congrArg Subtype.val ((cuspImageHomeomorph Y hY).apply_symm_apply ⟨z, hp⟩)
+      open_source := (cuspNeighborhood Y).isOpen
+      open_target := Metric.isOpen_ball
+      continuousOn_toFun := cuspFullForward_continuousOn Y hY
+      continuousOn_invFun := cuspFullInverse_continuousOn Y hY }
+
+@[simp]
+private theorem SpecialPeriods.Triangle.cuspFullChart_source (Y : ℝ) (hY : width ≤ Y) :
+    (cuspFullChart Y hY).source =
+      (cuspNeighborhood Y : Set SpecialPeriods.TriangleCompactifiedOrbitSpace) :=
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.Triangle.cuspFullChart_target (Y : ℝ) (hY : width ≤ Y) :
+    (cuspFullChart Y hY).target = Metric.ball 0 (cuspRadius Y) :=
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.Triangle.cuspFullChart_cuspPoint (Y : ℝ) (hY : width ≤ Y) :
+    cuspFullChart Y hY SpecialPeriods.triangleCuspPoint = 0 :=
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.Triangle.cuspFullChart_symm_zero (Y : ℝ) (hY : width ≤ Y) :
+    (cuspFullChart Y hY).symm 0 = SpecialPeriods.triangleCuspPoint :=
+  cuspFullInverse_zero Y hY
+
+private theorem SpecialPeriods.Triangle.cuspFullChart_openInclusion (Y : ℝ) (hY : width ≤ Y)
+    (q : SpecialPeriods.TriangleOrbitSpace) (hq : q ∈ cuspImage Y) :
+    cuspFullChart Y hY (SpecialPeriods.triangleOpenInclusion q) =
+      (cuspImageHomeomorph Y hY ⟨q, hq⟩ : ℂ) :=
+  cuspFullForward_openInclusion Y hY q hq
+
+private theorem SpecialPeriods.Triangle.cuspFullChart_mk (Y : ℝ) (hY : width ≤ Y) (z : horodisc Y) :
+    cuspFullChart Y hY
+        (SpecialPeriods.triangleOpenInclusion
+          (SpecialPeriods.triangleOrbitProjection (z : UpperHalfPlane))) =
+      cuspQ (z : UpperHalfPlane) := by
+  change cuspFullChart Y hY (SpecialPeriods.triangleOpenInclusion (cuspImageProjection Y z)) = _
+  rw [cuspFullChart_openInclusion Y hY _ (cuspImageProjection Y z).property]
+  exact cuspImageHomeomorph_mk_coe Y hY z
+
+private theorem SpecialPeriods.cyclic_eq_positive_generator_pow_mo1973_16242 {n : ℕ} [NeZero n]
+    (a : Multiplicative (ZMod n)) (ha : a ≠ 1) :
+    ∃ k : ℕ, 0 < k ∧ k < n ∧ a = Multiplicative.ofAdd (1 : ZMod n) ^ k := by
+  refine ⟨a.toAdd.val, ZMod.val_pos.mpr ?_, ZMod.val_lt _, ?_⟩
+  · exact ha
+  · change a.toAdd = a.toAdd.val • (1 : ZMod n)
+    simp only [nsmul_eq_mul, mul_one, ZMod.natCast_zmod_val]
+
+private theorem SpecialPeriods.triangle_nontrivial_isOfFinOrder_conjugate_generator_power
+    (g : TriangleGroup) (hg : IsOfFinOrder g) (hne : g ≠ 1) :
+    (∃ n : ℕ, 0 < n ∧ n < 3 ∧ IsConj (triangleGenerator₁ ^ n) g) ∨
+      ∃ n : ℕ, 0 < n ∧ n < 4 ∧ IsConj (triangleGenerator₂ ^ n) g := by
+  obtain ⟨a, hane, ha⟩ | ⟨a, hane, ha⟩ :=
+    CoprodTorsion.coprod_nontrivial_isOfFinOrder_conjugate_factor g hg hne
+  · obtain ⟨n, hn0, hn3, rfl⟩ := cyclic_eq_positive_generator_pow_mo1973_16242 a hane
+    exact Or.inl ⟨n, hn0, hn3, by simpa only [map_pow, triangleGenerator₁] using ha⟩
+  · obtain ⟨n, hn0, hn4, rfl⟩ := cyclic_eq_positive_generator_pow_mo1973_16242 a hane
+    exact Or.inr ⟨n, hn0, hn4, by simpa only [map_pow, triangleGenerator₂] using ha⟩
+
+private theorem SpecialPeriods.triangle_nontrivial_isOfFinOrder_eq_conjugate_generator_power
+    (g : TriangleGroup) (hg : IsOfFinOrder g) (hne : g ≠ 1) :
+    (∃ (h : TriangleGroup) (n : ℕ), 0 < n ∧ n < 3 ∧ g = h * triangleGenerator₁ ^ n * h⁻¹) ∨
+      (∃ (h : TriangleGroup) (n : ℕ), 0 < n ∧ n < 4 ∧ g = h * triangleGenerator₂ ^ n * h⁻¹) := by
+  obtain ⟨n, hn0, hn3, hn⟩ | ⟨n, hn0, hn4, hn⟩ :=
+    triangle_nontrivial_isOfFinOrder_conjugate_generator_power g hg hne
+  · obtain ⟨h, hh⟩ := isConj_iff.mp hn
+    exact Or.inl ⟨h, n, hn0, hn3, hh.symm⟩
+  · obtain ⟨h, hh⟩ := isConj_iff.mp hn
+    exact Or.inr ⟨h, n, hn0, hn4, hh.symm⟩
+
+private def SpecialPeriods.rhoPoint : ℍ :=
+  ⟨rho, rho_im_pos⟩
+
+@[simp]
+private theorem SpecialPeriods.coe_rhoPoint : (rhoPoint : ℂ) = rho :=
+  rfl
+
+private theorem SpecialPeriods.rho_ne_zero : rho ≠ 0 :=
+  rhoPoint.ne_zero
+
+private theorem SpecialPeriods.rho_fourth : rho ^ 4 = -rho := by
+  calc
+    rho ^ 4 = rho ^ 3 * rho := by ring
+    _ = -rho := by rw [rho_cube]; ring
+
+private theorem SpecialPeriods.rho_fourth_ne_one : rho ^ 4 ≠ 1 := by
+  intro h
+  have hr : rho = -1 := neg_eq_iff_eq_neg.mp (rho_fourth.symm.trans h)
+  have := rho_im_pos
+  simp [hr] at this
+
+private theorem SpecialPeriods.TS_smul_rhoPoint :
+    (ModularGroup.T * ModularGroup.S) • rhoPoint = rhoPoint := by
+  rw [SemigroupAction.mul_smul, UpperHalfPlane.modular_T_smul, UpperHalfPlane.modular_S_smul]
+  apply UpperHalfPlane.ext
+  simp only [UpperHalfPlane.coe_vadd, Complex.ofReal_one, coe_rhoPoint, inv_neg]
+  field_simp [rho_ne_zero]
+  linear_combination -rho_sq
+
+private theorem SpecialPeriods.S_smul_I : ModularGroup.S • UpperHalfPlane.I = UpperHalfPlane.I := by
+  rw [UpperHalfPlane.modular_S_smul]
+  apply UpperHalfPlane.ext
+  simp only [UpperHalfPlane.coe_I, inv_neg, Complex.inv_I, neg_neg]
+
+private theorem
+    SpecialPeriods.levelOne_transform {k : ℤ} (f : ModularForm 𝒮ℒ k) (g : SL(2, ℤ)) (z : ℍ) :
+    f (g • z) = (UpperHalfPlane.denom g z) ^ k * f z :=
+  SlashInvariantForm.slash_action_eqn'' f (show (g : GL (Fin 2) ℝ) ∈ 𝒮ℒ from ⟨g, rfl⟩) z
+
+private theorem SpecialPeriods.E₄_rhoPoint : ModularForm.E₄ rhoPoint = 0 := by
+  have h := levelOne_transform ModularForm.E₄ (ModularGroup.T * ModularGroup.S) rhoPoint
+  rw [TS_smul_rhoPoint] at h
+  have hd : UpperHalfPlane.denom (ModularGroup.T * ModularGroup.S : SL(2, ℤ)) rhoPoint = rho := by
+    have h10 : (ModularGroup.T * ModularGroup.S : SL(2, ℤ)) 1 0 = 1 := by decide
+    have h11 : (ModularGroup.T * ModularGroup.S : SL(2, ℤ)) 1 1 = 0 := by decide
+    rw [ModularGroup.denom_apply, h10, h11]
+    simp
+  rw [hd, zpow_ofNat] at h
+  exact
+    (mul_eq_zero.mp
+          (show (rho ^ 4 - 1) * ModularForm.E₄ rhoPoint = 0 by
+            linear_combination -h)).resolve_left
+      (sub_ne_zero.mpr rho_fourth_ne_one)
+
+private theorem SpecialPeriods.E₆_I : ModularForm.E₆ UpperHalfPlane.I = 0 := by
+  have h := levelOne_transform ModularForm.E₆ ModularGroup.S UpperHalfPlane.I
+  rw [S_smul_I, ModularGroup.denom_S, UpperHalfPlane.coe_I, zpow_ofNat] at h
+  have hi : Complex.I ^ 6 = -1 := by norm_num [Complex.I_sq, pow_succ]
+  rw [hi] at h
+  linear_combination h / 2
+
+private theorem SpecialPeriods.E₄_E₆_not_both_zero (z : ℍ) :
+    ModularForm.E₄ z ≠ 0 ∨ ModularForm.E₆ z ≠ 0 := by
+  by_contra! h
+  have hd := ModularForm.discriminant_ne_zero z
+  rw [ModularForm.discriminant_eq_E₄_cube_sub_E₆_sq, h.1, h.2] at hd
+  norm_num at hd
+
+private theorem SpecialPeriods.E₆_rhoPoint_ne_zero : ModularForm.E₆ rhoPoint ≠ 0 := by
+  simpa only [E₄_rhoPoint, ne_self_iff_false, false_or] using E₄_E₆_not_both_zero rhoPoint
+
+private theorem SpecialPeriods.E₄_I_ne_zero : ModularForm.E₄ UpperHalfPlane.I ≠ 0 := by
+  simpa only [E₆_I, ne_self_iff_false, or_false] using E₄_E₆_not_both_zero UpperHalfPlane.I
+
+private theorem SpecialPeriods.levelOne_eq_of_qExpansion_coeff_zero {k : ℤ} (hk : k < 12)
+    (f g : ModularForm 𝒮ℒ k)
+    (hfg : (UpperHalfPlane.qExpansion 1 f).coeff 0 = (UpperHalfPlane.qExpansion 1 g).coeff 0) :
+    f = g := by
+  have hq : (UpperHalfPlane.qExpansion 1 (f - g)).coeff 0 = 0 := by
+    rw [ModularForm.qExpansion_sub one_pos one_mem_strictPeriods_SL, map_sub, hfg, sub_self]
+  have hzero : ModularForm.toCuspForm (f - g) hq = 0 :=
+    rank_zero_iff_forall_zero.mp (CuspForm.rank_eq_zero_of_weight_lt_twelve hk) _
+  ext z
+  have hz := congrArg (fun F : CuspForm 𝒮ℒ k => F z) hzero
+  exact sub_eq_zero.mp hz
+
+private theorem SpecialPeriods.modularForm_analyticAt {k : ℤ} (f : ModularForm 𝒮ℒ k) (z : ℍ) :
+    AnalyticAt ℂ (f ∘ UpperHalfPlane.ofComplex) (z : ℂ) :=
+  (UpperHalfPlane.mdifferentiable_iff.mp f.holo').analyticOnNhd
+    UpperHalfPlane.isOpen_upperHalfPlaneSet _ z.im_pos
+
+private def SpecialPeriods.modularJ (z : ℍ) : ℂ :=
+  ModularForm.E₄ z ^ 3 / ModularForm.discriminant z
+
+private theorem SpecialPeriods.modularJ_mdifferentiable : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) modularJ :=
+  (ModularForm.E₄.holo'.pow 3).div CuspForm.discriminant.holo' ModularForm.discriminant_ne_zero
+
+private theorem SpecialPeriods.modularJ_analyticAt (z : ℍ) :
+    AnalyticAt ℂ (modularJ ∘ UpperHalfPlane.ofComplex) z :=
+  (UpperHalfPlane.mdifferentiable_iff.mp modularJ_mdifferentiable).analyticAt
+    (UpperHalfPlane.isOpen_upperHalfPlaneSet.mem_nhds z.im_pos)
+
+private theorem SpecialPeriods.modularJ_holomorphic : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω modularJ := by
+  intro z
+  exact UpperHalfPlane.contMDiffAt_iff.mpr (modularJ_analyticAt z).contDiffAt
+
+private theorem SpecialPeriods.modularJ_continuous : Continuous modularJ :=
+  modularJ_holomorphic.continuous
+
+private theorem SpecialPeriods.modularJ_invariant (γ : GL (Fin 2) ℝ) (hγ : γ ∈ 𝒮ℒ) (z : ℍ) :
+    modularJ (γ • z) = modularJ z := by
+  have h₄ := SlashInvariantForm.slash_action_eqn'' ModularForm.E₄ hγ z
+  have hΔ := SlashInvariantForm.slash_action_eqn'' CuspForm.discriminant hγ z
+  change
+    ModularForm.discriminant (γ • z) =
+      UpperHalfPlane.denom γ z ^ (12 : ℤ) * ModularForm.discriminant z at hΔ
+  simp only [modularJ, h₄, hΔ, zpow_ofNat, mul_pow, ← pow_mul]
+  norm_num
+  exact mul_div_mul_left _ _ (pow_ne_zero 12 (UpperHalfPlane.denom_ne_zero γ z))
+
+private theorem SpecialPeriods.modularJ_SL_invariant (γ : SL(2, ℤ)) (z : ℍ) :
+    modularJ (γ • z) = modularJ z :=
+  modularJ_invariant γ (MonoidHom.mem_range.mpr ⟨γ, rfl⟩) z
+
+private theorem SpecialPeriods.modularJ_sub_1728 (z : ℍ) :
+    modularJ z - 1728 = ModularForm.E₆ z ^ 2 / ModularForm.discriminant z := by
+  have h := ModularForm.discriminant_eq_E₄_cube_sub_E₆_sq z
+  rw [eq_div_iff (by norm_num : (1728 : ℂ) ≠ 0)] at h
+  unfold modularJ
+  field_simp [ModularForm.discriminant_ne_zero z]
+  linear_combination -h
+
+private theorem
+    SpecialPeriods.modularJ_eq_zero_iff (z : ℍ) : modularJ z = 0 ↔ ModularForm.E₄ z = 0 := by
+  simp [modularJ, ModularForm.discriminant_ne_zero]
+
+private theorem
+    SpecialPeriods.modularJ_eq_1728_iff (z : ℍ) : modularJ z = 1728 ↔ ModularForm.E₆ z = 0 := by
+  rw [← sub_eq_zero, modularJ_sub_1728]
+  simp [ModularForm.discriminant_ne_zero]
+
+@[simp]
+private theorem SpecialPeriods.modularJ_rhoPoint : modularJ rhoPoint = 0 :=
+  (modularJ_eq_zero_iff rhoPoint).mpr E₄_rhoPoint
+
+@[simp]
+private theorem SpecialPeriods.modularJ_I : modularJ UpperHalfPlane.I = 1728 :=
+  (modularJ_eq_1728_iff UpperHalfPlane.I).mpr E₆_I
+
+private def SpecialPeriods.discriminantUnit (q : ℂ) : ℂ :=
+  ∏' n : ℕ, (1 - q ^ (n + 1)) ^ 24
+
+@[simp]
+private theorem SpecialPeriods.discriminantUnit_zero : discriminantUnit 0 = 1 := by
+  simp [discriminantUnit]
+
+private theorem SpecialPeriods.discriminantUnit_differentiableOn :
+    DifferentiableOn ℂ discriminantUnit (Metric.ball 0 1) :=
+  ModularForm.differentiableOn_tprod_one_sub_pow_pow 24
+
+private theorem SpecialPeriods.discriminantUnit_analyticAt_zero : AnalyticAt ℂ discriminantUnit 0 :=
+  discriminantUnit_differentiableOn.analyticAt (Metric.ball_mem_nhds (0 : ℂ) zero_lt_one)
+
+private def SpecialPeriods.modularJUnit (q : ℂ) : ℂ :=
+  UpperHalfPlane.cuspFunction 1 ModularForm.E₄ q ^ 3 / discriminantUnit q
+
+private theorem SpecialPeriods.E₄_cuspFunction_zero :
+    UpperHalfPlane.cuspFunction 1 ModularForm.E₄ 0 = 1 := by
+  have h :=
+    EisensteinSeries.E_qExpansion_coeff_zero (show 3 ≤ 4 by decide) (show Even 4 by decide)
+  simpa [UpperHalfPlane.qExpansion_coeff] using h
+
+@[simp]
+private theorem SpecialPeriods.modularJUnit_zero : modularJUnit 0 = 1 := by
+  simp [modularJUnit, E₄_cuspFunction_zero]
+
+private theorem SpecialPeriods.modularJUnit_analyticAt_zero : AnalyticAt ℂ modularJUnit 0 :=
+  ((ModularFormClass.analyticAt_cuspFunction_zero ModularForm.E₄ zero_lt_one
+            one_mem_strictPeriods_SL).pow
+        3).div
+    discriminantUnit_analyticAt_zero (by simp)
+
+private theorem SpecialPeriods.modularJ_eq_unit_div_q (z : ℍ) :
+    modularJ z = modularJUnit (Function.Periodic.qParam 1 z) / Function.Periodic.qParam 1 z := by
+  have hE :=
+    SlashInvariantFormClass.eq_cuspFunction ModularForm.E₄ z one_mem_strictPeriods_SL one_ne_zero
+  have hΔ := ModularForm.discriminant_eq_q_prod z
+  change
+    ModularForm.discriminant z =
+      Function.Periodic.qParam 1 z * discriminantUnit (Function.Periodic.qParam 1 z) at hΔ
+  rw [modularJ, hΔ, modularJUnit, hE]
+  rw [div_div, mul_comm]
+
+private def SpecialPeriods.modularJInQ (q : ℂ) : ℂ :=
+  modularJUnit q / q
+
+private theorem SpecialPeriods.modularJInQ_qParam (z : ℍ) :
+    modularJInQ (Function.Periodic.qParam 1 z) = modularJ z :=
+  (modularJ_eq_unit_div_q z).symm
+
+private theorem SpecialPeriods.modularJInQ_order : meromorphicOrderAt modularJInQ 0 = (-1 : ℤ) := by
+  have hu : meromorphicOrderAt modularJUnit 0 = 0 := by
+    rw [modularJUnit_analyticAt_zero.meromorphicOrderAt_eq,
+      (modularJUnit_analyticAt_zero.analyticOrderAt_eq_zero.mpr (by simp))]
+    rfl
+  change meromorphicOrderAt (modularJUnit / id) 0 = _
+  rw [meromorphicOrderAt_div modularJUnit_analyticAt_zero.meromorphicAt
+      analyticAt_id.meromorphicAt,
+    hu, meromorphicOrderAt_id]
+  norm_num
+
+private theorem SpecialPeriods.q_mul_modularJ_tendsto :
+    Filter.Tendsto (fun z : ℍ => Function.Periodic.qParam 1 z * modularJ z)
+      UpperHalfPlane.atImInfty (𝓝 1) := by
+  have h :=
+    modularJUnit_analyticAt_zero.continuousAt.tendsto.comp
+      (UpperHalfPlane.qParam_tendsto_atImInfty zero_lt_one)
+  simp only [modularJUnit_zero, Function.comp_def] at h
+  apply h.congr
+  intro z
+  rw [modularJ_eq_unit_div_q]
+  exact (mul_div_cancel₀ _ (Function.Periodic.qParam_ne_zero z)).symm
+
+private theorem SpecialPeriods.norm_modularJ_tendsto :
+    Filter.Tendsto (fun z : ℍ => ‖modularJ z‖) UpperHalfPlane.atImInfty Filter.atTop := by
+  have hq :
+    Filter.Tendsto (fun z : ℍ => Function.Periodic.qParam 1 z) UpperHalfPlane.atImInfty
+      (𝓝[≠] (0 : ℂ)) := by
+    apply tendsto_nhdsWithin_iff.mpr
+    refine ⟨UpperHalfPlane.qParam_tendsto_atImInfty zero_lt_one, ?_⟩
+    exact Filter.Eventually.of_forall (fun z => Function.Periodic.qParam_ne_zero z)
+  have hj : Filter.Tendsto modularJInQ (𝓝[≠] (0 : ℂ)) (Bornology.cobounded ℂ) :=
+    tendsto_cobounded_of_meromorphicOrderAt_neg
+      (by
+        rw [modularJInQ_order]
+        exact_mod_cast (show (-1 : ℤ) < 0 by norm_num))
+  have h := (tendsto_norm_atTop_iff_cobounded.mpr hj).comp hq
+  simpa only [Function.comp_def, modularJInQ_qParam] using h
+
+private theorem SpecialPeriods.modularJ_not_constant : ¬∃ c : ℂ, ∀ z : ℍ, modularJ z = c := by
+  rintro ⟨c, hc⟩
+  have h :
+    Filter.Tendsto (fun z : ℍ => Function.Periodic.qParam 1 z * c) UpperHalfPlane.atImInfty
+      (𝓝 0) := by simpa using (UpperHalfPlane.qParam_tendsto_atImInfty zero_lt_one).mul_const c
+  have h' :
+    Filter.Tendsto (fun z : ℍ => Function.Periodic.qParam 1 z * c) UpperHalfPlane.atImInfty
+      (𝓝 1) := by simpa only [hc] using q_mul_modularJ_tendsto
+  exact zero_ne_one (tendsto_nhds_unique h h')
+
+private theorem SpecialPeriods.inv_modularJ_sub_tendsto (c : ℂ) :
+    Filter.Tendsto (fun z : ℍ => (modularJ z - c)⁻¹) UpperHalfPlane.atImInfty (𝓝 0) := by
+  exact
+    Filter.tendsto_inv₀_cobounded.comp
+      ((tendsto_sub_const_cobounded c).comp
+        (tendsto_norm_atTop_iff_cobounded.mp norm_modularJ_tendsto))
+
+private theorem SpecialPeriods.inv_modularJ_sub_slash_mo1973_16294 (c : ℂ) (γ : SL(2, ℤ)) :
+    (fun z : ℍ => (modularJ z - c)⁻¹) ∣[(0 : ℤ)] γ = fun z : ℍ => (modularJ z - c)⁻¹ := by
+  funext z
+  simp only [ModularForm.SL_slash_apply, neg_zero, zpow_zero, mul_one]
+  exact congrArg (fun w : ℂ => (w - c)⁻¹) (modularJ_SL_invariant γ z)
+
+private def SpecialPeriods.omittedValueModularForm_mo1973_16295 (c : ℂ)
+    (hc : ∀ z : ℍ, modularJ z ≠ c) : ModularForm 𝒮ℒ 0
+    where
+  toFun z := (modularJ z - c)⁻¹
+  slash_action_eq' := by
+    rintro γ ⟨γ', rfl⟩
+    exact inv_modularJ_sub_slash_mo1973_16294 c γ'
+  holo' :=
+    (modularJ_mdifferentiable.sub mdifferentiable_const).inv (fun z => sub_ne_zero.mpr (hc z))
+  bdd_at_cusps' {s}
+    hs := by
+    rw [OnePoint.isBoundedAt_iff_forall_SL2Z hs]
+    intro γ _
+    rw [inv_modularJ_sub_slash_mo1973_16294]
+    exact Filter.ZeroAtFilter.boundedAtFilter (inv_modularJ_sub_tendsto c)
+
+private theorem SpecialPeriods.modularJ_surjective : Function.Surjective modularJ := by
+  intro c
+  by_contra h
+  have hc : ∀ z : ℍ, modularJ z ≠ c := fun z hz => h ⟨z, hz⟩
+  let f := omittedValueModularForm_mo1973_16295 c hc
+  obtain ⟨a, ha⟩ := ModularFormClass.levelOne_weight_zero_const f
+  have hlim : Filter.Tendsto (fun _ : ℍ => a) UpperHalfPlane.atImInfty (𝓝 (0 : ℂ)) := by
+    change Filter.Tendsto (Function.const ℍ a) UpperHalfPlane.atImInfty (𝓝 (0 : ℂ))
+    rw [← ha]
+    exact inv_modularJ_sub_tendsto c
+  have ha₀ : a = 0 := tendsto_nhds_unique tendsto_const_nhds hlim
+  have hz : (modularJ UpperHalfPlane.I - c)⁻¹ = 0 := by
+    have he := congr_fun ha UpperHalfPlane.I
+    change (modularJ UpperHalfPlane.I - c)⁻¹ = a at he
+    exact he.trans ha₀
+  exact inv_ne_zero (sub_ne_zero.mpr (hc UpperHalfPlane.I)) hz
+
+private theorem
+    SpecialPeriods.modularJ_eventually_ne (c : ℂ) (z : ℍ) : ∀ᶠ w in 𝓝[≠] z, modularJ w ≠ c := by
+  by_contra h
+  have hfreq : ∃ᶠ w in 𝓝[≠] z, modularJ w = c := by
+    simpa only [Classical.not_not] using (Filter.not_eventually.mp h)
+  have hzero : (fun w : ℍ => modularJ w - c) = 0 :=
+    UpperHalfPlane.eq_zero_of_frequently (modularJ_mdifferentiable.sub mdifferentiable_const)
+      (hfreq.mono fun w hw => sub_eq_zero.mpr hw)
+  apply modularJ_not_constant
+  exact ⟨c, fun w => sub_eq_zero.mp (congr_fun hzero w)⟩
+
+private theorem
+    SpecialPeriods.modularJ_preimage_finite_closed_discrete {s : Set ℂ} (hs : s.Finite) :
+    IsClosed (modularJ ⁻¹' s) ∧ IsDiscrete (modularJ ⁻¹' s) := by
+  rw [isClosed_and_discrete_iff]
+  intro z
+  rw [Filter.disjoint_principal_right]
+  have h : ∀ᶠ w in 𝓝[≠] z, ∀ c ∈ s, modularJ w ≠ c :=
+    hs.eventually_all.mpr (fun c _ => modularJ_eventually_ne c z)
+  exact h.mono fun w hw hmem => hw (modularJ w) hmem rfl
+
+private theorem
+    SpecialPeriods.modularJ_fibre_isClosed (c : ℂ) : IsClosed {z : ℍ | modularJ z = c} :=
+  (modularJ_preimage_finite_closed_discrete (Set.finite_singleton c)).1
+
+private theorem
+    SpecialPeriods.modularJ_fibre_isDiscrete (c : ℂ) : IsDiscrete {z : ℍ | modularJ z = c} :=
+  (modularJ_preimage_finite_closed_discrete (Set.finite_singleton c)).2
+
+private theorem SpecialPeriods.modularJ_isOpenMap : IsOpenMap modularJ := by
+  have hA : AnalyticOnNhd ℂ (modularJ ∘ UpperHalfPlane.ofComplex) {z : ℂ | 0 < z.im} := by
+    intro z hz
+    exact modularJ_analyticAt ⟨z, hz⟩
+  have hU : IsPreconnected {z : ℂ | 0 < z.im} := (convex_halfSpace_im_gt 0).isPreconnected
+  have hO :=
+    (hA.is_constant_or_isOpen hU).resolve_left
+      (by
+        rintro ⟨c, hc⟩
+        apply modularJ_not_constant
+        refine ⟨c, fun z => ?_⟩
+        simpa only [Function.comp_apply, UpperHalfPlane.ofComplex_apply] using hc z z.im_pos)
+  intro s hs
+  have ho :=
+    hO (((↑) : ℍ → ℂ) '' s)
+      (by
+        rintro _ ⟨z, _, rfl⟩
+        exact z.im_pos)
+      (UpperHalfPlane.isOpenEmbedding_coe.isOpenMap s hs)
+  simpa only [Set.image_image, Function.comp_def, UpperHalfPlane.ofComplex_apply] using ho
+
+private def SpecialPeriods.upperHalfPlaneEuclideanHomeomorph_mo1973_16307 : ℂ ≃ₜ ℍ
+    where
+  toFun z := ⟨⟨z.re, Real.exp z.im⟩, Real.exp_pos z.im⟩
+  invFun z := ⟨z.re, Real.log z.im⟩
+  left_inv z := by apply Complex.ext <;> simp
+  right_inv
+    z := by
+    apply UpperHalfPlane.ext
+    apply Complex.ext <;> simp [Real.exp_log z.im_pos]
+  continuous_toFun :=
+    Continuous.upperHalfPlaneMk
+      (Complex.equivRealProdCLM.symm.continuous.comp
+        (Complex.continuous_re.prodMk (Real.continuous_exp.comp Complex.continuous_im)))
+      (fun z => Real.exp_pos z.im)
+  continuous_invFun :=
+    Complex.equivRealProdCLM.symm.continuous.comp
+      (UpperHalfPlane.continuous_re.prodMk
+        (UpperHalfPlane.continuous_im.log (fun z => ne_of_gt z.im_pos)))
+
+private theorem SpecialPeriods.upperHalfPlane_compl_isPathConnected_of_countable {s : Set ℍ}
+    (hs : s.Countable) : IsPathConnected sᶜ := by
+  let e := upperHalfPlaneEuclideanHomeomorph_mo1973_16307
+  have h : IsPathConnected (e ⁻¹' s)ᶜ :=
+    (hs.preimage e.injective).isPathConnected_compl_of_one_lt_rank (by simp)
+  exact e.isPathConnected_preimage.mp h
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangleGenerator₁_ne_one : triangleGenerator₁ ≠ 1 := by
+  intro h
+  have ho := triangleGenerator₁_order
+  simp [h] at ho
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangleGenerator₂_ne_one : triangleGenerator₂ ≠ 1 := by
+  intro h
+  have ho := triangleGenerator₂_order
+  simp [h] at ho
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangle_generator₁_pow_apply (n : ℕ) (z : ℍ) :
+    triangleGeometricRepresentation (triangleGenerator₁ ^ n) z =
+      Triangle.generatorOneSL ^ n • z := by
+  rw [map_pow, triangleGeometricRepresentation_generator₁]
+  exact Triangle.generatorOnePerm_pow_apply n z
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangle_generator₂_pow_apply (n : ℕ) (z : ℍ) :
+    triangleGeometricRepresentation (triangleGenerator₂ ^ n) z =
+      Triangle.generatorTwoSL ^ n • z := by
+  rw [map_pow, triangleGeometricRepresentation_generator₂]
+  exact Triangle.generatorTwoPerm_pow_apply n z
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangle_generator₁_pow_fixed_iff (n : ℕ) (hn : 0 < n) (hn' : n < 3)
+    (z : ℍ) :
+    triangleGeometricRepresentation (triangleGenerator₁ ^ n) z = z ↔ z = Triangle.centerOne := by
+  rw [triangle_generator₁_pow_apply]
+  exact Triangle.generatorOne_pow_fixed_iff n hn hn' z
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangle_generator₂_pow_fixed_iff (n : ℕ) (hn : 0 < n) (hn' : n < 4)
+    (z : ℍ) :
+    triangleGeometricRepresentation (triangleGenerator₂ ^ n) z = z ↔ z = Triangle.centerTwo := by
+  rw [triangle_generator₂_pow_apply]
+  exact Triangle.generatorTwo_pow_fixed_iff n hn hn' z
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangle_conjugate_fixed_iff_mo1973_16318 (g h : TriangleGroup)
+    (z : ℍ) :
+    triangleGeometricRepresentation (h * g * h⁻¹) z = z ↔
+      triangleGeometricRepresentation g (triangleGeometricRepresentation h⁻¹ z) =
+        triangleGeometricRepresentation h⁻¹ z := by
+  change (h * g * h⁻¹) • z = z ↔ g • (h⁻¹ • z) = h⁻¹ • z
+  constructor
+  · intro hz
+    simpa only [SemigroupAction.mul_smul, inv_smul_smul] using congrArg (fun x : ℍ => h⁻¹ • x) hz
+  · intro hz
+    simpa only [SemigroupAction.mul_smul, smul_inv_smul] using congrArg (fun x : ℍ => h • x) hz
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangle_conjugate_generator₁_fixed_iff (h : TriangleGroup) (n : ℕ)
+    (hn : 0 < n) (hn' : n < 3) (z : ℍ) :
+    triangleGeometricRepresentation (h * triangleGenerator₁ ^ n * h⁻¹) z = z ↔
+      z = triangleGeometricRepresentation h Triangle.centerOne := by
+  rw [triangle_conjugate_fixed_iff_mo1973_16318, triangle_generator₁_pow_fixed_iff n hn hn']
+  change h⁻¹ • z = Triangle.centerOne ↔ z = h • Triangle.centerOne
+  exact inv_smul_eq_iff
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangle_conjugate_generator₂_fixed_iff (h : TriangleGroup) (n : ℕ)
+    (hn : 0 < n) (hn' : n < 4) (z : ℍ) :
+    triangleGeometricRepresentation (h * triangleGenerator₂ ^ n * h⁻¹) z = z ↔
+      z = triangleGeometricRepresentation h Triangle.centerTwo := by
+  rw [triangle_conjugate_fixed_iff_mo1973_16318, triangle_generator₂_pow_fixed_iff n hn hn']
+  change h⁻¹ • z = Triangle.centerTwo ↔ z = h • Triangle.centerTwo
+  exact inv_smul_eq_iff
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangle_centerOne_not_regular :
+    Triangle.centerOne ∉ triangleRegularLocus := by
+  intro h
+  rw [mem_triangleRegularLocus_iff] at h
+  exact
+    triangleGenerator₁_ne_one
+      (h triangleGenerator₁
+        ((triangleGeometricRepresentation_generator₁_apply _).trans Triangle.generatorOne_fix))
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangle_centerTwo_not_regular :
+    Triangle.centerTwo ∉ triangleRegularLocus := by
+  intro h
+  rw [mem_triangleRegularLocus_iff] at h
+  exact
+    triangleGenerator₂_ne_one
+      (h triangleGenerator₂
+        ((triangleGeometricRepresentation_generator₂_apply _).trans Triangle.generatorTwo_fix))
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.triangleEllipticSet : Set ℍ :=
+  Set.range (fun g : TriangleGroup => triangleGeometricRepresentation g Triangle.centerOne) ∪
+    Set.range (fun g : TriangleGroup => triangleGeometricRepresentation g Triangle.centerTwo)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangleRegularLocus_eq_compl_ellipticSet :
+    triangleRegularLocus = triangleEllipticSetᶜ := by
+  ext z
+  constructor
+  · intro hz hze
+    rcases hze with ⟨g, rfl⟩ | ⟨g, rfl⟩
+    · exact
+        triangle_centerOne_not_regular
+          ((triangleRegularLocus_invariant g Triangle.centerOne).mp hz)
+    · exact
+        triangle_centerTwo_not_regular
+          ((triangleRegularLocus_invariant g Triangle.centerTwo).mp hz)
+  · intro hz g hg
+    by_contra hgne
+    obtain ⟨h, n, hn, hn', hgh⟩ | ⟨h, n, hn, hn', hgh⟩ :=
+      triangle_nontrivial_isOfFinOrder_eq_conjugate_generator_power g
+        (triangle_isOfFinOrder_of_fixed g z hg) hgne
+    · rw [hgh] at hg
+      exact hz (Or.inl ⟨h, ((triangle_conjugate_generator₁_fixed_iff h n hn hn' z).mp hg).symm⟩)
+    · rw [hgh] at hg
+      exact hz (Or.inr ⟨h, ((triangle_conjugate_generator₂_fixed_iff h n hn hn' z).mp hg).symm⟩)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangle_orbit_inter_compact_finite (a : ℍ) {K : Set ℍ}
+    (hK : IsCompact K) :
+    (Set.range (fun g : TriangleGroup => triangleGeometricRepresentation g a) ∩ K).Finite := by
+  have hf : {g : TriangleGroup | triangleGeometricRepresentation g a ∈ K}.Finite := by
+    simpa only [Set.image_singleton, Set.singleton_inter_nonempty,
+      triangleGeometricAction_smul] using
+      (ProperlyDiscontinuousSMul.finite_disjoint_inter_image (Γ := TriangleGroup)
+        (isCompact_singleton (x := a)) hK)
+  convert hf.image (fun g : TriangleGroup => triangleGeometricRepresentation g a) using 1
+  ext z
+  constructor
+  · rintro ⟨⟨g, rfl⟩, hg⟩
+    exact ⟨g, hg, rfl⟩
+  · rintro ⟨g, hg, rfl⟩
+    exact ⟨⟨g, rfl⟩, hg⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem
+    SpecialPeriods.triangleEllipticSet_inter_compact_finite {K : Set ℍ} (hK : IsCompact K) :
+    (triangleEllipticSet ∩ K).Finite := by
+  rw [triangleEllipticSet, Set.union_inter_distrib_right]
+  exact
+    (triangle_orbit_inter_compact_finite Triangle.centerOne hK).union
+      (triangle_orbit_inter_compact_finite Triangle.centerTwo hK)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangleEllipticSet_closed_discrete :
+    IsClosed triangleEllipticSet ∧ IsDiscrete triangleEllipticSet := by
+  rw [isClosed_and_discrete_iff]
+  intro z
+  obtain ⟨K, hK, hKz⟩ := WeaklyLocallyCompactSpace.exists_compact_mem_nhds z
+  have hf := triangleEllipticSet_inter_compact_finite hK
+  have hf' : ((triangleEllipticSet ∩ K) ∩ ({ z } : Set ℍ)ᶜ).Finite :=
+    hf.subset Set.inter_subset_left
+  have hU : ((triangleEllipticSet ∩ K) ∩ ({ z } : Set ℍ)ᶜ)ᶜ ∈ 𝓝 z :=
+    hf'.isClosed.isOpen_compl.mem_nhds (by simp)
+  rw [Filter.disjoint_principal_right]
+  filter_upwards [nhdsWithin_le_nhds hKz, nhdsWithin_le_nhds hU, self_mem_nhdsWithin] with y hyK
+    hyU hyz
+  intro hyE
+  exact hyU ⟨⟨hyE, hyK⟩, hyz⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangleEllipticSet_isDiscrete : IsDiscrete triangleEllipticSet :=
+  triangleEllipticSet_closed_discrete.2
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangleEllipticSet_countable : triangleEllipticSet.Countable :=
+  (HereditarilyLindelofSpace.isLindelof triangleEllipticSet).countable_of_isDiscrete
+    triangleEllipticSet_isDiscrete
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangleRegularLocus_isPathConnected :
+    IsPathConnected triangleRegularLocus := by
+  rw [triangleRegularLocus_eq_compl_ellipticSet]
+  exact upperHalfPlane_compl_isPathConnected_of_countable triangleEllipticSet_countable
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private instance SpecialPeriods.triangleRegularPoint_pathConnected :
+    PathConnectedSpace TriangleRegularPoint :=
+  isPathConnected_iff_pathConnectedSpace.mp triangleRegularLocus_isPathConnected
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private instance SpecialPeriods.triangleRegularQuotient_pathConnected :
+    PathConnectedSpace TriangleRegularQuotient :=
+  triangleRegularProject_surjective.pathConnectedSpace triangleRegularProject_covering.continuous
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.triangleRegularToOrbit : TriangleRegularQuotient → TriangleOrbitSpace :=
+  Quotient.lift (fun z : TriangleRegularPoint => triangleOrbitProjection z.val) fun x y h =>
+    by
+    obtain ⟨g, hg⟩ := h
+    apply (triangleOrbitProjection_eq_iff _ _).mpr
+    exact ⟨g, congrArg Subtype.val hg⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+@[simp]
+private theorem SpecialPeriods.triangleRegularToOrbit_project (z : TriangleRegularPoint) :
+    triangleRegularToOrbit (triangleRegularProject z) = triangleOrbitProjection z.val :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem
+    SpecialPeriods.triangleRegularToOrbit_continuous : Continuous triangleRegularToOrbit :=
+  (triangleOrbitProjection_continuous.comp continuous_subtype_val).quotient_lift _
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangleRegularToOrbit_injective :
+    Function.Injective triangleRegularToOrbit := by
+  intro x y
+  refine Quotient.inductionOn₂ x y ?_
+  intro a b hab
+  obtain ⟨g, hg⟩ := (triangleOrbitProjection_eq_iff _ _).mp hab
+  apply Quotient.sound
+  exact ⟨g, Subtype.ext hg⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem
+    SpecialPeriods.triangleRegularToOrbit_isOpenMap : IsOpenMap triangleRegularToOrbit :=
+  IsOpenMap.of_comp triangleRegularProject_covering.continuous triangleRegularProject_surjective
+    (triangleOrbitProjection_isOpenMap.comp triangleRegularDomain.isOpen.isOpenMap_subtype_val)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangleRegularToOrbit_isOpenEmbedding :
+    Topology.IsOpenEmbedding triangleRegularToOrbit :=
+  Topology.IsOpenEmbedding.of_continuous_injective_isOpenMap triangleRegularToOrbit_continuous
+    triangleRegularToOrbit_injective triangleRegularToOrbit_isOpenMap
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangleRegularToOrbit_range :
+    Set.range triangleRegularToOrbit = triangleOrbitProjection '' triangleRegularLocus := by
+  ext x
+  constructor
+  · rintro ⟨y, rfl⟩
+    obtain ⟨z, rfl⟩ := triangleRegularProject_surjective y
+    exact ⟨z.val, z.property, rfl⟩
+  · rintro ⟨z, hz, rfl⟩
+    exact ⟨triangleRegularProject ⟨z, hz⟩, rfl⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.triangleOrbitRegularDomain : TopologicalSpace.Opens TriangleOrbitSpace :=
+  ⟨Set.range triangleRegularToOrbit, triangleRegularToOrbit_isOpenEmbedding.isOpen_range⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangleOrbitProjection_mem_regularDomain_iff (z : ℍ) :
+    triangleOrbitProjection z ∈ triangleOrbitRegularDomain ↔ z ∈ triangleRegularLocus := by
+  change triangleOrbitProjection z ∈ Set.range triangleRegularToOrbit ↔ _
+  rw [triangleRegularToOrbit_range]
+  constructor
+  · rintro ⟨w, hw, he⟩
+    obtain ⟨g, hg⟩ := (triangleOrbitProjection_eq_iff _ _).mp he
+    exact (triangleRegularLocus_invariant g z).mp (hg ▸ hw)
+  · intro hz
+    exact ⟨z, hz, rfl⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.triangleOrbitRegularDomain_mem_iff (x : TriangleOrbitSpace) :
+    x ∈ triangleOrbitRegularDomain ↔ x ≠ triangleOrbitCenterOne ∧ x ≠ triangleOrbitCenterTwo := by
+  obtain ⟨z, rfl⟩ := triangleOrbitProjection_surjective x
+  rw [triangleOrbitProjection_mem_regularDomain_iff, triangleRegularLocus_eq_compl_ellipticSet]
+  simp only [triangleEllipticSet, Set.mem_compl_iff, Set.mem_union, Set.mem_range, not_or, ne_eq,
+    triangleOrbitCenterOne, triangleOrbitCenterTwo, triangleOrbitProjection_eq_iff]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.triangleRegularOrbitHomeomorph :
+    TriangleRegularQuotient ≃ₜ triangleOrbitRegularDomain :=
+  triangleRegularToOrbit_isOpenEmbedding.toIsEmbedding.toHomeomorph
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.triangleRegularOrbitParametrization :
+    OpenPartialHomeomorph TriangleRegularQuotient TriangleOrbitSpace :=
+  triangleRegularToOrbit_isOpenEmbedding.toOpenPartialHomeomorph triangleRegularToOrbit
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+@[simp]
+private theorem SpecialPeriods.triangleRegularOrbitParametrization_target :
+    triangleRegularOrbitParametrization.target =
+      (triangleOrbitRegularDomain : Set TriangleOrbitSpace) := by
+  simp [triangleRegularOrbitParametrization, triangleOrbitRegularDomain]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+@[simp]
+private theorem SpecialPeriods.triangleRegularOrbitParametrization_symm_apply
+    (x : TriangleRegularQuotient) :
+    triangleRegularOrbitParametrization.symm (triangleRegularToOrbit x) = x :=
+  triangleRegularOrbitParametrization.left_inv (Set.mem_univ x)
+
+private theorem
+    SpecialPeriods.Triangle.horodisc_subset_triangleRegularLocus (Y : ℝ) (hY : width ≤ Y) :
+    (horodisc Y : Set ℍ) ⊆ SpecialPeriods.triangleRegularLocus := by
+  intro z hz
+  apply (SpecialPeriods.mem_triangleRegularLocus_iff z).mpr
+  intro g hg
+  have hgC := triangle_horodisc_overlap_mem_cusp Y hY g ⟨z, ⟨z, hz, hg⟩, hz⟩
+  obtain ⟨n, hn⟩ := Subgroup.mem_zpowers_iff.mp hgC
+  have hfixed :
+    SpecialPeriods.triangleGeometricRepresentation (SpecialPeriods.triangleCuspGenerator ^ n) z =
+      z := by
+    rw [hn]
+    exact hg
+  have hzero :
+    SpecialPeriods.triangleGeometricRepresentation
+        (SpecialPeriods.triangleCuspGenerator ^ (0 : ℤ)) z =
+      z := by simp
+  have hn0 :=
+    SpecialPeriods.triangleGeometricRepresentation_cusp_orbit_injective z
+      (hfixed.trans hzero.symm)
+  rw [← hn, hn0, zpow_zero]
+
+private theorem SpecialPeriods.Triangle.cuspImage_subset_regularDomain (Y : ℝ) (hY : width ≤ Y) :
+    (cuspImage Y : Set SpecialPeriods.TriangleOrbitSpace) ⊆
+      SpecialPeriods.triangleOrbitRegularDomain := by
+  rintro q ⟨z, hz, rfl⟩
+  exact
+    (SpecialPeriods.triangleOrbitProjection_mem_regularDomain_iff z).mpr
+      (horodisc_subset_triangleRegularLocus Y hY hz)
+
+private theorem SpecialPeriods.exists_analytic_openPartialHomeomorph {f : ℂ → ℂ} {x : ℂ}
+    (hf : AnalyticAt ℂ f x) (hderiv : deriv f x ≠ 0) :
+    ∃ e : OpenPartialHomeomorph ℂ ℂ,
+      x ∈ e.source ∧
+        (∀ z, e z = f z) ∧ AnalyticOnNhd ℂ e e.source ∧ AnalyticOnNhd ℂ e.symm e.target := by
+  let e₀ : OpenPartialHomeomorph ℂ ℂ :=
+    (hf.hasStrictDerivAt.hasStrictFDerivAt_equiv hderiv).toOpenPartialHomeomorph f
+  have hx : x ∈ e₀.source := HasStrictFDerivAt.mem_toOpenPartialHomeomorph_source _
+  have hi : AnalyticAt ℂ e₀.symm (f x) := hf.analyticAt_localInverse hderiv
+  let e₁ := e₀.restrOpen {z | AnalyticAt ℂ f z} (isOpen_analyticAt ℂ f)
+  let e := (e₁.symm.restrOpen {z | AnalyticAt ℂ e₀.symm z} (isOpen_analyticAt ℂ e₀.symm)).symm
+  refine ⟨e, ?_, ?_, ?_, ?_⟩
+  · change (x ∈ e₀.source ∧ AnalyticAt ℂ f x) ∧ AnalyticAt ℂ e₀.symm (f x)
+    exact ⟨⟨hx, hf⟩, hi⟩
+  · intro z
+    rfl
+  · intro z hz
+    change AnalyticAt ℂ f z
+    exact hz.1.2
+  · intro z hz
+    change AnalyticAt ℂ e₀.symm z
+    exact hz.2
+
+private theorem SpecialPeriods.Triangle.upperHalfPlaneCoe_isLocalDiffeomorph_mo1973_16358 :
+    IsLocalDiffeomorph 𝓘(ℂ) 𝓘(ℂ) ω (UpperHalfPlane.coe : ℍ → ℂ) := by
+  let Φ : PartialDiffeomorph 𝓘(ℂ) 𝓘(ℂ) ℍ ℂ ω :=
+    { toPartialEquiv := UpperHalfPlane.ofComplex.symm.toPartialEquiv
+      open_source := UpperHalfPlane.ofComplex.symm.open_source
+      open_target := UpperHalfPlane.ofComplex.symm.open_target
+      contMDiffOn_toFun := UpperHalfPlane.contMDiff_coe.contMDiffOn
+      contMDiffOn_invFun := by
+        intro w hw
+        have he : ((UpperHalfPlane.ofComplex w : ℍ) : ℂ) = w :=
+          UpperHalfPlane.ofComplex.left_inv hw
+        have hwim : 0 < w.im := by
+          rw [← he]
+          exact (UpperHalfPlane.ofComplex w).im_pos
+        exact (UpperHalfPlane.contMDiffAt_ofComplex hwim).contMDiffWithinAt }
+  intro z
+  refine ⟨Φ, ?_, fun _ _ => rfl⟩
+  exact Set.mem_univ z
+
+private theorem SpecialPeriods.Triangle.cuspQ_coordinate_isLocalDiffeomorphAt_mo1973_16359
+    (z : ℍ) : IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω (cuspQ ∘ UpperHalfPlane.ofComplex) (z : ℂ) := by
+  have ha : AnalyticAt ℂ (cuspQ ∘ UpperHalfPlane.ofComplex) (z : ℂ) :=
+    (UpperHalfPlane.contMDiffAt_iff.mp (cuspQ_holomorphic z)).analyticAt
+  obtain ⟨e, hz, he, hforward, hinverse⟩ :=
+    SpecialPeriods.exists_analytic_openPartialHomeomorph ha (cuspQ_deriv_ne_zero z)
+  refine
+    ⟨{  toPartialEquiv := e.toPartialEquiv
+        open_source := e.open_source
+        open_target := e.open_target
+        contMDiffOn_toFun := (hforward.contDiffOn e.open_source.uniqueDiffOn).contMDiffOn
+        contMDiffOn_invFun := (hinverse.contDiffOn e.open_target.uniqueDiffOn).contMDiffOn }, hz,
+      ?_⟩
+  intro w _
+  exact (he w).symm
+
+private theorem
+    SpecialPeriods.Triangle.cuspQ_isLocalDiffeomorph : IsLocalDiffeomorph 𝓘(ℂ) 𝓘(ℂ) ω cuspQ :=
+  by
+  intro z
+  have h :=
+    (upperHalfPlaneCoe_isLocalDiffeomorph_mo1973_16358 z).comp (K := 𝓘(ℂ)) (P := ℂ)
+      (cuspQ_coordinate_isLocalDiffeomorphAt_mo1973_16359 z)
+  simpa only [Function.comp_def, UpperHalfPlane.ofComplex_apply] using h
+
+private theorem SpecialPeriods.Triangle.cuspQHorodisc_isLocalDiffeomorph (Y : ℝ) :
+    IsLocalDiffeomorph 𝓘(ℂ) 𝓘(ℂ) ω (cuspQHorodisc Y) := by
+  intro z
+  exact
+    isLocalDiffeomorphAt_restrictOpens 𝓘(ℂ) 𝓘(ℂ) (cuspQ_isLocalDiffeomorph (z : ℍ)) (horodisc Y)
+      (puncturedCuspBall Y) (fun w hw => (cuspQ_mem_puncturedCuspBall_iff Y w).mpr hw) z.property
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace in
+private theorem SpecialPeriods.instIsManifold1 : IsManifold 𝓘(ℂ) ω TriangleRegularQuotient :=
+  triangleRegularQuotient_isManifold
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold1 in
+private def SpecialPeriods.regularFullChart (x : TriangleRegularQuotient) :
+    OpenPartialHomeomorph TriangleOrbitSpace ℂ :=
+  triangleRegularOrbitParametrization.symm.trans (chartAt ℂ x)
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold1 in
+private theorem SpecialPeriods.regularFullChart_mem_source_iff (x : TriangleRegularQuotient)
+    (y : TriangleOrbitSpace) :
+    y ∈ (regularFullChart x).source ↔
+      y ∈ triangleOrbitRegularDomain ∧
+        triangleRegularOrbitParametrization.symm y ∈ (chartAt ℂ x).source := by
+  change
+    (y ∈ triangleRegularOrbitParametrization.target ∧
+        triangleRegularOrbitParametrization.symm y ∈ (chartAt ℂ x).source) ↔
+      _
+  rw [triangleRegularOrbitParametrization_target]
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold1 in
+private theorem SpecialPeriods.regularFullChart_source_subset (x : TriangleRegularQuotient) :
+    (regularFullChart x).source ⊆ triangleOrbitRegularDomain := fun _ hy =>
+  ((regularFullChart_mem_source_iff x _).mp hy).1
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold1 in
+@[simp]
+private theorem SpecialPeriods.regularFullChart_apply_inclusion (x y : TriangleRegularQuotient) :
+    regularFullChart x (triangleRegularToOrbit y) = chartAt ℂ x y := by
+  change chartAt ℂ x (triangleRegularOrbitParametrization.symm (triangleRegularToOrbit y)) = _
+  rw [triangleRegularOrbitParametrization_symm_apply]
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold1 in
+@[simp]
+private theorem
+    SpecialPeriods.regularFullChart_mem_source_inclusion_iff (x y : TriangleRegularQuotient) :
+    triangleRegularToOrbit y ∈ (regularFullChart x).source ↔ y ∈ (chartAt ℂ x).source := by
+  rw [regularFullChart_mem_source_iff, triangleRegularOrbitParametrization_symm_apply]
+  exact and_iff_right ⟨y, rfl⟩
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold1 in
+private theorem SpecialPeriods.regularFullChart_mem_source (x : TriangleRegularQuotient) :
+    triangleRegularToOrbit x ∈ (regularFullChart x).source :=
+  (regularFullChart_mem_source_inclusion_iff x x).mpr (mem_chart_source ℂ x)
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold1 in
+private theorem SpecialPeriods.exists_regularFullChart (y : TriangleOrbitSpace)
+    (hy : y ∈ triangleOrbitRegularDomain) :
+    ∃ x : TriangleRegularQuotient, y ∈ (regularFullChart x).source := by
+  obtain ⟨x, rfl⟩ := hy
+  exact ⟨x, regularFullChart_mem_source x⟩
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold1 in
+@[simp]
+private theorem SpecialPeriods.regularFullChart_projection (x : TriangleRegularQuotient)
+    (z : TriangleRegularPoint) :
+    regularFullChart x (triangleOrbitProjection z.val) = chartAt ℂ x (triangleRegularProject z) :=
+  by rw [← triangleRegularToOrbit_project z, regularFullChart_apply_inclusion]
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold1 in
+private def SpecialPeriods.triangleRegularCoordinatePartial (x : TriangleRegularQuotient) :
+    PartialDiffeomorph 𝓘(ℂ) 𝓘(ℂ) TriangleRegularQuotient ℂ ω
+    where
+  toPartialEquiv := (chartAt ℂ x).toPartialEquiv
+  open_source := (chartAt ℂ x).open_source
+  open_target := (chartAt ℂ x).open_target
+  contMDiffOn_toFun := contMDiffOn_chart
+  contMDiffOn_invFun := contMDiffOn_chart_symm
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold1 in
+private theorem SpecialPeriods.regularFullChart_pullback_isLocalDiffeomorphAt
+    (x : TriangleRegularQuotient) {z : ℍ}
+    (hz : triangleOrbitProjection z ∈ (regularFullChart x).source) :
+    IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω (regularFullChart x ∘ triangleOrbitProjection) z := by
+  have hzreg : z ∈ triangleRegularLocus :=
+    (triangleOrbitProjection_mem_regularDomain_iff z).mp (regularFullChart_source_subset x hz)
+  let a : TriangleRegularPoint := ⟨z, hzreg⟩
+  have hsource : triangleRegularProject a ∈ (chartAt ℂ x).source := by
+    apply (regularFullChart_mem_source_inclusion_iff x (triangleRegularProject a)).mp
+    simpa only [triangleRegularToOrbit_project] using hz
+  have hchart : IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω (chartAt ℂ x) (triangleRegularProject a) :=
+    (triangleRegularCoordinatePartial x).isLocalDiffeomorphAt _ _ _ hsource
+  have hreg : IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω (chartAt ℂ x ∘ triangleRegularProject) a :=
+    (triangleRegularProject_isLocalDiffeomorph a).comp (K := 𝓘(ℂ)) (P := ℂ) hchart
+  have heq :
+    (regularFullChart x ∘ triangleOrbitProjection) ∘ (Subtype.val : TriangleRegularPoint → ℍ) =
+      chartAt ℂ x ∘ triangleRegularProject := by
+    funext w
+    exact regularFullChart_projection x w
+  have hrestricted :
+    IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω
+      ((regularFullChart x ∘ triangleOrbitProjection) ∘ (Subtype.val : TriangleRegularPoint → ℍ))
+      a := by
+    rw [heq]
+    exact hreg
+  exact isLocalDiffeomorphAt_of_comp_opensSubtypeVal 𝓘(ℂ) 𝓘(ℂ) triangleRegularDomain a hrestricted
+
+attribute [local instance] SpecialPeriods.triangleRegularQuotientChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold1 in
+private theorem SpecialPeriods.regularFullChart_pullback_holomorphic (x : TriangleRegularQuotient) :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (regularFullChart x ∘ triangleOrbitProjection)
+      (triangleOrbitProjection ⁻¹' (regularFullChart x).source) :=
+  fun _ hz => (regularFullChart_pullback_isLocalDiffeomorphAt x hz).contMDiffAt.contMDiffWithinAt
+
+private theorem SpecialPeriods.cyclic_eq_bounded_generator_pow_mo1973_16380 {n : ℕ} [NeZero n]
+    (a : Multiplicative (ZMod n)) : ∃ k : ℕ, k < n ∧ a = Multiplicative.ofAdd (1 : ZMod n) ^ k := by
+  refine ⟨a.toAdd.val, ZMod.val_lt _, ?_⟩
+  change a.toAdd = a.toAdd.val • (1 : ZMod n)
+  simp only [nsmul_eq_mul, mul_one, ZMod.natCast_zmod_val]
+
+private theorem SpecialPeriods.triangleGenerator₁_commute_eq_pow (g : TriangleGroup)
+    (h : Commute triangleGenerator₁ g) : ∃ n : ℕ, n < 3 ∧ g = triangleGenerator₁ ^ n := by
+  obtain ⟨a, ha⟩ :=
+    CoprodTorsion.coprod_commute_inl (Multiplicative.ofAdd (1 : ZMod 3)) (by decide) g h
+  obtain ⟨n, hn, rfl⟩ := cyclic_eq_bounded_generator_pow_mo1973_16380 a
+  exact ⟨n, hn, by simpa only [map_pow, triangleGenerator₁] using ha⟩
+
+private theorem SpecialPeriods.triangleGenerator₂_commute_eq_pow (g : TriangleGroup)
+    (h : Commute triangleGenerator₂ g) : ∃ n : ℕ, n < 4 ∧ g = triangleGenerator₂ ^ n := by
+  obtain ⟨a, ha⟩ :=
+    CoprodTorsion.coprod_commute_inr (Multiplicative.ofAdd (1 : ZMod 4)) (by decide) g h
+  obtain ⟨n, hn, rfl⟩ := cyclic_eq_bounded_generator_pow_mo1973_16380 a
+  exact ⟨n, hn, by simpa only [map_pow, triangleGenerator₂] using ha⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.Triangle.realSLPermutation_commute_of_fixed (A B : SL(2, ℝ)) (a : ℍ)
+    (hA : A • a = a) (hB : B • a = a) : Commute (realSLPermutation A) (realSLPermutation B) := by
+  apply Equiv.ext
+  intro z
+  apply (cayleyBiholomorph a).injective
+  apply Subtype.ext
+  change cayleyCoordinate a (A • (B • z)) = cayleyCoordinate a (B • (A • z))
+  rw [cayleyCoordinate_smul A a _ hA, cayleyCoordinate_smul B a _ hB,
+    cayleyCoordinate_smul B a _ hB, cayleyCoordinate_smul A a _ hA]
+  ring
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.triangle_commute_of_common_fixed (g h : TriangleGroup) (z : ℍ)
+    (hg : triangleGeometricRepresentation g z = z)
+    (hh : triangleGeometricRepresentation h z = z) : Commute g h := by
+  apply triangleGeometricRepresentation_injective
+  rw [map_mul, map_mul]
+  obtain ⟨A, hA⟩ := triangleGeometricRepresentation_has_SL_lift g
+  obtain ⟨B, hB⟩ := triangleGeometricRepresentation_has_SL_lift h
+  have ha : A • z = z := (congrArg (fun f : Equiv.Perm ℍ => f z) hA).trans hg
+  have hb : B • z = z := (congrArg (fun f : Equiv.Perm ℍ => f z) hB).trans hh
+  simpa only [hA, hB] using (Triangle.realSLPermutation_commute_of_fixed A B z ha hb).eq
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.triangle_fixed_centerOne_iff (g : TriangleGroup) :
+    triangleGeometricRepresentation g Triangle.centerOne = Triangle.centerOne ↔
+      ∃ n : ℕ, n < 3 ∧ g = triangleGenerator₁ ^ n := by
+  constructor
+  · intro hg
+    apply triangleGenerator₁_commute_eq_pow g
+    exact
+      triangle_commute_of_common_fixed _ _ Triangle.centerOne
+        ((triangleGeometricRepresentation_generator₁_apply _).trans Triangle.generatorOne_fix) hg
+  · rintro ⟨n, hn, rfl⟩
+    clear hn
+    rw [triangle_generator₁_pow_apply]
+    induction n with
+    | zero => simp
+    | succ n ih => simp only [pow_succ', SemigroupAction.mul_smul, ih, Triangle.generatorOne_fix]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.triangle_fixed_centerTwo_iff (g : TriangleGroup) :
+    triangleGeometricRepresentation g Triangle.centerTwo = Triangle.centerTwo ↔
+      ∃ n : ℕ, n < 4 ∧ g = triangleGenerator₂ ^ n := by
+  constructor
+  · intro hg
+    apply triangleGenerator₂_commute_eq_pow g
+    exact
+      triangle_commute_of_common_fixed _ _ Triangle.centerTwo
+        ((triangleGeometricRepresentation_generator₂_apply _).trans Triangle.generatorTwo_fix) hg
+  · rintro ⟨n, hn, rfl⟩
+    clear hn
+    rw [triangle_generator₂_pow_apply]
+    induction n with
+    | zero => simp
+    | succ n ih => simp only [pow_succ', SemigroupAction.mul_smul, ih, Triangle.generatorTwo_fix]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.triangle_stabilizer_centerOne :
+    MulAction.stabilizer TriangleGroup Triangle.centerOne = Subgroup.zpowers triangleGenerator₁ :=
+  by
+  apply le_antisymm
+  · intro g hg
+    obtain ⟨n, _, rfl⟩ := (triangle_fixed_centerOne_iff g).mp hg
+    exact Subgroup.pow_mem _ (Subgroup.mem_zpowers _) _
+  · apply Subgroup.zpowers_le.mpr
+    exact (triangleGeometricRepresentation_generator₁_apply _).trans Triangle.generatorOne_fix
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.triangle_stabilizer_centerTwo :
+    MulAction.stabilizer TriangleGroup Triangle.centerTwo = Subgroup.zpowers triangleGenerator₂ :=
+  by
+  apply le_antisymm
+  · intro g hg
+    obtain ⟨n, _, rfl⟩ := (triangle_fixed_centerTwo_iff g).mp hg
+    exact Subgroup.pow_mem _ (Subgroup.mem_zpowers _) _
+  · apply Subgroup.zpowers_le.mpr
+    exact (triangleGeometricRepresentation_generator₂_apply _).trans Triangle.generatorTwo_fix
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.triangleOrbitCenterOne_ne_centerTwo :
+    triangleOrbitCenterOne ≠ triangleOrbitCenterTwo := by
+  intro he
+  obtain ⟨g, hg⟩ := (triangleOrbitProjection_eq_iff _ _).mp he.symm
+  have hfix :
+    triangleGeometricRepresentation (g * triangleGenerator₁ * g⁻¹) Triangle.centerTwo =
+      Triangle.centerTwo := by
+    simpa only [pow_one] using
+      (triangle_conjugate_generator₁_fixed_iff g 1 (by norm_num) (by norm_num)
+            Triangle.centerTwo).mpr
+        hg.symm
+  obtain ⟨n, _, hn⟩ := (triangle_fixed_centerTwo_iff _).mp hfix
+  have ho : orderOf (g * triangleGenerator₁ * g⁻¹) = 3 := by
+    change orderOf ((MulAut.conj g) triangleGenerator₁) = 3
+    exact
+      (orderOf_injective (MulAut.conj g).toMonoidHom (MulAut.conj g).injective
+            triangleGenerator₁).trans
+        triangleGenerator₁_order
+  have hd := orderOf_pow_dvd (x := triangleGenerator₂) n
+  rw [← hn, ho, triangleGenerator₂_order] at hd
+  norm_num at hd
+
+private def SpecialPeriods.Triangle.cayleyBall (a : ℍ) (r : ℝ) : TopologicalSpace.Opens ℍ :=
+  ⟨{z | ‖cayleyCoordinate a z‖ < r},
+    isOpen_lt (cayleyCoordinate_holomorphic a).continuous.norm continuous_const⟩
+
+@[simp]
+private theorem SpecialPeriods.Triangle.mem_cayleyBall (a z : ℍ) (r : ℝ) :
+    z ∈ cayleyBall a r ↔ ‖cayleyCoordinate a z‖ < r :=
+  Iff.rfl
+
+private theorem SpecialPeriods.Triangle.center_mem_cayleyBall (a : ℍ) (r : ℝ) :
+    a ∈ cayleyBall a r ↔ 0 < r := by simp [cayleyBall, cayleyCoordinate]
+
+private def
+    SpecialPeriods.Triangle.cayleyBallToDisc (a : ℍ) (r : ℝ) (hr : 0 < r) (z : cayleyBall a r) :
+    SpecialPeriods.Disc :=
+  ⟨cayleyCoordinate a z / (r : ℂ),
+    by
+    have hn : ‖cayleyCoordinate a z / (r : ℂ)‖ < 1 := by
+      rw [norm_div, Complex.norm_real, Real.norm_eq_abs, abs_of_pos hr]
+      exact (div_lt_one hr).mpr z.property
+    simpa [SpecialPeriods.unitDisc] using hn⟩
+
+@[simp]
+private theorem SpecialPeriods.Triangle.cayleyBallToDisc_val (a : ℍ) (r : ℝ) (hr : 0 < r)
+    (z : cayleyBall a r) : (cayleyBallToDisc a r hr z : ℂ) = cayleyCoordinate a z / (r : ℂ) :=
+  rfl
+
+private def SpecialPeriods.Triangle.cayleyBallDiscScale (r : ℝ) (hr : 0 < r) (hr1 : r ≤ 1)
+    (z : SpecialPeriods.Disc) : SpecialPeriods.Disc :=
+  ⟨(r : ℂ) * z,
+    by
+    have hn : ‖(r : ℂ) * (z : ℂ)‖ < 1 := by
+      rw [norm_mul, Complex.norm_real, Real.norm_eq_abs, abs_of_pos hr]
+      exact (mul_lt_of_lt_one_right hr (SpecialPeriods.disc_norm_lt_one z)).trans_le hr1
+    simpa [SpecialPeriods.unitDisc] using hn⟩
+
+@[simp]
+private theorem SpecialPeriods.Triangle.cayleyBallDiscScale_val (r : ℝ) (hr : 0 < r) (hr1 : r ≤ 1)
+    (z : SpecialPeriods.Disc) : (cayleyBallDiscScale r hr hr1 z : ℂ) = (r : ℂ) * z :=
+  rfl
+
+private theorem SpecialPeriods.Triangle.cayleyBallDiscScale_norm (r : ℝ) (hr : 0 < r) (hr1 : r ≤ 1)
+    (z : SpecialPeriods.Disc) : ‖(cayleyBallDiscScale r hr hr1 z : ℂ)‖ < r := by
+  rw [cayleyBallDiscScale_val, norm_mul, Complex.norm_real, Real.norm_eq_abs, abs_of_pos hr]
+  exact mul_lt_of_lt_one_right hr (SpecialPeriods.disc_norm_lt_one z)
+
+private def SpecialPeriods.Triangle.cayleyBallFromDisc (a : ℍ) (r : ℝ) (hr : 0 < r) (hr1 : r ≤ 1)
+    (z : SpecialPeriods.Disc) : cayleyBall a r :=
+  ⟨fromDisc a (cayleyBallDiscScale r hr hr1 z),
+    by
+    change ‖(toDisc a (fromDisc a (cayleyBallDiscScale r hr hr1 z)) : ℂ)‖ < r
+    rw [toDisc_fromDisc]
+    exact cayleyBallDiscScale_norm r hr hr1 z⟩
+
+private theorem SpecialPeriods.Triangle.cayleyBallFromDisc_toDisc (a : ℍ) (r : ℝ) (hr : 0 < r)
+    (hr1 : r ≤ 1) (z : cayleyBall a r) :
+    cayleyBallFromDisc a r hr hr1 (cayleyBallToDisc a r hr z) = z := by
+  apply Subtype.ext
+  change fromDisc a (cayleyBallDiscScale r hr hr1 (cayleyBallToDisc a r hr z)) = z
+  have he : cayleyBallDiscScale r hr hr1 (cayleyBallToDisc a r hr z) = toDisc a z := by
+    apply Subtype.ext
+    simp only [cayleyBallDiscScale_val, cayleyBallToDisc_val, toDisc_val]
+    exact mul_div_cancel₀ _ (Complex.ofReal_ne_zero.mpr hr.ne')
+  rw [he, fromDisc_toDisc]
+
+private theorem SpecialPeriods.Triangle.cayleyBallToDisc_fromDisc (a : ℍ) (r : ℝ) (hr : 0 < r)
+    (hr1 : r ≤ 1) (z : SpecialPeriods.Disc) :
+    cayleyBallToDisc a r hr (cayleyBallFromDisc a r hr hr1 z) = z := by
+  apply Subtype.ext
+  change (toDisc a (fromDisc a (cayleyBallDiscScale r hr hr1 z)) : ℂ) / (r : ℂ) = z
+  rw [toDisc_fromDisc, cayleyBallDiscScale_val]
+  exact mul_div_cancel_left₀ _ (Complex.ofReal_ne_zero.mpr hr.ne')
+
+private theorem SpecialPeriods.Triangle.cayleyBallToDisc_holomorphic (a : ℍ) (r : ℝ) (hr : 0 < r) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (cayleyBallToDisc a r hr) := by
+  have hc : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z : cayleyBall a r => cayleyCoordinate a z / (r : ℂ)) :=
+    ((cayleyCoordinate_holomorphic a).comp contMDiff_subtype_val).div₀ contMDiff_const
+      (fun _ => Complex.ofReal_ne_zero.mpr hr.ne')
+  intro z
+  exact (ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..).mp (hc z)
+
+private theorem SpecialPeriods.Triangle.cayleyBallDiscScale_holomorphic (r : ℝ) (hr : 0 < r)
+    (hr1 : r ≤ 1) : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (cayleyBallDiscScale r hr hr1) := by
+  have hc : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z : SpecialPeriods.Disc => (r : ℂ) * z) :=
+    contMDiff_const.mul contMDiff_subtype_val
+  intro z
+  exact (ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..).mp (hc z)
+
+private theorem SpecialPeriods.Triangle.cayleyBallFromDisc_holomorphic (a : ℍ) (r : ℝ) (hr : 0 < r)
+    (hr1 : r ≤ 1) : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (cayleyBallFromDisc a r hr hr1) := by
+  have hc := (fromDisc_holomorphic a).comp (cayleyBallDiscScale_holomorphic r hr hr1)
+  intro z
+  exact (ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..).mp (hc z)
+
+private def
+    SpecialPeriods.Triangle.cayleyBallBiholomorph (a : ℍ) (r : ℝ) (hr : 0 < r) (hr1 : r ≤ 1) :
+    Diffeomorph 𝓘(ℂ) 𝓘(ℂ) (cayleyBall a r) SpecialPeriods.Disc ω
+    where
+  toFun := cayleyBallToDisc a r hr
+  invFun := cayleyBallFromDisc a r hr hr1
+  left_inv := cayleyBallFromDisc_toDisc a r hr hr1
+  right_inv := cayleyBallToDisc_fromDisc a r hr hr1
+  contMDiff_toFun := cayleyBallToDisc_holomorphic a r hr
+  contMDiff_invFun := cayleyBallFromDisc_holomorphic a r hr hr1
+
+@[simp]
+private theorem SpecialPeriods.Triangle.cayleyBallToDisc_center (a : ℍ) (r : ℝ) (hr : 0 < r) :
+    cayleyBallToDisc a r hr ⟨a, (center_mem_cayleyBall a r).mpr hr⟩ = SpecialPeriods.discZero := by
+  apply Subtype.ext
+  simp [cayleyBallToDisc_val, cayleyCoordinate]
+
+@[simp]
+private theorem SpecialPeriods.Triangle.cayleyBallBiholomorph_center (a : ℍ) (r : ℝ) (hr : 0 < r)
+    (hr1 : r ≤ 1) :
+    cayleyBallBiholomorph a r hr hr1 ⟨a, (center_mem_cayleyBall a r).mpr hr⟩ =
+      SpecialPeriods.discZero :=
+  cayleyBallToDisc_center a r hr
+
+private theorem
+    SpecialPeriods.Triangle.exists_cayleyBall_subset (a : ℍ) {U : Set ℍ} (hU : U ∈ 𝓝 a) :
+    ∃ r : ℝ, 0 < r ∧ r ≤ 1 ∧ (cayleyBall a r : Set ℍ) ⊆ U := by
+  have hc : fromDisc a SpecialPeriods.discZero = a := by
+    apply UpperHalfPlane.ext
+    simp [fromDisc_val]
+  have hpre : fromDisc a ⁻¹' U ∈ 𝓝 SpecialPeriods.discZero :=
+    (fromDisc_holomorphic a).continuous.continuousAt.preimage_mem_nhds (by simpa [hc] using hU)
+  obtain ⟨r, hr, hsub⟩ := Metric.mem_nhds_iff.mp hpre
+  refine ⟨Min.min r 1, lt_min hr zero_lt_one, min_le_right _ _, ?_⟩
+  intro z hz
+  have hm : toDisc a z ∈ Metric.ball SpecialPeriods.discZero r := by
+    change Dist.dist (toDisc a z : ℂ) (SpecialPeriods.discZero : ℂ) < r
+    rw [toDisc_val, SpecialPeriods.discZero_val, dist_zero_right]
+    exact lt_of_lt_of_le hz (min_le_left _ _)
+  simpa only [Set.mem_preimage, fromDisc_toDisc] using hsub hm
+
+private theorem SpecialPeriods.Triangle.smul_mem_cayleyBall_iff (g : SL(2, ℝ)) (a z : ℍ) (r : ℝ)
+    (hfix : g • a = a) : g • z ∈ cayleyBall a r ↔ z ∈ cayleyBall a r := by
+  simp only [mem_cayleyBall, cayleyCoordinate_smul g a z hfix, norm_mul,
+    slMultiplier_norm g a hfix, one_mul]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.ellipticOtherKind : Elliptic.Kind → Elliptic.Kind
+  | .three => .four
+  | .four => .three
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.ellipticCenter : Elliptic.Kind → ℍ
+  | .three => centerOne
+  | .four => centerTwo
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.ellipticGenerator : Elliptic.Kind → SpecialPeriods.TriangleGroup
+  | .three => SpecialPeriods.triangleGenerator₁
+  | .four => SpecialPeriods.triangleGenerator₂
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.ellipticGeneratorSL : Elliptic.Kind → SL(2, ℝ)
+  | .three => generatorOneSL
+  | .four => generatorTwoSL
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticGenerator_smul (j : Elliptic.Kind) (z : ℍ) :
+    ellipticGenerator j • z = ellipticGeneratorSL j • z := by
+  cases j
+  · exact SpecialPeriods.triangleGeometricRepresentation_generator₁_apply z
+  · exact SpecialPeriods.triangleGeometricRepresentation_generator₂_apply z
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticGeneratorSL_fixed (j : Elliptic.Kind) :
+    ellipticGeneratorSL j • ellipticCenter j = ellipticCenter j := by
+  cases j
+  · exact generatorOne_fix
+  · exact generatorTwo_fix
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.ellipticOrbitCenter (j : Elliptic.Kind) :
+    SpecialPeriods.TriangleOrbitSpace :=
+  SpecialPeriods.triangleOrbitProjection (ellipticCenter j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+@[simp]
+private theorem SpecialPeriods.Triangle.ellipticOrbitCenter_three :
+    ellipticOrbitCenter .three = SpecialPeriods.triangleOrbitCenterOne :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+@[simp]
+private theorem SpecialPeriods.Triangle.ellipticOrbitCenter_four :
+    ellipticOrbitCenter .four = SpecialPeriods.triangleOrbitCenterTwo :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticOrbitCenter_ne_other (j : Elliptic.Kind) :
+    ellipticOrbitCenter j ≠ ellipticOrbitCenter (ellipticOtherKind j) := by
+  cases j
+  · exact SpecialPeriods.triangleOrbitCenterOne_ne_centerTwo
+  · exact SpecialPeriods.triangleOrbitCenterOne_ne_centerTwo.symm
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.ellipticStabilizer (j : Elliptic.Kind) :
+    Subgroup SpecialPeriods.TriangleGroup :=
+  MulAction.stabilizer SpecialPeriods.TriangleGroup (ellipticCenter j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.mem_ellipticStabilizer_iff (j : Elliptic.Kind)
+    (g : SpecialPeriods.TriangleGroup) :
+    g ∈ ellipticStabilizer j ↔ ∃ n : ℕ, n < j.order ∧ g = ellipticGenerator j ^ n := by
+  cases j
+  · exact SpecialPeriods.triangle_fixed_centerOne_iff g
+  · exact SpecialPeriods.triangle_fixed_centerTwo_iff g
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticStabilizer_eq_zpowers (j : Elliptic.Kind) :
+    ellipticStabilizer j = Subgroup.zpowers (ellipticGenerator j) := by
+  cases j
+  · exact SpecialPeriods.triangle_stabilizer_centerOne
+  · exact SpecialPeriods.triangle_stabilizer_centerTwo
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticGenerator_mem_stabilizer (j : Elliptic.Kind) :
+    ellipticGenerator j ∈ ellipticStabilizer j := by
+  change ellipticGenerator j • ellipticCenter j = ellipticCenter j
+  rw [ellipticGenerator_smul, ellipticGeneratorSL_fixed]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.ellipticStabilizerGenerator (j : Elliptic.Kind) :
+    ellipticStabilizer j :=
+  ⟨ellipticGenerator j, ellipticGenerator_mem_stabilizer j⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+@[simp]
+private theorem SpecialPeriods.Triangle.ellipticStabilizerGenerator_val (j : Elliptic.Kind) :
+    (ellipticStabilizerGenerator j : SpecialPeriods.TriangleGroup) = ellipticGenerator j :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticStabilizer_eq_generator_pow (j : Elliptic.Kind)
+    (g : ellipticStabilizer j) : ∃ n : ℕ, n < j.order ∧ g = ellipticStabilizerGenerator j ^ n := by
+  obtain ⟨n, hn, hg⟩ := (mem_ellipticStabilizer_iff j g).mp g.property
+  exact ⟨n, hn, Subtype.ext hg⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.ellipticOtherOrbitComplement (j : Elliptic.Kind) :
+    TopologicalSpace.Opens ℍ :=
+  ⟨{z | SpecialPeriods.triangleOrbitProjection z ≠ ellipticOrbitCenter (ellipticOtherKind j)},
+    isOpen_ne_fun SpecialPeriods.triangleOrbitProjection_continuous continuous_const⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem
+    SpecialPeriods.Triangle.ellipticCenter_mem_otherOrbitComplement (j : Elliptic.Kind) :
+    ellipticCenter j ∈ ellipticOtherOrbitComplement j :=
+  ellipticOrbitCenter_ne_other j
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.exists_ellipticNeighborhoodRadius (j : Elliptic.Kind) :
+    ∃ r : ℝ,
+      0 < r ∧
+        r ≤ 1 ∧
+          (∀ g : SpecialPeriods.TriangleGroup,
+              (((g • ·) '' (cayleyBall (ellipticCenter j) r : Set ℍ)) ∩
+                    cayleyBall (ellipticCenter j) r).Nonempty →
+                g ∈ ellipticStabilizer j) ∧
+            (cayleyBall (ellipticCenter j) r : Set ℍ) ⊆ ellipticOtherOrbitComplement j := by
+  obtain ⟨U, hU, hret⟩ :=
+    ProperlyDiscontinuousSMul.exists_nhds_image_smul_eq_self SpecialPeriods.TriangleGroup
+      (ellipticCenter j)
+  have hV :=
+    (ellipticOtherOrbitComplement j).isOpen.mem_nhds (ellipticCenter_mem_otherOrbitComplement j)
+  obtain ⟨r, hr, hr1, hball⟩ :=
+    exists_cayleyBall_subset (ellipticCenter j) (Filter.inter_mem hU hV)
+  refine ⟨r, hr, hr1, ?_, fun z hz => (hball hz).2⟩
+  intro g hg
+  obtain ⟨z, ⟨w, hw, hgw⟩, hz⟩ := hg
+  exact hret g ⟨z, ⟨w, (hball hw).1, hgw⟩, (hball hz).1⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.ellipticNeighborhoodRadius (j : Elliptic.Kind) : ℝ :=
+  (exists_ellipticNeighborhoodRadius j).choose
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticNeighborhoodRadius_pos (j : Elliptic.Kind) :
+    0 < ellipticNeighborhoodRadius j :=
+  (exists_ellipticNeighborhoodRadius j).choose_spec.1
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticNeighborhoodRadius_le_one (j : Elliptic.Kind) :
+    ellipticNeighborhoodRadius j ≤ 1 :=
+  (exists_ellipticNeighborhoodRadius j).choose_spec.2.1
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def
+    SpecialPeriods.Triangle.ellipticNeighborhood (j : Elliptic.Kind) : TopologicalSpace.Opens ℍ :=
+  cayleyBall (ellipticCenter j) (ellipticNeighborhoodRadius j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticCenter_mem_neighborhood (j : Elliptic.Kind) :
+    ellipticCenter j ∈ ellipticNeighborhood j :=
+  (center_mem_cayleyBall _ _).mpr (ellipticNeighborhoodRadius_pos j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticNeighborhood_mem_nhds (j : Elliptic.Kind) :
+    (ellipticNeighborhood j : Set ℍ) ∈ 𝓝 (ellipticCenter j) :=
+  (ellipticNeighborhood j).isOpen.mem_nhds (ellipticCenter_mem_neighborhood j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticNeighborhood_return (j : Elliptic.Kind)
+    (g : SpecialPeriods.TriangleGroup)
+    (hret : (((g • ·) '' (ellipticNeighborhood j : Set ℍ)) ∩ ellipticNeighborhood j).Nonempty) :
+    g ∈ ellipticStabilizer j :=
+  (exists_ellipticNeighborhoodRadius j).choose_spec.2.2.1 g hret
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticNeighborhood_subset_otherOrbitComplement
+    (j : Elliptic.Kind) : (ellipticNeighborhood j : Set ℍ) ⊆ ellipticOtherOrbitComplement j :=
+  (exists_ellipticNeighborhoodRadius j).choose_spec.2.2.2
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem
+    SpecialPeriods.Triangle.ellipticNeighborhood_avoids_other (j : Elliptic.Kind) (z : ℍ)
+    (hz : z ∈ ellipticNeighborhood j) :
+    SpecialPeriods.triangleOrbitProjection z ≠ ellipticOrbitCenter (ellipticOtherKind j) :=
+  ellipticNeighborhood_subset_otherOrbitComplement j hz
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticStabilizer_cayleyBall_invariant (j : Elliptic.Kind)
+    (g : ellipticStabilizer j) (r : ℝ) (z : ℍ) :
+    (g : SpecialPeriods.TriangleGroup) • z ∈ cayleyBall (ellipticCenter j) r ↔
+      z ∈ cayleyBall (ellipticCenter j) r := by
+  have hfix :
+    (SpecialPeriods.triangleMatrixLift g : SL(2, ℝ)) • ellipticCenter j = ellipticCenter j :=
+    (SpecialPeriods.triangleMatrixLift_smul g _).trans g.property
+  rw [← SpecialPeriods.triangleMatrixLift_smul]
+  exact smul_mem_cayleyBall_iff (SpecialPeriods.triangleMatrixLift g) (ellipticCenter j) z r hfix
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticNeighborhood_invariant (j : Elliptic.Kind)
+    (g : ellipticStabilizer j) (z : ℍ) :
+    (g : SpecialPeriods.TriangleGroup) • z ∈ ellipticNeighborhood j ↔
+      z ∈ ellipticNeighborhood j :=
+  ellipticStabilizer_cayleyBall_invariant j g _ z
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticNeighborhood_mapsTo (j : Elliptic.Kind)
+    (g : ellipticStabilizer j) :
+    Set.MapsTo (fun z : ℍ => (g : SpecialPeriods.TriangleGroup) • z) (ellipticNeighborhood j)
+      (ellipticNeighborhood j) :=
+  fun z hz => (ellipticNeighborhood_invariant j g z).mpr hz
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+@[instance_reducible]
+private def SpecialPeriods.Triangle.ellipticNeighborhoodAction (j : Elliptic.Kind) :
+    MulAction (ellipticStabilizer j) (ellipticNeighborhood j) :=
+  LocalOrbitQuotient.restrictedAction (ellipticStabilizer j) (ellipticNeighborhood j)
+    (ellipticNeighborhood_mapsTo j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+@[simp]
+private theorem SpecialPeriods.Triangle.ellipticNeighborhood_smul_val (j : Elliptic.Kind)
+    (g : ellipticStabilizer j) (z : ellipticNeighborhood j) :
+    letI := ellipticNeighborhoodAction j
+    ((g • z : ellipticNeighborhood j) : ℍ) = (g : SpecialPeriods.TriangleGroup) • (z : ℍ) :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.ellipticNeighborhoodCenter (j : Elliptic.Kind) :
+    ellipticNeighborhood j :=
+  ⟨ellipticCenter j, ellipticCenter_mem_neighborhood j⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.ellipticNeighborhoodChart (j : Elliptic.Kind) :
+    Diffeomorph 𝓘(ℂ) 𝓘(ℂ) (ellipticNeighborhood j) SpecialPeriods.Disc ω :=
+  cayleyBallBiholomorph (ellipticCenter j) (ellipticNeighborhoodRadius j)
+    (ellipticNeighborhoodRadius_pos j) (ellipticNeighborhoodRadius_le_one j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+@[simp]
+private theorem SpecialPeriods.Triangle.ellipticNeighborhoodChart_val (j : Elliptic.Kind)
+    (z : ellipticNeighborhood j) :
+    (ellipticNeighborhoodChart j z : ℂ) =
+      cayleyCoordinate (ellipticCenter j) z / (ellipticNeighborhoodRadius j : ℂ) :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+@[simp]
+private theorem SpecialPeriods.Triangle.ellipticNeighborhoodChart_center (j : Elliptic.Kind) :
+    ellipticNeighborhoodChart j (ellipticNeighborhoodCenter j) = SpecialPeriods.discZero :=
+  cayleyBallBiholomorph_center _ _ _ _
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticNeighborhoodChart_generator (j : Elliptic.Kind)
+    (z : ellipticNeighborhood j) :
+    letI := ellipticNeighborhoodAction j
+    ellipticNeighborhoodChart j (ellipticStabilizerGenerator j • z) =
+      Elliptic.familyRotation j (ellipticNeighborhoodChart j z) := by
+  let := ellipticNeighborhoodAction j
+  apply Subtype.ext
+  change
+    cayleyCoordinate (ellipticCenter j) (ellipticGenerator j • (z : ℍ)) /
+        (ellipticNeighborhoodRadius j : ℂ) =
+      _
+  rw [ellipticGenerator_smul]
+  cases j
+  · change
+      cayleyCoordinate centerOne (generatorOneSL • (z : ℍ)) /
+          (ellipticNeighborhoodRadius .three : ℂ) =
+        -SpecialPeriods.rho *
+          (cayleyCoordinate centerOne z / (ellipticNeighborhoodRadius .three : ℂ))
+    rw [generatorOne_cayley, mul_div_assoc]
+  · change
+      cayleyCoordinate centerTwo (generatorTwoSL • (z : ℍ)) /
+          (ellipticNeighborhoodRadius .four : ℂ) =
+        -Complex.I * (cayleyCoordinate centerTwo z / (ellipticNeighborhoodRadius .four : ℂ))
+    rw [generatorTwo_cayley, mul_div_assoc]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem
+    SpecialPeriods.Triangle.ellipticNeighborhood_projection_eq_center_iff (j : Elliptic.Kind)
+    (z : ellipticNeighborhood j) :
+    SpecialPeriods.triangleOrbitProjection z = ellipticOrbitCenter j ↔
+      z = ellipticNeighborhoodCenter j := by
+  constructor
+  · intro hz
+    obtain ⟨g, hg⟩ := (SpecialPeriods.triangleOrbitProjection_eq_iff z (ellipticCenter j)).mp hz
+    have hgH : g ∈ ellipticStabilizer j :=
+      ellipticNeighborhood_return j g
+        ⟨z, ⟨ellipticCenter j, ellipticCenter_mem_neighborhood j, hg⟩, z.property⟩
+    apply Subtype.ext
+    exact hg.symm.trans hgH
+  · rintro rfl
+    rfl
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private abbrev SpecialPeriods.Triangle.EllipticNeighborhoodQuotient (j : Elliptic.Kind) :=
+  LocalOrbitQuotient.LocalQuotient (ellipticStabilizer j) (ellipticNeighborhood j)
+    (ellipticNeighborhood_mapsTo j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.ellipticNeighborhoodImage (j : Elliptic.Kind) :
+    TopologicalSpace.Opens SpecialPeriods.TriangleOrbitSpace :=
+  LocalOrbitQuotient.imageOpen (G := SpecialPeriods.TriangleGroup) (ellipticNeighborhood j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.ellipticNeighborhoodQuotientHomeomorph (j : Elliptic.Kind) :
+    EllipticNeighborhoodQuotient j ≃ₜ ellipticNeighborhoodImage j :=
+  LocalOrbitQuotient.localHomeomorph (ellipticStabilizer j) (ellipticNeighborhood j)
+    (ellipticNeighborhood_mapsTo j) (ellipticNeighborhood_return j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem
+    SpecialPeriods.Triangle.ellipticOrbitCenter_mem_neighborhoodImage (j : Elliptic.Kind) :
+    ellipticOrbitCenter j ∈ ellipticNeighborhoodImage j :=
+  ⟨ellipticCenter j, ellipticCenter_mem_neighborhood j, rfl⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticOtherOrbitCenter_not_mem_neighborhoodImage
+    (j : Elliptic.Kind) :
+    ellipticOrbitCenter (ellipticOtherKind j) ∉ ellipticNeighborhoodImage j := by
+  rintro ⟨z, hz, he⟩
+  exact ellipticNeighborhood_avoids_other j z hz he
+
+private theorem SpecialPeriods.TriangleQuotientPower.discPower_isOpenMap (m : ℕ) (hm : 0 < m) :
+    IsOpenMap (Elliptic.discPower m hm) := by
+  let : NeZero m := ⟨hm.ne'⟩
+  have h : IsOpenMap (fun z : SpecialPeriods.Disc => (z : ℂ) ^ m) :=
+    (Complex.isOpenQuotientMap_pow m).isOpenMap.comp
+      SpecialPeriods.unitDisc.isOpen.isOpenMap_subtype_val
+  exact h.subtype_mk _
+
+private theorem SpecialPeriods.TriangleQuotientPower.map_pow_smul {H Y : Type*} [Group H]
+    [TopologicalSpace Y] [MulAction H Y] (j : Elliptic.Kind) (e : Y ≃ₜ SpecialPeriods.Disc)
+    (a : H) (heq : ∀ y : Y, e (a • y) = Elliptic.familyRotation j (e y)) (n : ℕ) (y : Y) :
+    e ((a ^ n) • y) = (Elliptic.familyRotation j)^[n] (e y) := by
+  induction n with
+  | zero => simp
+  | succ n ih => rw [pow_succ', SemigroupAction.mul_smul, heq, ih, Function.iterate_succ_apply']
+
+private theorem SpecialPeriods.TriangleQuotientPower.powerCoordinate_eq_iff_mem_orbit {H Y : Type*}
+    [Group H] [TopologicalSpace Y] [MulAction H Y] (j : Elliptic.Kind)
+    (e : Y ≃ₜ SpecialPeriods.Disc) (a : H) (hgen : ∀ h : H, ∃ n : ℕ, n < j.order ∧ h = a ^ n)
+    (heq : ∀ y : Y, e (a • y) = Elliptic.familyRotation j (e y)) (x y : Y) :
+    Elliptic.discPower j.order j.order_pos (e x) = Elliptic.discPower j.order j.order_pos (e y) ↔
+      x ∈ MulAction.orbit H y := by
+  rw [Elliptic.discPower_eq_iff_familyRotation]
+  constructor
+  · rintro ⟨n, hn, hxy⟩
+    refine ⟨a ^ n, ?_⟩
+    apply e.injective
+    exact (map_pow_smul j e a heq n y).trans hxy
+  · rintro ⟨h, hh⟩
+    obtain ⟨n, hn, rfl⟩ := hgen h
+    exact ⟨n, hn, (map_pow_smul j e a heq n y).symm.trans (congrArg e hh)⟩
+
+private def
+    SpecialPeriods.TriangleQuotientPower.orbitDiscMap {H Y : Type*} [Group H] [TopologicalSpace Y]
+    [MulAction H Y] (j : Elliptic.Kind) (e : Y ≃ₜ SpecialPeriods.Disc) (a : H)
+    (hgen : ∀ h : H, ∃ n : ℕ, n < j.order ∧ h = a ^ n)
+    (heq : ∀ y : Y, e (a • y) = Elliptic.familyRotation j (e y)) :
+    Quotient (MulAction.orbitRel H Y) → SpecialPeriods.Disc :=
+  Quotient.lift (fun y => Elliptic.discPower j.order j.order_pos (e y)) fun x y hxy =>
+    (powerCoordinate_eq_iff_mem_orbit j e a hgen heq x y).mpr hxy
+
+@[simp]
+private theorem SpecialPeriods.TriangleQuotientPower.orbitDiscMap_mk {H Y : Type*} [Group H]
+    [TopologicalSpace Y] [MulAction H Y] (j : Elliptic.Kind) (e : Y ≃ₜ SpecialPeriods.Disc)
+    (a : H) (hgen : ∀ h : H, ∃ n : ℕ, n < j.order ∧ h = a ^ n)
+    (heq : ∀ y : Y, e (a • y) = Elliptic.familyRotation j (e y)) (y : Y) :
+    orbitDiscMap j e a hgen heq (Quotient.mk (MulAction.orbitRel H Y) y) =
+      Elliptic.discPower j.order j.order_pos (e y) :=
+  rfl
+
+private theorem SpecialPeriods.TriangleQuotientPower.orbitDiscMap_continuous {H Y : Type*} [Group H]
+    [TopologicalSpace Y] [MulAction H Y] (j : Elliptic.Kind) (e : Y ≃ₜ SpecialPeriods.Disc)
+    (a : H) (hgen : ∀ h : H, ∃ n : ℕ, n < j.order ∧ h = a ^ n)
+    (heq : ∀ y : Y, e (a • y) = Elliptic.familyRotation j (e y)) :
+    Continuous (orbitDiscMap j e a hgen heq) :=
+  ((Elliptic.discPower_continuous j.order j.order_pos).comp e.continuous).quotient_lift _
+
+private theorem SpecialPeriods.TriangleQuotientPower.orbitDiscMap_surjective {H Y : Type*} [Group H]
+    [TopologicalSpace Y] [MulAction H Y] (j : Elliptic.Kind) (e : Y ≃ₜ SpecialPeriods.Disc)
+    (a : H) (hgen : ∀ h : H, ∃ n : ℕ, n < j.order ∧ h = a ^ n)
+    (heq : ∀ y : Y, e (a • y) = Elliptic.familyRotation j (e y)) :
+    Function.Surjective (orbitDiscMap j e a hgen heq) := by
+  intro z
+  obtain ⟨w, hw⟩ := Elliptic.discPower_surjective j.order j.order_pos z
+  refine ⟨Quotient.mk (MulAction.orbitRel H Y) (e.symm w), ?_⟩
+  simpa only [orbitDiscMap_mk, e.apply_symm_apply] using hw
+
+private theorem SpecialPeriods.TriangleQuotientPower.orbitDiscMap_injective {H Y : Type*} [Group H]
+    [TopologicalSpace Y] [MulAction H Y] (j : Elliptic.Kind) (e : Y ≃ₜ SpecialPeriods.Disc)
+    (a : H) (hgen : ∀ h : H, ∃ n : ℕ, n < j.order ∧ h = a ^ n)
+    (heq : ∀ y : Y, e (a • y) = Elliptic.familyRotation j (e y)) :
+    Function.Injective (orbitDiscMap j e a hgen heq) := by
+  intro q r
+  refine Quotient.inductionOn₂ q r ?_
+  intro x y hxy
+  apply Quotient.sound
+  exact (powerCoordinate_eq_iff_mem_orbit j e a hgen heq x y).mp hxy
+
+private theorem SpecialPeriods.TriangleQuotientPower.orbitDiscMap_isOpenMap {H Y : Type*} [Group H]
+    [TopologicalSpace Y] [MulAction H Y] (j : Elliptic.Kind) (e : Y ≃ₜ SpecialPeriods.Disc)
+    (a : H) (hgen : ∀ h : H, ∃ n : ℕ, n < j.order ∧ h = a ^ n)
+    (heq : ∀ y : Y, e (a • y) = Elliptic.familyRotation j (e y)) :
+    IsOpenMap (orbitDiscMap j e a hgen heq) := by
+  apply
+    IsOpenMap.of_comp
+      (show Continuous (Quotient.mk (MulAction.orbitRel H Y)) from continuous_quotient_mk')
+      Quotient.mk_surjective
+  exact (discPower_isOpenMap j.order j.order_pos).comp e.isOpenMap
+
+private def SpecialPeriods.TriangleQuotientPower.orbitDiscHomeomorph {H Y : Type*} [Group H]
+    [TopologicalSpace Y] [MulAction H Y] (j : Elliptic.Kind) (e : Y ≃ₜ SpecialPeriods.Disc)
+    (a : H) (hgen : ∀ h : H, ∃ n : ℕ, n < j.order ∧ h = a ^ n)
+    (heq : ∀ y : Y, e (a • y) = Elliptic.familyRotation j (e y)) :
+    Quotient (MulAction.orbitRel H Y) ≃ₜ SpecialPeriods.Disc :=
+  Equiv.toHomeomorphOfContinuousOpen
+    (Equiv.ofBijective (orbitDiscMap j e a hgen heq)
+      ⟨orbitDiscMap_injective j e a hgen heq, orbitDiscMap_surjective j e a hgen heq⟩)
+    (orbitDiscMap_continuous j e a hgen heq) (orbitDiscMap_isOpenMap j e a hgen heq)
+
+private theorem SpecialPeriods.Triangle.cayleyCoordinate_eq_zero_iff (a z : ℍ) :
+    cayleyCoordinate a z = 0 ↔ z = a := by
+  simp [cayleyCoordinate, div_eq_zero_iff, sub_conj_ne_zero a z, sub_eq_zero]
+
+private theorem SpecialPeriods.Triangle.cayleyCoordinate_analyticAt (a z : ℍ) :
+    AnalyticAt ℂ (cayleyCoordinate a ∘ UpperHalfPlane.ofComplex) (z : ℂ) :=
+  (UpperHalfPlane.mdifferentiable_iff.mp
+        ((cayleyCoordinate_holomorphic a).mdifferentiable (by simp))).analyticAt
+    (UpperHalfPlane.isOpen_upperHalfPlaneSet.mem_nhds z.im_pos)
+
+private theorem SpecialPeriods.Triangle.cayleyCoordinate_hasStrictDerivAt_center (a : ℍ) :
+    HasStrictDerivAt (cayleyCoordinate a ∘ UpperHalfPlane.ofComplex)
+      (1 / ((a : ℂ) - starRingEnd ℂ (a : ℂ))) (a : ℂ) := by
+  have hd := sub_conj_ne_zero a a
+  have h :
+    HasStrictDerivAt (fun z : ℂ => (z - (a : ℂ)) / (z - starRingEnd ℂ (a : ℂ)))
+      (1 / ((a : ℂ) - starRingEnd ℂ (a : ℂ))) (a : ℂ) := by
+    have hn : HasStrictDerivAt (fun z : ℂ => z - (a : ℂ)) 1 (a : ℂ) :=
+      (hasStrictDerivAt_id (a : ℂ)).sub_const (a : ℂ)
+    have hd' : HasStrictDerivAt (fun z : ℂ => z - starRingEnd ℂ (a : ℂ)) 1 (a : ℂ) :=
+      (hasStrictDerivAt_id (a : ℂ)).sub_const (starRingEnd ℂ (a : ℂ))
+    convert hn.div hd' hd using 1
+    all_goals
+      first
+      | rfl
+      | (field_simp; ring)
+  apply h.congr_of_eventuallyEq
+  filter_upwards [UpperHalfPlane.eventuallyEq_coe_comp_ofComplex a.im_pos] with z hz
+  change (UpperHalfPlane.ofComplex z : ℂ) = z at hz
+  simp only [Function.comp_apply, cayleyCoordinate, hz]
+
+private theorem SpecialPeriods.Triangle.cayleyCoordinate_order_center (a : ℍ) :
+    analyticOrderAt (cayleyCoordinate a ∘ UpperHalfPlane.ofComplex) (a : ℂ) = 1 := by
+  apply (cayleyCoordinate_analyticAt a a).analyticOrderAt_eq_one_of_zero_deriv_ne_zero
+  · simp [cayleyCoordinate]
+  · rw [(cayleyCoordinate_hasStrictDerivAt_center a).hasDerivAt.deriv]
+    exact one_div_ne_zero (sub_conj_ne_zero a a)
+
+private def SpecialPeriods.Triangle.complexDivideBiholomorph (c : ℂ) (hc : c ≠ 0) :
+    Diffeomorph 𝓘(ℂ) 𝓘(ℂ) ℂ ℂ ω where
+  toFun z := z / c
+  invFun z := z * c
+  left_inv z := div_mul_cancel₀ z hc
+  right_inv z := mul_div_cancel_right₀ z hc
+  contMDiff_toFun := contMDiff_id.div₀ contMDiff_const (fun _ => hc)
+  contMDiff_invFun := contMDiff_id.mul contMDiff_const
+
+private def SpecialPeriods.Triangle.normalizedCayley (a : ℍ) (r : ℝ) (z : ℍ) : ℂ :=
+  cayleyCoordinate a z / (r : ℂ)
+
+private theorem SpecialPeriods.Triangle.normalizedCayley_holomorphic (a : ℍ) (r : ℝ) (hr : r ≠ 0) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (normalizedCayley a r) :=
+  (cayleyCoordinate_holomorphic a).div₀ contMDiff_const (fun _ => Complex.ofReal_ne_zero.mpr hr)
+
+private theorem
+    SpecialPeriods.Triangle.normalizedCayley_isLocalDiffeomorph (a : ℍ) (r : ℝ) (hr : r ≠ 0) :
+    IsLocalDiffeomorph 𝓘(ℂ) 𝓘(ℂ) ω (normalizedCayley a r) := by
+  intro z
+  have hc :=
+    ((cayleyBiholomorph a).isLocalDiffeomorph z).comp (K := 𝓘(ℂ)) (P := ℂ)
+      (isLocalDiffeomorph_subtypeVal 𝓘(ℂ) SpecialPeriods.unitDisc (toDisc a z))
+  exact
+    hc.comp (K := 𝓘(ℂ)) (P := ℂ)
+      ((complexDivideBiholomorph (r : ℂ) (Complex.ofReal_ne_zero.mpr hr)).isLocalDiffeomorph
+        (cayleyCoordinate a z))
+
+private def SpecialPeriods.Triangle.normalizedCayleyBranch (a : ℍ) (r : ℝ) (m : ℕ) (z : ℍ) : ℂ :=
+  normalizedCayley a r z ^ m
+
+private theorem
+    SpecialPeriods.Triangle.normalizedCayleyBranch_holomorphic (a : ℍ) (r : ℝ) (hr : r ≠ 0)
+    (m : ℕ) : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (normalizedCayleyBranch a r m) :=
+  (normalizedCayley_holomorphic a r hr).pow m
+
+private theorem
+    SpecialPeriods.Triangle.normalizedCayleyBranch_isLocalDiffeomorphAt (a z : ℍ) (r : ℝ)
+    (hr : r ≠ 0) (m : ℕ) (hm : 0 < m) (hz : z ≠ a) :
+    IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω (normalizedCayleyBranch a r m) z := by
+  have hc : normalizedCayley a r z ≠ 0 :=
+    div_ne_zero ((cayleyCoordinate_eq_zero_iff a z).not.mpr hz) (Complex.ofReal_ne_zero.mpr hr)
+  exact
+    (normalizedCayley_isLocalDiffeomorph a r hr z).comp (K := 𝓘(ℂ)) (P := ℂ)
+      (Elliptic.complexPower_isLocalDiffeomorphAt m hm (normalizedCayley a r z) hc)
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Uniformization/SpecialPeriods3.lean b/LeanPool/HopfProblem/Uniformization/SpecialPeriods3.lean
new file mode 100644
index 000000000..ee4adaf36
--- /dev/null
+++ b/LeanPool/HopfProblem/Uniformization/SpecialPeriods3.lean
@@ -0,0 +1,3066 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Foundations.TwoAffineCharts
+public import LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Recognition.Smale1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Elliptic.Core2
+import all LeanPool.HopfProblem.Foundations.LocalOrbitQuotient
+import all LeanPool.HopfProblem.Foundations.TwoAffineCharts
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+
+/-!
+# Hopf problem: uniformization · special periods 3
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.ellipticLocalDiscHomeomorph (j : Elliptic.Kind) :
+    EllipticNeighborhoodQuotient j ≃ₜ SpecialPeriods.Disc := by
+  letI := ellipticNeighborhoodAction j
+  exact
+    SpecialPeriods.TriangleQuotientPower.orbitDiscHomeomorph j
+      (ellipticNeighborhoodChart j).toHomeomorph (ellipticStabilizerGenerator j)
+      (ellipticStabilizer_eq_generator_pow j) (ellipticNeighborhoodChart_generator j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+@[simp]
+private theorem SpecialPeriods.Triangle.ellipticLocalDiscHomeomorph_mk (j : Elliptic.Kind)
+    (z : ellipticNeighborhood j) :
+    ellipticLocalDiscHomeomorph j
+        (LocalOrbitQuotient.localProjection (ellipticStabilizer j) (ellipticNeighborhood j)
+          (ellipticNeighborhood_mapsTo j) z) =
+      Elliptic.discPower j.order j.order_pos (ellipticNeighborhoodChart j z) :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.ellipticImageDiscHomeomorph (j : Elliptic.Kind) :
+    ellipticNeighborhoodImage j ≃ₜ SpecialPeriods.Disc :=
+  (ellipticNeighborhoodQuotientHomeomorph j).symm.trans (ellipticLocalDiscHomeomorph j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticImageDiscHomeomorph_projection (j : Elliptic.Kind)
+    (z : ellipticNeighborhood j) :
+    ellipticImageDiscHomeomorph j
+        (LocalOrbitQuotient.imageProjection (G := SpecialPeriods.TriangleGroup)
+          (ellipticNeighborhood j) z) =
+      Elliptic.discPower j.order j.order_pos (ellipticNeighborhoodChart j z) := by
+  let q :=
+    LocalOrbitQuotient.localProjection (ellipticStabilizer j) (ellipticNeighborhood j)
+      (ellipticNeighborhood_mapsTo j) z
+  have he :
+    ellipticNeighborhoodQuotientHomeomorph j q =
+      LocalOrbitQuotient.imageProjection (G := SpecialPeriods.TriangleGroup)
+        (ellipticNeighborhood j) z :=
+    rfl
+  change ellipticLocalDiscHomeomorph j ((ellipticNeighborhoodQuotientHomeomorph j).symm _) = _
+  rw [← he, Homeomorph.symm_apply_apply]
+  exact ellipticLocalDiscHomeomorph_mk j z
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.ellipticOrbitParametrization (j : Elliptic.Kind) :
+    OpenPartialHomeomorph SpecialPeriods.Disc SpecialPeriods.TriangleOrbitSpace :=
+  (ellipticImageDiscHomeomorph j).symm.toOpenPartialHomeomorph.trans
+    ((ellipticNeighborhoodImage j).openPartialHomeomorphSubtypeCoe
+      ⟨⟨ellipticOrbitCenter j, ellipticOrbitCenter_mem_neighborhoodImage j⟩⟩)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+@[simp]
+private theorem SpecialPeriods.Triangle.ellipticOrbitParametrization_source (j : Elliptic.Kind) :
+    (ellipticOrbitParametrization j).source = Set.univ := by simp [ellipticOrbitParametrization]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+@[simp]
+private theorem SpecialPeriods.Triangle.ellipticOrbitParametrization_target (j : Elliptic.Kind) :
+    (ellipticOrbitParametrization j).target = ellipticNeighborhoodImage j := by
+  simp [ellipticOrbitParametrization]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticOrbitParametrization_power (j : Elliptic.Kind)
+    (z : ellipticNeighborhood j) :
+    ellipticOrbitParametrization j
+        (Elliptic.discPower j.order j.order_pos (ellipticNeighborhoodChart j z)) =
+      SpecialPeriods.triangleOrbitProjection z := by
+  change
+    ((ellipticImageDiscHomeomorph j).symm
+          (Elliptic.discPower j.order j.order_pos (ellipticNeighborhoodChart j z)) :
+        SpecialPeriods.TriangleOrbitSpace) =
+      SpecialPeriods.triangleOrbitProjection z
+  rw [← ellipticImageDiscHomeomorph_projection j z]
+  exact
+    congrArg (fun q : ellipticNeighborhoodImage j => (q : SpecialPeriods.TriangleOrbitSpace))
+      ((ellipticImageDiscHomeomorph j).symm_apply_apply
+        (show ellipticNeighborhoodImage j from
+          LocalOrbitQuotient.imageProjection (G := SpecialPeriods.TriangleGroup)
+            (ellipticNeighborhood j) z))
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private def SpecialPeriods.Triangle.ellipticFullChart (j : Elliptic.Kind) :
+    OpenPartialHomeomorph SpecialPeriods.TriangleOrbitSpace ℂ :=
+  (ellipticOrbitParametrization j).symm.trans
+    (SpecialPeriods.unitDisc.openPartialHomeomorphSubtypeCoe ⟨SpecialPeriods.discZero⟩)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+@[simp]
+private theorem SpecialPeriods.Triangle.ellipticFullChart_source (j : Elliptic.Kind) :
+    (ellipticFullChart j).source = ellipticNeighborhoodImage j := by simp [ellipticFullChart]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+@[simp]
+private theorem SpecialPeriods.Triangle.ellipticFullChart_target (j : Elliptic.Kind) :
+    (ellipticFullChart j).target = SpecialPeriods.unitDisc := by simp [ellipticFullChart]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticFullChart_projection (j : Elliptic.Kind)
+    (z : ellipticNeighborhood j) :
+    ellipticFullChart j (SpecialPeriods.triangleOrbitProjection z) =
+      normalizedCayleyBranch (ellipticCenter j) (ellipticNeighborhoodRadius j) j.order z := by
+  have he :
+    (ellipticOrbitParametrization j).symm (SpecialPeriods.triangleOrbitProjection z) =
+      Elliptic.discPower j.order j.order_pos (ellipticNeighborhoodChart j z) := by
+    rw [← ellipticOrbitParametrization_power j z]
+    exact (ellipticOrbitParametrization j).left_inv (by simp)
+  change
+    ((ellipticOrbitParametrization j).symm (SpecialPeriods.triangleOrbitProjection z) : ℂ) = _
+  rw [he, Elliptic.discPower_coe, ellipticNeighborhoodChart_val]
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticFullChart_center_mem_source (j : Elliptic.Kind) :
+    ellipticOrbitCenter j ∈ (ellipticFullChart j).source := by
+  rw [ellipticFullChart_source]
+  exact ellipticOrbitCenter_mem_neighborhoodImage j
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+@[simp]
+private theorem SpecialPeriods.Triangle.ellipticFullChart_center (j : Elliptic.Kind) :
+    ellipticFullChart j (ellipticOrbitCenter j) = 0 := by
+  have he := ellipticFullChart_projection j (ellipticNeighborhoodCenter j)
+  simpa only [ellipticOrbitCenter, ellipticNeighborhoodCenter, normalizedCayleyBranch,
+    normalizedCayley, cayleyCoordinate, sub_self, zero_div, zero_pow j.order_pos.ne'] using he
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticFullChart_other_not_mem_source (j : Elliptic.Kind) :
+    ellipticOrbitCenter (ellipticOtherKind j) ∉ (ellipticFullChart j).source := by
+  rw [ellipticFullChart_source]
+  exact ellipticOtherOrbitCenter_not_mem_neighborhoodImage j
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticFullChart_pullback_eventuallyEq (j : Elliptic.Kind)
+    (g : SpecialPeriods.TriangleGroup) {z : ℍ}
+    (hz : SpecialPeriods.triangleGeometricRepresentation g z ∈ ellipticNeighborhood j) :
+    (ellipticFullChart j ∘ SpecialPeriods.triangleOrbitProjection) =ᶠ[𝓝 z]
+      (normalizedCayleyBranch (ellipticCenter j) (ellipticNeighborhoodRadius j) j.order ∘
+        SpecialPeriods.triangleGeometricRepresentation g) := by
+  have hU :
+    ∀ᶠ w in 𝓝 z, SpecialPeriods.triangleGeometricRepresentation g w ∈ ellipticNeighborhood j :=
+    (SpecialPeriods.triangleGeometricRepresentation_holomorphic g).continuous.continuousAt
+      ((ellipticNeighborhood j).isOpen.mem_nhds hz)
+  filter_upwards [hU] with w hw
+  change ellipticFullChart j (SpecialPeriods.triangleOrbitProjection w) = _
+  rw [← SpecialPeriods.triangleOrbitProjection_smul g w]
+  exact ellipticFullChart_projection j ⟨SpecialPeriods.triangleGeometricRepresentation g w, hw⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticFullChart_exists_lift (j : Elliptic.Kind) {z : ℍ}
+    (hz : SpecialPeriods.triangleOrbitProjection z ∈ (ellipticFullChart j).source) :
+    ∃ g : SpecialPeriods.TriangleGroup,
+      SpecialPeriods.triangleGeometricRepresentation g z ∈ ellipticNeighborhood j := by
+  rw [ellipticFullChart_source] at hz
+  obtain ⟨w, hw, he⟩ := hz
+  obtain ⟨g, hg⟩ := (SpecialPeriods.triangleOrbitProjection_eq_iff w z).mp he
+  exact ⟨g, hg ▸ hw⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticFullChart_pullback_holomorphic (j : Elliptic.Kind) :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (ellipticFullChart j ∘ SpecialPeriods.triangleOrbitProjection)
+      (SpecialPeriods.triangleOrbitProjection ⁻¹' (ellipticFullChart j).source) := by
+  intro z hz
+  obtain ⟨g, hg⟩ := ellipticFullChart_exists_lift j hz
+  have hf :=
+    (normalizedCayleyBranch_holomorphic (ellipticCenter j) (ellipticNeighborhoodRadius j)
+          (ellipticNeighborhoodRadius_pos j).ne' j.order).comp
+      (SpecialPeriods.triangleGeometricRepresentation_holomorphic g)
+  exact
+    (hf.contMDiffAt.congr_of_eventuallyEq
+        (ellipticFullChart_pullback_eventuallyEq j g hg)).contMDiffWithinAt
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous
+    SpecialPeriods.triangleGeometricAction_continuous in
+private theorem SpecialPeriods.Triangle.ellipticFullChart_pullback_isLocalDiffeomorphAt
+    (j : Elliptic.Kind) {z : ℍ}
+    (hz : SpecialPeriods.triangleOrbitProjection z ∈ (ellipticFullChart j).source)
+    (hcenter : SpecialPeriods.triangleOrbitProjection z ≠ ellipticOrbitCenter j) :
+    IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω
+      (ellipticFullChart j ∘ SpecialPeriods.triangleOrbitProjection) z := by
+  obtain ⟨g, hg⟩ := ellipticFullChart_exists_lift j hz
+  have hgc : SpecialPeriods.triangleGeometricRepresentation g z ≠ ellipticCenter j := by
+    intro h
+    apply hcenter
+    rw [← SpecialPeriods.triangleOrbitProjection_smul g z, h]
+    rfl
+  have hf :=
+    ((SpecialPeriods.triangleGeometricBiholomorph g).isLocalDiffeomorph z).comp (K := 𝓘(ℂ)) (P :=
+      ℂ)
+      (normalizedCayleyBranch_isLocalDiffeomorphAt (ellipticCenter j)
+        (SpecialPeriods.triangleGeometricRepresentation g z) (ellipticNeighborhoodRadius j)
+        (ellipticNeighborhoodRadius_pos j).ne' j.order j.order_pos hgc)
+  exact
+    isLocalDiffeomorphAt_congr_of_eventuallyEq hf (ellipticFullChart_pullback_eventuallyEq j g hg)
+
+private abbrev SpecialPeriods.TriangleOrbitChartIndex :=
+  TriangleRegularQuotient ⊕ Elliptic.Kind
+
+private def SpecialPeriods.triangleOrbitChart :
+    TriangleOrbitChartIndex → OpenPartialHomeomorph TriangleOrbitSpace ℂ
+  | .inl x => regularFullChart x
+  | .inr j => Triangle.ellipticFullChart j
+
+private theorem SpecialPeriods.triangleOrbitChart_cover (x : TriangleOrbitSpace) :
+    ∃ i, x ∈ (triangleOrbitChart i).source := by
+  by_cases h₁ : x = triangleOrbitCenterOne
+  · subst x
+    exact ⟨.inr .three, Triangle.ellipticFullChart_center_mem_source .three⟩
+  by_cases h₂ : x = triangleOrbitCenterTwo
+  · subst x
+    exact ⟨.inr .four, Triangle.ellipticFullChart_center_mem_source .four⟩
+  obtain ⟨r, hr⟩ :=
+    exists_regularFullChart x ((triangleOrbitRegularDomain_mem_iff x).mpr ⟨h₁, h₂⟩)
+  exact ⟨.inl r, hr⟩
+
+private theorem SpecialPeriods.triangleOrbitChart_center_unique (j : Elliptic.Kind)
+    (i : TriangleOrbitChartIndex)
+    (hi : Triangle.ellipticOrbitCenter j ∈ (triangleOrbitChart i).source) : i = .inr j := by
+  cases i with
+  | inl
+    x =>
+    have h := (triangleOrbitRegularDomain_mem_iff _).mp (regularFullChart_source_subset x hi)
+    cases j
+    · exact (h.1 rfl).elim
+    · exact (h.2 rfl).elim
+  | inr k =>
+    cases j <;> cases k
+    · rfl
+    · exact (Triangle.ellipticFullChart_other_not_mem_source .four hi).elim
+    · exact (Triangle.ellipticFullChart_other_not_mem_source .three hi).elim
+    · rfl
+
+private def SpecialPeriods.triangleOrbitAtlasData :
+    BranchedQuotientAtlas.Data (E := ℂ) triangleOrbitProjection TriangleOrbitChartIndex
+    where
+  chart := triangleOrbitChart
+  cover := triangleOrbitChart_cover
+  continuous_project := triangleOrbitProjection_continuous
+  pullback_contMDiff
+    i := by
+    cases i with
+    | inl x => exact regularFullChart_pullback_holomorphic x
+    | inr j => exact Triangle.ellipticFullChart_pullback_holomorphic j
+  overlap_lift i j hij z
+    hz := by
+    obtain ⟨a, ha⟩ := triangleOrbitProjection_surjective ((triangleOrbitChart i).symm z)
+    have hsource : triangleOrbitProjection a ∈ (triangleOrbitChart i).source := by
+      rw [ha]
+      exact (triangleOrbitChart i).map_target hz.1
+    refine ⟨a, ha, ?_⟩
+    cases i with
+    | inl r => exact regularFullChart_pullback_isLocalDiffeomorphAt r hsource
+    | inr k =>
+      apply Triangle.ellipticFullChart_pullback_isLocalDiffeomorphAt k hsource
+      intro h
+      have hcritical : Triangle.ellipticOrbitCenter k ∈ (triangleOrbitChart j).source := by
+        rw [← h, ha]
+        exact hz.2
+      exact hij (triangleOrbitChart_center_unique k j hcritical).symm
+
+@[instance_reducible]
+private def SpecialPeriods.triangleOrbitChartedSpace : ChartedSpace ℂ TriangleOrbitSpace :=
+  triangleOrbitAtlasData.chartedSpace
+
+private theorem SpecialPeriods.triangleOrbit_isManifold :
+    letI := triangleOrbitChartedSpace
+    IsManifold 𝓘(ℂ) ω TriangleOrbitSpace :=
+  triangleOrbitAtlasData.isManifold
+
+private theorem SpecialPeriods.triangleOrbitChart_mem_atlas (i : TriangleOrbitChartIndex) :
+    letI := triangleOrbitChartedSpace
+    triangleOrbitChart i ∈ atlas ℂ TriangleOrbitSpace :=
+  triangleOrbitAtlasData.chart_mem_atlas i
+
+private theorem SpecialPeriods.triangleOrbitProjection_holomorphic :
+    letI := triangleOrbitChartedSpace
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω triangleOrbitProjection :=
+  triangleOrbitAtlasData.contMDiff_project
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+private theorem SpecialPeriods.instIsManifold2 : IsManifold 𝓘(ℂ) ω TriangleOrbitSpace :=
+  triangleOrbit_isManifold
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold2 in
+private def SpecialPeriods.triangleOrbitCoordinatePartial (i : TriangleOrbitChartIndex) :
+    PartialDiffeomorph 𝓘(ℂ) 𝓘(ℂ) TriangleOrbitSpace ℂ ω
+    where
+  toPartialEquiv := (triangleOrbitChart i).toPartialEquiv
+  open_source := (triangleOrbitChart i).open_source
+  open_target := (triangleOrbitChart i).open_target
+  contMDiffOn_toFun :=
+    contMDiffOn_of_mem_maximalAtlas
+      (StructureGroupoid.subset_maximalAtlas _ (triangleOrbitChart_mem_atlas i))
+  contMDiffOn_invFun :=
+    contMDiffOn_symm_of_mem_maximalAtlas
+      (StructureGroupoid.subset_maximalAtlas _ (triangleOrbitChart_mem_atlas i))
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold2 in
+private theorem SpecialPeriods.triangleOrbitProjection_isLocalDiffeomorphAt_of_regular {z : ℍ}
+    (hz : z ∈ triangleRegularLocus) :
+    IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω triangleOrbitProjection z := by
+  obtain ⟨r, hr⟩ :=
+    exists_regularFullChart (triangleOrbitProjection z)
+      ((triangleOrbitProjection_mem_regularDomain_iff z).mpr hz)
+  have hf := regularFullChart_pullback_isLocalDiffeomorphAt r hr
+  have hinv :
+    IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω (regularFullChart r).symm
+      (regularFullChart r (triangleOrbitProjection z)) :=
+    (triangleOrbitCoordinatePartial (.inl r)).symm.isLocalDiffeomorphAt _ _ _
+      ((regularFullChart r).map_source hr)
+  have hcomp := hf.comp (K := 𝓘(ℂ)) (P := TriangleOrbitSpace) hinv
+  apply isLocalDiffeomorphAt_congr_of_eventuallyEq hcomp
+  have hU : ∀ᶠ w in 𝓝 z, triangleOrbitProjection w ∈ (regularFullChart r).source :=
+    triangleOrbitProjection_continuous.continuousAt ((regularFullChart r).open_source.mem_nhds hr)
+  exact hU.mono fun w hw => ((regularFullChart r).left_inv hw).symm
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold2 in
+private theorem SpecialPeriods.triangleOrbitProjection_isLocalDiffeomorphAt_of_not_elliptic {z : ℍ}
+    (h₁ : triangleOrbitProjection z ≠ triangleOrbitCenterOne)
+    (h₂ : triangleOrbitProjection z ≠ triangleOrbitCenterTwo) :
+    IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω triangleOrbitProjection z :=
+  triangleOrbitProjection_isLocalDiffeomorphAt_of_regular
+    ((triangleOrbitProjection_mem_regularDomain_iff z).mp
+      ((triangleOrbitRegularDomain_mem_iff _).mpr ⟨h₁, h₂⟩))
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold2 in
+private theorem SpecialPeriods.triangleRegularToOrbit_holomorphic :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω triangleRegularToOrbit := by
+  apply CoveringQuotient.contMDiff_of_comp triangleRegularProject_covering 𝓘(ℂ) ω
+  have hf :=
+    triangleOrbitProjection_holomorphic.comp
+      (contMDiff_subtype_val (U := triangleRegularDomain) (I := 𝓘(ℂ)) (n := ω))
+  convert hf using 1
+  funext z
+  exact triangleRegularToOrbit_project z
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold2 in
+private theorem SpecialPeriods.triangleRegularOrbitHomeomorph_holomorphic :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω triangleRegularOrbitHomeomorph := by
+  intro x
+  have he :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω
+        (fun y : TriangleRegularQuotient =>
+          (triangleRegularOrbitHomeomorph y : TriangleOrbitSpace))
+        x ↔
+      ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω triangleRegularOrbitHomeomorph x :=
+    ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..
+  exact he.mp (triangleRegularToOrbit_holomorphic x)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold2 in
+private def SpecialPeriods.triangleRegularFullProjection :
+    TriangleRegularPoint → triangleOrbitRegularDomain := fun z =>
+  ⟨triangleOrbitProjection z, (triangleOrbitProjection_mem_regularDomain_iff z).mpr z.property⟩
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold2 in
+private theorem SpecialPeriods.triangleRegularFullProjection_eq :
+    triangleRegularFullProjection = triangleRegularOrbitHomeomorph ∘ triangleRegularProject := by
+  funext z
+  apply Subtype.ext
+  exact (triangleRegularToOrbit_project z).symm
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold2 in
+private theorem SpecialPeriods.triangleRegularFullProjection_isLocalDiffeomorph :
+    IsLocalDiffeomorph 𝓘(ℂ) 𝓘(ℂ) ω triangleRegularFullProjection := by
+  intro z
+  exact
+    isLocalDiffeomorphAt_restrictOpens 𝓘(ℂ) 𝓘(ℂ)
+      (triangleOrbitProjection_isLocalDiffeomorphAt_of_regular z.property) triangleRegularDomain
+      triangleOrbitRegularDomain
+      (fun w hw => (triangleOrbitProjection_mem_regularDomain_iff w).mpr hw) z.property
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold2 in
+private theorem SpecialPeriods.triangleRegularFullProjection_surjective :
+    Function.Surjective triangleRegularFullProjection := by
+  rw [triangleRegularFullProjection_eq]
+  exact triangleRegularOrbitHomeomorph.surjective.comp triangleRegularProject_surjective
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold2 in
+private theorem SpecialPeriods.triangleRegularOrbitHomeomorph_symm_holomorphic :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω triangleRegularOrbitHomeomorph.symm := by
+  apply
+    contMDiff_of_comp_localDiffeomorph 𝓘(ℂ) 𝓘(ℂ) 𝓘(ℂ)
+      triangleRegularFullProjection_isLocalDiffeomorph triangleRegularFullProjection_surjective
+  have he :
+    triangleRegularOrbitHomeomorph.symm ∘ triangleRegularFullProjection =
+      triangleRegularProject := by
+    rw [triangleRegularFullProjection_eq]
+    funext z
+    exact triangleRegularOrbitHomeomorph.symm_apply_apply (triangleRegularProject z)
+  rw [he]
+  exact triangleRegularProject_holomorphic
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleRegularQuotientChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold2 in
+private def SpecialPeriods.triangleRegularOrbitBiholomorph :
+    Diffeomorph 𝓘(ℂ) 𝓘(ℂ) TriangleRegularQuotient triangleOrbitRegularDomain ω
+    where
+  toEquiv := triangleRegularOrbitHomeomorph.toEquiv
+  contMDiff_toFun := triangleRegularOrbitHomeomorph_holomorphic
+  contMDiff_invFun := triangleRegularOrbitHomeomorph_symm_holomorphic
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+private theorem
+    SpecialPeriods.Triangle.cuspImageProjection_isLocalDiffeomorph (Y : ℝ) (hY : width ≤ Y) :
+    IsLocalDiffeomorph 𝓘(ℂ) 𝓘(ℂ) ω (cuspImageProjection Y) := by
+  intro z
+  exact
+    isLocalDiffeomorphAt_restrictOpens 𝓘(ℂ) 𝓘(ℂ)
+      (SpecialPeriods.triangleOrbitProjection_isLocalDiffeomorphAt_of_regular
+        (horodisc_subset_triangleRegularLocus Y hY z.property))
+      (horodisc Y) (cuspImage Y) (fun w hw => ⟨w, hw, rfl⟩) z.property
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+private theorem SpecialPeriods.Triangle.cuspImageHomeomorph_holomorphic (Y : ℝ) (hY : width ≤ Y) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (cuspImageHomeomorph Y hY) := by
+  apply
+    contMDiff_of_comp_localDiffeomorph 𝓘(ℂ) 𝓘(ℂ) 𝓘(ℂ)
+      (cuspImageProjection_isLocalDiffeomorph Y hY) (cuspImageProjection_surjective Y)
+  have he : (cuspImageHomeomorph Y hY) ∘ cuspImageProjection Y = cuspQHorodisc Y := by
+    funext z
+    exact cuspImageHomeomorph_mk Y hY z
+  rw [he]
+  exact cuspQHorodisc_holomorphic Y
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+private theorem
+    SpecialPeriods.Triangle.cuspImageHomeomorph_symm_holomorphic (Y : ℝ) (hY : width ≤ Y) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (cuspImageHomeomorph Y hY).symm := by
+  apply
+    contMDiff_of_comp_localDiffeomorph 𝓘(ℂ) 𝓘(ℂ) 𝓘(ℂ) (cuspQHorodisc_isLocalDiffeomorph Y)
+      (cuspQHorodisc_surjective Y (width_pos.le.trans hY))
+  have he : (cuspImageHomeomorph Y hY).symm ∘ cuspQHorodisc Y = cuspImageProjection Y := by
+    funext z
+    exact cuspImageHomeomorph_symm_q Y hY z
+  rw [he]
+  exact (cuspImageProjection_isLocalDiffeomorph Y hY).contMDiff
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+private def SpecialPeriods.Triangle.cuspImageBiholomorph (Y : ℝ) (hY : width ≤ Y) :
+    Diffeomorph 𝓘(ℂ) 𝓘(ℂ) (cuspImage Y) (puncturedCuspBall Y) ω
+    where
+  toEquiv := (cuspImageHomeomorph Y hY).toEquiv
+  contMDiff_toFun := cuspImageHomeomorph_holomorphic Y hY
+  contMDiff_invFun := cuspImageHomeomorph_symm_holomorphic Y hY
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Triangle.cuspImageBiholomorph_toHomeomorph (Y : ℝ) (hY : width ≤ Y) :
+    (cuspImageBiholomorph Y hY).toHomeomorph = cuspImageHomeomorph Y hY := by
+  ext x
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+private theorem SpecialPeriods.Triangle.cuspImageNonemptyForChart_mo1973_16605 (Y : ℝ) :
+    Nonempty (cuspImage Y) := by
+  obtain ⟨z, hz⟩ := horodisc_nonempty Y
+  exact ⟨cuspImageProjection Y ⟨z, hz⟩⟩
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+private def SpecialPeriods.Triangle.cuspImagePartialDiffeomorph (Y : ℝ) (hY : width ≤ Y) :
+    PartialDiffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleOrbitSpace ℂ ω :=
+  (opensInclusionPartialDiffeomorph 𝓘(ℂ) (cuspImage Y)
+        (cuspImageNonemptyForChart_mo1973_16605 Y)).symm.trans
+    ((cuspImageBiholomorph Y hY).toPartialDiffeomorph.trans
+      (opensInclusionPartialDiffeomorph 𝓘(ℂ) (puncturedCuspBall Y)
+        ((cuspImageNonemptyForChart_mo1973_16605 Y).map (cuspImageHomeomorph Y hY))))
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+@[simp]
+private theorem
+    SpecialPeriods.Triangle.cuspImagePartialDiffeomorph_source (Y : ℝ) (hY : width ≤ Y) :
+    (cuspImagePartialDiffeomorph Y hY).source =
+      (cuspImage Y : Set SpecialPeriods.TriangleOrbitSpace) := by
+  simp [cuspImagePartialDiffeomorph, PartialDiffeomorph.trans, PartialDiffeomorph.symm,
+    Diffeomorph.toPartialDiffeomorph, opensInclusionPartialDiffeomorph]
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+private theorem SpecialPeriods.Triangle.cuspImagePartialDiffeomorph_apply (Y : ℝ) (hY : width ≤ Y)
+    (x : SpecialPeriods.TriangleOrbitSpace) (hx : x ∈ cuspImage Y) :
+    cuspImagePartialDiffeomorph Y hY x = (cuspImageHomeomorph Y hY ⟨x, hx⟩ : ℂ) := by
+  let e :=
+    (cuspImage Y).openPartialHomeomorphSubtypeCoe (cuspImageNonemptyForChart_mo1973_16605 Y)
+  have he : e.symm x = ⟨x, hx⟩ := e.left_inv (Set.mem_univ (⟨x, hx⟩ : cuspImage Y))
+  change (cuspImageBiholomorph Y hY (e.symm x) : ℂ) = _
+  rw [he]
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+private theorem
+    SpecialPeriods.Triangle.cuspImagePartialDiffeomorph_holomorphic (Y : ℝ) (hY : width ≤ Y) :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (cuspImagePartialDiffeomorph Y hY)
+      (cuspImage Y : Set SpecialPeriods.TriangleOrbitSpace) := by
+  simpa only [cuspImagePartialDiffeomorph_source] using
+    (cuspImagePartialDiffeomorph Y hY).contMDiffOn
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+private theorem SpecialPeriods.instIsManifold3 : IsManifold 𝓘(ℂ) ω TriangleOrbitSpace :=
+  triangleOrbit_isManifold
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold3 in
+private theorem SpecialPeriods.Triangle.cuspFullChart_pullback_eqOn (Y : ℝ) (hY : width ≤ Y) :
+    Set.EqOn (cuspFullChart Y hY ∘ SpecialPeriods.triangleOpenInclusion)
+      (cuspImagePartialDiffeomorph Y hY) (cuspImage Y : Set SpecialPeriods.TriangleOrbitSpace) := by
+  intro q hq
+  simp only [Function.comp_apply, cuspFullChart_openInclusion Y hY q hq,
+    cuspImagePartialDiffeomorph_apply Y hY q hq]
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold3 in
+private theorem
+    SpecialPeriods.Triangle.cuspFullChart_pullback_holomorphic (Y : ℝ) (hY : width ≤ Y) :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (cuspFullChart Y hY ∘ SpecialPeriods.triangleOpenInclusion)
+      (SpecialPeriods.triangleOpenInclusion ⁻¹' (cuspFullChart Y hY).source) := by
+  rw [cuspFullChart_source, cuspNeighborhood_preimage]
+  exact (cuspImagePartialDiffeomorph_holomorphic Y hY).congr (cuspFullChart_pullback_eqOn Y hY)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold3 in
+private theorem SpecialPeriods.Triangle.cuspFullChart_pullback_isLocalDiffeomorphAt (Y : ℝ)
+    (hY : width ≤ Y) (q : SpecialPeriods.TriangleOrbitSpace)
+    (hq : SpecialPeriods.triangleOpenInclusion q ∈ (cuspFullChart Y hY).source) :
+    IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω (cuspFullChart Y hY ∘ SpecialPeriods.triangleOpenInclusion)
+      q := by
+  have hmem : q ∈ cuspImage Y := (openInclusion_mem_cuspNeighborhood Y q).mp hq
+  refine ⟨cuspImagePartialDiffeomorph Y hY, ?_, ?_⟩
+  · rw [cuspImagePartialDiffeomorph_source]
+    exact hmem
+  · rw [cuspImagePartialDiffeomorph_source]
+    exact cuspFullChart_pullback_eqOn Y hY
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold3 in
+private def SpecialPeriods.triangleCompactifiedAtlasData :
+    BranchedQuotientAtlas.Data (E := ℂ) triangleOpenInclusion (Option TriangleOrbitSpace) :=
+  OnePointAtlas.data (Triangle.cuspFullChart Triangle.width le_rfl)
+    (Triangle.cuspPoint_mem_cuspNeighborhood Triangle.width)
+    (Triangle.cuspFullChart_pullback_holomorphic Triangle.width le_rfl)
+    (Triangle.cuspFullChart_pullback_isLocalDiffeomorphAt Triangle.width le_rfl)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold3 in
+@[instance_reducible]
+private def SpecialPeriods.triangleCompactifiedChartedSpace :
+    ChartedSpace ℂ TriangleCompactifiedOrbitSpace :=
+  triangleCompactifiedAtlasData.chartedSpace
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold3 in
+private theorem SpecialPeriods.triangleCompactified_isManifold :
+    letI := triangleCompactifiedChartedSpace
+    IsManifold 𝓘(ℂ) ω TriangleCompactifiedOrbitSpace :=
+  triangleCompactifiedAtlasData.isManifold
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold3 in
+private theorem SpecialPeriods.triangleCompactified_cuspChart_mem_atlas :
+    letI := triangleCompactifiedChartedSpace
+    Triangle.cuspFullChart Triangle.width le_rfl ∈ atlas ℂ TriangleCompactifiedOrbitSpace :=
+  triangleCompactifiedAtlasData.chart_mem_atlas Option.none
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold3 in
+private theorem SpecialPeriods.triangleOpenInclusion_holomorphic :
+    letI := triangleCompactifiedChartedSpace
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω triangleOpenInclusion :=
+  triangleCompactifiedAtlasData.contMDiff_project
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold3 in
+private def SpecialPeriods.triangleCompactifiedProjection : ℍ → TriangleCompactifiedOrbitSpace :=
+  triangleOpenInclusion ∘ triangleOrbitProjection
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold3 in
+private theorem SpecialPeriods.triangleCompactified_cuspChart_holomorphic :
+    letI := triangleCompactifiedChartedSpace
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (Triangle.cuspFullChart Triangle.width le_rfl)
+      (Triangle.cuspNeighborhood Triangle.width : Set TriangleCompactifiedOrbitSpace) := by
+  let := triangleCompactifiedChartedSpace
+  let := triangleCompactified_isManifold
+  exact
+    contMDiffOn_of_mem_maximalAtlas
+      (IsManifold.subset_maximalAtlas triangleCompactified_cuspChart_mem_atlas)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold3 in
+private theorem SpecialPeriods.triangleCompactified_cuspChart_symm_holomorphic :
+    letI := triangleCompactifiedChartedSpace
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (Triangle.cuspFullChart Triangle.width le_rfl).symm
+      (Metric.ball 0 (Triangle.cuspRadius Triangle.width)) := by
+  let := triangleCompactifiedChartedSpace
+  let := triangleCompactified_isManifold
+  exact
+    contMDiffOn_symm_of_mem_maximalAtlas
+      (IsManifold.subset_maximalAtlas triangleCompactified_cuspChart_mem_atlas)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.instIsManifold4 : IsManifold 𝓘(ℂ) ω TriangleOrbitSpace :=
+  triangleOrbit_isManifold
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold4 in
+private theorem SpecialPeriods.instIsManifold5 : IsManifold 𝓘(ℂ) ω TriangleCompactifiedOrbitSpace :=
+  triangleCompactified_isManifold
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold4 SpecialPeriods.instIsManifold5 in
+private def SpecialPeriods.triangleCompactifiedOldCoordinatePartial (q : TriangleOrbitSpace) :
+    PartialDiffeomorph 𝓘(ℂ) 𝓘(ℂ) TriangleCompactifiedOrbitSpace ℂ ω
+    where
+  toPartialEquiv := (OnePointAtlas.oldChart q).toPartialEquiv
+  open_source := (OnePointAtlas.oldChart q).open_source
+  open_target := (OnePointAtlas.oldChart q).open_target
+  contMDiffOn_toFun :=
+    contMDiffOn_of_mem_maximalAtlas
+      (IsManifold.subset_maximalAtlas
+        (triangleCompactifiedAtlasData.chart_mem_atlas (Option.some q)))
+  contMDiffOn_invFun :=
+    contMDiffOn_symm_of_mem_maximalAtlas
+      (IsManifold.subset_maximalAtlas
+        (triangleCompactifiedAtlasData.chart_mem_atlas (Option.some q)))
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold4 SpecialPeriods.instIsManifold5 in
+private theorem SpecialPeriods.triangleOpenInclusion_isLocalDiffeomorph :
+    IsLocalDiffeomorph 𝓘(ℂ) 𝓘(ℂ) ω triangleOpenInclusion := by
+  intro q
+  have hq : triangleOpenInclusion q ∈ (OnePointAtlas.oldChart q).source :=
+    (OnePointAtlas.coe_mem_oldChart_source q q).mpr (mem_chart_source ℂ q)
+  have hpull := OnePointAtlas.oldChart_pullback_localDiffeomorph q q hq
+  have hinv :
+    IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω (OnePointAtlas.oldChart q).symm
+      (OnePointAtlas.oldChart q (triangleOpenInclusion q)) :=
+    (triangleCompactifiedOldCoordinatePartial q).symm.isLocalDiffeomorphAt _ _ _
+      ((OnePointAtlas.oldChart q).map_source hq)
+  have hcomp := hpull.comp (K := 𝓘(ℂ)) (P := TriangleCompactifiedOrbitSpace) hinv
+  apply isLocalDiffeomorphAt_congr_of_eventuallyEq hcomp
+  have hU : ∀ᶠ x in 𝓝 q, triangleOpenInclusion x ∈ (OnePointAtlas.oldChart q).source :=
+    OnePoint.continuous_coe.continuousAt ((OnePointAtlas.oldChart q).open_source.mem_nhds hq)
+  exact hU.mono fun x hx => ((OnePointAtlas.oldChart q).left_inv hx).symm
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold4 SpecialPeriods.instIsManifold5 in
+private def SpecialPeriods.triangleCuspComplement :
+    TopologicalSpace.Opens TriangleCompactifiedOrbitSpace :=
+  ⟨{ triangleCuspPoint }ᶜ, isClosed_singleton.isOpen_compl⟩
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold4 SpecialPeriods.instIsManifold5 in
+private def SpecialPeriods.triangleOpenInclusionToComplement (q : TriangleOrbitSpace) :
+    triangleCuspComplement :=
+  ⟨triangleOpenInclusion q, triangleOpenInclusion_ne_cusp q⟩
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold4 SpecialPeriods.instIsManifold5 in
+private theorem SpecialPeriods.triangleOpenInclusionToComplement_isLocalDiffeomorph :
+    IsLocalDiffeomorph 𝓘(ℂ) 𝓘(ℂ) ω triangleOpenInclusionToComplement :=
+  isLocalDiffeomorph_codRestrictOpens 𝓘(ℂ) 𝓘(ℂ) triangleOpenInclusion_isLocalDiffeomorph
+    triangleCuspComplement triangleOpenInclusion_ne_cusp
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold4 SpecialPeriods.instIsManifold5 in
+private theorem SpecialPeriods.triangleOpenInclusionToComplement_bijective :
+    Function.Bijective triangleOpenInclusionToComplement := by
+  constructor
+  · intro x y h
+    exact OnePoint.coe_injective (congrArg Subtype.val h)
+  · intro x
+    obtain ⟨q, hq⟩ := OnePoint.ne_infty_iff_exists.mp x.property
+    exact ⟨q, Subtype.ext hq⟩
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold4 SpecialPeriods.instIsManifold5 in
+private def SpecialPeriods.triangleOpenComplementBiholomorph :
+    Diffeomorph 𝓘(ℂ) 𝓘(ℂ) TriangleOrbitSpace triangleCuspComplement ω :=
+  triangleOpenInclusionToComplement_isLocalDiffeomorph.diffeomorphOfBijective
+    triangleOpenInclusionToComplement_bijective
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold4 SpecialPeriods.instIsManifold5 in
+@[simp]
+private theorem
+    SpecialPeriods.triangleOpenComplementBiholomorph_symm_apply (q : triangleCuspComplement) :
+    triangleOpenInclusion (triangleOpenComplementBiholomorph.symm q) = q :=
+  congrArg Subtype.val (triangleOpenComplementBiholomorph.apply_symm_apply q)
+
+private def SpecialPeriods.triangleCompactifiedCenterOne : TriangleCompactifiedOrbitSpace :=
+  triangleOpenInclusion triangleOrbitCenterOne
+
+private def SpecialPeriods.triangleCompactifiedCenterTwo : TriangleCompactifiedOrbitSpace :=
+  triangleOpenInclusion triangleOrbitCenterTwo
+
+private theorem SpecialPeriods.triangleCompactifiedCenterOne_ne_centerTwo :
+    triangleCompactifiedCenterOne ≠ triangleCompactifiedCenterTwo := by
+  intro h
+  exact triangleOrbitCenterOne_ne_centerTwo (OnePoint.coe_injective h)
+
+private def SpecialPeriods.Triangle.ellipticCompactifiedCenter (j : Elliptic.Kind) :
+    SpecialPeriods.TriangleCompactifiedOrbitSpace :=
+  SpecialPeriods.triangleOpenInclusion (ellipticOrbitCenter j)
+
+@[simp]
+private theorem SpecialPeriods.Triangle.ellipticCompactifiedCenter_ne_cusp (j : Elliptic.Kind) :
+    ellipticCompactifiedCenter j ≠ SpecialPeriods.triangleCuspPoint :=
+  SpecialPeriods.triangleOpenInclusion_ne_cusp (ellipticOrbitCenter j)
+
+private theorem SpecialPeriods.Triangle.normalizedCayley_analyticAt (a z : ℍ) (r : ℝ) (hr : r ≠ 0) :
+    AnalyticAt ℂ (normalizedCayley a r ∘ UpperHalfPlane.ofComplex) (z : ℂ) :=
+  (cayleyCoordinate_analyticAt a z).div analyticAt_const (Complex.ofReal_ne_zero.mpr hr)
+
+private theorem SpecialPeriods.Triangle.normalizedCayley_order_center (a : ℍ) (r : ℝ) (hr : r ≠ 0) :
+    analyticOrderAt (normalizedCayley a r ∘ UpperHalfPlane.ofComplex) (a : ℂ) = 1 := by
+  have hc : AnalyticAt ℂ (fun _ : ℂ => (r : ℂ)⁻¹) (a : ℂ) := analyticAt_const
+  have hcorder : analyticOrderAt (fun _ : ℂ => (r : ℂ)⁻¹) (a : ℂ) = 0 :=
+    hc.analyticOrderAt_eq_zero.mpr (inv_ne_zero (Complex.ofReal_ne_zero.mpr hr))
+  have he :
+    normalizedCayley a r ∘ UpperHalfPlane.ofComplex =
+      (cayleyCoordinate a ∘ UpperHalfPlane.ofComplex) * (fun _ : ℂ => (r : ℂ)⁻¹) := by
+    funext z
+    exact div_eq_mul_inv _ _
+  rw [he, analyticOrderAt_mul (cayleyCoordinate_analyticAt a a) hc, cayleyCoordinate_order_center,
+    hcorder, add_zero]
+
+private theorem
+    SpecialPeriods.Triangle.normalizedCayleyBranch_analyticAt (a z : ℍ) (r : ℝ) (hr : r ≠ 0)
+    (m : ℕ) : AnalyticAt ℂ (normalizedCayleyBranch a r m ∘ UpperHalfPlane.ofComplex) (z : ℂ) :=
+  (normalizedCayley_analyticAt a z r hr).pow m
+
+private theorem
+    SpecialPeriods.Triangle.normalizedCayleyBranch_order_center (a : ℍ) (r : ℝ) (hr : r ≠ 0)
+    (m : ℕ) :
+    analyticOrderAt (normalizedCayleyBranch a r m ∘ UpperHalfPlane.ofComplex) (a : ℂ) =
+      (m : ℕ∞) := by
+  change analyticOrderAt ((normalizedCayley a r ∘ UpperHalfPlane.ofComplex) ^ m) (a : ℂ) = _
+  rw [analyticOrderAt_pow (normalizedCayley_analyticAt a a r hr),
+    normalizedCayley_order_center a r hr]
+  simp
+
+private theorem
+    SpecialPeriods.Triangle.ellipticFullChart_complexGerm_eventuallyEq (j : Elliptic.Kind) :
+    (ellipticFullChart j ∘
+        SpecialPeriods.triangleOrbitProjection ∘
+          UpperHalfPlane.ofComplex) =ᶠ[𝓝 (ellipticCenter j : ℂ)]
+      (normalizedCayleyBranch (ellipticCenter j) (ellipticNeighborhoodRadius j) j.order ∘
+        UpperHalfPlane.ofComplex) := by
+  have hU : IsOpen (UpperHalfPlane.coe '' (ellipticNeighborhood j : Set ℍ)) :=
+    UpperHalfPlane.isOpenEmbedding_coe.isOpenMap _ (ellipticNeighborhood j).isOpen
+  have hcenter :
+    (ellipticCenter j : ℂ) ∈ UpperHalfPlane.coe '' (ellipticNeighborhood j : Set ℍ) :=
+    ⟨ellipticCenter j, ellipticCenter_mem_neighborhood j, rfl⟩
+  filter_upwards [hU.mem_nhds hcenter] with z hz
+  obtain ⟨w, hw, rfl⟩ := hz
+  simp only [Function.comp_apply, UpperHalfPlane.ofComplex_apply]
+  exact ellipticFullChart_projection j ⟨w, hw⟩
+
+private theorem
+    SpecialPeriods.Triangle.ellipticFullChart_complexGerm_analyticAt (j : Elliptic.Kind) :
+    AnalyticAt ℂ
+      (ellipticFullChart j ∘ SpecialPeriods.triangleOrbitProjection ∘ UpperHalfPlane.ofComplex)
+      (ellipticCenter j : ℂ) :=
+  (normalizedCayleyBranch_analyticAt (ellipticCenter j) (ellipticCenter j)
+        (ellipticNeighborhoodRadius j) (ellipticNeighborhoodRadius_pos j).ne' j.order).congr
+    (ellipticFullChart_complexGerm_eventuallyEq j).symm
+
+private theorem SpecialPeriods.Triangle.ellipticFullChart_order_center (j : Elliptic.Kind) :
+    analyticOrderAt
+        (ellipticFullChart j ∘ SpecialPeriods.triangleOrbitProjection ∘ UpperHalfPlane.ofComplex)
+        (ellipticCenter j : ℂ) =
+      (j.order : ℕ∞) := by
+  rw [analyticOrderAt_congr (ellipticFullChart_complexGerm_eventuallyEq j)]
+  exact
+    normalizedCayleyBranch_order_center (ellipticCenter j) (ellipticNeighborhoodRadius j)
+      (ellipticNeighborhoodRadius_pos j).ne' j.order
+
+private theorem SpecialPeriods.Triangle.sl_analyticAt_smul (g : SL(2, ℝ)) (z : ℍ) :
+    AnalyticAt ℂ (fun w : ℂ => ((g • UpperHalfPlane.ofComplex w : ℍ) : ℂ)) (z : ℂ) := by
+  have h := UpperHalfPlane.analyticAt_smul (g := Matrix.SpecialLinearGroup.mapGL ℝ g) (by simp) z
+  simpa only [MulAction.compHom_smul_def] using h
+
+private theorem
+    SpecialPeriods.Triangle.sl_analyticOrderAt_comp_smul (f : ℍ → ℂ) (g : SL(2, ℝ)) (z : ℍ) :
+    analyticOrderAt (fun w : ℂ => f (g • UpperHalfPlane.ofComplex w)) (z : ℂ) =
+      analyticOrderAt (f ∘ UpperHalfPlane.ofComplex) ((g • z : ℍ) : ℂ) := by
+  let G : ℂ → ℂ := fun w => ((g • UpperHalfPlane.ofComplex w : ℍ) : ℂ)
+  have he :
+    (fun w : ℂ => f (g • UpperHalfPlane.ofComplex w)) = (f ∘ UpperHalfPlane.ofComplex) ∘ G := by
+    funext w
+    simp only [Function.comp_apply, G, UpperHalfPlane.ofComplex_apply]
+  rw [he, analyticOrderAt_comp_of_deriv_ne_zero]
+  · simp only [G, UpperHalfPlane.ofComplex_apply]
+  · exact sl_analyticAt_smul g z
+  · rw [sl_deriv_smul]
+    exact div_ne_zero one_ne_zero (pow_ne_zero 2 (slDenom_ne_zero g z))
+
+private theorem SpecialPeriods.Triangle.triangle_analyticOrderAt_comp_action (f : ℍ → ℂ)
+    (g : SpecialPeriods.TriangleGroup) (z : ℍ) :
+    analyticOrderAt
+        (fun w : ℂ =>
+          f (SpecialPeriods.triangleGeometricRepresentation g (UpperHalfPlane.ofComplex w)))
+        (z : ℂ) =
+      analyticOrderAt (f ∘ UpperHalfPlane.ofComplex)
+        (SpecialPeriods.triangleGeometricRepresentation g z : ℂ) := by
+  have hl (w : ℍ) :
+    (SpecialPeriods.triangleMatrixLift g).val • w =
+      SpecialPeriods.triangleGeometricRepresentation g w :=
+    SpecialPeriods.triangleMatrixLift_smul g w
+  simpa only [hl] using sl_analyticOrderAt_comp_smul f (SpecialPeriods.triangleMatrixLift g).val z
+
+private theorem SpecialPeriods.Triangle.triangle_invariant_analyticOrderAt (f : ℍ → ℂ)
+    (hf :
+      ∀ (g : SpecialPeriods.TriangleGroup) (z : ℍ),
+        f (SpecialPeriods.triangleGeometricRepresentation g z) = f z)
+    (g : SpecialPeriods.TriangleGroup) (z : ℍ) :
+    analyticOrderAt (f ∘ UpperHalfPlane.ofComplex)
+        (SpecialPeriods.triangleGeometricRepresentation g z : ℂ) =
+      analyticOrderAt (f ∘ UpperHalfPlane.ofComplex) (z : ℂ) := by
+  have he :
+    (fun w : ℂ =>
+        f (SpecialPeriods.triangleGeometricRepresentation g (UpperHalfPlane.ofComplex w))) =
+      f ∘ UpperHalfPlane.ofComplex := by
+    funext w
+    exact hf g (UpperHalfPlane.ofComplex w)
+  have h := triangle_analyticOrderAt_comp_action f g z
+  rw [he] at h
+  exact h.symm
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.instIsManifold7 : IsManifold 𝓘(ℂ) ω TriangleOrbitSpace :=
+  triangleOrbit_isManifold
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold7 in
+private theorem SpecialPeriods.triangleCuspComplement_nonempty_for_coordinates_mo1973_16685 :
+    Nonempty triangleCuspComplement :=
+  ⟨triangleOpenInclusionToComplement triangleOrbitCenterOne⟩
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold7 in
+private def SpecialPeriods.triangleOpenInclusionPartial :
+    PartialDiffeomorph 𝓘(ℂ) 𝓘(ℂ) TriangleOrbitSpace TriangleCompactifiedOrbitSpace ω :=
+  triangleOpenComplementBiholomorph.toPartialDiffeomorph.trans
+    (opensInclusionPartialDiffeomorph 𝓘(ℂ) triangleCuspComplement
+      triangleCuspComplement_nonempty_for_coordinates_mo1973_16685)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold7 in
+@[simp]
+private theorem SpecialPeriods.triangleOpenInclusionPartial_source :
+    triangleOpenInclusionPartial.source = Set.univ := by
+  simp [triangleOpenInclusionPartial, PartialDiffeomorph.trans, Diffeomorph.toPartialDiffeomorph,
+    opensInclusionPartialDiffeomorph]
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold7 in
+@[simp]
+private theorem SpecialPeriods.triangleOpenInclusionPartial_target :
+    triangleOpenInclusionPartial.target =
+      (triangleCuspComplement : Set TriangleCompactifiedOrbitSpace) := by
+  simp [triangleOpenInclusionPartial, PartialDiffeomorph.trans, Diffeomorph.toPartialDiffeomorph,
+    opensInclusionPartialDiffeomorph]
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold7 in
+private theorem SpecialPeriods.triangleOpenInclusionPartial_symm_apply (q : TriangleOrbitSpace) :
+    triangleOpenInclusionPartial.symm (triangleOpenInclusion q) = q := by
+  change
+    triangleOpenInclusionPartial.toPartialEquiv.invFun
+        (triangleOpenInclusionPartial.toPartialEquiv.toFun q) =
+      q
+  exact triangleOpenInclusionPartial.toPartialEquiv.left_inv (by simp)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold7 in
+private def SpecialPeriods.Triangle.ellipticCompactifiedPartial (j : Elliptic.Kind) :
+    PartialDiffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace ℂ ω :=
+  SpecialPeriods.triangleOpenInclusionPartial.symm.trans
+    (SpecialPeriods.triangleOrbitCoordinatePartial (.inr j))
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold7 in
+private def SpecialPeriods.Triangle.ellipticCompactifiedChart (j : Elliptic.Kind) :
+    OpenPartialHomeomorph SpecialPeriods.TriangleCompactifiedOrbitSpace ℂ :=
+  (ellipticCompactifiedPartial j).toOpenPartialHomeomorph
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold7 in
+@[simp]
+private theorem SpecialPeriods.Triangle.ellipticCompactifiedChart_openInclusion (j : Elliptic.Kind)
+    (q : SpecialPeriods.TriangleOrbitSpace) :
+    ellipticCompactifiedChart j (SpecialPeriods.triangleOpenInclusion q) =
+      ellipticFullChart j q := by
+  change
+    ellipticFullChart j
+        (SpecialPeriods.triangleOpenInclusionPartial.symm
+          (SpecialPeriods.triangleOpenInclusion q)) =
+      _
+  rw [SpecialPeriods.triangleOpenInclusionPartial_symm_apply]
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold7 in
+@[simp]
+private theorem SpecialPeriods.Triangle.openInclusion_mem_ellipticCompactifiedChart_source
+    (j : Elliptic.Kind) (q : SpecialPeriods.TriangleOrbitSpace) :
+    SpecialPeriods.triangleOpenInclusion q ∈ (ellipticCompactifiedChart j).source ↔
+      q ∈ (ellipticFullChart j).source := by
+  change
+    (SpecialPeriods.triangleOpenInclusion q ∈ SpecialPeriods.triangleOpenInclusionPartial.target ∧
+        SpecialPeriods.triangleOpenInclusionPartial.symm
+            (SpecialPeriods.triangleOpenInclusion q) ∈
+          (ellipticFullChart j).source) ↔
+      _
+  rw [SpecialPeriods.triangleOpenInclusionPartial_target,
+    SpecialPeriods.triangleOpenInclusionPartial_symm_apply]
+  exact and_iff_right (SpecialPeriods.triangleOpenInclusion_ne_cusp q)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold7 in
+@[simp]
+private theorem SpecialPeriods.Triangle.ellipticCompactifiedChart_target (j : Elliptic.Kind) :
+    (ellipticCompactifiedChart j).target = (SpecialPeriods.unitDisc : Set ℂ) := by
+  change
+    (ellipticFullChart j).target ∩
+        (ellipticFullChart j).symm ⁻¹' SpecialPeriods.triangleOpenInclusionPartial.source =
+      _
+  rw [SpecialPeriods.triangleOpenInclusionPartial_source, Set.preimage_univ, Set.inter_univ,
+    ellipticFullChart_target]
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold7 in
+private theorem
+    SpecialPeriods.Triangle.ellipticCompactifiedChart_center_mem_source (j : Elliptic.Kind) :
+    ellipticCompactifiedCenter j ∈ (ellipticCompactifiedChart j).source :=
+  (openInclusion_mem_ellipticCompactifiedChart_source j (ellipticOrbitCenter j)).mpr
+    (ellipticFullChart_center_mem_source j)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold7 in
+@[simp]
+private theorem SpecialPeriods.Triangle.ellipticCompactifiedChart_center (j : Elliptic.Kind) :
+    ellipticCompactifiedChart j (ellipticCompactifiedCenter j) = 0 := by
+  change
+    ellipticCompactifiedChart j (SpecialPeriods.triangleOpenInclusion (ellipticOrbitCenter j)) = 0
+  rw [ellipticCompactifiedChart_openInclusion, ellipticFullChart_center]
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold7 in
+private theorem SpecialPeriods.Triangle.ellipticCompactifiedChart_holomorphic (j : Elliptic.Kind) :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (ellipticCompactifiedChart j) (ellipticCompactifiedChart j).source :=
+  (ellipticCompactifiedPartial j).contMDiffOn
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.instIsManifold7 in
+private theorem
+    SpecialPeriods.Triangle.ellipticCompactifiedChart_symm_holomorphic (j : Elliptic.Kind) :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (ellipticCompactifiedChart j).symm
+      (ellipticCompactifiedChart j).target :=
+  (ellipticCompactifiedPartial j).symm.contMDiffOn
+
+private abbrev RiemannSphere :=
+  OnePoint ℂ
+
+private def RiemannSphere.infinityParametrization (z : ℂ) : RiemannSphere := by
+  classical exact if z = 0 then ((OnePoint.infty) : RiemannSphere) else (z⁻¹ : ℂ)
+
+@[simp]
+private theorem RiemannSphere.infinityParametrization_zero :
+    infinityParametrization 0 = ((OnePoint.infty) : RiemannSphere) := by
+  simp [infinityParametrization]
+
+private theorem RiemannSphere.infinityParametrization_of_ne {z : ℂ} (hz : z ≠ 0) :
+    infinityParametrization z = (z⁻¹ : ℂ) := by simp [infinityParametrization, hz]
+
+private theorem
+    RiemannSphere.infinityParametrization_continuous : Continuous infinityParametrization := by
+  classical
+  rw [continuous_iff_continuousAt]
+  intro z
+  by_cases hz : z = 0
+  · subst z
+    change Filter.Tendsto infinityParametrization (𝓝 (0 : ℂ)) (𝓝 (infinityParametrization 0))
+    rw [infinityParametrization_zero, ← nhdsNE_sup_pure (0 : ℂ), Filter.tendsto_sup]
+    constructor
+    · have hc :
+        Filter.Tendsto ((↑) : ℂ → OnePoint ℂ) (Bornology.cobounded ℂ)
+          (𝓝 ((OnePoint.infty) : RiemannSphere)) := by
+        simpa only [Filter.coclosedCompact_eq_cocompact, Metric.cobounded_eq_cocompact] using
+          (OnePoint.tendsto_coe_infty (X := ℂ))
+      have hi := hc.comp (Filter.tendsto_inv₀_nhdsNE_zero (α := ℂ))
+      apply hi.congr'
+      filter_upwards [self_mem_nhdsWithin] with w hw
+      have hw' : w ≠ 0 := hw
+      simp [infinityParametrization, hw']
+    · simpa only [infinityParametrization_zero] using
+        (tendsto_pure_nhds infinityParametrization (0 : ℂ))
+  · have hc : ContinuousAt (fun w : ℂ => ((w⁻¹ : ℂ) : OnePoint ℂ)) z :=
+      OnePoint.continuous_coe.continuousAt.comp (contDiffAt_inv ℂ hz (n := ω)).continuousAt
+    apply hc.congr_of_eventuallyEq
+    filter_upwards [(isOpen_ne_fun continuous_id continuous_const).mem_nhds hz] with w hw
+    exact infinityParametrization_of_ne hw
+
+private theorem RiemannSphere.infinityParametrization_injective :
+    Function.Injective infinityParametrization := by
+  classical
+  intro z w he
+  by_cases hz : z = 0 <;> by_cases hw : w = 0
+  · exact hz.trans hw.symm
+  · simp [infinityParametrization, hz, hw] at he
+  · simp [infinityParametrization, hz, hw] at he
+  · simpa [infinityParametrization, hz, hw] using he
+
+private def RiemannSphere.standardCharts : TwoAffineCharts RiemannSphere
+    where
+  left := ((↑) : ℂ → OnePoint ℂ)
+  right := infinityParametrization
+  continuous_left := OnePoint.continuous_coe
+  continuous_right := infinityParametrization_continuous
+  left_injective := OnePoint.coe_injective
+  right_injective := infinityParametrization_injective
+  inversion z hz := by simp [infinityParametrization, inv_ne_zero hz]
+  endpoints_ne := by simp [infinityParametrization]
+  covered
+    p := by
+    induction p using OnePoint.rec with
+    | infty => exact Or.inr ⟨0, infinityParametrization_zero⟩
+    | coe z => exact Or.inl ⟨z, rfl⟩
+
+private instance RiemannSphere.chartedSpace : ChartedSpace ℂ RiemannSphere :=
+  standardCharts.chartedSpace
+
+private instance RiemannSphere.isManifold : IsManifold (modelWithCornersSelf ℂ ℂ) ω RiemannSphere :=
+  standardCharts.isManifold
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.MuTorsor.Cover.finiteInverse
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (z : ℂ) : SpecialPeriods.TriangleCompactifiedOrbitSpace :=
+  π.symm (z : RiemannSphere)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.MuTorsor.Cover.apply_finiteInverse
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (z : ℂ) : π (finiteInverse π z) = (z : RiemannSphere) :=
+  π.apply_symm_apply _
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.Cover.finiteInverse_continuous
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω) :
+    Continuous (finiteInverse π) :=
+  π.symm.continuous.comp OnePoint.continuous_coe
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.Cover.finiteInverse_holomorphic
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (finiteInverse π) := by
+  have hc : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z : ℂ => (z : RiemannSphere)) :=
+    RiemannSphere.standardCharts.affineMap_holomorphic Bool.false
+  exact π.symm.contMDiff.comp hc
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.MuTorsor.Cover.finitePullback
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (V : TopologicalSpace.Opens SpecialPeriods.TriangleCompactifiedOrbitSpace) :
+    TopologicalSpace.Opens ℂ :=
+  ⟨finiteInverse π ⁻¹' (V : Set SpecialPeriods.TriangleCompactifiedOrbitSpace),
+    V.isOpen.preimage (finiteInverse_continuous π)⟩
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.MuTorsor.Cover.mem_finitePullback
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (V : TopologicalSpace.Opens SpecialPeriods.TriangleCompactifiedOrbitSpace) (z : ℂ) :
+    z ∈ finitePullback π V ↔ finiteInverse π z ∈ V :=
+  Iff.rfl
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.Cover.symm_infty
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    π.symm ((OnePoint.infty) : RiemannSphere) = SpecialPeriods.triangleCuspPoint := by
+  exact π.injective ((π.apply_symm_apply _).trans hπ.symm)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.Cover.finiteInverse_ne_cusp
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) (z : ℂ) :
+    finiteInverse π z ≠ SpecialPeriods.triangleCuspPoint := by
+  intro h
+  exact OnePoint.coe_ne_infty z ((apply_finiteInverse π z).symm.trans ((congrArg π h).trans hπ))
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.Cover.finiteInverse_tendsto_cusp
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    Filter.Tendsto (finiteInverse π) (Bornology.cobounded ℂ)
+      (𝓝 SpecialPeriods.triangleCuspPoint) := by
+  have hc :
+    Filter.Tendsto (fun z : ℂ => (z : RiemannSphere)) (Bornology.cobounded ℂ)
+      (𝓝 ((OnePoint.infty) : RiemannSphere)) := by
+    simpa only [Filter.coclosedCompact_eq_cocompact, Metric.cobounded_eq_cocompact] using
+      (OnePoint.tendsto_coe_infty (X := ℂ))
+  have h := π.symm.continuous.continuousAt.tendsto.comp hc
+  change
+    Filter.Tendsto (finiteInverse π) (Bornology.cobounded ℂ)
+      (𝓝 (π.symm ((OnePoint.infty) : RiemannSphere))) at h
+  simpa only [symm_infty π hπ] using h
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.Cover.finitePullback_contains_exterior
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (V : TopologicalSpace.Opens SpecialPeriods.TriangleCompactifiedOrbitSpace)
+    (hV : SpecialPeriods.triangleCuspPoint ∈ V) :
+    ∃ R : ℝ, 0 < R ∧ (Metric.ball (0 : ℂ) R)ᶜ ⊆ finitePullback π V := by
+  have hmem : (finitePullback π V : Set ℂ) ∈ Bornology.cobounded ℂ :=
+    (finiteInverse_tendsto_cusp π hπ) (V.isOpen.mem_nhds hV)
+  obtain ⟨r, _, hr⟩ := (Metric.hasBasis_cobounded_compl_ball (0 : ℂ)).mem_iff.mp hmem
+  refine ⟨Max.max r 1, lt_of_lt_of_le zero_lt_one (le_max_right _ _), ?_⟩
+  exact (Set.compl_subset_compl.mpr (Metric.ball_subset_ball (le_max_left r 1))).trans hr
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def
+    SpecialPeriods.MuTorsor.CuspCoordinates.sphereReciprocalCoordinate : RiemannSphere → ℂ :=
+  (RiemannSphere.standardCharts.parametrization Bool.true).symm
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.CuspCoordinates.sphereReciprocalCoordinate_mem_source
+    {p : RiemannSphere} (hp : p ≠ ((0 : ℂ) : RiemannSphere)) :
+    p ∈ (RiemannSphere.standardCharts.parametrization Bool.true).target := by
+  rw [TwoAffineCharts.parametrization_target]
+  change p ∈ Set.range RiemannSphere.standardCharts.right
+  rw [RiemannSphere.standardCharts.range_right]
+  exact hp
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.MuTorsor.CuspCoordinates.sphereReciprocalCoordinate_infty :
+    sphereReciprocalCoordinate ((OnePoint.infty) : RiemannSphere) = 0 := by
+  have h := RiemannSphere.standardCharts.parametrization_symm_apply Bool.true (0 : ℂ)
+  change sphereReciprocalCoordinate (RiemannSphere.infinityParametrization 0) = 0 at h
+  simpa only [RiemannSphere.infinityParametrization_zero] using h
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.CuspCoordinates.sphereReciprocalCoordinate_coe {z : ℂ}
+    (hz : z ≠ 0) : sphereReciprocalCoordinate (z : RiemannSphere) = z⁻¹ := by
+  have he : RiemannSphere.infinityParametrization z⁻¹ = (z : RiemannSphere) := by
+    rw [RiemannSphere.infinityParametrization_of_ne (inv_ne_zero hz), inv_inv]
+  have h := RiemannSphere.standardCharts.parametrization_symm_apply Bool.true z⁻¹
+  change sphereReciprocalCoordinate (RiemannSphere.infinityParametrization z⁻¹) = z⁻¹ at h
+  simpa only [he] using h
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.CuspCoordinates.sphereReciprocalCoordinate_holomorphicAt
+    {p : RiemannSphere} (hp : p ≠ ((0 : ℂ) : RiemannSphere)) :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω sphereReciprocalCoordinate p := by
+  apply
+    contMDiffAt_of_mem_maximalAtlas
+      (IsManifold.subset_maximalAtlas (Set.mem_range_self Bool.true))
+  exact sphereReciprocalCoordinate_mem_source hp
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.MuTorsor.CuspCoordinates.t
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (q : ℂ) : ℂ :=
+  sphereReciprocalCoordinate
+    (π ((SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).symm q))
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.MuTorsor.CuspCoordinates.tDivQ
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω) :
+    ℂ → ℂ :=
+  dslope (t π) 0
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.MuTorsor.CuspCoordinates.t_zero
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) : t π 0 = 0 := by
+  rw [t, SpecialPeriods.Triangle.cuspFullChart_symm_zero, hπ, sphereReciprocalCoordinate_infty]
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.CuspCoordinates.t_holomorphicAt_zero
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (t π) 0 := by
+  have hC :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω
+      (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).symm (0 : ℂ) :=
+    SpecialPeriods.triangleCompactified_cuspChart_symm_holomorphic.contMDiffAt
+      (Metric.isOpen_ball.mem_nhds
+        (Metric.mem_ball_self
+          (SpecialPeriods.Triangle.cuspRadius_pos SpecialPeriods.Triangle.width)))
+  have hR :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω sphereReciprocalCoordinate
+      (π ((SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).symm 0)) :=
+    by
+    rw [SpecialPeriods.Triangle.cuspFullChart_symm_zero, hπ]
+    exact sphereReciprocalCoordinate_holomorphicAt (OnePoint.infty_ne_coe (0 : ℂ))
+  exact hR.comp 0 (π.contMDiffAt.comp 0 hC)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.CuspCoordinates.t_analyticAt_zero
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    AnalyticAt ℂ (t π) 0 :=
+  (t_holomorphicAt_zero π hπ).contDiffAt.analyticAt
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.CuspCoordinates.tDivQ_analyticAt_zero
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    AnalyticAt ℂ (tDivQ π) 0 :=
+  (t_analyticAt_zero π hπ).hasFPowerSeriesAt.has_fpower_series_dslope_fslope.analyticAt
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.CuspCoordinates.t_eq_mul_tDivQ
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) (q : ℂ) :
+    t π q = q * tDivQ π q := by
+  simpa only [tDivQ, sub_zero, t_zero π hπ, smul_eq_mul] using (sub_smul_dslope (t π) 0 q).symm
+
+private theorem SpecialPeriods.MuTorsor.SourceOrders.deriv_ne_zero_of_isLocalDiffeomorph {f : ℂ → ℂ}
+    {z : ℂ} (hf : IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω f z) : deriv f z ≠ 0 := by
+  let e : ℂ ≃L[ℂ] ℂ := hf.mfderivToContinuousLinearEquiv (by simp)
+  have he : e 1 = deriv f z := by
+    change (show ℂ →L[ℂ] ℂ from mfderiv 𝓘(ℂ) 𝓘(ℂ) f z) 1 = deriv f z
+    rw [mfderiv_eq_fderiv]
+    rfl
+  intro h
+  have h10 : e 1 = e 0 := by rw [he, h, map_zero]
+  exact one_ne_zero (e.injective h10)
+
+private theorem SpecialPeriods.MuTorsor.SourceOrders.centered_order_eq_one_of_isLocalDiffeomorph
+    {f : ℂ → ℂ} {z : ℂ} (hf : IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω f z) :
+    analyticOrderAt (fun w => f w - f z) z = 1 :=
+  hf.contMDiffAt.contDiffAt.analyticAt.analyticOrderAt_sub_eq_one_of_deriv_ne_zero
+    (deriv_ne_zero_of_isLocalDiffeomorph hf)
+
+private theorem SpecialPeriods.MuTorsor.SourceOrders.order_eq_one_of_isLocalDiffeomorph {f : ℂ → ℂ}
+    {z : ℂ} (hf : IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω f z) (hz : f z = 0) :
+    analyticOrderAt f z = 1 := by
+  simpa only [hz, sub_zero] using centered_order_eq_one_of_isLocalDiffeomorph hf
+
+private theorem SpecialPeriods.MuTorsor.SourceOrders.centered_order_comp {F f : ℂ → ℂ} {a : ℂ}
+    (hF : AnalyticAt ℂ F a) (hf : IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω f (F a)) :
+    analyticOrderAt (fun w => f (F w) - f (F a)) a = analyticOrderAt (fun w => F w - F a) a := by
+  have houter : AnalyticAt ℂ (fun w => f w - f (F a)) (F a) :=
+    hf.contMDiffAt.contDiffAt.analyticAt.sub analyticAt_const
+  simpa only [Function.comp_def, centered_order_eq_one_of_isLocalDiffeomorph hf, one_mul] using
+    houter.analyticOrderAt_comp hF
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.TriangleSource.cuspPartialDiffeomorph :
+    PartialDiffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace ℂ ω
+    where
+  toPartialEquiv :=
+    (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).toPartialEquiv
+  open_source :=
+    (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).open_source
+  open_target :=
+    (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).open_target
+  contMDiffOn_toFun := SpecialPeriods.triangleCompactified_cuspChart_holomorphic
+  contMDiffOn_invFun := SpecialPeriods.triangleCompactified_cuspChart_symm_holomorphic
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.TriangleSource.sphereReciprocalPartialDiffeomorph :
+    PartialDiffeomorph 𝓘(ℂ) 𝓘(ℂ) RiemannSphere ℂ ω
+    where
+  toPartialEquiv := (RiemannSphere.standardCharts.parametrization Bool.true).symm.toPartialEquiv
+  open_source := (RiemannSphere.standardCharts.parametrization Bool.true).open_target
+  open_target := (RiemannSphere.standardCharts.parametrization Bool.true).open_source
+  contMDiffOn_toFun :=
+    contMDiffOn_of_mem_maximalAtlas
+      (IsManifold.subset_maximalAtlas (Set.mem_range_self Bool.true))
+  contMDiffOn_invFun :=
+    contMDiffOn_symm_of_mem_maximalAtlas
+      (IsManifold.subset_maximalAtlas (Set.mem_range_self Bool.true))
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.TriangleSource.meromorphicCuspJ
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (q : ℂ) : ℂ :=
+  1728 / SpecialPeriods.MuTorsor.CuspCoordinates.t π q
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.TriangleSource.reciprocalCusp_isLocalDiffeomorphAt
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω (SpecialPeriods.MuTorsor.CuspCoordinates.t π) 0 := by
+  have hc :
+    IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω
+      (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).symm 0 :=
+    cuspPartialDiffeomorph.symm.isLocalDiffeomorphAt _ _ _
+      (Metric.mem_ball_self
+        (SpecialPeriods.Triangle.cuspRadius_pos SpecialPeriods.Triangle.width))
+  have hr :
+    IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω
+      SpecialPeriods.MuTorsor.CuspCoordinates.sphereReciprocalCoordinate
+      (π ((SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).symm 0)) :=
+    by
+    rw [SpecialPeriods.Triangle.cuspFullChart_symm_zero, hπ]
+    exact
+      sphereReciprocalPartialDiffeomorph.isLocalDiffeomorphAt _ _ _
+        (SpecialPeriods.MuTorsor.CuspCoordinates.sphereReciprocalCoordinate_mem_source
+          (OnePoint.infty_ne_coe (0 : ℂ)))
+  have hp :=
+    hc.comp (K := 𝓘(ℂ)) (P := RiemannSphere)
+      (π.isLocalDiffeomorph
+        ((SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).symm 0))
+  exact hp.comp (K := 𝓘(ℂ)) (P := ℂ) hr
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.TriangleSource.reciprocalCusp_deriv_ne_zero
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    deriv (SpecialPeriods.MuTorsor.CuspCoordinates.t π) 0 ≠ 0 :=
+  SpecialPeriods.MuTorsor.SourceOrders.deriv_ne_zero_of_isLocalDiffeomorph
+    (reciprocalCusp_isLocalDiffeomorphAt π hπ)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.TriangleSource.reciprocalCusp_analyticOrder
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    analyticOrderAt (SpecialPeriods.MuTorsor.CuspCoordinates.t π) 0 = 1 :=
+  SpecialPeriods.MuTorsor.SourceOrders.order_eq_one_of_isLocalDiffeomorph
+    (reciprocalCusp_isLocalDiffeomorphAt π hπ)
+    (SpecialPeriods.MuTorsor.CuspCoordinates.t_zero π hπ)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.TriangleSource.meromorphicCuspJ_meromorphicAt
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    MeromorphicAt (meromorphicCuspJ π) 0 :=
+  analyticAt_const.meromorphicAt.div
+    (SpecialPeriods.MuTorsor.CuspCoordinates.t_analyticAt_zero π hπ).meromorphicAt
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.TriangleSource.meromorphicCuspJ_order
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    meromorphicOrderAt (meromorphicCuspJ π) 0 = (-1 : ℤ) := by
+  change
+    meromorphicOrderAt ((fun _ : ℂ => (1728 : ℂ)) / SpecialPeriods.MuTorsor.CuspCoordinates.t π)
+        0 =
+      _
+  rw [meromorphicOrderAt_div analyticAt_const.meromorphicAt
+      (SpecialPeriods.MuTorsor.CuspCoordinates.t_analyticAt_zero π hπ).meromorphicAt,
+    (SpecialPeriods.MuTorsor.CuspCoordinates.t_analyticAt_zero π hπ).meromorphicOrderAt_eq,
+    reciprocalCusp_analyticOrder π hπ]
+  norm_num [meromorphicOrderAt_const]
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.BetaTorsor.sphereFiniteCoordinate : RiemannSphere → ℂ :=
+  (RiemannSphere.standardCharts.parametrization Bool.false).symm
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.BetaTorsor.sphereFiniteCoordinate_coe (z : ℂ) :
+    sphereFiniteCoordinate (z : RiemannSphere) = z :=
+  RiemannSphere.standardCharts.parametrization_symm_apply Bool.false z
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.sphereFiniteCoordinate_mem_source {q : RiemannSphere}
+    (hq : q ≠ ((OnePoint.infty) : RiemannSphere)) :
+    q ∈ (RiemannSphere.standardCharts.parametrization Bool.false).target := by
+  obtain ⟨z, rfl⟩ := OnePoint.ne_infty_iff_exists.mp hq
+  exact ⟨z, Set.mem_univ z, rfl⟩
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.sphereFiniteCoordinate_coe_apply {q : RiemannSphere}
+    (hq : q ≠ ((OnePoint.infty) : RiemannSphere)) :
+    (sphereFiniteCoordinate q : RiemannSphere) = q :=
+  (RiemannSphere.standardCharts.parametrization Bool.false).right_inv
+    (sphereFiniteCoordinate_mem_source hq)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.sphereFiniteCoordinate_holomorphicAt {q : RiemannSphere}
+    (hq : q ≠ ((OnePoint.infty) : RiemannSphere)) :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω sphereFiniteCoordinate q := by
+  apply
+    contMDiffAt_of_mem_maximalAtlas
+      (IsManifold.subset_maximalAtlas (Set.mem_range_self Bool.false))
+  exact sphereFiniteCoordinate_mem_source hq
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.BetaTorsor.finiteOrbitCoordinate
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (q : SpecialPeriods.TriangleOrbitSpace) : ℂ :=
+  sphereFiniteCoordinate (π (SpecialPeriods.triangleOpenInclusion q))
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.BetaTorsor.finiteProjection
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (z : ℍ) : ℂ :=
+  finiteOrbitCoordinate π (SpecialPeriods.triangleOrbitProjection z)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.finiteOrbitCoordinate_target_ne_infty
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (q : SpecialPeriods.TriangleOrbitSpace) :
+    π (SpecialPeriods.triangleOpenInclusion q) ≠ ((OnePoint.infty) : RiemannSphere) := by
+  intro h
+  exact SpecialPeriods.triangleOpenInclusion_ne_cusp q (π.injective (h.trans hπ.symm))
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.finiteOrbitCoordinate_coe
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (q : SpecialPeriods.TriangleOrbitSpace) :
+    (finiteOrbitCoordinate π q : RiemannSphere) = π (SpecialPeriods.triangleOpenInclusion q) :=
+  sphereFiniteCoordinate_coe_apply (finiteOrbitCoordinate_target_ne_infty π hπ q)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.finiteOrbitCoordinate_holomorphic
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (finiteOrbitCoordinate π) := by
+  intro q
+  exact
+    (sphereFiniteCoordinate_holomorphicAt (finiteOrbitCoordinate_target_ne_infty π hπ q)).comp q
+      ((π.contMDiff.comp SpecialPeriods.triangleOpenInclusion_holomorphic) q)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.finiteOrbitCoordinate_injective
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    Function.Injective (finiteOrbitCoordinate π) := by
+  intro q r h
+  apply OnePoint.coe_injective
+  apply π.injective
+  exact
+    (finiteOrbitCoordinate_coe π hπ q).symm.trans
+      ((congrArg (fun z : ℂ => (z : RiemannSphere)) h).trans (finiteOrbitCoordinate_coe π hπ r))
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.BetaTorsor.finiteOrbitInverse
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) (z : ℂ) :
+    SpecialPeriods.TriangleOrbitSpace :=
+  SpecialPeriods.triangleOpenComplementBiholomorph.symm
+    ⟨SpecialPeriods.MuTorsor.Cover.finiteInverse π z,
+      SpecialPeriods.MuTorsor.Cover.finiteInverse_ne_cusp π hπ z⟩
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.openInclusion_finiteOrbitInverse
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) (z : ℂ) :
+    SpecialPeriods.triangleOpenInclusion (finiteOrbitInverse π hπ z) =
+      SpecialPeriods.MuTorsor.Cover.finiteInverse π z :=
+  SpecialPeriods.triangleOpenComplementBiholomorph_symm_apply _
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.finiteOrbitInverse_holomorphic
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (finiteOrbitInverse π hπ) := by
+  have hcod :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω
+      (fun z : ℂ =>
+        (⟨SpecialPeriods.MuTorsor.Cover.finiteInverse π z,
+            SpecialPeriods.MuTorsor.Cover.finiteInverse_ne_cusp π hπ z⟩ :
+          SpecialPeriods.triangleCuspComplement)) := by
+    intro z
+    exact
+      (ChartedSpace.liftPropWithinAt_subtypeVal_comp_iff ..).mp
+        (SpecialPeriods.MuTorsor.Cover.finiteInverse_holomorphic π z)
+  exact SpecialPeriods.triangleOpenComplementBiholomorph.symm.contMDiff.comp hcod
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.BetaTorsor.finiteOrbitCoordinate_inverse
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) (z : ℂ) :
+    finiteOrbitCoordinate π (finiteOrbitInverse π hπ z) = z := by
+  apply OnePoint.coe_injective
+  rw [finiteOrbitCoordinate_coe π hπ, openInclusion_finiteOrbitInverse,
+    SpecialPeriods.MuTorsor.Cover.apply_finiteInverse]
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.BetaTorsor.finiteOrbitInverse_coordinate
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (q : SpecialPeriods.TriangleOrbitSpace) :
+    finiteOrbitInverse π hπ (finiteOrbitCoordinate π q) = q :=
+  finiteOrbitCoordinate_injective π hπ (finiteOrbitCoordinate_inverse π hπ _)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.BetaTorsor.finiteOrbitBiholomorph
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleOrbitSpace ℂ ω
+    where
+  toEquiv :=
+    { toFun := finiteOrbitCoordinate π
+      invFun := finiteOrbitInverse π hπ
+      left_inv := finiteOrbitInverse_coordinate π hπ
+      right_inv := finiteOrbitCoordinate_inverse π hπ }
+  contMDiff_toFun := finiteOrbitCoordinate_holomorphic π hπ
+  contMDiff_invFun := finiteOrbitInverse_holomorphic π hπ
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.finiteProjection_holomorphic
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (finiteProjection π) :=
+  (finiteOrbitCoordinate_holomorphic π hπ).comp SpecialPeriods.triangleOrbitProjection_holomorphic
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.finiteProjection_surjective
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    Function.Surjective (finiteProjection π) := by
+  intro z
+  obtain ⟨a, ha⟩ := SpecialPeriods.triangleOrbitProjection_surjective (finiteOrbitInverse π hπ z)
+  exact ⟨a, by simp only [finiteProjection, ha, finiteOrbitCoordinate_inverse]⟩
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.finiteProjection_invariant
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (g : SpecialPeriods.TriangleGroup) (z : ℍ) :
+    finiteProjection π (SpecialPeriods.triangleGeometricRepresentation g z) =
+      finiteProjection π z := by
+  simp only [finiteProjection, SpecialPeriods.triangleOrbitProjection_smul]
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.finiteInverse_finiteProjection
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) (z : ℍ) :
+    SpecialPeriods.MuTorsor.Cover.finiteInverse π (finiteProjection π z) =
+      SpecialPeriods.triangleCompactifiedProjection z := by
+  apply π.injective
+  change
+    π (SpecialPeriods.MuTorsor.Cover.finiteInverse π (finiteProjection π z)) =
+      π (SpecialPeriods.triangleCompactifiedProjection z)
+  rw [SpecialPeriods.MuTorsor.Cover.apply_finiteInverse]
+  exact finiteOrbitCoordinate_coe π hπ (SpecialPeriods.triangleOrbitProjection z)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.finiteProjection_mem_pullback
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (V : TopologicalSpace.Opens SpecialPeriods.TriangleCompactifiedOrbitSpace) (z : ℍ) :
+    finiteProjection π z ∈ SpecialPeriods.MuTorsor.Cover.finitePullback π V ↔
+      SpecialPeriods.triangleCompactifiedProjection z ∈ V := by
+  rw [SpecialPeriods.MuTorsor.Cover.mem_finitePullback, finiteInverse_finiteProjection π hπ]
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.analyticOnNhd_finite_pullback
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (U : TopologicalSpace.Opens SpecialPeriods.TriangleOrbitSpace)
+    {f : SpecialPeriods.TriangleOrbitSpace → ℂ} (hf : ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω f U) :
+    AnalyticOnNhd ℂ (f ∘ finiteOrbitInverse π hπ)
+      (finiteOrbitInverse π hπ ⁻¹' (U : Set SpecialPeriods.TriangleOrbitSpace)) := by
+  intro z hz
+  have hh := hf.contMDiffAt (U.isOpen.mem_nhds hz)
+  exact (hh.comp z (finiteOrbitInverse_holomorphic π hπ z)).contDiffAt.analyticAt
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.CuspCoordinates.eventually_mem_horodisc (Y : ℝ) :
+    ∀ᶠ z in UpperHalfPlane.atImInfty, z ∈ SpecialPeriods.Triangle.horodisc Y := by
+  apply (UpperHalfPlane.atImInfty_mem _).mpr
+  exact ⟨Y + 1, fun _ hz => lt_of_lt_of_le (lt_add_one Y) hz⟩
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.CuspCoordinates.compactifiedProjection_tendsto_cusp :
+    Filter.Tendsto SpecialPeriods.triangleCompactifiedProjection UpperHalfPlane.atImInfty
+      (𝓝 SpecialPeriods.triangleCuspPoint) := by
+  rw [SpecialPeriods.Triangle.cuspNeighborhood_basis.tendsto_right_iff]
+  intro Y _
+  filter_upwards [eventually_mem_horodisc Y] with z hz
+  change
+    SpecialPeriods.triangleOpenInclusion (SpecialPeriods.triangleOrbitProjection z) ∈
+      SpecialPeriods.Triangle.cuspNeighborhood Y
+  apply (SpecialPeriods.Triangle.openInclusion_mem_cuspNeighborhood Y _).mpr
+  exact ⟨z, hz, rfl⟩
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.CuspCoordinates.sphereProjection_tendsto_infty
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    Filter.Tendsto (π ∘ SpecialPeriods.triangleCompactifiedProjection) UpperHalfPlane.atImInfty
+      (𝓝 ((OnePoint.infty) : RiemannSphere)) := by
+  have h := π.continuous.continuousAt.tendsto.comp compactifiedProjection_tendsto_cusp
+  simpa only [hπ] using h
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.MuTorsor.CuspCoordinates.finiteProjection_coe
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) (z : ℍ) :
+    (SpecialPeriods.BetaTorsor.finiteProjection π z : RiemannSphere) =
+      π (SpecialPeriods.triangleCompactifiedProjection z) :=
+  SpecialPeriods.BetaTorsor.finiteOrbitCoordinate_coe π hπ
+    (SpecialPeriods.triangleOrbitProjection z)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.CuspCoordinates.finiteProjection_tendsto_cobounded
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    Filter.Tendsto (SpecialPeriods.BetaTorsor.finiteProjection π) UpperHalfPlane.atImInfty
+      (Bornology.cobounded ℂ) := by
+  have hc :
+    Filter.comap (fun z : ℂ => (z : RiemannSphere)) (𝓝 ((OnePoint.infty) : RiemannSphere)) =
+      Bornology.cobounded ℂ := by
+    simpa only [Filter.coclosedCompact_eq_cocompact, Metric.cobounded_eq_cocompact] using
+      (OnePoint.comap_coe_nhds_infty (X := ℂ))
+  rw [← hc, Filter.tendsto_comap_iff]
+  simpa only [Function.comp_def, finiteProjection_coe π hπ] using
+    sphereProjection_tendsto_infty π hπ
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.CuspCoordinates.finiteProjection_norm_tendsto_atTop
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    Filter.Tendsto (fun z : ℍ => ‖SpecialPeriods.BetaTorsor.finiteProjection π z‖)
+      UpperHalfPlane.atImInfty Filter.atTop :=
+  tendsto_norm_cobounded_atTop.comp (finiteProjection_tendsto_cobounded π hπ)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.CuspCoordinates.eventually_lt_norm_finiteProjection
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) (R : ℝ) :
+    ∀ᶠ z in UpperHalfPlane.atImInfty, R < ‖SpecialPeriods.BetaTorsor.finiteProjection π z‖ :=
+  (finiteProjection_norm_tendsto_atTop π hπ).eventually_gt_atTop R
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.CuspCoordinates.finiteProjection_eventually_ne_zero
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    ∀ᶠ z in UpperHalfPlane.atImInfty, SpecialPeriods.BetaTorsor.finiteProjection π z ≠ 0 := by
+  filter_upwards [eventually_lt_norm_finiteProjection π hπ 0] with z hz
+  exact norm_pos_iff.mp hz
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.CuspCoordinates.finiteProjection_inv_tendsto_zero
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    Filter.Tendsto (fun z : ℍ => (SpecialPeriods.BetaTorsor.finiteProjection π z)⁻¹)
+      UpperHalfPlane.atImInfty (𝓝[≠] (0 : ℂ)) :=
+  Filter.tendsto_inv₀_cobounded'.comp (finiteProjection_tendsto_cobounded π hπ)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.CuspCoordinates.cuspChart_symm_cuspQ_of_mem (z : ℍ)
+    (hz : z ∈ SpecialPeriods.Triangle.horodisc SpecialPeriods.Triangle.width) :
+    (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).symm
+        (SpecialPeriods.Triangle.cuspQ z) =
+      SpecialPeriods.triangleCompactifiedProjection z := by
+  have hs :
+    SpecialPeriods.triangleCompactifiedProjection z ∈
+      (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).source := by
+    rw [SpecialPeriods.Triangle.cuspFullChart_source]
+    exact
+      (SpecialPeriods.Triangle.openInclusion_mem_cuspNeighborhood SpecialPeriods.Triangle.width
+            _).mpr
+        ⟨z, hz, rfl⟩
+  have he := SpecialPeriods.Triangle.cuspFullChart_mk SpecialPeriods.Triangle.width le_rfl ⟨z, hz⟩
+  exact
+    (congrArg (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).symm
+          he).symm.trans
+      ((SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl).left_inv hs)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.CuspCoordinates.t_cuspQ_eq_inv_finiteProjection_of_mem
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) (z : ℍ)
+    (hz : z ∈ SpecialPeriods.Triangle.horodisc SpecialPeriods.Triangle.width)
+    (hp : SpecialPeriods.BetaTorsor.finiteProjection π z ≠ 0) :
+    t π (SpecialPeriods.Triangle.cuspQ z) = (SpecialPeriods.BetaTorsor.finiteProjection π z)⁻¹ := by
+  rw [t, cuspChart_symm_cuspQ_of_mem z hz, ← finiteProjection_coe π hπ z]
+  exact sphereReciprocalCoordinate_coe hp
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.CuspCoordinates.t_cuspQ_eq_inv_finiteProjection
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    ∀ᶠ z in UpperHalfPlane.atImInfty,
+      t π (SpecialPeriods.Triangle.cuspQ z) =
+        (SpecialPeriods.BetaTorsor.finiteProjection π z)⁻¹ := by
+  filter_upwards [eventually_mem_horodisc SpecialPeriods.Triangle.width,
+    finiteProjection_eventually_ne_zero π hπ] with z hz hp
+  exact t_cuspQ_eq_inv_finiteProjection_of_mem π hπ z hz hp
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.CuspCoordinates.analyticAt_correction
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) {v S : ℂ → ℂ}
+    (hv : AnalyticAt ℂ v 0) (hS : AnalyticAt ℂ S 0) :
+    AnalyticAt ℂ (fun q => -v q * tDivQ π q * S (t π q)) 0 := by
+  have hS' : AnalyticAt ℂ S (t π 0) := by simpa only [t_zero π hπ] using hS
+  exact (hv.neg.mul (tDivQ_analyticAt_zero π hπ)).mul (hS'.comp (t_analyticAt_zero π hπ))
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.TriangleSource.exists_cusp_formula_radius
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    ∃ r₀ : ℝ,
+      0 < r₀ ∧
+        ∀ z : ℍ,
+          ‖Function.Periodic.qParam SpecialPeriods.Triangle.width (z : ℂ)‖ < r₀ →
+            1728 * SpecialPeriods.BetaTorsor.finiteProjection π z =
+              1728 /
+                SpecialPeriods.MuTorsor.CuspCoordinates.t π
+                  (Function.Periodic.qParam SpecialPeriods.Triangle.width (z : ℂ)) := by
+  obtain ⟨Y, hY⟩ :=
+    (UpperHalfPlane.atImInfty_mem _).mp
+      (SpecialPeriods.MuTorsor.CuspCoordinates.t_cuspQ_eq_inv_finiteProjection π hπ)
+  refine ⟨SpecialPeriods.Triangle.cuspRadius Y, SpecialPeriods.Triangle.cuspRadius_pos Y, ?_⟩
+  intro z hz
+  have hheight : Y < z.im := (SpecialPeriods.Triangle.cuspQ_norm_lt_exp_iff Y z).mp hz
+  have he := hY z hheight.le
+  change
+    SpecialPeriods.MuTorsor.CuspCoordinates.t π
+        (Function.Periodic.qParam SpecialPeriods.Triangle.width (z : ℂ)) =
+      (SpecialPeriods.BetaTorsor.finiteProjection π z)⁻¹ at he
+  rw [he, div_inv_eq_mul]
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.MuTorsor.SourceOrders.chartToFinite
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (j : Elliptic.Kind) : ℂ → ℂ :=
+  SpecialPeriods.BetaTorsor.finiteOrbitCoordinate π ∘
+    (SpecialPeriods.Triangle.ellipticFullChart j).symm
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.MuTorsor.SourceOrders.ellipticFullChart_symm_zero (j : Elliptic.Kind) :
+    (SpecialPeriods.Triangle.ellipticFullChart j).symm 0 =
+      SpecialPeriods.Triangle.ellipticOrbitCenter j := by
+  simpa only [SpecialPeriods.Triangle.ellipticFullChart_center] using
+    (SpecialPeriods.Triangle.ellipticFullChart j).left_inv
+      (SpecialPeriods.Triangle.ellipticFullChart_center_mem_source j)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.MuTorsor.SourceOrders.chartToFinite_zero
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (j : Elliptic.Kind) :
+    chartToFinite π j 0 =
+      SpecialPeriods.BetaTorsor.finiteProjection π (SpecialPeriods.Triangle.ellipticCenter j) := by
+  rw [chartToFinite, Function.comp_apply, ellipticFullChart_symm_zero]
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.MuTorsor.SourceOrders.finiteProjection_germ_eventuallyEq_chartToFinite
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (j : Elliptic.Kind) (z : ℍ)
+    (hz :
+      SpecialPeriods.triangleOrbitProjection z ∈
+        (SpecialPeriods.Triangle.ellipticFullChart j).source) :
+    (SpecialPeriods.BetaTorsor.finiteProjection π ∘ UpperHalfPlane.ofComplex) =ᶠ[𝓝 (z : ℂ)]
+      chartToFinite π j ∘
+        (SpecialPeriods.Triangle.ellipticFullChart j ∘
+          SpecialPeriods.triangleOrbitProjection ∘ UpperHalfPlane.ofComplex) := by
+  have hc :
+    ContinuousAt (SpecialPeriods.triangleOrbitProjection ∘ UpperHalfPlane.ofComplex) (z : ℂ) :=
+    SpecialPeriods.triangleOrbitProjection_continuous.continuousAt.comp
+      (UpperHalfPlane.contMDiffAt_ofComplex (n := ω) z.im_pos).continuousAt
+  have hz' :
+    (SpecialPeriods.triangleOrbitProjection ∘ UpperHalfPlane.ofComplex) (z : ℂ) ∈
+      (SpecialPeriods.Triangle.ellipticFullChart j).source := by
+    simpa only [Function.comp_apply, UpperHalfPlane.ofComplex_apply] using hz
+  have hU :
+    ∀ᶠ w in 𝓝 (z : ℂ),
+      SpecialPeriods.triangleOrbitProjection (UpperHalfPlane.ofComplex w) ∈
+        (SpecialPeriods.Triangle.ellipticFullChart j).source :=
+    hc ((SpecialPeriods.Triangle.ellipticFullChart j).open_source.mem_nhds hz')
+  filter_upwards [hU] with w hw
+  exact
+    congrArg (SpecialPeriods.BetaTorsor.finiteOrbitCoordinate π)
+      ((SpecialPeriods.Triangle.ellipticFullChart j).left_inv hw).symm
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.SourceOrders.chartToFinite_isLocalDiffeomorphAt_zero
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (j : Elliptic.Kind) : IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω (chartToFinite π j) 0 := by
+  have hzero : (0 : ℂ) ∈ (SpecialPeriods.Triangle.ellipticFullChart j).target := by
+    simpa only [SpecialPeriods.Triangle.ellipticFullChart_center] using
+      (SpecialPeriods.Triangle.ellipticFullChart j).map_source
+        (SpecialPeriods.Triangle.ellipticFullChart_center_mem_source j)
+  have hinv :
+    IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω (SpecialPeriods.Triangle.ellipticFullChart j).symm 0 :=
+    (SpecialPeriods.triangleOrbitCoordinatePartial (.inr j)).symm.isLocalDiffeomorphAt _ _ _ hzero
+  exact
+    hinv.comp (K := 𝓘(ℂ)) (P := ℂ)
+      ((SpecialPeriods.BetaTorsor.finiteOrbitBiholomorph π hπ).isLocalDiffeomorph _)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.SourceOrders.finiteProjection_analyticAt
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) (z : ℍ) :
+    AnalyticAt ℂ (SpecialPeriods.BetaTorsor.finiteProjection π ∘ UpperHalfPlane.ofComplex)
+      (z : ℂ) :=
+  ((SpecialPeriods.BetaTorsor.finiteProjection_holomorphic π hπ).contMDiffAt.comp (z : ℂ)
+      (UpperHalfPlane.contMDiffAt_ofComplex z.im_pos)).contDiffAt.analyticAt
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.SourceOrders.finiteProjection_eq_center_iff
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (j : Elliptic.Kind) (z : ℍ) :
+    SpecialPeriods.BetaTorsor.finiteProjection π z =
+        SpecialPeriods.BetaTorsor.finiteProjection π (SpecialPeriods.Triangle.ellipticCenter j) ↔
+      SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.Triangle.ellipticOrbitCenter j :=
+  (SpecialPeriods.BetaTorsor.finiteOrbitCoordinate_injective π hπ).eq_iff
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.SourceOrders.finiteProjection_centered_order_center
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (j : Elliptic.Kind) :
+    analyticOrderAt
+        (fun w : ℂ =>
+          SpecialPeriods.BetaTorsor.finiteProjection π (UpperHalfPlane.ofComplex w) -
+            SpecialPeriods.BetaTorsor.finiteProjection π
+              (SpecialPeriods.Triangle.ellipticCenter j))
+        (SpecialPeriods.Triangle.ellipticCenter j : ℂ) =
+      (j.order : ℕ∞) := by
+  let F : ℂ → ℂ :=
+    SpecialPeriods.Triangle.ellipticFullChart j ∘
+      SpecialPeriods.triangleOrbitProjection ∘ UpperHalfPlane.ofComplex
+  have hF : AnalyticAt ℂ F (SpecialPeriods.Triangle.ellipticCenter j : ℂ) :=
+    SpecialPeriods.Triangle.ellipticFullChart_complexGerm_analyticAt j
+  have hF0 : F (SpecialPeriods.Triangle.ellipticCenter j : ℂ) = 0 := by
+    simp only [F, Function.comp_apply, UpperHalfPlane.ofComplex_apply]
+    exact SpecialPeriods.Triangle.ellipticFullChart_center j
+  have hlocal :
+    IsLocalDiffeomorphAt 𝓘(ℂ) 𝓘(ℂ) ω (chartToFinite π j)
+      (F (SpecialPeriods.Triangle.ellipticCenter j : ℂ)) := by
+    rw [hF0]
+    exact chartToFinite_isLocalDiffeomorphAt_zero π hπ j
+  have horder := centered_order_comp hF hlocal
+  have he :
+    (fun w : ℂ =>
+        SpecialPeriods.BetaTorsor.finiteProjection π (UpperHalfPlane.ofComplex w) -
+          SpecialPeriods.BetaTorsor.finiteProjection π
+            (SpecialPeriods.Triangle.ellipticCenter
+              j)) =ᶠ[𝓝 (SpecialPeriods.Triangle.ellipticCenter j : ℂ)]
+      (fun w =>
+        chartToFinite π j (F w) -
+          SpecialPeriods.BetaTorsor.finiteProjection π
+            (SpecialPeriods.Triangle.ellipticCenter j)) := by
+    filter_upwards [finiteProjection_germ_eventuallyEq_chartToFinite π j
+        (SpecialPeriods.Triangle.ellipticCenter j)
+        (SpecialPeriods.Triangle.ellipticFullChart_center_mem_source j)] with
+      w hw
+    exact
+      congrArg
+        (fun a : ℂ =>
+          a -
+            SpecialPeriods.BetaTorsor.finiteProjection π
+              (SpecialPeriods.Triangle.ellipticCenter j))
+        hw
+  calc
+    analyticOrderAt
+          (fun w : ℂ =>
+            SpecialPeriods.BetaTorsor.finiteProjection π (UpperHalfPlane.ofComplex w) -
+              SpecialPeriods.BetaTorsor.finiteProjection π
+                (SpecialPeriods.Triangle.ellipticCenter j))
+          (SpecialPeriods.Triangle.ellipticCenter j : ℂ) =
+        analyticOrderAt
+          (fun w =>
+            chartToFinite π j (F w) -
+              SpecialPeriods.BetaTorsor.finiteProjection π
+                (SpecialPeriods.Triangle.ellipticCenter j))
+          (SpecialPeriods.Triangle.ellipticCenter j : ℂ) :=
+      analyticOrderAt_congr he
+    _ = analyticOrderAt F (SpecialPeriods.Triangle.ellipticCenter j : ℂ) := by
+      simpa only [hF0, chartToFinite_zero, sub_zero] using horder
+    _ = (j.order : ℕ∞) := SpecialPeriods.Triangle.ellipticFullChart_order_center j
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.SourceOrders.finiteProjection_centered_order_of_fibre
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (j : Elliptic.Kind) (z : ℍ)
+    (hz :
+      SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.Triangle.ellipticOrbitCenter j) :
+    analyticOrderAt
+        (fun w : ℂ =>
+          SpecialPeriods.BetaTorsor.finiteProjection π (UpperHalfPlane.ofComplex w) -
+            SpecialPeriods.BetaTorsor.finiteProjection π
+              (SpecialPeriods.Triangle.ellipticCenter j))
+        (z : ℂ) =
+      (j.order : ℕ∞) := by
+  obtain ⟨g, rfl⟩ :=
+    (SpecialPeriods.triangleOrbitProjection_eq_iff z
+          (SpecialPeriods.Triangle.ellipticCenter j)).mp
+      hz
+  have ht :=
+    SpecialPeriods.Triangle.triangle_invariant_analyticOrderAt
+      (fun a : ℍ =>
+        SpecialPeriods.BetaTorsor.finiteProjection π a -
+          SpecialPeriods.BetaTorsor.finiteProjection π (SpecialPeriods.Triangle.ellipticCenter j))
+      (fun g a => by rw [SpecialPeriods.BetaTorsor.finiteProjection_invariant]) g
+      (SpecialPeriods.Triangle.ellipticCenter j)
+  exact ht.trans (finiteProjection_centered_order_center π hπ j)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.SourceOrders.finiteProjection_centerOne
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere)) :
+    SpecialPeriods.BetaTorsor.finiteProjection π SpecialPeriods.Triangle.centerOne = 0 := by
+  apply OnePoint.coe_injective
+  exact
+    (SpecialPeriods.BetaTorsor.finiteOrbitCoordinate_coe π hπ
+          SpecialPeriods.triangleOrbitCenterOne).trans
+      h₀
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.SourceOrders.finiteProjection_centerTwo
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere)) :
+    SpecialPeriods.BetaTorsor.finiteProjection π SpecialPeriods.Triangle.centerTwo = 1 := by
+  apply OnePoint.coe_injective
+  exact
+    (SpecialPeriods.BetaTorsor.finiteOrbitCoordinate_coe π hπ
+          SpecialPeriods.triangleOrbitCenterTwo).trans
+      h₁
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.SourceOrders.finiteProjection_eq_zero_iff
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (z : ℍ) :
+    SpecialPeriods.BetaTorsor.finiteProjection π z = 0 ↔
+      SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterOne := by
+  rw [← finiteProjection_centerOne π hπ h₀]
+  exact finiteProjection_eq_center_iff π hπ .three z
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.SourceOrders.finiteProjection_eq_one_iff
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere))
+    (z : ℍ) :
+    SpecialPeriods.BetaTorsor.finiteProjection π z = 1 ↔
+      SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterTwo := by
+  rw [← finiteProjection_centerTwo π hπ h₁]
+  exact finiteProjection_eq_center_iff π hπ .four z
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.MuTorsor.SourceOrders.sourceJ
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (z : ℍ) : ℂ :=
+  1728 * SpecialPeriods.BetaTorsor.finiteProjection π z
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.SourceOrders.sourceJ_invariant
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (g : SpecialPeriods.TriangleGroup) (z : ℍ) :
+    sourceJ π (SpecialPeriods.triangleGeometricRepresentation g z) = sourceJ π z := by
+  simp only [sourceJ, SpecialPeriods.BetaTorsor.finiteProjection_invariant]
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.SourceOrders.sourceJ_eq_zero_iff_finiteProjection
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (z : ℍ) : sourceJ π z = 0 ↔ SpecialPeriods.BetaTorsor.finiteProjection π z = 0 := by
+  simp only [sourceJ, mul_eq_zero, show (1728 : ℂ) ≠ 0 by norm_num, false_or]
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.SourceOrders.sourceJ_eq_1728_iff_finiteProjection
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (z : ℍ) : sourceJ π z = 1728 ↔ SpecialPeriods.BetaTorsor.finiteProjection π z = 1 := by
+  constructor
+  · intro h
+    exact mul_left_cancel₀ (by norm_num : (1728 : ℂ) ≠ 0) (h.trans (mul_one (1728 : ℂ)).symm)
+  · intro h
+    simp only [sourceJ, h, mul_one]
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.SourceOrders.sourceJ_holomorphic
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (sourceJ π) :=
+  contMDiff_const.mul (SpecialPeriods.BetaTorsor.finiteProjection_holomorphic π hπ)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.SourceOrders.finiteProjection_order_of_eq_zero
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (z : ℍ) (hz : SpecialPeriods.BetaTorsor.finiteProjection π z = 0) :
+    analyticOrderAt (SpecialPeriods.BetaTorsor.finiteProjection π ∘ UpperHalfPlane.ofComplex)
+        (z : ℂ) =
+      3 := by
+  have h :=
+    finiteProjection_centered_order_of_fibre π hπ .three z
+      ((finiteProjection_eq_zero_iff π hπ h₀ z).mp hz)
+  change
+    analyticOrderAt
+        (fun w : ℂ =>
+          SpecialPeriods.BetaTorsor.finiteProjection π (UpperHalfPlane.ofComplex w) -
+            SpecialPeriods.BetaTorsor.finiteProjection π SpecialPeriods.Triangle.centerOne)
+        (z : ℂ) =
+      3 at h
+  simpa only [finiteProjection_centerOne π hπ h₀, sub_zero, Function.comp_def] using h
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.SourceOrders.finiteProjection_sub_one_order_of_eq_one
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere))
+    (z : ℍ) (hz : SpecialPeriods.BetaTorsor.finiteProjection π z = 1) :
+    analyticOrderAt
+        (fun w : ℂ =>
+          SpecialPeriods.BetaTorsor.finiteProjection π (UpperHalfPlane.ofComplex w) - 1)
+        (z : ℂ) =
+      4 := by
+  have h :=
+    finiteProjection_centered_order_of_fibre π hπ .four z
+      ((finiteProjection_eq_one_iff π hπ h₁ z).mp hz)
+  change
+    analyticOrderAt
+        (fun w : ℂ =>
+          SpecialPeriods.BetaTorsor.finiteProjection π (UpperHalfPlane.ofComplex w) -
+            SpecialPeriods.BetaTorsor.finiteProjection π SpecialPeriods.Triangle.centerTwo)
+        (z : ℂ) =
+      4 at h
+  simpa only [finiteProjection_centerTwo π hπ h₁] using h
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.SourceOrders.sourceJ_centerOne
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere)) :
+    sourceJ π SpecialPeriods.Triangle.centerOne = 0 := by
+  simp only [sourceJ, finiteProjection_centerOne π hπ h₀, MulZeroClass.mul_zero]
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.SourceOrders.sourceJ_centerTwo
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere)) :
+    sourceJ π SpecialPeriods.Triangle.centerTwo = 1728 := by
+  simp only [sourceJ, finiteProjection_centerTwo π hπ h₁, mul_one]
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.SourceOrders.sourceJ_order_of_eq_zero
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (z : ℍ) (hz : sourceJ π z = 0) :
+    analyticOrderAt (sourceJ π ∘ UpperHalfPlane.ofComplex) (z : ℂ) = 3 := by
+  have hc : AnalyticAt ℂ (fun _ : ℂ => (1728 : ℂ)) (z : ℂ) := analyticAt_const
+  have hco : analyticOrderAt (fun _ : ℂ => (1728 : ℂ)) (z : ℂ) = 0 :=
+    hc.analyticOrderAt_eq_zero.mpr (by norm_num)
+  change
+    analyticOrderAt
+        ((fun _ : ℂ => (1728 : ℂ)) *
+          (SpecialPeriods.BetaTorsor.finiteProjection π ∘ UpperHalfPlane.ofComplex))
+        (z : ℂ) =
+      3
+  rw [analyticOrderAt_mul hc (finiteProjection_analyticAt π hπ z), hco, zero_add]
+  exact
+    finiteProjection_order_of_eq_zero π hπ h₀ z ((sourceJ_eq_zero_iff_finiteProjection π z).mp hz)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.SourceOrders.sourceJ_sub_1728_order_of_eq
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere))
+    (z : ℍ) (hz : sourceJ π z = 1728) :
+    analyticOrderAt (fun w : ℂ => sourceJ π (UpperHalfPlane.ofComplex w) - 1728) (z : ℂ) = 4 := by
+  have hc : AnalyticAt ℂ (fun _ : ℂ => (1728 : ℂ)) (z : ℂ) := analyticAt_const
+  have hco : analyticOrderAt (fun _ : ℂ => (1728 : ℂ)) (z : ℂ) = 0 :=
+    hc.analyticOrderAt_eq_zero.mpr (by norm_num)
+  have hp :
+    AnalyticAt ℂ
+      (fun w : ℂ => SpecialPeriods.BetaTorsor.finiteProjection π (UpperHalfPlane.ofComplex w) - 1)
+      (z : ℂ) :=
+    (finiteProjection_analyticAt π hπ z).sub analyticAt_const
+  have he :
+    (fun w : ℂ => sourceJ π (UpperHalfPlane.ofComplex w) - 1728) =
+      (fun _ : ℂ => (1728 : ℂ)) *
+        (fun w : ℂ =>
+          SpecialPeriods.BetaTorsor.finiteProjection π (UpperHalfPlane.ofComplex w) - 1) := by
+    funext w
+    simp only [sourceJ, Pi.mul_apply]
+    ring
+  rw [he, analyticOrderAt_mul hc hp, hco, zero_add]
+  exact
+    finiteProjection_sub_one_order_of_eq_one π hπ h₁ z
+      ((sourceJ_eq_1728_iff_finiteProjection π z).mp hz)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.SourceOrders.sourceJ_order_centerOne
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere)) :
+    analyticOrderAt (sourceJ π ∘ UpperHalfPlane.ofComplex)
+        (SpecialPeriods.Triangle.centerOne : ℂ) =
+      3 :=
+  sourceJ_order_of_eq_zero π hπ h₀ SpecialPeriods.Triangle.centerOne (sourceJ_centerOne π hπ h₀)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.SourceOrders.sourceJ_sub_1728_order_centerTwo
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere)) :
+    analyticOrderAt (fun w : ℂ => sourceJ π (UpperHalfPlane.ofComplex w) - 1728)
+        (SpecialPeriods.Triangle.centerTwo : ℂ) =
+      4 :=
+  sourceJ_sub_1728_order_of_eq π hπ h₁ SpecialPeriods.Triangle.centerTwo
+    (sourceJ_centerTwo π hπ h₁)
+
+private abbrev SpecialPeriods.ModularOrbitSpace :=
+  Quotient (MulAction.orbitRel SL(2, ℤ) ℍ)
+
+private def SpecialPeriods.modularOrbitProjection : ℍ → ModularOrbitSpace :=
+  Quotient.mk _
+
+private theorem
+    SpecialPeriods.modularOrbitProjection_continuous : Continuous modularOrbitProjection :=
+  continuous_quotient_mk'
+
+private theorem SpecialPeriods.modularOrbitProjection_surjective :
+    Function.Surjective modularOrbitProjection :=
+  Quotient.mk_surjective
+
+private theorem SpecialPeriods.modularOrbitProjection_smul (γ : SL(2, ℤ)) (z : ℍ) :
+    modularOrbitProjection (γ • z) = modularOrbitProjection z :=
+  MulAction.orbitRel.Quotient.quotient_smul_eq
+
+private def SpecialPeriods.modularQuotientJ : ModularOrbitSpace → ℂ :=
+  Quotient.lift modularJ
+    (by
+      intro z w h
+      change z ∈ MulAction.orbit SL(2, ℤ) w at h
+      obtain ⟨γ, rfl⟩ := h
+      exact modularJ_SL_invariant γ w)
+
+@[simp]
+private theorem SpecialPeriods.modularQuotientJ_projection (z : ℍ) :
+    modularQuotientJ (modularOrbitProjection z) = modularJ z :=
+  rfl
+
+private theorem SpecialPeriods.modularQuotientJ_continuous : Continuous modularQuotientJ :=
+  modularJ_continuous.quotient_lift _
+
+private theorem SpecialPeriods.modularJ_bounded_im (R : ℝ) :
+    ∃ A : ℝ, ∀ z : ℍ, ‖modularJ z‖ ≤ R → z.im ≤ A := by
+  have h := norm_modularJ_tendsto.eventually (Filter.eventually_gt_atTop R)
+  obtain ⟨A, hA⟩ := (UpperHalfPlane.atImInfty_mem {z : ℍ | R < ‖modularJ z‖}).mp h
+  refine ⟨A, fun z hz => ?_⟩
+  by_contra hzA
+  exact (not_lt_of_ge hz) (hA z (le_of_lt (lt_of_not_ge hzA)))
+
+private theorem SpecialPeriods.modularQuotientJ_bounded_representatives (R : ℝ) :
+    ∃ A : ℝ,
+      ∀ x : ModularOrbitSpace,
+        ‖modularQuotientJ x‖ ≤ R →
+          x ∈ modularOrbitProjection '' ModularGroup.truncatedFundamentalDomain A := by
+  obtain ⟨A, hA⟩ := modularJ_bounded_im R
+  refine ⟨A, ?_⟩
+  intro x hx
+  obtain ⟨z, rfl⟩ := modularOrbitProjection_surjective x
+  obtain ⟨γ, hγ⟩ := ModularGroup.exists_smul_mem_fd z
+  refine ⟨γ • z, ⟨hγ, hA (γ • z) ?_⟩, modularOrbitProjection_smul γ z⟩
+  simpa only [modularJ_SL_invariant, modularQuotientJ_projection] using hx
+
+private theorem SpecialPeriods.modularQuotientJ_isCompact_preimage {K : Set ℂ} (hK : IsCompact K) :
+    IsCompact (modularQuotientJ ⁻¹' K) := by
+  obtain ⟨R, hR⟩ := hK.isBounded.exists_norm_le
+  obtain ⟨A, hA⟩ := modularQuotientJ_bounded_representatives R
+  have hcompact :
+    IsCompact (modularOrbitProjection '' ModularGroup.truncatedFundamentalDomain A) :=
+    (ModularGroup.isCompact_truncatedFundamentalDomain A).image modularOrbitProjection_continuous
+  exact
+    hcompact.of_isClosed_subset (hK.isClosed.preimage modularQuotientJ_continuous)
+      (fun x hx => hA x (hR _ hx))
+
+private theorem SpecialPeriods.modularQuotientJ_proper : IsProperMap modularQuotientJ :=
+  isProperMap_iff_isCompact_preimage.mpr
+    ⟨modularQuotientJ_continuous, fun _ hK => modularQuotientJ_isCompact_preimage hK⟩
+
+private theorem SpecialPeriods.modularQuotientJ_isClosedMap : IsClosedMap modularQuotientJ :=
+  modularQuotientJ_proper.isClosedMap
+
+private theorem
+    SpecialPeriods.modularJ_compact_fibre_finite {K : Set ℍ} (hK : IsCompact K) (c : ℂ) :
+    (K ∩ modularJ ⁻¹' { c }).Finite := by
+  have hd : IsDiscrete (K ∩ {z : ℍ | modularJ z = c}) :=
+    (modularJ_fibre_isDiscrete c).mono Set.inter_subset_right
+  have h := (hK.inter_right (modularJ_fibre_isClosed c)).finite hd
+  simpa only [Set.preimage, Set.mem_singleton_iff] using h
+
+private theorem SpecialPeriods.modularQuotientJ_fibre_finite (c : ℂ) :
+    (modularQuotientJ ⁻¹' { c }).Finite := by
+  obtain ⟨A, hA⟩ := modularQuotientJ_bounded_representatives ‖c‖
+  have hfinite :=
+    modularJ_compact_fibre_finite (ModularGroup.isCompact_truncatedFundamentalDomain A) c
+  apply (hfinite.image modularOrbitProjection).subset
+  intro x hx
+  have hxc : modularQuotientJ x = c := hx
+  obtain ⟨z, hz, hzx⟩ := hA x (by rw [hxc])
+  refine ⟨z, ⟨hz, ?_⟩, hzx⟩
+  change modularJ z = c
+  rw [← modularQuotientJ_projection, hzx, hxc]
+
+private theorem
+    SpecialPeriods.modularQuotientJ_surjective : Function.Surjective modularQuotientJ := by
+  intro c
+  obtain ⟨z, hz⟩ := modularJ_surjective c
+  exact ⟨modularOrbitProjection z, hz⟩
+
+private theorem SpecialPeriods.modularQuotientJ_isOpenMap : IsOpenMap modularQuotientJ :=
+  IsOpenMap.of_comp modularOrbitProjection_continuous modularOrbitProjection_surjective
+    modularJ_isOpenMap
+
+private instance
+    SpecialPeriods.modularGroup_continuousConstSMul : ContinuousConstSMul SL(2, ℤ) ℍ where
+  continuous_const_smul
+    γ := ContinuousConstSMul.continuous_const_smul (Matrix.SpecialLinearGroup.mapGL ℝ γ)
+
+private instance SpecialPeriods.modularGroup_properlyDiscontinuous :
+    ProperlyDiscontinuousSMul SL(2, ℤ) ℍ := by
+  constructor
+  intro K L hK hL
+  have hfinite : {g : GL (Fin 2) ℝ | g ∈ 𝒮ℒ ∧ (g • K ∩ L).Nonempty}.Finite :=
+    (Subgroup.properlyDiscontinuousSMul_iff 𝒮ℒ).mp inferInstance hK hL
+  have hpre :=
+    hfinite.preimage
+      (Matrix.SpecialLinearGroup.mapGL_injective (R := ℤ) (n := Fin 2) (S := ℝ)).injOn
+  exact hpre.subset fun γ hγ => ⟨⟨γ, rfl⟩, hγ⟩
+
+private theorem SpecialPeriods.modularOrbitProjection_isOpenQuotientMap :
+    IsOpenQuotientMap modularOrbitProjection :=
+  MulAction.isOpenQuotientMap_quotientMk
+
+private theorem
+    SpecialPeriods.modularOrbitProjection_isOpenMap : IsOpenMap modularOrbitProjection :=
+  modularOrbitProjection_isOpenQuotientMap.isOpenMap
+
+private instance SpecialPeriods.modularOrbitSpace_t2 : T2Space ModularOrbitSpace :=
+  t2Space_of_properlyDiscontinuousSMul_of_t2Space
+
+private theorem SpecialPeriods.hasDerivAt_qParam_one_mo1973_16934 (z : ℂ) :
+    HasDerivAt (Function.Periodic.qParam 1)
+      ((2 * Real.pi * Complex.I) * Function.Periodic.qParam 1 z) z := by
+  change
+    HasDerivAt (fun w : ℂ => Complex.exp ((2 * Real.pi * Complex.I) * w / 1))
+      ((2 * Real.pi * Complex.I) * Complex.exp ((2 * Real.pi * Complex.I) * z / 1)) z
+  simpa [Function.Periodic.qParam, mul_comm] using
+    ((hasDerivAt_id z).const_mul (2 * (Real.pi : ℂ) * Complex.I)).cexp
+
+private theorem
+    SpecialPeriods.normalizedDerivOfComplex_eq_q_mul_deriv {k : ℤ} (f : ModularForm 𝒮ℒ k)
+    (z : ℍ) :
+    Derivative.normalizedDerivOfComplex f z =
+      Function.Periodic.qParam 1 z *
+        deriv (UpperHalfPlane.cuspFunction 1 f) (Function.Periodic.qParam 1 z) := by
+  have hdiff :=
+    ModularFormClass.differentiableAt_cuspFunction f zero_lt_one one_mem_strictPeriods_SL
+      (Function.Periodic.norm_qParam_lt_one zero_lt_one z.im_pos)
+  have hcomp := hdiff.hasDerivAt.comp (z : ℂ) (hasDerivAt_qParam_one_mo1973_16934 z)
+  have heq :
+    (f ∘ UpperHalfPlane.ofComplex) =ᶠ[𝓝 (z : ℂ)]
+      (fun w => UpperHalfPlane.cuspFunction 1 f (Function.Periodic.qParam 1 w)) := by
+    filter_upwards [UpperHalfPlane.isOpen_upperHalfPlaneSet.mem_nhds z.im_pos] with w hw
+    have h :=
+      SlashInvariantFormClass.eq_cuspFunction f (⟨w, hw⟩ : ℍ) one_mem_strictPeriods_SL one_ne_zero
+    simpa [Function.comp_apply, UpperHalfPlane.ofComplex_apply_of_im_pos hw] using h.symm
+  have hd := (hcomp.congr_of_eventuallyEq heq).deriv
+  rw [Derivative.normalizedDerivOfComplex, hd]
+  field_simp [Complex.two_pi_I_ne_zero]
+
+private theorem
+    SpecialPeriods.normalizedDerivOfComplex_tendsto_zero {k : ℤ} (f : ModularForm 𝒮ℒ k) :
+    Filter.Tendsto (Derivative.normalizedDerivOfComplex f) UpperHalfPlane.atImInfty (𝓝 0) := by
+  have ha := ModularFormClass.analyticAt_cuspFunction_zero f zero_lt_one one_mem_strictPeriods_SL
+  have ht :=
+    (UpperHalfPlane.qParam_tendsto_atImInfty (h := 1) zero_lt_one).mul
+      (ha.deriv.continuousAt.tendsto.comp (UpperHalfPlane.qParam_tendsto_atImInfty zero_lt_one))
+  simpa only [MulZeroClass.zero_mul, Function.comp_def,
+    ← normalizedDerivOfComplex_eq_q_mul_deriv] using ht
+
+private theorem SpecialPeriods.E2_periodic_comp_ofComplex :
+    Function.Periodic (EisensteinSeries.E2 ∘ UpperHalfPlane.ofComplex) (1 : ℂ) := by
+  have hT (z : ℍ) : EisensteinSeries.E2 ((1 : ℝ) +ᵥ z) = EisensteinSeries.E2 z := by
+    have h := congrFun (EisensteinSeries.E2_slash_action ModularGroup.T) z
+    rw [ModularForm.SL_slash_apply, UpperHalfPlane.modular_T_smul] at h
+    have hd : UpperHalfPlane.denom (ModularGroup.T : SL(2, ℤ)) z = 1 := by
+      rw [ModularGroup.denom_apply]
+      rw [ModularGroup.coe_T]
+      norm_num
+    simpa only [hd, one_zpow, mul_one, EisensteinSeries.D2_T, smul_zero, sub_zero] using h
+  intro w
+  by_cases hw : 0 < w.im
+  · have hw' : 0 < (w + 1).im := by simpa using hw
+    have hz : UpperHalfPlane.ofComplex (w + 1) = (1 : ℝ) +ᵥ (⟨w, hw⟩ : ℍ) := by
+      apply UpperHalfPlane.ext
+      simp [UpperHalfPlane.ofComplex_apply_of_im_pos hw', add_comm]
+    simpa [Function.comp_apply, hz, UpperHalfPlane.ofComplex_apply_of_im_pos hw] using hT ⟨w, hw⟩
+  · have hw' : (w + 1).im ≤ 0 := by simpa using le_of_not_gt hw
+    simp [Function.comp_apply, UpperHalfPlane.ofComplex_apply_of_im_nonpos hw',
+      UpperHalfPlane.ofComplex_apply_of_im_nonpos (le_of_not_gt hw)]
+
+private theorem SpecialPeriods.E2_cuspFunction_analyticAt_zero :
+    AnalyticAt ℂ (UpperHalfPlane.cuspFunction 1 EisensteinSeries.E2) 0 :=
+  UpperHalfPlane.analyticAt_cuspFunction_zero zero_lt_one E2_periodic_comp_ofComplex
+    E2_mdifferentiable EisensteinSeries.isBoundedAtImInfty_E2
+
+private theorem SpecialPeriods.E2_hasSum_qParam (z : ℍ) :
+    HasSum
+      (fun m : ℕ =>
+        (if m = 0 then (1 : ℂ) else -24 * (ArithmeticFunction.sigma 1 m : ℂ)) •
+          Function.Periodic.qParam 1 z ^ m)
+      (EisensteinSeries.E2 z) := by
+  simpa only [Function.Periodic.qParam, Complex.ofReal_one, div_one] using
+    EisensteinSeries.hasSum_qExpansion_E2 (z := z)
+
+private theorem SpecialPeriods.cuspFunction_zero_of_hasSum_mo1973_16940 (f : ℍ → ℂ) (c : ℕ → ℂ)
+    (ha : AnalyticAt ℂ (UpperHalfPlane.cuspFunction 1 f) 0)
+    (hs : ∀ z : ℍ, HasSum (fun m => c m • Function.Periodic.qParam 1 z ^ m) (f z)) :
+    UpperHalfPlane.cuspFunction 1 f 0 = c 0 := by
+  have h :=
+    (UpperHalfPlane.hasFPowerSeriesOnBall_cuspFunction (h := 1) (f := f) (c := c) zero_lt_one ha
+          hs).coeff_zero
+      (fun i => Fin.elim0 i)
+  simpa using h.symm
+
+private theorem SpecialPeriods.E2_cuspFunction_zero :
+    UpperHalfPlane.cuspFunction 1 EisensteinSeries.E2 0 = 1 := by
+  exact
+    cuspFunction_zero_of_hasSum_mo1973_16940 EisensteinSeries.E2
+      (fun m => if m = 0 then (1 : ℂ) else -24 * (ArithmeticFunction.sigma 1 m : ℂ))
+      E2_cuspFunction_analyticAt_zero E2_hasSum_qParam
+
+private theorem SpecialPeriods.E2_tendsto_one :
+    Filter.Tendsto EisensteinSeries.E2 UpperHalfPlane.atImInfty (𝓝 1) := by
+  have h :=
+    E2_cuspFunction_analyticAt_zero.continuousAt.tendsto.comp
+      (UpperHalfPlane.qParam_tendsto_atImInfty (h := 1) zero_lt_one)
+  simpa only [Function.comp_def, E2_cuspFunction_zero,
+    UpperHalfPlane.eq_cuspFunction _ one_ne_zero E2_periodic_comp_ofComplex] using h
+
+private theorem
+    SpecialPeriods.modularForm_tendsto_qExpansion_coeff_zero {k : ℤ} (f : ModularForm 𝒮ℒ k) :
+    Filter.Tendsto f UpperHalfPlane.atImInfty (𝓝 ((UpperHalfPlane.qExpansion 1 f).coeff 0)) := by
+  have h :=
+    (ModularFormClass.analyticAt_cuspFunction_zero f zero_lt_one
+          one_mem_strictPeriods_SL).continuousAt.tendsto.comp
+      (UpperHalfPlane.qParam_tendsto_atImInfty (h := 1) zero_lt_one)
+  simpa [Function.comp_def, UpperHalfPlane.qExpansion_coeff,
+    SlashInvariantFormClass.eq_cuspFunction f _ one_mem_strictPeriods_SL one_ne_zero] using h
+
+private theorem SpecialPeriods.serreDerivative_tendsto {k : ℤ} (f : ModularForm 𝒮ℒ k) :
+    Filter.Tendsto (Derivative.serreDerivative k f) UpperHalfPlane.atImInfty
+      (𝓝 (-(k : ℂ) / 12 * (UpperHalfPlane.qExpansion 1 f).coeff 0)) := by
+  have h :=
+    (normalizedDerivOfComplex_tendsto_zero f).sub
+      (((tendsto_const_nhds (x := (k : ℂ) * 12⁻¹)).mul E2_tendsto_one).mul
+        (modularForm_tendsto_qExpansion_coeff_zero f))
+  convert h using 1
+  · ext z
+    rfl
+  · congr 1
+    ring
+
+private theorem SpecialPeriods.serreDerivative_boundedAtImInfty {k : ℤ} (f : ModularForm 𝒮ℒ k) :
+    UpperHalfPlane.IsBoundedAtImInfty (Derivative.serreDerivative k f) :=
+  (serreDerivative_tendsto f).isBigO_one ℝ
+
+private def SpecialPeriods.serreDerivativeModularForm {k : ℤ} (f : ModularForm 𝒮ℒ k) :
+    ModularForm 𝒮ℒ (k + 2)
+    where
+  toFun := Derivative.serreDerivative k f
+  slash_action_eq' γ
+    hγ := by
+    obtain ⟨g, rfl⟩ := MonoidHom.mem_range.mp hγ
+    apply Derivative.serreDerivative_slash_invariant (ModularFormClass.holo f)
+    exact SlashInvariantFormClass.slash_action_eq f g (MonoidHom.mem_range.mpr ⟨g, rfl⟩)
+  holo' := Derivative.serreDerivative_mdifferentiable k (ModularFormClass.holo f)
+  bdd_at_cusps'
+    hc := by
+    apply (OnePoint.isBoundedAt_iff_forall_SL2Z hc).mpr
+    intro γ hγ
+    rw [Derivative.serreDerivative_slash_invariant (ModularFormClass.holo f)
+        (SlashInvariantFormClass.slash_action_eq f γ (MonoidHom.mem_range.mpr ⟨γ, rfl⟩))]
+    exact serreDerivative_boundedAtImInfty f
+
+private theorem SpecialPeriods.serreDerivativeModularForm_qExpansion_coeff_zero {k : ℤ}
+    (f : ModularForm 𝒮ℒ k) :
+    (UpperHalfPlane.qExpansion 1 (serreDerivativeModularForm f)).coeff 0 =
+      -(k : ℂ) / 12 * (UpperHalfPlane.qExpansion 1 f).coeff 0 := by
+  apply
+    tendsto_nhds_unique (modularForm_tendsto_qExpansion_coeff_zero (serreDerivativeModularForm f))
+  exact serreDerivative_tendsto f
+
+private theorem SpecialPeriods.serreDerivative_E₄ (z : ℍ) :
+    Derivative.serreDerivative 4 ModularForm.E₄ z = -(ModularForm.E₆ z) / 3 := by
+  have heq : serreDerivativeModularForm ModularForm.E₄ = (-1 / 3 : ℂ) • ModularForm.E₆ := by
+    apply levelOne_eq_of_qExpansion_coeff_zero (by norm_num)
+    rw [serreDerivativeModularForm_qExpansion_coeff_zero, FunLike.coe_smul,
+      ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL, PowerSeries.coeff_smul,
+      EisensteinSeries.E_qExpansion_coeff_zero _ ⟨2, rfl⟩,
+      EisensteinSeries.E_qExpansion_coeff_zero _ ⟨3, rfl⟩]
+    norm_num
+  have hz := congrArg (fun f : ModularForm 𝒮ℒ 6 => f z) heq
+  change Derivative.serreDerivative 4 ModularForm.E₄ z = (-1 / 3 : ℂ) * ModularForm.E₆ z at hz
+  rw [hz]
+  ring
+
+private theorem SpecialPeriods.serreDerivative_E₆ (z : ℍ) :
+    Derivative.serreDerivative 6 ModularForm.E₆ z = -(ModularForm.E₄ z ^ 2) / 2 := by
+  have heq :
+    serreDerivativeModularForm ModularForm.E₆ =
+      (-1 / 2 : ℂ) • ModularForm.E₄.mul ModularForm.E₄ := by
+    apply levelOne_eq_of_qExpansion_coeff_zero (by norm_num)
+    rw [serreDerivativeModularForm_qExpansion_coeff_zero, FunLike.coe_smul,
+      ModularForm.qExpansion_smul one_pos one_mem_strictPeriods_SL, PowerSeries.coeff_smul,
+      ModularForm.qExpansion_mul one_pos one_mem_strictPeriods_SL, PowerSeries.coeff_mul]
+    norm_num [EisensteinSeries.E_qExpansion_coeff_zero _ ⟨3, rfl⟩,
+      EisensteinSeries.E_qExpansion_coeff_zero _ ⟨2, rfl⟩]
+  have hz := congrArg (fun f : ModularForm 𝒮ℒ 8 => f z) heq
+  change
+    Derivative.serreDerivative 6 ModularForm.E₆ z =
+      (-1 / 2 : ℂ) * (ModularForm.E₄ z * ModularForm.E₄ z) at hz
+  rw [hz]
+  ring
+
+private theorem SpecialPeriods.normalizedDeriv_E₄ (z : ℍ) :
+    Derivative.normalizedDerivOfComplex ModularForm.E₄ z =
+      (EisensteinSeries.E2 z * ModularForm.E₄ z - ModularForm.E₆ z) / 3 := by
+  have h := serreDerivative_E₄ z
+  unfold Derivative.serreDerivative at h
+  linear_combination h
+
+private theorem SpecialPeriods.normalizedDeriv_E₆ (z : ℍ) :
+    Derivative.normalizedDerivOfComplex ModularForm.E₆ z =
+      (EisensteinSeries.E2 z * ModularForm.E₆ z - ModularForm.E₄ z ^ 2) / 2 := by
+  have h := serreDerivative_E₆ z
+  unfold Derivative.serreDerivative at h
+  linear_combination h
+
+private theorem SpecialPeriods.normalizedDeriv_discriminant (z : ℍ) :
+    Derivative.normalizedDerivOfComplex ModularForm.discriminant z =
+      EisensteinSeries.E2 z * ModularForm.discriminant z := by
+  have hf :
+    ModularForm.discriminant =
+      (1 / 1728 : ℂ) • ((ModularForm.E₄ : ℍ → ℂ) ^ 3 - (ModularForm.E₆ : ℍ → ℂ) ^ 2) := by
+    funext w
+    change
+      ModularForm.discriminant w = (1 / 1728 : ℂ) * (ModularForm.E₄ w ^ 3 - ModularForm.E₆ w ^ 2)
+    rw [ModularForm.discriminant_eq_E₄_cube_sub_E₆_sq]
+    ring
+  have h4 : MDiff (ModularForm.E₄ : ℍ → ℂ) := ModularFormClass.holo ModularForm.E₄
+  have h6 : MDiff (ModularForm.E₆ : ℍ → ℂ) := ModularFormClass.holo ModularForm.E₆
+  rw [hf, Derivative.normalizedDerivOfComplex_smul _ _ ((h4.pow 3).sub (h6.pow 2)),
+    Derivative.normalizedDerivOfComplex_sub _ _ (h4.pow 3) (h6.pow 2),
+    Derivative.normalizedDerivOfComplex_pow _ 3 h4,
+    Derivative.normalizedDerivOfComplex_pow _ 2 h6]
+  simp only [Pi.smul_apply, Pi.sub_apply, Pi.mul_apply, Pi.pow_apply, Pi.natCast_apply,
+    smul_eq_mul]
+  rw [normalizedDeriv_E₄, normalizedDeriv_E₆]
+  ring
+
+private theorem SpecialPeriods.deriv_eq_two_pi_I_mul_normalizedDeriv (f : ℍ → ℂ) (z : ℍ) :
+    deriv (f ∘ UpperHalfPlane.ofComplex) (z : ℂ) =
+      (2 * (Real.pi : ℂ) * Complex.I) * Derivative.normalizedDerivOfComplex f z := by
+  rw [Derivative.normalizedDerivOfComplex, ← mul_assoc, mul_inv_cancel₀ Complex.two_pi_I_ne_zero,
+    one_mul]
+
+private theorem SpecialPeriods.deriv_E₄ (z : ℍ) :
+    deriv (ModularForm.E₄ ∘ UpperHalfPlane.ofComplex) (z : ℂ) =
+      (2 * (Real.pi : ℂ) * Complex.I) / 3 *
+        (EisensteinSeries.E2 z * ModularForm.E₄ z - ModularForm.E₆ z) := by
+  rw [deriv_eq_two_pi_I_mul_normalizedDeriv, normalizedDeriv_E₄]
+  ring
+
+private theorem SpecialPeriods.deriv_E₆ (z : ℍ) :
+    deriv (ModularForm.E₆ ∘ UpperHalfPlane.ofComplex) (z : ℂ) =
+      (2 * (Real.pi : ℂ) * Complex.I) / 2 *
+        (EisensteinSeries.E2 z * ModularForm.E₆ z - ModularForm.E₄ z ^ 2) := by
+  rw [deriv_eq_two_pi_I_mul_normalizedDeriv, normalizedDeriv_E₆]
+  ring
+
+private theorem SpecialPeriods.deriv_discriminant (z : ℍ) :
+    deriv (ModularForm.discriminant ∘ UpperHalfPlane.ofComplex) (z : ℂ) =
+      (2 * (Real.pi : ℂ) * Complex.I) * EisensteinSeries.E2 z * ModularForm.discriminant z := by
+  rw [deriv_eq_two_pi_I_mul_normalizedDeriv, normalizedDeriv_discriminant]
+  ring
+
+private theorem SpecialPeriods.deriv_E₄_ne_zero_of_eq_zero (z : ℍ) (hz : ModularForm.E₄ z = 0) :
+    deriv (ModularForm.E₄ ∘ UpperHalfPlane.ofComplex) (z : ℂ) ≠ 0 := by
+  have h6 : ModularForm.E₆ z ≠ 0 := (E₄_E₆_not_both_zero z).resolve_left (by simp [hz])
+  rw [deriv_E₄, hz, MulZeroClass.mul_zero, zero_sub]
+  exact mul_ne_zero (div_ne_zero Complex.two_pi_I_ne_zero (by norm_num)) (neg_ne_zero.mpr h6)
+
+private theorem SpecialPeriods.deriv_E₆_ne_zero_of_eq_zero (z : ℍ) (hz : ModularForm.E₆ z = 0) :
+    deriv (ModularForm.E₆ ∘ UpperHalfPlane.ofComplex) (z : ℂ) ≠ 0 := by
+  have h4 : ModularForm.E₄ z ≠ 0 := (E₄_E₆_not_both_zero z).resolve_right (by simp [hz])
+  rw [deriv_E₆, hz, MulZeroClass.mul_zero, zero_sub]
+  exact
+    mul_ne_zero (div_ne_zero Complex.two_pi_I_ne_zero (by norm_num))
+      (neg_ne_zero.mpr (pow_ne_zero 2 h4))
+
+private theorem SpecialPeriods.analyticOrderAt_E₄_of_eq_zero (z : ℍ) (hz : ModularForm.E₄ z = 0) :
+    analyticOrderAt (ModularForm.E₄ ∘ UpperHalfPlane.ofComplex) (z : ℂ) = 1 := by
+  apply (modularForm_analyticAt ModularForm.E₄ z).analyticOrderAt_eq_one_of_zero_deriv_ne_zero
+  · simpa only [Function.comp_apply, UpperHalfPlane.ofComplex_apply] using hz
+  · exact deriv_E₄_ne_zero_of_eq_zero z hz
+
+public
+theorem SpecialPeriods.analyticOrderAt_E₆_of_eq_zero (z : ℍ) (hz : ModularForm.E₆ z = 0) :
+    analyticOrderAt (ModularForm.E₆ ∘ UpperHalfPlane.ofComplex) (z : ℂ) = 1 := by
+  apply (modularForm_analyticAt ModularForm.E₆ z).analyticOrderAt_eq_one_of_zero_deriv_ne_zero
+  · simpa only [Function.comp_apply, UpperHalfPlane.ofComplex_apply] using hz
+  · exact deriv_E₆_ne_zero_of_eq_zero z hz
+
+private theorem SpecialPeriods.discriminant_analyticAt (z : ℍ) :
+    AnalyticAt ℂ (ModularForm.discriminant ∘ UpperHalfPlane.ofComplex) (z : ℂ) :=
+  modularForm_analyticAt (CuspForm.discriminant : ModularForm 𝒮ℒ 12) z
+
+private theorem SpecialPeriods.deriv_modularJ (z : ℍ) :
+    deriv (modularJ ∘ UpperHalfPlane.ofComplex) (z : ℂ) =
+      -(2 * (Real.pi : ℂ) * Complex.I) * (ModularForm.E₄ z ^ 2 * ModularForm.E₆ z) /
+        ModularForm.discriminant z := by
+  have h₄ := (modularForm_analyticAt ModularForm.E₄ z).differentiableAt.hasDerivAt
+  have hΔ := (discriminant_analyticAt z).differentiableAt.hasDerivAt
+  have hd :=
+    (h₄.pow 3).div hΔ
+      (by
+        simpa only [Function.comp_apply, UpperHalfPlane.ofComplex_apply] using
+          ModularForm.discriminant_ne_zero z)
+  have he := hd.deriv
+  change deriv (modularJ ∘ UpperHalfPlane.ofComplex) (z : ℂ) = _ at he
+  rw [he]
+  simp only [Pi.pow_apply, Function.comp_apply, UpperHalfPlane.ofComplex_apply, Nat.cast_ofNat,
+    Nat.reduceSub]
+  rw [deriv_E₄, deriv_discriminant]
+  field_simp [ModularForm.discriminant_ne_zero z]
+  ring
+
+private theorem SpecialPeriods.deriv_modularJ_eq_zero_iff (z : ℍ) :
+    deriv (modularJ ∘ UpperHalfPlane.ofComplex) (z : ℂ) = 0 ↔
+      modularJ z = 0 ∨ modularJ z = 1728 := by
+  rw [deriv_modularJ, modularJ_eq_zero_iff, modularJ_eq_1728_iff]
+  simp [ModularForm.discriminant_ne_zero z]
+
+private theorem SpecialPeriods.deriv_modularJ_ne_zero (z : ℍ) (h₀ : modularJ z ≠ 0)
+    (h₁ : modularJ z ≠ 1728) : deriv (modularJ ∘ UpperHalfPlane.ofComplex) (z : ℂ) ≠ 0 := by
+  exact fun he => ((deriv_modularJ_eq_zero_iff z).mp he).elim h₀ h₁
+
+private theorem SpecialPeriods.discriminant_inv_order_zero (z : ℍ) :
+    analyticOrderAt (ModularForm.discriminant ∘ UpperHalfPlane.ofComplex)⁻¹ (z : ℂ) = 0 := by
+  have hΔ :=
+    (discriminant_analyticAt z).inv
+      (by
+        simpa only [Function.comp_apply, UpperHalfPlane.ofComplex_apply] using
+          ModularForm.discriminant_ne_zero z)
+  apply hΔ.analyticOrderAt_eq_zero.mpr
+  simpa only [Pi.inv_apply, Function.comp_apply, UpperHalfPlane.ofComplex_apply] using
+    inv_ne_zero (ModularForm.discriminant_ne_zero z)
+
+private theorem SpecialPeriods.analyticOrderAt_modularJ_of_eq_zero (z : ℍ) (hz : modularJ z = 0) :
+    analyticOrderAt (modularJ ∘ UpperHalfPlane.ofComplex) (z : ℂ) = 3 := by
+  have h₄ := modularForm_analyticAt ModularForm.E₄ z
+  have hΔ :=
+    (discriminant_analyticAt z).inv
+      (by
+        simpa only [Function.comp_apply, UpperHalfPlane.ofComplex_apply] using
+          ModularForm.discriminant_ne_zero z)
+  change
+    analyticOrderAt
+        (((ModularForm.E₄ ∘ UpperHalfPlane.ofComplex) ^ 3) *
+          (ModularForm.discriminant ∘ UpperHalfPlane.ofComplex)⁻¹)
+        (z : ℂ) =
+      3
+  rw [analyticOrderAt_mul (h₄.pow 3) hΔ, analyticOrderAt_pow h₄, discriminant_inv_order_zero,
+    analyticOrderAt_E₄_of_eq_zero z ((modularJ_eq_zero_iff z).mp hz)]
+  norm_num
+
+private theorem
+    SpecialPeriods.analyticOrderAt_modularJ_sub_1728_of_eq (z : ℍ) (hz : modularJ z = 1728) :
+    analyticOrderAt (fun w : ℂ => modularJ (UpperHalfPlane.ofComplex w) - 1728) (z : ℂ) = 2 := by
+  have h₆ := modularForm_analyticAt ModularForm.E₆ z
+  have hΔ :=
+    (discriminant_analyticAt z).inv
+      (by
+        simpa only [Function.comp_apply, UpperHalfPlane.ofComplex_apply] using
+          ModularForm.discriminant_ne_zero z)
+  simp_rw [modularJ_sub_1728, div_eq_mul_inv]
+  change
+    analyticOrderAt
+        (((ModularForm.E₆ ∘ UpperHalfPlane.ofComplex) ^ 2) *
+          (ModularForm.discriminant ∘ UpperHalfPlane.ofComplex)⁻¹)
+        (z : ℂ) =
+      2
+  rw [analyticOrderAt_mul (h₆.pow 2) hΔ, analyticOrderAt_pow h₆, discriminant_inv_order_zero,
+    analyticOrderAt_E₆_of_eq_zero z ((modularJ_eq_1728_iff z).mp hz)]
+  norm_num
+
+private def
+    SpecialPeriods.modularLocalInverse (z : ℍ) (h₀ : modularJ z ≠ 0) (h₁ : modularJ z ≠ 1728) :
+    ℂ → ℂ :=
+  (modularJ_analyticAt z).hasStrictDerivAt.localInverse (modularJ ∘ UpperHalfPlane.ofComplex)
+    (deriv (modularJ ∘ UpperHalfPlane.ofComplex) (z : ℂ)) (z : ℂ) (deriv_modularJ_ne_zero z h₀ h₁)
+
+private theorem SpecialPeriods.modularLocalInverse_analyticAt (z : ℍ) (h₀ : modularJ z ≠ 0)
+    (h₁ : modularJ z ≠ 1728) : AnalyticAt ℂ (modularLocalInverse z h₀ h₁) (modularJ z) := by
+  simpa only [modularLocalInverse, Function.comp_apply, UpperHalfPlane.ofComplex_apply] using
+    (modularJ_analyticAt z).analyticAt_localInverse (deriv_modularJ_ne_zero z h₀ h₁)
+
+private theorem
+    SpecialPeriods.modularLocalInverse_eventually_left_inverse (z : ℍ) (h₀ : modularJ z ≠ 0)
+    (h₁ : modularJ z ≠ 1728) :
+    ∀ᶠ w in 𝓝 (z : ℂ), modularLocalInverse z h₀ h₁ (modularJ (UpperHalfPlane.ofComplex w)) = w :=
+  (modularJ_analyticAt z).hasStrictDerivAt.eventually_left_inverse
+    (deriv_modularJ_ne_zero z h₀ h₁)
+
+private theorem
+    SpecialPeriods.modularLocalInverse_eventually_right_inverse (z : ℍ) (h₀ : modularJ z ≠ 0)
+    (h₁ : modularJ z ≠ 1728) :
+    ∀ᶠ w in 𝓝 (modularJ z),
+      modularJ (UpperHalfPlane.ofComplex (modularLocalInverse z h₀ h₁ w)) = w := by
+  simpa only [modularLocalInverse, Function.comp_apply, UpperHalfPlane.ofComplex_apply] using
+    (modularJ_analyticAt z).hasStrictDerivAt.eventually_right_inverse
+      (deriv_modularJ_ne_zero z h₀ h₁)
+
+private def SpecialPeriods.modularRegularValues : Set ℂ :=
+  ({0, 1728} : Set ℂ)ᶜ
+
+@[simp]
+private theorem SpecialPeriods.mem_modularRegularValues (c : ℂ) :
+    c ∈ modularRegularValues ↔ c ≠ 0 ∧ c ≠ 1728 := by simp [modularRegularValues]
+
+private theorem SpecialPeriods.modularJ_regular_injOn_neighbourhood (z : ℍ) (h₀ : modularJ z ≠ 0)
+    (h₁ : modularJ z ≠ 1728) : ∃ U : Set ℍ, IsOpen U ∧ z ∈ U ∧ Set.InjOn modularJ U := by
+  have hleft : ∀ᶠ w in 𝓝 z, modularLocalInverse z h₀ h₁ (modularJ w) = (w : ℂ) := by
+    have h :=
+      UpperHalfPlane.continuous_coe.continuousAt.tendsto.eventually
+        (modularLocalInverse_eventually_left_inverse z h₀ h₁)
+    simpa only [Function.comp_apply, UpperHalfPlane.ofComplex_apply] using h
+  obtain ⟨U, hU, hUo, hz⟩ := mem_nhds_iff.mp hleft
+  refine ⟨U, hUo, hz, ?_⟩
+  intro w hw v hv heq
+  apply UpperHalfPlane.ext
+  rw [← hU hw, ← hU hv, heq]
+
+private theorem SpecialPeriods.modularQuotientJ_regular_injOn_neighbourhood (x : ModularOrbitSpace)
+    (hx : modularQuotientJ x ∈ modularRegularValues) :
+    ∃ V : Set ModularOrbitSpace, IsOpen V ∧ x ∈ V ∧ Set.InjOn modularQuotientJ V := by
+  obtain ⟨z, rfl⟩ := modularOrbitProjection_surjective x
+  obtain ⟨h₀, h₁⟩ := (mem_modularRegularValues _).mp hx
+  obtain ⟨U, hUo, hz, hinj⟩ := modularJ_regular_injOn_neighbourhood z h₀ h₁
+  refine ⟨modularOrbitProjection '' U, modularOrbitProjection_isOpenMap U hUo, ⟨z, hz, rfl⟩, ?_⟩
+  rintro _ ⟨w, hw, rfl⟩ _ ⟨v, hv, rfl⟩ h
+  exact congrArg modularOrbitProjection (hinj hw hv h)
+
+private theorem SpecialPeriods.modularQuotientJ_regular_isLocalHomeomorphOn :
+    IsLocalHomeomorphOn modularQuotientJ (modularQuotientJ ⁻¹' modularRegularValues) := by
+  intro x hx
+  obtain ⟨V, hVo, hxV, hinj⟩ := modularQuotientJ_regular_injOn_neighbourhood x hx
+  let e :=
+    OpenPartialHomeomorph.ofContinuousOpen (hinj.toPartialEquiv modularQuotientJ V)
+      modularQuotientJ_continuous.continuousOn modularQuotientJ_isOpenMap hVo
+  exact ⟨e, hxV, rfl⟩
+
+private theorem SpecialPeriods.modularQuotientJ_regular_isCoveringMapOn :
+    IsCoveringMapOn modularQuotientJ modularRegularValues :=
+  modularQuotientJ_isClosedMap.isCoveringMapOn_of_isLocalHomeomorphOn
+    (fun c _ => modularQuotientJ_fibre_finite c) modularQuotientJ_regular_isLocalHomeomorphOn
+
+private abbrev SpecialPeriods.ModularRegularBase :=
+  ↥modularRegularValues
+
+private abbrev SpecialPeriods.ModularRegularOrbitSpace :=
+  ↥(modularQuotientJ ⁻¹' modularRegularValues)
+
+private def
+    SpecialPeriods.modularRegularQuotientJ : ModularRegularOrbitSpace → ModularRegularBase :=
+  modularRegularValues.restrictPreimage modularQuotientJ
+
+private theorem SpecialPeriods.modularRegularQuotientJ_isCoveringMap :
+    IsCoveringMap modularRegularQuotientJ :=
+  modularQuotientJ_regular_isCoveringMapOn.isCoveringMap_restrictPreimage
+
+private def SpecialPeriods.modularCuspBase (q : ℂ) : ℂ :=
+  1728 * q / modularJUnit q
+
+@[simp]
+private theorem
+    SpecialPeriods.modularCuspBase_zero : modularCuspBase 0 = 0 := by simp [modularCuspBase]
+
+private theorem SpecialPeriods.modularCuspBase_analyticAt_zero : AnalyticAt ℂ modularCuspBase 0 :=
+  (analyticAt_const.mul analyticAt_id).div modularJUnit_analyticAt_zero (by simp)
+
+private theorem SpecialPeriods.modularCuspBase_hasDerivAt : HasDerivAt modularCuspBase 1728 0 := by
+  have hn : HasDerivAt (fun q : ℂ => 1728 * q) 1728 0 := by
+    simpa only [id_eq, mul_one] using (hasDerivAt_id (0 : ℂ)).const_mul (1728 : ℂ)
+  have hu : HasDerivAt modularJUnit (deriv modularJUnit 0) 0 :=
+    modularJUnit_analyticAt_zero.differentiableAt.hasDerivAt
+  have hd := hn.div hu (by simp : modularJUnit 0 ≠ 0)
+  change
+    HasDerivAt modularCuspBase
+      ((1728 * modularJUnit 0 - (1728 * (0 : ℂ)) * deriv modularJUnit 0) / modularJUnit 0 ^ 2)
+      0 at hd
+  simpa only [modularJUnit_zero, mul_one, MulZeroClass.mul_zero, MulZeroClass.zero_mul, sub_zero,
+    one_pow, div_one] using hd
+
+private theorem SpecialPeriods.modularCuspBase_deriv : deriv modularCuspBase 0 = 1728 :=
+  modularCuspBase_hasDerivAt.deriv
+
+private theorem SpecialPeriods.modularCuspBase_deriv_ne_zero : deriv modularCuspBase 0 ≠ 0 := by
+  rw [modularCuspBase_deriv]
+  norm_num
+
+private def SpecialPeriods.modularCuspQ : ℂ → ℂ :=
+  modularCuspBase_analyticAt_zero.hasStrictDerivAt.localInverse modularCuspBase
+    (deriv modularCuspBase 0) 0 modularCuspBase_deriv_ne_zero
+
+private theorem SpecialPeriods.modularCuspQ_analyticAt_zero : AnalyticAt ℂ modularCuspQ 0 := by
+  simpa only [modularCuspQ, modularCuspBase_zero] using
+    modularCuspBase_analyticAt_zero.analyticAt_localInverse modularCuspBase_deriv_ne_zero
+
+private theorem SpecialPeriods.modularCuspQ_eventually_left_inverse :
+    ∀ᶠ q in 𝓝 (0 : ℂ), modularCuspQ (modularCuspBase q) = q :=
+  modularCuspBase_analyticAt_zero.hasStrictDerivAt.eventually_left_inverse
+    modularCuspBase_deriv_ne_zero
+
+private theorem SpecialPeriods.modularCuspQ_eventually_right_inverse :
+    ∀ᶠ t in 𝓝 (0 : ℂ), modularCuspBase (modularCuspQ t) = t := by
+  simpa only [modularCuspQ, modularCuspBase_zero] using
+    modularCuspBase_analyticAt_zero.hasStrictDerivAt.eventually_right_inverse
+      modularCuspBase_deriv_ne_zero
+
+@[simp]
+private theorem SpecialPeriods.modularCuspQ_zero : modularCuspQ 0 = 0 := by
+  simpa only [modularCuspBase_zero] using modularCuspQ_eventually_left_inverse.self_of_nhds
+
+private theorem SpecialPeriods.modularCuspQ_hasDerivAt : HasDerivAt modularCuspQ (1 / 1728) 0 := by
+  simpa only [modularCuspQ, modularCuspBase_zero, modularCuspBase_deriv, one_div] using
+    (modularCuspBase_analyticAt_zero.hasStrictDerivAt.to_localInverse
+        modularCuspBase_deriv_ne_zero).hasDerivAt
+
+private theorem SpecialPeriods.modularCuspQ_deriv : deriv modularCuspQ 0 = 1 / 1728 :=
+  modularCuspQ_hasDerivAt.deriv
+
+private def SpecialPeriods.modularCuspUnit : ℂ → ℂ :=
+  dslope modularCuspQ 0
+
+private theorem SpecialPeriods.modularCuspUnit_analyticAt_zero : AnalyticAt ℂ modularCuspUnit 0 :=
+  modularCuspQ_analyticAt_zero.hasFPowerSeriesAt.has_fpower_series_dslope_fslope.analyticAt
+
+@[simp]
+private theorem SpecialPeriods.modularCuspUnit_zero : modularCuspUnit 0 = 1 / 1728 := by
+  rw [modularCuspUnit, dslope_same, modularCuspQ_deriv]
+
+private theorem SpecialPeriods.modularCuspQ_eq_mul_unit (t : ℂ) :
+    modularCuspQ t = t * modularCuspUnit t := by
+  simpa only [modularCuspUnit, sub_zero, modularCuspQ_zero, smul_eq_mul] using
+    (sub_smul_dslope modularCuspQ 0 t).symm
+
+private theorem SpecialPeriods.modularCuspUnit_eventually_ne_zero :
+    ∀ᶠ t in 𝓝 (0 : ℂ), modularCuspUnit t ≠ 0 :=
+  modularCuspUnit_analyticAt_zero.continuousAt.eventually_ne (by simp)
+
+private theorem SpecialPeriods.modularCuspQ_eventually_j_eq :
+    ∀ᶠ t in 𝓝[≠] (0 : ℂ), modularJInQ (modularCuspQ t) = 1728 / t := by
+  filter_upwards [modularCuspQ_eventually_right_inverse.filter_mono nhdsWithin_le_nhds,
+    modularCuspUnit_eventually_ne_zero.filter_mono nhdsWithin_le_nhds, self_mem_nhdsWithin] with t
+    ht hu ht₀
+  have ht₀' : t ≠ 0 := ht₀
+  have hq : modularCuspQ t ≠ 0 := by rw [modularCuspQ_eq_mul_unit]; exact mul_ne_zero ht₀' hu
+  have hj : modularJUnit (modularCuspQ t) ≠ 0 := by
+    intro h
+    simp [modularCuspBase, h] at ht
+    exact ht₀' ht.symm
+  unfold modularCuspBase at ht
+  unfold modularJInQ
+  rw [eq_div_iff ht₀']
+  calc
+    modularJUnit (modularCuspQ t) / modularCuspQ t * t =
+        modularJUnit (modularCuspQ t) / modularCuspQ t *
+          (1728 * modularCuspQ t / modularJUnit (modularCuspQ t)) :=
+      congrArg (fun v => modularJUnit (modularCuspQ t) / modularCuspQ t * v) ht.symm
+    _ = 1728 := by field_simp
+
+private theorem SpecialPeriods.modularCuspBase_eq_div_j (q : ℂ) :
+    modularCuspBase q = 1728 / modularJInQ q := by
+  rw [modularCuspBase, modularJInQ, div_div_eq_mul_div]
+
+private theorem SpecialPeriods.modularJInQ_injOn_small_disc :
+    ∃ r : ℝ, 0 < r ∧ Set.InjOn modularJInQ (Metric.ball 0 r) := by
+  obtain ⟨r, hr, hball⟩ := Metric.mem_nhds_iff.mp modularCuspQ_eventually_left_inverse
+  refine ⟨r, hr, ?_⟩
+  intro q hq w hw he
+  calc
+    q = modularCuspQ (modularCuspBase q) := (hball hq).symm
+    _ = modularCuspQ (modularCuspBase w) := by
+      rw [modularCuspBase_eq_div_j, he, ← modularCuspBase_eq_div_j]
+    _ = w := hball hw
+
+private theorem SpecialPeriods.modularOrbitProjection_eq_of_qParam_eq {z w : ℍ}
+    (hq : Function.Periodic.qParam 1 (z : ℂ) = Function.Periodic.qParam 1 (w : ℂ)) :
+    modularOrbitProjection z = modularOrbitProjection w := by
+  obtain ⟨m, hm⟩ :=
+    Function.Periodic.qParam_left_inv_mod_period (h := (1 : ℝ)) one_ne_zero (z : ℂ)
+  obtain ⟨n, hn⟩ :=
+    Function.Periodic.qParam_left_inv_mod_period (h := (1 : ℝ)) one_ne_zero (w : ℂ)
+  have he : (z : ℂ) + (m : ℂ) = (w : ℂ) + (n : ℂ) := by
+    simpa only [Complex.ofReal_one, mul_one] using
+      hm.symm.trans ((congrArg (Function.Periodic.invQParam 1) hq).trans hn)
+  have htw : ModularGroup.T ^ (m - n) • z = w := by
+    apply UpperHalfPlane.ext
+    rw [ModularGroup.coe_T_zpow_smul_eq, Int.cast_sub]
+    linear_combination he
+  rw [← htw, modularOrbitProjection_smul]
+
+private theorem SpecialPeriods.modularJ_high_im_orbit_separation :
+    ∃ A : ℝ,
+      ∀ z w : ℍ,
+        A ≤ z.im →
+          A ≤ w.im →
+            modularJ z = modularJ w → modularOrbitProjection z = modularOrbitProjection w := by
+  obtain ⟨r, hr, hinj⟩ := modularJInQ_injOn_small_disc
+  have hevent :
+    {z : ℍ | Function.Periodic.qParam 1 (z : ℂ) ∈ Metric.ball 0 r} ∈ UpperHalfPlane.atImInfty :=
+    (UpperHalfPlane.qParam_tendsto_atImInfty zero_lt_one).eventually (Metric.ball_mem_nhds 0 hr)
+  obtain ⟨A, hA⟩ := UpperHalfPlane.atImInfty_mem _ |>.mp hevent
+  refine ⟨A, fun z w hz hw hj => modularOrbitProjection_eq_of_qParam_eq ?_⟩
+  apply hinj (hA z hz) (hA w hw)
+  simpa only [modularJInQ_qParam] using hj
+
+private theorem SpecialPeriods.modularQuotientJ_large_norm_injective :
+    ∃ R : ℝ,
+      ∀ x y : ModularOrbitSpace,
+        R < ‖modularQuotientJ x‖ → modularQuotientJ x = modularQuotientJ y → x = y := by
+  obtain ⟨A, hA⟩ := modularJ_high_im_orbit_separation
+  have hcompact := ModularGroup.isCompact_truncatedFundamentalDomain A
+  obtain ⟨R, hR⟩ := hcompact.exists_bound_of_continuousOn modularJ_continuous.continuousOn
+  refine ⟨R, ?_⟩
+  intro x y hx hxy
+  obtain ⟨z, rfl⟩ := modularOrbitProjection_surjective x
+  obtain ⟨w, rfl⟩ := modularOrbitProjection_surjective y
+  obtain ⟨γ, hγ⟩ := ModularGroup.exists_smul_mem_fd z
+  obtain ⟨δ, hδ⟩ := ModularGroup.exists_smul_mem_fd w
+  have hzlarge : R < ‖modularJ (γ • z)‖ := by
+    simpa only [modularJ_SL_invariant, modularQuotientJ_projection] using hx
+  have hwlarge : R < ‖modularJ (δ • w)‖ := by
+    simpa only [modularJ_SL_invariant, modularQuotientJ_projection, hxy] using hx
+  have hzheight : A ≤ (γ • z).im := by
+    by_contra h
+    exact (not_lt_of_ge (hR (γ • z) ⟨hγ, (lt_of_not_ge h).le⟩)) hzlarge
+  have hwheight : A ≤ (δ • w).im := by
+    by_contra h
+    exact (not_lt_of_ge (hR (δ • w) ⟨hδ, (lt_of_not_ge h).le⟩)) hwlarge
+  have heq : modularJ (γ • z) = modularJ (δ • w) := by
+    simpa only [modularJ_SL_invariant, modularQuotientJ_projection] using hxy
+  simpa only [modularOrbitProjection_smul] using hA _ _ hzheight hwheight heq
+
+private theorem SpecialPeriods.modularQuotientJ_unique_fibre_at_large_values :
+    ∃ R : ℝ, 0 < R ∧ ∀ c : ℂ, R < ‖c‖ → ∃! x : ModularOrbitSpace, modularQuotientJ x = c := by
+  obtain ⟨R, hR⟩ := modularQuotientJ_large_norm_injective
+  refine ⟨Max.max R 0 + 1, by positivity, ?_⟩
+  intro c hc
+  obtain ⟨x, hx⟩ := modularQuotientJ_surjective c
+  refine ⟨x, hx, ?_⟩
+  intro y hy
+  apply hR y x
+  · rw [hy]
+    exact
+      (lt_of_le_of_lt (le_max_left R 0) (lt_add_of_pos_right (Max.max R 0) zero_lt_one)).trans hc
+  · exact hy.trans hx.symm
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Uniformization/SpecialPeriods4.lean b/LeanPool/HopfProblem/Uniformization/SpecialPeriods4.lean
new file mode 100644
index 000000000..b55b02e91
--- /dev/null
+++ b/LeanPool/HopfProblem/Uniformization/SpecialPeriods4.lean
@@ -0,0 +1,2892 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods3
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+
+/-!
+# Hopf problem: uniformization · special periods 4
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private instance SpecialPeriods.modularRegularBase_pathConnected :
+    PathConnectedSpace ModularRegularBase :=
+  ModularCoverTools.complex_compl_pair_pathConnected 0 1728
+
+private theorem SpecialPeriods.modularRegularValues_dense : Dense modularRegularValues :=
+  ModularCoverTools.complex_compl_pair_dense 0 1728
+
+private theorem SpecialPeriods.modularRegularQuotientJ_exists_subsingleton_fibre :
+    ∃ c : ModularRegularBase, Subsingleton (modularRegularQuotientJ ⁻¹' { c }) := by
+  obtain ⟨R, hR, hlarge⟩ := modularQuotientJ_unique_fibre_at_large_values
+  let r : ℝ := Max.max R 1728 + 1
+  have hrpos : 0 < r := by dsimp [r]; linarith [le_max_right R (1728 : ℝ)]
+  have hrbig : 1728 < r := by dsimp [r]; linarith [le_max_right R (1728 : ℝ)]
+  have hrR : R < r := by dsimp [r]; linarith [le_max_left R (1728 : ℝ)]
+  let c : ModularRegularBase :=
+    ⟨(r : ℂ),
+      (mem_modularRegularValues _).mpr ⟨by exact_mod_cast hrpos.ne', by exact_mod_cast hrbig.ne'⟩⟩
+  have hRc : R < ‖(c : ℂ)‖ := by
+    change R < ‖(r : ℂ)‖
+    simpa only [Complex.norm_real, Real.norm_of_nonneg hrpos.le] using hrR
+  obtain ⟨x, hx, hunique⟩ := hlarge c hRc
+  refine ⟨c, ⟨?_⟩⟩
+  intro u v
+  apply Subtype.ext
+  apply Subtype.ext
+  have hu : modularQuotientJ (u.1 : ModularOrbitSpace) = (c : ℂ) :=
+    congrArg Subtype.val (show modularRegularQuotientJ u.1 = c from u.2)
+  have hv : modularQuotientJ (v.1 : ModularOrbitSpace) = (c : ℂ) :=
+    congrArg Subtype.val (show modularRegularQuotientJ v.1 = c from v.2)
+  exact (hunique _ hu).trans (hunique _ hv).symm
+
+private theorem SpecialPeriods.modularRegularQuotientJ_injective :
+    Function.Injective modularRegularQuotientJ := by
+  obtain ⟨c, hc⟩ := modularRegularQuotientJ_exists_subsingleton_fibre
+  exact
+    ModularCoverTools.injective_of_covering_singleton_fibre modularRegularQuotientJ_isCoveringMap
+      c hc
+
+private theorem SpecialPeriods.modularQuotientJ_injOn_regular :
+    Set.InjOn modularQuotientJ (modularQuotientJ ⁻¹' modularRegularValues) := by
+  intro x hx y hy hxy
+  have h : (⟨x, hx⟩ : ModularRegularOrbitSpace) = ⟨y, hy⟩ :=
+    modularRegularQuotientJ_injective (Subtype.ext hxy)
+  exact congrArg Subtype.val h
+
+private theorem SpecialPeriods.modularQuotientJ_injective : Function.Injective modularQuotientJ :=
+  ModularCoverTools.injective_of_open_dense modularQuotientJ_isOpenMap modularRegularValues_dense
+    modularQuotientJ_injOn_regular
+
+private theorem SpecialPeriods.modularJ_eq_iff_mem_orbit (z w : ℍ) :
+    modularJ z = modularJ w ↔ z ∈ MulAction.orbit SL(2, ℤ) w := by
+  constructor
+  · intro h
+    exact Quotient.exact (modularQuotientJ_injective h)
+  · intro h
+    exact congrArg modularQuotientJ (Quotient.sound h)
+
+private theorem SpecialPeriods.modularJ_eq_iff_exists_smul (z w : ℍ) :
+    modularJ z = modularJ w ↔ ∃ γ : SL(2, ℤ), γ • w = z :=
+  modularJ_eq_iff_mem_orbit z w
+
+private theorem SpecialPeriods.exists_analytic_unit_root {g : ℂ → ℂ} {a : ℂ} {m : ℕ}
+    (hg : AnalyticAt ℂ g a) (hga : g a ≠ 0) (hm : 0 < m) :
+    ∃ r : ℂ → ℂ, AnalyticAt ℂ r a ∧ r a ≠ 0 ∧ ∀ᶠ w in 𝓝 a, r w ^ m = g w := by
+  obtain ⟨b, hb⟩ := IsAlgClosed.exists_pow_nat_eq (g a) hm
+  have hb0 : b ≠ 0 := by
+    intro h
+    apply hga
+    rw [← hb, h, zero_pow hm.ne']
+  have hpow : AnalyticAt ℂ (fun w : ℂ => w ^ m) b := analyticAt_id.pow m
+  have hderiv : deriv (fun w : ℂ => w ^ m) b ≠ 0 := by
+    rw [deriv_pow_field]
+    exact mul_ne_zero (Nat.cast_ne_zero.mpr hm.ne') (pow_ne_zero _ hb0)
+  let R : ℂ → ℂ := hpow.hasStrictDerivAt.localInverse (fun w : ℂ => w ^ m) _ b hderiv
+  have hRa : AnalyticAt ℂ R (g a) := by
+    rw [← hb]
+    exact hpow.analyticAt_localInverse hderiv
+  have hRb : R (g a) = b := by
+    rw [← hb]
+    exact HasStrictFDerivAt.localInverse_apply_image ..
+  have hRpow : ∀ᶠ y in 𝓝 (g a), R y ^ m = y := by
+    rw [← hb]
+    exact hpow.hasStrictDerivAt.eventually_right_inverse hderiv
+  refine ⟨fun w => R (g w), hRa.comp hg, ?_, ?_⟩
+  · change R (g a) ≠ 0
+    rw [hRb]
+    exact hb0
+  · exact hg.continuousAt.tendsto.eventually hRpow
+
+private theorem SpecialPeriods.exists_analytic_power_coordinate {F : ℂ → ℂ} {a : ℂ} {m : ℕ}
+    (hF : AnalyticAt ℂ F a) (horder : analyticOrderAt F a = m) (hm : 0 < m) :
+    ∃ h : ℂ → ℂ, AnalyticAt ℂ h a ∧ h a = 0 ∧ deriv h a ≠ 0 ∧ ∀ᶠ w in 𝓝 a, F w = h w ^ m := by
+  obtain ⟨g, hg, hga, hFg⟩ := hF.analyticOrderAt_eq_natCast.mp horder
+  obtain ⟨r, hr, hra, hrpow⟩ := exists_analytic_unit_root hg hga hm
+  let h : ℂ → ℂ := fun w => (w - a) * r w
+  have hh : AnalyticAt ℂ h a := (analyticAt_id.sub analyticAt_const).mul hr
+  have hderiv : deriv h a = r a := by
+    simpa only [h, id_eq, sub_self, MulZeroClass.zero_mul, one_mul, add_zero] using
+      (((hasDerivAt_id a).sub_const a).fun_mul hr.differentiableAt.hasDerivAt).deriv
+  refine ⟨h, hh, by simp [h], hderiv ▸ hra, ?_⟩
+  filter_upwards [hFg, hrpow] with w hw hwr
+  rw [hw, smul_eq_mul, ← hwr, ← mul_pow]
+
+private theorem
+    SpecialPeriods.exists_analytic_power_chart_in {F : ℂ → ℂ} {a : ℂ} {m : ℕ} {U : Set ℂ}
+    (hF : AnalyticAt ℂ F a) (horder : analyticOrderAt F a = m) (hm : 0 < m) (hU : U ∈ 𝓝 a) :
+    ∃ e : OpenPartialHomeomorph ℂ ℂ,
+      a ∈ e.source ∧
+        e a = 0 ∧
+          e.source ⊆ U ∧
+            AnalyticOnNhd ℂ e e.source ∧
+              AnalyticOnNhd ℂ e.symm e.target ∧ ∀ w ∈ e.source, F w = e w ^ m := by
+  obtain ⟨h, hh, hha, hdh, hpower⟩ := exists_analytic_power_coordinate hF horder hm
+  obtain ⟨e₀, hae₀, he₀, hea, hei⟩ := exists_analytic_openPartialHomeomorph hh hdh
+  have hboth : ∀ᶠ w in 𝓝 a, F w = h w ^ m ∧ w ∈ U := hpower.and hU
+  obtain ⟨V, hV, hVo, haV⟩ := eventually_nhds_iff.mp hboth
+  let e : OpenPartialHomeomorph ℂ ℂ := e₀.restrOpen V hVo
+  refine ⟨e, ⟨hae₀, haV⟩, ?_, ?_, ?_, ?_, ?_⟩
+  · exact (he₀ a).trans hha
+  · intro w hw
+    exact (hV w hw.2).2
+  · intro w hw
+    exact hea w hw.1
+  · intro w hw
+    exact hei w hw.1
+  · intro w hw
+    exact (hV w hw.2).1.trans (congrArg (· ^ m) (he₀ w).symm)
+
+private theorem SpecialPeriods.exists_analytic_power_chart {F : ℂ → ℂ} {a : ℂ} {m : ℕ}
+    (hF : AnalyticAt ℂ F a) (horder : analyticOrderAt F a = m) (hm : 0 < m) :
+    ∃ e : OpenPartialHomeomorph ℂ ℂ,
+      a ∈ e.source ∧
+        e a = 0 ∧
+          AnalyticOnNhd ℂ e e.source ∧
+            AnalyticOnNhd ℂ e.symm e.target ∧ ∀ w ∈ e.source, F w = e w ^ m := by
+  obtain ⟨e, ha, he, _, hf, hi, hp⟩ :=
+    exists_analytic_power_chart_in hF horder hm (Filter.univ_mem : Set.univ ∈ 𝓝 a)
+  exact ⟨e, ha, he, hf, hi, hp⟩
+
+private theorem
+    SpecialPeriods.power_chart_inverse_identity (e : OpenPartialHomeomorph ℂ ℂ) {F : ℂ → ℂ}
+    {m : ℕ} (hp : ∀ w ∈ e.source, F w = e w ^ m) : ∀ w ∈ e.target, F (e.symm w) = w ^ m := by
+  intro w hw
+  rw [hp _ (e.map_target hw), e.right_inv hw]
+
+private theorem SpecialPeriods.modularJ_cubic_chart (z : ℍ) (hz : modularJ z = 0) :
+    ∃ e : OpenPartialHomeomorph ℂ ℂ,
+      (z : ℂ) ∈ e.source ∧
+        e z = 0 ∧
+          e.source ⊆ UpperHalfPlane.upperHalfPlaneSet ∧
+            AnalyticOnNhd ℂ e e.source ∧
+              AnalyticOnNhd ℂ e.symm e.target ∧
+                (∀ w ∈ e.source, modularJ (UpperHalfPlane.ofComplex w) = e w ^ 3) ∧
+                  (∀ w ∈ e.target, modularJ (UpperHalfPlane.ofComplex (e.symm w)) = w ^ 3) := by
+  obtain ⟨e, ha, he, hU, hf, hi, hp⟩ :=
+    exists_analytic_power_chart_in (modularJ_analyticAt z)
+      (analyticOrderAt_modularJ_of_eq_zero z hz) (by decide : 0 < 3)
+      (UpperHalfPlane.isOpen_upperHalfPlaneSet.mem_nhds z.im_pos)
+  exact ⟨e, ha, he, hU, hf, hi, hp, power_chart_inverse_identity e hp⟩
+
+private theorem SpecialPeriods.modularJ_quadratic_chart (z : ℍ) (hz : modularJ z = 1728) :
+    ∃ e : OpenPartialHomeomorph ℂ ℂ,
+      (z : ℂ) ∈ e.source ∧
+        e z = 0 ∧
+          e.source ⊆ UpperHalfPlane.upperHalfPlaneSet ∧
+            AnalyticOnNhd ℂ e e.source ∧
+              AnalyticOnNhd ℂ e.symm e.target ∧
+                (∀ w ∈ e.source, modularJ (UpperHalfPlane.ofComplex w) - 1728 = e w ^ 2) ∧
+                  (∀ w ∈ e.target,
+                    modularJ (UpperHalfPlane.ofComplex (e.symm w)) - 1728 = w ^ 2) := by
+  obtain ⟨e, ha, he, hU, hf, hi, hp⟩ :=
+    exists_analytic_power_chart_in ((modularJ_analyticAt z).sub analyticAt_const)
+      (analyticOrderAt_modularJ_sub_1728_of_eq z hz) (by decide : 0 < 2)
+      (UpperHalfPlane.isOpen_upperHalfPlaneSet.mem_nhds z.im_pos)
+  exact ⟨e, ha, he, hU, hf, hi, hp, power_chart_inverse_identity e hp⟩
+
+private theorem SpecialPeriods.modularJ_rhoPoint_cubic_chart :
+    ∃ e : OpenPartialHomeomorph ℂ ℂ,
+      rho ∈ e.source ∧
+        e rho = 0 ∧
+          e.source ⊆ UpperHalfPlane.upperHalfPlaneSet ∧
+            AnalyticOnNhd ℂ e e.source ∧
+              AnalyticOnNhd ℂ e.symm e.target ∧
+                (∀ w ∈ e.source, modularJ (UpperHalfPlane.ofComplex w) = e w ^ 3) ∧
+                  (∀ w ∈ e.target, modularJ (UpperHalfPlane.ofComplex (e.symm w)) = w ^ 3) :=
+  modularJ_cubic_chart rhoPoint modularJ_rhoPoint
+
+private theorem SpecialPeriods.modularJ_I_quadratic_chart :
+    ∃ e : OpenPartialHomeomorph ℂ ℂ,
+      Complex.I ∈ e.source ∧
+        e Complex.I = 0 ∧
+          e.source ⊆ UpperHalfPlane.upperHalfPlaneSet ∧
+            AnalyticOnNhd ℂ e e.source ∧
+              AnalyticOnNhd ℂ e.symm e.target ∧
+                (∀ w ∈ e.source, modularJ (UpperHalfPlane.ofComplex w) - 1728 = e w ^ 2) ∧
+                  (∀ w ∈ e.target,
+                    modularJ (UpperHalfPlane.ofComplex (e.symm w)) - 1728 = w ^ 2) :=
+  modularJ_quadratic_chart UpperHalfPlane.I modularJ_I
+
+private theorem
+    SpecialPeriods.analytic_chart_inverse_order_one (e : OpenPartialHomeomorph ℂ ℂ) {a : ℂ}
+    (ha : a ∈ e.source) (he : e a = 0) (hf : AnalyticOnNhd ℂ e e.source)
+    (hi : AnalyticOnNhd ℂ e.symm e.target) : analyticOrderAt (fun z : ℂ => e.symm z - a) 0 = 1 := by
+  have ht : (0 : ℂ) ∈ e.target := he ▸ e.map_source ha
+  have hia : e.symm 0 = a := by rw [← he, e.left_inv ha]
+  have hfi : AnalyticAt ℂ e (e.symm 0) := hia ▸ hf a ha
+  have hii := hi 0 ht
+  have hc := hfi.differentiableAt.hasDerivAt.comp 0 hii.differentiableAt.hasDerivAt
+  have hnear : ∀ᶠ z : ℂ in 𝓝 0, z ∈ e.target := e.open_target.mem_nhds ht
+  have heq : (fun z : ℂ => e (e.symm z)) =ᶠ[𝓝 0] id := hnear.mono fun z hz => e.right_inv hz
+  have hm : deriv e (e.symm 0) * deriv e.symm 0 = 1 :=
+    (hc.congr_of_eventuallyEq heq.symm).unique (hasDerivAt_id 0)
+  have hne : deriv e.symm 0 ≠ 0 := by
+    intro h
+    rw [h, MulZeroClass.mul_zero] at hm
+    exact zero_ne_one hm
+  simpa only [hia] using hii.analyticOrderAt_sub_eq_one_of_deriv_ne_zero hne
+
+private theorem
+    SpecialPeriods.analytic_chart_inverse_power_order (e : OpenPartialHomeomorph ℂ ℂ) {a : ℂ}
+    (ha : a ∈ e.source) (he : e a = 0) (hf : AnalyticOnNhd ℂ e e.source)
+    (hi : AnalyticOnNhd ℂ e.symm e.target) (c : ℂ) (hc : c ≠ 0) (k : ℕ) (hk : 0 < k) :
+    analyticOrderAt (fun z : ℂ => e.symm (c * z ^ k) - a) 0 = (k : ℕ∞) := by
+  have ht : (0 : ℂ) ∈ e.target := he ▸ e.map_source ha
+  have hg : AnalyticAt ℂ (fun z : ℂ => c * z ^ k) 0 := by fun_prop
+  have hg0 : c * (0 : ℂ) ^ k = 0 := by simp [hk.ne']
+  have hi0 : AnalyticAt ℂ (fun z : ℂ => e.symm z - a) (c * (0 : ℂ) ^ k) := by
+    rw [hg0]
+    exact (hi 0 ht).sub analyticAt_const
+  have horder : analyticOrderAt (fun z : ℂ => c * z ^ k) 0 = (k : ℕ∞) := by
+    rw [hg.analyticOrderAt_eq_natCast]
+    refine ⟨fun _ => c, analyticAt_const, hc, ?_⟩
+    exact Filter.Eventually.of_forall fun z => by simp [mul_comm]
+  have hcomp := hi0.analyticOrderAt_comp (g := fun z : ℂ => c * z ^ k) (z₀ := 0) hg
+  simpa only [Function.comp_def, hg0, sub_zero, analytic_chart_inverse_order_one e ha he hf hi,
+    horder, one_mul] using hcomp
+
+private theorem SpecialPeriods.analytic_chart_deriv_ne_zero (e : OpenPartialHomeomorph ℂ ℂ) {a : ℂ}
+    (ha : a ∈ e.source) (hf : AnalyticOnNhd ℂ e e.source) (hi : AnalyticOnNhd ℂ e.symm e.target) :
+    deriv e a ≠ 0 := by
+  have hii := hi (e a) (e.map_source ha)
+  have hc := hii.differentiableAt.hasDerivAt.comp a (hf a ha).differentiableAt.hasDerivAt
+  have hnear : ∀ᶠ z : ℂ in 𝓝 a, z ∈ e.source := e.open_source.mem_nhds ha
+  have heq : (fun z : ℂ => e.symm (e z)) =ᶠ[𝓝 a] id := hnear.mono fun z hz => e.left_inv hz
+  have hm : deriv e.symm (e a) * deriv e a = 1 :=
+    (hc.congr_of_eventuallyEq heq.symm).unique (hasDerivAt_id a)
+  intro h
+  rw [h, MulZeroClass.mul_zero] at hm
+  exact zero_ne_one hm
+
+private def SpecialPeriods.modularRhoAction (w : ℂ) : ℂ :=
+  (w - 1) / w
+
+private def SpecialPeriods.modularIAction (w : ℂ) : ℂ :=
+  -1 / w
+
+private theorem SpecialPeriods.modularRhoAction_coe (z : ℍ) :
+    modularRhoAction z = (((ModularGroup.T * ModularGroup.S) • z : ℍ) : ℂ) := by
+  rw [SemigroupAction.mul_smul, UpperHalfPlane.modular_T_smul, UpperHalfPlane.modular_S_smul]
+  simp only [modularRhoAction, UpperHalfPlane.coe_vadd, Complex.ofReal_one, inv_neg]
+  field_simp [z.ne_zero]
+  ring
+
+private theorem SpecialPeriods.modularIAction_coe (z : ℍ) :
+    modularIAction z = ((ModularGroup.S • z : ℍ) : ℂ) := by
+  rw [UpperHalfPlane.modular_S_smul]
+  simp [modularIAction, inv_neg, div_eq_mul_inv]
+
+private theorem SpecialPeriods.modularRhoAction_deriv_rho : deriv modularRhoAction rho = -rho := by
+  have h := ((hasDerivAt_id rho).sub_const 1).div (hasDerivAt_id rho) rho_ne_zero
+  change HasDerivAt modularRhoAction _ rho at h
+  rw [h.deriv]
+  simp only [id_eq, one_mul, mul_one]
+  field_simp [rho_ne_zero]
+  linear_combination rho_cube
+
+private theorem SpecialPeriods.modularSL_holomorphic (g : SL(2, ℤ)) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z : ℍ => g • z) :=
+  UpperHalfPlane.contMDiff_smul (g := Matrix.SpecialLinearGroup.mapGL ℝ g) (by simp)
+
+private theorem SpecialPeriods.upperHalfPlane_holomorphic_eq_of_eventuallyEq {f g : ℍ → ℍ}
+    (hf : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω f) (hg : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω g) {a : ℍ} (he : f =ᶠ[𝓝 a] g) :
+    f = g := by
+  have hfc : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (fun z => (f z : ℂ)) :=
+    (UpperHalfPlane.contMDiff_coe.comp hf).mdifferentiable (by simp)
+  have hgc : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) (fun z => (g z : ℂ)) :=
+    (UpperHalfPlane.contMDiff_coe.comp hg).mdifferentiable (by simp)
+  have hz : ∀ᶠ z in 𝓝[≠] a, (f z : ℂ) - (g z : ℂ) = 0 :=
+    (he.mono fun z hz => by rw [hz, sub_self]).filter_mono nhdsWithin_le_nhds
+  have hzero := UpperHalfPlane.eq_zero_of_frequently (hfc.sub hgc) hz.frequently
+  funext z
+  apply UpperHalfPlane.ext
+  exact sub_eq_zero.mp (congrFun hzero z)
+
+private theorem SpecialPeriods.realSL_action_identity_of_two_fixed (g : SL(2, ℝ)) {a b : ℍ}
+    (ha : g • a = a) (hb : g • b = b) (hab : a ≠ b) : ∀ z : ℍ, g • z = z := by
+  have hc : Triangle.cayleyCoordinate a b ≠ 0 := by
+    apply div_ne_zero _ (Triangle.sub_conj_ne_zero a b)
+    apply sub_ne_zero.mpr
+    intro h
+    exact hab (UpperHalfPlane.ext h).symm
+  have hm : Triangle.slMultiplier g a = 1 := by
+    have h := Triangle.cayleyCoordinate_smul g a b ha
+    rw [hb] at h
+    exact mul_right_cancel₀ hc (by simpa only [one_mul] using h.symm)
+  intro z
+  apply (Triangle.cayleyBiholomorph a).injective
+  apply Subtype.ext
+  change Triangle.cayleyCoordinate a (g • z) = Triangle.cayleyCoordinate a z
+  rw [Triangle.cayleyCoordinate_smul g a z ha, hm, one_mul]
+
+private theorem SpecialPeriods.integerSL_real_action (g : SL(2, ℤ)) (z : ℍ) :
+    (Matrix.SpecialLinearGroup.map (Int.castRingHom ℝ) g) • z = g • z := by
+  apply UpperHalfPlane.ext
+  rw [UpperHalfPlane.coe_specialLinearGroup_apply, UpperHalfPlane.coe_specialLinearGroup_apply]
+  rfl
+
+private theorem SpecialPeriods.modularSL_action_identity_of_two_fixed (g : SL(2, ℤ)) {a b : ℍ}
+    (ha : g • a = a) (hb : g • b = b) (hab : a ≠ b) : ∀ z : ℍ, g • z = z := by
+  have h :=
+    realSL_action_identity_of_two_fixed (Matrix.SpecialLinearGroup.map (Int.castRingHom ℝ) g)
+      (by simpa only [integerSL_real_action] using ha)
+      (by simpa only [integerSL_real_action] using hb) hab
+  simpa only [integerSL_real_action] using h
+
+private theorem SpecialPeriods.modularJ_equal_lifts_differ_by_SL {f g : ℍ → ℍ}
+    (hf : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω f) (hg : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω g)
+    (hJ : ∀ z, modularJ (f z) = modularJ (g z)) (a : ℍ)
+    (ha : modularJ (f a) ∈ modularRegularValues) : ∃ γ : SL(2, ℤ), ∀ z, γ • f z = g z := by
+  obtain ⟨γ, hγ⟩ := (modularJ_eq_iff_exists_smul (g a) (f a)).mp (hJ a).symm
+  have hga : modularJ (g a) ∈ modularRegularValues := (hJ a) ▸ ha
+  obtain ⟨U, hUo, hgaU, hUi⟩ :=
+    modularJ_regular_injOn_neighbourhood (g a) ((mem_modularRegularValues _).mp hga).1
+      ((mem_modularRegularValues _).mp hga).2
+  have hγf : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z => γ • f z) := (modularSL_holomorphic γ).comp hf
+  have hnear₁ : ∀ᶠ z in 𝓝 a, γ • f z ∈ U := by
+    apply hγf.continuous.continuousAt.preimage_mem_nhds
+    simpa only [hγ] using hUo.mem_nhds hgaU
+  have hnear₂ : ∀ᶠ z in 𝓝 a, g z ∈ U :=
+    hg.continuous.continuousAt.preimage_mem_nhds (hUo.mem_nhds hgaU)
+  have he : (fun z => γ • f z) =ᶠ[𝓝 a] g := by
+    filter_upwards [hnear₁, hnear₂] with z h₁ h₂
+    exact hUi h₁ h₂ ((modularJ_SL_invariant γ (f z)).trans (hJ z))
+  refine ⟨γ, ?_⟩
+  exact congrFun (upperHalfPlane_holomorphic_eq_of_eventuallyEq hγf hg he)
+
+private theorem SpecialPeriods.modular_T_has_no_fixed_point (z : ℍ) : ModularGroup.T • z ≠ z := by
+  intro h
+  have hc := congrArg (fun w : ℍ => (w : ℂ)) h
+  rw [UpperHalfPlane.modular_T_smul, UpperHalfPlane.coe_vadd] at hc
+  have hr := congrArg Complex.re hc
+  simp only [Complex.add_re, Complex.ofReal_one, Complex.one_re] at hr
+  linarith
+
+private theorem SpecialPeriods.modularRho_fixed_iff (z : ℍ) :
+    (ModularGroup.T * ModularGroup.S) • z = z ↔ z = rhoPoint := by
+  constructor
+  · intro hz
+    by_contra hzr
+    have hid :=
+      modularSL_action_identity_of_two_fixed (ModularGroup.T * ModularGroup.S) TS_smul_rhoPoint hz
+        (Ne.symm hzr)
+    have hI := hid UpperHalfPlane.I
+    rw [SemigroupAction.mul_smul, S_smul_I] at hI
+    exact modular_T_has_no_fixed_point UpperHalfPlane.I hI
+  · rintro rfl
+    exact TS_smul_rhoPoint
+
+private theorem SpecialPeriods.modularI_fixed_iff (z : ℍ) :
+    ModularGroup.S • z = z ↔ z = UpperHalfPlane.I := by
+  constructor
+  · intro hz
+    by_contra hzi
+    have hid := modularSL_action_identity_of_two_fixed ModularGroup.S S_smul_I hz (Ne.symm hzi)
+    have hρ : ModularGroup.T • rhoPoint = rhoPoint := by
+      simpa only [SemigroupAction.mul_smul, hid rhoPoint] using TS_smul_rhoPoint
+    exact modular_T_has_no_fixed_point rhoPoint hρ
+  · rintro rfl
+    exact S_smul_I
+
+private def SpecialPeriods.TauCovariant (τ : ℍ → ℍ) : Prop :=
+  (∀ z : ℍ, (τ (Triangle.generatorOneSL • z) : ℂ) = ((τ z : ℂ) - 1) / (τ z : ℂ)) ∧
+    (∀ z : ℍ, (τ (Triangle.generatorTwoSL • z) : ℂ) = -1 / (τ z : ℂ))
+
+private theorem SpecialPeriods.tau_covariant_values {τ : ℍ → ℍ} (hτ : TauCovariant τ) :
+    τ Triangle.centerOne = rhoPoint ∧ τ Triangle.centerTwo = UpperHalfPlane.I := by
+  constructor
+  · apply (modularRho_fixed_iff _).mp
+    apply UpperHalfPlane.ext
+    rw [← modularRhoAction_coe]
+    have h := hτ.1 Triangle.centerOne
+    rw [Triangle.generatorOne_fix] at h
+    exact h.symm
+  · apply (modularI_fixed_iff _).mp
+    apply UpperHalfPlane.ext
+    rw [← modularIAction_coe]
+    have h := hτ.2 Triangle.centerTwo
+    rw [Triangle.generatorTwo_fix] at h
+    exact h.symm
+
+private theorem SpecialPeriods.ModularGermLift.enat_eq_nat_of_mul_eq_mo1973_17094 {x : ℕ∞}
+    {m n : ℕ} (hm : 0 < m) (h : (m : ℕ∞) * x = (m * n : ℕ)) : x = n := by
+  have hm0 : (m : ℕ∞) ≠ 0 := by exact_mod_cast hm.ne'
+  have hfin : x ≠ ⊤ := by
+    intro hx
+    rw [hx, ENat.mul_top hm0] at h
+    exact ENat.top_ne_natCast _ h
+  obtain ⟨k, hk⟩ := ENat.ne_top_iff_exists.mp hfin
+  rw [← hk] at h
+  have hkn : k = n := by
+    have hmul : m * k = m * n := by exact_mod_cast h
+    exact Nat.eq_of_mul_eq_mul_left hm hmul
+  rw [← hk, hkn]
+
+private theorem SpecialPeriods.ModularGermLift.modularJ_lift_order_mul {F τ : ℂ → ℂ} {a : ℂ}
+    (hτ : AnalyticAt ℂ τ a) (hpos : 0 < (τ a).im)
+    (hJ : (fun z => SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (τ z))) =ᶠ[𝓝 a] F) :
+    analyticOrderAt F a =
+      analyticOrderAt (SpecialPeriods.modularJ ∘ UpperHalfPlane.ofComplex) (τ a) *
+        analyticOrderAt (fun z => τ z - τ a) a := by
+  have hj : AnalyticAt ℂ (SpecialPeriods.modularJ ∘ UpperHalfPlane.ofComplex) (τ a) := by
+    simpa only [UpperHalfPlane.ofComplex_apply_of_im_pos hpos] using
+      SpecialPeriods.modularJ_analyticAt (UpperHalfPlane.ofComplex (τ a))
+  exact (analyticOrderAt_congr hJ).symm.trans (hj.analyticOrderAt_comp hτ)
+
+private theorem
+    SpecialPeriods.ModularGermLift.modularJ_lift_sub_1728_order_mul {F τ : ℂ → ℂ} {a : ℂ}
+    (hτ : AnalyticAt ℂ τ a) (hpos : 0 < (τ a).im)
+    (hJ : (fun z => SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (τ z))) =ᶠ[𝓝 a] F) :
+    analyticOrderAt (fun z => F z - 1728) a =
+      analyticOrderAt (fun z => SpecialPeriods.modularJ (UpperHalfPlane.ofComplex z) - 1728)
+          (τ a) *
+        analyticOrderAt (fun z => τ z - τ a) a := by
+  have hjbase : AnalyticAt ℂ (SpecialPeriods.modularJ ∘ UpperHalfPlane.ofComplex) (τ a) := by
+    simpa only [UpperHalfPlane.ofComplex_apply_of_im_pos hpos] using
+      SpecialPeriods.modularJ_analyticAt (UpperHalfPlane.ofComplex (τ a))
+  have hj :
+    AnalyticAt ℂ (fun z => SpecialPeriods.modularJ (UpperHalfPlane.ofComplex z) - 1728) (τ a) :=
+    hjbase.sub analyticAt_const
+  have he :
+    (fun z => SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (τ z)) - 1728) =ᶠ[𝓝 a]
+      (fun z => F z - 1728) :=
+    hJ.sub (Filter.EventuallyEq.rfl)
+  exact (analyticOrderAt_congr he).symm.trans (hj.analyticOrderAt_comp hτ)
+
+private theorem
+    SpecialPeriods.ModularGermLift.modularJ_lift_order_of_zero {F τ : ℂ → ℂ} {a : ℂ} {n : ℕ}
+    (hτ : AnalyticAt ℂ τ a) (hpos : 0 < (τ a).im)
+    (hJ : (fun z => SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (τ z))) =ᶠ[𝓝 a] F)
+    (ha : F a = 0) (horder : analyticOrderAt F a = (3 * n : ℕ)) :
+    analyticOrderAt (fun z => τ z - τ a) a = n := by
+  have hj0 : SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (τ a)) = 0 :=
+    hJ.self_of_nhds.trans ha
+  have hjord : analyticOrderAt (SpecialPeriods.modularJ ∘ UpperHalfPlane.ofComplex) (τ a) = 3 := by
+    simpa only [UpperHalfPlane.ofComplex_apply_of_im_pos hpos] using
+      SpecialPeriods.analyticOrderAt_modularJ_of_eq_zero (UpperHalfPlane.ofComplex (τ a)) hj0
+  have hmul := modularJ_lift_order_mul hτ hpos hJ
+  rw [horder, hjord] at hmul
+  exact enat_eq_nat_of_mul_eq_mo1973_17094 (by decide : 0 < 3) hmul.symm
+
+private theorem
+    SpecialPeriods.ModularGermLift.modularJ_lift_order_of_1728 {F τ : ℂ → ℂ} {a : ℂ} {n : ℕ}
+    (hτ : AnalyticAt ℂ τ a) (hpos : 0 < (τ a).im)
+    (hJ : (fun z => SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (τ z))) =ᶠ[𝓝 a] F)
+    (ha : F a = 1728) (horder : analyticOrderAt (fun z => F z - 1728) a = (2 * n : ℕ)) :
+    analyticOrderAt (fun z => τ z - τ a) a = n := by
+  have hj1728 : SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (τ a)) = 1728 :=
+    hJ.self_of_nhds.trans ha
+  have hjord :
+    analyticOrderAt (fun z => SpecialPeriods.modularJ (UpperHalfPlane.ofComplex z) - 1728) (τ a) =
+      2 := by
+    simpa only [UpperHalfPlane.ofComplex_apply_of_im_pos hpos] using
+      SpecialPeriods.analyticOrderAt_modularJ_sub_1728_of_eq (UpperHalfPlane.ofComplex (τ a))
+        hj1728
+  have hmul := modularJ_lift_sub_1728_order_mul hτ hpos hJ
+  rw [horder, hjord] at hmul
+  exact enat_eq_nat_of_mul_eq_mo1973_17094 (by decide : 0 < 2) hmul.symm
+
+private theorem SpecialPeriods.ModularGermLift.E₄_lift_order_of_zero {τ : ℂ → ℂ} {a : ℂ}
+    (hτ : AnalyticAt ℂ τ a) (hpos : 0 < (τ a).im)
+    (ha : ModularForm.E₄ (UpperHalfPlane.ofComplex (τ a)) = 0) :
+    analyticOrderAt (fun z => ModularForm.E₄ (UpperHalfPlane.ofComplex (τ z))) a =
+      analyticOrderAt (fun z => τ z - τ a) a := by
+  have hE : AnalyticAt ℂ (ModularForm.E₄ ∘ UpperHalfPlane.ofComplex) (τ a) := by
+    simpa only [UpperHalfPlane.ofComplex_apply_of_im_pos hpos] using
+      SpecialPeriods.modularForm_analyticAt ModularForm.E₄ (UpperHalfPlane.ofComplex (τ a))
+  have ho : analyticOrderAt (ModularForm.E₄ ∘ UpperHalfPlane.ofComplex) (τ a) = 1 := by
+    simpa only [UpperHalfPlane.ofComplex_apply_of_im_pos hpos] using
+      SpecialPeriods.analyticOrderAt_E₄_of_eq_zero (UpperHalfPlane.ofComplex (τ a)) ha
+  calc
+    analyticOrderAt (fun z => ModularForm.E₄ (UpperHalfPlane.ofComplex (τ z))) a =
+        analyticOrderAt (ModularForm.E₄ ∘ UpperHalfPlane.ofComplex) (τ a) *
+          analyticOrderAt (fun z => τ z - τ a) a :=
+      hE.analyticOrderAt_comp hτ
+    _ = analyticOrderAt (fun z => τ z - τ a) a := by rw [ho, one_mul]
+
+private theorem SpecialPeriods.ModularGermLift.E₆_lift_order_of_zero {τ : ℂ → ℂ} {a : ℂ}
+    (hτ : AnalyticAt ℂ τ a) (hpos : 0 < (τ a).im)
+    (ha : ModularForm.E₆ (UpperHalfPlane.ofComplex (τ a)) = 0) :
+    analyticOrderAt (fun z => ModularForm.E₆ (UpperHalfPlane.ofComplex (τ z))) a =
+      analyticOrderAt (fun z => τ z - τ a) a := by
+  have hE : AnalyticAt ℂ (ModularForm.E₆ ∘ UpperHalfPlane.ofComplex) (τ a) := by
+    simpa only [UpperHalfPlane.ofComplex_apply_of_im_pos hpos] using
+      SpecialPeriods.modularForm_analyticAt ModularForm.E₆ (UpperHalfPlane.ofComplex (τ a))
+  have ho : analyticOrderAt (ModularForm.E₆ ∘ UpperHalfPlane.ofComplex) (τ a) = 1 := by
+    simpa only [UpperHalfPlane.ofComplex_apply_of_im_pos hpos] using
+      SpecialPeriods.analyticOrderAt_E₆_of_eq_zero (UpperHalfPlane.ofComplex (τ a)) ha
+  calc
+    analyticOrderAt (fun z => ModularForm.E₆ (UpperHalfPlane.ofComplex (τ z))) a =
+        analyticOrderAt (ModularForm.E₆ ∘ UpperHalfPlane.ofComplex) (τ a) *
+          analyticOrderAt (fun z => τ z - τ a) a :=
+      hE.analyticOrderAt_comp hτ
+    _ = analyticOrderAt (fun z => τ z - τ a) a := by rw [ho, one_mul]
+
+private theorem SpecialPeriods.ModularGermLift.analyticAt_upperHalfPlane_lift {τ : ℍ → ℍ}
+    (hτ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) τ) (a : ℍ) :
+    AnalyticAt ℂ (fun z => (τ (UpperHalfPlane.ofComplex z) : ℂ)) (a : ℂ) :=
+  (UpperHalfPlane.mdifferentiable_iff.mp (UpperHalfPlane.mdifferentiable_coe.comp hτ)).analyticAt
+    (UpperHalfPlane.isOpen_upperHalfPlaneSet.mem_nhds a.im_pos)
+
+private theorem
+    SpecialPeriods.ModularGermLift.native_modular_equation_eventually {τ : ℍ → ℍ} {F : ℍ → ℂ}
+    (hJ : ∀ a : ℍ, SpecialPeriods.modularJ (τ a) = F a) (a : ℍ) :
+    (fun z : ℂ =>
+        SpecialPeriods.modularJ
+          (UpperHalfPlane.ofComplex (τ (UpperHalfPlane.ofComplex z)))) =ᶠ[𝓝 (a : ℂ)]
+      (F ∘ UpperHalfPlane.ofComplex) := by
+  filter_upwards with z
+  simpa only [UpperHalfPlane.ofComplex_apply, Function.comp_apply] using
+    hJ (UpperHalfPlane.ofComplex z)
+
+private theorem
+    SpecialPeriods.ModularGermLift.native_modularJ_lift_order_of_zero {τ : ℍ → ℍ} {F : ℍ → ℂ}
+    (hτ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) τ) (hJ : ∀ a : ℍ, SpecialPeriods.modularJ (τ a) = F a) {a : ℍ}
+    {n : ℕ} (ha : F a = 0)
+    (horder : analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (a : ℂ) = (3 * n : ℕ)) :
+    analyticOrderAt (fun z : ℂ => (τ (UpperHalfPlane.ofComplex z) : ℂ) - (τ a : ℂ)) (a : ℂ) = n :=
+  by
+  simpa only [UpperHalfPlane.ofComplex_apply] using
+    modularJ_lift_order_of_zero (analyticAt_upperHalfPlane_lift hτ a)
+      (by simpa only [UpperHalfPlane.ofComplex_apply, UpperHalfPlane.coe_im] using (τ a).im_pos)
+      (native_modular_equation_eventually hJ a)
+      (by simpa only [Function.comp_apply, UpperHalfPlane.ofComplex_apply] using ha) horder
+
+private theorem
+    SpecialPeriods.ModularGermLift.native_modularJ_lift_order_of_1728 {τ : ℍ → ℍ} {F : ℍ → ℂ}
+    (hτ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) τ) (hJ : ∀ a : ℍ, SpecialPeriods.modularJ (τ a) = F a) {a : ℍ}
+    {n : ℕ} (ha : F a = 1728)
+    (horder :
+      analyticOrderAt (fun z : ℂ => F (UpperHalfPlane.ofComplex z) - 1728) (a : ℂ) =
+        (2 * n : ℕ)) :
+    analyticOrderAt (fun z : ℂ => (τ (UpperHalfPlane.ofComplex z) : ℂ) - (τ a : ℂ)) (a : ℂ) = n :=
+  by
+  simpa only [UpperHalfPlane.ofComplex_apply] using
+    modularJ_lift_order_of_1728 (analyticAt_upperHalfPlane_lift hτ a)
+      (by simpa only [UpperHalfPlane.ofComplex_apply, UpperHalfPlane.coe_im] using (τ a).im_pos)
+      (native_modular_equation_eventually hJ a)
+      (by simpa only [Function.comp_apply, UpperHalfPlane.ofComplex_apply] using ha) horder
+
+private theorem SpecialPeriods.ModularGermLift.native_E₄_lift_order_of_zero {τ : ℍ → ℍ}
+    (hτ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) τ) {a : ℍ} (ha : ModularForm.E₄ (τ a) = 0) :
+    analyticOrderAt (fun z : ℂ => ModularForm.E₄ (τ (UpperHalfPlane.ofComplex z))) (a : ℂ) =
+      analyticOrderAt (fun z : ℂ => (τ (UpperHalfPlane.ofComplex z) : ℂ) - (τ a : ℂ)) (a : ℂ) := by
+  simpa only [UpperHalfPlane.ofComplex_apply] using
+    E₄_lift_order_of_zero (analyticAt_upperHalfPlane_lift hτ a)
+      (by simpa only [UpperHalfPlane.ofComplex_apply, UpperHalfPlane.coe_im] using (τ a).im_pos)
+      (by simpa only [UpperHalfPlane.ofComplex_apply] using ha)
+
+private theorem SpecialPeriods.ModularGermLift.native_E₆_lift_order_of_zero {τ : ℍ → ℍ}
+    (hτ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) τ) {a : ℍ} (ha : ModularForm.E₆ (τ a) = 0) :
+    analyticOrderAt (fun z : ℂ => ModularForm.E₆ (τ (UpperHalfPlane.ofComplex z))) (a : ℂ) =
+      analyticOrderAt (fun z : ℂ => (τ (UpperHalfPlane.ofComplex z) : ℂ) - (τ a : ℂ)) (a : ℂ) := by
+  simpa only [UpperHalfPlane.ofComplex_apply] using
+    E₆_lift_order_of_zero (analyticAt_upperHalfPlane_lift hτ a)
+      (by simpa only [UpperHalfPlane.ofComplex_apply, UpperHalfPlane.coe_im] using (τ a).im_pos)
+      (by simpa only [UpperHalfPlane.ofComplex_apply] using ha)
+
+private theorem
+    SpecialPeriods.ModularGermLift.native_E₆_order_of_source_order {τ : ℍ → ℍ} {F : ℍ → ℂ}
+    (hτ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) τ) (hJ : ∀ a : ℍ, SpecialPeriods.modularJ (τ a) = F a) {a : ℍ}
+    {n : ℕ} (ha : F a = 1728)
+    (horder :
+      analyticOrderAt (fun z : ℂ => F (UpperHalfPlane.ofComplex z) - 1728) (a : ℂ) =
+        (2 * n : ℕ)) :
+    analyticOrderAt (fun z : ℂ => ModularForm.E₆ (τ (UpperHalfPlane.ofComplex z))) (a : ℂ) = n := by
+  have hE : ModularForm.E₆ (τ a) = 0 :=
+    (SpecialPeriods.modularJ_eq_1728_iff (τ a)).mp ((hJ a).trans ha)
+  exact
+    (native_E₆_lift_order_of_zero hτ hE).trans
+      (native_modularJ_lift_order_of_1728 hτ hJ ha horder)
+
+private theorem SpecialPeriods.ModularGermLift.native_E₆_order_of_source_four_order {τ : ℍ → ℍ}
+    {F : ℍ → ℂ} (hτ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) τ)
+    (hJ : ∀ a : ℍ, SpecialPeriods.modularJ (τ a) = F a) {a : ℍ} {k : ℕ} (ha : F a = 1728)
+    (horder :
+      analyticOrderAt (fun z : ℂ => F (UpperHalfPlane.ofComplex z) - 1728) (a : ℂ) =
+        (4 * k : ℕ)) :
+    analyticOrderAt (fun z : ℂ => ModularForm.E₆ (τ (UpperHalfPlane.ofComplex z))) (a : ℂ) =
+      (2 * k : ℕ) := by
+  apply native_E₆_order_of_source_order hτ hJ ha
+  simpa only [← Nat.mul_assoc] using horder
+
+private theorem SpecialPeriods.ModularGermLift.native_E₆_finite_even_zeros {τ : ℍ → ℍ} {F : ℍ → ℂ}
+    (hτ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) τ) (hJ : ∀ a : ℍ, SpecialPeriods.modularJ (τ a) = F a)
+    (hsource :
+      ∀ a : ℍ,
+        F a = 1728 →
+          ∃ k : ℕ,
+            analyticOrderAt (fun z : ℂ => F (UpperHalfPlane.ofComplex z) - 1728) (a : ℂ) =
+              (4 * k : ℕ)) :
+    ∀ a : ℍ,
+      ModularForm.E₆ (τ a) = 0 →
+        ∃ n : ℕ,
+          analyticOrderAt (fun z : ℂ => ModularForm.E₆ (τ (UpperHalfPlane.ofComplex z))) (a : ℂ) =
+            (2 * n : ℕ) := by
+  intro a ha
+  have hFa : F a = 1728 := (hJ a).symm.trans ((SpecialPeriods.modularJ_eq_1728_iff (τ a)).mpr ha)
+  obtain ⟨k, hk⟩ := hsource a hFa
+  exact ⟨k, native_E₆_order_of_source_four_order hτ hJ hFa hk⟩
+
+private theorem
+    SpecialPeriods.realSL_actions_eq_of_fixed_deriv (g h : SL(2, ℝ)) (a : ℍ) (hg : g • a = a)
+    (hh : h • a = a)
+    (hd :
+      deriv (fun z : ℂ => ((g • UpperHalfPlane.ofComplex z : ℍ) : ℂ)) (a : ℂ) =
+        deriv (fun z : ℂ => ((h • UpperHalfPlane.ofComplex z : ℍ) : ℂ)) (a : ℂ)) :
+    ∀ z : ℍ, g • z = h • z := by
+  have hm : Triangle.slMultiplier g a = Triangle.slMultiplier h a := by
+    simpa only [Triangle.sl_deriv_smul] using hd
+  intro z
+  apply (Triangle.cayleyBiholomorph a).injective
+  apply Subtype.ext
+  change Triangle.cayleyCoordinate a (g • z) = Triangle.cayleyCoordinate a (h • z)
+  rw [Triangle.cayleyCoordinate_smul g a z hg, Triangle.cayleyCoordinate_smul h a z hh, hm]
+
+private theorem SpecialPeriods.modularSL_actions_eq_of_fixed_deriv (g h : SL(2, ℤ)) (a : ℍ)
+    (hg : g • a = a) (hh : h • a = a)
+    (hd :
+      deriv (fun z : ℂ => ((g • UpperHalfPlane.ofComplex z : ℍ) : ℂ)) (a : ℂ) =
+        deriv (fun z : ℂ => ((h • UpperHalfPlane.ofComplex z : ℍ) : ℂ)) (a : ℂ)) :
+    ∀ z : ℍ, g • z = h • z := by
+  simpa only [integerSL_real_action] using
+    realSL_actions_eq_of_fixed_deriv (Matrix.SpecialLinearGroup.map (Int.castRingHom ℝ) g)
+      (Matrix.SpecialLinearGroup.map (Int.castRingHom ℝ) h) a
+      (by simpa only [integerSL_real_action] using hg)
+      (by simpa only [integerSL_real_action] using hh)
+      (by simpa only [integerSL_real_action] using hd)
+
+private theorem SpecialPeriods.modularSL_ambient_deriv_eq (g : SL(2, ℤ)) (f : ℂ → ℂ)
+    (hf : ∀ z : ℍ, f z = ((g • z : ℍ) : ℂ)) (a : ℍ) :
+    deriv (fun z : ℂ => ((g • UpperHalfPlane.ofComplex z : ℍ) : ℂ)) (a : ℂ) = deriv f (a : ℂ) := by
+  apply Filter.EventuallyEq.deriv_eq
+  have hpos : ∀ᶠ z : ℂ in 𝓝 (a : ℂ), 0 < z.im :=
+    UpperHalfPlane.isOpen_upperHalfPlaneSet.mem_nhds a.im_pos
+  filter_upwards [hpos] with z hz
+  simpa only [UpperHalfPlane.ofComplex_apply_of_im_pos hz] using
+    (hf (UpperHalfPlane.ofComplex z)).symm
+
+private theorem SpecialPeriods.modularRho_ambient_deriv :
+    deriv
+        (fun z : ℂ => (((ModularGroup.T * ModularGroup.S) • UpperHalfPlane.ofComplex z : ℍ) : ℂ))
+        (rhoPoint : ℂ) =
+      -rho :=
+  (modularSL_ambient_deriv_eq (ModularGroup.T * ModularGroup.S) modularRhoAction
+        modularRhoAction_coe rhoPoint).trans
+    modularRhoAction_deriv_rho
+
+private theorem
+    SpecialPeriods.modularJ_invariant_lift_action {τ : ℍ → ℍ} (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ)
+    (A : SL(2, ℝ)) (hJ : ∀ z : ℍ, modularJ (τ (A • z)) = modularJ (τ z)) (x : ℍ)
+    (hx : modularJ (τ x) ∈ modularRegularValues) : ∃ γ : SL(2, ℤ), ∀ z : ℍ, γ • τ z = τ (A • z) :=
+  by
+  exact
+    modularJ_equal_lifts_differ_by_SL hτ (hτ.comp (Triangle.specialLinear_holomorphic A))
+      (fun z => (hJ z).symm) x hx
+
+private theorem
+    SpecialPeriods.analytic_semiconjugacy_multiplier (τ A B : ℂ → ℂ) (a b ξ η : ℂ) (k : ℕ)
+    (hτ : AnalyticAt ℂ τ a) (hτa : τ a = b)
+    (horder : analyticOrderAt (fun z => τ z - b) a = (k : ℕ∞)) (hA : HasDerivAt A ξ a)
+    (hAa : A a = a) (hB : HasDerivAt B η b) (hBb : B b = b) (hsem : τ ∘ A =ᶠ[𝓝 a] B ∘ τ) :
+    η = ξ ^ k := by
+  obtain ⟨u, hu, hu0, hfactor⟩ := (hτ.sub analyticAt_const).analyticOrderAt_eq_natCast.mp horder
+  have hf : ∀ᶠ z in 𝓝 a, τ z - b = (z - a) ^ k * u z := by
+    simpa only [Pi.sub_apply, smul_eq_mul] using hfactor
+  have hAt : Filter.Tendsto A (𝓝 a) (𝓝 a) := by
+    simpa only [ContinuousAt, hAa] using hA.continuousAt
+  have hfA : ∀ᶠ z in 𝓝 a, τ (A z) - b = (A z - a) ^ k * u (A z) := hAt.eventually hf
+  have he : (fun z => dslope A a z ^ k * u (A z)) =ᶠ[𝓝[≠] a] (fun z => u z * dslope B b (τ z)) := by
+    filter_upwards [hf.filter_mono nhdsWithin_le_nhds, hfA.filter_mono nhdsWithin_le_nhds,
+      hsem.filter_mono nhdsWithin_le_nhds, self_mem_nhdsWithin] with z hfz hfAz hsemz hza
+    have hAz : A z - a = (z - a) * dslope A a z := by
+      simpa only [smul_eq_mul, hAa] using (sub_smul_dslope A a z).symm
+    have hBz : B (τ z) - b = (τ z - b) * dslope B b (τ z) := by
+      simpa only [smul_eq_mul, hBb] using (sub_smul_dslope B b (τ z)).symm
+    apply mul_left_cancel₀ (pow_ne_zero k (sub_ne_zero.mpr hza))
+    calc
+      (z - a) ^ k * (dslope A a z ^ k * u (A z)) = ((z - a) * dslope A a z) ^ k * u (A z) := by
+        rw [mul_pow, mul_assoc]
+      _ = (A z - a) ^ k * u (A z) := by rw [← hAz]
+      _ = τ (A z) - b := hfAz.symm
+      _ = B (τ z) - b := (congrArg (fun w => w - b) hsemz)
+      _ = (τ z - b) * dslope B b (τ z) := hBz
+      _ = (z - a) ^ k * (u z * dslope B b (τ z)) := by rw [hfz, mul_assoc]
+  have hcL : ContinuousAt (fun z => dslope A a z ^ k * u (A z)) a :=
+    ((continuousAt_dslope_same.mpr hA.differentiableAt).pow k).mul
+      (hu.continuousAt.comp_of_eq hA.continuousAt hAa)
+  have hcR : ContinuousAt (fun z => u z * dslope B b (τ z)) a :=
+    hu.continuousAt.mul
+      ((continuousAt_dslope_same.mpr hB.differentiableAt).comp_of_eq hτ.continuousAt hτa)
+  have hcenter :=
+    tendsto_nhds_unique_of_eventuallyEq hcL.continuousWithinAt hcR.continuousWithinAt he
+  have hcoeff : ξ ^ k * u a = u a * η := by
+    simpa only [hAa, hτa, dslope_same, hA.deriv, hB.deriv] using hcenter
+  apply mul_right_cancel₀ hu0
+  rw [mul_comm η (u a)]
+  exact hcoeff.symm
+
+private theorem SpecialPeriods.analytic_semiconjugacy_deriv_pow (τ A B : ℂ → ℂ) (a b : ℂ) (k : ℕ)
+    (hτ : AnalyticAt ℂ τ a) (hτa : τ a = b)
+    (horder : analyticOrderAt (fun z => τ z - b) a = (k : ℕ∞)) (hA : AnalyticAt ℂ A a)
+    (hAa : A a = a) (hB : AnalyticAt ℂ B b) (hBb : B b = b) (hsem : τ ∘ A =ᶠ[𝓝 a] B ∘ τ) :
+    deriv B b = deriv A a ^ k :=
+  analytic_semiconjugacy_multiplier τ A B a b (deriv A a) (deriv B b) k hτ hτa horder
+    hA.differentiableAt.hasDerivAt hAa hB.differentiableAt.hasDerivAt hBb hsem
+
+private theorem SpecialPeriods.tau_covariant_triangle_action {τ : ℍ → ℍ} (hτ : TauCovariant τ)
+    (g : TriangleGroup) (z : ℍ) :
+    τ (triangleGeometricRepresentation g z) = triangleModularAction g (τ z) := by
+  let H :=
+    TauEquivariance.intertwiningSubgroup triangleGeometricRepresentation triangleModularAction τ
+  have hgen : ({ triangleGenerator₁, triangleGenerator₂ } : Set TriangleGroup) ⊆ H := by
+    intro h hh
+    rcases Set.mem_insert_iff.mp hh with rfl | hh
+    · intro x
+      apply UpperHalfPlane.ext
+      rw [triangleGeometricRepresentation_generator₁_apply, triangleModularAction_generator₁_coe]
+      exact hτ.1 x
+    · have he : h = triangleGenerator₂ := Set.mem_singleton_iff.mp hh
+      subst h
+      intro x
+      apply UpperHalfPlane.ext
+      rw [triangleGeometricRepresentation_generator₂_apply, triangleModularAction_generator₂_coe]
+      exact hτ.2 x
+  have htop : (⊤ : Subgroup TriangleGroup) ≤ H := by
+    rw [← triangle_generators_generate]
+    exact (Subgroup.closure_le _).mpr hgen
+  exact htop (Subgroup.mem_top g) z
+
+private theorem SpecialPeriods.tau_covariant_cusp {τ : ℍ → ℍ} (hτ : TauCovariant τ) (z : ℍ) :
+    τ (triangleGeometricRepresentation triangleCuspGenerator z) = (-1 : ℝ) +ᵥ τ z := by
+  rw [tau_covariant_triangle_action hτ, triangleModularAction_cusp_apply]
+
+private theorem SpecialPeriods.tau_covariant_cusp_coe {τ : ℍ → ℍ} (hτ : TauCovariant τ) (z : ℍ) :
+    (τ (triangleGeometricRepresentation triangleCuspGenerator z) : ℂ) = (τ z : ℂ) - 1 := by
+  rw [tau_covariant_triangle_action hτ, triangleModularAction_cusp_coe]
+
+private theorem
+    SpecialPeriods.modular_lift_action_of_order {τ : ℍ → ℍ} (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ)
+    (A : SL(2, ℝ)) (a : ℍ) (hAa : A • a = a) (k : ℕ)
+    (horder :
+      analyticOrderAt (fun z : ℂ => (τ (UpperHalfPlane.ofComplex z) : ℂ) - (τ a : ℂ)) (a : ℂ) =
+        (k : ℕ∞))
+    (B : SL(2, ℤ)) (hBb : B • τ a = τ a)
+    (hBderiv :
+      deriv (fun z : ℂ => ((B • UpperHalfPlane.ofComplex z : ℍ) : ℂ)) (τ a : ℂ) =
+        Triangle.slMultiplier A a ^ k)
+    (hJ : ∀ z : ℍ, modularJ (τ (A • z)) = modularJ (τ z)) (x : ℍ)
+    (hx : modularJ (τ x) ∈ modularRegularValues) : ∀ z : ℍ, τ (A • z) = B • τ z := by
+  obtain ⟨γ, hγ⟩ := modularJ_invariant_lift_action hτ A hJ x hx
+  have hγfix : γ • τ a = τ a := by simpa only [hAa] using hγ a
+  let t : ℂ → ℂ := fun z => (τ (UpperHalfPlane.ofComplex z) : ℂ)
+  let α : ℂ → ℂ := fun z => ((A • UpperHalfPlane.ofComplex z : ℍ) : ℂ)
+  let β : ℂ → ℂ := fun z => ((γ • UpperHalfPlane.ofComplex z : ℍ) : ℂ)
+  have ht : AnalyticAt ℂ t (a : ℂ) :=
+    ModularGermLift.analyticAt_upperHalfPlane_lift (hτ.mdifferentiable (by simp)) a
+  have hα : AnalyticAt ℂ α (a : ℂ) :=
+    ModularGermLift.analyticAt_upperHalfPlane_lift
+      ((Triangle.specialLinear_holomorphic A).mdifferentiable (by simp)) a
+  have hβ : AnalyticAt ℂ β (τ a : ℂ) :=
+    ModularGermLift.analyticAt_upperHalfPlane_lift
+      ((modularSL_holomorphic γ).mdifferentiable (by simp)) (τ a)
+  have ht₀ : t (a : ℂ) = (τ a : ℂ) := by simp only [t, UpperHalfPlane.ofComplex_apply]
+  have hα₀ : α (a : ℂ) = (a : ℂ) := by simp only [α, UpperHalfPlane.ofComplex_apply, hAa]
+  have hβ₀ : β (τ a : ℂ) = (τ a : ℂ) := by simp only [β, UpperHalfPlane.ofComplex_apply, hγfix]
+  have hsem : t ∘ α =ᶠ[𝓝 (a : ℂ)] β ∘ t := by
+    filter_upwards with w
+    simpa only [t, α, β, Function.comp_apply, UpperHalfPlane.ofComplex_apply] using
+      (congrArg (fun z : ℍ => (z : ℂ)) (hγ (UpperHalfPlane.ofComplex w))).symm
+  have hm :=
+    analytic_semiconjugacy_deriv_pow t α β (a : ℂ) (τ a : ℂ) k ht ht₀ horder hα hα₀ hβ hβ₀ hsem
+  have hderiv :
+    deriv (fun z : ℂ => ((γ • UpperHalfPlane.ofComplex z : ℍ) : ℂ)) (τ a : ℂ) =
+      Triangle.slMultiplier A a ^ k := by simpa only [α, β, Triangle.sl_deriv_smul] using hm
+  have he := modularSL_actions_eq_of_fixed_deriv γ B (τ a) hγfix hBb (hderiv.trans hBderiv.symm)
+  intro z
+  exact (hγ z).symm.trans (he (τ z))
+
+private theorem
+    SpecialPeriods.exists_regular_modular_value_of_j_values {X : Type*} [TopologicalSpace X]
+    [PreconnectedSpace X] {τ : X → ℍ} (hτ : Continuous τ) (a b : X) (ha : modularJ (τ a) = 0)
+    (hb : modularJ (τ b) = 1728) : ∃ x, modularJ (τ x) ∈ modularRegularValues := by
+  let F : X → ℝ := fun x => (modularJ (τ x)).re
+  have hF : Continuous F := Complex.continuous_re.comp (modularJ_continuous.comp hτ)
+  have hmid : (864 : ℝ) ∈ Set.Icc (F a) (F b) := by norm_num [F, ha, hb]
+  obtain ⟨x, hx⟩ := intermediate_value_univ a b hF hmid
+  refine ⟨x, (mem_modularRegularValues _).mpr ⟨?_, ?_⟩⟩
+  · intro hz
+    have hh : F x = 0 := by simp [F, hz]
+    linarith
+  · intro hz
+    have hh : F x = 1728 := by norm_num [F, hz]
+    linarith
+
+private theorem SpecialPeriods.modular_lift_first_generator_of_rho_order {τ : ℍ → ℍ}
+    (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (ha : τ Triangle.centerOne = rhoPoint)
+    (horder :
+      analyticOrderAt (fun z : ℂ => (τ (UpperHalfPlane.ofComplex z) : ℂ) - rho)
+          (Triangle.centerOne : ℂ) =
+        1)
+    (hJ : ∀ z : ℍ, modularJ (τ (Triangle.generatorOneSL • z)) = modularJ (τ z)) (x : ℍ)
+    (hx : modularJ (τ x) ∈ modularRegularValues) :
+    ∀ z : ℍ, τ (Triangle.generatorOneSL • z) = triangleModularA • τ z := by
+  rw [triangleModularA_eq_T_mul_S]
+  exact
+    modular_lift_action_of_order hτ Triangle.generatorOneSL Triangle.centerOne
+      Triangle.generatorOne_fix 1 (by simpa [ha] using horder) (ModularGroup.T * ModularGroup.S)
+      (by rw [ha]; exact TS_smul_rhoPoint)
+      (by rw [ha, modularRho_ambient_deriv, Triangle.generatorOne_multiplier, pow_one]) hJ x hx
+
+private theorem
+    SpecialPeriods.modularSL_actions_eq_of_two_values (B C : SL(2, ℤ)) (a b : ℍ) (hab : a ≠ b)
+    (ha : B • a = C • a) (hb : B • b = C • b) : ∀ z : ℍ, B • z = C • z := by
+  have ha' : (C⁻¹ * B) • a = a := by rw [SemigroupAction.mul_smul, ha, inv_smul_smul]
+  have hb' : (C⁻¹ * B) • b = b := by rw [SemigroupAction.mul_smul, hb, inv_smul_smul]
+  have h := modularSL_action_identity_of_two_fixed (C⁻¹ * B) ha' hb' hab
+  intro z
+  simpa only [SemigroupAction.mul_smul, smul_inv_smul] using congrArg (fun w : ℍ => C • w) (h z)
+
+private theorem SpecialPeriods.modular_lift_product_cusp_action {τ : ℍ → ℍ} (B : SL(2, ℤ))
+    (hA : ∀ z : ℍ, τ (Triangle.generatorOneSL • z) = triangleModularA • τ z)
+    (hB : ∀ z : ℍ, B • τ z = τ (Triangle.generatorTwoSL • z)) :
+    ∀ z : ℍ, (triangleModularA * B)⁻¹ • τ z = τ (Triangle.cuspSL • z) := by
+  intro z
+  rw [inv_smul_eq_iff, SemigroupAction.mul_smul, hB, ← hA, ← SemigroupAction.mul_smul, ←
+    SemigroupAction.mul_smul, Triangle.generatorOneSL_mul_generatorTwoSL_mul_cuspSL, one_smul]
+
+private theorem SpecialPeriods.modular_lift_cusp_monodromy_comparison {τ : ℍ → ℍ} (B C : SL(2, ℤ))
+    (hA : ∀ z : ℍ, τ (Triangle.generatorOneSL • z) = triangleModularA • τ z)
+    (hB : ∀ z : ℍ, B • τ z = τ (Triangle.generatorTwoSL • z))
+    (hC : ∀ z : ℍ, τ (Triangle.cuspSL • z) = C • τ z) (a b : ℍ) (hab : τ a ≠ τ b) :
+    ∀ z : ℍ, (triangleModularA * B)⁻¹ • z = C • z := by
+  have hp := modular_lift_product_cusp_action B hA hB
+  exact
+    modularSL_actions_eq_of_two_values _ _ (τ a) (τ b) hab ((hp a).trans (hC a))
+      ((hp b).trans (hC b))
+
+private theorem SpecialPeriods.modular_lift_cusp_monodromy_conjugate {τ : ℍ → ℍ} (γ C : SL(2, ℤ))
+    (hC : ∀ z : ℍ, τ (Triangle.cuspSL • z) = C • τ z) :
+    ∀ z : ℍ, γ • τ (Triangle.cuspSL • z) = (γ * C * γ⁻¹) • (γ • τ z) := by
+  intro z
+  rw [hC, SemigroupAction.mul_smul, SemigroupAction.mul_smul, inv_smul_smul]
+
+private theorem SpecialPeriods.modular_lift_monodromy_fixes_image {τ : ℍ → ℍ} (A : SL(2, ℝ)) (a : ℍ)
+    (hAa : A • a = a) (γ : SL(2, ℤ)) (hγ : ∀ z : ℍ, γ • τ z = τ (A • z)) : γ • τ a = τ a := by
+  simpa only [hAa] using hγ a
+
+private theorem SpecialPeriods.modular_lift_monodromy_deriv_of_order {τ : ℍ → ℍ}
+    (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (A : SL(2, ℝ)) (a : ℍ) (hAa : A • a = a) (k : ℕ)
+    (horder :
+      analyticOrderAt (fun z : ℂ => (τ (UpperHalfPlane.ofComplex z) : ℂ) - (τ a : ℂ)) (a : ℂ) =
+        (k : ℕ∞))
+    (γ : SL(2, ℤ)) (hγ : ∀ z : ℍ, γ • τ z = τ (A • z)) :
+    deriv (fun w : ℂ => ((γ • UpperHalfPlane.ofComplex w : ℍ) : ℂ)) (τ a : ℂ) =
+      Triangle.slMultiplier A a ^ k := by
+  have hγfix := modular_lift_monodromy_fixes_image A a hAa γ hγ
+  let t : ℂ → ℂ := fun z => (τ (UpperHalfPlane.ofComplex z) : ℂ)
+  let α : ℂ → ℂ := fun z => ((A • UpperHalfPlane.ofComplex z : ℍ) : ℂ)
+  let β : ℂ → ℂ := fun z => ((γ • UpperHalfPlane.ofComplex z : ℍ) : ℂ)
+  have ht : AnalyticAt ℂ t (a : ℂ) :=
+    ModularGermLift.analyticAt_upperHalfPlane_lift (hτ.mdifferentiable (by simp)) a
+  have hα : AnalyticAt ℂ α (a : ℂ) :=
+    ModularGermLift.analyticAt_upperHalfPlane_lift
+      ((Triangle.specialLinear_holomorphic A).mdifferentiable (by simp)) a
+  have hβ : AnalyticAt ℂ β (τ a : ℂ) :=
+    ModularGermLift.analyticAt_upperHalfPlane_lift
+      ((modularSL_holomorphic γ).mdifferentiable (by simp)) (τ a)
+  have ht₀ : t (a : ℂ) = (τ a : ℂ) := by simp only [t, UpperHalfPlane.ofComplex_apply]
+  have hα₀ : α (a : ℂ) = (a : ℂ) := by simp only [α, UpperHalfPlane.ofComplex_apply, hAa]
+  have hβ₀ : β (τ a : ℂ) = (τ a : ℂ) := by simp only [β, UpperHalfPlane.ofComplex_apply, hγfix]
+  have hsem : t ∘ α =ᶠ[𝓝 (a : ℂ)] β ∘ t := by
+    filter_upwards with w
+    simpa only [t, α, β, Function.comp_apply, UpperHalfPlane.ofComplex_apply] using
+      (congrArg (fun z : ℍ => (z : ℂ)) (hγ (UpperHalfPlane.ofComplex w))).symm
+  have hm :=
+    analytic_semiconjugacy_deriv_pow t α β (a : ℂ) (τ a : ℂ) k ht ht₀ horder hα hα₀ hβ hβ₀ hsem
+  simpa only [α, β, Triangle.sl_deriv_smul] using hm
+
+private theorem SpecialPeriods.modular_lift_generatorTwo_monodromy_deriv {τ : ℍ → ℍ}
+    (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ)
+    (horder :
+      analyticOrderAt
+          (fun z : ℂ => (τ (UpperHalfPlane.ofComplex z) : ℂ) - (τ Triangle.centerTwo : ℂ))
+          (Triangle.centerTwo : ℂ) =
+        2)
+    (γ : SL(2, ℤ)) (hγ : ∀ z : ℍ, γ • τ z = τ (Triangle.generatorTwoSL • z)) :
+    deriv (fun w : ℂ => ((γ • UpperHalfPlane.ofComplex w : ℍ) : ℂ)) (τ Triangle.centerTwo : ℂ) =
+      -1 := by
+  simpa only [Triangle.generatorTwo_multiplier, neg_sq, Complex.I_sq] using
+    modular_lift_monodromy_deriv_of_order hτ Triangle.generatorTwoSL Triangle.centerTwo
+      Triangle.generatorTwo_fix 2 horder γ hγ
+
+private def SpecialPeriods.modularSCyclicConjugate (k : Fin 3) : SL(2, ℤ) :=
+  triangleModularA ^ (k : ℕ) * ModularGroup.S * (triangleModularA ^ (k : ℕ))⁻¹
+
+private theorem SpecialPeriods.modularSCyclicConjugate_zero_matrix :
+    (modularSCyclicConjugate 0 : Matrix (Fin 2) (Fin 2) ℤ) = !![0, -1; 1, 0] := by decide
+
+private theorem SpecialPeriods.modularSCyclicConjugate_one_matrix :
+    (modularSCyclicConjugate 1 : Matrix (Fin 2) (Fin 2) ℤ) = !![1, -2; 1, -1] := by decide
+
+private theorem SpecialPeriods.modularSCyclicConjugate_two_matrix :
+    (modularSCyclicConjugate 2 : Matrix (Fin 2) (Fin 2) ℤ) = !![1, -1; 2, -1] := by decide
+
+private theorem SpecialPeriods.triangleModularA_product_trace (B : SL(2, ℤ)) :
+    Matrix.trace (triangleModularA * B).val = B 0 0 + B 0 1 - B 1 0 := by
+  change Matrix.trace ((triangleModularA : Matrix (Fin 2) (Fin 2) ℤ) * B.val) = _
+  rw [Matrix.trace_fin_two]
+  simp [triangleModularA, Matrix.mul_apply, Fin.sum_univ_two]
+  ring
+
+private theorem SpecialPeriods.trace_zero_entry_one_one_mo1973_17146 (B : SL(2, ℤ))
+    (htr : Matrix.trace B.val = 0) : B 1 1 = -(B 0 0) := by
+  rw [Matrix.trace_fin_two] at htr
+  omega
+
+private theorem SpecialPeriods.modular_trace_zero_trace_neg_two_classification (B : SL(2, ℤ))
+    (htr : Matrix.trace B.val = 0) (hprod : Matrix.trace (triangleModularA * B).val = -2) :
+    ∃ k : Fin 3, B = modularSCyclicConjugate k := by
+  have h11 := trace_zero_entry_one_one_mo1973_17146 B htr
+  have hdet : -(B 0 0) ^ 2 - B 0 1 * B 1 0 = 1 := by
+    have hd : B 0 0 * B 1 1 - B 0 1 * B 1 0 = 1 :=
+      (Matrix.det_fin_two B.val).symm.trans B.property
+    rw [h11] at hd
+    nlinarith [hd]
+  rw [triangleModularA_product_trace] at hprod
+  rcases GlobalTauNormalization.trace_neg_two_triples (B 0 0) (B 0 1) (B 1 0) hdet hprod with
+    ⟨hp, hq, hr⟩ | ⟨hp, hq, hr⟩ | ⟨hp, hq, hr⟩
+  · refine ⟨0, Subtype.ext ?_⟩
+    rw [modularSCyclicConjugate_zero_matrix]
+    ext i j
+    fin_cases i <;> fin_cases j <;> simp [hp, hq, hr, h11]
+  · refine ⟨1, Subtype.ext ?_⟩
+    rw [modularSCyclicConjugate_one_matrix]
+    ext i j
+    fin_cases i <;> fin_cases j <;> simp [hp, hq, hr, h11]
+  · refine ⟨2, Subtype.ext ?_⟩
+    rw [modularSCyclicConjugate_two_matrix]
+    ext i j
+    fin_cases i <;> fin_cases j <;> simp [hp, hq, hr, h11]
+
+private theorem SpecialPeriods.modular_trace_zero_parabolic_pair_classification (B : SL(2, ℤ))
+    (htr : Matrix.trace B.val = 0)
+    (hprod :
+      Matrix.trace (triangleModularA * B).val = 2 ∨
+        Matrix.trace (triangleModularA * B).val = -2) :
+    ∃ k : Fin 3, B = modularSCyclicConjugate k ∨ B = -modularSCyclicConjugate k := by
+  rcases hprod with hprod | hprod
+  · have htr' : Matrix.trace (-B).val = 0 := by
+      change Matrix.trace (-B.val) = 0
+      rw [Matrix.trace_neg, htr, neg_zero]
+    have hprod' : Matrix.trace (triangleModularA * (-B)).val = -2 := by
+      rw [mul_neg]
+      change Matrix.trace (-(triangleModularA * B).val) = -2
+      rw [Matrix.trace_neg, hprod]
+    obtain ⟨k, hk⟩ := modular_trace_zero_trace_neg_two_classification (-B) htr' hprod'
+    refine ⟨k, Or.inr ?_⟩
+    simpa only [neg_neg] using congrArg (fun C : SL(2, ℤ) => -C) hk
+  · obtain ⟨k, hk⟩ := modular_trace_zero_trace_neg_two_classification B htr hprod
+    exact ⟨k, Or.inl hk⟩
+
+private def SpecialPeriods.modularCyclicNormalizer (k : Fin 3) : SL(2, ℤ) :=
+  (triangleModularA ^ (k : ℕ))⁻¹
+
+private theorem SpecialPeriods.modularCyclicNormalizer_conjugate_A (k : Fin 3) :
+    modularCyclicNormalizer k * triangleModularA * (modularCyclicNormalizer k)⁻¹ =
+      triangleModularA := by fin_cases k <;> decide
+
+private theorem SpecialPeriods.modularCyclicNormalizer_conjugate_S (k : Fin 3) :
+    modularCyclicNormalizer k * modularSCyclicConjugate k * (modularCyclicNormalizer k)⁻¹ =
+      ModularGroup.S := by simp [modularCyclicNormalizer, modularSCyclicConjugate, mul_assoc]
+
+private theorem SpecialPeriods.modular_pair_signed_conjugation_normalization (B : SL(2, ℤ))
+    (htr : Matrix.trace B.val = 0)
+    (hprod :
+      Matrix.trace (triangleModularA * B).val = 2 ∨
+        Matrix.trace (triangleModularA * B).val = -2) :
+    ∃ k : Fin 3,
+      modularCyclicNormalizer k * B * (modularCyclicNormalizer k)⁻¹ = ModularGroup.S ∨
+        modularCyclicNormalizer k * B * (modularCyclicNormalizer k)⁻¹ = -ModularGroup.S := by
+  obtain ⟨k, hk | hk⟩ := modular_trace_zero_parabolic_pair_classification B htr hprod
+  · refine ⟨k, Or.inl ?_⟩
+    rw [hk]
+    exact modularCyclicNormalizer_conjugate_S k
+  · refine ⟨k, Or.inr ?_⟩
+    rw [hk, mul_neg, neg_mul, modularCyclicNormalizer_conjugate_S]
+
+private theorem SpecialPeriods.modular_pair_projective_conjugation_normalization (B : SL(2, ℤ))
+    (htr : Matrix.trace B.val = 0)
+    (hprod :
+      Matrix.trace (triangleModularA * B).val = 2 ∨
+        Matrix.trace (triangleModularA * B).val = -2) :
+    ∃ k : Fin 3,
+      modularProjectivization (modularCyclicNormalizer k * B * (modularCyclicNormalizer k)⁻¹) =
+        modularProjectivization ModularGroup.S := by
+  obtain ⟨k, hk | hk⟩ := modular_pair_signed_conjugation_normalization B htr hprod
+  · exact ⟨k, congrArg modularProjectivization hk⟩
+  · exact
+      ⟨k,
+        (congrArg modularProjectivization hk).trans (modularProjectivization_neg ModularGroup.S)⟩
+
+private theorem
+    SpecialPeriods.triangleModularA_smul_rhoPoint : triangleModularA • rhoPoint = rhoPoint := by
+  rw [triangleModularA_eq_T_mul_S]
+  exact TS_smul_rhoPoint
+
+private theorem SpecialPeriods.triangleModularA_pow_smul_rhoPoint (n : ℕ) :
+    triangleModularA ^ n • rhoPoint = rhoPoint := by
+  induction n with
+  | zero => simp
+  | succ n ih => rw [pow_succ, SemigroupAction.mul_smul, triangleModularA_smul_rhoPoint, ih]
+
+private theorem SpecialPeriods.modularCyclicNormalizer_smul_rhoPoint (k : Fin 3) :
+    modularCyclicNormalizer k • rhoPoint = rhoPoint := by
+  rw [modularCyclicNormalizer, inv_smul_eq_iff]
+  exact (triangleModularA_pow_smul_rhoPoint k).symm
+
+private theorem SpecialPeriods.modularCyclicNormalizer_intertwines_A (k : Fin 3) (z : ℍ) :
+    modularCyclicNormalizer k • (triangleModularA • z) =
+      triangleModularA • (modularCyclicNormalizer k • z) := by
+  have he :=
+    congrArg (fun C : SL(2, ℤ) => C • (modularCyclicNormalizer k • z))
+      (modularCyclicNormalizer_conjugate_A k)
+  simpa only [SemigroupAction.mul_smul, inv_smul_smul] using he
+
+private theorem SpecialPeriods.normalized_B_action_mo1973_17159 (k : Fin 3) (B : SL(2, ℤ))
+    (hB :
+      modularProjectivization (modularCyclicNormalizer k * B * (modularCyclicNormalizer k)⁻¹) =
+        modularProjectivization ModularGroup.S)
+    (z : ℍ) :
+    modularCyclicNormalizer k • (B • z) = ModularGroup.S • (modularCyclicNormalizer k • z) := by
+  have he :=
+    congrArg (fun C : PSL(2, ℤ) => modularPSLPermutation C (modularCyclicNormalizer k • z)) hB
+  simpa only [modularPSLPermutation_projectivization, SemigroupAction.mul_smul,
+    inv_smul_smul] using he
+
+private theorem SpecialPeriods.normalized_product_projective_mo1973_17160 (k : Fin 3)
+    (B : SL(2, ℤ))
+    (hB :
+      modularProjectivization (modularCyclicNormalizer k * B * (modularCyclicNormalizer k)⁻¹) =
+        modularProjectivization ModularGroup.S) :
+    modularProjectivization
+        (modularCyclicNormalizer k * (triangleModularA * B) * (modularCyclicNormalizer k)⁻¹) =
+      modularProjectivization ModularGroup.T := by
+  have he :
+    modularCyclicNormalizer k * (triangleModularA * B) * (modularCyclicNormalizer k)⁻¹ =
+      (modularCyclicNormalizer k * triangleModularA * (modularCyclicNormalizer k)⁻¹) *
+        (modularCyclicNormalizer k * B * (modularCyclicNormalizer k)⁻¹) := by group
+  rw [he, map_mul, modularCyclicNormalizer_conjugate_A, hB]
+  exact triangleModularGenerator₁_mul_generator₂
+
+private theorem SpecialPeriods.normalized_cusp_projective_mo1973_17161 (k : Fin 3) (B : SL(2, ℤ))
+    (hB :
+      modularProjectivization (modularCyclicNormalizer k * B * (modularCyclicNormalizer k)⁻¹) =
+        modularProjectivization ModularGroup.S) :
+    modularProjectivization
+        (modularCyclicNormalizer k * (triangleModularA * B)⁻¹ * (modularCyclicNormalizer k)⁻¹) =
+      modularProjectivization ModularGroup.T⁻¹ := by
+  have he :
+    modularCyclicNormalizer k * (triangleModularA * B)⁻¹ * (modularCyclicNormalizer k)⁻¹ =
+      (modularCyclicNormalizer k * (triangleModularA * B) * (modularCyclicNormalizer k)⁻¹)⁻¹ := by
+    group
+  rw [he, map_inv, normalized_product_projective_mo1973_17160 k B hB, ← map_inv]
+
+private theorem SpecialPeriods.normalized_cusp_action_mo1973_17162 (k : Fin 3) (B : SL(2, ℤ))
+    (hB :
+      modularProjectivization (modularCyclicNormalizer k * B * (modularCyclicNormalizer k)⁻¹) =
+        modularProjectivization ModularGroup.S)
+    (z : ℍ) :
+    modularCyclicNormalizer k • ((triangleModularA * B)⁻¹ • z) =
+      ModularGroup.T⁻¹ • (modularCyclicNormalizer k • z) := by
+  have he :=
+    congrArg (fun C : PSL(2, ℤ) => modularPSLPermutation C (modularCyclicNormalizer k • z))
+      (normalized_cusp_projective_mo1973_17161 k B hB)
+  simpa only [modularPSLPermutation_projectivization, SemigroupAction.mul_smul,
+    inv_smul_smul] using he
+
+private theorem SpecialPeriods.modular_pair_cyclic_normalization (B : SL(2, ℤ))
+    (htr : Matrix.trace B.val = 0)
+    (hprod :
+      Matrix.trace (triangleModularA * B).val = 2 ∨
+        Matrix.trace (triangleModularA * B).val = -2) :
+    ∃ k : Fin 3,
+      modularCyclicNormalizer k • rhoPoint = rhoPoint ∧
+        (∀ z : ℍ,
+            modularCyclicNormalizer k • (triangleModularA • z) =
+              triangleModularA • (modularCyclicNormalizer k • z)) ∧
+          (∀ z : ℍ,
+              modularCyclicNormalizer k • (B • z) =
+                ModularGroup.S • (modularCyclicNormalizer k • z)) ∧
+            (∀ z : ℍ,
+              modularCyclicNormalizer k • ((triangleModularA * B)⁻¹ • z) =
+                ModularGroup.T⁻¹ • (modularCyclicNormalizer k • z)) := by
+  obtain ⟨k, hk⟩ := modular_pair_projective_conjugation_normalization B htr hprod
+  exact
+    ⟨k, modularCyclicNormalizer_smul_rhoPoint k, modularCyclicNormalizer_intertwines_A k,
+      normalized_B_action_mo1973_17159 k B hk, normalized_cusp_action_mo1973_17162 k B hk⟩
+
+private theorem SpecialPeriods.modular_pair_elliptic_value_normalization (B : SL(2, ℤ))
+    (htr : Matrix.trace B.val = 0)
+    (hprod :
+      Matrix.trace (triangleModularA * B).val = 2 ∨ Matrix.trace (triangleModularA * B).val = -2)
+    (z : ℍ) (hz : B • z = z) :
+    ∃ k : Fin 3,
+      modularCyclicNormalizer k • rhoPoint = rhoPoint ∧
+        modularCyclicNormalizer k • z = UpperHalfPlane.I ∧
+          (∀ w : ℍ,
+              modularCyclicNormalizer k • (triangleModularA • w) =
+                triangleModularA • (modularCyclicNormalizer k • w)) ∧
+            (∀ w : ℍ,
+                modularCyclicNormalizer k • (B • w) =
+                  ModularGroup.S • (modularCyclicNormalizer k • w)) ∧
+              (∀ w : ℍ,
+                modularCyclicNormalizer k • ((triangleModularA * B)⁻¹ • w) =
+                  ModularGroup.T⁻¹ • (modularCyclicNormalizer k • w)) := by
+  obtain ⟨k, hρ, hA, hB, hcusp⟩ := modular_pair_cyclic_normalization B htr hprod
+  refine ⟨k, hρ, ?_, hA, hB, hcusp⟩
+  apply (modularI_fixed_iff _).mp
+  exact (hB z).symm.trans (congrArg (fun w : ℍ => modularCyclicNormalizer k • w) hz)
+
+private theorem
+    SpecialPeriods.realSL_fixed_multiplier_eq_neg_one_iff_trace_zero (B : SL(2, ℝ)) (b : ℍ)
+    (hfix : B • b = b) : Triangle.slMultiplier B b = -1 ↔ Matrix.trace B.val = 0 := by
+  have hd := Triangle.slDenom_ne_zero B b
+  have hidentity := Triangle.sl_fixed_denominator_identity B b hfix
+  constructor
+  · intro hmul
+    have hsquare : Triangle.slDenom B b ^ 2 = -1 := by
+      have he := (div_eq_iff (pow_ne_zero 2 hd)).mp hmul
+      linear_combination he
+    have hproduct : ((B 0 0 : ℂ) + (B 1 1 : ℂ)) * Triangle.slDenom B b = 0 := by
+      dsimp [Triangle.slDenom] at hidentity hsquare ⊢
+      linear_combination hidentity + hsquare
+    have hsum := (mul_eq_zero.mp hproduct).resolve_right hd
+    rw [Matrix.trace_fin_two]
+    exact_mod_cast hsum
+  · intro htrace
+    rw [Matrix.trace_fin_two] at htrace
+    have hsum : (B 0 0 : ℂ) + (B 1 1 : ℂ) = 0 := by exact_mod_cast htrace
+    have hsquare : Triangle.slDenom B b ^ 2 = -1 := by
+      dsimp [Triangle.slDenom] at hidentity ⊢
+      linear_combination -hidentity + ((B 1 0 : ℂ) * (b : ℂ) + (B 1 1 : ℂ)) * hsum
+    rw [Triangle.slMultiplier, hsquare]
+    norm_num
+
+private theorem SpecialPeriods.realSL_fixed_deriv_eq_neg_one_iff_trace_zero (B : SL(2, ℝ)) (b : ℍ)
+    (hfix : B • b = b) :
+    deriv (fun z : ℂ => ((B • UpperHalfPlane.ofComplex z : ℍ) : ℂ)) (b : ℂ) = -1 ↔
+      Matrix.trace B.val = 0 := by
+  rw [Triangle.sl_deriv_smul]
+  exact realSL_fixed_multiplier_eq_neg_one_iff_trace_zero B b hfix
+
+private theorem
+    SpecialPeriods.modularSL_fixed_deriv_eq_neg_one_iff_trace_zero (B : SL(2, ℤ)) (b : ℍ)
+    (hfix : B • b = b) :
+    deriv (fun z : ℂ => ((B • UpperHalfPlane.ofComplex z : ℍ) : ℂ)) (b : ℂ) = -1 ↔
+      Matrix.trace B.val = 0 := by
+  have hfixR : Matrix.SpecialLinearGroup.map (Int.castRingHom ℝ) B • b = b := by
+    rw [integerSL_real_action]
+    exact hfix
+  have htrace :
+    Matrix.trace (Matrix.SpecialLinearGroup.map (Int.castRingHom ℝ) B).val = 0 ↔
+      Matrix.trace B.val = 0 := by
+    rw [Matrix.trace_fin_two, Matrix.trace_fin_two]
+    change (B 0 0 : ℝ) + (B 1 1 : ℝ) = 0 ↔ B 0 0 + B 1 1 = 0
+    rw [← Int.cast_add, Int.cast_eq_zero]
+  have h :=
+    (realSL_fixed_deriv_eq_neg_one_iff_trace_zero
+          (Matrix.SpecialLinearGroup.map (Int.castRingHom ℝ) B) b hfixR).trans
+      htrace
+  simpa only [integerSL_real_action] using h
+
+private theorem SpecialPeriods.modularSL_trace_zero_of_fixed_deriv_neg_one (B : SL(2, ℤ)) (b : ℍ)
+    (hfix : B • b = b)
+    (hderiv : deriv (fun z : ℂ => ((B • UpperHalfPlane.ofComplex z : ℍ) : ℂ)) (b : ℂ) = -1) :
+    Matrix.trace B.val = 0 :=
+  (modularSL_fixed_deriv_eq_neg_one_iff_trace_zero B b hfix).mp hderiv
+
+private theorem SpecialPeriods.modularSL_trace_inv (B : SL(2, ℤ)) :
+    Matrix.trace (B⁻¹).val = Matrix.trace B.val := by
+  change Matrix.trace (Matrix.adjugate B.val) = Matrix.trace B.val
+  simp [Matrix.trace_fin_two, Matrix.adjugate_fin_two, add_comm]
+
+private theorem SpecialPeriods.modularSL_trace_conjugate (u B : SL(2, ℤ)) :
+    Matrix.trace (u * B * u⁻¹).val = Matrix.trace B.val := by
+  change
+    Matrix.trace
+        ((u : Matrix (Fin 2) (Fin 2) ℤ) * B.val * ((u⁻¹ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ)) =
+      _
+  have hinv :
+    ((u⁻¹ : SL(2, ℤ)) : Matrix (Fin 2) (Fin 2) ℤ) * (u : Matrix (Fin 2) (Fin 2) ℤ) = 1 := by
+    exact congrArg (fun C : SL(2, ℤ) => C.val) (inv_mul_cancel u)
+  rw [Matrix.trace_mul_cycle, hinv, one_mul]
+
+private theorem SpecialPeriods.modularSL_actions_eq_iff (B C : SL(2, ℤ)) :
+    (∀ z : ℍ, B • z = C • z) ↔ B = C ∨ B = -C := by
+  constructor
+  · intro h
+    have he :
+      Triangle.realSLPermutation (B : SL(2, ℝ)) = Triangle.realSLPermutation (C : SL(2, ℝ)) := by
+      apply Equiv.ext
+      intro z
+      change
+        (Matrix.SpecialLinearGroup.map (Int.castRingHom ℝ) B) • z =
+          (Matrix.SpecialLinearGroup.map (Int.castRingHom ℝ) C) • z
+      simpa only [integerSL_real_action] using h z
+    rcases (Triangle.realSLPermutation_eq_iff _ _).mp he with he | he
+    · exact Or.inl (Matrix.SpecialLinearGroup.map_intCast_injective (R := ℝ) he)
+    · right
+      apply Matrix.SpecialLinearGroup.map_intCast_injective (R := ℝ)
+      simpa only [Matrix.SpecialLinearGroup.coe_int_neg] using he
+  · rintro (rfl | rfl) z
+    · rfl
+    · exact ModularGroup.SL_neg_smul C z
+
+private theorem SpecialPeriods.modularSL_trace_two_or_neg_two_of_actions_eq (B C : SL(2, ℤ))
+    (h : ∀ z : ℍ, B • z = C • z) (hC : Matrix.trace C.val = 2 ∨ Matrix.trace C.val = -2) :
+    Matrix.trace B.val = 2 ∨ Matrix.trace B.val = -2 := by
+  rcases (modularSL_actions_eq_iff B C).mp h with rfl | rfl
+  · exact hC
+  · change Matrix.trace (-C.val) = 2 ∨ Matrix.trace (-C.val) = -2
+    rw [Matrix.trace_neg]
+    rcases hC with hC | hC
+    · right
+      rw [hC]
+    · left
+      rw [hC, neg_neg]
+
+private theorem SpecialPeriods.modularSL_trace_two_or_neg_two_of_inverse_actions_eq (B C : SL(2, ℤ))
+    (h : ∀ z : ℍ, B⁻¹ • z = C • z) (hC : Matrix.trace C.val = 2 ∨ Matrix.trace C.val = -2) :
+    Matrix.trace B.val = 2 ∨ Matrix.trace B.val = -2 := by
+  simpa only [modularSL_trace_inv] using modularSL_trace_two_or_neg_two_of_actions_eq B⁻¹ C h hC
+
+private theorem SpecialPeriods.modular_pair_trace_two_or_neg_two_of_cusp_actions_eq (B C : SL(2, ℤ))
+    (h : ∀ z : ℍ, (triangleModularA * B)⁻¹ • z = C • z)
+    (hC : Matrix.trace C.val = 2 ∨ Matrix.trace C.val = -2) :
+    Matrix.trace (triangleModularA * B).val = 2 ∨ Matrix.trace (triangleModularA * B).val = -2 :=
+  modularSL_trace_two_or_neg_two_of_inverse_actions_eq (triangleModularA * B) C h hC
+
+private theorem SpecialPeriods.exists_cyclic_normalization_of_rho_lift (F : ℍ → ℂ) {τ : ℍ → ℍ}
+    (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (hJ : ∀ z : ℍ, modularJ (τ z) = F z)
+    (ha : τ Triangle.centerOne = rhoPoint) (hFb : F Triangle.centerTwo = 1728)
+    (hF₁ : ∀ z : ℍ, F (Triangle.generatorOneSL • z) = F z)
+    (hF₂ : ∀ z : ℍ, F (Triangle.generatorTwoSL • z) = F z)
+    (horder₁ : analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (Triangle.centerOne : ℂ) = 3)
+    (horder₂ :
+      analyticOrderAt (fun z : ℂ => F (UpperHalfPlane.ofComplex z) - 1728)
+          (Triangle.centerTwo : ℂ) =
+        4)
+    (C : SL(2, ℤ)) (hCtr : Matrix.trace C.val = 2 ∨ Matrix.trace C.val = -2)
+    (hC : ∀ z : ℍ, τ (Triangle.cuspSL • z) = C • τ z) :
+    ∃ k : Fin 3,
+      TauCovariant (fun z => modularCyclicNormalizer k • τ z) ∧
+        modularCyclicNormalizer k • τ Triangle.centerOne = rhoPoint ∧
+          modularCyclicNormalizer k • τ Triangle.centerTwo = UpperHalfPlane.I := by
+  have hJa : modularJ (τ Triangle.centerOne) = 0 := by rw [ha, modularJ_rhoPoint]
+  have hJb : modularJ (τ Triangle.centerTwo) = 1728 := (hJ _).trans hFb
+  have hFa : F Triangle.centerOne = 0 := (hJ _).symm.trans hJa
+  obtain ⟨x, hx⟩ :=
+    exists_regular_modular_value_of_j_values hτ.continuous Triangle.centerOne Triangle.centerTwo
+      hJa hJb
+  have hτMD := hτ.mdifferentiable (by simp)
+  have ho₁ :=
+    ModularGermLift.native_modularJ_lift_order_of_zero hτMD hJ (n := 1) hFa
+      (by simpa using horder₁)
+  have ho₂ :=
+    ModularGermLift.native_modularJ_lift_order_of_1728 hτMD hJ (n := 2) hFb
+      (by simpa using horder₂)
+  have hA :=
+    modular_lift_first_generator_of_rho_order hτ ha (by simpa [ha] using ho₁)
+      (by intro z; rw [hJ, hJ, hF₁]) x hx
+  obtain ⟨B, hB⟩ :=
+    modularJ_invariant_lift_action hτ Triangle.generatorTwoSL (by intro z; rw [hJ, hJ, hF₂]) x hx
+  have hBfix :=
+    modular_lift_monodromy_fixes_image Triangle.generatorTwoSL Triangle.centerTwo
+      Triangle.generatorTwo_fix B hB
+  have hBderiv := modular_lift_generatorTwo_monodromy_deriv hτ (by simpa using ho₂) B hB
+  have hBtr := modularSL_trace_zero_of_fixed_deriv_neg_one B (τ Triangle.centerTwo) hBfix hBderiv
+  have hab : τ Triangle.centerOne ≠ τ Triangle.centerTwo := by
+    intro he
+    have hh := congrArg modularJ he
+    rw [hJa, hJb] at hh
+    norm_num at hh
+  have hcomp :=
+    modular_lift_cusp_monodromy_comparison B C hA hB hC Triangle.centerOne Triangle.centerTwo hab
+  have hprod := modular_pair_trace_two_or_neg_two_of_cusp_actions_eq B C hcomp hCtr
+  obtain ⟨k, hkρ, hki, hkA, hkB, _⟩ :=
+    modular_pair_elliptic_value_normalization B hBtr hprod (τ Triangle.centerTwo) hBfix
+  refine ⟨k, ⟨?_, ?_⟩, ?_, hki⟩
+  · intro z
+    change ((modularCyclicNormalizer k • τ (Triangle.generatorOneSL • z) : ℍ) : ℂ) = _
+    rw [hA, hkA, triangleModularA_eq_T_mul_S, ← modularRhoAction_coe]
+    rfl
+  · intro z
+    change ((modularCyclicNormalizer k • τ (Triangle.generatorTwoSL • z) : ℍ) : ℂ) = _
+    rw [← hB z, hkB, ← modularIAction_coe]
+    rfl
+  · rw [ha, hkρ]
+
+private theorem SpecialPeriods.exists_normalized_covariant_modular_translate (F : ℍ → ℂ) {τ : ℍ → ℍ}
+    (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (hJ : ∀ z : ℍ, modularJ (τ z) = F z)
+    (hFa : F Triangle.centerOne = 0) (hFb : F Triangle.centerTwo = 1728)
+    (hF₁ : ∀ z : ℍ, F (Triangle.generatorOneSL • z) = F z)
+    (hF₂ : ∀ z : ℍ, F (Triangle.generatorTwoSL • z) = F z)
+    (horder₁ : analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (Triangle.centerOne : ℂ) = 3)
+    (horder₂ :
+      analyticOrderAt (fun z : ℂ => F (UpperHalfPlane.ofComplex z) - 1728)
+          (Triangle.centerTwo : ℂ) =
+        4)
+    (C : SL(2, ℤ)) (hCtr : Matrix.trace C.val = 2 ∨ Matrix.trace C.val = -2)
+    (hC : ∀ z : ℍ, τ (Triangle.cuspSL • z) = C • τ z) :
+    ∃ γ : SL(2, ℤ),
+      TauCovariant (fun z => γ • τ z) ∧
+        γ • τ Triangle.centerOne = rhoPoint ∧ γ • τ Triangle.centerTwo = UpperHalfPlane.I := by
+  have hzero : modularJ rhoPoint = modularJ (τ Triangle.centerOne) := by
+    rw [modularJ_rhoPoint, hJ, hFa]
+  obtain ⟨δ, hδ⟩ := (modularJ_eq_iff_exists_smul rhoPoint (τ Triangle.centerOne)).mp hzero
+  let σ : ℍ → ℍ := fun z => δ • τ z
+  have hσ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω σ := (modularSL_holomorphic δ).comp hτ
+  have hσJ : ∀ z : ℍ, modularJ (σ z) = F z := by
+    intro z
+    exact (modularJ_SL_invariant δ (τ z)).trans (hJ z)
+  have hσa : σ Triangle.centerOne = rhoPoint := hδ
+  have hCtr' : Matrix.trace (δ * C * δ⁻¹).val = 2 ∨ Matrix.trace (δ * C * δ⁻¹).val = -2 := by
+    simpa only [modularSL_trace_conjugate] using hCtr
+  have hC' : ∀ z : ℍ, σ (Triangle.cuspSL • z) = (δ * C * δ⁻¹) • σ z :=
+    modular_lift_cusp_monodromy_conjugate δ C hC
+  obtain ⟨k, hkc, hka, hkb⟩ :=
+    exists_cyclic_normalization_of_rho_lift F hσ hσJ hσa hFb hF₁ hF₂ horder₁ horder₂ (δ * C * δ⁻¹)
+      hCtr' hC'
+  refine ⟨modularCyclicNormalizer k * δ, ?_, ?_, ?_⟩
+  · simpa only [TauCovariant, σ, SemigroupAction.mul_smul] using hkc
+  · simpa only [σ, SemigroupAction.mul_smul] using hka
+  · simpa only [σ, SemigroupAction.mul_smul] using hkb
+
+private theorem
+    SpecialPeriods.modular_Tinv_vadd (z : ℍ) : ModularGroup.T⁻¹ • z = (-1 : ℝ) +ᵥ z := by
+  simpa using UpperHalfPlane.modular_T_zpow_smul z (-1)
+
+private theorem
+    SpecialPeriods.tau_cusp_monodromy_of_formula {τ : ℍ → ℍ} (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ)
+    {r : ℝ} (hr : 0 < r) {h : ℂ → ℂ}
+    (hformula :
+      ∀ z : ℍ,
+        ‖Function.Periodic.qParam Triangle.width (z : ℂ)‖ < r →
+          (τ z : ℂ) = TauCusp.correctedLogarithmWidth Triangle.width h (z : ℂ)) :
+    ∀ z : ℍ, τ (Triangle.cuspSL • z) = ModularGroup.T⁻¹ • τ z := by
+  intro z
+  have he :=
+    TauCusp.global_native_sub_int_mul_width_of_cuspFormula Triangle.width Triangle.width_pos hr hτ
+      hformula (1 : ℤ) z
+  have hz : ((Triangle.cuspSL • z : ℍ) : ℂ) = (z : ℂ) - Triangle.width := by
+    rw [Triangle.cuspSL_apply, UpperHalfPlane.coe_vadd]
+    push_cast
+    ring
+  have harg :
+    UpperHalfPlane.ofComplex ((z : ℂ) - (1 : ℂ) * Triangle.width) = Triangle.cuspSL • z := by
+    rw [one_mul, ← hz, UpperHalfPlane.ofComplex_apply]
+  apply UpperHalfPlane.ext
+  calc
+    (τ (Triangle.cuspSL • z) : ℂ) = (τ z : ℂ) - 1 := by simpa only [Int.cast_one, harg] using he
+    _ = ((ModularGroup.T⁻¹ • τ z : ℍ) : ℂ) := by
+      rw [modular_Tinv_vadd, UpperHalfPlane.coe_vadd]
+      push_cast
+      ring
+
+private theorem SpecialPeriods.tau_covariant_cuspSL {τ : ℍ → ℍ} (hτ : TauCovariant τ) (z : ℍ) :
+    τ (Triangle.cuspSL • z) = ModularGroup.T⁻¹ • τ z := by
+  rw [Triangle.cuspSL_apply, modular_Tinv_vadd]
+  simpa only [triangleGeometricRepresentation_cusp_apply] using tau_covariant_cusp hτ z
+
+private theorem SpecialPeriods.modular_translate_commutes_Tinv_of_cusp_covariance {τ : ℍ → ℍ}
+    (γ : SL(2, ℤ)) (hC : ∀ z : ℍ, τ (Triangle.cuspSL • z) = ModularGroup.T⁻¹ • τ z)
+    (hcov : TauCovariant (fun z => γ • τ z)) (a b : ℍ) (hab : τ a ≠ τ b) :
+    ∀ z : ℍ, γ • (ModularGroup.T⁻¹ • z) = ModularGroup.T⁻¹ • (γ • z) := by
+  have hvalues (z : ℍ) : (γ * ModularGroup.T⁻¹) • τ z = (ModularGroup.T⁻¹ * γ) • τ z := by
+    rw [SemigroupAction.mul_smul, SemigroupAction.mul_smul, ← hC z]
+    exact tau_covariant_cuspSL hcov z
+  simpa only [SemigroupAction.mul_smul] using
+    modularSL_actions_eq_of_two_values (γ * ModularGroup.T⁻¹) (ModularGroup.T⁻¹ * γ) (τ a) (τ b)
+      hab (hvalues a) (hvalues b)
+
+private theorem SpecialPeriods.modularSL_commutes_T_inv_of_actions_commute (γ : SL(2, ℤ))
+    (h : ∀ z : ℍ, γ • (ModularGroup.T⁻¹ • z) = ModularGroup.T⁻¹ • (γ • z)) :
+    Commute γ ModularGroup.T⁻¹ := by
+  have hconj : ∀ z : ℍ, (γ * ModularGroup.T⁻¹ * γ⁻¹) • z = ModularGroup.T⁻¹ • z := by
+    intro z
+    simp only [SemigroupAction.mul_smul]
+    rw [h, smul_inv_smul]
+  rcases (modularSL_actions_eq_iff (γ * ModularGroup.T⁻¹ * γ⁻¹) ModularGroup.T⁻¹).mp hconj with
+    he | he
+  · change γ * ModularGroup.T⁻¹ = ModularGroup.T⁻¹ * γ
+    have hm := congrArg (fun B : SL(2, ℤ) => B * γ) he
+    simpa only [mul_assoc, inv_mul_cancel, mul_one] using hm
+  · have ht := congrArg (fun B : SL(2, ℤ) => Matrix.trace B.val) he
+    rw [modularSL_trace_conjugate] at ht
+    change
+      Matrix.trace (ModularGroup.T⁻¹ : SL(2, ℤ)).val =
+        Matrix.trace (-((ModularGroup.T⁻¹ : SL(2, ℤ)).val)) at ht
+    have hT : Matrix.trace (ModularGroup.T⁻¹ : SL(2, ℤ)).val = 2 := by decide
+    rw [Matrix.trace_neg, hT] at ht
+    norm_num at ht
+
+private theorem SpecialPeriods.modularSL_lower_left_zero_of_commutes_T_inv_mo1973_17251
+    (γ : SL(2, ℤ)) (h : Commute γ ModularGroup.T⁻¹) : γ 1 0 = 0 := by
+  have he := congrArg (fun B : SL(2, ℤ) => B 0 0) h.eq
+  change
+    (γ.val * (ModularGroup.T⁻¹ : SL(2, ℤ)).val) 0 0 =
+      ((ModularGroup.T⁻¹ : SL(2, ℤ)).val * γ.val) 0 0 at he
+  rw [ModularGroup.coe_T_inv] at he
+  simp [Matrix.mul_apply, Fin.sum_univ_two] at he
+  omega
+
+private theorem SpecialPeriods.modularSL_integer_translation_of_commutes_T_inv_action (γ : SL(2, ℤ))
+    (h : ∀ z : ℍ, γ • (ModularGroup.T⁻¹ • z) = ModularGroup.T⁻¹ • (γ • z)) :
+    ∃ n : ℤ, ∀ z : ℍ, γ • z = (n : ℝ) +ᵥ z := by
+  have hc :=
+    modularSL_lower_left_zero_of_commutes_T_inv_mo1973_17251 γ
+      (modularSL_commutes_T_inv_of_actions_commute γ h)
+  obtain ⟨n, hn⟩ := ModularGroup.exists_eq_T_zpow_of_c_eq_zero (g := γ) hc
+  exact ⟨n, fun z => (hn z).trans (UpperHalfPlane.modular_T_zpow_smul z n)⟩
+
+private theorem
+    SpecialPeriods.modularSL_integer_translation_coe_of_commutes_T_inv_action (γ : SL(2, ℤ))
+    (h : ∀ z : ℍ, γ • (ModularGroup.T⁻¹ • z) = ModularGroup.T⁻¹ • (γ • z)) :
+    ∃ n : ℤ, ∀ z : ℍ, ((γ • z : ℍ) : ℂ) = (z : ℂ) + (n : ℂ) := by
+  obtain ⟨n, hn⟩ := modularSL_integer_translation_of_commutes_T_inv_action γ h
+  refine ⟨n, fun z => ?_⟩
+  rw [hn z, UpperHalfPlane.coe_vadd]
+  simp [add_comm]
+
+private theorem
+    SpecialPeriods.ModularGermLift.analyticAt_modular_smul_of_im_pos (γ : SL(2, ℤ)) {w : ℂ}
+    (hw : 0 < w.im) : AnalyticAt ℂ (fun v : ℂ => ((γ • UpperHalfPlane.ofComplex v : ℍ) : ℂ)) w := by
+  change
+    AnalyticAt ℂ
+      (fun v : ℂ => ((Matrix.SpecialLinearGroup.mapGL ℝ γ • UpperHalfPlane.ofComplex v : ℍ) : ℂ))
+      w
+  apply UpperHalfPlane.analyticAt_smul (τ := (⟨w, hw⟩ : ℍ))
+  change 0 < ((Matrix.SpecialLinearGroup.mapGL ℝ γ).det : ℝ)
+  simp
+
+private theorem
+    SpecialPeriods.ModularGermLift.analyticAt_modular_smul (γ : SL(2, ℤ)) {σ : ℂ → ℂ} {a : ℂ}
+    (hσ : AnalyticAt ℂ σ a) (hσa : 0 < (σ a).im) :
+    AnalyticAt ℂ (fun z => ((γ • UpperHalfPlane.ofComplex (σ z) : ℍ) : ℂ)) a :=
+  (analyticAt_modular_smul_of_im_pos γ hσa).comp hσ
+
+private theorem SpecialPeriods.ModularGermLift.analyticOnNhd_modular_smul (γ : SL(2, ℤ)) {σ : ℂ → ℂ}
+    {U : Set ℂ} (hσ : AnalyticOnNhd ℂ σ U)
+    (hσU : Set.MapsTo σ U UpperHalfPlane.upperHalfPlaneSet) :
+    AnalyticOnNhd ℂ (fun z => ((γ • UpperHalfPlane.ofComplex (σ z) : ℍ) : ℂ)) U := fun a ha =>
+  analyticAt_modular_smul γ (hσ a ha) (hσU ha)
+
+private theorem SpecialPeriods.ModularGermLift.modularJ_modular_smul (γ : SL(2, ℤ)) (w : ℂ) :
+    SpecialPeriods.modularJ
+        (UpperHalfPlane.ofComplex ((γ • UpperHalfPlane.ofComplex w : ℍ) : ℂ)) =
+      SpecialPeriods.modularJ (UpperHalfPlane.ofComplex w) := by
+  rw [UpperHalfPlane.ofComplex_apply]
+  exact SpecialPeriods.modularJ_SL_invariant γ (UpperHalfPlane.ofComplex w)
+
+private theorem SpecialPeriods.ModularGermLift.modularGroup_countable : Countable SL(2, ℤ) := by
+  unfold Matrix.SpecialLinearGroup Matrix
+  infer_instance
+
+private theorem SpecialPeriods.ModularGermLift.exists_eqOn_of_countable_analytic_cover {ι : Type*}
+    [Countable ι] {U : Set ℂ} {f : ℂ → ℂ} {g : ι → ℂ → ℂ} (hU : IsOpen U) (hUc : IsPreconnected U)
+    (hUn : U.Nonempty) (hf : AnalyticOnNhd ℂ f U) (hg : ∀ i, AnalyticOnNhd ℂ (g i) U)
+    (hcover : ∀ z ∈ U, ∃ i, f z = g i z) : ∃ i, Set.EqOn f (g i) U := by
+  let : BaireSpace U := hU.baireSpace
+  obtain ⟨a, ha⟩ := hUn
+  let : Nonempty U := ⟨⟨a, ha⟩⟩
+  let C : ι → Set U := fun i => {z | f z = g i z}
+  have hC (i : ι) : IsClosed (C i) :=
+    isClosed_eq hf.continuousOn.domRestrict (hg i).continuousOn.domRestrict
+  have hCU : ⋃ i, C i = Set.univ := by
+    ext z
+    simp only [Set.mem_iUnion, Set.mem_univ, iff_true]
+    exact hcover z z.2
+  obtain ⟨i, z, hz⟩ := nonempty_interior_of_iUnion_of_closed hC hCU
+  let V : Set ℂ := Subtype.val '' interior (C i)
+  have hV : IsOpen V := hU.isOpenMap_subtype_val _ isOpen_interior
+  have hzV : (z : ℂ) ∈ V := Set.mem_image_of_mem Subtype.val hz
+  have heq : f =ᶠ[𝓝 (z : ℂ)] g i := by
+    filter_upwards [hV.mem_nhds hzV] with w hw
+    obtain ⟨v, hv, rfl⟩ := hw
+    have hvC : v ∈ C i := interior_subset hv
+    exact hvC
+  exact ⟨i, hf.eqOn_of_preconnected_of_eventuallyEq (hg i) hUc z.2 heq⟩
+
+private theorem SpecialPeriods.ModularGermLift.exists_modular_alignment {U : Set ℂ} {τ σ : ℂ → ℂ}
+    (hU : IsOpen U) (hUc : IsPreconnected U) (hUn : U.Nonempty) (hτ : AnalyticOnNhd ℂ τ U)
+    (hσ : AnalyticOnNhd ℂ σ U) (hτU : Set.MapsTo τ U UpperHalfPlane.upperHalfPlaneSet)
+    (hσU : Set.MapsTo σ U UpperHalfPlane.upperHalfPlaneSet)
+    (hJ :
+      Set.EqOn (fun z => SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (τ z)))
+        (fun z => SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (σ z))) U) :
+    ∃ γ : SL(2, ℤ), Set.EqOn τ (fun z => ((γ • UpperHalfPlane.ofComplex (σ z) : ℍ) : ℂ)) U := by
+  let : Countable SL(2, ℤ) := modularGroup_countable
+  apply
+    exists_eqOn_of_countable_analytic_cover hU hUc hUn hτ
+      (fun γ => analyticOnNhd_modular_smul γ hσ hσU)
+  intro z hz
+  obtain ⟨γ, hγ⟩ :=
+    (SpecialPeriods.modularJ_eq_iff_exists_smul (UpperHalfPlane.ofComplex (τ z))
+          (UpperHalfPlane.ofComplex (σ z))).mp
+      (hJ hz)
+  refine ⟨γ, ?_⟩
+  have hc := congrArg (fun w : ℍ => (w : ℂ)) hγ
+  rw [UpperHalfPlane.ofComplex_apply_of_im_pos (hτU hz)] at hc
+  exact hc.symm
+
+private theorem SpecialPeriods.ModularGermLift.exists_modular_alignment_germ {τ σ : ℂ → ℂ} {a : ℂ}
+    (hτ : AnalyticAt ℂ τ a) (hσ : AnalyticAt ℂ σ a) (hτa : 0 < (τ a).im) (hσa : 0 < (σ a).im)
+    (hJ :
+      (fun z => SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (τ z))) =ᶠ[𝓝 a]
+        (fun z => SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (σ z)))) :
+    ∃ γ : SL(2, ℤ), τ =ᶠ[𝓝 a] (fun z => ((γ • UpperHalfPlane.ofComplex (σ z) : ℍ) : ℂ)) := by
+  have hpτ : ∀ᶠ z in 𝓝 a, τ z ∈ UpperHalfPlane.upperHalfPlaneSet :=
+    hτ.continuousAt.preimage_mem_nhds (UpperHalfPlane.isOpen_upperHalfPlaneSet.mem_nhds hτa)
+  have hpσ : ∀ᶠ z in 𝓝 a, σ z ∈ UpperHalfPlane.upperHalfPlaneSet :=
+    hσ.continuousAt.preimage_mem_nhds (UpperHalfPlane.isOpen_upperHalfPlaneSet.mem_nhds hσa)
+  have hn :
+    {z |
+        AnalyticAt ℂ τ z ∧
+          AnalyticAt ℂ σ z ∧
+            τ z ∈ UpperHalfPlane.upperHalfPlaneSet ∧
+              σ z ∈ UpperHalfPlane.upperHalfPlaneSet ∧
+                SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (τ z)) =
+                  SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (σ z))} ∈
+      𝓝 a :=
+    hτ.eventually_analyticAt.and (hσ.eventually_analyticAt.and (hpτ.and (hpσ.and hJ)))
+  obtain ⟨ε, hε, hball⟩ := Metric.mem_nhds_iff.mp hn
+  obtain ⟨γ, hγ⟩ :=
+    exists_modular_alignment Metric.isOpen_ball (convex_ball a ε).isPreconnected
+      ⟨a, Metric.mem_ball_self hε⟩ (fun z hz => (hball hz).1) (fun z hz => (hball hz).2.1)
+      (fun z hz => (hball hz).2.2.1) (fun z hz => (hball hz).2.2.2.1)
+      (fun z hz => (hball hz).2.2.2.2)
+  exact ⟨γ, Filter.eventually_of_mem (Metric.ball_mem_nhds a hε) (fun _ hz => hγ hz)⟩
+
+private def
+    AnalyticRootCover.ambientVal (S : TopologicalSpace.Opens ℂ) (V : TopologicalSpace.Opens S)
+    (x : V) : ℂ :=
+  ((x : S) : ℂ)
+
+private theorem AnalyticRootCover.ambientVal_injective (S : TopologicalSpace.Opens ℂ)
+    (V : TopologicalSpace.Opens S) : Function.Injective (ambientVal S V) :=
+  Subtype.val_injective.comp Subtype.val_injective
+
+private def
+    AnalyticRootCover.ambientOpen (S : TopologicalSpace.Opens ℂ) (V : TopologicalSpace.Opens S) :
+    TopologicalSpace.Opens ℂ :=
+  ⟨Subtype.val '' (V : Set S), S.isOpen.isOpenMap_subtype_val _ V.isOpen⟩
+
+private theorem AnalyticRootCover.ambientVal_mem (S : TopologicalSpace.Opens ℂ)
+    (V : TopologicalSpace.Opens S) (x : V) : ambientVal S V x ∈ ambientOpen S V :=
+  ⟨(x : S), x.2, rfl⟩
+
+private theorem AnalyticRootCover.mem_ambientOpen (S : TopologicalSpace.Opens ℂ)
+    (V : TopologicalSpace.Opens S) {z : ℂ} :
+    z ∈ ambientOpen S V ↔ ∃ x : V, ambientVal S V x = z := by
+  constructor
+  · rintro ⟨x, hx, hxz⟩
+    exact ⟨⟨x, hx⟩, hxz⟩
+  · rintro ⟨x, rfl⟩
+    exact ambientVal_mem S V x
+
+@[simp]
+private theorem AnalyticRootCover.coe_mem_ambientOpen (S : TopologicalSpace.Opens ℂ)
+    (V : TopologicalSpace.Opens S) (x : S) : (x : ℂ) ∈ ambientOpen S V ↔ x ∈ V := by
+  constructor
+  · rintro ⟨y, hy, hyx⟩
+    have he : y = x := Subtype.ext hyx
+    subst y
+    exact hy
+  · intro hx
+    exact ⟨x, hx, rfl⟩
+
+private def
+    AnalyticRootCover.extendSection (S : TopologicalSpace.Opens ℂ) (V : TopologicalSpace.Opens S)
+    (s : V → ℂ) : ℂ → ℂ :=
+  Function.extend (ambientVal S V) s 0
+
+@[simp]
+private theorem AnalyticRootCover.extendSection_apply (S : TopologicalSpace.Opens ℂ)
+    (V : TopologicalSpace.Opens S) (s : V → ℂ) (x : V) :
+    extendSection S V s (ambientVal S V x) = s x :=
+  (ambientVal_injective S V).extend_apply s 0 x
+
+private theorem AnalyticRootCover.extendSection_agrees (S : TopologicalSpace.Opens ℂ)
+    (V : TopologicalSpace.Opens S) (s : V → ℂ) (f : ℂ → ℂ)
+    (hf : ∀ x, s x = f (ambientVal S V x)) : Set.EqOn (extendSection S V s) f (ambientOpen S V) :=
+  by
+  intro z hz
+  obtain ⟨x, rfl⟩ := (mem_ambientOpen S V).mp hz
+  rw [extendSection_apply]
+  exact hf x
+
+private theorem AnalyticRootCover.extension_agreement (S : TopologicalSpace.Opens ℂ)
+    (V : TopologicalSpace.Opens S) (f : ℂ → ℂ) :
+    Set.EqOn (extendSection S V (fun x => f (ambientVal S V x))) f (ambientOpen S V) :=
+  extendSection_agrees S V _ f (fun _ => rfl)
+
+private theorem AnalyticRootCover.extendSection_restrict_agrees (S : TopologicalSpace.Opens ℂ)
+    {U V : TopologicalSpace.Opens S} (i : U ⟶ V) (s : V → ℂ) :
+    Set.EqOn (extendSection S U (fun x => s (Set.inclusion i.le x))) (extendSection S V s)
+      (ambientOpen S U) := by
+  intro z hz
+  obtain ⟨x, rfl⟩ := (mem_ambientOpen S U).mp hz
+  rw [extendSection_apply]
+  exact (extendSection_apply S V s (Set.inclusion i.le x)).symm
+
+private theorem AnalyticRootCover.extendSection_restrict_eventuallyEq (S : TopologicalSpace.Opens ℂ)
+    {U V : TopologicalSpace.Opens S} (i : U ⟶ V) (s : V → ℂ) (x : U) :
+    extendSection S U (fun y => s (Set.inclusion i.le y)) =ᶠ[𝓝 (ambientVal S U x)]
+      extendSection S V s := by
+  filter_upwards [(ambientOpen S U).isOpen.mem_nhds (ambientVal_mem S U x)] with z hz
+  exact extendSection_restrict_agrees S i s hz
+
+private def AnalyticRootCover.IsRootSection (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ)
+    {V : TopologicalSpace.Opens S} (s : V → ℂ) : Prop :=
+  ∀ x : V, AnalyticAt ℂ (extendSection S V s) (ambientVal S V x) ∧ s x ^ 2 = F (ambientVal S V x)
+
+private def AnalyticRootCover.rootLocalPredicate (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ) :
+    TopCat.LocalPredicate (fun _ : TopCat.of S => ℂ)
+    where
+  pred {_} s := IsRootSection S F s
+  res {_ _} i s
+    hs := by
+    intro x
+    refine ⟨?_, (hs (Set.inclusion i.le x)).2⟩
+    exact (hs (Set.inclusion i.le x)).1.congr (extendSection_restrict_eventuallyEq S i s x).symm
+  locality {U} s
+    hs := by
+    intro x
+    obtain ⟨V, hxV, i, hV⟩ := hs x
+    let y : V := ⟨(x : S), hxV⟩
+    have hix : Set.inclusion i.le y = x := Subtype.ext rfl
+    refine ⟨?_, ?_⟩
+    · exact (hV y).1.congr (extendSection_restrict_eventuallyEq S i s y)
+    · have hsq : s (Set.inclusion i.le y) ^ 2 = F (ambientVal S U x) := (hV y).2
+      rwa [hix] at hsq
+
+private def AnalyticRootCover.rootPresheaf (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ) :
+    (TopCat.of S).Presheaf (Type 0) :=
+  TopCat.subpresheafToTypes (rootLocalPredicate S F).toPrelocalPredicate
+
+private abbrev AnalyticRootCover.RootSection (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ)
+    (V : TopologicalSpace.Opens S) :=
+  (rootPresheaf S F).obj (Opposite.op V)
+
+private theorem AnalyticRootCover.rootSection_analytic (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ)
+    {V : TopologicalSpace.Opens S} (s : RootSection S F V) (x : V) :
+    AnalyticAt ℂ (extendSection S V s.1) (ambientVal S V x) :=
+  (s.2 x).1
+
+private theorem AnalyticRootCover.rootSection_sq (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ)
+    {V : TopologicalSpace.Opens S} (s : RootSection S F V) (x : V) :
+    s.1 x ^ 2 = F (ambientVal S V x) :=
+  (s.2 x).2
+
+@[simp]
+private theorem AnalyticRootCover.rootPresheaf_map_apply (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ)
+    {U V : TopologicalSpace.Opens S} (i : U ⟶ V) (s : RootSection S F V) (x : U) :
+    ((rootPresheaf S F).map i.op s).1 x = s.1 (Set.inclusion i.le x) :=
+  rfl
+
+private theorem AnalyticRootCover.RootSection.analyticOnNhd_extend {S : TopologicalSpace.Opens ℂ}
+    {F : ℂ → ℂ} {V : TopologicalSpace.Opens S} (s : AnalyticRootCover.RootSection S F V) :
+    AnalyticOnNhd ℂ (AnalyticRootCover.extendSection S V s.1)
+      (AnalyticRootCover.ambientOpen S V) := by
+  intro z hz
+  obtain ⟨x, rfl⟩ := (AnalyticRootCover.mem_ambientOpen S V).mp hz
+  exact AnalyticRootCover.rootSection_analytic S F s x
+
+private theorem AnalyticRootCover.RootSection.square_eq {S : TopologicalSpace.Opens ℂ} {F : ℂ → ℂ}
+    {V : TopologicalSpace.Opens S} (s : AnalyticRootCover.RootSection S F V) {z : ℂ}
+    (hz : z ∈ AnalyticRootCover.ambientOpen S V) :
+    AnalyticRootCover.extendSection S V s.1 z ^ 2 = F z := by
+  obtain ⟨x, rfl⟩ := (AnalyticRootCover.mem_ambientOpen S V).mp hz
+  rw [AnalyticRootCover.extendSection_apply]
+  exact AnalyticRootCover.rootSection_sq S F s x
+
+@[ext]
+private theorem AnalyticRootCover.RootSection.ext {S : TopologicalSpace.Opens ℂ} {F : ℂ → ℂ}
+    {V : TopologicalSpace.Opens S} {s t : AnalyticRootCover.RootSection S F V}
+    (he : ∀ x, s.1 x = t.1 x) : s = t :=
+  Subtype.ext (funext he)
+
+private def AnalyticRootCover.rootSectionOfAnalytic (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ)
+    {V : TopologicalSpace.Opens S} (f : ℂ → ℂ) (hf : AnalyticOnNhd ℂ f (ambientOpen S V))
+    (hsq : ∀ x : V, f (ambientVal S V x) ^ 2 = F (ambientVal S V x)) : RootSection S F V := by
+  refine ⟨fun x => f (ambientVal S V x), fun x => ⟨?_, hsq x⟩⟩
+  apply (hf _ (ambientVal_mem S V x)).congr
+  filter_upwards [(ambientOpen S V).isOpen.mem_nhds (ambientVal_mem S V x)] with z hz
+  exact (extension_agreement S V f hz).symm
+
+private theorem AnalyticRootCover.extend_rootSectionOfAnalytic_eqOn (S : TopologicalSpace.Opens ℂ)
+    (F : ℂ → ℂ) {V : TopologicalSpace.Opens S} (f : ℂ → ℂ)
+    (hf : AnalyticOnNhd ℂ f (ambientOpen S V))
+    (hsq : ∀ x : V, f (ambientVal S V x) ^ 2 = F (ambientVal S V x)) :
+    Set.EqOn (extendSection S V (rootSectionOfAnalytic S F f hf hsq).1) f (ambientOpen S V) :=
+  extension_agreement S V f
+
+private def SpecialPeriods.ModularGermLift.extendLiftSection (S : TopologicalSpace.Opens ℂ)
+    (V : TopologicalSpace.Opens S) (s : V → ℍ) : ℂ → ℂ :=
+  AnalyticRootCover.extendSection S V (fun x => (s x : ℂ))
+
+@[simp]
+private theorem
+    SpecialPeriods.ModularGermLift.extendLiftSection_apply (S : TopologicalSpace.Opens ℂ)
+    (V : TopologicalSpace.Opens S) (s : V → ℍ) (x : V) :
+    extendLiftSection S V s (AnalyticRootCover.ambientVal S V x) = (s x : ℂ) :=
+  AnalyticRootCover.extendSection_apply S V (fun y => (s y : ℂ)) x
+
+private theorem SpecialPeriods.ModularGermLift.extendLiftSection_restrict_eventuallyEq
+    (S : TopologicalSpace.Opens ℂ) {U V : TopologicalSpace.Opens S} (i : U ⟶ V) (s : V → ℍ)
+    (x : U) :
+    extendLiftSection S U
+        (fun y => s (Set.inclusion i.le y)) =ᶠ[𝓝 (AnalyticRootCover.ambientVal S U x)]
+      extendLiftSection S V s :=
+  AnalyticRootCover.extendSection_restrict_eventuallyEq S i (fun y => (s y : ℂ)) x
+
+private def SpecialPeriods.ModularGermLift.IsLiftSection (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ)
+    {V : TopologicalSpace.Opens S} (s : V → ℍ) : Prop :=
+  ∀ x : V,
+    AnalyticAt ℂ (extendLiftSection S V s) (AnalyticRootCover.ambientVal S V x) ∧
+      SpecialPeriods.modularJ (s x) = F (AnalyticRootCover.ambientVal S V x)
+
+private def
+    SpecialPeriods.ModularGermLift.liftLocalPredicate (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ) :
+    TopCat.LocalPredicate (fun _ : TopCat.of S => ℍ)
+    where
+  pred {_} s := IsLiftSection S F s
+  res {_ _} i s
+    hs := by
+    intro x
+    refine ⟨?_, (hs (Set.inclusion i.le x)).2⟩
+    exact
+      (hs (Set.inclusion i.le x)).1.congr (extendLiftSection_restrict_eventuallyEq S i s x).symm
+  locality {U} s
+    hs := by
+    intro x
+    obtain ⟨V, hxV, i, hV⟩ := hs x
+    let y : V := ⟨(x : S), hxV⟩
+    have hix : Set.inclusion i.le y = x := Subtype.ext rfl
+    refine ⟨?_, ?_⟩
+    · exact (hV y).1.congr (extendLiftSection_restrict_eventuallyEq S i s y)
+    · have he :
+        SpecialPeriods.modularJ (s (Set.inclusion i.le y)) =
+          F (AnalyticRootCover.ambientVal S U x) :=
+        (hV y).2
+      rwa [hix] at he
+
+private def SpecialPeriods.ModularGermLift.liftPresheaf (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ) :
+    (TopCat.of S).Presheaf (Type 0) :=
+  TopCat.subpresheafToTypes (liftLocalPredicate S F).toPrelocalPredicate
+
+private abbrev SpecialPeriods.ModularGermLift.LiftSection (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ)
+    (V : TopologicalSpace.Opens S) :=
+  (liftPresheaf S F).obj (Opposite.op V)
+
+private theorem SpecialPeriods.ModularGermLift.liftSection_analytic (S : TopologicalSpace.Opens ℂ)
+    (F : ℂ → ℂ) {V : TopologicalSpace.Opens S} (s : LiftSection S F V) (x : V) :
+    AnalyticAt ℂ (extendLiftSection S V s.1) (AnalyticRootCover.ambientVal S V x) :=
+  (s.2 x).1
+
+private theorem SpecialPeriods.ModularGermLift.liftSection_modular (S : TopologicalSpace.Opens ℂ)
+    (F : ℂ → ℂ) {V : TopologicalSpace.Opens S} (s : LiftSection S F V) (x : V) :
+    SpecialPeriods.modularJ (s.1 x) = F (AnalyticRootCover.ambientVal S V x) :=
+  (s.2 x).2
+
+@[simp]
+private theorem SpecialPeriods.ModularGermLift.liftPresheaf_map_apply (S : TopologicalSpace.Opens ℂ)
+    (F : ℂ → ℂ) {U V : TopologicalSpace.Opens S} (i : U ⟶ V) (s : LiftSection S F V) (x : U) :
+    ((liftPresheaf S F).map i.op s).1 x = s.1 (Set.inclusion i.le x) :=
+  rfl
+
+private theorem SpecialPeriods.ModularGermLift.LiftSection.analyticOnNhd_extend
+    {S : TopologicalSpace.Opens ℂ} {F : ℂ → ℂ} {V : TopologicalSpace.Opens S}
+    (s : SpecialPeriods.ModularGermLift.LiftSection S F V) :
+    AnalyticOnNhd ℂ (SpecialPeriods.ModularGermLift.extendLiftSection S V s.1)
+      (AnalyticRootCover.ambientOpen S V) := by
+  intro z hz
+  obtain ⟨x, rfl⟩ := (AnalyticRootCover.mem_ambientOpen S V).mp hz
+  exact SpecialPeriods.ModularGermLift.liftSection_analytic S F s x
+
+private theorem
+    SpecialPeriods.ModularGermLift.LiftSection.mapsTo_extend {S : TopologicalSpace.Opens ℂ}
+    {F : ℂ → ℂ} {V : TopologicalSpace.Opens S}
+    (s : SpecialPeriods.ModularGermLift.LiftSection S F V) :
+    Set.MapsTo (SpecialPeriods.ModularGermLift.extendLiftSection S V s.1)
+      (AnalyticRootCover.ambientOpen S V) UpperHalfPlane.upperHalfPlaneSet := by
+  intro z hz
+  obtain ⟨x, rfl⟩ := (AnalyticRootCover.mem_ambientOpen S V).mp hz
+  rw [SpecialPeriods.ModularGermLift.extendLiftSection_apply]
+  exact (s.1 x).im_pos
+
+private theorem SpecialPeriods.ModularGermLift.LiftSection.modular_eq {S : TopologicalSpace.Opens ℂ}
+    {F : ℂ → ℂ} {V : TopologicalSpace.Opens S}
+    (s : SpecialPeriods.ModularGermLift.LiftSection S F V) {z : ℂ}
+    (hz : z ∈ AnalyticRootCover.ambientOpen S V) :
+    SpecialPeriods.modularJ
+        (UpperHalfPlane.ofComplex (SpecialPeriods.ModularGermLift.extendLiftSection S V s.1 z)) =
+      F z := by
+  obtain ⟨x, rfl⟩ := (AnalyticRootCover.mem_ambientOpen S V).mp hz
+  rw [SpecialPeriods.ModularGermLift.extendLiftSection_apply, UpperHalfPlane.ofComplex_apply]
+  exact SpecialPeriods.ModularGermLift.liftSection_modular S F s x
+
+@[ext]
+private theorem
+    SpecialPeriods.ModularGermLift.LiftSection.ext {S : TopologicalSpace.Opens ℂ} {F : ℂ → ℂ}
+    {V : TopologicalSpace.Opens S} {s t : SpecialPeriods.ModularGermLift.LiftSection S F V}
+    (he : ∀ x, s.1 x = t.1 x) : s = t :=
+  Subtype.ext (funext he)
+
+private def
+    SpecialPeriods.ModularGermLift.liftSectionOfComplex (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ)
+    {V : TopologicalSpace.Opens S} (r : ℂ → ℂ)
+    (hr : AnalyticOnNhd ℂ r (AnalyticRootCover.ambientOpen S V))
+    (hpos : Set.MapsTo r (AnalyticRootCover.ambientOpen S V) UpperHalfPlane.upperHalfPlaneSet)
+    (hJ :
+      Set.EqOn (fun z => SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (r z))) F
+        (AnalyticRootCover.ambientOpen S V)) :
+    LiftSection S F V := by
+  refine
+    ⟨fun x =>
+      ⟨r (AnalyticRootCover.ambientVal S V x), hpos (AnalyticRootCover.ambientVal_mem S V x)⟩,
+      fun x => ⟨?_, ?_⟩⟩
+  · apply (hr _ (AnalyticRootCover.ambientVal_mem S V x)).congr
+    filter_upwards [(AnalyticRootCover.ambientOpen S V).isOpen.mem_nhds
+        (AnalyticRootCover.ambientVal_mem S V x)] with
+      z hz
+    exact (AnalyticRootCover.extension_agreement S V r hz).symm
+  · simpa only [UpperHalfPlane.ofComplex_apply_of_im_pos
+          (hpos (AnalyticRootCover.ambientVal_mem S V x))] using
+      hJ (AnalyticRootCover.ambientVal_mem S V x)
+
+private theorem SpecialPeriods.ModularGermLift.extend_liftSectionOfComplex_eqOn
+    (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ) {V : TopologicalSpace.Opens S} (r : ℂ → ℂ)
+    (hr : AnalyticOnNhd ℂ r (AnalyticRootCover.ambientOpen S V))
+    (hpos : Set.MapsTo r (AnalyticRootCover.ambientOpen S V) UpperHalfPlane.upperHalfPlaneSet)
+    (hJ :
+      Set.EqOn (fun z => SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (r z))) F
+        (AnalyticRootCover.ambientOpen S V)) :
+    Set.EqOn (extendLiftSection S V (liftSectionOfComplex S F r hr hpos hJ).1) r
+      (AnalyticRootCover.ambientOpen S V) :=
+  AnalyticRootCover.extension_agreement S V r
+
+private theorem
+    SpecialPeriods.ModularGermLift.germ_eq_iff_eventuallyEq (S : TopologicalSpace.Opens ℂ)
+    (F : ℂ → ℂ) {U V : TopologicalSpace.Opens (TopCat.of S)} (x : S) (hxU : x ∈ U) (hxV : x ∈ V)
+    (s : LiftSection S F U) (t : LiftSection S F V) :
+    (liftPresheaf S F).germ U x hxU s = (liftPresheaf S F).germ V x hxV t ↔
+      extendLiftSection S U s.1 =ᶠ[𝓝 (x : ℂ)] extendLiftSection S V t.1 := by
+  constructor
+  · intro h
+    obtain ⟨W, hxW, iU, iV, hst⟩ := (liftPresheaf S F).germ_eq x hxU hxV s t h
+    have hxA : (x : ℂ) ∈ AnalyticRootCover.ambientOpen S W :=
+      AnalyticRootCover.ambientVal_mem S W ⟨x, hxW⟩
+    filter_upwards [(AnalyticRootCover.ambientOpen S W).isOpen.mem_nhds hxA] with z hz
+    obtain ⟨y, hyW, rfl⟩ := hz
+    have hval := congrArg (fun r : LiftSection S F W => r.1 ⟨y, hyW⟩) hst
+    rw [liftPresheaf_map_apply, liftPresheaf_map_apply] at hval
+    calc
+      extendLiftSection S U s.1 (y : ℂ) = (s.1 (Set.inclusion iU.le ⟨y, hyW⟩) : ℂ) :=
+        extendLiftSection_apply S U s.1 (Set.inclusion iU.le ⟨y, hyW⟩)
+      _ = (t.1 (Set.inclusion iV.le ⟨y, hyW⟩) : ℂ) := (congrArg (fun w : ℍ => (w : ℂ)) hval)
+      _ = extendLiftSection S V t.1 (y : ℂ) :=
+        (extendLiftSection_apply S V t.1 (Set.inclusion iV.le ⟨y, hyW⟩)).symm
+  · intro h
+    obtain ⟨A, hA, hAo, hxA⟩ := mem_nhds_iff.mp h
+    let B : TopologicalSpace.Opens (TopCat.of S) :=
+      TopologicalSpace.Opens.comap ⟨Subtype.val, continuous_subtype_val⟩ ⟨A, hAo⟩
+    let W : TopologicalSpace.Opens (TopCat.of S) := (U ⊓ V) ⊓ B
+    have hxW : x ∈ W := ⟨⟨hxU, hxV⟩, hxA⟩
+    let iU : W ⟶ U := CategoryTheory.homOfLE (inf_le_left.trans inf_le_left)
+    let iV : W ⟶ V := CategoryTheory.homOfLE (inf_le_left.trans inf_le_right)
+    apply (liftPresheaf S F).germ_ext W hxW iU iV
+    apply Subtype.ext
+    funext y
+    rw [liftPresheaf_map_apply, liftPresheaf_map_apply]
+    apply UpperHalfPlane.coe_injective
+    calc
+      (s.1 (Set.inclusion iU.le y) : ℂ) =
+          extendLiftSection S U s.1 (AnalyticRootCover.ambientVal S W y) :=
+        (extendLiftSection_apply S U s.1 (Set.inclusion iU.le y)).symm
+      _ = extendLiftSection S V t.1 (AnalyticRootCover.ambientVal S W y) := (hA y.2.2)
+      _ = (t.1 (Set.inclusion iV.le y) : ℂ) :=
+        extendLiftSection_apply S V t.1 (Set.inclusion iV.le y)
+
+private theorem
+    SpecialPeriods.exists_analytic_lift_through_power_chart {F G : ℂ → ℂ} {a b : ℂ} {m k : ℕ}
+    (hF : AnalyticAt ℂ F a) (horder : analyticOrderAt F a = (m * k : ℕ)) (hm : 0 < m) (hk : 0 < k)
+    (e : OpenPartialHomeomorph ℂ ℂ) (hb : b ∈ e.source) (he : e b = 0)
+    (hf : AnalyticOnNhd ℂ e e.source) (hi : AnalyticOnNhd ℂ e.symm e.target)
+    (hG : ∀ z ∈ e.target, G (e.symm z) = z ^ m) :
+    ∃ r : ℝ,
+      0 < r ∧
+        ∃ τ : ℂ → ℂ,
+          AnalyticOnNhd ℂ τ (Metric.ball a r) ∧
+            τ a = b ∧
+              Set.MapsTo τ (Metric.ball a r) e.source ∧
+                (∀ z ∈ Metric.ball a r, G (τ z) = F z) ∧
+                  analyticOrderAt (fun z => τ z - b) a = (k : ℕ∞) := by
+  obtain ⟨d, ha, hd, hdf, hdi, hp⟩ := exists_analytic_power_chart hF horder (Nat.mul_pos hm hk)
+  have ht : (0 : ℂ) ∈ e.target := he ▸ e.map_source hb
+  have hc : ContinuousAt (fun z : ℂ => d z ^ k) a := (hdf a ha).continuousAt.pow k
+  have hnear : ∀ᶠ z : ℂ in 𝓝 a, d z ^ k ∈ e.target := by
+    apply hc.preimage_mem_nhds
+    simpa only [hd, zero_pow hk.ne'] using e.open_target.mem_nhds ht
+  have hsrc : ∀ᶠ z : ℂ in 𝓝 a, z ∈ d.source := d.open_source.mem_nhds ha
+  obtain ⟨r, hr, hball⟩ := Metric.mem_nhds_iff.mp (hsrc.and hnear)
+  refine ⟨r, hr, fun z => e.symm (d z ^ k), ?_, ?_, ?_, ?_, ?_⟩
+  · intro z hz
+    exact (hi _ (hball hz).2).comp (f := fun w : ℂ => d w ^ k) ((hdf z (hball hz).1).pow k)
+  · change e.symm (d a ^ k) = b
+    rw [hd, zero_pow hk.ne', ← he, e.left_inv hb]
+  · intro z hz
+    exact e.map_target (hball hz).2
+  · intro z hz
+    change G (e.symm (d z ^ k)) = F z
+    rw [hG _ (hball hz).2, hp _ (hball hz).1, ← pow_mul, Nat.mul_comm k m]
+  · calc
+      analyticOrderAt (fun z => e.symm (d z ^ k) - b) a =
+          analyticOrderAt (fun z : ℂ => e.symm (z ^ k) - b) (d a) :=
+        analyticOrderAt_comp_of_deriv_ne_zero (f := fun z : ℂ => e.symm (z ^ k) - b) (hdf a ha)
+          (analytic_chart_deriv_ne_zero d ha hdf hdi)
+      _ = (k : ℕ∞) := by
+        rw [hd]
+        simpa only [one_mul] using
+          analytic_chart_inverse_power_order e hb he hf hi 1 one_ne_zero k hk
+
+private theorem
+    SpecialPeriods.exists_modularJ_lift_of_order_multiple_three {F : ℂ → ℂ} {a : ℂ} {k : ℕ}
+    (hF : AnalyticAt ℂ F a) (horder : analyticOrderAt F a = (3 * k : ℕ)) (hk : 0 < k) :
+    ∃ r : ℝ,
+      0 < r ∧
+        ∃ τ : ℂ → ℂ,
+          AnalyticOnNhd ℂ τ (Metric.ball a r) ∧
+            τ a = rho ∧
+              Set.MapsTo τ (Metric.ball a r) UpperHalfPlane.upperHalfPlaneSet ∧
+                (∀ z ∈ Metric.ball a r, modularJ (UpperHalfPlane.ofComplex (τ z)) = F z) ∧
+                  analyticOrderAt (fun z => τ z - rho) a = (k : ℕ∞) := by
+  obtain ⟨e, hb, he, hU, hf, hi, _, hp⟩ := modularJ_rhoPoint_cubic_chart
+  obtain ⟨r, hr, τ, hτ, hτa, hτU, hτj, hτord⟩ :=
+    exists_analytic_lift_through_power_chart (G := fun w => modularJ (UpperHalfPlane.ofComplex w))
+      hF horder (by decide : 0 < 3) hk e hb he hf hi hp
+  exact ⟨r, hr, τ, hτ, hτa, fun z hz => hU (hτU hz), hτj, hτord⟩
+
+private theorem
+    SpecialPeriods.exists_modularJ_lift_of_order_multiple_two {F : ℂ → ℂ} {a : ℂ} {k : ℕ}
+    (hF : AnalyticAt ℂ F a) (horder : analyticOrderAt (fun z => F z - 1728) a = (2 * k : ℕ))
+    (hk : 0 < k) :
+    ∃ r : ℝ,
+      0 < r ∧
+        ∃ τ : ℂ → ℂ,
+          AnalyticOnNhd ℂ τ (Metric.ball a r) ∧
+            τ a = Complex.I ∧
+              Set.MapsTo τ (Metric.ball a r) UpperHalfPlane.upperHalfPlaneSet ∧
+                (∀ z ∈ Metric.ball a r, modularJ (UpperHalfPlane.ofComplex (τ z)) = F z) ∧
+                  analyticOrderAt (fun z => τ z - Complex.I) a = (k : ℕ∞) := by
+  obtain ⟨e, hb, he, hU, hf, hi, _, hp⟩ := modularJ_I_quadratic_chart
+  obtain ⟨r, hr, τ, hτ, hτa, hτU, hτj, hτord⟩ :=
+    exists_analytic_lift_through_power_chart (G := fun w =>
+      modularJ (UpperHalfPlane.ofComplex w) - 1728) (hF.sub analyticAt_const) horder
+      (by decide : 0 < 2) hk e hb he hf hi hp
+  refine ⟨r, hr, τ, hτ, hτa, fun z hz => hU (hτU hz), ?_, hτord⟩
+  intro z hz
+  exact sub_left_inj.mp (hτj z hz)
+
+private theorem SpecialPeriods.ModularGermLift.exists_regular_local_lift_at {F : ℂ → ℂ} {a : ℂ}
+    (hF : AnalyticAt ℂ F a) (b : ℍ) (hb : SpecialPeriods.modularJ b = F a) (h₀ : F a ≠ 0)
+    (h₁ : F a ≠ 1728) :
+    ∃ r : ℝ,
+      0 < r ∧
+        ∃ τ : ℂ → ℂ,
+          AnalyticOnNhd ℂ τ (Metric.ball a r) ∧
+            τ a = (b : ℂ) ∧
+              Set.MapsTo τ (Metric.ball a r) UpperHalfPlane.upperHalfPlaneSet ∧
+                ∀ z ∈ Metric.ball a r,
+                  SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (τ z)) = F z := by
+  have hb₀ : SpecialPeriods.modularJ b ≠ 0 := hb ▸ h₀
+  have hb₁ : SpecialPeriods.modularJ b ≠ 1728 := hb ▸ h₁
+  let g : ℂ → ℂ := SpecialPeriods.modularLocalInverse b hb₀ hb₁
+  let τ : ℂ → ℂ := fun z => g (F z)
+  have hg : AnalyticAt ℂ g (F a) := by
+    rw [← hb]
+    exact SpecialPeriods.modularLocalInverse_analyticAt b hb₀ hb₁
+  have hτ : AnalyticAt ℂ τ a := hg.comp hF
+  have hτa : τ a = (b : ℂ) := by
+    dsimp only [τ]
+    rw [← hb]
+    simpa only [UpperHalfPlane.ofComplex_apply] using
+      (SpecialPeriods.modularLocalInverse_eventually_left_inverse b hb₀ hb₁).self_of_nhds
+  have hU : ∀ᶠ z in 𝓝 a, τ z ∈ UpperHalfPlane.upperHalfPlaneSet := by
+    apply hτ.continuousAt.preimage_mem_nhds
+    rw [hτa]
+    exact UpperHalfPlane.isOpen_upperHalfPlaneSet.mem_nhds b.im_pos
+  have hinv : ∀ᶠ w in 𝓝 (F a), SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (g w)) = w := by
+    rw [← hb]
+    exact SpecialPeriods.modularLocalInverse_eventually_right_inverse b hb₀ hb₁
+  have hj : ∀ᶠ z in 𝓝 a, SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (τ z)) = F z :=
+    hF.continuousAt.tendsto.eventually hinv
+  obtain ⟨r, hr, hball⟩ := Metric.mem_nhds_iff.mp (hτ.eventually_analyticAt.and (hU.and hj))
+  exact
+    ⟨r, hr, τ, fun z hz => (hball hz).1, hτa, fun z hz => (hball hz).2.1, fun z hz =>
+      (hball hz).2.2⟩
+
+private theorem SpecialPeriods.ModularGermLift.exists_local_lift {F : ℂ → ℂ} {a : ℂ}
+    (hF : AnalyticAt ℂ F a) (h₃ : F a = 0 → ∃ k : ℕ, analyticOrderAt F a = (3 * k : ℕ))
+    (h₂ : F a = 1728 → ∃ k : ℕ, analyticOrderAt (fun z => F z - 1728) a = (2 * k : ℕ)) :
+    ∃ r : ℝ,
+      0 < r ∧
+        ∃ τ : ℂ → ℂ,
+          AnalyticOnNhd ℂ τ (Metric.ball a r) ∧
+            Set.MapsTo τ (Metric.ball a r) UpperHalfPlane.upperHalfPlaneSet ∧
+              ∀ z ∈ Metric.ball a r,
+                SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (τ z)) = F z := by
+  by_cases ha₀ : F a = 0
+  · obtain ⟨k, hk⟩ := h₃ ha₀
+    have hkpos : 0 < k := by
+      apply Nat.pos_of_ne_zero
+      intro hk₀
+      exact
+        (hF.analyticOrderAt_ne_zero.mpr ha₀)
+          (by simpa only [hk₀, MulZeroClass.mul_zero, Nat.cast_zero] using hk)
+    obtain ⟨r, hr, τ, hτ, -, hU, hj, -⟩ :=
+      SpecialPeriods.exists_modularJ_lift_of_order_multiple_three hF hk hkpos
+    exact ⟨r, hr, τ, hτ, hU, hj⟩
+  · by_cases ha₁ : F a = 1728
+    · obtain ⟨k, hk⟩ := h₂ ha₁
+      have hkpos : 0 < k := by
+        apply Nat.pos_of_ne_zero
+        intro hk₀
+        have hshift : AnalyticAt ℂ (fun z => F z - 1728) a := hF.sub analyticAt_const
+        have hn : analyticOrderAt (fun z => F z - 1728) a ≠ 0 :=
+          hshift.analyticOrderAt_ne_zero.mpr (sub_eq_zero.mpr ha₁)
+        exact hn (by simpa only [hk₀, MulZeroClass.mul_zero, Nat.cast_zero] using hk)
+      obtain ⟨r, hr, τ, hτ, -, hU, hj, -⟩ :=
+        SpecialPeriods.exists_modularJ_lift_of_order_multiple_two hF hk hkpos
+      exact ⟨r, hr, τ, hτ, hU, hj⟩
+    · obtain ⟨b, hb⟩ := SpecialPeriods.modularJ_surjective (F a)
+      obtain ⟨r, hr, τ, hτ, -, hU, hj⟩ := exists_regular_local_lift_at hF b hb ha₀ ha₁
+      exact ⟨r, hr, τ, hτ, hU, hj⟩
+
+private theorem SpecialPeriods.ModularGermLift.exists_local_lift_ball_subset {F : ℂ → ℂ} {a : ℂ}
+    {S : Set ℂ} (hS : IsOpen S) (ha : a ∈ S) (hF : AnalyticAt ℂ F a)
+    (h₃ : F a = 0 → ∃ k : ℕ, analyticOrderAt F a = (3 * k : ℕ))
+    (h₂ : F a = 1728 → ∃ k : ℕ, analyticOrderAt (fun z => F z - 1728) a = (2 * k : ℕ)) :
+    ∃ r : ℝ,
+      0 < r ∧
+        Metric.ball a r ⊆ S ∧
+          ∃ τ : ℂ → ℂ,
+            AnalyticOnNhd ℂ τ (Metric.ball a r) ∧
+              Set.MapsTo τ (Metric.ball a r) UpperHalfPlane.upperHalfPlaneSet ∧
+                ∀ z ∈ Metric.ball a r,
+                  SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (τ z)) = F z := by
+  obtain ⟨r, hr, τ, hτ, hU, hj⟩ := exists_local_lift hF h₃ h₂
+  obtain ⟨s, hs, hsS⟩ := Metric.mem_nhds_iff.mp (hS.mem_nhds ha)
+  have hsub : Metric.ball a (Min.min r s) ⊆ Metric.ball a r :=
+    Metric.ball_subset_ball (min_le_left _ _)
+  refine
+    ⟨Min.min r s, lt_min hr hs, (Metric.ball_subset_ball (min_le_right _ _)).trans hsS, τ,
+      hτ.mono hsub, ?_, ?_⟩
+  · exact hU.mono_left hsub
+  · exact fun z hz => hj z (hsub hz)
+
+private theorem
+    AnalyticRootCover.eventuallyEq_zero_or_eventuallyEq_zero_of_mul_eq_zero {r s : ℂ → ℂ}
+    {a : ℂ} (hr : AnalyticAt ℂ r a) (hs : AnalyticAt ℂ s a) (hmul : ∀ᶠ z in 𝓝 a, r z * s z = 0) :
+    r =ᶠ[𝓝 a] 0 ∨ s =ᶠ[𝓝 a] 0 := by
+  have hfrequent : ∃ᶠ z in 𝓝[≠] a, r z = 0 ∨ s z = 0 := by
+    apply (hmul.filter_mono nhdsWithin_le_nhds).frequently.mono
+    intro z hz
+    exact mul_eq_zero.mp hz
+  rcases Filter.frequently_or_distrib.mp hfrequent with hrzero | hszero
+  · exact Or.inl (hr.frequently_zero_iff_eventually_zero.mp hrzero)
+  · exact Or.inr (hs.frequently_zero_iff_eventually_zero.mp hszero)
+
+private theorem AnalyticRootCover.eventuallyEq_or_neg_of_sq_eq {r s : ℂ → ℂ} {a : ℂ}
+    (hr : AnalyticAt ℂ r a) (hs : AnalyticAt ℂ s a)
+    (hsq : (fun z => r z ^ 2) =ᶠ[𝓝 a] (fun z => s z ^ 2)) :
+    r =ᶠ[𝓝 a] s ∨ r =ᶠ[𝓝 a] (fun z => -s z) := by
+  have hmul : ∀ᶠ z in 𝓝 a, (r - s) z * (r + s) z = 0 := by
+    filter_upwards [hsq] with z hz
+    calc
+      (r - s) z * (r + s) z = r z ^ 2 - s z ^ 2 := by dsimp; ring
+      _ = 0 := sub_eq_zero.mpr hz
+  rcases eventuallyEq_zero_or_eventuallyEq_zero_of_mul_eq_zero (hr.sub hs) (hr.add hs) hmul with
+    hsub | hadd
+  · exact Or.inl (hsub.mono fun z hz => sub_eq_zero.mp hz)
+  · exact Or.inr (hadd.mono fun z hz => eq_neg_iff_add_eq_zero.mpr hz)
+
+private theorem AnalyticRootCover.eqOn_of_eventuallyEq {r s : ℂ → ℂ} {V : Set ℂ} {a : ℂ}
+    (hr : AnalyticOnNhd ℂ r V) (hs : AnalyticOnNhd ℂ s V) (hV : IsPreconnected V) (ha : a ∈ V)
+    (heq : r =ᶠ[𝓝 a] s) : Set.EqOn r s V :=
+  hr.eqOn_of_preconnected_of_eventuallyEq hs hV ha heq
+
+private theorem AnalyticRootCover.exists_analytic_square_root {F : ℂ → ℂ} {a : ℂ} {n : ℕ}
+    (hF : AnalyticAt ℂ F a) (horder : analyticOrderAt F a = (2 * n : ℕ)) :
+    ∃ r : ℂ → ℂ, AnalyticAt ℂ r a ∧ (∀ᶠ z in 𝓝 a, r z ^ 2 = F z) ∧ analyticOrderAt r a = n := by
+  obtain ⟨u, hu, hua, hFu⟩ := hF.analyticOrderAt_eq_natCast.mp horder
+  obtain ⟨q, hq, hqa, hqpow⟩ :=
+    SpecialPeriods.exists_analytic_unit_root hu hua (by norm_num : 0 < (2 : ℕ))
+  let r : ℂ → ℂ := fun z => (z - a) ^ n * q z
+  have hr : AnalyticAt ℂ r a := ((analyticAt_id.sub analyticAt_const).pow n).mul hq
+  refine ⟨r, hr, ?_, ?_⟩
+  · filter_upwards [hFu, hqpow] with z hFz hqz
+    change ((z - a) ^ n * q z) ^ 2 = F z
+    rw [mul_pow, hqz, ← pow_mul, Nat.mul_comm n 2]
+    simpa only [smul_eq_mul] using hFz.symm
+  · apply hr.analyticOrderAt_eq_natCast.mpr
+    refine ⟨q, hq, hqa, ?_⟩
+    exact Filter.Eventually.of_forall (fun _ => rfl)
+
+private theorem
+    AnalyticRootCover.exists_analytic_square_root_ball {F : ℂ → ℂ} {a : ℂ} {n : ℕ} {S : Set ℂ}
+    (hF : AnalyticAt ℂ F a) (horder : analyticOrderAt F a = (2 * n : ℕ)) (hS : S ∈ 𝓝 a) :
+    ∃ ε > 0,
+      ∃ r : ℂ → ℂ,
+        Metric.ball a ε ⊆ S ∧
+          AnalyticOnNhd ℂ r (Metric.ball a ε) ∧
+            Set.EqOn (fun z => r z ^ 2) F (Metric.ball a ε) ∧ analyticOrderAt r a = n := by
+  obtain ⟨r, hr, hroot, horderR⟩ := exists_analytic_square_root hF horder
+  have hn : {z | z ∈ S ∧ AnalyticAt ℂ r z ∧ r z ^ 2 = F z} ∈ 𝓝 a :=
+    Filter.Eventually.and hS (hr.eventually_analyticAt.and hroot)
+  obtain ⟨ε, hε, hball⟩ := Metric.mem_nhds_iff.mp hn
+  refine ⟨ε, hε, r, ?_, ?_, ?_, horderR⟩
+  · exact fun z hz => (hball hz).1
+  · exact fun z hz => (hball hz).2.1
+  · exact fun z hz => (hball hz).2.2
+
+private theorem
+    AnalyticRootCover.germ_eq_iff_eventuallyEq (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ)
+    {U V : TopologicalSpace.Opens (TopCat.of S)} (x : S) (hxU : x ∈ U) (hxV : x ∈ V)
+    (s : RootSection S F U) (t : RootSection S F V) :
+    (rootPresheaf S F).germ U x hxU s = (rootPresheaf S F).germ V x hxV t ↔
+      extendSection S U s.1 =ᶠ[𝓝 (x : ℂ)] extendSection S V t.1 := by
+  constructor
+  · intro h
+    obtain ⟨W, hxW, iU, iV, hst⟩ := (rootPresheaf S F).germ_eq x hxU hxV s t h
+    have hxA : (x : ℂ) ∈ ambientOpen S W := ambientVal_mem S W ⟨x, hxW⟩
+    filter_upwards [(ambientOpen S W).isOpen.mem_nhds hxA] with z hz
+    obtain ⟨y, hyW, rfl⟩ := hz
+    have hval := congrArg (fun r : RootSection S F W => r.1 ⟨y, hyW⟩) hst
+    rw [rootPresheaf_map_apply, rootPresheaf_map_apply] at hval
+    calc
+      extendSection S U s.1 (y : ℂ) = s.1 (Set.inclusion iU.le ⟨y, hyW⟩) :=
+        extendSection_apply S U s.1 (Set.inclusion iU.le ⟨y, hyW⟩)
+      _ = t.1 (Set.inclusion iV.le ⟨y, hyW⟩) := hval
+      _ = extendSection S V t.1 (y : ℂ) :=
+        (extendSection_apply S V t.1 (Set.inclusion iV.le ⟨y, hyW⟩)).symm
+  · intro h
+    obtain ⟨A, hA, hAo, hxA⟩ := mem_nhds_iff.mp h
+    let B : TopologicalSpace.Opens (TopCat.of S) :=
+      TopologicalSpace.Opens.comap ⟨Subtype.val, continuous_subtype_val⟩ ⟨A, hAo⟩
+    let W : TopologicalSpace.Opens (TopCat.of S) := (U ⊓ V) ⊓ B
+    have hxW : x ∈ W := ⟨⟨hxU, hxV⟩, hxA⟩
+    let iU : W ⟶ U := CategoryTheory.homOfLE (inf_le_left.trans inf_le_left)
+    let iV : W ⟶ V := CategoryTheory.homOfLE (inf_le_left.trans inf_le_right)
+    apply (rootPresheaf S F).germ_ext W hxW iU iV
+    apply Subtype.ext
+    funext y
+    rw [rootPresheaf_map_apply, rootPresheaf_map_apply]
+    calc
+      s.1 (Set.inclusion iU.le y) = extendSection S U s.1 (ambientVal S W y) :=
+        (extendSection_apply S U s.1 (Set.inclusion iU.le y)).symm
+      _ = extendSection S V t.1 (ambientVal S W y) := (hA y.2.2)
+      _ = t.1 (Set.inclusion iV.le y) := extendSection_apply S V t.1 (Set.inclusion iV.le y)
+
+private def AnalyticRootCover.RootSection.neg {S : TopologicalSpace.Opens ℂ} {F : ℂ → ℂ}
+    {U : TopologicalSpace.Opens S} (s : AnalyticRootCover.RootSection S F U) :
+    AnalyticRootCover.RootSection S F U :=
+  AnalyticRootCover.rootSectionOfAnalytic S F
+    (fun z => -AnalyticRootCover.extendSection S U s.1 z) (analyticOnNhd_extend s).neg
+    (fun x => by
+      rw [neg_sq]
+      exact square_eq s (AnalyticRootCover.ambientVal_mem S U x))
+
+private theorem
+    AnalyticRootCover.RootSection.extend_neg_eqOn {S : TopologicalSpace.Opens ℂ} {F : ℂ → ℂ}
+    {U : TopologicalSpace.Opens S} (s : AnalyticRootCover.RootSection S F U) :
+    Set.EqOn (AnalyticRootCover.extendSection S U s.neg.1)
+      (fun z => -AnalyticRootCover.extendSection S U s.1 z) (AnalyticRootCover.ambientOpen S U) :=
+  by exact AnalyticRootCover.extend_rootSectionOfAnalytic_eqOn S F _ _ _
+
+private theorem AnalyticRootCover.germ_eq_or_neg {S : TopologicalSpace.Opens ℂ} {F : ℂ → ℂ}
+    {U V : TopologicalSpace.Opens S} (x : S) (hxU : x ∈ U) (hxV : x ∈ V) (s : RootSection S F U)
+    (t : RootSection S F V) :
+    (rootPresheaf S F).germ V x hxV t = (rootPresheaf S F).germ U x hxU s ∨
+      (rootPresheaf S F).germ V x hxV t = (rootPresheaf S F).germ U x hxU s.neg := by
+  have hxUA : (x : ℂ) ∈ ambientOpen S U := (coe_mem_ambientOpen S U x).mpr hxU
+  have hxVA : (x : ℂ) ∈ ambientOpen S V := (coe_mem_ambientOpen S V x).mpr hxV
+  have hsquare :
+    (fun z => extendSection S V t.1 z ^ 2) =ᶠ[𝓝 (x : ℂ)] (fun z => extendSection S U s.1 z ^ 2) :=
+    by
+    filter_upwards [(ambientOpen S U).isOpen.mem_nhds hxUA,
+      (ambientOpen S V).isOpen.mem_nhds hxVA] with z hzU hzV
+    exact (RootSection.square_eq t hzV).trans (RootSection.square_eq s hzU).symm
+  rcases
+    eventuallyEq_or_neg_of_sq_eq (RootSection.analyticOnNhd_extend t _ hxVA)
+      (RootSection.analyticOnNhd_extend s _ hxUA) hsquare with
+    hpos | hneg
+  · exact Or.inl ((germ_eq_iff_eventuallyEq S F x hxV hxU t s).mpr hpos)
+  · apply Or.inr
+    apply (germ_eq_iff_eventuallyEq S F x hxV hxU t s.neg).mpr
+    filter_upwards [hneg, (ambientOpen S U).isOpen.mem_nhds hxUA] with z hz hzU
+    exact hz.trans (RootSection.extend_neg_eqOn s hzU).symm
+
+private theorem AnalyticRootCover.germ_injective {S : TopologicalSpace.Opens ℂ} {F : ℂ → ℂ}
+    {U : TopologicalSpace.Opens S} (hU : IsPreconnected (ambientOpen S U : Set ℂ)) (x : S)
+    (hx : x ∈ U) : Function.Injective ((rootPresheaf S F).germ U x hx) := by
+  intro s t hst
+  have he :=
+    eqOn_of_eventuallyEq (RootSection.analyticOnNhd_extend s) (RootSection.analyticOnNhd_extend t)
+      hU ((coe_mem_ambientOpen S U x).mpr hx) ((germ_eq_iff_eventuallyEq S F x hx hx s t).mp hst)
+  apply RootSection.ext
+  intro y
+  simpa only [extendSection_apply] using he (ambientVal_mem S U y)
+
+private theorem AnalyticRootCover.germ_surjective {S : TopologicalSpace.Opens ℂ} {F : ℂ → ℂ}
+    {U : TopologicalSpace.Opens S} (s : RootSection S F U) (x : S) (hx : x ∈ U) :
+    Function.Surjective ((rootPresheaf S F).germ U x hx) := by
+  intro g
+  obtain ⟨V, hxV, t, ht⟩ := (rootPresheaf S F).exists_germ_eq g
+  rcases germ_eq_or_neg x hx hxV s t with hpos | hneg
+  · exact ⟨s, hpos.symm.trans ht⟩
+  · exact ⟨s.neg, hneg.symm.trans ht⟩
+
+private theorem AnalyticRootCover.germ_bijective {S : TopologicalSpace.Opens ℂ} {F : ℂ → ℂ}
+    {U : TopologicalSpace.Opens S} (hU : IsPreconnected (ambientOpen S U : Set ℂ))
+    (s : RootSection S F U) (x : S) (hx : x ∈ U) :
+    Function.Bijective ((rootPresheaf S F).germ U x hx) :=
+  ⟨germ_injective hU x hx, germ_surjective s x hx⟩
+
+private theorem AnalyticRootCover.ambientOpen_comap_of_subset (S : TopologicalSpace.Opens ℂ)
+    (A : TopologicalSpace.Opens ℂ) (hAS : A ≤ S) :
+    ambientOpen S (TopologicalSpace.Opens.comap ⟨Subtype.val, continuous_subtype_val⟩ A) = A := by
+  ext z
+  constructor
+  · rintro ⟨x, hx, rfl⟩
+    exact hx
+  · intro hz
+    exact ⟨⟨z, hAS hz⟩, hz, rfl⟩
+
+private theorem
+    AnalyticRootCover.exists_root_neighborhood (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ)
+    (hF : AnalyticOnNhd ℂ F S) (horder : ∀ a ∈ S, ∃ n : ℕ, analyticOrderAt F a = (2 * n : ℕ))
+    (x : S) :
+    ∃ U : TopologicalSpace.Opens S,
+      x ∈ U ∧ IsPreconnected (ambientOpen S U : Set ℂ) ∧ Nonempty (RootSection S F U) := by
+  obtain ⟨n, hn⟩ := horder x x.2
+  obtain ⟨ε, hε, r, hball, hr, hsquare, _⟩ :=
+    exists_analytic_square_root_ball (hF x x.2) hn (S.isOpen.mem_nhds x.2)
+  let A : TopologicalSpace.Opens ℂ := ⟨Metric.ball (x : ℂ) ε, Metric.isOpen_ball⟩
+  let U : TopologicalSpace.Opens S :=
+    TopologicalSpace.Opens.comap ⟨Subtype.val, continuous_subtype_val⟩ A
+  have hUA : ambientOpen S U = A := ambientOpen_comap_of_subset S A hball
+  have hxU : x ∈ U := Metric.mem_ball_self hε
+  refine ⟨U, hxU, ?_, ?_⟩
+  · rw [hUA]
+    exact (convex_ball (x : ℂ) ε).isPreconnected
+  · have hrU : AnalyticOnNhd ℂ r (ambientOpen S U) := by rwa [hUA]
+    refine ⟨rootSectionOfAnalytic S F r hrU (fun y => hsquare ?_)⟩
+    have hy := ambientVal_mem S U y
+    rwa [hUA] at hy
+
+private theorem AnalyticRootCover.rootPresheaf_locally_bijective (S : TopologicalSpace.Opens ℂ)
+    (F : ℂ → ℂ) (hF : AnalyticOnNhd ℂ F S)
+    (horder : ∀ a ∈ S, ∃ n : ℕ, analyticOrderAt F a = (2 * n : ℕ)) :
+    ∀ x : S,
+      ∃ U : TopologicalSpace.Opens S,
+        x ∈ U ∧ ∀ y (hy : y ∈ U), Function.Bijective ((rootPresheaf S F).germ U y hy) := by
+  intro x
+  obtain ⟨U, hx, hU, ⟨s⟩⟩ := exists_root_neighborhood S F hF horder x
+  exact ⟨U, hx, fun y hy => germ_bijective hU s y hy⟩
+
+private theorem AnalyticRootCover.rootStalk_nonempty (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ)
+    (hF : AnalyticOnNhd ℂ F S) (horder : ∀ a ∈ S, ∃ n : ℕ, analyticOrderAt F a = (2 * n : ℕ))
+    (x : S) : Nonempty ((rootPresheaf S F).stalk x) := by
+  obtain ⟨U, hx, _, ⟨s⟩⟩ := exists_root_neighborhood S F hF horder x
+  exact ⟨(rootPresheaf S F).germ U x hx s⟩
+
+private def
+    SpecialPeriods.ModularGermLift.LiftSection.smul {S : TopologicalSpace.Opens ℂ} {F : ℂ → ℂ}
+    {U : TopologicalSpace.Opens S} (s : SpecialPeriods.ModularGermLift.LiftSection S F U)
+    (γ : SL(2, ℤ)) : SpecialPeriods.ModularGermLift.LiftSection S F U :=
+  SpecialPeriods.ModularGermLift.liftSectionOfComplex S F
+    (fun z =>
+      ((γ •
+            UpperHalfPlane.ofComplex
+              (SpecialPeriods.ModularGermLift.extendLiftSection S U s.1 z) :
+          ℍ) :
+        ℂ))
+    (SpecialPeriods.ModularGermLift.analyticOnNhd_modular_smul γ s.analyticOnNhd_extend
+      s.mapsTo_extend)
+    (fun _ _ => (γ • UpperHalfPlane.ofComplex _).im_pos)
+    (fun _ hz =>
+      (SpecialPeriods.ModularGermLift.modularJ_modular_smul γ _).trans (s.modular_eq hz))
+
+private theorem
+    SpecialPeriods.ModularGermLift.LiftSection.extend_smul_eqOn {S : TopologicalSpace.Opens ℂ}
+    {F : ℂ → ℂ} {U : TopologicalSpace.Opens S}
+    (s : SpecialPeriods.ModularGermLift.LiftSection S F U) (γ : SL(2, ℤ)) :
+    Set.EqOn (SpecialPeriods.ModularGermLift.extendLiftSection S U (s.smul γ).1)
+      (fun z =>
+        ((γ •
+              UpperHalfPlane.ofComplex
+                (SpecialPeriods.ModularGermLift.extendLiftSection S U s.1 z) :
+            ℍ) :
+          ℂ))
+      (AnalyticRootCover.ambientOpen S U) :=
+  SpecialPeriods.ModularGermLift.extend_liftSectionOfComplex_eqOn S F _ _ _ _
+
+private theorem
+    SpecialPeriods.ModularGermLift.germ_eq_smul {S : TopologicalSpace.Opens ℂ} {F : ℂ → ℂ}
+    {U V : TopologicalSpace.Opens S} (x : S) (hxU : x ∈ U) (hxV : x ∈ V) (s : LiftSection S F U)
+    (t : LiftSection S F V) :
+    ∃ γ : SL(2, ℤ),
+      (liftPresheaf S F).germ V x hxV t = (liftPresheaf S F).germ U x hxU (s.smul γ) := by
+  have hxUA : (x : ℂ) ∈ AnalyticRootCover.ambientOpen S U :=
+    (AnalyticRootCover.coe_mem_ambientOpen S U x).mpr hxU
+  have hxVA : (x : ℂ) ∈ AnalyticRootCover.ambientOpen S V :=
+    (AnalyticRootCover.coe_mem_ambientOpen S V x).mpr hxV
+  have hJ :
+    (fun z =>
+        SpecialPeriods.modularJ
+          (UpperHalfPlane.ofComplex (extendLiftSection S V t.1 z))) =ᶠ[𝓝 (x : ℂ)]
+      (fun z =>
+        SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (extendLiftSection S U s.1 z))) := by
+    filter_upwards [(AnalyticRootCover.ambientOpen S U).isOpen.mem_nhds hxUA,
+      (AnalyticRootCover.ambientOpen S V).isOpen.mem_nhds hxVA] with z hzU hzV
+    exact (t.modular_eq hzV).trans (s.modular_eq hzU).symm
+  obtain ⟨γ, hγ⟩ :=
+    exists_modular_alignment_germ (t.analyticOnNhd_extend _ hxVA) (s.analyticOnNhd_extend _ hxUA)
+      (t.mapsTo_extend hxVA) (s.mapsTo_extend hxUA) hJ
+  refine ⟨γ, (germ_eq_iff_eventuallyEq S F x hxV hxU t (s.smul γ)).mpr ?_⟩
+  filter_upwards [hγ, (AnalyticRootCover.ambientOpen S U).isOpen.mem_nhds hxUA] with z hz hzU
+  exact hz.trans (s.extend_smul_eqOn γ hzU).symm
+
+private theorem
+    SpecialPeriods.ModularGermLift.germ_injective {S : TopologicalSpace.Opens ℂ} {F : ℂ → ℂ}
+    {U : TopologicalSpace.Opens S}
+    (hU : IsPreconnected (AnalyticRootCover.ambientOpen S U : Set ℂ)) (x : S) (hx : x ∈ U) :
+    Function.Injective ((liftPresheaf S F).germ U x hx) := by
+  intro s t hst
+  have he :=
+    AnalyticRootCover.eqOn_of_eventuallyEq (LiftSection.analyticOnNhd_extend s)
+      (LiftSection.analyticOnNhd_extend t) hU
+      ((AnalyticRootCover.coe_mem_ambientOpen S U x).mpr hx)
+      ((germ_eq_iff_eventuallyEq S F x hx hx s t).mp hst)
+  apply LiftSection.ext
+  intro y
+  apply UpperHalfPlane.coe_injective
+  simpa only [extendLiftSection_apply] using he (AnalyticRootCover.ambientVal_mem S U y)
+
+private theorem
+    SpecialPeriods.ModularGermLift.germ_surjective {S : TopologicalSpace.Opens ℂ} {F : ℂ → ℂ}
+    {U : TopologicalSpace.Opens S} (s : LiftSection S F U) (x : S) (hx : x ∈ U) :
+    Function.Surjective ((liftPresheaf S F).germ U x hx) := by
+  intro g
+  obtain ⟨V, hxV, t, ht⟩ := (liftPresheaf S F).exists_germ_eq g
+  obtain ⟨γ, hγ⟩ := germ_eq_smul x hx hxV s t
+  exact ⟨s.smul γ, hγ.symm.trans ht⟩
+
+private theorem
+    SpecialPeriods.ModularGermLift.germ_bijective {S : TopologicalSpace.Opens ℂ} {F : ℂ → ℂ}
+    {U : TopologicalSpace.Opens S}
+    (hU : IsPreconnected (AnalyticRootCover.ambientOpen S U : Set ℂ)) (s : LiftSection S F U)
+    (x : S) (hx : x ∈ U) : Function.Bijective ((liftPresheaf S F).germ U x hx) :=
+  ⟨germ_injective hU x hx, germ_surjective s x hx⟩
+
+private theorem
+    SpecialPeriods.ModularGermLift.exists_lift_neighborhood (S : TopologicalSpace.Opens ℂ)
+    (F : ℂ → ℂ) (hF : AnalyticOnNhd ℂ F S)
+    (h₃ : ∀ a ∈ S, F a = 0 → ∃ k : ℕ, analyticOrderAt F a = (3 * k : ℕ))
+    (h₂ : ∀ a ∈ S, F a = 1728 → ∃ k : ℕ, analyticOrderAt (fun z => F z - 1728) a = (2 * k : ℕ))
+    (x : S) :
+    ∃ U : TopologicalSpace.Opens S,
+      x ∈ U ∧
+        IsPreconnected (AnalyticRootCover.ambientOpen S U : Set ℂ) ∧
+          Nonempty (LiftSection S F U) := by
+  obtain ⟨r, hr, hball, τ, hτ, hpos, hJ⟩ :=
+    exists_local_lift_ball_subset S.isOpen x.2 (hF x x.2) (h₃ x x.2) (h₂ x x.2)
+  let A : TopologicalSpace.Opens ℂ := ⟨Metric.ball (x : ℂ) r, Metric.isOpen_ball⟩
+  let U : TopologicalSpace.Opens S :=
+    TopologicalSpace.Opens.comap ⟨Subtype.val, continuous_subtype_val⟩ A
+  have hUA : AnalyticRootCover.ambientOpen S U = A :=
+    AnalyticRootCover.ambientOpen_comap_of_subset S A hball
+  refine ⟨U, Metric.mem_ball_self hr, ?_, ?_⟩
+  · rw [hUA]
+    exact (convex_ball (x : ℂ) r).isPreconnected
+  · have hτU : AnalyticOnNhd ℂ τ (AnalyticRootCover.ambientOpen S U) := by rwa [hUA]
+    have hposU :
+      Set.MapsTo τ (AnalyticRootCover.ambientOpen S U) UpperHalfPlane.upperHalfPlaneSet := by
+      rwa [hUA]
+    refine ⟨liftSectionOfComplex S F τ hτU hposU ?_⟩
+    intro z hz
+    apply hJ z
+    rwa [hUA] at hz
+
+private theorem SpecialPeriods.ModularGermLift.liftPresheaf_locally_bijective
+    (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ) (hF : AnalyticOnNhd ℂ F S)
+    (h₃ : ∀ a ∈ S, F a = 0 → ∃ k : ℕ, analyticOrderAt F a = (3 * k : ℕ))
+    (h₂ : ∀ a ∈ S, F a = 1728 → ∃ k : ℕ, analyticOrderAt (fun z => F z - 1728) a = (2 * k : ℕ)) :
+    ∀ x : S,
+      ∃ U : TopologicalSpace.Opens S,
+        x ∈ U ∧ ∀ y (hy : y ∈ U), Function.Bijective ((liftPresheaf S F).germ U y hy) := by
+  intro x
+  obtain ⟨U, hx, hU, ⟨s⟩⟩ := exists_lift_neighborhood S F hF h₃ h₂ x
+  exact ⟨U, hx, fun y hy => germ_bijective hU s y hy⟩
+
+private theorem
+    AnalyticRootCover.square_root_order {f r : ℂ → ℂ} {a : ℂ} {n : ℕ} (hr : AnalyticAt ℂ r a)
+    (heq : (fun z => r z ^ 2) =ᶠ[𝓝 a] f) (horder : analyticOrderAt f a = (2 * n : ℕ)) :
+    analyticOrderAt r a = n := by
+  have hpow : 2 • analyticOrderAt r a = (2 * n : ℕ) := by
+    rw [← analyticOrderAt_pow hr 2]
+    exact (analyticOrderAt_congr heq).trans horder
+  have hfin : analyticOrderAt r a ≠ ⊤ := by
+    intro ht
+    simp only [ht, two_nsmul, top_add, ENat.top_ne_natCast] at hpow
+  obtain ⟨k, hk⟩ := ENat.ne_top_iff_exists.mp hfin
+  rw [← hk] at hpow
+  have hkn : k = n := by
+    rw [two_nsmul] at hpow
+    have he : k + k = 2 * n := by exact_mod_cast hpow
+    omega
+  rw [← hk, hkn]
+
+private theorem AnalyticRootCover.even_order_at_all_points {f : ℂ → ℂ} {U : Set ℂ}
+    (hf : AnalyticOnNhd ℂ f U)
+    (hzero : ∀ a ∈ U, f a = 0 → ∃ n : ℕ, analyticOrderAt f a = (2 * n : ℕ)) :
+    ∀ a ∈ U, ∃ n : ℕ, analyticOrderAt f a = (2 * n : ℕ) := by
+  intro a ha
+  by_cases hfa : f a = 0
+  · exact hzero a ha hfa
+  · exact
+      ⟨0, by
+        simpa only [MulZeroClass.mul_zero, Nat.cast_zero] using
+          (hf a ha).analyticOrderAt_eq_zero.mpr hfa⟩
+
+private abbrev AnalyticRootCoverContinuation.predicatePresheaf {X : TopCat.{0}} {Y : Type}
+    (P : TopCat.LocalPredicate (fun _ : X => Y)) : TopCat.Presheaf (Type) X :=
+  TopCat.subpresheafToTypes P.toPrelocalPredicate
+
+private def AnalyticRootCoverContinuation.etaleValue {X : TopCat.{0}} {Y : Type}
+    (P : TopCat.LocalPredicate (fun _ : X => Y)) (g : (predicatePresheaf P).EtaleSpace) : Y :=
+  TopCat.stalkToFiber P g.base g.germ
+
+private def AnalyticRootCoverContinuation.sectionGerm {X : TopCat.{0}} {Y : Type}
+    (P : TopCat.LocalPredicate (fun _ : X => Y)) (U : TopologicalSpace.Opens X)
+    (s : (predicatePresheaf P).obj (Opposite.op U)) (x : U) : (predicatePresheaf P).EtaleSpace :=
+  ⟨x.1, (predicatePresheaf P).germ U x.1 x.2 s⟩
+
+private theorem AnalyticRootCoverContinuation.etaleValue_sectionGerm {X : TopCat.{0}} {Y : Type}
+    (P : TopCat.LocalPredicate (fun _ : X => Y)) (U : TopologicalSpace.Opens X)
+    (s : (predicatePresheaf P).obj (Opposite.op U)) (x : U) :
+    etaleValue P (sectionGerm P U s x) = s.1 x :=
+  TopCat.stalkToFiber_germ P U x.1 x.2 s
+
+private theorem AnalyticRootCoverContinuation.etaleSection_localGerms {X : TopCat.{0}} {Y : Type}
+    (P : TopCat.LocalPredicate (fun _ : X => Y)) (σ : C(X, (predicatePresheaf P).EtaleSpace))
+    (hσ : ∀ x : X, (σ x).base = x) (x : X) :
+    ∃ (U : TopologicalSpace.Opens X) (_hx : x ∈ U) (s :
+      (predicatePresheaf P).obj (Opposite.op U)),
+      ∀ (y : X) (hy : y ∈ U), σ y = sectionGerm P U s ⟨y, hy⟩ := by
+  obtain ⟨U, hxU, s, hs⟩ :=
+    TopCat.Presheaf.EtaleSpace.exists_section_of_tendsto (σ.continuous.continuousAt (x := x))
+  have hvalues : ∀ᶠ y in 𝓝 x, ∃ hy : y ∈ U, σ y = sectionGerm P U s ⟨y, hy⟩ := by
+    filter_upwards [hs] with y hy
+    obtain ⟨hyU, hg⟩ := hy
+    refine ⟨hσ y ▸ hyU, ?_⟩
+    calc
+      σ y = sectionGerm P U s ⟨(σ y).base, hyU⟩ := by
+        change σ y = ⟨(σ y).base, (predicatePresheaf P).germ U (σ y).base hyU s⟩
+        rw [← hg]
+      _ = sectionGerm P U s ⟨y, hσ y ▸ hyU⟩ := congrArg (sectionGerm P U s) (Subtype.ext (hσ y))
+  obtain ⟨V, hV, hVo, hxV⟩ := eventually_nhds_iff.mp hvalues
+  let W : TopologicalSpace.Opens X := ⟨V, hVo⟩
+  have hWU : W ≤ U := fun y hy => (hV y hy).choose
+  let i : W ⟶ U := CategoryTheory.homOfLE hWU
+  refine ⟨W, hxV, (predicatePresheaf P).map i.op s, ?_⟩
+  intro y hy
+  have hg := (hV y hy).choose_spec
+  convert hg using 1
+  dsimp only [sectionGerm]
+  rw [(predicatePresheaf P).germ_res_apply]
+
+private theorem AnalyticRootCoverContinuation.etaleSection_locally {X : TopCat.{0}} {Y : Type}
+    (P : TopCat.LocalPredicate (fun _ : X => Y)) (σ : C(X, (predicatePresheaf P).EtaleSpace))
+    (hσ : ∀ x : X, (σ x).base = x) (x : X) :
+    ∃ (U : TopologicalSpace.Opens X) (_hx : x ∈ U) (s :
+      (predicatePresheaf P).obj (Opposite.op U)),
+      ∀ (y : X) (hy : y ∈ U), etaleValue P (σ y) = s.1 ⟨y, hy⟩ := by
+  obtain ⟨U, hxU, s, hs⟩ := etaleSection_localGerms P σ hσ x
+  refine ⟨U, hxU, s, ?_⟩
+  intro y hy
+  rw [hs y hy, etaleValue_sectionGerm]
+
+private theorem AnalyticRootCoverContinuation.etaleSection_pred {X : TopCat.{0}} {Y : Type}
+    (P : TopCat.LocalPredicate (fun _ : X => Y)) (σ : C(X, (predicatePresheaf P).EtaleSpace))
+    (hσ : ∀ x : X, (σ x).base = x) : P.pred (U := ⊤) (fun x => etaleValue P (σ x.1)) := by
+  apply P.locality
+  intro x
+  obtain ⟨U, hxU, s, hs⟩ := etaleSection_locally P σ hσ x.1
+  refine ⟨U, hxU, CategoryTheory.homOfLE le_top, ?_⟩
+  convert s.2 using 1
+  funext y
+  exact hs y.1 y.2
+
+private def AnalyticRootCoverContinuation.sectionOfEtaleSection {X : TopCat.{0}} {Y : Type}
+    (P : TopCat.LocalPredicate (fun _ : X => Y)) (σ : C(X, (predicatePresheaf P).EtaleSpace))
+    (hσ : ∀ x : X, (σ x).base = x) : (predicatePresheaf P).obj (Opposite.op ⊤) :=
+  ⟨fun x => etaleValue P (σ x.1), etaleSection_pred P σ hσ⟩
+
+private theorem AnalyticRootCoverContinuation.sectionOfEtaleSection_germ {X : TopCat.{0}} {Y : Type}
+    (P : TopCat.LocalPredicate (fun _ : X => Y)) (σ : C(X, (predicatePresheaf P).EtaleSpace))
+    (hσ : ∀ x : X, (σ x).base = x) (x : X) :
+    sectionGerm P ⊤ (sectionOfEtaleSection P σ hσ) ⟨x, trivial⟩ = σ x := by
+  obtain ⟨U, hxU, s, hs⟩ := etaleSection_localGerms P σ hσ x
+  let i : U ⟶ (⊤ : TopologicalSpace.Opens X) := CategoryTheory.homOfLE le_top
+  have heq : (predicatePresheaf P).map i.op (sectionOfEtaleSection P σ hσ) = s := by
+    apply Subtype.ext
+    funext y
+    change etaleValue P (σ y.1) = s.1 y
+    rw [hs y.1 y.2, etaleValue_sectionGerm]
+  have hg :
+    (predicatePresheaf P).germ ⊤ x trivial (sectionOfEtaleSection P σ hσ) =
+      (predicatePresheaf P).germ U x hxU s := by
+    rw [← (predicatePresheaf P).germ_res_apply i x hxU, heq]
+  calc
+    sectionGerm P ⊤ (sectionOfEtaleSection P σ hσ) ⟨x, trivial⟩ = sectionGerm P U s ⟨x, hxU⟩ := by
+      dsimp only [sectionGerm]
+      rw [hg]
+    _ = σ x := (hs x hxU).symm
+
+private theorem AnalyticRootCoverContinuation.exists_global_section_with_germ_of_germ_bijective
+    {X : TopCat.{0}} {Y : Type} [SimplyConnectedSpace X] [LocallyPathConnectedSpace X]
+    (P : TopCat.LocalPredicate (fun _ : X => Y))
+    (hbij :
+      ∀ x : X,
+        ∃ U : TopologicalSpace.Opens X,
+          x ∈ U ∧ ∀ (y : X) (hy : y ∈ U), Function.Bijective ((predicatePresheaf P).germ U y hy))
+    (x₀ : X) (g₀ : (predicatePresheaf P).stalk x₀) :
+    ∃ s : (predicatePresheaf P).obj (Opposite.op ⊤),
+      (predicatePresheaf P).germ ⊤ x₀ trivial s = g₀ := by
+  have hc : IsCoveringMap (TopCat.Presheaf.EtaleSpace.base (F := predicatePresheaf P)) :=
+    TopCat.Presheaf.EtaleSpace.isCoveringMap_base hbij
+  obtain ⟨σ, hσ, -⟩ := hc.existsUnique_continuousMap_lifts (ContinuousMap.id X) x₀ ⟨x₀, g₀⟩ rfl
+  have hbase (x : X) : (σ x).base = x := congrFun hσ.2 x
+  refine ⟨sectionOfEtaleSection P σ hbase, ?_⟩
+  have hg := (sectionOfEtaleSection_germ P σ hbase x₀).trans hσ.1
+  simpa only [sectionGerm, TopCat.Presheaf.EtaleSpace.mk.injEq, heq_eq_eq, true_and] using hg
+
+private theorem
+    AnalyticRootCover.ambientOpen_top (S : TopologicalSpace.Opens ℂ) : ambientOpen S ⊤ = S := by
+  ext z
+  constructor
+  · rintro ⟨x, _, rfl⟩
+    exact x.2
+  · intro hz
+    exact ⟨⟨z, hz⟩, trivial, rfl⟩
+
+private theorem AnalyticRootCover.exists_global_rootSection_with_germ (S : TopologicalSpace.Opens ℂ)
+    (F : ℂ → ℂ) [SimplyConnectedSpace S] (hF : AnalyticOnNhd ℂ F S)
+    (horder : ∀ a ∈ S, ∃ n : ℕ, analyticOrderAt F a = (2 * n : ℕ)) (x : S)
+    (g : (rootPresheaf S F).stalk x) :
+    ∃ s : RootSection S F ⊤, (rootPresheaf S F).germ ⊤ x trivial s = g := by
+  let : LocallyPathConnectedSpace S := S.isOpen.locallyPathConnectedSpace
+  exact
+    AnalyticRootCoverContinuation.exists_global_section_with_germ_of_germ_bijective
+      (rootLocalPredicate S F) (rootPresheaf_locally_bijective S F hF horder) x g
+
+private theorem
+    AnalyticRootCover.exists_global_rootSection (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ)
+    [SimplyConnectedSpace S] (hF : AnalyticOnNhd ℂ F S)
+    (horder : ∀ a ∈ S, ∃ n : ℕ, analyticOrderAt F a = (2 * n : ℕ)) :
+    Nonempty (RootSection S F ⊤) := by
+  let x : S := Classical.choice inferInstance
+  obtain ⟨g⟩ := rootStalk_nonempty S F hF horder x
+  obtain ⟨s, _⟩ := exists_global_rootSection_with_germ S F hF horder x g
+  exact ⟨s⟩
+
+private theorem AnalyticRootCover.exists_analytic_square_root_on (S : TopologicalSpace.Opens ℂ)
+    (F : ℂ → ℂ) [SimplyConnectedSpace S] (hF : AnalyticOnNhd ℂ F S)
+    (horder : ∀ a ∈ S, ∃ n : ℕ, analyticOrderAt F a = (2 * n : ℕ)) :
+    ∃ r : ℂ → ℂ,
+      AnalyticOnNhd ℂ r S ∧
+        Set.EqOn (fun z => r z ^ 2) F S ∧
+          ∀ a ∈ S, ∀ n : ℕ, analyticOrderAt F a = (2 * n : ℕ) → analyticOrderAt r a = n := by
+  obtain ⟨s⟩ := exists_global_rootSection S F hF horder
+  have hr : AnalyticOnNhd ℂ (extendSection S ⊤ s.1) S := by
+    simpa only [ambientOpen_top] using RootSection.analyticOnNhd_extend s
+  have hsquare : Set.EqOn (fun z => extendSection S ⊤ s.1 z ^ 2) F S := by
+    intro z hz
+    apply RootSection.square_eq (S := S) (F := F) (V := ⊤) s
+    rw [ambientOpen_top]
+    exact hz
+  refine ⟨extendSection S ⊤ s.1, hr, hsquare, ?_⟩
+  intro a ha n hn
+  exact
+    square_root_order (hr a ha)
+      (Filter.eventually_of_mem (S.isOpen.mem_nhds ha) (fun _ hz => hsquare hz)) hn
+
+private theorem AnalyticRootCover.exists_analytic_square_root_on_of_even_zeros
+    (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ) [SimplyConnectedSpace S] (hF : AnalyticOnNhd ℂ F S)
+    (hzero : ∀ a ∈ S, F a = 0 → ∃ n : ℕ, analyticOrderAt F a = (2 * n : ℕ)) :
+    ∃ r : ℂ → ℂ,
+      AnalyticOnNhd ℂ r S ∧
+        Set.EqOn (fun z => r z ^ 2) F S ∧
+          ∀ a ∈ S, ∀ n : ℕ, analyticOrderAt F a = (2 * n : ℕ) → analyticOrderAt r a = n :=
+  exists_analytic_square_root_on S F hF (even_order_at_all_points hF hzero)
+
+private theorem SpecialPeriods.ModularGermLift.exists_global_liftSection_with_germ
+    (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ) [SimplyConnectedSpace S] (hF : AnalyticOnNhd ℂ F S)
+    (h₃ : ∀ a ∈ S, F a = 0 → ∃ k : ℕ, analyticOrderAt F a = (3 * k : ℕ))
+    (h₂ : ∀ a ∈ S, F a = 1728 → ∃ k : ℕ, analyticOrderAt (fun z => F z - 1728) a = (2 * k : ℕ))
+    (x : S) (g : (liftPresheaf S F).stalk x) :
+    ∃ s : LiftSection S F ⊤, (liftPresheaf S F).germ ⊤ x trivial s = g := by
+  let : LocallyPathConnectedSpace S := S.isOpen.locallyPathConnectedSpace
+  exact
+    AnalyticRootCoverContinuation.exists_global_section_with_germ_of_germ_bijective
+      (liftLocalPredicate S F) (liftPresheaf_locally_bijective S F hF h₃ h₂) x g
+
+private theorem SpecialPeriods.ModularGermLift.exists_analytic_modularJ_lift_on_with_germ
+    (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ) [SimplyConnectedSpace S] (hF : AnalyticOnNhd ℂ F S)
+    (h₃ : ∀ a ∈ S, F a = 0 → ∃ k : ℕ, analyticOrderAt F a = (3 * k : ℕ))
+    (h₂ : ∀ a ∈ S, F a = 1728 → ∃ k : ℕ, analyticOrderAt (fun z => F z - 1728) a = (2 * k : ℕ))
+    {U : TopologicalSpace.Opens S} (x : S) (hx : x ∈ U) (s : LiftSection S F U) :
+    ∃ τ : ℂ → ℂ,
+      AnalyticOnNhd ℂ τ S ∧
+        Set.MapsTo τ S UpperHalfPlane.upperHalfPlaneSet ∧
+          Set.EqOn (fun z => SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (τ z))) F S ∧
+            τ =ᶠ[𝓝 (x : ℂ)] extendLiftSection S U s.1 := by
+  obtain ⟨t, ht⟩ :=
+    exists_global_liftSection_with_germ S F hF h₃ h₂ x ((liftPresheaf S F).germ U x hx s)
+  refine ⟨extendLiftSection S ⊤ t.1, ?_, ?_, ?_, ?_⟩
+  · simpa only [AnalyticRootCover.ambientOpen_top] using t.analyticOnNhd_extend
+  · simpa only [AnalyticRootCover.ambientOpen_top] using t.mapsTo_extend
+  · intro z hz
+    apply LiftSection.modular_eq (S := S) (F := F) (V := ⊤) t
+    rwa [AnalyticRootCover.ambientOpen_top]
+  · exact (germ_eq_iff_eventuallyEq S F (U := ⊤) (V := U) x trivial hx t s).mp ht
+
+private theorem
+    SpecialPeriods.ModularGermLift.exists_liftSection_of_germ (S : TopologicalSpace.Opens ℂ)
+    (F : ℂ → ℂ) {a : ℂ} (ha : a ∈ S) (τ₀ : ℂ → ℂ) (hτ₀ : AnalyticAt ℂ τ₀ a) (hpos : 0 < (τ₀ a).im)
+    (hJ₀ : (fun z => SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (τ₀ z))) =ᶠ[𝓝 a] F) :
+    ∃ (U : TopologicalSpace.Opens S) (_hx : (⟨a, ha⟩ : S) ∈ U) (s : LiftSection S F U),
+      extendLiftSection S U s.1 =ᶠ[𝓝 a] τ₀ := by
+  have hposnear : ∀ᶠ z in 𝓝 a, τ₀ z ∈ UpperHalfPlane.upperHalfPlaneSet :=
+    hτ₀.continuousAt.preimage_mem_nhds (UpperHalfPlane.isOpen_upperHalfPlaneSet.mem_nhds hpos)
+  have hSnear : ∀ᶠ z in 𝓝 a, z ∈ S := S.isOpen.mem_nhds ha
+  obtain ⟨r, hr, hball⟩ :=
+    Metric.mem_nhds_iff.mp (hSnear.and (hτ₀.eventually_analyticAt.and (hposnear.and hJ₀)))
+  let A : TopologicalSpace.Opens ℂ := ⟨Metric.ball a r, Metric.isOpen_ball⟩
+  let U : TopologicalSpace.Opens S :=
+    TopologicalSpace.Opens.comap ⟨Subtype.val, continuous_subtype_val⟩ A
+  have hUA : AnalyticRootCover.ambientOpen S U = A :=
+    AnalyticRootCover.ambientOpen_comap_of_subset S A (fun _ hz => (hball hz).1)
+  have hτU : AnalyticOnNhd ℂ τ₀ (AnalyticRootCover.ambientOpen S U) := by
+    rw [hUA]
+    exact fun z hz => (hball hz).2.1
+  have hposU :
+    Set.MapsTo τ₀ (AnalyticRootCover.ambientOpen S U) UpperHalfPlane.upperHalfPlaneSet := by
+    rw [hUA]
+    exact fun z hz => (hball hz).2.2.1
+  have hJU :
+    Set.EqOn (fun z => SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (τ₀ z))) F
+      (AnalyticRootCover.ambientOpen S U) := by
+    rw [hUA]
+    exact fun z hz => (hball hz).2.2.2
+  let s : LiftSection S F U := liftSectionOfComplex S F τ₀ hτU hposU hJU
+  refine ⟨U, Metric.mem_ball_self hr, s, ?_⟩
+  filter_upwards [Metric.isOpen_ball.mem_nhds (Metric.mem_ball_self hr)] with z hz
+  apply extend_liftSectionOfComplex_eqOn S F τ₀ hτU hposU hJU
+  rwa [hUA]
+
+private theorem SpecialPeriods.ModularGermLift.exists_analytic_modularJ_lift_extending
+    (S : TopologicalSpace.Opens ℂ) (F : ℂ → ℂ) [SimplyConnectedSpace S] (hF : AnalyticOnNhd ℂ F S)
+    (h₃ : ∀ a ∈ S, F a = 0 → ∃ k : ℕ, analyticOrderAt F a = (3 * k : ℕ))
+    (h₂ : ∀ a ∈ S, F a = 1728 → ∃ k : ℕ, analyticOrderAt (fun z => F z - 1728) a = (2 * k : ℕ))
+    {a : ℂ} (ha : a ∈ S) (τ₀ : ℂ → ℂ) (hτ₀ : AnalyticAt ℂ τ₀ a) (hpos : 0 < (τ₀ a).im)
+    (hJ₀ : (fun z => SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (τ₀ z))) =ᶠ[𝓝 a] F) :
+    ∃ τ : ℂ → ℂ,
+      AnalyticOnNhd ℂ τ S ∧
+        Set.MapsTo τ S UpperHalfPlane.upperHalfPlaneSet ∧
+          Set.EqOn (fun z => SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (τ z))) F S ∧
+            τ =ᶠ[𝓝 a] τ₀ := by
+  obtain ⟨U, hx, s, hs⟩ := exists_liftSection_of_germ S F ha τ₀ hτ₀ hpos hJ₀
+  obtain ⟨τ, hτ, hτpos, hJ, heq⟩ :=
+    exists_analytic_modularJ_lift_on_with_germ S F hF h₃ h₂ ⟨a, ha⟩ hx s
+  exact ⟨τ, hτ, hτpos, hJ, heq.trans hs⟩
+
+private def AnalyticRootCover.upperHalfPlaneOpen : TopologicalSpace.Opens ℂ :=
+  ⟨UpperHalfPlane.upperHalfPlaneSet, UpperHalfPlane.isOpen_upperHalfPlaneSet⟩
+
+private instance AnalyticRootCover.instContractibleSpace1 : ContractibleSpace upperHalfPlaneOpen :=
+  (convex_halfSpace_im_gt 0).contractibleSpace ⟨Complex.I, by simp⟩
+
+private theorem AnalyticRootCover.exists_analytic_square_root_upperHalfPlane (F : ℂ → ℂ)
+    (hF : AnalyticOnNhd ℂ F UpperHalfPlane.upperHalfPlaneSet)
+    (hzero :
+      ∀ a ∈ UpperHalfPlane.upperHalfPlaneSet,
+        F a = 0 → ∃ n : ℕ, analyticOrderAt F a = (2 * n : ℕ)) :
+    ∃ r : ℂ → ℂ,
+      AnalyticOnNhd ℂ r UpperHalfPlane.upperHalfPlaneSet ∧
+        Set.EqOn (fun z => r z ^ 2) F UpperHalfPlane.upperHalfPlaneSet ∧
+          ∀ a ∈ UpperHalfPlane.upperHalfPlaneSet,
+            ∀ n : ℕ, analyticOrderAt F a = (2 * n : ℕ) → analyticOrderAt r a = n :=
+  exists_analytic_square_root_on_of_even_zeros upperHalfPlaneOpen F hF hzero
+
+public
+theorem AnalyticRootCover.exists_holomorphic_square_root_upperHalfPlane (f : ℍ → ℂ)
+    (hf : MDifferentiable 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) f)
+    (hzero :
+      ∀ a : ℍ,
+        f a = 0 → ∃ n : ℕ, analyticOrderAt (f ∘ UpperHalfPlane.ofComplex) (a : ℂ) = (2 * n : ℕ)) :
+    ∃ r : ℍ → ℂ,
+      ContMDiff 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) ω r ∧
+        (∀ a : ℍ, r a ^ 2 = f a) ∧
+          ∀ a : ℍ,
+            ∀ n : ℕ,
+              analyticOrderAt (f ∘ UpperHalfPlane.ofComplex) (a : ℂ) = (2 * n : ℕ) →
+                analyticOrderAt (r ∘ UpperHalfPlane.ofComplex) (a : ℂ) = n := by
+  let F : ℂ → ℂ := f ∘ UpperHalfPlane.ofComplex
+  have hF : AnalyticOnNhd ℂ F UpperHalfPlane.upperHalfPlaneSet :=
+    (UpperHalfPlane.mdifferentiable_iff.mp hf).analyticOnNhd
+      UpperHalfPlane.isOpen_upperHalfPlaneSet
+  have hzeroF :
+    ∀ a ∈ UpperHalfPlane.upperHalfPlaneSet,
+      F a = 0 → ∃ n : ℕ, analyticOrderAt F a = (2 * n : ℕ) := by
+    intro a ha hfa
+    apply hzero ⟨a, ha⟩
+    simpa only [F, Function.comp_apply, UpperHalfPlane.ofComplex_apply_of_im_pos ha] using hfa
+  obtain ⟨g, hg, hgsquare, hgorder⟩ := exists_analytic_square_root_upperHalfPlane F hF hzeroF
+  let r : ℍ → ℂ := fun a => g a
+  refine ⟨r, ?_, ?_, ?_⟩
+  · intro a
+    exact (hg a a.im_pos).contDiffAt.contMDiffAt.comp a (UpperHalfPlane.contMDiff_coe a)
+  · intro a
+    simpa only [r, F, Function.comp_apply, UpperHalfPlane.ofComplex_apply] using hgsquare a.im_pos
+  · intro a n hn
+    have he : (r ∘ UpperHalfPlane.ofComplex) =ᶠ[𝓝 (a : ℂ)] g := by
+      filter_upwards [UpperHalfPlane.eventuallyEq_coe_comp_ofComplex a.im_pos] with z hz
+      exact congrArg g hz
+    exact (analyticOrderAt_congr he).trans (hgorder a a.im_pos n hn)
+
+private def SpecialPeriods.ModularGermLift.upperHalfPlaneLift (g : ℂ → ℂ) : ℍ → ℍ := fun z =>
+  UpperHalfPlane.ofComplex (g (z : ℂ))
+
+private theorem SpecialPeriods.ModularGermLift.upperHalfPlaneLift_holomorphic {g : ℂ → ℂ}
+    (hg : AnalyticOnNhd ℂ g UpperHalfPlane.upperHalfPlaneSet)
+    (hpos : Set.MapsTo g UpperHalfPlane.upperHalfPlaneSet UpperHalfPlane.upperHalfPlaneSet) :
+    ContMDiff 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) ω (upperHalfPlaneLift g) := by
+  intro z
+  exact
+    (UpperHalfPlane.contMDiffAt_ofComplex (hpos z.im_pos)).comp z
+      ((hg z z.im_pos).contDiffAt.contMDiffAt.comp z (UpperHalfPlane.contMDiff_coe z))
+
+private theorem SpecialPeriods.ModularGermLift.upperHalfPlaneLift_eventuallyEq {g : ℂ → ℂ}
+    (hpos : Set.MapsTo g UpperHalfPlane.upperHalfPlaneSet UpperHalfPlane.upperHalfPlaneSet)
+    (a : ℍ) :
+    (fun z => (upperHalfPlaneLift g (UpperHalfPlane.ofComplex z) : ℂ)) =ᶠ[𝓝 (a : ℂ)] g := by
+  filter_upwards [UpperHalfPlane.isOpen_upperHalfPlaneSet.mem_nhds a.im_pos] with z hz
+  change (UpperHalfPlane.ofComplex (g (UpperHalfPlane.ofComplex z : ℂ)) : ℂ) = g z
+  rw [UpperHalfPlane.ofComplex_apply_of_im_pos hz,
+    UpperHalfPlane.ofComplex_apply_of_im_pos (hpos hz)]
+
+private theorem SpecialPeriods.ModularGermLift.upperHalfPlane_critical_orders {F : ℍ → ℂ}
+    (h₃ :
+      ∀ a : ℍ,
+        F a = 0 → ∃ k : ℕ, analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (a : ℂ) = (3 * k : ℕ))
+    (h₂ :
+      ∀ a : ℍ,
+        F a = 1728 →
+          ∃ k : ℕ,
+            analyticOrderAt (fun z => F (UpperHalfPlane.ofComplex z) - 1728) (a : ℂ) =
+              (2 * k : ℕ)) :
+    (∀ a ∈ UpperHalfPlane.upperHalfPlaneSet,
+        (F ∘ UpperHalfPlane.ofComplex) a = 0 →
+          ∃ k : ℕ, analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) a = (3 * k : ℕ)) ∧
+      (∀ a ∈ UpperHalfPlane.upperHalfPlaneSet,
+        (F ∘ UpperHalfPlane.ofComplex) a = 1728 →
+          ∃ k : ℕ,
+            analyticOrderAt (fun z => (F ∘ UpperHalfPlane.ofComplex) z - 1728) a = (2 * k : ℕ)) :=
+  by
+  constructor
+  · intro a ha hFa
+    apply h₃ ⟨a, ha⟩
+    simpa only [Function.comp_apply, UpperHalfPlane.ofComplex_apply_of_im_pos ha] using hFa
+  · intro a ha hFa
+    apply h₂ ⟨a, ha⟩
+    simpa only [Function.comp_apply, UpperHalfPlane.ofComplex_apply_of_im_pos ha] using hFa
+
+private theorem
+    SpecialPeriods.ModularGermLift.exists_holomorphic_modularJ_lift_upperHalfPlane_extending
+    (F : ℍ → ℂ) (hF : MDifferentiable 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) F)
+    (h₃ :
+      ∀ a : ℍ,
+        F a = 0 → ∃ k : ℕ, analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (a : ℂ) = (3 * k : ℕ))
+    (h₂ :
+      ∀ a : ℍ,
+        F a = 1728 →
+          ∃ k : ℕ,
+            analyticOrderAt (fun z => F (UpperHalfPlane.ofComplex z) - 1728) (a : ℂ) =
+              (2 * k : ℕ))
+    (a : ℍ) (τ₀ : ℂ → ℂ) (hτ₀ : AnalyticAt ℂ τ₀ (a : ℂ)) (hpos₀ : 0 < (τ₀ a).im)
+    (hJ₀ :
+      (fun z => SpecialPeriods.modularJ (UpperHalfPlane.ofComplex (τ₀ z))) =ᶠ[𝓝 (a : ℂ)]
+        F ∘ UpperHalfPlane.ofComplex) :
+    ∃ τ : ℍ → ℍ,
+      ContMDiff 𝓘(ℂ, ℂ) 𝓘(ℂ, ℂ) ω τ ∧
+        (∀ z : ℍ, SpecialPeriods.modularJ (τ z) = F z) ∧
+          (fun z => (τ (UpperHalfPlane.ofComplex z) : ℂ)) =ᶠ[𝓝 (a : ℂ)] τ₀ := by
+  have hF' : AnalyticOnNhd ℂ (F ∘ UpperHalfPlane.ofComplex) UpperHalfPlane.upperHalfPlaneSet :=
+    (UpperHalfPlane.mdifferentiable_iff.mp hF).analyticOnNhd
+      UpperHalfPlane.isOpen_upperHalfPlaneSet
+  obtain ⟨h₃', h₂'⟩ := upperHalfPlane_critical_orders h₃ h₂
+  obtain ⟨g, hg, hpos, hJ, hg₀⟩ :=
+    exists_analytic_modularJ_lift_extending AnalyticRootCover.upperHalfPlaneOpen
+      (F ∘ UpperHalfPlane.ofComplex) hF' h₃' h₂' a.im_pos τ₀ hτ₀ hpos₀ hJ₀
+  refine
+    ⟨upperHalfPlaneLift g, upperHalfPlaneLift_holomorphic hg hpos, ?_,
+      (upperHalfPlaneLift_eventuallyEq hpos a).trans hg₀⟩
+  intro z
+  simpa only [upperHalfPlaneLift, Function.comp_apply, UpperHalfPlane.ofComplex_apply] using
+    hJ z.im_pos
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Uniformization/SpecialPeriods5.lean b/LeanPool/HopfProblem/Uniformization/SpecialPeriods5.lean
new file mode 100644
index 000000000..e592079bf
--- /dev/null
+++ b/LeanPool/HopfProblem/Uniformization/SpecialPeriods5.lean
@@ -0,0 +1,5618 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Threefold.SpecialPeriods5
+public import LeanPool.HopfProblem.CuspFibre.CuspCentralHomology1
+import all LeanPool.HopfProblem.Uniformization.HolomorphicCousin
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Uniformization.CuspUniformization1
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Foundations.LocalOrbitQuotient
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods3
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods4
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods4
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods5
+import all LeanPool.HopfProblem.CuspFibre.CuspCentralHomology1
+
+/-!
+# Hopf problem: uniformization · special periods 5
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem SpecialPeriods.exists_covariant_tau_of_triangle_source (F : ℍ → ℂ)
+    (hF : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) F)
+    (h₃ :
+      ∀ a : ℍ,
+        F a = 0 → ∃ k : ℕ, analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (a : ℂ) = (3 * k : ℕ))
+    (h₂ :
+      ∀ a : ℍ,
+        F a = 1728 →
+          ∃ k : ℕ,
+            analyticOrderAt (fun z => F (UpperHalfPlane.ofComplex z) - 1728) (a : ℂ) =
+              (2 * k : ℕ))
+    (hF₁ : ∀ z : ℍ, F (Triangle.generatorOneSL • z) = F z)
+    (hF₂ : ∀ z : ℍ, F (Triangle.generatorTwoSL • z) = F z)
+    (horder₁ : analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (Triangle.centerOne : ℂ) = 3)
+    (horder₂ :
+      analyticOrderAt (fun z : ℂ => F (UpperHalfPlane.ofComplex z) - 1728)
+          (Triangle.centerTwo : ℂ) =
+        4)
+    (Fc : ℂ → ℂ) (hFc : MeromorphicAt Fc 0) (hFcorder : meromorphicOrderAt Fc 0 = (-1 : ℤ))
+    {r₀ : ℝ} (hr₀ : 0 < r₀)
+    (hsource :
+      ∀ z : ℍ,
+        ‖Function.Periodic.qParam Triangle.width (z : ℂ)‖ < r₀ →
+          F z = Fc (Function.Periodic.qParam Triangle.width (z : ℂ))) :
+    ∃ τ : ℍ → ℍ,
+      ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ ∧
+        (∀ z : ℍ, modularJ (τ z) = F z) ∧
+          TauCovariant τ ∧
+            τ Triangle.centerOne = rhoPoint ∧
+              τ Triangle.centerTwo = UpperHalfPlane.I ∧
+                ∃ r > 0,
+                  r < r₀ ∧
+                    r < 1 ∧
+                      ∃ h : ℂ → ℂ,
+                        AnalyticOnNhd ℂ h (Metric.ball 0 r) ∧
+                          ∀ z : ℍ,
+                            ‖Function.Periodic.qParam Triangle.width (z : ℂ)‖ < r →
+                              (τ z : ℂ) =
+                                TauCusp.correctedLogarithmWidth Triangle.width h (z : ℂ) := by
+  have hFa : F Triangle.centerOne = 0 := by
+    have hh :=
+      (analyticOrderAt_ne_zero.mp
+          (show analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (Triangle.centerOne : ℂ) ≠ 0 by
+            rw [horder₁]; norm_num)).2
+    simpa only [Function.comp_apply, UpperHalfPlane.ofComplex_apply] using hh
+  have hFb : F Triangle.centerTwo = 1728 := by
+    have hh :=
+      (analyticOrderAt_ne_zero.mp
+          (show
+            analyticOrderAt (fun z : ℂ => F (UpperHalfPlane.ofComplex z) - 1728)
+                (Triangle.centerTwo : ℂ) ≠
+              0
+            by rw [horder₂]; norm_num)).2
+    exact sub_eq_zero.mp (by simpa only [UpperHalfPlane.ofComplex_apply] using hh)
+  obtain ⟨_, _, _, τ, hτ, hJ, r, hr, hrr₀, hr1, h, hh, _, hformula⟩ :=
+    TauCusp.exists_global_normalized_lift_of_simplePole_cusp F hF h₃ h₂ Triangle.width
+      Triangle.width_pos Fc hFc hFcorder hr₀ hsource
+  have hC := tau_cusp_monodromy_of_formula hτ hr hformula
+  have hCtr :
+    Matrix.trace (ModularGroup.T⁻¹).val = 2 ∨ Matrix.trace (ModularGroup.T⁻¹).val = -2 := by
+    left
+    rw [modularSL_trace_inv]
+    norm_num [Matrix.trace_fin_two, ModularGroup.T]
+  obtain ⟨γ, hcov, hγa, hγb⟩ :=
+    exists_normalized_covariant_modular_translate F hτ hJ hFa hFb hF₁ hF₂ horder₁ horder₂
+      ModularGroup.T⁻¹ hCtr hC
+  have hab : τ Triangle.centerOne ≠ τ Triangle.centerTwo := by
+    intro he
+    have hj := congrArg modularJ he
+    rw [hJ, hJ, hFa, hFb] at hj
+    norm_num at hj
+  have hcomm :=
+    modular_translate_commutes_Tinv_of_cusp_covariance γ hC hcov Triangle.centerOne
+      Triangle.centerTwo hab
+  obtain ⟨n, hn⟩ := modularSL_integer_translation_coe_of_commutes_T_inv_action γ hcomm
+  refine
+    ⟨fun z => γ • τ z, (modularSL_holomorphic γ).comp hτ,
+      (fun z => (modularJ_SL_invariant γ (τ z)).trans (hJ z)), hcov, hγa, hγb, r, hr, hrr₀, hr1,
+      fun q => h q + (n : ℂ), hh.add analyticOnNhd_const, ?_⟩
+  intro z hz
+  rw [hn, hformula z hz]
+  simp only [TauCusp.correctedLogarithmWidth]
+  ring
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.TriangleSource.exists_tau_of_normalized_sphere_equivalence
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere)) :
+    ∃ τ : ℍ → ℍ,
+      ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ ∧
+        (∀ z : ℍ,
+            SpecialPeriods.modularJ (τ z) = SpecialPeriods.MuTorsor.SourceOrders.sourceJ π z) ∧
+          SpecialPeriods.TauCovariant τ ∧
+            τ SpecialPeriods.Triangle.centerOne = SpecialPeriods.rhoPoint ∧
+              τ SpecialPeriods.Triangle.centerTwo = UpperHalfPlane.I ∧
+                ∃ r > 0,
+                  r < 1 ∧
+                    ∃ h : ℂ → ℂ,
+                      AnalyticOnNhd ℂ h (Metric.ball 0 r) ∧
+                        ∀ z : ℍ,
+                          ‖Function.Periodic.qParam SpecialPeriods.Triangle.width (z : ℂ)‖ < r →
+                            (τ z : ℂ) =
+                              SpecialPeriods.TauCusp.correctedLogarithmWidth
+                                SpecialPeriods.Triangle.width h (z : ℂ) := by
+  have h₃ :
+    ∀ z : ℍ,
+      SpecialPeriods.MuTorsor.SourceOrders.sourceJ π z = 0 →
+        ∃ k : ℕ,
+          analyticOrderAt
+              (SpecialPeriods.MuTorsor.SourceOrders.sourceJ π ∘ UpperHalfPlane.ofComplex)
+              (z : ℂ) =
+            (3 * k : ℕ) := by
+    intro z hz
+    exact
+      ⟨1, by
+        simpa using SpecialPeriods.MuTorsor.SourceOrders.sourceJ_order_of_eq_zero π hπ h₀ z hz⟩
+  have h₂ :
+    ∀ z : ℍ,
+      SpecialPeriods.MuTorsor.SourceOrders.sourceJ π z = 1728 →
+        ∃ k : ℕ,
+          analyticOrderAt
+              (fun w =>
+                SpecialPeriods.MuTorsor.SourceOrders.sourceJ π (UpperHalfPlane.ofComplex w) -
+                  1728)
+              (z : ℂ) =
+            (2 * k : ℕ) := by
+    intro z hz
+    exact
+      ⟨2, by
+        simpa using
+          SpecialPeriods.MuTorsor.SourceOrders.sourceJ_sub_1728_order_of_eq π hπ h₁ z hz⟩
+  have hG₁ :
+    ∀ z : ℍ,
+      SpecialPeriods.MuTorsor.SourceOrders.sourceJ π
+          (SpecialPeriods.Triangle.generatorOneSL • z) =
+        SpecialPeriods.MuTorsor.SourceOrders.sourceJ π z := by
+    intro z
+    simpa only [SpecialPeriods.triangleGeometricRepresentation_generator₁_apply] using
+      SpecialPeriods.MuTorsor.SourceOrders.sourceJ_invariant π SpecialPeriods.triangleGenerator₁ z
+  have hG₂ :
+    ∀ z : ℍ,
+      SpecialPeriods.MuTorsor.SourceOrders.sourceJ π
+          (SpecialPeriods.Triangle.generatorTwoSL • z) =
+        SpecialPeriods.MuTorsor.SourceOrders.sourceJ π z := by
+    intro z
+    simpa only [SpecialPeriods.triangleGeometricRepresentation_generator₂_apply] using
+      SpecialPeriods.MuTorsor.SourceOrders.sourceJ_invariant π SpecialPeriods.triangleGenerator₂ z
+  obtain ⟨r₀, hr₀, hsource⟩ := exists_cusp_formula_radius π hπ
+  obtain ⟨τ, hτ, hJ, hcov, ha, hb, r, hr, _, hr1, h, hh, hformula⟩ :=
+    SpecialPeriods.exists_covariant_tau_of_triangle_source
+      (SpecialPeriods.MuTorsor.SourceOrders.sourceJ π)
+      ((SpecialPeriods.MuTorsor.SourceOrders.sourceJ_holomorphic π hπ).mdifferentiable (by simp))
+      h₃ h₂ hG₁ hG₂ (SpecialPeriods.MuTorsor.SourceOrders.sourceJ_order_centerOne π hπ h₀)
+      (SpecialPeriods.MuTorsor.SourceOrders.sourceJ_sub_1728_order_centerTwo π hπ h₁)
+      (meromorphicCuspJ π) (meromorphicCuspJ_meromorphicAt π hπ) (meromorphicCuspJ_order π hπ) hr₀
+      hsource
+  exact ⟨τ, hτ, hJ, hcov, ha, hb, r, hr, hr1, h, hh, hformula⟩
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.TriangleSource.tauOfSphere
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere)) :
+    ℍ → ℍ :=
+  (exists_tau_of_normalized_sphere_equivalence π hπ h₀ h₁).choose
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.TriangleSource.tauOfSphere_holomorphic
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere)) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (tauOfSphere π hπ h₀ h₁) :=
+  (exists_tau_of_normalized_sphere_equivalence π hπ h₀ h₁).choose_spec.1
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.TriangleSource.tauOfSphere_modular
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere))
+    (z : ℍ) :
+    SpecialPeriods.modularJ (tauOfSphere π hπ h₀ h₁ z) =
+      1728 * SpecialPeriods.BetaTorsor.finiteProjection π z :=
+  (exists_tau_of_normalized_sphere_equivalence π hπ h₀ h₁).choose_spec.2.1 z
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.TriangleSource.tauOfSphere_covariant
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere)) :
+    SpecialPeriods.TauCovariant (tauOfSphere π hπ h₀ h₁) :=
+  (exists_tau_of_normalized_sphere_equivalence π hπ h₀ h₁).choose_spec.2.2.1
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.TriangleSource.tauOfSphere_cusp
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere)) :
+    ∃ r > 0,
+      r < 1 ∧
+        ∃ h : ℂ → ℂ,
+          AnalyticOnNhd ℂ h (Metric.ball 0 r) ∧
+            ∀ z : ℍ,
+              ‖Function.Periodic.qParam SpecialPeriods.Triangle.width (z : ℂ)‖ < r →
+                (tauOfSphere π hπ h₀ h₁ z : ℂ) =
+                  SpecialPeriods.TauCusp.correctedLogarithmWidth SpecialPeriods.Triangle.width h
+                    (z : ℂ) :=
+  (exists_tau_of_normalized_sphere_equivalence π hπ h₀ h₁).choose_spec.2.2.2.2.2
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.TriangleSource.cuspCorrectionUnit (h : ℂ → ℂ) (q : ℂ) : ℂ :=
+  CuspUniformization.exponential (h q)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.TriangleSource.cuspCorrectionUnit_analyticOnNhd {h : ℂ → ℂ} {r : ℝ}
+    (hh : AnalyticOnNhd ℂ h (Metric.ball 0 r)) :
+    AnalyticOnNhd ℂ (cuspCorrectionUnit h) (Metric.ball 0 r) := by
+  intro q hq
+  exact CuspUniformization.exponential_holomorphic.contDiffAt.analyticAt.comp (hh q hq)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.TriangleSource.cuspCorrectionUnit_ne_zero (h : ℂ → ℂ) (q : ℂ) :
+    cuspCorrectionUnit h q ≠ 0 :=
+  CuspUniformization.exponential_ne_zero _
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.TriangleSource.tauOfSphere_cusp_unit
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere)) :
+    ∃ r > 0,
+      ∃ u : ℂ → ℂ,
+        AnalyticOnNhd ℂ u (Metric.ball 0 r) ∧
+          u 0 ≠ 0 ∧
+            ∀ z : ℍ,
+              ‖Function.Periodic.qParam SpecialPeriods.Triangle.width (z : ℂ)‖ < r →
+                Function.Periodic.qParam 1 (tauOfSphere π hπ h₀ h₁ z : ℂ) =
+                  Function.Periodic.qParam SpecialPeriods.Triangle.width (z : ℂ) *
+                    u (Function.Periodic.qParam SpecialPeriods.Triangle.width (z : ℂ)) := by
+  obtain ⟨r, hr, _, h, hh, hformula⟩ := tauOfSphere_cusp π hπ h₀ h₁
+  refine
+    ⟨r, hr, cuspCorrectionUnit h, cuspCorrectionUnit_analyticOnNhd hh,
+      cuspCorrectionUnit_ne_zero h 0, ?_⟩
+  intro z hz
+  rw [← SpecialPeriods.TauCusp.exponential_eq_qParam_one, hformula z hz]
+  exact
+    SpecialPeriods.TauCusp.correctedLogarithmWidth_exponential SpecialPeriods.Triangle.width h z
+
+private def SpecialPeriods.MuTorsor.affinePermutation {B : Type*} (e : Equiv.Perm B) (a : B → ℂˣ)
+    (b : B → ℂ) : Equiv.Perm (B × ℂ)
+    where
+  toFun p := (e p.1, (a p.1 : ℂ) * p.2 + b p.1)
+  invFun p := (e.symm p.1, (a (e.symm p.1) : ℂ)⁻¹ * (p.2 - b (e.symm p.1)))
+  left_inv := by
+    rintro ⟨z, u⟩
+    apply Prod.ext
+    · exact e.symm_apply_apply z
+    · simp only [Equiv.symm_apply_apply]
+      rw [add_sub_cancel_right, ← mul_assoc, inv_mul_cancel₀ (a z).ne_zero, one_mul]
+  right_inv := by
+    rintro ⟨z, u⟩
+    apply Prod.ext
+    · exact e.apply_symm_apply z
+    · dsimp
+      rw [← mul_assoc, mul_inv_cancel₀ (a (e.symm z)).ne_zero, one_mul, sub_add_cancel]
+
+private def SpecialPeriods.MuTorsor.generatorOneScale (τ : ℍ → ℍ) (z : ℍ) : ℂˣ :=
+  Units.mk0 (-1 / (τ z : ℂ)) (div_ne_zero (neg_ne_zero.mpr one_ne_zero) (τ z).ne_zero)
+
+private def SpecialPeriods.MuTorsor.generatorTwoScale (τ : ℍ → ℍ) (z : ℍ) : ℂˣ :=
+  Units.mk0 (1 / (τ z : ℂ)) (div_ne_zero one_ne_zero (τ z).ne_zero)
+
+private def SpecialPeriods.MuTorsor.generatorOneShift (τ : ℍ → ℍ) (z : ℍ) : ℂ :=
+  1 / (τ z : ℂ)
+
+private def SpecialPeriods.MuTorsor.generatorTwoShift (_z : ℍ) : ℂ :=
+  1
+
+@[simp]
+private theorem SpecialPeriods.MuTorsor.generatorOneScale_val (τ : ℍ → ℍ) (z : ℍ) :
+    (generatorOneScale τ z : ℂ) = -1 / (τ z : ℂ) :=
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.MuTorsor.generatorTwoScale_val (τ : ℍ → ℍ) (z : ℍ) :
+    (generatorTwoScale τ z : ℂ) = 1 / (τ z : ℂ) :=
+  rfl
+
+private def SpecialPeriods.MuTorsor.generatorOne (τ : ℍ → ℍ) : Equiv.Perm (ℍ × ℂ) :=
+  affinePermutation SpecialPeriods.Triangle.generatorOnePerm (generatorOneScale τ)
+    (generatorOneShift τ)
+
+private def SpecialPeriods.MuTorsor.generatorTwo (τ : ℍ → ℍ) : Equiv.Perm (ℍ × ℂ) :=
+  affinePermutation SpecialPeriods.Triangle.generatorTwoPerm (generatorTwoScale τ)
+    generatorTwoShift
+
+@[simp]
+private theorem SpecialPeriods.MuTorsor.generatorOne_apply (τ : ℍ → ℍ) (z : ℍ) (u : ℂ) :
+    generatorOne τ (z, u) = (SpecialPeriods.Triangle.generatorOneSL • z, (1 - u) / (τ z : ℂ)) := by
+  apply Prod.ext
+  · rfl
+  · change (-1 / (τ z : ℂ)) * u + 1 / (τ z : ℂ) = _
+    ring
+
+@[simp]
+private theorem SpecialPeriods.MuTorsor.generatorTwo_apply (τ : ℍ → ℍ) (z : ℍ) (u : ℂ) :
+    generatorTwo τ (z, u) = (SpecialPeriods.Triangle.generatorTwoSL • z, 1 + u / (τ z : ℂ)) := by
+  apply Prod.ext
+  · rfl
+  · change (1 / (τ z : ℂ)) * u + 1 = _
+    ring
+
+private theorem SpecialPeriods.MuTorsor.generatorOne_cube {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) : generatorOne τ ^ 3 = 1 := by
+  apply Equiv.ext
+  rintro ⟨z, u⟩
+  change generatorOne τ (generatorOne τ (generatorOne τ (z, u))) = (z, u)
+  simp only [generatorOne_apply]
+  apply Prod.ext
+  · exact congrArg (fun e : Equiv.Perm ℍ => e z) SpecialPeriods.Triangle.generatorOnePerm_cube
+  · dsimp
+    rw [hτ.1 (SpecialPeriods.Triangle.generatorOneSL • z), hτ.1 z]
+    have ht : (τ z : ℂ) ≠ 0 := (τ z).ne_zero
+    have ht1 : (τ z : ℂ) - 1 ≠ 0 :=
+      sub_ne_zero.mpr (by simpa only [Int.cast_one] using (τ z).ne_intCast 1)
+    field_simp [ht, ht1]
+    ring
+
+private theorem SpecialPeriods.MuTorsor.generatorTwo_fourth {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) : generatorTwo τ ^ 4 = 1 := by
+  apply Equiv.ext
+  rintro ⟨z, u⟩
+  change generatorTwo τ (generatorTwo τ (generatorTwo τ (generatorTwo τ (z, u)))) = (z, u)
+  simp only [generatorTwo_apply]
+  apply Prod.ext
+  · exact congrArg (fun e : Equiv.Perm ℍ => e z) SpecialPeriods.Triangle.generatorTwoPerm_fourth
+  · dsimp
+    rw [hτ.2
+        (SpecialPeriods.Triangle.generatorTwoSL • (SpecialPeriods.Triangle.generatorTwoSL • z)),
+      hτ.2 (SpecialPeriods.Triangle.generatorTwoSL • z), hτ.2 z]
+    field_simp [(τ z).ne_zero]
+    ring
+
+private def
+    SpecialPeriods.MuTorsor.representation {τ : ℍ → ℍ} (hτ : SpecialPeriods.TauCovariant τ) :
+    SpecialPeriods.TriangleGroup →* Equiv.Perm (ℍ × ℂ) :=
+  SpecialPeriods.triangleLift (generatorOne τ) (generatorTwo τ) (generatorOne_cube hτ)
+    (generatorTwo_fourth hτ)
+
+@[simp]
+private theorem SpecialPeriods.MuTorsor.representation_generator₁ {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) :
+    representation hτ SpecialPeriods.triangleGenerator₁ = generatorOne τ :=
+  SpecialPeriods.triangleLift_generator₁ ..
+
+@[simp]
+private theorem SpecialPeriods.MuTorsor.representation_generator₂ {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) :
+    representation hτ SpecialPeriods.triangleGenerator₂ = generatorTwo τ :=
+  SpecialPeriods.triangleLift_generator₂ ..
+
+private theorem SpecialPeriods.MuTorsor.generatorOne_mul_generatorTwo_apply {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (z : ℍ) (u : ℂ) :
+    (generatorOne τ * generatorTwo τ) (z, u) =
+      (SpecialPeriods.Triangle.generatorOneSL • (SpecialPeriods.Triangle.generatorTwoSL • z),
+        u) := by
+  change generatorOne τ (generatorTwo τ (z, u)) = _
+  rw [generatorTwo_apply, generatorOne_apply, hτ.2 z]
+  congr 1
+  field_simp [(τ z).ne_zero]
+  ring
+
+private theorem SpecialPeriods.MuTorsor.representation_cusp_snd {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (z : ℍ) (u : ℂ) :
+    (representation hτ SpecialPeriods.triangleCuspGenerator (z, u)).2 = u := by
+  rw [representation, SpecialPeriods.triangleLift_cusp]
+  have he := (generatorOne τ * generatorTwo τ).apply_symm_apply (z, u)
+  have hc := congrArg Prod.snd he
+  rw [generatorOne_mul_generatorTwo_apply hτ] at hc
+  exact hc
+
+private theorem SpecialPeriods.MuTorsor.generatorOneScale_holomorphic {τ : ℍ → ℍ}
+    (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z => (generatorOneScale τ z : ℂ)) :=
+  contMDiff_const.div₀ (UpperHalfPlane.contMDiff_coe.comp hτa) (fun z => (τ z).ne_zero)
+
+private theorem SpecialPeriods.MuTorsor.generatorTwoScale_holomorphic {τ : ℍ → ℍ}
+    (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z => (generatorTwoScale τ z : ℂ)) :=
+  contMDiff_const.div₀ (UpperHalfPlane.contMDiff_coe.comp hτa) (fun z => (τ z).ne_zero)
+
+private theorem SpecialPeriods.MuTorsor.generatorOneShift_holomorphic {τ : ℍ → ℍ}
+    (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (generatorOneShift τ) :=
+  contMDiff_const.div₀ (UpperHalfPlane.contMDiff_coe.comp hτa) (fun z => (τ z).ne_zero)
+
+private theorem SpecialPeriods.MuTorsor.generatorTwoShift_holomorphic :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω generatorTwoShift :=
+  contMDiff_const
+
+private def
+    SpecialPeriods.MuTorsor.AffineFibres {G B : Type*} [Group G] (ρ : G →* Equiv.Perm (B × ℂ))
+    (β : G →* Equiv.Perm B) (g : G) : Prop :=
+  ∃ a : B → ℂˣ, ∃ b : B → ℂ, ∀ z u, ρ g (z, u) = (β g z, (a z : ℂ) * u + b z)
+
+private theorem SpecialPeriods.MuTorsor.affine_coefficients_unique {G B : Type*} [Group G]
+    (ρ : G →* Equiv.Perm (B × ℂ)) (β : G →* Equiv.Perm B) {g : G} {a c : B → ℂˣ} {b d : B → ℂ}
+    (hf : ∀ z u, ρ g (z, u) = (β g z, (a z : ℂ) * u + b z))
+    (hf' : ∀ z u, ρ g (z, u) = (β g z, (c z : ℂ) * u + d z)) : a = c ∧ b = d := by
+  have hb : ∀ z, b z = d z := by
+    intro z
+    have h := congrArg Prod.snd ((hf z 0).symm.trans (hf' z 0))
+    simpa only [MulZeroClass.mul_zero, zero_add] using h
+  refine ⟨?_, funext hb⟩
+  funext z
+  apply Units.ext
+  have h : (a z : ℂ) + b z = (c z : ℂ) + d z := by
+    simpa only [mul_one] using congrArg Prod.snd ((hf z 1).symm.trans (hf' z 1))
+  rw [hb z] at h
+  exact add_right_cancel h
+
+private theorem SpecialPeriods.MuTorsor.affine_one_formula {G B : Type*} [Group G]
+    (ρ : G →* Equiv.Perm (B × ℂ)) (β : G →* Equiv.Perm B) (z : B) (u : ℂ) :
+    ρ 1 (z, u) = (β 1 z, ((1 : ℂˣ) : ℂ) * u + 0) := by simp
+
+private theorem SpecialPeriods.MuTorsor.affine_mul_formula {G B : Type*} [Group G]
+    (ρ : G →* Equiv.Perm (B × ℂ)) (β : G →* Equiv.Perm B) {g h : G} {a c : B → ℂˣ} {b d : B → ℂ}
+    (hg : ∀ z u, ρ g (z, u) = (β g z, (a z : ℂ) * u + b z))
+    (hh : ∀ z u, ρ h (z, u) = (β h z, (c z : ℂ) * u + d z)) (z : B) (u : ℂ) :
+    ρ (g * h) (z, u) =
+      (β (g * h) z, ((a (β h z) * c z : ℂˣ) : ℂ) * u + ((a (β h z) : ℂ) * d z + b (β h z))) := by
+  rw [map_mul, Equiv.Perm.mul_apply, hh, hg]
+  apply Prod.ext
+  · simp only [map_mul, Equiv.Perm.mul_apply]
+  · simp only [Units.val_mul]
+    ring
+
+private theorem SpecialPeriods.MuTorsor.affine_inv_formula {G B : Type*} [Group G]
+    (ρ : G →* Equiv.Perm (B × ℂ)) (β : G →* Equiv.Perm B) {g : G} {a : B → ℂˣ} {b : B → ℂ}
+    (hg : ∀ z u, ρ g (z, u) = (β g z, (a z : ℂ) * u + b z)) (z : B) (u : ℂ) :
+    ρ g⁻¹ (z, u) =
+      (β g⁻¹ z, (((a (β g⁻¹ z))⁻¹ : ℂˣ) : ℂ) * u + (-((a (β g⁻¹ z) : ℂ)⁻¹ * b (β g⁻¹ z)))) := by
+  apply (ρ g).injective
+  have hc : ρ g (ρ g⁻¹ (z, u)) = (z, u) := by
+    rw [map_inv, Equiv.Perm.inv_def]
+    exact (ρ g).apply_symm_apply _
+  rw [hc, hg]
+  apply Prod.ext
+  · rw [map_inv, Equiv.Perm.inv_def]
+    exact ((β g).apply_symm_apply z).symm
+  · simp only [Units.val_inv_eq_inv_val, mul_add, mul_neg, ← mul_assoc,
+      mul_inv_cancel₀ (a (β g⁻¹ z)).ne_zero, one_mul, neg_add_cancel_right]
+
+private theorem SpecialPeriods.MuTorsor.affineFibres_one {G B : Type*} [Group G]
+    (ρ : G →* Equiv.Perm (B × ℂ)) (β : G →* Equiv.Perm B) : AffineFibres ρ β 1 :=
+  ⟨fun _ => 1, fun _ => 0, affine_one_formula ρ β⟩
+
+private theorem SpecialPeriods.MuTorsor.affineFibres_mul {G B : Type*} [Group G]
+    (ρ : G →* Equiv.Perm (B × ℂ)) (β : G →* Equiv.Perm B) {g h : G} (hg : AffineFibres ρ β g)
+    (hh : AffineFibres ρ β h) : AffineFibres ρ β (g * h) := by
+  obtain ⟨a, b, ha⟩ := hg
+  obtain ⟨c, d, hc⟩ := hh
+  exact
+    ⟨fun z => a (β h z) * c z, fun z => (a (β h z) : ℂ) * d z + b (β h z),
+      affine_mul_formula ρ β ha hc⟩
+
+private theorem SpecialPeriods.MuTorsor.affineFibres_inv {G B : Type*} [Group G]
+    (ρ : G →* Equiv.Perm (B × ℂ)) (β : G →* Equiv.Perm B) {g : G} (hg : AffineFibres ρ β g) :
+    AffineFibres ρ β g⁻¹ := by
+  obtain ⟨a, b, ha⟩ := hg
+  exact
+    ⟨fun z => (a (β g⁻¹ z))⁻¹, fun z => -((a (β g⁻¹ z) : ℂ)⁻¹ * b (β g⁻¹ z)),
+      affine_inv_formula ρ β ha⟩
+
+private def
+    SpecialPeriods.MuTorsor.affineSubgroup {G B : Type*} [Group G] (ρ : G →* Equiv.Perm (B × ℂ))
+    (β : G →* Equiv.Perm B) : Subgroup G
+    where
+  carrier := AffineFibres ρ β
+  one_mem' := affineFibres_one ρ β
+  mul_mem' := affineFibres_mul ρ β
+  inv_mem' := affineFibres_inv ρ β
+
+private def SpecialPeriods.MuTorsor.scale {G B : Type*} [Group G] (ρ : G →* Equiv.Perm (B × ℂ))
+    (β : G →* Equiv.Perm B) (h_all : ∀ g, AffineFibres ρ β g) (g : G) : B → ℂˣ :=
+  (h_all g).choose
+
+private def SpecialPeriods.MuTorsor.shift {G B : Type*} [Group G] (ρ : G →* Equiv.Perm (B × ℂ))
+    (β : G →* Equiv.Perm B) (h_all : ∀ g, AffineFibres ρ β g) (g : G) : B → ℂ :=
+  (h_all g).choose_spec.choose
+
+private theorem SpecialPeriods.MuTorsor.action_formula {G B : Type*} [Group G]
+    (ρ : G →* Equiv.Perm (B × ℂ)) (β : G →* Equiv.Perm B) (h_all : ∀ g, AffineFibres ρ β g)
+    (g : G) (z : B) (u : ℂ) :
+    ρ g (z, u) = (β g z, (scale ρ β h_all g z : ℂ) * u + shift ρ β h_all g z) :=
+  (h_all g).choose_spec.choose_spec z u
+
+private theorem SpecialPeriods.MuTorsor.scale_eq_of_formula {G B : Type*} [Group G]
+    (ρ : G →* Equiv.Perm (B × ℂ)) (β : G →* Equiv.Perm B) (h_all : ∀ g, AffineFibres ρ β g)
+    {g : G} {a : B → ℂˣ} {b : B → ℂ} (hg : ∀ z u, ρ g (z, u) = (β g z, (a z : ℂ) * u + b z)) :
+    scale ρ β h_all g = a :=
+  (affine_coefficients_unique ρ β (action_formula ρ β h_all g) hg).1
+
+private theorem SpecialPeriods.MuTorsor.shift_eq_of_formula {G B : Type*} [Group G]
+    (ρ : G →* Equiv.Perm (B × ℂ)) (β : G →* Equiv.Perm B) (h_all : ∀ g, AffineFibres ρ β g)
+    {g : G} {a : B → ℂˣ} {b : B → ℂ} (hg : ∀ z u, ρ g (z, u) = (β g z, (a z : ℂ) * u + b z)) :
+    shift ρ β h_all g = b :=
+  (affine_coefficients_unique ρ β (action_formula ρ β h_all g) hg).2
+
+@[simp]
+private theorem
+    SpecialPeriods.MuTorsor.scale_one {G B : Type*} [Group G] (ρ : G →* Equiv.Perm (B × ℂ))
+    (β : G →* Equiv.Perm B) (h_all : ∀ g, AffineFibres ρ β g) (z : B) : scale ρ β h_all 1 z = 1 :=
+  congrFun (scale_eq_of_formula ρ β h_all (affine_one_formula ρ β)) z
+
+@[simp]
+private theorem
+    SpecialPeriods.MuTorsor.shift_one {G B : Type*} [Group G] (ρ : G →* Equiv.Perm (B × ℂ))
+    (β : G →* Equiv.Perm B) (h_all : ∀ g, AffineFibres ρ β g) (z : B) : shift ρ β h_all 1 z = 0 :=
+  congrFun (shift_eq_of_formula ρ β h_all (affine_one_formula ρ β)) z
+
+private theorem
+    SpecialPeriods.MuTorsor.scale_mul {G B : Type*} [Group G] (ρ : G →* Equiv.Perm (B × ℂ))
+    (β : G →* Equiv.Perm B) (h_all : ∀ g, AffineFibres ρ β g) (g h : G) (z : B) :
+    scale ρ β h_all (g * h) z = scale ρ β h_all g (β h z) * scale ρ β h_all h z :=
+  congrFun
+    (scale_eq_of_formula ρ β h_all
+      (affine_mul_formula ρ β (action_formula ρ β h_all g) (action_formula ρ β h_all h)))
+    z
+
+private theorem
+    SpecialPeriods.MuTorsor.shift_mul {G B : Type*} [Group G] (ρ : G →* Equiv.Perm (B × ℂ))
+    (β : G →* Equiv.Perm B) (h_all : ∀ g, AffineFibres ρ β g) (g h : G) (z : B) :
+    shift ρ β h_all (g * h) z =
+      (scale ρ β h_all g (β h z) : ℂ) * shift ρ β h_all h z + shift ρ β h_all g (β h z) :=
+  congrFun
+    (shift_eq_of_formula ρ β h_all
+      (affine_mul_formula ρ β (action_formula ρ β h_all g) (action_formula ρ β h_all h)))
+    z
+
+private def SpecialPeriods.MuTorsor.HolomorphicAffineFibres {G B : Type*} [Group G]
+    (ρ : G →* Equiv.Perm (B × ℂ)) (β : G →* Equiv.Perm B) {E H : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [TopologicalSpace H] [TopologicalSpace B] [ChartedSpace H B]
+    (I : ModelWithCorners ℂ E H) (g : G) : Prop :=
+  ∃ a : B → ℂˣ,
+    ∃ b : B → ℂ,
+      (∀ z u, ρ g (z, u) = (β g z, (a z : ℂ) * u + b z)) ∧
+        ContMDiff I (modelWithCornersSelf ℂ ℂ) ω (fun z => (a z : ℂ)) ∧
+          ContMDiff I (modelWithCornersSelf ℂ ℂ) ω b
+
+private theorem SpecialPeriods.MuTorsor.holomorphicAffineFibres_one {G B : Type*} [Group G]
+    (ρ : G →* Equiv.Perm (B × ℂ)) (β : G →* Equiv.Perm B) {E H : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [TopologicalSpace H] [TopologicalSpace B] [ChartedSpace H B]
+    (I : ModelWithCorners ℂ E H) : HolomorphicAffineFibres ρ β I 1 :=
+  ⟨fun _ => 1, fun _ => 0, affine_one_formula ρ β, contMDiff_const, contMDiff_const⟩
+
+private theorem SpecialPeriods.MuTorsor.holomorphicAffineFibres_mul {G B : Type*} [Group G]
+    (ρ : G →* Equiv.Perm (B × ℂ)) (β : G →* Equiv.Perm B) {E H : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [TopologicalSpace H] [TopologicalSpace B] [ChartedSpace H B]
+    (I : ModelWithCorners ℂ E H) (hβ : ∀ g, ContMDiff I I ω (β g)) {g h : G}
+    (hg : HolomorphicAffineFibres ρ β I g) (hh : HolomorphicAffineFibres ρ β I h) :
+    HolomorphicAffineFibres ρ β I (g * h) := by
+  obtain ⟨a, b, hf, ha, hb⟩ := hg
+  obtain ⟨c, d, hf', hc, hd⟩ := hh
+  refine
+    ⟨fun z => a (β h z) * c z, fun z => (a (β h z) : ℂ) * d z + b (β h z),
+      affine_mul_formula ρ β hf hf', ?_, ?_⟩
+  · change ContMDiff I (modelWithCornersSelf ℂ ℂ) ω (fun z => (a (β h z) : ℂ) * (c z : ℂ))
+    exact (ha.comp (hβ h)).mul hc
+  · exact ((ha.comp (hβ h)).mul hd).add (hb.comp (hβ h))
+
+private theorem SpecialPeriods.MuTorsor.holomorphicAffineFibres_inv {G B : Type*} [Group G]
+    (ρ : G →* Equiv.Perm (B × ℂ)) (β : G →* Equiv.Perm B) {E H : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [TopologicalSpace H] [TopologicalSpace B] [ChartedSpace H B]
+    (I : ModelWithCorners ℂ E H) (hβ : ∀ g, ContMDiff I I ω (β g)) {g : G}
+    (hg : HolomorphicAffineFibres ρ β I g) : HolomorphicAffineFibres ρ β I g⁻¹ := by
+  obtain ⟨a, b, hf, ha, hb⟩ := hg
+  have hInv : ContMDiff I (modelWithCornersSelf ℂ ℂ) ω (fun z => (a (β g⁻¹ z) : ℂ)⁻¹) :=
+    (ha.comp (hβ g⁻¹)).inv₀ (fun z => (a (β g⁻¹ z)).ne_zero)
+  refine
+    ⟨fun z => (a (β g⁻¹ z))⁻¹, fun z => -((a (β g⁻¹ z) : ℂ)⁻¹ * b (β g⁻¹ z)),
+      affine_inv_formula ρ β hf, ?_, ?_⟩
+  · simpa only [Units.val_inv_eq_inv_val] using hInv
+  · exact (hInv.mul (hb.comp (hβ g⁻¹))).neg
+
+private def SpecialPeriods.MuTorsor.holomorphicAffineSubgroup {G B : Type*} [Group G]
+    (ρ : G →* Equiv.Perm (B × ℂ)) (β : G →* Equiv.Perm B) {E H : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [TopologicalSpace H] [TopologicalSpace B] [ChartedSpace H B]
+    (I : ModelWithCorners ℂ E H) (hβ : ∀ g, ContMDiff I I ω (β g)) : Subgroup G
+    where
+  carrier := HolomorphicAffineFibres ρ β I
+  one_mem' := holomorphicAffineFibres_one ρ β I
+  mul_mem' := holomorphicAffineFibres_mul ρ β I hβ
+  inv_mem' := holomorphicAffineFibres_inv ρ β I hβ
+
+private theorem SpecialPeriods.MuTorsor.scale_holomorphic {G B : Type*} [Group G]
+    (ρ : G →* Equiv.Perm (B × ℂ)) (β : G →* Equiv.Perm B) {E H : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [TopologicalSpace H] [TopologicalSpace B] [ChartedSpace H B]
+    (I : ModelWithCorners ℂ E H) (h_all : ∀ g, AffineFibres ρ β g) (g : G)
+    (hg : HolomorphicAffineFibres ρ β I g) :
+    ContMDiff I (modelWithCornersSelf ℂ ℂ) ω (fun z => (scale ρ β h_all g z : ℂ)) := by
+  obtain ⟨a, b, hf, ha, _⟩ := hg
+  rw [scale_eq_of_formula ρ β h_all hf]
+  exact ha
+
+private theorem SpecialPeriods.MuTorsor.shift_holomorphic {G B : Type*} [Group G]
+    (ρ : G →* Equiv.Perm (B × ℂ)) (β : G →* Equiv.Perm B) {E H : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [TopologicalSpace H] [TopologicalSpace B] [ChartedSpace H B]
+    (I : ModelWithCorners ℂ E H) (h_all : ∀ g, AffineFibres ρ β g) (g : G)
+    (hg : HolomorphicAffineFibres ρ β I g) :
+    ContMDiff I (modelWithCornersSelf ℂ ℂ) ω (shift ρ β h_all g) := by
+  obtain ⟨a, b, hf, _, hb⟩ := hg
+  rw [shift_eq_of_formula ρ β h_all hf]
+  exact hb
+
+private structure SpecialPeriods.MuTorsor.AffineCocycle where
+  scale : SpecialPeriods.TriangleGroup → ℍ → ℂˣ
+  shift : SpecialPeriods.TriangleGroup → ℍ → ℂ
+  scale_one : ∀ z, scale 1 z = 1
+  shift_one : ∀ z, shift 1 z = 0
+  scale_mul :
+    ∀ g h z,
+      scale (g * h) z = scale g (SpecialPeriods.triangleGeometricRepresentation h z) * scale h z
+  shift_mul :
+    ∀ g h z,
+      shift (g * h) z =
+        (scale g (SpecialPeriods.triangleGeometricRepresentation h z) : ℂ) * shift h z +
+          shift g (SpecialPeriods.triangleGeometricRepresentation h z)
+  scale_holomorphic : ∀ g, ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z => (scale g z : ℂ))
+  shift_holomorphic : ∀ g, ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (shift g)
+
+private def
+    SpecialPeriods.MuTorsor.AffineCocycle.fibreMap (c : SpecialPeriods.MuTorsor.AffineCocycle)
+    (g : SpecialPeriods.TriangleGroup) (z : ℍ) (u : ℂ) : ℂ :=
+  (c.scale g z : ℂ) * u + c.shift g z
+
+@[simp]
+private theorem SpecialPeriods.MuTorsor.AffineCocycle.fibreMap_one
+    (c : SpecialPeriods.MuTorsor.AffineCocycle) (z : ℍ) (u : ℂ) : c.fibreMap 1 z u = u := by
+  simp only [fibreMap, c.scale_one, c.shift_one, Units.val_one, one_mul, add_zero]
+
+private theorem SpecialPeriods.MuTorsor.AffineCocycle.fibreMap_mul
+    (c : SpecialPeriods.MuTorsor.AffineCocycle) (g h : SpecialPeriods.TriangleGroup) (z : ℍ)
+    (u : ℂ) :
+    c.fibreMap (g * h) z u =
+      c.fibreMap g (SpecialPeriods.triangleGeometricRepresentation h z) (c.fibreMap h z u) := by
+  simp only [fibreMap, c.scale_mul, c.shift_mul, Units.val_mul]
+  ring
+
+private theorem SpecialPeriods.MuTorsor.AffineCocycle.fibreMap_inv
+    (c : SpecialPeriods.MuTorsor.AffineCocycle) (g : SpecialPeriods.TriangleGroup) (z : ℍ)
+    (u : ℂ) :
+    c.fibreMap g⁻¹ (SpecialPeriods.triangleGeometricRepresentation g z) (c.fibreMap g z u) = u := by
+  rw [← c.fibreMap_mul, inv_mul_cancel, c.fibreMap_one]
+
+private theorem SpecialPeriods.MuTorsor.AffineCocycle.fibreMap_injective
+    (c : SpecialPeriods.MuTorsor.AffineCocycle) (g : SpecialPeriods.TriangleGroup) (z : ℍ) :
+    Function.Injective (c.fibreMap g z) := by
+  intro u v huv
+  exact mul_left_cancel₀ (c.scale g z).ne_zero (add_right_cancel huv)
+
+private theorem SpecialPeriods.MuTorsor.AffineCocycle.fibreMap_sub
+    (c : SpecialPeriods.MuTorsor.AffineCocycle) (g : SpecialPeriods.TriangleGroup) (z : ℍ)
+    (u v : ℂ) : c.fibreMap g z u - c.fibreMap g z v = (c.scale g z : ℂ) * (u - v) := by
+  simp only [fibreMap]
+  ring
+
+private def SpecialPeriods.MuTorsor.AffineCocycle.EquivariantOn
+    (c : SpecialPeriods.MuTorsor.AffineCocycle) (f : ℍ → ℂ) (V : Set ℍ) : Prop :=
+  ∀ g z, z ∈ V → f (SpecialPeriods.triangleGeometricRepresentation g z) = c.fibreMap g z (f z)
+
+private structure SpecialPeriods.MuTorsor.PreciselyInvariantPatch where
+  sheet : TopologicalSpace.Opens ℍ
+  stabilizer : Subgroup SpecialPeriods.TriangleGroup
+  mapsTo :
+    ∀ g : stabilizer,
+      Set.MapsTo
+        (SpecialPeriods.triangleGeometricRepresentation (g : SpecialPeriods.TriangleGroup)) sheet
+        sheet
+  returning :
+    ∀ g : SpecialPeriods.TriangleGroup,
+      ((SpecialPeriods.triangleGeometricRepresentation g '' (sheet : Set ℍ)) ∩ sheet).Nonempty →
+        g ∈ stabilizer
+
+private def SpecialPeriods.MuTorsor.PreciselyInvariantPatch.saturation
+    (P : SpecialPeriods.MuTorsor.PreciselyInvariantPatch) : Set ℍ :=
+  {z |
+    ∃ g : SpecialPeriods.TriangleGroup,
+      ∃ x : ℍ, x ∈ P.sheet ∧ SpecialPeriods.triangleGeometricRepresentation g x = z}
+
+private theorem SpecialPeriods.MuTorsor.PreciselyInvariantPatch.saturation_invariant
+    (P : SpecialPeriods.MuTorsor.PreciselyInvariantPatch) (g : SpecialPeriods.TriangleGroup)
+    (z : ℍ) :
+    SpecialPeriods.triangleGeometricRepresentation g z ∈ P.saturation ↔ z ∈ P.saturation := by
+  constructor
+  · rintro ⟨h, x, hx, he⟩
+    refine ⟨g⁻¹ * h, x, hx, ?_⟩
+    rw [map_mul]
+    change
+      SpecialPeriods.triangleGeometricRepresentation g⁻¹
+          (SpecialPeriods.triangleGeometricRepresentation h x) =
+        z
+    rw [he, map_inv]
+    exact (SpecialPeriods.triangleGeometricRepresentation g).symm_apply_apply z
+  · rintro ⟨h, x, hx, rfl⟩
+    exact ⟨g * h, x, hx, by simp⟩
+
+private theorem SpecialPeriods.MuTorsor.PreciselyInvariantPatch.saturation_isOpen
+    (P : SpecialPeriods.MuTorsor.PreciselyInvariantPatch) : IsOpen P.saturation := by
+  have he :
+    P.saturation =
+      ⋃ g : SpecialPeriods.TriangleGroup,
+        SpecialPeriods.triangleGeometricRepresentation g '' (P.sheet : Set ℍ) := by
+    ext z
+    simp only [saturation, Set.mem_iUnion, Set.mem_image]
+    rfl
+  rw [he]
+  exact
+    isOpen_iUnion fun g =>
+      (SpecialPeriods.triangleGeometricBiholomorph g).toHomeomorph.isOpenMap _ P.sheet.isOpen
+
+private theorem SpecialPeriods.MuTorsor.PreciselyInvariantPatch.saturation_eq_preimage_image
+    (P : SpecialPeriods.MuTorsor.PreciselyInvariantPatch) :
+    P.saturation =
+      SpecialPeriods.triangleOrbitProjection ⁻¹'
+        (SpecialPeriods.triangleOrbitProjection '' P.sheet) := by
+  ext z
+  constructor
+  · rintro ⟨g, x, hx, rfl⟩
+    exact ⟨x, hx, (SpecialPeriods.triangleOrbitProjection_smul g x).symm⟩
+  · rintro ⟨x, hx, he⟩
+    obtain ⟨g, hg⟩ := (SpecialPeriods.triangleOrbitProjection_eq_iff z x).mp he.symm
+    exact ⟨g, x, hx, hg⟩
+
+private theorem SpecialPeriods.MuTorsor.PreciselyInvariantPatch.stabilizer_mem_iff
+    (P : SpecialPeriods.MuTorsor.PreciselyInvariantPatch) (g : SpecialPeriods.TriangleGroup)
+    (x : ℍ) (hx : x ∈ P.sheet) :
+    SpecialPeriods.triangleGeometricRepresentation g x ∈ P.sheet ↔ g ∈ P.stabilizer := by
+  constructor
+  · intro hgx
+    exact P.returning g ⟨_, ⟨x, hx, rfl⟩, hgx⟩
+  · intro hg
+    exact P.mapsTo ⟨g, hg⟩ hx
+
+private structure SpecialPeriods.MuTorsor.PreciselyInvariantPatch.Seed
+    (P : SpecialPeriods.MuTorsor.PreciselyInvariantPatch)
+    (c : SpecialPeriods.MuTorsor.AffineCocycle) where
+  toFun : ℍ → ℂ
+  holomorphic : ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω toFun P.sheet
+  equivariant :
+    ∀ g : P.stabilizer,
+      ∀ z ∈ P.sheet,
+        toFun
+            (SpecialPeriods.triangleGeometricRepresentation (g : SpecialPeriods.TriangleGroup)
+              z) =
+          c.fibreMap g z (toFun z)
+
+private def SpecialPeriods.MuTorsor.AffineCocycle.sectionStabilizer
+    (c : SpecialPeriods.MuTorsor.AffineCocycle) (f : ℍ → ℂ) :
+    Subgroup SpecialPeriods.TriangleGroup
+    where
+  carrier :=
+    {g | ∀ z, f (SpecialPeriods.triangleGeometricRepresentation g z) = c.fibreMap g z (f z)}
+  one_mem' := by
+    intro z
+    simp only [map_one, Equiv.Perm.one_apply, c.fibreMap_one]
+  mul_mem' := by
+    intro g h hg hh z
+    calc
+      f (SpecialPeriods.triangleGeometricRepresentation (g * h) z) =
+          f
+            (SpecialPeriods.triangleGeometricRepresentation g
+              (SpecialPeriods.triangleGeometricRepresentation h z)) := by
+        rw [map_mul, Equiv.Perm.mul_apply]
+      _ =
+          c.fibreMap g (SpecialPeriods.triangleGeometricRepresentation h z)
+            (f (SpecialPeriods.triangleGeometricRepresentation h z)) :=
+        (hg _)
+      _ =
+          c.fibreMap g (SpecialPeriods.triangleGeometricRepresentation h z)
+            (c.fibreMap h z (f z)) := by rw [hh z]
+      _ = c.fibreMap (g * h) z (f z) := (c.fibreMap_mul g h z (f z)).symm
+  inv_mem' := by
+    intro g hg z
+    apply c.fibreMap_injective g (SpecialPeriods.triangleGeometricRepresentation g⁻¹ z)
+    have hbase :
+      SpecialPeriods.triangleGeometricRepresentation g
+          (SpecialPeriods.triangleGeometricRepresentation g⁻¹ z) =
+        z := by
+      rw [map_inv, Equiv.Perm.inv_def]
+      exact (SpecialPeriods.triangleGeometricRepresentation g).apply_symm_apply z
+    calc
+      c.fibreMap g (SpecialPeriods.triangleGeometricRepresentation g⁻¹ z)
+            (f (SpecialPeriods.triangleGeometricRepresentation g⁻¹ z)) =
+          f
+            (SpecialPeriods.triangleGeometricRepresentation g
+              (SpecialPeriods.triangleGeometricRepresentation g⁻¹ z)) :=
+        (hg _).symm
+      _ = f z := (congrArg f hbase)
+      _ =
+          c.fibreMap g (SpecialPeriods.triangleGeometricRepresentation g⁻¹ z)
+            (c.fibreMap g⁻¹ z (f z)) := by
+        simpa only [inv_inv] using (c.fibreMap_inv g⁻¹ z (f z)).symm
+
+private theorem SpecialPeriods.MuTorsor.AffineCocycle.zpowers_le_sectionStabilizer
+    (c : SpecialPeriods.MuTorsor.AffineCocycle) (f : ℍ → ℂ) (g : SpecialPeriods.TriangleGroup)
+    (hg : ∀ z, f (SpecialPeriods.triangleGeometricRepresentation g z) = c.fibreMap g z (f z)) :
+    Subgroup.zpowers g ≤ c.sectionStabilizer f :=
+  Subgroup.zpowers_le.mpr hg
+
+private theorem SpecialPeriods.MuTorsor.AffineCocycle.equivariant_of_mem_zpowers
+    (c : SpecialPeriods.MuTorsor.AffineCocycle) (f : ℍ → ℂ) (g : SpecialPeriods.TriangleGroup)
+    (hg : ∀ z, f (SpecialPeriods.triangleGeometricRepresentation g z) = c.fibreMap g z (f z))
+    {h : SpecialPeriods.TriangleGroup} (hh : h ∈ Subgroup.zpowers g) (z : ℍ) :
+    f (SpecialPeriods.triangleGeometricRepresentation h z) = c.fibreMap h z (f z) :=
+  c.zpowers_le_sectionStabilizer f g hg hh z
+
+private theorem SpecialPeriods.MuTorsor.mem_subgroup_of_triangle_generators_mo1973_17509
+    (K : Subgroup SpecialPeriods.TriangleGroup) (h₁ : SpecialPeriods.triangleGenerator₁ ∈ K)
+    (h₂ : SpecialPeriods.triangleGenerator₂ ∈ K) (g : SpecialPeriods.TriangleGroup) : g ∈ K := by
+  have hle :
+    Subgroup.closure
+        ({ SpecialPeriods.triangleGenerator₁, SpecialPeriods.triangleGenerator₂ } :
+          Set SpecialPeriods.TriangleGroup) ≤
+      K :=
+    (Subgroup.closure_le _).mpr
+      (by
+        intro x hx
+        rcases hx with rfl | rfl
+        · exact h₁
+        · exact h₂)
+  rw [SpecialPeriods.triangle_generators_generate] at hle
+  exact hle (Subgroup.mem_top g)
+
+private theorem SpecialPeriods.MuTorsor.representation_generatorOne_formula {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (z : ℍ) (u : ℂ) :
+    representation hτ SpecialPeriods.triangleGenerator₁ (z, u) =
+      (SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleGenerator₁ z,
+        (generatorOneScale τ z : ℂ) * u + generatorOneShift τ z) := by
+  rw [representation_generator₁, SpecialPeriods.triangleGeometricRepresentation_generator₁]
+  rfl
+
+private theorem SpecialPeriods.MuTorsor.representation_generatorTwo_formula {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (z : ℍ) (u : ℂ) :
+    representation hτ SpecialPeriods.triangleGenerator₂ (z, u) =
+      (SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleGenerator₂ z,
+        (generatorTwoScale τ z : ℂ) * u + generatorTwoShift z) := by
+  rw [representation_generator₂, SpecialPeriods.triangleGeometricRepresentation_generator₂]
+  rfl
+
+private theorem SpecialPeriods.MuTorsor.representation_affine {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (g : SpecialPeriods.TriangleGroup) :
+    AffineFibres (representation hτ) SpecialPeriods.triangleGeometricRepresentation g := by
+  apply
+    mem_subgroup_of_triangle_generators_mo1973_17509
+      (affineSubgroup (representation hτ) SpecialPeriods.triangleGeometricRepresentation)
+  · exact ⟨generatorOneScale τ, generatorOneShift τ, representation_generatorOne_formula hτ⟩
+  · exact ⟨generatorTwoScale τ, generatorTwoShift, representation_generatorTwo_formula hτ⟩
+
+private theorem SpecialPeriods.MuTorsor.representation_fst {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (g : SpecialPeriods.TriangleGroup) (z : ℍ) (u : ℂ) :
+    (representation hτ g (z, u)).1 = SpecialPeriods.triangleGeometricRepresentation g z :=
+  congrArg Prod.fst
+    (action_formula (representation hτ) SpecialPeriods.triangleGeometricRepresentation
+      (representation_affine hτ) g z u)
+
+private theorem SpecialPeriods.MuTorsor.representation_cusp_formula {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (z : ℍ) (u : ℂ) :
+    representation hτ SpecialPeriods.triangleCuspGenerator (z, u) =
+      (SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleCuspGenerator z,
+        u) :=
+  Prod.ext (representation_fst hτ _ z u) (representation_cusp_snd hτ z u)
+
+private theorem SpecialPeriods.MuTorsor.representation_holomorphic_affine {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ)
+    (g : SpecialPeriods.TriangleGroup) :
+    HolomorphicAffineFibres (representation hτ) SpecialPeriods.triangleGeometricRepresentation
+      𝓘(ℂ) g := by
+  apply
+    mem_subgroup_of_triangle_generators_mo1973_17509
+      (holomorphicAffineSubgroup (representation hτ)
+        SpecialPeriods.triangleGeometricRepresentation 𝓘(ℂ)
+        SpecialPeriods.triangleGeometricRepresentation_holomorphic)
+  · exact
+      ⟨generatorOneScale τ, generatorOneShift τ, representation_generatorOne_formula hτ,
+        generatorOneScale_holomorphic hτa, generatorOneShift_holomorphic hτa⟩
+  · exact
+      ⟨generatorTwoScale τ, generatorTwoShift, representation_generatorTwo_formula hτ,
+        generatorTwoScale_holomorphic hτa, generatorTwoShift_holomorphic⟩
+
+private def SpecialPeriods.MuTorsor.cocycle {τ : ℍ → ℍ} (hτ : SpecialPeriods.TauCovariant τ)
+    (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) : AffineCocycle
+    where
+  scale :=
+    scale (representation hτ) SpecialPeriods.triangleGeometricRepresentation
+      (representation_affine hτ)
+  shift :=
+    shift (representation hτ) SpecialPeriods.triangleGeometricRepresentation
+      (representation_affine hτ)
+  scale_one :=
+    scale_one (representation hτ) SpecialPeriods.triangleGeometricRepresentation
+      (representation_affine hτ)
+  shift_one :=
+    shift_one (representation hτ) SpecialPeriods.triangleGeometricRepresentation
+      (representation_affine hτ)
+  scale_mul :=
+    scale_mul (representation hτ) SpecialPeriods.triangleGeometricRepresentation
+      (representation_affine hτ)
+  shift_mul :=
+    shift_mul (representation hτ) SpecialPeriods.triangleGeometricRepresentation
+      (representation_affine hτ)
+  scale_holomorphic
+    g :=
+    scale_holomorphic (representation hτ) SpecialPeriods.triangleGeometricRepresentation 𝓘(ℂ)
+      (representation_affine hτ) g (representation_holomorphic_affine hτ hτa g)
+  shift_holomorphic
+    g :=
+    shift_holomorphic (representation hτ) SpecialPeriods.triangleGeometricRepresentation 𝓘(ℂ)
+      (representation_affine hτ) g (representation_holomorphic_affine hτ hτa g)
+
+@[simp]
+private theorem SpecialPeriods.MuTorsor.cocycle_scale_generator₁ {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (z : ℍ) :
+    (cocycle hτ hτa).scale SpecialPeriods.triangleGenerator₁ z = generatorOneScale τ z :=
+  congrFun
+    (scale_eq_of_formula (representation hτ) SpecialPeriods.triangleGeometricRepresentation
+      (representation_affine hτ) (representation_generatorOne_formula hτ))
+    z
+
+@[simp]
+private theorem SpecialPeriods.MuTorsor.cocycle_scale_generator₂ {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (z : ℍ) :
+    (cocycle hτ hτa).scale SpecialPeriods.triangleGenerator₂ z = generatorTwoScale τ z :=
+  congrFun
+    (scale_eq_of_formula (representation hτ) SpecialPeriods.triangleGeometricRepresentation
+      (representation_affine hτ) (representation_generatorTwo_formula hτ))
+    z
+
+@[simp]
+private theorem SpecialPeriods.MuTorsor.cocycle_shift_generator₁ {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (z : ℍ) :
+    (cocycle hτ hτa).shift SpecialPeriods.triangleGenerator₁ z = 1 / (τ z : ℂ) :=
+  congrFun
+    (shift_eq_of_formula (representation hτ) SpecialPeriods.triangleGeometricRepresentation
+      (representation_affine hτ) (representation_generatorOne_formula hτ))
+    z
+
+@[simp]
+private theorem SpecialPeriods.MuTorsor.cocycle_shift_generator₂ {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (z : ℍ) :
+    (cocycle hτ hτa).shift SpecialPeriods.triangleGenerator₂ z = 1 :=
+  congrFun
+    (shift_eq_of_formula (representation hτ) SpecialPeriods.triangleGeometricRepresentation
+      (representation_affine hτ) (representation_generatorTwo_formula hτ))
+    z
+
+private theorem SpecialPeriods.MuTorsor.cocycle_scale_generator₁_val {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (z : ℍ) :
+    ((cocycle hτ hτa).scale SpecialPeriods.triangleGenerator₁ z : ℂ) = -1 / (τ z : ℂ) := by
+  rw [cocycle_scale_generator₁, generatorOneScale_val]
+
+private theorem SpecialPeriods.MuTorsor.cocycle_scale_generator₂_val {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (z : ℍ) :
+    ((cocycle hτ hτa).scale SpecialPeriods.triangleGenerator₂ z : ℂ) = 1 / (τ z : ℂ) := by
+  rw [cocycle_scale_generator₂, generatorTwoScale_val]
+
+private theorem SpecialPeriods.MuTorsor.cocycle_fibreMap_generator₁ {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (z : ℍ) (u : ℂ) :
+    (cocycle hτ hτa).fibreMap SpecialPeriods.triangleGenerator₁ z u = (1 - u) / (τ z : ℂ) := by
+  rw [AffineCocycle.fibreMap, cocycle_scale_generator₁_val, cocycle_shift_generator₁]
+  ring
+
+private theorem SpecialPeriods.MuTorsor.cocycle_fibreMap_generator₂ {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (z : ℍ) (u : ℂ) :
+    (cocycle hτ hτa).fibreMap SpecialPeriods.triangleGenerator₂ z u = 1 + u / (τ z : ℂ) := by
+  rw [AffineCocycle.fibreMap, cocycle_scale_generator₂_val, cocycle_shift_generator₂]
+  ring
+
+private theorem SpecialPeriods.MuTorsor.representation_cusp_affine_formula_mo1973_17526
+    {τ : ℍ → ℍ} (hτ : SpecialPeriods.TauCovariant τ) (z : ℍ) (u : ℂ) :
+    representation hτ SpecialPeriods.triangleCuspGenerator (z, u) =
+      (SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleCuspGenerator z,
+        ((1 : ℂˣ) : ℂ) * u + 0) := by
+  simpa only [Units.val_one, one_mul, add_zero] using representation_cusp_formula hτ z u
+
+@[simp]
+private theorem SpecialPeriods.MuTorsor.cocycle_scale_cusp {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (z : ℍ) :
+    (cocycle hτ hτa).scale SpecialPeriods.triangleCuspGenerator z = 1 :=
+  congrFun
+    (scale_eq_of_formula (representation hτ) SpecialPeriods.triangleGeometricRepresentation
+      (representation_affine hτ) (representation_cusp_affine_formula_mo1973_17526 hτ))
+    z
+
+@[simp]
+private theorem SpecialPeriods.MuTorsor.cocycle_shift_cusp {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (z : ℍ) :
+    (cocycle hτ hτa).shift SpecialPeriods.triangleCuspGenerator z = 0 :=
+  congrFun
+    (shift_eq_of_formula (representation hτ) SpecialPeriods.triangleGeometricRepresentation
+      (representation_affine hτ) (representation_cusp_affine_formula_mo1973_17526 hτ))
+    z
+
+@[simp]
+private theorem SpecialPeriods.MuTorsor.cocycle_fibreMap_cusp {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (z : ℍ) (u : ℂ) :
+    (cocycle hτ hτa).fibreMap SpecialPeriods.triangleCuspGenerator z u = u := by
+  simp only [AffineCocycle.fibreMap, cocycle_scale_cusp, cocycle_shift_cusp, Units.val_one,
+    one_mul, add_zero]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private def SpecialPeriods.MuTorsor.Cover.regularRepresentative
+    (x : SpecialPeriods.TriangleRegularQuotient) : SpecialPeriods.TriangleRegularPoint :=
+  CoveringQuotient.representative SpecialPeriods.triangleRegularProject_covering x
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+@[simp]
+private theorem SpecialPeriods.MuTorsor.Cover.regularRepresentative_project
+    (x : SpecialPeriods.TriangleRegularQuotient) :
+    SpecialPeriods.triangleRegularProject (regularRepresentative x) = x :=
+  CoveringQuotient.project_representative SpecialPeriods.triangleRegularProject_covering x
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private def SpecialPeriods.MuTorsor.Cover.regularLift (x : SpecialPeriods.TriangleRegularQuotient) :
+    OpenPartialHomeomorph SpecialPeriods.TriangleRegularQuotient
+      SpecialPeriods.TriangleRegularPoint :=
+  CoveringQuotient.localInverse SpecialPeriods.triangleRegularProject_covering
+    (regularRepresentative x)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+@[simp]
+private theorem SpecialPeriods.MuTorsor.Cover.regularLift_symm
+    (x : SpecialPeriods.TriangleRegularQuotient) :
+    (regularLift x).symm = SpecialPeriods.triangleRegularProject :=
+  CoveringQuotient.localInverse_symm SpecialPeriods.triangleRegularProject_covering
+    (regularRepresentative x)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.MuTorsor.Cover.regularRepresentative_mem_target
+    (x : SpecialPeriods.TriangleRegularQuotient) :
+    regularRepresentative x ∈ (regularLift x).target :=
+  IsLocalHomeomorph.self_mem_localInverseAt_target
+    SpecialPeriods.triangleRegularProject_covering.isCoveringMap.isLocalHomeomorph
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private def
+    SpecialPeriods.MuTorsor.Cover.regularSheet (x : SpecialPeriods.TriangleRegularQuotient) :
+    TopologicalSpace.Opens ℍ :=
+  ⟨Subtype.val '' (regularLift x).target,
+    SpecialPeriods.triangleRegularDomain.isOpen.isOpenMap_subtype_val _
+      (regularLift x).open_target⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.MuTorsor.Cover.regularSheet_subset_regularLocus
+    (x : SpecialPeriods.TriangleRegularQuotient) :
+    (regularSheet x : Set ℍ) ⊆ SpecialPeriods.triangleRegularLocus := by
+  rintro z ⟨a, ha, rfl⟩
+  exact a.property
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.MuTorsor.Cover.regularRepresentative_mem_sheet
+    (x : SpecialPeriods.TriangleRegularQuotient) :
+    (regularRepresentative x).val ∈ regularSheet x :=
+  ⟨regularRepresentative x, regularRepresentative_mem_target x, rfl⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.MuTorsor.Cover.regularSheet_no_return
+    (x : SpecialPeriods.TriangleRegularQuotient) (g : SpecialPeriods.TriangleGroup)
+    (hg :
+      ((SpecialPeriods.triangleGeometricRepresentation g '' (regularSheet x : Set ℍ)) ∩
+          regularSheet x).Nonempty) :
+    g = 1 := by
+  rcases hg with ⟨z, ⟨w, ⟨a, ha, rfl⟩, hga⟩, ⟨b, hb, rfl⟩⟩
+  have hab : g • a = b := Subtype.ext hga
+  have hproj :
+    SpecialPeriods.triangleRegularProject b = SpecialPeriods.triangleRegularProject a := by
+    rw [← hab]
+    exact SpecialPeriods.triangleRegularProject_covering.map_smul g
+  have hba : b = a :=
+    (regularLift x).symm.injOn hb ha (by simpa only [regularLift_symm] using hproj)
+  exact
+    (SpecialPeriods.mem_triangleRegularLocus_iff a.val).mp a.property g
+      (congrArg Subtype.val (hab.trans hba))
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+@[simp]
+private theorem SpecialPeriods.MuTorsor.Cover.regularRepresentative_orbitProjection
+    (x : SpecialPeriods.TriangleRegularQuotient) :
+    SpecialPeriods.triangleOrbitProjection (regularRepresentative x).val =
+      SpecialPeriods.triangleRegularToOrbit x := by
+  rw [← SpecialPeriods.triangleRegularToOrbit_project, regularRepresentative_project]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private def
+    SpecialPeriods.MuTorsor.Cover.regularImage (x : SpecialPeriods.TriangleRegularQuotient) :
+    TopologicalSpace.Opens SpecialPeriods.TriangleOrbitSpace :=
+  ⟨SpecialPeriods.triangleOrbitProjection '' (regularSheet x : Set ℍ),
+    SpecialPeriods.triangleOrbitProjection_isOpenMap _ (regularSheet x).isOpen⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.MuTorsor.Cover.regularImage_subset_regularDomain
+    (x : SpecialPeriods.TriangleRegularQuotient) :
+    (regularImage x : Set SpecialPeriods.TriangleOrbitSpace) ⊆
+      SpecialPeriods.triangleOrbitRegularDomain := by
+  rintro y ⟨z, hz, rfl⟩
+  exact
+    (SpecialPeriods.triangleOrbitProjection_mem_regularDomain_iff z).mpr
+      (regularSheet_subset_regularLocus x hz)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.MuTorsor.Cover.regularImage_mem
+    (x : SpecialPeriods.TriangleRegularQuotient) :
+    SpecialPeriods.triangleRegularToOrbit x ∈ regularImage x :=
+  ⟨(regularRepresentative x).val, regularRepresentative_mem_sheet x,
+    regularRepresentative_orbitProjection x⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem
+    SpecialPeriods.MuTorsor.Cover.exists_regularImage (y : SpecialPeriods.TriangleOrbitSpace)
+    (hy : y ∈ SpecialPeriods.triangleOrbitRegularDomain) :
+    ∃ x : SpecialPeriods.TriangleRegularQuotient, y ∈ regularImage x := by
+  obtain ⟨x, rfl⟩ := hy
+  exact ⟨x, regularImage_mem x⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private abbrev SpecialPeriods.MuTorsor.Cover.Index :=
+  Option (SpecialPeriods.TriangleRegularQuotient ⊕ Elliptic.Kind)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.MuTorsor.Cover.cuspIndex : Index :=
+  Option.none
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def
+    SpecialPeriods.MuTorsor.Cover.regularIndex (x : SpecialPeriods.TriangleRegularQuotient) :
+    Index :=
+  Option.some (.inl x)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.MuTorsor.Cover.ellipticIndex (j : Elliptic.Kind) : Index :=
+  Option.some (.inr j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def
+    SpecialPeriods.MuTorsor.Cover.cuspPatch : SpecialPeriods.MuTorsor.PreciselyInvariantPatch
+    where
+  sheet := SpecialPeriods.Triangle.horodisc SpecialPeriods.Triangle.width
+  stabilizer := Subgroup.zpowers SpecialPeriods.triangleCuspGenerator
+  mapsTo := SpecialPeriods.Triangle.cusp_horodisc_invariant SpecialPeriods.Triangle.width
+  returning :=
+    SpecialPeriods.Triangle.triangle_horodisc_overlap_mem_cusp SpecialPeriods.Triangle.width
+      le_rfl
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def
+    SpecialPeriods.MuTorsor.Cover.regularPatch (x : SpecialPeriods.TriangleRegularQuotient) :
+    SpecialPeriods.MuTorsor.PreciselyInvariantPatch
+    where
+  sheet := regularSheet x
+  stabilizer := ⊥
+  mapsTo := by
+    intro g z hz
+    have hg : (g : SpecialPeriods.TriangleGroup) = 1 := Subgroup.mem_bot.mp g.property
+    simpa only [hg, map_one, Equiv.Perm.one_apply] using hz
+  returning := fun g hg => Subgroup.mem_bot.mpr (regularSheet_no_return x g hg)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.MuTorsor.Cover.ellipticPatch (j : Elliptic.Kind) :
+    SpecialPeriods.MuTorsor.PreciselyInvariantPatch
+    where
+  sheet := SpecialPeriods.Triangle.ellipticNeighborhood j
+  stabilizer := SpecialPeriods.Triangle.ellipticStabilizer j
+  mapsTo := SpecialPeriods.Triangle.ellipticNeighborhood_mapsTo j
+  returning := SpecialPeriods.Triangle.ellipticNeighborhood_return j
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def
+    SpecialPeriods.MuTorsor.Cover.patch : Index → SpecialPeriods.MuTorsor.PreciselyInvariantPatch
+  | none => cuspPatch
+  | some (.inl x) => regularPatch x
+  | some (.inr j) => ellipticPatch j
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.MuTorsor.Cover.compactImage
+    (V : TopologicalSpace.Opens SpecialPeriods.TriangleOrbitSpace) :
+    TopologicalSpace.Opens SpecialPeriods.TriangleCompactifiedOrbitSpace :=
+  ⟨SpecialPeriods.triangleOpenInclusion '' (V : Set SpecialPeriods.TriangleOrbitSpace),
+    SpecialPeriods.triangleOpenInclusion_isOpenEmbedding.isOpenMap _ V.isOpen⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.MuTorsor.Cover.openInclusion_mem_compactImage
+    (V : TopologicalSpace.Opens SpecialPeriods.TriangleOrbitSpace)
+    (q : SpecialPeriods.TriangleOrbitSpace) :
+    SpecialPeriods.triangleOpenInclusion q ∈ compactImage V ↔ q ∈ V :=
+  SpecialPeriods.triangleOpenInclusion_isOpenEmbedding.injective.mem_set_image
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.MuTorsor.Cover.compactPatch :
+    Index → TopologicalSpace.Opens SpecialPeriods.TriangleCompactifiedOrbitSpace
+  | none => SpecialPeriods.Triangle.cuspNeighborhood SpecialPeriods.Triangle.width
+  | some (.inl x) => compactImage (regularImage x)
+  | some (.inr j) => compactImage (SpecialPeriods.Triangle.ellipticNeighborhoodImage j)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.Cover.compactPatch_preimage_openInclusion (i : Index) :
+    SpecialPeriods.triangleOpenInclusion ⁻¹'
+        (compactPatch i : Set SpecialPeriods.TriangleCompactifiedOrbitSpace) =
+      SpecialPeriods.triangleOrbitProjection '' ((patch i).sheet : Set ℍ) := by
+  cases i with
+  | none => exact SpecialPeriods.Triangle.cuspNeighborhood_preimage SpecialPeriods.Triangle.width
+  | some i =>
+    cases i with
+    | inl x =>
+      ext q
+      exact openInclusion_mem_compactImage (regularImage x) q
+    | inr j =>
+      ext q
+      exact openInclusion_mem_compactImage (SpecialPeriods.Triangle.ellipticNeighborhoodImage j) q
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.Cover.compactPatch_preimage_projection (i : Index) :
+    SpecialPeriods.triangleCompactifiedProjection ⁻¹'
+        (compactPatch i : Set SpecialPeriods.TriangleCompactifiedOrbitSpace) =
+      (patch i).saturation := by
+  change
+    SpecialPeriods.triangleOrbitProjection ⁻¹'
+        (SpecialPeriods.triangleOpenInclusion ⁻¹'
+          (compactPatch i : Set SpecialPeriods.TriangleCompactifiedOrbitSpace)) =
+      _
+  rw [compactPatch_preimage_openInclusion, (patch i).saturation_eq_preimage_image]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.MuTorsor.Cover.compactifiedProjection_mem_compactPatch (i : Index)
+    (z : ℍ) :
+    SpecialPeriods.triangleCompactifiedProjection z ∈ compactPatch i ↔ z ∈ (patch i).saturation :=
+  by
+  change
+    z ∈
+        SpecialPeriods.triangleCompactifiedProjection ⁻¹'
+          (compactPatch i : Set SpecialPeriods.TriangleCompactifiedOrbitSpace) ↔
+      _
+  rw [compactPatch_preimage_projection]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.Cover.exists_compactPatch
+    (q : SpecialPeriods.TriangleCompactifiedOrbitSpace) : ∃ i : Index, q ∈ compactPatch i := by
+  induction q using OnePoint.rec with
+  | infty =>
+    exact
+      ⟨cuspIndex,
+        SpecialPeriods.Triangle.cuspPoint_mem_cuspNeighborhood SpecialPeriods.Triangle.width⟩
+  | coe q =>
+    by_cases h₁ : q = SpecialPeriods.triangleOrbitCenterOne
+    · subst q
+      exact
+        ⟨ellipticIndex .three, SpecialPeriods.triangleOrbitCenterOne,
+          SpecialPeriods.Triangle.ellipticOrbitCenter_mem_neighborhoodImage .three, rfl⟩
+    by_cases h₂ : q = SpecialPeriods.triangleOrbitCenterTwo
+    · subst q
+      exact
+        ⟨ellipticIndex .four, SpecialPeriods.triangleOrbitCenterTwo,
+          SpecialPeriods.Triangle.ellipticOrbitCenter_mem_neighborhoodImage .four, rfl⟩
+    obtain ⟨x, hx⟩ :=
+      exists_regularImage q ((SpecialPeriods.triangleOrbitRegularDomain_mem_iff q).mpr ⟨h₁, h₂⟩)
+    exact ⟨regularIndex x, q, hx, rfl⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.Cover.ellipticOrbitCenter_not_mem_regularDomain
+    (j : Elliptic.Kind) :
+    SpecialPeriods.Triangle.ellipticOrbitCenter j ∉ SpecialPeriods.triangleOrbitRegularDomain := by
+  cases j with
+  | three => exact fun h => ((SpecialPeriods.triangleOrbitRegularDomain_mem_iff _).mp h).1 rfl
+  | four => exact fun h => ((SpecialPeriods.triangleOrbitRegularDomain_mem_iff _).mp h).2 rfl
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.Cover.ellipticOrbitCenter_mem_neighborhoodImage_iff
+    (j k : Elliptic.Kind) :
+    SpecialPeriods.Triangle.ellipticOrbitCenter j ∈
+        SpecialPeriods.Triangle.ellipticNeighborhoodImage k ↔
+      j = k := by
+  by_cases h : j = k
+  · subst j
+    exact iff_of_true (SpecialPeriods.Triangle.ellipticOrbitCenter_mem_neighborhoodImage k) rfl
+  · have hj : j = SpecialPeriods.Triangle.ellipticOtherKind k := by
+      cases j <;> cases k <;> simp_all [SpecialPeriods.Triangle.ellipticOtherKind]
+    exact
+      iff_of_false
+        (by
+          rw [hj]
+          exact SpecialPeriods.Triangle.ellipticOtherOrbitCenter_not_mem_neighborhoodImage k)
+        h
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.MuTorsor.Cover.compactPatch_center_unique (j : Elliptic.Kind) (i : Index) :
+    SpecialPeriods.triangleOpenInclusion (SpecialPeriods.Triangle.ellipticOrbitCenter j) ∈
+        compactPatch i ↔
+      i = ellipticIndex j := by
+  cases i with
+  | none =>
+    apply iff_of_false
+    · intro h
+      exact
+        ellipticOrbitCenter_not_mem_regularDomain j
+          (SpecialPeriods.Triangle.cuspImage_subset_regularDomain SpecialPeriods.Triangle.width
+            le_rfl
+            ((SpecialPeriods.Triangle.openInclusion_mem_cuspNeighborhood
+                  SpecialPeriods.Triangle.width _).mp
+              h))
+    · intro h
+      cases h
+  | some i =>
+    cases i with
+    | inl x =>
+      apply iff_of_false
+      · intro h
+        exact
+          ellipticOrbitCenter_not_mem_regularDomain j
+            (regularImage_subset_regularDomain x
+              ((openInclusion_mem_compactImage (regularImage x) _).mp h))
+      · intro h
+        cases h
+    | inr
+      k =>
+      change
+        SpecialPeriods.triangleOpenInclusion (SpecialPeriods.Triangle.ellipticOrbitCenter j) ∈
+            compactImage (SpecialPeriods.Triangle.ellipticNeighborhoodImage k) ↔
+          Option.some (Sum.inr k) = Option.some (Sum.inr j)
+      rw [openInclusion_mem_compactImage, ellipticOrbitCenter_mem_neighborhoodImage_iff]
+      simp only [Option.some.injEq, Sum.inr.injEq, eq_comm]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.MuTorsor.Cover.distinct_compactPatch_overlap_avoids_center {i k : Index}
+    (hik : i ≠ k) (j : Elliptic.Kind) :
+    SpecialPeriods.triangleOpenInclusion (SpecialPeriods.Triangle.ellipticOrbitCenter j) ∉
+      (compactPatch i : Set SpecialPeriods.TriangleCompactifiedOrbitSpace) ∩ compactPatch k := by
+  intro h
+  exact
+    hik
+      (((compactPatch_center_unique j i).mp h.1).trans
+        ((compactPatch_center_unique j k).mp h.2).symm)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.Cover.distinct_saturation_overlap_subset_regularLocus
+    {i k : Index} (hik : i ≠ k) :
+    (patch i).saturation ∩ (patch k).saturation ⊆ SpecialPeriods.triangleRegularLocus := by
+  intro z hz
+  have hq :
+    SpecialPeriods.triangleCompactifiedProjection z ∈
+      (compactPatch i : Set SpecialPeriods.TriangleCompactifiedOrbitSpace) ∩ compactPatch k :=
+    ⟨(compactifiedProjection_mem_compactPatch i z).mpr hz.1,
+      (compactifiedProjection_mem_compactPatch k z).mpr hz.2⟩
+  apply (SpecialPeriods.triangleOrbitProjection_mem_regularDomain_iff z).mp
+  apply (SpecialPeriods.triangleOrbitRegularDomain_mem_iff _).mpr
+  constructor
+  · intro h
+    have he :
+      SpecialPeriods.triangleCompactifiedProjection z =
+        SpecialPeriods.triangleOpenInclusion
+          (SpecialPeriods.Triangle.ellipticOrbitCenter .three) :=
+      congrArg SpecialPeriods.triangleOpenInclusion h
+    exact distinct_compactPatch_overlap_avoids_center hik .three (he ▸ hq)
+  · intro h
+    have he :
+      SpecialPeriods.triangleCompactifiedProjection z =
+        SpecialPeriods.triangleOpenInclusion
+          (SpecialPeriods.Triangle.ellipticOrbitCenter .four) :=
+      congrArg SpecialPeriods.triangleOpenInclusion h
+    exact distinct_compactPatch_overlap_avoids_center hik .four (he ▸ hq)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.MuTorsor.Cover.finitePatch
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (i : Index) : TopologicalSpace.Opens ℂ :=
+  finitePullback π (compactPatch i)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.Cover.exists_finitePatch
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (z : ℂ) : ∃ i : Index, z ∈ finitePatch π i :=
+  exists_compactPatch (finiteInverse π z)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.Cover.finitePatch_cusp_contains_exterior
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    ∃ R : ℝ, 0 < R ∧ (Metric.ball (0 : ℂ) R)ᶜ ⊆ finitePatch π cuspIndex :=
+  finitePullback_contains_exterior π hπ
+    (SpecialPeriods.Triangle.cuspNeighborhood SpecialPeriods.Triangle.width)
+    (SpecialPeriods.Triangle.cuspPoint_mem_cuspNeighborhood SpecialPeriods.Triangle.width)
+
+private theorem SpecialPeriods.MuTorsor.PreciselyInvariantPatch.Seed.translated_values_agree
+    {P : SpecialPeriods.MuTorsor.PreciselyInvariantPatch}
+    {c : SpecialPeriods.MuTorsor.AffineCocycle} (s : P.Seed c)
+    (g h : SpecialPeriods.TriangleGroup) (x y : ℍ) (hx : x ∈ P.sheet) (hy : y ∈ P.sheet)
+    (he :
+      SpecialPeriods.triangleGeometricRepresentation g x =
+        SpecialPeriods.triangleGeometricRepresentation h y) :
+    c.fibreMap g x (s.toFun x) = c.fibreMap h y (s.toFun y) := by
+  have hxy : SpecialPeriods.triangleGeometricRepresentation (h⁻¹ * g) x = y := by
+    rw [map_mul]
+    change
+      SpecialPeriods.triangleGeometricRepresentation h⁻¹
+          (SpecialPeriods.triangleGeometricRepresentation g x) =
+        y
+    rw [he, map_inv]
+    exact (SpecialPeriods.triangleGeometricRepresentation h).symm_apply_apply y
+  have hk : h⁻¹ * g ∈ P.stabilizer := (P.stabilizer_mem_iff (h⁻¹ * g) x hx).mp (hxy ▸ hy)
+  have hs := s.equivariant ⟨h⁻¹ * g, hk⟩ x hx
+  change
+    s.toFun (SpecialPeriods.triangleGeometricRepresentation (h⁻¹ * g) x) =
+      c.fibreMap (h⁻¹ * g) x (s.toFun x) at hs
+  rw [hxy] at hs
+  calc
+    c.fibreMap g x (s.toFun x) = c.fibreMap (h * (h⁻¹ * g)) x (s.toFun x) := by
+      rw [mul_inv_cancel_left]
+    _ =
+        c.fibreMap h (SpecialPeriods.triangleGeometricRepresentation (h⁻¹ * g) x)
+          (c.fibreMap (h⁻¹ * g) x (s.toFun x)) :=
+      c.fibreMap_mul ..
+    _ = c.fibreMap h y (s.toFun y) := by rw [hxy, ← hs]
+
+private def SpecialPeriods.MuTorsor.PreciselyInvariantPatch.representative
+    (P : SpecialPeriods.MuTorsor.PreciselyInvariantPatch) (z : P.saturation) :
+    SpecialPeriods.TriangleGroup × P.sheet :=
+  let hg := z.property.choose_spec
+  ⟨z.property.choose, ⟨hg.choose, hg.choose_spec.1⟩⟩
+
+private theorem SpecialPeriods.MuTorsor.PreciselyInvariantPatch.representative_spec
+    (P : SpecialPeriods.MuTorsor.PreciselyInvariantPatch) (z : P.saturation) :
+    SpecialPeriods.triangleGeometricRepresentation (P.representative z).1 (P.representative z).2 =
+      z :=
+  z.property.choose_spec.choose_spec.2
+
+private def SpecialPeriods.MuTorsor.PreciselyInvariantPatch.Seed.extend
+    {P : SpecialPeriods.MuTorsor.PreciselyInvariantPatch}
+    {c : SpecialPeriods.MuTorsor.AffineCocycle} (s : P.Seed c) (z : ℍ) : ℂ := by
+  classical
+    exact
+    if hz : z ∈ P.saturation then
+      let r := P.representative ⟨z, hz⟩
+      c.fibreMap r.1 r.2 (s.toFun r.2)
+    else 0
+
+private theorem SpecialPeriods.MuTorsor.PreciselyInvariantPatch.Seed.extend_translate
+    {P : SpecialPeriods.MuTorsor.PreciselyInvariantPatch}
+    {c : SpecialPeriods.MuTorsor.AffineCocycle} (s : P.Seed c) (g : SpecialPeriods.TriangleGroup)
+    (x : ℍ) (hx : x ∈ P.sheet) :
+    s.extend (SpecialPeriods.triangleGeometricRepresentation g x) = c.fibreMap g x (s.toFun x) := by
+  have hz : SpecialPeriods.triangleGeometricRepresentation g x ∈ P.saturation := ⟨g, x, hx, rfl⟩
+  rw [SpecialPeriods.MuTorsor.PreciselyInvariantPatch.Seed.extend, dite_eq_left hz]
+  exact
+    s.translated_values_agree _ g _ x (P.representative ⟨_, hz⟩).2.property hx
+      (P.representative_spec ⟨_, hz⟩)
+
+private theorem SpecialPeriods.MuTorsor.PreciselyInvariantPatch.Seed.extend_eq
+    {P : SpecialPeriods.MuTorsor.PreciselyInvariantPatch}
+    {c : SpecialPeriods.MuTorsor.AffineCocycle} (s : P.Seed c) (x : ℍ) (hx : x ∈ P.sheet) :
+    s.extend x = s.toFun x := by
+  simpa only [map_one, Equiv.Perm.one_apply, c.fibreMap_one] using s.extend_translate 1 x hx
+
+private theorem SpecialPeriods.MuTorsor.PreciselyInvariantPatch.Seed.extend_equivariant
+    {P : SpecialPeriods.MuTorsor.PreciselyInvariantPatch}
+    {c : SpecialPeriods.MuTorsor.AffineCocycle} (s : P.Seed c) :
+    c.EquivariantOn s.extend P.saturation := by
+  intro g z hz
+  obtain ⟨h, x, hx, rfl⟩ := hz
+  have hmul :
+    SpecialPeriods.triangleGeometricRepresentation g
+        (SpecialPeriods.triangleGeometricRepresentation h x) =
+      SpecialPeriods.triangleGeometricRepresentation (g * h) x := by simp
+  rw [hmul, s.extend_translate (g * h) x hx, s.extend_translate h x hx, c.fibreMap_mul]
+
+private theorem SpecialPeriods.MuTorsor.PreciselyInvariantPatch.Seed.extend_holomorphic
+    {P : SpecialPeriods.MuTorsor.PreciselyInvariantPatch}
+    {c : SpecialPeriods.MuTorsor.AffineCocycle} (s : P.Seed c) :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω s.extend P.saturation := by
+  rintro z ⟨g, x, hx, rfl⟩
+  apply ContMDiffAt.contMDiffWithinAt
+  let v : ℍ → ℍ := SpecialPeriods.triangleGeometricRepresentation g⁻¹
+  have hv : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω v :=
+    SpecialPeriods.triangleGeometricRepresentation_holomorphic g⁻¹
+  have hvx : v (SpecialPeriods.triangleGeometricRepresentation g x) = x := by simp [v, map_inv]
+  have hsx : ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω s.toFun x :=
+    s.holomorphic.contMDiffAt (P.sheet.isOpen.mem_nhds hx)
+  have hcomp :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (s.toFun ∘ v) (SpecialPeriods.triangleGeometricRepresentation g x) :=
+    hsx.comp_of_eq (hv _) hvx
+  have ha :=
+    ((c.scale_holomorphic g).comp hv) (SpecialPeriods.triangleGeometricRepresentation g x)
+  have hb :=
+    ((c.shift_holomorphic g).comp hv) (SpecialPeriods.triangleGeometricRepresentation g x)
+  apply (ha.mul hcomp |>.add hb).congr_of_eventuallyEq
+  have hnear : ∀ᶠ y in 𝓝 (SpecialPeriods.triangleGeometricRepresentation g x), v y ∈ P.sheet := by
+    apply hv.continuous.continuousAt.preimage_mem_nhds
+    rw [hvx]
+    exact P.sheet.isOpen.mem_nhds hx
+  filter_upwards [hnear] with y hy
+  have hgy : SpecialPeriods.triangleGeometricRepresentation g (v y) = y := by simp [v, map_inv]
+  have he := s.extend_translate g (v y) hy
+  rw [hgy] at he
+  exact he
+
+private def SpecialPeriods.MuTorsor.ellipticFormula (τ : ℍ → ℍ) : Elliptic.Kind → ℍ → ℂ
+  | .three, z => (2 - (τ z : ℂ)) / 3
+  | .four, z => (1 - (τ z : ℂ)) / 2
+
+private theorem SpecialPeriods.MuTorsor.ellipticFormula_holomorphic {τ : ℍ → ℍ}
+    (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (j : Elliptic.Kind) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (ellipticFormula τ j) := by
+  have ht := UpperHalfPlane.contMDiff_coe.comp hτa
+  cases j
+  · exact (contMDiff_const.sub ht).div₀ contMDiff_const (fun _ => by norm_num)
+  · exact (contMDiff_const.sub ht).div₀ contMDiff_const (fun _ => by norm_num)
+
+private theorem SpecialPeriods.MuTorsor.ellipticFormula_generator {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (j : Elliptic.Kind)
+    (z : ℍ) :
+    ellipticFormula τ j
+        (SpecialPeriods.triangleGeometricRepresentation
+          (SpecialPeriods.Triangle.ellipticGenerator j) z) =
+      (cocycle hτ hτa).fibreMap (SpecialPeriods.Triangle.ellipticGenerator j) z
+        (ellipticFormula τ j z) := by
+  cases j
+  · change
+      (2 -
+            (τ
+                (SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleGenerator₁
+                  z) :
+              ℂ)) /
+          3 =
+        _
+    dsimp only [SpecialPeriods.Triangle.ellipticGenerator]
+    rw [SpecialPeriods.triangleGeometricRepresentation_generator₁_apply, hτ.1 z,
+      cocycle_fibreMap_generator₁]
+    dsimp only [ellipticFormula]
+    field_simp [(τ z).ne_zero]
+    ring
+  · change
+      (1 -
+            (τ
+                (SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleGenerator₂
+                  z) :
+              ℂ)) /
+          2 =
+        _
+    dsimp only [SpecialPeriods.Triangle.ellipticGenerator]
+    rw [SpecialPeriods.triangleGeometricRepresentation_generator₂_apply, hτ.2 z,
+      cocycle_fibreMap_generator₂]
+    dsimp only [ellipticFormula]
+    field_simp [(τ z).ne_zero]
+    ring
+
+private def SpecialPeriods.MuTorsor.regularSeed {τ : ℍ → ℍ} (hτ : SpecialPeriods.TauCovariant τ)
+    (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (x : SpecialPeriods.TriangleRegularQuotient) :
+    (Cover.regularPatch x).Seed (cocycle hτ hτa)
+    where
+  toFun _ := 0
+  holomorphic := contMDiffOn_const
+  equivariant := by
+    intro g z _
+    have hg : (g : SpecialPeriods.TriangleGroup) = 1 := Subgroup.mem_bot.mp g.property
+    simp only [hg, AffineCocycle.fibreMap_one]
+
+private def SpecialPeriods.MuTorsor.cuspSeed {τ : ℍ → ℍ} (hτ : SpecialPeriods.TauCovariant τ)
+    (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) : Cover.cuspPatch.Seed (cocycle hτ hτa)
+    where
+  toFun _ := 0
+  holomorphic := contMDiffOn_const
+  equivariant := by
+    intro g z _
+    exact
+      (cocycle hτ hτa).equivariant_of_mem_zpowers (fun _ => 0)
+        SpecialPeriods.triangleCuspGenerator (fun w => (cocycle_fibreMap_cusp hτ hτa w 0).symm)
+        g.property z
+
+private def SpecialPeriods.MuTorsor.ellipticSeed {τ : ℍ → ℍ} (hτ : SpecialPeriods.TauCovariant τ)
+    (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (j : Elliptic.Kind) :
+    (Cover.ellipticPatch j).Seed (cocycle hτ hτa)
+    where
+  toFun := ellipticFormula τ j
+  holomorphic := (ellipticFormula_holomorphic hτa j).contMDiffOn
+  equivariant := by
+    intro g z _
+    have hg :
+      (g : SpecialPeriods.TriangleGroup) ∈
+        Subgroup.zpowers (SpecialPeriods.Triangle.ellipticGenerator j) := by
+      rw [← SpecialPeriods.Triangle.ellipticStabilizer_eq_zpowers]
+      exact g.property
+    exact
+      (cocycle hτ hτa).equivariant_of_mem_zpowers (ellipticFormula τ j)
+        (SpecialPeriods.Triangle.ellipticGenerator j) (ellipticFormula_generator hτ hτa j) hg z
+
+private def SpecialPeriods.MuTorsor.seed {τ : ℍ → ℍ} (hτ : SpecialPeriods.TauCovariant τ)
+    (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) : (i : Cover.Index) → (Cover.patch i).Seed (cocycle hτ hτa)
+  | none => cuspSeed hτ hτa
+  | some (.inl x) => regularSeed hτ hτa x
+  | some (.inr j) => ellipticSeed hτ hτa j
+
+private def SpecialPeriods.MuTorsor.localSection {τ : ℍ → ℍ} (hτ : SpecialPeriods.TauCovariant τ)
+    (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (i : Cover.Index) : ℍ → ℂ :=
+  (seed hτ hτa i).extend
+
+private theorem SpecialPeriods.MuTorsor.localSection_holomorphic {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (i : Cover.Index) :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (localSection hτ hτa i) (Cover.patch i).saturation :=
+  (seed hτ hτa i).extend_holomorphic
+
+private theorem SpecialPeriods.MuTorsor.localSection_equivariant {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (i : Cover.Index) :
+    (cocycle hτ hτa).EquivariantOn (localSection hτ hτa i) (Cover.patch i).saturation :=
+  (seed hτ hτa i).extend_equivariant
+
+private theorem
+    SpecialPeriods.MuTorsor.localSection_cusp {τ : ℍ → ℍ} (hτ : SpecialPeriods.TauCovariant τ)
+    (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (z : ℍ)
+    (hz : z ∈ SpecialPeriods.Triangle.horodisc SpecialPeriods.Triangle.width) :
+    localSection hτ hτa Cover.cuspIndex z = 0 :=
+  (cuspSeed hτ hτa).extend_eq z hz
+
+private def SpecialPeriods.MuGenerator.FiniteEvenZeros (τ : ℍ → ℍ) : Prop :=
+  ∀ a : ℍ,
+    ModularForm.E₆ (τ a) = 0 →
+      ∃ n : ℕ,
+        analyticOrderAt (fun z : ℂ => ModularForm.E₆ (τ (UpperHalfPlane.ofComplex z))) (a : ℂ) =
+          (2 * n : ℕ)
+
+private theorem
+    SpecialPeriods.MuGenerator.finiteEvenZeros_of_modular_equation {τ : ℍ → ℍ} {J : ℍ → ℂ}
+    (hτ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) τ) (hJ : ∀ a : ℍ, SpecialPeriods.modularJ (τ a) = J a)
+    (hsource :
+      ∀ a : ℍ,
+        J a = 1728 →
+          ∃ k : ℕ,
+            analyticOrderAt (fun z : ℂ => J (UpperHalfPlane.ofComplex z) - 1728) (a : ℂ) =
+              (4 * k : ℕ)) :
+    FiniteEvenZeros τ :=
+  SpecialPeriods.ModularGermLift.native_E₆_finite_even_zeros hτ hJ hsource
+
+private structure SpecialPeriods.MuGenerator.Root (τ : ℍ → ℍ) where
+  toFun : ℍ → ℂ
+  holomorphic : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω toFun
+  square : ∀ a : ℍ, toFun a ^ 2 = ModularForm.E₆ (τ a)
+
+private instance
+    SpecialPeriods.MuGenerator.instCoeFun1 {τ : ℍ → ℍ} : CoeFun (Root τ) (fun _ => ℍ → ℂ) :=
+  ⟨Root.toFun⟩
+
+private theorem
+    SpecialPeriods.MuGenerator.nonempty_root {τ : ℍ → ℍ} (hτ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) τ)
+    (hzero : FiniteEvenZeros τ) : Nonempty (Root τ) := by
+  obtain ⟨r, hr, hrsq, _⟩ :=
+    AnalyticRootCover.exists_holomorphic_square_root_upperHalfPlane
+      (fun a => ModularForm.E₆ (τ a)) (ModularForm.E₆.holo'.comp hτ) hzero
+  exact ⟨⟨r, hr, hrsq⟩⟩
+
+private def SpecialPeriods.MuGenerator.root (τ : ℍ → ℍ) (hτ : MDifferentiable 𝓘(ℂ) 𝓘(ℂ) τ)
+    (hzero : FiniteEvenZeros τ) : Root τ :=
+  Classical.choice (nonempty_root hτ hzero)
+
+private theorem SpecialPeriods.MuGenerator.modularForm_holomorphic {k : ℤ} (f : ModularForm 𝒮ℒ k) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω f := by
+  intro a
+  exact UpperHalfPlane.contMDiffAt_iff.mpr (SpecialPeriods.modularForm_analyticAt f a).contDiffAt
+
+private theorem SpecialPeriods.MuGenerator.Root.analyticAt {τ : ℍ → ℍ}
+    (r : SpecialPeriods.MuGenerator.Root τ) (a : ℍ) :
+    AnalyticAt ℂ (r ∘ UpperHalfPlane.ofComplex) (a : ℂ) :=
+  (UpperHalfPlane.contMDiffAt_iff.mp (r.holomorphic a)).analyticAt
+
+@[simp]
+private theorem SpecialPeriods.MuGenerator.Root.eq_zero_iff {τ : ℍ → ℍ}
+    (r : SpecialPeriods.MuGenerator.Root τ) (a : ℍ) : r a = 0 ↔ ModularForm.E₆ (τ a) = 0 := by
+  rw [← r.square a]
+  exact (pow_eq_zero_iff (by decide : (2 : ℕ) ≠ 0)).symm
+
+private theorem SpecialPeriods.MuGenerator.Root.order_of_square_order {τ : ℍ → ℍ}
+    (r : SpecialPeriods.MuGenerator.Root τ) (a : ℍ) (n : ℕ)
+    (horder :
+      analyticOrderAt (fun z : ℂ => ModularForm.E₆ (τ (UpperHalfPlane.ofComplex z))) (a : ℂ) =
+        (2 * n : ℕ)) :
+    analyticOrderAt (r ∘ UpperHalfPlane.ofComplex) (a : ℂ) = n := by
+  apply AnalyticRootCover.square_root_order (r.analyticAt a) _ horder
+  filter_upwards with z
+  exact r.square (UpperHalfPlane.ofComplex z)
+
+private def SpecialPeriods.MuGenerator.Root.generator {τ : ℍ → ℍ}
+    (r : SpecialPeriods.MuGenerator.Root τ) : ℍ → ℂ := fun a =>
+  ModularForm.E₄ (τ a) ^ 2 * r a / ModularForm.discriminant (τ a)
+
+private theorem SpecialPeriods.MuGenerator.Root.generator_holomorphic {τ : ℍ → ℍ}
+    (r : SpecialPeriods.MuGenerator.Root τ) (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω r.generator := by
+  have h4 : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun a => ModularForm.E₄ (τ a)) :=
+    (SpecialPeriods.MuGenerator.modularForm_holomorphic ModularForm.E₄).comp hτ
+  have hD : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun a => ModularForm.discriminant (τ a)) :=
+    (SpecialPeriods.MuGenerator.modularForm_holomorphic
+          (CuspForm.discriminant : ModularForm 𝒮ℒ 12)).comp
+      hτ
+  exact ((h4.pow 2).mul r.holomorphic).div₀ hD (fun a => ModularForm.discriminant_ne_zero (τ a))
+
+private theorem SpecialPeriods.MuGenerator.Root.generator_eq_zero_iff {τ : ℍ → ℍ}
+    (r : SpecialPeriods.MuGenerator.Root τ) (a : ℍ) :
+    r.generator a = 0 ↔ ModularForm.E₄ (τ a) = 0 ∨ ModularForm.E₆ (τ a) = 0 := by
+  simp only [generator, div_eq_zero_iff, ModularForm.discriminant_ne_zero, or_false, mul_eq_zero,
+    pow_eq_zero_iff (by decide : (2 : ℕ) ≠ 0), r.eq_zero_iff]
+
+private theorem SpecialPeriods.MuGenerator.Root.generator_eq_zero_iff_modularJ {τ : ℍ → ℍ}
+    (r : SpecialPeriods.MuGenerator.Root τ) (a : ℍ) :
+    r.generator a = 0 ↔
+      SpecialPeriods.modularJ (τ a) = 0 ∨ SpecialPeriods.modularJ (τ a) = 1728 := by
+  rw [r.generator_eq_zero_iff, SpecialPeriods.modularJ_eq_zero_iff,
+    SpecialPeriods.modularJ_eq_1728_iff]
+
+private theorem SpecialPeriods.MuGenerator.modularForm_pullback_analyticAt {τ : ℍ → ℍ}
+    (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) {k : ℤ} (f : ModularForm 𝒮ℒ k) (a : ℍ) :
+    AnalyticAt ℂ (fun z : ℂ => f (τ (UpperHalfPlane.ofComplex z))) (a : ℂ) :=
+  (UpperHalfPlane.contMDiffAt_iff.mp ((modularForm_holomorphic f).comp hτ a)).analyticAt
+
+private theorem SpecialPeriods.MuGenerator.Root.generator_order {τ : ℍ → ℍ}
+    (r : SpecialPeriods.MuGenerator.Root τ) (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (a : ℍ) :
+    analyticOrderAt (r.generator ∘ UpperHalfPlane.ofComplex) (a : ℂ) =
+      2 • analyticOrderAt (fun z : ℂ => ModularForm.E₄ (τ (UpperHalfPlane.ofComplex z))) (a : ℂ) +
+        analyticOrderAt (r ∘ UpperHalfPlane.ofComplex) (a : ℂ) := by
+  let f4 : ℂ → ℂ := fun z => ModularForm.E₄ (τ (UpperHalfPlane.ofComplex z))
+  let fD : ℂ → ℂ := fun z => ModularForm.discriminant (τ (UpperHalfPlane.ofComplex z))
+  have h4 : AnalyticAt ℂ f4 (a : ℂ) :=
+    SpecialPeriods.MuGenerator.modularForm_pullback_analyticAt hτ ModularForm.E₄ a
+  have hD : AnalyticAt ℂ fD (a : ℂ) :=
+    SpecialPeriods.MuGenerator.modularForm_pullback_analyticAt hτ
+      (CuspForm.discriminant : ModularForm 𝒮ℒ 12) a
+  have hD0 : fD (a : ℂ) ≠ 0 := by
+    simpa only [fD, UpperHalfPlane.ofComplex_apply] using ModularForm.discriminant_ne_zero (τ a)
+  have hDi := hD.inv hD0
+  have hDiorder : analyticOrderAt fD⁻¹ (a : ℂ) = 0 :=
+    hDi.analyticOrderAt_eq_zero.mpr (inv_ne_zero hD0)
+  have he :
+    r.generator ∘ UpperHalfPlane.ofComplex = (f4 ^ 2 * (r ∘ UpperHalfPlane.ofComplex)) * fD⁻¹ := by
+    funext z
+    exact div_eq_mul_inv _ _
+  rw [he, analyticOrderAt_mul ((h4.pow 2).mul (r.analyticAt a)) hDi,
+    analyticOrderAt_mul (h4.pow 2) (r.analyticAt a), analyticOrderAt_pow h4, hDiorder, add_zero]
+
+private theorem SpecialPeriods.MuGenerator.Root.generator_order_of_pullback_orders {τ : ℍ → ℍ}
+    (r : SpecialPeriods.MuGenerator.Root τ) (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (a : ℍ) (m n : ℕ)
+    (h4 :
+      analyticOrderAt (fun z : ℂ => ModularForm.E₄ (τ (UpperHalfPlane.ofComplex z))) (a : ℂ) = m)
+    (h6 :
+      analyticOrderAt (fun z : ℂ => ModularForm.E₆ (τ (UpperHalfPlane.ofComplex z))) (a : ℂ) =
+        (2 * n : ℕ)) :
+    analyticOrderAt (r.generator ∘ UpperHalfPlane.ofComplex) (a : ℂ) = (2 * m + n : ℕ) := by
+  rw [r.generator_order hτ, h4, r.order_of_square_order a n h6]
+  simp only [two_nsmul, ← Nat.cast_add]
+  congr 1
+  omega
+
+private theorem SpecialPeriods.MuGenerator.Root.order_centerTwo_of_tau_order {τ : ℍ → ℍ}
+    (r : SpecialPeriods.MuGenerator.Root τ) (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ)
+    (hc : SpecialPeriods.TauCovariant τ)
+    (ho :
+      analyticOrderAt (fun z : ℂ => (τ (UpperHalfPlane.ofComplex z) : ℂ) - Complex.I)
+          (SpecialPeriods.Triangle.centerTwo : ℂ) =
+        2) :
+    analyticOrderAt (r ∘ UpperHalfPlane.ofComplex) (SpecialPeriods.Triangle.centerTwo : ℂ) = 1 := by
+  have hv := (SpecialPeriods.tau_covariant_values hc).2
+  have h6 :=
+    SpecialPeriods.ModularGermLift.native_E₆_lift_order_of_zero (hτ.mdifferentiable (by simp))
+      (a := SpecialPeriods.Triangle.centerTwo) (by rw [hv, SpecialPeriods.E₆_I])
+  rw [hv, UpperHalfPlane.coe_I] at h6
+  apply r.order_of_square_order SpecialPeriods.Triangle.centerTwo 1
+  simpa only [Nat.mul_one, Nat.cast_ofNat] using h6.trans ho
+
+private theorem SpecialPeriods.MuGenerator.Root.generator_order_centerOne_of_tau_order {τ : ℍ → ℍ}
+    (r : SpecialPeriods.MuGenerator.Root τ) (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ)
+    (hc : SpecialPeriods.TauCovariant τ)
+    (ho :
+      analyticOrderAt (fun z : ℂ => (τ (UpperHalfPlane.ofComplex z) : ℂ) - SpecialPeriods.rho)
+          (SpecialPeriods.Triangle.centerOne : ℂ) =
+        1) :
+    analyticOrderAt (r.generator ∘ UpperHalfPlane.ofComplex)
+        (SpecialPeriods.Triangle.centerOne : ℂ) =
+      2 := by
+  have hv := (SpecialPeriods.tau_covariant_values hc).1
+  have h4 :=
+    SpecialPeriods.ModularGermLift.native_E₄_lift_order_of_zero (hτ.mdifferentiable (by simp))
+      (a := SpecialPeriods.Triangle.centerOne) (by rw [hv, SpecialPeriods.E₄_rhoPoint])
+  rw [hv, SpecialPeriods.coe_rhoPoint] at h4
+  have h6 :
+    analyticOrderAt (fun z : ℂ => ModularForm.E₆ (τ (UpperHalfPlane.ofComplex z)))
+        (SpecialPeriods.Triangle.centerOne : ℂ) =
+      (2 * 0 : ℕ) := by
+    apply analyticOrderAt_eq_zero.mpr
+    right
+    simpa only [UpperHalfPlane.ofComplex_apply, hv] using SpecialPeriods.E₆_rhoPoint_ne_zero
+  simpa only [Nat.mul_one, Nat.add_zero, Nat.cast_ofNat] using
+    r.generator_order_of_pullback_orders hτ SpecialPeriods.Triangle.centerOne 1 0 (h4.trans ho) h6
+
+private theorem SpecialPeriods.MuGenerator.Root.generator_order_centerTwo_of_tau_order {τ : ℍ → ℍ}
+    (r : SpecialPeriods.MuGenerator.Root τ) (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ)
+    (hc : SpecialPeriods.TauCovariant τ)
+    (ho :
+      analyticOrderAt (fun z : ℂ => (τ (UpperHalfPlane.ofComplex z) : ℂ) - Complex.I)
+          (SpecialPeriods.Triangle.centerTwo : ℂ) =
+        2) :
+    analyticOrderAt (r.generator ∘ UpperHalfPlane.ofComplex)
+        (SpecialPeriods.Triangle.centerTwo : ℂ) =
+      1 := by
+  have hv := (SpecialPeriods.tau_covariant_values hc).2
+  have h4 :
+    analyticOrderAt (fun z : ℂ => ModularForm.E₄ (τ (UpperHalfPlane.ofComplex z)))
+        (SpecialPeriods.Triangle.centerTwo : ℂ) =
+      0 := by
+    apply analyticOrderAt_eq_zero.mpr
+    right
+    simpa only [UpperHalfPlane.ofComplex_apply, hv] using SpecialPeriods.E₄_I_ne_zero
+  rw [r.generator_order hτ, h4, r.order_centerTwo_of_tau_order hτ hc ho, smul_zero, zero_add]
+
+private theorem SpecialPeriods.upperHalfPlane_holomorphic_sq_eq_sq_dichotomy {f g : ℍ → ℂ}
+    (hf : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω f) (hg : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω g) (hsq : ∀ z, f z ^ 2 = g z ^ 2) :
+    f = g ∨ f = -g := by
+  have hprod : (f - g) * (f + g) = 0 := by
+    funext z
+    change (f z - g z) * (f z + g z) = 0
+    calc
+      _ = f z ^ 2 - g z ^ 2 := by ring
+      _ = 0 := sub_eq_zero.mpr (hsq z)
+  rcases
+    (UpperHalfPlane.mul_eq_zero_iff ((hf.sub hg).mdifferentiable (by simp))
+          ((hf.add hg).mdifferentiable (by simp))).mp
+      hprod with
+    h | h
+  · exact Or.inl (sub_eq_zero.mp h)
+  · exact Or.inr (eq_neg_of_add_eq_zero_left h)
+
+private theorem SpecialPeriods.eisensteinSix_root_generatorOne_sq {τ : ℍ → ℍ} {r : ℍ → ℂ}
+    (hτc : TauCovariant τ) (hrsq : ∀ z, r z ^ 2 = ModularForm.E₆ (τ z)) (z : ℍ) :
+    r (Triangle.generatorOneSL • z) ^ 2 = ((τ z : ℂ) ^ 3 * r z) ^ 2 := by
+  have hτg : τ (Triangle.generatorOneSL • z) = (ModularGroup.T * ModularGroup.S) • τ z := by
+    apply UpperHalfPlane.ext
+    rw [← modularRhoAction_coe]
+    exact hτc.1 z
+  have hd : UpperHalfPlane.denom (ModularGroup.T * ModularGroup.S : SL(2, ℤ)) (τ z) = (τ z : ℂ) :=
+    by
+    have h10 : (ModularGroup.T * ModularGroup.S : SL(2, ℤ)) 1 0 = 1 := by decide
+    have h11 : (ModularGroup.T * ModularGroup.S : SL(2, ℤ)) 1 1 = 0 := by decide
+    rw [ModularGroup.denom_apply, h10, h11]
+    simp
+  calc
+    _ = ModularForm.E₆ (τ (Triangle.generatorOneSL • z)) := hrsq _
+    _ = (τ z : ℂ) ^ 6 * ModularForm.E₆ (τ z) := by rw [hτg, levelOne_transform, hd, zpow_ofNat]
+    _ = ((τ z : ℂ) ^ 3 * r z) ^ 2 := by
+      rw [← hrsq z]
+      ring
+
+private theorem SpecialPeriods.eisensteinSix_root_generatorTwo_sq {τ : ℍ → ℍ} {r : ℍ → ℂ}
+    (hτc : TauCovariant τ) (hrsq : ∀ z, r z ^ 2 = ModularForm.E₆ (τ z)) (z : ℍ) :
+    r (Triangle.generatorTwoSL • z) ^ 2 = ((τ z : ℂ) ^ 3 * r z) ^ 2 := by
+  have hτg : τ (Triangle.generatorTwoSL • z) = ModularGroup.S • τ z := by
+    apply UpperHalfPlane.ext
+    rw [← modularIAction_coe]
+    exact hτc.2 z
+  calc
+    _ = ModularForm.E₆ (τ (Triangle.generatorTwoSL • z)) := hrsq _
+    _ = (τ z : ℂ) ^ 6 * ModularForm.E₆ (τ z) := by
+      rw [hτg, levelOne_transform, ModularGroup.denom_S, zpow_ofNat]
+    _ = ((τ z : ℂ) ^ 3 * r z) ^ 2 := by
+      rw [← hrsq z]
+      ring
+
+private theorem SpecialPeriods.eisensteinSix_root_centerOne_ne_zero {τ : ℍ → ℍ} {r : ℍ → ℂ}
+    (hτc : TauCovariant τ) (hrsq : ∀ z, r z ^ 2 = ModularForm.E₆ (τ z)) :
+    r Triangle.centerOne ≠ 0 := by
+  intro hrzero
+  have h := hrsq Triangle.centerOne
+  rw [hrzero, zero_pow (by decide), (tau_covariant_values hτc).1] at h
+  exact E₆_rhoPoint_ne_zero h.symm
+
+private theorem SpecialPeriods.eisensteinSix_root_generatorOne {τ : ℍ → ℍ} {r : ℍ → ℂ}
+    (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (hτc : TauCovariant τ) (hr : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω r)
+    (hrsq : ∀ z, r z ^ 2 = ModularForm.E₆ (τ z)) :
+    ∀ z, r (Triangle.generatorOneSL • z) = -(τ z : ℂ) ^ 3 * r z := by
+  have hweight : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z => (τ z : ℂ) ^ 3 * r z) :=
+    ((UpperHalfPlane.contMDiff_coe.comp hτ).pow 3).mul hr
+  rcases
+    upperHalfPlane_holomorphic_sq_eq_sq_dichotomy
+      (hr.comp (Triangle.specialLinear_holomorphic Triangle.generatorOneSL)) hweight
+      (eisensteinSix_root_generatorOne_sq hτc hrsq) with
+    hpos | hneg
+  · exfalso
+    have h := congrFun hpos Triangle.centerOne
+    change
+      r (Triangle.generatorOneSL • Triangle.centerOne) =
+        (τ Triangle.centerOne : ℂ) ^ 3 * r Triangle.centerOne at h
+    rw [Triangle.generatorOne_fix, (tau_covariant_values hτc).1, coe_rhoPoint, rho_cube,
+      neg_one_mul] at h
+    apply eisensteinSix_root_centerOne_ne_zero hτc hrsq
+    linear_combination h / 2
+  · intro z
+    simpa only [Function.comp_apply, Pi.neg_apply, neg_mul] using congrFun hneg z
+
+private theorem SpecialPeriods.eisensteinSix_root_generatorTwo_dichotomy {τ : ℍ → ℍ} {r : ℍ → ℂ}
+    (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (hτc : TauCovariant τ) (hr : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω r)
+    (hrsq : ∀ z, r z ^ 2 = ModularForm.E₆ (τ z)) :
+    (∀ z, r (Triangle.generatorTwoSL • z) = (τ z : ℂ) ^ 3 * r z) ∨
+      (∀ z, r (Triangle.generatorTwoSL • z) = -(τ z : ℂ) ^ 3 * r z) := by
+  have hweight : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z => (τ z : ℂ) ^ 3 * r z) :=
+    ((UpperHalfPlane.contMDiff_coe.comp hτ).pow 3).mul hr
+  rcases
+    upperHalfPlane_holomorphic_sq_eq_sq_dichotomy
+      (hr.comp (Triangle.specialLinear_holomorphic Triangle.generatorTwoSL)) hweight
+      (eisensteinSix_root_generatorTwo_sq hτc hrsq) with
+    hpos | hneg
+  · exact Or.inl (congrFun hpos)
+  · right
+    intro z
+    simpa only [Function.comp_apply, Pi.neg_apply, neg_mul] using congrFun hneg z
+
+private theorem
+    SpecialPeriods.holomorphic_simple_zero_not_generatorTwo_negative {τ : ℍ → ℍ} {r : ℍ → ℂ}
+    (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (hτc : TauCovariant τ) (hr : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω r)
+    (horder : analyticOrderAt (r ∘ UpperHalfPlane.ofComplex) (Triangle.centerTwo : ℂ) = 1) :
+    ¬(∀ z, r (Triangle.generatorTwoSL • z) = -(τ z : ℂ) ^ 3 * r z) := by
+  intro hneg
+  let R : ℂ → ℂ := r ∘ UpperHalfPlane.ofComplex
+  let T : ℂ → ℂ := fun z => (τ (UpperHalfPlane.ofComplex z) : ℂ)
+  let B : ℂ → ℂ := fun z => ((Triangle.generatorTwoSL • UpperHalfPlane.ofComplex z : ℍ) : ℂ)
+  let c : ℂ := (Triangle.centerTwo : ℂ)
+  have hRA : AnalyticAt ℂ R c :=
+    (UpperHalfPlane.contMDiffAt_iff.mp (hr Triangle.centerTwo)).analyticAt
+  have hTA : AnalyticAt ℂ T c :=
+    (UpperHalfPlane.contMDiffAt_iff.mp
+        ((UpperHalfPlane.contMDiff_coe.comp hτ) Triangle.centerTwo)).analyticAt
+  have hRorder : analyticOrderAt R c = 1 := horder
+  have hRzero : R c = 0 :=
+    apply_eq_zero_of_analyticOrderAt_ne_zero (by rw [hRorder]; exact one_ne_zero)
+  have hdOrder : analyticOrderAt (deriv R) c = 0 :=
+    analyticOrderAt_deriv_of_pos hRA (n := 0) (by simpa using hRorder)
+  have hd : deriv R c ≠ 0 := hRA.deriv.analyticOrderAt_eq_zero.mp hdOrder
+  have hBc : B c = c := by
+    dsimp only [B, c]
+    rw [UpperHalfPlane.ofComplex_apply, Triangle.generatorTwo_fix]
+  have hTc : T c = Complex.I := by
+    dsimp only [T, c]
+    rw [UpperHalfPlane.ofComplex_apply, (tau_covariant_values hτc).2]
+    rfl
+  have hB : HasDerivAt B (-Complex.I) c := Triangle.generatorTwo_hasStrictDerivAt.hasDerivAt
+  have hRder : HasDerivAt R (deriv R c) (B c) := by
+    rw [hBc]
+    exact hRA.differentiableAt.hasDerivAt
+  have hleft :
+    HasDerivAt (fun z : ℂ => r (Triangle.generatorTwoSL • UpperHalfPlane.ofComplex z))
+      (deriv R c * -Complex.I) c := by
+    simpa only [Function.comp_def, R, B, UpperHalfPlane.ofComplex_apply] using hRder.comp c hB
+  have hright : HasDerivAt (fun z : ℂ => -(T z) ^ 3 * R z) _ c :=
+    ((hTA.differentiableAt.hasDerivAt.pow 3).neg).mul hRA.differentiableAt.hasDerivAt
+  have hright' : HasDerivAt (fun z : ℂ => -(T z) ^ 3 * R z) (Complex.I * deriv R c) c := by
+    simpa [hRzero, hTc, Complex.I_sq, pow_succ] using hright
+  have hfun :
+    (fun z : ℂ => r (Triangle.generatorTwoSL • UpperHalfPlane.ofComplex z)) =
+      (fun z : ℂ => -(T z) ^ 3 * R z) := by
+    funext z
+    exact hneg (UpperHalfPlane.ofComplex z)
+  rw [hfun] at hleft
+  have heq := hleft.unique hright'
+  have hI : -Complex.I = Complex.I := by
+    apply mul_right_cancel₀ hd
+    simpa only [mul_comm] using heq
+  have him := congrArg Complex.im hI
+  norm_num at him
+
+private theorem SpecialPeriods.eisensteinSix_root_generatorTwo {τ : ℍ → ℍ} {r : ℍ → ℂ}
+    (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (hτc : TauCovariant τ) (hr : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω r)
+    (hrsq : ∀ z, r z ^ 2 = ModularForm.E₆ (τ z))
+    (horder : analyticOrderAt (r ∘ UpperHalfPlane.ofComplex) (Triangle.centerTwo : ℂ) = 1) :
+    ∀ z, r (Triangle.generatorTwoSL • z) = (τ z : ℂ) ^ 3 * r z := by
+  rcases eisensteinSix_root_generatorTwo_dichotomy hτ hτc hr hrsq with hpos | hneg
+  · exact hpos
+  · exact (holomorphic_simple_zero_not_generatorTwo_negative hτ hτc hr horder hneg).elim
+
+private theorem SpecialPeriods.MuGenerator.modularForm_generatorOne {τ : ℍ → ℍ} {k : ℤ}
+    (f : ModularForm 𝒮ℒ k) (hτc : SpecialPeriods.TauCovariant τ) (z : ℍ) :
+    f (τ (SpecialPeriods.Triangle.generatorOneSL • z)) = (τ z : ℂ) ^ k * f (τ z) := by
+  have hτg :
+    τ (SpecialPeriods.Triangle.generatorOneSL • z) = (ModularGroup.T * ModularGroup.S) • τ z := by
+    apply UpperHalfPlane.ext
+    rw [← SpecialPeriods.modularRhoAction_coe]
+    exact hτc.1 z
+  have hd : UpperHalfPlane.denom (ModularGroup.T * ModularGroup.S : SL(2, ℤ)) (τ z) = (τ z : ℂ) :=
+    by
+    have h10 : (ModularGroup.T * ModularGroup.S : SL(2, ℤ)) 1 0 = 1 := by decide
+    have h11 : (ModularGroup.T * ModularGroup.S : SL(2, ℤ)) 1 1 = 0 := by decide
+    rw [ModularGroup.denom_apply, h10, h11]
+    simp
+  rw [hτg, SpecialPeriods.levelOne_transform, hd]
+
+private theorem SpecialPeriods.MuGenerator.modularForm_generatorTwo {τ : ℍ → ℍ} {k : ℤ}
+    (f : ModularForm 𝒮ℒ k) (hτc : SpecialPeriods.TauCovariant τ) (z : ℍ) :
+    f (τ (SpecialPeriods.Triangle.generatorTwoSL • z)) = (τ z : ℂ) ^ k * f (τ z) := by
+  have hτg : τ (SpecialPeriods.Triangle.generatorTwoSL • z) = ModularGroup.S • τ z := by
+    apply UpperHalfPlane.ext
+    rw [← SpecialPeriods.modularIAction_coe]
+    exact hτc.2 z
+  rw [hτg, SpecialPeriods.levelOne_transform, ModularGroup.denom_S]
+
+private theorem SpecialPeriods.MuGenerator.triangle_invariant_of_generators (f : ℍ → ℂ)
+    (h₁ : ∀ z, f (SpecialPeriods.Triangle.generatorOneSL • z) = f z)
+    (h₂ : ∀ z, f (SpecialPeriods.Triangle.generatorTwoSL • z) = f z)
+    (g : SpecialPeriods.TriangleGroup) :
+    ∀ z, f (SpecialPeriods.triangleGeometricRepresentation g z) = f z := by
+  let := SpecialPeriods.triangleGeometricAction
+  have hg :
+    g ∈
+      Subgroup.closure
+        ({ SpecialPeriods.triangleGenerator₁, SpecialPeriods.triangleGenerator₂ } :
+          Set SpecialPeriods.TriangleGroup) := by
+    rw [SpecialPeriods.triangle_generators_generate]
+    trivial
+  change ∀ z, f (g • z) = f z
+  induction hg using Subgroup.closure_induction with
+  | mem x hx =>
+    rcases hx with rfl | rfl
+    · intro z
+      change
+        f (SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleGenerator₁ z) =
+          f z
+      simpa only [SpecialPeriods.triangleGeometricRepresentation_generator₁_apply] using h₁ z
+    · intro z
+      change
+        f (SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleGenerator₂ z) =
+          f z
+      simpa only [SpecialPeriods.triangleGeometricRepresentation_generator₂_apply] using h₂ z
+  | one => intro z; rw [one_smul]
+  | mul g h _ _ ihg ihh => intro z; rw [SemigroupAction.mul_smul, ihg, ihh]
+  | inv g _ ih =>
+    intro z
+    simpa only [smul_inv_smul] using (ih (g⁻¹ • z)).symm
+
+private theorem SpecialPeriods.MuGenerator.Root.generator_generatorOne {τ : ℍ → ℍ}
+    (r : SpecialPeriods.MuGenerator.Root τ) (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ)
+    (hτc : SpecialPeriods.TauCovariant τ) (z : ℍ) :
+    r.generator (SpecialPeriods.Triangle.generatorOneSL • z) = -r.generator z / (τ z : ℂ) := by
+  have h4 :
+    ModularForm.E₄ (τ (SpecialPeriods.Triangle.generatorOneSL • z)) =
+      (τ z : ℂ) ^ 4 * ModularForm.E₄ (τ z) := by
+    simpa only [zpow_ofNat] using
+      SpecialPeriods.MuGenerator.modularForm_generatorOne ModularForm.E₄ hτc z
+  have hD :
+    ModularForm.discriminant (τ (SpecialPeriods.Triangle.generatorOneSL • z)) =
+      (τ z : ℂ) ^ 12 * ModularForm.discriminant (τ z) := by
+    have h :=
+      SpecialPeriods.MuGenerator.modularForm_generatorOne
+        (CuspForm.discriminant : ModularForm 𝒮ℒ 12) hτc z
+    change
+      ModularForm.discriminant (τ (SpecialPeriods.Triangle.generatorOneSL • z)) =
+        (τ z : ℂ) ^ (12 : ℤ) * ModularForm.discriminant (τ z) at h
+    simpa only [zpow_ofNat] using h
+  rw [generator, h4, hD,
+    SpecialPeriods.eisensteinSix_root_generatorOne hτ hτc r.holomorphic r.square z]
+  dsimp only [generator]
+  field_simp [(τ z).ne_zero, ModularForm.discriminant_ne_zero (τ z)]
+
+private theorem SpecialPeriods.MuGenerator.Root.generator_generatorTwo {τ : ℍ → ℍ}
+    (r : SpecialPeriods.MuGenerator.Root τ) (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ)
+    (hτc : SpecialPeriods.TauCovariant τ)
+    (horder :
+      analyticOrderAt (r ∘ UpperHalfPlane.ofComplex) (SpecialPeriods.Triangle.centerTwo : ℂ) = 1)
+    (z : ℍ) :
+    r.generator (SpecialPeriods.Triangle.generatorTwoSL • z) = r.generator z / (τ z : ℂ) := by
+  have h4 :
+    ModularForm.E₄ (τ (SpecialPeriods.Triangle.generatorTwoSL • z)) =
+      (τ z : ℂ) ^ 4 * ModularForm.E₄ (τ z) := by
+    simpa only [zpow_ofNat] using
+      SpecialPeriods.MuGenerator.modularForm_generatorTwo ModularForm.E₄ hτc z
+  have hD :
+    ModularForm.discriminant (τ (SpecialPeriods.Triangle.generatorTwoSL • z)) =
+      (τ z : ℂ) ^ 12 * ModularForm.discriminant (τ z) := by
+    have h :=
+      SpecialPeriods.MuGenerator.modularForm_generatorTwo
+        (CuspForm.discriminant : ModularForm 𝒮ℒ 12) hτc z
+    change
+      ModularForm.discriminant (τ (SpecialPeriods.Triangle.generatorTwoSL • z)) =
+        (τ z : ℂ) ^ (12 : ℤ) * ModularForm.discriminant (τ z) at h
+    simpa only [zpow_ofNat] using h
+  rw [generator, h4, hD,
+    SpecialPeriods.eisensteinSix_root_generatorTwo hτ hτc r.holomorphic r.square horder z]
+  dsimp only [generator]
+  field_simp [(τ z).ne_zero, ModularForm.discriminant_ne_zero (τ z)]
+
+private theorem HolomorphicCousin.analyticOnNhd_dslope_zero {f : ℂ → ℂ} {R : ℝ} (hR : 0 < R)
+    (hf : AnalyticOnNhd ℂ f (Metric.ball 0 R)) : AnalyticOnNhd ℂ (dslope f 0) (Metric.ball 0 R) :=
+  (Complex.analyticOnNhd_iff_differentiableOn Metric.isOpen_ball).mpr
+    ((Complex.differentiableOn_dslope (Metric.ball_mem_nhds (0 : ℂ) hR)).mpr hf.differentiableOn)
+
+private theorem HolomorphicCousin.zero_mul_dslope {f : ℂ → ℂ} (hf : f 0 = 0) (z : ℂ) :
+    z * dslope f 0 z = f z := by
+  simpa only [sub_zero, smul_eq_mul] using sub_smul_dslope_of_zero hf z
+
+private theorem
+    SpecialPeriods.MuGenerator.scalar_analyticAt {f : ℍ → ℂ} (hf : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω f)
+    (a : ℍ) : AnalyticAt ℂ (f ∘ UpperHalfPlane.ofComplex) (a : ℂ) :=
+  (UpperHalfPlane.mdifferentiable_iff.mp (hf.mdifferentiable (by simp))).analyticAt
+    (UpperHalfPlane.isOpen_upperHalfPlaneSet.mem_nhds a.im_pos)
+
+private theorem SpecialPeriods.MuGenerator.homogeneous_centerOne_eq_zero {τ : ℍ → ℍ} {ν : ℍ → ℂ}
+    (hν₁ : ∀ z : ℍ, ν (SpecialPeriods.Triangle.generatorOneSL • z) = -ν z / (τ z : ℂ)) :
+    ν SpecialPeriods.Triangle.centerOne = 0 := by
+  have he := hν₁ SpecialPeriods.Triangle.centerOne
+  rw [SpecialPeriods.Triangle.generatorOne_fix] at he
+  have hmul :
+    ν SpecialPeriods.Triangle.centerOne * (τ SpecialPeriods.Triangle.centerOne : ℂ) =
+      -ν SpecialPeriods.Triangle.centerOne :=
+    (eq_div_iff (τ SpecialPeriods.Triangle.centerOne).ne_zero).mp he
+  have hz :
+    ν SpecialPeriods.Triangle.centerOne * ((τ SpecialPeriods.Triangle.centerOne : ℂ) + 1) = 0 := by
+    calc
+      _ =
+          ν SpecialPeriods.Triangle.centerOne * (τ SpecialPeriods.Triangle.centerOne : ℂ) +
+            ν SpecialPeriods.Triangle.centerOne := by ring
+      _ = 0 := by rw [hmul]; ring
+  apply (mul_eq_zero.mp hz).resolve_right
+  intro hc
+  have hi := congrArg Complex.im hc
+  simp only [Complex.add_im, Complex.one_im, add_zero, Complex.zero_im] at hi
+  exact (τ SpecialPeriods.Triangle.centerOne).im_ne_zero hi
+
+private theorem SpecialPeriods.MuGenerator.homogeneous_centerTwo_eq_zero {τ : ℍ → ℍ} {ν : ℍ → ℂ}
+    (hν₂ : ∀ z : ℍ, ν (SpecialPeriods.Triangle.generatorTwoSL • z) = ν z / (τ z : ℂ)) :
+    ν SpecialPeriods.Triangle.centerTwo = 0 := by
+  have he := hν₂ SpecialPeriods.Triangle.centerTwo
+  rw [SpecialPeriods.Triangle.generatorTwo_fix] at he
+  have hmul :
+    ν SpecialPeriods.Triangle.centerTwo * (τ SpecialPeriods.Triangle.centerTwo : ℂ) =
+      ν SpecialPeriods.Triangle.centerTwo :=
+    (eq_div_iff (τ SpecialPeriods.Triangle.centerTwo).ne_zero).mp he
+  have hz :
+    ν SpecialPeriods.Triangle.centerTwo * ((τ SpecialPeriods.Triangle.centerTwo : ℂ) - 1) = 0 := by
+    calc
+      _ =
+          ν SpecialPeriods.Triangle.centerTwo * (τ SpecialPeriods.Triangle.centerTwo : ℂ) -
+            ν SpecialPeriods.Triangle.centerTwo := by ring
+      _ = 0 := by rw [hmul]; ring
+  apply (mul_eq_zero.mp hz).resolve_right
+  intro hc
+  have hi := congrArg Complex.im hc
+  simp only [Complex.sub_im, Complex.one_im, sub_zero, Complex.zero_im] at hi
+  exact (τ SpecialPeriods.Triangle.centerTwo).im_ne_zero hi
+
+private theorem
+    SpecialPeriods.MuGenerator.homogeneous_fixed_derivative_identity {τ : ℍ → ℍ} {ν : ℍ → ℂ}
+    (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (hν : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω ν) (g : SL(2, ℝ)) (a : ℍ) (c : ℂ)
+    (hfix : g • a = a) (hzero : ν a = 0) (hlaw : ∀ z : ℍ, ν (g • z) * (τ z : ℂ) = c * ν z) :
+    (deriv (ν ∘ UpperHalfPlane.ofComplex) (a : ℂ) * SpecialPeriods.Triangle.slMultiplier g a) *
+        (τ a : ℂ) =
+      c * deriv (ν ∘ UpperHalfPlane.ofComplex) (a : ℂ) := by
+  let V : ℂ → ℂ := ν ∘ UpperHalfPlane.ofComplex
+  let T : ℂ → ℂ := fun z => (τ (UpperHalfPlane.ofComplex z) : ℂ)
+  let A : ℂ → ℂ := fun z => ((g • UpperHalfPlane.ofComplex z : ℍ) : ℂ)
+  have hV := (scalar_analyticAt hν a).differentiableAt.hasDerivAt
+  have hTa := scalar_analyticAt (UpperHalfPlane.contMDiff_coe.comp hτ) a
+  have hT := hTa.differentiableAt.hasDerivAt
+  have hA : HasDerivAt A (SpecialPeriods.Triangle.slMultiplier g a) (a : ℂ) :=
+    (SpecialPeriods.Triangle.sl_hasStrictDerivAt_smul g a).hasDerivAt
+  have hAa : A (a : ℂ) = (a : ℂ) := by simp [A, hfix]
+  have hVo : HasDerivAt V (deriv V (a : ℂ)) (A (a : ℂ)) := by
+    rw [hAa]
+    exact hV
+  have hcomp :
+    HasDerivAt (fun z : ℂ => ν (g • UpperHalfPlane.ofComplex z))
+      (deriv V (a : ℂ) * SpecialPeriods.Triangle.slMultiplier g a) (a : ℂ) := by
+    simpa only [V, A, Function.comp_def, UpperHalfPlane.ofComplex_apply] using hVo.comp (a : ℂ) hA
+  have hprod :
+    HasDerivAt (fun z : ℂ => ν (g • UpperHalfPlane.ofComplex z) * T z)
+      ((deriv V (a : ℂ) * SpecialPeriods.Triangle.slMultiplier g a) * (τ a : ℂ)) (a : ℂ) := by
+    simpa only [T, Function.comp_def, Pi.mul_def, UpperHalfPlane.ofComplex_apply, hfix, hzero,
+      MulZeroClass.zero_mul, add_zero] using hcomp.mul hT
+  have he : (fun z : ℂ => ν (g • UpperHalfPlane.ofComplex z) * T z) = fun z => c * V z := by
+    funext z
+    exact hlaw (UpperHalfPlane.ofComplex z)
+  rw [he] at hprod
+  exact hprod.unique (hV.const_mul c)
+
+private theorem
+    SpecialPeriods.MuGenerator.homogeneous_centerOne_deriv_eq_zero {τ : ℍ → ℍ} {ν : ℍ → ℂ}
+    (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (hτc : SpecialPeriods.TauCovariant τ)
+    (hν : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω ν)
+    (hν₁ : ∀ z : ℍ, ν (SpecialPeriods.Triangle.generatorOneSL • z) = -ν z / (τ z : ℂ)) :
+    deriv (ν ∘ UpperHalfPlane.ofComplex) (SpecialPeriods.Triangle.centerOne : ℂ) = 0 := by
+  have hzero := homogeneous_centerOne_eq_zero hν₁
+  have hprod :
+    ∀ z : ℍ, ν (SpecialPeriods.Triangle.generatorOneSL • z) * (τ z : ℂ) = (-1 : ℂ) * ν z := by
+    intro z
+    rw [hν₁, div_mul_cancel₀ _ (τ z).ne_zero, neg_one_mul]
+  have hd :=
+    homogeneous_fixed_derivative_identity hτ hν SpecialPeriods.Triangle.generatorOneSL
+      SpecialPeriods.Triangle.centerOne (-1) SpecialPeriods.Triangle.generatorOne_fix hzero hprod
+  rw [SpecialPeriods.Triangle.generatorOne_multiplier,
+    (SpecialPeriods.tau_covariant_values hτc).1] at hd
+  change
+    (deriv (ν ∘ UpperHalfPlane.ofComplex) (SpecialPeriods.Triangle.centerOne : ℂ) *
+          -SpecialPeriods.rho) *
+        SpecialPeriods.rho =
+      -1 * deriv (ν ∘ UpperHalfPlane.ofComplex) (SpecialPeriods.Triangle.centerOne : ℂ) at hd
+  have hz :
+    deriv (ν ∘ UpperHalfPlane.ofComplex) (SpecialPeriods.Triangle.centerOne : ℂ) *
+        (SpecialPeriods.rho ^ 2 - 1) =
+      0 := by linear_combination -hd
+  apply (mul_eq_zero.mp hz).resolve_right
+  intro hc
+  rw [SpecialPeriods.rho_sq] at hc
+  have hi := congrArg Complex.im hc
+  simp only [Complex.sub_im, Complex.one_im, sub_zero, Complex.zero_im] at hi
+  exact SpecialPeriods.rho_im_pos.ne' hi
+
+private theorem SpecialPeriods.MuGenerator.exists_analytic_factor_of_order_le {ν f : ℂ → ℂ} {a : ℂ}
+    {n : ℕ} (hν : AnalyticAt ℂ ν a) (hf : AnalyticAt ℂ f a)
+    (hforder : analyticOrderAt f a = (n : ℕ∞)) (hνorder : (n : ℕ∞) ≤ analyticOrderAt ν a) :
+    ∃ h : ℂ → ℂ, AnalyticAt ℂ h a ∧ ν =ᶠ[𝓝 a] fun z => f z * h z := by
+  obtain ⟨u, hu, hu0, hfu⟩ := hf.analyticOrderAt_eq_natCast.mp hforder
+  obtain ⟨v, hv, hνv⟩ := (natCast_le_analyticOrderAt hν).mp hνorder
+  refine ⟨fun z => v z / u z, hv.div hu hu0, ?_⟩
+  filter_upwards [hfu, hνv, hu.continuousAt.eventually_ne hu0] with z hfz hνz huz
+  simp only [smul_eq_mul] at hfz hνz
+  rw [hfz, hνz]
+  field_simp
+
+private theorem
+    SpecialPeriods.MuGenerator.homogeneous_centerOne_order_ge_two {τ : ℍ → ℍ} {ν : ℍ → ℂ}
+    (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (hτc : SpecialPeriods.TauCovariant τ)
+    (hν : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω ν)
+    (hν₁ : ∀ z : ℍ, ν (SpecialPeriods.Triangle.generatorOneSL • z) = -ν z / (τ z : ℂ)) :
+    (2 : ℕ∞) ≤
+      analyticOrderAt (ν ∘ UpperHalfPlane.ofComplex) (SpecialPeriods.Triangle.centerOne : ℂ) := by
+  rw [show (2 : ℕ∞) = (2 : ℕ) by rfl,
+    natCast_le_analyticOrderAt_iff_iteratedDeriv_eq_zero (scalar_analyticAt hν _)]
+  intro k hk
+  have hk01 : k = 0 ∨ k = 1 := by omega
+  rcases hk01 with rfl | rfl
+  · simpa only [iteratedDeriv_zero, Function.comp_apply, UpperHalfPlane.ofComplex_apply] using
+      homogeneous_centerOne_eq_zero hν₁
+  · simpa only [iteratedDeriv_one] using homogeneous_centerOne_deriv_eq_zero hτ hτc hν hν₁
+
+private theorem
+    SpecialPeriods.MuGenerator.homogeneous_centerTwo_order_ge_one {τ : ℍ → ℍ} {ν : ℍ → ℂ}
+    (hν : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω ν)
+    (hν₂ : ∀ z : ℍ, ν (SpecialPeriods.Triangle.generatorTwoSL • z) = ν z / (τ z : ℂ)) :
+    (1 : ℕ∞) ≤
+      analyticOrderAt (ν ∘ UpperHalfPlane.ofComplex) (SpecialPeriods.Triangle.centerTwo : ℂ) := by
+  rw [show (1 : ℕ∞) = (1 : ℕ) by rfl,
+    natCast_le_analyticOrderAt_iff_iteratedDeriv_eq_zero (scalar_analyticAt hν _)]
+  intro k hk
+  have hk0 : k = 0 := by omega
+  subst k
+  simpa only [iteratedDeriv_zero, Function.comp_apply, UpperHalfPlane.ofComplex_apply] using
+    homogeneous_centerTwo_eq_zero hν₂
+
+private theorem SpecialPeriods.MuGenerator.exists_division_at_centerOne {τ : ℍ → ℍ} {ν f : ℍ → ℂ}
+    (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (hτc : SpecialPeriods.TauCovariant τ)
+    (hν : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω ν)
+    (hν₁ : ∀ z : ℍ, ν (SpecialPeriods.Triangle.generatorOneSL • z) = -ν z / (τ z : ℂ))
+    (hf : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω f)
+    (hforder :
+      analyticOrderAt (f ∘ UpperHalfPlane.ofComplex) (SpecialPeriods.Triangle.centerOne : ℂ) =
+        2) :
+    ∃ h : ℂ → ℂ,
+      AnalyticAt ℂ h (SpecialPeriods.Triangle.centerOne : ℂ) ∧
+        (ν ∘ UpperHalfPlane.ofComplex) =ᶠ[𝓝 (SpecialPeriods.Triangle.centerOne : ℂ)] fun z =>
+          (f ∘ UpperHalfPlane.ofComplex) z * h z :=
+  exists_analytic_factor_of_order_le (scalar_analyticAt hν _) (scalar_analyticAt hf _) (n := 2)
+    hforder (homogeneous_centerOne_order_ge_two hτ hτc hν hν₁)
+
+private theorem SpecialPeriods.MuGenerator.exists_division_at_centerTwo {τ : ℍ → ℍ} {ν f : ℍ → ℂ}
+    (hν : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω ν)
+    (hν₂ : ∀ z : ℍ, ν (SpecialPeriods.Triangle.generatorTwoSL • z) = ν z / (τ z : ℂ))
+    (hf : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω f)
+    (hforder :
+      analyticOrderAt (f ∘ UpperHalfPlane.ofComplex) (SpecialPeriods.Triangle.centerTwo : ℂ) =
+        1) :
+    ∃ h : ℂ → ℂ,
+      AnalyticAt ℂ h (SpecialPeriods.Triangle.centerTwo : ℂ) ∧
+        (ν ∘ UpperHalfPlane.ofComplex) =ᶠ[𝓝 (SpecialPeriods.Triangle.centerTwo : ℂ)] fun z =>
+          (f ∘ UpperHalfPlane.ofComplex) z * h z :=
+  exists_analytic_factor_of_order_le (scalar_analyticAt hν _) (scalar_analyticAt hf _) (n := 1)
+    hforder (homogeneous_centerTwo_order_ge_one hν hν₂)
+
+private def SpecialPeriods.MuGenerator.Homogeneous (τ : ℍ → ℍ) (F : ℍ → ℂ) : Prop :=
+  (∀ z, F (SpecialPeriods.Triangle.generatorOneSL • z) = -F z / (τ z : ℂ)) ∧
+    (∀ z, F (SpecialPeriods.Triangle.generatorTwoSL • z) = F z / (τ z : ℂ))
+
+private theorem SpecialPeriods.MuGenerator.Root.generator_eq_zero_iff_normalized_source {τ : ℍ → ℍ}
+    (r : SpecialPeriods.MuGenerator.Root τ) {π : ℍ → ℂ}
+    (hJ : ∀ z, SpecialPeriods.modularJ (τ z) = 1728 * π z) (z : ℍ) :
+    r.generator z = 0 ↔ π z = 0 ∨ π z = 1 := by
+  rw [r.generator_eq_zero_iff_modularJ, hJ z]
+  have h1728 : (1728 : ℂ) ≠ 0 := by norm_num
+  constructor
+  · rintro (h | h)
+    · exact Or.inl ((mul_eq_zero.mp h).resolve_left h1728)
+    · right
+      apply mul_left_cancel₀ h1728
+      simpa only [mul_one] using h
+  · rintro (h | h)
+    · left
+      rw [h, MulZeroClass.mul_zero]
+    · right
+      rw [h, mul_one]
+
+private theorem SpecialPeriods.MuGenerator.Root.generator_homogeneous {τ : ℍ → ℍ}
+    (r : SpecialPeriods.MuGenerator.Root τ) (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ)
+    (hc : SpecialPeriods.TauCovariant τ)
+    (ho₂ :
+      analyticOrderAt (fun z : ℂ => (τ (UpperHalfPlane.ofComplex z) : ℂ) - Complex.I)
+          (SpecialPeriods.Triangle.centerTwo : ℂ) =
+        2) :
+    SpecialPeriods.MuGenerator.Homogeneous τ r.generator :=
+  ⟨r.generator_generatorOne hτ hc,
+    r.generator_generatorTwo hτ hc (r.order_centerTwo_of_tau_order hτ hc ho₂)⟩
+
+private theorem SpecialPeriods.MuGenerator.exists_homogeneous_generator {τ : ℍ → ℍ}
+    (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (hc : SpecialPeriods.TauCovariant τ)
+    (heven : FiniteEvenZeros τ)
+    (ho₁ :
+      analyticOrderAt (fun z : ℂ => (τ (UpperHalfPlane.ofComplex z) : ℂ) - SpecialPeriods.rho)
+          (SpecialPeriods.Triangle.centerOne : ℂ) =
+        1)
+    (ho₂ :
+      analyticOrderAt (fun z : ℂ => (τ (UpperHalfPlane.ofComplex z) : ℂ) - Complex.I)
+          (SpecialPeriods.Triangle.centerTwo : ℂ) =
+        2) :
+    ∃ F : ℍ → ℂ,
+      (∃ r : Root τ, F = r.generator) ∧
+        ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω F ∧
+          Homogeneous τ F ∧
+            (∀ z,
+                F z = 0 ↔
+                  SpecialPeriods.modularJ (τ z) = 0 ∨ SpecialPeriods.modularJ (τ z) = 1728) ∧
+              analyticOrderAt (F ∘ UpperHalfPlane.ofComplex)
+                    (SpecialPeriods.Triangle.centerOne : ℂ) =
+                  2 ∧
+                analyticOrderAt (F ∘ UpperHalfPlane.ofComplex)
+                    (SpecialPeriods.Triangle.centerTwo : ℂ) =
+                  1 := by
+  let r := root τ (hτ.mdifferentiable (by simp)) heven
+  exact
+    ⟨r.generator, ⟨r, rfl⟩, r.generator_holomorphic hτ, r.generator_homogeneous hτ hc ho₂,
+      r.generator_eq_zero_iff_modularJ, r.generator_order_centerOne_of_tau_order hτ hc ho₁,
+      r.generator_order_centerTwo_of_tau_order hτ hc ho₂⟩
+
+private theorem
+    SpecialPeriods.MuGenerator.exists_homogeneous_generator_of_modular_equation {τ : ℍ → ℍ}
+    {J : ℍ → ℂ} (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (hc : SpecialPeriods.TauCovariant τ)
+    (hJ : ∀ a : ℍ, SpecialPeriods.modularJ (τ a) = J a)
+    (hzero : ∀ a : ℍ, J a = 0 → analyticOrderAt (J ∘ UpperHalfPlane.ofComplex) (a : ℂ) = 3)
+    (h1728 :
+      ∀ a : ℍ,
+        J a = 1728 →
+          analyticOrderAt (fun z : ℂ => J (UpperHalfPlane.ofComplex z) - 1728) (a : ℂ) = 4) :
+    ∃ F : ℍ → ℂ,
+      (∃ r : Root τ, F = r.generator) ∧
+        ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω F ∧
+          Homogeneous τ F ∧
+            (∀ z, F z = 0 ↔ J z = 0 ∨ J z = 1728) ∧
+              analyticOrderAt (F ∘ UpperHalfPlane.ofComplex)
+                    (SpecialPeriods.Triangle.centerOne : ℂ) =
+                  2 ∧
+                analyticOrderAt (F ∘ UpperHalfPlane.ofComplex)
+                    (SpecialPeriods.Triangle.centerTwo : ℂ) =
+                  1 := by
+  have hτd := hτ.mdifferentiable (by simp)
+  have heven : FiniteEvenZeros τ :=
+    finiteEvenZeros_of_modular_equation hτd hJ
+      (fun a ha => ⟨1, by simpa only [Nat.mul_one, Nat.cast_ofNat] using h1728 a ha⟩)
+  have hJ₁ : J SpecialPeriods.Triangle.centerOne = 0 := by
+    rw [← hJ, (SpecialPeriods.tau_covariant_values hc).1, SpecialPeriods.modularJ_rhoPoint]
+  have hJ₂ : J SpecialPeriods.Triangle.centerTwo = 1728 := by
+    rw [← hJ, (SpecialPeriods.tau_covariant_values hc).2, SpecialPeriods.modularJ_I]
+  have ho₁ :=
+    SpecialPeriods.ModularGermLift.native_modularJ_lift_order_of_zero hτd hJ (a :=
+      SpecialPeriods.Triangle.centerOne) (n := 1) hJ₁
+      (by
+        simpa only [Nat.mul_one, Nat.cast_ofNat] using
+          hzero SpecialPeriods.Triangle.centerOne hJ₁)
+  rw [(SpecialPeriods.tau_covariant_values hc).1, SpecialPeriods.coe_rhoPoint] at ho₁
+  have ho₂ :=
+    SpecialPeriods.ModularGermLift.native_modularJ_lift_order_of_1728 hτd hJ (a :=
+      SpecialPeriods.Triangle.centerTwo) (n := 2) hJ₂
+      (by simpa using h1728 SpecialPeriods.Triangle.centerTwo hJ₂)
+  rw [(SpecialPeriods.tau_covariant_values hc).2, UpperHalfPlane.coe_I] at ho₂
+  obtain ⟨F, hFroot, hF, hFc, hFzero, hF₁, hF₂⟩ :=
+    exists_homogeneous_generator hτ hc heven ho₁ ho₂
+  exact ⟨F, hFroot, hF, hFc, fun z => by rw [hFzero z, hJ z], hF₁, hF₂⟩
+
+private def
+    SpecialPeriods.MuTorsor.AffineCocycle.linearPart (c : SpecialPeriods.MuTorsor.AffineCocycle) :
+    SpecialPeriods.MuTorsor.AffineCocycle
+    where
+  scale := c.scale
+  shift _ _ := 0
+  scale_one := c.scale_one
+  shift_one _ := rfl
+  scale_mul := c.scale_mul
+  shift_mul _ _ _ := by simp
+  scale_holomorphic := c.scale_holomorphic
+  shift_holomorphic _ := contMDiff_const
+
+@[simp]
+private theorem SpecialPeriods.MuTorsor.AffineCocycle.linearPart_fibreMap
+    (c : SpecialPeriods.MuTorsor.AffineCocycle) (g : SpecialPeriods.TriangleGroup) (z : ℍ)
+    (u : ℂ) : c.linearPart.fibreMap g z u = (c.scale g z : ℂ) * u := by exact add_zero _
+
+private theorem SpecialPeriods.MuTorsor.homogeneous_scale_law {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) {F : ℍ → ℂ}
+    (hF : SpecialPeriods.MuGenerator.Homogeneous τ F) (g : SpecialPeriods.TriangleGroup) (z : ℍ) :
+    F (SpecialPeriods.triangleGeometricRepresentation g z) =
+      ((cocycle hτ hτa).scale g z : ℂ) * F z := by
+  let K := (cocycle hτ hτa).linearPart.sectionStabilizer F
+  have h₁ : SpecialPeriods.triangleGenerator₁ ∈ K := by
+    intro w
+    rw [SpecialPeriods.triangleGeometricRepresentation_generator₁_apply,
+      AffineCocycle.linearPart_fibreMap, cocycle_scale_generator₁_val, hF.1 w]
+    ring
+  have h₂ : SpecialPeriods.triangleGenerator₂ ∈ K := by
+    intro w
+    rw [SpecialPeriods.triangleGeometricRepresentation_generator₂_apply,
+      AffineCocycle.linearPart_fibreMap, cocycle_scale_generator₂_val, hF.2 w]
+    ring
+  have hle :
+    Subgroup.closure
+        ({ SpecialPeriods.triangleGenerator₁, SpecialPeriods.triangleGenerator₂ } :
+          Set SpecialPeriods.TriangleGroup) ≤
+      K :=
+    (Subgroup.closure_le _).mpr
+      (by
+        intro x hx
+        rcases hx with rfl | rfl
+        · exact h₁
+        · exact h₂)
+  rw [SpecialPeriods.triangle_generators_generate] at hle
+  have hz := hle (Subgroup.mem_top g) z
+  simpa only [AffineCocycle.linearPart_fibreMap] using hz
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous SpecialPeriods.triangleOrbitChartedSpace in
+private def SpecialPeriods.MuTorsor.descentDomain (V : TopologicalSpace.Opens ℍ) :
+    TopologicalSpace.Opens SpecialPeriods.TriangleOrbitSpace :=
+  LocalOrbitQuotient.imageOpen (G := SpecialPeriods.TriangleGroup) V
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous SpecialPeriods.triangleOrbitChartedSpace in
+private theorem
+    SpecialPeriods.MuTorsor.project_mem_descentDomain (V : TopologicalSpace.Opens ℍ) {z : ℍ}
+    (hz : z ∈ V) : SpecialPeriods.triangleOrbitProjection z ∈ descentDomain V :=
+  ⟨z, hz, rfl⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous SpecialPeriods.triangleOrbitChartedSpace in
+private def SpecialPeriods.MuTorsor.descentProjection (V : TopologicalSpace.Opens ℍ) :
+    V → descentDomain V :=
+  LocalOrbitQuotient.imageProjection (G := SpecialPeriods.TriangleGroup) V
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous SpecialPeriods.triangleOrbitChartedSpace in
+private theorem SpecialPeriods.MuTorsor.descentProjection_isOpenQuotientMap
+    (V : TopologicalSpace.Opens ℍ) : IsOpenQuotientMap (descentProjection V) :=
+  LocalOrbitQuotient.imageProjection_isOpenQuotientMap V
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous SpecialPeriods.triangleOrbitChartedSpace in
+private def
+    SpecialPeriods.MuTorsor.orbitRepresentative (q : SpecialPeriods.TriangleOrbitSpace) : ℍ :=
+  (SpecialPeriods.triangleOrbitProjection_surjective q).choose
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous SpecialPeriods.triangleOrbitChartedSpace in
+@[simp]
+private theorem SpecialPeriods.MuTorsor.project_orbitRepresentative
+    (q : SpecialPeriods.TriangleOrbitSpace) :
+    SpecialPeriods.triangleOrbitProjection (orbitRepresentative q) = q :=
+  (SpecialPeriods.triangleOrbitProjection_surjective q).choose_spec
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous SpecialPeriods.triangleOrbitChartedSpace in
+private def SpecialPeriods.MuTorsor.descend (V : TopologicalSpace.Opens ℍ) (f : ℍ → ℂ)
+    (q : SpecialPeriods.TriangleOrbitSpace) : ℂ := by
+  classical exact if orbitRepresentative q ∈ V then f (orbitRepresentative q) else 0
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous SpecialPeriods.triangleOrbitChartedSpace in
+private theorem SpecialPeriods.MuTorsor.project_mem_descentDomain_iff (V : TopologicalSpace.Opens ℍ)
+    (hV :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z : ℍ, SpecialPeriods.triangleGeometricRepresentation g z ∈ V ↔ z ∈ V)
+    (z : ℍ) : SpecialPeriods.triangleOrbitProjection z ∈ descentDomain V ↔ z ∈ V := by
+  constructor
+  · rintro ⟨w, hw, h⟩
+    obtain ⟨g, hg⟩ := (SpecialPeriods.triangleOrbitProjection_eq_iff w z).mp h
+    exact (hV g z).mp (hg ▸ hw)
+  · exact project_mem_descentDomain V
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous SpecialPeriods.triangleOrbitChartedSpace in
+private theorem SpecialPeriods.MuTorsor.orbitRepresentative_mem_iff (V : TopologicalSpace.Opens ℍ)
+    (hV :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z : ℍ, SpecialPeriods.triangleGeometricRepresentation g z ∈ V ↔ z ∈ V)
+    (q : SpecialPeriods.TriangleOrbitSpace) : orbitRepresentative q ∈ V ↔ q ∈ descentDomain V := by
+  rw [← project_mem_descentDomain_iff V hV, project_orbitRepresentative]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous SpecialPeriods.triangleOrbitChartedSpace in
+private theorem SpecialPeriods.MuTorsor.descend_project (V : TopologicalSpace.Opens ℍ) (f : ℍ → ℂ)
+    (hV :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z : ℍ, SpecialPeriods.triangleGeometricRepresentation g z ∈ V ↔ z ∈ V)
+    (hInv :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z ∈ V, f (SpecialPeriods.triangleGeometricRepresentation g z) = f z)
+    {z : ℍ} (hz : z ∈ V) : descend V f (SpecialPeriods.triangleOrbitProjection z) = f z := by
+  have hr : orbitRepresentative (SpecialPeriods.triangleOrbitProjection z) ∈ V :=
+    (orbitRepresentative_mem_iff V hV _).mpr (project_mem_descentDomain V hz)
+  obtain ⟨g, hg⟩ :=
+    (SpecialPeriods.triangleOrbitProjection_eq_iff
+          (orbitRepresentative (SpecialPeriods.triangleOrbitProjection z)) z).mp
+      (project_orbitRepresentative (SpecialPeriods.triangleOrbitProjection z))
+  simp only [descend, ite_eq_left hr]
+  rw [← hg]
+  exact hInv g z hz
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous SpecialPeriods.triangleOrbitChartedSpace in
+private theorem
+    SpecialPeriods.MuTorsor.descend_continuousOn (V : TopologicalSpace.Opens ℍ) (f : ℍ → ℂ)
+    (hV :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z : ℍ, SpecialPeriods.triangleGeometricRepresentation g z ∈ V ↔ z ∈ V)
+    (hInv :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z ∈ V, f (SpecialPeriods.triangleGeometricRepresentation g z) = f z)
+    (hf : ContinuousOn f V) : ContinuousOn (descend V f) (descentDomain V) := by
+  apply continuousOn_iff_continuous_domRestrict.mpr
+  apply (descentProjection_isOpenQuotientMap V).isQuotientMap.continuous_iff.mpr
+  have he : (fun q : descentDomain V => descend V f q) ∘ descentProjection V = fun z : V => f z :=
+    by
+    funext z
+    exact descend_project V f hV hInv z.property
+  change Continuous ((fun q : descentDomain V => descend V f q) ∘ descentProjection V)
+  rw [he]
+  exact hf.domRestrict
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_continuous SpecialPeriods.triangleOrbitChartedSpace in
+private theorem
+    SpecialPeriods.MuTorsor.descend_contMDiffAt_of_not_elliptic (V : TopologicalSpace.Opens ℍ)
+    (f : ℍ → ℂ)
+    (hV :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z : ℍ, SpecialPeriods.triangleGeometricRepresentation g z ∈ V ↔ z ∈ V)
+    (hInv :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z ∈ V, f (SpecialPeriods.triangleGeometricRepresentation g z) = f z)
+    (hf : ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω f V) {q : SpecialPeriods.TriangleOrbitSpace}
+    (hq : q ∈ descentDomain V) (h₁ : q ≠ SpecialPeriods.triangleOrbitCenterOne)
+    (h₂ : q ≠ SpecialPeriods.triangleOrbitCenterTwo) : ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (descend V f) q := by
+  obtain ⟨z, hz, rfl⟩ := hq
+  have hp := SpecialPeriods.triangleOrbitProjection_isLocalDiffeomorphAt_of_not_elliptic h₁ h₂
+  have hcomp : ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (descend V f ∘ SpecialPeriods.triangleOrbitProjection) z :=
+    by
+    apply (hf.contMDiffAt (V.isOpen.mem_nhds hz)).congr_of_eventuallyEq
+    filter_upwards [V.isOpen.mem_nhds hz] with w hw
+    exact descend_project V f hV hInv hw
+  have h :=
+    hcomp.comp_of_eq hp.localInverse_contMDiffAt
+      (hp.localInverse_left_inv hp.localInverse_mem_target)
+  apply h.congr_of_eventuallyEq
+  filter_upwards [hp.localInverse_eventuallyEq_right] with r hr
+  change descend V f r = descend V f (SpecialPeriods.triangleOrbitProjection (hp.localInverse r))
+  rw [show SpecialPeriods.triangleOrbitProjection (hp.localInverse r) = r from hr]
+
+private theorem
+    SpecialPeriods.MuTorsor.contMDiffAt_of_continuousAt_of_eventually_punctured {M : Type*}
+    [TopologicalSpace M] [ChartedSpace ℂ M] [IsManifold 𝓘(ℂ) ω M] {f : M → ℂ} {x : M}
+    (hc : ContinuousAt f x) (hd : ∀ᶠ y in 𝓝[≠] x, ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω f y) :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω f x := by
+  let e := chartAt ℂ x
+  have hx : x ∈ e.source := mem_chart_source ℂ x
+  have hxe : e x ∈ e.target := e.map_source hx
+  have hc' : ContinuousAt (f ∘ e.symm) (e x) :=
+    (e.symm.continuousAt_iff_continuousAt_comp_right hx).mp hc
+  have hp : Filter.Tendsto e.symm (𝓝[≠] e x) (𝓝[≠] x) := by
+    refine tendsto_nhdsWithin_iff.mpr ⟨(e.tendsto_symm hx).mono_left nhdsWithin_le_nhds, ?_⟩
+    simpa only [e.left_inv hx, Set.mem_compl_iff, Set.mem_singleton_iff] using
+      e.symm.eventually_ne_nhdsWithin hxe
+  have hd' : ∀ᶠ z in 𝓝[≠] e x, DifferentiableAt ℂ (f ∘ e.symm) z := by
+    filter_upwards [hp.eventually hd,
+      eventually_nhdsWithin_of_eventually_nhds (e.open_target.eventually_mem hxe)] with z hz hzt
+    have he : ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω e.symm z :=
+      contMDiffAt_symm_of_mem_maximalAtlas
+        (IsManifold.chart_mem_maximalAtlas (I := 𝓘(ℂ)) (n := ω) x) hzt
+    exact (hz.comp z he).contDiffAt.differentiableAt (by simp)
+  have ha := Complex.analyticAt_of_differentiable_on_punctured_nhds_of_continuousAt hd' hc'
+  have he : ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω e x :=
+    contMDiffAt_of_mem_maximalAtlas (IsManifold.chart_mem_maximalAtlas (I := 𝓘(ℂ)) (n := ω) x) hx
+  apply (ha.contDiffAt.contMDiffAt.comp x he).congr_of_eventuallyEq
+  filter_upwards [e.eventually_left_inverse hx] with y hy
+  exact (congrArg f hy).symm
+
+private theorem SpecialPeriods.MuTorsor.contMDiffOn_of_continuousOn_of_finite {M : Type*}
+    [TopologicalSpace M] [ChartedSpace ℂ M] [IsManifold 𝓘(ℂ) ω M] {f : M → ℂ} [T1Space M]
+    {U s : Set M} (hU : IsOpen U) (hs : s.Finite) (hc : ContinuousOn f U)
+    (hd : ∀ x ∈ U, x ∉ s → ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω f x) : ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω f U := by
+  intro x hx
+  apply ContMDiffAt.contMDiffWithinAt
+  apply
+    contMDiffAt_of_continuousAt_of_eventually_punctured ((hc x hx).continuousAt (hU.mem_nhds hx))
+  have hclosed : IsClosed (s \ { x }) := (hs.subset Set.sdiff_subset).isClosed
+  have havoid : (s \ { x })ᶜ ∈ 𝓝 x := hclosed.isOpen_compl.mem_nhds (by simp)
+  filter_upwards [nhdsWithin_le_nhds (hU.mem_nhds hx), nhdsWithin_le_nhds havoid,
+    self_mem_nhdsWithin] with y hy hyavoid hyne
+  apply hd y hy
+  intro hys
+  exact hyavoid ⟨hys, hyne⟩
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+private theorem SpecialPeriods.MuTorsor.instIsManifold1 :
+    IsManifold 𝓘(ℂ) ω SpecialPeriods.TriangleOrbitSpace :=
+  SpecialPeriods.triangleOrbit_isManifold
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+attribute [local instance] SpecialPeriods.MuTorsor.instIsManifold1 in
+private theorem
+    SpecialPeriods.MuTorsor.descend_holomorphic (V : TopologicalSpace.Opens ℍ) (f : ℍ → ℂ)
+    (hV :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z : ℍ, SpecialPeriods.triangleGeometricRepresentation g z ∈ V ↔ z ∈ V)
+    (hInv :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z ∈ V, f (SpecialPeriods.triangleGeometricRepresentation g z) = f z)
+    (hf : ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω f V) :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (descend V f) (descentDomain V) := by
+  apply
+    contMDiffOn_of_continuousOn_of_finite (s :=
+      { SpecialPeriods.triangleOrbitCenterOne, SpecialPeriods.triangleOrbitCenterTwo })
+      (descentDomain V).isOpen
+      ((Set.finite_singleton SpecialPeriods.triangleOrbitCenterTwo).insert
+        SpecialPeriods.triangleOrbitCenterOne)
+      (descend_continuousOn V f hV hInv hf.continuousOn)
+  intro q hq hnot
+  have h₁ : q ≠ SpecialPeriods.triangleOrbitCenterOne := fun h => hnot (by simp [h])
+  have h₂ : q ≠ SpecialPeriods.triangleOrbitCenterTwo := fun h => hnot (by simp [h])
+  exact descend_contMDiffAt_of_not_elliptic V f hV hInv hf hq h₁ h₂
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+attribute [local instance] SpecialPeriods.MuTorsor.instIsManifold1 in
+private theorem
+    SpecialPeriods.MuTorsor.descend_holomorphicAt (V : TopologicalSpace.Opens ℍ) (f : ℍ → ℂ)
+    (hV :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z : ℍ, SpecialPeriods.triangleGeometricRepresentation g z ∈ V ↔ z ∈ V)
+    (hInv :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z ∈ V, f (SpecialPeriods.triangleGeometricRepresentation g z) = f z)
+    (hf : ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω f V) {q : SpecialPeriods.TriangleOrbitSpace}
+    (hq : q ∈ descentDomain V) : ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (descend V f) q :=
+  (descend_holomorphic V f hV hInv hf).contMDiffAt ((descentDomain V).isOpen.mem_nhds hq)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.BetaTorsor.finiteDescentDomain
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (V : TopologicalSpace.Opens ℍ) : TopologicalSpace.Opens ℂ :=
+  ⟨finiteOrbitInverse π hπ ⁻¹'
+      (SpecialPeriods.MuTorsor.descentDomain V : Set SpecialPeriods.TriangleOrbitSpace),
+    (SpecialPeriods.MuTorsor.descentDomain V).isOpen.preimage
+      (finiteOrbitInverse_holomorphic π hπ).continuous⟩
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.BetaTorsor.finiteDescent
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (V : TopologicalSpace.Opens ℍ) (f : ℍ → ℂ) : ℂ → ℂ :=
+  SpecialPeriods.MuTorsor.descend V f ∘ finiteOrbitInverse π hπ
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.finiteDescentDomain_projection
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (V : TopologicalSpace.Opens ℍ)
+    (hV :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z : ℍ, SpecialPeriods.triangleGeometricRepresentation g z ∈ V ↔ z ∈ V)
+    (z : ℍ) : finiteProjection π z ∈ finiteDescentDomain π hπ V ↔ z ∈ V := by
+  change
+    finiteOrbitInverse π hπ (finiteOrbitCoordinate π (SpecialPeriods.triangleOrbitProjection z)) ∈
+        SpecialPeriods.MuTorsor.descentDomain V ↔
+      z ∈ V
+  rw [finiteOrbitInverse_coordinate]
+  exact SpecialPeriods.MuTorsor.project_mem_descentDomain_iff V hV z
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.finiteDescent_projection
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (V : TopologicalSpace.Opens ℍ) (f : ℍ → ℂ)
+    (hV :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z : ℍ, SpecialPeriods.triangleGeometricRepresentation g z ∈ V ↔ z ∈ V)
+    (hInv :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z ∈ V, f (SpecialPeriods.triangleGeometricRepresentation g z) = f z)
+    {z : ℍ} (hz : z ∈ V) : finiteDescent π hπ V f (finiteProjection π z) = f z := by
+  simp only [finiteDescent, finiteProjection, Function.comp_apply, finiteOrbitInverse_coordinate]
+  exact SpecialPeriods.MuTorsor.descend_project V f hV hInv hz
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.finiteDescent_analytic
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (V : TopologicalSpace.Opens ℍ) (f : ℍ → ℂ)
+    (hV :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z : ℍ, SpecialPeriods.triangleGeometricRepresentation g z ∈ V ↔ z ∈ V)
+    (hInv :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z ∈ V, f (SpecialPeriods.triangleGeometricRepresentation g z) = f z)
+    (hf : ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω f V) :
+    AnalyticOnNhd ℂ (finiteDescent π hπ V f) (finiteDescentDomain π hπ V) :=
+  analyticOnNhd_finite_pullback π hπ (SpecialPeriods.MuTorsor.descentDomain V)
+    (SpecialPeriods.MuTorsor.descend_holomorphic V f hV hInv hf)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.MuTorsor.overlap (i j : Cover.Index) : TopologicalSpace.Opens ℍ :=
+  ⟨(Cover.patch i).saturation ∩ (Cover.patch j).saturation,
+    (Cover.patch i).saturation_isOpen.inter (Cover.patch j).saturation_isOpen⟩
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.overlap_invariant (i j : Cover.Index)
+    (g : SpecialPeriods.TriangleGroup) (z : ℍ) :
+    SpecialPeriods.triangleGeometricRepresentation g z ∈ overlap i j ↔ z ∈ overlap i j := by
+  change (_ ∈ (Cover.patch i).saturation ∧ _ ∈ (Cover.patch j).saturation) ↔ _
+  rw [(Cover.patch i).saturation_invariant, (Cover.patch j).saturation_invariant]
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.MuTorsor.overlapQuotient {τ : ℍ → ℍ} (hτ : SpecialPeriods.TauCovariant τ)
+    (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (F : ℍ → ℂ) (i j : Cover.Index) (z : ℍ) : ℂ :=
+  (localSection hτ hτa i z - localSection hτ hτa j z) / F z
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.overlapQuotient_invariant {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (F : ℍ → ℂ)
+    (hFc : SpecialPeriods.MuGenerator.Homogeneous τ F) (i j : Cover.Index)
+    (g : SpecialPeriods.TriangleGroup) (z : ℍ) (hz : z ∈ overlap i j) :
+    overlapQuotient hτ hτa F i j (SpecialPeriods.triangleGeometricRepresentation g z) =
+      overlapQuotient hτ hτa F i j z := by
+  unfold overlapQuotient
+  rw [localSection_equivariant hτ hτa i g z hz.1, localSection_equivariant hτ hτa j g z hz.2,
+    AffineCocycle.fibreMap_sub, homogeneous_scale_law hτ hτa hFc]
+  exact mul_div_mul_left _ _ (cocycle hτ hτa |>.scale g z).ne_zero
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.overlap_generator_ne_zero (F : ℍ → ℂ)
+    (hFzero :
+      ∀ z,
+        F z = 0 ↔
+          SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterOne ∨
+            SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterTwo)
+    {i j : Cover.Index} (hij : i ≠ j) {z : ℍ} (hz : z ∈ overlap i j) : F z ≠ 0 := by
+  have hr := Cover.distinct_saturation_overlap_subset_regularLocus hij hz
+  have hq :=
+    (SpecialPeriods.triangleOrbitRegularDomain_mem_iff _).mp
+      ((SpecialPeriods.triangleOrbitProjection_mem_regularDomain_iff z).mpr hr)
+  intro hf
+  rcases (hFzero z).mp hf with h | h
+  · exact hq.1 h
+  · exact hq.2 h
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.overlapQuotient_holomorphic {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (F : ℍ → ℂ)
+    (hFzero :
+      ∀ z,
+        F z = 0 ↔
+          SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterOne ∨
+            SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterTwo)
+    (hF : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω F) (i j : Cover.Index) :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (overlapQuotient hτ hτa F i j) (overlap i j) := by
+  by_cases hij : i = j
+  · subst j
+    have he : overlapQuotient hτ hτa F i i = fun _ => 0 := by
+      funext z
+      simp only [overlapQuotient, sub_self, zero_div]
+    rw [he]
+    exact contMDiffOn_const
+  · have h₁ :=
+      (localSection_holomorphic hτ hτa i).mono
+        (show (overlap i j : Set ℍ) ⊆ (Cover.patch i).saturation from Set.inter_subset_left)
+    have h₂ :=
+      (localSection_holomorphic hτ hτa j).mono
+        (show (overlap i j : Set ℍ) ⊆ (Cover.patch j).saturation from Set.inter_subset_right)
+    exact (h₁.sub h₂).div₀ hF.contMDiffOn (fun z hz => overlap_generator_ne_zero F hFzero hij hz)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.localSection_eq_at_generator_zero {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (F : ℍ → ℂ)
+    (hFzero :
+      ∀ z,
+        F z = 0 ↔
+          SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterOne ∨
+            SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterTwo)
+    (i j : Cover.Index) (z : ℍ) (hi : z ∈ (Cover.patch i).saturation)
+    (hj : z ∈ (Cover.patch j).saturation) (hz : F z = 0) :
+    localSection hτ hτa i z = localSection hτ hτa j z := by
+  have hij : i = j := by
+    by_contra h
+    exact overlap_generator_ne_zero F hFzero h ⟨hi, hj⟩ hz
+  rw [hij]
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.finiteProjection_mem_patch
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (i : Cover.Index) (z : ℍ) :
+    SpecialPeriods.BetaTorsor.finiteProjection π z ∈ Cover.finitePatch π i ↔
+      z ∈ (Cover.patch i).saturation :=
+  (SpecialPeriods.BetaTorsor.finiteProjection_mem_pullback π hπ (Cover.compactPatch i) z).trans
+    (Cover.compactifiedProjection_mem_compactPatch i z)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.finiteProjection_preimage_patch
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (i : Cover.Index) :
+    SpecialPeriods.BetaTorsor.finiteProjection π ⁻¹' (Cover.finitePatch π i : Set ℂ) =
+      (Cover.patch i).saturation := by
+  ext z
+  exact finiteProjection_mem_patch π hπ i z
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.finiteDescentDomain_overlap
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (i j : Cover.Index) :
+    (SpecialPeriods.BetaTorsor.finiteDescentDomain π hπ (overlap i j) : Set ℂ) =
+      (Cover.finitePatch π i : Set ℂ) ∩ Cover.finitePatch π j := by
+  ext w
+  obtain ⟨z, rfl⟩ := SpecialPeriods.BetaTorsor.finiteProjection_surjective π hπ w
+  change
+    SpecialPeriods.BetaTorsor.finiteProjection π z ∈
+        SpecialPeriods.BetaTorsor.finiteDescentDomain π hπ (overlap i j) ↔
+      SpecialPeriods.BetaTorsor.finiteProjection π z ∈ Cover.finitePatch π i ∧
+        SpecialPeriods.BetaTorsor.finiteProjection π z ∈ Cover.finitePatch π j
+  rw [SpecialPeriods.BetaTorsor.finiteDescentDomain_projection π hπ (overlap i j)
+      (overlap_invariant i j)]
+  rw [finiteProjection_mem_patch π hπ, finiteProjection_mem_patch π hπ]
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def
+    SpecialPeriods.MuTorsor.descendedOverlap {τ : ℍ → ℍ} (hτ : SpecialPeriods.TauCovariant τ)
+    (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (F : ℍ → ℂ)
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (i j : Cover.Index) : ℂ → ℂ :=
+  SpecialPeriods.BetaTorsor.finiteDescent π hπ (overlap i j) (overlapQuotient hτ hτa F i j)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.descendedOverlap_projection {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (F : ℍ → ℂ)
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (hFc : SpecialPeriods.MuGenerator.Homogeneous τ F) (i j : Cover.Index) (z : ℍ)
+    (hi : SpecialPeriods.BetaTorsor.finiteProjection π z ∈ Cover.finitePatch π i)
+    (hj : SpecialPeriods.BetaTorsor.finiteProjection π z ∈ Cover.finitePatch π j) :
+    descendedOverlap hτ hτa F π hπ i j (SpecialPeriods.BetaTorsor.finiteProjection π z) =
+      (localSection hτ hτa i z - localSection hτ hτa j z) / F z := by
+  exact
+    SpecialPeriods.BetaTorsor.finiteDescent_projection π hπ (overlap i j)
+      (overlapQuotient hτ hτa F i j) (overlap_invariant i j)
+      (overlapQuotient_invariant hτ hτa F hFc i j)
+      ⟨(finiteProjection_mem_patch π hπ i z).mp hi, (finiteProjection_mem_patch π hπ j z).mp hj⟩
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.descendedOverlap_analytic {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (F : ℍ → ℂ)
+    (hFzero :
+      ∀ z,
+        F z = 0 ↔
+          SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterOne ∨
+            SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterTwo)
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (hF : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω F) (hFc : SpecialPeriods.MuGenerator.Homogeneous τ F)
+    (i j : Cover.Index) :
+    AnalyticOnNhd ℂ (descendedOverlap hτ hτa F π hπ i j)
+      ((Cover.finitePatch π i : Set ℂ) ∩ Cover.finitePatch π j) := by
+  rw [← finiteDescentDomain_overlap π hπ]
+  exact
+    SpecialPeriods.BetaTorsor.finiteDescent_analytic π hπ (overlap i j)
+      (overlapQuotient hτ hτa F i j) (overlap_invariant i j)
+      (overlapQuotient_invariant hτ hτa F hFc i j)
+      (overlapQuotient_holomorphic hτ hτa F hFzero hF i j)
+
+private def HolomorphicCousin.partitionCochain {ι E H M F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [TopologicalSpace M]
+    [ChartedSpace H M] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    (ρ : SmoothPartitionOfUnity ι I M Set.univ) (h : ι → ι → M → F) (i : ι) (x : M) : F :=
+  ∑ᶠ k, ρ k x • h i k x
+
+private theorem
+    HolomorphicCousin.mem_cover_of_mem_finsupport {ι E H M : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [TopologicalSpace M]
+    [ChartedSpace H M] {U : ι → Set M} {ρ : SmoothPartitionOfUnity ι I M Set.univ}
+    (hρ : ρ.IsSubordinate U) {x : M} {k : ι} (hk : k ∈ ρ.finsupport x) : x ∈ U k := by
+  apply hρ k
+  apply subset_tsupport
+  simpa only [ρ.mem_finsupport, Function.mem_support] using hk
+
+private theorem
+    HolomorphicCousin.partitionCochain_contMDiffOn {ι E H M F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [TopologicalSpace M]
+    [ChartedSpace H M] [NormedAddCommGroup F] [NormedSpace ℝ F] {U : ι → Set M}
+    (hU : ∀ i, IsOpen (U i)) {ρ : SmoothPartitionOfUnity ι I M Set.univ} (hρ : ρ.IsSubordinate U)
+    {h : ι → ι → M → F} (hh : ∀ i j, ContMDiffOn I 𝓘(ℝ, F) ∞ (h i j) (U i ∩ U j)) (i : ι) :
+    ContMDiffOn I 𝓘(ℝ, F) ∞ (partitionCochain ρ h i) (U i) := by
+  intro x hx
+  apply ContMDiffAt.contMDiffWithinAt
+  apply ρ.contMDiffAt_finsum
+  intro k hk
+  exact (hh i k).contMDiffAt ((hU i).inter (hU k) |>.mem_nhds ⟨hx, hρ k hk⟩)
+
+private theorem HolomorphicCousin.partitionCochain_sub_eq {ι E H M F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H} [TopologicalSpace M]
+    [ChartedSpace H M] [NormedAddCommGroup F] [NormedSpace ℝ F] {U : ι → Set M}
+    {ρ : SmoothPartitionOfUnity ι I M Set.univ} (hρ : ρ.IsSubordinate U) {h : ι → ι → M → F}
+    (hc : ∀ i j k x, x ∈ U i → x ∈ U j → x ∈ U k → h i j x + h j k x = h i k x) (i j : ι) {x : M}
+    (hi : x ∈ U i) (hj : x ∈ U j) :
+    partitionCochain ρ h i x - partitionCochain ρ h j x = h i j x := by
+  classical
+  unfold partitionCochain
+  rw [← ρ.sum_finsupport_smul_eq_finsum x (h i), ← ρ.sum_finsupport_smul_eq_finsum x (h j), ←
+    Finset.sum_sub_distrib]
+  calc
+    (∑ k ∈ ρ.finsupport x, (ρ k x • h i k x - ρ k x • h j k x)) =
+        ∑ k ∈ ρ.finsupport x, ρ k x • h i j x := by
+      apply Finset.sum_congr rfl
+      intro k hk
+      rw [← smul_sub,
+        sub_eq_iff_eq_add.mpr (hc i j k x hi hj (mem_cover_of_mem_finsupport hρ hk)).symm]
+    _ = (∑ k ∈ ρ.finsupport x, ρ k x) • h i j x := (Finset.sum_smul ..).symm
+    _ = h i j x := by rw [ρ.sum_finsupport x (Set.mem_univ x), one_smul]
+
+private theorem HolomorphicCousin.partitionCochain_eq_zero_of_weights_single {ι E H M F : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [TopologicalSpace M] [ChartedSpace H M] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    {U : ι → Set M} {ρ : SmoothPartitionOfUnity ι I M Set.univ} {h : ι → ι → M → F}
+    (hc : ∀ i j k x, x ∈ U i → x ∈ U j → x ∈ U k → h i j x + h j k x = h i k x) (j : ι) {x : M}
+    (hj : x ∈ U j) (hρ0 : ∀ k, k ≠ j → ρ k x = 0) : partitionCochain ρ h j x = 0 := by
+  have hdiag : h j j x = 0 := add_eq_left.mp (hc j j j x hj hj hj)
+  have hz : ∀ k, ρ k x • h j k x = 0 := by
+    intro k
+    by_cases hkj : k = j
+    · subst k
+      rw [hdiag, smul_zero]
+    · rw [hρ0 k hkj, zero_smul]
+  simp only [partitionCochain, hz, finsum_zero]
+
+private theorem HolomorphicCousin.partitionCochain_eq_overlap_of_weights_single {ι E H M F : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [TopologicalSpace M] [ChartedSpace H M] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    {U : ι → Set M} {ρ : SmoothPartitionOfUnity ι I M Set.univ} (hρ : ρ.IsSubordinate U)
+    {h : ι → ι → M → F}
+    (hc : ∀ i j k x, x ∈ U i → x ∈ U j → x ∈ U k → h i j x + h j k x = h i k x) (i j : ι) {x : M}
+    (hi : x ∈ U i) (hj : x ∈ U j) (hρ0 : ∀ k, k ≠ j → ρ k x = 0) :
+    partitionCochain ρ h i x = h i j x := by
+  have he := partitionCochain_sub_eq hρ hc i j hi hj
+  rwa [partitionCochain_eq_zero_of_weights_single hc j hj hρ0, sub_zero] at he
+
+private theorem HolomorphicCousin.exists_normalized_smooth_cocycle_cochain {ι E H M F : Type*}
+    [NormedAddCommGroup E] [NormedSpace ℝ E] [TopologicalSpace H] {I : ModelWithCorners ℝ E H}
+    [TopologicalSpace M] [ChartedSpace H M] [NormedAddCommGroup F] [NormedSpace ℝ F]
+    [FiniteDimensional ℝ E] [IsManifold I ∞ M] [T2Space M] [SigmaCompactSpace M] {U : ι → Set M}
+    (hU : ∀ i, IsOpen (U i)) (hcover : ∀ x, ∃ i, x ∈ U i) {h : ι → ι → M → F}
+    (hh : ∀ i j, ContMDiffOn I 𝓘(ℝ, F) ∞ (h i j) (U i ∩ U j))
+    (hc : ∀ i j k x, x ∈ U i → x ∈ U j → x ∈ U k → h i j x + h j k x = h i k x) (i₀ : ι)
+    {K : Set M} (hK : IsClosed K) (hKU : K ⊆ U i₀) :
+    ∃ (V : Set M) (s : ι → M → F),
+      IsOpen V ∧
+        K ⊆ V ∧
+          V ⊆ U i₀ ∧
+            (∀ i, ContMDiffOn I 𝓘(ℝ, F) ∞ (s i) (U i)) ∧
+              (∀ i j x, x ∈ U i → x ∈ U j → s i x - s j x = h i j x) ∧
+                Set.EqOn (s i₀) (fun _ => 0) V ∧ ∀ i, Set.EqOn (s i) (h i i₀) (U i ∩ V) := by
+  obtain ⟨V, hVo, hKV, hVU, ρ, hρ, _, hρ0, _⟩ :=
+    exists_smoothPartitionOfUnity_eq_one_near_closed I U hU
+      (fun x _ => Set.mem_iUnion.mpr (hcover x)) i₀ hK hKU
+  refine
+    ⟨V, partitionCochain ρ h, hVo, hKV, hVU, partitionCochain_contMDiffOn hU hρ hh,
+      fun i j _ hi hj => partitionCochain_sub_eq hρ hc i j hi hj, ?_, ?_⟩
+  · intro x hx
+    exact partitionCochain_eq_zero_of_weights_single hc i₀ (hVU hx) (fun k hk => hρ0 k hk x hx)
+  · intro i x hx
+    exact
+      partitionCochain_eq_overlap_of_weights_single hρ hc i i₀ hx.1 (hVU hx.2)
+        (fun k hk => hρ0 k hk x hx.2)
+
+private def HolomorphicCousin.dbarLinear : (ℂ →L[ℝ] ℂ) →L[ℝ] ℂ :=
+  (1 / (2 : ℂ)) •
+    (ContinuousLinearMap.apply ℝ ℂ (1 : ℂ) + Complex.I • ContinuousLinearMap.apply ℝ ℂ Complex.I)
+
+@[simp]
+private theorem HolomorphicCousin.dbarLinear_apply (L : ℂ →L[ℝ] ℂ) :
+    dbarLinear L = (L 1 + Complex.I * L Complex.I) / 2 := by
+  simp only [dbarLinear, smul_apply, add_apply, ContinuousLinearMap.apply_apply, smul_eq_mul]
+  ring
+
+private def HolomorphicCousin.dbar (f : ℂ → ℂ) (z : ℂ) : ℂ :=
+  (fderiv ℝ f z 1 + Complex.I * fderiv ℝ f z Complex.I) / 2
+
+private theorem HolomorphicCousin.dbar_eq_dbarLinear (f : ℂ → ℂ) (z : ℂ) :
+    dbar f z = dbarLinear (fderiv ℝ f z) :=
+  (dbarLinear_apply _).symm
+
+private theorem HolomorphicCousin.dbarLinear_complex_smul (c : ℂ) (L : ℂ →L[ℝ] ℂ) :
+    dbarLinear (c • L) = c * dbarLinear L := by
+  simp only [dbarLinear_apply, smul_apply, smul_eq_mul]
+  ring
+
+private theorem HolomorphicCousin.dbar_eq_zero_iff (f : ℂ → ℂ) (z : ℂ) :
+    dbar f z = 0 ↔ fderiv ℝ f z Complex.I = Complex.I * fderiv ℝ f z 1 := by
+  constructor
+  · intro h
+    have hs : fderiv ℝ f z 1 + Complex.I * fderiv ℝ f z Complex.I = 0 := by
+      simpa only [dbar, div_eq_zero_iff, OfNat.ofNat_ne_zero, or_false] using h
+    have hm := congrArg (fun w : ℂ => -Complex.I * w) hs
+    simp only [mul_add, neg_mul, ← mul_assoc, Complex.I_mul_I, neg_neg,
+      MulZeroClass.mul_zero] at hm
+    linear_combination hm
+  · intro h
+    rw [dbar, h, ← mul_assoc, Complex.I_mul_I, neg_one_mul, add_neg_cancel, zero_div]
+
+private theorem HolomorphicCousin.differentiableAt_complex_iff_dbar {f : ℂ → ℂ} {z : ℂ} :
+    DifferentiableAt ℂ f z ↔ DifferentiableAt ℝ f z ∧ dbar f z = 0 := by
+  rw [differentiableAt_complex_iff_differentiableAt_real, dbar_eq_zero_iff]
+  rfl
+
+private theorem HolomorphicCousin.dbar_eq_zero_of_differentiableAt {f : ℂ → ℂ} {z : ℂ}
+    (hf : DifferentiableAt ℂ f z) : dbar f z = 0 :=
+  (differentiableAt_complex_iff_dbar.mp hf).2
+
+private theorem
+    HolomorphicCousin.analyticOnNhd_of_dbar_eq_zero {f : ℂ → ℂ} {U : Set ℂ} (hU : IsOpen U)
+    (hf : DifferentiableOn ℝ f U) (hd : ∀ z ∈ U, dbar f z = 0) : AnalyticOnNhd ℂ f U := by
+  apply (Complex.analyticOnNhd_iff_differentiableOn hU).mpr
+  intro z hz
+  exact
+    ((differentiableAt_complex_iff_dbar).mpr
+        ⟨(hf z hz).differentiableAt (hU.mem_nhds hz), hd z hz⟩).differentiableWithinAt
+
+private theorem HolomorphicCousin.dbar_sub {f g : ℂ → ℂ} {z : ℂ} (hf : DifferentiableAt ℝ f z)
+    (hg : DifferentiableAt ℝ g z) : dbar (fun w => f w - g w) z = dbar f z - dbar g z := by
+  simp only [dbar_eq_dbarLinear, fderiv_fun_sub hf hg, map_sub]
+
+private theorem HolomorphicCousin.dbar_comp_const_sub {f : ℂ → ℂ} (a z : ℂ)
+    (hf : DifferentiableAt ℝ f (a - z)) : dbar (fun w => f (a - w)) z = -dbar f (a - z) := by
+  have hi : HasFDerivAt (fun w : ℂ => a - w) (-ContinuousLinearMap.id ℝ ℂ) z :=
+    (hasFDerivAt_id z).const_sub a
+  have he := (hf.hasFDerivAt.comp z hi).fderiv
+  change fderiv ℝ (fun w => f (a - w)) z = _ at he
+  simp only [dbar, he, ContinuousLinearMap.comp_apply, neg_apply, ContinuousLinearMap.id_apply,
+    map_neg]
+  ring
+
+private theorem HolomorphicCousin.contDiffAt_dbar {f : ℂ → ℂ} {z : ℂ} (hf : ContDiffAt ℝ ∞ f z) :
+    ContDiffAt ℝ ∞ (dbar f) z := by
+  have he : dbar f = dbarLinear ∘ fderiv ℝ f := funext (dbar_eq_dbarLinear f)
+  rw [he]
+  exact dbarLinear.contDiff.contDiffAt.comp z (hf.fderiv_right (by simp))
+
+private theorem HolomorphicCousin.dbar_eq_of_sub_differentiableAt {f g : ℂ → ℂ} {z : ℂ}
+    (hf : DifferentiableAt ℝ f z) (hg : DifferentiableAt ℝ g z)
+    (hfg : DifferentiableAt ℂ (fun w => f w - g w) z) : dbar f z = dbar g z := by
+  have he := dbar_eq_zero_of_differentiableAt hfg
+  rw [dbar_sub hf hg] at he
+  exact sub_eq_zero.mp he
+
+private structure HolomorphicCousin.LocalPotential (ι : Type*) where
+  domain : ι → Set ℂ
+  isOpen_domain : ∀ i, IsOpen (domain i)
+  cover : ∀ z : ℂ, ∃ i, z ∈ domain i
+  potential : ι → ℂ → ℂ
+  smooth : ∀ i, ContDiffOn ℝ ∞ (potential i) (domain i)
+  analytic_difference :
+    ∀ i j, AnalyticOnNhd ℂ (fun z => potential i z - potential j z) (domain i ∩ domain j)
+
+private def
+    HolomorphicCousin.LocalPotential.indexAt {ι : Type*} (P : HolomorphicCousin.LocalPotential ι)
+    (z : ℂ) : ι :=
+  (P.cover z).choose
+
+private theorem HolomorphicCousin.LocalPotential.mem_domain_indexAt {ι : Type*}
+    (P : HolomorphicCousin.LocalPotential ι) (z : ℂ) : z ∈ P.domain (P.indexAt z) :=
+  (P.cover z).choose_spec
+
+private theorem HolomorphicCousin.LocalPotential.smoothAt {ι : Type*}
+    (P : HolomorphicCousin.LocalPotential ι) {i : ι} {z : ℂ} (hz : z ∈ P.domain i) :
+    ContDiffAt ℝ ∞ (P.potential i) z :=
+  (P.smooth i z hz).contDiffAt ((P.isOpen_domain i).mem_nhds hz)
+
+private def
+    HolomorphicCousin.LocalPotential.forcing {ι : Type*} (P : HolomorphicCousin.LocalPotential ι)
+    (z : ℂ) : ℂ :=
+  HolomorphicCousin.dbar (P.potential (P.indexAt z)) z
+
+private theorem HolomorphicCousin.LocalPotential.forcing_eq {ι : Type*}
+    (P : HolomorphicCousin.LocalPotential ι) {i : ι} {z : ℂ} (hz : z ∈ P.domain i) :
+    P.forcing z = HolomorphicCousin.dbar (P.potential i) z := by
+  exact
+    HolomorphicCousin.dbar_eq_of_sub_differentiableAt
+      ((P.smoothAt (P.mem_domain_indexAt z)).differentiableAt (by simp))
+      ((P.smoothAt hz).differentiableAt (by simp))
+      (P.analytic_difference (P.indexAt z) i z ⟨P.mem_domain_indexAt z, hz⟩).differentiableAt
+
+private theorem HolomorphicCousin.LocalPotential.forcing_eventuallyEq {ι : Type*}
+    (P : HolomorphicCousin.LocalPotential ι) {i : ι} {z : ℂ} (hz : z ∈ P.domain i) :
+    P.forcing =ᶠ[𝓝 z] HolomorphicCousin.dbar (P.potential i) := by
+  filter_upwards [(P.isOpen_domain i).mem_nhds hz] with w hw
+  exact P.forcing_eq hw
+
+private theorem HolomorphicCousin.LocalPotential.forcing_contDiff {ι : Type*}
+    (P : HolomorphicCousin.LocalPotential ι) : ContDiff ℝ ∞ P.forcing := by
+  apply contDiff_iff_contDiffAt.mpr
+  intro z
+  exact
+    (HolomorphicCousin.contDiffAt_dbar
+          (P.smoothAt (P.mem_domain_indexAt z))).congr_of_eventuallyEq
+      (P.forcing_eventuallyEq (P.mem_domain_indexAt z))
+
+private theorem HolomorphicCousin.LocalPotential.forcing_eq_zero {ι : Type*}
+    (P : HolomorphicCousin.LocalPotential ι) {i : ι} {z : ℂ} (hz : z ∈ P.domain i)
+    (hs : DifferentiableAt ℂ (P.potential i) z) : P.forcing z = 0 := by
+  rw [P.forcing_eq hz]
+  exact HolomorphicCousin.dbar_eq_zero_of_differentiableAt hs
+
+private theorem HolomorphicCousin.LocalPotential.corrected_difference {ι : Type*}
+    (P : HolomorphicCousin.LocalPotential ι) (u : ℂ → ℂ) (i j : ι) (z : ℂ) :
+    (P.potential i z - u z) - (P.potential j z - u z) = P.potential i z - P.potential j z := by
+  ring
+
+private theorem HolomorphicCousin.LocalPotential.corrected_analytic {ι : Type*}
+    (P : HolomorphicCousin.LocalPotential ι) {u : ℂ → ℂ} (hu : Differentiable ℝ u)
+    (hsolve : ∀ z, HolomorphicCousin.dbar u z = P.forcing z) (i : ι) :
+    AnalyticOnNhd ℂ (fun z => P.potential i z - u z) (P.domain i) := by
+  apply HolomorphicCousin.analyticOnNhd_of_dbar_eq_zero (P.isOpen_domain i)
+  · exact ((P.smooth i).differentiableOn (by simp)).sub hu.differentiableOn
+  · intro z hz
+    rw [HolomorphicCousin.dbar_sub ((P.smoothAt hz).differentiableAt (by simp)) (hu z), hsolve,
+      P.forcing_eq hz, sub_self]
+
+private theorem HolomorphicCousin.LocalPotential.forcing_eq_zero_on_normalization {ι : Type*}
+    (P : HolomorphicCousin.LocalPotential ι) {i : ι} {V : Set ℂ} (hV : IsOpen V)
+    (hVi : V ⊆ P.domain i) (hzero : Set.EqOn (P.potential i) (fun _ => 0) V) :
+    Set.EqOn P.forcing (fun _ => 0) V := by
+  intro z hz
+  apply P.forcing_eq_zero (hVi hz)
+  apply (differentiableAt_const (0 : ℂ)).congr_of_eventuallyEq
+  filter_upwards [hV.mem_nhds hz] with w hw
+  exact hzero hw
+
+private theorem
+    HolomorphicCousin.LocalPotential.forcing_tsupport_subset_of_normalization {ι : Type*}
+    (P : HolomorphicCousin.LocalPotential ι) {i : ι} {V : Set ℂ} (hV : IsOpen V)
+    (hVi : V ⊆ P.domain i) (hzero : Set.EqOn (P.potential i) (fun _ => 0) V) :
+    tsupport P.forcing ⊆ Vᶜ := by
+  apply closure_minimal ?_ hV.isClosed_compl
+  intro z hz hzV
+  exact hz (P.forcing_eq_zero_on_normalization hV hVi hzero hzV)
+
+private theorem
+    HolomorphicCousin.exists_normalized_cocycle_localPotential {ι : Type*} {U : ι → Set ℂ}
+    (hU : ∀ i, IsOpen (U i)) (hcover : ∀ z, ∃ i, z ∈ U i) {h : ι → ι → ℂ → ℂ}
+    (hh : ∀ i j, AnalyticOnNhd ℂ (h i j) (U i ∩ U j))
+    (hc : ∀ i j k z, z ∈ U i → z ∈ U j → z ∈ U k → h i j z + h j k z = h i k z) (i₀ : ι) (R : ℝ)
+    (hRU : (Metric.ball (0 : ℂ) R)ᶜ ⊆ U i₀) :
+    ∃ P : LocalPotential ι,
+      P.domain = U ∧
+        (∀ i j z, z ∈ U i → z ∈ U j → P.potential i z - P.potential j z = h i j z) ∧
+          (∃ V : Set ℂ,
+              IsOpen V ∧
+                (Metric.ball (0 : ℂ) R)ᶜ ⊆ V ∧
+                  V ⊆ U i₀ ∧
+                    Set.EqOn (P.potential i₀) (fun _ => 0) V ∧
+                      ∀ i, Set.EqOn (P.potential i) (h i i₀) (U i ∩ V)) ∧
+            tsupport P.forcing ⊆ Metric.ball (0 : ℂ) R ∧ HasCompactSupport P.forcing := by
+  have hsmooth i j : ContMDiffOn 𝓘(ℝ, ℂ) 𝓘(ℝ, ℂ) ∞ (h i j) (U i ∩ U j) :=
+    ((hh i j).contDiffOn_of_completeSpace (n := ∞)).restrict_scalars ℝ |>.contMDiffOn
+  obtain ⟨V, s, hVo, hRV, hVU, hs, htrans, hs0, hsOverlap⟩ :=
+    exists_normalized_smooth_cocycle_cochain hU hcover hsmooth hc i₀
+      Metric.isOpen_ball.isClosed_compl hRU
+  let P : LocalPotential ι :=
+    { domain := U
+      isOpen_domain := hU
+      cover := hcover
+      potential := s
+      smooth := fun i => (hs i).contDiffOn
+      analytic_difference := fun i j =>
+        (hh i j).congr ((hU i).inter (hU j)) (fun z hz => (htrans i j z hz.1 hz.2).symm) }
+  have hsupport : tsupport P.forcing ⊆ Metric.ball (0 : ℂ) R := by
+    have hsub := P.forcing_tsupport_subset_of_normalization hVo hVU hs0
+    intro z hz
+    by_contra hzR
+    exact hsub hz (hRV hzR)
+  have hcompact : HasCompactSupport P.forcing := by
+    apply
+      HasCompactSupport.of_support_subset_isCompact (ProperSpace.isCompact_closedBall (0 : ℂ) R)
+    exact (subset_tsupport P.forcing).trans (hsupport.trans Metric.ball_subset_closedBall)
+  exact ⟨P, rfl, htrans, ⟨V, hVo, hRV, hVU, hs0, hsOverlap⟩, hsupport, hcompact⟩
+
+private theorem HolomorphicCousin.locallyIntegrable_complex_inv :
+    MeasureTheory.LocallyIntegrable (fun z : ℂ => z⁻¹) := by
+  refine
+    MeasureTheory.locallyIntegrable_of_norm_le_rpow (C := 1) (α := 1)
+      (by simp [Complex.finrank_real_complex]) (by norm_num [Complex.finrank_real_complex]) ?_ ?_
+  · filter_upwards with z
+    simp only [norm_inv, Real.rpow_neg_one, one_mul, le_refl]
+  · exact Measurable.aestronglyMeasurable (by fun_prop)
+
+private def HolomorphicCousin.cauchyGreen (f : ℂ → ℂ) (z : ℂ) : ℂ :=
+  (1 / (Real.pi : ℂ)) * ∫ w : ℂ, w⁻¹ * f (z - w)
+
+private theorem HolomorphicCousin.contDiff_cauchyGreen {n : ℕ∞} {f : ℂ → ℂ} (hf : ContDiff ℝ n f)
+    (hcf : HasCompactSupport f) : ContDiff ℝ n (cauchyGreen f) := by
+  change
+    ContDiff ℝ n
+      (fun z => (1 / (Real.pi : ℂ)) * ((fun w : ℂ => w⁻¹) ⋆[ContinuousLinearMap.mul ℝ ℂ] f) z)
+  exact
+    contDiff_const.mul
+      (hcf.contDiff_convolution_right (ContinuousLinearMap.mul ℝ ℂ) locallyIntegrable_complex_inv
+        hf)
+
+private theorem HolomorphicCousin.hasFDerivAt_cauchyGreen {f : ℂ → ℂ} (hf : ContDiff ℝ 1 f)
+    (hcf : HasCompactSupport f) (z : ℂ) :
+    HasFDerivAt (cauchyGreen f)
+      ((1 / (Real.pi : ℂ)) •
+        ((fun w : ℂ => w⁻¹) ⋆[(ContinuousLinearMap.mul ℝ ℂ).precompR ℂ] fderiv ℝ f) z)
+      z := by
+  convert!
+    (hcf.hasFDerivAt_convolution_right (ContinuousLinearMap.mul ℝ ℂ) locallyIntegrable_complex_inv
+          hf z).const_mul
+      (1 / (Real.pi : ℂ)) using
+    1
+
+private theorem HolomorphicCousin.dbarLinear_precompR_mul (a : ℂ) (L : ℂ →L[ℝ] ℂ) :
+    dbarLinear ((ContinuousLinearMap.mul ℝ ℂ).precompR ℂ a L) = a * dbarLinear L := by
+  change dbarLinear (a • L) = a * dbarLinear L
+  exact dbarLinear_complex_smul a L
+
+private theorem
+    HolomorphicCousin.dbar_cauchyGreen_eq_cauchyGreen_dbar {f : ℂ → ℂ} (hf : ContDiff ℝ 1 f)
+    (hcf : HasCompactSupport f) (z : ℂ) : dbar (cauchyGreen f) z = cauchyGreen (dbar f) z := by
+  have hi :
+    MeasureTheory.Integrable
+      (fun w : ℂ => (ContinuousLinearMap.mul ℝ ℂ).precompR ℂ w⁻¹ (fderiv ℝ f (z - w))) :=
+    (hcf.fderiv ℝ).convolutionExists_right ((ContinuousLinearMap.mul ℝ ℂ).precompR ℂ)
+      locallyIntegrable_complex_inv (hf.continuous_fderiv one_ne_zero) z
+  rw [dbar_eq_dbarLinear, (hasFDerivAt_cauchyGreen hf hcf z).fderiv, dbarLinear_complex_smul,
+    MeasureTheory.convolution_def, ← dbarLinear.integral_comp_comm hi]
+  simp only [dbarLinear_precompR_mul, ← dbar_eq_dbarLinear, cauchyGreen]
+
+private def HolomorphicCousin.greenUnit (θ : ℝ) : ℂ :=
+  circleMap 0 1 θ
+
+private theorem HolomorphicCousin.greenUnit_eq (θ : ℝ) :
+    greenUnit θ = (Real.cos θ : ℂ) + (Real.sin θ : ℂ) * Complex.I := by
+  simp [greenUnit, circleMap, Complex.exp_mul_I]
+
+@[simp]
+private theorem HolomorphicCousin.norm_greenUnit (θ : ℝ) : ‖greenUnit θ‖ = 1 := by simp [greenUnit]
+
+private theorem HolomorphicCousin.continuous_greenUnit : Continuous greenUnit := by
+  exact continuous_circleMap 0 1
+
+private theorem HolomorphicCousin.polarCoord_symm_eq_greenUnit (p : ℝ × ℝ) :
+    Complex.polarCoord.symm p = (p.1 : ℂ) * greenUnit p.2 := by
+  simp [Complex.polarCoord_symm_apply, greenUnit_eq]
+
+private theorem HolomorphicCousin.realLinear_apply_complex (D : ℂ →L[ℝ] ℂ) (z : ℂ) :
+    D z = (z.re : ℂ) * D 1 + (z.im : ℂ) * D Complex.I := by
+  calc
+    D z = D (z.re • (1 : ℂ) + z.im • Complex.I) := by
+      congr 1
+      simp [Complex.real_smul]
+    _ = (z.re : ℂ) * D 1 + (z.im : ℂ) * D Complex.I := by
+      rw [map_add, map_smul, map_smul]
+      simp [Complex.real_smul]
+
+private theorem HolomorphicCousin.polar_realLinear_identity (D : ℂ →L[ℝ] ℂ) (z : ℂ) :
+    D z + Complex.I * D (Complex.I * z) = Star.star z * (D 1 + Complex.I * D Complex.I) := by
+  have hc : Star.star z = (z.re : ℂ) - (z.im : ℂ) * Complex.I := by apply Complex.ext <;> simp
+  rw [realLinear_apply_complex D z, realLinear_apply_complex D (Complex.I * z), hc]
+  simp only [Complex.mul_re, Complex.mul_im, Complex.I_re, Complex.I_im, MulZeroClass.zero_mul,
+    one_mul, zero_sub, zero_add, Complex.ofReal_neg]
+  ring_nf
+  simp [Complex.I_sq]
+
+private def HolomorphicCousin.greenRadial (φ : ℂ → ℂ) (p : ℝ × ℝ) : ℂ :=
+  fderiv ℝ φ ((p.1 : ℂ) * greenUnit p.2) (greenUnit p.2)
+
+private def HolomorphicCousin.greenAngular (φ : ℂ → ℂ) (p : ℝ × ℝ) : ℂ :=
+  fderiv ℝ φ ((p.1 : ℂ) * greenUnit p.2) (Complex.I * greenUnit p.2)
+
+private theorem HolomorphicCousin.continuous_greenRadial {φ : ℂ → ℂ} (hφ : ContDiff ℝ 1 φ) :
+    Continuous (greenRadial φ) := by
+  exact
+    (hφ.continuous_fderiv_apply one_ne_zero).comp
+      (((Complex.continuous_ofReal.comp continuous_fst).mul
+            (continuous_greenUnit.comp continuous_snd)).prodMk
+        (continuous_greenUnit.comp continuous_snd))
+
+private theorem HolomorphicCousin.continuous_greenAngular {φ : ℂ → ℂ} (hφ : ContDiff ℝ 1 φ) :
+    Continuous (greenAngular φ) := by
+  exact
+    (hφ.continuous_fderiv_apply one_ne_zero).comp
+      (((Complex.continuous_ofReal.comp continuous_fst).mul
+            (continuous_greenUnit.comp continuous_snd)).prodMk
+        (continuous_const.mul (continuous_greenUnit.comp continuous_snd)))
+
+private theorem HolomorphicCousin.hasDerivAt_green_radial {φ : ℂ → ℂ} (hφ : Differentiable ℝ φ)
+    (r θ : ℝ) : HasDerivAt (fun t : ℝ => φ ((t : ℂ) * greenUnit θ)) (greenRadial φ (r, θ)) r := by
+  apply (hφ _).hasFDerivAt.comp_hasDerivAt
+  simpa using (Complex.ofRealCLM.hasDerivAt (x := r)).mul_const (greenUnit θ)
+
+private theorem HolomorphicCousin.hasDerivAt_green_angular {φ : ℂ → ℂ} (hφ : Differentiable ℝ φ)
+    (r θ : ℝ) :
+    HasDerivAt (fun t : ℝ => φ ((r : ℂ) * greenUnit t)) ((r : ℂ) * greenAngular φ (r, θ)) θ := by
+  have hu : HasDerivAt greenUnit (Complex.I * greenUnit θ) θ := by
+    change HasDerivAt (circleMap 0 1) (Complex.I * circleMap 0 1 θ) θ
+    simpa [mul_comm] using hasDerivAt_circleMap 0 1 θ
+  have hd := (hφ _).hasFDerivAt.comp_hasDerivAt θ (hu.const_mul (r : ℂ))
+  simpa only [Function.comp_def, ← Complex.real_smul, map_smul, greenAngular] using hd
+
+private theorem HolomorphicCousin.integral_greenRadial {φ : ℂ → ℂ} (hφ : ContDiff ℝ 1 φ) (R θ : ℝ) :
+    (∫ r in 0..R, greenRadial φ (r, θ)) = φ ((R : ℂ) * greenUnit θ) - φ 0 := by
+  have hint :
+    IntervalIntegrable (fun r => greenRadial φ (r, θ)) MeasureTheory.MeasureSpace.volume 0 R :=
+    ((continuous_greenRadial hφ).comp (continuous_id.prodMk continuous_const)).intervalIntegrable
+      _ _
+  simpa using
+    intervalIntegral.integral_eq_sub_of_hasDerivAt
+      (fun r _ => hasDerivAt_green_radial (hφ.differentiable one_ne_zero) r θ) hint
+
+private theorem HolomorphicCousin.integral_greenAngular {φ : ℂ → ℂ} (hφ : ContDiff ℝ 1 φ) {r : ℝ}
+    (hr : r ≠ 0) : (∫ θ in (-Real.pi)..Real.pi, greenAngular φ (r, θ)) = 0 := by
+  have hint :
+    IntervalIntegrable (fun θ => (r : ℂ) * greenAngular φ (r, θ))
+      MeasureTheory.MeasureSpace.volume (-Real.pi) Real.pi :=
+    (continuous_const.mul
+          ((continuous_greenAngular hφ).comp
+            (continuous_const.prodMk continuous_id))).intervalIntegrable
+      _ _
+  have heq :=
+    intervalIntegral.integral_eq_sub_of_hasDerivAt
+      (fun θ _ => hasDerivAt_green_angular (hφ.differentiable one_ne_zero) r θ) hint
+  have hend : greenUnit Real.pi = greenUnit (-Real.pi) := by simp [greenUnit_eq]
+  have hz : (r : ℂ) * (∫ θ in (-Real.pi)..Real.pi, greenAngular φ (r, θ)) = 0 := by
+    simpa only [intervalIntegral.integral_const_mul, hend, sub_self] using heq
+  exact (mul_eq_zero.mp hz).resolve_left (Complex.ofReal_ne_zero.mpr hr)
+
+private theorem
+    HolomorphicCousin.exists_green_support_radius {φ : ℂ → ℂ} (hφ : HasCompactSupport φ) :
+    ∃ R : ℝ, 0 < R ∧ ∀ z : ℂ, R ≤ ‖z‖ → φ z = 0 ∧ fderiv ℝ φ z = 0 := by
+  obtain ⟨R, hR, hs⟩ := hφ.isBounded.subset_ball_lt 0 (0 : ℂ)
+  refine ⟨R, hR, ?_⟩
+  intro z hz
+  have hn : z ∉ tsupport φ := by
+    intro hmem
+    have hlt : ‖z‖ < R := by simpa using hs hmem
+    exact not_lt_of_ge hz hlt
+  exact ⟨image_eq_zero_of_notMem_tsupport hn, fderiv_of_notMem_tsupport ℝ hn⟩
+
+private theorem HolomorphicCousin.integrableOn_polarRectangle_mo1973_17804 {G : ℝ × ℝ → ℂ} {R : ℝ}
+    (hG : ContinuousOn G (Set.Icc 0 R ×ˢ Set.Icc (-Real.pi) Real.pi)) :
+    MeasureTheory.IntegrableOn G (Set.Ioc 0 R ×ˢ Set.Ioo (-Real.pi) Real.pi) := by
+  apply
+    (hG.integrableOn_compact
+        (CompactIccSpace.isCompact_Icc.prod CompactIccSpace.isCompact_Icc)).mono_set
+  rintro ⟨r, θ⟩ ⟨hr, hθ⟩
+  exact ⟨⟨hr.1.le, hr.2⟩, ⟨hθ.1.le, hθ.2.le⟩⟩
+
+private theorem HolomorphicCousin.integrableOn_polarTarget_of_radial_support {G : ℝ × ℝ → ℂ} {R : ℝ}
+    (hG : ContinuousOn G (Set.Icc 0 R ×ˢ Set.Icc (-Real.pi) Real.pi))
+    (hzero : ∀ p, R < p.1 → G p = 0) : MeasureTheory.IntegrableOn G polarCoord.target := by
+  apply
+    (integrableOn_polarRectangle_mo1973_17804 hG).of_forall_sdiff_eq_zero
+      polarCoord.open_target.measurableSet
+  rintro ⟨r, θ⟩ ⟨hp, hnot⟩
+  apply hzero
+  by_contra hr
+  exact hnot ⟨⟨hp.1, le_of_not_gt hr⟩, hp.2⟩
+
+private theorem HolomorphicCousin.integral_polarTarget_eq_rectangle {G : ℝ × ℝ → ℂ} {R : ℝ}
+    (hzero : ∀ p, R < p.1 → G p = 0) :
+    (∫ p in polarCoord.target, G p) = ∫ p in Set.Ioc 0 R ×ˢ Set.Ioo (-Real.pi) Real.pi, G p := by
+  apply
+    MeasureTheory.setIntegral_eq_of_subset_of_forall_sdiff_eq_zero
+      polarCoord.open_target.measurableSet
+  · rintro ⟨r, θ⟩ ⟨hr, hθ⟩
+    exact ⟨hr.1, hθ⟩
+  · rintro ⟨r, θ⟩ ⟨hp, hnot⟩
+    apply hzero
+    by_contra hr
+    exact hnot ⟨⟨hp.1, le_of_not_gt hr⟩, hp.2⟩
+
+private theorem HolomorphicCousin.integral_polarTarget_eq_radius_angle {G : ℝ × ℝ → ℂ} {R : ℝ}
+    (hR : 0 ≤ R) (hG : ContinuousOn G (Set.Icc 0 R ×ˢ Set.Icc (-Real.pi) Real.pi))
+    (hzero : ∀ p, R < p.1 → G p = 0) :
+    (∫ p in polarCoord.target, G p) = ∫ r in 0..R, ∫ θ in (-Real.pi)..Real.pi, G (r, θ) := by
+  rw [integral_polarTarget_eq_rectangle hzero]
+  rw [MeasureTheory.Measure.volume_eq_prod]
+  rw [MeasureTheory.setIntegral_prod G
+      (by
+        simpa only [MeasureTheory.Measure.volume_eq_prod] using
+          integrableOn_polarRectangle_mo1973_17804 hG)]
+  simp_rw [intervalIntegral.integral_of_le hR,
+    intervalIntegral.integral_of_le (neg_le_self Real.pi_pos.le),
+    MeasureTheory.integral_Ioc_eq_integral_Ioo]
+
+private theorem HolomorphicCousin.integral_polarTarget_eq_angle_radius {G : ℝ × ℝ → ℂ} {R : ℝ}
+    (hR : 0 ≤ R) (hG : ContinuousOn G (Set.Icc 0 R ×ˢ Set.Icc (-Real.pi) Real.pi))
+    (hzero : ∀ p, R < p.1 → G p = 0) :
+    (∫ p in polarCoord.target, G p) = ∫ θ in (-Real.pi)..Real.pi, ∫ r in 0..R, G (r, θ) := by
+  rw [integral_polarTarget_eq_rectangle hzero, MeasureTheory.Measure.volume_eq_prod, ←
+    MeasureTheory.Measure.prod_restrict]
+  rw [MeasureTheory.integral_prod_symm G
+      (by
+        simpa only [MeasureTheory.IntegrableOn, MeasureTheory.Measure.prod_restrict,
+          ← MeasureTheory.Measure.volume_eq_prod] using
+          integrableOn_polarRectangle_mo1973_17804 hG)]
+  simp_rw [intervalIntegral.integral_of_le hR,
+    intervalIntegral.integral_of_le (neg_le_self Real.pi_pos.le),
+    MeasureTheory.integral_Ioc_eq_integral_Ioo]
+
+private theorem HolomorphicCousin.green_polar_integrand (φ : ℂ → ℂ) (p : ℝ × ℝ) (hp : 0 < p.1) :
+    p.1 • ((Complex.polarCoord.symm p)⁻¹ * dbar φ (Complex.polarCoord.symm p)) =
+      (greenRadial φ p + Complex.I * greenAngular φ p) / 2 := by
+  have hr : (p.1 : ℂ) ≠ 0 := Complex.ofReal_ne_zero.mpr hp.ne'
+  rw [polarCoord_symm_eq_greenUnit, Complex.real_smul, dbar]
+  unfold greenRadial greenAngular
+  rw [polar_realLinear_identity, Complex.star_def, ← Complex.inv_eq_conj (norm_greenUnit p.2)]
+  field_simp
+
+private theorem HolomorphicCousin.greenRadial_radius_vanish_mo1973_17810 {φ : ℂ → ℂ} {R : ℝ}
+    (hR : 0 < R) (hz : ∀ z : ℂ, R ≤ ‖z‖ → fderiv ℝ φ z = 0) :
+    ∀ p : ℝ × ℝ, R < p.1 → greenRadial φ p = 0 := by
+  intro p hp
+  have hn : R ≤ ‖(p.1 : ℂ) * greenUnit p.2‖ := by
+    simpa only [norm_mul, norm_greenUnit, mul_one, Complex.norm_real, Real.norm_eq_abs,
+      abs_of_pos (hR.trans hp)] using hp.le
+  simp only [greenRadial, hz _ hn, zero_apply]
+
+private theorem HolomorphicCousin.greenAngular_radius_vanish_mo1973_17811 {φ : ℂ → ℂ} {R : ℝ}
+    (hR : 0 < R) (hz : ∀ z : ℂ, R ≤ ‖z‖ → fderiv ℝ φ z = 0) :
+    ∀ p : ℝ × ℝ, R < p.1 → greenAngular φ p = 0 := by
+  intro p hp
+  have hn : R ≤ ‖(p.1 : ℂ) * greenUnit p.2‖ := by
+    simpa only [norm_mul, norm_greenUnit, mul_one, Complex.norm_real, Real.norm_eq_abs,
+      abs_of_pos (hR.trans hp)] using hp.le
+  simp only [greenAngular, hz _ hn, zero_apply]
+
+private theorem HolomorphicCousin.integrableOn_greenRadial {φ : ℂ → ℂ} (hφ : ContDiff ℝ 1 φ)
+    (hc : HasCompactSupport φ) : MeasureTheory.IntegrableOn (greenRadial φ) polarCoord.target := by
+  obtain ⟨R, hR, hz⟩ := exists_green_support_radius hc
+  exact
+    integrableOn_polarTarget_of_radial_support (continuous_greenRadial hφ).continuousOn
+      (greenRadial_radius_vanish_mo1973_17810 hR (fun z h => (hz z h).2))
+
+private theorem HolomorphicCousin.integrableOn_greenAngular {φ : ℂ → ℂ} (hφ : ContDiff ℝ 1 φ)
+    (hc : HasCompactSupport φ) : MeasureTheory.IntegrableOn (greenAngular φ) polarCoord.target := by
+  obtain ⟨R, hR, hz⟩ := exists_green_support_radius hc
+  exact
+    integrableOn_polarTarget_of_radial_support (continuous_greenAngular hφ).continuousOn
+      (greenAngular_radius_vanish_mo1973_17811 hR (fun z h => (hz z h).2))
+
+private theorem HolomorphicCousin.integral_greenRadial_polarTarget {φ : ℂ → ℂ} (hφ : ContDiff ℝ 1 φ)
+    (hc : HasCompactSupport φ) :
+    (∫ p in polarCoord.target, greenRadial φ p) = -(2 * (Real.pi : ℂ)) * φ 0 := by
+  obtain ⟨R, hR, hz⟩ := exists_green_support_radius hc
+  rw [integral_polarTarget_eq_angle_radius hR.le (continuous_greenRadial hφ).continuousOn
+      (greenRadial_radius_vanish_mo1973_17810 hR (fun z h => (hz z h).2))]
+  have hend (θ : ℝ) : φ ((R : ℂ) * greenUnit θ) = 0 := by
+    apply (hz _ _).1
+    simp [abs_of_pos hR]
+  simp_rw [integral_greenRadial hφ, hend, zero_sub]
+  simp only [intervalIntegral.integral_const, Complex.real_smul, sub_neg_eq_add,
+    Complex.ofReal_add]
+  ring
+
+private theorem
+    HolomorphicCousin.integral_greenAngular_polarTarget {φ : ℂ → ℂ} (hφ : ContDiff ℝ 1 φ)
+    (hc : HasCompactSupport φ) : (∫ p in polarCoord.target, greenAngular φ p) = 0 := by
+  obtain ⟨R, hR, hz⟩ := exists_green_support_radius hc
+  rw [integral_polarTarget_eq_radius_angle hR.le (continuous_greenAngular hφ).continuousOn
+      (greenAngular_radius_vanish_mo1973_17811 hR (fun z h => (hz z h).2))]
+  apply intervalIntegral.integral_zero_ae
+  filter_upwards with r hr
+  have hr' : r ∈ Set.Ioc 0 R := by simpa only [Set.uIoc_of_le hR.le] using hr
+  exact integral_greenAngular hφ hr'.1.ne'
+
+private theorem HolomorphicCousin.integral_inv_mul_dbar {φ : ℂ → ℂ} (hφ : ContDiff ℝ 1 φ)
+    (hc : HasCompactSupport φ) : (∫ w : ℂ, w⁻¹ * dbar φ w) = -(Real.pi : ℂ) * φ 0 := by
+  rw [← Complex.integral_comp_polarCoord_symm]
+  calc
+    (∫ p in polarCoord.target,
+          p.1 • ((Complex.polarCoord.symm p)⁻¹ * dbar φ (Complex.polarCoord.symm p))) =
+        ∫ p in polarCoord.target, (greenRadial φ p + Complex.I * greenAngular φ p) / 2 := by
+      apply MeasureTheory.setIntegral_congr_fun polarCoord.open_target.measurableSet
+      intro p hp
+      exact green_polar_integrand φ p hp.1
+    _ =
+        ((∫ p in polarCoord.target, greenRadial φ p) +
+            Complex.I * (∫ p in polarCoord.target, greenAngular φ p)) /
+          2 := by
+      rw [MeasureTheory.integral_div,
+        MeasureTheory.integral_add (integrableOn_greenRadial hφ hc)
+          ((integrableOn_greenAngular hφ hc).const_mul Complex.I),
+        MeasureTheory.integral_const_mul]
+    _ = -(Real.pi : ℂ) * φ 0 := by
+      rw [integral_greenRadial_polarTarget hφ hc, integral_greenAngular_polarTarget hφ hc]
+      ring
+
+private theorem HolomorphicCousin.cauchyGreen_dbar {f : ℂ → ℂ} (hf : ContDiff ℝ 1 f)
+    (hcf : HasCompactSupport f) (z : ℂ) : cauchyGreen (dbar f) z = f z := by
+  let φ : ℂ → ℂ := fun w => f (z - w)
+  have hφ : ContDiff ℝ 1 φ := hf.comp (contDiff_const.sub contDiff_id)
+  have hcφ : HasCompactSupport φ := hcf.comp_homeomorph (Homeomorph.subLeft z)
+  have hd : dbar φ = fun w => -dbar f (z - w) := by
+    funext w
+    exact dbar_comp_const_sub z w ((hf.differentiable one_ne_zero) (z - w))
+  have he := integral_inv_mul_dbar hφ hcφ
+  have he' : -(∫ w : ℂ, w⁻¹ * dbar f (z - w)) = -((Real.pi : ℂ) * f z) := by
+    simpa only [hd, mul_neg, MeasureTheory.integral_neg, φ, sub_zero, neg_mul] using he
+  have hi := neg_injective he'
+  unfold cauchyGreen
+  rw [hi, one_div, ← mul_assoc, inv_mul_cancel₀, one_mul]
+  exact Complex.ofReal_ne_zero.mpr Real.pi_ne_zero
+
+private theorem HolomorphicCousin.dbar_cauchyGreen {f : ℂ → ℂ} (hf : ContDiff ℝ 1 f)
+    (hcf : HasCompactSupport f) (z : ℂ) : dbar (cauchyGreen f) z = f z := by
+  rw [dbar_cauchyGreen_eq_cauchyGreen_dbar hf hcf, cauchyGreen_dbar hf hcf]
+
+private theorem HolomorphicCousin.cauchyGreen_smooth_dbar_solution {f : ℂ → ℂ} (hf : ContDiff ℝ ∞ f)
+    (hcf : HasCompactSupport f) :
+    ContDiff ℝ ∞ (cauchyGreen f) ∧ ∀ z, dbar (cauchyGreen f) z = f z := by
+  refine ⟨contDiff_cauchyGreen hf hcf, ?_⟩
+  exact dbar_cauchyGreen (hf.of_le (by simp)) hcf
+
+private def HolomorphicCousin.cauchyGreenInfinity (f : ℂ → ℂ) (u : ℂ) : ℂ :=
+  (1 / (Real.pi : ℂ)) * ∫ w : ℂ, u * (1 - w * u)⁻¹ * f w
+
+@[simp]
+private theorem
+    HolomorphicCousin.cauchyGreenInfinity_zero (f : ℂ → ℂ) : cauchyGreenInfinity f 0 = 0 := by
+  simp [cauchyGreenInfinity]
+
+private theorem HolomorphicCousin.area_denominator_ne_zero_mo1973_17824 {R : ℝ} (hR : 0 < R)
+    {u w : ℂ} (hu : u ∈ Metric.ball 0 R⁻¹) (hw : ‖w‖ ≤ R) : 1 - w * u ≠ 0 := by
+  have hu' : ‖u‖ < R⁻¹ := by simpa using hu
+  have hmul : ‖w * u‖ < 1 := by
+    rw [norm_mul]
+    calc
+      ‖w‖ * ‖u‖ ≤ R * ‖u‖ := mul_le_mul_of_nonneg_right hw (norm_nonneg u)
+      _ < R * R⁻¹ := (mul_lt_mul_of_pos_left hu' hR)
+      _ = 1 := mul_inv_cancel₀ hR.ne'
+  intro heq
+  have hwu : w * u = 1 := (sub_eq_zero.mp heq).symm
+  simp [hwu] at hmul
+
+private theorem HolomorphicCousin.area_denominator_lower_bound_mo1973_17825 {R r : ℝ} (hR : 0 < R)
+    {x w : ℂ} (hx : x ∈ Metric.ball 0 r) (hw : ‖w‖ ≤ R) : 1 - R * r ≤ ‖1 - w * x‖ := by
+  have hx' : ‖x‖ ≤ r := le_of_lt (by simpa using hx)
+  have hmul : ‖w * x‖ ≤ R * r := by
+    rw [norm_mul]
+    exact mul_le_mul hw hx' (norm_nonneg x) hR.le
+  calc
+    1 - R * r ≤ 1 - ‖w * x‖ := sub_le_sub_left hmul 1
+    _ = ‖(1 : ℂ)‖ - ‖w * x‖ := by rw [NormOneClass.norm_one]
+    _ ≤ ‖1 - w * x‖ := norm_sub_norm_le _ _
+
+private theorem HolomorphicCousin.area_reciprocal_kernel_hasDerivAt_mo1973_17826 {w x : ℂ}
+    (hne : 1 - w * x ≠ 0) : HasDerivAt (fun y : ℂ => y * (1 - w * y)⁻¹) (1 / (1 - w * x) ^ 2) x :=
+  by
+  have hn : HasDerivAt (fun y : ℂ => y) 1 x := hasDerivAt_id x
+  have hd : HasDerivAt (fun y : ℂ => 1 - w * y) (-w) x := by
+    simpa only [mul_one, id_eq] using! ((hasDerivAt_id x).const_mul w).const_sub 1
+  have hnum : (1 : ℂ) * (1 - w * x) - x * -w = 1 := by ring
+  simpa only [Pi.div_apply, hnum, div_eq_mul_inv] using! hn.div hd hne
+
+private theorem HolomorphicCousin.hasDerivAt_cauchyGreenInfinity {f : ℂ → ℂ} {R : ℝ}
+    (hf : MeasureTheory.Integrable f) (hR : 0 < R) (hbound : ∀ w ∈ Function.support f, ‖w‖ ≤ R)
+    {u : ℂ} (hu : u ∈ Metric.ball 0 R⁻¹) :
+    HasDerivAt (cauchyGreenInfinity f)
+      ((1 / (Real.pi : ℂ)) * ∫ w : ℂ, (1 / (1 - w * u) ^ 2) * f w) u := by
+  have hu' : ‖u‖ < R⁻¹ := by simpa using hu
+  obtain ⟨r, hur, hrR⟩ := exists_between hu'
+  have hsub : Metric.ball (0 : ℂ) r ⊆ Metric.ball 0 R⁻¹ := Metric.ball_subset_ball hrR.le
+  have humem : u ∈ Metric.ball (0 : ℂ) r := by simpa using hur
+  have hd : 0 < 1 - R * r := by
+    have hlt : R * r < 1 := by
+      calc
+        R * r < R * R⁻¹ := mul_lt_mul_of_pos_left hrR hR
+        _ = 1 := mul_inv_cancel₀ hR.ne'
+    linarith
+  have hmeas (x : ℂ) :
+    MeasureTheory.AEStronglyMeasurable (fun w : ℂ => x * (1 - w * x)⁻¹ * f w)
+      MeasureTheory.MeasureSpace.volume := by
+    apply MeasureTheory.AEStronglyMeasurable.mul _ hf.aestronglyMeasurable
+    exact Measurable.aestronglyMeasurable (by fun_prop)
+  have hint : MeasureTheory.Integrable (fun w : ℂ => u * (1 - w * u)⁻¹ * f w) := by
+    refine (hf.norm.const_mul (‖u‖ * (1 - R * r)⁻¹)).mono' (hmeas u) ?_
+    filter_upwards with w
+    by_cases hw : f w = 0
+    · simp [hw]
+    · have hwb := hbound w hw
+      simp only [norm_mul, norm_inv]
+      gcongr
+      exact area_denominator_lower_bound_mo1973_17825 hR humem hwb
+  change HasDerivAt (fun x => cauchyGreenInfinity f x) _ u
+  simp only [cauchyGreenInfinity]
+  apply HasDerivAt.const_mul
+  refine
+    (hasDerivAt_integral_of_dominated_loc_of_deriv_le (F' := fun x w : ℂ =>
+        (1 / (1 - w * x) ^ 2) * f w) (bound := fun w : ℂ => ((1 - R * r) ^ 2)⁻¹ * ‖f w‖)
+        (Metric.isOpen_ball.mem_nhds humem) (Filter.Eventually.of_forall hmeas) hint ?_ ?_ ?_
+        ?_).2
+  · apply MeasureTheory.AEStronglyMeasurable.mul _ hf.aestronglyMeasurable
+    exact Measurable.aestronglyMeasurable (by fun_prop)
+  · filter_upwards with w x hx
+    by_cases hw : f w = 0
+    · simp [hw]
+    · have hwb := hbound w hw
+      simp only [norm_mul, norm_inv, norm_pow, one_div]
+      gcongr
+      exact area_denominator_lower_bound_mo1973_17825 hR hx hwb
+  · exact hf.norm.const_mul _
+  · filter_upwards with w x hx
+    by_cases hw : f w = 0
+    · simpa only [hw, MulZeroClass.mul_zero] using hasDerivAt_const x (0 : ℂ)
+    · exact
+        (area_reciprocal_kernel_hasDerivAt_mo1973_17826
+              (area_denominator_ne_zero_mo1973_17824 hR (hsub hx) (hbound w hw))).mul_const
+          (f w)
+
+private theorem
+    HolomorphicCousin.analyticOnNhd_cauchyGreenInfinity_of_integrable {f : ℂ → ℂ} {R : ℝ}
+    (hf : MeasureTheory.Integrable f) (hR : 0 < R) (hbound : ∀ w ∈ Function.support f, ‖w‖ ≤ R) :
+    AnalyticOnNhd ℂ (cauchyGreenInfinity f) (Metric.ball 0 R⁻¹) := by
+  apply DifferentiableOn.analyticOnNhd _ Metric.isOpen_ball
+  intro u hu
+  exact (hasDerivAt_cauchyGreenInfinity hf hR hbound hu).differentiableAt.differentiableWithinAt
+
+private theorem HolomorphicCousin.analyticOnNhd_cauchyGreenInfinity {f : ℂ → ℂ} {R : ℝ}
+    (hf : Continuous f) (hfc : HasCompactSupport f) (hR : 0 < R)
+    (hbound : ∀ w ∈ Function.support f, ‖w‖ ≤ R) :
+    AnalyticOnNhd ℂ (cauchyGreenInfinity f) (Metric.ball 0 R⁻¹) :=
+  analyticOnNhd_cauchyGreenInfinity_of_integrable (hf.integrable_of_hasCompactSupport hfc) hR
+    hbound
+
+private theorem HolomorphicCousin.cauchyGreenInfinity_inv (f : ℂ → ℂ) {z : ℂ} (hz : z ≠ 0) :
+    cauchyGreenInfinity f z⁻¹ = cauchyGreen f z := by
+  unfold cauchyGreenInfinity cauchyGreen
+  congr 1
+  calc
+    (∫ w : ℂ, z⁻¹ * (1 - w * z⁻¹)⁻¹ * f w) = ∫ w : ℂ, (z - w)⁻¹ * f w := by
+      apply MeasureTheory.integral_congr_ae
+      filter_upwards with w
+      have hden : 1 - w * z⁻¹ = (z - w) * z⁻¹ := by rw [sub_mul, mul_inv_cancel₀ hz]
+      rw [hden, mul_inv_rev, inv_inv, ← mul_assoc, inv_mul_cancel₀ hz, one_mul]
+    _ = ∫ w : ℂ, w⁻¹ * f (z - w) := by
+      simpa only [sub_sub_self] using
+        MeasureTheory.integral_sub_left_eq_self (fun w : ℂ => w⁻¹ * f (z - w))
+          MeasureTheory.MeasureSpace.volume z
+
+private def HolomorphicCousin.LocalPotential.correctedPart {ι : Type*}
+    (P : HolomorphicCousin.LocalPotential ι) (i : ι) (z : ℂ) : ℂ :=
+  P.potential i z - HolomorphicCousin.cauchyGreen P.forcing z
+
+private theorem HolomorphicCousin.LocalPotential.correctedPart_analytic {ι : Type*}
+    (P : HolomorphicCousin.LocalPotential ι) (hc : HasCompactSupport P.forcing) (i : ι) :
+    AnalyticOnNhd ℂ (P.correctedPart i) (P.domain i) := by
+  obtain ⟨hs, he⟩ := HolomorphicCousin.cauchyGreen_smooth_dbar_solution P.forcing_contDiff hc
+  exact P.corrected_analytic (hs.differentiable (by simp)) he i
+
+private theorem HolomorphicCousin.LocalPotential.correctedPart_sub {ι : Type*}
+    (P : HolomorphicCousin.LocalPotential ι) (i j : ι) (z : ℂ) :
+    P.correctedPart i z - P.correctedPart j z = P.potential i z - P.potential j z :=
+  P.corrected_difference (HolomorphicCousin.cauchyGreen P.forcing) i j z
+
+private def HolomorphicCousin.LocalPotential.correctedInfinity {ι : Type*}
+    (P : HolomorphicCousin.LocalPotential ι) (u : ℂ) : ℂ :=
+  -HolomorphicCousin.cauchyGreenInfinity P.forcing u
+
+@[simp]
+private theorem HolomorphicCousin.LocalPotential.correctedInfinity_zero {ι : Type*}
+    (P : HolomorphicCousin.LocalPotential ι) : P.correctedInfinity 0 = 0 := by
+  simp [correctedInfinity]
+
+private theorem HolomorphicCousin.LocalPotential.correctedInfinity_analytic {ι : Type*}
+    (P : HolomorphicCousin.LocalPotential ι) (hc : HasCompactSupport P.forcing) {R : ℝ}
+    (hR : 0 < R) (hbound : ∀ z ∈ Function.support P.forcing, ‖z‖ ≤ R) :
+    AnalyticOnNhd ℂ P.correctedInfinity (Metric.ball 0 R⁻¹) :=
+  (HolomorphicCousin.analyticOnNhd_cauchyGreenInfinity P.forcing_contDiff.continuous hc hR
+      hbound).neg
+
+private theorem HolomorphicCousin.LocalPotential.correctedPart_eq_infinity {ι : Type*}
+    (P : HolomorphicCousin.LocalPotential ι) {i : ι} {z : ℂ} (hz : z ≠ 0)
+    (hs : P.potential i z = 0) : P.correctedPart i z = P.correctedInfinity z⁻¹ := by
+  simp only [correctedPart, hs, zero_sub, correctedInfinity,
+    HolomorphicCousin.cauchyGreenInfinity_inv P.forcing hz]
+
+private structure HolomorphicCousin.NormalizedCocycleSolution {ι : Type*} (U : ι → Set ℂ)
+    (h : ι → ι → ℂ → ℂ) (i₀ : ι) (R : ℝ) where
+  localPart : ι → ℂ → ℂ
+  infinityPart : ℂ → ℂ
+  local_analytic : ∀ i, AnalyticOnNhd ℂ (localPart i) (U i)
+  infinity_analytic : AnalyticOnNhd ℂ infinityPart (Metric.ball 0 R⁻¹)
+  infinity_zero : infinityPart 0 = 0
+  equation : ∀ i j z, z ∈ U i → z ∈ U j → localPart i z - localPart j z = h i j z
+  atInfinity : ∀ z, R < ‖z‖ → localPart i₀ z = infinityPart z⁻¹
+
+private theorem HolomorphicCousin.exists_normalized_holomorphic_cocycle_solution {ι : Type*}
+    {U : ι → Set ℂ} (hU : ∀ i, IsOpen (U i)) (hcover : ∀ z, ∃ i, z ∈ U i) {h : ι → ι → ℂ → ℂ}
+    (hh : ∀ i j, AnalyticOnNhd ℂ (h i j) (U i ∩ U j))
+    (hc : ∀ i j k z, z ∈ U i → z ∈ U j → z ∈ U k → h i j z + h j k z = h i k z) (i₀ : ι) {R : ℝ}
+    (hR : 0 < R) (hRU : (Metric.ball (0 : ℂ) R)ᶜ ⊆ U i₀) :
+    Nonempty (NormalizedCocycleSolution U h i₀ R) := by
+  obtain ⟨P, hPU, htrans, ⟨V, _, hRV, _, hs0, _⟩, hsupport, hcompact⟩ :=
+    exists_normalized_cocycle_localPotential hU hcover hh hc i₀ R hRU
+  have hbound : ∀ z ∈ Function.support P.forcing, ‖z‖ ≤ R := by
+    intro z hz
+    have hzR := hsupport (subset_tsupport P.forcing hz)
+    exact (show ‖z‖ < R by simpa only [Metric.mem_ball, dist_zero_right] using hzR).le
+  refine
+    ⟨{  localPart := P.correctedPart
+        infinityPart := P.correctedInfinity
+        local_analytic := ?_
+        infinity_analytic := P.correctedInfinity_analytic hcompact hR hbound
+        infinity_zero := P.correctedInfinity_zero
+        equation := ?_
+        atInfinity := ?_ }⟩
+  · intro i
+    simpa only [hPU] using P.correctedPart_analytic hcompact i
+  · intro i j z hi hj
+    exact (P.correctedPart_sub i j z).trans (htrans i j z hi hj)
+  · intro z hz
+    apply P.correctedPart_eq_infinity (norm_pos_iff.mp (hR.trans hz))
+    apply hs0
+    apply hRV
+    simpa only [Set.mem_compl_iff, Metric.mem_ball, dist_zero_right, not_lt] using hz.le
+
+private structure HolomorphicCousin.NegativeOneCocycleSolution {ι : Type*} (U : ι → Set ℂ)
+    (h : ι → ι → ℂ → ℂ) (i₀ : ι) (R : ℝ) where
+  localPart : ι → ℂ → ℂ
+  infinityPart : ℂ → ℂ
+  local_analytic : ∀ i, AnalyticOnNhd ℂ (localPart i) (U i)
+  infinity_analytic : AnalyticOnNhd ℂ infinityPart (Metric.ball 0 R⁻¹)
+  equation : ∀ i j z, z ∈ U i → z ∈ U j → localPart i z - localPart j z = h i j z
+  atInfinity : ∀ z, R < ‖z‖ → localPart i₀ z = z⁻¹ * infinityPart z⁻¹
+
+private def HolomorphicCousin.NormalizedCocycleSolution.negativeOne {ι : Type*} {U : ι → Set ℂ}
+    {h : ι → ι → ℂ → ℂ} {i₀ : ι} {R : ℝ} (hR : 0 < R)
+    (s : HolomorphicCousin.NormalizedCocycleSolution U h i₀ R) :
+    HolomorphicCousin.NegativeOneCocycleSolution U h i₀ R
+    where
+  localPart := s.localPart
+  infinityPart := dslope s.infinityPart 0
+  local_analytic := s.local_analytic
+  infinity_analytic :=
+    HolomorphicCousin.analyticOnNhd_dslope_zero (inv_pos.mpr hR) s.infinity_analytic
+  equation := s.equation
+  atInfinity := by
+    intro z hz
+    rw [s.atInfinity z hz]
+    exact (HolomorphicCousin.zero_mul_dslope s.infinity_zero z⁻¹).symm
+
+private theorem HolomorphicCousin.exists_negativeOne_holomorphic_cocycle_solution {ι : Type*}
+    {U : ι → Set ℂ} (hU : ∀ i, IsOpen (U i)) (hcover : ∀ z, ∃ i, z ∈ U i) {h : ι → ι → ℂ → ℂ}
+    (hh : ∀ i j, AnalyticOnNhd ℂ (h i j) (U i ∩ U j))
+    (hc : ∀ i j k z, z ∈ U i → z ∈ U j → z ∈ U k → h i j z + h j k z = h i k z) (i₀ : ι) {R : ℝ}
+    (hR : 0 < R) (hRU : (Metric.ball (0 : ℂ) R)ᶜ ⊆ U i₀) :
+    Nonempty (NegativeOneCocycleSolution U h i₀ R) := by
+  obtain ⟨s⟩ := exists_normalized_holomorphic_cocycle_solution hU hcover hh hc i₀ hR hRU
+  exact ⟨s.negativeOne hR⟩
+
+private theorem SpecialPeriods.MuTorsor.Gluing.descended_quotient_cocycle {X ι : Type*} {p : X → ℂ}
+    (hp : Function.Surjective p) {U : ι → Set ℂ} {μ : ι → X → ℂ} {F : X → ℂ} {h : ι → ι → ℂ → ℂ}
+    (hq : ∀ i j z, p z ∈ U i → p z ∈ U j → h i j (p z) = (μ i z - μ j z) / F z) :
+    ∀ i j k w, w ∈ U i → w ∈ U j → w ∈ U k → h i j w + h j k w = h i k w := by
+  intro i j k w hi hj hk
+  obtain ⟨z, rfl⟩ := hp w
+  rw [hq i j z hi hj, hq j k z hj hk, hq i k z hi hk]
+  ring
+
+private theorem SpecialPeriods.MuTorsor.Gluing.difference_eq_mul_quotient {X ι : Type*} {p : X → ℂ}
+    {U : ι → Set ℂ} {μ : ι → X → ℂ} {F : X → ℂ} {h : ι → ι → ℂ → ℂ}
+    (hq : ∀ i j z, p z ∈ U i → p z ∈ U j → h i j (p z) = (μ i z - μ j z) / F z)
+    (hz : ∀ i j z, p z ∈ U i → p z ∈ U j → F z = 0 → μ i z = μ j z) (i j : ι) (z : X)
+    (hi : p z ∈ U i) (hj : p z ∈ U j) : μ i z - μ j z = F z * h i j (p z) := by
+  rw [hq i j z hi hj]
+  by_cases hF : F z = 0
+  · rw [hz i j z hi hj hF, sub_self, zero_div, MulZeroClass.mul_zero]
+  · exact (mul_div_cancel₀ (μ i z - μ j z) hF).symm
+
+private def SpecialPeriods.MuTorsor.Gluing.correctedGlue {X ι : Type*} (p : X → ℂ) (U : ι → Set ℂ)
+    (hcover : ∀ w, ∃ i, w ∈ U i) (μ : ι → X → ℂ) (F : X → ℂ) {h : ι → ι → ℂ → ℂ} {i₀ : ι} {R : ℝ}
+    (s : HolomorphicCousin.NegativeOneCocycleSolution U h i₀ R) (z : X) : ℂ :=
+  μ (hcover (p z)).choose z - F z * s.localPart (hcover (p z)).choose (p z)
+
+private theorem
+    SpecialPeriods.MuTorsor.Gluing.correctedGlue_eq {X ι : Type*} {p : X → ℂ} {U : ι → Set ℂ}
+    {hcover : ∀ w, ∃ i, w ∈ U i} {μ : ι → X → ℂ} {F : X → ℂ} {h : ι → ι → ℂ → ℂ} {i₀ : ι} {R : ℝ}
+    (s : HolomorphicCousin.NegativeOneCocycleSolution U h i₀ R)
+    (hdiff : ∀ i j z, p z ∈ U i → p z ∈ U j → μ i z - μ j z = F z * h i j (p z)) {i : ι} {z : X}
+    (hz : p z ∈ U i) : correctedGlue p U hcover μ F s z = μ i z - F z * s.localPart i (p z) := by
+  let j := (hcover (p z)).choose
+  have hj : p z ∈ U j := (hcover (p z)).choose_spec
+  change μ j z - F z * s.localPart j (p z) = μ i z - F z * s.localPart i (p z)
+  have hd := hdiff j i z hj hz
+  have hs := s.equation j i (p z) hj hz
+  linear_combination hd - F z * hs
+
+private theorem SpecialPeriods.MuTorsor.Gluing.correctedGlue_eventuallyEq {X ι : Type*}
+    [TopologicalSpace X] {p : X → ℂ} (hp : Continuous p) {U : ι → Set ℂ} (hU : ∀ i, IsOpen (U i))
+    {hcover : ∀ w, ∃ i, w ∈ U i} {μ : ι → X → ℂ} {F : X → ℂ} {h : ι → ι → ℂ → ℂ} {i₀ : ι} {R : ℝ}
+    (s : HolomorphicCousin.NegativeOneCocycleSolution U h i₀ R)
+    (hdiff : ∀ i j z, p z ∈ U i → p z ∈ U j → μ i z - μ j z = F z * h i j (p z)) {i : ι} {z : X}
+    (hz : p z ∈ U i) :
+    correctedGlue p U hcover μ F s =ᶠ[𝓝 z] fun w => μ i w - F w * s.localPart i (p w) := by
+  filter_upwards [((hU i).preimage hp).mem_nhds hz] with w hw
+  exact correctedGlue_eq s hdiff hw
+
+private theorem SpecialPeriods.MuTorsor.Gluing.correctedGlue_holomorphic {ι : Type*} {p : ℍ → ℂ}
+    (hp : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω p) {U : ι → Set ℂ} (hU : ∀ i, IsOpen (U i))
+    {hcover : ∀ w, ∃ i, w ∈ U i} {μ : ι → ℍ → ℂ}
+    (hμ : ∀ i, ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (μ i) (p ⁻¹' U i)) {F : ℍ → ℂ}
+    (hF : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω F) {h : ι → ι → ℂ → ℂ} {i₀ : ι} {R : ℝ}
+    (s : HolomorphicCousin.NegativeOneCocycleSolution U h i₀ R)
+    (hdiff : ∀ i j z, p z ∈ U i → p z ∈ U j → μ i z - μ j z = F z * h i j (p z)) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (correctedGlue p U hcover μ F s) := by
+  intro z
+  obtain ⟨i, hi⟩ := hcover (p z)
+  have hm : ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (μ i) z :=
+    (hμ i).contMDiffAt (((hU i).preimage hp.continuous).mem_nhds hi)
+  have hs : ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (fun w => s.localPart i (p w)) z :=
+    (s.local_analytic i (p z) hi).contDiffAt.contMDiffAt.comp z (hp z)
+  exact
+    (hm.sub ((hF z).mul hs)).congr_of_eventuallyEq
+      (correctedGlue_eventuallyEq hp.continuous hU s hdiff hi)
+
+private theorem SpecialPeriods.MuTorsor.Gluing.correctedGlue_affine_law {ι : Type*} {p : ℍ → ℂ}
+    {U : ι → Set ℂ} {hcover : ∀ w, ∃ i, w ∈ U i} {μ : ι → ℍ → ℂ} {F : ℍ → ℂ} {h : ι → ι → ℂ → ℂ}
+    {i₀ : ι} {R : ℝ} (s : HolomorphicCousin.NegativeOneCocycleSolution U h i₀ R)
+    (hdiff : ∀ i j z, p z ∈ U i → p z ∈ U j → μ i z - μ j z = F z * h i j (p z))
+    (c : SpecialPeriods.MuTorsor.AffineCocycle)
+    (hp : ∀ g z, p (SpecialPeriods.triangleGeometricRepresentation g z) = p z)
+    (hμ : ∀ i, c.EquivariantOn (μ i) (p ⁻¹' U i))
+    (hF : ∀ g z, F (SpecialPeriods.triangleGeometricRepresentation g z) = (c.scale g z : ℂ) * F z)
+    (g : SpecialPeriods.TriangleGroup) (z : ℍ) :
+    correctedGlue p U hcover μ F s (SpecialPeriods.triangleGeometricRepresentation g z) =
+      c.fibreMap g z (correctedGlue p U hcover μ F s z) := by
+  obtain ⟨i, hi⟩ := hcover (p z)
+  have hig : p (SpecialPeriods.triangleGeometricRepresentation g z) ∈ U i := by rwa [hp g z]
+  rw [correctedGlue_eq s hdiff hig, correctedGlue_eq s hdiff hi, hp g z, hμ i g z hi, hF g z]
+  simp only [SpecialPeriods.MuTorsor.AffineCocycle.fibreMap]
+  ring
+
+private theorem SpecialPeriods.MuTorsor.Gluing.correctedGlue_cusp {X ι : Type*} {p : X → ℂ}
+    {U : ι → Set ℂ} {hcover : ∀ w, ∃ i, w ∈ U i} {μ : ι → X → ℂ} {F : X → ℂ} {h : ι → ι → ℂ → ℂ}
+    {i₀ : ι} {R : ℝ} (s : HolomorphicCousin.NegativeOneCocycleSolution U h i₀ R)
+    (hdiff : ∀ i j z, p z ∈ U i → p z ∈ U j → μ i z - μ j z = F z * h i j (p z))
+    (hRU : (Metric.ball (0 : ℂ) R)ᶜ ⊆ U i₀) {W : Set X} (hμ₀ : ∀ z ∈ W, μ i₀ z = 0) {z : X}
+    (hz : z ∈ W) (hlarge : R < ‖p z‖) :
+    correctedGlue p U hcover μ F s z = -F z * (p z)⁻¹ * s.infinityPart (p z)⁻¹ := by
+  have hzU : p z ∈ U i₀ :=
+    hRU
+      (by
+        simpa only [Set.mem_compl_iff, Metric.mem_ball, dist_zero_right, not_lt] using hlarge.le)
+  rw [correctedGlue_eq s hdiff hzU, hμ₀ z hz, s.atInfinity (p z) hlarge]
+  ring
+
+private theorem SpecialPeriods.MuTorsor.Gluing.exists_corrected_gluing {ι : Type*} {p : ℍ → ℂ}
+    (hp : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω p) (hps : Function.Surjective p) {U : ι → Set ℂ}
+    (hU : ∀ i, IsOpen (U i)) (hcover : ∀ w, ∃ i, w ∈ U i) {μ : ι → ℍ → ℂ}
+    (hμ : ∀ i, ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (μ i) (p ⁻¹' U i)) {F : ℍ → ℂ}
+    (hF : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω F) {h : ι → ι → ℂ → ℂ}
+    (hh : ∀ i j, AnalyticOnNhd ℂ (h i j) (U i ∩ U j))
+    (hq : ∀ i j z, p z ∈ U i → p z ∈ U j → h i j (p z) = (μ i z - μ j z) / F z)
+    (hz : ∀ i j z, p z ∈ U i → p z ∈ U j → F z = 0 → μ i z = μ j z) (i₀ : ι) {R : ℝ} (hR : 0 < R)
+    (hRU : (Metric.ball (0 : ℂ) R)ᶜ ⊆ U i₀) :
+    ∃ s : HolomorphicCousin.NegativeOneCocycleSolution U h i₀ R,
+      ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (correctedGlue p U hcover μ F s) ∧
+        ∀ i,
+          Set.EqOn (correctedGlue p U hcover μ F s) (fun z => μ i z - F z * s.localPart i (p z))
+            (p ⁻¹' U i) := by
+  obtain ⟨s⟩ :=
+    HolomorphicCousin.exists_negativeOne_holomorphic_cocycle_solution hU hcover hh
+      (descended_quotient_cocycle hps hq) i₀ hR hRU
+  have hd := difference_eq_mul_quotient hq hz
+  exact ⟨s, correctedGlue_holomorphic hp hU hμ hF s hd, fun _ _ hi => correctedGlue_eq s hd hi⟩
+
+private def SpecialPeriods.MuTorsor.CuspRegular (f : ℍ → ℂ) : Prop :=
+  ∃ M : ℂ → ℂ,
+    AnalyticAt ℂ M 0 ∧ ∀ᶠ z in UpperHalfPlane.atImInfty, f z = M (SpecialPeriods.Triangle.cuspQ z)
+
+private theorem SpecialPeriods.MuTorsor.CuspRegular.sub {f g : ℍ → ℂ}
+    (hf : SpecialPeriods.MuTorsor.CuspRegular f) (hg : SpecialPeriods.MuTorsor.CuspRegular g) :
+    SpecialPeriods.MuTorsor.CuspRegular (f - g) := by
+  obtain ⟨M, hM, hfM⟩ := hf
+  obtain ⟨N, hN, hgN⟩ := hg
+  refine ⟨M - N, hM.sub hN, ?_⟩
+  filter_upwards [hfM, hgN] with z hfz hgz
+  simp only [Pi.sub_apply, hfz, hgz]
+
+private theorem
+    SpecialPeriods.MuTorsor.factor_cusp_germ {ν F H : ℍ → ℂ} {v : ℂ → ℂ} (hνc : CuspRegular ν)
+    (hv : AnalyticAt ℂ v 0) (hv0 : v 0 ≠ 0)
+    (hF :
+      ∀ᶠ z in UpperHalfPlane.atImInfty,
+        F z = (SpecialPeriods.Triangle.cuspQ z)⁻¹ * v (SpecialPeriods.Triangle.cuspQ z))
+    (hfac : ∀ z : ℍ, ν z = F z * H z) :
+    ∃ g : ℂ → ℂ,
+      AnalyticAt ℂ g 0 ∧
+        g 0 = 0 ∧ ∀ᶠ z in UpperHalfPlane.atImInfty, H z = g (SpecialPeriods.Triangle.cuspQ z) := by
+  obtain ⟨M, hM, hνM⟩ := hνc
+  refine ⟨fun q => q * M q / v q, (analyticAt_id.mul hM).div hv hv0, by simp, ?_⟩
+  have hvne : ∀ᶠ z in UpperHalfPlane.atImInfty, v (SpecialPeriods.Triangle.cuspQ z) ≠ 0 :=
+    (SpecialPeriods.Triangle.cuspQ_tendsto_atImInfty.mono_right nhdsWithin_le_nhds).eventually
+      (hv.continuousAt.eventually_ne hv0)
+  filter_upwards [hνM, hF, hvne] with z hνz hFz hvz
+  apply (eq_div_iff hvz).mpr
+  have he := hfac z
+  rw [hνz, hFz] at he
+  calc
+    H z * v (SpecialPeriods.Triangle.cuspQ z) = v (SpecialPeriods.Triangle.cuspQ z) * H z :=
+      mul_comm _ _
+    _ =
+        (SpecialPeriods.Triangle.cuspQ z * (SpecialPeriods.Triangle.cuspQ z)⁻¹) *
+          (v (SpecialPeriods.Triangle.cuspQ z) * H z) := by
+      rw [mul_inv_cancel₀ (SpecialPeriods.Triangle.cuspQ_ne_zero z), one_mul]
+    _ =
+        SpecialPeriods.Triangle.cuspQ z *
+          ((SpecialPeriods.Triangle.cuspQ z)⁻¹ * v (SpecialPeriods.Triangle.cuspQ z) * H z) := by
+      ring
+    _ = SpecialPeriods.Triangle.cuspQ z * M (SpecialPeriods.Triangle.cuspQ z) := by rw [← he]
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.correctedGlue_cuspRegular
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) {F : ℍ → ℂ}
+    {h : Cover.Index → Cover.Index → ℂ → ℂ} {R : ℝ} (hR : 0 < R)
+    (hRU : (Metric.ball (0 : ℂ) R)ᶜ ⊆ Cover.finitePatch π Cover.cuspIndex)
+    (s :
+      HolomorphicCousin.NegativeOneCocycleSolution (fun i => (Cover.finitePatch π i : Set ℂ)) h
+        Cover.cuspIndex R)
+    (hdiff :
+      ∀ i j z,
+        SpecialPeriods.BetaTorsor.finiteProjection π z ∈ Cover.finitePatch π i →
+          SpecialPeriods.BetaTorsor.finiteProjection π z ∈ Cover.finitePatch π j →
+            localSection hτ hτa i z - localSection hτ hτa j z =
+              F z * h i j (SpecialPeriods.BetaTorsor.finiteProjection π z))
+    (hFpole :
+      ∃ v : ℂ → ℂ,
+        AnalyticAt ℂ v 0 ∧
+          v 0 ≠ 0 ∧
+            ∀ᶠ z in UpperHalfPlane.atImInfty,
+              F z = (SpecialPeriods.Triangle.cuspQ z)⁻¹ * v (SpecialPeriods.Triangle.cuspQ z)) :
+    CuspRegular
+      (Gluing.correctedGlue (SpecialPeriods.BetaTorsor.finiteProjection π)
+        (fun i => (Cover.finitePatch π i : Set ℂ)) (Cover.exists_finitePatch π)
+        (localSection hτ hτa) F s) := by
+  obtain ⟨v, hv, _hv0, hFv⟩ := hFpole
+  have hS : AnalyticAt ℂ s.infinityPart 0 :=
+    s.infinity_analytic 0 (Metric.mem_ball_self (inv_pos.mpr hR))
+  refine
+    ⟨fun q => -v q * CuspCoordinates.tDivQ π q * s.infinityPart (CuspCoordinates.t π q),
+      CuspCoordinates.analyticAt_correction π hπ hv hS, ?_⟩
+  filter_upwards [hFv, CuspCoordinates.eventually_mem_horodisc SpecialPeriods.Triangle.width,
+    CuspCoordinates.eventually_lt_norm_finiteProjection π hπ R,
+    CuspCoordinates.t_cuspQ_eq_inv_finiteProjection π hπ] with z hFz hz hlarge ht
+  rw [Gluing.correctedGlue_cusp s hdiff hRU (fun z hz => localSection_cusp hτ hτa z hz) hz hlarge,
+    hFz, ← ht]
+  have hc :
+    -((SpecialPeriods.Triangle.cuspQ z)⁻¹ * v (SpecialPeriods.Triangle.cuspQ z)) *
+        CuspCoordinates.t π (SpecialPeriods.Triangle.cuspQ z) =
+      -v (SpecialPeriods.Triangle.cuspQ z) *
+        CuspCoordinates.tDivQ π (SpecialPeriods.Triangle.cuspQ z) := by
+    rw [CuspCoordinates.t_eq_mul_tDivQ π hπ]
+    field_simp [SpecialPeriods.Triangle.cuspQ_ne_zero z]
+  rw [hc]
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.exists_holomorphic_affine_cuspRegular
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (F : ℍ → ℂ)
+    (hF : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω F) (hFc : SpecialPeriods.MuGenerator.Homogeneous τ F)
+    (hFzero :
+      ∀ z,
+        F z = 0 ↔
+          SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterOne ∨
+            SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterTwo)
+    (hFpole :
+      ∃ v : ℂ → ℂ,
+        AnalyticAt ℂ v 0 ∧
+          v 0 ≠ 0 ∧
+            ∀ᶠ z in UpperHalfPlane.atImInfty,
+              F z = (SpecialPeriods.Triangle.cuspQ z)⁻¹ * v (SpecialPeriods.Triangle.cuspQ z)) :
+    ∃ μ : ℍ → ℂ,
+      ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω μ ∧
+        (∀ g z,
+            μ (SpecialPeriods.triangleGeometricRepresentation g z) =
+              (cocycle hτ hτa).fibreMap g z (μ z)) ∧
+          (∀ z, μ (SpecialPeriods.Triangle.generatorOneSL • z) = (1 - μ z) / (τ z : ℂ)) ∧
+            (∀ z, μ (SpecialPeriods.Triangle.generatorTwoSL • z) = 1 + μ z / (τ z : ℂ)) ∧
+              CuspRegular μ := by
+  let U : Cover.Index → Set ℂ := fun i => Cover.finitePatch π i
+  let h := descendedOverlap hτ hτa F π hπ
+  have hlocal :
+    ∀ i,
+      ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (localSection hτ hτa i)
+        (SpecialPeriods.BetaTorsor.finiteProjection π ⁻¹' U i) := by
+    intro i
+    change
+      ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (localSection hτ hτa i)
+        (SpecialPeriods.BetaTorsor.finiteProjection π ⁻¹' (Cover.finitePatch π i : Set ℂ))
+    rw [finiteProjection_preimage_patch π hπ]
+    exact localSection_holomorphic hτ hτa i
+  have hq :
+    ∀ i j z,
+      SpecialPeriods.BetaTorsor.finiteProjection π z ∈ U i →
+        SpecialPeriods.BetaTorsor.finiteProjection π z ∈ U j →
+          h i j (SpecialPeriods.BetaTorsor.finiteProjection π z) =
+            (localSection hτ hτa i z - localSection hτ hτa j z) / F z :=
+    descendedOverlap_projection hτ hτa F π hπ hFc
+  have hz :
+    ∀ i j z,
+      SpecialPeriods.BetaTorsor.finiteProjection π z ∈ U i →
+        SpecialPeriods.BetaTorsor.finiteProjection π z ∈ U j →
+          F z = 0 → localSection hτ hτa i z = localSection hτ hτa j z := by
+    intro i j z hi hj hzero
+    exact
+      localSection_eq_at_generator_zero hτ hτa F hFzero i j z
+        ((finiteProjection_mem_patch π hπ i z).mp hi)
+        ((finiteProjection_mem_patch π hπ j z).mp hj) hzero
+  have hd := Gluing.difference_eq_mul_quotient hq hz
+  obtain ⟨R, hR, hRU⟩ := Cover.finitePatch_cusp_contains_exterior π hπ
+  obtain ⟨s, hs, _⟩ :=
+    Gluing.exists_corrected_gluing (SpecialPeriods.BetaTorsor.finiteProjection_holomorphic π hπ)
+      (SpecialPeriods.BetaTorsor.finiteProjection_surjective π hπ)
+      (fun i => (Cover.finitePatch π i).isOpen) (Cover.exists_finitePatch π) hlocal hF
+      (descendedOverlap_analytic hτ hτa F hFzero π hπ hF hFc) hq hz Cover.cuspIndex hR hRU
+  let μ :=
+    Gluing.correctedGlue (SpecialPeriods.BetaTorsor.finiteProjection π) U
+      (Cover.exists_finitePatch π) (localSection hτ hτa) F s
+  have hlocalLaw :
+    ∀ i,
+      (cocycle hτ hτa).EquivariantOn (localSection hτ hτa i)
+        (SpecialPeriods.BetaTorsor.finiteProjection π ⁻¹' U i) := by
+    intro i
+    change
+      (cocycle hτ hτa).EquivariantOn (localSection hτ hτa i)
+        (SpecialPeriods.BetaTorsor.finiteProjection π ⁻¹' (Cover.finitePatch π i : Set ℂ))
+    rw [finiteProjection_preimage_patch π hπ]
+    exact localSection_equivariant hτ hτa i
+  have hμ :
+    ∀ g z,
+      μ (SpecialPeriods.triangleGeometricRepresentation g z) =
+        (cocycle hτ hτa).fibreMap g z (μ z) :=
+    Gluing.correctedGlue_affine_law s hd (cocycle hτ hτa)
+      (SpecialPeriods.BetaTorsor.finiteProjection_invariant π) hlocalLaw
+      (homogeneous_scale_law hτ hτa hFc)
+  refine ⟨μ, hs, hμ, ?_, ?_, ?_⟩
+  · intro z
+    simpa only [SpecialPeriods.triangleGeometricRepresentation_generator₁_apply,
+      cocycle_fibreMap_generator₁] using hμ SpecialPeriods.triangleGenerator₁ z
+  · intro z
+    simpa only [SpecialPeriods.triangleGeometricRepresentation_generator₂_apply,
+      cocycle_fibreMap_generator₂] using hμ SpecialPeriods.triangleGenerator₂ z
+  · exact correctedGlue_cuspRegular π hπ hτ hτa hR hRU s hd hFpole
+
+private theorem SpecialPeriods.MuTorsor.Division.quotient_invariant {τ : ℍ → ℍ} {ν F : ℍ → ℂ}
+    (hν₁ : ∀ z : ℍ, ν (SpecialPeriods.Triangle.generatorOneSL • z) = -ν z / (τ z : ℂ))
+    (hν₂ : ∀ z : ℍ, ν (SpecialPeriods.Triangle.generatorTwoSL • z) = ν z / (τ z : ℂ))
+    (hF₁ : ∀ z : ℍ, F (SpecialPeriods.Triangle.generatorOneSL • z) = -F z / (τ z : ℂ))
+    (hF₂ : ∀ z : ℍ, F (SpecialPeriods.Triangle.generatorTwoSL • z) = F z / (τ z : ℂ))
+    (g : SpecialPeriods.TriangleGroup) (z : ℍ) :
+    ν (SpecialPeriods.triangleGeometricRepresentation g z) /
+        F (SpecialPeriods.triangleGeometricRepresentation g z) =
+      ν z / F z := by
+  apply SpecialPeriods.MuGenerator.triangle_invariant_of_generators (fun w => ν w / F w) _ _ g z
+  · intro w
+    rw [hν₁, hF₁, div_div_div_cancel_right₀ (τ w).ne_zero, neg_div_neg_eq]
+  · intro w
+    rw [hν₂, hF₂, div_div_div_cancel_right₀ (τ w).ne_zero]
+
+private theorem SpecialPeriods.MuTorsor.Division.zero_invariant {τ : ℍ → ℍ} {ν : ℍ → ℂ}
+    (hν₁ : ∀ z : ℍ, ν (SpecialPeriods.Triangle.generatorOneSL • z) = -ν z / (τ z : ℂ))
+    (hν₂ : ∀ z : ℍ, ν (SpecialPeriods.Triangle.generatorTwoSL • z) = ν z / (τ z : ℂ))
+    (g : SpecialPeriods.TriangleGroup) (z : ℍ) :
+    ν (SpecialPeriods.triangleGeometricRepresentation g z) = 0 ↔ ν z = 0 := by
+  have h := quotient_invariant hν₁ hν₂ hν₁ hν₂ g z
+  have hz :
+    ν (SpecialPeriods.triangleGeometricRepresentation g z) /
+          ν (SpecialPeriods.triangleGeometricRepresentation g z) =
+        0 ↔
+      ν z / ν z = 0 := by rw [h]
+  simpa only [div_eq_zero_iff, or_self] using hz
+
+private theorem SpecialPeriods.MuTorsor.Division.zero_of_centerOneOrbit {τ : ℍ → ℍ} {ν : ℍ → ℂ}
+    (hν₁ : ∀ z : ℍ, ν (SpecialPeriods.Triangle.generatorOneSL • z) = -ν z / (τ z : ℂ))
+    (hν₂ : ∀ z : ℍ, ν (SpecialPeriods.Triangle.generatorTwoSL • z) = ν z / (τ z : ℂ)) {z : ℍ}
+    (hz : SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterOne) :
+    ν z = 0 := by
+  obtain ⟨g, hg⟩ :=
+    (SpecialPeriods.triangleOrbitProjection_eq_iff z SpecialPeriods.Triangle.centerOne).mp hz
+  rw [← hg]
+  exact
+    (zero_invariant hν₁ hν₂ g SpecialPeriods.Triangle.centerOne).mpr
+      (SpecialPeriods.MuGenerator.homogeneous_centerOne_eq_zero hν₁)
+
+private theorem SpecialPeriods.MuTorsor.Division.zero_of_centerTwoOrbit {τ : ℍ → ℍ} {ν : ℍ → ℂ}
+    (hν₁ : ∀ z : ℍ, ν (SpecialPeriods.Triangle.generatorOneSL • z) = -ν z / (τ z : ℂ))
+    (hν₂ : ∀ z : ℍ, ν (SpecialPeriods.Triangle.generatorTwoSL • z) = ν z / (τ z : ℂ)) {z : ℍ}
+    (hz : SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterTwo) :
+    ν z = 0 := by
+  obtain ⟨g, hg⟩ :=
+    (SpecialPeriods.triangleOrbitProjection_eq_iff z SpecialPeriods.Triangle.centerTwo).mp hz
+  rw [← hg]
+  exact
+    (zero_invariant hν₁ hν₂ g SpecialPeriods.Triangle.centerTwo).mpr
+      (SpecialPeriods.MuGenerator.homogeneous_centerTwo_eq_zero hν₂)
+
+private theorem SpecialPeriods.MuTorsor.Division.zero_of_ellipticOrbit {τ : ℍ → ℍ} {ν : ℍ → ℂ}
+    (hν₁ : ∀ z : ℍ, ν (SpecialPeriods.Triangle.generatorOneSL • z) = -ν z / (τ z : ℂ))
+    (hν₂ : ∀ z : ℍ, ν (SpecialPeriods.Triangle.generatorTwoSL • z) = ν z / (τ z : ℂ)) {z : ℍ}
+    (hz :
+      SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterOne ∨
+        SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterTwo) :
+    ν z = 0 :=
+  hz.elim (zero_of_centerOneOrbit hν₁ hν₂) (zero_of_centerTwoOrbit hν₁ hν₂)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.MuTorsor.Division.ellipticNeighborhood_projection_eq_iff
+    (j : Elliptic.Kind) (z : ℍ) (hz : z ∈ SpecialPeriods.Triangle.ellipticNeighborhood j) :
+    SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.Triangle.ellipticOrbitCenter j ↔
+      z = SpecialPeriods.Triangle.ellipticCenter j := by
+  constructor
+  · intro he
+    obtain ⟨g, hg⟩ :=
+      (SpecialPeriods.triangleOrbitProjection_eq_iff z
+            (SpecialPeriods.Triangle.ellipticCenter j)).mp
+        he
+    have hr : g ∈ SpecialPeriods.Triangle.ellipticStabilizer j :=
+      SpecialPeriods.Triangle.ellipticNeighborhood_return j g
+        ⟨z,
+          ⟨SpecialPeriods.Triangle.ellipticCenter j,
+            SpecialPeriods.Triangle.ellipticCenter_mem_neighborhood j, hg⟩,
+          hz⟩
+    have hfix :
+      SpecialPeriods.triangleGeometricRepresentation g
+          (SpecialPeriods.Triangle.ellipticCenter j) =
+        SpecialPeriods.Triangle.ellipticCenter j :=
+      hr
+    exact hg.symm.trans hfix
+  · rintro rfl
+    rfl
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.MuTorsor.Division.ellipticNeighborhood_projection_ne_centers
+    (j : Elliptic.Kind) (z : ℍ) (hz : z ∈ SpecialPeriods.Triangle.ellipticNeighborhood j)
+    (hne : z ≠ SpecialPeriods.Triangle.ellipticCenter j) :
+    SpecialPeriods.triangleOrbitProjection z ≠ SpecialPeriods.triangleOrbitCenterOne ∧
+      SpecialPeriods.triangleOrbitProjection z ≠ SpecialPeriods.triangleOrbitCenterTwo := by
+  have hself :
+    SpecialPeriods.triangleOrbitProjection z ≠ SpecialPeriods.Triangle.ellipticOrbitCenter j :=
+    fun h => hne ((ellipticNeighborhood_projection_eq_iff j z hz).mp h)
+  have hother := SpecialPeriods.Triangle.ellipticNeighborhood_avoids_other j z hz
+  cases j
+  · exact ⟨hself, hother⟩
+  · exact ⟨hother, hself⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private def SpecialPeriods.MuTorsor.Division.completedQuotient (ν F : ℍ → ℂ) (v : Elliptic.Kind → ℂ)
+    (z : ℍ) : ℂ := by
+  classical
+    exact
+    if SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterOne then
+      v .three
+    else
+      if SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterTwo then
+        v .four
+      else ν z / F z
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.MuTorsor.Division.completedQuotient_center (ν F : ℍ → ℂ)
+    (v : Elliptic.Kind → ℂ) (j : Elliptic.Kind) :
+    completedQuotient ν F v (SpecialPeriods.Triangle.ellipticCenter j) = v j := by
+  cases j
+  · simp only [SpecialPeriods.Triangle.ellipticCenter, completedQuotient,
+      SpecialPeriods.triangleOrbitCenterOne, ite_true]
+  · have hne :
+      SpecialPeriods.triangleOrbitProjection SpecialPeriods.Triangle.centerTwo ≠
+        SpecialPeriods.triangleOrbitCenterOne :=
+      SpecialPeriods.triangleOrbitCenterOne_ne_centerTwo.symm
+    simp only [SpecialPeriods.Triangle.ellipticCenter, completedQuotient, hne, ite_false,
+      SpecialPeriods.triangleOrbitCenterTwo, ite_true]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.MuTorsor.Division.completedQuotient_eq_div (ν F : ℍ → ℂ)
+    (v : Elliptic.Kind → ℂ) (z : ℍ)
+    (h₁ : SpecialPeriods.triangleOrbitProjection z ≠ SpecialPeriods.triangleOrbitCenterOne)
+    (h₂ : SpecialPeriods.triangleOrbitProjection z ≠ SpecialPeriods.triangleOrbitCenterTwo) :
+    completedQuotient ν F v z = ν z / F z := by simp only [completedQuotient, h₁, h₂, ite_false]
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.MuTorsor.Division.completedQuotient_eventuallyEq_germ {ν F : ℍ → ℂ}
+    (hFzero :
+      ∀ z : ℍ,
+        F z = 0 ↔
+          SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterOne ∨
+            SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterTwo)
+    (v : Elliptic.Kind → ℂ) (j : Elliptic.Kind) (h : ℂ → ℂ)
+    (hv : v j = h (SpecialPeriods.Triangle.ellipticCenter j : ℂ))
+    (hfactor :
+      (ν ∘ UpperHalfPlane.ofComplex) =ᶠ[𝓝 (SpecialPeriods.Triangle.ellipticCenter j : ℂ)] fun w =>
+        (F ∘ UpperHalfPlane.ofComplex) w * h w) :
+    completedQuotient ν F v =ᶠ[𝓝 (SpecialPeriods.Triangle.ellipticCenter j)] fun z => h (z : ℂ) :=
+  by
+  have he : ∀ᶠ z : ℍ in 𝓝 (SpecialPeriods.Triangle.ellipticCenter j), ν z = F z * h (z : ℂ) := by
+    simpa only [Function.comp_apply, UpperHalfPlane.ofComplex_apply] using
+      UpperHalfPlane.continuous_coe.continuousAt.eventually hfactor
+  filter_upwards [he, SpecialPeriods.Triangle.ellipticNeighborhood_mem_nhds j] with z hez hzn
+  by_cases hz : z = SpecialPeriods.Triangle.ellipticCenter j
+  · subst z
+    exact (completedQuotient_center ν F v j).trans hv
+  · obtain ⟨h₁, h₂⟩ := ellipticNeighborhood_projection_ne_centers j z hzn hz
+    have hFz : F z ≠ 0 := fun hzero => (hFzero z).mp hzero |>.elim h₁ h₂
+    rw [completedQuotient_eq_div ν F v z h₁ h₂, hez]
+    exact mul_div_cancel_left₀ _ hFz
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.MuTorsor.Division.completedQuotient_contMDiffAt_center {ν F : ℍ → ℂ}
+    (hFzero :
+      ∀ z : ℍ,
+        F z = 0 ↔
+          SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterOne ∨
+            SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterTwo)
+    (v : Elliptic.Kind → ℂ) (j : Elliptic.Kind) (h : ℂ → ℂ)
+    (hh : AnalyticAt ℂ h (SpecialPeriods.Triangle.ellipticCenter j : ℂ))
+    (hv : v j = h (SpecialPeriods.Triangle.ellipticCenter j : ℂ))
+    (hfactor :
+      (ν ∘ UpperHalfPlane.ofComplex) =ᶠ[𝓝 (SpecialPeriods.Triangle.ellipticCenter j : ℂ)] fun w =>
+        (F ∘ UpperHalfPlane.ofComplex) w * h w) :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (completedQuotient ν F v)
+      (SpecialPeriods.Triangle.ellipticCenter j) := by
+  exact
+    (hh.contDiffAt.contMDiffAt.comp _ (UpperHalfPlane.contMDiff_coe _)).congr_of_eventuallyEq
+      (completedQuotient_eventuallyEq_germ hFzero v j h hv hfactor)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem
+    SpecialPeriods.MuTorsor.Division.completedQuotient_contMDiffAt_of_ne_zero {ν F : ℍ → ℂ}
+    (hν : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω ν) (hF : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω F)
+    (hFzero :
+      ∀ z : ℍ,
+        F z = 0 ↔
+          SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterOne ∨
+            SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterTwo)
+    (v : Elliptic.Kind → ℂ) (z : ℍ) (hz : F z ≠ 0) :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (completedQuotient ν F v) z := by
+  apply ((hν z).div₀ (hF z) hz).congr_of_eventuallyEq
+  filter_upwards [(hF z).continuousAt.eventually_ne hz] with w hw
+  have hn :
+    ¬(SpecialPeriods.triangleOrbitProjection w = SpecialPeriods.triangleOrbitCenterOne ∨
+        SpecialPeriods.triangleOrbitProjection w = SpecialPeriods.triangleOrbitCenterTwo) :=
+    fun he => hw ((hFzero w).mpr he)
+  exact completedQuotient_eq_div ν F v w (fun h => hn (.inl h)) (fun h => hn (.inr h))
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction in
+private theorem SpecialPeriods.MuTorsor.Division.contMDiffAt_orbit {H : ℍ → ℂ}
+    (hH :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z : ℍ, H (SpecialPeriods.triangleGeometricRepresentation g z) = H z)
+    {a : ℍ} (ha : ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω H a) (g : SpecialPeriods.TriangleGroup) :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω H (SpecialPeriods.triangleGeometricRepresentation g a) := by
+  have hi :
+    SpecialPeriods.triangleGeometricRepresentation g⁻¹
+        (SpecialPeriods.triangleGeometricRepresentation g a) =
+      a := by
+    rw [map_inv]
+    exact (SpecialPeriods.triangleGeometricRepresentation g).symm_apply_apply a
+  have hh :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω H
+      (SpecialPeriods.triangleGeometricRepresentation g⁻¹
+        (SpecialPeriods.triangleGeometricRepresentation g a)) :=
+    hi.symm ▸ ha
+  apply
+    (hh.comp _
+        (SpecialPeriods.triangleGeometricRepresentation_holomorphic g⁻¹ _)).congr_of_eventuallyEq
+  filter_upwards with z
+  exact (hH g⁻¹ z).symm
+
+private theorem SpecialPeriods.MuTorsor.Division.completedQuotient_invariant {ν F : ℍ → ℂ}
+    (v : Elliptic.Kind → ℂ)
+    (hinv :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z : ℍ,
+          ν (SpecialPeriods.triangleGeometricRepresentation g z) /
+              F (SpecialPeriods.triangleGeometricRepresentation g z) =
+            ν z / F z)
+    (g : SpecialPeriods.TriangleGroup) (z : ℍ) :
+    completedQuotient ν F v (SpecialPeriods.triangleGeometricRepresentation g z) =
+      completedQuotient ν F v z := by
+  unfold completedQuotient
+  rw [SpecialPeriods.triangleOrbitProjection_smul g z, hinv g z]
+
+private theorem SpecialPeriods.MuTorsor.Division.completedQuotient_factorization {ν F : ℍ → ℂ}
+    (hFzero :
+      ∀ z : ℍ,
+        F z = 0 ↔
+          SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterOne ∨
+            SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterTwo)
+    (hνzero : ∀ z : ℍ, F z = 0 → ν z = 0) (v : Elliptic.Kind → ℂ) (z : ℍ) :
+    ν z = F z * completedQuotient ν F v z := by
+  by_cases hz : F z = 0
+  · rw [hz, hνzero z hz, MulZeroClass.zero_mul]
+  · have hn :
+      ¬(SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterOne ∨
+          SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterTwo) :=
+      fun he => hz ((hFzero z).mpr he)
+    rw [completedQuotient_eq_div ν F v z (fun h => hn (.inl h)) (fun h => hn (.inr h))]
+    exact (mul_div_cancel₀ (ν z) hz).symm.trans (by ring)
+
+private theorem SpecialPeriods.MuTorsor.Division.completedQuotient_holomorphic {ν F : ℍ → ℂ}
+    (hν : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω ν) (hF : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω F)
+    (hFzero :
+      ∀ z : ℍ,
+        F z = 0 ↔
+          SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterOne ∨
+            SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterTwo)
+    (v : Elliptic.Kind → ℂ)
+    (hinv :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z : ℍ,
+          completedQuotient ν F v (SpecialPeriods.triangleGeometricRepresentation g z) =
+            completedQuotient ν F v z)
+    (hcenter :
+      ∀ j : Elliptic.Kind,
+        ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (completedQuotient ν F v)
+          (SpecialPeriods.Triangle.ellipticCenter j)) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (completedQuotient ν F v) := by
+  intro z
+  by_cases hz : F z = 0
+  · rcases (hFzero z).mp hz with h₁ | h₂
+    · obtain ⟨g, hg⟩ :=
+        (SpecialPeriods.triangleOrbitProjection_eq_iff z SpecialPeriods.Triangle.centerOne).mp h₁
+      rw [← hg]
+      exact contMDiffAt_orbit hinv (hcenter .three) g
+    · obtain ⟨g, hg⟩ :=
+        (SpecialPeriods.triangleOrbitProjection_eq_iff z SpecialPeriods.Triangle.centerTwo).mp h₂
+      rw [← hg]
+      exact contMDiffAt_orbit hinv (hcenter .four) g
+  · exact completedQuotient_contMDiffAt_of_ne_zero hν hF hFzero v z hz
+
+private theorem SpecialPeriods.MuTorsor.Division.exists_holomorphic_invariant_factor {τ : ℍ → ℍ}
+    {ν F : ℍ → ℂ} (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (hτc : SpecialPeriods.TauCovariant τ)
+    (hν : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω ν)
+    (hν₁ : ∀ z : ℍ, ν (SpecialPeriods.Triangle.generatorOneSL • z) = -ν z / (τ z : ℂ))
+    (hν₂ : ∀ z : ℍ, ν (SpecialPeriods.Triangle.generatorTwoSL • z) = ν z / (τ z : ℂ))
+    (hF : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω F)
+    (hF₁ : ∀ z : ℍ, F (SpecialPeriods.Triangle.generatorOneSL • z) = -F z / (τ z : ℂ))
+    (hF₂ : ∀ z : ℍ, F (SpecialPeriods.Triangle.generatorTwoSL • z) = F z / (τ z : ℂ))
+    (hFzero :
+      ∀ z : ℍ,
+        F z = 0 ↔
+          SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterOne ∨
+            SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterTwo)
+    (hForder₁ :
+      analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (SpecialPeriods.Triangle.centerOne : ℂ) = 2)
+    (hForder₂ :
+      analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (SpecialPeriods.Triangle.centerTwo : ℂ) =
+        1) :
+    ∃ H : ℍ → ℂ,
+      ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω H ∧
+        (∀ g : SpecialPeriods.TriangleGroup,
+            ∀ z : ℍ, H (SpecialPeriods.triangleGeometricRepresentation g z) = H z) ∧
+          ∀ z : ℍ, ν z = F z * H z := by
+  obtain ⟨h₁, hh₁, he₁⟩ :=
+    SpecialPeriods.MuGenerator.exists_division_at_centerOne hτ hτc hν hν₁ hF hForder₁
+  obtain ⟨h₂, hh₂, he₂⟩ :=
+    SpecialPeriods.MuGenerator.exists_division_at_centerTwo hν hν₂ hF hForder₂
+  let v : Elliptic.Kind → ℂ
+    | .three => h₁ (SpecialPeriods.Triangle.centerOne : ℂ)
+    | .four => h₂ (SpecialPeriods.Triangle.centerTwo : ℂ)
+  have hinv := completedQuotient_invariant v (quotient_invariant hν₁ hν₂ hF₁ hF₂)
+  refine ⟨completedQuotient ν F v, ?_, hinv, ?_⟩
+  · apply completedQuotient_holomorphic hν hF hFzero v hinv
+    intro j
+    cases j
+    · exact completedQuotient_contMDiffAt_center hFzero v .three h₁ hh₁ rfl he₁
+    · exact completedQuotient_contMDiffAt_center hFzero v .four h₂ hh₂ rfl he₂
+  · apply completedQuotient_factorization hFzero
+    intro z hz
+    exact zero_of_ellipticOrbit hν₁ hν₂ ((hFzero z).mp hz)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.instIsManifold2 :
+    IsManifold 𝓘(ℂ) ω SpecialPeriods.TriangleOrbitSpace :=
+  SpecialPeriods.triangleOrbit_isManifold
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.MuTorsor.instIsManifold2 in
+private theorem SpecialPeriods.MuTorsor.instIsManifold3 :
+    IsManifold 𝓘(ℂ) ω SpecialPeriods.TriangleCompactifiedOrbitSpace :=
+  SpecialPeriods.triangleCompactified_isManifold
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.MuTorsor.instIsManifold2
+    SpecialPeriods.MuTorsor.instIsManifold3 in
+private def
+    SpecialPeriods.MuTorsor.compactExtension (f : SpecialPeriods.TriangleOrbitSpace → ℂ) (c : ℂ) :
+    SpecialPeriods.TriangleCompactifiedOrbitSpace → ℂ :=
+  OnePoint.rec c f
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.MuTorsor.instIsManifold2
+    SpecialPeriods.MuTorsor.instIsManifold3 in
+private theorem SpecialPeriods.MuTorsor.compactExtension_holomorphicAt_openInclusion
+    (f : SpecialPeriods.TriangleOrbitSpace → ℂ) (c : ℂ) (hf : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω f)
+    (q : SpecialPeriods.TriangleOrbitSpace) :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (compactExtension f c) (SpecialPeriods.triangleOpenInclusion q) := by
+  have hp := SpecialPeriods.triangleOpenInclusion_isLocalDiffeomorph q
+  have hcomp :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (compactExtension f c ∘ SpecialPeriods.triangleOpenInclusion) q :=
+    hf q
+  have h :=
+    hcomp.comp_of_eq hp.localInverse_contMDiffAt
+      (hp.localInverse_left_inv hp.localInverse_mem_target)
+  apply h.congr_of_eventuallyEq
+  filter_upwards [hp.localInverse_eventuallyEq_right] with x hx
+  change
+    compactExtension f c x =
+      compactExtension f c (SpecialPeriods.triangleOpenInclusion (hp.localInverse x))
+  rw [show SpecialPeriods.triangleOpenInclusion (hp.localInverse x) = x from hx]
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.MuTorsor.instIsManifold2
+    SpecialPeriods.MuTorsor.instIsManifold3 in
+private theorem SpecialPeriods.MuTorsor.compactExtension_eventuallyEq_cuspChart
+    (f : SpecialPeriods.TriangleOrbitSpace → ℂ) (g : ℂ → ℂ) (Y : ℝ)
+    (h :
+      ∀ q ∈ SpecialPeriods.Triangle.cuspImage Y,
+        f q =
+          g
+            (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl
+              (SpecialPeriods.triangleOpenInclusion q))) :
+    compactExtension f (g 0) =ᶠ[𝓝 SpecialPeriods.triangleCuspPoint]
+      g ∘ SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl := by
+  filter_upwards [SpecialPeriods.Triangle.cuspNeighborhood_mem_nhds Y] with x hx
+  induction x using OnePoint.rec with
+  |
+    infty =>
+    change
+      g 0 =
+        g
+          (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl
+            SpecialPeriods.triangleCuspPoint)
+    rw [SpecialPeriods.Triangle.cuspFullChart_cuspPoint]
+  | coe
+    q =>
+    change
+      f q =
+        g
+          (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl
+            (SpecialPeriods.triangleOpenInclusion q))
+    exact h q ((SpecialPeriods.Triangle.openInclusion_mem_cuspNeighborhood Y q).mp hx)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.MuTorsor.instIsManifold2
+    SpecialPeriods.MuTorsor.instIsManifold3 in
+private theorem SpecialPeriods.MuTorsor.compactExtension_holomorphicAt_cusp_of_cuspImage
+    (f : SpecialPeriods.TriangleOrbitSpace → ℂ) (g : ℂ → ℂ) (Y : ℝ) (hg : AnalyticAt ℂ g 0)
+    (h :
+      ∀ q ∈ SpecialPeriods.Triangle.cuspImage Y,
+        f q =
+          g
+            (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl
+              (SpecialPeriods.triangleOpenInclusion q))) :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (compactExtension f (g 0)) SpecialPeriods.triangleCuspPoint := by
+  have hc :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω
+      (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl)
+      SpecialPeriods.triangleCuspPoint :=
+    SpecialPeriods.triangleCompactified_cuspChart_holomorphic.contMDiffAt
+      (SpecialPeriods.Triangle.cuspNeighborhood_mem_nhds SpecialPeriods.Triangle.width)
+  have hgc :=
+    hg.contDiffAt.contMDiffAt.comp_of_eq hc
+      (SpecialPeriods.Triangle.cuspFullChart_cuspPoint SpecialPeriods.Triangle.width le_rfl)
+  exact hgc.congr_of_eventuallyEq (compactExtension_eventuallyEq_cuspChart f g Y h)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.MuTorsor.instIsManifold2
+    SpecialPeriods.MuTorsor.instIsManifold3 in
+private theorem SpecialPeriods.MuTorsor.compactExtension_holomorphic_of_cuspImage
+    (f : SpecialPeriods.TriangleOrbitSpace → ℂ) (g : ℂ → ℂ) (Y : ℝ) (hf : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω f)
+    (hg : AnalyticAt ℂ g 0)
+    (h :
+      ∀ q ∈ SpecialPeriods.Triangle.cuspImage Y,
+        f q =
+          g
+            (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl
+              (SpecialPeriods.triangleOpenInclusion q))) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (compactExtension f (g 0)) := by
+  intro x
+  induction x using OnePoint.rec with
+  | infty => exact compactExtension_holomorphicAt_cusp_of_cuspImage f g Y hg h
+  | coe q => exact compactExtension_holomorphicAt_openInclusion f (g 0) hf q
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] SpecialPeriods.MuTorsor.instIsManifold2
+    SpecialPeriods.MuTorsor.instIsManifold3 in
+private theorem
+    SpecialPeriods.MuTorsor.eq_const_of_cuspImage (f : SpecialPeriods.TriangleOrbitSpace → ℂ)
+    (g : ℂ → ℂ) (Y : ℝ) (hf : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω f) (hg : AnalyticAt ℂ g 0)
+    (h :
+      ∀ q ∈ SpecialPeriods.Triangle.cuspImage Y,
+        f q =
+          g
+            (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl
+              (SpecialPeriods.triangleOpenInclusion q))) :
+    ∀ q, f q = g 0 := by
+  let := SpecialPeriods.triangleCompactifiedOrbitSpace_compact
+  let := SpecialPeriods.triangleCompactifiedOrbitSpace_connected
+  have he := compactExtension_holomorphic_of_cuspImage f g Y hf hg h
+  intro q
+  exact
+    (he.mdifferentiable (by simp)).apply_eq_of_compactSpace
+      (SpecialPeriods.triangleOpenInclusion q) SpecialPeriods.triangleCuspPoint
+
+private theorem SpecialPeriods.MuTorsor.exists_cuspImage_eq_of_eventually_atImInfty
+    {f : SpecialPeriods.TriangleOrbitSpace → ℂ} {g : ℂ → ℂ}
+    (h :
+      ∀ᶠ z in UpperHalfPlane.atImInfty,
+        f (SpecialPeriods.triangleOrbitProjection z) = g (SpecialPeriods.Triangle.cuspQ z)) :
+    ∃ Y : ℝ,
+      SpecialPeriods.Triangle.width ≤ Y ∧
+        ∀ q ∈ SpecialPeriods.Triangle.cuspImage Y,
+          f q =
+            g
+              (SpecialPeriods.Triangle.cuspFullChart SpecialPeriods.Triangle.width le_rfl
+                (SpecialPeriods.triangleOpenInclusion q)) := by
+  obtain ⟨A, hA⟩ := (UpperHalfPlane.atImInfty_mem _).mp h
+  refine ⟨Max.max SpecialPeriods.Triangle.width A, le_max_left _ _, ?_⟩
+  intro q hq
+  obtain ⟨z, hz, rfl⟩ := (SpecialPeriods.Triangle.mem_cuspImage _ _).mp hq
+  have hzwidth : z ∈ SpecialPeriods.Triangle.horodisc SpecialPeriods.Triangle.width :=
+    (le_max_left _ _).trans_lt hz
+  rw [SpecialPeriods.Triangle.cuspFullChart_mk SpecialPeriods.Triangle.width le_rfl ⟨z, hzwidth⟩]
+  exact hA z ((le_max_right _ _).trans hz.le)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.eq_const_of_eventually_cusp
+    (f : SpecialPeriods.TriangleOrbitSpace → ℂ) (g : ℂ → ℂ) (hf : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω f)
+    (hg : AnalyticAt ℂ g 0)
+    (h :
+      ∀ᶠ z in UpperHalfPlane.atImInfty,
+        f (SpecialPeriods.triangleOrbitProjection z) = g (SpecialPeriods.Triangle.cuspQ z)) :
+    ∀ q, f q = g 0 := by
+  obtain ⟨Y, _, hY⟩ := exists_cuspImage_eq_of_eventually_atImInfty h
+  exact eq_const_of_cuspImage f g Y hf hg hY
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.eq_zero_of_eventually_cusp
+    (f : SpecialPeriods.TriangleOrbitSpace → ℂ) (g : ℂ → ℂ) (hf : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω f)
+    (hg : AnalyticAt ℂ g 0) (hg0 : g 0 = 0)
+    (h :
+      ∀ᶠ z in UpperHalfPlane.atImInfty,
+        f (SpecialPeriods.triangleOrbitProjection z) = g (SpecialPeriods.Triangle.cuspQ z)) :
+    f = 0 := by
+  funext q
+  exact (eq_const_of_eventually_cusp f g hf hg h q).trans hg0
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+private theorem SpecialPeriods.MuTorsor.descend_top_project {H : ℍ → ℂ}
+    (hInv :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z : ℍ, H (SpecialPeriods.triangleGeometricRepresentation g z) = H z)
+    (z : ℍ) : descend ⊤ H (SpecialPeriods.triangleOrbitProjection z) = H z := by
+  apply descend_project ⊤ H
+  · intro g w
+    rfl
+  · intro g w _
+    exact hInv g w
+  · trivial
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+private theorem
+    SpecialPeriods.MuTorsor.descend_top_holomorphic {H : ℍ → ℂ} (hH : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω H)
+    (hInv :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z : ℍ, H (SpecialPeriods.triangleGeometricRepresentation g z) = H z) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (descend ⊤ H) := by
+  intro q
+  apply descend_holomorphicAt ⊤ H
+  · intro g w
+    rfl
+  · intro g w _
+    exact hInv g w
+  · exact hH.contMDiffOn
+  · exact ⟨orbitRepresentative q, trivial, project_orbitRepresentative q⟩
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+private theorem SpecialPeriods.MuTorsor.invariant_eq_zero_of_eventually_cusp {H : ℍ → ℂ}
+    (hH : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω H)
+    (hInv :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z : ℍ, H (SpecialPeriods.triangleGeometricRepresentation g z) = H z)
+    {g : ℂ → ℂ} (hg : AnalyticAt ℂ g 0) (hg0 : g 0 = 0)
+    (he : ∀ᶠ z in UpperHalfPlane.atImInfty, H z = g (SpecialPeriods.Triangle.cuspQ z)) : H = 0 := by
+  have hd : descend ⊤ H = 0 := by
+    apply eq_zero_of_eventually_cusp (descend ⊤ H) g (descend_top_holomorphic hH hInv) hg hg0
+    filter_upwards [he] with z hz
+    exact (descend_top_project hInv z).trans hz
+  funext z
+  exact
+    (descend_top_project hInv z).symm.trans
+      (congrFun hd (SpecialPeriods.triangleOrbitProjection z))
+
+private theorem SpecialPeriods.MuTorsor.homogeneous_eq_zero_of_cuspRegular {τ : ℍ → ℍ} {ν F : ℍ → ℂ}
+    (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (hτc : SpecialPeriods.TauCovariant τ)
+    (hν : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω ν)
+    (hν₁ : ∀ z : ℍ, ν (SpecialPeriods.Triangle.generatorOneSL • z) = -ν z / (τ z : ℂ))
+    (hν₂ : ∀ z : ℍ, ν (SpecialPeriods.Triangle.generatorTwoSL • z) = ν z / (τ z : ℂ))
+    (hνc : CuspRegular ν) (hF : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω F)
+    (hF₁ : ∀ z : ℍ, F (SpecialPeriods.Triangle.generatorOneSL • z) = -F z / (τ z : ℂ))
+    (hF₂ : ∀ z : ℍ, F (SpecialPeriods.Triangle.generatorTwoSL • z) = F z / (τ z : ℂ))
+    (hFzero :
+      ∀ z : ℍ,
+        F z = 0 ↔
+          SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterOne ∨
+            SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterTwo)
+    (hForder₁ :
+      analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (SpecialPeriods.Triangle.centerOne : ℂ) = 2)
+    (hForder₂ :
+      analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (SpecialPeriods.Triangle.centerTwo : ℂ) = 1)
+    (hFcusp :
+      ∃ v : ℂ → ℂ,
+        AnalyticAt ℂ v 0 ∧
+          v 0 ≠ 0 ∧
+            ∀ᶠ z in UpperHalfPlane.atImInfty,
+              F z = (SpecialPeriods.Triangle.cuspQ z)⁻¹ * v (SpecialPeriods.Triangle.cuspQ z)) :
+    ν = 0 := by
+  obtain ⟨H, hH, hInv, hfactor⟩ :=
+    Division.exists_holomorphic_invariant_factor hτ hτc hν hν₁ hν₂ hF hF₁ hF₂ hFzero hForder₁
+      hForder₂
+  obtain ⟨v, hv, hv0, hFv⟩ := hFcusp
+  obtain ⟨g, hg, hg0, hHg⟩ := factor_cusp_germ hνc hv hv0 hFv hfactor
+  have hH0 : H = 0 := invariant_eq_zero_of_eventually_cusp hH hInv hg hg0 hHg
+  funext z
+  calc
+    ν z = F z * H z := hfactor z
+    _ = 0 := by simp only [hH0, Pi.zero_apply, MulZeroClass.mul_zero]
+
+private theorem SpecialPeriods.MuTorsor.affine_sub_homogeneous {τ : ℍ → ℍ} {μ μ' : ℍ → ℂ}
+    (hμ₁ : ∀ z : ℍ, μ (SpecialPeriods.Triangle.generatorOneSL • z) = (1 - μ z) / (τ z : ℂ))
+    (hμ₂ : ∀ z : ℍ, μ (SpecialPeriods.Triangle.generatorTwoSL • z) = 1 + μ z / (τ z : ℂ))
+    (hμ'₁ : ∀ z : ℍ, μ' (SpecialPeriods.Triangle.generatorOneSL • z) = (1 - μ' z) / (τ z : ℂ))
+    (hμ'₂ : ∀ z : ℍ, μ' (SpecialPeriods.Triangle.generatorTwoSL • z) = 1 + μ' z / (τ z : ℂ)) :
+    (∀ z : ℍ, (μ - μ') (SpecialPeriods.Triangle.generatorOneSL • z) = -(μ - μ') z / (τ z : ℂ)) ∧
+      (∀ z : ℍ, (μ - μ') (SpecialPeriods.Triangle.generatorTwoSL • z) = (μ - μ') z / (τ z : ℂ)) :=
+  by
+  constructor
+  · intro z
+    simp only [Pi.sub_apply, hμ₁ z, hμ'₁ z]
+    ring
+  · intro z
+    simp only [Pi.sub_apply, hμ₂ z, hμ'₂ z]
+    ring
+
+private theorem SpecialPeriods.MuTorsor.affine_eq_of_cuspRegular {τ : ℍ → ℍ} {μ μ' F : ℍ → ℂ}
+    (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (hτc : SpecialPeriods.TauCovariant τ)
+    (hμ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω μ) (hμ' : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω μ')
+    (hμ₁ : ∀ z : ℍ, μ (SpecialPeriods.Triangle.generatorOneSL • z) = (1 - μ z) / (τ z : ℂ))
+    (hμ₂ : ∀ z : ℍ, μ (SpecialPeriods.Triangle.generatorTwoSL • z) = 1 + μ z / (τ z : ℂ))
+    (hμ'₁ : ∀ z : ℍ, μ' (SpecialPeriods.Triangle.generatorOneSL • z) = (1 - μ' z) / (τ z : ℂ))
+    (hμ'₂ : ∀ z : ℍ, μ' (SpecialPeriods.Triangle.generatorTwoSL • z) = 1 + μ' z / (τ z : ℂ))
+    (hμc : CuspRegular μ) (hμ'c : CuspRegular μ') (hF : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω F)
+    (hF₁ : ∀ z : ℍ, F (SpecialPeriods.Triangle.generatorOneSL • z) = -F z / (τ z : ℂ))
+    (hF₂ : ∀ z : ℍ, F (SpecialPeriods.Triangle.generatorTwoSL • z) = F z / (τ z : ℂ))
+    (hFzero :
+      ∀ z : ℍ,
+        F z = 0 ↔
+          SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterOne ∨
+            SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterTwo)
+    (hForder₁ :
+      analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (SpecialPeriods.Triangle.centerOne : ℂ) = 2)
+    (hForder₂ :
+      analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (SpecialPeriods.Triangle.centerTwo : ℂ) = 1)
+    (hFcusp :
+      ∃ v : ℂ → ℂ,
+        AnalyticAt ℂ v 0 ∧
+          v 0 ≠ 0 ∧
+            ∀ᶠ z in UpperHalfPlane.atImInfty,
+              F z = (SpecialPeriods.Triangle.cuspQ z)⁻¹ * v (SpecialPeriods.Triangle.cuspQ z)) :
+    μ = μ' := by
+  obtain ⟨hν₁, hν₂⟩ := affine_sub_homogeneous hμ₁ hμ₂ hμ'₁ hμ'₂
+  exact
+    sub_eq_zero.mp
+      (homogeneous_eq_zero_of_cuspRegular hτ hτc (hμ.sub hμ') hν₁ hν₂ (hμc.sub hμ'c) hF hF₁ hF₂
+        hFzero hForder₁ hForder₂ hFcusp)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private structure SpecialPeriods.MuTorsor.IsSolution (τ : ℍ → ℍ) (μ : ℍ → ℂ) : Prop where
+  holomorphic : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω μ
+  generatorOne : ∀ z : ℍ, μ (SpecialPeriods.Triangle.generatorOneSL • z) = (1 - μ z) / (τ z : ℂ)
+  generatorTwo : ∀ z : ℍ, μ (SpecialPeriods.Triangle.generatorTwoSL • z) = 1 + μ z / (τ z : ℂ)
+  cuspRegular : CuspRegular μ
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.exists_unique_solution_from_generator
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (F : ℍ → ℂ)
+    (hF : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω F) (hFc : SpecialPeriods.MuGenerator.Homogeneous τ F)
+    (hFzero :
+      ∀ z : ℍ,
+        F z = 0 ↔
+          SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterOne ∨
+            SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterTwo)
+    (hForder₁ :
+      analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (SpecialPeriods.Triangle.centerOne : ℂ) = 2)
+    (hForder₂ :
+      analyticOrderAt (F ∘ UpperHalfPlane.ofComplex) (SpecialPeriods.Triangle.centerTwo : ℂ) = 1)
+    (hFcusp :
+      ∃ v : ℂ → ℂ,
+        AnalyticAt ℂ v 0 ∧
+          v 0 ≠ 0 ∧
+            ∀ᶠ z in UpperHalfPlane.atImInfty,
+              F z = (SpecialPeriods.Triangle.cuspQ z)⁻¹ * v (SpecialPeriods.Triangle.cuspQ z)) :
+    ∃! μ : ℍ → ℂ, IsSolution τ μ := by
+  obtain ⟨μ, hμ, _, hμ₁, hμ₂, hμc⟩ :=
+    exists_holomorphic_affine_cuspRegular π hπ hτ hτa F hF hFc hFzero hFcusp
+  refine ⟨μ, ⟨hμ, hμ₁, hμ₂, hμc⟩, ?_⟩
+  intro μ' hμ'
+  exact
+    affine_eq_of_cuspRegular hτa hτ hμ'.holomorphic hμ hμ'.generatorOne hμ'.generatorTwo hμ₁ hμ₂
+      hμ'.cuspRegular hμc hF hFc.1 hFc.2 hFzero hForder₁ hForder₂ hFcusp
+
+private theorem SpecialPeriods.MuGenerator.E₆_cuspFunction_zero :
+    UpperHalfPlane.cuspFunction 1 ModularForm.E₆ 0 = 1 := by
+  have h :=
+    EisensteinSeries.E_qExpansion_coeff_zero (show 3 ≤ 6 by decide) (show Even 6 by decide)
+  simpa [UpperHalfPlane.qExpansion_coeff] using h
+
+private def SpecialPeriods.MuGenerator.cuspModularParameter (u : ℂ → ℂ) (t : ℂ) : ℂ :=
+  t * u t
+
+@[simp]
+private theorem SpecialPeriods.MuGenerator.cuspModularParameter_zero (u : ℂ → ℂ) :
+    cuspModularParameter u 0 = 0 := by simp [cuspModularParameter]
+
+private theorem SpecialPeriods.MuGenerator.cuspModularParameter_analyticAt {u : ℂ → ℂ}
+    (hu : AnalyticAt ℂ u 0) : AnalyticAt ℂ (cuspModularParameter u) 0 :=
+  analyticAt_id.mul hu
+
+private def SpecialPeriods.MuGenerator.cuspEisensteinFour (u : ℂ → ℂ) (t : ℂ) : ℂ :=
+  UpperHalfPlane.cuspFunction 1 ModularForm.E₄ (cuspModularParameter u t)
+
+private def SpecialPeriods.MuGenerator.cuspEisensteinSix (u : ℂ → ℂ) (t : ℂ) : ℂ :=
+  UpperHalfPlane.cuspFunction 1 ModularForm.E₆ (cuspModularParameter u t)
+
+private def SpecialPeriods.MuGenerator.cuspDiscriminantUnit (u : ℂ → ℂ) (t : ℂ) : ℂ :=
+  u t * SpecialPeriods.discriminantUnit (cuspModularParameter u t)
+
+@[simp]
+private theorem SpecialPeriods.MuGenerator.cuspEisensteinFour_zero (u : ℂ → ℂ) :
+    cuspEisensteinFour u 0 = 1 := by
+  simp [cuspEisensteinFour, SpecialPeriods.E₄_cuspFunction_zero]
+
+@[simp]
+private theorem SpecialPeriods.MuGenerator.cuspEisensteinSix_zero (u : ℂ → ℂ) :
+    cuspEisensteinSix u 0 = 1 := by simp [cuspEisensteinSix, E₆_cuspFunction_zero]
+
+@[simp]
+private theorem SpecialPeriods.MuGenerator.cuspDiscriminantUnit_zero (u : ℂ → ℂ) :
+    cuspDiscriminantUnit u 0 = u 0 := by simp [cuspDiscriminantUnit]
+
+private theorem SpecialPeriods.MuGenerator.cuspEisensteinFour_analyticAt {u : ℂ → ℂ}
+    (hu : AnalyticAt ℂ u 0) : AnalyticAt ℂ (cuspEisensteinFour u) 0 := by
+  have h :
+    AnalyticAt ℂ (UpperHalfPlane.cuspFunction 1 ModularForm.E₄) (cuspModularParameter u 0) := by
+    rw [cuspModularParameter_zero]
+    exact
+      ModularFormClass.analyticAt_cuspFunction_zero ModularForm.E₄ zero_lt_one
+        one_mem_strictPeriods_SL
+  exact h.comp (cuspModularParameter_analyticAt hu)
+
+private theorem SpecialPeriods.MuGenerator.cuspEisensteinSix_analyticAt {u : ℂ → ℂ}
+    (hu : AnalyticAt ℂ u 0) : AnalyticAt ℂ (cuspEisensteinSix u) 0 := by
+  have h :
+    AnalyticAt ℂ (UpperHalfPlane.cuspFunction 1 ModularForm.E₆) (cuspModularParameter u 0) := by
+    rw [cuspModularParameter_zero]
+    exact
+      ModularFormClass.analyticAt_cuspFunction_zero ModularForm.E₆ zero_lt_one
+        one_mem_strictPeriods_SL
+  exact h.comp (cuspModularParameter_analyticAt hu)
+
+private theorem SpecialPeriods.MuGenerator.cuspDiscriminantUnit_analyticAt {u : ℂ → ℂ}
+    (hu : AnalyticAt ℂ u 0) : AnalyticAt ℂ (cuspDiscriminantUnit u) 0 := by
+  have h : AnalyticAt ℂ SpecialPeriods.discriminantUnit (cuspModularParameter u 0) := by
+    rw [cuspModularParameter_zero]
+    exact SpecialPeriods.discriminantUnit_analyticAt_zero
+  exact hu.mul (h.comp (cuspModularParameter_analyticAt hu))
+
+private def SpecialPeriods.MuGenerator.cuspGeneratorUnit (u b : ℂ → ℂ) (t : ℂ) : ℂ :=
+  cuspEisensteinFour u t ^ 2 * b t / cuspDiscriminantUnit u t
+
+@[simp]
+private theorem SpecialPeriods.MuGenerator.cuspGeneratorUnit_zero (u b : ℂ → ℂ) :
+    cuspGeneratorUnit u b 0 = b 0 / u 0 := by simp [cuspGeneratorUnit]
+
+private theorem SpecialPeriods.MuGenerator.cuspGeneratorUnit_analyticAt {u b : ℂ → ℂ}
+    (hu : AnalyticAt ℂ u 0) (hb : AnalyticAt ℂ b 0) (hu0 : u 0 ≠ 0) :
+    AnalyticAt ℂ (cuspGeneratorUnit u b) 0 :=
+  ((cuspEisensteinFour_analyticAt hu).pow 2 |>.mul hb).div (cuspDiscriminantUnit_analyticAt hu)
+    (by simpa only [cuspDiscriminantUnit_zero] using hu0)
+
+private theorem
+    SpecialPeriods.MuGenerator.cuspGeneratorUnit_zero_ne_zero {u b : ℂ → ℂ} (hu0 : u 0 ≠ 0)
+    (hb0 : b 0 ≠ 0) : cuspGeneratorUnit u b 0 ≠ 0 := by
+  rw [cuspGeneratorUnit_zero]
+  exact div_ne_zero hb0 hu0
+
+private theorem SpecialPeriods.MuGenerator.Root.square_eq_cuspEisensteinSix {τ : ℍ → ℍ}
+    (r : SpecialPeriods.MuGenerator.Root τ) (u : ℂ → ℂ) (z : ℍ)
+    (hq :
+      Function.Periodic.qParam 1 (τ z) =
+        SpecialPeriods.Triangle.cuspQ z * u (SpecialPeriods.Triangle.cuspQ z)) :
+    r z ^ 2 = SpecialPeriods.MuGenerator.cuspEisensteinSix u (SpecialPeriods.Triangle.cuspQ z) := by
+  rw [r.square z, ←
+    SlashInvariantFormClass.eq_cuspFunction ModularForm.E₆ (τ z) one_mem_strictPeriods_SL
+      one_ne_zero,
+    hq]
+  rfl
+
+private theorem SpecialPeriods.MuGenerator.Root.generator_eq_inv_q_mul_unit {τ : ℍ → ℍ}
+    (r : SpecialPeriods.MuGenerator.Root τ) (u b : ℂ → ℂ) (z : ℍ)
+    (hq :
+      Function.Periodic.qParam 1 (τ z) =
+        SpecialPeriods.Triangle.cuspQ z * u (SpecialPeriods.Triangle.cuspQ z))
+    (hr : r z = b (SpecialPeriods.Triangle.cuspQ z)) :
+    r.generator z =
+      (SpecialPeriods.Triangle.cuspQ z)⁻¹ *
+        SpecialPeriods.MuGenerator.cuspGeneratorUnit u b (SpecialPeriods.Triangle.cuspQ z) := by
+  have hE :
+    ModularForm.E₄ (τ z) =
+      SpecialPeriods.MuGenerator.cuspEisensteinFour u (SpecialPeriods.Triangle.cuspQ z) := by
+    rw [←
+      SlashInvariantFormClass.eq_cuspFunction ModularForm.E₄ (τ z) one_mem_strictPeriods_SL
+        one_ne_zero,
+      hq]
+    rfl
+  have hD :
+    ModularForm.discriminant (τ z) =
+      SpecialPeriods.Triangle.cuspQ z *
+        SpecialPeriods.MuGenerator.cuspDiscriminantUnit u (SpecialPeriods.Triangle.cuspQ z) := by
+    have h := ModularForm.discriminant_eq_q_prod (τ z)
+    change
+      ModularForm.discriminant (τ z) =
+        Function.Periodic.qParam 1 (τ z) *
+          SpecialPeriods.discriminantUnit (Function.Periodic.qParam 1 (τ z)) at h
+    rw [h, hq, SpecialPeriods.MuGenerator.cuspDiscriminantUnit,
+      SpecialPeriods.MuGenerator.cuspModularParameter]
+    ring
+  rw [generator, hE, hr, hD, SpecialPeriods.MuGenerator.cuspGeneratorUnit]
+  simp only [div_eq_mul_inv, mul_inv_rev]
+  ring
+
+private theorem SpecialPeriods.MuGenerator.exists_analytic_sqrt_germ_one {h : ℂ → ℂ}
+    (hh : AnalyticAt ℂ h 0) (h0 : h 0 = 1) :
+    ∃ b : ℂ → ℂ, AnalyticAt ℂ b 0 ∧ b 0 = 1 ∧ ∀ᶠ t in 𝓝 0, b t ^ 2 = h t := by
+  obtain ⟨r, hr, hr0, hrpow⟩ :=
+    SpecialPeriods.exists_analytic_unit_root hh (by simp [h0]) (by norm_num : 0 < (2 : ℕ))
+  have hr02 : r 0 ^ 2 = 1 := by simpa only [h0] using hrpow.self_of_nhds
+  refine ⟨fun t => r t / r 0, hr.div analyticAt_const hr0, div_self hr0, ?_⟩
+  filter_upwards [hrpow] with t ht
+  simp only [div_pow, hr02, div_one, ht]
+
+private theorem SpecialPeriods.MuGenerator.exists_analytic_sqrt_ball_one {h : ℂ → ℂ}
+    (hh : AnalyticAt ℂ h 0) (h0 : h 0 = 1) :
+    ∃ ε > 0,
+      ∃ b : ℂ → ℂ,
+        AnalyticOnNhd ℂ b (Metric.ball 0 ε) ∧
+          b 0 = 1 ∧
+            (∀ t ∈ Metric.ball 0 ε, b t ≠ 0) ∧ Set.EqOn (fun t => b t ^ 2) h (Metric.ball 0 ε) := by
+  obtain ⟨b, hb, hb0, hbpow⟩ := exists_analytic_sqrt_germ_one hh h0
+  have hbne : ∀ᶠ t in 𝓝 0, b t ≠ 0 := hb.continuousAt.eventually_ne (by simp [hb0])
+  obtain ⟨ε, hε, hball⟩ := Metric.mem_nhds_iff.mp (hb.eventually_analyticAt.and (hbne.and hbpow))
+  refine ⟨ε, hε, b, ?_, hb0, ?_, ?_⟩
+  · exact fun t ht => (hball ht).1
+  · exact fun t ht => (hball ht).2.1
+  · exact fun t ht => (hball ht).2.2
+
+private theorem SpecialPeriods.MuGenerator.cuspHorodisc_isPreconnected (Y : ℝ) (hY : 0 ≤ Y) :
+    IsPreconnected (SpecialPeriods.Triangle.horodisc Y : Set ℍ) := by
+  apply UpperHalfPlane.isOpenEmbedding_coe.toIsEmbedding.toIsInducing.isPreconnected_image.mp
+  have he :
+    (UpperHalfPlane.coe '' (SpecialPeriods.Triangle.horodisc Y : Set ℍ)) = {w : ℂ | Y < w.im} := by
+    ext w
+    constructor
+    · rintro ⟨z, hz, rfl⟩
+      exact hz
+    · intro hw
+      exact ⟨⟨w, hY.trans_lt hw⟩, hw, rfl⟩
+  rw [he]
+  exact (convex_halfSpace_im_gt Y).isPreconnected
+
+private theorem SpecialPeriods.MuGenerator.Root.exists_cusp_root_unit {τ : ℍ → ℍ}
+    (r : SpecialPeriods.MuGenerator.Root τ) {u : ℂ → ℂ} (hu : AnalyticAt ℂ u 0)
+    (hq :
+      ∀ᶠ z in UpperHalfPlane.atImInfty,
+        Function.Periodic.qParam 1 (τ z) =
+          SpecialPeriods.Triangle.cuspQ z * u (SpecialPeriods.Triangle.cuspQ z)) :
+    ∃ b : ℂ → ℂ,
+      AnalyticAt ℂ b 0 ∧
+        (b 0 = 1 ∨ b 0 = -1) ∧
+          ∀ᶠ z in UpperHalfPlane.atImInfty, r z = b (SpecialPeriods.Triangle.cuspQ z) := by
+  obtain ⟨R, hR, b, hb, hb0, hbne, hbsq⟩ :=
+    SpecialPeriods.MuGenerator.exists_analytic_sqrt_ball_one
+      (SpecialPeriods.MuGenerator.cuspEisensteinSix_analyticAt hu)
+      (SpecialPeriods.MuGenerator.cuspEisensteinSix_zero u)
+  have hsmall :
+    ∀ᶠ z in UpperHalfPlane.atImInfty, SpecialPeriods.Triangle.cuspQ z ∈ Metric.ball 0 R :=
+    (UpperHalfPlane.qParam_tendsto_atImInfty SpecialPeriods.Triangle.width_pos).eventually
+      (Metric.ball_mem_nhds 0 hR)
+  obtain ⟨A, hA⟩ := (UpperHalfPlane.atImInfty_mem _).mp (hq.and hsmall)
+  let Y := Max.max A SpecialPeriods.Triangle.width
+  have hY : 0 ≤ Y := SpecialPeriods.Triangle.width_pos.le.trans (le_max_right _ _)
+  have hhigh :
+    ∀ z ∈ SpecialPeriods.Triangle.horodisc Y,
+      Function.Periodic.qParam 1 (τ z) =
+          SpecialPeriods.Triangle.cuspQ z * u (SpecialPeriods.Triangle.cuspQ z) ∧
+        SpecialPeriods.Triangle.cuspQ z ∈ Metric.ball 0 R := by
+    intro z hz
+    change Y < z.im at hz
+    exact hA z ((le_max_left _ _).trans hz.le)
+  have hcont :
+    ContinuousOn (b ∘ SpecialPeriods.Triangle.cuspQ)
+      (SpecialPeriods.Triangle.horodisc Y : Set ℍ) :=
+    hb.continuousOn.comp SpecialPeriods.Triangle.cuspQ_continuous.continuousOn
+      (fun z hz => (hhigh z hz).2)
+  have hsq :
+    Set.EqOn ((r : ℍ → ℂ) ^ 2) ((b ∘ SpecialPeriods.Triangle.cuspQ) ^ 2)
+      (SpecialPeriods.Triangle.horodisc Y : Set ℍ) := by
+    intro z hz
+    change r z ^ 2 = b (SpecialPeriods.Triangle.cuspQ z) ^ 2
+    exact (r.square_eq_cuspEisensteinSix u z (hhigh z hz).1).trans (hbsq (hhigh z hz).2).symm
+  have hne :
+    ∀ {z : ℍ},
+      z ∈ SpecialPeriods.Triangle.horodisc Y → (b ∘ SpecialPeriods.Triangle.cuspQ) z ≠ 0 :=
+    fun {z} hz => hbne _ (hhigh z hz).2
+  have hYe : ∀ᶠ z in UpperHalfPlane.atImInfty, z ∈ SpecialPeriods.Triangle.horodisc Y := by
+    apply (UpperHalfPlane.atImInfty_mem _).mpr
+    refine ⟨Y + 1, fun z hz => ?_⟩
+    change Y < z.im
+    linarith
+  have hbAt : AnalyticAt ℂ b 0 := hb 0 (Metric.mem_ball_self hR)
+  rcases
+    (SpecialPeriods.MuGenerator.cuspHorodisc_isPreconnected Y hY).eq_or_eq_neg_of_sq_eq
+      r.holomorphic.continuous.continuousOn hcont hsq hne with
+    h | h
+  · exact ⟨b, hbAt, Or.inl hb0, hYe.mono fun z hz => h hz⟩
+  · refine ⟨-b, hbAt.neg, Or.inr ?_, ?_⟩
+    · simp only [Pi.neg_apply, hb0]
+    · filter_upwards [hYe] with z hz
+      simpa only [Pi.neg_apply, Function.comp_apply] using h hz
+
+private theorem SpecialPeriods.MuGenerator.Root.exists_cusp_unit {τ : ℍ → ℍ}
+    (r : SpecialPeriods.MuGenerator.Root τ) {u : ℂ → ℂ} (hu : AnalyticAt ℂ u 0) (hu0 : u 0 ≠ 0)
+    (hq :
+      ∀ᶠ z in UpperHalfPlane.atImInfty,
+        Function.Periodic.qParam 1 (τ z) =
+          SpecialPeriods.Triangle.cuspQ z * u (SpecialPeriods.Triangle.cuspQ z)) :
+    ∃ v : ℂ → ℂ,
+      AnalyticAt ℂ v 0 ∧
+        v 0 ≠ 0 ∧
+          ∀ᶠ z in UpperHalfPlane.atImInfty,
+            r.generator z =
+              (SpecialPeriods.Triangle.cuspQ z)⁻¹ * v (SpecialPeriods.Triangle.cuspQ z) := by
+  obtain ⟨b, hb, hb0, hrb⟩ := r.exists_cusp_root_unit hu hq
+  have hbne : b 0 ≠ 0 := by rcases hb0 with h | h <;> simp [h]
+  refine
+    ⟨SpecialPeriods.MuGenerator.cuspGeneratorUnit u b,
+      SpecialPeriods.MuGenerator.cuspGeneratorUnit_analyticAt hu hb hu0,
+      SpecialPeriods.MuGenerator.cuspGeneratorUnit_zero_ne_zero hu0 hbne, ?_⟩
+  filter_upwards [hq, hrb] with z hqz hrz
+  exact r.generator_eq_inv_q_mul_unit u b z hqz hrz
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.generator_zero_iff_orbits
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere))
+    {τ : ℍ → ℍ}
+    (hJ :
+      ∀ z, SpecialPeriods.modularJ (τ z) = 1728 * SpecialPeriods.BetaTorsor.finiteProjection π z)
+    (r : SpecialPeriods.MuGenerator.Root τ) (z : ℍ) :
+    r.generator z = 0 ↔
+      SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterOne ∨
+        SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitCenterTwo := by
+  rw [r.generator_eq_zero_iff_normalized_source hJ,
+    SourceOrders.finiteProjection_eq_zero_iff π hπ h₀,
+    SourceOrders.finiteProjection_eq_one_iff π hπ h₁]
+
+private theorem SpecialPeriods.MuTorsor.CuspRegular.bounded {f : ℍ → ℂ}
+    (hf : SpecialPeriods.MuTorsor.CuspRegular f) : UpperHalfPlane.IsBoundedAtImInfty f := by
+  obtain ⟨M, hM, he⟩ := hf
+  have he' : f =ᶠ[UpperHalfPlane.atImInfty] fun z => M (SpecialPeriods.Triangle.cuspQ z) := he
+  have ht : Filter.Tendsto f UpperHalfPlane.atImInfty (𝓝 (M 0)) :=
+    (hM.continuousAt.tendsto.comp
+          (SpecialPeriods.Triangle.cuspQ_tendsto_atImInfty.mono_right nhdsWithin_le_nhds)).congr'
+      he'.symm
+  exact ht.isBigO_one ℝ
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.MuTorsor.exists_unique_solution
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (h₀ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+        ((0 : ℂ) : RiemannSphere))
+    (h₁ :
+      π (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+        ((1 : ℂ) : RiemannSphere))
+    {τ : ℍ → ℍ} (hτ : SpecialPeriods.TauCovariant τ) (hτa : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ)
+    (hJ :
+      ∀ z, SpecialPeriods.modularJ (τ z) = 1728 * SpecialPeriods.BetaTorsor.finiteProjection π z)
+    {u : ℂ → ℂ} (hu : AnalyticAt ℂ u 0) (hu0 : u 0 ≠ 0)
+    (hq :
+      ∀ᶠ z in UpperHalfPlane.atImInfty,
+        Function.Periodic.qParam 1 (τ z) =
+          SpecialPeriods.Triangle.cuspQ z * u (SpecialPeriods.Triangle.cuspQ z)) :
+    ∃! μ : ℍ → ℂ, IsSolution τ μ := by
+  have hJ' : ∀ z, SpecialPeriods.modularJ (τ z) = SourceOrders.sourceJ π z := hJ
+  obtain ⟨F, ⟨r, rfl⟩, hF, hFc, _, hF₁, hF₂⟩ :=
+    SpecialPeriods.MuGenerator.exists_homogeneous_generator_of_modular_equation hτa hτ hJ'
+      (SourceOrders.sourceJ_order_of_eq_zero π hπ h₀)
+      (SourceOrders.sourceJ_sub_1728_order_of_eq π hπ h₁)
+  exact
+    exists_unique_solution_from_generator π hπ hτ hτa r.generator hF hFc
+      (generator_zero_iff_orbits π hπ h₀ h₁ hJ r) hF₁ hF₂ (r.exists_cusp_unit hu hu0 hq)
+
+private def SpecialPeriods.phiThree (p : PeriodPoint) : ℂ :=
+  2 - 6 * (1 - p.μ) ^ 2 / p.τ
+
+private def SpecialPeriods.phiFour (p : PeriodPoint) : ℂ :=
+  -3 - 6 * p.μ ^ 2 / p.τ
+
+private theorem
+    SpecialPeriods.phiThree_eq_beta_sub (p : PeriodPoint) : phiThree p = p.step₁.β - p.β := by
+  simp only [phiThree, PeriodPoint.step₁]
+  ring
+
+private theorem
+    SpecialPeriods.phiFour_eq_beta_sub (p : PeriodPoint) : phiFour p = p.step₂.β - p.β := by
+  simp only [phiFour, PeriodPoint.step₂]
+  ring
+
+private theorem
+    SpecialPeriods.phiThree_cyclic_sum (p : PeriodPoint) (h₀ : p.τ ≠ 0) (h₁ : p.τ - 1 ≠ 0) :
+    phiThree p + phiThree p.step₁ + phiThree p.step₁.step₁ = 0 := by
+  simp only [phiThree_eq_beta_sub]
+  rw [p.step₁_cube h₀ h₁]
+  ring
+
+private theorem SpecialPeriods.phiFour_cyclic_sum (p : PeriodPoint) (h₀ : p.τ ≠ 0) :
+    phiFour p + phiFour p.step₂ + phiFour p.step₂.step₂ + phiFour p.step₂.step₂.step₂ = 0 := by
+  simp only [phiFour_eq_beta_sub]
+  rw [p.step₂_fourth h₀]
+  ring
+
+private def SpecialPeriods.betaAverageThree (p : PeriodPoint) : ℂ :=
+  (phiThree p.step₁ + 2 * phiThree p.step₁.step₁) / 3
+
+private def SpecialPeriods.betaAverageFour (p : PeriodPoint) : ℂ :=
+  (phiFour p.step₂ + 2 * phiFour p.step₂.step₂ + 3 * phiFour p.step₂.step₂.step₂) / 4
+
+private theorem SpecialPeriods.betaAverageThree_difference (p : PeriodPoint) (h₀ : p.τ ≠ 0)
+    (h₁ : p.τ - 1 ≠ 0) : betaAverageThree p.step₁ - betaAverageThree p = phiThree p := by
+  unfold betaAverageThree
+  rw [p.step₁_cube h₀ h₁]
+  linear_combination -(1 / 3 : ℂ) * phiThree_cyclic_sum p h₀ h₁
+
+private theorem SpecialPeriods.betaAverageFour_difference (p : PeriodPoint) (h₀ : p.τ ≠ 0) :
+    betaAverageFour p.step₂ - betaAverageFour p = phiFour p := by
+  unfold betaAverageFour
+  rw [p.step₂_fourth h₀]
+  linear_combination -(1 / 4 : ℂ) * phiFour_cyclic_sum p h₀
+
+private def SpecialPeriods.betaPrimitiveThree (τ μ : ℂ) : ℂ :=
+  (2 - 6 * (τ - 1 + μ) ^ 2 / (τ * (τ - 1)) + 2 * (2 + 6 * μ ^ 2 / (τ - 1))) / 3
+
+private def SpecialPeriods.betaPrimitiveFour (τ μ : ℂ) : ℂ :=
+  ((-3 + 6 * (τ + μ) ^ 2 / τ) + 2 * (-3 - 6 * (1 - τ - μ) ^ 2 / τ) +
+      3 * (-3 + 6 * (1 - μ) ^ 2 / τ)) /
+    4
+
+private theorem SpecialPeriods.phiThree_step (p : PeriodPoint) (h₀ : p.τ ≠ 0) (h₁ : p.τ - 1 ≠ 0) :
+    phiThree p.step₁ = 2 - 6 * (p.τ - 1 + p.μ) ^ 2 / (p.τ * (p.τ - 1)) := by
+  simp only [phiThree, PeriodPoint.step₁]
+  field_simp
+  ring
+
+private theorem
+    SpecialPeriods.phiThree_step_sq (p : PeriodPoint) (h₀ : p.τ ≠ 0) (h₁ : p.τ - 1 ≠ 0) :
+    phiThree p.step₁.step₁ = 2 + 6 * p.μ ^ 2 / (p.τ - 1) := by
+  rw [p.step₁_sq h₀ h₁]
+  simp only [phiThree]
+  field_simp
+  ring
+
+private theorem SpecialPeriods.phiFour_step (p : PeriodPoint) (h₀ : p.τ ≠ 0) :
+    phiFour p.step₂ = -3 + 6 * (p.τ + p.μ) ^ 2 / p.τ := by
+  simp only [phiFour, PeriodPoint.step₂]
+  field_simp
+  ring
+
+private theorem SpecialPeriods.phiFour_step_sq (p : PeriodPoint) (h₀ : p.τ ≠ 0) :
+    phiFour p.step₂.step₂ = -3 - 6 * (1 - p.τ - p.μ) ^ 2 / p.τ := by
+  rw [p.step₂_sq h₀]
+  rfl
+
+private theorem SpecialPeriods.phiFour_step_cube (p : PeriodPoint) (h₀ : p.τ ≠ 0) :
+    phiFour p.step₂.step₂.step₂ = -3 + 6 * (1 - p.μ) ^ 2 / p.τ := by
+  rw [phiFour_step _ (by simpa only [p.step₂_sq h₀] using h₀), p.step₂_sq h₀]
+  ring
+
+private theorem SpecialPeriods.betaAverageThree_eq_primitive (p : PeriodPoint) (h₀ : p.τ ≠ 0)
+    (h₁ : p.τ - 1 ≠ 0) : betaAverageThree p = betaPrimitiveThree p.τ p.μ := by
+  rw [betaAverageThree, phiThree_step p h₀ h₁, phiThree_step_sq p h₀ h₁]
+  rfl
+
+private theorem SpecialPeriods.betaAverageFour_eq_primitive (p : PeriodPoint) (h₀ : p.τ ≠ 0) :
+    betaAverageFour p = betaPrimitiveFour p.τ p.μ := by
+  rw [betaAverageFour, phiFour_step p h₀, phiFour_step_sq p h₀, phiFour_step_cube p h₀]
+  rfl
+
+private theorem
+    SpecialPeriods.betaPrimitiveThree_difference (τ μ : ℂ) (h₀ : τ ≠ 0) (h₁ : τ - 1 ≠ 0) :
+    betaPrimitiveThree ((τ - 1) / τ) ((1 - μ) / τ) - betaPrimitiveThree τ μ =
+      2 - 6 * (1 - μ) ^ 2 / τ := by
+  let p : PeriodPoint := ⟨τ, μ, 0⟩
+  have hs₀ : p.step₁.τ ≠ 0 := div_ne_zero h₁ h₀
+  have hs₁ : p.step₁.τ - 1 ≠ 0 := by
+    have he : p.step₁.τ - 1 = -1 / τ := by
+      dsimp [p, PeriodPoint.step₁]
+      field_simp
+      ring
+    rw [he]
+    exact div_ne_zero (by norm_num) h₀
+  change betaPrimitiveThree p.step₁.τ p.step₁.μ - betaPrimitiveThree p.τ p.μ = phiThree p
+  rw [← betaAverageThree_eq_primitive p.step₁ hs₀ hs₁, ← betaAverageThree_eq_primitive p h₀ h₁]
+  exact betaAverageThree_difference p h₀ h₁
+
+private theorem SpecialPeriods.betaPrimitiveFour_difference (τ μ : ℂ) (h₀ : τ ≠ 0) :
+    betaPrimitiveFour (-1 / τ) (1 + μ / τ) - betaPrimitiveFour τ μ = -3 - 6 * μ ^ 2 / τ := by
+  let p : PeriodPoint := ⟨τ, μ, 0⟩
+  have hs₀ : p.step₂.τ ≠ 0 := div_ne_zero (by norm_num) h₀
+  change betaPrimitiveFour p.step₂.τ p.step₂.μ - betaPrimitiveFour p.τ p.μ = phiFour p
+  rw [← betaAverageFour_eq_primitive p.step₂ hs₀, ← betaAverageFour_eq_primitive p h₀]
+  exact betaAverageFour_difference p h₀
+
+private def SpecialPeriods.BetaTorsor.phiOne (τ : ℍ → ℍ) (μ : ℍ → ℂ) (z : ℍ) : ℂ :=
+  2 - 6 * (1 - μ z) ^ 2 / (τ z : ℂ)
+
+private def SpecialPeriods.BetaTorsor.phiTwo (τ : ℍ → ℍ) (μ : ℍ → ℂ) (z : ℍ) : ℂ :=
+  -3 - 6 * μ z ^ 2 / (τ z : ℂ)
+
+private def SpecialPeriods.BetaTorsor.primitiveOne (τ : ℍ → ℍ) (μ : ℍ → ℂ) (z : ℍ) : ℂ :=
+  SpecialPeriods.betaPrimitiveThree (τ z) (μ z)
+
+private def SpecialPeriods.BetaTorsor.primitiveTwo (τ : ℍ → ℍ) (μ : ℍ → ℂ) (z : ℍ) : ℂ :=
+  SpecialPeriods.betaPrimitiveFour (τ z) (μ z)
+
+public
+theorem SpecialPeriods.BetaTorsor.tau_sub_one_ne_zero_mo1973_17984 (τ : ℍ → ℍ) (z : ℍ) :
+    (τ z : ℂ) - 1 ≠ 0 :=
+  sub_ne_zero.mpr (by simpa only [Complex.ofReal_one] using (τ z).ne_ofReal 1)
+
+private theorem SpecialPeriods.BetaTorsor.phiOne_holomorphic {τ : ℍ → ℍ} {μ : ℍ → ℂ}
+    (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (hμ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω μ) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (phiOne τ μ) := by
+  have ht : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z => (τ z : ℂ)) := UpperHalfPlane.contMDiff_coe.comp hτ
+  exact
+    contMDiff_const.sub
+      ((contMDiff_const.mul ((contMDiff_const.sub hμ).pow 2)).div₀ ht (fun z => (τ z).ne_zero))
+
+private theorem SpecialPeriods.BetaTorsor.phiTwo_holomorphic {τ : ℍ → ℍ} {μ : ℍ → ℂ}
+    (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (hμ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω μ) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (phiTwo τ μ) := by
+  have ht : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z => (τ z : ℂ)) := UpperHalfPlane.contMDiff_coe.comp hτ
+  exact contMDiff_const.sub ((contMDiff_const.mul (hμ.pow 2)).div₀ ht (fun z => (τ z).ne_zero))
+
+private theorem SpecialPeriods.BetaTorsor.primitiveOne_holomorphic {τ : ℍ → ℍ} {μ : ℍ → ℂ}
+    (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (hμ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω μ) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (primitiveOne τ μ) := by
+  have ht : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z => (τ z : ℂ)) := UpperHalfPlane.contMDiff_coe.comp hτ
+  have ha :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω
+      (fun z => 6 * ((τ z : ℂ) - 1 + μ z) ^ 2 / ((τ z : ℂ) * ((τ z : ℂ) - 1))) :=
+    (contMDiff_const.mul (((ht.sub contMDiff_const).add hμ).pow 2)).div₀
+      (ht.mul (ht.sub contMDiff_const))
+      (fun z => mul_ne_zero (τ z).ne_zero (tau_sub_one_ne_zero_mo1973_17984 τ z))
+  have hb : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z => 6 * μ z ^ 2 / ((τ z : ℂ) - 1)) :=
+    (contMDiff_const.mul (hμ.pow 2)).div₀ (ht.sub contMDiff_const)
+      (tau_sub_one_ne_zero_mo1973_17984 τ)
+  exact ((contMDiff_const.sub ha).add (contMDiff_const.mul (contMDiff_const.add hb))).div_const 3
+
+private theorem SpecialPeriods.BetaTorsor.primitiveTwo_holomorphic {τ : ℍ → ℍ} {μ : ℍ → ℂ}
+    (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) (hμ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω μ) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (primitiveTwo τ μ) := by
+  have ht : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z => (τ z : ℂ)) := UpperHalfPlane.contMDiff_coe.comp hτ
+  have ha : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z => 6 * ((τ z : ℂ) + μ z) ^ 2 / (τ z : ℂ)) :=
+    (contMDiff_const.mul ((ht.add hμ).pow 2)).div₀ ht (fun z => (τ z).ne_zero)
+  have hb : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z => 6 * (1 - (τ z : ℂ) - μ z) ^ 2 / (τ z : ℂ)) :=
+    (contMDiff_const.mul (((contMDiff_const.sub ht).sub hμ).pow 2)).div₀ ht
+      (fun z => (τ z).ne_zero)
+  have hc : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (fun z => 6 * (1 - μ z) ^ 2 / (τ z : ℂ)) :=
+    (contMDiff_const.mul ((contMDiff_const.sub hμ).pow 2)).div₀ ht (fun z => (τ z).ne_zero)
+  exact
+    (((contMDiff_const.add ha).add (contMDiff_const.mul (contMDiff_const.sub hb))).add
+          (contMDiff_const.mul (contMDiff_const.add hc))).div_const
+      4
+
+private theorem SpecialPeriods.BetaTorsor.primitiveOne_difference {τ : ℍ → ℍ} {μ : ℍ → ℂ}
+    (hτ : SpecialPeriods.TauCovariant τ)
+    (hμ : ∀ z : ℍ, μ (SpecialPeriods.Triangle.generatorOneSL • z) = (1 - μ z) / (τ z : ℂ))
+    (z : ℍ) :
+    primitiveOne τ μ (SpecialPeriods.Triangle.generatorOneSL • z) - primitiveOne τ μ z =
+      phiOne τ μ z := by
+  simp only [primitiveOne, phiOne, hτ.1, hμ]
+  exact
+    SpecialPeriods.betaPrimitiveThree_difference (τ z) (μ z) (τ z).ne_zero
+      (tau_sub_one_ne_zero_mo1973_17984 τ z)
+
+private theorem SpecialPeriods.BetaTorsor.primitiveTwo_difference {τ : ℍ → ℍ} {μ : ℍ → ℂ}
+    (hτ : SpecialPeriods.TauCovariant τ)
+    (hμ : ∀ z : ℍ, μ (SpecialPeriods.Triangle.generatorTwoSL • z) = 1 + μ z / (τ z : ℂ)) (z : ℍ) :
+    primitiveTwo τ μ (SpecialPeriods.Triangle.generatorTwoSL • z) - primitiveTwo τ μ z =
+      phiTwo τ μ z := by
+  simp only [primitiveTwo, phiTwo, hτ.2, hμ]
+  exact SpecialPeriods.betaPrimitiveFour_difference (τ z) (μ z) (τ z).ne_zero
+
+private theorem SpecialPeriods.BetaTorsor.generatorOne_triple_mo1973_17991 (z : ℍ) :
+    SpecialPeriods.Triangle.generatorOneSL •
+        (SpecialPeriods.Triangle.generatorOneSL • (SpecialPeriods.Triangle.generatorOneSL • z)) =
+      z := by
+  have he := congrArg (fun g : Equiv.Perm ℍ => g z) SpecialPeriods.Triangle.generatorOnePerm_cube
+  simpa only [pow_succ, pow_zero, one_mul, Equiv.Perm.mul_apply, Equiv.Perm.one_apply,
+    SpecialPeriods.Triangle.generatorOnePerm,
+    SpecialPeriods.Triangle.realSLPermutation_apply] using he
+
+private theorem SpecialPeriods.BetaTorsor.generatorTwo_quadruple_mo1973_17992 (z : ℍ) :
+    SpecialPeriods.Triangle.generatorTwoSL •
+        (SpecialPeriods.Triangle.generatorTwoSL •
+          (SpecialPeriods.Triangle.generatorTwoSL •
+            (SpecialPeriods.Triangle.generatorTwoSL • z))) =
+      z := by
+  have he :=
+    congrArg (fun g : Equiv.Perm ℍ => g z) SpecialPeriods.Triangle.generatorTwoPerm_fourth
+  simpa only [pow_succ, pow_zero, one_mul, Equiv.Perm.mul_apply, Equiv.Perm.one_apply,
+    SpecialPeriods.Triangle.generatorTwoPerm,
+    SpecialPeriods.Triangle.realSLPermutation_apply] using he
+
+private theorem SpecialPeriods.BetaTorsor.phiOne_cyclic_sum {τ : ℍ → ℍ} {μ : ℍ → ℂ}
+    (hτ : SpecialPeriods.TauCovariant τ)
+    (hμ : ∀ z : ℍ, μ (SpecialPeriods.Triangle.generatorOneSL • z) = (1 - μ z) / (τ z : ℂ))
+    (z : ℍ) :
+    phiOne τ μ z + phiOne τ μ (SpecialPeriods.Triangle.generatorOneSL • z) +
+        phiOne τ μ
+          (SpecialPeriods.Triangle.generatorOneSL •
+            (SpecialPeriods.Triangle.generatorOneSL • z)) =
+      0 := by
+  have h₀ := primitiveOne_difference hτ hμ z
+  have h₁ := primitiveOne_difference hτ hμ (SpecialPeriods.Triangle.generatorOneSL • z)
+  have h₂ :=
+    primitiveOne_difference hτ hμ
+      (SpecialPeriods.Triangle.generatorOneSL • (SpecialPeriods.Triangle.generatorOneSL • z))
+  rw [generatorOne_triple_mo1973_17991] at h₂
+  linear_combination -h₀ - h₁ - h₂
+
+private theorem SpecialPeriods.BetaTorsor.phiTwo_cyclic_sum {τ : ℍ → ℍ} {μ : ℍ → ℂ}
+    (hτ : SpecialPeriods.TauCovariant τ)
+    (hμ : ∀ z : ℍ, μ (SpecialPeriods.Triangle.generatorTwoSL • z) = 1 + μ z / (τ z : ℂ)) (z : ℍ) :
+    phiTwo τ μ z + phiTwo τ μ (SpecialPeriods.Triangle.generatorTwoSL • z) +
+          phiTwo τ μ
+            (SpecialPeriods.Triangle.generatorTwoSL •
+              (SpecialPeriods.Triangle.generatorTwoSL • z)) +
+        phiTwo τ μ
+          (SpecialPeriods.Triangle.generatorTwoSL •
+            (SpecialPeriods.Triangle.generatorTwoSL •
+              (SpecialPeriods.Triangle.generatorTwoSL • z))) =
+      0 := by
+  have h₀ := primitiveTwo_difference hτ hμ z
+  have h₁ := primitiveTwo_difference hτ hμ (SpecialPeriods.Triangle.generatorTwoSL • z)
+  have h₂ :=
+    primitiveTwo_difference hτ hμ
+      (SpecialPeriods.Triangle.generatorTwoSL • (SpecialPeriods.Triangle.generatorTwoSL • z))
+  have h₃ :=
+    primitiveTwo_difference hτ hμ
+      (SpecialPeriods.Triangle.generatorTwoSL •
+        (SpecialPeriods.Triangle.generatorTwoSL • (SpecialPeriods.Triangle.generatorTwoSL • z)))
+  rw [generatorTwo_quadruple_mo1973_17992] at h₃
+  linear_combination -h₀ - h₁ - h₂ - h₃
+
+private theorem SpecialPeriods.BetaTorsor.phiOne_sum_range {τ : ℍ → ℍ} {μ : ℍ → ℂ}
+    (hτ : SpecialPeriods.TauCovariant τ)
+    (hμ : ∀ z : ℍ, μ (SpecialPeriods.Triangle.generatorOneSL • z) = (1 - μ z) / (τ z : ℂ))
+    (z : ℍ) :
+    (∑ k ∈ Finset.range 3, phiOne τ μ ((SpecialPeriods.Triangle.generatorOnePerm ^ k) z)) = 0 := by
+  simpa only [Finset.sum_range_succ, Finset.sum_range_zero, zero_add, pow_succ, pow_zero, one_mul,
+    Equiv.Perm.mul_apply, Equiv.Perm.one_apply, SpecialPeriods.Triangle.generatorOnePerm,
+    SpecialPeriods.Triangle.realSLPermutation_apply] using phiOne_cyclic_sum hτ hμ z
+
+private theorem SpecialPeriods.BetaTorsor.phiTwo_sum_range {τ : ℍ → ℍ} {μ : ℍ → ℂ}
+    (hτ : SpecialPeriods.TauCovariant τ)
+    (hμ : ∀ z : ℍ, μ (SpecialPeriods.Triangle.generatorTwoSL • z) = 1 + μ z / (τ z : ℂ)) (z : ℍ) :
+    (∑ k ∈ Finset.range 4, phiTwo τ μ ((SpecialPeriods.Triangle.generatorTwoPerm ^ k) z)) = 0 := by
+  simpa only [Finset.sum_range_succ, Finset.sum_range_zero, zero_add, pow_succ, pow_zero, one_mul,
+    Equiv.Perm.mul_apply, Equiv.Perm.one_apply, SpecialPeriods.Triangle.generatorTwoPerm,
+    SpecialPeriods.Triangle.realSLPermutation_apply] using phiTwo_cyclic_sum hτ hμ z
+
+private theorem SpecialPeriods.BetaTorsor.phi_product_relation {τ : ℍ → ℍ} {μ : ℍ → ℂ}
+    (hτ : SpecialPeriods.TauCovariant τ)
+    (hμ : ∀ z : ℍ, μ (SpecialPeriods.Triangle.generatorTwoSL • z) = 1 + μ z / (τ z : ℂ)) (z : ℍ) :
+    phiOne τ μ (SpecialPeriods.Triangle.generatorTwoSL • z) + phiTwo τ μ z = -1 := by
+  let p : PeriodPoint := ⟨τ z, μ z, 0⟩
+  have hp : SpecialPeriods.phiThree p.step₂ + SpecialPeriods.phiFour p = -1 := by
+    rw [SpecialPeriods.phiThree_eq_beta_sub, SpecialPeriods.phiFour_eq_beta_sub,
+      p.step₁_step₂ (τ z).ne_zero]
+    simp only
+    ring
+  simp only [phiOne, phiTwo, hτ.2, hμ]
+  exact hp
+
+private def SpecialPeriods.BetaTorsor.cuspPrimitive (τ : ℍ → ℍ) (z : ℍ) : ℂ :=
+  -(τ z : ℂ)
+
+private theorem SpecialPeriods.BetaTorsor.cuspPrimitive_holomorphic {τ : ℍ → ℍ}
+    (hτ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω τ) : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (cuspPrimitive τ) :=
+  (UpperHalfPlane.contMDiff_coe.comp hτ).neg
+
+private theorem SpecialPeriods.BetaTorsor.cuspPrimitive_difference {τ : ℍ → ℍ}
+    (hτ : SpecialPeriods.TauCovariant τ) (z : ℍ) :
+    cuspPrimitive τ
+          (SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleCuspGenerator
+            z) -
+        cuspPrimitive τ z =
+      1 := by
+  rw [cuspPrimitive, cuspPrimitive, SpecialPeriods.tau_covariant_cusp_coe hτ]
+  ring
+
+private def SpecialPeriods.BetaTorsor.skewPerm {X : Type*} (e : Equiv.Perm X) (φ : X → ℂ) :
+    Equiv.Perm (X × ℂ) where
+  toFun x := (e x.1, x.2 + φ x.1)
+  invFun x := (e.symm x.1, x.2 - φ (e.symm x.1))
+  left_inv := by
+    rintro ⟨z, b⟩
+    simp
+  right_inv := by
+    rintro ⟨z, b⟩
+    simp
+
+@[simp]
+private theorem SpecialPeriods.BetaTorsor.skewPerm_apply {X : Type*} (e : Equiv.Perm X) (φ : X → ℂ)
+    (z : X) (b : ℂ) : skewPerm e φ (z, b) = (e z, b + φ z) :=
+  rfl
+
+private theorem
+    SpecialPeriods.BetaTorsor.skewPerm_pow_apply {X : Type*} (e : Equiv.Perm X) (φ : X → ℂ)
+    (n : ℕ) (z : X) (b : ℂ) :
+    (skewPerm e φ ^ n) (z, b) = ((e ^ n) z, b + ∑ k ∈ Finset.range n, φ ((e ^ k) z)) := by
+  induction n with
+  | zero => simp
+  | succ n ih =>
+    rw [pow_succ', Equiv.Perm.mul_apply, ih, skewPerm_apply]
+    rw [pow_succ', Equiv.Perm.mul_apply, Finset.sum_range_succ]
+    simp only [add_assoc]
+
+private theorem
+    SpecialPeriods.BetaTorsor.skewPerm_pow_eq_one {X : Type*} (e : Equiv.Perm X) (φ : X → ℂ)
+    (m : ℕ) (he : e ^ m = 1) (hφ : ∀ z, (∑ k ∈ Finset.range m, φ ((e ^ k) z)) = 0) :
+    skewPerm e φ ^ m = 1 := by
+  apply Equiv.ext
+  rintro ⟨z, b⟩
+  rw [skewPerm_pow_apply, he, hφ z]
+  simp
+
+private def SpecialPeriods.BetaTorsor.IsAdditiveSkewOver {X : Type*} (e : Equiv.Perm X)
+    (p : Equiv.Perm (X × ℂ)) : Prop :=
+  ∀ z b, p (z, b) = (e z, b + (p (z, 0)).2)
+
+private theorem SpecialPeriods.BetaTorsor.isAdditiveSkewOver_skewPerm {X : Type*} (e : Equiv.Perm X)
+    (φ : X → ℂ) : IsAdditiveSkewOver e (skewPerm e φ) := by
+  intro z b
+  simp
+
+private theorem SpecialPeriods.BetaTorsor.isAdditiveSkewOver_one {X : Type*} :
+    IsAdditiveSkewOver (1 : Equiv.Perm X) (1 : Equiv.Perm (X × ℂ)) := by
+  intro z b
+  simp
+
+private theorem SpecialPeriods.BetaTorsor.IsAdditiveSkewOver.mul {X : Type*} {e f : Equiv.Perm X}
+    {p q : Equiv.Perm (X × ℂ)} (hp : SpecialPeriods.BetaTorsor.IsAdditiveSkewOver e p)
+    (hq : SpecialPeriods.BetaTorsor.IsAdditiveSkewOver f q) :
+    SpecialPeriods.BetaTorsor.IsAdditiveSkewOver (e * f) (p * q) := by
+  intro z b
+  have hzero : ((p * q) (z, 0)).2 = (q (z, 0)).2 + (p (f z, 0)).2 := by
+    change (p (q (z, 0))).2 = _
+    rw [hq z 0]
+    simpa only [zero_add] using congrArg Prod.snd (hp (f z) ((q (z, 0)).2))
+  change p (q (z, b)) = (e (f z), b + ((p * q) (z, 0)).2)
+  rw [hq z b, hp (f z) (b + (q (z, 0)).2), hzero]
+  simp only [add_assoc]
+
+private theorem SpecialPeriods.BetaTorsor.IsAdditiveSkewOver.inv {X : Type*} {e : Equiv.Perm X}
+    {p : Equiv.Perm (X × ℂ)} (hp : SpecialPeriods.BetaTorsor.IsAdditiveSkewOver e p) :
+    SpecialPeriods.BetaTorsor.IsAdditiveSkewOver e⁻¹ p⁻¹ := by
+  have hpi (z : X) (b : ℂ) : p.symm (z, b) = (e.symm z, b - (p (e.symm z, 0)).2) := by
+    apply p.injective
+    rw [p.apply_symm_apply, hp]
+    simp
+  intro z b
+  change p.symm (z, b) = (e.symm z, b + (p.symm (z, 0)).2)
+  rw [hpi z b, hpi z 0]
+  simp only [sub_eq_add_neg, zero_add]
+
+private def SpecialPeriods.BetaTorsor.triangleAdditiveRepresentation (φ₁ φ₂ : ℍ → ℂ)
+    (h₁ : ∀ z, (∑ k ∈ Finset.range 3, φ₁ ((SpecialPeriods.Triangle.generatorOnePerm ^ k) z)) = 0)
+    (h₂ :
+      ∀ z, (∑ k ∈ Finset.range 4, φ₂ ((SpecialPeriods.Triangle.generatorTwoPerm ^ k) z)) = 0) :
+    SpecialPeriods.TriangleGroup →* Equiv.Perm (ℍ × ℂ) :=
+  SpecialPeriods.triangleLift (skewPerm SpecialPeriods.Triangle.generatorOnePerm φ₁)
+    (skewPerm SpecialPeriods.Triangle.generatorTwoPerm φ₂)
+    (skewPerm_pow_eq_one _ _ _ SpecialPeriods.Triangle.generatorOnePerm_cube h₁)
+    (skewPerm_pow_eq_one _ _ _ SpecialPeriods.Triangle.generatorTwoPerm_fourth h₂)
+
+@[simp]
+private theorem SpecialPeriods.BetaTorsor.triangleAdditiveRepresentation_generator₁ (φ₁ φ₂ : ℍ → ℂ)
+    (h₁ : ∀ z, (∑ k ∈ Finset.range 3, φ₁ ((SpecialPeriods.Triangle.generatorOnePerm ^ k) z)) = 0)
+    (h₂ :
+      ∀ z, (∑ k ∈ Finset.range 4, φ₂ ((SpecialPeriods.Triangle.generatorTwoPerm ^ k) z)) = 0) :
+    triangleAdditiveRepresentation φ₁ φ₂ h₁ h₂ SpecialPeriods.triangleGenerator₁ =
+      skewPerm SpecialPeriods.Triangle.generatorOnePerm φ₁ :=
+  SpecialPeriods.triangleLift_generator₁ ..
+
+@[simp]
+private theorem SpecialPeriods.BetaTorsor.triangleAdditiveRepresentation_generator₂ (φ₁ φ₂ : ℍ → ℂ)
+    (h₁ : ∀ z, (∑ k ∈ Finset.range 3, φ₁ ((SpecialPeriods.Triangle.generatorOnePerm ^ k) z)) = 0)
+    (h₂ :
+      ∀ z, (∑ k ∈ Finset.range 4, φ₂ ((SpecialPeriods.Triangle.generatorTwoPerm ^ k) z)) = 0) :
+    triangleAdditiveRepresentation φ₁ φ₂ h₁ h₂ SpecialPeriods.triangleGenerator₂ =
+      skewPerm SpecialPeriods.Triangle.generatorTwoPerm φ₂ :=
+  SpecialPeriods.triangleLift_generator₂ ..
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Uniformization/SpecialPeriods6.lean b/LeanPool/HopfProblem/Uniformization/SpecialPeriods6.lean
new file mode 100644
index 000000000..fe70e51da
--- /dev/null
+++ b/LeanPool/HopfProblem/Uniformization/SpecialPeriods6.lean
@@ -0,0 +1,4043 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.PeriodFamily.Core1
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.Elliptic.Core1
+import all LeanPool.HopfProblem.Foundations.TwoAffineCharts
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods3
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods4
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods5
+import all LeanPool.HopfProblem.PeriodFamily.Core1
+
+/-!
+# Hopf problem: uniformization · special periods 6
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem SpecialPeriods.BetaTorsor.triangleAdditiveRepresentation_isAdditiveSkewOver
+    (φ₁ φ₂ : ℍ → ℂ)
+    (h₁ : ∀ z, (∑ k ∈ Finset.range 3, φ₁ ((SpecialPeriods.Triangle.generatorOnePerm ^ k) z)) = 0)
+    (h₂ : ∀ z, (∑ k ∈ Finset.range 4, φ₂ ((SpecialPeriods.Triangle.generatorTwoPerm ^ k) z)) = 0)
+    (g : SpecialPeriods.TriangleGroup) :
+    IsAdditiveSkewOver (SpecialPeriods.triangleGeometricRepresentation g)
+      (triangleAdditiveRepresentation φ₁ φ₂ h₁ h₂ g) := by
+  let H : Subgroup SpecialPeriods.TriangleGroup :=
+    { carrier :=
+        {g |
+          IsAdditiveSkewOver (SpecialPeriods.triangleGeometricRepresentation g)
+            (triangleAdditiveRepresentation φ₁ φ₂ h₁ h₂ g)}
+      one_mem' := by
+        change
+          IsAdditiveSkewOver (SpecialPeriods.triangleGeometricRepresentation 1)
+            (triangleAdditiveRepresentation φ₁ φ₂ h₁ h₂ 1)
+        simpa only [map_one] using (isAdditiveSkewOver_one (X := ℍ))
+      mul_mem' := by
+        intro g h hg hh
+        change
+          IsAdditiveSkewOver (SpecialPeriods.triangleGeometricRepresentation (g * h))
+            (triangleAdditiveRepresentation φ₁ φ₂ h₁ h₂ (g * h))
+        simpa only [map_mul] using (IsAdditiveSkewOver.mul hg hh)
+      inv_mem' := by
+        intro g hg
+        change
+          IsAdditiveSkewOver (SpecialPeriods.triangleGeometricRepresentation g⁻¹)
+            (triangleAdditiveRepresentation φ₁ φ₂ h₁ h₂ g⁻¹)
+        simpa only [map_inv] using (IsAdditiveSkewOver.inv hg) }
+  have hgen :
+    ({ SpecialPeriods.triangleGenerator₁, SpecialPeriods.triangleGenerator₂ } :
+        Set SpecialPeriods.TriangleGroup) ⊆
+      H := by
+    intro g hg
+    rcases hg with rfl | rfl
+    · change
+        IsAdditiveSkewOver
+          (SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleGenerator₁)
+          (triangleAdditiveRepresentation φ₁ φ₂ h₁ h₂ SpecialPeriods.triangleGenerator₁)
+      rw [SpecialPeriods.triangleGeometricRepresentation_generator₁,
+        triangleAdditiveRepresentation_generator₁]
+      exact isAdditiveSkewOver_skewPerm _ _
+    · change
+        IsAdditiveSkewOver
+          (SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleGenerator₂)
+          (triangleAdditiveRepresentation φ₁ φ₂ h₁ h₂ SpecialPeriods.triangleGenerator₂)
+      rw [SpecialPeriods.triangleGeometricRepresentation_generator₂,
+        triangleAdditiveRepresentation_generator₂]
+      exact isAdditiveSkewOver_skewPerm _ _
+  have hclosure :
+    Subgroup.closure
+        ({ SpecialPeriods.triangleGenerator₁, SpecialPeriods.triangleGenerator₂ } :
+          Set SpecialPeriods.TriangleGroup) ≤
+      H :=
+    (Subgroup.closure_le H).mpr hgen
+  apply hclosure
+  rw [SpecialPeriods.triangle_generators_generate]
+  exact Subgroup.mem_top g
+
+private def SpecialPeriods.BetaTorsor.triangleAdditiveShift (φ₁ φ₂ : ℍ → ℂ)
+    (h₁ : ∀ z, (∑ k ∈ Finset.range 3, φ₁ ((SpecialPeriods.Triangle.generatorOnePerm ^ k) z)) = 0)
+    (h₂ : ∀ z, (∑ k ∈ Finset.range 4, φ₂ ((SpecialPeriods.Triangle.generatorTwoPerm ^ k) z)) = 0)
+    (g : SpecialPeriods.TriangleGroup) (z : ℍ) : ℂ :=
+  (triangleAdditiveRepresentation φ₁ φ₂ h₁ h₂ g (z, 0)).2
+
+private theorem SpecialPeriods.BetaTorsor.triangleAdditiveRepresentation_apply (φ₁ φ₂ : ℍ → ℂ)
+    (h₁ : ∀ z, (∑ k ∈ Finset.range 3, φ₁ ((SpecialPeriods.Triangle.generatorOnePerm ^ k) z)) = 0)
+    (h₂ : ∀ z, (∑ k ∈ Finset.range 4, φ₂ ((SpecialPeriods.Triangle.generatorTwoPerm ^ k) z)) = 0)
+    (g : SpecialPeriods.TriangleGroup) (z : ℍ) (b : ℂ) :
+    triangleAdditiveRepresentation φ₁ φ₂ h₁ h₂ g (z, b) =
+      (SpecialPeriods.triangleGeometricRepresentation g z,
+        b + triangleAdditiveShift φ₁ φ₂ h₁ h₂ g z) :=
+  triangleAdditiveRepresentation_isAdditiveSkewOver φ₁ φ₂ h₁ h₂ g z b
+
+@[simp]
+private theorem SpecialPeriods.BetaTorsor.triangleAdditiveShift_one (φ₁ φ₂ : ℍ → ℂ)
+    (h₁ : ∀ z, (∑ k ∈ Finset.range 3, φ₁ ((SpecialPeriods.Triangle.generatorOnePerm ^ k) z)) = 0)
+    (h₂ : ∀ z, (∑ k ∈ Finset.range 4, φ₂ ((SpecialPeriods.Triangle.generatorTwoPerm ^ k) z)) = 0)
+    (z : ℍ) : triangleAdditiveShift φ₁ φ₂ h₁ h₂ 1 z = 0 := by
+  simp only [triangleAdditiveShift, map_one, Equiv.Perm.one_apply]
+
+private theorem SpecialPeriods.BetaTorsor.triangleAdditiveShift_mul (φ₁ φ₂ : ℍ → ℂ)
+    (h₁ : ∀ z, (∑ k ∈ Finset.range 3, φ₁ ((SpecialPeriods.Triangle.generatorOnePerm ^ k) z)) = 0)
+    (h₂ : ∀ z, (∑ k ∈ Finset.range 4, φ₂ ((SpecialPeriods.Triangle.generatorTwoPerm ^ k) z)) = 0)
+    (g h : SpecialPeriods.TriangleGroup) (z : ℍ) :
+    triangleAdditiveShift φ₁ φ₂ h₁ h₂ (g * h) z =
+      triangleAdditiveShift φ₁ φ₂ h₁ h₂ g (SpecialPeriods.triangleGeometricRepresentation h z) +
+        triangleAdditiveShift φ₁ φ₂ h₁ h₂ h z := by
+  change (triangleAdditiveRepresentation φ₁ φ₂ h₁ h₂ (g * h) (z, 0)).2 = _
+  rw [map_mul, Equiv.Perm.mul_apply, triangleAdditiveRepresentation_apply,
+    triangleAdditiveRepresentation_apply]
+  simp only [zero_add, add_comm]
+
+private theorem SpecialPeriods.BetaTorsor.triangleAdditiveShift_inv (φ₁ φ₂ : ℍ → ℂ)
+    (h₁ : ∀ z, (∑ k ∈ Finset.range 3, φ₁ ((SpecialPeriods.Triangle.generatorOnePerm ^ k) z)) = 0)
+    (h₂ : ∀ z, (∑ k ∈ Finset.range 4, φ₂ ((SpecialPeriods.Triangle.generatorTwoPerm ^ k) z)) = 0)
+    (g : SpecialPeriods.TriangleGroup) (z : ℍ) :
+    triangleAdditiveShift φ₁ φ₂ h₁ h₂ g⁻¹ z =
+      -triangleAdditiveShift φ₁ φ₂ h₁ h₂ g
+          (SpecialPeriods.triangleGeometricRepresentation g⁻¹ z) := by
+  have h := triangleAdditiveShift_mul φ₁ φ₂ h₁ h₂ g g⁻¹ z
+  rw [mul_inv_cancel, triangleAdditiveShift_one] at h
+  apply eq_neg_iff_add_eq_zero.mpr
+  simpa only [add_comm] using h.symm
+
+@[simp]
+private theorem SpecialPeriods.BetaTorsor.triangleAdditiveShift_generator₁ (φ₁ φ₂ : ℍ → ℂ)
+    (h₁ : ∀ z, (∑ k ∈ Finset.range 3, φ₁ ((SpecialPeriods.Triangle.generatorOnePerm ^ k) z)) = 0)
+    (h₂ : ∀ z, (∑ k ∈ Finset.range 4, φ₂ ((SpecialPeriods.Triangle.generatorTwoPerm ^ k) z)) = 0)
+    (z : ℍ) : triangleAdditiveShift φ₁ φ₂ h₁ h₂ SpecialPeriods.triangleGenerator₁ z = φ₁ z := by
+  simp only [triangleAdditiveShift, triangleAdditiveRepresentation_generator₁, skewPerm_apply,
+    zero_add]
+
+@[simp]
+private theorem SpecialPeriods.BetaTorsor.triangleAdditiveShift_generator₂ (φ₁ φ₂ : ℍ → ℂ)
+    (h₁ : ∀ z, (∑ k ∈ Finset.range 3, φ₁ ((SpecialPeriods.Triangle.generatorOnePerm ^ k) z)) = 0)
+    (h₂ : ∀ z, (∑ k ∈ Finset.range 4, φ₂ ((SpecialPeriods.Triangle.generatorTwoPerm ^ k) z)) = 0)
+    (z : ℍ) : triangleAdditiveShift φ₁ φ₂ h₁ h₂ SpecialPeriods.triangleGenerator₂ z = φ₂ z := by
+  simp only [triangleAdditiveShift, triangleAdditiveRepresentation_generator₂, skewPerm_apply,
+    zero_add]
+
+private theorem SpecialPeriods.BetaTorsor.additive_cocycle_holomorphic_mo1973_18030
+    (b : SpecialPeriods.TriangleGroup → ℍ → ℂ) (hone : ∀ z, b 1 z = 0)
+    (hmul :
+      ∀ g h z, b (g * h) z = b g (SpecialPeriods.triangleGeometricRepresentation h z) + b h z)
+    (hinv : ∀ g z, b g⁻¹ z = -b g (SpecialPeriods.triangleGeometricRepresentation g⁻¹ z))
+    (h₁ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (b SpecialPeriods.triangleGenerator₁))
+    (h₂ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (b SpecialPeriods.triangleGenerator₂))
+    (g : SpecialPeriods.TriangleGroup) : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (b g) := by
+  have hg :
+    g ∈
+      Subgroup.closure
+        ({ SpecialPeriods.triangleGenerator₁, SpecialPeriods.triangleGenerator₂ } :
+          Set SpecialPeriods.TriangleGroup) := by
+    rw [SpecialPeriods.triangle_generators_generate]
+    exact Subgroup.mem_top g
+  induction hg using Subgroup.closure_induction with
+  | mem g hg =>
+    rcases Set.mem_insert_iff.mp hg with rfl | hg
+    · exact h₁
+    · have he : g = SpecialPeriods.triangleGenerator₂ := Set.mem_singleton_iff.mp hg
+      subst g
+      exact h₂
+  | one =>
+    have he : b 1 = fun _ => 0 := funext hone
+    rw [he]
+    exact contMDiff_const
+  | mul g h _ _ ihg
+    ihh =>
+    have he :
+      b (g * h) = fun z => b g (SpecialPeriods.triangleGeometricRepresentation h z) + b h z :=
+      funext (hmul g h)
+    rw [he]
+    exact (ihg.comp (SpecialPeriods.triangleGeometricRepresentation_holomorphic h)).add ihh
+  | inv g _
+    ihg =>
+    have he : b g⁻¹ = fun z => -b g (SpecialPeriods.triangleGeometricRepresentation g⁻¹ z) :=
+      funext (hinv g)
+    rw [he]
+    exact (ihg.comp (SpecialPeriods.triangleGeometricRepresentation_holomorphic g⁻¹)).neg
+
+private def SpecialPeriods.BetaTorsor.additiveAffineCocycle_mo1973_18031
+    (b : SpecialPeriods.TriangleGroup → ℍ → ℂ) (hone : ∀ z, b 1 z = 0)
+    (hmul :
+      ∀ g h z, b (g * h) z = b g (SpecialPeriods.triangleGeometricRepresentation h z) + b h z)
+    (hhol : ∀ g, ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (b g)) : SpecialPeriods.MuTorsor.AffineCocycle
+    where
+  scale _ _ := 1
+  shift := b
+  scale_one _ := rfl
+  shift_one := hone
+  scale_mul _ _ _ := by simp
+  shift_mul g h z := by simpa only [Units.val_one, one_mul, add_comm] using hmul g h z
+  scale_holomorphic _ := contMDiff_const
+  shift_holomorphic := hhol
+
+private theorem SpecialPeriods.BetaTorsor.triangleAdditiveShift_holomorphic (φ₁ φ₂ : ℍ → ℂ)
+    (h₁ : ∀ z, ∑ k ∈ Finset.range 3, φ₁ ((SpecialPeriods.Triangle.generatorOnePerm ^ k) z) = 0)
+    (h₂ : ∀ z, ∑ k ∈ Finset.range 4, φ₂ ((SpecialPeriods.Triangle.generatorTwoPerm ^ k) z) = 0)
+    (hφ₁ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω φ₁) (hφ₂ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω φ₂)
+    (g : SpecialPeriods.TriangleGroup) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (triangleAdditiveShift φ₁ φ₂ h₁ h₂ g) := by
+  refine
+    additive_cocycle_holomorphic_mo1973_18030 (triangleAdditiveShift φ₁ φ₂ h₁ h₂)
+      (triangleAdditiveShift_one φ₁ φ₂ h₁ h₂) (triangleAdditiveShift_mul φ₁ φ₂ h₁ h₂)
+      (triangleAdditiveShift_inv φ₁ φ₂ h₁ h₂) ?_ ?_ g
+  · have he : triangleAdditiveShift φ₁ φ₂ h₁ h₂ SpecialPeriods.triangleGenerator₁ = φ₁ :=
+      funext (triangleAdditiveShift_generator₁ φ₁ φ₂ h₁ h₂)
+    rw [he]
+    exact hφ₁
+  · have he : triangleAdditiveShift φ₁ φ₂ h₁ h₂ SpecialPeriods.triangleGenerator₂ = φ₂ :=
+      funext (triangleAdditiveShift_generator₂ φ₁ φ₂ h₁ h₂)
+    rw [he]
+    exact hφ₂
+
+private def SpecialPeriods.BetaTorsor.triangleAdditiveCocycle (φ₁ φ₂ : ℍ → ℂ)
+    (h₁ : ∀ z, ∑ k ∈ Finset.range 3, φ₁ ((SpecialPeriods.Triangle.generatorOnePerm ^ k) z) = 0)
+    (h₂ : ∀ z, ∑ k ∈ Finset.range 4, φ₂ ((SpecialPeriods.Triangle.generatorTwoPerm ^ k) z) = 0)
+    (hφ₁ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω φ₁) (hφ₂ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω φ₂) :
+    SpecialPeriods.MuTorsor.AffineCocycle :=
+  additiveAffineCocycle_mo1973_18031 (triangleAdditiveShift φ₁ φ₂ h₁ h₂)
+    (triangleAdditiveShift_one φ₁ φ₂ h₁ h₂) (triangleAdditiveShift_mul φ₁ φ₂ h₁ h₂)
+    (triangleAdditiveShift_holomorphic φ₁ φ₂ h₁ h₂ hφ₁ hφ₂)
+
+private def SpecialPeriods.BetaTorsor.covarianceSubgroup (b : SpecialPeriods.TriangleGroup → ℍ → ℂ)
+    (hone : ∀ z, b 1 z = 0)
+    (hmul :
+      ∀ g h z, b (g * h) z = b g (SpecialPeriods.triangleGeometricRepresentation h z) + b h z)
+    (hinv : ∀ g z, b g⁻¹ z = -b g (SpecialPeriods.triangleGeometricRepresentation g⁻¹ z))
+    (β : ℍ → ℂ) : Subgroup SpecialPeriods.TriangleGroup
+    where
+  carrier := {g | ∀ z, β (SpecialPeriods.triangleGeometricRepresentation g z) = β z + b g z}
+  one_mem' := by
+    intro z
+    simp only [map_one, Equiv.Perm.one_apply, hone, add_zero]
+  mul_mem' := by
+    intro g h hg hh z
+    rw [map_mul, Equiv.Perm.mul_apply, hg, hh, hmul]
+    abel
+  inv_mem' := by
+    intro g hg z
+    have he := hg (SpecialPeriods.triangleGeometricRepresentation g⁻¹ z)
+    have hc :
+      SpecialPeriods.triangleGeometricRepresentation g
+          (SpecialPeriods.triangleGeometricRepresentation g⁻¹ z) =
+        z := by
+      rw [map_inv]
+      exact (SpecialPeriods.triangleGeometricRepresentation g).apply_symm_apply z
+    rw [hc] at he
+    rw [hinv, he]
+    abel
+
+private theorem
+    SpecialPeriods.BetaTorsor.covariance_zpowers (b : SpecialPeriods.TriangleGroup → ℍ → ℂ)
+    (hone : ∀ z, b 1 z = 0)
+    (hmul :
+      ∀ g h z, b (g * h) z = b g (SpecialPeriods.triangleGeometricRepresentation h z) + b h z)
+    (hinv : ∀ g z, b g⁻¹ z = -b g (SpecialPeriods.triangleGeometricRepresentation g⁻¹ z))
+    (β : ℍ → ℂ) (g : SpecialPeriods.TriangleGroup)
+    (hg : ∀ z, β (SpecialPeriods.triangleGeometricRepresentation g z) = β z + b g z)
+    {h : SpecialPeriods.TriangleGroup} (hh : h ∈ Subgroup.zpowers g) (z : ℍ) :
+    β (SpecialPeriods.triangleGeometricRepresentation h z) = β z + b h z :=
+  (Subgroup.zpowers_le.mpr (show g ∈ covarianceSubgroup b hone hmul hinv β from hg)) hh z
+
+private theorem SpecialPeriods.BetaTorsor.triangleAdditiveShift_product (φ₁ φ₂ : ℍ → ℂ)
+    (h₁ : ∀ z, (∑ k ∈ Finset.range 3, φ₁ ((SpecialPeriods.Triangle.generatorOnePerm ^ k) z)) = 0)
+    (h₂ : ∀ z, (∑ k ∈ Finset.range 4, φ₂ ((SpecialPeriods.Triangle.generatorTwoPerm ^ k) z)) = 0)
+    (hproduct : ∀ z, φ₁ (SpecialPeriods.Triangle.generatorTwoPerm z) + φ₂ z = -1) (z : ℍ) :
+    triangleAdditiveShift φ₁ φ₂ h₁ h₂
+        (SpecialPeriods.triangleGenerator₁ * SpecialPeriods.triangleGenerator₂) z =
+      -1 := by
+  rw [triangleAdditiveShift_mul, triangleAdditiveShift_generator₁,
+    triangleAdditiveShift_generator₂, SpecialPeriods.triangleGeometricRepresentation_generator₂]
+  exact hproduct z
+
+private theorem SpecialPeriods.BetaTorsor.triangleAdditiveShift_cusp (φ₁ φ₂ : ℍ → ℂ)
+    (h₁ : ∀ z, (∑ k ∈ Finset.range 3, φ₁ ((SpecialPeriods.Triangle.generatorOnePerm ^ k) z)) = 0)
+    (h₂ : ∀ z, (∑ k ∈ Finset.range 4, φ₂ ((SpecialPeriods.Triangle.generatorTwoPerm ^ k) z)) = 0)
+    (hproduct : ∀ z, φ₁ (SpecialPeriods.Triangle.generatorTwoPerm z) + φ₂ z = -1) (z : ℍ) :
+    triangleAdditiveShift φ₁ φ₂ h₁ h₂ SpecialPeriods.triangleCuspGenerator z = 1 := by
+  rw [SpecialPeriods.triangleCuspGenerator, triangleAdditiveShift_inv,
+    triangleAdditiveShift_product φ₁ φ₂ h₁ h₂ hproduct]
+  norm_num
+
+private structure SpecialPeriods.BetaTorsor.Data where
+  tau : ℍ → ℍ
+  mu : ℍ → ℂ
+  tau_holomorphic : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω tau
+  mu_holomorphic : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω mu
+  tau_covariant : SpecialPeriods.TauCovariant tau
+  mu_one : ∀ z : ℍ, mu (SpecialPeriods.Triangle.generatorOneSL • z) = (1 - mu z) / (tau z : ℂ)
+  mu_two : ∀ z : ℍ, mu (SpecialPeriods.Triangle.generatorTwoSL • z) = 1 + mu z / (tau z : ℂ)
+
+private def SpecialPeriods.BetaTorsor.Data.cocycle (D : SpecialPeriods.BetaTorsor.Data) :
+    SpecialPeriods.MuTorsor.AffineCocycle :=
+  SpecialPeriods.BetaTorsor.triangleAdditiveCocycle (SpecialPeriods.BetaTorsor.phiOne D.tau D.mu)
+    (SpecialPeriods.BetaTorsor.phiTwo D.tau D.mu)
+    (SpecialPeriods.BetaTorsor.phiOne_sum_range D.tau_covariant D.mu_one)
+    (SpecialPeriods.BetaTorsor.phiTwo_sum_range D.tau_covariant D.mu_two)
+    (SpecialPeriods.BetaTorsor.phiOne_holomorphic D.tau_holomorphic D.mu_holomorphic)
+    (SpecialPeriods.BetaTorsor.phiTwo_holomorphic D.tau_holomorphic D.mu_holomorphic)
+
+private def SpecialPeriods.BetaTorsor.Data.shift (D : SpecialPeriods.BetaTorsor.Data) :
+    SpecialPeriods.TriangleGroup → ℍ → ℂ :=
+  SpecialPeriods.BetaTorsor.triangleAdditiveShift (SpecialPeriods.BetaTorsor.phiOne D.tau D.mu)
+    (SpecialPeriods.BetaTorsor.phiTwo D.tau D.mu)
+    (SpecialPeriods.BetaTorsor.phiOne_sum_range D.tau_covariant D.mu_one)
+    (SpecialPeriods.BetaTorsor.phiTwo_sum_range D.tau_covariant D.mu_two)
+
+@[simp]
+private theorem SpecialPeriods.BetaTorsor.Data.cocycle_scale (D : SpecialPeriods.BetaTorsor.Data)
+    (g : SpecialPeriods.TriangleGroup) (z : ℍ) : D.cocycle.scale g z = 1 :=
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.BetaTorsor.Data.cocycle_shift (D : SpecialPeriods.BetaTorsor.Data)
+    (g : SpecialPeriods.TriangleGroup) (z : ℍ) : D.cocycle.shift g z = D.shift g z :=
+  rfl
+
+private theorem SpecialPeriods.BetaTorsor.Data.cocycle_fibreMap (D : SpecialPeriods.BetaTorsor.Data)
+    (g : SpecialPeriods.TriangleGroup) (z : ℍ) (u : ℂ) :
+    D.cocycle.fibreMap g z u = u + D.shift g z := by
+  simp only [SpecialPeriods.MuTorsor.AffineCocycle.fibreMap, D.cocycle_scale, Units.val_one,
+    one_mul, D.cocycle_shift]
+
+@[simp]
+private theorem
+    SpecialPeriods.BetaTorsor.Data.shift_one (D : SpecialPeriods.BetaTorsor.Data) (z : ℍ) :
+    D.shift 1 z = 0 :=
+  SpecialPeriods.BetaTorsor.triangleAdditiveShift_one ..
+
+private theorem SpecialPeriods.BetaTorsor.Data.shift_mul (D : SpecialPeriods.BetaTorsor.Data)
+    (g h : SpecialPeriods.TriangleGroup) (z : ℍ) :
+    D.shift (g * h) z =
+      D.shift g (SpecialPeriods.triangleGeometricRepresentation h z) + D.shift h z :=
+  SpecialPeriods.BetaTorsor.triangleAdditiveShift_mul ..
+
+private theorem SpecialPeriods.BetaTorsor.Data.shift_inv (D : SpecialPeriods.BetaTorsor.Data)
+    (g : SpecialPeriods.TriangleGroup) (z : ℍ) :
+    D.shift g⁻¹ z = -D.shift g (SpecialPeriods.triangleGeometricRepresentation g⁻¹ z) :=
+  SpecialPeriods.BetaTorsor.triangleAdditiveShift_inv ..
+
+@[simp]
+private theorem SpecialPeriods.BetaTorsor.Data.shift_generator₁ (D : SpecialPeriods.BetaTorsor.Data)
+    (z : ℍ) :
+    D.shift SpecialPeriods.triangleGenerator₁ z = SpecialPeriods.BetaTorsor.phiOne D.tau D.mu z :=
+  SpecialPeriods.BetaTorsor.triangleAdditiveShift_generator₁ ..
+
+@[simp]
+private theorem SpecialPeriods.BetaTorsor.Data.shift_generator₂ (D : SpecialPeriods.BetaTorsor.Data)
+    (z : ℍ) :
+    D.shift SpecialPeriods.triangleGenerator₂ z = SpecialPeriods.BetaTorsor.phiTwo D.tau D.mu z :=
+  SpecialPeriods.BetaTorsor.triangleAdditiveShift_generator₂ ..
+
+@[simp]
+private theorem
+    SpecialPeriods.BetaTorsor.Data.shift_cusp (D : SpecialPeriods.BetaTorsor.Data) (z : ℍ) :
+    D.shift SpecialPeriods.triangleCuspGenerator z = 1 :=
+  SpecialPeriods.BetaTorsor.triangleAdditiveShift_cusp
+    (SpecialPeriods.BetaTorsor.phiOne D.tau D.mu) (SpecialPeriods.BetaTorsor.phiTwo D.tau D.mu)
+    (SpecialPeriods.BetaTorsor.phiOne_sum_range D.tau_covariant D.mu_one)
+    (SpecialPeriods.BetaTorsor.phiTwo_sum_range D.tau_covariant D.mu_two)
+    (SpecialPeriods.BetaTorsor.phi_product_relation D.tau_covariant D.mu_two) z
+
+private theorem
+    SpecialPeriods.BetaTorsor.Data.covariance_zpowers (D : SpecialPeriods.BetaTorsor.Data)
+    (β : ℍ → ℂ) (g : SpecialPeriods.TriangleGroup)
+    (hg : ∀ z : ℍ, β (SpecialPeriods.triangleGeometricRepresentation g z) = β z + D.shift g z)
+    {h : SpecialPeriods.TriangleGroup} (hh : h ∈ Subgroup.zpowers g) (z : ℍ) :
+    β (SpecialPeriods.triangleGeometricRepresentation h z) = β z + D.shift h z :=
+  SpecialPeriods.BetaTorsor.covariance_zpowers D.shift D.shift_one D.shift_mul D.shift_inv β g hg
+    hh z
+
+private def SpecialPeriods.BetaTorsor.Data.ellipticPrimitive (D : SpecialPeriods.BetaTorsor.Data) :
+    Elliptic.Kind → ℍ → ℂ
+  | .three => SpecialPeriods.BetaTorsor.primitiveOne D.tau D.mu
+  | .four => SpecialPeriods.BetaTorsor.primitiveTwo D.tau D.mu
+
+private theorem SpecialPeriods.BetaTorsor.Data.ellipticPrimitive_holomorphic
+    (D : SpecialPeriods.BetaTorsor.Data) (j : Elliptic.Kind) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (D.ellipticPrimitive j) := by
+  cases j
+  · exact SpecialPeriods.BetaTorsor.primitiveOne_holomorphic D.tau_holomorphic D.mu_holomorphic
+  · exact SpecialPeriods.BetaTorsor.primitiveTwo_holomorphic D.tau_holomorphic D.mu_holomorphic
+
+private theorem SpecialPeriods.BetaTorsor.Data.ellipticPrimitive_generator
+    (D : SpecialPeriods.BetaTorsor.Data) (j : Elliptic.Kind) (z : ℍ) :
+    D.ellipticPrimitive j
+        (SpecialPeriods.triangleGeometricRepresentation
+          (SpecialPeriods.Triangle.ellipticGenerator j) z) =
+      D.ellipticPrimitive j z + D.shift (SpecialPeriods.Triangle.ellipticGenerator j) z := by
+  cases j
+  · change
+      SpecialPeriods.BetaTorsor.primitiveOne D.tau D.mu
+          (SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleGenerator₁ z) =
+        SpecialPeriods.BetaTorsor.primitiveOne D.tau D.mu z +
+          D.shift SpecialPeriods.triangleGenerator₁ z
+    rw [SpecialPeriods.triangleGeometricRepresentation_generator₁_apply, D.shift_generator₁]
+    exact
+      sub_eq_iff_eq_add'.mp
+        (SpecialPeriods.BetaTorsor.primitiveOne_difference D.tau_covariant D.mu_one z)
+  · change
+      SpecialPeriods.BetaTorsor.primitiveTwo D.tau D.mu
+          (SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleGenerator₂ z) =
+        SpecialPeriods.BetaTorsor.primitiveTwo D.tau D.mu z +
+          D.shift SpecialPeriods.triangleGenerator₂ z
+    rw [SpecialPeriods.triangleGeometricRepresentation_generator₂_apply, D.shift_generator₂]
+    exact
+      sub_eq_iff_eq_add'.mp
+        (SpecialPeriods.BetaTorsor.primitiveTwo_difference D.tau_covariant D.mu_two z)
+
+private theorem SpecialPeriods.BetaTorsor.Data.ellipticPrimitive_additive
+    (D : SpecialPeriods.BetaTorsor.Data) (j : Elliptic.Kind) {g : SpecialPeriods.TriangleGroup}
+    (hg : g ∈ SpecialPeriods.Triangle.ellipticStabilizer j) (z : ℍ) :
+    D.ellipticPrimitive j (SpecialPeriods.triangleGeometricRepresentation g z) =
+      D.ellipticPrimitive j z + D.shift g z := by
+  apply
+    D.covariance_zpowers (D.ellipticPrimitive j) (SpecialPeriods.Triangle.ellipticGenerator j)
+      (D.ellipticPrimitive_generator j)
+  simpa only [SpecialPeriods.Triangle.ellipticStabilizer_eq_zpowers] using hg
+
+private theorem SpecialPeriods.BetaTorsor.Data.cuspPrimitive_generator
+    (D : SpecialPeriods.BetaTorsor.Data) (z : ℍ) :
+    SpecialPeriods.BetaTorsor.cuspPrimitive D.tau
+        (SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleCuspGenerator z) =
+      SpecialPeriods.BetaTorsor.cuspPrimitive D.tau z +
+        D.shift SpecialPeriods.triangleCuspGenerator z := by
+  rw [D.shift_cusp]
+  exact
+    sub_eq_iff_eq_add'.mp (SpecialPeriods.BetaTorsor.cuspPrimitive_difference D.tau_covariant z)
+
+private theorem
+    SpecialPeriods.BetaTorsor.Data.cuspPrimitive_additive (D : SpecialPeriods.BetaTorsor.Data)
+    {g : SpecialPeriods.TriangleGroup}
+    (hg : g ∈ Subgroup.zpowers SpecialPeriods.triangleCuspGenerator) (z : ℍ) :
+    SpecialPeriods.BetaTorsor.cuspPrimitive D.tau
+        (SpecialPeriods.triangleGeometricRepresentation g z) =
+      SpecialPeriods.BetaTorsor.cuspPrimitive D.tau z + D.shift g z :=
+  D.covariance_zpowers (SpecialPeriods.BetaTorsor.cuspPrimitive D.tau)
+    SpecialPeriods.triangleCuspGenerator D.cuspPrimitive_generator hg z
+
+private def SpecialPeriods.BetaTorsor.Data.regularSeed (D : SpecialPeriods.BetaTorsor.Data)
+    (x : SpecialPeriods.TriangleRegularQuotient) :
+    (SpecialPeriods.MuTorsor.Cover.regularPatch x).Seed D.cocycle
+    where
+  toFun _ := 0
+  holomorphic := contMDiffOn_const
+  equivariant := by
+    intro g z _
+    have hg : (g : SpecialPeriods.TriangleGroup) = 1 := Subgroup.mem_bot.mp g.property
+    rw [hg, D.cocycle.fibreMap_one]
+
+private def SpecialPeriods.BetaTorsor.Data.ellipticSeed (D : SpecialPeriods.BetaTorsor.Data)
+    (j : Elliptic.Kind) : (SpecialPeriods.MuTorsor.Cover.ellipticPatch j).Seed D.cocycle
+    where
+  toFun := D.ellipticPrimitive j
+  holomorphic := (D.ellipticPrimitive_holomorphic j).contMDiffOn
+  equivariant := by
+    intro g z _
+    rw [D.cocycle_fibreMap]
+    exact D.ellipticPrimitive_additive j g.property z
+
+private def SpecialPeriods.BetaTorsor.Data.cuspSeed (D : SpecialPeriods.BetaTorsor.Data) :
+    SpecialPeriods.MuTorsor.Cover.cuspPatch.Seed D.cocycle
+    where
+  toFun := SpecialPeriods.BetaTorsor.cuspPrimitive D.tau
+  holomorphic :=
+    (SpecialPeriods.BetaTorsor.cuspPrimitive_holomorphic D.tau_holomorphic).contMDiffOn
+  equivariant := by
+    intro g z _
+    rw [D.cocycle_fibreMap]
+    exact D.cuspPrimitive_additive g.property z
+
+private def SpecialPeriods.BetaTorsor.Data.seed (D : SpecialPeriods.BetaTorsor.Data)
+    (i : SpecialPeriods.MuTorsor.Cover.Index) :
+    (SpecialPeriods.MuTorsor.Cover.patch i).Seed D.cocycle :=
+  match i with
+  | none => D.cuspSeed
+  | some (.inl x) => D.regularSeed x
+  | some (.inr j) => D.ellipticSeed j
+
+private def SpecialPeriods.BetaTorsor.Data.localSection (D : SpecialPeriods.BetaTorsor.Data)
+    (i : SpecialPeriods.MuTorsor.Cover.Index) : ℍ → ℂ :=
+  (D.seed i).extend
+
+private theorem SpecialPeriods.BetaTorsor.Data.localSection_holomorphic
+    (D : SpecialPeriods.BetaTorsor.Data) (i : SpecialPeriods.MuTorsor.Cover.Index) :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (D.localSection i)
+      (SpecialPeriods.MuTorsor.Cover.patch i).saturation :=
+  (D.seed i).extend_holomorphic
+
+private theorem
+    SpecialPeriods.BetaTorsor.Data.localSection_additive (D : SpecialPeriods.BetaTorsor.Data)
+    (i : SpecialPeriods.MuTorsor.Cover.Index) (g : SpecialPeriods.TriangleGroup) (z : ℍ)
+    (hz : z ∈ (SpecialPeriods.MuTorsor.Cover.patch i).saturation) :
+    D.localSection i (SpecialPeriods.triangleGeometricRepresentation g z) =
+      D.localSection i z + D.shift g z := by
+  have he := (D.seed i).extend_equivariant g z hz
+  rwa [D.cocycle_fibreMap] at he
+
+private theorem
+    SpecialPeriods.BetaTorsor.Data.localSection_cusp (D : SpecialPeriods.BetaTorsor.Data)
+    (z : ℍ) (hz : z ∈ SpecialPeriods.Triangle.horodisc SpecialPeriods.Triangle.width) :
+    D.localSection SpecialPeriods.MuTorsor.Cover.cuspIndex z = -(D.tau z : ℂ) :=
+  D.cuspSeed.extend_eq z hz
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.BetaTorsor.patchSaturation (i : SpecialPeriods.MuTorsor.Cover.Index) :
+    TopologicalSpace.Opens ℍ :=
+  ⟨(SpecialPeriods.MuTorsor.Cover.patch i).saturation,
+    (SpecialPeriods.MuTorsor.Cover.patch i).saturation_isOpen⟩
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.patchSaturation_invariant
+    (i : SpecialPeriods.MuTorsor.Cover.Index) (g : SpecialPeriods.TriangleGroup) (z : ℍ) :
+    SpecialPeriods.triangleGeometricRepresentation g z ∈ patchSaturation i ↔
+      z ∈ patchSaturation i :=
+  (SpecialPeriods.MuTorsor.Cover.patch i).saturation_invariant g z
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.BetaTorsor.overlapDomain (i j : SpecialPeriods.MuTorsor.Cover.Index) :
+    TopologicalSpace.Opens ℍ :=
+  patchSaturation i ⊓ patchSaturation j
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.overlapDomain_invariant
+    (i j : SpecialPeriods.MuTorsor.Cover.Index) (g : SpecialPeriods.TriangleGroup) (z : ℍ) :
+    SpecialPeriods.triangleGeometricRepresentation g z ∈ overlapDomain i j ↔
+      z ∈ overlapDomain i j :=
+  (patchSaturation_invariant i g z).and (patchSaturation_invariant j g z)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.finiteProjection_mem_patch
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (i : SpecialPeriods.MuTorsor.Cover.Index) (z : ℍ) :
+    finiteProjection π z ∈ SpecialPeriods.MuTorsor.Cover.finitePatch π i ↔
+      z ∈ patchSaturation i := by
+  rw [SpecialPeriods.MuTorsor.Cover.finitePatch, finiteProjection_mem_pullback π hπ]
+  change
+    z ∈
+        SpecialPeriods.triangleCompactifiedProjection ⁻¹'
+          (SpecialPeriods.MuTorsor.Cover.compactPatch i :
+            Set SpecialPeriods.TriangleCompactifiedOrbitSpace) ↔
+      _
+  rw [SpecialPeriods.MuTorsor.Cover.compactPatch_preimage_projection]
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.finiteProjection_preimage_patch
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (i : SpecialPeriods.MuTorsor.Cover.Index) :
+    finiteProjection π ⁻¹' (SpecialPeriods.MuTorsor.Cover.finitePatch π i : Set ℂ) =
+      patchSaturation i := by
+  ext z
+  exact finiteProjection_mem_patch π hπ i z
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.finiteDescentDomain_overlap
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (i j : SpecialPeriods.MuTorsor.Cover.Index) :
+    finiteDescentDomain π hπ (overlapDomain i j) =
+      SpecialPeriods.MuTorsor.Cover.finitePatch π i ⊓
+        SpecialPeriods.MuTorsor.Cover.finitePatch π j := by
+  ext t
+  obtain ⟨z, rfl⟩ := finiteProjection_surjective π hπ t
+  change
+    finiteProjection π z ∈ finiteDescentDomain π hπ (overlapDomain i j) ↔
+      finiteProjection π z ∈ SpecialPeriods.MuTorsor.Cover.finitePatch π i ∧
+        finiteProjection π z ∈ SpecialPeriods.MuTorsor.Cover.finitePatch π j
+  rw [finiteDescentDomain_projection π hπ _ (overlapDomain_invariant i j)]
+  change
+    z ∈ patchSaturation i ∧ z ∈ patchSaturation j ↔
+      finiteProjection π z ∈ SpecialPeriods.MuTorsor.Cover.finitePatch π i ∧
+        finiteProjection π z ∈ SpecialPeriods.MuTorsor.Cover.finitePatch π j
+  rw [finiteProjection_mem_patch π hπ i, finiteProjection_mem_patch π hπ j]
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.BetaTorsor.Data.overlapDifference (D : SpecialPeriods.BetaTorsor.Data)
+    (i j : SpecialPeriods.MuTorsor.Cover.Index) (z : ℍ) : ℂ :=
+  D.localSection i z - D.localSection j z
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.Data.overlapDifference_invariant
+    (D : SpecialPeriods.BetaTorsor.Data) (i j : SpecialPeriods.MuTorsor.Cover.Index)
+    (g : SpecialPeriods.TriangleGroup) (z : ℍ)
+    (hz : z ∈ SpecialPeriods.BetaTorsor.overlapDomain i j) :
+    D.overlapDifference i j (SpecialPeriods.triangleGeometricRepresentation g z) =
+      D.overlapDifference i j z := by
+  dsimp only [overlapDifference]
+  rw [D.localSection_additive i g z hz.1, D.localSection_additive j g z hz.2]
+  ring
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.Data.overlapDifference_holomorphic
+    (D : SpecialPeriods.BetaTorsor.Data) (i j : SpecialPeriods.MuTorsor.Cover.Index) :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (D.overlapDifference i j)
+      (SpecialPeriods.BetaTorsor.overlapDomain i j) :=
+  ((D.localSection_holomorphic i).mono (fun _ hz => hz.1)).sub
+    ((D.localSection_holomorphic j).mono (fun _ hz => hz.2))
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.BetaTorsor.Data.overlapCocycle (D : SpecialPeriods.BetaTorsor.Data)
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (i j : SpecialPeriods.MuTorsor.Cover.Index) : ℂ → ℂ :=
+  SpecialPeriods.BetaTorsor.finiteDescent π hπ (SpecialPeriods.BetaTorsor.overlapDomain i j)
+    (D.overlapDifference i j)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.Data.overlapCocycle_analytic
+    (D : SpecialPeriods.BetaTorsor.Data)
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (i j : SpecialPeriods.MuTorsor.Cover.Index) :
+    AnalyticOnNhd ℂ (D.overlapCocycle π hπ i j)
+      ((SpecialPeriods.MuTorsor.Cover.finitePatch π i : Set ℂ) ∩
+        SpecialPeriods.MuTorsor.Cover.finitePatch π j) := by
+  have h :=
+    SpecialPeriods.BetaTorsor.finiteDescent_analytic π hπ
+      (SpecialPeriods.BetaTorsor.overlapDomain i j) (D.overlapDifference i j)
+      (SpecialPeriods.BetaTorsor.overlapDomain_invariant i j) (D.overlapDifference_invariant i j)
+      (D.overlapDifference_holomorphic i j)
+  rw [SpecialPeriods.BetaTorsor.finiteDescentDomain_overlap] at h
+  exact h
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.Data.localSection_difference
+    (D : SpecialPeriods.BetaTorsor.Data)
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (i j : SpecialPeriods.MuTorsor.Cover.Index) (z : ℍ)
+    (hi :
+      SpecialPeriods.BetaTorsor.finiteProjection π z ∈
+        SpecialPeriods.MuTorsor.Cover.finitePatch π i)
+    (hj :
+      SpecialPeriods.BetaTorsor.finiteProjection π z ∈
+        SpecialPeriods.MuTorsor.Cover.finitePatch π j) :
+    D.localSection i z - D.localSection j z =
+      D.overlapCocycle π hπ i j (SpecialPeriods.BetaTorsor.finiteProjection π z) :=
+  (SpecialPeriods.BetaTorsor.finiteDescent_projection π hπ
+      (SpecialPeriods.BetaTorsor.overlapDomain i j) (D.overlapDifference i j)
+      (SpecialPeriods.BetaTorsor.overlapDomain_invariant i j) (D.overlapDifference_invariant i j)
+      ⟨(SpecialPeriods.BetaTorsor.finiteProjection_mem_patch π hπ i z).mp hi,
+        (SpecialPeriods.BetaTorsor.finiteProjection_mem_patch π hπ j z).mp hj⟩).symm
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.Data.localSection_holomorphic_finite
+    (D : SpecialPeriods.BetaTorsor.Data)
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (i : SpecialPeriods.MuTorsor.Cover.Index) :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (D.localSection i)
+      (SpecialPeriods.BetaTorsor.finiteProjection π ⁻¹'
+        (SpecialPeriods.MuTorsor.Cover.finitePatch π i : Set ℂ)) := by
+  rw [SpecialPeriods.BetaTorsor.finiteProjection_preimage_patch π hπ]
+  exact D.localSection_holomorphic i
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.Data.localSection_additive_finite
+    (D : SpecialPeriods.BetaTorsor.Data)
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere))
+    (i : SpecialPeriods.MuTorsor.Cover.Index) (g : SpecialPeriods.TriangleGroup) (z : ℍ)
+    (hz :
+      SpecialPeriods.BetaTorsor.finiteProjection π z ∈
+        SpecialPeriods.MuTorsor.Cover.finitePatch π i) :
+    D.localSection i (SpecialPeriods.triangleGeometricRepresentation g z) =
+      D.localSection i z + D.shift g z :=
+  D.localSection_additive i g z
+    ((SpecialPeriods.BetaTorsor.finiteProjection_mem_patch π hπ i z).mp hz)
+
+private theorem
+    SpecialPeriods.BetaTorsorGluing.descended_difference_cocycle {X ι : Type*} {π : X → ℂ}
+    (hπ : Function.Surjective π) {U : ι → Set ℂ} {βlocal : ι → X → ℂ} {h : ι → ι → ℂ → ℂ}
+    (hdiff : ∀ i j z, π z ∈ U i → π z ∈ U j → βlocal i z - βlocal j z = h i j (π z)) :
+    ∀ i j k w, w ∈ U i → w ∈ U j → w ∈ U k → h i j w + h j k w = h i k w := by
+  intro i j k w hi hj hk
+  obtain ⟨z, rfl⟩ := hπ w
+  rw [← hdiff i j z hi hj, ← hdiff j k z hj hk, ← hdiff i k z hi hk]
+  ring
+
+private def SpecialPeriods.BetaTorsorGluing.correctedGlue {X ι : Type*} (π : X → ℂ) (U : ι → Set ℂ)
+    (hcover : ∀ w, ∃ i, w ∈ U i) (βlocal : ι → X → ℂ) {h : ι → ι → ℂ → ℂ} {i₀ : ι} {R : ℝ}
+    (c : HolomorphicCousin.NormalizedCocycleSolution U h i₀ R) (z : X) : ℂ :=
+  βlocal (hcover (π z)).choose z - c.localPart (hcover (π z)).choose (π z)
+
+private theorem
+    SpecialPeriods.BetaTorsorGluing.correctedGlue_eq {X ι : Type*} {π : X → ℂ} {U : ι → Set ℂ}
+    {hcover : ∀ w, ∃ i, w ∈ U i} {βlocal : ι → X → ℂ} {h : ι → ι → ℂ → ℂ} {i₀ : ι} {R : ℝ}
+    (c : HolomorphicCousin.NormalizedCocycleSolution U h i₀ R)
+    (hdiff : ∀ i j z, π z ∈ U i → π z ∈ U j → βlocal i z - βlocal j z = h i j (π z)) {i : ι}
+    {z : X} (hz : π z ∈ U i) :
+    correctedGlue π U hcover βlocal c z = βlocal i z - c.localPart i (π z) := by
+  let j := (hcover (π z)).choose
+  have hj : π z ∈ U j := (hcover (π z)).choose_spec
+  change βlocal j z - c.localPart j (π z) = βlocal i z - c.localPart i (π z)
+  have hb := hdiff j i z hj hz
+  have hc := c.equation j i (π z) hj hz
+  linear_combination hb - hc
+
+private theorem SpecialPeriods.BetaTorsorGluing.correctedGlue_eventuallyEq {X ι : Type*}
+    [TopologicalSpace X] {π : X → ℂ} (hπ : Continuous π) {U : ι → Set ℂ} (hU : ∀ i, IsOpen (U i))
+    {hcover : ∀ w, ∃ i, w ∈ U i} {βlocal : ι → X → ℂ} {h : ι → ι → ℂ → ℂ} {i₀ : ι} {R : ℝ}
+    (c : HolomorphicCousin.NormalizedCocycleSolution U h i₀ R)
+    (hdiff : ∀ i j z, π z ∈ U i → π z ∈ U j → βlocal i z - βlocal j z = h i j (π z)) {i : ι}
+    {z : X} (hz : π z ∈ U i) :
+    correctedGlue π U hcover βlocal c =ᶠ[𝓝 z] fun w => βlocal i w - c.localPart i (π w) := by
+  filter_upwards [((hU i).preimage hπ).mem_nhds hz] with w hw
+  exact correctedGlue_eq c hdiff hw
+
+private theorem SpecialPeriods.BetaTorsorGluing.correctedGlue_holomorphic {ι : Type*} {π : ℍ → ℂ}
+    (hπ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω π) {U : ι → Set ℂ} (hU : ∀ i, IsOpen (U i))
+    {hcover : ∀ w, ∃ i, w ∈ U i} {βlocal : ι → ℍ → ℂ}
+    (hβ : ∀ i, ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (βlocal i) (π ⁻¹' U i)) {h : ι → ι → ℂ → ℂ} {i₀ : ι}
+    {R : ℝ} (c : HolomorphicCousin.NormalizedCocycleSolution U h i₀ R)
+    (hdiff : ∀ i j z, π z ∈ U i → π z ∈ U j → βlocal i z - βlocal j z = h i j (π z)) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (correctedGlue π U hcover βlocal c) := by
+  intro z
+  obtain ⟨i, hi⟩ := hcover (π z)
+  have hb : ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (βlocal i) z :=
+    (hβ i).contMDiffAt (((hU i).preimage hπ.continuous).mem_nhds hi)
+  have hc : ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (fun w => c.localPart i (π w)) z :=
+    (c.local_analytic i (π z) hi).contDiffAt.contMDiffAt.comp z (hπ z)
+  exact (hb.sub hc).congr_of_eventuallyEq (correctedGlue_eventuallyEq hπ.continuous hU c hdiff hi)
+
+private theorem SpecialPeriods.BetaTorsorGluing.correctedGlue_additive_law {X ι : Type*} {G : Type*}
+    {π : X → ℂ} {U : ι → Set ℂ} {hcover : ∀ w, ∃ i, w ∈ U i} {βlocal : ι → X → ℂ}
+    {h : ι → ι → ℂ → ℂ} {i₀ : ι} {R : ℝ}
+    (c : HolomorphicCousin.NormalizedCocycleSolution U h i₀ R)
+    (hdiff : ∀ i j z, π z ∈ U i → π z ∈ U j → βlocal i z - βlocal j z = h i j (π z))
+    (A : G → X → X) (δ : G → X → ℂ) (hπA : ∀ g z, π (A g z) = π z)
+    (hβA : ∀ i g z, π z ∈ U i → βlocal i (A g z) = βlocal i z + δ g z) (g : G) (z : X) :
+    correctedGlue π U hcover βlocal c (A g z) = correctedGlue π U hcover βlocal c z + δ g z := by
+  obtain ⟨i, hi⟩ := hcover (π z)
+  have hiA : π (A g z) ∈ U i := by rwa [hπA g z]
+  rw [correctedGlue_eq c hdiff hiA, correctedGlue_eq c hdiff hi, hπA g z, hβA i g z hi]
+  ring
+
+private theorem SpecialPeriods.BetaTorsorGluing.correctedGlue_cusp {X ι : Type*} {π : X → ℂ}
+    {U : ι → Set ℂ} {hcover : ∀ w, ∃ i, w ∈ U i} {βlocal : ι → X → ℂ} {h : ι → ι → ℂ → ℂ} {i₀ : ι}
+    {R : ℝ} (c : HolomorphicCousin.NormalizedCocycleSolution U h i₀ R)
+    (hdiff : ∀ i j z, π z ∈ U i → π z ∈ U j → βlocal i z - βlocal j z = h i j (π z))
+    (hRU : (Metric.ball (0 : ℂ) R)ᶜ ⊆ U i₀) {τ : X → ℂ} {W : Set X}
+    (hβ₀ : ∀ z ∈ W, βlocal i₀ z = -τ z) {z : X} (hz : z ∈ W) (hlarge : R < ‖π z‖) :
+    correctedGlue π U hcover βlocal c z + τ z = -c.infinityPart (π z)⁻¹ := by
+  have hzU : π z ∈ U i₀ :=
+    hRU
+      (by
+        simpa only [Set.mem_compl_iff, Metric.mem_ball, dist_zero_right, not_lt] using hlarge.le)
+  rw [correctedGlue_eq c hdiff hzU, hβ₀ z hz, c.atInfinity (π z) hlarge]
+  ring
+
+private theorem SpecialPeriods.BetaTorsorGluing.exists_corrected_gluing {ι : Type*} {π : ℍ → ℂ}
+    (hπ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω π) (hπsurj : Function.Surjective π) {U : ι → Set ℂ}
+    (hU : ∀ i, IsOpen (U i)) (hcover : ∀ w, ∃ i, w ∈ U i) {βlocal : ι → ℍ → ℂ}
+    (hβ : ∀ i, ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (βlocal i) (π ⁻¹' U i)) {h : ι → ι → ℂ → ℂ}
+    (hh : ∀ i j, AnalyticOnNhd ℂ (h i j) (U i ∩ U j))
+    (hdiff : ∀ i j z, π z ∈ U i → π z ∈ U j → βlocal i z - βlocal j z = h i j (π z)) (i₀ : ι)
+    {R : ℝ} (hR : 0 < R) (hRU : (Metric.ball (0 : ℂ) R)ᶜ ⊆ U i₀) :
+    ∃ c : HolomorphicCousin.NormalizedCocycleSolution U h i₀ R,
+      ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (correctedGlue π U hcover βlocal c) ∧
+        ∀ i,
+          Set.EqOn (correctedGlue π U hcover βlocal c) (fun z => βlocal i z - c.localPart i (π z))
+            (π ⁻¹' U i) := by
+  obtain ⟨c⟩ :=
+    HolomorphicCousin.exists_normalized_holomorphic_cocycle_solution hU hcover hh
+      (descended_difference_cocycle hπsurj hdiff) i₀ hR hRU
+  exact ⟨c, correctedGlue_holomorphic hπ hU hβ c hdiff, fun _ _ hz => correctedGlue_eq c hdiff hz⟩
+
+private theorem SpecialPeriods.BetaTorsorGluing.exists_glued_beta_with_cusp {ι : Type*} {G : Type*}
+    {π : ℍ → ℂ} (hπ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω π) (hπsurj : Function.Surjective π) {U : ι → Set ℂ}
+    (hU : ∀ i, IsOpen (U i)) (hcover : ∀ w, ∃ i, w ∈ U i) {βlocal : ι → ℍ → ℂ}
+    (hβ : ∀ i, ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (βlocal i) (π ⁻¹' U i)) {h : ι → ι → ℂ → ℂ}
+    (hh : ∀ i j, AnalyticOnNhd ℂ (h i j) (U i ∩ U j))
+    (hdiff : ∀ i j z, π z ∈ U i → π z ∈ U j → βlocal i z - βlocal j z = h i j (π z)) (i₀ : ι)
+    {R : ℝ} (hR : 0 < R) (hRU : (Metric.ball (0 : ℂ) R)ᶜ ⊆ U i₀) (A : G → ℍ → ℍ) (δ : G → ℍ → ℂ)
+    (hπA : ∀ g z, π (A g z) = π z)
+    (hβA : ∀ i g z, π z ∈ U i → βlocal i (A g z) = βlocal i z + δ g z) (τ : ℍ → ℂ) (W : Set ℍ)
+    (hβ₀ : ∀ z ∈ W, βlocal i₀ z = -τ z) :
+    ∃ (β : ℍ → ℂ) (B : ℂ → ℂ),
+      ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω β ∧
+        AnalyticOnNhd ℂ B (Metric.ball 0 R⁻¹) ∧
+          B 0 = 0 ∧
+            (∀ g z, β (A g z) = β z + δ g z) ∧ ∀ z ∈ W, R < ‖π z‖ → β z + τ z = B (π z)⁻¹ := by
+  obtain ⟨c, hc, _⟩ := exists_corrected_gluing hπ hπsurj hU hcover hβ hh hdiff i₀ hR hRU
+  refine
+    ⟨correctedGlue π U hcover βlocal c, fun u => -c.infinityPart u, hc, c.infinity_analytic.neg,
+      ?_, ?_, ?_⟩
+  · change -c.infinityPart 0 = 0
+    rw [c.infinity_zero, neg_zero]
+  · exact correctedGlue_additive_law c hdiff A δ hπA hβA
+  · intro z hz hlarge
+    exact correctedGlue_cusp c hdiff hRU hβ₀ hz hlarge
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.BetaTorsor.Data.GeneratorLaws (D : SpecialPeriods.BetaTorsor.Data)
+    (β : ℍ → ℂ) : Prop :=
+  (∀ z : ℍ,
+      β (SpecialPeriods.Triangle.generatorOneSL • z) =
+        β z + SpecialPeriods.BetaTorsor.phiOne D.tau D.mu z) ∧
+    (∀ z : ℍ,
+      β (SpecialPeriods.Triangle.generatorTwoSL • z) =
+        β z + SpecialPeriods.BetaTorsor.phiTwo D.tau D.mu z)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.Data.generatorLaws_of_all_words
+    (D : SpecialPeriods.BetaTorsor.Data) {β : ℍ → ℂ}
+    (hβ :
+      ∀ g : SpecialPeriods.TriangleGroup,
+        ∀ z : ℍ, β (SpecialPeriods.triangleGeometricRepresentation g z) = β z + D.shift g z) :
+    D.GeneratorLaws β := by
+  constructor
+  · intro z
+    simpa only [SpecialPeriods.triangleGeometricRepresentation_generator₁_apply,
+      D.shift_generator₁] using hβ SpecialPeriods.triangleGenerator₁ z
+  · intro z
+    simpa only [SpecialPeriods.triangleGeometricRepresentation_generator₂_apply,
+      D.shift_generator₂] using hβ SpecialPeriods.triangleGenerator₂ z
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.Data.GeneratorLaws.add_const
+    (D : SpecialPeriods.BetaTorsor.Data) {β : ℍ → ℂ} (hβ : D.GeneratorLaws β) (c : ℂ) :
+    D.GeneratorLaws (fun z => β z + c) := by
+  constructor
+  · intro z
+    dsimp only
+    rw [hβ.1 z]
+    ring
+  · intro z
+    dsimp only
+    rw [hβ.2 z]
+    ring
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem
+    SpecialPeriods.BetaTorsor.Data.exists_global_beta (D : SpecialPeriods.BetaTorsor.Data)
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    ∃ R : ℝ,
+      0 < R ∧
+        ∃ (β : ℍ → ℂ) (B : ℂ → ℂ),
+          ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω β ∧
+            D.GeneratorLaws β ∧
+              AnalyticOnNhd ℂ B (Metric.ball 0 R⁻¹) ∧
+                B 0 = 0 ∧
+                  ∀ z ∈ SpecialPeriods.Triangle.horodisc SpecialPeriods.Triangle.width,
+                    R < ‖SpecialPeriods.BetaTorsor.finiteProjection π z‖ →
+                      β z + (D.tau z : ℂ) =
+                        B (SpecialPeriods.BetaTorsor.finiteProjection π z)⁻¹ := by
+  obtain ⟨R, hR, hRU⟩ := SpecialPeriods.MuTorsor.Cover.finitePatch_cusp_contains_exterior π hπ
+  obtain ⟨β, B, hβ, hB, hB0, hwords, hcusp⟩ :=
+    SpecialPeriods.BetaTorsorGluing.exists_glued_beta_with_cusp
+      (SpecialPeriods.BetaTorsor.finiteProjection_holomorphic π hπ)
+      (SpecialPeriods.BetaTorsor.finiteProjection_surjective π hπ)
+      (fun i => (SpecialPeriods.MuTorsor.Cover.finitePatch π i).isOpen)
+      (SpecialPeriods.MuTorsor.Cover.exists_finitePatch π)
+      (D.localSection_holomorphic_finite π hπ) (D.overlapCocycle_analytic π hπ)
+      (D.localSection_difference π hπ) SpecialPeriods.MuTorsor.Cover.cuspIndex hR hRU
+      (fun g z => SpecialPeriods.triangleGeometricRepresentation g z) D.shift
+      (SpecialPeriods.BetaTorsor.finiteProjection_invariant π)
+      (D.localSection_additive_finite π hπ) (fun z => (D.tau z : ℂ))
+      (SpecialPeriods.Triangle.horodisc SpecialPeriods.Triangle.width) D.localSection_cusp
+  exact ⟨R, hR, β, B, hβ, D.generatorLaws_of_all_words hwords, hB, hB0, hcusp⟩
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.BetaTorsor.qExtension
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (B : ℂ → ℂ) (q : ℂ) : ℂ :=
+  B (SpecialPeriods.MuTorsor.CuspCoordinates.t π q)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.qExtension_zero
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) (B : ℂ → ℂ) :
+    qExtension π B 0 = B 0 := by
+  rw [qExtension, SpecialPeriods.MuTorsor.CuspCoordinates.t_zero π hπ]
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.qExtension_analyticAt_zero
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) {B : ℂ → ℂ}
+    (hB : AnalyticAt ℂ B 0) : AnalyticAt ℂ (qExtension π B) 0 := by
+  have ht : AnalyticAt ℂ B (SpecialPeriods.MuTorsor.CuspCoordinates.t π 0) := by
+    rw [SpecialPeriods.MuTorsor.CuspCoordinates.t_zero π hπ]
+    exact hB
+  exact ht.comp (SpecialPeriods.MuTorsor.CuspCoordinates.t_analyticAt_zero π hπ)
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.cusp_formula_eventually_q
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) {β : ℍ → ℂ}
+    {τ : ℍ → ℍ} {B : ℂ → ℂ} {R : ℝ}
+    (hformula :
+      ∀ z ∈ SpecialPeriods.Triangle.horodisc SpecialPeriods.Triangle.width,
+        R < ‖finiteProjection π z‖ → β z + (τ z : ℂ) = B (finiteProjection π z)⁻¹) :
+    ∀ᶠ z in UpperHalfPlane.atImInfty,
+      β z + (τ z : ℂ) = qExtension π B (SpecialPeriods.Triangle.cuspQ z) := by
+  filter_upwards [SpecialPeriods.MuTorsor.CuspCoordinates.eventually_mem_horodisc
+      SpecialPeriods.Triangle.width,
+    SpecialPeriods.MuTorsor.CuspCoordinates.eventually_lt_norm_finiteProjection π hπ R,
+    SpecialPeriods.MuTorsor.CuspCoordinates.t_cuspQ_eq_inv_finiteProjection π hπ] with z hz hRz ht
+  rw [hformula z hz hRz]
+  change
+    B (finiteProjection π z)⁻¹ =
+      B (SpecialPeriods.MuTorsor.CuspCoordinates.t π (SpecialPeriods.Triangle.cuspQ z))
+  rw [ht]
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.analytic_cusp_formula_to_q_extension
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) {β : ℍ → ℂ}
+    {τ : ℍ → ℍ} {B : ℂ → ℂ} {R : ℝ} (hB : AnalyticAt ℂ B 0)
+    (hformula :
+      ∀ z ∈ SpecialPeriods.Triangle.horodisc SpecialPeriods.Triangle.width,
+        R < ‖finiteProjection π z‖ → β z + (τ z : ℂ) = B (finiteProjection π z)⁻¹) :
+    ∃ C : ℂ → ℂ,
+      AnalyticAt ℂ C 0 ∧
+        C 0 = B 0 ∧
+          ∃ Y : ℝ, ∀ z : ℍ, Y < z.im → β z + (τ z : ℂ) = C (SpecialPeriods.Triangle.cuspQ z) := by
+  refine ⟨qExtension π B, qExtension_analyticAt_zero π hπ hB, qExtension_zero π hπ B, ?_⟩
+  obtain ⟨Y, hY⟩ := (UpperHalfPlane.atImInfty_mem _).mp (cusp_formula_eventually_q π hπ hformula)
+  exact ⟨Y, fun z hz => hY z hz.le⟩
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.tendsto_of_analytic_cusp_formula
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) {β : ℍ → ℂ}
+    {τ : ℍ → ℍ} {B : ℂ → ℂ} {R : ℝ} (hB : AnalyticAt ℂ B 0)
+    (hformula :
+      ∀ z ∈ SpecialPeriods.Triangle.horodisc SpecialPeriods.Triangle.width,
+        R < ‖finiteProjection π z‖ → β z + (τ z : ℂ) = B (finiteProjection π z)⁻¹) :
+    Filter.Tendsto (fun z : ℍ => β z + (τ z : ℂ)) UpperHalfPlane.atImInfty (𝓝 (B 0)) := by
+  have hlim :
+    Filter.Tendsto (fun z : ℍ => B (finiteProjection π z)⁻¹) UpperHalfPlane.atImInfty (𝓝 (B 0)) :=
+    hB.continuousAt.tendsto.comp
+      ((SpecialPeriods.MuTorsor.CuspCoordinates.finiteProjection_inv_tendsto_zero π hπ).mono_right
+        nhdsWithin_le_nhds)
+  apply hlim.congr'
+  filter_upwards [SpecialPeriods.MuTorsor.CuspCoordinates.eventually_mem_horodisc
+      SpecialPeriods.Triangle.width,
+    SpecialPeriods.MuTorsor.CuspCoordinates.eventually_lt_norm_finiteProjection π hπ R] with z hz
+    hRz
+  exact (hformula z hz hRz).symm
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.bounded_of_analytic_cusp_formula
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) {β : ℍ → ℂ}
+    {τ : ℍ → ℍ} {B : ℂ → ℂ} {R : ℝ} (hB : AnalyticAt ℂ B 0)
+    (hformula :
+      ∀ z ∈ SpecialPeriods.Triangle.horodisc SpecialPeriods.Triangle.width,
+        R < ‖finiteProjection π z‖ → β z + (τ z : ℂ) = B (finiteProjection π z)⁻¹) :
+    ∃ Y M : ℝ, ∀ z : ℍ, Y < z.im → ‖β z + (τ z : ℂ)‖ ≤ M := by
+  have hlim := (tendsto_of_analytic_cusp_formula π hπ hB hformula).norm
+  have hbound : ∀ᶠ z in UpperHalfPlane.atImInfty, ‖β z + (τ z : ℂ)‖ < ‖B 0‖ + 1 :=
+    hlim.eventually (Iio_mem_nhds (lt_add_one ‖B 0‖))
+  obtain ⟨Y, hY⟩ := (UpperHalfPlane.atImInfty_mem _).mp hbound
+  exact ⟨Y, ‖B 0‖ + 1, fun z hz => (hY z hz.le).le⟩
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private structure SpecialPeriods.BetaTorsor.Data.IsSolution (D : SpecialPeriods.BetaTorsor.Data)
+    (β : ℍ → ℂ) : Prop where
+  holomorphic : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω β
+  generators : D.GeneratorLaws β
+  cusp_bounded : ∃ Y M : ℝ, ∀ z : ℍ, Y < z.im → ‖β z + (D.tau z : ℂ)‖ ≤ M
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.BetaTorsor.Data.exists_solution_with_cusp_extension
+    (D : SpecialPeriods.BetaTorsor.Data)
+    (π : Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω)
+    (hπ : π SpecialPeriods.triangleCuspPoint = ((OnePoint.infty) : RiemannSphere)) :
+    ∃ (β : ℍ → ℂ) (C : ℂ → ℂ),
+      D.IsSolution β ∧
+        AnalyticAt ℂ C 0 ∧
+          C 0 = 0 ∧
+            ∃ Y : ℝ,
+              ∀ z : ℍ, Y < z.im → β z + (D.tau z : ℂ) = C (SpecialPeriods.Triangle.cuspQ z) := by
+  obtain ⟨R, hR, β, B, hβ, hgen, hB, hB0, hformula⟩ := D.exists_global_beta π hπ
+  have hBzero : AnalyticAt ℂ B 0 := hB 0 (Metric.mem_ball_self (inv_pos.mpr hR))
+  obtain ⟨Y, M, hbound⟩ :=
+    SpecialPeriods.BetaTorsor.bounded_of_analytic_cusp_formula π hπ hBzero hformula
+  obtain ⟨C, hC, hC0, Y', hCformula⟩ :=
+    SpecialPeriods.BetaTorsor.analytic_cusp_formula_to_q_extension π hπ hBzero hformula
+  exact ⟨β, C, ⟨hβ, hgen, Y, M, hbound⟩, hC, hC0.trans hB0, Y', hCformula⟩
+
+private theorem
+    SpecialPeriods.exists_compact_cutoff_of_tendsto_atBot {B : Type*} [TopologicalSpace B]
+    [CompactSpace B] (p : B) (f : B → ℝ) (hf : Filter.Tendsto f (𝓝[≠] p) Filter.atBot) :
+    ∃ K : Set B,
+      IsCompact K ∧ K ⊆ ({ p } : Set B)ᶜ ∧ ∀ x : B, x ∈ ({ p } : Set B)ᶜ → x ∉ K → f x < 0 := by
+  obtain ⟨U, hU, hpU, hUf⟩ := mem_nhdsWithin.mp (hf.eventually_lt_atBot 0)
+  refine ⟨Uᶜ, hU.isClosed_compl.isCompact, ?_, ?_⟩
+  · intro x hx hp
+    have hxp : x = p := by simpa only [Set.mem_singleton_iff] using hp
+    exact hx (hxp ▸ hpU)
+  · intro x hxp hx
+    exact hUf ⟨Classical.not_not.mp hx, hxp⟩
+
+private theorem
+    SpecialPeriods.bddAbove_image_punctured_of_tendsto_atBot {B : Type*} [TopologicalSpace B]
+    [CompactSpace B] (p : B) (f : B → ℝ) (hc : ContinuousOn f ({ p } : Set B)ᶜ)
+    (hf : Filter.Tendsto f (𝓝[≠] p) Filter.atBot) : BddAbove (f '' ({ p } : Set B)ᶜ) := by
+  obtain ⟨K, hK, hKp, hneg⟩ := exists_compact_cutoff_of_tendsto_atBot p f hf
+  obtain ⟨C, hC⟩ := hK.bddAbove_image (hc.mono hKp)
+  refine ⟨Max.max C 0, ?_⟩
+  rintro _ ⟨x, hx, rfl⟩
+  by_cases hxK : x ∈ K
+  · exact (hC (Set.mem_image_of_mem f hxK)).trans (le_max_left _ _)
+  · exact (hneg x hx hxK).le.trans (le_max_right _ _)
+
+private def
+    SpecialPeriods.BetaTorsor.Data.periodPoint (D : SpecialPeriods.BetaTorsor.Data) (β : ℍ → ℂ)
+    (z : ℍ) : PeriodPoint :=
+  ⟨(D.tau z : ℂ), D.mu z, β z⟩
+
+private def
+    SpecialPeriods.BetaTorsor.Data.periodMap (D : SpecialPeriods.BetaTorsor.Data) (β : ℍ → ℂ)
+    (hβ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω β) (hAdm : ∀ z : ℍ, (D.periodPoint β z).Admissible) :
+    HolomorphicPeriodMap ℂ ℍ
+    where
+  point z := ⟨D.periodPoint β z, hAdm z⟩
+  holomorphic_tau := UpperHalfPlane.contMDiff_coe.comp D.tau_holomorphic
+  holomorphic_mu := D.mu_holomorphic
+  holomorphic_beta := hβ
+
+private def SpecialPeriods.BetaTorsor.Data.shiftedPeriodMap (D : SpecialPeriods.BetaTorsor.Data)
+    (β : ℍ → ℂ) (hβ : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω β) (c : ℂ)
+    (hAdm : ∀ z : ℍ, ((D.periodPoint β z).shiftBeta c).Admissible) : HolomorphicPeriodMap ℂ ℍ :=
+  D.periodMap (fun z => β z + c) (hβ.add contMDiff_const) hAdm
+
+private def
+    SpecialPeriods.triangleRealRepresentation : TriangleGroup →* (RealPlane₄ ≃ₗ[ℝ] RealPlane₄) :=
+  Matrix.SpecialLinearGroup.toLin'.comp
+    ((Matrix.SpecialLinearGroup.map (Int.castRingHom ℝ)).comp triangleDualRepresentation)
+
+/-- The real-linear equivalence induced by an element of the triangle group. -/
+public
+def SpecialPeriods.triangleRealEquiv (g : TriangleGroup) : RealPlane₄ ≃ₗ[ℝ] RealPlane₄ :=
+  triangleRealRepresentation g
+
+private theorem SpecialPeriods.triangleRealEquiv_apply (g : TriangleGroup) (x : RealPlane₄) :
+    triangleRealEquiv g x =
+      (triangleDualRepresentation g : LatticeMatrix).map (Int.castRingHom ℝ) *ᵥ x :=
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.triangleRealEquiv_one :
+    triangleRealEquiv 1 = LinearEquiv.refl ℝ RealPlane₄ :=
+  triangleRealRepresentation.map_one
+
+private theorem SpecialPeriods.triangleRealEquiv_mul (g h : TriangleGroup) :
+    triangleRealEquiv (g * h) = triangleRealEquiv g * triangleRealEquiv h :=
+  triangleRealRepresentation.map_mul g h
+
+private theorem SpecialPeriods.triangleRealEquiv_mul_apply (g h : TriangleGroup) (x : RealPlane₄) :
+    triangleRealEquiv (g * h) x = triangleRealEquiv g (triangleRealEquiv h x) := by
+  rw [triangleRealEquiv_mul]
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.triangleRealEquiv_inv (g : TriangleGroup) :
+    triangleRealEquiv g⁻¹ = (triangleRealEquiv g).symm :=
+  triangleRealRepresentation.map_inv g
+
+private theorem SpecialPeriods.triangleRealEquiv_realCast (g : TriangleGroup) (v : Lattice) :
+    triangleRealEquiv g (Elliptic.realCast v) =
+      Elliptic.realCast ((triangleDualRepresentation g : LatticeMatrix) *ᵥ v) := by
+  rw [triangleRealEquiv_apply]
+  ext i
+  exact
+    (RingHom.map_mulVec (Int.castRingHom ℝ) (triangleDualRepresentation g : LatticeMatrix) v
+        i).symm
+
+private theorem
+    SpecialPeriods.triangleRealEquiv_mem_standardLattice (g : TriangleGroup) {x : RealPlane₄}
+    (hx : x ∈ standardLattice) : triangleRealEquiv g x ∈ standardLattice := by
+  obtain ⟨v, rfl⟩ := (Elliptic.standardLattice_mem_iff x).mp hx
+  exact
+    (Elliptic.standardLattice_mem_iff _).mpr
+      ⟨(triangleDualRepresentation g : LatticeMatrix) *ᵥ v, triangleRealEquiv_realCast g v⟩
+
+private theorem SpecialPeriods.triangleRealEquiv_map_standardLattice (g : TriangleGroup) :
+    standardLattice.map ((triangleRealEquiv g).restrictScalars ℤ).toLinearMap = standardLattice :=
+  by
+  ext x
+  rw [Submodule.mem_map]
+  constructor
+  · rintro ⟨y, hy, rfl⟩
+    exact triangleRealEquiv_mem_standardLattice g hy
+  · intro hx
+    refine ⟨triangleRealEquiv g⁻¹ x, triangleRealEquiv_mem_standardLattice g⁻¹ hx, ?_⟩
+    change triangleRealEquiv g (triangleRealEquiv g⁻¹ x) = x
+    rw [triangleRealEquiv_inv, LinearEquiv.apply_symm_apply]
+
+private def
+    SpecialPeriods.triangleTorusLinearEquiv (g : TriangleGroup) : RealTorus₄ ≃ₗ[ℤ] RealTorus₄ :=
+  Submodule.Quotient.equiv standardLattice standardLattice
+    ((triangleRealEquiv g).restrictScalars ℤ) (triangleRealEquiv_map_standardLattice g)
+
+private def SpecialPeriods.triangleTorusHomeomorph (g : TriangleGroup) : RealTorus₄ ≃ₜ RealTorus₄
+    where
+  toEquiv := (triangleTorusLinearEquiv g).toEquiv
+  continuous_toFun := by
+    apply standardLattice.isQuotientMap_mkQ.continuous_iff.mpr
+    exact
+      standardLattice.continuous_mkQ.comp (triangleRealEquiv g).toContinuousLinearEquiv.continuous
+  continuous_invFun := by
+    apply standardLattice.isQuotientMap_mkQ.continuous_iff.mpr
+    exact
+      standardLattice.continuous_mkQ.comp
+        (triangleRealEquiv g).symm.toContinuousLinearEquiv.continuous
+
+private theorem SpecialPeriods.triangleTorusHomeomorph_mkQ (g : TriangleGroup) (x : RealPlane₄) :
+    triangleTorusHomeomorph g (standardLattice.mkQ x) =
+      standardLattice.mkQ (triangleRealEquiv g x) :=
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.triangleTorusHomeomorph_zero (g : TriangleGroup) :
+    triangleTorusHomeomorph g 0 = 0 :=
+  (triangleTorusLinearEquiv g).map_zero
+
+private theorem SpecialPeriods.triangleTorusHomeomorph_add (g : TriangleGroup) (x y : RealTorus₄) :
+    triangleTorusHomeomorph g (x + y) =
+      triangleTorusHomeomorph g x + triangleTorusHomeomorph g y :=
+  (triangleTorusLinearEquiv g).map_add x y
+
+private theorem SpecialPeriods.triangleTorusHomeomorph_one_apply (x : RealTorus₄) :
+    triangleTorusHomeomorph 1 x = x := by
+  obtain ⟨y, rfl⟩ := standardLattice.mkQ_surjective x
+  rw [triangleTorusHomeomorph_mkQ, triangleRealEquiv_one]
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.triangleTorusHomeomorph_one :
+    triangleTorusHomeomorph 1 = Homeomorph.refl RealTorus₄ := by
+  apply Homeomorph.ext
+  exact triangleTorusHomeomorph_one_apply
+
+private theorem
+    SpecialPeriods.triangleTorusHomeomorph_mul_apply (g h : TriangleGroup) (x : RealTorus₄) :
+    triangleTorusHomeomorph (g * h) x = triangleTorusHomeomorph g (triangleTorusHomeomorph h x) :=
+  by
+  obtain ⟨y, rfl⟩ := standardLattice.mkQ_surjective x
+  rw [triangleTorusHomeomorph_mkQ, triangleTorusHomeomorph_mkQ, triangleTorusHomeomorph_mkQ,
+    triangleRealEquiv_mul_apply]
+
+private theorem SpecialPeriods.triangleTorusHomeomorph_mul (g h : TriangleGroup) :
+    triangleTorusHomeomorph (g * h) =
+      (triangleTorusHomeomorph h).trans (triangleTorusHomeomorph g) := by
+  apply Homeomorph.ext
+  exact triangleTorusHomeomorph_mul_apply g h
+
+@[simp]
+private theorem SpecialPeriods.triangleTorusHomeomorph_inv (g : TriangleGroup) :
+    triangleTorusHomeomorph g⁻¹ = (triangleTorusHomeomorph g).symm := by
+  apply Homeomorph.ext
+  intro x
+  apply (triangleTorusHomeomorph g).injective
+  rw [← triangleTorusHomeomorph_mul_apply, mul_inv_cancel, triangleTorusHomeomorph_one_apply,
+    Homeomorph.apply_symm_apply]
+
+@[instance_reducible]
+private def SpecialPeriods.triangleTorusAction : MulAction TriangleGroup RealTorus₄
+    where
+  smul g x := triangleTorusHomeomorph g x
+  one_smul := triangleTorusHomeomorph_one_apply
+  mul_smul := triangleTorusHomeomorph_mul_apply
+
+private theorem SpecialPeriods.triangleTorusAction_mkQ (g : TriangleGroup) (x : RealPlane₄) :
+    letI := triangleTorusAction
+    g • standardLattice.mkQ x =
+      standardLattice.mkQ
+        ((triangleDualRepresentation g : LatticeMatrix).map (Int.castRingHom ℝ) *ᵥ x) := by
+  change triangleTorusHomeomorph g (standardLattice.mkQ x) = _
+  rw [triangleTorusHomeomorph_mkQ, triangleRealEquiv_apply]
+
+@[simp]
+private theorem SpecialPeriods.triangleTorusAction_zero (g : TriangleGroup) :
+    letI := triangleTorusAction
+    g • (0 : RealTorus₄) = 0 :=
+  triangleTorusHomeomorph_zero g
+
+private theorem SpecialPeriods.triangleTorusAction_continuous :
+    letI := triangleTorusAction
+    ContinuousConstSMul TriangleGroup RealTorus₄ := by
+  let := triangleTorusAction
+  exact ⟨fun g => (triangleTorusHomeomorph g).continuous⟩
+
+private theorem SpecialPeriods.triangleTorusAction_generator₁_mkQ (x : RealPlane₄) :
+    letI := triangleTorusAction
+    triangleGenerator₁ • standardLattice.mkQ x =
+      standardLattice.mkQ (Elliptic.flatLinear .three x) := by
+  let := triangleTorusAction
+  rw [triangleTorusAction_mkQ, triangleDualRepresentation_generator₁_matrix]
+  rfl
+
+private theorem SpecialPeriods.triangleTorusAction_generator₂_mkQ (x : RealPlane₄) :
+    letI := triangleTorusAction
+    triangleGenerator₂ • standardLattice.mkQ x =
+      standardLattice.mkQ (Elliptic.flatLinear .four x) := by
+  let := triangleTorusAction
+  rw [triangleTorusAction_mkQ, triangleDualRepresentation_generator₂_matrix]
+  rfl
+
+private def SpecialPeriods.Triangle.firstSector : Set ℍ :=
+  {z | z.re < -(1 / 2) ∧ 1 < ‖(z : ℂ)‖}
+
+private def SpecialPeriods.Triangle.secondSector : Set ℍ :=
+  {z | stripLeft < z.re ∧ stripRight < ‖(z : ℂ) - (stripLeft : ℂ)‖}
+
+private def SpecialPeriods.Triangle.firstExcluded : Set ℍ :=
+  {z | -(1 / 2) < z.re ∨ ‖(z : ℂ)‖ < 1}
+
+private def SpecialPeriods.Triangle.secondExcluded : Set ℍ :=
+  {z | z.re < stripLeft ∨ ‖(z : ℂ) - (stripLeft : ℂ)‖ < stripRight}
+
+private def SpecialPeriods.Triangle.circularDoubleInterior : Set ℍ :=
+  firstSector ∩ secondSector
+
+private theorem SpecialPeriods.Triangle.stripLeft_add_stripRight : stripLeft + stripRight = -1 := by
+  unfold stripLeft stripRight
+  ring
+
+private theorem SpecialPeriods.Triangle.stripLeft_lt_neg_one : stripLeft < -1 := by
+  linarith [stripLeft_add_stripRight, stripRight_pos]
+
+private theorem
+    SpecialPeriods.Triangle.firstExcluded_subset_pingPongOne : firstExcluded ⊆ pingPongOne := by
+  intro z hz
+  rcases hz with hx | hn
+  · change -1 < z.re
+    linarith
+  · have hr := Complex.re_le_norm (-(z : ℂ))
+    simp only [Complex.neg_re, UpperHalfPlane.coe_re, norm_neg] at hr
+    change -1 < z.re
+    linarith
+
+private theorem SpecialPeriods.Triangle.secondExcluded_subset_pingPongTwo :
+    secondExcluded ⊆ pingPongTwo := by
+  intro z hz
+  rcases hz with hx | hn
+  · exact hx.trans stripLeft_lt_neg_one
+  · have hr := Complex.re_le_norm ((z : ℂ) - (stripLeft : ℂ))
+    simp only [Complex.sub_re, UpperHalfPlane.coe_re, Complex.ofReal_re] at hr
+    change z.re < -1
+    linarith [stripLeft_add_stripRight]
+
+private theorem
+    SpecialPeriods.Triangle.pingPongTwo_subset_firstSector : pingPongTwo ⊆ firstSector := by
+  intro z hz
+  change z.re < -1 at hz
+  refine ⟨by linarith, ?_⟩
+  have hr := Complex.re_le_norm (-(z : ℂ))
+  simp only [Complex.neg_re, UpperHalfPlane.coe_re, norm_neg] at hr
+  linarith
+
+private theorem
+    SpecialPeriods.Triangle.pingPongOne_subset_secondSector : pingPongOne ⊆ secondSector := by
+  intro z hz
+  change -1 < z.re at hz
+  refine ⟨stripLeft_lt_neg_one.trans hz, ?_⟩
+  have hr := Complex.re_le_norm ((z : ℂ) - (stripLeft : ℂ))
+  simp only [Complex.sub_re, UpperHalfPlane.coe_re, Complex.ofReal_re] at hr
+  linarith [stripLeft_add_stripRight]
+
+private theorem SpecialPeriods.Triangle.secondExcluded_subset_firstSector :
+    secondExcluded ⊆ firstSector :=
+  secondExcluded_subset_pingPongTwo.trans pingPongTwo_subset_firstSector
+
+private theorem SpecialPeriods.Triangle.firstExcluded_subset_secondSector :
+    firstExcluded ⊆ secondSector :=
+  firstExcluded_subset_pingPongOne.trans pingPongOne_subset_secondSector
+
+private theorem SpecialPeriods.Triangle.circularDoubleInterior_disjoint_firstExcluded :
+    Disjoint circularDoubleInterior firstExcluded := by
+  apply Set.disjoint_left.mpr
+  intro z hz he
+  rcases he with hx | hn
+  · exact lt_asymm hz.1.1 hx
+  · exact lt_asymm hz.1.2 hn
+
+private theorem SpecialPeriods.Triangle.circularDoubleInterior_disjoint_secondExcluded :
+    Disjoint circularDoubleInterior secondExcluded := by
+  apply Set.disjoint_left.mpr
+  intro z hz he
+  rcases he with hx | hn
+  · exact lt_asymm hz.2.1 hx
+  · exact lt_asymm hz.2.2 hn
+
+private theorem SpecialPeriods.Triangle.generatorOne_firstSector :
+    Set.MapsTo (fun z : ℍ => generatorOneSL • z) firstSector firstExcluded := by
+  intro z hz
+  left
+  change -(1 / 2) < (((generatorOneSL • z : ℍ) : ℂ)).re
+  rw [generatorOneSL_smul_coe]
+  simp only [Complex.neg_re, Complex.inv_re, Complex.add_re, UpperHalfPlane.coe_re,
+    Complex.one_re]
+  have hd := Complex.normSq_pos.mpr (denominatorOne_ne_zero z)
+  have hn : 1 < Complex.normSq (z : ℂ) := by
+    rw [Complex.normSq_eq_norm_sq]
+    nlinarith [hz.2]
+  simp only [← neg_div]
+  apply (lt_div_iff₀ hd).mpr
+  simp only [Complex.normSq_apply, Complex.add_re, Complex.one_re, Complex.add_im, Complex.one_im,
+    add_zero, UpperHalfPlane.coe_re, UpperHalfPlane.coe_im] at hn ⊢
+  nlinarith
+
+private theorem SpecialPeriods.Triangle.norm_add_one_lt_norm_of_re_lt_half (z : ℍ)
+    (hz : z.re < -(1 / 2)) : ‖(z : ℂ) + 1‖ < ‖(z : ℂ)‖ := by
+  have hsq : ‖(z : ℂ) + 1‖ ^ 2 < ‖(z : ℂ)‖ ^ 2 := by
+    simp only [Complex.sq_norm, Complex.normSq_apply, Complex.add_re, Complex.one_re,
+      Complex.add_im, Complex.one_im, add_zero, UpperHalfPlane.coe_re, UpperHalfPlane.coe_im]
+    linarith
+  nlinarith [norm_nonneg ((z : ℂ) + 1), norm_nonneg (z : ℂ)]
+
+private theorem SpecialPeriods.Triangle.generatorOne_sq_firstSector :
+    Set.MapsTo (fun z : ℍ => (generatorOneSL ^ 2) • z) firstSector firstExcluded := by
+  intro z hz
+  right
+  change ‖(((generatorOneSL ^ 2) • z : ℍ) : ℂ)‖ < 1
+  rw [generatorOneSL_sq_smul_coe]
+  have he : (-1 : ℂ) - (z : ℂ)⁻¹ = -(((z : ℂ) + 1) / (z : ℂ)) := by
+    field_simp [z.ne_zero]
+    ring
+  rw [he, norm_neg, norm_div]
+  exact (div_lt_one (norm_pos_iff.mpr z.ne_zero)).mpr (norm_add_one_lt_norm_of_re_lt_half z hz.1)
+
+private def SpecialPeriods.Triangle.secondShift_mo1973_18636 (z : ℍ) : ℂ :=
+  (z : ℂ) - (stripLeft : ℂ)
+
+private theorem SpecialPeriods.Triangle.secondShift_re_mo1973_18637 (z : ℍ) :
+    (secondShift_mo1973_18636 z).re = z.re - stripLeft := by simp [secondShift_mo1973_18636]
+
+private theorem SpecialPeriods.Triangle.secondShift_add_real_ne_zero_mo1973_18638 (z : ℍ)
+    (a : ℝ) : secondShift_mo1973_18636 z + (a : ℂ) ≠ 0 := by
+  intro h
+  have hi := congrArg Complex.im h
+  simp only [secondShift_mo1973_18636, Complex.sub_im, Complex.add_im, Complex.ofReal_im,
+    sub_zero, add_zero, Complex.zero_im, UpperHalfPlane.coe_im] at hi
+  exact z.im_ne_zero hi
+
+private theorem SpecialPeriods.Triangle.stripLeft_eq_neg_stripRight_sub_one_mo1973_18639 :
+    stripLeft = -stripRight - 1 := by linarith [stripLeft_add_stripRight]
+
+private theorem SpecialPeriods.Triangle.width_eq_two_stripRight_add_one_mo1973_18640 :
+    width = 2 * stripRight + 1 := by
+  unfold stripRight
+  ring
+
+private theorem SpecialPeriods.Triangle.stripRight_sq_complex_mo1973_18641 :
+    (stripRight : ℂ) ^ 2 = 1 / 2 := by
+  rw [← Complex.ofReal_pow, stripRight_sq]
+  norm_num
+
+private theorem SpecialPeriods.Triangle.generatorTwo_secondShift_mo1973_18642 (z : ℍ) :
+    secondShift_mo1973_18636 (generatorTwoSL • z) =
+      (stripRight : ℂ) * (secondShift_mo1973_18636 z - stripRight) /
+        (secondShift_mo1973_18636 z + stripRight) := by
+  have hd := secondShift_add_real_ne_zero_mo1973_18638 z stripRight
+  have hs := stripRight_sq_complex_mo1973_18641
+  unfold secondShift_mo1973_18636 at *
+  rw [generatorTwoSL_smul_coe]
+  rw [stripLeft_eq_neg_stripRight_sub_one_mo1973_18639,
+    width_eq_two_stripRight_add_one_mo1973_18640] at *
+  push_cast at *
+  have he :
+    (z : ℂ) + (2 * (stripRight : ℂ) + 1) = (z : ℂ) - (-(stripRight : ℂ) - 1) + stripRight := by
+    ring
+  rw [he]
+  field_simp [hd]
+  linear_combination 2 * hs
+
+private theorem SpecialPeriods.Triangle.generatorTwo_sq_secondShift_mo1973_18643 (z : ℍ) :
+    secondShift_mo1973_18636 ((generatorTwoSL ^ 2 : SL(2, ℝ)) • z) =
+      -(stripRight : ℂ) ^ 2 / secondShift_mo1973_18636 z := by
+  have hz : secondShift_mo1973_18636 z ≠ 0 := by
+    simpa using secondShift_add_real_ne_zero_mo1973_18638 z 0
+  have hd := secondShift_add_real_ne_zero_mo1973_18638 z stripRight
+  have hR : (stripRight : ℂ) ≠ 0 := by exact_mod_cast stripRight_pos.ne'
+  rw [pow_two, SemigroupAction.mul_smul, generatorTwo_secondShift_mo1973_18642,
+    generatorTwo_secondShift_mo1973_18642]
+  field_simp [hz, hd, hR]
+  ring
+
+private theorem SpecialPeriods.Triangle.generatorTwo_cube_secondShift_mo1973_18644 (z : ℍ) :
+    secondShift_mo1973_18636 ((generatorTwoSL ^ 3 : SL(2, ℝ)) • z) =
+      -(stripRight : ℂ) * (secondShift_mo1973_18636 z + stripRight) /
+        (secondShift_mo1973_18636 z - stripRight) := by
+  have hd : secondShift_mo1973_18636 z - (stripRight : ℂ) ≠ 0 := by
+    simpa only [Complex.ofReal_neg, sub_eq_add_neg] using
+      secondShift_add_real_ne_zero_mo1973_18638 z (-stripRight)
+  have hs := stripRight_sq_complex_mo1973_18641
+  unfold secondShift_mo1973_18636 at *
+  rw [generatorTwoSL_cube_smul_coe]
+  rw [stripLeft_eq_neg_stripRight_sub_one_mo1973_18639,
+    width_eq_two_stripRight_add_one_mo1973_18640] at *
+  push_cast at *
+  have he : (z : ℂ) + 1 = (z : ℂ) - (-(stripRight : ℂ) - 1) - stripRight := by ring
+  rw [he]
+  field_simp [hd]
+  linear_combination 2 * hs
+
+private theorem SpecialPeriods.Triangle.norm_sub_div_add_lt_one_mo1973_18645 {r : ℝ} (hr : 0 < r)
+    {u : ℂ} (hu : 0 < u.re) : ‖(u - (r : ℂ)) / (u + (r : ℂ))‖ < 1 := by
+  have hd : u + (r : ℂ) ≠ 0 := by
+    intro h
+    have h' := congrArg Complex.re h
+    simp only [Complex.add_re, Complex.ofReal_re, Complex.zero_re] at h'
+    linarith
+  rw [norm_div]
+  apply (div_lt_one (norm_pos_iff.mpr hd)).mpr
+  have hsq : ‖u - (r : ℂ)‖ ^ 2 < ‖u + (r : ℂ)‖ ^ 2 := by
+    simp only [Complex.sq_norm, Complex.normSq_apply, Complex.sub_re, Complex.add_re,
+      Complex.sub_im, Complex.add_im, Complex.ofReal_re, Complex.ofReal_im, sub_zero, add_zero]
+    nlinarith [mul_pos hr hu]
+  nlinarith [norm_nonneg (u - (r : ℂ)), norm_nonneg (u + (r : ℂ))]
+
+private theorem SpecialPeriods.Triangle.re_add_div_sub_pos_mo1973_18646 {r : ℝ} (hr : 0 < r)
+    {u : ℂ} (hu : r < ‖u‖) : 0 < ((u + (r : ℂ)) / (u - (r : ℂ))).re := by
+  have hd : u - (r : ℂ) ≠ 0 := by
+    intro h
+    have he : u = (r : ℂ) := sub_eq_zero.mp h
+    rw [he, Complex.norm_real, Real.norm_eq_abs, abs_of_pos hr] at hu
+    exact lt_irrefl r hu
+  have hsq : r ^ 2 < Complex.normSq u := by
+    rw [Complex.normSq_eq_norm_sq]
+    nlinarith
+  rw [Complex.div_re, ← add_div]
+  apply div_pos ?_ (Complex.normSq_pos.mpr hd)
+  simp only [Complex.add_re, Complex.sub_re, Complex.ofReal_re, Complex.add_im, Complex.sub_im,
+    Complex.ofReal_im, add_zero, sub_zero]
+  rw [Complex.normSq_apply] at hsq
+  nlinarith
+
+private theorem SpecialPeriods.Triangle.re_neg_sq_div_neg_mo1973_18647 {r : ℝ} (hr : 0 < r)
+    {u : ℂ} (hu : 0 < u.re) : (-(r : ℂ) ^ 2 / u).re < 0 := by
+  have hd : u ≠ 0 := by
+    intro h
+    simp [h] at hu
+  have hnum : -(r ^ 2) * u.re < 0 := mul_neg_of_neg_of_pos (neg_neg_of_pos (sq_pos_of_pos hr)) hu
+  simpa [Complex.div_re, ← Complex.ofReal_pow] using
+    div_neg_of_neg_of_pos hnum (Complex.normSq_pos.mpr hd)
+
+private theorem SpecialPeriods.Triangle.generatorTwo_secondSector :
+    Set.MapsTo (fun z : ℍ => generatorTwoSL • z) secondSector secondExcluded := by
+  intro z hz
+  refine Or.inr ?_
+  change ‖secondShift_mo1973_18636 (generatorTwoSL • z)‖ < stripRight
+  rw [generatorTwo_secondShift_mo1973_18642, mul_div_assoc, norm_mul, Complex.norm_real,
+    Real.norm_eq_abs, abs_of_pos stripRight_pos]
+  have hrez : 0 < (secondShift_mo1973_18636 z).re := by
+    rw [secondShift_re_mo1973_18637]
+    exact sub_pos.mpr hz.1
+  simpa only [mul_one] using
+    mul_lt_mul_of_pos_left (norm_sub_div_add_lt_one_mo1973_18645 stripRight_pos hrez)
+      stripRight_pos
+
+private theorem SpecialPeriods.Triangle.generatorTwo_sq_secondSector :
+    Set.MapsTo (fun z : ℍ => (generatorTwoSL ^ 2 : SL(2, ℝ)) • z) secondSector secondExcluded := by
+  intro z hz
+  refine Or.inl ?_
+  have hrez : 0 < (secondShift_mo1973_18636 z).re := by
+    rw [secondShift_re_mo1973_18637]
+    exact sub_pos.mpr hz.1
+  have h := re_neg_sq_div_neg_mo1973_18647 stripRight_pos hrez
+  rw [← generatorTwo_sq_secondShift_mo1973_18643 z, secondShift_re_mo1973_18637] at h
+  exact sub_neg.mp h
+
+private theorem SpecialPeriods.Triangle.generatorTwo_cube_secondSector :
+    Set.MapsTo (fun z : ℍ => (generatorTwoSL ^ 3 : SL(2, ℝ)) • z) secondSector secondExcluded := by
+  intro z hz
+  refine Or.inl ?_
+  have hnorm : stripRight < ‖secondShift_mo1973_18636 z‖ := hz.2
+  have h : (secondShift_mo1973_18636 ((generatorTwoSL ^ 3 : SL(2, ℝ)) • z)).re < 0 := by
+    rw [generatorTwo_cube_secondShift_mo1973_18644, mul_div_assoc]
+    simp only [Complex.mul_re, Complex.neg_re, Complex.ofReal_re, Complex.neg_im,
+      Complex.ofReal_im, neg_zero, MulZeroClass.zero_mul, sub_zero]
+    exact
+      mul_neg_of_neg_of_pos (neg_neg_of_pos stripRight_pos)
+        (re_add_div_sub_pos_mo1973_18646 stripRight_pos hnorm)
+  rw [secondShift_re_mo1973_18637] at h
+  exact sub_neg.mp h
+
+private theorem SpecialPeriods.lift_neWord_domain_subset_mo1973_18651 {ι G α : Type*} [Group G]
+    [MulAction G α] {H : ι → Type*} [∀ i, Group (H i)] (f : ∀ i, H i →* G) (X : ι → Set α)
+    (D : Set α) (hpp : Pairwise fun i j => ∀ h : H i, h ≠ 1 → f i h • X j ⊆ X i)
+    (hD : ∀ i (h : H i), h ≠ 1 → f i h • D ⊆ X i) {i j : ι} (w : Monoid.CoprodI.NeWord H i j) :
+    Monoid.CoprodI.lift f w.prod • D ⊆ X i := by
+  induction w with
+  | singleton x hx => simpa using hD _ x hx
+  | @append i j k l w₁ hne w₂ _ih₁ ih₂ =>
+    calc
+      Monoid.CoprodI.lift f (Monoid.CoprodI.NeWord.append w₁ hne w₂).prod • D =
+          Monoid.CoprodI.lift f w₁.prod • Monoid.CoprodI.lift f w₂.prod • D := by
+        simp [SemigroupAction.mul_smul]
+      _ ⊆ Monoid.CoprodI.lift f w₁.prod • X k := (Set.smul_set_subset_smul_set_iff.mpr ih₂)
+      _ ⊆ X i := Monoid.CoprodI.lift_word_ping_pong f X hpp w₁ hne
+
+private theorem SpecialPeriods.tiling_cyclicPowerHom_two_mo1973_18652 {G : Type*} [Group G]
+    (n : ℕ) (a : G) (ha : a ^ n = 1) :
+    cyclicPowerHom n a ha (Multiplicative.ofAdd (2 : ZMod n)) = a ^ 2 := by
+  simpa only [Int.cast_ofNat, zpow_ofNat] using cyclicPowerHom_intCast n a ha (2 : ℤ)
+
+private theorem SpecialPeriods.tiling_cyclicPowerHom_three_mo1973_18653 {G : Type*} [Group G]
+    (n : ℕ) (a : G) (ha : a ^ n = 1) :
+    cyclicPowerHom n a ha (Multiplicative.ofAdd (3 : ZMod n)) = a ^ 3 := by
+  simpa only [Int.cast_ofNat, zpow_ofNat] using cyclicPowerHom_intCast n a ha (3 : ℤ)
+
+private theorem SpecialPeriods.cyclicThree_domain_subset_mo1973_18654 {G α : Type*} [Group G]
+    [MulAction G α] (a : G) (ha : a ^ 3 = 1) (S T : Set α) (h₁ : Set.MapsTo (fun z => a • z) S T)
+    (h₂ : Set.MapsTo (fun z => a ^ 2 • z) S T) (g : Multiplicative (ZMod 3)) (hg : g ≠ 1) :
+    cyclicPowerHom 3 a ha g • S ⊆ T := by
+  have hc : g = Multiplicative.ofAdd (1 : ZMod 3) ∨ g = Multiplicative.ofAdd (2 : ZMod 3) :=
+    (by decide :
+        ∀ x : Multiplicative (ZMod 3),
+          x ≠ 1 → x = Multiplicative.ofAdd 1 ∨ x = Multiplicative.ofAdd 2)
+      g hg
+  rcases hc with rfl | rfl
+  · rw [cyclicPowerHom_one]
+    exact Set.smul_set_subset_iff.mpr h₁
+  · rw [tiling_cyclicPowerHom_two_mo1973_18652]
+    exact Set.smul_set_subset_iff.mpr h₂
+
+private theorem SpecialPeriods.cyclicFour_domain_subset_mo1973_18655 {G α : Type*} [Group G]
+    [MulAction G α] (b : G) (hb : b ^ 4 = 1) (S T : Set α) (h₁ : Set.MapsTo (fun z => b • z) S T)
+    (h₂ : Set.MapsTo (fun z => b ^ 2 • z) S T) (h₃ : Set.MapsTo (fun z => b ^ 3 • z) S T)
+    (g : Multiplicative (ZMod 4)) (hg : g ≠ 1) : cyclicPowerHom 4 b hb g • S ⊆ T := by
+  have hc :
+    g = Multiplicative.ofAdd (1 : ZMod 4) ∨
+      g = Multiplicative.ofAdd (2 : ZMod 4) ∨ g = Multiplicative.ofAdd (3 : ZMod 4) :=
+    (by decide :
+        ∀ x : Multiplicative (ZMod 4),
+          x ≠ 1 →
+            x = Multiplicative.ofAdd 1 ∨ x = Multiplicative.ofAdd 2 ∨ x = Multiplicative.ofAdd 3)
+      g hg
+  rcases hc with rfl | rfl | rfl
+  · rw [cyclicPowerHom_one]
+    exact Set.smul_set_subset_iff.mpr h₁
+  · rw [tiling_cyclicPowerHom_two_mo1973_18652]
+    exact Set.smul_set_subset_iff.mpr h₂
+  · rw [tiling_cyclicPowerHom_three_mo1973_18653]
+    exact Set.smul_set_subset_iff.mpr h₃
+
+private theorem
+    SpecialPeriods.triangleLift_mapsTo_pingPongUnion {G α : Type*} [Group G] [MulAction G α]
+    (a b : G) (ha : a ^ 3 = 1) (hb : b ^ 4 = 1) (X Y D : Set α)
+    (ha₁ : Set.MapsTo (fun z => a • z) Y X) (ha₂ : Set.MapsTo (fun z => a ^ 2 • z) Y X)
+    (hb₁ : Set.MapsTo (fun z => b • z) X Y) (hb₂ : Set.MapsTo (fun z => b ^ 2 • z) X Y)
+    (hb₃ : Set.MapsTo (fun z => b ^ 3 • z) X Y) (hDa₁ : Set.MapsTo (fun z => a • z) D X)
+    (hDa₂ : Set.MapsTo (fun z => a ^ 2 • z) D X) (hDb₁ : Set.MapsTo (fun z => b • z) D Y)
+    (hDb₂ : Set.MapsTo (fun z => b ^ 2 • z) D Y) (hDb₃ : Set.MapsTo (fun z => b ^ 3 • z) D Y)
+    (g : TriangleGroup) (hg : g ≠ 1) :
+    Set.MapsTo (fun z => triangleLift a b ha hb g • z) D (X ∪ Y) := by
+  classical
+  let H : Bool → Type := fun i => cond i (Multiplicative (ZMod 4)) (Multiplicative (ZMod 3))
+  let : ∀ i, Group (H i) :=
+    Bool.rec (inferInstance : Group (Multiplicative (ZMod 3)))
+      (inferInstance : Group (Multiplicative (ZMod 4)))
+  let f : ∀ i, H i →* G := fun i =>
+    match i with
+    | false => cyclicPowerHom 3 a ha
+    | true => cyclicPowerHom 4 b hb
+  let toI : TriangleGroup →* Monoid.CoprodI H :=
+    Monoid.Coprod.lift (Monoid.CoprodI.of (M := H) (i := Bool.false))
+      (Monoid.CoprodI.of (M := H) (i := Bool.true))
+  let fromI : Monoid.CoprodI H →* TriangleGroup :=
+    Monoid.CoprodI.lift fun i =>
+      match i with
+      | false => Monoid.Coprod.inl
+      | true => Monoid.Coprod.inr
+  have hleft : fromI.comp toI = MonoidHom.id TriangleGroup := by
+    apply triangle_hom_ext
+    · simp [toI, fromI, triangleGenerator₁]
+    · simp [toI, fromI, triangleGenerator₂]
+  have hto_ne : toI g ≠ 1 := by
+    intro h
+    apply hg
+    calc
+      g = fromI (toI g) := (DFunLike.congr_fun hleft g).symm
+      _ = 1 := by rw [h, map_one]
+  have hrepresentation : triangleLift a b ha hb = (Monoid.CoprodI.lift f).comp toI := by
+    apply triangle_hom_ext
+    · simp only [triangleLift_generator₁, MonoidHom.coe_comp, Function.comp_apply]
+      exact (cyclicPowerHom_one 3 a ha).symm
+    · simp only [triangleLift_generator₂, MonoidHom.coe_comp, Function.comp_apply]
+      exact (cyclicPowerHom_one 4 b hb).symm
+  let U : Bool → Set α := fun i => cond i Y X
+  have hpp : Pairwise fun i j => ∀ h : H i, h ≠ 1 → f i h • U j ⊆ U i := by
+    intro i j hij h hh
+    cases i <;> cases j
+    · exact (hij rfl).elim
+    · exact cyclicThree_domain_subset_mo1973_18654 a ha Y X ha₁ ha₂ h hh
+    · exact cyclicFour_domain_subset_mo1973_18655 b hb X Y hb₁ hb₂ hb₃ h hh
+    · exact (hij rfl).elim
+  have hstart : ∀ i (h : H i), h ≠ 1 → f i h • D ⊆ U i := by
+    intro i h hh
+    cases i
+    · exact cyclicThree_domain_subset_mo1973_18654 a ha D X hDa₁ hDa₂ h hh
+    · exact cyclicFour_domain_subset_mo1973_18655 b hb D Y hDb₁ hDb₂ hDb₃ h hh
+  let : (i : Bool) → DecidableEq (H i) := fun _ => Classical.decEq _
+  let r := Monoid.CoprodI.Word.equiv (M := H) (toI g)
+  have hr : r.prod = toI g := (Monoid.CoprodI.Word.equiv (M := H)).symm_apply_apply (toI g)
+  have hr_ne : r ≠ Monoid.CoprodI.Word.empty := by
+    intro h
+    apply hto_ne
+    rw [← hr, h, Monoid.CoprodI.Word.prod_empty]
+  obtain ⟨i, j, w, hw⟩ := Monoid.CoprodI.NeWord.of_word r hr_ne
+  have hwprod : w.prod = toI g := by
+    change w.toWord.prod = toI g
+    rw [hw]
+    exact hr
+  have himage := lift_neWord_domain_subset_mo1973_18651 f U D hpp hstart w
+  have hUi : U i ⊆ X ∪ Y := by
+    cases i
+    · exact Set.subset_union_left
+    · exact Set.subset_union_right
+  have heval : triangleLift a b ha hb g = Monoid.CoprodI.lift f (toI g) :=
+    DFunLike.congr_fun hrepresentation g
+  intro z hz
+  rw [heval, ← hwprod]
+  exact hUi (Set.smul_set_subset_iff.mp himage hz)
+
+private theorem SpecialPeriods.triangleLift_disjoint_domain_translate {G α : Type*} [Group G]
+    [MulAction G α] (a b : G) (ha : a ^ 3 = 1) (hb : b ^ 4 = 1) (X Y D : Set α)
+    (ha₁ : Set.MapsTo (fun z => a • z) Y X) (ha₂ : Set.MapsTo (fun z => a ^ 2 • z) Y X)
+    (hb₁ : Set.MapsTo (fun z => b • z) X Y) (hb₂ : Set.MapsTo (fun z => b ^ 2 • z) X Y)
+    (hb₃ : Set.MapsTo (fun z => b ^ 3 • z) X Y) (hDa₁ : Set.MapsTo (fun z => a • z) D X)
+    (hDa₂ : Set.MapsTo (fun z => a ^ 2 • z) D X) (hDb₁ : Set.MapsTo (fun z => b • z) D Y)
+    (hDb₂ : Set.MapsTo (fun z => b ^ 2 • z) D Y) (hDb₃ : Set.MapsTo (fun z => b ^ 3 • z) D Y)
+    (hDX : Disjoint D X) (hDY : Disjoint D Y) (g : TriangleGroup) (hg : g ≠ 1) :
+    Disjoint D (triangleLift a b ha hb g • D) := by
+  apply (hDX.sup_right hDY).mono_right
+  exact
+    Set.smul_set_subset_iff.mpr
+      (triangleLift_mapsTo_pingPongUnion a b ha hb X Y D ha₁ ha₂ hb₁ hb₂ hb₃ hDa₁ hDa₂ hDb₁ hDb₂
+        hDb₃ g hg)
+
+private theorem
+    SpecialPeriods.triangleLift_eq_one_of_domain_mem {G α : Type*} [Group G] [MulAction G α]
+    (a b : G) (ha : a ^ 3 = 1) (hb : b ^ 4 = 1) (X Y D : Set α)
+    (ha₁ : Set.MapsTo (fun z => a • z) Y X) (ha₂ : Set.MapsTo (fun z => a ^ 2 • z) Y X)
+    (hb₁ : Set.MapsTo (fun z => b • z) X Y) (hb₂ : Set.MapsTo (fun z => b ^ 2 • z) X Y)
+    (hb₃ : Set.MapsTo (fun z => b ^ 3 • z) X Y) (hDa₁ : Set.MapsTo (fun z => a • z) D X)
+    (hDa₂ : Set.MapsTo (fun z => a ^ 2 • z) D X) (hDb₁ : Set.MapsTo (fun z => b • z) D Y)
+    (hDb₂ : Set.MapsTo (fun z => b ^ 2 • z) D Y) (hDb₃ : Set.MapsTo (fun z => b ^ 3 • z) D Y)
+    (hDX : Disjoint D X) (hDY : Disjoint D Y) (g : TriangleGroup) {z : α} (hz : z ∈ D)
+    (hgz : triangleLift a b ha hb g • z ∈ D) : g = 1 := by
+  by_contra hg
+  have hd :=
+    triangleLift_disjoint_domain_translate a b ha hb X Y D ha₁ ha₂ hb₁ hb₂ hb₃ hDa₁ hDa₂ hDb₁ hDb₂
+      hDb₃ hDX hDY g hg
+  exact hd.le_bot ⟨hgz, ⟨z, hz, rfl⟩⟩
+
+private theorem SpecialPeriods.Triangle.generatorOnePerm_firstSector :
+    Set.MapsTo (fun z : ℍ => generatorOnePerm z) firstSector firstExcluded :=
+  generatorOne_firstSector
+
+private theorem SpecialPeriods.Triangle.generatorOnePerm_sq_firstSector :
+    Set.MapsTo (fun z : ℍ => (generatorOnePerm ^ 2) z) firstSector firstExcluded := by
+  intro z hz
+  change (generatorOnePerm ^ 2) z ∈ firstExcluded
+  rw [generatorOnePerm_pow_apply]
+  exact generatorOne_sq_firstSector hz
+
+private theorem SpecialPeriods.Triangle.generatorTwoPerm_secondSector :
+    Set.MapsTo (fun z : ℍ => generatorTwoPerm z) secondSector secondExcluded :=
+  generatorTwo_secondSector
+
+private theorem SpecialPeriods.Triangle.generatorTwoPerm_sq_secondSector :
+    Set.MapsTo (fun z : ℍ => (generatorTwoPerm ^ 2) z) secondSector secondExcluded := by
+  intro z hz
+  change (generatorTwoPerm ^ 2) z ∈ secondExcluded
+  rw [generatorTwoPerm_pow_apply]
+  exact generatorTwo_sq_secondSector hz
+
+private theorem SpecialPeriods.Triangle.generatorTwoPerm_cube_secondSector :
+    Set.MapsTo (fun z : ℍ => (generatorTwoPerm ^ 3) z) secondSector secondExcluded := by
+  intro z hz
+  change (generatorTwoPerm ^ 3) z ∈ secondExcluded
+  rw [generatorTwoPerm_pow_apply]
+  exact generatorTwo_cube_secondSector hz
+
+private theorem SpecialPeriods.Triangle.eq_one_of_circularDoubleInterior_mem
+    (g : SpecialPeriods.TriangleGroup) {z : ℍ} (hz : z ∈ circularDoubleInterior)
+    (hgz : SpecialPeriods.triangleGeometricRepresentation g z ∈ circularDoubleInterior) : g = 1 :=
+  by
+  exact
+    SpecialPeriods.triangleLift_eq_one_of_domain_mem generatorOnePerm generatorTwoPerm
+      generatorOnePerm_cube generatorTwoPerm_fourth firstExcluded secondExcluded
+      circularDoubleInterior
+      (fun _ hw => generatorOnePerm_firstSector (secondExcluded_subset_firstSector hw))
+      (fun _ hw => generatorOnePerm_sq_firstSector (secondExcluded_subset_firstSector hw))
+      (fun _ hw => generatorTwoPerm_secondSector (firstExcluded_subset_secondSector hw))
+      (fun _ hw => generatorTwoPerm_sq_secondSector (firstExcluded_subset_secondSector hw))
+      (fun _ hw => generatorTwoPerm_cube_secondSector (firstExcluded_subset_secondSector hw))
+      (fun _ hw => generatorOnePerm_firstSector hw.1)
+      (fun _ hw => generatorOnePerm_sq_firstSector hw.1)
+      (fun _ hw => generatorTwoPerm_secondSector hw.2)
+      (fun _ hw => generatorTwoPerm_sq_secondSector hw.2)
+      (fun _ hw => generatorTwoPerm_cube_secondSector hw.2)
+      circularDoubleInterior_disjoint_firstExcluded circularDoubleInterior_disjoint_secondExcluded
+      g hz hgz
+
+private def SpecialPeriods.Triangle.fordInterior : Set ℍ :=
+  {z | stripLeft < z.re ∧ z.re < stripRight ∧ 1 < ‖(z : ℂ) + 1‖ ∧ 1 < ‖(z : ℂ)‖}
+
+private theorem SpecialPeriods.Triangle.fordInterior_isOpen : IsOpen fordInterior :=
+  (isOpen_lt continuous_const UpperHalfPlane.continuous_re).inter
+    ((isOpen_lt UpperHalfPlane.continuous_re continuous_const).inter
+      ((isOpen_lt continuous_const
+            ((UpperHalfPlane.continuous_coe.add continuous_const).norm)).inter
+        (isOpen_lt continuous_const UpperHalfPlane.continuous_coe.norm)))
+
+private theorem
+    SpecialPeriods.Triangle.fordInterior_subset_fordRegion : fordInterior ⊆ fordRegion := by
+  intro z hz
+  exact ⟨hz.1.le, hz.2.1.le, hz.2.2.1.le, hz.2.2.2.le⟩
+
+private theorem
+    SpecialPeriods.Triangle.fordInterior_subset_secondSector : fordInterior ⊆ secondSector := by
+  intro z hz
+  refine ⟨hz.1, ?_⟩
+  have hn : 1 < Complex.normSq ((z : ℂ) + 1) := by
+    rw [Complex.normSq_eq_norm_sq]
+    nlinarith [hz.2.2.1]
+  have hprod : 0 < stripRight * (z.re - stripLeft) := mul_pos stripRight_pos (sub_pos.mpr hz.1)
+  have hs : stripRight ^ 2 < ‖(z : ℂ) - (stripLeft : ℂ)‖ ^ 2 := by
+    rw [Complex.sq_norm]
+    simp only [Complex.normSq_apply, Complex.sub_re, Complex.ofReal_re, Complex.sub_im,
+      Complex.ofReal_im, sub_zero, Complex.add_re, Complex.one_re, Complex.add_im, Complex.one_im,
+      add_zero, UpperHalfPlane.coe_re, UpperHalfPlane.coe_im] at hn ⊢
+    have hleft : stripLeft = -1 - stripRight := by linarith [stripLeft_add_stripRight]
+    rw [hleft] at hprod ⊢
+    nlinarith [stripRight_sq]
+  nlinarith [norm_nonneg ((z : ℂ) - (stripLeft : ℂ)), stripRight_pos]
+
+private theorem SpecialPeriods.Triangle.fordInterior_left_mem_circularDoubleInterior (z : ℍ)
+    (hz : z ∈ fordInterior) (hx : z.re < -(1 / 2)) : z ∈ circularDoubleInterior :=
+  ⟨⟨hx, hz.2.2.2⟩, fordInterior_subset_secondSector hz⟩
+
+private theorem SpecialPeriods.Triangle.exists_mem_open_ne_re_and_image_re (e : ℍ ≃ₜ ℍ) (c : ℝ)
+    (U : Set ℍ) (hU : IsOpen U) (hne : U.Nonempty) : ∃ z ∈ U, z.re ≠ c ∧ (e z).re ≠ c := by
+  have hd : Dense {z : ℍ | z.re ≠ c} :=
+    (dense_compl_singleton c).preimage UpperHalfPlane.isOpenMap_re
+  have he : Dense {z : ℍ | (e z).re ≠ c} :=
+    (dense_compl_singleton c).preimage (UpperHalfPlane.isOpenMap_re.comp e.isOpenMap)
+  have ho : IsOpen {z : ℍ | z.re ≠ c} :=
+    isOpen_compl_singleton.preimage UpperHalfPlane.continuous_re
+  obtain ⟨z, hz⟩ :=
+    he.inter_open_nonempty (U ∩ {z : ℍ | z.re ≠ c}) (hU.inter ho)
+      (hd.inter_open_nonempty U hU hne)
+  exact ⟨z, hz.1.1, hz.1.2, hz.2⟩
+
+private theorem SpecialPeriods.Triangle.norm_lt_norm_add_one_of_re_gt_half_mo1973_18679 (z : ℍ)
+    (hx : -(1 / 2) < z.re) : ‖(z : ℂ)‖ < ‖(z : ℂ) + 1‖ := by
+  have hsq : ‖(z : ℂ)‖ ^ 2 < ‖(z : ℂ) + 1‖ ^ 2 := by
+    simp only [Complex.sq_norm, Complex.normSq_apply, Complex.add_re, Complex.one_re,
+      Complex.add_im, Complex.one_im, add_zero, UpperHalfPlane.coe_re, UpperHalfPlane.coe_im]
+    linarith
+  nlinarith [norm_nonneg ((z : ℂ) + 1), norm_nonneg (z : ℂ)]
+
+private theorem SpecialPeriods.Triangle.norm_real_sub_inv_gt_mo1973_18680 {r : ℝ} (hr : 0 < r)
+    (hr2 : r ^ 2 = 1 / 2) {u : ℂ} (hu : u ≠ 0) (hx : u.re < r) : r < ‖(r : ℂ) - u⁻¹‖ := by
+  have he : (r : ℂ) - u⁻¹ = ((r : ℂ) * u - 1) / u := by field_simp
+  have hnum : r ^ 2 * Complex.normSq u < Complex.normSq ((r : ℂ) * u - 1) := by
+    simp only [Complex.normSq_sub, Complex.normSq_mul, Complex.normSq_ofReal, map_one, mul_one,
+      Complex.mul_re, Complex.ofReal_re, Complex.ofReal_im, MulZeroClass.zero_mul, sub_zero]
+    nlinarith [mul_lt_mul_of_pos_left hx hr]
+  have hsq : r ^ 2 < ‖(r : ℂ) - u⁻¹‖ ^ 2 := by
+    rw [he, Complex.sq_norm, Complex.normSq_div]
+    exact (lt_div_iff₀ (Complex.normSq_pos.mpr hu)).mpr hnum
+  nlinarith [norm_nonneg ((r : ℂ) - u⁻¹)]
+
+private theorem SpecialPeriods.Triangle.fordInterior_right_mem_circularDoubleInterior (z : ℍ)
+    (hz : z ∈ fordInterior) (hx : -(1 / 2) < z.re) :
+    (generatorOneSL ^ 2 : SL(2, ℝ)) • z ∈ circularDoubleInterior := by
+  have hd : 1 < Complex.normSq (z : ℂ) := by
+    rw [Complex.normSq_eq_norm_sq]
+    nlinarith [hz.2.2.2]
+  have hp : 0 < Complex.normSq (z : ℂ) := zero_lt_one.trans hd
+  have hc : 1 < Complex.normSq ((z : ℂ) + 1) := by
+    rw [Complex.normSq_eq_norm_sq]
+    nlinarith [hz.2.2.1]
+  have hshift : 0 < Complex.normSq (z : ℂ) + 2 * z.re := by
+    simp only [Complex.normSq_apply, Complex.add_re, Complex.one_re, Complex.add_im,
+      Complex.one_im, add_zero, UpperHalfPlane.coe_re, UpperHalfPlane.coe_im] at hc ⊢
+    nlinarith
+  refine ⟨⟨?_, ?_⟩, ⟨?_, ?_⟩⟩
+  · change ((((generatorOneSL ^ 2 : SL(2, ℝ)) • z : ℍ) : ℂ)).re < -(1 / 2)
+    rw [generatorOneSL_sq_smul_coe]
+    simp only [Complex.sub_re, Complex.neg_re, Complex.one_re, Complex.inv_re,
+      UpperHalfPlane.coe_re]
+    have hfrac : -(1 / 2 : ℝ) < z.re / Complex.normSq (z : ℂ) :=
+      (lt_div_iff₀ hp).mpr (by linarith)
+    linarith
+  · rw [generatorOneSL_sq_smul_coe]
+    have he : (-1 : ℂ) - (z : ℂ)⁻¹ = -(((z : ℂ) + 1) / (z : ℂ)) := by
+      field_simp [z.ne_zero]
+      ring
+    rw [he, norm_neg, norm_div]
+    exact
+      (one_lt_div (norm_pos_iff.mpr z.ne_zero)).mpr
+        (norm_lt_norm_add_one_of_re_gt_half_mo1973_18679 z hx)
+  · change stripLeft < ((((generatorOneSL ^ 2 : SL(2, ℝ)) • z : ℍ) : ℂ)).re
+    rw [generatorOneSL_sq_smul_coe]
+    simp only [Complex.sub_re, Complex.neg_re, Complex.one_re, Complex.inv_re,
+      UpperHalfPlane.coe_re]
+    have hfrac : z.re / Complex.normSq (z : ℂ) < stripRight := by
+      apply (div_lt_iff₀ hp).mpr
+      exact hz.2.1.trans (by simpa only [mul_one] using mul_lt_mul_of_pos_left hd stripRight_pos)
+    linarith [stripLeft_add_stripRight]
+  · rw [generatorOneSL_sq_smul_coe]
+    have hL : stripLeft = -stripRight - 1 := by linarith [stripLeft_add_stripRight]
+    rw [hL]
+    push_cast
+    have he : (-1 : ℂ) - (z : ℂ)⁻¹ - (-(stripRight : ℂ) - 1) = (stripRight : ℂ) - (z : ℂ)⁻¹ := by
+      ring
+    rw [he]
+    exact norm_real_sub_inv_gt_mo1973_18680 stripRight_pos stripRight_sq z.ne_zero hz.2.1
+
+private theorem SpecialPeriods.Triangle.generatorOne_not_mem_fordInterior (z : ℍ)
+    (hz : z ∈ fordInterior) : generatorOneSL • z ∉ fordInterior := by
+  intro hw
+  have hn := hw.2.2.2
+  rw [generatorOneSL_smul_coe, norm_neg, norm_inv] at hn
+  exact lt_asymm hn (inv_lt_one_of_one_lt₀ hz.2.2.1)
+
+private theorem SpecialPeriods.Triangle.generatorOne_sq_not_mem_fordInterior (z : ℍ)
+    (hz : z ∈ fordInterior) : (generatorOneSL ^ 2 : SL(2, ℝ)) • z ∉ fordInterior := by
+  intro hw
+  have hn := hw.2.2.1
+  have he : ((((generatorOneSL ^ 2 : SL(2, ℝ)) • z : ℍ) : ℂ) + 1) = -(z : ℂ)⁻¹ := by
+    rw [generatorOneSL_sq_smul_coe]
+    ring
+  rw [he, norm_neg, norm_inv] at hn
+  exact lt_asymm hn (inv_lt_one_of_one_lt₀ hz.2.2.2)
+
+@[instance_reducible]
+private def SpecialPeriods.Triangle.instMulAction1 : MulAction SpecialPeriods.TriangleGroup ℍ :=
+  SpecialPeriods.triangleGeometricAction
+
+attribute [local instance] SpecialPeriods.Triangle.instMulAction1 in
+private theorem SpecialPeriods.Triangle.first_generator_inv_eq_sq_mo1973_18685 :
+    SpecialPeriods.triangleGenerator₁⁻¹ = SpecialPeriods.triangleGenerator₁ ^ 2 := by
+  apply inv_eq_of_mul_eq_one_right
+  simpa only [← pow_succ'] using SpecialPeriods.triangleGenerator₁_cube
+
+attribute [local instance] SpecialPeriods.Triangle.instMulAction1 in
+private theorem SpecialPeriods.Triangle.first_generator_inv_apply_mo1973_18686 (z : ℍ) :
+    SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleGenerator₁⁻¹ z =
+      (generatorOneSL ^ 2) • z := by
+  rw [first_generator_inv_eq_sq_mo1973_18685, map_pow,
+    SpecialPeriods.triangleGeometricRepresentation_generator₁, generatorOnePerm_pow_apply]
+
+attribute [local instance] SpecialPeriods.Triangle.instMulAction1 in
+private theorem SpecialPeriods.Triangle.right_mem_circularDouble_mo1973_18687 (z : ℍ)
+    (hz : z ∈ fordInterior) (hx : -(1 / 2) < z.re) :
+    SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleGenerator₁⁻¹ z ∈
+      circularDoubleInterior := by
+  rw [first_generator_inv_apply_mo1973_18686]
+  exact fordInterior_right_mem_circularDoubleInterior z hz hx
+
+attribute [local instance] SpecialPeriods.Triangle.instMulAction1 in
+private theorem SpecialPeriods.Triangle.eq_one_of_fordInterior_mem_off_axis_mo1973_18688
+    (g : SpecialPeriods.TriangleGroup) {z : ℍ} (hz : z ∈ fordInterior)
+    (hgz : SpecialPeriods.triangleGeometricRepresentation g z ∈ fordInterior)
+    (hx : z.re ≠ -(1 / 2))
+    (hgx : (SpecialPeriods.triangleGeometricRepresentation g z).re ≠ -(1 / 2)) : g = 1 := by
+  rcases lt_or_gt_of_ne hx with hx | hx <;> rcases lt_or_gt_of_ne hgx with hgx | hgx
+  · exact
+      eq_one_of_circularDoubleInterior_mem g
+        (fordInterior_left_mem_circularDoubleInterior z hz hx)
+        (fordInterior_left_mem_circularDoubleInterior _ hgz hgx)
+  · have hm :
+      SpecialPeriods.triangleGeometricRepresentation (SpecialPeriods.triangleGenerator₁⁻¹ * g) z ∈
+        circularDoubleInterior := by
+      change (SpecialPeriods.triangleGenerator₁⁻¹ * g) • z ∈ circularDoubleInterior
+      simpa only [SemigroupAction.mul_smul, SpecialPeriods.triangleGeometricAction_smul] using
+        right_mem_circularDouble_mo1973_18687 _ hgz hgx
+    have he :=
+      eq_one_of_circularDoubleInterior_mem (SpecialPeriods.triangleGenerator₁⁻¹ * g)
+        (fordInterior_left_mem_circularDoubleInterior z hz hx) hm
+    have hg : g = SpecialPeriods.triangleGenerator₁ := (inv_mul_eq_one.mp he).symm
+    rw [hg, SpecialPeriods.triangleGeometricRepresentation_generator₁_apply] at hgz
+    exact False.elim (generatorOne_not_mem_fordInterior z hz hgz)
+  · have hm :
+      SpecialPeriods.triangleGeometricRepresentation (g * SpecialPeriods.triangleGenerator₁)
+          (SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleGenerator₁⁻¹ z) ∈
+        circularDoubleInterior := by
+      change
+        (g * SpecialPeriods.triangleGenerator₁) • (SpecialPeriods.triangleGenerator₁⁻¹ • z) ∈
+          circularDoubleInterior
+      rw [SemigroupAction.mul_smul, smul_inv_smul, SpecialPeriods.triangleGeometricAction_smul]
+      exact fordInterior_left_mem_circularDoubleInterior _ hgz hgx
+    have he :=
+      eq_one_of_circularDoubleInterior_mem (g * SpecialPeriods.triangleGenerator₁)
+        (right_mem_circularDouble_mo1973_18687 z hz hx) hm
+    have hg : g = SpecialPeriods.triangleGenerator₁⁻¹ := eq_inv_of_mul_eq_one_left he
+    apply False.elim
+    apply generatorOne_sq_not_mem_fordInterior z hz
+    rw [hg, first_generator_inv_apply_mo1973_18686] at hgz
+    exact hgz
+  · have hm :
+      SpecialPeriods.triangleGeometricRepresentation
+          (SpecialPeriods.triangleGenerator₁⁻¹ * g * SpecialPeriods.triangleGenerator₁)
+          (SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleGenerator₁⁻¹ z) ∈
+        circularDoubleInterior := by
+      change
+        (SpecialPeriods.triangleGenerator₁⁻¹ * g * SpecialPeriods.triangleGenerator₁) •
+            (SpecialPeriods.triangleGenerator₁⁻¹ • z) ∈
+          circularDoubleInterior
+      rw [SemigroupAction.mul_smul, smul_inv_smul, SemigroupAction.mul_smul]
+      simpa only [SpecialPeriods.triangleGeometricAction_smul] using
+        right_mem_circularDouble_mo1973_18687 _ hgz hgx
+    have he :=
+      eq_one_of_circularDoubleInterior_mem
+        (SpecialPeriods.triangleGenerator₁⁻¹ * g * SpecialPeriods.triangleGenerator₁)
+        (right_mem_circularDouble_mo1973_18687 z hz hx) hm
+    have he' :=
+      congrArg
+        (fun h : SpecialPeriods.TriangleGroup =>
+          SpecialPeriods.triangleGenerator₁ * h * SpecialPeriods.triangleGenerator₁⁻¹)
+        he
+    simpa only [mul_assoc, mul_inv_cancel, inv_mul_cancel, one_mul, mul_one,
+      mul_inv_cancel_left] using he'
+
+attribute [local instance] SpecialPeriods.Triangle.instMulAction1 in
+private theorem
+    SpecialPeriods.Triangle.eq_one_of_fordInterior_mem (g : SpecialPeriods.TriangleGroup)
+    {z : ℍ} (hz : z ∈ fordInterior)
+    (hgz : SpecialPeriods.triangleGeometricRepresentation g z ∈ fordInterior) : g = 1 := by
+  let U : Set ℍ :=
+    fordInterior ∩ (SpecialPeriods.triangleGeometricRepresentation g) ⁻¹' fordInterior
+  have hU : IsOpen U :=
+    fordInterior_isOpen.inter
+      (fordInterior_isOpen.preimage (SpecialPeriods.triangleGeometricBiholomorph g).continuous)
+  have hne : U.Nonempty := ⟨z, hz, hgz⟩
+  obtain ⟨w, hw, hx, hgx⟩ :=
+    exists_mem_open_ne_re_and_image_re
+      (SpecialPeriods.triangleGeometricBiholomorph g).toHomeomorph (-(1 / 2)) U hU hne
+  exact eq_one_of_fordInterior_mem_off_axis_mo1973_18688 g hw.1 hw.2 hx hgx
+
+attribute [local instance] SpecialPeriods.Triangle.instMulAction1 in
+private theorem SpecialPeriods.Triangle.eq_one_of_fordInterior_eq (g : SpecialPeriods.TriangleGroup)
+    {z w : ℍ} (hz : z ∈ fordInterior) (hw : w ∈ fordInterior)
+    (hzw : SpecialPeriods.triangleGeometricRepresentation g z = w) : g = 1 :=
+  eq_one_of_fordInterior_mem g hz (hzw ▸ hw)
+
+private def SpecialPeriods.Triangle.verticalReflection (a : ℝ) : ℍ ≃ₜ ℍ
+    where
+  toFun z := ⟨(a : ℂ) - conj (z : ℂ), by simpa using z.im_pos⟩
+  invFun z := ⟨(a : ℂ) - conj (z : ℂ), by simpa using z.im_pos⟩
+  left_inv z := by apply UpperHalfPlane.ext; simp
+  right_inv z := by apply UpperHalfPlane.ext; simp
+  continuous_toFun := by
+    apply UpperHalfPlane.isEmbedding_coe.continuous_iff.mpr
+    change Continuous (fun z : ℍ => (a : ℂ) - conj (z : ℂ))
+    fun_prop
+  continuous_invFun := by
+    apply UpperHalfPlane.isEmbedding_coe.continuous_iff.mpr
+    change Continuous (fun z : ℍ => (a : ℂ) - conj (z : ℂ))
+    fun_prop
+
+@[simp]
+private theorem SpecialPeriods.Triangle.verticalReflection_re (a : ℝ) (z : ℍ) :
+    (verticalReflection a z).re = a - z.re := by
+  change ((a : ℂ) - conj (z : ℂ)).re = a - z.re
+  simp only [Complex.sub_re, Complex.ofReal_re, Complex.conj_re, UpperHalfPlane.coe_re]
+
+@[simp]
+private theorem SpecialPeriods.Triangle.verticalReflection_im (a : ℝ) (z : ℍ) :
+    (verticalReflection a z).im = z.im := by
+  change ((a : ℂ) - conj (z : ℂ)).im = z.im
+  simp only [Complex.sub_im, Complex.ofReal_im, Complex.conj_im, zero_sub, neg_neg,
+    UpperHalfPlane.coe_im]
+
+private theorem SpecialPeriods.Triangle.verticalReflection_involutive (a : ℝ) :
+    Function.Involutive (verticalReflection a) :=
+  (verticalReflection a).left_inv
+
+private theorem SpecialPeriods.Triangle.verticalReflection_fixed_iff (a : ℝ) (z : ℍ) :
+    verticalReflection a z = z ↔ z.re = a / 2 := by
+  constructor
+  · intro h
+    have hr := congrArg UpperHalfPlane.re h
+    rw [verticalReflection_re] at hr
+    linarith
+  · intro h
+    apply UpperHalfPlane.ext
+    apply Complex.ext
+    · change (verticalReflection a z).re = z.re
+      rw [verticalReflection_re]
+      linarith
+    · exact verticalReflection_im a z
+
+private def SpecialPeriods.Triangle.rightReflection : ℍ ≃ₜ ℍ :=
+  verticalReflection (-1)
+
+private def SpecialPeriods.Triangle.leftReflection : ℍ ≃ₜ ℍ :=
+  verticalReflection (-(width + 1))
+
+@[simp]
+private theorem SpecialPeriods.Triangle.rightReflection_coe (z : ℍ) :
+    (rightReflection z : ℂ) = -1 - conj (z : ℂ) := by simp [verticalReflection, rightReflection]
+
+@[simp]
+private theorem SpecialPeriods.Triangle.leftReflection_coe (z : ℍ) :
+    (leftReflection z : ℂ) = -((width : ℂ) + 1) - conj (z : ℂ) := by
+  simp [verticalReflection, leftReflection]
+
+@[simp]
+private theorem
+    SpecialPeriods.Triangle.rightReflection_re (z : ℍ) : (rightReflection z).re = -1 - z.re :=
+  by simp [rightReflection]
+
+private theorem SpecialPeriods.Triangle.rightReflection_norm (z : ℍ) :
+    ‖(rightReflection z : ℂ)‖ = ‖(z : ℂ) + 1‖ := by
+  rw [rightReflection_coe]
+  calc
+    _ = ‖-conj ((z : ℂ) + 1)‖ := by congr 1; simp; ring
+    _ = _ := by rw [norm_neg, Complex.norm_conj]
+
+private theorem SpecialPeriods.Triangle.rightReflection_add_one_norm (z : ℍ) :
+    ‖(rightReflection z : ℂ) + 1‖ = ‖(z : ℂ)‖ := by
+  rw [rightReflection_coe]
+  calc
+    _ = ‖-conj (z : ℂ)‖ := by congr 1; ring
+    _ = _ := by rw [norm_neg, Complex.norm_conj]
+
+private theorem SpecialPeriods.Triangle.rightReflection_involutive :
+    Function.Involutive rightReflection :=
+  verticalReflection_involutive _
+
+@[simp]
+private theorem SpecialPeriods.Triangle.rightReflection_fixed_iff (z : ℍ) :
+    rightReflection z = z ↔ z.re = -(1 / 2) := by
+  simpa only [rightReflection, neg_div] using verticalReflection_fixed_iff (-1) z
+
+@[simp]
+private theorem SpecialPeriods.Triangle.leftReflection_fixed_iff (z : ℍ) :
+    leftReflection z = z ↔ z.re = stripLeft :=
+  verticalReflection_fixed_iff _ _
+
+private theorem
+    SpecialPeriods.Triangle.conjugate_denominatorOne_ne_zero (z : ℍ) : conj (z : ℂ) + 1 ≠ 0 :=
+  by
+  simpa only [map_add, map_one, map_ne_zero] using
+    (map_ne_zero (starRingEnd ℂ)).mpr (denominatorOne_ne_zero z)
+
+private def SpecialPeriods.Triangle.circleReflectionMap_mo1973_18716 (z : ℍ) : ℍ :=
+  ⟨-1 + 1 / (conj (z : ℂ) + 1),
+    by
+    simp only [one_div, Complex.add_im, Complex.neg_im, Complex.one_im, neg_zero, zero_add,
+      Complex.inv_im, Complex.conj_im, add_zero, neg_neg, UpperHalfPlane.coe_im]
+    exact div_pos z.im_pos (Complex.normSq_pos.mpr (conjugate_denominatorOne_ne_zero z))⟩
+
+private theorem SpecialPeriods.Triangle.circleReflectionMap_involutive_mo1973_18717 :
+    Function.Involutive circleReflectionMap_mo1973_18716 := by
+  intro z
+  apply UpperHalfPlane.ext
+  change -1 + 1 / (conj (-1 + 1 / (conj (z : ℂ) + 1)) + 1) = (z : ℂ)
+  simp
+
+private theorem SpecialPeriods.Triangle.circleReflectionMap_continuous_mo1973_18718 :
+    Continuous circleReflectionMap_mo1973_18716 := by
+  apply UpperHalfPlane.isEmbedding_coe.continuous_iff.mpr
+  change Continuous (fun z : ℍ => -1 + 1 / (conj (z : ℂ) + 1))
+  exact
+    continuous_const.add
+      (continuous_const.div
+        ((Complex.continuous_conj.comp UpperHalfPlane.continuous_coe).add continuous_const)
+        conjugate_denominatorOne_ne_zero)
+
+private def SpecialPeriods.Triangle.circleReflection : ℍ ≃ₜ ℍ
+    where
+  toFun := circleReflectionMap_mo1973_18716
+  invFun := circleReflectionMap_mo1973_18716
+  left_inv := circleReflectionMap_involutive_mo1973_18717
+  right_inv := circleReflectionMap_involutive_mo1973_18717
+  continuous_toFun := circleReflectionMap_continuous_mo1973_18718
+  continuous_invFun := circleReflectionMap_continuous_mo1973_18718
+
+@[simp]
+private theorem SpecialPeriods.Triangle.circleReflection_coe (z : ℍ) :
+    (circleReflection z : ℂ) = -1 + 1 / (conj (z : ℂ) + 1) :=
+  rfl
+
+private theorem SpecialPeriods.Triangle.circleReflection_involutive :
+    Function.Involutive circleReflection :=
+  circleReflectionMap_involutive_mo1973_18717
+
+private theorem SpecialPeriods.Triangle.circleReflection_im (z : ℍ) :
+    (circleReflection z).im = z.im / Complex.normSq ((z : ℂ) + 1) := by
+  change (-1 + 1 / (conj (z : ℂ) + 1)).im = _
+  rw [show conj (z : ℂ) + 1 = conj ((z : ℂ) + 1) by simp]
+  simp only [one_div, Complex.add_im, Complex.neg_im, Complex.one_im, neg_zero, zero_add,
+    Complex.inv_im, Complex.normSq_conj, Complex.conj_im, add_zero, neg_neg,
+    UpperHalfPlane.coe_im]
+
+@[simp]
+private theorem SpecialPeriods.Triangle.circleReflection_fixed_iff (z : ℍ) :
+    circleReflection z = z ↔ ‖(z : ℂ) + 1‖ = 1 := by
+  constructor
+  · intro h
+    have hi := congrArg UpperHalfPlane.im h
+    rw [circleReflection_im] at hi
+    have hd : Complex.normSq ((z : ℂ) + 1) ≠ 0 :=
+      (Complex.normSq_pos.mpr (denominatorOne_ne_zero z)).ne'
+    have hs : Complex.normSq ((z : ℂ) + 1) = 1 := by
+      apply mul_left_cancel₀ z.im_ne_zero
+      simpa only [mul_one] using ((div_eq_iff hd).mp hi).symm
+    rw [Complex.normSq_eq_norm_sq] at hs
+    nlinarith [norm_nonneg ((z : ℂ) + 1)]
+  · intro h
+    apply UpperHalfPlane.ext
+    rw [circleReflection_coe]
+    have hs : Complex.normSq (conj (z : ℂ) + 1) = 1 := by
+      rw [show conj (z : ℂ) + 1 = conj ((z : ℂ) + 1) by simp, Complex.normSq_conj,
+        Complex.normSq_eq_norm_sq, h]
+      norm_num
+    simp [one_div, Complex.inv_def, hs]
+
+@[simp]
+private theorem SpecialPeriods.Triangle.rightReflection_mem_fordRegion_iff (z : ℍ) :
+    rightReflection z ∈ fordRegion ↔ z ∈ fordRegion := by
+  simp only [fordRegion, Set.mem_ofPred_eq, rightReflection_re, rightReflection_add_one_norm,
+    rightReflection_norm]
+  unfold stripLeft stripRight
+  constructor
+  · rintro ⟨hl, hr, hnorm, hadd⟩
+    refine ⟨?_, ?_, hadd, hnorm⟩ <;> linarith
+  · rintro ⟨hl, hr, hadd, hnorm⟩
+    refine ⟨?_, ?_, hnorm, hadd⟩ <;> linarith
+
+private theorem SpecialPeriods.Triangle.rightReflection_mapsTo_fordRegion :
+    Set.MapsTo rightReflection fordRegion fordRegion := fun z hz =>
+  (rightReflection_mem_fordRegion_iff z).mpr hz
+
+private theorem SpecialPeriods.Triangle.generatorOne_reflections (z : ℍ) :
+    generatorOneSL • z = rightReflection (circleReflection z) := by
+  apply UpperHalfPlane.ext
+  simp [generatorOne_coe, neg_div, one_div]
+
+private theorem SpecialPeriods.Triangle.generatorTwo_reflections (z : ℍ) :
+    generatorTwoSL • z = circleReflection (leftReflection z) := by
+  apply UpperHalfPlane.ext
+  rw [generatorTwo_coe, circleReflection_coe, leftReflection_coe]
+  simp only [map_sub, map_neg, map_add, Complex.conj_ofReal, map_one, Complex.conj_conj]
+  rw [show -((width : ℂ) + 1) - (z : ℂ) + 1 = -(z : ℂ) - width by ring]
+  have hd := denominatorTwo_ne_zero z
+  field_simp [hd]
+  ring
+
+private theorem SpecialPeriods.Triangle.cusp_reflections (z : ℍ) :
+    cuspSL • z = leftReflection (rightReflection z) := by
+  apply UpperHalfPlane.ext
+  rw [cuspSL_apply]
+  simp [UpperHalfPlane.coe_vadd]
+
+private theorem SpecialPeriods.Triangle.generatorOne_eq_rightReflection_of_norm_add_one (z : ℍ)
+    (hz : ‖(z : ℂ) + 1‖ = 1) : generatorOneSL • z = rightReflection z := by
+  rw [generatorOne_reflections, (circleReflection_fixed_iff z).mpr hz]
+
+private theorem SpecialPeriods.Triangle.rightReflection_re_eq_stripRight_iff (z : ℍ) :
+    (rightReflection z).re = stripRight ↔ z.re = stripLeft := by
+  rw [rightReflection_re]
+  unfold stripLeft stripRight
+  constructor <;> intro h <;> linarith
+
+private theorem SpecialPeriods.Triangle.rightReflection_re_eq_stripLeft_iff (z : ℍ) :
+    (rightReflection z).re = stripLeft ↔ z.re = stripRight := by
+  rw [rightReflection_re]
+  unfold stripLeft stripRight
+  constructor <;> intro h <;> linarith
+
+private theorem SpecialPeriods.Triangle.cusp_eq_rightReflection_of_re_eq_stripRight (z : ℍ)
+    (hz : z.re = stripRight) : cuspSL • z = rightReflection z := by
+  rw [cusp_reflections]
+  exact
+    (leftReflection_fixed_iff (rightReflection z)).mpr
+      ((rightReflection_re_eq_stripLeft_iff z).mpr hz)
+
+private theorem SpecialPeriods.Triangle.generatorOne_inv_eq_rightReflection_of_norm (z : ℍ)
+    (hz : ‖(z : ℂ)‖ = 1) : generatorOneSL⁻¹ • z = rightReflection z := by
+  have h :=
+    generatorOne_eq_rightReflection_of_norm_add_one (rightReflection z)
+      (by simpa only [rightReflection_add_one_norm] using hz)
+  rw [rightReflection_involutive z] at h
+  simpa only [inv_smul_smul] using congrArg (fun w : ℍ => generatorOneSL⁻¹ • w) h.symm
+
+private def SpecialPeriods.Triangle.triangleInterior : Set ℂ :=
+  {z | stripLeft < z.re ∧ z.re < -1 / 2 ∧ 0 < z.im ∧ 1 < ‖z + 1‖}
+
+private def SpecialPeriods.Triangle.boundaryHeight (x : ℝ) : ℝ :=
+  Real.sqrt (1 - (x + 1) ^ 2)
+
+@[fun_prop]
+private theorem SpecialPeriods.Triangle.continuous_boundaryHeight : Continuous boundaryHeight := by
+  unfold boundaryHeight
+  fun_prop
+
+private theorem SpecialPeriods.Triangle.boundaryHeight_le_one (x : ℝ) : boundaryHeight x ≤ 1 := by
+  have h : 1 - (x + 1) ^ 2 ≤ (1 : ℝ) := by nlinarith [sq_nonneg (x + 1)]
+  simpa only [boundaryHeight, Real.sqrt_one] using Real.sqrt_le_sqrt h
+
+private theorem SpecialPeriods.Triangle.neg_two_lt_stripLeft : -2 < stripLeft := by
+  have h : width < 3 := by nlinarith [width_sq, width_pos]
+  unfold stripLeft
+  linarith
+
+private theorem SpecialPeriods.Triangle.circle_epigraph_iff (z : ℂ) :
+    (0 < z.im ∧ 1 < ‖z + 1‖) ↔ boundaryHeight z.re < z.im := by
+  have hnorm : ‖z + 1‖ ^ 2 = (z.re + 1) ^ 2 + z.im ^ 2 := by
+    rw [← Complex.normSq_eq_norm_sq]
+    simp [Complex.normSq_apply, pow_two]
+  constructor
+  · rintro ⟨hy, hn⟩
+    apply (Real.sqrt_lt' hy).mpr
+    have hs := (sq_lt_sq₀ (show (0 : ℝ) ≤ 1 by norm_num) (norm_nonneg (z + 1))).mpr hn
+    nlinarith
+  · intro h
+    have hy : 0 < z.im := lt_of_le_of_lt (Real.sqrt_nonneg _) h
+    refine ⟨hy, ?_⟩
+    apply (sq_lt_sq₀ (show (0 : ℝ) ≤ 1 by norm_num) (norm_nonneg (z + 1))).mp
+    have hs := (Real.sqrt_lt' hy).mp h
+    nlinarith
+
+private theorem SpecialPeriods.Triangle.mem_triangleInterior_iff_epigraph (z : ℂ) :
+    z ∈ triangleInterior ↔ stripLeft < z.re ∧ z.re < -1 / 2 ∧ boundaryHeight z.re < z.im := by
+  change (stripLeft < z.re ∧ z.re < -1 / 2 ∧ (0 < z.im ∧ 1 < ‖z + 1‖)) ↔ _
+  rw [circle_epigraph_iff]
+
+private def SpecialPeriods.Triangle.triangleBasepoint : ℂ :=
+  -1 + 2 * Complex.I
+
+private theorem
+    SpecialPeriods.Triangle.triangleBasepoint_mem : triangleBasepoint ∈ triangleInterior := by
+  rw [mem_triangleInterior_iff_epigraph]
+  norm_num [triangleBasepoint, boundaryHeight, stripLeft_lt_neg_one]
+
+private theorem SpecialPeriods.Triangle.triangleInterior_isOpen : IsOpen triangleInterior :=
+  (isOpen_lt continuous_const Complex.continuous_re).inter
+    ((isOpen_lt Complex.continuous_re continuous_const).inter
+      ((isOpen_lt continuous_const Complex.continuous_im).inter
+        (isOpen_lt continuous_const ((continuous_id.add continuous_const).norm))))
+
+private theorem
+    SpecialPeriods.Triangle.zero_not_mem_triangleInterior : (0 : ℂ) ∉ triangleInterior := by
+  simp [triangleInterior]
+
+private theorem SpecialPeriods.Triangle.triangleInterior_ne_univ : triangleInterior ≠ Set.univ := by
+  intro h
+  exact zero_not_mem_triangleInterior (h.symm ▸ Set.mem_univ (0 : ℂ))
+
+private def SpecialPeriods.Triangle.triangleOpenStrip : Set ℂ :=
+  {z | stripLeft < z.re ∧ z.re < -1 / 2 ∧ 0 < z.im}
+
+private theorem SpecialPeriods.Triangle.triangleOpenStrip_convex : Convex ℝ triangleOpenStrip :=
+  (convex_halfSpace_re_gt stripLeft).inter
+    ((convex_halfSpace_re_lt (-1 / 2)).inter (convex_halfSpace_im_gt 0))
+
+private theorem
+    SpecialPeriods.Triangle.triangleOpenStrip_nonempty : triangleOpenStrip.Nonempty := by
+  refine ⟨(-1 : ℂ) + Complex.I, ?_⟩
+  norm_num [triangleOpenStrip, stripLeft_lt_neg_one]
+
+private def SpecialPeriods.Triangle.triangleHeightShift : ℂ ≃ₜ ℂ
+    where
+  toFun z := ⟨z.re, z.im - boundaryHeight z.re⟩
+  invFun z := ⟨z.re, z.im + boundaryHeight z.re⟩
+  left_inv z := by apply Complex.ext <;> simp
+  right_inv z := by apply Complex.ext <;> simp
+  continuous_toFun :=
+    Complex.equivRealProdCLM.symm.continuous.comp
+      (show Continuous (fun z : ℂ => (z.re, z.im - boundaryHeight z.re)) from by fun_prop)
+  continuous_invFun :=
+    Complex.equivRealProdCLM.symm.continuous.comp
+      (show Continuous (fun z : ℂ => (z.re, z.im + boundaryHeight z.re)) from by fun_prop)
+
+@[simp]
+private theorem SpecialPeriods.Triangle.triangleHeightShift_re (z : ℂ) :
+    (triangleHeightShift z).re = z.re :=
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.Triangle.triangleHeightShift_im (z : ℂ) :
+    (triangleHeightShift z).im = z.im - boundaryHeight z.re :=
+  rfl
+
+private theorem SpecialPeriods.Triangle.triangleInterior_eq_preimage_strip :
+    triangleInterior = triangleHeightShift ⁻¹' triangleOpenStrip := by
+  ext z
+  rw [mem_triangleInterior_iff_epigraph]
+  simp only [Set.mem_preimage, triangleOpenStrip, Set.mem_ofPred_eq, triangleHeightShift_re,
+    triangleHeightShift_im, sub_pos]
+
+private def SpecialPeriods.Triangle.triangleInteriorHomeomorphStrip :
+    triangleInterior ≃ₜ triangleOpenStrip :=
+  triangleHeightShift.sets triangleInterior_eq_preimage_strip
+
+private instance SpecialPeriods.Triangle.triangleInterior_contractible :
+    ContractibleSpace triangleInterior := by
+  have : ContractibleSpace triangleOpenStrip :=
+    triangleOpenStrip_convex.contractibleSpace triangleOpenStrip_nonempty
+  exact triangleInteriorHomeomorphStrip.contractibleSpace
+
+private instance SpecialPeriods.Triangle.triangleInterior_simplyConnectedSpace :
+    SimplyConnectedSpace triangleInterior :=
+  inferInstance
+
+private theorem SpecialPeriods.Triangle.triangleInterior_isSimplyConnected :
+    IsSimplyConnected triangleInterior := by
+  change SimplyConnectedSpace triangleInterior
+  infer_instance
+
+private def SpecialPeriods.Triangle.halfFordRegion : Set ℍ :=
+  fordRegion ∩ {z | z.re ≤ -(1 / 2)}
+
+private def SpecialPeriods.Triangle.halfFordInterior : Set ℍ :=
+  fordInterior ∩ {z | z.re < -(1 / 2)}
+
+private theorem SpecialPeriods.Triangle.halfFordRegion_isClosed : IsClosed halfFordRegion :=
+  fordRegion_closed.inter (isClosed_le UpperHalfPlane.continuous_re continuous_const)
+
+private theorem SpecialPeriods.Triangle.halfFordInterior_isOpen : IsOpen halfFordInterior :=
+  fordInterior_isOpen.inter (isOpen_lt UpperHalfPlane.continuous_re continuous_const)
+
+private theorem SpecialPeriods.Triangle.halfFordInterior_subset_halfFordRegion :
+    halfFordInterior ⊆ halfFordRegion := by
+  intro z hz
+  exact ⟨fordInterior_subset_fordRegion hz.1, (show z.re < -(1 / 2) from hz.2).le⟩
+
+private theorem SpecialPeriods.Triangle.norm_add_one_lt_norm_of_re_lt_neg_half (z : ℍ)
+    (hzre : z.re < -(1 / 2)) : ‖(z : ℂ) + 1‖ < ‖(z : ℂ)‖ := by
+  apply (sq_lt_sq₀ (norm_nonneg ((z : ℂ) + 1)) (norm_nonneg (z : ℂ))).mp
+  rw [← Complex.normSq_eq_norm_sq, ← Complex.normSq_eq_norm_sq]
+  simp only [Complex.normSq_apply, Complex.add_re, Complex.one_re, Complex.add_im, Complex.one_im,
+    add_zero, UpperHalfPlane.coe_re, UpperHalfPlane.coe_im]
+  nlinarith
+
+private theorem
+    SpecialPeriods.Triangle.one_lt_norm_of_re_lt_neg_half (z : ℍ) (hzre : z.re < -(1 / 2))
+    (hn : 1 < ‖(z : ℂ) + 1‖) : 1 < ‖(z : ℂ)‖ :=
+  hn.trans (norm_add_one_lt_norm_of_re_lt_neg_half z hzre)
+
+private theorem SpecialPeriods.Triangle.strict_ford_left_half_iff_triangleInterior (z : ℍ) :
+    ((stripLeft < z.re ∧ z.re < stripRight ∧ 1 < ‖(z : ℂ) + 1‖ ∧ 1 < ‖(z : ℂ)‖) ∧
+        z.re < -(1 / 2)) ↔
+      (z : ℂ) ∈ triangleInterior := by
+  change _ ↔ stripLeft < z.re ∧ z.re < -1 / 2 ∧ 0 < z.im ∧ 1 < ‖(z : ℂ) + 1‖
+  constructor
+  · rintro ⟨⟨hl, _, hn, _⟩, hm⟩
+    exact ⟨hl, by linarith, z.im_pos, hn⟩
+  · rintro ⟨hl, hm, _, hn⟩
+    have hm' : z.re < -(1 / 2) := by linarith
+    refine ⟨⟨hl, ?_, hn, one_lt_norm_of_re_lt_neg_half z hm' hn⟩, hm'⟩
+    linarith [stripRight_pos]
+
+private theorem SpecialPeriods.Triangle.halfFordInterior_eq_preimage_triangleInterior :
+    halfFordInterior = ((↑) : ℍ → ℂ) ⁻¹' triangleInterior :=
+  Set.ext strict_ford_left_half_iff_triangleInterior
+
+@[simp]
+private theorem SpecialPeriods.Triangle.rightReflection_mem_fordInterior_iff (z : ℍ) :
+    rightReflection z ∈ fordInterior ↔ z ∈ fordInterior := by
+  simp only [fordInterior, Set.mem_ofPred_eq, rightReflection_re, rightReflection_add_one_norm,
+    rightReflection_norm]
+  unfold stripLeft stripRight
+  constructor
+  · rintro ⟨hl, hr, hnorm, hadd⟩
+    refine ⟨?_, ?_, hadd, hnorm⟩ <;> linarith
+  · rintro ⟨hl, hr, hadd, hnorm⟩
+    refine ⟨?_, ?_, hnorm, hadd⟩ <;> linarith
+
+private theorem SpecialPeriods.Triangle.rightReflection_mapsTo_fordInterior :
+    Set.MapsTo rightReflection fordInterior fordInterior := fun z hz =>
+  (rightReflection_mem_fordInterior_iff z).mpr hz
+
+private def SpecialPeriods.Triangle.halfFold (b : Bool) : ℍ ≃ₜ ℍ :=
+  if b then rightReflection else Homeomorph.refl ℍ
+
+private theorem SpecialPeriods.Triangle.halfFold_mapsTo_region (b : Bool) :
+    Set.MapsTo (halfFold b) halfFordRegion fordRegion := by
+  cases b
+  · intro z hz
+    exact hz.1
+  · intro z hz
+    exact rightReflection_mapsTo_fordRegion hz.1
+
+private theorem SpecialPeriods.Triangle.halfFold_image_region_subset (b : Bool) :
+    halfFold b '' halfFordRegion ⊆ fordRegion :=
+  (halfFold_mapsTo_region b).image_subset
+
+private theorem SpecialPeriods.Triangle.rightReflection_image_halfFordRegion :
+    rightReflection '' halfFordRegion = fordRegion ∩ {z | -(1 / 2) ≤ z.re} := by
+  ext z
+  constructor
+  · rintro ⟨w, hw, rfl⟩
+    refine ⟨rightReflection_mapsTo_fordRegion hw.1, ?_⟩
+    change -(1 / 2) ≤ (rightReflection w).re
+    rw [rightReflection_re]
+    have hcut : w.re ≤ -(1 / 2) := hw.2
+    linarith
+  · rintro ⟨hz, hr⟩
+    refine
+      ⟨rightReflection z, ⟨rightReflection_mapsTo_fordRegion hz, ?_⟩,
+        rightReflection_involutive z⟩
+    change (rightReflection z).re ≤ -(1 / 2)
+    rw [rightReflection_re]
+    change -(1 / 2) ≤ z.re at hr
+    linarith
+
+private theorem SpecialPeriods.Triangle.halfFordRegion_union_reflection :
+    halfFordRegion ∪ rightReflection '' halfFordRegion = fordRegion := by
+  rw [rightReflection_image_halfFordRegion]
+  ext z
+  change
+    ((z ∈ fordRegion ∧ z.re ≤ -(1 / 2)) ∨ (z ∈ fordRegion ∧ -(1 / 2) ≤ z.re)) ↔ z ∈ fordRegion
+  constructor
+  · rintro (hz | hz) <;> exact hz.1
+  · intro hz
+    rcases le_total z.re (-(1 / 2)) with h | h
+    · exact Or.inl ⟨hz, h⟩
+    · exact Or.inr ⟨hz, h⟩
+
+private theorem SpecialPeriods.Triangle.halfFold_closed_cover :
+    (⋃ b : Bool, halfFold b '' halfFordRegion) = fordRegion := by
+  ext z
+  rw [Set.mem_iUnion]
+  constructor
+  · rintro ⟨b, hb⟩
+    exact halfFold_image_region_subset b hb
+  · intro hz
+    rw [← halfFordRegion_union_reflection] at hz
+    rcases hz with hz | hz
+    · exact ⟨Bool.false, z, hz, rfl⟩
+    · exact ⟨Bool.true, hz⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous in
+private theorem SpecialPeriods.Triangle.compact_return_height_bound {K : Set ℍ} (hK : IsCompact K) :
+    ∃ hi : ℝ,
+      ∀ (g : SpecialPeriods.TriangleGroup) (z : ℍ),
+        SpecialPeriods.triangleGeometricRepresentation g z ∈ K → z.im ≤ hi := by
+  obtain ⟨hi, hhi⟩ := hK.bddAbove_image orbitHeightBound_continuous.continuousOn
+  refine ⟨hi, fun g z hz => ?_⟩
+  have hb :=
+    triangle_im_le_orbitHeightBound g⁻¹ (SpecialPeriods.triangleGeometricRepresentation g z)
+  have he :
+    SpecialPeriods.triangleGeometricRepresentation g⁻¹
+        (SpecialPeriods.triangleGeometricRepresentation g z) =
+      z := by
+    rw [map_inv]
+    exact (SpecialPeriods.triangleGeometricRepresentation g).symm_apply_apply z
+  rw [he] at hb
+  exact hb.trans (hhi ⟨_, hz, rfl⟩)
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous in
+private theorem SpecialPeriods.Triangle.fordRegion_translates_finite_inter_compact {K : Set ℍ}
+    (hK : IsCompact K) :
+    {g : SpecialPeriods.TriangleGroup |
+        (SpecialPeriods.triangleGeometricRepresentation g '' fordRegion ∩ K).Nonempty}.Finite := by
+  obtain ⟨hi, hhi⟩ := compact_return_height_bound hK
+  have hf :=
+    ProperlyDiscontinuousSMul.finite_disjoint_inter_image (Γ := SpecialPeriods.TriangleGroup)
+      (truncatedFordRegion_compact hi) hK
+  apply hf.subset
+  rintro g ⟨z, ⟨w, hw, rfl⟩, hz⟩
+  exact ⟨SpecialPeriods.triangleGeometricRepresentation g w, ⟨w, ⟨hw, hhi g w hz⟩, rfl⟩, hz⟩
+
+attribute [local instance] SpecialPeriods.triangleGeometricAction
+    SpecialPeriods.triangleGeometricAction_properlyDiscontinuous in
+private theorem SpecialPeriods.Triangle.fordRegion_translates_locallyFinite :
+    LocallyFinite
+      (fun g : SpecialPeriods.TriangleGroup =>
+        SpecialPeriods.triangleGeometricRepresentation g '' fordRegion) := by
+  intro z
+  obtain ⟨K, hK, hKz⟩ := WeaklyLocallyCompactSpace.exists_compact_mem_nhds z
+  exact ⟨K, hKz, fordRegion_translates_finite_inter_compact hK⟩
+
+private def
+    SpecialPeriods.Triangle.halfTriangleMap (i : SpecialPeriods.TriangleGroup × Bool) : ℍ ≃ₜ ℍ :=
+  (halfFold i.2).trans (SpecialPeriods.triangleGeometricBiholomorph i.1).toHomeomorph
+
+@[simp]
+private theorem
+    SpecialPeriods.Triangle.halfTriangleMap_apply (i : SpecialPeriods.TriangleGroup × Bool)
+    (z : ℍ) :
+    halfTriangleMap i z = SpecialPeriods.triangleGeometricRepresentation i.1 (halfFold i.2 z) :=
+  rfl
+
+private def
+    SpecialPeriods.Triangle.halfTriangleTile (i : SpecialPeriods.TriangleGroup × Bool) : Set ℍ :=
+  halfTriangleMap i '' halfFordRegion
+
+private def SpecialPeriods.Triangle.halfTriangleOpenTile (i : SpecialPeriods.TriangleGroup × Bool) :
+    Set ℍ :=
+  halfTriangleMap i '' halfFordInterior
+
+private theorem
+    SpecialPeriods.Triangle.halfTriangleTile_eq (i : SpecialPeriods.TriangleGroup × Bool) :
+    halfTriangleTile i =
+      SpecialPeriods.triangleGeometricRepresentation i.1 '' (halfFold i.2 '' halfFordRegion) := by
+  rw [Set.image_image]
+  rfl
+
+private theorem SpecialPeriods.Triangle.halfTriangleOpenTile_eq
+    (i : SpecialPeriods.TriangleGroup × Bool) :
+    halfTriangleOpenTile i =
+      SpecialPeriods.triangleGeometricRepresentation i.1 '' (halfFold i.2 '' halfFordInterior) := by
+  rw [Set.image_image]
+  rfl
+
+private theorem SpecialPeriods.Triangle.halfTriangleOpenTile_isOpen
+    (i : SpecialPeriods.TriangleGroup × Bool) : IsOpen (halfTriangleOpenTile i) :=
+  (halfTriangleMap i).isOpenMap halfFordInterior halfFordInterior_isOpen
+
+private theorem SpecialPeriods.Triangle.halfTriangleTile_subset_fordRegion_translate
+    (i : SpecialPeriods.TriangleGroup × Bool) :
+    halfTriangleTile i ⊆ SpecialPeriods.triangleGeometricRepresentation i.1 '' fordRegion := by
+  rw [halfTriangleTile_eq]
+  exact Set.image_mono (halfFold_image_region_subset i.2)
+
+private theorem SpecialPeriods.Triangle.halfTriangleTiles_cover :
+    (⋃ i : SpecialPeriods.TriangleGroup × Bool, halfTriangleTile i) = Set.univ := by
+  apply Set.eq_univ_of_forall
+  intro z
+  obtain ⟨w, hw, g, hgz⟩ := SpecialPeriods.triangle_exists_fordRegion_preimage z
+  have hfold : w ∈ ⋃ b : Bool, halfFold b '' halfFordRegion := by
+    rw [halfFold_closed_cover]
+    exact hw
+  obtain ⟨b, u, hu, hwu⟩ := Set.mem_iUnion.mp hfold
+  refine Set.mem_iUnion.mpr ⟨(g, b), u, hu, ?_⟩
+  rw [halfTriangleMap_apply, hwu, hgz]
+
+private theorem SpecialPeriods.Triangle.halfTriangleTiles_finite_inter_compact {K : Set ℍ}
+    (hK : IsCompact K) :
+    {i : SpecialPeriods.TriangleGroup × Bool | (halfTriangleTile i ∩ K).Nonempty}.Finite := by
+  apply
+    ((fordRegion_translates_finite_inter_compact hK).prod
+        (Set.finite_univ : (Set.univ : Set Bool).Finite)).subset
+  rintro i ⟨z, hz, hKz⟩
+  exact ⟨⟨z, halfTriangleTile_subset_fordRegion_translate i hz, hKz⟩, Set.mem_univ _⟩
+
+private theorem SpecialPeriods.Triangle.halfTriangleTiles_locallyFinite :
+    LocallyFinite halfTriangleTile := by
+  intro z
+  obtain ⟨K, hK, hKz⟩ := WeaklyLocallyCompactSpace.exists_compact_mem_nhds z
+  exact ⟨K, hKz, halfTriangleTiles_finite_inter_compact hK⟩
+
+private structure TriangleUniformizationGluing.BoundaryMap where
+  toFun : ℍ → ℂ
+  continuousOn : ContinuousOn toFun SpecialPeriods.Triangle.halfFordRegion
+  boundary_real :
+    ∀ z ∈ SpecialPeriods.Triangle.halfFordRegion,
+      z ∉ SpecialPeriods.Triangle.halfFordInterior → (toFun z).im = 0
+
+private instance TriangleUniformizationGluing.instCoeFun1 : CoeFun BoundaryMap (fun _ => ℍ → ℂ) :=
+  ⟨BoundaryMap.toFun⟩
+
+private def TriangleUniformizationGluing.BoundaryMap.foldedFordMap
+    (D : TriangleUniformizationGluing.BoundaryMap) (z : ℍ) : ℂ := by
+  classical
+    exact if z.re ≤ -(1 / 2) then D z else conj (D (SpecialPeriods.Triangle.rightReflection z))
+
+private theorem TriangleUniformizationGluing.BoundaryMap.foldedFordMap_of_left
+    (D : TriangleUniformizationGluing.BoundaryMap) {z : ℍ} (hz : z.re ≤ -(1 / 2)) :
+    D.foldedFordMap z = D z := by simp only [foldedFordMap, ite_eq_left hz]
+
+private theorem TriangleUniformizationGluing.BoundaryMap.foldedFordMap_of_right
+    (D : TriangleUniformizationGluing.BoundaryMap) {z : ℍ} (hz : -(1 / 2) < z.re) :
+    D.foldedFordMap z = conj (D (SpecialPeriods.Triangle.rightReflection z)) := by
+  simp only [foldedFordMap, ite_eq_right hz.not_ge]
+
+private theorem TriangleUniformizationGluing.BoundaryMap.foldedFordMap_eqOn_left
+    (D : TriangleUniformizationGluing.BoundaryMap) :
+    Set.EqOn D.foldedFordMap D SpecialPeriods.Triangle.halfFordRegion := fun _ hz =>
+  D.foldedFordMap_of_left hz.2
+
+private theorem TriangleUniformizationGluing.BoundaryMap.real_at_axis
+    (D : TriangleUniformizationGluing.BoundaryMap) {z : ℍ}
+    (hz : z ∈ SpecialPeriods.Triangle.fordRegion) (hx : z.re = -(1 / 2)) : (D z).im = 0 := by
+  apply D.boundary_real z ⟨hz, hx.le⟩
+  intro hi
+  have hh : z.re < -(1 / 2) := hi.2
+  linarith
+
+private theorem TriangleUniformizationGluing.BoundaryMap.foldedFordMap_reflected
+    (D : TriangleUniformizationGluing.BoundaryMap) (z : ℍ)
+    (hz : z ∈ SpecialPeriods.Triangle.halfFordRegion) :
+    D.foldedFordMap (SpecialPeriods.Triangle.rightReflection z) = conj (D z) := by
+  by_cases hx : (SpecialPeriods.Triangle.rightReflection z).re ≤ -(1 / 2)
+  · have hcut : z.re = -(1 / 2) := by
+      rw [SpecialPeriods.Triangle.rightReflection_re] at hx
+      have hleft : z.re ≤ -(1 / 2) := hz.2
+      linarith
+    have hfix : SpecialPeriods.Triangle.rightReflection z = z :=
+      (SpecialPeriods.Triangle.rightReflection_fixed_iff z).mpr hcut
+    rw [hfix, D.foldedFordMap_of_left hz.2]
+    exact (Complex.conj_eq_iff_im.mpr (D.real_at_axis hz.1 hcut)).symm
+  · simp only [foldedFordMap, ite_eq_right hx]
+    rw [SpecialPeriods.Triangle.rightReflection_involutive z]
+
+private theorem TriangleUniformizationGluing.BoundaryMap.foldedFordMap_eqOn_right
+    (D : TriangleUniformizationGluing.BoundaryMap) :
+    Set.EqOn D.foldedFordMap (fun z => conj (D (SpecialPeriods.Triangle.rightReflection z)))
+      (SpecialPeriods.Triangle.rightReflection '' SpecialPeriods.Triangle.halfFordRegion) := by
+  rintro z ⟨w, hw, rfl⟩
+  change
+    D.foldedFordMap (SpecialPeriods.Triangle.rightReflection w) =
+      conj
+        (D (SpecialPeriods.Triangle.rightReflection (SpecialPeriods.Triangle.rightReflection w)))
+  rw [D.foldedFordMap_reflected w hw, SpecialPeriods.Triangle.rightReflection_involutive w]
+
+private theorem TriangleUniformizationGluing.BoundaryMap.foldedFordMap_continuousOn
+    (D : TriangleUniformizationGluing.BoundaryMap) :
+    ContinuousOn D.foldedFordMap SpecialPeriods.Triangle.fordRegion := by
+  have hl : ContinuousOn D.foldedFordMap SpecialPeriods.Triangle.halfFordRegion :=
+    D.continuousOn.congr D.foldedFordMap_eqOn_left
+  have hm :
+    Set.MapsTo SpecialPeriods.Triangle.rightReflection
+      (SpecialPeriods.Triangle.rightReflection '' SpecialPeriods.Triangle.halfFordRegion)
+      SpecialPeriods.Triangle.halfFordRegion := by
+    rintro z ⟨w, hw, rfl⟩
+    rw [SpecialPeriods.Triangle.rightReflection_involutive w]
+    exact hw
+  have hr :
+    ContinuousOn D.foldedFordMap
+      (SpecialPeriods.Triangle.rightReflection '' SpecialPeriods.Triangle.halfFordRegion) := by
+    apply
+      (Complex.continuous_conj.continuousOn.comp
+          (D.continuousOn.comp SpecialPeriods.Triangle.rightReflection.continuous.continuousOn hm)
+          (Set.mapsTo_univ _ _)).congr
+    exact D.foldedFordMap_eqOn_right
+  rw [← SpecialPeriods.Triangle.halfFordRegion_union_reflection]
+  exact
+    hl.union_of_isClosed hr SpecialPeriods.Triangle.halfFordRegion_isClosed
+      (SpecialPeriods.Triangle.rightReflection.isClosedMap _
+        SpecialPeriods.Triangle.halfFordRegion_isClosed)
+
+private theorem TriangleUniformizationGluing.BoundaryMap.foldedFordMap_rightReflection
+    (D : TriangleUniformizationGluing.BoundaryMap) {z : ℍ}
+    (hz : z ∈ SpecialPeriods.Triangle.fordRegion) :
+    D.foldedFordMap (SpecialPeriods.Triangle.rightReflection z) = conj (D.foldedFordMap z) := by
+  by_cases hx : z.re ≤ -(1 / 2)
+  · rw [D.foldedFordMap_of_left hx]
+    exact D.foldedFordMap_reflected z ⟨hz, hx⟩
+  · have hright : -(1 / 2) < z.re := lt_of_not_ge hx
+    have hleft : (SpecialPeriods.Triangle.rightReflection z).re ≤ -(1 / 2) := by
+      rw [SpecialPeriods.Triangle.rightReflection_re]
+      linarith
+    rw [D.foldedFordMap_of_left hleft, D.foldedFordMap_of_right hright, Complex.conj_conj]
+
+private theorem TriangleUniformizationGluing.BoundaryMap.foldedFordMap_real_of_not_mem_interior
+    (D : TriangleUniformizationGluing.BoundaryMap) {z : ℍ}
+    (hz : z ∈ SpecialPeriods.Triangle.fordRegion)
+    (hi : z ∉ SpecialPeriods.Triangle.fordInterior) : (D.foldedFordMap z).im = 0 := by
+  by_cases hx : z.re ≤ -(1 / 2)
+  · rw [D.foldedFordMap_of_left hx]
+    exact D.boundary_real z ⟨hz, hx⟩ (fun hh => hi hh.1)
+  · have hright : -(1 / 2) < z.re := lt_of_not_ge hx
+    have hleft : (SpecialPeriods.Triangle.rightReflection z).re ≤ -(1 / 2) := by
+      rw [SpecialPeriods.Triangle.rightReflection_re]
+      linarith
+    have hr :
+      SpecialPeriods.Triangle.rightReflection z ∈ SpecialPeriods.Triangle.halfFordRegion :=
+      ⟨SpecialPeriods.Triangle.rightReflection_mapsTo_fordRegion hz, hleft⟩
+    have hn :
+      SpecialPeriods.Triangle.rightReflection z ∉ SpecialPeriods.Triangle.halfFordInterior := by
+      intro hh
+      exact hi ((SpecialPeriods.Triangle.rightReflection_mem_fordInterior_iff z).mp hh.1)
+    rw [D.foldedFordMap_of_right hright, Complex.conj_im, D.boundary_real _ hr hn, neg_zero]
+
+private theorem TriangleUniformizationGluing.BoundaryMap.foldedFordMap_rightReflection_boundary
+    (D : TriangleUniformizationGluing.BoundaryMap) {z : ℍ}
+    (hz : z ∈ SpecialPeriods.Triangle.fordRegion)
+    (hi : z ∉ SpecialPeriods.Triangle.fordInterior) :
+    D.foldedFordMap (SpecialPeriods.Triangle.rightReflection z) = D.foldedFordMap z := by
+  rw [D.foldedFordMap_rightReflection hz]
+  exact Complex.conj_eq_iff_im.mpr (D.foldedFordMap_real_of_not_mem_interior hz hi)
+
+private structure TriangleUniformizationGluing.HalfPlaneMap extends BoundaryMap where
+  injOn : Set.InjOn toFun SpecialPeriods.Triangle.halfFordRegion
+  image_eq : toFun '' SpecialPeriods.Triangle.halfFordRegion = {w : ℂ | 0 ≤ w.im}
+  interior_positive : ∀ z ∈ SpecialPeriods.Triangle.halfFordInterior, 0 < (toFun z).im
+
+private instance TriangleUniformizationGluing.instCoeFun2 : CoeFun HalfPlaneMap (fun _ => ℍ → ℂ) :=
+  ⟨fun D => D.toFun⟩
+
+private abbrev TriangleUniformizationGluing.HalfPlaneMap.foldedFordMap
+    (D : TriangleUniformizationGluing.HalfPlaneMap) : ℍ → ℂ :=
+  D.toBoundaryMap.foldedFordMap
+
+private theorem TriangleUniformizationGluing.HalfPlaneMap.im_nonneg
+    (D : TriangleUniformizationGluing.HalfPlaneMap) {z : ℍ}
+    (hz : z ∈ SpecialPeriods.Triangle.halfFordRegion) : 0 ≤ (D z).im := by
+  have h : D.toFun z ∈ D.toFun '' SpecialPeriods.Triangle.halfFordRegion :=
+    Set.mem_image_of_mem D.toFun hz
+  rw [D.image_eq] at h
+  exact h
+
+private theorem TriangleUniformizationGluing.HalfPlaneMap.im_eq_zero_iff_not_mem_halfFordInterior
+    (D : TriangleUniformizationGluing.HalfPlaneMap) {z : ℍ}
+    (hz : z ∈ SpecialPeriods.Triangle.halfFordRegion) :
+    (D z).im = 0 ↔ z ∉ SpecialPeriods.Triangle.halfFordInterior := by
+  constructor
+  · intro him hi
+    exact (D.interior_positive z hi).ne' him
+  · exact D.boundary_real z hz
+
+private theorem TriangleUniformizationGluing.HalfPlaneMap.foldedFordMap_of_left
+    (D : TriangleUniformizationGluing.HalfPlaneMap) {z : ℍ} (hz : z.re ≤ -(1 / 2)) :
+    D.foldedFordMap z = D z :=
+  D.toBoundaryMap.foldedFordMap_of_left hz
+
+private theorem TriangleUniformizationGluing.HalfPlaneMap.foldedFordMap_of_right
+    (D : TriangleUniformizationGluing.HalfPlaneMap) {z : ℍ} (hz : -(1 / 2) < z.re) :
+    D.foldedFordMap z = conj (D (SpecialPeriods.Triangle.rightReflection z)) :=
+  D.toBoundaryMap.foldedFordMap_of_right hz
+
+private theorem TriangleUniformizationGluing.HalfPlaneMap.foldedFordMap_surjOn
+    (D : TriangleUniformizationGluing.HalfPlaneMap) :
+    Set.SurjOn D.foldedFordMap SpecialPeriods.Triangle.fordRegion Set.univ := by
+  intro w _
+  by_cases hw : 0 ≤ w.im
+  · have hmem : w ∈ D.toFun '' SpecialPeriods.Triangle.halfFordRegion := by
+      rw [D.image_eq]
+      exact hw
+    obtain ⟨z, hz, he⟩ := hmem
+    refine ⟨z, hz.1, ?_⟩
+    change D.toBoundaryMap.foldedFordMap z = w
+    rw [D.toBoundaryMap.foldedFordMap_of_left hz.2]
+    exact he
+  · have hmem : conj w ∈ D.toFun '' SpecialPeriods.Triangle.halfFordRegion := by
+      rw [D.image_eq]
+      change 0 ≤ (conj w).im
+      rw [Complex.conj_im]
+      exact neg_nonneg.mpr (le_of_lt (lt_of_not_ge hw))
+    obtain ⟨z, hz, he⟩ := hmem
+    refine
+      ⟨SpecialPeriods.Triangle.rightReflection z,
+        SpecialPeriods.Triangle.rightReflection_mapsTo_fordRegion hz.1, ?_⟩
+    change D.toBoundaryMap.foldedFordMap (SpecialPeriods.Triangle.rightReflection z) = w
+    rw [D.toBoundaryMap.foldedFordMap_reflected z hz, he, Complex.conj_conj]
+
+private theorem
+  TriangleUniformizationGluing.HalfPlaneMap.rightReflection_mem_halfFordRegion_mo1973_18870
+    {z : ℍ} (hz : z ∈ SpecialPeriods.Triangle.fordRegion) (hx : -(1 / 2) < z.re) :
+    SpecialPeriods.Triangle.rightReflection z ∈ SpecialPeriods.Triangle.halfFordRegion := by
+  refine ⟨SpecialPeriods.Triangle.rightReflection_mapsTo_fordRegion hz, ?_⟩
+  change (SpecialPeriods.Triangle.rightReflection z).re ≤ -(1 / 2)
+  rw [SpecialPeriods.Triangle.rightReflection_re]
+  linarith
+
+private theorem TriangleUniformizationGluing.HalfPlaneMap.cross_fibre_mo1973_18871
+    (D : TriangleUniformizationGluing.HalfPlaneMap) {z w : ℍ}
+    (hz : z ∈ SpecialPeriods.Triangle.halfFordRegion)
+    (hw : w ∈ SpecialPeriods.Triangle.fordRegion) (hwr : -(1 / 2) < w.re)
+    (heq : D.foldedFordMap z = D.foldedFordMap w) :
+    w = SpecialPeriods.Triangle.rightReflection z ∧ z ∉ SpecialPeriods.Triangle.fordInterior := by
+  have hrw : SpecialPeriods.Triangle.rightReflection w ∈ SpecialPeriods.Triangle.halfFordRegion :=
+    rightReflection_mem_halfFordRegion_mo1973_18870 hw hwr
+  rw [D.foldedFordMap_of_left hz.2, D.foldedFordMap_of_right hwr] at heq
+  have him := congrArg Complex.im heq
+  rw [Complex.conj_im] at him
+  have hzpos := D.im_nonneg hz
+  have hwpos := D.im_nonneg hrw
+  have hzreal : (D z).im = 0 := by linarith
+  have hwreal : (D (SpecialPeriods.Triangle.rightReflection w)).im = 0 := by linarith
+  have hf : D z = D (SpecialPeriods.Triangle.rightReflection w) :=
+    heq.trans (Complex.conj_eq_iff_im.mpr hwreal)
+  have hzw : z = SpecialPeriods.Triangle.rightReflection w := D.injOn hz hrw hf
+  have hwz : w = SpecialPeriods.Triangle.rightReflection z := by
+    rw [hzw, SpecialPeriods.Triangle.rightReflection_involutive]
+  refine ⟨hwz, ?_⟩
+  have hnot : z ∉ SpecialPeriods.Triangle.halfFordInterior :=
+    (D.im_eq_zero_iff_not_mem_halfFordInterior hz).mp hzreal
+  intro hi
+  apply hnot
+  refine ⟨hi, ?_⟩
+  change z.re < -(1 / 2)
+  rw [hzw, SpecialPeriods.Triangle.rightReflection_re]
+  linarith
+
+private theorem TriangleUniformizationGluing.HalfPlaneMap.foldedFordMap_eq_iff
+    (D : TriangleUniformizationGluing.HalfPlaneMap) {z w : ℍ}
+    (hz : z ∈ SpecialPeriods.Triangle.fordRegion) (hw : w ∈ SpecialPeriods.Triangle.fordRegion) :
+    D.foldedFordMap z = D.foldedFordMap w ↔
+      z = w ∨
+        (w = SpecialPeriods.Triangle.rightReflection z ∧
+          z ∉ SpecialPeriods.Triangle.fordInterior) := by
+  constructor
+  · intro heq
+    by_cases hzl : z.re ≤ -(1 / 2)
+    · by_cases hwl : w.re ≤ -(1 / 2)
+      · left
+        rw [D.foldedFordMap_of_left hzl, D.foldedFordMap_of_left hwl] at heq
+        exact D.injOn ⟨hz, hzl⟩ ⟨hw, hwl⟩ heq
+      · exact Or.inr (D.cross_fibre_mo1973_18871 ⟨hz, hzl⟩ hw (lt_of_not_ge hwl) heq)
+    · have hzr : -(1 / 2) < z.re := lt_of_not_ge hzl
+      by_cases hwl : w.re ≤ -(1 / 2)
+      · obtain ⟨hzw, hwnot⟩ := D.cross_fibre_mo1973_18871 ⟨hw, hwl⟩ hz hzr heq.symm
+        right
+        constructor
+        · rw [hzw, SpecialPeriods.Triangle.rightReflection_involutive]
+        · rw [hzw, SpecialPeriods.Triangle.rightReflection_mem_fordInterior_iff]
+          exact hwnot
+      · have hwr : -(1 / 2) < w.re := lt_of_not_ge hwl
+        left
+        rw [D.foldedFordMap_of_right hzr, D.foldedFordMap_of_right hwr] at heq
+        have hf :
+          D (SpecialPeriods.Triangle.rightReflection z) =
+            D (SpecialPeriods.Triangle.rightReflection w) := by
+          simpa only [Complex.conj_conj] using congrArg (fun u : ℂ => conj u) heq
+        exact
+          SpecialPeriods.Triangle.rightReflection.injective
+            (D.injOn (rightReflection_mem_halfFordRegion_mo1973_18870 hz hzr)
+              (rightReflection_mem_halfFordRegion_mo1973_18870 hw hwr) hf)
+  · rintro (rfl | ⟨rfl, hi⟩)
+    · rfl
+    · exact (D.toBoundaryMap.foldedFordMap_rightReflection_boundary hz hi).symm
+
+private structure TriangleUniformizationGluing.SignedHalfPlaneMap extends BoundaryMap where
+  orientation : ℝ
+  orientation_sq : orientation ^ 2 = 1
+  injOn : Set.InjOn toFun SpecialPeriods.Triangle.halfFordRegion
+  image_eq : toFun '' SpecialPeriods.Triangle.halfFordRegion = {w : ℂ | 0 ≤ orientation * w.im}
+  interior_positive :
+    ∀ z ∈ SpecialPeriods.Triangle.halfFordInterior, 0 < orientation * (toFun z).im
+
+private instance
+    TriangleUniformizationGluing.instCoeFun3 : CoeFun SignedHalfPlaneMap (fun _ => ℍ → ℂ) :=
+  ⟨fun D => D.toFun⟩
+
+private theorem TriangleUniformizationGluing.SignedHalfPlaneMap.orientation_ne_zero
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap) : D.orientation ≠ 0 := by
+  intro h
+  have hs := D.orientation_sq
+  rw [h] at hs
+  norm_num at hs
+
+private theorem TriangleUniformizationGluing.SignedHalfPlaneMap.orientation_coe_ne_zero
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap) : (D.orientation : ℂ) ≠ 0 := by
+  exact_mod_cast D.orientation_ne_zero
+
+private theorem TriangleUniformizationGluing.SignedHalfPlaneMap.orientation_mul_self
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap) : D.orientation * D.orientation = 1 := by
+  simpa only [pow_two] using D.orientation_sq
+
+private theorem TriangleUniformizationGluing.SignedHalfPlaneMap.orientation_coe_mul_self
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap) :
+    (D.orientation : ℂ) * (D.orientation : ℂ) = 1 := by
+  rw [← Complex.ofReal_mul, D.orientation_mul_self, Complex.ofReal_one]
+
+private def TriangleUniformizationGluing.SignedHalfPlaneMap.orientationScale
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap) (w : ℂ) : ℂ :=
+  (D.orientation : ℂ) * w
+
+private theorem TriangleUniformizationGluing.SignedHalfPlaneMap.orientationScale_involutive
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap) :
+    Function.Involutive D.orientationScale := by
+  intro w
+  change (D.orientation : ℂ) * ((D.orientation : ℂ) * w) = w
+  rw [← mul_assoc, D.orientation_coe_mul_self, one_mul]
+
+private theorem TriangleUniformizationGluing.SignedHalfPlaneMap.orientationScale_injective
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap) :
+    Function.Injective D.orientationScale :=
+  D.orientationScale_involutive.injective
+
+private abbrev TriangleUniformizationGluing.SignedHalfPlaneMap.foldedFordMap
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap) : ℍ → ℂ :=
+  D.toBoundaryMap.foldedFordMap
+
+private def TriangleUniformizationGluing.SignedHalfPlaneMap.normalized
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap) :
+    TriangleUniformizationGluing.HalfPlaneMap
+    where
+  toFun := fun z => (D.orientation : ℂ) * D z
+  continuousOn := continuousOn_const.mul D.continuousOn
+  boundary_real := by
+    intro z hz hi
+    simp only [Complex.mul_im, Complex.ofReal_re, Complex.ofReal_im, MulZeroClass.zero_mul,
+      add_zero, D.boundary_real z hz hi, MulZeroClass.mul_zero]
+  injOn := by
+    intro z hz w hw he
+    exact D.injOn hz hw ((mul_right_inj' D.orientation_coe_ne_zero).mp he)
+  image_eq := by
+    ext w
+    constructor
+    · rintro ⟨z, hz, rfl⟩
+      have h : D.toFun z ∈ D.toFun '' SpecialPeriods.Triangle.halfFordRegion :=
+        Set.mem_image_of_mem D.toFun hz
+      rw [D.image_eq] at h
+      simpa only [Set.mem_ofPred_eq, Complex.mul_im, Complex.ofReal_re, Complex.ofReal_im,
+        MulZeroClass.zero_mul, add_zero] using h
+    · intro hw
+      have h : (D.orientation : ℂ) * w ∈ D.toFun '' SpecialPeriods.Triangle.halfFordRegion := by
+        rw [D.image_eq]
+        simp only [Set.mem_ofPred_eq, Complex.mul_im, Complex.ofReal_re, Complex.ofReal_im,
+          MulZeroClass.zero_mul, add_zero]
+        rw [← mul_assoc, D.orientation_mul_self, one_mul]
+        exact hw
+      obtain ⟨z, hz, he⟩ := h
+      refine ⟨z, hz, ?_⟩
+      change (D.orientation : ℂ) * D.toFun z = w
+      rw [he, ← mul_assoc, D.orientation_coe_mul_self, one_mul]
+  interior_positive := by
+    intro z hz
+    simpa only [Complex.mul_im, Complex.ofReal_re, Complex.ofReal_im, MulZeroClass.zero_mul,
+      add_zero] using D.interior_positive z hz
+
+private theorem TriangleUniformizationGluing.SignedHalfPlaneMap.normalized_foldedFordMap
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap) (z : ℍ) :
+    D.normalized.foldedFordMap z = (D.orientation : ℂ) * D.foldedFordMap z := by
+  simp only [TriangleUniformizationGluing.HalfPlaneMap.foldedFordMap, foldedFordMap,
+    TriangleUniformizationGluing.BoundaryMap.foldedFordMap]
+  split_ifs
+  · rfl
+  · change
+      conj ((D.orientation : ℂ) * D (SpecialPeriods.Triangle.rightReflection z)) =
+        (D.orientation : ℂ) * conj (D (SpecialPeriods.Triangle.rightReflection z))
+    rw [map_mul, Complex.conj_ofReal]
+
+private theorem TriangleUniformizationGluing.SignedHalfPlaneMap.foldedFordMap_surjOn
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap) :
+    Set.SurjOn D.foldedFordMap SpecialPeriods.Triangle.fordRegion Set.univ := by
+  intro w _
+  obtain ⟨z, hz, he⟩ := D.normalized.foldedFordMap_surjOn (Set.mem_univ ((D.orientation : ℂ) * w))
+  refine ⟨z, hz, ?_⟩
+  apply D.orientationScale_injective
+  change (D.orientation : ℂ) * D.foldedFordMap z = (D.orientation : ℂ) * w
+  rw [← D.normalized_foldedFordMap z]
+  exact he
+
+private theorem TriangleUniformizationGluing.SignedHalfPlaneMap.foldedFordMap_eq_iff
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap) {z w : ℍ}
+    (hz : z ∈ SpecialPeriods.Triangle.fordRegion) (hw : w ∈ SpecialPeriods.Triangle.fordRegion) :
+    D.foldedFordMap z = D.foldedFordMap w ↔
+      z = w ∨
+        (w = SpecialPeriods.Triangle.rightReflection z ∧
+          z ∉ SpecialPeriods.Triangle.fordInterior) := by
+  have heq :
+    D.normalized.foldedFordMap z = D.normalized.foldedFordMap w ↔
+      D.foldedFordMap z = D.foldedFordMap w := by
+    rw [D.normalized_foldedFordMap z, D.normalized_foldedFordMap w]
+    constructor
+    · intro h
+      exact D.orientationScale_injective h
+    · intro h
+      exact congrArg D.orientationScale h
+  exact heq.symm.trans (D.normalized.foldedFordMap_eq_iff hz hw)
+
+private abbrev RiemannSphere.Biholomorph :=
+  Diffeomorph (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) RiemannSphere RiemannSphere ω
+
+private def RiemannSphere.reciprocal (p : RiemannSphere) : RiemannSphere :=
+  p.elim ((0 : ℂ) : RiemannSphere) infinityParametrization
+
+@[simp]
+private theorem RiemannSphere.reciprocal_coe (z : ℂ) :
+    reciprocal (z : RiemannSphere) = infinityParametrization z :=
+  rfl
+
+@[simp]
+private theorem RiemannSphere.reciprocal_infinityParametrization (z : ℂ) :
+    reciprocal (infinityParametrization z) = (z : RiemannSphere) := by
+  have hinfty : reciprocal (OnePoint.infty) = ((0 : ℂ) : RiemannSphere) := rfl
+  by_cases hz : z = 0
+  · subst z
+    simp [hinfty]
+  · rw [infinityParametrization_of_ne hz, reciprocal_coe,
+      infinityParametrization_of_ne (inv_ne_zero hz), inv_inv]
+
+private theorem RiemannSphere.reciprocal_involutive : Function.Involutive reciprocal := by
+  have hinfty : reciprocal (OnePoint.infty) = ((0 : ℂ) : RiemannSphere) := rfl
+  intro p
+  induction p using OnePoint.rec with
+  | infty => simp [hinfty]
+  | coe z => simp []
+
+private theorem RiemannSphere.reciprocal_holomorphic :
+    ContMDiff (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) ω reciprocal := by
+  apply standardCharts.contMDiff_of_comp_affineMaps (modelWithCornersSelf ℂ ℂ)
+  intro b
+  have he : reciprocal ∘ standardCharts.affineMap b = standardCharts.affineMap (!b) := by
+    funext z
+    cases b
+    · rfl
+    · exact reciprocal_infinityParametrization z
+  rw [he]
+  exact standardCharts.affineMap_holomorphic (!b)
+
+private def RiemannSphere.reciprocalBiholomorph : Biholomorph
+    where
+  toEquiv := reciprocal_involutive.toPerm reciprocal
+  contMDiff_toFun := reciprocal_holomorphic
+  contMDiff_invFun := reciprocal_holomorphic
+
+@[simp]
+private theorem RiemannSphere.reciprocalBiholomorph_apply (p : RiemannSphere) :
+    reciprocalBiholomorph p = reciprocal p :=
+  rfl
+
+private def RiemannSphere.affineComplexHomeomorph (a b : ℂ) (ha : a ≠ 0) : ℂ ≃ₜ ℂ :=
+  (Homeomorph.mulLeft₀ a ha).trans (Homeomorph.addRight b)
+
+private def
+    RiemannSphere.affineHomeomorph (a b : ℂ) (ha : a ≠ 0) : RiemannSphere ≃ₜ RiemannSphere :=
+  (affineComplexHomeomorph a b ha).onePointCongr
+
+@[simp]
+private theorem RiemannSphere.affineHomeomorph_coe (a b z : ℂ) (ha : a ≠ 0) :
+    RiemannSphere.affineHomeomorph a b ha (z : RiemannSphere) =
+      ((a * z + b : ℂ) : RiemannSphere) :=
+  rfl
+
+private theorem RiemannSphere.affineHomeomorph_infinityParametrization (a b z : ℂ) (ha : a ≠ 0)
+    (hz : a + b * z ≠ 0) :
+    RiemannSphere.affineHomeomorph a b ha (infinityParametrization z) =
+      infinityParametrization (z / (a + b * z)) := by
+  have hinfty :
+    RiemannSphere.affineHomeomorph a b ha ((OnePoint.infty) : RiemannSphere) =
+      ((OnePoint.infty) : RiemannSphere) :=
+    rfl
+  by_cases hz0 : z = 0
+  · subst z
+    simp [hinfty]
+  · rw [infinityParametrization_of_ne hz0, affineHomeomorph_coe,
+      infinityParametrization_of_ne (div_ne_zero hz0 hz)]
+    congr 1
+    field_simp
+
+private theorem RiemannSphere.affineHomeomorph_holomorphic (a b : ℂ) (ha : a ≠ 0) :
+    ContMDiff (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) ω
+      (RiemannSphere.affineHomeomorph a b ha) := by
+  apply standardCharts.contMDiff_of_comp_affineMaps (modelWithCornersSelf ℂ ℂ)
+  intro chart
+  cases chart
+  · have hc : ContDiff ℂ ω (fun z : ℂ => a * z + b) :=
+      (contDiff_const.mul contDiff_id).add contDiff_const
+    exact (standardCharts.affineMap_holomorphic Bool.false).comp hc.contMDiff
+  · intro z
+    by_cases hz : z = 0
+    · subst z
+      have hd : ContDiffAt ℂ ω (fun w : ℂ => w / (a + b * w)) 0 :=
+        contDiffAt_id.div (contDiffAt_const.add (contDiffAt_const.mul contDiffAt_id))
+          (by simpa using ha)
+      have hc :
+        ContMDiffAt (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) ω
+          (fun w : ℂ => infinityParametrization (w / (a + b * w))) 0 :=
+        (standardCharts.affineMap_holomorphic Bool.true).contMDiffAt.comp 0 hd.contMDiffAt
+      apply hc.congr_of_eventuallyEq
+      have hn : ∀ᶠ w : ℂ in 𝓝 0, a + b * w ≠ 0 :=
+        (isOpen_ne_fun (continuous_const.add (continuous_const.mul continuous_id))
+              continuous_const).mem_nhds
+          (by simpa using ha)
+      filter_upwards [hn] with w hw
+      exact affineHomeomorph_infinityParametrization a b w ha hw
+    · have hd : ContDiffAt ℂ ω (fun w : ℂ => a * w⁻¹ + b) z :=
+        (contDiffAt_const.mul (contDiffAt_inv ℂ hz)).add contDiffAt_const
+      have hc :
+        ContMDiffAt (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) ω
+          (fun w : ℂ => ((a * w⁻¹ + b : ℂ) : RiemannSphere)) z :=
+        (standardCharts.affineMap_holomorphic Bool.false).contMDiffAt.comp z hd.contMDiffAt
+      apply hc.congr_of_eventuallyEq
+      filter_upwards [(isOpen_ne_fun continuous_id continuous_const).mem_nhds hz] with w hw
+      change w ≠ 0 at hw
+      change RiemannSphere.affineHomeomorph a b ha (infinityParametrization w) = _
+      rw [infinityParametrization_of_ne hw, affineHomeomorph_coe]
+
+private theorem RiemannSphere.affineHomeomorph_symm_eq (a b : ℂ) (ha : a ≠ 0) :
+    ⇑(RiemannSphere.affineHomeomorph a b ha).symm =
+      RiemannSphere.affineHomeomorph a⁻¹ (-a⁻¹ * b) (inv_ne_zero ha) := by
+  funext p
+  induction p using OnePoint.rec with
+  | infty => rfl
+  | coe
+    z =>
+    change ((a⁻¹ * (z - b) : ℂ) : RiemannSphere) = ((a⁻¹ * z + -a⁻¹ * b : ℂ) : RiemannSphere)
+    congr 1
+    ring
+
+private def RiemannSphere.affineBiholomorph (a b : ℂ) (ha : a ≠ 0) : Biholomorph
+    where
+  toEquiv := (RiemannSphere.affineHomeomorph a b ha).toEquiv
+  contMDiff_toFun := affineHomeomorph_holomorphic a b ha
+  contMDiff_invFun := by
+    change
+      ContMDiff (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) ω
+        (RiemannSphere.affineHomeomorph a b ha).symm
+    rw [affineHomeomorph_symm_eq]
+    exact affineHomeomorph_holomorphic a⁻¹ (-a⁻¹ * b) (inv_ne_zero ha)
+
+@[simp]
+private theorem RiemannSphere.affineBiholomorph_coe (a b z : ℂ) (ha : a ≠ 0) :
+    affineBiholomorph a b ha (z : RiemannSphere) = ((a * z + b : ℂ) : RiemannSphere) :=
+  rfl
+
+private theorem RiemannSphere.crossRatioScale_ne_zero (a b c : ℂ) (hab : a ≠ b) (hbc : b ≠ c) :
+    (b - c) / (b - a) ≠ 0 :=
+  div_ne_zero (sub_ne_zero.mpr hbc) (sub_ne_zero.mpr hab.symm)
+
+private theorem RiemannSphere.crossRatioResidue_ne_zero (a b c : ℂ) (hab : a ≠ b) (hac : a ≠ c)
+    (hbc : b ≠ c) : (c - a) * ((b - c) / (b - a)) ≠ 0 :=
+  mul_ne_zero (sub_ne_zero.mpr hac.symm) (crossRatioScale_ne_zero a b c hab hbc)
+
+private def
+    RiemannSphere.threePointBiholomorph (a b c : ℂ) (hab : a ≠ b) (hac : a ≠ c) (hbc : b ≠ c) :
+    Biholomorph :=
+  ((affineBiholomorph 1 (-c) one_ne_zero).trans reciprocalBiholomorph).trans
+    (affineBiholomorph ((c - a) * ((b - c) / (b - a))) ((b - c) / (b - a))
+      (crossRatioResidue_ne_zero a b c hab hac hbc))
+
+private theorem RiemannSphere.threePointBiholomorph_coe (a b c : ℂ) (hab : a ≠ b) (hac : a ≠ c)
+    (hbc : b ≠ c) (z : ℂ) (hz : z ≠ c) :
+    threePointBiholomorph a b c hab hac hbc (z : RiemannSphere) =
+      ((((z - a) * (b - c)) / ((z - c) * (b - a)) : ℂ) : RiemannSphere) := by
+  change
+    affineBiholomorph _ _ _
+        (reciprocalBiholomorph (affineBiholomorph 1 (-c) one_ne_zero (z : RiemannSphere))) =
+      _
+  simp only [affineBiholomorph_coe, one_mul, ← sub_eq_add_neg, reciprocalBiholomorph_apply,
+    reciprocal_coe, infinityParametrization_of_ne (sub_ne_zero.mpr hz), affineBiholomorph_coe]
+  congr 1
+  field_simp
+  ring
+
+@[simp]
+private theorem RiemannSphere.threePointBiholomorph_third (a b c : ℂ) (hab : a ≠ b) (hac : a ≠ c)
+    (hbc : b ≠ c) :
+    threePointBiholomorph a b c hab hac hbc (c : RiemannSphere) =
+      ((OnePoint.infty) : RiemannSphere) := by
+  have hinfty (a b : ℂ) (ha : a ≠ 0) :
+    affineBiholomorph a b ha ((OnePoint.infty) : RiemannSphere) =
+      ((OnePoint.infty) : RiemannSphere) :=
+    rfl
+  have hreciprocal : reciprocal (OnePoint.infty) = ((0 : ℂ) : RiemannSphere) := rfl
+  change
+    affineBiholomorph _ _ _
+        (reciprocalBiholomorph (affineBiholomorph 1 (-c) one_ne_zero (c : RiemannSphere))) =
+      _
+  simp [hinfty]
+
+@[simp]
+private theorem RiemannSphere.threePointBiholomorph_infty (a b c : ℂ) (hab : a ≠ b) (hac : a ≠ c)
+    (hbc : b ≠ c) :
+    threePointBiholomorph a b c hab hac hbc ((OnePoint.infty) : RiemannSphere) =
+      (((b - c) / (b - a) : ℂ) : RiemannSphere) := by
+  have hinfty (a b : ℂ) (ha : a ≠ 0) :
+    affineBiholomorph a b ha ((OnePoint.infty) : RiemannSphere) =
+      ((OnePoint.infty) : RiemannSphere) :=
+    rfl
+  have hreciprocal : reciprocal (OnePoint.infty) = ((0 : ℂ) : RiemannSphere) := rfl
+  change
+    affineBiholomorph _ _ _
+        (reciprocalBiholomorph
+          (affineBiholomorph 1 (-c) one_ne_zero ((OnePoint.infty) : RiemannSphere))) =
+      _
+  simp [hinfty, hreciprocal]
+
+private def RiemannSphere.MobiusCircle.crossRatio (a b c z : ℂ) : ℂ :=
+  ((z - a) * (b - c)) / ((z - c) * (b - a))
+
+private def RiemannSphere.MobiusCircle.coefficient (a b c : ℂ) : ℂ :=
+  (b - c) / (b - a)
+
+private def RiemannSphere.MobiusCircle.orientation (a b c : ℂ) : ℝ :=
+  -(coefficient a b c).im
+
+private theorem RiemannSphere.MobiusCircle.crossRatio_eq_coefficient (a b c z : ℂ) :
+    crossRatio a b c z = coefficient a b c * ((z - a) / (z - c)) := by
+  simp only [crossRatio, coefficient, div_eq_mul_inv, mul_inv_rev]
+  ring
+
+private theorem
+    RiemannSphere.MobiusCircle.coefficient_ne_zero {a b c : ℂ} (hba : b ≠ a) (hbc : b ≠ c) :
+    coefficient a b c ≠ 0 :=
+  div_ne_zero (sub_ne_zero.mpr hbc) (sub_ne_zero.mpr hba)
+
+private theorem RiemannSphere.MobiusCircle.unit_ne_zero {z : ℂ} (hz : ‖z‖ = 1) : z ≠ 0 := by
+  intro h
+  simp [h] at hz
+
+private theorem RiemannSphere.MobiusCircle.coefficient_mul_eq_conj_mul {a b c : ℂ} (ha : ‖a‖ = 1)
+    (hb : ‖b‖ = 1) (hc : ‖c‖ = 1) (hba : b ≠ a) :
+    coefficient a b c * a = conj (coefficient a b c) * c := by
+  have ha0 := unit_ne_zero ha
+  have hb0 := unit_ne_zero hb
+  have hc0 := unit_ne_zero hc
+  have hba0 := sub_ne_zero.mpr hba
+  simp only [coefficient, map_div₀, map_sub, ← Complex.inv_eq_conj ha, ← Complex.inv_eq_conj hb,
+    ← Complex.inv_eq_conj hc]
+  field_simp
+  ring
+
+private theorem
+    RiemannSphere.MobiusCircle.orientation_ne_zero {a b c : ℂ} (ha : ‖a‖ = 1) (hb : ‖b‖ = 1)
+    (hc : ‖c‖ = 1) (hba : b ≠ a) (hbc : b ≠ c) (hac : a ≠ c) : orientation a b c ≠ 0 := by
+  intro h
+  have him : (coefficient a b c).im = 0 := neg_eq_zero.mp h
+  have hd := coefficient_mul_eq_conj_mul ha hb hc hba
+  rw [Complex.conj_eq_iff_im.mpr him] at hd
+  exact hac (mul_left_cancel₀ (coefficient_ne_zero hba hbc) hd)
+
+private theorem RiemannSphere.MobiusCircle.numerator_im {a c d : ℂ} (hc : ‖c‖ = 1)
+    (hd : d * a = conj d * c) (z : ℂ) :
+    (d * (z - a) * conj (z - c)).im = d.im * (Complex.normSq z - 1) := by
+  have hcross : conj (d * z * conj c) = conj d * c * conj z := by
+    simp only [map_mul, starRingEnd_self_apply]
+    ring
+  have hconst : conj d * c * conj c = conj d := by
+    rw [mul_assoc, Complex.mul_conj, Complex.normSq_eq_norm_sq, hc]
+    simp
+  have heq :
+    d * (z - a) * conj (z - c) =
+      d * (Complex.normSq z : ℂ) - (d * z * conj c + conj (d * z * conj c)) + conj d := by
+    calc
+      d * (z - a) * conj (z - c) =
+          d * (z * conj z) - (d * z * conj c + d * a * conj z) + d * a * conj c := by
+        rw [map_sub]
+        ring
+      _ = _ := by rw [Complex.mul_conj, hd, hconst, hcross]
+  rw [heq]
+  simp only [Complex.sub_im, Complex.add_im, Complex.mul_im, Complex.ofReal_re, Complex.ofReal_im,
+    Complex.conj_im]
+  ring
+
+private theorem RiemannSphere.MobiusCircle.crossRatio_im {a b c : ℂ} (ha : ‖a‖ = 1) (hb : ‖b‖ = 1)
+    (hc : ‖c‖ = 1) (hba : b ≠ a) (z : ℂ) :
+    (crossRatio a b c z).im = orientation a b c * (1 - ‖z‖ ^ 2) / Complex.normSq (z - c) := by
+  have heq :
+    crossRatio a b c z =
+      (coefficient a b c * (z - a) * conj (z - c)) / (Complex.normSq (z - c) : ℂ) := by
+    rw [crossRatio_eq_coefficient, div_eq_mul_inv, Complex.inv_def]
+    simp only [div_eq_mul_inv, Complex.ofReal_inv]
+    ring
+  rw [heq, Complex.div_ofReal_im, numerator_im hc (coefficient_mul_eq_conj_mul ha hb hc hba),
+    Complex.normSq_eq_norm_sq]
+  unfold orientation
+  ring
+
+private theorem RiemannSphere.MobiusCircle.orientation_mul_crossRatio_im {a b c : ℂ} (ha : ‖a‖ = 1)
+    (hb : ‖b‖ = 1) (hc : ‖c‖ = 1) (hba : b ≠ a) (z : ℂ) :
+    orientation a b c * (crossRatio a b c z).im =
+      orientation a b c ^ 2 * (1 - ‖z‖ ^ 2) / Complex.normSq (z - c) := by
+  rw [crossRatio_im ha hb hc hba]
+  ring
+
+private theorem RiemannSphere.MobiusCircle.orientation_mul_crossRatio_im_pos_iff {a b c z : ℂ}
+    (ha : ‖a‖ = 1) (hb : ‖b‖ = 1) (hc : ‖c‖ = 1) (hba : b ≠ a) (hbc : b ≠ c) (hac : a ≠ c)
+    (hzc : z ≠ c) : 0 < orientation a b c * (crossRatio a b c z).im ↔ ‖z‖ < 1 := by
+  have hK := sq_pos_of_ne_zero (orientation_ne_zero ha hb hc hba hbc hac)
+  have hd : 0 < Complex.normSq (z - c) := Complex.normSq_pos.mpr (sub_ne_zero.mpr hzc)
+  rw [orientation_mul_crossRatio_im ha hb hc hba, div_pos_iff_of_pos_right hd,
+    mul_pos_iff_of_pos_left hK, sub_pos, sq_lt_one_iff₀ (norm_nonneg z)]
+
+private theorem RiemannSphere.MobiusCircle.orientation_mul_crossRatio_im_neg_iff {a b c z : ℂ}
+    (ha : ‖a‖ = 1) (hb : ‖b‖ = 1) (hc : ‖c‖ = 1) (hba : b ≠ a) (hbc : b ≠ c) (hac : a ≠ c)
+    (hzc : z ≠ c) : orientation a b c * (crossRatio a b c z).im < 0 ↔ 1 < ‖z‖ := by
+  have hK := sq_pos_of_ne_zero (orientation_ne_zero ha hb hc hba hbc hac)
+  have hd : 0 < Complex.normSq (z - c) := Complex.normSq_pos.mpr (sub_ne_zero.mpr hzc)
+  have heq :
+    -(orientation a b c * (crossRatio a b c z).im) =
+      orientation a b c ^ 2 * (‖z‖ ^ 2 - 1) / Complex.normSq (z - c) := by
+    rw [orientation_mul_crossRatio_im ha hb hc hba]
+    ring
+  rw [← neg_pos, heq, div_pos_iff_of_pos_right hd, mul_pos_iff_of_pos_left hK, sub_pos,
+    one_lt_sq_iff₀ (norm_nonneg z)]
+
+private theorem RiemannSphere.MobiusCircle.orientation_mul_coefficient_im (a b c : ℂ) :
+    orientation a b c * (coefficient a b c).im = -(orientation a b c ^ 2) := by
+  unfold orientation
+  ring
+
+private theorem
+    RiemannSphere.MobiusCircle.orientation_mul_coefficient_im_neg {a b c : ℂ} (ha : ‖a‖ = 1)
+    (hb : ‖b‖ = 1) (hc : ‖c‖ = 1) (hba : b ≠ a) (hbc : b ≠ c) (hac : a ≠ c) :
+    orientation a b c * (coefficient a b c).im < 0 := by
+  rw [orientation_mul_coefficient_im]
+  exact neg_neg_of_pos (sq_pos_of_ne_zero (orientation_ne_zero ha hb hc hba hbc hac))
+
+private theorem
+    RiemannSphere.MobiusCircle.crossRatio_at_zero (a b c : ℂ) : crossRatio a b c a = 0 := by
+  simp [crossRatio]
+
+private theorem
+    RiemannSphere.MobiusCircle.crossRatio_at_one {a b c : ℂ} (hba : b ≠ a) (hbc : b ≠ c) :
+    crossRatio a b c b = 1 := by
+  unfold crossRatio
+  rw [mul_comm (b - c) (b - a)]
+  exact div_self (mul_ne_zero (sub_ne_zero.mpr hba) (sub_ne_zero.mpr hbc))
+
+private def RiemannSphere.finiteImage (s : Set ℂ) : Set RiemannSphere :=
+  ((↑) : ℂ → RiemannSphere) '' s
+
+@[simp]
+private theorem RiemannSphere.coe_mem_finiteImage_iff (s : Set ℂ) (z : ℂ) :
+    (z : RiemannSphere) ∈ finiteImage s ↔ z ∈ s := by simp [finiteImage]
+
+@[simp]
+private theorem RiemannSphere.infty_not_mem_finiteImage (s : Set ℂ) :
+    ((OnePoint.infty) : RiemannSphere) ∉ finiteImage s := by simp [finiteImage]
+
+private theorem
+    RiemannSphere.crossRatio_holomorphicOn_disc {a b c : ℂ} (hab : a ≠ b) (hc : ‖c‖ = 1) :
+    ContDiffOn ℂ ω (MobiusCircle.crossRatio a b c) {z : ℂ | ‖z‖ < 1} := by
+  intro z hz
+  have hzc : z ≠ c := by
+    intro he
+    subst z
+    exact (not_lt_of_ge hc.ge) hz
+  have hden : (z - c) * (b - a) ≠ 0 :=
+    mul_ne_zero (sub_ne_zero.mpr hzc) (sub_ne_zero.mpr hab.symm)
+  have hn : ContDiffAt ℂ ω (fun w : ℂ => (w - a) * (b - c)) z :=
+    (contDiffAt_id.sub contDiffAt_const).mul contDiffAt_const
+  have hd : ContDiffAt ℂ ω (fun w : ℂ => (w - c) * (b - a)) z :=
+    (contDiffAt_id.sub contDiffAt_const).mul contDiffAt_const
+  exact (hn.div hd hden).contDiffWithinAt
+
+private def RiemannSphere.closedDiscWithoutPole (c : ℂ) : Set ℂ :=
+  {z | ‖z‖ ≤ 1 ∧ z ≠ c}
+
+private def RiemannSphere.closedOrientedHalfPlane (k : ℝ) : Set ℂ :=
+  {w | 0 ≤ k * w.im}
+
+private def RiemannSphere.finiteImageHomeomorph (s : Set ℂ) : s ≃ₜ finiteImage s :=
+  (OnePoint.isOpenEmbedding_coe (X := ℂ)).isEmbedding.homeomorphImage s
+
+@[simp]
+private theorem RiemannSphere.finiteImageHomeomorph_symm_apply_coe (s : Set ℂ) (p : finiteImage s) :
+    (((finiteImageHomeomorph s).symm p : ℂ) : RiemannSphere) = (p : RiemannSphere) := by
+  exact congrArg Subtype.val ((finiteImageHomeomorph s).apply_symm_apply p)
+
+private theorem RiemannSphere.orientation_mul_crossRatio_im_nonneg_iff {a b c : ℂ} (hab : a ≠ b)
+    (hac : a ≠ c) (hbc : b ≠ c) (ha : ‖a‖ = 1) (hb : ‖b‖ = 1) (hc : ‖c‖ = 1) {z : ℂ}
+    (hzc : z ≠ c) :
+    0 ≤ MobiusCircle.orientation a b c * (MobiusCircle.crossRatio a b c z).im ↔ ‖z‖ ≤ 1 := by
+  have h :=
+    not_congr (MobiusCircle.orientation_mul_crossRatio_im_neg_iff ha hb hc hab.symm hbc hac hzc)
+  simpa only [not_lt] using h
+
+private theorem
+    RiemannSphere.threePointBiholomorph_mem_closedHalfPlane_iff {a b c : ℂ} (hab : a ≠ b)
+    (hac : a ≠ c) (hbc : b ≠ c) (ha : ‖a‖ = 1) (hb : ‖b‖ = 1) (hc : ‖c‖ = 1) (p : RiemannSphere) :
+    threePointBiholomorph a b c hab hac hbc p ∈
+        finiteImage (closedOrientedHalfPlane (MobiusCircle.orientation a b c)) ↔
+      p ∈ finiteImage (closedDiscWithoutPole c) := by
+  induction p using OnePoint.rec with
+  | infty =>
+    rw [threePointBiholomorph_infty]
+    simp only [coe_mem_finiteImage_iff, infty_not_mem_finiteImage, iff_false,
+      closedOrientedHalfPlane, Set.mem_ofPred_eq]
+    exact not_le_of_gt (MobiusCircle.orientation_mul_coefficient_im_neg ha hb hc hab.symm hbc hac)
+  | coe z =>
+    by_cases hzc : z = c
+    · subst z
+      simp [closedDiscWithoutPole]
+    · rw [threePointBiholomorph_coe a b c hab hac hbc z hzc]
+      simp only [coe_mem_finiteImage_iff, closedOrientedHalfPlane, closedDiscWithoutPole,
+        Set.mem_ofPred_eq, and_iff_left hzc]
+      exact orientation_mul_crossRatio_im_nonneg_iff hab hac hbc ha hb hc hzc
+
+private def
+    RiemannSphere.closedDiscHalfPlaneSphereHomeomorph {a b c : ℂ} (hab : a ≠ b) (hac : a ≠ c)
+    (hbc : b ≠ c) (ha : ‖a‖ = 1) (hb : ‖b‖ = 1) (hc : ‖c‖ = 1) :
+    finiteImage (closedDiscWithoutPole c) ≃ₜ
+      finiteImage (closedOrientedHalfPlane (MobiusCircle.orientation a b c)) :=
+  (threePointBiholomorph a b c hab hac hbc).toHomeomorph.subtype
+    (fun p => (threePointBiholomorph_mem_closedHalfPlane_iff hab hac hbc ha hb hc p).symm)
+
+private def RiemannSphere.closedDiscHalfPlaneHomeomorph {a b c : ℂ} (hab : a ≠ b) (hac : a ≠ c)
+    (hbc : b ≠ c) (ha : ‖a‖ = 1) (hb : ‖b‖ = 1) (hc : ‖c‖ = 1) :
+    closedDiscWithoutPole c ≃ₜ closedOrientedHalfPlane (MobiusCircle.orientation a b c) :=
+  ((finiteImageHomeomorph (closedDiscWithoutPole c)).trans
+        (closedDiscHalfPlaneSphereHomeomorph hab hac hbc ha hb hc)).trans
+    (finiteImageHomeomorph (closedOrientedHalfPlane (MobiusCircle.orientation a b c))).symm
+
+private theorem
+    RiemannSphere.closedDiscHalfPlaneHomeomorph_sphere {a b c : ℂ} (hab : a ≠ b) (hac : a ≠ c)
+    (hbc : b ≠ c) (ha : ‖a‖ = 1) (hb : ‖b‖ = 1) (hc : ‖c‖ = 1) (z : closedDiscWithoutPole c) :
+    (((closedDiscHalfPlaneHomeomorph hab hac hbc ha hb hc z :
+            closedOrientedHalfPlane (MobiusCircle.orientation a b c)) :
+          ℂ) :
+        RiemannSphere) =
+      threePointBiholomorph a b c hab hac hbc ((z : ℂ) : RiemannSphere) := by
+  exact
+    finiteImageHomeomorph_symm_apply_coe
+      (closedOrientedHalfPlane (MobiusCircle.orientation a b c))
+      (closedDiscHalfPlaneSphereHomeomorph hab hac hbc ha hb hc
+        (finiteImageHomeomorph (closedDiscWithoutPole c) z))
+
+@[simp]
+private theorem
+    RiemannSphere.closedDiscHalfPlaneHomeomorph_apply {a b c : ℂ} (hab : a ≠ b) (hac : a ≠ c)
+    (hbc : b ≠ c) (ha : ‖a‖ = 1) (hb : ‖b‖ = 1) (hc : ‖c‖ = 1) (z : closedDiscWithoutPole c) :
+    (closedDiscHalfPlaneHomeomorph hab hac hbc ha hb hc z : ℂ) =
+      MobiusCircle.crossRatio a b c z := by
+  apply OnePoint.coe_injective
+  rw [closedDiscHalfPlaneHomeomorph_sphere,
+    threePointBiholomorph_coe a b c hab hac hbc z z.property.2]
+  rfl
+
+private theorem RiemannSphere.closedDiscHalfPlaneHomeomorph_strict_iff {a b c : ℂ} (hab : a ≠ b)
+    (hac : a ≠ c) (hbc : b ≠ c) (ha : ‖a‖ = 1) (hb : ‖b‖ = 1) (hc : ‖c‖ = 1)
+    (z : closedDiscWithoutPole c) :
+    0 <
+        MobiusCircle.orientation a b c *
+          (closedDiscHalfPlaneHomeomorph hab hac hbc ha hb hc z : ℂ).im ↔
+      ‖(z : ℂ)‖ < 1 := by
+  rw [closedDiscHalfPlaneHomeomorph_apply]
+  exact MobiusCircle.orientation_mul_crossRatio_im_pos_iff ha hb hc hab.symm hbc hac z.property.2
+
+private def TriangleUniformizationGluing.halfPlaneOrientationSign (k : ℝ) : ℝ :=
+  if 0 < k then 1 else -1
+
+private theorem TriangleUniformizationGluing.halfPlaneOrientationSign_sq (k : ℝ) :
+    halfPlaneOrientationSign k ^ 2 = 1 := by
+  unfold halfPlaneOrientationSign
+  split_ifs <;> norm_num
+
+private theorem
+    TriangleUniformizationGluing.halfPlaneOrientationSign_nonneg_iff {k : ℝ} (hk : k ≠ 0)
+    (t : ℝ) : 0 ≤ halfPlaneOrientationSign k * t ↔ 0 ≤ k * t := by
+  unfold halfPlaneOrientationSign
+  split_ifs with hp
+  · simpa only [one_mul] using (mul_nonneg_iff_of_pos_left hp).symm
+  · have hn : k < 0 := lt_of_le_of_ne (le_of_not_gt hp) hk
+    simp only [neg_one_mul, neg_nonneg]
+    constructor
+    · exact fun ht => mul_nonneg_of_nonpos_of_nonpos hn.le ht
+    · intro ht
+      by_contra h
+      exact (not_le_of_gt (mul_neg_of_neg_of_pos hn (lt_of_not_ge h))) ht
+
+private theorem TriangleUniformizationGluing.halfPlaneOrientationSign_pos_iff {k : ℝ} (hk : k ≠ 0)
+    (t : ℝ) : 0 < halfPlaneOrientationSign k * t ↔ 0 < k * t := by
+  unfold halfPlaneOrientationSign
+  split_ifs with hp
+  · simpa only [one_mul] using (mul_pos_iff_of_pos_left hp).symm
+  · have hn : k < 0 := lt_of_le_of_ne (le_of_not_gt hp) hk
+    simp only [neg_one_mul, neg_pos]
+    constructor
+    · exact fun ht => mul_pos_of_neg_of_neg hn ht
+    · intro ht
+      by_contra h
+      exact (not_lt_of_ge (mul_nonpos_of_nonpos_of_nonneg hn.le (le_of_not_gt h))) ht
+
+private def TriangleUniformizationGluing.halfFordHomeomorphExtension {k : ℝ}
+    (e : SpecialPeriods.Triangle.halfFordRegion ≃ₜ RiemannSphere.closedOrientedHalfPlane k)
+    (z : ℍ) : ℂ := by
+  classical exact if hz : z ∈ SpecialPeriods.Triangle.halfFordRegion then (e ⟨z, hz⟩ : ℂ) else 0
+
+@[simp]
+private theorem TriangleUniformizationGluing.halfFordHomeomorphExtension_coe {k : ℝ}
+    (e : SpecialPeriods.Triangle.halfFordRegion ≃ₜ RiemannSphere.closedOrientedHalfPlane k)
+    (z : SpecialPeriods.Triangle.halfFordRegion) : halfFordHomeomorphExtension e z = (e z : ℂ) := by
+  simp only [halfFordHomeomorphExtension, dite_eq_left z.property]
+
+private theorem TriangleUniformizationGluing.halfFordHomeomorphExtension_of_mem {k : ℝ}
+    (e : SpecialPeriods.Triangle.halfFordRegion ≃ₜ RiemannSphere.closedOrientedHalfPlane k)
+    {z : ℍ} (hz : z ∈ SpecialPeriods.Triangle.halfFordRegion) :
+    halfFordHomeomorphExtension e z = (e ⟨z, hz⟩ : ℂ) :=
+  halfFordHomeomorphExtension_coe e ⟨z, hz⟩
+
+private theorem TriangleUniformizationGluing.halfFordHomeomorphExtension_continuousOn {k : ℝ}
+    (e : SpecialPeriods.Triangle.halfFordRegion ≃ₜ RiemannSphere.closedOrientedHalfPlane k) :
+    ContinuousOn (halfFordHomeomorphExtension e) SpecialPeriods.Triangle.halfFordRegion := by
+  rw [continuousOn_iff_continuous_domRestrict]
+  change
+    Continuous (fun z : SpecialPeriods.Triangle.halfFordRegion => halfFordHomeomorphExtension e z)
+  simp only [halfFordHomeomorphExtension_coe]
+  exact continuous_subtype_val.comp e.continuous
+
+private theorem TriangleUniformizationGluing.halfFordHomeomorphExtension_isProperMap {k : ℝ}
+    (e : SpecialPeriods.Triangle.halfFordRegion ≃ₜ RiemannSphere.closedOrientedHalfPlane k) :
+    IsProperMap
+      (fun z : SpecialPeriods.Triangle.halfFordRegion => halfFordHomeomorphExtension e z) := by
+  have hc : IsClosed (RiemannSphere.closedOrientedHalfPlane k) :=
+    isClosed_le continuous_const (continuous_const.mul Complex.continuous_im)
+  simpa only [Function.comp_def, halfFordHomeomorphExtension_coe] using
+    hc.isProperMap_subtypeVal.comp e.isProperMap
+
+private def TriangleUniformizationGluing.signedHalfPlaneMapOfHomeomorph {k : ℝ} (hk : k ≠ 0)
+    (e : SpecialPeriods.Triangle.halfFordRegion ≃ₜ RiemannSphere.closedOrientedHalfPlane k)
+    (hinterior :
+      ∀ z : SpecialPeriods.Triangle.halfFordRegion,
+        0 < k * (e z : ℂ).im ↔ (z : ℍ) ∈ SpecialPeriods.Triangle.halfFordInterior) :
+    SignedHalfPlaneMap where
+  toFun := halfFordHomeomorphExtension e
+  continuousOn := halfFordHomeomorphExtension_continuousOn e
+  boundary_real := by
+    intro z hz hi
+    rw [halfFordHomeomorphExtension_of_mem e hz]
+    have hn : ¬0 < k * (e ⟨z, hz⟩ : ℂ).im := fun h => hi ((hinterior ⟨z, hz⟩).mp h)
+    have he : k * (e ⟨z, hz⟩ : ℂ).im = 0 := le_antisymm (le_of_not_gt hn) (e ⟨z, hz⟩).property
+    exact (mul_eq_zero.mp he).resolve_left hk
+  orientation := halfPlaneOrientationSign k
+  orientation_sq := halfPlaneOrientationSign_sq k
+  injOn := by
+    intro z hz w hw he
+    rw [halfFordHomeomorphExtension_of_mem e hz, halfFordHomeomorphExtension_of_mem e hw] at he
+    exact congrArg Subtype.val (e.injective (Subtype.ext he))
+  image_eq := by
+    ext w
+    constructor
+    · rintro ⟨z, hz, rfl⟩
+      rw [Set.mem_ofPred_eq, halfFordHomeomorphExtension_of_mem e hz,
+        halfPlaneOrientationSign_nonneg_iff hk]
+      exact (e ⟨z, hz⟩).property
+    · intro hw
+      have hwk : w ∈ RiemannSphere.closedOrientedHalfPlane k :=
+        (halfPlaneOrientationSign_nonneg_iff hk w.im).mp hw
+      obtain ⟨z, hz⟩ := e.surjective ⟨w, hwk⟩
+      refine ⟨z, z.property, ?_⟩
+      rw [halfFordHomeomorphExtension_coe]
+      exact congrArg Subtype.val hz
+  interior_positive := by
+    intro z hz
+    have hzR : z ∈ SpecialPeriods.Triangle.halfFordRegion :=
+      SpecialPeriods.Triangle.halfFordInterior_subset_halfFordRegion hz
+    rw [halfFordHomeomorphExtension_of_mem e hzR, halfPlaneOrientationSign_pos_iff hk]
+    exact (hinterior ⟨z, hzR⟩).mpr hz
+
+@[simp]
+private theorem
+    TriangleUniformizationGluing.signedHalfPlaneMapOfHomeomorph_apply {k : ℝ} (hk : k ≠ 0)
+    (e : SpecialPeriods.Triangle.halfFordRegion ≃ₜ RiemannSphere.closedOrientedHalfPlane k)
+    (hinterior :
+      ∀ z : SpecialPeriods.Triangle.halfFordRegion,
+        0 < k * (e z : ℂ).im ↔ (z : ℍ) ∈ SpecialPeriods.Triangle.halfFordInterior)
+    (z : SpecialPeriods.Triangle.halfFordRegion) :
+    signedHalfPlaneMapOfHomeomorph hk e hinterior z = (e z : ℂ) :=
+  halfFordHomeomorphExtension_coe e z
+
+private def SpecialPeriods.Triangle.triangleClosedRegion : Set ℂ :=
+  {z | stripLeft ≤ z.re ∧ z.re ≤ -1 / 2 ∧ 0 < z.im ∧ 1 ≤ ‖z + 1‖}
+
+private theorem
+    SpecialPeriods.Triangle.boundaryHeight_pos_of_closed_bounds {x : ℝ} (hl : stripLeft ≤ x)
+    (hr : x ≤ -1 / 2) : 0 < boundaryHeight x := by
+  have hlo : 0 < x + 2 := by linarith [neg_two_lt_stripLeft]
+  have hhi : 0 < -x := by linarith
+  apply Real.sqrt_pos.mpr
+  nlinarith [mul_pos hlo hhi]
+
+private theorem SpecialPeriods.Triangle.circle_closed_epigraph_iff {z : ℂ} (hl : stripLeft ≤ z.re)
+    (hr : z.re ≤ -1 / 2) : (0 < z.im ∧ 1 ≤ ‖z + 1‖) ↔ boundaryHeight z.re ≤ z.im := by
+  have hnorm : ‖z + 1‖ ^ 2 = (z.re + 1) ^ 2 + z.im ^ 2 := by
+    rw [← Complex.normSq_eq_norm_sq]
+    simp [Complex.normSq_apply, pow_two]
+  constructor
+  · rintro ⟨hy, hn⟩
+    apply (Real.sqrt_le_left hy.le).mpr
+    have hs := (sq_le_sq₀ (show (0 : ℝ) ≤ 1 by norm_num) (norm_nonneg (z + 1))).mpr hn
+    nlinarith
+  · intro hh
+    have hy : 0 < z.im := (boundaryHeight_pos_of_closed_bounds hl hr).trans_le hh
+    refine ⟨hy, ?_⟩
+    apply (sq_le_sq₀ (show (0 : ℝ) ≤ 1 by norm_num) (norm_nonneg (z + 1))).mp
+    have hs := (Real.sqrt_le_left hy.le).mp hh
+    nlinarith
+
+private theorem SpecialPeriods.Triangle.mem_triangleClosedRegion_iff_epigraph (z : ℂ) :
+    z ∈ triangleClosedRegion ↔ stripLeft ≤ z.re ∧ z.re ≤ -1 / 2 ∧ boundaryHeight z.re ≤ z.im := by
+  constructor
+  · rintro ⟨hl, hr, hi, hn⟩
+    exact ⟨hl, hr, (circle_closed_epigraph_iff hl hr).mp ⟨hi, hn⟩⟩
+  · rintro ⟨hl, hr, hh⟩
+    exact ⟨hl, hr, (circle_closed_epigraph_iff hl hr).mpr hh⟩
+
+private def SpecialPeriods.Triangle.triangleClosedStrip : Set ℂ :=
+  {z | stripLeft ≤ z.re ∧ z.re ≤ -1 / 2 ∧ 0 ≤ z.im}
+
+private theorem SpecialPeriods.Triangle.triangleOpenStrip_eq_reProdIm :
+    triangleOpenStrip = (Set.Ioo stripLeft (-1 / 2)) ×ℂ (Set.Ioi 0) := by
+  ext z
+  change
+    (stripLeft < z.re ∧ z.re < -1 / 2 ∧ 0 < z.im) ↔
+      ((stripLeft < z.re ∧ z.re < -1 / 2) ∧ 0 < z.im)
+  exact and_assoc.symm
+
+private theorem SpecialPeriods.Triangle.triangleClosedStrip_eq_reProdIm :
+    triangleClosedStrip = (Set.Icc stripLeft (-1 / 2)) ×ℂ (Set.Ici 0) := by
+  ext z
+  change
+    (stripLeft ≤ z.re ∧ z.re ≤ -1 / 2 ∧ 0 ≤ z.im) ↔
+      ((stripLeft ≤ z.re ∧ z.re ≤ -1 / 2) ∧ 0 ≤ z.im)
+  exact and_assoc.symm
+
+private theorem SpecialPeriods.Triangle.closure_triangleOpenStrip :
+    closure triangleOpenStrip = triangleClosedStrip := by
+  rw [triangleOpenStrip_eq_reProdIm, Complex.closure_reProdIm,
+    closure_Ioo (show stripLeft ≠ -1 / 2 by linarith [stripLeft_lt_neg_one]), closure_Ioi, ←
+    triangleClosedStrip_eq_reProdIm]
+
+private theorem SpecialPeriods.Triangle.triangleClosedRegion_eq_preimage_strip :
+    triangleClosedRegion = triangleHeightShift ⁻¹' triangleClosedStrip := by
+  ext z
+  rw [mem_triangleClosedRegion_iff_epigraph]
+  simp only [Set.mem_preimage, triangleClosedStrip, Set.mem_ofPred_eq, triangleHeightShift_re,
+    triangleHeightShift_im, sub_nonneg]
+
+private theorem SpecialPeriods.Triangle.closure_triangleInterior :
+    closure triangleInterior = triangleClosedRegion := by
+  rw [triangleInterior_eq_preimage_strip, ← triangleHeightShift.preimage_closure,
+    closure_triangleOpenStrip, ← triangleClosedRegion_eq_preimage_strip]
+
+private theorem SpecialPeriods.Triangle.triangle_norm_add_one_le_norm {z : ℂ} (hz : z.re ≤ -1 / 2) :
+    ‖z + 1‖ ≤ ‖z‖ := by
+  apply (sq_le_sq₀ (norm_nonneg (z + 1)) (norm_nonneg z)).mp
+  rw [← Complex.normSq_eq_norm_sq, ← Complex.normSq_eq_norm_sq]
+  simp only [Complex.normSq_apply, Complex.add_re, Complex.one_re, Complex.add_im, Complex.one_im,
+    add_zero]
+  nlinarith
+
+private theorem SpecialPeriods.Triangle.coe_mem_triangleClosedRegion_iff_halfFordRegion (z : ℍ) :
+    (z : ℂ) ∈ triangleClosedRegion ↔ z ∈ halfFordRegion := by
+  change
+    (stripLeft ≤ z.re ∧ z.re ≤ -1 / 2 ∧ 0 < z.im ∧ 1 ≤ ‖(z : ℂ) + 1‖) ↔
+      ((stripLeft ≤ z.re ∧ z.re ≤ stripRight ∧ 1 ≤ ‖(z : ℂ) + 1‖ ∧ 1 ≤ ‖(z : ℂ)‖) ∧
+        z.re ≤ -(1 / 2))
+  constructor
+  · rintro ⟨hl, hr, _, hn⟩
+    refine ⟨⟨hl, ?_, hn, hn.trans (triangle_norm_add_one_le_norm hr)⟩, by linarith⟩
+    linarith [stripRight_pos]
+  · rintro ⟨hz, hr⟩
+    exact ⟨hz.1, by linarith, z.im_pos, hz.2.2.1⟩
+
+private theorem RiemannMapping.isCompact_discHomeomorph_preimage_closedBall {U : Set ℂ}
+    (e : U ≃ₜ Metric.ball (0 : ℂ) 1) {r : ℝ} (hr : r < 1) :
+    IsCompact
+      ((Subtype.val : U → ℂ) ''
+        (e ⁻¹' ((Subtype.val : Metric.ball (0 : ℂ) 1 → ℂ) ⁻¹' Metric.closedBall 0 r))) := by
+  apply IsCompact.image _ continuous_subtype_val
+  apply e.isCompact_preimage.mpr
+  apply
+    Topology.IsInducing.subtypeVal.isCompact_preimage' (ProperSpace.isCompact_closedBall _ _) ?_
+  simpa only [Subtype.range_coe] using Metric.closedBall_subset_ball hr
+
+private theorem RiemannMapping.tendsto_norm_discHomeomorph_of_notMem {U : Set ℂ}
+    (e : U ≃ₜ Metric.ball (0 : ℂ) 1) {α : Type*} {l : Filter α} {z : α → U} {a : ℂ} (ha : a ∉ U)
+    (hz : Filter.Tendsto (fun i => (z i : ℂ)) l (𝓝 a)) :
+    Filter.Tendsto (fun i => ‖(e (z i) : ℂ)‖) l (𝓝 1) := by
+  apply tendsto_order.mpr
+  constructor
+  · intro r hr
+    let K : Set ℂ :=
+      (Subtype.val : U → ℂ) ''
+        (e ⁻¹' ((Subtype.val : Metric.ball (0 : ℂ) 1 → ℂ) ⁻¹' Metric.closedBall 0 r))
+    have hK : IsCompact K := isCompact_discHomeomorph_preimage_closedBall e hr
+    have haK : a ∉ K := by
+      rintro ⟨w, _, hwa⟩
+      exact ha (hwa ▸ w.property)
+    have hevent : ∀ᶠ i in l, (z i : ℂ) ∉ K :=
+      hz.eventually (hK.isClosed.isOpen_compl.mem_nhds haK)
+    filter_upwards [hevent] with i hi
+    apply lt_of_not_ge
+    intro hle
+    apply hi
+    refine ⟨z i, ?_, rfl⟩
+    simpa only [Set.mem_preimage, Metric.mem_closedBall, dist_zero_right] using hle
+  · intro r hr
+    apply Filter.Eventually.of_forall
+    intro i
+    have hi : ‖(e (z i) : ℂ)‖ < 1 := by
+      simpa only [Metric.mem_ball, dist_zero_right] using (e (z i)).property
+    exact hi.trans hr
+
+private theorem RiemannBoundary.tendsto_norm_discHomeomorph_of_cocompact {D : Set ℂ}
+    (e : D ≃ₜ Metric.ball (0 : ℂ) 1) {f : ℂ → ℂ} (he : ∀ z : D, f z = (e z : ℂ)) {α : Type*}
+    {l : Filter α} {z : α → ℂ} (hz : Filter.Tendsto z l (Filter.cocompact ℂ))
+    (hmem : ∀ᶠ i in l, z i ∈ D) : Filter.Tendsto (fun i => ‖f (z i)‖) l (𝓝 1) := by
+  apply tendsto_order.mpr
+  constructor
+  · intro r hr
+    let K : Set ℂ :=
+      (Subtype.val : D → ℂ) ''
+        (e ⁻¹' ((Subtype.val : Metric.ball (0 : ℂ) 1 → ℂ) ⁻¹' Metric.closedBall 0 r))
+    have hK : IsCompact K := RiemannMapping.isCompact_discHomeomorph_preimage_closedBall e hr
+    have hesc : ∀ᶠ i in l, z i ∉ K := hz.eventually hK.compl_mem_cocompact
+    filter_upwards [hesc, hmem] with i hi him
+    apply lt_of_not_ge
+    intro hle
+    apply hi
+    refine ⟨⟨z i, him⟩, ?_, rfl⟩
+    have hh := he ⟨z i, him⟩
+    simpa only [Set.mem_preimage, Metric.mem_closedBall, dist_zero_right, ← hh] using hle
+  · intro r hr
+    filter_upwards [hmem] with i hi
+    have hh := he ⟨z i, hi⟩
+    have hb : ‖f (z i)‖ < 1 := by
+      simpa only [Metric.mem_ball, dist_zero_right, ← hh] using (e ⟨z i, hi⟩).property
+    exact hb.trans hr
+
+private theorem RiemannBoundary.tendsto_norm_discHomeomorph_of_norm_atTop {D : Set ℂ}
+    (e : D ≃ₜ Metric.ball (0 : ℂ) 1) {f : ℂ → ℂ} (he : ∀ z : D, f z = (e z : ℂ)) {α : Type*}
+    {l : Filter α} {z : α → ℂ} (hz : Filter.Tendsto (fun i => ‖z i‖) l Filter.atTop)
+    (hmem : ∀ᶠ i in l, z i ∈ D) : Filter.Tendsto (fun i => ‖f (z i)‖) l (𝓝 1) := by
+  apply tendsto_norm_discHomeomorph_of_cocompact e he _ hmem
+  simpa only [Metric.cobounded_eq_cocompact] using tendsto_norm_atTop_iff_cobounded.mp hz
+
+private theorem RiemannBoundary.tendsto_norm_discHomeomorph_of_im_atTop {D : Set ℂ}
+    (e : D ≃ₜ Metric.ball (0 : ℂ) 1) {f : ℂ → ℂ} (he : ∀ z : D, f z = (e z : ℂ)) {α : Type*}
+    {l : Filter α} {z : α → ℂ} (hz : Filter.Tendsto (fun i => (z i).im) l Filter.atTop)
+    (hmem : ∀ᶠ i in l, z i ∈ D) : Filter.Tendsto (fun i => ‖f (z i)‖) l (𝓝 1) :=
+  tendsto_norm_discHomeomorph_of_norm_atTop e he
+    (Filter.tendsto_atTop_mono (fun i => Complex.im_le_norm (z i)) hz) hmem
+
+private def RiemannBoundary.logHalfStrip (a c : ℝ) (q : ℂ) : ℂ :=
+  a - Complex.I * c * Complex.log q
+
+@[simp]
+private theorem RiemannBoundary.logHalfStrip_re (a c : ℝ) (q : ℂ) :
+    (logHalfStrip a c q).re = a + c * q.arg := by
+  simp [logHalfStrip, Complex.mul_re, Complex.mul_im, Complex.log_im]
+
+@[simp]
+private theorem RiemannBoundary.logHalfStrip_im (a c : ℝ) (q : ℂ) :
+    (logHalfStrip a c q).im = -c * Real.log ‖q‖ := by
+  simp [logHalfStrip, Complex.mul_re, Complex.mul_im, Complex.log_re]
+
+private theorem RiemannBoundary.tendsto_logHalfStrip_im_atTop (a : ℝ) {c : ℝ} (hc : 0 < c) :
+    Filter.Tendsto (fun q : ℂ => (logHalfStrip a c q).im) (𝓝[≠] 0) Filter.atTop := by
+  simp only [logHalfStrip_im]
+  exact
+    (Filter.tendsto_const_mul_atTop_of_neg (neg_neg_of_pos hc)).mpr
+      (Real.tendsto_log_nhdsGT_zero.comp tendsto_norm_nhdsNE_zero)
+
+private theorem RiemannBoundary.tendsto_norm_discHomeomorph_logHalfStrip {D : Set ℂ}
+    (e : D ≃ₜ Metric.ball (0 : ℂ) 1) {f : ℂ → ℂ} (he : ∀ z : D, f z = (e z : ℂ)) (a : ℝ) {c : ℝ}
+    (hc : 0 < c) (hmem : ∀ᶠ q in 𝓝[{z : ℂ | 0 < z.im}] (0 : ℂ), logHalfStrip a c q ∈ D) :
+    Filter.Tendsto (fun q => ‖f (logHalfStrip a c q)‖) (𝓝[{z : ℂ | 0 < z.im}] (0 : ℂ)) (𝓝 1) := by
+  apply tendsto_norm_discHomeomorph_of_im_atTop e he _ hmem
+  apply (tendsto_logHalfStrip_im_atTop a hc).mono_left
+  apply nhdsWithin_mono
+  intro z hz
+  change 0 < z.im at hz
+  change z ≠ 0
+  intro heq
+  rw [heq, Complex.zero_im] at hz
+  exact (lt_irrefl 0) hz
+
+private def RiemannBoundary.onePointLogHalfStrip (a c : ℝ) (q : ℂ) : OnePoint ℂ :=
+  if q = 0 then (OnePoint.infty) else (logHalfStrip a c q : OnePoint ℂ)
+
+@[simp]
+private theorem RiemannBoundary.onePointLogHalfStrip_zero (a c : ℝ) :
+    onePointLogHalfStrip a c 0 = (OnePoint.infty) := by simp [onePointLogHalfStrip]
+
+private theorem RiemannBoundary.onePointLogHalfStrip_of_ne_zero (a c : ℝ) {q : ℂ} (hq : q ≠ 0) :
+    onePointLogHalfStrip a c q = (logHalfStrip a c q : OnePoint ℂ) := by
+  simp [onePointLogHalfStrip, hq]
+
+private theorem RiemannBoundary.tendsto_logHalfStrip_cocompact (a : ℝ) {c : ℝ} (hc : 0 < c) :
+    Filter.Tendsto (logHalfStrip a c) (𝓝[≠] 0) (Filter.cocompact ℂ) := by
+  have hn : Filter.Tendsto (fun q : ℂ => ‖logHalfStrip a c q‖) (𝓝[≠] 0) Filter.atTop :=
+    Filter.tendsto_atTop_mono (fun q => Complex.im_le_norm (logHalfStrip a c q))
+      (tendsto_logHalfStrip_im_atTop a hc)
+  simpa only [Metric.cobounded_eq_cocompact] using tendsto_norm_atTop_iff_cobounded.mp hn
+
+private theorem RiemannBoundary.tendsto_coe_logHalfStrip_infty (a : ℝ) {c : ℝ} (hc : 0 < c) :
+    Filter.Tendsto (fun q : ℂ => (logHalfStrip a c q : OnePoint ℂ)) (𝓝[≠] 0)
+      (𝓝 (OnePoint.infty)) := by
+  have hcoe : Filter.Tendsto ((↑) : ℂ → OnePoint ℂ) (Filter.cocompact ℂ) (𝓝 (OnePoint.infty)) := by
+    simpa only [Filter.coclosedCompact_eq_cocompact] using (OnePoint.tendsto_coe_infty (X := ℂ))
+  exact hcoe.comp (tendsto_logHalfStrip_cocompact a hc)
+
+private theorem
+    RiemannBoundary.continuousAt_onePointLogHalfStrip_zero (a : ℝ) {c : ℝ} (hc : 0 < c) :
+    ContinuousAt (onePointLogHalfStrip a c) 0 := by
+  rw [continuousAt_iff_punctured_nhds, onePointLogHalfStrip_zero]
+  apply (tendsto_coe_logHalfStrip_infty a hc).congr'
+  filter_upwards [self_mem_nhdsWithin] with q hq
+  exact (onePointLogHalfStrip_of_ne_zero a c hq).symm
+
+private def RiemannBoundary.onePointDomain (D : Set ℂ) : Set (OnePoint ℂ) :=
+  ((↑) : ℂ → OnePoint ℂ) '' D
+
+@[simp]
+private theorem RiemannBoundary.coe_mem_onePointDomain {D : Set ℂ} {z : ℂ} :
+    (z : OnePoint ℂ) ∈ onePointDomain D ↔ z ∈ D := by exact OnePoint.coe_injective.mem_set_image
+
+@[simp]
+private theorem RiemannBoundary.infty_notMem_onePointDomain (D : Set ℂ) :
+    (OnePoint.infty) ∉ onePointDomain D :=
+  OnePoint.infty_notMem_image_coe
+
+private theorem RiemannBoundary.isOpen_onePointDomain {D : Set ℂ} (hD : IsOpen D) :
+    IsOpen (onePointDomain D) :=
+  OnePoint.isOpen_image_coe.mpr hD
+
+private def RiemannBoundary.onePointDomainHomeomorph (D : Set ℂ) : D ≃ₜ onePointDomain D :=
+  OnePoint.isOpenEmbedding_coe.isEmbedding.homeomorphImage D
+
+@[simp]
+private theorem RiemannBoundary.onePointDomainHomeomorph_apply_coe (D : Set ℂ) (z : D) :
+    (onePointDomainHomeomorph D z : OnePoint ℂ) = (z : ℂ) :=
+  rfl
+
+private def
+    RiemannBoundary.onePointDomainDiscHomeomorph {D : Set ℂ} (e : D ≃ₜ Metric.ball (0 : ℂ) 1) :
+    onePointDomain D ≃ₜ Metric.ball (0 : ℂ) 1 :=
+  (onePointDomainHomeomorph D).symm.trans e
+
+@[simp]
+private theorem RiemannBoundary.onePointDomainDiscHomeomorph_apply {D : Set ℂ}
+    (e : D ≃ₜ Metric.ball (0 : ℂ) 1) (z : D) :
+    onePointDomainDiscHomeomorph e (onePointDomainHomeomorph D z) = e z := by
+  simp [onePointDomainDiscHomeomorph]
+
+private theorem RiemannBoundary.onePointDomainDiscHomeomorph_representative {D : Set ℂ}
+    (e : D ≃ₜ Metric.ball (0 : ℂ) 1) {f : ℂ → ℂ} (he : ∀ z : D, f z = (e z : ℂ)) (b : ℂ)
+    (z : onePointDomain D) : (z : OnePoint ℂ).elim b f = (onePointDomainDiscHomeomorph e z : ℂ) :=
+  by
+  obtain ⟨w, rfl⟩ := (onePointDomainHomeomorph D).surjective z
+  simpa only [onePointDomainHomeomorph_apply_coe, OnePoint.elim_some,
+    onePointDomainDiscHomeomorph_apply] using he w
+
+private theorem
+    RiemannBoundary.infty_mem_frontier_onePointDomain_of_cocompact {D : Set ℂ} {α : Type*}
+    {l : Filter α} [Filter.NeBot l] {z : α → ℂ} (hz : Filter.Tendsto z l (Filter.cocompact ℂ))
+    (hmem : ∀ᶠ i in l, z i ∈ D) : ((OnePoint.infty) : OnePoint ℂ) ∈ frontier (onePointDomain D) :=
+  by
+  have hcoe : Filter.Tendsto ((↑) : ℂ → OnePoint ℂ) (Filter.cocompact ℂ) (𝓝 (OnePoint.infty)) := by
+    simpa only [Filter.coclosedCompact_eq_cocompact] using (OnePoint.tendsto_coe_infty (X := ℂ))
+  have hcl : ((OnePoint.infty) : OnePoint ℂ) ∈ closure (onePointDomain D) := by
+    apply isClosed_closure.mem_of_tendsto (hcoe.comp hz)
+    filter_upwards [hmem] with i hi
+    exact subset_closure (coe_mem_onePointDomain.mpr hi)
+  exact ⟨hcl, fun hi => infty_notMem_onePointDomain D (interior_subset hi)⟩
+
+private def SpecialPeriods.Triangle.triangleVerticalRay (t : ℝ) : ℂ :=
+  -1 + ((t : ℂ) + 2) * Complex.I
+
+@[simp]
+private theorem SpecialPeriods.Triangle.triangleVerticalRay_re (t : ℝ) :
+    (triangleVerticalRay t).re = -1 := by simp [triangleVerticalRay]
+
+@[simp]
+private theorem SpecialPeriods.Triangle.triangleVerticalRay_im (t : ℝ) :
+    (triangleVerticalRay t).im = t + 2 := by simp [triangleVerticalRay]
+
+private theorem SpecialPeriods.Triangle.triangleVerticalRay_mem {t : ℝ} (ht : 0 ≤ t) :
+    triangleVerticalRay t ∈ triangleInterior := by
+  rw [mem_triangleInterior_iff_epigraph, triangleVerticalRay_re, triangleVerticalRay_im]
+  refine ⟨stripLeft_lt_neg_one, by norm_num, ?_⟩
+  linarith [boundaryHeight_le_one (-1)]
+
+private theorem SpecialPeriods.Triangle.triangleVerticalRay_eventually_mem :
+    ∀ᶠ t : ℝ in Filter.atTop, triangleVerticalRay t ∈ triangleInterior :=
+  (Filter.eventually_ge_atTop (0 : ℝ)).mono fun _ ht => triangleVerticalRay_mem ht
+
+private theorem SpecialPeriods.Triangle.triangleVerticalRay_im_tendsto :
+    Filter.Tendsto (fun t : ℝ => (triangleVerticalRay t).im) Filter.atTop Filter.atTop := by
+  simpa only [triangleVerticalRay_im, id_eq] using
+    (Filter.tendsto_atTop_add_const_right Filter.atTop (2 : ℝ) Filter.tendsto_id)
+
+private theorem SpecialPeriods.Triangle.triangleVerticalRay_norm_tendsto :
+    Filter.Tendsto (fun t : ℝ => ‖triangleVerticalRay t‖) Filter.atTop Filter.atTop :=
+  Filter.tendsto_atTop_mono (fun t => Complex.im_le_norm (triangleVerticalRay t))
+    triangleVerticalRay_im_tendsto
+
+private theorem SpecialPeriods.Triangle.triangleVerticalRay_tendsto_cocompact :
+    Filter.Tendsto triangleVerticalRay Filter.atTop (Filter.cocompact ℂ) := by
+  simpa only [Metric.cobounded_eq_cocompact] using
+    tendsto_norm_atTop_iff_cobounded.mp triangleVerticalRay_norm_tendsto
+
+private theorem SpecialPeriods.Triangle.triangle_infty_mem_frontier :
+    ((OnePoint.infty) : OnePoint ℂ) ∈
+      frontier (RiemannBoundary.onePointDomain triangleInterior) :=
+  RiemannBoundary.infty_mem_frontier_onePointDomain_of_cocompact
+    triangleVerticalRay_tendsto_cocompact triangleVerticalRay_eventually_mem
+
+private theorem SpecialPeriods.Triangle.triangle_infty_mem_closure :
+    ((OnePoint.infty) : OnePoint ℂ) ∈ closure (RiemannBoundary.onePointDomain triangleInterior) :=
+  frontier_subset_closure triangle_infty_mem_frontier
+
+private theorem RiemannMapping.uniformEquicontinuousOn_of_thickening_subset_of_forall_norm_le
+    {ι E F : Type*} [NormedAddCommGroup E] [NormedSpace ℂ E] [NormedAddCommGroup F]
+    [NormedSpace ℂ F] {f : ι → E → F} {s U : Set E} {r : ℝ} (hr₀ : 0 < r)
+    (hU : Metric.thickening r s ⊆ U) (hfd : ∀ i, DifferentiableOn ℂ (f i) U)
+    (hf : ∃ C, ∀ i, ∀ z ∈ U, ‖f i z‖ ≤ C) : UniformEquicontinuousOn f s := by
+  have hsU : s ⊆ U := (Metric.self_subset_thickening hr₀ _).trans hU
+  rw [(Metric.uniformity_basis_dist.inf_principal _).uniformEquicontinuousOn_iff
+      Metric.uniformity_basis_dist_le]
+  intro ε hε
+  rcases hf with ⟨C, hC⟩
+  rcases exists_pos_mul_lt hε (2 * C / r) with ⟨δ, hδ₀, hδ⟩
+  use Min.min δ r, by positivity
+  simp only [Set.mem_ofPred, Set.mem_inter_iff, Set.prodMk_mem_set_prod_eq]
+  rintro x y ⟨hdist, hx, hy⟩ i
+  rw [lt_min_iff] at hdist
+  rw [Metric.thickening_eq_biUnion_ball, Set.iUnion₂_subset_iff] at hU
+  calc
+    Dist.dist (f i x) (f i y) ≤ (2 * C / r) * Dist.dist x y := by
+      apply Complex.dist_le_div_mul_dist_of_mapsTo_ball
+      · exact (hfd i).mono (hU _ hy)
+      · intro z hz
+        rw [Metric.mem_closedBall, two_mul]
+        exact
+          dist_le_norm_add_norm _ _ |>.trans <|
+            add_le_add (hC _ _ <| hU y hy hz) (hC _ _ <| hsU hy)
+      · exact hdist.2
+    _ ≤ _ := by
+      grw [hdist.1]
+      · exact hδ.le
+      · have := (norm_nonneg _).trans (hC i x (hsU hx))
+        positivity
+
+private theorem
+    RiemannMapping.equicontinuousAt_of_forall_norm_le {ι E F : Type*} [NormedAddCommGroup E]
+    [NormedSpace ℂ E] [NormedAddCommGroup F] [NormedSpace ℂ F] {f : ι → E → F} {U : Set E} {x : E}
+    (hU : U ∈ 𝓝 x) (hfd : ∀ i, DifferentiableOn ℂ (f i) U) (hf : ∃ C, ∀ i, ∀ z ∈ U, ‖f i z‖ ≤ C) :
+    EquicontinuousAt f x := by
+  rcases Metric.nhds_basis_ball.mem_iff.mp hU with ⟨r, hr₀, hr⟩
+  have : Metric.thickening (r / 2) (Metric.ball x (r / 2)) ⊆ U := by
+    grw [Metric.thickening_ball]
+    rwa [add_halves]
+  have :=
+    uniformEquicontinuousOn_of_thickening_subset_of_forall_norm_le (by positivity) this hfd
+        hf |>.equicontinuousOn
+      x (by simpa)
+  rwa [EquicontinuousWithinAt,
+    nhdsWithin_eq_nhds.mpr (Metric.ball_mem_nhds _ (by positivity))] at this
+
+private def RiemannMapping.compactSubsets (U : Set ℂ) : Set (Set ℂ) :=
+  {K | K ⊆ U ∧ IsCompact K}
+
+private abbrev RiemannMapping.FunctionSpace (U : Set ℂ) :=
+  ℂ →ᵤ[compactSubsets U] ℂ
+
+private def RiemannMapping.evaluation {U : Set ℂ} (f : FunctionSpace U) : ℂ → ℂ :=
+  UniformOnFun.toFun (compactSubsets U) f
+
+private theorem RiemannMapping.uniformity_isCountablyGenerated {U : Set ℂ} (hUo : IsOpen U) :
+    (𝓤 (FunctionSpace U)).IsCountablyGenerated := by
+  have := hUo.locallyCompactSpace
+  have : SigmaCompactSpace U := sigmaCompactSpace_of_locallyCompact_secondCountable
+  let φ : CompactExhaustion U := Inhabited.default
+  apply UniformOnFun.isCountablyGenerated_uniformity (t := fun n => (↑) '' φ n)
+  · intro n
+    exact ⟨Set.image_val_subset, (φ.isCompact n).image continuous_subtype_val⟩
+  · exact Set.monotone_image.comp φ.subset
+  · rintro K ⟨hKU, hKc⟩
+    lift K to Set U using hKU
+    rw [← Subtype.isCompact_iff] at hKc
+    exact (φ.exists_superset_of_isCompact hKc).imp fun n hn => by gcongr
+
+private theorem RiemannMapping.evaluation_tendstoLocallyUniformlyOn {U : Set ℂ} (hUo : IsOpen U)
+    {f : FunctionSpace U} {s : Set (FunctionSpace U)} :
+    TendstoLocallyUniformlyOn evaluation (evaluation f) (𝓝[s] f) U := by
+  have h : Filter.Tendsto id (𝓝[s] f) (𝓝 f) := Filter.tendsto_id'.mpr nhdsWithin_le_nhds
+  rw [tendstoLocallyUniformlyOn_iff_forall_isCompact hUo]
+  intro K hKU hK
+  exact (UniformOnFun.tendsto_iff_tendstoUniformlyOn.mp h) K ⟨hKU, hK⟩
+
+private theorem RiemannMapping.isCompact_closure_of_bounded_holomorphic {U : Set ℂ} (hUo : IsOpen U)
+    {s : Set (FunctionSpace U)} (hsd : ∀ f ∈ s, DifferentiableOn ℂ (evaluation f) U)
+    (hsb : ∃ C : ℝ, ∀ f ∈ s, ∀ z ∈ U, ‖evaluation f z‖ ≤ C) : IsCompact (closure s) := by
+  obtain ⟨C, hC⟩ := hsb
+  apply
+    ArzelaAscoli.isCompact_closure_of_isClosedEmbedding (𝔖 := compactSubsets U) (fun K hK => hK.2)
+      (F := evaluation) .id
+  · rintro K ⟨hKU, _⟩ z hz
+    exact
+      (equicontinuousAt_of_forall_norm_le (hUo.mem_nhds (hKU hz))
+            (fun f : s => hsd f.val f.property)
+            ⟨C, fun f z hz => hC f.val f.property z hz⟩).equicontinuousWithinAt
+        K
+  · intro K hK x hx
+    exact
+      ⟨Metric.closedBall 0 C, ProperSpace.isCompact_closedBall _ _, fun f hf => by
+        simpa only [mem_closedBall_zero_iff] using hC f hf x (hK.1 hx)⟩
+
+private def RiemannMapping.normalizedClass (U : Set ℂ) (x₀ : ℂ) : Set (FunctionSpace U) :=
+  {f |
+    Set.MapsTo (evaluation f) U (Metric.ball 0 1) ∧
+      Set.InjOn (evaluation f) U ∧
+        DifferentiableOn ℂ (evaluation f) U ∧
+          (∀ z ∈ U, deriv (evaluation f) z ≠ 0) ∧ evaluation f x₀ = 0}
+
+private theorem
+    RiemannMapping.normalizedClass_compact_closure {U : Set ℂ} (hUo : IsOpen U) (x₀ : ℂ) :
+    IsCompact (closure (normalizedClass U x₀)) := by
+  apply isCompact_closure_of_bounded_holomorphic hUo (fun f hf => hf.2.2.1)
+  exact ⟨1, fun f hf z hz => (mem_ball_zero_iff.mp (hf.1 hz)).le⟩
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Uniformization/SpecialPeriods7.lean b/LeanPool/HopfProblem/Uniformization/SpecialPeriods7.lean
new file mode 100644
index 000000000..592c3e071
--- /dev/null
+++ b/LeanPool/HopfProblem/Uniformization/SpecialPeriods7.lean
@@ -0,0 +1,5608 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.PeriodFamily.Core2
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods1
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods6
+import all LeanPool.HopfProblem.Foundations.Complex
+import all LeanPool.HopfProblem.PeriodFamily.Core2
+
+/-!
+# Hopf problem: uniformization · special periods 7
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem RiemannMapping.closure_normalizedClass {U : Set ℂ} (hUo : IsOpen U)
+    (hUc : IsPreconnected U) {x₀ : ℂ} (hx₀ : x₀ ∈ U) :
+    closure (normalizedClass U x₀) ⊆
+      {f |
+        Set.MapsTo (evaluation f) U (Metric.ball 0 1) ∧
+          ((∃ C, Set.EqOn (evaluation f) (Function.const ℂ C) U) ∨ Set.InjOn (evaluation f) U) ∧
+            DifferentiableOn ℂ (evaluation f) U ∧
+              evaluation f x₀ = 0 ∧
+                (Set.EqOn (deriv (evaluation f)) 0 U ∨ ∀ z ∈ U, deriv (evaluation f) z ≠ 0)} := by
+  let := uniformity_isCountablyGenerated hUo
+  intro f hf
+  let : (𝓝[normalizedClass U x₀] f).NeBot := mem_closure_iff_nhdsWithin_neBot.mp hf
+  have htendsto :
+    TendstoLocallyUniformlyOn evaluation (evaluation f) (𝓝[normalizedClass U x₀] f) U :=
+    evaluation_tendstoLocallyUniformlyOn hUo
+  have hFd : ∀ᶠ g in 𝓝[normalizedClass U x₀] f, DifferentiableOn ℂ (evaluation g) U :=
+    eventually_mem_nhdsWithin.mono fun g hg => hg.2.2.1
+  have hdf : DifferentiableOn ℂ (evaluation f) U := htendsto.differentiableOn hFd hUo
+  have hf_le : ∀ z ∈ U, ‖evaluation f z‖ ≤ 1 := by
+    intro z hz
+    refine le_of_tendsto (htendsto.tendsto_at hz).norm (eventually_mem_nhdsWithin.mono ?_)
+    intro g hg
+    exact (mem_ball_zero_iff.mp (hg.1 hz)).le
+  have hfx₀ : evaluation f x₀ = 0 := by
+    refine tendsto_nhds_unique (htendsto.tendsto_at hx₀) ?_
+    refine tendsto_const_nhds.congr' (eventually_mem_nhdsWithin.mono fun g hg => ?_)
+    exact hg.2.2.2.2.symm
+  refine ⟨?_, ?_, hdf, hfx₀, ?_⟩
+  · by_contra hf_ball
+    obtain ⟨z, hzU, hz⟩ : ∃ z ∈ U, 1 ≤ ‖evaluation f z‖ := by simpa [Set.MapsTo] using hf_ball
+    have hm : IsMaxOn (fun z => ‖evaluation f z‖) U z := by
+      intro y hy
+      exact (hf_le y hy).trans hz
+    have he : evaluation f x₀ = evaluation f z :=
+      Complex.eqOn_of_isPreconnected_of_isMaxOn_norm hUc hUo hdf hzU hm hx₀
+    norm_num [← he, hfx₀] at hz
+  · exact
+      Complex.eqOn_const_or_injOn_of_tendstoLocallyUniformlyOn hUo hUc
+        (eventually_mem_nhdsWithin.mono fun g hg => hg.2.1) hFd htendsto
+  · apply
+      Complex.eqOn_zero_or_forall_ne_zero_of_tendstoLocallyUniformlyOn hUo hUc
+        (eventually_mem_nhdsWithin.mono fun g hg => hg.2.2.2.1)
+        (hFd.mono fun g hg => hg.deriv hUo)
+    exact htendsto.deriv hFd hUo
+
+private theorem RiemannMapping.norm_deriv_continuousOn_closure {U : Set ℂ} (hUo : IsOpen U)
+    (hUc : IsPreconnected U) {x₀ : ℂ} (hx₀ : x₀ ∈ U) :
+    ContinuousOn (fun f : FunctionSpace U => ‖deriv (evaluation f) x₀‖)
+      (closure (normalizedClass U x₀)) := by
+  have hc := closure_normalizedClass hUo hUc hx₀
+  refine ContinuousOn.mono (ContinuousOn.norm fun f hf => ?_) hc
+  refine
+    TendstoLocallyUniformlyOn.tendsto_at
+      (TendstoLocallyUniformlyOn.deriv (evaluation_tendstoLocallyUniformlyOn hUo) ?_ hUo) hx₀
+  exact eventually_mem_nhdsWithin.mono fun g hg => hg.2.2.1
+
+private theorem RiemannMapping.exists_maximal_normalizedMap {U : Set ℂ} (hUo : IsOpen U)
+    (hUc : IsPreconnected U) {x₀ : ℂ} (hx₀ : x₀ ∈ U) (hne : (normalizedClass U x₀).Nonempty) :
+    ∃ f : FunctionSpace U,
+      f ∈ normalizedClass U x₀ ∧
+        ∀ g ∈ normalizedClass U x₀, ‖deriv (evaluation g) x₀‖ ≤ ‖deriv (evaluation f) x₀‖ := by
+  obtain ⟨f, hf, hmax⟩ :=
+    (normalizedClass_compact_closure hUo x₀).exists_isMaxOn hne.closure
+      (norm_deriv_continuousOn_closure hUo hUc hx₀)
+  have hpos : 0 < ‖deriv (evaluation f) x₀‖ := by
+    obtain ⟨g, hg⟩ := hne
+    exact (norm_pos_iff.mpr (hg.2.2.2.1 x₀ hx₀)).trans_le (hmax (subset_closure hg))
+  obtain ⟨hmap, hinj, hdiff, hzero, hderiv⟩ := closure_normalizedClass hUo hUc hx₀ hf
+  have hinj' : Set.InjOn (evaluation f) U := by
+    apply hinj.resolve_left
+    rintro ⟨C, hC⟩
+    rw [(hC.eventuallyEq_of_mem (hUo.mem_nhds hx₀)).deriv_eq] at hpos
+    change 0 < ‖deriv (fun _ : ℂ => C) x₀‖ at hpos
+    simp only [deriv_const, norm_zero, lt_self_iff_false] at hpos
+  have hderiv' : ∀ z ∈ U, deriv (evaluation f) z ≠ 0 := by
+    apply hderiv.resolve_left
+    intro hzero'
+    have hz : deriv (evaluation f) x₀ = 0 := hzero' hx₀
+    simp only [hz, norm_zero, lt_self_iff_false] at hpos
+  exact ⟨f, ⟨hmap, hinj', hdiff, hderiv', hzero⟩, fun g hg => hmax (subset_closure hg)⟩
+
+private def
+    RiemannMapping.discExtension {U : Set ℂ} (f : ℂ → ℂ) (hf : Set.MapsTo f U (Metric.ball 0 1)) :
+    ℂ → Complex.UnitDisc := by
+  classical
+    exact fun z =>
+    if hz : z ∈ U then Complex.UnitDisc.mk (f z) (mem_ball_zero_iff.mp (hf hz)) else 0
+
+@[simp]
+private theorem RiemannMapping.discExtension_coe {U : Set ℂ} (f : ℂ → ℂ)
+    (hf : Set.MapsTo f U (Metric.ball 0 1)) {z : ℂ} (hz : z ∈ U) :
+    (discExtension f hf z : ℂ) = f z := by
+  simp only [discExtension, dite_eq_left hz, Complex.UnitDisc.coe_mk]
+
+private theorem RiemannMapping.discExtension_eqOn {U : Set ℂ} (f : ℂ → ℂ)
+    (hf : Set.MapsTo f U (Metric.ball 0 1)) :
+    Set.EqOn (Complex.UnitDisc.coe ∘ discExtension f hf) f U := fun _ hz =>
+  discExtension_coe f hf hz
+
+private theorem RiemannMapping.normalizedClass_nonempty {U : Set ℂ} (hUo : IsOpen U)
+    (hUc : IsSimplyConnected U) (hU : U ≠ Set.univ) (x₀ : ℂ) :
+    (normalizedClass U x₀).Nonempty := by
+  obtain ⟨f, hf₀, hf_inj, hfd⟩ :=
+    Complex.exists_map_unitDisc_injOn_deriv_ne_zero₀ hUo hUc hU x₀
+  refine ⟨UniformOnFun.ofFun (compactSubsets U) (Complex.UnitDisc.coe ∘ f), ?_⟩
+  refine ⟨fun z _ => (f z).property, ?_, ?_, hfd, ?_⟩
+  · intro z hz w hw he
+    exact hf_inj hz hw (Complex.UnitDisc.coe_injective he)
+  · intro z hz
+    exact (differentiableAt_of_deriv_ne_zero (hfd z hz)).differentiableWithinAt
+  · change (f x₀ : ℂ) = 0
+    rw [hf₀]
+    rfl
+
+private theorem RiemannMapping.exists_bijOn_unitBall_deriv_ne_zero_map_eq_zero {U : Set ℂ}
+    (hUo : IsOpen U) (hUc : IsSimplyConnected U) (hU : U ≠ Set.univ) {x₀ : ℂ} (hx₀ : x₀ ∈ U) :
+    ∃ f : ℂ → ℂ,
+      DifferentiableOn ℂ f U ∧
+        Set.BijOn f U (Metric.ball 0 1) ∧ (∀ z ∈ U, deriv f z ≠ 0) ∧ f x₀ = 0 := by
+  obtain ⟨f, hf, hmax⟩ :=
+    exists_maximal_normalizedMap hUo hUc.isPathConnected.isConnected.isPreconnected hx₀
+      (normalizedClass_nonempty hUo hUc hU x₀)
+  obtain ⟨hfmap, hfinj, hfdiff, hfderiv, hfzero⟩ := hf
+  refine ⟨evaluation f, hfdiff, ⟨hfmap, hfinj, ?_⟩, hfderiv, hfzero⟩
+  by_contra hsurj
+  let fDisc := discExtension (evaluation f) hfmap
+  have hfeq : Set.EqOn (Complex.UnitDisc.coe ∘ fDisc) (evaluation f) U :=
+    discExtension_eqOn (evaluation f) hfmap
+  have hfdDisc : DifferentiableOn ℂ (Complex.UnitDisc.coe ∘ fDisc) U :=
+    (differentiableOn_congr hfeq).mpr hfdiff
+  have hfDisc0 : fDisc x₀ = 0 := by
+    apply Complex.UnitDisc.coe_injective
+    change (fDisc x₀ : ℂ) = 0
+    exact (hfeq hx₀).trans hfzero
+  have hfDiscInj : Set.InjOn fDisc U := by
+    intro z hz w hw he
+    apply hfinj hz hw
+    exact (hfeq hz).symm.trans ((congrArg Complex.UnitDisc.coe he).trans (hfeq hw))
+  have hfDiscDeriv : ∀ z ∈ U, deriv (Complex.UnitDisc.coe ∘ fDisc) z ≠ 0 := by
+    intro z hz
+    rw [(hfeq.eventuallyEq_of_mem (hUo.mem_nhds hz)).deriv_eq]
+    exact hfderiv z hz
+  have hfDiscSurj : ¬Set.SurjOn fDisc U Set.univ := by
+    intro hs
+    apply hsurj
+    intro w hw
+    obtain ⟨z, hz, he⟩ := hs (Set.mem_univ (Complex.UnitDisc.mk w (mem_ball_zero_iff.mp hw)))
+    refine ⟨z, hz, ?_⟩
+    exact (hfeq hz).symm.trans (congrArg Complex.UnitDisc.coe he)
+  obtain ⟨g, hg₀, hginj, hgdiff, hgderiv, hglt⟩ :=
+    Complex.exist_map_unitDisc_injOn_deriv_ne_zero_norm_deriv_gt hUo hUc hU hx₀ hfdDisc hfDisc0
+      hfDiscInj hfDiscSurj hfDiscDeriv
+  let gFun : FunctionSpace U := UniformOnFun.ofFun (compactSubsets U) (Complex.UnitDisc.coe ∘ g)
+  have hgmem : gFun ∈ normalizedClass U x₀ := by
+    refine ⟨fun z _ => (g z).property, ?_, hgdiff, hgderiv, ?_⟩
+    · intro z hz w hw he
+      exact hginj hz hw (Complex.UnitDisc.coe_injective he)
+    · change (g x₀ : ℂ) = 0
+      rw [hg₀]
+      rfl
+  have hle := hmax gFun hgmem
+  have heDeriv : deriv (Complex.UnitDisc.coe ∘ fDisc) x₀ = deriv (evaluation f) x₀ :=
+    (hfeq.eventuallyEq_of_mem (hUo.mem_nhds hx₀)).deriv_eq
+  rw [heDeriv] at hglt
+  exact hle.not_gt hglt
+
+private theorem RiemannMapping.isLocalDiffeomorphAt_of_deriv_ne_zero (U : TopologicalSpace.Opens ℂ)
+    {f : ℂ → ℂ} (hf : DifferentiableOn ℂ f (U : Set ℂ)) (hderiv : ∀ z ∈ U, deriv f z ≠ 0) {z : ℂ}
+    (hz : z ∈ U) :
+    IsLocalDiffeomorphAt (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) ω f z := by
+  have hfω : ContDiffOn ℂ ω f (U : Set ℂ) := hf.contDiffOn U.isOpen
+  have hF (w : ℂ) (hw : w ∈ U) : ContDiffAt ℂ ω f w := hfω.contDiffAt (U.isOpen.mem_nhds hw)
+  have hD (w : ℂ) (hw : w ∈ U) : HasDerivAt f (deriv f w) w :=
+    hf.hasDerivAt (U.isOpen.mem_nhds hw)
+  let e : OpenPartialHomeomorph ℂ ℂ :=
+    ((hF z hz).toOpenPartialHomeomorph f ((hD z hz).hasFDerivAt_equiv (hderiv z hz))
+          (by simp)).restr
+      (U : Set ℂ)
+  have heU : e.source ⊆ (U : Set ℂ) := by
+    intro w hw
+    dsimp only [e] at hw
+    rw [OpenPartialHomeomorph.restr_source' _ _ U.isOpen] at hw
+    exact hw.2
+  have hze : z ∈ e.source := by
+    dsimp only [e]
+    rw [OpenPartialHomeomorph.restr_source' _ _ U.isOpen]
+    exact
+      ⟨(hF z hz).mem_toOpenPartialHomeomorph_source ((hD z hz).hasFDerivAt_equiv (hderiv z hz))
+          (by simp),
+        hz⟩
+  refine
+    ⟨{  toPartialEquiv := e.toPartialEquiv
+        open_source := e.open_source
+        open_target := e.open_target
+        contMDiffOn_toFun := ?_
+        contMDiffOn_invFun := ?_ }, hze, fun _ _ => rfl⟩
+  · change ContMDiffOn (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) ω f e.source
+    exact (hfω.mono heU).contMDiffOn
+  · apply ContDiffOn.contMDiffOn
+    intro w hw
+    have hwU := heU (e.map_target hw)
+    exact
+      (e.contDiffAt_symm hw ((hD _ hwU).hasFDerivAt_equiv (hderiv _ hwU))
+          (hF _ hwU)).contDiffWithinAt
+
+private theorem
+    RiemannMapping.restrict_isLocalDiffeomorph (U V : TopologicalSpace.Opens ℂ) {f : ℂ → ℂ}
+    (hf : DifferentiableOn ℂ f (U : Set ℂ)) (hUV : Set.MapsTo f (U : Set ℂ) (V : Set ℂ))
+    (hderiv : ∀ z ∈ U, deriv f z ≠ 0) :
+    IsLocalDiffeomorph (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) ω
+      (fun z : U => (⟨f z, hUV z.property⟩ : V)) := by
+  intro z
+  exact
+    isLocalDiffeomorphAt_restrictOpens (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ)
+      (isLocalDiffeomorphAt_of_deriv_ne_zero U hf hderiv z.property) U V hUV z.property
+
+private def RiemannMapping.biholomorphOfBijOn (U V : TopologicalSpace.Opens ℂ) (f : ℂ → ℂ)
+    (hf : DifferentiableOn ℂ f (U : Set ℂ)) (hbij : Set.BijOn f (U : Set ℂ) (V : Set ℂ))
+    (hderiv : ∀ z ∈ U, deriv f z ≠ 0) :
+    Diffeomorph (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) U V ω := by
+  apply (restrict_isLocalDiffeomorph U V hf hbij.mapsTo hderiv).diffeomorphOfBijective
+  constructor
+  · intro z w hzw
+    apply Subtype.ext
+    exact hbij.injOn z.property w.property (congrArg Subtype.val hzw)
+  · intro w
+    obtain ⟨z, hz, hzw⟩ := hbij.surjOn w.property
+    exact ⟨⟨z, hz⟩, Subtype.ext hzw⟩
+
+private def RiemannMapping.unitDisc : TopologicalSpace.Opens ℂ :=
+  ⟨Metric.ball 0 1, Metric.isOpen_ball⟩
+
+private def
+    RiemannMapping.riemannMap (U : TopologicalSpace.Opens ℂ) (hUc : IsSimplyConnected (U : Set ℂ))
+    (hU : (U : Set ℂ) ≠ Set.univ) (x₀ : U) : ℂ → ℂ :=
+  (exists_bijOn_unitBall_deriv_ne_zero_map_eq_zero U.isOpen hUc hU x₀.property).choose
+
+private theorem RiemannMapping.riemannMap_spec (U : TopologicalSpace.Opens ℂ)
+    (hUc : IsSimplyConnected (U : Set ℂ)) (hU : (U : Set ℂ) ≠ Set.univ) (x₀ : U) :
+    DifferentiableOn ℂ (riemannMap U hUc hU x₀) (U : Set ℂ) ∧
+      Set.BijOn (riemannMap U hUc hU x₀) (U : Set ℂ) (unitDisc : Set ℂ) ∧
+        (∀ z ∈ U, deriv (riemannMap U hUc hU x₀) z ≠ 0) ∧ riemannMap U hUc hU x₀ x₀ = 0 :=
+  (exists_bijOn_unitBall_deriv_ne_zero_map_eq_zero U.isOpen hUc hU x₀.property).choose_spec
+
+private def RiemannMapping.biholomorphUnitDisc (U : TopologicalSpace.Opens ℂ)
+    (hUc : IsSimplyConnected (U : Set ℂ)) (hU : (U : Set ℂ) ≠ Set.univ) (x₀ : U) :
+    Diffeomorph (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) U unitDisc ω :=
+  biholomorphOfBijOn U unitDisc (riemannMap U hUc hU x₀) (riemannMap_spec U hUc hU x₀).1
+    (riemannMap_spec U hUc hU x₀).2.1 (riemannMap_spec U hUc hU x₀).2.2.1
+
+private def RiemannMapping.triangleDomain : TopologicalSpace.Opens ℂ :=
+  ⟨SpecialPeriods.Triangle.triangleInterior, SpecialPeriods.Triangle.triangleInterior_isOpen⟩
+
+private def RiemannMapping.trianglePoint : triangleDomain :=
+  ⟨SpecialPeriods.Triangle.triangleBasepoint, SpecialPeriods.Triangle.triangleBasepoint_mem⟩
+
+private def RiemannMapping.triangleBiholomorph :
+    Diffeomorph (modelWithCornersSelf ℂ ℂ) (modelWithCornersSelf ℂ ℂ) triangleDomain unitDisc ω :=
+  biholomorphUnitDisc triangleDomain SpecialPeriods.Triangle.triangleInterior_isSimplyConnected
+    SpecialPeriods.Triangle.triangleInterior_ne_univ trianglePoint
+
+private def SpecialPeriods.Triangle.triangleClosedSet : Set (OnePoint ℂ) :=
+  closure (RiemannBoundary.onePointDomain triangleInterior)
+
+private abbrev SpecialPeriods.Triangle.TriangleClosedDomain :=
+  triangleClosedSet
+
+private theorem SpecialPeriods.Triangle.triangleClosedSet_isClosed : IsClosed triangleClosedSet :=
+  isClosed_closure
+
+private theorem SpecialPeriods.Triangle.triangleClosedSet_isCompact : IsCompact triangleClosedSet :=
+  triangleClosedSet_isClosed.isCompact
+
+private instance SpecialPeriods.Triangle.triangleClosedDomain_compactSpace :
+    CompactSpace TriangleClosedDomain :=
+  isCompact_iff_compactSpace.mp triangleClosedSet_isCompact
+
+private instance
+    SpecialPeriods.Triangle.triangleClosedDomain_t2Space : T2Space TriangleClosedDomain :=
+  inferInstance
+
+private theorem SpecialPeriods.Triangle.coe_mem_triangleClosedSet_iff_closure (z : ℂ) :
+    (z : OnePoint ℂ) ∈ triangleClosedSet ↔ z ∈ closure triangleInterior := by
+  change z ∈ ((↑) : ℂ → OnePoint ℂ) ⁻¹' closure (((↑) : ℂ → OnePoint ℂ) '' triangleInterior) ↔ _
+  rw [← OnePoint.isOpenEmbedding_coe.isEmbedding.closure_eq_preimage_closure_image]
+
+private theorem SpecialPeriods.Triangle.coe_mem_triangleClosedSet_iff (z : ℂ) :
+    (z : OnePoint ℂ) ∈ triangleClosedSet ↔
+      stripLeft ≤ z.re ∧ z.re ≤ -1 / 2 ∧ 0 < z.im ∧ 1 ≤ ‖z + 1‖ := by
+  rw [coe_mem_triangleClosedSet_iff_closure, closure_triangleInterior]
+  rfl
+
+private theorem SpecialPeriods.Triangle.infty_mem_triangleClosedSet :
+    ((OnePoint.infty) : OnePoint ℂ) ∈ triangleClosedSet :=
+  triangle_infty_mem_closure
+
+private def SpecialPeriods.Triangle.triangleClosedInfinity : TriangleClosedDomain :=
+  ⟨(OnePoint.infty), infty_mem_triangleClosedSet⟩
+
+private def SpecialPeriods.Triangle.triangleClosedInterior :
+    TopologicalSpace.Opens TriangleClosedDomain :=
+  ⟨{x | x.val ∈ RiemannBoundary.onePointDomain triangleInterior},
+    (RiemannBoundary.isOpen_onePointDomain triangleInterior_isOpen).preimage
+      continuous_subtype_val⟩
+
+private theorem SpecialPeriods.Triangle.triangleClosedInterior_dense :
+    Dense (triangleClosedInterior : Set TriangleClosedDomain) := by
+  have hi :
+    ((↑) : TriangleClosedDomain → OnePoint ℂ) ''
+        (triangleClosedInterior : Set TriangleClosedDomain) =
+      RiemannBoundary.onePointDomain triangleInterior := by
+    ext x
+    constructor
+    · rintro ⟨y, hy, rfl⟩
+      exact hy
+    · intro hx
+      exact ⟨⟨x, subset_closure hx⟩, hx, rfl⟩
+  apply Subtype.dense_iff.mpr
+  rw [hi]
+  exact Set.Subset.refl _
+
+private def SpecialPeriods.Triangle.triangleClosedInclusion (z : RiemannMapping.triangleDomain) :
+    TriangleClosedDomain :=
+  ⟨(z : ℂ), subset_closure (RiemannBoundary.coe_mem_onePointDomain.mpr z.property)⟩
+
+private theorem SpecialPeriods.Triangle.triangleClosedInclusion_continuous :
+    Continuous triangleClosedInclusion :=
+  (OnePoint.continuous_coe.comp continuous_subtype_val).subtype_mk _
+
+private theorem SpecialPeriods.Triangle.triangleClosedInclusion_mem_interior
+    (z : RiemannMapping.triangleDomain) : triangleClosedInclusion z ∈ triangleClosedInterior :=
+  RiemannBoundary.coe_mem_onePointDomain.mpr z.property
+
+private def SpecialPeriods.Triangle.triangleClosedInteriorHomeomorph :
+    RiemannMapping.triangleDomain ≃ₜ triangleClosedInterior
+    where
+  toFun z := ⟨triangleClosedInclusion z, triangleClosedInclusion_mem_interior z⟩
+  invFun
+    x := (RiemannBoundary.onePointDomainHomeomorph triangleInterior).symm ⟨x.val.val, x.property⟩
+  left_inv
+    z := by exact (RiemannBoundary.onePointDomainHomeomorph triangleInterior).symm_apply_apply z
+  right_inv
+    x := by
+    apply Subtype.ext
+    apply Subtype.ext
+    exact
+      congrArg (fun y : RiemannBoundary.onePointDomain triangleInterior => (y : OnePoint ℂ))
+        ((RiemannBoundary.onePointDomainHomeomorph triangleInterior).apply_symm_apply
+          ⟨x.val.val, x.property⟩)
+  continuous_toFun := triangleClosedInclusion_continuous.subtype_mk _
+  continuous_invFun :=
+    (RiemannBoundary.onePointDomainHomeomorph triangleInterior).symm.continuous.comp
+      ((continuous_subtype_val.comp continuous_subtype_val).subtype_mk _)
+
+private def SpecialPeriods.Triangle.triangleClosedInteriorDiscHomeomorph :
+    triangleClosedInterior ≃ₜ Metric.ball (0 : ℂ) 1 :=
+  triangleClosedInteriorHomeomorph.symm.trans RiemannMapping.triangleBiholomorph.toHomeomorph
+
+@[simp]
+private theorem SpecialPeriods.Triangle.triangleClosedInteriorDiscHomeomorph_apply
+    (z : RiemannMapping.triangleDomain) :
+    triangleClosedInteriorDiscHomeomorph (triangleClosedInteriorHomeomorph z) =
+      RiemannMapping.triangleBiholomorph z := by
+  change
+    RiemannMapping.triangleBiholomorph
+        (triangleClosedInteriorHomeomorph.symm (triangleClosedInteriorHomeomorph z)) =
+      _
+  rw [triangleClosedInteriorHomeomorph.symm_apply_apply]
+
+private theorem SpecialPeriods.Triangle.coe_mem_triangleOnePoint_frontier_iff (z : ℂ) :
+    (z : OnePoint ℂ) ∈ frontier (RiemannBoundary.onePointDomain triangleInterior) ↔
+      z ∈ frontier triangleInterior := by
+  change
+    ((z : OnePoint ℂ) ∈ closure (RiemannBoundary.onePointDomain triangleInterior) ∧
+        (z : OnePoint ℂ) ∉ interior (RiemannBoundary.onePointDomain triangleInterior)) ↔
+      (z ∈ closure triangleInterior ∧ z ∉ interior triangleInterior)
+  rw [(RiemannBoundary.isOpen_onePointDomain triangleInterior_isOpen).interior_eq,
+    triangleInterior_isOpen.interior_eq]
+  exact
+    and_congr (coe_mem_triangleClosedSet_iff_closure z)
+      (not_congr RiemannBoundary.coe_mem_onePointDomain)
+
+private theorem
+    SpecialPeriods.Triangle.triangleClosedBoundary_iff_frontier (x : TriangleClosedDomain) :
+    x ∉ triangleClosedInterior ↔
+      x.val ∈ frontier (RiemannBoundary.onePointDomain triangleInterior) := by
+  change
+    x.val ∉ RiemannBoundary.onePointDomain triangleInterior ↔
+      x.val ∈ closure (RiemannBoundary.onePointDomain triangleInterior) ∧
+        x.val ∉ interior (RiemannBoundary.onePointDomain triangleInterior)
+  rw [(RiemannBoundary.isOpen_onePointDomain triangleInterior_isOpen).interior_eq]
+  exact ⟨fun hx => ⟨x.property, hx⟩, fun hx => hx.2⟩
+
+private def SpecialPeriods.Triangle.circleStraighten (z : ℂ) : ℂ :=
+  Complex.I * z / (z + 2)
+
+private def SpecialPeriods.Triangle.circleUnstraighten (w : ℂ) : ℂ :=
+  2 * w / (Complex.I - w)
+
+private theorem SpecialPeriods.Triangle.circleStraighten_sub_I {z : ℂ} (hz : z + 2 ≠ 0) :
+    Complex.I - circleStraighten z = 2 * Complex.I / (z + 2) := by
+  unfold circleStraighten
+  field_simp
+  ring
+
+private theorem SpecialPeriods.Triangle.circleStraighten_ne_I {z : ℂ} (hz : z + 2 ≠ 0) :
+    circleStraighten z ≠ Complex.I := by
+  have h : Complex.I - circleStraighten z ≠ 0 := by
+    rw [circleStraighten_sub_I hz]
+    exact div_ne_zero (mul_ne_zero (by norm_num) Complex.I_ne_zero) hz
+  exact fun he => h (by rw [he, sub_self])
+
+private theorem
+    SpecialPeriods.Triangle.circleUnstraighten_add_two {w : ℂ} (hw : Complex.I - w ≠ 0) :
+    circleUnstraighten w + 2 = 2 * Complex.I / (Complex.I - w) := by
+  unfold circleUnstraighten
+  field_simp
+  ring
+
+private theorem SpecialPeriods.Triangle.circleUnstraighten_add_two_ne_zero {w : ℂ}
+    (hw : Complex.I - w ≠ 0) : circleUnstraighten w + 2 ≠ 0 := by
+  rw [circleUnstraighten_add_two hw]
+  exact div_ne_zero (mul_ne_zero (by norm_num) Complex.I_ne_zero) hw
+
+private theorem SpecialPeriods.Triangle.circleUnstraighten_straighten {z : ℂ} (hz : z + 2 ≠ 0) :
+    circleUnstraighten (circleStraighten z) = z := by
+  rw [circleUnstraighten, circleStraighten_sub_I hz]
+  unfold circleStraighten
+  field_simp
+
+private theorem
+    SpecialPeriods.Triangle.circleStraighten_unstraighten {w : ℂ} (hw : Complex.I - w ≠ 0) :
+    circleStraighten (circleUnstraighten w) = w := by
+  rw [circleStraighten, circleUnstraighten_add_two hw]
+  unfold circleUnstraighten
+  field_simp
+
+private def SpecialPeriods.Triangle.circleBoundaryChart : OpenPartialHomeomorph ℂ ℂ
+    where
+  toFun := circleStraighten
+  invFun := circleUnstraighten
+  source := {z | z + 2 ≠ 0}
+  target := {w | Complex.I - w ≠ 0}
+  map_source' z hz := sub_ne_zero.mpr (circleStraighten_ne_I hz).symm
+  map_target' w hw := circleUnstraighten_add_two_ne_zero hw
+  left_inv' z hz := circleUnstraighten_straighten hz
+  right_inv' w hw := circleStraighten_unstraighten hw
+  open_source := isOpen_ne_fun (continuous_id.add continuous_const) continuous_const
+  open_target := isOpen_ne_fun (continuous_const.sub continuous_id) continuous_const
+  continuousOn_toFun := by
+    apply ContinuousOn.div (by fun_prop) (by fun_prop)
+    exact fun z hz => hz
+  continuousOn_invFun := by
+    apply ContinuousOn.div (by fun_prop) (by fun_prop)
+    exact fun z hz => hz
+
+private theorem SpecialPeriods.Triangle.circleStraighten_analyticOnNhd :
+    AnalyticOnNhd ℂ circleStraighten {z | z + 2 ≠ 0} := by
+  intro z hz
+  exact (analyticAt_const.mul analyticAt_id).div (analyticAt_id.add analyticAt_const) hz
+
+private theorem SpecialPeriods.Triangle.circleUnstraighten_analyticOnNhd :
+    AnalyticOnNhd ℂ circleUnstraighten {w | Complex.I - w ≠ 0} := by
+  intro z hz
+  exact (analyticAt_const.mul analyticAt_id).div (analyticAt_const.sub analyticAt_id) hz
+
+private theorem SpecialPeriods.Triangle.circleStraighten_im (z : ℂ) :
+    (circleStraighten z).im = (Complex.normSq (z + 1) - 1) / Complex.normSq (z + 2) := by
+  simp only [circleStraighten, Complex.div_im, Complex.mul_im, Complex.I_re, Complex.I_im,
+    MulZeroClass.zero_mul, one_mul, zero_add, Complex.mul_re, zero_sub, Complex.add_re,
+    Complex.re_ofNat, Complex.add_im, Complex.im_ofNat, add_zero]
+  rw [← sub_div]
+  congr 1
+  simp only [Complex.normSq_apply, Complex.add_re, Complex.one_re, Complex.add_im, Complex.one_im,
+    add_zero]
+  ring
+
+private theorem SpecialPeriods.Triangle.circleStraighten_im_pos_iff {z : ℂ} (hz : z + 2 ≠ 0) :
+    0 < (circleStraighten z).im ↔ 1 < ‖z + 1‖ := by
+  rw [circleStraighten_im, div_pos_iff_of_pos_right (Complex.normSq_pos.mpr hz), sub_pos]
+  rw [Complex.normSq_eq_norm_sq]
+  constructor
+  · intro h
+    nlinarith [norm_nonneg (z + 1)]
+  · intro h
+    nlinarith
+
+private theorem SpecialPeriods.Triangle.circleStraighten_im_eq_zero_iff {z : ℂ} (hz : z + 2 ≠ 0) :
+    (circleStraighten z).im = 0 ↔ ‖z + 1‖ = 1 := by
+  rw [circleStraighten_im, div_eq_zero_iff, or_iff_left (Complex.normSq_pos.mpr hz).ne',
+    sub_eq_zero, Complex.normSq_eq_norm_sq]
+  constructor
+  · intro h
+    nlinarith [norm_nonneg (z + 1)]
+  · intro h
+    rw [h]
+    norm_num
+
+private theorem
+    SpecialPeriods.Triangle.exists_circle_side_neighborhood {a : ℂ} (haL : stripLeft < a.re)
+    (haR : a.re < -1 / 2) (hai : 0 < a.im) :
+    ∃ r > 0,
+      ∀ z ∈ Metric.ball a r,
+        z ∈ circleBoundaryChart.source ∧
+          (z ∈ triangleInterior ↔ 0 < (circleBoundaryChart z).im) := by
+  let V : Set ℂ := {z | stripLeft < z.re ∧ z.re < -1 / 2 ∧ 0 < z.im}
+  have hV : IsOpen V :=
+    (isOpen_lt continuous_const Complex.continuous_re).inter
+      ((isOpen_lt Complex.continuous_re continuous_const).inter
+        (isOpen_lt continuous_const Complex.continuous_im))
+  obtain ⟨r, hr, hball⟩ := Metric.isOpen_iff.mp hV a ⟨haL, haR, hai⟩
+  refine ⟨r, hr, ?_⟩
+  intro z hz
+  have h := hball hz
+  have hzden : z + 2 ≠ 0 := by
+    intro he
+    have hi := congrArg Complex.im he
+    simp only [Complex.add_im, Complex.im_ofNat, add_zero, Complex.zero_im] at hi
+    exact h.2.2.ne' hi
+  refine ⟨hzden, ?_⟩
+  change (stripLeft < z.re ∧ z.re < -1 / 2 ∧ 0 < z.im ∧ 1 < ‖z + 1‖) ↔ 0 < (circleStraighten z).im
+  rw [circleStraighten_im_pos_iff hzden]
+  exact ⟨fun hz' => hz'.2.2.2, fun hnorm => ⟨h.1, h.2.1, h.2.2, hnorm⟩⟩
+
+private def SpecialPeriods.Triangle.leftBoundaryChart : ℂ ≃ₜ ℂ
+    where
+  toFun z := Complex.I * (z - stripLeft)
+  invFun w := -Complex.I * w + stripLeft
+  left_inv z := by ring_nf; simp
+  right_inv w := by ring_nf; simp
+  continuous_toFun := by fun_prop
+  continuous_invFun := by fun_prop
+
+private def SpecialPeriods.Triangle.rightBoundaryChart : ℂ ≃ₜ ℂ
+    where
+  toFun z := -Complex.I * (z + 1 / 2)
+  invFun w := Complex.I * w - 1 / 2
+  left_inv z := by ring_nf; simp
+  right_inv w := by ring_nf; simp
+  continuous_toFun := by fun_prop
+  continuous_invFun := by fun_prop
+
+@[simp]
+private theorem SpecialPeriods.Triangle.leftBoundaryChart_im (z : ℂ) :
+    (leftBoundaryChart z).im = z.re - stripLeft := by
+  change (Complex.I * (z - (stripLeft : ℂ))).im = _
+  simp
+
+@[simp]
+private theorem SpecialPeriods.Triangle.rightBoundaryChart_im (z : ℂ) :
+    (rightBoundaryChart z).im = -(z.re + 1 / 2) := by
+  change (-Complex.I * (z + 1 / 2)).im = _
+  simp
+
+private theorem SpecialPeriods.Triangle.leftBoundaryChart_symm_analyticAt (z : ℂ) :
+    AnalyticAt ℂ leftBoundaryChart.symm z :=
+  (analyticAt_const.mul analyticAt_id).add analyticAt_const
+
+private theorem SpecialPeriods.Triangle.rightBoundaryChart_symm_analyticAt (z : ℂ) :
+    AnalyticAt ℂ rightBoundaryChart.symm z :=
+  (analyticAt_const.mul analyticAt_id).sub analyticAt_const
+
+private theorem SpecialPeriods.Triangle.stripLeft_lt_right : stripLeft < -1 / 2 := by
+  unfold stripLeft
+  linarith [width_pos]
+
+private theorem
+    SpecialPeriods.Triangle.exists_left_side_neighborhood {a : ℂ} (ha : a.re = stripLeft)
+    (hai : 0 < a.im) (haC : 1 < ‖a + 1‖) :
+    ∃ r > 0, ∀ z ∈ Metric.ball a r, z ∈ triangleInterior ↔ 0 < (leftBoundaryChart z).im := by
+  let V : Set ℂ := {z | z.re < -1 / 2 ∧ 0 < z.im ∧ 1 < ‖z + 1‖}
+  have hV : IsOpen V :=
+    (isOpen_lt Complex.continuous_re continuous_const).inter
+      ((isOpen_lt continuous_const Complex.continuous_im).inter
+        (isOpen_lt continuous_const ((continuous_id.add continuous_const).norm)))
+  have haV : a ∈ V := ⟨ha ▸ stripLeft_lt_right, hai, haC⟩
+  obtain ⟨r, hr, hball⟩ := Metric.isOpen_iff.mp hV a haV
+  refine ⟨r, hr, ?_⟩
+  intro z hz
+  have h := hball hz
+  rw [leftBoundaryChart_im, sub_pos]
+  exact ⟨fun hz' => hz'.1, fun hz' => ⟨hz', h.1, h.2.1, h.2.2⟩⟩
+
+private theorem SpecialPeriods.Triangle.exists_right_side_neighborhood {a : ℂ} (ha : a.re = -1 / 2)
+    (hai : 0 < a.im) (haC : 1 < ‖a + 1‖) :
+    ∃ r > 0, ∀ z ∈ Metric.ball a r, z ∈ triangleInterior ↔ 0 < (rightBoundaryChart z).im := by
+  let V : Set ℂ := {z | stripLeft < z.re ∧ 0 < z.im ∧ 1 < ‖z + 1‖}
+  have hV : IsOpen V :=
+    (isOpen_lt continuous_const Complex.continuous_re).inter
+      ((isOpen_lt continuous_const Complex.continuous_im).inter
+        (isOpen_lt continuous_const ((continuous_id.add continuous_const).norm)))
+  have haV : a ∈ V := ⟨ha ▸ stripLeft_lt_right, hai, haC⟩
+  obtain ⟨r, hr, hball⟩ := Metric.isOpen_iff.mp hV a haV
+  refine ⟨r, hr, ?_⟩
+  intro z hz
+  have h := hball hz
+  rw [rightBoundaryChart_im]
+  have he : 0 < -(z.re + 1 / 2) ↔ z.re < -1 / 2 := by constructor <;> intro hi <;> linarith
+  rw [he]
+  exact ⟨fun hz' => hz'.2.1, fun hz' => ⟨h.1, hz', h.2.1, h.2.2⟩⟩
+
+private def SpecialPeriods.Triangle.triangleOpenLeftSide : Set ℂ :=
+  {z | z.re = stripLeft ∧ 0 < z.im ∧ 1 < ‖z + 1‖}
+
+private def SpecialPeriods.Triangle.triangleOpenRightSide : Set ℂ :=
+  {z | z.re = -1 / 2 ∧ 0 < z.im ∧ 1 < ‖z + 1‖}
+
+private def SpecialPeriods.Triangle.triangleOpenCircleSide : Set ℂ :=
+  {z | stripLeft < z.re ∧ z.re < -1 / 2 ∧ 0 < z.im ∧ ‖z + 1‖ = 1}
+
+private theorem SpecialPeriods.Triangle.triangleOpenLeftSide_disjoint_interior :
+    Disjoint triangleOpenLeftSide triangleInterior := by
+  apply Set.disjoint_left.mpr
+  intro z hL hI
+  exact (ne_of_gt hI.1) hL.1
+
+private theorem SpecialPeriods.Triangle.triangleOpenRightSide_disjoint_interior :
+    Disjoint triangleOpenRightSide triangleInterior := by
+  apply Set.disjoint_left.mpr
+  intro z hR hI
+  exact (ne_of_lt hI.2.1) hR.1
+
+private theorem SpecialPeriods.Triangle.triangleOpenCircleSide_disjoint_interior :
+    Disjoint triangleOpenCircleSide triangleInterior := by
+  apply Set.disjoint_left.mpr
+  intro z hC hI
+  exact (ne_of_gt hI.2.2.2) hC.2.2.2
+
+private theorem SpecialPeriods.Triangle.centerOne_coe_re : (centerOne : ℂ).re = -1 / 2 := by
+  simp only [centerOne_val, Complex.sub_re, SpecialPeriods.rho_re, Complex.one_re]
+  norm_num
+
+private theorem SpecialPeriods.Triangle.centerTwo_coe_re : (centerTwo : ℂ).re = stripLeft :=
+  centerTwo_re
+
+private theorem SpecialPeriods.Triangle.centerOne_norm_add_one : ‖(centerOne : ℂ) + 1‖ = 1 := by
+  simpa only [centerOne_val, sub_add_cancel] using SpecialPeriods.norm_rho
+
+private theorem SpecialPeriods.Triangle.centerTwo_norm_add_one : ‖(centerTwo : ℂ) + 1‖ = 1 := by
+  have hsq : Complex.normSq ((centerTwo : ℂ) + 1) = 1 := by
+    simp only [Complex.normSq_apply, Complex.add_re, Complex.one_re, Complex.add_im,
+      Complex.one_im, add_zero, UpperHalfPlane.coe_re, UpperHalfPlane.coe_im, centerTwo_re,
+      centerTwo_im]
+    nlinarith [width_sq]
+  rw [Complex.normSq_eq_norm_sq] at hsq
+  nlinarith [norm_nonneg ((centerTwo : ℂ) + 1)]
+
+public
+theorem SpecialPeriods.Triangle.complex_eq_of_re_eq_norm_add_one_eq {z w : ℂ} (hr : z.re = w.re)
+    (hz : 0 < z.im) (hw : 0 < w.im) (hn : ‖z + 1‖ = ‖w + 1‖) : z = w := by
+  apply Complex.ext hr
+  apply (sq_eq_sq₀ hz.le hw.le).mp
+  have hsq : Complex.normSq (z + 1) = Complex.normSq (w + 1) := by
+    rw [Complex.normSq_eq_norm_sq, Complex.normSq_eq_norm_sq, hn]
+  simp only [Complex.normSq_apply, Complex.add_re, Complex.one_re, Complex.add_im, Complex.one_im,
+    add_zero, hr] at hsq
+  nlinarith
+
+private theorem SpecialPeriods.Triangle.right_circle_endpoint_iff (z : ℂ) :
+    (z.re = -1 / 2 ∧ 0 < z.im ∧ ‖z + 1‖ = 1) ↔ z = (centerOne : ℂ) := by
+  constructor
+  · rintro ⟨hr, hi, hn⟩
+    exact
+      complex_eq_of_re_eq_norm_add_one_eq (hr.trans centerOne_coe_re.symm) hi centerOne.im_pos
+        (hn.trans centerOne_norm_add_one.symm)
+  · rintro rfl
+    exact ⟨centerOne_coe_re, centerOne.im_pos, centerOne_norm_add_one⟩
+
+private theorem SpecialPeriods.Triangle.left_circle_endpoint_iff (z : ℂ) :
+    (z.re = stripLeft ∧ 0 < z.im ∧ ‖z + 1‖ = 1) ↔ z = (centerTwo : ℂ) := by
+  constructor
+  · rintro ⟨hr, hi, hn⟩
+    exact
+      complex_eq_of_re_eq_norm_add_one_eq (hr.trans centerTwo_coe_re.symm) hi centerTwo.im_pos
+        (hn.trans centerTwo_norm_add_one.symm)
+  · rintro rfl
+    exact ⟨centerTwo_coe_re, centerTwo.im_pos, centerTwo_norm_add_one⟩
+
+private theorem SpecialPeriods.Triangle.mem_frontier_triangleInterior_iff_closedRegion {z : ℂ} :
+    z ∈ frontier triangleInterior ↔ z ∈ triangleClosedRegion ∧ z ∉ triangleInterior := by
+  rw [frontier, triangleInterior_isOpen.interior_eq, closure_triangleInterior]
+  rfl
+
+private theorem SpecialPeriods.Triangle.triangleOpenLeftSide_subset_frontier :
+    triangleOpenLeftSide ⊆ frontier triangleInterior := by
+  intro z hz
+  rw [mem_frontier_triangleInterior_iff_closedRegion]
+  refine ⟨⟨hz.1.symm.le, ?_, hz.2.1, hz.2.2.le⟩, ?_⟩
+  · simpa only [hz.1] using stripLeft_lt_right.le
+  · exact fun h => Set.disjoint_left.mp triangleOpenLeftSide_disjoint_interior hz h
+
+private theorem SpecialPeriods.Triangle.triangleOpenRightSide_subset_frontier :
+    triangleOpenRightSide ⊆ frontier triangleInterior := by
+  intro z hz
+  rw [mem_frontier_triangleInterior_iff_closedRegion]
+  refine ⟨⟨?_, hz.1.le, hz.2.1, hz.2.2.le⟩, ?_⟩
+  · simpa only [hz.1] using stripLeft_lt_right.le
+  · exact fun h => Set.disjoint_left.mp triangleOpenRightSide_disjoint_interior hz h
+
+private theorem SpecialPeriods.Triangle.triangleOpenCircleSide_subset_frontier :
+    triangleOpenCircleSide ⊆ frontier triangleInterior := by
+  intro z hz
+  rw [mem_frontier_triangleInterior_iff_closedRegion]
+  exact
+    ⟨⟨hz.1.le, hz.2.1.le, hz.2.2.1, hz.2.2.2.symm.le⟩, fun h =>
+      Set.disjoint_left.mp triangleOpenCircleSide_disjoint_interior hz h⟩
+
+private theorem SpecialPeriods.Triangle.centerOne_mem_triangleClosedRegion :
+    (centerOne : ℂ) ∈ triangleClosedRegion := by
+  refine ⟨?_, ?_, centerOne.im_pos, ?_⟩
+  · rw [centerOne_coe_re]
+    exact stripLeft_lt_right.le
+  · rw [centerOne_coe_re]
+  · rw [centerOne_norm_add_one]
+
+private theorem SpecialPeriods.Triangle.centerTwo_mem_triangleClosedRegion :
+    (centerTwo : ℂ) ∈ triangleClosedRegion := by
+  refine ⟨?_, ?_, centerTwo.im_pos, ?_⟩
+  · rw [centerTwo_coe_re]
+  · rw [centerTwo_coe_re]
+    exact stripLeft_lt_right.le
+  · rw [centerTwo_norm_add_one]
+
+private theorem SpecialPeriods.Triangle.centerOne_not_mem_triangleInterior :
+    (centerOne : ℂ) ∉ triangleInterior := by
+  intro hz
+  have h := hz.2.1
+  rw [centerOne_coe_re] at h
+  exact lt_irrefl _ h
+
+private theorem SpecialPeriods.Triangle.centerTwo_not_mem_triangleInterior :
+    (centerTwo : ℂ) ∉ triangleInterior := by
+  intro hz
+  have h := hz.1
+  rw [centerTwo_coe_re] at h
+  exact lt_irrefl _ h
+
+private theorem SpecialPeriods.Triangle.centerOne_mem_frontier_triangleInterior :
+    (centerOne : ℂ) ∈ frontier triangleInterior :=
+  mem_frontier_triangleInterior_iff_closedRegion.mpr
+    ⟨centerOne_mem_triangleClosedRegion, centerOne_not_mem_triangleInterior⟩
+
+private theorem SpecialPeriods.Triangle.centerTwo_mem_frontier_triangleInterior :
+    (centerTwo : ℂ) ∈ frontier triangleInterior :=
+  mem_frontier_triangleInterior_iff_closedRegion.mpr
+    ⟨centerTwo_mem_triangleClosedRegion, centerTwo_not_mem_triangleInterior⟩
+
+private theorem SpecialPeriods.Triangle.centerOne_mem_closure_triangleInterior :
+    (centerOne : ℂ) ∈ closure triangleInterior := by
+  rw [closure_triangleInterior]
+  exact centerOne_mem_triangleClosedRegion
+
+private theorem SpecialPeriods.Triangle.centerTwo_mem_closure_triangleInterior :
+    (centerTwo : ℂ) ∈ closure triangleInterior := by
+  rw [closure_triangleInterior]
+  exact centerTwo_mem_triangleClosedRegion
+
+private theorem
+    SpecialPeriods.Triangle.centerOne_coe_ne_centerTwo : (centerOne : ℂ) ≠ (centerTwo : ℂ) := by
+  intro h
+  have hr := congrArg Complex.re h
+  rw [centerOne_coe_re, centerTwo_coe_re] at hr
+  exact (ne_of_gt stripLeft_lt_right) hr
+
+private theorem SpecialPeriods.Triangle.mem_frontier_triangleInterior_iff {z : ℂ} :
+    z ∈ frontier triangleInterior ↔
+      z ∈ triangleOpenLeftSide ∨
+        z ∈ triangleOpenRightSide ∨
+          z ∈ triangleOpenCircleSide ∨ z = (centerOne : ℂ) ∨ z = (centerTwo : ℂ) := by
+  constructor
+  · intro hz
+    obtain ⟨hR, hI⟩ := mem_frontier_triangleInterior_iff_closedRegion.mp hz
+    rcases lt_or_eq_of_le hR.1 with hL | hL
+    · rcases lt_or_eq_of_le hR.2.1 with hU | hU
+      · rcases lt_or_eq_of_le hR.2.2.2 with hN | hN
+        · exact (hI ⟨hL, hU, hR.2.2.1, hN⟩).elim
+        · exact Or.inr (Or.inr (Or.inl ⟨hL, hU, hR.2.2.1, hN.symm⟩))
+      · rcases lt_or_eq_of_le hR.2.2.2 with hN | hN
+        · exact Or.inr (Or.inl ⟨hU, hR.2.2.1, hN⟩)
+        · exact
+            Or.inr
+              (Or.inr
+                (Or.inr (Or.inl ((right_circle_endpoint_iff z).mp ⟨hU, hR.2.2.1, hN.symm⟩))))
+    · rcases lt_or_eq_of_le hR.2.2.2 with hN | hN
+      · exact Or.inl ⟨hL.symm, hR.2.2.1, hN⟩
+      · exact
+          Or.inr
+            (Or.inr
+              (Or.inr (Or.inr ((left_circle_endpoint_iff z).mp ⟨hL.symm, hR.2.2.1, hN.symm⟩))))
+  · rintro (h | h | h | rfl | rfl)
+    · exact triangleOpenLeftSide_subset_frontier h
+    · exact triangleOpenRightSide_subset_frontier h
+    · exact triangleOpenCircleSide_subset_frontier h
+    · exact centerOne_mem_frontier_triangleInterior
+    · exact centerTwo_mem_frontier_triangleInterior
+
+private def SpecialPeriods.Triangle.triangleClosedCenterOne : TriangleClosedDomain :=
+  ⟨((centerOne : ℂ) : OnePoint ℂ),
+    (coe_mem_triangleClosedSet_iff_closure _).mpr centerOne_mem_closure_triangleInterior⟩
+
+private def SpecialPeriods.Triangle.triangleClosedCenterTwo : TriangleClosedDomain :=
+  ⟨((centerTwo : ℂ) : OnePoint ℂ),
+    (coe_mem_triangleClosedSet_iff_closure _).mpr centerTwo_mem_closure_triangleInterior⟩
+
+@[simp]
+private theorem SpecialPeriods.Triangle.triangleClosedCenterOne_val :
+    (triangleClosedCenterOne : OnePoint ℂ) = ((centerOne : ℂ) : OnePoint ℂ) :=
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.Triangle.triangleClosedCenterTwo_val :
+    (triangleClosedCenterTwo : OnePoint ℂ) = ((centerTwo : ℂ) : OnePoint ℂ) :=
+  rfl
+
+private theorem SpecialPeriods.Triangle.triangleClosedCenterOne_ne_centerTwo :
+    triangleClosedCenterOne ≠ triangleClosedCenterTwo := by
+  intro h
+  exact centerOne_coe_ne_centerTwo (OnePoint.coe_injective (congrArg Subtype.val h))
+
+@[simp]
+private theorem SpecialPeriods.Triangle.triangleClosedCenterOne_ne_infty :
+    triangleClosedCenterOne ≠ triangleClosedInfinity := by
+  intro h
+  exact OnePoint.coe_ne_infty (centerOne : ℂ) (congrArg Subtype.val h)
+
+@[simp]
+private theorem SpecialPeriods.Triangle.triangleClosedCenterTwo_ne_infty :
+    triangleClosedCenterTwo ≠ triangleClosedInfinity := by
+  intro h
+  exact OnePoint.coe_ne_infty (centerTwo : ℂ) (congrArg Subtype.val h)
+
+private theorem SpecialPeriods.Triangle.mem_triangleOnePoint_frontier_iff {x : OnePoint ℂ} :
+    x ∈ frontier (RiemannBoundary.onePointDomain triangleInterior) ↔
+      x = (OnePoint.infty) ∨
+        x ∈ RiemannBoundary.onePointDomain triangleOpenLeftSide ∨
+          x ∈ RiemannBoundary.onePointDomain triangleOpenRightSide ∨
+            x ∈ RiemannBoundary.onePointDomain triangleOpenCircleSide ∨
+              x = ((centerOne : ℂ) : OnePoint ℂ) ∨ x = ((centerTwo : ℂ) : OnePoint ℂ) := by
+  induction x using OnePoint.rec with
+  | infty => exact iff_of_true triangle_infty_mem_frontier (Or.inl rfl)
+  | coe z =>
+    simpa only [coe_mem_triangleOnePoint_frontier_iff, OnePoint.coe_ne_infty, false_or,
+      RiemannBoundary.coe_mem_onePointDomain, OnePoint.coe_eq_coe] using
+      (mem_frontier_triangleInterior_iff (z := z))
+
+private theorem
+    SpecialPeriods.Triangle.triangleClosedBoundary_iff_cases (x : TriangleClosedDomain) :
+    x ∉ triangleClosedInterior ↔
+      x = triangleClosedInfinity ∨
+        x.val ∈ RiemannBoundary.onePointDomain triangleOpenLeftSide ∨
+          x.val ∈ RiemannBoundary.onePointDomain triangleOpenRightSide ∨
+            x.val ∈ RiemannBoundary.onePointDomain triangleOpenCircleSide ∨
+              x = triangleClosedCenterOne ∨ x = triangleClosedCenterTwo := by
+  rw [triangleClosedBoundary_iff_frontier]
+  simpa only [Subtype.ext_iff, triangleClosedInfinity, triangleClosedCenterOne_val,
+    triangleClosedCenterTwo_val] using (mem_triangleOnePoint_frontier_iff (x := x.val))
+
+private theorem SpecialPeriods.Triangle.triangleClosedBoundary_cases (x : TriangleClosedDomain)
+    (hx : x ∉ triangleClosedInterior) :
+    x = triangleClosedInfinity ∨
+      (∃ z : ℂ, z ∈ triangleOpenLeftSide ∧ x.val = (z : OnePoint ℂ)) ∨
+        (∃ z : ℂ, z ∈ triangleOpenRightSide ∧ x.val = (z : OnePoint ℂ)) ∨
+          (∃ z : ℂ, z ∈ triangleOpenCircleSide ∧ x.val = (z : OnePoint ℂ)) ∨
+            x = triangleClosedCenterOne ∨ x = triangleClosedCenterTwo := by
+  rcases (triangleClosedBoundary_iff_cases x).mp hx with hi | hL | hR | hC | h₁ | h₂
+  · exact Or.inl hi
+  · obtain ⟨z, hz, he⟩ := hL
+    exact Or.inr (Or.inl ⟨z, hz, he.symm⟩)
+  · obtain ⟨z, hz, he⟩ := hR
+    exact Or.inr (Or.inr (Or.inl ⟨z, hz, he.symm⟩))
+  · obtain ⟨z, hz, he⟩ := hC
+    exact Or.inr (Or.inr (Or.inr (Or.inl ⟨z, hz, he.symm⟩)))
+  · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inl h₁))))
+  · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inr h₂))))
+
+private def RiemannBoundary.openRectangle (a b c d : ℝ) : Set ℂ :=
+  {z | z.re ∈ Set.Ioo a b ∧ z.im ∈ Set.Ioo c d}
+
+private theorem
+    RiemannBoundary.isOpen_openRectangle (a b c d : ℝ) : IsOpen (openRectangle a b c d) :=
+  isOpen_Ioo.reProdIm isOpen_Ioo
+
+private theorem
+    RiemannBoundary.convex_openRectangle (a b c d : ℝ) : Convex ℝ (openRectangle a b c d) :=
+  ((convex_halfSpace_re_gt a).inter (convex_halfSpace_re_lt b)).inter
+    ((convex_halfSpace_im_gt c).inter (convex_halfSpace_im_lt d))
+
+private theorem RiemannBoundary.mixed_mem_openRectangle {a b c d : ℝ} {z w : ℂ}
+    (hz : z ∈ openRectangle a b c d) (hw : w ∈ openRectangle a b c d) :
+    z.re + w.im * Complex.I ∈ openRectangle a b c d := by
+  simpa only [openRectangle, Set.mem_ofPred_eq, Complex.add_re, Complex.ofReal_re, Complex.mul_re,
+    Complex.I_re, Complex.ofReal_im, Complex.I_im, MulZeroClass.mul_zero, MulZeroClass.zero_mul,
+    sub_zero, add_zero, Complex.add_im, Complex.mul_im, mul_one, zero_add] using
+    And.intro hz.1 hw.2
+
+private theorem RiemannBoundary.rectangle_subset_openRectangle {a b c d : ℝ} {z w : ℂ}
+    (hz : z ∈ openRectangle a b c d) (hw : w ∈ openRectangle a b c d) :
+    Complex.Rectangle z w ⊆ openRectangle a b c d :=
+  Complex.Convex.rectangle_subset (convex_openRectangle a b c d) hz hw
+    (mixed_mem_openRectangle hz hw) (mixed_mem_openRectangle hw hz)
+
+private theorem RiemannBoundary.horizontal_segment_subset_mo1973_19308 {a b c d : ℝ} {x₁ x₂ y : ℝ}
+    (h₁ : (x₁ : ℂ) + y * Complex.I ∈ openRectangle a b c d)
+    (h₂ : (x₂ : ℂ) + y * Complex.I ∈ openRectangle a b c d) :
+    (fun x : ℝ => (x : ℂ) + y * Complex.I) '' [[x₁, x₂]] ⊆ openRectangle a b c d := by
+  convert rectangle_subset_openRectangle h₁ h₂ using 1
+  simp [Complex.horizontalSegment_eq x₁ x₂ y, Complex.Rectangle]
+
+private theorem RiemannBoundary.vertical_segment_subset_mo1973_19309 {a b c d : ℝ} {x y₁ y₂ : ℝ}
+    (h₁ : (x : ℂ) + y₁ * Complex.I ∈ openRectangle a b c d)
+    (h₂ : (x : ℂ) + y₂ * Complex.I ∈ openRectangle a b c d) :
+    (fun y : ℝ => (x : ℂ) + y * Complex.I) '' [[y₁, y₂]] ⊆ openRectangle a b c d := by
+  convert rectangle_subset_openRectangle h₁ h₂ using 1
+  simp [Complex.verticalSegment_eq x y₁ y₂, Complex.Rectangle]
+
+private theorem
+    RiemannBoundary.wedgeIntegral_sub_wedgeIntegral_openRectangle {a b c d : ℝ} {f : ℂ → ℂ}
+    (hc : ContinuousOn f (openRectangle a b c d))
+    (hf : Complex.IsConservativeOn f (openRectangle a b c d)) {p z w : ℂ}
+    (hp : p ∈ openRectangle a b c d) (hz : z ∈ openRectangle a b c d)
+    (hw : w ∈ openRectangle a b c d) :
+    Complex.wedgeIntegral p w f - Complex.wedgeIntegral p z f = Complex.wedgeIntegral z w f := by
+  have integrableHoriz (x₁ x₂ y : ℝ) (h₁ : (x₁ : ℂ) + y * Complex.I ∈ openRectangle a b c d)
+    (h₂ : (x₂ : ℂ) + y * Complex.I ∈ openRectangle a b c d) :
+    IntervalIntegrable (fun x : ℝ => f (x + y * Complex.I)) MeasureTheory.MeasureSpace.volume x₁
+      x₂ :=
+    ((hc.mono (horizontal_segment_subset_mo1973_19308 h₁ h₂)).comp (by fun_prop)
+        (Set.mapsTo_image _ _)).intervalIntegrable
+  have integrableVert (x y₁ y₂ : ℝ) (h₁ : (x : ℂ) + y₁ * Complex.I ∈ openRectangle a b c d)
+    (h₂ : (x : ℂ) + y₂ * Complex.I ∈ openRectangle a b c d) :
+    IntervalIntegrable (fun y : ℝ => f (x + y * Complex.I)) MeasureTheory.MeasureSpace.volume y₁
+      y₂ :=
+    ((hc.mono (vertical_segment_subset_mo1973_19309 h₁ h₂)).comp (by fun_prop)
+        (Set.mapsTo_image _ _)).intervalIntegrable
+  have hHoriz :
+    (∫ x in p.re..w.re, f (x + p.im * Complex.I)) =
+      (∫ x in p.re..z.re, f (x + p.im * Complex.I)) +
+        (∫ x in z.re..w.re, f (x + p.im * Complex.I)) := by
+    rw [intervalIntegral.integral_add_adjacent_intervals]
+    · apply integrableHoriz
+      · simpa only [Complex.re_add_im] using hp
+      · exact mixed_mem_openRectangle hz hp
+    · apply integrableHoriz
+      · exact mixed_mem_openRectangle hz hp
+      · exact mixed_mem_openRectangle hw hp
+  have hVert :
+    Complex.I * (∫ y in p.im..w.im, f (w.re + y * Complex.I)) =
+      Complex.I * (∫ y in p.im..z.im, f (w.re + y * Complex.I)) +
+        Complex.I * (∫ y in z.im..w.im, f (w.re + y * Complex.I)) := by
+    rw [← mul_add, intervalIntegral.integral_add_adjacent_intervals]
+    · apply integrableVert
+      · exact mixed_mem_openRectangle hw hp
+      · exact mixed_mem_openRectangle hw hz
+    · apply integrableVert
+      · exact mixed_mem_openRectangle hw hz
+      · simpa only [Complex.re_add_im] using hw
+  have hRect :=
+    hf (z.re + p.im * Complex.I) (w.re + z.im * Complex.I)
+      (rectangle_subset_openRectangle (mixed_mem_openRectangle hz hp)
+        (mixed_mem_openRectangle hw hz))
+  have hBoundary :
+    (∫ x in z.re..w.re, f (x + p.im * Complex.I)) -
+            (∫ x in z.re..w.re, f (x + z.im * Complex.I)) +
+          Complex.I * (∫ y in p.im..z.im, f (w.re + y * Complex.I)) -
+        Complex.I * (∫ y in p.im..z.im, f (z.re + y * Complex.I)) =
+      0 := by
+    simpa [← add_eq_zero_iff_eq_neg, Complex.wedgeIntegral_add_wedgeIntegral_eq] using hRect
+  simp only [Complex.wedgeIntegral, smul_eq_mul]
+  rw [hHoriz, hVert]
+  linear_combination hBoundary
+
+private theorem RiemannBoundary.hasDerivAt_wedgeIntegral_openRectangle {a b c d : ℝ} {f : ℂ → ℂ}
+    (hf : DifferentiableOn ℂ f (openRectangle a b c d)) {p z : ℂ} (hp : p ∈ openRectangle a b c d)
+    (hz : z ∈ openRectangle a b c d) :
+    HasDerivAt (fun w => Complex.wedgeIntegral p w f) (f z) z := by
+  obtain ⟨r, hr, hsub⟩ := Metric.isOpen_iff.mp (isOpen_openRectangle a b c d) z hz
+  have hd : HasDerivAt (fun w => Complex.wedgeIntegral z w f) (f z) z :=
+    (hf.isConservativeOn.mono hsub).hasDerivAt_wedgeIntegral (hf.continuousOn.mono hsub)
+      (Metric.mem_ball_self hr)
+  apply (hd.add_const (Complex.wedgeIntegral p z f)).congr_of_eventuallyEq
+  filter_upwards [(isOpen_openRectangle a b c d).mem_nhds hz] with w hw
+  exact
+    sub_eq_iff_eq_add.mp
+      (wedgeIntegral_sub_wedgeIntegral_openRectangle hf.continuousOn hf.isConservativeOn hp hz hw)
+
+private theorem RiemannBoundary.isExactOn_openRectangle {a b c d : ℝ} {f : ℂ → ℂ}
+    (hf : DifferentiableOn ℂ f (openRectangle a b c d)) :
+    Complex.IsExactOn f (openRectangle a b c d) := by
+  by_cases h : (openRectangle a b c d).Nonempty
+  · obtain ⟨p, hp⟩ := h
+    exact
+      ⟨fun z => Complex.wedgeIntegral p z f, fun _ hz =>
+        hasDerivAt_wedgeIntegral_openRectangle hf hp hz⟩
+  · refine ⟨fun _ => 0, fun z hz => ?_⟩
+    exact (h ⟨z, hz⟩).elim
+
+private theorem RiemannBoundary.exists_lipschitz_extension_primitive_openRectangle {a b c d : ℝ}
+    {f : ℂ → ℂ} {F : ℂ → ℂ} {K : ℝ≥0} (hF : ∀ z ∈ openRectangle a b c d, HasDerivAt F (f z) z)
+    (hb : ∀ z ∈ openRectangle a b c d, ‖f z‖₊ ≤ K) :
+    ∃ G : ℂ → ℂ,
+      LipschitzWith (lipschitzExtensionConstant ℂ * K) G ∧
+        Set.EqOn F G (openRectangle a b c d) ∧
+          ∀ z ∈ openRectangle a b c d, HasDerivAt G (f z) z := by
+  have hLip : LipschitzOnWith K F (openRectangle a b c d) :=
+    (convex_openRectangle a b c d).lipschitzOnWith_of_nnnorm_hasDerivWithin_le
+      (fun z hz => (hF z hz).hasDerivWithinAt) hb
+  obtain ⟨G, hG, heq⟩ := hLip.extend_finite_dimension
+  refine ⟨G, hG, heq, fun z hz => ?_⟩
+  apply (hF z hz).congr_of_eventuallyEq
+  filter_upwards [(isOpen_openRectangle a b c d).mem_nhds hz] with w hw
+  exact (heq hw).symm
+
+private theorem RiemannBoundary.exists_continuous_primitive_openRectangle {a b c d : ℝ} {f : ℂ → ℂ}
+    {K : ℝ≥0} (hf : DifferentiableOn ℂ f (openRectangle a b c d))
+    (hb : ∀ z ∈ openRectangle a b c d, ‖f z‖₊ ≤ K) :
+    ∃ G : ℂ → ℂ, Continuous G ∧ ∀ z ∈ openRectangle a b c d, HasDerivAt G (f z) z := by
+  obtain ⟨F, hF⟩ := isExactOn_openRectangle hf
+  obtain ⟨G, hG, _, hd⟩ := exists_lipschitz_extension_primitive_openRectangle hF hb
+  exact ⟨G, hG.continuous, hd⟩
+
+private theorem RiemannBoundary.exists_continuous_primitive_openRectangle_of_norm_le {a b c d : ℝ}
+    {f : ℂ → ℂ} {M : ℝ} (hf : DifferentiableOn ℂ f (openRectangle a b c d))
+    (hb : ∀ z ∈ openRectangle a b c d, ‖f z‖ ≤ M) :
+    ∃ G : ℂ → ℂ, Continuous G ∧ ∀ z ∈ openRectangle a b c d, HasDerivAt G (f z) z := by
+  apply exists_continuous_primitive_openRectangle (K := M.toNNReal) hf
+  intro z hz
+  exact_mod_cast (hb z hz).trans (Real.le_coe_toNNReal M)
+
+private theorem RiemannBoundary.hasDerivAt_horizontal {F : ℂ → ℂ} {f : ℂ} {x y : ℝ}
+    (hF : HasDerivAt F f ((x : ℂ) + y * Complex.I)) :
+    HasDerivAt (fun t : ℝ => F (t + y * Complex.I)) f x := by
+  have h := hF.comp (x : ℂ) ((hasDerivAt_id (x : ℂ)).add_const (y * Complex.I))
+  simpa only [mul_one, Function.comp_def, id_eq] using h.comp_ofReal
+
+private theorem RiemannBoundary.upper_limit_tendstoUniformlyOnFilter {q : ℂ → ℂ} {x : ℝ}
+    (hq : Filter.Tendsto q (𝓝[{z : ℂ | 0 < z.im}] (x : ℂ)) (𝓝 0)) :
+    TendstoUniformlyOnFilter (fun y t : ℝ => q (t + y * Complex.I)) (fun _ => 0) (𝓝[>] 0) (𝓝 x) :=
+  by
+  have ht :
+    Filter.Tendsto (fun p : ℝ × ℝ => (p.2 : ℂ) + p.1 * Complex.I) ((𝓝[>] 0) ×ˢ 𝓝 x)
+      (𝓝[{z : ℂ | 0 < z.im}] (x : ℂ)) := by
+    apply tendsto_nhdsWithin_iff.mpr
+    constructor
+    · have h₁ : Filter.Tendsto (fun p : ℝ × ℝ => (p.1 : ℂ)) ((𝓝[>] 0) ×ˢ 𝓝 x) (𝓝 (0 : ℂ)) :=
+        Complex.continuous_ofReal.continuousAt.tendsto.comp
+          (Filter.tendsto_fst.mono_right nhdsWithin_le_nhds)
+      have h₂ : Filter.Tendsto (fun p : ℝ × ℝ => (p.2 : ℂ)) ((𝓝[>] 0) ×ˢ 𝓝 x) (𝓝 (x : ℂ)) :=
+        Complex.continuous_ofReal.continuousAt.tendsto.comp Filter.tendsto_snd
+      simpa using h₂.add (h₁.mul_const Complex.I)
+    · have hy : ∀ᶠ p : ℝ × ℝ in (𝓝[>] 0) ×ˢ 𝓝 x, 0 < p.1 :=
+        Filter.tendsto_fst.eventually eventually_mem_nhdsWithin
+      filter_upwards [hy] with p hp
+      simpa using hp
+  apply Metric.tendstoUniformlyOnFilter_iff.mpr
+  intro ε hε
+  simpa only [Function.comp_def, dist_zero_left, dist_zero_right] using
+    Metric.tendsto_nhds.mp (hq.comp ht) ε hε
+
+private theorem
+    RiemannBoundary.hasDerivAt_boundary_trace_sub {F G f g : ℂ → ℂ} {a b h x : ℝ} (hh : 0 < h)
+    (hx : x ∈ Set.Ioo a b) (hF : Continuous F) (hG : Continuous G)
+    (hFd :
+      ∀ t ∈ Set.Ioo a b,
+        ∀ y ∈ Set.Ioo 0 h, HasDerivAt F (f (t + y * Complex.I)) (t + y * Complex.I))
+    (hGd :
+      ∀ t ∈ Set.Ioo a b,
+        ∀ y ∈ Set.Ioo 0 h, HasDerivAt G (g (t - y * Complex.I)) (t - y * Complex.I))
+    (hjump :
+      ∀ t ∈ Set.Ioo a b,
+        Filter.Tendsto (fun z => f z - g (conj z)) (𝓝[{z : ℂ | 0 < z.im}] (t : ℂ)) (𝓝 0)) :
+    HasDerivAt (fun t : ℝ => F t - G t) 0 x := by
+  let H : ℝ → ℝ → ℂ := fun y t => F (t + y * Complex.I) - G (t - y * Complex.I)
+  let H' : ℝ → ℝ → ℂ := fun y t => f (t + y * Complex.I) - g (t - y * Complex.I)
+  have hd : ∀ᶠ y in 𝓝[>] 0, ∀ t ∈ Set.Ioo a b, HasDerivAt (H y) (H' y t) t := by
+    filter_upwards [Ioo_mem_nhdsGT hh] with y hy t ht
+    have hu := hasDerivAt_horizontal (hFd t ht y hy)
+    have hl : HasDerivAt (fun s : ℝ => G (s - y * Complex.I)) (g (t - y * Complex.I)) t := by
+      have hi :=
+        hasDerivAt_horizontal (y := -y)
+          (by simpa only [Complex.ofReal_neg, neg_mul, sub_eq_add_neg] using hGd t ht y hy)
+      simpa only [Complex.ofReal_neg, neg_mul, sub_eq_add_neg] using hi
+    exact hu.sub hl
+  have hdu : TendstoLocallyUniformlyOn H' (fun _ => 0) (𝓝[>] 0) (Set.Ioo a b) := by
+    rw [tendstoLocallyUniformlyOn_iff_filter]
+    intro t ht
+    rw [isOpen_Ioo.nhdsWithin_eq ht]
+    simpa only [H', map_add, map_mul, Complex.conj_ofReal, Complex.conj_I, mul_neg,
+      ← sub_eq_add_neg] using upper_limit_tendstoUniformlyOnFilter (hjump t ht)
+  have hlim :
+    ∀ t ∈ Set.Ioo a b, Filter.Tendsto (fun y => H y t) (𝓝[>] 0) (𝓝 (F (t : ℂ) - G (t : ℂ))) := by
+    intro t _
+    have hc : Continuous (fun y : ℝ => H y t) := by dsimp [H]; fun_prop
+    simpa [H] using (hc.tendsto 0).mono_left (nhdsWithin_le_nhds (s := Set.Ioi 0))
+  exact hasDerivAt_of_tendstoLocallyUniformlyOn isOpen_Ioo hdu hd hlim hx
+
+private theorem RiemannBoundary.boundary_trace_sub_eq {F G f g : ℂ → ℂ} {a b h x t : ℝ} (hh : 0 < h)
+    (hx : x ∈ Set.Ioo a b) (ht : t ∈ Set.Ioo a b) (hF : Continuous F) (hG : Continuous G)
+    (hFd :
+      ∀ s ∈ Set.Ioo a b,
+        ∀ y ∈ Set.Ioo 0 h, HasDerivAt F (f (s + y * Complex.I)) (s + y * Complex.I))
+    (hGd :
+      ∀ s ∈ Set.Ioo a b,
+        ∀ y ∈ Set.Ioo 0 h, HasDerivAt G (g (s - y * Complex.I)) (s - y * Complex.I))
+    (hjump :
+      ∀ s ∈ Set.Ioo a b,
+        Filter.Tendsto (fun z => f z - g (conj z)) (𝓝[{z : ℂ | 0 < z.im}] (s : ℂ)) (𝓝 0)) :
+    F (x : ℂ) - G (x : ℂ) = F (t : ℂ) - G (t : ℂ) := by
+  have hd (s : ℝ) (hs : s ∈ Set.Ioo a b) :=
+    hasDerivAt_boundary_trace_sub hh hs hF hG hFd hGd hjump
+  exact
+    isOpen_Ioo.is_const_of_deriv_eq_zero (convex_Ioo a b).isPreconnected
+      (fun s hs => (hd s hs).differentiableAt.differentiableWithinAt)
+      (fun s hs => (hd s hs).deriv) hx ht
+
+private theorem
+    RiemannBoundary.exists_analytic_extension_of_vanishing_jump {f g : ℂ → ℂ} {a b h M N : ℝ}
+    (hab : a < b) (hh : 0 < h) (hf : DifferentiableOn ℂ f (openRectangle a b 0 h))
+    (hg : DifferentiableOn ℂ g (openRectangle a b (-h) 0))
+    (hfb : ∀ z ∈ openRectangle a b 0 h, ‖f z‖ ≤ M)
+    (hgb : ∀ z ∈ openRectangle a b (-h) 0, ‖g z‖ ≤ N)
+    (hjump :
+      ∀ x ∈ Set.Ioo a b,
+        Filter.Tendsto (fun z => f z - g (conj z)) (𝓝[{z : ℂ | 0 < z.im}] (x : ℂ)) (𝓝 0)) :
+    ∃ H : ℂ → ℂ,
+      AnalyticOnNhd ℂ H (openRectangle a b (-h) h) ∧
+        Set.EqOn H f (openRectangle a b 0 h) ∧ Set.EqOn H g (openRectangle a b (-h) 0) := by
+  obtain ⟨F, hFc, hFd⟩ := exists_continuous_primitive_openRectangle_of_norm_le hf hfb
+  obtain ⟨G, hGc, hGd⟩ := exists_continuous_primitive_openRectangle_of_norm_le hg hgb
+  let x₀ : ℝ := (a + b) / 2
+  have hx₀ : x₀ ∈ Set.Ioo a b := by dsimp [x₀]; constructor <;> linarith
+  let c : ℂ := F x₀ - G x₀
+  have htrace : ∀ x ∈ Set.Ioo a b, F (x : ℂ) = G (x : ℂ) + c := by
+    intro x hx
+    have hdF :
+      ∀ t ∈ Set.Ioo a b,
+        ∀ y ∈ Set.Ioo 0 h, HasDerivAt F (f (t + y * Complex.I)) (t + y * Complex.I) := by
+      intro t ht y hy
+      exact hFd _ (by simpa [openRectangle] using And.intro ht hy)
+    have hdG :
+      ∀ t ∈ Set.Ioo a b,
+        ∀ y ∈ Set.Ioo 0 h, HasDerivAt G (g (t - y * Complex.I)) (t - y * Complex.I) := by
+      intro t ht y hy
+      apply hGd
+      simpa [openRectangle] using
+        And.intro ht (show -y ∈ Set.Ioo (-h) 0 by constructor <;> linarith [hy.1, hy.2])
+    have he := boundary_trace_sub_eq hh hx hx₀ hFc hGc hdF hdG hjump
+    dsimp [c]
+    linear_combination he
+  let P := SchwarzReflection.pasteUpper F (fun z => G z + c)
+  have hP : AnalyticOnNhd ℂ P (openRectangle a b (-h) h) := by
+    apply
+      SchwarzReflection.analyticOnNhd_pasteUpper (isOpen_openRectangle _ _ _ _) hFc.continuousOn
+        (hGc.add continuous_const).continuousOn
+    · intro z hz hpos
+      exact (hFd z ⟨hz.1, hpos, hz.2.2⟩).differentiableAt
+    · intro z hz hneg
+      exact ((hGd z ⟨hz.1, hz.2.1, hneg⟩).add_const c).differentiableAt
+    · intro z hz hzero
+      change F z = G z + c
+      have heq : (z.re : ℂ) = z := by exact Complex.ext (by simp) (by simpa using hzero.symm)
+      simpa only [heq] using htrace z.re hz.1
+  refine ⟨deriv P, hP.deriv, ?_, ?_⟩
+  · intro z hz
+    have hnear : P =ᶠ[𝓝 z] F := by
+      filter_upwards [continuousAt_const.eventually_lt Complex.continuous_im.continuousAt
+          hz.2.1] with
+        w hw
+      exact SchwarzReflection.pasteUpper_of_nonneg F (fun w => G w + c) hw.le
+    exact ((hFd z hz).congr_of_eventuallyEq hnear).deriv
+  · intro z hz
+    have hnear : P =ᶠ[𝓝 z] (fun w => G w + c) := by
+      filter_upwards [Complex.continuous_im.continuousAt.eventually_lt continuousAt_const
+          hz.2.2] with
+        w hw
+      exact SchwarzReflection.pasteUpper_of_neg F (fun w => G w + c) hw
+    exact (((hGd z hz).add_const c).congr_of_eventuallyEq hnear).deriv
+
+private theorem
+    RiemannBoundary.norm_sub_inv_conj (w : ℂ) : ‖w - (conj w)⁻¹‖ = |‖w‖ ^ 2 - 1| / ‖w‖ := by
+  have heq : w - (conj w)⁻¹ = ((‖w‖ ^ 2 - 1 : ℝ) : ℂ) / conj w := by
+    by_cases hw : w = 0
+    · simp [hw]
+    have hc : conj w ≠ 0 := by simpa using hw
+    apply (eq_div_iff hc).mpr
+    rw [sub_mul, inv_mul_cancel₀ hc, Complex.mul_conj, Complex.normSq_eq_norm_sq,
+      Complex.ofReal_sub, Complex.ofReal_one]
+  rw [heq, norm_div, Complex.norm_real, Real.norm_eq_abs, Complex.norm_conj]
+
+private theorem RiemannBoundary.tendsto_sub_inv_conj_of_norm {α : Type*} {l : Filter α} {f : α → ℂ}
+    (hf : Filter.Tendsto (fun x => ‖f x‖) l (𝓝 1)) :
+    Filter.Tendsto (fun x => f x - (conj (f x))⁻¹) l (𝓝 0) := by
+  rw [tendsto_zero_iff_norm_tendsto_zero]
+  simp_rw [norm_sub_inv_conj]
+  have hn : Filter.Tendsto (fun x => |‖f x‖ ^ 2 - 1|) l (𝓝 (0 : ℝ)) := by
+    simpa using ((hf.pow 2).sub (tendsto_const_nhds (x := (1 : ℝ)))).abs
+  have hdiv := hn.div hf one_ne_zero
+  have hfun :
+    ((fun x => |‖f x‖ ^ 2 - 1|) / (fun x => ‖f x‖)) = (fun x => |‖f x‖ ^ 2 - 1| / ‖f x‖) := by rfl
+  rw [hfun] at hdiv
+  simpa only [zero_div] using hdiv
+
+private theorem
+    RiemannBoundary.norm_axis_eq_one_of_extension {H f : ℂ → ℂ} {a b h x : ℝ} (hh : 0 < h)
+    (hx : x ∈ Set.Ioo a b) (hH : ContinuousOn H (openRectangle a b (-h) h))
+    (heq : Set.EqOn H f (openRectangle a b 0 h))
+    (hmod : Filter.Tendsto (fun z => ‖f z‖) (𝓝[{z : ℂ | 0 < z.im}] (x : ℂ)) (𝓝 1)) :
+    ‖H (x : ℂ)‖ = 1 := by
+  have hxU : (x : ℂ) ∈ openRectangle a b (-h) h := by
+    simpa [openRectangle] using
+      And.intro hx (show (0 : ℝ) ∈ Set.Ioo (-h) h by constructor <;> linarith)
+  have hHt : Filter.Tendsto (fun y : ℝ => ‖H (x + y * Complex.I)‖) (𝓝[>] 0) (𝓝 ‖H (x : ℂ)‖) := by
+    have hcont := (hH.continuousAt ((isOpen_openRectangle _ _ _ _).mem_nhds hxU)).norm
+    have ht : Filter.Tendsto (fun y : ℝ => (x : ℂ) + y * Complex.I) (𝓝[>] 0) (𝓝 (x : ℂ)) := by
+      have hc : Continuous (fun y : ℝ => (x : ℂ) + y * Complex.I) := by fun_prop
+      simpa using (hc.tendsto 0).mono_left (nhdsWithin_le_nhds (s := Set.Ioi 0))
+    exact hcont.tendsto.comp ht
+  have hft : Filter.Tendsto (fun y : ℝ => ‖f (x + y * Complex.I)‖) (𝓝[>] 0) (𝓝 1) := by
+    apply hmod.comp
+    apply tendsto_nhdsWithin_iff.mpr
+    constructor
+    · have hc : Continuous (fun y : ℝ => (x : ℂ) + y * Complex.I) := by fun_prop
+      simpa using (hc.tendsto 0).mono_left (nhdsWithin_le_nhds (s := Set.Ioi 0))
+    · filter_upwards [self_mem_nhdsWithin] with y hy
+      simpa using hy
+  have hevent :
+    (fun y : ℝ => ‖H (x + y * Complex.I)‖) =ᶠ[𝓝[>] 0] (fun y : ℝ => ‖f (x + y * Complex.I)‖) := by
+    filter_upwards [Ioo_mem_nhdsGT hh] with y hy
+    rw [heq (by simpa [openRectangle] using And.intro hx hy)]
+  exact tendsto_nhds_unique hHt (hft.congr' hevent.symm)
+
+private theorem RiemannBoundary.exists_analytic_extension_of_modulus_one_bounded {f : ℂ → ℂ}
+    {a b h M m : ℝ} (hab : a < b) (hh : 0 < h) (hm : 0 < m)
+    (hf : DifferentiableOn ℂ f (openRectangle a b 0 h))
+    (hfb : ∀ z ∈ openRectangle a b 0 h, ‖f z‖ ≤ M) (hfl : ∀ z ∈ openRectangle a b 0 h, m ≤ ‖f z‖)
+    (hmod :
+      ∀ x ∈ Set.Ioo a b, Filter.Tendsto (fun z => ‖f z‖) (𝓝[{z : ℂ | 0 < z.im}] (x : ℂ)) (𝓝 1)) :
+    ∃ H : ℂ → ℂ,
+      AnalyticOnNhd ℂ H (openRectangle a b (-h) h) ∧
+        Set.EqOn H f (openRectangle a b 0 h) ∧
+          Set.EqOn H (fun z => (conj (f (conj z)))⁻¹) (openRectangle a b (-h) 0) ∧
+            ∀ x ∈ Set.Ioo a b, ‖H (x : ℂ)‖ = 1 := by
+  let g : ℂ → ℂ := fun z => (conj (f (conj z)))⁻¹
+  have hconj : ∀ z ∈ openRectangle a b (-h) 0, conj z ∈ openRectangle a b 0 h := by
+    intro z hz
+    refine ⟨by simpa using hz.1, ?_⟩
+    simp only [Complex.conj_im, Set.mem_Ioo]
+    constructor <;> linarith [hz.2.1, hz.2.2]
+  have hnz : ∀ z ∈ openRectangle a b 0 h, f z ≠ 0 := by
+    intro z hz heq
+    have hb := hfl z hz
+    rw [heq, norm_zero] at hb
+    exact (not_le.mpr hm) hb
+  have hg : DifferentiableOn ℂ g (openRectangle a b (-h) 0) := by
+    intro z hz
+    have hd :=
+      (hf.differentiableAt ((isOpen_openRectangle _ _ _ _).mem_nhds (hconj z hz))).conj_conj
+    have hd' : DifferentiableAt ℂ (fun w => conj (f (conj w))) z := by
+      simpa only [Function.comp_def, starRingEnd_self_apply] using hd
+    exact (hd'.inv (by simpa using hnz (conj z) (hconj z hz))).differentiableWithinAt
+  have hgb : ∀ z ∈ openRectangle a b (-h) 0, ‖g z‖ ≤ m⁻¹ := by
+    intro z hz
+    simp only [g, norm_inv, Complex.norm_conj]
+    exact (inv_le_inv₀ (hm.trans_le (hfl _ (hconj z hz))) hm).mpr (hfl _ (hconj z hz))
+  have hjump :
+    ∀ x ∈ Set.Ioo a b,
+      Filter.Tendsto (fun z => f z - g (conj z)) (𝓝[{z : ℂ | 0 < z.im}] (x : ℂ)) (𝓝 0) := by
+    intro x hx
+    simpa only [g, starRingEnd_self_apply] using tendsto_sub_inv_conj_of_norm (hmod x hx)
+  obtain ⟨H, hH, he, hl⟩ := exists_analytic_extension_of_vanishing_jump hab hh hf hg hfb hgb hjump
+  exact
+    ⟨H, hH, he, hl, fun x hx =>
+      norm_axis_eq_one_of_extension hh hx hH.continuousOn he (hmod x hx)⟩
+
+private theorem RiemannBoundary.dist_lt_two_mul_of_mem_centeredRectangle {x r : ℝ} {z : ℂ}
+    (hz : z ∈ openRectangle (x - r) (x + r) (-r) r) : Dist.dist z (x : ℂ) < 2 * r := by
+  have hre : |(z - x).re| < r := by
+    simp only [Complex.sub_re, Complex.ofReal_re]
+    exact abs_lt.mpr ⟨by linarith [hz.1.1], by linarith [hz.1.2]⟩
+  have him : |(z - x).im| < r := by
+    simpa only [Complex.sub_im, Complex.ofReal_im, sub_zero] using abs_lt.mpr hz.2
+  rw [dist_eq_norm]
+  exact (Complex.norm_le_abs_re_add_abs_im (z - x)).trans_lt (by linarith)
+
+private theorem RiemannBoundary.ball_subset_centeredRectangle (x r : ℝ) :
+    Metric.ball (x : ℂ) r ⊆ openRectangle (x - r) (x + r) (-r) r := by
+  intro z hz
+  have hn : ‖z - x‖ < r := by simpa only [Metric.mem_ball, dist_eq_norm] using hz
+  have hre := abs_lt.mp ((Complex.abs_re_le_norm (z - x)).trans_lt hn)
+  have him := abs_lt.mp ((Complex.abs_im_le_norm (z - x)).trans_lt hn)
+  simp only [Complex.sub_re, Complex.ofReal_re, Complex.sub_im, Complex.ofReal_im,
+    sub_zero] at hre him
+  exact ⟨⟨by linarith [hre.1], by linarith [hre.2]⟩, him⟩
+
+private theorem RiemannBoundary.exists_analytic_extension_of_modulus_one {U : Set ℂ} (hU : IsOpen U)
+    {f : ℂ → ℂ} {x : ℝ} (hx : (x : ℂ) ∈ U) (hf : DifferentiableOn ℂ f (U ∩ {z : ℂ | 0 < z.im}))
+    (hmod :
+      ∀ t : ℝ,
+        (t : ℂ) ∈ U → Filter.Tendsto (fun z => ‖f z‖) (𝓝[{z : ℂ | 0 < z.im}] (t : ℂ)) (𝓝 1)) :
+    ∃ r > 0,
+      ∃ H : ℂ → ℂ,
+        AnalyticOnNhd ℂ H (Metric.ball (x : ℂ) r) ∧
+          Set.EqOn H f (Metric.ball (x : ℂ) r ∩ {z : ℂ | 0 < z.im}) ∧
+            Set.EqOn H (fun z => (conj (f (conj z)))⁻¹)
+                (Metric.ball (x : ℂ) r ∩ {z : ℂ | z.im < 0}) ∧
+              ∀ t : ℝ, (t : ℂ) ∈ Metric.ball (x : ℂ) r → ‖H (t : ℂ)‖ = 1 := by
+  obtain ⟨ε, hε, hεU⟩ := Metric.isOpen_iff.mp hU (x : ℂ) hx
+  obtain ⟨δ, hδ, hδf⟩ := Metric.tendsto_nhdsWithin_nhds.mp (hmod x hx) (1 / 2) (by norm_num)
+  let r : ℝ := Min.min ε δ / 4
+  have hr : 0 < r := by dsimp [r]; positivity
+  have hrε : 2 * r < ε := by
+    have hm := min_le_left ε δ
+    dsimp [r]
+    linarith
+  have hrδ : 2 * r < δ := by
+    have hm := min_le_right ε δ
+    dsimp [r]
+    linarith
+  have hrectU : openRectangle (x - r) (x + r) (-r) r ⊆ U := by
+    intro z hz
+    apply hεU
+    exact (dist_lt_two_mul_of_mem_centeredRectangle hz).trans hrε
+  have hu : openRectangle (x - r) (x + r) 0 r ⊆ U ∩ {z : ℂ | 0 < z.im} := by
+    intro z hz
+    exact ⟨hrectU ⟨hz.1, by linarith [hz.2.1], hz.2.2⟩, hz.2.1⟩
+  have hsize : ∀ z ∈ openRectangle (x - r) (x + r) 0 r, 1 / 2 ≤ ‖f z‖ ∧ ‖f z‖ ≤ 2 := by
+    intro z hz
+    have hzR : z ∈ openRectangle (x - r) (x + r) (-r) r := ⟨hz.1, by linarith [hz.2.1], hz.2.2⟩
+    have he := hδf hz.2.1 ((dist_lt_two_mul_of_mem_centeredRectangle hzR).trans hrδ)
+    rw [Real.dist_eq, abs_lt] at he
+    constructor <;> linarith [he.1, he.2]
+  have hmodR :
+    ∀ t ∈ Set.Ioo (x - r) (x + r),
+      Filter.Tendsto (fun z => ‖f z‖) (𝓝[{z : ℂ | 0 < z.im}] (t : ℂ)) (𝓝 1) := by
+    intro t ht
+    apply hmod
+    apply hrectU
+    simpa only [openRectangle, Set.mem_ofPred_eq, Complex.ofReal_re, Complex.ofReal_im] using
+      And.intro ht (show (0 : ℝ) ∈ Set.Ioo (-r) r by constructor <;> linarith)
+  obtain ⟨H, hH, hHe, hHl, hHcircle⟩ :=
+    exists_analytic_extension_of_modulus_one_bounded (by linarith) hr
+      (show (0 : ℝ) < 1 / 2 by norm_num) (hf.mono hu) (fun z hz => (hsize z hz).2)
+      (fun z hz => (hsize z hz).1) hmodR
+  refine ⟨r, hr, H, hH.mono (ball_subset_centeredRectangle x r), ?_, ?_, ?_⟩
+  · intro z hz
+    have hzR := ball_subset_centeredRectangle x r hz.1
+    exact hHe ⟨hzR.1, hz.2, hzR.2.2⟩
+  · intro z hz
+    have hzR := ball_subset_centeredRectangle x r hz.1
+    exact hHl ⟨hzR.1, hzR.2.1, hz.2⟩
+  · intro t ht
+    have htR := ball_subset_centeredRectangle x r ht
+    exact hHcircle t (by simpa only [Complex.ofReal_re] using htR.1)
+
+private theorem RiemannBoundary.tendsto_norm_discHomeomorph_nhdsWithin_of_notMem {D : Set ℂ}
+    (e : D ≃ₜ Metric.ball (0 : ℂ) 1) {f : ℂ → ℂ} (he : ∀ z : D, f z = (e z : ℂ)) {a : ℂ}
+    (ha : a ∉ D) : Filter.Tendsto (fun z => ‖f z‖) (𝓝[D] a) (𝓝 1) := by
+  have hz :
+    Filter.Tendsto (Subtype.val : D → ℂ) (Filter.comap (Subtype.val : D → ℂ) (𝓝[D] a)) (𝓝 a) :=
+    Filter.tendsto_comap.mono_right nhdsWithin_le_nhds
+  have ht := RiemannMapping.tendsto_norm_discHomeomorph_of_notMem e ha hz
+  apply (Filter.tendsto_comap'_iff (i := (Subtype.val : D → ℂ)) ?_).mp
+  · simpa only [Function.comp_def, he] using ht
+  · simpa only [Subtype.range_coe] using (self_mem_nhdsWithin : D ∈ 𝓝[D] a)
+
+private theorem RiemannBoundary.tendsto_norm_discHomeomorph_in_boundary_chart {D U : Set ℂ}
+    (e : D ≃ₜ Metric.ball (0 : ℂ) 1) {f φ : ℂ → ℂ} (he : ∀ z : D, f z = (e z : ℂ)) (hU : IsOpen U)
+    (hφ : ContinuousOn φ (U ∩ {z : ℂ | 0 ≤ z.im}))
+    (hside : Set.MapsTo φ (U ∩ {z : ℂ | 0 < z.im}) D) {x : ℝ} (hx : (x : ℂ) ∈ U)
+    (hout : φ (x : ℂ) ∉ D) :
+    Filter.Tendsto (fun z => ‖f (φ z)‖) (𝓝[{z : ℂ | 0 < z.im}] (x : ℂ)) (𝓝 1) := by
+  apply (tendsto_norm_discHomeomorph_nhdsWithin_of_notMem e he hout).comp
+  apply tendsto_nhdsWithin_iff.mpr
+  constructor
+  · have hc := hφ (x : ℂ) ⟨hx, by simp⟩
+    apply hc.tendsto.comp
+    apply tendsto_nhdsWithin_iff.mpr
+    constructor
+    · exact Filter.tendsto_id.mono_right nhdsWithin_le_nhds
+    · have hnear : U ∈ 𝓝[{z : ℂ | 0 < z.im}] (x : ℂ) :=
+        mem_nhdsWithin_of_mem_nhds (hU.mem_nhds hx)
+      filter_upwards [hnear, self_mem_nhdsWithin] with z hz hu
+      exact ⟨hz, le_of_lt hu⟩
+  · have hnear : U ∈ 𝓝[{z : ℂ | 0 < z.im}] (x : ℂ) := mem_nhdsWithin_of_mem_nhds (hU.mem_nhds hx)
+    filter_upwards [hnear, self_mem_nhdsWithin] with z hz hu
+    exact hside ⟨hz, hu⟩
+
+private theorem RiemannMapping.im_mul_exp_real_mo1973_19358 (c : ℂ) (θ : ℝ) :
+    (c * Complex.exp ((θ : ℂ) * Complex.I)).im = ‖c‖ * Real.sin (c.arg + θ) := by
+  calc
+    (c * Complex.exp ((θ : ℂ) * Complex.I)).im =
+        (((‖c‖ : ℝ) : ℂ) *
+            (Complex.exp ((c.arg : ℂ) * Complex.I) * Complex.exp ((θ : ℂ) * Complex.I))).im := by
+      rw [← mul_assoc, Complex.norm_mul_exp_arg_mul_I]
+    _ = (((‖c‖ : ℝ) : ℂ) * Complex.exp (((c.arg + θ : ℝ) : ℂ) * Complex.I)).im := by
+      rw [← Complex.exp_add]
+      congr 3
+      push_cast
+      ring
+    _ = ‖c‖ * Real.sin (c.arg + θ) := by rw [Complex.im_ofReal_mul, Complex.exp_ofReal_mul_I_im]
+
+private theorem RiemannMapping.im_mul_exp_real_pow_mo1973_19359 (c : ℂ) (θ : ℝ) (n : ℕ) :
+    (c * Complex.exp ((θ : ℂ) * Complex.I) ^ n).im = ‖c‖ * Real.sin (c.arg + (n : ℝ) * θ) := by
+  rw [← Complex.exp_nat_mul]
+  have h : (n : ℂ) * ((θ : ℂ) * Complex.I) = (((n : ℝ) * θ : ℝ) : ℂ) * Complex.I := by
+    push_cast
+    ring
+  rw [h]
+  exact im_mul_exp_real_mo1973_19358 c ((n : ℝ) * θ)
+
+private theorem RiemannMapping.exists_unit_upperHalf_power_direction {c : ℂ} (hc : c ≠ 0) {n : ℕ}
+    (hn : 2 ≤ n) : ∃ v : ℂ, ‖v‖ = 1 ∧ 0 < v.im ∧ (c * v ^ n).im < 0 := by
+  have hn₂ : (2 : ℝ) ≤ n := by exact_mod_cast hn
+  have hn₀ : (0 : ℝ) < n := by linarith
+  have hc₀ : 0 < ‖c‖ := norm_pos_iff.mpr hc
+  have hπ : 0 < Real.pi := Real.pi_pos
+  have ha₁ : -Real.pi < c.arg := Complex.neg_pi_lt_arg c
+  have ha₂ : c.arg ≤ Real.pi := Complex.arg_le_pi c
+  have hπn : 2 * Real.pi ≤ Real.pi * n := by nlinarith
+  by_cases ha : -(Real.pi / 2) < c.arg
+  · let θ : ℝ := (3 * Real.pi / 2 - c.arg) / n
+    have hθ₀ : 0 < θ := div_pos (by linarith) hn₀
+    have hθπ : θ < Real.pi := by
+      apply (div_lt_iff₀ hn₀).mpr
+      linarith
+    have hphase : c.arg + (n : ℝ) * θ = 3 * Real.pi / 2 := by
+      dsimp [θ]
+      rw [mul_comm (n : ℝ), div_mul_cancel₀ _ hn₀.ne']
+      ring
+    refine ⟨Complex.exp ((θ : ℂ) * Complex.I), Complex.norm_exp_ofReal_mul_I θ, ?_, ?_⟩
+    · rw [Complex.exp_ofReal_mul_I_im]
+      exact Real.sin_pos_of_pos_of_lt_pi hθ₀ hθπ
+    · rw [im_mul_exp_real_pow_mo1973_19359, hphase]
+      rw [show 3 * Real.pi / 2 = Real.pi / 2 + Real.pi by ring, Real.sin_add_pi,
+        Real.sin_pi_div_two]
+      linarith
+  · have ha' : c.arg ≤ -(Real.pi / 2) := le_of_not_gt ha
+    let θ : ℝ := (-Real.pi / 4 - c.arg) / n
+    have hθ₀ : 0 < θ := div_pos (by linarith) hn₀
+    have hθπ : θ < Real.pi := by
+      apply (div_lt_iff₀ hn₀).mpr
+      linarith
+    have hphase : c.arg + (n : ℝ) * θ = -Real.pi / 4 := by
+      dsimp [θ]
+      rw [mul_comm (n : ℝ), div_mul_cancel₀ _ hn₀.ne']
+      ring
+    refine ⟨Complex.exp ((θ : ℂ) * Complex.I), Complex.norm_exp_ofReal_mul_I θ, ?_, ?_⟩
+    · rw [Complex.exp_ofReal_mul_I_im]
+      exact Real.sin_pos_of_pos_of_lt_pi hθ₀ hθπ
+    · rw [im_mul_exp_real_pow_mo1973_19359, hphase]
+      exact
+        mul_neg_of_pos_of_neg hc₀ (Real.sin_neg_of_neg_of_neg_pi_lt (by linarith) (by linarith))
+
+private theorem RiemannMapping.exists_upperHalf_power_direction {c : ℂ} (hc : c ≠ 0) {n : ℕ}
+    (hn : 2 ≤ n) : ∃ v : ℂ, 0 < v.im ∧ (c * v ^ n).im < 0 := by
+  obtain ⟨v, _, hv, hcv⟩ := exists_unit_upperHalf_power_direction hc hn
+  exact ⟨v, hv, hcv⟩
+
+private theorem RiemannMapping.tendsto_boundaryRay (a v : ℂ) :
+    Filter.Tendsto (fun t : ℝ => a + (t : ℂ) * v) (𝓝[>] 0) (𝓝 a) := by
+  have hc : Continuous (fun t : ℝ => a + (t : ℂ) * v) := by fun_prop
+  simpa using (hc.continuousAt (x := 0)).tendsto.mono_left nhdsWithin_le_nhds
+
+private theorem RiemannMapping.boundaryRay_im_pos {a v : ℂ} (ha : a.im = 0) (hv : 0 < v.im) {t : ℝ}
+    (ht : 0 < t) : 0 < (a + (t : ℂ) * v).im := by
+  simpa only [Complex.add_im, Complex.mul_im, Complex.ofReal_re, Complex.ofReal_im, ha,
+    MulZeroClass.zero_mul, MulZeroClass.mul_zero, add_zero, zero_add] using mul_pos ht hv
+
+private theorem RiemannMapping.analyticOrderAt_ne_top_of_upper_halfPlane {f : ℂ → ℂ} {a : ℂ}
+    (ha : a.im = 0) (hupper : ∀ᶠ z in 𝓝 a, 0 < z.im → 0 < (f z).im) : analyticOrderAt f a ≠ ⊤ := by
+  intro htop
+  have hz := (tendsto_boundaryRay a Complex.I).eventually (analyticOrderAt_eq_top.mp htop)
+  have hp := (tendsto_boundaryRay a Complex.I).eventually hupper
+  have hfalse : ∀ᶠ t : ℝ in 𝓝[>] 0, False := by
+    filter_upwards [self_mem_nhdsWithin, hz, hp] with t ht hzero hpos
+    have hi := hpos (boundaryRay_im_pos ha (by simp) ht)
+    simp only [hzero, Complex.zero_im, lt_self_iff_false] at hi
+  obtain ⟨t, ht⟩ := hfalse.exists
+  exact ht
+
+private theorem RiemannMapping.nonneg_im_leading_of_upper_halfPlane {f u : ℂ → ℂ} {a : ℂ} {m : ℕ}
+    (ha : a.im = 0) (hu : ContinuousAt u a) (hfactor : ∀ᶠ z in 𝓝 a, f z = (z - a) ^ m * u z)
+    (hupper : ∀ᶠ z in 𝓝 a, 0 < z.im → 0 < (f z).im) {v : ℂ} (hv : 0 < v.im) :
+    0 ≤ (v ^ m * u a).im := by
+  have hray := tendsto_boundaryRay a v
+  have hlimC :
+    Filter.Tendsto (fun t : ℝ => v ^ m * u (a + (t : ℂ) * v)) (𝓝[>] 0) (𝓝 (v ^ m * u a)) :=
+    tendsto_const_nhds.mul (hu.tendsto.comp hray)
+  have hlim :
+    Filter.Tendsto (fun t : ℝ => (v ^ m * u (a + (t : ℂ) * v)).im) (𝓝[>] 0)
+      (𝓝 (v ^ m * u a).im) :=
+    Complex.continuous_im.continuousAt.tendsto.comp hlimC
+  apply ge_of_tendsto hlim
+  filter_upwards [self_mem_nhdsWithin, hray.eventually hfactor, hray.eventually hupper] with t ht
+    hft hpos
+  have hft' : (f (a + (t : ℂ) * v)).im = t ^ m * (v ^ m * u (a + (t : ℂ) * v)).im := by
+    rw [hft, add_sub_cancel_left, mul_pow, mul_assoc]
+    simp only [← Complex.ofReal_pow, Complex.mul_im, Complex.ofReal_re, Complex.ofReal_im,
+      MulZeroClass.zero_mul, add_zero]
+  have hp : 0 < t ^ m * (v ^ m * u (a + (t : ℂ) * v)).im := by
+    rw [← hft']
+    exact hpos (boundaryRay_im_pos ha hv ht)
+  exact ((mul_pos_iff_of_pos_left (pow_pos ht m)).mp hp).le
+
+private theorem RiemannMapping.analyticOrderAt_eq_one_of_upper_halfPlane {f : ℂ → ℂ} {a : ℂ}
+    (hf : AnalyticAt ℂ f a) (ha : a.im = 0) (hfa : f a = 0)
+    (hupper : ∀ᶠ z in 𝓝 a, 0 < z.im → 0 < (f z).im) : analyticOrderAt f a = 1 := by
+  have hfin := analyticOrderAt_ne_top_of_upper_halfPlane ha hupper
+  let m := analyticOrderNatAt f a
+  have horder : (m : ℕ∞) = analyticOrderAt f a := Nat.cast_analyticOrderNatAt hfin
+  have hm0 : m ≠ 0 := by
+    intro hm
+    have hf0 : analyticOrderAt f a = 0 := by simpa [hm] using horder.symm
+    exact (hf.analyticOrderAt_ne_zero.mpr hfa) hf0
+  obtain ⟨u, hu, hua, hfactor⟩ := hf.analyticOrderAt_eq_natCast.mp horder.symm
+  have hm2 : ¬2 ≤ m := by
+    intro hm
+    obtain ⟨v, hv, hneg⟩ := exists_upperHalf_power_direction hua hm
+    have hnonneg : 0 ≤ (v ^ m * u a).im :=
+      nonneg_im_leading_of_upper_halfPlane ha hu.continuousAt
+        (by simpa only [smul_eq_mul] using hfactor) hupper hv
+    rw [mul_comm] at hneg
+    exact hneg.not_ge hnonneg
+  have hm : m = 1 := by omega
+  rw [← horder, hm]
+  rfl
+
+private theorem RiemannMapping.deriv_ne_zero_of_upper_halfPlane {f : ℂ → ℂ} {a : ℂ}
+    (hf : AnalyticAt ℂ f a) (ha : a.im = 0) (hfa : f a = 0)
+    (hupper : ∀ᶠ z in 𝓝 a, 0 < z.im → 0 < (f z).im) : deriv f a ≠ 0 := by
+  have ho := analyticOrderAt_eq_one_of_upper_halfPlane hf ha hfa hupper
+  have hd := (analyticOrderAt_eq_nat_iff_iteratedDeriv_eq_zero hf).mp ho
+  simpa only [iteratedDeriv_one] using hd.2
+
+private def RiemannMapping.boundaryLog (f : ℂ → ℂ) (a z : ℂ) : ℂ :=
+  -Complex.I * Complex.log (f z / f a)
+
+@[simp]
+private theorem RiemannMapping.boundaryLog_self {f : ℂ → ℂ} {a : ℂ} (hfa : f a ≠ 0) :
+    boundaryLog f a a = 0 := by simp [boundaryLog, hfa]
+
+private theorem RiemannMapping.analyticAt_boundaryLog {f : ℂ → ℂ} {a : ℂ} (hf : AnalyticAt ℂ f a)
+    (hfa : f a ≠ 0) : AnalyticAt ℂ (boundaryLog f a) a := by
+  have hratio : AnalyticAt ℂ (fun z => f z / f a) a := hf.div_const
+  have hslit : f a / f a ∈ Complex.slitPlane := by simp [hfa]
+  exact analyticAt_const.mul (hratio.clog hslit)
+
+private theorem RiemannMapping.hasDerivAt_boundaryLog {f : ℂ → ℂ} {a d : ℂ} (hf : HasDerivAt f d a)
+    (hfa : f a ≠ 0) : HasDerivAt (boundaryLog f a) (-Complex.I * (d / f a)) a := by
+  have hslit : f a / f a ∈ Complex.slitPlane := by simp [hfa]
+  have hlog := (hf.div_const (f a)).clog hslit
+  change HasDerivAt (fun z => -Complex.I * Complex.log (f z / f a)) (-Complex.I * (d / f a)) a
+  simpa only [div_self hfa, div_one] using hlog.const_mul (-Complex.I)
+
+private theorem
+    RiemannMapping.im_boundaryLog_pos {f : ℂ → ℂ} {a z : ℂ} (hfa : ‖f a‖ = 1) (hfz : f z ≠ 0)
+    (hz : ‖f z‖ < 1) : 0 < (boundaryLog f a z).im := by
+  have hfa0 : f a ≠ 0 := by
+    intro hzero
+    simp [hzero] at hfa
+  have hratio0 : 0 < ‖f z / f a‖ := norm_pos_iff.mpr (div_ne_zero hfz hfa0)
+  have hratio1 : ‖f z / f a‖ < 1 := by simpa only [norm_div, hfa, div_one] using hz
+  have hlog := Real.log_neg hratio0 hratio1
+  simpa [boundaryLog, Complex.mul_im, Complex.log_re] using neg_pos.mpr hlog
+
+private theorem RiemannMapping.deriv_ne_zero_of_upper_halfPlane_to_unitDisc {f : ℂ → ℂ} {a : ℂ}
+    (hf : AnalyticAt ℂ f a) (ha : a.im = 0) (hfa : ‖f a‖ = 1)
+    (hupper : ∀ᶠ z in 𝓝 a, 0 < z.im → ‖f z‖ < 1) : deriv f a ≠ 0 := by
+  have hfa0 : f a ≠ 0 := by
+    intro hzero
+    simp [hzero] at hfa
+  have hnz : ∀ᶠ z in 𝓝 a, f z ≠ 0 := hf.continuousAt.eventually_ne hfa0
+  have hlogUpper : ∀ᶠ z in 𝓝 a, 0 < z.im → 0 < (boundaryLog f a z).im := by
+    filter_upwards [hupper, hnz] with z hz hzne hzim
+    exact im_boundaryLog_pos hfa hzne (hz hzim)
+  have hlogDeriv :=
+    deriv_ne_zero_of_upper_halfPlane (analyticAt_boundaryLog hf hfa0) ha (boundaryLog_self hfa0)
+      hlogUpper
+  intro hderiv
+  apply hlogDeriv
+  simpa [hderiv] using (hasDerivAt_boundaryLog hf.differentiableAt.hasDerivAt hfa0).deriv
+
+private def RiemannMapping.triangleMap : ℂ → ℂ :=
+  riemannMap triangleDomain SpecialPeriods.Triangle.triangleInterior_isSimplyConnected
+    SpecialPeriods.Triangle.triangleInterior_ne_univ trianglePoint
+
+private theorem RiemannMapping.triangleMap_differentiable :
+    DifferentiableOn ℂ triangleMap SpecialPeriods.Triangle.triangleInterior :=
+  (riemannMap_spec triangleDomain SpecialPeriods.Triangle.triangleInterior_isSimplyConnected
+      SpecialPeriods.Triangle.triangleInterior_ne_univ trianglePoint).1
+
+private theorem RiemannMapping.triangleMap_bijOn :
+    Set.BijOn triangleMap SpecialPeriods.Triangle.triangleInterior (Metric.ball (0 : ℂ) 1) :=
+  (riemannMap_spec triangleDomain SpecialPeriods.Triangle.triangleInterior_isSimplyConnected
+        SpecialPeriods.Triangle.triangleInterior_ne_univ trianglePoint).2.1
+
+private theorem RiemannMapping.triangleMap_biholomorph (z : triangleDomain) :
+    triangleMap z = (triangleBiholomorph z : ℂ) :=
+  rfl
+
+private theorem RiemannMapping.triangleMap_norm_lt_one {z : ℂ}
+    (hz : z ∈ SpecialPeriods.Triangle.triangleInterior) : ‖triangleMap z‖ < 1 := by
+  simpa using triangleMap_bijOn.mapsTo hz
+
+private theorem
+    RiemannMapping.exists_boundary_chart_target_ball (e : OpenPartialHomeomorph ℂ ℂ) {a : ℂ}
+    (ha : a ∈ e.source) {r : ℝ} (hr : 0 < r) :
+    ∃ δ > 0, ∀ w ∈ Metric.ball (e a) δ, w ∈ e.target ∧ e.symm w ∈ Metric.ball a r := by
+  have hat := e.map_source ha
+  have hinv : Filter.Tendsto e.symm (𝓝 (e a)) (𝓝 a) := by
+    have h := (e.continuousOn_symm.continuousAt (e.open_target.mem_nhds hat)).tendsto
+    rwa [e.left_inv ha] at h
+  have hnear : ∀ᶠ w in 𝓝 (e a), w ∈ e.target ∧ e.symm w ∈ Metric.ball a r := by
+    filter_upwards [e.open_target.mem_nhds hat, hinv.eventually (Metric.ball_mem_nhds a hr)] with
+      w hw hb
+    exact ⟨hw, hb⟩
+  exact Metric.mem_nhds_iff.mp hnear
+
+private theorem SpecialPeriods.Triangle.cayley_re_sub (a z : ℂ) (hz : 1 - z ≠ 0) :
+    (SpecialPeriods.cayley a z).re - a.re = -2 * a.im * z.im / Complex.normSq (1 - z) := by
+  have hd : Complex.normSq (1 - z) ≠ 0 := (Complex.normSq_pos.mpr hz).ne'
+  simp only [SpecialPeriods.cayley, Complex.div_re, Complex.sub_re, Complex.mul_re,
+    Complex.conj_re, Complex.conj_im, Complex.sub_im, Complex.mul_im, Complex.one_re,
+    Complex.one_im]
+  field_simp [hd]
+  simp only [Complex.normSq_apply, Complex.sub_re, Complex.sub_im, Complex.one_re, Complex.one_im]
+  ring
+
+private theorem SpecialPeriods.Triangle.cayley_add_one (a z : ℂ) (hz : 1 - z ≠ 0) :
+    SpecialPeriods.cayley a z + 1 = ((a + 1) - conj (a + 1) * z) / (1 - z) := by
+  unfold SpecialPeriods.cayley
+  simp only [map_add, map_one]
+  field_simp
+  ring
+
+private theorem SpecialPeriods.Triangle.cayley_circle_normSq (a z : ℂ) (hz : 1 - z ≠ 0)
+    (ha : Complex.normSq (a + 1) = 1) :
+    Complex.normSq (SpecialPeriods.cayley a z + 1) - 1 =
+      (2 * z.re - 2 * ((a + 1) ^ 2 * conj z).re) / Complex.normSq (1 - z) := by
+  have hd : Complex.normSq (1 - z) ≠ 0 := (Complex.normSq_pos.mpr hz).ne'
+  rw [cayley_add_one a z hz, map_div₀]
+  field_simp [hd]
+  simp only [Complex.normSq_apply, Complex.sub_re, Complex.sub_im, Complex.mul_re, Complex.mul_im,
+    Complex.conj_re, Complex.conj_im, Complex.add_re, Complex.add_im, Complex.one_re,
+    Complex.one_im, add_zero, pow_two] at ha ⊢
+  linear_combination (1 + z.re ^ 2 + z.im ^ 2) * ha
+
+private theorem SpecialPeriods.Triangle.centerOne_re : centerOne.re = -1 / 2 := by
+  simp only [UpperHalfPlane.re, centerOne_val, Complex.sub_re, SpecialPeriods.rho_re,
+    Complex.one_re]
+  norm_num
+
+private theorem SpecialPeriods.Triangle.centerOne_circle_normSq :
+    Complex.normSq ((centerOne : ℂ) + 1) = 1 := by
+  rw [centerOne_val, sub_add_cancel, Complex.normSq_eq_norm_sq, SpecialPeriods.norm_rho]
+  norm_num
+
+private theorem SpecialPeriods.Triangle.centerTwo_circle_normSq :
+    Complex.normSq ((centerTwo : ℂ) + 1) = 1 := by
+  simp only [Complex.normSq_apply, Complex.add_re, Complex.add_im, Complex.one_re, Complex.one_im,
+    add_zero, UpperHalfPlane.coe_re, UpperHalfPlane.coe_im, centerTwo_re, centerTwo_im]
+  nlinarith [width_sq]
+
+private theorem SpecialPeriods.Triangle.cayley_centerOne_circle_normSq {z : ℂ} (hz : ‖z‖ < 1) :
+    Complex.normSq (SpecialPeriods.cayley centerOne z + 1) - 1 =
+      (3 * z.re - Real.sqrt 3 * z.im) / Complex.normSq (1 - z) := by
+  rw [cayley_circle_normSq _ _ (SpecialPeriods.one_sub_ne_zero_of_norm_lt_one hz)
+      centerOne_circle_normSq]
+  congr 1
+  simp only [centerOne_val, sub_add_cancel, SpecialPeriods.rho_sq, Complex.mul_re, Complex.sub_re,
+    Complex.sub_im, Complex.conj_re, Complex.conj_im, Complex.one_re, Complex.one_im, sub_zero,
+    SpecialPeriods.rho_re, SpecialPeriods.rho_im]
+  ring
+
+private theorem SpecialPeriods.Triangle.cayley_centerTwo_circle_normSq {z : ℂ} (hz : ‖z‖ < 1) :
+    Complex.normSq (SpecialPeriods.cayley centerTwo z + 1) - 1 =
+      2 * (z.re + z.im) / Complex.normSq (1 - z) := by
+  rw [cayley_circle_normSq _ _ (SpecialPeriods.one_sub_ne_zero_of_norm_lt_one hz)
+      centerTwo_circle_normSq]
+  congr 1
+  simp only [pow_two, Complex.mul_re, Complex.mul_im, Complex.add_re, Complex.add_im,
+    Complex.one_re, Complex.one_im, add_zero, Complex.conj_re, Complex.conj_im,
+    UpperHalfPlane.coe_re, UpperHalfPlane.coe_im, centerTwo_re, centerTwo_im]
+  linear_combination z.im * width_sq
+
+private def SpecialPeriods.Triangle.cornerSectorThree : Set ℂ :=
+  {z | 0 < z.im ∧ Real.sqrt 3 * z.im < 3 * z.re}
+
+private def SpecialPeriods.Triangle.cornerSectorFour : Set ℂ :=
+  {z | z.im < 0 ∧ 0 < z.re + z.im}
+
+private theorem SpecialPeriods.Triangle.cayley_centerOne_right_iff {z : ℂ} (hz : ‖z‖ < 1) :
+    (SpecialPeriods.cayley centerOne z).re < -1 / 2 ↔ 0 < z.im := by
+  have h := cayley_re_sub centerOne z (SpecialPeriods.one_sub_ne_zero_of_norm_lt_one hz)
+  rw [UpperHalfPlane.coe_re, centerOne_re] at h
+  have hd := Complex.normSq_pos.mpr (SpecialPeriods.one_sub_ne_zero_of_norm_lt_one hz)
+  have hc : 0 < (centerOne : ℂ).im := centerOne.im_pos
+  have hsign : -2 * (centerOne : ℂ).im * z.im / Complex.normSq (1 - z) < 0 ↔ 0 < z.im := by
+    rw [div_lt_iff₀ hd, MulZeroClass.zero_mul]
+    constructor
+    · intro hi
+      by_contra hn
+      have hle : z.im ≤ 0 := le_of_not_gt hn
+      have hnonneg : 0 ≤ -2 * (centerOne : ℂ).im * z.im :=
+        mul_nonneg_of_nonpos_of_nonpos (by linarith) hle
+      linarith
+    · intro hi
+      exact mul_neg_of_neg_of_pos (by linarith) hi
+  rw [← h, sub_neg] at hsign
+  exact hsign
+
+private theorem SpecialPeriods.Triangle.cayley_centerTwo_left_iff {z : ℂ} (hz : ‖z‖ < 1) :
+    stripLeft < (SpecialPeriods.cayley centerTwo z).re ↔ z.im < 0 := by
+  have h := cayley_re_sub centerTwo z (SpecialPeriods.one_sub_ne_zero_of_norm_lt_one hz)
+  rw [UpperHalfPlane.coe_re, centerTwo_re] at h
+  change (SpecialPeriods.cayley centerTwo z).re - stripLeft = _ at h
+  have hd := Complex.normSq_pos.mpr (SpecialPeriods.one_sub_ne_zero_of_norm_lt_one hz)
+  have hc : 0 < (centerTwo : ℂ).im := centerTwo.im_pos
+  have hsign : 0 < -2 * (centerTwo : ℂ).im * z.im / Complex.normSq (1 - z) ↔ z.im < 0 := by
+    rw [div_pos_iff_of_pos_right hd]
+    constructor
+    · intro hi
+      by_contra hn
+      have hle : 0 ≤ z.im := le_of_not_gt hn
+      have hnonpos : -2 * (centerTwo : ℂ).im * z.im ≤ 0 :=
+        mul_nonpos_of_nonpos_of_nonneg (by linarith) hle
+      linarith
+    · intro hi
+      exact mul_pos_of_neg_of_neg (by linarith) hi
+  rw [← h, sub_pos] at hsign
+  exact hsign
+
+private theorem SpecialPeriods.Triangle.one_lt_norm_iff_normSq_sub_pos (u : ℂ) :
+    1 < ‖u‖ ↔ 0 < Complex.normSq u - 1 := by
+  rw [Complex.normSq_eq_norm_sq]
+  constructor <;> intro h <;> nlinarith [norm_nonneg u]
+
+private theorem SpecialPeriods.Triangle.cayley_centerOne_circle_iff {z : ℂ} (hz : ‖z‖ < 1) :
+    1 < ‖SpecialPeriods.cayley centerOne z + 1‖ ↔ Real.sqrt 3 * z.im < 3 * z.re := by
+  rw [one_lt_norm_iff_normSq_sub_pos, cayley_centerOne_circle_normSq hz,
+    div_pos_iff_of_pos_right
+      (Complex.normSq_pos.mpr (SpecialPeriods.one_sub_ne_zero_of_norm_lt_one hz)),
+    sub_pos]
+
+private theorem SpecialPeriods.Triangle.cayley_centerTwo_circle_iff {z : ℂ} (hz : ‖z‖ < 1) :
+    1 < ‖SpecialPeriods.cayley centerTwo z + 1‖ ↔ 0 < z.re + z.im := by
+  rw [one_lt_norm_iff_normSq_sub_pos, cayley_centerTwo_circle_normSq hz,
+    div_pos_iff_of_pos_right
+      (Complex.normSq_pos.mpr (SpecialPeriods.one_sub_ne_zero_of_norm_lt_one hz))]
+  exact mul_pos_iff_of_pos_left (by norm_num : (0 : ℝ) < 2)
+
+private theorem SpecialPeriods.Triangle.cayley_analyticAt (a : ℂ) {z : ℂ} (hz : 1 - z ≠ 0) :
+    AnalyticAt ℂ (SpecialPeriods.cayley a) z :=
+  (analyticAt_const.sub (analyticAt_const.mul analyticAt_id)).div
+    (analyticAt_const.sub analyticAt_id) hz
+
+private theorem SpecialPeriods.Triangle.exists_cornerThree_radius :
+    ∃ r : ℝ,
+      0 < r ∧
+        r ≤ 1 ∧
+          ∀ z : ℂ,
+            ‖z‖ < r →
+              (SpecialPeriods.cayley centerOne z ∈ triangleInterior ↔ z ∈ cornerSectorThree) := by
+  have hc : ContinuousAt (fun z : ℂ => (SpecialPeriods.cayley centerOne z).re) 0 :=
+    Complex.continuous_re.continuousAt.comp
+      (cayley_analyticAt centerOne (z := 0) (by simp)).continuousAt
+  have hleft : ∀ᶠ z : ℂ in 𝓝 0, stripLeft < (SpecialPeriods.cayley centerOne z).re :=
+    continuousAt_const.eventually_lt hc
+      (by
+        simp only [SpecialPeriods.cayley_zero, UpperHalfPlane.coe_re, centerOne_re]
+        unfold stripLeft
+        linarith [width_pos])
+  obtain ⟨s, hs, hball⟩ := Metric.mem_nhds_iff.mp hleft
+  refine ⟨Min.min s 1, lt_min hs zero_lt_one, min_le_right _ _, ?_⟩
+  intro z hz
+  have hz1 : ‖z‖ < 1 := hz.trans_le (min_le_right _ _)
+  have hzs : z ∈ Metric.ball 0 s := by simpa using hz.trans_le (min_le_left _ _)
+  have hzi := SpecialPeriods.cayley_im_pos centerOne.im_pos hz1
+  change
+    (stripLeft < (SpecialPeriods.cayley centerOne z).re ∧
+        (SpecialPeriods.cayley centerOne z).re < -1 / 2 ∧
+          0 < (SpecialPeriods.cayley centerOne z).im ∧
+            1 < ‖SpecialPeriods.cayley centerOne z + 1‖) ↔
+      _
+  rw [cayley_centerOne_right_iff hz1, cayley_centerOne_circle_iff hz1]
+  exact ⟨fun h => ⟨h.2.1, h.2.2.2⟩, fun h => ⟨hball hzs, h.1, hzi, h.2⟩⟩
+
+private theorem SpecialPeriods.Triangle.exists_cornerFour_radius :
+    ∃ r : ℝ,
+      0 < r ∧
+        r ≤ 1 ∧
+          ∀ z : ℂ,
+            ‖z‖ < r →
+              (SpecialPeriods.cayley centerTwo z ∈ triangleInterior ↔ z ∈ cornerSectorFour) := by
+  have hc : ContinuousAt (fun z : ℂ => (SpecialPeriods.cayley centerTwo z).re) 0 :=
+    Complex.continuous_re.continuousAt.comp
+      (cayley_analyticAt centerTwo (z := 0) (by simp)).continuousAt
+  have hright : ∀ᶠ z : ℂ in 𝓝 0, (SpecialPeriods.cayley centerTwo z).re < -1 / 2 :=
+    hc.eventually_lt continuousAt_const
+      (by
+        simp only [SpecialPeriods.cayley_zero, UpperHalfPlane.coe_re, centerTwo_re]
+        linarith [width_pos])
+  obtain ⟨s, hs, hball⟩ := Metric.mem_nhds_iff.mp hright
+  refine ⟨Min.min s 1, lt_min hs zero_lt_one, min_le_right _ _, ?_⟩
+  intro z hz
+  have hz1 : ‖z‖ < 1 := hz.trans_le (min_le_right _ _)
+  have hzs : z ∈ Metric.ball 0 s := by simpa using hz.trans_le (min_le_left _ _)
+  have hzi := SpecialPeriods.cayley_im_pos centerTwo.im_pos hz1
+  change
+    (stripLeft < (SpecialPeriods.cayley centerTwo z).re ∧
+        (SpecialPeriods.cayley centerTwo z).re < -1 / 2 ∧
+          0 < (SpecialPeriods.cayley centerTwo z).im ∧
+            1 < ‖SpecialPeriods.cayley centerTwo z + 1‖) ↔
+      _
+  rw [cayley_centerTwo_left_iff hz1, cayley_centerTwo_circle_iff hz1]
+  exact ⟨fun h => ⟨h.1, h.2.2.2⟩, fun h => ⟨h.1, hball hzs, hzi, h.2⟩⟩
+
+private def RiemannBoundary.principalRoot (n : ℕ) (z : ℂ) : ℂ :=
+  z ^ ((n : ℂ)⁻¹)
+
+@[simp]
+private theorem RiemannBoundary.principalRoot_pow {n : ℕ} (hn : 0 < n) (z : ℂ) :
+    principalRoot n z ^ n = z :=
+  Complex.cpow_nat_inv_pow z hn.ne'
+
+@[simp]
+private theorem
+    RiemannBoundary.principalRoot_zero {n : ℕ} (hn : 0 < n) : principalRoot n 0 = 0 := by
+  exact Complex.zero_cpow (inv_ne_zero (Nat.cast_ne_zero.mpr hn.ne'))
+
+private theorem RiemannBoundary.principalRoot_injective {n : ℕ} (hn : 0 < n) :
+    Function.Injective (principalRoot n) := by
+  intro z w h
+  simpa only [principalRoot_pow hn] using congrArg (fun u : ℂ => u ^ n) h
+
+@[simp]
+private theorem RiemannBoundary.principalRoot_eq_zero_iff {n : ℕ} (hn : 0 < n) {z : ℂ} :
+    principalRoot n z = 0 ↔ z = 0 := by
+  have h : principalRoot n z = principalRoot n 0 ↔ z = 0 := (principalRoot_injective hn).eq_iff
+  simpa only [principalRoot_zero hn] using h
+
+@[simp]
+private theorem RiemannBoundary.norm_principalRoot (n : ℕ) (z : ℂ) :
+    ‖principalRoot n z‖ = ‖z‖ ^ ((n : ℝ)⁻¹) :=
+  Complex.norm_cpow_inv_nat z n
+
+private theorem RiemannBoundary.principalRoot_exponent_re_pos_mo1973_19407 {n : ℕ} (hn : 0 < n) :
+    0 < ((n : ℂ)⁻¹).re := by
+  simpa only [← Complex.ofReal_natCast, ← Complex.ofReal_inv, Complex.ofReal_re] using
+    inv_pos.mpr (Nat.cast_pos.mpr hn : (0 : ℝ) < n)
+
+private theorem RiemannBoundary.continuousAt_principalRoot_zero {n : ℕ} (hn : 0 < n) :
+    ContinuousAt (principalRoot n) 0 :=
+  Complex.continuousAt_cpow_const_of_re_pos (Or.inl (by simp))
+    (principalRoot_exponent_re_pos_mo1973_19407 hn)
+
+private theorem RiemannBoundary.continuousOn_principalRoot_closedUpper {n : ℕ} (hn : 0 < n) :
+    ContinuousOn (principalRoot n) {z : ℂ | 0 ≤ z.im} := by
+  intro z _hz
+  change ContinuousWithinAt (fun w : ℂ => w ^ ((n : ℂ)⁻¹)) _ z
+  by_cases h : 0 ≤ z.re ∨ z.im ≠ 0
+  · exact
+      (Complex.continuousAt_cpow_const_of_re_pos h
+          (principalRoot_exponent_re_pos_mo1973_19407 hn)).continuousWithinAt
+  push Not at h
+  have hz0 : z ≠ 0 := fun hz => by simpa only [hz, Complex.zero_re, lt_self_iff_false] using h.1
+  have hc :
+    ContinuousWithinAt (fun w : ℂ => Complex.exp (Complex.log w * (n : ℂ)⁻¹)) {w : ℂ | 0 ≤ w.im}
+      z :=
+    Complex.continuous_exp.continuousAt.comp_continuousWithinAt
+      ((Complex.continuousWithinAt_log_of_re_neg_of_im_zero h.1 h.2).mul_const _)
+  exact
+    hc.congr_of_eventuallyEq ((cpow_eq_nhds hz0).filter_mono nhdsWithin_le_nhds)
+      (Complex.cpow_def_of_ne_zero hz0 _)
+
+private theorem RiemannBoundary.differentiableOn_principalRoot_upper (n : ℕ) :
+    DifferentiableOn ℂ (principalRoot n) {z : ℂ | 0 < z.im} := by
+  intro z hz
+  exact
+    ((differentiableAt_id : DifferentiableAt ℂ (fun w : ℂ => w) z).cpow_const
+        (Or.inr (ne_of_gt hz))).differentiableWithinAt
+
+private theorem RiemannBoundary.analyticOnNhd_principalRoot_upper (n : ℕ) :
+    AnalyticOnNhd ℂ (principalRoot n) {z : ℂ | 0 < z.im} :=
+  (differentiableOn_principalRoot_upper n).analyticOnNhd
+    (isOpen_lt continuous_const Complex.continuous_im)
+
+private theorem RiemannBoundary.principalRoot_ofReal_nonneg (n : ℕ) {x : ℝ} (hx : 0 ≤ x) :
+    principalRoot n (x : ℂ) = (x ^ ((n : ℝ)⁻¹) : ℝ) := by
+  simpa only [principalRoot, Complex.ofReal_inv, Complex.ofReal_natCast] using
+    (Complex.ofReal_cpow hx ((n : ℝ)⁻¹)).symm
+
+private theorem RiemannBoundary.principalRoot_ofReal_nonpos (n : ℕ) {x : ℝ} (hx : x ≤ 0) :
+    principalRoot n (x : ℂ) =
+      ((-x) ^ ((n : ℝ)⁻¹) : ℝ) * Complex.exp ((Real.pi / (n : ℝ) : ℝ) * Complex.I) := by
+  rw [principalRoot, Complex.ofReal_cpow_of_nonpos hx]
+  have hr : (-(x : ℂ)) ^ ((n : ℂ)⁻¹) = ((-x) ^ ((n : ℝ)⁻¹) : ℝ) := by
+    simpa only [principalRoot, Complex.ofReal_neg] using
+      principalRoot_ofReal_nonneg n (neg_nonneg.mpr hx)
+  rw [hr]
+  congr 2
+  simp only [div_eq_mul_inv, Complex.ofReal_mul, Complex.ofReal_inv, Complex.ofReal_natCast]
+  ring
+
+private theorem RiemannBoundary.arg_div_nat_mem_Ioc_mo1973_19416 {n : ℕ} (hn : 0 < n) (z : ℂ) :
+    z.arg / (n : ℝ) ∈ Set.Ioc (-Real.pi) Real.pi := by
+  have hnR : (0 : ℝ) < n := Nat.cast_pos.mpr hn
+  have hn1 : (1 : ℝ) ≤ n := by exact_mod_cast hn
+  constructor
+  · rw [lt_div_iff₀ hnR]
+    have hl : -Real.pi * (n : ℝ) ≤ -Real.pi := by nlinarith [Real.pi_pos]
+    exact hl.trans_lt (Complex.neg_pi_lt_arg z)
+  · rw [div_le_iff₀ hnR]
+    have hu : Real.pi ≤ Real.pi * (n : ℝ) := by nlinarith [Real.pi_pos]
+    exact (Complex.arg_le_pi z).trans hu
+
+private theorem RiemannBoundary.arg_principalRoot {n : ℕ} (hn : 0 < n) (z : ℂ) :
+    Complex.arg (principalRoot n z) = z.arg / (n : ℝ) := by
+  by_cases hz : z = 0
+  · simp only [hz, principalRoot_zero hn, Complex.arg_zero, zero_div]
+  have hpolar :
+    principalRoot n z =
+      (‖z‖ ^ ((n : ℝ)⁻¹) : ℝ) *
+        (Real.cos (z.arg / (n : ℝ)) + Real.sin (z.arg / (n : ℝ)) * Complex.I) := by
+    simpa only [principalRoot, Complex.ofReal_inv, Complex.ofReal_natCast, div_eq_mul_inv] using
+      Complex.cpow_ofReal z ((n : ℝ)⁻¹)
+  rw [hpolar]
+  simpa only [Complex.ofReal_cos, Complex.ofReal_sin] using
+    Complex.arg_mul_cos_add_sin_mul_I (Real.rpow_pos_of_pos (norm_pos_iff.mpr hz) ((n : ℝ)⁻¹))
+      (arg_div_nat_mem_Ioc_mo1973_19416 hn z)
+
+private theorem
+    RiemannBoundary.principalRoot_arg_mem_Ioo {n : ℕ} (hn : 0 < n) {z : ℂ} (hz : 0 < z.im) :
+    Complex.arg (principalRoot n z) ∈ Set.Ioo 0 (Real.pi / (n : ℝ)) := by
+  rw [arg_principalRoot hn]
+  have harg0 : z.arg ≠ 0 := fun h => (ne_of_gt hz) (Complex.arg_eq_zero_iff.mp h).2
+  have harg : 0 < z.arg := lt_of_le_of_ne (Complex.arg_nonneg_iff.mpr hz.le) harg0.symm
+  exact
+    ⟨div_pos harg (Nat.cast_pos.mpr hn),
+      (div_lt_div_iff_of_pos_right (Nat.cast_pos.mpr hn)).mpr
+        (Complex.arg_lt_pi_iff.mpr (Or.inr (ne_of_gt hz)))⟩
+
+private theorem RiemannBoundary.principalRoot_pow_of_sector {n : ℕ} (hn : 0 < n) {z : ℂ}
+    (hz : z.arg ∈ Set.Icc 0 (Real.pi / (n : ℝ))) : principalRoot n (z ^ n) = z := by
+  apply Complex.pow_cpow_nat_inv hn.ne' _ hz.2
+  exact (neg_neg_of_pos (div_pos Real.pi_pos (Nat.cast_pos.mpr hn))).trans_le hz.1
+
+private theorem RiemannBoundary.cubic_sector_slack_mo1973_19421 (w : ℂ) :
+    3 * w.re - Real.sqrt 3 * w.im = (2 * Real.sqrt 3 * ‖w‖) * Real.sin (Real.pi / 3 - w.arg) := by
+  rw [Real.sin_sub, Real.sin_pi_div_three, Real.cos_pi_div_three]
+  rw [← Complex.norm_mul_cos_arg w, ← Complex.norm_mul_sin_arg w]
+  calc
+    3 * (‖w‖ * Real.cos w.arg) - Real.sqrt 3 * (‖w‖ * Real.sin w.arg) =
+        ‖w‖ * ((Real.sqrt 3 * Real.sqrt 3) * Real.cos w.arg - Real.sqrt 3 * Real.sin w.arg) := by
+      rw [Real.mul_self_sqrt (by norm_num : (0 : ℝ) ≤ 3)]
+      ring
+    _ = _ := by ring
+
+private theorem RiemannBoundary.quartic_sector_slack_mo1973_19422 (w : ℂ) :
+    w.re - w.im = (Real.sqrt 2 * ‖w‖) * Real.sin (Real.pi / 4 - w.arg) := by
+  rw [Real.sin_sub, Real.sin_pi_div_four, Real.cos_pi_div_four]
+  rw [← Complex.norm_mul_cos_arg w, ← Complex.norm_mul_sin_arg w]
+  calc
+    ‖w‖ * Real.cos w.arg - ‖w‖ * Real.sin w.arg =
+        (‖w‖ / 2) *
+          ((Real.sqrt 2 * Real.sqrt 2) * Real.cos w.arg -
+            (Real.sqrt 2 * Real.sqrt 2) * Real.sin w.arg) := by
+      rw [Real.mul_self_sqrt (by norm_num : (0 : ℝ) ≤ 2)]
+      ring
+    _ = _ := by ring
+
+private theorem RiemannBoundary.principalRoot_three_upper {z : ℂ} (hz : 0 < z.im) :
+    0 < (principalRoot 3 z).im ∧
+      Real.sqrt 3 * (principalRoot 3 z).im < 3 * (principalRoot 3 z).re := by
+  have ha := principalRoot_arg_mem_Ioo (by norm_num : 0 < 3) hz
+  norm_num only [Nat.cast_ofNat] at ha
+  have hw : principalRoot 3 z ≠ 0 := by
+    rw [ne_eq, principalRoot_eq_zero_iff (by norm_num : 0 < 3)]
+    exact fun h => by simp only [h, Complex.zero_im, lt_self_iff_false] at hz
+  constructor
+  · rw [← Complex.norm_mul_sin_arg]
+    exact
+      mul_pos (norm_pos_iff.mpr hw)
+        (Real.sin_pos_of_pos_of_lt_pi ha.1 (by linarith [Real.pi_pos, ha.2]))
+  · apply sub_pos.mp
+    rw [cubic_sector_slack_mo1973_19421]
+    exact
+      mul_pos
+        (mul_pos (mul_pos (by norm_num) (Real.sqrt_pos.mpr (by norm_num))) (norm_pos_iff.mpr hw))
+        (Real.sin_pos_of_pos_of_lt_pi (by linarith [ha.2]) (by linarith [Real.pi_pos, ha.1]))
+
+private theorem RiemannBoundary.principalRoot_three_ofReal_nonneg_im {x : ℝ} (hx : 0 ≤ x) :
+    (principalRoot 3 (x : ℂ)).im = 0 := by
+  rw [principalRoot_ofReal_nonneg 3 hx]
+  exact Complex.ofReal_im _
+
+private theorem RiemannBoundary.principalRoot_three_ofReal_nonpos_boundary {x : ℝ} (hx : x ≤ 0) :
+    Real.sqrt 3 * (principalRoot 3 (x : ℂ)).im = 3 * (principalRoot 3 (x : ℂ)).re := by
+  rw [principalRoot_ofReal_nonpos 3 hx]
+  simp only [Complex.mul_im, Complex.mul_re, Complex.ofReal_re, Complex.ofReal_im,
+    MulZeroClass.zero_mul, add_zero, sub_zero, Complex.exp_ofReal_mul_I_im,
+    Complex.exp_ofReal_mul_I_re, Nat.cast_ofNat, Real.sin_pi_div_three, Real.cos_pi_div_three]
+  have hsq := Real.mul_self_sqrt (by norm_num : (0 : ℝ) ≤ 3)
+  calc
+    Real.sqrt 3 * ((-x) ^ (3 : ℝ)⁻¹ * (Real.sqrt 3 / 2)) =
+        (Real.sqrt 3 * Real.sqrt 3) * ((-x) ^ (3 : ℝ)⁻¹ / 2) := by ring
+    _ = _ := by rw [hsq]; ring
+
+private theorem RiemannBoundary.principalRoot_three_real_boundary {z : ℂ} (hz : z.im = 0) :
+    (principalRoot 3 z).im = 0 ∨
+      Real.sqrt 3 * (principalRoot 3 z).im = 3 * (principalRoot 3 z).re := by
+  have he : z = (z.re : ℂ) := by apply Complex.ext <;> simp [hz]
+  rw [he]
+  rcases le_total 0 z.re with hp | hn
+  · exact Or.inl (principalRoot_three_ofReal_nonneg_im hp)
+  · exact Or.inr (principalRoot_three_ofReal_nonpos_boundary hn)
+
+private def RiemannBoundary.quarticRootRotation : ℂ :=
+  Complex.exp (((-Real.pi / 4 : ℝ) : ℂ) * Complex.I)
+
+@[simp]
+private theorem
+    RiemannBoundary.quarticRootRotation_re : quarticRootRotation.re = Real.sqrt 2 / 2 := by
+  simp only [quarticRootRotation, Complex.exp_ofReal_mul_I_re, neg_div, Real.cos_neg,
+    Real.cos_pi_div_four]
+
+@[simp]
+private theorem
+    RiemannBoundary.quarticRootRotation_im : quarticRootRotation.im = -(Real.sqrt 2 / 2) := by
+  simp only [quarticRootRotation, Complex.exp_ofReal_mul_I_im, neg_div, Real.sin_neg,
+    Real.sin_pi_div_four]
+
+@[simp]
+private theorem RiemannBoundary.norm_quarticRootRotation : ‖quarticRootRotation‖ = 1 :=
+  Complex.norm_exp_ofReal_mul_I _
+
+private theorem RiemannBoundary.quarticRootRotation_ne_zero : quarticRootRotation ≠ 0 :=
+  Complex.exp_ne_zero _
+
+@[simp]
+private theorem RiemannBoundary.quarticRootRotation_pow_four : quarticRootRotation ^ 4 = -1 := by
+  rw [quarticRootRotation, ← Complex.exp_nat_mul]
+  norm_num only [Nat.cast_ofNat]
+  have he : (4 : ℂ) * (((-Real.pi / 4 : ℝ) : ℂ) * Complex.I) = -(Real.pi * Complex.I) := by
+    push_cast
+    ring
+  rw [he, Complex.exp_neg, Complex.exp_pi_mul_I]
+  norm_num
+
+private def RiemannBoundary.rotatedPrincipalRootFour (z : ℂ) : ℂ :=
+  quarticRootRotation * principalRoot 4 z
+
+@[simp]
+private theorem RiemannBoundary.rotatedPrincipalRootFour_pow (z : ℂ) :
+    rotatedPrincipalRootFour z ^ 4 = -z := by
+  rw [rotatedPrincipalRootFour, mul_pow, quarticRootRotation_pow_four,
+    principalRoot_pow (by norm_num : 0 < 4)]
+  ring
+
+@[simp]
+private theorem RiemannBoundary.rotatedPrincipalRootFour_zero : rotatedPrincipalRootFour 0 = 0 := by
+  rw [rotatedPrincipalRootFour, principalRoot_zero (by norm_num : 0 < 4), MulZeroClass.mul_zero]
+
+@[simp]
+private theorem RiemannBoundary.norm_rotatedPrincipalRootFour (z : ℂ) :
+    ‖rotatedPrincipalRootFour z‖ = ‖z‖ ^ (4 : ℝ)⁻¹ := by
+  rw [rotatedPrincipalRootFour, norm_mul, norm_quarticRootRotation, one_mul, norm_principalRoot]
+  norm_num only [Nat.cast_ofNat]
+
+private theorem RiemannBoundary.rotatedPrincipalRootFour_re (z : ℂ) :
+    (rotatedPrincipalRootFour z).re =
+      (Real.sqrt 2 / 2) * ((principalRoot 4 z).re + (principalRoot 4 z).im) := by
+  simp only [rotatedPrincipalRootFour, Complex.mul_re, quarticRootRotation_re,
+    quarticRootRotation_im]
+  ring
+
+private theorem RiemannBoundary.rotatedPrincipalRootFour_im (z : ℂ) :
+    (rotatedPrincipalRootFour z).im =
+      (Real.sqrt 2 / 2) * ((principalRoot 4 z).im - (principalRoot 4 z).re) := by
+  simp only [rotatedPrincipalRootFour, Complex.mul_im, quarticRootRotation_re,
+    quarticRootRotation_im]
+  ring
+
+private theorem RiemannBoundary.rotatedPrincipalRootFour_re_add_im (z : ℂ) :
+    (rotatedPrincipalRootFour z).re + (rotatedPrincipalRootFour z).im =
+      Real.sqrt 2 * (principalRoot 4 z).im := by
+  rw [rotatedPrincipalRootFour_re, rotatedPrincipalRootFour_im]
+  ring
+
+private theorem RiemannBoundary.rotatedPrincipalRootFour_upper {z : ℂ} (hz : 0 < z.im) :
+    (rotatedPrincipalRootFour z).im < 0 ∧
+      0 < (rotatedPrincipalRootFour z).re + (rotatedPrincipalRootFour z).im := by
+  have ha := principalRoot_arg_mem_Ioo (by norm_num : 0 < 4) hz
+  norm_num only [Nat.cast_ofNat] at ha
+  have hw : principalRoot 4 z ≠ 0 := by
+    rw [ne_eq, principalRoot_eq_zero_iff (by norm_num : 0 < 4)]
+    exact fun h => by simp only [h, Complex.zero_im, lt_self_iff_false] at hz
+  have hi : 0 < (principalRoot 4 z).im := by
+    rw [← Complex.norm_mul_sin_arg]
+    exact
+      mul_pos (norm_pos_iff.mpr hw)
+        (Real.sin_pos_of_pos_of_lt_pi ha.1 (by linarith [Real.pi_pos, ha.2]))
+  have hri : (principalRoot 4 z).im < (principalRoot 4 z).re := by
+    apply sub_pos.mp
+    rw [quartic_sector_slack_mo1973_19422]
+    exact
+      mul_pos (mul_pos (Real.sqrt_pos.mpr (by norm_num)) (norm_pos_iff.mpr hw))
+        (Real.sin_pos_of_pos_of_lt_pi (by linarith [ha.2]) (by linarith [Real.pi_pos, ha.1]))
+  constructor
+  · rw [rotatedPrincipalRootFour_im]
+    exact mul_neg_of_pos_of_neg (by positivity) (sub_neg.mpr hri)
+  · rw [rotatedPrincipalRootFour_re_add_im]
+    exact mul_pos (Real.sqrt_pos.mpr (by norm_num)) hi
+
+private theorem
+    RiemannBoundary.rotatedPrincipalRootFour_ofReal_nonneg_boundary {x : ℝ} (hx : 0 ≤ x) :
+    (rotatedPrincipalRootFour (x : ℂ)).re + (rotatedPrincipalRootFour (x : ℂ)).im = 0 := by
+  rw [rotatedPrincipalRootFour_re_add_im, principalRoot_ofReal_nonneg 4 hx]
+  simp only [Complex.ofReal_im, MulZeroClass.mul_zero]
+
+private theorem RiemannBoundary.rotatedPrincipalRootFour_ofReal_nonpos_im {x : ℝ} (hx : x ≤ 0) :
+    (rotatedPrincipalRootFour (x : ℂ)).im = 0 := by
+  rw [rotatedPrincipalRootFour_im, principalRoot_ofReal_nonpos 4 hx]
+  simp only [Complex.mul_im, Complex.mul_re, Complex.ofReal_re, Complex.ofReal_im,
+    MulZeroClass.zero_mul, add_zero, sub_zero, Complex.exp_ofReal_mul_I_im,
+    Complex.exp_ofReal_mul_I_re, Nat.cast_ofNat, Real.sin_pi_div_four, Real.cos_pi_div_four,
+    sub_self, MulZeroClass.mul_zero]
+
+private theorem RiemannBoundary.rotatedPrincipalRootFour_real_boundary {z : ℂ} (hz : z.im = 0) :
+    (rotatedPrincipalRootFour z).im = 0 ∨
+      (rotatedPrincipalRootFour z).re + (rotatedPrincipalRootFour z).im = 0 := by
+  have he : z = (z.re : ℂ) := by apply Complex.ext <;> simp [hz]
+  rw [he]
+  rcases le_total 0 z.re with hp | hn
+  · exact Or.inr (rotatedPrincipalRootFour_ofReal_nonneg_boundary hp)
+  · exact Or.inl (rotatedPrincipalRootFour_ofReal_nonpos_im hn)
+
+private theorem RiemannBoundary.continuousOn_rotatedPrincipalRootFour_closedUpper :
+    ContinuousOn rotatedPrincipalRootFour {z : ℂ | 0 ≤ z.im} :=
+  continuousOn_const.mul (continuousOn_principalRoot_closedUpper (by norm_num : 0 < 4))
+
+private theorem RiemannBoundary.continuousAt_rotatedPrincipalRootFour_zero :
+    ContinuousAt rotatedPrincipalRootFour 0 :=
+  continuousAt_const.mul (continuousAt_principalRoot_zero (by norm_num : 0 < 4))
+
+private theorem RiemannBoundary.analyticOnNhd_rotatedPrincipalRootFour_upper :
+    AnalyticOnNhd ℂ rotatedPrincipalRootFour {z : ℂ | 0 < z.im} := by
+  intro z hz
+  exact analyticAt_const.mul (analyticOnNhd_principalRoot_upper 4 z hz)
+
+private def SpecialPeriods.Triangle.cornerParameterThree (w : ℂ) : ℂ :=
+  SpecialPeriods.cayley centerOne (RiemannBoundary.principalRoot 3 w)
+
+private def SpecialPeriods.Triangle.cornerParameterFour (w : ℂ) : ℂ :=
+  SpecialPeriods.cayley centerTwo (RiemannBoundary.rotatedPrincipalRootFour w)
+
+@[simp]
+private theorem
+    SpecialPeriods.Triangle.cornerParameterThree_zero : cornerParameterThree 0 = centerOne := by
+  simp [cornerParameterThree, RiemannBoundary.principalRoot_zero (by norm_num : 0 < 3)]
+
+@[simp]
+private theorem
+    SpecialPeriods.Triangle.cornerParameterFour_zero : cornerParameterFour 0 = centerTwo := by
+  simp [cornerParameterFour]
+
+private theorem SpecialPeriods.Triangle.continuousAt_cornerParameterThree_zero :
+    ContinuousAt cornerParameterThree 0 := by
+  have hc : ContinuousAt (SpecialPeriods.cayley (centerOne : ℂ)) 0 :=
+    (cayley_analyticAt centerOne (by simp)).continuousAt
+  have h0 : RiemannBoundary.principalRoot 3 (0 : ℂ) = 0 :=
+    RiemannBoundary.principalRoot_zero (by norm_num)
+  exact (h0 ▸ hc).comp (RiemannBoundary.continuousAt_principalRoot_zero (by norm_num : 0 < 3))
+
+private theorem SpecialPeriods.Triangle.continuousAt_cornerParameterFour_zero :
+    ContinuousAt cornerParameterFour 0 := by
+  have hc : ContinuousAt (SpecialPeriods.cayley (centerTwo : ℂ)) 0 :=
+    (cayley_analyticAt centerTwo (by simp)).continuousAt
+  exact
+    (RiemannBoundary.rotatedPrincipalRootFour_zero ▸ hc).comp
+      RiemannBoundary.continuousAt_rotatedPrincipalRootFour_zero
+
+private theorem SpecialPeriods.Triangle.cornerParameterThree_im_pos {w : ℂ}
+    (hw : ‖RiemannBoundary.principalRoot 3 w‖ < 1) : 0 < (cornerParameterThree w).im :=
+  SpecialPeriods.cayley_im_pos centerOne.im_pos hw
+
+private theorem SpecialPeriods.Triangle.cornerParameterFour_im_pos {w : ℂ}
+    (hw : ‖RiemannBoundary.rotatedPrincipalRootFour w‖ < 1) : 0 < (cornerParameterFour w).im :=
+  SpecialPeriods.cayley_im_pos centerTwo.im_pos hw
+
+private theorem SpecialPeriods.Triangle.cayley_coordinate_inverse (a : UpperHalfPlane) {z : ℂ}
+    (hz : ‖z‖ < 1) :
+    (SpecialPeriods.cayley a z - a) / (SpecialPeriods.cayley a z - conj (a : ℂ)) = z := by
+  have he :=
+    congrArg Subtype.val (toDisc_fromDisc a ⟨z, by simpa [SpecialPeriods.unitDisc] using hz⟩)
+  simpa only [toDisc_val, cayleyCoordinate, fromDisc_val] using he
+
+private theorem SpecialPeriods.Triangle.cornerParameterThree_power {w : ℂ}
+    (hw : ‖RiemannBoundary.principalRoot 3 w‖ < 1) :
+    ((cornerParameterThree w - centerOne) / (cornerParameterThree w - conj (centerOne : ℂ))) ^ 3 =
+      w := by
+  rw [cornerParameterThree, cayley_coordinate_inverse centerOne hw,
+    RiemannBoundary.principalRoot_pow (by norm_num : 0 < 3)]
+
+private theorem SpecialPeriods.Triangle.cornerParameterFour_power {w : ℂ}
+    (hw : ‖RiemannBoundary.rotatedPrincipalRootFour w‖ < 1) :
+    ((cornerParameterFour w - centerTwo) / (cornerParameterFour w - conj (centerTwo : ℂ))) ^ 4 =
+      -w := by
+  rw [cornerParameterFour, cayley_coordinate_inverse centerTwo hw,
+    RiemannBoundary.rotatedPrincipalRootFour_pow]
+
+private theorem SpecialPeriods.Triangle.exists_small_root_ball_mo1973_19462 {f : ℂ → ℂ}
+    (hf : ContinuousAt f 0) (hf0 : f 0 = 0) {r : ℝ} (hr : 0 < r) :
+    ∃ δ : ℝ, 0 < δ ∧ ∀ w ∈ Metric.ball (0 : ℂ) δ, ‖f w‖ < r := by
+  have hn : ∀ᶠ w in 𝓝 (0 : ℂ), ‖f w‖ < r :=
+    hf.norm.eventually_lt continuousAt_const (by simpa only [hf0, norm_zero] using hr)
+  exact Metric.mem_nhds_iff.mp hn
+
+private theorem SpecialPeriods.Triangle.cornerParameterThree_analyticOnNhd {U : Set ℂ}
+    (hU : ∀ w ∈ U, ‖RiemannBoundary.principalRoot 3 w‖ < 1) :
+    AnalyticOnNhd ℂ cornerParameterThree (U ∩ {w : ℂ | 0 < w.im}) := by
+  intro w hw
+  exact
+    (cayley_analyticAt centerOne (SpecialPeriods.one_sub_ne_zero_of_norm_lt_one (hU w hw.1))).comp
+      (RiemannBoundary.analyticOnNhd_principalRoot_upper 3 w hw.2)
+
+private theorem SpecialPeriods.Triangle.cornerParameterFour_analyticOnNhd {U : Set ℂ}
+    (hU : ∀ w ∈ U, ‖RiemannBoundary.rotatedPrincipalRootFour w‖ < 1) :
+    AnalyticOnNhd ℂ cornerParameterFour (U ∩ {w : ℂ | 0 < w.im}) := by
+  intro w hw
+  exact
+    (cayley_analyticAt centerTwo (SpecialPeriods.one_sub_ne_zero_of_norm_lt_one (hU w hw.1))).comp
+      (RiemannBoundary.analyticOnNhd_rotatedPrincipalRootFour_upper w hw.2)
+
+private theorem SpecialPeriods.Triangle.cornerParameterThree_continuousOn {U : Set ℂ}
+    (hU : ∀ w ∈ U, ‖RiemannBoundary.principalRoot 3 w‖ < 1) :
+    ContinuousOn cornerParameterThree (U ∩ {w : ℂ | 0 ≤ w.im}) := by
+  have hc := (SpecialPeriods.cayley_contDiffOn (centerOne : ℂ)).continuousOn
+  exact
+    hc.comp
+      ((RiemannBoundary.continuousOn_principalRoot_closedUpper (by norm_num : 0 < 3)).mono
+        (fun _ h => h.2))
+      (fun w hw => by simpa using hU w hw.1)
+
+private theorem SpecialPeriods.Triangle.cornerParameterFour_continuousOn {U : Set ℂ}
+    (hU : ∀ w ∈ U, ‖RiemannBoundary.rotatedPrincipalRootFour w‖ < 1) :
+    ContinuousOn cornerParameterFour (U ∩ {w : ℂ | 0 ≤ w.im}) := by
+  have hc := (SpecialPeriods.cayley_contDiffOn (centerTwo : ℂ)).continuousOn
+  exact
+    hc.comp
+      (RiemannBoundary.continuousOn_rotatedPrincipalRootFour_closedUpper.mono (fun _ h => h.2))
+      (fun w hw => by simpa using hU w hw.1)
+
+private theorem SpecialPeriods.Triangle.exists_cornerParameterThree_neighborhood :
+    ∃ δ : ℝ,
+      0 < δ ∧
+        AnalyticOnNhd ℂ cornerParameterThree (Metric.ball 0 δ ∩ {w : ℂ | 0 < w.im}) ∧
+          ContinuousOn cornerParameterThree (Metric.ball 0 δ ∩ {w : ℂ | 0 ≤ w.im}) ∧
+            Set.MapsTo cornerParameterThree (Metric.ball 0 δ ∩ {w : ℂ | 0 < w.im})
+                triangleInterior ∧
+              (∀ t : ℝ,
+                  (t : ℂ) ∈ Metric.ball 0 δ → cornerParameterThree (t : ℂ) ∉ triangleInterior) ∧
+                (∀ w ∈ Metric.ball 0 δ, 0 < (cornerParameterThree w).im) ∧
+                  (∀ w ∈ Metric.ball 0 δ,
+                    ((cornerParameterThree w - centerOne) /
+                          (cornerParameterThree w - conj (centerOne : ℂ))) ^
+                        3 =
+                      w) := by
+  obtain ⟨r, hr, hr1, hsector⟩ := exists_cornerThree_radius
+  obtain ⟨δ, hδ, hδr⟩ :=
+    exists_small_root_ball_mo1973_19462
+      (RiemannBoundary.continuousAt_principalRoot_zero (by norm_num : 0 < 3))
+      (RiemannBoundary.principalRoot_zero (by norm_num : 0 < 3)) hr
+  have hδ1 : ∀ w ∈ Metric.ball (0 : ℂ) δ, ‖RiemannBoundary.principalRoot 3 w‖ < 1 := fun w hw =>
+    (hδr w hw).trans_le hr1
+  refine
+    ⟨δ, hδ, cornerParameterThree_analyticOnNhd hδ1, cornerParameterThree_continuousOn hδ1, ?_, ?_,
+      ?_, ?_⟩
+  · intro w hw
+    exact (hsector _ (hδr w hw.1)).mpr (RiemannBoundary.principalRoot_three_upper hw.2)
+  · intro t ht hmem
+    have hs := (hsector _ (hδr (t : ℂ) ht)).mp hmem
+    rcases RiemannBoundary.principalRoot_three_real_boundary (Complex.ofReal_im t) with h | h
+    · exact hs.1.ne' h
+    · exact hs.2.ne h
+  · exact fun w hw => cornerParameterThree_im_pos (hδ1 w hw)
+  · exact fun w hw => cornerParameterThree_power (hδ1 w hw)
+
+private theorem SpecialPeriods.Triangle.exists_cornerParameterFour_neighborhood :
+    ∃ δ : ℝ,
+      0 < δ ∧
+        AnalyticOnNhd ℂ cornerParameterFour (Metric.ball 0 δ ∩ {w : ℂ | 0 < w.im}) ∧
+          ContinuousOn cornerParameterFour (Metric.ball 0 δ ∩ {w : ℂ | 0 ≤ w.im}) ∧
+            Set.MapsTo cornerParameterFour (Metric.ball 0 δ ∩ {w : ℂ | 0 < w.im})
+                triangleInterior ∧
+              (∀ t : ℝ,
+                  (t : ℂ) ∈ Metric.ball 0 δ → cornerParameterFour (t : ℂ) ∉ triangleInterior) ∧
+                (∀ w ∈ Metric.ball 0 δ, 0 < (cornerParameterFour w).im) ∧
+                  (∀ w ∈ Metric.ball 0 δ,
+                    ((cornerParameterFour w - centerTwo) /
+                          (cornerParameterFour w - conj (centerTwo : ℂ))) ^
+                        4 =
+                      -w) := by
+  obtain ⟨r, hr, hr1, hsector⟩ := exists_cornerFour_radius
+  obtain ⟨δ, hδ, hδr⟩ :=
+    exists_small_root_ball_mo1973_19462 RiemannBoundary.continuousAt_rotatedPrincipalRootFour_zero
+      RiemannBoundary.rotatedPrincipalRootFour_zero hr
+  have hδ1 : ∀ w ∈ Metric.ball (0 : ℂ) δ, ‖RiemannBoundary.rotatedPrincipalRootFour w‖ < 1 :=
+    fun w hw => (hδr w hw).trans_le hr1
+  refine
+    ⟨δ, hδ, cornerParameterFour_analyticOnNhd hδ1, cornerParameterFour_continuousOn hδ1, ?_, ?_,
+      ?_, ?_⟩
+  · intro w hw
+    exact (hsector _ (hδr w hw.1)).mpr (RiemannBoundary.rotatedPrincipalRootFour_upper hw.2)
+  · intro t ht hmem
+    have hs := (hsector _ (hδr (t : ℂ) ht)).mp hmem
+    rcases RiemannBoundary.rotatedPrincipalRootFour_real_boundary (Complex.ofReal_im t) with h | h
+    · exact hs.1.ne h
+    · exact hs.2.ne' h
+  · exact fun w hw => cornerParameterFour_im_pos (hδ1 w hw)
+  · exact fun w hw => cornerParameterFour_power (hδ1 w hw)
+
+private theorem RiemannBoundary.norm_lt_one_iff_im_pos_eventually {H k : ℂ → ℂ} {x : ℝ}
+    (hH : ContinuousAt H (x : ℂ)) (hcenter : ‖H (x : ℂ)‖ = 1)
+    (hk : ∀ᶠ z in 𝓝 (x : ℂ), 0 < z.im → ‖k z‖ < 1) (hu : ∀ᶠ z in 𝓝 (x : ℂ), 0 < z.im → H z = k z)
+    (hl : ∀ᶠ z in 𝓝 (x : ℂ), z.im < 0 → H z = (conj (k (conj z)))⁻¹)
+    (hr : ∀ᶠ z in 𝓝 (x : ℂ), z.im = 0 → ‖H z‖ = 1) : ∀ᶠ z in 𝓝 (x : ℂ), ‖H z‖ < 1 ↔ 0 < z.im := by
+  have hcenter0 : H (x : ℂ) ≠ 0 := by
+    intro hzero
+    simp [hzero] at hcenter
+  have hnz := hH.eventually_ne hcenter0
+  have hconj : Filter.Tendsto (conj : ℂ → ℂ) (𝓝 (x : ℂ)) (𝓝 (x : ℂ)) := by
+    simpa only [Complex.conj_ofReal] using Complex.continuous_conj.tendsto (x : ℂ)
+  have hkc := hconj.eventually hk
+  filter_upwards [hk, hu, hl, hr, hnz, hkc] with z hzk hzu hzl hzr hzne hzconj
+  rcases lt_trichotomy z.im 0 with hneg | hzero | hpos
+  · have hw : ‖k (conj z)‖ < 1 := hzconj (by simpa using hneg)
+    have hw0 : k (conj z) ≠ 0 := by
+      intro heq
+      apply hzne
+      rw [hzl hneg, heq]
+      simp
+    have hlarge : 1 < ‖H z‖ := by
+      rw [hzl hneg, norm_inv, Complex.norm_conj]
+      exact (one_lt_inv₀ (norm_pos_iff.mpr hw0)).mpr hw
+    exact iff_of_false (not_lt_of_ge hlarge.le) (not_lt_of_ge hneg.le)
+  · rw [hzr hzero]
+    simp only [lt_self_iff_false, hzero]
+  · rw [hzu hpos]
+    exact iff_of_true (hzk hpos) hpos
+
+private theorem
+    RiemannBoundary.exists_conformal_extension_of_modulus_one {U : Set ℂ} (hU : IsOpen U)
+    {f : ℂ → ℂ} {x : ℝ} (hx : (x : ℂ) ∈ U) (hf : DifferentiableOn ℂ f (U ∩ {z : ℂ | 0 < z.im}))
+    (hmod :
+      ∀ t : ℝ,
+        (t : ℂ) ∈ U → Filter.Tendsto (fun z => ‖f z‖) (𝓝[{z : ℂ | 0 < z.im}] (t : ℂ)) (𝓝 1))
+    (hdisc : ∀ z ∈ U ∩ {z : ℂ | 0 < z.im}, ‖f z‖ < 1) :
+    ∃ r > 0,
+      ∃ H : ℂ → ℂ,
+        AnalyticOnNhd ℂ H (Metric.ball (x : ℂ) r) ∧
+          Set.EqOn H f (Metric.ball (x : ℂ) r ∩ {z : ℂ | 0 < z.im}) ∧
+            Set.EqOn H (fun z => (conj (f (conj z)))⁻¹)
+                (Metric.ball (x : ℂ) r ∩ {z : ℂ | z.im < 0}) ∧
+              (∀ t : ℝ, (t : ℂ) ∈ Metric.ball (x : ℂ) r → ‖H (t : ℂ)‖ = 1) ∧
+                HasStrictDerivAt H (deriv H (x : ℂ)) (x : ℂ) ∧
+                  deriv H (x : ℂ) ≠ 0 ∧ ∀ᶠ z in 𝓝 (x : ℂ), ‖H z‖ < 1 ↔ 0 < z.im := by
+  obtain ⟨r, hr, H, hHa, hHe, hHl, hHc⟩ := exists_analytic_extension_of_modulus_one hU hx hf hmod
+  have hHx := hHa (x : ℂ) (Metric.mem_ball_self hr)
+  have hcenter := hHc x (Metric.mem_ball_self hr)
+  have hk : ∀ᶠ z in 𝓝 (x : ℂ), 0 < z.im → ‖f z‖ < 1 := by
+    filter_upwards [hU.mem_nhds hx] with z hz hpos
+    exact hdisc z ⟨hz, hpos⟩
+  have hu : ∀ᶠ z in 𝓝 (x : ℂ), 0 < z.im → H z = f z := by
+    filter_upwards [Metric.ball_mem_nhds (x : ℂ) hr] with z hz hpos
+    exact hHe ⟨hz, hpos⟩
+  have hl : ∀ᶠ z in 𝓝 (x : ℂ), z.im < 0 → H z = (conj (f (conj z)))⁻¹ := by
+    filter_upwards [Metric.ball_mem_nhds (x : ℂ) hr] with z hz hneg
+    exact hHl ⟨hz, hneg⟩
+  have hreal : ∀ᶠ z in 𝓝 (x : ℂ), z.im = 0 → ‖H z‖ = 1 := by
+    filter_upwards [Metric.ball_mem_nhds (x : ℂ) hr] with z hz hzero
+    have heq : (z.re : ℂ) = z := Complex.ext (by simp) (by simpa using hzero.symm)
+    simpa only [heq] using hHc z.re (by simpa only [heq] using hz)
+  have hinside : ∀ᶠ z in 𝓝 (x : ℂ), 0 < z.im → ‖H z‖ < 1 := by
+    filter_upwards [hu, hk] with z heq hz hpos
+    rw [heq hpos]
+    exact hz hpos
+  have hnonzero :=
+    RiemannMapping.deriv_ne_zero_of_upper_halfPlane_to_unitDisc hHx (by simp) hcenter hinside
+  exact
+    ⟨r, hr, H, hHa, hHe, hHl, hHc, hHx.hasStrictDerivAt, hnonzero,
+      norm_lt_one_iff_im_pos_eventually hHx.continuousAt hcenter hk hu hl hreal⟩
+
+private theorem
+    RiemannBoundary.exists_conformal_extension_discHomeomorph_in_half_chart {D U : Set ℂ}
+    (e : D ≃ₜ Metric.ball (0 : ℂ) 1) {f φ : ℂ → ℂ} (he : ∀ z : D, f z = (e z : ℂ)) (hU : IsOpen U)
+    (hf : DifferentiableOn ℂ f D) (hφ : DifferentiableOn ℂ φ (U ∩ {z : ℂ | 0 < z.im}))
+    (hφc : ContinuousOn φ (U ∩ {z : ℂ | 0 ≤ z.im}))
+    (hside : Set.MapsTo φ (U ∩ {z : ℂ | 0 < z.im}) D)
+    (hout : ∀ t : ℝ, (t : ℂ) ∈ U → φ (t : ℂ) ∉ D) {x : ℝ} (hx : (x : ℂ) ∈ U) :
+    ∃ r > 0,
+      ∃ H : ℂ → ℂ,
+        AnalyticOnNhd ℂ H (Metric.ball (x : ℂ) r) ∧
+          Set.EqOn H (f ∘ φ) (Metric.ball (x : ℂ) r ∩ {z : ℂ | 0 < z.im}) ∧
+            Set.EqOn H (fun z => (conj (f (φ (conj z))))⁻¹)
+                (Metric.ball (x : ℂ) r ∩ {z : ℂ | z.im < 0}) ∧
+              (∀ t : ℝ, (t : ℂ) ∈ Metric.ball (x : ℂ) r → ‖H (t : ℂ)‖ = 1) ∧
+                HasStrictDerivAt H (deriv H (x : ℂ)) (x : ℂ) ∧
+                  deriv H (x : ℂ) ≠ 0 ∧ ∀ᶠ z in 𝓝 (x : ℂ), ‖H z‖ < 1 ↔ 0 < z.im := by
+  apply exists_conformal_extension_of_modulus_one hU hx (hf.comp hφ hside)
+  · intro t ht
+    exact tendsto_norm_discHomeomorph_in_boundary_chart e he hU hφc hside ht (hout t ht)
+  · intro z hz
+    have hp := hside hz
+    have hv := he ⟨φ z, hp⟩
+    simpa only [Function.comp_def, Metric.mem_ball, dist_zero_right, ← hv] using
+      (e ⟨φ z, hp⟩).property
+
+private def RiemannBoundary.discHomeomorphInverse {X : Type*} [TopologicalSpace X] {D : Set X}
+    (e : D ≃ₜ Metric.ball (0 : ℂ) 1) (z : ℂ) : X := by
+  classical
+    exact
+    if hz : z ∈ Metric.ball (0 : ℂ) 1 then (e.symm ⟨z, hz⟩ : X) else (e.symm ⟨0, by simp⟩ : X)
+
+private theorem
+    RiemannBoundary.discHomeomorphInverse_of_mem {X : Type*} [TopologicalSpace X] {D : Set X}
+    (e : D ≃ₜ Metric.ball (0 : ℂ) 1) {z : ℂ} (hz : z ∈ Metric.ball (0 : ℂ) 1) :
+    discHomeomorphInverse e z = (e.symm ⟨z, hz⟩ : X) := by
+  simp only [discHomeomorphInverse, dite_eq_left hz]
+
+private theorem RiemannBoundary.tendsto_discHomeomorphInverse_of_boundary_chart {X : Type*}
+    [TopologicalSpace X] {D : Set X} (e : D ≃ₜ Metric.ball (0 : ℂ) 1) {f : X → ℂ}
+    (he : ∀ z : D, f z = (e z : ℂ)) {φ : ℂ → X} {H : ℂ → ℂ} {d : ℂ} (hφ : ContinuousAt φ 0)
+    (hH : HasStrictDerivAt H d 0) (hd : d ≠ 0)
+    (hcoord : ∀ᶠ z in 𝓝 (0 : ℂ), ‖H z‖ < 1 → φ z ∈ D ∧ f (φ z) = H z) :
+    Filter.Tendsto (discHomeomorphInverse e) (𝓝[Metric.ball (0 : ℂ) 1] (H 0)) (𝓝 (φ 0)) := by
+  let k := hH.localInverse H d 0 hd
+  have hk0 : k (H 0) = 0 := hH.eventually_left_inverse hd |>.self_of_nhds
+  have hk : Filter.Tendsto k (𝓝 (H 0)) (𝓝 (0 : ℂ)) := by
+    have ht : Filter.Tendsto k (𝓝 (H 0)) (𝓝 (k (H 0))) :=
+      (hH.to_localInverse hd).hasDerivAt.continuousAt.tendsto
+    rwa [hk0] at ht
+  have ht : Filter.Tendsto (φ ∘ k) (𝓝[Metric.ball (0 : ℂ) 1] (H 0)) (𝓝 (φ 0)) :=
+    (hφ.tendsto.comp hk).mono_left nhdsWithin_le_nhds
+  have heq : discHomeomorphInverse e =ᶠ[𝓝[Metric.ball (0 : ℂ) 1] (H 0)] φ ∘ k := by
+    have hright : ∀ᶠ y in 𝓝[Metric.ball (0 : ℂ) 1] (H 0), H (k y) = y :=
+      (hH.eventually_right_inverse hd).filter_mono nhdsWithin_le_nhds
+    have hparam :
+      ∀ᶠ y in 𝓝[Metric.ball (0 : ℂ) 1] (H 0),
+        ‖H (k y)‖ < 1 → φ (k y) ∈ D ∧ f (φ (k y)) = H (k y) :=
+      (hk.eventually hcoord).filter_mono nhdsWithin_le_nhds
+    filter_upwards [hright, hparam, self_mem_nhdsWithin] with y hy hcy hyD
+    have hyn : ‖y‖ < 1 := by simpa using hyD
+    obtain ⟨hmem, hval⟩ := hcy (by simpa only [hy] using hyn)
+    have himage : e ⟨φ (k y), hmem⟩ = ⟨y, hyD⟩ := by
+      apply Subtype.ext
+      exact (he ⟨φ (k y), hmem⟩).symm.trans (hval.trans hy)
+    rw [discHomeomorphInverse_of_mem e hyD]
+    change (e.symm ⟨y, hyD⟩ : X) = φ (k y)
+    have hinv : e.symm ⟨y, hyD⟩ = ⟨φ (k y), hmem⟩ := by rw [← himage, e.symm_apply_apply]
+    exact congrArg Subtype.val hinv
+  exact ht.congr' heq.symm
+
+private theorem RiemannBoundary.unitCircle_mem_closure_unitBall {w : ℂ} (hw : ‖w‖ = 1) :
+    w ∈ closure (Metric.ball (0 : ℂ) 1) := by
+  rw [closure_ball (0 : ℂ) (by norm_num : (1 : ℝ) ≠ 0)]
+  simpa only [Metric.mem_closedBall, dist_zero_right, hw] using le_rfl (a := (1 : ℝ))
+
+private theorem
+    RiemannBoundary.boundary_points_eq_of_equal_disc_values {X : Type*} [TopologicalSpace X]
+    {D : Set X} [T2Space X] (e : D ≃ₜ Metric.ball (0 : ℂ) 1) {f : X → ℂ}
+    (he : ∀ z : D, f z = (e z : ℂ)) {φ ψ : ℂ → X} {F G : ℂ → ℂ} {dF dG : ℂ}
+    (hφ : ContinuousAt φ 0) (hψ : ContinuousAt ψ 0) (hF : HasStrictDerivAt F dF 0) (hdF : dF ≠ 0)
+    (hG : HasStrictDerivAt G dG 0) (hdG : dG ≠ 0)
+    (hcoordF : ∀ᶠ z in 𝓝 (0 : ℂ), ‖F z‖ < 1 → φ z ∈ D ∧ f (φ z) = F z)
+    (hcoordG : ∀ᶠ z in 𝓝 (0 : ℂ), ‖G z‖ < 1 → ψ z ∈ D ∧ f (ψ z) = G z) (hcircle : ‖F 0‖ = 1)
+    (hvalue : F 0 = G 0) : φ 0 = ψ 0 := by
+  have : Filter.NeBot (𝓝[Metric.ball (0 : ℂ) 1] (F 0)) :=
+    (mem_closure_iff_nhdsWithin_neBot).mp (unitCircle_mem_closure_unitBall hcircle)
+  have htF := tendsto_discHomeomorphInverse_of_boundary_chart e he hφ hF hdF hcoordF
+  have htG := tendsto_discHomeomorphInverse_of_boundary_chart e he hψ hG hdG hcoordG
+  rw [← hvalue] at htG
+  exact tendsto_nhds_unique htF htG
+
+private structure RiemannMapping.TriangleBoundaryGerm (φ : ℂ → ℂ) where
+  function : ℂ → ℂ
+  radius : ℝ
+  radius_pos : 0 < radius
+  analytic : AnalyticOnNhd ℂ function (Metric.ball 0 radius)
+  agrees : Set.EqOn function (triangleMap ∘ φ) (Metric.ball 0 radius ∩ {z | 0 < z.im})
+  unit : ‖function 0‖ = 1
+  strictDeriv : HasStrictDerivAt function (deriv function 0) 0
+  deriv_ne_zero : deriv function 0 ≠ 0
+  sourceCorrespondence :
+    ∀ᶠ z in 𝓝 (0 : ℂ),
+      ‖function z‖ < 1 →
+        φ z ∈ SpecialPeriods.Triangle.triangleInterior ∧ triangleMap (φ z) = function z
+
+private theorem RiemannMapping.exists_triangleBoundaryGerm {φ : ℂ → ℂ} {δ : ℝ} (hδ : 0 < δ)
+    (hφ : AnalyticOnNhd ℂ φ (Metric.ball 0 δ ∩ {z | 0 < z.im}))
+    (hφc : ContinuousOn φ (Metric.ball 0 δ ∩ {z | 0 ≤ z.im}))
+    (hside :
+      Set.MapsTo φ (Metric.ball 0 δ ∩ {z | 0 < z.im}) SpecialPeriods.Triangle.triangleInterior)
+    (hout :
+      ∀ t : ℝ, (t : ℂ) ∈ Metric.ball 0 δ → φ (t : ℂ) ∉ SpecialPeriods.Triangle.triangleInterior) :
+    Nonempty (TriangleBoundaryGerm φ) := by
+  obtain ⟨r, hr, H, hHa, hHe, _, hHc, hHd, hHn, hHside⟩ :=
+    RiemannBoundary.exists_conformal_extension_discHomeomorph_in_half_chart
+      triangleBiholomorph.toHomeomorph triangleMap_biholomorph Metric.isOpen_ball
+      triangleMap_differentiable hφ.differentiableOn hφc hside hout
+      (show ((0 : ℝ) : ℂ) ∈ Metric.ball (0 : ℂ) δ from Metric.mem_ball_self hδ)
+  refine
+    ⟨{  function := H
+        radius := r
+        radius_pos := hr
+        analytic := hHa
+        agrees := hHe
+        unit := hHc 0 (Metric.mem_ball_self hr)
+        strictDeriv := hHd
+        deriv_ne_zero := hHn
+        sourceCorrespondence := ?_ }⟩
+  filter_upwards [hHside, Metric.ball_mem_nhds (0 : ℂ) hr, Metric.ball_mem_nhds (0 : ℂ) hδ] with z
+    hz hrz hδz hn
+  have hi := hz.mp hn
+  exact ⟨hside ⟨hδz, hi⟩, (hHe ⟨hrz, hi⟩).symm⟩
+
+private theorem RiemannMapping.exists_triangleCornerThreeGerm :
+    Nonempty (TriangleBoundaryGerm SpecialPeriods.Triangle.cornerParameterThree) := by
+  obtain ⟨δ, hδ, hφ, hφc, hside, hout, _, _⟩ :=
+    SpecialPeriods.Triangle.exists_cornerParameterThree_neighborhood
+  exact exists_triangleBoundaryGerm hδ hφ hφc hside hout
+
+private theorem RiemannMapping.exists_triangleCornerFourGerm :
+    Nonempty (TriangleBoundaryGerm SpecialPeriods.Triangle.cornerParameterFour) := by
+  obtain ⟨δ, hδ, hφ, hφc, hside, hout, _, _⟩ :=
+    SpecialPeriods.Triangle.exists_cornerParameterFour_neighborhood
+  exact exists_triangleBoundaryGerm hδ hφ hφc hside hout
+
+private def RiemannMapping.triangleCornerThreeGerm :
+    TriangleBoundaryGerm SpecialPeriods.Triangle.cornerParameterThree :=
+  Classical.choice exists_triangleCornerThreeGerm
+
+private def RiemannMapping.triangleCornerFourGerm :
+    TriangleBoundaryGerm SpecialPeriods.Triangle.cornerParameterFour :=
+  Classical.choice exists_triangleCornerFourGerm
+
+private theorem RiemannMapping.triangleCornerThree_inverse_limit :
+    Filter.Tendsto (RiemannBoundary.discHomeomorphInverse triangleBiholomorph.toHomeomorph)
+      (𝓝[Metric.ball (0 : ℂ) 1] (triangleCornerThreeGerm.function 0))
+      (𝓝 (SpecialPeriods.Triangle.centerOne : ℂ)) := by
+  simpa only [SpecialPeriods.Triangle.cornerParameterThree_zero] using
+    RiemannBoundary.tendsto_discHomeomorphInverse_of_boundary_chart
+      triangleBiholomorph.toHomeomorph triangleMap_biholomorph
+      SpecialPeriods.Triangle.continuousAt_cornerParameterThree_zero
+      triangleCornerThreeGerm.strictDeriv triangleCornerThreeGerm.deriv_ne_zero
+      triangleCornerThreeGerm.sourceCorrespondence
+
+private theorem RiemannMapping.triangleCornerFour_inverse_limit :
+    Filter.Tendsto (RiemannBoundary.discHomeomorphInverse triangleBiholomorph.toHomeomorph)
+      (𝓝[Metric.ball (0 : ℂ) 1] (triangleCornerFourGerm.function 0))
+      (𝓝 (SpecialPeriods.Triangle.centerTwo : ℂ)) := by
+  simpa only [SpecialPeriods.Triangle.cornerParameterFour_zero] using
+    RiemannBoundary.tendsto_discHomeomorphInverse_of_boundary_chart
+      triangleBiholomorph.toHomeomorph triangleMap_biholomorph
+      SpecialPeriods.Triangle.continuousAt_cornerParameterFour_zero
+      triangleCornerFourGerm.strictDeriv triangleCornerFourGerm.deriv_ne_zero
+      triangleCornerFourGerm.sourceCorrespondence
+
+private theorem RiemannMapping.triangle_centers_complex_ne :
+    (SpecialPeriods.Triangle.centerOne : ℂ) ≠ (SpecialPeriods.Triangle.centerTwo : ℂ) := by
+  intro h
+  have hr := congrArg Complex.re h
+  change SpecialPeriods.Triangle.centerOne.re = SpecialPeriods.Triangle.centerTwo.re at hr
+  rw [SpecialPeriods.Triangle.centerTwo_re] at hr
+  have hleft : SpecialPeriods.Triangle.centerOne.re = -1 / 2 := by
+    change (SpecialPeriods.rho - 1).re = -1 / 2
+    simp only [Complex.sub_re, SpecialPeriods.rho_re, Complex.one_re]
+    norm_num
+  rw [hleft] at hr
+  linarith [SpecialPeriods.Triangle.width_pos]
+
+private theorem RiemannMapping.triangleCorner_boundary_values_ne :
+    triangleCornerThreeGerm.function 0 ≠ triangleCornerFourGerm.function 0 := by
+  intro h
+  have hp :=
+    RiemannBoundary.boundary_points_eq_of_equal_disc_values triangleBiholomorph.toHomeomorph
+      triangleMap_biholomorph SpecialPeriods.Triangle.continuousAt_cornerParameterThree_zero
+      SpecialPeriods.Triangle.continuousAt_cornerParameterFour_zero
+      triangleCornerThreeGerm.strictDeriv triangleCornerThreeGerm.deriv_ne_zero
+      triangleCornerFourGerm.strictDeriv triangleCornerFourGerm.deriv_ne_zero
+      triangleCornerThreeGerm.sourceCorrespondence triangleCornerFourGerm.sourceCorrespondence
+      triangleCornerThreeGerm.unit h
+  exact
+    triangle_centers_complex_ne
+      (by
+        simpa only [SpecialPeriods.Triangle.cornerParameterThree_zero,
+          SpecialPeriods.Triangle.cornerParameterFour_zero] using hp)
+
+private theorem RiemannBoundary.continuousWithinAt_log_closedUpper {q : ℂ} (hq : q ≠ 0) :
+    ContinuousWithinAt Complex.log {z : ℂ | 0 ≤ z.im} q := by
+  by_cases hi : q.im = 0
+  · by_cases hr : 0 < q.re
+    · exact (continuousAt_clog (Or.inl hr)).continuousWithinAt
+    · have hre : q.re < 0 := by
+        have hne : q.re ≠ 0 := by
+          intro heq
+          apply hq
+          exact Complex.ext heq hi
+        exact lt_of_le_of_ne (le_of_not_gt hr) hne
+      exact Complex.continuousWithinAt_log_of_re_neg_of_im_zero hre hi
+  · exact (continuousAt_clog (Or.inr hi)).continuousWithinAt
+
+private theorem RiemannBoundary.continuousWithinAt_logHalfStrip_closedUpper (a c : ℝ) {q : ℂ}
+    (hq : q ≠ 0) : ContinuousWithinAt (logHalfStrip a c) {z : ℂ | 0 ≤ z.im} q := by
+  exact
+    continuousWithinAt_const.sub
+      (continuousWithinAt_const.mul (continuousWithinAt_log_closedUpper hq))
+
+private theorem RiemannBoundary.analyticOnNhd_logHalfStrip_upper (a c : ℝ) :
+    AnalyticOnNhd ℂ (logHalfStrip a c) {z : ℂ | 0 < z.im} := by
+  intro q hq
+  exact analyticAt_const.sub (analyticAt_const.mul (analyticAt_clog (Or.inr (ne_of_gt hq))))
+
+private theorem RiemannBoundary.logHalfStrip_re_mem_Ioo (a : ℝ) {c : ℝ} (hc : 0 < c) {q : ℂ}
+    (hq : 0 < q.im) : (logHalfStrip a c q).re ∈ Set.Ioo a (a + c * Real.pi) := by
+  have harg0 : q.arg ≠ 0 := fun h => (ne_of_gt hq) (Complex.arg_eq_zero_iff.mp h).2
+  have harg : 0 < q.arg := lt_of_le_of_ne (Complex.arg_nonneg_iff.mpr hq.le) harg0.symm
+  have hargπ : q.arg < Real.pi := Complex.arg_lt_pi_iff.mpr (Or.inr (ne_of_gt hq))
+  rw [logHalfStrip_re]
+  constructor <;> nlinarith
+
+private theorem RiemannBoundary.logHalfStrip_real_re (a c : ℝ) (t : ℝ) :
+    (logHalfStrip a c (t : ℂ)).re = a ∨ (logHalfStrip a c (t : ℂ)).re = a + c * Real.pi := by
+  by_cases ht : 0 ≤ t
+  · left
+    simp [logHalfStrip_re, Complex.arg_ofReal_of_nonneg ht]
+  · right
+    simp [logHalfStrip_re, Complex.arg_ofReal_of_neg (lt_of_not_ge ht)]
+
+private theorem RiemannBoundary.exists_logHalfStrip_height_radius (a B : ℝ) {c : ℝ} (hc : 0 < c) :
+    ∃ R > 0, ∀ q ∈ Metric.ball (0 : ℂ) R, q ≠ 0 → B < (logHalfStrip a c q).im := by
+  have ht : ∀ᶠ q in 𝓝[≠] (0 : ℂ), B < (logHalfStrip a c q).im :=
+    (tendsto_logHalfStrip_im_atTop a hc).eventually_gt_atTop B
+  obtain ⟨R, hR, hs⟩ := Metric.mem_nhdsWithin_iff.mp ht
+  exact ⟨R, hR, fun q hq hne => hs ⟨hq, hne⟩⟩
+
+private theorem
+    RiemannBoundary.exists_conformal_extension_discHomeomorph_at_ideal_vertex {D : Set ℂ}
+    (e : D ≃ₜ Metric.ball (0 : ℂ) 1) {f : ℂ → ℂ} (he : ∀ z : D, f z = (e z : ℂ))
+    (hf : DifferentiableOn ℂ f D) (a B : ℝ) {c : ℝ} (hc : 0 < c)
+    (hstrip : ∀ z : ℂ, a < z.re → z.re < a + c * Real.pi → B < z.im → z ∈ D)
+    (hedge : ∀ z : ℂ, B < z.im → (z.re = a ∨ z.re = a + c * Real.pi) → z ∉ D) :
+    ∃ r > 0,
+      ∃ H : ℂ → ℂ,
+        AnalyticOnNhd ℂ H (Metric.ball (0 : ℂ) r) ∧
+          Set.EqOn H (f ∘ logHalfStrip a c) (Metric.ball (0 : ℂ) r ∩ {z : ℂ | 0 < z.im}) ∧
+            Set.EqOn H (fun z => (conj (f (logHalfStrip a c (conj z))))⁻¹)
+                (Metric.ball (0 : ℂ) r ∩ {z : ℂ | z.im < 0}) ∧
+              (∀ t : ℝ, (t : ℂ) ∈ Metric.ball (0 : ℂ) r → ‖H (t : ℂ)‖ = 1) ∧
+                HasStrictDerivAt H (deriv H 0) 0 ∧
+                  deriv H 0 ≠ 0 ∧ ∀ᶠ z in 𝓝 (0 : ℂ), ‖H z‖ < 1 ↔ 0 < z.im := by
+  obtain ⟨R, hR, hheight⟩ := exists_logHalfStrip_height_radius a B hc
+  let U : Set ℂ := Metric.ball (0 : ℂ) R
+  have hU : IsOpen U := Metric.isOpen_ball
+  have h0U : (0 : ℂ) ∈ U := Metric.mem_ball_self hR
+  have hside : Set.MapsTo (logHalfStrip a c) (U ∩ {z : ℂ | 0 < z.im}) D := by
+    intro q hq
+    have hq0 : q ≠ 0 := by
+      intro heq
+      have hi := hq.2
+      rw [heq] at hi
+      exact (lt_irrefl (0 : ℝ)) hi
+    have hRe := logHalfStrip_re_mem_Ioo a hc hq.2
+    exact hstrip _ hRe.1 hRe.2 (hheight q hq.1 hq0)
+  have hφ : DifferentiableOn ℂ (logHalfStrip a c) (U ∩ {z : ℂ | 0 < z.im}) :=
+    (analyticOnNhd_logHalfStrip_upper a c).differentiableOn.mono Set.inter_subset_right
+  have hdiff : DifferentiableOn ℂ (f ∘ logHalfStrip a c) (U ∩ {z : ℂ | 0 < z.im}) :=
+    hf.comp hφ hside
+  have hmod :
+    ∀ t : ℝ,
+      (t : ℂ) ∈ U →
+        Filter.Tendsto (fun q => ‖f (logHalfStrip a c q)‖) (𝓝[{z : ℂ | 0 < z.im}] (t : ℂ))
+          (𝓝 1) := by
+    intro t ht
+    by_cases ht0 : t = 0
+    · subst t
+      apply tendsto_norm_discHomeomorph_logHalfStrip e he a hc
+      have hnear : U ∈ 𝓝[{z : ℂ | 0 < z.im}] (0 : ℂ) :=
+        mem_nhdsWithin_of_mem_nhds (hU.mem_nhds h0U)
+      filter_upwards [hnear, self_mem_nhdsWithin] with q hq hi
+      exact hside ⟨hq, hi⟩
+    · let V : Set ℂ := U \ {0}
+      have hV : IsOpen V := hU.sdiff isClosed_singleton
+      have htC : (t : ℂ) ≠ 0 := Complex.ofReal_ne_zero.mpr ht0
+      have htV : (t : ℂ) ∈ V := ⟨ht, htC⟩
+      have hcont : ContinuousOn (logHalfStrip a c) (V ∩ {z : ℂ | 0 ≤ z.im}) := by
+        intro q hq
+        exact (continuousWithinAt_logHalfStrip_closedUpper a c hq.1.2).mono Set.inter_subset_right
+      have hsideV : Set.MapsTo (logHalfStrip a c) (V ∩ {z : ℂ | 0 < z.im}) D := by
+        intro q hq
+        exact hside ⟨hq.1.1, hq.2⟩
+      exact
+        tendsto_norm_discHomeomorph_in_boundary_chart e he hV hcont hsideV htV
+          (hedge _ (hheight _ ht htC) (logHalfStrip_real_re a c t))
+  apply exists_conformal_extension_of_modulus_one hU h0U hdiff hmod
+  intro q hq
+  have hp := hside hq
+  have hv := he ⟨logHalfStrip a c q, hp⟩
+  simpa only [Function.comp_def, Metric.mem_ball, dist_zero_right, ← hv] using
+    (e ⟨logHalfStrip a c q, hp⟩).property
+
+private def RiemannMapping.triangleCuspScale : ℝ :=
+  SpecialPeriods.Triangle.width / (2 * Real.pi)
+
+private theorem RiemannMapping.triangleCuspScale_pos : 0 < triangleCuspScale := by
+  exact div_pos SpecialPeriods.Triangle.width_pos (mul_pos (by norm_num) Real.pi_pos)
+
+private theorem RiemannMapping.triangleCuspScale_endpoint :
+    SpecialPeriods.Triangle.stripLeft + triangleCuspScale * Real.pi = -1 / 2 := by
+  unfold SpecialPeriods.Triangle.stripLeft triangleCuspScale
+  field_simp [Real.pi_ne_zero]
+  ring
+
+private def RiemannMapping.triangleCuspLog : ℂ → ℂ :=
+  RiemannBoundary.logHalfStrip SpecialPeriods.Triangle.stripLeft triangleCuspScale
+
+private theorem RiemannMapping.triangle_high_halfStrip_mem (z : ℂ)
+    (hl : SpecialPeriods.Triangle.stripLeft < z.re)
+    (hr : z.re < SpecialPeriods.Triangle.stripLeft + triangleCuspScale * Real.pi)
+    (hi : 1 < z.im) : z ∈ SpecialPeriods.Triangle.triangleInterior := by
+  rw [SpecialPeriods.Triangle.mem_triangleInterior_iff_epigraph]
+  exact
+    ⟨hl, by simpa only [triangleCuspScale_endpoint] using hr,
+      (SpecialPeriods.Triangle.boundaryHeight_le_one z.re).trans_lt hi⟩
+
+private theorem RiemannMapping.triangle_high_halfStrip_edge_notMem (z : ℂ)
+    (he :
+      z.re = SpecialPeriods.Triangle.stripLeft ∨
+        z.re = SpecialPeriods.Triangle.stripLeft + triangleCuspScale * Real.pi) :
+    z ∉ SpecialPeriods.Triangle.triangleInterior := by
+  intro hz
+  rcases he with hl | hr
+  · exact (lt_irrefl SpecialPeriods.Triangle.stripLeft) (hl ▸ hz.1)
+  · rw [triangleCuspScale_endpoint] at hr
+    exact (lt_irrefl (-1 / 2 : ℝ)) (hr ▸ hz.2.1)
+
+private theorem RiemannMapping.exists_triangleMap_extension_ideal_vertex :
+    ∃ r > 0,
+      ∃ H : ℂ → ℂ,
+        AnalyticOnNhd ℂ H (Metric.ball (0 : ℂ) r) ∧
+          Set.EqOn H (triangleMap ∘ triangleCuspLog)
+              (Metric.ball (0 : ℂ) r ∩ {z : ℂ | 0 < z.im}) ∧
+            Set.EqOn H (fun z => (conj (triangleMap (triangleCuspLog (conj z))))⁻¹)
+                (Metric.ball (0 : ℂ) r ∩ {z : ℂ | z.im < 0}) ∧
+              (∀ t : ℝ, (t : ℂ) ∈ Metric.ball (0 : ℂ) r → ‖H (t : ℂ)‖ = 1) ∧
+                HasStrictDerivAt H (deriv H 0) 0 ∧
+                  deriv H 0 ≠ 0 ∧ ∀ᶠ z in 𝓝 (0 : ℂ), ‖H z‖ < 1 ↔ 0 < z.im := by
+  exact
+    RiemannBoundary.exists_conformal_extension_discHomeomorph_at_ideal_vertex
+      triangleBiholomorph.toHomeomorph triangleMap_biholomorph triangleMap_differentiable
+      SpecialPeriods.Triangle.stripLeft 1 triangleCuspScale_pos triangle_high_halfStrip_mem
+      (fun z _ he => triangle_high_halfStrip_edge_notMem z he)
+
+private theorem RiemannMapping.exists_triangleIdealGerm :
+    Nonempty (TriangleBoundaryGerm triangleCuspLog) := by
+  obtain ⟨r, hr, H, hHa, hHe, _, hHc, hHd, hHn, hHside⟩ :=
+    exists_triangleMap_extension_ideal_vertex
+  obtain ⟨R, hR, hheight⟩ :=
+    RiemannBoundary.exists_logHalfStrip_height_radius SpecialPeriods.Triangle.stripLeft 1
+      triangleCuspScale_pos
+  refine
+    ⟨{  function := H
+        radius := r
+        radius_pos := hr
+        analytic := hHa
+        agrees := hHe
+        unit := hHc 0 (Metric.mem_ball_self hr)
+        strictDeriv := hHd
+        deriv_ne_zero := hHn
+        sourceCorrespondence := ?_ }⟩
+  filter_upwards [hHside, Metric.ball_mem_nhds (0 : ℂ) hr, Metric.ball_mem_nhds (0 : ℂ) hR] with q
+    hq hrq hRq hn
+  have hi : 0 < q.im := hq.mp hn
+  have hq0 : q ≠ 0 := by
+    intro heq
+    rw [heq, Complex.zero_im] at hi
+    exact (lt_irrefl 0) hi
+  have hRe :=
+    RiemannBoundary.logHalfStrip_re_mem_Ioo SpecialPeriods.Triangle.stripLeft
+      triangleCuspScale_pos hi
+  have hD : triangleCuspLog q ∈ SpecialPeriods.Triangle.triangleInterior :=
+    triangle_high_halfStrip_mem _ hRe.1 hRe.2 (hheight q hRq hq0)
+  exact ⟨hD, (hHe ⟨hrq, hi⟩).symm⟩
+
+private def RiemannMapping.triangleIdealGerm : TriangleBoundaryGerm triangleCuspLog :=
+  Classical.choice exists_triangleIdealGerm
+
+private def RiemannMapping.triangleDiscOnOnePointDomain :
+    RiemannBoundary.onePointDomain SpecialPeriods.Triangle.triangleInterior ≃ₜ
+      Metric.ball (0 : ℂ) 1 :=
+  RiemannBoundary.onePointDomainDiscHomeomorph triangleBiholomorph.toHomeomorph
+
+private def RiemannMapping.triangleOnePointRepresentative (z : OnePoint ℂ) : ℂ :=
+  z.elim 0 triangleMap
+
+@[simp]
+private theorem RiemannMapping.triangleOnePointRepresentative_coe (z : ℂ) :
+    triangleOnePointRepresentative (z : OnePoint ℂ) = triangleMap z :=
+  rfl
+
+private theorem RiemannMapping.triangleOnePointRepresentative_homeomorph
+    (z : RiemannBoundary.onePointDomain SpecialPeriods.Triangle.triangleInterior) :
+    triangleOnePointRepresentative z = (triangleDiscOnOnePointDomain z : ℂ) :=
+  RiemannBoundary.onePointDomainDiscHomeomorph_representative triangleBiholomorph.toHomeomorph
+    triangleMap_biholomorph 0 z
+
+private def RiemannMapping.triangleIdealParameter : ℂ → OnePoint ℂ :=
+  RiemannBoundary.onePointLogHalfStrip SpecialPeriods.Triangle.stripLeft triangleCuspScale
+
+@[simp]
+private theorem RiemannMapping.triangleIdealParameter_zero :
+    triangleIdealParameter 0 = (OnePoint.infty) :=
+  RiemannBoundary.onePointLogHalfStrip_zero _ _
+
+private theorem RiemannMapping.continuousAt_triangleIdealParameter_zero :
+    ContinuousAt triangleIdealParameter 0 :=
+  RiemannBoundary.continuousAt_onePointLogHalfStrip_zero SpecialPeriods.Triangle.stripLeft
+    triangleCuspScale_pos
+
+private theorem RiemannMapping.triangleIdeal_onePoint_sourceCorrespondence :
+    ∀ᶠ z in 𝓝 (0 : ℂ),
+      ‖triangleIdealGerm.function z‖ < 1 →
+        triangleIdealParameter z ∈
+            RiemannBoundary.onePointDomain SpecialPeriods.Triangle.triangleInterior ∧
+          triangleOnePointRepresentative (triangleIdealParameter z) =
+            triangleIdealGerm.function z := by
+  filter_upwards [triangleIdealGerm.sourceCorrespondence] with z hz hn
+  have hzne : z ≠ 0 := by
+    intro heq
+    rw [heq, triangleIdealGerm.unit] at hn
+    exact (lt_irrefl 1) hn
+  have hparameter : triangleIdealParameter z = (triangleCuspLog z : OnePoint ℂ) :=
+    RiemannBoundary.onePointLogHalfStrip_of_ne_zero SpecialPeriods.Triangle.stripLeft
+      triangleCuspScale hzne
+  rw [hparameter]
+  obtain ⟨hmem, hvalue⟩ := hz hn
+  exact ⟨RiemannBoundary.coe_mem_onePointDomain.mpr hmem, hvalue⟩
+
+private theorem RiemannMapping.triangleIdeal_inverse_limit :
+    Filter.Tendsto (RiemannBoundary.discHomeomorphInverse triangleDiscOnOnePointDomain)
+      (𝓝[Metric.ball (0 : ℂ) 1] (triangleIdealGerm.function 0))
+      (𝓝 ((OnePoint.infty) : OnePoint ℂ)) := by
+  simpa only [triangleIdealParameter_zero] using
+    RiemannBoundary.tendsto_discHomeomorphInverse_of_boundary_chart triangleDiscOnOnePointDomain
+      triangleOnePointRepresentative_homeomorph continuousAt_triangleIdealParameter_zero
+      triangleIdealGerm.strictDeriv triangleIdealGerm.deriv_ne_zero
+      triangleIdeal_onePoint_sourceCorrespondence
+
+private def RiemannBoundary.discCompactificationMap {X : Type*} [TopologicalSpace X] {D : Set X}
+    (hD : Dense D) (e : D ≃ₜ Metric.ball (0 : ℂ) 1) : X → ℂ :=
+  hD.extend (fun z : D => (e z : ℂ))
+
+private theorem
+    RiemannBoundary.discCompactificationMap_coe {X : Type*} [TopologicalSpace X] {D : Set X}
+    (hD : Dense D) (e : D ≃ₜ Metric.ball (0 : ℂ) 1) (z : D) :
+    discCompactificationMap hD e z = (e z : ℂ) :=
+  hD.extend_eq (continuous_subtype_val.comp e.continuous) z
+
+private def RiemannBoundary.DiscBoundaryLimits {X : Type*} [TopologicalSpace X] {D : Set X}
+    (e : D ≃ₜ Metric.ball (0 : ℂ) 1) : Prop :=
+  ∀ x ∉ D,
+    ∃ w : ℂ,
+      ‖w‖ = 1 ∧
+        Filter.Tendsto (fun z : D => (e z : ℂ)) (Filter.comap Subtype.val (𝓝 x)) (𝓝 w) ∧
+          Filter.Tendsto (discHomeomorphInverse e) (𝓝[Metric.ball (0 : ℂ) 1] w) (𝓝 x)
+
+private theorem RiemannBoundary.discCompactificationMap_continuous {X : Type*} [TopologicalSpace X]
+    {D : Set X} (hD : Dense D) (e : D ≃ₜ Metric.ball (0 : ℂ) 1) (hb : DiscBoundaryLimits e) :
+    Continuous (discCompactificationMap hD e) := by
+  apply hD.continuous_extend
+  intro x
+  by_cases hx : x ∈ D
+  · refine ⟨(e ⟨x, hx⟩ : ℂ), ?_⟩
+    rw [← hD.isDenseInducing_val.nhds_eq_comap ⟨x, hx⟩]
+    exact (continuous_subtype_val.comp e.continuous).continuousAt
+  · obtain ⟨w, _, hw, _⟩ := hb x hx
+    exact ⟨w, hw⟩
+
+private theorem RiemannBoundary.discCompactificationMap_boundary {X : Type*} [TopologicalSpace X]
+    {D : Set X} (hD : Dense D) (e : D ≃ₜ Metric.ball (0 : ℂ) 1) (hb : DiscBoundaryLimits e)
+    {x : X} (hx : x ∉ D) :
+    ‖discCompactificationMap hD e x‖ = 1 ∧
+      Filter.Tendsto (discHomeomorphInverse e)
+        (𝓝[Metric.ball (0 : ℂ) 1] (discCompactificationMap hD e x)) (𝓝 x) := by
+  obtain ⟨w, hw, ht, hi⟩ := hb x hx
+  have he : discCompactificationMap hD e x = w := hD.extend_eq_of_tendsto ht
+  rw [he]
+  exact ⟨hw, hi⟩
+
+private theorem RiemannBoundary.discCompactificationMap_norm_le {X : Type*} [TopologicalSpace X]
+    {D : Set X} (hD : Dense D) (e : D ≃ₜ Metric.ball (0 : ℂ) 1) (hb : DiscBoundaryLimits e)
+    (x : X) : ‖discCompactificationMap hD e x‖ ≤ 1 := by
+  by_cases hx : x ∈ D
+  · rw [discCompactificationMap_coe hD e ⟨x, hx⟩]
+    exact
+      (show ‖(e ⟨x, hx⟩ : ℂ)‖ < 1 by
+          simpa only [Metric.mem_ball, dist_zero_right] using (e ⟨x, hx⟩).property).le
+  · exact ((discCompactificationMap_boundary hD e hb hx).1).le
+
+private theorem RiemannBoundary.discCompactificationMap_injective {X : Type*} [TopologicalSpace X]
+    {D : Set X} [T2Space X] (hD : Dense D) (e : D ≃ₜ Metric.ball (0 : ℂ) 1)
+    (hb : DiscBoundaryLimits e) : Function.Injective (discCompactificationMap hD e) := by
+  intro x y hxy
+  by_cases hx : x ∈ D
+  · by_cases hy : y ∈ D
+    · apply congrArg Subtype.val (e.injective ?_ : (⟨x, hx⟩ : D) = ⟨y, hy⟩)
+      apply Subtype.ext
+      simpa only [discCompactificationMap_coe hD e ⟨x, hx⟩,
+        discCompactificationMap_coe hD e ⟨y, hy⟩] using hxy
+    · have hn := (discCompactificationMap_boundary hD e hb hy).1
+      rw [← hxy, discCompactificationMap_coe hD e ⟨x, hx⟩] at hn
+      have hlt : ‖(e ⟨x, hx⟩ : ℂ)‖ < 1 := by
+        simpa only [Metric.mem_ball, dist_zero_right] using (e ⟨x, hx⟩).property
+      exact (hlt.ne hn).elim
+  · by_cases hy : y ∈ D
+    · have hn := (discCompactificationMap_boundary hD e hb hx).1
+      rw [hxy, discCompactificationMap_coe hD e ⟨y, hy⟩] at hn
+      have hlt : ‖(e ⟨y, hy⟩ : ℂ)‖ < 1 := by
+        simpa only [Metric.mem_ball, dist_zero_right] using (e ⟨y, hy⟩).property
+      exact (hlt.ne hn).elim
+    · obtain ⟨hn, ht⟩ := discCompactificationMap_boundary hD e hb hx
+      have hu := (discCompactificationMap_boundary hD e hb hy).2
+      rw [← hxy] at hu
+      have : Filter.NeBot (𝓝[Metric.ball (0 : ℂ) 1] (discCompactificationMap hD e x)) :=
+        mem_closure_iff_nhdsWithin_neBot.mp (unitCircle_mem_closure_unitBall hn)
+      exact tendsto_nhds_unique ht hu
+
+private theorem
+    RiemannBoundary.discCompactificationMap_range {X : Type*} [TopologicalSpace X] {D : Set X}
+    [CompactSpace X] (hD : Dense D) (e : D ≃ₜ Metric.ball (0 : ℂ) 1) (hb : DiscBoundaryLimits e) :
+    Set.range (discCompactificationMap hD e) = Metric.closedBall (0 : ℂ) 1 := by
+  apply le_antisymm
+  · rintro y ⟨x, rfl⟩
+    simpa using discCompactificationMap_norm_le hD e hb x
+  · have hclosed : IsClosed (Set.range (discCompactificationMap hD e)) :=
+      (isCompact_range (discCompactificationMap_continuous hD e hb)).isClosed
+    have hdisc : Metric.ball (0 : ℂ) 1 ⊆ Set.range (discCompactificationMap hD e) := by
+      intro y hy
+      refine ⟨(e.symm ⟨y, hy⟩ : X), ?_⟩
+      rw [discCompactificationMap_coe, e.apply_symm_apply]
+    rw [← closure_ball (0 : ℂ) (by norm_num : (1 : ℝ) ≠ 0)]
+    exact closure_minimal hdisc hclosed
+
+private def
+    RiemannBoundary.closedDiscHomeomorph {X : Type*} [TopologicalSpace X] {D : Set X} [T2Space X]
+    [CompactSpace X] (hD : Dense D) (e : D ≃ₜ Metric.ball (0 : ℂ) 1) (hb : DiscBoundaryLimits e) :
+    X ≃ₜ Metric.closedBall (0 : ℂ) 1 := by
+  let F : X → Metric.closedBall (0 : ℂ) 1 := fun x =>
+    ⟨discCompactificationMap hD e x, by simpa using discCompactificationMap_norm_le hD e hb x⟩
+  have hF : Function.Bijective F := by
+    constructor
+    · intro x y hxy
+      exact discCompactificationMap_injective hD e hb (congrArg Subtype.val hxy)
+    · intro y
+      have hy : (y : ℂ) ∈ Set.range (discCompactificationMap hD e) := by
+        rw [discCompactificationMap_range hD e hb]
+        exact y.property
+      obtain ⟨x, hx⟩ := hy
+      exact ⟨x, Subtype.ext hx⟩
+  exact
+    Continuous.homeoOfEquivCompactToT2 (f := Equiv.ofBijective F hF)
+      ((discCompactificationMap_continuous hD e hb).subtype_mk _)
+
+private theorem
+    RiemannBoundary.closedDiscHomeomorph_coe {X : Type*} [TopologicalSpace X] {D : Set X}
+    [T2Space X] [CompactSpace X] (hD : Dense D) (e : D ≃ₜ Metric.ball (0 : ℂ) 1)
+    (hb : DiscBoundaryLimits e) (z : D) : (closedDiscHomeomorph hD e hb z : ℂ) = (e z : ℂ) :=
+  discCompactificationMap_coe hD e z
+
+private def SpecialPeriods.Triangle.triangleClosedInteriorToOnePoint :
+    triangleClosedInterior ≃ₜ RiemannBoundary.onePointDomain triangleInterior
+    where
+  toFun x := ⟨x.val.val, x.property⟩
+  invFun x := ⟨⟨x.val, subset_closure x.property⟩, x.property⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := (continuous_subtype_val.comp continuous_subtype_val).subtype_mk _
+  continuous_invFun := (continuous_subtype_val.subtype_mk _).subtype_mk _
+
+private theorem SpecialPeriods.Triangle.triangleClosedInterior_comap_onePoint_filter
+    (x : TriangleClosedDomain) :
+    Filter.comap triangleClosedInteriorToOnePoint
+        (Filter.comap (Subtype.val : RiemannBoundary.onePointDomain triangleInterior → OnePoint ℂ)
+          (𝓝 x.val)) =
+      Filter.comap (Subtype.val : triangleClosedInterior → TriangleClosedDomain) (𝓝 x) := by
+  rw [nhds_subtype_eq_comap, Filter.comap_comap, Filter.comap_comap]
+  rfl
+
+private theorem SpecialPeriods.Triangle.triangleClosedInterior_map_onePoint_filter
+    (x : TriangleClosedDomain) :
+    Filter.map triangleClosedInteriorToOnePoint
+        (Filter.comap (Subtype.val : triangleClosedInterior → TriangleClosedDomain) (𝓝 x)) =
+      Filter.comap (Subtype.val : RiemannBoundary.onePointDomain triangleInterior → OnePoint ℂ)
+        (𝓝 x.val) := by
+  rw [← triangleClosedInterior_comap_onePoint_filter x,
+    Filter.map_comap_of_surjective triangleClosedInteriorToOnePoint.surjective]
+
+private theorem SpecialPeriods.Triangle.triangleClosedInterior_forward_tendsto_iff
+    (x : TriangleClosedDomain) {l : Filter ℂ} :
+    Filter.Tendsto
+        (fun z : triangleClosedInterior => (triangleClosedInteriorDiscHomeomorph z : ℂ))
+        (Filter.comap (Subtype.val : triangleClosedInterior → TriangleClosedDomain) (𝓝 x)) l ↔
+      Filter.Tendsto
+        (fun z : RiemannBoundary.onePointDomain triangleInterior =>
+          (RiemannMapping.triangleDiscOnOnePointDomain z : ℂ))
+        (Filter.comap (Subtype.val : RiemannBoundary.onePointDomain triangleInterior → OnePoint ℂ)
+          (𝓝 x.val))
+        l := by
+  rw [← triangleClosedInterior_map_onePoint_filter x, Filter.tendsto_map'_iff]
+  rfl
+
+private theorem SpecialPeriods.Triangle.triangleClosedInterior_forward_representative_tendsto_iff
+    (x : TriangleClosedDomain) {l : Filter ℂ} :
+    Filter.Tendsto
+        (fun z : triangleClosedInterior => (triangleClosedInteriorDiscHomeomorph z : ℂ))
+        (Filter.comap (Subtype.val : triangleClosedInterior → TriangleClosedDomain) (𝓝 x)) l ↔
+      Filter.Tendsto RiemannMapping.triangleOnePointRepresentative
+        (𝓝[RiemannBoundary.onePointDomain triangleInterior] x.val) l := by
+  rw [triangleClosedInterior_forward_tendsto_iff]
+  have he :
+    (fun z : RiemannBoundary.onePointDomain triangleInterior =>
+        (RiemannMapping.triangleDiscOnOnePointDomain z : ℂ)) =
+      RiemannMapping.triangleOnePointRepresentative ∘
+        (Subtype.val : RiemannBoundary.onePointDomain triangleInterior → OnePoint ℂ) := by
+    funext z
+    exact (RiemannMapping.triangleOnePointRepresentative_homeomorph z).symm
+  rw [he, ← Filter.tendsto_map'_iff, Filter.map_comap_setCoe_val]
+  rfl
+
+private theorem SpecialPeriods.Triangle.triangleClosedInteriorDiscHomeomorph_inverse_coe (z : ℂ) :
+    ((RiemannBoundary.discHomeomorphInverse triangleClosedInteriorDiscHomeomorph z :
+          TriangleClosedDomain) :
+        OnePoint ℂ) =
+      RiemannBoundary.discHomeomorphInverse RiemannMapping.triangleDiscOnOnePointDomain z := by
+  classical
+  unfold RiemannBoundary.discHomeomorphInverse
+  split_ifs <;> rfl
+
+private theorem SpecialPeriods.Triangle.triangleClosedInterior_inverse_tendsto_iff
+    (x : TriangleClosedDomain) {l : Filter ℂ} :
+    Filter.Tendsto (RiemannBoundary.discHomeomorphInverse triangleClosedInteriorDiscHomeomorph) l
+        (𝓝 x) ↔
+      Filter.Tendsto
+        (RiemannBoundary.discHomeomorphInverse RiemannMapping.triangleDiscOnOnePointDomain) l
+        (𝓝 x.val) := by
+  rw [tendsto_subtype_rng]
+  simp only [triangleClosedInteriorDiscHomeomorph_inverse_coe]
+
+private theorem SpecialPeriods.Triangle.triangleOnePointRepresentative_finite_tendsto_iff {a : ℂ}
+    {l : Filter ℂ} :
+    Filter.Tendsto RiemannMapping.triangleOnePointRepresentative
+        (𝓝[RiemannBoundary.onePointDomain triangleInterior] (a : OnePoint ℂ)) l ↔
+      Filter.Tendsto RiemannMapping.triangleMap (𝓝[triangleInterior] a) l := by
+  change
+    Filter.Tendsto RiemannMapping.triangleOnePointRepresentative
+        (𝓝[((↑) : ℂ → OnePoint ℂ) '' triangleInterior] (a : OnePoint ℂ)) l ↔
+      _
+  rw [OnePoint.nhdsWithin_coe_image, Filter.tendsto_map'_iff]
+  rfl
+
+private theorem SpecialPeriods.Triangle.triangleDiscOnOnePointDomain_inverse_coe (z : ℂ) :
+    RiemannBoundary.discHomeomorphInverse RiemannMapping.triangleDiscOnOnePointDomain z =
+      ((RiemannBoundary.discHomeomorphInverse RiemannMapping.triangleBiholomorph.toHomeomorph z :
+          ℂ) :
+        OnePoint ℂ) := by
+  classical
+  unfold RiemannBoundary.discHomeomorphInverse
+  split_ifs <;> rfl
+
+private theorem
+    SpecialPeriods.Triangle.triangleDiscOnOnePointDomain_finite_inverse_tendsto_iff {a : ℂ}
+    {l : Filter ℂ} :
+    Filter.Tendsto
+        (RiemannBoundary.discHomeomorphInverse RiemannMapping.triangleDiscOnOnePointDomain) l
+        (𝓝 (a : OnePoint ℂ)) ↔
+      Filter.Tendsto
+        (RiemannBoundary.discHomeomorphInverse RiemannMapping.triangleBiholomorph.toHomeomorph) l
+        (𝓝 a) := by
+  have h :=
+    (OnePoint.isOpenEmbedding_coe (X := ℂ)).isEmbedding.tendsto_nhds_iff (f :=
+      RiemannBoundary.discHomeomorphInverse RiemannMapping.triangleBiholomorph.toHomeomorph) (l :=
+      l) (y := a)
+  simpa only [Function.comp_def, ← triangleDiscOnOnePointDomain_inverse_coe] using h.symm
+
+private def RiemannMapping.triangleSideParameter (e : OpenPartialHomeomorph ℂ ℂ) (a w : ℂ) : ℂ :=
+  e.symm (w + e a)
+
+private theorem RiemannMapping.triangleSideParameter_zero (e : OpenPartialHomeomorph ℂ ℂ) {a : ℂ}
+    (ha : a ∈ e.source) : triangleSideParameter e a 0 = a := by
+  simp only [triangleSideParameter, zero_add, e.left_inv ha]
+
+private theorem
+    RiemannMapping.continuousAt_triangleSideParameter_zero (e : OpenPartialHomeomorph ℂ ℂ)
+    {a : ℂ} (ha : a ∈ e.source) : ContinuousAt (triangleSideParameter e a) 0 := by
+  have hi := e.continuousOn_symm.continuousAt (e.open_target.mem_nhds (e.map_source ha))
+  exact
+    ContinuousAt.comp (g := e.symm) (f := fun w : ℂ => w + e a) (x := 0)
+      (by simpa only [zero_add] using hi) (continuousAt_id.add_const (e a))
+
+private theorem
+    RiemannMapping.exists_triangleSideBoundaryGerm (e : OpenPartialHomeomorph ℂ ℂ) {a : ℂ}
+    (ha : a ∈ e.source) (he : AnalyticOnNhd ℂ e.symm e.target) (hreal : (e a).im = 0) {r : ℝ}
+    (hr : 0 < r)
+    (hside : ∀ z ∈ Metric.ball a r, z ∈ SpecialPeriods.Triangle.triangleInterior ↔ 0 < (e z).im) :
+    Nonempty (TriangleBoundaryGerm (triangleSideParameter e a)) := by
+  obtain ⟨δ, hδ, hδball⟩ := exists_boundary_chart_target_ball e ha hr
+  have hadd : ∀ w ∈ Metric.ball (0 : ℂ) δ, w + e a ∈ Metric.ball (e a) δ := by
+    intro w hw
+    simpa only [Metric.mem_ball, dist_eq_norm, add_sub_cancel_right, sub_zero] using hw
+  have hφ : AnalyticOnNhd ℂ (triangleSideParameter e a) (Metric.ball 0 δ) := by
+    intro w hw
+    exact
+      (he (w + e a) (hδball _ (hadd w hw)).1).comp (f := fun z : ℂ => z + e a)
+        (analyticAt_id.add analyticAt_const)
+  apply
+    exists_triangleBoundaryGerm hδ (hφ.mono Set.inter_subset_left)
+      (hφ.continuousOn.mono Set.inter_subset_left)
+  · intro w hw
+    apply (hside _ (hδball _ (hadd w hw.1)).2).mpr
+    rw [e.right_inv (hδball _ (hadd w hw.1)).1, Complex.add_im, hreal, add_zero]
+    exact hw.2
+  · intro t ht hin
+    have hi := (hside _ (hδball _ (hadd t ht)).2).mp hin
+    change 0 < (e (e.symm ((t : ℂ) + e a))).im at hi
+    rw [e.right_inv (hδball _ (hadd t ht)).1, Complex.add_im, Complex.ofReal_im, hreal,
+      add_zero] at hi
+    exact lt_irrefl _ hi
+
+private theorem
+    RiemannMapping.triangleSideBoundaryGerm_forward_limit (e : OpenPartialHomeomorph ℂ ℂ)
+    {a : ℂ} (ha : a ∈ e.source) (hreal : (e a).im = 0) {r : ℝ} (hr : 0 < r)
+    (hside : ∀ z ∈ Metric.ball a r, z ∈ SpecialPeriods.Triangle.triangleInterior ↔ 0 < (e z).im)
+    (g : TriangleBoundaryGerm (triangleSideParameter e a)) :
+    Filter.Tendsto triangleMap (𝓝[SpecialPeriods.Triangle.triangleInterior] a)
+      (𝓝 (g.function 0)) := by
+  have hec : ContinuousAt e a := e.continuousOn.continuousAt (e.open_source.mem_nhds ha)
+  have ht : Filter.Tendsto (fun z => e z - e a) (𝓝 a) (𝓝 (0 : ℂ)) := by
+    have hsub : Filter.Tendsto (fun z => e z - e a) (𝓝 a) (𝓝 (e a - e a)) :=
+      hec.tendsto.sub_const (e a)
+    simpa only [sub_self] using hsub
+  have hlim :
+    Filter.Tendsto (fun z => g.function (e z - e a))
+      (𝓝[SpecialPeriods.Triangle.triangleInterior] a) (𝓝 (g.function 0)) :=
+    ((g.analytic 0 (Metric.mem_ball_self g.radius_pos)).continuousAt.tendsto.comp ht).mono_left
+      nhdsWithin_le_nhds
+  have heq :
+    triangleMap =ᶠ[𝓝[SpecialPeriods.Triangle.triangleInterior] a]
+      (fun z => g.function (e z - e a)) := by
+    have hs : ∀ᶠ z in 𝓝[SpecialPeriods.Triangle.triangleInterior] a, z ∈ e.source :=
+      mem_nhdsWithin_of_mem_nhds (e.open_source.mem_nhds ha)
+    have hb : ∀ᶠ z in 𝓝[SpecialPeriods.Triangle.triangleInterior] a, z ∈ Metric.ball a r :=
+      mem_nhdsWithin_of_mem_nhds (Metric.ball_mem_nhds a hr)
+    have hp :
+      ∀ᶠ z in 𝓝[SpecialPeriods.Triangle.triangleInterior] a,
+        e z - e a ∈ Metric.ball (0 : ℂ) g.radius :=
+      (ht.eventually (Metric.ball_mem_nhds (0 : ℂ) g.radius_pos)).filter_mono nhdsWithin_le_nhds
+    filter_upwards [hs, hb, hp, self_mem_nhdsWithin] with z hz hbz hpz hzT
+    have hi : 0 < (e z - e a).im := by
+      rw [Complex.sub_im, hreal, sub_zero]
+      exact (hside z hbz).mp hzT
+    have hg := g.agrees ⟨hpz, hi⟩
+    simpa only [Function.comp_apply, triangleSideParameter, sub_add_cancel, e.left_inv hz] using
+      hg.symm
+  exact hlim.congr' heq.symm
+
+private theorem
+    RiemannMapping.triangleSideBoundaryGerm_inverse_limit (e : OpenPartialHomeomorph ℂ ℂ)
+    {a : ℂ} (ha : a ∈ e.source) (g : TriangleBoundaryGerm (triangleSideParameter e a)) :
+    Filter.Tendsto (RiemannBoundary.discHomeomorphInverse triangleBiholomorph.toHomeomorph)
+      (𝓝[Metric.ball (0 : ℂ) 1] (g.function 0)) (𝓝 a) := by
+  simpa only [triangleSideParameter_zero e ha] using
+    RiemannBoundary.tendsto_discHomeomorphInverse_of_boundary_chart
+      triangleBiholomorph.toHomeomorph triangleMap_biholomorph
+      (continuousAt_triangleSideParameter_zero e ha) g.strictDeriv g.deriv_ne_zero
+      g.sourceCorrespondence
+
+private theorem
+    RiemannMapping.exists_triangleMap_side_limits (e : OpenPartialHomeomorph ℂ ℂ) {a : ℂ}
+    (ha : a ∈ e.source) (he : AnalyticOnNhd ℂ e.symm e.target) (hreal : (e a).im = 0) {r : ℝ}
+    (hr : 0 < r)
+    (hside : ∀ z ∈ Metric.ball a r, z ∈ SpecialPeriods.Triangle.triangleInterior ↔ 0 < (e z).im) :
+    ∃ w : ℂ,
+      ‖w‖ = 1 ∧
+        Filter.Tendsto triangleMap (𝓝[SpecialPeriods.Triangle.triangleInterior] a) (𝓝 w) ∧
+          Filter.Tendsto (RiemannBoundary.discHomeomorphInverse triangleBiholomorph.toHomeomorph)
+            (𝓝[Metric.ball (0 : ℂ) 1] w) (𝓝 a) := by
+  obtain ⟨g⟩ := exists_triangleSideBoundaryGerm e ha he hreal hr hside
+  exact
+    ⟨g.function 0, g.unit, triangleSideBoundaryGerm_forward_limit e ha hreal hr hside g,
+      triangleSideBoundaryGerm_inverse_limit e ha g⟩
+
+private theorem RiemannMapping.exists_triangleMap_circle_side_limits {a : ℂ}
+    (haL : SpecialPeriods.Triangle.stripLeft < a.re) (haR : a.re < -1 / 2) (hai : 0 < a.im)
+    (haC : ‖a + 1‖ = 1) :
+    ∃ w : ℂ,
+      ‖w‖ = 1 ∧
+        Filter.Tendsto triangleMap (𝓝[SpecialPeriods.Triangle.triangleInterior] a) (𝓝 w) ∧
+          Filter.Tendsto (RiemannBoundary.discHomeomorphInverse triangleBiholomorph.toHomeomorph)
+            (𝓝[Metric.ball (0 : ℂ) 1] w) (𝓝 a) := by
+  obtain ⟨r, hr, hside⟩ := SpecialPeriods.Triangle.exists_circle_side_neighborhood haL haR hai
+  have ha : a ∈ SpecialPeriods.Triangle.circleBoundaryChart.source :=
+    (hside a (Metric.mem_ball_self hr)).1
+  exact
+    exists_triangleMap_side_limits SpecialPeriods.Triangle.circleBoundaryChart ha
+      SpecialPeriods.Triangle.circleUnstraighten_analyticOnNhd
+      ((SpecialPeriods.Triangle.circleStraighten_im_eq_zero_iff ha).mpr haC) hr
+      (fun z hz => (hside z hz).2)
+
+private theorem RiemannMapping.exists_triangleMap_left_side_limits {a : ℂ}
+    (ha : a.re = SpecialPeriods.Triangle.stripLeft) (hai : 0 < a.im) (haC : 1 < ‖a + 1‖) :
+    ∃ w : ℂ,
+      ‖w‖ = 1 ∧
+        Filter.Tendsto triangleMap (𝓝[SpecialPeriods.Triangle.triangleInterior] a) (𝓝 w) ∧
+          Filter.Tendsto (RiemannBoundary.discHomeomorphInverse triangleBiholomorph.toHomeomorph)
+            (𝓝[Metric.ball (0 : ℂ) 1] w) (𝓝 a) := by
+  obtain ⟨r, hr, hside⟩ := SpecialPeriods.Triangle.exists_left_side_neighborhood ha hai haC
+  apply
+    exists_triangleMap_side_limits
+      SpecialPeriods.Triangle.leftBoundaryChart.toOpenPartialHomeomorph (Set.mem_univ a)
+      (fun z _ => SpecialPeriods.Triangle.leftBoundaryChart_symm_analyticAt z)
+  · change (SpecialPeriods.Triangle.leftBoundaryChart a).im = 0
+    simp [ha]
+  · exact hr
+  · exact hside
+
+private theorem RiemannMapping.exists_triangleMap_right_side_limits {a : ℂ} (ha : a.re = -1 / 2)
+    (hai : 0 < a.im) (haC : 1 < ‖a + 1‖) :
+    ∃ w : ℂ,
+      ‖w‖ = 1 ∧
+        Filter.Tendsto triangleMap (𝓝[SpecialPeriods.Triangle.triangleInterior] a) (𝓝 w) ∧
+          Filter.Tendsto (RiemannBoundary.discHomeomorphInverse triangleBiholomorph.toHomeomorph)
+            (𝓝[Metric.ball (0 : ℂ) 1] w) (𝓝 a) := by
+  obtain ⟨r, hr, hside⟩ := SpecialPeriods.Triangle.exists_right_side_neighborhood ha hai haC
+  apply
+    exists_triangleMap_side_limits
+      SpecialPeriods.Triangle.rightBoundaryChart.toOpenPartialHomeomorph (Set.mem_univ a)
+      (fun z _ => SpecialPeriods.Triangle.rightBoundaryChart_symm_analyticAt z)
+  · change (SpecialPeriods.Triangle.rightBoundaryChart a).im = 0
+    norm_num [SpecialPeriods.Triangle.rightBoundaryChart_im, ha]
+  · exact hr
+  · exact hside
+
+private def SpecialPeriods.Triangle.cornerCoordinate (a : UpperHalfPlane) (z : ℂ) : ℂ :=
+  (z - a) / (z - conj (a : ℂ))
+
+@[simp]
+private theorem SpecialPeriods.Triangle.cornerCoordinate_self (a : UpperHalfPlane) :
+    cornerCoordinate a a = 0 := by simp [cornerCoordinate]
+
+private theorem SpecialPeriods.Triangle.cornerCoordinate_analyticAt (a : UpperHalfPlane) {z : ℂ}
+    (hz : z - conj (a : ℂ) ≠ 0) : AnalyticAt ℂ (cornerCoordinate a) z :=
+  (analyticAt_id.sub analyticAt_const).div (analyticAt_id.sub analyticAt_const) hz
+
+private theorem SpecialPeriods.Triangle.cornerCoordinate_analyticAt_self (a : UpperHalfPlane) :
+    AnalyticAt ℂ (cornerCoordinate a) (a : ℂ) :=
+  cornerCoordinate_analyticAt a (sub_conj_ne_zero a a)
+
+private theorem SpecialPeriods.Triangle.cayley_cornerCoordinate (a : UpperHalfPlane) {z : ℂ}
+    (hz : 0 < z.im) : SpecialPeriods.cayley a (cornerCoordinate a z) = z := by
+  have he := congrArg (fun w : UpperHalfPlane => (w : ℂ)) (fromDisc_toDisc a ⟨z, hz⟩)
+  simpa only [fromDisc_val, toDisc_val, cornerCoordinate, cayleyCoordinate] using he
+
+private def SpecialPeriods.Triangle.cornerPowerThree (z : ℂ) : ℂ :=
+  cornerCoordinate centerOne z ^ 3
+
+private def SpecialPeriods.Triangle.cornerPowerFour (z : ℂ) : ℂ :=
+  -(cornerCoordinate centerTwo z ^ 4)
+
+private theorem
+    SpecialPeriods.Triangle.cornerPowerThree_center : cornerPowerThree centerOne = 0 := by
+  simp only [cornerPowerThree, cornerCoordinate_self, zero_pow, ne_eq, OfNat.ofNat_ne_zero,
+    not_false_eq_true]
+
+private theorem SpecialPeriods.Triangle.cornerPowerFour_center : cornerPowerFour centerTwo = 0 := by
+  simp only [cornerPowerFour, cornerCoordinate_self, zero_pow, ne_eq, OfNat.ofNat_ne_zero,
+    not_false_eq_true, neg_zero]
+
+private theorem SpecialPeriods.Triangle.cornerPowerThree_analyticAt_center :
+    AnalyticAt ℂ cornerPowerThree (centerOne : ℂ) :=
+  (cornerCoordinate_analyticAt_self centerOne).pow 3
+
+private theorem SpecialPeriods.Triangle.cornerPowerFour_analyticAt_center :
+    AnalyticAt ℂ cornerPowerFour (centerTwo : ℂ) :=
+  ((cornerCoordinate_analyticAt_self centerTwo).pow 4).neg
+
+private theorem
+    SpecialPeriods.Triangle.exists_cornerCoordinate_neighborhood (a : UpperHalfPlane) {r : ℝ}
+    (hr : 0 < r) :
+    ∃ ε : ℝ, 0 < ε ∧ ∀ z ∈ Metric.ball (a : ℂ) ε, 0 < z.im ∧ ‖cornerCoordinate a z‖ < r := by
+  have him : ∀ᶠ z : ℂ in 𝓝 (a : ℂ), 0 < z.im :=
+    continuousAt_const.eventually_lt Complex.continuous_im.continuousAt a.im_pos
+  have hnorm : ∀ᶠ z : ℂ in 𝓝 (a : ℂ), ‖cornerCoordinate a z‖ < r :=
+    (cornerCoordinate_analyticAt_self a).continuousAt.norm.eventually_lt continuousAt_const
+      (by simpa only [cornerCoordinate_self, norm_zero] using hr)
+  exact Metric.mem_nhds_iff.mp (him.and hnorm)
+
+private theorem SpecialPeriods.Triangle.exists_cornerThree_neighborhood :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∀ z ∈ Metric.ball (centerOne : ℂ) ε,
+          0 < z.im ∧ (z ∈ triangleInterior ↔ cornerCoordinate centerOne z ∈ cornerSectorThree) := by
+  obtain ⟨r, hr, _, hsector⟩ := exists_cornerThree_radius
+  obtain ⟨ε, hε, hball⟩ := exists_cornerCoordinate_neighborhood centerOne hr
+  refine ⟨ε, hε, ?_⟩
+  intro z hz
+  have h := hball z hz
+  refine ⟨h.1, ?_⟩
+  have he := hsector _ h.2
+  rwa [cayley_cornerCoordinate centerOne h.1] at he
+
+private theorem SpecialPeriods.Triangle.exists_cornerFour_neighborhood :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∀ z ∈ Metric.ball (centerTwo : ℂ) ε,
+          0 < z.im ∧ (z ∈ triangleInterior ↔ cornerCoordinate centerTwo z ∈ cornerSectorFour) := by
+  obtain ⟨r, hr, _, hsector⟩ := exists_cornerFour_radius
+  obtain ⟨ε, hε, hball⟩ := exists_cornerCoordinate_neighborhood centerTwo hr
+  refine ⟨ε, hε, ?_⟩
+  intro z hz
+  have h := hball z hz
+  refine ⟨h.1, ?_⟩
+  have he := hsector _ h.2
+  rwa [cayley_cornerCoordinate centerTwo h.1] at he
+
+private theorem
+    SpecialPeriods.Triangle.cornerSectorThree_re_pos {z : ℂ} (hz : z ∈ cornerSectorThree) :
+    0 < z.re := by
+  change 0 < z.im ∧ Real.sqrt 3 * z.im < 3 * z.re at hz
+  have hsqrt : 0 < Real.sqrt 3 := Real.sqrt_pos.mpr (by norm_num)
+  nlinarith [mul_pos hsqrt hz.1]
+
+private theorem SpecialPeriods.Triangle.cornerSectorThree_arg {z : ℂ} (hz : z ∈ cornerSectorThree) :
+    z.arg ∈ Set.Ioo 0 (Real.pi / 3) := by
+  have hr := cornerSectorThree_re_pos hz
+  change 0 < z.im ∧ Real.sqrt 3 * z.im < 3 * z.re at hz
+  have hsqrt : 0 < Real.sqrt 3 := Real.sqrt_pos.mpr (by norm_num)
+  have hsq : Real.sqrt 3 * Real.sqrt 3 = 3 := Real.mul_self_sqrt (by norm_num)
+  have hm : Real.sqrt 3 * z.im < Real.sqrt 3 * (Real.sqrt 3 * z.re) := by
+    rw [← mul_assoc, hsq]
+    exact hz.2
+  have him : z.im < Real.sqrt 3 * z.re := (mul_lt_mul_iff_right₀ hsqrt).mp hm
+  have hargHalf : z.arg ∈ Set.Ioo (-(Real.pi / 2)) (Real.pi / 2) :=
+    abs_lt.mp (Complex.abs_arg_lt_pi_div_two_iff.mpr (Or.inl hr))
+  have hthird : Real.pi / 3 ∈ Set.Ioo (-(Real.pi / 2)) (Real.pi / 2) := by
+    constructor <;> linarith [Real.pi_pos]
+  have htan : Real.tan z.arg < Real.tan (Real.pi / 3) := by
+    rw [Complex.tan_arg, Real.tan_pi_div_three]
+    exact (div_lt_iff₀ hr).mpr him
+  have harg0 : 0 < z.arg := by
+    have hn : z.arg ≠ 0 := fun h => (ne_of_gt hz.1) (Complex.arg_eq_zero_iff.mp h).2
+    exact lt_of_le_of_ne (Complex.arg_nonneg_iff.mpr hz.1.le) hn.symm
+  exact ⟨harg0, (Real.strictMonoOn_tan.lt_iff_lt hargHalf hthird).mp htan⟩
+
+private theorem
+    SpecialPeriods.Triangle.cornerSectorThree_root_pow {z : ℂ} (hz : z ∈ cornerSectorThree) :
+    RiemannBoundary.principalRoot 3 (z ^ 3) = z := by
+  apply RiemannBoundary.principalRoot_pow_of_sector (by norm_num : 0 < 3)
+  exact ⟨(cornerSectorThree_arg hz).1.le, (cornerSectorThree_arg hz).2.le⟩
+
+private theorem SpecialPeriods.Triangle.im_pos_of_principalRoot_arg_mo1973_19574 {n : ℕ}
+    (hn : 0 < n) {z : ℂ}
+    (ha : (RiemannBoundary.principalRoot n z).arg ∈ Set.Ioo 0 (Real.pi / (n : ℝ))) : 0 < z.im := by
+  rw [RiemannBoundary.arg_principalRoot hn] at ha
+  have hnR : (0 : ℝ) < n := Nat.cast_pos.mpr hn
+  have harg0 : 0 < z.arg := (div_pos_iff_of_pos_right hnR).mp ha.1
+  have hargPi : z.arg < Real.pi := (div_lt_div_iff_of_pos_right hnR).mp ha.2
+  have hz0 : z ≠ 0 := by
+    intro hz
+    simp only [hz, Complex.arg_zero, lt_self_iff_false] at harg0
+  rw [← Complex.norm_mul_sin_arg]
+  exact mul_pos (norm_pos_iff.mpr hz0) (Real.sin_pos_of_pos_of_lt_pi harg0 hargPi)
+
+private theorem SpecialPeriods.Triangle.cornerSectorThree_pow_im_pos {z : ℂ}
+    (hz : z ∈ cornerSectorThree) : 0 < (z ^ 3).im := by
+  apply im_pos_of_principalRoot_arg_mo1973_19574 (by norm_num : 0 < 3)
+  rw [cornerSectorThree_root_pow hz]
+  exact cornerSectorThree_arg hz
+
+private theorem
+    SpecialPeriods.Triangle.cornerSectorFour_re_pos {z : ℂ} (hz : z ∈ cornerSectorFour) :
+    0 < z.re := by
+  change z.im < 0 ∧ 0 < z.re + z.im at hz
+  linarith [hz.1, hz.2]
+
+private theorem SpecialPeriods.Triangle.cornerSectorFour_arg {z : ℂ} (hz : z ∈ cornerSectorFour) :
+    z.arg ∈ Set.Ioo (-Real.pi / 4) 0 := by
+  have hr := cornerSectorFour_re_pos hz
+  change z.im < 0 ∧ 0 < z.re + z.im at hz
+  have hargHalf : z.arg ∈ Set.Ioo (-(Real.pi / 2)) (Real.pi / 2) :=
+    abs_lt.mp (Complex.abs_arg_lt_pi_div_two_iff.mpr (Or.inl hr))
+  have hfourth : -Real.pi / 4 ∈ Set.Ioo (-(Real.pi / 2)) (Real.pi / 2) := by
+    constructor <;> linarith [Real.pi_pos]
+  have htan : Real.tan (-Real.pi / 4) < Real.tan z.arg := by
+    rw [neg_div, Real.tan_neg, Real.tan_pi_div_four, Complex.tan_arg]
+    apply (lt_div_iff₀ hr).mpr
+    linarith [hz.2]
+  exact ⟨(Real.strictMonoOn_tan.lt_iff_lt hfourth hargHalf).mp htan, Complex.arg_neg_iff.mpr hz.1⟩
+
+private theorem SpecialPeriods.Triangle.quarticRootRotation_arg :
+    RiemannBoundary.quarticRootRotation.arg = -Real.pi / 4 := by
+  rw [RiemannBoundary.quarticRootRotation, Complex.arg_exp_mul_I]
+  apply (toIocMod_eq_self Real.two_pi_pos).mpr
+  constructor <;> linarith [Real.pi_pos]
+
+private theorem SpecialPeriods.Triangle.quarticRootRotation_inv_arg :
+    (RiemannBoundary.quarticRootRotation⁻¹).arg = Real.pi / 4 := by
+  rw [Complex.arg_inv, quarticRootRotation_arg]
+  have hn : -Real.pi / 4 ≠ Real.pi := by linarith [Real.pi_pos]
+  rw [ite_eq_right hn]
+  ring
+
+private theorem SpecialPeriods.Triangle.cornerSectorFour_unrotate_arg {z : ℂ}
+    (hz : z ∈ cornerSectorFour) :
+    (RiemannBoundary.quarticRootRotation⁻¹ * z).arg ∈ Set.Ioo 0 (Real.pi / 4) := by
+  have ha := cornerSectorFour_arg hz
+  have hz0 : z ≠ 0 := by
+    intro h
+    have hi := hz.1
+    simp only [h, Complex.zero_im, lt_self_iff_false] at hi
+  have hsum : (RiemannBoundary.quarticRootRotation⁻¹).arg + z.arg ∈ Set.Ioc (-Real.pi) Real.pi := by
+    rw [quarticRootRotation_inv_arg]
+    constructor <;> linarith [ha.1, ha.2, Real.pi_pos]
+  rw [Complex.arg_mul (inv_ne_zero RiemannBoundary.quarticRootRotation_ne_zero) hz0 hsum,
+    quarticRootRotation_inv_arg]
+  constructor <;> linarith [ha.1, ha.2]
+
+private theorem SpecialPeriods.Triangle.quarticRootRotation_inv_mul_pow_four (z : ℂ) :
+    (RiemannBoundary.quarticRootRotation⁻¹ * z) ^ 4 = -(z ^ 4) := by
+  rw [mul_pow, inv_pow, RiemannBoundary.quarticRootRotation_pow_four]
+  norm_num
+
+private theorem SpecialPeriods.Triangle.cornerSectorFour_unrotate_root_pow {z : ℂ}
+    (hz : z ∈ cornerSectorFour) :
+    RiemannBoundary.principalRoot 4 (-(z ^ 4)) = RiemannBoundary.quarticRootRotation⁻¹ * z := by
+  rw [← quarticRootRotation_inv_mul_pow_four]
+  apply RiemannBoundary.principalRoot_pow_of_sector (by norm_num : 0 < 4)
+  exact ⟨(cornerSectorFour_unrotate_arg hz).1.le, (cornerSectorFour_unrotate_arg hz).2.le⟩
+
+private theorem
+    SpecialPeriods.Triangle.cornerSectorFour_root_pow {z : ℂ} (hz : z ∈ cornerSectorFour) :
+    RiemannBoundary.rotatedPrincipalRootFour (-(z ^ 4)) = z := by
+  rw [RiemannBoundary.rotatedPrincipalRootFour, cornerSectorFour_unrotate_root_pow hz, ←
+    mul_assoc, mul_inv_cancel₀ RiemannBoundary.quarticRootRotation_ne_zero, one_mul]
+
+private theorem
+    SpecialPeriods.Triangle.cornerSectorFour_pow_im_pos {z : ℂ} (hz : z ∈ cornerSectorFour) :
+    0 < (-(z ^ 4)).im := by
+  apply im_pos_of_principalRoot_arg_mo1973_19574 (by norm_num : 0 < 4)
+  rw [cornerSectorFour_unrotate_root_pow hz]
+  exact cornerSectorFour_unrotate_arg hz
+
+private theorem SpecialPeriods.Triangle.cornerParameterThree_cornerPower {z : ℂ} (hzi : 0 < z.im)
+    (hz : cornerCoordinate centerOne z ∈ cornerSectorThree) :
+    cornerParameterThree (cornerPowerThree z) = z := by
+  change
+    SpecialPeriods.cayley centerOne
+        (RiemannBoundary.principalRoot 3 (cornerCoordinate centerOne z ^ 3)) =
+      z
+  rw [cornerSectorThree_root_pow hz, cayley_cornerCoordinate centerOne hzi]
+
+private theorem SpecialPeriods.Triangle.cornerParameterFour_cornerPower {z : ℂ} (hzi : 0 < z.im)
+    (hz : cornerCoordinate centerTwo z ∈ cornerSectorFour) :
+    cornerParameterFour (cornerPowerFour z) = z := by
+  change
+    SpecialPeriods.cayley centerTwo
+        (RiemannBoundary.rotatedPrincipalRootFour (-(cornerCoordinate centerTwo z ^ 4))) =
+      z
+  rw [cornerSectorFour_root_pow hz, cayley_cornerCoordinate centerTwo hzi]
+
+private theorem SpecialPeriods.Triangle.exists_cornerParameterThree_coverage {δ : ℝ} (hδ : 0 < δ) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∀ z ∈ Metric.ball (centerOne : ℂ) ε,
+          z ∈ triangleInterior →
+            cornerPowerThree z ∈ Metric.ball 0 δ ∩ {w : ℂ | 0 < w.im} ∧
+              cornerParameterThree (cornerPowerThree z) = z := by
+  obtain ⟨r, hr, hgeom⟩ := exists_cornerThree_neighborhood
+  have hp : ∀ᶠ z : ℂ in 𝓝 (centerOne : ℂ), ‖cornerPowerThree z‖ < δ :=
+    cornerPowerThree_analyticAt_center.continuousAt.norm.eventually_lt continuousAt_const
+      (by simpa only [cornerPowerThree_center, norm_zero] using hδ)
+  have hb : ∀ᶠ z : ℂ in 𝓝 (centerOne : ℂ), z ∈ Metric.ball (centerOne : ℂ) r :=
+    Metric.ball_mem_nhds (centerOne : ℂ) hr
+  obtain ⟨ε, hε, hball⟩ := Metric.mem_nhds_iff.mp (hb.and hp)
+  refine ⟨ε, hε, ?_⟩
+  intro z hz hT
+  have hnear := hball hz
+  have h := hgeom z hnear.1
+  have hs := h.2.mp hT
+  refine
+    ⟨⟨by simpa only [Metric.mem_ball, dist_zero_right] using hnear.2, ?_⟩,
+      cornerParameterThree_cornerPower h.1 hs⟩
+  exact cornerSectorThree_pow_im_pos hs
+
+private theorem SpecialPeriods.Triangle.exists_cornerParameterFour_coverage {δ : ℝ} (hδ : 0 < δ) :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        ∀ z ∈ Metric.ball (centerTwo : ℂ) ε,
+          z ∈ triangleInterior →
+            cornerPowerFour z ∈ Metric.ball 0 δ ∩ {w : ℂ | 0 < w.im} ∧
+              cornerParameterFour (cornerPowerFour z) = z := by
+  obtain ⟨r, hr, hgeom⟩ := exists_cornerFour_neighborhood
+  have hp : ∀ᶠ z : ℂ in 𝓝 (centerTwo : ℂ), ‖cornerPowerFour z‖ < δ :=
+    cornerPowerFour_analyticAt_center.continuousAt.norm.eventually_lt continuousAt_const
+      (by simpa only [cornerPowerFour_center, norm_zero] using hδ)
+  have hb : ∀ᶠ z : ℂ in 𝓝 (centerTwo : ℂ), z ∈ Metric.ball (centerTwo : ℂ) r :=
+    Metric.ball_mem_nhds (centerTwo : ℂ) hr
+  obtain ⟨ε, hε, hball⟩ := Metric.mem_nhds_iff.mp (hb.and hp)
+  refine ⟨ε, hε, ?_⟩
+  intro z hz hT
+  have hnear := hball hz
+  have h := hgeom z hnear.1
+  have hs := h.2.mp hT
+  refine
+    ⟨⟨by simpa only [Metric.mem_ball, dist_zero_right] using hnear.2, ?_⟩,
+      cornerParameterFour_cornerPower h.1 hs⟩
+  exact cornerSectorFour_pow_im_pos hs
+
+private def RiemannMapping.triangleCornerThreePatch : ℂ → ℂ :=
+  triangleCornerThreeGerm.function ∘ SpecialPeriods.Triangle.cornerPowerThree
+
+private def RiemannMapping.triangleCornerFourPatch : ℂ → ℂ :=
+  triangleCornerFourGerm.function ∘ SpecialPeriods.Triangle.cornerPowerFour
+
+private theorem RiemannMapping.triangleCornerThreePatch_center :
+    triangleCornerThreePatch SpecialPeriods.Triangle.centerOne =
+      triangleCornerThreeGerm.function 0 := by
+  simp only [triangleCornerThreePatch, Function.comp_apply,
+    SpecialPeriods.Triangle.cornerPowerThree_center]
+
+private theorem RiemannMapping.triangleCornerFourPatch_center :
+    triangleCornerFourPatch SpecialPeriods.Triangle.centerTwo =
+      triangleCornerFourGerm.function 0 := by
+  simp only [triangleCornerFourPatch, Function.comp_apply,
+    SpecialPeriods.Triangle.cornerPowerFour_center]
+
+private theorem RiemannMapping.triangleCornerThreePatch_analyticAt :
+    AnalyticAt ℂ triangleCornerThreePatch (SpecialPeriods.Triangle.centerOne : ℂ) := by
+  have hH :
+    AnalyticAt ℂ triangleCornerThreeGerm.function
+      (SpecialPeriods.Triangle.cornerPowerThree SpecialPeriods.Triangle.centerOne) := by
+    rw [SpecialPeriods.Triangle.cornerPowerThree_center]
+    exact
+      triangleCornerThreeGerm.analytic 0 (Metric.mem_ball_self triangleCornerThreeGerm.radius_pos)
+  exact hH.comp SpecialPeriods.Triangle.cornerPowerThree_analyticAt_center
+
+private theorem RiemannMapping.triangleCornerFourPatch_analyticAt :
+    AnalyticAt ℂ triangleCornerFourPatch (SpecialPeriods.Triangle.centerTwo : ℂ) := by
+  have hH :
+    AnalyticAt ℂ triangleCornerFourGerm.function
+      (SpecialPeriods.Triangle.cornerPowerFour SpecialPeriods.Triangle.centerTwo) := by
+    rw [SpecialPeriods.Triangle.cornerPowerFour_center]
+    exact
+      triangleCornerFourGerm.analytic 0 (Metric.mem_ball_self triangleCornerFourGerm.radius_pos)
+  exact hH.comp SpecialPeriods.Triangle.cornerPowerFour_analyticAt_center
+
+private theorem RiemannMapping.exists_triangleCornerThreePatch_agrees :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        Set.EqOn triangleCornerThreePatch triangleMap
+          (Metric.ball (SpecialPeriods.Triangle.centerOne : ℂ) ε ∩
+            SpecialPeriods.Triangle.triangleInterior) := by
+  obtain ⟨ε, hε, hcover⟩ :=
+    SpecialPeriods.Triangle.exists_cornerParameterThree_coverage
+      triangleCornerThreeGerm.radius_pos
+  refine ⟨ε, hε, ?_⟩
+  intro z hz
+  have hc := hcover z hz.1 hz.2
+  have he := triangleCornerThreeGerm.agrees hc.1
+  change
+    triangleCornerThreeGerm.function (SpecialPeriods.Triangle.cornerPowerThree z) = triangleMap z
+  simpa only [Function.comp_apply, hc.2] using he
+
+private theorem RiemannMapping.exists_triangleCornerFourPatch_agrees :
+    ∃ ε : ℝ,
+      0 < ε ∧
+        Set.EqOn triangleCornerFourPatch triangleMap
+          (Metric.ball (SpecialPeriods.Triangle.centerTwo : ℂ) ε ∩
+            SpecialPeriods.Triangle.triangleInterior) := by
+  obtain ⟨ε, hε, hcover⟩ :=
+    SpecialPeriods.Triangle.exists_cornerParameterFour_coverage triangleCornerFourGerm.radius_pos
+  refine ⟨ε, hε, ?_⟩
+  intro z hz
+  have hc := hcover z hz.1 hz.2
+  have he := triangleCornerFourGerm.agrees hc.1
+  change
+    triangleCornerFourGerm.function (SpecialPeriods.Triangle.cornerPowerFour z) = triangleMap z
+  simpa only [Function.comp_apply, hc.2] using he
+
+private theorem RiemannMapping.triangleCornerThreePatch_eventuallyEq :
+    triangleCornerThreePatch =ᶠ[𝓝[SpecialPeriods.Triangle.triangleInterior]
+        (SpecialPeriods.Triangle.centerOne : ℂ)]
+      triangleMap := by
+  obtain ⟨ε, hε, he⟩ := exists_triangleCornerThreePatch_agrees
+  filter_upwards [self_mem_nhdsWithin,
+    mem_nhdsWithin_of_mem_nhds
+      (Metric.ball_mem_nhds (SpecialPeriods.Triangle.centerOne : ℂ) hε)] with
+    z hz hb
+  exact he ⟨hb, hz⟩
+
+private theorem RiemannMapping.triangleCornerFourPatch_eventuallyEq :
+    triangleCornerFourPatch =ᶠ[𝓝[SpecialPeriods.Triangle.triangleInterior]
+        (SpecialPeriods.Triangle.centerTwo : ℂ)]
+      triangleMap := by
+  obtain ⟨ε, hε, he⟩ := exists_triangleCornerFourPatch_agrees
+  filter_upwards [self_mem_nhdsWithin,
+    mem_nhdsWithin_of_mem_nhds
+      (Metric.ball_mem_nhds (SpecialPeriods.Triangle.centerTwo : ℂ) hε)] with
+    z hz hb
+  exact he ⟨hb, hz⟩
+
+private theorem RiemannMapping.triangleCornerThree_forward_limit :
+    Filter.Tendsto triangleMap
+      (𝓝[SpecialPeriods.Triangle.triangleInterior] (SpecialPeriods.Triangle.centerOne : ℂ))
+      (𝓝 (triangleCornerThreeGerm.function 0)) := by
+  have h :
+    Filter.Tendsto triangleCornerThreePatch
+      (𝓝[SpecialPeriods.Triangle.triangleInterior] (SpecialPeriods.Triangle.centerOne : ℂ))
+      (𝓝 (triangleCornerThreePatch SpecialPeriods.Triangle.centerOne)) :=
+    triangleCornerThreePatch_analyticAt.continuousAt.tendsto.mono_left nhdsWithin_le_nhds
+  rw [triangleCornerThreePatch_center] at h
+  exact h.congr' triangleCornerThreePatch_eventuallyEq
+
+private theorem RiemannMapping.triangleCornerFour_forward_limit :
+    Filter.Tendsto triangleMap
+      (𝓝[SpecialPeriods.Triangle.triangleInterior] (SpecialPeriods.Triangle.centerTwo : ℂ))
+      (𝓝 (triangleCornerFourGerm.function 0)) := by
+  have h :
+    Filter.Tendsto triangleCornerFourPatch
+      (𝓝[SpecialPeriods.Triangle.triangleInterior] (SpecialPeriods.Triangle.centerTwo : ℂ))
+      (𝓝 (triangleCornerFourPatch SpecialPeriods.Triangle.centerTwo)) :=
+    triangleCornerFourPatch_analyticAt.continuousAt.tendsto.mono_left nhdsWithin_le_nhds
+  rw [triangleCornerFourPatch_center] at h
+  exact h.congr' triangleCornerFourPatch_eventuallyEq
+
+private def RiemannBoundary.halfStripExp (a c : ℝ) (z : ℂ) : ℂ :=
+  Complex.exp (Complex.I * (z - a) / c)
+
+private theorem RiemannBoundary.logHalfStrip_halfStripExp (a : ℝ) {c : ℝ} (hc : 0 < c) {z : ℂ}
+    (hz : z.re ∈ Set.Ioo a (a + c * Real.pi)) : logHalfStrip a c (halfStripExp a c z) = z := by
+  have hcC : (c : ℂ) ≠ 0 := Complex.ofReal_ne_zero.mpr hc.ne'
+  have him : (Complex.I * (z - a) / c).im = (z.re - a) / c := by simp
+  have hpos : 0 < (Complex.I * (z - a) / c).im := by
+    rw [him]
+    exact div_pos (sub_pos.mpr hz.1) hc
+  have hpi : (Complex.I * (z - a) / c).im < Real.pi := by
+    rw [him, div_lt_iff₀ hc]
+    linarith [hz.2]
+  rw [logHalfStrip, halfStripExp, Complex.log_exp (by linarith [Real.pi_pos]) hpi.le]
+  field_simp
+  ring_nf
+  simp
+
+@[simp]
+private theorem RiemannBoundary.norm_halfStripExp (a c : ℝ) (z : ℂ) :
+    ‖halfStripExp a c z‖ = Real.exp (-z.im / c) := by simp [halfStripExp, Complex.norm_exp]
+
+private theorem RiemannBoundary.halfStripExp_im_pos (a : ℝ) {c : ℝ} (hc : 0 < c) {z : ℂ}
+    (hz : z.re ∈ Set.Ioo a (a + c * Real.pi)) : 0 < (halfStripExp a c z).im := by
+  rw [halfStripExp, Complex.exp_im]
+  apply mul_pos (Real.exp_pos _)
+  apply Real.sin_pos_of_pos_of_lt_pi
+  · simp only [Complex.div_ofReal_im, Complex.mul_im, Complex.I_re, Complex.sub_im,
+      Complex.ofReal_im, MulZeroClass.zero_mul, Complex.I_im, Complex.sub_re, Complex.ofReal_re,
+      one_mul, zero_add]
+    exact div_pos (sub_pos.mpr hz.1) hc
+  · simp only [Complex.div_ofReal_im, Complex.mul_im, Complex.I_re, Complex.sub_im,
+      Complex.ofReal_im, MulZeroClass.zero_mul, Complex.I_im, Complex.sub_re, Complex.ofReal_re,
+      one_mul, zero_add]
+    rw [div_lt_iff₀ hc]
+    linarith [hz.2]
+
+private def RiemannMapping.triangleCuspExp : ℂ → ℂ :=
+  RiemannBoundary.halfStripExp SpecialPeriods.Triangle.stripLeft triangleCuspScale
+
+@[simp]
+private theorem RiemannMapping.norm_triangleCuspExp (z : ℂ) :
+    ‖triangleCuspExp z‖ = Real.exp (-z.im / triangleCuspScale) :=
+  RiemannBoundary.norm_halfStripExp _ _ _
+
+private theorem RiemannMapping.triangleCuspExp_im_pos {z : ℂ}
+    (hz : z ∈ SpecialPeriods.Triangle.triangleInterior) : 0 < (triangleCuspExp z).im := by
+  apply
+    RiemannBoundary.halfStripExp_im_pos SpecialPeriods.Triangle.stripLeft triangleCuspScale_pos
+  exact ⟨hz.1, by simpa only [triangleCuspScale_endpoint] using hz.2.1⟩
+
+private theorem RiemannMapping.triangleCuspLog_triangleCuspExp {z : ℂ}
+    (hz : z ∈ SpecialPeriods.Triangle.triangleInterior) :
+    triangleCuspLog (triangleCuspExp z) = z := by
+  apply
+    RiemannBoundary.logHalfStrip_halfStripExp SpecialPeriods.Triangle.stripLeft
+      triangleCuspScale_pos
+  exact ⟨hz.1, by simpa only [triangleCuspScale_endpoint] using hz.2.1⟩
+
+private def RiemannMapping.triangleInfinityFilter : Filter ℂ :=
+  Filter.cocompact ℂ ⊓ 𝓟 SpecialPeriods.Triangle.triangleInterior
+
+private theorem RiemannMapping.triangleInfinity_eventually_mem :
+    ∀ᶠ z in triangleInfinityFilter, z ∈ SpecialPeriods.Triangle.triangleInterior :=
+  (show
+        ∀ᶠ z in 𝓟 SpecialPeriods.Triangle.triangleInterior,
+          z ∈ SpecialPeriods.Triangle.triangleInterior
+        by simp).filter_mono
+    inf_le_right
+
+private theorem RiemannMapping.triangle_norm_add_stripLeft_le_im {z : ℂ}
+    (hz : z ∈ SpecialPeriods.Triangle.triangleInterior) :
+    ‖z‖ + SpecialPeriods.Triangle.stripLeft ≤ z.im := by
+  have hre : z.re < 0 := hz.2.1.trans (by norm_num)
+  have hnorm := Complex.norm_le_abs_re_add_abs_im z
+  rw [abs_of_neg hre, abs_of_pos hz.2.2.1] at hnorm
+  linarith [hz.1]
+
+private theorem RiemannMapping.tendsto_im_triangleInfinity :
+    Filter.Tendsto (fun z : ℂ => z.im) triangleInfinityFilter Filter.atTop := by
+  have hn : Filter.Tendsto (fun z : ℂ => ‖z‖) triangleInfinityFilter Filter.atTop :=
+    tendsto_norm_cocompact_atTop.mono_left inf_le_left
+  have hshift :
+    Filter.Tendsto (fun z : ℂ => ‖z‖ + SpecialPeriods.Triangle.stripLeft) triangleInfinityFilter
+      Filter.atTop :=
+    Filter.tendsto_atTop_add_const_right _ SpecialPeriods.Triangle.stripLeft hn
+  apply Filter.tendsto_atTop_mono' triangleInfinityFilter _ hshift
+  filter_upwards [triangleInfinity_eventually_mem] with z hz
+  exact triangle_norm_add_stripLeft_le_im hz
+
+private theorem RiemannMapping.tendsto_triangleCuspExp_triangleInfinity :
+    Filter.Tendsto triangleCuspExp triangleInfinityFilter (𝓝 0) := by
+  rw [tendsto_zero_iff_norm_tendsto_zero]
+  simp only [norm_triangleCuspExp]
+  apply Real.tendsto_exp_atBot.comp
+  have ht :=
+    Filter.tendsto_neg_atTop_atBot.comp
+      (tendsto_im_triangleInfinity.atTop_div_const triangleCuspScale_pos)
+  simpa only [Function.comp_def, neg_div] using ht
+
+private theorem RiemannMapping.triangleMap_eq_ideal_cusp_of_param_mem {z : ℂ}
+    (hz : z ∈ SpecialPeriods.Triangle.triangleInterior)
+    (hq : triangleCuspExp z ∈ Metric.ball (0 : ℂ) triangleIdealGerm.radius) :
+    triangleMap z = triangleIdealGerm.function (triangleCuspExp z) := by
+  have he := triangleIdealGerm.agrees ⟨hq, triangleCuspExp_im_pos hz⟩
+  simpa only [Function.comp_def, triangleCuspLog_triangleCuspExp hz] using he.symm
+
+private theorem RiemannMapping.triangleMap_eventually_eq_ideal_cusp :
+    triangleMap =ᶠ[triangleInfinityFilter]
+      (fun z => triangleIdealGerm.function (triangleCuspExp z)) := by
+  have hsmall :=
+    tendsto_triangleCuspExp_triangleInfinity.eventually
+      (Metric.ball_mem_nhds (0 : ℂ) triangleIdealGerm.radius_pos)
+  filter_upwards [triangleInfinity_eventually_mem, hsmall] with z hz hq
+  exact triangleMap_eq_ideal_cusp_of_param_mem hz hq
+
+private theorem RiemannMapping.triangleIdeal_forward_limit :
+    Filter.Tendsto triangleMap triangleInfinityFilter (𝓝 (triangleIdealGerm.function 0)) := by
+  have hc :=
+    (triangleIdealGerm.analytic 0
+        (Metric.mem_ball_self triangleIdealGerm.radius_pos)).continuousAt
+  exact
+    (hc.tendsto.comp tendsto_triangleCuspExp_triangleInfinity).congr'
+      triangleMap_eventually_eq_ideal_cusp.symm
+
+private theorem RiemannMapping.comap_coe_triangle_onePoint_nhds_infty :
+    Filter.comap ((↑) : ℂ → OnePoint ℂ)
+        (𝓝[RiemannBoundary.onePointDomain SpecialPeriods.Triangle.triangleInterior]
+          ((OnePoint.infty) : OnePoint ℂ)) =
+      triangleInfinityFilter := by
+  have hp :
+    ((↑) : ℂ → OnePoint ℂ) ⁻¹'
+        RiemannBoundary.onePointDomain SpecialPeriods.Triangle.triangleInterior =
+      SpecialPeriods.Triangle.triangleInterior :=
+    Set.ext fun _ => RiemannBoundary.coe_mem_onePointDomain
+  rw [nhdsWithin, Filter.comap_inf, OnePoint.comap_coe_nhds_infty,
+    Filter.coclosedCompact_eq_cocompact, Filter.comap_principal, hp]
+  rfl
+
+private theorem RiemannMapping.triangleIdeal_forward_limit_onePoint :
+    Filter.Tendsto triangleOnePointRepresentative
+      (𝓝[RiemannBoundary.onePointDomain SpecialPeriods.Triangle.triangleInterior]
+        ((OnePoint.infty) : OnePoint ℂ))
+      (𝓝 (triangleIdealGerm.function 0)) := by
+  have hRange :
+    Set.range ((↑) : ℂ → OnePoint ℂ) ∈
+      𝓝[RiemannBoundary.onePointDomain SpecialPeriods.Triangle.triangleInterior]
+        ((OnePoint.infty) : OnePoint ℂ) := by
+    apply Filter.mem_of_superset self_mem_nhdsWithin
+    rintro _ ⟨z, _, rfl⟩
+    exact Set.mem_range_self z
+  apply (Filter.tendsto_comap'_iff (i := ((↑) : ℂ → OnePoint ℂ)) hRange).mp
+  simpa only [Function.comp_def, triangleOnePointRepresentative_coe,
+    comap_coe_triangle_onePoint_nhds_infty] using triangleIdeal_forward_limit
+
+private theorem RiemannMapping.triangleClosed_finite_forward_limit
+    (x : SpecialPeriods.Triangle.TriangleClosedDomain) {a w : ℂ} (hxa : x.val = (a : OnePoint ℂ))
+    (hf : Filter.Tendsto triangleMap (𝓝[SpecialPeriods.Triangle.triangleInterior] a) (𝓝 w)) :
+    Filter.Tendsto
+      (fun z : SpecialPeriods.Triangle.triangleClosedInterior =>
+        (SpecialPeriods.Triangle.triangleClosedInteriorDiscHomeomorph z : ℂ))
+      (Filter.comap
+        (Subtype.val :
+          SpecialPeriods.Triangle.triangleClosedInterior →
+            SpecialPeriods.Triangle.TriangleClosedDomain)
+        (𝓝 x))
+      (𝓝 w) := by
+  apply (SpecialPeriods.Triangle.triangleClosedInterior_forward_representative_tendsto_iff x).mpr
+  rw [hxa]
+  exact SpecialPeriods.Triangle.triangleOnePointRepresentative_finite_tendsto_iff.mpr hf
+
+private theorem RiemannMapping.triangleClosed_finite_inverse_limit
+    (x : SpecialPeriods.Triangle.TriangleClosedDomain) {a w : ℂ} (hxa : x.val = (a : OnePoint ℂ))
+    (hi :
+      Filter.Tendsto (RiemannBoundary.discHomeomorphInverse triangleBiholomorph.toHomeomorph)
+        (𝓝[Metric.ball (0 : ℂ) 1] w) (𝓝 a)) :
+    Filter.Tendsto
+      (RiemannBoundary.discHomeomorphInverse
+        SpecialPeriods.Triangle.triangleClosedInteriorDiscHomeomorph)
+      (𝓝[Metric.ball (0 : ℂ) 1] w) (𝓝 x) := by
+  apply (SpecialPeriods.Triangle.triangleClosedInterior_inverse_tendsto_iff x).mpr
+  rw [hxa]
+  exact SpecialPeriods.Triangle.triangleDiscOnOnePointDomain_finite_inverse_tendsto_iff.mpr hi
+
+private theorem RiemannMapping.triangleClosedDiscBoundaryLimits :
+    RiemannBoundary.DiscBoundaryLimits
+      SpecialPeriods.Triangle.triangleClosedInteriorDiscHomeomorph := by
+  intro x hx
+  rcases SpecialPeriods.Triangle.triangleClosedBoundary_cases x hx with rfl | ⟨a, ha, hxa⟩ |
+    ⟨a, ha, hxa⟩ | ⟨a, ha, hxa⟩ | rfl | rfl
+  · exact
+      ⟨triangleIdealGerm.function 0, triangleIdealGerm.unit,
+        (SpecialPeriods.Triangle.triangleClosedInterior_forward_representative_tendsto_iff _).mpr
+          triangleIdeal_forward_limit_onePoint,
+        (SpecialPeriods.Triangle.triangleClosedInterior_inverse_tendsto_iff _).mpr
+          triangleIdeal_inverse_limit⟩
+  · obtain ⟨w, hw, hf, hi⟩ := exists_triangleMap_left_side_limits ha.1 ha.2.1 ha.2.2
+    exact
+      ⟨w, hw, triangleClosed_finite_forward_limit x hxa hf,
+        triangleClosed_finite_inverse_limit x hxa hi⟩
+  · obtain ⟨w, hw, hf, hi⟩ := exists_triangleMap_right_side_limits ha.1 ha.2.1 ha.2.2
+    exact
+      ⟨w, hw, triangleClosed_finite_forward_limit x hxa hf,
+        triangleClosed_finite_inverse_limit x hxa hi⟩
+  · obtain ⟨w, hw, hf, hi⟩ := exists_triangleMap_circle_side_limits ha.1 ha.2.1 ha.2.2.1 ha.2.2.2
+    exact
+      ⟨w, hw, triangleClosed_finite_forward_limit x hxa hf,
+        triangleClosed_finite_inverse_limit x hxa hi⟩
+  · exact
+      ⟨triangleCornerThreeGerm.function 0, triangleCornerThreeGerm.unit,
+        triangleClosed_finite_forward_limit _ rfl triangleCornerThree_forward_limit,
+        triangleClosed_finite_inverse_limit _ rfl triangleCornerThree_inverse_limit⟩
+  · exact
+      ⟨triangleCornerFourGerm.function 0, triangleCornerFourGerm.unit,
+        triangleClosed_finite_forward_limit _ rfl triangleCornerFour_forward_limit,
+        triangleClosed_finite_inverse_limit _ rfl triangleCornerFour_inverse_limit⟩
+
+private def RiemannMapping.triangleClosedDiscHomeomorph :
+    SpecialPeriods.Triangle.TriangleClosedDomain ≃ₜ Metric.closedBall (0 : ℂ) 1 :=
+  RiemannBoundary.closedDiscHomeomorph SpecialPeriods.Triangle.triangleClosedInterior_dense
+    SpecialPeriods.Triangle.triangleClosedInteriorDiscHomeomorph triangleClosedDiscBoundaryLimits
+
+private theorem RiemannMapping.triangleClosedDiscHomeomorph_interior
+    (z : SpecialPeriods.Triangle.triangleClosedInterior) :
+    (triangleClosedDiscHomeomorph z : ℂ) =
+      (SpecialPeriods.Triangle.triangleClosedInteriorDiscHomeomorph z : ℂ) :=
+  RiemannBoundary.closedDiscHomeomorph_coe SpecialPeriods.Triangle.triangleClosedInterior_dense
+    SpecialPeriods.Triangle.triangleClosedInteriorDiscHomeomorph triangleClosedDiscBoundaryLimits
+    z
+
+private theorem RiemannMapping.triangleClosedDiscHomeomorph_triangle (z : triangleDomain) :
+    (triangleClosedDiscHomeomorph (SpecialPeriods.Triangle.triangleClosedInclusion z) : ℂ) =
+      triangleMap z := by
+  rw [triangleMap_biholomorph z]
+  exact
+    (triangleClosedDiscHomeomorph_interior
+          (SpecialPeriods.Triangle.triangleClosedInteriorHomeomorph z)).trans
+      (congrArg (fun w : Metric.ball (0 : ℂ) 1 => (w : ℂ))
+        (SpecialPeriods.Triangle.triangleClosedInteriorDiscHomeomorph_apply z))
+
+private theorem RiemannMapping.triangleClosedDiscHomeomorph_boundary
+    {x : SpecialPeriods.Triangle.TriangleClosedDomain}
+    (hx : x ∉ SpecialPeriods.Triangle.triangleClosedInterior) :
+    ‖(triangleClosedDiscHomeomorph x : ℂ)‖ = 1 :=
+  (RiemannBoundary.discCompactificationMap_boundary
+      SpecialPeriods.Triangle.triangleClosedInterior_dense
+      SpecialPeriods.Triangle.triangleClosedInteriorDiscHomeomorph
+      triangleClosedDiscBoundaryLimits hx).1
+
+private theorem RiemannMapping.triangleClosedDiscHomeomorph_norm_lt_iff
+    (x : SpecialPeriods.Triangle.TriangleClosedDomain) :
+    ‖(triangleClosedDiscHomeomorph x : ℂ)‖ < 1 ↔
+      x ∈ SpecialPeriods.Triangle.triangleClosedInterior := by
+  constructor
+  · intro h
+    by_contra hx
+    rw [triangleClosedDiscHomeomorph_boundary hx] at h
+    exact lt_irrefl _ h
+  · intro hx
+    rw [triangleClosedDiscHomeomorph_interior
+        (⟨x, hx⟩ : SpecialPeriods.Triangle.triangleClosedInterior)]
+    simpa only [Metric.mem_ball, dist_zero_right] using
+      (SpecialPeriods.Triangle.triangleClosedInteriorDiscHomeomorph ⟨x, hx⟩).property
+
+@[simp]
+private theorem RiemannMapping.triangleClosedDiscHomeomorph_centerOne :
+    (triangleClosedDiscHomeomorph SpecialPeriods.Triangle.triangleClosedCenterOne : ℂ) =
+      triangleCornerThreeGerm.function 0 := by
+  change
+    RiemannBoundary.discCompactificationMap SpecialPeriods.Triangle.triangleClosedInterior_dense
+        SpecialPeriods.Triangle.triangleClosedInteriorDiscHomeomorph
+        SpecialPeriods.Triangle.triangleClosedCenterOne =
+      _
+  exact
+    SpecialPeriods.Triangle.triangleClosedInterior_dense.extend_eq_of_tendsto
+      (triangleClosed_finite_forward_limit _ rfl triangleCornerThree_forward_limit)
+
+@[simp]
+private theorem RiemannMapping.triangleClosedDiscHomeomorph_centerTwo :
+    (triangleClosedDiscHomeomorph SpecialPeriods.Triangle.triangleClosedCenterTwo : ℂ) =
+      triangleCornerFourGerm.function 0 := by
+  change
+    RiemannBoundary.discCompactificationMap SpecialPeriods.Triangle.triangleClosedInterior_dense
+        SpecialPeriods.Triangle.triangleClosedInteriorDiscHomeomorph
+        SpecialPeriods.Triangle.triangleClosedCenterTwo =
+      _
+  exact
+    SpecialPeriods.Triangle.triangleClosedInterior_dense.extend_eq_of_tendsto
+      (triangleClosed_finite_forward_limit _ rfl triangleCornerFour_forward_limit)
+
+@[simp]
+private theorem RiemannMapping.triangleClosedDiscHomeomorph_infty :
+    (triangleClosedDiscHomeomorph SpecialPeriods.Triangle.triangleClosedInfinity : ℂ) =
+      triangleIdealGerm.function 0 := by
+  change
+    RiemannBoundary.discCompactificationMap SpecialPeriods.Triangle.triangleClosedInterior_dense
+        SpecialPeriods.Triangle.triangleClosedInteriorDiscHomeomorph
+        SpecialPeriods.Triangle.triangleClosedInfinity =
+      _
+  exact
+    SpecialPeriods.Triangle.triangleClosedInterior_dense.extend_eq_of_tendsto
+      ((SpecialPeriods.Triangle.triangleClosedInterior_forward_representative_tendsto_iff _).mpr
+        triangleIdeal_forward_limit_onePoint)
+
+private theorem RiemannMapping.triangleClosedDiscHomeomorph_norm_centerOne :
+    ‖(triangleClosedDiscHomeomorph SpecialPeriods.Triangle.triangleClosedCenterOne : ℂ)‖ = 1 := by
+  rw [triangleClosedDiscHomeomorph_centerOne]
+  exact triangleCornerThreeGerm.unit
+
+private theorem RiemannMapping.triangleClosedDiscHomeomorph_norm_centerTwo :
+    ‖(triangleClosedDiscHomeomorph SpecialPeriods.Triangle.triangleClosedCenterTwo : ℂ)‖ = 1 := by
+  rw [triangleClosedDiscHomeomorph_centerTwo]
+  exact triangleCornerFourGerm.unit
+
+private theorem RiemannMapping.triangleClosedDiscHomeomorph_norm_infty :
+    ‖(triangleClosedDiscHomeomorph SpecialPeriods.Triangle.triangleClosedInfinity : ℂ)‖ = 1 := by
+  rw [triangleClosedDiscHomeomorph_infty]
+  exact triangleIdealGerm.unit
+
+private abbrev SpecialPeriods.Triangle.TriangleClosedFinite :=
+  { x : TriangleClosedDomain // x ≠ triangleClosedInfinity }
+
+private theorem SpecialPeriods.Triangle.coe_mem_triangleClosedSet_iff_halfFordRegion (z : ℍ) :
+    ((z : ℂ) : OnePoint ℂ) ∈ triangleClosedSet ↔ z ∈ halfFordRegion := by
+  rw [coe_mem_triangleClosedSet_iff_closure, closure_triangleInterior]
+  exact coe_mem_triangleClosedRegion_iff_halfFordRegion z
+
+private def
+    SpecialPeriods.Triangle.halfFordToClosedDomain (z : halfFordRegion) : TriangleClosedDomain :=
+  ⟨((z : ℍ) : ℂ), (coe_mem_triangleClosedSet_iff_halfFordRegion z).mpr z.property⟩
+
+private theorem SpecialPeriods.Triangle.halfFordToClosedDomain_ne_infinity (z : halfFordRegion) :
+    halfFordToClosedDomain z ≠ triangleClosedInfinity := by
+  intro h
+  exact OnePoint.coe_ne_infty ((z : ℍ) : ℂ) (congrArg Subtype.val h)
+
+private def
+    SpecialPeriods.Triangle.halfFordToClosedFinite (z : halfFordRegion) : TriangleClosedFinite :=
+  ⟨halfFordToClosedDomain z, halfFordToClosedDomain_ne_infinity z⟩
+
+private theorem SpecialPeriods.Triangle.halfFordToClosedFinite_isEmbedding :
+    Topology.IsEmbedding halfFordToClosedFinite := by
+  have htarget : Topology.IsEmbedding (fun x : TriangleClosedFinite => x.val.val) :=
+    Topology.IsEmbedding.subtypeVal.comp Topology.IsEmbedding.subtypeVal
+  apply htarget.of_comp_iff.mp
+  exact
+    OnePoint.isOpenEmbedding_coe.isEmbedding.comp
+      (UpperHalfPlane.isEmbedding_coe.comp Topology.IsEmbedding.subtypeVal)
+
+private theorem SpecialPeriods.Triangle.halfFordToClosedFinite_surjective :
+    Function.Surjective halfFordToClosedFinite := by
+  intro x
+  have hx : x.val.val ≠ ((OnePoint.infty) : OnePoint ℂ) := by
+    intro h
+    exact x.property (Subtype.ext h)
+  obtain ⟨z, hz⟩ := OnePoint.ne_infty_iff_exists.mp hx
+  have hmem : (z : OnePoint ℂ) ∈ triangleClosedSet := by
+    rw [hz]
+    exact x.val.property
+  have him : 0 < z.im := ((coe_mem_triangleClosedSet_iff z).mp hmem).2.2.1
+  let w : ℍ := ⟨z, him⟩
+  have hw : w ∈ halfFordRegion := (coe_mem_triangleClosedSet_iff_halfFordRegion w).mp hmem
+  exact ⟨⟨w, hw⟩, Subtype.ext (Subtype.ext hz)⟩
+
+private def
+    SpecialPeriods.Triangle.halfFordClosedHomeomorph : halfFordRegion ≃ₜ TriangleClosedFinite :=
+  halfFordToClosedFinite_isEmbedding.toHomeomorphOfSurjective halfFordToClosedFinite_surjective
+
+private theorem
+    SpecialPeriods.Triangle.halfFordClosedHomeomorph_mem_interior_iff (z : halfFordRegion) :
+    (halfFordClosedHomeomorph z).val ∈ triangleClosedInterior ↔ (z : ℍ) ∈ halfFordInterior := by
+  change (((z : ℍ) : ℂ) : OnePoint ℂ) ∈ RiemannBoundary.onePointDomain triangleInterior ↔ _
+  rw [RiemannBoundary.coe_mem_onePointDomain, halfFordInterior_eq_preimage_triangleInterior]
+  rfl
+
+private theorem SpecialPeriods.Triangle.halfFordClosedHomeomorph_of_interior (z : ℍ)
+    (hz : z ∈ halfFordInterior) :
+    (halfFordClosedHomeomorph ⟨z, halfFordInterior_subset_halfFordRegion hz⟩).val =
+      triangleClosedInclusion
+        (⟨(z : ℂ), by
+            change (z : ℂ) ∈ triangleInterior
+            simpa only [halfFordInterior_eq_preimage_triangleInterior, Set.mem_preimage] using
+              hz⟩ :
+          RiemannMapping.triangleDomain) :=
+  rfl
+
+private theorem SpecialPeriods.Triangle.centerOne_mem_halfFordRegion : centerOne ∈ halfFordRegion :=
+  (coe_mem_triangleClosedSet_iff_halfFordRegion centerOne).mp triangleClosedCenterOne.property
+
+private theorem SpecialPeriods.Triangle.centerTwo_mem_halfFordRegion : centerTwo ∈ halfFordRegion :=
+  (coe_mem_triangleClosedSet_iff_halfFordRegion centerTwo).mp triangleClosedCenterTwo.property
+
+private def RiemannMapping.normalizationZeroValue : ℂ :=
+  triangleClosedDiscHomeomorph SpecialPeriods.Triangle.triangleClosedCenterOne
+
+private def RiemannMapping.normalizationOneValue : ℂ :=
+  triangleClosedDiscHomeomorph SpecialPeriods.Triangle.triangleClosedCenterTwo
+
+private def RiemannMapping.normalizationPoleValue : ℂ :=
+  triangleClosedDiscHomeomorph SpecialPeriods.Triangle.triangleClosedInfinity
+
+@[simp]
+private theorem RiemannMapping.normalizationZeroValue_eq :
+    normalizationZeroValue = triangleCornerThreeGerm.function 0 :=
+  triangleClosedDiscHomeomorph_centerOne
+
+@[simp]
+private theorem RiemannMapping.normalizationOneValue_eq :
+    normalizationOneValue = triangleCornerFourGerm.function 0 :=
+  triangleClosedDiscHomeomorph_centerTwo
+
+@[simp]
+private theorem RiemannMapping.normalizationPoleValue_eq :
+    normalizationPoleValue = triangleIdealGerm.function 0 :=
+  triangleClosedDiscHomeomorph_infty
+
+private def RiemannMapping.normalizationOrientation : ℝ :=
+  RiemannSphere.MobiusCircle.orientation normalizationZeroValue normalizationOneValue
+    normalizationPoleValue
+
+private theorem RiemannMapping.normalizationOrientation_ne_zero : normalizationOrientation ≠ 0 :=
+  TriangleRiemannNormalization.normalization_orientation_ne_zero triangleClosedDiscHomeomorph
+    SpecialPeriods.Triangle.triangleClosedCenterOne
+    SpecialPeriods.Triangle.triangleClosedCenterTwo SpecialPeriods.Triangle.triangleClosedInfinity
+    SpecialPeriods.Triangle.triangleClosedCenterOne_ne_centerTwo
+    SpecialPeriods.Triangle.triangleClosedCenterOne_ne_infty
+    SpecialPeriods.Triangle.triangleClosedCenterTwo_ne_infty
+    triangleClosedDiscHomeomorph_norm_centerOne triangleClosedDiscHomeomorph_norm_centerTwo
+    triangleClosedDiscHomeomorph_norm_infty
+
+private def RiemannMapping.triangleFiniteNormalizationHomeomorph :
+    SpecialPeriods.Triangle.TriangleClosedFinite ≃ₜ
+      RiemannSphere.closedOrientedHalfPlane normalizationOrientation :=
+  TriangleRiemannNormalization.normalizationHomeomorph triangleClosedDiscHomeomorph
+    SpecialPeriods.Triangle.triangleClosedCenterOne
+    SpecialPeriods.Triangle.triangleClosedCenterTwo SpecialPeriods.Triangle.triangleClosedInfinity
+    SpecialPeriods.Triangle.triangleClosedCenterOne_ne_centerTwo
+    SpecialPeriods.Triangle.triangleClosedCenterOne_ne_infty
+    SpecialPeriods.Triangle.triangleClosedCenterTwo_ne_infty
+    triangleClosedDiscHomeomorph_norm_centerOne triangleClosedDiscHomeomorph_norm_centerTwo
+    triangleClosedDiscHomeomorph_norm_infty
+
+@[simp]
+private theorem RiemannMapping.triangleFiniteNormalizationHomeomorph_apply
+    (x : SpecialPeriods.Triangle.TriangleClosedFinite) :
+    (triangleFiniteNormalizationHomeomorph x : ℂ) =
+      RiemannSphere.MobiusCircle.crossRatio normalizationZeroValue normalizationOneValue
+        normalizationPoleValue
+        (triangleClosedDiscHomeomorph (x : SpecialPeriods.Triangle.TriangleClosedDomain) : ℂ) :=
+  TriangleRiemannNormalization.normalizationHomeomorph_apply triangleClosedDiscHomeomorph
+    SpecialPeriods.Triangle.triangleClosedCenterOne
+    SpecialPeriods.Triangle.triangleClosedCenterTwo SpecialPeriods.Triangle.triangleClosedInfinity
+    SpecialPeriods.Triangle.triangleClosedCenterOne_ne_centerTwo
+    SpecialPeriods.Triangle.triangleClosedCenterOne_ne_infty
+    SpecialPeriods.Triangle.triangleClosedCenterTwo_ne_infty
+    triangleClosedDiscHomeomorph_norm_centerOne triangleClosedDiscHomeomorph_norm_centerTwo
+    triangleClosedDiscHomeomorph_norm_infty x
+
+private theorem RiemannMapping.triangleFiniteNormalizationHomeomorph_centerOne :
+    (triangleFiniteNormalizationHomeomorph
+          ⟨SpecialPeriods.Triangle.triangleClosedCenterOne,
+            SpecialPeriods.Triangle.triangleClosedCenterOne_ne_infty⟩ :
+        ℂ) =
+      0 :=
+  TriangleRiemannNormalization.normalizationHomeomorph_first triangleClosedDiscHomeomorph
+    SpecialPeriods.Triangle.triangleClosedCenterOne
+    SpecialPeriods.Triangle.triangleClosedCenterTwo SpecialPeriods.Triangle.triangleClosedInfinity
+    SpecialPeriods.Triangle.triangleClosedCenterOne_ne_centerTwo
+    SpecialPeriods.Triangle.triangleClosedCenterOne_ne_infty
+    SpecialPeriods.Triangle.triangleClosedCenterTwo_ne_infty
+    triangleClosedDiscHomeomorph_norm_centerOne triangleClosedDiscHomeomorph_norm_centerTwo
+    triangleClosedDiscHomeomorph_norm_infty
+
+private theorem RiemannMapping.triangleFiniteNormalizationHomeomorph_centerTwo :
+    (triangleFiniteNormalizationHomeomorph
+          ⟨SpecialPeriods.Triangle.triangleClosedCenterTwo,
+            SpecialPeriods.Triangle.triangleClosedCenterTwo_ne_infty⟩ :
+        ℂ) =
+      1 :=
+  TriangleRiemannNormalization.normalizationHomeomorph_second triangleClosedDiscHomeomorph
+    SpecialPeriods.Triangle.triangleClosedCenterOne
+    SpecialPeriods.Triangle.triangleClosedCenterTwo SpecialPeriods.Triangle.triangleClosedInfinity
+    SpecialPeriods.Triangle.triangleClosedCenterOne_ne_centerTwo
+    SpecialPeriods.Triangle.triangleClosedCenterOne_ne_infty
+    SpecialPeriods.Triangle.triangleClosedCenterTwo_ne_infty
+    triangleClosedDiscHomeomorph_norm_centerOne triangleClosedDiscHomeomorph_norm_centerTwo
+    triangleClosedDiscHomeomorph_norm_infty
+
+private theorem RiemannMapping.triangleFiniteNormalizationHomeomorph_strict_iff
+    (x : SpecialPeriods.Triangle.TriangleClosedFinite) :
+    0 < normalizationOrientation * (triangleFiniteNormalizationHomeomorph x : ℂ).im ↔
+      (x : SpecialPeriods.Triangle.TriangleClosedDomain) ∈
+        SpecialPeriods.Triangle.triangleClosedInterior := by
+  have h :=
+    TriangleRiemannNormalization.normalizationHomeomorph_strict_iff triangleClosedDiscHomeomorph
+      SpecialPeriods.Triangle.triangleClosedCenterOne
+      SpecialPeriods.Triangle.triangleClosedCenterTwo
+      SpecialPeriods.Triangle.triangleClosedInfinity
+      SpecialPeriods.Triangle.triangleClosedCenterOne_ne_centerTwo
+      SpecialPeriods.Triangle.triangleClosedCenterOne_ne_infty
+      SpecialPeriods.Triangle.triangleClosedCenterTwo_ne_infty
+      triangleClosedDiscHomeomorph_norm_centerOne triangleClosedDiscHomeomorph_norm_centerTwo
+      triangleClosedDiscHomeomorph_norm_infty x
+  exact h.trans (triangleClosedDiscHomeomorph_norm_lt_iff x)
+
+private def RiemannMapping.halfFordNormalizationHomeomorph :
+    SpecialPeriods.Triangle.halfFordRegion ≃ₜ
+      RiemannSphere.closedOrientedHalfPlane normalizationOrientation :=
+  SpecialPeriods.Triangle.halfFordClosedHomeomorph.trans triangleFiniteNormalizationHomeomorph
+
+@[simp]
+private theorem RiemannMapping.halfFordNormalizationHomeomorph_apply
+    (z : SpecialPeriods.Triangle.halfFordRegion) :
+    (halfFordNormalizationHomeomorph z : ℂ) =
+      RiemannSphere.MobiusCircle.crossRatio normalizationZeroValue normalizationOneValue
+        normalizationPoleValue
+        (triangleClosedDiscHomeomorph (SpecialPeriods.Triangle.halfFordClosedHomeomorph z).val :
+          ℂ) :=
+  triangleFiniteNormalizationHomeomorph_apply (SpecialPeriods.Triangle.halfFordClosedHomeomorph z)
+
+private theorem RiemannMapping.halfFordNormalizationHomeomorph_centerOne :
+    (halfFordNormalizationHomeomorph
+          ⟨SpecialPeriods.Triangle.centerOne,
+            SpecialPeriods.Triangle.centerOne_mem_halfFordRegion⟩ :
+        ℂ) =
+      0 :=
+  triangleFiniteNormalizationHomeomorph_centerOne
+
+private theorem RiemannMapping.halfFordNormalizationHomeomorph_centerTwo :
+    (halfFordNormalizationHomeomorph
+          ⟨SpecialPeriods.Triangle.centerTwo,
+            SpecialPeriods.Triangle.centerTwo_mem_halfFordRegion⟩ :
+        ℂ) =
+      1 :=
+  triangleFiniteNormalizationHomeomorph_centerTwo
+
+private theorem RiemannMapping.halfFordNormalizationHomeomorph_apply_of_interior (z : ℍ)
+    (hz : z ∈ SpecialPeriods.Triangle.halfFordInterior) :
+    (halfFordNormalizationHomeomorph
+          ⟨z, SpecialPeriods.Triangle.halfFordInterior_subset_halfFordRegion hz⟩ :
+        ℂ) =
+      RiemannSphere.MobiusCircle.crossRatio normalizationZeroValue normalizationOneValue
+        normalizationPoleValue (triangleMap (z : ℂ)) := by
+  rw [halfFordNormalizationHomeomorph_apply,
+    SpecialPeriods.Triangle.halfFordClosedHomeomorph_of_interior z hz,
+    triangleClosedDiscHomeomorph_triangle]
+
+private theorem RiemannMapping.halfFordNormalizationHomeomorph_strict_iff
+    (z : SpecialPeriods.Triangle.halfFordRegion) :
+    0 < normalizationOrientation * (halfFordNormalizationHomeomorph z : ℂ).im ↔
+      (z : ℍ) ∈ SpecialPeriods.Triangle.halfFordInterior :=
+  (triangleFiniteNormalizationHomeomorph_strict_iff
+        (SpecialPeriods.Triangle.halfFordClosedHomeomorph z)).trans
+    (SpecialPeriods.Triangle.halfFordClosedHomeomorph_mem_interior_iff z)
+
+private theorem RiemannMapping.halfFordNormalizationHomeomorph_boundary_iff
+    (z : SpecialPeriods.Triangle.halfFordRegion) :
+    (halfFordNormalizationHomeomorph z : ℂ).im = 0 ↔
+      (z : ℍ) ∉ SpecialPeriods.Triangle.halfFordInterior := by
+  constructor
+  · intro hz hin
+    have h := (halfFordNormalizationHomeomorph_strict_iff z).mpr hin
+    simp only [hz, MulZeroClass.mul_zero, lt_self_iff_false] at h
+  · intro hz
+    have hn : ¬0 < normalizationOrientation * (halfFordNormalizationHomeomorph z : ℂ).im :=
+      fun h => hz ((halfFordNormalizationHomeomorph_strict_iff z).mp h)
+    have he : normalizationOrientation * (halfFordNormalizationHomeomorph z : ℂ).im = 0 :=
+      le_antisymm (le_of_not_gt hn) (halfFordNormalizationHomeomorph z).property
+    exact (mul_eq_zero.mp he).resolve_left normalizationOrientation_ne_zero
+
+private def
+    RiemannMapping.triangleSignedHalfPlaneMap : TriangleUniformizationGluing.SignedHalfPlaneMap :=
+  TriangleUniformizationGluing.signedHalfPlaneMapOfHomeomorph normalizationOrientation_ne_zero
+    halfFordNormalizationHomeomorph halfFordNormalizationHomeomorph_strict_iff
+
+@[simp]
+private theorem RiemannMapping.triangleSignedHalfPlaneMap_coe
+    (z : SpecialPeriods.Triangle.halfFordRegion) :
+    triangleSignedHalfPlaneMap z = (halfFordNormalizationHomeomorph z : ℂ) :=
+  TriangleUniformizationGluing.signedHalfPlaneMapOfHomeomorph_apply
+    normalizationOrientation_ne_zero halfFordNormalizationHomeomorph
+    halfFordNormalizationHomeomorph_strict_iff z
+
+private theorem RiemannMapping.triangleSignedHalfPlaneMap_of_mem {z : ℍ}
+    (hz : z ∈ SpecialPeriods.Triangle.halfFordRegion) :
+    triangleSignedHalfPlaneMap z = (halfFordNormalizationHomeomorph ⟨z, hz⟩ : ℂ) :=
+  triangleSignedHalfPlaneMap_coe ⟨z, hz⟩
+
+private theorem RiemannMapping.triangleSignedHalfPlaneMap_of_interior (z : ℍ)
+    (hz : z ∈ SpecialPeriods.Triangle.halfFordInterior) :
+    triangleSignedHalfPlaneMap z =
+      RiemannSphere.MobiusCircle.crossRatio normalizationZeroValue normalizationOneValue
+        normalizationPoleValue (triangleMap (z : ℂ)) := by
+  rw [triangleSignedHalfPlaneMap_of_mem
+      (SpecialPeriods.Triangle.halfFordInterior_subset_halfFordRegion hz)]
+  exact halfFordNormalizationHomeomorph_apply_of_interior z hz
+
+@[simp]
+private theorem RiemannMapping.triangleSignedHalfPlaneMap_centerOne :
+    triangleSignedHalfPlaneMap SpecialPeriods.Triangle.centerOne = 0 := by
+  rw [triangleSignedHalfPlaneMap_of_mem SpecialPeriods.Triangle.centerOne_mem_halfFordRegion]
+  exact halfFordNormalizationHomeomorph_centerOne
+
+@[simp]
+private theorem RiemannMapping.triangleSignedHalfPlaneMap_centerTwo :
+    triangleSignedHalfPlaneMap SpecialPeriods.Triangle.centerTwo = 1 := by
+  rw [triangleSignedHalfPlaneMap_of_mem SpecialPeriods.Triangle.centerTwo_mem_halfFordRegion]
+  exact halfFordNormalizationHomeomorph_centerTwo
+
+private theorem RiemannMapping.triangleSignedHalfPlaneMap_isProperMap :
+    IsProperMap
+      (fun z : SpecialPeriods.Triangle.halfFordRegion => triangleSignedHalfPlaneMap z) :=
+  TriangleUniformizationGluing.halfFordHomeomorphExtension_isProperMap
+    halfFordNormalizationHomeomorph
+
+private theorem RiemannMapping.triangleSignedHalfPlaneMap_holomorphicOn :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω triangleSignedHalfPlaneMap SpecialPeriods.Triangle.halfFordInterior :=
+  by
+  have hab : normalizationZeroValue ≠ normalizationOneValue := by
+    simpa only [normalizationZeroValue_eq, normalizationOneValue_eq] using
+      triangleCorner_boundary_values_ne
+  have hc : ‖normalizationPoleValue‖ = 1 := by
+    simpa only [normalizationPoleValue_eq] using triangleIdealGerm.unit
+  have hf : ContDiffOn ℂ ω triangleMap SpecialPeriods.Triangle.triangleInterior :=
+    (triangleMap_differentiable.analyticOnNhd
+          SpecialPeriods.Triangle.triangleInterior_isOpen).contDiffOn
+      SpecialPeriods.Triangle.triangleInterior_isOpen.uniqueDiffOn
+  have hcr :
+    ContDiffOn ℂ ω
+      (RiemannSphere.MobiusCircle.crossRatio normalizationZeroValue normalizationOneValue
+        normalizationPoleValue)
+      {z : ℂ | ‖z‖ < 1} :=
+    RiemannSphere.crossRatio_holomorphicOn_disc hab hc
+  have hcomp :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω
+      (fun z : ℂ =>
+        RiemannSphere.MobiusCircle.crossRatio normalizationZeroValue normalizationOneValue
+          normalizationPoleValue (triangleMap z))
+      SpecialPeriods.Triangle.triangleInterior :=
+    contMDiffOn_iff_contDiffOn.mpr (hcr.comp hf (fun _ hz => triangleMap_norm_lt_one hz))
+  have hu :=
+    hcomp.comp UpperHalfPlane.contMDiff_coe.contMDiffOn
+      (show
+        Set.MapsTo ((↑) : ℍ → ℂ) SpecialPeriods.Triangle.halfFordInterior
+          SpecialPeriods.Triangle.triangleInterior
+        from by
+        intro z hz
+        simpa only [SpecialPeriods.Triangle.halfFordInterior_eq_preimage_triangleInterior,
+          Set.mem_preimage] using hz)
+  apply hu.congr
+  intro z hz
+  exact triangleSignedHalfPlaneMap_of_interior z hz
+
+private theorem TriangleUniformizationGluing.BoundaryMap.foldedFordMap_compact_preimage
+    (D : TriangleUniformizationGluing.BoundaryMap)
+    (hlocal : IsProperMap (fun z : SpecialPeriods.Triangle.halfFordRegion => D.toFun z))
+    (K : Set ℂ) (hK : IsCompact K) :
+    IsCompact (SpecialPeriods.Triangle.fordRegion ∩ D.foldedFordMap ⁻¹' K) := by
+  have hhalf (L : Set ℂ) (hL : IsCompact L) :
+    IsCompact (SpecialPeriods.Triangle.halfFordRegion ∩ D.toFun ⁻¹' L) := by
+    have hs := (hlocal.isCompact_preimage hL).image continuous_subtype_val
+    change
+      IsCompact
+        ((Subtype.val : SpecialPeriods.Triangle.halfFordRegion → ℍ) ''
+          ((Subtype.val : SpecialPeriods.Triangle.halfFordRegion → ℍ) ⁻¹' (D.toFun ⁻¹' L))) at hs
+    simpa only [Subtype.image_preimage_val] using hs
+  have hconj : IsCompact ((conj : ℂ → ℂ) ⁻¹' K) :=
+    Complex.conjCLE.toHomeomorph.isCompact_preimage.mpr hK
+  have heq :
+    SpecialPeriods.Triangle.fordRegion ∩ D.foldedFordMap ⁻¹' K =
+      (SpecialPeriods.Triangle.halfFordRegion ∩ D.toFun ⁻¹' K) ∪
+        SpecialPeriods.Triangle.rightReflection ''
+          (SpecialPeriods.Triangle.halfFordRegion ∩ D.toFun ⁻¹' ((conj : ℂ → ℂ) ⁻¹' K)) := by
+    ext z
+    constructor
+    · rintro ⟨hz, hKz⟩
+      change D.foldedFordMap z ∈ K at hKz
+      rw [← SpecialPeriods.Triangle.halfFordRegion_union_reflection] at hz
+      rcases hz with hz | ⟨w, hw, rfl⟩
+      · left
+        refine ⟨hz, ?_⟩
+        change D z ∈ K
+        rwa [D.foldedFordMap_of_left hz.2] at hKz
+      · right
+        refine ⟨w, ⟨hw, ?_⟩, rfl⟩
+        change conj (D w) ∈ K
+        rwa [D.foldedFordMap_reflected w hw] at hKz
+    · rintro (⟨hz, hKz⟩ | ⟨w, ⟨hw, hKw⟩, rfl⟩)
+      · refine ⟨hz.1, ?_⟩
+        change D.foldedFordMap z ∈ K
+        rwa [D.foldedFordMap_of_left hz.2]
+      · refine ⟨SpecialPeriods.Triangle.rightReflection_mapsTo_fordRegion hw.1, ?_⟩
+        change D.foldedFordMap (SpecialPeriods.Triangle.rightReflection w) ∈ K
+        rw [D.foldedFordMap_reflected w hw]
+        exact hKw
+  rw [heq]
+  exact
+    (hhalf K hK).union ((hhalf _ hconj).image SpecialPeriods.Triangle.rightReflection.continuous)
+
+private def SpecialPeriods.Triangle.closedFirstSector : Set ℍ :=
+  {z | z.re ≤ -(1 / 2) ∧ 1 ≤ ‖(z : ℂ)‖}
+
+private def SpecialPeriods.Triangle.closedSecondSector : Set ℍ :=
+  {z | stripLeft ≤ z.re ∧ stripRight ≤ ‖(z : ℂ) - (stripLeft : ℂ)‖}
+
+private def SpecialPeriods.Triangle.firstWeakExcluded : Set ℍ :=
+  {z | -(1 / 2) ≤ z.re ∨ ‖(z : ℂ)‖ ≤ 1}
+
+private def SpecialPeriods.Triangle.secondWeakExcluded : Set ℍ :=
+  {z | z.re ≤ stripLeft ∨ ‖(z : ℂ) - (stripLeft : ℂ)‖ ≤ stripRight}
+
+private def SpecialPeriods.Triangle.circularDoubleRegion : Set ℍ :=
+  closedFirstSector ∩ closedSecondSector
+
+private theorem SpecialPeriods.Triangle.firstExcluded_subset_firstWeakExcluded :
+    firstExcluded ⊆ firstWeakExcluded := by
+  intro z hz
+  exact hz.imp le_of_lt le_of_lt
+
+private theorem SpecialPeriods.Triangle.secondExcluded_subset_secondWeakExcluded :
+    secondExcluded ⊆ secondWeakExcluded := by
+  intro z hz
+  exact hz.imp le_of_lt le_of_lt
+
+private theorem SpecialPeriods.Triangle.firstWeakExcluded_subset_pingPongOne :
+    firstWeakExcluded ⊆ pingPongOne := by
+  intro z hz
+  change -1 < z.re
+  rcases hz with hx | hn
+  · linarith
+  · have habs : |z.re| < ‖(z : ℂ)‖ := Complex.abs_re_lt_norm.mpr z.im_ne_zero
+    linarith [neg_le_abs z.re]
+
+private theorem SpecialPeriods.Triangle.secondWeakExcluded_subset_pingPongTwo :
+    secondWeakExcluded ⊆ pingPongTwo := by
+  intro z hz
+  change z.re < -1
+  rcases hz with hx | hn
+  · exact hx.trans_lt stripLeft_lt_neg_one
+  · have him : ((z : ℂ) - (stripLeft : ℂ)).im ≠ 0 := by simpa using z.im_ne_zero
+    have habs := Complex.abs_re_lt_norm.mpr him
+    have hr := le_abs_self (((z : ℂ) - (stripLeft : ℂ)).re)
+    simp only [Complex.sub_re, UpperHalfPlane.coe_re, Complex.ofReal_re] at habs hr
+    linarith [stripLeft_add_stripRight]
+
+private theorem SpecialPeriods.Triangle.firstWeakExcluded_subset_secondSector :
+    firstWeakExcluded ⊆ secondSector :=
+  firstWeakExcluded_subset_pingPongOne.trans pingPongOne_subset_secondSector
+
+private theorem SpecialPeriods.Triangle.secondWeakExcluded_subset_firstSector :
+    secondWeakExcluded ⊆ firstSector :=
+  secondWeakExcluded_subset_pingPongTwo.trans pingPongTwo_subset_firstSector
+
+private theorem SpecialPeriods.Triangle.circularDoubleRegion_disjoint_firstExcluded :
+    Disjoint circularDoubleRegion firstExcluded := by
+  apply Set.disjoint_left.mpr
+  intro z hz he
+  rcases he with hx | hn
+  · exact (not_lt_of_ge hz.1.1) hx
+  · exact (not_lt_of_ge hz.1.2) hn
+
+private theorem SpecialPeriods.Triangle.circularDoubleRegion_disjoint_secondExcluded :
+    Disjoint circularDoubleRegion secondExcluded := by
+  apply Set.disjoint_left.mpr
+  intro z hz he
+  rcases he with hx | hn
+  · exact (not_lt_of_ge hz.2.1) hx
+  · exact (not_lt_of_ge hz.2.2) hn
+
+private theorem SpecialPeriods.Triangle.generatorOne_closedFirstSector :
+    Set.MapsTo (fun z : ℍ => generatorOneSL • z) closedFirstSector firstWeakExcluded := by
+  intro z hz
+  left
+  change -(1 / 2) ≤ (((generatorOneSL • z : ℍ) : ℂ)).re
+  rw [generatorOneSL_smul_coe]
+  simp only [Complex.neg_re, Complex.inv_re, Complex.add_re, UpperHalfPlane.coe_re,
+    Complex.one_re]
+  have hd := Complex.normSq_pos.mpr (denominatorOne_ne_zero z)
+  have hn : 1 ≤ Complex.normSq (z : ℂ) := by
+    rw [Complex.normSq_eq_norm_sq]
+    nlinarith [hz.2]
+  simp only [← neg_div]
+  apply (le_div_iff₀ hd).mpr
+  simp only [Complex.normSq_apply, Complex.add_re, Complex.one_re, Complex.add_im, Complex.one_im,
+    add_zero, UpperHalfPlane.coe_re, UpperHalfPlane.coe_im] at hn ⊢
+  nlinarith
+
+private theorem SpecialPeriods.Triangle.norm_add_one_le_norm_of_re_le_half_mo1973_19719 (z : ℍ)
+    (hz : z.re ≤ -(1 / 2)) : ‖(z : ℂ) + 1‖ ≤ ‖(z : ℂ)‖ := by
+  have hsq : ‖(z : ℂ) + 1‖ ^ 2 ≤ ‖(z : ℂ)‖ ^ 2 := by
+    simp only [Complex.sq_norm, Complex.normSq_apply, Complex.add_re, Complex.one_re,
+      Complex.add_im, Complex.one_im, add_zero, UpperHalfPlane.coe_re, UpperHalfPlane.coe_im]
+    linarith
+  nlinarith [norm_nonneg ((z : ℂ) + 1), norm_nonneg (z : ℂ)]
+
+private theorem SpecialPeriods.Triangle.generatorOne_sq_closedFirstSector :
+    Set.MapsTo (fun z : ℍ => (generatorOneSL ^ 2 : SL(2, ℝ)) • z) closedFirstSector
+      firstWeakExcluded := by
+  intro z hz
+  right
+  rw [generatorOneSL_sq_smul_coe]
+  have he : (-1 : ℂ) - (z : ℂ)⁻¹ = -(((z : ℂ) + 1) / (z : ℂ)) := by
+    field_simp [z.ne_zero]
+    ring
+  rw [he, norm_neg, norm_div]
+  exact
+    (div_le_one (norm_pos_iff.mpr z.ne_zero)).mpr
+      (norm_add_one_le_norm_of_re_le_half_mo1973_19719 z hz.1)
+
+private def SpecialPeriods.Triangle.secondShift_mo1973_19721 (z : ℍ) : ℂ :=
+  (z : ℂ) - (stripLeft : ℂ)
+
+private theorem SpecialPeriods.Triangle.secondShift_re_mo1973_19722 (z : ℍ) :
+    (secondShift_mo1973_19721 z).re = z.re - stripLeft := by simp [secondShift_mo1973_19721]
+
+private theorem SpecialPeriods.Triangle.secondShift_add_real_ne_zero_mo1973_19723 (z : ℍ)
+    (a : ℝ) : secondShift_mo1973_19721 z + (a : ℂ) ≠ 0 := by
+  intro h
+  have hi := congrArg Complex.im h
+  simp only [secondShift_mo1973_19721, Complex.sub_im, Complex.add_im, Complex.ofReal_im,
+    sub_zero, add_zero, Complex.zero_im, UpperHalfPlane.coe_im] at hi
+  exact z.im_ne_zero hi
+
+private theorem SpecialPeriods.Triangle.stripLeft_eq_neg_stripRight_sub_one_mo1973_19724 :
+    stripLeft = -stripRight - 1 := by linarith [stripLeft_add_stripRight]
+
+private theorem SpecialPeriods.Triangle.width_eq_two_stripRight_add_one_mo1973_19725 :
+    width = 2 * stripRight + 1 := by
+  unfold stripRight
+  ring
+
+private theorem SpecialPeriods.Triangle.stripRight_sq_complex_mo1973_19726 :
+    (stripRight : ℂ) ^ 2 = 1 / 2 := by
+  rw [← Complex.ofReal_pow, stripRight_sq]
+  norm_num
+
+private theorem SpecialPeriods.Triangle.generatorTwo_secondShift_mo1973_19727 (z : ℍ) :
+    secondShift_mo1973_19721 (generatorTwoSL • z) =
+      (stripRight : ℂ) * (secondShift_mo1973_19721 z - stripRight) /
+        (secondShift_mo1973_19721 z + stripRight) := by
+  have hd := secondShift_add_real_ne_zero_mo1973_19723 z stripRight
+  have hs := stripRight_sq_complex_mo1973_19726
+  unfold secondShift_mo1973_19721 at *
+  rw [generatorTwoSL_smul_coe]
+  rw [stripLeft_eq_neg_stripRight_sub_one_mo1973_19724,
+    width_eq_two_stripRight_add_one_mo1973_19725] at *
+  push_cast at *
+  have he :
+    (z : ℂ) + (2 * (stripRight : ℂ) + 1) = (z : ℂ) - (-(stripRight : ℂ) - 1) + stripRight := by
+    ring
+  rw [he]
+  field_simp [hd]
+  linear_combination 2 * hs
+
+private theorem SpecialPeriods.Triangle.generatorTwo_sq_secondShift_mo1973_19728 (z : ℍ) :
+    secondShift_mo1973_19721 ((generatorTwoSL ^ 2 : SL(2, ℝ)) • z) =
+      -(stripRight : ℂ) ^ 2 / secondShift_mo1973_19721 z := by
+  have hz : secondShift_mo1973_19721 z ≠ 0 := by
+    simpa using secondShift_add_real_ne_zero_mo1973_19723 z 0
+  have hd := secondShift_add_real_ne_zero_mo1973_19723 z stripRight
+  have hR : (stripRight : ℂ) ≠ 0 := by exact_mod_cast stripRight_pos.ne'
+  rw [pow_two, SemigroupAction.mul_smul, generatorTwo_secondShift_mo1973_19727,
+    generatorTwo_secondShift_mo1973_19727]
+  field_simp [hz, hd, hR]
+  ring
+
+private theorem SpecialPeriods.Triangle.generatorTwo_cube_secondShift_mo1973_19729 (z : ℍ) :
+    secondShift_mo1973_19721 ((generatorTwoSL ^ 3 : SL(2, ℝ)) • z) =
+      -(stripRight : ℂ) * (secondShift_mo1973_19721 z + stripRight) /
+        (secondShift_mo1973_19721 z - stripRight) := by
+  have hd : secondShift_mo1973_19721 z - (stripRight : ℂ) ≠ 0 := by
+    simpa only [Complex.ofReal_neg, sub_eq_add_neg] using
+      secondShift_add_real_ne_zero_mo1973_19723 z (-stripRight)
+  have hs := stripRight_sq_complex_mo1973_19726
+  unfold secondShift_mo1973_19721 at *
+  rw [generatorTwoSL_cube_smul_coe]
+  rw [stripLeft_eq_neg_stripRight_sub_one_mo1973_19724,
+    width_eq_two_stripRight_add_one_mo1973_19725] at *
+  push_cast at *
+  have he : (z : ℂ) + 1 = (z : ℂ) - (-(stripRight : ℂ) - 1) - stripRight := by ring
+  rw [he]
+  field_simp [hd]
+  linear_combination 2 * hs
+
+private theorem SpecialPeriods.Triangle.norm_sub_div_add_le_one_mo1973_19730 {r : ℝ} (hr : 0 < r)
+    {u : ℂ} (hu : 0 ≤ u.re) : ‖(u - (r : ℂ)) / (u + (r : ℂ))‖ ≤ 1 := by
+  have hd : u + (r : ℂ) ≠ 0 := by
+    intro h
+    have h' := congrArg Complex.re h
+    simp only [Complex.add_re, Complex.ofReal_re, Complex.zero_re] at h'
+    linarith
+  rw [norm_div]
+  apply (div_le_one (norm_pos_iff.mpr hd)).mpr
+  have hsq : ‖u - (r : ℂ)‖ ^ 2 ≤ ‖u + (r : ℂ)‖ ^ 2 := by
+    simp only [Complex.sq_norm, Complex.normSq_apply, Complex.sub_re, Complex.add_re,
+      Complex.sub_im, Complex.add_im, Complex.ofReal_re, Complex.ofReal_im, sub_zero, add_zero]
+    nlinarith [mul_nonneg hr.le hu]
+  nlinarith [norm_nonneg (u - (r : ℂ)), norm_nonneg (u + (r : ℂ))]
+
+private theorem SpecialPeriods.Triangle.re_add_div_sub_nonneg_mo1973_19731 {r : ℝ} (hr : 0 < r)
+    {u : ℂ} (hu : r ≤ ‖u‖) : 0 ≤ ((u + (r : ℂ)) / (u - (r : ℂ))).re := by
+  have hsq : r ^ 2 ≤ Complex.normSq u := by
+    rw [Complex.normSq_eq_norm_sq]
+    nlinarith
+  rw [Complex.div_re, ← add_div]
+  apply div_nonneg ?_ (Complex.normSq_nonneg _)
+  simp only [Complex.add_re, Complex.sub_re, Complex.ofReal_re, Complex.add_im, Complex.sub_im,
+    Complex.ofReal_im, add_zero, sub_zero]
+  rw [Complex.normSq_apply] at hsq
+  nlinarith
+
+private theorem SpecialPeriods.Triangle.re_neg_sq_div_nonpos_mo1973_19732 {r : ℝ} {u : ℂ}
+    (hu : 0 ≤ u.re) : (-(r : ℂ) ^ 2 / u).re ≤ 0 := by
+  have hnum : -(r ^ 2) * u.re ≤ 0 :=
+    mul_nonpos_of_nonpos_of_nonneg (neg_nonpos.mpr (sq_nonneg r)) hu
+  simpa [Complex.div_re, ← Complex.ofReal_pow] using
+    div_nonpos_of_nonpos_of_nonneg hnum (Complex.normSq_nonneg u)
+
+private theorem SpecialPeriods.Triangle.norm_sub_div_add_lt_one_mo1973_19733 {r : ℝ} (hr : 0 < r)
+    {u : ℂ} (hu : 0 < u.re) : ‖(u - (r : ℂ)) / (u + (r : ℂ))‖ < 1 := by
+  have hd : u + (r : ℂ) ≠ 0 := by
+    intro h
+    have h' := congrArg Complex.re h
+    simp only [Complex.add_re, Complex.ofReal_re, Complex.zero_re] at h'
+    linarith
+  rw [norm_div]
+  apply (div_lt_one (norm_pos_iff.mpr hd)).mpr
+  have hsq : ‖u - (r : ℂ)‖ ^ 2 < ‖u + (r : ℂ)‖ ^ 2 := by
+    simp only [Complex.sq_norm, Complex.normSq_apply, Complex.sub_re, Complex.add_re,
+      Complex.sub_im, Complex.add_im, Complex.ofReal_re, Complex.ofReal_im, sub_zero, add_zero]
+    nlinarith [mul_pos hr hu]
+  nlinarith [norm_nonneg (u - (r : ℂ)), norm_nonneg (u + (r : ℂ))]
+
+private theorem SpecialPeriods.Triangle.re_neg_sq_div_neg_mo1973_19735 {r : ℝ} (hr : 0 < r)
+    {u : ℂ} (hu : 0 < u.re) : (-(r : ℂ) ^ 2 / u).re < 0 := by
+  have hd : u ≠ 0 := by
+    intro h
+    simp [h] at hu
+  have hnum : -(r ^ 2) * u.re < 0 := mul_neg_of_neg_of_pos (neg_neg_of_pos (sq_pos_of_pos hr)) hu
+  simpa [Complex.div_re, ← Complex.ofReal_pow] using
+    div_neg_of_neg_of_pos hnum (Complex.normSq_pos.mpr hd)
+
+private theorem SpecialPeriods.Triangle.generatorTwo_sq_shift (z : ℍ) :
+    (((generatorTwoSL ^ 2 : SL(2, ℝ)) • z : ℍ) : ℂ) - (stripLeft : ℂ) =
+      -(stripRight : ℂ) ^ 2 / ((z : ℂ) - (stripLeft : ℂ)) :=
+  generatorTwo_sq_secondShift_mo1973_19728 z
+
+private theorem SpecialPeriods.Triangle.generatorTwo_shift_norm_le (z : ℍ) (hx : stripLeft ≤ z.re) :
+    ‖((generatorTwoSL • z : ℍ) : ℂ) - (stripLeft : ℂ)‖ ≤ stripRight := by
+  change ‖secondShift_mo1973_19721 (generatorTwoSL • z)‖ ≤ stripRight
+  rw [generatorTwo_secondShift_mo1973_19727, mul_div_assoc, norm_mul, Complex.norm_real,
+    Real.norm_eq_abs, abs_of_pos stripRight_pos]
+  have hrez : 0 ≤ (secondShift_mo1973_19721 z).re := by
+    rw [secondShift_re_mo1973_19722]
+    exact sub_nonneg.mpr hx
+  simpa only [mul_one] using
+    mul_le_mul_of_nonneg_left (norm_sub_div_add_le_one_mo1973_19730 stripRight_pos hrez)
+      stripRight_pos.le
+
+private theorem SpecialPeriods.Triangle.generatorTwo_shift_norm_lt (z : ℍ) (hx : stripLeft < z.re) :
+    ‖((generatorTwoSL • z : ℍ) : ℂ) - (stripLeft : ℂ)‖ < stripRight := by
+  change ‖secondShift_mo1973_19721 (generatorTwoSL • z)‖ < stripRight
+  rw [generatorTwo_secondShift_mo1973_19727, mul_div_assoc, norm_mul, Complex.norm_real,
+    Real.norm_eq_abs, abs_of_pos stripRight_pos]
+  have hrez : 0 < (secondShift_mo1973_19721 z).re := by
+    rw [secondShift_re_mo1973_19722]
+    exact sub_pos.mpr hx
+  simpa only [mul_one] using
+    mul_lt_mul_of_pos_left (norm_sub_div_add_lt_one_mo1973_19733 stripRight_pos hrez)
+      stripRight_pos
+
+private theorem
+    SpecialPeriods.Triangle.generatorTwo_sq_re_le_stripLeft (z : ℍ) (hx : stripLeft ≤ z.re) :
+    ((generatorTwoSL ^ 2 : SL(2, ℝ)) • z).re ≤ stripLeft := by
+  have hrez : 0 ≤ (secondShift_mo1973_19721 z).re := by
+    rw [secondShift_re_mo1973_19722]
+    exact sub_nonneg.mpr hx
+  have h := re_neg_sq_div_nonpos_mo1973_19732 (r := stripRight) hrez
+  rw [← generatorTwo_sq_secondShift_mo1973_19728 z, secondShift_re_mo1973_19722] at h
+  exact sub_nonpos.mp h
+
+private theorem
+    SpecialPeriods.Triangle.generatorTwo_sq_re_lt_stripLeft (z : ℍ) (hx : stripLeft < z.re) :
+    ((generatorTwoSL ^ 2 : SL(2, ℝ)) • z).re < stripLeft := by
+  have hrez : 0 < (secondShift_mo1973_19721 z).re := by
+    rw [secondShift_re_mo1973_19722]
+    exact sub_pos.mpr hx
+  have h := re_neg_sq_div_neg_mo1973_19735 stripRight_pos hrez
+  rw [← generatorTwo_sq_secondShift_mo1973_19728 z, secondShift_re_mo1973_19722] at h
+  exact sub_neg.mp h
+
+private theorem SpecialPeriods.Triangle.generatorTwo_cube_re_le_stripLeft (z : ℍ)
+    (hn : stripRight ≤ ‖(z : ℂ) - (stripLeft : ℂ)‖) :
+    ((generatorTwoSL ^ 3 : SL(2, ℝ)) • z).re ≤ stripLeft := by
+  have h : (secondShift_mo1973_19721 ((generatorTwoSL ^ 3 : SL(2, ℝ)) • z)).re ≤ 0 := by
+    rw [generatorTwo_cube_secondShift_mo1973_19729, mul_div_assoc]
+    simp only [Complex.mul_re, Complex.neg_re, Complex.ofReal_re, Complex.neg_im,
+      Complex.ofReal_im, neg_zero, MulZeroClass.zero_mul, sub_zero]
+    exact
+      mul_nonpos_of_nonpos_of_nonneg (neg_nonpos.mpr stripRight_pos.le)
+        (re_add_div_sub_nonneg_mo1973_19731 stripRight_pos hn)
+  rw [secondShift_re_mo1973_19722] at h
+  exact sub_nonpos.mp h
+
+private theorem SpecialPeriods.Triangle.generatorTwo_closedSecondSector :
+    Set.MapsTo (fun z : ℍ => generatorTwoSL • z) closedSecondSector secondWeakExcluded :=
+  fun z hz => Or.inr (generatorTwo_shift_norm_le z hz.1)
+
+private theorem SpecialPeriods.Triangle.generatorTwo_sq_closedSecondSector :
+    Set.MapsTo (fun z : ℍ => (generatorTwoSL ^ 2 : SL(2, ℝ)) • z) closedSecondSector
+      secondWeakExcluded :=
+  fun z hz => Or.inl (generatorTwo_sq_re_le_stripLeft z hz.1)
+
+private theorem SpecialPeriods.Triangle.generatorTwo_cube_closedSecondSector :
+    Set.MapsTo (fun z : ℍ => (generatorTwoSL ^ 3 : SL(2, ℝ)) • z) closedSecondSector
+      secondWeakExcluded :=
+  fun z hz => Or.inl (generatorTwo_cube_re_le_stripLeft z hz.2)
+
+private theorem SpecialPeriods.Triangle.generatorOne_re_lower_of_one_le_norm_mo1973_19748 (z : ℍ)
+    (hn : 1 ≤ ‖(z : ℂ)‖) : -(1 / 2) ≤ (generatorOneSL • z).re := by
+  change -(1 / 2) ≤ (((generatorOneSL • z : ℍ) : ℂ)).re
+  rw [generatorOneSL_smul_coe]
+  simp only [Complex.neg_re, Complex.inv_re, Complex.add_re, UpperHalfPlane.coe_re,
+    Complex.one_re]
+  have hd := Complex.normSq_pos.mpr (denominatorOne_ne_zero z)
+  have hsq : 1 ≤ Complex.normSq (z : ℂ) := by
+    rw [Complex.normSq_eq_norm_sq]
+    nlinarith
+  simp only [← neg_div]
+  apply (le_div_iff₀ hd).mpr
+  simp only [Complex.normSq_apply, Complex.add_re, Complex.one_re, Complex.add_im, Complex.one_im,
+    add_zero, UpperHalfPlane.coe_re, UpperHalfPlane.coe_im] at hsq ⊢
+  nlinarith
+
+private theorem SpecialPeriods.Triangle.re_lower_of_one_le_generatorOne_sq_norm_mo1973_19749
+    (z : ℍ) (hn : 1 ≤ ‖(((generatorOneSL ^ 2) • z : ℍ) : ℂ)‖) : -(1 / 2) ≤ z.re := by
+  rw [generatorOneSL_sq_smul_coe] at hn
+  have he : (-1 : ℂ) - (z : ℂ)⁻¹ = -(((z : ℂ) + 1) / (z : ℂ)) := by
+    field_simp [z.ne_zero]
+    ring
+  rw [he, norm_neg, norm_div] at hn
+  have hnorm : ‖(z : ℂ)‖ ≤ ‖(z : ℂ) + 1‖ := (one_le_div (norm_pos_iff.mpr z.ne_zero)).mp hn
+  have hsq := (sq_le_sq₀ (norm_nonneg (z : ℂ)) (norm_nonneg ((z : ℂ) + 1))).mpr hnorm
+  simp only [Complex.sq_norm, Complex.normSq_apply, Complex.add_re, Complex.one_re,
+    Complex.add_im, Complex.one_im, add_zero, UpperHalfPlane.coe_re, UpperHalfPlane.coe_im] at hsq
+  linarith
+
+private theorem SpecialPeriods.Triangle.generatorOne_sq_reflections (z : ℍ) :
+    (generatorOneSL ^ 2) • z = circleReflection (rightReflection z) := by
+  apply UpperHalfPlane.ext
+  rw [generatorOneSL_sq_smul_coe, circleReflection_coe, rightReflection_coe]
+  simp only [map_sub, map_neg, map_one, Complex.conj_conj]
+  rw [show (-1 : ℂ) - (z : ℂ) + 1 = -(z : ℂ) by ring]
+  simp [one_div, sub_eq_add_neg]
+
+private theorem SpecialPeriods.Triangle.generatorOne_closedFirst_return (z : ℍ)
+    (hz : z ∈ closedFirstSector) (hw : generatorOneSL • z ∈ closedFirstSector) :
+    generatorOneSL • z = circleReflection z := by
+  have hx : (generatorOneSL • z).re = -(1 / 2) :=
+    le_antisymm hw.1 (generatorOne_re_lower_of_one_le_norm_mo1973_19748 z hz.2)
+  have hfix := (rightReflection_fixed_iff (generatorOneSL • z)).mpr hx
+  calc
+    generatorOneSL • z = rightReflection (generatorOneSL • z) := hfix.symm
+    _ = circleReflection z := by rw [generatorOne_reflections, rightReflection_involutive]
+
+private theorem SpecialPeriods.Triangle.generatorOne_sq_closedFirst_return (z : ℍ)
+    (hz : z ∈ closedFirstSector) (hw : (generatorOneSL ^ 2) • z ∈ closedFirstSector) :
+    (generatorOneSL ^ 2) • z = circleReflection z := by
+  have hx : z.re = -(1 / 2) :=
+    le_antisymm hz.1 (re_lower_of_one_le_generatorOne_sq_norm_mo1973_19749 z hw.2)
+  rw [generatorOne_sq_reflections, (rightReflection_fixed_iff z).mpr hx]
+
+private theorem
+    SpecialPeriods.Triangle.generatorOne_closed_return (z : ℍ) (hz : z ∈ circularDoubleRegion)
+    (hw : generatorOneSL • z ∈ circularDoubleRegion) : generatorOneSL • z = circleReflection z :=
+  generatorOne_closedFirst_return z hz.1 hw.1
+
+private theorem SpecialPeriods.Triangle.generatorOne_sq_closed_return (z : ℍ)
+    (hz : z ∈ circularDoubleRegion) (hw : (generatorOneSL ^ 2) • z ∈ circularDoubleRegion) :
+    (generatorOneSL ^ 2) • z = circleReflection z :=
+  generatorOne_sq_closedFirst_return z hz.1 hw.1
+
+private theorem SpecialPeriods.Triangle.eq_centerTwo_of_secondSector_boundaries_mo1973_19755
+    (z : ℍ) (hr : z.re = stripLeft) (hn : ‖(z : ℂ) - (stripLeft : ℂ)‖ = stripRight) :
+    z = centerTwo := by
+  have hs := congrArg (fun r : ℝ => r ^ 2) hn
+  rw [Complex.sq_norm, Complex.normSq_apply] at hs
+  simp only [Complex.sub_re, Complex.sub_im, Complex.ofReal_re, Complex.ofReal_im,
+    UpperHalfPlane.coe_re, UpperHalfPlane.coe_im, hr, sub_self, sub_zero, MulZeroClass.zero_mul,
+    zero_add] at hs
+  have hi : z.im = stripRight := by nlinarith [z.im_pos, stripRight_pos]
+  apply UpperHalfPlane.ext
+  apply Complex.ext
+  · simpa only [UpperHalfPlane.coe_re, centerTwo_re, stripLeft] using hr
+  · simpa only [UpperHalfPlane.coe_im, centerTwo_im, stripRight] using hi
+
+private theorem SpecialPeriods.Triangle.generatorTwo_smul_cube_mo1973_19756 (z : ℍ) :
+    generatorTwoSL • ((generatorTwoSL ^ 3 : SL(2, ℝ)) • z) = z := by
+  rw [← SemigroupAction.mul_smul, ← pow_succ']
+  change realSLPermutation (generatorTwoSL ^ 4) z = z
+  rw [generatorTwoSL_fourth, realSLPermutation_neg_one]
+  rfl
+
+private theorem SpecialPeriods.Triangle.generatorTwo_closedSecond_return (z : ℍ)
+    (hz : z ∈ closedSecondSector) (hgz : generatorTwoSL • z ∈ closedSecondSector) :
+    generatorTwoSL • z = circleReflection z := by
+  have hr : z.re = stripLeft :=
+    le_antisymm (le_of_not_gt fun h => (not_lt_of_ge hgz.2) (generatorTwo_shift_norm_lt z h)) hz.1
+  rw [generatorTwo_reflections, (leftReflection_fixed_iff z).mpr hr]
+
+private theorem SpecialPeriods.Triangle.generatorTwo_sq_closedSecond_return_eq_centerTwo (z : ℍ)
+    (hz : z ∈ closedSecondSector)
+    (hgz : (generatorTwoSL ^ 2 : SL(2, ℝ)) • z ∈ closedSecondSector) : z = centerTwo := by
+  have hr : z.re = stripLeft :=
+    le_antisymm (le_of_not_gt fun h => (not_lt_of_ge hgz.1) (generatorTwo_sq_re_lt_stripLeft z h))
+      hz.1
+  have hn := hgz.2
+  rw [generatorTwo_sq_shift, norm_div, norm_neg, norm_pow, Complex.norm_real, Real.norm_eq_abs,
+    abs_of_pos stripRight_pos] at hn
+  have hp : 0 < ‖(z : ℂ) - (stripLeft : ℂ)‖ := stripRight_pos.trans_le hz.2
+  have hle : ‖(z : ℂ) - (stripLeft : ℂ)‖ ≤ stripRight := by
+    apply (mul_le_mul_iff_of_pos_left stripRight_pos).mp
+    simpa only [pow_two] using (le_div_iff₀ hp).mp hn
+  exact eq_centerTwo_of_secondSector_boundaries_mo1973_19755 z hr (le_antisymm hle hz.2)
+
+private theorem SpecialPeriods.Triangle.generatorTwo_sq_closedSecond_return (z : ℍ)
+    (hz : z ∈ closedSecondSector)
+    (hgz : (generatorTwoSL ^ 2 : SL(2, ℝ)) • z ∈ closedSecondSector) :
+    (generatorTwoSL ^ 2 : SL(2, ℝ)) • z = circleReflection z := by
+  obtain rfl := generatorTwo_sq_closedSecond_return_eq_centerTwo z hz hgz
+  have hl : leftReflection centerTwo = centerTwo :=
+    (leftReflection_fixed_iff centerTwo).mpr centerTwo_re
+  have hc : circleReflection centerTwo = centerTwo := by
+    have h := generatorTwo_reflections centerTwo
+    rw [generatorTwo_fix, hl] at h
+    exact h.symm
+  simp only [pow_two, SemigroupAction.mul_smul, generatorTwo_fix, hc]
+
+private theorem SpecialPeriods.Triangle.generatorTwo_cube_closedSecond_return (z : ℍ)
+    (hz : z ∈ closedSecondSector)
+    (hgz : (generatorTwoSL ^ 3 : SL(2, ℝ)) • z ∈ closedSecondSector) :
+    (generatorTwoSL ^ 3 : SL(2, ℝ)) • z = circleReflection z := by
+  have h :=
+    generatorTwo_closedSecond_return ((generatorTwoSL ^ 3 : SL(2, ℝ)) • z) hgz
+      (by simpa only [generatorTwo_smul_cube_mo1973_19756] using hz)
+  have hc := congrArg circleReflection h
+  simpa only [generatorTwo_smul_cube_mo1973_19756,
+    circleReflection_involutive ((generatorTwoSL ^ 3 : SL(2, ℝ)) • z)] using hc.symm
+
+private theorem
+    SpecialPeriods.Triangle.generatorTwo_closed_return (z : ℍ) (hz : z ∈ circularDoubleRegion)
+    (hgz : generatorTwoSL • z ∈ circularDoubleRegion) : generatorTwoSL • z = circleReflection z :=
+  generatorTwo_closedSecond_return z hz.2 hgz.2
+
+private theorem SpecialPeriods.Triangle.generatorTwo_sq_closed_return (z : ℍ)
+    (hz : z ∈ circularDoubleRegion)
+    (hgz : (generatorTwoSL ^ 2 : SL(2, ℝ)) • z ∈ circularDoubleRegion) :
+    (generatorTwoSL ^ 2 : SL(2, ℝ)) • z = circleReflection z :=
+  generatorTwo_sq_closedSecond_return z hz.2 hgz.2
+
+private theorem SpecialPeriods.Triangle.generatorTwo_cube_closed_return (z : ℍ)
+    (hz : z ∈ circularDoubleRegion)
+    (hgz : (generatorTwoSL ^ 3 : SL(2, ℝ)) • z ∈ circularDoubleRegion) :
+    (generatorTwoSL ^ 3 : SL(2, ℝ)) • z = circleReflection z :=
+  generatorTwo_cube_closedSecond_return z hz.2 hgz.2
+
+private theorem SpecialPeriods.Triangle.circleReflection_re (z : ℍ) :
+    (circleReflection z).re = -1 + (z.re + 1) / Complex.normSq ((z : ℂ) + 1) := by
+  change (-1 + 1 / (conj (z : ℂ) + 1)).re = _
+  rw [show conj (z : ℂ) + 1 = conj ((z : ℂ) + 1) by simp]
+  simp only [one_div, Complex.add_re, Complex.neg_re, Complex.one_re, Complex.inv_re,
+    Complex.conj_re, Complex.normSq_conj, UpperHalfPlane.coe_re]
+
+private theorem SpecialPeriods.Triangle.circleReflection_re_le_neg_half_iff (z : ℍ) :
+    (circleReflection z).re ≤ -(1 / 2) ↔ 1 ≤ ‖(z : ℂ)‖ := by
+  have hd := Complex.normSq_pos.mpr (denominatorOne_ne_zero z)
+  calc
+    (circleReflection z).re ≤ -(1 / 2) ↔ (z.re + 1) / Complex.normSq ((z : ℂ) + 1) ≤ 1 / 2 := by
+      rw [circleReflection_re]
+      constructor <;> intro h <;> linarith
+    _ ↔ z.re + 1 ≤ (1 / 2) * Complex.normSq ((z : ℂ) + 1) := (div_le_iff₀ hd)
+    _ ↔ (1 : ℝ) ^ 2 ≤ ‖(z : ℂ)‖ ^ 2 := by
+      simp only [Complex.sq_norm, Complex.normSq_apply, Complex.add_re, Complex.one_re,
+        Complex.add_im, Complex.one_im, add_zero, UpperHalfPlane.coe_re, UpperHalfPlane.coe_im]
+      constructor <;> intro h <;> nlinarith
+    _ ↔ 1 ≤ ‖(z : ℂ)‖ := sq_le_sq₀ (by norm_num) (norm_nonneg _)
+
+private theorem SpecialPeriods.Triangle.one_le_circleReflection_norm_iff (z : ℍ) :
+    1 ≤ ‖(circleReflection z : ℂ)‖ ↔ z.re ≤ -(1 / 2) := by
+  simpa only [circleReflection_involutive z] using
+    (circleReflection_re_le_neg_half_iff (circleReflection z)).symm
+
+private theorem SpecialPeriods.Triangle.circleReflection_re_ge_stripLeft_iff (z : ℍ) :
+    stripLeft ≤ (circleReflection z).re ↔ stripRight ≤ ‖(z : ℂ) - (stripLeft : ℂ)‖ := by
+  have hd := Complex.normSq_pos.mpr (denominatorOne_ne_zero z)
+  have hL : stripLeft = -stripRight - 1 := by linarith [stripLeft_add_stripRight]
+  have he :
+    stripRight * (‖(z : ℂ) - (stripLeft : ℂ)‖ ^ 2 - stripRight ^ 2) =
+      z.re + 1 + stripRight * Complex.normSq ((z : ℂ) + 1) := by
+    simp only [Complex.sq_norm, Complex.normSq_apply, Complex.sub_re, Complex.sub_im,
+      Complex.ofReal_re, Complex.ofReal_im, sub_zero, Complex.add_re, Complex.add_im,
+      Complex.one_re, Complex.one_im, add_zero, UpperHalfPlane.coe_re, UpperHalfPlane.coe_im, hL]
+    linear_combination (2 * z.re + 2) * stripRight_sq
+  calc
+    stripLeft ≤ (circleReflection z).re ↔
+        -stripRight ≤ (z.re + 1) / Complex.normSq ((z : ℂ) + 1) := by
+      rw [circleReflection_re, hL]
+      constructor <;> intro h <;> linarith
+    _ ↔ -stripRight * Complex.normSq ((z : ℂ) + 1) ≤ z.re + 1 := (le_div_iff₀ hd)
+    _ ↔ 0 ≤ z.re + 1 + stripRight * Complex.normSq ((z : ℂ) + 1) := by
+      constructor <;> intro h <;> linarith
+    _ ↔ 0 ≤ stripRight * (‖(z : ℂ) - (stripLeft : ℂ)‖ ^ 2 - stripRight ^ 2) := by rw [he]
+    _ ↔ 0 ≤ ‖(z : ℂ) - (stripLeft : ℂ)‖ ^ 2 - stripRight ^ 2 :=
+      (mul_nonneg_iff_of_pos_left stripRight_pos)
+    _ ↔ stripRight ^ 2 ≤ ‖(z : ℂ) - (stripLeft : ℂ)‖ ^ 2 := sub_nonneg
+    _ ↔ stripRight ≤ ‖(z : ℂ) - (stripLeft : ℂ)‖ := sq_le_sq₀ stripRight_pos.le (norm_nonneg _)
+
+private theorem
+    SpecialPeriods.Triangle.stripRight_le_circleReflection_sub_stripLeft_norm_iff (z : ℍ) :
+    stripRight ≤ ‖(circleReflection z : ℂ) - (stripLeft : ℂ)‖ ↔ stripLeft ≤ z.re := by
+  simpa only [circleReflection_involutive z] using
+    (circleReflection_re_ge_stripLeft_iff (circleReflection z)).symm
+
+@[simp]
+private theorem SpecialPeriods.Triangle.circleReflection_mem_closedFirstSector_iff (z : ℍ) :
+    circleReflection z ∈ closedFirstSector ↔ z ∈ closedFirstSector := by
+  change
+    (circleReflection z).re ≤ -(1 / 2) ∧ 1 ≤ ‖(circleReflection z : ℂ)‖ ↔
+      z.re ≤ -(1 / 2) ∧ 1 ≤ ‖(z : ℂ)‖
+  rw [circleReflection_re_le_neg_half_iff, one_le_circleReflection_norm_iff, and_comm]
+
+@[simp]
+private theorem SpecialPeriods.Triangle.circleReflection_mem_closedSecondSector_iff (z : ℍ) :
+    circleReflection z ∈ closedSecondSector ↔ z ∈ closedSecondSector := by
+  change
+    stripLeft ≤ (circleReflection z).re ∧
+        stripRight ≤ ‖(circleReflection z : ℂ) - (stripLeft : ℂ)‖ ↔
+      stripLeft ≤ z.re ∧ stripRight ≤ ‖(z : ℂ) - (stripLeft : ℂ)‖
+  rw [circleReflection_re_ge_stripLeft_iff, stripRight_le_circleReflection_sub_stripLeft_norm_iff,
+    and_comm]
+
+@[simp]
+private theorem SpecialPeriods.Triangle.circleReflection_mem_circularDoubleRegion_iff (z : ℍ) :
+    circleReflection z ∈ circularDoubleRegion ↔ z ∈ circularDoubleRegion := by
+  simp only [circularDoubleRegion, Set.mem_inter_iff, circleReflection_mem_closedFirstSector_iff,
+    circleReflection_mem_closedSecondSector_iff]
+
+private theorem SpecialPeriods.Triangle.circleReflection_mapsTo_circularDoubleRegion :
+    Set.MapsTo circleReflection circularDoubleRegion circularDoubleRegion := fun z hz =>
+  (circleReflection_mem_circularDoubleRegion_iff z).mpr hz
+
+private theorem SpecialPeriods.Triangle.circleReflection_add_one_norm (z : ℍ) :
+    ‖(circleReflection z : ℂ) + 1‖ = 1 / ‖(z : ℂ) + 1‖ := by
+  rw [circleReflection_coe]
+  have he : (-1 : ℂ) + 1 / (conj (z : ℂ) + 1) + 1 = 1 / (conj (z : ℂ) + 1) := by ring
+  rw [he, norm_div, NormOneClass.norm_one, show conj (z : ℂ) + 1 = conj ((z : ℂ) + 1) by simp,
+    Complex.norm_conj]
+
+private theorem SpecialPeriods.Triangle.fordRegion_subset_closedSecondSector :
+    fordRegion ⊆ closedSecondSector := by
+  intro z hz
+  refine ⟨hz.1, ?_⟩
+  have hn : 1 ≤ Complex.normSq ((z : ℂ) + 1) := by
+    rw [Complex.normSq_eq_norm_sq]
+    nlinarith [hz.2.2.1]
+  have hprod : 0 ≤ stripRight * (z.re - stripLeft) :=
+    mul_nonneg stripRight_pos.le (sub_nonneg.mpr hz.1)
+  have hs : stripRight ^ 2 ≤ ‖(z : ℂ) - (stripLeft : ℂ)‖ ^ 2 := by
+    rw [Complex.sq_norm]
+    simp only [Complex.normSq_apply, Complex.sub_re, Complex.ofReal_re, Complex.sub_im,
+      Complex.ofReal_im, sub_zero, Complex.add_re, Complex.one_re, Complex.add_im, Complex.one_im,
+      add_zero, UpperHalfPlane.coe_re, UpperHalfPlane.coe_im] at hn ⊢
+    have hleft : stripLeft = -1 - stripRight := by linarith [stripLeft_add_stripRight]
+    rw [hleft] at hprod ⊢
+    nlinarith [stripRight_sq]
+  exact (sq_le_sq₀ stripRight_pos.le (norm_nonneg _)).mp hs
+
+private theorem SpecialPeriods.Triangle.halfFordRegion_subset_circularDoubleRegion :
+    halfFordRegion ⊆ circularDoubleRegion := by
+  intro z hz
+  exact ⟨⟨hz.2, hz.1.2.2.2⟩, fordRegion_subset_closedSecondSector hz.1⟩
+
+private theorem
+    SpecialPeriods.Triangle.circularDoubleRegion_and_norm_add_one_iff_halfFordRegion (z : ℍ) :
+    z ∈ circularDoubleRegion ∧ 1 ≤ ‖(z : ℂ) + 1‖ ↔ z ∈ halfFordRegion := by
+  constructor
+  · rintro ⟨hz, hn⟩
+    refine ⟨⟨hz.2.1, ?_, hn, hz.1.2⟩, hz.1.1⟩
+    linarith [hz.1.1, stripRight_pos]
+  · intro hz
+    exact ⟨halfFordRegion_subset_circularDoubleRegion hz, hz.1.2.2.1⟩
+
+private theorem SpecialPeriods.Triangle.halfFordRegion_eq_circularDoubleRegion_inter :
+    halfFordRegion = circularDoubleRegion ∩ {z | 1 ≤ ‖(z : ℂ) + 1‖} := by
+  ext z
+  exact (circularDoubleRegion_and_norm_add_one_iff_halfFordRegion z).symm
+
+private theorem SpecialPeriods.Triangle.fordRegion_left_mem_circularDoubleRegion (z : ℍ)
+    (hz : z ∈ fordRegion) (hx : z.re ≤ -(1 / 2)) : z ∈ circularDoubleRegion :=
+  halfFordRegion_subset_circularDoubleRegion ⟨hz, hx⟩
+
+private theorem SpecialPeriods.Triangle.circleReflection_image_halfFordRegion :
+    circleReflection '' halfFordRegion = circularDoubleRegion ∩ {z | ‖(z : ℂ) + 1‖ ≤ 1} := by
+  ext z
+  constructor
+  · rintro ⟨w, hw, rfl⟩
+    refine
+      ⟨circleReflection_mapsTo_circularDoubleRegion
+          (halfFordRegion_subset_circularDoubleRegion hw),
+        ?_⟩
+    change ‖(circleReflection w : ℂ) + 1‖ ≤ 1
+    rw [circleReflection_add_one_norm]
+    exact (div_le_one (norm_pos_iff.mpr (denominatorOne_ne_zero w))).mpr hw.1.2.2.1
+  · rintro ⟨hz, hn⟩
+    refine ⟨circleReflection z, ?_, circleReflection_involutive z⟩
+    apply (circularDoubleRegion_and_norm_add_one_iff_halfFordRegion (circleReflection z)).mp
+    refine ⟨circleReflection_mapsTo_circularDoubleRegion hz, ?_⟩
+    rw [circleReflection_add_one_norm]
+    exact (one_le_div (norm_pos_iff.mpr (denominatorOne_ne_zero z))).mpr hn
+
+private theorem SpecialPeriods.Triangle.circularDoubleRegion_eq_halfFordRegion_union_circle :
+    circularDoubleRegion = halfFordRegion ∪ circleReflection '' halfFordRegion := by
+  rw [circleReflection_image_halfFordRegion, halfFordRegion_eq_circularDoubleRegion_inter]
+  ext z
+  change
+    z ∈ circularDoubleRegion ↔
+      ((z ∈ circularDoubleRegion ∧ 1 ≤ ‖(z : ℂ) + 1‖) ∨
+        (z ∈ circularDoubleRegion ∧ ‖(z : ℂ) + 1‖ ≤ 1))
+  constructor
+  · intro hz
+    rcases le_total 1 ‖(z : ℂ) + 1‖ with hn | hn
+    · exact Or.inl ⟨hz, hn⟩
+    · exact Or.inr ⟨hz, hn⟩
+  · rintro (hz | hz) <;> exact hz.1
+
+private theorem SpecialPeriods.Triangle.circleReflection_eq_self_of_halfFordRegion_mem (z : ℍ)
+    (hz : z ∈ halfFordRegion) (hcz : circleReflection z ∈ halfFordRegion) :
+    circleReflection z = z := by
+  have hn : 1 ≤ ‖(circleReflection z : ℂ) + 1‖ := hcz.1.2.2.1
+  rw [circleReflection_add_one_norm] at hn
+  have hle := (one_le_div (norm_pos_iff.mpr (denominatorOne_ne_zero z))).mp hn
+  exact (circleReflection_fixed_iff z).mpr (le_antisymm hle hz.1.2.2.1)
+
+private theorem SpecialPeriods.Triangle.generatorOne_inv_reflections (z : ℍ) :
+    generatorOneSL⁻¹ • z = circleReflection (rightReflection z) := by
+  have h : generatorOneSL • circleReflection (rightReflection z) = z := by
+    rw [generatorOne_reflections, circleReflection_involutive, rightReflection_involutive]
+  simpa only [inv_smul_smul] using congrArg (fun w : ℍ => generatorOneSL⁻¹ • w) h.symm
+
+private theorem SpecialPeriods.lift_neWord_weak_to_strict_mo1973_19793 {ι G α : Type*} [Group G]
+    [MulAction G α] {H : ι → Type*} [∀ i, Group (H i)] (f : ∀ i, H i →* G) (X W : ι → Set α)
+    (hXW : ∀ i, X i ⊆ W i) (hcross : Pairwise fun i j => ∀ h : H i, h ≠ 1 → f i h • W j ⊆ X i)
+    {i j k : ι} (w : Monoid.CoprodI.NeWord H i j) (hk : j ≠ k) :
+    Monoid.CoprodI.lift f w.prod • W k ⊆ X i := by
+  induction w generalizing k with
+  | singleton x hx => simpa using hcross hk x hx
+  | @append i j m l w₁ hne w₂ ih₁
+    ih₂ =>
+    rw [Monoid.CoprodI.NeWord.append_prod, map_mul, SemigroupAction.mul_smul]
+    exact (Set.smul_set_subset_smul_set_iff.mpr ((ih₂ hk).trans (hXW m))).trans (ih₁ hne)
+
+private theorem SpecialPeriods.lift_neWord_closed_domain_subset_mo1973_19794 {ι G α : Type*}
+    [Group G] [MulAction G α] {H : ι → Type*} [∀ i, Group (H i)] (f : ∀ i, H i →* G)
+    (X W : ι → Set α) (D : Set α) (hXW : ∀ i, X i ⊆ W i)
+    (hcross : Pairwise fun i j => ∀ h : H i, h ≠ 1 → f i h • W j ⊆ X i)
+    (hD : ∀ i (h : H i), h ≠ 1 → f i h • D ⊆ W i) {i j : ι} (w : Monoid.CoprodI.NeWord H i j) :
+    Monoid.CoprodI.lift f w.prod • D ⊆ W i := by
+  induction w with
+  | singleton x hx => simpa using hD _ x hx
+  | @append i j k l w₁ hne w₂ _ih₁
+    ih₂ =>
+    rw [Monoid.CoprodI.NeWord.append_prod, map_mul, SemigroupAction.mul_smul]
+    exact
+      (Set.smul_set_subset_smul_set_iff.mpr ih₂).trans
+        ((lift_neWord_weak_to_strict_mo1973_19793 f X W hXW hcross w₁ hne).trans (hXW i))
+
+private theorem SpecialPeriods.lift_neWord_factor_or_strict_mo1973_19795 {ι G α : Type*} [Group G]
+    [MulAction G α] {H : ι → Type*} [∀ i, Group (H i)] (f : ∀ i, H i →* G) (X W : ι → Set α)
+    (D : Set α) (hXW : ∀ i, X i ⊆ W i)
+    (hcross : Pairwise fun i j => ∀ h : H i, h ≠ 1 → f i h • W j ⊆ X i)
+    (hD : ∀ i (h : H i), h ≠ 1 → f i h • D ⊆ W i) {i j : ι} (w : Monoid.CoprodI.NeWord H i j) :
+    (∃ x : H i, w.prod = Monoid.CoprodI.of x) ∨ Monoid.CoprodI.lift f w.prod • D ⊆ X i := by
+  cases w with
+  | singleton x hx => exact Or.inl ⟨x, Monoid.CoprodI.NeWord.prod_singleton x hx⟩
+  | @append i j k l w₁ hne w₂ =>
+    right
+    rw [Monoid.CoprodI.NeWord.append_prod, map_mul, SemigroupAction.mul_smul]
+    exact
+      (Set.smul_set_subset_smul_set_iff.mpr
+            (lift_neWord_closed_domain_subset_mo1973_19794 f X W D hXW hcross hD w₂)).trans
+        (lift_neWord_weak_to_strict_mo1973_19793 f X W hXW hcross w₁ hne)
+
+private theorem SpecialPeriods.gluing_cyclicPowerHom_two_mo1973_19796 {G : Type*} [Group G]
+    (n : ℕ) (a : G) (ha : a ^ n = 1) :
+    cyclicPowerHom n a ha (Multiplicative.ofAdd (2 : ZMod n)) = a ^ 2 := by
+  simpa only [Int.cast_ofNat, zpow_ofNat] using cyclicPowerHom_intCast n a ha (2 : ℤ)
+
+private theorem SpecialPeriods.gluing_cyclicPowerHom_three_mo1973_19797 {G : Type*} [Group G]
+    (n : ℕ) (a : G) (ha : a ^ n = 1) :
+    cyclicPowerHom n a ha (Multiplicative.ofAdd (3 : ZMod n)) = a ^ 3 := by
+  simpa only [Int.cast_ofNat, zpow_ofNat] using cyclicPowerHom_intCast n a ha (3 : ℤ)
+
+private theorem SpecialPeriods.cyclicThree_closed_subset_mo1973_19798 {G α : Type*} [Group G]
+    [MulAction G α] (a : G) (ha : a ^ 3 = 1) (S T : Set α) (h₁ : Set.MapsTo (fun z => a • z) S T)
+    (h₂ : Set.MapsTo (fun z => a ^ 2 • z) S T) (g : Multiplicative (ZMod 3)) (hg : g ≠ 1) :
+    cyclicPowerHom 3 a ha g • S ⊆ T := by
+  have hc : g = Multiplicative.ofAdd (1 : ZMod 3) ∨ g = Multiplicative.ofAdd (2 : ZMod 3) :=
+    (by decide :
+        ∀ x : Multiplicative (ZMod 3),
+          x ≠ 1 → x = Multiplicative.ofAdd 1 ∨ x = Multiplicative.ofAdd 2)
+      g hg
+  rcases hc with rfl | rfl
+  · rw [cyclicPowerHom_one]
+    exact Set.smul_set_subset_iff.mpr h₁
+  · rw [gluing_cyclicPowerHom_two_mo1973_19796]
+    exact Set.smul_set_subset_iff.mpr h₂
+
+private theorem SpecialPeriods.cyclicFour_closed_subset_mo1973_19799 {G α : Type*} [Group G]
+    [MulAction G α] (b : G) (hb : b ^ 4 = 1) (S T : Set α) (h₁ : Set.MapsTo (fun z => b • z) S T)
+    (h₂ : Set.MapsTo (fun z => b ^ 2 • z) S T) (h₃ : Set.MapsTo (fun z => b ^ 3 • z) S T)
+    (g : Multiplicative (ZMod 4)) (hg : g ≠ 1) : cyclicPowerHom 4 b hb g • S ⊆ T := by
+  have hc :
+    g = Multiplicative.ofAdd (1 : ZMod 4) ∨
+      g = Multiplicative.ofAdd (2 : ZMod 4) ∨ g = Multiplicative.ofAdd (3 : ZMod 4) :=
+    (by decide :
+        ∀ x : Multiplicative (ZMod 4),
+          x ≠ 1 →
+            x = Multiplicative.ofAdd 1 ∨ x = Multiplicative.ofAdd 2 ∨ x = Multiplicative.ofAdd 3)
+      g hg
+  rcases hc with rfl | rfl | rfl
+  · rw [cyclicPowerHom_one]
+    exact Set.smul_set_subset_iff.mpr h₁
+  · rw [gluing_cyclicPowerHom_two_mo1973_19796]
+    exact Set.smul_set_subset_iff.mpr h₂
+  · rw [gluing_cyclicPowerHom_three_mo1973_19797]
+    exact Set.smul_set_subset_iff.mpr h₃
+
+private theorem SpecialPeriods.cyclic_eq_generator_pow_val_mo1973_19800 {n : ℕ} [NeZero n]
+    (x : Multiplicative (ZMod n)) : x = Multiplicative.ofAdd (1 : ZMod n) ^ x.toAdd.val := by
+  change x.toAdd = x.toAdd.val • (1 : ZMod n)
+  simp only [nsmul_eq_mul, mul_one, ZMod.natCast_zmod_val]
+
+private theorem
+    SpecialPeriods.triangleLift_eq_generator_pow_of_closed_domain_mem {G α : Type*} [Group G]
+    [MulAction G α] (a b : G) (ha : a ^ 3 = 1) (hb : b ^ 4 = 1) (X Y XB YB D : Set α)
+    (hXXB : X ⊆ XB) (hYYB : Y ⊆ YB) (ha₁ : Set.MapsTo (fun z => a • z) YB X)
+    (ha₂ : Set.MapsTo (fun z => a ^ 2 • z) YB X) (hb₁ : Set.MapsTo (fun z => b • z) XB Y)
+    (hb₂ : Set.MapsTo (fun z => b ^ 2 • z) XB Y) (hb₃ : Set.MapsTo (fun z => b ^ 3 • z) XB Y)
+    (hDa₁ : Set.MapsTo (fun z => a • z) D XB) (hDa₂ : Set.MapsTo (fun z => a ^ 2 • z) D XB)
+    (hDb₁ : Set.MapsTo (fun z => b • z) D YB) (hDb₂ : Set.MapsTo (fun z => b ^ 2 • z) D YB)
+    (hDb₃ : Set.MapsTo (fun z => b ^ 3 • z) D YB) (hDX : Disjoint D X) (hDY : Disjoint D Y)
+    (g : TriangleGroup) {z : α} (hz : z ∈ D) (hgz : triangleLift a b ha hb g • z ∈ D) :
+    (∃ n : ℕ, n < 3 ∧ g = triangleGenerator₁ ^ n) ∨
+      (∃ n : ℕ, n < 4 ∧ g = triangleGenerator₂ ^ n) := by
+  classical
+  by_cases hg : g = 1
+  · exact Or.inl ⟨0, by decide, by simpa using hg⟩
+  let H : Bool → Type := fun i => cond i (Multiplicative (ZMod 4)) (Multiplicative (ZMod 3))
+  let : ∀ i, Group (H i) :=
+    Bool.rec (inferInstance : Group (Multiplicative (ZMod 3)))
+      (inferInstance : Group (Multiplicative (ZMod 4)))
+  let f : ∀ i, H i →* G := fun i =>
+    match i with
+    | false => cyclicPowerHom 3 a ha
+    | true => cyclicPowerHom 4 b hb
+  let toI : TriangleGroup →* Monoid.CoprodI H :=
+    Monoid.Coprod.lift (Monoid.CoprodI.of (M := H) (i := Bool.false))
+      (Monoid.CoprodI.of (M := H) (i := Bool.true))
+  let fromI : Monoid.CoprodI H →* TriangleGroup :=
+    Monoid.CoprodI.lift fun i =>
+      match i with
+      | false => Monoid.Coprod.inl
+      | true => Monoid.Coprod.inr
+  have hleft : fromI.comp toI = MonoidHom.id TriangleGroup := by
+    apply triangle_hom_ext
+    · simp [toI, fromI, triangleGenerator₁]
+    · simp [toI, fromI, triangleGenerator₂]
+  have hto_ne : toI g ≠ 1 := by
+    intro h
+    apply hg
+    calc
+      g = fromI (toI g) := (DFunLike.congr_fun hleft g).symm
+      _ = 1 := by rw [h, map_one]
+  have hrepresentation : triangleLift a b ha hb = (Monoid.CoprodI.lift f).comp toI := by
+    apply triangle_hom_ext
+    · simp only [triangleLift_generator₁, MonoidHom.coe_comp, Function.comp_apply]
+      exact (cyclicPowerHom_one 3 a ha).symm
+    · simp only [triangleLift_generator₂, MonoidHom.coe_comp, Function.comp_apply]
+      exact (cyclicPowerHom_one 4 b hb).symm
+  let U : Bool → Set α := fun i => cond i Y X
+  let W : Bool → Set α := fun i => cond i YB XB
+  have hUW : ∀ i, U i ⊆ W i := by
+    intro i
+    cases i
+    · exact hXXB
+    · exact hYYB
+  have hcross : Pairwise fun i j => ∀ h : H i, h ≠ 1 → f i h • W j ⊆ U i := by
+    intro i j hij h hh
+    cases i <;> cases j
+    · exact (hij rfl).elim
+    · exact cyclicThree_closed_subset_mo1973_19798 a ha YB X ha₁ ha₂ h hh
+    · exact cyclicFour_closed_subset_mo1973_19799 b hb XB Y hb₁ hb₂ hb₃ h hh
+    · exact (hij rfl).elim
+  have hstart : ∀ i (h : H i), h ≠ 1 → f i h • D ⊆ W i := by
+    intro i h hh
+    cases i
+    · exact cyclicThree_closed_subset_mo1973_19798 a ha D XB hDa₁ hDa₂ h hh
+    · exact cyclicFour_closed_subset_mo1973_19799 b hb D YB hDb₁ hDb₂ hDb₃ h hh
+  let : (i : Bool) → DecidableEq (H i) := fun _ => Classical.decEq _
+  let r := Monoid.CoprodI.Word.equiv (M := H) (toI g)
+  have hr : r.prod = toI g := (Monoid.CoprodI.Word.equiv (M := H)).symm_apply_apply (toI g)
+  have hr_ne : r ≠ Monoid.CoprodI.Word.empty := by
+    intro h
+    apply hto_ne
+    rw [← hr, h, Monoid.CoprodI.Word.prod_empty]
+  obtain ⟨i, j, w, hw⟩ := Monoid.CoprodI.NeWord.of_word r hr_ne
+  have hwprod : w.prod = toI g := by
+    change w.toWord.prod = toI g
+    rw [hw]
+    exact hr
+  rcases lift_neWord_factor_or_strict_mo1973_19795 f U W D hUW hcross hstart w with ⟨x, hx⟩ |
+    himage
+  · have hfrom : fromI (Monoid.CoprodI.of x) = g := by
+      rw [← hx, hwprod]
+      exact DFunLike.congr_fun hleft g
+    cases i
+    · left
+      refine ⟨x.toAdd.val, ZMod.val_lt x.toAdd, ?_⟩
+      calc
+        g = Monoid.Coprod.inl x := by simpa [fromI] using hfrom.symm
+        _ = triangleGenerator₁ ^ x.toAdd.val := by
+          rw [triangleGenerator₁, ← map_pow]
+          exact congrArg Monoid.Coprod.inl (cyclic_eq_generator_pow_val_mo1973_19800 x)
+    · right
+      refine ⟨x.toAdd.val, ZMod.val_lt x.toAdd, ?_⟩
+      calc
+        g = Monoid.Coprod.inr x := by simpa [fromI] using hfrom.symm
+        _ = triangleGenerator₂ ^ x.toAdd.val := by
+          rw [triangleGenerator₂, ← map_pow]
+          exact congrArg Monoid.Coprod.inr (cyclic_eq_generator_pow_val_mo1973_19800 x)
+  · have heval : triangleLift a b ha hb g = Monoid.CoprodI.lift f (toI g) :=
+      DFunLike.congr_fun hrepresentation g
+    have hstrict : triangleLift a b ha hb g • z ∈ U i := by
+      rw [heval, ← hwprod]
+      exact Set.smul_set_subset_iff.mp himage hz
+    cases i
+    · exact (hDX.le_bot ⟨hgz, hstrict⟩).elim
+    · exact (hDY.le_bot ⟨hgz, hstrict⟩).elim
+
+private theorem SpecialPeriods.Triangle.circularDoubleRegion_return_generator_pow
+    (g : SpecialPeriods.TriangleGroup) {z : ℍ} (hz : z ∈ circularDoubleRegion)
+    (hgz : SpecialPeriods.triangleGeometricRepresentation g z ∈ circularDoubleRegion) :
+    (∃ n : ℕ, n < 3 ∧ g = SpecialPeriods.triangleGenerator₁ ^ n) ∨
+      (∃ n : ℕ, n < 4 ∧ g = SpecialPeriods.triangleGenerator₂ ^ n) := by
+  exact
+    SpecialPeriods.triangleLift_eq_generator_pow_of_closed_domain_mem generatorOnePerm
+      generatorTwoPerm generatorOnePerm_cube generatorTwoPerm_fourth firstExcluded secondExcluded
+      firstWeakExcluded secondWeakExcluded circularDoubleRegion
+      firstExcluded_subset_firstWeakExcluded secondExcluded_subset_secondWeakExcluded
+      (fun _ hw => generatorOnePerm_firstSector (secondWeakExcluded_subset_firstSector hw))
+      (fun _ hw => generatorOnePerm_sq_firstSector (secondWeakExcluded_subset_firstSector hw))
+      (fun _ hw => generatorTwoPerm_secondSector (firstWeakExcluded_subset_secondSector hw))
+      (fun _ hw => generatorTwoPerm_sq_secondSector (firstWeakExcluded_subset_secondSector hw))
+      (fun _ hw => generatorTwoPerm_cube_secondSector (firstWeakExcluded_subset_secondSector hw))
+      (fun _ hw => generatorOne_closedFirstSector hw.1)
+      (fun z hw => by
+        change (generatorOnePerm ^ 2) z ∈ firstWeakExcluded
+        rw [generatorOnePerm_pow_apply]
+        exact generatorOne_sq_closedFirstSector hw.1)
+      (fun _ hw => generatorTwo_closedSecondSector hw.2)
+      (fun z hw => by
+        change (generatorTwoPerm ^ 2) z ∈ secondWeakExcluded
+        rw [generatorTwoPerm_pow_apply]
+        exact generatorTwo_sq_closedSecondSector hw.2)
+      (fun z hw => by
+        change (generatorTwoPerm ^ 3) z ∈ secondWeakExcluded
+        rw [generatorTwoPerm_pow_apply]
+        exact generatorTwo_cube_closedSecondSector hw.2)
+      circularDoubleRegion_disjoint_firstExcluded circularDoubleRegion_disjoint_secondExcluded g
+      hz hgz
+
+private theorem SpecialPeriods.Triangle.circularDoubleRegion_orbit_point
+    (g : SpecialPeriods.TriangleGroup) {z : ℍ} (hz : z ∈ circularDoubleRegion)
+    (hgz : SpecialPeriods.triangleGeometricRepresentation g z ∈ circularDoubleRegion) :
+    SpecialPeriods.triangleGeometricRepresentation g z = z ∨
+      SpecialPeriods.triangleGeometricRepresentation g z = circleReflection z := by
+  rcases circularDoubleRegion_return_generator_pow g hz hgz with ⟨n, hn, rfl⟩ | ⟨n, hn, rfl⟩
+  · simp only [map_pow, SpecialPeriods.triangleGeometricRepresentation_generator₁,
+      generatorOnePerm_pow_apply] at hgz ⊢
+    interval_cases n
+    · exact Or.inl (by simp)
+    · right
+      simp only [pow_one] at hgz ⊢
+      exact generatorOne_closed_return z hz hgz
+    · exact Or.inr (generatorOne_sq_closed_return z hz hgz)
+  · simp only [map_pow, SpecialPeriods.triangleGeometricRepresentation_generator₂,
+      generatorTwoPerm_pow_apply] at hgz ⊢
+    interval_cases n
+    · exact Or.inl (by simp)
+    · right
+      simp only [pow_one] at hgz ⊢
+      exact generatorTwo_closed_return z hz hgz
+    · exact Or.inr (generatorTwo_sq_closed_return z hz hgz)
+    · exact Or.inr (generatorTwo_cube_closed_return z hz hgz)
+
+private theorem SpecialPeriods.Triangle.circularDoubleRegion_orbit_point_of_eq
+    (g : SpecialPeriods.TriangleGroup) {z w : ℍ} (hz : z ∈ circularDoubleRegion)
+    (hw : w ∈ circularDoubleRegion)
+    (hzw : SpecialPeriods.triangleGeometricRepresentation g z = w) :
+    w = z ∨ w = circleReflection z := by
+  simpa only [hzw] using circularDoubleRegion_orbit_point g hz (hzw ▸ hw)
+
+private def SpecialPeriods.Triangle.circularHalfPoint_mo1973_19807 (z : ℍ) : ℍ := by
+  classical exact if 1 ≤ ‖(z : ℂ) + 1‖ then z else circleReflection z
+
+private theorem SpecialPeriods.Triangle.circularHalfPoint_of_half_mo1973_19808 {z : ℍ}
+    (hz : z ∈ halfFordRegion) : circularHalfPoint_mo1973_19807 z = z := by
+  simp only [circularHalfPoint_mo1973_19807, ite_eq_left hz.1.2.2.1]
+
+private theorem SpecialPeriods.Triangle.circularHalfPoint_circle_of_half_mo1973_19809 {z : ℍ}
+    (hz : z ∈ halfFordRegion) : circularHalfPoint_mo1973_19807 (circleReflection z) = z := by
+  by_cases hn : 1 ≤ ‖(circleReflection z : ℂ) + 1‖
+  · rw [circularHalfPoint_mo1973_19807, ite_eq_left hn]
+    apply circleReflection_eq_self_of_halfFordRegion_mem z hz
+    exact
+      (circularDoubleRegion_and_norm_add_one_iff_halfFordRegion _).mp
+        ⟨circleReflection_mapsTo_circularDoubleRegion
+            (halfFordRegion_subset_circularDoubleRegion hz),
+          hn⟩
+  · rw [circularHalfPoint_mo1973_19807, ite_eq_right hn, circleReflection_involutive z]
+
+private theorem SpecialPeriods.Triangle.circularHalfPoint_circle_mo1973_19810 {z : ℍ}
+    (hz : z ∈ circularDoubleRegion) :
+    circularHalfPoint_mo1973_19807 (circleReflection z) = circularHalfPoint_mo1973_19807 z := by
+  rw [circularDoubleRegion_eq_halfFordRegion_union_circle] at hz
+  rcases hz with hz | ⟨w, hw, rfl⟩
+  · rw [circularHalfPoint_circle_of_half_mo1973_19809 hz,
+      circularHalfPoint_of_half_mo1973_19808 hz]
+  · rw [circleReflection_involutive w, circularHalfPoint_of_half_mo1973_19808 hw,
+      circularHalfPoint_circle_of_half_mo1973_19809 hw]
+
+private def SpecialPeriods.Triangle.fordHalfPoint_mo1973_19811 (z : ℍ) : ℍ := by
+  classical exact if z.re ≤ -(1 / 2) then z else rightReflection z
+
+private theorem SpecialPeriods.Triangle.fordHalfPoint_mem_mo1973_19812 {z : ℍ}
+    (hz : z ∈ fordRegion) : fordHalfPoint_mo1973_19811 z ∈ halfFordRegion := by
+  by_cases hx : z.re ≤ -(1 / 2)
+  · rw [fordHalfPoint_mo1973_19811, ite_eq_left hx]
+    exact ⟨hz, hx⟩
+  · rw [fordHalfPoint_mo1973_19811, ite_eq_right hx]
+    refine ⟨rightReflection_mapsTo_fordRegion hz, ?_⟩
+    change (rightReflection z).re ≤ -(1 / 2)
+    rw [rightReflection_re]
+    have hh := lt_of_not_ge hx
+    linarith
+
+private theorem SpecialPeriods.Triangle.eq_or_reflection_of_fordHalfPoint_eq_mo1973_19813
+    {z w : ℍ} (h : fordHalfPoint_mo1973_19811 w = fordHalfPoint_mo1973_19811 z) :
+    w = z ∨ w = rightReflection z := by
+  by_cases hz : z.re ≤ -(1 / 2) <;> by_cases hw : w.re ≤ -(1 / 2)
+  · left
+    simpa only [fordHalfPoint_mo1973_19811, ite_eq_left hz, ite_eq_left hw] using h
+  · right
+    have hh : rightReflection w = z := by
+      simpa only [fordHalfPoint_mo1973_19811, ite_eq_left hz, ite_eq_right hw] using h
+    have he := congrArg rightReflection hh
+    simpa only [rightReflection_involutive w] using he
+  · right
+    simpa only [fordHalfPoint_mo1973_19811, ite_eq_right hz, ite_eq_left hw] using h
+  · left
+    apply rightReflection.injective
+    simpa only [fordHalfPoint_mo1973_19811, ite_eq_right hz, ite_eq_right hw] using h
+
+private def SpecialPeriods.Triangle.fordCircularNormalizer_mo1973_19814 (z : ℍ) :
+    SpecialPeriods.TriangleGroup := by
+  classical exact if z.re ≤ -(1 / 2) then 1 else SpecialPeriods.triangleGenerator₁⁻¹
+
+private def SpecialPeriods.Triangle.fordCircularPoint_mo1973_19815 (z : ℍ) : ℍ :=
+  SpecialPeriods.triangleGeometricRepresentation (fordCircularNormalizer_mo1973_19814 z) z
+
+private theorem SpecialPeriods.Triangle.generatorOne_inv_representation_apply_mo1973_19816
+    (z : ℍ) :
+    SpecialPeriods.triangleGeometricRepresentation SpecialPeriods.triangleGenerator₁⁻¹ z =
+      generatorOneSL⁻¹ • z := by
+  rw [map_inv, SpecialPeriods.triangleGeometricRepresentation_generator₁]
+  change (realSLPermutation generatorOneSL)⁻¹ z = _
+  rw [← map_inv]
+  rfl
+
+private theorem SpecialPeriods.Triangle.fordCircularPoint_of_left_mo1973_19817 {z : ℍ}
+    (hz : z.re ≤ -(1 / 2)) : fordCircularPoint_mo1973_19815 z = z := by
+  rw [fordCircularPoint_mo1973_19815, fordCircularNormalizer_mo1973_19814, ite_eq_left hz, map_one]
+  rfl
+
+private theorem SpecialPeriods.Triangle.fordCircularPoint_of_right_mo1973_19818 {z : ℍ}
+    (hz : ¬z.re ≤ -(1 / 2)) :
+    fordCircularPoint_mo1973_19815 z = circleReflection (rightReflection z) := by
+  rw [fordCircularPoint_mo1973_19815, fordCircularNormalizer_mo1973_19814, ite_eq_right hz,
+    generatorOne_inv_representation_apply_mo1973_19816, generatorOne_inv_reflections]
+
+private theorem SpecialPeriods.Triangle.fordCircularPoint_mem_mo1973_19819 {z : ℍ}
+    (hz : z ∈ fordRegion) : fordCircularPoint_mo1973_19815 z ∈ circularDoubleRegion := by
+  by_cases hx : z.re ≤ -(1 / 2)
+  · rw [fordCircularPoint_of_left_mo1973_19817 hx]
+    exact fordRegion_left_mem_circularDoubleRegion z hz hx
+  · rw [fordCircularPoint_of_right_mo1973_19818 hx]
+    apply circleReflection_mapsTo_circularDoubleRegion
+    have hh := fordHalfPoint_mem_mo1973_19812 hz
+    rw [fordHalfPoint_mo1973_19811, ite_eq_right hx] at hh
+    exact halfFordRegion_subset_circularDoubleRegion hh
+
+private theorem SpecialPeriods.Triangle.circularHalfPoint_fordCircularPoint_mo1973_19820 {z : ℍ}
+    (hz : z ∈ fordRegion) :
+    circularHalfPoint_mo1973_19807 (fordCircularPoint_mo1973_19815 z) =
+      fordHalfPoint_mo1973_19811 z := by
+  by_cases hx : z.re ≤ -(1 / 2)
+  · rw [fordCircularPoint_of_left_mo1973_19817 hx, fordHalfPoint_mo1973_19811, ite_eq_left hx]
+    exact circularHalfPoint_of_half_mo1973_19808 ⟨hz, hx⟩
+  · rw [fordCircularPoint_of_right_mo1973_19818 hx, fordHalfPoint_mo1973_19811, ite_eq_right hx]
+    apply circularHalfPoint_circle_of_half_mo1973_19809
+    have hh := fordHalfPoint_mem_mo1973_19812 hz
+    simpa only [fordHalfPoint_mo1973_19811, ite_eq_right hx] using hh
+
+private theorem SpecialPeriods.Triangle.fordHalfPoint_eq_of_orbit_mo1973_19821
+    (g : SpecialPeriods.TriangleGroup) {z w : ℍ} (hz : z ∈ fordRegion) (hw : w ∈ fordRegion)
+    (hzw : SpecialPeriods.triangleGeometricRepresentation g z = w) :
+    fordHalfPoint_mo1973_19811 w = fordHalfPoint_mo1973_19811 z := by
+  let h : SpecialPeriods.TriangleGroup :=
+    fordCircularNormalizer_mo1973_19814 w * g * (fordCircularNormalizer_mo1973_19814 z)⁻¹
+  have he :
+    SpecialPeriods.triangleGeometricRepresentation h (fordCircularPoint_mo1973_19815 z) =
+      fordCircularPoint_mo1973_19815 w := by
+    dsimp only [h, fordCircularPoint_mo1973_19815]
+    rw [map_mul, map_mul, map_inv]
+    change
+      SpecialPeriods.triangleGeometricRepresentation (fordCircularNormalizer_mo1973_19814 w)
+          (SpecialPeriods.triangleGeometricRepresentation g
+            ((SpecialPeriods.triangleGeometricRepresentation
+                  (fordCircularNormalizer_mo1973_19814 z)).symm
+              (SpecialPeriods.triangleGeometricRepresentation
+                (fordCircularNormalizer_mo1973_19814 z) z))) =
+        _
+    rw [(SpecialPeriods.triangleGeometricRepresentation
+            (fordCircularNormalizer_mo1973_19814 z)).symm_apply_apply
+        z,
+      hzw]
+  have hor :=
+    circularDoubleRegion_orbit_point_of_eq h (fordCircularPoint_mem_mo1973_19819 hz)
+      (fordCircularPoint_mem_mo1973_19819 hw) he
+  have hh :
+    circularHalfPoint_mo1973_19807 (fordCircularPoint_mo1973_19815 w) =
+      circularHalfPoint_mo1973_19807 (fordCircularPoint_mo1973_19815 z) := by
+    rcases hor with hor | hor
+    · exact congrArg circularHalfPoint_mo1973_19807 hor
+    · rw [hor, circularHalfPoint_circle_mo1973_19810 (fordCircularPoint_mem_mo1973_19819 hz)]
+  rwa [circularHalfPoint_fordCircularPoint_mo1973_19820 hw,
+    circularHalfPoint_fordCircularPoint_mo1973_19820 hz] at hh
+
+private theorem
+    SpecialPeriods.Triangle.fordRegion_orbit_point_of_eq (g : SpecialPeriods.TriangleGroup)
+    {z w : ℍ} (hz : z ∈ fordRegion) (hw : w ∈ fordRegion)
+    (hzw : SpecialPeriods.triangleGeometricRepresentation g z = w) :
+    w = z ∨ (w = rightReflection z ∧ z ∉ fordInterior) := by
+  rcases
+    eq_or_reflection_of_fordHalfPoint_eq_mo1973_19813
+      (fordHalfPoint_eq_of_orbit_mo1973_19821 g hz hw hzw) with
+    he | he
+  · exact Or.inl he
+  · by_cases hwz : w = z
+    · exact Or.inl hwz
+    · refine Or.inr ⟨he, ?_⟩
+      intro hi
+      have hwi : w ∈ fordInterior := he ▸ rightReflection_mapsTo_fordInterior hi
+      have hg := eq_one_of_fordInterior_eq g hi hwi hzw
+      apply hwz
+      rw [hg, map_one] at hzw
+      exact hzw.symm
+
+private theorem SpecialPeriods.Triangle.fordRegion_boundary_cases {z : ℍ} (hz : z ∈ fordRegion)
+    (hi : z ∉ fordInterior) :
+    z.re = stripLeft ∨ z.re = stripRight ∨ ‖(z : ℂ) + 1‖ = 1 ∨ ‖(z : ℂ)‖ = 1 := by
+  by_cases hl : stripLeft < z.re
+  · by_cases hr : z.re < stripRight
+    · by_cases hc : 1 < ‖(z : ℂ) + 1‖
+      · right; right; right
+        apply le_antisymm _ hz.2.2.2
+        apply le_of_not_gt
+        intro hn
+        exact hi ⟨hl, hr, hc, hn⟩
+      · exact Or.inr (Or.inr (Or.inl (le_antisymm (le_of_not_gt hc) hz.2.2.1)))
+    · exact Or.inr (Or.inl (le_antisymm hz.2.1 (le_of_not_gt hr)))
+  · exact Or.inl (le_antisymm (le_of_not_gt hl) hz.1)
+
+private theorem SpecialPeriods.Triangle.orbitProjection_rightReflection_of_right_side_mo1973_19825
+    {z : ℍ} (hz : z.re = stripRight) :
+    SpecialPeriods.triangleOrbitProjection (rightReflection z) =
+      SpecialPeriods.triangleOrbitProjection z := by
+  have h := SpecialPeriods.triangleOrbitProjection_smul SpecialPeriods.triangleCuspGenerator z
+  rw [SpecialPeriods.triangleGeometricRepresentation_cusp] at h
+  change
+    SpecialPeriods.triangleOrbitProjection (cuspSL • z) =
+      SpecialPeriods.triangleOrbitProjection z at h
+  rwa [cusp_eq_rightReflection_of_re_eq_stripRight z hz] at h
+
+private theorem SpecialPeriods.Triangle.orbitProjection_rightReflection_boundary {z : ℍ}
+    (hz : z ∈ fordRegion) (hi : z ∉ fordInterior) :
+    SpecialPeriods.triangleOrbitProjection (rightReflection z) =
+      SpecialPeriods.triangleOrbitProjection z := by
+  rcases fordRegion_boundary_cases hz hi with hl | hr | hc | hn
+  · have hr' : (rightReflection z).re = stripRight :=
+      (rightReflection_re_eq_stripRight_iff z).mpr hl
+    have h := orbitProjection_rightReflection_of_right_side_mo1973_19825 hr'
+    rw [rightReflection_involutive z] at h
+    exact h.symm
+  · exact orbitProjection_rightReflection_of_right_side_mo1973_19825 hr
+  · have h := SpecialPeriods.triangleOrbitProjection_smul SpecialPeriods.triangleGenerator₁ z
+    rwa [SpecialPeriods.triangleGeometricRepresentation_generator₁_apply,
+      generatorOne_eq_rightReflection_of_norm_add_one z hc] at h
+  · have h := SpecialPeriods.triangleOrbitProjection_smul SpecialPeriods.triangleGenerator₁⁻¹ z
+    rwa [generatorOne_inv_representation_apply_mo1973_19816,
+      generatorOne_inv_eq_rightReflection_of_norm z hn] at h
+
+private theorem
+    SpecialPeriods.Triangle.orbitProjection_eq_iff_fordRegion {z w : ℍ} (hz : z ∈ fordRegion)
+    (hw : w ∈ fordRegion) :
+    SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitProjection w ↔
+      z = w ∨ (w = rightReflection z ∧ z ∉ fordInterior) := by
+  constructor
+  · intro h
+    obtain ⟨g, hg⟩ := (SpecialPeriods.triangleOrbitProjection_eq_iff w z).mp h.symm
+    rcases fordRegion_orbit_point_of_eq g hz hw hg with he | he
+    · exact Or.inl he.symm
+    · exact Or.inr he
+  · rintro (rfl | ⟨he, hi⟩)
+    · rfl
+    · rw [he]
+      exact (orbitProjection_rightReflection_boundary hz hi).symm
+
+private theorem TriangleUniformizationGluing.exists_fordRepresentative
+    (q : SpecialPeriods.TriangleOrbitSpace) :
+    ∃ z : ℍ,
+      z ∈ SpecialPeriods.Triangle.fordRegion ∧ SpecialPeriods.triangleOrbitProjection z = q := by
+  obtain ⟨u, rfl⟩ := SpecialPeriods.triangleOrbitProjection_surjective q
+  obtain ⟨g, hg⟩ := SpecialPeriods.triangle_exists_fordRegion_representative u
+  exact
+    ⟨SpecialPeriods.triangleGeometricRepresentation g u, hg,
+      SpecialPeriods.triangleOrbitProjection_smul g u⟩
+
+private def
+    TriangleUniformizationGluing.fordRepresentative (q : SpecialPeriods.TriangleOrbitSpace) :
+    SpecialPeriods.Triangle.fordRegion :=
+  ⟨Classical.choose (exists_fordRepresentative q),
+    (Classical.choose_spec (exists_fordRepresentative q)).1⟩
+
+@[simp]
+private theorem TriangleUniformizationGluing.fordRepresentative_projection
+    (q : SpecialPeriods.TriangleOrbitSpace) :
+    SpecialPeriods.triangleOrbitProjection (fordRepresentative q) = q :=
+  (Classical.choose_spec (exists_fordRepresentative q)).2
+
+private theorem TriangleUniformizationGluing.BoundaryMap.foldedFordMap_eq_of_projection_eq
+    (D : TriangleUniformizationGluing.BoundaryMap) {z w : ℍ}
+    (hz : z ∈ SpecialPeriods.Triangle.fordRegion) (hw : w ∈ SpecialPeriods.Triangle.fordRegion)
+    (he : SpecialPeriods.triangleOrbitProjection z = SpecialPeriods.triangleOrbitProjection w) :
+    D.foldedFordMap z = D.foldedFordMap w := by
+  rcases (SpecialPeriods.Triangle.orbitProjection_eq_iff_fordRegion hz hw).mp he with rfl |
+    ⟨hr, hi⟩
+  · rfl
+  · rw [hr, D.foldedFordMap_rightReflection_boundary hz hi]
+
+private def TriangleUniformizationGluing.BoundaryMap.quotientMap
+    (D : TriangleUniformizationGluing.BoundaryMap) (q : SpecialPeriods.TriangleOrbitSpace) : ℂ :=
+  D.foldedFordMap (TriangleUniformizationGluing.fordRepresentative q)
+
+private theorem TriangleUniformizationGluing.BoundaryMap.quotientMap_projection
+    (D : TriangleUniformizationGluing.BoundaryMap) (z : ℍ)
+    (hz : z ∈ SpecialPeriods.Triangle.fordRegion) :
+    D.quotientMap (SpecialPeriods.triangleOrbitProjection z) = D.foldedFordMap z :=
+  D.foldedFordMap_eq_of_projection_eq (TriangleUniformizationGluing.fordRepresentative _).property
+    hz (TriangleUniformizationGluing.fordRepresentative_projection _)
+
+private def TriangleUniformizationGluing.BoundaryMap.upstairsMap
+    (D : TriangleUniformizationGluing.BoundaryMap) (z : ℍ) : ℂ :=
+  D.quotientMap (SpecialPeriods.triangleOrbitProjection z)
+
+private theorem TriangleUniformizationGluing.BoundaryMap.upstairsMap_of_mem
+    (D : TriangleUniformizationGluing.BoundaryMap) {z : ℍ}
+    (hz : z ∈ SpecialPeriods.Triangle.fordRegion) : D.upstairsMap z = D.foldedFordMap z :=
+  D.quotientMap_projection z hz
+
+@[simp]
+private theorem TriangleUniformizationGluing.BoundaryMap.upstairsMap_smul
+    (D : TriangleUniformizationGluing.BoundaryMap) (g : SpecialPeriods.TriangleGroup) (z : ℍ) :
+    D.upstairsMap (SpecialPeriods.triangleGeometricRepresentation g z) = D.upstairsMap z := by
+  change
+    D.quotientMap
+        (SpecialPeriods.triangleOrbitProjection
+          (SpecialPeriods.triangleGeometricRepresentation g z)) =
+      _
+  rw [SpecialPeriods.triangleOrbitProjection_smul]
+  rfl
+
+private theorem TriangleUniformizationGluing.BoundaryMap.upstairsMap_eqOn_translate
+    (D : TriangleUniformizationGluing.BoundaryMap) (g : SpecialPeriods.TriangleGroup) :
+    Set.EqOn D.upstairsMap
+      (fun z => D.foldedFordMap (SpecialPeriods.triangleGeometricRepresentation g⁻¹ z))
+      (SpecialPeriods.triangleGeometricRepresentation g '' SpecialPeriods.Triangle.fordRegion) := by
+  rintro z ⟨w, hw, rfl⟩
+  change
+    D.upstairsMap (SpecialPeriods.triangleGeometricRepresentation g w) =
+      D.foldedFordMap
+        (SpecialPeriods.triangleGeometricRepresentation g⁻¹
+          (SpecialPeriods.triangleGeometricRepresentation g w))
+  rw [D.upstairsMap_smul, map_inv]
+  change
+    D.upstairsMap w =
+      D.foldedFordMap
+        ((SpecialPeriods.triangleGeometricRepresentation g).symm
+          (SpecialPeriods.triangleGeometricRepresentation g w))
+  rw [(SpecialPeriods.triangleGeometricRepresentation g).symm_apply_apply w,
+    D.upstairsMap_of_mem hw]
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Uniformization/SpecialPeriods8.lean b/LeanPool/HopfProblem/Uniformization/SpecialPeriods8.lean
new file mode 100644
index 000000000..cdd5ce7c5
--- /dev/null
+++ b/LeanPool/HopfProblem/Uniformization/SpecialPeriods8.lean
@@ -0,0 +1,1131 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Elliptic.Core5
+import all LeanPool.HopfProblem.Foundations.TriangleRegularBaseFundamentalGroup
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Uniformization.TriangleUniformizationGluing
+import all LeanPool.HopfProblem.Foundations.TwoOpenTransition
+import all LeanPool.HopfProblem.Elliptic.Core5
+
+/-!
+# Hopf problem: uniformization · special periods 8
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def SpecialPeriods.Triangle.twicePuncturedPlaneDomain : TopologicalSpace.Opens ℂ :=
+  ⟨{z | z ≠ 0 ∧ z ≠ 1}, isOpen_ne.inter isOpen_ne⟩
+
+private abbrev SpecialPeriods.Triangle.TwicePuncturedPlane : Type :=
+  twicePuncturedPlaneDomain
+
+@[simp]
+private theorem SpecialPeriods.Triangle.mem_twicePuncturedPlaneDomain (z : ℂ) :
+    z ∈ twicePuncturedPlaneDomain ↔ z ≠ 0 ∧ z ≠ 1 :=
+  Iff.rfl
+
+private theorem SpecialPeriods.Triangle.trianglePlaneUniformizationHomeomorph_regular_iff
+    (q : SpecialPeriods.TriangleOrbitSpace) :
+    q ∈ SpecialPeriods.triangleOrbitRegularDomain ↔
+      trianglePlaneUniformizationHomeomorph q ∈ twicePuncturedPlaneDomain := by
+  rw [SpecialPeriods.triangleOrbitRegularDomain_mem_iff, mem_twicePuncturedPlaneDomain, ←
+    trianglePlaneUniformizationHomeomorph_centerOne, ←
+    trianglePlaneUniformizationHomeomorph_centerTwo]
+  simp only [ne_eq, trianglePlaneUniformizationHomeomorph.injective.eq_iff]
+
+private def SpecialPeriods.Triangle.triangleRegularDomainPlaneHomeomorph :
+    SpecialPeriods.triangleOrbitRegularDomain ≃ₜ TwicePuncturedPlane :=
+  trianglePlaneUniformizationHomeomorph.subtype trianglePlaneUniformizationHomeomorph_regular_iff
+
+private def SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph :
+    SpecialPeriods.TriangleRegularQuotient ≃ₜ TwicePuncturedPlane :=
+  SpecialPeriods.triangleRegularOrbitHomeomorph.trans triangleRegularDomainPlaneHomeomorph
+
+@[simp]
+private theorem SpecialPeriods.Triangle.triangleRegularPlaneHomeomorph_project
+    (z : SpecialPeriods.TriangleRegularPoint) :
+    (triangleRegularPlaneHomeomorph (SpecialPeriods.triangleRegularProject z) : ℂ) =
+      trianglePlaneUniformizationHomeomorph (SpecialPeriods.triangleOrbitProjection z.val) :=
+  rfl
+
+private def SpecialPeriods.Triangle.upperSlitPlane : Set ℂ :=
+  {z | 0 < z.im ∨ (z.re ≠ 0 ∧ z.re ≠ 1)}
+
+private def SpecialPeriods.Triangle.lowerSlitPlane : Set ℂ :=
+  {z | z.im < 0 ∨ (z.re ≠ 0 ∧ z.re ≠ 1)}
+
+private theorem SpecialPeriods.Triangle.upperSlitPlane_isOpen : IsOpen upperSlitPlane :=
+  (isOpen_lt continuous_const Complex.continuous_im).union
+    ((isOpen_ne_fun Complex.continuous_re continuous_const).inter
+      (isOpen_ne_fun Complex.continuous_re continuous_const))
+
+private theorem SpecialPeriods.Triangle.lowerSlitPlane_isOpen : IsOpen lowerSlitPlane :=
+  (isOpen_lt Complex.continuous_im continuous_const).union
+    ((isOpen_ne_fun Complex.continuous_re continuous_const).inter
+      (isOpen_ne_fun Complex.continuous_re continuous_const))
+
+private theorem SpecialPeriods.Triangle.upperSlitPlane_subset_punctured :
+    upperSlitPlane ⊆ {z : ℂ | z ≠ 0 ∧ z ≠ 1} := by
+  intro z hz
+  constructor
+  · rintro rfl
+    simp [upperSlitPlane] at hz
+  · rintro rfl
+    simp [upperSlitPlane] at hz
+
+private theorem SpecialPeriods.Triangle.lowerSlitPlane_subset_punctured :
+    lowerSlitPlane ⊆ {z : ℂ | z ≠ 0 ∧ z ≠ 1} := by
+  intro z hz
+  constructor
+  · rintro rfl
+    simp [lowerSlitPlane] at hz
+  · rintro rfl
+    simp [lowerSlitPlane] at hz
+
+private theorem SpecialPeriods.Triangle.slitPlanes_union :
+    upperSlitPlane ∪ lowerSlitPlane = {z : ℂ | z ≠ 0 ∧ z ≠ 1} := by
+  ext z
+  constructor
+  · rintro (hz | hz)
+    · exact upperSlitPlane_subset_punctured hz
+    · exact lowerSlitPlane_subset_punctured hz
+  · rintro ⟨hzero, hone⟩
+    by_cases hp : 0 < z.im
+    · exact Or.inl (Or.inl hp)
+    by_cases hn : z.im < 0
+    · exact Or.inr (Or.inl hn)
+    have hi : z.im = 0 := le_antisymm (le_of_not_gt hp) (le_of_not_gt hn)
+    apply Or.inl
+    apply Or.inr
+    constructor
+    · intro hr
+      apply hzero
+      apply Complex.ext <;> simp_all
+    · intro hr
+      apply hone
+      apply Complex.ext <;> simp_all
+
+private theorem SpecialPeriods.Triangle.slitPlanes_inter :
+    upperSlitPlane ∩ lowerSlitPlane = {z : ℂ | z.re ≠ 0 ∧ z.re ≠ 1} := by
+  ext z
+  constructor
+  · rintro ⟨hp | hx, hn | hx'⟩
+    · linarith
+    · exact hx'
+    · exact hx
+    · exact hx
+  · intro hx
+    exact ⟨Or.inr hx, Or.inr hx⟩
+
+private def SpecialPeriods.Triangle.meridianHalfCircle (t : ℝ) : ℂ :=
+  circleMap 0 (1 / 2) (Real.pi * t)
+
+@[fun_prop]
+private theorem
+    SpecialPeriods.Triangle.continuous_meridianHalfCircle : Continuous meridianHalfCircle := by
+  unfold meridianHalfCircle circleMap
+  fun_prop
+
+@[simp]
+private theorem
+    SpecialPeriods.Triangle.meridianHalfCircle_zero : meridianHalfCircle 0 = (1 / 2 : ℂ) := by
+  simp [meridianHalfCircle, circleMap]
+
+@[simp]
+private theorem
+    SpecialPeriods.Triangle.meridianHalfCircle_one : meridianHalfCircle 1 = (-1 / 2 : ℂ) := by
+  simp [meridianHalfCircle, circleMap, Complex.exp_pi_mul_I]
+  ring
+
+private theorem
+    SpecialPeriods.Triangle.meridianHalfCircle_im_pos {t : ℝ} (ht0 : 0 < t) (ht1 : t < 1) :
+    0 < (meridianHalfCircle t).im := by
+  rw [meridianHalfCircle, circleMap_zero_im]
+  apply mul_pos (by norm_num)
+  exact Real.sin_pos_of_pos_of_lt_pi (mul_pos Real.pi_pos ht0) (by nlinarith [Real.pi_pos])
+
+private theorem SpecialPeriods.Triangle.meridianHalfCircle_mem_upperSlitPlane (t : unitInterval) :
+    meridianHalfCircle t ∈ upperSlitPlane := by
+  by_cases ht0 : (t : ℝ) = 0
+  · rw [ht0, meridianHalfCircle_zero]
+    norm_num [upperSlitPlane]
+  by_cases ht1 : (t : ℝ) = 1
+  · rw [ht1, meridianHalfCircle_one]
+    norm_num [upperSlitPlane]
+  apply Or.inl
+  apply meridianHalfCircle_im_pos
+  · have := t.property.1
+    exact lt_of_le_of_ne this (Ne.symm ht0)
+  · have := t.property.2
+    exact lt_of_le_of_ne this ht1
+
+private theorem SpecialPeriods.Triangle.conj_mem_lowerSlitPlane_iff_mo1973_23420 (z : ℂ) :
+    conj z ∈ lowerSlitPlane ↔ z ∈ upperSlitPlane := by simp [lowerSlitPlane, upperSlitPlane]
+
+private theorem SpecialPeriods.Triangle.one_sub_mem_upperSlitPlane_iff_mo1973_23421 (z : ℂ) :
+    1 - z ∈ upperSlitPlane ↔ z ∈ lowerSlitPlane := by
+  simp [upperSlitPlane, lowerSlitPlane, ne_comm, and_comm, eq_sub_iff_add_eq]
+
+private theorem SpecialPeriods.Triangle.one_sub_mem_lowerSlitPlane_iff_mo1973_23422 (z : ℂ) :
+    1 - z ∈ lowerSlitPlane ↔ z ∈ upperSlitPlane := by
+  simp [upperSlitPlane, lowerSlitPlane, ne_comm, and_comm, eq_sub_iff_add_eq]
+
+private def SpecialPeriods.Triangle.upperZeroArc : Path (1 / 2 : ℂ) (-1 / 2) :=
+  Path.ofLine continuous_meridianHalfCircle.continuousOn meridianHalfCircle_zero
+    meridianHalfCircle_one
+
+private def SpecialPeriods.Triangle.lowerZeroArc : Path (1 / 2 : ℂ) (-1 / 2) :=
+  Path.ofLine (f := fun t : ℝ => conj (meridianHalfCircle t)) (by fun_prop) (by simp [map_ofNat])
+    (by simp [map_ofNat])
+
+private def SpecialPeriods.Triangle.upperOneArc : Path (1 / 2 : ℂ) (3 / 2) :=
+  Path.ofLine (f := fun t : ℝ => 1 - conj (meridianHalfCircle t)) (by fun_prop)
+    (by norm_num [map_ofNat]) (by norm_num [map_ofNat])
+
+private def SpecialPeriods.Triangle.lowerOneArc : Path (1 / 2 : ℂ) (3 / 2) :=
+  Path.ofLine (f := fun t : ℝ => 1 - meridianHalfCircle t) (by fun_prop) (by norm_num)
+    (by norm_num)
+
+@[simp]
+private theorem SpecialPeriods.Triangle.upperZeroArc_apply (t : unitInterval) :
+    upperZeroArc t = (1 / 2 : ℂ) * Complex.exp ((Real.pi : ℂ) * Complex.I * (t : ℝ)) := by
+  change meridianHalfCircle t = _
+  unfold meridianHalfCircle
+  rw [circleMap_zero]
+  push_cast
+  congr 1
+  congr 1
+  ring
+
+@[simp]
+private theorem SpecialPeriods.Triangle.lowerZeroArc_apply (t : unitInterval) :
+    lowerZeroArc t = (1 / 2 : ℂ) * Complex.exp (-((Real.pi : ℂ) * Complex.I * (t : ℝ))) := by
+  change conj (upperZeroArc t) = _
+  rw [upperZeroArc_apply]
+  simp only [map_mul, map_div₀, map_one, map_ofNat, ← Complex.exp_conj, Complex.conj_ofReal,
+    Complex.conj_I]
+  congr 1
+  congr 1
+  ring
+
+@[simp]
+private theorem SpecialPeriods.Triangle.upperOneArc_apply (t : unitInterval) :
+    upperOneArc t = 1 - (1 / 2 : ℂ) * Complex.exp (-((Real.pi : ℂ) * Complex.I * (t : ℝ))) := by
+  change 1 - lowerZeroArc t = _
+  rw [lowerZeroArc_apply]
+
+@[simp]
+private theorem SpecialPeriods.Triangle.lowerOneArc_apply (t : unitInterval) :
+    lowerOneArc t = 1 - (1 / 2 : ℂ) * Complex.exp ((Real.pi : ℂ) * Complex.I * (t : ℝ)) := by
+  change 1 - upperZeroArc t = _
+  rw [upperZeroArc_apply]
+
+private theorem SpecialPeriods.Triangle.upperZeroArc_mem_upperSlitPlane (t : unitInterval) :
+    upperZeroArc t ∈ upperSlitPlane :=
+  meridianHalfCircle_mem_upperSlitPlane t
+
+private theorem SpecialPeriods.Triangle.lowerZeroArc_mem_lowerSlitPlane (t : unitInterval) :
+    lowerZeroArc t ∈ lowerSlitPlane :=
+  (conj_mem_lowerSlitPlane_iff_mo1973_23420 _).mpr (meridianHalfCircle_mem_upperSlitPlane t)
+
+private theorem SpecialPeriods.Triangle.upperOneArc_mem_upperSlitPlane (t : unitInterval) :
+    upperOneArc t ∈ upperSlitPlane :=
+  (one_sub_mem_upperSlitPlane_iff_mo1973_23421 _).mpr (lowerZeroArc_mem_lowerSlitPlane t)
+
+private theorem SpecialPeriods.Triangle.lowerOneArc_mem_lowerSlitPlane (t : unitInterval) :
+    lowerOneArc t ∈ lowerSlitPlane :=
+  (one_sub_mem_lowerSlitPlane_iff_mo1973_23422 _).mpr (upperZeroArc_mem_upperSlitPlane t)
+
+private theorem SpecialPeriods.Triangle.upperZeroArc_avoids_punctures (t : unitInterval) :
+    upperZeroArc t ≠ 0 ∧ upperZeroArc t ≠ 1 :=
+  upperSlitPlane_subset_punctured (upperZeroArc_mem_upperSlitPlane t)
+
+private theorem SpecialPeriods.Triangle.lowerZeroArc_avoids_punctures (t : unitInterval) :
+    lowerZeroArc t ≠ 0 ∧ lowerZeroArc t ≠ 1 :=
+  lowerSlitPlane_subset_punctured (lowerZeroArc_mem_lowerSlitPlane t)
+
+private theorem SpecialPeriods.Triangle.upperOneArc_avoids_punctures (t : unitInterval) :
+    upperOneArc t ≠ 0 ∧ upperOneArc t ≠ 1 :=
+  upperSlitPlane_subset_punctured (upperOneArc_mem_upperSlitPlane t)
+
+private theorem SpecialPeriods.Triangle.lowerOneArc_avoids_punctures (t : unitInterval) :
+    lowerOneArc t ≠ 0 ∧ lowerOneArc t ≠ 1 :=
+  lowerSlitPlane_subset_punctured (lowerOneArc_mem_lowerSlitPlane t)
+
+public
+theorem SpecialPeriods.Triangle.trans_symm_exp_apply_mo1973_23439 {x y : ℂ}
+    (a b : Path x y) (c r : ℂ)
+    (ha : ∀ t : unitInterval, a t = c + r * Complex.exp ((Real.pi : ℂ) * Complex.I * (t : ℝ)))
+    (hb : ∀ t : unitInterval, b t = c + r * Complex.exp (-((Real.pi : ℂ) * Complex.I * (t : ℝ))))
+    (t : unitInterval) :
+    (a.trans b.symm) t = c + r * Complex.exp ((2 * Real.pi : ℂ) * Complex.I * (t : ℝ)) := by
+  rw [Path.trans_apply]
+  split_ifs with ht
+  · rw [ha]
+    apply congrArg (fun u : ℂ => c + r * Complex.exp u)
+    push_cast
+    ring
+  · rw [Path.symm_apply, Function.comp_apply, hb]
+    simp only [unitInterval.coe_symm_eq]
+    have he :
+      -((Real.pi : ℂ) * Complex.I * ((1 - (2 * (t : ℝ) - 1) : ℝ) : ℂ)) =
+        (2 * Real.pi : ℂ) * Complex.I * (t : ℝ) - 2 * Real.pi * Complex.I := by
+      push_cast
+      ring
+    rw [he, Complex.exp_periodic.sub_eq]
+
+private def SpecialPeriods.Triangle.meridianZeroComplex : Path (1 / 2 : ℂ) (1 / 2) :=
+  upperZeroArc.trans lowerZeroArc.symm
+
+private def SpecialPeriods.Triangle.meridianOneComplex : Path (1 / 2 : ℂ) (1 / 2) :=
+  lowerOneArc.trans upperOneArc.symm
+
+@[simp]
+private theorem SpecialPeriods.Triangle.meridianZeroComplex_apply (t : unitInterval) :
+    meridianZeroComplex t = (1 / 2 : ℂ) * Complex.exp ((2 * Real.pi : ℂ) * Complex.I * (t : ℝ)) :=
+  by
+  simpa only [meridianZeroComplex, zero_add] using
+    trans_symm_exp_apply_mo1973_23439 upperZeroArc lowerZeroArc 0 (1 / 2)
+      (fun s => by simpa only [zero_add] using upperZeroArc_apply s)
+      (fun s => by simpa only [zero_add] using lowerZeroArc_apply s) t
+
+@[simp]
+private theorem SpecialPeriods.Triangle.meridianOneComplex_apply (t : unitInterval) :
+    meridianOneComplex t =
+      1 - (1 / 2 : ℂ) * Complex.exp ((2 * Real.pi : ℂ) * Complex.I * (t : ℝ)) := by
+  simpa only [meridianOneComplex, neg_mul, ← sub_eq_add_neg] using
+    trans_symm_exp_apply_mo1973_23439 lowerOneArc upperOneArc 1 (-(1 / 2))
+      (fun s => by simpa only [neg_mul, ← sub_eq_add_neg] using lowerOneArc_apply s)
+      (fun s => by simpa only [neg_mul, ← sub_eq_add_neg] using upperOneArc_apply s) t
+
+private theorem SpecialPeriods.Triangle.meridianZeroComplex_eq_circleMap (t : unitInterval) :
+    meridianZeroComplex t = circleMap 0 (1 / 2) (2 * Real.pi * (t : ℝ)) := by
+  rw [meridianZeroComplex_apply, circleMap_zero]
+  push_cast
+  apply congrArg (fun u : ℂ => (1 / 2 : ℂ) * Complex.exp u)
+  ring
+
+private def SpecialPeriods.Triangle.meridianBasepoint : TwicePuncturedPlane :=
+  ⟨(1 / 2 : ℂ), by norm_num⟩
+
+private def SpecialPeriods.Triangle.meridianLeftPoint : TwicePuncturedPlane :=
+  ⟨(-1 / 2 : ℂ), by norm_num⟩
+
+private def SpecialPeriods.Triangle.meridianRightPoint : TwicePuncturedPlane :=
+  ⟨(3 / 2 : ℂ), by norm_num⟩
+
+private def SpecialPeriods.Triangle.liftPuncturedPath_mo1973_23454 {x y : TwicePuncturedPlane}
+    (γ : Path (x : ℂ) (y : ℂ)) (hγ : ∀ t : unitInterval, γ t ∈ twicePuncturedPlaneDomain) :
+    Path x y where
+  toFun t := ⟨γ t, hγ t⟩
+  continuous_toFun := γ.continuous.subtype_mk _
+  source' := Subtype.ext γ.source
+  target' := Subtype.ext γ.target
+
+private def SpecialPeriods.Triangle.upperZeroPath : Path meridianBasepoint meridianLeftPoint :=
+  liftPuncturedPath_mo1973_23454 upperZeroArc upperZeroArc_avoids_punctures
+
+private def SpecialPeriods.Triangle.lowerZeroPath : Path meridianBasepoint meridianLeftPoint :=
+  liftPuncturedPath_mo1973_23454 lowerZeroArc lowerZeroArc_avoids_punctures
+
+private def SpecialPeriods.Triangle.upperOnePath : Path meridianBasepoint meridianRightPoint :=
+  liftPuncturedPath_mo1973_23454 upperOneArc upperOneArc_avoids_punctures
+
+private def SpecialPeriods.Triangle.lowerOnePath : Path meridianBasepoint meridianRightPoint :=
+  liftPuncturedPath_mo1973_23454 lowerOneArc lowerOneArc_avoids_punctures
+
+private theorem SpecialPeriods.Triangle.upperZeroPath_mem_upperSlitPlane (t : unitInterval) :
+    (upperZeroPath t : ℂ) ∈ upperSlitPlane :=
+  upperZeroArc_mem_upperSlitPlane t
+
+private theorem SpecialPeriods.Triangle.lowerZeroPath_mem_lowerSlitPlane (t : unitInterval) :
+    (lowerZeroPath t : ℂ) ∈ lowerSlitPlane :=
+  lowerZeroArc_mem_lowerSlitPlane t
+
+private theorem SpecialPeriods.Triangle.upperOnePath_mem_upperSlitPlane (t : unitInterval) :
+    (upperOnePath t : ℂ) ∈ upperSlitPlane :=
+  upperOneArc_mem_upperSlitPlane t
+
+private theorem SpecialPeriods.Triangle.lowerOnePath_mem_lowerSlitPlane (t : unitInterval) :
+    (lowerOnePath t : ℂ) ∈ lowerSlitPlane :=
+  lowerOneArc_mem_lowerSlitPlane t
+
+@[simp]
+private theorem SpecialPeriods.Triangle.upperZeroPath_map_coe :
+    upperZeroPath.map continuous_subtype_val = upperZeroArc := by
+  ext t
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.Triangle.lowerZeroPath_map_coe :
+    lowerZeroPath.map continuous_subtype_val = lowerZeroArc := by
+  ext t
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.Triangle.upperOnePath_map_coe :
+    upperOnePath.map continuous_subtype_val = upperOneArc := by
+  ext t
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.Triangle.lowerOnePath_map_coe :
+    lowerOnePath.map continuous_subtype_val = lowerOneArc := by
+  ext t
+  rfl
+
+private def
+    SpecialPeriods.Triangle.positiveMeridianZero : Path meridianBasepoint meridianBasepoint :=
+  upperZeroPath.trans lowerZeroPath.symm
+
+private def
+    SpecialPeriods.Triangle.positiveMeridianOne : Path meridianBasepoint meridianBasepoint :=
+  lowerOnePath.trans upperOnePath.symm
+
+@[simp]
+private theorem SpecialPeriods.Triangle.positiveMeridianZero_map_coe :
+    positiveMeridianZero.map continuous_subtype_val = meridianZeroComplex := by
+  change
+    (upperZeroPath.trans lowerZeroPath.symm).map continuous_subtype_val =
+      upperZeroArc.trans lowerZeroArc.symm
+  rw [Path.map_trans, ← Path.map_symm, upperZeroPath_map_coe, lowerZeroPath_map_coe]
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.Triangle.positiveMeridianOne_map_coe :
+    positiveMeridianOne.map continuous_subtype_val = meridianOneComplex := by
+  change
+    (lowerOnePath.trans upperOnePath.symm).map continuous_subtype_val =
+      lowerOneArc.trans upperOneArc.symm
+  rw [Path.map_trans, ← Path.map_symm, lowerOnePath_map_coe, upperOnePath_map_coe]
+  rfl
+
+@[simp]
+private theorem SpecialPeriods.Triangle.positiveMeridianZero_coe (t : unitInterval) :
+    (positiveMeridianZero t : ℂ) = meridianZeroComplex t :=
+  congrArg (fun γ : Path (1 / 2 : ℂ) (1 / 2) => γ t) positiveMeridianZero_map_coe
+
+@[simp]
+private theorem SpecialPeriods.Triangle.positiveMeridianOne_coe (t : unitInterval) :
+    (positiveMeridianOne t : ℂ) = meridianOneComplex t :=
+  congrArg (fun γ : Path (1 / 2 : ℂ) (1 / 2) => γ t) positiveMeridianOne_map_coe
+
+private theorem SpecialPeriods.Triangle.positiveMeridianZero_apply (t : unitInterval) :
+    (positiveMeridianZero t : ℂ) =
+      (1 / 2 : ℂ) * Complex.exp ((2 * Real.pi : ℂ) * Complex.I * (t : ℝ)) := by
+  rw [positiveMeridianZero_coe, meridianZeroComplex_apply]
+
+private theorem SpecialPeriods.Triangle.positiveMeridianOne_apply (t : unitInterval) :
+    (positiveMeridianOne t : ℂ) =
+      1 - (1 / 2 : ℂ) * Complex.exp ((2 * Real.pi : ℂ) * Complex.I * (t : ℝ)) := by
+  rw [positiveMeridianOne_coe, meridianOneComplex_apply]
+
+private theorem SpecialPeriods.Triangle.positiveMeridianZero_eq_circleMap (t : unitInterval) :
+    (positiveMeridianZero t : ℂ) = circleMap 0 (1 / 2) (2 * Real.pi * (t : ℝ)) := by
+  rw [positiveMeridianZero_coe, meridianZeroComplex_eq_circleMap]
+
+private def SpecialPeriods.Triangle.upperSlitBasepoint : upperSlitPlane :=
+  ⟨Complex.I, Or.inl (by simp)⟩
+
+private def SpecialPeriods.Triangle.upperSlitHeightMap : C(upperSlitPlane, upperSlitPlane)
+    where
+  toFun z := ⟨(z.val.re : ℂ) + Complex.I, Or.inl (by simp)⟩
+  continuous_toFun := by fun_prop
+
+private theorem SpecialPeriods.Triangle.upperSlit_vertical_mem_mo1973_23539 (t : unitInterval)
+    (z : upperSlitPlane) :
+    (z.val.re : ℂ) + (((1 - t.val) * z.val.im + t.val : ℝ) : ℂ) * Complex.I ∈ upperSlitPlane := by
+  simp only [upperSlitPlane, Set.mem_ofPred_eq, Complex.add_im, Complex.ofReal_im, Complex.mul_im,
+    Complex.ofReal_re, Complex.I_im, mul_one, Complex.I_re, MulZeroClass.mul_zero, add_zero,
+    zero_add, Complex.add_re, Complex.mul_re, sub_zero]
+  rcases z.property with hz | hz
+  · left
+    by_cases ht : t.val = 1
+    · simp [ht]
+    · have hp : 0 < 1 - t.val := sub_pos.mpr ((lt_or_eq_of_le t.property.2).resolve_right ht)
+      exact add_pos_of_pos_of_nonneg (mul_pos hp hz) t.property.1
+  · exact Or.inr hz
+
+private def SpecialPeriods.Triangle.upperSlitVerticalHomotopy :
+    ContinuousMap.Homotopy (ContinuousMap.id upperSlitPlane) upperSlitHeightMap
+    where
+  toFun
+    p :=
+    ⟨(p.2.val.re : ℂ) + (((1 - p.1.val) * p.2.val.im + p.1.val : ℝ) : ℂ) * Complex.I,
+      upperSlit_vertical_mem_mo1973_23539 p.1 p.2⟩
+  continuous_toFun := by fun_prop
+  map_zero_left
+    z := by
+    apply Subtype.ext
+    simp
+  map_one_left
+    z := by
+    apply Subtype.ext
+    simp [upperSlitHeightMap]
+
+private def SpecialPeriods.Triangle.upperSlitHorizontalHomotopy :
+    ContinuousMap.Homotopy upperSlitHeightMap
+      (ContinuousMap.const upperSlitPlane upperSlitBasepoint)
+    where
+  toFun p := ⟨(((1 - p.1.val) * p.2.val.re : ℝ) : ℂ) + Complex.I, Or.inl (by simp)⟩
+  continuous_toFun := by fun_prop
+  map_zero_left
+    z := by
+    apply Subtype.ext
+    simp [upperSlitHeightMap]
+  map_one_left
+    z := by
+    apply Subtype.ext
+    simp [upperSlitBasepoint]
+
+private def SpecialPeriods.Triangle.upperSlitContraction :
+    ContinuousMap.Homotopy (ContinuousMap.id upperSlitPlane)
+      (ContinuousMap.const upperSlitPlane upperSlitBasepoint) :=
+  upperSlitVerticalHomotopy.trans upperSlitHorizontalHomotopy
+
+private instance SpecialPeriods.Triangle.upperSlitPlane_contractibleSpace :
+    ContractibleSpace upperSlitPlane :=
+  (contractible_iff_id_nullhomotopic upperSlitPlane).mpr
+    ⟨upperSlitBasepoint, ⟨upperSlitContraction⟩⟩
+
+private def SpecialPeriods.Triangle.slitConjugation : upperSlitPlane ≃ₜ lowerSlitPlane
+    where
+  toFun z := ⟨conj (z : ℂ), by simpa [upperSlitPlane, lowerSlitPlane] using z.property⟩
+  invFun z := ⟨conj (z : ℂ), by simpa [upperSlitPlane, lowerSlitPlane] using z.property⟩
+  left_inv z := Subtype.ext (Complex.conj_conj _)
+  right_inv z := Subtype.ext (Complex.conj_conj _)
+  continuous_toFun := by fun_prop
+  continuous_invFun := by fun_prop
+
+private instance SpecialPeriods.Triangle.lowerSlitPlane_contractibleSpace :
+    ContractibleSpace lowerSlitPlane :=
+  slitConjugation.symm.contractibleSpace
+
+private def SpecialPeriods.Triangle.overlapStrip : Fin 3 → Set ℂ
+  | 0 => {z | z.re < 0}
+  | 1 => {z | 0 < z.re ∧ z.re < 1}
+  | 2 => {z | 1 < z.re}
+
+private def SpecialPeriods.Triangle.overlapStripBasepoint : Fin 3 → ℂ
+  | 0 => -1
+  | 1 => ((1 / 2 : ℝ) : ℂ)
+  | 2 => 2
+
+private theorem SpecialPeriods.Triangle.overlapStrip_basepoint_mem (i : Fin 3) :
+    overlapStripBasepoint i ∈ overlapStrip i := by
+  fin_cases i <;> norm_num [overlapStripBasepoint, overlapStrip]
+
+private def SpecialPeriods.Triangle.overlapStripPoint (i : Fin 3) : overlapStrip i :=
+  ⟨overlapStripBasepoint i, overlapStrip_basepoint_mem i⟩
+
+private theorem
+    SpecialPeriods.Triangle.overlapStrip_nonempty (i : Fin 3) : (overlapStrip i).Nonempty :=
+  ⟨overlapStripBasepoint i, overlapStrip_basepoint_mem i⟩
+
+private theorem
+    SpecialPeriods.Triangle.overlapStrip_isOpen (i : Fin 3) : IsOpen (overlapStrip i) := by
+  fin_cases i
+  · exact isOpen_lt Complex.continuous_re continuous_const
+  · exact
+      (isOpen_lt continuous_const Complex.continuous_re).inter
+        (isOpen_lt Complex.continuous_re continuous_const)
+  · exact isOpen_lt continuous_const Complex.continuous_re
+
+private theorem
+    SpecialPeriods.Triangle.overlapStrip_convex (i : Fin 3) : Convex ℝ (overlapStrip i) := by
+  fin_cases i
+  · exact convex_halfSpace_re_lt 0
+  · exact (convex_halfSpace_re_gt 0).inter (convex_halfSpace_re_lt 1)
+  · exact convex_halfSpace_re_gt 1
+
+private theorem SpecialPeriods.Triangle.overlapStrip_isPathConnected (i : Fin 3) :
+    IsPathConnected (overlapStrip i) :=
+  (overlapStrip_convex i).isPathConnected (overlapStrip_nonempty i)
+
+private theorem SpecialPeriods.Triangle.overlapStrip_isConnected (i : Fin 3) :
+    IsConnected (overlapStrip i) :=
+  (overlapStrip_isPathConnected i).isConnected
+
+private instance SpecialPeriods.Triangle.overlapStrip_contractibleSpace (i : Fin 3) :
+    ContractibleSpace (overlapStrip i) :=
+  (overlapStrip_convex i).contractibleSpace (overlapStrip_nonempty i)
+
+private theorem SpecialPeriods.Triangle.overlapStrip_joinedIn (i : Fin 3) {z w : ℂ}
+    (hz : z ∈ overlapStrip i) (hw : w ∈ overlapStrip i) : JoinedIn (overlapStrip i) z w :=
+  JoinedIn.of_segment_subset ((overlapStrip_convex i).segment_subset hz hw)
+
+private theorem SpecialPeriods.Triangle.overlapStrip_pairwise_disjoint :
+    Pairwise (fun i j : Fin 3 => Disjoint (overlapStrip i) (overlapStrip j)) := by
+  intro i j hij
+  apply Set.disjoint_left.mpr
+  intro z hi hj
+  fin_cases i <;> fin_cases j <;> simp_all [overlapStrip] <;> linarith
+
+private theorem SpecialPeriods.Triangle.overlapStrip_iUnion :
+    (⋃ i : Fin 3, overlapStrip i) = upperSlitPlane ∩ lowerSlitPlane := by
+  rw [slitPlanes_inter]
+  ext z
+  rw [Set.mem_iUnion]
+  constructor
+  · rintro ⟨i, hi⟩
+    fin_cases i <;> simp only [overlapStrip, Set.mem_ofPred_eq] at hi ⊢ <;> constructor <;>
+        intro heq <;>
+      linarith
+  · rintro ⟨hzero, hone⟩
+    rcases lt_or_gt_of_ne hzero with hneg | hpos
+    · exact ⟨0, hneg⟩
+    · rcases lt_or_gt_of_ne hone with hlt | hgt
+      · exact ⟨1, hpos, hlt⟩
+      · exact ⟨2, hgt⟩
+
+private theorem SpecialPeriods.Triangle.overlapStrip_subset_overlap (i : Fin 3) :
+    overlapStrip i ⊆ upperSlitPlane ∩ lowerSlitPlane := by
+  rw [← overlapStrip_iUnion]
+  exact Set.subset_iUnion overlapStrip i
+
+private theorem SpecialPeriods.Triangle.overlapStrip_connectedComponentIn (i : Fin 3) {z : ℂ}
+    (hz : z ∈ overlapStrip i) :
+    connectedComponentIn (upperSlitPlane ∩ lowerSlitPlane) z = overlapStrip i := by
+  let R : Set ℂ := ⋃ j : Fin 3, ⋃ (_ : j ≠ i), overlapStrip j
+  have hRopen : IsOpen R := isOpen_iUnion fun j => isOpen_iUnion fun _ => overlapStrip_isOpen j
+  have hdisj : Disjoint (overlapStrip i) R := by
+    apply Set.disjoint_iUnion_right.mpr
+    intro j
+    apply Set.disjoint_iUnion_right.mpr
+    intro hji
+    exact overlapStrip_pairwise_disjoint hji.symm
+  have hcover : upperSlitPlane ∩ lowerSlitPlane ⊆ overlapStrip i ∪ R := by
+    rw [← overlapStrip_iUnion]
+    intro w hw
+    obtain ⟨j, hj⟩ := Set.mem_iUnion.mp hw
+    by_cases hji : j = i
+    · exact Or.inl (hji ▸ hj)
+    · exact Or.inr (Set.mem_iUnion₂.mpr ⟨j, hji, hj⟩)
+  apply subset_antisymm
+  · have hc : IsPreconnected (connectedComponentIn (upperSlitPlane ∩ lowerSlitPlane) z) :=
+      isPreconnected_connectedComponentIn
+    exact
+      hc.subset_left_of_subset_union (overlapStrip_isOpen i) hRopen hdisj
+        ((connectedComponentIn_subset _ _).trans hcover)
+        ⟨z, mem_connectedComponentIn (overlapStrip_subset_overlap i hz), hz⟩
+  · exact
+      (overlapStrip_isConnected i).isPreconnected.subset_connectedComponentIn hz
+        (overlapStrip_subset_overlap i)
+
+private theorem SpecialPeriods.Triangle.overlapStrip_pathComponentIn (i : Fin 3) {z : ℂ}
+    (hz : z ∈ overlapStrip i) :
+    pathComponentIn (upperSlitPlane ∩ lowerSlitPlane) z = overlapStrip i := by
+  have hzO := overlapStrip_subset_overlap i hz
+  apply subset_antisymm
+  · calc
+      pathComponentIn (upperSlitPlane ∩ lowerSlitPlane) z ⊆
+          connectedComponentIn (upperSlitPlane ∩ lowerSlitPlane) z :=
+        (isPathConnected_pathComponentIn
+              hzO).isConnected.isPreconnected.subset_connectedComponentIn
+          (mem_pathComponentIn_self hzO) pathComponentIn_subset
+      _ = overlapStrip i := overlapStrip_connectedComponentIn i hz
+  · exact
+      (overlapStrip_isPathConnected i).subset_pathComponentIn hz (overlapStrip_subset_overlap i)
+
+private theorem SpecialPeriods.Triangle.overlap_joinedIn_iff {z w : ℂ} :
+    JoinedIn (upperSlitPlane ∩ lowerSlitPlane) z w ↔
+      ∃ i : Fin 3, z ∈ overlapStrip i ∧ w ∈ overlapStrip i := by
+  constructor
+  · intro h
+    have hz : z ∈ ⋃ i : Fin 3, overlapStrip i := by
+      rw [overlapStrip_iUnion]
+      exact h.source_mem
+    obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hz
+    refine ⟨i, hi, ?_⟩
+    have hm : w ∈ pathComponentIn (upperSlitPlane ∩ lowerSlitPlane) z := h
+    rwa [overlapStrip_pathComponentIn i hi] at hm
+  · rintro ⟨i, hz, hw⟩
+    exact (overlapStrip_joinedIn i hz hw).mono (overlapStrip_subset_overlap i)
+
+private def SpecialPeriods.Triangle.upperSlit : TopologicalSpace.Opens TwicePuncturedPlane :=
+  ⟨{z | (z : ℂ) ∈ upperSlitPlane}, upperSlitPlane_isOpen.preimage continuous_subtype_val⟩
+
+private def SpecialPeriods.Triangle.lowerSlit : TopologicalSpace.Opens TwicePuncturedPlane :=
+  ⟨{z | (z : ℂ) ∈ lowerSlitPlane}, lowerSlitPlane_isOpen.preimage continuous_subtype_val⟩
+
+private theorem SpecialPeriods.Triangle.mem_upperSlit_or_lowerSlit (z : TwicePuncturedPlane) :
+    z ∈ upperSlit ∨ z ∈ lowerSlit := by
+  have hz : (z : ℂ) ∈ ({w : ℂ | w ≠ 0 ∧ w ≠ 1}) := z.property
+  rwa [← slitPlanes_union] at hz
+
+private theorem SpecialPeriods.Triangle.upperSlit_union_lowerSlit :
+    (upperSlit : Set TwicePuncturedPlane) ∪ lowerSlit = Set.univ :=
+  Set.eq_univ_of_forall mem_upperSlit_or_lowerSlit
+
+private def SpecialPeriods.Triangle.upperSlitHomeomorph : upperSlit ≃ₜ upperSlitPlane
+    where
+  toFun z := ⟨z.val.val, z.property⟩
+  invFun z := ⟨⟨z.val, upperSlitPlane_subset_punctured z.property⟩, z.property⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := by fun_prop
+  continuous_invFun := by fun_prop
+
+private def SpecialPeriods.Triangle.lowerSlitHomeomorph : lowerSlit ≃ₜ lowerSlitPlane
+    where
+  toFun z := ⟨z.val.val, z.property⟩
+  invFun z := ⟨⟨z.val, lowerSlitPlane_subset_punctured z.property⟩, z.property⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := by fun_prop
+  continuous_invFun := by fun_prop
+
+private instance
+    SpecialPeriods.Triangle.upperSlit_contractibleSpace : ContractibleSpace upperSlit :=
+  upperSlitHomeomorph.contractibleSpace
+
+private instance
+    SpecialPeriods.Triangle.lowerSlit_contractibleSpace : ContractibleSpace lowerSlit :=
+  lowerSlitHomeomorph.contractibleSpace
+
+private theorem
+    SpecialPeriods.Triangle.upperSlit_simplyConnectedSpace : SimplyConnectedSpace upperSlit :=
+  inferInstance
+
+private theorem
+    SpecialPeriods.Triangle.lowerSlit_simplyConnectedSpace : SimplyConnectedSpace lowerSlit :=
+  inferInstance
+
+private def SpecialPeriods.Triangle.slitOverlapStrip (i : Fin 3) :
+    TopologicalSpace.Opens TwicePuncturedPlane :=
+  ⟨{z | (z : ℂ) ∈ overlapStrip i}, (overlapStrip_isOpen i).preimage continuous_subtype_val⟩
+
+private def SpecialPeriods.Triangle.slitOverlapStripHomeomorph (i : Fin 3) :
+    slitOverlapStrip i ≃ₜ overlapStrip i
+    where
+  toFun z := ⟨z.val.val, z.property⟩
+  invFun
+    z :=
+    ⟨⟨z.val, upperSlitPlane_subset_punctured ((overlapStrip_subset_overlap i z.property).1)⟩,
+      z.property⟩
+  left_inv _ := rfl
+  right_inv _ := rfl
+  continuous_toFun := by fun_prop
+  continuous_invFun := by fun_prop
+
+private instance SpecialPeriods.Triangle.slitOverlapStrip_contractibleSpace (i : Fin 3) :
+    ContractibleSpace (slitOverlapStrip i) :=
+  (slitOverlapStripHomeomorph i).contractibleSpace
+
+private theorem SpecialPeriods.Triangle.slitOverlapStrip_isPathConnected (i : Fin 3) :
+    IsPathConnected (slitOverlapStrip i : Set TwicePuncturedPlane) := by
+  let : ContractibleSpace (slitOverlapStrip i : Set TwicePuncturedPlane) :=
+    slitOverlapStrip_contractibleSpace i
+  exact isPathConnected_iff_pathConnectedSpace.mpr inferInstance
+
+private theorem SpecialPeriods.Triangle.slitOverlapStrip_subset_overlap (i : Fin 3) :
+    (slitOverlapStrip i : Set TwicePuncturedPlane) ⊆
+      (upperSlit : Set TwicePuncturedPlane) ∩ lowerSlit :=
+  fun _ hz => overlapStrip_subset_overlap i hz
+
+private def SpecialPeriods.Triangle.slitOverlapStripPoint (i : Fin 3) : slitOverlapStrip i :=
+  (slitOverlapStripHomeomorph i).symm (overlapStripPoint i)
+
+private theorem SpecialPeriods.Triangle.slitOverlapStrip_pairwise_disjoint :
+    Pairwise fun i j : Fin 3 =>
+      Disjoint (slitOverlapStrip i : Set TwicePuncturedPlane) (slitOverlapStrip j) := by
+  intro i j hij
+  apply Set.disjoint_left.mpr
+  intro z hi hj
+  exact Set.disjoint_left.mp (overlapStrip_pairwise_disjoint hij) hi hj
+
+private theorem SpecialPeriods.Triangle.slitOverlapStrip_iUnion :
+    (⋃ i : Fin 3, (slitOverlapStrip i : Set TwicePuncturedPlane)) =
+      (upperSlit : Set TwicePuncturedPlane) ∩ lowerSlit := by
+  ext z
+  constructor
+  · intro hz
+    obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hz
+    exact slitOverlapStrip_subset_overlap i hi
+  · intro hz
+    have hc : (z : ℂ) ∈ (⋃ i : Fin 3, overlapStrip i) := by
+      rw [overlapStrip_iUnion]
+      exact hz
+    obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hc
+    exact Set.mem_iUnion.mpr ⟨i, hi⟩
+
+private theorem SpecialPeriods.Triangle.slitOverlap_joinedIn_iff {z w : TwicePuncturedPlane} :
+    JoinedIn ((upperSlit : Set TwicePuncturedPlane) ∩ lowerSlit) z w ↔
+      ∃ i : Fin 3, z ∈ slitOverlapStrip i ∧ w ∈ slitOverlapStrip i := by
+  constructor
+  · intro h
+    have hc :
+      JoinedIn
+        (((↑) : TwicePuncturedPlane → ℂ) '' ((upperSlit : Set TwicePuncturedPlane) ∩ lowerSlit))
+        (z : ℂ) (w : ℂ) :=
+      h.map continuous_subtype_val
+    have hs :
+      ((↑) : TwicePuncturedPlane → ℂ) '' ((upperSlit : Set TwicePuncturedPlane) ∩ lowerSlit) ⊆
+        upperSlitPlane ∩ lowerSlitPlane := by
+      rintro x ⟨y, hy, rfl⟩
+      exact hy
+    exact overlap_joinedIn_iff.mp (hc.mono hs)
+  · rintro ⟨i, hz, hw⟩
+    exact
+      ((slitOverlapStrip_isPathConnected i).joinedIn z hz w hw).mono
+        (slitOverlapStrip_subset_overlap i)
+
+private def SpecialPeriods.Triangle.meridianClass (b : Bool) :
+    FundamentalGroup TwicePuncturedPlane meridianBasepoint :=
+  FundamentalGroup.fromPath
+    (Path.Homotopic.Quotient.mk (if b then positiveMeridianOne else positiveMeridianZero))
+
+private def SpecialPeriods.Triangle.meridianWordMap :
+    FreeGroup Bool →* FundamentalGroup TwicePuncturedPlane meridianBasepoint :=
+  FreeGroup.lift meridianClass
+
+@[simp]
+private theorem SpecialPeriods.Triangle.meridianWordMap_of (b : Bool) :
+    meridianWordMap (FreeGroup.of b) = meridianClass b :=
+  FreeGroup.lift_apply_of
+
+private theorem SpecialPeriods.Triangle.base_mem_upper_mo1973_23596 :
+    meridianBasepoint ∈ upperSlit := by
+  change (meridianBasepoint : ℂ) ∈ upperSlitPlane
+  simpa using upperZeroPath_mem_upperSlitPlane 0
+
+private theorem SpecialPeriods.Triangle.base_mem_lower_mo1973_23597 :
+    meridianBasepoint ∈ lowerSlit := by
+  change (meridianBasepoint : ℂ) ∈ lowerSlitPlane
+  simpa using lowerZeroPath_mem_lowerSlitPlane 0
+
+private theorem SpecialPeriods.Triangle.left_mem_upper_mo1973_23598 :
+    meridianLeftPoint ∈ upperSlit := by
+  change (meridianLeftPoint : ℂ) ∈ upperSlitPlane
+  simpa using upperZeroPath_mem_upperSlitPlane 1
+
+private theorem SpecialPeriods.Triangle.left_mem_lower_mo1973_23599 :
+    meridianLeftPoint ∈ lowerSlit := by
+  change (meridianLeftPoint : ℂ) ∈ lowerSlitPlane
+  simpa using lowerZeroPath_mem_lowerSlitPlane 1
+
+private theorem SpecialPeriods.Triangle.right_mem_upper_mo1973_23600 :
+    meridianRightPoint ∈ upperSlit := by
+  change (meridianRightPoint : ℂ) ∈ upperSlitPlane
+  simpa using upperOnePath_mem_upperSlitPlane 1
+
+private theorem SpecialPeriods.Triangle.right_mem_lower_mo1973_23601 :
+    meridianRightPoint ∈ lowerSlit := by
+  change (meridianRightPoint : ℂ) ∈ lowerSlitPlane
+  simpa using lowerOnePath_mem_lowerSlitPlane 1
+
+private def SpecialPeriods.Triangle.meridianSlitCover :
+    TriangleRegularBaseFundamentalGroup.TwoSimplyConnectedCover TwicePuncturedPlane
+    where
+  U := upperSlit
+  V := lowerSlit
+  cover := upperSlit_union_lowerSlit
+  simplyU := upperSlit_simplyConnectedSpace
+  simplyV := lowerSlit_simplyConnectedSpace
+  base := meridianBasepoint
+  baseU := base_mem_upper_mo1973_23596
+  baseV := base_mem_lower_mo1973_23597
+
+private theorem SpecialPeriods.Triangle.switch_left_mo1973_23603 :
+    meridianSlitCover.switchClass meridianLeftPoint left_mem_upper_mo1973_23598
+        left_mem_lower_mo1973_23599 =
+      meridianClass Bool.false :=
+  meridianSlitCover.switchClass_eq_of_paths left_mem_upper_mo1973_23598
+    left_mem_lower_mo1973_23599 upperZeroPath lowerZeroPath upperZeroPath_mem_upperSlitPlane
+    lowerZeroPath_mem_lowerSlitPlane
+
+private theorem SpecialPeriods.Triangle.switch_right_mo1973_23604 :
+    meridianSlitCover.switchClass meridianRightPoint right_mem_upper_mo1973_23600
+        right_mem_lower_mo1973_23601 =
+      (meridianClass Bool.true)⁻¹ := by
+  rw [meridianSlitCover.switchClass_eq_of_paths right_mem_upper_mo1973_23600
+      right_mem_lower_mo1973_23601 upperOnePath lowerOnePath upperOnePath_mem_upperSlitPlane
+      lowerOnePath_mem_lowerSlitPlane]
+  change
+    Path.Homotopic.Quotient.mk (upperOnePath.trans lowerOnePath.symm) =
+      Path.Homotopic.Quotient.mk (lowerOnePath.trans upperOnePath.symm).symm
+  rw [Path.trans_symm, Path.symm_symm]
+
+private def SpecialPeriods.Triangle.overlapRepresentative_mo1973_23605 :
+    Fin 3 → TwicePuncturedPlane
+  | 0 => meridianLeftPoint
+  | 1 => meridianBasepoint
+  | 2 => meridianRightPoint
+
+private theorem SpecialPeriods.Triangle.overlapRepresentative_mem_mo1973_23606 (i : Fin 3) :
+    overlapRepresentative_mo1973_23605 i ∈ slitOverlapStrip i := by
+  fin_cases i <;>
+    norm_num [overlapRepresentative_mo1973_23605, slitOverlapStrip, overlapStrip,
+      meridianLeftPoint, meridianBasepoint, meridianRightPoint]
+
+private theorem SpecialPeriods.Triangle.overlapRepresentative_mem_upper_mo1973_23607 (i : Fin 3) :
+    overlapRepresentative_mo1973_23605 i ∈ meridianSlitCover.U :=
+  (slitOverlapStrip_subset_overlap i (overlapRepresentative_mem_mo1973_23606 i)).1
+
+private theorem SpecialPeriods.Triangle.overlapRepresentative_mem_lower_mo1973_23608 (i : Fin 3) :
+    overlapRepresentative_mo1973_23605 i ∈ meridianSlitCover.V :=
+  (slitOverlapStrip_subset_overlap i (overlapRepresentative_mem_mo1973_23606 i)).2
+
+private theorem SpecialPeriods.Triangle.every_overlap_point_joined_mo1973_23609
+    (x : TwicePuncturedPlane) (hxU : x ∈ meridianSlitCover.U) (hxV : x ∈ meridianSlitCover.V) :
+    ∃ i : Fin 3,
+      JoinedIn ((meridianSlitCover.U : Set TwicePuncturedPlane) ∩ meridianSlitCover.V)
+        (overlapRepresentative_mo1973_23605 i) x := by
+  have hx : x ∈ ⋃ i : Fin 3, (slitOverlapStrip i : Set TwicePuncturedPlane) := by
+    rw [slitOverlapStrip_iUnion]
+    exact ⟨hxU, hxV⟩
+  obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hx
+  exact ⟨i, slitOverlap_joinedIn_iff.mpr ⟨i, overlapRepresentative_mem_mo1973_23606 i, hi⟩⟩
+
+private theorem SpecialPeriods.Triangle.meridianWordMap_surjective :
+    Function.Surjective meridianWordMap := by
+  apply MonoidHom.range_eq_top.mp
+  apply meridianSlitCover.subgroup_eq_top_of_switchClass_mem
+  intro x hxU hxV
+  obtain ⟨i, hi⟩ := every_overlap_point_joined_mo1973_23609 x hxU hxV
+  rw [←
+    meridianSlitCover.switchClass_eq_of_joinedIn (overlapRepresentative_mem_upper_mo1973_23607 i)
+      (overlapRepresentative_mem_lower_mo1973_23608 i) hxU hxV hi]
+  fin_cases i
+  · change meridianSlitCover.switchClass meridianLeftPoint _ _ ∈ meridianWordMap.range
+    rw [switch_left_mo1973_23603]
+    exact ⟨FreeGroup.of Bool.false, meridianWordMap_of Bool.false⟩
+  · change meridianSlitCover.switchClass meridianSlitCover.base _ _ ∈ meridianWordMap.range
+    rw [meridianSlitCover.switchClass_base]
+    exact meridianWordMap.range.one_mem
+  · change meridianSlitCover.switchClass meridianRightPoint _ _ ∈ meridianWordMap.range
+    rw [switch_right_mo1973_23604]
+    exact meridianWordMap.range.inv_mem ⟨FreeGroup.of Bool.true, meridianWordMap_of Bool.true⟩
+
+@[instance_reducible]
+private def SpecialPeriods.Triangle.discreteFreeGroup : TopologicalSpace (FreeGroup Bool) :=
+  ⊥
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+private instance
+    SpecialPeriods.Triangle.discreteFreeGroup_discrete : DiscreteTopology (FreeGroup Bool) :=
+  ⟨rfl⟩
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+private def SpecialPeriods.Triangle.freeGroupTransitionValue : Fin 3 → FreeGroup Bool
+  | 0 => (FreeGroup.of Bool.false)⁻¹
+  | 1 => 1
+  | 2 => FreeGroup.of Bool.true
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+private def
+    SpecialPeriods.Triangle.freeGroupTransition (z : TwicePuncturedPlane) : FreeGroup Bool :=
+  if (z : ℂ).re < 0 then (FreeGroup.of Bool.false)⁻¹
+  else if (z : ℂ).re < 1 then 1 else FreeGroup.of Bool.true
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+private theorem SpecialPeriods.Triangle.freeGroupTransition_eqOn_strip (i : Fin 3) :
+    Set.EqOn freeGroupTransition (fun _ => freeGroupTransitionValue i)
+      (slitOverlapStrip i : Set TwicePuncturedPlane) := by
+  intro z hz
+  fin_cases i
+  · have hneg : (z : ℂ).re < 0 := hz
+    simp only [freeGroupTransition, ite_eq_left hneg, freeGroupTransitionValue]
+  · have hmid : 0 < (z : ℂ).re ∧ (z : ℂ).re < 1 := hz
+    simp only [freeGroupTransition, ite_eq_right (not_lt.mpr hmid.1.le), ite_eq_left hmid.2,
+      freeGroupTransitionValue]
+  · have hpos : 1 < (z : ℂ).re := hz
+    have hnonneg : ¬(z : ℂ).re < 0 := by linarith
+    simp only [freeGroupTransition, ite_eq_right hnonneg, ite_eq_right (not_lt.mpr hpos.le),
+      freeGroupTransitionValue]
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+private theorem SpecialPeriods.Triangle.freeGroupTransition_continuousOn :
+    ContinuousOn freeGroupTransition ((upperSlit : Set TwicePuncturedPlane) ∩ lowerSlit) := by
+  apply continuousOn_of_locally_continuousOn
+  intro z hz
+  have hz' : z ∈ ⋃ i : Fin 3, (slitOverlapStrip i : Set TwicePuncturedPlane) := by
+    rw [slitOverlapStrip_iUnion]
+    exact hz
+  obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hz'
+  refine ⟨slitOverlapStrip i, (slitOverlapStrip i).isOpen, hi, ?_⟩
+  apply (continuousOn_const (c := freeGroupTransitionValue i)).congr
+  intro w hw
+  exact freeGroupTransition_eqOn_strip i hw.2
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+private def SpecialPeriods.Triangle.freeGroupCover :
+    TwoOpenTransition TwicePuncturedPlane (FreeGroup Bool)
+    where
+  U := upperSlit
+  V := lowerSlit
+  cover := upperSlit_union_lowerSlit
+  transition := freeGroupTransition
+  continuousOn_transition := freeGroupTransition_continuousOn
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+@[simp]
+private theorem SpecialPeriods.Triangle.freeGroupCover_transition :
+    freeGroupCover.transition = freeGroupTransition :=
+  rfl
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+@[simp]
+private theorem SpecialPeriods.Triangle.freeGroupTransition_basepoint :
+    freeGroupTransition meridianBasepoint = 1 := by
+  norm_num [freeGroupTransition, meridianBasepoint]
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+@[simp]
+private theorem SpecialPeriods.Triangle.freeGroupTransition_leftPoint :
+    freeGroupTransition meridianLeftPoint = (FreeGroup.of Bool.false)⁻¹ := by
+  norm_num [freeGroupTransition, meridianLeftPoint]
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+@[simp]
+private theorem SpecialPeriods.Triangle.freeGroupTransition_rightPoint :
+    freeGroupTransition meridianRightPoint = FreeGroup.of Bool.true := by
+  norm_num [freeGroupTransition, meridianRightPoint]
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+private theorem SpecialPeriods.Triangle.freeGroupCover_basepoint_mem :
+    meridianBasepoint ∈ (freeGroupCover.U : Set TwicePuncturedPlane) ∩ freeGroupCover.V := by
+  change (meridianBasepoint : ℂ) ∈ upperSlitPlane ∩ lowerSlitPlane
+  rw [slitPlanes_inter]
+  norm_num [meridianBasepoint]
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+private theorem SpecialPeriods.Triangle.freeGroupCover_leftPoint_mem :
+    meridianLeftPoint ∈ (freeGroupCover.U : Set TwicePuncturedPlane) ∩ freeGroupCover.V := by
+  change (meridianLeftPoint : ℂ) ∈ upperSlitPlane ∩ lowerSlitPlane
+  rw [slitPlanes_inter]
+  norm_num [meridianLeftPoint]
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+private theorem SpecialPeriods.Triangle.freeGroupCover_rightPoint_mem :
+    meridianRightPoint ∈ (freeGroupCover.U : Set TwicePuncturedPlane) ∩ freeGroupCover.V := by
+  change (meridianRightPoint : ℂ) ∈ upperSlitPlane ∩ lowerSlitPlane
+  rw [slitPlanes_inter]
+  norm_num [meridianRightPoint]
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+private def SpecialPeriods.Triangle.meridianFreeWordHom :
+    FundamentalGroup TwicePuncturedPlane meridianBasepoint →* FreeGroup Bool :=
+  (MulEquiv.inv' (FreeGroup Bool)).symm.toMonoidHom.comp
+    (freeGroupCover.fundamentalGroupToMulOpposite meridianBasepoint
+      freeGroupCover_basepoint_mem.1)
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+@[simp]
+private theorem SpecialPeriods.Triangle.meridianFreeWordHom_positiveMeridianZero :
+    meridianFreeWordHom (.mk positiveMeridianZero) = FreeGroup.of Bool.false := by
+  have hzero :=
+    freeGroupCover.fundamentalGroupToMulOpposite_trans_U_V freeGroupCover_basepoint_mem
+      freeGroupCover_leftPoint_mem upperZeroPath lowerZeroPath.symm
+      (fun s => upperZeroPath_mem_upperSlitPlane s)
+      (fun s => lowerZeroPath_mem_lowerSlitPlane (unitInterval.symm s))
+  change
+    (MulEquiv.inv' (FreeGroup Bool)).symm
+        (freeGroupCover.fundamentalGroupToMulOpposite meridianBasepoint
+          freeGroupCover_basepoint_mem.1 (.mk (upperZeroPath.trans lowerZeroPath.symm))) =
+      _
+  rw [hzero]
+  change (freeGroupTransition meridianLeftPoint * (freeGroupTransition meridianBasepoint)⁻¹)⁻¹ = _
+  simp
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+@[simp]
+private theorem SpecialPeriods.Triangle.meridianFreeWordHom_positiveMeridianOne :
+    meridianFreeWordHom (.mk positiveMeridianOne) = FreeGroup.of Bool.true := by
+  have hone :=
+    freeGroupCover.fundamentalGroupToMulOpposite_trans_U_V freeGroupCover_basepoint_mem
+      freeGroupCover_rightPoint_mem upperOnePath lowerOnePath.symm
+      (fun s => upperOnePath_mem_upperSlitPlane s)
+      (fun s => lowerOnePath_mem_lowerSlitPlane (unitInterval.symm s))
+  have hword :
+    meridianFreeWordHom (.mk (upperOnePath.trans lowerOnePath.symm)) =
+      (FreeGroup.of Bool.true)⁻¹ := by
+    change
+      (MulEquiv.inv' (FreeGroup Bool)).symm
+          (freeGroupCover.fundamentalGroupToMulOpposite meridianBasepoint
+            freeGroupCover_basepoint_mem.1 (.mk (upperOnePath.trans lowerOnePath.symm))) =
+        _
+    rw [hone]
+    change
+      (freeGroupTransition meridianRightPoint * (freeGroupTransition meridianBasepoint)⁻¹)⁻¹ = _
+    simp
+  let q : FundamentalGroup TwicePuncturedPlane meridianBasepoint :=
+    .mk (upperOnePath.trans lowerOnePath.symm)
+  have hpath :
+    (.mk positiveMeridianOne : FundamentalGroup TwicePuncturedPlane meridianBasepoint) = q⁻¹ := by
+    rw [FundamentalGroup.inv_def]
+    change
+      .mk positiveMeridianOne =
+        (Path.Homotopic.Quotient.mk (upperOnePath.trans lowerOnePath.symm)).symm
+    rw [← Path.Homotopic.Quotient.mk_symm, Path.trans_symm, Path.symm_symm]
+    rfl
+  rw [hpath, map_inv]
+  change (meridianFreeWordHom (.mk (upperOnePath.trans lowerOnePath.symm)))⁻¹ = _
+  rw [hword, inv_inv]
+
+@[simp]
+private theorem SpecialPeriods.Triangle.meridianFreeWordHom_meridianClass (b : Bool) :
+    meridianFreeWordHom (meridianClass b) = FreeGroup.of b := by
+  cases b
+  · exact meridianFreeWordHom_positiveMeridianZero
+  · exact meridianFreeWordHom_positiveMeridianOne
+
+private theorem SpecialPeriods.Triangle.meridianFreeWordHom_comp_wordMap :
+    meridianFreeWordHom.comp meridianWordMap = MonoidHom.id (FreeGroup Bool) := by
+  apply FreeGroup.ext_hom
+  intro b
+  simp only [MonoidHom.comp_apply, meridianWordMap_of, meridianFreeWordHom_meridianClass,
+    MonoidHom.id_apply]
+
+@[simp]
+private theorem SpecialPeriods.Triangle.meridianFreeWordHom_wordMap (w : FreeGroup Bool) :
+    meridianFreeWordHom (meridianWordMap w) = w :=
+  DFunLike.congr_fun meridianFreeWordHom_comp_wordMap w
+
+@[simp]
+private theorem SpecialPeriods.Triangle.meridianWordMap_freeWordHom
+    (γ : FundamentalGroup TwicePuncturedPlane meridianBasepoint) :
+    meridianWordMap (meridianFreeWordHom γ) = γ := by
+  obtain ⟨w, rfl⟩ := meridianWordMap_surjective γ
+  rw [meridianFreeWordHom_wordMap]
+
+private def SpecialPeriods.Triangle.twicePuncturedFundamentalGroupFreeEquiv :
+    FundamentalGroup TwicePuncturedPlane meridianBasepoint ≃* FreeGroup Bool
+    where
+  __ := meridianFreeWordHom
+  invFun := meridianWordMap
+  left_inv := meridianWordMap_freeWordHom
+  right_inv := meridianFreeWordHom_wordMap
+
+@[simp]
+private theorem SpecialPeriods.Triangle.twicePuncturedFundamentalGroupFreeEquiv_symm_of (b : Bool) :
+    twicePuncturedFundamentalGroupFreeEquiv.symm (FreeGroup.of b) = meridianClass b :=
+  meridianWordMap_of b
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Uniformization/SpecialPeriods9.lean b/LeanPool/HopfProblem/Uniformization/SpecialPeriods9.lean
new file mode 100644
index 000000000..b186af2f9
--- /dev/null
+++ b/LeanPool/HopfProblem/Uniformization/SpecialPeriods9.lean
@@ -0,0 +1,453 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.HomologyOfX.TrianglePeriodFamilyHomologyLattice
+import all LeanPool.HopfProblem.Foundations.TriangleRegularBaseFundamentalGroup
+import all LeanPool.HopfProblem.Pi1.FundamentalGroupVanKampen1
+import all LeanPool.HopfProblem.Foundations.TwoOpenTransition
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods8
+import all LeanPool.HopfProblem.HomologyOfX.TrianglePeriodFamilyHomologyLattice
+
+/-!
+# Hopf problem: uniformization · special periods 9
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private def SpecialPeriods.Triangle.outerCircleValue (R t : ℝ) : ℂ :=
+  circleMap (1 / 2 : ℂ) R (-Real.pi / 2 + 2 * Real.pi * t)
+
+@[fun_prop]
+private theorem SpecialPeriods.Triangle.continuous_outerCircleValue (R : ℝ) :
+    Continuous (outerCircleValue R) := by
+  unfold outerCircleValue circleMap
+  fun_prop
+
+@[simp]
+private theorem SpecialPeriods.Triangle.outerCircleValue_zero (R : ℝ) :
+    outerCircleValue R 0 = (1 / 2 : ℂ) - (R : ℂ) * Complex.I := by
+  simpa only [outerCircleValue, MulZeroClass.mul_zero, add_zero] using
+    circleMap_neg_pi_div_two (1 / 2 : ℂ) R
+
+@[simp]
+private theorem SpecialPeriods.Triangle.outerCircleValue_one (R : ℝ) :
+    outerCircleValue R 1 = (1 / 2 : ℂ) - (R : ℂ) * Complex.I := by
+  unfold outerCircleValue
+  rw [mul_one, periodic_circleMap (1 / 2 : ℂ) R (-Real.pi / 2)]
+  exact circleMap_neg_pi_div_two (1 / 2 : ℂ) R
+
+private theorem
+    SpecialPeriods.Triangle.outerCircleValue_norm_sub_center (R : ℝ) (hR : 2 ≤ R) (t : ℝ) :
+    ‖outerCircleValue R t - (1 / 2 : ℂ)‖ = R := by
+  simp only [outerCircleValue, circleMap_sub_center, norm_circleMap_zero]
+  exact abs_of_nonneg (by linarith)
+
+private theorem
+    SpecialPeriods.Triangle.outerCircleValue_avoids_punctures (R : ℝ) (hR : 2 ≤ R) (t : ℝ) :
+    outerCircleValue R t ≠ 0 ∧ outerCircleValue R t ≠ 1 := by
+  have hn := outerCircleValue_norm_sub_center R hR t
+  constructor
+  · intro h
+    rw [h] at hn
+    norm_num [norm_div] at hn
+    linarith
+  · intro h
+    rw [h, show (1 : ℂ) - 1 / 2 = 1 / 2 by ring] at hn
+    norm_num [norm_div] at hn
+    linarith
+
+private def
+    SpecialPeriods.Triangle.outerCircleBasepoint (R : ℝ) (hR : 2 ≤ R) : TwicePuncturedPlane :=
+  ⟨(1 / 2 : ℂ) - (R : ℂ) * Complex.I,
+    by
+    rw [← outerCircleValue_zero R]
+    exact outerCircleValue_avoids_punctures R hR 0⟩
+
+private def SpecialPeriods.Triangle.outerPositiveCircle (R : ℝ) (hR : 2 ≤ R) :
+    Path (outerCircleBasepoint R hR) (outerCircleBasepoint R hR)
+    where
+  toFun t := ⟨outerCircleValue R t, outerCircleValue_avoids_punctures R hR t⟩
+  continuous_toFun := ((continuous_outerCircleValue R).comp continuous_subtype_val).subtype_mk _
+  source' := Subtype.ext (outerCircleValue_zero R)
+  target' := Subtype.ext (outerCircleValue_one R)
+
+@[simp]
+private theorem
+    SpecialPeriods.Triangle.outerPositiveCircle_coe (R : ℝ) (hR : 2 ≤ R) (t : unitInterval) :
+    (outerPositiveCircle R hR t : ℂ) =
+      circleMap (1 / 2 : ℂ) R (-Real.pi / 2 + 2 * Real.pi * (t : ℝ)) :=
+  rfl
+
+private theorem SpecialPeriods.Triangle.outerPositiveCircle_norm_sub_center (R : ℝ) (hR : 2 ≤ R)
+    (t : unitInterval) : ‖(outerPositiveCircle R hR t : ℂ) - (1 / 2 : ℂ)‖ = R :=
+  outerCircleValue_norm_sub_center R hR t
+
+private def SpecialPeriods.Triangle.outerTailValue (R t : ℝ) : ℂ :=
+  (1 / 2 : ℂ) - ((R * t : ℝ) : ℂ) * Complex.I
+
+@[simp]
+private theorem
+    SpecialPeriods.Triangle.outerTailValue_re (R t : ℝ) : (outerTailValue R t).re = 1 / 2 := by
+  simp [outerTailValue, Complex.mul_re]
+
+private theorem SpecialPeriods.Triangle.outerTailValue_mem_slitPlanes (R t : ℝ) :
+    outerTailValue R t ∈ upperSlitPlane ∩ lowerSlitPlane := by
+  have hx : (outerTailValue R t).re ≠ 0 ∧ (outerTailValue R t).re ≠ 1 := by
+    rw [outerTailValue_re]
+    norm_num
+  exact ⟨Or.inr hx, Or.inr hx⟩
+
+private def SpecialPeriods.Triangle.outerMeridianTail (R : ℝ) (hR : 2 ≤ R) :
+    Path meridianBasepoint (outerCircleBasepoint R hR)
+    where
+  toFun
+    t :=
+    ⟨outerTailValue R t, upperSlitPlane_subset_punctured (outerTailValue_mem_slitPlanes R t).1⟩
+  continuous_toFun := by
+    apply Continuous.subtype_mk
+    unfold outerTailValue
+    fun_prop
+  source' := Subtype.ext (by simp [outerTailValue, meridianBasepoint])
+  target' := Subtype.ext (by simp [outerTailValue, outerCircleBasepoint])
+
+private theorem SpecialPeriods.Triangle.outerMeridianTail_mem_lowerSlitPlane (R : ℝ) (hR : 2 ≤ R)
+    (t : unitInterval) : (outerMeridianTail R hR t : ℂ) ∈ lowerSlitPlane :=
+  (outerTailValue_mem_slitPlanes R t).2
+
+private def SpecialPeriods.Triangle.outerQuarter : unitInterval :=
+  ⟨1 / 4, by norm_num⟩
+
+private def SpecialPeriods.Triangle.outerThreeQuarters : unitInterval :=
+  ⟨3 / 4, by norm_num⟩
+
+private theorem SpecialPeriods.Triangle.outerCircleValue_quarter (R : ℝ) :
+    outerCircleValue R (1 / 4) = (1 / 2 : ℂ) + (R : ℂ) := by
+  unfold outerCircleValue
+  rw [show -Real.pi / 2 + 2 * Real.pi * (1 / 4) = 0 by ring]
+  simp [circleMap]
+
+private theorem SpecialPeriods.Triangle.outerCircleValue_threeQuarters (R : ℝ) :
+    outerCircleValue R (3 / 4) = (1 / 2 : ℂ) - (R : ℂ) := by
+  unfold outerCircleValue
+  rw [show -Real.pi / 2 + 2 * Real.pi * (3 / 4) = Real.pi by ring]
+  simp [circleMap, Complex.exp_pi_mul_I, sub_eq_add_neg]
+
+private theorem SpecialPeriods.Triangle.outerCircleValue_im (R t : ℝ) :
+    (outerCircleValue R t).im = R * Real.sin (-Real.pi / 2 + 2 * Real.pi * t) := by
+  simpa [outerCircleValue, circleMap] using circleMap_zero_im R (-Real.pi / 2 + 2 * Real.pi * t)
+
+private theorem
+    SpecialPeriods.Triangle.outerCircleValue_mem_lowerSlitPlane (R : ℝ) (hR : 2 ≤ R) (t : ℝ)
+    (ht0 : 0 ≤ t) (ht1 : t ≤ 1) (ht : t ≤ 1 / 4 ∨ 3 / 4 ≤ t) :
+    outerCircleValue R t ∈ lowerSlitPlane := by
+  by_cases hquarter : t = 1 / 4
+  · rw [hquarter, outerCircleValue_quarter]
+    norm_num [lowerSlitPlane]
+    constructor <;> linarith
+  by_cases hthree : t = 3 / 4
+  · rw [hthree, outerCircleValue_threeQuarters]
+    norm_num [lowerSlitPlane]
+    constructor <;> linarith
+  apply Or.inl
+  rw [outerCircleValue_im]
+  have hRpos : 0 < R := by linarith
+  apply mul_neg_of_pos_of_neg hRpos
+  rcases ht with ht | ht
+  · have htlt : t < 1 / 4 := lt_of_le_of_ne ht hquarter
+    apply Real.sin_neg_of_neg_of_neg_pi_lt
+    · nlinarith [Real.pi_pos]
+    · nlinarith [Real.pi_pos]
+  · have htlt : 3 / 4 < t := lt_of_le_of_ne ht (Ne.symm hthree)
+    have hsin : 0 < Real.sin ((-Real.pi / 2 + 2 * Real.pi * t) - Real.pi) := by
+      apply Real.sin_pos_of_pos_of_lt_pi
+      · nlinarith [Real.pi_pos]
+      · nlinarith [Real.pi_pos]
+    rw [Real.sin_sub_pi] at hsin
+    linarith
+
+private theorem
+    SpecialPeriods.Triangle.outerCircleValue_mem_upperSlitPlane (R : ℝ) (hR : 2 ≤ R) (t : ℝ)
+    (ht0 : 1 / 4 ≤ t) (ht1 : t ≤ 3 / 4) : outerCircleValue R t ∈ upperSlitPlane := by
+  by_cases hquarter : t = 1 / 4
+  · rw [hquarter, outerCircleValue_quarter]
+    norm_num [upperSlitPlane]
+    constructor <;> linarith
+  by_cases hthree : t = 3 / 4
+  · rw [hthree, outerCircleValue_threeQuarters]
+    norm_num [upperSlitPlane]
+    constructor <;> linarith
+  apply Or.inl
+  rw [outerCircleValue_im]
+  have hRpos : 0 < R := by linarith
+  apply mul_pos hRpos
+  have ht0lt : 1 / 4 < t := lt_of_le_of_ne ht0 (Ne.symm hquarter)
+  have ht1lt : t < 3 / 4 := lt_of_le_of_ne ht1 hthree
+  apply Real.sin_pos_of_pos_of_lt_pi
+  · nlinarith [Real.pi_pos]
+  · nlinarith [Real.pi_pos]
+
+private theorem SpecialPeriods.Triangle.outerPositiveCircle_quarter (R : ℝ) (hR : 2 ≤ R) :
+    (outerPositiveCircle R hR outerQuarter : ℂ) = (1 / 2 : ℂ) + (R : ℂ) :=
+  outerCircleValue_quarter R
+
+private theorem SpecialPeriods.Triangle.outerPositiveCircle_threeQuarters (R : ℝ) (hR : 2 ≤ R) :
+    (outerPositiveCircle R hR outerThreeQuarters : ℂ) = (1 / 2 : ℂ) - (R : ℂ) :=
+  outerCircleValue_threeQuarters R
+
+private theorem SpecialPeriods.Triangle.outerPositiveCircle_mem_lowerSlitPlane (R : ℝ) (hR : 2 ≤ R)
+    (t : unitInterval) (ht : (t : ℝ) ≤ 1 / 4 ∨ 3 / 4 ≤ (t : ℝ)) :
+    (outerPositiveCircle R hR t : ℂ) ∈ lowerSlitPlane :=
+  outerCircleValue_mem_lowerSlitPlane R hR t t.property.1 t.property.2 ht
+
+private theorem SpecialPeriods.Triangle.outerPositiveCircle_mem_upperSlitPlane (R : ℝ) (hR : 2 ≤ R)
+    (t : unitInterval) (ht0 : 1 / 4 ≤ (t : ℝ)) (ht1 : (t : ℝ) ≤ 3 / 4) :
+    (outerPositiveCircle R hR t : ℂ) ∈ upperSlitPlane :=
+  outerCircleValue_mem_upperSlitPlane R hR t ht0 ht1
+
+private theorem SpecialPeriods.Triangle.outerPositiveCircle_quarter_re_gt_one (R : ℝ) (hR : 2 ≤ R) :
+    1 < (outerPositiveCircle R hR outerQuarter : ℂ).re := by
+  rw [outerPositiveCircle_quarter]
+  norm_num
+  linarith
+
+private theorem SpecialPeriods.Triangle.outerPositiveCircle_threeQuarters_re_lt_zero (R : ℝ)
+    (hR : 2 ≤ R) : (outerPositiveCircle R hR outerThreeQuarters : ℂ).re < 0 := by
+  rw [outerPositiveCircle_threeQuarters]
+  norm_num
+  linarith
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+private theorem
+    SpecialPeriods.Triangle.meridianFreeWordHom_lower_upper_lower {c d : TwicePuncturedPlane}
+    (hc : c ∈ (freeGroupCover.U : Set TwicePuncturedPlane) ∩ freeGroupCover.V)
+    (hd : d ∈ (freeGroupCover.U : Set TwicePuncturedPlane) ∩ freeGroupCover.V)
+    (α : Path meridianBasepoint c) (β : Path c d) (γ : Path d meridianBasepoint)
+    (hα : ∀ s, α s ∈ freeGroupCover.V) (hβ : ∀ s, β s ∈ freeGroupCover.U)
+    (hγ : ∀ s, γ s ∈ freeGroupCover.V) :
+    meridianFreeWordHom (.mk (α.trans (β.trans γ))) =
+      (freeGroupTransition d)⁻¹ * freeGroupTransition c := by
+  have hm :
+    freeGroupCover.isCoveringMap.monodromy (.mk (α.trans (β.trans γ)))
+        (freeGroupCover.fiberPointU meridianBasepoint 1) =
+      freeGroupCover.fiberPointU meridianBasepoint
+        ((freeGroupTransition c)⁻¹ * freeGroupTransition d) := by
+    rw [Path.Homotopic.Quotient.mk_trans, freeGroupCover.isCoveringMap.monodromy_trans_apply,
+      freeGroupCover.fiberPointU_eq_fiberPointV meridianBasepoint 1 freeGroupCover_basepoint_mem,
+      freeGroupCover.monodromy_of_path_V α hα, freeGroupCover.fiberPointV_eq_fiberPointU c _ hc,
+      Path.Homotopic.Quotient.mk_trans, freeGroupCover.isCoveringMap.monodromy_trans_apply,
+      freeGroupCover.monodromy_of_path_U β hβ, freeGroupCover.fiberPointU_eq_fiberPointV d _ hd,
+      freeGroupCover.monodromy_of_path_V γ hγ,
+      freeGroupCover.fiberPointV_eq_fiberPointU meridianBasepoint _ freeGroupCover_basepoint_mem]
+    simp only [freeGroupCover_transition, freeGroupTransition_basepoint, one_mul, inv_one,
+      mul_one]
+  have hop :
+    freeGroupCover.fundamentalGroupToMulOpposite meridianBasepoint freeGroupCover_basepoint_mem.1
+        (.mk (α.trans (β.trans γ))) =
+      MulOpposite.op ((freeGroupTransition c)⁻¹ * freeGroupTransition d) := by
+    apply (freeGroupCover.isQuotientCoveringMap.fundamentalGroupToMulOpposite_apply_eq_Iff).mpr
+    have hm' := congrArg Subtype.val hm
+    simpa only [MulOpposite.unop_op, TwoOpenTransition.basepointU_eq_fiberPointU,
+      TwoOpenTransition.fiberPointU_val, TwoOpenTransition.smul_pointU, mul_one] using hm'.symm
+  change
+    (MulEquiv.inv' (FreeGroup Bool)).symm
+        (freeGroupCover.fundamentalGroupToMulOpposite meridianBasepoint
+          freeGroupCover_basepoint_mem.1 (.mk (α.trans (β.trans γ)))) =
+      _
+  rw [hop]
+  change ((freeGroupTransition c)⁻¹ * freeGroupTransition d)⁻¹ = _
+  simp only [mul_inv_rev, inv_inv]
+
+private theorem SpecialPeriods.Triangle.three_subpaths_homotopic_mo1973_26253 {X : Type*}
+    [TopologicalSpace X] {x : X} (C : Path x x) (a c : unitInterval) :
+    (((C.subpath 0 a).trans ((C.subpath a c).trans (C.subpath c 1))).cast C.source.symm
+          C.target.symm).Homotopic
+      C := by
+  have h :
+    ((C.subpath 0 a).trans ((C.subpath a c).trans (C.subpath c 1))).Homotopic (C.subpath 0 1) :=
+    ((Path.Homotopic.refl _).hcomp ⟨Path.Homotopy.subpathTransSubpath C a c 1⟩).trans
+      ⟨Path.Homotopy.subpathTransSubpath C 0 a 1⟩
+  have hcast : (C.cast C.source C.target).cast C.source.symm C.target.symm = C := by
+    ext s
+    rfl
+  simpa only [Path.subpath_zero_one, hcast] using h.pathCast C.source.symm C.target.symm
+
+public
+theorem SpecialPeriods.Triangle.basedLoop_subpaths_mo1973_26254 {X : Type*}
+    [TopologicalSpace X] {x b : X} (τ : Path b x) (C : Path x x) (a c : unitInterval) :
+    Path.Homotopic.Quotient.mk ((τ.trans C).trans τ.symm) =
+      Path.Homotopic.Quotient.mk
+        ((τ.trans ((C.subpath 0 a).cast C.source.symm rfl)).trans
+          ((C.subpath a c).trans (((C.subpath c 1).cast rfl C.target.symm).trans τ.symm))) := by
+  have h :
+    Path.Homotopic.Quotient.mk C =
+      Path.Homotopic.Quotient.mk
+        (((C.subpath 0 a).cast C.source.symm rfl).trans
+          ((C.subpath a c).trans ((C.subpath c 1).cast rfl C.target.symm))) := by
+    apply Path.Homotopic.Quotient.eq.mpr
+    exact (three_subpaths_homotopic_mo1973_26253 C a c).symm
+  simp only [Path.Homotopic.Quotient.mk_trans]
+  rw [h]
+  simp only [Path.Homotopic.Quotient.mk_trans, Path.Homotopic.Quotient.trans_assoc]
+
+private def SpecialPeriods.Triangle.positiveOuterMeridian (R : ℝ) (hR : 2 ≤ R) :
+    Path meridianBasepoint meridianBasepoint :=
+  ((outerMeridianTail R hR).trans (outerPositiveCircle R hR)).trans (outerMeridianTail R hR).symm
+
+private theorem
+    SpecialPeriods.Triangle.positiveOuterMeridian_eq_tail_circle_tail (R : ℝ) (hR : 2 ≤ R) :
+    positiveOuterMeridian R hR =
+      ((outerMeridianTail R hR).trans (outerPositiveCircle R hR)).trans
+        (outerMeridianTail R hR).symm :=
+  rfl
+
+private def SpecialPeriods.Triangle.outerLowerStart (R : ℝ) (hR : 2 ≤ R) :
+    Path meridianBasepoint (outerPositiveCircle R hR outerQuarter) :=
+  (outerMeridianTail R hR).trans
+    (((outerPositiveCircle R hR).subpath 0 outerQuarter).cast
+      (outerPositiveCircle R hR).source.symm rfl)
+
+private def SpecialPeriods.Triangle.outerUpperCross (R : ℝ) (hR : 2 ≤ R) :
+    Path (outerPositiveCircle R hR outerQuarter) (outerPositiveCircle R hR outerThreeQuarters) :=
+  (outerPositiveCircle R hR).subpath outerQuarter outerThreeQuarters
+
+private def SpecialPeriods.Triangle.outerLowerFinish (R : ℝ) (hR : 2 ≤ R) :
+    Path (outerPositiveCircle R hR outerThreeQuarters) meridianBasepoint :=
+  (((outerPositiveCircle R hR).subpath outerThreeQuarters 1).cast rfl
+        (outerPositiveCircle R hR).target.symm).trans
+    (outerMeridianTail R hR).symm
+
+private theorem SpecialPeriods.Triangle.positiveOuterMeridian_subdivision (R : ℝ) (hR : 2 ≤ R) :
+    Path.Homotopic.Quotient.mk (positiveOuterMeridian R hR) =
+      Path.Homotopic.Quotient.mk
+        ((outerLowerStart R hR).trans ((outerUpperCross R hR).trans (outerLowerFinish R hR))) :=
+  basedLoop_subpaths_mo1973_26254 (outerMeridianTail R hR) (outerPositiveCircle R hR) outerQuarter
+    outerThreeQuarters
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+private theorem SpecialPeriods.Triangle.outerLowerStart_mem_lower (R : ℝ) (hR : 2 ≤ R)
+    (t : unitInterval) : outerLowerStart R hR t ∈ freeGroupCover.V := by
+  apply SimplyConnectedCover.trans_mem
+  · exact outerMeridianTail_mem_lowerSlitPlane R hR
+  · intro s
+    change (outerPositiveCircle R hR).subpath 0 outerQuarter s ∈ freeGroupCover.V
+    apply
+      FundamentalGroupVanKampen.subpath_mem_of_mem_Icc (outerPositiveCircle R hR)
+        (show (0 : unitInterval) ≤ outerQuarter from bot_le) _ s
+    intro u hu
+    exact outerPositiveCircle_mem_lowerSlitPlane R hR u (Or.inl hu.2)
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+private theorem SpecialPeriods.Triangle.outerUpperCross_mem_upper (R : ℝ) (hR : 2 ≤ R)
+    (t : unitInterval) : outerUpperCross R hR t ∈ freeGroupCover.U := by
+  apply
+    FundamentalGroupVanKampen.subpath_mem_of_mem_Icc (outerPositiveCircle R hR)
+      (show outerQuarter ≤ outerThreeQuarters by norm_num [outerQuarter, outerThreeQuarters]) _ t
+  intro u hu
+  exact outerPositiveCircle_mem_upperSlitPlane R hR u hu.1 hu.2
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+private theorem SpecialPeriods.Triangle.outerLowerFinish_mem_lower (R : ℝ) (hR : 2 ≤ R)
+    (t : unitInterval) : outerLowerFinish R hR t ∈ freeGroupCover.V := by
+  apply SimplyConnectedCover.trans_mem
+  · intro s
+    change (outerPositiveCircle R hR).subpath outerThreeQuarters 1 s ∈ freeGroupCover.V
+    apply
+      FundamentalGroupVanKampen.subpath_mem_of_mem_Icc (outerPositiveCircle R hR)
+        (show outerThreeQuarters ≤ (1 : unitInterval) from le_top) _ s
+    intro u hu
+    exact outerPositiveCircle_mem_lowerSlitPlane R hR u (Or.inr hu.1)
+  · exact fun s => outerMeridianTail_mem_lowerSlitPlane R hR (unitInterval.symm s)
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+private theorem SpecialPeriods.Triangle.outerQuarter_mem_overlap (R : ℝ) (hR : 2 ≤ R) :
+    outerPositiveCircle R hR outerQuarter ∈
+      (freeGroupCover.U : Set TwicePuncturedPlane) ∩ freeGroupCover.V := by
+  change (outerPositiveCircle R hR outerQuarter : ℂ) ∈ upperSlitPlane ∩ lowerSlitPlane
+  rw [slitPlanes_inter]
+  have h := outerPositiveCircle_quarter_re_gt_one R hR
+  exact ⟨ne_of_gt (lt_trans zero_lt_one h), ne_of_gt h⟩
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+private theorem SpecialPeriods.Triangle.outerThreeQuarters_mem_overlap (R : ℝ) (hR : 2 ≤ R) :
+    outerPositiveCircle R hR outerThreeQuarters ∈
+      (freeGroupCover.U : Set TwicePuncturedPlane) ∩ freeGroupCover.V := by
+  change (outerPositiveCircle R hR outerThreeQuarters : ℂ) ∈ upperSlitPlane ∩ lowerSlitPlane
+  rw [slitPlanes_inter]
+  have h := outerPositiveCircle_threeQuarters_re_lt_zero R hR
+  exact ⟨ne_of_lt h, ne_of_lt (lt_trans h zero_lt_one)⟩
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+@[simp]
+private theorem SpecialPeriods.Triangle.freeGroupTransition_outerQuarter (R : ℝ) (hR : 2 ≤ R) :
+    freeGroupTransition (outerPositiveCircle R hR outerQuarter) = FreeGroup.of Bool.true := by
+  have h := outerPositiveCircle_quarter_re_gt_one R hR
+  have hzero : ¬(outerPositiveCircle R hR outerQuarter : ℂ).re < 0 := by linarith
+  have hone : ¬(outerPositiveCircle R hR outerQuarter : ℂ).re < 1 := not_lt.mpr h.le
+  simp only [freeGroupTransition, ite_eq_right hzero, ite_eq_right hone]
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+@[simp]
+private theorem
+    SpecialPeriods.Triangle.freeGroupTransition_outerThreeQuarters (R : ℝ) (hR : 2 ≤ R) :
+    freeGroupTransition (outerPositiveCircle R hR outerThreeQuarters) =
+      (FreeGroup.of Bool.false)⁻¹ := by
+  simp only [freeGroupTransition, ite_eq_left (outerPositiveCircle_threeQuarters_re_lt_zero R hR)]
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+private theorem
+    SpecialPeriods.Triangle.meridianFreeWordHom_positiveOuterMeridian (R : ℝ) (hR : 2 ≤ R) :
+    meridianFreeWordHom (.mk (positiveOuterMeridian R hR)) =
+      FreeGroup.of Bool.false * FreeGroup.of Bool.true := by
+  rw [positiveOuterMeridian_subdivision]
+  rw [meridianFreeWordHom_lower_upper_lower (outerQuarter_mem_overlap R hR)
+      (outerThreeQuarters_mem_overlap R hR) (outerLowerStart R hR) (outerUpperCross R hR)
+      (outerLowerFinish R hR) (outerLowerStart_mem_lower R hR) (outerUpperCross_mem_upper R hR)
+      (outerLowerFinish_mem_lower R hR)]
+  rw [freeGroupTransition_outerThreeQuarters, freeGroupTransition_outerQuarter, inv_inv]
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+private theorem SpecialPeriods.Triangle.positiveOuterMeridian_class_eq (R : ℝ) (hR : 2 ≤ R) :
+    (.mk (positiveOuterMeridian R hR) : FundamentalGroup TwicePuncturedPlane meridianBasepoint) =
+      meridianClass Bool.false * meridianClass Bool.true := by
+  apply twicePuncturedFundamentalGroupFreeEquiv.injective
+  change
+    meridianFreeWordHom (.mk (positiveOuterMeridian R hR)) =
+      meridianFreeWordHom (meridianClass Bool.false * meridianClass Bool.true)
+  rw [meridianFreeWordHom_positiveOuterMeridian, map_mul, meridianFreeWordHom_meridianClass,
+    meridianFreeWordHom_meridianClass]
+
+attribute [local instance] SpecialPeriods.Triangle.discreteFreeGroup in
+private theorem SpecialPeriods.Triangle.outerPositiveCircle_norm_lower_bound (R : ℝ) (hR : 2 ≤ R)
+    (t : unitInterval) : R - 1 / 2 ≤ ‖(outerPositiveCircle R hR t : ℂ)‖ := by
+  have h := norm_sub_le (outerPositiveCircle R hR t : ℂ) (1 / 2 : ℂ)
+  rw [outerPositiveCircle_norm_sub_center] at h
+  norm_num [norm_div] at h
+  change R - 1 / 2 ≤ ‖circleMap (1 / 2 : ℂ) R (-Real.pi / 2 + 2 * Real.pi * (t : ℝ))‖
+  linarith
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/HopfProblem/Uniformization/TriangleUniformizationGluing.lean b/LeanPool/HopfProblem/Uniformization/TriangleUniformizationGluing.lean
new file mode 100644
index 000000000..76cfd7daa
--- /dev/null
+++ b/LeanPool/HopfProblem/Uniformization/TriangleUniformizationGluing.lean
@@ -0,0 +1,1455 @@
+/-
+Copyright (c) 2026 Boris Alexeev. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Boris Alexeev
+-/
+module
+
+public import LeanPool.HopfProblem.Prelude
+public import LeanPool.HopfProblem.Threefold.SpecialPeriods6
+public import LeanPool.HopfProblem.HomologyOfX.ThreefoldGluing1
+import all LeanPool.HopfProblem.Foundations.Core1
+import all LeanPool.HopfProblem.Lattice.Core1
+import all LeanPool.HopfProblem.Foundations.Core2
+import all LeanPool.HopfProblem.PeriodFamily.PeriodPoint
+import all LeanPool.HopfProblem.Foundations.Core3
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods1
+import all LeanPool.HopfProblem.Foundations.TwoAffineCharts
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods2
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods3
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods6
+import all LeanPool.HopfProblem.Foundations.Complex
+import all LeanPool.HopfProblem.Uniformization.SpecialPeriods7
+import all LeanPool.HopfProblem.Threefold.SpecialPeriods6
+import all LeanPool.HopfProblem.HomologyOfX.ThreefoldGluing1
+
+/-!
+# Hopf problem: uniformization · triangle uniformization gluing
+
+Supporting definitions and proofs for this stage of the six-sphere construction.
+-/
+
+
+open Set Function Filter Manifold Topology
+
+open scoped BigOperators CategoryTheory Complex.UnitDisc ComplexConjugate ContDiff ContinuousMap
+  Convolution ENNReal EuclideanSpace Fin.NatCast InnerProductSpace Interval Matrix MatrixGroups
+  Modular NNReal Pointwise RealInnerProductSpace TensorProduct UniformConvergence Uniformity
+  UpperHalfPlane
+
+universe u v
+
+noncomputable section
+
+namespace Mathoverflow1973
+
+local infixr:80 " ≫ₚ " => Path.trans
+
+local notation:100 f " ∣[" k "] " a:100 => SlashAction.map k a f
+
+private theorem TriangleUniformizationGluing.BoundaryMap.upstairsMap_continuousOn_translate
+    (D : TriangleUniformizationGluing.BoundaryMap) (g : SpecialPeriods.TriangleGroup) :
+    ContinuousOn D.upstairsMap
+      (SpecialPeriods.triangleGeometricRepresentation g '' SpecialPeriods.Triangle.fordRegion) := by
+  have hc : Continuous (SpecialPeriods.triangleGeometricRepresentation g⁻¹ : ℍ → ℍ) :=
+    (SpecialPeriods.triangleGeometricRepresentation_holomorphic g⁻¹).continuous
+  have hm :
+    Set.MapsTo (SpecialPeriods.triangleGeometricRepresentation g⁻¹)
+      (SpecialPeriods.triangleGeometricRepresentation g '' SpecialPeriods.Triangle.fordRegion)
+      SpecialPeriods.Triangle.fordRegion := by
+    rintro z ⟨w, hw, rfl⟩
+    rw [map_inv]
+    change
+      (SpecialPeriods.triangleGeometricRepresentation g).symm
+          (SpecialPeriods.triangleGeometricRepresentation g w) ∈
+        _
+    rw [(SpecialPeriods.triangleGeometricRepresentation g).symm_apply_apply w]
+    exact hw
+  exact
+    (D.foldedFordMap_continuousOn.comp hc.continuousOn hm).congr (D.upstairsMap_eqOn_translate g)
+
+private theorem TriangleUniformizationGluing.BoundaryMap.upstairsMap_continuous
+    (D : TriangleUniformizationGluing.BoundaryMap) : Continuous D.upstairsMap := by
+  apply
+    SpecialPeriods.Triangle.fordRegion_translates_locallyFinite.continuous
+      SpecialPeriods.triangle_translates_fordRegion_cover
+  · intro g
+    have h :=
+      (SpecialPeriods.triangleGeometricBiholomorph g).toHomeomorph.isClosedMap
+        SpecialPeriods.Triangle.fordRegion SpecialPeriods.Triangle.fordRegion_closed
+    have he :
+      ((SpecialPeriods.triangleGeometricBiholomorph g).toHomeomorph : ℍ → ℍ) =
+        SpecialPeriods.triangleGeometricRepresentation g :=
+      rfl
+    rwa [he] at h
+  · exact D.upstairsMap_continuousOn_translate
+
+private theorem TriangleUniformizationGluing.BoundaryMap.quotientMap_continuous
+    (D : TriangleUniformizationGluing.BoundaryMap) : Continuous D.quotientMap := by
+  apply SpecialPeriods.triangleOrbitProjection_isOpenQuotientMap.isQuotientMap.continuous_iff.mpr
+  exact D.upstairsMap_continuous
+
+private abbrev TriangleUniformizationGluing.SignedHalfPlaneMap.quotientMap
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap) :
+    SpecialPeriods.TriangleOrbitSpace → ℂ :=
+  D.toBoundaryMap.quotientMap
+
+private abbrev TriangleUniformizationGluing.SignedHalfPlaneMap.upstairsMap
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap) : ℍ → ℂ :=
+  D.toBoundaryMap.upstairsMap
+
+private theorem TriangleUniformizationGluing.SignedHalfPlaneMap.quotientMap_continuous
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap) : Continuous D.quotientMap :=
+  D.toBoundaryMap.quotientMap_continuous
+
+private theorem TriangleUniformizationGluing.SignedHalfPlaneMap.quotientMap_surjective
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap) : Function.Surjective D.quotientMap := by
+  intro w
+  obtain ⟨z, hz, he⟩ := D.foldedFordMap_surjOn (Set.mem_univ w)
+  refine ⟨SpecialPeriods.triangleOrbitProjection z, ?_⟩
+  change D.toBoundaryMap.quotientMap (SpecialPeriods.triangleOrbitProjection z) = w
+  rw [D.toBoundaryMap.quotientMap_projection z hz]
+  exact he
+
+private theorem TriangleUniformizationGluing.SignedHalfPlaneMap.quotientMap_injective
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap) : Function.Injective D.quotientMap := by
+  intro q r he
+  have hfold :
+    D.foldedFordMap (TriangleUniformizationGluing.fordRepresentative q) =
+      D.foldedFordMap (TriangleUniformizationGluing.fordRepresentative r) :=
+    he
+  have hor :=
+    (SpecialPeriods.Triangle.orbitProjection_eq_iff_fordRegion
+          (TriangleUniformizationGluing.fordRepresentative q).property
+          (TriangleUniformizationGluing.fordRepresentative r).property).mpr
+      ((D.foldedFordMap_eq_iff (TriangleUniformizationGluing.fordRepresentative q).property
+            (TriangleUniformizationGluing.fordRepresentative r).property).mp
+        hfold)
+  simpa only [TriangleUniformizationGluing.fordRepresentative_projection] using hor
+
+private theorem TriangleUniformizationGluing.SignedHalfPlaneMap.quotientMap_bijective
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap) : Function.Bijective D.quotientMap :=
+  ⟨D.quotientMap_injective, D.quotientMap_surjective⟩
+
+private def TriangleUniformizationGluing.SignedHalfPlaneMap.quotientEquiv
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap) :
+    SpecialPeriods.TriangleOrbitSpace ≃ ℂ :=
+  Equiv.ofBijective D.quotientMap D.quotientMap_bijective
+
+private theorem TriangleUniformizationGluing.BoundaryMap.quotientMap_preimage_eq_image_ford
+    (D : TriangleUniformizationGluing.BoundaryMap) (K : Set ℂ) :
+    D.quotientMap ⁻¹' K =
+      SpecialPeriods.triangleOrbitProjection ''
+        (SpecialPeriods.Triangle.fordRegion ∩ D.foldedFordMap ⁻¹' K) := by
+  ext q
+  constructor
+  · intro hq
+    exact
+      ⟨TriangleUniformizationGluing.fordRepresentative q,
+        ⟨(TriangleUniformizationGluing.fordRepresentative q).property, hq⟩,
+        TriangleUniformizationGluing.fordRepresentative_projection q⟩
+  · rintro ⟨z, ⟨hz, hzK⟩, rfl⟩
+    change D.quotientMap (SpecialPeriods.triangleOrbitProjection z) ∈ K
+    rw [D.quotientMap_projection z hz]
+    exact hzK
+
+private theorem TriangleUniformizationGluing.BoundaryMap.quotientMap_isProperMap
+    (D : TriangleUniformizationGluing.BoundaryMap)
+    (hlocal : IsProperMap (fun z : SpecialPeriods.Triangle.halfFordRegion => D.toFun z)) :
+    IsProperMap D.quotientMap := by
+  apply isProperMap_iff_isCompact_preimage.mpr
+  refine ⟨D.quotientMap_continuous, ?_⟩
+  intro K hK
+  rw [D.quotientMap_preimage_eq_image_ford K]
+  exact
+    (D.foldedFordMap_compact_preimage hlocal K hK).image
+      SpecialPeriods.triangleOrbitProjection_continuous
+
+private theorem TriangleUniformizationGluing.SignedHalfPlaneMap.quotientMap_isProperMap
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap)
+    (hlocal : IsProperMap (fun z : SpecialPeriods.Triangle.halfFordRegion => D.toFun z)) :
+    IsProperMap D.quotientMap :=
+  D.toBoundaryMap.quotientMap_isProperMap hlocal
+
+private def TriangleUniformizationGluing.SignedHalfPlaneMap.quotientHomeomorph
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap)
+    (hlocal : IsProperMap (fun z : SpecialPeriods.Triangle.halfFordRegion => D.toFun z)) :
+    SpecialPeriods.TriangleOrbitSpace ≃ₜ ℂ :=
+  D.quotientEquiv.toHomeomorphOfContinuousClosed D.quotientMap_continuous
+    (D.quotientMap_isProperMap hlocal).isClosedMap
+
+private theorem TriangleUniformizationGluing.SignedHalfPlaneMap.quotientHomeomorph_projection
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap)
+    (hlocal : IsProperMap (fun z : SpecialPeriods.Triangle.halfFordRegion => D.toFun z)) (z : ℍ)
+    (hz : z ∈ SpecialPeriods.Triangle.fordRegion) :
+    D.quotientHomeomorph hlocal (SpecialPeriods.triangleOrbitProjection z) = D.foldedFordMap z :=
+  D.toBoundaryMap.quotientMap_projection z hz
+
+private def TriangleUniformizationGluing.SignedHalfPlaneMap.compactifiedHomeomorph
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap)
+    (hlocal : IsProperMap (fun z : SpecialPeriods.Triangle.halfFordRegion => D.toFun z)) :
+    SpecialPeriods.TriangleCompactifiedOrbitSpace ≃ₜ RiemannSphere :=
+  (D.quotientHomeomorph hlocal).onePointCongr
+
+@[simp]
+private theorem TriangleUniformizationGluing.SignedHalfPlaneMap.compactifiedHomeomorph_openInclusion
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap)
+    (hlocal : IsProperMap (fun z : SpecialPeriods.Triangle.halfFordRegion => D.toFun z))
+    (q : SpecialPeriods.TriangleOrbitSpace) :
+    D.compactifiedHomeomorph hlocal (SpecialPeriods.triangleOpenInclusion q) =
+      (D.quotientMap q : RiemannSphere) :=
+  rfl
+
+private def SpecialPeriods.Triangle.trianglePlaneUniformizationHomeomorph :
+    SpecialPeriods.TriangleOrbitSpace ≃ₜ ℂ :=
+  RiemannMapping.triangleSignedHalfPlaneMap.quotientHomeomorph
+    RiemannMapping.triangleSignedHalfPlaneMap_isProperMap
+
+private def SpecialPeriods.Triangle.triangleSphereUniformizationHomeomorph :
+    SpecialPeriods.TriangleCompactifiedOrbitSpace ≃ₜ RiemannSphere :=
+  RiemannMapping.triangleSignedHalfPlaneMap.compactifiedHomeomorph
+    RiemannMapping.triangleSignedHalfPlaneMap_isProperMap
+
+@[simp]
+private theorem SpecialPeriods.Triangle.triangleSphereUniformizationHomeomorph_openInclusion
+    (q : SpecialPeriods.TriangleOrbitSpace) :
+    triangleSphereUniformizationHomeomorph (SpecialPeriods.triangleOpenInclusion q) =
+      ((trianglePlaneUniformizationHomeomorph q : ℂ) : RiemannSphere) :=
+  rfl
+
+private theorem SpecialPeriods.Triangle.trianglePlaneUniformizationHomeomorph_projection {z : ℍ}
+    (hz : z ∈ halfFordRegion) :
+    trianglePlaneUniformizationHomeomorph (SpecialPeriods.triangleOrbitProjection z) =
+      RiemannMapping.triangleSignedHalfPlaneMap z := by
+  change
+    RiemannMapping.triangleSignedHalfPlaneMap.quotientHomeomorph
+        RiemannMapping.triangleSignedHalfPlaneMap_isProperMap
+        (SpecialPeriods.triangleOrbitProjection z) =
+      _
+  rw [RiemannMapping.triangleSignedHalfPlaneMap.quotientHomeomorph_projection
+      RiemannMapping.triangleSignedHalfPlaneMap_isProperMap z hz.1]
+  exact RiemannMapping.triangleSignedHalfPlaneMap.toBoundaryMap.foldedFordMap_of_left hz.2
+
+@[simp]
+private theorem SpecialPeriods.Triangle.trianglePlaneUniformizationHomeomorph_centerOne :
+    trianglePlaneUniformizationHomeomorph SpecialPeriods.triangleOrbitCenterOne = 0 := by
+  rw [show
+      SpecialPeriods.triangleOrbitCenterOne = SpecialPeriods.triangleOrbitProjection centerOne
+      from rfl,
+    trianglePlaneUniformizationHomeomorph_projection centerOne_mem_halfFordRegion,
+    RiemannMapping.triangleSignedHalfPlaneMap_centerOne]
+
+@[simp]
+private theorem SpecialPeriods.Triangle.trianglePlaneUniformizationHomeomorph_centerTwo :
+    trianglePlaneUniformizationHomeomorph SpecialPeriods.triangleOrbitCenterTwo = 1 := by
+  rw [show
+      SpecialPeriods.triangleOrbitCenterTwo = SpecialPeriods.triangleOrbitProjection centerTwo
+      from rfl,
+    trianglePlaneUniformizationHomeomorph_projection centerTwo_mem_halfFordRegion,
+    RiemannMapping.triangleSignedHalfPlaneMap_centerTwo]
+
+private theorem SpecialPeriods.Triangle.triangleSphereUniformizationHomeomorph_centerOne :
+    triangleSphereUniformizationHomeomorph
+        (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+      ((0 : ℂ) : RiemannSphere) := by
+  rw [triangleSphereUniformizationHomeomorph_openInclusion,
+    trianglePlaneUniformizationHomeomorph_centerOne]
+
+private theorem SpecialPeriods.Triangle.triangleSphereUniformizationHomeomorph_centerTwo :
+    triangleSphereUniformizationHomeomorph
+        (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+      ((1 : ℂ) : RiemannSphere) := by
+  rw [triangleSphereUniformizationHomeomorph_openInclusion,
+    trianglePlaneUniformizationHomeomorph_centerTwo]
+
+private def TriangleUniformizationGluing.ContinuousRemovable (Ω S : Set ℂ) : Prop :=
+  ∀ V : Set ℂ,
+    IsOpen V →
+      V ⊆ Ω →
+        ∀ f : ℂ → ℂ,
+          ContinuousOn f V → (∀ z ∈ V \ S, DifferentiableAt ℂ f z) → DifferentiableOn ℂ f V
+
+private theorem TriangleUniformizationGluing.continuousRemovable_empty (Ω : Set ℂ) :
+    ContinuousRemovable Ω ∅ := by
+  intro V _ _ f _ hd z hz
+  exact (hd z ⟨hz, Set.notMem_empty z⟩).differentiableWithinAt
+
+private theorem TriangleUniformizationGluing.ContinuousRemovable.mono_domain {Ω Ω' S : Set ℂ}
+    (hS : TriangleUniformizationGluing.ContinuousRemovable Ω S) (hΩ : Ω' ⊆ Ω) :
+    TriangleUniformizationGluing.ContinuousRemovable Ω' S := by
+  intro V hV hVΩ f hf hd
+  exact hS V hV (hVΩ.trans hΩ) f hf hd
+
+private theorem TriangleUniformizationGluing.ContinuousRemovable.mono_set_on {Ω S T : Set ℂ}
+    (hS : TriangleUniformizationGluing.ContinuousRemovable Ω S) (hTS : ∀ z ∈ Ω, z ∈ T → z ∈ S) :
+    TriangleUniformizationGluing.ContinuousRemovable Ω T := by
+  intro V hV hVΩ f hf hd
+  apply hS V hV hVΩ f hf
+  intro z hz
+  exact hd z ⟨hz.1, fun hT => hz.2 (hTS z (hVΩ hz.1) hT)⟩
+
+private theorem TriangleUniformizationGluing.ContinuousRemovable.mono_set {Ω S T : Set ℂ}
+    (hS : TriangleUniformizationGluing.ContinuousRemovable Ω S) (hTS : T ⊆ S) :
+    TriangleUniformizationGluing.ContinuousRemovable Ω T :=
+  hS.mono_set_on (fun _ _ hz => hTS hz)
+
+private theorem TriangleUniformizationGluing.continuousRemovable_realAxis (Ω : Set ℂ) :
+    ContinuousRemovable Ω {z : ℂ | z.im = 0} := by
+  intro V hV _ f hf hd
+  exact
+    SchwarzReflection.differentiableOn_of_continuousOn_off_real hV hf
+      (fun z hz him => hd z ⟨hz, him⟩)
+
+private theorem TriangleUniformizationGluing.ContinuousRemovable.preimage {Ω S : Set ℂ}
+    {e : OpenPartialHomeomorph ℂ ℂ}
+    (hS : TriangleUniformizationGluing.ContinuousRemovable (e '' Ω) S) (hΩ : Ω ⊆ e.source)
+    (he : DifferentiableOn ℂ e e.source) (he' : DifferentiableOn ℂ e.symm e.target) :
+    TriangleUniformizationGluing.ContinuousRemovable Ω (e ⁻¹' S) := by
+  intro V hV hVΩ f hf hd
+  have hVs : V ⊆ e.source := hVΩ.trans hΩ
+  have hW : IsOpen (e '' V) := e.isOpen_image_of_subset_source hV hVs
+  have hWt : e '' V ⊆ e.target := by
+    rintro y ⟨z, hz, rfl⟩
+    exact e.map_source (hVs hz)
+  have hinv : Set.MapsTo e.symm (e '' V) V := by
+    rintro y ⟨z, hz, rfl⟩
+    simpa only [e.left_inv (hVs hz)] using hz
+  have hc : ContinuousOn (f ∘ e.symm) (e '' V) := hf.comp (e.symm.continuousOn.mono hWt) hinv
+  have hd' : ∀ y ∈ (e '' V) \ S, DifferentiableAt ℂ (f ∘ e.symm) y := by
+    intro y hy
+    have hnot : e.symm y ∉ e ⁻¹' S := by
+      change e (e.symm y) ∉ S
+      rw [e.right_inv (hWt hy.1)]
+      exact hy.2
+    exact
+      (hd (e.symm y) ⟨hinv hy.1, hnot⟩).comp y
+        (he'.differentiableAt (e.open_target.mem_nhds (hWt hy.1)))
+  have hdiff := hS (e '' V) hW (Set.image_mono hVΩ) (f ∘ e.symm) hc hd'
+  have hcomp : DifferentiableOn ℂ ((f ∘ e.symm) ∘ e) V :=
+    hdiff.comp (he.mono hVs) (fun z hz => ⟨z, hz, rfl⟩)
+  apply hcomp.congr
+  intro z hz
+  simp only [Function.comp_apply, e.left_inv (hVs hz)]
+
+private theorem TriangleUniformizationGluing.ContinuousRemovable.image {Ω S : Set ℂ}
+    {e : OpenPartialHomeomorph ℂ ℂ} (hS : TriangleUniformizationGluing.ContinuousRemovable Ω S)
+    (hΩ : Ω ⊆ e.source) (hSΩ : S ⊆ Ω) (he : DifferentiableOn ℂ e e.source)
+    (he' : DifferentiableOn ℂ e.symm e.target) :
+    TriangleUniformizationGluing.ContinuousRemovable (e '' Ω) (e '' S) := by
+  have htarget : e '' Ω ⊆ e.target := by
+    rintro y ⟨z, hz, rfl⟩
+    exact e.map_source (hΩ hz)
+  have hinverse : e.symm '' (e '' Ω) = Ω := e.toPartialEquiv.symm_image_image_of_subset_source hΩ
+  have hS' : TriangleUniformizationGluing.ContinuousRemovable (e.symm '' (e '' Ω)) S := by
+    rwa [hinverse]
+  have hp : TriangleUniformizationGluing.ContinuousRemovable (e '' Ω) (e.symm ⁻¹' S) :=
+    hS'.preimage (e := e.symm) htarget he' he
+  apply hp.mono_set_on
+  rintro y _ ⟨z, hz, rfl⟩
+  change e.symm (e z) ∈ S
+  simpa only [e.left_inv (hΩ (hSΩ hz))] using hz
+
+private theorem TriangleUniformizationGluing.continuousRemovable_preimage_realAxis
+    (e : OpenPartialHomeomorph ℂ ℂ) (Ω : Set ℂ) (hΩ : Ω ⊆ e.source)
+    (he : DifferentiableOn ℂ e e.source) (he' : DifferentiableOn ℂ e.symm e.target) :
+    ContinuousRemovable Ω {z : ℂ | (e z).im = 0} :=
+  (continuousRemovable_realAxis (e '' Ω)).preimage hΩ he he'
+
+private def TriangleUniformizationGluing.verticalLineChart_mo1973_19880 (a : ℝ) : ℂ ≃ₜ ℂ
+    where
+  toFun z := Complex.I * (z - (a : ℂ))
+  invFun w := -Complex.I * w + (a : ℂ)
+  left_inv z := by ring_nf; simp
+  right_inv w := by ring_nf; simp
+  continuous_toFun := by fun_prop
+  continuous_invFun := by fun_prop
+
+private theorem TriangleUniformizationGluing.verticalLineChart_differentiable_mo1973_19881
+    (a : ℝ) : Differentiable ℂ (verticalLineChart_mo1973_19880 a) := fun _ =>
+  (differentiableAt_const Complex.I).mul (differentiableAt_id.sub_const _)
+
+private theorem TriangleUniformizationGluing.verticalLineChart_symm_differentiable_mo1973_19882
+    (a : ℝ) : Differentiable ℂ (verticalLineChart_mo1973_19880 a).symm := fun _ =>
+  ((differentiableAt_const (-Complex.I)).mul differentiableAt_id).add_const _
+
+private theorem TriangleUniformizationGluing.continuousRemovable_verticalLine (a : ℝ) :
+    ContinuousRemovable UpperHalfPlane.upperHalfPlaneSet {z : ℂ | z.re = a} := by
+  have h :=
+    continuousRemovable_preimage_realAxis
+      (verticalLineChart_mo1973_19880 a).toOpenPartialHomeomorph UpperHalfPlane.upperHalfPlaneSet
+      (fun z _ => Set.mem_univ z)
+      (verticalLineChart_differentiable_mo1973_19881 a).differentiableOn
+      (verticalLineChart_symm_differentiable_mo1973_19882 a).differentiableOn
+  apply h.mono_set
+  intro z hz
+  change (Complex.I * (z - (a : ℂ))).im = 0
+  simpa using sub_eq_zero.mpr hz
+
+private def TriangleUniformizationGluing.translatedUnitCircleChart_mo1973_19884 (a : ℝ) :
+    OpenPartialHomeomorph ℂ ℂ :=
+  (Homeomorph.subRight ((a : ℂ) + 1)).transOpenPartialHomeomorph
+    SpecialPeriods.Triangle.circleBoundaryChart
+
+private theorem
+  TriangleUniformizationGluing.upperHalfPlane_subset_translatedUnitCircleChart_source_mo1973_19885
+    (a : ℝ) :
+    UpperHalfPlane.upperHalfPlaneSet ⊆ (translatedUnitCircleChart_mo1973_19884 a).source := by
+  intro z hz
+  change z - ((a : ℂ) + 1) + 2 ≠ 0
+  intro he
+  have hi := congrArg Complex.im he
+  simp only [Complex.add_im, Complex.sub_im, Complex.ofReal_im, Complex.one_im, Complex.im_ofNat,
+    add_zero, sub_zero, Complex.zero_im] at hi
+  exact (show 0 < z.im from hz).ne' hi
+
+private theorem
+  TriangleUniformizationGluing.translatedUnitCircleChart_differentiableOn_mo1973_19886 (a : ℝ) :
+    DifferentiableOn ℂ (translatedUnitCircleChart_mo1973_19884 a)
+      (translatedUnitCircleChart_mo1973_19884 a).source := by
+  intro z hz
+  change
+    DifferentiableWithinAt ℂ
+      (fun w : ℂ => SpecialPeriods.Triangle.circleStraighten (w - ((a : ℂ) + 1))) _ z
+  exact
+    ((SpecialPeriods.Triangle.circleStraighten_analyticOnNhd _ hz).differentiableAt.comp z
+        (differentiableAt_id.sub_const _)).differentiableWithinAt
+
+private theorem
+  TriangleUniformizationGluing.translatedUnitCircleChart_symm_differentiableOn_mo1973_19887
+    (a : ℝ) :
+    DifferentiableOn ℂ (translatedUnitCircleChart_mo1973_19884 a).symm
+      (translatedUnitCircleChart_mo1973_19884 a).target := by
+  intro z hz
+  change
+    DifferentiableWithinAt ℂ
+      (fun w : ℂ => SpecialPeriods.Triangle.circleUnstraighten w + ((a : ℂ) + 1)) _ z
+  exact
+    ((SpecialPeriods.Triangle.circleUnstraighten_analyticOnNhd z hz).differentiableAt.add_const
+        _).differentiableWithinAt
+
+private theorem TriangleUniformizationGluing.translatedUnitCircleChart_im_eq_zero_iff_mo1973_19888
+    (a : ℝ) {z : ℂ} (hz : z ∈ UpperHalfPlane.upperHalfPlaneSet) :
+    (translatedUnitCircleChart_mo1973_19884 a z).im = 0 ↔ ‖z - (a : ℂ)‖ = 1 := by
+  change (SpecialPeriods.Triangle.circleStraighten (z - ((a : ℂ) + 1))).im = 0 ↔ _
+  rw [SpecialPeriods.Triangle.circleStraighten_im_eq_zero_iff (z := z - ((a : ℂ) + 1))
+      (upperHalfPlane_subset_translatedUnitCircleChart_source_mo1973_19885 a hz)]
+  rw [show z - ((a : ℂ) + 1) + 1 = z - (a : ℂ) by ring]
+
+private theorem TriangleUniformizationGluing.continuousRemovable_unitCircle (a : ℝ) :
+    ContinuousRemovable UpperHalfPlane.upperHalfPlaneSet {z : ℂ | ‖z - (a : ℂ)‖ = 1} := by
+  have h :=
+    continuousRemovable_preimage_realAxis (translatedUnitCircleChart_mo1973_19884 a)
+      UpperHalfPlane.upperHalfPlaneSet
+      (upperHalfPlane_subset_translatedUnitCircleChart_source_mo1973_19885 a)
+      (translatedUnitCircleChart_differentiableOn_mo1973_19886 a)
+      (translatedUnitCircleChart_symm_differentiableOn_mo1973_19887 a)
+  exact
+    h.mono_set_on
+      (fun z hz hnorm => (translatedUnitCircleChart_im_eq_zero_iff_mo1973_19888 a hz).mpr hnorm)
+
+private def TriangleUniformizationGluing.triangleAmbientMap (g : SpecialPeriods.TriangleGroup) :
+    OpenPartialHomeomorph ℂ ℂ :=
+  (UpperHalfPlane.ofComplex.trans
+        (SpecialPeriods.triangleGeometricBiholomorph
+            g).toHomeomorph.toOpenPartialHomeomorph).trans
+    UpperHalfPlane.ofComplex.symm
+
+@[simp]
+private theorem TriangleUniformizationGluing.triangleAmbientMap_source
+    (g : SpecialPeriods.TriangleGroup) :
+    (triangleAmbientMap g).source = UpperHalfPlane.upperHalfPlaneSet := by
+  simp [triangleAmbientMap, UpperHalfPlane.ofComplex, UpperHalfPlane.range_coe]
+
+@[simp]
+private theorem TriangleUniformizationGluing.triangleAmbientMap_target
+    (g : SpecialPeriods.TriangleGroup) :
+    (triangleAmbientMap g).target = UpperHalfPlane.upperHalfPlaneSet := by
+  simp [triangleAmbientMap, UpperHalfPlane.ofComplex, UpperHalfPlane.range_coe]
+
+private theorem
+    TriangleUniformizationGluing.triangleAmbientMap_apply (g : SpecialPeriods.TriangleGroup)
+    (z : ℂ) :
+    triangleAmbientMap g z =
+      (SpecialPeriods.triangleGeometricRepresentation g (UpperHalfPlane.ofComplex z) : ℂ) :=
+  rfl
+
+@[simp]
+private theorem TriangleUniformizationGluing.triangleAmbientMap_apply_coe
+    (g : SpecialPeriods.TriangleGroup) (z : ℍ) :
+    triangleAmbientMap g (z : ℂ) = (SpecialPeriods.triangleGeometricRepresentation g z : ℂ) := by
+  rw [triangleAmbientMap_apply, UpperHalfPlane.ofComplex_apply]
+
+private theorem TriangleUniformizationGluing.triangleAmbientMap_symm_apply
+    (g : SpecialPeriods.TriangleGroup) (z : ℂ) :
+    (triangleAmbientMap g).symm z =
+      (SpecialPeriods.triangleGeometricRepresentation g⁻¹ (UpperHalfPlane.ofComplex z) : ℂ) := by
+  rw [map_inv]
+  rfl
+
+@[simp]
+private theorem
+    TriangleUniformizationGluing.triangleAmbientMap_symm (g : SpecialPeriods.TriangleGroup) :
+    (triangleAmbientMap g).symm = triangleAmbientMap g⁻¹ := by
+  apply OpenPartialHomeomorph.ext
+  · intro z
+    rw [triangleAmbientMap_symm_apply, triangleAmbientMap_apply]
+  · intro z
+    simp only [OpenPartialHomeomorph.symm_symm, triangleAmbientMap_apply,
+      triangleAmbientMap_symm_apply, inv_inv]
+  · simp only [OpenPartialHomeomorph.symm_source, triangleAmbientMap_source,
+      triangleAmbientMap_target]
+
+private theorem TriangleUniformizationGluing.triangleAmbientMap_differentiableOn
+    (g : SpecialPeriods.TriangleGroup) :
+    DifferentiableOn ℂ (triangleAmbientMap g) (triangleAmbientMap g).source := by
+  rw [triangleAmbientMap_source]
+  exact
+    UpperHalfPlane.mdifferentiable_iff.mp
+      (UpperHalfPlane.mdifferentiable_coe.comp
+        ((SpecialPeriods.triangleGeometricRepresentation_holomorphic g).mdifferentiable
+          (by simp)))
+
+private theorem TriangleUniformizationGluing.triangleAmbientMap_symm_differentiableOn
+    (g : SpecialPeriods.TriangleGroup) :
+    DifferentiableOn ℂ (triangleAmbientMap g).symm (triangleAmbientMap g).target := by
+  simpa only [triangleAmbientMap_source, triangleAmbientMap_target, triangleAmbientMap_symm] using
+    triangleAmbientMap_differentiableOn g⁻¹
+
+private theorem TriangleUniformizationGluing.triangleAmbientMap_image_upperHalfPlaneSet
+    (g : SpecialPeriods.TriangleGroup) :
+    triangleAmbientMap g '' UpperHalfPlane.upperHalfPlaneSet = UpperHalfPlane.upperHalfPlaneSet :=
+  by
+  simpa only [triangleAmbientMap_source, triangleAmbientMap_target] using
+    (triangleAmbientMap g).image_source_eq_target
+
+private theorem TriangleUniformizationGluing.triangleAmbientMap_image_coe
+    (g : SpecialPeriods.TriangleGroup) (S : Set ℍ) :
+    triangleAmbientMap g '' (((↑) : ℍ → ℂ) '' S) =
+      ((↑) : ℍ → ℂ) '' (SpecialPeriods.triangleGeometricRepresentation g '' S) := by
+  rw [Set.image_image, Set.image_image]
+  apply Set.image_congr
+  intro z _
+  exact triangleAmbientMap_apply_coe g z
+
+private def SpecialPeriods.Triangle.halfEdgeCarrier : Fin 3 → Set ℍ :=
+  ![{z | z.re = stripLeft}, {z | z.re = -(1 / 2)}, {z | ‖(z : ℂ) + 1‖ = 1}]
+
+private def SpecialPeriods.Triangle.halfFordEdge (k : Fin 3) : Set ℍ :=
+  halfFordRegion ∩ halfEdgeCarrier k
+
+private theorem SpecialPeriods.Triangle.halfEdgeCarrier_isClosed (k : Fin 3) :
+    IsClosed (halfEdgeCarrier k) := by
+  fin_cases k
+  · exact isClosed_eq UpperHalfPlane.continuous_re continuous_const
+  · exact isClosed_eq UpperHalfPlane.continuous_re continuous_const
+  · exact isClosed_eq (UpperHalfPlane.continuous_coe.add continuous_const).norm continuous_const
+
+private theorem
+    SpecialPeriods.Triangle.halfFordEdge_isClosed (k : Fin 3) : IsClosed (halfFordEdge k) :=
+  halfFordRegion_isClosed.inter (halfEdgeCarrier_isClosed k)
+
+private theorem SpecialPeriods.Triangle.halfFordEdge_subset_region (k : Fin 3) :
+    halfFordEdge k ⊆ halfFordRegion :=
+  Set.inter_subset_left
+
+private theorem SpecialPeriods.Triangle.halfFordEdge_subset_boundary (k : Fin 3) :
+    halfFordEdge k ⊆ halfFordRegion \ halfFordInterior := by
+  intro z hz
+  refine ⟨hz.1, ?_⟩
+  intro hi
+  have hc := hz.2
+  fin_cases k
+  · change z.re = stripLeft at hc
+    exact (ne_of_gt hi.1.1) hc
+  · change z.re = -(1 / 2) at hc
+    exact (ne_of_lt hi.2) hc
+  · change ‖(z : ℂ) + 1‖ = 1 at hc
+    exact (ne_of_gt hi.1.2.2.1) hc
+
+private theorem SpecialPeriods.Triangle.halfFordEdges_eq_boundary :
+    (⋃ k : Fin 3, halfFordEdge k) = halfFordRegion \ halfFordInterior := by
+  apply Set.Subset.antisymm
+  · exact Set.iUnion_subset halfFordEdge_subset_boundary
+  · rintro z ⟨hz, hnot⟩
+    by_cases hl : z.re = stripLeft
+    · exact Set.mem_iUnion.mpr ⟨0, hz, hl⟩
+    by_cases hr : z.re = -(1 / 2)
+    · exact Set.mem_iUnion.mpr ⟨1, hz, hr⟩
+    by_cases hn : ‖(z : ℂ) + 1‖ = 1
+    · exact Set.mem_iUnion.mpr ⟨2, hz, hn⟩
+    have hl' : stripLeft < z.re := lt_of_le_of_ne hz.1.1 (Ne.symm hl)
+    have hr' : z.re < -(1 / 2) := lt_of_le_of_ne hz.2 hr
+    have hn' : 1 < ‖(z : ℂ) + 1‖ := lt_of_le_of_ne hz.1.2.2.1 (Ne.symm hn)
+    apply (hnot ?_).elim
+    refine ⟨⟨hl', ?_, hn', one_lt_norm_of_re_lt_neg_half z hr' hn'⟩, hr'⟩
+    linarith [stripRight_pos]
+
+private def SpecialPeriods.Triangle.halfTriangleEdge (i : SpecialPeriods.TriangleGroup × Bool)
+    (k : Fin 3) : Set ℍ :=
+  halfTriangleMap i '' halfFordEdge k
+
+private abbrev SpecialPeriods.Triangle.TriangleEdgeIndex :=
+  (SpecialPeriods.TriangleGroup × Bool) × Fin 3
+
+private theorem
+    SpecialPeriods.Triangle.halfTriangleEdge_eq (i : SpecialPeriods.TriangleGroup × Bool)
+    (k : Fin 3) :
+    halfTriangleEdge i k =
+      SpecialPeriods.triangleGeometricRepresentation i.1 '' (halfFold i.2 '' halfFordEdge k) := by
+  rw [Set.image_image]
+  rfl
+
+private theorem SpecialPeriods.Triangle.halfTriangleEdge_isClosed
+    (i : SpecialPeriods.TriangleGroup × Bool) (k : Fin 3) : IsClosed (halfTriangleEdge i k) :=
+  (halfTriangleMap i).isClosedMap _ (halfFordEdge_isClosed k)
+
+private theorem SpecialPeriods.Triangle.halfTriangleEdge_subset_tile
+    (i : SpecialPeriods.TriangleGroup × Bool) (k : Fin 3) :
+    halfTriangleEdge i k ⊆ halfTriangleTile i :=
+  Set.image_mono (halfFordEdge_subset_region k)
+
+private theorem SpecialPeriods.Triangle.halfTriangleEdges_eq_boundary
+    (i : SpecialPeriods.TriangleGroup × Bool) :
+    (⋃ k : Fin 3, halfTriangleEdge i k) = halfTriangleTile i \ halfTriangleOpenTile i := by
+  unfold halfTriangleEdge halfTriangleTile halfTriangleOpenTile
+  rw [← Set.image_iUnion, halfFordEdges_eq_boundary,
+    Set.image_sdiff (halfTriangleMap i).injective]
+
+private theorem SpecialPeriods.Triangle.triangleEdges_cover_openTile_complement :
+    (⋃ i : SpecialPeriods.TriangleGroup × Bool, halfTriangleOpenTile i)ᶜ ⊆
+      ⋃ j : TriangleEdgeIndex, halfTriangleEdge j.1 j.2 := by
+  intro z hz
+  have hcover : z ∈ ⋃ i : SpecialPeriods.TriangleGroup × Bool, halfTriangleTile i := by
+    rw [halfTriangleTiles_cover]
+    exact Set.mem_univ z
+  obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hcover
+  have hb : z ∈ ⋃ k : Fin 3, halfTriangleEdge i k := by
+    rw [halfTriangleEdges_eq_boundary]
+    exact ⟨hi, fun h => hz (Set.mem_iUnion.mpr ⟨i, h⟩)⟩
+  obtain ⟨k, hk⟩ := Set.mem_iUnion.mp hb
+  exact Set.mem_iUnion.mpr ⟨(i, k), hk⟩
+
+private theorem SpecialPeriods.Triangle.halfTriangleEdges_locallyFinite :
+    LocallyFinite (fun j : TriangleEdgeIndex => halfTriangleEdge j.1 j.2) := by
+  intro z
+  obtain ⟨U, hU, hfin⟩ := halfTriangleTiles_locallyFinite z
+  refine ⟨U, hU, (hfin.prod (Set.finite_univ : (Set.univ : Set (Fin 3)).Finite)).subset ?_⟩
+  rintro j ⟨w, hw, hwU⟩
+  exact ⟨⟨w, halfTriangleEdge_subset_tile j.1 j.2 hw, hwU⟩, Set.mem_univ _⟩
+
+private def SpecialPeriods.Triangle.triangleEdgeComplex (j : TriangleEdgeIndex) : Set ℂ :=
+  ((↑) : ℍ → ℂ) '' halfTriangleEdge j.1 j.2
+
+private theorem SpecialPeriods.Triangle.triangleEdgeComplex_relative_compl_isOpen
+    (j : TriangleEdgeIndex) : IsOpen (UpperHalfPlane.upperHalfPlaneSet \ triangleEdgeComplex j) :=
+  by
+  have h :=
+    UpperHalfPlane.isOpenEmbedding_coe.isOpenMap (halfTriangleEdge j.1 j.2)ᶜ
+      (halfTriangleEdge_isClosed j.1 j.2).isOpen_compl
+  simpa only [triangleEdgeComplex,
+    Set.image_compl_eq_range_sdiff_image UpperHalfPlane.coe_injective,
+    UpperHalfPlane.range_coe] using h
+
+private theorem SpecialPeriods.Triangle.triangleEdgeComplex_locallyFinite :
+    LocallyFinite
+      (fun j : TriangleEdgeIndex =>
+        ((↑) : UpperHalfPlane.upperHalfPlaneSet → ℂ) ⁻¹' triangleEdgeComplex j) := by
+  let g : UpperHalfPlane.upperHalfPlaneSet → ℍ := fun z => ⟨z.1, z.2⟩
+  have hg : Continuous g :=
+    UpperHalfPlane.isEmbedding_coe.continuous_iff.mpr continuous_subtype_val
+  have hpre :
+    ∀ j : TriangleEdgeIndex,
+      ((↑) : UpperHalfPlane.upperHalfPlaneSet → ℂ) ⁻¹' triangleEdgeComplex j =
+        g ⁻¹' halfTriangleEdge j.1 j.2 := by
+    intro j
+    ext z
+    simp only [triangleEdgeComplex, Set.mem_preimage, Set.mem_image]
+    constructor
+    · rintro ⟨w, hw, hwz⟩
+      have hwg : w = g z := UpperHalfPlane.coe_injective hwz
+      simpa only [hwg] using hw
+    · intro h
+      exact ⟨g z, h, rfl⟩
+  simp_rw [hpre]
+  exact halfTriangleEdges_locallyFinite.preimage_continuous hg
+
+private theorem SpecialPeriods.Triangle.triangleEdgeComplex_cover_openTile_complement :
+    UpperHalfPlane.upperHalfPlaneSet \
+        (⋃ i : SpecialPeriods.TriangleGroup × Bool, ((↑) : ℍ → ℂ) '' halfTriangleOpenTile i) ⊆
+      ⋃ j : TriangleEdgeIndex, triangleEdgeComplex j := by
+  rintro z ⟨hz, hnot⟩
+  let w : ℍ := ⟨z, hz⟩
+  have hw : w ∈ (⋃ i : SpecialPeriods.TriangleGroup × Bool, halfTriangleOpenTile i)ᶜ := by
+    intro hi
+    obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hi
+    exact hnot (Set.mem_iUnion.mpr ⟨i, w, hi, rfl⟩)
+  obtain ⟨j, hj⟩ := Set.mem_iUnion.mp (triangleEdges_cover_openTile_complement hw)
+  exact Set.mem_iUnion.mpr ⟨j, w, hj, rfl⟩
+
+private def SpecialPeriods.Triangle.foldedEdgeComplexCarrier (b : Bool) : Fin 3 → Set ℂ :=
+  if b then ![{z | z.re = stripRight}, {z | z.re = -(1 / 2)}, {z | ‖z‖ = 1}]
+  else ![{z | z.re = stripLeft}, {z | z.re = -(1 / 2)}, {z | ‖z + 1‖ = 1}]
+
+private theorem SpecialPeriods.Triangle.foldedEdgeComplex_subset_carrier (b : Bool) (k : Fin 3) :
+    ((↑) : ℍ → ℂ) '' (halfFold b '' halfFordEdge k) ⊆ foldedEdgeComplexCarrier b k := by
+  rintro z ⟨w, ⟨u, hu, rfl⟩, rfl⟩
+  have hc := hu.2
+  cases b <;> fin_cases k
+  · exact hc
+  · exact hc
+  · exact hc
+  · change u.re = stripLeft at hc
+    change (rightReflection u).re = stripRight
+    rw [rightReflection_re, hc]
+    linarith [stripLeft_add_stripRight]
+  · change u.re = -(1 / 2) at hc
+    change (rightReflection u).re = -(1 / 2)
+    rw [rightReflection_re, hc]
+    norm_num
+  · change ‖(u : ℂ) + 1‖ = 1 at hc
+    change ‖(rightReflection u : ℂ)‖ = 1
+    rw [rightReflection_norm]
+    exact hc
+
+private theorem TriangleUniformizationGluing.ContinuousRemovable.union {Ω S T : Set ℂ}
+    (hS : TriangleUniformizationGluing.ContinuousRemovable Ω S)
+    (hT : TriangleUniformizationGluing.ContinuousRemovable Ω T) (hclosedT : IsOpen (Ω \ T)) :
+    TriangleUniformizationGluing.ContinuousRemovable Ω (S ∪ T) := by
+  intro V hV hVΩ f hf hd
+  have hVT : IsOpen (V \ T) := by
+    have he : V \ T = V ∩ (Ω \ T) := by
+      ext z
+      constructor
+      · intro hz
+        exact ⟨hz.1, hVΩ hz.1, hz.2⟩
+      · intro hz
+        exact ⟨hz.1, hz.2.2⟩
+    rw [he]
+    exact hV.inter hclosedT
+  have hdiff : DifferentiableOn ℂ f (V \ T) := by
+    apply hS (V \ T) hVT (Set.sdiff_subset.trans hVΩ) f (hf.mono Set.sdiff_subset)
+    intro z hz
+    exact hd z ⟨hz.1.1, fun hu => hu.elim hz.2 hz.1.2⟩
+  apply hT V hV hVΩ f hf
+  intro z hz
+  exact hdiff.differentiableAt (hVT.mem_nhds hz)
+
+private theorem
+    TriangleUniformizationGluing.continuousRemovable_biUnion_finset {ι : Type*} {Ω : Set ℂ}
+    {S : ι → Set ℂ} (t : Finset ι) (hS : ∀ i ∈ t, ContinuousRemovable Ω (S i))
+    (hclosed : ∀ i ∈ t, IsOpen (Ω \ S i)) : ContinuousRemovable Ω (⋃ i ∈ t, S i) := by
+  classical
+  revert hS hclosed
+  induction t using Finset.induction_on with
+  | empty =>
+    intro _ _
+    simpa using continuousRemovable_empty Ω
+  | @insert a t hat ih =>
+    intro hS hclosed
+    have ht : ContinuousRemovable Ω (⋃ i ∈ t, S i) :=
+      ih (fun i hi => hS i (Finset.mem_insert_of_mem hi))
+        (fun i hi => hclosed i (Finset.mem_insert_of_mem hi))
+    simpa only [Finset.mem_insert, Set.iUnion_iUnion_eq_or_left, Set.union_comm] using
+      ht.union (hS a (Finset.mem_insert_self a t)) (hclosed a (Finset.mem_insert_self a t))
+
+private theorem TriangleUniformizationGluing.continuousRemovable_of_locally {Ω S : Set ℂ}
+    (hlocal : ∀ z ∈ Ω, ∃ W : Set ℂ, IsOpen W ∧ z ∈ W ∧ ContinuousRemovable W S) :
+    ContinuousRemovable Ω S := by
+  intro V hV hVΩ f hf hd z hz
+  obtain ⟨W, hW, hzW, hrem⟩ := hlocal z (hVΩ hz)
+  have hVW : IsOpen (V ∩ W) := hV.inter hW
+  have hdiff : DifferentiableOn ℂ f (V ∩ W) := by
+    apply hrem (V ∩ W) hVW Set.inter_subset_right f (hf.mono Set.inter_subset_left)
+    intro x hx
+    exact hd x ⟨hx.1.1, hx.2⟩
+  exact (hdiff.differentiableAt (hVW.mem_nhds ⟨hz, hzW⟩)).differentiableWithinAt
+
+private theorem TriangleUniformizationGluing.continuousRemovable_iUnion_of_locallyFinite {ι : Type*}
+    {Ω : Set ℂ} (hΩ : IsOpen Ω) (S : ι → Set ℂ) (hS : ∀ i, ContinuousRemovable Ω (S i))
+    (hclosed : ∀ i, IsOpen (Ω \ S i))
+    (hloc : LocallyFinite (fun i => (Subtype.val : Ω → ℂ) ⁻¹' S i)) :
+    ContinuousRemovable Ω (⋃ i, S i) := by
+  classical
+  apply continuousRemovable_of_locally
+  intro z hz
+  obtain ⟨N, hN, hfin⟩ := hloc ⟨z, hz⟩
+  obtain ⟨W, hWN, hW, hzW⟩ := mem_nhds_iff.mp hN
+  let t := hfin.toFinset
+  have hWΩ : (Subtype.val '' W : Set ℂ) ⊆ Ω := by
+    rintro x ⟨w, hw, rfl⟩
+    exact w.property
+  have hrem : ContinuousRemovable Ω (⋃ i ∈ t, S i) :=
+    continuousRemovable_biUnion_finset t (fun i _ => hS i) (fun i _ => hclosed i)
+  refine ⟨Subtype.val '' W, hΩ.isOpenMap_subtype_val _ hW, Set.mem_image_of_mem _ hzW, ?_⟩
+  apply (hrem.mono_domain hWΩ).mono_set_on
+  rintro x ⟨w, hw, rfl⟩ hx
+  obtain ⟨i, hi⟩ := Set.mem_iUnion.mp hx
+  apply Set.mem_iUnion₂.mpr
+  refine ⟨i, ?_, hi⟩
+  exact hfin.mem_toFinset.mpr ⟨w, hi, hWN hw⟩
+
+private theorem TriangleUniformizationGluing.continuousRemovable_foldedEdgeComplexCarrier (b : Bool)
+    (k : Fin 3) :
+    ContinuousRemovable UpperHalfPlane.upperHalfPlaneSet
+      (SpecialPeriods.Triangle.foldedEdgeComplexCarrier b k) := by
+  cases b <;> fin_cases k
+  · exact continuousRemovable_verticalLine SpecialPeriods.Triangle.stripLeft
+  · exact continuousRemovable_verticalLine (-(1 / 2))
+  · change ContinuousRemovable UpperHalfPlane.upperHalfPlaneSet {z : ℂ | ‖z + 1‖ = 1}
+    simpa only [Complex.ofReal_neg, Complex.ofReal_one, sub_neg_eq_add] using
+      continuousRemovable_unitCircle (-1)
+  · exact continuousRemovable_verticalLine SpecialPeriods.Triangle.stripRight
+  · exact continuousRemovable_verticalLine (-(1 / 2))
+  · change ContinuousRemovable UpperHalfPlane.upperHalfPlaneSet {z : ℂ | ‖z‖ = 1}
+    simpa only [Complex.ofReal_zero, sub_zero] using continuousRemovable_unitCircle 0
+
+private theorem
+    TriangleUniformizationGluing.continuousRemovable_foldedHalfEdge (b : Bool) (k : Fin 3) :
+    ContinuousRemovable UpperHalfPlane.upperHalfPlaneSet
+      (((↑) : ℍ → ℂ) ''
+        (SpecialPeriods.Triangle.halfFold b '' SpecialPeriods.Triangle.halfFordEdge k)) :=
+  (continuousRemovable_foldedEdgeComplexCarrier b k).mono_set
+    (SpecialPeriods.Triangle.foldedEdgeComplex_subset_carrier b k)
+
+private theorem TriangleUniformizationGluing.continuousRemovable_triangleEdgeComplex
+    (j : SpecialPeriods.Triangle.TriangleEdgeIndex) :
+    ContinuousRemovable UpperHalfPlane.upperHalfPlaneSet
+      (SpecialPeriods.Triangle.triangleEdgeComplex j) := by
+  rcases j with ⟨⟨g, b⟩, k⟩
+  have hsource : UpperHalfPlane.upperHalfPlaneSet ⊆ (triangleAmbientMap g).source := by
+    rw [triangleAmbientMap_source]
+  have hsubset :
+    ((↑) : ℍ → ℂ) ''
+        (SpecialPeriods.Triangle.halfFold b '' SpecialPeriods.Triangle.halfFordEdge k) ⊆
+      UpperHalfPlane.upperHalfPlaneSet := by
+    rintro z ⟨w, _, rfl⟩
+    exact w.im_pos
+  have h :=
+    (continuousRemovable_foldedHalfEdge b k).image (e := triangleAmbientMap g) hsource hsubset
+      (triangleAmbientMap_differentiableOn g) (triangleAmbientMap_symm_differentiableOn g)
+  simpa only [triangleAmbientMap_image_upperHalfPlaneSet, triangleAmbientMap_image_coe,
+    SpecialPeriods.Triangle.triangleEdgeComplex,
+    SpecialPeriods.Triangle.halfTriangleEdge_eq] using h
+
+private theorem TriangleUniformizationGluing.continuousRemovable_triangleEdges :
+    ContinuousRemovable UpperHalfPlane.upperHalfPlaneSet
+      (⋃ j : SpecialPeriods.Triangle.TriangleEdgeIndex,
+        SpecialPeriods.Triangle.triangleEdgeComplex j) :=
+  continuousRemovable_iUnion_of_locallyFinite UpperHalfPlane.isOpen_upperHalfPlaneSet
+    SpecialPeriods.Triangle.triangleEdgeComplex continuousRemovable_triangleEdgeComplex
+    SpecialPeriods.Triangle.triangleEdgeComplex_relative_compl_isOpen
+    SpecialPeriods.Triangle.triangleEdgeComplex_locallyFinite
+
+private theorem TriangleUniformizationGluing.differentiableOn_of_continuousOn_halfTriangleOpenTiles
+    {f : ℂ → ℂ} (hf : ContinuousOn f UpperHalfPlane.upperHalfPlaneSet)
+    (hd :
+      ∀ i : SpecialPeriods.TriangleGroup × Bool,
+        DifferentiableOn ℂ f (((↑) : ℍ → ℂ) '' SpecialPeriods.Triangle.halfTriangleOpenTile i)) :
+    DifferentiableOn ℂ f UpperHalfPlane.upperHalfPlaneSet := by
+  apply
+    continuousRemovable_triangleEdges UpperHalfPlane.upperHalfPlaneSet
+      UpperHalfPlane.isOpen_upperHalfPlaneSet Set.Subset.rfl f hf
+  intro z hz
+  have htile :
+    z ∈
+      ⋃ i : SpecialPeriods.TriangleGroup × Bool,
+        ((↑) : ℍ → ℂ) '' SpecialPeriods.Triangle.halfTriangleOpenTile i := by
+    by_contra hnot
+    exact
+      hz.2 (SpecialPeriods.Triangle.triangleEdgeComplex_cover_openTile_complement ⟨hz.1, hnot⟩)
+  obtain ⟨i, hi⟩ := Set.mem_iUnion.mp htile
+  exact
+    (hd i).differentiableAt
+      ((UpperHalfPlane.isOpenEmbedding_coe.isOpenMap _
+            (SpecialPeriods.Triangle.halfTriangleOpenTile_isOpen i)).mem_nhds
+        hi)
+
+private theorem
+    TriangleUniformizationGluing.contMDiff_of_continuous_of_halfTriangleOpenTiles {f : ℍ → ℂ}
+    (hf : Continuous f)
+    (hd :
+      ∀ i : SpecialPeriods.TriangleGroup × Bool,
+        ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω f (SpecialPeriods.Triangle.halfTriangleOpenTile i)) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω f := by
+  have hfc : ContinuousOn (f ∘ UpperHalfPlane.ofComplex) UpperHalfPlane.upperHalfPlaneSet := by
+    intro z hz
+    exact
+      (hf.continuousAt.comp
+          (UpperHalfPlane.contMDiffAt_ofComplex (n := ω) hz).continuousAt).continuousWithinAt
+  have hfd :
+    ∀ i : SpecialPeriods.TriangleGroup × Bool,
+      DifferentiableOn ℂ (f ∘ UpperHalfPlane.ofComplex)
+        (((↑) : ℍ → ℂ) '' SpecialPeriods.Triangle.halfTriangleOpenTile i) := by
+    intro i z hz
+    rcases hz with ⟨w, hw, rfl⟩
+    have ht : ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω f w :=
+      (hd i w hw).contMDiffAt
+        ((SpecialPeriods.Triangle.halfTriangleOpenTile_isOpen i).mem_nhds hw)
+    exact
+      ((UpperHalfPlane.contMDiffAt_iff.mp ht).differentiableAt (by simp)).differentiableWithinAt
+  have hglobal := differentiableOn_of_continuousOn_halfTriangleOpenTiles hfc hfd
+  intro z
+  apply UpperHalfPlane.contMDiffAt_iff.mpr
+  exact (hglobal.analyticOnNhd UpperHalfPlane.isOpen_upperHalfPlaneSet z z.im_pos).contDiffAt
+
+private theorem TriangleUniformizationGluing.differentiableAt_conj_affine_reflection_mo1973_19938
+    {f : ℂ → ℂ} {z : ℂ} (hf : DifferentiableAt ℂ f (-1 - conj z)) :
+    DifferentiableAt ℂ (fun w => conj (f (-1 - conj w))) z := by
+  have hc : DifferentiableAt ℂ (conj ∘ f ∘ conj) (-1 - z) := by
+    simpa only [map_sub, map_neg, map_one, Complex.conj_conj] using hf.conj_conj
+  have ha : DifferentiableAt ℂ (fun w : ℂ => -1 - w) z :=
+    (differentiableAt_const (-1 : ℂ)).sub differentiableAt_id
+  simpa only [Function.comp_def, map_sub, map_neg, map_one] using hc.comp z ha
+
+private theorem
+    TriangleUniformizationGluing.contMDiffOn_conj_rightReflection {f : ℍ → ℂ} {S : Set ℍ}
+    (hS : IsOpen S) (hf : ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω f S) :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (fun z => conj (f (SpecialPeriods.Triangle.rightReflection z)))
+      (SpecialPeriods.Triangle.rightReflection '' S) := by
+  let F : ℂ → ℂ := fun z => conj (f (UpperHalfPlane.ofComplex (-1 - conj z)))
+  have hU : IsOpen (((↑) : ℍ → ℂ) '' (SpecialPeriods.Triangle.rightReflection '' S)) :=
+    UpperHalfPlane.isOpenEmbedding_coe.isOpenMap _
+      (SpecialPeriods.Triangle.rightReflection.isOpenMap _ hS)
+  have hF :
+    DifferentiableOn ℂ F (((↑) : ℍ → ℂ) '' (SpecialPeriods.Triangle.rightReflection '' S)) := by
+    rintro z ⟨w, ⟨x, hx, rfl⟩, rfl⟩
+    have hfx : ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω f x := (hf x hx).contMDiffAt (hS.mem_nhds hx)
+    have hfd : DifferentiableAt ℂ (f ∘ UpperHalfPlane.ofComplex) (x : ℂ) :=
+      (UpperHalfPlane.contMDiffAt_iff.mp hfx).differentiableAt (by simp)
+    have hr : (-1 : ℂ) - conj (SpecialPeriods.Triangle.rightReflection x : ℂ) = (x : ℂ) :=
+      (SpecialPeriods.Triangle.rightReflection_coe
+            (SpecialPeriods.Triangle.rightReflection x)).symm.trans
+        (congrArg ((↑) : ℍ → ℂ) (SpecialPeriods.Triangle.rightReflection_involutive x))
+    apply DifferentiableAt.differentiableWithinAt
+    apply differentiableAt_conj_affine_reflection_mo1973_19938 (f := f ∘ UpperHalfPlane.ofComplex)
+    rw [hr]
+    exact hfd
+  have hFM :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω F (((↑) : ℍ → ℂ) '' (SpecialPeriods.Triangle.rightReflection '' S)) :=
+    contMDiffOn_iff_contDiffOn.mpr ((hF.analyticOnNhd hU).contDiffOn hU.uniqueDiffOn)
+  have hcomp :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (F ∘ ((↑) : ℍ → ℂ)) (SpecialPeriods.Triangle.rightReflection '' S) :=
+    hFM.comp UpperHalfPlane.contMDiff_coe.contMDiffOn (fun z hz => ⟨z, hz, rfl⟩)
+  apply hcomp.congr
+  intro z _
+  change
+    conj (f (SpecialPeriods.Triangle.rightReflection z)) =
+      conj (f (UpperHalfPlane.ofComplex (-1 - conj (z : ℂ))))
+  rw [← SpecialPeriods.Triangle.rightReflection_coe, UpperHalfPlane.ofComplex_apply]
+
+private theorem TriangleUniformizationGluing.BoundaryMap.upstairsMap_holomorphicOn_half
+    (D : TriangleUniformizationGluing.BoundaryMap)
+    (hd : ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (D : ℍ → ℂ) SpecialPeriods.Triangle.halfFordInterior) :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω D.upstairsMap SpecialPeriods.Triangle.halfFordInterior := by
+  apply hd.congr
+  intro z hz
+  have hclosed := SpecialPeriods.Triangle.halfFordInterior_subset_halfFordRegion hz
+  rw [D.upstairsMap_of_mem hclosed.1, D.foldedFordMap_of_left hclosed.2]
+
+private theorem TriangleUniformizationGluing.BoundaryMap.upstairsMap_holomorphicOn_reflected_half
+    (D : TriangleUniformizationGluing.BoundaryMap)
+    (hd : ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (D : ℍ → ℂ) SpecialPeriods.Triangle.halfFordInterior) :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω D.upstairsMap
+      (SpecialPeriods.Triangle.rightReflection '' SpecialPeriods.Triangle.halfFordInterior) := by
+  have href :=
+    TriangleUniformizationGluing.contMDiffOn_conj_rightReflection
+      SpecialPeriods.Triangle.halfFordInterior_isOpen hd
+  apply href.congr
+  rintro z ⟨w, hw, rfl⟩
+  have hclosed := SpecialPeriods.Triangle.halfFordInterior_subset_halfFordRegion hw
+  rw [D.upstairsMap_of_mem (SpecialPeriods.Triangle.rightReflection_mapsTo_fordRegion hclosed.1)]
+  exact D.foldedFordMap_eqOn_right ⟨w, hclosed, rfl⟩
+
+private theorem TriangleUniformizationGluing.BoundaryMap.upstairsMap_holomorphicOn_fold
+    (D : TriangleUniformizationGluing.BoundaryMap) (b : Bool)
+    (hd : ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (D : ℍ → ℂ) SpecialPeriods.Triangle.halfFordInterior) :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω D.upstairsMap
+      (SpecialPeriods.Triangle.halfFold b '' SpecialPeriods.Triangle.halfFordInterior) := by
+  cases b
+  · change ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω D.upstairsMap (id '' SpecialPeriods.Triangle.halfFordInterior)
+    rw [Set.image_id]
+    exact D.upstairsMap_holomorphicOn_half hd
+  · exact D.upstairsMap_holomorphicOn_reflected_half hd
+
+private theorem TriangleUniformizationGluing.BoundaryMap.upstairsMap_holomorphicOn_tile
+    (D : TriangleUniformizationGluing.BoundaryMap) (i : SpecialPeriods.TriangleGroup × Bool)
+    (hd : ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (D : ℍ → ℂ) SpecialPeriods.Triangle.halfFordInterior) :
+    ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω D.upstairsMap (SpecialPeriods.Triangle.halfTriangleOpenTile i) := by
+  rw [SpecialPeriods.Triangle.halfTriangleOpenTile_eq]
+  have hm :
+    Set.MapsTo (SpecialPeriods.triangleGeometricRepresentation i.1⁻¹)
+      (SpecialPeriods.triangleGeometricRepresentation i.1 ''
+        (SpecialPeriods.Triangle.halfFold i.2 '' SpecialPeriods.Triangle.halfFordInterior))
+      (SpecialPeriods.Triangle.halfFold i.2 '' SpecialPeriods.Triangle.halfFordInterior) := by
+    rintro z ⟨w, hw, rfl⟩
+    rw [map_inv]
+    change
+      (SpecialPeriods.triangleGeometricRepresentation i.1).symm
+          (SpecialPeriods.triangleGeometricRepresentation i.1 w) ∈
+        _
+    rw [(SpecialPeriods.triangleGeometricRepresentation i.1).symm_apply_apply w]
+    exact hw
+  have hc :=
+    (D.upstairsMap_holomorphicOn_fold i.2 hd).comp
+      (SpecialPeriods.triangleGeometricRepresentation_holomorphic i.1⁻¹).contMDiffOn hm
+  apply hc.congr
+  intro z _
+  exact (D.upstairsMap_smul i.1⁻¹ z).symm
+
+private theorem TriangleUniformizationGluing.BoundaryMap.upstairsMap_holomorphic
+    (D : TriangleUniformizationGluing.BoundaryMap)
+    (hd : ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (D : ℍ → ℂ) SpecialPeriods.Triangle.halfFordInterior) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω D.upstairsMap :=
+  TriangleUniformizationGluing.contMDiff_of_continuous_of_halfTriangleOpenTiles
+    D.upstairsMap_continuous (fun i => D.upstairsMap_holomorphicOn_tile i hd)
+
+private theorem TriangleUniformizationGluing.SignedHalfPlaneMap.upstairsMap_holomorphic
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap)
+    (hd : ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (D.toFun : ℍ → ℂ) SpecialPeriods.Triangle.halfFordInterior) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω D.upstairsMap :=
+  D.toBoundaryMap.upstairsMap_holomorphic hd
+
+private theorem
+  TriangleUniformizationGluing.openPartialHomeomorph_symm_tendsto_punctured_mo1973_19946
+    {X Y : Type*} [TopologicalSpace X] [TopologicalSpace Y] (e : OpenPartialHomeomorph X Y)
+    {x : X} (hx : x ∈ e.source) : Filter.Tendsto e.symm (𝓝[≠] (e x)) (𝓝[≠] x) := by
+  refine tendsto_nhdsWithin_iff.mpr ⟨(e.tendsto_symm hx).mono_left nhdsWithin_le_nhds, ?_⟩
+  simpa only [Set.mem_compl_iff, Set.mem_singleton_iff, e.left_inv hx] using
+    e.symm.eventually_ne_nhdsWithin (e.map_source hx)
+
+private theorem TriangleUniformizationGluing.contMDiffAt_of_continuousAt_of_punctured {M N : Type*}
+    [TopologicalSpace M] [ChartedSpace ℂ M] [IsManifold 𝓘(ℂ) ω M] [TopologicalSpace N]
+    [ChartedSpace ℂ N] [IsManifold 𝓘(ℂ) ω N] {f : M → N} {x : M} (hf : ContinuousAt f x)
+    (hd : ∀ᶠ z in 𝓝[≠] x, ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω f z) : ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω f x := by
+  let e := chartAt ℂ x
+  let e' := chartAt ℂ (f x)
+  let F : ℂ → ℂ := e' ∘ f ∘ e.symm
+  have hxe : x ∈ e.source := ChartedSpace.mem_chart_source x
+  have hye : f x ∈ e'.source := ChartedSpace.mem_chart_source (f x)
+  have hcF : ContinuousAt F (e x) := by
+    have hcomposed : Filter.Tendsto F (𝓝 (e x)) (𝓝 (e' (f x))) :=
+      (e'.continuousAt hye).tendsto.comp (hf.tendsto.comp (e.tendsto_symm hxe))
+    simpa only [ContinuousAt, F, Function.comp_apply, e.left_inv hxe] using hcomposed
+  have hdomain : ∀ᶠ z in 𝓝 (e x), z ∈ e.target := e.open_target.mem_nhds (e.map_source hxe)
+  have htarget : ∀ᶠ z in 𝓝 (e x), f (e.symm z) ∈ e'.source :=
+    (hf.tendsto.comp (e.tendsto_symm hxe)).eventually (e'.open_source.mem_nhds hye)
+  have hdiff : ∀ᶠ z in 𝓝[≠] (e x), DifferentiableAt ℂ F z := by
+    filter_upwards [(openPartialHomeomorph_symm_tendsto_punctured_mo1973_19946 e hxe).eventually
+        hd,
+      eventually_nhdsWithin_of_eventually_nhds hdomain,
+      eventually_nhdsWithin_of_eventually_nhds htarget] with z hz hzDomain hzTarget
+    have hcoords : ContDiffAt ℂ ω F (e (e.symm z)) := by
+      have h :=
+        (contMDiffAt_iff_of_mem_source (I := 𝓘(ℂ)) (I' := 𝓘(ℂ)) (x := x) (y := f x)
+              (e.map_target hzDomain) hzTarget).mp
+          hz
+      simpa only [e, e', F, mfld_simps, contDiffWithinAt_univ] using h.2
+    rw [e.right_inv hzDomain] at hcoords
+    exact hcoords.differentiableAt (by simp)
+  have ha := Complex.analyticAt_of_differentiable_on_punctured_nhds_of_continuousAt hdiff hcF
+  apply contMDiffAt_iff.mpr
+  refine ⟨hf, ?_⟩
+  have hsm : ContDiffAt ℂ ω F (e x) := ha.contDiffAt
+  simpa only [e, e', F, mfld_simps] using hsm.contDiffWithinAt (s := Set.univ)
+
+private theorem TriangleUniformizationGluing.contMDiff_of_continuous_of_finite {M N : Type*}
+    [TopologicalSpace M] [ChartedSpace ℂ M] [IsManifold 𝓘(ℂ) ω M] [TopologicalSpace N]
+    [ChartedSpace ℂ N] [IsManifold 𝓘(ℂ) ω N] {f : M → N} {S : Set M} (hf : Continuous f)
+    (hS : S.Finite) (hd : ∀ z ∉ S, ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω f z) : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω f := by
+  have : T1Space M := ChartedSpace.t1Space ℂ M
+  intro x
+  apply contMDiffAt_of_continuousAt_of_punctured hf.continuousAt
+  have hclosed : IsClosed (S \ { x }) := (hS.subset Set.sdiff_subset).isClosed
+  have haway : (S \ { x })ᶜ ∈ 𝓝 x := hclosed.isOpen_compl.mem_nhds (by simp)
+  filter_upwards [eventually_nhdsWithin_of_eventually_nhds haway, self_mem_nhdsWithin] with z hz
+    hzx
+  exact hd z (fun hzS => hz ⟨hzS, hzx⟩)
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+private theorem TriangleUniformizationGluing.instIsManifold1 :
+    IsManifold 𝓘(ℂ) ω SpecialPeriods.TriangleOrbitSpace :=
+  SpecialPeriods.triangleOrbit_isManifold
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+attribute [local instance] TriangleUniformizationGluing.instIsManifold1 in
+private theorem TriangleUniformizationGluing.BoundaryMap.quotientMap_holomorphicAt_of_not_elliptic
+    (D : TriangleUniformizationGluing.BoundaryMap) (hup : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω D.upstairsMap)
+    {q : SpecialPeriods.TriangleOrbitSpace} (h₁ : q ≠ SpecialPeriods.triangleOrbitCenterOne)
+    (h₂ : q ≠ SpecialPeriods.triangleOrbitCenterTwo) : ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω D.quotientMap q := by
+  obtain ⟨z, rfl⟩ := SpecialPeriods.triangleOrbitProjection_surjective q
+  have hp := SpecialPeriods.triangleOrbitProjection_isLocalDiffeomorphAt_of_not_elliptic h₁ h₂
+  have h :=
+    hup.contMDiffAt.comp (SpecialPeriods.triangleOrbitProjection z) hp.localInverse_contMDiffAt
+  apply h.congr_of_eventuallyEq
+  filter_upwards [hp.localInverse_eventuallyEq_right] with y hy
+  change
+    D.quotientMap y = D.quotientMap (SpecialPeriods.triangleOrbitProjection (hp.localInverse y))
+  rw [show SpecialPeriods.triangleOrbitProjection (hp.localInverse y) = y from hy]
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+attribute [local instance] TriangleUniformizationGluing.instIsManifold1 in
+private theorem TriangleUniformizationGluing.BoundaryMap.quotientMap_holomorphic
+    (D : TriangleUniformizationGluing.BoundaryMap) (hup : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω D.upstairsMap) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω D.quotientMap := by
+  apply
+    TriangleUniformizationGluing.contMDiff_of_continuous_of_finite D.quotientMap_continuous
+      ((Set.finite_singleton SpecialPeriods.triangleOrbitCenterTwo).insert
+        SpecialPeriods.triangleOrbitCenterOne)
+  intro q hq
+  simp only [Set.mem_insert_iff, Set.mem_singleton_iff, not_or] at hq
+  exact D.quotientMap_holomorphicAt_of_not_elliptic hup hq.1 hq.2
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+attribute [local instance] TriangleUniformizationGluing.instIsManifold1 in
+private theorem TriangleUniformizationGluing.SignedHalfPlaneMap.quotientMap_holomorphic
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap)
+    (hup : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω D.upstairsMap) : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω D.quotientMap :=
+  D.toBoundaryMap.quotientMap_holomorphic hup
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace in
+attribute [local instance] TriangleUniformizationGluing.instIsManifold1 in
+private theorem TriangleUniformizationGluing.SignedHalfPlaneMap.quotientHomeomorph_holomorphic
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap)
+    (hlocal : IsProperMap (fun z : SpecialPeriods.Triangle.halfFordRegion => D.toFun z))
+    (hup : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω D.upstairsMap) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (D.quotientHomeomorph hlocal) :=
+  D.quotientMap_holomorphic hup
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem TriangleUniformizationGluing.instIsManifold2 :
+    IsManifold 𝓘(ℂ) ω SpecialPeriods.TriangleCompactifiedOrbitSpace :=
+  SpecialPeriods.triangleCompactified_isManifold
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] TriangleUniformizationGluing.instIsManifold2 in
+private theorem
+  TriangleUniformizationGluing.SignedHalfPlaneMap.compactifiedHomeomorph_holomorphicAt_of_ne_cusp
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap)
+    (hlocal : IsProperMap (fun z : SpecialPeriods.Triangle.halfFordRegion => D.toFun z))
+    (hq : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω D.quotientMap) {p : SpecialPeriods.TriangleCompactifiedOrbitSpace}
+    (hp : p ≠ SpecialPeriods.triangleCuspPoint) :
+    ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (D.compactifiedHomeomorph hlocal) p := by
+  obtain ⟨q, rfl⟩ := OnePoint.ne_infty_iff_exists.mp hp
+  have hfinite : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω ((↑) : ℂ → RiemannSphere) :=
+    RiemannSphere.standardCharts.affineMap_holomorphic Bool.false
+  have hcomp :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω
+      ((D.compactifiedHomeomorph hlocal) ∘ SpecialPeriods.triangleOpenInclusion) := by
+    simpa only [Function.comp_def, D.compactifiedHomeomorph_openInclusion hlocal] using
+      hfinite.comp hq
+  have hi := SpecialPeriods.triangleOpenInclusion_isLocalDiffeomorph q
+  have h :=
+    hcomp.contMDiffAt.comp (SpecialPeriods.triangleOpenInclusion q) hi.localInverse_contMDiffAt
+  apply h.congr_of_eventuallyEq
+  filter_upwards [hi.localInverse_eventuallyEq_right] with z hz
+  change
+    D.compactifiedHomeomorph hlocal z =
+      D.compactifiedHomeomorph hlocal (SpecialPeriods.triangleOpenInclusion (hi.localInverse z))
+  rw [show SpecialPeriods.triangleOpenInclusion (hi.localInverse z) = z from hz]
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] TriangleUniformizationGluing.instIsManifold2 in
+private theorem TriangleUniformizationGluing.SignedHalfPlaneMap.compactifiedHomeomorph_holomorphic
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap)
+    (hlocal : IsProperMap (fun z : SpecialPeriods.Triangle.halfFordRegion => D.toFun z))
+    (hup : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω D.upstairsMap) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω (D.compactifiedHomeomorph hlocal) := by
+  apply
+    TriangleUniformizationGluing.contMDiff_of_continuous_of_finite
+      (D.compactifiedHomeomorph hlocal).continuous
+      (Set.finite_singleton SpecialPeriods.triangleCuspPoint)
+  intro p hp
+  exact
+    D.compactifiedHomeomorph_holomorphicAt_of_ne_cusp hlocal (D.quotientMap_holomorphic hup)
+      (by simpa only [Set.mem_singleton_iff] using hp)
+
+private theorem TriangleUniformizationGluing.eventually_deriv_ne_zero_of_differentiableOn
+    (e : OpenPartialHomeomorph ℂ ℂ) (he : DifferentiableOn ℂ e e.source) {a : ℂ}
+    (ha : a ∈ e.source) : ∀ᶠ z in 𝓝[≠] a, deriv e z ≠ 0 := by
+  have hda : AnalyticAt ℂ (deriv e) a := (he.analyticAt (e.open_source.mem_nhds ha)).deriv
+  rcases hda.eventually_eq_zero_or_eventually_ne_zero with hzero | hnonzero
+  · exfalso
+    have hnear : ∀ᶠ z in 𝓝 a, z ∈ e.source ∧ deriv e z = 0 := by
+      filter_upwards [e.open_source.mem_nhds ha, hzero] with z hz hdz
+      exact ⟨hz, hdz⟩
+    obtain ⟨r, hr, hball⟩ := Metric.mem_nhds_iff.mp hnear
+    have hballSource : Metric.ball a r ⊆ e.source := fun z hz => (hball hz).1
+    have hconstant : ∀ z ∈ Metric.ball a r, e z = e a := by
+      intro z hz
+      exact
+        Metric.isOpen_ball.is_const_of_deriv_eq_zero Metric.isPreconnected_ball
+          (he.mono hballSource) (fun w hw => (hball hw).2) hz (Metric.mem_ball_self hr)
+    have hballNhds : ∀ᶠ z in 𝓝 a, z ∈ Metric.ball a r := Metric.ball_mem_nhds a hr
+    have hballPunctured : ∀ᶠ z in 𝓝[≠] a, z ∈ Metric.ball a r :=
+      hballNhds.filter_mono nhdsWithin_le_nhds
+    obtain ⟨z, hz, hza⟩ :=
+      (hballPunctured.and (self_mem_nhdsWithin : ∀ᶠ z in 𝓝[≠] a, z ≠ a)).exists
+    exact hza (e.injOn (hballSource hz) ha (hconstant z hz))
+  · exact hnonzero
+
+private theorem TriangleUniformizationGluing.differentiableOn_symm_of_differentiableOn
+    (e : OpenPartialHomeomorph ℂ ℂ) (he : DifferentiableOn ℂ e e.source) :
+    DifferentiableOn ℂ e.symm e.target := by
+  intro w hw
+  apply DifferentiableAt.differentiableWithinAt
+  apply AnalyticAt.differentiableAt
+  apply Complex.analyticAt_of_differentiable_on_punctured_nhds_of_continuousAt
+  · have hnonzero := eventually_deriv_ne_zero_of_differentiableOn e he (e.map_target hw)
+    rw [eventually_nhdsWithin_iff] at hnonzero
+    have hnear := (e.continuousAt_symm hw).tendsto.eventually hnonzero
+    rw [eventually_nhdsWithin_iff]
+    filter_upwards [e.open_target.mem_nhds hw, hnear] with z hz hdz hzw
+    have hinvNe : e.symm z ≠ e.symm w := fun h => hzw (e.symm.injOn hz hw h)
+    exact
+      (e.hasDerivAt_symm hz (hdz hinvNe)
+          (he.hasDerivAt (e.open_source.mem_nhds (e.map_target hz)))).differentiableAt
+  · exact e.continuousAt_symm hw
+
+public
+theorem TriangleUniformizationGluing.contMDiff_symm_of_contMDiff {M N : Type*}
+    [TopologicalSpace M] [TopologicalSpace N] [ChartedSpace ℂ M] [ChartedSpace ℂ N]
+    [IsManifold 𝓘(ℂ) ω M] [IsManifold 𝓘(ℂ) ω N] (e : M ≃ₜ N) (he : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω e) :
+    ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω e.symm := by
+  intro y
+  let c : OpenPartialHomeomorph ℂ ℂ :=
+    ((chartAt ℂ (e.symm y)).symm.trans e.toOpenPartialHomeomorph).trans (chartAt ℂ y)
+  have hc : DifferentiableOn ℂ c c.source := by
+    intro z hz
+    have hz₁ : z ∈ (chartAt ℂ (e.symm y)).target := hz.1.1
+    have hz₂ : e ((chartAt ℂ (e.symm y)).symm z) ∈ (chartAt ℂ y).source := hz.2
+    have h₁ : ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (chartAt ℂ (e.symm y)).symm z :=
+      contMDiffAt_symm_of_mem_maximalAtlas (IsManifold.chart_mem_maximalAtlas (e.symm y)) hz₁
+    have h₂ : ContMDiffAt 𝓘(ℂ) 𝓘(ℂ) ω (chartAt ℂ y) (e ((chartAt ℂ (e.symm y)).symm z)) :=
+      contMDiffAt_of_mem_maximalAtlas (IsManifold.chart_mem_maximalAtlas y) hz₂
+    exact
+      ((h₂.comp z ((he _).comp z h₁)).contDiffAt.differentiableAt
+          (by simp)).differentiableWithinAt
+  have hy : (chartAt ℂ y) y ∈ c.target := by
+    refine ⟨(chartAt ℂ y).map_source (mem_chart_source ℂ y), ?_⟩
+    change
+      (chartAt ℂ y).symm ((chartAt ℂ y) y) ∈ (Set.univ : Set N) ∧
+        e.symm ((chartAt ℂ y).symm ((chartAt ℂ y) y)) ∈ (chartAt ℂ (e.symm y)).source
+    rw [(chartAt ℂ y).left_inv (mem_chart_source ℂ y)]
+    exact ⟨Set.mem_univ _, mem_chart_source ℂ _⟩
+  have hinv : ContDiffAt ℂ ω c.symm ((chartAt ℂ y) y) :=
+    ((differentiableOn_symm_of_differentiableOn c hc).contDiffOn c.open_target).contDiffAt
+      (c.open_target.mem_nhds hy)
+  change
+    ContDiffAt ℂ ω ((chartAt ℂ (e.symm y)) ∘ e.symm ∘ (chartAt ℂ y).symm)
+      ((chartAt ℂ y) y) at hinv
+  apply contMDiffAt_iff.mpr
+  refine ⟨e.symm.continuous.continuousAt, ?_⟩
+  simpa only [extChartAt_coe, extChartAt_coe_symm, modelWithCornersSelf_coe,
+    modelWithCornersSelf_coe_symm, Function.id_comp, Function.comp_id, Set.range_id,
+    contDiffWithinAt_univ] using hinv
+
+private def TriangleUniformizationGluing.biholomorphOfHomeomorph {M N : Type*} [TopologicalSpace M]
+    [TopologicalSpace N] [ChartedSpace ℂ M] [ChartedSpace ℂ N] [IsManifold 𝓘(ℂ) ω M]
+    [IsManifold 𝓘(ℂ) ω N] (e : M ≃ₜ N) (he : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω e) :
+    Diffeomorph 𝓘(ℂ) 𝓘(ℂ) M N ω where
+  toEquiv := e.toEquiv
+  contMDiff_toFun := he
+  contMDiff_invFun := contMDiff_symm_of_contMDiff e he
+
+@[simp]
+private theorem TriangleUniformizationGluing.biholomorphOfHomeomorph_toHomeomorph {M N : Type*}
+    [TopologicalSpace M] [TopologicalSpace N] [ChartedSpace ℂ M] [ChartedSpace ℂ N]
+    [IsManifold 𝓘(ℂ) ω M] [IsManifold 𝓘(ℂ) ω N] (e : M ≃ₜ N) (he : ContMDiff 𝓘(ℂ) 𝓘(ℂ) ω e) :
+    (biholomorphOfHomeomorph e he).toHomeomorph = e := by
+  ext x
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem TriangleUniformizationGluing.instIsManifold3 :
+    IsManifold 𝓘(ℂ) ω SpecialPeriods.TriangleOrbitSpace :=
+  SpecialPeriods.triangleOrbit_isManifold
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] TriangleUniformizationGluing.instIsManifold3 in
+private theorem TriangleUniformizationGluing.instIsManifold4 :
+    IsManifold 𝓘(ℂ) ω SpecialPeriods.TriangleCompactifiedOrbitSpace :=
+  SpecialPeriods.triangleCompactified_isManifold
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] TriangleUniformizationGluing.instIsManifold3
+    TriangleUniformizationGluing.instIsManifold4 in
+private def TriangleUniformizationGluing.SignedHalfPlaneMap.quotientBiholomorph
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap)
+    (hlocal : IsProperMap (fun z : SpecialPeriods.Triangle.halfFordRegion => D.toFun z))
+    (hd : ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (D.toFun : ℍ → ℂ) SpecialPeriods.Triangle.halfFordInterior) :
+    Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleOrbitSpace ℂ ω :=
+  TriangleUniformizationGluing.biholomorphOfHomeomorph (D.quotientHomeomorph hlocal)
+    (D.quotientHomeomorph_holomorphic hlocal (D.upstairsMap_holomorphic hd))
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] TriangleUniformizationGluing.instIsManifold3
+    TriangleUniformizationGluing.instIsManifold4 in
+private def TriangleUniformizationGluing.SignedHalfPlaneMap.compactifiedBiholomorph
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap)
+    (hlocal : IsProperMap (fun z : SpecialPeriods.Triangle.halfFordRegion => D.toFun z))
+    (hd : ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (D.toFun : ℍ → ℂ) SpecialPeriods.Triangle.halfFordInterior) :
+    Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω :=
+  TriangleUniformizationGluing.biholomorphOfHomeomorph (D.compactifiedHomeomorph hlocal)
+    (D.compactifiedHomeomorph_holomorphic hlocal (D.upstairsMap_holomorphic hd))
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+attribute [local instance] TriangleUniformizationGluing.instIsManifold3
+    TriangleUniformizationGluing.instIsManifold4 in
+@[simp]
+private theorem TriangleUniformizationGluing.SignedHalfPlaneMap.quotientBiholomorph_toHomeomorph
+    (D : TriangleUniformizationGluing.SignedHalfPlaneMap)
+    (hlocal : IsProperMap (fun z : SpecialPeriods.Triangle.halfFordRegion => D.toFun z))
+    (hd : ContMDiffOn 𝓘(ℂ) 𝓘(ℂ) ω (D.toFun : ℍ → ℂ) SpecialPeriods.Triangle.halfFordInterior) :
+    (D.quotientBiholomorph hlocal hd).toHomeomorph = D.quotientHomeomorph hlocal :=
+  TriangleUniformizationGluing.biholomorphOfHomeomorph_toHomeomorph _ _
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Triangle.trianglePlaneUniformization :
+    Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleOrbitSpace ℂ ω :=
+  RiemannMapping.triangleSignedHalfPlaneMap.quotientBiholomorph
+    RiemannMapping.triangleSignedHalfPlaneMap_isProperMap
+    RiemannMapping.triangleSignedHalfPlaneMap_holomorphicOn
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.Triangle.triangleSphereUniformization :
+    Diffeomorph 𝓘(ℂ) 𝓘(ℂ) SpecialPeriods.TriangleCompactifiedOrbitSpace RiemannSphere ω :=
+  RiemannMapping.triangleSignedHalfPlaneMap.compactifiedBiholomorph
+    RiemannMapping.triangleSignedHalfPlaneMap_isProperMap
+    RiemannMapping.triangleSignedHalfPlaneMap_holomorphicOn
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Triangle.trianglePlaneUniformization_toHomeomorph :
+    trianglePlaneUniformization.toHomeomorph = trianglePlaneUniformizationHomeomorph :=
+  RiemannMapping.triangleSignedHalfPlaneMap.quotientBiholomorph_toHomeomorph
+    RiemannMapping.triangleSignedHalfPlaneMap_isProperMap
+    RiemannMapping.triangleSignedHalfPlaneMap_holomorphicOn
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Triangle.triangleSphereUniformization_cusp :
+    triangleSphereUniformization SpecialPeriods.triangleCuspPoint =
+      ((OnePoint.infty) : RiemannSphere) :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Triangle.triangleSphereUniformization_openInclusion
+    (q : SpecialPeriods.TriangleOrbitSpace) :
+    triangleSphereUniformization (SpecialPeriods.triangleOpenInclusion q) =
+      ((trianglePlaneUniformization q : ℂ) : RiemannSphere) :=
+  rfl
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Triangle.trianglePlaneUniformization_centerOne :
+    trianglePlaneUniformization SpecialPeriods.triangleOrbitCenterOne = 0 :=
+  trianglePlaneUniformizationHomeomorph_centerOne
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+@[simp]
+private theorem SpecialPeriods.Triangle.trianglePlaneUniformization_centerTwo :
+    trianglePlaneUniformization SpecialPeriods.triangleOrbitCenterTwo = 1 :=
+  trianglePlaneUniformizationHomeomorph_centerTwo
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Triangle.triangleSphereUniformization_centerOne :
+    triangleSphereUniformization
+        (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterOne) =
+      ((0 : ℂ) : RiemannSphere) :=
+  triangleSphereUniformizationHomeomorph_centerOne
+
+attribute [local instance] SpecialPeriods.triangleOrbitChartedSpace
+    SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.Triangle.triangleSphereUniformization_centerTwo :
+    triangleSphereUniformization
+        (SpecialPeriods.triangleOpenInclusion SpecialPeriods.triangleOrbitCenterTwo) =
+      ((1 : ℂ) : RiemannSphere) :=
+  triangleSphereUniformizationHomeomorph_centerTwo
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.specialPeriodMap : HolomorphicPeriodMap ℂ ℍ :=
+  Construction.periodMapOfSphere Triangle.triangleSphereUniformization
+    Triangle.triangleSphereUniformization_cusp Triangle.triangleSphereUniformization_centerOne
+    Triangle.triangleSphereUniformization_centerTwo
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.specialPeriodMap_generator₁ (z : ℍ) :
+    specialPeriodMap.point (Triangle.generatorOneSL • z) = (specialPeriodMap.point z).step₁ :=
+  Construction.periodMapOfSphere_generator₁ Triangle.triangleSphereUniformization
+    Triangle.triangleSphereUniformization_cusp Triangle.triangleSphereUniformization_centerOne
+    Triangle.triangleSphereUniformization_centerTwo z
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private theorem SpecialPeriods.specialPeriodMap_generator₂ (z : ℍ) :
+    specialPeriodMap.point (Triangle.generatorTwoSL • z) = (specialPeriodMap.point z).step₂ :=
+  Construction.periodMapOfSphere_generator₂ Triangle.triangleSphereUniformization
+    Triangle.triangleSphereUniformization_cusp Triangle.triangleSphereUniformization_centerOne
+    Triangle.triangleSphereUniformization_centerTwo z
+
+attribute [local instance] SpecialPeriods.triangleCompactifiedChartedSpace in
+private def SpecialPeriods.specialCuspData : CuspFamily.Data :=
+  Construction.cuspDataOfSphere Triangle.triangleSphereUniformization
+    Triangle.triangleSphereUniformization_cusp Triangle.triangleSphereUniformization_centerOne
+    Triangle.triangleSphereUniformization_centerTwo
+
+private theorem SpecialPeriods.triangleDualRepresentation_cusp_zpow_matrix (k : ℤ) :
+    (triangleDualRepresentation (triangleCuspGenerator ^ k) : LatticeMatrix) =
+      CuspFamily.cuspIntegralMatrix k := by
+  let C : Multiplicative ℤ →* LatticeMatrix :=
+    { toFun := fun n => CuspFamily.cuspIntegralMatrix n.toAdd
+      map_one' := CuspFamily.cuspIntegralMatrix_zero
+      map_mul' := fun m n => CuspFamily.cuspIntegralMatrix_add m.toAdd n.toAdd }
+  let R : Multiplicative ℤ →* LatticeMatrix :=
+    { toFun := fun n =>
+        (triangleDualRepresentation (triangleCuspGenerator ^ n.toAdd) : LatticeMatrix)
+      map_one' := by simp
+      map_mul' := by
+        intro m n
+        change
+          (triangleDualRepresentation (triangleCuspGenerator ^ (m.toAdd + n.toAdd)) :
+              LatticeMatrix) =
+            _
+        rw [_root_.zpow_add, map_mul, Matrix.SpecialLinearGroup.coe_mul] }
+  have he : R = C := by
+    apply MonoidHom.ext_mint
+    change
+      (triangleDualRepresentation (triangleCuspGenerator ^ (1 : ℤ)) : LatticeMatrix) =
+        CuspFamily.cuspIntegralMatrix 1
+    rw [zpow_one, CuspFamily.cuspIntegralMatrix_one, triangleDualRepresentation_cusp_matrix]
+  exact DFunLike.congr_fun he (Multiplicative.ofAdd k)
+
+private theorem SpecialPeriods.triangleRealEquiv_cusp_zpow (k : ℤ) :
+    triangleRealEquiv (triangleCuspGenerator ^ k) = CuspFamily.cuspRealEquiv k := by
+  apply LinearEquiv.ext
+  intro x
+  rw [triangleRealEquiv_apply, triangleDualRepresentation_cusp_zpow_matrix,
+    CuspFamily.cuspRealEquiv_apply]
+
+private theorem SpecialPeriods.triangleTorusHomeomorph_cusp_zpow (k : ℤ) :
+    triangleTorusHomeomorph (triangleCuspGenerator ^ k) = CuspFamily.cuspTorusHomeomorph k := by
+  apply Homeomorph.ext
+  intro x
+  obtain ⟨v, rfl⟩ := standardLattice.mkQ_surjective x
+  rw [triangleTorusHomeomorph_mkQ, CuspFamily.cuspTorusHomeomorph_mkQ,
+    triangleRealEquiv_cusp_zpow]
+
+end Mathoverflow1973
+
+end
diff --git a/LeanPool/projects.yml b/LeanPool/projects.yml
index 563c654dd..5ec72c79e 100644
--- a/LeanPool/projects.yml
+++ b/LeanPool/projects.yml
@@ -7255,3 +7255,56 @@ projects:
       - "11T06"
       - "11T71"
       - "94A60"
+  - slug: hopf-problem
+    title: A complex structure on the six-sphere
+    summary: >-
+      Formalizes Levent Alpöge's construction of a complex-analytic atlas on
+      the standard six-sphere. The development builds a compact complex
+      threefold from torus fibrations with cusp and elliptic fibres, computes
+      its homology and fundamental group, recognizes its underlying smooth
+      manifold as the six-sphere, and transports the complex atlas across the
+      resulting homeomorphism. It adapts Lean developments by Yury G.
+      Kudryashov and Sebastian Kumar, together with the statement from the
+      Formal Conjectures Authors.
+    branch: complex geometry and differential topology
+    entry_module: LeanPool.HopfProblem
+    authors:
+      - Boris Alexeev
+      - Yury G. Kudryashov
+      - Sebastian Kumar
+      - The Formal Conjectures Authors
+    source:
+      title: "HopfProblem: formalization of Alpöge's six-sphere construction"
+      authors:
+        - Boris Alexeev
+      url: https://github.com/plby/HopfProblem/tree/9ac8a456b526527837d7082ff775213ca8bc9809
+      github_repo: plby/HopfProblem
+      commit: 9ac8a456b526527837d7082ff775213ca8bc9809
+    license: Apache-2.0
+    status: verified
+    provenance: AI
+    main_declarations:
+      - Mathoverflow1973.mathoverflow_1973
+    main_results:
+      - declaration: Mathoverflow1973.SixSphereComplexAtlas.exists_complex_analytic_atlas
+        informal: >-
+          The standard unit six-sphere admits a complex three-dimensional
+          charted-space structure making it a complex-analytic manifold.
+      - declaration: Mathoverflow1973.SixSphereComplexAtlas.exists_complex_atlas
+        informal: >-
+          The standard unit six-sphere admits a complex three-dimensional
+          charted-space structure making it a continuously differentiable
+          complex manifold.
+      - declaration: Mathoverflow1973.mathoverflow_1973
+        informal: >-
+          The formalized statement of MathOverflow question 1973: the standard
+          six-sphere carries a complex three-dimensional manifold atlas.
+    tags:
+      - complex-geometry
+      - differential-topology
+      - complex-manifolds
+      - six-sphere
+      - torus-fibrations
+    msc:
+      - "32Q55"
+      - "57R15"